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