Branch data Line data Source code
1 : : !!****m* ABINIT/m_gemm_nonlop_projectors
2 : : !! NAME
3 : : !! m_gemm_nonlop
4 : : !!
5 : : !! FUNCTION
6 : : !! This module provides functions to compute the nonlocal operator by means of the BLAS GEMM
7 : : !! routine. By treating ndat simultaneous wavefunctions, it is able to exploit BLAS3 routines,
8 : : !! which leads to excellent CPU efficiency and OpenMP scalability.
9 : : !!
10 : : !! COPYRIGHT
11 : : !! Copyright (C) 2014-2026 ABINIT group (AL)
12 : : !! This file is distributed under the terms of the
13 : : !! GNU General Public License, see ~abinit/COPYING
14 : : !! or http://www.gnu.org/copyleft/gpl.txt .
15 : : !!
16 : : !! SOURCE
17 : :
18 : : ! TODO list :
19 : : ! Don't allocate the full nkpt structures, only those that are treated by this proc: use same init as in m_bandfft_kpt
20 : : ! support more options (forces & stresses mostly)
21 : : ! Support RF/other computations (only GS right now)
22 : : ! handle the case where nloalg(2) < 0, ie no precomputation of ph3d
23 : : ! more systematic checking of the workflow (right now, only works if init/make/gemm/destroy, no multiple makes, etc)
24 : : ! Avoid allocating the complex matrix when istwfk > 1
25 : : ! Merge with chebfi's invovl
26 : :
27 : :
28 : : #if defined HAVE_CONFIG_H
29 : : #include "config.h"
30 : : #endif
31 : :
32 : : #include "abi_common.h"
33 : :
34 : : module m_gemm_nonlop_projectors
35 : :
36 : : use defs_basis
37 : : use m_errors
38 : : use m_abicore
39 : : use m_xomp
40 : : use m_xmpi
41 : : use m_fstrings, only : itoa, ftoa, sjoin
42 : : use m_gputk
43 : : use m_abi_linalg
44 : :
45 : : use defs_abitypes, only : MPI_type
46 : : use m_kg, only : mkkpg
47 : : use m_hamiltonian, only : KPRIME_H_K, K_H_KPRIME, K_H_K, KPRIME_H_KPRIME
48 : :
49 : : #if defined(HAVE_GPU)
50 : : use m_gpu_toolbox
51 : : #endif
52 : :
53 : : #if defined(HAVE_GPU_CUDA)
54 : : use m_alloc_hamilt_gpu, only : gemm_nonlop_gpu_data
55 : : #endif
56 : :
57 : : use, intrinsic :: iso_c_binding, only : c_int32_t, c_int64_t, c_float, c_double, c_size_t, c_loc, c_ptr
58 : :
59 : : implicit none
60 : :
61 : : private
62 : :
63 : : public :: init_gemm_nonlop
64 : : public :: destroy_gemm_nonlop
65 : : public :: reset_gemm_nonlop
66 : : public :: set_gemm_nonlop_ikpt
67 : : public :: prep_projectors
68 : : public :: prep_dprojectors
69 : : public :: refresh_projectors
70 : :
71 : : !!***
72 : :
73 : : !----------------------------------------------------------------------
74 : :
75 : : !!****t* m_gemm_nonlop_projectors/gemm_nonlop_type
76 : : !! NAME
77 : : !! gemm_nonlop_type
78 : : !!
79 : : !! FUNCTION
80 : : !! Contains information needed to apply the nonlocal operator
81 : : !!
82 : : !! SOURCE
83 : : type,public :: gemm_nonlop_type
84 : :
85 : : integer :: npw
86 : : integer :: nprojs
87 : : integer :: ngrads
88 : : integer :: ngrads2
89 : :
90 : : integer :: nprojs_blk
91 : : integer :: nprojs_last_blk
92 : :
93 : : real(dp), allocatable :: projs(:, :, :)
94 : : ! (2, npw, nprojs)
95 : :
96 : : real(dp), allocatable :: projs_r(:, :, :)
97 : : ! (1, npw, nprojs)
98 : :
99 : : real(dp), allocatable :: projs_i(:, :, :)
100 : : ! (1, npw, nprojs)
101 : :
102 : : real(dp), allocatable :: dprojs(:, :, :)
103 : : ! (2, npw, nprojs*ngrads)
104 : : real(dp), allocatable :: dprojs_r(:, :, :)
105 : : ! (1, npw, nprojs*ngrads)
106 : : real(dp), allocatable :: dprojs_i(:, :, :)
107 : : ! (1, npw, nprojs*ngrads)
108 : :
109 : : real(dp), allocatable :: d2projs(:, :, :)
110 : : ! (2, npw, nprojs*ngrads)
111 : :
112 : : integer :: idir
113 : : integer :: ikpt
114 : : integer :: choice
115 : :
116 : : end type gemm_nonlop_type
117 : : !!***
118 : :
119 : : type(gemm_nonlop_type), save, public, target :: gemm_nonlop_kpt(2)
120 : : !(nkpt)
121 : :
122 : : integer, save, public :: gemm_nonlop_ikpt_this_proc_being_treated
123 : : !! This is oh so very crude, but I can't find any other way to do it without passing ikpt deep down to nonlop
124 : :
125 : : logical, save, public :: gemm_nonlop_use_gemm = .false.
126 : : ! Public variable indicating whether we should call gemm_nonlop or fall back to the usual nonlop. Set to false
127 : : ! in order not to interfere with non-GS calls to nonlop.
128 : :
129 : : logical, save, public :: gemm_nonlop_is_distributed = .false.
130 : : ! Public variable indicating whether we should gemm_nonlop operated in a distributed manner. Set to false by default
131 : : ! but might be enabled by memory constraints or forced by user through parameters.
132 : :
133 : : logical, save, public :: gemm_nonlop_split_choice23 = .false.
134 : : ! Public variable indicating whether choice 23 computation should be splitted. Set to false by default
135 : : ! but might be enabled by memory constraints or forced by user through parameters.
136 : :
137 : : integer, save :: gemm_nonlop_nblocks = 1
138 : : ! How many blocks of MPI tasks should the projs arrays be ditributed.
139 : :
140 : : integer, save, public :: gemm_nonlop_block_comm = xmpi_comm_null
141 : : ! MPI communicator for MPI tasks processing the same gemm_nonlop block for projs array distribution
142 : :
143 : : integer, save, public :: gemm_nonlop_block_size = 0
144 : : ! Public variable indicating size of a block (ie: number of MPI tasks in gemm_nonlop_block_comm)
145 : : ! Default size 0 indicates no distribution at all.
146 : :
147 : : integer, save, public :: gemm_nonlop_choice = -1
148 : :
149 : : integer, save, public :: gemm_nonlop_gpu_option = ABI_GPU_DISABLED
150 : :
151 : : real(dp),save, allocatable, target :: atom_projs(:,:,:)
152 : : real(dp),save, allocatable, target :: atom_dprojs(:,:,:,:)
153 : : real(dp),save, allocatable, target :: atom_d2projs(:,:,:,:)
154 : : integer,save, allocatable, target :: scal(:)
155 : : integer,save, allocatable, target :: lmn_parity(:)
156 : : integer, save :: mod__lmnmax, mod__npw, mod__ndprojs, mod__nd2projs
157 : : ! Work arrays for prep_*projectors functions. Sized after mod__lmnmax, mod__npw and mod__ndprojs.
158 : :
159 : : #if defined(HAVE_FC_ISO_C_BINDING) && defined(HAVE_GPU_CUDA)
160 : :
161 : : type, bind(c), public :: gemm_nonlop_gpu_type
162 : :
163 : : integer(kind=c_int32_t) :: npw
164 : : integer(kind=c_int32_t) :: nprojs
165 : :
166 : : ! array of double on GPU, dimensions are (2, npw, nprojs)
167 : : type(c_ptr) :: projs
168 : :
169 : : ! array of double on GPU, dimensions are (1, npw, nprojs)
170 : : type(c_ptr) :: projs_r
171 : :
172 : : ! array of double on GPU, dimensions are (1, npw, nprojs)
173 : : type(c_ptr) :: projs_i
174 : :
175 : : end type gemm_nonlop_gpu_type
176 : :
177 : : !! array of size nkpt of sobjects of type gemm_nonlop_gpu_type, array size is nkpt
178 : : type(gemm_nonlop_gpu_type), save, public, target :: gemm_nonlop_kpt_gpu(2)
179 : : !(nkpt)
180 : :
181 : : #endif
182 : :
183 : : !!***
184 : :
185 : : !----------------------------------------------------------------------
186 : :
187 : : contains
188 : :
189 : : !----------------------------------------------------------------------
190 : :
191 : : !!****f* m_gemm_nonlop_projectors/init_gemm_nonlop
192 : : !! NAME
193 : : !! init_gemm_nonlop
194 : : !!
195 : : !! FUNCTION
196 : : !! Initalization of the gemm_nonlop_kpt array
197 : : !!
198 : : !! INPUTS
199 : : !! nkpt= number of k-points
200 : : !!
201 : : !! SOURCE
202 : 29 : subroutine init_gemm_nonlop(gpu_option)
203 : :
204 : : integer,intent(in) :: gpu_option
205 : :
206 : : ! *************************************************************************
207 : :
208 [ + + ]: 87 : gemm_nonlop_kpt(:)%npw = -1
209 [ + + ]: 87 : gemm_nonlop_kpt(:)%nprojs = -1
210 [ + + ]: 87 : gemm_nonlop_kpt(:)%ngrads = -1
211 [ + + ]: 87 : gemm_nonlop_kpt(:)%ngrads2 = -1
212 [ + + ]: 87 : gemm_nonlop_kpt(:)%choice = -1
213 [ + + ]: 87 : gemm_nonlop_kpt(:)%idir = -1
214 [ + + ]: 87 : gemm_nonlop_kpt(:)%ikpt = -1
215 : :
216 : 29 : if(gpu_option == ABI_GPU_LEGACY .or. gpu_option == ABI_GPU_KOKKOS) then
217 : : #ifdef HAVE_GPU_CUDA
218 : : gemm_nonlop_kpt_gpu(:)%npw = -1
219 : : gemm_nonlop_kpt_gpu(:)%nprojs = -1
220 : : gemm_nonlop_gpu_data % allocated = .false.
221 : : #endif
222 : : end if
223 : :
224 : 29 : gemm_nonlop_block_comm=xmpi_comm_null
225 : 29 : gemm_nonlop_block_size=0
226 : 29 : gemm_nonlop_nblocks=1
227 : 29 : gemm_nonlop_gpu_option=gpu_option
228 : :
229 : 29 : end subroutine init_gemm_nonlop
230 : : !!***
231 : :
232 : : !----------------------------------------------------------------------
233 : :
234 : : !!****f* m_gemm_nonlop_projectors/destroy_gemm_nonlop
235 : : !! NAME
236 : : !! destroy_gemm_nonlop
237 : : !!
238 : : !! FUNCTION
239 : : !! Destruction of the gemm_nonlop_kpt array
240 : : !!
241 : : !! INPUTS
242 : : !! nkpt= number of k-points
243 : : !!
244 : : !! SOURCE
245 : 29 : subroutine destroy_gemm_nonlop(gpu_option)
246 : :
247 : : integer,intent(in) :: gpu_option
248 : :
249 : : ! *************************************************************************
250 : :
251 : 29 : call free_gemm_nonlop_ikpt(1,gpu_option)
252 : 29 : call free_gemm_nonlop_ikpt(2,gpu_option)
253 : 29 : call destroy_work_arrays(gpu_option)
254 [ - + ]: 29 : if(gemm_nonlop_block_comm/=xmpi_comm_null) call xmpi_comm_free(gemm_nonlop_block_comm)
255 : :
256 : 29 : end subroutine destroy_gemm_nonlop
257 : : !!***
258 : :
259 : : !----------------------------------------------------------------------
260 : :
261 : : !!****f* m_gemm_nonlop_projectors/alloc_work_arrays
262 : : !! NAME
263 : : !! alloc_work_arrays
264 : : !!
265 : : !! FUNCTION
266 : : !! Allocation of work arrays
267 : : !!
268 : : !! INPUTS
269 : : !! gpu_option = which GPU code path is used
270 : : !!
271 : : !! SOURCE
272 : 1120 : subroutine alloc_work_arrays(lmnmax,npw,ndprojs,nd2projs,gpu_option)
273 : :
274 : : integer,intent(in) :: lmnmax,npw,ndprojs,nd2projs,gpu_option
275 : :
276 : : ! *************************************************************************
277 : :
278 : : !FIXME Would be nice to not allocate/reallocate at each call, but it seem troublesome in practice
279 : : !if(mod__lmnmax>=lmnmax .and. mod__npw>=npw .and. mod__ndprojs>=ndprojs .and. mod__nd2projs>=nd2projs) then
280 : : ! return ! Nothing to do
281 : : !end if
282 : :
283 : 1120 : call destroy_work_arrays(gpu_option)
284 : :
285 [ - + + - : 4480 : ABI_MALLOC(atom_projs, (2, npw, lmnmax))
- + + - +
- + - - +
- + - + ]
286 [ - + + - : 3360 : ABI_MALLOC(scal, (lmnmax))
+ - + - -
+ - + -
+ ]
287 [ - + + - : 2240 : ABI_MALLOC(lmn_parity, (lmnmax))
- + - + -
+ ]
288 : : #ifdef HAVE_OPENMP_OFFLOAD
289 : : !$OMP TARGET ENTER DATA MAP(alloc:atom_projs,scal,lmn_parity) IF(gpu_option==ABI_GPU_OPENMP)
290 : : #endif
291 : :
292 [ + + ]: 1120 : if(ndprojs>0) then
293 [ - + + - : 1060 : ABI_MALLOC(atom_dprojs, (2, npw, ndprojs, lmnmax))
- + + - -
+ + - + -
+ - - + -
+ - + ]
294 : : #ifdef HAVE_OPENMP_OFFLOAD
295 : : !$OMP TARGET ENTER DATA MAP(alloc:atom_dprojs) IF(gpu_option==ABI_GPU_OPENMP)
296 : : #endif
297 : : end if
298 : :
299 [ - + ]: 1120 : if(nd2projs>0) then
300 [ # # # # : 0 : ABI_MALLOC(atom_d2projs, (2, npw, nd2projs, lmnmax))
# # # # #
# # # # #
# # # # #
# # # ]
301 : : #ifdef HAVE_OPENMP_OFFLOAD
302 : : !$OMP TARGET ENTER DATA MAP(alloc:atom_d2projs) IF(gpu_option==ABI_GPU_OPENMP)
303 : : #endif
304 : : end if
305 : :
306 : 1120 : mod__lmnmax=lmnmax
307 : 1120 : mod__npw=npw
308 : 1120 : mod__ndprojs=ndprojs
309 : 1120 : mod__nd2projs=nd2projs
310 : :
311 : 1120 : end subroutine alloc_work_arrays
312 : : !!***
313 : :
314 : : !----------------------------------------------------------------------
315 : :
316 : : !!****f* m_gemm_nonlop_projectors/destroy_work_arrays
317 : : !! NAME
318 : : !! destroy_work_arrays
319 : : !!
320 : : !! FUNCTION
321 : : !! Destruction of work arrays
322 : : !!
323 : : !! INPUTS
324 : : !! gpu_option = which GPU code path is used
325 : : !!
326 : : !! SOURCE
327 : 1149 : subroutine destroy_work_arrays(gpu_option)
328 : :
329 : : integer,intent(in) :: gpu_option
330 : :
331 : : ! *************************************************************************
332 : : ABI_UNUSED((/gpu_option/))
333 : :
334 [ + + ]: 1149 : if(allocated(atom_projs)) then
335 : : #ifdef HAVE_OPENMP_OFFLOAD
336 : : !$OMP TARGET EXIT DATA MAP(delete:atom_projs) IF(gpu_option==ABI_GPU_OPENMP)
337 : : #endif
338 : 1120 : ABI_FREE(atom_projs)
339 : : end if
340 [ + + ]: 1149 : if(allocated(atom_dprojs)) then
341 : : #ifdef HAVE_OPENMP_OFFLOAD
342 : : !$OMP TARGET EXIT DATA MAP(delete:atom_dprojs) IF(gpu_option==ABI_GPU_OPENMP)
343 : : #endif
344 : 212 : ABI_FREE(atom_dprojs)
345 : : end if
346 [ - + ]: 1149 : if(allocated(atom_d2projs)) then
347 : : #ifdef HAVE_OPENMP_OFFLOAD
348 : : !$OMP TARGET EXIT DATA MAP(delete:atom_d2projs) IF(gpu_option==ABI_GPU_OPENMP)
349 : : #endif
350 : 0 : ABI_FREE(atom_d2projs)
351 : : end if
352 [ + + ]: 1149 : if(allocated(scal)) then
353 : : #ifdef HAVE_OPENMP_OFFLOAD
354 : : !$OMP TARGET EXIT DATA MAP(delete:scal) IF(gpu_option==ABI_GPU_OPENMP)
355 : : #endif
356 : 1120 : ABI_FREE(scal)
357 : : end if
358 [ + + ]: 1149 : if(allocated(lmn_parity)) then
359 : : #ifdef HAVE_OPENMP_OFFLOAD
360 : : !$OMP TARGET EXIT DATA MAP(delete:lmn_parity) IF(gpu_option==ABI_GPU_OPENMP)
361 : : #endif
362 : 1120 : ABI_FREE(lmn_parity)
363 : : end if
364 : 1149 : mod__lmnmax=0
365 : 1149 : mod__npw=0
366 : 1149 : mod__ndprojs=0
367 : 1149 : mod__nd2projs=0
368 : :
369 : 1149 : end subroutine destroy_work_arrays
370 : : !!***
371 : :
372 : : !----------------------------------------------------------------------
373 : :
374 : : !!****f* m_gemm_nonlop_projectors/free_gemm_nonlop_ikpt
375 : : !! NAME
376 : : !! free_destroy_gemm_nonlop_ikpt
377 : : !!
378 : : !! FUNCTION
379 : : !! Release memory for one kpt value of the gemm_nonlop_kpt array
380 : : !!
381 : : !! INPUTS
382 : : !! ikpt= index of gemm_nonlop_kptto be released
383 : : !!
384 : : !! SOURCE
385 : 1430 : subroutine free_gemm_nonlop_ikpt(ik, gpu_option)
386 : :
387 : : integer,intent(in) :: ik, gpu_option
388 : :
389 : : ! *************************************************************************
390 : :
391 : : if(gpu_option == ABI_GPU_LEGACY .or. gpu_option == ABI_GPU_KOKKOS) then
392 : : #ifdef HAVE_GPU_CUDA
393 : : if(gemm_nonlop_kpt_gpu(ik)%nprojs /= -1) then
394 : : ! deallocate arrays projs, projs_r and projs_i
395 : : if (allocated(gemm_nonlop_kpt(ik)%projs)) then
396 : : call dealloc_on_gpu(gemm_nonlop_kpt_gpu(ik)%projs)
397 : : end if
398 : : if (allocated(gemm_nonlop_kpt(ik)%projs_r)) then
399 : : call dealloc_on_gpu(gemm_nonlop_kpt_gpu(ik)%projs_r)
400 : : end if
401 : : if (allocated(gemm_nonlop_kpt(ik)%projs_i)) then
402 : : call dealloc_on_gpu(gemm_nonlop_kpt_gpu(ik)%projs_i)
403 : : end if
404 : : gemm_nonlop_kpt_gpu(ik)%nprojs = -1
405 : : gemm_nonlop_kpt_gpu(ik)%npw = -1
406 : : end if
407 : : #endif
408 : : end if
409 : :
410 : : if(gpu_option == ABI_GPU_OPENMP) then
411 : : #ifdef HAVE_OPENMP_OFFLOAD
412 : : call free_ompgpu_current_ikpt(ik)
413 : : #endif
414 : : end if
415 : :
416 [ + + ]: 1430 : if(gemm_nonlop_kpt(ik)%nprojs /= -1) then
417 [ + + ]: 1372 : if (allocated(gemm_nonlop_kpt(ik)%projs)) then
418 : 1086 : ABI_FREE(gemm_nonlop_kpt(ik)%projs)
419 : : end if
420 [ + + ]: 1372 : if (allocated(gemm_nonlop_kpt(ik)%projs_r)) then
421 : 286 : ABI_FREE(gemm_nonlop_kpt(ik)%projs_r)
422 : : end if
423 [ + + ]: 1372 : if (allocated(gemm_nonlop_kpt(ik)%projs_i)) then
424 : 286 : ABI_FREE(gemm_nonlop_kpt(ik)%projs_i)
425 : : end if
426 : 1372 : gemm_nonlop_kpt(ik)%nprojs = -1
427 [ + + ]: 1372 : if(gemm_nonlop_kpt(ik)%ngrads /= -1) then
428 [ + + ]: 108 : if (allocated(gemm_nonlop_kpt(ik)%dprojs)) then
429 : 87 : ABI_FREE(gemm_nonlop_kpt(ik)%dprojs)
430 : : end if
431 [ + + ]: 108 : if (allocated(gemm_nonlop_kpt(ik)%dprojs_r)) then
432 : 21 : ABI_FREE(gemm_nonlop_kpt(ik)%dprojs_r)
433 : : end if
434 [ + + ]: 108 : if (allocated(gemm_nonlop_kpt(ik)%dprojs_i)) then
435 : 21 : ABI_FREE(gemm_nonlop_kpt(ik)%dprojs_i)
436 : : end if
437 : 108 : gemm_nonlop_kpt(ik)%ngrads = -1
438 : : end if
439 [ - + ]: 1372 : if(gemm_nonlop_kpt(ik)%ngrads2 /= -1) then
440 [ # # ]: 0 : if (allocated(gemm_nonlop_kpt(ik)%d2projs)) then
441 : 0 : ABI_FREE(gemm_nonlop_kpt(ik)%d2projs)
442 : : end if
443 : 0 : gemm_nonlop_kpt(ik)%ngrads2 = -1
444 : : end if
445 : : end if
446 : 1430 : gemm_nonlop_kpt(ik)%choice = -1
447 : 1430 : gemm_nonlop_kpt(ik)%idir = -1
448 : 1430 : gemm_nonlop_kpt(ik)%ikpt = -1
449 : :
450 [ - + ]: 1430 : if(gemm_nonlop_is_distributed) then
451 : 0 : gemm_nonlop_kpt(ik)%nprojs_blk = -1
452 : 0 : gemm_nonlop_kpt(ik)%nprojs_last_blk = -1
453 : : end if
454 : :
455 : 1430 : end subroutine free_gemm_nonlop_ikpt
456 : : !!***
457 : :
458 : : !----------------------------------------------------------------------
459 : :
460 : : subroutine free_ompgpu_current_ikpt(ik)
461 : :
462 : : integer,intent(in) :: ik
463 : :
464 : : #ifdef HAVE_OPENMP_OFFLOAD
465 : :
466 : : call free_ompgpu_current_ikpt_projs(ik)
467 : : call free_ompgpu_current_ikpt_dprojs(ik)
468 : :
469 : : #else
470 : : ABI_UNUSED((/ik/))
471 : : #endif
472 : : end subroutine free_ompgpu_current_ikpt
473 : :
474 : : !----------------------------------------------------------------------
475 : :
476 : : subroutine free_ompgpu_current_ikpt_projs(ik)
477 : :
478 : : integer,intent(in) :: ik
479 : : #ifdef HAVE_OPENMP_OFFLOAD
480 : :
481 : : if(xomp_target_is_present(c_loc(gemm_nonlop_kpt(ik)%projs))) then
482 : : call ompgpu_exit_map(gemm_nonlop_kpt(ik)%projs)
483 : : end if
484 : : if(xomp_target_is_present(c_loc(gemm_nonlop_kpt(ik)%projs_r))) then
485 : : call ompgpu_exit_map(gemm_nonlop_kpt(ik)%projs_r)
486 : : call ompgpu_exit_map(gemm_nonlop_kpt(ik)%projs_i)
487 : : end if
488 : :
489 : : #else
490 : : ABI_UNUSED((/ik/))
491 : : #endif
492 : : #ifdef HAVE_OPENMP_OFFLOAD
493 : : contains
494 : : ! This deallocation helper exist to circumvent issues
495 : : ! on compilers that have trouble handling with derived types.
496 : : subroutine ompgpu_exit_map(gemm_nonlop_projs)
497 : : real(dp),intent(inout) :: gemm_nonlop_projs(:,:,:)
498 : : !$OMP TARGET EXIT DATA MAP(delete:gemm_nonlop_projs)
499 : : end subroutine ompgpu_exit_map
500 : : #endif
501 : : end subroutine free_ompgpu_current_ikpt_projs
502 : :
503 : : !----------------------------------------------------------------------
504 : :
505 : :
506 : : subroutine free_ompgpu_current_ikpt_dprojs(ik)
507 : :
508 : : integer,intent(in) :: ik
509 : : #ifdef HAVE_OPENMP_OFFLOAD
510 : :
511 : : if(xomp_target_is_present(c_loc(gemm_nonlop_kpt(ik)%dprojs))) then
512 : : call ompgpu_exit_map(gemm_nonlop_kpt(ik)%dprojs)
513 : : end if
514 : : if(xomp_target_is_present(c_loc(gemm_nonlop_kpt(ik)%dprojs_i))) then
515 : : call ompgpu_exit_map(gemm_nonlop_kpt(ik)%dprojs_r)
516 : : call ompgpu_exit_map(gemm_nonlop_kpt(ik)%dprojs_i)
517 : : end if
518 : :
519 : : if(xomp_target_is_present(c_loc(gemm_nonlop_kpt(ik)%d2projs))) then
520 : : call ompgpu_exit_map(gemm_nonlop_kpt(ik)%d2projs)
521 : : end if
522 : :
523 : : #else
524 : : ABI_UNUSED((/ik/))
525 : : #endif
526 : : #ifdef HAVE_OPENMP_OFFLOAD
527 : : contains
528 : : ! This deallocation helper exist to circumvent issues
529 : : ! on compilers that have trouble handling with derived types.
530 : : subroutine ompgpu_exit_map(gemm_nonlop_projs)
531 : : real(dp),intent(inout) :: gemm_nonlop_projs(:,:,:)
532 : : !$OMP TARGET EXIT DATA MAP(delete:gemm_nonlop_projs)
533 : : end subroutine ompgpu_exit_map
534 : : #endif
535 : : end subroutine free_ompgpu_current_ikpt_dprojs
536 : :
537 : : !----------------------------------------------------------------------
538 : :
539 : : !!****f* m_gemm_nonlop_projectors/set_gemm_nonlop_ikpt
540 : : !! NAME
541 : : !! set_gemm_nonlop_ikpt
542 : : !!
543 : : !! FUNCTION
544 : : !! Set the K-point upon which projectors will be computed and
545 : : !! pre-allocate projectors buffers.
546 : : !!
547 : : !! INPUTS
548 : : !! ikpt= K-point id
549 : : !! npw= number of plane-wave
550 : : !! istwf_k=option parameter that describes the storage of wfs
551 : : !! indlmn(6,nlmn)= array giving l,m,n,lm,ln,s for i=lmn
552 : : !! ntypat=number of atoms types
553 : : !! nattyp(ntypat)=number of atoms of each type
554 : : !! gpu_option=which variant of GEMM nonlop is used
555 : : !!
556 : : !! SOURCE
557 [ - + ]: 768 : subroutine set_gemm_nonlop_ikpt(ikpt,npw,istwf_k,indlmn,ntypat,nattyp,gpu_option)
558 : :
559 : : integer,intent(in) :: ikpt,istwf_k,npw,ntypat,gpu_option
560 : : integer,intent(in) :: indlmn(:,:,:), nattyp(ntypat)
561 : :
562 : : integer :: nprojs, itypat
563 : :
564 : : ! *************************************************************************
565 : :
566 : 768 : gemm_nonlop_ikpt_this_proc_being_treated=ikpt
567 : :
568 : 768 : nprojs=0
569 [ + + ]: 1880 : do itypat=1,ntypat
570 [ + + + + ]: 17656 : nprojs = nprojs + count(indlmn(3,:,itypat)>0)*nattyp(itypat)
571 : : end do
572 : : ! Call a "dummy" refresh of projectors buffers
573 : : ! This is mostly a work-around in GPU workloads to ensure there
574 : : ! is a buffer allocated in GPU memory.
575 : 768 : call refresh_projectors(npw,istwf_k,nprojs,0,0,.false.,gpu_option)
576 : :
577 : 768 : end subroutine set_gemm_nonlop_ikpt
578 : : !!***
579 : :
580 : : !!****f* m_gemm_nonlop_projectors/reset_gemm_nonlop
581 : : !! NAME
582 : : !! reset_gemm_nonlop
583 : : !!
584 : : !! FUNCTION
585 : : !! Reset projectors to trigger their recomputation
586 : : !!
587 : : !! INPUTS
588 : : !!
589 : : !! SOURCE
590 : 137 : subroutine reset_gemm_nonlop()
591 : :
592 : : ! *************************************************************************
593 : :
594 [ + + ]: 411 : gemm_nonlop_kpt(:)%ikpt = -1
595 [ + + ]: 411 : gemm_nonlop_kpt(:)%choice = -1
596 [ + + ]: 411 : gemm_nonlop_kpt(:)%idir = -1
597 : :
598 : 137 : end subroutine reset_gemm_nonlop
599 : : !!***
600 : :
601 : : !----------------------------------------------------------------------
602 : :
603 : : !!****f* m_gemm_nonlop_projectors/refresh_projectors
604 : : !! NAME
605 : : !! prep_projectors
606 : : !!
607 : : !! FUNCTION
608 : : !! Check allocation of projectors arrays for GEMM nonlop, and resize them if need be
609 : : !!
610 : : !! INPUTS
611 : : !!
612 : : !! SOURCE
613 : 24960 : subroutine refresh_projectors(npw,istwf_k,nprojs,ndgxdt,nd2gxdt,&
614 : : & is_kprime,gpu_option)
615 : : integer,intent(in) :: npw,istwf_k,nprojs,ndgxdt,nd2gxdt,gpu_option
616 : : logical,intent(in) :: is_kprime
617 : : integer :: ik,rank,nprojs_blk,nprojs_my_blk,nprojs_last_blk,ierr,nprocs
618 : : logical :: is_last_rank
619 : :
620 [ - + ]: 24960 : ik=1; if(is_kprime) ik=2
621 : : if(gemm_nonlop_kpt(ik)%ikpt/=gemm_nonlop_ikpt_this_proc_being_treated &
622 [ + + + - : 24960 : & .or. npw/=gemm_nonlop_kpt(ik)%npw .or. nprojs/=gemm_nonlop_kpt(ik)%nprojs) then
- + ]
623 : 1372 : call free_gemm_nonlop_ikpt(ik, gpu_option)
624 : : end if
625 : :
626 [ - + ]: 24960 : if(gemm_nonlop_is_distributed) then
627 : 0 : nprocs = xmpi_comm_size(xmpi_world)
628 : : ! If split size has changed, reset array and init MPI communicator
629 [ # # # # ]: 0 : if(gemm_nonlop_block_comm==xmpi_comm_null .or. gemm_nonlop_nblocks /= nprocs/gemm_nonlop_block_size) then
630 : 0 : call free_gemm_nonlop_ikpt(ik, gpu_option)
631 [ # # ]: 0 : if(gemm_nonlop_block_comm/=xmpi_comm_null) call xmpi_comm_free(gemm_nonlop_block_comm)
632 : 0 : rank = xmpi_comm_rank(xmpi_world);
633 : 0 : gemm_nonlop_nblocks=nprocs/gemm_nonlop_block_size
634 : 0 : write(std_out,'(A,I3,A,I3,A)') "Splitting GEMM nonlop projectors on ",&
635 : 0 : & gemm_nonlop_nblocks, " blocks of ", gemm_nonlop_block_size, " MPI tasks..."
636 : 0 : call xmpi_comm_split(xmpi_world, rank/gemm_nonlop_block_size, rank, gemm_nonlop_block_comm, ierr)
637 [ # # ]: 0 : if(ierr/=0) ABI_BUG("MPI_comm_split failed!")
638 : : end if
639 : : end if
640 : :
641 : 24960 : nprojs_last_blk = nprojs
642 : 24960 : nprojs_my_blk = nprojs
643 : 24960 : nprojs_blk = nprojs
644 : 24960 : rank = 0; is_last_rank = .true.
645 : :
646 [ - + ]: 24960 : if(gemm_nonlop_block_size > 1) then
647 : 0 : nprojs_blk = nprojs / gemm_nonlop_block_size
648 : 0 : nprojs_last_blk = nprojs_blk + modulo(nprojs,nprojs_blk)
649 : :
650 [ # # ]: 0 : if(gemm_nonlop_is_distributed) then
651 : 0 : rank = xmpi_comm_rank(gemm_nonlop_block_comm);
652 : 0 : is_last_rank = (rank==gemm_nonlop_block_size-1)
653 : : if(is_last_rank) then
654 : 24960 : nprojs_my_blk = nprojs_last_blk
655 : : else
656 : 0 : nprojs_my_blk = nprojs_blk
657 : : end if
658 : : end if
659 : : end if
660 : :
661 : :
662 : : ! Allocation of buffers for 1st and 2nd order derivatives of projectors
663 : : ! NOTE: those are allocated, if needed, before regular projectors buffers
664 : : ! for optimization purposes, regarding GPU memory pool.
665 [ + - ]: 24960 : if(nprojs>0) then
666 [ + + ]: 24960 : if(ndgxdt>0) then
667 : : if(npw/=gemm_nonlop_kpt(ik)%npw .or. nprojs/=gemm_nonlop_kpt(ik)%nprojs &
668 [ + - + + : 424 : & .or. ndgxdt /= gemm_nonlop_kpt(ik)%ngrads .or. nd2gxdt /= gemm_nonlop_kpt(ik)%ngrads2) then
- + - - ]
669 : : if(gpu_option == ABI_GPU_OPENMP) call free_ompgpu_current_ikpt_dprojs(ik)
670 [ + + ]: 424 : ABI_SFREE(gemm_nonlop_kpt(ik)%dprojs)
671 [ + + ]: 424 : ABI_SFREE(gemm_nonlop_kpt(ik)%dprojs_r)
672 [ + + ]: 424 : ABI_SFREE(gemm_nonlop_kpt(ik)%dprojs_i)
673 [ - + ]: 424 : ABI_SFREE(gemm_nonlop_kpt(ik)%d2projs)
674 : 424 : gemm_nonlop_kpt(ik)%ngrads = -1
675 : 424 : gemm_nonlop_kpt(ik)%ngrads2 = -1
676 : :
677 [ + + ]: 424 : if(istwf_k <= 1) then
678 [ - + + - : 1216 : ABI_MALLOC(gemm_nonlop_kpt(ik)%dprojs, (2, npw, nprojs_last_blk*ndgxdt))
- + + - +
- + - - +
- + - + ]
679 [ - + ]: 304 : if(nd2gxdt>0) then
680 [ # # # # : 0 : ABI_MALLOC(gemm_nonlop_kpt(ik)%d2projs, (2, npw, nprojs_last_blk*nd2gxdt))
# # # # #
# # # # #
# # # # ]
681 : : end if
682 : : else
683 [ - + + - : 480 : ABI_MALLOC(gemm_nonlop_kpt(ik)%dprojs_r, (1, npw, nprojs_last_blk*ndgxdt))
- + + - +
- + - - +
- + - + ]
684 [ - + + - : 360 : ABI_MALLOC(gemm_nonlop_kpt(ik)%dprojs_i, (1, npw, nprojs_last_blk*ndgxdt))
- + + - -
+ - + -
+ ]
685 : : end if
686 : : #ifdef HAVE_OPENMP_OFFLOAD
687 : : if(gpu_option == ABI_GPU_OPENMP) then
688 : : if(istwf_k <= 1) then
689 : : call ompgpu_map_dprojs(gemm_nonlop_kpt(ik)%dprojs)
690 : : if(nd2gxdt>0) then
691 : : call ompgpu_map_d2projs(gemm_nonlop_kpt(ik)%d2projs)
692 : : end if
693 : : else
694 : : call ompgpu_map_dprojs_r(gemm_nonlop_kpt(ik)%dprojs_r)
695 : : call ompgpu_map_dprojs_i(gemm_nonlop_kpt(ik)%dprojs_i)
696 : : end if
697 : : end if
698 : : #endif
699 : : end if
700 : : end if
701 : :
702 : :
703 : : ! Allocation of projectors buffers
704 [ + + + + ]: 24960 : if(npw/=gemm_nonlop_kpt(ik)%npw .or. nprojs/=gemm_nonlop_kpt(ik)%nprojs) then
705 [ + + ]: 1372 : if(istwf_k <= 1) then
706 [ - + + - : 4344 : ABI_MALLOC(gemm_nonlop_kpt(ik)%projs, (2, npw, nprojs_last_blk))
- + + - +
- + - - +
- + - + ]
707 : : else
708 [ - + + - : 1144 : ABI_MALLOC(gemm_nonlop_kpt(ik)%projs_r, (1, npw, nprojs_last_blk))
- + + - +
- + - - +
- + - + ]
709 [ - + + - : 858 : ABI_MALLOC(gemm_nonlop_kpt(ik)%projs_i, (1, npw, nprojs_last_blk))
- + + - -
+ - + -
+ ]
710 : : end if
711 : :
712 : : #ifdef HAVE_OPENMP_OFFLOAD
713 : : if(gpu_option == ABI_GPU_OPENMP) then
714 : : if(istwf_k <= 1) then
715 : : call ompgpu_map_projs(gemm_nonlop_kpt(ik)%projs)
716 : : else
717 : : call ompgpu_map_projs_r(gemm_nonlop_kpt(ik)%projs_r)
718 : : call ompgpu_map_projs_i(gemm_nonlop_kpt(ik)%projs_i)
719 : : end if
720 : : end if
721 : : #endif
722 : : end if
723 : : end if
724 : :
725 : :
726 [ + - ]: 24960 : if (nprojs>0) gemm_nonlop_kpt(ik)%nprojs = nprojs
727 [ + - ]: 24960 : if (nprojs>0) gemm_nonlop_kpt(ik)%npw = npw
728 [ + + ]: 24960 : if (ndgxdt>0) gemm_nonlop_kpt(ik)%ngrads = ndgxdt
729 [ - + ]: 24960 : if (nd2gxdt>0) gemm_nonlop_kpt(ik)%ngrads2 = nd2gxdt
730 [ - + ]: 24960 : if(gemm_nonlop_block_size > 1) then
731 [ # # ]: 0 : if(nprojs_blk>0) gemm_nonlop_kpt(ik)%nprojs_blk = nprojs_blk
732 [ # # ]: 0 : if(nprojs_last_blk>0) gemm_nonlop_kpt(ik)%nprojs_last_blk = nprojs_last_blk
733 : : end if
734 : :
735 : : !!!!! CUDA stuff
736 : : if(gpu_option == ABI_GPU_LEGACY .or. gpu_option == ABI_GPU_KOKKOS) then
737 : : #ifdef HAVE_GPU_CUDA
738 : : if(gemm_nonlop_kpt_gpu(ik)%nprojs==-1) then
739 : : gemm_nonlop_kpt_gpu(ik)%npw = npw
740 : : gemm_nonlop_kpt_gpu(ik)%nprojs = nprojs
741 : :
742 : : #ifdef DEBUG_VERBOSE_GPU
743 : : if(xmpi_comm_rank(xmpi_world) == 0) then
744 : : call check_gpu_mem("refresh_projectors begin")
745 : : call wrtout(std_out,sjoin(" npw .......", itoa(npw)), 'COLL')
746 : : call wrtout(std_out,sjoin(" nprojs .......", itoa(nprojs)), 'COLL')
747 : : end if
748 : : #endif
749 : :
750 : : if(istwf_k <= 1) then
751 : : call alloc_on_gpu(gemm_nonlop_kpt_gpu(ik)%projs, INT(2,c_size_t)*npw*nprojs*dp)
752 : : ! TODO : gradients
753 : : else
754 : : call alloc_on_gpu(gemm_nonlop_kpt_gpu(ik)%projs_r, INT(1, c_size_t)*npw*nprojs*dp)
755 : : call alloc_on_gpu(gemm_nonlop_kpt_gpu(ik)%projs_i, INT(1, c_size_t)*npw*nprojs*dp)
756 : : ! TODO : gradients
757 : : end if
758 : :
759 : : #ifdef DEBUG_VERBOSE_GPU
760 : : if(xmpi_comm_rank(xmpi_world) == 0) then
761 : : call check_gpu_mem("refresh_projectors end ")
762 : : end if
763 : : #endif
764 : : end if
765 : :
766 : : #endif
767 : : end if
768 : : #ifdef HAVE_OPENMP_OFFLOAD
769 : : contains
770 : : ! Those allocations helpers exist to circumvent issues
771 : : ! on compilers that have trouble handling with derived types.
772 : : ! One subroutine for each so arrays are named accordingly
773 : : ! in debug dumps.
774 : : subroutine ompgpu_map_projs(gemm_nonlop_projs)
775 : : real(dp),intent(inout) :: gemm_nonlop_projs(:,:,:)
776 : : !$OMP TARGET ENTER DATA MAP(alloc:gemm_nonlop_projs)
777 : : end subroutine ompgpu_map_projs
778 : :
779 : : subroutine ompgpu_map_projs_r(gemm_nonlop_projs_r)
780 : : real(dp),intent(inout) :: gemm_nonlop_projs_r(:,:,:)
781 : : !$OMP TARGET ENTER DATA MAP(alloc:gemm_nonlop_projs_r)
782 : : end subroutine ompgpu_map_projs_r
783 : :
784 : : subroutine ompgpu_map_projs_i(gemm_nonlop_projs_i)
785 : : real(dp),intent(inout) :: gemm_nonlop_projs_i(:,:,:)
786 : : !$OMP TARGET ENTER DATA MAP(alloc:gemm_nonlop_projs_i)
787 : : end subroutine ompgpu_map_projs_i
788 : :
789 : : subroutine ompgpu_map_dprojs(gemm_nonlop_dprojs)
790 : : real(dp),intent(inout) :: gemm_nonlop_dprojs(:,:,:)
791 : : !$OMP TARGET ENTER DATA MAP(alloc:gemm_nonlop_dprojs)
792 : : end subroutine ompgpu_map_dprojs
793 : :
794 : : subroutine ompgpu_map_dprojs_r(gemm_nonlop_dprojs_r)
795 : : real(dp),intent(inout) :: gemm_nonlop_dprojs_r(:,:,:)
796 : : !$OMP TARGET ENTER DATA MAP(alloc:gemm_nonlop_dprojs_r)
797 : : end subroutine ompgpu_map_dprojs_r
798 : :
799 : : subroutine ompgpu_map_dprojs_i(gemm_nonlop_dprojs_i)
800 : : real(dp),intent(inout) :: gemm_nonlop_dprojs_i(:,:,:)
801 : : !$OMP TARGET ENTER DATA MAP(alloc:gemm_nonlop_dprojs_i)
802 : : end subroutine ompgpu_map_dprojs_i
803 : :
804 : : subroutine ompgpu_map_d2projs(gemm_nonlop_d2projs)
805 : : real(dp),intent(inout) :: gemm_nonlop_d2projs(:,:,:)
806 : : !$OMP TARGET ENTER DATA MAP(alloc:gemm_nonlop_d2projs)
807 : : end subroutine ompgpu_map_d2projs
808 : : #endif
809 : 24960 : end subroutine refresh_projectors
810 : : !!***
811 : :
812 : : !----------------------------------------------------------------------
813 : :
814 : : !!****f* m_gemm_nonlop_projectors/prep_projectors
815 : : !! NAME
816 : : !! prep_projectors
817 : : !!
818 : : !! FUNCTION
819 : : !! Prepare projectors array for GEMM nonlop (choice=={0,1})
820 : : !!
821 : : !! INPUTS
822 : : !!
823 : : !! SOURCE
824 : 696 : subroutine prep_projectors(npw,lmnmax,ntypat,indlmn,nattyp,istwf_k,&
825 : 696 : & ucvol,ffnl,ph3d,dimffnl,matblk,&
826 : : & nprojs,is_kprime,gpu_option,&
827 : : & iblock)
828 : :
829 : : integer, intent(in) :: npw,lmnmax,ntypat,dimffnl,matblk
830 : : integer, intent(in) :: istwf_k
831 : : integer, intent(in) :: nprojs,gpu_option,iblock
832 : : logical, intent(in) :: is_kprime
833 : : real(dp), intent(in) :: ucvol
834 : : ! arrays
835 : : integer, intent(in) :: indlmn(6,lmnmax,ntypat),nattyp(ntypat)
836 : : real(dp),intent(in),target :: ffnl(npw,dimffnl,lmnmax,ntypat)
837 : : real(dp),intent(in),target :: ph3d(2,npw,matblk)
838 : :
839 : : logical :: map_ffnl,map_ph3d,is_last_rank
840 : : integer :: il, ipw, ik
841 : : integer :: itypat, ilmn, nlmn, ia, iaph3d, shift, nprojs_my_blk
842 : : integer :: lmn_beg,ibeg,iend,shift_do,nlmn_o
843 : : real(dp):: wt
844 : : ! parity_re/parity_im hold the real/imaginary parts of (-i)^l for each ilmn of the
845 : : ! current species: this only depends on itypat, not on the atom index ia.
846 : 1392 : real(dp) :: parity_re(lmnmax), parity_im(lmnmax)
847 : 696 : real(dp), contiguous, pointer :: projs(:,:,:)
848 : 696 : real(dp), contiguous, pointer :: projs_r(:,:,:)
849 : 696 : real(dp), contiguous, pointer :: projs_i(:,:,:)
850 : :
851 : 0 : ik=1; if(is_kprime) ik=2
852 [ + + ]: 696 : if(istwf_k <= 1) then
853 : 551 : projs => gemm_nonlop_kpt(ik)%projs
854 : : else
855 : 145 : projs_r => gemm_nonlop_kpt(ik)%projs_r
856 : 145 : projs_i => gemm_nonlop_kpt(ik)%projs_i
857 : : end if
858 : :
859 [ - + ]: 696 : if(gpu_option==ABI_GPU_OPENMP) then
860 : :
861 [ # # ]: 0 : if(istwf_k <= 1) then
862 : 0 : call gpu_set_to_zero(projs,int(2,c_size_t)*npw*nprojs)
863 : : else
864 : 0 : call gpu_set_to_zero(projs_r,int(npw,c_size_t)*nprojs)
865 : 0 : call gpu_set_to_zero(projs_i,int(npw,c_size_t)*nprojs)
866 : : end if
867 : :
868 : : else
869 : :
870 [ + + ]: 696 : if(istwf_k <= 1) then
871 [ + + + + : 330194679 : projs(:,:,:) = zero
+ + ]
872 : : else
873 [ + + + + : 36945149 : projs_r(:,:,:) = zero
+ + ]
874 [ + + + + : 36945149 : projs_i(:,:,:) = zero
+ + ]
875 : : end if
876 : :
877 : : end if
878 : :
879 : 696 : iaph3d = 1
880 : 696 : wt=four_pi/sqrt(ucvol)
881 : :
882 : : ! Allocate atom_projs and other work arrays if need be
883 : 696 : call alloc_work_arrays(lmnmax,npw,-1,-1,gpu_option)
884 : :
885 : 696 : map_ph3d=.false.; map_ffnl=.false.
886 : : #ifdef HAVE_OPENMP_OFFLOAD
887 : : if(.not. xomp_target_is_present(c_loc(ffnl))) map_ffnl = .true.
888 : : if(.not. xomp_target_is_present(c_loc(ph3d))) map_ph3d = .true.
889 : : !$OMP TARGET ENTER DATA MAP(to:ffnl) IF(gpu_option==ABI_GPU_OPENMP .and. map_ffnl)
890 : : !$OMP TARGET ENTER DATA MAP(to:ph3d) IF(gpu_option==ABI_GPU_OPENMP .and. map_ph3d)
891 : : #endif
892 : :
893 : 696 : shift = 0
894 : 696 : lmn_beg = 1
895 : :
896 [ - + ]: 696 : if(gemm_nonlop_block_size > 1) then
897 : 0 : is_last_rank = (iblock==gemm_nonlop_block_size)
898 : 0 : nprojs_my_blk=gemm_nonlop_kpt(ik)%nprojs_blk
899 [ # # ]: 0 : if(is_last_rank) nprojs_my_blk=gemm_nonlop_kpt(ik)%nprojs_last_blk
900 : 0 : ibeg = (iblock-1)*gemm_nonlop_kpt(ik)%nprojs_blk+1
901 : 0 : iend = ibeg+nprojs_my_blk
902 : 0 : shift_do = 0
903 : : end if
904 : :
905 [ + + ]: 1736 : do itypat = 1, ntypat
906 [ + + + + ]: 16240 : nlmn = count(indlmn(3,:,itypat)>0)
907 : : nlmn_o = nlmn
908 : :
909 : : !! build the atom-independent part of atom_projs, from opernlb
910 : : !! P_type = 4pi/sqrt(ucvol) * ffnl * diag(parity), with parity = (-i)^l
911 : : !! This part only depends on itypat (not on the atom index ia), so it is
912 : : !! computed once per species instead of once per atom as before: this
913 : : !! replaces what used to be 4 kernels launched nattyp(itypat) times each
914 : : !! by a single kernel launched once per species.
915 [ + + ]: 14960 : do ilmn=1,nlmn_o
916 : 13920 : il=mod(indlmn(1,ilmn, itypat),4)
917 : 1040 : select case(il)
918 : : case(0)
919 : 2080 : parity_re(ilmn)= one ; parity_im(ilmn)= zero
920 : : case(1)
921 : 6240 : parity_re(ilmn)= zero; parity_im(ilmn)=-one
922 : : case(2)
923 : 5600 : parity_re(ilmn)=-one ; parity_im(ilmn)= zero
924 : : case default ! il==3
925 [ + + + - ]: 13920 : parity_re(ilmn)= zero; parity_im(ilmn)= one
926 : : end select
927 : : end do
928 : :
929 : : #ifdef HAVE_OPENMP_OFFLOAD
930 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(2) &
931 : : !$OMP& PRIVATE(ilmn,ipw) MAP(to:atom_projs,ffnl,parity_re,parity_im) &
932 : : !$OMP& IF(gpu_option==ABI_GPU_OPENMP)
933 : : #endif
934 [ + + ]: 14960 : do ilmn=1,nlmn_o
935 [ + + ]: 31995026 : do ipw=1, npw
936 : 31980066 : atom_projs(1,ipw, ilmn) = wt * ffnl(ipw, 1, ilmn, itypat) * parity_re(ilmn)
937 : 31993986 : atom_projs(2,ipw, ilmn) = wt * ffnl(ipw, 1, ilmn, itypat) * parity_im(ilmn)
938 : : end do
939 : : end do
940 : :
941 [ + + ]: 4224 : do ia = 1, nattyp(itypat)
942 : :
943 : : ! In distributed mode, loops are skipped until reach the section
944 : : ! of "ilmn" to be stored by local rank
945 [ - + ]: 3184 : if(gemm_nonlop_block_size > 1) then
946 [ # # ]: 0 : if(shift_do+nlmn < ibeg) then
947 : 0 : shift_do = shift_do + nlmn
948 : 0 : iaph3d = iaph3d + 1
949 : 0 : cycle
950 : : end if
951 : :
952 : 0 : lmn_beg = max(1,ibeg-shift_do)
953 [ # # ]: 0 : if(shift_do+nlmn > iend - 1) nlmn = iend - shift_do - 1
954 : : end if
955 : :
956 : : !! multiply the (species-only) atom_projs by conj(ph3d) for this atom,
957 : : !! and store the result directly into projs/projs_r/projs_i: this fuses
958 : : !! what used to be two separate kernels (ph3d multiply, then copy) into
959 : : !! a single kernel launched once per atom.
960 [ + - ]: 3184 : if(gpu_option==ABI_GPU_OPENMP) then
961 : : #ifdef HAVE_OPENMP_OFFLOAD
962 : : if(istwf_k <= 1) then
963 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(2) &
964 : : !$OMP& PRIVATE(ipw,ilmn) MAP(to:projs,atom_projs,ph3d)
965 : : do ilmn=1,nlmn-(lmn_beg-1)
966 : : do ipw=1,npw
967 : : projs(1, ipw, shift+ilmn) = atom_projs(1, ipw, ilmn+(lmn_beg-1)) * ph3d(1, ipw, iaph3d) &
968 : : & + atom_projs(2, ipw, ilmn+(lmn_beg-1)) * ph3d(2, ipw, iaph3d)
969 : : projs(2, ipw, shift+ilmn) = atom_projs(2, ipw, ilmn+(lmn_beg-1)) * ph3d(1, ipw, iaph3d) &
970 : : & - atom_projs(1, ipw, ilmn+(lmn_beg-1)) * ph3d(2, ipw, iaph3d)
971 : : end do
972 : : end do
973 : : else ! istwf_k>1
974 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(2) &
975 : : !$OMP& PRIVATE(ipw,ilmn) MAP(to:projs_r,projs_i,atom_projs,ph3d)
976 : : do ilmn=1,nlmn-(lmn_beg-1)
977 : : do ipw=1,npw
978 : : projs_r(1, ipw, shift+ilmn) = atom_projs(1, ipw, ilmn+(lmn_beg-1)) * ph3d(1, ipw, iaph3d) &
979 : : & + atom_projs(2, ipw, ilmn+(lmn_beg-1)) * ph3d(2, ipw, iaph3d)
980 : : projs_i(1, ipw, shift+ilmn) = atom_projs(2, ipw, ilmn+(lmn_beg-1)) * ph3d(1, ipw, iaph3d) &
981 : : & - atom_projs(1, ipw, ilmn+(lmn_beg-1)) * ph3d(2, ipw, iaph3d)
982 : : end do
983 : : end do
984 : : end if
985 : : #endif
986 : : else
987 [ + + ]: 3184 : if(istwf_k <= 1) then
988 [ + + ]: 34634 : do ilmn=1,nlmn-(lmn_beg-1)
989 : : projs(1, :, shift+ilmn) = atom_projs(1, :, ilmn+(lmn_beg-1)) * ph3d(1, :, iaph3d) &
990 [ + - + + : 220140148 : & + atom_projs(2, :, ilmn+(lmn_beg-1)) * ph3d(2, :, iaph3d)
+ + ]
991 : : projs(2, :, shift+ilmn) = atom_projs(2, :, ilmn+(lmn_beg-1)) * ph3d(1, :, iaph3d) &
992 [ + + + + ]: 220142594 : & - atom_projs(1, :, ilmn+(lmn_beg-1)) * ph3d(2, :, iaph3d)
993 : : end do
994 : : else ! istwf_k>1
995 [ + + ]: 11142 : do ilmn=1,nlmn-(lmn_beg-1)
996 : : projs_r(1, :, shift+ilmn) = atom_projs(1, :, ilmn+(lmn_beg-1)) * ph3d(1, :, iaph3d) &
997 [ + - + + : 36945004 : & + atom_projs(2, :, ilmn+(lmn_beg-1)) * ph3d(2, :, iaph3d)
+ + ]
998 : : projs_i(1, :, shift+ilmn) = atom_projs(2, :, ilmn+(lmn_beg-1)) * ph3d(1, :, iaph3d) &
999 [ + + + + ]: 36945742 : & - atom_projs(1, :, ilmn+(lmn_beg-1)) * ph3d(2, :, iaph3d)
1000 : : end do
1001 : : end if
1002 : : end if
1003 : :
1004 : 3184 : iaph3d = iaph3d + 1
1005 [ - + ]: 4224 : if(gemm_nonlop_block_size > 1) then
1006 : 0 : shift = shift + nlmn - (lmn_beg-1)
1007 : 0 : shift_do = shift_do + nlmn
1008 [ # # ]: 0 : if(shift_do >= iend - 1) exit
1009 : : else
1010 : 3184 : shift = shift + nlmn
1011 : : end if
1012 : : end do
1013 [ - + - - ]: 1736 : if(gemm_nonlop_block_size > 1 .and. shift_do >= iend - 1) exit
1014 : : end do
1015 : :
1016 : :
1017 : : !!!!! CUDA stuff
1018 : : if(gpu_option == ABI_GPU_LEGACY .or. gpu_option == ABI_GPU_KOKKOS) then
1019 : : #ifdef HAVE_GPU_CUDA
1020 : : ! upload data to gpu memory
1021 : : if(istwf_k <= 1) then
1022 : : call copy_on_gpu(gemm_nonlop_kpt(ik)%projs, gemm_nonlop_kpt_gpu(ik)%projs, INT(2, c_size_t)*npw*nprojs*dp)
1023 : : ! TODO : gradients
1024 : : else
1025 : : call copy_on_gpu(gemm_nonlop_kpt(ik)%projs_r, gemm_nonlop_kpt_gpu(ik)%projs_r, &
1026 : : & INT(1, c_size_t)*npw*nprojs*dp)
1027 : : call copy_on_gpu(gemm_nonlop_kpt(ik)%projs_i, gemm_nonlop_kpt_gpu(ik)%projs_i, &
1028 : : & INT(1, c_size_t)*npw*nprojs*dp)
1029 : : end if
1030 : : #endif
1031 : : end if
1032 : :
1033 : : #ifdef HAVE_OPENMP_OFFLOAD
1034 : : !$OMP TARGET EXIT DATA MAP(delete:ffnl) IF(gpu_option==ABI_GPU_OPENMP .and. map_ffnl)
1035 : : !$OMP TARGET EXIT DATA MAP(delete:ph3d) IF(gpu_option==ABI_GPU_OPENMP .and. map_ph3d)
1036 : : #endif
1037 : :
1038 [ - + ]: 696 : end subroutine prep_projectors
1039 : : !!***
1040 : :
1041 : : !----------------------------------------------------------------------
1042 : :
1043 : : !!****f* m_gemm_nonlop_projectors/prep_dprojectors
1044 : : !! NAME
1045 : : !! prep_projectors
1046 : : !!
1047 : : !! FUNCTION
1048 : : !! Prepare projectors' derivatives for given choice (choice={2,3,4,5,51,54,55})
1049 : : !!
1050 : : !! INPUTS
1051 : : !!
1052 : : !! SOURCE
1053 : 424 : subroutine prep_dprojectors(npw,lmnmax,ntypat,indlmn,nattyp,istwf_k,&
1054 : 424 : & ucvol,ffnl,ph3d,kpg,nkpg,dimffnl,matblk,&
1055 : : & nprojs,ngrads,ngrads2,choice,signs,idir_pert,&
1056 : : & is_kprime,gpu_option,iblock)
1057 : :
1058 : : integer, intent(in) :: npw,lmnmax,ntypat,nkpg,dimffnl,matblk
1059 : : integer, intent(in) :: istwf_k,iblock
1060 : : integer, intent(in) :: nprojs,ngrads,ngrads2,choice,signs,idir_pert,gpu_option
1061 : : logical, intent(in) :: is_kprime
1062 : : real(dp), intent(in) :: ucvol
1063 : : ! arrays
1064 : : integer, intent(in) :: indlmn(6,lmnmax,ntypat),nattyp(ntypat)
1065 : : real(dp), intent(in), target :: ffnl(npw,dimffnl,lmnmax,ntypat)
1066 : : real(dp), intent(in), target :: ph3d(2,npw,matblk)
1067 : : real(dp), intent(in), target :: kpg(npw,nkpg)
1068 : :
1069 : : logical :: map_ffnl,map_ph3d,is_last_rank
1070 : : integer,parameter :: alpha(6)=(/1,2,3,3,3,2/),beta(6)=(/1,2,3,2,1,1/)
1071 : : integer,parameter :: gamma(3,3)=reshape((/1,6,5,6,2,4,5,4,3/),(/3,3/))
1072 : : integer :: ndprojs, nd2projs, ilmn_p, nlmn_p
1073 : : integer :: il, ipw, ik, idir, idir1, idir2, jdir1, jdir2, kdir1, kdir2, ldir1, ldir2, ldir3, ldir4, ffnl_dir
1074 : : integer :: itypat, ilmn, nlmn, ia, iaph3d, igrad, shift, shift_grad, shift_grad2
1075 : : integer :: lmn_beg,ibeg,iend,shift_do,nlmn_o,lmn_grad_beg,nprojs_my_blk
1076 : : real(dp), parameter :: two_pi2=two_pi*two_pi
1077 : : real(dp):: wt,tmp
1078 : 424 : real(dp), contiguous, pointer :: projs (:,:,:) ,dprojs(:,:,:) ,d2projs(:,:,:)
1079 : 424 : real(dp), contiguous, pointer :: projs_r(:,:,:),dprojs_r(:,:,:)
1080 : 424 : real(dp), contiguous, pointer :: projs_i(:,:,:),dprojs_i(:,:,:)
1081 : :
1082 : :
1083 : 0 : ik=1; if(is_kprime) ik=2
1084 [ + + ]: 424 : if(istwf_k <= 1) then
1085 : 304 : projs => gemm_nonlop_kpt(ik)%projs
1086 : 304 : dprojs => gemm_nonlop_kpt(ik)%dprojs
1087 [ - + ]: 304 : if(ngrads2 > 0) then
1088 : 0 : d2projs => gemm_nonlop_kpt(ik)%d2projs
1089 : : end if
1090 : : else
1091 : 120 : projs_r => gemm_nonlop_kpt(ik)%projs_r
1092 : 120 : projs_i => gemm_nonlop_kpt(ik)%projs_i
1093 : 120 : dprojs_r => gemm_nonlop_kpt(ik)%dprojs_r
1094 : 120 : dprojs_i => gemm_nonlop_kpt(ik)%dprojs_i
1095 : : end if
1096 : :
1097 [ - + ]: 424 : if(gpu_option==ABI_GPU_OPENMP) then
1098 : :
1099 [ # # ]: 0 : if(istwf_k <= 1) then
1100 : 0 : call gpu_set_to_zero(dprojs,int(2,c_size_t)*npw*nprojs*ngrads)
1101 [ # # ]: 0 : if(ngrads2 > 0) then
1102 : 0 : call gpu_set_to_zero(d2projs,int(2,c_size_t)*npw*nprojs*ngrads2)
1103 : : end if
1104 : : else
1105 : 0 : call gpu_set_to_zero(dprojs_r,int(npw,c_size_t)*nprojs*ngrads)
1106 : 0 : call gpu_set_to_zero(dprojs_i,int(npw,c_size_t)*nprojs*ngrads)
1107 : : end if
1108 : :
1109 : : else
1110 : :
1111 [ + + ]: 424 : if(istwf_k <= 1) then
1112 [ + + + + : 395458864 : dprojs(:,:,:) = zero
+ + ]
1113 [ - + ]: 304 : if(ngrads2 > 0) then
1114 [ # # # # : 0 : d2projs(:,:,:) = zero
# # ]
1115 : : end if
1116 : : else
1117 [ + + + + : 47384544 : dprojs_r(:,:,:) = zero
+ + ]
1118 [ + + + + : 47384544 : dprojs_i(:,:,:) = zero
+ + ]
1119 : : end if
1120 : :
1121 : : end if
1122 : :
1123 : 424 : iaph3d = 1
1124 : 424 : wt=four_pi/sqrt(ucvol)
1125 [ + - ]: 424 : ffnl_dir=1; if(dimffnl>2) ffnl_dir=idir_pert
1126 : :
1127 : 424 : ndprojs = 0
1128 [ + - + + ]: 424 : if (signs==1 .and. (choice==3 .or. choice==23 .or. choice==54 .or. choice==55 .or. choice==6)) then
1129 : 212 : ndprojs = 3
1130 [ - + - - ]: 212 : else if(signs==2 .and. (choice==5 .or. choice==51 .or. choice==3)) then
1131 : 0 : ndprojs = 1
1132 : : end if
1133 : 424 : nd2projs = 0
1134 [ + - - + ]: 424 : if(signs==1 .and. choice==54) then
1135 : 0 : nd2projs = 3
1136 [ + - - + ]: 424 : else if(signs==1 .and. choice==55) then
1137 : 0 : nd2projs = 6
1138 [ + - - + ]: 424 : else if(signs==1 .and. choice==6) then
1139 : 0 : nd2projs = 10
1140 : : end if
1141 : :
1142 : : ! Allocate atom_projs and other work arrays if need be
1143 : 424 : call alloc_work_arrays(lmnmax,npw,ndprojs,nd2projs,gpu_option)
1144 : :
1145 : 424 : map_ph3d=.false.; map_ffnl=.false.
1146 : 424 : if(.not. xomp_target_is_present(c_loc(ffnl))) map_ffnl = .true.
1147 : 424 : if(.not. xomp_target_is_present(c_loc(ph3d))) map_ph3d = .true.
1148 : : #ifdef HAVE_OPENMP_OFFLOAD
1149 : : !$OMP TARGET ENTER DATA MAP(to:ffnl) IF(gpu_option==ABI_GPU_OPENMP .and. map_ffnl)
1150 : : !$OMP TARGET ENTER DATA MAP(to:ph3d) IF(gpu_option==ABI_GPU_OPENMP .and. map_ph3d)
1151 : : !!$OMP TARGET ENTER DATA MAP(to:kpg) IF(gpu_option==ABI_GPU_OPENMP)
1152 : : #endif
1153 : :
1154 : 424 : shift = 0 ; shift_grad = 0; shift_grad2 = 0
1155 : 424 : lmn_beg = 1
1156 : :
1157 [ - + ]: 424 : if(gemm_nonlop_block_size > 1) then
1158 : 0 : is_last_rank = (iblock==gemm_nonlop_block_size)
1159 : 0 : nprojs_my_blk=gemm_nonlop_kpt(ik)%nprojs_blk
1160 [ # # ]: 0 : if(is_last_rank) nprojs_my_blk=gemm_nonlop_kpt(ik)%nprojs_last_blk
1161 : 0 : ibeg = (iblock-1)*gemm_nonlop_kpt(ik)%nprojs_blk+1
1162 : 0 : iend = ibeg+nprojs_my_blk
1163 : 0 : shift_do = 0
1164 : 0 : lmn_grad_beg = -1
1165 : :
1166 : : end if
1167 : :
1168 [ + + ]: 1136 : do itypat = 1, ntypat
1169 [ + + + + ]: 12168 : nlmn = count(indlmn(3,:,itypat)>0)
1170 : 712 : nlmn_o = nlmn
1171 : :
1172 [ + + ]: 2008 : do ia = 1, nattyp(itypat)
1173 : :
1174 : : ! In distributed mode, loops are skipped until reach the section
1175 : : ! of "ilmn" to be stored by local rank
1176 [ - + ]: 1296 : if(gemm_nonlop_block_size > 1) then
1177 [ # # ]: 0 : if(shift_do+nlmn < ibeg) then
1178 : 0 : shift_do = shift_do + nlmn
1179 : 0 : iaph3d = iaph3d + 1
1180 : 0 : cycle
1181 : : end if
1182 : :
1183 : 0 : lmn_beg = max(1,ibeg-shift_do)
1184 : : if(lmn_grad_beg==-1) lmn_grad_beg = (lmn_beg-1)*ngrads
1185 [ # # ]: 0 : if(shift_do+nlmn > iend - 1) nlmn = iend - shift_do - 1
1186 : : end if
1187 : :
1188 : : !! build atom_dprojs, from opernlb
1189 : : !! P = 4pi/sqrt(ucvol)* conj(diag(ph3d)) * ffnl * diag(parity), with parity = (-i)^l
1190 : :
1191 : : ! start from 4pi/sqrt(ucvol)*ffnl
1192 [ - + ]: 1296 : if(gpu_option==ABI_GPU_OPENMP) then
1193 [ # # ]: 0 : if (ndprojs>0) then
1194 : 0 : call gpu_set_to_zero(atom_dprojs,int(2,c_size_t)*npw*ndprojs*lmnmax)
1195 [ # # ]: 0 : if(ngrads2>0) then
1196 : 0 : call gpu_set_to_zero(atom_d2projs,int(2,c_size_t)*npw*nd2projs*lmnmax)
1197 : : end if
1198 : : end if
1199 : : else
1200 [ + + + + : 186112580 : if (ndprojs>0) atom_dprojs(:,:,:,:) = zero
+ + + + +
+ ]
1201 [ - + - - : 1296 : if (nd2projs>0) atom_d2projs(:,:,:,:) = zero
- - - - -
- ]
1202 : : end if
1203 [ + - + + ]: 1296 : if (signs==1 .and. (choice==3 .or. choice==23 .or. choice==54 .or. choice==55 .or. choice==6)) then
1204 : : #ifdef HAVE_OPENMP_OFFLOAD
1205 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(3) &
1206 : : !$OMP& PRIVATE(ilmn,idir,ipw) MAP(to:atom_dprojs,ffnl) &
1207 : : !$OMP& IF(gpu_option==ABI_GPU_OPENMP)
1208 : : #endif
1209 [ + + ]: 9992 : do ilmn=1,nlmn_o
1210 [ + + ]: 38024 : do idir=1,ndprojs
1211 [ + + ]: 51863912 : do ipw=1, npw
1212 : 51854568 : atom_dprojs(1, ipw, idir, ilmn) = wt * ffnl(ipw, idir+1, ilmn, itypat)
1213 : : end do
1214 : : end do
1215 : : end do
1216 : : end if
1217 [ - + - - ]: 1296 : if (signs==2 .and. (choice==3 .or. choice==5 .or. choice==51)) then
1218 : : #ifdef HAVE_OPENMP_OFFLOAD
1219 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(2) &
1220 : : !$OMP& PRIVATE(ilmn,ipw) MAP(to:atom_dprojs,ffnl) &
1221 : : !$OMP& IF(gpu_option==ABI_GPU_OPENMP)
1222 : : #endif
1223 [ # # ]: 0 : do ilmn=1,nlmn_o
1224 [ - - ]: 1296 : do ipw=1, npw
1225 : 0 : atom_dprojs(1, ipw, 1, ilmn) = wt * ffnl(ipw, 1+ffnl_dir, ilmn, itypat)
1226 : : end do
1227 : : end do
1228 : : end if
1229 [ + - - + ]: 1296 : if(signs==1 .and. choice==54) then
1230 : : #ifdef HAVE_OPENMP_OFFLOAD
1231 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(3) &
1232 : : !$OMP& PRIVATE(ilmn,idir,ipw) MAP(to:atom_d2projs,ffnl) &
1233 : : !$OMP& IF(gpu_option==ABI_GPU_OPENMP)
1234 : : #endif
1235 [ # # ]: 0 : do ilmn=1,nlmn_o
1236 [ # # ]: 0 : do idir=1,nd2projs
1237 [ # # ]: 0 : do ipw=1, npw
1238 : 0 : atom_d2projs(1, ipw, idir, ilmn) = wt * ffnl(ipw, idir+1, ilmn, itypat)
1239 : : end do
1240 : : end do
1241 : : end do
1242 [ + - - + ]: 1296 : else if(signs==1 .and. choice==55) then
1243 : : #ifdef HAVE_OPENMP_OFFLOAD
1244 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(3) &
1245 : : !$OMP& PRIVATE(ilmn,idir,ipw) MAP(to:atom_d2projs,ffnl) &
1246 : : !$OMP& IF(gpu_option==ABI_GPU_OPENMP)
1247 : : #endif
1248 [ # # ]: 0 : do ilmn=1,nlmn_o
1249 [ # # ]: 0 : do idir=1,nd2projs
1250 [ # # ]: 0 : do ipw=1, npw
1251 : 0 : atom_d2projs(1, ipw, idir, ilmn) = wt * ffnl(ipw, idir+4, ilmn, itypat)
1252 : : end do
1253 : : end do
1254 : : end do
1255 [ + - - + ]: 1296 : else if(signs==1 .and. choice==6) then
1256 : : #ifdef HAVE_OPENMP_OFFLOAD
1257 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(3) &
1258 : : !$OMP& PRIVATE(ilmn,idir,ipw) MAP(to:atom_d2projs,ffnl) &
1259 : : !$OMP& IF(gpu_option==ABI_GPU_OPENMP)
1260 : : #endif
1261 [ # # ]: 0 : do ilmn=1,nlmn_o
1262 [ # # ]: 0 : do idir=1,10
1263 [ # # ]: 0 : do ipw=1, npw
1264 : 0 : atom_d2projs(1, ipw, idir, ilmn) = wt * ffnl(ipw, idir, ilmn, itypat)
1265 : : end do
1266 : : end do
1267 : : end do
1268 : : end if
1269 : :
1270 : 1296 : nlmn_p=0
1271 : : ! multiply by (-i)^l
1272 [ + + ]: 1296 : if (ndprojs>0) then
1273 [ + + ]: 9992 : do ilmn=1,nlmn_o
1274 : 9344 : il=mod(indlmn(1,ilmn, itypat),4);
1275 [ + + ]: 9344 : if(.not. (mod(il,2)==0)) then
1276 : 3888 : nlmn_p=nlmn_p+1
1277 : 3888 : lmn_parity(nlmn_p)=ilmn
1278 : : end if
1279 [ + + ]: 9992 : scal(ilmn)=1; if(il>1) scal(ilmn)=-1
1280 : : end do
1281 : : ! multiply by -1
1282 [ + - ]: 648 : if(gpu_option==ABI_GPU_OPENMP) then
1283 : : #ifdef HAVE_OPENMP_OFFLOAD
1284 : : !$OMP TARGET UPDATE TO(scal,lmn_parity)
1285 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(3) &
1286 : : !$OMP& PRIVATE(ilmn,idir,ipw) MAP(to:atom_dprojs,scal) &
1287 : : !$OMP& IF(gpu_option==ABI_GPU_OPENMP)
1288 : : do ilmn=1,nlmn_o
1289 : : do idir=1,ndprojs
1290 : : do ipw=1,npw
1291 : : atom_dprojs(1,ipw,idir,ilmn) = atom_dprojs(1,ipw,idir,ilmn) * scal(ilmn)
1292 : : atom_dprojs(2,ipw,idir,ilmn) = atom_dprojs(2,ipw,idir,ilmn) * scal(ilmn)
1293 : : end do
1294 : : end do
1295 : : end do
1296 : : if(nd2projs>0) then
1297 : : !$OMP TARGET TEAMS DISTRIBUTE &
1298 : : !$OMP& PRIVATE(ilmn) MAP(to:atom_d2projs,scal) &
1299 : : !$OMP& IF(gpu_option==ABI_GPU_OPENMP)
1300 : : do ilmn=1,nlmn_o
1301 : : !$OMP PARALLEL DO COLLAPSE(2) PRIVATE(idir,ipw)
1302 : : do idir=1,nd2projs
1303 : : do ipw=1,npw
1304 : : atom_d2projs(1,ipw,idir,ilmn) = atom_d2projs(1,ipw,idir,ilmn) * scal(ilmn)
1305 : : atom_d2projs(2,ipw,idir,ilmn) = atom_d2projs(2,ipw,idir,ilmn) * scal(ilmn)
1306 : : end do
1307 : : end do
1308 : : end do
1309 : : end if
1310 : : #endif
1311 : : else
1312 [ + + ]: 9992 : do ilmn=1,nlmn_o
1313 [ + + + + : 155517632 : atom_dprojs(:,:,:,ilmn) = atom_dprojs(:,:,:,ilmn) * scal(ilmn)
+ + ]
1314 : : end do
1315 [ - + ]: 648 : if(nd2projs>0) then
1316 [ # # ]: 0 : do ilmn=1,nlmn_o
1317 [ # # # # : 0 : atom_d2projs(:,:,:,ilmn) = atom_d2projs(:,:,:,ilmn) * scal(ilmn)
# # ]
1318 : : end do
1319 : : end if
1320 : : end if
1321 : : ! multiply by -i
1322 : : #ifdef HAVE_OPENMP_OFFLOAD
1323 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(3) &
1324 : : !$OMP MAP(to:atom_dprojs,lmn_parity) PRIVATE(ilmn,ilmn_p,idir,ipw,tmp) &
1325 : : !$OMP& IF(gpu_option==ABI_GPU_OPENMP)
1326 : : #endif
1327 [ + + ]: 4536 : do ilmn_p=1,nlmn_p
1328 [ + + ]: 16200 : do idir=1,ndprojs
1329 [ + + ]: 21157164 : do ipw=1,npw
1330 : 21141612 : ilmn=lmn_parity(ilmn_p)
1331 : 21141612 : tmp = atom_dprojs(2,ipw,idir,ilmn)
1332 : 21141612 : atom_dprojs(2,ipw,idir,ilmn) = -atom_dprojs(1,ipw,idir,ilmn)
1333 : 21153276 : atom_dprojs(1,ipw,idir,ilmn) = tmp
1334 : : end do
1335 : : end do
1336 : : end do
1337 [ - + ]: 648 : if(ngrads2>0) then
1338 : : #ifdef HAVE_OPENMP_OFFLOAD
1339 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(3) &
1340 : : !$OMP& MAP(to:atom_d2projs) PRIVATE(idir,ipw,ilmn) &
1341 : : !$OMP& IF(gpu_option==ABI_GPU_OPENMP)
1342 : : #endif
1343 [ # # ]: 0 : do ilmn=1,nlmn_o
1344 [ # # ]: 0 : do idir=1,nd2projs
1345 [ # # ]: 0 : do ipw=1,npw
1346 : 0 : atom_d2projs(1,ipw,idir,ilmn) = -atom_d2projs(1,ipw,idir,ilmn)
1347 : 0 : atom_d2projs(2,ipw,idir,ilmn) = -atom_d2projs(2,ipw,idir,ilmn)
1348 : : end do
1349 : : end do
1350 : : end do
1351 : : #ifdef HAVE_OPENMP_OFFLOAD
1352 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(3) &
1353 : : !$OMP& MAP(to:atom_d2projs,lmn_parity) PRIVATE(ilmn,ilmn_p,idir,ipw,tmp) &
1354 : : !$OMP& IF(gpu_option==ABI_GPU_OPENMP)
1355 : : #endif
1356 [ # # ]: 0 : do ilmn_p=1,nlmn_p
1357 [ # # ]: 0 : do idir=1,nd2projs
1358 [ # # ]: 0 : do ipw=1,npw
1359 : 0 : ilmn=lmn_parity(ilmn_p)
1360 : 0 : tmp = atom_d2projs(2,ipw,idir,ilmn)
1361 : 0 : atom_d2projs(2,ipw,idir,ilmn) = -atom_d2projs(1,ipw,idir,ilmn)
1362 : 0 : atom_d2projs(1,ipw,idir,ilmn) = tmp
1363 : : end do
1364 : : end do
1365 : : end do
1366 : : end if
1367 : : end if
1368 : :
1369 : : ! multiply by conj(ph3d)
1370 [ + + ]: 1296 : if (ndprojs>0) then
1371 : : #ifdef HAVE_OPENMP_OFFLOAD
1372 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(3) &
1373 : : !$OMP& PRIVATE(ilmn,tmp,ipw,idir) MAP(to:atom_dprojs,ph3d) &
1374 : : !$OMP& IF(gpu_option==ABI_GPU_OPENMP)
1375 : : #endif
1376 [ + + ]: 9992 : do ilmn=1,nlmn_o
1377 [ + + ]: 38024 : do idir=1,ndprojs
1378 [ + + ]: 51863912 : do ipw=1,npw
1379 : 51826536 : tmp = atom_dprojs(1, ipw, idir,ilmn)
1380 : : atom_dprojs(1, ipw, idir,ilmn) = atom_dprojs(1, ipw, idir,ilmn) * ph3d(1, ipw, iaph3d) &
1381 : 51826536 : & + atom_dprojs(2, ipw, idir,ilmn) * ph3d(2, ipw, iaph3d)
1382 : : atom_dprojs(2, ipw, idir,ilmn) = atom_dprojs(2, ipw, idir,ilmn) * ph3d(1, ipw, iaph3d) &
1383 : 51854568 : & - tmp * ph3d(2, ipw, iaph3d)
1384 : : end do
1385 : : end do
1386 : : end do
1387 : : end if
1388 [ - + ]: 1296 : if (nd2projs>0) then
1389 : : #ifdef HAVE_OPENMP_OFFLOAD
1390 : : !$OMP TARGET TEAMS DISTRIBUTE &
1391 : : !$OMP& PRIVATE(ilmn,idir,ipw,tmp) MAP(to:atom_d2projs,ph3d) &
1392 : : !$OMP& IF(gpu_option==ABI_GPU_OPENMP)
1393 : : #endif
1394 [ # # ]: 0 : do ilmn=1,nlmn_o
1395 : : !$OMP PARALLEL DO COLLAPSE(2) PRIVATE(ipw,idir,tmp)
1396 [ # # ]: 0 : do idir=1,nd2projs
1397 [ # # ]: 0 : do ipw=1,npw
1398 : 0 : tmp = atom_d2projs(1, ipw, idir,ilmn)
1399 : : atom_d2projs(1, ipw, idir,ilmn) = atom_d2projs(1, ipw, idir,ilmn) * ph3d(1, ipw, iaph3d) &
1400 : 0 : & + atom_d2projs(2, ipw, idir,ilmn) * ph3d(2, ipw, iaph3d)
1401 : : atom_d2projs(2, ipw, idir,ilmn) = atom_d2projs(2, ipw, idir,ilmn) * ph3d(1, ipw, iaph3d) &
1402 : 0 : & - tmp * ph3d(2, ipw, iaph3d)
1403 : : end do
1404 : : end do
1405 : : end do
1406 : : end if
1407 : :
1408 : : !! Handling dprojs
1409 : :
1410 [ + - + + ]: 1296 : if(signs==1 .and. (choice==3 .or. choice==23 .or. choice==55 .or. choice==6)) then
1411 [ + + ]: 648 : if(istwf_k <= 1) then
1412 : : #ifdef HAVE_OPENMP_OFFLOAD
1413 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(3) &
1414 : : !$OMP& PRIVATE(ilmn,ipw,idir,idir1,idir2) MAP(to:atom_dprojs,dprojs,kpg) &
1415 : : !$OMP& IF(gpu_option==ABI_GPU_OPENMP)
1416 : : #endif
1417 [ + + ]: 7088 : do ilmn=lmn_beg,nlmn
1418 [ + + ]: 46784 : do idir=1,6
1419 [ + + ]: 87912760 : do ipw=1,npw
1420 : 87866448 : idir1=alpha(idir);idir2=beta(idir)
1421 : : dprojs(1, ipw, shift_grad+(ilmn-lmn_beg)*ngrads+idir) = &
1422 : : & -half*(atom_dprojs(1, ipw, idir1, ilmn)*kpg(ipw,idir2) &
1423 : 87866448 : & +atom_dprojs(1, ipw, idir2, ilmn)*kpg(ipw,idir1))
1424 : : dprojs(2, ipw, shift_grad+(ilmn-lmn_beg)*ngrads+idir) = &
1425 : : & -half*(atom_dprojs(2, ipw, idir1, ilmn)*kpg(ipw,idir2) &
1426 : 87906144 : & +atom_dprojs(2, ipw, idir2, ilmn)*kpg(ipw,idir1))
1427 : : end do
1428 : : end do
1429 : : end do
1430 : : else ! istwf_k>1
1431 : : #ifdef HAVE_OPENMP_OFFLOAD
1432 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(3) &
1433 : : !$OMP& PRIVATE(ilmn,ipw,idir,idir1,idir2) MAP(to:atom_dprojs,dprojs_r,dprojs_i,kpg) &
1434 : : !$OMP& IF(gpu_option==ABI_GPU_OPENMP)
1435 : : #endif
1436 [ + + ]: 2904 : do ilmn=lmn_beg,nlmn
1437 [ + + ]: 19272 : do idir=1,6
1438 [ + + ]: 15805720 : do ipw=1,npw
1439 : 15786624 : idir1=alpha(idir);idir2=beta(idir)
1440 : : dprojs_r(1, ipw, shift_grad+(ilmn-lmn_beg)*ngrads+idir) = &
1441 : : & -half*(atom_dprojs(1, ipw, idir1, ilmn)*kpg(ipw,idir2) &
1442 : 15786624 : & +atom_dprojs(1, ipw, idir2, ilmn)*kpg(ipw,idir1))
1443 : :
1444 : : dprojs_i(1, ipw, shift_grad+(ilmn-lmn_beg)*ngrads+idir) = &
1445 : : & -half*(atom_dprojs(2, ipw, idir1, ilmn)*kpg(ipw,idir2) &
1446 : 15802992 : & +atom_dprojs(2, ipw, idir2, ilmn)*kpg(ipw,idir1))
1447 : : end do
1448 : : end do
1449 : : end do
1450 : : end if
1451 : : end if
1452 : :
1453 : :
1454 [ + - + + ]: 1296 : if(signs==1 .and. (choice==2 .or. choice==23 .or. choice==4 .or. choice==54 .or. choice==6)) then
1455 [ - + ]: 648 : igrad=0; if(choice==23 .or. choice==6) igrad=6
1456 [ + + ]: 648 : if(istwf_k <= 1) then
1457 : : #ifdef HAVE_OPENMP_OFFLOAD
1458 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(3) &
1459 : : !$OMP& PRIVATE(ilmn,ipw,idir) MAP(to:projs,dprojs,kpg) &
1460 : : !$OMP& IF(gpu_option==ABI_GPU_OPENMP)
1461 : : #endif
1462 [ + + ]: 7088 : do ilmn=lmn_beg,nlmn
1463 [ + + ]: 26936 : do idir=1,3
1464 [ + + ]: 43959688 : do ipw=1,npw
1465 : : dprojs(1, ipw, shift_grad+(ilmn-lmn_beg)*ngrads+igrad+idir) = &
1466 : 43933224 : & +projs(2, ipw, shift+ilmn-lmn_beg+1)*kpg(ipw,idir)*two_pi
1467 : : dprojs(2, ipw, shift_grad+(ilmn-lmn_beg)*ngrads+igrad+idir) = &
1468 : 43953072 : & -projs(1, ipw, shift+ilmn-lmn_beg+1)*kpg(ipw,idir)*two_pi
1469 : : end do
1470 : : end do
1471 : : end do
1472 : : else ! istwf_k>1
1473 : : #ifdef HAVE_OPENMP_OFFLOAD
1474 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(3) &
1475 : : !$OMP& PRIVATE(ilmn,ipw,idir) MAP(to:projs_r,projs_i,dprojs_r,dprojs_i,kpg) &
1476 : : !$OMP& IF(gpu_option==ABI_GPU_OPENMP)
1477 : : #endif
1478 [ + + ]: 2904 : do ilmn=lmn_beg,nlmn
1479 [ + + ]: 11088 : do idir=1,3
1480 [ + + ]: 7904224 : do ipw=1,npw
1481 : : dprojs_r(1, ipw, shift_grad+(ilmn-lmn_beg)*ngrads+igrad+idir) = &
1482 : 7893312 : & +projs_i(1, ipw, shift+ilmn-lmn_beg+1)*kpg(ipw,idir)*two_pi
1483 : : dprojs_i(1, ipw, shift_grad+(ilmn-lmn_beg)*ngrads+igrad+idir) = &
1484 : 7901496 : & -projs_r(1, ipw, shift+ilmn-lmn_beg+1)*kpg(ipw,idir)*two_pi
1485 : : end do
1486 : : end do
1487 : : end do
1488 : : end if
1489 : : end if
1490 : :
1491 [ + - - + ]: 1296 : if(signs==1 .and. (choice==5 .or. choice==51 .or. choice==54 .or. choice==55)) then
1492 [ # # # # ]: 0 : igrad=0; if(choice==54) igrad=3; if(choice==55) igrad=6
1493 : : #ifdef HAVE_OPENMP_OFFLOAD
1494 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(3) &
1495 : : !$OMP& PRIVATE(ilmn,ipw,idir) MAP(to:atom_dprojs,dprojs) &
1496 : : !$OMP& IF(gpu_option==ABI_GPU_OPENMP)
1497 : : #endif
1498 [ # # ]: 0 : do ilmn=lmn_beg,nlmn
1499 [ # # ]: 0 : do idir=1,3
1500 [ # # ]: 0 : do ipw=1,npw
1501 : : dprojs(1, ipw, shift_grad+(ilmn-lmn_beg)*ngrads+igrad+idir) = &
1502 : 0 : & +atom_dprojs(1, ipw, idir, ilmn)
1503 : : dprojs(2, ipw, shift_grad+(ilmn-lmn_beg)*ngrads+igrad+idir) = &
1504 : 0 : & +atom_dprojs(2, ipw, idir, ilmn)
1505 : : end do
1506 : : end do
1507 : : end do
1508 : : end if
1509 : :
1510 [ - + - - ]: 1296 : if(signs==2 .and. (choice==2)) then
1511 : : #ifdef HAVE_OPENMP_OFFLOAD
1512 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(2) &
1513 : : !$OMP& PRIVATE(ilmn,ipw) MAP(to:projs,dprojs,kpg) &
1514 : : !$OMP& IF(gpu_option==ABI_GPU_OPENMP)
1515 : : #endif
1516 [ # # ]: 0 : do ilmn=lmn_beg,nlmn
1517 [ # # ]: 0 : do ipw=1,npw
1518 : : dprojs(1, ipw, shift_grad+ilmn) = &
1519 : 0 : & projs(2, ipw, shift+ilmn-lmn_beg+1)*kpg(ipw,idir_pert)*two_pi
1520 : : dprojs(2, ipw, shift_grad+ilmn) = &
1521 : 0 : & -projs(1, ipw, shift+ilmn-lmn_beg+1)*kpg(ipw,idir_pert)*two_pi
1522 : : end do
1523 : : end do
1524 : : end if
1525 : :
1526 : :
1527 [ - + - - ]: 1296 : if(signs==2 .and. (choice==3)) then
1528 : : #ifdef HAVE_OPENMP_OFFLOAD
1529 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(2) &
1530 : : !$OMP& PRIVATE(ilmn,ipw) MAP(to:atom_dprojs,dprojs) &
1531 : : !$OMP& IF(gpu_option==ABI_GPU_OPENMP)
1532 : : #endif
1533 [ # # ]: 0 : do ilmn=lmn_beg,nlmn
1534 [ # # ]: 0 : do ipw=1,npw
1535 : : dprojs(1, ipw, shift_grad+ilmn) = &
1536 : 0 : & -atom_dprojs(1, ipw, 1, ilmn)
1537 : : dprojs(2, ipw, shift_grad+ilmn) = &
1538 : 0 : & -atom_dprojs(2, ipw, 1, ilmn)
1539 : : end do
1540 : : end do
1541 : : end if
1542 : :
1543 : :
1544 [ - + - - ]: 1296 : if(signs==2 .and. (choice==5 .or. choice==51)) then
1545 : : #ifdef HAVE_OPENMP_OFFLOAD
1546 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(2) &
1547 : : !$OMP& PRIVATE(ilmn,ipw) MAP(to:atom_dprojs,dprojs) &
1548 : : !$OMP& IF(gpu_option==ABI_GPU_OPENMP)
1549 : : #endif
1550 [ # # ]: 0 : do ilmn=lmn_beg,nlmn
1551 [ # # ]: 0 : do ipw=1,npw
1552 : : dprojs(1, ipw, shift_grad+ilmn) = &
1553 : 0 : & +atom_dprojs(1, ipw, 1, ilmn)
1554 : : dprojs(2, ipw, shift_grad+ilmn) = &
1555 : 0 : & +atom_dprojs(2, ipw, 1, ilmn)
1556 : : end do
1557 : : end do
1558 : : end if
1559 : :
1560 : :
1561 : :
1562 : : ! Handling d2projs
1563 : :
1564 [ + - - + ]: 1296 : if(signs==1 .and. choice==4) then
1565 : : #ifdef HAVE_OPENMP_OFFLOAD
1566 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(3) &
1567 : : !$OMP& PRIVATE(idir,ilmn,ipw) MAP(to:projs,d2projs,kpg) &
1568 : : !$OMP& IF(gpu_option==ABI_GPU_OPENMP)
1569 : : #endif
1570 [ # # ]: 0 : do ilmn=lmn_beg,nlmn
1571 [ # # ]: 0 : do idir=1,6
1572 [ # # ]: 0 : do ipw=1,npw
1573 : : d2projs(1, ipw, shift_grad2+(ilmn-lmn_beg)*ngrads2+idir) = &
1574 : 0 : & -projs(1, ipw, shift+ilmn-lmn_beg+1)*kpg(ipw,idir+3)*two_pi2
1575 : : d2projs(2, ipw, shift_grad2+(ilmn-lmn_beg)*ngrads2+idir) = &
1576 : 0 : & -projs(2, ipw, shift+ilmn-lmn_beg+1)*kpg(ipw,idir+3)*two_pi2
1577 : : end do
1578 : : end do
1579 : : end do
1580 : : end if
1581 : :
1582 [ + - - + ]: 1296 : if(signs==1 .and. choice==54) then
1583 : : #ifdef HAVE_OPENMP_OFFLOAD
1584 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(4) &
1585 : : !$OMP& PRIVATE(idir1,idir2,ilmn,ipw) MAP(to:atom_d2projs,d2projs,kpg) &
1586 : : !$OMP& IF(gpu_option==ABI_GPU_OPENMP)
1587 : : #endif
1588 [ # # ]: 0 : do ilmn=lmn_beg,nlmn
1589 [ # # ]: 0 : do idir1=1,3
1590 [ # # ]: 0 : do idir2=1,3
1591 [ # # ]: 0 : do ipw=1,npw
1592 : : d2projs(1, ipw, shift_grad2+(ilmn-lmn_beg)*ngrads2+(idir1-1)*3+idir2) = &
1593 : 0 : & -atom_d2projs(2, ipw, idir2, ilmn)*kpg(ipw,idir1)*two_pi
1594 : : d2projs(2, ipw, shift_grad2+(ilmn-lmn_beg)*ngrads2+(idir1-1)*3+idir2) = &
1595 : 0 : & +atom_d2projs(1, ipw, idir2, ilmn)*kpg(ipw,idir1)*two_pi
1596 : : end do
1597 : : end do
1598 : : end do
1599 : : end do
1600 : : end if
1601 : :
1602 [ + - - + ]: 1296 : if(signs==1 .and. choice==55) then
1603 : : #ifdef HAVE_OPENMP_OFFLOAD
1604 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(4) &
1605 : : !$OMP& PRIVATE(idir1,idir2,ilmn,ipw) MAP(to:atom_d2projs,d2projs,kpg) &
1606 : : !$OMP& IF(gpu_option==ABI_GPU_OPENMP)
1607 : : #endif
1608 [ # # ]: 0 : do ilmn=lmn_beg,nlmn
1609 [ # # ]: 0 : do idir1=1,6
1610 [ # # ]: 0 : do idir2=1,3
1611 [ # # ]: 0 : do ipw=1,npw
1612 : : d2projs(1, ipw, shift_grad2+(ilmn-lmn_beg)*ngrads2+(idir1-1)*3+idir2) = &
1613 : 0 : & +atom_d2projs(1, ipw, idir1, ilmn)*kpg(ipw,idir2)
1614 : : d2projs(2, ipw, shift_grad2+(ilmn-lmn_beg)*ngrads2+(idir1-1)*3+idir2) = &
1615 : 0 : & +atom_d2projs(2, ipw, idir1, ilmn)*kpg(ipw,idir2)
1616 : : end do
1617 : : end do
1618 : : end do
1619 : : end do
1620 : : end if
1621 : :
1622 [ + - - + ]: 1296 : if(signs==1 .and. choice==6) then
1623 : : #ifdef HAVE_OPENMP_OFFLOAD
1624 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(4) &
1625 : : !$OMP& PRIVATE(idir1,idir2,jdir1,jdir2,kdir1,kdir2,ldir1,ldir2,ldir3,ldir4,ilmn,ipw) &
1626 : : !$OMP& MAP(to:atom_d2projs,d2projs,kpg) &
1627 : : !$OMP& IF(gpu_option==ABI_GPU_OPENMP)
1628 : : #endif
1629 [ # # ]: 0 : do ilmn=lmn_beg,nlmn
1630 [ # # ]: 0 : do idir1=1,6
1631 [ # # ]: 0 : do idir2=1,6
1632 [ # # ]: 0 : do ipw=1,npw
1633 : 0 : jdir1=alpha(idir1);jdir2=beta(idir1)
1634 : 0 : kdir1=alpha(idir2);kdir2=beta(idir2)
1635 : 0 : ldir1=gamma(jdir1,kdir1)
1636 : 0 : ldir2=gamma(jdir2,kdir1)
1637 : 0 : ldir3=gamma(jdir1,kdir2)
1638 : 0 : ldir4=gamma(jdir2,kdir2)
1639 : : d2projs(1, ipw, shift_grad2+(ilmn-lmn_beg)*ngrads2+(idir1-1)*6+idir2) = &
1640 : : & -atom_d2projs(1, ipw, 4+ldir1, ilmn)*kpg(ipw,jdir2)*kpg(ipw,kdir2)*quarter &
1641 : : & -atom_d2projs(1, ipw, 4+ldir2, ilmn)*kpg(ipw,jdir1)*kpg(ipw,kdir2)*quarter &
1642 : : & -atom_d2projs(1, ipw, 4+ldir3, ilmn)*kpg(ipw,jdir2)*kpg(ipw,kdir1)*quarter &
1643 : 0 : & -atom_d2projs(1, ipw, 4+ldir4, ilmn)*kpg(ipw,jdir1)*kpg(ipw,kdir1)*quarter
1644 : : d2projs(2, ipw, shift_grad2+(ilmn-lmn_beg)*ngrads2+(idir1-1)*6+idir2) = &
1645 : : & -atom_d2projs(2, ipw, 4+ldir1, ilmn)*kpg(ipw,jdir2)*kpg(ipw,kdir2)*quarter &
1646 : : & -atom_d2projs(2, ipw, 4+ldir2, ilmn)*kpg(ipw,jdir1)*kpg(ipw,kdir2)*quarter &
1647 : : & -atom_d2projs(2, ipw, 4+ldir3, ilmn)*kpg(ipw,jdir2)*kpg(ipw,kdir1)*quarter &
1648 : 0 : & -atom_d2projs(2, ipw, 4+ldir4, ilmn)*kpg(ipw,jdir1)*kpg(ipw,kdir1)*quarter
1649 : : end do
1650 : : end do
1651 : : end do
1652 : : end do
1653 : 0 : igrad=36
1654 : : #ifdef HAVE_OPENMP_OFFLOAD
1655 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(4) &
1656 : : !$OMP& PRIVATE(idir1,idir2,jdir1,jdir2,ilmn,ipw) &
1657 : : !$OMP& MAP(to:atom_d2projs,d2projs,kpg) &
1658 : : !$OMP& IF(gpu_option==ABI_GPU_OPENMP)
1659 : : #endif
1660 [ # # ]: 0 : do ilmn=lmn_beg,nlmn
1661 [ # # ]: 0 : do idir1=1,6 !mub
1662 [ # # ]: 0 : do idir2=1,3 !mua
1663 [ # # ]: 0 : do ipw=1,npw
1664 : 0 : jdir1=alpha(idir1);jdir2=beta(idir1)
1665 : : d2projs(1, ipw, shift_grad2+(ilmn-lmn_beg)*ngrads2+igrad+(idir1-1)*3+idir2) = &
1666 : : & +kpg(ipw,idir2)*(atom_d2projs(2,ipw,1+jdir1,ilmn)*kpg(ipw,jdir2)*pi &
1667 : 0 : & + atom_d2projs(2,ipw,1+jdir2,ilmn)*kpg(ipw,jdir1)*pi)
1668 : :
1669 : : d2projs(2, ipw, shift_grad2+(ilmn-lmn_beg)*ngrads2+igrad+(idir1-1)*3+idir2) = &
1670 : : & -kpg(ipw,idir2)*(atom_d2projs(1,ipw,1+jdir1,ilmn)*kpg(ipw,jdir2)*pi &
1671 : 0 : & + atom_d2projs(1,ipw,1+jdir2,ilmn)*kpg(ipw,jdir1)*pi)
1672 : : end do
1673 : : end do
1674 : : end do
1675 : : end do
1676 : : end if
1677 : :
1678 : 1296 : iaph3d = iaph3d + 1
1679 : 1296 : shift_grad2 = shift_grad2 + ngrads2*(nlmn-lmn_beg+1)
1680 : 1296 : shift_grad = shift_grad + ngrads*(nlmn-lmn_beg+1)
1681 : :
1682 [ - + ]: 2008 : if(gemm_nonlop_block_size > 1) then
1683 : 0 : shift = shift + nlmn - (lmn_beg-1)
1684 : 0 : shift_do = shift_do + nlmn
1685 [ # # ]: 0 : if(shift_do >= iend - 1) exit
1686 : : else
1687 : 1296 : shift = shift + nlmn
1688 : : end if
1689 : :
1690 : : end do
1691 [ - + - - ]: 1136 : if(gemm_nonlop_block_size > 1 .and. shift_do >= iend - 1) exit
1692 : : end do
1693 : :
1694 : : #ifdef HAVE_OPENMP_OFFLOAD
1695 : : !!$OMP TARGET EXIT DATA MAP(delete:kpg) IF(gpu_option==ABI_GPU_OPENMP)
1696 : : !$OMP TARGET EXIT DATA MAP(delete:ffnl) IF(gpu_option==ABI_GPU_OPENMP .and. map_ffnl)
1697 : : !$OMP TARGET EXIT DATA MAP(delete:ph3d) IF(gpu_option==ABI_GPU_OPENMP .and. map_ph3d)
1698 : : #endif
1699 : :
1700 [ - + ]: 424 : end subroutine prep_dprojectors
1701 : : !!***
1702 : :
1703 [ # # # # : 0 : end module m_gemm_nonlop_projectors
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
1704 : : !!***
|
