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 215011 : 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 215011 : 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 5733916 : 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 5733916 : real(dp),allocatable :: fofr(:,:,:,:,:), fofrvz(:,:)
1161 5733916 : real(dp),contiguous, pointer :: fpt_ftarr(:,:,:,:,:)
1162 : ! *************************************************************************
1163 :
1164 5733916 : 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 5733911 : 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 5733916 : 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 41292771 : subroutine fourwf_optmem(cplex,denpot,fofgin,fofgout,fofr,gboundin,gboundout,istwf_k,&
2637 41292771 : kg_kin,kg_kout,mgfft,mpi_enreg,ndat,nblocks,ngfft,npwin,npwout,n4,n5,n6,option,&
2638 : tim_fourwf,weight_r,weight_i, &
2639 41292771 : 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 41292771 : 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 41292771 : gpu_option_=ABI_GPU_DISABLED; if(present(gpu_option)) gpu_option_=gpu_option
2663 :
2664 41292771 : ABI_CHECK_IEQ(size(fofr,dim=1), 2, 'wrong size for fofr (dim 1)')
2665 41292771 : ABI_CHECK_IEQ(size(fofr,dim=2), n4, 'wrong size for fofr (dim 2)')
2666 41292771 : ABI_CHECK_IEQ(size(fofr,dim=3), n5, 'wrong size for fofr (dim 3)')
2667 :
2668 41292771 : if(gpu_option_==ABI_GPU_DISABLED .or. option==0 .or. option==3) then
2669 41292771 : 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 82585542 : & 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 41292771 : 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 122113026 : subroutine fourwf(cplex,denpot,fofgin,fofgout,fofr,gboundin,gboundout,istwf_k,&
2857 61056513 : kg_kin,kg_kout,mgfft,mpi_enreg,ndat,ngfft,npwin,npwout,n4,n5,n6,option,&
2858 : tim_fourwf,weight_r,weight_i, &
2859 61056513 : 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 61056513 : integer, contiguous, pointer :: fftn2_distrib(:),ffti2_local(:)
2889 61056513 : integer, contiguous, pointer :: fftn3_distrib(:),ffti3_local(:)
2890 : real(dp) :: tsec(2)
2891 61056513 : real(dp),allocatable :: work1(:,:,:,:),work2(:,:,:,:),work3(:,:,:,:)
2892 61056513 : real(dp),allocatable :: work4(:,:,:,:),work_sum(:,:,:,:)
2893 61056513 : real(dp),pointer :: weight_ptr_r(:),weight_ptr_i(:)
2894 : ! *************************************************************************
2895 :
2896 : ! Accumulate timing
2897 61056513 : call timab(840+tim_fourwf,1,tsec)
2898 :
2899 61056513 : 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 61056513 : n1=ngfft(1); n2=ngfft(2); n3=ngfft(3); nfftot=n1*n2*n3
2905 61056513 : fftcache=ngfft(8)
2906 61056513 : fftalg=ngfft(7); fftalga=fftalg/100; fftalgc=mod(fftalg,10)
2907 61056513 : me_fft=ngfft(11)
2908 61056513 : nproc_fft=ngfft(10)
2909 :
2910 61056513 : comm_fft = mpi_enreg%comm_fft; me_g0 = mpi_enreg%me_g0_fft
2911 61056513 : 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 61056513 : gpu_option_=ABI_GPU_DISABLED
2929 61056513 : if (PRESENT(gpu_option)) gpu_option_=gpu_option
2930 :
2931 : !If processing gamma-point, disable GPU, except OpenMP (not supported on other variants)
2932 61056513 : 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 59703376 : 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 61056513 : 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 61056513 : 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 61056513 : 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 61056513 : 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 61056513 : 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 61056513 : luse_ndo=.false.
3017 61056513 : if (present(use_ndo).and.present(fofginb)) then
3018 1442742 : 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 61056513 : 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 61023503 : call ptabs_fourwf(mpi_enreg,n2,n3,fftn2_distrib,ffti2_local,fftn3_distrib,ffti3_local)
3044 :
3045 : ! Branch immediately depending on nproc_fft
3046 61023503 : 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 696830 : n4,n5,n6,ndat,option,weight_r,weight_i,comm_fft)
3050 696830 : 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 59093181 : 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 59093181 : 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 61560165 : ABI_SFREE(work2)
3500 : end select
3501 :
3502 : ! Accumulate timing
3503 : 100 continue
3504 61056513 : call timab(840+tim_fourwf,2,tsec)
3505 :
3506 122113026 : 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 1398195 : 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 1398195 : integer, contiguous, pointer :: fftn2_distrib(:),ffti2_local(:)
3565 1398195 : integer, contiguous, pointer :: fftn3_distrib(:),ffti3_local(:)
3566 : real(dp) :: tsec(2)
3567 1398195 : real(dp),allocatable :: work1(:,:,:,:,:),work2(:,:,:,:,:)
3568 1398195 : real(dp),allocatable :: workf(:,:,:,:,:),workr(:,:,:,:,:)
3569 : ! *************************************************************************
3570 :
3571 : !ABI_CHECK(ndat == 1, "ndat != 1 should be tested")
3572 :
3573 : ! Keep track of timing
3574 1398195 : call timab(1260+tim_fourdp,1,tsec)
3575 :
3576 1398195 : if (fourdp_counter>=0) then
3577 0 : fourdp_counter = fourdp_counter + ndat
3578 : end if
3579 :
3580 : ! GPU version of fourdp
3581 1398195 : gpu_option_=ABI_GPU_DISABLED
3582 1398195 : if (PRESENT(gpu_option)) gpu_option_=gpu_option
3583 :
3584 1398195 : n1=ngfft(1); n2=ngfft(2); n3=ngfft(3)
3585 1398195 : n4=ngfft(4); n5=ngfft(5); n6=ngfft(6)
3586 1398195 : me_fft=ngfft(11); nproc_fft=ngfft(10)
3587 1398195 : 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 1398195 : 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 1398195 : fftcache=ngfft(8)
3597 1398195 : fftalg =ngfft(7); fftalga =fftalg/100; fftalgb =mod(fftalg,100)/10
3598 :
3599 1398195 : xnorm=one/dble(n1*n2*n3)
3600 : !write(std_out,*)' fourdp :me_fft',me_fft,'nproc_fft',nproc_fft,'nfft',nfft
3601 :
3602 1398195 : 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 1398195 : 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 1398195 : 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 1398195 : call ptabs_fourdp(mpi_enreg,n2,n3,fftn2_distrib,ffti2_local,fftn3_distrib,ffti3_local)
3625 :
3626 : ! Branch immediately depending on nproc_fft
3627 1398195 : if (nproc_fft > 1) then
3628 27020 : call fourdp_mpi(cplex,nfft,ngfft,ndat,isign,fftn2_distrib,ffti2_local,fftn3_distrib,ffti3_local,fofg,fofr,comm_fft)
3629 27020 : goto 100
3630 : end if
3631 :
3632 1371175 : 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 1371175 : if (fftalga == FFT_DFTI) then
3647 : ! Call sequential or MPI MKL.
3648 1251726 : if (nproc_fft == 1) then
3649 1251726 : 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 1251726 : 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 146469 : 100 call timab(1260+tim_fourdp,2,tsec)
3892 :
3893 1398195 : 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 27020 : subroutine fourdp_mpi(cplex,nfft,ngfft,ndat,isign,&
4051 27020 : 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 27020 : fftalg=ngfft(7); fftalga=fftalg/100 ; fftalgc=mod(fftalg,10)
4069 :
4070 27020 : select case (fftalga)
4071 : case (FFT_SG2002)
4072 : call sg2002_mpifourdp(cplex,nfft,ngfft,ndat,isign,&
4073 27020 : 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 27020 : ABI_BUG(msg)
4087 : end select
4088 :
4089 27020 : 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 799411 : subroutine fourwf_mpi(cplex,denpot,fofgin,fofgout,fofr,&
4176 799411 : & 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 1598822 : real(dp) :: weight_array_r(ndat), weight_array_i(ndat)
4211 799411 : real(dp),allocatable :: workf(:,:,:,:)
4212 : ! *************************************************************************
4213 :
4214 : !call timab(540,1,tsec)
4215 :
4216 799411 : fftalg=ngfft(7); fftalga=fftalg/100 ; fftalgc=mod(fftalg,10)
4217 :
4218 799411 : 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 799411 : 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 799411 : 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 799411 : 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 799411 : 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 799411 : use_ialltoall = (ndat > 1)
4255 : #endif
4256 799411 : use_ialltoall = (use_ialltoall .and. ALLOW_IALLTOALL)
4257 9385 : if (use_ialltoall .and. nwrites_ialltoall==0) then
4258 28 : nwrites_ialltoall = 1
4259 28 : call wrtout(std_out, "- Will use non-blocking ialltoall for MPI-FFT")
4260 : end if
4261 :
4262 799411 : md1i=0; md2i=0; md3i=0; m2i=0
4263 799411 : md1o=0; md2o=0; md3o=0; m2o=0
4264 :
4265 799411 : if (option/=3) then
4266 : ! Compute the dimensions of the small-box enclosing the input G-sphere
4267 799369 : max1i=gboundin(2,1); min1i=gboundin(1,1)
4268 799369 : max2i=gboundin(4,1); min2i=gboundin(3,1)
4269 :
4270 799369 : 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 799369 : if (istwf_k>=2 .and. istwf_k<=5) then
4278 185 : max2i=max(max2i,-min2i)
4279 185 : min2i=-max2i
4280 799184 : 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 799369 : max3i=gboundin(4,2); min3i=gboundin(3,2)
4286 :
4287 : ! Compute arrays size and leading dimensions to avoid cache trashing
4288 799369 : m1i=max1i-min1i+1; md1i=2*(m1i/2)+1
4289 799369 : m2i=max2i-min2i+1; md2i=2*(m2i/2)+1
4290 :
4291 : !if (.False.) then
4292 799369 : if (nproc_fft/=1) then
4293 : ! Increase max2i in order to have m2i divisible by nproc_fft
4294 696830 : min2i_moins=(((m2i-1)/nproc_fft+1)*nproc_fft-m2i)/2
4295 696830 : max2i_plus=((m2i-1)/nproc_fft+1)*nproc_fft-m2i-min2i_moins
4296 : ! max2i=max2i+((m2i-1)/nproc_fft+1)*nproc_fft-m2i
4297 696830 : max2i=max2i+max2i_plus
4298 696830 : min2i=min2i-min2i_moins
4299 : ! careful, to be checked and make sure the max and min are smaller than size of box
4300 696830 : m2i=max2i-min2i+1; md2i=2*(m2i/2)+1
4301 : end if
4302 799369 : ABI_CHECK(m2i <= n2, "m2i > n2")
4303 :
4304 799369 : m3i=max3i-min3i+1; md3i=2*(m3i/2)+1
4305 : end if
4306 :
4307 799411 : if (option==2 .or. option==3) then
4308 : ! Compute the dimensions of the small-box enclosing the output G-sphere
4309 736047 : max1o=gboundout(2,1); min1o=gboundout(1,1)
4310 736047 : max2o=gboundout(4,1); min2o=gboundout(3,1)
4311 :
4312 736047 : 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 736047 : if (istwf_k>=2 .and. istwf_k<=5) then
4320 96 : max2o=max(max2o,-min2o)
4321 96 : min2o=-max2o
4322 735951 : 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 736047 : max3o=gboundout(4,2); min3o=gboundout(3,2)
4328 :
4329 : ! Compute arrays size and leading dimensions to avoid cache trashing
4330 736047 : m1o=max1o-min1o+1; md1o=2*(m1o/2)+1
4331 736047 : m2o=max2o-min2o+1; md2o=2*(m2o/2)+1
4332 :
4333 736047 : if (nproc_fft/=1) then
4334 : ! Increase max2o in order to have m2o divisible by nproc_fft
4335 648932 : min2o_moins=(((m2o-1)/nproc_fft+1)*nproc_fft-m2o)/2
4336 648932 : max2o_plus=((m2o-1)/nproc_fft+1)*nproc_fft-m2o-min2o_moins
4337 : ! max2o=max2o+((m2o-1)/nproc_fft+1)*nproc_fft-m2o
4338 648932 : max2o=max2o+max2o_plus
4339 648932 : min2o=min2o-min2o_moins
4340 : ! careful, to be checked and make sure the max and min are smaller than size of box
4341 648932 : m2o=max2o-min2o+1; md2o=2*(m2o/2)+1
4342 : end if
4343 736047 : ABI_CHECK(m2o <= n2, "m2o > n2")
4344 :
4345 736047 : m3o=max3o-min3o+1; md3o=2*(m3o/2)+1
4346 : end if
4347 :
4348 799411 : md1=max(md1i,md1o)
4349 : md2=max(md2i,md2o)
4350 799411 : md3=max(md3i,md3o)
4351 :
4352 799411 : md2proc=(max(m2i,m2o)-1)/nproc_fft+1
4353 799411 : 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 3997055 : ABI_MALLOC(workf,(2,md1,md3,md2proc*ndat))
4360 :
4361 799411 : 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 799369 : if (nproc_fft > 1) then
4366 696830 : 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 696830 : 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 799411 : cplexwf_=2; if (istwf_k==2) cplexwf_=1
4380 799411 : if (present(cplexwf)) cplexwf_ = cplexwf
4381 :
4382 799411 : if (option==0 .or. ((option==1.or.option==2) .and. fftalgc==1) .or. option==3) then
4383 : ! Treat non-composite operations
4384 :
4385 798294 : 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 798252 : 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 798252 : 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 798252 : ABI_ERROR("fftalga does not provide MPI back_wf")
4417 : end select
4418 :
4419 : end if ! option
4420 :
4421 798294 : nd3proc=(n3-1)/nproc_fft+1
4422 :
4423 798294 : if (option==1) then
4424 : ! Accumulate density
4425 123644 : do idat=1,ndat
4426 867575 : do i3=1,nd3proc
4427 743931 : i3_glob = i3 + nd3proc * me_fft
4428 743931 : i3dat = i3 + n6eff * (idat-1)
4429 16767117 : do i2=1,n2
4430 420216995 : do i1=1,n1
4431 : denpot(i1,i2,i3_glob) = denpot(i1,i2,i3_glob) &
4432 419473064 : + (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 798294 : if (option==2) then
4440 :
4441 : ! Apply local potential
4442 735102 : if (cplex==1) then
4443 1325287 : do idat=1,ndat
4444 8917145 : do i3=1,nd3proc
4445 7591858 : i3_glob = i3 + nd3proc * me_fft
4446 7591858 : i3dat = i3 + n6eff * (idat-1)
4447 173507616 : do i2=1,n2
4448 4065150274 : do i1=1,n1
4449 3892330554 : fofr(1,i1,i2,i3dat)=denpot(i1,i2,i3_glob)*fofr(1,i1,i2,i3dat)
4450 4057558416 : 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 798294 : 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 735144 : 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 735144 : 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 735144 : 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 799411 : if (option==2 .or. option==3) then
4576 : ! From FFT box to kg_kout.
4577 736047 : xnorm=one/dble(n1*n2*n3)
4578 :
4579 736047 : if (nproc_fft > 1) then
4580 1318188 : do idat=1,ndat
4581 129924242 : do ig=1,npwout
4582 128606054 : i1=kg_kout(1,ig); if(i1<0) i1=i1+m1o; i1=i1+1
4583 128606054 : i2=kg_kout(2,ig); if(i2<0) i2=i2+m2o; i2=i2+1
4584 128606054 : i3=kg_kout(3,ig); if(i3<0) i3=i3+m3o; i3=i3+1
4585 :
4586 128606054 : igdat = ig + (idat-1) * npwout
4587 128606054 : i2_loc = (i2-1)/nproc_fft +1
4588 128606054 : i2dat_loc = i2_loc + (idat-1) * md2proc
4589 :
4590 128606054 : fofgout(1,igdat)=workf(1,i1,i3,i2dat_loc)*xnorm
4591 129275310 : 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 799411 : ABI_FREE(workf)
4603 :
4604 : !call timab(540,2,tsec)
4605 :
4606 799411 : 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 116031 : 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 116031 : integer, contiguous, pointer :: fftn2_distrib(:),ffti2_local(:)
4710 : ! **********************************************************************
4711 :
4712 116031 : me_fft=0;nproc_fft=1
4713 116031 : if (present(comm_fft)) then
4714 108272 : me_fft=xmpi_comm_rank(comm_fft)
4715 108272 : nproc_fft=xmpi_comm_size(comm_fft)
4716 : end if
4717 116031 : nd2=(n2-1)/nproc_fft+1
4718 116031 : nn12=n1*n2
4719 :
4720 : !Get the distrib associated with this fft_grid
4721 116031 : if (present(distribfft)) then
4722 108272 : if (n2== distribfft%n2_coarse) then
4723 66786 : fftn2_distrib => distribfft%tab_fftdp2_distrib
4724 66786 : ffti2_local => distribfft%tab_fftdp2_local
4725 41486 : else if(n2 == distribfft%n2_fine) then
4726 41486 : fftn2_distrib => distribfft%tab_fftdp2dg_distrib
4727 41486 : 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 116031 : if (present(ig1)) then
4738 5622 : n1sel=ig1
4739 110409 : else if (mod(n1,2)==0) then
4740 89203 : n1sel=1+n1/2
4741 : else
4742 : n1sel=-1
4743 : end if
4744 116031 : if (present(ig2)) then
4745 5622 : n2sel=ig2
4746 110409 : else if (mod(n2,2)==0) then
4747 86450 : n2sel=1+n2/2
4748 : else
4749 : n2sel=-1
4750 : end if
4751 116031 : if (present(ig3)) then
4752 5622 : n3sel=ig3
4753 110409 : else if (mod(n3,2)==0) then
4754 88233 : n3sel=1+n3/2
4755 : else
4756 : n3sel=-1
4757 : end if
4758 :
4759 116031 : if (n1sel>0) then
4760 94801 : index=n1sel-nn12-n1
4761 2348342 : do i3=1,n3
4762 2253541 : index=index+nn12;ifft=index
4763 62564503 : do i2=1,n2
4764 60216161 : ifft=ifft+n1
4765 62469702 : if (nproc_fft>1) then
4766 : ! MPIWF: consider ifft only if it is treated by the current proc and compute its address
4767 6214624 : j=ifft-1;j1=modulo(j,n1);j2=modulo(j/n1,n2);j3=j/(n1*n2) !;r2=modulo(j2,nd2)
4768 6214624 : if(fftn2_distrib(j2+1)==me_fft) then ! MPIWF this ifft is to be treated by me_fft
4769 3051728 : r2= ffti2_local(j2+1) - 1
4770 3051728 : ifft_proc=n1*(nd2*j3+r2)+j1+1 !this is ifft in the current proc
4771 9155184 : array(:,ifft_proc)=zero
4772 : end if
4773 : else
4774 158285277 : array(:,ifft)=zero
4775 : end if
4776 : end do
4777 : end do
4778 : end if
4779 :
4780 116031 : if (n2sel>0) then
4781 92042 : index=n1*n2sel-nn12-n1
4782 2244482 : do i3=1,n3
4783 2152440 : index=index+nn12;ifft=index
4784 63729018 : do i1=1,n1
4785 61484536 : ifft=ifft+1
4786 63636976 : if (nproc_fft>1) then
4787 : ! MPIWF: consider ifft only if it is treated by the current proc and compute its address
4788 6240544 : j=ifft-1;j1=modulo(j,n1);j2=modulo(j/n1,n2);j3=j/(n1*n2);
4789 6240544 : if(fftn2_distrib(j2+1)==me_fft) then ! MPIWF this ifft is to be treated by me_fft
4790 3064688 : r2= ffti2_local(j2+1) - 1
4791 3064688 : ifft_proc=n1*(nd2*j3+r2)+j1+1 !this is ifft in the current proc
4792 9194064 : array(:,ifft_proc)=zero
4793 : end if
4794 : else
4795 164143752 : array(:,ifft)=zero
4796 : end if
4797 : end do
4798 : end do
4799 : end if
4800 :
4801 116031 : if (n3sel>0) then
4802 93813 : index=nn12*n3sel-nn12-n1
4803 2177896 : do i2=1,n2
4804 2084083 : index=index+n1;ifft=index
4805 63884765 : do i1=1,n1
4806 61706869 : ifft=ifft+1
4807 63790952 : if (nproc_fft>1) then
4808 : ! MPIWF: consider ifft only if it is treated by the current proc and compute its address
4809 6240544 : j=ifft-1;j1=modulo(j,n1);j2=modulo(j/n1,n2);j3=j/(n1*n2)
4810 6240544 : if(fftn2_distrib(j2+1)==me_fft) then ! MPIWF this ifft is to be treated by me_fft
4811 3064688 : r2= ffti2_local(j2+1) - 1
4812 3064688 : ifft_proc=n1*(nd2*j3+r2)+j1+1 !this is ifft in the current proc
4813 9194064 : array(:,ifft_proc)=zero
4814 : end if
4815 : else
4816 164572611 : array(:,ifft)=zero
4817 : end if
4818 : end do
4819 : end do
4820 : end if
4821 :
4822 116031 : if (.not.present(distribfft)) then
4823 7759 : ABI_FREE(fftn2_distrib)
4824 7759 : ABI_FREE(ffti2_local)
4825 : end if
4826 :
4827 116031 : 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 974393 : 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 974393 : integer, contiguous, pointer :: fftn2_distrib(:),ffti2_local(:)
4994 974393 : integer, contiguous, pointer :: fftn3_distrib(:),ffti3_local(:)
4995 : ! *************************************************************************
4996 :
4997 974393 : me_fft=ngfft(11); nproc_fft=ngfft(10)
4998 :
4999 974393 : if (option==1.or.option==2) then
5000 974393 : 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 974393 : call ptabs_fourdp(mpi_enreg,n2,n3,fftn2_distrib,ffti2_local,fftn3_distrib,ffti3_local)
5015 :
5016 974393 : if (option==1) then
5017 : ! aa(n1*n2*n3,ispden) <-- bb(nd1,nd2,nd3) real case
5018 2306775 : do i3=1,n3
5019 2306775 : if (me_fft==fftn3_distrib(i3)) then
5020 49389931 : do i2=1,n2
5021 1439100118 : do i1=1,n1
5022 1436946212 : 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 867804 : 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 867804 : do i3=nd3,n3+1,-1
5035 867804 : 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 15087613 : do i3=n3,1,-1
5042 15087613 : if (me_fft==fftn3_distrib(i3)) then
5043 20326006 : do i2=nd2,n2+1,-1
5044 184859675 : do i1=nd1,1,-1
5045 170670350 : bb(i1,i2,i3)=0.d0
5046 : end do
5047 : end do
5048 257891269 : do i2=n2,1,-1
5049 403355313 : do i1=nd1,n1+1,-1
5050 403355313 : bb(i1,i2,i3)=0.d0
5051 : end do
5052 6787019444 : do i1=n1,1,-1
5053 6772830119 : 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 974393 : 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 2896 : 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 2896 : integer,allocatable :: index_recv(:),index_send(:),siz_slice(:), ffti2r_global(:)
5132 2896 : integer, contiguous, pointer :: fftn2l_distrib(:),ffti2l_local(:)
5133 2896 : integer, contiguous, pointer :: fftn3l_distrib(:),ffti3l_local(:)
5134 2896 : integer, contiguous, pointer :: fftn2r_distrib(:),ffti2r_local(:)
5135 2896 : integer, contiguous, pointer :: fftn3r_distrib(:),ffti3r_local(:)
5136 2896 : real(dp),allocatable :: right_send(:,:),right_recv(:,:)
5137 : ! *************************************************************************
5138 :
5139 2896 : n1r=ngright(1);n2r=ngright(2);n3r=ngright(3)
5140 2896 : n1l=ngleft(1) ;n2l=ngleft(2) ;n3l=ngleft(3)
5141 2896 : nproc_fft=mpi_enreg%nproc_fft; me_fft=mpi_enreg%me_fft
5142 2896 : nd2r=n2r/nproc_fft; nd2l=n2l/nproc_fft
5143 :
5144 : !Get the distrib associated with the left fft_grid
5145 2896 : 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 2896 : call ptabs_fourdp(mpi_enreg,n2r,n3r,fftn2r_distrib,ffti2r_local,fftn3r_distrib,ffti3r_local)
5149 :
5150 : !Precompute local --> global corespondance
5151 8688 : ABI_MALLOC(ffti2r_global,(nd2r))
5152 41432 : ffti2r_global(:) = -1
5153 81576 : do j2=1,n2r
5154 81576 : if( fftn2r_distrib(j2) == me_fft ) then
5155 38536 : ffti2r_global( ffti2r_local(j2) ) = j2
5156 : end if
5157 : end do
5158 :
5159 8688 : ABI_MALLOC(siz_slice,(nproc_fft))
5160 8872 : siz_slice(:)=0
5161 90099696 : do i_global=1,sizeindex !look for the maximal size of slice of data
5162 90096800 : j_global=index(i_global)!; write(std_out,*) j_global,i_global
5163 90099696 : if(j_global /=0) then
5164 : !use the fact that (j-1)=i1 + n1l*(j2l-1 + n2l*(j3l-1))
5165 18768064 : proc_dest= fftn2l_distrib( modulo((j_global-1)/n1l,n2l) + 1)
5166 18768064 : 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 8872 : 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 8688 : ABI_MALLOC(right_send,(2,nproc_fft*siz_slice_max))
5175 8688 : ABI_MALLOC(index_send,(nproc_fft*siz_slice_max))
5176 81145032 : siz_slice(:)=0; index_send(:)=0; right_send(:,:)=zero
5177 43732832 : do iright=1,nright
5178 43729936 : j=iright-1;j1=modulo(j,n1r);j2=modulo(j/n1r,nd2r);j3=j/(n1r*nd2r)
5179 43729936 : j2 = ffti2r_global(j2+1) - 1
5180 43729936 : iright_global=n1r*(n2r*j3+j2)+j1+1
5181 43729936 : jleft_global=index(iright_global)
5182 43732832 : if(jleft_global/=0)then
5183 9066080 : j=jleft_global-1;j1=modulo(j,n1l);j2=modulo(j/n1l,n2l);j3=j/(n1l*n2l); r2=ffti2l_local(j2+1)-1
5184 9066080 : jleft_local=n1l*(nd2l*j3+r2)+j1+1
5185 9066080 : proc_dest=fftn2l_distrib(j2+1)
5186 9066080 : siz_slice(proc_dest+1)=siz_slice(proc_dest+1)+1
5187 27198240 : right_send(:,proc_dest*siz_slice_max+siz_slice(proc_dest+1))=right(:,iright)
5188 9066080 : 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 5792 : ABI_MALLOC(right_recv,(2,nproc_fft*siz_slice_max))
5193 5792 : ABI_MALLOC(index_recv,(nproc_fft*siz_slice_max))
5194 : #if defined HAVE_MPI
5195 2896 : 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 2896 : 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 2896 : MPI_integer,mpi_enreg%comm_fft,ierr)
5204 : endif
5205 : #endif
5206 20285488 : do ileft=1,siz_slice_max*nproc_fft
5207 : !write(std_out,*)index_recv(ileft)
5208 38417648 : if(index_recv(ileft) /=0 ) left(:,index_recv(ileft))=right_recv(:,ileft)
5209 : end do
5210 2896 : ABI_FREE(right_recv)
5211 2896 : ABI_FREE(index_recv)
5212 2896 : ABI_FREE(right_send)
5213 2896 : ABI_FREE(index_send)
5214 2896 : ABI_FREE(siz_slice)
5215 2896 : ABI_FREE(ffti2r_global)
5216 :
5217 2896 : 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 : !!***
|
