Branch data Line data Source code
1 : : !!****m* ABINIT/m_fft
2 : : !! NAME
3 : : !! m_fft
4 : : !!
5 : : !! FUNCTION
6 : : !! This module provides driver routines for sequential FFTs (OpenMP threads are supported).
7 : : !! It also defines generic interfaces for single or double precision FFTs.
8 : : !!
9 : : !! COPYRIGHT
10 : : !! Copyright (C) 2009-2026 ABINIT group (MG, MM, GZ, MT, MF, XG, PT, FF)
11 : : !! This file is distributed under the terms of the
12 : : !! GNU General Public License, see ~abinit/COPYING
13 : : !! or http://www.gnu.org/copyleft/gpl.txt .
14 : : !!
15 : : !! SOURCE
16 : :
17 : : #if defined HAVE_CONFIG_H
18 : : #include "config.h"
19 : : #endif
20 : :
21 : : #include "abi_common.h"
22 : :
23 : : ! nvtx related macro definition
24 : : #include "nvtx_macros.h"
25 : :
26 : : module m_fft
27 : :
28 : : use, intrinsic :: iso_c_binding
29 : : use defs_basis
30 : : use m_abicore
31 : : use m_errors
32 : : use m_xomp
33 : : USE_MPI
34 : : use m_xmpi
35 : : use m_cplxtools
36 : : use m_cgtools
37 : : use m_sgfft
38 : : use m_sg2002
39 : : use m_fftw3
40 : : use m_dfti
41 : : #if defined HAVE_GPU_CUDA
42 : : use m_manage_cuda
43 : : #endif
44 : : use m_ompgpu_fourwf
45 : :
46 : : use defs_abitypes, only : MPI_type
47 : : use defs_fftdata, only : mg
48 : : use m_time, only : cwtime, timab
49 : : use m_numeric_tools, only : r2c
50 : : use m_fstrings, only : sjoin, itoa
51 : : use m_geometry, only : metric
52 : : use m_hide_blas, only : xscal
53 : : use m_fftcore, only : get_cache_kb, kpgsph, get_kg, sphere_fft, sphere_fft1, sphere, change_istwfk, &
54 : : fftalg_info, fftalg_has_mpi, print_ngfft, getng, sphereboundary, ngfft_seq
55 : : use m_mpinfo, only : destroy_mpi_enreg, ptabs_fourdp, ptabs_fourwf, initmpi_seq
56 : : use m_distribfft, only : distribfft_type
57 : : use m_gputk , only : gpu_set_to_zero_complex, gpu_set_to_zero_complex_sp
58 : :
59 : : implicit none
60 : :
61 : : private
62 : :
63 : : #if defined HAVE_MPI1
64 : : include 'mpif.h'
65 : : #endif
66 : :
67 : : public :: fft_ug ! Driver for zero-padded FFTs u(g) --> u(r)
68 : : public :: fft_ur ! Driver for zero-padded FFTs u(r) --> u(g)
69 : : public :: fftpad ! Driver for (low-level) zero-padded FFTs, note that fft_ug is the preferred interface.
70 : : public :: fft_poisson ! Solve the poisson equation in G-space starting from n(r).
71 : : public :: fourdp_6d ! Calculate a 6-dimensional Fast Fourier Transform
72 : : public :: fftpac ! Copy to change the stride of a three-dimension array for more efficient FFT.
73 : : public :: indirect_parallel_Fourier
74 : :
75 : : public :: fft_use_lib_threads
76 : : public :: fft_allow_ialltoall ! Allow the use of non-blocking IALLOTOALL in MPI-FFTs algorithms
77 : : public :: zerosym ! Symmetrize an array on the FFT grid by vanishing some term on the boundaries.
78 : :
79 : : ! Main entry points.
80 : : public :: fourdp
81 : : public :: fourwf
82 : :
83 : : ! Alternate routine wrapping fourwf, for memory sensitive regions
84 : : public :: fourwf_optmem
85 : :
86 : : integer,public,save :: fourdp_counter = -1
87 : : integer,public,save :: fourwf_counter = -1
88 : : public :: fft_init_counters
89 : : public :: fft_stop_counters
90 : : public :: fft_output_counters
91 : :
92 : : ! Driver routines for MPI version.
93 : : public :: fourdp_mpi ! MPI FFT of densities/potentials on the full box.
94 : : public :: fourwf_mpi ! specialized MPI-FFT for wavefunctions.
95 : : !public :: fftmpi_u
96 : :
97 : : interface fft_ug
98 : : module procedure fft_ug_sp
99 : : module procedure fft_ug_dp
100 : : module procedure fft_ug_spc
101 : : module procedure fft_ug_dpc
102 : : end interface fft_ug
103 : :
104 : : interface fft_ur
105 : : module procedure fft_ur_dp
106 : : module procedure fft_ur_spc
107 : : module procedure fft_ur_dpc
108 : : end interface fft_ur
109 : :
110 : : interface fftpad
111 : : module procedure fftpad_spc
112 : : module procedure fftpad_dpc
113 : : end interface fftpad
114 : : !!***
115 : :
116 : : !----------------------------------------------------------------------
117 : :
118 : : !!****t* m_fft/fftbox_plan3_t
119 : : !! NAME
120 : : !! fftbox_plan3_t
121 : : !!
122 : : !! FUNCTION
123 : : !! Options passed to the fftbox_* routines to perform dense 3d FFTs.
124 : : !!
125 : : !! SOURCE
126 : :
127 : : type,public :: fftbox_plan3_t
128 : :
129 : : integer :: fftalg = 112 ! The library to call on the CPU
130 : : integer :: fftcache = 16 ! Cache size in kB. Only used in SG routines.
131 : : integer(c_size_t) :: nfft = -1 ! Total number of points in the FFT box.
132 : : integer(c_size_t) :: ldxyz = -1 ! Physical dimension of the array to transform
133 : : integer :: batch_size = -1 ! MAXIMUM number of FFTs associated to the plan.
134 : : integer :: dims(3) = -1 ! The number of FFT divisions.
135 : : integer :: embed(3) = -1 ! Leading dimensions of the input, output arrays.
136 : : integer :: gpu_option = ABI_GPU_DISABLED ! /= 0 if FFTs should be offloaded to the GPU
137 : :
138 : : type(c_ptr) :: gpu_ctx_spc = c_null_ptr, gpu_ctx_dpc = c_null_ptr
139 : :
140 : : contains
141 : :
142 : : procedure :: init => fftbox_plan3_init ! Low-level constructor
143 : : procedure :: from_ngfft => fftbox_plan3_from_ngfft ! Build object from ngfft.
144 : :
145 : : procedure :: execute_ip_spc => fftbox_execute_ip_spc
146 : : procedure :: execute_ip_dpc => fftbox_execute_ip_dpc
147 : : procedure :: execute_op_spc => fftbox_execute_op_spc
148 : : procedure :: execute_op_dpc => fftbox_execute_op_dpc
149 : :
150 : : ! Main entry point for performing FFTs on the full box
151 : : ! complex-to-complex version, operating on complex arrays
152 : : generic :: execute => execute_ip_spc, &
153 : : execute_ip_dpc, &
154 : : execute_op_spc, &
155 : : execute_op_dpc
156 : :
157 : : procedure :: free => fftbox_plan3_free
158 : : ! Free dynamic memory
159 : :
160 : : end type fftbox_plan3_t
161 : : !!***
162 : :
163 : : #if defined HAVE_GPU_CUDA
164 : : ! The c functions are declared in shared/common/src/17_gpu_toolbox
165 : : ! gpu_fft_cuda.cpp or gpu_fft_hip.cpp
166 : : interface
167 : : subroutine gpu_ctx_init(ctx, f_dims, f_embed, batch, kind) bind(C, name="gpu_ctx_init_cpp")
168 : : use, intrinsic :: iso_c_binding
169 : : type(c_ptr), intent(out) :: ctx
170 : : integer(c_int), intent(in) :: f_dims(3), f_embed(3)
171 : : integer(c_int), value :: batch, kind
172 : : end subroutine
173 : : subroutine gpu_ctx_synch(ctx) bind(C, name="gpu_ctx_synch_cpp")
174 : : use, intrinsic :: iso_c_binding
175 : : type(c_ptr), value :: ctx
176 : : end subroutine gpu_ctx_synch
177 : : subroutine gpu_ctx_free(ctx) bind(C, name="gpu_ctx_free_cpp")
178 : : use, intrinsic :: iso_c_binding
179 : : type(c_ptr) :: ctx
180 : : end subroutine
181 : : subroutine gpu_fftbox_c2c_ip(ctx, nfft, ndat, isign, iscale, kind, d_ff) bind(C, name="gpu_fftbox_c2c_ip_cpp")
182 : : use, intrinsic :: iso_c_binding
183 : : type(c_ptr),value,intent(in) :: ctx
184 : : integer(c_int),value, intent(in) :: nfft, ndat, isign, iscale, kind
185 : : type(c_ptr),intent(in) :: d_ff
186 : : end subroutine gpu_fftbox_c2c_ip
187 : : subroutine gpu_fftbox_c2c_op(ctx, nfft, ndat, isign, iscale, kind, d_ff, d_gg) bind(C, name="gpu_fftbox_c2c_op_cpp")
188 : : use, intrinsic :: iso_c_binding
189 : : type(c_ptr),value,intent(in) :: ctx
190 : : integer(c_int),value, intent(in) :: nfft, ndat, isign, iscale, kind
191 : : type(c_ptr),intent(in) :: d_ff, d_gg
192 : : end subroutine gpu_fftbox_c2c_op
193 : : end interface
194 : : #endif
195 : :
196 : : !----------------------------------------------------------------------
197 : :
198 : : !!****t* m_fft/uplan_t
199 : : !! NAME
200 : : !! uplan_t
201 : : !!
202 : : !! FUNCTION
203 : : !!
204 : : !! SOURCE
205 : :
206 : : type, public :: uplan_t
207 : :
208 : : integer(c_size_t) :: npw = -1
209 : : integer :: nspinor = -1
210 : : integer :: batch_size = -1 ! MAXIMUM number of FFTs associated to the plan.
211 : : integer :: istwfk = -1
212 : : integer :: kind = -1
213 : : integer :: gpu_option = ABI_GPU_DISABLED ! /= 0 if FFTs should be offloaded to the GPU.
214 : : integer(c_size_t) :: nfft = -1
215 : : integer :: mgfft = -1
216 : : integer :: ngfft(18)
217 : : integer, contiguous, pointer :: kg_k(:,:)
218 : : integer, allocatable :: gbound(:,:)
219 : :
220 : : integer, allocatable :: ig2ifft(:)
221 : : ! (npw)
222 : : ! Mapping gvec index --> FFT box
223 : :
224 : : integer, allocatable :: ifft2ig(:)
225 : : ! (nfft)
226 : : ! Mapping FFT box -> gvec index. 0 if FFT point is not in g-sphere.
227 : :
228 : : type(c_ptr) :: gpu_ctx_spc = c_null_ptr, gpu_ctx_dpc = c_null_ptr
229 : :
230 : : contains
231 : : procedure :: init => uplan_init ! Build object
232 : : procedure :: free => uplan_free ! Free dynamic memory
233 : :
234 : : procedure :: execute_gr_spc => uplan_execute_gr_spc
235 : : procedure :: execute_gr_dpc => uplan_execute_gr_dpc
236 : : procedure :: execute_rg_spc => uplan_execute_rg_spc
237 : : procedure :: execute_rg_dpc => uplan_execute_rg_dpc
238 : :
239 : : ! Main entry points for performing FFTs on the full box.
240 : : ! complex-to-complex version, operating on complex arrays
241 : : generic :: execute_gr => execute_gr_spc, execute_gr_dpc
242 : : generic :: execute_rg => execute_rg_spc, execute_rg_dpc
243 : : end type uplan_t
244 : : !!***
245 : :
246 : : !----------------------------------------------------------------------
247 : :
248 : : ! unit tests
249 : : public :: fftbox_utests ! Unit tests for FFTs on the full box.
250 : : public :: fftu_utests ! Unit tests for the FFTs of wavefunctions.
251 : : public :: uplan_utests ! Unit tests for the FFTs of wavefunctions (including GPU support)
252 : : public :: fftbox_mpi_utests ! Unit tests for MPI-FFT on the full box.
253 : : public :: fftu_mpi_utests ! Unit tests for MPI-FFT of the wavefunctions.
254 : : !!***
255 : :
256 : : ! Flag used to enable/disable the use of non-blocking IALLTOALL
257 : : #ifdef HAVE_MPI_IALLTOALL
258 : : logical,save,private :: ALLOW_IALLTOALL = .True.
259 : : #else
260 : : logical,save,private :: ALLOW_IALLTOALL = .False.
261 : : #endif
262 : :
263 : : CONTAINS !===========================================================
264 : : !!***
265 : :
266 : : !----------------------------------------------------------------------
267 : :
268 : : !!****f* m_fft/fft_allow_ialltoall
269 : : !! NAME
270 : : !! fft_allow_ialltoall
271 : : !!
272 : : !! FUNCTION
273 : : !! Allow the use of non-blocking IALLOTOALL in MPI-FFTs algorithms
274 : : !! Mainly used for profiling purposes.
275 : : !!
276 : : !! SOURCE
277 : :
278 : 0 : subroutine fft_allow_ialltoall(bool)
279 : :
280 : : !Arguments ------------------------------------
281 : : logical,intent(in) :: bool
282 : : ! *************************************************************************
283 : :
284 : 0 : ALLOW_IALLTOALL = bool
285 : : #ifndef HAVE_MPI_IALLTOALL
286 : : ALLOW_IALLTOALL = .False.
287 : : #endif
288 : :
289 : 0 : end subroutine fft_allow_ialltoall
290 : : !!***
291 : :
292 : : !----------------------------------------------------------------------
293 : :
294 : : !!****f* m_fft/fftbox_plan3_init
295 : : !! NAME
296 : : !! fftbox_plan3_init
297 : : !!
298 : : !! FUNCTION
299 : : !! Initialize the plan with the options passed to the fttbox_ routines.
300 : : !! Low-level constructor.
301 : : !!
302 : : !! INPUTS
303 : : !! See fftbox_plan3_t for the meaning of the different arguments.
304 : : !!
305 : : !! SOURCE
306 : :
307 [ - + ]: 14981 : subroutine fftbox_plan3_init(plan, batch_size, dims, embed, fftalg, fftcache, gpu_option)
308 : :
309 : : !Arguments ------------------------------------
310 : : !scalars
311 : : class(fftbox_plan3_t),intent(out) :: plan
312 : : integer,intent(in) :: batch_size, fftalg, fftcache, gpu_option
313 : : !arrays
314 : : integer,intent(in) :: dims(3), embed(3)
315 : : ! *************************************************************************
316 : :
317 : 14981 : plan%batch_size = batch_size
318 [ + + ]: 59924 : plan%dims = dims ! ngfft(1:3)
319 [ + + ]: 59924 : plan%embed = embed ! ngfft(4:6)
320 : 14981 : plan%fftalg = fftalg ! ngfft(7)
321 [ - + ]: 14981 : if (fftcache > 0) plan%fftcache = fftcache ! ngfft(8)
322 : 14981 : plan%gpu_option = gpu_option
323 [ + + ]: 59924 : plan%nfft = product(plan%dims)
324 [ + + ]: 59924 : plan%ldxyz = product(plan%embed)
325 : :
326 : 14981 : plan%gpu_ctx_spc = c_null_ptr; plan%gpu_ctx_dpc = c_null_ptr
327 : :
328 [ - + ]: 14981 : if (gpu_option /= ABI_GPU_DISABLED) then
329 [ # # # # : 0 : if (any(dims /= embed)) then
# # ]
330 : 0 : ABI_ERROR("FFTs on GPUs with fftbox_plan3 do not support dims != embed")
331 : : end if
332 : : end if
333 : :
334 : 14981 : end subroutine fftbox_plan3_init
335 : : !!***
336 : :
337 : : !----------------------------------------------------------------------
338 : :
339 : : !!****f* m_fft/fftbox_plan3_from_ngfft
340 : : !! NAME
341 : : !! fftbox_plan3_from_ngfft
342 : : !!
343 : : !! FUNCTION
344 : : !! Initialize plan from ngfft.
345 : : !!
346 : : !! SOURCE
347 : :
348 [ # # ]: 0 : subroutine fftbox_plan3_from_ngfft(plan, ngfft, batch_size, gpu_option)
349 : :
350 : : !Arguments ------------------------------------
351 : : class(fftbox_plan3_t),intent(out) :: plan
352 : : integer,intent(in) :: ngfft(18), batch_size, gpu_option
353 : : ! *************************************************************************
354 : :
355 : 0 : call plan%init(batch_size, ngfft(1:3), ngfft(4:6), ngfft(7), ngfft(8), gpu_option)
356 : :
357 : 0 : end subroutine fftbox_plan3_from_ngfft
358 : : !!***
359 : :
360 : : !----------------------------------------------------------------------
361 : :
362 : : !!****f* m_fft/fftbox_plan3_free
363 : : !! NAME
364 : : !! fftbox_plan3_free
365 : : !!
366 : : !! FUNCTION
367 : : !! Free dynamic memory.
368 : : !!
369 : : !! SOURCE
370 : :
371 : 14957 : subroutine fftbox_plan3_free(plan)
372 : :
373 : : !Arguments ------------------------------------
374 : : class(fftbox_plan3_t),target,intent(inout) :: plan
375 : : ! *************************************************************************
376 : :
377 : : ABI_UNUSED(plan%ldxyz)
378 : :
379 : : #ifdef HAVE_GPU_CUDA
380 : : call gpu_ctx_free(plan%gpu_ctx_spc)
381 : : call gpu_ctx_free(plan%gpu_ctx_dpc)
382 : : #endif
383 : :
384 : 14957 : end subroutine fftbox_plan3_free
385 : : !!***
386 : :
387 : : !----------------------------------------------------------------------
388 : :
389 : : !!****f* m_fft/fftbox_execute_ip_spc
390 : : !! NAME
391 : : !! fftbox_execute_ip_spc
392 : : !!
393 : : !! FUNCTION
394 : : !! In-place FFT transform of complex array.
395 : : !! Call (FFTW3|DFTI) routines if available, otherwise fallback to SG routines
396 : : !! TARGET: spc arrays
397 : : !!
398 : : !! INPUTS
399 : : !! isign= Sign of the exponential in the FFT
400 : : !! ndat: Number of FFTs.
401 : : !! [iscale]= 0 if G --> R FFT should not be scaled. Default: 1 i.e. scale
402 : : !!
403 : : !! SIDE EFFECTS
404 : : !! ff(plan%ldxyz*ndat) =
405 : : !! In input: the data to transform.
406 : : !! Changed in output, filled with the FFT results.
407 : : !!
408 : : !! SOURCE
409 : :
410 : 48 : subroutine fftbox_execute_ip_spc(plan, ff, isign, ndat, &
411 : : iscale, gpu_mode) ! optional
412 : :
413 : : !Arguments ------------------------------------
414 : : !scalars
415 : : class(fftbox_plan3_t),target,intent(inout) :: plan
416 : : integer,intent(in) :: isign, ndat
417 : : integer,optional,intent(in) :: iscale, gpu_mode
418 : : !arrays
419 : : complex(sp),target,intent(inout) :: ff(plan%ldxyz*ndat)
420 : :
421 : : !Local variables-------------------------------
422 : : integer :: ndat__, iscale__, gpu_mode__
423 : : #ifdef HAVE_GPU_CUDA
424 : : logical :: transfer_ff
425 : : #endif
426 : : ! *************************************************************************
427 : :
428 : 48 : ndat__ = ndat
429 [ - + ]: 48 : ABI_DEFAULT(iscale__, iscale, 1)
430 [ - + + - ]: 48 : ABI_DEFAULT(gpu_mode__, gpu_mode, 0)
431 : :
432 : : if (plan%gpu_option == ABI_GPU_OPENMP) then
433 : : #if defined HAVE_GPU_CUDA && defined HAVE_OPENMP_OFFLOAD
434 : : ! Build plan if not yet done. note batch_size instead of ndat.
435 : : if (.not. c_associated(plan%gpu_ctx_spc)) then
436 : : call gpu_ctx_init(plan%gpu_ctx_spc, plan%dims, plan%embed, plan%batch_size, sp)
437 : : end if
438 : :
439 : : if (ndat__ /= plan%batch_size) then
440 : : ! Have to rebuild the plan with batch_size == ndat.
441 : : call gpu_ctx_free(plan%gpu_ctx_spc)
442 : : call gpu_ctx_init(plan%gpu_ctx_spc, plan%dims, plan%embed, ndat__, sp)
443 : : end if
444 : :
445 : : plan%batch_size = ndat__
446 : :
447 : : transfer_ff = .False.
448 : : if (gpu_mode__ /= 0) then
449 : : transfer_ff = .not. xomp_target_is_present(c_loc(ff))
450 : : !$OMP TARGET ENTER DATA MAP(alloc:ff) IF(transfer_ff)
451 : : !$OMP TARGET UPDATE TO(ff) IF(transfer_ff)
452 : : end if
453 : :
454 : : !$OMP TARGET DATA USE_DEVICE_ADDR(ff)
455 : : call gpu_fftbox_c2c_ip(plan%gpu_ctx_spc, int(plan%nfft), ndat__, isign, iscale__, sp, c_loc(ff))
456 : : call gpu_ctx_synch(plan%gpu_ctx_spc)
457 : : !$OMP END TARGET DATA
458 : :
459 : : if (gpu_mode__ /= 0) then
460 : : !$OMP TARGET UPDATE FROM(ff) IF(transfer_ff)
461 : : !$OMP TARGET EXIT DATA MAP(delete:ff) IF(transfer_ff)
462 : : end if
463 : :
464 : : return
465 : : #endif
466 : : end if
467 : :
468 : : ! CPU version
469 : : #include "fftbox_ip_driver.finc"
470 : :
471 : 48 : end subroutine fftbox_execute_ip_spc
472 : : !!***
473 : :
474 : : !----------------------------------------------------------------------
475 : :
476 : : !!****f* m_fft/fftbox_execute_ip_dpc
477 : : !! NAME
478 : : !! fftbox_execute_ip_dpc
479 : : !!
480 : : !! FUNCTION
481 : : !! In-place FFT transform of complex arrays
482 : : !! Call (FFTW3|DFTI) routines if available, otherwise fallback to SG routines
483 : : !! TARGET: dp arrays
484 : : !!
485 : : !! INPUTS
486 : : !! isign= Sign of the exponential in the FFT
487 : : !! ndat: Number of FFTs.
488 : : !! [iscale]= 0 if G --> R FFT should not be scaled. Default: 1 i.e. scale
489 : : !!
490 : : !! SIDE EFFECTS
491 : : !! ff(plan%ldxyz*ndat) =
492 : : !! In input: the data to transform.
493 : : !! Changed in output, filled with the FFT results.
494 : : !!
495 : : !! SOURCE
496 : :
497 : 12175 : subroutine fftbox_execute_ip_dpc(plan, ff, isign, ndat, &
498 : : iscale, gpu_mode) ! optional
499 : :
500 : : !Arguments ------------------------------------
501 : : !scalars
502 : : class(fftbox_plan3_t),target,intent(inout) :: plan
503 : : integer,intent(in) :: isign, ndat
504 : : integer,optional,intent(in) :: iscale, gpu_mode
505 : : !arrays
506 : : complex(dp),target,intent(inout) :: ff(plan%ldxyz*ndat)
507 : : !Local variables-------------------------------
508 : : integer :: ndat__, iscale__, gpu_mode__
509 : : #ifdef HAVE_GPU_CUDA
510 : : logical :: transfer_ff
511 : : #endif
512 : : ! *************************************************************************
513 : :
514 : : !call wrtout(std_out, "in fftbox_execute_ip_dpc")
515 : :
516 : 12175 : ndat__ = ndat
517 [ + + ]: 12175 : ABI_DEFAULT(iscale__, iscale, 1)
518 [ - + + - ]: 12175 : ABI_DEFAULT(gpu_mode__, gpu_mode, 0)
519 : :
520 : : if (plan%gpu_option == ABI_GPU_OPENMP) then
521 : : #if defined HAVE_GPU_CUDA && defined HAVE_OPENMP_OFFLOAD
522 : : ! Build plan if not yet done. note batch_size instead of ndat.
523 : : if (.not. c_associated(plan%gpu_ctx_dpc)) then
524 : : call gpu_ctx_init(plan%gpu_ctx_dpc, plan%dims, plan%embed, plan%batch_size, dp)
525 : : end if
526 : :
527 : : if (ndat__ /= plan%batch_size) then
528 : : ! Have to rebuild the plan with batch_size == ndat.
529 : : call gpu_ctx_free(plan%gpu_ctx_dpc)
530 : : call gpu_ctx_init(plan%gpu_ctx_dpc, plan%dims, plan%embed, ndat__, dp)
531 : : end if
532 : :
533 : : plan%batch_size = ndat__
534 : :
535 : : transfer_ff = .False.
536 : : if (gpu_mode__ /= 0) then
537 : : transfer_ff = .not. xomp_target_is_present(c_loc(ff))
538 : : !$OMP TARGET ENTER DATA MAP(alloc:ff) IF(transfer_ff)
539 : : !$OMP TARGET UPDATE TO(ff) IF(transfer_ff)
540 : : end if
541 : :
542 : : !$OMP TARGET DATA USE_DEVICE_ADDR(ff)
543 : : call gpu_fftbox_c2c_ip(plan%gpu_ctx_dpc, int(plan%nfft), ndat__, isign, iscale__, dp, c_loc(ff))
544 : : call gpu_ctx_synch(plan%gpu_ctx_dpc)
545 : : !$OMP END TARGET DATA
546 : :
547 : : if (gpu_mode__ /= 0) then
548 : : !$OMP TARGET UPDATE FROM(ff) IF(transfer_ff)
549 : : !$OMP TARGET EXIT DATA MAP(delete:ff) IF(transfer_ff)
550 : : end if
551 : :
552 : : return
553 : : #endif
554 : : end if
555 : :
556 : : ! CPU version
557 : : #include "fftbox_ip_driver.finc"
558 : :
559 : 12175 : end subroutine fftbox_execute_ip_dpc
560 : : !!***
561 : :
562 : : !----------------------------------------------------------------------
563 : :
564 : : !!****f* m_fft/fftbox_execute_op_spc
565 : : !! NAME
566 : : !! fftbox_execute_op_spc
567 : : !!
568 : : !! FUNCTION
569 : : !! Out-of-place FFT transform of complex arrays.
570 : : !! Call (FFTW3|DFTI) routines if available, otherwise fallback to SG routines
571 : : !! TARGET: spc arrays
572 : : !!
573 : : !! INPUTS
574 : : !! ff(plan%ldxyz*plan%batch_size)=The input array to be transformed.
575 : : !! isign= Sign of the exponential in the FFT
576 : : !! ndat= Number of FFTs.
577 : : !! [iscale]= 0 if G --> R FFT should not be scaled. Default: 1 i.e. scale
578 : : !!
579 : : !! OUTPUT
580 : : !! gg(plan%ldxyz*ndat)= The FFT results.
581 : : !!
582 : : !! SOURCE
583 : :
584 : 48 : subroutine fftbox_execute_op_spc(plan, ff, gg, isign, &
585 : : ndat, iscale, gpu_mode)
586 : :
587 : : !Arguments ------------------------------------
588 : : !scalars
589 : : class(fftbox_plan3_t),intent(inout) :: plan
590 : : integer,intent(in) :: isign, ndat
591 : : integer,optional,intent(in) :: iscale, gpu_mode
592 : : !arrays
593 : : complex(sp),target,intent(in) :: ff(plan%ldxyz*ndat)
594 : : complex(sp),target,intent(inout) :: gg(plan%ldxyz*ndat)
595 : : !Local variables-------------------------------
596 : : integer :: ndat__, iscale__, gpu_mode__
597 : : #if defined HAVE_GPU_CUDA && defined HAVE_OPENMP_OFFLOAD
598 : : logical :: transfer_ff, transfer_gg
599 : : #endif
600 : : ! *************************************************************************
601 : :
602 : : !call wrtout(std_out, "in fftbox_execute_op_spc")
603 : :
604 : 48 : ndat__ = ndat
605 [ - + ]: 48 : ABI_DEFAULT(iscale__, iscale, 1)
606 [ - + + - ]: 48 : ABI_DEFAULT(gpu_mode__, gpu_mode, 0)
607 : :
608 : : if (plan%gpu_option == ABI_GPU_OPENMP) then
609 : : #if defined HAVE_GPU_CUDA && defined HAVE_OPENMP_OFFLOAD
610 : : ! Build plan if not yet done. note batch_size instead of ndat.
611 : : if (.not. c_associated(plan%gpu_ctx_spc)) then
612 : : call gpu_ctx_init(plan%gpu_ctx_spc, plan%dims, plan%embed, plan%batch_size, sp)
613 : : end if
614 : :
615 : : if (ndat__ /= plan%batch_size) then
616 : : ! Have to rebuild the plan with batch_size == ndat.
617 : : call gpu_ctx_free(plan%gpu_ctx_spc)
618 : : call gpu_ctx_init(plan%gpu_ctx_spc, plan%dims, plan%embed, ndat__, sp)
619 : : end if
620 : :
621 : : plan%batch_size = ndat__
622 : :
623 : : transfer_ff = .False.; transfer_gg = .False.
624 : : if (gpu_mode__ /= 0) then
625 : : transfer_ff = .not. xomp_target_is_present(c_loc(ff))
626 : : transfer_gg = .not. xomp_target_is_present(c_loc(gg))
627 : : !$OMP TARGET ENTER DATA MAP(alloc:ff) IF(transfer_ff)
628 : : !$OMP TARGET UPDATE TO(ff) IF(transfer_ff)
629 : : !$OMP TARGET ENTER DATA MAP(alloc:gg) IF(transfer_gg)
630 : : end if
631 : :
632 : : !$OMP TARGET DATA USE_DEVICE_ADDR(ff, gg)
633 : : call gpu_fftbox_c2c_op(plan%gpu_ctx_spc, int(plan%nfft), ndat__, isign, iscale__, sp, c_loc(ff), c_loc(gg))
634 : : call gpu_ctx_synch(plan%gpu_ctx_spc)
635 : : !$OMP END TARGET DATA
636 : :
637 : : if (gpu_mode__ /= 0) then
638 : : !$OMP TARGET UPDATE FROM(gg) IF(transfer_gg)
639 : : !$OMP TARGET EXIT DATA MAP(delete:gg) IF(transfer_gg)
640 : : end if
641 : :
642 : : return
643 : : #endif
644 : : end if
645 : :
646 : : ! CPU version
647 : : #include "fftbox_op_driver.finc"
648 : :
649 : 48 : end subroutine fftbox_execute_op_spc
650 : : !!***
651 : :
652 : : !----------------------------------------------------------------------
653 : :
654 : : !!****f* m_fft/fftbox_execute_op_dpc
655 : : !! NAME
656 : : !! fftbox_execute_op_dpc
657 : : !!
658 : : !! FUNCTION
659 : : !! Out-of-place FFT transform of complex arrays.
660 : : !! Call (FFTW3|DFTI) routines if available, otherwise fallback to SG routines
661 : : !! TARGET: dp arrays
662 : : !!
663 : : !! INPUTS
664 : : !! ff(plan%ldxyz*plan%batch_size)=The input array to be transformed.
665 : : !! isign= Sign of the exponential in the FFT
666 : : !! ndat=Number of FFTs.
667 : : !! [iscale]= 0 if G --> R FFT should not be scaled. Default: 1 i.e. scale
668 : : !!
669 : : !! OUTPUT
670 : : !! gg(plan%ldxyz*ndat)= The FFT results.
671 : : !!
672 : : !! SOURCE
673 : :
674 : 2910 : subroutine fftbox_execute_op_dpc(plan, ff, gg, isign, ndat, &
675 : : iscale, gpu_mode) ! optional
676 : :
677 : : !Arguments ------------------------------------
678 : : !scalars
679 : : class(fftbox_plan3_t),intent(inout) :: plan
680 : : integer,intent(in) :: isign, ndat
681 : : integer,optional,intent(in) :: iscale, gpu_mode
682 : : !arrays
683 : : complex(dp),target,intent(in) :: ff(plan%ldxyz*ndat)
684 : : complex(dp),target,intent(inout) :: gg(plan%ldxyz*ndat)
685 : :
686 : : !Local variables-------------------------------
687 : : integer :: ndat__, iscale__, gpu_mode__
688 : : #if defined HAVE_GPU_CUDA && defined HAVE_OPENMP_OFFLOAD
689 : : logical :: transfer_ff, transfer_gg
690 : : #endif
691 : : ! *************************************************************************
692 : :
693 : : !call wrtout(std_out, "in fftbox_execute_op_dpc")
694 : :
695 : 2910 : ndat__ = ndat
696 [ + + ]: 2910 : ABI_DEFAULT(iscale__, iscale, 1)
697 [ - + + - ]: 2910 : ABI_DEFAULT(gpu_mode__, gpu_mode, 0)
698 : :
699 : : if (plan%gpu_option == ABI_GPU_OPENMP) then
700 : : #if defined HAVE_GPU_CUDA && defined HAVE_OPENMP_OFFLOAD
701 : : ! Build plan if not yet done. note batch_size instead of ndat.
702 : : if (.not. c_associated(plan%gpu_ctx_dpc)) then
703 : : call gpu_ctx_init(plan%gpu_ctx_dpc, plan%dims, plan%embed, plan%batch_size, dp)
704 : : end if
705 : :
706 : : if (ndat__ /= plan%batch_size) then
707 : : ! Have to rebuild the plan with batch_size == ndat.
708 : : call gpu_ctx_free(plan%gpu_ctx_dpc)
709 : : call gpu_ctx_init(plan%gpu_ctx_dpc, plan%dims, plan%embed, ndat__, dp)
710 : : end if
711 : :
712 : : plan%batch_size = ndat__
713 : :
714 : : transfer_ff = .False.; transfer_gg = .False.
715 : : if (gpu_mode__ /= 0) then
716 : : transfer_ff = .not. xomp_target_is_present(c_loc(ff))
717 : : transfer_gg = .not. xomp_target_is_present(c_loc(gg))
718 : : !$OMP TARGET ENTER DATA MAP(alloc:ff) IF(transfer_ff)
719 : : !$OMP TARGET UPDATE TO(ff) IF(transfer_ff)
720 : : !$OMP TARGET ENTER DATA MAP(alloc:gg) IF(transfer_gg)
721 : : end if
722 : :
723 : : !$OMP TARGET DATA USE_DEVICE_ADDR(ff, gg)
724 : : call gpu_fftbox_c2c_op(plan%gpu_ctx_dpc, int(plan%nfft), ndat__, isign, iscale__, dp, c_loc(ff), c_loc(gg))
725 : : call gpu_ctx_synch(plan%gpu_ctx_dpc)
726 : : !$OMP END TARGET DATA
727 : :
728 : : if (gpu_mode__ /= 0) then
729 : : !$OMP TARGET UPDATE FROM(gg) IF(transfer_gg)
730 : : !$OMP TARGET EXIT DATA MAP(delete:gg) IF(transfer_gg)
731 : : end if
732 : :
733 : : return
734 : : #endif
735 : : end if
736 : :
737 : : ! CPU version
738 : : #include "fftbox_op_driver.finc"
739 : :
740 : 2910 : end subroutine fftbox_execute_op_dpc
741 : : !!***
742 : :
743 : : !----------------------------------------------------------------------
744 : :
745 : : !!****f* m_fft/fft_ug_sp
746 : : !! NAME
747 : : !! fft_ug_sp
748 : : !!
749 : : !! FUNCTION
750 : : !! Driver routine for G-->R transform of wavefunctions with zero-padded FFT.
751 : : !! TARGET: single precision real arrays with Re/Im.
752 : : !!
753 : : !! INPUTS
754 : : !! See fft_ug_dpc
755 : : !!
756 : : !! SOURCE
757 : :
758 : 0 : subroutine fft_ug_sp(npw_k, nfft, nspinor, ndat, mgfft, ngfft, istwf_k, kg_k, gbound_k, ug, ur)
759 : :
760 : : !Arguments ------------------------------------
761 : : !scalars
762 : : integer,intent(in) :: npw_k,nfft,nspinor,istwf_k,mgfft,ndat
763 : : !arrays
764 : : integer,intent(in) :: ngfft(18),gbound_k(2*mgfft+8,2),kg_k(3,npw_k)
765 : : real(sp),target,intent(in) :: ug(2*npw_k*nspinor*ndat)
766 : : real(sp),target,intent(out) :: ur(2*nfft*nspinor*ndat)
767 : :
768 : : !Local variables-------------------------------
769 : 0 : complex(sp),contiguous,pointer :: ug_cplx(:), ur_cplx(:)
770 : : ! *************************************************************************
771 : :
772 : 0 : call C_F_pointer(c_loc(ug), ug_cplx, shape=[npw_k*nspinor*ndat])
773 : 0 : call C_F_pointer(c_loc(ur), ur_cplx, shape=[nfft*nspinor*ndat])
774 : :
775 : 0 : call fft_ug_spc(npw_k, nfft, nspinor, ndat, mgfft, ngfft, istwf_k, kg_k, gbound_k, ug_cplx, ur_cplx)
776 : :
777 : 0 : end subroutine fft_ug_sp
778 : : !!***
779 : :
780 : : !!****f* m_fft/fft_ug_dp
781 : : !! NAME
782 : : !! fft_ug_dp
783 : : !!
784 : : !! FUNCTION
785 : : !! Driver routine for G-->R transform of wavefunctions with zero-padded FFT.
786 : : !! TARGET: double precision real arrays with Re/Im.
787 : : !!
788 : : !! INPUTS
789 : : !! See fft_ug_dpc
790 : : !!
791 : : !! SOURCE
792 : :
793 : 0 : subroutine fft_ug_dp(npw_k, nfft, nspinor, ndat, mgfft, ngfft, istwf_k, kg_k, gbound_k, ug, ur)
794 : :
795 : : !Arguments ------------------------------------
796 : : !scalars
797 : : integer,intent(in) :: npw_k,nfft,nspinor,istwf_k,mgfft,ndat
798 : : !arrays
799 : : integer,intent(in) :: ngfft(18),gbound_k(2*mgfft+8,2),kg_k(3,npw_k)
800 : : real(dp),target,intent(in) :: ug(*) !2*npw_k*nspinor*ndat)
801 : : real(dp),target,intent(out) :: ur(*) !2*nfft*nspinor*ndat)
802 : :
803 : : !Local variables-------------------------------
804 : 0 : complex(dp),contiguous,pointer :: ug_cplx(:), ur_cplx(:)
805 : : ! *************************************************************************
806 : :
807 : 0 : call C_F_pointer(c_loc(ug), ug_cplx, shape=[npw_k*nspinor*ndat])
808 : 0 : call C_F_pointer(c_loc(ur), ur_cplx, shape=[nfft*nspinor*ndat])
809 : :
810 : 0 : call fft_ug_dpc(npw_k, nfft, nspinor, ndat, mgfft, ngfft, istwf_k, kg_k, gbound_k, ug_cplx, ur_cplx)
811 : :
812 : 0 : end subroutine fft_ug_dp
813 : : !!***
814 : :
815 : : !----------------------------------------------------------------------
816 : :
817 : : !!****f* m_fft/fft_ug_spc
818 : : !! NAME
819 : : !! fft_ug_spc
820 : : !!
821 : : !! FUNCTION
822 : : !! Driver routine for G-->R transform of wavefunctions with zero-padded FFT.
823 : : !! TARGET: single precision arrays
824 : : !!
825 : : !! INPUTS
826 : : !! npw_k=number of plane waves for this k-point.
827 : : !! nfft=Number of FFT points.
828 : : !! nspinor=number of spinorial components
829 : : !! ndat=Number of wavefunctions to transform.
830 : : !! mgfft=Max number of FFT divisions
831 : : !! ngfft(18)=information about 3D FFT, see ~abinit/doc/variables/vargs.htm#ngfft
832 : : !! istwfk=Option describing the storage of the wavefunction. (at present must be 1)
833 : : !! kg_k(3,npw_k)=G-vectors in reduced coordinates
834 : : !! gbound_k_k(2*mgfft+8,2)=Table for padded-FFT. See sphereboundary.
835 : : !! ug(npw_k*nspinor*ndat)=wavefunctions in reciprocal space
836 : : !!
837 : : !! OUTPUT
838 : : !! ur(nfft*nspinor*ndat)=wavefunctions in real space.
839 : : !!
840 : : !! SOURCE
841 : :
842 [ - + + - ]: 36 : subroutine fft_ug_spc(npw_k, nfft, nspinor, ndat, mgfft, ngfft, istwf_k, kg_k, gbound_k, ug, ur)
843 : :
844 : : !Arguments ------------------------------------
845 : : !scalars
846 : : integer,intent(in) :: npw_k,nfft,nspinor,istwf_k,mgfft,ndat
847 : : !arrays
848 : : integer,intent(in) :: ngfft(18),gbound_k(2*mgfft+8,2),kg_k(3,npw_k)
849 : : complex(sp),intent(in) :: ug(*) !npw_k*nspinor*ndat)
850 : : complex(sp),intent(out) :: ur(*) !nfft*nspinor*ndat)
851 : : ! *************************************************************************
852 : :
853 : : #include "fftug_driver.finc"
854 : :
855 : 36 : end subroutine fft_ug_spc
856 : : !!***
857 : :
858 : : !----------------------------------------------------------------------
859 : :
860 : : !!****f* m_fft/fft_ug_dpc
861 : : !! NAME
862 : : !! fft_ug_dpc
863 : : !!
864 : : !! FUNCTION
865 : : !! Driver routine for G-->R transform of wavefunctions with zero-padded FFT.
866 : : !! TARGET: double precision arrays
867 : : !!
868 : : !! INPUTS
869 : : !! npw_k=number of plane waves for this k-point.
870 : : !! nfft=Number of FFT points.
871 : : !! nspinor=number of spinorial components
872 : : !! ndat=Number of wavefunctions to transform.
873 : : !! mgfft=Max number of FFT divisions
874 : : !! ngfft(18)=information about 3D FFT, see ~abinit/doc/variables/vargs.htm#ngfft
875 : : !! istwfk=Option describing the storage of the wavefunction. (at present must be 1)
876 : : !! kg_k(3,npw_k)=G-vectors in reduced coordinates
877 : : !! gbound_k_k(2*mgfft+8,2)=Table for padded-FFT. See sphereboundary.
878 : : !! ug(npw_k*nspinor*ndat)=wavefunctions in reciprocal space
879 : : !!
880 : : !! OUTPUT
881 : : !! ur(nfft*nspinor*ndat)=wavefunctions in real space.
882 : : !!
883 : : !! SOURCE
884 : :
885 [ - + + - ]: 215446 : subroutine fft_ug_dpc(npw_k, nfft, nspinor, ndat, mgfft, ngfft, istwf_k, kg_k, gbound_k, ug, ur)
886 : :
887 : : !Arguments ------------------------------------
888 : : !scalars
889 : : integer,intent(in) :: npw_k,nfft,nspinor,istwf_k,mgfft,ndat
890 : : !arrays
891 : : integer,intent(in) :: ngfft(18),gbound_k(2*mgfft+8,2),kg_k(3,npw_k)
892 : : complex(dp),intent(in) :: ug(*) !npw_k*nspinor*ndat)
893 : : complex(dp),intent(out) :: ur(*) !nfft*nspinor*ndat)
894 : : ! *************************************************************************
895 : :
896 : : #include "fftug_driver.finc"
897 : :
898 : 215446 : end subroutine fft_ug_dpc
899 : : !!***
900 : :
901 : : !!****f* m_fft/fft_ur_dp
902 : : !! NAME
903 : : !! fft_ur_dp
904 : : !!
905 : : !! FUNCTION
906 : : !! Compute ndat zero-padded FFTs from R- to G-space .
907 : : !! Mainly used for the transform of wavefunctions.
908 : : !! TARGET: double precision real arrays with re/im
909 : : !!
910 : : !! INPUTS
911 : : !! See fft_ur_dpc
912 : : !!
913 : : !! SOURCE
914 : :
915 : 0 : subroutine fft_ur_dp(npw_k, nfft, nspinor, ndat, mgfft, ngfft, istwf_k, kg_k, gbound_k, ur, ug)
916 : :
917 : : !Arguments ------------------------------------
918 : : !scalars
919 : : integer,intent(in) :: npw_k,nfft,nspinor,ndat,istwf_k,mgfft
920 : : !arrays
921 : : integer,intent(in) :: ngfft(18),gbound_k(2*mgfft+8,2), kg_k(3,npw_k)
922 : : real(dp),target,intent(inout) :: ur(*) !2*nfft*nspinor*ndat)
923 : : real(dp),target,intent(out) :: ug(*) !2*npw_k*nspinor*ndat)
924 : :
925 : : !Local variables-------------------------------
926 : 0 : complex(dp),contiguous,pointer :: ug_cplx(:), ur_cplx(:)
927 : : ! *************************************************************************
928 : :
929 : 0 : call C_F_pointer(c_loc(ug), ug_cplx, shape=[npw_k*nspinor*ndat])
930 : 0 : call C_F_pointer(c_loc(ur), ur_cplx, shape=[nfft*nspinor*ndat])
931 : 0 : call fft_ur_dpc(npw_k, nfft, nspinor, ndat, mgfft, ngfft, istwf_k, kg_k, gbound_k, ur_cplx, ug_cplx)
932 : :
933 : 0 : end subroutine fft_ur_dp
934 : : !!***
935 : :
936 : : !----------------------------------------------------------------------
937 : :
938 : : !!****f* m_fft/fft_ur_spc
939 : : !! NAME
940 : : !! fft_ur_spc
941 : : !!
942 : : !! FUNCTION
943 : : !! Compute ndat zero-padded FFTs from R- to G-space .
944 : : !! Mainly used for the transform of wavefunctions.
945 : : !! TARGET: spc complex arrays
946 : : !!
947 : : !! INPUTS
948 : : !! npw_k=number of plane waves for this k-point.
949 : : !! nfft=Number of FFT points.
950 : : !! nspinor=number of spinorial components
951 : : !! ndat=Number of wavefunctions to transform.
952 : : !! mgfft=Max number of FFT divisions
953 : : !! ngfft(18)=contain all needed information about 3D FFT, see ~abinit/doc/variables/vargs.htm#ngfft
954 : : !! istwfk=Option describing the storage of the wavefunction. (at present must be 1)
955 : : !! kg_k(3,npw_k)=G-vectors in reduced coordinates
956 : : !! gbound_k(2*mgfft+8,2)=Table for padded-FFT. See sphereboundary.
957 : : !!
958 : : !! SIDE EFFECTS
959 : : !! ur(nfft*nspinor*ndat)=In input: wavefunctions in real space
960 : : !! Destroyed in output. Do not use ur anymore!
961 : : !!
962 : : !! OUTPUT
963 : : !! ug(npw_k*nspinor*ndat)=wavefunctions in reciprocal space given on the G-sphere.
964 : : !!
965 : : !! SOURCE
966 : :
967 [ - + + - ]: 36 : subroutine fft_ur_spc(npw_k, nfft, nspinor, ndat, mgfft, ngfft, istwf_k, kg_k, gbound_k, ur, ug)
968 : :
969 : : !Arguments ------------------------------------
970 : : !scalars
971 : : integer,intent(in) :: npw_k,nfft,nspinor,ndat,istwf_k,mgfft
972 : : !arrays
973 : : integer,intent(in) :: ngfft(18),gbound_k(2*mgfft+8,2),kg_k(3,npw_k)
974 : : complex(sp),intent(inout) :: ur(*) !nfft*nspinor*ndat)
975 : : complex(sp),intent(out) :: ug(*) !npw_k*nspinor*ndat)
976 : : ! *************************************************************************
977 : :
978 : : #include "fftur_driver.finc"
979 : :
980 : 36 : end subroutine fft_ur_spc
981 : : !!***
982 : :
983 : : !----------------------------------------------------------------------
984 : :
985 : : !!****f* m_fft/fft_ur_dpc
986 : : !! NAME
987 : : !! fft_ur_dpc
988 : : !!
989 : : !! FUNCTION
990 : : !! Compute ndat zero-padded FFTs from R- to G-space .
991 : : !! Mainly used for the transform of wavefunctions.
992 : : !! TARGET: dp complex arrays
993 : : !!
994 : : !! INPUTS
995 : : !! npw_k=number of plane waves for this k-point.
996 : : !! nfft=Number of FFT points.
997 : : !! nspinor=number of spinorial components
998 : : !! ndat=Number of wavefunctions to transform.
999 : : !! mgfft=Max number of FFT divisions
1000 : : !! ngfft(18)=contain all needed information about 3D FFT, see ~abinit/doc/variables/vargs.htm#ngfft
1001 : : !! istwfk=Option describing the storage of the wavefunction. (at present must be 1)
1002 : : !! kg_k(3,npw_k)=G-vectors in reduced coordinates
1003 : : !! gbound_k(2*mgfft+8,2)=Table for padded-FFT. See sphereboundary.
1004 : : !!
1005 : : !! SIDE EFFECTS
1006 : : !! ur(nfft*nspinor*ndat)=In input: wavefunctions in real space
1007 : : !! Destroyed in output. Do not use ur anymore!
1008 : : !!
1009 : : !! OUTPUT
1010 : : !! ug(npw_k*nspinor*ndat)=wavefunctions in reciprocal space given on the G-sphere.
1011 : : !!
1012 : : !! SOURCE
1013 : :
1014 [ - + + - ]: 780009 : subroutine fft_ur_dpc(npw_k, nfft, nspinor, ndat, mgfft, ngfft, istwf_k, kg_k, gbound_k, ur, ug)
1015 : :
1016 : : !Arguments ------------------------------------
1017 : : !scalars
1018 : : integer,intent(in) :: npw_k,nfft,nspinor,ndat,istwf_k,mgfft
1019 : : !arrays
1020 : : integer,intent(in) :: ngfft(18),gbound_k(2*mgfft+8,2),kg_k(3,npw_k)
1021 : : complex(dp),intent(inout) :: ur(*) ! nfft*nspinor*ndat)
1022 : : complex(dp),intent(out) :: ug(*) ! npw_k*nspinor*ndat)
1023 : : ! *************************************************************************
1024 : :
1025 : : #include "fftur_driver.finc"
1026 : :
1027 : 780009 : end subroutine fft_ur_dpc
1028 : : !!***
1029 : :
1030 : : !----------------------------------------------------------------------
1031 : :
1032 : : !!****f* m_fft/fftpad_spc
1033 : : !! NAME
1034 : : !! fftpad_spc
1035 : : !!
1036 : : !! FUNCTION
1037 : : !! Driver routine used to transform COMPLEX arrays using 3D zero-padded FFTs.
1038 : : !! TARGET: single-precision complex.
1039 : : !!
1040 : : !! INPUTS
1041 : : !! ngfft(18)=Info on the 3D FFT.
1042 : : !! nx,ny,nz=Logical dimensions of the FFT mesh.
1043 : : !! ldx,ldy,ldz=Physical dimension of the f array (to avoid cache conflicts).
1044 : : !! ndat=Number of FFTs
1045 : : !! mgfft=MAX(nx,ny,nz), only used to dimension gbound
1046 : : !! isign=The sign of the transform.
1047 : : !! gbound(2*mgfft+8,2)= The boundaries of the basis sphere of G vectors at a given k-point.
1048 : : !! See sphereboundary for more info.
1049 : : !!
1050 : : !! SIDE EFFECTS
1051 : : !! ff(ldx*ldy*ldz*ndat)=
1052 : : !! input: The array with the data to be transformed.
1053 : : !! output: The results of the FFT.
1054 : : !!
1055 : : !! SOURCE
1056 : :
1057 : 0 : subroutine fftpad_spc(ff, ngfft, nx, ny, nz, ldx, ldy, ldz, ndat, mgfft, isign, gbound)
1058 : :
1059 : : !Arguments ------------------------------------
1060 : : !scalars
1061 : : integer,intent(in) :: nx,ny,nz,ldx,ldy,ldz,ndat,mgfft,isign
1062 : : !arrays
1063 : : integer,intent(in) :: ngfft(18),gbound(2*mgfft+8,2)
1064 : : complex(sp),target,intent(inout) :: ff(ldx*ldy*ldz*ndat)
1065 : :
1066 : : !Local variables-------------------------------
1067 : : !scalars
1068 : : integer :: fftalg,fftalga,fftalgc,ncount,p
1069 : : character(len=500) :: msg
1070 : : !arrays
1071 : 0 : real(dp),allocatable :: fofr(:,:),ftarr(:,:)
1072 : : ! *************************************************************************
1073 : :
1074 : 0 : fftalg=ngfft(7); fftalga=fftalg/100; fftalgc=MOD(fftalg,10)
1075 : :
1076 : 0 : select case (fftalga)
1077 : :
1078 : : case (FFT_FFTW3)
1079 : 0 : call fftw3_fftpad(ff, nx, ny, nz, ldx, ldy, ldz, ndat, mgfft, isign, gbound)
1080 : :
1081 : : case (FFT_DFTI)
1082 : 0 : call dfti_fftpad(ff, nx, ny, nz, ldx, ldy, ldz, ndat, mgfft, isign, gbound)
1083 : :
1084 : : case (FFT_SG)
1085 : : ! Goedecker"s routines.
1086 : : ! TODO: sg_fftpad is not the fastest routine, here I should call sg_fftrisc but I need
1087 : : ! kg_kin that are not available in rho_tw_g, actually one should pass G-G0 due to
1088 : : ! the shift introduced by the umklapp.
1089 : 0 : ncount = ldx*ldy*ldz*ndat
1090 : :
1091 [ # # # # : 0 : ABI_MALLOC(fofr,(2,ldx*ldy*ldz*ndat))
# # # # #
# # # ]
1092 [ # # # # : 0 : ABI_MALLOC(ftarr,(2,ldx*ldy*ldz*ndat))
# # # # ]
1093 : :
1094 [ # # ]: 0 : do p=1,ldx*ldy*ldz*ndat
1095 : 0 : fofr(1,p) = REAL(ff(p))
1096 : 0 : fofr(2,p) = AIMAG(ff(p))
1097 : : end do
1098 : :
1099 : 0 : call sg_fftpad(ngfft(8),mgfft,nx,ny,nz,ldx,ldy,ldz,ndat,gbound,isign,fofr,ftarr)
1100 : : !
1101 : : ! Copy the results.
1102 [ # # ]: 0 : do p=1,ldx*ldy*ldz*ndat
1103 : 0 : ff(p) = CMPLX(ftarr(1,p), ftarr(2,p))
1104 : : end do
1105 : :
1106 [ # # ]: 0 : if (isign==-1) then ! Here there might be numerical exceptions due to the holes.
1107 [ # # ]: 0 : ff = ff/(nx*ny*nz)
1108 : : end if
1109 : :
1110 [ # # ]: 0 : ABI_FREE(ftarr)
1111 [ # # ]: 0 : ABI_FREE(fofr)
1112 : :
1113 : : case default
1114 : 0 : write(msg,'(a,i0,a)')"fftalga = ", fftalga," not coded "
1115 [ # # # # ]: 0 : ABI_ERROR(msg)
1116 : : end select
1117 : :
1118 : 0 : end subroutine fftpad_spc
1119 : : !!***
1120 : :
1121 : : !----------------------------------------------------------------------
1122 : :
1123 : : !!****f* m_fft/fftpad_dpc
1124 : : !! NAME
1125 : : !! fftpad_dpc
1126 : : !!
1127 : : !! FUNCTION
1128 : : !! Driver routine used to transform COMPLEX arrays using 3D zero-padded FFTs.
1129 : : !! TARGET: DP arrays
1130 : : !!
1131 : : !! INPUTS
1132 : : !! ngfft(18)=Info on the 3D FFT.
1133 : : !! nx,ny,nz=Logical dimensions of the FFT mesh.
1134 : : !! ldx,ldy,ldz=Physical dimension of the f array (to avoid cache conflicts).
1135 : : !! ndat=Number of FFTs
1136 : : !! mgfft=MAX(nx,ny,nz), only used to dimension gbound
1137 : : !! isign=The sign of the transform.
1138 : : !! gbound(2*mgfft+8,2)= The boundaries of the basis sphere of G vectors at a given k-point. See sphereboundary for more info.
1139 : : !!
1140 : : !! SIDE EFFECTS
1141 : : !! ff(ldx*ldy*ldz*ndat)=
1142 : : !! input: The array with the data to be transformed.
1143 : : !! output: The results of the FFT.
1144 : : !!
1145 : : !! SOURCE
1146 : :
1147 : 5736835 : subroutine fftpad_dpc(ff, ngfft, nx, ny, nz, ldx, ldy, ldz, ndat, mgfft, isign, gbound)
1148 : :
1149 : : !Arguments ------------------------------------
1150 : : !scalars
1151 : : integer,intent(in) :: nx,ny,nz,ldx,ldy,ldz,ndat,mgfft,isign
1152 : : !arrays
1153 : : integer,intent(in) :: ngfft(18),gbound(2*mgfft+8,2)
1154 : : complex(dp),target,intent(inout) :: ff(ldx*ldy*ldz*ndat)
1155 : :
1156 : : !Local variables-------------------------------
1157 : : !scalars
1158 : : integer :: fftalg,fftalga,fftalgc,ncount, ivz
1159 : : !arrays
1160 : 5736835 : real(dp),allocatable :: fofr(:,:,:,:,:), fofrvz(:,:)
1161 : 5736835 : real(dp),contiguous, pointer :: fpt_ftarr(:,:,:,:,:)
1162 : : ! *************************************************************************
1163 : :
1164 : 5736835 : fftalg=ngfft(7); fftalga=fftalg/100; fftalgc=MOD(fftalg,10)
1165 : :
1166 : 0 : select case (fftalga)
1167 : :
1168 : : case (FFT_FFTW3)
1169 : 0 : call fftw3_fftpad(ff, nx, ny, nz, ldx, ldy, ldz, ndat, mgfft, isign, gbound)
1170 : :
1171 : : case (FFT_DFTI)
1172 : 5736830 : call dfti_fftpad(ff, nx, ny, nz, ldx, ldy, ldz, ndat, mgfft, isign, gbound)
1173 : :
1174 : : case (FFT_SG)
1175 : : ! Goedecker"s routines.
1176 : : ! TODO: sg_fftpad is not the fastest routine, here I should call sg_fftrisc but I need
1177 : : ! kg_kin that is not available in rho_tw_g, actually one should pass G-G0 due to
1178 : : ! the shift introduced by the umklapp.
1179 : 5 : ncount = ldx*ldy*ldz*ndat
1180 : :
1181 [ - + + - : 30 : ABI_MALLOC(fofr, (2,ldx,ldy,ldz,ndat))
- + + - -
+ + - - +
+ - + - +
- - + -
+ ]
1182 : : !call ZCOPY(ncount,ff,1,fofr,1) !vz_d
1183 : : !call DCOPY(2*ncount,ff,1,fofr,1) ! MG
1184 : : ! alternative of ZCOPY from vz
1185 [ - + + - : 15 : ABI_MALLOC(fofrvz,(2,ncount))
+ - + - -
+ - + ]
1186 [ + + ]: 3645005 : do ivz=1,ncount
1187 : 3645000 : fofrvz(1,ivz)= real(ff(ivz))
1188 : 3645005 : fofrvz(2,ivz)=aimag(ff(ivz))
1189 : : end do
1190 : 5 : call DCOPY(2*ncount,fofrvz,1,fofr,1)
1191 [ - + ]: 5 : ABI_FREE(fofrvz)
1192 : :
1193 : 5 : call C_F_pointer(C_loc(ff),fpt_ftarr, shape=(/2,ldx,ldy,ldz,ndat/))
1194 : :
1195 : : ! MT nov. 2012: with xlf, need to put explicit boundaries for the 4th dimension
1196 : : ! this looks like a compiler bug...
1197 : : !if (size(fpt_ftarr)==2*size(ff)) then
1198 : 5 : call sg_fftpad(ngfft(8),mgfft,nx,ny,nz,ldx,ldy,ldz,ndat,gbound,isign,fofr,fpt_ftarr)
1199 : : !else
1200 : : ! call sg_fftpad(ngfft(8),mgfft,nx,ny,nz,ldx,ldy,ldz,ndat,gbound,isign,fofr,fpt_ftarr(:,:,:,1:ldz,dat))
1201 : : !end if
1202 : :
1203 [ - + ]: 5 : ABI_FREE(fofr)
1204 : :
1205 [ + - ]: 5 : if (isign==-1) then ! Here there might be numerical exceptions due to the holes.
1206 : 5 : call xscal(ncount,one/(nx*ny*nz),ff,1)
1207 : : end if
1208 : :
1209 : : case default
1210 : 0 : ABI_BUG(sjoin("Wrong value for fftalga: ",itoa(fftalga)))
1211 : : end select
1212 : :
1213 [ - + + - ]: 5736835 : end subroutine fftpad_dpc
1214 : : !!***
1215 : :
1216 : : !----------------------------------------------------------------------
1217 : :
1218 : : !!****f* m_fft/fft_poisson
1219 : : !! NAME
1220 : : !! fft_poisson
1221 : : !!
1222 : : !! FUNCTION
1223 : : !! Driver routine to solve the Poisson equation in G-space given the density, n(r),
1224 : : !! in real space of the FFT box.
1225 : : !!
1226 : : !! INPUTS
1227 : : !! ngfft(18)=Info on the 3D FFT.
1228 : : !! cplex=1 if fofr is real, 2 if fofr is complex
1229 : : !! nx,ny,nz=Number of FFT points along the three directions.
1230 : : !! ldx,ldy,ldz=Leading dimension of the array nr and vg.
1231 : : !! ndat = Number of densities
1232 : : !! vg(nx*ny*nz)=Potential in reciprocal space.
1233 : : !!
1234 : : !! SIDE EFFECTS
1235 : : !! nr(cplex*ldx*ldy*ldz*ndat)
1236 : : !! input: n(r) (real or complex)
1237 : : !! output: the hartree potential in real space
1238 : : !!
1239 : : !! NOTES
1240 : : !! vg is given on the FFT mesh instead of the augmented mesh [ldx,ldy,ldz]
1241 : : !! in order to simplify the interface with the other routines operating of vg
1242 : : !!
1243 : : !! SOURCE
1244 : :
1245 : 0 : subroutine fft_poisson(ngfft, cplex, nx, ny, nz, ldx, ldy, ldz, ndat, vg, nr)
1246 : :
1247 : : !Arguments ------------------------------------
1248 : : !scalars
1249 : : integer,intent(in) :: cplex,nx,ny,nz,ldx,ldy,ldz,ndat
1250 : : integer,intent(in) :: ngfft(18)
1251 : : !arrays
1252 : : real(dp),intent(inout) :: nr(cplex*ldx*ldy*ldz*ndat)
1253 : : real(dp),intent(in) :: vg(nx*ny*nz)
1254 : :
1255 : : !Local variables-------------------------------
1256 : : integer :: fftalga, fftcache
1257 : : ! *************************************************************************
1258 : :
1259 : 0 : fftalga = ngfft(7)/100; fftcache = ngfft(8)
1260 : :
1261 : 0 : select case (fftalga)
1262 : : case (FFT_SG, FFT_SG2002)
1263 : : ! Note: according to my tests fftalg 1xx is always faster than 4xx in sequential
1264 : : ! hence it does not make sense to provide a fallback for fftalg 4xx.
1265 : : ! Use external FFT libraries if you want to run at top-level speed.
1266 : 0 : call sg_poisson(fftcache,cplex,nx,ny,nz,ldx,ldy,ldz,ndat,vg,nr)
1267 : :
1268 : : case (FFT_FFTW3)
1269 : 0 : call fftw3_poisson(cplex,nx,ny,nz,ldx,ldy,ldz,ndat,vg,nr)
1270 : :
1271 : : !case (FFT_DFTI)
1272 : : ! call dfti_poisson(cplex,nx,ny,nz,ldx,ldy,ldz,ndat,vg,nr)
1273 : :
1274 : : case default
1275 [ # # # ]: 0 : ABI_BUG(sjoin("Wrong value for fftalga: ",itoa(fftalga)))
1276 : : end select
1277 : :
1278 : 0 : end subroutine fft_poisson
1279 : : !!***
1280 : :
1281 : : !----------------------------------------------------------------------
1282 : :
1283 : : !!****f* m_fft/fft_use_lib_threads
1284 : : !! NAME
1285 : : !! fft_use_lib_threads
1286 : : !!
1287 : : !! FUNCTION
1288 : : !!
1289 : : !! INPUTS
1290 : : !!
1291 : : !! OUTPUT
1292 : : !!
1293 : : !! SOURCE
1294 : :
1295 : 19 : subroutine fft_use_lib_threads(logvar)
1296 : :
1297 : : !Arguments ------------------------------------
1298 : : logical,intent(in) :: logvar
1299 : : ! *************************************************************************
1300 : :
1301 : 19 : call dfti_use_lib_threads(logvar)
1302 : 19 : call fftw3_use_lib_threads(logvar)
1303 : :
1304 : 19 : end subroutine fft_use_lib_threads
1305 : : !!***
1306 : :
1307 : : !----------------------------------------------------------------------
1308 : :
1309 : : !!****f* m_fft/fftbox_utests
1310 : : !! NAME
1311 : : !! fftbox_utests
1312 : : !!
1313 : : !! FUNCTION
1314 : : !! Driver routine for base unitary tests of the FFT routines (sequential version).
1315 : : !!
1316 : : !! INPUTS
1317 : : !! fftalg =fftalg input variable.
1318 : : !! ndat = Number of transform to execute
1319 : : !! nthreads = Number of OpenMP threads.
1320 : : !! gpu_option= GPU version to active (0: no GPU).
1321 : : !! [unit]=Output Unit number (DEFAULT std_out)
1322 : : !!
1323 : : !! OUTPUT
1324 : : !! nfailed=number of failures.
1325 : : !!
1326 : : !! SOURCE
1327 : :
1328 : 4 : integer function fftbox_utests(fftalg, ndat, nthreads, gpu_option, unit) result(nfailed)
1329 : :
1330 : : !Arguments -----------------------------------
1331 : : !scalars
1332 : : integer,intent(in) :: fftalg, ndat, nthreads, gpu_option
1333 : : integer,optional,intent(in) :: unit
1334 : :
1335 : : !Local variables-------------------------------
1336 : : !scalars
1337 : : integer,parameter :: NSETS=6, fftcache0 = 0
1338 : : integer :: ifft,ierr,ldxyz,old_nthreads,ount,cplex,ii
1339 : : integer :: iset,nx,ny,nz,ldx,ldy,ldz,fftalga,fftalgc
1340 : : real(dp),parameter :: ATOL_SP=tol6,ATOL_DP=tol12 ! Tolerances on the absolute errors
1341 : : real(dp) :: max_abserr
1342 : : character(len=500) :: msg,info,library,cplex_mode,padding_mode
1343 : : type(fftbox_plan3_t) :: box_plan
1344 : : !arrays
1345 : : integer :: pars(6,NSETS), ngfft(18)
1346 : : real(dp) :: crand(2)
1347 : 4 : real(dp),allocatable :: fofg(:),fofr_ref(:),fofr(:)
1348 : 4 : complex(dp),allocatable :: ff(:),ff_ref(:),gg(:)
1349 : 4 : complex(sp),allocatable :: ffsp(:),ff_refsp(:),ggsp(:)
1350 : : ! *************************************************************************
1351 : :
1352 : 4 : nfailed = 0
1353 : 0 : ount = std_out; if (PRESENT(unit)) ount = unit
1354 : : !return
1355 : :
1356 [ + - ]: 4 : if (nthreads > 0) then
1357 : 4 : old_nthreads = xomp_get_max_threads()
1358 : 4 : call xomp_set_num_threads(nthreads)
1359 : : end if
1360 : :
1361 : : ! These values must be compatible with all the FFT routines.
1362 : : ! SG library is the most restrictive (only powers of 2,3,5).
1363 : : pars = RESHAPE( [ &
1364 : : 12, 18, 15, 12, 18, 15, &
1365 : : 12, 18, 15, 13, 19, 16, &
1366 : : 12, 18, 15, 13, 19, 15, &
1367 : : 12, 18, 15, 12, 18, 16, &
1368 : : 12, 18, 15, 13, 18, 15, &
1369 : : 12, 18, 15, 15, 21, 18 &
1370 : 4 : ], [6, NSETS])
1371 : : !pars = 10 * pars
1372 : :
1373 [ - + ]: 4 : if (gpu_option /= ABI_GPU_DISABLED) then
1374 : : ! Augmentation is not supported for GPUS.
1375 [ # # ]: 0 : do ii=1,NSETS
1376 [ # # ]: 0 : pars(4:6, ii) = pars(1:3, ii)
1377 : : end do
1378 : : end if
1379 : :
1380 : 4 : fftalga=fftalg/100; fftalgc=mod(fftalg,10)
1381 : :
1382 : 4 : call fftalg_info(fftalg, library, cplex_mode, padding_mode)
1383 : :
1384 [ + + ]: 28 : do iset=1,SIZE(pars,DIM=2)
1385 : : !if (iset == 2) return
1386 : 24 : nx =pars(1,iset); ny=pars(2,iset); nz=pars(3,iset)
1387 : 24 : ldx=pars(4,iset); ldy=pars(5,iset); ldz=pars(6,iset)
1388 : :
1389 [ + + ]: 96 : call ngfft_seq(ngfft, [nx,ny,nz])
1390 [ + + ]: 96 : ngfft(4:6) = [ldx, ldy, ldz]
1391 : :
1392 : : ! Create the FFT plan
1393 : 24 : call box_plan%init(ndat, pars(1,iset), pars(4,iset), fftalg, fftcache0, gpu_option)
1394 : :
1395 : 24 : ldxyz = ldx*ldy*ldz
1396 : :
1397 : : ! ======================================
1398 : : ! === TEST the single precision version
1399 : : ! ======================================
1400 [ - + + - : 72 : ABI_MALLOC(ff_refsp, (ldxyz*ndat))
+ - + - -
+ - + ]
1401 [ - + + - : 48 : ABI_MALLOC(ffsp, (ldxyz*ndat))
- + - + ]
1402 [ - + + - : 48 : ABI_MALLOC(ggsp, (ldxyz*ndat))
- + - + ]
1403 : :
1404 [ + + ]: 235354 : do ifft=1,ldxyz*ndat
1405 : 235330 : call RANDOM_NUMBER(crand)
1406 : 235354 : ff_refsp(ifft) = DCMPLX(crand(1), crand(2))
1407 : : end do
1408 : : ! Set the augmentation region to zero to avoid SIGFPE, as FFTW3 wrappers use zscal to scale the results.
1409 : 24 : call cplx_setaug_zero_spc(nx,ny,nz,ldx,ldy,ldz,ndat,ff_refsp)
1410 : :
1411 : : ! in-place version.
1412 [ - + + + ]: 235378 : ffsp = ff_refsp
1413 : : #ifdef HAVE_OPENMP_OFFLOAD
1414 : : !$OMP TARGET ENTER DATA MAP(to:ffsp) IF (gpu_option == ABI_GPU_OPENMP)
1415 : : #endif
1416 : 24 : call box_plan%execute(ffsp, +1, ndat)
1417 : 24 : call box_plan%execute(ffsp, -1, ndat)
1418 : : #ifdef HAVE_OPENMP_OFFLOAD
1419 : : !$OMP TARGET EXIT DATA MAP(from:ffsp) IF (gpu_option == ABI_GPU_OPENMP)
1420 : : #endif
1421 : :
1422 [ + + - + ]: 235354 : ierr = COUNT(ABS(ffsp - ff_refsp) > ATOL_SP)
1423 : 24 : nfailed = nfailed + ierr
1424 [ + - ]: 24 : info = sjoin(library, "c2c_ip_spc :")
1425 : 24 : write(msg,"(a)")" OK"
1426 [ - + ]: 24 : if (ierr /= 0) then
1427 [ # # # # : 0 : max_abserr = MAXVAL(ABS(ffsp - ff_refsp))
# # # # ]
1428 : 0 : write(msg,"(a,es9.2,a)")" FAILED (max_abserr = ",max_abserr,")"
1429 : : end if
1430 : 24 : call wrtout(ount, sjoin(info,msg))
1431 : :
1432 : : ! out-of-place version.
1433 [ - + + + ]: 235378 : ffsp = ff_refsp
1434 : : #ifdef HAVE_OPENMP_OFFLOAD
1435 : : !$OMP TARGET ENTER DATA MAP(to:ffsp) MAP(alloc: ggsp) IF (gpu_option == ABI_GPU_OPENMP)
1436 : : #endif
1437 : 24 : call box_plan%execute(ffsp, ggsp, +1, ndat)
1438 [ + + ]: 235354 : ffsp = zero
1439 : 24 : call box_plan%execute(ggsp, ffsp, -1, ndat)
1440 : : #ifdef HAVE_OPENMP_OFFLOAD
1441 : : !$OMP TARGET EXIT DATA MAP(from:ffsp) IF (gpu_option == ABI_GPU_OPENMP)
1442 : : #endif
1443 : :
1444 [ + + - + ]: 235354 : ierr = COUNT(ABS(ffsp - ff_refsp) > ATOL_SP)
1445 : 24 : nfailed = nfailed + ierr
1446 [ + - ]: 24 : info = sjoin(library, "c2c_op_spc :")
1447 : 24 : write(msg,"(a)")" OK"
1448 [ - + ]: 24 : if (ierr /= 0) then
1449 [ # # # # : 0 : max_abserr = MAXVAL(ABS(ffsp - ff_refsp))
# # # # ]
1450 : 0 : write(msg,"(a,es9.2,a)")" FAILED (max_abserr = ",max_abserr,")"
1451 : : end if
1452 : 24 : call wrtout(ount, sjoin(info, msg))
1453 : :
1454 : : #ifdef HAVE_OPENMP_OFFLOAD
1455 : : !$OMP TARGET EXIT DATA MAP(delete: ffsp, ggsp) if (gpu_option == ABI_GPU_OPENMP)
1456 : : #endif
1457 [ - + ]: 24 : ABI_FREE(ffsp)
1458 [ - + ]: 24 : ABI_FREE(ggsp)
1459 [ - + ]: 24 : ABI_FREE(ff_refsp)
1460 : :
1461 : : ! =======================================
1462 : : ! === TEST the double precision version
1463 : : ! =======================================
1464 [ - + + - : 72 : ABI_MALLOC(ff_ref, (ldxyz*ndat))
+ - + - -
+ - + ]
1465 [ - + + - : 48 : ABI_MALLOC(ff, (ldxyz*ndat))
- + - + ]
1466 [ - + + - : 48 : ABI_MALLOC(gg, (ldxyz*ndat))
- + - + ]
1467 : :
1468 [ + + ]: 235354 : do ifft=1,ldxyz*ndat
1469 : 235330 : call RANDOM_NUMBER(crand)
1470 : 235354 : ff_ref(ifft) = DCMPLX(crand(1), crand(2))
1471 : : end do
1472 : :
1473 : : ! Set the augmentation region to zero to avoid SIGFPE, as FFTW3 wrappers use zscal to scale the results.
1474 : 24 : call cplx_setaug_zero_dpc(nx,ny,nz,ldx,ldy,ldz,ndat,ff_ref)
1475 : :
1476 : : ! in-place version.
1477 [ - + + + ]: 235378 : ff = ff_ref
1478 : : #ifdef HAVE_OPENMP_OFFLOAD
1479 : : !$OMP TARGET ENTER DATA MAP(to:ff) IF (gpu_option == ABI_GPU_OPENMP)
1480 : : #endif
1481 : 24 : call box_plan%execute(ff, +1, ndat)
1482 : 24 : call box_plan%execute(ff, -1, ndat)
1483 : : #ifdef HAVE_OPENMP_OFFLOAD
1484 : : !$OMP TARGET EXIT DATA MAP(from:ff) IF (gpu_option == ABI_GPU_OPENMP)
1485 : : #endif
1486 : :
1487 [ + + - + ]: 235354 : ierr = COUNT(ABS(ff - ff_ref) > ATOL_DP)
1488 : 24 : nfailed = nfailed + ierr
1489 : :
1490 [ + - ]: 24 : info = sjoin(library, "c2c_ip_dpc :")
1491 : 24 : write(msg,"(a)")" OK"
1492 [ - + ]: 24 : if (ierr /= 0) then
1493 [ # # # # : 0 : max_abserr = MAXVAL(ABS(ff - ff_ref))
# # # # ]
1494 : 0 : write(msg,"(a,es9.2,a)")" FAILED (max_abserr = ",max_abserr,")"
1495 : : end if
1496 : 24 : call wrtout(ount,sjoin(info, msg))
1497 : :
1498 : : ! out-of-place version.
1499 [ - + + + ]: 235378 : ff = ff_ref
1500 : : #ifdef HAVE_OPENMP_OFFLOAD
1501 : : !$OMP TARGET ENTER DATA MAP(to:ff) MAP(alloc:gg) IF (gpu_option == ABI_GPU_OPENMP)
1502 : : #endif
1503 : 24 : call box_plan%execute(ff, gg, +1, ndat)
1504 [ + + ]: 235354 : ff = zero
1505 : 24 : call box_plan%execute(gg, ff, -1, ndat)
1506 : : #ifdef HAVE_OPENMP_OFFLOAD
1507 : : !$OMP TARGET EXIT DATA MAP(from:ff) IF (gpu_option == ABI_GPU_OPENMP)
1508 : : #endif
1509 : :
1510 [ + + - + ]: 235354 : ierr = COUNT(ABS(ff - ff_ref) > ATOL_DP)
1511 : 24 : nfailed = nfailed + ierr
1512 : :
1513 [ + - ]: 24 : info = sjoin(library, "c2c_op_dpc :")
1514 : 24 : write(msg,"(a)")" OK"
1515 [ - + ]: 24 : if (ierr /= 0) then
1516 [ # # # # : 0 : max_abserr = MAXVAL(ABS(ff - ff_ref))
# # # # ]
1517 : 0 : write(msg,"(a,es9.2,a)")" FAILED (max_abserr = ",max_abserr,")"
1518 : : end if
1519 : 24 : call wrtout(ount, sjoin(info, msg))
1520 : :
1521 : : #ifdef HAVE_OPENMP_OFFLOAD
1522 : : !$OMP TARGET EXIT DATA MAP(delete: ff, gg) if (gpu_option == ABI_GPU_OPENMP)
1523 : : #endif
1524 [ - + ]: 24 : ABI_FREE(ff)
1525 [ - + ]: 24 : ABI_FREE(gg)
1526 [ - + ]: 24 : ABI_FREE(ff_ref)
1527 : :
1528 : 24 : call box_plan%free() !; stop
1529 : :
1530 [ + + ]: 76 : do cplex=1,2
1531 : : !if (fftalga == FFT_FFTW3 .and. ndat > 1 .and. cplex==1) then
1532 : : ! call wrtout(ount,"Warning: fourdp with FFTW3-wrappers, cplex=2 and ndat>1, might crash if MKL is used")
1533 : : ! !CYCLE
1534 : : !end if
1535 : :
1536 : : ! MG: June 24. 2025
1537 : : ! dfti_seqfourdp does not work as expected when cplex= 1 and ngfft(1:3) != ngfft(4:6)
1538 : : ! very likely do the use of r->c, c->r transforms.
1539 : : ! I don't know if it's a bug as the error seems to depend on the mkl version.
1540 : : ! To bypass this problem, we change the params on the fly so that ngfft(1:3) == ngfft(4:6)
1541 : : ! when FFT_DFTI is used.
1542 : : ! Note however that we never call fourdp with ngfft(1:3) != ngftt(4:6) so this is not a serious problem.
1543 : : ! An additional check is done inside dfti_seqfourdp
1544 [ + + ]: 48 : if (fftalga == FFT_DFTI) then
1545 : 24 : ldx=nx; ldy=ny; ldz=nz
1546 : 24 : ldxyz = ldx*ldy*ldz
1547 : : endif
1548 : :
1549 [ + - - + : 144 : ABI_MALLOC(fofg, (2*ldxyz*ndat))
+ - + - +
- - + -
+ ]
1550 [ - + + - : 144 : ABI_MALLOC(fofr_ref, (cplex*ldxyz*ndat))
+ - + - -
+ - + -
+ ]
1551 [ - + + - : 96 : ABI_MALLOC(fofr, (cplex*ldxyz*ndat))
- + - + ]
1552 : :
1553 : 48 : call RANDOM_NUMBER(fofr_ref)
1554 : 48 : call cg_setaug_zero(cplex,nx,ny,nz,ldx,ldy,ldz,ndat,fofr_ref)
1555 [ + - - + : 644691 : fofr = fofr_ref
- - - - +
+ ]
1556 : :
1557 [ + - ]: 48 : if (gpu_option == ABI_GPU_OPENMP) then
1558 : : if (cplex == 2) then
1559 : : ! FIXME
1560 : : !!!$OMP TARGET ENTER DATA MAP(to:fofg, fofr) IF (gpu_option == ABI_GPU_OPENMP)
1561 : : !call ompgpu_fourdp(cplex, ngfft, ldx, ldy, ldz, ndat, -1, fofg, fofr)
1562 : : !call ompgpu_fourdp(cplex, ngfft, ldx, ldy, ldz, ndat, +1, fofg, fofr)
1563 : : !!!$OMP TARGET EXIT DATA MAP(from:fofr) IF (gpu_option == ABI_GPU_OPENMP)
1564 : : end if
1565 : : else
1566 : : ! CPU version.
1567 : 0 : select case (fftalga)
1568 : : case (FFT_FFTW3)
1569 : 0 : call fftw3_seqfourdp(cplex,nx,ny,nz,ldx,ldy,ldz,ndat,-1,fofg,fofr)
1570 : 0 : call fftw3_seqfourdp(cplex,nx,ny,nz,ldx,ldy,ldz,ndat,+1,fofg,fofr)
1571 : :
1572 : : case (FFT_DFTI)
1573 : 24 : call dfti_seqfourdp(cplex,nx,ny,nz,ldx,ldy,ldz,ndat,-1,fofg,fofr)
1574 : 24 : call dfti_seqfourdp(cplex,nx,ny,nz,ldx,ldy,ldz,ndat,+1,fofg,fofr)
1575 : :
1576 : : case default
1577 : : ! TODO
1578 [ - + + ]: 48 : continue
1579 : : end select
1580 : : end if
1581 : :
1582 : 48 : call cg_setaug_zero(cplex,nx,ny,nz,ldx,ldy,ldz,ndat,fofr)
1583 : :
1584 [ + + - + ]: 644643 : ierr = COUNT(ABS(fofr - fofr_ref) > ATOL_DP)
1585 : 48 : nfailed = nfailed + ierr
1586 : :
1587 : 48 : write(info,"(a,i1,a)")sjoin(library, "fourdp (cplex "),cplex,") :"
1588 : : !write(info,"(2a,i1,a,i0,a)")trim(library), "fourdp (cplex ", cplex,"), ndata = ",ndat," :"
1589 : 48 : write(msg,"(a)")" OK"
1590 [ - + ]: 48 : if (ierr /= 0) then
1591 [ # # # # : 0 : max_abserr = MAXVAL(ABS(fofr - fofr_ref))
# # # # ]
1592 : 0 : write(msg,"(a,es9.2,a)")" FAILED (max_abserr = ",max_abserr,")"
1593 : : !write(std_out, *)"abs_diff fofr fofr_ref"
1594 : : !do ifft=1,cplex*ldxyz*ndat
1595 : : ! write(std_out, *)abs(fofr(ifft) - fofr_ref(ifft)), fofr(ifft), fofr_ref(ifft)
1596 : : !end do
1597 : : end if
1598 : 48 : call wrtout(ount,sjoin(info, msg))
1599 : :
1600 : : !!$OMP TARGET EXIT DATA MAP(delete: fofg, fofr) if (gpu_option == ABI_GPU_OPENMP)
1601 [ - + ]: 48 : ABI_FREE(fofg)
1602 [ - + ]: 48 : ABI_FREE(fofr)
1603 [ - + ]: 48 : ABI_FREE(fofr_ref)
1604 : :
1605 [ + + ]: 72 : if (fftalga == FFT_DFTI) then
1606 : : ! Revert changes. See comment above.
1607 : 24 : ldx=pars(4,iset); ldy=pars(5,iset); ldz=pars(6,iset)
1608 : 24 : ldxyz = ldx*ldy*ldz
1609 : : end if
1610 : :
1611 : : end do
1612 : : end do
1613 : :
1614 [ + - ]: 4 : if (nthreads > 0) call xomp_set_num_threads(old_nthreads)
1615 : :
1616 [ + + + + : 32 : end function fftbox_utests
- + - + ]
1617 : : !!***
1618 : :
1619 : : !----------------------------------------------------------------------
1620 : :
1621 : : !!****f* m_fft/fftu_utests
1622 : : !! NAME
1623 : : !! fftu_utests
1624 : : !!
1625 : : !! FUNCTION
1626 : : !! Unit tests for the FFTs of wavefunctions (sequential version).
1627 : : !!
1628 : : !! INPUTS
1629 : : !!
1630 : : !! OUTPUT
1631 : : !! nfailed=number of failed tests.
1632 : : !!
1633 : : !! SOURCE
1634 : :
1635 : 4 : integer function fftu_utests(ecut, ngfft, rprimd, ndat, nthreads, unit) result(nfailed)
1636 : :
1637 : : !Arguments ------------------------------------
1638 : : !scalars
1639 : : real(dp),intent(in) :: ecut
1640 : : integer,intent(in) :: ndat, nthreads
1641 : : integer,optional,intent(in) :: unit
1642 : : !arrays
1643 : : integer,intent(in) :: ngfft(18)
1644 : : real(dp),intent(in) :: rprimd(3,3)
1645 : :
1646 : : !Local variables-------------------------------
1647 : : !scalars
1648 : : integer,parameter :: nspinor=1
1649 : : integer :: nx,ny,nz,nxyz,ldx,ldy,ldz,ierr,npw_k,mgfft,istwf_k,ikpt,ldxyz,ipw,old_nthreads,ount, fftalg
1650 : : real(dp),parameter :: ATOL_SP=tol6, ATOL_DP=tol12 ! Tolerances on the absolute error
1651 : : real(dp) :: max_abserr,ucvol
1652 : : character(len=500) :: msg,info,library,cplex_mode,padding_mode
1653 : : !arrays
1654 : 4 : integer,allocatable :: gbound_k(:,:),kg_k(:,:)
1655 : : real(dp) :: kpoint(3),crand(2),kpoints(3,9), gmet(3,3),gprimd(3,3),rmet(3,3)
1656 : 4 : real(dp),allocatable :: cg(:,:),cg_ref(:,:),cr(:,:)
1657 : 4 : complex(sp),allocatable :: ugsp(:),ug_refsp(:),ursp(:)
1658 : 4 : complex(dp),allocatable :: ug(:),ug_ref(:),ur(:)
1659 : : ! *************************************************************************
1660 : :
1661 [ - + ]: 4 : ount = std_out; if (PRESENT(unit)) ount = unit
1662 : :
1663 : 4 : nfailed = 0
1664 : 4 : fftalg = ngfft(7)
1665 : :
1666 [ + - ]: 4 : if (nthreads > 0) then
1667 : 4 : old_nthreads = xomp_get_max_threads()
1668 : 4 : call xomp_set_num_threads(nthreads)
1669 : : end if
1670 : :
1671 : 4 : call metric(gmet,gprimd,-1,rmet,rprimd,ucvol)
1672 : :
1673 : 4 : nx = ngfft(1); ny = ngfft(2); nz = ngfft(3)
1674 : 4 : ldx = ngfft(4); ldy = ngfft(5); ldz = ngfft(6)
1675 [ + + ]: 16 : mgfft = MAXVAL(ngfft(1:3))
1676 : :
1677 : 4 : nxyz = nx* ny* nz
1678 : 4 : ldxyz = ldx*ldy*ldz
1679 : :
1680 [ - + + - : 30603012 : ABI_CALLOC(cg_ref, (2, ldxyz*ndat))
+ - + - -
+ - + + +
+ + ]
1681 [ - + + - : 30603008 : ABI_CALLOC(cg, (2, ldxyz*ndat))
- + - + +
+ + + ]
1682 [ - + + - : 30603008 : ABI_CALLOC(cr, (2, ldxyz*ndat))
- + - + +
+ + + ]
1683 [ - + + - : 10201012 : ABI_CALLOC(ug_ref, (ldxyz*ndat))
+ - + - -
+ - + +
+ ]
1684 [ - + + - : 10201008 : ABI_CALLOC(ug, (ldxyz*ndat))
- + - + +
+ ]
1685 [ - + + - : 10201008 : ABI_CALLOC(ur, (ldxyz*ndat))
- + - + +
+ ]
1686 [ - + + - : 10201012 : ABI_CALLOC(ug_refsp, (ldxyz*ndat))
+ - + - -
+ - + +
+ ]
1687 [ - + + - : 10201008 : ABI_CALLOC(ugsp, (ldxyz*ndat))
- + - + +
+ ]
1688 [ - + + - : 10201008 : ABI_CALLOC(ursp, (ldxyz*ndat))
- + - + +
+ ]
1689 : :
1690 : : kpoints = RESHAPE([ &
1691 : : 0.1, 0.2, 0.3, &
1692 : : 0.0, 0.0, 0.0, &
1693 : : 0.5, 0.0, 0.0, &
1694 : : 0.0, 0.0, 0.5, &
1695 : : 0.5, 0.0, 0.5, &
1696 : : 0.0, 0.5, 0.0, &
1697 : : 0.5, 0.5, 0.0, &
1698 : : 0.0, 0.5, 0.5, &
1699 : 4 : 0.5, 0.5, 0.5], [3, 9])
1700 : :
1701 : 4 : call fftalg_info(fftalg, library, cplex_mode, padding_mode)
1702 : :
1703 [ + + ]: 40 : do ikpt=1,SIZE(kpoints,DIM=2)
1704 [ + + ]: 144 : kpoint = kpoints(:,ikpt)
1705 : 36 : istwf_k = set_istwfk(kpoint)
1706 : :
1707 : : ! Allocate and calculate the set of G-vectors.
1708 [ - + ]: 36 : call get_kg(kpoint, istwf_k, ecut, gmet, npw_k, kg_k)
1709 : :
1710 [ + - - + : 144 : ABI_MALLOC(gbound_k, (2*mgfft+8,2))
+ - + - +
- + - - +
- + ]
1711 : 36 : call sphereboundary(gbound_k,istwf_k,kg_k,mgfft,npw_k)
1712 : :
1713 : : ! =================================================
1714 : : ! === Test the single precision complex version ===
1715 : : ! =================================================
1716 [ + + ]: 3140026 : do ipw=1,npw_k*ndat
1717 : 3139990 : call RANDOM_NUMBER(crand)
1718 : 3140026 : ug_refsp(ipw) = CMPLX(crand(1), crand(2))
1719 : : end do
1720 : :
1721 [ + + ]: 36 : if (istwf_k == 2) then
1722 [ - + - - : 4 : do ipw=1,npw_k*ndat,npw_k
- + ]
1723 [ + + ]: 10 : ug_refsp(ipw) = REAL(ug_refsp(ipw))
1724 : : end do
1725 : : end if
1726 : :
1727 [ - + + + ]: 91809072 : ugsp = ug_refsp
1728 : 36 : call fft_ug(npw_k,nxyz,nspinor,ndat,mgfft,ngfft,istwf_k,kg_k,gbound_k,ugsp,ursp)
1729 : 36 : call fft_ur(npw_k,nxyz,nspinor,ndat,mgfft,ngfft,istwf_k,kg_k,gbound_k,ursp,ugsp)
1730 : :
1731 [ + + - + ]: 91809036 : ierr = COUNT(ABS(ugsp - ug_refsp) > ATOL_SP)
1732 : 36 : nfailed = nfailed + ierr
1733 : :
1734 : 36 : write(info,"(a,i1,a)")sjoin(library,"fftu_spc, istwfk "),istwf_k," :"
1735 : 36 : write(msg,"(a)")" OK"
1736 [ - + ]: 36 : if (ierr /= 0) then
1737 [ # # # # : 0 : max_abserr = MAXVAL(ABS(ugsp - ug_refsp))
# # # # ]
1738 : 0 : write(msg,"(a,es9.2,a)")" FAILED (max_abserr = ",max_abserr,")"
1739 : : end if
1740 : 36 : call wrtout(ount,sjoin(info, msg))
1741 : :
1742 : : ! =================================================
1743 : : ! === Test the double precision complex version ===
1744 : : ! =================================================
1745 [ + + ]: 3140026 : do ipw=1,npw_k*ndat
1746 : 3139990 : call RANDOM_NUMBER(crand)
1747 : 3140026 : ug_ref(ipw) = DCMPLX(crand(1), crand(2))
1748 : : end do
1749 : :
1750 [ + + ]: 36 : if (istwf_k == 2) then
1751 [ - + - - : 4 : do ipw=1,npw_k*ndat,npw_k
- + ]
1752 [ + + ]: 10 : ug_ref(ipw) = REAL(ug_ref(ipw))
1753 : : end do
1754 : : end if
1755 : :
1756 [ - + + + ]: 91809072 : ug = ug_ref
1757 : 36 : call fft_ug(npw_k,nxyz,nspinor,ndat,mgfft,ngfft,istwf_k,kg_k,gbound_k,ug,ur)
1758 : 36 : call fft_ur(npw_k,nxyz,nspinor,ndat,mgfft,ngfft,istwf_k,kg_k,gbound_k,ur,ug)
1759 : :
1760 [ + + - + ]: 91809036 : ierr = COUNT(ABS(ug - ug_ref) > ATOL_DP)
1761 : 36 : nfailed = nfailed + ierr
1762 : :
1763 : 36 : write(info,"(a,i1,a)")sjoin(library,"fftu_dpc, istwfk "),istwf_k," :"
1764 : 36 : write(msg,"(a)")" OK"
1765 [ - + ]: 36 : if (ierr /= 0) then
1766 [ # # # # : 0 : max_abserr = MAXVAL(ABS(ug - ug_ref))
# # # # ]
1767 : 0 : write(msg,"(a,es9.2,a)")" FAILED (max_abserr = ",max_abserr,")"
1768 : : end if
1769 : 36 : call wrtout(ount, sjoin(info, msg))
1770 : :
1771 [ - + ]: 36 : ABI_FREE(kg_k)
1772 [ - + ]: 40 : ABI_FREE(gbound_k)
1773 : : end do
1774 : :
1775 [ - + ]: 4 : ABI_FREE(cg_ref)
1776 [ - + ]: 4 : ABI_FREE(cg)
1777 [ - + ]: 4 : ABI_FREE(cr)
1778 [ - + ]: 4 : ABI_FREE(ug_ref)
1779 [ - + ]: 4 : ABI_FREE(ug)
1780 [ - + ]: 4 : ABI_FREE(ur)
1781 [ - + ]: 4 : ABI_FREE(ug_refsp)
1782 [ - + ]: 4 : ABI_FREE(ugsp)
1783 [ - + ]: 4 : ABI_FREE(ursp)
1784 : :
1785 [ + - ]: 4 : if (nthreads > 0) call xomp_set_num_threads(old_nthreads)
1786 : :
1787 [ - + ]: 4 : end function fftu_utests
1788 : : !!***
1789 : :
1790 : : !----------------------------------------------------------------------
1791 : :
1792 : : !!****f* m_fft/uplan_utests
1793 : : !! NAME
1794 : : !! uplan_utests
1795 : : !!
1796 : : !! FUNCTION
1797 : : !! Unit tests for the FFTs of wavefunctions (sequential version).
1798 : : !!
1799 : : !! INPUTS
1800 : : !!
1801 : : !! OUTPUT
1802 : : !! nfailed=number of failed tests.
1803 : : !!
1804 : : !! SOURCE
1805 : :
1806 : 0 : integer function uplan_utests(ecut, ngfft, rprimd, ndat, nthreads, gpu_option, unit) result(nfailed)
1807 : :
1808 : : !Arguments ------------------------------------
1809 : : !scalars
1810 : : real(dp),intent(in) :: ecut
1811 : : integer,intent(in) :: ndat, nthreads, gpu_option
1812 : : integer,optional,intent(in) :: unit
1813 : : !arrays
1814 : : integer,intent(in) :: ngfft(18)
1815 : : real(dp),intent(in) :: rprimd(3,3)
1816 : :
1817 : : !Local variables-------------------------------
1818 : : !scalars
1819 : : integer,parameter :: nspinor=1
1820 : : integer :: nx,ny,nz,nxyz,ldx,ldy,ldz,ierr,npw_k,mgfft,istwf_k,ikpt,ldxyz,ipw,old_nthreads,ount, fftalg, ii, ndat__
1821 : : real(dp),parameter :: ATOL_SP=tol6, ATOL_DP=tol12 ! Tolerances on the absolute error
1822 : : real(dp) :: max_abserr,ucvol
1823 : : character(len=500) :: msg,info,library,cplex_mode,padding_mode
1824 : : !arrays
1825 : 0 : integer,allocatable :: kg_k(:,:)
1826 : : real(dp) :: kpoint(3),crand(2),kpoints(3,1), gmet(3,3),gprimd(3,3),rmet(3,3)
1827 : 0 : complex(sp),allocatable :: ugsp(:),ug_refsp(:),ursp(:)
1828 : 0 : complex(dp),allocatable :: ug(:),ug_ref(:),ur(:)
1829 : 0 : type(uplan_t) :: uplan_k
1830 : : ! *************************************************************************
1831 : :
1832 [ # # ]: 0 : ount = std_out; if (PRESENT(unit)) ount = unit
1833 : :
1834 : 0 : nfailed = 0
1835 : 0 : fftalg = ngfft(7)
1836 : :
1837 [ # # ]: 0 : if (nthreads > 0) then
1838 : 0 : old_nthreads = xomp_get_max_threads()
1839 : 0 : call xomp_set_num_threads(nthreads)
1840 : : end if
1841 : :
1842 : 0 : call metric(gmet,gprimd,-1,rmet,rprimd,ucvol)
1843 : :
1844 : 0 : nx = ngfft(1); ny = ngfft(2); nz = ngfft(3)
1845 : 0 : ldx = ngfft(4); ldy = ngfft(5); ldz = ngfft(6)
1846 : : mgfft = MAXVAL(ngfft(1:3))
1847 : :
1848 : 0 : nxyz = nx*ny*nz
1849 : 0 : ldxyz = ldx*ldy*ldz
1850 : :
1851 [ # # # # : 0 : ABI_CALLOC(ug_ref, (ldxyz*ndat))
# # # # #
# # # #
# ]
1852 [ # # # # : 0 : ABI_CALLOC(ug, (ldxyz*ndat))
# # # # #
# ]
1853 [ # # # # : 0 : ABI_CALLOC(ur, (ldxyz*ndat))
# # # # #
# ]
1854 [ # # # # : 0 : ABI_CALLOC(ug_refsp, (ldxyz*ndat))
# # # # #
# # # #
# ]
1855 [ # # # # : 0 : ABI_CALLOC(ugsp, (ldxyz*ndat))
# # # # #
# ]
1856 [ # # # # : 0 : ABI_CALLOC(ursp, (ldxyz*ndat))
# # # # #
# ]
1857 : :
1858 : : kpoints = RESHAPE([ &
1859 : : 0.1, 0.2, 0.3 &
1860 : : !0.0, 0.0, 0.0, &
1861 : : !0.5, 0.0, 0.0, &
1862 : : !0.0, 0.0, 0.5, &
1863 : : !0.5, 0.0, 0.5, &
1864 : : !0.0, 0.5, 0.0, &
1865 : : !0.5, 0.5, 0.0, &
1866 : : !0.0, 0.5, 0.5, &
1867 : : !0.5, 0.5, 0.5
1868 : 0 : ], [3, 1])
1869 : :
1870 : 0 : call fftalg_info(fftalg, library, cplex_mode, padding_mode)
1871 : :
1872 [ # # ]: 0 : do ikpt=1,SIZE(kpoints,DIM=2)
1873 [ # # ]: 0 : kpoint = kpoints(:,ikpt)
1874 : 0 : istwf_k = set_istwfk(kpoint)
1875 : :
1876 : : ! Allocate and calculate the set of G-vectors.
1877 [ # # ]: 0 : call get_kg(kpoint, istwf_k, ecut, gmet, npw_k, kg_k)
1878 : :
1879 : : ! =================================================
1880 : : ! === Test the single precision complex version ===
1881 : : ! =================================================
1882 [ # # ]: 0 : do ipw=1,npw_k*ndat
1883 : 0 : call RANDOM_NUMBER(crand)
1884 : 0 : ug_refsp(ipw) = CMPLX(crand(1), crand(2))
1885 : : end do
1886 : :
1887 [ # # ]: 0 : if (istwf_k == 2) then
1888 [ # # # # : 0 : do ipw=1,npw_k*ndat,npw_k
# # ]
1889 [ # # ]: 0 : ug_refsp(ipw) = REAL(ug_refsp(ipw))
1890 : : end do
1891 : : end if
1892 : :
1893 : 0 : call uplan_k%init(npw_k, nspinor, ndat, ngfft, istwf_k, kg_k, sp, gpu_option)
1894 : :
1895 : 0 : call wrtout(ount, "Test version with gpu_mode 1 (GPU only)")
1896 [ # # ]: 0 : do ii=1,2
1897 : : !do ii=2,1,-1
1898 [ # # # # ]: 0 : ugsp = ug_refsp
1899 : 0 : ndat__ = ndat
1900 [ # # ]: 0 : if (ii == 2) ndat__ = max(ndat / 2, 1)
1901 : 0 : call uplan_k%execute_gr(ndat__, ugsp, ursp, gpu_mode=1)
1902 [ # # ]: 0 : ugsp = zero
1903 : 0 : call uplan_k%execute_rg(ndat__, ursp, ugsp, gpu_mode=1)
1904 : :
1905 [ # # # # ]: 0 : ierr = COUNT(ABS(ugsp(1:npw_k*ndat__) - ug_refsp(1:npw_k*ndat__)) > ATOL_SP); nfailed = nfailed + ierr
1906 : 0 : write(info,"(a,i1,a)")sjoin(library,"uplan_k spc, gpu_mode 1, istwfk "),istwf_k," :"; write(msg,"(a)")" OK"
1907 [ # # ]: 0 : if (ierr /= 0) then
1908 [ # # # # : 0 : max_abserr = MAXVAL(ABS(ugsp - ug_refsp)); write(msg,"(a,es9.2,a)")" FAILED (max_abserr = ",max_abserr,")"
# # # # ]
1909 : : end if
1910 : 0 : call wrtout(ount, sjoin(info, msg))
1911 : : end do ! ii
1912 : :
1913 : 0 : call wrtout(ount, "Test version with explicit GPU offloading.")
1914 [ # # # # ]: 0 : ugsp = ug_refsp
1915 : : #ifdef HAVE_OPENMP_OFFLOAD
1916 : : !$OMP TARGET ENTER DATA MAP(to:ugsp, ursp) IF (gpu_option == ABI_GPU_OPENMP)
1917 : : #endif
1918 : 0 : call uplan_k%execute_gr(ndat, ugsp, ursp)
1919 [ # # ]: 0 : ugsp = zero
1920 : 0 : call uplan_k%execute_rg(ndat, ursp, ugsp)
1921 : : #ifdef HAVE_OPENMP_OFFLOAD
1922 : : !$OMP TARGET EXIT DATA MAP(from:ugsp) IF (gpu_option == ABI_GPU_OPENMP)
1923 : : #endif
1924 : 0 : call uplan_k%free()
1925 : :
1926 [ # # # # ]: 0 : ierr = COUNT(ABS(ugsp - ug_refsp) > ATOL_SP); nfailed = nfailed + ierr
1927 : 0 : write(info,"(a,i1,a)")sjoin(library,"uplan_k spc, gpu_mode 0, istwfk "),istwf_k," :"; write(msg,"(a)")" OK"
1928 [ # # ]: 0 : if (ierr /= 0) then
1929 [ # # # # : 0 : max_abserr = MAXVAL(ABS(ugsp - ug_refsp)); write(msg,"(a,es9.2,a)")" FAILED (max_abserr = ",max_abserr,")"
# # # # ]
1930 : : end if
1931 : 0 : call wrtout(ount, sjoin(info, msg))
1932 : :
1933 : : ! =================================================
1934 : : ! === Test the double precision complex version ===
1935 : : ! =================================================
1936 [ # # ]: 0 : do ipw=1,npw_k*ndat
1937 : 0 : call RANDOM_NUMBER(crand)
1938 : 0 : ug_ref(ipw) = DCMPLX(crand(1), crand(2))
1939 : : end do
1940 : :
1941 [ # # ]: 0 : if (istwf_k == 2) then
1942 [ # # # # : 0 : do ipw=1,npw_k*ndat,npw_k
# # ]
1943 [ # # ]: 0 : ug_ref(ipw) = REAL(ug_ref(ipw))
1944 : : end do
1945 : : end if
1946 : :
1947 : : ! Test uplan_k transforms with double precision.
1948 : 0 : call uplan_k%init(npw_k, nspinor, ndat, ngfft, istwf_k, kg_k, dp, gpu_option)
1949 : :
1950 : 0 : call wrtout(ount, "Test version with gpu_mode 1 (GPU only)")
1951 [ # # ]: 0 : do ii=1,2
1952 : : !do ii=2,1,-1
1953 [ # # # # ]: 0 : ug = ug_ref
1954 [ # # ]: 0 : if (ii == 2) ndat__ = max(ndat__ / 2, 1)
1955 : 0 : call uplan_k%execute_gr(ndat__, ug, ur, gpu_mode=1)
1956 [ # # ]: 0 : ug = zero
1957 : 0 : call uplan_k%execute_rg(ndat__, ur, ug, gpu_mode=1)
1958 : :
1959 [ # # # # ]: 0 : ierr = COUNT(ABS(ug(1:npw_k*ndat__) - ug_ref(1:npw_k*ndat__)) > ATOL_DP); nfailed = nfailed + ierr
1960 : 0 : write(info,"(a,i1,a)")sjoin(library,"uplan_k dpc, gpu_mode 1, istwfk "),istwf_k," :"; write(msg,"(a)")" OK"
1961 [ # # ]: 0 : if (ierr /= 0) then
1962 [ # # # # : 0 : max_abserr = MAXVAL(ABS(ug - ug_ref)); write(msg,"(a,es9.2,a)")" FAILED (max_abserr = ",max_abserr,")"
# # # # ]
1963 : : end if
1964 : 0 : call wrtout(ount, sjoin(info, msg))
1965 : : end do ! ii
1966 : :
1967 : 0 : call wrtout(ount, "Test version with explicit GPU offloading.")
1968 [ # # # # ]: 0 : ug = ug_ref
1969 : : #ifdef HAVE_OPENMP_OFFLOAD
1970 : : !$OMP TARGET ENTER DATA MAP(to:ug, ur) IF (gpu_option == ABI_GPU_OPENMP)
1971 : : #endif
1972 : 0 : call uplan_k%execute_gr(ndat, ug, ur)
1973 [ # # ]: 0 : ug = zero
1974 : 0 : call uplan_k%execute_rg(ndat, ur, ug)
1975 : : #ifdef HAVE_OPENMP_OFFLOAD
1976 : : !$OMP TARGET EXIT DATA MAP(from:ug) IF (gpu_option == ABI_GPU_OPENMP)
1977 : : #endif
1978 : 0 : call uplan_k%free()
1979 : :
1980 [ # # # # ]: 0 : ierr = COUNT(ABS(ug - ug_ref) > ATOL_DP); nfailed = nfailed + ierr
1981 : 0 : write(info,"(a,i1,a)")sjoin(library,"uplan_k, dpc, gpu_mode 0, istwfk "),istwf_k," :"; write(msg,"(a)")" OK"
1982 [ # # ]: 0 : if (ierr /= 0) then
1983 [ # # # # : 0 : max_abserr = MAXVAL(ABS(ug - ug_ref)); write(msg,"(a,es9.2,a)")" FAILED (max_abserr = ",max_abserr,")"
# # # # ]
1984 : : end if
1985 : 0 : call wrtout(ount, sjoin(info, msg))
1986 : :
1987 [ # # ]: 0 : ABI_FREE(kg_k)
1988 : : end do
1989 : :
1990 [ # # ]: 0 : ABI_FREE(ug_ref)
1991 [ # # ]: 0 : ABI_FREE(ug)
1992 [ # # ]: 0 : ABI_FREE(ur)
1993 [ # # ]: 0 : ABI_FREE(ug_refsp)
1994 [ # # ]: 0 : ABI_FREE(ugsp)
1995 [ # # ]: 0 : ABI_FREE(ursp)
1996 : :
1997 [ # # ]: 0 : if (nthreads > 0) call xomp_set_num_threads(old_nthreads)
1998 : :
1999 [ # # # # : 0 : end function uplan_utests
# # # # ]
2000 : : !!***
2001 : :
2002 : : !----------------------------------------------------------------------
2003 : :
2004 : : !!****f* m_fft/fftbox_mpi_utests
2005 : : !! NAME
2006 : : !! fftbox_mpi_utests
2007 : : !!
2008 : : !! FUNCTION
2009 : : !! Driver routine for unit tests of the MPI FFT routines.
2010 : : !!
2011 : : !! INPUTS
2012 : : !! fftalg =fftalg input variable.
2013 : : !! cplex=1 for r2c, 2 for c2c transforms.
2014 : : !! ndat = Number of transform to execute
2015 : : !! nthreads = Number of OpenMP threads.
2016 : : !! comm_fft=MPI communicator for the FFT
2017 : : !! [unit]=Output Unit number (DEFAULT std_out)
2018 : : !!
2019 : : !! OUTPUT
2020 : : !! nfailed=number of failures.
2021 : : !!
2022 : : !! SOURCE
2023 : :
2024 : 8 : integer function fftbox_mpi_utests(fftalg, cplex, ndat, nthreads, comm_fft, unit) result(nfailed)
2025 : :
2026 : : !Arguments -----------------------------------
2027 : : !scalars
2028 : : integer,intent(in) :: fftalg,cplex,ndat,nthreads,comm_fft
2029 : : integer,optional,intent(in) :: unit
2030 : :
2031 : : !Local variables-------------------------------
2032 : : !scalars
2033 : : integer,parameter :: NSETS=6
2034 : : integer :: ierr,old_nthreads,ount,iset,mpierr,nfft,me_fft
2035 : : integer :: nproc_fft,fftalga,fftalgc,n1,n2,n3,n4,n5,n6
2036 : : real(dp),parameter :: ATOL_DP=tol12
2037 : : real(dp) :: max_abserr, ctime, wtime, gflops
2038 : : character(len=500) :: msg,info,library,cplex_mode,padding_mode
2039 : 8 : type(distribfft_type),target :: fftabs
2040 : : !arrays
2041 : : integer :: pars(6,NSETS),ngfft(18)
2042 : 8 : integer, contiguous, pointer :: fftn2_distrib(:),ffti2_local(:)
2043 : 8 : integer, contiguous, pointer :: fftn3_distrib(:),ffti3_local(:)
2044 : 8 : real(dp),allocatable :: fofg(:,:),fofr(:),fofr_copy(:)
2045 : : ! *************************************************************************
2046 : :
2047 : 0 : ount = std_out; if (PRESENT(unit)) ount = unit
2048 : 8 : nfailed = 0
2049 : :
2050 [ - + ]: 8 : if (nthreads > 0) then
2051 : 0 : old_nthreads = xomp_get_max_threads()
2052 : 0 : call xomp_set_num_threads(nthreads)
2053 : : end if
2054 : :
2055 : : ! These values must be compatible with all the FFT routines.
2056 : : ! SG library is the most restrictive (only powers of 2,3,5).
2057 : : pars = RESHAPE( [ &
2058 : : 12, 18, 15, 12, 18, 15, &
2059 : : 12, 18, 15, 13, 19, 16, &
2060 : : 12, 18, 15, 13, 19, 15, &
2061 : : 12, 18, 15, 12, 18, 16, &
2062 : : 12, 18, 15, 13, 18, 15, &
2063 : : 12, 18, 15, 15, 21, 18 &
2064 : 8 : ], [6, NSETS] )
2065 : :
2066 : 8 : fftalga=fftalg/100; fftalgc=mod(fftalg,10)
2067 : :
2068 : 8 : nproc_fft = xmpi_comm_size(comm_fft); me_fft = xmpi_comm_rank(comm_fft)
2069 : :
2070 : 8 : call fftalg_info(fftalg,library,cplex_mode,padding_mode)
2071 : :
2072 : : !do iset=1,SIZE(pars,DIM=2)
2073 [ + + ]: 16 : do iset=1,1
2074 : 8 : n1=pars(1,iset); n2=pars(2,iset); n3=pars(3,iset)
2075 : : ! For the time being, ngfft(2) and ngfft(3) must be multiple of nproc_fft
2076 : 8 : n2 = n2 * nproc_fft; n3 = n3 * nproc_fft
2077 : : !n4=pars(4,iset); n5=pars(5,iset); n6=pars(6,iset)
2078 : 8 : n4=n1; n5=n2; n6=n3
2079 : :
2080 : : ! Init ngfft
2081 : : ! TODO Propagate more info via ngfft, define helper functions, write routine to get fftcache
2082 : 8 : ngfft = 0
2083 [ + + ]: 64 : ngfft(1:7) = [n1,n2,n3,n4,n5,n6,fftalg]
2084 : 8 : ngfft(8)= get_cache_kb() ! cache
2085 : 8 : ngfft(9)=1 ! paral_fft_
2086 : 8 : ngfft(10)=nproc_fft ! nproc_fft
2087 : 8 : ngfft(11)=xmpi_comm_rank(comm_fft) ! me_fft
2088 : 8 : ngfft(12)=ngfft(2)/nproc_fft ! n2proc
2089 : 8 : ngfft(13)=ngfft(3)/nproc_fft ! n3proc
2090 : :
2091 : : !call print_ngfft([std_out], ngfft, header="ngfft for MPI-fourdp", prtvol=0)
2092 : :
2093 : : ! Allocate arrays, fill fofr with random numbers and keep a copy.
2094 : 8 : nfft = (n1 * n2 * n3) / nproc_fft
2095 [ - + + - : 24 : ABI_MALLOC(fofg, (2,nfft*ndat))
+ - + - -
+ - + ]
2096 [ - + + - : 24 : ABI_MALLOC(fofr, (cplex*nfft*ndat))
+ - + - -
+ - + -
+ ]
2097 [ - + + - : 16 : ABI_MALLOC(fofr_copy, (cplex*nfft*ndat))
- + - + ]
2098 : :
2099 : 8 : call RANDOM_NUMBER(fofr)
2100 [ + - - + : 77776 : fofr_copy = fofr
- - - - +
+ ]
2101 : :
2102 : 8 : call fftabs%init("c",nproc_fft,n2,n3)
2103 : 8 : fftn2_distrib => fftabs%tab_fftdp2_distrib
2104 : 8 : ffti2_local => fftabs%tab_fftdp2_local
2105 : 8 : fftn3_distrib => fftabs%tab_fftdp3_distrib
2106 : 8 : ffti3_local => fftabs%tab_fftdp3_local
2107 : :
2108 : 8 : call cwtime(ctime,wtime,gflops,"start")
2109 : :
2110 : 8 : select case (fftalga)
2111 : :
2112 : : case (FFT_SG2002)
2113 : 8 : call sg2002_mpifourdp(cplex,nfft,ngfft,ndat,-1,fftn2_distrib,ffti2_local,fftn3_distrib,ffti3_local,fofg,fofr,comm_fft)
2114 : 8 : call sg2002_mpifourdp(cplex,nfft,ngfft,ndat,+1,fftn2_distrib,ffti2_local,fftn3_distrib,ffti3_local,fofg,fofr,comm_fft)
2115 : :
2116 : : case (FFT_FFTW3)
2117 : 0 : call fftw3_mpifourdp(cplex,nfft,ngfft,ndat,-1,fftn2_distrib,ffti2_local,fftn3_distrib,ffti3_local,fofg,fofr,comm_fft)
2118 : 0 : call fftw3_mpifourdp(cplex,nfft,ngfft,ndat,+1,fftn2_distrib,ffti2_local,fftn3_distrib,ffti3_local,fofg,fofr,comm_fft)
2119 : :
2120 : : !case (FFT_DFTI)
2121 : : ! call dfti_mpifourdp(cplex,nfft,ngfft,ndat,-1,fftn2_distrib,ffti2_local,fftn3_distrib,ffti3_local,fofg,fofr,comm_fft)
2122 : : ! call dfti_mpifourdp(cplex,nfft,ngfft,ndat,+1,fftn2_distrib,ffti2_local,fftn3_distrib,ffti3_local,fofg,fofr,comm_fft)
2123 : :
2124 : : case default
2125 [ + - - ]: 8 : ABI_BUG(sjoin("fftalg: ", itoa(fftalg), " does not support MPI-FFT"))
2126 : : end select
2127 : :
2128 : 8 : call cwtime(ctime,wtime,gflops,"stop")
2129 : : if (me_fft == 0) then
2130 : : !write(std_out,'(a,i0,2(a,f10.4))')"fftalg: ",fftalg,", cpu_time: ",ctime,", wall_time: ",wtime
2131 : : end if
2132 : :
2133 : : ! Check if F^{-1} F = I within ATOL_DP
2134 [ + + - + ]: 77768 : ierr = COUNT(ABS(fofr - fofr_copy) > ATOL_DP)
2135 : 8 : call xmpi_sum(ierr,comm_fft,mpierr)
2136 : 8 : nfailed = nfailed + ierr
2137 : :
2138 [ + + + - ]: 8 : if (cplex == 1) info = sjoin(library,"r2c --> c2r :")
2139 [ + + + - ]: 8 : if (cplex == 2) info = sjoin(library,"c2c :")
2140 : :
2141 : 8 : write(msg,"(a)")" OK"
2142 [ - + ]: 8 : if (ierr /= 0) then
2143 : : ! Compute the maximum of the absolute error.
2144 [ # # # # : 0 : max_abserr = MAXVAL(ABS(fofr - fofr_copy))
# # # # ]
2145 : 0 : call xmpi_max(max_abserr,comm_fft,mpierr)
2146 : 0 : write(msg,"(a,es9.2,a)")" FAILED (max_abserr = ",max_abserr,")"
2147 : : end if
2148 : 8 : call wrtout(ount,sjoin(info, msg))
2149 : :
2150 : 8 : call fftabs%free()
2151 : :
2152 [ - + ]: 8 : ABI_FREE(fofg)
2153 [ - + ]: 8 : ABI_FREE(fofr_copy)
2154 [ - + ]: 40 : ABI_FREE(fofr)
2155 : : end do
2156 : :
2157 [ - + ]: 8 : if (nthreads > 0) call xomp_set_num_threads(old_nthreads)
2158 : :
2159 [ - + - + : 16 : end function fftbox_mpi_utests
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + ]
2160 : : !!***
2161 : :
2162 : : !----------------------------------------------------------------------
2163 : :
2164 : : !!****f* m_fft/fftu_mpi_utests
2165 : : !! NAME
2166 : : !! fftu_mpi_utests
2167 : : !!
2168 : : !! FUNCTION
2169 : : !! Unit tests for the FFTs of wavefunctions (MPI version).
2170 : : !!
2171 : : !! INPUTS
2172 : : !!
2173 : : !! OUTPUT
2174 : : !! nfailed=number of failed tests.
2175 : : !!
2176 : : !! SOURCE
2177 : :
2178 : 4 : integer function fftu_mpi_utests(fftalg, ecut, rprimd, ndat, nthreads, comm_fft, paral_kgb, unit) result(nfailed)
2179 : :
2180 : : !Arguments ------------------------------------
2181 : : !scalars
2182 : : integer,intent(in) :: fftalg,ndat,nthreads,comm_fft,paral_kgb
2183 : : integer,optional,intent(in) :: unit
2184 : : real(dp),intent(in) :: ecut
2185 : : !arrays
2186 : : real(dp),intent(in) :: rprimd(3,3)
2187 : :
2188 : : !Local variables-------------------------------
2189 : : !scalars
2190 : : integer,parameter :: nsym1=1,npw0=0,cplex_one=1,istwfk_one=1
2191 : : integer :: n1,n2,n3,idat,n4,n5,n6,ierr,npw_k,full_npw_k,istwf_npw_k,cplexwf
2192 : : integer :: mgfft,istwf_k,ikpt,old_nthreads,ount,isign,fftalga,fftalgc
2193 : : integer :: ig,i1,i2,i3,i3_glob,i3dat,nd3proc,i3_local,g0sender
2194 : : integer :: step,me_g0,me_fft,nproc_fft,mpierr,nfft,cplex,chksymtnons
2195 : : real(dp),parameter :: boxcutmin2=two,ATOL_DP=tol12,RTOL_DP=tol3 ! Tolerances on the absolute and relative error
2196 : : real(dp),parameter :: weight_r=one,weight_i=one
2197 : : real(dp) :: max_abserr,max_relerr,ucvol,relerr,den,refden
2198 : : real(dp) :: ctime,wtime,gflops
2199 : : character(len=500) :: msg,info,library,cplex_mode,padding_mode
2200 : 4 : type(distribfft_type) :: fftabs
2201 : : !arrays
2202 : : integer :: symrel(3,3,nsym1),ngfft(18)
2203 : 4 : integer,allocatable :: full_kg_k(:,:),istw_kg_k(:,:)
2204 : 4 : integer,allocatable :: gbound_k(:,:),kg_k(:,:)
2205 : : real(dp) :: dummy_fofg(0,0) !dummy_denpot(0,0,0)
2206 : : real(dp) :: kpoint(3),kpoints(3,2)
2207 : : real(dp) :: gmet(3,3),gprimd(3,3),rmet(3,3),tnons(3,nsym1)
2208 : 4 : real(dp),allocatable :: fofg(:,:),ref_fofg(:,:),fofg_out(:,:),fofr(:,:,:,:)
2209 : 4 : real(dp),allocatable :: density(:,:,:),pot(:,:,:),invpot(:,:,:)
2210 : 4 : real(dp),allocatable :: full_fofg(:,:),istwf_fofg(:,:)
2211 : : ! *************************************************************************
2212 : :
2213 : 4 : nfailed = 0
2214 [ - + ]: 4 : ount = std_out; if (PRESENT(unit)) ount = unit
2215 : :
2216 [ - + ]: 4 : if (nthreads > 0) then
2217 : 0 : old_nthreads = xomp_get_max_threads()
2218 : 0 : call xomp_set_num_threads(nthreads)
2219 : : end if
2220 : :
2221 [ - + ]: 4 : if (.not. fftalg_has_mpi(fftalg)) then
2222 : 0 : write(msg,'(a,i0,a)')"fftalg: ",fftalg," does not support MPI"
2223 : 0 : ABI_ERROR(msg)
2224 : : end if
2225 : :
2226 : 4 : nproc_fft = xmpi_comm_size(comm_fft); me_fft = xmpi_comm_rank(comm_fft)
2227 : :
2228 : 4 : symrel = reshape([1,0,0,0,1,0,0,0,1],[3,3,nsym1])
2229 : 4 : tnons=zero
2230 : 4 : chksymtnons=0
2231 : 4 : call metric(gmet,gprimd,-1,rmet,rprimd,ucvol)
2232 : :
2233 : : kpoints = RESHAPE( [ &
2234 : : 0.1, 0.2, 0.3, &
2235 : 4 : 0.0, 0.0, 0.0 ], [3,2] )
2236 : :
2237 : 4 : call fftalg_info(fftalg,library,cplex_mode,padding_mode)
2238 : :
2239 : 4 : fftalga=fftalg/100; fftalgc=mod(fftalg,10)
2240 : :
2241 [ + + ]: 12 : do ikpt=1,size(kpoints, dim=2)
2242 [ + + ]: 32 : kpoint = kpoints(:,ikpt)
2243 : :
2244 : : ! Get full G-sphere (no MPI distribution, no time-reversal)
2245 [ - + ]: 8 : call get_kg(kpoint,istwfk_one,ecut,gmet,full_npw_k,full_kg_k)
2246 : :
2247 : : ! Get full G-sphere (no MPI distribution, use time-reversal if possible)
2248 : 8 : istwf_k = set_istwfk(kpoint)
2249 [ - + ]: 8 : call get_kg(kpoint,istwf_k,ecut,gmet,istwf_npw_k,istw_kg_k)
2250 : :
2251 : : ! Get FFT box dims.
2252 [ + + ]: 152 : ngfft = -1
2253 : 8 : ngfft(7) = fftalg
2254 : 8 : ngfft(8) = get_cache_kb()
2255 : :
2256 : : call getng(boxcutmin2,chksymtnons,ecut,gmet,kpoint,me_fft,mgfft,nfft,ngfft,nproc_fft,nsym1,&
2257 : 8 : paral_kgb,symrel,tnons,unit=dev_null)
2258 : :
2259 : 8 : n1 = ngfft(1); n2 = ngfft(2); n3 = ngfft(3)
2260 : : ! Do not use augmentation.
2261 : : !ngfft(4:6) = ngfft(1:3)
2262 : 8 : n4 = ngfft(4); n5 = ngfft(5); n6 = ngfft(6)
2263 : :
2264 [ + + ]: 16 : call print_ngfft([std_out], ngfft, header="ngfft for MPI-fourwf", prtvol=0)
2265 : :
2266 : : ! Compute FFT distribution tables.
2267 : 8 : call fftabs%init("c",nproc_fft,n2,n3)
2268 : :
2269 : : ! Set to 1 if this node owns G = 0.
2270 [ + - ]: 8 : me_g0 = 0; if (fftabs%tab_fftwf2_distrib(1) == me_fft) me_g0 = 1
2271 : 8 : g0sender = fftabs%tab_fftwf2_distrib(1)
2272 : :
2273 : : ! Allocate u(g) on the full sphere, initialize with random numbers.
2274 : : ! and broadcast full data to the other nodes.
2275 [ - + + - : 24 : ABI_MALLOC(full_fofg, (2,full_npw_k*ndat))
+ - + - -
+ - + -
+ ]
2276 : :
2277 [ + - ]: 8 : if (me_fft == g0sender) then
2278 [ + + ]: 8 : if (istwf_k == 1) then
2279 : 4 : call RANDOM_NUMBER(full_fofg)
2280 : : !full_fofg = one
2281 : :
2282 [ + - ]: 4 : else if (istwf_k == 2) then
2283 : : ! Special treatment for real wavefunctions.
2284 : : ! Fill the irreducible G-vectors first so that we have the u(g) of a real u(r)
2285 : : ! Then get u(g) on the full G-sphere.
2286 : : ! TODO: Sequential version OK, SIGSEV if mpi_ncpus > 1!
2287 [ - + + - : 12 : ABI_MALLOC(istwf_fofg, (2,istwf_npw_k*ndat))
+ - + - -
+ - + -
+ ]
2288 : 4 : call RANDOM_NUMBER(istwf_fofg)
2289 : : ! Enforce real u in G-space.
2290 [ + + ]: 12 : do idat=1,ndat
2291 : 12 : istwf_fofg(2,1+(idat-1)*istwf_npw_k) = zero
2292 : : end do
2293 : :
2294 : : ! from istwfk 2 to 1.
2295 : 4 : call change_istwfk(istwf_npw_k,istw_kg_k,istwf_k,full_npw_k,full_kg_k,istwfk_one,n1,n2,n3,ndat,istwf_fofg,full_fofg)
2296 [ - + ]: 4 : ABI_FREE(istwf_fofg)
2297 : :
2298 : : else
2299 : 0 : ABI_ERROR("istwf_k /= [1,2] not available in MPI-FFT mode")
2300 : : end if
2301 : : end if
2302 : :
2303 : 8 : call xmpi_bcast(full_fofg,g0sender,comm_fft,ierr)
2304 : :
2305 : : ! Compute sphere boundaries for zero-padded FFTs
2306 [ + - - + : 32 : ABI_MALLOC(gbound_k,(2*mgfft+8,2))
+ - + - +
- + - - +
- + ]
2307 : 8 : call sphereboundary(gbound_k,istwfk_one,full_kg_k,mgfft,full_npw_k)
2308 : :
2309 : : ! Extract my G-vectors from full_kg_k and store them in kg_k.
2310 : : !write(std_out,*)"fftwf2_distrib",fftabs%tab_fftwf2_distrib
2311 [ + + ]: 24 : do step=1,2
2312 [ + + ]: 16 : if (step == 2) then
2313 : : ! Allocate my u(g) and my Gs.
2314 : : ! Set fofg to zero to bypass a bug with XLF!
2315 [ - + + - : 24 : ABI_MALLOC(kg_k, (3, npw_k))
+ - + - -
+ - + -
+ ]
2316 [ - + + - : 4648344 : ABI_CALLOC(fofg, (2,npw_k*ndat))
+ - + - -
+ - + - +
+ + + + ]
2317 : : end if
2318 : :
2319 : 16 : npw_k = 0
2320 [ + + ]: 1549464 : do ig=1,full_npw_k
2321 : 1549440 : i1=full_kg_k(1,ig); if(i1<0) i1=i1+n1; i1=i1+1
2322 [ + + ]: 1549440 : i2=full_kg_k(2,ig); if(i2<0) i2=i2+n2; i2=i2+1
2323 : 1549440 : i3=full_kg_k(3,ig); if(i3<0) i3=i3+n3; i3=i3+1
2324 [ + - ]: 1549456 : if (fftabs%tab_fftwf2_distrib(i2) == me_fft) then
2325 : 1549440 : npw_k = npw_k + 1
2326 [ + + ]: 1549440 : if (step == 2) then
2327 [ + + ]: 3098880 : kg_k(:,npw_k) = full_kg_k(:,ig)
2328 [ + + ]: 2324160 : fofg(:,npw_k) = full_fofg(:,ig)
2329 : : end if
2330 : : end if
2331 : : end do
2332 : : end do ! step
2333 : :
2334 [ - + ]: 8 : ABI_FREE(istw_kg_k)
2335 : :
2336 : : !write(std_out,*)"dist",trim(itoa(me_fft)),fftabs%tab_fftdp3_distrib(:) !== me_fft)
2337 : : !write(std_out,*)"local",trim(itoa(me_fft)),fftabs%tab_fftdp3_local(:)
2338 : :
2339 : : ! Allocate my local portion of u(r), and keep a copy my u(g).
2340 [ - + + - : 40 : ABI_MALLOC(fofr, (2,n4,n5,n6*ndat))
- + + - -
+ + - + -
+ - - + -
+ ]
2341 [ - + + - : 24 : ABI_MALLOC(ref_fofg, (2,npw_k*ndat))
+ - + - -
+ - + ]
2342 [ + - - + : 4648336 : ref_fofg = fofg
- - + + +
+ ]
2343 : :
2344 : 8 : call cwtime(ctime,wtime,gflops,"start")
2345 : :
2346 : : ! ----------------------------------------------------------------
2347 : : ! Test the the backward and the forward transform of wavefunctions
2348 : : ! ----------------------------------------------------------------
2349 : : ! c2c or [c2r, r2c]
2350 : : cplexwf = 2; if (istwf_k==2) cplexwf = 1
2351 : : ! FIXME:
2352 : : ! There's a bug somewhere in the MPI routines if cplexwf == 1 is used and ndat > 1
2353 : : ! Not a serious problem at present since cplexwf==1 is never used in abinit.
2354 : : if (ndat>1) cplexwf = 2
2355 : : if (nproc_fft > 1) cplexwf = 2
2356 : 8 : cplexwf = 2
2357 : : !cplexwf = 2; if (istwf_k==2) cplexwf = 1
2358 : :
2359 [ + + ]: 24 : do isign = 1,-1,-2
2360 : : call fftmpi_u(npw_k,n4,n5,n6,ndat,mgfft,ngfft,&
2361 : 24 : istwfk_one,gbound_k,kg_k,me_g0,fftabs,isign,fofg,fofr,comm_fft,cplexwf=cplexwf)
2362 : : end do
2363 : :
2364 : : ! The final interface should be:
2365 : : !subroutine fftmpi_u(npw_k,n4,n5,n6,nspinor,ndat,mgfft,ngfft,istwf_k,kg_k,gbound_k,fftabs,isign,fofg,fofr)
2366 : :
2367 : : ! Parallel version (must support augmentation in forf(:,:,:,:), hence we have a different API wrt the seq case!
2368 : : !call fftmpi_ug(npw_k,n4,n5,n6,nspinor,ndat,mgfft,ngfft,istwf_k,kg_k,gbound_k,fftabs,fofg,fofr)
2369 : : !call fftmpi_ur(npw_k,n4,n5,n6,nspinor,ndat,mgfft,ngfft,istwf_k,kg_k,gbound_k,fftabs,fofr,fofgout)
2370 : :
2371 : : ! Seq version.
2372 : : !call fft_ug(npw_k,nxyz,nspinor,ndat,mgfft,ngfft,istwf_k,kg_k,gbound_k,ugsp,ursp)
2373 : : !call fft_ur(npw_k,nxyz,nspinor,ndat,mgfft,ngfft,istwf_k,kg_k,gbound_k,ursp,ugsp)
2374 : :
2375 : 8 : call cwtime(ctime,wtime,gflops,"stop")
2376 : : if (me_fft == 0) then
2377 : : !write(std_out,'(a,i0,3(a,f10.4))')"fftalg: ",fftalg,", ecut: ",ecut,", cpu_time: ",ctime,", wall_time: ",wtime
2378 : : end if
2379 : :
2380 : : ! Check if F^{-1} F = I within ATOL_DP
2381 [ + + + + : 4648328 : ierr = COUNT(ABS(fofg - ref_fofg) > ATOL_DP)
- + ]
2382 : 8 : call xmpi_sum(ierr,comm_fft,mpierr)
2383 : 8 : nfailed = nfailed + ierr
2384 : :
2385 : 8 : write(info,"(a,i1,a)")sjoin(library,"fftu_mpi, istwfk "),istwf_k," :"
2386 : :
2387 : 8 : write(msg,"(a)")" OK"
2388 [ - + ]: 8 : if (ierr /= 0) then
2389 [ # # # # : 0 : max_abserr = MAXVAL(ABS(fofg - ref_fofg))
# # # # #
# # # ]
2390 : 0 : call xmpi_max(max_abserr,comm_fft,mpierr)
2391 : 0 : write(msg,"(a,es9.2,a)")" FAILED (max_abserr = ",max_abserr,")"
2392 : : end if
2393 : 8 : call wrtout(ount,sjoin(info, msg))
2394 : :
2395 : : ! -------------------------------------------
2396 : : ! Test the accumulation of density (option 1)
2397 : : ! -------------------------------------------
2398 [ - + + - : 14172520 : ABI_CALLOC(density, (cplex_one*n4,n5,n6))
- + + - -
+ + - + -
+ - - + -
+ + + + +
+ + ]
2399 : : !fofg = one
2400 : :
2401 : : ! Accumulate density. Does not work if cplexwf==1
2402 : : call fourwf_mpi(cplex_one,density,fofg,dummy_fofg,fofr,&
2403 : : gbound_k,gbound_k,istwfk_one,kg_k,kg_k,me_g0,mgfft,ngfft,fftabs,n1,n2,n3,&
2404 : 8 : npw_k,npw_k,n4,n5,n6,ndat,1,weight_r,weight_i,comm_fft,cplexwf=cplexwf)
2405 : :
2406 : : ! Recompute u(r)
2407 : : ! call fourwf_mpi(cplex_one,density,fofg,dummy_fofg,fofr,&
2408 : : !& gbound_k,gbound_k,istwf_one,kg_k,kg_k,me_g0,mgfft,ngfft,fftabs,n1,n2,n3,&
2409 : : !& npw_k,npw_k,n4,n5,n6,ndat,0,weight_r,weight_i,comm_fft,cplexwf=cplexwf)
2410 : : ! call xmpi_sum(density,comm_fft,ierr)
2411 : : ! if (me_fft == 0) write(std_out,*)"sum density", sum(density)
2412 : :
2413 : : !do i3=1,n6
2414 : : ! write(110+me_fft,*)i3,density(:,:,i3)
2415 : : !end do
2416 : :
2417 : 8 : max_relerr = zero
2418 : :
2419 : : ! FIXME: This is wrong if ndat > 1
2420 : : ! Must unify the treatment of fofr and rhor on the augmented mesh (n4,n5,n6)
2421 : : ! back_wf and for_wf return a MPI distributed arrays but fofr is allocated with
2422 : : ! the global dimensions.
2423 : 8 : nd3proc=(n3-1)/nproc_fft+1
2424 [ + + ]: 968 : do i3=1,n3
2425 : : !do i3=1,nd3proc
2426 [ + - ]: 968 : if( me_fft == fftabs%tab_fftdp3_distrib(i3) ) then
2427 : 960 : i3_local = fftabs%tab_fftdp3_local(i3) !+ nd3proc*(idat-1)
2428 : : !i3_local = i3
2429 : 960 : i3_glob = i3
2430 : : !i3_glob = i3_local
2431 : : !i3_glob = i3 + nd3proc * me_fft
2432 : : !i3dat = i3 + n6 * (idat-1)
2433 [ + + ]: 116160 : do i2=1,n2
2434 [ + + ]: 13940160 : do i1=1,n1
2435 : 13824000 : den = density(i1,i2,i3_glob)
2436 : 13824000 : refden = zero
2437 [ + + ]: 41472000 : do idat=1,ndat
2438 : 27648000 : i3dat = i3_local + n6 * (idat-1)
2439 : 41472000 : refden = refden + weight_r*fofr(1,i1,i2,i3dat)**2+ weight_i*fofr(2,i1,i2,i3dat)**2
2440 : : end do
2441 : 13824000 : relerr = abs(refden - den)
2442 [ - + ]: 13824000 : if (abs(refden) < tol12) refden = tol12
2443 : 13824000 : relerr = relerr / abs(refden)
2444 : 13939200 : max_relerr = max(max_relerr, relerr)
2445 : : !if (relerr > RTOL_DP) write(std_out,*)trim(itoa(me_fft)),i1,i2,i3,idat,den,refden
2446 : : end do
2447 : : end do
2448 : : end if
2449 : : end do
2450 : :
2451 : 8 : call xmpi_max(max_relerr,comm_fft,mpierr)
2452 : :
2453 : 8 : write(info,"(a,i1,a)")sjoin(library,"accrho_mpi, istwfk "),istwf_k," :"
2454 : 8 : write(msg,"(a)")" OK"
2455 [ - + ]: 8 : if (max_relerr > RTOL_DP) then
2456 : 0 : write(msg,"(a,es9.2,a)")" FAILED (max_relerr = ",max_relerr,")"
2457 : : end if
2458 : 8 : call wrtout(ount, sjoin(info, msg))
2459 : :
2460 [ - + ]: 8 : ABI_FREE(density)
2461 : :
2462 : : ! -------------------------------------------
2463 : : ! Test the application of the local potential
2464 : : ! -------------------------------------------
2465 : 8 : cplex = 1
2466 [ - + + - : 32 : ABI_MALLOC(pot, (cplex*n4,n5,n6))
- + + - -
+ + - - +
- + - + ]
2467 [ - + + - : 32 : ABI_MALLOC(invpot, (cplex*n4,n5,n6))
- + + - -
+ + - - +
- + - + ]
2468 : :
2469 [ + - ]: 8 : if (me_fft == g0sender) then
2470 : : !pot = fofr(1,:,:,:)
2471 : : !call RANDOM_NUMBER(pot)
2472 : : !where (abs(pot) < tol4) pot = tol4
2473 : : ! Simplest potential ever (G=0 to reduce errors due to aliasing)
2474 [ + + + + : 14172488 : pot = four
+ + ]
2475 [ - + + + : 14172496 : invpot = one/pot
+ + + + ]
2476 : : end if
2477 : :
2478 : 8 : call xmpi_bcast(pot,g0sender,comm_fft,ierr)
2479 : 8 : call xmpi_bcast(invpot,g0sender,comm_fft,ierr)
2480 : :
2481 [ - + + - : 16 : ABI_MALLOC(fofg_out, (2,npw_k*ndat))
- + - + ]
2482 : :
2483 : : ! Compute fofg_out = <G|pot(r)|fofg>
2484 : : call fourwf_mpi(cplex,pot,fofg,fofg_out,fofr,&
2485 : : gbound_k,gbound_k,istwfk_one,kg_k,kg_k,me_g0,mgfft,ngfft,fftabs,n1,n2,n3,&
2486 : 8 : npw_k,npw_k,n4,n5,n6,ndat,2,weight_r,weight_i,comm_fft,cplexwf=cplexwf)
2487 : :
2488 : : ! Compute fofg = <G|1/pot(r)|fofg_out>
2489 : : call fourwf_mpi(cplex,invpot,fofg_out,fofg,fofr,&
2490 : : gbound_k,gbound_k,istwfk_one,kg_k,kg_k,me_g0,mgfft,ngfft,fftabs,n1,n2,n3,&
2491 : 8 : npw_k,npw_k,n4,n5,n6,ndat,2,weight_r,weight_i,comm_fft,cplexwf=cplexwf)
2492 : :
2493 : : ! Check if we got the initial u(g) within ATOL_DP
2494 [ + + + + : 4648328 : ierr = COUNT(ABS(fofg - ref_fofg) > ATOL_DP)
- + ]
2495 : 8 : call xmpi_sum(ierr,comm_fft,mpierr)
2496 : 8 : nfailed = nfailed + ierr
2497 : :
2498 : 8 : write(info,"(a,i1,a)")sjoin(library,"<G|vloc|u>, istwfk "),istwf_k," :"
2499 : 8 : write(msg,"(a)")" OK"
2500 [ - + ]: 8 : if (ierr /= 0) then
2501 [ # # # # : 0 : max_abserr = MAXVAL(ABS(fofg - ref_fofg))
# # # # #
# # # ]
2502 : 0 : call xmpi_max(max_abserr,comm_fft,mpierr)
2503 : 0 : write(msg,"(a,es9.2,a)")" FAILED (max_abserr = ",max_abserr,")"
2504 : : !if (me_fft == 0) write(std_out,*)(fofg(:,ig),ref_fofg(:,ig), ig=1,npw_k*ndat)
2505 : : end if
2506 : 8 : call wrtout(ount, sjoin(info, msg))
2507 : :
2508 [ - + ]: 8 : ABI_FREE(fofg_out)
2509 [ - + ]: 8 : ABI_FREE(pot)
2510 [ - + ]: 8 : ABI_FREE(invpot)
2511 [ - + ]: 8 : ABI_FREE(kg_k)
2512 [ - + ]: 8 : ABI_FREE(gbound_k)
2513 [ - + ]: 8 : ABI_FREE(fofg)
2514 [ - + ]: 8 : ABI_FREE(ref_fofg)
2515 [ - + ]: 8 : ABI_FREE(fofr)
2516 [ - + ]: 8 : ABI_FREE(full_kg_k)
2517 [ - + ]: 8 : ABI_FREE(full_fofg)
2518 : :
2519 : 68 : call fftabs%free()
2520 : : end do
2521 : :
2522 [ - + ]: 4 : if (nthreads > 0) call xomp_set_num_threads(old_nthreads)
2523 : :
2524 [ - + - + : 4 : end function fftu_mpi_utests
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + ]
2525 : : !!***
2526 : :
2527 : : !!****f* ABINIT/fourwf_optmem
2528 : : !! NAME
2529 : : !! fourwf_optmem
2530 : : !!
2531 : : !! FUNCTION
2532 : : !! Wrapper on fourwf call, meant to be called on a fofr array smaller than ndat.
2533 : : !! Mainly used in sections where this array may explode in size, thus requiring
2534 : : !! fourwf computation to be done in many times to save on memory.
2535 : : !! For now, only GPU usecases are handled, where lack of memory is problematic
2536 : : !! even if CPU usecases can be handled by this routine.
2537 : : !! Arguments are identical to fourwf, except for extra 'nblocks', and the size of fofr array.
2538 : : !! For option={0,3} or gpu_option=ABI_GPU_DISABLED, regular fourwf is used and fofr is assumed sized by ndat
2539 : : !!
2540 : : !! Carry out composite Fourier transforms between real and reciprocal (G) space.
2541 : : !! Wavefunctions, contained in a sphere in reciprocal space,
2542 : : !! can be FFT to real space. They can also be FFT from real space
2543 : : !! to a sphere. Also, the density maybe accumulated, and a local
2544 : : !! potential can be applied.
2545 : : !!
2546 : : !! The different options are :
2547 : : !! - option=0 --> reciprocal to real space and output the result.
2548 : : !! - option=1 --> reciprocal to real space and accumulate the density.
2549 : : !! - option=2 --> reciprocal to real space, apply the local potential to the wavefunction
2550 : : !! in real space and produce the result in reciprocal space.
2551 : : !! - option=3 --> real space to reciprocal space.
2552 : : !! NOTE that in this case, fftalg=1x1 MUST be used. This may be changed in the future.
2553 : : !!
2554 : : !! The different sections of this routine corresponds to different
2555 : : !! algorithms, used independently of each others :
2556 : : !!(read first the description of the fftalg input variable in abinit_help)
2557 : : !! - fftalg=xx0 : use simple complex-to-complex routines, without zero padding
2558 : : !! (rather simple, so can be used to understand how fourwf.f works);
2559 : : !! - fftalg=1x1 : use S Goedecker routines, with zero padding
2560 : : !! (7/12 savings in execution time);
2561 : : !! - fftalg=1x2 : call even more sophisticated coding also based on S Goedecker routines
2562 : : !!
2563 : : !! This routine contains many parts that differ only
2564 : : !! by small details, in order to treat each case with the better speed.
2565 : : !! Also for better speed, it uses no F90 construct, except the allocate command
2566 : : !! and for zeroing arrays.
2567 : : !!
2568 : : !! INPUTS
2569 : : !! cplex= if 1 , denpot is real, if 2 , denpot is complex
2570 : : !! (cplex=2 only allowed for option=2, and istwf_k=1)
2571 : : !! not relevant if option=0 or option=3, so cplex=0 can be used to minimize memory
2572 : : !! fofgin(2,npwin)=holds input wavefunction in G vector basis sphere.
2573 : : !! (intent(in) but the routine sphere can modify it for another iflag)
2574 : : !! gboundin(2*mgfft+8,2)=sphere boundary info for reciprocal to real space
2575 : : !! gboundout(2*mgfft+8,2)=sphere boundary info for real to reciprocal space
2576 : : !! istwf_k=option parameter that describes the storage of wfs
2577 : : !! kg_kin(3,npwin)=reduced planewave coordinates, input
2578 : : !! kg_kout(3,npwout)=reduced planewave coordinates, output
2579 : : !! mgfft=maximum size of 1D FFTs
2580 : : !! mpi_enreg=information about MPI parallelization
2581 : : !! ndat=number of FFT to do in //
2582 : : !! nblocks=number of FFT to split computation into
2583 : : !! ngfft(18)=contain all needed information about 3D FFT, see ~abinit/doc/variables/vargs.htm#ngfft
2584 : : !! npwin=number of elements in fofgin array (for option 0, 1 and 2)
2585 : : !! npwout=number of elements in fofgout array (for option 2 and 3)
2586 : : !! n4,n5,n6=ngfft(4),ngfft(5),ngfft(6), dimensions of fofr.
2587 : : !! option= if 0: do direct FFT
2588 : : !! if 1: do direct FFT, then sum the density
2589 : : !! if 2: do direct FFT, multiply by the potential, then do reverse FFT
2590 : : !! if 3: do reverse FFT only
2591 : : !! tim_fourwf=timing code of the calling routine (can be set to 0 if not attributed)
2592 : : !! weight_r=weight to be used for the accumulation of the density in real space
2593 : : !! (needed only when option=1)
2594 : : !! weight_i=weight to be used for the accumulation of the density in real space
2595 : : !! (needed only when option=1 and (fftalg=4 and fftalgc/=0))
2596 : : !! [weight_array_r]= -- optional -- same as weight_r when ndat>1
2597 : : !! weight_array_r(i)=weight_r to be used for band i
2598 : : !! at present only used for the GPU version
2599 : : !! [weight_array_i]= -- optional -- same as weight_i when ndat>1
2600 : : !! weight_array_i(i)=weight_i to be used for band i
2601 : : !! at present only used for the GPU version
2602 : : !! [fofginb(2,npwin)]=holds second input wavefunction in G vector basis sphere.
2603 : : !! (intent(in) but the routine sphere can modify it for another iflag)
2604 : : !! (for non diagonal occupation)
2605 : : !! [use_ndo] = use non diagonal occupations.
2606 : : !! [gpu_option] = GPU implementation to use, i.e. cuda, openMP, ... (0=not using GPU)
2607 : : !!
2608 : : !! OUTPUT
2609 : : !! (see side effects)
2610 : : !!
2611 : : !! SIDE EFFECTS
2612 : : !! Input/Output
2613 : : !! for option==0, fofgin(2,npwin*ndat)=holds input wavefunction in G sphere;
2614 : : !! fofr(2,n4,n5,n6*ndat) contains the output Fourier Transform of fofgin;
2615 : : !! no use of denpot, fofgout and npwout.
2616 : : !! for option==1, fofgin(2,npwin*ndat)=holds input wavefunction in G sphere;
2617 : : !! denpot(cplex*n4,n5,n6) contains the input density at input,
2618 : : !! and the updated density at output (accumulated);
2619 : : !! no use of fofgout and npwout.
2620 : : !! for option==2, fofgin(2,npwin*ndat)=holds input wavefunction in G sphere;
2621 : : !! denpot(cplex*n4,n5,n6) contains the input local potential;
2622 : : !! fofgout(2,npwout*ndat) contains the output function;
2623 : : !! for option==3, fofr(2,n4,n5,n6*ndat) contains the input real space wavefunction;
2624 : : !! fofgout(2,npwout*ndat) contains its output Fourier transform;
2625 : : !! no use of fofgin and npwin.
2626 : : !!
2627 : : !! NOTES
2628 : : !! DO NOT CHANGE THE API OF THIS FUNCTION.
2629 : : !! If you need a specialized routine for the FFT of the wavefunctions, create
2630 : : !! a wrapper that uses fourwf to accomplish your task. This routine, indeed,
2631 : : !! has already too many parameters and each change in the API requires a careful
2632 : : !! modification of the different wrappers used for specialized FFTs such as FFTW3 and MKL-DFTI
2633 : : !!
2634 : : !! SOURCE
2635 : :
2636 [ - + ]: 41708080 : subroutine fourwf_optmem(cplex,denpot,fofgin,fofgout,fofr,gboundin,gboundout,istwf_k,&
2637 : 41708080 : kg_kin,kg_kout,mgfft,mpi_enreg,ndat,nblocks,ngfft,npwin,npwout,n4,n5,n6,option,&
2638 : : tim_fourwf,weight_r,weight_i, &
2639 [ - + - - : 41708080 : weight_array_r,weight_array_i,gpu_option,use_ndo,fofginb) ! Optional arguments
- - ]
2640 : :
2641 : : !Arguments ------------------------------------
2642 : : !scalars
2643 : : integer,intent(in) :: cplex,istwf_k,mgfft,n4,n5,n6,ndat,nblocks,npwin,npwout,option
2644 : : integer,intent(in) :: tim_fourwf
2645 : : integer,intent(in),optional :: gpu_option,use_ndo
2646 : : real(dp),intent(in) :: weight_r,weight_i
2647 : : real(dp),intent(in),optional,target :: weight_array_r(ndat),weight_array_i(ndat)
2648 : : type(MPI_type),intent(in) :: mpi_enreg
2649 : : !arrays
2650 : : integer,intent(in) :: gboundin(2*mgfft+8,2),gboundout(2*mgfft+8,2)
2651 : : integer,intent(in) :: kg_kin(3,npwin),kg_kout(3,npwout),ngfft(18)
2652 : : real(dp),intent(inout) :: denpot(cplex*n4,n5,n6),fofgin(2,npwin*ndat)
2653 : : real(dp),intent(inout),optional :: fofginb(:,:) ! (2,npwin*ndat)
2654 : : real(dp),intent(inout) :: fofr(:,:,:,:) !(2,n4,n5,n6*(ndat/nblocks+ndat-(ndat/nblocks)*nblocks))
2655 : : real(dp),intent(out) :: fofgout(2,npwout*ndat)
2656 : :
2657 : 41708080 : real(dp),pointer :: weight_ptr_r(:),weight_ptr_i(:)
2658 : :
2659 : : integer :: ii,chunk,residuchunk,iblock,gpu_option_
2660 : : integer :: firstelt,firstelt_out,firstband,lastelt,lastelt_out,lastband
2661 : :
2662 : 41708080 : gpu_option_=ABI_GPU_DISABLED; if(present(gpu_option)) gpu_option_=gpu_option
2663 : :
2664 [ - + ]: 41708080 : ABI_CHECK_IEQ(size(fofr,dim=1), 2, 'wrong size for fofr (dim 1)')
2665 [ - + ]: 41708080 : ABI_CHECK_IEQ(size(fofr,dim=2), n4, 'wrong size for fofr (dim 2)')
2666 [ - + ]: 41708080 : ABI_CHECK_IEQ(size(fofr,dim=3), n5, 'wrong size for fofr (dim 3)')
2667 : :
2668 [ - + - - : 41708080 : if(gpu_option_==ABI_GPU_DISABLED .or. option==0 .or. option==3) then
- - ]
2669 [ - + ]: 41708080 : if(gpu_option/=ABI_GPU_DISABLED) then
2670 [ # # ]: 0 : ABI_CHECK_IEQ(size(fofr,dim=4), n6*ndat, 'wrong size for fofr (dim 4)')
2671 : : end if
2672 : :
2673 : : call fourwf(cplex,denpot,fofgin,fofgout,fofr,gboundin,gboundout,istwf_k,&
2674 : : & kg_kin,kg_kout,mgfft,mpi_enreg,ndat,ngfft,npwin,npwout,n4,n5,n6,option,&
2675 : : & tim_fourwf,weight_r,weight_i, &
2676 : : & weight_array_r=weight_array_r,weight_array_i=weight_array_i,&
2677 [ - + - - : 83416160 : & gpu_option=gpu_option,use_ndo=use_ndo,fofginb=fofginb)
- - - - -
- - - + -
- + - - -
- - - -
- ]
2678 : :
2679 : : else
2680 : 0 : chunk = ndat/nblocks
2681 : 0 : residuchunk = ndat - nblocks*chunk
2682 : :
2683 [ # # ]: 0 : ABI_CHECK_IEQ(size(fofr,dim=4), n6*(chunk+residuchunk), 'wrong size for fofr (dim 4)')
2684 : :
2685 [ # # ]: 0 : if(option==1) then
2686 : :
2687 [ # # ]: 0 : if (present(weight_array_r)) then
2688 : 0 : weight_ptr_r => weight_array_r
2689 : : else
2690 [ # # # # : 0 : ABI_MALLOC(weight_ptr_r,(ndat))
# # # # #
# # # ]
2691 [ # # ]: 0 : weight_ptr_r(:)=weight_r
2692 : : end if
2693 [ # # ]: 0 : if (present(weight_array_i)) then
2694 : 0 : weight_ptr_i => weight_array_i
2695 : : else
2696 [ # # # # : 0 : ABI_MALLOC(weight_ptr_i,(ndat))
# # # # #
# # # ]
2697 [ # # ]: 0 : weight_ptr_i(:)=weight_i
2698 : : end if
2699 : :
2700 [ # # ]: 0 : do ii=1,nblocks
2701 : 0 : iblock=ii-1
2702 [ # # ]: 0 : if ( iblock < nblocks-residuchunk ) then
2703 : 0 : firstband = iblock*chunk+1
2704 : 0 : lastband = (iblock+1)*chunk
2705 : : else
2706 : 0 : firstband = (nblocks-residuchunk)*chunk + ( iblock -(nblocks-residuchunk) )*(chunk+1) +1
2707 : 0 : lastband = firstband+chunk
2708 : : end if
2709 : 0 : firstelt = (firstband-1)*npwin+1; lastelt = lastband*npwin
2710 : : call fourwf(cplex,denpot,&
2711 : : & fofgin(:,firstelt:lastelt),&
2712 : : & fofgout,fofr,gboundin,gboundout,&
2713 : : & istwf_k,kg_kin,kg_kout,mgfft,mpi_enreg,lastband-firstband+1,&
2714 : : & ngfft,npwin,npwout,n4,n5,n6,option,tim_fourwf,weight_r,weight_i,&
2715 : : & weight_array_r=weight_ptr_r(firstband:lastband),&
2716 : : & weight_array_i=weight_ptr_i(firstband:lastband),&
2717 [ # # # # : 0 : & gpu_option=gpu_option_,use_ndo=use_ndo,fofginb=fofginb)
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
2718 : : end do
2719 : :
2720 [ # # ]: 0 : if (.not.present(weight_array_r)) then
2721 [ # # ]: 0 : ABI_FREE(weight_ptr_r)
2722 : : end if
2723 [ # # ]: 0 : if (.not.present(weight_array_i)) then
2724 [ # # ]: 0 : ABI_FREE(weight_ptr_i)
2725 : : end if
2726 : :
2727 [ # # ]: 0 : else if(option==2) then
2728 : :
2729 [ # # ]: 0 : do ii=1,nblocks
2730 : 0 : iblock=ii-1
2731 [ # # ]: 0 : if ( iblock < nblocks-residuchunk ) then
2732 : 0 : firstband = iblock*chunk+1
2733 : 0 : lastband = (iblock+1)*chunk
2734 : : else
2735 : 0 : firstband = (nblocks-residuchunk)*chunk + ( iblock -(nblocks-residuchunk) )*(chunk+1) +1
2736 : 0 : lastband = firstband+chunk
2737 : : end if
2738 : 0 : firstelt = (firstband-1)*npwin+1; lastelt = lastband*npwin
2739 : 0 : firstelt_out = (firstband-1)*npwout+1; lastelt_out = lastband*npwout
2740 : : call fourwf(cplex,denpot,&
2741 : : & fofgin(:,firstelt:lastelt),&
2742 : : & fofgout(:,firstelt_out:lastelt_out),fofr,gboundin,gboundout,&
2743 : : & istwf_k,kg_kin,kg_kout,mgfft,mpi_enreg,lastband-firstband+1,&
2744 : : & ngfft,npwin,npwout,n4,n5,n6,option,tim_fourwf,weight_r,weight_i,&
2745 [ # # # # : 0 : & gpu_option=gpu_option_,use_ndo=use_ndo,fofginb=fofginb)
# # # # #
# # # # #
# # # # #
# # # #
# ]
2746 : : end do
2747 : :
2748 : : end if
2749 : :
2750 : : end if
2751 : :
2752 : :
2753 [ + - ]: 41708080 : end subroutine fourwf_optmem
2754 : : !!***
2755 : :
2756 : : !!****f* ABINIT/fourwf
2757 : : !! NAME
2758 : : !! fourwf
2759 : : !!
2760 : : !! FUNCTION
2761 : : !! Carry out composite Fourier transforms between real and reciprocal (G) space.
2762 : : !! Wavefunctions, contained in a sphere in reciprocal space,
2763 : : !! can be FFT to real space. They can also be FFT from real space
2764 : : !! to a sphere. Also, the density maybe accumulated, and a local
2765 : : !! potential can be applied.
2766 : : !!
2767 : : !! The different options are :
2768 : : !! - option=0 --> reciprocal to real space and output the result.
2769 : : !! - option=1 --> reciprocal to real space and accumulate the density.
2770 : : !! - option=2 --> reciprocal to real space, apply the local potential to the wavefunction
2771 : : !! in real space and produce the result in reciprocal space.
2772 : : !! - option=3 --> real space to reciprocal space.
2773 : : !! NOTE that in this case, fftalg=1x1 MUST be used. This may be changed in the future.
2774 : : !!
2775 : : !! The different sections of this routine corresponds to different
2776 : : !! algorithms, used independently of each others :
2777 : : !!(read first the description of the fftalg input variable in abinit_help)
2778 : : !! - fftalg=xx0 : use simple complex-to-complex routines, without zero padding
2779 : : !! (rather simple, so can be used to understand how fourwf.f works);
2780 : : !! - fftalg=1x1 : use S Goedecker routines, with zero padding
2781 : : !! (7/12 savings in execution time);
2782 : : !! - fftalg=1x2 : call even more sophisticated coding also based on S Goedecker routines
2783 : : !!
2784 : : !! This routine contains many parts that differ only
2785 : : !! by small details, in order to treat each case with the better speed.
2786 : : !! Also for better speed, it uses no F90 construct, except the allocate command
2787 : : !! and for zeroing arrays.
2788 : : !!
2789 : : !! INPUTS
2790 : : !! cplex= if 1 , denpot is real, if 2 , denpot is complex
2791 : : !! (cplex=2 only allowed for option=2, and istwf_k=1)
2792 : : !! not relevant if option=0 or option=3, so cplex=0 can be used to minimize memory
2793 : : !! fofgin(2,npwin)=holds input wavefunction in G vector basis sphere.
2794 : : !! (intent(in) but the routine sphere can modify it for another iflag)
2795 : : !! gboundin(2*mgfft+8,2)=sphere boundary info for reciprocal to real space
2796 : : !! gboundout(2*mgfft+8,2)=sphere boundary info for real to reciprocal space
2797 : : !! istwf_k=option parameter that describes the storage of wfs
2798 : : !! kg_kin(3,npwin)=reduced planewave coordinates, input
2799 : : !! kg_kout(3,npwout)=reduced planewave coordinates, output
2800 : : !! mgfft=maximum size of 1D FFTs
2801 : : !! mpi_enreg=information about MPI parallelization
2802 : : !! ndat=number of FFT to do in //
2803 : : !! ngfft(18)=contain all needed information about 3D FFT, see ~abinit/doc/variables/vargs.htm#ngfft
2804 : : !! npwin=number of elements in fofgin array (for option 0, 1 and 2)
2805 : : !! npwout=number of elements in fofgout array (for option 2 and 3)
2806 : : !! n4,n5,n6=ngfft(4),ngfft(5),ngfft(6), dimensions of fofr.
2807 : : !! option= if 0: do direct FFT
2808 : : !! if 1: do direct FFT, then sum the density
2809 : : !! if 2: do direct FFT, multiply by the potential, then do reverse FFT
2810 : : !! if 3: do reverse FFT only
2811 : : !! tim_fourwf=timing code of the calling routine (can be set to 0 if not attributed)
2812 : : !! weight_r=weight to be used for the accumulation of the density in real space
2813 : : !! (needed only when option=1)
2814 : : !! weight_i=weight to be used for the accumulation of the density in real space
2815 : : !! (needed only when option=1 and (fftalg=4 and fftalgc/=0))
2816 : : !! [weight_array_r]= -- optional -- same as weight_r when ndat>1
2817 : : !! weight_array_r(i)=weight_r to be used for band i
2818 : : !! at present only used for the GPU version
2819 : : !! [weight_array_i]= -- optional -- same as weight_i when ndat>1
2820 : : !! weight_array_i(i)=weight_i to be used for band i
2821 : : !! at present only used for the GPU version
2822 : : !! [fofginb(2,npwin)]=holds second input wavefunction in G vector basis sphere.
2823 : : !! (intent(in) but the routine sphere can modify it for another iflag)
2824 : : !! (for non diagonal occupation)
2825 : : !! [use_ndo] = use non diagonal occupations.
2826 : : !! [gpu_option] = GPU implementation to use, i.e. cuda, openMP, ... (0=not using GPU)
2827 : : !!
2828 : : !! OUTPUT
2829 : : !! (see side effects)
2830 : : !!
2831 : : !! SIDE EFFECTS
2832 : : !! Input/Output
2833 : : !! for option==0, fofgin(2,npwin*ndat)=holds input wavefunction in G sphere;
2834 : : !! fofr(2,n4,n5,n6*ndat) contains the output Fourier Transform of fofgin;
2835 : : !! no use of denpot, fofgout and npwout.
2836 : : !! for option==1, fofgin(2,npwin*ndat)=holds input wavefunction in G sphere;
2837 : : !! denpot(cplex*n4,n5,n6) contains the input density at input,
2838 : : !! and the updated density at output (accumulated);
2839 : : !! no use of fofgout and npwout.
2840 : : !! for option==2, fofgin(2,npwin*ndat)=holds input wavefunction in G sphere;
2841 : : !! denpot(cplex*n4,n5,n6) contains the input local potential;
2842 : : !! fofgout(2,npwout*ndat) contains the output function;
2843 : : !! for option==3, fofr(2,n4,n5,n6*ndat) contains the input real space wavefunction;
2844 : : !! fofgout(2,npwout*ndat) contains its output Fourier transform;
2845 : : !! no use of fofgin and npwin.
2846 : : !!
2847 : : !! NOTES
2848 : : !! DO NOT CHANGE THE API OF THIS FUNCTION.
2849 : : !! If you need a specialized routine for the FFT of the wavefunctions, create
2850 : : !! a wrapper that uses fourwf to accomplish your task. This routine, indeed,
2851 : : !! has already too many parameters and each change in the API requires a careful
2852 : : !! modification of the different wrappers used for specialized FFTs such as FFTW3 and MKL-DFTI
2853 : : !!
2854 : : !! SOURCE
2855 : :
2856 : 123184106 : subroutine fourwf(cplex,denpot,fofgin,fofgout,fofr,gboundin,gboundout,istwf_k,&
2857 : 61592053 : kg_kin,kg_kout,mgfft,mpi_enreg,ndat,ngfft,npwin,npwout,n4,n5,n6,option,&
2858 : : tim_fourwf,weight_r,weight_i, &
2859 [ + + + - : 61592053 : weight_array_r,weight_array_i,gpu_option,use_ndo,fofginb) ! Optional arguments
- + ]
2860 : :
2861 : : !Arguments ------------------------------------
2862 : : !scalars
2863 : : integer,intent(in) :: cplex,istwf_k,mgfft,n4,n5,n6,ndat,npwin,npwout,option
2864 : : integer,intent(in) :: tim_fourwf
2865 : : integer,intent(in),optional :: gpu_option,use_ndo
2866 : : real(dp),intent(in) :: weight_r,weight_i
2867 : : real(dp),intent(in),optional,target :: weight_array_r(ndat),weight_array_i(ndat)
2868 : : type(MPI_type),intent(in) :: mpi_enreg
2869 : : !arrays
2870 : : integer,intent(in) :: gboundin(2*mgfft+8,2),gboundout(2*mgfft+8,2)
2871 : : integer,intent(in) :: kg_kin(3,npwin),kg_kout(3,npwout),ngfft(18)
2872 : : real(dp),intent(inout) :: denpot(cplex*n4,n5,n6),fofgin(2,npwin*ndat)
2873 : : real(dp),intent(inout),optional :: fofginb(:,:) ! (2,npwin*ndat)
2874 : : real(dp),intent(inout) :: fofr(2,n4,n5,n6*ndat)
2875 : : real(dp),intent(out) :: fofgout(2,npwout*ndat)
2876 : :
2877 : : !Local variables-------------------------------
2878 : : !scalars
2879 : : integer :: fftalg,fftalga,fftalgc,fftcache,i1,i2,i2_local,i3,i3_local,i3_glob,idat,ier
2880 : : integer :: iflag,ig,comm_fft,me_g0,me_fft,n1,n2,n3,nd2proc,nd3proc
2881 : : integer :: nfftot,nproc_fft,option_ccfft,paral_kgb,gpu_option_
2882 : : real(dp) :: fim,fre,xnorm
2883 : : character(len=500) :: msg
2884 : : logical :: luse_ndo
2885 : : !arrays
2886 : : integer,parameter :: shiftg0(3)=0
2887 : : integer,parameter :: symmE(3,3)=reshape([1,0,0,0,1,0,0,0,1],[3,3])
2888 : 61592053 : integer, contiguous, pointer :: fftn2_distrib(:),ffti2_local(:)
2889 : 61592053 : integer, contiguous, pointer :: fftn3_distrib(:),ffti3_local(:)
2890 : : real(dp) :: tsec(2)
2891 : 61592053 : real(dp),allocatable :: work1(:,:,:,:),work2(:,:,:,:),work3(:,:,:,:)
2892 : 61592053 : real(dp),allocatable :: work4(:,:,:,:),work_sum(:,:,:,:)
2893 : 61592053 : real(dp),pointer :: weight_ptr_r(:),weight_ptr_i(:)
2894 : : ! *************************************************************************
2895 : :
2896 : : ! Accumulate timing
2897 : 61592053 : call timab(840+tim_fourwf,1,tsec)
2898 : :
2899 [ - + ]: 61592053 : if (fourwf_counter>=0) then
2900 : 0 : fourwf_counter = fourwf_counter + ndat
2901 [ # # ]: 0 : if (option==2) fourwf_counter = fourwf_counter + ndat
2902 : : end if
2903 : :
2904 : 61592053 : n1=ngfft(1); n2=ngfft(2); n3=ngfft(3); nfftot=n1*n2*n3
2905 : 61592053 : fftcache=ngfft(8)
2906 : 61592053 : fftalg=ngfft(7); fftalga=fftalg/100; fftalgc=mod(fftalg,10)
2907 : 61592053 : me_fft=ngfft(11)
2908 : 61592053 : nproc_fft=ngfft(10)
2909 : :
2910 : 61592053 : comm_fft = mpi_enreg%comm_fft; me_g0 = mpi_enreg%me_g0_fft
2911 : 61592053 : paral_kgb = mpi_enreg%paral_kgb
2912 : :
2913 : : !if (ndat/=1) then
2914 : : ! write(std_out,*)fftalg
2915 : : ! ABI_ERROR("Really? I thought nobody uses ndat > 1")
2916 : : !end if
2917 : :
2918 : : !if (weight_r /= weight_i) then
2919 : : ! write(std_out,*)fftalg
2920 : : ! ABI_ERROR("Really? I thought nobody uses weight_r != weight_i")
2921 : : !end if
2922 : :
2923 : : !if (option == 0 .and. fftalgc == 0) then
2924 : : ! ABI_ERROR("Option 0 is buggy when fftalgc ==0 is used!")
2925 : : !end if
2926 : :
2927 : : !GPU version of fourwf
2928 : 61592053 : gpu_option_=ABI_GPU_DISABLED
2929 [ + + ]: 61592053 : if (PRESENT(gpu_option)) gpu_option_=gpu_option
2930 : :
2931 : : !If processing gamma-point, disable GPU, except OpenMP (not supported on other variants)
2932 [ + + + + : 61592053 : if(me_g0==1 .and. istwf_k>1 .and. gpu_option_/=ABI_GPU_OPENMP) then
- + ]
2933 : : gpu_option_=ABI_GPU_DISABLED
2934 : : end if
2935 : :
2936 [ - + ]: 60177018 : if(gpu_option_/=ABI_GPU_DISABLED) then
2937 [ # # ]: 0 : if (present(weight_array_r)) then
2938 : 0 : weight_ptr_r => weight_array_r
2939 : : else
2940 [ # # # # : 0 : ABI_MALLOC(weight_ptr_r,(ndat))
# # # # #
# # # ]
2941 [ # # ]: 0 : weight_ptr_r(:)=weight_r
2942 : : end if
2943 [ # # ]: 0 : if (present(weight_array_i)) then
2944 : 0 : weight_ptr_i => weight_array_i
2945 : : else
2946 [ # # # # : 0 : ABI_MALLOC(weight_ptr_i,(ndat))
# # # # #
# # # ]
2947 [ # # ]: 0 : weight_ptr_i(:)=weight_i
2948 : : end if
2949 : : if(gpu_option_==ABI_GPU_LEGACY) then
2950 : : #if defined HAVE_GPU_CUDA
2951 : : call gpu_fourwf(cplex,denpot,fofgin,fofgout,fofr,gboundin,gboundout,istwf_k,&
2952 : : kg_kin,kg_kout,mgfft,mpi_enreg,ndat,ngfft,npwin,npwout,n4,n5,n6,option,&
2953 : : paral_kgb,tim_fourwf,weight_ptr_r,weight_ptr_i) !,use_ndo,fofginb)
2954 : : #endif
2955 : : else if(gpu_option_==ABI_GPU_KOKKOS) then
2956 : : #if defined HAVE_GPU_CUDA && defined HAVE_YAKL
2957 : : call gpu_fourwf_managed(cplex,denpot,fofgin,fofgout,fofr,gboundin,gboundout,istwf_k,&
2958 : : kg_kin,kg_kout,mgfft,mpi_enreg,ndat,ngfft,npwin,npwout,n4,n5,n6,option,&
2959 : : paral_kgb,tim_fourwf,weight_ptr_r,weight_ptr_i) !,use_ndo,fofginb)
2960 : : #endif
2961 : : else if(gpu_option_==ABI_GPU_OPENMP) then
2962 : : #ifdef HAVE_OPENMP_OFFLOAD
2963 : : call ompgpu_fourwf(cplex,denpot,fofgin,fofgout,fofr,gboundin,gboundout,istwf_k,&
2964 : : kg_kin,kg_kout,mgfft,me_g0,ndat,ngfft,npwin,npwout,n4,n5,n6,option,&
2965 : : weight_ptr_r,weight_ptr_i,use_ndo=use_ndo,fofginb=fofginb)
2966 : : #endif
2967 : : end if
2968 [ # # ]: 0 : if (.not.present(weight_array_r)) then
2969 [ # # ]: 0 : ABI_FREE(weight_ptr_r)
2970 : : end if
2971 [ # # ]: 0 : if (.not.present(weight_array_i)) then
2972 [ # # ]: 0 : ABI_FREE(weight_ptr_i)
2973 : : end if
2974 : 0 : call timab(840+tim_fourwf,2,tsec)
2975 : : return
2976 : : end if ! GPU
2977 : :
2978 [ - + ]: 61592053 : if ((fftalgc < 0 .or. fftalgc > 2)) then
2979 : : write(msg, '(a,i0,5a)' )&
2980 : 0 : 'The input algorithm number fftalg= ',fftalg,' is not allowed.',ch10,&
2981 : 0 : 'The third digit, fftalg(C), must be 0, 1, or 2',ch10,&
2982 : 0 : 'Action: change fftalg in your input file.'
2983 : 0 : ABI_ERROR(msg)
2984 : : end if
2985 : :
2986 [ + + + + : 61592053 : if (fftalgc /= 0 .and. ALL(fftalga /= [1,3,4,5])) then
- + ]
2987 : : write(msg, '(a,i0,5a)' )&
2988 : 0 : 'The input algorithm number fftalg= ',fftalg,' is not allowed.',ch10,&
2989 : 0 : 'The first digit must be 1,3,4 when the last digit is not 0.',ch10,&
2990 : 0 : 'Action: change fftalg in your input file.'
2991 : 0 : ABI_ERROR(msg)
2992 : : end if
2993 : :
2994 [ - + ]: 61592053 : if (option < 0 .or. option > 3)then
2995 : : write(msg, '(a,i0,3a)' )&
2996 : 0 : 'The option number ',option,' is not allowed.',ch10,&
2997 : 0 : 'Only option=0, 1, 2 or 3 are allowed presently.'
2998 : 0 : ABI_ERROR(msg)
2999 : : end if
3000 : :
3001 [ + + - + ]: 61592053 : if (option == 1 .and. cplex /= 1) then
3002 : : write(msg, '(3a,i0,a)' )&
3003 : 0 : 'With the option number 1, cplex must be 1,',ch10,&
3004 : 0 : 'but it is cplex= ',cplex,'.'
3005 : 0 : ABI_ERROR(msg)
3006 : : end if
3007 : :
3008 [ + + - + ]: 61592053 : if (option==2 .and. (cplex/=1 .and. cplex/=2)) then
3009 : : write(msg, '(3a,i0,a)' )&
3010 : 0 : 'With the option number 2, cplex must be 1 or 2,',ch10,&
3011 : 0 : 'but it is cplex= ',cplex,'.'
3012 : 0 : ABI_ERROR(msg)
3013 : : end if
3014 : :
3015 : : ! DMFT uses its own FFT algorithm (that should be wrapped in a different routine!)
3016 : 61592053 : luse_ndo=.false.
3017 [ + + ]: 61592053 : if (present(use_ndo).and.present(fofginb)) then
3018 [ + + ]: 1478298 : if(use_ndo==1) then
3019 : 33010 : luse_ndo=.true.
3020 [ - + ]: 33010 : if((size(fofginb,2)==0)) then
3021 : : write(msg, '(a,a,a,i4,i5)' )&
3022 : 0 : 'fofginb has a dimension equal to zero and use_ndo==1',ch10,&
3023 : 0 : 'Action: check dimension of fofginb',size(fofginb,2),use_ndo
3024 : 0 : ABI_ERROR(msg)
3025 : : end if
3026 : : end if
3027 : : end if
3028 : :
3029 [ + + ]: 61592053 : if (luse_ndo) then
3030 [ + - - + ]: 33010 : if (.not.(fftalgc==2 .and. option/=3)) then
3031 : 0 : ABI_ERROR("luse_ndo but not .not.(fftalgc==2 .and. option/=3)")
3032 : : end if
3033 [ - + ]: 33010 : ABI_CHECK(nproc_fft==1, "DMFT with nproc_fft != 1")
3034 [ - + ]: 33010 : ABI_CHECK(ndat == 1, "use_ndo and ndat != 1 not coded")
3035 : :
3036 : : call sg_fftrisc_2(cplex,denpot,fofgin,fofgout,fofr,gboundin,gboundout,&
3037 : : istwf_k,kg_kin,kg_kout,&
3038 [ - + ]: 33010 : mgfft,ngfft,npwin,npwout,n4,n5,n6,option,weight_r,weight_2=weight_i,luse_ndo=luse_ndo,fofgin_p=fofginb)
3039 : 33010 : goto 100
3040 : : end if
3041 : :
3042 : : ! Get the distrib associated with this fft_grid => for i2 and i3 planes
3043 : 61559043 : call ptabs_fourwf(mpi_enreg,n2,n3,fftn2_distrib,ffti2_local,fftn3_distrib,ffti3_local)
3044 : :
3045 : : ! Branch immediately depending on nproc_fft
3046 [ + + + - ]: 61559043 : if (nproc_fft > 1 .and. fftalg /= 412) then
3047 : : call fourwf_mpi(cplex,denpot,fofgin,fofgout,fofr,gboundin,gboundout,&
3048 : : istwf_k,kg_kin,kg_kout,me_g0,mgfft,ngfft,mpi_enreg%distribfft,n1,n2,n3,npwin,npwout,&
3049 : 699442 : n4,n5,n6,ndat,option,weight_r,weight_i,comm_fft)
3050 : 699442 : goto 100
3051 : : end if
3052 : :
3053 : : select case (fftalga)
3054 : :
3055 : : case (FFT_FFTW3)
3056 : : if (luse_ndo) ABI_ERROR("luse_ndo not supported by FFTW3")
3057 [ # # ]: 0 : if (nproc_fft == 1) then
3058 : : ! call wrtout(std_out, "FFTW3_SEQFOURWF")
3059 : : call fftw3_seqfourwf(cplex,denpot,fofgin,fofgout,fofr,gboundin,gboundout,istwf_k,&
3060 : 0 : kg_kin,kg_kout,mgfft,ndat,ngfft,npwin,npwout,n4,n5,n6,option,weight_r,weight_i)
3061 : : else
3062 : 0 : ABI_ERROR("Not coded")
3063 : : end if
3064 : :
3065 : : case (FFT_DFTI)
3066 : : if (luse_ndo) ABI_ERROR("luse_ndo not supported by DFTI")
3067 [ + - ]: 59626109 : if (nproc_fft == 1) then
3068 : : ! call wrtout(std_out, "DFTI_SEQFOURWF")
3069 : : call dfti_seqfourwf(cplex,denpot,fofgin,fofgout,fofr,gboundin,gboundout,istwf_k,&
3070 : 59626109 : kg_kin,kg_kout,mgfft,ndat,ngfft,npwin,npwout,n4,n5,n6,option,weight_r,weight_i)
3071 : : else
3072 : 0 : ABI_ERROR("Not coded")
3073 : : end if
3074 : :
3075 : : case default
3076 : : ! TODO: Clean this code!
3077 : :
3078 : : ! Here, use routines that make forwards FFT separately of backwards FFT,
3079 : : ! in particular, usual 3DFFT library routines, called in ccfft.
3080 [ + + + + : 1233492 : if (fftalgc==0 .or. (fftalgc==1 .and. fftalga/=4) .or. &
+ + + + ]
3081 : : (fftalgc==2 .and. fftalga/=4 .and. option==3) )then
3082 : :
3083 [ - + + - : 184045 : ABI_MALLOC(work1,(2,n4,n5,n6*ndat))
- + + - -
+ + - + -
+ - - + -
+ ]
3084 : :
3085 [ + + ]: 36809 : if (option/=3)then
3086 : : ! Insert fofgin into the fft box (array fofr)
3087 : :
3088 [ + + ]: 8577 : if (fftalga/=4)then
3089 : 5906 : iflag=1
3090 : 5906 : call sphere(fofgin,ndat,npwin,fofr,n1,n2,n3,n4,n5,n6,kg_kin,istwf_k,iflag,me_g0,shiftg0,symmE,one)
3091 : :
3092 [ - + ]: 2671 : else if (fftalga==4 .and. fftalgc==0) then
3093 : : ! Note the switch of n5 and n6, as they are only
3094 : : ! needed to dimension work2 inside "sphere"
3095 [ - + + - : 13355 : ABI_MALLOC(work2,(2,n4,n6,n5*ndat))
- + + - -
+ + - + -
+ - - + -
+ ]
3096 : :
3097 : 2671 : iflag=2
3098 : 2671 : nd2proc=((n2-1)/nproc_fft) +1
3099 : 2671 : nd3proc=((n6-1)/nproc_fft) +1
3100 [ - + + - : 13355 : ABI_MALLOC(work3,(2,n4,n6,nd2proc*ndat))
- + + - -
+ + - + -
+ - - + -
+ ]
3101 [ - + + - : 13355 : ABI_MALLOC(work4,(2,n4,n5,nd3proc*ndat))
- + + - -
+ + - + -
+ - - + -
+ ]
3102 : :
3103 [ + + - + ]: 2671 : if (istwf_k == 1 .and. paral_kgb==1) then
3104 : : ! sphere dont need a big array
3105 [ # # # # : 0 : work3=zero
# # # # ]
3106 : : call sphere_fft(fofgin,ndat,npwin,work3,n1,n2,n3,n4,n6,kg_kin,&
3107 : 0 : mpi_enreg%distribfft%tab_fftwf2_local,nd2proc)
3108 : : else
3109 : : ! sphere needs a big array and communications
3110 [ - + - + : 2671 : if (nproc_fft == 1 .and. ndat == 1 .and. istwf_k == 1) then
+ + ]
3111 : : ! dimensions of tab work3 and work2 are identical no need to use work2
3112 [ + + + + : 68285179 : work3=zero
+ + + + ]
3113 : : call sphere(fofgin,ndat,npwin,work3,n1,n2,n3,n4,n6,nd2proc,&
3114 : 1298 : kg_kin,istwf_k,iflag,me_g0,shiftg0,symmE,one)
3115 : : else
3116 [ + + + + : 211074442 : work2=zero
+ + + + ]
3117 : : call sphere(fofgin,ndat,npwin,work2,n1,n2,n3,n4,n6,n5,&
3118 : 1373 : kg_kin,istwf_k,iflag,me_g0,shiftg0,symmE,one)
3119 : :
3120 [ - + - - ]: 1373 : if (paral_kgb==1 .and. istwf_k > 1) then
3121 : : ! Collect G-vectors on each node
3122 [ # # # # : 0 : work3=zero
# # # # ]
3123 [ # # # # : 0 : ABI_MALLOC(work_sum,(2,n4,n6,n5*ndat))
# # # # #
# # # # #
# # ]
3124 : 0 : call timab(48,1,tsec)
3125 : 0 : call xmpi_sum(work2,work_sum,2*n4*n6*n5*ndat,comm_fft,ier)
3126 : 0 : call timab(48,2,tsec)
3127 : :
3128 : : ! Extract my list of G-vectors needed for MPI-FFT.
3129 [ # # ]: 0 : do idat=1,ndat
3130 [ # # ]: 0 : do i2=1,n2
3131 [ # # ]: 0 : if( fftn2_distrib(i2) == me_fft) then
3132 : 0 : i2_local = ffti2_local(i2) + nd2proc*(idat-1)
3133 [ # # ]: 0 : do i3=1,n3
3134 [ # # ]: 0 : do i1=1,n1
3135 : 0 : work3(1,i1,i3,i2_local)=work_sum(1,i1,i3,i2+n5*(idat-1))
3136 : 0 : work3(2,i1,i3,i2_local)=work_sum(2,i1,i3,i2+n5*(idat-1))
3137 : : end do
3138 : : end do
3139 : : end if
3140 : : end do
3141 : : end do
3142 [ # # ]: 0 : ABI_FREE(work_sum)
3143 : : end if
3144 : :
3145 : : if (paral_kgb/=1) then
3146 [ + + ]: 2746 : do idat=1,ndat
3147 [ + + ]: 25598 : do i2=1,n2
3148 [ + + ]: 1024873 : do i3=1,n3
3149 [ + + ]: 69852532 : do i1=1,n1
3150 : 68829032 : work3(1,i1,i3,i2+nd2proc*(idat-1))=work2(1,i1,i3,i2+n5*(idat-1))
3151 : 69829680 : work3(2,i1,i3,i2+nd2proc*(idat-1))=work2(2,i1,i3,i2+n5*(idat-1))
3152 : : end do
3153 : : end do
3154 : : end do
3155 : : end do
3156 : : end if
3157 : : end if
3158 : : end if
3159 [ - + ]: 2671 : if (paral_kgb==1) then
3160 : 0 : option_ccfft=1
3161 : : else
3162 : 2671 : option_ccfft=2
3163 : : end if
3164 : : end if
3165 : :
3166 : : ! Fourier transform fofr (reciprocal to real space)
3167 : : ! The output might be in work1 or fofr, depending on inplace
3168 [ + + ]: 8577 : if (fftalgc==0) then
3169 [ + + ]: 8262 : if (fftalga/=4) then
3170 : : ! Call usual 3DFFT library routines
3171 : 5591 : call ccfft(ngfft,+1,n1,n2,n3,n4,n5,n6,ndat,2,fofr,work1,comm_fft)
3172 : : else
3173 : : ! SG simplest complex-to-complex routine
3174 : 2671 : call ccfft(ngfft,+1,n1,n2,n3,n4,n5,n6,ndat,option_ccfft,work3,work4,comm_fft)
3175 [ - + ]: 2671 : ABI_FREE(work2)
3176 [ - + ]: 2671 : ABI_FREE(work3)
3177 : : end if
3178 : : else
3179 : : ! Call SG routine, with zero padding
3180 : 315 : call sg_fftpad(fftcache,mgfft,n1,n2,n3,n4,n5,n6,ndat,gboundin,+1,fofr,work1)
3181 : : end if
3182 : : end if ! option/=3
3183 : :
3184 : : ! Note that if option==0 everything is alright already, the output is available in fofr.
3185 : : ! MG: TODO: Rewrite this mess in human-readable form!
3186 [ + + ]: 36809 : if (option==0) then
3187 [ + + ]: 5514 : if (fftalgc==0) then
3188 [ + + ]: 5422 : if (fftalga/=4) then
3189 : 5372 : call DCOPY(2*n4*n5*n6*ndat,work1,1,fofr,1)
3190 : : else
3191 : 50 : call DCOPY(2*n4*n5*n6*ndat,work4,1,fofr,1)
3192 : : end if
3193 : : else
3194 : : ! Results are copied to fofr.
3195 : 92 : call DCOPY(2*n4*n5*n6*ndat,work1,1,fofr,1)
3196 : : end if
3197 : : end if
3198 : :
3199 [ + + ]: 36809 : if (option==1) then
3200 : : ! Accumulate density
3201 [ + + ]: 555 : if ((fftalgc==0) .and. (fftalga==4)) then
3202 [ + + ]: 642 : do idat=1,ndat
3203 [ + + ]: 8432 : do i3=1,n3
3204 [ + - ]: 8111 : if( me_fft == fftn3_distrib(i3) ) then
3205 : 7790 : i3_local = ffti3_local(i3) + nd3proc*(idat-1)
3206 [ + + ]: 386446 : do i2=1,n2
3207 [ + + ]: 28413886 : do i1=1,n1
3208 : : denpot(i1,i2,i3)=denpot(i1,i2,i3)+&
3209 : : weight_r*work4(1,i1,i2,i3_local)**2+&
3210 : 28406096 : weight_i*work4(2,i1,i2,i3_local)**2
3211 : : end do
3212 : : end do
3213 : : end if
3214 : : end do
3215 : : end do ! idat
3216 : : else
3217 : 234 : call cg_addtorho(n1,n2,n3,n4,n5,n6,ndat,weight_r,weight_i,work1,denpot)
3218 : : end if
3219 : : end if ! option==1
3220 : :
3221 [ + + ]: 36809 : if (option==2) then
3222 : : ! Apply local potential
3223 [ + + ]: 2508 : if (cplex==1) then
3224 : :
3225 [ + + ]: 2489 : if ((fftalgc==0) .and. (fftalga==4)) then
3226 : : !$OMP PARALLEL DO PRIVATE(i3_local,i3_glob)
3227 [ + + ]: 4590 : do idat=1,ndat
3228 [ + + ]: 34811 : do i3=1,n3
3229 [ + - ]: 32516 : if( me_fft == fftn3_distrib(i3) ) then
3230 : 30221 : i3_local = ffti3_local(i3) + nd3proc*(idat-1)
3231 : 30221 : i3_glob = i3+n3*(idat-1)
3232 [ + + ]: 645218 : do i2=1,n2
3233 [ + + ]: 31431629 : do i1=1,n1
3234 : 30786411 : fofr(1,i1,i2,i3_glob)= denpot(i1,i2,i3)*work4(1,i1,i2,i3_local)
3235 : 31401408 : fofr(2,i1,i2,i3_glob)= denpot(i1,i2,i3)*work4(2,i1,i2,i3_local)
3236 : : end do
3237 : : end do
3238 : : end if
3239 : : end do
3240 : : end do
3241 : : end if
3242 [ + + ]: 2489 : if ((fftalgc/=0) .or. (fftalga/=4)) then
3243 : : !$OMP PARALLEL DO PRIVATE(i3_glob)
3244 [ + + ]: 400 : do idat=1,ndat
3245 [ + + ]: 11915 : do i3=1,n3
3246 [ + - ]: 11721 : if( me_fft == fftn3_distrib(i3) ) then
3247 : 11515 : i3_glob = i3+n3*(idat-1)
3248 [ + + ]: 858550 : do i2=1,n2
3249 [ + + ]: 71917915 : do i1=1,n1
3250 : 71059365 : fofr(1,i1,i2,i3_glob)=denpot(i1,i2,i3)*work1(1,i1,i2,i3+n3*(idat-1))
3251 : 71906400 : fofr(2,i1,i2,i3_glob)=denpot(i1,i2,i3)*work1(2,i1,i2,i3+n3*(idat-1))
3252 : : end do
3253 : : end do
3254 : : end if
3255 : : end do
3256 : : end do
3257 : : end if
3258 : :
3259 [ + - ]: 19 : else if (cplex==2) then
3260 [ + + ]: 19 : if ((fftalgc==0) .and. (fftalga==4)) then
3261 : : !$OMP PARALLEL DO PRIVATE(fre,fim,i3_local,i3_glob)
3262 [ + + ]: 10 : do idat=1,ndat
3263 [ + + ]: 510 : do i3=1,n3
3264 [ + - ]: 505 : if( me_fft == fftn3_distrib(i3) ) then
3265 : 500 : i3_local = ffti3_local(i3) + nd3proc*(idat-1)
3266 : 500 : i3_glob = i3+n3*(idat-1)
3267 [ + + ]: 50500 : do i2=1,n2
3268 [ + + ]: 5050500 : do i1=1,n1
3269 : 5000000 : fre=work4(1,i1,i2,i3_local)
3270 : 5000000 : fim=work4(2,i1,i2,i3_local)
3271 : 5000000 : fofr(1,i1,i2,i3_glob)=denpot(2*i1-1,i2,i3)*fre -denpot(2*i1,i2,i3)*fim
3272 : 5050000 : fofr(2,i1,i2,i3_glob)=denpot(2*i1-1,i2,i3)*fim +denpot(2*i1,i2,i3)*fre
3273 : : end do
3274 : : end do
3275 : : end if
3276 : : end do
3277 : : end do
3278 : : end if
3279 : :
3280 [ + + ]: 19 : if ((fftalgc/=0) .or. (fftalga/=4)) then
3281 : : !$OMP PARALLEL DO PRIVATE(fre,fim,i3_glob)
3282 [ + + ]: 40 : do idat=1,ndat
3283 [ + + ]: 2640 : do i3=1,n3
3284 [ + - ]: 2626 : if( me_fft == fftn3_distrib(i3) ) then
3285 : 2600 : i3_glob = i3+n3*(idat-1)
3286 [ + + ]: 262600 : do i2=1,n2
3287 [ + + ]: 26262600 : do i1=1,n1
3288 : 26000000 : fre=work1(1,i1,i2,i3+n3*(idat-1))
3289 : 26000000 : fim=work1(2,i1,i2,i3+n3*(idat-1))
3290 : 26000000 : fofr(1,i1,i2,i3_glob)=denpot(2*i1-1,i2,i3)*fre -denpot(2*i1,i2,i3)*fim
3291 : 26260000 : fofr(2,i1,i2,i3_glob)=denpot(2*i1-1,i2,i3)*fim +denpot(2*i1,i2,i3)*fre
3292 : : end do
3293 : : end do
3294 : : end if
3295 : : end do
3296 : : end do
3297 : : end if
3298 : : end if ! cplex=2
3299 : :
3300 : : end if ! option=2
3301 : :
3302 : : ! The data for option==2 or option==3 is now in fofr.
3303 [ + + ]: 36809 : if (option==2 .or. option==3) then
3304 : :
3305 [ + + ]: 30740 : if (fftalgc==0) then
3306 : : ! Call usual 3DFFT library routines or SG simplest complex-to-complex routine
3307 [ + + ]: 30541 : if (fftalga==FFT_SG2002) then
3308 [ - + ]: 2350 : ABI_FREE(work1)
3309 [ - + + - : 11750 : ABI_MALLOC(work1,(2,n4,n6,n5*ndat))
- + + - -
+ + - + -
+ - - + -
+ ]
3310 : : end if
3311 : :
3312 [ + + + + ]: 30541 : if (option==3 .or. fftalga/=4) then
3313 : 28241 : call ccfft(ngfft,-1,n1,n2,n3,n4,n5,n6,ndat,2,fofr,work1,comm_fft)
3314 : : else
3315 : : ! creation of small arrays
3316 : : ! nd3proc=((n5-1)/nproc_fft) +1
3317 : 2300 : nd3proc=((n6-1)/nproc_fft) +1
3318 : 2300 : nd2proc=((n2-1)/nproc_fft) +1
3319 [ - + + - : 11500 : ABI_MALLOC(work3,(2,n4,n5,nd3proc*ndat))
- + + - -
+ + - + -
+ - - + -
+ - + ]
3320 [ - + + - : 11500 : ABI_MALLOC(work2,(2,n4,n6,nd2proc*ndat))
- + + - -
+ + - + -
+ - - + -
+ - + ]
3321 : :
3322 [ - + ]: 2300 : if (paral_kgb==1) then
3323 : :
3324 [ # # ]: 0 : if (cplex==1) then
3325 [ # # ]: 0 : do idat=1,ndat
3326 [ # # ]: 0 : do i3=1,n3
3327 [ # # ]: 0 : if( me_fft == fftn3_distrib(i3) ) then
3328 : 0 : i3_local = ffti3_local(i3) + nd3proc*(idat-1)
3329 [ # # ]: 0 : do i2=1,n2
3330 [ # # ]: 0 : do i1=1,n1
3331 : 0 : work3(1,i1,i2,i3_local)=denpot(i1,i2,i3)*work4(1,i1,i2,i3_local)
3332 : 0 : work3(2,i1,i2,i3_local)=denpot(i1,i2,i3)*work4(2,i1,i2,i3_local)
3333 : : end do
3334 : : end do
3335 : : end if
3336 : : end do
3337 : : end do
3338 : : else
3339 [ # # ]: 0 : do idat=1,ndat
3340 [ # # ]: 0 : do i3=1,n3
3341 [ # # ]: 0 : if( me_fft == fftn3_distrib(i3) ) then
3342 : 0 : i3_local = ffti3_local(i3) + nd3proc*(idat-1)
3343 [ # # ]: 0 : do i2=1,n2
3344 [ # # ]: 0 : do i1=1,n1
3345 : 0 : fre=work4(1,i1,i2,i3_local)
3346 : 0 : fim=work4(2,i1,i2,i3_local)
3347 : 0 : work3(1,i1,i2,i3_local) = denpot(2*i1-1,i2,i3)*fre-denpot(2*i1,i2,i3)*fim
3348 : 0 : work3(2,i1,i2,i3_local) = denpot(2*i1-1,i2,i3)*fim+denpot(2*i1,i2,i3)*fre
3349 : : end do
3350 : : end do
3351 : : end if
3352 : : end do
3353 : : end do
3354 : : end if
3355 : 0 : option_ccfft=1
3356 : :
3357 : : else
3358 [ + - - + ]: 2300 : if (nproc_fft /=1 .or. ndat /= 1 ) then
3359 [ # # ]: 0 : do idat=1,ndat
3360 [ # # ]: 0 : do i3=1,n3
3361 [ # # ]: 0 : do i2=1,n2
3362 [ # # ]: 0 : do i1=1,n1
3363 : 0 : work3(1,i1,i2,i3+nd3proc*(idat-1))=fofr(1,i1,i2,i3+n3*(idat-1))
3364 : 0 : work3(2,i1,i2,i3+nd3proc*(idat-1))=fofr(2,i1,i2,i3+n3*(idat-1))
3365 : : end do
3366 : : end do
3367 : : end do
3368 : : end do
3369 : 0 : option_ccfft=2
3370 : : end if
3371 : : end if
3372 : :
3373 [ - + ]: 2300 : if (paral_kgb==1) then
3374 : 0 : call ccfft(ngfft,-1,n1,n2,n3,n4,n5,n6,ndat,option_ccfft,work3,work2,comm_fft)
3375 : : else
3376 [ + - - + ]: 2300 : if (nproc_fft /=1 .or. ndat /= 1 ) then
3377 : 0 : call ccfft(ngfft,-1,n1,n2,n3,n4,n5,n6,ndat,option_ccfft,work3,work2,comm_fft)
3378 : : else
3379 : 2300 : call ccfft(ngfft,-1,n1,n2,n3,n4,n5,n6,ndat,option_ccfft,fofr,work1,comm_fft)
3380 : : end if
3381 : : end if
3382 : :
3383 : : ! load of work1
3384 [ - + - - : 2300 : if ((paral_kgb==1) .and. ( istwf_k > 1 )) work1(:,:,:,:)=zero
- - - - -
- - - ]
3385 : :
3386 : : if (paral_kgb==1) then
3387 [ # # ]: 0 : if ( istwf_k > 1 ) then
3388 [ # # ]: 0 : do idat=1,ndat
3389 [ # # ]: 0 : do i2=1,n2
3390 [ # # ]: 0 : if( me_fft == fftn2_distrib(i2) ) then
3391 : 0 : i2_local = ffti2_local(i2) + nd2proc*(idat-1)
3392 [ # # ]: 0 : do i3=1,n3
3393 [ # # ]: 0 : do i1=1,n1
3394 : 0 : work1(1,i1,i3,i2+n5*(idat-1))= work2(1,i1,i3,i2_local)
3395 : 0 : work1(2,i1,i3,i2+n5*(idat-1))= work2(2,i1,i3,i2_local)
3396 : : end do
3397 : : end do
3398 : : end if
3399 : : end do
3400 : : end do
3401 : : end if
3402 : :
3403 : : else
3404 [ + - + - ]: 2300 : if (nproc_fft /=1 .or. ndat /= 1 ) then
3405 [ # # ]: 0 : do idat=1,ndat
3406 [ - - ]: 2300 : do i2=1,n2
3407 [ # # ]: 0 : do i3=1,n3
3408 [ # # ]: 0 : do i1=1,n1
3409 : 0 : work1(1,i1,i3,i2+n5*(idat-1))=work2(1,i1,i3,i2+nd2proc*(idat-1))
3410 : 0 : work1(2,i1,i3,i2+n5*(idat-1))=work2(2,i1,i3,i2+nd2proc*(idat-1))
3411 : : end do
3412 : : end do
3413 : : end do
3414 : : end do
3415 : : end if
3416 : : end if
3417 [ - + ]: 2300 : ABI_FREE(work3)
3418 [ + - - - ]: 2300 : if ((paral_kgb==1) .and. ( istwf_k > 1 )) then
3419 : 0 : call timab(48,1,tsec)
3420 : 0 : call xmpi_sum(work1,comm_fft,ier)
3421 : 0 : call timab(48,2,tsec)
3422 : : end if
3423 : : end if
3424 : :
3425 : : else
3426 : : ! Call SG routine, with zero padding
3427 : 199 : call sg_fftpad(fftcache,mgfft,n1,n2,n3,n4,n5,n6,ndat,gboundout,-1,fofr,work1)
3428 : : end if
3429 : :
3430 : 30740 : xnorm = one/dble(nfftot)
3431 : :
3432 [ + + ]: 30740 : if (fftalga/=4) then
3433 : 28390 : call cg_box2gsph(n1,n2,n3,n4,n5,n6,ndat,npwout,kg_kout,work1,fofgout, rscal=xnorm)
3434 : : else
3435 : : ! if fftalga==4
3436 [ - + - - ]: 2350 : if ((paral_kgb==1) .and. ( istwf_k == 1 )) then
3437 : : !$OMP PARALLEL DO PRIVATE(i1,i2,i3,i2_local)
3438 [ # # ]: 0 : do idat=1,ndat
3439 [ # # ]: 0 : do ig=1,npwout
3440 [ # # ]: 0 : i1=kg_kout(1,ig); if(i1<0)i1=i1+n1 ; i1=i1+1
3441 [ # # ]: 0 : i2=kg_kout(2,ig); if(i2<0)i2=i2+n2 ; i2=i2+1
3442 [ # # ]: 0 : i3=kg_kout(3,ig); if(i3<0)i3=i3+n3 ; i3=i3+1
3443 : 0 : i2_local = ffti2_local(i2) + nd2proc*(idat-1)
3444 : 0 : fofgout(1,ig+npwout*(idat-1))= work2(1,i1,i3,i2_local)*xnorm
3445 : 0 : fofgout(2,ig+npwout*(idat-1))= work2(2,i1,i3,i2_local)*xnorm
3446 : : end do
3447 : : end do
3448 [ # # ]: 0 : ABI_FREE(work2)
3449 : : else
3450 : : !$OMP PARALLEL DO PRIVATE(i1,i2,i3)
3451 [ + + ]: 4700 : do idat=1,ndat
3452 [ + + ]: 2359754 : do ig=1,npwout
3453 [ + + ]: 2355054 : i1=kg_kout(1,ig); if(i1<0)i1=i1+n1; i1=i1+1
3454 [ + + ]: 2355054 : i2=kg_kout(2,ig); if(i2<0)i2=i2+n2; i2=i2+1
3455 [ + + ]: 2355054 : i3=kg_kout(3,ig); if(i3<0)i3=i3+n3; i3=i3+1
3456 : 2355054 : fofgout(1,ig+npwout*(idat-1))=work1(1,i1,i3,i2+n5*(idat-1))*xnorm
3457 : 2357404 : fofgout(2,ig+npwout*(idat-1))=work1(2,i1,i3,i2+n5*(idat-1))*xnorm
3458 : : end do
3459 : : end do
3460 : : end if
3461 : : end if ! fftalga
3462 : : end if ! if option==2 or 3
3463 : :
3464 [ - + ]: 36809 : ABI_SFREE(work1)
3465 : : end if
3466 : :
3467 : : ! Here, call more specialized 3-dimensional fft
3468 : : ! (zero padding as well as maximize cache reuse) based on S Goedecker routines.
3469 : : ! Specially tuned for cache architectures.
3470 [ + + + + ]: 1233492 : if (fftalga==FFT_SG .and. fftalgc==2 .and. option/=3) then
3471 : : call sg_fftrisc(cplex,denpot,fofgin,fofgout,fofr,gboundin,gboundout,&
3472 : 1094142 : istwf_k,kg_kin,kg_kout,mgfft,ndat,ngfft,npwin,npwout,n4,n5,n6,option,weight_r,weight_i)
3473 : : end if
3474 : :
3475 : : ! Here, call new FFT from S Goedecker, also sophisticated specialized 3-dimensional fft
3476 : : ! (zero padding as well as maximize cache reuse)
3477 [ + + ]: 1233492 : if (fftalga==FFT_SG2002 .and. fftalgc/=0) then
3478 : : ! The args are not the same as fourwf, but might be
3479 : : call fourwf_mpi(cplex,denpot,fofgin,fofgout,fofr,gboundin,gboundout,&
3480 : : istwf_k,kg_kin,kg_kout,me_g0,mgfft,ngfft,mpi_enreg%distribfft,n1,n2,n3,npwin,npwout,&
3481 : 102541 : n4,n5,n6,ndat,option,weight_r,weight_i,comm_fft)
3482 : : end if
3483 : :
3484 [ + + + - ]: 1233492 : if (option==0.and.(fftalga==FFT_SG.or.fftalga==FFT_SG2002)) then
3485 : : ! In these cases, add the periodic image of the borders so all fofr components are computed
3486 [ + + ]: 4565884 : do i3=1,n3
3487 [ + + ]: 4281100 : if (n1==n4-1) then
3488 [ + + ]: 9572808 : do i2=1,n2
3489 [ + + ]: 27291264 : fofr(:,n4,i2,i3)=fofr(:,1,i2,i3)
3490 : : end do
3491 : : end if
3492 [ + + ]: 4565884 : if (n2==n5-1) then
3493 [ + + + + ]: 31706344 : fofr(:,:,n5,i3)=fofr(:,:,1,i3)
3494 : : end if
3495 : : end do
3496 : : end if
3497 : :
3498 [ + + ]: 1233492 : ABI_SFREE(work4)
3499 [ - + + + : 62093093 : ABI_SFREE(work2)
+ ]
3500 : : end select
3501 : :
3502 : : ! Accumulate timing
3503 : : 100 continue
3504 : 61592053 : call timab(840+tim_fourwf,2,tsec)
3505 : :
3506 [ - + - + : 123184106 : end subroutine fourwf
- + - + ]
3507 : : !!***
3508 : :
3509 : : !!****f* ABINIT/fourdp
3510 : : !! NAME
3511 : : !! fourdp
3512 : : !!
3513 : : !! FUNCTION
3514 : : !! Conduct Fourier transform of REAL or COMPLEX function f(r)=fofr defined on
3515 : : !! fft grid in real space, to create complex f(G)=fofg defined on full fft grid
3516 : : !! in reciprocal space, in full storage mode, or the reverse operation.
3517 : : !! For the reverse operation, the final data is divided by nfftot.
3518 : : !! REAL case when cplex=1, COMPLEX case when cplex=2
3519 : : !! Usually used for density and potentials.
3520 : : !!
3521 : : !! There are two different possibilities:
3522 : : !! fftalgb=0 means using the complex-to-complex FFT routine, irrespective of the value of cplex
3523 : : !! fftalgb=1 means using a real-to-complex FFT or a complex-to-complex FFT, depending on the value of cplex.
3524 : : !! The only real-to-complex FFT available is from SGoedecker library.
3525 : : !!
3526 : : !! INPUTS
3527 : : !! cplex=1 if fofr is real, 2 if fofr is complex
3528 : : !! isign=sign of Fourier transform exponent: current convention uses
3529 : : !! +1 for transforming from G to r
3530 : : !! -1 for transforming from r to G.
3531 : : !! mpi_enreg=information about MPI parallelization
3532 : : !! nfft=(effective) number of FFT grid points (for this processor)
3533 : : !! ndat=Number of functions to transform
3534 : : !! ngfft(18)=contain all needed information about 3D FFT, see ~abinit/doc/variables/vargs.htm#ngfft
3535 : : !! tim_fourdp=timing code of the calling routine (can be set to 0 if not attributed)
3536 : : !!
3537 : : !! SIDE EFFECTS
3538 : : !! Input/Output
3539 : : !! fofg(2,nfft)=f(G), complex.
3540 : : !! fofr(cplex*nfft)=input function f(r) (real or complex)
3541 : : !!
3542 : : !! SOURCE
3543 : :
3544 : 1412014 : subroutine fourdp(cplex, fofg, fofr, isign, mpi_enreg, nfft, ndat, ngfft, tim_fourdp, gpu_option)
3545 : :
3546 : : !Arguments ------------------------------------
3547 : : !scalars
3548 : : integer,intent(in) :: cplex,isign,nfft,ndat,tim_fourdp
3549 : : integer,intent(in),optional :: gpu_option
3550 : : type(MPI_type),intent(in) :: mpi_enreg
3551 : : !arrays
3552 : : integer,intent(in) :: ngfft(18)
3553 : : real(dp),intent(inout) :: fofg(2,nfft,ndat),fofr(cplex*nfft,ndat)
3554 : :
3555 : : !Local variables-------------------------------
3556 : : !scalars
3557 : : integer :: fftalg,fftalga,fftalgb,fftcache,i1,i2,i3,base,idat
3558 : : integer :: n1,n1half1,n1halfm,n2,n2half1,n3,n4
3559 : : integer :: n4half1,n5,n5half1,n6 !nd2proc,nd3proc,i3_local,i2_local,
3560 : : integer :: comm_fft,nproc_fft,me_fft,gpu_option_
3561 : : real(dp) :: xnorm
3562 : : character(len=500) :: msg
3563 : : !arrays
3564 : 1412014 : integer, contiguous, pointer :: fftn2_distrib(:),ffti2_local(:)
3565 : 1412014 : integer, contiguous, pointer :: fftn3_distrib(:),ffti3_local(:)
3566 : : real(dp) :: tsec(2)
3567 : 1412014 : real(dp),allocatable :: work1(:,:,:,:,:),work2(:,:,:,:,:)
3568 : 1412014 : real(dp),allocatable :: workf(:,:,:,:,:),workr(:,:,:,:,:)
3569 : : ! *************************************************************************
3570 : :
3571 : : !ABI_CHECK(ndat == 1, "ndat != 1 should be tested")
3572 : :
3573 : : ! Keep track of timing
3574 : 1412014 : call timab(1260+tim_fourdp,1,tsec)
3575 : :
3576 [ - + ]: 1412014 : if (fourdp_counter>=0) then
3577 : 0 : fourdp_counter = fourdp_counter + ndat
3578 : : end if
3579 : :
3580 : : ! GPU version of fourdp
3581 : 1412014 : gpu_option_=ABI_GPU_DISABLED
3582 [ + + ]: 1412014 : if (PRESENT(gpu_option)) gpu_option_=gpu_option
3583 : :
3584 : 1412014 : n1=ngfft(1); n2=ngfft(2); n3=ngfft(3)
3585 : 1412014 : n4=ngfft(4); n5=ngfft(5); n6=ngfft(6)
3586 : 1412014 : me_fft=ngfft(11); nproc_fft=ngfft(10)
3587 : 1412014 : comm_fft = mpi_enreg%comm_fft
3588 : : !write(std_out,*)"fourdp, nx,ny,nz,nfft =",n1,n2,n3,nfft
3589 : :
3590 : : ! Run fourdp with OpenMP GPU if requested, on CPU otherwise
3591 [ - + ]: 1412014 : if(gpu_option_==ABI_GPU_OPENMP) then
3592 : 0 : call ompgpu_fourdp(cplex,ngfft,n4,n5,n6,ndat,isign,fofg,fofr)
3593 : 0 : goto 100
3594 : : end if
3595 : :
3596 : 1412014 : fftcache=ngfft(8)
3597 : 1412014 : fftalg =ngfft(7); fftalga =fftalg/100; fftalgb =mod(fftalg,100)/10
3598 : :
3599 : 1412014 : xnorm=one/dble(n1*n2*n3)
3600 : : !write(std_out,*)' fourdp :me_fft',me_fft,'nproc_fft',nproc_fft,'nfft',nfft
3601 : :
3602 [ - + ]: 1412014 : if (fftalgb /= 0 .and. fftalgb /= 1) then
3603 : : write(msg, '(a,i0,5a)' )&
3604 : 0 : 'The input algorithm number fftalg= ',fftalg,' is not allowed.',ch10,&
3605 : 0 : 'The second digit (fftalg(B)) must be 0 or 1.',ch10,&
3606 : 0 : 'Action: change fftalg in your input file.'
3607 : 0 : ABI_BUG(msg)
3608 : : end if
3609 : :
3610 [ + + + + : 1412014 : if (fftalgb == 1 .and. ALL(fftalga /= [1,3,4,5])) then
- + ]
3611 : : write(msg,'(a,i0,5a)')&
3612 : 0 : 'The input algorithm number fftalg= ',fftalg,' is not allowed.',ch10,&
3613 : 0 : 'When fftalg(B) is 1, the allowed values for fftalg(A) are 1 and 4.',ch10,&
3614 : 0 : 'Action: change fftalg in your input file.'
3615 : 0 : ABI_BUG(msg)
3616 : : end if
3617 : :
3618 [ + - + - : 1412014 : if (n4<n1.or.n5<n2.or.n6<n3) then
- + ]
3619 : 0 : write(msg,'(a,3(i0,1x),a,3(i0,1x))')' Each of n4,n5,n6=',n4,n5,n6,'must be >= n1, n2, n3 =',n1,n2,n3
3620 : 0 : ABI_BUG(msg)
3621 : : end if
3622 : :
3623 : : ! Get the distrib associated with this fft_grid => for i2 and i3 planes
3624 : 1412014 : call ptabs_fourdp(mpi_enreg,n2,n3,fftn2_distrib,ffti2_local,fftn3_distrib,ffti3_local)
3625 : :
3626 : : ! Branch immediately depending on nproc_fft
3627 [ + + ]: 1412014 : if (nproc_fft > 1) then
3628 : 29328 : call fourdp_mpi(cplex,nfft,ngfft,ndat,isign,fftn2_distrib,ffti2_local,fftn3_distrib,ffti3_local,fofg,fofr,comm_fft)
3629 : 29328 : goto 100
3630 : : end if
3631 : :
3632 [ - + ]: 1382686 : if (fftalga == FFT_FFTW3) then
3633 : : ! Call sequential or MPI FFTW3 version.
3634 [ # # ]: 0 : if (nproc_fft == 1) then
3635 : : !call wrtout(std_out,"FFTW3 SEQFOURDP")
3636 : 0 : call fftw3_seqfourdp(cplex,n1,n2,n3,n1,n2,n3,ndat,isign,fofg,fofr)
3637 : : else
3638 : : !call wrtout(std_out,"FFTW3 MPIFOURDP")
3639 : : call fftw3_mpifourdp(cplex,nfft,ngfft,ndat,isign,&
3640 : 0 : fftn2_distrib,ffti2_local,fftn3_distrib,ffti3_local,fofg,fofr,comm_fft)
3641 : : end if
3642 : : ! Accumulate timing and return
3643 : 0 : call timab(1260+tim_fourdp,2,tsec); return
3644 : : end if
3645 : :
3646 [ + + ]: 1382686 : if (fftalga == FFT_DFTI) then
3647 : : ! Call sequential or MPI MKL.
3648 [ + - ]: 1263237 : if (nproc_fft == 1) then
3649 : 1263237 : call dfti_seqfourdp(cplex,n1,n2,n3,n1,n2,n3,ndat,isign,fofg,fofr)
3650 : : else
3651 : 0 : ABI_ERROR("MPI fourdp with MKL cluster DFT not implemented")
3652 : : end if
3653 : : ! Accumulate timing and return
3654 : 1263237 : call timab(1260+tim_fourdp,2,tsec); return
3655 : : end if
3656 : :
3657 : : ! Here, deal with the new SG FFT, complex-to-complex case
3658 [ + + + + : 119449 : if (fftalga==FFT_SG2002 .and. (fftalgb==0 .or. cplex==2)) then
+ + ]
3659 : 108084 : call sg2002_mpifourdp(cplex,nfft,ngfft,ndat,isign,fftn2_distrib,ffti2_local,fftn3_distrib,ffti3_local,fofg,fofr,comm_fft)
3660 : : !call sg2002_seqfourdp(cplex,nfft,ngfft,ndat,isign,fftn2_fofg,fofr)
3661 : : end if
3662 : :
3663 : : ! Here, deal with the new SG FFT, with real-to-complex
3664 [ + + + + ]: 119449 : if (fftalga==FFT_SG2002 .and. fftalgb==1 .and. cplex==1) then
3665 [ - + ]: 172 : ABI_CHECK(nproc_fft == 1,"fftalg 41x does not support nproc_fft > 1")
3666 [ - + ]: 172 : ABI_CHECK(ndat == 1, "ndat must be 1")
3667 : :
3668 : 172 : n1half1=n1/2+1; n1halfm=(n1+1)/2
3669 : 172 : n2half1=n2/2+1
3670 : : ! n4half1 or n5half1 are the odd integers >= n1half1 or n2half1
3671 : 172 : n4half1=(n1half1/2)*2+1
3672 : 172 : n5half1=(n2half1/2)*2+1
3673 [ - + + - : 1032 : ABI_MALLOC(workr, (2,n4half1,n5,n6,ndat))
- + + - -
+ + - - +
+ - + - +
- - + -
+ ]
3674 [ - + + - : 1032 : ABI_MALLOC(workf, (2,n4,n6,n5half1,ndat))
- + + - -
+ + - - +
+ - + - +
- - + -
+ ]
3675 : :
3676 [ + + ]: 172 : if (isign==1) then
3677 [ + + ]: 184 : do idat=1,ndat
3678 [ + + ]: 3136 : do i3=1,n3
3679 [ + + ]: 77006 : do i2=1,n2half1
3680 : 73962 : base=n1*(i2-1+n2*(i3-1))
3681 [ + + ]: 4418190 : do i1=1,n1
3682 : 4341276 : workf(1,i1,i3,i2,idat) = fofg(1,i1+base,idat)
3683 : 4415238 : workf(2,i1,i3,i2,idat) = fofg(2,i1+base,idat)
3684 : : end do
3685 : : end do
3686 : : end do
3687 : : end do
3688 : :
3689 : : !nd2proc=((n2-1)/nproc_fft) +1
3690 : : !nd3proc=((n6-1)/nproc_fft) +1
3691 : :
3692 : : ! change the call? n5half1 et n6 ?
3693 : 92 : call sg2002_back(cplex,ndat,n1,n2,n3,n4,n5,n6,n4half1,n5half1,n6,2,workf,workr,comm_fft)
3694 : :
3695 [ + + ]: 184 : do idat=1,ndat
3696 [ + + ]: 3136 : do i3=1,n3
3697 [ + + ]: 145064 : do i2=1,n2
3698 : 142020 : base=n1*(i2-1+n2*(i3-1))
3699 [ + + ]: 4347864 : do i1=1,n1half1-1
3700 : : ! copy data
3701 : 4205844 : fofr(2*i1-1+base, idat) = workr(1,i1,i2,i3,idat)
3702 : 4347864 : fofr(2*i1 +base, idat) = workr(2,i1,i2,i3,idat)
3703 : : end do
3704 : : ! If n1 odd, must add last data
3705 [ - + ]: 144972 : if((2*n1half1-2)/=n1)then
3706 : 0 : fofr(n1+base, idat) = workr(1,n1half1,i2,i3,idat)
3707 : : end if
3708 : : end do
3709 : : end do
3710 : : end do
3711 : :
3712 [ + - ]: 80 : else if (isign==-1) then
3713 [ + + ]: 160 : do idat=1,ndat
3714 [ + + ]: 2770 : do i3=1,n3
3715 [ + + ]: 131318 : do i2=1,n2
3716 : 128628 : base=n1*(i2-1+n2*(i3-1))
3717 [ + + ]: 4027320 : do i1=1,n1half1-1
3718 : 3898692 : workr(1,i1,i2,i3,idat)=fofr(2*i1-1+base,idat)
3719 : 4027320 : workr(2,i1,i2,i3,idat)=fofr(2*i1 +base,idat)
3720 : : end do
3721 : : ! If n1 odd, must add last data
3722 [ - + ]: 131238 : if((2*n1half1-2)/=n1)then
3723 : 0 : workr(1,n1half1,i2,i3,idat)=fofr(n1+base,idat)
3724 : 0 : workr(2,n1half1,i2,i3,idat)=zero
3725 : : end if
3726 : : end do
3727 : : end do
3728 : : end do
3729 : :
3730 : 80 : call sg2002_forw(cplex,ndat,n1,n2,n3,n4,n5,n6,n4half1,n5half1,n6,2,workr,workf,comm_fft)
3731 : :
3732 : : ! Transfer fft output to the original fft box
3733 [ + + ]: 160 : do idat=1,ndat
3734 [ + + ]: 2770 : do i3=1,n3
3735 : :
3736 [ + + ]: 69534 : do i2=1,n2half1
3737 : 66924 : base=n1*(i2-1+n2*(i3-1))
3738 [ + + ]: 4091022 : do i1=1,n1
3739 : 4021488 : fofg(1,i1+base,idat) = workf(1,i1,i3,i2,idat)*xnorm
3740 : 4088412 : fofg(2,i1+base,idat) = workf(2,i1,i3,i2,idat)*xnorm
3741 : : end do
3742 : : end do
3743 : :
3744 : : ! Complete missing values with complex conjugate
3745 : : ! Inverse of ix is located at nx+2-ix , except for ix=1, for which it is 1.
3746 [ + - ]: 2690 : if(n2half1>2)then
3747 [ + + ]: 64314 : do i2=2,n2+1-n2half1
3748 : 61704 : base=n1*((n2+2-i2)-1)
3749 [ + + ]: 61704 : if(i3/=1)base=base+n1*n2*((n3+2-i3)-1)
3750 : 61704 : fofg(1,1+base,idat)= workf(1,1,i3,i2,idat)*xnorm
3751 : 61704 : fofg(2,1+base,idat)=-workf(2,1,i3,i2,idat)*xnorm
3752 [ + + ]: 3778506 : do i1=2,n1
3753 : 3714192 : fofg(1,n1+2-i1+base,idat)= workf(1,i1,i3,i2,idat)*xnorm
3754 : 3775896 : fofg(2,n1+2-i1+base,idat)=-workf(2,i1,i3,i2,idat)*xnorm
3755 : : end do
3756 : : end do
3757 : : end if
3758 : :
3759 : : end do
3760 : : end do
3761 : :
3762 : : end if ! isign
3763 [ - + ]: 172 : ABI_FREE(workr)
3764 [ - + ]: 172 : ABI_FREE(workf)
3765 : : end if
3766 : :
3767 : : ! Here, one calls the complex-to-complex FFT subroutine
3768 [ + + + + : 119449 : if( (fftalgb==0 .or. cplex==2) .and. fftalga/=4 )then
+ + ]
3769 : : !ABI_CHECK(ndat == 1, "ndat must be 1")
3770 : :
3771 [ - + + - : 21006 : ABI_MALLOC(work1, (2,n4,n5,n6,ndat))
- + + - -
+ + - - +
+ - + - +
- - + -
+ ]
3772 [ - + + - : 17505 : ABI_MALLOC(work2, (2,n4,n5,n6,ndat))
- + + - -
+ + - - +
+ - - + -
+ ]
3773 : :
3774 [ + + ]: 3501 : if (isign==1) then
3775 : :
3776 : : ! Transfer fofg to the expanded fft box
3777 : : !$OMP PARALLEL DO COLLAPSE(2) PRIVATE(base)
3778 [ + + ]: 3678 : do idat=1,ndat
3779 [ + + ]: 57028 : do i3=1,n3
3780 [ + + ]: 1794587 : do i2=1,n2
3781 : 1739398 : base=n1*(i2-1+n2*(i3-1))
3782 [ + + ]: 76940925 : do i1=1,n1
3783 : 75148177 : work1(1,i1,i2,i3,idat) = fofg(1,i1+base,idat)
3784 : 76887575 : work1(2,i1,i2,i3,idat) = fofg(2,i1+base,idat)
3785 : : end do
3786 : : end do
3787 : : end do
3788 : : end do
3789 : :
3790 : : ! Call Goedecker C2C FFT
3791 : : !call sg_fft_cc(fftcache,n1,n2,n3,n4,n5,n6,ndat,isign,work1,work2)
3792 : 1839 : call ccfft(ngfft,isign,n1,n2,n3,n4,n5,n6,ndat,2,work1,work2,comm_fft)
3793 : :
3794 : : ! Take data from expanded box and put it in the original box.
3795 [ + + ]: 1839 : if (cplex==1) then
3796 : : ! REAL case
3797 : : !$OMP PARALLEL DO COLLAPSE(2) PRIVATE(base)
3798 [ + + ]: 1482 : do idat=1,ndat
3799 [ + + ]: 29944 : do i3=1,n3
3800 [ + + ]: 1143749 : do i2=1,n2
3801 : 1114546 : base=n1*(i2-1+n2*(i3-1))
3802 [ + + ]: 56426637 : do i1=1,n1
3803 : 56398175 : fofr(i1+base,idat) = work2(1,i1,i2,i3,idat)
3804 : : end do
3805 : : end do
3806 : : end do
3807 : : end do
3808 : :
3809 : : else
3810 : : ! COMPLEX case
3811 : : !$OMP PARALLEL DO COLLAPSE(2) PRIVATE(base)
3812 [ + + ]: 2196 : do idat=1,ndat
3813 [ + + ]: 27084 : do i3=1,n3
3814 [ + + ]: 650838 : do i2=1,n2
3815 : 624852 : base=2*n1*(i2-1+n2*(i3-1))
3816 [ + + ]: 20514288 : do i1=1,n1
3817 : 19864548 : fofr(2*i1-1+base, idat) = work2(1,i1,i2,i3,idat)
3818 : 20489400 : fofr(2*i1 +base, idat) = work2(2,i1,i2,i3,idat)
3819 : : end do
3820 : : end do
3821 : : end do
3822 : : end do
3823 : : end if
3824 : :
3825 [ + - ]: 1662 : else if (isign==-1) then
3826 : :
3827 : : ! Insert fofr into the augmented fft box
3828 [ + + ]: 1662 : if (cplex==1) then
3829 : : ! REAL case copy data
3830 : : !$OMP PARALLEL DO COLLAPSE(2) PRIVATE(base)
3831 [ + + ]: 1516 : do idat=1,ndat
3832 [ + + ]: 30771 : do i3=1,n3
3833 [ + + ]: 1151272 : do i2=1,n2
3834 : 1121259 : base=n1*(i2-1+n2*(i3-1))
3835 [ + + ]: 56475286 : do i1=1,n1
3836 : 55324772 : work1(1,i1,i2,i3,idat) = fofr(i1+base,idat)
3837 : 56446031 : work1(2,i1,i2,i3,idat) = zero
3838 : : end do
3839 : : end do
3840 : : end do
3841 : : end do
3842 : : else
3843 : : ! COMPLEX case copy data
3844 : : !$OMP PARALLEL DO COLLAPSE(2) PRIVATE(base)
3845 [ + + ]: 1808 : do idat=1,ndat
3846 [ + + ]: 21806 : do i3=1,n3
3847 [ + + ]: 524884 : do i2=1,n2
3848 : 503982 : base=2*n1*(i2-1+n2*(i3-1))
3849 [ + + ]: 17434998 : do i1=1,n1
3850 : 16911018 : work1(1,i1,i2,i3, idat) = fofr(2*i1-1+base, idat)
3851 : 17415000 : work1(2,i1,i2,i3, idat) = fofr(2*i1 +base, idat)
3852 : : end do
3853 : : end do
3854 : : end do
3855 : : end do
3856 : : end if ! cplex
3857 : :
3858 : : ! Call Stefan Goedecker C2C FFT
3859 : : !call sg_fft_cc(fftcache,n1,n2,n3,n4,n5,n6,ndat,isign,work1,work2)
3860 : 1662 : call ccfft(ngfft,isign,n1,n2,n3,n4,n5,n6,ndat,2,work1,work2,comm_fft)
3861 : :
3862 : : ! Transfer fft output to the original fft box
3863 : : !$OMP PARALLEL DO COLLAPSE(2) PRIVATE(base)
3864 [ + + ]: 3324 : do idat=1,ndat
3865 [ + + ]: 52577 : do i3=1,n3
3866 [ + + ]: 1676156 : do i2=1,n2
3867 : 1625241 : base=n1*(i2-1+n2*(i3-1))
3868 [ + + ]: 73910284 : do i1=1,n1
3869 : 72235790 : fofg(1,i1+base,idat) = work2(1,i1,i2,i3,idat)*xnorm
3870 : 73861031 : fofg(2,i1+base,idat) = work2(2,i1,i2,i3,idat)*xnorm
3871 : : end do
3872 : : end do
3873 : : end do
3874 : : end do
3875 : :
3876 : : end if ! isign
3877 : :
3878 [ - + ]: 3501 : ABI_FREE(work1)
3879 [ - + ]: 3501 : ABI_FREE(work2)
3880 : : end if ! End simple algorithm
3881 : :
3882 : : ! Here sophisticated algorithm based on S. Goedecker routines, only for the REAL case.
3883 : : ! Take advantage of the fact that fofr is real, and that fofg has corresponding symmetry properties.
3884 [ + + + + : 119449 : if( (fftalgb==1 .and. cplex==1) .and. fftalga/=4 )then
+ + ]
3885 [ - + ]: 7692 : ABI_CHECK(nproc_fft == 1,"nproc > 1 not supported")
3886 [ + + ]: 15384 : do idat=1,ndat
3887 : 15384 : call sg_fft_rc(cplex,fofg(1,1,idat),fofr(1,idat),isign,nfft,ngfft)
3888 : : end do
3889 : : end if
3890 : :
3891 : 148777 : 100 call timab(1260+tim_fourdp,2,tsec)
3892 : :
3893 : 1412014 : end subroutine fourdp
3894 : : !!***
3895 : :
3896 : : !!****f* ABINIT/ccfft
3897 : : !! NAME
3898 : : !! ccfft
3899 : : !!
3900 : : !! FUNCTION
3901 : : !! Carry out complex-to-complex Fourier transforms between real
3902 : : !! and reciprocal (G) space. Library of such routines.
3903 : : !! Include machine-dependent F90 routines used with fftalg=200.
3904 : : !!
3905 : : !! INPUTS
3906 : : !! fftalga=govern the choice of the fft routine to be used
3907 : : !! if 1: SGoedecker routine
3908 : : !! if 2: Machine dependent routine, depending on the precompilation options
3909 : : !! if 3: FFTW library routine
3910 : : !! if 4: new SGoedecker routine, version 2002
3911 : : !! Warning : the second and third dimensions of the Fourier space
3912 : : !! array are switched, compared to the usual case
3913 : : !! fftcache=size of the cache (kB)
3914 : : !! isign= Integer specifying which sign to be used for the transformation.
3915 : : !! must be either +1 or -1.
3916 : : !! ngfft(18)=contain all needed information about 3D FFT, see ~abinit/doc/variables/vargs.htm#ngfft
3917 : : !! n1,n2,n3=Actual integer dimensions (see ngfft) for the 3D sequence.
3918 : : !! Physical dimension of the transform.
3919 : : !! n4,n5,n6=Leading dimensions. Generally, n6 is not different to n3.
3920 : : !! ndat=number of FFT to do in //
3921 : : !! option= 1 if call from fourwf, 2 if call from other routine
3922 : : !! work1(2,n4*n5*n6)=Array to be transformed.
3923 : : !!
3924 : : !! OUTPUT
3925 : : !! inplace = 0 if result is in work2 ; =1 if result is in work1 (machine dependent)
3926 : : !! normalized=0 if the backward (isign=-1) FFT is not normalized, so has to be normalized outside of ccfft
3927 : : !! =1 otherwise
3928 : : !! work2(2,n4*n5*n6)=transformed array in case inplace=0.
3929 : : !!
3930 : : !! SIDE EFFECTS
3931 : : !! work1(2,n4*n5*n6)=at input, array to be transformed
3932 : : !! at output, transformed array (in case inplace=1)
3933 : : !!
3934 : : !! NOTES
3935 : : !! precompilation definitions :
3936 : : !! -D(machine_list) : (case fftalga=200)
3937 : : !! choice of machine-dependent FFT library, if permitted
3938 : : !! -DHAVE_FFT_FFTW2 : (case fftalga=300) activate the FFTW lib
3939 : : !! -Dnolib : (case fftalga=200) call SGoedecker routine,
3940 : : !! instead of machine-dependent one
3941 : : !!
3942 : : !! More about fftalga=200
3943 : : !! Library routines for the following platforms have been implemented :
3944 : : !! Compaq/DEC
3945 : : !! HP (in place FFT)
3946 : : !! SGI (in place FFT)
3947 : : !! NEC (in place FFT)
3948 : : !! For all the other platforms, or if the CPP directive nolib is
3949 : : !! activated, one uses the fft routine from S. Goedecker.
3950 : : !!
3951 : : !! SOURCE
3952 : :
3953 : 42304 : subroutine ccfft(ngfft,isign,n1,n2,n3,n4,n5,n6,ndat,option,work1,work2,comm_fft)
3954 : :
3955 : : !Arguments ------------------------------------
3956 : : !scalars
3957 : : integer,intent(in) :: isign,n1,n2,n3,n4,n5,n6,ndat,option,comm_fft
3958 : : !arrays
3959 : : integer,intent(in) :: ngfft(18)
3960 : : real(dp),intent(inout) :: work1(2,n4*n5*n6*ndat)
3961 : : real(dp),intent(inout) :: work2(2,n4*n5*n6*ndat)
3962 : :
3963 : : !Local variables ------------------------------
3964 : : !scalars
3965 : : integer,parameter :: cplex2=2
3966 : : integer :: fftalg,fftalga,fftalgb,fftalgc,fftcache
3967 : : integer :: nd2proc,nd3proc,nproc_fft
3968 : : character(len=500) :: msg
3969 : : !*************************************************************************
3970 : :
3971 : 42304 : nproc_fft=ngfft(10)
3972 : 42304 : fftcache=ngfft(8); fftalg =ngfft(7); fftalga =fftalg/100; fftalgb=mod(fftalg,100)/10; fftalgc=mod(fftalg,10)
3973 : :
3974 [ - + ]: 42304 : if(fftalga==2)then
3975 : 0 : ABI_ERROR("Machine dependent FFTs are not supported anymore")
3976 : :
3977 [ - + ]: 42304 : else if(fftalga==3)then
3978 : 0 : ABI_ERROR("Old interface with FFTW2 is not supported anymore")
3979 : :
3980 [ - + ]: 42304 : else if(fftalga<1 .or. fftalga>4)then
3981 : : write(msg, '(a,a,a,i5,a,a)' )&
3982 : 0 : 'The allowed values of fftalg(A) are 1, 2, 3, and 4 .',ch10,&
3983 : 0 : 'The actual value of fftalg(A) is',fftalga,ch10,&
3984 : 0 : 'Action: check the value of fftalg in your input file.'
3985 : 0 : ABI_ERROR(msg)
3986 : : end if
3987 : :
3988 : : ! This routine will be removed ASAP.
3989 : : ! Do not add new FFT libraries without previous discussion with Matteo Giantomassi
3990 : : ! inplace==1 or normalize==2 are not supported anymore in the caller (fourwf, fourdp)
3991 : : !inplace=0; normalized=0
3992 : :
3993 [ + + ]: 42304 : if (fftalga/=4) then
3994 : : ! Call Stefan Goedecker FFT
3995 : 37283 : call sg_fft_cc(fftcache,n1,n2,n3,n4,n5,n6,ndat,isign,work1,work2)
3996 : :
3997 : : else if (fftalga==4) then
3998 : : ! Call new version of Stefan Goedecker FFT
3999 : 5021 : nd2proc=((n2-1)/nproc_fft) +1
4000 : 5021 : nd3proc=((n6-1)/nproc_fft) +1
4001 : :
4002 [ + + ]: 5021 : if (isign==1) then
4003 : : ! Fourier to real space (backward)
4004 : 2671 : call sg2002_back(cplex2,ndat,n1,n2,n3,n4,n5,n6,n4,nd2proc,nd3proc,option,work1,work2,comm_fft)
4005 : : else
4006 : : ! isign=-1, real space to Fourier (forward)
4007 : 2350 : call sg2002_forw(cplex2,ndat,n1,n2,n3,n4,n5,n6,n4,nd2proc,nd3proc,option,work1,work2,comm_fft)
4008 : : end if
4009 : : end if
4010 : :
4011 : 42304 : end subroutine ccfft
4012 : : !!***
4013 : :
4014 : : !----------------------------------------------------------------------
4015 : :
4016 : : !!****f* m_fft/fourdp_mpi
4017 : : !! NAME
4018 : : !! fourdp_mpi
4019 : : !!
4020 : : !! FUNCTION
4021 : : !! Conduct Fourier transform of REAL or COMPLEX function f(r)=fofr defined on
4022 : : !! fft grid in real space, to create complex f(G)=fofg defined on full fft grid
4023 : : !! in reciprocal space, in full storage mode, or the reverse operation.
4024 : : !! For the reverse operation, the final data is divided by nfftot.
4025 : : !! REAL case when cplex=1, COMPLEX case when cplex=2
4026 : : !! Usually used for density and potentials.
4027 : : !!
4028 : : !! INPUTS
4029 : : !! cplex=1 if fofr is real, 2 if fofr is complex
4030 : : !! nfft=(effective) number of FFT grid points (for this processor)
4031 : : !! ngfft(18)=contain all needed information about 3D FFT, see ~abinit/doc/variables/vargs.htm#ngfft
4032 : : !! ndat=Number of FFT transforms
4033 : : !! isign=sign of Fourier transform exponent: current convention uses
4034 : : !! +1 for transforming from G to r
4035 : : !! -1 for transforming from r to G.
4036 : : !! fftn2_distrib(2),ffti2_local(2)
4037 : : !! fftn3_distrib(3),ffti3_local(3)
4038 : : !! comm_fft=MPI communicator
4039 : : !!
4040 : : !! SIDE EFFECTS
4041 : : !! Input/Output
4042 : : !! fofg(2,nfft)=f(G), complex.
4043 : : !! fofr(cplex*nfft)=input function f(r) (real or complex)
4044 : : !!
4045 : : !! TODO
4046 : : !! Write simplified API for sequential version.
4047 : : !!
4048 : : !! SOURCE
4049 : :
4050 : 29328 : subroutine fourdp_mpi(cplex,nfft,ngfft,ndat,isign,&
4051 : 29328 : fftn2_distrib,ffti2_local,fftn3_distrib,ffti3_local,fofg,fofr,comm_fft)
4052 : :
4053 : : !Arguments ------------------------------------
4054 : : !scalars
4055 : : integer,intent(in) :: cplex,isign,nfft,ndat,comm_fft
4056 : : !arrays
4057 : : integer,intent(in) :: ngfft(18)
4058 : : integer,intent(in) :: fftn2_distrib(ngfft(2)),ffti2_local(ngfft(2))
4059 : : integer,intent(in) :: fftn3_distrib(ngfft(3)),ffti3_local(ngfft(3))
4060 : : real(dp),intent(inout) :: fofg(2,nfft*ndat),fofr(cplex*nfft*ndat)
4061 : :
4062 : : !Local variables-------------------------------
4063 : : !scalars
4064 : : integer :: fftalg,fftalga,fftalgc
4065 : : character(len=500) :: msg
4066 : : ! *************************************************************************
4067 : :
4068 : 29328 : fftalg=ngfft(7); fftalga=fftalg/100 ; fftalgc=mod(fftalg,10)
4069 : :
4070 : 29328 : select case (fftalga)
4071 : : case (FFT_SG2002)
4072 : : call sg2002_mpifourdp(cplex,nfft,ngfft,ndat,isign,&
4073 : 29328 : fftn2_distrib,ffti2_local,fftn3_distrib,ffti3_local,fofg,fofr,comm_fft)
4074 : :
4075 : : case (FFT_FFTW3)
4076 : : call fftw3_mpifourdp(cplex,nfft,ngfft,ndat,isign,&
4077 : 0 : fftn2_distrib,ffti2_local,fftn3_distrib,ffti3_local,fofg,fofr,comm_fft)
4078 : :
4079 : : ! TODO
4080 : : !case (FFT_DFTI)
4081 : : ! call dfti_mpifourdp(cplex,nfft,ngfft,ndat,isign,&
4082 : : !& fftn2_distrib,ffti2_local,fftn3_distrib,ffti3_local,fofg,fofr,comm_fft)
4083 : :
4084 : : case default
4085 : 0 : write(msg,"(a,i0)")"Wrong fftalg: ",fftalg
4086 [ + - - ]: 29328 : ABI_BUG(msg)
4087 : : end select
4088 : :
4089 : 29328 : end subroutine fourdp_mpi
4090 : : !!***
4091 : :
4092 : : !----------------------------------------------------------------------
4093 : :
4094 : : !!****f* m_fft/fourwf_mpi
4095 : : !!
4096 : : !! NAME
4097 : : !! fourwf_mpi
4098 : : !!
4099 : : !! FUNCTION
4100 : : !! Carry out composite Fourier transforms between real and reciprocal (G) space.
4101 : : !! Wavefunctions, contained in a sphere in reciprocal space,
4102 : : !! can be FFT to real space. They can also be FFT from real space
4103 : : !! to a sphere. Also, the density maybe accumulated, and a local
4104 : : !! potential can be applied.
4105 : : !!
4106 : : !! The different options are :
4107 : : !! - reciprocal to real space and output the result (option=0),
4108 : : !! - reciprocal to real space and accumulate the density (option=1)
4109 : : !! - reciprocal to real space, apply the local potential to the wavefunction
4110 : : !! in real space and produce the result in reciprocal space (option=2)
4111 : : !! - real space to reciprocal space (option=3).
4112 : : !!
4113 : : !! Schedule of operations
4114 : : !!(read first the description of the fftalg input variable in abinit_help)
4115 : : !! - fftalgc=1 : use separate forward and backward transforms
4116 : : !! (7/12 savings in execution time);
4117 : : !! - fftalgc=2 : in case of option=1 and option=2, use routines for composite operation
4118 : : !! even faster than 1x1
4119 : : !!
4120 : : !! Also for better speed, it uses no F90 construct, except the allocate command and for zeroing arrays.
4121 : : !!
4122 : : !! INPUTS
4123 : : !! cplex= if 1 , denpot is real, if 2 , denpot is complex
4124 : : !! (cplex=2 only allowed for option=2, and istwf_k=1)
4125 : : !! not relevant if option=0 or option=3, so cplex=0 can be used to minimize memory
4126 : : !! fftalgc=1 or 2 => simple or composite FFT applications
4127 : : !! fofgin(2,npwin)=holds input wavefunction in G vector basis sphere.
4128 : : !! (intent(in) but the routine sphere can modify it for another iflag)
4129 : : !! gboundin(2*mgfft+8,2)=sphere boundary info for reciprocal to real space
4130 : : !! gboundout(2*mgfft+8,2)=sphere boundary info for real to reciprocal space
4131 : : !! istwf_k=option parameter that describes the storage of wfs
4132 : : !! kg_kin(3,npwin)=reduced planewave coordinates, input
4133 : : !! kg_kout(3,npwout)=reduced planewave coordinates, output
4134 : : !! me_g0=1 if this MPI node treats the Gamma, 0 otherwise
4135 : : !! mgfft=maximum size of 1D FFTs
4136 : : !! ngfft(18)=contain all needed information about 3D FFT, see ~abinit/doc/variables/vargs.htm#ngfft
4137 : : !! distribfft<distribfft_type>=Tables needed for the FFT parallelism
4138 : : !! n1,n2,n3=1D FFT sizes
4139 : : !! npwin=number of elements in fofgin array (for option 0, 1 and 2)
4140 : : !! npwout=number of elements in fofgout array (for option 2 and 3)
4141 : : !! n4,n5,n6=dimensions of fofr.
4142 : : !! ndat=Number of FFTs
4143 : : !! option= if 0: do direct FFT
4144 : : !! if 1: do direct FFT, then sum the density
4145 : : !! if 2: do direct FFT, multiply by the potential, then do reverse FFT
4146 : : !! if 3: do reverse FFT only
4147 : : !! weight_r=weight to be used for the accumulation of the density in real space
4148 : : !! (needed only when option=1)
4149 : : !! weight_i=weight to be used for the accumulation of the density in real space
4150 : : !! (needed only when option=1)
4151 : : !! comm_fft=MPI communicator.
4152 : : !! [cplexwf]= 1 c2r or r2c can be used. Default: 2 i.e. use complex-to-complex FFTs.
4153 : : !!
4154 : : !! OUTPUT
4155 : : !! (see side effects)
4156 : : !!
4157 : : !! SIDE EFFECTS
4158 : : !! Input/Output
4159 : : !! for option==0, fofgin(2,npwin)=holds input wavefunction in G sphere;
4160 : : !! fofr(2,n4,n5,n6) contains the output Fourier Transform of fofgin;
4161 : : !! no use of denpot, fofgout and npwout.
4162 : : !! for option==1, fofgin(2,npwin)=holds input wavefunction in G sphere;
4163 : : !! denpot(cplex*n4,n5,n6) contains the input density at input,
4164 : : !! and the updated density at output (accumulated);
4165 : : !! no use of fofgout and npwout.
4166 : : !! for option==2, fofgin(2,npwin)=holds input wavefunction in G sphere;
4167 : : !! denpot(cplex*n4,n5,n6) contains the input local potential;
4168 : : !! fofgout(2,npwout) contains the output function;
4169 : : !! for option==3, fofr(2,n4,n5,n6) contains the input real space wavefunction;
4170 : : !! fofgout(2,npwout) contains its output Fourier transform;
4171 : : !! no use of fofgin and npwin.
4172 : : !!
4173 : : !! SOURCE
4174 : :
4175 : 802023 : subroutine fourwf_mpi(cplex,denpot,fofgin,fofgout,fofr,&
4176 : 802023 : & gboundin,gboundout,istwf_k,kg_kin,kg_kout,me_g0,mgfft,ngfft,distribfft,n1,n2,n3,&
4177 : : & npwin,npwout,n4,n5,n6,ndat,option,weight_r,weight_i,comm_fft,cplexwf)
4178 : :
4179 : :
4180 : : !Arguments ------------------------------------
4181 : : !scalars
4182 : : integer,intent(in) :: cplex,istwf_k,mgfft,n1,n2,n3,n4,n5,n6,npwin,ndat
4183 : : integer,intent(in) :: npwout,option,comm_fft,me_g0
4184 : : integer,intent(in),optional :: cplexwf
4185 : : real(dp),intent(in) :: weight_r,weight_i
4186 : : type(distribfft_type),intent(in) :: distribfft
4187 : : !arrays
4188 : : integer,intent(in) :: gboundin(2*mgfft+8,2),gboundout(2*mgfft+8,2),ngfft(18)
4189 : : integer,intent(in) :: kg_kin(3,npwin),kg_kout(3,npwout)
4190 : : real(dp),intent(inout) :: denpot(cplex*n4,n5,n6),fofgin(2,npwin*ndat)
4191 : : real(dp),intent(inout) :: fofr(2,n4,n5,n6*ndat)
4192 : : real(dp),intent(out) :: fofgout(2,npwout*ndat)
4193 : :
4194 : : !Local variables-------------------------------
4195 : : !scalars
4196 : : integer :: fftalg,fftalga,fftalgc,idat
4197 : : integer :: cplexwf_,i1,i2,i3,iflag,ig,igdat,me_fft,m1i,m1o,m2i,m2o,m3i
4198 : : integer :: m3o,max1i,max1o,max2i,max2i_plus,max2o,max2o_plus
4199 : : integer :: max3i,max3o,md1,md1i,md1o,md2,md2i,md2o,md2proc
4200 : : integer :: md3,md3i,md3o,min1i,min1o,min2i,min2i_moins,min2o,min2o_moins,min3i,min3o
4201 : : integer :: nd3proc,nproc_fft,n6eff,i3_glob,i2_loc,i2dat_loc,i3dat
4202 : : integer,save :: nwrites_ialltoall=0
4203 : : logical :: use_ialltoall
4204 : : real(dp) :: fim,fre,xnorm
4205 : : character(len=500) :: msg
4206 : : !arrays
4207 : : integer,parameter :: shiftg0(3)=0
4208 : : integer,parameter :: symmE(3,3)=reshape([1,0,0,0,1,0,0,0,1],[3,3])
4209 : : ! real(dp) :: tsec(2)
4210 : 1604046 : real(dp) :: weight_array_r(ndat), weight_array_i(ndat)
4211 : 802023 : real(dp),allocatable :: workf(:,:,:,:)
4212 : : ! *************************************************************************
4213 : :
4214 : : !call timab(540,1,tsec)
4215 : :
4216 : 802023 : fftalg=ngfft(7); fftalga=fftalg/100 ; fftalgc=mod(fftalg,10)
4217 : :
4218 : 802023 : me_fft=ngfft(11); nproc_fft=ngfft(10)
4219 : : !write(std_out,*)"nproc_fft",nproc_fft
4220 : : ! Risky since I don't know if this entry is initialized
4221 : : ! Continue to pass comm_fft explicitly.
4222 : : !comm_fft = ngfft(14)
4223 : :
4224 [ - + ]: 802023 : if (fftalgc<1 .or. fftalgc>2) then
4225 : : write(msg,'(a,i0,3a)')&
4226 : 0 : 'The input algorithm number fftalgc=',fftalgc,' is not allowed with MPI-FFT. Must be 1 or 2',ch10,&
4227 : 0 : 'Action: change fftalgc in your input file.'
4228 : 0 : ABI_ERROR(msg)
4229 : : end if
4230 : :
4231 [ - + ]: 802023 : if (option<0 .or. option>3) then
4232 : : write(msg,'(a,i0,3a)')&
4233 : 0 : 'The option number',option,' is not allowed.',ch10,&
4234 : 0 : 'Only option=0, 1, 2 or 3 are allowed presently.'
4235 : 0 : ABI_ERROR(msg)
4236 : : end if
4237 : :
4238 [ + + - + ]: 802023 : if (option==1 .and. cplex/=1) then
4239 : : write(msg,'(a,i0,a)')&
4240 : 0 : 'With the option number 1, cplex must be 1 but it is cplex=',cplex,'.'
4241 : 0 : ABI_ERROR(msg)
4242 : : end if
4243 : :
4244 [ + + - + ]: 802023 : if ( ALL(cplex/=(/1,2/)) .and. ANY(option==(/1,2/)) ) then
4245 : 0 : write(msg,'(a,i0,a)')' When option is (1,2) cplex must be 1 or 2, but it is cplex=',cplex,'.'
4246 : 0 : ABI_ERROR(msg)
4247 : : end if
4248 : :
4249 : : !write(std_out,*)"in fourwf_mpi with fftalg: ",fftalg,fftalgc
4250 : :
4251 : : ! We use the non-blocking version if IALLTOALL is available and ndat > 1.
4252 : : use_ialltoall = .False.
4253 : : #ifdef HAVE_MPI_IALLTOALL
4254 : 802023 : use_ialltoall = (ndat > 1)
4255 : : #endif
4256 [ + + + - ]: 802023 : use_ialltoall = (use_ialltoall .and. ALLOW_IALLTOALL)
4257 [ + + ]: 11797 : if (use_ialltoall .and. nwrites_ialltoall==0) then
4258 : 32 : nwrites_ialltoall = 1
4259 : 32 : call wrtout(std_out, "- Will use non-blocking ialltoall for MPI-FFT")
4260 : : end if
4261 : :
4262 : 802023 : md1i=0; md2i=0; md3i=0; m2i=0
4263 : 802023 : md1o=0; md2o=0; md3o=0; m2o=0
4264 : :
4265 [ + + ]: 802023 : if (option/=3) then
4266 : : ! Compute the dimensions of the small-box enclosing the input G-sphere
4267 : 801981 : max1i=gboundin(2,1); min1i=gboundin(1,1)
4268 : 801981 : max2i=gboundin(4,1); min2i=gboundin(3,1)
4269 : :
4270 [ + + + ]: 801981 : if(istwf_k==2 .or. istwf_k==4 .or. istwf_k==6 .or. istwf_k==8)then
4271 : 181 : max1i=max(max1i,-min1i)
4272 : 181 : min1i=-max1i
4273 : : else if (istwf_k==3 .or. istwf_k==5 .or. istwf_k==7 .or. istwf_k==9) then
4274 : 134 : max1i=max(max1i,-min1i-1)
4275 : 134 : min1i=-max1i-1
4276 : : end if
4277 [ + + ]: 801981 : if (istwf_k>=2 .and. istwf_k<=5) then
4278 : 185 : max2i=max(max2i,-min2i)
4279 : 185 : min2i=-max2i
4280 [ + + ]: 801796 : else if (istwf_k>=6 .and. istwf_k<=9) then
4281 : 130 : max2i=max(max2i,-min2i-1)
4282 : 130 : min2i=-max2i-1
4283 : : end if
4284 : :
4285 : 801981 : max3i=gboundin(4,2); min3i=gboundin(3,2)
4286 : :
4287 : : ! Compute arrays size and leading dimensions to avoid cache trashing
4288 : 801981 : m1i=max1i-min1i+1; md1i=2*(m1i/2)+1
4289 : 801981 : m2i=max2i-min2i+1; md2i=2*(m2i/2)+1
4290 : :
4291 : : !if (.False.) then
4292 [ + + ]: 801981 : if (nproc_fft/=1) then
4293 : : ! Increase max2i in order to have m2i divisible by nproc_fft
4294 : 699442 : min2i_moins=(((m2i-1)/nproc_fft+1)*nproc_fft-m2i)/2
4295 : 699442 : max2i_plus=((m2i-1)/nproc_fft+1)*nproc_fft-m2i-min2i_moins
4296 : : ! max2i=max2i+((m2i-1)/nproc_fft+1)*nproc_fft-m2i
4297 : 699442 : max2i=max2i+max2i_plus
4298 : 699442 : min2i=min2i-min2i_moins
4299 : : ! careful, to be checked and make sure the max and min are smaller than size of box
4300 : 699442 : m2i=max2i-min2i+1; md2i=2*(m2i/2)+1
4301 : : end if
4302 [ - + ]: 801981 : ABI_CHECK(m2i <= n2, "m2i > n2")
4303 : :
4304 : 801981 : m3i=max3i-min3i+1; md3i=2*(m3i/2)+1
4305 : : end if
4306 : :
4307 [ + + ]: 802023 : if (option==2 .or. option==3) then
4308 : : ! Compute the dimensions of the small-box enclosing the output G-sphere
4309 : 738459 : max1o=gboundout(2,1); min1o=gboundout(1,1)
4310 : 738459 : max2o=gboundout(4,1); min2o=gboundout(3,1)
4311 : :
4312 [ + + + ]: 738459 : if (istwf_k==2 .or. istwf_k==4 .or. istwf_k==6 .or. istwf_k==8) then
4313 : 92 : max1o=max(max1o,-min1o)
4314 : 92 : min1o=-max1o
4315 : : else if (istwf_k==3 .or. istwf_k==5 .or. istwf_k==7 .or. istwf_k==9) then
4316 : 58 : max1o=max(max1o,-min1o-1)
4317 : 58 : min1o=-max1o-1
4318 : : end if
4319 [ + + ]: 738459 : if (istwf_k>=2 .and. istwf_k<=5) then
4320 : 96 : max2o=max(max2o,-min2o)
4321 : 96 : min2o=-max2o
4322 [ + + ]: 738363 : else if (istwf_k>=6 .and. istwf_k<=9) then
4323 : 54 : max2o=max(max2o,-min2o-1)
4324 : 54 : min2o=-max2o-1
4325 : : end if
4326 : :
4327 : 738459 : max3o=gboundout(4,2); min3o=gboundout(3,2)
4328 : :
4329 : : ! Compute arrays size and leading dimensions to avoid cache trashing
4330 : 738459 : m1o=max1o-min1o+1; md1o=2*(m1o/2)+1
4331 : 738459 : m2o=max2o-min2o+1; md2o=2*(m2o/2)+1
4332 : :
4333 [ + + ]: 738459 : if (nproc_fft/=1) then
4334 : : ! Increase max2o in order to have m2o divisible by nproc_fft
4335 : 651344 : min2o_moins=(((m2o-1)/nproc_fft+1)*nproc_fft-m2o)/2
4336 : 651344 : max2o_plus=((m2o-1)/nproc_fft+1)*nproc_fft-m2o-min2o_moins
4337 : : ! max2o=max2o+((m2o-1)/nproc_fft+1)*nproc_fft-m2o
4338 : 651344 : max2o=max2o+max2o_plus
4339 : 651344 : min2o=min2o-min2o_moins
4340 : : ! careful, to be checked and make sure the max and min are smaller than size of box
4341 : 651344 : m2o=max2o-min2o+1; md2o=2*(m2o/2)+1
4342 : : end if
4343 [ - + ]: 738459 : ABI_CHECK(m2o <= n2, "m2o > n2")
4344 : :
4345 : 738459 : m3o=max3o-min3o+1; md3o=2*(m3o/2)+1
4346 : : end if
4347 : :
4348 : 802023 : md1=max(md1i,md1o)
4349 : : md2=max(md2i,md2o)
4350 : 802023 : md3=max(md3i,md3o)
4351 : :
4352 : 802023 : md2proc=(max(m2i,m2o)-1)/nproc_fft+1
4353 : 802023 : n6eff=(n6-1)/nproc_fft+1
4354 : : !write(std_out,*)'fourwf_mpi : max1i,max2i,max3i=',max1i,max2i,max3i
4355 : : !write(std_out,*)'fourwf_mpi : min1i,min2i,min3i=',min1i,min2i,min3i
4356 : : !write(std_out,*)'fourwf_mpi : m1i,m2i,m3i=',m1i,m2i,m3i
4357 : :
4358 : : ! Allocate work array in G-space (note exchange 3 <--> 2)
4359 [ - + + - : 4010115 : ABI_MALLOC(workf,(2,md1,md3,md2proc*ndat))
- + + - -
+ + - + -
+ - - + -
+ ]
4360 : :
4361 [ + + ]: 802023 : if (option/=3) then
4362 : : ! Insert fofgin into the **small** box (array workf) :
4363 : : ! Note the switch of md3 and md2, as they are only needed to dimension workf inside "sphere"
4364 : :
4365 [ + + ]: 801981 : if (nproc_fft > 1) then
4366 [ - + ]: 699442 : if (istwf_k/=1 )then
4367 : 0 : write(msg,'(a,i0,a)')'The value of istwf_k: ',istwf_k,' is not allowed. Only istwf_k=1 is allowed in MPI-FFT'
4368 : : !ABI_WARNING(msg)
4369 : 0 : ABI_ERROR(msg)
4370 : : end if
4371 : 699442 : call sphere_fft1(fofgin,ndat,npwin,workf,m1i,m2i,m3i,md1,md3,md2proc,kg_kin,distribfft%tab_fftwf2_local)
4372 : : else
4373 : 102539 : iflag=2
4374 : 102539 : call sphere(fofgin,ndat,npwin,workf,m1i,m2i,m3i,md1,md3,md2proc,kg_kin,istwf_k,iflag,me_g0,shiftg0,symmE,one)
4375 : : end if
4376 : : end if
4377 : :
4378 : : ! Can we use c2r or r2c?
4379 [ + + ]: 802023 : cplexwf_=2; if (istwf_k==2) cplexwf_=1
4380 [ + + ]: 802023 : if (present(cplexwf)) cplexwf_ = cplexwf
4381 : :
4382 [ + + + + : 802023 : if (option==0 .or. ((option==1.or.option==2) .and. fftalgc==1) .or. option==3) then
+ + + + ]
4383 : : ! Treat non-composite operations
4384 : :
4385 [ + + ]: 800906 : if (option/=3) then
4386 : : ! Fourier transform workf(2,md1,md3,md2proc*ndat) to fofr (reciprocal to real space).
4387 : : ! FIXME: This is buggy if cplexwx==1
4388 : :
4389 : 800864 : select case (fftalga)
4390 : :
4391 : : case (FFT_SG2002)
4392 : :
4393 : : ! do idat=1,ndat
4394 : : ! call sg2002_mpiback_wf(cplexwf_,1,n1,n2,n3,n4,n5,(n6-1)/nproc_fft+1,&
4395 : : ! & max1i,max2i,max3i,m1i,m2i,m3i,md1,md2proc,md3, &
4396 : : ! & workf(:,:,:,(idat-1)*md2proc+1:idat*md2proc), &
4397 : : ! & fofr(:,:,:,(idat-1)*n6eff+1:idat*n6eff),comm_fft)
4398 : : ! enddo
4399 : : call sg2002_mpiback_wf(cplexwf_,ndat,n1,n2,n3,n4,n5,(n6-1)/nproc_fft+1,&
4400 : 800864 : max1i,max2i,max3i,m1i,m2i,m3i,md1,md2proc,md3,workf,fofr,comm_fft)
4401 : :
4402 : : case (FFT_FFTW3)
4403 : :
4404 [ # # ]: 0 : if (use_ialltoall) then
4405 : : call fftw3_mpiback_manywf(cplexwf_,ndat,n1,n2,n3,n4,n5,(n6-1)/nproc_fft+1,&
4406 : 0 : max1i,max2i,max3i,m1i,m2i,m3i,md1,md2proc,md3,workf,fofr,comm_fft)
4407 : : else
4408 : : call fftw3_mpiback_wf(cplexwf_,ndat,n1,n2,n3,n4,n5,(n6-1)/nproc_fft+1,&
4409 : 0 : max1i,max2i,max3i,m1i,m2i,m3i,md1,md2proc,md3,workf,fofr,comm_fft)
4410 : : end if
4411 : :
4412 : : !case (FFT_DFTI)
4413 : : ! call dfti_mpiback_wf(cplexwf_,ndat,n1,n2,n3,n4,n5,(n6-1)/nproc_fft+1,&
4414 : : ! & max1i,max2i,max3i,m1i,m2i,m3i,md1,md2proc,md3,workf,fofr,comm_fft)
4415 : : case default
4416 [ + - - ]: 800864 : ABI_ERROR("fftalga does not provide MPI back_wf")
4417 : : end select
4418 : :
4419 : : end if ! option
4420 : :
4421 : 800906 : nd3proc=(n3-1)/nproc_fft+1
4422 : :
4423 [ + + ]: 800906 : if (option==1) then
4424 : : ! Accumulate density
4425 [ + + ]: 124044 : do idat=1,ndat
4426 [ + + ]: 875175 : do i3=1,nd3proc
4427 : 751131 : i3_glob = i3 + nd3proc * me_fft
4428 : 751131 : i3dat = i3 + n6eff * (idat-1)
4429 [ + + ]: 17292917 : do i2=1,n2
4430 [ + + ]: 458067395 : do i1=1,n1
4431 : : denpot(i1,i2,i3_glob) = denpot(i1,i2,i3_glob) &
4432 : 457316264 : + (weight_r*fofr(1,i1,i2,i3dat)**2+ weight_i*fofr(2,i1,i2,i3dat)**2)
4433 : : end do
4434 : : end do
4435 : : end do
4436 : : end do
4437 : : end if ! option==1
4438 : :
4439 [ + + ]: 800906 : if (option==2) then
4440 : :
4441 : : ! Apply local potential
4442 [ + + ]: 737514 : if (cplex==1) then
4443 [ + + ]: 1333123 : do idat=1,ndat
4444 [ + + ]: 9120245 : do i3=1,nd3proc
4445 : 7787122 : i3_glob = i3 + nd3proc * me_fft
4446 : 7787122 : i3dat = i3 + n6eff * (idat-1)
4447 [ + + ]: 187767312 : do i2=1,n2
4448 [ + + ]: 5091653122 : do i1=1,n1
4449 : 4904579130 : fofr(1,i1,i2,i3dat)=denpot(i1,i2,i3_glob)*fofr(1,i1,i2,i3dat)
4450 : 5083866000 : fofr(2,i1,i2,i3dat)=denpot(i1,i2,i3_glob)*fofr(2,i1,i2,i3dat)
4451 : : end do
4452 : : end do
4453 : : end do
4454 : : end do
4455 : :
4456 [ + - ]: 97711 : else if (cplex==2) then
4457 [ + + ]: 195428 : do idat=1,ndat
4458 [ + + ]: 1410304 : do i3=1,(n3-1)/nproc_fft+1
4459 : 1214876 : i3_glob = i3 + nd3proc * me_fft
4460 : 1214876 : i3dat = i3 + n6eff * (idat-1)
4461 [ + + ]: 23760561 : do i2=1,n2
4462 [ + + ]: 451698268 : do i1=1,n1
4463 : 428035424 : fre=fofr(1,i1,i2,i3dat)
4464 : 428035424 : fim=fofr(2,i1,i2,i3dat)
4465 : 428035424 : fofr(1,i1,i2,i3dat)=denpot(2*i1-1,i2,i3_glob)*fre -denpot(2*i1,i2,i3_glob)*fim
4466 : 450483392 : fofr(2,i1,i2,i3dat)=denpot(2*i1-1,i2,i3_glob)*fim +denpot(2*i1,i2,i3_glob)*fre
4467 : : end do
4468 : : end do
4469 : : end do
4470 : : end do
4471 : : end if ! cplex
4472 : :
4473 : : end if ! option==2
4474 : :
4475 [ + + ]: 800906 : if (option==2 .or. option==3) then
4476 : : ! Fourier transform fofr to workf (real to reciprocal space)
4477 : : ! output in workf(2,md1,md3,md2proc*ndat)
4478 : :
4479 : 737556 : select case (fftalga)
4480 : : case (FFT_SG2002)
4481 : :
4482 : : call sg2002_mpiforw_wf(cplexwf_,ndat,n1,n2,n3,n4,n5,(n6-1)/nproc_fft+1,&
4483 : 737556 : max1o,max2o,max3o,m1o,m2o,m3o,md1,md2proc,md3,fofr,workf,comm_fft)
4484 : :
4485 : : case (FFT_FFTW3)
4486 : :
4487 [ # # ]: 0 : if (use_ialltoall) then
4488 : : call fftw3_mpiforw_manywf(cplexwf_,ndat,n1,n2,n3,n4,n5,(n6-1)/nproc_fft+1,&
4489 : 0 : max1o,max2o,max3o,m1o,m2o,m3o,md1,md2proc,md3,fofr,workf,comm_fft)
4490 : : else
4491 : : call fftw3_mpiforw_wf(cplexwf_,ndat,n1,n2,n3,n4,n5,(n6-1)/nproc_fft+1,&
4492 : 0 : max1o,max2o,max3o,m1o,m2o,m3o,md1,md2proc,md3,fofr,workf,comm_fft)
4493 : : end if
4494 : :
4495 : : !case (FFT_DFTI)
4496 : : ! call dfti_mpiforw_wf(cplexwf_,ndat,n1,n2,n3,n4,n5,(n6-1)/nproc_fft+1,&
4497 : : ! &max1o,max2o,max3o,m1o,m2o,m3o,md1,md2proc,md3,fofr,workf,comm_fft)
4498 : :
4499 : : case default
4500 [ + - - ]: 737556 : ABI_ERROR("fftalga does not provide MPI back_wf")
4501 : : end select
4502 : :
4503 : : end if
4504 : :
4505 [ + - + - ]: 1117 : else if (fftalgc==2 .and. (option==1 .or. option==2)) then
4506 : : ! Treat composite operations
4507 : :
4508 : 214 : select case (option)
4509 : : case (1)
4510 : : !ABI_CHECK(weight_r == weight_i,"weight_r != weight_i")
4511 [ + + ]: 438 : weight_array_r(:)=weight_r
4512 [ + + ]: 438 : weight_array_i(:)=weight_i
4513 : :
4514 : 1117 : select case (fftalga)
4515 : : case (FFT_SG2002)
4516 : : ! Note that here we don' fill fofr. Don't know if someone in
4517 : : ! abinit uses option 1 to get both fofr as well as denpot
4518 : : call sg2002_accrho(cplexwf_,ndat,n1,n2,n3,n4,n5,n6,(n6-1)/nproc_fft+1,&
4519 : : max1i,max2i,max3i,m1i,m2i,m3i,md1,md2proc,md3,comm_fft,nproc_fft,me_fft,&
4520 : 214 : workf,denpot,weight_array_r,weight_array_i)
4521 : :
4522 : : case (FFT_FFTW3)
4523 : : call fftw3_accrho(cplexwf_,ndat,n1,n2,n3,n4,n5,n6,(n6-1)/nproc_fft+1,&
4524 : : max1i,max2i,max3i,m1i,m2i,m3i,md1,md2proc,md3,comm_fft,nproc_fft,me_fft,&
4525 : 0 : workf,denpot,weight_array_r, weight_array_i)
4526 : :
4527 : : case default
4528 [ + - - ]: 214 : ABI_ERROR("fftalga does not provide accrho")
4529 : : end select
4530 : :
4531 : : case (2)
4532 : : !write(std_out,*)fftalg,option,cplex
4533 : : !ABI_CHECK(cplex==1,"cplex!=2 with fftalg 412 is buggy")
4534 : :
4535 : 903 : select case (fftalga)
4536 : :
4537 : : case (FFT_SG2002)
4538 : :
4539 [ + + ]: 903 : if (use_ialltoall) then
4540 : : call sg2002_applypot_many(cplexwf_,cplex,ndat,n1,n2,n3,n4,n5,n6,(n6-1)/nproc_fft+1,&
4541 : : max1i,max2i,max3i,m1i,m2i,m3i,md1,md2proc,md3,&
4542 : 680 : max1o,max2o,max3o,m1o,m2o,m3o,comm_fft,nproc_fft,me_fft,denpot,workf)
4543 : :
4544 : : else
4545 : : call sg2002_applypot(cplexwf_,cplex,ndat,n1,n2,n3,n4,n5,n6,(n6-1)/nproc_fft+1,&
4546 : : max1i,max2i,max3i,m1i,m2i,m3i,md1,md2proc,md3,&
4547 : 223 : max1o,max2o,max3o,m1o,m2o,m3o,comm_fft,nproc_fft,me_fft,denpot,workf)
4548 : : endif
4549 : :
4550 : : case (FFT_FFTW3)
4551 : :
4552 [ # # ]: 0 : if (use_ialltoall) then
4553 : :
4554 : : call fftw3_applypot_many(cplexwf_,cplex,ndat,n1,n2,n3,n4,n5,n6,(n6-1)/nproc_fft+1,&
4555 : : max1i,max2i,max3i,m1i,m2i,m3i,md1,md2proc,md3,&
4556 : 0 : max1o,max2o,max3o,m1o,m2o,m3o,comm_fft,nproc_fft,me_fft,denpot,workf)
4557 : :
4558 : : else
4559 : : call fftw3_applypot(cplexwf_,cplex,ndat,n1,n2,n3,n4,n5,n6,(n6-1)/nproc_fft+1,&
4560 : : max1i,max2i,max3i,m1i,m2i,m3i,md1,md2proc,md3,&
4561 : 0 : max1o,max2o,max3o,m1o,m2o,m3o,comm_fft,nproc_fft,me_fft,denpot,workf)
4562 : : end if
4563 : :
4564 : : case default
4565 [ + - - ]: 903 : ABI_ERROR("fftalga does not provide applypot")
4566 : : end select
4567 : :
4568 : : case default
4569 : : write(msg,"(a,i0,a)")"Option ",option," is not supported when fftalgc == 2"
4570 [ + + ]: 1117 : ABI_ERROR(msg)
4571 : : end select
4572 : :
4573 : : end if ! End of composite operations
4574 : :
4575 [ + + ]: 802023 : if (option==2 .or. option==3) then
4576 : : ! From FFT box to kg_kout.
4577 : 738459 : xnorm=one/dble(n1*n2*n3)
4578 : :
4579 [ + + ]: 738459 : if (nproc_fft > 1) then
4580 [ + + ]: 1326024 : do idat=1,ndat
4581 [ + + ]: 183283106 : do ig=1,npwout
4582 [ + + ]: 181957082 : i1=kg_kout(1,ig); if(i1<0) i1=i1+m1o; i1=i1+1
4583 [ + + ]: 181957082 : i2=kg_kout(2,ig); if(i2<0) i2=i2+m2o; i2=i2+1
4584 [ + + ]: 181957082 : i3=kg_kout(3,ig); if(i3<0) i3=i3+m3o; i3=i3+1
4585 : :
4586 : 181957082 : igdat = ig + (idat-1) * npwout
4587 : 181957082 : i2_loc = (i2-1)/nproc_fft +1
4588 : 181957082 : i2dat_loc = i2_loc + (idat-1) * md2proc
4589 : :
4590 : 181957082 : fofgout(1,igdat)=workf(1,i1,i3,i2dat_loc)*xnorm
4591 : 182631762 : fofgout(2,igdat)=workf(2,i1,i3,i2dat_loc)*xnorm
4592 : : end do
4593 : : end do
4594 : : else
4595 : : ! Warning: This call is buggy if istwfk > 2
4596 : 87115 : iflag=-2
4597 : : call sphere(fofgout,ndat,npwout,workf,m1o,m2o,m3o,md1,md3,md2proc,kg_kout,istwf_k,iflag,&
4598 : 87115 : me_g0,shiftg0,symmE,xnorm)
4599 : : end if
4600 : : end if ! if option==2 or 3
4601 : :
4602 [ - + ]: 802023 : ABI_FREE(workf)
4603 : :
4604 : : !call timab(540,2,tsec)
4605 : :
4606 : 802023 : end subroutine fourwf_mpi
4607 : : !!***
4608 : :
4609 : : !----------------------------------------------------------------------
4610 : :
4611 : : !!****f* m_fft/fftmpi_u
4612 : : !!
4613 : : !! NAME
4614 : : !! fftmpi_u
4615 : : !!
4616 : : !! FUNCTION
4617 : : !! **** DO NOT USE IT ****
4618 : : !! Wrapper function used to perform the MPI FFT of ndat wavefunctions.
4619 : : !! Mainly used for unit tests and prototyping. Better integration
4620 : : !! will be provided afterwards.
4621 : : !!
4622 : : !! INPUTS
4623 : : !! See fourwf_mpi
4624 : : !!
4625 : : !! OUTPUT
4626 : : !! See fourwf_mpi
4627 : : !!
4628 : : !! SOURCE
4629 : :
4630 : : ! The final interface should be:
4631 : : !subroutine fftmpi_u(npw_k,n4,n5,n6,nspinor,ndat,mgfft,ngfft,istwf_k,kg_k,gbound_k,fftabs,isign,fofg,fofr)
4632 : :
4633 : 16 : subroutine fftmpi_u(npw_k,n4,n5,n6,ndat,mgfft,ngfft,&
4634 : 16 : istwf_k,gbound_k,kg_k,me_g0,distribfft,isign,fofg,fofr,comm_fft,cplexwf)
4635 : :
4636 : : !Arguments ------------------------------------
4637 : : !scalars
4638 : : integer,intent(in) :: istwf_k,mgfft,n4,n5,n6,ndat,npw_k
4639 : : integer,intent(in) :: isign,comm_fft,me_g0,cplexwf
4640 : : type(distribfft_type),intent(in) :: distribfft
4641 : : !arrays
4642 : : integer,intent(in) :: gbound_k(2*mgfft+8,2),ngfft(18)
4643 : : integer,intent(in) :: kg_k(3,npw_k)
4644 : : real(dp),intent(inout) :: fofg(2,npw_k*ndat),fofr(2,n4,n5,n6*ndat)
4645 : :
4646 : : !Local variables-------------------------------
4647 : : !scalars
4648 : : integer,parameter :: npw0=0,cplex0=0
4649 : : integer :: n1,n2,n3
4650 : : real(dp),parameter :: weight_r=one,weight_i=one
4651 : : !arrays
4652 : : integer :: dummy_kg(0,0)
4653 : : real(dp) :: dummy_denpot(0,0,0),dummy_fofg(0,0)
4654 : : ! *************************************************************************
4655 : :
4656 : 16 : n1 = ngfft(1); n2 = ngfft(2); n3 = ngfft(3)
4657 : :
4658 [ + + ]: 16 : if (isign == 1) then
4659 : : ! option 0 G --> R
4660 : : call fourwf_mpi(cplex0,dummy_denpot,fofg,dummy_fofg,fofr,&
4661 : : gbound_k,gbound_k,istwf_k,kg_k,dummy_kg,me_g0,mgfft,ngfft,distribfft,n1,n2,n3,&
4662 : 8 : npw_k,npw0,n4,n5,n6,ndat,0,weight_r,weight_i,comm_fft,cplexwf=cplexwf)
4663 : : else
4664 : : ! option 3 R --> G
4665 : : call fourwf_mpi(cplex0,dummy_denpot,dummy_fofg,fofg,fofr,&
4666 : : gbound_k,gbound_k,istwf_k,dummy_kg,kg_k,me_g0,mgfft,ngfft,distribfft,n1,n2,n3,&
4667 : 8 : npw0,npw_k,n4,n5,n6,ndat,3,weight_r,weight_i,comm_fft,cplexwf=cplexwf)
4668 : : end if
4669 : :
4670 : 16 : end subroutine fftmpi_u
4671 : : !!***
4672 : :
4673 : : !!****f* m_fft/zerosym
4674 : : !! NAME
4675 : : !! zerosym
4676 : : !!
4677 : : !! FUNCTION
4678 : : !! Symmetrize an array on the FFT grid by vanishing some term on the boundaries.
4679 : : !!
4680 : : !! INPUTS
4681 : : !! cplex= if 1, input array is REAL, if 2, input array is COMPLEX
4682 : : !! mpi_enreg=information about MPI parallelization
4683 : : !! n1,n2,n3=FFT dimensions nfft=n1*n2*n3
4684 : : !! ig1,ig2,ig3=optional arguments= indexes of unbalanced g-vectors to cancel
4685 : : !! if not present, ig1=1+n1/2, ig2=1+n2/2, ig3=1+n3/2 for even n1,n2,n3
4686 : : !! if igj=-1, nothing is done in direction j
4687 : : !!
4688 : : !! SIDE EFFECTS
4689 : : !! array(cplex,n1*n2*n3)=complex array to be symetrized
4690 : : !!
4691 : : !! SOURCE
4692 : :
4693 : 119373 : subroutine zerosym(array,cplex,n1,n2,n3, &
4694 : : ig1,ig2,ig3,comm_fft,distribfft) ! Optional arguments
4695 : :
4696 : : !Arguments ------------------------------------
4697 : : !scalars
4698 : : integer,intent(in) :: cplex,n1,n2,n3
4699 : : integer,optional,intent(in) :: ig1,ig2,ig3,comm_fft
4700 : : type(distribfft_type),intent(in),target,optional :: distribfft
4701 : : !arrays
4702 : : real(dp),intent(inout) :: array(cplex,n1*n2*n3)
4703 : :
4704 : : !Local variables-------------------------------
4705 : : !scalars
4706 : : integer :: i1,i2,i3,ifft,ifft_proc,index,j,j1,j2,j3,me_fft,nd2
4707 : : integer :: nproc_fft,n1sel,nn12,n2sel,n3sel,r2
4708 : : !arrays
4709 : 119373 : integer, contiguous, pointer :: fftn2_distrib(:),ffti2_local(:)
4710 : : ! **********************************************************************
4711 : :
4712 : 119373 : me_fft=0;nproc_fft=1
4713 : 119373 : if (present(comm_fft)) then
4714 : 111614 : me_fft=xmpi_comm_rank(comm_fft)
4715 : 111614 : nproc_fft=xmpi_comm_size(comm_fft)
4716 : : end if
4717 : 119373 : nd2=(n2-1)/nproc_fft+1
4718 : 119373 : nn12=n1*n2
4719 : :
4720 : : !Get the distrib associated with this fft_grid
4721 [ + + ]: 119373 : if (present(distribfft)) then
4722 [ + + ]: 111614 : if (n2== distribfft%n2_coarse) then
4723 : 68916 : fftn2_distrib => distribfft%tab_fftdp2_distrib
4724 : 68916 : ffti2_local => distribfft%tab_fftdp2_local
4725 [ + - ]: 42698 : else if(n2 == distribfft%n2_fine) then
4726 : 42698 : fftn2_distrib => distribfft%tab_fftdp2dg_distrib
4727 : 42698 : ffti2_local => distribfft%tab_fftdp2dg_local
4728 : : else
4729 : 0 : ABI_BUG("Unable to find an allocated distrib for this fft grid")
4730 : : end if
4731 : : else
4732 [ - + + - : 23277 : ABI_MALLOC(fftn2_distrib,(n2))
+ - + - -
+ - + ]
4733 [ - + + - : 15518 : ABI_MALLOC(ffti2_local,(n2))
- + + - ]
4734 [ + + + - : 490226 : fftn2_distrib=0;ffti2_local=(/(i2,i2=1,n2)/)
+ + + + ]
4735 : : end if
4736 : :
4737 [ + + ]: 119373 : if (present(ig1)) then
4738 : 5622 : n1sel=ig1
4739 [ + + ]: 113751 : else if (mod(n1,2)==0) then
4740 : 92545 : n1sel=1+n1/2
4741 : : else
4742 : : n1sel=-1
4743 : : end if
4744 [ + + ]: 119373 : if (present(ig2)) then
4745 : 5622 : n2sel=ig2
4746 [ + + ]: 113751 : else if (mod(n2,2)==0) then
4747 : 89792 : n2sel=1+n2/2
4748 : : else
4749 : : n2sel=-1
4750 : : end if
4751 [ + + ]: 119373 : if (present(ig3)) then
4752 : 5622 : n3sel=ig3
4753 [ + + ]: 113751 : else if (mod(n3,2)==0) then
4754 : 91575 : n3sel=1+n3/2
4755 : : else
4756 : : n3sel=-1
4757 : : end if
4758 : :
4759 [ + + ]: 119373 : if (n1sel>0) then
4760 : 98143 : index=n1sel-nn12-n1
4761 [ + + ]: 2495716 : do i3=1,n3
4762 : 2397573 : index=index+nn12;ifft=index
4763 [ + + ]: 71020453 : do i2=1,n2
4764 : 68524737 : ifft=ifft+n1
4765 [ + + ]: 70922310 : if (nproc_fft>1) then
4766 : : ! MPIWF: consider ifft only if it is treated by the current proc and compute its address
4767 : 10006624 : j=ifft-1;j1=modulo(j,n1);j2=modulo(j/n1,n2);j3=j/(n1*n2) !;r2=modulo(j2,nd2)
4768 [ + + ]: 10006624 : if(fftn2_distrib(j2+1)==me_fft) then ! MPIWF this ifft is to be treated by me_fft
4769 : 4947728 : r2= ffti2_local(j2+1) - 1
4770 : 4947728 : ifft_proc=n1*(nd2*j3+r2)+j1+1 !this is ifft in the current proc
4771 [ + + ]: 14843184 : array(:,ifft_proc)=zero
4772 : : end if
4773 : : else
4774 [ + + ]: 171835005 : array(:,ifft)=zero
4775 : : end if
4776 : : end do
4777 : : end do
4778 : : end if
4779 : :
4780 [ + + ]: 119373 : if (n2sel>0) then
4781 : 95384 : index=n1*n2sel-nn12-n1
4782 [ + + ]: 2391856 : do i3=1,n3
4783 : 2296472 : index=index+nn12;ifft=index
4784 [ + + ]: 72184968 : do i1=1,n1
4785 : 69793112 : ifft=ifft+1
4786 [ + + ]: 72089584 : if (nproc_fft>1) then
4787 : : ! MPIWF: consider ifft only if it is treated by the current proc and compute its address
4788 : 10032544 : j=ifft-1;j1=modulo(j,n1);j2=modulo(j/n1,n2);j3=j/(n1*n2);
4789 [ + + ]: 10032544 : if(fftn2_distrib(j2+1)==me_fft) then ! MPIWF this ifft is to be treated by me_fft
4790 : 4960688 : r2= ffti2_local(j2+1) - 1
4791 : 4960688 : ifft_proc=n1*(nd2*j3+r2)+j1+1 !this is ifft in the current proc
4792 [ + + ]: 14882064 : array(:,ifft_proc)=zero
4793 : : end if
4794 : : else
4795 [ + + ]: 177693480 : array(:,ifft)=zero
4796 : : end if
4797 : : end do
4798 : : end do
4799 : : end if
4800 : :
4801 [ + + ]: 119373 : if (n3sel>0) then
4802 : 97155 : index=nn12*n3sel-nn12-n1
4803 [ + + ]: 2325270 : do i2=1,n2
4804 : 2228115 : index=index+n1;ifft=index
4805 [ + + ]: 72340715 : do i1=1,n1
4806 : 70015445 : ifft=ifft+1
4807 [ + + ]: 72243560 : if (nproc_fft>1) then
4808 : : ! MPIWF: consider ifft only if it is treated by the current proc and compute its address
4809 : 10032544 : j=ifft-1;j1=modulo(j,n1);j2=modulo(j/n1,n2);j3=j/(n1*n2)
4810 [ + + ]: 10032544 : if(fftn2_distrib(j2+1)==me_fft) then ! MPIWF this ifft is to be treated by me_fft
4811 : 4960688 : r2= ffti2_local(j2+1) - 1
4812 : 4960688 : ifft_proc=n1*(nd2*j3+r2)+j1+1 !this is ifft in the current proc
4813 [ + + ]: 14882064 : array(:,ifft_proc)=zero
4814 : : end if
4815 : : else
4816 [ + + ]: 178122339 : array(:,ifft)=zero
4817 : : end if
4818 : : end do
4819 : : end do
4820 : : end if
4821 : :
4822 [ + + ]: 119373 : if (.not.present(distribfft)) then
4823 [ - + ]: 7759 : ABI_FREE(fftn2_distrib)
4824 [ - + ]: 7759 : ABI_FREE(ffti2_local)
4825 : : end if
4826 : :
4827 [ + + ]: 119373 : end subroutine zerosym
4828 : : !!***
4829 : :
4830 : : !!****f* m_fft/fourdp_6d
4831 : : !! NAME
4832 : : !! fourdp_6d
4833 : : !!
4834 : : !! FUNCTION
4835 : : !! Calculate a 6-dimensional Fast Fourier Transform
4836 : : !!
4837 : : !! isign=-1 : A(G1,G2) = Sum(r1,r2) A(r1,r2) exp(-iG1.r1) exp(+iG2.r2)
4838 : : !! ^ ^
4839 : : !! isign=+1 : A(r1,r2) = Sum(G1,G2) A(G1,G2) exp(+iG1.r1) exp(-iG2.r2)
4840 : : !! ^ ^
4841 : : !! isign=-1 and isign=1 form a transform/inverse-transform pair: calling
4842 : : !! one then the other will take you back to the original function,
4843 : : !! multiplied by a factor of (nl*nm*nn)**2.
4844 : : !! ------------------------------------------------------------------
4845 : : !!
4846 : : !! input:
4847 : : !! a: A(r1,r2) [overwritten]
4848 : : !! output:
4849 : : !! a: A(G1,G2) in the format IGFFT
4850 : : !! ------------------------------------------------------------------
4851 : : !!
4852 : : !! INPUTS
4853 : : !!
4854 : : !! OUTPUT
4855 : : !!
4856 : : !! SOURCE
4857 : :
4858 : 0 : subroutine fourdp_6d(cplex, matrix, isign, MPI_enreg, nfft, ngfft, tim_fourdp)
4859 : :
4860 : : !Arguments ------------------------------------
4861 : : !scalars
4862 : : integer,intent(in) :: cplex, isign, nfft, tim_fourdp
4863 : : type(MPI_type),intent(in) :: MPI_enreg
4864 : : !arrays
4865 : : integer,intent(in) :: ngfft(18)
4866 : : complex(gwp),intent(inout) :: matrix(nfft,nfft)
4867 : :
4868 : : !Local variables-------------------------------
4869 : : !scalars
4870 : : !integer,parameter :: cplex=2
4871 : : integer :: i1,i2,i3,ifft, n1,n2,n3
4872 : : !arrays
4873 : 0 : real(dp),allocatable :: fofg(:,:),fofr(:)
4874 : : ! *************************************************************************
4875 : :
4876 : : ! TODO check normalization factor, it is better if we use the GW conventions.
4877 : 0 : n1 = ngfft(1)
4878 : 0 : n2 = ngfft(2)
4879 : 0 : n3 = ngfft(3)
4880 : :
4881 [ # # # # : 0 : ABI_MALLOC(fofg,(2,nfft))
# # # # #
# # # ]
4882 [ # # # # : 0 : ABI_MALLOC(fofr,(cplex*nfft))
# # # # #
# # # ]
4883 : :
4884 [ # # ]: 0 : do i3=0,n3-1
4885 [ # # ]: 0 : do i2=0,n2-1
4886 [ # # ]: 0 : do i1=0,n1-1
4887 : :
4888 : 0 : ifft=1+i1+i2*n1+i3*n1*n2
4889 [ # # ]: 0 : if (isign==1) then
4890 : : ! G1 -> r1 transform for each G2 to form A(r1,G2)
4891 [ # # ]: 0 : fofg(1,:)=REAL (matrix(:,ifft))
4892 [ # # ]: 0 : fofg(2,:)=AIMAG(matrix(:,ifft))
4893 [ # # ]: 0 : else if (isign==-1) then
4894 : : ! r1 -> G1 transform for each r2 to form A(G1,r2)
4895 [ # # ]: 0 : fofr(1:nfft) =REAL (matrix(:,ifft))
4896 [ # # ]: 0 : fofr(nfft+1:2*nfft)=AIMAG(matrix(:,ifft))
4897 : : else
4898 : 0 : ABI_ERROR("Wrong isign")
4899 : : end if
4900 : :
4901 : 0 : call fourdp(cplex,fofg,fofr,isign,MPI_enreg,nfft,1,ngfft,tim_fourdp)
4902 : :
4903 [ # # ]: 0 : if (isign==1) then
4904 : : ! Save A(r1,G2)
4905 [ # # ]: 0 : matrix(:,ifft)=CMPLX(fofr(1:nfft),fofr(nfft+1:2*nfft))
4906 [ # # ]: 0 : else if (isign==-1) then
4907 : : ! Save A(G1,r2)
4908 [ # # ]: 0 : matrix(:,ifft)=CMPLX(fofg(1,:),fofg(2,:))
4909 : : end if
4910 : :
4911 : : end do
4912 : : end do
4913 : : end do
4914 : :
4915 [ # # ]: 0 : do i3=0,n3-1
4916 [ # # ]: 0 : do i2=0,n2-1
4917 [ # # ]: 0 : do i1=0,n1-1
4918 : :
4919 : 0 : ifft=1+i1+i2*n1+i3*n1*n2
4920 [ # # ]: 0 : if (isign==1) then
4921 : : ! Do the G2 -> r2 transform of A(r1,G2) to get A(r1,r2)
4922 [ # # ]: 0 : fofr(1:nfft )=REAL (matrix(ifft,:))
4923 [ # # ]: 0 : fofr(nfft+1:2*nfft)=AIMAG(matrix(ifft,:))
4924 [ # # ]: 0 : else if (isign==-1) then
4925 : : ! Do the r2 -> G2 transform of A(G1,r2) to get A(G1,G2)
4926 [ # # ]: 0 : fofg(1,:)=REAL (matrix(ifft,:))
4927 [ # # ]: 0 : fofg(2,:)=AIMAG(matrix(ifft,:))
4928 : : end if
4929 : :
4930 : 0 : call fourdp(2,fofg,fofr,-isign,MPI_enreg,nfft,1,ngfft,tim_fourdp)
4931 : :
4932 [ # # ]: 0 : if (isign==1) then
4933 [ # # ]: 0 : matrix(ifft,:)=CMPLX(fofg(1,:),fofg(2,:))
4934 [ # # ]: 0 : else if (isign==-1) then
4935 [ # # ]: 0 : matrix(ifft,:)=CMPLX(fofr(1:nfft),fofr(nfft+1:2*nfft))
4936 : : end if
4937 : :
4938 : : end do
4939 : : end do
4940 : : end do
4941 : :
4942 [ # # ]: 0 : ABI_FREE(fofg)
4943 [ # # ]: 0 : ABI_FREE(fofr)
4944 : :
4945 : 0 : end subroutine fourdp_6d
4946 : : !!***
4947 : :
4948 : : !!****f* m_fft/fftpac
4949 : : !! NAME
4950 : : !! fftpac
4951 : : !!
4952 : : !! FUNCTION
4953 : : !! Allow for data copying to modify the stride (dimensioning) of a three-dimensional array,
4954 : : !! for more efficient three dimensional fft.
4955 : : !! NOTE that the arrays are in REAL space.
4956 : : !!
4957 : : !! Note that arrays aa and bb may be the same array (start at the same address).
4958 : : !! The array aa also incorporate a spin variable.
4959 : : !! MG FIXME: THIS IS **VERY BAD** AS FORTRAN DOES NOT ALLOW FOR ALIASING
4960 : : !!
4961 : : !! INPUTS
4962 : : !! ispden=actual spin-density of interest
4963 : : !! nspden=number of spin-density components
4964 : : !! n1,n2,n3=actual data dimensions, dimensions of complex array a
4965 : : !! nd1,nd2,nd3=array dimensions of (larger) array b
4966 : : !! ngfft(18)=contain all needed information about 3D FFT, see ~abinit/doc/variables/vargs.htm#ngfft
4967 : : !! option= see description of side effects
4968 : : !!
4969 : : !! SIDE EFFECTS
4970 : : !! aa & bb arrays are treated as input or output depending on option:
4971 : : !! option=1 aa(n1*n2*n3,ispden) <-- bb(nd1,nd2,nd3) real case
4972 : : !! option=2 aa(n1*n2*n3,ispden) --> bb(nd1,nd2,nd3) real case
4973 : : !! option=10 aa(n1*n2*n3,ispden) <-- bb(nd1,nd2,nd3) complex case like option 1 real part
4974 : : !! option=11 aa(n1*n2*n3,ispden) <-- bb(nd1,nd2,nd3) complex case like option 1 imag part
4975 : : !!
4976 : : !! SOURCE
4977 : :
4978 : 977119 : subroutine fftpac(ispden,mpi_enreg,nspden,n1,n2,n3,nd1,nd2,nd3,ngfft,aa,bb,option)
4979 : :
4980 : : !Arguments ------------------------------------
4981 : : !scalars
4982 : : integer,intent(in) :: ispden,n1,n2,n3,nd1,nd2,nd3,nspden,option
4983 : : type(mpi_type),intent(in) :: mpi_enreg
4984 : : !arrays
4985 : : integer,intent(in) :: ngfft(18)
4986 : : real(dp),intent(inout) :: aa(n1*n2*n3/ngfft(10),nspden),bb(nd1,nd2,nd3)
4987 : :
4988 : : !Local variables-------------------------------
4989 : : !scalars
4990 : : integer :: i1,i2,i3,index,me_fft,nproc_fft
4991 : : character(len=500) :: msg
4992 : : !arrays
4993 : 977119 : integer, contiguous, pointer :: fftn2_distrib(:),ffti2_local(:)
4994 : 977119 : integer, contiguous, pointer :: fftn3_distrib(:),ffti3_local(:)
4995 : : ! *************************************************************************
4996 : :
4997 : 977119 : me_fft=ngfft(11); nproc_fft=ngfft(10)
4998 : :
4999 : 977119 : if (option==1.or.option==2) then
5000 [ + - + - : 977119 : if (nd1<n1.or.nd2<n2.or.nd3<n3) then
- + ]
5001 : : write(msg,'(a,3i0,2a,3i0,a)')&
5002 : 0 : 'Each of nd1,nd2,nd3=',nd1,nd2,nd3,ch10,'must be >= n1, n2, n3 =',n1,n2,n3,'.'
5003 : 0 : ABI_BUG(msg)
5004 : : end if
5005 : : else
5006 [ # # # # : 0 : if (2*nd1<n1.or.nd2<n2.or.nd3<n3) then
# # ]
5007 : : write(msg,'(a,3i0,2a,3i0,a)')&
5008 : 0 : 'Each of 2*nd1,nd2,nd3=',2*nd1,nd2,nd3,ch10,'must be >= (n1, n2, n3) =',n1,n2,n3,'.'
5009 : 0 : ABI_BUG(msg)
5010 : : end if
5011 : : end if
5012 : :
5013 : : ! Get the distrib associated with this fft_grid
5014 : 977119 : call ptabs_fourdp(mpi_enreg,n2,n3,fftn2_distrib,ffti2_local,fftn3_distrib,ffti3_local)
5015 : :
5016 [ + + ]: 977119 : if (option==1) then
5017 : : ! aa(n1*n2*n3,ispden) <-- bb(nd1,nd2,nd3) real case
5018 [ + + ]: 2340803 : do i3=1,n3
5019 [ + + ]: 2340803 : if (me_fft==fftn3_distrib(i3)) then
5020 [ + + ]: 50368607 : do i2=1,n2
5021 [ + + ]: 1478555057 : do i1=1,n1
5022 : 1476371844 : aa(i1+n1*(i2-1+n2*(ffti3_local(i3)-1)),ispden)=bb(i1,i2,i3)
5023 : : end do
5024 : : end do
5025 : : end if
5026 : : end do
5027 : :
5028 [ + - ]: 869409 : else if (option==2) then
5029 : : ! option=2 aa(n1*n2*n3,ispden) --> bb(nd1,nd2,nd3) real case
5030 : : ! Here we avoid corrupting the data in a while writing to b in the
5031 : : ! case in which a and b are same array.
5032 : : ! Also: replace "trash" data with 0 s to avoid floating point
5033 : : ! exceptions when this data is actually manipulated in fft.
5034 [ - + ]: 869409 : do i3=nd3,n3+1,-1
5035 [ - - ]: 869409 : do i2=nd2,1,-1
5036 [ # # ]: 0 : do i1=nd1,1,-1
5037 : 0 : bb(i1,i2,i3)=0.d0
5038 : : end do
5039 : : end do
5040 : : end do
5041 [ + + ]: 15167184 : do i3=n3,1,-1
5042 [ + + ]: 15167184 : if (me_fft==fftn3_distrib(i3)) then
5043 [ + + ]: 20446076 : do i2=nd2,n2+1,-1
5044 [ + + ]: 188534137 : do i1=nd1,1,-1
5045 : 174281246 : bb(i1,i2,i3)=0.d0
5046 : : end do
5047 : : end do
5048 [ + + ]: 261641597 : do i2=n2,1,-1
5049 [ + + ]: 410539963 : do i1=nd1,n1+1,-1
5050 : 410539963 : bb(i1,i2,i3)=0.d0
5051 : : end do
5052 [ + + ]: 7033473986 : do i1=n1,1,-1
5053 : 7019221095 : bb(i1,i2,i3)=aa(i1+n1*(i2-1+n2*(ffti3_local(i3) - 1)),ispden)
5054 : : end do
5055 : : end do
5056 : : end if
5057 : : end do
5058 : : ! MF
5059 [ # # ]: 0 : else if (option==10 .or. option==11) then
5060 : : ! option=10 aa(n1*n2*n3,ispden) <-- bb(nd1,nd2,nd3) complex case like option 1 real part
5061 : : ! option=11 aa(n1*n2*n3,ispden) <-- bb(nd1,nd2,nd3) complex case like option 1 imag part
5062 : 0 : index=1
5063 [ # # ]: 0 : if(option==11) index=2
5064 [ # # ]: 0 : do i3=1,n3
5065 [ # # ]: 0 : do i2=1,n2
5066 [ # # ]: 0 : do i1=1,n1/2
5067 : 0 : aa(index,ispden)=bb(i1,i2,i3)
5068 : 0 : index=index+2
5069 : : end do
5070 : : end do
5071 : : end do
5072 : : ! MF
5073 : : else
5074 : 0 : ABI_BUG(sjoin('Bad option =',itoa(option)))
5075 : : end if
5076 : :
5077 [ + - ]: 977119 : end subroutine fftpac
5078 : : !!***
5079 : :
5080 : : !!****f* m_fft/indirect_parallel_Fourier
5081 : : !! NAME
5082 : : !! indirect_parallel_Fourier
5083 : : !!
5084 : : !! FUNCTION
5085 : : !! The purpose of this routine is to transfer data from right to left right(:,index(i))=left(:,i)
5086 : : !! The difficulty is that right and left are distributed among processors
5087 : : !! We will suppose that the distribution is done as a density in Fourier space
5088 : : !! We first order the right hand side data according to the processor
5089 : : !! in which they are going to be located in the left hand side.
5090 : : !! This is done is a way such that a mpi_alltoall put the data on the correct processor.
5091 : : !! We also transfer their future address. A final ordering put everything in place
5092 : : !!
5093 : : !! INPUTS
5094 : : !! index(sizeindex)= global address for the transfer from right to left
5095 : : !! left(2,nleft)=left hand side
5096 : : !! mpi_enreg=information about MPI parallelization
5097 : : !! ngleft(18)=contain all needed information about 3D FFT for the left hand side
5098 : : !! see ~abinit/doc/variables/vargs.htm#ngfft
5099 : : !! ngright(18)=contain all needed information about 3D FFT for the right hand side
5100 : : !! see ~abinit/doc/variables/vargs.htm#ngfft
5101 : : !! nleft=second dimension of left array (for this processor)
5102 : : !! nright=second dimension of right array (for this processor)
5103 : : !! sizeindex=size of the index array (different form nright, because it is global to all processors)
5104 : : !!
5105 : : !! OUTPUT
5106 : : !! left(2,nleft)=the elements of the right hand side, at the correct place in the correct processor
5107 : : !!
5108 : : !! NOTES
5109 : : !! A lot of things to improve.
5110 : : !!
5111 : : !! SOURCE
5112 : :
5113 : 3396 : subroutine indirect_parallel_Fourier(index,left,mpi_enreg,ngleft,ngright,nleft,nright,paral_kgb,right,sizeindex)
5114 : :
5115 : : !Arguments ---------------------------------------------
5116 : : !scalars
5117 : : integer,intent(in) :: ngleft(18),ngright(18),nleft,nright,paral_kgb,sizeindex
5118 : : type(MPI_type),intent(in) :: mpi_enreg
5119 : : !arrays
5120 : : integer,intent(in) :: index(sizeindex)
5121 : : real(dp),intent(in) :: right(2,nright)
5122 : : real(dp),intent(inout) :: left(2,nleft)
5123 : :
5124 : : !Local variables ---------------------------------------
5125 : : !scalars
5126 : : integer :: ierr,i_global,ileft,iright,iright_global
5127 : : integer :: j,j1,j2,j3,j_global,jleft_global
5128 : : integer :: jleft_local,me_fft,n1l,n2l,n3l,n1r,n2r,n3r,nd2l,nd2r
5129 : : integer :: nproc_fft,proc_dest,r2,siz_slice_max
5130 : : !arrays
5131 : 3396 : integer,allocatable :: index_recv(:),index_send(:),siz_slice(:), ffti2r_global(:)
5132 : 3396 : integer, contiguous, pointer :: fftn2l_distrib(:),ffti2l_local(:)
5133 : 3396 : integer, contiguous, pointer :: fftn3l_distrib(:),ffti3l_local(:)
5134 : 3396 : integer, contiguous, pointer :: fftn2r_distrib(:),ffti2r_local(:)
5135 : 3396 : integer, contiguous, pointer :: fftn3r_distrib(:),ffti3r_local(:)
5136 : 3396 : real(dp),allocatable :: right_send(:,:),right_recv(:,:)
5137 : : ! *************************************************************************
5138 : :
5139 : 3396 : n1r=ngright(1);n2r=ngright(2);n3r=ngright(3)
5140 : 3396 : n1l=ngleft(1) ;n2l=ngleft(2) ;n3l=ngleft(3)
5141 : 3396 : nproc_fft=mpi_enreg%nproc_fft; me_fft=mpi_enreg%me_fft
5142 : 3396 : nd2r=n2r/nproc_fft; nd2l=n2l/nproc_fft
5143 : :
5144 : : !Get the distrib associated with the left fft_grid
5145 : 3396 : call ptabs_fourdp(mpi_enreg,n2l,n3l,fftn2l_distrib,ffti2l_local,fftn3l_distrib,ffti3l_local)
5146 : :
5147 : : !Get the distrib associated with the right fft_grid
5148 : 3396 : call ptabs_fourdp(mpi_enreg,n2r,n3r,fftn2r_distrib,ffti2r_local,fftn3r_distrib,ffti3r_local)
5149 : :
5150 : : !Precompute local --> global corespondance
5151 [ - + + - : 10188 : ABI_MALLOC(ffti2r_global,(nd2r))
+ - + - -
+ - + ]
5152 [ + + ]: 65532 : ffti2r_global(:) = -1
5153 [ + + ]: 129276 : do j2=1,n2r
5154 [ + + ]: 129276 : if( fftn2r_distrib(j2) == me_fft ) then
5155 : 62136 : ffti2r_global( ffti2r_local(j2) ) = j2
5156 : : end if
5157 : : end do
5158 : :
5159 [ - + + - : 10188 : ABI_MALLOC(siz_slice,(nproc_fft))
+ - + - -
+ - + ]
5160 [ + + ]: 10372 : siz_slice(:)=0
5161 [ + + ]: 527424996 : do i_global=1,sizeindex !look for the maximal size of slice of data
5162 : 527421600 : j_global=index(i_global)!; write(std_out,*) j_global,i_global
5163 [ + + ]: 527424996 : if(j_global /=0) then
5164 : : !use the fact that (j-1)=i1 + n1l*(j2l-1 + n2l*(j3l-1))
5165 : 205392064 : proc_dest= fftn2l_distrib( modulo((j_global-1)/n1l,n2l) + 1)
5166 : 205392064 : siz_slice(proc_dest+1)=siz_slice(proc_dest+1)+1
5167 : : !write(std_out,*) 'in indirect proc',proc_dest,siz_slice(proc_dest+1)
5168 : : end if
5169 : : end do
5170 [ + + ]: 10372 : siz_slice_max=maxval(siz_slice) !This value could be made smaller by looking locally
5171 : : !and performing a allgather with a max
5172 : : !write(std_out,*) 'siz_slice,sizeindex,siz_slice',siz_slice(:),sizeindex,siz_slice_max
5173 : : !write(std_out,*) 'sizeindex,nright,nleft',sizeindex,nright,nleft
5174 [ - + + - : 10188 : ABI_MALLOC(right_send,(2,nproc_fft*siz_slice_max))
+ - + - -
+ - + ]
5175 [ - + + - : 10188 : ABI_MALLOC(index_send,(nproc_fft*siz_slice_max))
+ - + - -
+ + - ]
5176 [ + + + + : 831790732 : siz_slice(:)=0; index_send(:)=0; right_send(:,:)=zero
+ + + + ]
5177 [ + + ]: 262395732 : do iright=1,nright
5178 : 262392336 : j=iright-1;j1=modulo(j,n1r);j2=modulo(j/n1r,nd2r);j3=j/(n1r*nd2r)
5179 : 262392336 : j2 = ffti2r_global(j2+1) - 1
5180 : 262392336 : iright_global=n1r*(n2r*j3+j2)+j1+1
5181 : 262392336 : jleft_global=index(iright_global)
5182 [ + + ]: 262395732 : if(jleft_global/=0)then
5183 : 102378080 : j=jleft_global-1;j1=modulo(j,n1l);j2=modulo(j/n1l,n2l);j3=j/(n1l*n2l); r2=ffti2l_local(j2+1)-1
5184 : 102378080 : jleft_local=n1l*(nd2l*j3+r2)+j1+1
5185 : 102378080 : proc_dest=fftn2l_distrib(j2+1)
5186 : 102378080 : siz_slice(proc_dest+1)=siz_slice(proc_dest+1)+1
5187 [ + + ]: 307134240 : right_send(:,proc_dest*siz_slice_max+siz_slice(proc_dest+1))=right(:,iright)
5188 : 102378080 : index_send(proc_dest*siz_slice_max+siz_slice(proc_dest+1))=jleft_local
5189 : : !write(std_out,*) 'loop ir',jleft_local,jleft_global,iright_global,iright
5190 : : end if
5191 : : end do
5192 [ - + + - : 6792 : ABI_MALLOC(right_recv,(2,nproc_fft*siz_slice_max))
- + - + ]
5193 [ - + + - : 6792 : ABI_MALLOC(index_recv,(nproc_fft*siz_slice_max))
- + - + ]
5194 : : #if defined HAVE_MPI
5195 [ + - ]: 3396 : if(paral_kgb == 1) then
5196 : : call mpi_alltoall (right_send,2*siz_slice_max, &
5197 : : MPI_double_precision, &
5198 : : right_recv,2*siz_slice_max, &
5199 : 3396 : MPI_double_precision,mpi_enreg%comm_fft,ierr)
5200 : : call mpi_alltoall (index_send,siz_slice_max, &
5201 : : MPI_integer, &
5202 : : index_recv,siz_slice_max, &
5203 : 3396 : MPI_integer,mpi_enreg%comm_fft,ierr)
5204 : : endif
5205 : : #endif
5206 [ + + ]: 207946788 : do ileft=1,siz_slice_max*nproc_fft
5207 : : !write(std_out,*)index_recv(ileft)
5208 [ + + + + ]: 412702948 : if(index_recv(ileft) /=0 ) left(:,index_recv(ileft))=right_recv(:,ileft)
5209 : : end do
5210 [ - + ]: 3396 : ABI_FREE(right_recv)
5211 [ - + ]: 3396 : ABI_FREE(index_recv)
5212 [ - + ]: 3396 : ABI_FREE(right_send)
5213 [ - + ]: 3396 : ABI_FREE(index_send)
5214 [ - + ]: 3396 : ABI_FREE(siz_slice)
5215 [ - + ]: 3396 : ABI_FREE(ffti2r_global)
5216 : :
5217 : 3396 : end subroutine indirect_parallel_Fourier
5218 : : !!***
5219 : :
5220 : : !!****f* ABINIT/fft_init_counters
5221 : : !! NAME
5222 : : !! fft_init_counters
5223 : : !!
5224 : : !! FUNCTION
5225 : : !!
5226 : : !! SOURCE
5227 : :
5228 : 0 : subroutine fft_init_counters()
5229 : :
5230 : 0 : fourdp_counter = 0
5231 : 0 : fourwf_counter = 0
5232 : :
5233 : 0 : end subroutine fft_init_counters
5234 : : !!***
5235 : :
5236 : : !!****f* ABINIT/fft_stop_counters
5237 : : !! NAME
5238 : : !! fft_stop_counters
5239 : : !!
5240 : : !! FUNCTION
5241 : : !!
5242 : : !! SOURCE
5243 : :
5244 : 0 : subroutine fft_stop_counters()
5245 : :
5246 : 0 : fourdp_counter = -1
5247 : 0 : fourwf_counter = -1
5248 : :
5249 : 0 : end subroutine fft_stop_counters
5250 : : !!***
5251 : :
5252 : : !!****f* ABINIT/fft_output_counters
5253 : : !! NAME
5254 : : !! fft_output_counters
5255 : : !!
5256 : : !! FUNCTION
5257 : : !!
5258 : : !! SOURCE
5259 : :
5260 : 0 : subroutine fft_output_counters(nbandtot, mpi_enreg)
5261 : :
5262 : : !Arguments ------------------------------------
5263 : : integer,intent(in) :: nbandtot
5264 : : type(MPI_type),intent(in) :: mpi_enreg
5265 : :
5266 : : !Local variables-------------------------------
5267 : : !scalars
5268 : : character(len=500) :: msg
5269 : : integer :: cnt,ierr, units(2)
5270 : : ! *************************************************************************
5271 : :
5272 [ # # ]: 0 : units = [std_out, ab_out]
5273 : :
5274 : 0 : call wrtout(units,'')
5275 : 0 : write(msg,'(a)') ' --- FFT COUNTERS ------------------------------------------------------------'
5276 : 0 : call wrtout(units, msg)
5277 : 0 : write(msg,'(a,i6)') ' total Number of Bands : NB = ',nbandtot
5278 : 0 : call wrtout(units, msg)
5279 : 0 : write(msg,'(a)') ' | total count (TC) | TC/NB'
5280 : 0 : call wrtout(units, msg)
5281 : 0 : write(msg,'(a)') ' -----------------------------------------------------------------------------'
5282 : 0 : call wrtout(units, msg)
5283 : 0 : call xmpi_sum(fourwf_counter,mpi_enreg%comm_kpt,ierr)
5284 : 0 : cnt=fourdp_counter
5285 [ # # ]: 0 : if (cnt>0) then
5286 : 0 : write(msg,'(a,i16,a)') '_fourdp | ',cnt,' |'
5287 : 0 : call wrtout(units, msg)
5288 : : end if
5289 : 0 : cnt=fourwf_counter
5290 [ # # ]: 0 : if (cnt>0) then
5291 : 0 : write(msg,'(a,i16,a,f16.1)') '_fourwf | ',cnt,' | ',dble(cnt)/nbandtot
5292 : 0 : call wrtout(units, msg)
5293 : : end if
5294 : 0 : write(msg,'(a)') ' -----------------------------------------------------------------------------'
5295 : 0 : call wrtout(units, msg)
5296 : :
5297 : 0 : end subroutine fft_output_counters
5298 : : !!***
5299 : :
5300 : : !----------------------------------------------------------------------
5301 : :
5302 : : !!****f* m_fft/uplan_init
5303 : : !! NAME
5304 : : !! uplan_init
5305 : : !!
5306 : : !! FUNCTION
5307 : : !! Initialize the plan
5308 : : !!
5309 : : !! INPUTS
5310 : : !!
5311 : : !! SOURCE
5312 : :
5313 : 0 : subroutine uplan_init(uplan, npw, nspinor, batch_size, ngfft, istwfk, kg_k, kind, gpu_option)
5314 : :
5315 : : !Arguments ------------------------------------
5316 : : !scalars
5317 : : class(uplan_t),target,intent(out) :: uplan
5318 : : integer,intent(in) :: npw, nspinor, batch_size, istwfk, kind, gpu_option
5319 : : !Local variables-------------------------------
5320 : : integer :: ig, ig1, ig2, ig3, n1, n2, n3, ifft
5321 : : !arrays
5322 : : integer,intent(in) :: ngfft(18)
5323 : : integer,target,intent(in) :: kg_k(3,npw)
5324 : 0 : integer, contiguous, pointer :: ig2ifft(:), ifft2ig(:)
5325 : : ! *************************************************************************
5326 : :
5327 : 0 : uplan%npw = npw
5328 : 0 : uplan%nspinor = nspinor
5329 : 0 : uplan%istwfk = istwfk
5330 : 0 : uplan%batch_size = batch_size
5331 : 0 : uplan%kind = kind
5332 : 0 : uplan%gpu_option = gpu_option
5333 [ # # ]: 0 : uplan%ngfft = ngfft
5334 [ # # ]: 0 : uplan%mgfft = maxval(ngfft(1:3))
5335 [ # # ]: 0 : uplan%nfft = product(ngfft(1:3))
5336 : 0 : uplan%kg_k => kg_k
5337 : :
5338 [ # # # # : 0 : ABI_MALLOC(uplan%gbound, (2 * uplan%mgfft + 8, 2))
# # # # #
# # # # #
# # # # ]
5339 [ # # # # : 0 : call sphereboundary(uplan%gbound, uplan%istwfk, uplan%kg_k, uplan%mgfft, int(uplan%npw))
# # # # #
# ]
5340 : :
5341 : 0 : uplan%gpu_ctx_spc = c_null_ptr; uplan%gpu_ctx_dpc = c_null_ptr
5342 : :
5343 [ # # ]: 0 : if (uplan%gpu_option == ABI_GPU_OPENMP) then
5344 [ # # ]: 0 : ABI_CHECK_IEQ(istwfk, 1, "istwfk /= 1 not supported with GPUs")
5345 [ # # # # : 0 : if (any(ngfft(1:3) /= ngfft(4:6))) then
# # ]
5346 : 0 : ABI_ERROR("FFTs on GPUs with fftbox_plan3 do not support dims != embed")
5347 : : end if
5348 : :
5349 [ # # # # : 0 : ABI_MALLOC(uplan%ig2ifft, (uplan%npw))
# # # # #
# # # #
# ]
5350 [ # # # # : 0 : ABI_ICALLOC(uplan%ifft2ig, (uplan%nfft))
# # # # #
# # # # #
# # ]
5351 : :
5352 : 0 : n1 = ngfft(1); n2 = ngfft(2); n3 = ngfft(3)
5353 [ # # ]: 0 : do ig=1,uplan%npw
5354 : 0 : ig1 = modulo(kg_k(1, ig), n1)
5355 : 0 : ig2 = modulo(kg_k(2, ig), n2)
5356 : 0 : ig3 = modulo(kg_k(3, ig), n3)
5357 : 0 : ifft = 1 + ig1 + n1*(ig2+ig3*n2)
5358 : 0 : uplan%ig2ifft(ig) = ifft
5359 : 0 : uplan%ifft2ig(ifft) = ig
5360 : : end do
5361 : :
5362 : : ! Map data to GPU.
5363 : 0 : ig2ifft => uplan%ig2ifft; ifft2ig => uplan%ifft2ig
5364 : : #ifdef HAVE_OPENMP_OFFLOAD
5365 : : !$OMP TARGET ENTER DATA MAP(to:ig2ifft, ifft2ig)
5366 : : #endif
5367 : : end if
5368 : :
5369 [ # # ]: 0 : end subroutine uplan_init
5370 : : !!***
5371 : :
5372 : : !----------------------------------------------------------------------
5373 : :
5374 : : !!****f* m_fft/uplan_free
5375 : : !! NAME
5376 : : !! uplan_free
5377 : : !!
5378 : : !! FUNCTION
5379 : : !! Free dynamic memory.
5380 : : !!
5381 : : !! SOURCE
5382 : :
5383 : 0 : subroutine uplan_free(uplan)
5384 : :
5385 : : !Arguments ------------------------------------
5386 : : class(uplan_t),target,intent(inout) :: uplan
5387 : :
5388 : : !Local variables-------------------------------
5389 : 0 : integer, contiguous, pointer :: ig2ifft(:), ifft2ig(:)
5390 : : ! *************************************************************************
5391 : :
5392 : 0 : ABI_SFREE(uplan%gbound)
5393 : :
5394 : 0 : if (uplan%gpu_option == ABI_GPU_OPENMP) then
5395 : : ! Free memory on the GPU
5396 : : ig2ifft => uplan%ig2ifft; ifft2ig => uplan%ifft2ig
5397 : : #if defined HAVE_GPU_CUDA && defined HAVE_OPENMP_OFFLOAD
5398 : : call gpu_ctx_free(uplan%gpu_ctx_spc)
5399 : : call gpu_ctx_free(uplan%gpu_ctx_dpc)
5400 : : !$OMP TARGET EXIT DATA MAP(delete:ig2ifft, ifft2ig)
5401 : : #endif
5402 : : end if
5403 : :
5404 [ # # ]: 0 : ABI_SFREE(uplan%ig2ifft)
5405 [ # # ]: 0 : ABI_SFREE(uplan%ifft2ig)
5406 : :
5407 [ # # ]: 0 : end subroutine uplan_free
5408 : : !!***
5409 : :
5410 : : !----------------------------------------------------------------------
5411 : :
5412 : : !!****f* m_fft/uplan_execute_gr_spc
5413 : : !! NAME
5414 : : !! uplan_execute_gr_spc
5415 : : !!
5416 : : !! FUNCTION
5417 : : !!
5418 : : !! INPUTS
5419 : : !!
5420 : : !! SOURCE
5421 : :
5422 : 0 : subroutine uplan_execute_gr_spc(uplan, ndat, ug, ur, &
5423 : : isign, iscale, gpu_mode, phase_r) ! optional
5424 : :
5425 : : !Arguments ------------------------------------
5426 : : class(uplan_t),target,intent(inout) :: uplan
5427 : : integer,intent(in) :: ndat
5428 : : complex(sp),target,intent(in) :: ug(uplan%npw*uplan%nspinor*ndat)
5429 : : complex(sp),target,intent(out) :: ur(uplan%nfft*uplan%nspinor*ndat)
5430 : : integer,optional,intent(in) :: isign, iscale, gpu_mode
5431 : : complex(sp),optional,intent(in) :: phase_r(uplan%nfft*uplan%nspinor)
5432 : :
5433 : : !Local variables-------------------------------
5434 : : integer :: isign__, iscale__, nx, ny, nz, ldx, ldy, ldz, fftalg, fftalga, fftalgc, fftcache, nspinor, npw, nfft, gpu_mode__
5435 : : integer(c_size_t) :: idat, ir, offset, bufsize
5436 : : #if defined HAVE_GPU_CUDA && defined HAVE_OPENMP_OFFLOAD
5437 : : integer(c_size_t) :: ispinor, ipw, ifft, ig
5438 : : logical :: transfer_ug, transfer_ur
5439 : : integer, contiguous, pointer :: ig2ifft(:)
5440 : : #endif
5441 : : ! *************************************************************************
5442 : :
5443 : : !call wrtout(std_out, "in uplan_execute_gr_spc")
5444 [ # # ]: 0 : ABI_CHECK_IEQ(sp, uplan%kind, "Inconsistent kind!")
5445 : :
5446 : 0 : ABI_DEFAULT(gpu_mode__, gpu_mode, 0)
5447 : :
5448 [ # # ]: 0 : isign__ = +1; if (present(isign)) isign__ = isign
5449 [ # # ]: 0 : iscale__ = 0; if (present(iscale)) iscale__ = iscale
5450 : :
5451 : 0 : fftalg = uplan%ngfft(7); fftcache = uplan%ngfft(8); fftalga = fftalg/100; fftalgc = mod(fftalg, 10)
5452 : 0 : nx = uplan%ngfft(1); ny = uplan%ngfft(2); nz = uplan%ngfft(3)
5453 : 0 : ldx = nx; ldy = ny; ldz = nz ! No augmentation, the caller does not support it.
5454 : :
5455 : : ! NVHPC does not reliably support mapping derived_type components
5456 : 0 : nspinor = uplan%nspinor; npw = uplan%npw; nfft = uplan%nfft
5457 : :
5458 [ # # ]: 0 : if (uplan%gpu_option == ABI_GPU_DISABLED) then
5459 : 0 : select case (fftalga)
5460 : : case (FFT_FFTW3)
5461 : : call fftw3_fftug(fftalg, fftcache, int(uplan%npw), nx, ny, nz, ldx, ldy, ldz, uplan%nspinor*ndat, &
5462 : : uplan%istwfk, uplan%mgfft, uplan%kg_k, uplan%gbound, ug, ur, &
5463 [ # # # # : 0 : isign=isign__, iscale=iscale__)
# # # # #
# ]
5464 : : case (FFT_DFTI)
5465 : : call dfti_fftug(fftalg, fftcache, int(uplan%npw), nx, ny, nz, ldx, ldy, ldz, uplan%nspinor*ndat, &
5466 : : uplan%istwfk, uplan%mgfft, uplan%kg_k, uplan%gbound, ug, ur, &
5467 [ # # # # : 0 : isign=isign__, iscale=iscale__)
# # # # #
# ]
5468 : : case default
5469 [ # # # ]: 0 : ABI_ERROR(sjoin("Wrong fftalga:", itoa(fftalga)))
5470 : : end select
5471 : :
5472 : : ! Multiply by e^{ik.r}
5473 [ # # ]: 0 : if (present(phase_r)) then
5474 : 0 : bufsize = int(nfft, c_size_t) * nspinor
5475 : : !$OMP PARALLEL DO PRIVATE(offset) IF (ndat > 1)
5476 [ # # ]: 0 : do idat=1,ndat
5477 : 0 : offset = (idat - 1) * bufsize
5478 [ # # ]: 0 : do ir=1,bufsize
5479 : 0 : ur(offset + ir) = ur(offset + ir) * phase_r(ir)
5480 : : end do
5481 : : end do
5482 : : end if
5483 : :
5484 : : else
5485 : : #if defined HAVE_GPU_CUDA && defined HAVE_OPENMP_OFFLOAD
5486 : : ! Build plan if not yet done. note batch_size instead of ndat.
5487 : : if (.not. c_associated(uplan%gpu_ctx_spc)) then
5488 : : !call wrtout(std_out, sjoin("gr: Init plan with batch_size:", itoa(uplan%batch_size)))
5489 : : call gpu_ctx_init(uplan%gpu_ctx_spc, uplan%ngfft, uplan%ngfft, uplan%batch_size, sp)
5490 : : end if
5491 : :
5492 : : if (ndat /= uplan%batch_size) then
5493 : : ! Have to rebuild the plan with batch_size == ndat.
5494 : : !call wrtout(std_out, sjoin("gr: Init plan with ndat:", itoa(ndat)))
5495 : : call gpu_ctx_free(uplan%gpu_ctx_spc)
5496 : : call gpu_ctx_init(uplan%gpu_ctx_spc, uplan%ngfft, uplan%ngfft, ndat, sp)
5497 : : end if
5498 : :
5499 : : uplan%batch_size = ndat
5500 : :
5501 : : transfer_ug = .False.; transfer_ur = .False.
5502 : : if (gpu_mode__ /= 0) then
5503 : : transfer_ug = .not. xomp_target_is_present(c_loc(ug))
5504 : : transfer_ur = .not. xomp_target_is_present(c_loc(ur))
5505 : : !$OMP TARGET ENTER DATA MAP(alloc:ug) IF (transfer_ug)
5506 : : !$OMP TARGET UPDATE TO(ug) IF (transfer_ug)
5507 : : !$OMP TARGET ENTER DATA MAP(alloc:ur) IF (transfer_ur)
5508 : : end if
5509 : :
5510 : : bufsize = uplan%nfft * uplan%nspinor * ndat
5511 : : call gpu_set_to_zero_complex_sp(ur, bufsize)
5512 : :
5513 : : ig2ifft => uplan%ig2ifft
5514 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO PRIVATE(ifft, offset, ir, ig) COLLAPSE(3) MAP(to:ug, ig2ifft)
5515 : : do idat=1,ndat
5516 : : do ispinor=1,nspinor
5517 : : do ipw=1,npw
5518 : : ifft = ig2ifft(ipw)
5519 : : offset = (idat-1) * nspinor + (ispinor-1)
5520 : : ir = ifft + nfft * offset
5521 : : ig = ipw + npw * offset
5522 : : ur(ir) = ug(ig)
5523 : : end do ! ipw
5524 : : end do ! ispinor
5525 : : end do ! idat
5526 : :
5527 : : !$OMP TARGET DATA USE_DEVICE_ADDR(ur)
5528 : : call gpu_fftbox_c2c_ip(uplan%gpu_ctx_spc, int(uplan%nfft), ndat, isign__, iscale__, sp, c_loc(ur))
5529 : : call gpu_ctx_synch(uplan%gpu_ctx_spc)
5530 : : !$OMP END TARGET DATA
5531 : :
5532 : : ! Multiply by e^{ik.r}
5533 : : if (present(phase_r)) then
5534 : : bufsize = int(nfft, c_size_t) * nspinor
5535 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO PRIVATE(offset) COLLAPSE(2) MAP(to:ur, phase_r)
5536 : : do idat=1,ndat
5537 : : do ir=1,bufsize
5538 : : offset = (idat - 1) * bufsize
5539 : : ur(offset + ir) = ur(offset + ir) * phase_r(ir)
5540 : : end do
5541 : : end do
5542 : : end if
5543 : :
5544 : : if (gpu_mode__ /= 0) then
5545 : : !$OMP TARGET EXIT DATA MAP(delete:ug) IF (transfer_ug)
5546 : : !$OMP TARGET UPDATE FROM(ur) IF (transfer_ur)
5547 : : !$OMP TARGET EXIT DATA MAP(delete:ur) IF (transfer_ur)
5548 : : end if
5549 : : #endif
5550 : : end if
5551 : :
5552 : 0 : end subroutine uplan_execute_gr_spc
5553 : : !!***
5554 : :
5555 : : !----------------------------------------------------------------------
5556 : :
5557 : : !!****f* m_fft/uplan_execute_gr_dpc
5558 : : !! NAME
5559 : : !! uplan_execute_gr_dpc
5560 : : !!
5561 : : !! FUNCTION
5562 : : !!
5563 : : !! INPUTS
5564 : : !!
5565 : : !! SOURCE
5566 : :
5567 : 0 : subroutine uplan_execute_gr_dpc(uplan, ndat, ug, ur, &
5568 : : isign, iscale, gpu_mode, phase_r) ! optional
5569 : :
5570 : : !Arguments ------------------------------------
5571 : : class(uplan_t),target,intent(inout) :: uplan
5572 : : integer,intent(in) :: ndat
5573 : : complex(dp),target,intent(in) :: ug(uplan%npw*uplan%nspinor*ndat)
5574 : : complex(dp),target,intent(out) :: ur(uplan%nfft*uplan%nspinor*ndat)
5575 : : integer,optional,intent(in) :: isign, iscale, gpu_mode
5576 : : complex(dp),optional,intent(in) :: phase_r(uplan%nfft*uplan%nspinor)
5577 : :
5578 : : !Local variables-------------------------------
5579 : : integer :: isign__, iscale__, nx, ny, nz, ldx, ldy, ldz, fftalg, fftalga, fftalgc, fftcache, nspinor, npw, nfft, gpu_mode__
5580 : : integer(c_size_t) :: idat, ir, offset, bufsize
5581 : : #if defined HAVE_GPU_CUDA && defined HAVE_OPENMP_OFFLOAD
5582 : : integer(c_size_t) :: ispinor, ipw, ifft, ig
5583 : : logical :: transfer_ug, transfer_ur
5584 : : integer, contiguous, pointer :: ig2ifft(:)
5585 : : #endif
5586 : : ! *************************************************************************
5587 : :
5588 : : !call wrtout(std_out, "in uplan_execute_gr_dpc")
5589 [ # # ]: 0 : ABI_CHECK_IEQ(dp, uplan%kind, "Inconsistent kind!")
5590 : :
5591 : 0 : ABI_DEFAULT(gpu_mode__, gpu_mode, 0)
5592 : :
5593 [ # # ]: 0 : isign__ = +1; if (present(isign)) isign__ = isign
5594 [ # # ]: 0 : iscale__ = 0; if (present(iscale)) iscale__ = iscale
5595 : :
5596 : 0 : fftalg = uplan%ngfft(7); fftcache = uplan%ngfft(8); fftalga = fftalg/100; fftalgc = mod(fftalg, 10)
5597 : 0 : nx = uplan%ngfft(1); ny = uplan%ngfft(2); nz = uplan%ngfft(3)
5598 : 0 : ldx = nx; ldy = ny; ldz = nz ! No augmentation, the caller does not support it.
5599 : :
5600 : : ! NVHPC does not reliably support mapping derived_type components
5601 : 0 : nspinor = uplan%nspinor; npw = uplan%npw; nfft = uplan%nfft
5602 : :
5603 [ # # ]: 0 : if (uplan%gpu_option == ABI_GPU_DISABLED) then
5604 : 0 : select case (fftalga)
5605 : : case (FFT_FFTW3)
5606 : : call fftw3_fftug(fftalg, fftcache, int(uplan%npw), nx, ny, nz, ldx, ldy, ldz, uplan%nspinor*ndat, &
5607 : : uplan%istwfk, uplan%mgfft, uplan%kg_k, uplan%gbound, ug, ur, &
5608 [ # # # # : 0 : isign=isign__, iscale=iscale__)
# # # # #
# ]
5609 : : case (FFT_DFTI)
5610 : : call dfti_fftug(fftalg, fftcache, int(uplan%npw), nx, ny, nz, ldx, ldy, ldz, uplan%nspinor*ndat, &
5611 : : uplan%istwfk, uplan%mgfft, uplan%kg_k, uplan%gbound, ug, ur, &
5612 [ # # # # : 0 : isign=isign__, iscale=iscale__)
# # # # #
# ]
5613 : : case default
5614 [ # # # ]: 0 : ABI_ERROR(sjoin("Wrong fftalga:", itoa(fftalga)))
5615 : : end select
5616 : :
5617 : : ! Multiply by e^{ik.r}
5618 [ # # ]: 0 : if (present(phase_r)) then
5619 : 0 : bufsize = int(nfft, c_size_t) * nspinor
5620 : : !$OMP PARALLEL DO PRIVATE(offset) IF (ndat > 1)
5621 [ # # ]: 0 : do idat=1,ndat
5622 : 0 : offset = (idat - 1) * bufsize
5623 [ # # ]: 0 : do ir=1,bufsize
5624 : 0 : ur(offset + ir) = ur(offset + ir) * phase_r(ir)
5625 : : end do
5626 : : end do
5627 : : end if
5628 : :
5629 : : else
5630 : : #if defined HAVE_GPU_CUDA && defined HAVE_OPENMP_OFFLOAD
5631 : : ! Build plan if not yet done. note batch_size instead of ndat.
5632 : : if (.not. c_associated(uplan%gpu_ctx_dpc)) then
5633 : : call gpu_ctx_init(uplan%gpu_ctx_dpc, uplan%ngfft, uplan%ngfft, uplan%batch_size, dp)
5634 : : end if
5635 : :
5636 : : if (ndat /= uplan%batch_size) then
5637 : : ! Have to rebuild the plan with batch_size == ndat.
5638 : : call gpu_ctx_free(uplan%gpu_ctx_dpc)
5639 : : call gpu_ctx_init(uplan%gpu_ctx_dpc, uplan%ngfft, uplan%ngfft, ndat, dp)
5640 : : end if
5641 : :
5642 : : uplan%batch_size = ndat
5643 : :
5644 : : transfer_ug = .False.; transfer_ur = .False.
5645 : : if (gpu_mode__ /= 0) then
5646 : : transfer_ug = .not. xomp_target_is_present(c_loc(ug))
5647 : : transfer_ur = .not. xomp_target_is_present(c_loc(ur))
5648 : : !$OMP TARGET ENTER DATA MAP(alloc:ug) IF (transfer_ug)
5649 : : !$OMP TARGET UPDATE TO(ug) IF (transfer_ug)
5650 : : !$OMP TARGET ENTER DATA MAP(alloc:ur) IF (transfer_ur)
5651 : : end if
5652 : :
5653 : : bufsize = uplan%nfft * uplan%nspinor * ndat
5654 : : call gpu_set_to_zero_complex(ur, bufsize)
5655 : :
5656 : : ig2ifft => uplan%ig2ifft
5657 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO PRIVATE(ifft, offset, ir, ig) COLLAPSE(3) MAP(to:ug, ig2ifft)
5658 : : do idat=1,ndat
5659 : : do ispinor=1,nspinor
5660 : : do ipw=1,npw
5661 : : ifft = ig2ifft(ipw)
5662 : : offset = (idat-1) * nspinor + (ispinor-1)
5663 : : ir = ifft + nfft * offset
5664 : : ig = ipw + npw * offset
5665 : : ur(ir) = ug(ig)
5666 : : end do ! ipw
5667 : : end do ! ispinor
5668 : : end do ! idat
5669 : :
5670 : : !$OMP TARGET DATA USE_DEVICE_ADDR(ur)
5671 : : call gpu_fftbox_c2c_ip(uplan%gpu_ctx_dpc, int(uplan%nfft), ndat, isign__, iscale__, dp, c_loc(ur))
5672 : : call gpu_ctx_synch(uplan%gpu_ctx_dpc)
5673 : : !$OMP END TARGET DATA
5674 : :
5675 : : ! Multiply by e^{ik.r}
5676 : : if (present(phase_r)) then
5677 : : bufsize = int(nfft, c_size_t) * nspinor
5678 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO PRIVATE(offset) COLLAPSE(2) MAP(to:ur, phase_r)
5679 : : do idat=1,ndat
5680 : : do ir=1,bufsize
5681 : : offset = (idat - 1) * bufsize
5682 : : ur(offset + ir) = ur(offset + ir) * phase_r(ir)
5683 : : end do
5684 : : end do
5685 : : end if
5686 : :
5687 : : if (gpu_mode__ /= 0) then
5688 : : !$OMP TARGET EXIT DATA MAP(delete:ug) IF (transfer_ug)
5689 : : !$OMP TARGET UPDATE FROM(ur) IF (transfer_ur)
5690 : : !$OMP TARGET EXIT DATA MAP(delete:ur) IF (transfer_ur)
5691 : : end if
5692 : : #endif
5693 : : end if
5694 : :
5695 : 0 : end subroutine uplan_execute_gr_dpc
5696 : : !!***
5697 : :
5698 : : !----------------------------------------------------------------------
5699 : :
5700 : : !!****f* m_fft/uplan_execute_rg_spc
5701 : : !! NAME
5702 : : !! uplan_execute_rg_spc
5703 : : !!
5704 : : !! FUNCTION
5705 : : !!
5706 : : !! INPUTS
5707 : : !!
5708 : : !! SOURCE
5709 : :
5710 : 0 : subroutine uplan_execute_rg_spc(uplan, ndat, ur, ug, &
5711 : : isign, iscale, gpu_mode, phase_r) ! optional
5712 : :
5713 : : !Arguments ------------------------------------
5714 : : class(uplan_t),target,intent(inout) :: uplan
5715 : : integer,intent(in) :: ndat
5716 : : complex(sp),target,intent(inout) :: ur(uplan%nfft*uplan%nspinor*ndat)
5717 : : complex(sp),target,intent(out) :: ug(uplan%npw*uplan%nspinor*ndat)
5718 : : integer,optional,intent(in) :: isign, iscale, gpu_mode
5719 : : complex(sp),optional,intent(in) :: phase_r(uplan%nfft*uplan%nspinor)
5720 : :
5721 : : !Local variables-------------------------------
5722 : : integer :: isign__, iscale__, nx, ny, nz, ldx, ldy, ldz, fftalg, fftalga, fftalgc, fftcache, nspinor, npw, gpu_mode__, nfft
5723 : : integer(c_size_t) :: idat, ir, offset, bufsize
5724 : : #if defined HAVE_GPU_CUDA && defined HAVE_OPENMP_OFFLOAD
5725 : : logical :: transfer_ug, transfer_ur
5726 : : integer(c_size_t) :: ifft, ig, ispinor, ipw
5727 : : integer, contiguous, pointer :: ifft2ig(:)
5728 : : #endif
5729 : : ! *************************************************************************
5730 : :
5731 : : !call wrtout(std_out, "in uplan_execute_rg_spc")
5732 [ # # ]: 0 : ABI_CHECK_IEQ(sp, uplan%kind, "Inconsistent kind!")
5733 : :
5734 : 0 : ABI_DEFAULT(gpu_mode__, gpu_mode, 0)
5735 : :
5736 [ # # ]: 0 : isign__ = -1; if (present(isign)) isign__ = isign
5737 [ # # ]: 0 : iscale__ = 1; if (present(iscale)) iscale__ = iscale
5738 : :
5739 : 0 : fftalg = uplan%ngfft(7); fftcache = uplan%ngfft(8); fftalga = fftalg/100; fftalgc = mod(fftalg, 10)
5740 : 0 : nx = uplan%ngfft(1); ny = uplan%ngfft(2); nz = uplan%ngfft(3)
5741 : 0 : ldx = nx; ldy = ny; ldz = nz ! No augmentation, the caller does not support it.
5742 : :
5743 : : ! NVHPC does not reliably support mapping derived_type components
5744 : 0 : nspinor = uplan%nspinor; npw = uplan%npw; nfft = uplan%nfft
5745 : :
5746 [ # # ]: 0 : if (uplan%gpu_option == ABI_GPU_DISABLED) then
5747 : : ! Multiply by e^{ik.r}
5748 [ # # ]: 0 : if (present(phase_r)) then
5749 : 0 : bufsize = int(nfft, c_size_t) * nspinor
5750 : : !$OMP PARALLEL DO PRIVATE(offset) IF (ndat > 1)
5751 [ # # ]: 0 : do idat=1,ndat
5752 : 0 : offset = (idat - 1) * bufsize
5753 [ # # ]: 0 : do ir=1,bufsize
5754 : 0 : ur(offset + ir) = ur(offset + ir) * phase_r(ir)
5755 : : end do
5756 : : end do
5757 : : end if
5758 : :
5759 : 0 : select case (fftalga)
5760 : : case (FFT_FFTW3)
5761 : : call fftw3_fftur(fftalg, fftcache, int(uplan%npw), nx, ny, nz, ldx, ldy, ldz, uplan%nspinor*ndat, uplan%istwfk, uplan%mgfft, &
5762 [ # # # # : 0 : uplan%kg_k, uplan%gbound, ur, ug, isign=isign__, iscale=iscale__)
# # # # #
# ]
5763 : : case (FFT_DFTI)
5764 : : call dfti_fftur(fftalg, fftcache, int(uplan%npw), nx, ny, nz, ldx, ldy, ldz, uplan%nspinor*ndat, uplan%istwfk, uplan%mgfft, &
5765 [ # # # # : 0 : uplan%kg_k, uplan%gbound, ur, ug, isign=isign__, iscale=iscale__)
# # # # #
# ]
5766 : : case default
5767 [ # # # ]: 0 : ABI_ERROR(sjoin("Wrong fftalga:", itoa(fftalga)))
5768 : : end select
5769 : :
5770 : : else
5771 : : #if defined HAVE_GPU_CUDA && defined HAVE_OPENMP_OFFLOAD
5772 : : ! Build plan if not yet done. note batch_size instead of ndat.
5773 : : if (.not. c_associated(uplan%gpu_ctx_spc)) then
5774 : : !call wrtout(std_out, sjoin("rg: Init plan with batch_size:", itoa(uplan%batch_size)))
5775 : : call gpu_ctx_init(uplan%gpu_ctx_spc, uplan%ngfft, uplan%ngfft, uplan%batch_size, sp)
5776 : : end if
5777 : :
5778 : : if (ndat /= uplan%batch_size) then
5779 : : ! Have to rebuild the plan with batch_size == ndat.
5780 : : !call wrtout(std_out, sjoin("rg: Init plan with ndat:", itoa(ndat)))
5781 : : call gpu_ctx_free(uplan%gpu_ctx_spc)
5782 : : call gpu_ctx_init(uplan%gpu_ctx_spc, uplan%ngfft, uplan%ngfft, ndat, sp)
5783 : : end if
5784 : :
5785 : : uplan%batch_size = ndat
5786 : :
5787 : : transfer_ug = .False.; transfer_ur = .False.
5788 : : if (gpu_mode__ /= 0) then
5789 : : transfer_ug = .not. xomp_target_is_present(c_loc(ug))
5790 : : transfer_ur = .not. xomp_target_is_present(c_loc(ur))
5791 : : !$OMP TARGET ENTER DATA MAP(alloc:ug) IF(transfer_ug)
5792 : : !$OMP TARGET ENTER DATA MAP(alloc:ur) IF(transfer_ur)
5793 : : !$OMP TARGET UPDATE TO(ur) IF(transfer_ur)
5794 : : end if
5795 : :
5796 : : ! Multiply by e^{ik.r}
5797 : : if (present(phase_r)) then
5798 : : bufsize = int(nfft, c_size_t) * nspinor
5799 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO PRIVATE(offset) COLLAPSE(2) MAP(to:ur, phase_r)
5800 : : do idat=1,ndat
5801 : : do ir=1,bufsize
5802 : : offset = (idat - 1) * bufsize
5803 : : ur(offset + ir) = ur(offset + ir) * phase_r(ir)
5804 : : end do
5805 : : end do
5806 : : end if
5807 : :
5808 : : !$OMP TARGET DATA USE_DEVICE_ADDR(ur)
5809 : : call gpu_fftbox_c2c_ip(uplan%gpu_ctx_spc, int(uplan%nfft), ndat, isign__, iscale__, sp, c_loc(ur))
5810 : : call gpu_ctx_synch(uplan%gpu_ctx_spc)
5811 : : !$OMP END TARGET DATA
5812 : :
5813 : : ifft2ig => uplan%ifft2ig
5814 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO PRIVATE(ipw, offset, ir, ig) COLLAPSE(3) MAP(to:ug, ur, ifft2ig)
5815 : : do idat=1,ndat
5816 : : do ispinor=1,nspinor
5817 : : do ifft = 1, nfft
5818 : : ipw = ifft2ig(ifft); if (ipw == 0) cycle
5819 : : offset = (idat-1) * nspinor + (ispinor-1)
5820 : : ir = ifft + nfft * offset
5821 : : ig = ipw + npw * offset
5822 : : ug(ig) = ur(ir)
5823 : : end do ! ipw
5824 : : end do ! ispinor
5825 : : end do ! idat
5826 : :
5827 : : if (gpu_mode__ /= 0) then
5828 : : !$OMP TARGET UPDATE FROM(ug) IF(transfer_ug)
5829 : : !$OMP TARGET EXIT DATA MAP(delete:ug) IF(transfer_ug)
5830 : : !$OMP TARGET EXIT DATA MAP(delete:ur) IF(transfer_ur)
5831 : : end if
5832 : :
5833 : : #endif
5834 : : end if
5835 : :
5836 : 0 : end subroutine uplan_execute_rg_spc
5837 : : !!***
5838 : :
5839 : : !----------------------------------------------------------------------
5840 : :
5841 : : !!****f* m_fft/uplan_execute_rg_dpc
5842 : : !! NAME
5843 : : !! uplan_execute_rg_dpc
5844 : : !!
5845 : : !! FUNCTION
5846 : : !!
5847 : : !! INPUTS
5848 : : !!
5849 : : !! SOURCE
5850 : :
5851 : 0 : subroutine uplan_execute_rg_dpc(uplan, ndat, ur, ug, &
5852 : : isign, iscale, gpu_mode, phase_r) ! optional
5853 : :
5854 : : !Arguments ------------------------------------
5855 : : class(uplan_t),target,intent(inout) :: uplan
5856 : : integer,intent(in) :: ndat
5857 : : complex(dp),target,intent(inout) :: ur(uplan%nfft*uplan%nspinor*ndat)
5858 : : complex(dp),target,intent(out) :: ug(uplan%npw*uplan%nspinor*ndat)
5859 : : integer,optional,intent(in) :: isign, iscale, gpu_mode
5860 : : complex(dp),optional,intent(in) :: phase_r(uplan%nfft*uplan%nspinor)
5861 : :
5862 : : !Local variables-------------------------------
5863 : : integer :: isign__, iscale__, nx, ny, nz, ldx, ldy, ldz, fftalg, fftalga, fftalgc, fftcache, nspinor, npw, nfft, gpu_mode__
5864 : : integer(c_size_t) :: idat, ir, offset, bufsize
5865 : : #if defined HAVE_GPU_CUDA && defined HAVE_OPENMP_OFFLOAD
5866 : : integer(c_size_t) :: ispinor, ipw, ifft, ig
5867 : : logical :: transfer_ug, transfer_ur
5868 : : integer, contiguous, pointer :: ifft2ig(:)
5869 : : #endif
5870 : : ! *************************************************************************
5871 : :
5872 : : !call wrtout(std_out, "in uplan_execute_rg_dpc")
5873 [ # # ]: 0 : ABI_CHECK_IEQ(dp, uplan%kind, "Inconsistent kind!")
5874 : :
5875 : 0 : ABI_DEFAULT(gpu_mode__, gpu_mode, 0)
5876 : :
5877 [ # # ]: 0 : isign__ = -1; if (present(isign)) isign__ = isign
5878 [ # # ]: 0 : iscale__ = 1; if (present(iscale)) iscale__ = iscale
5879 : :
5880 : 0 : fftalg = uplan%ngfft(7); fftcache = uplan%ngfft(8); fftalga = fftalg/100; fftalgc = mod(fftalg, 10)
5881 : 0 : nx = uplan%ngfft(1); ny = uplan%ngfft(2); nz = uplan%ngfft(3)
5882 : 0 : ldx = nx; ldy = ny; ldz = nz ! No augmentation, the caller does not support it.
5883 : :
5884 : : ! NVHPC does not reliably support mapping derived_type components
5885 : 0 : nspinor = uplan%nspinor; npw = uplan%npw; nfft = uplan%nfft
5886 : :
5887 [ # # ]: 0 : if (uplan%gpu_option == ABI_GPU_DISABLED) then
5888 : :
5889 : : ! Multiply by e^{ik.r}
5890 [ # # ]: 0 : if (present(phase_r)) then
5891 : 0 : bufsize = int(nfft, c_size_t) * nspinor
5892 : : !$OMP PARALLEL DO PRIVATE(offset) IF (ndat > 1)
5893 [ # # ]: 0 : do idat=1,ndat
5894 : 0 : offset = (idat - 1) * bufsize
5895 [ # # ]: 0 : do ir=1,bufsize
5896 : 0 : ur(offset + ir) = ur(offset + ir) * phase_r(ir)
5897 : : end do
5898 : : end do
5899 : : end if
5900 : :
5901 : 0 : select case (fftalga)
5902 : : case (FFT_FFTW3)
5903 : : call fftw3_fftur(fftalg, fftcache, int(uplan%npw), nx, ny, nz, ldx, ldy, ldz, uplan%nspinor*ndat, uplan%istwfk, uplan%mgfft, &
5904 [ # # # # : 0 : uplan%kg_k, uplan%gbound, ur, ug, isign=isign__, iscale=iscale__)
# # # # #
# ]
5905 : : case (FFT_DFTI)
5906 : : call dfti_fftur(fftalg, fftcache, int(uplan%npw), nx, ny, nz, ldx, ldy, ldz, uplan%nspinor*ndat, uplan%istwfk, uplan%mgfft, &
5907 [ # # # # : 0 : uplan%kg_k, uplan%gbound, ur, ug, isign=isign__, iscale=iscale__)
# # # # #
# ]
5908 : : case default
5909 [ # # # ]: 0 : ABI_ERROR(sjoin("Wrong fftalga:", itoa(fftalga)))
5910 : : end select
5911 : :
5912 : : else
5913 : : #if defined HAVE_GPU_CUDA && defined HAVE_OPENMP_OFFLOAD
5914 : : ! Build plan if not yet done. note batch_size instead of ndat.
5915 : : if (.not. c_associated(uplan%gpu_ctx_dpc)) then
5916 : : call gpu_ctx_init(uplan%gpu_ctx_dpc, uplan%ngfft, uplan%ngfft, uplan%batch_size, dp)
5917 : : end if
5918 : :
5919 : : if (ndat /= uplan%batch_size) then
5920 : : ! Have to rebuild the plan with batch_size == ndat.
5921 : : call gpu_ctx_free(uplan%gpu_ctx_dpc)
5922 : : call gpu_ctx_init(uplan%gpu_ctx_dpc, uplan%ngfft, uplan%ngfft, ndat, dp)
5923 : : end if
5924 : :
5925 : : uplan%batch_size = ndat
5926 : :
5927 : : transfer_ug = .False.; transfer_ur = .False.
5928 : : if (gpu_mode__ /= 0) then
5929 : : transfer_ug = .not. xomp_target_is_present(c_loc(ug))
5930 : : transfer_ur = .not. xomp_target_is_present(c_loc(ur))
5931 : : !$OMP TARGET ENTER DATA MAP(alloc:ug) IF(transfer_ug)
5932 : : !$OMP TARGET ENTER DATA MAP(alloc:ur) IF(transfer_ur)
5933 : : !$OMP TARGET UPDATE TO(ur) IF(transfer_ur)
5934 : : end if
5935 : :
5936 : : ! Multiply by e^{ik.r}
5937 : : if (present(phase_r)) then
5938 : : bufsize = int(nfft, c_size_t) * nspinor
5939 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO PRIVATE(offset) COLLAPSE(2) MAP(to:ur, phase_r)
5940 : : do idat=1,ndat
5941 : : do ir=1,bufsize
5942 : : offset = (idat - 1) * bufsize
5943 : : ur(offset + ir) = ur(offset + ir) * phase_r(ir)
5944 : : end do
5945 : : end do
5946 : : end if
5947 : :
5948 : : !$OMP TARGET DATA USE_DEVICE_ADDR(ur)
5949 : : call gpu_fftbox_c2c_ip(uplan%gpu_ctx_dpc, int(uplan%nfft), ndat, isign__, iscale__, dp, c_loc(ur))
5950 : : call gpu_ctx_synch(uplan%gpu_ctx_dpc)
5951 : : !$OMP END TARGET DATA
5952 : :
5953 : : ifft2ig => uplan%ifft2ig
5954 : : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO PRIVATE(ipw, offset, ir, ig) COLLAPSE(3) MAP(to:ug, ur, ifft2ig)
5955 : : do idat=1,ndat
5956 : : do ispinor=1,nspinor
5957 : : do ifft = 1, nfft
5958 : : ipw = ifft2ig(ifft); if (ipw == 0) cycle
5959 : : offset = (idat-1) * nspinor + (ispinor-1)
5960 : : ir = ifft + nfft * offset
5961 : : ig = ipw + npw * offset
5962 : : ug(ig) = ur(ir)
5963 : : end do ! ipw
5964 : : end do ! ispinor
5965 : : end do ! idat
5966 : :
5967 : : if (gpu_mode__ /= 0) then
5968 : : !$OMP TARGET UPDATE FROM(ug) IF(transfer_ug)
5969 : : !$OMP TARGET EXIT DATA MAP(delete:ug) IF(transfer_ug)
5970 : : !$OMP TARGET EXIT DATA MAP(delete:ur) IF(transfer_ur)
5971 : : end if
5972 : : #endif
5973 : : end if
5974 : :
5975 : 0 : end subroutine uplan_execute_rg_dpc
5976 : : !!***
5977 : :
5978 [ # # # # : 0 : end module m_fft
# # # # #
# # # # #
# # # # ]
5979 : : !!***
|
