Branch data Line data Source code
1 : : !!****m* ABINIT/m_xgTools
2 : : !! NAME
3 : : !! m_xgTools
4 : : !!
5 : : !! FUNCTION
6 : : !! This is a module to manage and help developer with 2D arrays for low level routines.
7 : : !! Particularly, it manages memory for allocations and deallocations (see xg_routines),
8 : : !! It handles MPI, complex and real values (*8 kind only) automatically.
9 : : !! It is also possible to build sub-block of an array and work on it very easily (see xgBlock_routines)
10 : : !! Several routines are also available for performing blas/lapack which again
11 : : !! manage the type and MPI (and openmp if needed)
12 : : !! Almost all routines are timed by abinit timers
13 : : !! This is a starting point and has to be improved/developed
14 : : !! An example of how to use those types and routines can be found in
15 : : !! 30_diago/m_lobpcg2.F90. This is a full rewrite of LOBPCG algorithm which uses
16 : : !! only these types to perfom calculations.
17 : : !!
18 : : !! COPYRIGHT
19 : : !! Copyright (C) 2016-2026 ABINIT group (J. Bieder, MS, L. Baguet, IML)
20 : : !! This file is distributed under the terms of the
21 : : !! GNU General Public License, see ~abinit/COPYING
22 : : !! or http://www.gnu.org/copyleft/gpl.txt .
23 : : !!
24 : : !! NOTES
25 : : !!
26 : : !! SOURCE
27 : :
28 : : #if defined HAVE_CONFIG_H
29 : : #include "config.h"
30 : : #endif
31 : :
32 : : #include "abi_common.h"
33 : :
34 : : module m_xg
35 : :
36 : : use, intrinsic :: iso_c_binding, only: c_loc, c_double, c_double_complex, c_int32_t, c_size_t, c_ptr
37 : :
38 : : USE_MPI
39 : : use m_errors
40 : : use m_abicore
41 : : use defs_basis
42 : : use m_time, only : timab
43 : : use m_xmpi
44 : : use m_xomp
45 : : use m_gputk
46 : : use m_abi_linalg
47 : : use m_hide_blas, only : xdotc
48 : :
49 : : #if defined(HAVE_GPU)
50 : : use m_gpu_toolbox
51 : : #endif
52 : :
53 : : #if defined(HAVE_KOKKOS)
54 : : use m_xg_kokkos
55 : : #endif
56 : :
57 : : #if defined HAVE_YAKL
58 : : use gator_mod
59 : : #endif
60 : :
61 : : implicit none
62 : :
63 : : private
64 : :
65 : : integer, parameter, public :: SPACE_R = 1
66 : : integer, parameter, public :: SPACE_C = 2
67 : : integer, parameter, public :: SPACE_CR = 3
68 : :
69 : : integer, parameter, public :: SMALL2BIG = 1
70 : : integer, parameter, public :: BIG2SMALL = -1
71 : :
72 : : integer, parameter, public :: COLS2ROWS = 1
73 : : integer, parameter, public :: ROWS2COLS = -1
74 : :
75 : : integer, parameter :: tim_gemm_blas = 1670
76 : : integer, parameter :: tim_trsm = 1671
77 : : integer, parameter :: tim_potrf = 1672
78 : : integer, parameter :: tim_zero = 1673
79 : : integer, parameter :: tim_zero_im_g0 = 1674
80 : : ! integer, parameter :: tim_set = 1673
81 : : ! integer, parameter :: tim_get = 1674
82 : : integer, parameter :: tim_heev = 1675
83 : : integer, parameter :: tim_heevd = 1676
84 : : integer, parameter :: tim_hpev = 1677
85 : : integer, parameter :: tim_hpevd = 1678
86 : : integer, parameter :: tim_hegv = 1679
87 : : integer, parameter :: tim_hegvx = 1680
88 : : integer, parameter :: tim_hegvd = 1681
89 : : integer, parameter :: tim_hpgv = 1682
90 : : integer, parameter :: tim_hpgvx = 1683
91 : : integer, parameter :: tim_hpgvd = 1684
92 : : integer, parameter :: tim_copy = 1685
93 : : integer, parameter :: tim_cshift = 1686
94 : : integer, parameter :: tim_pack = 1687
95 : : integer, parameter :: tim_gemm_mpi = 1688
96 : : integer, parameter :: tim_apply_diag = 1689
97 : : integer, parameter :: tim_invertri = 1696
98 : :
99 : : integer, parameter :: tim_scale = 2000
100 : : integer, parameter :: tim_colw_dot = 2001
101 : : integer, parameter :: tim_colw_mul = 2002
102 : : integer, parameter :: tim_colw_cymax = 2003
103 : : integer, parameter :: tim_colw_div = 2004
104 : : integer, parameter :: tim_colw_norm2 = 2005
105 : : integer, parameter :: tim_saxpy = 2006
106 : : integer, parameter :: tim_minmax = 2007
107 : : integer, parameter :: tim_partialcopy = 2008
108 : : integer, parameter :: tim_gemmcyclic = 2009
109 : : integer, parameter :: tim_yxmax = 2010
110 : : integer, parameter :: tim_ymax = 2011
111 : : integer, parameter :: tim_add = 2012
112 : : integer, parameter :: tim_add_diag = 2013
113 : : integer, parameter :: tim_invert = 2014
114 : : integer, parameter :: tim_invert_sy = 2015
115 : : integer, parameter :: tim_dot = 2016
116 : :
117 : : integer, save, private :: lrwork = 0
118 : : integer, save, private :: lcwork = 0
119 : : integer, save, private :: liwork = 0
120 : : integer, allocatable, save, private :: iwork(:)
121 : : real(kind=c_double), allocatable, save, private :: rwork(:)
122 : : complex(kind=c_double_complex), allocatable, save, private :: cwork(:)
123 : :
124 : : type, public :: xgBlock_t
125 : : integer, private :: space
126 : : integer, private :: rows
127 : : integer, private :: LDim
128 : : integer, private :: cols
129 : : integer, private :: me_g0
130 : : character, public :: trans
131 : : character, public :: normal
132 : : integer, private :: spacedim_comm
133 : : integer, private :: gpu_option
134 : : real(kind=c_double) , contiguous, pointer, private :: vecR(:,:) => null()
135 : : complex(kind=c_double_complex) , contiguous, pointer, private :: vecC(:,:) => null()
136 : : end type xgBlock_t
137 : :
138 : : type, public :: xg_t
139 : : integer, private :: space
140 : : integer, private :: rows
141 : : integer, private :: cols
142 : : integer, private :: me_g0
143 : : character, public :: trans
144 : : character, public :: normal
145 : : integer, private :: spacedim_comm
146 : : !FIXME Settle this
147 : : real(kind=c_double) , contiguous, pointer, private :: vecR(:,:) => null()
148 : : complex(kind=c_double_complex) , contiguous, pointer, private :: vecC(:,:) => null()
149 : : integer, private :: gpu_option
150 : : type(xgBlock_t), public :: self
151 : : end type xg_t
152 : :
153 : : interface xgBlock_gemm
154 : : module procedure xgBlock_gemmR
155 : : module procedure xgBlock_gemmC
156 : : end interface xgBlock_gemm
157 : :
158 : : interface xgBlock_saxpy
159 : : module procedure xgBlock_saxpyR
160 : : module procedure xgBlock_saxpyC
161 : : end interface xgBlock_saxpy
162 : :
163 : : interface xgBlock_dot
164 : : module procedure xgBlock_dotC
165 : : end interface xgBlock_dot
166 : :
167 : : interface xgBlock_colwiseMul
168 : : module procedure xgBlock_colwiseMulR
169 : : module procedure xgBlock_colwiseMulC
170 : : end interface xgBlock_colwiseMul
171 : :
172 : : interface xgBlock_trsm
173 : : module procedure xgBlock_trsmR
174 : : module procedure xgBlock_trsmC
175 : : end interface xgBlock_trsm
176 : :
177 : : interface xgBlock_scale
178 : : module procedure xgBlock_scaleR
179 : : module procedure xgBlock_scaleC
180 : : end interface xgBlock_scale
181 : :
182 : : interface xgBlock_reverseMap
183 : : module procedure xgBlock_reverseMapR
184 : : module procedure xgBlock_reverseMapC
185 : : end interface xgBlock_reverseMap
186 : :
187 : : interface xgBlock_reverseMap_1d
188 : : module procedure xgBlock_reverseMap_1dR
189 : : module procedure xgBlock_reverseMap_1dC
190 : : end interface xgBlock_reverseMap_1d
191 : :
192 : : interface checkResize
193 : : module procedure checkResizeI
194 : : module procedure checkResizeR
195 : : module procedure checkResizeC
196 : : end interface checkResize
197 : :
198 : : public :: space
199 : : public :: cols
200 : : public :: rows
201 : : public :: comm
202 : : public :: gpu_option
203 : : public :: me_g0
204 : : public :: xgBlock_setComm
205 : : private :: getClocR
206 : : private :: getClocC
207 : : private :: checkResize
208 : :
209 : : public :: xg_init ! IL-10/03/25: on GPU- Contains OMP call to free/allocate memory on GPU
210 : : public :: xg_set ! LB-06/03/24: Be careful, this routine is not used (so not tested)
211 : : public :: xg_get ! LB-06/03/24: Be careful, this routine is not used (so not tested)
212 : : public :: xg_setBlock
213 : : public :: xg_free
214 : :
215 : : public :: xg_associated
216 : :
217 : : public :: xgBlock_setBlock
218 : : public :: xgBlock_set ! LB-06/03/24: Be careful, this routine is not used (so not tested)
219 : : public :: xgBlock_map ! IL-10/03/25: on GPU- Contains safe OMP call with target presence check
220 : : public :: xgBlock_map_1d
221 : : public :: xgBlock_reverseMap
222 : : public :: xgBlock_reverseMap_1d
223 : : public :: xgBlock_prefetch_async
224 : : public :: xgBlock_get ! LB-06/03/24: Be careful, this routine is not used (so not tested)
225 : : public :: xgBlock_copy ! IL-10/03/25: on GPU- Contains hidden one-way OMP calls (implicit H2D or D2H)
226 : : public :: xgBlock_colwiseSwap
227 : : public :: xgBlock_partialcopy
228 : : public :: xgBlock_permuteCols
229 : : public :: xgBlock_hermitian_pd_cond ! computes condition number of Hermitian positive definite
230 : : public :: xgBlock_spd_cond ! condition matrix for symmetric positive definite
231 : : public :: xgBlock_pack
232 : : public :: xgBlock_getSize
233 : : public :: xgBlock_get_gpu_option
234 : : public :: xgBlock_get_communicator
235 : :
236 : : public :: xgBlock_check
237 : : public :: xgBlock_check_gpu_option
238 : :
239 : : public :: xgBlock_potrf
240 : : public :: xgBlock_trsm
241 : :
242 : : public :: xgBlock_heev
243 : : public :: xgBlock_heevd
244 : :
245 : : public :: xgBlock_hpev
246 : : public :: xgBlock_hpevd
247 : :
248 : : public :: xgBlock_hegv
249 : : public :: xgBlock_hegvx
250 : : public :: xgBlock_hegvd
251 : :
252 : : public :: xgBlock_hpgv
253 : : public :: xgBlock_hpgvx
254 : : public :: xgBlock_hpgvd
255 : :
256 : : public :: xgBlock_gemm
257 : : public :: xgBlock_trmmR
258 : : public :: xgBlock_add
259 : : public :: xgBlock_cshift
260 : : public :: xgBlock_colwiseNorm2
261 : : public :: xgBlock_colwiseDotProduct
262 : : public :: xgBlock_colwiseDivision
263 : : public :: xgBlock_ymax
264 : : public :: xgBlock_yxmax
265 : : public :: xgBlock_colwiseCymax
266 : : public :: xgBlock_saxpy
267 : : public :: xgBlock_dot
268 : : public :: xgBlock_colwiseMul
269 : : public :: xgBlock_scale
270 : : public :: xgBlock_transpose
271 : : public :: xgBlock_r2c
272 : : public :: xgBlock_c2r
273 : :
274 : : public :: xgBlock_apply_diag
275 : : public :: xgBlock_add_diag
276 : :
277 : : public :: xgBlock_mpi_sum
278 : : public :: xgBlock_mpi_send
279 : : public :: xgBlock_mpi_isend
280 : : public :: xgBlock_mpi_recv
281 : : public :: xgBlock_gemm_mpi_cyclic_permutation
282 : :
283 : : public :: xgBlock_invert
284 : : public :: xgBlock_invert_sy
285 : : public :: xgBlock_invert_tri
286 : : public :: xgBlock_yxpa
287 : :
288 : : public :: xgBlock_zero
289 : : public :: xgBlock_zerotri
290 : : public :: xgBlock_zero_im_g0
291 : : public :: xgBlock_one
292 : : public :: xgBlock_ones
293 : : public :: xgBlock_diagonal
294 : : public :: xgBlock_diagonalOnly
295 : :
296 : : public :: xgBlock_colwiseRandom
297 : : public :: xgBlock_colwiseRandomGaussian
298 : : public :: xgBlock_colwiseRandomRademacher
299 : : public :: xgBlock_randomSketching
300 : :
301 : : public :: xgBlock_minmax
302 : : public :: xgBlock_average
303 : : public :: xgBlock_deviation
304 : :
305 : : public :: xgBlock_reshape
306 : : public :: xgBlock_reshape_spinor
307 : : public :: xgBlock_free_reshape
308 : : public :: xgBlock_print
309 : : public :: xgBlock_getid
310 : : public :: xgBlock_get_im_g0
311 : : public :: xgBlock_copy_from_gpu ! TODO IL-10/03/25: on GPU- Contains unsafe OMP call to copy memory from GPU
312 : : public :: xgBlock_copy_to_gpu ! TODO IL-10/03/25: on GPU- Contains unsafe OMP call to copy memory to GPU
313 : : public :: xg_finalize
314 : :
315 : : contains
316 : : !!***
317 : :
318 : : !!****f* m_xg/checkResizeI
319 : : !!
320 : : !! NAME
321 : : !! checkResizeI
322 : :
323 : 820787 : subroutine checkResizeI(array,current_dim,asked_dim)
324 : :
325 : : integer, allocatable, intent(inout) :: array(:)
326 : : integer, intent(inout) :: current_dim
327 : : integer, intent(in ) :: asked_dim
328 : :
329 [ + + ]: 820787 : if ( current_dim < asked_dim ) then
330 : 1851 : current_dim = asked_dim
331 [ + + ]: 1851 : if ( allocated(array) ) then
332 : 1194 : ABI_FREE(array)
333 : : end if
334 [ - + + - : 5553 : ABI_MALLOC(array,(asked_dim))
+ - + - -
+ - + -
+ ]
335 : : end if
336 : :
337 : 820787 : end subroutine checkResizeI
338 : : !!***
339 : :
340 : : !!****f* m_xg/checkResizeR
341 : : !!
342 : : !! NAME
343 : : !! checkResizeR
344 : :
345 : 820787 : subroutine checkResizeR(array,current_dim,asked_dim)
346 : :
347 : : double precision, allocatable, intent(inout) :: array(:)
348 : : integer, intent(inout) :: current_dim
349 : : integer, intent(in ) :: asked_dim
350 : :
351 [ + + ]: 820787 : if ( current_dim < asked_dim ) then
352 : 1851 : current_dim = asked_dim
353 [ + + ]: 1851 : if ( allocated(array) ) then
354 : 1194 : ABI_FREE(array)
355 : : end if
356 [ - + + - : 5553 : ABI_MALLOC(array,(asked_dim))
+ - + - -
+ - + -
+ ]
357 : : end if
358 : :
359 : 820787 : end subroutine checkResizeR
360 : : !!***
361 : :
362 : : !!****f* m_xg/checkResizeC
363 : : !!
364 : : !! NAME
365 : : !! checkResizeC
366 : :
367 : 716375 : subroutine checkResizeC(array,current_dim,asked_dim)
368 : :
369 : : complex(kind=8), allocatable, intent(inout) :: array(:)
370 : : integer, intent(inout) :: current_dim
371 : : integer, intent(in ) :: asked_dim
372 : :
373 : :
374 [ + + ]: 716375 : if ( current_dim < asked_dim ) then
375 : 1937 : current_dim = asked_dim
376 [ + + ]: 1937 : if ( allocated(array) ) then
377 : 1444 : ABI_FREE(array)
378 : : end if
379 [ - + + - : 5811 : ABI_MALLOC(array,(asked_dim))
+ - + - -
+ - + -
+ ]
380 : : end if
381 : :
382 : 716375 : end subroutine checkResizeC
383 : : !!***
384 : :
385 : : !!****f* m_xg/getClocR
386 : : !!
387 : : !! NAME
388 : : !! getClocR
389 : :
390 : 22038762 : function getClocR(rows,cols,array) result(cptr)
391 : : use, intrinsic :: iso_c_binding
392 : : integer, intent(in) :: rows
393 : : integer, intent(in) :: cols
394 : : double precision, target, intent(in) :: array(rows,cols)
395 : : type(c_ptr) :: cptr
396 : 22038762 : cptr = c_loc(array)
397 : : end function getClocR
398 : : !!***
399 : :
400 : : !!****f* m_xg/getClocC
401 : : !!
402 : : !! NAME
403 : : !! getClocC
404 : :
405 : 36373139 : function getClocC(rows,cols,array) result(cptr)
406 : : use, intrinsic :: iso_c_binding
407 : : integer, intent(in) :: rows
408 : : integer, intent(in) :: cols
409 : : complex(kind=8), target, intent(in) :: array(rows,cols)
410 : : type(c_ptr) :: cptr
411 : 36373139 : cptr = c_loc(array)
412 : : end function getClocC
413 : : !!***
414 : :
415 : : !!****f* m_xg/xg_init
416 : : !!
417 : : !! NAME
418 : : !! xg_init
419 : :
420 : 10001550 : subroutine xg_init(xg, space, rows, cols, comm, me_g0, gpu_option)
421 : :
422 : : type(xg_t), target, intent(inout) :: xg
423 : : integer , intent(in ) :: space
424 : : integer , intent(in ) :: rows
425 : : integer , intent(in ) :: cols
426 : : integer , optional, intent(in) :: comm, me_g0, gpu_option
427 : : integer :: l_gpu_option,fact
428 : : #if defined HAVE_GPU
429 : : integer(kind=c_int32_t), parameter :: izero = 0
430 : : #endif
431 : : #if defined HAVE_GPU && defined HAVE_OPENMP_OFFLOAD && !defined HAVE_OPENMP_OFFLOAD_DATASTRUCTURE
432 : : complex(dp), pointer :: xg__vecC(:,:)
433 : : real(dp), pointer :: xg__vecR(:,:)
434 : : #endif
435 : :
436 [ - + ]: 10001550 : if ( rows < 1 ) then
437 : 0 : ABI_ERROR("rows < 1 ")
438 : : endif
439 [ - + ]: 10001550 : if ( cols < 1 ) then
440 : 0 : ABI_ERROR("cols < 1 ")
441 : : end if
442 : :
443 : : ! if optional parameter is present, use it
444 : : ! else use default value, i.e. don't use GPU
445 : 10001550 : l_gpu_option = ABI_GPU_DISABLED
446 [ + + ]: 10001550 : if (present(gpu_option)) then
447 : 3525624 : l_gpu_option = gpu_option
448 : : end if
449 : :
450 [ + + ]: 10001550 : fact = 1 ; if (space==SPACE_CR) fact = 2
451 : :
452 [ + - ]: 10001550 : if (l_gpu_option==ABI_GPU_KOKKOS) then
453 : : #if defined HAVE_GPU && defined HAVE_YAKL
454 : : select case (space)
455 : : case (SPACE_R,SPACE_CR)
456 : : if ( associated(xg%vecR) ) then
457 : : ABI_FREE_MANAGED(xg%vecR)
458 : : end if
459 : : ABI_MALLOC_MANAGED_BOUNDS(xg%vecR,(/fact*rows,cols/), (/1,1/))
460 : : xg%trans = 't'
461 : : case (SPACE_C)
462 : : if ( associated(xg%vecC) ) then
463 : : ABI_FREE_MANAGED(xg%vecC)
464 : : end if
465 : : ABI_MALLOC_MANAGED_BOUNDS(xg%vecC,(/rows,cols/), (/1,1/))
466 : : xg%trans = 'c'
467 : : case default
468 : : ABI_ERROR("Invalid space")
469 : : end select
470 : : #endif
471 : :
472 [ + - ]: 10001550 : else if (l_gpu_option==ABI_GPU_OPENMP) then
473 : :
474 : : #if defined HAVE_GPU && defined HAVE_OPENMP_OFFLOAD
475 : : select case (space)
476 : :
477 : : case (SPACE_R,SPACE_CR)
478 : : if ( associated(xg%vecR) ) then
479 : : #if defined HAVE_OPENMP_OFFLOAD_DATASTRUCTURE
480 : : !$OMP TARGET EXIT DATA MAP(delete:xg%vecR)
481 : : #else
482 : : call xg_ompgpu_map_delete_real(xg%vecR)
483 : : #endif
484 : : ABI_FREE(xg%vecR)
485 : : end if
486 : : ABI_MALLOC(xg%vecR,(1:fact*rows,1:cols))
487 : : xg%trans = 't'
488 : : #if defined HAVE_OPENMP_OFFLOAD_DATASTRUCTURE
489 : : !$OMP TARGET ENTER DATA MAP(alloc:xg%vecR)
490 : : #else
491 : : call xg_ompgpu_map_alloc_real(xg%vecR, fact*rows*cols)
492 : : #endif
493 : :
494 : : case (SPACE_C)
495 : : if ( associated(xg%vecC) ) then
496 : : #if defined HAVE_OPENMP_OFFLOAD_DATASTRUCTURE
497 : : !$OMP TARGET EXIT DATA MAP(delete:xg%vecC)
498 : : #else
499 : : call xg_ompgpu_map_delete_cmplx(xg%vecC)
500 : : #endif
501 : : ABI_FREE(xg%vecC)
502 : : end if
503 : : ABI_MALLOC(xg%vecC,(1:rows,1:cols))
504 : : xg%trans = 'c'
505 : : #if defined HAVE_OPENMP_OFFLOAD_DATASTRUCTURE
506 : : !$OMP TARGET ENTER DATA MAP(alloc:xg%vecC)
507 : : #else
508 : : call xg_ompgpu_map_alloc_cmplx(xg%vecC, rows*cols)
509 : : #endif
510 : :
511 : : case default
512 : : ABI_ERROR("Invalid space")
513 : : end select
514 : : #endif
515 : :
516 [ + - ]: 10001550 : else if ( l_gpu_option==ABI_GPU_DISABLED .or. l_gpu_option==ABI_GPU_LEGACY ) then
517 : :
518 : 3008892 : select case (space)
519 : : case (SPACE_R,SPACE_CR)
520 [ + + ]: 3008892 : if ( associated(xg%vecR) ) then
521 : 2146 : ABI_FREE(xg%vecR)
522 : : end if
523 [ - + + - : 12035568 : ABI_MALLOC(xg%vecR,(1:fact*rows,1:cols))
- + + - +
- + - - +
- + ]
524 : 3008892 : xg%trans = 't'
525 : : case (SPACE_C)
526 [ + + ]: 6992658 : if ( associated(xg%vecC) ) then
527 : 1478 : ABI_FREE(xg%vecC)
528 : : end if
529 [ - + + - : 27970632 : ABI_MALLOC(xg%vecC,(1:rows,1:cols))
- + + - +
- + - - +
- + ]
530 : 6992658 : xg%trans = 'c'
531 : : case default
532 [ + + - ]: 10001550 : ABI_ERROR("Invalid space")
533 : : end select
534 : :
535 : : else
536 : 0 : ABI_ERROR("Invalid gpu_option")
537 : : end if
538 : :
539 : 10001550 : xg%space = space
540 : 10001550 : xg%normal = 'n'
541 : 10001550 : xg%cols = cols
542 : 10001550 : xg%rows = rows
543 : 10001550 : xg%spacedim_comm = xmpi_comm_null
544 : 10001550 : xg%gpu_option = l_gpu_option
545 : 10001550 : xg%me_g0 = -1
546 : :
547 [ + + ]: 10001550 : if ( present(comm) ) xg%spacedim_comm = comm
548 [ + + ]: 10001550 : if ( present(me_g0) ) then
549 [ + + - + ]: 1222472 : if (me_g0/=-1.and.me_g0/=0.and.me_g0/=1) then
550 : 0 : ABI_ERROR('Bad value of me_g0 in xg_init')
551 : : else
552 : 1222472 : xg%me_g0 = me_g0
553 : : end if
554 : : end if
555 : :
556 : 10001550 : call xg_setBlock(xg,xg%self,rows,cols)
557 : 10001550 : call xgBlock_zero(xg%self)
558 : :
559 : : #if defined HAVE_OPENMP_OFFLOAD && ! defined HAVE_OPENMP_OFFLOAD_DATASTRUCTURE
560 : : contains
561 : : !NOTE For several compilers, OMP doesn't work correctly with structured types syntax
562 : : ! in directives, so use subroutines instead
563 : : subroutine xg_ompgpu_map_alloc_real(xg_vecR,size)
564 : : integer,intent(in) :: size
565 : : real(dp),intent(inout) :: xg_vecR(size)
566 : : !$OMP TARGET ENTER DATA MAP(alloc:xg_vecR)
567 : : end subroutine xg_ompgpu_map_alloc_real
568 : :
569 : : subroutine xg_ompgpu_map_alloc_cmplx(xg_vecC,size)
570 : : integer,intent(in) :: size
571 : : complex(dp),intent(inout) :: xg_vecC(size)
572 : : !$OMP TARGET ENTER DATA MAP(alloc:xg_vecC)
573 : : end subroutine xg_ompgpu_map_alloc_cmplx
574 : :
575 : : subroutine xg_ompgpu_map_delete_real(xg_vecR)
576 : : real(dp),intent(inout) :: xg_vecR(:,:)
577 : : !$OMP TARGET EXIT DATA MAP(delete:xg_vecR)
578 : : end subroutine xg_ompgpu_map_delete_real
579 : :
580 : : subroutine xg_ompgpu_map_delete_cmplx(xg_vecC)
581 : : complex(dp),intent(inout) :: xg_vecC(:,:)
582 : : !$OMP TARGET EXIT DATA MAP(delete:xg_vecC)
583 : : end subroutine xg_ompgpu_map_delete_cmplx
584 : : #endif
585 : 10001550 : end subroutine xg_init
586 : : !!***
587 : :
588 : : !LB-06/03/24: Be careful, xg_set is not used anywhere in the code, so not tested...
589 : : !!****f* m_xg/xg_set
590 : : !!
591 : : !! NAME
592 : : !! xg_set
593 : :
594 [ # # ]: 0 : subroutine xg_set(xg,array,shift_col,rows)
595 : :
596 : : type(xg_t), target, intent(inout) :: xg
597 : : double precision, intent(in) :: array(:,:)
598 : : integer, intent(in) :: shift_col
599 : : integer, intent(in) :: rows
600 : : integer :: cols
601 : : integer :: col
602 : : ! double precision :: tsec(2)
603 : :
604 : : #if defined HAVE_GPU && defined HAVE_OPENMP_OFFLOAD
605 : : complex(dp), pointer :: xg__vecC(:,:)
606 : : real(dp), pointer :: xg__vecR(:,:)
607 : : #endif
608 : :
609 : : ! call timab(tim_set,1,tsec)
610 : :
611 [ # # ]: 0 : if ( size(array,dim=1) /= 2 ) then
612 : 0 : ABI_ERROR("First dim must be 2")
613 : : end if
614 : :
615 : 0 : cols = size(array,dim=2)/rows
616 [ # # ]: 0 : if ( shift_col+cols > xg%cols ) then
617 : 0 : ABI_WARNING("Ignore some columns, input array to large")
618 : : endif
619 : :
620 [ # # ]: 0 : if(xg%gpu_option == ABI_GPU_OPENMP) then
621 : : #if defined HAVE_GPU && defined HAVE_OPENMP_OFFLOAD
622 : : select case (xg%space)
623 : : case (SPACE_R)
624 : : xg__vecR => xg%vecR
625 : : do col = 1, min(cols,xg%cols-shift_col)
626 : : xg%vecR(1:rows,shift_col+col) = array(1,(col-1)*rows+1:col*rows)
627 : : end do
628 : : !$OMP TARGET UPDATE TO(xg__vecR)
629 : : case (SPACE_CR)
630 : : xg__vecR => xg%vecR
631 : : if ( xg%rows /= 2*rows ) then
632 : : ABI_ERROR("Bad number of rows")
633 : : end if
634 : :
635 : : do col = 1, min(cols,xg%cols-shift_col)
636 : : xg%vecR(1:rows,shift_col+col) = array(1,(col-1)*rows+1:col*rows)
637 : : xg%vecR(rows+1:2*rows,shift_col+col) = array(2,(col-1)*rows+1:col*rows)
638 : : end do
639 : : !$OMP TARGET UPDATE TO(xg__vecR)
640 : : case (SPACE_C)
641 : : xg__vecC => xg%vecC
642 : : do col = 1, min(cols,xg%cols-shift_col)
643 : : xg%vecC(1:rows,shift_col+col) = dcmplx(array(1,(col-1)*rows+1:col*rows), &
644 : : array(2,(col-1)*rows+1:col*rows))
645 : : end do
646 : : !$OMP TARGET UPDATE TO(xg__vecC)
647 : : end select
648 : : #endif
649 : : else
650 : 0 : select case (xg%space)
651 : : case (SPACE_R)
652 [ # # ]: 0 : do col = 1, min(cols,xg%cols-shift_col)
653 [ # # ]: 0 : xg%vecR(1:rows,shift_col+col) = array(1,(col-1)*rows+1:col*rows)
654 : : end do
655 : : case (SPACE_CR)
656 [ # # ]: 0 : if ( xg%rows /= 2*rows ) then
657 : 0 : ABI_ERROR("Bad number of rows")
658 : : end if
659 : :
660 [ # # ]: 0 : do col = 1, min(cols,xg%cols-shift_col)
661 [ # # ]: 0 : xg%vecR(1:rows,shift_col+col) = array(1,(col-1)*rows+1:col*rows)
662 [ # # ]: 0 : xg%vecR(rows+1:2*rows,shift_col+col) = array(2,(col-1)*rows+1:col*rows)
663 : : end do
664 : : case (SPACE_C)
665 [ # # # # : 0 : do col = 1, min(cols,xg%cols-shift_col)
# # ]
666 : : xg%vecC(1:rows,shift_col+col) = dcmplx(array(1,(col-1)*rows+1:col*rows), &
667 [ # # ]: 0 : array(2,(col-1)*rows+1:col*rows))
668 : : end do
669 : : end select
670 : : end if
671 : :
672 : : ! call timab(tim_set,2,tsec)
673 : :
674 : 0 : end subroutine xg_set
675 : : !!***
676 : :
677 : : !LB-06/03/24: Be careful, xgBlock_set is not used anywhere in the code, so not tested...
678 : : !!****f* m_xg/xgBlock_set
679 : : !!
680 : : !! NAME
681 : : !! xgBlock_set
682 : :
683 [ # # ]: 0 : subroutine xgBlock_set(xgBlock,array,shift_col,rows)
684 : :
685 : : type(xgBlock_t), intent(inout) :: xgBlock
686 : : double precision, intent(in) :: array(:,:)
687 : : integer, intent(in) :: shift_col
688 : : integer, intent(in) :: rows
689 : : integer :: cols
690 : : integer :: col
691 : : ! double precision :: tsec(2)
692 : :
693 : : ! call timab(tim_set,1,tsec)
694 : :
695 [ # # ]: 0 : if ( size(array,dim=1) /= 2 ) then
696 : 0 : ABI_ERROR("First dim must be 2")
697 : : end if
698 : :
699 : 0 : cols = size(array,dim=2)/rows
700 [ # # ]: 0 : if ( shift_col+cols > xgBlock%cols ) then
701 : 0 : ABI_WARNING("Block Ignore some columns, input array to large")
702 : : endif
703 : :
704 [ # # ]: 0 : if(xgBlock%gpu_option==ABI_GPU_OPENMP) then
705 : : #if defined HAVE_GPU && defined HAVE_OPENMP_OFFLOAD
706 : : select case (xgBlock%space)
707 : : case (SPACE_R)
708 : : call xgBlock_copy_from_gpu(xgBlock)
709 : : do col = 1, min(cols,xgBlock%cols-shift_col)
710 : : xgBlock%vecR(1:rows,shift_col+col) = array(1,(col-1)*rows+1:col*rows)
711 : : end do
712 : : call xgBlock_copy_to_gpu(xgBlock)
713 : : case (SPACE_CR)
714 : : if ( xgBlock%rows /= 2*rows ) then
715 : : ABI_ERROR("Bad number of rows")
716 : : end if
717 : :
718 : : call xgBlock_copy_from_gpu(xgBlock)
719 : : do col = 1, min(cols,xgBlock%cols-shift_col)
720 : : xgBlock%vecR(1:rows,shift_col+col) = array(1,(col-1)*rows+1:col*rows)
721 : : xgBlock%vecR(rows+1:2*rows,shift_col+col) = array(2,(col-1)*rows+1:col*rows)
722 : : end do
723 : : call xgBlock_copy_to_gpu(xgBlock)
724 : : case (SPACE_C)
725 : : call xgBlock_copy_from_gpu(xgBlock)
726 : : do col = 1, min(cols,xgBlock%cols-shift_col)
727 : : xgBlock%vecC(1:rows,shift_col+col) = dcmplx(array(1,(col-1)*rows+1:col*rows), &
728 : : array(2,(col-1)*rows+1:col*rows))
729 : : end do
730 : : call xgBlock_copy_to_gpu(xgBlock)
731 : : end select
732 : : #endif
733 : : else
734 : 0 : select case (xgBlock%space)
735 : : case (SPACE_R)
736 [ # # ]: 0 : do col = 1, min(cols,xgBlock%cols-shift_col)
737 [ # # ]: 0 : xgBlock%vecR(1:rows,shift_col+col) = array(1,(col-1)*rows+1:col*rows)
738 : : end do
739 : : case (SPACE_CR)
740 [ # # ]: 0 : if ( xgBlock%rows /= 2*rows ) then
741 : 0 : ABI_ERROR("Bad number of rows")
742 : : end if
743 : :
744 [ # # ]: 0 : do col = 1, min(cols,xgBlock%cols-shift_col)
745 [ # # ]: 0 : xgBlock%vecR(1:rows,shift_col+col) = array(1,(col-1)*rows+1:col*rows)
746 [ # # ]: 0 : xgBlock%vecR(rows+1:2*rows,shift_col+col) = array(2,(col-1)*rows+1:col*rows)
747 : : end do
748 : : case (SPACE_C)
749 [ # # # # : 0 : do col = 1, min(cols,xgBlock%cols-shift_col)
# # ]
750 : : xgBlock%vecC(1:rows,shift_col+col) = dcmplx(array(1,(col-1)*rows+1:col*rows), &
751 [ # # ]: 0 : array(2,(col-1)*rows+1:col*rows))
752 : : end do
753 : : end select
754 : : end if
755 : :
756 : : ! call timab(tim_set,2,tsec)
757 : :
758 : 0 : end subroutine xgBlock_set
759 : : !!***
760 : :
761 : : !!****f* m_xg/xgBlock_map
762 : : !!
763 : : !! NAME
764 : : !! xgBlock_map
765 : :
766 [ - + ]: 510642 : subroutine xgBlock_map(xgBlock,array,space,rows,cols,comm,me_g0,gpu_option)
767 : : use, intrinsic :: iso_c_binding
768 : : type(xgBlock_t) , intent(inout) :: xgBlock
769 : : double precision, target, intent(in) :: array(:,:)
770 : : integer , intent(in ) :: space
771 : : integer , intent(in ) :: rows
772 : : integer , intent(in ) :: cols
773 : : integer , optional, intent(in) :: comm
774 : : integer , optional, intent(in) :: me_g0
775 : : integer , optional, intent(in) :: gpu_option
776 : : integer :: fullsize,fact
777 : : type(c_ptr) :: cptr
778 : :
779 [ + + ]: 1531926 : fullsize = size(array)
780 [ + + ]: 510642 : fact = 1 ; if (space==SPACE_CR) fact = 2
781 : 352180 : select case (space)
782 : : case ( SPACE_R,SPACE_CR )
783 [ + - - + ]: 352180 : if ( fullsize < fact*cols*rows .or. mod(fullsize,fact*rows) /= 0) then
784 : 0 : ABI_ERROR("Bad size for real array")
785 : : end if
786 [ - + - - : 352180 : cptr = getClocR(size(array,dim=1),size(array,dim=2),array)
- - - - -
+ ]
787 [ + + ]: 1056540 : call c_f_pointer(cptr,xgBlock%vecR,(/ fact*rows, cols /))
788 : 352180 : xgBlock%trans = 't'
789 : : case ( SPACE_C )
790 [ + - - + ]: 158462 : if ( fullsize/2 < cols*rows .or. mod(fullsize/2,rows) /= 0) then
791 : 0 : ABI_ERROR("Bad size for complex array")
792 : : end if
793 [ - + - - : 158462 : cptr = getClocR(size(array,dim=1),size(array,dim=2),array)
- - - - -
+ ]
794 [ + + ]: 475386 : call c_f_pointer(cptr,xgBlock%vecC,(/ rows, cols /))
795 : :
796 : 158462 : xgBlock%trans = 'c'
797 : : case default
798 [ + + - ]: 510642 : ABI_ERROR('Bad space in xgBlock_map')
799 : : end select
800 : :
801 : 510642 : xgBlock%space = space
802 : 510642 : xgBlock%rows = rows
803 : 510642 : xgBlock%LDim = rows
804 : 510642 : xgBlock%cols = cols
805 : 510642 : xgBlock%normal = 'n'
806 : 510642 : xgBlock%spacedim_comm = xmpi_comm_null
807 : 510642 : xgBlock%me_g0 = -1
808 : 510642 : xgBlock%gpu_option = ABI_GPU_DISABLED
809 : :
810 [ + + ]: 510642 : if ( present(comm) ) xgBlock%spacedim_comm = comm
811 : :
812 [ + + ]: 510642 : if ( present(me_g0) ) then
813 [ + + - + ]: 491193 : if (me_g0/=-1.and.me_g0/=0.and.me_g0/=1) then
814 : 0 : ABI_ERROR('Bad value of me_g0 in xg_init')
815 : : else
816 : 491193 : xgBlock%me_g0 = me_g0
817 : : end if
818 : : end if
819 : :
820 [ + + ]: 510642 : if ( present(gpu_option) ) xgBlock%gpu_option = gpu_option
821 : : #if defined(DEBUG_VERBOSE) && defined(HAVE_OPENMP_OFFLOAD)
822 : : if ( xgBlock%gpu_option == ABI_GPU_OPENMP ) then
823 : : ABI_CHECK(xomp_target_is_present(c_loc(array)), "Mapped array isn't... mapped with OpenMP")
824 : : end if
825 : : #endif
826 : : if ( xgBlock%gpu_option /= ABI_GPU_DISABLED .and. xgBlock%gpu_option /= ABI_GPU_LEGACY .and. &
827 [ - + ]: 510642 : xgBlock%gpu_option /= ABI_GPU_OPENMP .and. xgBlock%gpu_option /= ABI_GPU_KOKKOS ) then
828 : 0 : ABI_ERROR('Bad GPU option in xgBlock_map')
829 : : end if
830 : :
831 : 510642 : end subroutine xgBlock_map
832 : : !!***
833 : :
834 : : !!****f* m_xg/xgBlock_map_1d
835 : : !!
836 : : !! NAME
837 : : !! xgBlock_map_1d
838 : :
839 : 257644 : subroutine xgBlock_map_1d(xgBlock,array,space,rows,comm,me_g0,gpu_option)
840 : : use iso_c_binding
841 : : type(xgBlock_t) , intent(inout) :: xgBlock
842 : : double precision, intent(in), target :: array(:)
843 : : integer , intent(in ) :: space
844 : : integer , intent(in ) :: rows
845 : : integer , optional, intent(in) :: comm
846 : : integer , optional, intent(in) :: me_g0
847 : : integer , optional, intent(in) :: gpu_option
848 : :
849 : : integer :: comm_,me_g0_,gpu_option_
850 : : type(c_ptr) :: cptr
851 : : real(dp), pointer :: array_ptr(:,:) => NULL()
852 : :
853 : : ! Trick the with C to change rank of arrays (:) to (:,:)
854 : 257644 : cptr = c_loc(array)
855 [ + + ]: 772932 : call c_f_pointer(cptr,array_ptr,(/ rows,1 /))
856 : :
857 : 257644 : comm_ =xmpi_comm_null
858 [ - + ]: 257644 : if (present(comm)) then
859 : 0 : comm_=comm
860 : : end if
861 : :
862 : 257644 : me_g0_=-1
863 [ - + ]: 257644 : if (present(me_g0)) then
864 : 0 : me_g0_=me_g0
865 : : end if
866 : :
867 : 257644 : gpu_option_=ABI_GPU_DISABLED
868 [ + + ]: 257644 : if (present(gpu_option)) then
869 : 149892 : gpu_option_=gpu_option
870 : : end if
871 : :
872 : 257644 : call xgBlock_map(xgBlock,array_ptr,space,rows,1,comm=comm_,me_g0=me_g0_,gpu_option=gpu_option_)
873 : :
874 : 257644 : end subroutine xgBlock_map_1d
875 : : !!***
876 : :
877 : : !!****f* m_xg/xgBlock_reverseMapR
878 : : !!
879 : : !! NAME
880 : : !! xgBlock_reverseMapR
881 : :
882 : 20067516 : subroutine xgBlock_reverseMapR(xgBlock,array,rows,cols)
883 : : use, intrinsic :: iso_c_binding
884 : : type(xgBlock_t) , intent(in) :: xgBlock
885 : : double precision, pointer, intent(inout) :: array(:,:)
886 : : integer,optional,intent(in) :: rows
887 : : integer,optional,intent(in) :: cols
888 : : type(c_ptr) :: cptr
889 : :
890 : : integer :: rows_,cols_,fact
891 : :
892 [ + + ]: 20067516 : fact = 1 ; if (xgBlock%space==SPACE_CR) fact = 2
893 : :
894 : 20067516 : rows_ = fact*xgBlock%ldim
895 : 20067516 : cols_ = xgBlock%cols
896 [ + + ]: 20067516 : if (present(rows)) rows_=fact*rows
897 [ + + ]: 20067516 : if (present(cols)) cols_=cols
898 : :
899 : 8082081 : select case (xgBlock%space)
900 : : case ( SPACE_R,SPACE_CR )
901 [ - + ]: 8082081 : if ( xgBlock%cols*fact*xgBlock%Ldim < cols_*rows_ ) then
902 : 0 : write(std_out,*) xgBlock%cols,xgBlock%Ldim,cols,rows
903 : 0 : write(std_out,*) xgBlock%cols*xgBlock%Ldim,cols*rows
904 : 0 : ABI_ERROR("Bad reverseMapping")
905 : : end if
906 [ - + - - : 8082081 : cptr = getClocR(fact*xgBlock%Ldim,xgBlock%cols,xgBlock%vecR(:,:))
- - - - -
+ ]
907 [ + + ]: 24246243 : call c_f_pointer(cptr,array,(/ rows_, cols_ /))
908 : : case ( SPACE_C )
909 [ - + ]: 11985435 : if ( xgBlock%cols*xgBlock%Ldim < cols_*rows_ ) then
910 : 0 : ABI_ERROR("Bad complex reverseMapping")
911 : : end if
912 [ - + - - : 11985435 : cptr = getClocC(xgBlock%Ldim,xgBlock%cols,xgBlock%vecC(:,:))
- - - - -
+ ]
913 [ + + - + : 56023821 : call c_f_pointer(cptr,array,(/ 2*rows_, cols_ /))
+ ]
914 : : end select
915 : :
916 : 20067516 : end subroutine xgBlock_reverseMapR
917 : : !!***
918 : :
919 : : !!****f* m_xg/xgBlock_reverseMap_1dR
920 : : !!
921 : : !! NAME
922 : : !! xgBlock_reverseMap_1dR
923 : :
924 : 918343 : subroutine xgBlock_reverseMap_1dR(xgBlock,array,array_dim)
925 : : use, intrinsic :: iso_c_binding
926 : : type(xgBlock_t) , intent(in) :: xgBlock
927 : : double precision, pointer, intent(inout) :: array(:)
928 : : integer,optional,intent(in) :: array_dim
929 : : type(c_ptr) :: cptr
930 : :
931 : : integer :: dim_,fact
932 : :
933 [ - + ]: 918343 : fact = 1 ; if (xgBlock%space==SPACE_CR) fact = 2
934 : :
935 : 918343 : dim_ = fact*xgBlock%ldim*xgBlock%cols
936 [ + + ]: 918343 : if (present(array_dim)) dim_=fact*array_dim
937 : :
938 : 918343 : select case (xgBlock%space)
939 : : case ( SPACE_R,SPACE_CR )
940 [ - + ]: 918343 : if ( xgBlock%cols*fact*xgBlock%Ldim < dim_ ) then
941 : 0 : write(std_out,*) xgBlock%cols,xgBlock%Ldim,dim_
942 : 0 : write(std_out,*) xgBlock%cols*xgBlock%Ldim,dim_
943 : 0 : ABI_ERROR("Bad reverseMapping")
944 : : end if
945 [ - + - - : 918343 : cptr = getClocR(fact*xgBlock%Ldim,xgBlock%cols,xgBlock%vecR(:,:))
- - - - -
+ ]
946 [ + + ]: 1836686 : call c_f_pointer(cptr,array,(/ dim_ /))
947 : : case ( SPACE_C )
948 [ # # ]: 0 : if ( xgBlock%cols*xgBlock%Ldim < dim_ ) then
949 : 0 : ABI_ERROR("Bad complex reverseMapping")
950 : : end if
951 [ # # # # : 0 : cptr = getClocC(xgBlock%Ldim,xgBlock%cols,xgBlock%vecC(:,:))
# # # # #
# ]
952 [ + - - - : 918343 : call c_f_pointer(cptr,array,(/ 2*dim_ /))
- ]
953 : : end select
954 : :
955 : 918343 : end subroutine xgBlock_reverseMap_1dR
956 : : !!***
957 : :
958 : : !!****f* m_xg/xgBlock_reverseMapC
959 : : !!
960 : : !! NAME
961 : : !! xgBlock_reverseMapC
962 : :
963 : 864200 : subroutine xgBlock_reverseMapC(xgBlock,array,rows,cols)
964 : : use, intrinsic :: iso_c_binding
965 : : type(xgBlock_t) , intent(in) :: xgBlock
966 : : complex(dp), pointer, intent(inout) :: array(:,:)
967 : : integer,optional,intent(in) :: rows
968 : : integer,optional,intent(in) :: cols
969 : : type(c_ptr) :: cptr
970 : :
971 : : integer :: rows_,cols_
972 : :
973 [ - + ]: 864200 : if (xgBlock%space/=SPACE_C) then
974 : 0 : ABI_ERROR('space(xgBlock) should be SPACE_C')
975 : : end if
976 : 864200 : rows_ = xgBlock%ldim
977 : 864200 : cols_ = xgBlock%cols
978 [ + + ]: 864200 : if (present(rows)) rows_=rows
979 [ + + ]: 864200 : if (present(cols)) cols_=cols
980 : :
981 [ - + ]: 864200 : if ( xgBlock%cols*xgBlock%Ldim < cols_*rows_ ) then
982 : 0 : ABI_ERROR("Bad complex reverseMapping")
983 : : end if
984 [ - + - - : 864200 : cptr = getClocC(xgBlock%Ldim,xgBlock%cols,xgBlock%vecC(:,:))
- - - - -
+ ]
985 [ + + ]: 2592600 : call c_f_pointer(cptr,array,(/ rows_, cols_ /))
986 : :
987 : 864200 : end subroutine xgBlock_reverseMapC
988 : : !!***
989 : :
990 : : !!****f* m_xg/xgBlock_reverseMap_1dC
991 : : !!
992 : : !! NAME
993 : : !! xgBlock_reverseMap_1dC
994 : :
995 : 0 : subroutine xgBlock_reverseMap_1dC(xgBlock,array,array_dim)
996 : : use, intrinsic :: iso_c_binding
997 : : type(xgBlock_t) , intent(in) :: xgBlock
998 : : complex(dp), pointer, intent(inout) :: array(:)
999 : : integer,optional,intent(in) :: array_dim
1000 : : type(c_ptr) :: cptr
1001 : :
1002 : : integer :: dim_
1003 : :
1004 [ # # ]: 0 : if (xgBlock%space/=SPACE_C) then
1005 : 0 : ABI_ERROR('space(xgBlock) should be SPACE_C')
1006 : : end if
1007 : 0 : dim_ = xgBlock%ldim*xgBlock%cols
1008 [ # # ]: 0 : if (present(array_dim)) dim_=array_dim
1009 : :
1010 [ # # ]: 0 : if ( xgBlock%cols*xgBlock%Ldim < dim_ ) then
1011 : 0 : ABI_ERROR("Bad complex reverseMapping")
1012 : : end if
1013 [ # # # # : 0 : cptr = getClocC(xgBlock%Ldim,xgBlock%cols,xgBlock%vecC(:,:))
# # # # #
# ]
1014 [ # # ]: 0 : call c_f_pointer(cptr,array,(/ dim_ /))
1015 : :
1016 : 0 : end subroutine xgBlock_reverseMap_1dC
1017 : : !!***
1018 : :
1019 : : !!****f* m_xg/xgBlock_prefetch_async
1020 : : !!
1021 : : !! Help the compiler to upload / dowload data to/from GPU memory
1022 : : !!
1023 : : !! if deviceId is CPU_DEVICE_ID (= -1, defined in 17_gpu_toolbox/m_gpu_toolbox.F90)
1024 : : !! then data is prefetch on host, else it is prefetch to GPU memory
1025 : : !!
1026 : : !! NAME
1027 : : !! xgBlock_prefetch_async
1028 : :
1029 : 0 : subroutine xgBlock_prefetch_async(xgBlock, deviceId)
1030 : : use iso_c_binding
1031 : : type(xgBlock_t) , intent(inout) :: xgBlock
1032 : : integer(C_INT32_T), optional, intent(in) :: deviceId
1033 : :
1034 : : #if defined(HAVE_GPU_CUDA) && defined(HAVE_YAKL)
1035 : :
1036 : : real(dp), pointer :: array(:,:)
1037 : : integer :: blockdim
1038 : : integer :: spacedim
1039 : : integer :: ldim
1040 : : integer(C_SIZE_T) :: byte_count
1041 : :
1042 : : ! get the array pointer underneath the xgBlock
1043 : : call xgBlock_getSize(xgBlock,spacedim,blockdim,ldim)
1044 : : call xgBlock_reverseMap(xgBlock,array,1,spacedim*blockdim)
1045 : :
1046 : : select case (xgBlock%space)
1047 : : case ( SPACE_R )
1048 : : byte_count = ldim*blockdim*dp
1049 : : case ( SPACE_CR )
1050 : : byte_count = 2*ldim*blockdim*dp
1051 : : case ( SPACE_C )
1052 : : byte_count = ldim*blockdim*2*dp ! Note the factor 2, needed here!
1053 : : end select
1054 : :
1055 : : ! now we can call the memory prefetch
1056 : : if (present(deviceId)) then
1057 : : call gpu_data_prefetch_async(c_loc(array), byte_count , deviceId)
1058 : : else
1059 : : call gpu_data_prefetch_async(c_loc(array), byte_count)
1060 : : end if
1061 : :
1062 : : #else
1063 : : ABI_UNUSED(deviceId)
1064 : 0 : ABI_UNUSED_A(xgBlock)
1065 : : #endif
1066 : :
1067 : 0 : end subroutine xgBlock_prefetch_async
1068 : : !!***
1069 : :
1070 : : !LB-06/03/24: Be careful, xg_get is not used anywhere in the code, so not tested...
1071 : : !!****f* m_xg/xg_get
1072 : : !!
1073 : : !! NAME
1074 : : !! xg_get
1075 : :
1076 [ # # ]: 0 : subroutine xg_get(xg,array,shift_col,rows)
1077 : :
1078 : : type(xg_t), intent(inout) :: xg
1079 : : double precision, intent(out) :: array(:,:)
1080 : : integer, intent(in) :: shift_col
1081 : : integer, intent(in) :: rows
1082 : : integer :: cols
1083 : : integer :: col
1084 : : ! double precision :: tsec(2)
1085 : :
1086 : : ! call timab(tim_get,1,tsec)
1087 : :
1088 [ # # ]: 0 : if ( size(array,dim=1) /= 2 ) then
1089 : 0 : ABI_ERROR("First dim must be 2")
1090 : : end if
1091 : :
1092 : 0 : cols = size(array,dim=2)/rows
1093 [ # # ]: 0 : if ( shift_col+cols > xg%cols ) then
1094 : 0 : ABI_WARNING("Ignore some columns, input array to large")
1095 : : endif
1096 : :
1097 : 0 : select case (xg%space)
1098 : : case (SPACE_R)
1099 : : !!$OMP TARGET UPDATE FROM(xg%vecR)
1100 [ # # ]: 0 : do col = 1, min(cols,xg%cols-shift_col)
1101 [ # # ]: 0 : array(1,(col-1)*rows+1:col*rows) = xg%vecR(1:rows,shift_col+col)
1102 : : end do
1103 : : case (SPACE_CR)
1104 [ # # ]: 0 : if ( xg%rows /= 2*rows ) then
1105 : 0 : ABI_ERROR("Bad number of rows")
1106 : : end if
1107 : :
1108 : : !!$OMP TARGET UPDATE FROM(xg%vecR)
1109 [ # # ]: 0 : do col = 1, min(cols,xg%cols-shift_col)
1110 [ # # ]: 0 : array(1,(col-1)*rows+1:col*rows) = xg%vecR(1:rows,shift_col+col)
1111 [ # # ]: 0 : array(2,(col-1)*rows+1:col*rows) = xg%vecR(rows+1:2*rows,shift_col+col)
1112 : : end do
1113 : : case (SPACE_C)
1114 : : !!$OMP TARGET UPDATE FROM(xg%vecC)
1115 [ # # # # : 0 : do col = 1, min(cols,xg%cols-shift_col)
# # ]
1116 [ # # ]: 0 : array(1,(col-1)*rows+1:col*rows) = dble(xg%vecC(1:rows,shift_col+col))
1117 [ # # ]: 0 : array(2,(col-1)*rows+1:col*rows) = aimag(xg%vecC(1:rows,shift_col+col))
1118 : : end do
1119 : : end select
1120 : :
1121 : : ! call timab(tim_get,2,tsec)
1122 : :
1123 : 0 : end subroutine xg_get
1124 : : !!***
1125 : :
1126 : : !LB-06/03/24: Be careful, xgBlock_get is not used anywhere in the code, so not tested...
1127 : : !!****f* m_xg/xgBlock_get
1128 : : !!
1129 : : !! NAME
1130 : : !! xgBlock_get
1131 : :
1132 [ # # ]: 0 : subroutine xgBlock_get(xgBlock,array,shift_col,rows)
1133 : :
1134 : : type(xgBlock_t), intent(in ) :: xgBlock
1135 : : double precision, intent(out) :: array(:,:)
1136 : : integer, intent(in) :: shift_col
1137 : : integer, intent(in) :: rows
1138 : : integer :: cols
1139 : : integer :: col
1140 : : ! double precision :: tsec(2)
1141 : :
1142 : : ! call timab(tim_get,1,tsec)
1143 : :
1144 [ # # ]: 0 : if ( size(array,dim=1) /= 2 ) then
1145 : 0 : ABI_ERROR("First dim must be 2")
1146 : : end if
1147 : :
1148 : 0 : cols = size(array,dim=2)/rows
1149 [ # # ]: 0 : if ( shift_col+cols > xgBlock%cols ) then
1150 : 0 : ABI_ERROR("Ignore some columns, input array to large")
1151 : : endif
1152 : :
1153 : 0 : select case (xgBlock%space)
1154 : : case (SPACE_R)
1155 [ # # ]: 0 : do col = 1, min(cols,xgBlock%cols-shift_col)
1156 [ # # ]: 0 : array(1,(col-1)*rows+1:col*rows) = xgBlock%vecR(1:rows,shift_col+col)
1157 : : end do
1158 : : case (SPACE_CR)
1159 [ # # ]: 0 : if ( xgBlock%rows /= 2*rows ) then
1160 : 0 : ABI_ERROR("Bad number of rows")
1161 : : end if
1162 : :
1163 [ # # ]: 0 : do col = 1, min(cols,xgBlock%cols-shift_col)
1164 [ # # ]: 0 : array(1,(col-1)*rows+1:col*rows) = xgBlock%vecR(1:rows,shift_col+col)
1165 [ # # ]: 0 : array(2,(col-1)*rows+1:col*rows) = xgBlock%vecR(rows+1:2*rows,shift_col+col)
1166 : : end do
1167 : : case (SPACE_C)
1168 [ # # # # : 0 : do col = 1, min(cols,xgBlock%cols-shift_col)
# # ]
1169 [ # # ]: 0 : array(1,(col-1)*rows+1:col*rows) = dble(xgBlock%vecC(1:rows,shift_col+col))
1170 [ # # ]: 0 : array(2,(col-1)*rows+1:col*rows) = aimag(xgBlock%vecC(1:rows,shift_col+col))
1171 : : end do
1172 : : end select
1173 : :
1174 : : ! call timab(tim_get,2,tsec)
1175 : :
1176 : 0 : end subroutine xgBlock_get
1177 : : !!***
1178 : :
1179 : : !!****f* m_xg/xg_setBlock
1180 : : !!
1181 : : !! NAME
1182 : : !! xg_setBlock
1183 : :
1184 : 22640645 : subroutine xg_setBlock(xg, Xgblock, rows, cols, fcol)
1185 : : use, intrinsic :: iso_c_binding
1186 : : type(xg_t), intent(inout) :: xg
1187 : : type(xgBlock_t), intent(inout) :: xgBlock
1188 : : integer, intent(in) :: rows
1189 : : integer, intent(in) :: cols
1190 : : integer, optional, intent(in) :: fcol
1191 : : type(c_ptr) :: cptr
1192 : : integer :: fcol_,fact
1193 : :
1194 : 22640645 : fcol_=1
1195 [ + + ]: 22640645 : if (present(fcol)) fcol_=fcol
1196 : :
1197 [ - + ]: 22640645 : if ( (fcol_+cols-1 ) > xg%cols ) then
1198 : 0 : ABI_ERROR("Too many columns")
1199 : : endif
1200 [ - + ]: 22640645 : if ( rows > xg%rows ) then
1201 : 0 : ABI_ERROR("Too many rows")
1202 : : end if
1203 : :
1204 : 22640645 : xgBlock%space = xg%space
1205 : 22640645 : xgBlock%rows = rows
1206 : 22640645 : xgBlock%LDim = xg%rows
1207 : 22640645 : xgBlock%cols = cols
1208 : 22640645 : xgBlock%trans = xg%trans
1209 : 22640645 : xgBlock%normal = xg%normal
1210 : 22640645 : xgBlock%spacedim_comm= xg%spacedim_comm
1211 : 22640645 : xgBlock%me_g0 = xg%me_g0
1212 : 22640645 : xgBlock%gpu_option = xg%gpu_option
1213 : :
1214 [ + + ]: 22640645 : fact = 1 ; if (xgBlock%space==SPACE_CR) fact = 2
1215 : 6731636 : select case(xgBlock%space)
1216 : : case (SPACE_R,SPACE_CR)
1217 [ - + - - : 6731636 : cptr = getClocR(xg%rows,xg%cols,xg%vecR(:,fcol_:fcol_+cols-1))
- - - - -
+ ]
1218 [ + + ]: 20194908 : call c_f_pointer(cptr,xgBlock%vecR,(/ fact*xgBlock%LDim,cols /))
1219 : : case(SPACE_C)
1220 [ - + - - : 15909009 : cptr = getClocC(xg%rows,xg%cols,xg%vecC(:,fcol_:fcol_+cols-1))
- - - - -
+ ]
1221 [ + + - + : 70367672 : call c_f_pointer(cptr,xgBlock%vecC,(/ xgBlock%LDim,cols /))
+ ]
1222 : : end select
1223 : :
1224 : 22640645 : end subroutine xg_setBlock
1225 : : !!***
1226 : :
1227 : : !!****f* m_xg/xgBlock_setBlock
1228 : : !!
1229 : : !! NAME
1230 : : !! xgBlock_setBlock
1231 : :
1232 : 11614447 : subroutine xgBlock_setBlock(xgBlockA,xgBlockB, rows, cols, fcol)
1233 : : use, intrinsic :: iso_c_binding
1234 : : type(xgBlock_t), intent(in ) :: xgBlockA
1235 : : type(xgBlock_t), intent(inout) :: xgBlockB
1236 : : integer, intent(in) :: rows
1237 : : integer, intent(in) :: cols
1238 : : integer,optional,intent(in) :: fcol
1239 : : type(c_ptr) :: cptr
1240 : : integer :: fcol_,fact
1241 : :
1242 : 11614447 : fcol_=1
1243 [ + + ]: 11614447 : if (present(fcol)) fcol_=fcol
1244 : :
1245 [ - + ]: 11614447 : if ( (fcol_+cols-1 ) > xgblockA%cols ) then
1246 : 0 : ABI_ERROR("Too many columns")
1247 : : endif
1248 [ - + ]: 11614447 : if ( rows > xgblockA%rows ) then
1249 : 0 : ABI_ERROR("Too many rows")
1250 : : end if
1251 : :
1252 : 11614447 : xgBlockB%space = xgBlockA%space
1253 : 11614447 : xgBlockB%rows = rows
1254 : 11614447 : xgBlockB%LDim = xgBlockA%LDim
1255 : 11614447 : xgBlockB%cols = cols
1256 : 11614447 : xgBlockB%trans = xgBlockA%trans
1257 : 11614447 : xgBlockB%normal = xgBlockA%normal
1258 : 11614447 : xgBlockB%spacedim_comm= xgBlockA%spacedim_comm
1259 : 11614447 : xgBlockB%me_g0 = xgBlockA%me_g0
1260 : 11614447 : xgBlockB%gpu_option= xgBlockA%gpu_option
1261 : :
1262 [ + + ]: 11614447 : fact = 1 ; if (xgBlockA%space==SPACE_CR) fact = 2
1263 : 5156040 : select case(xgBlockA%space)
1264 : : case (SPACE_R,SPACE_CR)
1265 [ - + - - : 5156040 : cptr = getClocR(xgBlockA%LDim,xgBlockA%cols,xgBlockA%vecR(:,fcol_:fcol_+cols-1))
- - - - -
+ ]
1266 [ + + ]: 15468120 : call c_f_pointer(cptr,xgBlockB%vecR,(/ fact*xgBlockB%LDim,cols /))
1267 : : case(SPACE_C)
1268 [ - + - - : 6458407 : cptr = getClocC(xgBlockA%LDim,xgBlockA%cols,xgBlockA%vecC(:,fcol_:fcol_+cols-1))
- - - - -
+ ]
1269 [ + + - + : 30989668 : call c_f_pointer(cptr,xgBlockB%vecC,(/ xgBlockB%LDim,cols /))
+ ]
1270 : : end select
1271 : :
1272 : 11614447 : end subroutine xgBlock_setBlock
1273 : : !!***
1274 : :
1275 : : !!****f* m_xg/xg_free
1276 : : !!
1277 : : !! NAME
1278 : : !! xg_free
1279 : :
1280 : 11266162 : subroutine xg_free(xg)
1281 : :
1282 : : type(xg_t),target, intent(inout) :: xg
1283 : :
1284 : : #if defined HAVE_GPU && defined HAVE_OPENMP_OFFLOAD
1285 : : complex(dp), pointer :: xg__vecC(:,:)
1286 : : real(dp), pointer :: xg__vecR(:,:)
1287 : : #endif
1288 : :
1289 [ + + ]: 11266162 : if(xg%gpu_option==ABI_GPU_KOKKOS) then
1290 : : #if defined HAVE_GPU && defined HAVE_YAKL
1291 : : if ( associated(xg%vecR) ) then
1292 : : ABI_FREE_MANAGED(xg%vecR)
1293 : : end if
1294 : : if ( associated(xg%vecC) ) then
1295 : : ABI_FREE_MANAGED(xg%vecC)
1296 : : end if
1297 : : #endif
1298 : :
1299 : : else
1300 : : if(xg%gpu_option==ABI_GPU_OPENMP) then
1301 : : #if defined HAVE_GPU && defined HAVE_OPENMP_OFFLOAD
1302 : : if ( associated(xg%vecR) ) then
1303 : : xg__vecR => xg%vecR
1304 : : !$OMP TARGET EXIT DATA MAP(delete:xg__vecR)
1305 : : end if
1306 : : if ( associated(xg%vecC) ) then
1307 : : xg__vecC => xg%vecC
1308 : : !$OMP TARGET EXIT DATA MAP(delete:xg__vecC)
1309 : : end if
1310 : : #endif
1311 : : end if
1312 [ + + ]: 11263913 : if ( associated(xg%vecR) ) then
1313 : 3006746 : ABI_FREE(xg%vecR)
1314 : : end if
1315 [ + + ]: 11263913 : if ( associated(xg%vecC) ) then
1316 : 6991180 : ABI_FREE(xg%vecC)
1317 : : end if
1318 : :
1319 : : end if
1320 : :
1321 : 11266162 : end subroutine xg_free
1322 : : !!***
1323 : :
1324 : : !!****f* m_xg/space
1325 : : !!
1326 : : !! NAME
1327 : : !! space
1328 : :
1329 : 11912810 : function space(xgBlock)
1330 : :
1331 : : type(xgBlock_t), intent(in) :: xgBlock
1332 : : integer :: space
1333 : 11917180 : space = xgBlock%space
1334 : 8123060 : end function space
1335 : : !!***
1336 : :
1337 : : !!****f* m_xg/comm
1338 : : !!
1339 : : !! NAME
1340 : : !! comm
1341 : :
1342 : 7353477 : function comm(xgBlock)
1343 : : type(xgBlock_t), intent(in) :: xgBlock
1344 : : integer :: comm
1345 : 7353477 : comm = xgBlock%spacedim_comm
1346 : 5674096 : end function comm
1347 : : !!***
1348 : :
1349 : : !!****f* m_xg/me_g0
1350 : : !!
1351 : : !! NAME
1352 : : !! me_g0
1353 : :
1354 : 1265323 : function me_g0(xgBlock)
1355 : : type(xgBlock_t), intent(in) :: xgBlock
1356 : : integer :: me_g0
1357 : 1265323 : me_g0 = xgBlock%me_g0
1358 : 1265323 : end function me_g0
1359 : : !!***
1360 : :
1361 : : !!****f* m_xg/gpu_option
1362 : : !!
1363 : : !! NAME
1364 : : !! gpu_option
1365 : :
1366 : 0 : function gpu_option(xgBlock)
1367 : : type(xgBlock_t), intent(in) :: xgBlock
1368 : : integer :: gpu_option
1369 : 0 : gpu_option = xgBlock%gpu_option
1370 : 0 : end function gpu_option
1371 : : !!***
1372 : :
1373 : : !!****f* m_xg/setComm
1374 : : !!
1375 : : !! NAME
1376 : : !! setComm
1377 : :
1378 : 46134 : subroutine xgBlock_setComm(xgBlock,comm)
1379 : :
1380 : : type(xgBlock_t), intent(inout) :: xgBlock
1381 : : integer :: comm
1382 : 46134 : xgBlock%spacedim_comm = comm
1383 : :
1384 : 46134 : end subroutine xgBlock_setComm
1385 : : !!***
1386 : :
1387 : : !!****f* m_xg/cols
1388 : : !!
1389 : : !! NAME
1390 : : !! cols
1391 : :
1392 : 16352130 : function cols(xgBlock)
1393 : :
1394 : : type(xgBlock_t), intent(in) :: xgBlock
1395 : : integer :: cols
1396 : 16352130 : cols = xgBlock%cols
1397 : 12836295 : end function cols
1398 : : !!***
1399 : :
1400 : : !!****f* m_xg/rows
1401 : : !!
1402 : : !! NAME
1403 : : !! rows
1404 : :
1405 : 11978012 : function rows(xgBlock)
1406 : : type(xgBlock_t), intent(in) :: xgBlock
1407 : : integer :: rows
1408 : 11978012 : rows = xgBlock%rows
1409 : : !LB-31/05/24 : this warning is too verbose when activated... (even with correct coding!)
1410 : : !if ( rows /= xgBlock%ldim ) then
1411 : : ! ABI_WARNING("rows/ldim ! Be very careful at what you are doing")
1412 : : !end if
1413 : 8462177 : end function rows
1414 : : !!***
1415 : :
1416 : : !!****f* m_xg/xgBlock_copy
1417 : : !!
1418 : : !! NAME
1419 : : !! xgBlock_copy
1420 : :
1421 : 6662482 : subroutine xgBlock_copy(xgBlockA, xgBlockB, inc1, inc2)
1422 : :
1423 : : type(xgBlock_t), intent(in ) :: xgBlockA
1424 : : type(xgBlock_t), intent(inout) :: xgBlockB
1425 : : integer, optional, intent(in ) :: inc1
1426 : : integer, optional, intent(in ) :: inc2
1427 : :
1428 : : integer :: incx
1429 : : integer :: incy
1430 : :
1431 : : integer :: size1
1432 : : integer :: size2
1433 : : integer :: size
1434 : : double precision :: tsec(2)
1435 : : integer :: l_gpu_option
1436 : :
1437 : 6662482 : call timab(tim_copy,1,tsec)
1438 : :
1439 [ + - ]: 6662482 : if (xgBlockA%gpu_option==xgBlockB%gpu_option) then
1440 : 6662482 : l_gpu_option = xgBlockA%gpu_option
1441 : : else if ((xgBlockA%gpu_option==ABI_GPU_DISABLED.and.xgBlockB%gpu_option==ABI_GPU_LEGACY) &
1442 [ # # # # : 0 : .or. (xgBlockA%gpu_option==ABI_GPU_LEGACY .and.xgBlockB%gpu_option==ABI_GPU_DISABLED)) then
# # # # ]
1443 : 0 : l_gpu_option = ABI_GPU_DISABLED
1444 [ # # # # ]: 0 : else if (xgBlockA%gpu_option==ABI_GPU_DISABLED.and.xgBlockB%gpu_option==ABI_GPU_OPENMP) then
1445 : 0 : l_gpu_option = ABI_GPU_DISABLED
1446 : 0 : call xgBlock_copy_from_gpu(xgBlockB)
1447 [ # # # # ]: 0 : else if (xgBlockB%gpu_option==ABI_GPU_DISABLED.and.xgBlockA%gpu_option==ABI_GPU_OPENMP) then
1448 : 0 : l_gpu_option = ABI_GPU_DISABLED
1449 : 0 : call xgBlock_copy_from_gpu(xgBlockA)
1450 : : else
1451 : 0 : ABI_ERROR('xgA%gpu_option/=xgB%gpu_option is possible only with ABI_GPU_OPENMP, ABI_GPU_LEGACY or ABI_GPU_DISABLED')
1452 : : end if
1453 : :
1454 [ - + ]: 6662482 : incx = 1; if ( present(inc1) ) incx = inc1
1455 [ - + ]: 6662482 : incy = 1; if ( present(inc2) ) incy = inc2
1456 : :
1457 [ - + ]: 6662482 : if ( xgBlockA%space /= xgBlockB%space ) then
1458 : 0 : ABI_ERROR("Not same space")
1459 : : end if
1460 : : !if ( xgBlockA%LDim*xgBlockA%cols/incx /= xgBlockB%LDim*xgBlockB%cols/incy ) then
1461 : : ! ABI_ERROR("Number of element different")
1462 : : !end if
1463 : :
1464 [ - + ]: 6662482 : size1 = xgBlockA%LDim*xgBlockA%cols/incx ; if ( size1 * incx < xgBlockA%LDim*xgBlockA%cols ) size1 = size1+1
1465 [ - + ]: 6662482 : size2 = xgBlockB%LDim*xgBlockB%cols/incy ; if ( size2 * incy < xgBlockB%LDim*xgBlockB%cols ) size2 = size2+1
1466 : 6662482 : size = min(size1,size2)
1467 [ + + ]: 6662482 : if (xgBlockA%space==SPACE_CR) then
1468 : 675161 : size = 2*size
1469 : : end if
1470 : :
1471 : 6662482 : xgBlockB%me_g0 = xgBlockA%me_g0
1472 : :
1473 : 1893968 : select case(xgBlockA%space)
1474 : : case (SPACE_R,SPACE_CR)
1475 : 1893968 : call abi_xcopy(size, xgBlockA%vecR, incx, xgBlockB%vecR, incy, x_cplx=1, gpu_option=l_gpu_option)
1476 : : case (SPACE_C)
1477 [ + + - ]: 6662482 : call abi_xcopy(size, xgBlockA%vecC, incx, xgBlockB%vecC, incy, gpu_option=l_gpu_option)
1478 : : end select
1479 : :
1480 : 6662482 : call timab(tim_copy,2,tsec)
1481 : :
1482 : 6662482 : end subroutine xgBlock_copy
1483 : : !!***
1484 : :
1485 : : !!****f* m_xg/xgBlock_colwiseSwap
1486 : : !!
1487 : : !! NAME
1488 : : !! xgBlock_colwiseSwap
1489 : :
1490 : 0 : subroutine xgBlock_colwiseSwap(xgBlock, j, k, tmp)
1491 : :
1492 : : implicit none
1493 : :
1494 : : type(xgBlock_t), intent(inout) :: xgBlock
1495 : : integer, intent(in) :: j, k
1496 : : type(xgBlock_t), intent(inout) :: tmp
1497 : :
1498 : : type(xgBlock_t) :: col_j, col_k
1499 : :
1500 : 0 : if (j == k) return
1501 : :
1502 : 0 : call xgBlock_setBlock(xgBlock, col_j, xgBlock%rows, 1, j)
1503 : 0 : call xgBlock_setBlock(xgBlock, col_k, xgBlock%rows, 1, k)
1504 : :
1505 : 0 : call xgBlock_copy(col_j, tmp)
1506 : 0 : call xgBlock_copy(col_k, col_j)
1507 : 0 : call xgBlock_copy(tmp, col_k)
1508 : :
1509 [ # # ]: 0 : end subroutine xgBlock_colwiseSwap
1510 : : !!***
1511 : :
1512 : : !!****f* m_xg/xgBlock_partialcopy
1513 : : !!
1514 : : !! NAME
1515 : : !! xgBlock_partialcopy
1516 : :
1517 : 10314608 : subroutine xgBlock_partialcopy(xgBlock_in, xgBlock_out, shift_row, shift_col, option)
1518 : :
1519 : : type(xgBlock_t), intent(in ) :: xgBlock_in
1520 : : type(xgBlock_t), intent(inout) :: xgBlock_out
1521 : : integer,intent(in) :: shift_row,shift_col
1522 : : integer,intent(in) :: option
1523 : :
1524 : : integer :: icol,ncols_small,ncols_big
1525 : : integer :: nrows_small,nrows_big
1526 : : integer :: shift_col_big,end_row,max_col
1527 : : double precision :: tsec(2)
1528 : :
1529 : 10314608 : call timab(tim_partialcopy,1,tsec)
1530 : :
1531 [ - + ]: 10314608 : if (xgBlock_in%gpu_option/=ABI_GPU_DISABLED) then
1532 : 0 : ABI_ERROR('Not implemented for GPU')
1533 : : end if
1534 : 10314608 : call xgBlock_check_gpu_option(xgBlock_in,xgBlock_out)
1535 : :
1536 [ + + ]: 10314608 : if (option==SMALL2BIG) then
1537 : 4846372 : ncols_big = xgBlock_out%cols
1538 : 4846372 : nrows_big = xgBlock_out%rows
1539 : 4846372 : ncols_small = xgBlock_in%cols
1540 : 4846372 : nrows_small = xgBlock_in%rows
1541 [ + - ]: 5468236 : else if (option==BIG2SMALL) then
1542 : 5468236 : ncols_big = xgBlock_in%cols
1543 : 5468236 : nrows_big = xgBlock_in%rows
1544 : 5468236 : ncols_small = xgBlock_out%cols
1545 : 5468236 : nrows_small = xgBlock_out%rows
1546 : : else
1547 : 0 : ABI_ERROR('Bad option')
1548 : : end if
1549 [ - + ]: 10314608 : if (xgBlock_in%space/=xgBlock_out%space) then
1550 : 0 : ABI_ERROR('xgBlockA%space/=xgBlockB%space')
1551 : : end if
1552 [ - + ]: 10314608 : if (ncols_small>ncols_big) then
1553 : 0 : ABI_ERROR('ncols_small>ncols_big')
1554 : : end if
1555 [ - + ]: 10314608 : if (nrows_small>nrows_big) then
1556 : 0 : ABI_ERROR('nrows_small>nrows_big')
1557 : : end if
1558 [ - + ]: 10314608 : if (shift_row<0) then
1559 : 0 : ABI_ERROR('start_row<0')
1560 : : end if
1561 [ - + ]: 10314608 : if (shift_col<0) then
1562 : 0 : ABI_ERROR('start_col<0')
1563 : : end if
1564 : :
1565 : 10314608 : end_row = shift_row + nrows_small
1566 [ - + ]: 10314608 : if (end_row>nrows_big) then
1567 : 0 : ABI_ERROR('end_row>nrows_big')
1568 : : end if
1569 : :
1570 : 10314608 : max_col = shift_col + ncols_small
1571 [ - + ]: 10314608 : if (max_col>ncols_big) then
1572 : 0 : ABI_ERROR('max_col>nrows_big')
1573 : : end if
1574 : :
1575 [ + + ]: 10314608 : if (option==SMALL2BIG) then ! copy small matrix into the big one
1576 : 4846372 : select case(xgBlock_in%space)
1577 : : case (SPACE_R)
1578 [ + + ]: 4975136 : do icol=1,ncols_small
1579 : 2524560 : shift_col_big = shift_col + (icol-1)
1580 [ + + ]: 7797808 : xgBlock_out%vecR(1+shift_row:end_row,1+shift_col_big) = xgBlock_in%vecR(1:nrows_small,icol)
1581 : : end do
1582 : : case (SPACE_CR)
1583 [ + + ]: 1396560 : do icol=1,ncols_small
1584 : 1117248 : shift_col_big = shift_col + (icol-1)
1585 [ + + ]: 43450416 : xgBlock_out%vecR(1+2*shift_row:2*end_row,1+shift_col_big) = xgBlock_in%vecR(1:2*nrows_small,icol)
1586 : : end do
1587 : : case(SPACE_C)
1588 [ + + + - : 10674988 : do icol=1,ncols_small
+ + ]
1589 : 3712132 : shift_col_big = shift_col + (icol-1)
1590 [ + + ]: 74427844 : xgBlock_out%vecC(1+shift_row:end_row,1+shift_col_big) = xgBlock_in%vecC(1:nrows_small,icol)
1591 : : end do
1592 : : end select
1593 [ + - ]: 5468236 : else if (option==BIG2SMALL) then ! copy a part of the big matrix in the small one
1594 : 5468236 : select case(xgBlock_in%space)
1595 : : case (SPACE_R)
1596 [ + + ]: 4966272 : do icol=1,ncols_small
1597 : 2533184 : shift_col_big = shift_col + (icol-1)
1598 [ + + ]: 7902016 : xgBlock_out%vecR(1:nrows_small,icol) = xgBlock_in%vecR(1+shift_row:end_row,1+shift_col_big)
1599 : : end do
1600 : : case (SPACE_CR)
1601 [ + + ]: 609456 : if (shift_row>0) xgBlock_out%me_g0 = 0
1602 [ + + ]: 3047280 : do icol=1,ncols_small
1603 : 2437824 : shift_col_big = shift_col + (icol-1)
1604 [ + + ]: 93934800 : xgBlock_out%vecR(1:2*nrows_small,icol) = xgBlock_in%vecR(1+2*shift_row:2*end_row,1+shift_col_big)
1605 : : end do
1606 : : case(SPACE_C)
1607 [ + + + - : 13432580 : do icol=1,ncols_small
+ + ]
1608 : 5538652 : shift_col_big = shift_col + (icol-1)
1609 [ + + ]: 142557884 : xgBlock_out%vecC(1:nrows_small,icol) = xgBlock_in%vecC(1+shift_row:end_row,1+shift_col_big)
1610 : : end do
1611 : : end select
1612 : : else
1613 : 0 : ABI_ERROR('Bad option')
1614 : : end if
1615 : :
1616 : 10314608 : call timab(tim_partialcopy,2,tsec)
1617 : :
1618 : 10314608 : end subroutine xgBlock_partialcopy
1619 : : !!***
1620 : :
1621 : : !!****f* m_xg/xgBlock_permuteCols
1622 : : !!
1623 : : !! NAME
1624 : : !! xgBlock_permuteCols
1625 : : !!
1626 : : !! FUNCTION
1627 : : !! Sequential in-place permute columns of xgBlock according to index permutation pcol.
1628 : : !! Performs the swap M(i,j) = M(i,perm(j)) for j=1,m using LAPACK.
1629 : : !! Checks memory location before applying LAPACK on CPU /!\
1630 : : !! Warning: implicit GPU transfer to place on CPU.
1631 : : !!
1632 : 0 : subroutine xgBlock_permuteCols(xgBlock, rows, cols, pcol)
1633 : :
1634 : : type(xgBlock_t), intent(inout) :: xgBlock
1635 : : integer , intent(in) :: rows,cols
1636 : : integer , intent(in) :: pcol(cols)
1637 : :
1638 : : logical :: forwrd = .true.
1639 : :
1640 : : ! Size check
1641 [ # # ]: 0 : if (size(pcol,dim=1)/=cols) then
1642 : 0 : ABI_ERROR("Permutation size must be equal to number of columns")
1643 : : end if
1644 : :
1645 : : ! Device to host transfer
1646 : : if (xgBlock%gpu_option==ABI_GPU_OPENMP) then
1647 : : call xgBlock_copy_from_gpu(xgBlock)
1648 : : end if
1649 : :
1650 : : ! LAPACK calls
1651 : 0 : select case(xgBlock%space)
1652 : : case (SPACE_R)
1653 [ # # # # : 0 : call dlapmt(forwrd, rows, cols, xgBlock%vecR, xgBlock%LDim, pcol)
# # # # #
# # # #
# ]
1654 : : case (SPACE_CR)
1655 [ # # # # : 0 : call dlapmt(forwrd, 2*rows, cols, xgBlock%vecR, xgBlock%LDim, pcol)
# # # # #
# # # #
# ]
1656 : : case (SPACE_C)
1657 [ # # # # : 0 : call zlapmt(forwrd, rows, cols, xgBlock%vecC, xgBlock%LDim, pcol)
# # # # #
# # # #
# ]
1658 : : end select
1659 : :
1660 : : ! Update GPU with modified CPU memory
1661 : : if (xgBlock%gpu_option==ABI_GPU_OPENMP) then
1662 : : call xgBlock_copy_to_gpu(xgBlock)
1663 : : end if
1664 : :
1665 : 0 : end subroutine xgBlock_permuteCols
1666 : : !!***
1667 : :
1668 : : !!****f* m_xg/xgBlock_hermitian_pd_cond
1669 : : !!
1670 : : !! NAME
1671 : : !! xgBlock_hermitian_pf_cond
1672 : : !!
1673 : : !! FUNCTION
1674 : : !! Condition number with 2-norm.
1675 : : !! kappa2(A)
1676 : : !!
1677 : : !! Convention:
1678 : : !! for compatibility with xg_RayleighRitz_cprj,
1679 : : !! xgBlock stores the upper triangle of matrix
1680 : : !! uplo = 'u'
1681 : :
1682 : 0 : subroutine xgBlock_hermitian_pd_cond(xgBlock, n, cond2)
1683 : :
1684 : : implicit none
1685 : : type(xgBlock_t), intent(in) :: xgBlock
1686 : : integer, intent(in) :: n
1687 : : real(dp), intent(inout) :: cond2
1688 : :
1689 : 0 : complex(dpc) :: vecC(n,n)
1690 : 0 : real(dp) :: w(n)
1691 : 0 : complex(dp) :: work(2*n)
1692 : 0 : real(dp) :: rwork(3*n-2)
1693 : : integer :: info
1694 : : external :: zheev
1695 : :
1696 : : ! IML debug
1697 : : !write(901,*) 'space B', xgBlock%space
1698 : :
1699 : : !# Validation
1700 : : ! Fill Hermitian SPD matrix (upper triangle only)
1701 : : !vecC(1,1) = (4.0_dp, 0.0_dp)
1702 : : !vecC(1,2) = (1.0_dp, 0.5_dp)
1703 : : !vecC(2,1) = dconjg(vecC(1,2))
1704 : : !vecC(2,2) = (3.0_dp, 0.0_dp)
1705 : : !#
1706 : : ! comment following line
1707 : :
1708 : : ! Copy input since LAPACK overwrites matrix
1709 [ # # # # ]: 0 : vecC(1:n,1:n) = xgBlock%vecC(1:n,1:n)
1710 : :
1711 : : ! IML debug
1712 : : ! Objects are independent(check)
1713 : : !write(901,*) 'temp', vecC(1,11)
1714 : : !write(901,*) 'ref', xgBlock%vecC(1,11)
1715 : : !vecC(1,11) = 2222
1716 : : !write(901,*) 'new temp', vecC(1,11)
1717 : : !write(901,*) 'new ref', xgBlock%vecC(1,11)
1718 : : !flush(901)
1719 : :
1720 : 0 : call zheev('N','U', n, vecC, n, w, work, size(work), rwork, info)
1721 [ # # # # : 0 : cond2 = maxval(w) / minval(w)
# # # # #
# # # # #
# # ]
1722 : :
1723 : : ! IML debug
1724 : : !write(901,*) 'eigenval(=singval)='
1725 : : !write(901,*) w
1726 : : !flush(901)
1727 : :
1728 : 0 : end subroutine xgBlock_hermitian_pd_cond
1729 : : !!***
1730 : :
1731 : 0 : subroutine xgBlock_spd_cond(xgBlock, n, cond2)
1732 : :
1733 : : implicit none
1734 : : type(xgBlock_t), intent(in) :: xgBlock
1735 : : integer, intent(in) :: n
1736 : : real(dp), intent(inout) :: cond2
1737 : :
1738 : 0 : real(dp) :: vecR(n,n)
1739 : 0 : real(dp) :: w(n)
1740 : 0 : real(dp) :: rwork(8*n)
1741 : : integer :: info
1742 : : external :: dsyev
1743 : :
1744 [ # # # # ]: 0 : vecR(1:n,1:n) = xgBlock%vecR(1:n,1:n)
1745 : 0 : call dsyev('N','U', n, vecR, n, w, rwork, 8*n, info)
1746 [ # # # # : 0 : cond2 = abs(maxval(w) / minval(w))
# # # # #
# # # # #
# # ]
1747 : :
1748 : 0 : end subroutine xgBlock_spd_cond
1749 : :
1750 : : !!****f* m_xg/xgBlock_pack
1751 : : !!
1752 : : !! NAME
1753 : : !! xgBlock_pack
1754 : :
1755 : 0 : subroutine xgBlock_pack(xgBlockA,xgBlockB,uplo)
1756 : : use, intrinsic :: iso_c_binding
1757 : : type(xgBlock_t), intent(inout) :: xgBlockA
1758 : : type(xgBlock_t), intent(inout) :: xgBlockB
1759 : : character, intent(in) :: uplo
1760 : : integer :: j
1761 : : integer :: i
1762 : : integer :: col
1763 : : type(c_ptr) :: cptr
1764 : 0 : double precision, pointer :: subR(:)
1765 : 0 : complex(kind=8), pointer :: subC(:)
1766 : : double precision :: tsec(2)
1767 : :
1768 : 0 : call timab(tim_pack,1,tsec)
1769 [ # # ]: 0 : if ( xgBlockA%space /= xgBlockB%space ) then
1770 : 0 : ABI_ERROR("Both blocks must be the same space")
1771 : : end if
1772 : :
1773 [ # # ]: 0 : if ( xgBlockA%Ldim /= xgBlockA%rows ) then
1774 : 0 : ABI_ERROR("Cannot pack when ldim /= rows")
1775 : : end if
1776 : :
1777 [ # # ]: 0 : if ( xgBlockA%Ldim /= xgBlockA%cols ) then
1778 : 0 : ABI_ERROR("Cannot pack when cols /= rows")
1779 : : end if
1780 : :
1781 [ # # ]: 0 : if ( xgBlockA%rows*(xgBlockA%rows+1)/2 > xgBlockB%Ldim*xgBlockB%cols ) then
1782 : 0 : ABI_ERROR("Not enought memory in destination")
1783 : : end if
1784 : :
1785 : : ! make a fake pointer to pack in a 1-D array instead of 2
1786 : : ! This allows to directly use the lapack conventions of transformation
1787 : 0 : select case(xgBlockA%space)
1788 : : case (SPACE_R,SPACE_CR)
1789 [ # # # # : 0 : cptr = getClocR(xgBlockB%Ldim,xgBlockB%cols,xgBlockB%vecR(:,:))
# # # # #
# ]
1790 [ # # ]: 0 : call c_f_pointer(cptr,subR,(/ (xgBlockB%cols*(xgBlockB%cols+1))/2 /))
1791 : : case (SPACE_C)
1792 [ # # # # : 0 : cptr = getClocC(xgBlockB%Ldim,xgBlockB%cols,xgBlockB%vecC(:,:))
# # # # #
# ]
1793 [ # # # # : 0 : call c_f_pointer(cptr,subC,(/ (xgBlockB%cols*(xgBlockB%cols+1))/2 /))
# ]
1794 : : end select
1795 : :
1796 : 0 : select case(uplo)
1797 : : case ('u','U')
1798 : 0 : select case(xgBlockA%space)
1799 : : case (SPACE_R,SPACE_CR)
1800 [ # # ]: 0 : do j = 1, xgBlockA%cols
1801 : 0 : col = (j*(j-1))/2
1802 [ # # ]: 0 : do i = 1, j
1803 : 0 : subR(i+col) = xgBlockA%vecR(i,j)
1804 : : end do
1805 : : end do
1806 : : case (SPACE_C)
1807 [ # # # # : 0 : do j = 1, xgBlockA%cols
# ]
1808 : 0 : col = (j*(j-1))/2
1809 [ # # ]: 0 : do i = 1, j
1810 : 0 : subC(i+col) = xgBlockA%vecC(i,j)
1811 : : end do
1812 : : end do
1813 : : end select
1814 : :
1815 : : case ('l','L')
1816 : 0 : select case(xgBlockA%space)
1817 : : case (SPACE_R,SPACE_CR)
1818 [ # # ]: 0 : do j = 1, xgBlockA%cols
1819 : 0 : col = ((2*xgBlockA%cols-j)*(j-1))/2
1820 [ # # ]: 0 : do i = j, xgBlockA%cols
1821 : 0 : subR(i+col) = xgBlockA%vecR(i,j)
1822 : : end do
1823 : : end do
1824 : : case (SPACE_C)
1825 [ # # # # : 0 : do j = 1, xgBlockA%cols
# ]
1826 : 0 : col = ((2*xgBlockA%cols-j)*(j-1))/2
1827 [ # # ]: 0 : do i = j, xgBlockA%cols
1828 : 0 : subC(i+col) = xgBlockA%vecC(i,j)
1829 : : end do
1830 : : end do
1831 : : end select
1832 : : case default
1833 [ # # # ]: 0 : ABI_ERROR("Error for packing matrix")
1834 : : end select
1835 : 0 : call timab(tim_pack,2,tsec)
1836 : :
1837 : 0 : end subroutine xgBlock_pack
1838 : : !!***
1839 : :
1840 : : !!****f* m_xg/xgBlock_gemmR
1841 : : !!
1842 : : !! NAME
1843 : : !! xgBlock_gemmR
1844 : :
1845 : 17441284 : subroutine xgBlock_gemmR(transa, transb, alpha, xgBlockA, xgBlockB, beta, xgBlockW, comm, timing)
1846 : :
1847 : : character, intent(in ) :: transa
1848 : : character, intent(in ) :: transb
1849 : : double precision, intent(in ) :: alpha
1850 : : type(xgBlock_t), intent(in ) :: xgBlockA
1851 : : type(xgBlock_t), intent(in ) :: xgBlockB
1852 : : double precision, intent(in ) :: beta
1853 : : type(xgBlock_t), intent(inout) :: xgBlockW
1854 : : integer,optional, intent(in) :: comm
1855 : : logical,optional, intent(in) :: timing
1856 : :
1857 : : real(dp) :: alpha_
1858 : : complex(dp) :: calpha
1859 : : complex(dp) :: cbeta
1860 : : character(kind=1) :: transa_,transb_
1861 : : integer :: K
1862 : : double precision :: tsec(2)
1863 : : logical :: timing_
1864 : :
1865 : :
1866 : 17441284 : timing_ = .true.
1867 [ + + ]: 17441284 : if (present(timing)) then
1868 : 3527492 : timing_ = timing
1869 : : end if
1870 [ - + ]: 17441284 : if (timing_) call timab(tim_gemm_blas,1,tsec)
1871 : :
1872 : 17441284 : call xgBlock_check_gpu_option(xgBlockA,xgBlockB)
1873 : 17441284 : call xgBlock_check_gpu_option(xgBlockA,xgBlockW)
1874 : :
1875 [ - + ]: 17441284 : if (transa /= 'n' .and. transa /= 't') then
1876 : 0 : ABI_ERROR("transa should be 'n' or 't'")
1877 : : end if
1878 [ - + ]: 17441284 : if (transb /= 'n' .and. transb /= 't') then
1879 : 0 : ABI_ERROR("transb should be 'n' or 't'")
1880 : : end if
1881 : :
1882 [ + + ]: 17441284 : if ( transa == 'n' ) then
1883 : 10016774 : K = xgBlockA%cols
1884 [ - + ]: 10016774 : if ( xgBlockA%rows /= xgBlockW%rows ) then
1885 : 0 : ABI_ERROR("rows(A)/=rows(W)")
1886 : : end if
1887 : : else
1888 : 7424510 : K = xgBlockA%rows
1889 [ - + ]: 7424510 : if ( xgBlockA%cols /= xgBlockW%rows ) then
1890 : 0 : ABI_ERROR("cols(A)/=rows(W)")
1891 : : end if
1892 : : end if
1893 [ + - ]: 17441284 : if ( transb == 'n' ) then
1894 [ - + ]: 17441284 : if ( xgBlockB%cols /= xgBlockW%cols ) then
1895 : 0 : ABI_ERROR("cols(B)/=cols(W)")
1896 : : end if
1897 : : else
1898 [ # # ]: 0 : if ( xgBlockB%rows /= xgBlockW%cols ) then
1899 : 0 : ABI_ERROR("rows(B)/=cols(W)")
1900 : : end if
1901 : : end if
1902 : :
1903 : 17441284 : calpha = dcmplx(alpha,0.d0)
1904 : 17441284 : cbeta = dcmplx(beta, 0.d0)
1905 : :
1906 [ + + ]: 17441284 : if ( xgBlockA%space == xgBlockB%space ) then
1907 : :
1908 [ + + - + ]: 16507962 : if ( xgBlockA%space /= SPACE_CR .and. xgBlockW%space /= xgBlockA%space ) then
1909 : 0 : ABI_ERROR("Not same space for A and W")
1910 : : end if
1911 [ + + ]: 16507962 : if ( xgBlockA%space == SPACE_CR ) then
1912 [ + - - + ]: 1149714 : if ( transa/= 't' .or. transb /='n' ) then
1913 : 0 : ABI_ERROR("if space(A)==SPACE_CR, transa shoulbe 't' and transb shoulb 'n'")
1914 : : end if
1915 [ - + ]: 1149714 : if ( xgBlockW%space /= SPACE_R) then
1916 : 0 : ABI_ERROR("space(W) should be SPACE_R")
1917 : : end if
1918 [ - + ]: 1149714 : if (xgBlockA%me_g0<0) then
1919 : 0 : ABI_ERROR("xgBlockA me_g0 is not initialized")
1920 : : end if
1921 [ - + ]: 1149714 : if (xgBlockB%me_g0<0) then
1922 : 0 : ABI_ERROR("xgBlockB me_g0 is not initialized")
1923 : : end if
1924 [ - + ]: 1149714 : if (xgBlockA%me_g0/=xgBlockB%me_g0) then
1925 : 0 : ABI_ERROR("xgBlockA and xgBlockB should have same me_g0")
1926 : : end if
1927 : : end if
1928 : : ! CALL GEMM
1929 : 18899129 : select case(xgBlockA%space)
1930 : : case (SPACE_R)
1931 : : call abi_xgemm(transa, transb, xgBlockW%rows, xgBlockW%cols, K, &
1932 : : & calpha, &
1933 : : & xgBlockA%vecR, xgBlockA%LDim, &
1934 : : & xgBlockB%vecR, xgBlockB%LDim, &
1935 : : & cbeta, &
1936 : : & xgBlockW%vecR, xgBlockW%LDim, &
1937 [ + - - - : 2391167 : & x_cplx=1, gpu_option=xgBlockA%gpu_option)
- - - - +
- - - - -
- - + - -
- - - - -
- + - + -
+ - - -
- ]
1938 : :
1939 : : case (SPACE_CR)
1940 : 1149714 : calpha = dcmplx(2*alpha,0.d0)
1941 : 1149714 : alpha_ = 2.0d0 * alpha
1942 : : call abi_xgemm(transa, transb, xgBlockW%rows, xgBlockW%cols, 2*K, &
1943 : : & calpha, &
1944 : : & xgBlockA%vecR, 2*xgBlockA%LDim, &
1945 : : & xgBlockB%vecR, 2*xgBlockB%LDim, &
1946 : : & cbeta, &
1947 : : & xgBlockW%vecR, xgBlockW%LDim, &
1948 [ + - - - : 1149714 : & x_cplx=1, gpu_option=xgBlockA%gpu_option)
- - - - +
- - - - -
- - + - -
- - - - -
- + - + -
+ - - -
- ]
1949 [ + + ]: 1149714 : if (xgBlockA%me_g0 == 1) then
1950 : 85505 : calpha = dcmplx(-2*alpha,0.d0)
1951 : : call abi_xgemm(transa, transb, xgBlockW%rows, xgBlockW%cols, 2, &
1952 : : & calpha, &
1953 : : & xgBlockA%vecR, 2*xgBlockA%LDim, &
1954 : : & xgBlockB%vecR, 2*xgBlockB%LDim, &
1955 : : & cone, &
1956 : : & xgBlockW%vecR, xgBlockW%LDim, &
1957 [ + - - - : 85505 : & x_cplx=1, gpu_option=xgBlockA%gpu_option)
- - - - +
- - - - -
- - + - -
- - - - -
- + - + -
+ - - -
- ]
1958 : 85505 : calpha = dcmplx(alpha,0.d0)
1959 : : call abi_xgemm(transa, transb, xgBlockW%rows, xgBlockW%cols, 1, &
1960 : : & calpha, &
1961 : : & xgBlockA%vecR, 2*xgBlockA%LDim, &
1962 : : & xgBlockB%vecR, 2*xgBlockB%LDim, &
1963 : : & cone, &
1964 : : & xgBlockW%vecR, xgBlockW%LDim, &
1965 [ + - - - : 85505 : & x_cplx=1, gpu_option=xgBlockA%gpu_option)
- - - - +
- - - - -
- - + - -
- - - - -
- + - + -
+ - - -
- ]
1966 : : end if
1967 : :
1968 : : case(SPACE_C)
1969 : :
1970 : 12967081 : transa_=transa
1971 [ + + ]: 12967081 : if (transa=='t') transa_ = 'c'
1972 : 12967081 : transb_=transb
1973 [ - + ]: 12967081 : if (transb=='t') transb_ = 'c'
1974 : :
1975 : : call abi_xgemm(transa_, transb_, xgBlockW%rows, xgBlockW%cols, K, &
1976 : : & calpha, &
1977 : : & xgBlockA%vecC, xgBlockA%LDim, &
1978 : : & xgBlockB%vecC, xgBlockB%LDim, &
1979 : : & cbeta, &
1980 : : & xgBlockW%vecC, xgBlockW%LDim, &
1981 [ + + + - : 29475043 : & gpu_option=xgBlockA%gpu_option)
+ - - - -
- - - + -
- - - - -
- + - - -
- - - - -
+ - + - +
- - - - ]
1982 : :
1983 : : end select
1984 : :
1985 : : else ! not same space for A and B
1986 : :
1987 [ + - + - ]: 933322 : if (xgBlockA%space==SPACE_CR.and.xgBlockB%space==SPACE_R) then
1988 [ + - - + ]: 933322 : if (transa/='n'.or.transb/='n') then
1989 : 0 : ABI_ERROR('Not implemented')
1990 : : end if
1991 [ - + ]: 933322 : if (xgBlockW%space/=SPACE_CR) then
1992 : 0 : ABI_ERROR('space(W) should be SPACE_CR')
1993 : : end if
1994 : : call abi_xgemm(transa, transb, 2*xgBlockW%rows, xgBlockW%cols,K, &
1995 : : & calpha, &
1996 : : & xgBlockA%vecR, 2*xgBlockA%LDim, &
1997 : : & xgBlockB%vecR, xgBlockB%LDim, &
1998 : : & cbeta, &
1999 : : & xgBlockW%vecR,2*xgBlockW%LDim, &
2000 [ + - - - : 933322 : & x_cplx=1, gpu_option=xgBlockA%gpu_option)
- - - - +
- - - - -
- - + - -
- - - - -
- + - + -
+ - - -
- ]
2001 : : else
2002 : 0 : ABI_ERROR('Not implemented')
2003 : : end if
2004 : :
2005 : : end if
2006 : :
2007 [ + + ]: 17441284 : if (timing_) call timab(tim_gemm_blas,2,tsec)
2008 : : ! END CALL GEMM
2009 : :
2010 : : ! MPI SUM
2011 [ + + ]: 17441284 : if ( present(comm) ) then
2012 [ + - ]: 5043394 : if (timing_) call timab(tim_gemm_mpi,1,tsec)
2013 : 5043394 : call xgBlock_mpi_sum(xgBlockW,comm=comm)
2014 [ + - ]: 5043394 : if (timing_) call timab(tim_gemm_mpi,2,tsec)
2015 : : end if
2016 : :
2017 : 17441284 : end subroutine xgBlock_gemmR
2018 : : !!***
2019 : :
2020 : : !!****f* m_xg/xgBlock_gemmC
2021 : : !!
2022 : : !! NAME
2023 : : !! xgBlock_gemmC
2024 : :
2025 : 0 : subroutine xgBlock_gemmC(transa, transb, alpha, xgBlockA, xgBlockB, beta, xgBlockW, comm, timing)
2026 : :
2027 : : character, intent(in ) :: transa
2028 : : character, intent(in ) :: transb
2029 : : complex(kind=8), intent(in ) :: alpha
2030 : : type(xgBlock_t), intent(in ) :: xgBlockA
2031 : : type(xgBlock_t), intent(in ) :: xgBlockB
2032 : : complex(kind=8), intent(in ) :: beta
2033 : : type(xgBlock_t), intent(inout) :: xgBlockW
2034 : : integer,optional,intent(in) :: comm
2035 : : logical,optional,intent(in) :: timing
2036 : :
2037 : : integer :: K
2038 : : double precision :: tsec(2)
2039 : : character(kind=1) :: transa_,transb_
2040 : : logical :: timing_
2041 : :
2042 : 0 : timing_ = .true.
2043 [ # # ]: 0 : if (present(timing)) then
2044 : 0 : timing_ = timing
2045 : : end if
2046 [ # # ]: 0 : if (timing_) call timab(tim_gemm_blas,1,tsec)
2047 : :
2048 : 0 : call xgBlock_check_gpu_option(xgBlockA,xgBlockB)
2049 : 0 : call xgBlock_check_gpu_option(xgBlockA,xgBlockW)
2050 : :
2051 [ # # # # ]: 0 : if ( xgBlockA%space /= xgBlockB%space .or. xgBlockB%space /= xgBlockW%space ) then
2052 : 0 : ABI_ERROR("Not same space")
2053 : : end if
2054 [ # # ]: 0 : if ( xgBlockA%space /= SPACE_C ) then
2055 : 0 : ABI_ERROR("Not correct space")
2056 : : end if
2057 : :
2058 [ # # ]: 0 : if (transa /= 'n' .and. transa /= 't') then
2059 : 0 : ABI_ERROR("transa should be 'n' or 't'")
2060 : : end if
2061 [ # # ]: 0 : if (transb /= 'n' .and. transb /= 't') then
2062 : 0 : ABI_ERROR("transb should be 'n' or 't'")
2063 : : end if
2064 : :
2065 [ # # ]: 0 : if ( transa == 'n' ) then
2066 : 0 : K = xgBlockA%cols
2067 : : else
2068 : 0 : K = xgBlockA%rows
2069 : : end if
2070 : :
2071 : 0 : transa_=transa
2072 [ # # ]: 0 : if (transa=='t') transa_ = 'c'
2073 : 0 : transb_=transb
2074 [ # # ]: 0 : if (transb=='t') transb_ = 'c'
2075 : :
2076 : : ! CALL GEMM
2077 : : call abi_xgemm(transa_, transb_, xgBlockW%rows, xgBlockW%cols, K, &
2078 : : & alpha, &
2079 : : & xgBlockA%vecC, xgBlockA%LDim, &
2080 : : & xgBlockB%vecC, xgBlockB%LDim, &
2081 : : & beta, &
2082 : : & xgBlockW%vecC, xgBlockW%LDim, &
2083 [ # # # # : 0 : & gpu_option=xgBlockA%gpu_option)
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # #
# ]
2084 : : ! END CALL GEMM
2085 [ # # ]: 0 : if (timing_) call timab(tim_gemm_blas,2,tsec)
2086 : :
2087 : : ! MPI SUM
2088 [ # # ]: 0 : if ( present(comm) ) then
2089 [ # # ]: 0 : if (timing_) call timab(tim_gemm_mpi,1,tsec)
2090 : 0 : call xgBlock_mpi_sum(xgBlockW,comm=comm)
2091 [ # # ]: 0 : if (timing_) call timab(tim_gemm_mpi,2,tsec)
2092 : : end if
2093 : :
2094 : 0 : end subroutine xgBlock_gemmC
2095 : : !!***
2096 : :
2097 : : !!****f* m_xg/xgBlock_trmmR
2098 : : !!
2099 : : !! NAME
2100 : : !! xgBlock_trmmR
2101 : :
2102 : 0 : subroutine xgBlock_trmmR(side, uplo, transa, diag, alpha, xgBlockA, xgBlockB)
2103 : :
2104 : : character, intent(in) :: transa,side,uplo,diag
2105 : : double precision, intent(in) :: alpha
2106 : : type(xgBlock_t), intent(in) :: xgBlockA
2107 : : type(xgBlock_t), intent(inout) :: xgBlockB
2108 : :
2109 : : complex(kind=8) :: calpha
2110 : :
2111 [ # # ]: 0 : if (xgBlockA%gpu_option/=ABI_GPU_DISABLED) then
2112 : 0 : ABI_ERROR('Not implemented for GPU')
2113 : : end if
2114 : 0 : call xgBlock_check_gpu_option(xgBlockA,xgBlockB)
2115 : :
2116 [ # # ]: 0 : if ( xgBlockA%space /= xgBlockB%space .or. xgBlockB%space /= xgBlockB%space ) then
2117 : 0 : ABI_ERROR("Not same space")
2118 : : end if
2119 : :
2120 : 0 : select case(xgBlockA%space)
2121 : : case (SPACE_R)
2122 : : call dtrmm(side,uplo,transa,diag,transa,xgBlockB%rows,xgBlockB%cols,&
2123 : : alpha,xgBlockA%vecR, xgBlockA%LDim, &
2124 [ # # # # : 0 : xgBlockB%vecR, xgBlockB%LDim)
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
2125 : : case (SPACE_CR)
2126 : 0 : ABI_ERROR("Not implemented")
2127 : : !call dtrmm(side,uplo,transa,diag,transa,xgBlockB%rows,xgBlockB%cols,&
2128 : : ! alpha,xgBlockA%vecR, xgBlockA%LDim, &
2129 : : ! xgBlockB%vecR, xgBlockB%LDim)
2130 : : case(SPACE_C)
2131 : 0 : calpha = dcmplx(alpha,0.d0)
2132 : : call ztrmm(side,uplo,transa,diag,transa,xgBlockB%rows,xgBlockB%cols,&
2133 : : calpha,xgBlockA%vecC, xgBlockA%LDim, &
2134 [ # # # # : 0 : xgBlockB%vecC, xgBlockB%LDim)
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # ]
2135 : : end select
2136 : :
2137 : 0 : end subroutine xgBlock_trmmR
2138 : : !!***
2139 : :
2140 : : !!****f* m_xg/xgBlock_potrf
2141 : : !!
2142 : : !! NAME
2143 : : !! xgBlock_potrf
2144 : :
2145 : 794171 : subroutine xgBlock_potrf(xgBlock,uplo,info)
2146 : :
2147 : : type(xgBlock_t), intent(inout) :: xgBlock
2148 : : character , intent(in ) :: uplo
2149 : : integer , intent( out) :: info
2150 : : double precision :: tsec(2)
2151 : :
2152 : 794171 : call timab(tim_potrf,1,tsec)
2153 : :
2154 [ - + ]: 794171 : if ( xgBlock%rows /= xgBlock%cols ) then
2155 : 0 : ABI_ERROR("Matrix should be a square matrixx")
2156 : : endif
2157 : :
2158 : 889227 : select case(xgBlock%space)
2159 : : case (SPACE_R)
2160 : : call abi_xpotrf(uplo,xgBlock%rows,xgBlock%vecR,xgBlock%LDim,info, &
2161 [ + - - - : 95056 : x_cplx=1,gpu_option=xgBlock%gpu_option)
- - - - -
+ - - -
- ]
2162 : : case (SPACE_C)
2163 : : call abi_xpotrf(uplo,xgBlock%rows,xgBlock%vecC,xgBlock%LDim,info, &
2164 [ + - - - : 699115 : gpu_option=xgBlock%gpu_option)
- - - - -
+ - - -
- ]
2165 : : case (SPACE_CR)
2166 [ + + - - ]: 794171 : ABI_ERROR('Not implemented for SPACE_CR')
2167 : : end select
2168 : :
2169 [ - + ]: 794171 : if(xgBlock%gpu_option==ABI_GPU_KOKKOS) call gpu_device_synchronize()
2170 : :
2171 : 794171 : call timab(tim_potrf,2,tsec)
2172 : :
2173 : 794171 : end subroutine xgBlock_potrf
2174 : : !!***
2175 : :
2176 : : !!****f* m_xg/xgBlock_heev
2177 : : !!
2178 : : !! NAME
2179 : : !! xgBlock_heev
2180 : :
2181 : :
2182 : : !===================================================
2183 : : != Hermitian Full Matrix diago
2184 : : !===================================================
2185 : 0 : subroutine xgBlock_heev(jobz,uplo,xgBlockA,xgBlockW,info)
2186 : :
2187 : : character , intent(in ) :: jobz
2188 : : character , intent(in ) :: uplo
2189 : : type(xgBlock_t) , intent(inout) :: xgBlockA
2190 : : type(xgBlock_t) , intent(inout) :: xgBlockW
2191 : : integer , intent( out) :: info
2192 : : double precision :: tsec(2)
2193 : :
2194 : 0 : call timab(tim_heev,1,tsec)
2195 : :
2196 [ # # ]: 0 : if ( xgBlockW%space /= SPACE_R ) then
2197 : 0 : ABI_ERROR("Block3 must be real")
2198 : : end if
2199 : :
2200 : 0 : select case(xgBlockA%space)
2201 : :
2202 : : case (SPACE_R)
2203 : 0 : call checkResize(rwork,lrwork,8*xgBlockA%rows)
2204 : :
2205 : : call dsyev(jobz,uplo,xgBlockA%cols, &
2206 : : xgBlockA%vecR,xgBlockA%LDim, &
2207 : : xgBlockW%vecR, &
2208 [ # # # # : 0 : rwork, lrwork,info)
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
2209 : :
2210 : :
2211 : : case (SPACE_C)
2212 : 0 : call checkResize(rwork,lrwork,3*xgBlockA%cols-2)
2213 : 0 : call checkResize(cwork,lcwork,lrwork)
2214 : :
2215 : : call zheev(jobz,uplo,xgBlockA%cols, &
2216 : : xgBlockA%vecC,xgBlockA%LDim, &
2217 : : xgBlockW%vecR, &
2218 [ # # # # : 0 : cwork, lrwork, rwork, info)
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
2219 : :
2220 : : case (SPACE_CR)
2221 [ # # # # ]: 0 : ABI_ERROR('Not implemented for SPACE_CR')
2222 : :
2223 : : end select
2224 : :
2225 [ # # ]: 0 : if ( rwork(1) > lrwork ) then
2226 : : !write(std_out,*) "Allocate work from", lrwork, "to", int(rwork(1))
2227 : 0 : call checkResize(rwork,lrwork,int(rwork(1)))
2228 : : end if
2229 : :
2230 : 0 : call timab(tim_heev,2,tsec)
2231 : :
2232 : 0 : end subroutine xgBlock_heev
2233 : : !!***
2234 : :
2235 : : !!****f* m_xg/xgBlock_heevd
2236 : : !!
2237 : : !! NAME
2238 : : !! xgBlock_heevd
2239 : :
2240 : 178245 : subroutine xgBlock_heevd(jobz, uplo, xgBlockA, xgBlockW, info)
2241 : :
2242 : : character , intent(in ) :: jobz
2243 : : character , intent(in ) :: uplo
2244 : : type(xgBlock_t) , intent(inout) :: xgBlockA
2245 : : type(xgBlock_t) , intent(inout) :: xgBlockW
2246 : : integer , intent( out) :: info
2247 : : double precision :: tsec(2)
2248 : :
2249 : 178245 : call timab(tim_heevd,1,tsec)
2250 : :
2251 : 178245 : call xgBlock_check_gpu_option(xgBlockA,xgBlockW)
2252 : :
2253 [ - + ]: 178245 : if ( xgBlockW%space /= SPACE_R ) then
2254 : 0 : ABI_ERROR("Block3 must be real")
2255 : : end if
2256 : :
2257 [ - + ]: 178245 : if (xgBlockA%gpu_option==ABI_GPU_KOKKOS .or. xgBlockA%gpu_option==ABI_GPU_OPENMP) then
2258 : 0 : select case(xgBlockA%space)
2259 : :
2260 : : case (SPACE_R)
2261 : : call abi_xheevd(jobz, uplo, xgBlockA%cols, &
2262 : : xgBlockA%vecR, xgBlockA%LDim, &
2263 : : xgBlockW%vecR, info, &
2264 : 0 : x_cplx=1, gpu_option=xgBlockA%gpu_option)
2265 : :
2266 : : case (SPACE_C)
2267 : : call abi_xheevd(jobz, uplo, xgBlockA%cols, &
2268 : : xgBlockA%vecC, xgBlockA%LDim, &
2269 : : xgBlockW%vecR, info, &
2270 : 0 : gpu_option=xgBlockA%gpu_option)
2271 : :
2272 : : case (SPACE_CR)
2273 [ # # # # ]: 0 : ABI_ERROR('Not implemented for SPACE_CR')
2274 : :
2275 : : end select
2276 : :
2277 [ # # ]: 0 : if(xgBlockA%gpu_option==ABI_GPU_KOKKOS) call gpu_device_synchronize()
2278 : :
2279 : : else
2280 : :
2281 : 178245 : call checkResize(iwork,liwork,5*xgBlockA%rows+3)
2282 : :
2283 : 202993 : select case(xgBlockA%space)
2284 : :
2285 : : case (SPACE_R)
2286 : 24748 : call checkResize(rwork,lrwork,2*xgBlockA%rows*xgBlockA%rows+6*xgBlockA%rows+1)
2287 : :
2288 : : call dsyevd(jobz,uplo,xgBlockA%cols, &
2289 : : xgBlockA%vecR,xgBlockA%LDim, &
2290 : : xgBlockW%vecR, rwork, lrwork, &
2291 [ + - - - : 24748 : iwork, liwork,info)
- - - - +
- - - - -
- - - + -
- - - - +
- - - - ]
2292 : :
2293 : : case (SPACE_C)
2294 : 153497 : call checkResize(cwork,lcwork,xgBlockA%rows*xgBlockA%rows+2*xgBlockA%rows)
2295 : 153497 : call checkResize(rwork,lrwork,2*xgBlockA%rows*xgBlockA%rows+5*xgBlockA%rows+1)
2296 : :
2297 : : call zheevd(jobz,uplo,xgBlockA%cols, &
2298 : : xgBlockA%vecC,xgBlockA%LDim, &
2299 : : xgBlockW%vecR, &
2300 [ + - - - : 153497 : cwork, lcwork, rwork, lrwork, iwork, liwork, info)
- - - - +
- - - - -
- - - + -
- - - - +
- - - - ]
2301 : :
2302 [ + + ]: 153497 : if ( int(cwork(1)) > lcwork ) then
2303 : : !write(std_out,*) "Allocate work from", int(lcwork), "to", int(cwork(1))
2304 : 295 : call checkResize(cwork,lcwork,int(cwork(1)))
2305 : : end if
2306 : :
2307 : : case (SPACE_CR)
2308 [ + + - - ]: 178245 : ABI_ERROR('Not implemented for SPACE_CR')
2309 : :
2310 : : end select
2311 : :
2312 [ - + ]: 178245 : if ( rwork(1) > lrwork ) then
2313 : : !write(std_out,*) "Allocate work from", lrwork, "to", int(rwork(1))
2314 : 0 : call checkResize(rwork,lrwork,int(rwork(1)))
2315 : : end if
2316 : :
2317 [ - + ]: 178245 : if ( iwork(1) > liwork ) then
2318 : : !write(std_out,*) "Allocate work from", liwork, "to", int(iwork(1))
2319 : 0 : call checkResize(iwork,liwork,int(iwork(1)))
2320 : : end if
2321 : :
2322 : : end if
2323 : :
2324 : :
2325 : 178245 : call timab(tim_heevd,2,tsec)
2326 : :
2327 : 178245 : end subroutine xgBlock_heevd
2328 : : !!***
2329 : :
2330 : : !!****f* m_xg/xgBlock_hpev
2331 : : !!
2332 : : !! NAME
2333 : : !! xgBlock_hpev
2334 : :
2335 : : !===================================================
2336 : : != Hermitian Packed Matrix diago
2337 : : !===================================================
2338 : 0 : subroutine xgBlock_hpev(jobz,uplo,xgBlockAP,xgBlockW,xgBlockZ,info)
2339 : :
2340 : : character , intent(in ) :: jobz
2341 : : character , intent(in ) :: uplo
2342 : : type(xgBlock_t) , intent(inout) :: xgBlockAP
2343 : : type(xgBlock_t) , intent(inout) :: xgBlockW
2344 : : type(xgBlock_t) , intent(inout) :: xgBlockZ
2345 : : integer , intent( out) :: info
2346 : : double precision :: tsec(2)
2347 : :
2348 : 0 : call timab(tim_hpev,1,tsec)
2349 : :
2350 [ # # ]: 0 : if ( xgBlockAP%space /= xgBlockZ%space ) then
2351 : 0 : ABI_ERROR("Not same space")
2352 : : end if
2353 : :
2354 [ # # ]: 0 : if ( xgBlockW%space /= SPACE_R ) then
2355 : 0 : ABI_ERROR("Block3 must be real")
2356 : : end if
2357 : :
2358 : 0 : select case(xgBlockAP%space)
2359 : :
2360 : : case (SPACE_R)
2361 : 0 : call checkResize(rwork,lrwork,3*xgBlockZ%cols)
2362 : :
2363 : : call dspev(jobz,uplo,xgBlockZ%cols, &
2364 : : xgBlockAP%vecR, xgBlockW%vecR, xgBlockZ%vecR, xgBlockZ%Ldim, &
2365 [ # # # # : 0 : rwork, info)
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # ]
2366 : :
2367 : :
2368 : : case (SPACE_C)
2369 : 0 : call checkResize(cwork,lcwork,2*xgBlockZ%cols-1)
2370 : 0 : call checkResize(rwork,lrwork,3*xgBlockZ%cols-2)
2371 : :
2372 : : call zhpev(jobz,uplo,xgBlockZ%cols, &
2373 : : xgBlockAP%vecC, xgBlockW%vecR, xgBlockZ%vecC, xgBlockZ%Ldim, &
2374 [ # # # # : 0 : cwork, rwork, info)
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # ]
2375 : :
2376 [ # # ]: 0 : if ( int(cwork(1)) > lcwork ) then
2377 : : !write(std_out,*) "Allocate cwork from", lcwork, "to", int(cwork(1))
2378 : 0 : call checkResize(cwork,lcwork,int(cwork(1)))
2379 : : end if
2380 : :
2381 : : case (SPACE_CR)
2382 [ # # # # ]: 0 : ABI_ERROR('Not implemented for SPACE_CR')
2383 : :
2384 : : end select
2385 : :
2386 [ # # ]: 0 : if ( rwork(1) > lrwork ) then
2387 : : !write(std_out,*) "Allocate work from", lrwork, "to", int(rwork(1))
2388 : 0 : call checkResize(rwork,lrwork,int(rwork(1)))
2389 : : end if
2390 : :
2391 : 0 : call timab(tim_hpev,2,tsec)
2392 : :
2393 : 0 : end subroutine xgBlock_hpev
2394 : : !!***
2395 : :
2396 : : !!****f* m_xg/xgBlock_hpevd
2397 : : !!
2398 : : !! NAME
2399 : : !! xgBlock_hpevd
2400 : :
2401 : 0 : subroutine xgBlock_hpevd(jobz,uplo,xgBlockAP,xgBlockW,xgBlockZ,info)
2402 : :
2403 : : character , intent(in ) :: jobz
2404 : : character , intent(in ) :: uplo
2405 : : type(xgBlock_t) , intent(inout) :: xgBlockAP
2406 : : type(xgBlock_t) , intent(inout) :: xgBlockW
2407 : : type(xgBlock_t) , intent(inout) :: xgBlockZ
2408 : : integer , intent( out) :: info
2409 : : double precision :: tsec(2)
2410 : :
2411 : 0 : call timab(tim_hpevd,1,tsec)
2412 : :
2413 [ # # ]: 0 : if ( xgBlockW%space /= SPACE_R ) then
2414 : 0 : ABI_ERROR("Block3 must be real")
2415 : : end if
2416 : :
2417 [ # # ]: 0 : if ( xgBlockAP%space /= xgBlockZ%space ) then
2418 : 0 : ABI_ERROR("Block 1 and 3 must have the same space")
2419 : : end if
2420 : :
2421 : 0 : call checkResize(iwork,liwork,5*xgBlockZ%rows+3)
2422 : 0 : select case(xgBlockAP%space)
2423 : :
2424 : : case (SPACE_R)
2425 : 0 : call checkResize(rwork,lrwork,xgBlockZ%rows*xgBlockZ%rows+6*xgBlockZ%rows+1)
2426 : :
2427 : : call dspevd(jobz,uplo,xgBlockZ%cols, &
2428 : : xgBlockAP%vecR, xgBlockW%vecR, xgBlockZ%vecR, xgBlockZ%Ldim, &
2429 [ # # # # : 0 : rwork, lrwork, iwork, liwork,info)
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # ]
2430 : :
2431 : :
2432 : : case (SPACE_C)
2433 : 0 : call checkResize(cwork,lcwork,2*xgBlockZ%rows)
2434 : 0 : call checkResize(rwork,lrwork,2*xgBlockZ%rows*xgBlockZ%rows+5*xgBlockZ%rows+1)
2435 : :
2436 : : call zhpevd(jobz,uplo,xgBlockZ%cols, &
2437 : : xgBlockAP%vecC, xgBlockW%vecR, xgBlockZ%vecC, xgBlockZ%Ldim, &
2438 [ # # # # : 0 : cwork, lcwork, rwork, lrwork, iwork, liwork, info)
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # ]
2439 : :
2440 [ # # ]: 0 : if ( int(cwork(1)) > lcwork ) then
2441 : : !write(std_out,*) "Allocate work from", lcwork, "to", int(cwork(1))
2442 : 0 : call checkResize(cwork,lcwork,int(cwork(1)))
2443 : : end if
2444 : :
2445 : : case (SPACE_CR)
2446 [ # # # # ]: 0 : ABI_ERROR('Not implemented for SPACE_CR')
2447 : :
2448 : : end select
2449 : :
2450 [ # # ]: 0 : if ( int(rwork(1)) > lrwork ) then
2451 : : !write(std_out,*) "Allocate work from", lrwork, "to", int(rwork(1))
2452 : 0 : call checkResize(rwork,lrwork,int(rwork(1)))
2453 : : end if
2454 : :
2455 [ # # ]: 0 : if ( iwork(1) > liwork ) then
2456 : : !write(std_out,*) "Allocate work from", liwork, "to", int(iwork(1))
2457 : 0 : call checkResize(iwork,liwork,int(iwork(1)))
2458 : : end if
2459 : :
2460 : 0 : call timab(tim_hpevd,2,tsec)
2461 : :
2462 : 0 : end subroutine xgBlock_hpevd
2463 : : !!***
2464 : :
2465 : : !!****f* m_xg/xgBlock_hgev
2466 : : !!
2467 : : !! NAME
2468 : : !! xgBlock_hgev
2469 : :
2470 : : !===================================================
2471 : : != Hermitian Full Generalized Matrix diago
2472 : : !===================================================
2473 : :
2474 : 0 : subroutine xgBlock_hegv(itype, jobz, uplo, xgBlockA, xgBlockB, xgBlockW, info)
2475 : :
2476 : : integer , intent(in ) :: itype
2477 : : character , intent(in ) :: jobz
2478 : : character , intent(in ) :: uplo
2479 : : type(xgBlock_t) , intent(inout) :: xgBlockA
2480 : : type(xgBlock_t) , intent(inout) :: xgBlockB
2481 : : type(xgBlock_t) , intent(inout) :: xgBlockW
2482 : : integer , intent( out) :: info
2483 : : double precision :: tsec(2)
2484 : :
2485 : 0 : call timab(tim_hegv,1,tsec)
2486 : :
2487 [ # # ]: 0 : if ( xgBlockA%space /= xgBlockB%space ) then
2488 : 0 : ABI_ERROR("Not same space")
2489 : : end if
2490 [ # # ]: 0 : if ( xgBlockW%space /= SPACE_R ) then
2491 : 0 : ABI_ERROR("Block3 must be real")
2492 : : end if
2493 : :
2494 : 0 : select case(xgBlockA%space)
2495 : :
2496 : : case (SPACE_R)
2497 : 0 : call checkResize(rwork,lrwork,2*xgBlockA%rows*xgBlockA%rows+6*xgBlockA%rows+1)
2498 : :
2499 : : call dsygv(itype, jobz, uplo, xgBlockA%rows, xgBlockA%vecR, xgBlockA%ldim, &
2500 [ # # # # : 0 : xgBlockB%vecR, xgBlockB%ldim, xgBlockW%vecR, rwork, lrwork, info)
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # ]
2501 : :
2502 : : case (SPACE_C)
2503 : :
2504 : 0 : call checkResize(cwork,lcwork,2*xgBlockA%rows-1)
2505 : 0 : call checkResize(rwork,lrwork,3*xgBlockA%rows-2)
2506 : :
2507 : : call zhegv(itype, jobz, uplo, xgBlockA%rows, xgBlockA%vecC, xgBlockA%ldim,&
2508 : : xgBlockB%vecC, xgBlockB%ldim, xgBlockW%vecR, cwork, lcwork, &
2509 [ # # # # : 0 : rwork, info)
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # ]
2510 : :
2511 [ # # ]: 0 : if ( int(cwork(1)) > lcwork ) then
2512 : : !write(std_out,*) "Allocate work from", lcwork, "to", int(cwork(1))
2513 : 0 : call checkResize(cwork,lcwork,int(cwork(1)))
2514 : : end if
2515 : :
2516 : : case (SPACE_CR)
2517 [ # # # # ]: 0 : ABI_ERROR('Not implemented for SPACE_CR')
2518 : :
2519 : : end select
2520 : :
2521 [ # # ]: 0 : if ( rwork(1) > lrwork ) then
2522 : : !write(std_out,*) "Allocate rwork from", lrwork, "to", int(rwork(1))
2523 : 0 : call checkResize(rwork,lrwork,int(rwork(1)))
2524 : : end if
2525 : :
2526 : 0 : call timab(tim_hegv,2,tsec)
2527 : :
2528 : 0 : end subroutine xgBlock_hegv
2529 : : !!***
2530 : :
2531 : : !!****f* m_xg/xgBlock_hegvx
2532 : : !!
2533 : : !! NAME
2534 : : !! xgBlock_hegvx
2535 : :
2536 : 0 : subroutine xgBlock_hegvx(itype,jobz,range,uplo,xgBlockA,xgBlockB,vl,vu,il,iu,abstol,xgBlockW,xgBlockZ,info)
2537 : :
2538 : : integer , intent(in ) :: itype
2539 : : character , intent(in ) :: jobz
2540 : : character , intent(in ) :: range
2541 : : character , intent(in ) :: uplo
2542 : : type(xgBlock_t) , intent(inout) :: xgBlockA
2543 : : type(xgBlock_t) , intent(inout) :: xgBlockB
2544 : : double precision, intent(in ) :: vl
2545 : : double precision, intent(in ) :: vu
2546 : : integer , intent(in ) :: il
2547 : : integer , intent(in ) :: iu
2548 : : double precision, intent(in ) :: abstol
2549 : : type(xgBlock_t) , intent(inout) :: xgBlockW
2550 : : type(xgBlock_t) , intent(inout) :: xgBlockZ
2551 : : integer , intent( out) :: info
2552 : : integer :: neigen
2553 : 0 : integer, allocatable :: ifail(:)
2554 : : double precision :: tsec(2)
2555 : :
2556 : 0 : call timab(tim_hegvx,1,tsec)
2557 : :
2558 [ # # # # ]: 0 : if ( xgBlockA%space /= xgBlockB%space .or. xgBlockA%space /= xgBlockZ%space ) then
2559 : 0 : ABI_ERROR("Not same space")
2560 : : end if
2561 [ # # ]: 0 : if ( xgBlockW%space /= SPACE_R ) then
2562 : 0 : ABI_ERROR("Block3 must be real")
2563 : : end if
2564 : :
2565 : 0 : call checkResize(iwork,liwork,5*xgBlockA%rows)
2566 : :
2567 [ # # # # : 0 : ABI_MALLOC(ifail,(xgBlockA%rows))
# # # # #
# # # ]
2568 [ # # ]: 0 : ifail = 0
2569 : :
2570 : 0 : select case(xgBlockA%space)
2571 : :
2572 : : case (SPACE_R)
2573 : 0 : call checkResize(rwork,lrwork,8*xgBlockA%rows)
2574 : :
2575 : : call dsygvx(itype,jobz,range,uplo,xgBlockA%rows, &
2576 : : xgBlockA%vecR,xgBlockA%LDim,xgBlockB%vecR,xgBlockB%LDim, &
2577 : : vl,vu,il,iu,abstol,&
2578 : : neigen,xgBlockW%vecR, xgBlockZ%vecR, xgBlockZ%LDim, &
2579 [ # # # # : 0 : rwork, lrwork,iwork,ifail,info)
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
2580 : :
2581 : : case (SPACE_C)
2582 : 0 : call checkResize(rwork,lrwork,7*xgBlockA%rows)
2583 : 0 : call checkResize(cwork,lcwork,lrwork)
2584 : :
2585 : : call zhegvx(itype,jobz,range,uplo,xgBlockA%rows, &
2586 : : xgBlockA%vecC,xgBlockA%LDim,xgBlockB%vecC,xgBlockB%LDim, &
2587 : : vl,vu,il,iu,abstol,&
2588 : : neigen,xgBlockW%vecR, xgBlockZ%vecC, xgBlockZ%LDim, &
2589 [ # # # # : 0 : cwork, lcwork, rwork, iwork,ifail,info)
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
2590 : :
2591 : : case (SPACE_CR)
2592 [ # # # # ]: 0 : ABI_ERROR('Not implemented for SPACE_CR')
2593 : :
2594 : : end select
2595 [ # # ]: 0 : ABI_FREE(ifail)
2596 : :
2597 [ # # ]: 0 : if ( rwork(1) > lrwork ) then
2598 : : !write(std_out,*) "Allocate work from", lrwork, "to", int(rwork(1))
2599 : 0 : call checkResize(rwork,lrwork,int(rwork(1)))
2600 : : end if
2601 : :
2602 : :
2603 : 0 : call timab(tim_hegvx,2,tsec)
2604 : :
2605 : 0 : end subroutine xgBlock_hegvx
2606 : : !!***
2607 : :
2608 : : !!****f* m_xg/xgBlock_hegvd
2609 : : !!
2610 : : !! NAME
2611 : : !! xgBlock_hegvd
2612 : :
2613 : 642542 : subroutine xgBlock_hegvd(itype, jobz, uplo, xgBlockA, xgBlockB, xgBlockW, info)
2614 : :
2615 : : integer , intent(in ) :: itype
2616 : : character , intent(in ) :: jobz
2617 : : character , intent(in ) :: uplo
2618 : : type(xgBlock_t) , intent(inout) :: xgBlockA
2619 : : type(xgBlock_t) , intent(inout) :: xgBlockB
2620 : : type(xgBlock_t) , intent(inout) :: xgBlockW
2621 : : integer , intent( out) :: info
2622 : :
2623 : : double precision :: tsec(2)
2624 : :
2625 : :
2626 : 642542 : call timab(tim_hegvd,1,tsec)
2627 : :
2628 [ - + ]: 642542 : if ( xgBlockA%space /= xgBlockB%space ) then
2629 : 0 : ABI_ERROR("Not same space")
2630 : : end if
2631 [ - + ]: 642542 : if ( xgBlockW%space /= SPACE_R ) then
2632 : 0 : ABI_ERROR("Block3 must be real")
2633 : : end if
2634 : :
2635 : 642542 : call xgBlock_check_gpu_option(xgBlockA,xgBlockB)
2636 : 642542 : call xgBlock_check_gpu_option(xgBlockA,xgBlockW)
2637 : :
2638 [ - + ]: 642542 : if (xgBlockA%gpu_option==ABI_GPU_KOKKOS .or. xgBlockA%gpu_option==ABI_GPU_OPENMP) then
2639 : :
2640 : 0 : select case(xgBlockA%space)
2641 : :
2642 : : case (SPACE_R)
2643 : : call abi_xhegvd(itype, jobz, uplo, xgBlockA%rows, &
2644 : : xgBlockA%vecR, xgBlockA%ldim, &
2645 : : xgBlockB%vecR, xgBlockB%ldim, &
2646 : : xgBlockW%vecR, info, &
2647 : 0 : x_cplx=1, gpu_option=xgBlockA%gpu_option)
2648 : :
2649 : : case (SPACE_C)
2650 : : call abi_xhegvd(itype, jobz, uplo, xgBlockA%rows, &
2651 : : xgBlockA%vecC, xgBlockA%ldim, &
2652 : : xgBlockB%vecC, xgBlockB%ldim, &
2653 : : xgBlockW%vecR, info, &
2654 : 0 : gpu_option=xgBlockA%gpu_option)
2655 : :
2656 : : case (SPACE_CR)
2657 [ # # # # ]: 0 : ABI_ERROR('Not implemented for SPACE_CR')
2658 : :
2659 : : end select
2660 : :
2661 [ # # ]: 0 : if(xgBlockA%gpu_option==ABI_GPU_KOKKOS) call gpu_device_synchronize()
2662 : :
2663 : : else
2664 : :
2665 : 642542 : call checkResize(iwork,liwork,5*xgBlockA%rows+3)
2666 : :
2667 : 722773 : select case(xgBlockA%space)
2668 : :
2669 : : case (SPACE_R)
2670 : :
2671 : 80231 : call checkResize(rwork,lrwork,2*xgBlockA%rows*xgBlockA%rows+6*xgBlockA%rows+1)
2672 : :
2673 : : call dsygvd(itype, jobz, uplo, xgBlockA%rows, xgBlockA%vecR, xgBlockA%ldim, &
2674 [ + - - - : 80231 : xgBlockB%vecR, xgBlockB%ldim, xgBlockW%vecR, rwork, lrwork, iwork, liwork, info)
- - - - +
- - - - -
- - + - -
- - - - -
- + - - -
- - + - -
- - - + -
- - - ]
2675 : :
2676 : : case (SPACE_C)
2677 : :
2678 : 562311 : call checkResize(cwork,lcwork,xgBlockA%rows*xgBlockA%rows+2*xgBlockA%rows)
2679 : 562311 : call checkResize(rwork,lrwork,2*(xgBlockA%rows*xgBlockA%rows)+5*xgBlockA%rows+1)
2680 : :
2681 : : call zhegvd(itype, jobz, uplo, xgBlockA%rows, xgBlockA%vecC, xgBlockA%ldim,&
2682 : : xgBlockB%vecC, xgBlockB%ldim, xgBlockW%vecR, cwork, lcwork, &
2683 [ + - - - : 562311 : rwork, lrwork, iwork, liwork, info)
- - - - +
- - - - -
- - + - -
- - - - -
- + - - -
- - + - -
- - - + -
- - - ]
2684 : :
2685 [ + + ]: 562311 : if ( int(cwork(1)) > lcwork ) then
2686 : : !write(std_out,*) "Allocate work from", lcwork, "to", int(cwork(1))
2687 : 272 : call checkResize(cwork,lcwork,int(cwork(1)))
2688 : : end if
2689 : :
2690 : : case (SPACE_CR)
2691 [ + + - - ]: 642542 : ABI_ERROR('Not implemented for SPACE_CR')
2692 : :
2693 : : end select
2694 : :
2695 [ - + ]: 642542 : if ( rwork(1) > lrwork ) then
2696 : : !write(std_out,*) "Allocate work from", lrwork, "to", int(rwork(1))
2697 : 0 : call checkResize(rwork,lrwork,int(rwork(1)))
2698 : : end if
2699 : :
2700 : :
2701 [ - + ]: 642542 : if ( iwork(1) > liwork ) then
2702 : : !write(std_out,*) "Allocate work from", liwork, "to", int(iwork(1))
2703 : 0 : call checkResize(iwork,liwork,int(iwork(1)))
2704 : : end if
2705 : :
2706 : : end if
2707 : :
2708 : 642542 : call timab(tim_hegvd,2,tsec)
2709 : :
2710 : 642542 : end subroutine xgBlock_hegvd
2711 : : !!***
2712 : :
2713 : : !!****f* m_xg/xgBlock_hpgv
2714 : : !!
2715 : : !! NAME
2716 : : !! xgBlock_hpgv
2717 : :
2718 : : !===================================================
2719 : : != Hermitian Full Generalized Matrix diago
2720 : : !===================================================
2721 : :
2722 : 0 : subroutine xgBlock_hpgv(itype, jobz, uplo, xgBlockAP, xgBlockBP, xgBlockW, xgBlockZ,info)
2723 : :
2724 : : integer , intent(in ) :: itype
2725 : : character , intent(in ) :: jobz
2726 : : character , intent(in ) :: uplo
2727 : : type(xgBlock_t) , intent(inout) :: xgBlockAP
2728 : : type(xgBlock_t) , intent(inout) :: xgBlockBP
2729 : : type(xgBlock_t) , intent(inout) :: xgBlockW
2730 : : type(xgBlock_t) , intent(inout) :: xgBlockZ
2731 : : integer , intent( out) :: info
2732 : : double precision :: tsec(2)
2733 : :
2734 : 0 : call timab(tim_hpgv,1,tsec)
2735 : :
2736 [ # # ]: 0 : if ( xgBlockAP%space /= xgBlockBP%space ) then
2737 : 0 : ABI_ERROR("Not same space")
2738 : : end if
2739 : :
2740 [ # # ]: 0 : if ( xgBlockW%space /= SPACE_R ) then
2741 : 0 : ABI_ERROR("Block3 must be real")
2742 : : end if
2743 : :
2744 : 0 : select case(xgBlockAP%space)
2745 : :
2746 : : case (SPACE_R)
2747 : 0 : call checkResize(rwork,lrwork,3*xgBlockZ%rows)
2748 : :
2749 : : call dspgv(itype, jobz, uplo, xgBlockZ%rows, xgBlockAP%vecR, xgBlockBP%vecR, &
2750 [ # # # # : 0 : xgBlockW%vecR, xgBlockZ%vecR, xgBlockZ%Ldim, rwork, info)
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
2751 : :
2752 : : case (SPACE_C)
2753 : :
2754 : 0 : call checkResize(cwork,lcwork,2*xgBlockZ%rows-1)
2755 : 0 : call checkResize(rwork,lrwork,3*xgBlockZ%rows-2)
2756 : :
2757 : : call zhpgv(itype, jobz, uplo, xgBlockAP%rows, xgBlockAP%vecC, xgBlockBP%vecC, &
2758 [ # # # # : 0 : xgBlockW%vecR, xgBlockZ%vecC, xgBlockZ%Ldim, cwork, rwork, info)
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
2759 : :
2760 [ # # ]: 0 : if ( int(cwork(1)) > lcwork ) then
2761 : : !write(std_out,*) "Allocate work from", lcwork, "to", int(cwork(1))
2762 : 0 : call checkResize(cwork,lcwork,int(cwork(1)))
2763 : : end if
2764 : :
2765 : : case (SPACE_CR)
2766 [ # # # # ]: 0 : ABI_ERROR('Not implemented for SPACE_CR')
2767 : :
2768 : : end select
2769 : :
2770 [ # # ]: 0 : if ( rwork(1) > lrwork ) then
2771 : : !write(std_out,*) "Allocate rwork from", lrwork, "to", int(rwork(1))
2772 : 0 : call checkResize(rwork,lrwork,int(rwork(1)))
2773 : : end if
2774 : :
2775 : 0 : call timab(tim_hpgv,2,tsec)
2776 : :
2777 : 0 : end subroutine xgBlock_hpgv
2778 : : !!***
2779 : :
2780 : : !!****f* m_xg/xgBlock_hpgvx
2781 : : !!
2782 : : !! NAME
2783 : : !! xgBlock_hpgvx
2784 : :
2785 : 0 : subroutine xgBlock_hpgvx(itype,jobz,range,uplo,xgBlockAP,xgBlockBP,vl,vu,il,iu,abstol,xgBlockW,xgBlockZ,info)
2786 : :
2787 : : integer , intent(in ) :: itype
2788 : : character , intent(in ) :: jobz
2789 : : character , intent(in ) :: range
2790 : : character , intent(in ) :: uplo
2791 : : type(xgBlock_t) , intent(inout) :: xgBlockAP
2792 : : type(xgBlock_t) , intent(inout) :: xgBlockBP
2793 : : double precision, intent(in ) :: vl
2794 : : double precision, intent(in ) :: vu
2795 : : integer , intent(in ) :: il
2796 : : integer , intent(in ) :: iu
2797 : : double precision, intent(in ) :: abstol
2798 : : type(xgBlock_t) , intent(inout) :: xgBlockW
2799 : : type(xgBlock_t) , intent(inout) :: xgBlockZ
2800 : : integer , intent( out) :: info
2801 : : integer :: neigen
2802 : 0 : integer, allocatable :: ifail(:)
2803 : : double precision :: tsec(2)
2804 : :
2805 : 0 : call timab(tim_hpgvx,1,tsec)
2806 : :
2807 [ # # # # ]: 0 : if ( xgBlockAP%space /= xgBlockBP%space .or. xgBlockAP%space /= xgBlockZ%space ) then
2808 : 0 : ABI_ERROR("Not same space")
2809 : : end if
2810 [ # # ]: 0 : if ( xgBlockW%space /= SPACE_R ) then
2811 : 0 : ABI_ERROR("Block3 must be real")
2812 : : end if
2813 : :
2814 : 0 : call checkResize(iwork,liwork,5*xgBlockZ%rows)
2815 : :
2816 [ # # # # : 0 : ABI_MALLOC(ifail,(xgBlockZ%rows))
# # # # #
# # # ]
2817 [ # # ]: 0 : ifail = 0
2818 : :
2819 : 0 : select case(xgBlockAP%space)
2820 : :
2821 : : case (SPACE_R)
2822 : 0 : call checkResize(rwork,lrwork,8*xgBlockZ%rows)
2823 : :
2824 : : call dspgvx(itype,jobz,range,uplo,xgBlockZ%rows, &
2825 : : xgBlockAP%vecR,xgBlockBP%vecR, &
2826 : : vl,vu,il,iu,abstol,&
2827 : : neigen,xgBlockW%vecR, xgBlockZ%vecR, xgBlockZ%LDim, &
2828 [ # # # # : 0 : rwork, iwork, ifail, info)
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
2829 : :
2830 : : case (SPACE_C)
2831 : 0 : call checkResize(rwork,lrwork,7*xgBlockAP%rows)
2832 : 0 : call checkResize(cwork,lcwork,2*xgBlockZ%rows)
2833 : :
2834 : : call zhpgvx(itype,jobz,range,uplo,xgBlockZ%rows, &
2835 : : xgBlockAP%vecC,xgBlockBP%vecC, &
2836 : : vl,vu,il,iu,abstol,&
2837 : : neigen,xgBlockW%vecR, xgBlockZ%vecC, xgBlockZ%LDim, &
2838 [ # # # # : 0 : cwork, rwork, iwork, ifail, info)
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
2839 : :
2840 : : case (SPACE_CR)
2841 [ # # # # ]: 0 : ABI_ERROR('Not implemented for SPACE_CR')
2842 : :
2843 : : end select
2844 [ # # ]: 0 : ABI_FREE(ifail)
2845 : :
2846 [ # # ]: 0 : if ( rwork(1) > lrwork ) then
2847 : : !write(std_out,*) "Allocate work from", lrwork, "to", int(rwork(1))
2848 : 0 : call checkResize(rwork,lrwork,int(rwork(1)))
2849 : : end if
2850 : :
2851 : :
2852 : 0 : call timab(tim_hpgvx,2,tsec)
2853 : :
2854 : 0 : end subroutine xgBlock_hpgvx
2855 : : !!***
2856 : :
2857 : : !!****f* m_xg/xgBlock_hpgvd
2858 : : !!
2859 : : !! NAME
2860 : : !! xgBlock_hpgvd
2861 : :
2862 : 0 : subroutine xgBlock_hpgvd(itype, jobz, uplo, xgBlockAP, xgBlockBP, xgBlockW, xgBlockZ, info)
2863 : :
2864 : : integer , intent(in ) :: itype
2865 : : character , intent(in ) :: jobz
2866 : : character , intent(in ) :: uplo
2867 : : type(xgBlock_t) , intent(inout) :: xgBlockAP
2868 : : type(xgBlock_t) , intent(inout) :: xgBlockBP
2869 : : type(xgBlock_t) , intent(inout) :: xgBlockW
2870 : : type(xgBlock_t) , intent(inout) :: xgBlockZ
2871 : : integer , intent( out) :: info
2872 : : double precision :: tsec(2)
2873 : :
2874 : 0 : call timab(tim_hpgvd,1,tsec)
2875 : :
2876 [ # # ]: 0 : if ( xgBlockAP%space /= xgBlockBP%space ) then
2877 : 0 : ABI_ERROR("Not same space")
2878 : : end if
2879 [ # # ]: 0 : if ( xgBlockW%space /= SPACE_R ) then
2880 : 0 : ABI_ERROR("Block3 must be real")
2881 : : end if
2882 : :
2883 : 0 : call checkResize(iwork,liwork,5*xgBlockZ%rows+3)
2884 : :
2885 : 0 : select case(xgBlockAP%space)
2886 : :
2887 : : case (SPACE_R)
2888 : 0 : call checkResize(rwork,lrwork,2*xgBlockZ%rows*xgBlockZ%rows+6*xgBlockZ%rows+1)
2889 : :
2890 : : call dspgvd(itype, jobz, uplo, xgBlockZ%rows, xgBlockAP%vecR, xgBlockBP%vecR, &
2891 : : xgBlockW%vecR, xgBlockZ%vecR, xgBlockZ%Ldim, &
2892 [ # # # # : 0 : rwork, lrwork, iwork, liwork, info)
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
2893 : :
2894 : : case (SPACE_C)
2895 : :
2896 : 0 : call checkResize(cwork,lcwork,2*xgBlockZ%rows)
2897 : 0 : call checkResize(rwork,lrwork,2*(xgBlockZ%rows*xgBlockZ%rows)+5*xgBlockZ%rows+1)
2898 : :
2899 : : call zhpgvd(itype, jobz, uplo, xgBlockZ%rows, xgBlockAP%vecC, xgBlockBP%vecC, &
2900 : : xgBlockW%vecR, xgBlockZ%vecC, xgBlockZ%Ldim, &
2901 [ # # # # : 0 : cwork, lcwork, rwork, lrwork, iwork, liwork, info)
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
2902 : :
2903 [ # # ]: 0 : if ( int(cwork(1)) > lcwork ) then
2904 : : !write(std_out,*) "Allocate work from", lcwork, "to", int(cwork(1))
2905 : 0 : call checkResize(cwork,lcwork,int(cwork(1)))
2906 : : end if
2907 : :
2908 : : case (SPACE_CR)
2909 [ # # # # ]: 0 : ABI_ERROR('Not implemented for SPACE_CR')
2910 : :
2911 : : end select
2912 : :
2913 [ # # ]: 0 : if ( rwork(1) > lrwork ) then
2914 : : !write(std_out,*) "Allocate work from", lrwork, "to", int(rwork(1))
2915 : 0 : call checkResize(rwork,lrwork,int(rwork(1)))
2916 : : end if
2917 : :
2918 [ # # ]: 0 : if ( iwork(1) > liwork ) then
2919 : : !write(std_out,*) "Allocate work from", liwork, "to", int(iwork(1))
2920 : 0 : call checkResize(iwork,liwork,int(iwork(1)))
2921 : : end if
2922 : :
2923 : 0 : call timab(tim_hpgvd,2,tsec)
2924 : :
2925 : 0 : end subroutine xgBlock_hpgvd
2926 : : !!***
2927 : :
2928 : : !!****f* m_xg/xgBlock_trsmR
2929 : : !!
2930 : : !! NAME
2931 : : !! xgBlock_trsmR
2932 : :
2933 : 2331407 : subroutine xgBlock_trsmR(side,uplo,transa,diag,alpha,xgBlockA,xgBlockB)
2934 : :
2935 : : character , intent(in ) :: side
2936 : : character , intent(in ) :: uplo
2937 : : character , intent(in ) :: transa
2938 : : character , intent(in ) :: diag
2939 : : double precision, intent(in ) :: alpha
2940 : : type(xgBlock_t) , intent(inout) :: xgBlockA
2941 : : type(xgBlock_t) , intent(inout) :: xgBlockB
2942 : : complex(kind=8) :: calpha
2943 : : double precision :: tsec(2)
2944 : : integer :: fact
2945 : :
2946 : 2331407 : call timab(tim_trsm,1,tsec)
2947 [ + + ]: 2331407 : if ( xgBlockB%space/=SPACE_CR ) then
2948 [ - + ]: 2084508 : if ( xgBlockA%space /= xgBlockB%space ) then
2949 : 0 : ABI_ERROR("Not same space")
2950 : : end if
2951 : : else
2952 [ - + ]: 246899 : if ( xgBlockA%space /= SPACE_R ) then
2953 : 0 : ABI_ERROR("If space(B)=SPACE_CR, space(A) should be space(R)")
2954 : : end if
2955 : : end if
2956 : :
2957 : 2331407 : call xgBlock_check_gpu_option(xgBlockA,xgBlockB)
2958 : :
2959 [ + + ]: 2331407 : fact = 1 ; if (xgBlockB%space==SPACE_CR) fact = 2
2960 : :
2961 : 2585595 : select case(xgBlockA%space)
2962 : : case (SPACE_R,SPACE_CR)
2963 : : call abi_xtrsm(side,uplo,transa,diag,fact*xgBlockB%rows,xgBlockB%cols, &
2964 : : alpha,xgBlockA%vecR,xgBlockA%LDim,xgBlockB%vecR,fact*xgBlockB%LDim, &
2965 [ + - - - : 254188 : gpu_option=xgBlockA%gpu_option)
- - - - +
- - - - -
- - - + -
+ - - -
- ]
2966 : : case (SPACE_C)
2967 : 2077219 : calpha = dcmplx(alpha,0.d0)
2968 : : call abi_xtrsm(side,uplo,transa,diag,xgBlockB%rows,xgBlockB%cols, &
2969 : : calpha,xgBlockA%vecC,xgBlockA%LDim,xgBlockB%vecC,xgBlockB%LDim, &
2970 [ + + - + : 2331407 : gpu_option=xgBlockA%gpu_option)
- - - - -
- - + - -
- - - - -
- + - + -
- - - ]
2971 : : end select
2972 : :
2973 : 2331407 : call timab(tim_trsm,2,tsec)
2974 : :
2975 : 2331407 : end subroutine xgBlock_trsmR
2976 : : !!***
2977 : :
2978 : : !!****f* m_xg/xgBlock_trsmC
2979 : : !!
2980 : : !! NAME
2981 : : !! xgBlock_trsmC
2982 : :
2983 : 0 : subroutine xgBlock_trsmC(side,uplo,transa,diag,alpha, xgBlockA,xgBlockB)
2984 : :
2985 : : character , intent(in ) :: side
2986 : : character , intent(in ) :: uplo
2987 : : character , intent(in ) :: transa
2988 : : character , intent(in ) :: diag
2989 : : complex(kind=8), intent(in ) :: alpha
2990 : : type(xgBlock_t), intent(inout) :: xgBlockA
2991 : : type(xgBlock_t), intent(inout) :: xgBlockB
2992 : : double precision :: tsec(2)
2993 : :
2994 : 0 : call timab(tim_trsm,1,tsec)
2995 : :
2996 [ # # # # ]: 0 : if ( xgBlockA%space /= xgBlockB%space .or. xgBlockA%space /= SPACE_C) then
2997 : 0 : ABI_ERROR("Space should be SPACE_C for xgBlockA and xgBlockB")
2998 : : end if
2999 : :
3000 : 0 : call xgBlock_check_gpu_option(xgBlockA,xgBlockB)
3001 : :
3002 : : call abi_xtrsm(side,uplo,transa,diag,xgBlockB%rows,xgBlockB%cols, &
3003 : : alpha,xgBlockA%vecC,xgBlockA%LDim,xgBlockB%vecC,xgBlockB%LDim, &
3004 [ # # # # : 0 : gpu_option=xgBlockA%gpu_option)
# # # # #
# # # # #
# # # # #
# # # #
# ]
3005 : :
3006 : 0 : call timab(tim_trsm,2,tsec)
3007 : :
3008 : 0 : end subroutine xgBlock_trsmC
3009 : : !!***
3010 : :
3011 : : !!****f* m_xg/xgBlock_ymax
3012 : : !!
3013 : : !! NAME
3014 : : !! xgBlock_ymax
3015 : : !!
3016 : : !! FUNCTION
3017 : : !! TODO IL-10/03/2025 Be careful, GPU version not tested
3018 : :
3019 : 96999 : subroutine xgBlock_ymax(xgBlockA, da, shift, nblocks)
3020 : :
3021 : : type(xgBlock_t), intent(inout) :: xgBlockA
3022 : : type(xgBlock_t), intent(in ) :: da
3023 : : integer, intent(in) :: shift,nblocks
3024 : :
3025 : : integer :: iblock,ncols,irow,nrows,fact
3026 : : double precision :: tsec(2)
3027 : :
3028 : : #if defined HAVE_GPU && defined HAVE_OPENMP_OFFLOAD
3029 : : complex(dpc), contiguous, pointer :: xgBlockA__vecC(:,:),da__vecC(:,:)
3030 : : real(dp), contiguous, pointer :: xgBlockA__vecR(:,:),da__vecR(:,:)
3031 : : #endif
3032 : :
3033 : 96999 : call timab(tim_ymax,1,tsec)
3034 : :
3035 [ - + ]: 96999 : if (xgBlockA%gpu_option==ABI_GPU_KOKKOS) then
3036 : 0 : ABI_ERROR('Not implemented for GPU Kokkos')
3037 : : end if
3038 : 96999 : call xgBlock_check_gpu_option(xgBlockA,da)
3039 : :
3040 : 96999 : nrows = xgBlockA%rows
3041 : 96999 : ncols = xgBlockA%cols
3042 : :
3043 [ - + ]: 96999 : if ( da%rows /= nblocks*ncols ) then
3044 : 0 : ABI_ERROR("rows(da)/=nblocks*ncols")
3045 : : end if
3046 [ - + ]: 96999 : if ( shift<0 ) then
3047 : 0 : ABI_ERROR("shift<0")
3048 : : end if
3049 [ - + ]: 96999 : if ( shift+ncols > da%rows ) then
3050 : 0 : ABI_ERROR("shift+xgBlockA%cols > da%rows")
3051 : : end if
3052 : :
3053 [ + + ]: 96999 : fact = 1 ; if (xgBlockA%space==SPACE_CR) fact = 2
3054 : :
3055 [ + - ]: 96999 : if (xgBlockA%gpu_option==ABI_GPU_DISABLED) then
3056 : :
3057 [ + + ]: 96999 : if (space(da)==SPACE_R) then
3058 : : select case(xgBlockA%space)
3059 : : case (SPACE_R,SPACE_CR)
3060 : : !$omp parallel do collapse(2) shared(da,xgBlockA) private(irow,iblock)
3061 [ + + ]: 104707 : do iblock = 1, ncols
3062 [ + + ]: 1520227 : do irow = 1, fact*nrows
3063 : 1483840 : xgBlockA%vecR(irow,iblock) = - da%vecR(iblock+shift,1) * xgBlockA%vecR(irow,iblock)
3064 : : end do
3065 : : end do
3066 : : !$omp end parallel do
3067 : : case (SPACE_C)
3068 : : !$omp parallel do collapse(2) shared(da,xgBlockA) private(irow,iblock)
3069 [ + + - + : 301893 : do iblock = 1, ncols
+ ]
3070 [ + + ]: 4026656 : do irow = 1, nrows
3071 : 3970414 : xgBlockA%vecC(irow,iblock) = - da%vecR(iblock+shift,1) * xgBlockA%vecC(irow,iblock)
3072 : : end do
3073 : : end do
3074 : : !$omp end parallel do
3075 : : end select
3076 [ + - ]: 4370 : else if (space(da)==SPACE_C) then
3077 [ - + ]: 4370 : if (xgBlockA%space/=SPACE_C) then
3078 : 0 : ABI_ERROR('If space(da)=SPACE_C, space(xgBlockA) has to be SPACE_C')
3079 : : end if
3080 : : !$omp parallel do collapse(2) shared(da,xgBlockA) private(irow,iblock)
3081 [ + + ]: 22930 : do iblock = 1, ncols
3082 [ + + ]: 7402994 : do irow = 1, nrows
3083 : 7398624 : xgBlockA%vecC(irow,iblock) = - da%vecC(iblock+shift,1) * xgBlockA%vecC(irow,iblock)
3084 : : end do
3085 : : end do
3086 : : !$omp end parallel do
3087 : : else
3088 : 0 : ABI_ERROR('Only SPACE_R or SPACE_C (for da) are implemented.')
3089 : : end if
3090 : :
3091 : : else if (xgBlockA%gpu_option==ABI_GPU_OPENMP) then
3092 : :
3093 : : #if defined HAVE_GPU && defined HAVE_OPENMP_OFFLOAD
3094 : :
3095 : : if (space(da)==SPACE_R) then
3096 : : select case(xgBlockA%space)
3097 : : case (SPACE_R,SPACE_CR)
3098 : : xgBlockA__vecR => xgBlockA%vecR
3099 : : da__vecR => da%vecR
3100 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(2) &
3101 : : !$OMP& MAP(to:xgBlockA__vecR,da__vecR)
3102 : : do iblock = 1, ncols
3103 : : do irow = 1, fact*nrows
3104 : : xgBlockA__vecR(irow,iblock) = - da__vecR(iblock+shift,1) * xgBlockA__vecR(irow,iblock)
3105 : : end do
3106 : : end do
3107 : : case (SPACE_C)
3108 : : xgBlockA__vecC => xgBlockA%vecC
3109 : : da__vecR => da%vecR
3110 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(2) &
3111 : : !$OMP& MAP(to:xgBlockA__vecC,da__vecR)
3112 : : do iblock = 1, ncols
3113 : : do irow = 1, nrows
3114 : : xgBlockA__vecC(irow,iblock) = - da__vecR(iblock+shift,1) * xgBlockA__vecC(irow,iblock)
3115 : : end do
3116 : : end do
3117 : : end select
3118 : : else if (space(da)==SPACE_C) then
3119 : : if (xgBlockA%space/=SPACE_C) then
3120 : : ABI_ERROR('If space(da)=SPACE_C, space(xgBlockA) has to be SPACE_C')
3121 : : end if
3122 : : xgBlockA__vecC => xgBlockA%vecC
3123 : : da__vecC => da%vecC
3124 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(2) &
3125 : : !$OMP& MAP(to:xgBlockA__vecC,da__vecC)
3126 : : do iblock = 1, ncols
3127 : : do irow = 1, nrows
3128 : : xgBlockA__vecC(irow,iblock) = - da__vecC(iblock+shift,1) * xgBlockA__vecC(irow,iblock)
3129 : : end do
3130 : : end do
3131 : : else
3132 : : ABI_ERROR('Only SPACE_R or SPACE_C (for da) are implemented.')
3133 : : end if
3134 : :
3135 : : #endif
3136 : :
3137 : : end if
3138 : :
3139 : 96999 : call timab(tim_ymax,2,tsec)
3140 : :
3141 : 96999 : end subroutine xgBlock_ymax
3142 : : !!***
3143 : :
3144 : : !!****f* m_xg/xgBlock_colwiseCymax
3145 : : !!
3146 : : !! NAME
3147 : : !! xgBlock_colwiseCymax
3148 : :
3149 : 708508 : subroutine xgBlock_colwiseCymax(xgBlockA, da, xgBlockB, xgBlockW)
3150 : :
3151 : : type(xgBlock_t), intent(inout) :: xgBlockA
3152 : : type(xgBlock_t), intent(in ) :: da
3153 : : type(xgBlock_t), intent(in ) :: xgBlockB
3154 : : type(xgBlock_t), intent(in ) :: xgBlockW
3155 : :
3156 : : integer :: iblock,fact,rows,cols,jblock
3157 : : #if defined HAVE_GPU && defined HAVE_OPENMP_OFFLOAD
3158 : : complex(dp), contiguous, pointer :: xgBlockA__vecC(:,:),xgBlockB__vecC(:,:),xgBlockW__vecC(:,:)
3159 : : real(dp), contiguous, pointer :: xgBlockA__vecR(:,:),xgBlockB__vecR(:,:),xgBlockW__vecR(:,:),da__vecR(:,:)
3160 : : #endif
3161 : : double precision :: tsec(2)
3162 : :
3163 : 708508 : call timab(tim_colw_cymax,1,tsec)
3164 : :
3165 [ + - - + ]: 708508 : if ( xgBlockA%space /= xgBlockB%space .or. xgBlockA%space /= xgBlockW%space ) then
3166 : 0 : ABI_ERROR("Must be same space for caxmy")
3167 : : end if
3168 [ + - - + ]: 708508 : if ( xgBlockA%LDim /= xgBlockB%LDim .or. xgBlockA%LDim /= xgBlockW%LDim) then
3169 : 0 : ABI_ERROR("Must have same LDim for caxmy")
3170 : : end if
3171 [ + - - + ]: 708508 : if ( xgBlockA%cols /= xgBlockB%cols .or. xgBlockA%cols /= xgBlockW%cols ) then
3172 : 0 : ABI_ERROR("Must have same cols for caxmy")
3173 : : end if
3174 [ - + ]: 708508 : if ( da%rows /= xgBlockA%cols ) then
3175 : 0 : ABI_ERROR("Must have same cols for caxmy")
3176 : : end if
3177 : :
3178 : 708508 : call xgBlock_check_gpu_option(xgBlockA,xgBlockB)
3179 : 708508 : call xgBlock_check_gpu_option(xgBlockA,xgBlockW)
3180 : 708508 : call xgBlock_check_gpu_option(xgBlockA,da)
3181 : :
3182 [ + + ]: 708508 : fact = 1 ; if (xgBlockA%space==SPACE_CR) fact = 2
3183 : :
3184 : 708508 : rows = fact*xgBlockA%rows; cols = xgBlockA%cols
3185 : :
3186 [ + - ]: 708508 : if (xgBlockA%gpu_option==ABI_GPU_KOKKOS) then
3187 : :
3188 : : #if defined HAVE_GPU && defined HAVE_KOKKOS
3189 : :
3190 : : select case(xgBlockA%space)
3191 : : case (SPACE_R,SPACE_CR)
3192 : : call compute_colwiseCymax_scalar(c_loc(xgBlockA%vecR), c_loc(da%vecR), c_loc(xgBlockB%vecR), &
3193 : : & c_loc(xgBlockW%vecR), fact*xgBlockA%rows, xgBlockA%cols, fact*xgBlockA%ldim)
3194 : : case (SPACE_C)
3195 : : call compute_colwiseCymax_cplx (c_loc(xgBlockA%vecC), c_loc(da%vecR), c_loc(xgBlockB%vecC), &
3196 : : & c_loc(xgBlockW%vecC), xgBlockA%rows, xgBlockA%cols, xgBlockA%ldim)
3197 : : end select
3198 : :
3199 : : #endif
3200 : :
3201 [ + - ]: 708508 : else if (xgBlockA%gpu_option==ABI_GPU_OPENMP) then
3202 : :
3203 : : #if defined HAVE_GPU && defined HAVE_OPENMP_OFFLOAD
3204 : :
3205 : : select case(xgBlockA%space)
3206 : : case (SPACE_R,SPACE_CR)
3207 : : xgBlockA__vecR => xgBlockA%vecR
3208 : : xgBlockB__vecR => xgBlockB%vecR
3209 : : xgBlockW__vecR => xgBlockW%vecR
3210 : : da__vecR => da%vecR
3211 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(2) &
3212 : : !$OMP& MAP(to:xgBlockA__vecR,xgBlockB__vecR,xgBlockW__vecR,da__vecR)
3213 : : do iblock = 1, cols
3214 : : do jblock = 1, rows
3215 : : xgBlockA__vecR(jblock,iblock) = - da__vecR(iblock,1) * xgBlockB__vecR(jblock,iblock) &
3216 : : + xgBlockW__vecR(jblock,iblock)
3217 : : end do
3218 : : end do
3219 : : case (SPACE_C)
3220 : : xgBlockA__vecC => xgBlockA%vecC
3221 : : xgBlockB__vecC => xgBlockB%vecC
3222 : : xgBlockW__vecC => xgBlockW%vecC
3223 : : da__vecR => da%vecR
3224 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(2) &
3225 : : !$OMP& MAP(to:xgBlockA__vecC,xgBlockB__vecC,xgBlockW__vecC,da__vecR)
3226 : : do iblock = 1, cols
3227 : : do jblock = 1, rows
3228 : : xgBlockA__vecC(jblock,iblock) = - da__vecR(iblock,1) * xgBlockB__vecC(jblock,iblock) &
3229 : : + xgBlockW__vecC(jblock,iblock)
3230 : : end do
3231 : : end do
3232 : : end select
3233 : :
3234 : : #endif
3235 : :
3236 : : else
3237 : :
3238 : : select case(xgBlockA%space)
3239 : : case (SPACE_R,SPACE_CR)
3240 : : !$omp parallel do collapse(2) shared(da,xgBlockB,xgBlockW,xgBlockA) private(iblock,jblock)
3241 [ + + ]: 572104 : do iblock = 1, cols
3242 [ + + ]: 283215696 : do jblock = 1, rows
3243 : 283157546 : xgBlockA%vecR(jblock,iblock) = - da%vecR(iblock,1) * xgBlockB%vecR(jblock,iblock) + xgBlockW%vecR(jblock,iblock)
3244 : : end do
3245 : : end do
3246 : : !$omp end parallel do
3247 : : case (SPACE_C)
3248 : : !$omp parallel do collapse(2) shared(da,xgBlockB,xgBlockW,xgBlockA) private(iblock,jblock)
3249 [ + + - + : 2763628 : do iblock = 1, cols
+ ]
3250 [ + + ]: 216239704 : do jblock = 1, rows
3251 : 215589346 : xgBlockA%vecC(jblock,iblock) = - da%vecR(iblock,1) * xgBlockB%vecC(jblock,iblock) + xgBlockW%vecC(jblock,iblock)
3252 : : end do
3253 : : end do
3254 : : !$omp end parallel do
3255 : : end select
3256 : :
3257 : : end if
3258 : :
3259 : 708508 : call timab(tim_colw_cymax,2,tsec)
3260 : :
3261 : 708508 : end subroutine xgBlock_colwiseCymax
3262 : : !!***
3263 : :
3264 : : !!****f* m_xg/xgBlock_yxmax
3265 : : !!
3266 : : !! NAME
3267 : : !! xgBlock_yxmax
3268 : :
3269 : 90464 : subroutine xgBlock_yxmax(xgBlockA, da, xgBlockB)
3270 : :
3271 : : type(xgBlock_t), intent(inout) :: xgBlockA
3272 : : type(xgBlock_t), intent(in ) :: da
3273 : : type(xgBlock_t), intent(in ) :: xgBlockB
3274 : :
3275 : : integer :: iblock,irow,cols,rows,fact
3276 : : double precision :: tsec(2)
3277 : :
3278 : 90464 : call timab(tim_yxmax,1,tsec)
3279 : :
3280 [ - + ]: 90464 : if (xgBlockA%gpu_option/=ABI_GPU_DISABLED) then
3281 : 0 : ABI_ERROR('Not implemented for GPU')
3282 : : end if
3283 : 90464 : call xgBlock_check_gpu_option(xgBlockA,da)
3284 : 90464 : call xgBlock_check_gpu_option(xgBlockA,da)
3285 : :
3286 [ - + ]: 90464 : if ( xgBlockA%space /= xgBlockB%space ) then
3287 : 0 : ABI_ERROR("Must be same space for ymax")
3288 : : end if
3289 [ - + ]: 90464 : if ( xgBlockA%rows /= xgBlockB%rows ) then
3290 : 0 : ABI_ERROR("Must have same rows for ymax")
3291 : : end if
3292 [ - + ]: 90464 : if ( xgBlockA%cols /= xgBlockB%cols ) then
3293 : 0 : ABI_ERROR("Must have same cols for ymax")
3294 : : end if
3295 [ - + ]: 90464 : if ( da%rows /= xgBlockA%cols ) then
3296 : 0 : ABI_ERROR("Must have same cols for ymax")
3297 : : end if
3298 : :
3299 : 90464 : cols = xgBlockA%cols
3300 : 90464 : rows = xgBlockA%rows
3301 [ + + ]: 90464 : fact = 1 ; if (xgBlockA%space==SPACE_CR) fact = 2
3302 : :
3303 : : select case(xgBlockA%space)
3304 : : case (SPACE_R,SPACE_CR)
3305 : : !$omp parallel do collapse(2) shared(da,xgBlockB,xgBlockA) private(iblock,irow)
3306 [ + + ]: 263955 : do iblock = 1, cols
3307 [ + + ]: 12989715 : do irow = 1, fact*rows
3308 : 12947298 : xgBlockA%vecR(irow,iblock) = xgBlockA%vecR(irow,iblock) - da%vecR(iblock,1) * xgBlockB%vecR(irow,iblock)
3309 : : end do
3310 : : end do
3311 : : !$omp end parallel do
3312 : : case (SPACE_C)
3313 : : !$omp parallel do collapse(2) shared(da,xgBlockB,xgBlockA) private(iblock,irow)
3314 [ + + - + : 363771 : do iblock = 1, cols
+ ]
3315 [ + + ]: 30600575 : do irow = 1, rows
3316 : 30552528 : xgBlockA%vecC(irow,iblock) = xgBlockA%vecC(irow,iblock) - da%vecR(iblock,1) * xgBlockB%vecC(irow,iblock)
3317 : : end do
3318 : : end do
3319 : : !$omp end parallel do
3320 : : end select
3321 : :
3322 : 90464 : call timab(tim_yxmax,2,tsec)
3323 : :
3324 : 90464 : end subroutine xgBlock_yxmax
3325 : : !!***
3326 : :
3327 : : !!****f* m_xg/xgBlock_apply_diag
3328 : : !!
3329 : : !! NAME
3330 : : !! xgBlock_apply_diag
3331 : :
3332 : 918295 : subroutine xgBlock_apply_diag(X, diag, nspinor, Y)
3333 : :
3334 : : type(xgBlock_t) , intent(inout) :: X
3335 : : type(xgBlock_t) , intent(in) :: diag
3336 : : integer, intent(in) :: nspinor
3337 : : type(xgBlock_t) , optional, intent(inout) :: Y
3338 : :
3339 : : type(xgBlock_t) :: X_spinor, Y_spinor
3340 : 918295 : real(dp) , pointer :: array(:)
3341 : 918295 : complex(dp), pointer :: arrayc(:)
3342 : : double precision :: tsec(2)
3343 : :
3344 : 918295 : call timab(tim_apply_diag,1,tsec)
3345 : :
3346 [ - + ]: 918295 : if (X%rows/=nspinor*diag%rows) then
3347 : 0 : ABI_ERROR('xgBlock%rows/=nspinor*xgBlock_diag%rows')
3348 : : end if
3349 [ - + ]: 918295 : if (diag%cols/=1) then
3350 : 0 : ABI_ERROR('diag should have one column')
3351 : : end if
3352 [ - + ]: 918295 : if (diag%space/=SPACE_R.and.diag%space/=SPACE_C) then
3353 : 0 : ABI_ERROR('space(diag) should be SPACE_C or SPACE_R')
3354 : : end if
3355 [ + + ]: 918295 : if (X%space==SPACE_R) then
3356 [ - + ]: 122043 : if (diag%space/=SPACE_R) then
3357 : 0 : ABI_ERROR('If space(X)==SPACE_R, space(diag) should be SPACE_R')
3358 : : end if
3359 : : end if
3360 : :
3361 [ + + ]: 918295 : if (present(Y)) then
3362 : 144043 : call xgBlock_check(Y,X)
3363 : 144043 : call xgBlock_copy(X,Y)
3364 : 144043 : call xgBlock_reshape_spinor(Y,Y_spinor,nspinor,ROWS2COLS)
3365 : : else
3366 : 774252 : call xgBlock_reshape_spinor(X,X_spinor,nspinor,ROWS2COLS)
3367 : 774252 : Y_spinor = X_spinor
3368 : : end if
3369 : :
3370 [ + - ]: 918295 : if (space(diag)==SPACE_R) then
3371 : 918295 : call xgBlock_reverseMap_1dR(diag,array,array_dim=diag%rows)
3372 : 918295 : call xgBlock_colwiseMulR(Y_spinor,array)
3373 [ # # ]: 0 : else if (space(diag)==SPACE_C) then
3374 : 0 : call xgBlock_reverseMap_1dC(diag,arrayc,array_dim=diag%rows)
3375 : 0 : call xgBlock_colwiseMulC(Y_spinor,arrayc)
3376 : : end if
3377 : :
3378 : 918295 : call timab(tim_apply_diag,2,tsec)
3379 : :
3380 : 918295 : end subroutine xgBlock_apply_diag
3381 : : !!***
3382 : :
3383 : : !****f* m_xg/xgBlock_add_diag
3384 : : !
3385 : : ! NAME
3386 : : ! xgBlock_add_diag
3387 : :
3388 : 204650 : subroutine xgBlock_add_diag(X, diag, nspinor, Y)
3389 : :
3390 : : type(xgBlock_t) , intent(in) :: X
3391 : : type(xgBlock_t) , intent(in) :: diag
3392 : : integer, intent(in) :: nspinor
3393 : : type(xgBlock_t) , intent(inout) :: Y
3394 : :
3395 : : integer :: iblock,irow,rows,cols
3396 : : type(xgBlock_t) :: X_spinor, Y_spinor
3397 : : double precision :: tsec(2)
3398 : :
3399 : 204650 : call timab(tim_add_diag,1,tsec)
3400 : :
3401 [ - + ]: 204650 : if (X%gpu_option/=ABI_GPU_DISABLED) then
3402 : 0 : ABI_ERROR('Not implemented for GPU')
3403 : : end if
3404 : 204650 : call xgBlock_check_gpu_option(X,diag)
3405 : 204650 : call xgBlock_check_gpu_option(X,Y)
3406 : :
3407 [ - + ]: 204650 : if (X%rows/=nspinor*diag%rows) then
3408 : 0 : ABI_ERROR('xgBlock%rows/=nspinor*xgBlock_diag%rows')
3409 : : end if
3410 [ - + ]: 204650 : if (diag%cols/=1) then
3411 : 0 : ABI_ERROR('xgBlock_diag should have one column')
3412 : : end if
3413 [ - + ]: 204650 : if (diag%space==SPACE_CR) then
3414 : 0 : ABI_ERROR('space(diag) should be SPACE_C or SPACE_R')
3415 : : end if
3416 [ - + ]: 204650 : if (X%space==SPACE_R) then
3417 [ # # ]: 0 : if (diag%space/=SPACE_R) then
3418 : 0 : ABI_ERROR('If space(X)==SPACE_R, space(diag) should be SPACE_R')
3419 : : end if
3420 : : end if
3421 : :
3422 : 204650 : call xgBlock_check(Y,X)
3423 : :
3424 : 204650 : call xgBlock_reshape_spinor(X,X_spinor,nspinor,ROWS2COLS)
3425 : 204650 : call xgBlock_reshape_spinor(Y,Y_spinor,nspinor,ROWS2COLS)
3426 : :
3427 : 204650 : rows = X_spinor%rows
3428 : 204650 : cols = X_spinor%cols
3429 : :
3430 : 204650 : select case(X%space)
3431 : : case (SPACE_R)
3432 : : !$omp parallel do collapse(2) shared(X_spinor,Y_spinor,diag) private(iblock,irow)
3433 [ # # ]: 0 : do iblock = 1, cols
3434 [ # # ]: 0 : do irow=1,rows
3435 : : Y_spinor%vecR(irow,iblock) = Y_spinor%vecR(irow,iblock) &
3436 : 0 : & + X_spinor%vecR(irow,iblock) * diag%vecR(irow,1)
3437 : : end do
3438 : : end do
3439 : : case (SPACE_CR)
3440 [ + - ]: 91520 : if (diag%space==SPACE_R) then
3441 : : !$omp parallel do collapse(2) shared(X_spinor,Y_spinor,diag) private(iblock,irow)
3442 [ + + ]: 491850 : do iblock = 1, cols
3443 [ + + ]: 24392946 : do irow=1,rows
3444 : : Y_spinor%vecR(2*irow-1,iblock) = Y_spinor%vecR(2*irow-1,iblock) &
3445 : 23901096 : & + X_spinor%vecR(2*irow-1,iblock) * diag%vecR(irow,1)
3446 : : Y_spinor%vecR(2*irow ,iblock) = Y_spinor%vecR(2*irow ,iblock) &
3447 : 24301426 : & + X_spinor%vecR(2*irow ,iblock) * diag%vecR(irow,1)
3448 : : end do
3449 : : end do
3450 : : else
3451 : 0 : ABI_ERROR('Not implemented')
3452 : : end if
3453 : : case (SPACE_C)
3454 [ - + + - : 204650 : if (diag%space==SPACE_C) then
- + ]
3455 : : !$omp parallel do collapse(2) shared(X_spinor,Y_spinor,diag) private(iblock,irow)
3456 [ # # ]: 0 : do iblock = 1, cols
3457 [ # # ]: 0 : do irow=1,rows
3458 : : Y_spinor%vecC(irow,iblock) = Y_spinor%vecC(irow,iblock) &
3459 : 0 : & + X_spinor%vecC(irow,iblock) * diag%vecC(irow,1)
3460 : : end do
3461 : : end do
3462 [ + - ]: 113130 : else if (diag%space==SPACE_R) then
3463 : : !$omp parallel do collapse(2) shared(X_spinor,Y_spinor,diag) private(iblock,irow)
3464 [ + + ]: 888922 : do iblock = 1, cols
3465 [ + + ]: 100807590 : do irow=1,rows
3466 : : Y_spinor%vecC(irow,iblock) = Y_spinor%vecC(irow,iblock) &
3467 : 100694460 : & + X_spinor%vecC(irow,iblock) * diag%vecR(irow,1)
3468 : : end do
3469 : : end do
3470 : : else
3471 : 0 : ABI_ERROR('Not implemented')
3472 : : end if
3473 : : end select
3474 : :
3475 : 204650 : call timab(tim_add_diag,2,tsec)
3476 : :
3477 : 204650 : end subroutine xgBlock_add_diag
3478 : : !!***
3479 : :
3480 : : !!****f* m_xg/xgBlock_mpi_sum
3481 : : !!
3482 : : !! NAME
3483 : : !! xgBlock_mpi_sum
3484 : :
3485 : 5783286 : subroutine xgBlock_mpi_sum(xgBlock,comm)
3486 : :
3487 : : type(xgBlock_t) , intent(inout) :: xgBlock
3488 : : integer,intent(in),optional :: comm
3489 : :
3490 : : integer :: ierr,comm_
3491 : :
3492 [ - + ]: 5783286 : if (.not.present(comm)) then
3493 : 0 : comm_ = xgBlock%spacedim_comm
3494 : : else
3495 : 5783286 : comm_ = comm
3496 : : end if
3497 : :
3498 [ + + ]: 5783286 : if ( xmpi_comm_size(comm_) > 1) then
3499 [ - + ]: 5252210 : if (xgBlock%gpu_option==ABI_GPU_KOKKOS) then
3500 : : ! CPU waits for GPU to finish before doing MPI communications
3501 : 0 : call gpu_device_synchronize()
3502 : : end if
3503 : :
3504 : 6093654 : select case(xgBlock%space)
3505 : :
3506 : : case (SPACE_R,SPACE_CR)
3507 : 841444 : call xmpi_sum(xgBlock%vecR,comm_,ierr,use_omp_map=(xgBlock%gpu_option==ABI_GPU_OPENMP))
3508 : : case (SPACE_C)
3509 [ + + - ]: 5252210 : call xmpi_sum(xgBlock%vecC,comm_,ierr,use_omp_map=(xgBlock%gpu_option==ABI_GPU_OPENMP))
3510 : : end select
3511 : : end if ! xmpi_comm_size>1
3512 : :
3513 : 5783286 : end subroutine xgBlock_mpi_sum
3514 : : !!***
3515 : :
3516 : : !!****f* m_xg/xgBlock_mpi_send
3517 : : !!
3518 : : !! NAME
3519 : : !! xgBlock_mpi_send
3520 : :
3521 : 0 : subroutine xgBlock_mpi_send(xgBlock,dest,tag,comm)
3522 : :
3523 : : type(xgBlock_t) , intent(in) :: xgBlock
3524 : : integer,intent(in) :: dest,tag
3525 : : integer,intent(in),optional :: comm
3526 : :
3527 : : integer :: ierr,comm_
3528 : 0 : real(dp), pointer :: vec(:,:)
3529 : :
3530 : 0 : if (xgBlock%gpu_option/=ABI_GPU_DISABLED) then
3531 : 0 : ABI_ERROR('Not implemented for GPU')
3532 : : end if
3533 : :
3534 [ # # ]: 0 : if (.not.present(comm)) then
3535 : 0 : comm_ = xgBlock%spacedim_comm
3536 : : else
3537 : 0 : comm_ = comm
3538 : : end if
3539 : :
3540 : 0 : call xgBlock_reverseMap(xgBlock,vec)
3541 : 0 : call xmpi_send(vec,dest,tag,comm_,ierr)
3542 : :
3543 [ # # ]: 0 : end subroutine xgBlock_mpi_send
3544 : : !!***
3545 : :
3546 : : !!****f* m_xg/xgBlock_mpi_isend
3547 : : !!
3548 : : !! NAME
3549 : : !! xgBlock_mpi_isend
3550 : :
3551 : 3135276 : subroutine xgBlock_mpi_isend(xgBlock,dest,tag,request,comm)
3552 : :
3553 : : type(xgBlock_t) , intent(in) :: xgBlock
3554 : : integer,intent(in) :: dest,tag
3555 : : integer,intent(inout) :: request
3556 : : integer,intent(in),optional :: comm
3557 : :
3558 : : integer :: ierr,comm_
3559 : 1567638 : real(dp), pointer :: vec(:,:)
3560 : :
3561 : 1567638 : if (xgBlock%gpu_option/=ABI_GPU_DISABLED) then
3562 : 0 : ABI_ERROR('Not implemented for GPU')
3563 : : end if
3564 : :
3565 [ + + ]: 1567638 : if (.not.present(comm)) then
3566 : 950822 : comm_ = xgBlock%spacedim_comm
3567 : : else
3568 : 616816 : comm_ = comm
3569 : : end if
3570 : :
3571 : 1567638 : call xgBlock_reverseMap(xgBlock,vec)
3572 : 1567638 : call xmpi_isend(vec,dest,tag,comm_,request,ierr)
3573 : :
3574 [ - + ]: 1567638 : end subroutine xgBlock_mpi_isend
3575 : : !!***
3576 : :
3577 : : !!****f* m_xg/xgBlock_mpi_recv
3578 : : !!
3579 : : !! NAME
3580 : : !! xgBlock_mpi_recv
3581 : :
3582 : 3135276 : subroutine xgBlock_mpi_recv(xgBlock,source,tag,comm)
3583 : :
3584 : : type(xgBlock_t) , intent(inout) :: xgBlock
3585 : : integer,intent(in) :: source,tag
3586 : : integer,intent(in),optional :: comm
3587 : :
3588 : : integer :: ierr,comm_
3589 : 1567638 : real(dp), pointer :: vec(:,:)
3590 : :
3591 : 1567638 : if (xgBlock%gpu_option/=ABI_GPU_DISABLED) then
3592 : 0 : ABI_ERROR('Not implemented for GPU')
3593 : : end if
3594 : :
3595 [ + + ]: 1567638 : if (.not.present(comm)) then
3596 : 950822 : comm_ = xgBlock%spacedim_comm
3597 : : else
3598 : 616816 : comm_ = comm
3599 : : end if
3600 : :
3601 : 1567638 : call xgBlock_reverseMap(xgBlock,vec)
3602 : 1567638 : call xmpi_recv(vec,source,tag,comm_,ierr)
3603 : :
3604 [ - + ]: 1567638 : end subroutine xgBlock_mpi_recv
3605 : : !!***
3606 : :
3607 : : !!****f* m_xg/xgBlock_gemm_mpi_cyclic_permutation
3608 : : !!
3609 : : !! NAME
3610 : : !! xgBlock_gemm_mpi_cyclic_permutation
3611 : :
3612 : 214911 : subroutine xgBlock_gemm_mpi_cyclic_permutation(xgBlockA,xgBlockB,xgBlockW,me_comm,blocksize,comm)
3613 : :
3614 : : type(xgBlock_t) , intent(in) :: xgBlockA,xgBlockB
3615 : : type(xgBlock_t) , intent(inout) :: xgBlockW
3616 : : integer,intent(in) :: me_comm
3617 : : integer,intent(in),optional :: blocksize,comm
3618 : :
3619 : : logical :: multiblock
3620 : : integer :: ierr,blocksize_,comm_,source,dest,tag,request
3621 : : integer :: iblock_left,iblock_right,iblock_mpi,nblocks_mpi,nblocks_left,nblocks_right
3622 : : integer :: shift_col,shift_row,shift_col_mpi,shift_row_mpi
3623 : : double precision :: tsec(2)
3624 : : type(xg_t) :: xg_mpi_work
3625 : : type(xg_t) :: subB,subB_mpi
3626 : :
3627 : 214911 : call timab(tim_gemmcyclic,1,tsec)
3628 : :
3629 [ - + ]: 214911 : if (xgBlockA%gpu_option/=ABI_GPU_DISABLED) then
3630 : 0 : ABI_ERROR('Not implemented for GPU')
3631 : : end if
3632 : 214911 : call xgBlock_check_gpu_option(xgBlockA,xgBlockB)
3633 : 214911 : call xgBlock_check_gpu_option(xgBlockA,xgBlockW)
3634 : :
3635 [ - + ]: 214911 : if (.not.present(comm)) then
3636 : 0 : comm_ = xgBlockA%spacedim_comm
3637 : : else
3638 : 214911 : comm_ = comm
3639 : : end if
3640 : :
3641 : 214911 : nblocks_mpi = xmpi_comm_size(comm_)
3642 : :
3643 [ - + ]: 214911 : if (xgBlockA%rows/=xgBlockW%rows) then
3644 : 0 : ABI_ERROR('rows(xgBlockA)/=rows(xgBlockW)')
3645 : : end if
3646 [ - + ]: 214911 : if (xgBlockB%rows/=nblocks_mpi*xgBlockA%cols) then
3647 : 0 : ABI_ERROR('rows(xgBlockB)/=nblocks_mpi*cols(xgBlockA)')
3648 : : end if
3649 [ - + ]: 214911 : if (xgBlockB%cols/=nblocks_mpi*xgBlockW%cols) then
3650 : 0 : ABI_ERROR('cols(xgBlockB)/=nblocks_mpi*cols(xgBlockW)')
3651 : : end if
3652 : :
3653 : 214911 : blocksize_ = xgBlockA%cols
3654 [ + - ]: 214911 : if (present(blocksize)) then
3655 [ - + ]: 214911 : if (mod(xgBlockA%cols,blocksize)/=0) then
3656 : 0 : ABI_ERROR('invalid blocksize')
3657 : : end if
3658 [ - + ]: 214911 : if (mod(xgBlockB%cols/nblocks_mpi,blocksize)/=0) then
3659 : 0 : ABI_ERROR('invalid blocksize')
3660 : : end if
3661 : 214911 : blocksize_ = blocksize
3662 : : end if
3663 : :
3664 [ + + ]: 214911 : if (nblocks_mpi==1) then
3665 : :
3666 : : ! If only one mpi process, use timing from gemm routine
3667 : 35023 : call timab(tim_gemmcyclic,2,tsec)
3668 : 35023 : call xgBlock_gemm('n','n',1.0d0,xgBlockA,xgBlockB,1.d0,xgBlockW)
3669 : 35023 : call timab(tim_gemmcyclic,1,tsec)
3670 : :
3671 : : else
3672 : :
3673 : 179888 : nblocks_left = xgBlockA%cols / blocksize_
3674 : 179888 : nblocks_right = xgBlockB%cols / (blocksize_*nblocks_mpi)
3675 : 179888 : multiblock = .false.
3676 [ + + ]: 179888 : if (nblocks_left>1.or.nblocks_right>1) then
3677 : 78170 : multiblock = .true.
3678 : : end if
3679 : :
3680 : 179888 : call xg_init(xg_mpi_work,xgBlockA%space,xgBlockA%rows,xgBlockA%cols,xmpi_comm_null)
3681 : 179888 : call xg_init(subB_mpi,xgBlockB%space,xgBlockB%rows/nblocks_mpi,xgBlockB%cols/nblocks_mpi,xmpi_comm_null)
3682 [ + + ]: 179888 : if (multiblock) then
3683 : 78170 : call xg_init(subB,xgBlockB%space,blocksize_,blocksize_,xmpi_comm_null)
3684 : : end if
3685 : :
3686 [ + + ]: 865616 : do iblock_mpi=1,nblocks_mpi
3687 : :
3688 : 685728 : shift_row_mpi = mod((iblock_mpi-1)+me_comm,nblocks_mpi) * blocksize_
3689 : 685728 : shift_col_mpi = me_comm * blocksize_
3690 [ + + ]: 685728 : if (.not.multiblock) then
3691 : 387420 : call xgBlock_partialcopy(xgBlockB,subB_mpi%self,shift_row_mpi,shift_col_mpi,BIG2SMALL)
3692 : : else
3693 [ + + ]: 857388 : do iblock_right=1,nblocks_right
3694 [ + + ]: 2387556 : do iblock_left=1,nblocks_left
3695 : 1530168 : shift_row = shift_row_mpi + (iblock_left-1) * blocksize_*nblocks_mpi
3696 : 1530168 : shift_col = shift_col_mpi + (iblock_right-1) * blocksize_*nblocks_mpi
3697 : 1530168 : call xgBlock_partialcopy(xgBlockB,subB%self,shift_row,shift_col,BIG2SMALL)
3698 : 1530168 : shift_row = (iblock_left-1) * blocksize_
3699 : 1530168 : shift_col = (iblock_right-1) * blocksize_
3700 : 2089248 : call xgBlock_partialcopy(subB%self,subB_mpi%self,shift_row,shift_col,SMALL2BIG)
3701 : : end do
3702 : : end do
3703 : : end if
3704 : :
3705 [ + + ]: 685728 : if (iblock_mpi==1) then
3706 : 179888 : call xgBlock_gemm('n','n',1.0d0,xgBlockA,subB_mpi%self,1.d0,xgBlockW,timing=.false.)
3707 : : else
3708 : 505840 : tag = iblock_mpi
3709 : 505840 : dest = mod(me_comm-(iblock_mpi-1),nblocks_mpi)
3710 [ + + ]: 505840 : if (dest<0) dest=dest+nblocks_mpi
3711 : 505840 : call xgBlock_mpi_isend(xgBlockA,dest,tag,request,comm=comm_)
3712 : 505840 : source = mod(me_comm+(iblock_mpi-1),nblocks_mpi)
3713 : 505840 : call xgBlock_mpi_recv(xg_mpi_work%self,source,tag,comm=comm_)
3714 : 505840 : call xgBlock_gemm('n','n',1.0d0,xg_mpi_work%self,subB_mpi%self,1.d0,xgBlockW,timing=.false.)
3715 : : end if
3716 : :
3717 [ + + ]: 865616 : if (iblock_mpi>1) call xmpi_wait(request,ierr)
3718 : :
3719 : : end do
3720 : :
3721 : 179888 : call xg_free(xg_mpi_work)
3722 : 179888 : call xg_free(subB_mpi)
3723 [ + + ]: 179888 : if (multiblock) then
3724 : 78170 : call xg_free(subB)
3725 : : end if
3726 : :
3727 : : end if
3728 : :
3729 : 214911 : call timab(tim_gemmcyclic,2,tsec)
3730 : :
3731 : 214911 : end subroutine xgBlock_gemm_mpi_cyclic_permutation
3732 : : !!***
3733 : :
3734 : : !!****f* m_xg/xgBlock_colwiseMulR
3735 : : !!
3736 : : !! NAME
3737 : : !! xgBlock_colwiseMulR
3738 : :
3739 [ - + ]: 918295 : subroutine xgBlock_colwiseMulR(xgBlock, vec)
3740 : :
3741 : : type(xgBlock_t) , intent(inout) :: xgBlock
3742 : : double precision, intent(in ), target :: vec(:)
3743 : :
3744 : : integer :: rows
3745 : : integer :: iblock,irow
3746 : :
3747 : : #if defined HAVE_GPU && defined HAVE_OPENMP_OFFLOAD
3748 : : integer :: cols
3749 : : logical :: map_vec
3750 : : complex(dp), contiguous, pointer :: xgBlock__vecC(:,:)
3751 : : real(dp), contiguous, pointer :: xgBlock__vecR(:,:)
3752 : : #endif
3753 : : double precision :: tsec(2)
3754 : :
3755 : 918295 : call timab(tim_colw_mul,1,tsec)
3756 : :
3757 : 918295 : rows = size(vec,dim=1)
3758 : :
3759 [ - + ]: 918295 : if (xgBlock%rows/=rows) then
3760 : 0 : ABI_ERROR('dim(vec)/=xgBlock%rows')
3761 : : end if
3762 : :
3763 [ + - ]: 918295 : if (xgBlock%gpu_option==ABI_GPU_KOKKOS) then
3764 : :
3765 : : #if defined(HAVE_GPU_CUDA) && defined(HAVE_KOKKOS) && defined(HAVE_YAKL)
3766 : :
3767 : : select case(xgBlock%space)
3768 : : case (SPACE_R)
3769 : : call compute_colwiseMul_scalar_scalar(c_loc(xgBlock%vecR), c_loc(vec), &
3770 : : & 0, xgBlock%rows, xgBlock%cols, &
3771 : : & xgBlock%ldim, rows)
3772 : : case (SPACE_CR)
3773 : : ABI_ERROR('Not implemented')
3774 : : case (SPACE_C)
3775 : : call compute_colwiseMul_cplx_scalar(c_loc(xgBlock%vecC), c_loc(vec), &
3776 : : & 0, xgBlock%rows, xgBlock%cols, &
3777 : : & xgBlock%ldim, rows)
3778 : : end select
3779 : :
3780 : : #endif
3781 : :
3782 [ + - ]: 918295 : else if (xgBlock%gpu_option==ABI_GPU_OPENMP) then
3783 : :
3784 : : #if defined HAVE_GPU && defined HAVE_OPENMP_OFFLOAD
3785 : :
3786 : : map_vec=.not. xomp_target_is_present(c_loc(vec))
3787 : : !$OMP TARGET ENTER DATA MAP(to:vec) IF(map_vec)
3788 : : cols=xgBlock%cols
3789 : : select case(xgBlock%space)
3790 : : case (SPACE_R)
3791 : : xgBlock__vecR => xgBlock%vecR
3792 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(2) MAP(to:xgBlock__vecR) MAP(to:vec) PRIVATE(iblock,irow)
3793 : : do iblock = 1, cols
3794 : : do irow = 1, rows
3795 : : xgBlock__vecR(irow,iblock) = xgBlock__vecR(irow,iblock) * vec(irow)
3796 : : end do
3797 : : end do
3798 : : case (SPACE_CR)
3799 : : xgBlock__vecR => xgBlock%vecR
3800 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(2) MAP(to:xgBlock__vecR) MAP(to:vec) PRIVATE(iblock,irow)
3801 : : do iblock = 1, cols
3802 : : do irow = 1, rows
3803 : : xgBlock__vecR(2*irow-1,iblock) = xgBlock__vecR(2*irow-1,iblock) * vec(irow)
3804 : : xgBlock__vecR(2*irow ,iblock) = xgBlock__vecR(2*irow ,iblock) * vec(irow)
3805 : : end do
3806 : : end do
3807 : : case (SPACE_C)
3808 : : xgBlock__vecC => xgBlock%vecC
3809 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(2) MAP(to:xgBlock__vecC) MAP(to:vec) PRIVATE(iblock,irow)
3810 : : do iblock = 1, cols
3811 : : do irow = 1, rows
3812 : : xgBlock__vecC(irow,iblock) = xgBlock__vecC(irow,iblock) * vec(irow)
3813 : : end do
3814 : : end do
3815 : : end select
3816 : : !$OMP TARGET EXIT DATA MAP(delete:vec) IF(map_vec)
3817 : : #endif
3818 : :
3819 : : else
3820 : :
3821 : 1040338 : select case(xgBlock%space)
3822 : : case (SPACE_R)
3823 : : !$omp parallel do collapse(2) shared(xgBlock,vec) private(iblock,irow)
3824 [ + + ]: 427750 : do iblock = 1, xgBlock%cols
3825 [ + + ]: 9972634 : do irow = 1, rows
3826 : 9850591 : xgBlock%vecR(irow,iblock) = xgBlock%vecR(irow,iblock) * vec(irow)
3827 : : end do
3828 : : end do
3829 : : case (SPACE_CR)
3830 : : !$omp parallel do collapse(2) shared(xgBlock,vec) private(iblock,irow)
3831 [ + + ]: 694528 : do iblock = 1, xgBlock%cols
3832 [ + + ]: 144975980 : do irow = 1, rows
3833 : 144281452 : xgBlock%vecR(2*irow-1,iblock) = xgBlock%vecR(2*irow-1,iblock) * vec(irow)
3834 : 144885336 : xgBlock%vecR(2*irow ,iblock) = xgBlock%vecR(2*irow ,iblock) * vec(irow)
3835 : : end do
3836 : : end do
3837 : : case (SPACE_C)
3838 : : !$omp parallel do collapse(2) shared(xgBlock,vec) private(iblock,irow)
3839 [ + + + - : 2728673 : do iblock = 1, xgBlock%cols
+ + ]
3840 [ + + ]: 232839374 : do irow = 1, rows
3841 : 232133766 : xgBlock%vecC(irow,iblock) = xgBlock%vecC(irow,iblock) * vec(irow)
3842 : : end do
3843 : : end do
3844 : : end select
3845 : :
3846 : : end if
3847 : :
3848 : 918295 : call timab(tim_colw_mul,2,tsec)
3849 : :
3850 : 918295 : end subroutine xgBlock_colwiseMulR
3851 : : !!***
3852 : :
3853 : : !!****f* m_xg/xgBlock_colwiseMulC
3854 : : !!
3855 : : !! NAME
3856 : : !! xgBlock_colwiseMulC
3857 : :
3858 [ # # ]: 0 : subroutine xgBlock_colwiseMulC(xgBlock, vec)
3859 : :
3860 : : type(xgBlock_t), intent(inout) :: xgBlock
3861 : : complex(kind=8), intent(in ), target :: vec(:)
3862 : :
3863 : : integer :: rows
3864 : : integer :: iblock,irow
3865 : :
3866 : : #if defined HAVE_GPU && defined HAVE_OPENMP_OFFLOAD
3867 : : integer :: cols
3868 : : complex(dp), contiguous, pointer :: xgBlock__vecC(:,:)
3869 : : #endif
3870 : : double precision :: tsec(2)
3871 : :
3872 : 0 : call timab(tim_colw_mul,1,tsec)
3873 : :
3874 : : ABI_UNUSED((/irow/)) ! Use in OpenMP GPU
3875 : 0 : rows = size(vec,dim=1)
3876 : :
3877 [ # # ]: 0 : if (xgBlock%rows/=rows) then
3878 : 0 : ABI_ERROR('dim(vec)/=xgBlock%rows')
3879 : : end if
3880 : :
3881 [ # # ]: 0 : if (xgBlock%gpu_option==ABI_GPU_KOKKOS) then
3882 : :
3883 : : #if defined(HAVE_GPU_CUDA) && defined(HAVE_KOKKOS) && defined(HAVE_YAKL)
3884 : :
3885 : : select case(xgBlock%space)
3886 : : case (SPACE_R,SPACE_CR)
3887 : : ABI_ERROR("Error colwiseMulC")
3888 : : case (SPACE_C)
3889 : : call compute_colwiseMul_cplx_cplx(c_loc(xgBlock%vecC), c_loc(vec), &
3890 : : & 0, xgBlock%rows, xgBlock%cols, &
3891 : : & xgBlock%ldim, rows)
3892 : : end select
3893 : :
3894 : : #endif
3895 : :
3896 [ # # ]: 0 : else if (xgBlock%gpu_option==ABI_GPU_OPENMP) then
3897 : :
3898 : : #if defined HAVE_GPU && defined HAVE_OPENMP_OFFLOAD
3899 : :
3900 : : select case(xgBlock%space)
3901 : : case (SPACE_R,SPACE_CR)
3902 : : ABI_ERROR("Error colwiseMulC")
3903 : : case (SPACE_C)
3904 : : cols = xgBlock%cols
3905 : : xgBlock__vecC => xgBlock%vecC
3906 : : !$OMP TARGET ENTER DATA MAP(to:vec)
3907 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(2) MAP(to:xgBlock__vecC) MAP(to:vec) PRIVATE(iblock,irow)
3908 : : do iblock = 1, cols
3909 : : do irow = 1, rows
3910 : : xgBlock__vecC(irow,iblock) = xgBlock__vecC(irow,iblock) * vec(irow)
3911 : : end do
3912 : : end do
3913 : : end select
3914 : : !$OMP TARGET EXIT DATA MAP(delete:vec)
3915 : :
3916 : : #endif
3917 : :
3918 : : else
3919 : :
3920 : 0 : select case(xgBlock%space)
3921 : : case (SPACE_R,SPACE_CR)
3922 : 0 : ABI_ERROR("Error colwiseMulC")
3923 : : case (SPACE_C)
3924 : : !$omp parallel do collapse(2) shared(xgBlock,vec) private(iblock,irow)
3925 [ # # # # : 0 : do iblock = 1, xgBlock%cols
# ]
3926 [ # # ]: 0 : do irow=1, rows
3927 : 0 : xgBlock%vecC(irow,iblock) = xgBlock%vecC(irow,iblock) * vec(irow)
3928 : : end do
3929 : : end do
3930 : : end select
3931 : :
3932 : : end if
3933 : :
3934 : 0 : call timab(tim_colw_mul,2,tsec)
3935 : :
3936 : 0 : end subroutine xgBlock_colwiseMulC
3937 : : !!***
3938 : :
3939 : : !!****f* m_xg/xgBlock_saxpyR
3940 : : !!
3941 : : !! NAME
3942 : : !! xgBlock_saxpyR
3943 : :
3944 : 1119737 : subroutine xgBlock_saxpyR(xgBlock1, da, xgBlock2)
3945 : :
3946 : : type(xgBlock_t), intent(inout) :: xgBlock1
3947 : : double precision, intent(in ) :: da
3948 : : type(xgBlock_t), intent(in ) :: xgBlock2
3949 : :
3950 : : integer :: fact
3951 : : complex(dp) :: da_cplx
3952 : : double precision :: tsec(2)
3953 : :
3954 : 1119737 : call timab(tim_saxpy,1,tsec)
3955 : :
3956 : 1119737 : da_cplx = dcmplx(da,0.0_dp)
3957 : :
3958 [ - + ]: 1119737 : if ( xgBlock1%space /= xgBlock2%space ) then
3959 : 0 : ABI_ERROR("Must be same space for saxpy")
3960 : : end if
3961 [ - + ]: 1119737 : if ( xgBlock1%LDim /= xgBlock2%LDim ) then
3962 : 0 : ABI_ERROR("Must have same LDim for saxpy")
3963 : : end if
3964 [ - + ]: 1119737 : if ( xgBlock1%cols /= xgBlock2%cols ) then
3965 : 0 : ABI_ERROR("Must have same cols for saxpy")
3966 : : end if
3967 : :
3968 : 1119737 : call xgBlock_check_gpu_option(xgBlock1,xgBlock2)
3969 : :
3970 [ + + ]: 1119737 : fact = 1 ; if (xgBlock1%space==SPACE_CR) fact = 2
3971 : :
3972 : 414239 : select case(xgBlock1%space)
3973 : : case (SPACE_R,SPACE_CR)
3974 : : call abi_xaxpy(xgBlock1%cols*fact*xgBlock1%LDim, da_cplx, xgBlock2%vecR, 1, xgBlock1%vecR, 1, &
3975 : 414239 : x_cplx=1, gpu_option=xgBlock1%gpu_option)
3976 : : case (SPACE_C)
3977 : : call abi_xaxpy(xgBlock1%cols*xgBlock1%LDim, da_cplx, xgBlock2%vecC, 1, xgBlock1%vecC, 1, &
3978 [ + + - ]: 1119737 : gpu_option=xgBlock1%gpu_option)
3979 : : end select
3980 : :
3981 : 1119737 : call timab(tim_saxpy,2,tsec)
3982 : :
3983 : 1119737 : end subroutine xgBlock_saxpyR
3984 : : !!***
3985 : :
3986 : : !!****f* m_xg/xgBlock_saxpyC
3987 : : !!
3988 : : !! NAME
3989 : : !! xgBlock_saxpyC
3990 : :
3991 : 0 : subroutine xgBlock_saxpyC(xgBlock1, da, xgBlock2)
3992 : :
3993 : : type(xgBlock_t), intent(inout) :: xgBlock1
3994 : : double complex, intent(in ) :: da
3995 : : type(xgBlock_t), intent(in ) :: xgBlock2
3996 : :
3997 : : #if defined HAVE_OPENMP_OFFLOAD && !defined HAVE_OPENMP_OFFLOAD_DATASTRUCTURE
3998 : : complex(dp), contiguous, pointer :: xgBlock1__vecC(:,:),xgBlock2__vecC(:,:)
3999 : : #endif
4000 : : double precision :: tsec(2)
4001 : :
4002 : 0 : call timab(tim_saxpy,1,tsec)
4003 : :
4004 [ # # ]: 0 : if ( xgBlock1%space /= xgBlock2%space ) then
4005 : 0 : ABI_ERROR("Must be same space for Saxpy")
4006 : : end if
4007 [ # # ]: 0 : if ( xgBlock1%LDim /= xgBlock2%LDim ) then
4008 : 0 : ABI_ERROR("Must have same LDim for Saxpy")
4009 : : end if
4010 [ # # ]: 0 : if ( xgBlock1%cols /= xgBlock2%cols ) then
4011 : 0 : ABI_ERROR("Must have same cols for Saxpy")
4012 : : end if
4013 [ # # ]: 0 : if ( xgBlock1%space /= SPACE_C ) then
4014 : 0 : ABI_ERROR("Not correct space")
4015 : : end if
4016 : :
4017 : 0 : call xgBlock_check_gpu_option(xgBlock1,xgBlock2)
4018 : :
4019 : : call abi_xaxpy(xgBlock1%cols*xgBlock1%LDim, da, xgBlock2%vecC, 1, xgBlock1%vecC, 1, &
4020 : 0 : gpu_option=xgBlock1%gpu_option)
4021 : :
4022 : 0 : call timab(tim_saxpy,2,tsec)
4023 : :
4024 : 0 : end subroutine xgBlock_saxpyC
4025 : : !!***
4026 : :
4027 : : !!****f* m_xg/xgBlock_dotC
4028 : : !!
4029 : : !! NAME
4030 : : !! xgBlock_dotC
4031 : :
4032 : 198 : subroutine xgBlock_dotC(xgBlock1, xgBlock2, xgBlock_out)
4033 : :
4034 : : type(xgBlock_t), intent(in ) :: xgBlock1
4035 : : type(xgBlock_t), intent(in ) :: xgBlock2
4036 : : type(xgBlock_t), intent(inout ) :: xgBlock_out
4037 : : double complex,external :: zdotc !conjugated dot product, not working on macos
4038 : :
4039 : : #if defined HAVE_OPENMP_OFFLOAD && !defined HAVE_OPENMP_OFFLOAD_DATASTRUCTURE
4040 : : complex(dp), contiguous, pointer :: xgBlock1__vecC(:,:),xgBlock2__vecC(:,:)
4041 : : #endif
4042 : : double precision :: tsec(2)
4043 : :
4044 : 198 : call timab(tim_dot,1,tsec)
4045 : :
4046 [ - + ]: 198 : if ( xgBlock1%space /= xgBlock2%space ) then
4047 : 0 : ABI_ERROR("Must be same space for dot")
4048 : : end if
4049 [ - + ]: 198 : if ( xgBlock1%LDim /= xgBlock2%LDim ) then
4050 : 0 : ABI_ERROR("Must have same LDim for dot")
4051 : : end if
4052 [ - + ]: 198 : if ( xgBlock1%cols /= xgBlock2%cols ) then
4053 : 0 : ABI_ERROR("Must have same cols for dot")
4054 : : end if
4055 [ + - - + ]: 198 : if ( xgBlock1%space /= SPACE_C .or. xgBlock_out%space /= SPACE_C) then
4056 : 0 : ABI_ERROR("Not correct space")
4057 : : end if
4058 : :
4059 : 198 : call xgBlock_check_gpu_option(xgBlock1,xgBlock2)
4060 : 198 : call xgBlock_check_gpu_option(xgBlock2,xgBlock_out)
4061 : :
4062 [ + - + - ]: 198 : if (xgBlock1%gpu_option==ABI_GPU_KOKKOS .or. xgBlock2%gpu_option==ABI_GPU_OPENMP) then
4063 : : #if defined HAVE_KOKKOS || defined HAVE_OPENMP_OFFLOAD_DATASTRUCTURE
4064 : : ! /IML\ will fix later compilation bug
4065 : : ABI_ERROR("not implemented")
4066 : : !call abi_gpu_xdot(2, xgBlock1%cols*xgBlock1%LDim, xgBlock_out%vecC, xgBlock1%vecC, 1, xgBlock2%vecC, 1)
4067 : : #elif defined HAVE_OPENMP_OFFLOAD
4068 : : !FIXME For several compilers, OMP doesn't work correctly with structured types, so use pointers
4069 : : xgBlock1__vecC => xgBlock1%vecC
4070 : : xgBlock2__vecC => xgBlock2%vecC
4071 : : !$OMP TARGET DATA USE_DEVICE_ADDR(xgBlock1__vecC,xgBlock2__vecC)
4072 : : ! /IML\ will fix later compilation bug
4073 : : ABI_ERROR("not implemented")
4074 : : !call abi_gpu_xdot(2, xgBlock1%cols*xgBlock1%LDim, xgBlock_out%vecC, c_loc(xgBlock1__vecC),1,c_loc(xgBlock2__vecC),1)
4075 : : !$OMP END TARGET DATA
4076 : : #endif
4077 : :
4078 : : else
4079 [ + - - - : 792 : xgBlock_out%vecC = zdotc(xgBlock1%cols*xgBlock1%LDim, xgBlock1%vecC, 1, xgBlock2%vecC, 1)
- - - - +
- - - - -
- - - + -
- - - - +
- - - - +
+ + + ]
4080 : : end if
4081 : :
4082 : 198 : call timab(tim_dot,2,tsec)
4083 : :
4084 : 198 : end subroutine xgBlock_dotC
4085 : : !!***
4086 : :
4087 : : !!****f* m_xg/xgBlock_add
4088 : : !!
4089 : : !! NAME
4090 : : !! xgBlock_add
4091 : :
4092 : 2149640 : subroutine xgBlock_add(xgBlockA, xgBlockB)
4093 : :
4094 : : type(xgBlock_t), intent(inout) :: xgBlockA
4095 : : type(xgBlock_t), intent(inout) :: xgBlockB
4096 : : integer :: col
4097 : : integer :: row
4098 : : integer :: fact
4099 : : integer :: rows,cols
4100 : :
4101 : : #if defined HAVE_GPU && defined HAVE_OPENMP_OFFLOAD
4102 : : real(dp), contiguous, pointer :: xgBlockA__vecR(:,:), xgBlockB__vecR(:,:)
4103 : : complex(dp), contiguous, pointer :: xgBlockA__vecC(:,:), xgBlockB__vecC(:,:)
4104 : : #endif
4105 : : double precision :: tsec(2)
4106 : :
4107 : 2149640 : call timab(tim_add,1,tsec)
4108 : :
4109 [ - + ]: 2149640 : if ( xgBlockA%space /= xgBlockB%space ) then
4110 : 0 : ABI_ERROR("Must be same space for add")
4111 : : end if
4112 [ - + ]: 2149640 : if ( xgBlockA%rows /= xgBlockB%rows ) then
4113 : 0 : ABI_ERROR("Must have same LDim for add")
4114 : : end if
4115 [ - + ]: 2149640 : if ( xgBlockA%cols /= xgBlockB%cols ) then
4116 : 0 : ABI_ERROR("Must have same cols for add")
4117 : : end if
4118 : :
4119 : 2149640 : call xgBlock_check_gpu_option(xgBlockA,xgBlockB)
4120 : :
4121 [ + + ]: 2149640 : fact = 1 ; if (xgBlockA%space==SPACE_CR) fact = 2
4122 : 2149640 : rows=fact*xgBlockB%rows
4123 : 2149640 : cols=xgBlockB%cols
4124 : :
4125 [ + - ]: 2149640 : if (xgBlockA%gpu_option==ABI_GPU_OPENMP) then
4126 : : #if defined HAVE_GPU && defined HAVE_OPENMP_OFFLOAD
4127 : : select case(xgBlockA%space)
4128 : : case (SPACE_R,SPACE_CR)
4129 : : xgBlockA__vecR => xgBlockA%vecR
4130 : : xgBlockB__vecR => xgBlockB%vecR
4131 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(2) MAP(to:xgBlockA__vecR,xgBlockB__vecR)
4132 : : do col = 1, cols
4133 : : do row = 1, rows
4134 : : xgBlockA__vecR(row,col) = xgBlockA__vecR(row,col) + xgBlockB__vecR(row,col)
4135 : : end do
4136 : : end do
4137 : : !call daxpy(xgBlockA%cols*xgBlockA%LDim,1.d0,xgBlockB%vecR,1,xgBlockA%vecR1)
4138 : : case (SPACE_C)
4139 : : xgBlockA__vecC => xgBlockA%vecC
4140 : : xgBlockB__vecC => xgBlockB%vecC
4141 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(2) MAP(to:xgBlockA__vecC,xgBlockB__vecC)
4142 : : do col = 1, cols
4143 : : do row = 1, rows
4144 : : xgBlockA__vecC(row,col) = xgBlockA__vecC(row,col) + xgBlockB__vecC(row,col)
4145 : : end do
4146 : : end do
4147 : : !call zaxpy(xgBlockA%cols*xgBlockA%LDim,1.d0,xgBlockB%vecR,1,xgBlockA%vecR1)
4148 : : end select
4149 : : #endif
4150 : : else
4151 : : select case(xgBlockA%space)
4152 : : case (SPACE_R,SPACE_CR)
4153 : : !$omp parallel do collapse(2) shared(xgBlockA,xgBlockB) private(col,row)
4154 [ + + ]: 2556988 : do col = 1, cols
4155 [ + + ]: 696784742 : do row = 1, rows
4156 : 696413818 : xgBlockA%vecR(row,col) = xgBlockA%vecR(row,col) + xgBlockB%vecR(row,col)
4157 : : end do
4158 : : end do
4159 : : !call daxpy(xgBlockA%cols*xgBlockA%LDim,1.d0,xgBlockB%vecR,1,xgBlockA%vecR1)
4160 : : case (SPACE_C)
4161 : : !$omp parallel do collapse(2) shared(xgBlockA,xgBlockB) private(col,row)
4162 [ + + - + : 8076844 : do col = 1, cols
+ ]
4163 [ + + ]: 552176552 : do row = 1, rows
4164 : 550397836 : xgBlockA%vecC(row,col) = xgBlockA%vecC(row,col) + xgBlockB%vecC(row,col)
4165 : : end do
4166 : : end do
4167 : : !call zaxpy(xgBlockA%cols*xgBlockA%LDim,1.d0,xgBlockB%vecR,1,xgBlockA%vecR1)
4168 : : end select
4169 : : end if
4170 : :
4171 : 2149640 : call timab(tim_add,2,tsec)
4172 : :
4173 : 2149640 : end subroutine xgBlock_add
4174 : : !!***
4175 : :
4176 : : !!****f* m_xg/xgBlock_cshift
4177 : : !!
4178 : : !! NAME
4179 : : !! xgBlock_cshift
4180 : :
4181 : 615918 : subroutine xgBlock_cshift(xgBlock,nshift,shiftdim)
4182 : :
4183 : : type(xgBlock_t), intent(inout) :: xgBlock
4184 : : integer , intent(in ) :: nshift
4185 : : integer , intent(in ) :: shiftdim
4186 : : double precision :: tsec(2)
4187 : :
4188 : 615918 : call timab(tim_cshift,1,tsec)
4189 : 686226 : select case(xgBlock%space)
4190 : : case (SPACE_R)
4191 [ + + + + ]: 42800784 : xgBlock%vecR(:,:) = cshift(xgBlock%vecR(:,:),nshift,dim=shiftdim) ! Bottom 2*blockdim lines are now at the top
4192 : : case (SPACE_C)
4193 [ + + + + ]: 21281316 : xgBlock%vecC(:,:) = cshift(xgBlock%vecC(:,:),nshift,dim=shiftdim) ! Bottom 2*blockdim lines are now at the top
4194 : : case (SPACE_CR)
4195 [ + + - - ]: 615918 : ABI_ERROR('Not implemented')
4196 : : end select
4197 : 615918 : call timab(tim_cshift,2,tsec)
4198 : :
4199 : 615918 : end subroutine xgBlock_cshift
4200 : : !!***
4201 : :
4202 : : !!****f* m_xg/xgBlock_colwiseNorm2
4203 : : !!
4204 : : !! NAME
4205 : : !! xgBlock_colwiseNorm2
4206 : :
4207 : 1606613 : subroutine xgBlock_colwiseNorm2(xgBlock, dot, max_val, max_elt, min_val, min_elt, comm_loc)
4208 : :
4209 : : type(xgBlock_t) , intent(in ) :: xgBlock
4210 : : type(xgBlock_t) , intent(inout) :: dot
4211 : : double precision, intent( out), optional :: max_val
4212 : : integer , intent( out), optional :: max_elt
4213 : : double precision, intent( out), optional :: min_val
4214 : : integer , intent( out), optional :: min_elt
4215 : : integer , intent(in ), optional :: comm_loc
4216 : :
4217 : : integer :: icol, ierr, fact, comm_
4218 : : double precision,external :: ddot
4219 : : #if defined HAVE_GPU && defined HAVE_OPENMP_OFFLOAD
4220 : : integer :: cols,rows
4221 : : complex(dp), contiguous, pointer :: xgBlock__vecC(:,:)
4222 : : real(dp), contiguous, pointer :: xgBlock__vecR(:,:),dot__vecR(:,:)
4223 : : #endif
4224 : :
4225 : : #if (defined HAVE_GPU && defined HAVE_OPENMP_OFFLOAD) || defined FC_CRAY
4226 : : integer :: ii
4227 : : double precision :: tmp
4228 : : #endif
4229 : : double precision :: tsec(2)
4230 : :
4231 : 1606613 : call timab(tim_colw_norm2,1,tsec)
4232 : :
4233 [ - + ]: 1606613 : if ( dot%space /= SPACE_R ) then
4234 : 0 : ABI_ERROR("space(dot) should be SPACE_R")
4235 : : end if
4236 [ - + ]: 1606613 : if ( dot%cols /= 1 ) then
4237 : 0 : ABI_ERROR("cols(dot) should be 1")
4238 : : end if
4239 [ - + ]: 1606613 : if ( dot%rows /= xgBlock%cols ) then
4240 : 0 : ABI_ERROR("rows(dot) should be cols(xgBlock)")
4241 : : end if
4242 : 1606613 : comm_=comm(xgBlock)
4243 [ + + ]: 1606613 : if (present(comm_loc)) then
4244 : 4660 : comm_ = comm_loc
4245 : : end if
4246 : :
4247 [ + + - + ]: 1606613 : if (xgBlock%space==SPACE_CR.and.xgBlock%me_g0<0) then
4248 : 0 : ABI_ERROR("xgBlock me_g0 is not initialized")
4249 : : end if
4250 [ + + ]: 1606613 : fact = 1 ; if (xgBlock%space==SPACE_CR) fact = 2
4251 : :
4252 [ + - ]: 1606613 : if (xgBlock%gpu_option==ABI_GPU_KOKKOS) then
4253 : :
4254 : : #if defined(HAVE_GPU_CUDA) && defined(HAVE_KOKKOS) && defined(HAVE_YAKL)
4255 : :
4256 : : select case(xgBlock%space)
4257 : : case(SPACE_R,SPACE_CR)
4258 : : if (xgBlock%space==SPACE_CR) then
4259 : : ABI_ERROR('Not implemented for GPU with KOKKOS')
4260 : : end if
4261 : : call computeBatchedDotProduct_scalar(c_loc(xgBlock%vecR), c_loc(xgBlock%vecR), &
4262 : : & c_loc(dot%vecR), fact*xgBlock%rows, xgBlock%cols, fact*xgBlock%ldim)
4263 : :
4264 : : case(SPACE_C)
4265 : : call computeBatchedDotProduct_cplx_scalar(c_loc(xgBlock%vecC), c_loc(xgBlock%vecC), &
4266 : : & c_loc(dot%vecR), xgBlock%rows, xgBlock%cols, xgBlock%ldim)
4267 : :
4268 : : end select
4269 : : call xmpi_sum(dot%vecR,comm_,ierr)
4270 : :
4271 : : ! do reductions
4272 : : if ( present(max_val) ) then
4273 : : call computeMax_scalar(c_loc(dot%vecR(1,1)), xgBlock%cols, max_val)
4274 : : end if
4275 : : if ( present(min_val) ) then
4276 : : call computeMin_scalar(c_loc(dot%vecR(1,1)), xgBlock%cols, min_val)
4277 : : end if
4278 : : if ( present(max_elt) ) then
4279 : : call computeMaxloc_scalar(c_loc(dot%vecR(1,1)), xgBlock%cols, max_elt)
4280 : : end if
4281 : : if ( present(min_elt) ) then
4282 : : call computeMinloc_scalar(c_loc(dot%vecR(1,1)), xgBlock%cols, min_elt)
4283 : : end if
4284 : :
4285 : : #else
4286 : : ! we shouldn't be here, it means gpu_option was wrongly set to 1 in
4287 : : ! input parameter file
4288 : : #endif
4289 : :
4290 [ + - ]: 1606613 : else if (xgBlock%gpu_option==ABI_GPU_OPENMP) then
4291 : :
4292 : : #if defined HAVE_GPU && defined HAVE_OPENMP_OFFLOAD
4293 : :
4294 : : cols=xgBlock%cols
4295 : : rows=fact*xgBlock%rows
4296 : : dot__vecR => dot%vecR
4297 : : select case(xgBlock%space)
4298 : : case(SPACE_R,SPACE_CR)
4299 : : xgBlock__vecR => xgBlock%vecR
4300 : : !$OMP TARGET TEAMS DISTRIBUTE MAP(to:dot__vecR,xgBlock__vecR) PRIVATE(icol,tmp)
4301 : : do icol = 1, cols
4302 : : tmp=0
4303 : : !$OMP PARALLEL DO REDUCTION(+:tmp) PRIVATE(ii)
4304 : : do ii = 1,rows
4305 : : tmp = tmp + fact*xgBlock__vecR(ii,icol)*xgBlock__vecR(ii,icol)
4306 : : end do
4307 : : dot__vecR(icol,1)=tmp
4308 : : end do
4309 : : if (xgBlock%me_g0==1) then
4310 : : !$OMP TARGET TEAMS DISTRIBUTE MAP(to:dot__vecR,xgBlock__vecR) PRIVATE(icol)
4311 : : do icol = 1, cols
4312 : : dot__vecR(icol,1) = dot__vecR(icol,1) - xgBlock__vecR(1,icol)*xgBlock__vecR(1,icol) &
4313 : : & - xgBlock__vecR(2,icol)*xgBlock__vecR(2,icol)
4314 : : end do
4315 : : end if
4316 : : case(SPACE_C)
4317 : : xgBlock__vecC => xgBlock%vecC
4318 : : !$OMP TARGET TEAMS DISTRIBUTE MAP(to:dot__vecR,xgBlock__vecC) PRIVATE(icol,tmp)
4319 : : do icol = 1, cols
4320 : : tmp=0
4321 : : !$OMP PARALLEL DO REDUCTION(+:tmp) PRIVATE(ii)
4322 : : do ii = 1,rows
4323 : : tmp = tmp + dconjg(xgBlock__vecC(ii,icol))*xgBlock__vecC(ii,icol)
4324 : : end do
4325 : : dot__vecR(icol,1)=tmp
4326 : : end do
4327 : : end select
4328 : : !FIXME This should happen inplace ideally
4329 : : !$OMP TARGET UPDATE FROM(dot__vecR)
4330 : : call xmpi_sum(dot%vecR,comm_,icol)
4331 : : !$OMP TARGET UPDATE TO(dot__vecR)
4332 : :
4333 : : ! do reductions
4334 : : if ( present(max_val) ) then
4335 : : max_val = maxval(dot%vecR(1:xgBlock%cols,1))
4336 : : end if
4337 : : if ( present(min_val) ) then
4338 : : min_val = minval(dot%vecR(1:xgBlock%cols,1))
4339 : : end if
4340 : : if ( present(max_elt) ) then
4341 : : max_elt = maxloc(dot%vecR(1:xgBlock%cols,1),dim=1)
4342 : : end if
4343 : : if ( present(min_elt) ) then
4344 : : min_elt = minloc(dot%vecR(1:xgBlock%cols,1),dim=1)
4345 : : end if
4346 : :
4347 : : #endif
4348 : :
4349 : : else
4350 : :
4351 : 381790 : select case(xgBlock%space)
4352 : : case(SPACE_R,SPACE_CR)
4353 : : !$omp parallel do shared(dot,xgBlock)
4354 [ + + ]: 2486410 : do icol = 1, xgBlock%cols
4355 : 2486410 : dot%vecR(icol,1) = fact*ddot(fact*xgBlock%rows,xgBlock%vecR(:,icol),1,xgBlock%vecR(:,icol),1)
4356 : : end do
4357 : : !$omp end parallel do
4358 [ + + ]: 381790 : if (xgBlock%me_g0==1) then
4359 : : !$omp parallel do shared(dot,xgBlock)
4360 [ + + ]: 180796 : do icol = 1, xgBlock%cols
4361 : 180796 : dot%vecR(icol,1) = dot%vecR(icol,1) - ddot(2,xgBlock%vecR(:,icol),1,xgBlock%vecR(:,icol),1)
4362 : : end do
4363 : : !$omp end parallel do
4364 : : end if
4365 : : case(SPACE_C)
4366 : : #if defined(FC_CRAY)
4367 : : !FIXME zdotc call goes wrong with NVHPC (NVHPC 22.11, MKL 22.3) or CRAY
4368 : : !$omp parallel do private(ii,tmp)
4369 : : do icol = 1, xgBlock%cols
4370 : : tmp=0
4371 : : do ii = 1, xgBlock%rows
4372 : : tmp = tmp + dconjg(xgBlock%vecC(ii,icol))*xgBlock%vecC(ii,icol)
4373 : : end do
4374 : : dot%vecR(icol,1)=tmp
4375 : : end do
4376 : : !$omp end parallel do
4377 : : #else
4378 : : !$omp parallel do shared(dot,xgBlock)
4379 [ + + - + : 7494639 : do icol = 1, xgBlock%cols
+ ]
4380 : : ! Instead of calling a complex function to get only the real part of the
4381 : : ! result
4382 : : !dot%vecR(icol,1) = dble(zdotc(xgBlock%rows,xgBlock%vecC(:,icol),1,xgBlock%vecC(:,icol),1))
4383 : : ! Directely call a real function which gives what we want.
4384 : 7112849 : dot%vecR(icol,1) = ddot(2*xgBlock%rows,xgBlock%vecC(:,icol),1,xgBlock%vecC(:,icol),1)
4385 : : end do
4386 : : !$omp end parallel do
4387 : : #endif
4388 : : end select
4389 : 1606613 : call xmpi_sum(dot%vecR,comm_,ierr)
4390 : :
4391 [ + + ]: 1606613 : if ( present(max_val) ) then
4392 [ + - - + : 7203198 : max_val = maxval(dot%vecR(1:xgBlock%cols,1))
- - + + ]
4393 : : end if
4394 [ - + ]: 1606613 : if ( present(min_val) ) then
4395 [ # # # # : 0 : min_val = minval(dot%vecR(1:xgBlock%cols,1))
# # # # ]
4396 : : end if
4397 [ - + ]: 1606613 : if ( present(max_elt) ) then
4398 [ # # # # : 0 : max_elt = maxloc(dot%vecR(1:xgBlock%cols,1),dim=1)
# # # # #
# ]
4399 : : end if
4400 [ - + ]: 1606613 : if ( present(min_elt) ) then
4401 [ # # # # : 0 : min_elt = minloc(dot%vecR(1:xgBlock%cols,1),dim=1)
# # # # #
# ]
4402 : : end if
4403 : :
4404 : : end if ! if gpu_option==ABI_GPU_KOKKOS
4405 : :
4406 : 1606613 : call timab(tim_colw_norm2,2,tsec)
4407 : :
4408 : 1606613 : end subroutine xgBlock_colwiseNorm2
4409 : : !!***
4410 : :
4411 : : !!****f* m_xg/xgBlock_colwiseDotProduct
4412 : : !!
4413 : : !! NAME
4414 : : !! xgBlock_colwiseDotProduct
4415 : :
4416 : 71688 : subroutine xgBlock_colwiseDotProduct(xgBlockA,xgBlockB,dot,max_val,max_elt,min_val,min_elt,comm_loc)
4417 : :
4418 : : type(xgBlock_t) , intent(in ) :: xgBlockA
4419 : : type(xgBlock_t) , intent(in ) :: xgBlockB
4420 : : type(xgBlock_t) , intent(inout) :: dot
4421 : : integer, intent(in), optional :: comm_loc
4422 : : double precision , intent( out), optional :: max_val
4423 : : integer , intent( out), optional :: max_elt
4424 : : double precision , intent( out), optional :: min_val
4425 : : integer , intent( out), optional :: min_elt
4426 : : integer :: icol,fact,comm_
4427 : : double precision,external :: ddot
4428 : : !double complex,external :: zdotc !conjugated dot product, not working on macos
4429 : :
4430 : : #if (defined HAVE_GPU && defined HAVE_OPENMP_OFFLOAD) || defined(FC_NVHPC) || defined(FC_CRAY)
4431 : : integer :: rows,cols,ii,me_g0
4432 : : double precision :: tmp
4433 : : complex(dp), contiguous, pointer :: xgBlockA__vecC(:,:),xgBlockB__vecC(:,:),dot__vecC(:,:)
4434 : : real(dp), contiguous, pointer :: xgBlockA__vecR(:,:),xgBlockB__vecR(:,:),dot__vecR(:,:)
4435 : : #endif
4436 : : double precision :: tsec(2)
4437 : :
4438 : 71688 : call timab(tim_colw_dot,1,tsec)
4439 : :
4440 : 71688 : call xgBlock_check(xgBlockA,xgBlockB)
4441 : :
4442 : 71688 : comm_=comm(xgBlockA)
4443 [ + + ]: 71688 : if (present(comm_loc)) then
4444 : 70608 : comm_ = comm_loc
4445 : : else
4446 [ - + ]: 1080 : if (comm(xgBlockA)/=comm(xgBlockB)) then
4447 : 0 : ABI_ERROR('xgBlockA and xgBlockB should have the same comm')
4448 : : end if
4449 : : end if
4450 : 71688 : call xgBlock_check_gpu_option(xgBlockA,xgBlockB)
4451 : 71688 : call xgBlock_check_gpu_option(xgBlockA,dot)
4452 : :
4453 [ + + ]: 71688 : if (xgBlockA%space/=SPACE_CR) then
4454 [ - + ]: 51842 : if (dot%space/=xgBlockA%space) then
4455 : 0 : ABI_ERROR('xgBlockA and dot should have the same space')
4456 : : end if
4457 : : else ! space(A) = space(B) = SPACE_CR
4458 [ - + ]: 19846 : if (xgBlockA%me_g0<0) then
4459 : 0 : ABI_ERROR("xgBlockA me_g0 is not initialized")
4460 : : end if
4461 [ - + ]: 19846 : if (xgBlockB%me_g0<0) then
4462 : 0 : ABI_ERROR("xgBlockB me_g0 is not initialized")
4463 : : end if
4464 [ - + ]: 19846 : if (xgBlockA%me_g0/=xgBlockB%me_g0) then
4465 : 0 : ABI_ERROR('xgBlockA and xgBlockB should have the same me_g0')
4466 : : end if
4467 [ - + ]: 19846 : if (dot%space/=SPACE_R) then
4468 : 0 : ABI_ERROR('if space(A)=SPACE_CR, space(dot) should be SPACE_R')
4469 : : end if
4470 : : end if
4471 [ - + ]: 71688 : if ( dot%cols /= 1 ) then
4472 : 0 : ABI_ERROR("cols(dot) should be 1")
4473 : : end if
4474 [ - + ]: 71688 : if ( dot%rows /= xgBlockA%cols ) then
4475 : 0 : ABI_ERROR("rows(dot) should be cols(xgBlockA)")
4476 : : end if
4477 : :
4478 [ + + ]: 71688 : fact = 1 ; if (xgBlockA%space==SPACE_CR) fact = 2
4479 : :
4480 [ + - ]: 71688 : if (xgBlockA%gpu_option==ABI_GPU_KOKKOS) then
4481 : :
4482 : : #if defined(HAVE_GPU_CUDA) && defined(HAVE_KOKKOS) && defined(HAVE_YAKL)
4483 : :
4484 : : select case(xgBlockA%space)
4485 : : case(SPACE_R,SPACE_CR)
4486 : : if (xgBlockA%space==SPACE_CR) then
4487 : : ABI_ERROR('Not implemented for GPU with KOKKOS')
4488 : : end if
4489 : : call computeBatchedDotProduct_scalar(c_loc(xgBlockA%vecR), c_loc(xgBlockB%vecR), &
4490 : : & c_loc(dot%vecR), xgBlockA%rows, xgBlockA%cols, xgBlockA%ldim)
4491 : :
4492 : : ! do reductions
4493 : : if ( present(max_val) ) then
4494 : : call computeMax_scalar(c_loc(dot%vecR(1,1)), xgBlockA%cols, max_val)
4495 : : end if
4496 : : if ( present(min_val) ) then
4497 : : call computeMin_scalar(c_loc(dot%vecR(1,1)), xgBlockA%cols, min_val)
4498 : : end if
4499 : : if ( present(max_elt) ) then
4500 : : call computeMaxloc_scalar(c_loc(dot%vecR(1,1)), xgBlockA%cols, max_elt)
4501 : : end if
4502 : : if ( present(min_elt) ) then
4503 : : call computeMinloc_scalar(c_loc(dot%vecR(1,1)), xgBlockA%cols, min_elt)
4504 : : end if
4505 : :
4506 : : case(SPACE_C)
4507 : : call computeBatchedDotProduct_cplx(c_loc(xgBlockA%vecC), c_loc(xgBlockB%vecC), &
4508 : : & c_loc(dot%vecC), xgBlockA%rows, xgBlockA%cols, xgBlockA%ldim)
4509 : :
4510 : : ! do reductions
4511 : : if ( present(max_val) ) then
4512 : : call computeMax_complex(c_loc(dot%vecC(1,1)), xgBlockA%cols, max_val)
4513 : : end if
4514 : : if ( present(min_val) ) then
4515 : : call computeMin_complex(c_loc(dot%vecC(1,1)), xgBlockA%cols, min_val)
4516 : : end if
4517 : : if ( present(max_elt) ) then
4518 : : call computeMaxloc_complex(c_loc(dot%vecC(1,1)), xgBlockA%cols, max_elt)
4519 : : end if
4520 : : if ( present(min_elt) ) then
4521 : : call computeMinloc_scalar(c_loc(dot%vecC(1,1)), xgBlockA%cols, min_elt)
4522 : :
4523 : : end if
4524 : :
4525 : : end select
4526 : :
4527 : : #else
4528 : : ! we shouldn't be here, it means gpu_option was wrongly set to 1 in
4529 : : ! input parameter file
4530 : : #endif
4531 : :
4532 [ + - ]: 71688 : else if (xgBlockA%gpu_option==ABI_GPU_OPENMP) then
4533 : :
4534 : : #if defined HAVE_GPU && defined HAVE_OPENMP_OFFLOAD
4535 : : rows = xgBlockA%rows; cols = xgBlockA%cols
4536 : : select case(xgBlockA%space)
4537 : : case(SPACE_R,SPACE_CR)
4538 : : xgBlockA__vecR => xgBlockA%vecR
4539 : : xgBlockB__vecR => xgBlockB%vecR
4540 : : dot__vecR => dot%vecR
4541 : : me_g0 = xgBlockA%me_g0
4542 : : #if defined FC_NVHPC
4543 : : !$OMP TARGET TEAMS DISTRIBUTE MAP(to:dot__vecR,xgBlockA__vecR,xgBlockB__vecR) PRIVATE(icol,tmp)
4544 : : do icol = 1, cols
4545 : : tmp=0
4546 : : !$OMP PARALLEL DO REDUCTION(+:tmp) PRIVATE(ii)
4547 : : do ii = 1, fact*rows
4548 : : tmp = tmp + fact*xgBlockA__vecR(ii,icol)*xgBlockB__vecR(ii,icol)
4549 : : end do
4550 : : dot__vecR(icol,1)=tmp
4551 : : end do
4552 : : if (me_g0==1) then
4553 : : !$OMP TARGET TEAMS DISTRIBUTE MAP(to:dot__vecR,xgBlockA__vecR,xgBlockB__vecR) PRIVATE(icol)
4554 : : do icol = 1, cols
4555 : : dot__vecR(icol,1) = dot__vecR(icol,1) - xgBlockA__vecR(1,icol)*xgBlockB__vecR(1,icol)
4556 : : end do
4557 : : end if
4558 : : !$OMP TARGET UPDATE FROM(dot__vecR)
4559 : : #else
4560 : : !FIXME For several compilers, this section doesnt work properly
4561 : : !$OMP TARGET UPDATE FROM(dot__vecR,xgBlockA__vecR,xgBlockB__vecR)
4562 : : !!$OMP TARGET TEAMS DISTRIBUTE MAP(to:dot__vecR,xgBlockA__vecR,xgBlockB__vecR) PRIVATE(icol,tmp)
4563 : : do icol = 1, cols
4564 : : tmp=0
4565 : : !!$OMP PARALLEL DO REDUCTION(+:tmp) PRIVATE(ii)
4566 : : do ii = 1, fact*rows
4567 : : tmp = tmp + fact*xgBlockA__vecR(ii,icol)*xgBlockB__vecR(ii,icol)
4568 : : end do
4569 : : dot__vecR(icol,1)=tmp
4570 : : end do
4571 : : if (me_g0==1) then
4572 : : do icol = 1, cols
4573 : : dot__vecR(icol,1) = dot__vecR(icol,1) - xgBlockA__vecR(1,icol)*xgBlockB__vecR(1,icol)
4574 : : end do
4575 : : end if
4576 : : !$OMP TARGET UPDATE TO(dot__vecR)
4577 : : #endif
4578 : :
4579 : : !TODO Port this to GPU (reductions)
4580 : : if ( present(max_val) ) then
4581 : : max_val = maxval(dot%vecR(1:xgBlockA%cols,1))
4582 : : end if
4583 : : if ( present(min_val) ) then
4584 : : min_val = minval(dot%vecR(1:xgBlockA%cols,1))
4585 : : end if
4586 : : if ( present(max_elt) ) then
4587 : : max_elt = maxloc(dot%vecR(1:xgBlockA%cols,1),dim=1)
4588 : : end if
4589 : : if ( present(min_elt) ) then
4590 : : min_elt = minloc(dot%vecR(1:xgBlockA%cols,1),dim=1)
4591 : : end if
4592 : :
4593 : : case(SPACE_C)
4594 : : xgBlockA__vecC => xgBlockA%vecC
4595 : : xgBlockB__vecC => xgBlockB%vecC
4596 : : dot__vecC => dot%vecC
4597 : : #if defined FC_NVHPC
4598 : : !$OMP TARGET TEAMS DISTRIBUTE MAP(to:dot__vecC,xgBlockA__vecC,xgBlockB__vecC) PRIVATE(icol,tmp)
4599 : : do icol = 1, cols
4600 : : tmp=0
4601 : : !$OMP PARALLEL DO REDUCTION(+:tmp) PRIVATE(ii)
4602 : : do ii = 1, rows
4603 : : tmp = tmp + dconjg(xgBlockA__vecC(ii,icol))*xgBlockB__vecC(ii,icol)
4604 : : end do
4605 : : dot__vecC(icol,1)=tmp
4606 : : end do
4607 : : !$OMP TARGET UPDATE FROM(dot__vecC)
4608 : : #else
4609 : : !FIXME For several compilers, this section doesnt work properly
4610 : : !$OMP TARGET UPDATE FROM(xgBlockA__vecC,xgBlockB__vecC)
4611 : : do icol = 1, cols
4612 : : tmp=0
4613 : : !$OMP PARALLEL DO REDUCTION(+:tmp) PRIVATE(ii)
4614 : : do ii = 1, rows
4615 : : tmp = tmp + dconjg(xgBlockA__vecC(ii,icol))*xgBlockB__vecC(ii,icol)
4616 : : end do
4617 : : dot__vecC(icol,1)=tmp
4618 : : end do
4619 : : !$OMP TARGET UPDATE TO(dot__vecC)
4620 : : #endif
4621 : :
4622 : : !TODO Port this to GPU (reductions)
4623 : : if ( present(max_val) ) then
4624 : : max_val = maxval(dble(dot%vecC(1:xgBlockA%cols,1)))
4625 : : end if
4626 : : if ( present(min_val) ) then
4627 : : min_val = minval(dble(dot%vecC(1:xgBlockA%cols,1)))
4628 : : end if
4629 : : if ( present(max_elt) ) then
4630 : : max_elt = maxloc(dble(dot%vecC(1:xgBlockA%cols,1)),dim=1)
4631 : : end if
4632 : : if ( present(min_elt) ) then
4633 : : min_elt = minloc(dble(dot%vecC(1:xgBlockA%cols,1)),dim=1)
4634 : : end if
4635 : :
4636 : : end select
4637 : :
4638 : : #endif
4639 : :
4640 : : else
4641 : :
4642 : 27191 : select case(xgBlockA%space)
4643 : : case(SPACE_R,SPACE_CR)
4644 : : !$omp parallel do shared(dot,xgBlockA,xgBlockB)
4645 [ + + ]: 155851 : do icol = 1, xgBlockA%cols
4646 : 155851 : dot%vecR(icol,1) = fact*ddot(fact*xgBlockA%rows,xgBlockA%vecR(:,icol),1,xgBlockB%vecR(:,icol),1)
4647 : : end do
4648 : : !$omp end parallel do
4649 [ + + ]: 27191 : if (xgBlockA%me_g0==1) then
4650 : : !$omp parallel do shared(dot,xgBlockA,xgBlockB) &
4651 : : !$omp& schedule(static)
4652 [ + + ]: 16230 : do icol = 1, xgBlockA%cols
4653 : 16230 : dot%vecR(icol,1) = dot%vecR(icol,1) - ddot(2,xgBlockA%vecR(:,icol),1,xgBlockB%vecR(:,icol),1)
4654 : : end do
4655 : : !$omp end parallel do
4656 : : end if
4657 : :
4658 [ - + ]: 27191 : if ( present(max_val) ) then
4659 [ # # # # : 0 : max_val = maxval(dot%vecR(1:xgBlockA%cols,1))
# # # # ]
4660 : : end if
4661 [ - + ]: 27191 : if ( present(min_val) ) then
4662 [ # # # # : 0 : min_val = minval(dot%vecR(1:xgBlockA%cols,1))
# # # # ]
4663 : : end if
4664 [ - + ]: 27191 : if ( present(max_elt) ) then
4665 [ # # # # : 0 : max_elt = maxloc(dot%vecR(1:xgBlockA%cols,1),dim=1)
# # # # #
# ]
4666 : : end if
4667 [ - + ]: 27191 : if ( present(min_elt) ) then
4668 [ # # # # : 0 : min_elt = minloc(dot%vecR(1:xgBlockA%cols,1),dim=1)
# # # # #
# ]
4669 : : end if
4670 : :
4671 : : case(SPACE_C)
4672 : : #if defined(FC_NVHPC) || defined(FC_CRAY)
4673 : : !FIXME zdotc call goes wrong with NVHPC (NVHPC 22.11, MKL 22.3) or CRAY
4674 : : !$omp parallel do private(ii,tmp) shared(dot,xgBlockA,xgBlockB)
4675 : : do icol = 1, xgBlockA%cols
4676 : : tmp=0
4677 : : do ii = 1, xgBlockA%rows
4678 : : tmp = tmp + dconjg(xgBlockA%vecC(ii,icol))*xgBlockB%vecC(ii,icol)
4679 : : end do
4680 : : dot%vecC(icol,1)=tmp
4681 : : end do
4682 : : !$omp end parallel do
4683 : : #else
4684 : : !$omp parallel do shared(dot,xgBlockA,xgBlockB)
4685 [ + + ]: 298921 : do icol = 1, xgBlockA%cols
4686 : 298921 : dot%vecC(icol,1) = xdotc(xgBlockA%rows,xgBlockA%vecC(:,icol),1,xgBlockB%vecC(:,icol),1)
4687 : : end do
4688 : : !$omp end parallel do
4689 : : #endif
4690 : :
4691 [ - + ]: 44497 : if ( present(max_val) ) then
4692 [ # # # # : 0 : max_val = maxval(dble(dot%vecC(1:xgBlockA%cols,1)))
# # # # ]
4693 : : end if
4694 [ - + ]: 44497 : if ( present(min_val) ) then
4695 [ # # # # : 0 : min_val = minval(dble(dot%vecC(1:xgBlockA%cols,1)))
# # # # ]
4696 : : end if
4697 [ - + ]: 44497 : if ( present(max_elt) ) then
4698 [ # # # # : 0 : max_elt = maxloc(dble(dot%vecC(1:xgBlockA%cols,1)),dim=1)
# # # # #
# ]
4699 : : end if
4700 [ + + - - : 116185 : if ( present(min_elt) ) then
+ ]
4701 [ # # # # : 0 : min_elt = minloc(dble(dot%vecC(1:xgBlockA%cols,1)),dim=1)
# # # # #
# ]
4702 : : end if
4703 : :
4704 : : end select
4705 : :
4706 : : end if ! gpu_option
4707 : :
4708 : 71688 : call xgBlock_mpi_sum(dot,comm=comm_)
4709 : :
4710 : 71688 : call timab(tim_colw_dot,2,tsec)
4711 : :
4712 : 71688 : end subroutine xgBlock_colwiseDotProduct
4713 : : !!***
4714 : :
4715 : : !!****f* m_xg/xgBlock_colwiseDivision
4716 : : !!
4717 : : !! NAME
4718 : : !! xgBlock_colwiseDivision
4719 : :
4720 : 26664 : subroutine xgBlock_colwiseDivision(xgBlockA, xgBlockB, divResult, &
4721 : : & max_val, max_elt, min_val, min_elt)
4722 : :
4723 : : type(xgBlock_t) , intent(in ) :: xgBlockA
4724 : : type(xgBlock_t) , intent(in ) :: xgBlockB
4725 : : type(xgBlock_t) , intent(inout) :: divResult
4726 : : double precision, intent(inout), optional :: max_val
4727 : : integer, dimension(2), intent(inout), optional, target :: max_elt
4728 : : double precision, intent(inout), optional :: min_val
4729 : : integer, dimension(2), intent(inout), optional, target :: min_elt
4730 : :
4731 : : integer :: irow,icol,rows,cols
4732 : :
4733 : : #if defined HAVE_GPU
4734 : : ! TODO: evaluate if total_size should be a 64 bit integer, i.e.
4735 : : ! does spacedim * neigenpairs be larger than 2^31 = 2. 10^9
4736 : : integer(kind=c_int32_t) :: total_size
4737 : : #if defined HAVE_OPENMP_OFFLOAD
4738 : : complex(dp), contiguous, pointer :: xgBlockA__vecC(:,:),xgBlockB__vecC(:,:),divResult__vecC(:,:)
4739 : : real(dp), contiguous, pointer :: xgBlockA__vecR(:,:),xgBlockB__vecR(:,:),divResult__vecR(:,:)
4740 : : #endif
4741 : : #endif
4742 : : double precision :: tsec(2)
4743 : :
4744 : 26664 : call timab(tim_colw_div,1,tsec)
4745 : :
4746 : 26664 : call xgBlock_check_gpu_option(xgBlockA,xgBlockB)
4747 : 26664 : call xgBlock_check_gpu_option(xgBlockA,divResult)
4748 : :
4749 : 26664 : rows = xgBlockA%rows; cols = xgBlockA%cols
4750 : :
4751 [ + - ]: 26664 : if (xgBlockA%gpu_option==ABI_GPU_KOKKOS) then
4752 : :
4753 : : #if defined(HAVE_GPU_CUDA) && defined(HAVE_KOKKOS) && defined(HAVE_YAKL)
4754 : :
4755 : : total_size = xgBlockA%rows * xgBlockA%cols
4756 : :
4757 : : select case(xgBlockA%space)
4758 : : case(SPACE_R)
4759 : : call computeColwiseDivision_scalar(c_loc(xgBlockA%vecR(1,1)), &
4760 : : & c_loc(xgBlockB%vecR(1,1)), &
4761 : : & total_size, &
4762 : : & c_loc(divResult%vecR(1,1)))
4763 : :
4764 : : ! do reductions
4765 : : if ( present(max_val) ) then
4766 : : call computeMax_scalar(c_loc(divResult%vecR(1,1)), total_size, max_val)
4767 : : end if
4768 : : if ( present(min_val) ) then
4769 : : call computeMin_scalar(c_loc(divResult%vecR(1,1)), total_size, min_val)
4770 : : end if
4771 : : if ( present(max_elt) ) then
4772 : : call computeMaxloc_scalar_2d(c_loc(divResult%vecR(1,1)), xgBlockA%rows, xgBlockA%cols, c_loc(max_elt))
4773 : : end if
4774 : : if ( present(min_elt) ) then
4775 : : call computeMinloc_scalar_2d(c_loc(divResult%vecR(1,1)), xgBlockA%rows, xgBlockA%cols, c_loc(min_elt))
4776 : : end if
4777 : :
4778 : : case(SPACE_C)
4779 : : call computeColwiseDivision_complex(c_loc(xgBlockA%vecC(1,1)), &
4780 : : & c_loc(xgBlockB%vecC(1,1)), &
4781 : : & total_size, &
4782 : : & c_loc(divResult%vecC(1,1)))
4783 : :
4784 : : if ( present(max_val) ) then
4785 : : call computeMax_complex(c_loc(divResult%vecC(1,1)), total_size, max_val)
4786 : : end if
4787 : : if ( present(min_val) ) then
4788 : : call computeMin_complex(c_loc(divResult%vecC(1,1)), total_size, min_val)
4789 : : end if
4790 : : if ( present(max_elt) ) then
4791 : : call computeMaxloc_complex_2d(c_loc(divResult%vecC(1,1)), xgBlockA%rows, xgBlockA%cols, c_loc(max_elt))
4792 : : end if
4793 : : if ( present(min_elt) ) then
4794 : : call computeMinloc_complex_2d(c_loc(divResult%vecC(1,1)), xgBlockA%rows, xgBlockA%cols, c_loc(min_elt))
4795 : : end if
4796 : : case(SPACE_CR)
4797 : : ABI_ERROR('Not implemented for SPACE_CR')
4798 : : end select
4799 : :
4800 : : #else
4801 : : ! we shouldn't be here, it means gpu_option was wrongly set to 1 in
4802 : : ! input parameter file
4803 : : #endif
4804 : :
4805 [ + - ]: 26664 : else if (xgBlockA%gpu_option==ABI_GPU_OPENMP) then
4806 : :
4807 : : #if defined HAVE_GPU && defined HAVE_OPENMP_OFFLOAD
4808 : :
4809 : : total_size = xgBlockA%rows * xgBlockA%cols
4810 : : select case(xgBlockA%space)
4811 : : case(SPACE_R)
4812 : : xgBlockA__vecR => xgBlockA%vecR
4813 : : xgBlockB__vecR => xgBlockB%vecR
4814 : : divResult__vecR => divResult%vecR
4815 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(2) MAP(to:xgBlockA__vecR,xgBlockB__vecR,divResult__vecR)
4816 : : do irow = 1, rows
4817 : : do icol = 1, cols
4818 : : divResult__vecR(irow,icol) = xgBlockA__vecR(irow,icol)/xgBlockB__vecR(irow,icol)
4819 : : end do
4820 : : end do
4821 : : !FIXME Port this on GPU to avoid copy below ?
4822 : : !$OMP TARGET UPDATE FROM(divResult__vecR)
4823 : : if ( present(max_val) ) then
4824 : : max_val = maxval(dble(divResult%vecR))
4825 : : end if
4826 : : if ( present(min_val) ) then
4827 : : min_val = minval(dble(divResult%vecR))
4828 : : end if
4829 : : if ( present(max_elt) ) then
4830 : : max_elt = maxloc(dble(divResult%vecR(1:xgBlockA%rows,1:xgBlockA%cols)))
4831 : : end if
4832 : : if ( present(min_elt) ) then
4833 : : min_elt = minloc(dble(divResult%vecR(1:xgBlockA%rows,1:xgBlockA%cols)))
4834 : : end if
4835 : :
4836 : : case(SPACE_C)
4837 : : xgBlockA__vecC => xgBlockA%vecC
4838 : : xgBlockB__vecC => xgBlockB%vecC
4839 : : divResult__vecC => divResult%vecC
4840 : : #if !defined FC_LLVM
4841 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(2) MAP(to:xgBlockA__vecC,xgBlockB__vecC,divResult__vecC)
4842 : : do irow = 1, rows
4843 : : do icol = 1, cols
4844 : : divResult__vecC(irow,icol) = xgBlockA__vecC(irow,icol)/xgBlockB__vecC(irow,icol)
4845 : : end do
4846 : : end do
4847 : : !FIXME Port this on GPU to avoid copy below ?
4848 : : !$OMP TARGET UPDATE FROM(divResult__vecC)
4849 : : #else
4850 : : !FIXME LLVM AOMP 16 doesn't support complex division inside OpenMP !?
4851 : : !$OMP TARGET UPDATE FROM(xgBlockA__vecC,xgBlockB__vecC)
4852 : : do irow = 1, rows
4853 : : do icol = 1, cols
4854 : : divResult__vecC(irow,icol) = xgBlockA__vecC(irow,icol)/xgBlockB__vecC(irow,icol)
4855 : : end do
4856 : : end do
4857 : : !$OMP TARGET UPDATE TO(divResult__vecC)
4858 : : #endif
4859 : : if ( present(max_val) ) then
4860 : : max_val = maxval(dble(divResult%vecC))
4861 : : end if
4862 : : if ( present(min_val) ) then
4863 : : min_val = minval(dble(divResult%vecC))
4864 : : end if
4865 : : if ( present(max_elt) ) then
4866 : : max_elt = maxloc(dble(divResult%vecC(1:xgBlockA%rows,1:xgBlockA%cols)))
4867 : : end if
4868 : : if ( present(min_elt) ) then
4869 : : min_elt = minloc(dble(divResult%vecC(1:xgBlockA%rows,1:xgBlockA%cols)))
4870 : : end if
4871 : : case(SPACE_CR)
4872 : : ABI_ERROR('Not implemented for SPACE_CR')
4873 : : end select
4874 : :
4875 : : #endif
4876 : :
4877 : : else
4878 : :
4879 : 26664 : select case(xgBlockA%space)
4880 : : case(SPACE_R)
4881 : : !$omp parallel do collapse(2) shared(divResult,xgBlockA,xgBlockB) private(icol,irow)
4882 [ + + ]: 19882 : do icol = 1, cols
4883 [ + + ]: 67778 : do irow = 1, rows
4884 : 57837 : divResult%vecR(irow,icol) = xgBlockA%vecR(irow,icol)/xgBlockB%vecR(irow,icol)
4885 : : end do
4886 : : end do
4887 : : !$omp end parallel do
4888 : :
4889 [ + + ]: 9941 : if ( present(max_val) ) then
4890 [ + + + + : 66590 : max_val = maxval(dble(divResult%vecR))
+ + + - -
+ - - ]
4891 : : end if
4892 [ + + ]: 9941 : if ( present(min_val) ) then
4893 [ + + + + : 66590 : min_val = minval(dble(divResult%vecR))
+ + + - -
+ - - ]
4894 : : end if
4895 [ + + ]: 9941 : if ( present(max_elt) ) then
4896 [ + - + + : 66590 : max_elt = maxloc(dble(divResult%vecR(1:xgBlockA%rows,1:xgBlockA%cols)))
+ + ]
4897 : : end if
4898 [ + + ]: 9941 : if ( present(min_elt) ) then
4899 [ + - + + : 66590 : min_elt = minloc(dble(divResult%vecR(1:xgBlockA%rows,1:xgBlockA%cols)))
+ + ]
4900 : : end if
4901 : :
4902 : : case(SPACE_C)
4903 : :
4904 : : !$omp parallel do collapse(2) shared(divResult,xgBlockA,xgBlockB) private(icol,irow)
4905 [ + + ]: 41442 : do icol = 1, cols
4906 [ + + ]: 32140634 : do irow = 1, rows
4907 : 32123911 : divResult%vecC(irow,icol) = xgBlockA%vecC(irow,icol)/xgBlockB%vecC(irow,icol)
4908 : : end do
4909 : : end do
4910 : : !$omp end parallel do
4911 : :
4912 [ + + ]: 16723 : if ( present(max_val) ) then
4913 [ + + + + : 131442 : max_val = maxval(dble(divResult%vecC))
+ + + - -
+ - - ]
4914 : : end if
4915 [ + + ]: 16723 : if ( present(min_val) ) then
4916 [ + + + + : 131442 : min_val = minval(dble(divResult%vecC))
+ + + - -
+ - - ]
4917 : : end if
4918 [ + + ]: 16723 : if ( present(max_elt) ) then
4919 [ + - + + : 131442 : max_elt = maxloc(dble(divResult%vecC(1:xgBlockA%rows,1:xgBlockA%cols)))
+ + ]
4920 : : end if
4921 [ + + ]: 16723 : if ( present(min_elt) ) then
4922 [ + - + + : 131442 : min_elt = minloc(dble(divResult%vecC(1:xgBlockA%rows,1:xgBlockA%cols)))
+ + ]
4923 : : end if
4924 : : case(SPACE_CR)
4925 [ + + - - ]: 26664 : ABI_ERROR('Not implemented for SPACE_CR')
4926 : : end select
4927 : :
4928 : : end if ! gpu_option
4929 : :
4930 : 26664 : call timab(tim_colw_div,2,tsec)
4931 : :
4932 : 26664 : end subroutine xgBlock_colwiseDivision
4933 : : !!***
4934 : :
4935 : : !!****f* m_xg/xgBlock_scaleR
4936 : : !!
4937 : : !! NAME
4938 : : !! xgBlock_scaleR
4939 : :
4940 : 1648961 : subroutine xgBlock_scaleR(xgBlock, val, inc)
4941 : :
4942 : : type(xgBlock_t) , intent(inout) :: xgBlock
4943 : : double precision, intent(in ) :: val
4944 : : integer , intent(in ) :: inc
4945 : :
4946 : : integer :: i,fact
4947 : : complex(dp) :: valc
4948 : :
4949 : : double precision :: tsec(2)
4950 : :
4951 : 1648961 : call timab(tim_scale,1,tsec)
4952 : :
4953 : 1648961 : valc = dcmplx(val,0.0_dp)
4954 : :
4955 [ + + ]: 1648961 : fact = 1 ; if (xgBlock%space==SPACE_CR) fact = 2
4956 : :
4957 [ + - ]: 1648961 : if ( xgBlock%ldim .eq. xgBlock%rows ) then
4958 : 590740 : select case(xgBlock%space)
4959 : : case (SPACE_R,SPACE_CR)
4960 : : call abi_xscal(fact*xgBlock%ldim*xgBlock%cols/inc, val, xgBlock%vecR, inc, &
4961 : 590740 : gpu_option=xgBlock%gpu_option)
4962 : : case (SPACE_C)
4963 : : call abi_xscal(xgBlock%ldim*xgBlock%cols/inc, valc, xgBlock%vecC, inc, &
4964 [ + + - ]: 1648961 : gpu_option=xgBlock%gpu_option)
4965 : : end select
4966 : : else
4967 : : !FIXME Do loop that calls scal on each column sequentially, might be improved
4968 : 0 : select case(xgBlock%space)
4969 : : case (SPACE_R,SPACE_CR)
4970 [ # # ]: 0 : do i=1,xgBlock%cols
4971 : : call abi_xscal(fact*xgBlock%rows/inc, val, xgBlock%vecR(:,i), inc, &
4972 : 0 : gpu_option=xgBlock%gpu_option)
4973 : : end do
4974 : : case (SPACE_C)
4975 [ # # # # : 0 : do i=1,xgBlock%cols
# ]
4976 : : call abi_xscal(xgBlock%rows/inc, valc, xgBlock%vecC(:,i), inc, &
4977 : 0 : gpu_option=xgBlock%gpu_option)
4978 : : end do
4979 : : end select
4980 : : end if
4981 : :
4982 : 1648961 : call timab(tim_scale,2,tsec)
4983 : :
4984 : 1648961 : end subroutine xgBlock_scaleR
4985 : : !!***
4986 : :
4987 : : !!****f* m_xg/xgBlock_scaleC
4988 : : !!
4989 : : !! NAME
4990 : : !! xgBlock_scaleC
4991 : :
4992 : 0 : subroutine xgBlock_scaleC(xgBlock, val, inc)
4993 : :
4994 : : type(xgBlock_t), intent(inout) :: xgBlock
4995 : : complex(kind=8), intent(in ) :: val
4996 : : integer , intent(in ) :: inc
4997 : :
4998 : : integer :: i
4999 : : double precision :: tsec(2)
5000 : :
5001 : 0 : call timab(tim_scale,1,tsec)
5002 : :
5003 [ # # ]: 0 : if ( xgBlock%ldim .eq. xgBlock%rows ) then
5004 : 0 : select case(xgBlock%space)
5005 : : case (SPACE_R,SPACE_CR)
5006 : 0 : ABI_ERROR("Scaling real vector with a complex not possible")
5007 : : case (SPACE_C)
5008 : : call abi_xscal(xgBlock%ldim*xgBlock%cols/inc, val, xgBlock%vecC, inc, &
5009 [ # # # ]: 0 : gpu_option=xgBlock%gpu_option)
5010 : : end select
5011 : : else
5012 : : ! TODO: evaluate if it is really necessary to deal with this case on GPU
5013 [ # # ]: 0 : if (xgBlock%gpu_option/=ABI_GPU_DISABLED) then
5014 : 0 : ABI_BUG("Scaling a xgBlock when xgBlock%ldim != xgBlock%rows is not implemented for GPU. FIX ME if needed.")
5015 : : end if
5016 : 0 : select case(xgBlock%space)
5017 : : case (SPACE_R,SPACE_CR)
5018 : 0 : ABI_ERROR("Scaling real vector with a complex not possible")
5019 : : case (SPACE_C)
5020 [ # # # # : 0 : do i=1,xgBlock%cols
# ]
5021 : 0 : call abi_xscal(xgBlock%rows/inc, val, xgBlock%vecC(:,i), inc)
5022 : : end do
5023 : : end select
5024 : : end if
5025 : :
5026 : 0 : call timab(tim_scale,2,tsec)
5027 : :
5028 : 0 : end subroutine xgBlock_scaleC
5029 : : !!***
5030 : :
5031 : : !!****f* m_xg/xgBlock_transpose
5032 : : !!
5033 : : !! NAME
5034 : : !! xgBlock_transpose
5035 : :
5036 : 0 : subroutine xgBlock_transpose(xgBlockI,xgBlockO)
5037 : :
5038 : : type(xgBlock_t) , intent(inout) :: xgBlockI,xgBlockO
5039 : : integer :: nrows,ncols
5040 : :
5041 [ # # ]: 0 : if (xgBlockI%gpu_option/=ABI_GPU_DISABLED) then
5042 : 0 : ABI_ERROR('Not implemented for GPU')
5043 : : end if
5044 : 0 : call xgBlock_check_gpu_option(xgBlockI,xgBlockO)
5045 : :
5046 : 0 : nrows = xgBlockI%rows
5047 : 0 : ncols = xgBlockI%cols
5048 [ # # ]: 0 : if (nrows/=xgBlockO%cols) then
5049 : 0 : ABI_ERROR('nrowsI/=ncolsO')
5050 : : end if
5051 [ # # ]: 0 : if (ncols/=xgBlockO%rows) then
5052 : 0 : ABI_ERROR('ncolsI/=nrowsO')
5053 : : end if
5054 : :
5055 : 0 : select case(xgBlockI%space)
5056 : : case (SPACE_R)
5057 [ # # # # ]: 0 : xgBlockO%vecR = TRANSPOSE(xgBlockI%vecR)
5058 : : case (SPACE_CR)
5059 : 0 : ABI_ERROR("Not implemented")
5060 : : case (SPACE_C)
5061 [ # # # # : 0 : xgBlockO%vecC = TRANSPOSE(CONJG(xgBlockI%vecC))
# # # # ]
5062 : : end select
5063 : :
5064 : 0 : end subroutine xgBlock_transpose
5065 : : !!***
5066 : :
5067 : : !!****f* m_xg/xgBlock_r2c
5068 : : !!
5069 : : !! NAME
5070 : : !! xgBlock_r2c
5071 : :
5072 : 693206 : subroutine xgBlock_r2c(xgBlockR,xgBlockC,nspinor)
5073 : :
5074 : : integer , intent(in) :: nspinor
5075 : : type(xgBlock_t) , intent(in) :: xgBlockR
5076 : : type(xgBlock_t) , intent(inout) :: xgBlockC
5077 : : integer :: nrows,ncols,col
5078 : 693206 : double precision,allocatable :: zeros(:)
5079 : :
5080 [ - + ]: 693206 : if (xgBlockR%gpu_option/=ABI_GPU_DISABLED) then
5081 : 0 : ABI_ERROR('Not implemented for GPU')
5082 : : end if
5083 : 693206 : call xgBlock_check_gpu_option(xgBlockR,xgBlockC)
5084 : :
5085 [ - + ]: 693206 : if (space(xgBlockR)/=SPACE_R) then
5086 : 0 : ABI_ERROR('space(xgBlockR)/=SPACE_R')
5087 : : end if
5088 [ - + ]: 693206 : if (space(xgBlockC)/=SPACE_C .and. space(xgBLockC)/=SPACE_CR) then
5089 : 0 : ABI_ERROR('space(xgBlockC)/=SPACE_C')
5090 : : end if
5091 [ - + - - ]: 693206 : if (space(xgBlockC)==SPACE_CR .and. nspinor/=1) then
5092 : 0 : ABI_ERROR('This should not happen')
5093 : : end if
5094 : :
5095 : 693206 : nrows = xgBlockR%rows
5096 : 693206 : ncols = xgBlockR%cols
5097 [ - + ]: 693206 : if (nspinor*nrows/=xgBlockC%rows) then
5098 : 0 : ABI_ERROR('nspinor*nrowsR/=nrowsC')
5099 : : end if
5100 [ - + ]: 693206 : if (nspinor*ncols/=xgBlockC%cols) then
5101 : 0 : ABI_ERROR('nspinor*ncolsR/=ncolsC')
5102 : : end if
5103 : :
5104 [ - + ]: 693206 : if (space(xgBlockC)==SPACE_C) then
5105 [ - + + - : 2079618 : ABI_MALLOC(zeros,(nrows))
+ - + - -
+ - + ]
5106 [ + + ]: 6889934 : zeros=zero
5107 [ + + ]: 6889934 : do col = 1,ncols
5108 [ + + ]: 67489992 : xgBlockC%vecC(1:nrows,col) = dcmplx(xgBlockR%vecR(1:nrows,col),zeros)
5109 [ + + ]: 6889934 : if (nspinor==2) then
5110 [ + + ]: 22317948 : xgBlockC%vecC(1+nrows:2*nrows,col ) = dcmplx(zeros,zeros)
5111 [ + + ]: 22317948 : xgBlockC%vecC(1 : nrows,col+ncols) = dcmplx(zeros,zeros)
5112 [ + + ]: 22317948 : xgBlockC%vecC(1+nrows:2*nrows,col+ncols) = dcmplx(xgBlockR%vecR(1:nrows,col),zeros)
5113 : : end if
5114 : : end do
5115 [ - + ]: 693206 : ABI_FREE(zeros)
5116 : : else ! space(C)==SPACE_CR
5117 [ # # ]: 0 : do col = 1,ncols
5118 [ # # ]: 0 : xgBlockC%vecR(1:2*nrows-1:2,col) = xgBlockR%vecR(1:nrows,col)
5119 [ # # ]: 0 : xgBlockC%vecR(2:2*nrows :2,col) = zero
5120 : : end do
5121 : : end if
5122 : :
5123 : 693206 : end subroutine xgBlock_r2c
5124 : : !!***
5125 : :
5126 : : !!****f* m_xg/xgBlock_c2r
5127 : : !!
5128 : : !! NAME
5129 : : !! xgBlock_c2r
5130 : :
5131 : 544 : subroutine xgBlock_c2r(xgBlockC,xgBlockR)
5132 : :
5133 : : type(xgBlock_t) , intent(in) :: xgBlockC
5134 : : type(xgBlock_t) , intent(inout) :: xgBlockR
5135 : : integer :: nrows,ncols,col
5136 : :
5137 [ - + ]: 544 : if (xgBlockR%gpu_option/=ABI_GPU_DISABLED) then
5138 : 0 : ABI_ERROR('Not implemented for GPU')
5139 : : end if
5140 : 544 : call xgBlock_check_gpu_option(xgBlockR,xgBlockC)
5141 : :
5142 [ - + ]: 544 : if (space(xgBlockR)/=SPACE_R) then
5143 : 0 : ABI_ERROR('space(xgBlockR)/=SPACE_R')
5144 : : end if
5145 [ - + ]: 544 : if (space(xgBlockC)/=SPACE_C .and. space(xgBLockC)/=SPACE_CR) then
5146 : 0 : ABI_ERROR('space(xgBlockC)/=SPACE_C')
5147 : : end if
5148 : :
5149 : 544 : nrows = xgBlockR%rows
5150 : 544 : ncols = xgBlockR%cols
5151 [ - + ]: 544 : if (nrows/=xgBlockC%rows) then
5152 : 0 : ABI_ERROR('nrowsR/=nrowsC')
5153 : : end if
5154 [ - + ]: 544 : if (ncols/=xgBlockC%cols) then
5155 : 0 : ABI_ERROR('ncolsR/=ncolsC')
5156 : : end if
5157 : :
5158 [ - + ]: 544 : if (space(xgBlockC)==SPACE_C) then
5159 [ + + ]: 1088 : do col = 1,ncols
5160 [ + + ]: 5440 : xgBlockR%vecR(1:nrows,col) = dble(xgBlockC%vecC(1:nrows,col))
5161 : : end do
5162 : : else ! space(C)==SPACE_CR
5163 [ # # ]: 0 : do col = 1,ncols
5164 [ # # ]: 0 : xgBlockR%vecR(1:nrows,col) = xgBlockC%vecR(1:2*nrows-1:2,col)
5165 : : end do
5166 : : end if
5167 : :
5168 : 544 : end subroutine xgBlock_c2r
5169 : : !!***
5170 : :
5171 : : !!****f* m_xg/xgBlock_getSize
5172 : : !!
5173 : : !! NAME
5174 : : !! xgBlock_getSize
5175 : :
5176 : 6534784 : subroutine xgBlock_getSize(xgBlock, rows, cols, ldim)
5177 : :
5178 : : type(xgBlock_t) , intent(in ) :: xgBlock
5179 : : integer , intent( out) :: rows
5180 : : integer , intent( out) :: cols
5181 : : integer, optional, intent( out) :: ldim
5182 : :
5183 : 6534784 : rows = xgBlock%rows
5184 : 6534784 : cols = xgBlock%cols
5185 : :
5186 [ - + ]: 6533037 : if (present(ldim)) then
5187 : 0 : ldim = xgBlock%ldim
5188 : : end if
5189 : :
5190 : 6533037 : end subroutine xgBlock_getSize
5191 : : !!***
5192 : :
5193 : : !!****f* m_xg/xgBlock_get_gpu_option
5194 : : !!
5195 : : !! NAME
5196 : : !! xgBlock_get_gpu_option
5197 : : !!
5198 : : !! FUNCTION
5199 : : !! Getter routine for private variable of xgBlock type
5200 : :
5201 : 0 : subroutine xgBlock_get_gpu_option(xgBlock, gpu_option)
5202 : :
5203 : : type(xgBlock_t) , intent(in ) :: xgBlock
5204 : : integer , intent( out) :: gpu_option
5205 : :
5206 : 0 : gpu_option = xgBlock%gpu_option
5207 : :
5208 : 0 : end subroutine xgBlock_get_gpu_option
5209 : : !!***
5210 : :
5211 : : !!****f* m_xg/xgBlock_get_communicator
5212 : : !!
5213 : : !! NAME
5214 : : !! xgBlock_get_communicator
5215 : : !!
5216 : : !! FUNCTION
5217 : : !! Getter routine for private variable of xgBlock type
5218 : :
5219 : 0 : subroutine xgBlock_get_communicator(xgBlock, comm)
5220 : :
5221 : : type(xgBlock_t) , intent(in ) :: xgBlock
5222 : : integer , intent( out) :: comm
5223 : :
5224 : 0 : comm = xgBlock%spacedim_comm
5225 : :
5226 : 0 : end subroutine xgBlock_get_communicator
5227 : : !!***
5228 : :
5229 : : !!****f* m_xg/xgBlock_check
5230 : : !!
5231 : : !! NAME
5232 : : !! xgBlock_check
5233 : :
5234 : 13202334 : subroutine xgBlock_check(X, Y, fact_col)
5235 : :
5236 : : type(xgBlock_t) , intent(in) :: X
5237 : : type(xgBlock_t) , intent(in) :: Y
5238 : : integer,optional, intent(in) :: fact_col
5239 : :
5240 : : integer :: fact_col_
5241 : :
5242 : 13202334 : fact_col_ = 1
5243 [ + + ]: 13202334 : if (present(fact_col)) then
5244 : 2878138 : fact_col_ = fact_col
5245 : : end if
5246 [ - + ]: 13202334 : if (X%space/=Y%space) then
5247 : 0 : ABI_ERROR('X%space/=Y%space')
5248 : : end if
5249 [ - + ]: 13202334 : if (X%rows/=Y%rows) then
5250 : 0 : ABI_ERROR('X%rows/=Y%rows')
5251 : : end if
5252 [ - + ]: 13202334 : if (fact_col_*X%cols/=Y%cols) then
5253 : 0 : ABI_ERROR('X%cols/=Y%cols')
5254 : : end if
5255 : :
5256 : 13202334 : end subroutine xgBlock_check
5257 : : !!***
5258 : :
5259 : : !!****f* m_xg/xgBlock_check_gpu_option
5260 : : !!
5261 : : !! NAME
5262 : : !! xgBlock_check_gpu_option
5263 : :
5264 : 57094826 : subroutine xgBlock_check_gpu_option(X, Y)
5265 : :
5266 : : type(xgBlock_t) , intent(in) :: X
5267 : : type(xgBlock_t) , intent(in) :: Y
5268 : :
5269 [ - + ]: 57094826 : if (X%gpu_option/=Y%gpu_option) then
5270 : 0 : ABI_ERROR('X%gpu_option /= Y%gpu_option')
5271 : : end if
5272 : :
5273 : 57094826 : end subroutine xgBlock_check_gpu_option
5274 : : !!***
5275 : :
5276 : : !!****f* m_xg/xgBlock_copy_to_gpu
5277 : : !!
5278 : : !! NAME
5279 : : !! xgBlock_copy_to_gpu
5280 : :
5281 : 0 : subroutine xgBlock_copy_to_gpu(xgBlock)
5282 : : type(xgBlock_t), target, intent(in ) :: xgBlock
5283 : : #if defined(HAVE_GPU) && defined(HAVE_OPENMP_OFFLOAD)
5284 : : integer(c_size_t) :: size
5285 : : complex(dp), contiguous, pointer :: xgBlock__vecC(:,:)
5286 : : real(dp), contiguous, pointer :: xgBlock__vecR(:,:)
5287 : :
5288 : : select case(xgBlock%space)
5289 : : case (SPACE_R,SPACE_CR)
5290 : : xgBlock__vecR => xgBlock%vecR
5291 : : !$OMP TARGET UPDATE TO(xgBlock__vecR)
5292 : : case (SPACE_C)
5293 : : xgBlock__vecC => xgBlock%vecC
5294 : : !$OMP TARGET UPDATE TO(xgBlock__vecC)
5295 : : end select
5296 : : #else
5297 : 105746 : ABI_UNUSED_A(xgBlock)
5298 : : #endif
5299 : :
5300 : 0 : end subroutine xgBlock_copy_to_gpu
5301 : : !!***
5302 : :
5303 : : !!****f* m_xg/xgBlock_copy_from_gpu
5304 : : !!
5305 : : !! NAME
5306 : : !! xgBlock_copy_from_gpu
5307 : :
5308 : 0 : subroutine xgBlock_copy_from_gpu(xgBlock)
5309 : : type(xgBlock_t), target, intent(in ) :: xgBlock
5310 : : #if defined(HAVE_GPU) && defined(HAVE_OPENMP_OFFLOAD)
5311 : : complex(dp), contiguous, pointer :: xgBlock__vecC(:,:)
5312 : : real(dp), contiguous, pointer :: xgBlock__vecR(:,:)
5313 : :
5314 : : select case(xgBlock%space)
5315 : : case (SPACE_R,SPACE_CR)
5316 : : xgBlock__vecR => xgBlock%vecR
5317 : : !$OMP TARGET UPDATE FROM(xgBlock__vecR)
5318 : : case (SPACE_C)
5319 : : xgBlock__vecC => xgBlock%vecC
5320 : : !$OMP TARGET UPDATE FROM(xgBlock__vecC)
5321 : : end select
5322 : : #else
5323 [ # # # # ]: 0 : ABI_UNUSED_A(xgBlock)
5324 : : #endif
5325 : :
5326 : 0 : end subroutine xgBlock_copy_from_gpu
5327 : : !!***
5328 : :
5329 : : !!****f* m_xg/xgBlock_reshape
5330 : : !!
5331 : : !! NAME
5332 : : !! xgBlock_reshape
5333 : :
5334 : 819896 : subroutine xgBlock_reshape(xgBlock,newrows,newcols)
5335 : : use, intrinsic :: iso_c_binding
5336 : : type(xgBlock_t), intent(inout) :: xgBlock
5337 : : integer , intent(in ) :: newrows
5338 : : integer , intent(in ) :: newcols
5339 : : integer :: fact,newshape(2)
5340 : : type(c_ptr) :: cptr
5341 : :
5342 [ - + ]: 819896 : if ( xgBlock%rows*xgBlock%cols /= newrows*newcols ) then
5343 : 0 : write(std_out,*) "xgBlock%rows", xgBlock%rows
5344 : 0 : write(std_out,*) "xgBlock%cols", xgBlock%cols
5345 : 0 : write(std_out,*) "newrows", newrows
5346 : 0 : write(std_out,*) "newcols", newcols
5347 : 0 : write(std_out,*) "xgBlock%rows*xgBlock%cols", xgBlock%rows*xgBlock%cols
5348 : 0 : write(std_out,*) "newrows*newcols", newrows*newcols
5349 : 0 : ABI_ERROR("Bad shape")
5350 : : end if
5351 : :
5352 : : fact = 1 ; if (xgBlock%space==SPACE_CR) fact = 2
5353 : :
5354 : 819896 : xgBlock%LDim = newrows+( (xgBlock%LDim-xgBlock%rows)* xgBlock%cols)/newcols
5355 : 819896 : xgBlock%rows = newrows
5356 : 819896 : xgBlock%cols = newcols
5357 : 819896 : newshape(1) = newrows
5358 : 819896 : newshape(2) = newcols
5359 : 1002824 : select case(xgBlock%space)
5360 : : case (SPACE_R,SPACE_CR)
5361 [ + - - - : 182928 : cptr = getClocR(fact*xgBlock%LDim,xgBlock%cols,xgBlock%vecR)
- - - - -
+ ]
5362 [ + + ]: 548784 : call c_f_pointer(cptr,xgBlock%vecR,newshape)
5363 : : case (SPACE_C)
5364 [ + - - - : 636968 : cptr = getClocC(xgBlock%LDim,xgBlock%cols,xgBlock%vecC)
- - - - -
+ ]
5365 [ + + - + : 2730800 : call c_f_pointer(cptr,xgBlock%vecC,newshape)
+ ]
5366 : : end select
5367 : :
5368 : 819896 : end subroutine xgBlock_reshape
5369 : : !!***
5370 : :
5371 : : !!****f* m_xg/xgBlock_reshape_spinor
5372 : : !!
5373 : : !! NAME
5374 : : !! xgBlock_reshape_spinor
5375 : :
5376 : 3513881 : subroutine xgBlock_reshape_spinor(xgBlock,xgBlock_spinor,nspinor,option)
5377 : : use iso_c_binding
5378 : : integer, intent(in ) :: nspinor,option
5379 : : type(xgBlock_t), intent(in ) :: xgBlock
5380 : : type(xgBlock_t), intent(inout) :: xgBlock_spinor
5381 : :
5382 : : integer :: nrows,ncols
5383 : :
5384 [ - + ]: 3513881 : if (nspinor/=1.and.nspinor/=2) then
5385 : 0 : ABI_ERROR('It should not happen : nspinor must be 1 or 2')
5386 : : end if
5387 [ + + - + ]: 3513881 : if (xgBlock%space==SPACE_CR.and.nspinor==2) then
5388 : 0 : ABI_ERROR('It should not happen : space_CR cannot be used with nspinor=2')
5389 : : end if
5390 : :
5391 : 3513881 : nrows = rows(xgBlock)
5392 : 3513881 : ncols = cols(xgBlock)
5393 : :
5394 [ + + ]: 3513881 : if (option==COLS2ROWS) then
5395 [ - + ]: 1487706 : if (modulo(ncols,nspinor)/=0) then
5396 : 0 : ABI_ERROR('nspinor should divide the number of cols')
5397 : : end if
5398 : 1487706 : call xgBlock_setBlock(xgBlock,xgBlock_spinor,nrows,ncols)
5399 [ + + ]: 1487706 : if (nspinor>1) call xgBlock_reshape(xgBlock_spinor,nrows*nspinor,ncols/nspinor)
5400 [ + - ]: 2026175 : else if (option==ROWS2COLS) then
5401 [ - + ]: 2026175 : if (modulo(nrows,nspinor)/=0) then
5402 : 0 : ABI_ERROR('nspinor should divide the number of rows')
5403 : : end if
5404 : 2026175 : call xgBlock_setBlock(xgBlock,xgBlock_spinor,nrows,ncols)
5405 [ + + ]: 2026175 : if (nspinor>1) call xgBlock_reshape(xgBlock_spinor,nrows/nspinor,ncols*nspinor)
5406 : : else
5407 : 0 : ABI_ERROR('bad option value')
5408 : : end if
5409 : :
5410 : 3513881 : end subroutine xgBlock_reshape_spinor
5411 : : !!***
5412 : :
5413 : : !!****f* m_xg/xgBlock_free_reshape
5414 : : !!
5415 : : !! NAME
5416 : : !! xgBlock_free_reshape
5417 : 976212 : subroutine xgBlock_free_reshape(xgBlock,newrows,newcols,newldim,new_me_g0)
5418 : : use iso_c_binding
5419 : : type(xgBlock_t) , intent(inout) :: xgBlock
5420 : : integer , intent(in ) :: newrows,newcols
5421 : : integer,optional, intent(in ) :: newldim
5422 : : integer,optional, intent(in ) :: new_me_g0
5423 : :
5424 : : integer :: newshape(2)
5425 : : type(c_ptr) :: cptr
5426 : :
5427 [ + - - + ]: 976212 : if (newrows<1.or.newcols<1) then
5428 : 0 : ABI_ERROR("Bad new shape")
5429 : : end if
5430 : :
5431 [ - + ]: 976212 : if ( xgBLock%Ldim*xgBlock%cols < newrows*newcols ) then
5432 : 0 : write(std_out,*) "xgBLock%rows", xgBLock%rows
5433 : 0 : write(std_out,*) "xgBlock%cols", xgBlock%cols
5434 : 0 : write(std_out,*) "newrows", newrows
5435 : 0 : write(std_out,*) "newcols", newcols
5436 : 0 : write(std_out,*) "xgBLock%rows*xgBlock%cols", xgBLock%rows*xgBlock%cols
5437 : 0 : write(std_out,*) "newrows*newcols", newrows*newcols
5438 : 0 : ABI_ERROR("Bad shape (ldim*cols<newrows*newcols")
5439 : : end if
5440 : :
5441 : 976212 : xgBlock%LDim = newrows
5442 [ - + ]: 976212 : if (present(newldim)) then
5443 [ # # ]: 0 : if (newldim<newrows) then
5444 : 0 : ABI_ERROR("newldim<newrows")
5445 : : end if
5446 [ # # ]: 0 : if ( xgBLock%Ldim*xgBlock%cols < newldim*newcols ) then
5447 : 0 : ABI_ERROR("Bad shape (ldim*cols<newldim*newcols")
5448 : : end if
5449 : 0 : xgBlock%LDim = newldim
5450 : : end if
5451 : 976212 : xgBlock%rows = newrows
5452 : 976212 : xgBlock%cols = newcols
5453 : 976212 : newshape(1) = newrows
5454 : 976212 : newshape(2) = newcols
5455 : 976212 : select case(xgBLock%space)
5456 : : case (SPACE_R)
5457 [ # # # # : 0 : cptr = getClocR(xgBlock%LDim,xgBlock%cols,xgBlock%vecR)
# # # # #
# ]
5458 [ # # ]: 0 : call c_f_pointer(cptr,xgBlock%vecR,newshape)
5459 : : case (SPACE_CR)
5460 [ + - - - : 457092 : cptr = getClocR(2*xgBlock%LDim,xgBlock%cols,xgBlock%vecR)
- - - - -
+ ]
5461 : 457092 : newshape(1) = 2*newshape(1)
5462 [ + + ]: 1371276 : call c_f_pointer(cptr,xgBlock%vecR,newshape)
5463 [ + + ]: 457092 : if (present(new_me_g0)) then
5464 : 247608 : xgBlock%me_g0=new_me_g0
5465 : : end if
5466 : : case (SPACE_C)
5467 [ + - - - : 519120 : cptr = getClocC(xgBlock%LDim,xgBlock%cols,xgBlock%vecC)
- - - - -
+ ]
5468 [ - + + - : 2533572 : call c_f_pointer(cptr,xgBlock%vecC,newshape)
+ + ]
5469 : : end select
5470 : 976212 : end subroutine xgBlock_free_reshape
5471 : : !!***
5472 : :
5473 : : !!****f* m_xg/xgBlock_zero
5474 : : !!
5475 : : !! NAME
5476 : : !! xgBlock_zero
5477 : :
5478 : 11748319 : subroutine xgBlock_zero(xgBlock)
5479 : :
5480 : : type(xgBlock_t), intent(inout) :: xgBlock
5481 : :
5482 : : integer :: i,fact
5483 : : #if defined HAVE_GPU
5484 : : integer(C_SIZE_T) :: byte_count
5485 : : #endif
5486 : :
5487 : : #if defined HAVE_OPENMP_OFFLOAD && !defined HAVE_OPENMP_OFFLOAD_DATASTRUCTURE
5488 : : complex(dp), contiguous, pointer :: xgBlock__vecC(:,:)
5489 : : real(dp), contiguous, pointer :: xgBlock__vecR(:,:)
5490 : : integer :: rows,cols,iblock,jblock
5491 : : #endif
5492 : : double precision :: tsec(2)
5493 : :
5494 : 11748319 : call timab(tim_zero,1,tsec)
5495 : :
5496 : 11748319 : fact = 1 ; if (xgBlock%space==SPACE_CR) fact = 2
5497 : :
5498 [ + - ]: 11748319 : if (xgBlock%gpu_option==ABI_GPU_KOKKOS) then
5499 : :
5500 : : #if defined HAVE_GPU && defined HAVE_KOKKOS
5501 : : select case(xgBlock%space)
5502 : : case (SPACE_R,SPACE_CR)
5503 : : byte_count = fact * xgBlock%ldim * xgBlock%cols * dp
5504 : : call gpu_memset(c_loc(xgBlock%vecR), 0, byte_count)
5505 : : case (SPACE_C)
5506 : : byte_count = xgBlock%ldim * xgBlock%cols * 2 * dp ! Note the factor 2, needed here!
5507 : : call gpu_memset(c_loc(xgBlock%vecC), 0, byte_count)
5508 : : end select
5509 : : #endif
5510 : :
5511 [ + - ]: 11748319 : else if (xgBlock%gpu_option==ABI_GPU_OPENMP) then
5512 : :
5513 : : #if defined HAVE_OPENMP_OFFLOAD
5514 : : select case(xgBlock%space)
5515 : : case (SPACE_R,SPACE_CR)
5516 : : call gpu_set_to_zero(xgBlock%vecR, int(fact, c_size_t) * xgBlock%ldim * xgBlock%cols)
5517 : : case (SPACE_C)
5518 : : call gpu_set_to_zero_complex(xgBlock%vecC, int(xgBlock%ldim, c_size_t) * xgBlock%cols)
5519 : : end select
5520 : : #endif
5521 : :
5522 : : else
5523 : :
5524 : 15423167 : select case(xgBlock%space)
5525 : : case (SPACE_R,SPACE_CR)
5526 : : !$omp parallel do
5527 [ + + ]: 20597347 : do i = 1, xgBlock%cols
5528 [ + + ]: 1593271843 : xgBlock%vecR(:,i) = 0.d0
5529 : : end do
5530 : : case (SPACE_C)
5531 : : !$omp parallel do
5532 [ + + - + : 53019254 : do i = 1, xgBlock%cols
+ ]
5533 [ + + ]: 1369506987 : xgBlock%vecC(:,i) = dcmplx(0.d0)
5534 : : end do
5535 : : end select
5536 : : end if
5537 : :
5538 : 11748319 : call timab(tim_zero,2,tsec)
5539 : :
5540 : 11748319 : end subroutine xgBlock_zero
5541 : : !!***
5542 : :
5543 : : !!****f* m_xg/xgBlock_ones
5544 : : !!
5545 : : !! NAME
5546 : : !! xgBlock_ones
5547 : :
5548 : 0 : subroutine xgBlock_ones(xgBlock)
5549 : :
5550 : : type(xgBlock_t), intent(inout) :: xgBlock
5551 : :
5552 : : integer :: i,fact
5553 : : #if defined HAVE_GPU
5554 : : integer(C_SIZE_T) :: byte_count
5555 : : #endif
5556 : :
5557 : : #if defined HAVE_OPENMP_OFFLOAD
5558 : : complex(dp), contiguous, pointer :: xgBlock__vecC(:,:)
5559 : : real(dp), contiguous, pointer :: xgBlock__vecR(:,:)
5560 : : integer :: rows,cols,iblock,jblock
5561 : : #endif
5562 : :
5563 : 0 : fact = 1 ; if (xgBlock%space==SPACE_CR) fact = 2
5564 : :
5565 [ # # ]: 0 : if (xgBlock%gpu_option==ABI_GPU_OPENMP) then
5566 : :
5567 : : #if defined HAVE_OPENMP_OFFLOAD
5568 : : rows = xgBlock%rows; cols = xgBlock%cols
5569 : : select case(xgBlock%space)
5570 : : case (SPACE_R,SPACE_CR)
5571 : : xgBlock__vecR => xgBlock%vecR
5572 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(2) MAP(to:xgBlock__vecR)
5573 : : do iblock = 1, cols
5574 : : do jblock = 1, fact * rows
5575 : : xgBlock__vecR(jblock,iblock) = 1.d0
5576 : : end do
5577 : : end do
5578 : : case (SPACE_C)
5579 : : xgBlock__vecC => xgBlock%vecC
5580 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(2) MAP(to:xgBlock__vecC)
5581 : : do iblock = 1, cols
5582 : : do jblock = 1, fact * rows
5583 : : xgBlock__vecC(jblock,iblock) = dcmplx(1.d0,0)
5584 : : end do
5585 : : end do
5586 : : end select
5587 : : #endif
5588 : :
5589 : : else
5590 : :
5591 : 0 : select case(xgBlock%space)
5592 : : case (SPACE_R,SPACE_CR)
5593 : : !$omp parallel do
5594 [ # # ]: 0 : do i = 1, xgBlock%cols
5595 [ # # ]: 0 : xgBlock%vecR(:,i) = 1.d0
5596 : : end do
5597 : : case (SPACE_C)
5598 : : !$omp parallel do
5599 [ # # # # : 0 : do i = 1, xgBlock%cols
# ]
5600 [ # # ]: 0 : xgBlock%vecC(:,i) = dcmplx(1.d0)
5601 : : end do
5602 : : end select
5603 : : end if
5604 : :
5605 : 0 : end subroutine xgBlock_ones
5606 : : !!***
5607 : :
5608 : : !!****f* m_xg/xgBlock_zerotri
5609 : : !!
5610 : : !! NAME
5611 : : !! xgBlock_zerotri
5612 : :
5613 : 51082 : subroutine xgBlock_zerotri(xgBlockA,uplo)
5614 : : use iso_c_binding
5615 : : type(xgBlock_t), intent(inout) :: xgBlockA
5616 : : character, intent(in) :: uplo
5617 : : integer :: j
5618 : : integer :: i
5619 : : integer :: nn
5620 : : integer :: col
5621 : :
5622 : 51082 : nn = xgBlockA%cols
5623 [ - + ]: 51082 : if (xgBlockA%rows/=nn) then
5624 : 0 : ABI_ERROR('rows should be equal to cols!')
5625 : : end if
5626 : :
5627 [ - + ]: 51082 : if (xgBlockA%gpu_option==ABI_GPU_KOKKOS) then
5628 : 0 : ABI_ERROR('Not implemented for GPU Kokkos')
5629 : : end if
5630 : : if (xgBlockA%gpu_option==ABI_GPU_OPENMP) then
5631 : : call xgBlock_copy_from_gpu(xgBlockA) !FIXME Avoid that transfer
5632 : : end if
5633 : :
5634 : 51082 : select case(uplo)
5635 : : case ('u','U')
5636 : 51082 : select case(xgBlockA%space)
5637 : : case (SPACE_R)
5638 [ + + ]: 341204 : do j = 1, nn
5639 : 310224 : col = (j*(j-1))/2
5640 [ + + ]: 1940556 : do i = j+1,nn
5641 : 1909576 : xgBlockA%vecR(i,j) = zero
5642 : : end do
5643 : : end do
5644 : : case (SPACE_CR)
5645 : 0 : ABI_ERROR("Not implemented")
5646 : : case (SPACE_C)
5647 [ + - + - : 248528 : do j = 1, nn
+ + ]
5648 : 177344 : col = (j*(j-1))/2
5649 [ + + ]: 1070446 : do i = j+1,nn
5650 : 1050344 : xgBlockA%vecC(i,j) = czero
5651 : : end do
5652 : : end do
5653 : : end select
5654 : :
5655 : : case ('l','L')
5656 : 0 : select case(xgBlockA%space)
5657 : : case (SPACE_R)
5658 [ # # ]: 0 : do j = 1, nn
5659 : 0 : col = ((2*xgBlockA%cols-j)*(j-1))/2
5660 [ # # ]: 0 : do i = 1, j-1
5661 : 0 : xgBlockA%vecR(i,j) = zero
5662 : : end do
5663 : : end do
5664 : : case (SPACE_CR)
5665 : 0 : ABI_ERROR("Not implemented")
5666 : : case (SPACE_C)
5667 [ # # # # : 0 : do j = 1, nn
# # ]
5668 : 0 : col = ((2*xgBlockA%cols-j)*(j-1))/2
5669 [ # # ]: 0 : do i = 1, j-1
5670 : 0 : xgBlockA%vecC(i,j) = czero
5671 : : end do
5672 : : end do
5673 : : end select
5674 : : case default
5675 [ + - - ]: 51082 : ABI_ERROR("Error for zerotri")
5676 : : end select
5677 : :
5678 : : if (xgBlockA%gpu_option==ABI_GPU_OPENMP) then
5679 : : call xgBlock_copy_to_gpu(xgBlockA) !FIXME Avoid that transfer
5680 : : end if
5681 : :
5682 : 51082 : end subroutine xgBlock_zerotri
5683 : : !!***
5684 : :
5685 : : !!****f* m_xg/xgBlock_zero_im_g0
5686 : : !!
5687 : : !! NAME
5688 : : !! xgBlock_zero_im_g0
5689 : :
5690 : 7943310 : subroutine xgBlock_zero_im_g0(xgBlock)
5691 : :
5692 : : type(xgBlock_t), intent(inout) :: xgBlock
5693 : :
5694 : : integer :: ii,cols
5695 : :
5696 : : #if defined HAVE_OPENMP_OFFLOAD
5697 : : real(dp), contiguous, pointer :: xgBlock__vecR(:,:)
5698 : : #endif
5699 : : double precision :: tsec(2)
5700 : :
5701 : 7943310 : call timab(tim_zero_im_g0,1,tsec)
5702 [ + + ]: 7943310 : if (xgBlock%space==SPACE_CR) then
5703 : :
5704 : 717442 : cols = xgBlock%cols
5705 : :
5706 [ - + ]: 717442 : if (xgBlock%me_g0<0) then
5707 : 0 : ABI_ERROR("xgBlock me_g0 is not initialized")
5708 [ + + ]: 717442 : else if (xgBlock%me_g0==1) then
5709 : :
5710 [ - + ]: 120693 : if (xgBlock%gpu_option==ABI_GPU_KOKKOS) then
5711 : :
5712 : 0 : ABI_ERROR('Not implemented')
5713 : :
5714 [ + - ]: 120693 : else if (xgBlock%gpu_option==ABI_GPU_OPENMP) then
5715 : :
5716 : : #if defined HAVE_OPENMP_OFFLOAD
5717 : : xgBlock__vecR => xgBlock%vecR
5718 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO MAP(to:xgBlock__vecR)
5719 : : do ii = 1, cols
5720 : : xgBlock__vecR(2,ii) = zero
5721 : : end do
5722 : : #endif
5723 : :
5724 : : else
5725 : :
5726 : : !$omp parallel do
5727 [ + + ]: 2738947 : do ii = 1, cols
5728 : 2738947 : xgBlock%vecR(2,ii) = zero
5729 : : end do
5730 : :
5731 : : end if ! gpu_option
5732 : :
5733 : : end if ! me_g0>=0
5734 : : end if ! SPACE_CR
5735 : 7943310 : call timab(tim_zero_im_g0,2,tsec)
5736 : :
5737 : 7943310 : end subroutine xgBlock_zero_im_g0
5738 : : !!***
5739 : :
5740 : : !!****f* m_xg/xgBlock_invert
5741 : : !!
5742 : : !! NAME
5743 : : !! xgBlock_invert
5744 : :
5745 : 0 : subroutine xgBlock_invert(xgBlockA,xgBlockW,xg_input)
5746 : :
5747 : : type(xgBlock_t), intent(inout) :: xgBlockA,xgblockW
5748 : : type(xgBlock_t), optional,intent(in) :: xg_input
5749 : :
5750 : : integer :: nn,nrows,info,ldim
5751 : 0 : integer,allocatable :: ipiv(:)
5752 : : double precision :: tsec(2)
5753 : :
5754 : 0 : call timab(tim_invert,1,tsec)
5755 : :
5756 [ # # ]: 0 : if (xgBlockA%gpu_option/=ABI_GPU_DISABLED) then
5757 : 0 : ABI_ERROR('Not implemented for GPU')
5758 : : end if
5759 : 0 : call xgBlock_check_gpu_option(xgBlockA,xgBlockW)
5760 [ # # ]: 0 : if (present(xg_input)) then
5761 : 0 : call xgBlock_check_gpu_option(xgBlockA,xg_input)
5762 : : end if
5763 : :
5764 : 0 : call xgBlock_getsize(xgBlockA,nrows,nn,ldim=ldim)
5765 : 0 : if (nrows/=nn) then
5766 : 0 : ABI_ERROR('nrows/=ncols')
5767 : : end if
5768 [ # # ]: 0 : if (cols(xgBlockW)/=nn) then
5769 : 0 : ABI_ERROR('cols(xgBlockW)/=ncols')
5770 : : end if
5771 [ # # ]: 0 : if (rows(xgBlockW)/=nn) then
5772 : 0 : ABI_ERROR('rows(xgBlockW)/=nrows')
5773 : : end if
5774 : :
5775 [ # # ]: 0 : if (present(xg_input)) then
5776 [ # # ]: 0 : if (cols(xg_input)/=nn) then
5777 : 0 : ABI_ERROR('cols(xgBlockB)/=ncols')
5778 : : end if
5779 [ # # ]: 0 : if (rows(xg_input)/=nn) then
5780 : 0 : ABI_ERROR('rows(xgBlockB)/=nrows')
5781 : : end if
5782 : 0 : call xgBlock_copy(xg_input,xgBlockA)
5783 : : end if
5784 : :
5785 [ # # # # : 0 : ABI_MALLOC(ipiv,(nn))
# # # # #
# # # ]
5786 : :
5787 : 0 : select case(xgBlockA%space)
5788 : : case (SPACE_R)
5789 [ # # # # : 0 : call DGETRF(nn,nn,xgBlockA%vecR,ldim,ipiv,info)
# # # # #
# # # #
# ]
5790 [ # # ]: 0 : if (info==0) then
5791 [ # # # # : 0 : call DGETRI(nn,xgBlockA%vecR,ldim,ipiv,xgBlockW%vecR,nn,info)
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
5792 : : else
5793 : 0 : ABI_ERROR('info/=0 : something bad happened in xgetrf')
5794 : : end if
5795 : : case (SPACE_CR)
5796 : 0 : ABI_ERROR("Not implemented")
5797 : : !call DGETRF(nn,nn,xgBlockA%vecR,ldim,ipiv,info)
5798 : : !if (info==0) then
5799 : : ! call DGETRI(nn,xgBlockA%vecR,ldim,ipiv,xgBlockW%vecR,nn,info)
5800 : : !else
5801 : : ! ABI_ERROR('info/=0 : something bad happened in xgetrf')
5802 : : !end if
5803 : : case (SPACE_C)
5804 [ # # # # : 0 : call ZGETRF(nn,nn,xgBlockA%vecC,ldim,ipiv,info)
# # # # #
# # # #
# ]
5805 [ # # # # : 0 : if (info==0) then
# # ]
5806 [ # # # # : 0 : call ZGETRI(nn,xgBlockA%vecC,ldim,ipiv,xgBlockW%vecC,nn,info)
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
5807 : : else
5808 : 0 : ABI_ERROR('info/=0 : something bad happened in xgetrf')
5809 : : end if
5810 : : end select
5811 : :
5812 [ # # ]: 0 : ABI_FREE(ipiv)
5813 : :
5814 [ # # ]: 0 : if (info/=0) then
5815 : 0 : ABI_ERROR('info/=0 : something bad happened in xgetri')
5816 : : end if
5817 : :
5818 : 0 : call timab(tim_invert,2,tsec)
5819 : :
5820 [ # # ]: 0 : end subroutine xgBlock_invert
5821 : : !!***
5822 : :
5823 : : !!****f* m_xg/xgBlock_invert_sy
5824 : : !!
5825 : : !! NAME
5826 : : !! xgBlock_invert_sy
5827 : :
5828 : 1747 : subroutine xgBlock_invert_sy(xgBlockA,xgBlockW,xg_input)
5829 : :
5830 : : type(xgBlock_t), intent(inout) :: xgBlockA,xgblockW
5831 : : type(xgBlock_t), optional,intent(in) :: xg_input
5832 : :
5833 : : integer :: nn,nrows,ldim,info
5834 : : integer :: ii,jj
5835 : 1747 : integer,allocatable :: ipiv(:)
5836 : : double precision :: tsec(2)
5837 : :
5838 : 1747 : call timab(tim_invert_sy,1,tsec)
5839 : :
5840 [ - + ]: 1747 : if (xgBlockA%gpu_option/=ABI_GPU_DISABLED) then
5841 : 0 : ABI_ERROR('Not implemented for GPU')
5842 : : end if
5843 : 1747 : call xgBlock_check_gpu_option(xgBlockA,xgBlockW)
5844 [ + + ]: 1747 : if (present(xg_input)) then
5845 : 207 : call xgBlock_check_gpu_option(xgBlockA,xg_input)
5846 : : end if
5847 : :
5848 : 1747 : call xgBlock_getsize(xgBlockA,nrows,nn,ldim=ldim)
5849 : 1747 : if (nrows/=nn) then
5850 : 0 : ABI_ERROR('nrows/=ncols')
5851 : : end if
5852 [ - + ]: 1747 : if (cols(xgBlockW)/=nn) then
5853 : 0 : ABI_ERROR('cols(xgBlockW)/=ncols')
5854 : : end if
5855 [ - + ]: 1747 : if (rows(xgBlockW)/=nn) then
5856 : 0 : ABI_ERROR('rows(xgBlockW)/=nrows')
5857 : : end if
5858 : :
5859 [ + + ]: 1747 : if (present(xg_input)) then
5860 [ - + ]: 207 : if (cols(xg_input)/=nn) then
5861 : 0 : ABI_ERROR('cols(xg_input)/=ncols')
5862 : : end if
5863 [ - + ]: 207 : if (rows(xg_input)/=nn) then
5864 : 0 : ABI_ERROR('rows(xg_input)/=nrows')
5865 : : end if
5866 : 207 : call xgBlock_copy(xg_input,xgBlockA)
5867 : : end if
5868 : :
5869 [ - + + - : 5241 : ABI_MALLOC(ipiv,(nn))
+ - + - -
+ - + ]
5870 : :
5871 : 2450 : select case(xgBlockA%space)
5872 : : case (SPACE_R)
5873 [ + - - - : 703 : call DSYTRF('U',nn,xgBlockA%vecR,ldim,ipiv,xgBlockW%vecR,nn,info)
- - - - +
- - - - -
- - - + -
- - - - +
- - - - ]
5874 [ + - ]: 703 : if (info==0) then
5875 [ + - - - : 703 : call DSYTRI('U',nn,xgBlockA%vecR,ldim,ipiv,xgBlockW%vecR,info)
- - - - +
- - - - -
- - - + -
- - - - +
- - - - ]
5876 [ - + ]: 703 : if (info/=0) then
5877 : 0 : ABI_ERROR('info/=0 : something bad happened in dsytri')
5878 : : end if
5879 : : else
5880 : 0 : ABI_ERROR('info/=0 : something bad happened in dsytrf')
5881 : : end if
5882 : : ! complete the matrix
5883 [ + + ]: 6377 : do ii=1, nn
5884 [ + + ]: 26686 : do jj=1, ii-1
5885 : 25983 : xgBlockA%vecR(ii,jj) = xgBlockA%vecR(jj,ii)
5886 : : end do
5887 : : end do
5888 : : case (SPACE_CR)
5889 : 0 : ABI_ERROR("Not implemented")
5890 : : case (SPACE_C)
5891 [ + - - - : 1044 : call ZHETRF('U',nn,xgBlockA%vecC,ldim,ipiv,xgBlockW%vecC,nn,info)
- - - - +
- - - - -
- - - + -
- - - - +
- - - - ]
5892 [ + - ]: 1044 : if (info==0) then
5893 [ + - - - : 1044 : call ZHETRI('U',nn,xgBlockA%vecC,ldim,ipiv,xgBlockW%vecC,info)
- - - - +
- - - - -
- - - + -
- - - - +
- - - - ]
5894 [ - + ]: 1044 : if (info/=0) then
5895 : 0 : ABI_ERROR('info/=0 : something bad happened in zhetri')
5896 : : end if
5897 : : else
5898 : 0 : ABI_ERROR('info/=0 : something bad happened in zhetrf')
5899 : : end if
5900 : : ! complete the matrix
5901 [ + - + - : 11163 : do ii=1, nn
+ + ]
5902 [ + + ]: 38898 : do jj=1, ii-1
5903 : 37854 : xgBlockA%vecC(ii,jj) = CONJG(xgBlockA%vecC(jj,ii))
5904 : : end do
5905 : : end do
5906 : : end select
5907 : :
5908 [ - + ]: 1747 : ABI_FREE(ipiv)
5909 : :
5910 : 1747 : call timab(tim_invert_sy,2,tsec)
5911 : :
5912 [ - + ]: 1747 : end subroutine xgBlock_invert_sy
5913 : : !!***
5914 : :
5915 : : !!****f* m_xg/xgBlock_invert_tri
5916 : : !!
5917 : : !! NAME
5918 : : !! xgBlock_invert_tri
5919 : :
5920 : 51082 : subroutine xgBlock_invert_tri(uplo,diag,xgBlock)
5921 : :
5922 : : type(xgBlock_t), intent(inout) :: xgBlock
5923 : : character, intent(in) :: uplo,diag
5924 : :
5925 : : integer :: info
5926 : : double precision :: tsec(2)
5927 : :
5928 : 51082 : call timab(tim_invertri,1,tsec)
5929 : :
5930 [ - + ]: 51082 : if (xgBlock%rows/=xgBlock%cols) then
5931 : 0 : ABI_ERROR('nrows/=ncols')
5932 : : end if
5933 : :
5934 [ - + ]: 51082 : if (xgBlock%gpu_option==ABI_GPU_KOKKOS) then
5935 : 0 : ABI_ERROR('Not implemented for GPU Kokkos')
5936 : : end if
5937 : : if (xgBlock%gpu_option==ABI_GPU_OPENMP) then
5938 : : call xgBlock_copy_from_gpu(xgBlock) !FIXME Avoid that transfer
5939 : : end if
5940 : :
5941 : 82062 : select case(xgBlock%space)
5942 : : case (SPACE_R)
5943 [ + - - - : 30980 : call DTRTRI(uplo,diag,xgBlock%rows,xgBlock%vecR,xgBlock%LDim,info)
- - - - -
+ - - -
- ]
5944 : : case (SPACE_CR)
5945 : 0 : ABI_ERROR("Not implemented")
5946 : : case (SPACE_C)
5947 [ + - + - : 51082 : call ZTRTRI(uplo,diag,xgBlock%rows,xgBlock%vecC,xgBlock%LDim,info)
+ - - - -
- - - - +
- - - - ]
5948 : : end select
5949 : :
5950 : : if (xgBlock%gpu_option==ABI_GPU_OPENMP) then
5951 : : call xgBlock_copy_to_gpu(xgBlock) !FIXME Avoid that transfer
5952 : : end if
5953 : :
5954 [ - + ]: 51082 : if (info/=0) then
5955 : 0 : ABI_ERROR('info/=0 : something bad happened in xtrtri')
5956 : : end if
5957 : :
5958 : 51082 : call timab(tim_invertri,2,tsec)
5959 : :
5960 : 51082 : end subroutine xgBlock_invert_tri
5961 : : !!***
5962 : :
5963 : : !!****f* m_xg/xgBlock_yxpa
5964 : : !!
5965 : : !! NAME
5966 : : !! xgBlock_yxpa
5967 : :
5968 : 0 : subroutine xgBlock_yxpa(xgBlockA,xgBlockB,aa)
5969 : :
5970 : : double precision,intent(in) :: aa
5971 : : type(xgBlock_t), intent(in) :: xgBlockA
5972 : : type(xgBlock_t), intent(inout) :: xgBlockB
5973 : :
5974 : : integer :: nrows
5975 : :
5976 [ # # ]: 0 : if (xgBlockA%gpu_option/=ABI_GPU_DISABLED) then
5977 : 0 : ABI_ERROR('Not implemented for GPU')
5978 : : end if
5979 : 0 : call xgBlock_check_gpu_option(xgBlockA,xgBlockB)
5980 : :
5981 : 0 : nrows = rows(xgBlockA)
5982 : :
5983 : 0 : select case(xgBlockA%space)
5984 : : case (SPACE_R)
5985 [ # # # # ]: 0 : xgBlockB%vecR(1:nrows,:) = xgBlockA%vecR(1:nrows,:) + aa
5986 : : case (SPACE_CR)
5987 [ # # # # ]: 0 : xgBlockB%vecR(1:2*nrows,:) = xgBlockA%vecR(1:2*nrows,:) + aa
5988 : : case (SPACE_C)
5989 [ # # # # : 0 : xgBlockB%vecC(1:nrows,:) = xgBlockA%vecC(1:nrows,:) + aa*(1.0d0,1.0d0)
# # # # ]
5990 : : end select
5991 : :
5992 : 0 : end subroutine xgBlock_yxpa
5993 : : !!***
5994 : :
5995 : : !!****f* m_xg/xgBlock_one
5996 : : !!
5997 : : !! NAME
5998 : : !! xgBlock_one
5999 : :
6000 : 0 : subroutine xgBlock_one(xgBlock)
6001 : :
6002 : : type(xgBlock_t), intent(inout) :: xgBlock
6003 : : integer :: i
6004 : :
6005 : 0 : select case(xgBlock%space)
6006 : : case (SPACE_R)
6007 : : !$omp parallel do
6008 [ # # ]: 0 : do i = 1, min(xgBlock%rows,xgBlock%cols)
6009 : 0 : xgBlock%vecR(i,i) = 1.d0
6010 : : end do
6011 : : case (SPACE_CR)
6012 : : !$omp parallel do
6013 [ # # ]: 0 : do i = 1, min(2*xgBlock%rows,xgBlock%cols)
6014 : 0 : xgBlock%vecR(2*i-1,i) = 1.d0
6015 : : end do
6016 : : case (SPACE_C)
6017 : : !$omp parallel do
6018 [ # # # # : 0 : do i = 1, min(xgBlock%rows,xgBlock%cols)
# # ]
6019 : 0 : xgBlock%vecC(i,i) = dcmplx(1.d0)
6020 : : end do
6021 : : end select
6022 : :
6023 : 0 : end subroutine xgBlock_one
6024 : : !!***
6025 : :
6026 : : !!****f* m_xg/xgBlock_colwiseRandom
6027 : : !!
6028 : : !! NAME
6029 : : !! xgBlock_colwiseRandom
6030 : :
6031 : 18 : subroutine xgBlock_colwiseRandom(xgBlock, my_rank, jcol)
6032 : :
6033 : : type(xgBlock_t), intent(inout) :: xgBlock
6034 : : integer, intent(in) :: my_rank ! mpi-parallel safe seed
6035 : : integer, intent(in) :: jcol
6036 : :
6037 : : type(xgBlock_t) :: xgBlock_part
6038 : : real(dp) :: re, reim(2)
6039 : : real(dp) :: norm2_vec
6040 : : integer :: tid, seed_size, i, n, fact
6041 : 18 : integer, allocatable :: seed(:)
6042 : : complex(kind=c_double_complex), contiguous, pointer :: vecC(:) => null()
6043 : : real(kind=c_double), contiguous, pointer:: vecR(:) => null()
6044 : :
6045 : 18 : if (jcol > xgBlock%cols) then
6046 : 0 : ABI_ERROR('given column is out of block')
6047 : : end if
6048 : :
6049 : 18 : tid = 0
6050 : 18 : n = xgBlock%rows
6051 [ - + ]: 18 : fact = 1 ; if (xgBlock%space==SPACE_CR) fact = 2
6052 : :
6053 [ - + ]: 18 : if (xgBlock%gpu_option == ABI_GPU_OPENMP) then
6054 : 0 : call xgBlock_setBlock(xgBlock, xgBlock_part, n, 1, fcol=jcol)
6055 : 0 : call xgBlock_copy_from_gpu(xgBlock_part)
6056 : : end if
6057 : :
6058 : : ! Each thread each MPI process maintains its own seed
6059 : 18 : select case(xgBlock%space)
6060 : : case (SPACE_R,SPACE_CR)
6061 : 0 : vecR => xgBlock%vecR(1:fact*n,jcol) ! contiguous in memory
6062 : : !$omp parallel default(none) &
6063 : : !$omp private(tid, seed, re, i, seed_size) &
6064 : : !$omp shared(vecR, my_rank, n)
6065 : 0 : call random_seed(size=seed_size)
6066 [ # # # # : 0 : ABI_MALLOC(seed, (seed_size))
# # # # #
# # # #
# ]
6067 : 0 : tid = xomp_get_thread_num()
6068 [ # # # # : 0 : seed = 123456 + 1000*my_rank + 97*tid + (/ (i, i=1,seed_size) /)
# # # # #
# # # # #
# # # # ]
6069 : 0 : call random_seed(put=seed)
6070 : : ! Avoid multiple threads modify the same RNG state race condition
6071 : : ! execute each iteration i by exactly one thread
6072 : : !$omp do
6073 [ # # ]: 0 : do i=1,n
6074 : 0 : call random_number(re)
6075 [ # # ]: 0 : vecR(i) = merge(1.d0, -1.d0, re>=0.5d0)
6076 : : end do
6077 : : !$omp end do
6078 [ # # ]: 0 : ABI_FREE(seed)
6079 : : !$omp end parallel
6080 : : case (SPACE_C)
6081 : 18 : vecC => xgBlock%vecC(:,jcol) ! contiguous in memory
6082 : : !$omp parallel default(none) &
6083 : : !$omp private(tid, seed, reim, i, seed_size) &
6084 : : !$omp shared(vecC, my_rank, n)
6085 : 18 : call random_seed(size=seed_size)
6086 [ - + + - : 54 : ABI_MALLOC(seed, (seed_size))
+ - + - -
+ - + -
+ ]
6087 : 18 : tid = xomp_get_thread_num()
6088 [ + + - + : 612 : seed = 123456 + 1000*my_rank + 97*tid + (/ (i, i=1,seed_size) /)
+ + + - +
+ + - - +
- - + + ]
6089 : 18 : call random_seed(put=seed)
6090 : : !$omp do
6091 [ + + ]: 69984 : do i=1,n
6092 : 69966 : call random_number(reim)
6093 : 69984 : vecC(i) = dcmplx(reim(1)-0.5_dp, reim(2)-0.5_dp) ! zero mean
6094 : : end do
6095 : : !$omp end do
6096 [ - + ]: 18 : ABI_FREE(seed)
6097 : : !$omp end parallel
6098 [ + + ]: 69984 : norm2_vec = sum(conjg(vecC)*vecC)
6099 [ - + - + : 70002 : vecC = vecC / sqrt(real(norm2_vec, dp))
+ ]
6100 : : end select
6101 : :
6102 : : if (xgBlock%gpu_option == ABI_GPU_OPENMP) then
6103 : : call xgBlock_copy_to_gpu(xgBlock_part)
6104 : : end if
6105 : :
6106 [ - + - + ]: 36 : end subroutine xgBlock_colwiseRandom
6107 : : !!***
6108 : :
6109 : : !!****f* m_xg/xgBlock_colwiseRandomGaussian
6110 : : !!
6111 : : !! NAME
6112 : : !! xgBlock_colwiseRandomGaussian
6113 : :
6114 : 3474 : subroutine xgBlock_colwiseRandomGaussian(xgBlock, my_rank, jcol)
6115 : :
6116 : : type(xgBlock_t), intent(inout) :: xgBlock
6117 : : integer, intent(in) :: my_rank ! mpi-parallel safe seed
6118 : : integer, intent(in) :: jcol
6119 : :
6120 : : type(xgBlock_t) :: xgBlock_part
6121 : : real(dp) :: u1, u2, r, theta
6122 : : complex(dp) :: z
6123 : : integer :: tid, seed_size, i, n
6124 : 3474 : integer, allocatable :: seed(:)
6125 : : complex(kind=c_double_complex), contiguous, pointer :: vecC(:) => null()
6126 : :
6127 : 3474 : if (jcol > xgBlock%cols) then
6128 : 0 : ABI_ERROR('given column is out of block')
6129 : : end if
6130 : :
6131 : 3474 : tid = 0
6132 : 3474 : n = xgBlock%rows
6133 : :
6134 [ - + ]: 3474 : if (xgBlock%gpu_option == ABI_GPU_OPENMP) then
6135 : 0 : call xgBlock_setBlock(xgBlock, xgBlock_part, n, 1, fcol=jcol)
6136 : 0 : call xgBlock_copy_from_gpu(xgBlock_part)
6137 : : end if
6138 : :
6139 : : ! Each thread each MPI process maintains its own seed
6140 : 3474 : select case(xgBlock%space)
6141 : : case (SPACE_R)
6142 : 0 : ABI_ERROR('Not implemented for SPACE_R')
6143 : : case (SPACE_C)
6144 : 3474 : vecC => xgBlock%vecC(:,jcol) ! contiguous in memory
6145 : : !$omp parallel default(none) &
6146 : : !$omp private(tid, seed, u1, u2, r, theta, z, i, seed_size) &
6147 : : !$omp shared(vecC, my_rank, n)
6148 : 3474 : call random_seed(size=seed_size)
6149 [ - + + - : 10422 : ABI_MALLOC(seed, (seed_size))
+ - + - -
+ - + -
+ ]
6150 : 3474 : tid = xomp_get_thread_num()
6151 [ + + - + : 118116 : seed = 123456 + 1000*my_rank + 97*tid + (/ (i, i=1,seed_size) /)
+ + + - +
+ + - - +
- - + + ]
6152 : 3474 : call random_seed(put=seed)
6153 : : !$omp do
6154 [ + + ]: 670482 : do i=1,n
6155 : 667008 : call random_number(u1)
6156 : 667008 : call random_number(u2)
6157 [ - + ]: 667008 : if (u1 == 0.0d0) u1 = 1.0e-12
6158 : 667008 : r = sqrt(-2.d0 * log(u1))
6159 : 667008 : theta = 2.d0 * PI * u2
6160 : 667008 : z = (r*cos(theta)+(0.d0,1.d0)*r*sin(theta))/sqrt(2.d0)
6161 : 670482 : vecC(i) = dcmplx(real(z), aimag(z)) ! zero mean
6162 : : end do
6163 : : !$omp end do
6164 [ - + ]: 3474 : ABI_FREE(seed)
6165 : : !$omp end parallel
6166 : : case (SPACE_CR)
6167 [ - + - - ]: 3474 : ABI_ERROR('Not implemented for SPACE_CR')
6168 : : end select
6169 : :
6170 : : if (xgBlock%gpu_option == ABI_GPU_OPENMP) then
6171 : : call xgBlock_copy_to_gpu(xgBlock_part)
6172 : : end if
6173 : :
6174 [ - + - + ]: 6948 : end subroutine xgBlock_colwiseRandomGaussian
6175 : : !!***
6176 : :
6177 : : !!****f* m_xg/xgBlock_colwiseRandomRademacher
6178 : : !!
6179 : : !! NAME
6180 : : !! xgBlock_colwiseRandomRademacher
6181 : : !!
6182 : : !! FUNCTION
6183 : : !! Every entry has |z_j| = 1 and E[z_j] = 0
6184 : :
6185 : 90 : subroutine xgBlock_colwiseRandomRademacher(xgBlock, my_rank, jcol)
6186 : :
6187 : : type(xgBlock_t), intent(inout) :: xgBlock
6188 : : integer, intent(in) :: my_rank ! mpi-parallel safe seed
6189 : : integer, intent(in) :: jcol
6190 : :
6191 : : type(xgBlock_t) :: xgBlock_part
6192 : : real(dp) :: u
6193 : : complex(dp) :: meanz
6194 : : real(dp) :: norm2_, variance
6195 : : integer :: tid, seed_size, i, n, k, fact
6196 : 90 : integer, allocatable :: seed(:)
6197 : : complex(kind=c_double_complex), contiguous, pointer :: vecC(:) => null()
6198 : : real(kind=c_double) , contiguous, pointer :: vecR(:) => null()
6199 : :
6200 : 90 : if (jcol > xgBlock%cols) then
6201 : 0 : ABI_ERROR('given column is out of block')
6202 : : end if
6203 : :
6204 : 90 : tid = 0
6205 : : fact = 1
6206 [ - + ]: 90 : fact = 1 ; if (xgBlock%space==SPACE_CR) fact = 2
6207 : :
6208 : 90 : n = fact*xgBlock%rows
6209 : :
6210 [ - + ]: 90 : if (xgBlock%gpu_option == ABI_GPU_OPENMP) then
6211 : 0 : call xgBlock_setBlock(xgBlock, xgBlock_part, n, 1, fcol=jcol)
6212 : 0 : call xgBlock_copy_from_gpu(xgBlock_part)
6213 : : end if
6214 : :
6215 : : ! Each thread each MPI process maintains its own seed
6216 : 90 : select case(xgBlock%space)
6217 : : case (SPACE_R)
6218 : 0 : ABI_ERROR('Not implemented for SPACE_R')
6219 : : case (SPACE_C)
6220 : 90 : vecC => xgBlock%vecC(:,jcol) ! contiguous in memory
6221 : : !$omp parallel default(none) &
6222 : : !$omp private(tid, seed, u, k, i, seed_size) &
6223 : : !$omp shared(vecC, my_rank, n)
6224 : 90 : call random_seed(size=seed_size)
6225 [ - + + - : 270 : ABI_MALLOC(seed, (seed_size))
+ - + - -
+ - + -
+ ]
6226 : 90 : tid = xomp_get_thread_num()
6227 [ + + - + : 3060 : seed = 123456 + 1000*my_rank + 97*tid + (/ (i, i=1,seed_size) /)
+ + + - +
+ + - - +
- - + + ]
6228 : 90 : call random_seed(put=seed)
6229 : : !$omp do
6230 [ + + ]: 349920 : do i=1,n
6231 : 349830 : call random_number(u)
6232 : 349830 : k = int(4.0d0 * u) ! 0,1,2,3
6233 : 349920 : vecC(i) = exp(dcmplx(0.0d0, 1.0d0) * (0.5d0 * PI * k))
6234 : : end do
6235 : : !$omp end do
6236 [ - + ]: 90 : ABI_FREE(seed)
6237 : : !$omp end parallel
6238 : 90 : meanz = sum(vecC) / dcmplx(n,0.0d0)
6239 : : norm2_ = sum(abs(vecC)**2) / n
6240 : 0 : variance = norm2_ - abs(meanz)**2
6241 : : ! IML debug
6242 : : !write(901,*) "mean = ", meanz
6243 : : !write(901,*) "E|z|^2 = ", norm2_
6244 : : !write(901,*) "variance = ", variance
6245 : : !flush(901)
6246 : : case (SPACE_CR)
6247 : 0 : vecR => xgBlock%vecR(1:fact*xgBlock%rows,jcol) ! contiguous in memory
6248 : : !$omp parallel default(none) &
6249 : : !$omp private(tid, seed, u, k, i, seed_size) &
6250 : : !$omp shared(vecR, my_rank, n)
6251 : 0 : call random_seed(size=seed_size)
6252 [ # # # # : 0 : ABI_MALLOC(seed, (seed_size))
# # # # #
# # # #
# ]
6253 : 0 : tid = xomp_get_thread_num()
6254 [ # # # # : 0 : seed = 123456 + 1000*my_rank + 97*tid + (/ (i, i=1,seed_size) /)
# # # # #
# # # # #
# # # # ]
6255 : 0 : call random_seed(put=seed)
6256 : : !$omp do
6257 [ # # ]: 0 : do i=1,n
6258 : 0 : call random_number(u)
6259 [ # # ]: 0 : vecR(i) = merge(1.d0, -1.d0, u>=0.5d0)
6260 : : end do
6261 : : !$omp end do
6262 [ - + - - : 90 : ABI_FREE(seed)
- - ]
6263 : : !$omp end parallel
6264 : : end select
6265 : :
6266 : : if (xgBlock%gpu_option == ABI_GPU_OPENMP) then
6267 : : call xgBlock_copy_to_gpu(xgBlock_part)
6268 : : end if
6269 : :
6270 [ - + - + ]: 180 : end subroutine xgBlock_colwiseRandomRademacher
6271 : : !!***
6272 : :
6273 : : !!****f* m_xg/xgBlock_randomSketching
6274 : : !!
6275 : : !! NAME
6276 : : !! xgBlock_randomSketching
6277 : : !!
6278 : :
6279 : 36 : subroutine xgBlock_randomSketching(X, X_sketch, k_sketch)
6280 : :
6281 : : implicit none
6282 : :
6283 : : type(xgBlock_t), intent(in) :: X
6284 : : type(xgBlock_t), intent(inout) :: X_sketch
6285 : : integer, intent(in) :: k_sketch
6286 : :
6287 : : integer :: k
6288 : : integer :: rank
6289 : : integer :: spacecom, space
6290 : : integer :: ncols, nrows
6291 : : integer :: gpu_option
6292 : : type(xg_t) :: Omega
6293 : : !type(xgBlock_t) :: q
6294 : :
6295 : : ! *********************************************************************
6296 : :
6297 : 36 : space = X%space
6298 : 36 : ncols = X%cols
6299 : 36 : nrows = X%rows
6300 : 36 : gpu_option = X%gpu_option
6301 : 36 : spacecom = X%spacedim_comm
6302 : :
6303 : 36 : if (k_sketch > ncols) then
6304 : 0 : ABI_ERROR("sketching dimension cannot be more than initial one")
6305 : : end if
6306 : :
6307 : : ! Each MPI has the same sketch matrix
6308 : 36 : call xg_init(Omega, space, ncols, k_sketch, xmpi_comm_null, gpu_option=gpu_option)
6309 : :
6310 : 36 : rank = xmpi_comm_rank(spacecom)
6311 : :
6312 [ + + ]: 3510 : do k = 1, k_sketch
6313 : : ! seed depends on column index
6314 : : ! rank * offset + k, with offset > ncols to avoid overlap between columns across ranks
6315 : 3510 : call xgBlock_colwiseRandomGaussian(Omega%self, rank*(k_sketch+10)+k, k)
6316 : :
6317 : : ! test
6318 : : ! q = random column vector
6319 : : !call xgBlock_setBlock(Omega%self, q, ncols, 1, fcol=k)
6320 : : !write(std_out,*) 'Random id=', xgBlock_getid(q)
6321 : : !flush(std_out)
6322 : : end do
6323 : :
6324 : : ! Compute X * Omega
6325 : 36 : call xgBlock_gemm('n','n',1.0d0,X,Omega%self,0.d0,X_sketch,comm=xmpi_comm_null)
6326 : : !call xgBlock_copy(Omega%self, X_sketch)
6327 : :
6328 : 36 : call xg_free(Omega)
6329 : :
6330 [ - + ]: 36 : end subroutine xgBlock_randomSketching
6331 : : !!***
6332 : :
6333 : : !!****f* m_xg/xgBlock_diagonal
6334 : : !!
6335 : : !! NAME
6336 : : !! xgBlock_diagonal
6337 : :
6338 : 0 : subroutine xgBlock_diagonal(xgBlock,diag)
6339 : :
6340 : : type(xgBlock_t), intent(inout) :: xgBlock
6341 : : type(xgBlock_t), intent(in ) :: diag
6342 : : integer :: i
6343 : :
6344 [ # # # # ]: 0 : if ( diag%cols /= 1 .or. diag%rows/= min(xgBlock%rows,xgBlock%cols) ) then
6345 : 0 : ABI_ERROR("Bad diagonal")
6346 : : end if
6347 : :
6348 : 0 : select case(xgBlock%space)
6349 : : case (SPACE_R)
6350 : 0 : select case(diag%space)
6351 : : case (SPACE_R)
6352 : : !$omp parallel do
6353 [ # # ]: 0 : do i = 1, min(xgBlock%rows,xgBlock%cols)
6354 : 0 : xgBlock%vecR(i,i) = diag%vecR(i,1)
6355 : : end do
6356 : : case (SPACE_CR)
6357 : 0 : ABI_ERROR('Not implemented for SPACE_CR')
6358 : : case (SPACE_C)
6359 : : !$omp parallel do
6360 [ # # # # : 0 : do i = 1, min(xgBlock%rows,xgBlock%cols)
# # ]
6361 : 0 : xgBlock%vecR(i,i) = dble(diag%vecC(i,1))
6362 : : end do
6363 : : end select
6364 : : case (SPACE_CR)
6365 : 0 : ABI_ERROR('Not implemented for SPACE_CR')
6366 : : case (SPACE_C)
6367 [ # # # # ]: 0 : select case(diag%space)
6368 : : case (SPACE_R)
6369 : : !$omp parallel do
6370 [ # # ]: 0 : do i = 1, min(xgBlock%rows,xgBlock%cols)
6371 : 0 : xgBlock%vecC(i,i) = dcmplx(diag%vecR(i,1))
6372 : : end do
6373 : : case (SPACE_CR)
6374 : 0 : ABI_ERROR('Not implemented for SPACE_CR')
6375 : : case (SPACE_C)
6376 : : !$omp parallel do
6377 [ # # # # : 0 : do i = 1, min(xgBlock%rows,xgBlock%cols)
# # ]
6378 : 0 : xgBlock%vecC(i,i) = diag%vecR(i,1)
6379 : : end do
6380 : : end select
6381 : : end select
6382 : :
6383 : 0 : end subroutine xgBlock_diagonal
6384 : : !!***
6385 : :
6386 : : !!****f* m_xg/xgBlock_diagonalOnly
6387 : : !!
6388 : : !! NAME
6389 : : !! xgBlock_diagonalOnly
6390 : :
6391 : 0 : subroutine xgBlock_diagonalOnly(xgBlock)
6392 : :
6393 : : type(xgBlock_t) , intent(inout) :: xgBlock
6394 : : type(xg_t) :: diag
6395 : : integer :: i
6396 : :
6397 : 0 : if ( xgBlock%rows /= xgBlock%cols) then
6398 : 0 : ABI_ERROR("Bad xgBlock shape")
6399 : : end if
6400 : :
6401 : 0 : call xg_init(diag,space(xgBlock),xgBlock%rows,1,xgBlock%spacedim_comm)
6402 : 0 : select case(xgBlock%space)
6403 : : case (SPACE_R)
6404 : : !$omp parallel do
6405 [ # # ]: 0 : do i = 1, xgBlock%cols
6406 : 0 : diag%vecR(i,1) = xgBlock%vecR(i,i)
6407 : : end do
6408 : : case (SPACE_CR)
6409 : 0 : ABI_ERROR('Not implemented for SPACE_CR')
6410 : : case (SPACE_C)
6411 : : !$omp parallel do
6412 [ # # # # : 0 : do i = 1, xgBlock%cols
# # ]
6413 : 0 : diag%vecC(i,1) = xgBlock%vecC(i,i)
6414 : : end do
6415 : : end select
6416 : 0 : call xgBlock_zero(xgBlock)
6417 : 0 : call xgBlock_diagonal(xgBlock,diag%self)
6418 : 0 : call xg_free(diag)
6419 : :
6420 [ # # ]: 0 : end subroutine xgBlock_diagonalOnly
6421 : : !!***
6422 : :
6423 : : !!****f* m_xg/xgBlock_minmax
6424 : : !!
6425 : : !! NAME
6426 : : !! xgBlock_minmax
6427 : :
6428 : 759215 : subroutine xgBlock_minmax(xgBlock,minimum,maximum,row_bound)
6429 : :
6430 : : type(XgBlock_t) , intent(in) :: xgBlock
6431 : : double precision, intent(out) :: minimum,maximum
6432 : : integer,optional, intent(in) :: row_bound
6433 : :
6434 : : integer :: row_bound_,fact
6435 : : double precision :: tsec(2)
6436 : :
6437 : 759215 : call timab(tim_minmax,1,tsec)
6438 : :
6439 [ - + ]: 759215 : fact = 1 ; if (xgBlock%space==SPACE_CR) fact = 2
6440 : :
6441 : 759215 : row_bound_ = fact*xgBlock%rows
6442 [ + + ]: 759215 : if (present(row_bound)) then
6443 [ + - - + ]: 28390 : if (row_bound<1.or.row_bound>fact*xgBlock%rows) then
6444 : 0 : ABI_ERROR('Bad row_bound')
6445 : : else
6446 : 28390 : row_bound_ = fact*row_bound
6447 : : end if
6448 : : end if
6449 : :
6450 : 1518430 : select case(xgBlock%space)
6451 : : case (SPACE_R,SPACE_CR)
6452 [ + + + + : 3453737 : minimum = minval(xgBlock%vecR(:row_bound_,:))
+ + + - -
+ - - ]
6453 [ + + + + : 3453737 : maximum = maxval(xgBlock%vecR(:row_bound_,:))
+ + + - -
+ - - ]
6454 : : case (SPACE_C)
6455 [ # # # # : 0 : minimum = minval(abs(xgBlock%vecC(:row_bound_,:)))
# # # # #
# # # ]
6456 [ + - - - : 759215 : maximum = maxval(abs(xgBlock%vecC(:row_bound_,:)))
- - - - -
- - - - -
- ]
6457 : : end select
6458 : :
6459 : 759215 : call timab(tim_minmax,2,tsec)
6460 : :
6461 : 759215 : end subroutine xgBlock_minmax
6462 : : !!***
6463 : :
6464 : : !!****f* m_xg/xgBlock_average
6465 : : !!
6466 : : !! NAME
6467 : : !! xgBlock_average
6468 : :
6469 : 0 : subroutine xgBlock_average(xgBlock,average)
6470 : :
6471 : : type(XgBlock_t) , intent(in) :: xgBlock
6472 : : double precision, intent(out) :: average
6473 : : complex(kind=8) :: averageC
6474 : : integer :: i,fact
6475 : :
6476 [ # # ]: 0 : fact = 1 ; if (xgBlock%space==SPACE_CR) fact = 2
6477 : :
6478 : 0 : select case(xgBlock%space)
6479 : : case (SPACE_R,SPACE_CR)
6480 : 0 : average = 0.d0
6481 [ # # ]: 0 : do i = 1, xgBlock%cols
6482 [ # # ]: 0 : average = average + sum(xgBlock%vecR(1:fact*xgBlock%rows,i))
6483 : : end do
6484 : 0 : average = average / dble(xgBlock%cols*xgBlock%rows)
6485 : : case (SPACE_C)
6486 : 0 : averageC = dcmplx(0.d0,0.d0)
6487 [ # # ]: 0 : do i = 1, xgBlock%cols
6488 [ # # ]: 0 : averageC = averageC + sum(xgBlock%vecC(1:xgBlock%rows,i))
6489 : : end do
6490 : 0 : averageC = averageC / dble(xgBlock%cols*xgBlock%rows)
6491 [ # # # ]: 0 : average = dble(averageC)
6492 : : end select
6493 : :
6494 : 0 : end subroutine xgBlock_average
6495 : : !!***
6496 : :
6497 : : !!****f* m_xg/xgBlock_deviation
6498 : : !!
6499 : : !! NAME
6500 : : !! xgBlock_deviation
6501 : :
6502 : 0 : subroutine xgBlock_deviation(xgBlock,deviation)
6503 : :
6504 : : type(XgBlock_t) , intent(in) :: xgBlock
6505 : : double precision, intent(out) :: deviation
6506 : : complex(kind=8) :: deviationC
6507 : : double precision :: average
6508 : : integer :: i,fact
6509 : :
6510 [ # # ]: 0 : fact = 1 ; if (xgBlock%space==SPACE_CR) fact = 2
6511 : :
6512 : 0 : call xgBlock_average(xgBlock,average)
6513 : 0 : select case(xgBlock%space)
6514 : : case (SPACE_R,SPACE_CR)
6515 : 0 : deviation = 0.d0
6516 [ # # ]: 0 : do i = 1, xgBlock%cols
6517 [ # # ]: 0 : deviation = deviation + sum((xgBlock%vecR(1:fact*xgBlock%rows,i)-average)*(xgBlock%vecR(1:fact*xgBlock%rows,i)-average))
6518 : : end do
6519 : 0 : deviation = sqrt( deviation / dble(xgBlock%cols*xgBlock%rows) )
6520 : : case (SPACE_C)
6521 : 0 : deviationC = dcmplx(0.d0,0.d0)
6522 [ # # ]: 0 : do i = 1, xgBlock%cols
6523 [ # # ]: 0 : deviationC = deviationC + sum((xgBlock%vecC(1:xgBlock%rows,i)-average)*(xgBlock%vecC(1:xgBlock%rows,i)-average))
6524 : : end do
6525 : 0 : deviationC = deviationC / dble(xgBlock%cols*xgBlock%rows)
6526 [ # # # ]: 0 : deviation = abs(deviationC)
6527 : : end select
6528 : 0 : end subroutine xgBlock_deviation
6529 : : !!***
6530 : :
6531 : : !!****f* m_xg/xgBlock_print
6532 : : !!
6533 : : !! NAME
6534 : : !! xgBlock_print
6535 : :
6536 : 0 : subroutine xgBlock_print(xgBlock,outunit)
6537 : :
6538 : : type(xgBlock_t), intent(in) :: xgBlock
6539 : : integer, intent(in) :: outunit
6540 : : integer :: i, j
6541 : : character(len=4) :: ccols
6542 : : character(len=50) :: fstring
6543 : 0 : real(dp), allocatable :: vecR_tmp(:)
6544 : :
6545 : : #if defined HAVE_GPU && defined HAVE_OPENMP_OFFLOAD
6546 : : complex(dp), pointer :: xgBlock__vecC(:,:)
6547 : : real(dp), pointer :: xgBlock__vecR(:,:)
6548 : : #endif
6549 : :
6550 : 0 : select case(xgBlock%space)
6551 : : case (SPACE_R)
6552 : : #if defined HAVE_GPU && defined HAVE_OPENMP_OFFLOAD
6553 : : if (xgBlock%gpu_option==ABI_GPU_OPENMP) then
6554 : : xgBlock__vecR => xgBlock%vecR
6555 : : !$OMP TARGET UPDATE FROM(xgBlock__vecR)
6556 : : end if
6557 : : #endif
6558 : 0 : write(ccols,'(i4)') xgBlock%cols
6559 : : !fstring = '(1x,'//trim(adjustl(ccols))//'ES22.14)'
6560 [ # # # # ]: 0 : fstring = '(1x,'//trim(adjustl(ccols))//'f24.14)'
6561 [ # # ]: 0 : do i = 1, xgBlock%rows
6562 [ # # # # : 0 : write(outunit,fstring) (/ (xgBlock%vecR(i,j), j = 1, xgBlock%cols) /)
# # ]
6563 : : end do
6564 : : case (SPACE_CR)
6565 : : #if defined HAVE_GPU && defined HAVE_OPENMP_OFFLOAD
6566 : : if (xgBlock%gpu_option==ABI_GPU_OPENMP) then
6567 : : xgBlock__vecR => xgBlock%vecR
6568 : : !$OMP TARGET UPDATE FROM(xgBlock__vecR)
6569 : : end if
6570 : : #endif
6571 [ # # # # : 0 : ABI_MALLOC(vecR_tmp,(2*xgBlock%cols))
# # # # #
# # # #
# ]
6572 : 0 : write(ccols,'(i4)') 2*xgBlock%cols
6573 : : !fstring = '(1x,2(1x,'//trim(adjustl(ccols))//'ES22.14))'
6574 [ # # # # ]: 0 : fstring = '(1x,2(1x,'//trim(adjustl(ccols))//'f24.14))'
6575 [ # # ]: 0 : do i = 1, xgBlock%rows
6576 [ # # ]: 0 : do j = 1, xgBlock%cols
6577 : 0 : vecR_tmp(2*j-1) = xgBlock%vecR(2*i-1,j)
6578 : 0 : vecR_tmp(2*j ) = xgBlock%vecR(2*i ,j)
6579 : : end do
6580 [ # # # # : 0 : write(outunit,fstring) (/ (vecR_tmp(j), j = 1, 2*xgBlock%cols) /)
# # ]
6581 : : end do
6582 [ # # ]: 0 : ABI_FREE(vecR_tmp)
6583 : : case (SPACE_C)
6584 : : #if defined HAVE_GPU && defined HAVE_OPENMP_OFFLOAD
6585 : : if (xgBlock%gpu_option==ABI_GPU_OPENMP) then
6586 : : xgBlock__vecC => xgBlock%vecC
6587 : : !$OMP TARGET UPDATE FROM(xgBlock__vecC)
6588 : : end if
6589 : : #endif
6590 : 0 : write(ccols,'(i4)') xgBlock%cols
6591 : : !fstring = '(1x,2(1x,'//trim(adjustl(ccols))//'ES22.14))'
6592 [ # # # # ]: 0 : fstring = '(1x,2(1x,'//trim(adjustl(ccols))//'f24.14))'
6593 [ # # # # : 0 : do i = 1, xgBlock%rows
# # ]
6594 [ # # # # : 0 : write(outunit,fstring) (/ (xgBlock%vecC(i,j), j = 1, xgBlock%cols) /)
# # ]
6595 : : end do
6596 : : end select
6597 : 0 : end subroutine xgBlock_print
6598 : : !!***
6599 : :
6600 : : !!****f* m_xg/xgBlock_getid
6601 : : !!
6602 : : !! NAME
6603 : : !! xgBlock_getid
6604 : :
6605 : 18 : function xgBlock_getid(xgBlock,comm) result (id)
6606 : :
6607 : : type(xgBlock_t), intent(in) :: xgBlock
6608 : : integer, intent(in),optional :: comm
6609 : :
6610 : : real(dp) :: id
6611 : : integer :: ierr,comm_
6612 : :
6613 : : if (xgBlock%gpu_option/=ABI_GPU_DISABLED) then
6614 : : call xgBlock_copy_from_gpu(xgBlock)
6615 : : end if
6616 : 18 : select case(xgBlock%space)
6617 : : case (SPACE_R)
6618 [ # # # # ]: 0 : id = sum(abs(xgBlock%vecR(:,:)))
6619 : : case (SPACE_CR)
6620 [ # # ]: 0 : if (xgBlock%me_g0<0) then
6621 : 0 : ABI_ERROR("xgBlock me_g0 is not initialized")
6622 : : end if
6623 [ # # # # ]: 0 : id = 2*sum(abs(xgBlock%vecR(:,:)))
6624 [ # # ]: 0 : if (xgBlock%me_g0==1) then
6625 [ # # ]: 0 : id = id - sum(abs(xgBlock%vecR(1,:)))
6626 : : end if
6627 : : case (SPACE_C)
6628 [ - - + - : 9009276 : id = sum(abs(dble(xgBlock%vecC(:,:))))+sum(abs(dimag(xgBlock%vecC(:,:))))
+ + + + +
+ + + ]
6629 : : end select
6630 : 18 : comm_=xgBlock%spacedim_comm
6631 [ - + ]: 18 : if (present(comm)) then
6632 : 0 : comm_=comm
6633 : : end if
6634 [ + + ]: 18 : if (xmpi_comm_size(comm_)>1) call xmpi_sum(id,comm_,ierr)
6635 : :
6636 : 18 : end function xgBlock_getid
6637 : : !!***
6638 : :
6639 : : !!****f* m_xg/xgBlock_get_im_g0
6640 : : !!
6641 : : !! NAME
6642 : : !! xgBlock_get_im_g0
6643 : :
6644 : 0 : function xgBlock_get_im_g0(xgBlock,comm) result (im_g0)
6645 : :
6646 : : type(xgBlock_t), intent(in) :: xgBlock
6647 : : integer, intent(in),optional :: comm
6648 : :
6649 : : real(dp) :: im_g0
6650 : : integer :: ierr,comm_
6651 : :
6652 : : if (xgBlock%gpu_option/=ABI_GPU_DISABLED) then
6653 : : call xgBlock_copy_from_gpu(xgBlock)
6654 : : end if
6655 : 0 : select case(xgBlock%space)
6656 : : case (SPACE_R)
6657 : 0 : im_g0 = zero
6658 : : case (SPACE_CR)
6659 [ # # ]: 0 : if (xgBlock%me_g0<0) then
6660 : 0 : ABI_ERROR("xgBlock me_g0 is not initialized")
6661 : : end if
6662 : 0 : im_g0 = zero
6663 [ # # ]: 0 : if (xgBlock%me_g0==1) then
6664 [ # # ]: 0 : im_g0 = im_g0 + sum(abs(xgBlock%vecR(2,:)))
6665 : : end if
6666 : : case (SPACE_C)
6667 [ # # # # ]: 0 : im_g0 = zero
6668 : : end select
6669 : 0 : comm_=xgBlock%spacedim_comm
6670 [ # # ]: 0 : if (present(comm)) then
6671 : 0 : comm_=comm
6672 : : end if
6673 [ # # ]: 0 : if (xmpi_comm_size(comm_)>1) call xmpi_sum(im_g0,comm_,ierr)
6674 : :
6675 : 0 : end function xgBlock_get_im_g0
6676 : : !!***
6677 : :
6678 : : !!****f* m_xg/xg_finalize
6679 : : !!
6680 : : !! NAME
6681 : : !! xg_finalize
6682 : :
6683 : 5334 : subroutine xg_finalize()
6684 : :
6685 [ + + ]: 5334 : if ( allocated(iwork) ) then
6686 : 657 : ABI_FREE(iwork)
6687 : : end if
6688 [ + + ]: 5334 : if ( allocated(rwork) ) then
6689 : 657 : ABI_FREE(rwork)
6690 : : end if
6691 [ + + ]: 5334 : if ( allocated(cwork) ) then
6692 : 493 : ABI_FREE(cwork)
6693 : : end if
6694 : :
6695 : 5334 : liwork = 0
6696 : 5334 : lrwork = 0
6697 : 5334 : lcwork = 0
6698 : :
6699 : 5334 : end subroutine xg_finalize
6700 : : !!***
6701 : :
6702 : : !!****f* m_xg/xg_associated
6703 : : !!
6704 : : !! NAME
6705 : : !! xg_associated
6706 : :
6707 : 0 : function xg_associated(xgB) result (tf)
6708 : :
6709 : : type(xgBlock_t), intent(inout) :: xgB
6710 : : logical :: tf
6711 : :
6712 : : if ( associated(xgB%vecR) ) then
6713 : : tf = .TRUE.
6714 : : end if
6715 : :
6716 [ # # ]: 0 : if ( associated(xgB%vecC) ) then
6717 : 0 : tf = .FALSE.
6718 : : end if
6719 : :
6720 : 0 : end function xg_associated
6721 : : !!***
6722 : :
6723 : 0 : end module m_xg
6724 : : !!***
|
