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