Branch data Line data Source code
1 : : !!****m* ABINIT/m_fftw3
2 : : !! NAME
3 : : !! m_fftw3
4 : : !!
5 : : !! FUNCTION
6 : : !! This module provides wrappers for the FFTW3 routines: in-place and out-of-place version.
7 : : !!
8 : : !! COPYRIGHT
9 : : !! Copyright (C) 2009-2026 ABINIT group (MG, FD)
10 : : !! This file is distributed under the terms of the
11 : : !! GNU General Public License, see ~abinit/COPYING
12 : : !! or http://www.gnu.org/copyleft/gpl.txt .
13 : : !!
14 : : !! NOTES
15 : : !! 1) MPI parallelism is in testing stage
16 : : !! 2) For better performance the FFT divisions should contain small factors [2, 3, 5, 7, 11]
17 : : !!
18 : : !! SOURCE
19 : :
20 : : #if defined HAVE_CONFIG_H
21 : : #include "config.h"
22 : : #endif
23 : :
24 : : #include "abi_common.h"
25 : :
26 : : ! It seems that MKL wrappers do not like the advanced interfaces for
27 : : ! r2c and c2r transforms although they work fine if the true FFTW3 library is used.
28 : : !#define DEV_RC_BUG
29 : : #undef DEV_RC_BUG
30 : :
31 : : #define FFTLIB "FFTW3"
32 : : ! do not use FFT_PREF(name) since not working with NAG compiler
33 : : #define FFT_PREF_fftrisc fftw3_fftrisc
34 : : #define FFT_PREF_fftrisc_mixprec fftw3_fftrisc_mixprec
35 : : #define FFT_PREF_fftpad fftw3_fftpad
36 : : #define FFT_PREF_fftug_dp fftw3_fftug_dp
37 : : #define FFT_PREF_fftur_dp fftw3_fftur_dp
38 : : #define FFT_PREF_fftug fftw3_fftug
39 : : #define FFT_PREF_fftur fftw3_fftur
40 : :
41 : :
42 : :
43 : : #define SPAWN_THREADS_HERE(ndat, nthreads) fftw3_spawn_threads_here(ndat, nthreads)
44 : : #define FFT_DOUBLE 1
45 : : #define FFT_SINGLE 2
46 : : #define FFT_MIXPREC 3
47 : :
48 : : MODULE m_fftw3
49 : :
50 : : use defs_basis
51 : : use m_abicore
52 : : use m_errors
53 : : use m_xomp
54 : : use m_xmpi
55 : : use m_hide_blas
56 : : use m_cgtools
57 : : use m_cplxtools
58 : : use m_distribfft
59 : : use m_fftcore
60 : : use, intrinsic :: iso_c_binding
61 : :
62 : : use m_time, only : timab
63 : : use m_numeric_tools, only : imax_loc
64 : : use defs_abitypes, only : MPI_type
65 : : use m_mpinfo, only : ptabs_fourwf
66 : : use m_fstrings, only : strcat, itoa, sjoin
67 : : use m_fft_mesh, only : zpad_t
68 : :
69 : : implicit none
70 : :
71 : : #ifdef HAVE_FFTW3_MPI
72 : : include 'fftw3-mpi.f03'
73 : : #endif
74 : :
75 : : !This should be done but MKL fftw hasn't always this include file
76 : : !#ifdef HAVE_FFT_FFTW3
77 : : ! include 'fftw3.f03'
78 : : !#endif
79 : :
80 : : private
81 : :
82 : : ! Entry points for client code
83 : : public :: fftw3_seqfourdp ! 3D FFT of lengths nx, ny, nz. Mainly used for densities or potentials.
84 : : public :: fftw3_seqfourwf ! FFT transform of wavefunctions (high-level interface).
85 : : public :: fftw3_fftrisc
86 : : public :: fftw3_fftrisc_mixprec ! Mixed precision version of fftrisc: input/output in dp, computation done in sp.
87 : : public :: fftw3_fftug ! G-->R. 3D zero-padded FFT of lengths nx, ny, nz. Mainly used for wavefunctions
88 : : public :: fftw3_fftur ! R-->G, 3D zero-padded FFT of lengths nx, ny, nz. Mainly used for wavefunctions
89 : : public :: fftw3_use_lib_threads
90 : : public :: fftw3_spawn_threads_here
91 : :
92 : : public :: fftw3_mpifourdp
93 : :
94 : : ! Low-level routines.
95 : : public :: fftw3_cleanup ! Reset FFTW to the pristine state it was in when you started your program,
96 : : public :: fftw3_init_threads ! one-time initialization required to use FFTW3 threads.
97 : : public :: fftw3_set_nthreads ! Set the number of threads you want FFTW3 to use when HAVE_FFT_FFTW3_THREADS is defined.
98 : : public :: fftw3_r2c_op ! Real to complex transform (out-of-place version).
99 : : public :: fftw3_c2r_op ! Complex to real transform (out-of-place version).
100 : : public :: fftw3_c2c_op ! complex to complex transform (out-of-place version).
101 : : public :: fftw3_c2c_ip ! complex to complex transform (in-place version).
102 : : public :: fftw3_many_dft_op ! Driver routine for many out-of-place 3D complex-to-complex FFTs.
103 : : public :: fftw3_many_dft_ip ! Driver routine for many in-place 3D complex-to-complex FFTs.
104 : : public :: fftw3_fftpad ! Driver routines for zero-padded FFT of wavefunctions.
105 : : public :: fftw3_fftpad_dp ! Driver routines for zero-padded FFT of wavefunctions.
106 : : public :: fftw3_fftug_dp ! Driver routines for zero-padded FFT of wavefunctions.
107 : : public :: fftw3_poisson ! Solve the poisson equation in G-space starting from n(r).
108 : :
109 : : ! MPI version
110 : : public :: fftw3_mpiback_wf
111 : : public :: fftw3_mpiback_manywf
112 : : public :: fftw3_mpiforw_wf
113 : : public :: fftw3_mpiforw_manywf
114 : : public :: fftw3_mpiback
115 : : public :: fftw3_mpiforw
116 : : public :: fftw3_applypot
117 : : public :: fftw3_applypot_many
118 : : public :: fftw3_accrho
119 : :
120 : : #ifdef HAVE_FFTW3_MPI
121 : : ! flags copied from fftw3.f
122 : : integer,public,parameter :: ABI_FFTW_FORWARD = FFTW_FORWARD
123 : : integer,public,parameter :: ABI_FFTW_BACKWARD = FFTW_BACKWARD
124 : : integer,public,parameter :: ABI_FFTW_ESTIMATE = FFTW_ESTIMATE
125 : : integer,public,parameter :: ABI_FFTW_MEASURE = FFTW_MEASURE
126 : : ! end flags copied from fftw3.f
127 : : integer,public,parameter :: ABI_FFTW_MPI_TRANSPOSED_IN = FFTW_MPI_TRANSPOSED_IN
128 : : integer,public,parameter :: ABI_FFTW_MPI_TRANSPOSED_OUT = FFTW_MPI_TRANSPOSED_OUT
129 : : ! end flags copies from fftw3-mpi.f03
130 : : #else
131 : : integer,public,parameter :: ABI_FFTW_FORWARD = -1
132 : : integer,public,parameter :: ABI_FFTW_BACKWARD = +1
133 : : integer,public,parameter :: ABI_FFTW_ESTIMATE = 64
134 : : integer,public,parameter :: ABI_FFTW_MEASURE = 0
135 : : ! end flags copied from fftw3.f
136 : : integer,public,parameter :: ABI_FFTW_MPI_TRANSPOSED_IN = 536870912
137 : : integer,public,parameter :: ABI_FFTW_MPI_TRANSPOSED_OUT = 1073741824
138 : : ! end flags copies from fftw3-mpi.f03
139 : : #endif
140 : :
141 : : ! ==========================================================================================
142 : : ! ==== Variables introduced for the FFTW3 interface in abinit. Not belonging to fftw3.f ====
143 : : ! ==========================================================================================
144 : :
145 : : integer,public,parameter :: NULL_PLAN = 0
146 : : ! MKL wrappers might return NULL_PLAN if a particular FFTW3 feature is not available
147 : :
148 : : integer,public,parameter :: KIND_FFTW_PLAN = 8
149 : : ! It should be at least integer*@SIZEOF_INT_P@
150 : : ! MKL wrappers requires it to be integer*8, so do _not_ use C_INTPTR_T.
151 : :
152 : : #ifdef HAVE_FFTW3_THREADS
153 : : integer,private,save :: THREADS_INITED = 0
154 : : ! 1 if treads have been initialized. 0 otherwise.
155 : : #endif
156 : :
157 : : logical,private,save :: USE_LIB_THREADS = .FALSE.
158 : : !!***
159 : :
160 : : !----------------------------------------------------------------------
161 : :
162 : : !!****t* m_fftw3/fftw3_plan3_t
163 : : !! NAME
164 : : !! fftw3_plan3_t
165 : : !!
166 : : !! FUNCTION
167 : : !! Structure storing the pointer to the FFTW plan as well as the options used to generate it.
168 : : !!
169 : : !! SOURCE
170 : :
171 : : type,private :: fftw3_plan3_t
172 : : integer :: isign=0 ! Sign of the exponential in the FFT
173 : : integer :: ndat=-1 ! Number of FFTs associated to the plan
174 : : integer :: flags=-HUGE(0) ! FFTW3 flags used to construct the plan.
175 : : integer(KIND_FFTW_PLAN) :: plan=NULL_PLAN ! FFTW3 plan.
176 : : integer :: nthreads=1 ! The number of threads associated to the plan.
177 : : integer :: idist=-1
178 : : integer :: odist=-1
179 : : integer :: istride=-1
180 : : integer :: ostride=-1
181 : : integer :: n(3)=-1 ! The number of FFT divisions.
182 : : integer :: inembed(3)=-1
183 : : integer :: onembed(3)=-1
184 : : !integer(C_INT) :: alignment(2) ! The alignment of the arrays used to construct the plan.
185 : : end type fftw3_plan3_t
186 : : !!***
187 : :
188 : : interface fftw3_fftrisc
189 : : module procedure fftw3_fftrisc_sp
190 : : module procedure fftw3_fftrisc_dp
191 : : end interface fftw3_fftrisc
192 : :
193 : : interface fftw3_fftug
194 : : module procedure fftw3_fftug_dp
195 : : module procedure fftw3_fftug_spc
196 : : module procedure fftw3_fftug_dpc
197 : : end interface fftw3_fftug
198 : :
199 : : interface fftw3_fftur
200 : : module procedure fftw3_fftur_dp
201 : : module procedure fftw3_fftur_spc
202 : : module procedure fftw3_fftur_dpc
203 : : end interface fftw3_fftur
204 : :
205 : : interface fftw3_c2c_op
206 : : module procedure fftw3_c2c_op_spc
207 : : module procedure fftw3_c2c_op_dpc
208 : : end interface fftw3_c2c_op
209 : :
210 : : interface fftw3_c2c_ip
211 : : module procedure fftw3_c2c_ip_spc
212 : : module procedure fftw3_c2c_ip_dpc
213 : : end interface fftw3_c2c_ip
214 : :
215 : : interface fftw3_fftpad
216 : : module procedure fftw3_fftpad_dp
217 : : module procedure fftw3_fftpad_spc
218 : : module procedure fftw3_fftpad_dpc
219 : : end interface fftw3_fftpad
220 : :
221 : : #ifdef HAVE_FFTW3
222 : : ! Overloaded planner.
223 : : interface fftw3_plan_many_dft
224 : : module procedure dplan_many_dft_1D
225 : : !module procedure dplan_many_dft_2D
226 : : module procedure cplan_many_dft
227 : : module procedure zplan_many_dft
228 : : end interface fftw3_plan_many_dft
229 : :
230 : : interface fftw3_execute_dft
231 : : module procedure fftw3_execute_dft_dp
232 : : module procedure fftw3_execute_dft_spc
233 : : module procedure fftw3_execute_dft_dpc
234 : : end interface fftw3_execute_dft
235 : :
236 : : interface fftw3_alloc_real
237 : : module procedure fftw3_alloc_real1d_dp
238 : : module procedure fftw3_alloc_real2d_dp
239 : : !module procedure fftw3_alloc_real3d_dp
240 : : end interface fftw3_alloc_real
241 : :
242 : : interface fftw3_alloc_complex
243 : : module procedure fftw3_alloc_complex1d_spc
244 : : module procedure fftw3_alloc_complex1d_dpc
245 : : end interface fftw3_alloc_complex
246 : :
247 : : !! FDahm :In case of ffw3-mpi flavor, one must include fftw3-mpi.F03 so
248 : : !! the next few lines cause compiler errors because of name redefinition
249 : : !! In deed, i think this should be avoid and replace by 'include fftw3.f03'
250 : : !! MG: These bindings are needed when we use the FFTW3 wrappers provided by
251 : : !! the MKL library. I agree that we should use the include file fftw3.F03
252 : : !! but this implies that
253 : : !! 1) we cannot use the procedures defined in this module to call the MKL wrappers
254 : : !! 2) we drop support for FFTW3 versions < 3.2 since these version do not provide
255 : : !! the F2003 interface
256 : : !! I don't have any problem in dropping support for old versions of FFTW3
257 : : !! We just have to handle the migration on the different slaves of the test farm
258 : : !! builders with MKL should use m_dfti.F90
259 : : !! builders with FFTW3 should provide a recent version of the library
260 : : !!
261 : : #ifndef HAVE_FFTW3_MPI
262 : : ! Fortran binding for fftw_malloc
263 : : interface fftw_malloc
264 : : type(C_PTR) function fftw_malloc(alloc_size) bind(C, name='fftw_malloc')
265 : : import
266 : : integer(C_SIZE_T), value :: alloc_size
267 : : end function fftw_malloc
268 : : end interface fftw_malloc
269 : : ! Fortran binding for fftw_free
270 : : interface fftw_free
271 : : subroutine fftw_free(cptr) bind(C, name='fftw_free')
272 : : import
273 : : type(C_PTR), value :: cptr
274 : : end subroutine fftw_free
275 : : end interface
276 : : #endif
277 : : #endif
278 : :
279 : : CONTAINS !===========================================================
280 : :
281 : : !!****f* m_fftw3/fftw3_seqfourdp
282 : : !! NAME
283 : : !! fftw3_seqfourdp
284 : : !!
285 : : !! FUNCTION
286 : : !! Driver routine for 3D FFT of lengths nx, ny, nz. Mainly used for densities or potentials.
287 : : !! FFT Transform is out-of-place
288 : : !!
289 : : !! INPUTS
290 : : !! cplex=1 if fofr is real, 2 if fofr is complex
291 : : !! nx,ny,nz=Number of point along the three directions.
292 : : !! ldx,ldy,ldz=Leading dimension of the array.
293 : : !! ndat = Number of FFTS
294 : : !! isign= +1 : fofg(G) => fofr(R);
295 : : !! -1 : fofr(R) => fofg(G)
296 : : !! fofg(2,ldx*ldy*ldz*ndat)=The array to be transformed.
297 : : !! [fftw_flags]=Flags used to create the plan. They can be combined with the "+" operator. Defaults to FFTW_ESTIMATE.
298 : : !!
299 : : !! OUTPUT
300 : : !! fofr(cplex,ldx*ldy*ldz*ndat)=The FFT of fofg
301 : : !!
302 : : !! SOURCE
303 : :
304 : 0 : subroutine fftw3_seqfourdp(cplex,nx,ny,nz,ldx,ldy,ldz,ndat,isign,fofg,fofr,fftw_flags)
305 : :
306 : : !Arguments ------------------------------------
307 : : !scalars
308 : : integer,intent(in) :: cplex,nx,ny,nz,ldx,ldy,ldz,ndat,isign
309 : : integer,optional,intent(in) :: fftw_flags
310 : : !arrays
311 : : real(dp),intent(inout) :: fofg(2*ldx*ldy*ldz*ndat)
312 : : real(dp),intent(inout) :: fofr(cplex*ldx*ldy*ldz*ndat)
313 : :
314 : : !Local variables-------------------------------
315 : : !scalars
316 : : integer,parameter :: iscale1 = 1
317 : : integer :: my_flags,ii,jj
318 : 0 : complex(sp), allocatable :: work_sp(:)
319 : : ! *************************************************************************
320 : :
321 : 0 : my_flags = ABI_FFTW_ESTIMATE; if (PRESENT(fftw_flags)) my_flags= fftw_flags
322 : :
323 : 0 : select case (cplex)
324 : : case (2)
325 : : ! Complex to Complex.
326 [ # # ]: 0 : if (fftcore_mixprec == 1) then
327 : : ! Mixed precision: copy in + in-place + copyout
328 [ # # # # : 0 : ABI_MALLOC(work_sp, (ldx*ldy*ldz*ndat))
# # # # #
# # # ]
329 [ # # ]: 0 : if (isign == ABI_FFTW_BACKWARD) then ! +1
330 [ # # ]: 0 : work_sp(:) = cmplx(fofg(1::2), fofg(2::2), kind=sp)
331 [ # # ]: 0 : else if (isign == ABI_FFTW_FORWARD) then ! -1
332 [ # # ]: 0 : work_sp(:) = cmplx(fofr(1::2), fofr(2::2), kind=sp)
333 : : else
334 : 0 : ABI_BUG("Wrong isign")
335 : : end if
336 : :
337 : 0 : call fftw3_c2c_ip_spc(nx, ny, nz, ldx, ldy, ldz, ndat, iscale1, isign, work_sp, fftw_flags=my_flags)
338 : :
339 [ # # ]: 0 : if (isign == ABI_FFTW_BACKWARD) then ! +1
340 : : jj = 1
341 [ # # ]: 0 : do ii=1,ldx*ldy*ldz*ndat
342 : 0 : fofr(jj) = real(work_sp(ii), kind=dp)
343 : 0 : fofr(jj+1) = aimag(work_sp(ii))
344 : 0 : jj = jj + 2
345 : : end do
346 [ # # ]: 0 : else if (isign == ABI_FFTW_FORWARD) then ! -1
347 : : jj = 1
348 [ # # ]: 0 : do ii=1,ldx*ldy*ldz*ndat
349 : 0 : fofg(jj) = real(work_sp(ii), kind=dp)
350 : 0 : fofg(jj+1) = aimag(work_sp(ii))
351 : 0 : jj = jj + 2
352 : : end do
353 : : end if
354 [ # # ]: 0 : ABI_FREE(work_sp)
355 : :
356 : : else
357 : : ! double precision version.
358 : 0 : select case (isign)
359 : : case (ABI_FFTW_BACKWARD) ! +1
360 : 0 : call fftw3_many_dft_op(nx,ny,nz,ldx,ldy,ldz,ndat,isign,fofg,fofr,fftw_flags=my_flags)
361 : : case (ABI_FFTW_FORWARD) ! -1
362 : 0 : call fftw3_many_dft_op(nx,ny,nz,ldx,ldy,ldz,ndat,isign,fofr,fofg,fftw_flags=my_flags)
363 : : case default
364 [ # # # ]: 0 : ABI_BUG("Wrong isign")
365 : : end select
366 : : end if
367 : :
368 : : case (1)
369 : : ! Real case.
370 : 0 : select case (isign)
371 : : case (ABI_FFTW_FORWARD)
372 : : ! -1; R --> G
373 : 0 : call fftw3_r2c_op(nx,ny,nz,ldx,ldy,ldz,ndat,fofr,fofg,fftw_flags=my_flags)
374 : : case (ABI_FFTW_BACKWARD)
375 : : ! +1; G --> R
376 : 0 : call fftw3_c2r_op(nx,ny,nz,ldx,ldy,ldz,ndat,fofg,fofr,fftw_flags=my_flags)
377 : : case default
378 [ # # # ]: 0 : ABI_BUG("Wrong isign")
379 : : end select
380 : :
381 : : case default
382 [ # # # ]: 0 : ABI_BUG(" Wrong value for cplex")
383 : : end select
384 : :
385 : 0 : end subroutine fftw3_seqfourdp
386 : : !!***
387 : :
388 : : !----------------------------------------------------------------------
389 : :
390 : : !!****f* m_fftw3/fftw3_seqfourwf
391 : : !! NAME
392 : : !! fftw3_seqfourwf
393 : : !!
394 : : !! FUNCTION
395 : : !! Carry out composite Fourier transforms between real and reciprocal (G) space.
396 : : !! Wavefunctions, contained in a sphere in reciprocal space,
397 : : !! can be FFT to real space. They can also be FFT from real space
398 : : !! to a sphere. Also, the density maybe accumulated, and a local potential can be applied.
399 : : !!
400 : : !! The different options are :
401 : : !! - option=0 --> reciprocal to real space and output the result.
402 : : !! - option=1 --> reciprocal to real space and accumulate the density.
403 : : !! - option=2 --> reciprocal to real space, apply the local potential to the wavefunction
404 : : !! in real space and produce the result in reciprocal space.
405 : : !! - option=3 --> real space to reciprocal space.
406 : : !! NOTE that in this case, fftalg=1x1 MUST be used. This may be changed in the future.
407 : : !!
408 : : !! INPUTS
409 : : !! cplex= if 1 , denpot is real, if 2 , denpot is complex
410 : : !! (cplex=2 only allowed for option=2, and istwf_k=1)
411 : : !! not relevant if option=0 or option=3, so cplex=0 can be used to minimize memory
412 : : !! fofgin(2,npwin)=holds input wavefunction in G vector basis sphere.
413 : : !! (intent(in) but the routine sphere can modify it for another iflag)
414 : : !! gboundin(2*mgfft+8,2)=sphere boundary info for reciprocal to real space
415 : : !! gboundout(2*mgfft+8,2)=sphere boundary info for real to reciprocal space
416 : : !! istwf_k=option parameter that describes the storage of wfs
417 : : !! kg_kin(3,npwin)=reduced planewave coordinates, input
418 : : !! kg_kout(3,npwout)=reduced planewave coordinates, output
419 : : !! mgfft=maximum size of 1D FFTs
420 : : !! ndat=number of FFT to do in //
421 : : !! ngfft(18)=contain all needed information about 3D FFT, see ~abinit/doc/variables/vargs.htm#ngfft
422 : : !! npwin=number of elements in fofgin array (for option 0, 1 and 2)
423 : : !! npwout=number of elements in fofgout array (for option 2 and 3)
424 : : !! ldx,ldy,ldz=ngfft(4),ngfft(5),ngfft(6), dimensions of fofr.
425 : : !! option= if 0: do direct FFT
426 : : !! if 1: do direct FFT, then sum the density
427 : : !! if 2: do direct FFT, multiply by the potential, then do reverse FFT
428 : : !! if 3: do reverse FFT only
429 : : !! weight_r=weight to be used for the accumulation of the density in real space
430 : : !! (needed only when option=1)
431 : : !!
432 : : !! OUTPUT
433 : : !! (see side effects)
434 : : !!
435 : : !! SIDE EFFECTS
436 : : !! Input/Output
437 : : !! for option==0, fofgin(2,npwin*ndat)=holds input wavefunction in G sphere;
438 : : !! fofr(2,ldx*ldy*ldz) contains the output Fourier Transform of fofgin;
439 : : !! no use of denpot, fofgout and npwout.
440 : : !! for option==1, fofgin(2,npwin*ndat)=holds input wavefunction in G sphere;
441 : : !! denpot(cplex*ldx,ldy,ldz) contains the input density at input,
442 : : !! and the updated density at output (accumulated);
443 : : !! no use of fofgout and npwout.
444 : : !! for option==2, fofgin(2,npwin*ndat)=holds input wavefunction in G sphere;
445 : : !! denpot(cplex*ldx,ldy,ldz) contains the input local potential;
446 : : !! fofgout(2,npwout*ndat) contains the output function;
447 : : !! for option==3, fofr(2,ldx*ldy*ldz*ndat) contains the input real space wavefunction;
448 : : !! fofgout(2,npwout*ndat) contains its output Fourier transform;
449 : : !! no use of fofgin and npwin.
450 : : !!
451 : : !! SOURCE
452 : :
453 : 0 : subroutine fftw3_seqfourwf(cplex,denpot,fofgin,fofgout,fofr,gboundin,gboundout,istwf_k, &
454 : 0 : kg_kin,kg_kout,mgfft,ndat,ngfft,npwin,npwout,ldx,ldy,ldz,option,weight_r,weight_i)
455 : :
456 : : !Arguments ------------------------------------
457 : : !scalars
458 : : integer,intent(in) :: cplex,istwf_k,ldx,ldy,ldz,ndat,npwin,npwout,option,mgfft
459 : : real(dp),intent(in) :: weight_i,weight_r
460 : : !arrays
461 : : integer,intent(in) :: gboundin(2*mgfft+8,2),gboundout(2*mgfft+8,2)
462 : : integer,intent(in) :: kg_kin(3,npwin),kg_kout(3,npwout),ngfft(18)
463 : : real(dp),intent(inout) :: denpot(cplex*ldx,ldy,ldz),fofgin(2,npwin*ndat)
464 : : real(dp),intent(inout) :: fofr(2,ldx*ldy*ldz*ndat)
465 : : real(dp),intent(out) :: fofgout(2,npwout*ndat)
466 : :
467 : : !Local variables-------------------------------
468 : : !scalars
469 : : integer,parameter :: me_g0=1,ndat1=1
470 : : integer :: nx,ny,nz,fftalg,fftalga,fftalgc,fftcache,dat,ptg,ptr,ptgin,ptgout,nthreads
471 : : character(len=500) :: msg
472 : : logical :: use_fftrisc
473 : : !arrays
474 : : !real(dp),allocatable :: saveden(:,:,:)
475 : : #if 0
476 : : logical :: use_fftbox
477 : : integer,parameter :: shiftg(3)=(/0,0,0/)
478 : : integer :: symm(3,3)
479 : : #endif
480 : : ! *************************************************************************
481 : :
482 [ # # # # : 0 : if (all(option /= [0, 1, 2, 3])) then
# # ]
483 : 0 : write(msg,'(a,i0,a)')' Option:',option,' is not allowed. Only option=0, 1, 2 or 3 are allowed presently.'
484 : 0 : ABI_ERROR(msg)
485 : : end if
486 : :
487 [ # # # # ]: 0 : if (option == 1 .and. cplex /= 1) then
488 : 0 : ABI_ERROR(sjoin("With option number 1, cplex must be 1 but it is cplex:", itoa(cplex)))
489 : : end if
490 : :
491 [ # # # # ]: 0 : if (option==2 .and. (cplex/=1 .and. cplex/=2)) then
492 : 0 : ABI_ERROR(sjoin("With the option number 2, cplex must be 1 or 2, but it is cplex:", itoa(cplex)))
493 : : end if
494 : :
495 : 0 : nx=ngfft(1); ny=ngfft(2); nz=ngfft(3)
496 : 0 : fftalg=ngfft(7); fftalga=fftalg/100; fftalgc=mod(fftalg,10)
497 : 0 : fftcache=ngfft(8)
498 : :
499 : 0 : use_fftrisc = (fftalgc==2)
500 [ # # # # ]: 0 : if (istwf_k==2.and.option==3) use_fftrisc = .FALSE.
501 [ # # # # : 0 : if (istwf_k>2.and.ANY(option==(/0,3/))) use_fftrisc = .FALSE.
# # # # ]
502 : :
503 : : nthreads = xomp_get_num_threads(open_parallel=.TRUE.)
504 : :
505 [ # # ]: 0 : if (use_fftrisc) then
506 : : !call wrtout(std_out, calling fftw3_fftrisc")
507 : :
508 [ # # ]: 0 : if (ndat == 1) then
509 [ # # ]: 0 : if (fftcore_mixprec == 0) then
510 : : call fftw3_fftrisc_dp(cplex,denpot,fofgin,fofgout,fofr,gboundin,gboundout,istwf_k,kg_kin,kg_kout,&
511 : 0 : mgfft,ngfft,npwin,npwout,ldx,ldy,ldz,option,weight_r,weight_i)
512 : : else
513 : : call fftw3_fftrisc_mixprec(cplex,denpot,fofgin,fofgout,fofr,gboundin,gboundout,istwf_k,kg_kin,kg_kout,&
514 : 0 : mgfft,ngfft,npwin,npwout,ldx,ldy,ldz,option,weight_r,weight_i)
515 : : end if
516 : :
517 : : else
518 : : ! All this boilerplate code is needed because the caller might pass zero-sized arrays
519 : : ! for the arguments that are not referenced and we don't want to have problems at run-time.
520 : : ! Moreover option 1 requires a special treatment when threads are started at this level.
521 : :
522 : : SELECT CASE (option)
523 : : CASE (0)
524 : : !
525 : : ! fofgin -> fofr, no use of denpot, fofgout and npwout.
526 : : if (.not.fftw3_spawn_threads_here(ndat,nthreads)) then
527 [ # # ]: 0 : do dat=1,ndat
528 : 0 : ptg = 1 + (dat-1)*npwin
529 : 0 : ptr = 1 + (dat-1)*ldx*ldy*ldz
530 : : call fftw3_fftrisc_dp(cplex,denpot,fofgin(1,ptg),fofgout,fofr(1,ptr),gboundin,gboundout,istwf_k,kg_kin,kg_kout,&
531 : 0 : mgfft,ngfft,npwin,npwout,ldx,ldy,ldz,option,weight_r,weight_i)
532 : : end do
533 : : else
534 : : !$OMP PARALLEL DO PRIVATE(ptg,ptr)
535 : : do dat=1,ndat
536 : : ptg = 1 + (dat-1)*npwin
537 : : ptr = 1 + (dat-1)*ldx*ldy*ldz
538 : : call fftw3_fftrisc_dp(cplex,denpot,fofgin(1,ptg),fofgout,fofr(1,ptr),gboundin,gboundout,istwf_k,kg_kin,kg_kout,&
539 : : mgfft,ngfft,npwin,npwout,ldx,ldy,ldz,option,weight_r,weight_i)
540 : : end do
541 : : end if
542 : :
543 : : CASE (1)
544 : : !fofgin -> local ur and accumulate density in denpot
545 : : ! TODO this is delicate part to do in parallel, as one should OMP reduce denpot.
546 : : ! but this causes problems with the stack.
547 : :
548 [ # # ]: 0 : do dat=1,ndat
549 : 0 : ptg = 1 + (dat-1)*npwin
550 : 0 : ptr = 1 + (dat-1)*ldx*ldy*ldz
551 : : call fftw3_fftrisc_dp(cplex,denpot,fofgin(1,ptg),fofgout,fofr,gboundin,gboundout,istwf_k,kg_kin,kg_kout,&
552 : 0 : mgfft,ngfft,npwin,npwout,ldx,ldy,ldz,option,weight_r,weight_i)
553 : : end do
554 : :
555 : : ! This version doesn't seem efficient
556 : : !!! !$OMP PARALLEL PRIVATE(ptg,ptr,saveden)
557 : : !!! ABI_MALLOC(saveden, (ldx,ldy,ldz))
558 : : !!! saveden = zero
559 : : !!! !$OMP DO
560 : : !!! do dat=1,ndat
561 : : !!! ptg = 1 + (dat-1)*npwin
562 : : !!! ptr = 1 + (dat-1)*ldx*ldy*ldz
563 : : !!! call fftw3_fftrisc_dp(cplex,saveden,fofgin(1,ptg),fofgout,fofr,gboundin,gboundout,istwf_k,kg_kin,kg_kout,&
564 : : !!! & mgfft,ngfft,npwin,npwout,ldx,ldy,ldz,option,weight_r)
565 : : !!! end do
566 : : !!! !$OMP END DO NOWAIT
567 : : !!! !$OMP CRITICAL (OMPC_addrho)
568 : : !!! denpot = denpot + saveden
569 : : !!! !$OMP END CRITICAL (OMPC_addrho)
570 : : !!! ABI_FREE(saveden)
571 : : !!! !$OMP END PARALLEL
572 : :
573 : : CASE (2)
574 : : ! <G|vloc(r)|fofgin(r)> in fofgout
575 : : if (.not.fftw3_spawn_threads_here(ndat,nthreads)) then
576 [ # # ]: 0 : do dat=1,ndat
577 : 0 : ptgin = 1 + (dat-1)*npwin
578 : 0 : ptgout = 1 + (dat-1)*npwout
579 [ # # ]: 0 : if (fftcore_mixprec == 0) then
580 : : call fftw3_fftrisc_dp(cplex,denpot,fofgin(1,ptgin),fofgout(1,ptgout),fofr,gboundin,gboundout,&
581 : 0 : istwf_k,kg_kin,kg_kout,mgfft,ngfft,npwin,npwout,ldx,ldy,ldz,option,weight_r,weight_i)
582 : : else
583 : : call fftw3_fftrisc_mixprec(cplex,denpot,fofgin(1,ptgin),fofgout(1,ptgout),fofr,gboundin,gboundout,&
584 : 0 : istwf_k,kg_kin,kg_kout,mgfft,ngfft,npwin,npwout,ldx,ldy,ldz,option,weight_r,weight_i)
585 : : end if
586 : : end do
587 : : else
588 : : !$OMP PARALLEL DO PRIVATE(ptgin,ptgout)
589 : : do dat=1,ndat
590 : : ptgin = 1 + (dat-1)*npwin
591 : : ptgout = 1 + (dat-1)*npwout
592 : : call fftw3_fftrisc_dp(cplex,denpot,fofgin(1,ptgin),fofgout(1,ptgout),fofr,gboundin,gboundout,istwf_k,kg_kin,kg_kout,&
593 : : mgfft,ngfft,npwin,npwout,ldx,ldy,ldz,option,weight_r,weight_i)
594 : : end do
595 : : end if
596 : :
597 : : CASE (3)
598 : : ! fofr -> fofgout
599 : 0 : if (.not.fftw3_spawn_threads_here(ndat,nthreads)) then
600 [ # # ]: 0 : do dat=1,ndat
601 : 0 : ptr = 1 + (dat-1)*ldx*ldy*ldz
602 : 0 : ptgout = 1 + (dat-1)*npwout
603 : : call fftw3_fftrisc_dp(cplex,denpot,fofgin,fofgout(1,ptgout),fofr(1,ptr),gboundin,gboundout,istwf_k,kg_kin,kg_kout,&
604 : 0 : mgfft,ngfft,npwin,npwout,ldx,ldy,ldz,option,weight_r,weight_i)
605 : : end do
606 : : else
607 : : !$OMP PARALLEL DO PRIVATE(ptr,ptgout)
608 : : do dat=1,ndat
609 : : ptr = 1 + (dat-1)*ldx*ldy*ldz
610 : : ptgout = 1 + (dat-1)*npwout
611 : : call fftw3_fftrisc_dp(cplex,denpot,fofgin,fofgout(1,ptgout),fofr(1,ptr),gboundin,gboundout,istwf_k,kg_kin,kg_kout,&
612 : : mgfft,ngfft,npwin,npwout,ldx,ldy,ldz,option,weight_r,weight_i)
613 : : end do
614 : : end if
615 : :
616 : : CASE DEFAULT
617 : 0 : write(msg,'(a,i0,a)')'Option',option,' is not allowed. Only option=0, 1, 2 or 3 are allowed presently.'
618 [ # # # # : 0 : ABI_ERROR(msg)
# ]
619 : : END SELECT
620 : :
621 : : end if
622 : :
623 : : else
624 : :
625 : : #if 1
626 : 0 : SELECT CASE (option)
627 : : CASE (0)
628 : : !
629 : : ! FFT u(g) --> u(r)
630 : 0 : if (.not.fftw3_spawn_threads_here(ndat,nthreads)) then
631 : 0 : call fftw3_fftug_dp(fftalg,fftcache,npwin,nx,ny,nz,ldx,ldy,ldz,ndat,istwf_k,mgfft,kg_kin,gboundin,fofgin,fofr)
632 : : else
633 : : !$OMP PARALLEL DO PRIVATE(ptg, ptr)
634 : : do dat=1,ndat
635 : : ptg = 1 + (dat-1)*npwin
636 : : ptr = 1 + (dat-1)*ldx*ldy*ldz
637 : : call fftw3_fftug_dp(fftalg,fftcache,npwin,nx,ny,nz,ldx,ldy,ldz,ndat1,&
638 : : & istwf_k,mgfft,kg_kin,gboundin,fofgin(1,ptg),fofr(1,ptr))
639 : : end do
640 : : end if
641 : :
642 : : CASE (1)
643 : : ! TODO this is delicate part to do in parallel, as one should OMP reduce denpot.
644 : 0 : call fftw3_fftug_dp(fftalg,fftcache,npwin,nx,ny,nz,ldx,ldy,ldz,ndat,istwf_k,mgfft,kg_kin,gboundin,fofgin,fofr)
645 : 0 : call cg_addtorho(nx,ny,nz,ldx,ldy,ldz,ndat,weight_r,weight_i,fofr,denpot)
646 : :
647 : : CASE (2)
648 : :
649 : 0 : if (.not.fftw3_spawn_threads_here(ndat,nthreads)) then
650 : 0 : call fftw3_fftug_dp(fftalg,fftcache,npwin,nx,ny,nz,ldx,ldy,ldz,ndat,istwf_k,mgfft,kg_kin,gboundin,fofgin,fofr)
651 : 0 : call cg_vlocpsi(nx,ny,nz,ldx,ldy,ldz,ndat,cplex,denpot,fofr)
652 : :
653 : : ! The data for option==2 is now in fofr.
654 : 0 : call fftw3_fftpad_dp(fofr,nx,ny,nz,ldx,ldy,ldz,ndat,mgfft,-1,gboundout)
655 : :
656 : 0 : call cg_box2gsph(nx,ny,nz,ldx,ldy,ldz,ndat,npwout,kg_kout,fofr,fofgout)
657 : : else
658 : :
659 : : !$OMP PARALLEL DO PRIVATE(ptg, ptr)
660 : : do dat=1,ndat
661 : : ptg = 1 + (dat-1)*npwin
662 : : ptr = 1 + (dat-1)*ldx*ldy*ldz
663 : : call fftw3_fftug_dp(fftalg,fftcache,npwin,nx,ny,nz,ldx,ldy,ldz,ndat1,&
664 : : istwf_k,mgfft,kg_kin,gboundin,fofgin(1,ptg),fofr(1,ptr))
665 : :
666 : : call cg_vlocpsi(nx,ny,nz,ldx,ldy,ldz,ndat1,cplex,denpot,fofr(1,ptr))
667 : :
668 : : ! The data for option==2 is now in fofr.
669 : : call fftw3_fftpad_dp(fofr(1,ptr),nx,ny,nz,ldx,ldy,ldz,ndat1,mgfft,-1,gboundout)
670 : :
671 : : ptg = 1 + (dat-1)*npwout
672 : : call cg_box2gsph(nx,ny,nz,ldx,ldy,ldz,ndat1,npwout,kg_kout,fofr(1,ptr),fofgout(1,ptg))
673 : : end do
674 : : end if
675 : :
676 : : CASE (3)
677 : : ! The data for option==3 is already in fofr.
678 : 0 : if (.not.fftw3_spawn_threads_here(ndat,nthreads)) then
679 : 0 : call fftw3_fftpad_dp(fofr,nx,ny,nz,ldx,ldy,ldz,ndat,mgfft,-1,gboundout)
680 : 0 : call cg_box2gsph(nx,ny,nz,ldx,ldy,ldz,ndat,npwout,kg_kout,fofr,fofgout)
681 : : else
682 : : !$OMP PARALLEL DO PRIVATE(ptg, ptr)
683 : : do dat=1,ndat
684 : : ptg = 1 + (dat-1)*npwout
685 : : ptr = 1 + (dat-1)*ldx*ldy*ldz
686 : : call fftw3_fftpad_dp(fofr(1,ptr),nx,ny,nz,ldx,ldy,ldz,ndat1,mgfft,-1,gboundout)
687 : : call cg_box2gsph(nx,ny,nz,ldx,ldy,ldz,ndat1,npwout,kg_kout,fofr(1,ptr),fofgout(1,ptg))
688 : : end do
689 : : end if
690 : :
691 : : CASE DEFAULT
692 : 0 : write(msg,'(a,i0,a)')'Option',option,' is not allowed. Only option=0, 1, 2 or 3 are allowed presently.'
693 [ # # # # : 0 : ABI_ERROR(msg)
# ]
694 : : END SELECT
695 : :
696 : : #else
697 : : symm=0; symm(1,1)=1; symm(2,2)=1; symm(3,3)=1
698 : : use_fftbox = .FALSE.
699 : : #ifdef HAVE_OPENMP
700 : : use_fftbox = (ndat>1)
701 : : #endif
702 : : !use_fftbox = .TRUE.
703 : :
704 : : SELECT CASE (option)
705 : : CASE (0)
706 : : !
707 : : ! FFT u(g) --> u(r)
708 : : call sphere(fofgin,ndat,npwin,fofr,nx,ny,nz,ldx,ldy,ldz,kg_kin,istwf_k,1,me_g0,shiftg,symm,one)
709 : :
710 : : if (use_fftbox) then
711 : : call fftw3_many_dft_ip(nx,ny,nz,ldx,ldy,ldz,ndat,ABI_FFTW_BACKWARD,fofr)
712 : : else
713 : : call fftw3_fftpad_dp(fofr,nx,ny,nz,ldx,ldy,ldz,ndat,mgfft,ABI_FFTW_BACKWARD,gboundin)
714 : : end if
715 : :
716 : : CASE (1)
717 : : ! TODO this is delicate part to do in parallel, as one should OMP reduce denpot.
718 : :
719 : : call sphere(fofgin,ndat,npwin,fofr,nx,ny,nz,ldx,ldy,ldz,kg_kin,istwf_k,1,me_g0,shiftg,symm,one)
720 : :
721 : : if (use_fftbox) then
722 : : call fftw3_many_dft_ip(nx,ny,nz,ldx,ldy,ldz,ndat,ABI_FFTW_BACKWARD,fofr)
723 : : else
724 : : call fftw3_fftpad_dp(fofr,nx,ny,nz,ldx,ldy,ldz,ndat,mgfft,ABI_FFTW_BACKWARD,gboundin)
725 : : end if
726 : :
727 : : call cg_addtorho(nx,ny,nz,ldx,ldy,ldz,ndat,weight_r,weight_i,fofr,denpot)
728 : :
729 : : CASE (2)
730 : :
731 : : call sphere(fofgin,ndat,npwin,fofr,nx,ny,nz,ldx,ldy,ldz,kg_kin,istwf_k,1,me_g0,shiftg,symm,one)
732 : :
733 : : if (use_fftbox) then
734 : : call fftw3_many_dft_ip(nx,ny,nz,ldx,ldy,ldz,ndat,ABI_FFTW_BACKWARD,fofr)
735 : : else
736 : : call fftw3_fftpad_dp(fofr,nx,ny,nz,ldx,ldy,ldz,ndat,mgfft,ABI_FFTW_BACKWARD,gboundin)
737 : : end if
738 : :
739 : : call cg_vlocpsi(nx,ny,nz,ldx,ldy,ldz,ndat,cplex,denpot,fofr)
740 : :
741 : : ! The data for option==2 is now in fofr.
742 : : if (use_fftbox) then
743 : : call fftw3_many_dft_ip(nx,ny,nz,ldx,ldy,ldz,ndat,ABI_FFTW_FORWARD,fofr)
744 : : else
745 : : call fftw3_fftpad_dp(fofr,nx,ny,nz,ldx,ldy,ldz,ndat,mgfft,ABI_FFTW_FORWARD,gboundout)
746 : : end if
747 : :
748 : : call cg_box2gsph(nx,ny,nz,ldx,ldy,ldz,ndat,npwout,kg_kout,fofr,fofgout)
749 : :
750 : : CASE (3)
751 : : ! The data for option==3 is already in fofr.
752 : : call fftw3_fftpad_dp(fofr,nx,ny,nz,ldx,ldy,ldz,ndat,mgfft,ABI_FFTW_FORWARD,gboundout)
753 : :
754 : : call cg_box2gsph(nx,ny,nz,ldx,ldy,ldz,ndat,npwout,kg_kout,fofr,fofgout)
755 : :
756 : : CASE DEFAULT
757 : : write(msg,'(a,i0,a)')'Option',option,' is not allowed. Only option=0, 1, 2 or 3 are allowed presently.'
758 : : ABI_ERROR(msg)
759 : : END SELECT
760 : : #endif
761 : : end if
762 : :
763 : 0 : end subroutine fftw3_seqfourwf
764 : : !!***
765 : :
766 : : !----------------------------------------------------------------------
767 : :
768 : : !!****f* m_fftw3/fftw3_fftrisc_sp
769 : : !! NAME
770 : : !! fftw3_fftrisc_sp
771 : : !!
772 : : !! FUNCTION
773 : : !! Carry out Fourier transforms between real and reciprocal (G) space,
774 : : !! for wavefunctions, contained in a sphere in reciprocal space,
775 : : !! in both directions. Also accomplish some post-processing.
776 : : !! See fftw3_fftrisc_dp for API doc.
777 : : !!
778 : : !! SOURCE
779 : :
780 : 0 : subroutine fftw3_fftrisc_sp(cplex,denpot,fofgin,fofgout,fofr,gboundin,gboundout,istwf_k,kg_kin,kg_kout,&
781 : : mgfft,ngfft,npwin,npwout,ldx,ldy,ldz,option, &
782 : : weight_r,weight_i, abi_convention, iscale)
783 : :
784 : : !Arguments ------------------------------------
785 : : !scalars
786 : : integer,intent(in) :: cplex,istwf_k,mgfft,ldx,ldy,ldz,npwin,npwout,option
787 : : real(dp),intent(in) :: weight_i,weight_r
788 : : !arrays
789 : : integer,intent(in) :: gboundin(2*mgfft+8,2),gboundout(2*mgfft+8,2)
790 : : integer,intent(in) :: kg_kin(3,npwin),kg_kout(3,npwout),ngfft(18)
791 : : real(sp),intent(in) :: fofgin(2,npwin)
792 : : real(dp),intent(inout) :: denpot(cplex*ldx,ldy,ldz)
793 : : real(sp),intent(inout) :: fofr(2,ldx*ldy*ldz)
794 : : real(sp),intent(inout) :: fofgout(2,npwout)
795 : : logical,optional,intent(in) :: abi_convention
796 : : integer,optional,intent(in) :: iscale
797 : : ! *************************************************************************
798 : :
799 : : #ifdef HAVE_FFTW3
800 : :
801 : : #undef FFT_PRECISION
802 : : #undef MYKIND
803 : : #undef MYCZERO
804 : : #undef MYCMPLX
805 : : #undef MYCONJG
806 : :
807 : : #define FFT_PRECISION FFT_SINGLE
808 : : #define MYKIND SP
809 : : #define MYCZERO (0._sp,0._sp)
810 : : #define MYCMPLX CMPLX
811 : : #define MYCONJG CONJG
812 : :
813 : : #include "fftw3_fftrisc.finc"
814 : :
815 : : #else
816 : 0 : ABI_ERROR("FFTW3 support not activated")
817 : : ABI_UNUSED((/cplex,gboundin(1,1),gboundout(1,1),istwf_k,kg_kin(1,1),kg_kout(1,1)/))
818 : : ABI_UNUSED((/mgfft,ngfft(1),npwin,npwout,ldx,ldy,ldz,option/))
819 : : ABI_UNUSED((/denpot(1,1,1),weight_r,weight_i/))
820 : : ABI_UNUSED((/fofgin(1,1),fofgout(1,1),fofr(1,1)/))
821 : : #endif
822 : :
823 : 0 : end subroutine fftw3_fftrisc_sp
824 : : !!***
825 : :
826 : : !----------------------------------------------------------------------
827 : :
828 : : !!****f* m_fftw3/fftw3_fftrisc_dp
829 : : !! NAME
830 : : !! fftw3_fftrisc_dp
831 : : !!
832 : : !! FUNCTION
833 : : !! Carry out Fourier transforms between real and reciprocal (G) space,
834 : : !! for wavefunctions, contained in a sphere in reciprocal space,
835 : : !! in both directions. Also accomplish some post-processing.
836 : : !!
837 : : !! NOTES
838 : : !! Specifically uses rather sophisticated algorithms, based on S Goedecker
839 : : !! routines, specialized for superscalar RISC architecture.
840 : : !! Zero padding : saves 7/12 execution time
841 : : !! Bi-dimensional data locality in most of the routine : cache reuse
842 : : !! For k-point (0 0 0) : takes advantage of symmetry of data.
843 : : !! Note however that no blocking is used, in both 1D z-transform
844 : : !! or subsequent 2D transform. This should be improved.
845 : : !!
846 : : !! INPUTS
847 : : !! cplex= if 1 , denpot is real, if 2 , denpot is complex
848 : : !! (cplex=2 only allowed for option=2 when istwf_k=1)
849 : : !! one can also use cplex=0 if option=0 or option=3
850 : : !! fofgin(2,npwin)=holds input wavefunction in G vector basis sphere.
851 : : !! gboundin(2*mgfft+8,2)=sphere boundary info for reciprocal to real space
852 : : !! gboundout(2*mgfft+8,2)=sphere boundary info for real to reciprocal space
853 : : !! istwf_k=option parameter that describes the storage of wfs
854 : : !! kg_kin(3,npwin)=reduced planewave coordinates, input
855 : : !! kg_kout(3,npwout)=reduced planewave coordinates, output
856 : : !! mgfft=maximum size of 1D FFTs
857 : : !! ngfft(18)=contain all needed information about 3D FFT, see ~abinit/doc/variables/vargs.htm#ngfft
858 : : !! npwin=number of elements in fofgin array (for option 0, 1 and 2)
859 : : !! npwout=number of elements in fofgout array (for option 2 and 3)
860 : : !! ldx,ldy,ldz=ngfft(4),ngfft(5),ngfft(6), dimensions of fofr.
861 : : !! option= if 0: do direct FFT
862 : : !! if 1: do direct FFT, then sum the density
863 : : !! if 2: do direct FFT, multiply by the potential, then do reverse FFT
864 : : !! if 3: do reverse FFT only
865 : : !! weight=weight to be used for the accumulation of the density in real space
866 : : !! (needed only when option=1)
867 : : !!
868 : : !! OUTPUT
869 : : !! (see side effects)
870 : : !!
871 : : !! OPTIONS
872 : : !! The different options are:
873 : : !! - reciprocal to real space and output the result (when option=0),
874 : : !! - reciprocal to real space and accumulate the density (when option=1) or
875 : : !! - reciprocal to real space, apply the local potential to the wavefunction
876 : : !! in real space and produce the result in reciprocal space (when option=2)
877 : : !! - real space to reciprocal space (when option=3).
878 : : !! option=0 IS NOT ALLOWED when istwf_k>2
879 : : !! option=3 IS NOT ALLOWED when istwf_k>=2
880 : : !!
881 : : !! SIDE EFFECTS
882 : : !! for option==0, fofgin(2,npwin)=holds input wavefunction in G sphere;
883 : : !! fofr(2,ldx,ldy,ldz) contains the Fourier Transform of fofgin;
884 : : !! no use of denpot, fofgout and npwout.
885 : : !! for option==1, fofgin(2,npwin)=holds input wavefunction in G sphere;
886 : : !! denpot(cplex*ldx,ldy,ldz) contains the input density at input,
887 : : !! and the updated density at output;
888 : : !! no use of fofgout and npwout.
889 : : !! for option==2, fofgin(2,npwin)=holds input wavefunction in G sphere;
890 : : !! denpot(cplex*ldx,ldy,ldz) contains the input local potential;
891 : : !! fofgout(2,npwout) contains the output function;
892 : : !! for option==3, fofr(2,ldx,ldy,ldz) contains the real space wavefunction;
893 : : !! fofgout(2,npwout) contains its Fourier transform;
894 : : !! no use of fofgin and npwin.
895 : : !!
896 : : !! SOURCE
897 : :
898 : 0 : subroutine fftw3_fftrisc_dp(cplex,denpot,fofgin,fofgout,fofr,gboundin,gboundout,istwf_k,kg_kin,kg_kout,&
899 : : mgfft,ngfft,npwin,npwout,ldx,ldy,ldz,option, &
900 : : weight_r, weight_i, abi_convention, iscale)
901 : :
902 : : !Arguments ------------------------------------
903 : : !scalars
904 : : integer,intent(in) :: cplex,istwf_k,mgfft,ldx,ldy,ldz,npwin,npwout,option
905 : : real(dp),intent(in) :: weight_r,weight_i
906 : : !arrays
907 : : integer,intent(in) :: gboundin(2*mgfft+8,2),gboundout(2*mgfft+8,2)
908 : : integer,intent(in) :: kg_kin(3,npwin),kg_kout(3,npwout),ngfft(18)
909 : : real(dp),intent(in) :: fofgin(2,npwin)
910 : : real(dp),intent(inout) :: denpot(cplex*ldx,ldy,ldz),fofr(2,ldx*ldy*ldz)
911 : : real(dp),intent(inout) :: fofgout(2,npwout)
912 : : logical,optional,intent(in) :: abi_convention
913 : : integer,optional,intent(in) :: iscale
914 : : ! *************************************************************************
915 : :
916 : : #ifdef HAVE_FFTW3
917 : :
918 : : #undef FFT_PRECISION
919 : : #undef MYKIND
920 : : #undef MYCZERO
921 : : #undef MYCMPLX
922 : : #undef MYCONJG
923 : :
924 : : #define FFT_PRECISION FFT_DOUBLE
925 : : #define MYKIND DP
926 : : #define MYCZERO (0._dp,0._dp)
927 : : #define MYCMPLX DCMPLX
928 : : #define MYCONJG DCONJG
929 : :
930 : : #include "fftw3_fftrisc.finc"
931 : :
932 : : #else
933 : 0 : ABI_ERROR("FFTW3 support not activated")
934 : : ABI_UNUSED((/cplex,gboundin(1,1),gboundout(1,1),istwf_k,kg_kin(1,1),kg_kout(1,1)/))
935 : : ABI_UNUSED((/mgfft,ngfft(1),npwin,npwout,ldx,ldy,ldz,option/))
936 : : ABI_UNUSED((/denpot(1,1,1),fofgin(1,1),fofgout(1,1),fofr(1,1),weight_r,weight_i/))
937 : : #endif
938 : :
939 : 0 : end subroutine fftw3_fftrisc_dp
940 : : !!***
941 : :
942 : : !----------------------------------------------------------------------
943 : :
944 : : !!****f* m_fftw3/fftw3_fftrisc_mixprec
945 : : !! NAME
946 : : !! fftw3_fftrisc_mixprec
947 : : !!
948 : : !! FUNCTION
949 : : !! Mixed precision version of fftrisc: input/output in dp, computation done in sp.
950 : : !! See fftw3_fftrisc_dp for API docs.
951 : : !!
952 : : !! SOURCE
953 : :
954 : 0 : subroutine fftw3_fftrisc_mixprec(cplex,denpot,fofgin,fofgout,fofr,gboundin,gboundout,istwf_k,kg_kin,kg_kout,&
955 : : mgfft,ngfft,npwin,npwout,ldx,ldy,ldz,option, &
956 : : weight_r,weight_i, abi_convention, iscale) ! optional
957 : :
958 : : !Arguments ------------------------------------
959 : : !scalars
960 : : integer,intent(in) :: cplex,istwf_k,mgfft,ldx,ldy,ldz,npwin,npwout,option
961 : : real(dp),intent(in) :: weight_r,weight_i
962 : : !arrays
963 : : integer,intent(in) :: gboundin(2*mgfft+8,2),gboundout(2*mgfft+8,2)
964 : : integer,intent(in) :: kg_kin(3,npwin),kg_kout(3,npwout),ngfft(18)
965 : : real(dp),intent(in) :: fofgin(2,npwin)
966 : : real(dp),intent(inout) :: denpot(cplex*ldx,ldy,ldz),fofr(2,ldx*ldy*ldz)
967 : : real(dp),intent(inout) :: fofgout(2,npwout)
968 : : logical,optional,intent(in) :: abi_convention
969 : : integer,optional,intent(in) :: iscale
970 : : ! *************************************************************************
971 : :
972 : : #ifdef HAVE_FFTW3
973 : :
974 : : #undef FFT_PRECISION
975 : : #undef MYKIND
976 : : #undef MYCZERO
977 : : #undef MYCMPLX
978 : : #undef MYCONJG
979 : :
980 : : #define FFT_PRECISION FFT_MIXPREC
981 : : #define MYKIND SP
982 : : #define MYCZERO (0._sp,0._sp)
983 : : #define MYCMPLX CMPLX
984 : : #define MYCONJG CONJG
985 : :
986 : : #include "fftw3_fftrisc.finc"
987 : :
988 : : #else
989 : 0 : ABI_ERROR("FFTW3 support not activated")
990 : : ABI_UNUSED((/cplex,gboundin(1,1),gboundout(1,1),istwf_k,kg_kin(1,1),kg_kout(1,1)/))
991 : : ABI_UNUSED((/mgfft,ngfft(1),npwin,npwout,ldx,ldy,ldz,option/))
992 : : ABI_UNUSED((/denpot(1,1,1),fofgin(1,1),fofgout(1,1),fofr(1,1),weight_r,weight_i/))
993 : : #endif
994 : :
995 : 0 : end subroutine fftw3_fftrisc_mixprec
996 : : !!***
997 : :
998 : : !----------------------------------------------------------------------
999 : :
1000 : : !!****f* m_fftw3/fftw3_fftug_dp
1001 : : !! NAME
1002 : : !! fftw3_fftug_dp
1003 : : !!
1004 : : !! FUNCTION
1005 : : !! Compute ndat zero-padded FFTs from G to R space.
1006 : : !! Mainly used for the transform of wavefunctions.
1007 : : !! TARGET: dp arrays with real and imaginary part
1008 : : !!
1009 : : !! INPUTS
1010 : : !! fftalg=FFT algorithm (see input variable)
1011 : : !! fftcache=size of the cache (kB)
1012 : : !! npw_k=number of plane waves for this k-point.
1013 : : !! nx,ny,nz=Number of point along the three directions.
1014 : : !! ldx,ldy,ldz=Leading dimensions of the array.
1015 : : !! ndat=Number of transforms
1016 : : !! istwf_k=Option describing the storage of the wavefunction.
1017 : : !! mgfft=Max number of FFT divisions (used to dimension gbound)
1018 : : !! kg_k(3,npw_k)=G-vectors in reduced coordinates
1019 : : !! gbound(2*mgfft+8,2)=Table for zero-padded FFT. See sphereboundary.
1020 : : !! ug(npw_k*ndat)=wavefunctions in reciprocal space.
1021 : : !!
1022 : : !! OUTPUT
1023 : : !! ur(ldx*ldy*ldz*ndat)=wavefunctions in real space.
1024 : : !!
1025 : : !! SOURCE
1026 : :
1027 : 0 : subroutine fftw3_fftug_dp(fftalg, fftcache, npw_k, nx, ny, nz, ldx, ldy, ldz, ndat, &
1028 : 0 : istwf_k, mgfft, kg_k,gbound, ug, ur, &
1029 : : isign, iscale) ! optional
1030 : :
1031 : : !Arguments ------------------------------------
1032 : : !scalars
1033 : : integer,intent(in) :: fftalg,fftcache
1034 : : integer,intent(in) :: npw_k,nx,ny,nz,ldx,ldy,ldz,ndat,istwf_k,mgfft
1035 : : !arrays
1036 : : integer,intent(in) :: gbound(2*mgfft+8,2),kg_k(3,npw_k)
1037 : : real(dp),target,intent(in) :: ug(2*npw_k*ndat)
1038 : : real(dp),target,intent(inout) :: ur(2*ldx*ldy*ldz*ndat)
1039 : : integer,optional,intent(in) :: isign, iscale
1040 : :
1041 : : #ifdef HAVE_FFTW3
1042 : : !Local variables-------------------------------
1043 : : !scalars
1044 : : integer,parameter :: dist=2
1045 : : integer :: iscale__, isign__
1046 : : real(dp) :: fofgout(2,0)
1047 : : real(dp),contiguous, pointer :: real_ug(:,:),real_ur(:,:)
1048 : : ! *************************************************************************
1049 : :
1050 : : iscale__ = 0; if (present(iscale)) iscale__ = iscale
1051 : : isign__ = +1; if (present(isign)) isign__ = isign
1052 : :
1053 : : #undef TK_PREF
1054 : : #define TK_PREF(name) CONCAT(cg_,name)
1055 : : #undef TK_PREF_box2gsph
1056 : : #define TK_PREF_box2gsph cg_box2gsph
1057 : : #undef TK_PREF_gsph2box
1058 : : #define TK_PREF_gsph2box cg_gsph2box
1059 : :
1060 : : #undef FFT_PRECISION
1061 : : #define FFT_PRECISION FFT_DOUBLE
1062 : :
1063 : : #include "fftug.finc"
1064 : :
1065 : : #undef FFT_PRECISION
1066 : :
1067 : : #else
1068 : : ! Silence compiler warning
1069 : 0 : ABI_ERROR("FFT_FFTW3 support not activated")
1070 : : ABI_UNUSED((/fftalg,fftcache,npw_k,nx,ny,nz,ldx,ldy,ldz,ndat,istwf_k,mgfft,kg_k(1,1),gbound(1,1),iscale,isign/))
1071 : : ABI_UNUSED((/ug(1),ur(1)/))
1072 : : #endif
1073 : :
1074 : 0 : end subroutine fftw3_fftug_dp
1075 : : !!***
1076 : :
1077 : : !----------------------------------------------------------------------
1078 : :
1079 : : !!****f* m_fftw3/fftw3_fftug_spc
1080 : : !! NAME
1081 : : !! fftw3_fftug_spc
1082 : : !!
1083 : : !! FUNCTION
1084 : : !! Compute ndat zero-padded FFTs from G-->R.
1085 : : !! Mainly used for the transform of wavefunctions.
1086 : : !! TARGET: spc arrays
1087 : : !! See fftw3_fftug_dp for API docs.
1088 : : !!
1089 : : !! SOURCE
1090 : :
1091 : 0 : subroutine fftw3_fftug_spc(fftalg, fftcache, npw_k, nx, ny, nz, ldx, ldy, ldz, ndat, &
1092 : 0 : istwf_k, mgfft, kg_k, gbound, ug, ur, &
1093 : : isign, iscale) ! optional
1094 : :
1095 : : !Arguments ------------------------------------
1096 : : !scalars
1097 : : integer,intent(in) :: fftalg,fftcache
1098 : : integer,intent(in) :: npw_k,nx,ny,nz,ldx,ldy,ldz,ndat,istwf_k,mgfft
1099 : : integer,optional,intent(in) :: isign, iscale
1100 : : !arrays
1101 : : integer,intent(in) :: gbound(2*mgfft+8,2),kg_k(3,npw_k)
1102 : : complex(sp),target,intent(in) :: ug(npw_k*ndat)
1103 : : complex(sp),target,intent(inout) :: ur(ldx*ldy*ldz*ndat)
1104 : :
1105 : : #ifdef HAVE_FFTW3
1106 : : !Local variables-------------------------------
1107 : : !scalars
1108 : : integer,parameter :: dist=1
1109 : : integer :: iscale__, isign__
1110 : : !arrays
1111 : : real(sp) :: fofgout(2,0)
1112 : : real(sp),contiguous, pointer :: real_ug(:,:),real_ur(:,:)
1113 : : ! *************************************************************************
1114 : :
1115 : : iscale__ = 0; if (present(iscale)) iscale__ = iscale
1116 : : isign__ = +1; if (present(isign)) isign__ = isign
1117 : :
1118 : : #undef TK_PREF
1119 : : #define TK_PREF(name) CONCAT(cplx_,name)
1120 : : #undef TK_PREF_box2gsph
1121 : : #define TK_PREF_box2gsph cplx_box2gsph
1122 : : #undef TK_PREF_gsph2box
1123 : : #define TK_PREF_gsph2box cplx_gsph2box
1124 : :
1125 : : #undef FFT_PRECISION
1126 : : #define FFT_PRECISION FFT_SINGLE
1127 : :
1128 : : #include "fftug.finc"
1129 : :
1130 : : #undef FFT_PRECISION
1131 : :
1132 : : #else
1133 : : ! Silence compiler warning
1134 : 0 : ABI_ERROR("FFTW3 support not activated")
1135 : : ABI_UNUSED((/fftalg,fftcache,npw_k,nx,ny,nz,ldx,ldy,ldz,ndat,istwf_k,mgfft,kg_k(1,1),gbound(1,1)/))
1136 : : ABI_UNUSED((/ug(1),ur(1)/))
1137 : : #endif
1138 : :
1139 : 0 : end subroutine fftw3_fftug_spc
1140 : : !!***
1141 : :
1142 : : !----------------------------------------------------------------------
1143 : :
1144 : : !!****f* m_fftw3/fftw3_fftug_dpc
1145 : : !! NAME
1146 : : !! fftw3_fftug_dpc
1147 : : !!
1148 : : !! FUNCTION
1149 : : !! Compute ndat zero-padded FFTs.
1150 : : !! Mainly used for the transform of wavefunctions.
1151 : : !! TARGET: DP arrays
1152 : : !! See fftw3_fftug_dp for API docs.
1153 : : !!
1154 : : !! SOURCE
1155 : :
1156 : 0 : subroutine fftw3_fftug_dpc(fftalg, fftcache, npw_k, nx, ny, nz, ldx, ldy, ldz, ndat, &
1157 : 0 : istwf_k, mgfft, kg_k, gbound, ug, ur, &
1158 : : isign, iscale) ! optional
1159 : :
1160 : : !Arguments ------------------------------------
1161 : : !scalars
1162 : : integer,intent(in) :: fftalg,fftcache
1163 : : integer,intent(in) :: npw_k,nx,ny,nz,ldx,ldy,ldz,ndat,istwf_k,mgfft
1164 : : !arrays
1165 : : integer,intent(in) :: gbound(2*mgfft+8,2),kg_k(3,npw_k)
1166 : : complex(dp),target,intent(in) :: ug(npw_k*ndat)
1167 : : complex(dp),target,intent(inout) :: ur(ldx*ldy*ldz*ndat)
1168 : : integer,optional,intent(in) :: isign, iscale
1169 : :
1170 : : #ifdef HAVE_FFTW3
1171 : : !Local variables-------------------------------
1172 : : !scalars
1173 : : integer,parameter :: dist=1
1174 : : integer :: iscale__, isign__
1175 : : !arrays
1176 : : real(dp) :: fofgout(2,0)
1177 : : real(dp),contiguous, pointer :: real_ug(:,:),real_ur(:,:)
1178 : : ! *************************************************************************
1179 : :
1180 : : iscale__ = 0; if (present(iscale)) iscale__ = iscale
1181 : : isign__ = +1; if (present(isign)) isign__ = isign
1182 : :
1183 : : #undef TK_PREF
1184 : : #define TK_PREF(name) CONCAT(cplx_,name)
1185 : : #undef TK_PREF_box2gsph
1186 : : #define TK_PREF_box2gsph cplx_box2gsph
1187 : : #undef TK_PREF_gsph2box
1188 : : #define TK_PREF_gsph2box cplx_gsph2box
1189 : :
1190 : : #undef FFT_PRECISION
1191 : : #define FFT_PRECISION FFT_DOUBLE
1192 : :
1193 : : #include "fftug.finc"
1194 : :
1195 : : #undef FFT_PRECISION
1196 : :
1197 : : #else
1198 : : ! Silence compiler warning
1199 : 0 : ABI_ERROR("FFTW3 support not activated")
1200 : : ABI_UNUSED((/fftalg,fftcache,npw_k,nx,ny,nz,ldx,ldy,ldz,ndat,istwf_k,mgfft,kg_k(1,1),gbound(1,1)/))
1201 : : ABI_UNUSED((/ug(1),ur(1)/))
1202 : : #endif
1203 : :
1204 : 0 : end subroutine fftw3_fftug_dpc
1205 : : !!***
1206 : :
1207 : : !----------------------------------------------------------------------
1208 : :
1209 : : !!****f* m_fftw3/fftw3_fftur_dp
1210 : : !! NAME
1211 : : !! fftw3_fftur_dp
1212 : : !!
1213 : : !! FUNCTION
1214 : : !! Compute ndat zero-padded FFTs from R- to G-space .
1215 : : !! Mainly used for the transform of wavefunctions.
1216 : : !! TARGET: dp arrays
1217 : : !!
1218 : : !! INPUTS
1219 : : !! fftalg=FFT algorithm (see input variable)
1220 : : !! fftcache=size of the cache (kB)
1221 : : !! npw_k=number of plane waves for this k-point.
1222 : : !! nx,ny,nz=Number of point along the three directions.
1223 : : !! ldx,ldy,ldz=Leading dimensions of the array.
1224 : : !! ndat=Number of transforms
1225 : : !! istwf_k=Option describing the storage of the wavefunction.
1226 : : !! mgfft=Max number of FFT divisions (used to dimension gbound)
1227 : : !! kg_k(3,npw_k)=G-vectors in reduced coordinates
1228 : : !! gbound(2*mgfft+8,2)=Table for padded-FFT. See sphereboundary.
1229 : : !!
1230 : : !! SIDE EFFECT
1231 : : !! ur(ldx*ldy*ldz*ndat)= In input: wavefunctions in real space.
1232 : : !! Destroyed in output. Do not use it anymore!
1233 : : !! OUTPUT
1234 : : !! ug(npw_k*ndat)=wavefunctions in reciprocal space.
1235 : : !!
1236 : : !! SOURCE
1237 : :
1238 : 0 : subroutine fftw3_fftur_dp(fftalg, fftcache, npw_k, nx, ny, nz, ldx, ldy, ldz, ndat, &
1239 : 0 : istwf_k, mgfft, kg_k, gbound, ur, ug, &
1240 : : isign, iscale) ! optional
1241 : :
1242 : : !Arguments ------------------------------------
1243 : : !scalars
1244 : : integer,intent(in) :: fftalg,fftcache
1245 : : integer,intent(in) :: npw_k,nx,ny,nz,ldx,ldy,ldz,ndat,istwf_k,mgfft
1246 : : integer,optional,intent(in) :: isign, iscale
1247 : : !arrays
1248 : : integer,intent(in) :: gbound(2*mgfft+8,2),kg_k(3,npw_k)
1249 : : real(dp),target,intent(inout) :: ur(2*ldx*ldy*ldz*ndat)
1250 : : real(dp),target,intent(inout) :: ug(2*npw_k*ndat)
1251 : :
1252 : : #ifdef HAVE_FFTW3
1253 : : !Local variables-------------------------------
1254 : : !scalars
1255 : : integer,parameter :: dist=2
1256 : : integer :: iscale__, isign__
1257 : : !arrays
1258 : : real(dp) :: dum_ugin(2,0)
1259 : : real(dp),contiguous, pointer :: real_ug(:,:),real_ur(:,:)
1260 : : ! *************************************************************************
1261 : :
1262 : : iscale__ = 1; if (present(iscale)) iscale__ = iscale
1263 : : isign__ = -1; if (present(isign)) isign__ = isign
1264 : :
1265 : : #undef TK_PREF
1266 : : #define TK_PREF(name) CONCAT(cg_,name)
1267 : : #undef TK_PREF_box2gsph
1268 : : #define TK_PREF_box2gsph cg_box2gsph
1269 : : #undef TK_PREF_gsph2box
1270 : : #define TK_PREF_gsph2box cg_gsph2box
1271 : :
1272 : : #undef FFT_PRECISION
1273 : : #define FFT_PRECISION FFT_DOUBLE
1274 : :
1275 : : #include "fftur.finc"
1276 : :
1277 : : #undef FFT_PRECISION
1278 : :
1279 : : #else
1280 : : ! Silence compiler warning
1281 : 0 : ABI_ERROR("FFTW3 support not activated")
1282 : : ABI_UNUSED((/fftalg,fftcache/))
1283 : : ABI_UNUSED((/npw_k,nx,ny,nz,ldx,ldy,ldz,ndat,istwf_k,mgfft,kg_k(1,1),gbound(1,1)/))
1284 : : ABI_UNUSED((/ug(1),ur(1)/))
1285 : : #endif
1286 : :
1287 : 0 : end subroutine fftw3_fftur_dp
1288 : : !!***
1289 : :
1290 : : !----------------------------------------------------------------------
1291 : :
1292 : : !!****f* m_fftw3/fftw3_fftur_spc
1293 : : !! NAME
1294 : : !! fftw3_fftur_spc
1295 : : !!
1296 : : !! FUNCTION
1297 : : !! Compute ndat zero-padded FFTs from R- to G-space .
1298 : : !! Mainly used for the transform of wavefunctions.
1299 : : !! TARGET: spc arrays
1300 : : !! See fftw3_fftur_dp for API doc.
1301 : : !!
1302 : : !! SOURCE
1303 : :
1304 : 0 : subroutine fftw3_fftur_spc(fftalg, fftcache, npw_k, nx, ny, nz, ldx, ldy, ldz, ndat, &
1305 : 0 : istwf_k, mgfft, kg_k, gbound, ur, ug, &
1306 : : isign, iscale) ! optional
1307 : :
1308 : : !Arguments ------------------------------------
1309 : : !scalars
1310 : : integer,intent(in) :: fftalg,fftcache
1311 : : integer,intent(in) :: npw_k,nx,ny,nz,ldx,ldy,ldz,ndat,istwf_k,mgfft
1312 : : integer,optional,intent(in) :: isign, iscale
1313 : : !arrays
1314 : : integer,intent(in) :: gbound(2*mgfft+8,2),kg_k(3,npw_k)
1315 : : complex(sp),target,intent(inout) :: ur(ldx*ldy*ldz*ndat)
1316 : : complex(sp),target,intent(inout) :: ug(npw_k*ndat)
1317 : :
1318 : : #ifdef HAVE_FFTW3
1319 : : !Local variables-------------------------------
1320 : : !scalars
1321 : : integer,parameter :: dist=1
1322 : : integer :: iscale__, isign__
1323 : : !arrays
1324 : : real(sp) :: dum_ugin(2,0)
1325 : : real(sp),contiguous, pointer :: real_ug(:,:),real_ur(:,:)
1326 : : ! *************************************************************************
1327 : :
1328 : : iscale__ = 1; if (present(iscale)) iscale__ = iscale
1329 : : isign__ = -1; if (present(isign)) isign__ = isign
1330 : :
1331 : : #undef TK_PREF
1332 : : #define TK_PREF(name) CONCAT(cplx_,name)
1333 : : #undef TK_PREF_box2gsph
1334 : : #define TK_PREF_box2gsph cplx_box2gsph
1335 : : #undef TK_PREF_gsph2box
1336 : : #define TK_PREF_gsph2box cplx_gsph2box
1337 : :
1338 : : #undef FFT_PRECISION
1339 : : #define FFT_PRECISION FFT_SINGLE
1340 : :
1341 : : #include "fftur.finc"
1342 : :
1343 : : #undef FFT_PRECISION
1344 : :
1345 : : #else
1346 : : ! Silence compiler warning
1347 : 0 : ABI_ERROR("FFTW3 support not activated")
1348 : : ABI_UNUSED((/fftalg,fftcache/))
1349 : : ABI_UNUSED((/npw_k,nx,ny,nz,ldx,ldy,ldz,ndat,istwf_k,mgfft,kg_k(1,1),gbound(1,1)/))
1350 : : ABI_UNUSED((/ug(1),ur(1)/))
1351 : : #endif
1352 : :
1353 : 0 : end subroutine fftw3_fftur_spc
1354 : : !!***
1355 : :
1356 : : !----------------------------------------------------------------------
1357 : :
1358 : : !!****f* m_fftw3/fftw3_fftur_dpc
1359 : : !! NAME
1360 : : !! fftw3_fftur_dpc
1361 : : !!
1362 : : !! FUNCTION
1363 : : !! Compute ndat zero-padded FFTs from R ro G.
1364 : : !! Mainly used for the transform of wavefunctions.
1365 : : !! TARGET: DP arrays
1366 : : !! See fftw3_fftur_dp for API doc.
1367 : : !!
1368 : : !! SOURCE
1369 : :
1370 : 0 : subroutine fftw3_fftur_dpc(fftalg, fftcache, npw_k, nx, ny, nz, ldx, ldy, ldz, ndat, &
1371 : 0 : istwf_k, mgfft, kg_k, gbound, ur, ug, &
1372 : : isign, iscale) ! optional
1373 : :
1374 : : !Arguments ------------------------------------
1375 : : !scalars
1376 : : integer,intent(in) :: fftalg,fftcache
1377 : : integer,intent(in) :: npw_k,nx,ny,nz,ldx,ldy,ldz,ndat,istwf_k,mgfft
1378 : : integer,optional,intent(in) :: isign, iscale
1379 : : !arrays
1380 : : integer,intent(in) :: gbound(2*mgfft+8,2),kg_k(3,npw_k)
1381 : : complex(dp),target,intent(inout) :: ur(ldx*ldy*ldz*ndat)
1382 : : complex(dp),target,intent(inout) :: ug(npw_k*ndat)
1383 : :
1384 : : #ifdef HAVE_FFTW3
1385 : : !Local variables-------------------------------
1386 : : !scalars
1387 : : integer,parameter :: dist=1
1388 : : integer :: iscale__, isign__
1389 : : !arrays
1390 : : real(dp) :: dum_ugin(2,0)
1391 : : real(dp),contiguous, pointer :: real_ug(:,:),real_ur(:,:)
1392 : : ! *************************************************************************
1393 : :
1394 : : iscale__ = 1; if (present(iscale)) iscale__ = iscale
1395 : : isign__ = -1; if (present(isign)) isign__ = isign
1396 : :
1397 : : #undef TK_PREF
1398 : : #define TK_PREF(name) CONCAT(cplx_,name)
1399 : : #undef TK_PREF_box2gsph
1400 : : #define TK_PREF_box2gsph cplx_box2gsph
1401 : : #undef TK_PREF_gsph2box
1402 : : #define TK_PREF_gsph2box cplx_gsph2box
1403 : :
1404 : : #undef FFT_PRECISION
1405 : : #define FFT_PRECISION FFT_DOUBLE
1406 : :
1407 : : #include "fftur.finc"
1408 : :
1409 : : #undef FFT_PRECISION
1410 : :
1411 : : #else
1412 : : ! Silence compiler warning
1413 : 0 : ABI_ERROR("FFTW3 support not activated")
1414 : : ABI_UNUSED((/fftalg,fftcache/))
1415 : : ABI_UNUSED((/npw_k,nx,ny,nz,ldx,ldy,ldz,ndat,istwf_k,mgfft,kg_k(1,1),gbound(1,1)/))
1416 : : ABI_UNUSED((/ug(1),ur(1)/))
1417 : : #endif
1418 : :
1419 : 0 : end subroutine fftw3_fftur_dpc
1420 : : !!***
1421 : :
1422 : : !----------------------------------------------------------------------
1423 : :
1424 : : !!****f* m_fftw3/fftw3_c2c_ip_spc
1425 : : !! NAME
1426 : : !! fftw3_c2c_ip_spc
1427 : : !!
1428 : : !! FUNCTION
1429 : : !! Driver routine for in-place 3D complex-complex FFT.
1430 : : !! TARGET: Simple precision complex arrays.
1431 : : !!
1432 : : !! INPUTS
1433 : : !! nx,ny,nz=Number of points along the three directions.
1434 : : !! ldx,ldy,ldz=Physical dimensions of the array.
1435 : : !! ndat=Number of FFTs to be done.
1436 : : !! iscale=0 if G --> R FFT should not be scaled.
1437 : : !! isign= +1 : ff(G) => ff(R); -1 : ff(R) => ff(G)
1438 : : !! [fftw_flags]=Flags used to create the plan. They can be combined with the "+" operator.
1439 : : !! Defaults to ABI_FFTW_ESTIMATE.
1440 : : !!
1441 : : !! SIDE EFFECTS
1442 : : !! ff(ldx*ldy*ldz*ndat)=
1443 : : !! In input: the complex array to be transformed.
1444 : : !! In output: the Fourier transformed in the space specified by isign.
1445 : : !!
1446 : : !! SOURCE
1447 : :
1448 : 0 : subroutine fftw3_c2c_ip_spc(nx, ny, nz, ldx, ldy, ldz, ndat, iscale, isign, ff, fftw_flags)
1449 : :
1450 : : !Arguments ------------------------------------
1451 : : !scalars
1452 : : integer,intent(in) :: nx,ny,nz,ldx,ldy,ldz,ndat,iscale,isign
1453 : : integer,optional,intent(in) :: fftw_flags
1454 : : !arrays
1455 : : complex(sp),intent(inout) :: ff(ldx*ldy*ldz*ndat)
1456 : :
1457 : : #ifdef HAVE_FFTW3
1458 : : !Local variables-------------------------------
1459 : : !scalars
1460 : : integer,parameter :: rank3=3,nt_all=-1
1461 : : integer :: my_flags,dist,stride
1462 : : integer(KIND_FFTW_PLAN) :: my_plan
1463 : : !arrays
1464 : : integer :: embed(rank3),n(rank3)
1465 : : ! *************************************************************************
1466 : :
1467 : : my_flags=ABI_FFTW_ESTIMATE; if (PRESENT(fftw_flags)) my_flags=fftw_flags
1468 : :
1469 : : stride = 1
1470 : : dist = ldx*ldy*ldz
1471 : : embed = [ldx, ldy, ldz]
1472 : : n = [nx, ny, nz]
1473 : :
1474 : : my_plan = fftw3_plan_many_dft(rank3, n, ndat, ff, embed, stride, dist, ff, embed, stride, dist, isign, my_flags, nt_all)
1475 : :
1476 : : ! Now perform the 3D FFT via FFTW.
1477 : : call sfftw_execute_dft(my_plan, ff, ff)
1478 : :
1479 : : call fftw3_destroy_plan(my_plan)
1480 : :
1481 : : if (isign == ABI_FFTW_FORWARD .and. iscale /= 0) then ! -1, FFTW returns not normalized FTs
1482 : : call xscal(ldx*ldy*ldz*ndat, REAL(one/(nx*ny*nz),KIND=sp), ff, 1)
1483 : : end if
1484 : :
1485 : : #else
1486 : 0 : ABI_ERROR("FFTW3 support not activated")
1487 : : ABI_UNUSED((/nx,ny,nz,ldx,ldy,ldz,isign/))
1488 : : ABI_UNUSED(ff)
1489 : : if (PRESENT(fftw_flags)) then
1490 : : ABI_UNUSED(fftw_flags)
1491 : : end if
1492 : : #endif
1493 : :
1494 : 0 : end subroutine fftw3_c2c_ip_spc
1495 : : !!***
1496 : :
1497 : : !----------------------------------------------------------------------
1498 : :
1499 : : !!****f* m_fftw3/fftw3_fftpad_spc
1500 : : !! NAME
1501 : : !! fftw3_fftpad_spc
1502 : : !!
1503 : : !! FUNCTION
1504 : : !! This routine transforms wavefunctions using 3D zero-padded FFTs with FFTW3.
1505 : : !! The 3D ffts are computed only on lines and planes which have non zero elements.
1506 : : !! These lines and planes are defined by the two vectors do_fft_x(ldy*nz) and do_fft_y(nz)
1507 : : !! FFT transform is in-place. Target: complex arrays.
1508 : : !!
1509 : : !! INPUTS
1510 : : !! nx,ny,nz=Logical dimensions of the FFT mesh.
1511 : : !! ldx,ldy,ldz=Physical dimension of the f array (to avoid cache conflicts).
1512 : : !! ndat=Number of FFT transforms.
1513 : : !! mgfft=MAX(nx,ny,nz), only used to dimension gbound.
1514 : : !! isign=The sign of the transform.
1515 : : !! gbound(2*mgfft+8,2)= The boundaries of the basis sphere of G vectors at a given k-point.
1516 : : !! See sphereboundary for more info.
1517 : : !!
1518 : : !! SIDE EFFECTS
1519 : : !! ff(ldx*ldy*ldz*ndat)=
1520 : : !! input: The array with the data to be transformed.
1521 : : !! output: The results of the FFT.
1522 : : !!
1523 : : !! SOURCE
1524 : :
1525 : 0 : subroutine fftw3_fftpad_spc(ff, nx, ny, nz, ldx, ldy, ldz, ndat, mgfft, isign, gbound, iscale)
1526 : :
1527 : : !Arguments ------------------------------------
1528 : : !scalars
1529 : : integer,intent(in) :: nx,ny,nz,ldx,ldy,ldz,ndat,mgfft,isign
1530 : : !arrays
1531 : : integer,intent(in) :: gbound(2*mgfft+8,2)
1532 : : complex(sp),intent(inout) :: ff(ldx*ldy*ldz*ndat)
1533 : : integer,optional,intent(in) :: iscale
1534 : :
1535 : : #ifdef HAVE_FFTW3
1536 : : !Local variables-------------------------------
1537 : : integer,parameter :: dst=1
1538 : : integer :: iscale__
1539 : : real(sp) :: fact
1540 : : ! *************************************************************************
1541 : :
1542 : : iscale__ = merge(1, 0, isign == -1); if (present(iscale)) iscale__ = iscale
1543 : :
1544 : : #include "fftw3_fftpad.finc"
1545 : :
1546 : : #else
1547 : 0 : ABI_ERROR("FFTW3 support not activated")
1548 : : ABI_UNUSED((/nx,ny,nz,ldx,ldy,ldz,ndat,mgfft,isign/))
1549 : : ABI_UNUSED(gbound(1,1))
1550 : : ABI_UNUSED(ff(1))
1551 : : #endif
1552 : :
1553 : 0 : end subroutine fftw3_fftpad_spc
1554 : : !!***
1555 : :
1556 : : !----------------------------------------------------------------------
1557 : :
1558 : : !!****f* m_fftw3/fftw3_c2c_ip_dpc
1559 : : !! NAME
1560 : : !! fftw3_c2c_ip_dpc
1561 : : !!
1562 : : !! FUNCTION
1563 : : !! Driver routine for in-place 3D complex-complex FFT.
1564 : : !!
1565 : : !! INPUTS
1566 : : !! nx,ny,nz=Number of points along the three directions.
1567 : : !! ldx,ldy,ldz=Physical dimensions of the array.
1568 : : !! ndat=Number of FFTs to be done.
1569 : : !! iscale=0 if G --> R FFT should not be scaled.
1570 : : !! isign= +1 : ff(G) => ff(R); -1 : ff(R) => ff(G)
1571 : : !! [fftw_flags]=Flags used to create the plan. They can be combined with the "+" operator.
1572 : : !! Defaults to ABI_FFTW_ESTIMATE.
1573 : : !!
1574 : : !! SIDE EFFECTS
1575 : : !! ff(ldx*ldy*ldz*ndat)=
1576 : : !! In input: the complex array to be transformed.
1577 : : !! In output: the Fourier transformed in the space specified by isign.
1578 : : !!
1579 : : !! SOURCE
1580 : :
1581 : 0 : subroutine fftw3_c2c_ip_dpc(nx, ny, nz, ldx, ldy, ldz, ndat, iscale, isign, ff, fftw_flags)
1582 : :
1583 : : !Arguments ------------------------------------
1584 : : !scalars
1585 : : integer,intent(in) :: nx,ny,nz,ldx,ldy,ldz,ndat,iscale,isign
1586 : : integer,optional,intent(in) :: fftw_flags
1587 : : !arrays
1588 : : complex(dp),intent(inout) :: ff(ldx*ldy*ldz*ndat)
1589 : :
1590 : : #ifdef HAVE_FFTW3
1591 : : !Local variables-------------------------------
1592 : : !scalars
1593 : : integer,parameter :: rank3=3,nt_all=-1
1594 : : integer :: my_flags,dist,stride
1595 : : integer(KIND_FFTW_PLAN) :: my_plan
1596 : : !arrays
1597 : : integer :: embed(rank3),n(rank3)
1598 : : ! *************************************************************************
1599 : :
1600 : : my_flags=ABI_FFTW_ESTIMATE; if (PRESENT(fftw_flags)) my_flags=fftw_flags
1601 : :
1602 : : stride = 1
1603 : : dist = ldx*ldy*ldz
1604 : : embed = [ldx, ldy, ldz]
1605 : : n = [nx, ny, nz]
1606 : :
1607 : : my_plan = fftw3_plan_many_dft(rank3, n, ndat, ff, embed, stride, dist, ff, embed, stride, dist, isign, my_flags, nt_all)
1608 : :
1609 : : ! Now perform the 3D FFT via FFTW.
1610 : : call dfftw_execute_dft(my_plan, ff, ff)
1611 : :
1612 : : call fftw3_destroy_plan(my_plan)
1613 : :
1614 : : ! -1, FFTW returns not normalized FTs
1615 : : if (isign == ABI_FFTW_FORWARD .and. iscale /= 0) then
1616 : : call ZDSCAL(ldx*ldy*ldz*ndat, one/(nx*ny*nz), ff, 1)
1617 : : end if
1618 : :
1619 : : #else
1620 : 0 : ABI_ERROR("FFTW3 support not activated")
1621 : : ABI_UNUSED((/nx,ny,nz,ldx,ldy,ldz,isign/))
1622 : : ABI_UNUSED(ff)
1623 : : if (PRESENT(fftw_flags)) then
1624 : : ABI_UNUSED(fftw_flags)
1625 : : end if
1626 : : #endif
1627 : :
1628 : 0 : end subroutine fftw3_c2c_ip_dpc
1629 : : !!***
1630 : :
1631 : : !----------------------------------------------------------------------
1632 : :
1633 : : !!****f* m_fftw3/fftw3_c2c_op_spc
1634 : : !! NAME
1635 : : !! fftw3_c2c_op_spc
1636 : : !!
1637 : : !! FUNCTION
1638 : : !! Driver routine for out-of-place 3D complex-complex FFT of lengths nx, ny, nz.
1639 : : !! TARGET: single precision complex arrays
1640 : : !!
1641 : : !! INPUTS
1642 : : !! nx,ny,nz=Number of points along the three directions.
1643 : : !! ldx,ldy,ldz=Physical dimensions of the array.
1644 : : !! ndat=Number of FFTs to be done.
1645 : : !! iscale=0 if G --> R FFT should not be scaled.
1646 : : !! isign= +1 : ff(G) => gg(R); -1 : ff(R) => gg(G)
1647 : : !! ff(ldx*ldy*ldz*ndat)=The array to be transformed.
1648 : : !! [fftw_flags]=Flags used to create the plan. They can be combined with the "+" operator.
1649 : : !! Defaults to ABI_FFTW_ESTIMATE.
1650 : : !!
1651 : : !! OUTPUT
1652 : : !! gg(ldx*ldy*ldz*ndat)=The FFT of ff.
1653 : : !!
1654 : : !! SOURCE
1655 : :
1656 : 0 : subroutine fftw3_c2c_op_spc(nx, ny, nz, ldx, ldy, ldz, ndat, iscale, isign, ff, gg, fftw_flags)
1657 : :
1658 : : !Arguments ------------------------------------
1659 : : !scalars
1660 : : integer,intent(in) :: nx,ny,nz,ldx,ldy,ldz,iscale,isign,ndat
1661 : : integer,optional,intent(in) :: fftw_flags
1662 : : !arrays
1663 : : complex(sp),intent(in) :: ff(ldx*ldy*ldz*ndat)
1664 : : complex(sp),intent(out) :: gg(ldx*ldy*ldz*ndat)
1665 : :
1666 : : #ifdef HAVE_FFTW3
1667 : : !Local variables-------------------------------
1668 : : !scalars
1669 : : integer,parameter :: rank3=3,nt_all=-1
1670 : : integer :: my_flags,dist,stride
1671 : : integer(KIND_FFTW_PLAN) :: my_plan
1672 : : !arrays
1673 : : integer :: embed(rank3),n(rank3)
1674 : : ! *************************************************************************
1675 : :
1676 : : my_flags=ABI_FFTW_ESTIMATE; if (PRESENT(fftw_flags)) my_flags= fftw_flags
1677 : :
1678 : : stride = 1
1679 : : dist = ldx*ldy*ldz
1680 : : embed = [ldx, ldy, ldz]
1681 : : n = [nx, ny, nz]
1682 : :
1683 : : my_plan = fftw3_plan_many_dft(rank3, n, ndat, ff, embed, stride, dist, gg, embed, stride, dist, isign, my_flags, nt_all)
1684 : :
1685 : : ! Now perform the 3D FFT via FFTW.
1686 : : call sfftw_execute_dft(my_plan, ff, gg)
1687 : :
1688 : : call fftw3_destroy_plan(my_plan)
1689 : :
1690 : : if (isign == ABI_FFTW_FORWARD .and. iscale /= 0) then ! -1, FFTW returns not normalized FTs
1691 : : call xscal(ldx*ldy*ldz*ndat, REAL(one/(nx*ny*nz), KIND=sp), gg, 1)
1692 : : end if
1693 : :
1694 : : #else
1695 : 0 : ABI_ERROR("FFTW3 support not activated")
1696 : : ABI_UNUSED((/nx,ny,nz,ldx,ldy,ldz,isign/))
1697 : : ABI_UNUSED(ff)
1698 : : ABI_UNUSED(gg)
1699 : : if (PRESENT(fftw_flags)) then
1700 : : ABI_UNUSED(fftw_flags)
1701 : : end if
1702 : : #endif
1703 : :
1704 : 0 : end subroutine fftw3_c2c_op_spc
1705 : : !!***
1706 : :
1707 : : !----------------------------------------------------------------------
1708 : :
1709 : : !!****f* m_fftw3/fftw3_c2c_op_dpc
1710 : : !! NAME
1711 : : !! fftw3_c2c_op_dpc
1712 : : !!
1713 : : !! FUNCTION
1714 : : !! Driver routine for out-of-place 3D complex-complex FFT of lengths nx, ny, nz.
1715 : : !! TARGET: single precision complex arrays
1716 : : !!
1717 : : !! INPUTS
1718 : : !! nx,ny,nz=Number of points along the three directions.
1719 : : !! ldx,ldy,ldz=Physical dimensions of the array.
1720 : : !! ndat=Number of FFTs to be done.
1721 : : !! iscale=0 if G --> R FFT should not be scaled.
1722 : : !! isign= +1 : ff(G) => gg(R); -1 : ff(R) => gg(G)
1723 : : !! ff(ldx*ldy*ldz*ndat)=The array to be transformed.
1724 : : !! [fftw_flags]=Flags used to create the plan. They can be combined with the "+" operator.
1725 : : !! Defaults to ABI_FFTW_ESTIMATE.
1726 : : !!
1727 : : !! OUTPUT
1728 : : !! gg(ldx*ldy*ldz*ndat)=The FFT of ff.
1729 : : !!
1730 : : !! SOURCE
1731 : :
1732 : 0 : subroutine fftw3_c2c_op_dpc(nx, ny, nz, ldx, ldy, ldz, ndat, iscale, isign, ff, gg, fftw_flags)
1733 : :
1734 : : !Arguments ------------------------------------
1735 : : !scalars
1736 : : integer,intent(in) :: nx,ny,nz,ldx,ldy,ldz,isign,ndat,iscale
1737 : : integer,optional,intent(in) :: fftw_flags
1738 : : !arrays
1739 : : complex(dp),intent(in) :: ff(ldx*ldy*ldz*ndat)
1740 : : complex(dp),intent(out) :: gg(ldx*ldy*ldz*ndat)
1741 : :
1742 : : #ifdef HAVE_FFTW3
1743 : : !Local variables-------------------------------
1744 : : !scalars
1745 : : integer,parameter :: rank3=3,nt_all=-1
1746 : : integer :: my_flags,dist,stride
1747 : : integer(KIND_FFTW_PLAN) :: my_plan
1748 : : !arrays
1749 : : integer :: embed(rank3),n(rank3)
1750 : : ! *************************************************************************
1751 : :
1752 : : my_flags=ABI_FFTW_ESTIMATE; if (PRESENT(fftw_flags)) my_flags= fftw_flags
1753 : :
1754 : : stride = 1
1755 : : dist = ldx*ldy*ldz
1756 : : embed = [ldx, ldy, ldz]
1757 : : n = [nx, ny, nz]
1758 : :
1759 : : my_plan = fftw3_plan_many_dft(rank3, n, ndat, ff, embed, stride, dist, gg, embed, stride, dist, isign, my_flags, nt_all)
1760 : :
1761 : : ! Now perform the 3D FFT via FFTW.
1762 : : call dfftw_execute_dft(my_plan, ff, gg)
1763 : :
1764 : : call fftw3_destroy_plan(my_plan)
1765 : :
1766 : : if (isign == ABI_FFTW_FORWARD .and. iscale /= 0) then ! -1, FFTW returns not normalized FTs
1767 : : call xscal(ldx*ldy*ldz*ndat, one/(nx*ny*nz), gg, 1)
1768 : : end if
1769 : :
1770 : : #else
1771 : 0 : ABI_ERROR("FFTW3 support not activated")
1772 : : ABI_UNUSED((/nx,ny,nz,ldx,ldy,ldz,isign/))
1773 : : ABI_UNUSED(ff)
1774 : : ABI_UNUSED(gg)
1775 : : if (PRESENT(fftw_flags)) then
1776 : : ABI_UNUSED(fftw_flags)
1777 : : end if
1778 : : #endif
1779 : :
1780 : 0 : end subroutine fftw3_c2c_op_dpc
1781 : : !!***
1782 : :
1783 : : !----------------------------------------------------------------------
1784 : :
1785 : : !!****f* m_fftw3/fftw3_r2c_op
1786 : : !! NAME
1787 : : !! fftw3_r2c_op
1788 : : !!
1789 : : !! FUNCTION
1790 : : !! Driver routine for out-of-place 3D real-to-complex FFT of lengths nx, ny, nz.
1791 : : !!
1792 : : !! INPUTS
1793 : : !! nx,ny,nz=Number of points along the three directions.
1794 : : !! ldx,ldy,ldz=Physical dimensions of the f array (to avoid cache conflicts).
1795 : : !! ff(ldx*ldy*ldz*ndat)=The real array to be transformed.
1796 : : !! ndat=Number of FFTs to be done.
1797 : : !! [fftw_flags]=Flags used to create the plan. They can be combined with the "+" operator.
1798 : : !! Defaults to ABI_FFTW_ESTIMATE.
1799 : : !!
1800 : : !! OUTPUT
1801 : : !! gg(2,nx*ny*nz*ndat)=The forward FFT of ff.
1802 : : !!
1803 : : !! NOTES
1804 : : !! FIXME For the time-being. No augmentation of the mesh to reduce memory conflicts, as MKL crashes
1805 : : !! if the advanced interface is used.
1806 : : !!
1807 : : !! SOURCE
1808 : :
1809 : 0 : subroutine fftw3_r2c_op(nx,ny,nz,ldx,ldy,ldz,ndat,ff,gg,fftw_flags)
1810 : :
1811 : : !Arguments ------------------------------------
1812 : : !scalars
1813 : : integer,intent(in) :: nx,ny,nz,ldx,ldy,ldz,ndat
1814 : : integer,optional,intent(in) :: fftw_flags
1815 : : !arrays
1816 : : real(dp),intent(in) :: ff(ldx*ldy*ldz*ndat)
1817 : : real(dp),intent(out) :: gg(2,ldx*ldy*ldz*ndat)
1818 : :
1819 : : #ifdef HAVE_FFTW3
1820 : : !Local variables-------------------------------
1821 : : !scalars
1822 : : integer,parameter :: rank3=3,nt_all=-1
1823 : : integer :: nhp,my_flags,idist,odist,padx,i1,i2,i3,igp,igf,imgf,stride
1824 : : integer :: i1inv,i2inv,i3inv,idat,padatf
1825 : : integer(KIND_FFTW_PLAN) :: my_plan
1826 : : !arrays
1827 : : integer :: inembed(rank3),onembed(rank3),n(rank3)
1828 : : integer,allocatable :: i1inver(:),i2inver(:),i3inver(:)
1829 : : real(dp),allocatable :: gg_hp(:,:)
1830 : : ! *************************************************************************
1831 : :
1832 : : my_flags=ABI_FFTW_ESTIMATE; if (PRESENT(fftw_flags)) my_flags= fftw_flags
1833 : :
1834 : : idist = ldx*ldy*ldz
1835 : : nhp = (nx/2+1)*ny*nz
1836 : : odist = nhp
1837 : :
1838 : : stride = 1
1839 : : n = (/nx,ny,nz/)
1840 : : inembed= (/ldx,ldy,ldz/)
1841 : : onembed= (/(nx/2+1),ny,nz/)
1842 : :
1843 : : ABI_MALLOC(gg_hp,(2,nhp*ndat))
1844 : :
1845 : : #ifdef DEV_RC_BUG
1846 : : if (ndat/=1) ABI_ERROR("ndat/=1 + MKL not coded")
1847 : :
1848 : : if (ANY( n /= inembed )) then
1849 : : ABI_ERROR("Augmentation not supported")
1850 : : end if
1851 : :
1852 : : call dfftw_plan_dft_r2c_3d(my_plan, nx, ny, nz, ff, gg_hp, my_flags)
1853 : : if (my_plan==NULL_PLAN) then
1854 : : ABI_ERROR("dfftw_plan_dft_r2c_3d returned NULL_PLAN")
1855 : : end if
1856 : :
1857 : : !fftw_plan fftw_plan_many_dft_r2c(int rank3, const int *n, int howmany,
1858 : : ! double *in, const int *inembed, int istride, int idist,
1859 : : ! fftw_complex *out, const int *onembed, int ostride, int odist, unsigned flags);
1860 : : #else
1861 : : my_plan = dplan_many_dft_r2c(rank3, n, ndat, ff, inembed, stride, idist, gg_hp, onembed, stride, odist, my_flags, nt_all)
1862 : : #endif
1863 : :
1864 : : ! Now perform the 3D FFT via FFTW. r2c are always ABI_FFTW_FORWARD
1865 : : call dfftw_execute_dft_r2c(my_plan, ff, gg_hp)
1866 : :
1867 : : call fftw3_destroy_plan(my_plan)
1868 : :
1869 : : ! FFTW returns not normalized FTs
1870 : : call ZDSCAL(nhp*ndat, one/(nx*ny*nz), gg_hp, 1)
1871 : :
1872 : : ! Reconstruct full FFT: Hermitian redundancy: out[i] is the conjugate of out[n-i]
1873 : : padx = (nx/2+1)
1874 : : ABI_MALLOC(i1inver,(padx))
1875 : : ABI_MALLOC(i2inver,(ny))
1876 : : ABI_MALLOC(i3inver,(nz))
1877 : :
1878 : : i1inver(1)=1
1879 : : do i1=2,padx
1880 : : i1inver(i1)=nx+2-i1
1881 : : end do
1882 : :
1883 : : i2inver(1)=1
1884 : : do i2=2,ny
1885 : : i2inver(i2)=ny+2-i2
1886 : : end do
1887 : :
1888 : : i3inver(1)=1
1889 : : do i3=2,nz
1890 : : i3inver(i3)=nz+2-i3
1891 : : end do
1892 : :
1893 : : igp=0
1894 : : do idat=1,ndat
1895 : : padatf = (idat-1)*ldx*ldy*ldz
1896 : : do i3=1,nz
1897 : : i3inv = i3inver(i3)
1898 : : do i2=1,ny
1899 : : i2inv = i2inver(i2)
1900 : : do i1=1,padx
1901 : : igp = igp+1
1902 : : igf = i1 + (i3-1)*ldx*ldy + (i2-1)*ldx + padatf
1903 : : gg(:,igf) = gg_hp(:,igp)
1904 : : i1inv = i1inver(i1)
1905 : : if (i1inv/=i1) then
1906 : : imgf = i1inv + (i3inv-1)*ldx*ldy + (i2inv-1)*ldx + padatf
1907 : : gg(1,imgf) = gg_hp(1,igp)
1908 : : gg(2,imgf) = -gg_hp(2,igp)
1909 : : end if
1910 : : end do
1911 : : end do
1912 : : end do
1913 : : end do
1914 : :
1915 : : ABI_FREE(i1inver)
1916 : : ABI_FREE(i2inver)
1917 : : ABI_FREE(i3inver)
1918 : : ABI_FREE(gg_hp)
1919 : :
1920 : : #else
1921 : 0 : ABI_ERROR("FFTW3 support not activated")
1922 : : ABI_UNUSED((/nx,ny,nz,ldx,ldy,ldz/))
1923 : : ABI_UNUSED(ff)
1924 : : ABI_UNUSED(gg(1,1))
1925 : : if (PRESENT(fftw_flags)) then
1926 : : ABI_UNUSED(fftw_flags)
1927 : : end if
1928 : : #endif
1929 : :
1930 : 0 : end subroutine fftw3_r2c_op
1931 : : !!***
1932 : :
1933 : : !----------------------------------------------------------------------
1934 : :
1935 : : !!****f* m_fftw3/fftw3_c2r_op
1936 : : !! NAME
1937 : : !! fftw3_c2r_op
1938 : : !!
1939 : : !! FUNCTION
1940 : : !! Driver routine for out-of-place 3D complex-to-real FFT of lengths nx, ny, nz.
1941 : : !!
1942 : : !! INPUTS
1943 : : !! nx,ny,nz=Number of point along the three directions.
1944 : : !! ldx,ldy,ldz=Physical dimension of the f array (to avoid cache conflicts).
1945 : : !! ndat=Number of FFTs to be done.
1946 : : !! ff(2*ldx*ldy*ldz*ndat)=The complex array to be transformed.
1947 : : !! [fftw_flags]=Flags used to create the plan. They can be combined with the "+" operator.
1948 : : !! Defaults to ABI_FFTW_ESTIMATE.
1949 : : !!
1950 : : !! OUTPUT
1951 : : !! gg(ldx*ldy*ldz*ndat)=The backwards real FFT of ff.
1952 : : !!
1953 : : !! NOTES
1954 : : !! FIXME For the time-being. No augmentation of the mesh to reduce memory conflicts, as MKL crashes
1955 : : !! if the advanced interface is used.
1956 : : !!
1957 : : !! SOURCE
1958 : :
1959 : 0 : subroutine fftw3_c2r_op(nx,ny,nz,ldx,ldy,ldz,ndat,ff,gg,fftw_flags)
1960 : :
1961 : : !Arguments ------------------------------------
1962 : : !scalars
1963 : : integer,intent(in) :: nx,ny,nz,ldx,ldy,ldz,ndat
1964 : : integer,optional,intent(in) :: fftw_flags
1965 : : !arrays
1966 : : real(dp),intent(in) :: ff(2,ldx*ldy*ldz*ndat)
1967 : : real(dp),intent(out) :: gg(ldx*ldy*ldz*ndat)
1968 : :
1969 : : #ifdef HAVE_FFTW3
1970 : : !Local variables-------------------------------
1971 : : !scalars
1972 : : integer,parameter :: rank3=3,nt_all=-1
1973 : : integer :: nhp,my_flags,padx,i2,i3,igp,igf,idat,padatf,padatp,idist,odist,stride
1974 : : integer(KIND_FFTW_PLAN) :: my_plan
1975 : : !arrays
1976 : : integer :: inembed(rank3),onembed(rank3),n(rank3)
1977 : : real(dp),allocatable :: ff_hp(:,:)
1978 : : ! *************************************************************************
1979 : :
1980 : : #ifdef DEV_RC_BUG
1981 : : if (ANY( (/nx,ny,nz/) /= (/ldx,ldy,ldz/) )) then
1982 : : ABI_ERROR("Augmentation not supported")
1983 : : end if
1984 : : #endif
1985 : :
1986 : : my_flags=ABI_FFTW_ESTIMATE; if (PRESENT(fftw_flags)) my_flags= fftw_flags
1987 : :
1988 : : stride = 1
1989 : : nhp = (nx/2+1)*ny*nz
1990 : : idist = nhp
1991 : : odist = ldx*ldy*ldz
1992 : : n = (/nx,ny,nz/)
1993 : : inembed = (/(nx/2+1),ny,nz/)
1994 : : onembed = (/ldx,ldy,ldz/)
1995 : :
1996 : : ! Fill the Hermitian part: Hermitian redundancy: out[i] is the conjugate of out[n-i]
1997 : : ABI_MALLOC(ff_hp,(2,nhp*ndat))
1998 : :
1999 : : padx = (nx/2+1)
2000 : : do idat=1,ndat
2001 : : padatf=(idat-1)*ldx*ldy*ldz
2002 : : padatp=(idat-1)*padx*ny*nz
2003 : : !$OMP PARALLEL DO PRIVATE(igf,igp)
2004 : : do i3=1,nz
2005 : : do i2=1,ny
2006 : : igf = (i3-1)*ldx*ldy + (i2-1)*ldx + padatf
2007 : : igp = (i3-1)*padx*ny + (i2-1)*padx + padatp
2008 : : ff_hp(:,igp+1:igp+padx) = ff(:,igf+1:igf+padx)
2009 : : end do
2010 : : end do
2011 : : end do
2012 : :
2013 : : ! NOTE: The c2r transform destroys its input array even for out-of-place transforms.
2014 : : #ifdef DEV_RC_BUG
2015 : : if (ndat/=1) ABI_ERROR("ndat/=1 + MKL not coded")
2016 : : call dfftw_plan_dft_c2r_3d(my_plan, nx, ny, nz, ff_hp, gg, my_flags)
2017 : : if (my_plan==NULL_PLAN) then
2018 : : ABI_ERROR("dfftw_plan_dft_c2r_3d returned NULL_PLAN")
2019 : : end if
2020 : : #else
2021 : : my_plan = dplan_many_dft_c2r(rank3, n, ndat, ff_hp, inembed, stride, idist, gg, onembed, stride, odist, my_flags, nt_all)
2022 : : #endif
2023 : :
2024 : : ! Now perform the 3D FFT via FFTW. c2r are always ABI_FFTW_BACKWARD
2025 : : call dfftw_execute_dft_c2r(my_plan, ff_hp, gg)
2026 : :
2027 : : call fftw3_destroy_plan(my_plan)
2028 : : ABI_FREE(ff_hp)
2029 : :
2030 : : #else
2031 : 0 : ABI_ERROR("FFTW3 support not activated")
2032 : : ABI_UNUSED((/nx,ny,nz,ldx,ldy,ldz/))
2033 : : ABI_UNUSED(ff(1,1))
2034 : : ABI_UNUSED(gg(1))
2035 : : if (PRESENT(fftw_flags)) then
2036 : : ABI_UNUSED(fftw_flags)
2037 : : end if
2038 : : #endif
2039 : :
2040 : 0 : end subroutine fftw3_c2r_op
2041 : : !!***
2042 : :
2043 : : !----------------------------------------------------------------------
2044 : :
2045 : : !!****f* m_fftw3/fftw3_many_dft_op
2046 : : !! NAME
2047 : : !! fftw3_many_dft_op
2048 : : !!
2049 : : !! FUNCTION
2050 : : !! Driver routine for many out-of-place 3D complex-to-complex FFTs of lengths nx, ny, nz.
2051 : : !!
2052 : : !! INPUTS
2053 : : !! nx,ny,nz=Number of points along the three directions.
2054 : : !! ldx,ldy,ldz=Physical dimension of the fin and fout arrays (to avoid cache conflicts).
2055 : : !! ndat=Number of FFTs to be done.
2056 : : !! fin(2*ldx*ldy*ldz*ndat)=The complex array to be transformed.
2057 : : !! isign=sign of Fourier transform exponent: current convention uses
2058 : : !! +1 for transforming from G to r,
2059 : : !! -1 for transforming from r to G.
2060 : : !! [fftw_flags]=Flags used to create the plan. They can be combined with the "+" operator.
2061 : : !! Defaults to ABI_FFTW_ESTIMATE.
2062 : : !!
2063 : : !! OUTPUT
2064 : : !! fout(2,ldx*ldy*ldz*ndat)=The Fourier transform of fin.
2065 : : !!
2066 : : !! SOURCE
2067 : :
2068 : 0 : subroutine fftw3_many_dft_op(nx,ny,nz,ldx,ldy,ldz,ndat,isign,fin,fout,fftw_flags)
2069 : :
2070 : : !Arguments ------------------------------------
2071 : : !scalars
2072 : : integer,intent(in) :: nx,ny,nz,ldx,ldy,ldz,ndat,isign
2073 : : integer,optional,intent(in) :: fftw_flags
2074 : : !arrays
2075 : : real(dp),intent(in) :: fin(2*ldx*ldy*ldz*ndat)
2076 : : real(dp),intent(out) :: fout(2*ldx*ldy*ldz*ndat)
2077 : :
2078 : : #ifdef HAVE_FFTW3
2079 : : !Local variables-------------------------------
2080 : : !scalars
2081 : : integer,parameter :: rank3=3,nt_all=-1
2082 : : integer :: my_flags,dist,stride
2083 : : integer(KIND_FFTW_PLAN) :: my_plan
2084 : : !arrays
2085 : : integer :: embed(rank3),n(rank3)
2086 : : ! *************************************************************************
2087 : :
2088 : : my_flags=ABI_FFTW_ESTIMATE; if (PRESENT(fftw_flags)) my_flags= fftw_flags
2089 : :
2090 : : stride = 1
2091 : : dist = ldx*ldy*ldz
2092 : : embed = [ldx, ldy, ldz]
2093 : : n = [nx, ny, nz]
2094 : :
2095 : : my_plan = fftw3_plan_many_dft(rank3, n, ndat, fin, embed, stride, dist, fout, embed, stride, dist, isign, my_flags, nt_all)
2096 : :
2097 : : ! Now perform the 3D FFT via FFTW.
2098 : : call dfftw_execute_dft(my_plan, fin, fout)
2099 : :
2100 : : call fftw3_destroy_plan(my_plan)
2101 : :
2102 : : ! -1, FFTW returns not normalized FTs
2103 : : if (isign == ABI_FFTW_FORWARD) then
2104 : : call ZDSCAL(ldx*ldy*ldz*ndat, one/(nx*ny*nz), fout, 1)
2105 : : end if
2106 : :
2107 : : #else
2108 : 0 : ABI_ERROR("FFTW3 support not activated")
2109 : : ABI_UNUSED((/nx,ny,nz,ldx,ldy,ldz,ndat,isign/))
2110 : : if (PRESENT(fftw_flags)) then
2111 : : ABI_UNUSED(fftw_flags)
2112 : : end if
2113 : : ABI_UNUSED(fin(1))
2114 : : ABI_UNUSED(fout(1))
2115 : : #endif
2116 : :
2117 : 0 : end subroutine fftw3_many_dft_op
2118 : : !!***
2119 : :
2120 : : !----------------------------------------------------------------------
2121 : :
2122 : : !!****f* m_fftw3/fftw3_many_dft_ip
2123 : : !! NAME
2124 : : !! fftw3_many_dft_ip
2125 : : !!
2126 : : !! FUNCTION
2127 : : !! Driver routine for many in-place 3D complex-to-complex FFTs of lengths nx, ny, nz.
2128 : : !!
2129 : : !! INPUTS
2130 : : !! nx,ny,nz=Number of points along the three directions.
2131 : : !! ldx,ldy,ldz=Physical dimension of the finout array (to avoid cache conflicts).
2132 : : !! ndat=Number of FFTs to be done.
2133 : : !! isign=sign of Fourier transform exponent: current convention uses
2134 : : !! +1 for transforming from G to r,
2135 : : !! -1 for transforming from r to G.
2136 : : !! [fftw_flags]=Flags used to create the plan. They can be combined with the "+" operator.
2137 : : !! Defaults to ABI_FFTW_ESTIMATE.
2138 : : !!
2139 : : !! OUTPUT
2140 : : !! finout(2,ldx*ldy*ldz*ndat)=
2141 : : !! In input: The complex array to be transformed.
2142 : : !! In output: The FFT results.
2143 : : !!
2144 : : !! SOURCE
2145 : :
2146 : 0 : subroutine fftw3_many_dft_ip(nx,ny,nz,ldx,ldy,ldz,ndat,isign,finout,fftw_flags)
2147 : :
2148 : : !Arguments ------------------------------------
2149 : : !scalars
2150 : : integer,intent(in) :: nx,ny,nz,ldx,ldy,ldz,ndat,isign
2151 : : integer,optional,intent(in) :: fftw_flags
2152 : : !arrays
2153 : : real(dp),intent(inout) :: finout(2*ldx*ldy*ldz*ndat)
2154 : :
2155 : : #ifdef HAVE_FFTW3
2156 : : !Local variables-------------------------------
2157 : : !scalars
2158 : : integer,parameter :: rank3=3,nt_all=-1
2159 : : integer :: my_flags,dist,stride
2160 : : integer(KIND_FFTW_PLAN) :: my_plan
2161 : : !arrays
2162 : : integer :: embed(rank3),n(rank3)
2163 : : ! *************************************************************************
2164 : :
2165 : : my_flags=ABI_FFTW_ESTIMATE; if (PRESENT(fftw_flags)) my_flags= fftw_flags
2166 : :
2167 : : stride = 1
2168 : : dist = ldx*ldy*ldz
2169 : : embed = [ldx, ldy, ldz]
2170 : : n = [nx, ny, nz]
2171 : :
2172 : : my_plan = fftw3_plan_many_dft(rank3, n, ndat, finout, embed, stride, dist, finout, embed, stride, dist, isign, my_flags, nt_all)
2173 : :
2174 : : ! Now perform the 3D FFT via FFTW.
2175 : : call dfftw_execute_dft(my_plan, finout, finout)
2176 : : call fftw3_destroy_plan(my_plan)
2177 : :
2178 : : ! -1, FFTW returns not normalized FTs
2179 : : if (isign == ABI_FFTW_FORWARD) then
2180 : : call ZDSCAL(ldx*ldy*ldz*ndat, one/(nx*ny*nz), finout, 1)
2181 : : end if
2182 : :
2183 : : #else
2184 : 0 : ABI_ERROR("FFTW3 support not activated")
2185 : : ABI_UNUSED((/nx,ny,nz,ldx,ldy,ldz,ndat,isign/))
2186 : : if (PRESENT(fftw_flags)) then
2187 : : ABI_UNUSED(fftw_flags)
2188 : : end if
2189 : : ABI_UNUSED(finout(1))
2190 : : #endif
2191 : :
2192 : 0 : end subroutine fftw3_many_dft_ip
2193 : : !!***
2194 : :
2195 : : !----------------------------------------------------------------------
2196 : :
2197 : : !!****f* m_fftw3/fftw3_cleanup
2198 : : !! NAME
2199 : : !! fftw3_cleanup
2200 : : !!
2201 : : !! FUNCTION
2202 : : !! Reset FFTW to the pristine state it was in when you started your program,
2203 : : !! All existing plans become undefined.
2204 : : !!
2205 : : !! NOTES
2206 : : !! FFTW planner saves some other persistent data, such as the accumulated wisdom and a list of
2207 : : !! algorithms available in the current configuration. If you want to deallocate all of that and reset
2208 : : !! FFTW to the pristine state it was in when you started your program, you can call fftw3_cleanup();
2209 : : !! After calling fftw3_cleanup, all existing plans become undefined, and you should not attempt to
2210 : : !! execute them nor to destroy them. You can however create and execute/destroy new plans, in which case
2211 : : !! FFTW starts accumulating wisdom information again.
2212 : : !! fftw3_cleanup does not deallocate your plans, however. To prevent memory leaks, you must still call
2213 : : !! fftw_destroy_plan before executing fftw3_cleanup
2214 : : !!
2215 : : !! SOURCE
2216 : :
2217 : 0 : subroutine fftw3_cleanup()
2218 : :
2219 : : #ifdef HAVE_FFTW3_MPI
2220 : : call fftw_mpi_cleanup()
2221 : : #endif
2222 : : #ifdef HAVE_FFTW3_THREADS
2223 : : if (THREADS_INITED==1) then
2224 : : call dfftw_cleanup_threads()
2225 : : THREADS_INITED = 0
2226 : : end if
2227 : : #elif defined HAVE_FFTW3
2228 : : call dfftw_cleanup()
2229 : : #else
2230 : 0 : ABI_ERROR("FFTW3 support not activated")
2231 : : #endif
2232 : :
2233 : 0 : end subroutine fftw3_cleanup
2234 : : !!***
2235 : :
2236 : : !----------------------------------------------------------------------
2237 : :
2238 : : !!****f* m_fftw3/fftw3_destroy_plan
2239 : : !! NAME
2240 : : !! fftw3_destroy_plan
2241 : : !!
2242 : : !! FUNCTION
2243 : : !! Release the memory allocate for the plan.
2244 : : !!
2245 : : !! INPUTS
2246 : : !!
2247 : : !! SOURCE
2248 : :
2249 : : subroutine fftw3_destroy_plan(plan)
2250 : :
2251 : : !Arguments ------------------------------------
2252 : : !scalars
2253 : : integer(KIND_FFTW_PLAN),intent(in) :: plan
2254 : : ! *************************************************************************
2255 : :
2256 : : #ifdef HAVE_FFTW3
2257 : : !$OMP CRITICAL (OMPC_fftw3_destroy_plan)
2258 : : call dfftw_destroy_plan(plan)
2259 : : !$OMP END CRITICAL (OMPC_fftw3_destroy_plan)
2260 : :
2261 : : #else
2262 : : if (.FALSE.) write(std_out,*)plan
2263 : : #endif
2264 : :
2265 : : end subroutine fftw3_destroy_plan
2266 : : !!***
2267 : :
2268 : : !----------------------------------------------------------------------
2269 : :
2270 : : !!****f* m_fftw3/fftw3_init_threads
2271 : : !! NAME
2272 : : !! fftw3_init_threads
2273 : : !!
2274 : : !! FUNCTION
2275 : : !! This function performs the one-time initialization required to use FFTW3 threads.
2276 : : !! It does nothing if HAVE_FFT_FFTW3_THREADS is not defined.
2277 : : !!
2278 : : !! INPUTS
2279 : : !!
2280 : : !! SIDE EFFECTS
2281 : : !! The one-time initialization required to use FFTW3 threads is performed when the routine
2282 : : !! is called for the first time.
2283 : : !!
2284 : : !! SOURCE
2285 : :
2286 : 0 : subroutine fftw3_init_threads()
2287 : :
2288 : : !Local variables ------------------------------
2289 : : !scalars
2290 : : #ifdef HAVE_FFTW3_THREADS
2291 : : integer :: iret
2292 : : #endif
2293 : : ! *************************************************************************
2294 : :
2295 : : #ifdef HAVE_FFTW3_THREADS
2296 : : if (THREADS_INITED==0) then
2297 : : !call wrtout(std_out,"Calling dfftw_init_threads()")
2298 : : call dfftw_init_threads(iret)
2299 : :
2300 : : if (iret==0) then
2301 : : ABI_WARNING(" dfftw_init_threads returned 0; threaded FFTW3 is not being used!")
2302 : : else
2303 : : THREADS_INITED=1
2304 : : end if
2305 : : call fftw3_set_nthreads()
2306 : : end if
2307 : :
2308 : : #ifndef HAVE_OPENMP
2309 : : ABI_WARNING("Using FFTW3 with threads but HAVE_OPENMP is not defined!")
2310 : : #endif
2311 : : #endif
2312 : :
2313 : : #ifdef HAVE_FFTW3_MPI
2314 : : !call wrtout(std_out,"Calling fftw_mpi_init()")
2315 : : call fftw_mpi_init()
2316 : : #endif
2317 : :
2318 : 0 : end subroutine fftw3_init_threads
2319 : : !!***
2320 : :
2321 : : !----------------------------------------------------------------------
2322 : :
2323 : : !!****f* m_fftw3/fftw3_set_nthreads
2324 : : !! NAME
2325 : : !! fftw3_set_nthreads
2326 : : !!
2327 : : !! FUNCTION
2328 : : !! This function sets the number of threads you want FFTW3 to use (or actually, the maximum number).
2329 : : !! It also performs any one-time initialization required to use FFTW3 threads.
2330 : : !! All plans subsequently created with any planner routine will use nthreads threads.
2331 : : !! If you pass an nthreads argument of 1 (the default), threads are disabled for subsequent plans.
2332 : : !! It does nothing if HAVE_FFT_FFTW3_THREADS is not defined.
2333 : : !!
2334 : : !! INPUTS
2335 : : !! [nthreads]=The number of threads you want FFTW3 to use. Default xomp_get_max_threads()
2336 : : !!
2337 : : !! SOURCE
2338 : :
2339 : 0 : subroutine fftw3_set_nthreads(nthreads)
2340 : :
2341 : : !Arguments ------------------------------------
2342 : : integer,optional,intent(in) :: nthreads
2343 : :
2344 : : !Local variables ------------------------------
2345 : : !scalars
2346 : : #ifdef HAVE_FFTW3_THREADS
2347 : : integer :: istat,nt
2348 : : integer,parameter :: enough=1
2349 : : integer,save :: nwarns=0
2350 : : #endif
2351 : : ! *************************************************************************
2352 : :
2353 : : #ifdef HAVE_FFTW3_THREADS
2354 : : if (THREADS_INITED==0) then
2355 : : ABI_WARNING("Threads are not initialized")
2356 : : end if
2357 : :
2358 : : if (PRESENT(nthreads)) then
2359 : : if (nthreads<=0) then
2360 : : nt = xomp_get_max_threads()
2361 : : else
2362 : : nt = nthreads
2363 : : end if
2364 : : else
2365 : : nt = xomp_get_max_threads()
2366 : : end if
2367 : :
2368 : : call dfftw_plan_with_nthreads(nt)
2369 : :
2370 : : #ifndef HAVE_OPENMP
2371 : : if (nwarns <= enough) then
2372 : : nwarns = nwarns + 1
2373 : : ABI_WARNING("Using FFTW3 with threads but HAVE_OPENMP is not defined!")
2374 : : end if
2375 : : #endif
2376 : :
2377 : : #else
2378 : : if (PRESENT(nthreads)) then
2379 : : ABI_UNUSED(nthreads)
2380 : : end if
2381 : : #endif
2382 : :
2383 : 0 : end subroutine fftw3_set_nthreads
2384 : : !!***
2385 : :
2386 : : !----------------------------------------------------------------------
2387 : :
2388 : : !!****f* m_fftw3/fftw3_fftpad_dp
2389 : : !! NAME
2390 : : !! fftw3_fftpad_dp
2391 : : !!
2392 : : !! FUNCTION
2393 : : !! This routine transforms wavefunctions using 3D zero-padded FFTs with FFTW3.
2394 : : !! The 3D ffts are computed only on lines and planes which have non zero elements.
2395 : : !! These lines and planes are defined by the two vectors do_fft_x(ldy*nz) and do_fft_y(nz)
2396 : : !! FFT transform is in-place.
2397 : : !!
2398 : : !! INPUTS
2399 : : !! nx,ny,nz=Logical dimensions of the FFT mesh.
2400 : : !! ldx,ldy,ldz=Physical dimension of the f array (to avoid cache conflicts).
2401 : : !! ndat=Number of FFT transforms.
2402 : : !! mgfft=MAX(nx,ny,nz), only used to dimension gbound
2403 : : !! isign=The sign of the transform.
2404 : : !! gbound(2*mgfft+8,2)= The boundaries of the basis sphere of G vectors at a given k-point.
2405 : : !! See sphereboundary for more info.
2406 : : !!
2407 : : !! SIDE EFFECTS
2408 : : !! ff(2*ldx*ldy*ldz*ndat)=
2409 : : !! input: The array with the data to be transformed.
2410 : : !! output: The results of the FFT.
2411 : : !!
2412 : : !! SOURCE
2413 : :
2414 : 0 : subroutine fftw3_fftpad_dp(ff, nx, ny, nz, ldx, ldy, ldz, ndat, mgfft, isign, gbound, iscale)
2415 : :
2416 : : !Arguments ------------------------------------
2417 : : !scalars
2418 : : integer,intent(in) :: nx,ny,nz,ldx,ldy,ldz,ndat,mgfft,isign
2419 : : !arrays
2420 : : integer,intent(in) :: gbound(2*mgfft+8,2)
2421 : : real(dp),intent(inout) :: ff(2*ldx*ldy*ldz*ndat)
2422 : : integer,optional,intent(in) :: iscale
2423 : :
2424 : : !Local variables-------------------------------
2425 : : !scalars
2426 : : #ifdef HAVE_FFTW3
2427 : : integer,parameter :: dst=2
2428 : : integer :: iscale__
2429 : : real(dp) :: fact
2430 : : ! *************************************************************************
2431 : :
2432 : : iscale__ = merge(1, 0, isign == -1); if (present(iscale)) iscale__ = iscale
2433 : :
2434 : : #include "fftw3_fftpad.finc"
2435 : :
2436 : : #else
2437 : 0 : ABI_ERROR("FFTW3 support not activated")
2438 : : ABI_UNUSED((/nx,ny,nz,ldx,ldy,ldz,mgfft,isign/))
2439 : : ABI_UNUSED(gbound(1,1))
2440 : : ABI_UNUSED(ff(1))
2441 : : #endif
2442 : :
2443 : 0 : end subroutine fftw3_fftpad_dp
2444 : : !!***
2445 : :
2446 : : !----------------------------------------------------------------------
2447 : :
2448 : : !!****f* m_fftw3/fftw3_fftpad_dpc
2449 : : !! NAME
2450 : : !! fftw3_fftpad_dpc
2451 : : !!
2452 : : !! FUNCTION
2453 : : !! This routine transforms wavefunctions using 3D zero-padded FFTs with FFTW3.
2454 : : !! The 3D ffts are computed only on lines and planes which have non zero elements.
2455 : : !! These lines and planes are defined by the two vectors do_fft_x(ldy*nz) and do_fft_y(nz)
2456 : : !! FFT transform is in-place. Target: complex arrays.
2457 : : !!
2458 : : !! INPUTS
2459 : : !! nx,ny,nz=Logical dimensions of the FFT mesh.
2460 : : !! ldx,ldy,ldz=Physical dimension of the f array (to avoid cache conflicts).
2461 : : !! ndat=Number of FFT transforms.
2462 : : !! mgfft=MAX(nx,ny,nz), only used to dimension gbound.
2463 : : !! isign=The sign of the transform.
2464 : : !! gbound(2*mgfft+8,2)= The boundaries of the basis sphere of G vectors at a given k-point.
2465 : : !! See sphereboundary for more info.
2466 : : !!
2467 : : !! SIDE EFFECTS
2468 : : !! ff(ldx*ldy*ldz*ndat)=
2469 : : !! input: The array with the data to be transformed.
2470 : : !! output: The results of the FFT.
2471 : : !!
2472 : : !! SOURCE
2473 : :
2474 : 0 : subroutine fftw3_fftpad_dpc(ff, nx, ny, nz, ldx, ldy, ldz, ndat, mgfft, isign, gbound, iscale)
2475 : :
2476 : : !Arguments ------------------------------------
2477 : : !scalars
2478 : : integer,intent(in) :: nx,ny,nz,ldx,ldy,ldz,ndat,mgfft,isign
2479 : : integer,optional,intent(in) :: iscale
2480 : : !arrays
2481 : : integer,intent(in) :: gbound(2*mgfft+8,2)
2482 : : complex(dp),intent(inout) :: ff(ldx*ldy*ldz*ndat)
2483 : :
2484 : : #ifdef HAVE_FFTW3
2485 : : !Local variables-------------------------------
2486 : : integer,parameter :: dst=1
2487 : : integer :: iscale__
2488 : : real(dp) :: fact
2489 : : ! *************************************************************************
2490 : :
2491 : : iscale__ = merge(1, 0, isign == -1); if (present(iscale)) iscale__ = iscale
2492 : :
2493 : : #include "fftw3_fftpad.finc"
2494 : :
2495 : : #else
2496 : 0 : ABI_ERROR("FFTW3 support not activated")
2497 : : ABI_UNUSED((/nx,ny,nz,ldx,ldy,ldz,ndat,mgfft,isign/))
2498 : : ABI_UNUSED(gbound(1,1))
2499 : : ABI_UNUSED(ff(1))
2500 : : #endif
2501 : :
2502 : 0 : end subroutine fftw3_fftpad_dpc
2503 : : !!***
2504 : :
2505 : : #ifdef HAVE_FFTW3
2506 : :
2507 : : !----------------------------------------------------------------------
2508 : :
2509 : : !!****f* m_fftw3/dplan_many_dft_1D
2510 : : !! NAME
2511 : : !!
2512 : : !! FUNCTION
2513 : : !!
2514 : : !! INPUTS
2515 : : !!
2516 : : !! SIDE EFFECTS
2517 : : !!
2518 : : !! SOURCE
2519 : :
2520 : : function dplan_many_dft_1D(rank,n,howmany,fin,inembed,istride,idist,fout,onembed,ostride,odist,sign,flags,nthreads) result(plan)
2521 : :
2522 : : !Arguments ------------------------------------
2523 : : !scalars
2524 : : integer,intent(in) :: rank,howmany,istride,ostride, sign,flags,idist,odist,nthreads
2525 : : integer,intent(in) :: n(rank),inembed(rank),onembed(rank)
2526 : : integer(KIND_FFTW_PLAN) :: plan
2527 : : !arrays
2528 : : real(dp) :: fin(*),fout(*)
2529 : :
2530 : : !Local variables-------------------------------
2531 : : character(len=500) :: msg,frmt
2532 : : ! *************************************************************************
2533 : :
2534 : : !$OMP CRITICAL (OMPC_dfftw_plan_many_dft_1D)
2535 : : call fftw3_set_nthreads(nthreads)
2536 : :
2537 : : call dfftw_plan_many_dft(plan, rank, n, howmany, &
2538 : : fin, inembed, istride, idist, fout, onembed, ostride, odist, sign, flags)
2539 : : !$OMP END CRITICAL (OMPC_dfftw_plan_many_dft_1D)
2540 : :
2541 : : if (plan==NULL_PLAN) then
2542 : : call wrtout(std_out, "dfftw_plan_many_dft returned NULL_PLAN!")
2543 : : write(frmt,*)"(a,",rank,"(1x,i0),3(a,i0),a,2(a,",rank,"(1x,i0),2(a,i0),a))"
2544 : : write(msg,frmt)&
2545 : : " n= ",n," howmany= ",howmany," sign= ",sign," flags= ",flags,ch10,&
2546 : : " inembed= ",inembed," istride= ",istride," idist=",idist,ch10, &
2547 : : " onembed= ",onembed," ostride= ",ostride," odist=",idist,ch10
2548 : : call wrtout(std_out, msg)
2549 : : ABI_ERROR("Check FFTW library and/or abinit code")
2550 : : end if
2551 : :
2552 : : end function dplan_many_dft_1D
2553 : : !!***
2554 : :
2555 : : !----------------------------------------------------------------------
2556 : :
2557 : : !!****f* m_fftw3/dplan_many_dft_2D
2558 : : !! NAME
2559 : : !!
2560 : : !! FUNCTION
2561 : : !!
2562 : : !! INPUTS
2563 : : !!
2564 : : !! SOURCE
2565 : :
2566 : : function dplan_many_dft_2D(rank,n,howmany,fin,inembed,istride,idist,fout,onembed,ostride,odist,sign,flags,nthreads) result(plan)
2567 : :
2568 : : !Arguments ------------------------------------
2569 : : !scalars
2570 : : integer,intent(in) :: rank,howmany,istride,ostride, sign,flags,idist,odist,nthreads
2571 : : integer,intent(in) :: n(rank),inembed(rank),onembed(rank)
2572 : : integer(KIND_FFTW_PLAN) :: plan
2573 : : !arrays
2574 : : real(dp) :: fin(2,*),fout(2,*)
2575 : :
2576 : : !Local variables-------------------------------
2577 : : character(len=500) :: msg,frmt
2578 : : ! *************************************************************************
2579 : :
2580 : : !$OMP CRITICAL (OMPC_dfftw_plan_many_dft_2D)
2581 : : call fftw3_set_nthreads(nthreads)
2582 : :
2583 : : call dfftw_plan_many_dft(plan, rank, n, howmany, &
2584 : : fin, inembed, istride, idist, fout, onembed, ostride, odist, sign, flags)
2585 : : !$OMP END CRITICAL (OMPC_dfftw_plan_many_dft_2D)
2586 : :
2587 : : if (plan==NULL_PLAN) then
2588 : : call wrtout(std_out, "dfftw_plan_many_dft returned NULL_PLAN!")
2589 : : write(frmt,*)"(a,",rank,"(1x,i0),3(a,i0),a,2(a,",rank,"(1x,i0),2(a,i0),a))"
2590 : : write(msg,frmt)&
2591 : : " n= ",n," howmany= ",howmany," sign= ",sign," flags= ",flags,ch10,&
2592 : : " inembed= ",inembed," istride= ",istride," idist=",idist,ch10, &
2593 : : " onembed= ",onembed," ostride= ",ostride," odist=",idist,ch10
2594 : : call wrtout(std_out, msg)
2595 : : ABI_ERROR("Check FFTW library and/or abinit code")
2596 : : end if
2597 : :
2598 : : end function dplan_many_dft_2D
2599 : : !!***
2600 : :
2601 : : !----------------------------------------------------------------------
2602 : :
2603 : : !!****f* m_fftw3/cplan_many_dft
2604 : : !! NAME
2605 : : !!
2606 : : !! FUNCTION
2607 : : !!
2608 : : !! INPUTS
2609 : : !!
2610 : : !! SIDE EFFECTS
2611 : : !!
2612 : : !! SOURCE
2613 : : !! FIXME technically it should be intent(inout) since FFTW3 can destroy the input for particular flags.
2614 : :
2615 : : function cplan_many_dft(rank,n,howmany,fin,inembed,istride,idist,fout,onembed,ostride,odist,sign,flags,nthreads) result(plan)
2616 : :
2617 : : !Arguments ------------------------------------
2618 : : !scalars
2619 : : integer,intent(in) :: rank,howmany,istride,ostride, sign,flags,idist,odist,nthreads
2620 : : integer,intent(in) :: n(rank),inembed(rank),onembed(rank)
2621 : : integer(KIND_FFTW_PLAN) :: plan
2622 : : !arrays
2623 : : complex(sp) :: fin(*),fout(*)
2624 : :
2625 : : !Local variables-------------------------------
2626 : : character(len=500) :: msg,frmt
2627 : : ! *************************************************************************
2628 : :
2629 : : !$OMP CRITICAL (OMPC_cplan_many_dft)
2630 : : call fftw3_set_nthreads(nthreads)
2631 : :
2632 : : call sfftw_plan_many_dft(plan, rank, n, howmany, &
2633 : : fin, inembed, istride, idist, fout, onembed, ostride, odist, sign, flags)
2634 : : !$OMP END CRITICAL (OMPC_cplan_many_dft)
2635 : :
2636 : : if (plan==NULL_PLAN) then ! handle the error
2637 : : call wrtout(std_out, "sfftw_plan_many_dft returned NULL_PLAN (complex version)")
2638 : : write(frmt,*)"(a,",rank,"(1x,i0),3(a,i0),a,2(a,",rank,"(1x,i0),2(a,i0),a))"
2639 : : write(msg,frmt)&
2640 : : " n = ",n," howmany = ",howmany," sign = ",sign," flags = ",flags,ch10,&
2641 : : " inembed = ",inembed," istride = ",istride," idist =",idist,ch10, &
2642 : : " onembed = ",onembed," ostride = ",ostride," odist =",idist,ch10
2643 : : call wrtout(std_out, msg)
2644 : : ABI_ERROR("Check FFTW library and/or abinit code")
2645 : : end if
2646 : :
2647 : : end function cplan_many_dft
2648 : : !!***
2649 : :
2650 : : !----------------------------------------------------------------------
2651 : :
2652 : : !!****f* m_fftw3/zplan_many_dft
2653 : : !! NAME
2654 : : !!
2655 : : !! FUNCTION
2656 : : !!
2657 : : !! INPUTS
2658 : : !!
2659 : : !! SIDE EFFECTS
2660 : : !!
2661 : : !! SOURCE
2662 : : !! FIXME technically it should be intent(inout) since FFTW3 can destroy the input for particular flags.
2663 : :
2664 : : function zplan_many_dft(rank,n,howmany,fin,inembed,istride,idist,fout,onembed,ostride,odist,sign,flags,nthreads) result(plan)
2665 : :
2666 : : !Arguments ------------------------------------
2667 : : !scalars
2668 : : integer,intent(in) :: rank,howmany,istride,ostride, sign,flags,idist,odist,nthreads
2669 : : integer,intent(in) :: n(rank),inembed(rank),onembed(rank)
2670 : : integer(KIND_FFTW_PLAN) :: plan
2671 : : !arrays
2672 : : complex(dp) :: fin(*),fout(*)
2673 : :
2674 : : !Local variables-------------------------------
2675 : : character(len=500) :: msg,frmt
2676 : : ! *************************************************************************
2677 : :
2678 : : !$OMP CRITICAL (OMPC_zplan_many_dft)
2679 : : call fftw3_set_nthreads(nthreads)
2680 : :
2681 : : call dfftw_plan_many_dft(plan, rank, n, howmany, &
2682 : : fin, inembed, istride, idist, fout, onembed, ostride, odist, sign, flags)
2683 : : !$OMP END CRITICAL (OMPC_zplan_many_dft)
2684 : :
2685 : : if (plan==NULL_PLAN) then ! handle the error
2686 : : call wrtout(std_out, "dfftw_plan_many_dft returned NULL_PLAN (complex version)")
2687 : : write(frmt,*)"(a,",rank,"(1x,i0),3(a,i0),a,2(a,",rank,"(1x,i0),2(a,i0),a))"
2688 : : write(msg,frmt)&
2689 : : " n = ",n," howmany = ",howmany," sign = ",sign," flags = ",flags,ch10,&
2690 : : " inembed = ",inembed," istride = ",istride," idist =",idist,ch10, &
2691 : : " onembed = ",onembed," ostride = ",ostride," odist =",idist,ch10
2692 : : call wrtout(std_out, msg)
2693 : : ABI_ERROR("Check FFTW library and/or abinit code")
2694 : : end if
2695 : :
2696 : : end function zplan_many_dft
2697 : : !!***
2698 : :
2699 : : !----------------------------------------------------------------------
2700 : :
2701 : : !!****f* m_fftw3/dplan_many_dft_r2c
2702 : : !! NAME
2703 : : !!
2704 : : !! FUNCTION
2705 : : !!
2706 : : !! INPUTS
2707 : : !!
2708 : : !! SIDE EFFECTS
2709 : : !!
2710 : : !! SOURCE
2711 : : !! FIXME technically it should be intent(inout) since FFTW3 can destroy the input
2712 : : !! for particular flags.
2713 : :
2714 : : function dplan_many_dft_r2c(rank,n,howmany,fin,inembed,istride,idist,fout,onembed,ostride,odist,flags,nthreads) result(plan)
2715 : :
2716 : : !Arguments ------------------------------------
2717 : : !scalars
2718 : : integer,intent(in) :: rank,howmany,istride,ostride,flags,idist,odist,nthreads
2719 : : integer,intent(in) :: n(rank),inembed(rank),onembed(rank)
2720 : : integer(KIND_FFTW_PLAN) :: plan
2721 : : !arrays
2722 : : real(dp) :: fin(*),fout(*)
2723 : :
2724 : : !Local variables-------------------------------
2725 : : character(len=500) :: msg,frmt
2726 : : ! *************************************************************************
2727 : :
2728 : : !$OMP CRITICAL (OMPC_dplan_many_dft_r2c)
2729 : : call fftw3_set_nthreads(nthreads)
2730 : :
2731 : : call dfftw_plan_many_dft_r2c(plan, rank, n, howmany, &
2732 : : fin, inembed, istride, idist, fout, onembed, ostride, odist, flags)
2733 : : !$OMP END CRITICAL (OMPC_dplan_many_dft_r2c)
2734 : :
2735 : : if (plan==NULL_PLAN) then ! handle the error.
2736 : : call wrtout(std_out, "dfftw_plan_many_dft_r2c returned NULL_PLAN")
2737 : : write(frmt,*)"(a,",rank,"(1x,i0),2(a,i0),a,2(a,",rank,"(1x,i0),2(a,i0),a))"
2738 : : write(msg,frmt)&
2739 : : " n = ",n," howmany = ",howmany," flags = ",flags,ch10,&
2740 : : " inembed = ",inembed," istride = ",istride," idist = ",idist,ch10,&
2741 : : " onembed = ",onembed," ostride = ",ostride," odist = ",idist,ch10
2742 : : call wrtout(std_out, msg)
2743 : : ABI_ERROR("Check FFTW library and/or abinit code")
2744 : : end if
2745 : :
2746 : : end function dplan_many_dft_r2c
2747 : : !!***
2748 : :
2749 : : !----------------------------------------------------------------------
2750 : :
2751 : : !!****f* m_fftw3/dplan_many_dft_c2r
2752 : : !! NAME
2753 : : !!
2754 : : !! FUNCTION
2755 : : !!
2756 : : !! INPUTS
2757 : : !!
2758 : : !! SIDE EFFECTS
2759 : : !!
2760 : : !! SOURCE
2761 : :
2762 : : function dplan_many_dft_c2r(rank,n,howmany,fin,inembed,istride,idist,fout,onembed,ostride,odist,flags, nthreads) result(plan)
2763 : :
2764 : : !Arguments ------------------------------------
2765 : : !scalars
2766 : : integer,intent(in) :: rank,howmany,istride,ostride,flags,idist,odist,nthreads
2767 : : integer,intent(in) :: n(rank),inembed(rank),onembed(rank)
2768 : : integer(KIND_FFTW_PLAN) :: plan
2769 : : !arrays
2770 : : real(dp) :: fin(*),fout(*)
2771 : :
2772 : : !Local variables-------------------------------
2773 : : character(len=500) :: msg,frmt
2774 : : ! *************************************************************************
2775 : :
2776 : : !$OMP CRITICAL (OMPC_dplan_many_dft_c2r)
2777 : : call fftw3_set_nthreads(nthreads)
2778 : :
2779 : : call dfftw_plan_many_dft_c2r(plan, rank, n, howmany, &
2780 : : fin, inembed, istride, idist, fout, onembed, ostride, odist, flags)
2781 : : !$OMP END CRITICAL (OMPC_dplan_many_dft_c2r)
2782 : :
2783 : : if (plan==NULL_PLAN) then ! handle the error.
2784 : : call wrtout(std_out, "dfftw_plan_many_dft_c2r returned NULL_PLAN")
2785 : : write(frmt,*)"(a,",rank,"(1x,i0),2(a,i0),a,2(a,",rank,"(1x,i0),2(a,i0),a))"
2786 : : write(msg,frmt)&
2787 : : " n = ",n," howmany = ",howmany," flags = ",flags,ch10,&
2788 : : " inembed = ",inembed," istride = ",istride," idist = ",idist,ch10,&
2789 : : " onembed = ",onembed," ostride = ",ostride," odist = ",idist,ch10
2790 : : call wrtout(std_out, msg)
2791 : : ABI_ERROR("Check FFTW library and/or abinit code")
2792 : : end if
2793 : :
2794 : : end function dplan_many_dft_c2r
2795 : : !!***
2796 : :
2797 : : #endif
2798 : :
2799 : : !----------------------------------------------------------------------
2800 : :
2801 : : !!****f* m_fftw3/fftw3_execute_dft_dp
2802 : : !! NAME
2803 : : !! fftw3_execute_dft_dp
2804 : : !!
2805 : : !! FUNCTION
2806 : : !!
2807 : : !! INPUTS
2808 : : !!
2809 : : !! OUTPUT
2810 : : !!
2811 : : !! NOTES
2812 : : !! This interface is used to perform complex to complex FFT with real arrays
2813 : : !! containing the real and imaginary part. I have to admit that this interface
2814 : : !! is a bit ambiguous since FFTW3 provides routines for real-to-real transforms.
2815 : : !!
2816 : : !! SOURCE
2817 : :
2818 : : #ifdef HAVE_FFTW3
2819 : :
2820 : : subroutine fftw3_execute_dft_dp(plan, in, out)
2821 : :
2822 : : !Arguments ------------------------------------
2823 : : !scalars
2824 : : integer(KIND_FFTW_PLAN),intent(in) :: plan
2825 : : real(C_DOUBLE),intent(inout) :: in(*)
2826 : : real(C_DOUBLE),intent(out) :: out(*)
2827 : : ! *************************************************************************
2828 : :
2829 : : call dfftw_execute_dft(plan, in, out)
2830 : :
2831 : : end subroutine fftw3_execute_dft_dp
2832 : : !!***
2833 : :
2834 : : #endif
2835 : :
2836 : : !----------------------------------------------------------------------
2837 : :
2838 : : !!****f* m_fftw3/fftw3_execute_dft_spc
2839 : : !! NAME
2840 : : !! fftw3_execute_dft_spc
2841 : : !!
2842 : : !! SOURCE
2843 : :
2844 : : #ifdef HAVE_FFTW3
2845 : :
2846 : : subroutine fftw3_execute_dft_spc(plan, in, out)
2847 : :
2848 : : !Arguments ------------------------------------
2849 : : !scalars
2850 : : integer(KIND_FFTW_PLAN),intent(in) :: plan
2851 : : complex(C_FLOAT_COMPLEX),intent(inout) :: in(*)
2852 : : complex(C_FLOAT_COMPLEX),intent(out) :: out(*)
2853 : : ! *************************************************************************
2854 : :
2855 : : call sfftw_execute_dft(plan, in, out)
2856 : :
2857 : : end subroutine fftw3_execute_dft_spc
2858 : : !!***
2859 : :
2860 : : #endif
2861 : :
2862 : : !----------------------------------------------------------------------
2863 : :
2864 : : !!****f* m_fftw3/fftw3_execute_dft_dpc
2865 : : !! NAME
2866 : : !! fftw3_execute_dft_dpc
2867 : : !!
2868 : : !! SOURCE
2869 : :
2870 : : #ifdef HAVE_FFTW3
2871 : :
2872 : : subroutine fftw3_execute_dft_dpc(plan, in, out)
2873 : :
2874 : : !Arguments ------------------------------------
2875 : : !scalars
2876 : : integer(KIND_FFTW_PLAN),intent(in) :: plan
2877 : : complex(C_DOUBLE_COMPLEX),intent(inout) :: in(*)
2878 : : complex(C_DOUBLE_COMPLEX),intent(out) :: out(*)
2879 : : ! *************************************************************************
2880 : :
2881 : : call dfftw_execute_dft(plan, in, out)
2882 : :
2883 : : end subroutine fftw3_execute_dft_dpc
2884 : : !!***
2885 : :
2886 : : #endif
2887 : :
2888 : : !----------------------------------------------------------------------
2889 : :
2890 : : !!****f* m_fftw3/fftw3_alloc_real1d_dp
2891 : : !! NAME
2892 : : !! fftw3_alloc_real1d_dp
2893 : : !!
2894 : : !! FUNCTION
2895 : : !!
2896 : : !! SOURCE
2897 : :
2898 : : #ifdef HAVE_FFTW3
2899 : :
2900 : : subroutine fftw3_alloc_real1d_dp(size,cptr,fptr)
2901 : :
2902 : : !Arguments ------------------------------------
2903 : : !scalars
2904 : : integer,intent(in) :: size
2905 : : real(dp),contiguous, pointer :: fptr(:)
2906 : : type(C_PTR),intent(out) :: cptr
2907 : : ! *************************************************************************
2908 : :
2909 : : cptr = fftw_malloc( INT(size*C_DOUBLE, KIND=C_SIZE_T))
2910 : : if (.not. C_ASSOCIATED(cptr)) then
2911 : : ABI_ERROR("fftw_malloc returned NULL!")
2912 : : end if
2913 : :
2914 : : call c_f_pointer(cptr, fptr, [size])
2915 : :
2916 : : end subroutine fftw3_alloc_real1d_dp
2917 : : !!***
2918 : :
2919 : : #endif
2920 : :
2921 : : !----------------------------------------------------------------------
2922 : :
2923 : : !!****f* m_fftw3/fftw3_alloc_real2d_dp
2924 : : !! NAME
2925 : : !! fftw3_alloc_real2d_dp
2926 : : !!
2927 : : !! SOURCE
2928 : :
2929 : : #ifdef HAVE_FFTW3
2930 : :
2931 : : subroutine fftw3_alloc_real2d_dp(shape,cptr,fptr)
2932 : :
2933 : : !Arguments ------------------------------------
2934 : : !scalars
2935 : : integer,intent(in) :: shape(2)
2936 : : real(dp),contiguous, pointer :: fptr(:,:)
2937 : : type(C_PTR),intent(out) :: cptr
2938 : : ! *************************************************************************
2939 : :
2940 : : cptr = fftw_malloc( INT(product(shape)*C_DOUBLE, KIND=C_SIZE_T))
2941 : : if (.not. C_ASSOCIATED(cptr)) then
2942 : : ABI_ERROR("fftw_malloc returned NULL!")
2943 : : end if
2944 : :
2945 : : call c_f_pointer(cptr, fptr, shape)
2946 : :
2947 : : end subroutine fftw3_alloc_real2d_dp
2948 : : !!***
2949 : :
2950 : : #endif
2951 : :
2952 : : !----------------------------------------------------------------------
2953 : :
2954 : : !!****f* m_fftw3/fftw3_alloc_complex1d_spc
2955 : : !! NAME
2956 : : !! fftw3_alloc_complex1d_spc
2957 : : !!
2958 : : !! SOURCE
2959 : :
2960 : : #ifdef HAVE_FFTW3
2961 : :
2962 : : subroutine fftw3_alloc_complex1d_spc(size,cptr,fptr)
2963 : :
2964 : : !Arguments ------------------------------------
2965 : : !scalars
2966 : : integer,intent(in) :: size
2967 : : complex(sp),contiguous, pointer :: fptr(:)
2968 : : type(C_PTR),intent(out) :: cptr
2969 : : ! *************************************************************************
2970 : :
2971 : : cptr = fftw_malloc( INT(2*size*C_FLOAT, KIND=C_SIZE_T))
2972 : : if (.not. C_ASSOCIATED(cptr)) then
2973 : : ABI_ERROR("fftw_malloc returned NULL!")
2974 : : end if
2975 : :
2976 : : call c_f_pointer(cptr, fptr, [size])
2977 : :
2978 : : end subroutine fftw3_alloc_complex1d_spc
2979 : : !!***
2980 : :
2981 : : #endif
2982 : :
2983 : : !----------------------------------------------------------------------
2984 : :
2985 : : !!****f* m_fftw3/fftw3_alloc_complex1d_dpc
2986 : : !! NAME
2987 : : !! fftw3_alloc_complex1d_dpc
2988 : : !!
2989 : : !! SOURCE
2990 : :
2991 : : #ifdef HAVE_FFTW3
2992 : :
2993 : : subroutine fftw3_alloc_complex1d_dpc(size,cptr,fptr)
2994 : :
2995 : : !Arguments ------------------------------------
2996 : : !scalars
2997 : : integer,intent(in) :: size
2998 : : complex(dp),contiguous, pointer :: fptr(:)
2999 : : type(C_PTR),intent(out) :: cptr
3000 : : ! *************************************************************************
3001 : :
3002 : : cptr = fftw_malloc( INT(2*size*C_DOUBLE, KIND=C_SIZE_T))
3003 : : if (.not. C_ASSOCIATED(cptr)) then
3004 : : ABI_ERROR("fftw_malloc returned NULL!")
3005 : : end if
3006 : :
3007 : : call c_f_pointer(cptr, fptr, [size])
3008 : :
3009 : : end subroutine fftw3_alloc_complex1d_dpc
3010 : : !!***
3011 : :
3012 : : #endif
3013 : :
3014 : : !----------------------------------------------------------------------
3015 : :
3016 : : !!****f* m_fftw3/fftw3_spawn_threads_here
3017 : : !! NAME
3018 : : !! fftw3_spawn_threads_here
3019 : : !!
3020 : : !! FUNCTION
3021 : : !! Helper function that returns true if FFT calls should be OMP
3022 : : !! parallelized in the client code.
3023 : : !!
3024 : : !! INPUTS
3025 : : !! ndat=Number of FFT transforms to do
3026 : : !! nthreads = Number of threads available
3027 : : !!
3028 : : !! SOURCE
3029 : :
3030 : 0 : function fftw3_spawn_threads_here(ndat,nthreads) result(ans)
3031 : :
3032 : : !Arguments ------------------------------------
3033 : : !scalars
3034 : : integer,intent(in) :: ndat,nthreads
3035 : : logical :: ans
3036 : : ! *************************************************************************
3037 : :
3038 : 0 : ans = .FALSE.
3039 : : #ifdef HAVE_OPENMP
3040 : : ans = (nthreads > 1 .and. MOD(ndat,nthreads) == 0 .and. .not. USE_LIB_THREADS)
3041 : : #else
3042 : : ABI_UNUSED((/ndat,nthreads/))
3043 : : #endif
3044 : :
3045 : 0 : end function fftw3_spawn_threads_here
3046 : : !!***
3047 : :
3048 : : !----------------------------------------------------------------------
3049 : :
3050 : : !!****f* m_fftw3/fftw3_use_lib_threads
3051 : : !! NAME
3052 : : !! fftw3_use_lib_threads
3053 : : !!
3054 : : !! FUNCTION
3055 : : !!
3056 : : !! INPUTS
3057 : : !!
3058 : : !! SOURCE
3059 : :
3060 : 19 : subroutine fftw3_use_lib_threads(logvar)
3061 : :
3062 : : !Arguments ------------------------------------
3063 : : logical,intent(in) :: logvar
3064 : : ! *************************************************************************
3065 : :
3066 : 19 : USE_LIB_THREADS = logvar
3067 : :
3068 : 19 : end subroutine fftw3_use_lib_threads
3069 : : !!***
3070 : :
3071 : : !----------------------------------------------------------------------
3072 : :
3073 : : !!****f* m_fftw3/fftwmpi_get_work_array
3074 : : !! NAME
3075 : : !! fftwmpi_get_work_array
3076 : : !!
3077 : : !! FUNCTION
3078 : : !! Driver routine for allocate fftw work array for 3D complex-to-complex FFTs of lengths nx, ny, nz.
3079 : : !!
3080 : : !! INPUTS
3081 : : !! nx,ny,nz=Number of points along the three directions.
3082 : : !! ndat=Number of FFTs to be done.
3083 : : !! comm_fft=MPI communicator.
3084 : : !!
3085 : : !! OUTPUT
3086 : : !! cdata_f,cdata_r: C pointers to use for fourier andreal data
3087 : : !! n0,n0_tr : local size on the shared dimension (nz or ny if transposed mode is used)
3088 : : !! offset,offset_tr : offset per process in continuous tabx
3089 : : !!
3090 : : !! SOURCE
3091 : :
3092 : : subroutine fftwmpi_get_work_array(cdata_f,cdata_r,rank,nx,ny,nz,ndat,comm_fft,n0,offset,n0_tr,offset_tr)
3093 : :
3094 : : !Arguments ------------------------------------
3095 : : !scalars
3096 : : integer,intent(in) :: nx,ny,nz,ndat,rank,comm_fft
3097 : : integer(C_INTPTR_T), intent(out) :: n0, offset, n0_tr, offset_tr
3098 : : type(C_PTR), intent(out) :: cdata_f,cdata_r
3099 : :
3100 : : !Local variables-------------------------------
3101 : : #ifdef HAVE_FFTW3_MPI
3102 : : !scalars
3103 : : integer(C_INTPTR_T) :: alloc_local
3104 : : !arrays
3105 : : integer(C_INTPTR_T) :: fft_sizes(4)
3106 : : ! *************************************************************************
3107 : :
3108 : : ! Dimensions are inverted here (C interface).
3109 : : fft_sizes(1)=nz
3110 : : fft_sizes(2)=ny
3111 : : fft_sizes(3)=nx
3112 : : fft_sizes(4)=ndat
3113 : :
3114 : : alloc_local = fftw_mpi_local_size_many_transposed(rank,fft_sizes(1:3),fft_sizes(4), &
3115 : : & FFTW_MPI_DEFAULT_BLOCK,FFTW_MPI_DEFAULT_BLOCK, comm_fft, &
3116 : : & n0,offset, &
3117 : : & n0_tr,offset_tr)
3118 : :
3119 : : cdata_f = fftw_alloc_complex(alloc_local)
3120 : : cdata_r = fftw_alloc_complex(alloc_local)
3121 : :
3122 : : #else
3123 : : ABI_ERROR("FFTW3_MPI support not activated")
3124 : : ABI_UNUSED((/nx,ny,nz,ndat,rank,comm_fft/))
3125 : : cdata_f = C_NULL_PTR; cdata_r = C_NULL_PTR
3126 : : n0 = 0; offset = 0; n0_tr = 0; offset_tr = 0
3127 : : #endif
3128 : :
3129 : : end subroutine fftwmpi_get_work_array
3130 : : !!***
3131 : :
3132 : : !----------------------------------------------------------------------
3133 : :
3134 : : !!****f* m_fftw3/fftwmpi_free_work_array
3135 : : !! NAME
3136 : : !! fftwmpi_free_work_array
3137 : : !!
3138 : : !! FUNCTION
3139 : : !! routine for freeing fftw work array
3140 : : !!
3141 : : !! INPUTS
3142 : : !!
3143 : : !! OUTPUT
3144 : : !! cdata_f,cdata_r: C pointers to free for fourier andreal data
3145 : : !!
3146 : : !! SOURCE
3147 : :
3148 : : subroutine fftwmpi_free_work_array(cdata_f,cdata_r)
3149 : :
3150 : : !Arguments ------------------------------------
3151 : : !scalars
3152 : : type(C_PTR), intent(inout) :: cdata_f,cdata_r
3153 : : ! *************************************************************************
3154 : :
3155 : : #ifdef HAVE_FFTW3_MPI
3156 : : call fftw_free(cdata_r)
3157 : : call fftw_free(cdata_f)
3158 : : #else
3159 : : ABI_ERROR("FFTW3_MPI support not activated")
3160 : : if(.false.) then
3161 : : cdata_r = C_NULL_PTR; cdata_f = C_NULL_PTR
3162 : : end if
3163 : : #endif
3164 : :
3165 : : end subroutine fftwmpi_free_work_array
3166 : : !!***
3167 : :
3168 : : !----------------------------------------------------------------------
3169 : :
3170 : : !!****f* m_fftw3/fftw3mpi_many_dft_ip
3171 : : !! NAME
3172 : : !! fftw3mpi_many_dft_ip
3173 : : !!
3174 : : !! FUNCTION
3175 : : !! Driver routine for many out-of-place 3D complex-to-complex FFTs of lengths nx, ny, nz.
3176 : : !!
3177 : : !! INPUTS
3178 : : !! nx,ny,nz=Number of points along the three directions.
3179 : : !! ldx,ldy,ldz=Physical dimension of the fin and fout arrays (to avoid cache conflicts).
3180 : : !! ndat=Number of FFTs to be done.
3181 : : !! fin(2*ldx*ldy*ldz*ndat)=The complex array to be transformed.
3182 : : !! isign=sign of Fourier transform exponent: current convention uses
3183 : : !! +1 for transforming from G to r,
3184 : : !! -1 for transforming from r to G.
3185 : : !! comm_fft=MPI communicator for the FFT
3186 : : !! [fftw_flags]=Flags used to create the plan. They can be combined with the "+" operator.
3187 : : !! Defaults to ABI_FFTW_ESTIMATE.
3188 : : !!
3189 : : !! TODO
3190 : : !! Remove me
3191 : : !!
3192 : : !! OUTPUT
3193 : : !! fout(2,ldx*ldy*ldz*ndat)=The Fourier transform of fin.
3194 : : !!
3195 : : !! SOURCE
3196 : :
3197 : : subroutine fftw3mpi_many_dft_ip(nx,ny,nz,ldx,ldy,ldz,ndat,isign,fin,fout,comm_fft,fftw_flags)
3198 : :
3199 : : !Arguments ------------------------------------
3200 : : !scalars
3201 : : integer,intent(in) :: nx,ny,nz,ldx,ldy,ldz,ndat,isign,comm_fft
3202 : : integer,optional,intent(in) :: fftw_flags
3203 : : !arrays
3204 : : real(dp),intent(in) :: fin(2,ldx,ldy,ldz*ndat)
3205 : : real(dp),intent(out) :: fout(2,ldx,ldy,ldz*ndat)
3206 : :
3207 : : #ifdef HAVE_FFTW3_MPI
3208 : : !Local variables-------------------------------
3209 : : !scalars
3210 : : integer,parameter :: rank3=3
3211 : : integer :: my_flags
3212 : : real(dp):: factor_fft
3213 : : !arrays
3214 : : type(C_PTR) :: plan, cdata
3215 : : complex(C_DOUBLE_COMPLEX), contiguous, pointer :: data(:,:,:)
3216 : : integer(C_INTPTR_T) :: i, j, k, alloc_local, local_n0, local_0_start,fft_sizes(4)
3217 : : !*************************************************************************
3218 : :
3219 : : my_flags=ABI_FFTW_ESTIMATE; if (PRESENT(fftw_flags)) my_flags= fftw_flags
3220 : :
3221 : : ! get local data size and allocate (note dimension reversal)
3222 : : fft_sizes = [nz,ny,nx,ndat]
3223 : :
3224 : : alloc_local = fftw_mpi_local_size_many( &
3225 : : rank3,fft_sizes(1:3),fft_sizes(4),&
3226 : : FFTW_MPI_DEFAULT_BLOCK, comm_fft, &
3227 : : local_n0,local_0_start)
3228 : :
3229 : : ! Allocate cdata, build the plane and copy data: fin --> data
3230 : : cdata = fftw_alloc_complex(alloc_local)
3231 : : call c_f_pointer(cdata, data, [fft_sizes(3),fft_sizes(2), local_n0])
3232 : :
3233 : : plan = fftw_mpi_plan_many_dft(rank3,fft_sizes(1:3),fft_sizes(4), &
3234 : : FFTW_MPI_DEFAULT_BLOCK,FFTW_MPI_DEFAULT_BLOCK, &
3235 : : data,data,comm_fft,isign,my_flags)
3236 : :
3237 : : do k=1, local_n0*ndat
3238 : : do j=1, ny
3239 : : do i=1, nx
3240 : : data(i,j,k) = CMPLX( fin(1,i,j,k),fin(2,i,j,k),C_DOUBLE_COMPLEX)
3241 : : end do
3242 : : end do
3243 : : end do
3244 : :
3245 : : ! Compute transform.
3246 : : call fftw_mpi_execute_dft(plan, data, data)
3247 : :
3248 : : if(isign==ABI_FFTW_FORWARD) then
3249 : : ! Scale results.
3250 : : factor_fft = one / (nx*ny*nz)
3251 : : do k=1, local_n0*ndat
3252 : : do j=1, ny
3253 : : do i=1, nx
3254 : : fout(1,i,j,k) = real(data(i,j,k)) * factor_fft
3255 : : fout(2,i,j,k) = aimag(data(i,j,k)) * factor_fft
3256 : : end do
3257 : : end do
3258 : : end do
3259 : : end if
3260 : :
3261 : : call fftw_destroy_plan(plan)
3262 : : call fftw_free(cdata)
3263 : :
3264 : : #else
3265 : : ABI_ERROR("FFTW3_MPI support not activated")
3266 : : ABI_UNUSED((/nx,ny,nz,ldx,ldy,ldz,ndat,isign/))
3267 : : ABI_UNUSED(comm_fft)
3268 : : if (PRESENT(fftw_flags)) then
3269 : : ABI_UNUSED(fftw_flags)
3270 : : end if
3271 : : ABI_UNUSED(fin(1,1,1,1))
3272 : : ABI_UNUSED(fout(1,1,1,1))
3273 : : #endif
3274 : :
3275 : : end subroutine fftw3mpi_many_dft_ip
3276 : : !!***
3277 : :
3278 : : !----------------------------------------------------------------------
3279 : :
3280 : : !!****f* m_fftw3/fftw3mpi_many_dft_tr
3281 : : !! NAME
3282 : : !! fftw3mpi_many_dft_tr
3283 : : !!
3284 : : !! FUNCTION
3285 : : !! Driver routine for many out-of-place 3D complex-to-complex FFTs of lengths nx, ny, nz.
3286 : : !!
3287 : : !! INPUTS
3288 : : !! nx,ny,nz=Number of points along the three directions.
3289 : : !! ldx,ldy,ldz=Physical dimension of the fin and fout arrays (to avoid cache conflicts).
3290 : : !! ndat=Number of FFTs to be done.
3291 : : !! fin(2*ldx*ldy*ldz*ndat)=The complex array to be transformed.
3292 : : !! isign=sign of Fourier transform exponent: current convention uses
3293 : : !! +1 for transforming from G to r,
3294 : : !! -1 for transforming from r to G.
3295 : : !! comm_fft=MPI communicator for the FFT.
3296 : : !! [fftw_flags]=Flags used to create the plan. They can be combined with the "+" operator.
3297 : : !! Defaults to ABI_FFTW_ESTIMATE.
3298 : : !!
3299 : : !! TODO
3300 : : !! Remove me
3301 : : !!
3302 : : !! OUTPUT
3303 : : !! fout(2,ldx*ldy*ldz*ndat)=The Fourier transform of fin.
3304 : : !!
3305 : : !! SOURCE
3306 : :
3307 : : subroutine fftw3mpi_many_dft_tr(nx,ny,nz,ndat,isign,fin,fout,comm_fft,fftw_flags)
3308 : :
3309 : : !Arguments ------------------------------------
3310 : : !scalars
3311 : : integer,intent(in) :: nx,ny,nz,ndat,isign,comm_fft
3312 : : integer,optional,intent(in) :: fftw_flags
3313 : : !arrays
3314 : : complex(C_DOUBLE_COMPLEX),contiguous, pointer :: fin(:,:,:)
3315 : : complex(C_DOUBLE_COMPLEX),contiguous, pointer :: fout(:,:,:)
3316 : :
3317 : : !Local variables-------------------------------
3318 : : #ifdef HAVE_FFTW3_MPI
3319 : : !scalars
3320 : : integer :: my_flags
3321 : : !FFTWMPI stuff
3322 : : type(C_PTR) :: plan
3323 : : integer(C_INTPTR_T) :: fft_sizes(4)
3324 : : !*************************************************************************
3325 : :
3326 : : my_flags=ABI_FFTW_ESTIMATE; if (PRESENT(fftw_flags)) my_flags= fftw_flags
3327 : : my_flags = ior(my_flags,FFTW_DESTROY_INPUT)
3328 : :
3329 : : fft_sizes(1)=nz
3330 : : fft_sizes(2)=ny
3331 : : fft_sizes(3)=nx
3332 : : fft_sizes(4)=ndat
3333 : :
3334 : : plan = fftw_mpi_plan_many_dft(3,fft_sizes(1:3),fft_sizes(4), &
3335 : : & FFTW_MPI_DEFAULT_BLOCK,FFTW_MPI_DEFAULT_BLOCK, &
3336 : : & fin,fout,comm_fft,isign,my_flags)
3337 : :
3338 : : !Compute transform (as many times as desired)
3339 : : call fftw_mpi_execute_dft(plan, fin, fout)
3340 : : call fftw_destroy_plan(plan)
3341 : :
3342 : : #else
3343 : : ABI_ERROR("FFTW3_MPI support not activated")
3344 : : ABI_UNUSED((/nx,ny,nz,ndat,isign,comm_fft/))
3345 : : if (PRESENT(fftw_flags)) then
3346 : : ABI_UNUSED(fftw_flags)
3347 : : end if
3348 : : ABI_UNUSED(fin(1,1,1))
3349 : : ABI_UNUSED(fout(1,1,1))
3350 : : #endif
3351 : :
3352 : : end subroutine fftw3mpi_many_dft_tr
3353 : : !!***
3354 : :
3355 : : !----------------------------------------------------------------------
3356 : :
3357 : : !!****f* m_fftw3/fftw3_mpifourdp_c2r
3358 : : !! NAME
3359 : : !! fftw3_mpifourdp_c2r
3360 : : !!
3361 : : !! FUNCTION
3362 : : !! Driver routine for transposed out-of-place 3D complex-to-real FFT of lengths nx, ny, nz.
3363 : : !!
3364 : : !! INPUTS
3365 : : !! nx,ny,nz=Number of point along the three directions.
3366 : : !! ndat=Number of FFTs to be done.
3367 : : !! fofg(2,nx*ny*nz*ndat)=The complex array to be transformed.
3368 : : !! comm_fft=MPI communicator.
3369 : : !! [fftw_flags]=Flags used to create the plan. They can be combined with the "+" operator.
3370 : : !! Defaults to ABI_FFTW_ESTIMATE.
3371 : : !!
3372 : : !! OUTPUT
3373 : : !! fofr(2,nx*ny*nz*ndat)=The backwards real FFT of ff.
3374 : : !!
3375 : : !! NOTES
3376 : : !! LOCAL DATA IN FOURIER SPACE : TRANSPOSED ORDER
3377 : : !! real space --> dim = [ nx | ny | nz/np_fft]
3378 : : !! fourier space --> dim = [ nx/2 | nz | ny/np_ff ]
3379 : : !!
3380 : : !! SOURCE
3381 : :
3382 : : subroutine fftw3_mpifourdp_c2r(nfft,ngfft,ndat,&
3383 : : fftn2_distrib,ffti2_local,fftn3_distrib,ffti3_local,fofg,fofr,comm_fft,fftw_flags)
3384 : :
3385 : : !Arguments ------------------------------------
3386 : : !scalars
3387 : : integer,intent(in) :: nfft,ndat,comm_fft
3388 : : integer,optional,intent(in) :: fftw_flags
3389 : : !arrays
3390 : : integer,intent(in) :: ngfft(18)
3391 : : integer,intent(in) :: fftn2_distrib(ngfft(2)),ffti2_local(ngfft(2))
3392 : : integer,intent(in) :: fftn3_distrib(ngfft(3)),ffti3_local(ngfft(3))
3393 : : real(dp),intent(in) :: fofg(2,nfft*ndat)
3394 : : real(dp),intent(out) :: fofr(nfft*ndat)
3395 : :
3396 : : !Local variables-------------------------------
3397 : : #ifdef HAVE_FFTW3_MPI
3398 : : !scalars
3399 : : integer,parameter :: rank3=3
3400 : : integer :: nx,ny,nz,nproc_fft
3401 : : type(C_PTR) :: plan_bw, cdata_cplx,cdata_real
3402 : : integer(C_INTPTR_T) :: i,j,jdat,k,alloc_local,fft_sizes(4),demi_nx,base,idat,kdat
3403 : : integer(C_INTPTR_T) :: local_n0, local_0_start, local_n1, local_1_start
3404 : : !arrays
3405 : : complex(C_DOUBLE_COMPLEX), contiguous, pointer :: data_cplx(:,:,:)
3406 : : real(C_DOUBLE), contiguous, pointer :: data_real(:,:,:)
3407 : : ! *************************************************************************
3408 : :
3409 : : !ABI_CHECK(ndat==1, "ndat > 1 not implemented yet")
3410 : :
3411 : : nx=ngfft(1); ny=ngfft(2); nz=ngfft(3)
3412 : : nproc_fft = xmpi_comm_size(comm_fft)
3413 : :
3414 : : demi_nx = nx/2 + 1
3415 : : fft_sizes(1)=nz
3416 : : fft_sizes(2)=ny
3417 : : fft_sizes(3)=demi_nx
3418 : : fft_sizes(4)=ndat
3419 : :
3420 : : alloc_local = fftw_mpi_local_size_many_transposed(&
3421 : : rank3,fft_sizes(1:3),fft_sizes(4), &
3422 : : FFTW_MPI_DEFAULT_BLOCK,FFTW_MPI_DEFAULT_BLOCK, comm_fft, &
3423 : : local_n0,local_0_start, &
3424 : : local_n1,local_1_start)
3425 : :
3426 : : cdata_cplx = fftw_alloc_complex(alloc_local)
3427 : : cdata_real = fftw_alloc_real(alloc_local*2)
3428 : :
3429 : : ! OLD BY FDHAM
3430 : : ! dimensions are (x/2,z,y) in Fourier's Space
3431 : : call c_f_pointer(cdata_cplx, data_cplx, [demi_nx ,fft_sizes(1),local_n1])
3432 : : ! dimensions in real space : (nx,ny,nz/nproc)
3433 : : call c_f_pointer(cdata_real, data_real, [2*demi_nx,fft_sizes(2),local_n0])
3434 : :
3435 : : ! dimensions are (x/2,z,y) in Fourier's Space
3436 : : !call c_f_pointer(cdata_cplx, data_cplx, [demi_nx ,fft_sizes(1),local_n0])
3437 : :
3438 : : !! dimensions in real space : (nx,ny,nz/nproc)
3439 : : !call c_f_pointer(cdata_real, data_real, [2*demi_nx,fft_sizes(2),local_n1])
3440 : :
3441 : : fft_sizes(3)=nx
3442 : : plan_bw = fftw_mpi_plan_many_dft_c2r(&
3443 : : rank3,fft_sizes(1:3),fft_sizes(4), &
3444 : : FFTW_MPI_DEFAULT_BLOCK,FFTW_MPI_DEFAULT_BLOCK, &
3445 : : data_cplx, data_real , &
3446 : : comm_fft,ior(ABI_FFTW_ESTIMATE,ABI_FFTW_MPI_TRANSPOSED_IN))
3447 : :
3448 : : do idat=1,ndat
3449 : : do k=1, nz
3450 : : do j=1, ny / nproc_fft
3451 : : jdat = j + (idat-1) * ny / nproc_fft
3452 : : base = nx*((j-1) + (ny/nproc_fft)*(k-1)) + (idat-1) * nfft
3453 : : do i=1, demi_nx
3454 : : data_cplx(i,k,jdat) = CMPLX(fofg(1, i + base), fofg(2, i + base), kind=C_DOUBLE_COMPLEX)
3455 : : end do
3456 : : end do
3457 : : end do
3458 : : end do
3459 : :
3460 : : ! compute transform (as many times as desired)
3461 : : call fftw_mpi_execute_dft_c2r(plan_bw, data_cplx, data_real)
3462 : :
3463 : : do idat=1,ndat
3464 : : do k=1,local_n0
3465 : : kdat = k + (idat - 1) * local_n0
3466 : : do j=1,ny
3467 : : base = nx*((j-1) + ny*(k-1)) + (idat - 1) * nfft
3468 : : do i=1,nx
3469 : : fofr(i+base) = data_real(i,j,kdat)
3470 : : end do
3471 : : end do
3472 : : end do
3473 : : end do
3474 : :
3475 : : call fftw_destroy_plan(plan_bw)
3476 : : call fftw_free(cdata_cplx)
3477 : : call fftw_free(cdata_real)
3478 : :
3479 : : #else
3480 : : ABI_ERROR("FFTW3_MPI support not activated")
3481 : : ABI_UNUSED((/nfft,ngfft(1),ndat,comm_fft/))
3482 : : ABI_UNUSED((/fftn2_distrib(1),ffti2_local(1)/))
3483 : : ABI_UNUSED((/fftn3_distrib(1),ffti3_local(1)/))
3484 : : if (PRESENT(fftw_flags)) then
3485 : : ABI_UNUSED(fftw_flags)
3486 : : end if
3487 : : ABI_UNUSED(fofg(1,1))
3488 : : ABI_UNUSED(fofr(1))
3489 : : #endif
3490 : :
3491 : : end subroutine fftw3_mpifourdp_c2r
3492 : : !!***
3493 : :
3494 : : !----------------------------------------------------------------------
3495 : :
3496 : : !!****f* m_fftw3/fftw3_mpifourdp_r2c
3497 : : !! NAME
3498 : : !! fftw3_mpifourdp_r2c
3499 : : !!
3500 : : !! FUNCTION
3501 : : !! Driver routine for out-of-place 3D real-to-complex FFT of lengths nx, ny, nz.
3502 : : !!
3503 : : !! INPUTS
3504 : : !! fofr(nx*ny*nz*ndat)=The real array to be transformed.
3505 : : !! ndat=Number of FFTs to be done.
3506 : : !! comm_fft=MPI communicator for the FFT.
3507 : : !! [fftw_flags]=Flags used to create the plan. They can be combined with the "+" operator.
3508 : : !! Defaults to ABI_FFTW_ESTIMATE.
3509 : : !!
3510 : : !! OUTPUT
3511 : : !! fofg(2,nx*ny*nz*ndat)=The forward FFT of ff.
3512 : : !!
3513 : : !! NOTES
3514 : : !! LOCAL DATA FOR FOURIER TRANSFORMS : TRANSPOSED ORDER AND DISTRIBUTED
3515 : : !! real space --> dim = [ nx | ny | nz/np_fft ]
3516 : : !! fourier space --> dim = [ nx | nz | ny/np_fft ]
3517 : : !! we can't take in account the symmetric of the real case because after
3518 : : !! fft have been computed, the symmetric data needed are dispatched over
3519 : : !! other process in parallel
3520 : : !!
3521 : : !! SOURCE
3522 : :
3523 : : subroutine fftw3_mpifourdp_r2c(nfft,ngfft,ndat,&
3524 : : fftn2_distrib,ffti2_local,fftn3_distrib,ffti3_local,fofg,fofr,comm_fft,fftw_flags)
3525 : :
3526 : : !Arguments ------------------------------------
3527 : : !scalars
3528 : : integer,intent(in) :: nfft,ndat,comm_fft
3529 : : integer,optional,intent(in) :: fftw_flags
3530 : : !arrays
3531 : : integer,intent(in) :: ngfft(18)
3532 : : integer,intent(in) :: fftn2_distrib(ngfft(2)),ffti2_local(ngfft(2))
3533 : : integer,intent(in) :: fftn3_distrib(ngfft(3)),ffti3_local(ngfft(3))
3534 : : real(dp),intent(in) :: fofr(nfft*ndat)
3535 : : real(dp),intent(out) :: fofg(2,nfft*ndat)
3536 : :
3537 : : !Local variables-------------------------------
3538 : : #ifdef HAVE_FFTW3_MPI
3539 : : !scalars
3540 : : integer,parameter :: rank3=3
3541 : : integer :: my_flags,nproc_fft,nx,ny,nz
3542 : : integer(C_INTPTR_T) :: i,j,k,base,alloc_local,i1,i2,i3,igf,idat,kdat,i2dat,padatf
3543 : : integer(C_INTPTR_T) :: local_n0,local_0_start,local_n1,local_1_start
3544 : : real(dp) :: factor_fft
3545 : : type(C_PTR) :: plan_fw,cdata_cplx,cdata_real
3546 : : !arrays
3547 : : complex(C_DOUBLE_COMPLEX), contiguous, pointer :: data_cplx(:,:,:),data_real(:,:,:)
3548 : : integer(C_INTPTR_T) :: fft_sizes(4)
3549 : : ! *************************************************************************
3550 : :
3551 : : nproc_fft = xmpi_comm_size(comm_fft)
3552 : :
3553 : : nx=ngfft(1); ny=ngfft(2); nz=ngfft(3)
3554 : :
3555 : : my_flags=ABI_FFTW_ESTIMATE; if (PRESENT(fftw_flags)) my_flags= fftw_flags
3556 : :
3557 : : fft_sizes(1)=nz
3558 : : fft_sizes(2)=ny
3559 : : fft_sizes(3)=nx
3560 : : fft_sizes(4)=ndat
3561 : :
3562 : : ! Get parallel sizes
3563 : : alloc_local = fftw_mpi_local_size_many_transposed(&
3564 : : rank3,fft_sizes(1:3),fft_sizes(4), &
3565 : : FFTW_MPI_DEFAULT_BLOCK,FFTW_MPI_DEFAULT_BLOCK, comm_fft, &
3566 : : local_n0,local_0_start, &
3567 : : local_n1,local_1_start)
3568 : :
3569 : : ! Allocate data and reference it
3570 : :
3571 : : ! local data in real space --> dim = [nx | ny | nz/nproc_fft]
3572 : : cdata_real = fftw_alloc_complex(alloc_local)
3573 : : call c_f_pointer(cdata_real, data_real, [fft_sizes(3),fft_sizes(2),local_n0])
3574 : :
3575 : : ! local data in Fourier space --> dim = [nx | nz | ny/nproc_fft]
3576 : : cdata_cplx = fftw_alloc_complex(alloc_local)
3577 : : call c_f_pointer(cdata_cplx, data_cplx, [fft_sizes(3),fft_sizes(1),local_n1])
3578 : :
3579 : : ! TODO: Use true real to complex API!
3580 : : ! Create Plan C2C (nx,ny,nz)
3581 : : plan_fw = fftw_mpi_plan_many_dft(&
3582 : : rank3,fft_sizes(1:3),fft_sizes(4), &
3583 : : FFTW_MPI_DEFAULT_BLOCK,FFTW_MPI_DEFAULT_BLOCK, &
3584 : : data_real, data_cplx , &
3585 : : comm_fft,ABI_FFTW_FORWARD,ior(ABI_FFTW_ESTIMATE,ABI_FFTW_MPI_TRANSPOSED_OUT))
3586 : :
3587 : : ! Copy input data in correct format
3588 : : do idat=1,ndat
3589 : : do k=1,local_n0
3590 : : kdat = k + (idat-1) * local_n0
3591 : : do j=1, ny
3592 : : base = nx*((j-1) + ny*(k-1)) + (idat-1) * nfft
3593 : : do i=1, nx
3594 : : data_real(i,j,kdat) = CMPLX(fofr(i+base),zero, kind=C_DOUBLE_COMPLEX)
3595 : : end do
3596 : : end do
3597 : : end do
3598 : : end do
3599 : :
3600 : : ! Compute transform
3601 : : call fftw_mpi_execute_dft(plan_fw, data_real, data_cplx)
3602 : :
3603 : : factor_fft = one / (nx*ny*nz)
3604 : :
3605 : : do idat=1,ndat
3606 : : padatf=(idat-1)*nfft
3607 : : do i3=1,nz
3608 : : do i2=1,ny/nproc_fft ! equivalent a local_n1
3609 : : i2dat = i2 + (idat-1) * ny/nproc_fft
3610 : : do i1=1,nx
3611 : : igf = i1 + nx*( (i2-1) + (i3-1)*ny/nproc_fft ) + padatf
3612 : : fofg(1,igf) = real(data_cplx(i1,i3,i2dat)) * factor_fft
3613 : : fofg(2,igf) =aimag(data_cplx(i1,i3,i2dat)) * factor_fft
3614 : : end do
3615 : : end do
3616 : : end do
3617 : : end do
3618 : :
3619 : : call fftw_destroy_plan(plan_fw)
3620 : : call fftw_free(cdata_cplx)
3621 : : call fftw_free(cdata_real)
3622 : :
3623 : : #else
3624 : : ABI_ERROR("FFTW3_MPI support not activated")
3625 : : ABI_UNUSED((/nfft,ngfft(1),ndat,comm_fft/))
3626 : : ABI_UNUSED((/fftn2_distrib(1),ffti2_local(1)/))
3627 : : ABI_UNUSED((/fftn3_distrib(1),ffti3_local(1)/))
3628 : : if (PRESENT(fftw_flags)) then
3629 : : ABI_UNUSED(fftw_flags)
3630 : : end if
3631 : : ABI_UNUSED(fofg(1,1))
3632 : : ABI_UNUSED(fofr(1))
3633 : : #endif
3634 : :
3635 : : end subroutine fftw3_mpifourdp_r2c
3636 : : !!***
3637 : :
3638 : : !----------------------------------------------------------------------
3639 : :
3640 : : !!****f* m_fftw3/old_fftw3_mpifourdp
3641 : : !! NAME
3642 : : !! old_fftw3_mpifourdp
3643 : : !!
3644 : : !! FUNCTION
3645 : : !!
3646 : : !! INPUTS
3647 : : !! cplex=1 if fofr is real, 2 if fofr is complex
3648 : : !! nfft=(effective) number of FFT grid points (for this processor)
3649 : : !! ndat=Number of FFTs to be done.
3650 : : !! isign= +1 : fofg(G) => fofr(R);
3651 : : !! -1 : fofr(R) => fofg(G)
3652 : : !! fftn2_distrib(n2)= rank of the processor which own fft planes in 2nd dimension for fourdp
3653 : : !! ffti2_local(n2) = local i2 indices in fourdp
3654 : : !! fftn3_distrib(n3) = rank of the processor which own fft planes in 3rd dimension for fourdp
3655 : : !! ffti3_local(n3) = local i3 indices in fourdp
3656 : : !! comm_fft=MPI communicator for the FFT
3657 : : !! [fftw_flags]=Flags used to create the plan. They can be combined with the "+" operator.
3658 : : !!
3659 : : !! SIDE EFFECTS
3660 : : !! Input/Output
3661 : : !! fofg(2,nfft*ndat)=f(G), complex.
3662 : : !! fofr(cplex*nfft*ndat)=input function f(r) (real or complex)
3663 : : !!
3664 : : !! SOURCE
3665 : :
3666 : : subroutine old_fftw3_mpifourdp(cplex,nfft,ngfft,ndat,isign,&
3667 : : fftn2_distrib,ffti2_local,fftn3_distrib,ffti3_local,fofg,fofr,comm_fft,fftw_flags)
3668 : :
3669 : : !Arguments ------------------------------------
3670 : : !scalars
3671 : : integer,intent(in) :: cplex,nfft,ndat,isign,comm_fft
3672 : : integer,optional,intent(in) :: fftw_flags
3673 : : !arrays
3674 : : integer,intent(in) :: ngfft(18)
3675 : : integer,intent(in) :: fftn2_distrib(ngfft(2)),ffti2_local(ngfft(2))
3676 : : integer,intent(in) :: fftn3_distrib(ngfft(3)),ffti3_local(ngfft(3))
3677 : : real(dp),intent(inout) :: fofg(2,nfft*ndat),fofr(cplex*nfft*ndat)
3678 : :
3679 : : #ifdef HAVE_FFTW3_MPI
3680 : : !Local variables-------------------------------
3681 : : !scalars
3682 : : integer :: nx,ny,nz,my_flags
3683 : : ! *************************************************************************
3684 : :
3685 : : my_flags=ABI_FFTW_ESTIMATE; if (PRESENT(fftw_flags)) my_flags= fftw_flags
3686 : :
3687 : : nx=ngfft(1); ny=ngfft(2); nz=ngfft(3)
3688 : : !me_fft=ngfft(11); nproc_fft=ngfft(10)
3689 : :
3690 : : select case (cplex)
3691 : :
3692 : : case (1)
3693 : :
3694 : : ! Complex to Complex.
3695 : : ! This one is ok when ndat > 1
3696 : : !call fftw3_mpifourdp_c2c(cplex,nfft,ngfft,ndat,isign,&
3697 : : !& fftn2_distrib,ffti2_local,fftn3_distrib,ffti3_local,fofg,fofr,comm_fft,fftw_flags=my_flags)
3698 : : !return
3699 : :
3700 : : ! r2c or c2r case.
3701 : : ! FIXME this one is buggy when ndat > 1
3702 : : select case (isign)
3703 : : case (ABI_FFTW_FORWARD)
3704 : : ! +1; R --> G
3705 : : call fftw3_mpifourdp_r2c(nfft,ngfft,ndat,fftn2_distrib,ffti2_local,fftn3_distrib,ffti3_local,&
3706 : : & fofg,fofr,comm_fft,fftw_flags=my_flags)
3707 : :
3708 : : case (ABI_FFTW_BACKWARD)
3709 : : ! -1; G --> R
3710 : : call fftw3_mpifourdp_c2r(nfft,ngfft,ndat,fftn2_distrib,ffti2_local,fftn3_distrib,ffti3_local,&
3711 : : fofg,fofr,comm_fft,fftw_flags=my_flags)
3712 : :
3713 : : case default
3714 : : ABI_BUG("Wrong isign")
3715 : : end select
3716 : :
3717 : : case (2)
3718 : : ! Complex to Complex.
3719 : : call fftw3_mpifourdp_c2c(cplex,nfft,ngfft,ndat,isign,&
3720 : : fftn2_distrib,ffti2_local,fftn3_distrib,ffti3_local,fofg,fofr,comm_fft,fftw_flags=my_flags)
3721 : :
3722 : : case default
3723 : : ABI_BUG(" Wrong value for cplex")
3724 : : end select
3725 : :
3726 : : #else
3727 : : ABI_ERROR("FFTW3_MPI support not activated")
3728 : : ABI_UNUSED((/cplex,nfft,ngfft(1),ndat,isign,comm_fft/))
3729 : : ABI_UNUSED((/fftn2_distrib(1),ffti2_local(1)/))
3730 : : ABI_UNUSED((/fftn3_distrib(1),ffti3_local(1)/))
3731 : : if (PRESENT(fftw_flags)) then
3732 : : ABI_UNUSED(fftw_flags)
3733 : : end if
3734 : : ABI_UNUSED(fofg(1,1))
3735 : : ABI_UNUSED(fofr(1))
3736 : : #endif
3737 : :
3738 : : end subroutine old_fftw3_mpifourdp
3739 : : !!***
3740 : :
3741 : : !----------------------------------------------------------------------
3742 : :
3743 : : !!****f* m_fftw3/fftw3_mpifourdp_c2c
3744 : : !! NAME
3745 : : !! fftw3_mpifourdp_c2c
3746 : : !!
3747 : : !! FUNCTION
3748 : : !! Driver routine for many out-of-place 3D complex-to-complex FFTs of lengths n1, n2, n3.
3749 : : !!
3750 : : !! INPUTS
3751 : : !! cplex=1 if fofr is real, 2 if fofr is complex
3752 : : !! nfft=(effective) number of FFT grid points (for this processor)
3753 : : !! ndat=Number of FFTs to be done.
3754 : : !! isign=sign of Fourier transform exponent: current convention uses
3755 : : !! +1 for transforming from G to r,
3756 : : !! -1 for transforming from r to G.
3757 : : !! fftn2_distrib(n2)= rank of the processor which own fft planes in 2nd dimension for fourdp
3758 : : !! ffti2_local(n2) = local i2 indices in fourdp
3759 : : !! fftn3_distrib(n3) = rank of the processor which own fft planes in 3rd dimension for fourdp
3760 : : !! ffti3_local(n3) = local i3 indices in fourdp
3761 : : !! comm_fft=MPI communicator for the FFT
3762 : : !! [fftw_flags]=Flags used to create the plan. They can be combined with the "+" operator.
3763 : : !! fin(2*ldx*ldy*ldz*ndat)=The complex array to be transformed.
3764 : : !!
3765 : : !! TODO
3766 : : !! Add c2r and r2c version.
3767 : : !!
3768 : : !! SIDE EFFECTS
3769 : : !! Input/Output
3770 : : !! fofg(2,nfft*ndat)=f(G), complex.
3771 : : !! fofr(cplex*nfft*ndat)=input function f(r) (real or complex)
3772 : : !!
3773 : : !! SOURCE
3774 : :
3775 : : subroutine fftw3_mpifourdp_c2c(cplex,nfft,ngfft,ndat,isign,&
3776 : : fftn2_distrib,ffti2_local,fftn3_distrib,ffti3_local,fofg,fofr,comm_fft,fftw_flags)
3777 : :
3778 : : !Arguments ------------------------------------
3779 : : !scalars
3780 : : integer,intent(in) :: cplex,isign,nfft,ndat,comm_fft
3781 : : integer,optional,intent(in) :: fftw_flags
3782 : : !arrays
3783 : : integer,intent(in) :: ngfft(18)
3784 : : integer,intent(in) :: fftn2_distrib(ngfft(2)),ffti2_local(ngfft(2))
3785 : : integer,intent(in) :: fftn3_distrib(ngfft(3)),ffti3_local(ngfft(3))
3786 : : real(dp),intent(inout) :: fofg(2,nfft*ndat),fofr(cplex*nfft*ndat)
3787 : :
3788 : : #ifdef HAVE_FFTW3_MPI
3789 : : !Local variables-------------------------------
3790 : : !scalars
3791 : : integer,parameter :: rank3=3
3792 : : integer :: n1,n2,n3,n4,n5,n6,nd2proc,nd3proc,my_flags,me_fft,nproc_fft
3793 : : integer(C_INTPTR_T) :: alloc_local,local_n0,local_0_start,local_n1,local_1_start
3794 : : type(C_PTR) :: plan,cptr_cdata
3795 : : !arrays
3796 : : integer(C_INTPTR_T) :: fft_sizes(4)
3797 : : complex(C_DOUBLE_COMPLEX), contiguous, pointer :: f03_cdata(:)
3798 : : !*************************************************************************
3799 : :
3800 : : my_flags=ABI_FFTW_ESTIMATE; if (PRESENT(fftw_flags)) my_flags= fftw_flags
3801 : :
3802 : : n1=ngfft(1); n2=ngfft(2); n3=ngfft(3)
3803 : : ! No augmentation as FFTW3 does not support it
3804 : : n4=n1; n5=n2; n6=n3
3805 : : me_fft=ngfft(11); nproc_fft=ngfft(10)
3806 : :
3807 : : nd2proc=((n2-1)/nproc_fft) +1
3808 : : nd3proc=((n6-1)/nproc_fft) +1
3809 : :
3810 : : ! Get local data size and allocate (note dimension reversal, we call the C interface directly!)
3811 : : fft_sizes = [n3,n2,n1,ndat]
3812 : :
3813 : : ! Use TRANSPOSED_OUT
3814 : : my_flags = ior(ABI_FFTW_ESTIMATE, ABI_FFTW_MPI_TRANSPOSED_OUT)
3815 : :
3816 : : if (isign == ABI_FFTW_BACKWARD) then
3817 : : ! G --> R, Exchange n2 and n3
3818 : : fft_sizes = [n2,n3,n1,ndat]
3819 : : !my_flags = ior(ABI_FFTW_ESTIMATE, ABI_FFTW_MPI_TRANSPOSED_IN)
3820 : : end if
3821 : :
3822 : : alloc_local = fftw_mpi_local_size_many_transposed(&
3823 : : rank3,fft_sizes(1:3),fft_sizes(4), &
3824 : : FFTW_MPI_DEFAULT_BLOCK,FFTW_MPI_DEFAULT_BLOCK, comm_fft, &
3825 : : local_n0,local_0_start, &
3826 : : local_n1,local_1_start)
3827 : :
3828 : : ! C to F
3829 : : !local_0_start = local_0_start + 1
3830 : : !local_1_start = local_1_start + 1
3831 : : !write(std_out,*)"local_n0,local_0_start,alloc_local",local_n0,local_0_start,alloc_local
3832 : : !write(std_out,*)"local_n1,local_1_start,alloc_local",local_n1,local_1_start,alloc_local
3833 : :
3834 : : ! Allocate cptr_cdata, associate to F pointer and build the plane.
3835 : : cptr_cdata = fftw_alloc_complex(alloc_local)
3836 : :
3837 : : call c_f_pointer(cptr_cdata, f03_cdata, [alloc_local])
3838 : :
3839 : : plan = fftw_mpi_plan_many_dft(rank3,fft_sizes(1:3),fft_sizes(4), &
3840 : : FFTW_MPI_DEFAULT_BLOCK,FFTW_MPI_DEFAULT_BLOCK, &
3841 : : f03_cdata,f03_cdata,comm_fft,isign,my_flags)
3842 : :
3843 : : select case (isign)
3844 : : case (ABI_FFTW_BACKWARD)
3845 : : ! G --> R
3846 : : ABI_CHECK(local_n0 == nd2proc, "local_n0 != nd2proc")
3847 : :
3848 : : call mpifft_fg2dbox_dpc(nfft,ndat,fofg,n1,n2,n3,n4,nd2proc,n6,fftn2_distrib,ffti2_local,me_fft,f03_cdata)
3849 : :
3850 : : ! Compute transform.
3851 : : call fftw_mpi_execute_dft(plan, f03_cdata, f03_cdata)
3852 : :
3853 : : call mpifft_dbox2fr_dpc(n1,n2,n3,n4,n5,nd3proc,ndat,fftn3_distrib,ffti3_local,me_fft,f03_cdata,cplex,nfft,fofr)
3854 : :
3855 : : case (ABI_FFTW_FORWARD)
3856 : : ! R --> G
3857 : : ABI_CHECK(local_n0 == nd3proc, "local_n0 != nd3proc")
3858 : :
3859 : : call mpifft_fr2dbox_dpc(cplex,nfft,ndat,fofr,n1,n2,n3,n4,n5,nd3proc,fftn3_distrib,ffti3_local,me_fft,f03_cdata)
3860 : :
3861 : : ! Compute transform.
3862 : : call fftw_mpi_execute_dft(plan, f03_cdata, f03_cdata)
3863 : :
3864 : : ! Scale results.
3865 : : call mpifft_dbox2fg_dpc(n1,n2,n3,n4,nd2proc,n6,ndat,fftn2_distrib,ffti2_local,me_fft,f03_cdata,nfft,fofg)
3866 : :
3867 : : case default
3868 : : ABI_ERROR("Wrong sign")
3869 : : end select
3870 : :
3871 : : call fftw_destroy_plan(plan)
3872 : : call fftw_free(cptr_cdata)
3873 : :
3874 : : #else
3875 : : ABI_ERROR("FFTW3_MPI support not activated")
3876 : : ABI_UNUSED((/cplex,nfft,ngfft(1),ndat,isign,comm_fft/))
3877 : : ABI_UNUSED((/fftn2_distrib(1),ffti2_local(1)/))
3878 : : ABI_UNUSED((/fftn3_distrib(1),ffti3_local(1)/))
3879 : : if (PRESENT(fftw_flags)) then
3880 : : ABI_UNUSED(fftw_flags)
3881 : : end if
3882 : : ABI_UNUSED(fofg(1,1))
3883 : : ABI_UNUSED(fofr(1))
3884 : : #endif
3885 : :
3886 : : end subroutine fftw3_mpifourdp_c2c
3887 : : !!***
3888 : :
3889 : : !----------------------------------------------------------------------
3890 : :
3891 : : !!****f* m_fftw3/fftw3_mpiback_wf
3892 : : !! NAME
3893 : : !! fftw3_mpiback_wf
3894 : : !!
3895 : : !! FUNCTION
3896 : : !! Does multiple 3-dim backward FFTs from Fourier into real space
3897 : : !! Adopt standard convention that isign=1 for backward transform
3898 : : !!
3899 : : !! CALCULATES THE DISCRETE FOURIER TRANSFORM ZF(I1,I2,I3)=
3900 : : !!
3901 : : !! S_(j1,j2,j3) EXP(isign*i*2*pi*(j1*i1/n1+j2*i2/n2+j3*i3/n3)) ZF(j1,j3,j2)
3902 : : !!
3903 : : !! in parallel using MPI/OpenMP.
3904 : : !!
3905 : : !! INPUTS:
3906 : : !! cplexwf=1 if wavefunction is real, 2 if complex
3907 : : !! ndat=Number of wavefunctions to transform.
3908 : : !! n1,n2,n3: logical dimension of the transform. As transform lengths
3909 : : !! most products of the prime factors 2,3,5 are allowed.
3910 : : !! The detailed table with allowed transform lengths can be found in subroutine CTRIG
3911 : : !! nd1,nd2,nd3: Leading Dimension of ZR
3912 : : !! nd3proc=((nd3-1)/nproc_fft)+1 maximal number of big box 3rd dim slices for one proc
3913 : : !! max1 is positive or zero; m1 >=max1+1
3914 : : !! i1= 1... max1+1 corresponds to positive and zero wavevectors 0 ... max1
3915 : : !! then, if m1 > max1+1, one has min1=max1-m1+1 and
3916 : : !! i1= max1+2 ... m1 corresponds to negative wavevectors min1 ... -1
3917 : : !! max2 and max3 have a similar definition of range
3918 : : !! m1,m2,m3=Size of the box enclosing the G-sphere.
3919 : : !! md1,md2,md3: Dimension of ZF given on the **small** FFT box.
3920 : : !! md2proc=((md2-1)/nproc_fft)+1 maximal number of small box 2nd dim slices for one proc
3921 : : !! nproc_fft: number of processors used as returned by MPI_COMM_SIZE
3922 : : !! comm_fft=MPI communicator for the FFT.
3923 : : !! ZF: input array (note the switch of i2 and i3)
3924 : : !! real(F(i1,i3,i2,idat))=ZF(1,i1,i3,i2,idat)
3925 : : !! imag(F(i1,i3,i2,idat))=ZF(2,i1,i3,i2,idat)
3926 : : !!
3927 : : !! OUTPUTS
3928 : : !! ZR: output array
3929 : : !! ZR(1,i1,i2,i3,idat)=real(R(i1,i2,i3,idat))
3930 : : !! ZR(2,i1,i2,i3,idat)=imag(R(i1,i2,i3,idat))
3931 : : !! i1=1,n1 , i2=1,n2 , i3=1,n3 , idat=1,ndat
3932 : : !!
3933 : : !! NOTES
3934 : : !! The maximum number of processors that can reasonably be used is max(n2/2,n3/2)
3935 : : !!
3936 : : !! It is very important to find the optimal
3937 : : !! value of NCACHE. NCACHE determines the size of the work array ZW, that
3938 : : !! has to fit into cache. It has therefore to be chosen to equal roughly
3939 : : !! half the size of the physical cache in units of real*8 numbers.
3940 : : !! The optimal value of ncache can easily be determined by numerical
3941 : : !! experimentation. A too large value of ncache leads to a dramatic
3942 : : !! and sudden decrease of performance, a too small value to a to a
3943 : : !! slow and less dramatic decrease of performance. If NCACHE is set
3944 : : !! to a value so small, that not even a single one dimensional transform
3945 : : !! can be done in the workarray zw, the program stops with an error message.
3946 : : !!
3947 : : !! SOURCE
3948 : :
3949 : 0 : subroutine fftw3_mpiback_wf(cplexwf,ndat,n1,n2,n3,nd1,nd2,nd3proc,&
3950 : 0 : max1,max2,max3,m1,m2,m3,md1,md2proc,md3,zf,zr,comm_fft)
3951 : :
3952 : : !Arguments ------------------------------------
3953 : : integer,intent(in) :: cplexwf,ndat,n1,n2,n3,nd1,nd2,nd3proc
3954 : : integer,intent(in) :: max1,max2,max3,m1,m2,m3,md1,md2proc,md3,comm_fft
3955 : : real(dp),intent(in) :: zf(2,md1,md3,md2proc,ndat)
3956 : : real(dp),intent(out) :: zr(2,nd1,nd2,nd3proc,ndat)
3957 : :
3958 : : #ifdef HAVE_FFTW3
3959 : : !Local variables-------------------------------
3960 : : integer,parameter :: nt1=1
3961 : : integer :: j,i1,i2,idat,ierr,includelast
3962 : : integer :: ioption,j2,j3,j2st,jp2st,jeff,lzt,m1zt,ma,mb,n1dfft,nnd3
3963 : : integer :: lot1,lot2,lot3
3964 : : integer :: m2eff,ncache,n1eff,n1half,nproc_fft,me_fft,nthreads
3965 : : integer(KIND_FFTW_PLAN) :: bw_plan1_lot,bw_plan1_rest
3966 : : integer(KIND_FFTW_PLAN) :: bw_plan2_lot,bw_plan2_rest
3967 : : integer(KIND_FFTW_PLAN) :: bw_plan3_lot,bw_plan3_rest
3968 : : !type(C_PTR) :: zw_cptr,zt_cptr
3969 : : character(len=500) :: msg
3970 : : !arrays
3971 : : real(dp),allocatable :: zmpi1(:,:,:,:),zmpi2(:,:,:,:) ! work arrays for MPI
3972 : : real(dp),allocatable :: zw(:,:),zt(:,:,:) ! cache work array and array for transpositions
3973 : : !real(dp),contiguous, pointer :: zw(:,:),zt(:,:,:)
3974 : : ! FFT work arrays
3975 : : real(dp) :: tsec(2)
3976 : : ! *************************************************************************
3977 : :
3978 : : !call wrtout(std_out,"mpiback standard ALLTOALL + FFTW3")
3979 : :
3980 : : ! FIXME must provide a default value but which one?
3981 : : ! ioption = 0
3982 : : ioption = 1
3983 : : !if (paral_kgb==1) ioption=1
3984 : :
3985 : : nproc_fft = xmpi_comm_size(comm_fft); me_fft = xmpi_comm_rank(comm_fft)
3986 : :
3987 : : ! Find cache size that gives optimal performance on machine
3988 : : ncache=2*max(n1,n2,n3,1024)
3989 : : if (ncache/(2*max(n1,n2,n3))<1) then
3990 : : write(msg,"(5a)") &
3991 : : 'ncache has to be enlarged to be able to hold at',ch10, &
3992 : : 'least one 1-d FFT of each size even though this will',ch10,&
3993 : : 'reduce the performance for shorter transform lengths'
3994 : : ABI_ERROR(msg)
3995 : : end if
3996 : :
3997 : : ! Effective m1 and m2 (complex-to-complex or real-to-complex)
3998 : : n1eff=n1; m2eff=m2; m1zt=n1
3999 : : if (cplexwf==1) then
4000 : : n1eff=(n1+1)/2; m2eff=m2/2+1; m1zt=2*(n1/2+1)
4001 : : end if
4002 : :
4003 : : lzt=m2eff
4004 : : if (mod(m2eff,2)==0) lzt=lzt+1
4005 : : if (mod(m2eff,4)==0) lzt=lzt+1
4006 : :
4007 : : ! maximal number of big box 3rd dim slices for all procs
4008 : : nnd3=nd3proc*nproc_fft
4009 : :
4010 : : ! Allocate cache work array and work arrays for MPI transpositions.
4011 : : ABI_MALLOC(zw,(2,ncache/2))
4012 : : ABI_MALLOC(zt,(2,lzt,m1zt))
4013 : :
4014 : : !call fftw3_alloc_real([2,ncache/2],zw_cptr,zw)
4015 : : !call fftw3_alloc_real([2,lzt,m1zt],zt_cptr,zt)
4016 : :
4017 : : ABI_MALLOC(zmpi2,(2,md1,md2proc,nnd3))
4018 : : if (nproc_fft>1) then
4019 : : ABI_MALLOC(zmpi1,(2,md1,md2proc,nnd3))
4020 : : end if
4021 : :
4022 : : !DEBUG
4023 : : ! write(std_out,'(2a,3i4)' )itoa(me_fft),': fftw3_mpiback_wf,zf n1,n2,n3',n1,n2,n3
4024 : : ! write(std_out,'(2a,3i4)' )itoa(me_fft),': nd1,nd2,nd3proc',nd1,nd2,nd3proc
4025 : : ! write(std_out,'(2a,3i4)' )itoa(me_fft),': m1,m2,m3',m1,m2,m3
4026 : : ! write(std_out,'(2a,3i4)' )itoa(me_fft),': max1,max2,max3',max1,max2,max3
4027 : : ! write(std_out,'(2a,3i4)' )itoa(me_fft),': md1,md2proc,md3',md1,md2proc,md3
4028 : : ! write(std_out,'(2a,3i4)' )itoa(me_fft),'n1eff,m2eff,m1zt',n1eff,m2eff,m1zt
4029 : : !ENDDEBUG
4030 : :
4031 : : ! Create plans.
4032 : : ! The prototype for sfftw_plan_many_dft is:
4033 : : ! sfftw_plan_many_dft(rank, n, howmany,
4034 : : ! fin, iembed, istride, idist,
4035 : : ! fout, oembed, ostride, odist, isign, my_flags)
4036 : :
4037 : : lot3=ncache/(2*n3)
4038 : : lot1=ncache/(2*n1)
4039 : : lot2=ncache/(2*n2)
4040 : :
4041 : : nthreads = xomp_get_num_threads(open_parallel=.TRUE.)
4042 : : !nthreads = 1
4043 : :
4044 : : bw_plan3_lot = dplan_many_dft_2D(1, [n3], lot3, &
4045 : : zw, [ncache/2], lot3, 1, &
4046 : : zw, [ncache/2], lot3, 1, ABI_FFTW_BACKWARD, ABI_FFTW_ESTIMATE, nthreads)
4047 : :
4048 : : if (mod(m1, lot3) /= 0) then
4049 : : bw_plan3_rest = dplan_many_dft_2D(1, [n3], mod(m1, lot3), &
4050 : : zw, [ncache/2], lot3, 1, &
4051 : : zw, [ncache/2], lot3, 1, ABI_FFTW_BACKWARD, ABI_FFTW_ESTIMATE, nthreads)
4052 : : end if
4053 : :
4054 : : bw_plan1_lot = dplan_many_dft_2D(1, [n1], lot1, &
4055 : : zw, [ncache/2], lot1, 1, &
4056 : : zt, [lzt, m1zt], lzt, 1, ABI_FFTW_BACKWARD, ABI_FFTW_ESTIMATE, nthreads)
4057 : :
4058 : : if (mod(m2eff, lot1) /= 0) then
4059 : : bw_plan1_rest = dplan_many_dft_2D(1, [n1], mod(m2eff, lot1), &
4060 : : zw, [ncache/2], lot1, 1, &
4061 : : zt, [lzt, m1zt], lzt, 1, ABI_FFTW_BACKWARD, ABI_FFTW_ESTIMATE, nthreads)
4062 : : end if
4063 : :
4064 : : bw_plan2_lot = dplan_many_dft_2D(1, [n2], lot2, &
4065 : : zw, [ncache/2], lot2, 1, &
4066 : : zr, [nd1,nd2,nd3proc,ndat], nd1, 1, ABI_FFTW_BACKWARD, ABI_FFTW_ESTIMATE, nthreads)
4067 : :
4068 : : if (mod(n1eff, lot2) /= 0) then
4069 : : bw_plan2_rest = dplan_many_dft_2D(1, [n2], mod(n1eff,lot2), &
4070 : : zw, [ncache/2], lot2, 1, &
4071 : : zr, [nd1,nd2,nd3proc,ndat], nd1, 1, ABI_FFTW_BACKWARD, ABI_FFTW_ESTIMATE, nthreads)
4072 : : end if
4073 : :
4074 : : do idat=1,ndat
4075 : : ! transform along z axis
4076 : : ! input: G1,G3,G2,(Gp2)
4077 : :
4078 : : ! Loop over the y planes treated by this node and transform n1ddft G_z lines.
4079 : : do j2=1,md2proc
4080 : : ! if (me_fft*md2proc+j2<=m2eff) then !a faire plus tard
4081 : : do i1=1,m1,lot3
4082 : : ma=i1
4083 : : mb=min(i1+(lot3-1),m1)
4084 : : n1dfft=mb-ma+1
4085 : :
4086 : : ! zero-pad n1dfft G_z lines
4087 : : ! input: G1,G3,G2,(Gp2)
4088 : : ! output: G1,R3,G2,(Gp2)
4089 : : call fill_cent(md1,md3,lot3,n1dfft,max3,m3,n3,zf(1,i1,1,j2,idat),zw)
4090 : :
4091 : : ! Transform along z.
4092 : : if (n1dfft == lot3) then
4093 : : call dfftw_execute_dft(bw_plan3_lot, zw, zw)
4094 : : else
4095 : : call dfftw_execute_dft(bw_plan3_rest, zw, zw)
4096 : : end if
4097 : :
4098 : : ! Local rotation.
4099 : : ! input: G1,R3,G2,(Gp2)
4100 : : ! output: G1,G2,R3,(Gp2)
4101 : : call scramble(i1,j2,lot3,n1dfft,md1,n3,md2proc,nnd3,zw,zmpi2)
4102 : : end do
4103 : : end do ! j2
4104 : :
4105 : : ! Interprocessor data transposition
4106 : : ! input: G1,G2,R3,Rp3,(Gp2)
4107 : : ! output: G1,G2,R3,Gp2,(Rp3)
4108 : : if (nproc_fft>1) then
4109 : : call timab(543,1,tsec)
4110 : : call xmpi_alltoall(zmpi2,2*md1*md2proc*nd3proc, &
4111 : : zmpi1,2*md1*md2proc*nd3proc,comm_fft,ierr)
4112 : : call timab(543,2,tsec)
4113 : : end if
4114 : :
4115 : : ! Loop over the z treated by this node.
4116 : : do j3=1,nd3proc
4117 : : if (me_fft*nd3proc+j3 <= n3) then
4118 : : Jp2st=1; J2st=1
4119 : :
4120 : : ! Loop over G_y in the small box.
4121 : : do j=1,m2eff,lot1
4122 : : ma=j
4123 : : mb=min(j+(lot1-1),m2eff)
4124 : : n1dfft=mb-ma+1
4125 : :
4126 : : ! Zero-pad input.
4127 : : ! input: G1,G2,R3,JG2,(Rp3)
4128 : : ! output: G2,G1,R3,JG2,(Rp3)
4129 : : if (nproc_fft==1) then
4130 : : call mpiswitch_cent(j3,n1dfft,Jp2st,J2st,lot1,max1,md1,m1,n1,&
4131 : : md2proc,nd3proc,nproc_fft,ioption,zmpi2,zw,max2,m2,n2)
4132 : : else
4133 : : call mpiswitch_cent(j3,n1dfft,Jp2st,J2st,lot1,max1,md1,m1,n1,&
4134 : : md2proc,nd3proc,nproc_fft,ioption,zmpi1,zw,max2,m2,n2)
4135 : : end if
4136 : :
4137 : : ! Transform along x
4138 : : ! input: G2,G1,R3,(Rp3)
4139 : : ! output: G2,R1,R3,(Rp3)
4140 : : if (n1dfft == lot1) then
4141 : : call dfftw_execute_dft(bw_plan1_lot, zw, zt(1,j,1))
4142 : : else
4143 : : call dfftw_execute_dft(bw_plan1_rest, zw, zt(1,j,1))
4144 : : end if
4145 : :
4146 : : end do ! j
4147 : :
4148 : : ! Transform along y axis (take into account c2c or c2r case).
4149 : : ! Must loop over the full box.
4150 : : do j=1,n1eff,lot2
4151 : : ma=j
4152 : : mb=min(j+(lot2-1),n1eff)
4153 : : n1dfft=mb-ma+1
4154 : : includelast=1
4155 : :
4156 : : if (cplexwf==1) then
4157 : : jeff=2*j-1
4158 : : if (mb==n1eff .and. n1eff*2/=n1) includelast=0
4159 : : end if
4160 : :
4161 : : ! Zero-pad the input.
4162 : : ! input: G2,R1,R3,(Rp3)
4163 : : ! output: R1,G2,R3,(Rp3)
4164 : : if (cplexwf==2) then
4165 : : call switch_cent(n1dfft,max2,m2,n2,lot2,n1,lzt,zt(1,1,j),zw)
4166 : : else
4167 : : call switchreal_cent(includelast,n1dfft,max2,n2,lot2,m1zt,lzt,zt(1,1,jeff),zw)
4168 : : end if
4169 : :
4170 : : ! input: R1,G2,R3,(Rp3)
4171 : : ! output: R1,R2,R3,(Rp3)
4172 : : if (n1dfft == lot2) then
4173 : : call dfftw_execute_dft(bw_plan2_lot, zw, zr(1,j,1,j3,idat))
4174 : : else
4175 : : call dfftw_execute_dft(bw_plan2_rest, zw, zr(1,j,1,j3,idat))
4176 : : end if
4177 : :
4178 : : end do
4179 : :
4180 : : ! Treat real wavefunctions.
4181 : : if (cplexwf==1) then
4182 : : n1half=n1/2
4183 : : ! If odd
4184 : : if (n1half*2/=n1) then
4185 : : do i2=1,n2
4186 : : zr(1,n1,i2,j3,idat)=zr(1,n1eff,i2,j3,idat)
4187 : : zr(2,n1,i2,j3,idat)=zero
4188 : : end do
4189 : : end if
4190 : : do i2=1,n2
4191 : : do i1=n1half,1,-1
4192 : : zr(1,2*i1-1,i2,j3,idat)=zr(1,i1,i2,j3,idat)
4193 : : zr(1,2*i1 ,i2,j3,idat)=zr(2,i1,i2,j3,idat)
4194 : : zr(2,2*i1-1,i2,j3,idat)=zero
4195 : : zr(2,2*i1 ,i2,j3,idat)=zero
4196 : : end do
4197 : : end do
4198 : : end if
4199 : :
4200 : : end if
4201 : : end do ! j3
4202 : : end do ! idat
4203 : :
4204 : : call dfftw_destroy_plan(bw_plan3_lot)
4205 : : if (mod(m1, lot3) /= 0) call dfftw_destroy_plan(bw_plan3_rest)
4206 : :
4207 : : call dfftw_destroy_plan(bw_plan1_lot)
4208 : : if (mod(m2eff, lot1) /= 0) call dfftw_destroy_plan(bw_plan1_rest)
4209 : :
4210 : : call dfftw_destroy_plan(bw_plan2_lot)
4211 : : if (mod(n1eff, lot2) /= 0) call dfftw_destroy_plan(bw_plan2_rest)
4212 : :
4213 : : ABI_FREE(zmpi2)
4214 : : ABI_FREE(zw)
4215 : : ABI_FREE(zt)
4216 : : if (nproc_fft>1) then
4217 : : ABI_FREE(zmpi1)
4218 : : end if
4219 : :
4220 : : #else
4221 : 0 : ABI_ERROR("FFTW3 support not activated")
4222 : : ABI_UNUSED((/cplexwf,ndat,n1,n2,n3,nd1,nd2,nd3proc/))
4223 : : ABI_UNUSED((/ max1,max2,max3,m1,m2,m3,md1,md2proc,md3,comm_fft/))
4224 : : ABI_UNUSED((/zf(1,1,1,1,1),zr(1,1,1,1,1)/))
4225 : : #endif
4226 : :
4227 : 0 : end subroutine fftw3_mpiback_wf
4228 : : !!***
4229 : :
4230 : : !----------------------------------------------------------------------
4231 : :
4232 : : !!****f* m_fftw3/fftw3_mpiforw_wf
4233 : : !! NAME
4234 : : !! fftw3_mpiforw_wf
4235 : : !!
4236 : : !! FUNCTION
4237 : : !! Does multiple 3-dim backward FFTs from real into Fourier space
4238 : : !! Adopt standard convention that isign=-1 for forward transform
4239 : : !! CALCULATES THE DISCRETE FOURIERTRANSFORM
4240 : : !!
4241 : : !! ZF(I1,I3,I2)=S_(j1,j2,j3) EXP(isign*i*2*pi*(j1*i1/n1+j2*i2/n2+j3*i3/n3)) ZR(j1,j2,j3)
4242 : : !!
4243 : : !! in parallel using MPI/OpenMP.
4244 : : !!
4245 : : !! INPUT:
4246 : : !! ZR: input array
4247 : : !! ZR(1,i1,i2,i3,idat)=real(R(i1,i2,i3,idat))
4248 : : !! ZR(2,i1,i2,i3,idat)=imag(R(i1,i2,i3,idat))
4249 : : !! i1=1,n1 , i2=1,n2 , i3=1,n3 , idat=1,ndat
4250 : : !! NOTE that ZR is changed by the routine
4251 : : !!
4252 : : !! n1,n2,n3: logical dimension of the transform. As transform lengths
4253 : : !! most products of the prime factors 2,3,5 are allowed.
4254 : : !! The detailed table with allowed transform lengths can
4255 : : !! be found in subroutine CTRIG
4256 : : !! nd1,nd2,nd3: Dimension of ZR
4257 : : !! nd3proc=((nd3-1)/nproc_fft)+1 maximal number of big box 3rd dim slices for one proc
4258 : : !!
4259 : : !! OUTPUT:
4260 : : !! ZF: output array (note the switch of i2 and i3)
4261 : : !! real(F(i1,i3,i2,idat))=ZF(1,i1,i3,i2,idat)
4262 : : !! imag(F(i1,i3,i2,idat))=ZF(2,i1,i3,i2,idat)
4263 : : !! max1 is positive or zero ; m1 >=max1+1
4264 : : !! i1= 1... max1+1 corresponds to positive and zero wavevectors 0 ... max1
4265 : : !! then, if m1 > max1+1, one has min1=max1-m1+1 and
4266 : : !! i1= max1+2 ... m1 corresponds to negative wavevectors min1 ... -1
4267 : : !! i2 and i3 have a similar definition of range
4268 : : !! idat=1,ndat
4269 : : !! md1,md2,md3: Dimension of ZF
4270 : : !! md2proc=((md2-1)/nproc_fft)+1 maximal number of small box 2nd dim slices for one proc
4271 : : !! nproc_fft: number of processors used as returned by MPI_COMM_SIZE
4272 : : !! me_fft: [0:nproc-1] rank of the processor in the FFT communicator.
4273 : : !! comm_fft=MPI communicator for parallel FFT.
4274 : : !!
4275 : : !! NOTES
4276 : : !! The maximum number of processors that can reasonably be used is max(n2/2,n3/2)
4277 : : !!
4278 : : !! It is very important to find the optimal
4279 : : !! value of NCACHE. NCACHE determines the size of the work array ZW, that
4280 : : !! has to fit into cache. It has therefore to be chosen to equal roughly
4281 : : !! half the size of the physical cache in units of real*8 numbers.
4282 : : !! The optimal value of ncache can easily be determined by numerical
4283 : : !! experimentation. A too large value of ncache leads to a dramatic
4284 : : !! and sudden decrease of performance, a too small value to a to a
4285 : : !! slow and less dramatic decrease of performance. If NCACHE is set
4286 : : !! to a value so small, that not even a single one dimensional transform
4287 : : !! can be done in the workarray zw, the program stops with an error message.
4288 : : !!
4289 : : !! SOURCE
4290 : :
4291 : 0 : subroutine fftw3_mpiforw_wf(cplexwf,ndat,n1,n2,n3,nd1,nd2,nd3proc,&
4292 : 0 : & max1,max2,max3,m1,m2,m3,md1,md2proc,md3,zr,zf,comm_fft)
4293 : :
4294 : : !Arguments ------------------------------------
4295 : : !scalars
4296 : : integer,intent(in) :: cplexwf,ndat,n1,n2,n3,nd1,nd2,nd3proc
4297 : : integer,intent(in) :: max1,max2,max3,m1,m2,m3,md1,md2proc,md3,comm_fft
4298 : : !arrays
4299 : : real(dp),intent(inout) :: zr(2,nd1,nd2,nd3proc,ndat)
4300 : : real(dp),intent(out) :: zf(2,md1,md3,md2proc,ndat)
4301 : :
4302 : : !Local variables-------------------------------
4303 : : !scalars
4304 : : #ifdef HAVE_FFTW3
4305 : : integer :: j,i1,i2,i3,idat,ierr,nproc_fft,me_fft,nthreads
4306 : : integer :: ioption,j2,j3,j2st,jp2st,lot1,lot2,lot3,lzt,m1zt,ma,mb,n1dfft,nnd3
4307 : : integer :: m2eff,ncache,n1eff,n1half,i1inv,i2inv,i3inv
4308 : : integer(KIND_FFTW_PLAN) :: fw_plan1_lot,fw_plan1_rest
4309 : : integer(KIND_FFTW_PLAN) :: fw_plan2_lot,fw_plan2_rest
4310 : : integer(KIND_FFTW_PLAN) :: fw_plan3_lot,fw_plan3_rest
4311 : : character(len=500) :: msg
4312 : : !arrays
4313 : : real(dp), allocatable :: zmpi1(:,:,:,:),zmpi2(:,:,:,:) ! work arrays for MPI
4314 : : real(dp),allocatable :: zw(:,:),zt(:,:,:) ! cache work array and array for transpositions
4315 : : ! FFT work arrays
4316 : : real(dp) :: tsec(2)
4317 : : ! *************************************************************************
4318 : :
4319 : : ! FIXME must provide a default value but which one?
4320 : : !ioption = 0
4321 : : ioption = 1
4322 : : !if (paral_kgb==1) ioption=1
4323 : :
4324 : : nproc_fft = xmpi_comm_size(comm_fft); me_fft = xmpi_comm_rank(comm_fft)
4325 : :
4326 : : ! find cache size that gives optimal performance on machine
4327 : : ncache=2*max(n1,n2,n3,1024)
4328 : : !ncache=2*max(n1,n2,n3,16*1024)
4329 : :
4330 : : if (ncache/(2*max(n1,n2,n3))<1) then
4331 : : write(msg,'(5a)') &
4332 : : 'ncache has to be enlarged to be able to hold at',ch10, &
4333 : : 'least one 1-d FFT of each size even though this will',ch10,&
4334 : : 'reduce the performance for shorter transform lengths'
4335 : : ABI_ERROR(msg)
4336 : : end if
4337 : :
4338 : : ! Effective m1 and m2 (complex-to-complex or real-to-complex)
4339 : : n1eff=n1; m2eff=m2; m1zt=n1
4340 : : if (cplexwf==1) then
4341 : : n1eff=(n1+1)/2; m2eff=m2/2+1; m1zt=2*(n1/2+1)
4342 : : end if
4343 : :
4344 : : lzt=m2eff
4345 : : if (mod(m2eff,2)==0) lzt=lzt+1
4346 : : if (mod(m2eff,4)==0) lzt=lzt+1
4347 : :
4348 : : ! maximal number of big box 3rd dim slices for all procs
4349 : : nnd3=nd3proc*nproc_fft
4350 : :
4351 : : ABI_MALLOC(zw,(2,ncache/2))
4352 : : ABI_MALLOC(zt,(2,lzt,m1zt))
4353 : : ABI_MALLOC(zmpi2,(2,md1,md2proc,nnd3))
4354 : : if (nproc_fft>1) then
4355 : : ABI_MALLOC(zmpi1,(2,md1,md2proc,nnd3))
4356 : : end if
4357 : :
4358 : : !DEBUG
4359 : : ! write(std_out,'(2a,3i4)' )itoa(me_fft),'fftw3_mpiforw_wf, enter, i1,i2,i3,zr,n1,n2,n3',n1,n2,n3
4360 : : ! write(std_out,'(2a,3i4)' )itoa(me_fft),'nd1,nd2,nd3proc',nd1,nd2,nd3proc
4361 : : ! write(std_out,'(2a,3i4)' )itoa(me_fft),'m1,m2,m3',m1,m2,m3
4362 : : ! write(std_out,'(2a,3i4)' )itoa(me_fft),'max1,max2,max3',max1,max2,max3
4363 : : ! write(std_out,'(2a,3i4)' )itoa(me_fft),'md1,md2proc,md3',md1,md2proc,md3
4364 : : ! write(std_out,'(2a,3i4)' )itoa(me_fft),'n1eff,m2eff,m1zt',n1eff,m2eff,m1zt
4365 : : !ENDDEBUG
4366 : :
4367 : : ! Create plans.
4368 : : ! The prototype for sfftw_plan_many_dft is:
4369 : : ! sfftw_plan_many_dft(rank, n, howmany,
4370 : : ! fin, iembed, istride, idist,
4371 : : ! fout, oembed, ostride, odist, isign, my_flags)
4372 : :
4373 : : lot2=ncache/(2*n2)
4374 : : lot1=ncache/(2*n1)
4375 : : lot3=ncache/(2*n3)
4376 : :
4377 : : nthreads = xomp_get_num_threads(open_parallel=.TRUE.)
4378 : : !nthreads = 1
4379 : :
4380 : : fw_plan3_lot = dplan_many_dft_2D(1, [n3], lot3, &
4381 : : zw, [ncache/2], lot3, 1, &
4382 : : zw, [ncache/2], lot3, 1, ABI_FFTW_FORWARD, ABI_FFTW_ESTIMATE,nthreads)
4383 : :
4384 : : if (mod(m1, lot3) /= 0) then
4385 : : fw_plan3_rest = dplan_many_dft_2D(1, [n3], mod(m1, lot3), &
4386 : : zw, [ncache/2], lot3, 1, &
4387 : : zw, [ncache/2], lot3, 1, ABI_FFTW_FORWARD, ABI_FFTW_ESTIMATE, nthreads)
4388 : : end if
4389 : :
4390 : : fw_plan1_lot = dplan_many_dft_2D(1, [n1], lot1, &
4391 : : zt, [lzt, m1zt], lzt, 1, &
4392 : : zw, [ncache/2], lot1, 1, ABI_FFTW_FORWARD, ABI_FFTW_ESTIMATE, nthreads)
4393 : :
4394 : : if (mod(m2eff, lot1) /= 0) then
4395 : : fw_plan1_rest = dplan_many_dft_2D(1, [n1], mod(m2eff, lot1), &
4396 : : zt, [lzt, m1zt], lzt, 1, &
4397 : : zw, [ncache/2], lot1, 1, ABI_FFTW_FORWARD, ABI_FFTW_ESTIMATE, nthreads)
4398 : : end if
4399 : :
4400 : : fw_plan2_lot = dplan_many_dft_2D(1, [n2], lot2, &
4401 : : zr, [nd1,nd2,nd3proc,ndat], nd1, 1, &
4402 : : zw, [ncache/2], lot2, 1, ABI_FFTW_FORWARD, ABI_FFTW_ESTIMATE, nthreads)
4403 : :
4404 : : if (mod(n1eff, lot2) /= 0) then
4405 : : fw_plan2_rest = dplan_many_dft_2D(1, [n2], mod(n1eff,lot2), &
4406 : : zr, [nd1,nd2,nd3proc,ndat], nd1, 1, &
4407 : : zw, [ncache/2], lot2, 1, ABI_FFTW_FORWARD, ABI_FFTW_ESTIMATE, nthreads)
4408 : : end if
4409 : :
4410 : : do idat=1,ndat
4411 : : ! Loop over the z-planes treated by this node
4412 : : do j3=1,nd3proc
4413 : :
4414 : : if (me_fft*nd3proc+j3 <= n3) then
4415 : : Jp2st=1
4416 : : J2st=1
4417 : :
4418 : : ! Treat real wavefunctions.
4419 : : if (cplexwf==1) then
4420 : : n1half=n1/2
4421 : : do i2=1,n2
4422 : : do i1=1,n1half
4423 : : zr(1,i1,i2,j3,idat)=zr(1,2*i1-1,i2,j3,idat)
4424 : : zr(2,i1,i2,j3,idat)=zr(1,2*i1 ,i2,j3,idat)
4425 : : end do
4426 : : end do
4427 : : ! If odd
4428 : : if(n1half*2/=n1)then
4429 : : do i2=1,n2
4430 : : zr(1,n1eff,i2,j3,idat)=zr(1,n1,i2,j3,idat)
4431 : : zr(2,n1eff,i2,j3,idat)=zero
4432 : : end do
4433 : : end if
4434 : : end if
4435 : :
4436 : : ! transform along y axis
4437 : : ! input: R1,R2,R3,(Rp3)
4438 : : ! input: R1,G2,R3,(Rp3)
4439 : : do j=1,n1eff,lot2
4440 : : ma=j
4441 : : mb=min(j+(lot2-1),n1eff)
4442 : : n1dfft=mb-ma+1
4443 : :
4444 : : if (n1dfft == lot2) then
4445 : : call dfftw_execute_dft(fw_plan2_lot, zr(1,j,1,j3,idat), zw)
4446 : : else
4447 : : call dfftw_execute_dft(fw_plan2_rest, zr(1,j,1,j3,idat), zw)
4448 : : end if
4449 : :
4450 : : ! input: R1,G2,R3,(Rp3)
4451 : : ! output: G2,R1,R3,(Rp3)
4452 : : if (cplexwf==2) then
4453 : : call unswitch_cent(n1dfft,max2,m2,n2,lot2,n1,lzt,zw,zt(1,1,j))
4454 : : else
4455 : : call unswitchreal_cent(n1dfft,max2,n2,lot2,n1,lzt,zw,zt(1,1,2*j-1))
4456 : : end if
4457 : : end do
4458 : :
4459 : : ! transform along x axis
4460 : : ! input: G2,R1,R3,(Rp3)
4461 : : do j=1,m2eff,lot1
4462 : : ma=j
4463 : : mb=min(j+(lot1-1),m2eff)
4464 : : n1dfft=mb-ma+1
4465 : :
4466 : : if (n1dfft == lot1) then
4467 : : call dfftw_execute_dft(fw_plan1_lot, zt(1,j,1), zw)
4468 : : else
4469 : : call dfftw_execute_dft(fw_plan1_rest, zt(1,j,1), zw)
4470 : : end if
4471 : : ! output: G2,G1,R3,(Rp3)
4472 : :
4473 : : ! input: G2,G1,R3,Gp2,(Rp3)
4474 : : ! output: G1,G2,R3,Gp2,(Rp3)
4475 : : if (nproc_fft==1) then
4476 : : call unmpiswitch_cent(j3,n1dfft,Jp2st,J2st,lot1,max1,md1,m1,n1,&
4477 : : md2proc,nd3proc,nproc_fft,ioption,zw,zmpi2)
4478 : : else
4479 : : call unmpiswitch_cent(j3,n1dfft,Jp2st,J2st,lot1,max1,md1,m1,n1,&
4480 : : md2proc,nd3proc,nproc_fft,ioption,zw,zmpi1)
4481 : : end if
4482 : : end do
4483 : :
4484 : : end if
4485 : : end do ! j3
4486 : :
4487 : : ! Interprocessor data transposition
4488 : : ! input: G1,G2,R3,Gp2,(Rp3)
4489 : : ! output: G1,G2,R3,Rp3,(Gp2)
4490 : : if (nproc_fft>1) then
4491 : : call timab(544,1,tsec)
4492 : : call xmpi_alltoall(zmpi1,2*md1*md2proc*nd3proc, &
4493 : : zmpi2,2*md1*md2proc*nd3proc,comm_fft,ierr)
4494 : : call timab(544,2,tsec)
4495 : : end if
4496 : :
4497 : : ! transform along z axis
4498 : : ! input: G1,G2,R3,(Gp2)
4499 : :
4500 : : do j2=1,md2proc
4501 : : if (me_fft*md2proc+j2 <= m2eff) then
4502 : : ! write(std_out,*)' forwf_wf : before unscramble, j2,md2proc,me_fft,m2=',j2,md2proc,me_fft,m2
4503 : : do i1=1,m1,lot3
4504 : : ma=i1
4505 : : mb=min(i1+(lot3-1),m1)
4506 : : n1dfft=mb-ma+1
4507 : :
4508 : : ! input: G1,G2,R3,(Gp2)
4509 : : ! output: G1,R3,G2,(Gp2)
4510 : : call unscramble(i1,j2,lot3,n1dfft,md1,n3,md2proc,nnd3,zmpi2,zw)
4511 : :
4512 : : if (n1dfft == lot3) then
4513 : : call dfftw_execute_dft(fw_plan3_lot, zw, zw)
4514 : : else
4515 : : call dfftw_execute_dft(fw_plan3_rest, zw, zw)
4516 : : end if
4517 : :
4518 : : call unfill_cent(md1,md3,lot3,n1dfft,max3,m3,n3,zw,zf(1,i1,1,j2,idat))
4519 : : ! output: G1,G3,G2,(Gp2)
4520 : : end do
4521 : : end if
4522 : : end do
4523 : :
4524 : : if (cplexwf==1) then
4525 : : ! Complete missing values with complex conjugate
4526 : : ! Inverse of ix is located at nx+2-ix , except for ix=1, for which it is 1.
4527 : : do i3=1,m3
4528 : : i3inv=m3+2-i3
4529 : : if(i3==1)i3inv=1
4530 : :
4531 : : if (m2eff>1) then
4532 : : do i2=2,m2eff
4533 : : i2inv=m2+2-i2
4534 : : zf(1,1,i3inv,i2inv,idat)= zf(1,1,i3,i2,idat)
4535 : : zf(2,1,i3inv,i2inv,idat)=-zf(2,1,i3,i2,idat)
4536 : : do i1=2,m1
4537 : : i1inv=m1+2-i1
4538 : : zf(1,i1inv,i3inv,i2inv,idat)= zf(1,i1,i3,i2,idat)
4539 : : zf(2,i1inv,i3inv,i2inv,idat)=-zf(2,i1,i3,i2,idat)
4540 : : end do
4541 : : end do
4542 : : end if
4543 : : end do
4544 : : end if
4545 : :
4546 : : end do ! idat
4547 : :
4548 : : call dfftw_destroy_plan(fw_plan3_lot)
4549 : : if (mod(m1, lot3) /= 0) call dfftw_destroy_plan(fw_plan3_rest)
4550 : :
4551 : : call dfftw_destroy_plan(fw_plan1_lot)
4552 : : if (mod(m2eff, lot1) /= 0) call dfftw_destroy_plan(fw_plan1_rest)
4553 : :
4554 : : call dfftw_destroy_plan(fw_plan2_lot)
4555 : : if (mod(n1eff, lot2) /= 0) call dfftw_destroy_plan(fw_plan2_rest)
4556 : :
4557 : : ABI_FREE(zmpi2)
4558 : : ABI_FREE(zw)
4559 : : ABI_FREE(zt)
4560 : : if (nproc_fft>1) then
4561 : : ABI_FREE(zmpi1)
4562 : : end if
4563 : :
4564 : : #else
4565 : 0 : ABI_ERROR("FFTW3 support not activated")
4566 : : ABI_UNUSED((/cplexwf,ndat,n1,n2,n3,nd1,nd2,nd3proc/))
4567 : : ABI_UNUSED((/max1,max2,max3,m1,m2,m3,md1,md2proc,md3,comm_fft/))
4568 : : ABI_UNUSED((/zf(1,1,1,1,1),zr(1,1,1,1,1)/))
4569 : : #endif
4570 : :
4571 : 0 : end subroutine fftw3_mpiforw_wf
4572 : : !!***
4573 : :
4574 : : !----------------------------------------------------------------------
4575 : :
4576 : : !!****f* m_fftw3/fftw3_mpiback
4577 : : !! NAME
4578 : : !! fftw3_mpiback
4579 : : !!
4580 : : !! FUNCTION
4581 : : !! CALCULATES THE DISCRETE FOURIER TRANSFORM in parallel using MPI/OpenMP
4582 : : !!
4583 : : !! ZR(I1,I2,I3)= \sum_(j1,j2,j3) EXP(isign*i*2*pi*(j1*i1/n1+j2*i2/n2+j3*i3/n3)) ZF(j1,j3,j2)
4584 : : !!
4585 : : !! Adopt standard convention that isign=1 for backward transform
4586 : : !!
4587 : : !! INPUTS:
4588 : : !! option= 1 if call from fourwf, 2 if call from other routine
4589 : : !! cplex=1 for real --> complex, 2 for complex --> complex
4590 : : !! ZF: input array in G-space (note the switch of i2 and i3)
4591 : : !!
4592 : : !! real(F(i1,i3,i2,idat))=ZF(1,i1,i3,i2,idat)
4593 : : !! imag(F(i1,i3,i2,idat))=ZF(2,i1,i3,i2,idat)
4594 : : !!
4595 : : !! i1=1,n1 , i2=1,n2 , i3=1,n3 , idat=1,ndat
4596 : : !! OUTPUTS:
4597 : : !! ZR: output array in R space.
4598 : : !!
4599 : : !! ZR(1,i1,i2,i3,idat)=real(R(i1,i2,i3,idat))
4600 : : !! ZR(2,i1,i2,i3,idat)=imag(R(i1,i2,i3,idat))
4601 : : !!
4602 : : !! i1=1,n1 , i2=1,n2 , i3=1,n3 , idat=1,ndat
4603 : : !!
4604 : : !! nproc_fft: number of processors used as returned by MPI_COMM_SIZE
4605 : : !! me_fft: [0:nproc_fft-1] number of processor as returned by MPI_COMM_RANK
4606 : : !! n1,n2,n3: logical dimension of the transform. As transform lengths
4607 : : !! most products of the prime factors 2,3,5 are allowed.
4608 : : !! The detailed table with allowed transform lengths can
4609 : : !! be found in subroutine CTRIG
4610 : : !! nd1,nd2,nd3: Dimension of ZF and ZR
4611 : : !! nd2proc=((nd2-1)/nproc_fft)+1 maximal number of 2nd dim slices
4612 : : !! nd3proc=((nd3-1)/nproc_fft)+1 maximal number of 3rd dim slices
4613 : : !!
4614 : : !! NOTES:
4615 : : !! The maximum number of processors that can reasonably be used is max(n2,n3)
4616 : : !! It is very important to find the optimal
4617 : : !! value of NCACHE. NCACHE determines the size of the work array ZW, that
4618 : : !! has to fit into cache. It has therefore to be chosen to equal roughly
4619 : : !! half the size of the physical cache in units of real*8 numbers.
4620 : : !! The optimal value of ncache can easily be determined by numerical
4621 : : !! experimentation. A too large value of ncache leads to a dramatic
4622 : : !! and sudden decrease of performance, a too small value to a to a
4623 : : !! slow and less dramatic decrease of performance. If NCACHE is set
4624 : : !! to a value so small, that not even a single one dimensional transform
4625 : : !! can be done in the workarray zw, the program stops with an error message.
4626 : : !!
4627 : : !! SOURCE
4628 : :
4629 : 0 : subroutine fftw3_mpiback(cplex,ndat,n1,n2,n3,nd1,nd2,nd3,nd1eff,nd2proc,nd3proc,option,zf,zr,comm_fft)
4630 : :
4631 : : !Arguments ------------------------------------
4632 : : ! real space input
4633 : : integer,intent(in) :: cplex,ndat,n1,n2,n3,nd1,nd2,nd3,nd1eff,nd2proc,nd3proc,option,comm_fft
4634 : : real(dp),intent(in) :: zf(2,nd1,nd3,nd2proc,ndat)
4635 : : real(dp),intent(out) :: zr(2,nd1eff,nd2,nd3proc,ndat)
4636 : :
4637 : : !Local variables-------------------------------
4638 : : !scalaras
4639 : : #ifdef HAVE_FFTW3
4640 : : integer :: j,i1,idat,ierr,includelast,j2,j2st,j3,jeff,jp2st,lzt,nthreads
4641 : : integer :: ma,mb,n1dfft,n1eff,n2eff,n1zt,ncache,nnd3,nproc_fft,me_fft,lot1,lot2,lot3
4642 : : integer(KIND_FFTW_PLAN) :: bw_plan1_lot,bw_plan1_rest
4643 : : integer(KIND_FFTW_PLAN) :: bw_plan2_lot,bw_plan2_rest
4644 : : integer(KIND_FFTW_PLAN) :: bw_plan3_lot,bw_plan3_rest
4645 : : character(len=500) :: msg
4646 : : !arrays
4647 : : real(dp), allocatable :: zmpi1(:,:,:,:),zmpi2(:,:,:,:) ! work arrays for MPI
4648 : : real(dp),allocatable :: zw(:,:),zt(:,:,:) ! cache work array and array for transpositions
4649 : : ! *************************************************************************
4650 : :
4651 : : nproc_fft = xmpi_comm_size(comm_fft); me_fft = xmpi_comm_rank(comm_fft)
4652 : :
4653 : : ! find cache size that gives optimal performance on machine
4654 : : ncache=2*max(n1,n2,n3,1024)
4655 : :
4656 : : if (ncache/(2*max(n1,n2,n3))<1) then
4657 : : write(msg,'(5a)') &
4658 : : 'ncache has to be enlarged to be able to hold at',ch10, &
4659 : : 'least one 1-d FFT of each size even though this will',ch10,&
4660 : : 'reduce the performance for shorter transform lengths'
4661 : : ABI_ERROR(msg)
4662 : : end if
4663 : :
4664 : : ! check input
4665 : : if (nd1<n1 .or. nd2<n2 .or. nd3<n3) then
4666 : : ABI_ERROR("nd1<n1 .or. nd2<n2 .or. nd3<n3")
4667 : : end if
4668 : :
4669 : : ! Effective n1 and n2 (complex-to-complex or real-to-complex)
4670 : : n1eff=n1; n2eff=n2; n1zt=n1
4671 : : if (cplex==1) then
4672 : : n1eff=(n1+1)/2; n2eff=n2/2+1 ; n1zt=2*(n1/2+1)
4673 : : end if
4674 : :
4675 : : lzt=n2eff
4676 : : if (mod(n2eff,2) == 0) lzt=lzt+1
4677 : : if (mod(n2eff,4) == 0) lzt=lzt+1
4678 : :
4679 : : ! maximal number of big box 3rd dim slices for all procs
4680 : : nnd3=nd3proc*nproc_fft
4681 : :
4682 : : ABI_MALLOC(zw,(2,ncache/2))
4683 : : ABI_MALLOC(zt,(2,lzt,n1zt))
4684 : : ABI_MALLOC(zmpi2,(2,n1,nd2proc,nnd3))
4685 : : if (nproc_fft>1) then
4686 : : ABI_MALLOC(zmpi1,(2,n1,nd2proc,nnd3))
4687 : : end if
4688 : :
4689 : : !DEBUG
4690 : : ! write(std_out,'(a,3i4)' )'back,zf n1,n2,n3',n1,n2,n3
4691 : : ! write(std_out,'(a,3i4)' )'nd1,nd2,nd3proc',nd1,nd2,nd3proc
4692 : : ! write(std_out,'(a,3i4)' )'m1,m2,m3',m1,m2,m3
4693 : : ! write(std_out,'(a,3i4)' )'max1,max2,max3',max1,max2,max3
4694 : : ! write(std_out,'(a,3i4)' )'md1,md2proc,md3',md1,md2proc,md3
4695 : : ! write(std_out,'(a,3i4)' )'n1eff,m2eff,m1zt',n1eff,m2eff,m1zt
4696 : : !ENDDEBUG
4697 : :
4698 : : ! Create plans.
4699 : : ! The prototype for sfftw_plan_many_dft is:
4700 : : ! sfftw_plan_many_dft(rank, n, howmany,
4701 : : ! fin, iembed, istride, idist,
4702 : : ! fout, oembed, ostride, odist, isign, my_flags)
4703 : :
4704 : : lot3=ncache/(2*n3)
4705 : : lot1=ncache/(2*n1)
4706 : : lot2=ncache/(2*n2)
4707 : :
4708 : : nthreads = xomp_get_num_threads(open_parallel=.TRUE.)
4709 : : !nthreads = 1
4710 : :
4711 : : bw_plan3_lot = dplan_many_dft_2D(1, [n3], lot3, &
4712 : : zw, [ncache/2], lot3, 1, &
4713 : : zw, [ncache/2], lot3, 1, ABI_FFTW_BACKWARD, ABI_FFTW_ESTIMATE, nthreads)
4714 : :
4715 : : if (mod(n1, lot3) /= 0) then
4716 : : bw_plan3_rest = dplan_many_dft_2D(1, [n3], mod(n1, lot3), &
4717 : : zw, [ncache/2], lot3, 1, &
4718 : : zw, [ncache/2], lot3, 1, ABI_FFTW_BACKWARD, ABI_FFTW_ESTIMATE, nthreads)
4719 : : end if
4720 : :
4721 : : bw_plan1_lot = dplan_many_dft_2D(1, [n1], lot1, &
4722 : : zw, [ncache/2], lot1, 1, &
4723 : : zt, [lzt, n1zt], lzt, 1, ABI_FFTW_BACKWARD, ABI_FFTW_ESTIMATE, nthreads)
4724 : :
4725 : : if (mod(n2eff, lot1) /= 0) then
4726 : : bw_plan1_rest = dplan_many_dft_2D(1, [n1], mod(n2eff, lot1), &
4727 : : zw, [ncache/2], lot1, 1, &
4728 : : zt, [lzt, n1zt], lzt, 1, ABI_FFTW_BACKWARD, ABI_FFTW_ESTIMATE, nthreads)
4729 : : end if
4730 : :
4731 : : bw_plan2_lot = dplan_many_dft_2D(1, [n2], lot2, &
4732 : : zw, [ncache/2], lot2, 1, &
4733 : : zr, [nd1eff,nd2,nd3proc,ndat], nd1eff, 1, ABI_FFTW_BACKWARD, ABI_FFTW_ESTIMATE, nthreads)
4734 : :
4735 : : if (mod(n1eff, lot2) /= 0) then
4736 : : bw_plan2_rest = dplan_many_dft_2D(1, [n2], mod(n1eff,lot2), &
4737 : : zw, [ncache/2], lot2, 1, &
4738 : : zr, [nd1eff,nd2,nd3proc,ndat], nd1eff, 1, ABI_FFTW_BACKWARD, ABI_FFTW_ESTIMATE, nthreads)
4739 : : end if
4740 : :
4741 : : do idat=1,ndat
4742 : : ! transform along z axis
4743 : : ! input: I1,I3,J2,(Jp2)
4744 : :
4745 : : do j2=1,nd2proc
4746 : : if (me_fft*nd2proc+j2 <= n2eff) then
4747 : :
4748 : : do i1=1,n1,lot3
4749 : : ma=i1
4750 : : mb=min(i1+(lot3-1),n1)
4751 : : n1dfft=mb-ma+1
4752 : :
4753 : : ! input: G1,G3,G2,(Gp2)
4754 : : ! output: G1,R3,G2,(Gp2)
4755 : : call fill(nd1,nd3,lot3,n1dfft,n3,zf(1,i1,1,j2,idat),zw)
4756 : :
4757 : : if (n1dfft == lot3) then
4758 : : call dfftw_execute_dft(bw_plan3_lot, zw, zw)
4759 : : else
4760 : : call dfftw_execute_dft(bw_plan3_rest, zw, zw)
4761 : : end if
4762 : :
4763 : : ! input: G1,R3,G2,(Gp2)
4764 : : ! output: G1,G2,R3,(Gp2)
4765 : : call scramble(i1,j2,lot3,n1dfft,n1,n3,nd2proc,nd3,zw,zmpi2)
4766 : : end do
4767 : : end if
4768 : : end do
4769 : :
4770 : : ! Interprocessor data transposition
4771 : : ! input: G1,G2,R3,Rp3,(Gp2)
4772 : : ! output: G1,G2,G3,Gp2,(Rp3)
4773 : : if (nproc_fft>1) then
4774 : : call xmpi_alltoall(zmpi2,2*n1*nd2proc*nd3proc, &
4775 : : zmpi1,2*n1*nd2proc*nd3proc,comm_fft,ierr)
4776 : : end if
4777 : :
4778 : : do j3=1,nd3proc
4779 : : if (me_fft*nd3proc+j3 <= n3) then
4780 : : Jp2st=1; J2st=1
4781 : :
4782 : : ! transform along x axis
4783 : : do j=1,n2eff,lot1
4784 : : ma=j
4785 : : mb=min(j+(lot1-1),n2eff)
4786 : : n1dfft=mb-ma+1
4787 : :
4788 : : ! input: G1,G2,R3,Gp2,(Rp3)
4789 : : ! output: G2,G1,R3,Jp2,(Rp3)
4790 : : if (nproc_fft == 1) then
4791 : : call mpiswitch(j3,n1dfft,Jp2st,J2st,lot1,n1,nd2proc,nd3proc,nproc_fft,option,zmpi2,zw)
4792 : : else
4793 : : call mpiswitch(j3,n1dfft,Jp2st,J2st,lot1,n1,nd2proc,nd3proc,nproc_fft,option,zmpi1,zw)
4794 : : end if
4795 : :
4796 : : ! input: G2,G1,R3,(Rp3)
4797 : : ! output: G2,R1,R3,(Rp3)
4798 : : if (n1dfft == lot1) then
4799 : : call dfftw_execute_dft(bw_plan1_lot, zw, zt(1,j,1))
4800 : : else
4801 : : call dfftw_execute_dft(bw_plan1_rest, zw, zt(1,j,1))
4802 : : end if
4803 : :
4804 : : end do
4805 : :
4806 : : ! transform along y axis
4807 : : do j=1,n1eff,lot2
4808 : : ma=j
4809 : : mb=min(j+(lot2-1),n1eff)
4810 : : n1dfft=mb-ma+1
4811 : : includelast=1
4812 : : if (cplex==1) then
4813 : : jeff=2*j-1
4814 : : includelast=1
4815 : : if (mb==n1eff .and. n1eff*2/=n1) includelast=0
4816 : : end if
4817 : :
4818 : : ! input: G2,R1,R3,(Rp3)
4819 : : ! output: R1,G2,R3,(Rp3)
4820 : : if (cplex==2) then
4821 : : call switch(n1dfft,n2,lot2,n1,lzt,zt(1,1,j),zw)
4822 : : else
4823 : : call switchreal(includelast,n1dfft,n2,n2eff,lot2,n1zt,lzt,zt(1,1,jeff),zw)
4824 : : end if
4825 : :
4826 : : if (n1dfft == lot2) then
4827 : : call dfftw_execute_dft(bw_plan2_lot, zw, zr(1,j,1,j3,idat))
4828 : : else
4829 : : call dfftw_execute_dft(bw_plan2_rest, zw, zr(1,j,1,j3,idat))
4830 : : end if
4831 : : end do
4832 : : ! output: R1,R2,R3,(Rp3)
4833 : :
4834 : : end if
4835 : : end do
4836 : : end do ! idat
4837 : :
4838 : : call dfftw_destroy_plan(bw_plan3_lot)
4839 : : if (mod(n1, lot3) /= 0) call dfftw_destroy_plan(bw_plan3_rest)
4840 : :
4841 : : call dfftw_destroy_plan(bw_plan1_lot)
4842 : : if (mod(n2eff, lot1) /= 0) call dfftw_destroy_plan(bw_plan1_rest)
4843 : :
4844 : : call dfftw_destroy_plan(bw_plan2_lot)
4845 : : if (mod(n1eff, lot2) /= 0) call dfftw_destroy_plan(bw_plan2_rest)
4846 : :
4847 : : ABI_FREE(zmpi2)
4848 : : ABI_FREE(zw)
4849 : : ABI_FREE(zt)
4850 : : if (nproc_fft>1) then
4851 : : ABI_FREE(zmpi1)
4852 : : end if
4853 : :
4854 : : #else
4855 : 0 : ABI_ERROR("FFTW3 support not activated")
4856 : : ABI_UNUSED((/cplex,ndat,n1,n2,n3,nd1,nd2,nd1eff,nd2proc,nd3proc,option,comm_fft/))
4857 : : ABI_UNUSED((/zf(1,1,1,1,1),zr(1,1,1,1,1)/))
4858 : : #endif
4859 : :
4860 : 0 : end subroutine fftw3_mpiback
4861 : : !!***
4862 : :
4863 : : !----------------------------------------------------------------------
4864 : :
4865 : : !!****f* m_fftw3/fftw3_mpiforw
4866 : : !! NAME
4867 : : !! fftw3_mpiforw
4868 : : !!
4869 : : !! FUNCTION
4870 : : !! Adopt standard convention that isign=-1 for forward transform
4871 : : !! CALCULATES THE DISCRETE FOURIERTRANSFORM ZF(I1,I3,I2)=
4872 : : !! S_(j1,j2,j3) EXP(isign*i*2*pi*(j1*i1/n1+j2*i2/n2+j3*i3/n3)) ZR(j1,j2,j3)
4873 : : !! in parallel using MPI/OpenMP and BLAS library calls.
4874 : : !!
4875 : : !! INPUTS
4876 : : !! ZR: input array
4877 : : !! ZR(1,i1,i2,i3,idat)=real(R(i1,i2,i3,idat))
4878 : : !! ZR(2,i1,i2,i3,idat)=imag(R(i1,i2,i3,idat))
4879 : : !! i1=1,n1 , i2=1,n2 , i3=1,n3 , idat=1,ndat
4880 : : !! OUTPUTS
4881 : : !! ZF: output array (note the switch of i2 and i3)
4882 : : !! real(F(i1,i3,i2,idat))=ZF(1,i1,i3,i2,idat)
4883 : : !! imag(F(i1,i3,i2,idat))=ZF(2,i1,i3,i2,idat)
4884 : : !! i1=1,n1 , i2=1,n2 , i3=1,n3 , idat=1,ndat
4885 : : !! nproc_fft: number of processors used as returned by MPI_COMM_SIZE
4886 : : !! me_fft: [0:nproc_fft-1] number of processor as returned by MPI_COMM_RANK
4887 : : !! n1,n2,n3: logical dimension of the transform. As transform lengths
4888 : : !! most products of the prime factors 2,3,5 are allowed.
4889 : : !! The detailed table with allowed transform lengths can
4890 : : !! be found in subroutine CTRIG
4891 : : !! nd1,nd2,nd3: Dimension of ZR and ZF
4892 : : !! nd2proc=((nd2-1)/nproc_fft)+1 maximal number of 2nd dim slices
4893 : : !! nd3proc=((nd3-1)/nproc_fft)+1 maximal number of 3rd dim slices
4894 : : !!
4895 : : !! NOTES
4896 : : !! SHOULD describe nd1eff
4897 : : !! SHOULD put cplex and nd1eff in OMP declarations
4898 : : !! SHOULD describe the change of value of nd2prod
4899 : : !!
4900 : : !! The maximum number of processors that can reasonably be used is max(n2,n3)
4901 : : !!
4902 : : !! It is very important to find the optimal
4903 : : !! value of NCACHE. NCACHE determines the size of the work array ZW, that
4904 : : !! has to fit into cache. It has therefore to be chosen to equal roughly
4905 : : !! half the size of the physical cache in units of real*8 numbers.
4906 : : !! The optimal value of ncache can easily be determined by numerical
4907 : : !! experimentation. A too large value of ncache leads to a dramatic
4908 : : !! and sudden decrease of performance, a too small value to a to a
4909 : : !! slow and less dramatic decrease of performance. If NCACHE is set
4910 : : !! to a value so small, that not even a single one dimensional transform
4911 : : !! can be done in the workarray zw, the program stops with an error message.
4912 : : !!
4913 : : !! SOURCE
4914 : :
4915 : 0 : subroutine fftw3_mpiforw(cplex,ndat,n1,n2,n3,nd1,nd2,nd3,nd1eff,nd2proc,nd3proc,option,zr,zf,comm_fft)
4916 : :
4917 : : !Arguments ------------------------------------
4918 : : !scalars
4919 : : integer,intent(in) :: cplex,comm_fft
4920 : : integer,intent(in) :: ndat,n1,n2,n3,nd1,nd2,nd3,nd1eff,nd2proc,nd3proc,option
4921 : : !arrays
4922 : : real(dp),intent(in) :: zr(2,nd1eff,nd2,nd3proc,ndat)
4923 : : real(dp),intent(out) :: zf(2,nd1,nd3,nd2proc,ndat)
4924 : :
4925 : : !Local variables-------------------------------
4926 : : !scalars
4927 : : #ifdef HAVE_FFTW3
4928 : : integer :: j,i1,idat,ierr,j2,j2st,j3,jp2st,lzt,nthreads
4929 : : integer :: ma,mb,n1dfft,n1eff,n2eff,n1zt,ncache,nnd3,nproc_fft,me_fft,lot1,lot2,lot3
4930 : : integer(KIND_FFTW_PLAN) :: fw_plan1_lot,fw_plan1_rest
4931 : : integer(KIND_FFTW_PLAN) :: fw_plan2_lot,fw_plan2_rest
4932 : : integer(KIND_FFTW_PLAN) :: fw_plan3_lot,fw_plan3_rest
4933 : : character(len=500) :: msg
4934 : : !arrays
4935 : : real(dp), allocatable :: zmpi1(:,:,:,:),zmpi2(:,:,:,:) ! work arrays for MPI
4936 : : real(dp),allocatable :: zw(:,:),zt(:,:,:) ! cache work array and array for transpositions
4937 : : ! *************************************************************************
4938 : :
4939 : : nproc_fft = xmpi_comm_size(comm_fft); me_fft = xmpi_comm_rank(comm_fft)
4940 : :
4941 : : ! find cache size that gives optimal performance on machine
4942 : : ncache=2*max(n1,n2,n3,1024)
4943 : : if (ncache/(2*max(n1,n2,n3))<1) then
4944 : : write(msg,'(5a)')&
4945 : : 'ncache has to be enlarged to be able to hold at',ch10, &
4946 : : 'least one 1-d FFT of each size even though this will',ch10,&
4947 : : 'reduce the performance for shorter transform lengths'
4948 : : ABI_ERROR(msg)
4949 : : end if
4950 : :
4951 : : ! check input
4952 : : if (nd1<n1 .or. nd2<n2 .or. nd3<n3) then
4953 : : ABI_ERROR("forw: assertion error nd1<n1 .or. nd2<n2 .or. nd3<n3")
4954 : : end if
4955 : :
4956 : : !Effective n1 and n2 (complex-to-complex or real-to-complex)
4957 : : n1eff=n1; n2eff=n2; n1zt=n1
4958 : : if (cplex==1) then
4959 : : n1eff=(n1+1)/2; n2eff=n2/2+1; n1zt=2*(n1/2+1)
4960 : : end if
4961 : :
4962 : : lzt=n2eff
4963 : : if (mod(n2eff,2) == 0) lzt=lzt+1
4964 : : if (mod(n2eff,4) == 0) lzt=lzt+1
4965 : :
4966 : : ! maximal number of big box 3rd dim slices for all procs
4967 : : nnd3=nd3proc*nproc_fft
4968 : :
4969 : : ABI_MALLOC(zw,(2,ncache/2))
4970 : : ABI_MALLOC(zt,(2,lzt,n1zt))
4971 : : ABI_MALLOC(zmpi2,(2,n1,nd2proc,nnd3))
4972 : : if (nproc_fft>1) then
4973 : : ABI_MALLOC(zmpi1,(2,n1,nd2proc,nnd3))
4974 : : end if
4975 : :
4976 : : ! Create plans.
4977 : : ! The prototype for sfftw_plan_many_dft is:
4978 : : ! sfftw_plan_many_dft(rank, n, howmany,
4979 : : ! fin, iembed, istride, idist,
4980 : : ! fout, oembed, ostride, odist, isign, my_flags)
4981 : :
4982 : : lot1=ncache/(2*n1)
4983 : : lot2=ncache/(2*n2)
4984 : : lot3=ncache/(2*n3)
4985 : :
4986 : : nthreads = xomp_get_num_threads(open_parallel=.TRUE.)
4987 : : !nthreads = 1
4988 : :
4989 : : fw_plan3_lot = dplan_many_dft_2D(1, [n3], lot3, &
4990 : : zw, [ncache/2], lot3, 1, &
4991 : : zw, [ncache/2], lot3, 1, ABI_FFTW_FORWARD, ABI_FFTW_ESTIMATE, nthreads)
4992 : :
4993 : : if (mod(n1, lot3) /= 0) then
4994 : : fw_plan3_rest = dplan_many_dft_2D(1, [n3], mod(n1, lot3), &
4995 : : zw, [ncache/2], lot3, 1, &
4996 : : zw, [ncache/2], lot3, 1, ABI_FFTW_FORWARD, ABI_FFTW_ESTIMATE, nthreads)
4997 : : end if
4998 : :
4999 : : fw_plan1_lot = dplan_many_dft_2D(1, [n1], lot1, &
5000 : : zt, [lzt, n1zt], lzt, 1, &
5001 : : zw, [ncache/2], lot1, 1, ABI_FFTW_FORWARD, ABI_FFTW_ESTIMATE, nthreads)
5002 : :
5003 : : if (mod(n2eff, lot1) /= 0) then
5004 : : fw_plan1_rest = dplan_many_dft_2D(1, [n1], mod(n2eff, lot1), &
5005 : : zt, [lzt, n1zt], lzt, 1, &
5006 : : zw, [ncache/2], lot1, 1, ABI_FFTW_FORWARD, ABI_FFTW_ESTIMATE, nthreads)
5007 : : end if
5008 : :
5009 : : fw_plan2_lot = dplan_many_dft_2D(1, [n2], lot2, &
5010 : : zr, [nd1eff,nd2,nd3proc,ndat], nd1eff, 1, &
5011 : : zw, [ncache/2], lot2, 1, ABI_FFTW_FORWARD, ABI_FFTW_ESTIMATE, nthreads)
5012 : :
5013 : : if (mod(n1eff, lot2) /= 0) then
5014 : : fw_plan2_rest = dplan_many_dft_2D(1, [n2], mod(n1eff,lot2), &
5015 : : zr, [nd1eff,nd2,nd3proc,ndat], nd1eff, 1, &
5016 : : zw, [ncache/2], lot2, 1, ABI_FFTW_FORWARD, ABI_FFTW_ESTIMATE, nthreads)
5017 : : end if
5018 : :
5019 : : do idat=1,ndat
5020 : :
5021 : : do j3=1,nd3proc
5022 : : if (me_fft*(nd3proc)+j3 <= n3) then
5023 : : Jp2st=1; J2st=1
5024 : :
5025 : : ! transform along y axis
5026 : : ! input: R1,R2,R3,(Rp3)
5027 : : do j=1,n1eff,lot2
5028 : : ma=j
5029 : : mb=min(j+(lot2-1),n1eff)
5030 : : n1dfft=mb-ma+1
5031 : :
5032 : : if (n1dfft == lot2) then
5033 : : call dfftw_execute_dft(fw_plan2_lot, zr(1,j,1,j3,idat), zw)
5034 : : else
5035 : : call dfftw_execute_dft(fw_plan2_rest, zr(1,j,1,j3,idat), zw)
5036 : : end if
5037 : :
5038 : : ! input: R1,G2,R3,(Rp3)
5039 : : ! output: G2,R1,R3,(Rp3)
5040 : : if (cplex==2) then
5041 : : call unswitch(n1dfft,n2,lot2,n1zt,lzt,zw,zt(1,1,j))
5042 : : else
5043 : : call unswitchreal(n1dfft,n2,n2eff,lot2,n1zt,lzt,zw,zt(1,1,2*j-1))
5044 : : end if
5045 : : end do
5046 : :
5047 : : ! transform along x axis
5048 : : ! input: G2,R1,R3,(Rp3)
5049 : : do j=1,n2eff,lot1
5050 : : ma=j
5051 : : mb=min(j+(lot1-1),n2eff)
5052 : : n1dfft=mb-ma+1
5053 : :
5054 : : if (n1dfft == lot1) then
5055 : : call dfftw_execute_dft(fw_plan1_lot, zt(1,j,1), zw)
5056 : : else
5057 : : call dfftw_execute_dft(fw_plan1_rest, zt(1,j,1), zw)
5058 : : end if
5059 : :
5060 : : ! input: G2,G1,R3,Gp2,(Rp3)
5061 : : ! output: G1,G2,R3,Gp2,(Rp3)
5062 : : ! write(std_out,*) 'J2st,Jp2st',J2st,Jp2st
5063 : : if (nproc_fft == 1) then
5064 : : call unmpiswitch(j3,n1dfft,Jp2st,J2st,lot1,n1,nd2proc,nd3proc,nproc_fft,option,zw,zmpi2)
5065 : : else
5066 : : call unmpiswitch(j3,n1dfft,Jp2st,J2st,lot1,n1,nd2proc,nd3proc,nproc_fft,option,zw,zmpi1)
5067 : : end if
5068 : : end do
5069 : :
5070 : : end if
5071 : : end do ! j3
5072 : :
5073 : : ! Interprocessor data transposition
5074 : : ! input: G1,G2,R3,Gp2,(Rp3)
5075 : : ! output: G1,G2,R3,Rp3,(Gp2)
5076 : : if (nproc_fft>1) then
5077 : : call xmpi_alltoall(zmpi1,2*n1*nd2proc*nd3proc, &
5078 : : zmpi2,2*n1*nd2proc*nd3proc,comm_fft,ierr)
5079 : : end if
5080 : :
5081 : : ! transform along z axis
5082 : : ! input: G1,G2,R3,(Gp2)
5083 : :
5084 : : do j2=1,nd2proc
5085 : : if (me_fft*(nd2proc)+j2 <= n2eff) then
5086 : : do i1=1,n1,lot3
5087 : : ma=i1
5088 : : mb=min(i1+(lot3-1),n1)
5089 : : n1dfft=mb-ma+1
5090 : :
5091 : : ! input: G1,G2,R3,(Gp2)
5092 : : ! output: G1,R3,G2,(Gp2)
5093 : : call unscramble(i1,j2,lot3,n1dfft,n1,n3,nd2proc,nd3,zmpi2,zw)
5094 : :
5095 : : if (n1dfft == lot3) then
5096 : : call dfftw_execute_dft(fw_plan3_lot, zw, zw)
5097 : : else
5098 : : call dfftw_execute_dft(fw_plan3_rest, zw, zw)
5099 : : end if
5100 : :
5101 : : call unfill(nd1,nd3,lot3,n1dfft,n3,zw,zf(1,i1,1,j2,idat))
5102 : : ! output: G1,G3,G2,(Gp2)
5103 : : end do
5104 : : end if
5105 : : end do
5106 : :
5107 : : end do ! idat
5108 : :
5109 : : call dfftw_destroy_plan(fw_plan3_lot)
5110 : : if (mod(n1, lot3) /= 0) call dfftw_destroy_plan(fw_plan3_rest)
5111 : :
5112 : : call dfftw_destroy_plan(fw_plan1_lot)
5113 : : if (mod(n2eff, lot1) /= 0) call dfftw_destroy_plan(fw_plan1_rest)
5114 : :
5115 : : call dfftw_destroy_plan(fw_plan2_lot)
5116 : : if (mod(n1eff, lot2) /= 0) call dfftw_destroy_plan(fw_plan2_rest)
5117 : :
5118 : : ABI_FREE(zmpi2)
5119 : : ABI_FREE(zw)
5120 : : ABI_FREE(zt)
5121 : : if (nproc_fft>1) then
5122 : : ABI_FREE(zmpi1)
5123 : : end if
5124 : :
5125 : : #else
5126 : 0 : ABI_ERROR("FFTW3 support not activated")
5127 : : ABI_UNUSED((/cplex,ndat,n1,n2,n3,nd1,nd2,nd1eff,nd2proc,nd3proc,option,comm_fft/))
5128 : : ABI_UNUSED((/zf(1,1,1,1,1),zr(1,1,1,1,1)/))
5129 : : #endif
5130 : :
5131 : 0 : end subroutine fftw3_mpiforw
5132 : : !!***
5133 : :
5134 : : !----------------------------------------------------------------------
5135 : :
5136 : : !!****f* m_m_fftw3/fftw3_mpifourdp
5137 : : !! NAME
5138 : : !! fftw3_mpifourdp
5139 : : !!
5140 : : !! FUNCTION
5141 : : !! Conduct Fourier transform of REAL or COMPLEX function f(r)=fofr defined on
5142 : : !! fft grid in real space, to create complex f(G)=fofg defined on full fft grid
5143 : : !! in reciprocal space, in full storage mode, or the reverse operation.
5144 : : !! For the reverse operation, the final data is divided by nfftot.
5145 : : !! REAL case when cplex=1, COMPLEX case when cplex=2
5146 : : !! Usually used for density and potentials.
5147 : : !!
5148 : : !! INPUTS
5149 : : !! cplex=1 if fofr is real, 2 if fofr is complex
5150 : : !! nfft=(effective) number of FFT grid points (for this processor)
5151 : : !! ngfft(18)=contain all needed information about 3D FFT, see ~abinit/doc/variables/vargs.htm#ngfft
5152 : : !! ndat=Number of FFT transforms
5153 : : !! isign=sign of Fourier transform exponent: current convention uses
5154 : : !! +1 for transforming from G to r
5155 : : !! -1 for transforming from r to G.
5156 : : !! fftn2_distrib(2),ffti2_local(2)
5157 : : !! fftn3_distrib(3),ffti3_local(3)
5158 : : !! comm_fft=MPI communicator
5159 : : !!
5160 : : !! SIDE EFFECTS
5161 : : !! Input/Output
5162 : : !! fofg(2,nfft)=f(G), complex.
5163 : : !! fofr(cplex*nfft)=input function f(r) (real or complex)
5164 : : !!
5165 : : !! SOURCE
5166 : :
5167 : 0 : subroutine fftw3_mpifourdp(cplex,nfft,ngfft,ndat,isign,&
5168 : 0 : fftn2_distrib,ffti2_local,fftn3_distrib,ffti3_local,fofg,fofr,comm_fft)
5169 : :
5170 : : !Arguments ------------------------------------
5171 : : !scalars
5172 : : integer,intent(in) :: cplex,isign,nfft,ndat,comm_fft
5173 : : !arrays
5174 : : integer,intent(in) :: ngfft(18)
5175 : : integer,intent(in) :: fftn2_distrib(ngfft(2)),ffti2_local(ngfft(2))
5176 : : integer,intent(in) :: fftn3_distrib(ngfft(3)),ffti3_local(ngfft(3))
5177 : : real(dp),intent(inout) :: fofg(2,nfft*ndat),fofr(cplex*nfft*ndat)
5178 : :
5179 : : !Local variables-------------------------------
5180 : : !scalars
5181 : : integer :: n1,n2,n3,n4,n5,n6,nd2proc,nd3proc,nproc_fft,me_fft
5182 : : !arrays
5183 : 0 : real(dp),allocatable :: workf(:,:,:,:,:),workr(:,:,:,:,:)
5184 : : ! *************************************************************************
5185 : :
5186 : : ! Note the only c2c is supported in parallel.
5187 : 0 : n1=ngfft(1); n2=ngfft(2); n3=ngfft(3)
5188 : 0 : n4=ngfft(4); n5=ngfft(5); n6=ngfft(6)
5189 : 0 : me_fft=ngfft(11); nproc_fft=ngfft(10)
5190 : :
5191 : 0 : nd2proc=((n2-1)/nproc_fft) +1
5192 : 0 : nd3proc=((n6-1)/nproc_fft) +1
5193 [ # # # # : 0 : ABI_MALLOC(workr,(2,n4,n5,nd3proc,ndat))
# # # # #
# # # # #
# # # # #
# # # #
# ]
5194 [ # # # # : 0 : ABI_MALLOC(workf,(2,n4,n6,nd2proc,ndat))
# # # # #
# # # # #
# # # # #
# # # #
# ]
5195 : :
5196 : : ! Complex to Complex
5197 : : ! TODO: Complex to Real
5198 : 0 : select case (isign)
5199 : : case (1)
5200 : : ! G --> R
5201 : 0 : call mpifft_fg2dbox(nfft,ndat,fofg,n1,n2,n3,n4,nd2proc,n6,fftn2_distrib,ffti2_local,me_fft,workf)
5202 : :
5203 : 0 : call fftw3_mpiback(2,ndat,n1,n2,n3,n4,n5,n6,n4,nd2proc,nd3proc,2,workf,workr,comm_fft)
5204 : :
5205 : 0 : call mpifft_dbox2fr(n1,n2,n3,n4,n5,nd3proc,ndat,fftn3_distrib,ffti3_local,me_fft,workr,cplex,nfft,fofr)
5206 : :
5207 : : case (-1)
5208 : : ! R --> G
5209 : 0 : call mpifft_fr2dbox(cplex,nfft,ndat,fofr,n1,n2,n3,n4,n5,nd3proc,fftn3_distrib,ffti3_local,me_fft,workr)
5210 : :
5211 : 0 : call fftw3_mpiforw(2,ndat,n1,n2,n3,n4,n5,n6,n4,nd2proc,nd3proc,2,workr,workf,comm_fft)
5212 : :
5213 : : ! Transfer FFT output to the original fft box.
5214 : 0 : call mpifft_dbox2fg(n1,n2,n3,n4,nd2proc,n6,ndat,fftn2_distrib,ffti2_local,me_fft,workf,nfft,fofg)
5215 : :
5216 : : case default
5217 [ # # # ]: 0 : ABI_BUG("Wrong isign")
5218 : : end select
5219 : :
5220 [ # # ]: 0 : ABI_FREE(workr)
5221 [ # # ]: 0 : ABI_FREE(workf)
5222 : :
5223 : 0 : end subroutine fftw3_mpifourdp
5224 : : !!***
5225 : :
5226 : : !----------------------------------------------------------------------
5227 : :
5228 : : !!****f* m_fftw3/fftw3_applypot
5229 : : !! NAME
5230 : : !! fftw3_applypot
5231 : : !!
5232 : : !! FUNCTION
5233 : : !! Applies the local real space potential to multiple wavefunctions in Fourier space
5234 : : !!
5235 : : !! INPUTS
5236 : : !! ZF: Wavefunction (input/output) (note the switch of i2 and i3)
5237 : : !! real(F(i1,i3,i2,idat))=ZF(1,i1,i3,i2,idat)
5238 : : !! imag(F(i1,i3,i2,idat))=ZF(2,i1,i3,i2,idat)
5239 : : !! max1 is positive or zero ; m1 >=max1+1
5240 : : !! i1= 1... max1+1 corresponds to positive and zero wavevectors 0 ... max1
5241 : : !! then, if m1 > max1+1, one has min1=max1-m1+1 and
5242 : : !! i1= max1+2 ... m1 corresponds to negative wavevectors min1 ... -1
5243 : : !! i2 and i3 have a similar definition of range
5244 : : !! idat=1,ndat
5245 : : !! md1,md2,md3: Dimension of ZF (input as well as output), distributed on different procs
5246 : : !! md2proc=((md2-1)/nproc_fft)+1 maximal number of small box 2nd dim slices for one proc
5247 : : !!
5248 : : !! POT: Potential
5249 : : !! POT(cplex*i1,i2,i3)
5250 : : !! cplex=1 or 2 , i1=1,n1 , i2=1,n2 , i3=1,n3
5251 : : !! nd1,nd2,nd3: dimension of pot
5252 : : !! comm_fft: MPI communicator
5253 : : !! nproc_fft: number of processors used as returned by MPI_COMM_SIZE
5254 : : !! me_fft: [0:nproc_fft-1] number of processor as returned by MPI_COMM_RANK
5255 : : !! n1,n2,n3: logical dimension of the transform. As transform lengths
5256 : : !! most products of the prime factors 2,3,5 are allowed.
5257 : : !! The detailed table with allowed transform lengths can
5258 : : !! be found in subroutine CTRIG
5259 : : !!
5260 : : !! NOTES:
5261 : : !! PERFORMANCE CONSIDERATIONS:
5262 : : !! The maximum number of processors that can reasonably be used is max(n2/2,n3/2)
5263 : : !!
5264 : : !! It is very important to find the optimal
5265 : : !! value of NCACHE. NCACHE determines the size of the work array ZW, that
5266 : : !! has to fit into cache. It has therefore to be chosen to equal roughly
5267 : : !! half the size of the physical cache in units of real*8 numbers.
5268 : : !! The optimal value of ncache can easily be determined by numerical
5269 : : !! experimentation. A too large value of ncache leads to a dramatic
5270 : : !! and sudden decrease of performance, a too small value to a to a
5271 : : !! slow and less dramatic decrease of performance. If NCACHE is set
5272 : : !! to a value so small, that not even a single one dimensional transform
5273 : : !! can be done in the workarray zw, the program stops with an error message.
5274 : : !!
5275 : : !! SOURCE
5276 : :
5277 : :
5278 : 0 : subroutine fftw3_applypot(cplexwf,cplex,ndat,n1,n2,n3,nd1,nd2,nd3,nd3proc,&
5279 : : & max1i,max2i,max3i,m1i,m2i,m3i,md1,md2proc,md3,&
5280 : 0 : & max1o,max2o,max3o,m1o,m2o,m3o,comm_fft,nproc_fft,me_fft,pot,zf)
5281 : :
5282 : : !Arguments ------------------------------------
5283 : : integer,intent(in) :: cplexwf,cplex,ndat,n1,n2,n3,nd1,nd2,nd3,nd3proc
5284 : : integer,intent(in) :: max1i,max2i,max3i,m1i,m2i,m3i,md1,md2proc,md3
5285 : : integer,intent(in) :: max1o,max2o,max3o,m1o,m2o,m3o,comm_fft,nproc_fft,me_fft
5286 : : real(dp),intent(in) :: pot(cplex*nd1,nd2,nd3)
5287 : : real(dp),intent(inout) :: zf(2,md1,md3,md2proc,ndat)
5288 : :
5289 : : !Local variables-------------------------------
5290 : : !scalars
5291 : : #ifdef HAVE_FFTW3
5292 : : integer,parameter :: unused0=0
5293 : : integer :: j,i1,i2,i3,idat,ierr,j3glob,nthreads
5294 : : integer :: ioption,j2,j3,lzt,m1zt,ma,mb,n1dfft,nnd3,lot1,lot2,lot3
5295 : : integer :: m2eff,ncache,n1eff,i1inv,i2inv,i3inv,jeff,includelast,j2stb
5296 : : integer :: jx,j2stf,Jp2stb,Jp2stf,m2ieff,m2oeff
5297 : : integer(KIND_FFTW_PLAN) :: bw_plan1_lot,bw_plan1_rest
5298 : : integer(KIND_FFTW_PLAN) :: bw_plan2_lot,bw_plan2_rest
5299 : : integer(KIND_FFTW_PLAN) :: bw_plan3_lot,bw_plan3_rest
5300 : : integer(KIND_FFTW_PLAN) :: fw_plan1_lot,fw_plan1_rest
5301 : : integer(KIND_FFTW_PLAN) :: fw_plan2_lot,fw_plan2_rest
5302 : : integer(KIND_FFTW_PLAN) :: fw_plan3_lot,fw_plan3_rest
5303 : : character(len=500) :: msg
5304 : : !arrays
5305 : : real(dp) :: tsec(2)
5306 : : real(dp), allocatable :: zmpi1(:,:,:,:),zmpi2(:,:,:,:) ! work arrays for MPI
5307 : : real(dp),allocatable :: zw(:,:),zt(:,:,:) ! cache work array and array for transpositions
5308 : : ! FFT work arrays
5309 : : ! *************************************************************************
5310 : :
5311 : : !ioption=0 ! This was in the old version.
5312 : : ioption=1 ! This one is needed to be compatible with paral_kgb
5313 : :
5314 : : ncache=2*max(n1,n2,n3,1024)
5315 : : if (ncache/(2*max(n1,n2,n3)) < 1) then
5316 : : write(msg,"(5a)") &
5317 : : 'ncache has to be enlarged to be able to hold at',ch10,&
5318 : : 'least one 1-d FFT of each size even though this will',ch10,&
5319 : : 'reduce the performance for shorter transform lengths'
5320 : : ABI_ERROR(msg)
5321 : : end if
5322 : :
5323 : : !call wrtout(std_out,"applypot standard ALLTOALL + FFTW3")
5324 : :
5325 : : ! Effective m1 and m2 (complex-to-complex or real-to-complex)
5326 : : n1eff=n1; m2ieff=m2i; m2oeff=m2o; m1zt=n1
5327 : : if (cplexwf==1) then
5328 : : n1eff=(n1+1)/2; m2ieff=m2i/2+1; m2oeff=m2o/2+1; m1zt=2*(n1/2+1)
5329 : : end if
5330 : :
5331 : : m2eff=max(m2ieff,m2oeff)
5332 : : lzt=m2eff
5333 : : if (mod(m2eff,2) == 0) lzt=lzt+1
5334 : : if (mod(m2eff,4) == 0) lzt=lzt+1
5335 : :
5336 : : ! maximal number of big box 3rd dim slices for all procs
5337 : : nnd3=nd3proc*nproc_fft
5338 : :
5339 : : ABI_MALLOC(zw,(2,ncache/2))
5340 : : ABI_MALLOC(zt,(2,lzt,m1zt))
5341 : : ABI_MALLOC(zmpi2,(2,md1,md2proc,nnd3))
5342 : : if (nproc_fft > 1) then
5343 : : ABI_MALLOC(zmpi1,(2,md1,md2proc,nnd3))
5344 : : end if
5345 : :
5346 : : lot3=ncache/(2*n3)
5347 : : lot1=ncache/(2*n1)
5348 : : lot2=ncache/(2*n2)
5349 : :
5350 : : ! The prototype for sfftw_plan_many_dft is:
5351 : : ! sfftw_plan_many_dft(rank, n, howmany,
5352 : : ! fin, iembed, istride, idist,
5353 : : ! fout, oembed, ostride, odist, isign, my_flags)
5354 : :
5355 : : nthreads = xomp_get_num_threads(open_parallel=.TRUE.)
5356 : : !nthreads = 1
5357 : :
5358 : : ! Create plans for G --> R (see back_wf)
5359 : : bw_plan3_lot = dplan_many_dft_2D(1, [n3], lot3, &
5360 : : zw, [ncache/2], lot3, 1, &
5361 : : zw, [ncache/2], lot3, 1, ABI_FFTW_BACKWARD, ABI_FFTW_ESTIMATE, nthreads)
5362 : :
5363 : : if (mod(m1i, lot3) /= 0) then
5364 : : bw_plan3_rest = dplan_many_dft_2D(1, [n3], mod(m1i, lot3),&
5365 : : zw, [ncache/2], lot3, 1, &
5366 : : zw, [ncache/2], lot3, 1, ABI_FFTW_BACKWARD, ABI_FFTW_ESTIMATE, nthreads)
5367 : : end if
5368 : :
5369 : : bw_plan1_lot = dplan_many_dft_2D(1, [n1], lot1, &
5370 : : zw, [ncache/2], lot1, 1, &
5371 : : zt, [lzt, m1zt], lzt, 1, ABI_FFTW_BACKWARD, ABI_FFTW_ESTIMATE, nthreads)
5372 : :
5373 : : if (mod(m2ieff, lot1) /= 0) then
5374 : : bw_plan1_rest = dplan_many_dft_2D(1, [n1], mod(m2ieff, lot1), &
5375 : : zw, [ncache/2], lot1, 1, &
5376 : : zt, [lzt, m1zt], lzt, 1, ABI_FFTW_BACKWARD, ABI_FFTW_ESTIMATE, nthreads)
5377 : : end if
5378 : :
5379 : : !TODO this won't work if iclexwf==1
5380 : : ! Recheck this
5381 : : bw_plan2_lot = dplan_many_dft_2D(1, [n2], lot2, &
5382 : : zw, [ncache/2], lot2, 1, &
5383 : : zw, [ncache/2], lot2, 1, ABI_FFTW_BACKWARD, ABI_FFTW_ESTIMATE, nthreads)
5384 : :
5385 : : if (mod(n1eff, lot2) /= 0) then
5386 : : bw_plan2_rest = dplan_many_dft_2D(1, [n2], mod(n1eff,lot2), &
5387 : : zw, [ncache/2], lot2, 1, &
5388 : : zw, [ncache/2], lot2, 1, ABI_FFTW_BACKWARD, ABI_FFTW_ESTIMATE, nthreads)
5389 : : end if
5390 : :
5391 : : ! Create plans for G --> R (see forw_wf)
5392 : : fw_plan3_lot = dplan_many_dft_2D(1, [n3], lot3, &
5393 : : zw, [ncache/2], lot3, 1, &
5394 : : zw, [ncache/2], lot3, 1, ABI_FFTW_FORWARD, ABI_FFTW_ESTIMATE, nthreads)
5395 : :
5396 : : if (mod(m1o, lot3) /= 0) then
5397 : : fw_plan3_rest = dplan_many_dft_2D(1, [n3], mod(m1o, lot3),&
5398 : : zw, [ncache/2], lot3, 1, &
5399 : : zw, [ncache/2], lot3, 1, ABI_FFTW_FORWARD, ABI_FFTW_ESTIMATE, nthreads)
5400 : : end if
5401 : :
5402 : : fw_plan1_lot = dplan_many_dft_2D(1, [n1], lot1,&
5403 : : zt, [lzt, m1zt], lzt, 1, &
5404 : : zw, [ncache/2], lot1, 1, ABI_FFTW_FORWARD, ABI_FFTW_ESTIMATE, nthreads)
5405 : :
5406 : : if (mod(m2oeff, lot1) /= 0) then
5407 : : fw_plan1_rest = dplan_many_dft_2D(1, [n1], mod(m2oeff, lot1),&
5408 : : zt, [lzt, m1zt], lzt, 1, &
5409 : : zw, [ncache/2], lot1, 1, ABI_FFTW_FORWARD, ABI_FFTW_ESTIMATE, nthreads)
5410 : : end if
5411 : :
5412 : : fw_plan2_lot = dplan_many_dft_2D(1, [n2], lot2,&
5413 : : zw, [ncache/2], lot2, 1, &
5414 : : zw, [ncache/2], lot2, 1, ABI_FFTW_FORWARD, ABI_FFTW_ESTIMATE, nthreads)
5415 : :
5416 : : if (mod(n1eff, lot2) /= 0) then
5417 : : fw_plan2_rest = dplan_many_dft_2D(1, [n2], mod(n1eff,lot2),&
5418 : : zw, [ncache/2], lot2, 1, &
5419 : : zw, [ncache/2], lot2, 1, ABI_FFTW_FORWARD, ABI_FFTW_ESTIMATE, nthreads)
5420 : : end if
5421 : :
5422 : : do idat=1,ndat
5423 : : !
5424 : : ! transform along z axis
5425 : : ! input: G1,G3,G2,(Gp2)
5426 : : do j2=1,md2proc
5427 : : if (me_fft*md2proc+j2 <= m2ieff) then
5428 : : do i1=1,m1i,lot3
5429 : : ma=i1
5430 : : mb=min(i1+(lot3-1),m1i)
5431 : : n1dfft=mb-ma+1
5432 : :
5433 : : ! zero-pad n1dfft G_z lines
5434 : : ! input: G1,G3,G2,(Gp2)
5435 : : call fill_cent(md1,md3,lot3,n1dfft,max3i,m3i,n3,zf(1,i1,1,j2,idat),zw)
5436 : :
5437 : : if (n1dfft == lot3) then
5438 : : call dfftw_execute_dft(bw_plan3_lot, zw, zw)
5439 : : else
5440 : : call dfftw_execute_dft(bw_plan3_rest, zw, zw)
5441 : : end if
5442 : :
5443 : : ! Local rotation.
5444 : : ! input: G1,R3,G2,(Gp2)
5445 : : ! output: G1,G2,R3,(Gp2)
5446 : : call scramble(i1,j2,lot3,n1dfft,md1,n3,md2proc,nnd3,zw,zmpi2)
5447 : : end do
5448 : : end if
5449 : : end do
5450 : :
5451 : : ! Interprocessor data transposition
5452 : : ! input: G1,G2,R3,Rp3,(Gp2)
5453 : : ! output: G1,G2,R3,Gp2,(Rp3)
5454 : : if (nproc_fft > 1) then
5455 : : call timab(543,1,tsec)
5456 : : call xmpi_alltoall(zmpi2,2*md1*md2proc*nd3proc,&
5457 : : zmpi1,2*md1*md2proc*nd3proc,comm_fft,ierr)
5458 : : call timab(543,2,tsec)
5459 : : end if
5460 : :
5461 : : do j3=1,nd3proc
5462 : : j3glob = j3 + me_fft*nd3proc
5463 : : if (me_fft*nd3proc+j3 <= n3) then
5464 : : Jp2stb=1; J2stb=1
5465 : : Jp2stf=1; J2stf=1
5466 : :
5467 : : ! transform along x axis
5468 : : do j=1,m2ieff,lot1
5469 : : ma=j
5470 : : mb=min(j+(lot1-1),m2ieff)
5471 : : n1dfft=mb-ma+1
5472 : :
5473 : : ! Zero-pad input.
5474 : : ! input: G1,G2,R3,G2,(Rp3)
5475 : : ! output: G2,G1,R3,G2,(Rp3)
5476 : : if (nproc_fft == 1) then
5477 : : call mpiswitch_cent(j3,n1dfft,Jp2stb,J2stb,lot1,max1i,md1,m1i,n1,&
5478 : : md2proc,nd3proc,nproc_fft,ioption,zmpi2,zw, unused0, unused0, unused0)
5479 : : else
5480 : : call mpiswitch_cent(j3,n1dfft,Jp2stb,J2stb,lot1,max1i,md1,m1i,n1,&
5481 : : md2proc,nd3proc,nproc_fft,ioption,zmpi1,zw, unused0, unused0, unused0)
5482 : : end if
5483 : :
5484 : : ! Transform along x
5485 : : ! input: G2,G1,R3,(Rp3)
5486 : : ! output: G2,R1,R3,(Rp3)
5487 : : if (n1dfft == lot1) then
5488 : : call dfftw_execute_dft(bw_plan1_lot, zw, zt(1,j,1))
5489 : : else
5490 : : call dfftw_execute_dft(bw_plan1_rest, zw, zt(1,j,1))
5491 : : end if
5492 : : end do
5493 : :
5494 : : ! Transform along y axis (take into account c2c or c2r case).
5495 : : ! Must loop over the full box.
5496 : : !TODO this won't work
5497 : : if (cplexwf==1) then
5498 : : if(mod(lot2,2).ne.0) lot2=lot2-1 ! needed to introduce jeff
5499 : : end if
5500 : :
5501 : : do j=1,n1eff,lot2
5502 : : ma=j
5503 : : mb=min(j+(lot2-1),n1eff)
5504 : : n1dfft=mb-ma+1
5505 : : jeff=j
5506 : : includelast=1
5507 : :
5508 : : if (cplexwf==1) then
5509 : : jeff=2*j-1
5510 : : includelast=1
5511 : : if (mb==n1eff .and. n1eff*2/=n1) includelast=0
5512 : : end if
5513 : :
5514 : : ! Zero-pad the input.
5515 : : ! input: G2,R1,R3,(Rp3)
5516 : : ! output: R1,G2,R3,(Rp3)
5517 : : if (cplexwf==2) then
5518 : : call switch_cent(n1dfft,max2i,m2i,n2,lot2,n1,lzt,zt(1,1,jeff),zw)
5519 : : else
5520 : : call switchreal_cent(includelast,n1dfft,max2i,n2,lot2,m1zt,lzt,zt(1,1,jeff),zw)
5521 : : end if
5522 : :
5523 : : ! input: R1,G2,R3,(Rp3)
5524 : : ! output: R1,R2,R3,(Rp3)
5525 : : ! Be careful here
5526 : : if (n1dfft == lot2) then
5527 : : call dfftw_execute_dft(bw_plan2_lot, zw, zw)
5528 : : else
5529 : : call dfftw_execute_dft(bw_plan2_rest, zw, zw)
5530 : : end if
5531 : :
5532 : : ! Multiply with potential in real space
5533 : : jx=cplex*(jeff-1)+1
5534 : : call multpot(cplexwf,cplex,includelast,nd1,nd2,n2,lot2,n1dfft,pot(jx,1,j3glob),zw)
5535 : :
5536 : : ! TRANSFORM BACK IN FOURIER SPACE
5537 : : ! transform along y axis
5538 : : ! input: R1,R2,R3,(Rp3)
5539 : : if (n1dfft == lot2) then
5540 : : call dfftw_execute_dft(fw_plan2_lot, zw, zw)
5541 : : else
5542 : : call dfftw_execute_dft(fw_plan2_rest, zw, zw)
5543 : : end if
5544 : :
5545 : : ! input: R1,G2,R3,(Rp3)
5546 : : ! output: G2,R1,R3,(Rp3)
5547 : : if (cplexwf==2) then
5548 : : call unswitch_cent(n1dfft,max2o,m2o,n2,lot2,n1,lzt,zw,zt(1,1,jeff))
5549 : : else
5550 : : call unswitchreal_cent(n1dfft,max2o,n2,lot2,n1,lzt,zw,zt(1,1,jeff))
5551 : : end if
5552 : : end do ! j
5553 : :
5554 : : ! transform along x axis
5555 : : ! input: R2,R1,R3,(Rp3)
5556 : : ! output: R2,G1,R3,(Rp3)
5557 : : do j=1,m2oeff,lot1
5558 : : ma=j
5559 : : mb=min(j+(lot1-1),m2oeff)
5560 : : n1dfft=mb-ma+1
5561 : :
5562 : : if (n1dfft == lot1) then
5563 : : call dfftw_execute_dft(fw_plan1_lot, zt(1,j,1), zw)
5564 : : else
5565 : : call dfftw_execute_dft(fw_plan1_rest, zt(1,j,1), zw)
5566 : : end if
5567 : :
5568 : : ! input: G2,G1,R3,Gp2,(Rp3)
5569 : : ! output: G1,G2,R3,Gp2,(Rp3)
5570 : : if (nproc_fft == 1) then
5571 : : call unmpiswitch_cent(j3,n1dfft,Jp2stf,J2stf,lot1,max1o,md1,m1o,n1,&
5572 : : md2proc,nd3proc,nproc_fft,ioption,zw,zmpi2)
5573 : : else
5574 : : call unmpiswitch_cent(j3,n1dfft,Jp2stf,J2stf,lot1,max1o,md1,m1o,n1,&
5575 : : md2proc,nd3proc,nproc_fft,ioption,zw,zmpi1)
5576 : : end if
5577 : : end do ! j
5578 : : end if
5579 : : end do
5580 : :
5581 : : ! Interprocessor data transposition
5582 : : ! input: G1,G2,R3,Gp2,(Rp3)
5583 : : ! output: G1,G2,R3,Rp3,(Gp2)
5584 : : if (nproc_fft > 1) then
5585 : : call timab(544,1,tsec)
5586 : : call xmpi_alltoall(zmpi1,2*md1*md2proc*nd3proc, &
5587 : : zmpi2,2*md1*md2proc*nd3proc,comm_fft,ierr)
5588 : : call timab(544,2,tsec)
5589 : : end if
5590 : :
5591 : : ! transform along z axis
5592 : : ! input: G1,G2,R3,(Gp2)
5593 : : !lot=ncache/(4*n3)
5594 : : do j2=1,md2proc
5595 : : if (me_fft*md2proc+j2 <= m2oeff) then
5596 : : do i1=1,m1o,lot3
5597 : : ma=i1
5598 : : mb=min(i1+(lot3-1),m1o)
5599 : : n1dfft=mb-ma+1
5600 : :
5601 : : ! input: G1,G2,R3,(Gp2)
5602 : : ! output: G1,R3,G2,(Gp2)
5603 : : call unscramble(i1,j2,lot3,n1dfft,md1,n3,md2proc,nnd3,zmpi2,zw)
5604 : :
5605 : : if (n1dfft == lot3) then
5606 : : call dfftw_execute_dft(fw_plan3_lot, zw, zw)
5607 : : else
5608 : : call dfftw_execute_dft(fw_plan3_rest, zw, zw)
5609 : : end if
5610 : :
5611 : : call unfill_cent(md1,md3,lot3,n1dfft,max3o,m3o,n3,zw,zf(1,i1,1,j2,idat))
5612 : : ! output: G1,G3,G2,(Gp2)
5613 : : end do
5614 : : end if
5615 : : end do
5616 : :
5617 : : ! Complete missing values with complex conjugate
5618 : : ! Inverse of ix is located at nx+2-ix , except for ix=1, for which it is 1.
5619 : : if (cplexwf==1) then
5620 : : do i3=1,m3o
5621 : : i3inv=m3o+2-i3
5622 : : if (i3==1) i3inv=1
5623 : : if (m2oeff>1)then
5624 : : do i2=2,m2oeff
5625 : : i2inv=m2o+2-i2
5626 : : zf(1,1,i3inv,i2inv,idat)= zf(1,1,i3,i2,idat)
5627 : : zf(2,1,i3inv,i2inv,idat)=-zf(2,1,i3,i2,idat)
5628 : : do i1=2,m1o
5629 : : i1inv=m1o+2-i1
5630 : : zf(1,i1inv,i3inv,i2inv,idat)= zf(1,i1,i3,i2,idat)
5631 : : zf(2,i1inv,i3inv,i2inv,idat)=-zf(2,i1,i3,i2,idat)
5632 : : end do
5633 : : end do
5634 : : end if
5635 : : end do
5636 : : end if
5637 : :
5638 : : end do ! idat
5639 : :
5640 : : call dfftw_destroy_plan(bw_plan3_lot)
5641 : : if (mod(m1i, lot3) /= 0) call dfftw_destroy_plan(bw_plan3_rest)
5642 : :
5643 : : call dfftw_destroy_plan(bw_plan1_lot)
5644 : : if (mod(m2ieff, lot1) /= 0) call dfftw_destroy_plan(bw_plan1_rest)
5645 : :
5646 : : call dfftw_destroy_plan(bw_plan2_lot)
5647 : : if (mod(n1eff, lot2) /= 0) call dfftw_destroy_plan(bw_plan2_rest)
5648 : :
5649 : : call dfftw_destroy_plan(fw_plan3_lot)
5650 : : if (mod(m1o, lot3) /= 0) call dfftw_destroy_plan(fw_plan3_rest)
5651 : :
5652 : : call dfftw_destroy_plan(fw_plan1_lot)
5653 : : if (mod(m2oeff, lot1) /= 0) call dfftw_destroy_plan(fw_plan1_rest)
5654 : :
5655 : : call dfftw_destroy_plan(fw_plan2_lot)
5656 : : if (mod(n1eff, lot2) /= 0) call dfftw_destroy_plan(fw_plan2_rest)
5657 : :
5658 : : ABI_FREE(zmpi2)
5659 : : ABI_FREE(zw)
5660 : : ABI_FREE(zt)
5661 : : if (nproc_fft > 1) then
5662 : : ABI_FREE(zmpi1)
5663 : : end if
5664 : :
5665 : : #else
5666 : 0 : ABI_ERROR("FFTW3 support not activated")
5667 : : ABI_UNUSED((/cplexwf,cplex,ndat,n1,n2,n3,nd1,nd2,nd3,nd3proc/))
5668 : : ABI_UNUSED((/max1i,max2i,max3i,m1i,m2i,m3i,md1,md2proc,md3/))
5669 : : ABI_UNUSED((/max1o,max2o,max3o,m1o,m2o,m3o,comm_fft,nproc_fft,me_fft/))
5670 : : ABI_UNUSED((/pot(1,1,1),zf(1,1,1,1,1)/))
5671 : : #endif
5672 : :
5673 : 0 : end subroutine fftw3_applypot
5674 : : !!***
5675 : :
5676 : : !----------------------------------------------------------------------
5677 : :
5678 : : !!****f* m_fftw3/fftw3_accrho
5679 : : !! NAME
5680 : : !! fftw3_accrho
5681 : : !!
5682 : : !! FUNCTION
5683 : : !! Accumulates the real space density rho from the ndat wavefunctions zf
5684 : : !! by transforming zf into real space and adding all the amplitudes squared
5685 : : !!
5686 : : !! INPUTS:
5687 : : !! ZF: input array (note the switch of i2 and i3)
5688 : : !! real(F(i1,i3,i2,idat))=ZF(1,i1,i3,i2,idat)
5689 : : !! imag(F(i1,i3,i2,idat))=ZF(2,i1,i3,i2,idat)
5690 : : !! max1 is positive or zero ; m1 >=max1+1
5691 : : !! i1= 1... max1+1 corresponds to positive and zero wavevectors 0 ... max1
5692 : : !! then, if m1 > max1+1, one has min1=max1-m1+1 and
5693 : : !! i1= max1+2 ... m1 corresponds to negative wavevectors min1 ... -1
5694 : : !! i2 and i3 have a similar definition of range
5695 : : !! idat=1,ndat
5696 : : !! md1,md2,md3: Dimension of ZF
5697 : : !! md2proc=((md2-1)/nproc_fft)+1 ! maximal number of small box 2nd dim slices for one proc
5698 : : !! weight(ndat)= weight for the density accumulation
5699 : : !!
5700 : : !! OUTPUTS:
5701 : : !! RHOoutput(i1,i2,i3) = RHOinput(i1,i2,i3) + sum on idat of (FFT(ZF))**2 *weight
5702 : : !! i1=1,n1 , i2=1,n2 , i3=1,n3
5703 : : !! comm_fft: MPI communicator
5704 : : !! nproc_fft: number of processors used as returned by MPI_COMM_SIZE
5705 : : !! me_fft: [0:nproc_fft-1] number of processor as returned by MPI_COMM_RANK
5706 : : !! n1,n2,n3: logical dimension of the transform. As transform lengths
5707 : : !! most products of the prime factors 2,3,5 are allowed.
5708 : : !! The detailed table with allowed transform lengths can
5709 : : !! be found in subroutine CTRIG
5710 : : !! nd1,nd2,nd3: Dimension of RHO
5711 : : !! nd3proc=((nd3-1)/nproc_fft)+1 ! maximal number of big box 3rd dim slices for one proc
5712 : : !!
5713 : : !! NOTES:
5714 : : !! PERFORMANCE CONSIDERATIONS:
5715 : : !! The maximum number of processors that can reasonably be used is max(n2/2,n3/2)
5716 : : !!
5717 : : !! It is very important to find the optimal
5718 : : !! value of NCACHE. NCACHE determines the size of the work array ZW, that
5719 : : !! has to fit into cache. It has therefore to be chosen to equal roughly
5720 : : !! half the size of the physical cache in units of real*8 numbers.
5721 : : !! The optimal value of ncache can easily be determined by numerical
5722 : : !! experimentation. A too large value of ncache leads to a dramatic
5723 : : !! and sudden decrease of performance, a too small value to a to a
5724 : : !! slow and less dramatic decrease of performance. If NCACHE is set
5725 : : !! to a value so small, that not even a single one dimensional transform
5726 : : !! can be done in the workarray zw, the program stops with an error message.
5727 : : !!
5728 : : !! SOURCE
5729 : :
5730 : 0 : subroutine fftw3_accrho(cplexwf,ndat,n1,n2,n3,nd1,nd2,nd3,nd3proc,&
5731 : 0 : & max1,max2,max3,m1,m2,m3,md1,md2proc,md3,comm_fft,nproc_fft,me_fft,zf,rho,weight_r,weight_i)
5732 : :
5733 : : !Arguments ------------------------------------
5734 : : integer,intent(in) :: cplexwf,ndat,n1,n2,n3,nd1,nd2,nd3,nd3proc
5735 : : integer,intent(in) :: max1,max2,max3,m1,m2,m3,md1,md2proc,md3,comm_fft,nproc_fft,me_fft
5736 : : real(dp),intent(in) :: zf(2,md1,md3,md2proc,ndat)
5737 : : real(dp),intent(in) :: weight_r(ndat) , weight_i(ndat)
5738 : : real(dp),intent(inout) :: rho(nd1,nd2,nd3)
5739 : :
5740 : : !Local variables-------------------------------
5741 : : !scalars
5742 : : #ifdef HAVE_FFTW3
5743 : : integer,parameter :: unused0=0
5744 : : integer :: j,i1,idat,ierr,j3glob
5745 : : integer :: ioption,j2,j3,j2st,jp2st,lzt,m1zt,ma,mb,n1dfft,nnd3
5746 : : integer :: m2eff,ncache,n1eff,jeff,includelast,lot1,lot2,lot3,nthreads
5747 : : integer(KIND_FFTW_PLAN) :: bw_plan1_lot,bw_plan1_rest
5748 : : integer(KIND_FFTW_PLAN) :: bw_plan2_lot,bw_plan2_rest
5749 : : integer(KIND_FFTW_PLAN) :: bw_plan3_lot,bw_plan3_rest
5750 : : character(len=500) :: msg
5751 : : !arrays
5752 : : real(dp), allocatable :: zmpi1(:,:,:,:),zmpi2(:,:,:,:) ! work arrays for MPI
5753 : : real(dp),allocatable :: zw(:,:),zt(:,:,:) ! cache work array and array for transpositions
5754 : : real(dp) :: tsec(2)
5755 : : ! *************************************************************************
5756 : :
5757 : : !ioption=0 ! This was in the old version.
5758 : : ioption=1 ! This one is needed to be compatible with paral_kgb
5759 : :
5760 : : !nproc_fft = xmpi_comm_size(comm_fft); me_fft = xmpi_comm_rank(comm_fft)
5761 : :
5762 : : ! find cache size that gives optimal performance on machine
5763 : : ncache=2*max(n1,n2,n3,1024)
5764 : : if (ncache/(2*max(n1,n2,n3)) < 1) then
5765 : : write(msg,"(5a)") &
5766 : : 'ncache has to be enlarged to be able to hold at',ch10,&
5767 : : 'least one 1-d FFT of each size even though this will',ch10,&
5768 : : 'reduce the performance for shorter transform lengths'
5769 : : ABI_ERROR(msg)
5770 : : end if
5771 : :
5772 : : !Effective m1 and m2 (complex-to-complex or real-to-complex)
5773 : : n1eff=n1; m2eff=m2 ; m1zt=n1
5774 : : if (cplexwf==1) then
5775 : : n1eff=(n1+1)/2; m2eff=m2/2+1; m1zt=2*(n1/2+1)
5776 : : end if
5777 : :
5778 : : lzt=m2eff
5779 : : if (mod(m2eff,2) == 0) lzt=lzt+1
5780 : : if (mod(m2eff,4) == 0) lzt=lzt+1
5781 : :
5782 : : ! maximal number of big box 3rd dim slices for all procs
5783 : : nnd3=nd3proc*nproc_fft
5784 : :
5785 : : ABI_MALLOC(zw,(2,ncache/2))
5786 : : ABI_MALLOC(zt,(2,lzt,m1zt))
5787 : : ABI_MALLOC(zmpi2,(2,md1,md2proc,nnd3))
5788 : : if (nproc_fft > 1) then
5789 : : ABI_MALLOC(zmpi1,(2,md1,md2proc,nnd3))
5790 : : end if
5791 : :
5792 : : ! Create plans.
5793 : : ! The prototype for sfftw_plan_many_dft is:
5794 : : ! sfftw_plan_many_dft(rank, n, howmany,
5795 : : ! fin, iembed, istride, idist,
5796 : : ! fout, oembed, ostride, odist, isign, my_flags)
5797 : :
5798 : : lot3=ncache/(2*n3)
5799 : : lot1=ncache/(2*n1)
5800 : : lot2=ncache/(2*n2)
5801 : :
5802 : : nthreads = xomp_get_num_threads(open_parallel=.TRUE.)
5803 : : !nthreads = 1
5804 : :
5805 : : bw_plan3_lot = dplan_many_dft_2D(1, [n3], lot3, &
5806 : : zw, [ncache/2], lot3, 1, &
5807 : : zw, [ncache/2], lot3, 1, ABI_FFTW_BACKWARD, ABI_FFTW_ESTIMATE, nthreads)
5808 : :
5809 : : if (mod(m1, lot3) /= 0) then
5810 : : bw_plan3_rest = dplan_many_dft_2D(1, [n3], mod(m1, lot3), &
5811 : : zw, [ncache/2], lot3, 1, &
5812 : : zw, [ncache/2], lot3, 1, ABI_FFTW_BACKWARD, ABI_FFTW_ESTIMATE, nthreads)
5813 : : end if
5814 : :
5815 : : bw_plan1_lot = dplan_many_dft_2D(1, [n1], lot1, &
5816 : : zw, [ncache/2], lot1, 1, &
5817 : : zt, [lzt, m1zt], lzt, 1, ABI_FFTW_BACKWARD, ABI_FFTW_ESTIMATE, nthreads)
5818 : :
5819 : : if (mod(m2eff, lot1) /= 0) then
5820 : : bw_plan1_rest = dplan_many_dft_2D(1, [n1], mod(m2eff, lot1), &
5821 : : zw, [ncache/2], lot1, 1, &
5822 : : zt, [lzt, m1zt], lzt, 1, ABI_FFTW_BACKWARD, ABI_FFTW_ESTIMATE, nthreads)
5823 : : end if
5824 : :
5825 : : ! FIXME THis won't work if ixplexwf == 1
5826 : : bw_plan2_lot = dplan_many_dft_2D(1, [n2], lot2, &
5827 : : zw, [ncache/2], lot2, 1, &
5828 : : zw, [ncache/2], lot2, 1, ABI_FFTW_BACKWARD, ABI_FFTW_ESTIMATE, nthreads)
5829 : :
5830 : : if (mod(n1eff, lot2) /= 0) then
5831 : : bw_plan2_rest = dplan_many_dft_2D(1, [n2], mod(n1eff,lot2), &
5832 : : zw, [ncache/2], lot2, 1, &
5833 : : zw, [ncache/2], lot2, 1, ABI_FFTW_BACKWARD, ABI_FFTW_ESTIMATE, nthreads)
5834 : : end if
5835 : :
5836 : : do idat=1,ndat
5837 : : ! transform along z axis
5838 : : ! input: I1,I3,J2,(Jp2)
5839 : : !lot=ncache/(4*n3)
5840 : :
5841 : : ! Loop over the y planes treated by this node and transform n1ddft G_z lines.
5842 : : do j2=1,md2proc
5843 : : if (me_fft*md2proc+j2 <= m2eff) then ! MG REMOVED TO BE CONSISTENT WITH BACK_WF
5844 : : do i1=1,m1,lot3
5845 : : ma=i1
5846 : : mb=min(i1+(lot3-1),m1)
5847 : : n1dfft=mb-ma+1
5848 : :
5849 : : ! zero-pad n1dfft G_z lines
5850 : : ! input: G1,G3,G2,(Gp2)
5851 : : ! output: G1,R3,G2,(Gp2)
5852 : : call fill_cent(md1,md3,lot3,n1dfft,max3,m3,n3,zf(1,i1,1,j2,idat),zw)
5853 : :
5854 : : ! Transform along z.
5855 : : if (n1dfft == lot3) then
5856 : : call dfftw_execute_dft(bw_plan3_lot, zw, zw)
5857 : : else
5858 : : call dfftw_execute_dft(bw_plan3_rest, zw, zw)
5859 : : end if
5860 : :
5861 : : ! Local rotation.
5862 : : ! input: G1,R3,G2,(Gp2)
5863 : : ! output: G1,G2,R3,(Gp2)
5864 : : call scramble(i1,j2,lot3,n1dfft,md1,n3,md2proc,nnd3,zw,zmpi2)
5865 : : end do
5866 : : end if
5867 : : end do
5868 : :
5869 : : ! Interprocessor data transposition
5870 : : ! input: G1,G2,R3,Rp3,(Gp2)
5871 : : ! output: G1,G2,R3,Gp2,(Rp3)
5872 : : if (nproc_fft > 1) then
5873 : : call timab(543,1,tsec)
5874 : : call xmpi_alltoall(zmpi2,2*md1*md2proc*nd3proc, &
5875 : : zmpi1,2*md1*md2proc*nd3proc,comm_fft,ierr)
5876 : : call timab(543,2,tsec)
5877 : : end if
5878 : :
5879 : : ! Loop over the z treated by this node.
5880 : : do j3=1,nd3proc
5881 : : j3glob = j3 + me_fft*nd3proc
5882 : :
5883 : : if (me_fft*nd3proc+j3 <= n3) then
5884 : : Jp2st=1; J2st=1
5885 : :
5886 : : ! Loop over G_y in the small box.
5887 : : do j=1,m2eff,lot1
5888 : : ma=j
5889 : : mb=min(j+(lot1-1),m2eff)
5890 : : n1dfft=mb-ma+1
5891 : :
5892 : : ! Zero-pad input.
5893 : : ! input: G1,G2,R3,JG2,(Rp3)
5894 : : ! output: G2,G1,R3,JG2,(Rp3)
5895 : : if (nproc_fft == 1) then
5896 : : call mpiswitch_cent(j3,n1dfft,Jp2st,J2st,lot1,max1,md1,m1,n1,&
5897 : : md2proc,nd3proc,nproc_fft,ioption,zmpi2,zw,unused0, unused0,unused0)
5898 : : else
5899 : : call mpiswitch_cent(j3,n1dfft,Jp2st,J2st,lot1,max1,md1,m1,n1,&
5900 : : md2proc,nd3proc,nproc_fft,ioption,zmpi1,zw, unused0,unused0,unused0)
5901 : : end if
5902 : :
5903 : : ! Transform along x
5904 : : ! input: G2,G1,R3,(Rp3)
5905 : : ! output: G2,R1,R3,(Rp3)
5906 : : if (n1dfft == lot1) then
5907 : : call dfftw_execute_dft(bw_plan1_lot, zw, zt(1,j,1))
5908 : : else
5909 : : call dfftw_execute_dft(bw_plan1_rest, zw, zt(1,j,1))
5910 : : end if
5911 : :
5912 : : end do
5913 : :
5914 : : ! Transform along y axis (take into account c2c or c2r case).
5915 : : ! Must loop over the full box.
5916 : : !lot=ncache/(4*n2)
5917 : : ! FIXME THis won't work
5918 : : if (cplexwf==1) then
5919 : : if (mod(lot2,2) /=0) lot2=lot2-1 ! needed to introduce jeff
5920 : : end if
5921 : :
5922 : : do j=1,n1eff,lot2
5923 : : ma=j
5924 : : mb=min(j+(lot2-1),n1eff)
5925 : : n1dfft=mb-ma+1
5926 : : jeff=j
5927 : : includelast=1
5928 : :
5929 : : if (cplexwf==1) then
5930 : : jeff=2*j-1
5931 : : includelast=1
5932 : : if (mb==n1eff .and. n1eff*2/=n1) includelast=0
5933 : : end if
5934 : :
5935 : : ! Zero-pad the input.
5936 : : ! input: G2,R1,R3,(Rp3)
5937 : : ! output: R1,G2,R3,(Rp3)
5938 : : if (cplexwf==2) then
5939 : : call switch_cent(n1dfft,max2,m2,n2,lot2,n1,lzt,zt(1,1,j),zw)
5940 : : else
5941 : : call switchreal_cent(includelast,n1dfft,max2,n2,lot2,m1zt,lzt,zt(1,1,jeff),zw)
5942 : : end if
5943 : :
5944 : : if (n1dfft == lot2) then
5945 : : call dfftw_execute_dft(bw_plan2_lot, zw, zw)
5946 : : else
5947 : : call dfftw_execute_dft(bw_plan2_rest, zw, zw)
5948 : : end if
5949 : :
5950 : : ! Accumulate
5951 : : call addrho(cplexwf,includelast,nd1,nd2,n2,lot2,n1dfft,&
5952 : : & zw,rho(jeff,1,j3glob),weight_r(idat),weight_i(idat))
5953 : : end do
5954 : : ! output: i1,i2,j3,(jp3)
5955 : :
5956 : : end if
5957 : : end do ! j3
5958 : : end do ! idat
5959 : :
5960 : : call dfftw_destroy_plan(bw_plan3_lot)
5961 : : if (mod(m1, lot3) /= 0) call dfftw_destroy_plan(bw_plan3_rest)
5962 : :
5963 : : call dfftw_destroy_plan(bw_plan1_lot)
5964 : : if (mod(m2eff, lot1) /= 0) call dfftw_destroy_plan(bw_plan1_rest)
5965 : :
5966 : : call dfftw_destroy_plan(bw_plan2_lot)
5967 : : if (mod(n1eff, lot2) /= 0) call dfftw_destroy_plan(bw_plan2_rest)
5968 : :
5969 : : ABI_FREE(zmpi2)
5970 : : ABI_FREE(zw)
5971 : : ABI_FREE(zt)
5972 : : if (nproc_fft > 1) then
5973 : : ABI_FREE(zmpi1)
5974 : : end if
5975 : :
5976 : : #else
5977 : 0 : ABI_ERROR("FFTW3 support not activated")
5978 : : ABI_UNUSED((/cplexwf,ndat,n1,n2,n3,nd1,nd2,nd3proc/))
5979 : : ABI_UNUSED((/ max1,max2,max3,m1,m2,m3,md1,md2proc,md3,comm_fft,nproc_fft,me_fft/))
5980 : : ABI_UNUSED((/zf(1,1,1,1,1),rho(1,1,1),weight_r(1),weight_i(1)/))
5981 : : #endif
5982 : :
5983 : 0 : end subroutine fftw3_accrho
5984 : : !!***
5985 : :
5986 : : !----------------------------------------------------------------------
5987 : :
5988 : : !!****f* m_fftw3/fftw3_mpiback_manywf
5989 : : !! NAME
5990 : : !! fftw3_mpiback_manywf
5991 : : !!
5992 : : !! FUNCTION
5993 : : !! Does multiple 3-dim backward FFTs from Fourier into real space
5994 : : !! Adopt standard convention that isign=1 for backward transform
5995 : : !!
5996 : : !! CALCULATES THE DISCRETE FOURIER TRANSFORM ZF(I1,I2,I3)=
5997 : : !!
5998 : : !! S_(j1,j2,j3) EXP(isign*i*2*pi*(j1*i1/n1+j2*i2/n2+j3*i3/n3)) ZF(j1,j3,j2)
5999 : : !!
6000 : : !! in parallel using MPI/OpenMP.
6001 : : !!
6002 : : !! INPUTS:
6003 : : !! cplexwf=1 if wavefunction is real, 2 if complex
6004 : : !! ndat=Number of wavefunctions to transform.
6005 : : !! n1,n2,n3: logical dimension of the transform. As transform lengths
6006 : : !! most products of the prime factors 2,3,5 are allowed.
6007 : : !! The detailed table with allowed transform lengths can be found in subroutine CTRIG
6008 : : !! nd1,nd2,nd3: Leading Dimension of ZR
6009 : : !! nd3proc=((nd3-1)/nproc_fft)+1 maximal number of big box 3rd dim slices for one proc
6010 : : !! max1 is positive or zero; m1 >=max1+1
6011 : : !! i1= 1... max1+1 corresponds to positive and zero wavevectors 0 ... max1
6012 : : !! then, if m1 > max1+1, one has min1=max1-m1+1 and
6013 : : !! i1= max1+2 ... m1 corresponds to negative wavevectors min1 ... -1
6014 : : !! max2 and max3 have a similar definition of range
6015 : : !! m1,m2,m3=Size of the box enclosing the G-sphere.
6016 : : !! md1,md2,md3: Dimension of ZF given on the **small** FFT box.
6017 : : !! md2proc=((md2-1)/nproc_fft)+1 maximal number of small box 2nd dim slices for one proc
6018 : : !! nproc_fft: number of processors used as returned by MPI_COMM_SIZE
6019 : : !! comm_fft=MPI communicator for the FFT.
6020 : : !! ZF: input array (note the switch of i2 and i3)
6021 : : !! real(F(i1,i3,i2,idat))=ZF(1,i1,i3,i2,idat)
6022 : : !! imag(F(i1,i3,i2,idat))=ZF(2,i1,i3,i2,idat)
6023 : : !!
6024 : : !! OUTPUTS
6025 : : !! ZR: output array
6026 : : !! ZR(1,i1,i2,i3,idat)=real(R(i1,i2,i3,idat))
6027 : : !! ZR(2,i1,i2,i3,idat)=imag(R(i1,i2,i3,idat))
6028 : : !! i1=1,n1 , i2=1,n2 , i3=1,n3 , idat=1,ndat
6029 : : !!
6030 : : !! NOTES
6031 : : !! The maximum number of processors that can reasonably be used is max(n2/2,n3/2)
6032 : : !!
6033 : : !! It is very important to find the optimal
6034 : : !! value of NCACHE. NCACHE determines the size of the work array ZW, that
6035 : : !! has to fit into cache. It has therefore to be chosen to equal roughly
6036 : : !! half the size of the physical cache in units of real*8 numbers.
6037 : : !! The optimal value of ncache can easily be determined by numerical
6038 : : !! experimentation. A too large value of ncache leads to a dramatic
6039 : : !! and sudden decrease of performance, a too small value to a to a
6040 : : !! slow and less dramatic decrease of performance. If NCACHE is set
6041 : : !! to a value so small, that not even a single one dimensional transform
6042 : : !! can be done in the workarray zw, the program stops with an error message.
6043 : : !!
6044 : : !! SOURCE
6045 : :
6046 : 0 : subroutine fftw3_mpiback_manywf(cplexwf,ndat,n1,n2,n3,nd1,nd2,nd3proc,&
6047 : 0 : & max1,max2,max3,m1,m2,m3,md1,md2proc,md3,zf,zr,comm_fft)
6048 : :
6049 : : !Arguments ------------------------------------
6050 : : integer,intent(in) :: cplexwf,ndat,n1,n2,n3,nd1,nd2,nd3proc
6051 : : integer,intent(in) :: max1,max2,max3,m1,m2,m3,md1,md2proc,md3,comm_fft
6052 : : real(dp),intent(in) :: zf(2,md1,md3,md2proc,ndat)
6053 : : real(dp),intent(out) :: zr(2,nd1,nd2,nd3proc,ndat)
6054 : :
6055 : : #ifdef HAVE_FFTW3
6056 : : !Local variables-------------------------------
6057 : : integer,parameter :: nt1=1
6058 : : integer :: j,i1,i2,idat,ierr,includelast,nthreads
6059 : : integer :: ioption,j2,j3,j2st,jp2st,jeff,lzt,m1zt,ma,mb,n1dfft,nnd3
6060 : : integer :: lot1,lot2,lot3
6061 : : integer :: m2eff,ncache,n1eff,n1half,nproc_fft,me_fft
6062 : : integer(KIND_FFTW_PLAN) :: bw_plan1_lot,bw_plan1_rest
6063 : : integer(KIND_FFTW_PLAN) :: bw_plan2_lot,bw_plan2_rest
6064 : : integer(KIND_FFTW_PLAN) :: bw_plan3_lot,bw_plan3_rest
6065 : : !type(C_PTR) :: zw_cptr,zt_cptr
6066 : : character(len=500) :: msg
6067 : : !arrays
6068 : : integer :: requests(ndat)
6069 : : real(dp) ABI_ASYNC, allocatable :: zmpi1(:,:,:,:,:),zmpi2(:,:,:,:,:) ! work arrays for MPI
6070 : : real(dp),allocatable :: zw(:,:),zt(:,:,:) ! cache work array and array for transpositions
6071 : : !real(dp),contiguous, pointer :: zw(:,:),zt(:,:,:)
6072 : : ! FFT work arrays
6073 : : real(dp) :: tsec(2)
6074 : : ! *************************************************************************
6075 : :
6076 : : !call wrtout(std_out,"mpiback with non-blocking IALLTOALL + FFTW3")
6077 : : ! FIXME must provide a default value but which one?
6078 : : ! ioption = 0
6079 : : ioption = 1
6080 : : !if (paral_kgb==1) ioption=1
6081 : :
6082 : : nproc_fft = xmpi_comm_size(comm_fft); me_fft = xmpi_comm_rank(comm_fft)
6083 : :
6084 : : ! Find cache size that gives optimal performance on machine
6085 : : ncache=2*max(n1,n2,n3,1024)
6086 : : if (ncache/(2*max(n1,n2,n3))<1) then
6087 : : write(msg,"(5a)") &
6088 : : 'ncache has to be enlarged to be able to hold at',ch10, &
6089 : : 'least one 1-d FFT of each size even though this will',ch10,&
6090 : : 'reduce the performance for shorter transform lengths'
6091 : : ABI_ERROR(msg)
6092 : : end if
6093 : :
6094 : : ! Effective m1 and m2 (complex-to-complex or real-to-complex)
6095 : : n1eff=n1; m2eff=m2; m1zt=n1
6096 : : if (cplexwf==1) then
6097 : : n1eff=(n1+1)/2; m2eff=m2/2+1; m1zt=2*(n1/2+1)
6098 : : end if
6099 : :
6100 : : lzt=m2eff
6101 : : if (mod(m2eff,2)==0) lzt=lzt+1
6102 : : if (mod(m2eff,4)==0) lzt=lzt+1
6103 : :
6104 : : ! maximal number of big box 3rd dim slices for all procs
6105 : : nnd3=nd3proc*nproc_fft
6106 : :
6107 : : ! Allocate cache work array and work arrays for MPI transpositions.
6108 : : ABI_MALLOC(zw,(2,ncache/2))
6109 : : ABI_MALLOC(zt,(2,lzt,m1zt))
6110 : :
6111 : : !call fftw3_alloc_real([2,ncache/2],zw_cptr,zw)
6112 : : !call fftw3_alloc_real([2,lzt,m1zt],zt_cptr,zt)
6113 : :
6114 : : ABI_MALLOC(zmpi2,(2,md1,md2proc,nnd3,ndat))
6115 : : if (nproc_fft>1) then
6116 : : ABI_MALLOC(zmpi1,(2,md1,md2proc,nnd3,ndat))
6117 : : end if
6118 : :
6119 : : ! Create plans.
6120 : : ! The prototype for sfftw_plan_many_dft is:
6121 : : ! sfftw_plan_many_dft(rank, n, howmany,
6122 : : ! fin, iembed, istride, idist,
6123 : : ! fout, oembed, ostride, odist, isign, my_flags)
6124 : :
6125 : : lot3=ncache/(2*n3)
6126 : : lot1=ncache/(2*n1)
6127 : : lot2=ncache/(2*n2)
6128 : :
6129 : : nthreads = xomp_get_num_threads(open_parallel=.TRUE.)
6130 : : !nthreads = 1
6131 : :
6132 : : bw_plan3_lot = dplan_many_dft_2D(1, [n3], lot3, &
6133 : : zw, [ncache/2], lot3, 1, &
6134 : : zw, [ncache/2], lot3, 1, ABI_FFTW_BACKWARD, ABI_FFTW_ESTIMATE, nthreads)
6135 : :
6136 : : if (mod(m1, lot3) /= 0) then
6137 : : bw_plan3_rest = dplan_many_dft_2D(1, [n3], mod(m1, lot3), &
6138 : : zw, [ncache/2], lot3, 1, &
6139 : : zw, [ncache/2], lot3, 1, ABI_FFTW_BACKWARD, ABI_FFTW_ESTIMATE, nthreads)
6140 : : end if
6141 : :
6142 : : bw_plan1_lot = dplan_many_dft_2D(1, [n1], lot1, &
6143 : : zw, [ncache/2], lot1, 1, &
6144 : : zt, [lzt, m1zt], lzt, 1, ABI_FFTW_BACKWARD, ABI_FFTW_ESTIMATE, nthreads)
6145 : :
6146 : : if (mod(m2eff, lot1) /= 0) then
6147 : : bw_plan1_rest = dplan_many_dft_2D(1, [n1], mod(m2eff, lot1), &
6148 : : zw, [ncache/2], lot1, 1, &
6149 : : zt, [lzt, m1zt], lzt, 1, ABI_FFTW_BACKWARD, ABI_FFTW_ESTIMATE, nthreads)
6150 : : end if
6151 : :
6152 : : bw_plan2_lot = dplan_many_dft_2D(1, [n2], lot2, &
6153 : : zw, [ncache/2], lot2, 1, &
6154 : : zr, [nd1,nd2,nd3proc,ndat], nd1, 1, ABI_FFTW_BACKWARD, ABI_FFTW_ESTIMATE, nthreads)
6155 : :
6156 : : if (mod(n1eff, lot2) /= 0) then
6157 : : bw_plan2_rest = dplan_many_dft_2D(1, [n2], mod(n1eff,lot2), &
6158 : : zw, [ncache/2], lot2, 1, &
6159 : : zr, [nd1,nd2,nd3proc,ndat], nd1, 1, ABI_FFTW_BACKWARD, ABI_FFTW_ESTIMATE, nthreads)
6160 : : end if
6161 : :
6162 : : do idat=1,ndat
6163 : : ! transform along z axis
6164 : : ! input: G1,G3,G2,(Gp2)
6165 : :
6166 : : ! Loop over the y planes treated by this node and transform n1ddft G_z lines.
6167 : : do j2=1,md2proc
6168 : : ! if (me_fft*md2proc+j2<=m2eff) then !a faire plus tard
6169 : : do i1=1,m1,lot3
6170 : : ma=i1
6171 : : mb=min(i1+(lot3-1),m1)
6172 : : n1dfft=mb-ma+1
6173 : :
6174 : : ! zero-pad n1dfft G_z lines
6175 : : ! input: G1,G3,G2,(Gp2)
6176 : : ! output: G1,R3,G2,(Gp2)
6177 : : call fill_cent(md1,md3,lot3,n1dfft,max3,m3,n3,zf(1,i1,1,j2,idat),zw)
6178 : :
6179 : : ! Transform along z.
6180 : : if (n1dfft == lot3) then
6181 : : call dfftw_execute_dft(bw_plan3_lot, zw, zw)
6182 : : else
6183 : : call dfftw_execute_dft(bw_plan3_rest, zw, zw)
6184 : : end if
6185 : :
6186 : : ! Local rotation.
6187 : : ! input: G1,R3,G2,(Gp2)
6188 : : ! output: G1,G2,R3,(Gp2)
6189 : : call scramble(i1,j2,lot3,n1dfft,md1,n3,md2proc,nnd3,zw,zmpi2(:,:,:,:,idat))
6190 : : end do
6191 : : end do ! j2
6192 : :
6193 : : ! Interprocessor data transposition
6194 : : ! input: G1,G2,R3,Rp3,(Gp2)
6195 : : ! output: G1,G2,R3,Gp2,(Rp3)
6196 : : if (nproc_fft>1) then
6197 : : call timab(543,1,tsec)
6198 : : call xmpi_ialltoall(zmpi2(:,:,:,:,idat),2*md1*md2proc*nd3proc, &
6199 : : zmpi1(:,:,:,:,idat),2*md1*md2proc*nd3proc,comm_fft,requests(idat))
6200 : : call timab(543,2,tsec)
6201 : : end if
6202 : : end do
6203 : :
6204 : : do idat=1,ndat
6205 : : if (nproc_fft>1) call xmpi_wait(requests(idat),ierr)
6206 : : ! Loop over the z treated by this node.
6207 : : do j3=1,nd3proc
6208 : : if (me_fft*nd3proc+j3 <= n3) then
6209 : : Jp2st=1; J2st=1
6210 : :
6211 : : ! Loop over G_y in the small box.
6212 : : do j=1,m2eff,lot1
6213 : : ma=j
6214 : : mb=min(j+(lot1-1),m2eff)
6215 : : n1dfft=mb-ma+1
6216 : :
6217 : : ! Zero-pad input.
6218 : : ! input: G1,G2,R3,JG2,(Rp3)
6219 : : ! output: G2,G1,R3,JG2,(Rp3)
6220 : : if (nproc_fft==1) then
6221 : : call mpiswitch_cent(j3,n1dfft,Jp2st,J2st,lot1,max1,md1,m1,n1,&
6222 : : md2proc,nd3proc,nproc_fft,ioption,zmpi2(:,:,:,:,idat),zw,max2,m2,n2)
6223 : : else
6224 : : call mpiswitch_cent(j3,n1dfft,Jp2st,J2st,lot1,max1,md1,m1,n1,&
6225 : : md2proc,nd3proc,nproc_fft,ioption,zmpi1(:,:,:,:,idat),zw,max2,m2,n2)
6226 : : end if
6227 : :
6228 : : ! Transform along x
6229 : : ! input: G2,G1,R3,(Rp3)
6230 : : ! output: G2,R1,R3,(Rp3)
6231 : : if (n1dfft == lot1) then
6232 : : call dfftw_execute_dft(bw_plan1_lot, zw, zt(1,j,1))
6233 : : else
6234 : : call dfftw_execute_dft(bw_plan1_rest, zw, zt(1,j,1))
6235 : : end if
6236 : :
6237 : : end do ! j
6238 : :
6239 : : ! Transform along y axis (take into account c2c or c2r case).
6240 : : ! Must loop over the full box.
6241 : : do j=1,n1eff,lot2
6242 : : ma=j
6243 : : mb=min(j+(lot2-1),n1eff)
6244 : : n1dfft=mb-ma+1
6245 : : includelast=1
6246 : :
6247 : : if (cplexwf==1) then
6248 : : jeff=2*j-1
6249 : : if (mb==n1eff .and. n1eff*2/=n1) includelast=0
6250 : : end if
6251 : :
6252 : : ! Zero-pad the input.
6253 : : ! input: G2,R1,R3,(Rp3)
6254 : : ! output: R1,G2,R3,(Rp3)
6255 : : if (cplexwf==2) then
6256 : : call switch_cent(n1dfft,max2,m2,n2,lot2,n1,lzt,zt(1,1,j),zw)
6257 : : else
6258 : : call switchreal_cent(includelast,n1dfft,max2,n2,lot2,m1zt,lzt,zt(1,1,jeff),zw)
6259 : : end if
6260 : :
6261 : : ! input: R1,G2,R3,(Rp3)
6262 : : ! output: R1,R2,R3,(Rp3)
6263 : : if (n1dfft == lot2) then
6264 : : call dfftw_execute_dft(bw_plan2_lot, zw, zr(1,j,1,j3,idat))
6265 : : else
6266 : : call dfftw_execute_dft(bw_plan2_rest, zw, zr(1,j,1,j3,idat))
6267 : : end if
6268 : :
6269 : : end do
6270 : :
6271 : : ! Treat real wavefunctions.
6272 : : if (cplexwf==1) then
6273 : : n1half=n1/2
6274 : : ! If odd
6275 : : if (n1half*2/=n1) then
6276 : : do i2=1,n2
6277 : : zr(1,n1,i2,j3,idat)=zr(1,n1eff,i2,j3,idat)
6278 : : zr(2,n1,i2,j3,idat)=zero
6279 : : end do
6280 : : end if
6281 : : do i2=1,n2
6282 : : do i1=n1half,1,-1
6283 : : zr(1,2*i1-1,i2,j3,idat)=zr(1,i1,i2,j3,idat)
6284 : : zr(1,2*i1 ,i2,j3,idat)=zr(2,i1,i2,j3,idat)
6285 : : zr(2,2*i1-1,i2,j3,idat)=zero
6286 : : zr(2,2*i1 ,i2,j3,idat)=zero
6287 : : end do
6288 : : end do
6289 : : end if
6290 : :
6291 : : end if
6292 : :
6293 : : end do ! j3
6294 : : end do ! idat
6295 : :
6296 : : call dfftw_destroy_plan(bw_plan3_lot)
6297 : : if (mod(m1, lot3) /= 0) call dfftw_destroy_plan(bw_plan3_rest)
6298 : :
6299 : : call dfftw_destroy_plan(bw_plan1_lot)
6300 : : if (mod(m2eff, lot1) /= 0) call dfftw_destroy_plan(bw_plan1_rest)
6301 : :
6302 : : call dfftw_destroy_plan(bw_plan2_lot)
6303 : : if (mod(n1eff, lot2) /= 0) call dfftw_destroy_plan(bw_plan2_rest)
6304 : :
6305 : : ABI_FREE(zmpi2)
6306 : : ABI_FREE(zw)
6307 : : ABI_FREE(zt)
6308 : : if (nproc_fft>1) then
6309 : : ABI_FREE(zmpi1)
6310 : : end if
6311 : :
6312 : : #else
6313 : 0 : ABI_ERROR("FFTW3 support not activated")
6314 : : ABI_UNUSED((/cplexwf,ndat,n1,n2,n3,nd1,nd2,nd3proc/))
6315 : : ABI_UNUSED((/ max1,max2,max3,m1,m2,m3,md1,md2proc,md3,comm_fft/))
6316 : : ABI_UNUSED((/zf(1,1,1,1,1),zr(1,1,1,1,1)/))
6317 : : #endif
6318 : :
6319 : 0 : end subroutine fftw3_mpiback_manywf
6320 : : !!***
6321 : :
6322 : : !----------------------------------------------------------------------
6323 : :
6324 : : !!****f* m_fftw3/fftw3_mpiforw_manywf
6325 : : !! NAME
6326 : : !! fftw3_mpiforw_manywf
6327 : : !!
6328 : : !! FUNCTION
6329 : : !! Does multiple 3-dim backward FFTs from real into Fourier space
6330 : : !! Adopt standard convention that isign=-1 for forward transform
6331 : : !! CALCULATES THE DISCRETE FOURIERTRANSFORM
6332 : : !!
6333 : : !! ZF(I1,I3,I2)=S_(j1,j2,j3) EXP(isign*i*2*pi*(j1*i1/n1+j2*i2/n2+j3*i3/n3)) ZR(j1,j2,j3)
6334 : : !!
6335 : : !! in parallel using MPI/OpenMP.
6336 : : !!
6337 : : !! INPUT:
6338 : : !! ZR: input array
6339 : : !! ZR(1,i1,i2,i3,idat)=real(R(i1,i2,i3,idat))
6340 : : !! ZR(2,i1,i2,i3,idat)=imag(R(i1,i2,i3,idat))
6341 : : !! i1=1,n1 , i2=1,n2 , i3=1,n3 , idat=1,ndat
6342 : : !! NOTE that ZR is changed by the routine
6343 : : !!
6344 : : !! n1,n2,n3: logical dimension of the transform. As transform lengths
6345 : : !! most products of the prime factors 2,3,5 are allowed.
6346 : : !! The detailed table with allowed transform lengths can
6347 : : !! be found in subroutine CTRIG
6348 : : !! nd1,nd2,nd3: Dimension of ZR
6349 : : !! nd3proc=((nd3-1)/nproc_fft)+1 maximal number of big box 3rd dim slices for one proc
6350 : : !!
6351 : : !! OUTPUT:
6352 : : !! ZF: output array (note the switch of i2 and i3)
6353 : : !! real(F(i1,i3,i2,idat))=ZF(1,i1,i3,i2,idat)
6354 : : !! imag(F(i1,i3,i2,idat))=ZF(2,i1,i3,i2,idat)
6355 : : !! max1 is positive or zero ; m1 >=max1+1
6356 : : !! i1= 1... max1+1 corresponds to positive and zero wavevectors 0 ... max1
6357 : : !! then, if m1 > max1+1, one has min1=max1-m1+1 and
6358 : : !! i1= max1+2 ... m1 corresponds to negative wavevectors min1 ... -1
6359 : : !! i2 and i3 have a similar definition of range
6360 : : !! idat=1,ndat
6361 : : !! md1,md2,md3: Dimension of ZF
6362 : : !! md2proc=((md2-1)/nproc_fft)+1 maximal number of small box 2nd dim slices for one proc
6363 : : !! nproc_fft: number of processors used as returned by MPI_COMM_SIZE
6364 : : !! me_fft: [0:nproc-1] rank of the processor in the FFT communicator.
6365 : : !! comm_fft=MPI communicator for parallel FFT.
6366 : : !!
6367 : : !! NOTES
6368 : : !! The maximum number of processors that can reasonably be used is max(n2/2,n3/2)
6369 : : !!
6370 : : !! It is very important to find the optimal
6371 : : !! value of NCACHE. NCACHE determines the size of the work array ZW, that
6372 : : !! has to fit into cache. It has therefore to be chosen to equal roughly
6373 : : !! half the size of the physical cache in units of real*8 numbers.
6374 : : !! The optimal value of ncache can easily be determined by numerical
6375 : : !! experimentation. A too large value of ncache leads to a dramatic
6376 : : !! and sudden decrease of performance, a too small value to a to a
6377 : : !! slow and less dramatic decrease of performance. If NCACHE is set
6378 : : !! to a value so small, that not even a single one dimensional transform
6379 : : !! can be done in the workarray zw, the program stops with an error message.
6380 : : !!
6381 : : !! SOURCE
6382 : :
6383 : 0 : subroutine fftw3_mpiforw_manywf(cplexwf,ndat,n1,n2,n3,nd1,nd2,nd3proc,&
6384 : 0 : & max1,max2,max3,m1,m2,m3,md1,md2proc,md3,zr,zf,comm_fft)
6385 : :
6386 : : !Arguments ------------------------------------
6387 : : !scalars
6388 : : integer,intent(in) :: cplexwf,ndat,n1,n2,n3,nd1,nd2,nd3proc
6389 : : integer,intent(in) :: max1,max2,max3,m1,m2,m3,md1,md2proc,md3,comm_fft
6390 : : !arrays
6391 : : real(dp),intent(inout) :: zr(2,nd1,nd2,nd3proc,ndat)
6392 : : real(dp),intent(out) :: zf(2,md1,md3,md2proc,ndat)
6393 : :
6394 : : !Local variables-------------------------------
6395 : : !scalars
6396 : : #ifdef HAVE_FFTW3
6397 : : integer :: j,i1,i2,i3,idat,ierr,nproc_fft,me_fft
6398 : : integer :: ioption,j2,j3,j2st,jp2st,lot1,lot2,lot3,lzt,m1zt,ma,mb,n1dfft,nnd3
6399 : : integer :: m2eff,ncache,n1eff,n1half,i1inv,i2inv,i3inv,nthreads
6400 : : integer(KIND_FFTW_PLAN) :: fw_plan1_lot,fw_plan1_rest
6401 : : integer(KIND_FFTW_PLAN) :: fw_plan2_lot,fw_plan2_rest
6402 : : integer(KIND_FFTW_PLAN) :: fw_plan3_lot,fw_plan3_rest
6403 : : character(len=500) :: msg
6404 : : !arrays
6405 : : integer :: requests(ndat)
6406 : : real(dp) ABI_ASYNC, allocatable :: zmpi1(:,:,:,:,:),zmpi2(:,:,:,:,:) ! work arrays for MPI
6407 : : real(dp),allocatable :: zw(:,:),zt(:,:,:) ! cache work array and array for transpositions
6408 : : ! FFT work arrays
6409 : : real(dp) :: tsec(2)
6410 : : ! *************************************************************************
6411 : :
6412 : : ! FIXME must provide a default value but which one?
6413 : : !ioption = 0
6414 : : ioption = 1
6415 : : !if (paral_kgb==1) ioption=1
6416 : :
6417 : : nproc_fft = xmpi_comm_size(comm_fft); me_fft = xmpi_comm_rank(comm_fft)
6418 : :
6419 : : ! find cache size that gives optimal performance on machine
6420 : : ncache=2*max(n1,n2,n3,1024)
6421 : : !ncache=2*max(n1,n2,n3,16*1024)
6422 : :
6423 : : if (ncache/(2*max(n1,n2,n3))<1) then
6424 : : write(msg,'(5a)') &
6425 : : 'ncache has to be enlarged to be able to hold at',ch10, &
6426 : : 'least one 1-d FFT of each size even though this will',ch10,&
6427 : : 'reduce the performance for shorter transform lengths'
6428 : : ABI_ERROR(msg)
6429 : : end if
6430 : :
6431 : : ! Effective m1 and m2 (complex-to-complex or real-to-complex)
6432 : : n1eff=n1; m2eff=m2; m1zt=n1
6433 : : if (cplexwf==1) then
6434 : : n1eff=(n1+1)/2; m2eff=m2/2+1; m1zt=2*(n1/2+1)
6435 : : end if
6436 : :
6437 : : lzt=m2eff
6438 : : if (mod(m2eff,2)==0) lzt=lzt+1
6439 : : if (mod(m2eff,4)==0) lzt=lzt+1
6440 : :
6441 : : ! maximal number of big box 3rd dim slices for all procs
6442 : : nnd3=nd3proc*nproc_fft
6443 : :
6444 : : ABI_MALLOC(zw,(2,ncache/2))
6445 : : ABI_MALLOC(zt,(2,lzt,m1zt))
6446 : : ABI_MALLOC(zmpi2,(2,md1,md2proc,nnd3,ndat))
6447 : : if (nproc_fft>1) then
6448 : : ABI_MALLOC(zmpi1,(2,md1,md2proc,nnd3,ndat))
6449 : : end if
6450 : :
6451 : : ! Create plans.
6452 : : ! The prototype for sfftw_plan_many_dft is:
6453 : : ! sfftw_plan_many_dft(rank, n, howmany,
6454 : : ! fin, iembed, istride, idist,
6455 : : ! fout, oembed, ostride, odist, isign, my_flags)
6456 : :
6457 : : lot2=ncache/(2*n2)
6458 : : lot1=ncache/(2*n1)
6459 : : lot3=ncache/(2*n3)
6460 : :
6461 : : nthreads = xomp_get_num_threads(open_parallel=.TRUE.)
6462 : : !nthreads = 1
6463 : :
6464 : : fw_plan3_lot = dplan_many_dft_2D(1, [n3], lot3, &
6465 : : zw, [ncache/2], lot3, 1, &
6466 : : zw, [ncache/2], lot3, 1, ABI_FFTW_FORWARD, ABI_FFTW_ESTIMATE, nthreads)
6467 : :
6468 : : if (mod(m1, lot3) /= 0) then
6469 : : fw_plan3_rest = dplan_many_dft_2D(1, [n3], mod(m1, lot3), &
6470 : : zw, [ncache/2], lot3, 1, &
6471 : : zw, [ncache/2], lot3, 1, ABI_FFTW_FORWARD, ABI_FFTW_ESTIMATE, nthreads)
6472 : : end if
6473 : :
6474 : : fw_plan1_lot = dplan_many_dft_2D(1, [n1], lot1, &
6475 : : zt, [lzt, m1zt], lzt, 1, &
6476 : : zw, [ncache/2], lot1, 1, ABI_FFTW_FORWARD, ABI_FFTW_ESTIMATE, nthreads)
6477 : :
6478 : : if (mod(m2eff, lot1) /= 0) then
6479 : : fw_plan1_rest = dplan_many_dft_2D(1, [n1], mod(m2eff, lot1), &
6480 : : zt, [lzt, m1zt], lzt, 1, &
6481 : : zw, [ncache/2], lot1, 1, ABI_FFTW_FORWARD, ABI_FFTW_ESTIMATE, nthreads)
6482 : : end if
6483 : :
6484 : : fw_plan2_lot = dplan_many_dft_2D(1, [n2], lot2, &
6485 : : zr, [nd1,nd2,nd3proc,ndat], nd1, 1, &
6486 : : zw, [ncache/2], lot2, 1, ABI_FFTW_FORWARD, ABI_FFTW_ESTIMATE, nthreads)
6487 : :
6488 : : if (mod(n1eff, lot2) /= 0) then
6489 : : fw_plan2_rest = dplan_many_dft_2D(1, [n2], mod(n1eff,lot2), &
6490 : : zr, [nd1,nd2,nd3proc,ndat], nd1, 1, &
6491 : : zw, [ncache/2], lot2, 1, ABI_FFTW_FORWARD, ABI_FFTW_ESTIMATE, nthreads)
6492 : : end if
6493 : :
6494 : : do idat=1,ndat
6495 : : ! Loop over the z-planes treated by this node
6496 : : do j3=1,nd3proc
6497 : :
6498 : : if (me_fft*nd3proc+j3 <= n3) then
6499 : : Jp2st=1
6500 : : J2st=1
6501 : :
6502 : : ! Treat real wavefunctions.
6503 : : if (cplexwf==1) then
6504 : : n1half=n1/2
6505 : : do i2=1,n2
6506 : : do i1=1,n1half
6507 : : zr(1,i1,i2,j3,idat)=zr(1,2*i1-1,i2,j3,idat)
6508 : : zr(2,i1,i2,j3,idat)=zr(1,2*i1 ,i2,j3,idat)
6509 : : end do
6510 : : end do
6511 : : ! If odd
6512 : : if(n1half*2/=n1)then
6513 : : do i2=1,n2
6514 : : zr(1,n1eff,i2,j3,idat)=zr(1,n1,i2,j3,idat)
6515 : : zr(2,n1eff,i2,j3,idat)=zero
6516 : : end do
6517 : : end if
6518 : : end if
6519 : :
6520 : : ! transform along y axis
6521 : : ! input: R1,R2,R3,(Rp3)
6522 : : ! input: R1,G2,R3,(Rp3)
6523 : : do j=1,n1eff,lot2
6524 : : ma=j
6525 : : mb=min(j+(lot2-1),n1eff)
6526 : : n1dfft=mb-ma+1
6527 : :
6528 : : if (n1dfft == lot2) then
6529 : : call dfftw_execute_dft(fw_plan2_lot, zr(1,j,1,j3,idat), zw)
6530 : : else
6531 : : call dfftw_execute_dft(fw_plan2_rest, zr(1,j,1,j3,idat), zw)
6532 : : end if
6533 : :
6534 : : ! input: R1,G2,R3,(Rp3)
6535 : : ! output: G2,R1,R3,(Rp3)
6536 : : if (cplexwf==2) then
6537 : : call unswitch_cent(n1dfft,max2,m2,n2,lot2,n1,lzt,zw,zt(1,1,j))
6538 : : else
6539 : : call unswitchreal_cent(n1dfft,max2,n2,lot2,n1,lzt,zw,zt(1,1,2*j-1))
6540 : : end if
6541 : : end do
6542 : :
6543 : : ! transform along x axis
6544 : : ! input: G2,R1,R3,(Rp3)
6545 : : do j=1,m2eff,lot1
6546 : : ma=j
6547 : : mb=min(j+(lot1-1),m2eff)
6548 : : n1dfft=mb-ma+1
6549 : :
6550 : : if (n1dfft == lot1) then
6551 : : call dfftw_execute_dft(fw_plan1_lot, zt(1,j,1), zw)
6552 : : else
6553 : : call dfftw_execute_dft(fw_plan1_rest, zt(1,j,1), zw)
6554 : : end if
6555 : : ! output: G2,G1,R3,(Rp3)
6556 : :
6557 : : ! input: G2,G1,R3,Gp2,(Rp3)
6558 : : ! output: G1,G2,R3,Gp2,(Rp3)
6559 : : if (nproc_fft==1) then
6560 : : call unmpiswitch_cent(j3,n1dfft,Jp2st,J2st,lot1,max1,md1,m1,n1,&
6561 : : & md2proc,nd3proc,nproc_fft,ioption,zw,zmpi2(:,:,:,:,idat))
6562 : : else
6563 : : call unmpiswitch_cent(j3,n1dfft,Jp2st,J2st,lot1,max1,md1,m1,n1,&
6564 : : & md2proc,nd3proc,nproc_fft,ioption,zw,zmpi1(:,:,:,:,idat))
6565 : : end if
6566 : : end do
6567 : : end if
6568 : : end do ! j3
6569 : :
6570 : : ! Interprocessor data transposition
6571 : : ! input: G1,G2,R3,Gp2,(Rp3)
6572 : : ! output: G1,G2,R3,Rp3,(Gp2)
6573 : : if (nproc_fft>1) then
6574 : : call timab(544,1,tsec)
6575 : : call xmpi_ialltoall(zmpi1(:,:,:,:,idat),2*md1*md2proc*nd3proc, &
6576 : : zmpi2(:,:,:,:,idat),2*md1*md2proc*nd3proc,comm_fft,requests(idat))
6577 : : call timab(544,2,tsec)
6578 : : end if
6579 : : end do
6580 : :
6581 : : do idat=1,ndat
6582 : : if (nproc_fft>1) call xmpi_wait(requests(idat),ierr)
6583 : : ! transform along z axis
6584 : : ! input: G1,G2,R3,(Gp2)
6585 : :
6586 : : do j2=1,md2proc
6587 : : if (me_fft*md2proc+j2 <= m2eff) then
6588 : : ! write(std_out,*)' forwf_wf : before unscramble, j2,md2proc,me_fft,m2=',j2,md2proc,me_fft,m2
6589 : : do i1=1,m1,lot3
6590 : : ma=i1
6591 : : mb=min(i1+(lot3-1),m1)
6592 : : n1dfft=mb-ma+1
6593 : :
6594 : : ! input: G1,G2,R3,(Gp2)
6595 : : ! output: G1,R3,G2,(Gp2)
6596 : : call unscramble(i1,j2,lot3,n1dfft,md1,n3,md2proc,nnd3,zmpi2(:,:,:,:,idat),zw)
6597 : :
6598 : : if (n1dfft == lot3) then
6599 : : call dfftw_execute_dft(fw_plan3_lot, zw, zw)
6600 : : else
6601 : : call dfftw_execute_dft(fw_plan3_rest, zw, zw)
6602 : : end if
6603 : :
6604 : : call unfill_cent(md1,md3,lot3,n1dfft,max3,m3,n3,zw,zf(1,i1,1,j2,idat))
6605 : : ! output: G1,G3,G2,(Gp2)
6606 : : end do
6607 : : end if
6608 : : end do
6609 : :
6610 : : if (cplexwf==1) then
6611 : : ! Complete missing values with complex conjugate
6612 : : ! Inverse of ix is located at nx+2-ix , except for ix=1, for which it is 1.
6613 : : do i3=1,m3
6614 : : i3inv=m3+2-i3
6615 : : if(i3==1)i3inv=1
6616 : :
6617 : : if (m2eff>1) then
6618 : : do i2=2,m2eff
6619 : : i2inv=m2+2-i2
6620 : : zf(1,1,i3inv,i2inv,idat)= zf(1,1,i3,i2,idat)
6621 : : zf(2,1,i3inv,i2inv,idat)=-zf(2,1,i3,i2,idat)
6622 : : do i1=2,m1
6623 : : i1inv=m1+2-i1
6624 : : zf(1,i1inv,i3inv,i2inv,idat)= zf(1,i1,i3,i2,idat)
6625 : : zf(2,i1inv,i3inv,i2inv,idat)=-zf(2,i1,i3,i2,idat)
6626 : : end do
6627 : : end do
6628 : : end if
6629 : : end do
6630 : : end if
6631 : :
6632 : : end do ! idat
6633 : :
6634 : : call dfftw_destroy_plan(fw_plan3_lot)
6635 : : if (mod(m1, lot3) /= 0) call dfftw_destroy_plan(fw_plan3_rest)
6636 : :
6637 : : call dfftw_destroy_plan(fw_plan1_lot)
6638 : : if (mod(m2eff, lot1) /= 0) call dfftw_destroy_plan(fw_plan1_rest)
6639 : :
6640 : : call dfftw_destroy_plan(fw_plan2_lot)
6641 : : if (mod(n1eff, lot2) /= 0) call dfftw_destroy_plan(fw_plan2_rest)
6642 : :
6643 : : ABI_FREE(zmpi2)
6644 : : ABI_FREE(zw)
6645 : : ABI_FREE(zt)
6646 : : if (nproc_fft>1) then
6647 : : ABI_FREE(zmpi1)
6648 : : end if
6649 : :
6650 : : #else
6651 : 0 : ABI_ERROR("FFTW3 support not activated")
6652 : : ABI_UNUSED((/cplexwf,ndat,n1,n2,n3,nd1,nd2,nd3proc/))
6653 : : ABI_UNUSED((/max1,max2,max3,m1,m2,m3,md1,md2proc,md3,comm_fft/))
6654 : : ABI_UNUSED((/zf(1,1,1,1,1),zr(1,1,1,1,1)/))
6655 : : #endif
6656 : :
6657 : 0 : end subroutine fftw3_mpiforw_manywf
6658 : : !!***
6659 : :
6660 : : !----------------------------------------------------------------------
6661 : :
6662 : : !!****f* m_fftw3/fftw3_applypot_many
6663 : : !! NAME
6664 : : !! fftw3_applypot_many
6665 : : !!
6666 : : !! FUNCTION
6667 : : !! Applies the local real space potential to multiple wavefunctions in Fourier space
6668 : : !!
6669 : : !! INPUTS
6670 : : !! ZF: Wavefunction (input/output) (note the switch of i2 and i3)
6671 : : !! real(F(i1,i3,i2,idat))=ZF(1,i1,i3,i2,idat)
6672 : : !! imag(F(i1,i3,i2,idat))=ZF(2,i1,i3,i2,idat)
6673 : : !! max1 is positive or zero ; m1 >=max1+1
6674 : : !! i1= 1... max1+1 corresponds to positive and zero wavevectors 0 ... max1
6675 : : !! then, if m1 > max1+1, one has min1=max1-m1+1 and
6676 : : !! i1= max1+2 ... m1 corresponds to negative wavevectors min1 ... -1
6677 : : !! i2 and i3 have a similar definition of range
6678 : : !! idat=1,ndat
6679 : : !! md1,md2,md3: Dimension of ZF (input as well as output), distributed on different procs
6680 : : !! md2proc=((md2-1)/nproc_fft)+1 maximal number of small box 2nd dim slices for one proc
6681 : : !!
6682 : : !! POT: Potential
6683 : : !! POT(cplex*i1,i2,i3)
6684 : : !! cplex=1 or 2 , i1=1,n1 , i2=1,n2 , i3=1,n3
6685 : : !! nd1,nd2,nd3: dimension of pot
6686 : : !! comm_fft: MPI communicator
6687 : : !! nproc_fft: number of processors used as returned by MPI_COMM_SIZE
6688 : : !! me_fft: [0:nproc_fft-1] number of processor as returned by MPI_COMM_RANK
6689 : : !! n1,n2,n3: logical dimension of the transform. As transform lengths
6690 : : !! most products of the prime factors 2,3,5 are allowed.
6691 : : !! The detailed table with allowed transform lengths can
6692 : : !! be found in subroutine CTRIG
6693 : : !!
6694 : : !! NOTES:
6695 : : !! PERFORMANCE CONSIDERATIONS:
6696 : : !! The maximum number of processors that can reasonably be used is max(n2/2,n3/2)
6697 : : !!
6698 : : !! It is very important to find the optimal
6699 : : !! value of NCACHE. NCACHE determines the size of the work array ZW, that
6700 : : !! has to fit into cache. It has therefore to be chosen to equal roughly
6701 : : !! half the size of the physical cache in units of real*8 numbers.
6702 : : !! The optimal value of ncache can easily be determined by numerical
6703 : : !! experimentation. A too large value of ncache leads to a dramatic
6704 : : !! and sudden decrease of performance, a too small value to a to a
6705 : : !! slow and less dramatic decrease of performance. If NCACHE is set
6706 : : !! to a value so small, that not even a single one dimensional transform
6707 : : !! can be done in the workarray zw, the program stops with an error message.
6708 : : !!
6709 : : !! SOURCE
6710 : :
6711 : :
6712 : 0 : subroutine fftw3_applypot_many(cplexwf,cplex,ndat,n1,n2,n3,nd1,nd2,nd3,nd3proc,&
6713 : : max1i,max2i,max3i,m1i,m2i,m3i,md1,md2proc,md3,&
6714 : 0 : max1o,max2o,max3o,m1o,m2o,m3o,comm_fft,nproc_fft,me_fft,pot,zf)
6715 : :
6716 : : !Arguments ------------------------------------
6717 : : integer,intent(in) :: cplexwf,cplex,ndat,n1,n2,n3,nd1,nd2,nd3,nd3proc
6718 : : integer,intent(in) :: max1i,max2i,max3i,m1i,m2i,m3i,md1,md2proc,md3
6719 : : integer,intent(in) :: max1o,max2o,max3o,m1o,m2o,m3o,comm_fft,nproc_fft,me_fft
6720 : : real(dp),intent(in) :: pot(cplex*nd1,nd2,nd3)
6721 : : real(dp),intent(inout) :: zf(2,md1,md3,md2proc,ndat)
6722 : :
6723 : : !Local variables-------------------------------
6724 : : !scalars
6725 : : #ifdef HAVE_FFTW3
6726 : : integer,parameter :: unused0=0
6727 : : integer :: j,i1,i2,i3,idat,ierr,j3glob,nthreads
6728 : : integer :: ioption,j2,j3,lzt,m1zt,ma,mb,n1dfft,nnd3,lot1,lot2,lot3
6729 : : integer :: m2eff,ncache,n1eff,i1inv,i2inv,i3inv,jeff,includelast,j2stb
6730 : : integer :: jx,j2stf,Jp2stb,Jp2stf,m2ieff,m2oeff
6731 : : integer(KIND_FFTW_PLAN) :: bw_plan1_lot,bw_plan1_rest
6732 : : integer(KIND_FFTW_PLAN) :: bw_plan2_lot,bw_plan2_rest
6733 : : integer(KIND_FFTW_PLAN) :: bw_plan3_lot,bw_plan3_rest
6734 : : integer(KIND_FFTW_PLAN) :: fw_plan1_lot,fw_plan1_rest
6735 : : integer(KIND_FFTW_PLAN) :: fw_plan2_lot,fw_plan2_rest
6736 : : integer(KIND_FFTW_PLAN) :: fw_plan3_lot,fw_plan3_rest
6737 : : character(len=500) :: msg
6738 : : !arrays
6739 : : integer :: requests(ndat)
6740 : : real(dp) :: tsec(2)
6741 : : real(dp) ABI_ASYNC, allocatable :: zmpi1(:,:,:,:,:),zmpi2(:,:,:,:,:) ! work arrays for MPI
6742 : : real(dp),allocatable :: zw(:,:),zt(:,:,:) ! cache work array and array for transpositions
6743 : : ! FFT work arrays
6744 : : ! *************************************************************************
6745 : :
6746 : : !ioption=0 ! This was in the old version.
6747 : : ioption=1 ! This one is needed to be compatible with paral_kgb
6748 : :
6749 : : ncache=2*max(n1,n2,n3,1024)
6750 : : if (ncache/(2*max(n1,n2,n3)) < 1) then
6751 : : write(msg,"(5a)") &
6752 : : 'ncache has to be enlarged to be able to hold at',ch10,&
6753 : : 'least one 1-d FFT of each size even though this will',ch10,&
6754 : : 'reduce the performance for shorter transform lengths'
6755 : : ABI_ERROR(msg)
6756 : : end if
6757 : :
6758 : : !call wrtout(std_out,"applypot with non-blocking IALLTOALL + FFTW3")
6759 : : !write(std_out,"(a,i0)")"in applypot_many with ndat: ",ndat
6760 : :
6761 : : ! Effective m1 and m2 (complex-to-complex or real-to-complex)
6762 : : n1eff=n1; m2ieff=m2i; m2oeff=m2o; m1zt=n1
6763 : : if (cplexwf==1) then
6764 : : n1eff=(n1+1)/2; m2ieff=m2i/2+1; m2oeff=m2o/2+1; m1zt=2*(n1/2+1)
6765 : : end if
6766 : :
6767 : : m2eff=max(m2ieff,m2oeff)
6768 : : lzt=m2eff
6769 : : if (mod(m2eff,2) == 0) lzt=lzt+1
6770 : : if (mod(m2eff,4) == 0) lzt=lzt+1
6771 : :
6772 : : ! maximal number of big box 3rd dim slices for all procs
6773 : : nnd3=nd3proc*nproc_fft
6774 : :
6775 : : ABI_MALLOC(zw,(2,ncache/2))
6776 : : ABI_MALLOC(zt,(2,lzt,m1zt))
6777 : : ABI_MALLOC(zmpi2,(2,md1,md2proc,nnd3,ndat))
6778 : : if (nproc_fft > 1) then
6779 : : ABI_MALLOC(zmpi1,(2,md1,md2proc,nnd3,ndat))
6780 : : end if
6781 : :
6782 : : lot3=ncache/(2*n3)
6783 : : lot1=ncache/(2*n1)
6784 : : lot2=ncache/(2*n2)
6785 : :
6786 : : nthreads = xomp_get_num_threads(open_parallel=.TRUE.)
6787 : : !nthreads = 1
6788 : :
6789 : : ! The prototype for sfftw_plan_many_dft is:
6790 : : ! sfftw_plan_many_dft(rank, n, howmany,
6791 : : ! fin, iembed, istride, idist,
6792 : : ! fout, oembed, ostride, odist, isign, my_flags)
6793 : :
6794 : : ! Create plans for G --> R (see back_wf)
6795 : : bw_plan3_lot = dplan_many_dft_2D(1, [n3], lot3, &
6796 : : zw, [ncache/2], lot3, 1, &
6797 : : zw, [ncache/2], lot3, 1, ABI_FFTW_BACKWARD, ABI_FFTW_ESTIMATE, nthreads)
6798 : :
6799 : : if (mod(m1i, lot3) /= 0) then
6800 : : bw_plan3_rest = dplan_many_dft_2D(1, [n3], mod(m1i, lot3),&
6801 : : zw, [ncache/2], lot3, 1, &
6802 : : zw, [ncache/2], lot3, 1, ABI_FFTW_BACKWARD, ABI_FFTW_ESTIMATE, nthreads)
6803 : : end if
6804 : :
6805 : : bw_plan1_lot = dplan_many_dft_2D(1, [n1], lot1, &
6806 : : zw, [ncache/2], lot1, 1, &
6807 : : zt, [lzt, m1zt], lzt, 1, ABI_FFTW_BACKWARD, ABI_FFTW_ESTIMATE, nthreads)
6808 : :
6809 : : if (mod(m2ieff, lot1) /= 0) then
6810 : : bw_plan1_rest = dplan_many_dft_2D(1, [n1], mod(m2ieff, lot1), &
6811 : : zw, [ncache/2], lot1, 1, &
6812 : : zt, [lzt, m1zt], lzt, 1, ABI_FFTW_BACKWARD, ABI_FFTW_ESTIMATE, nthreads)
6813 : : end if
6814 : :
6815 : : !TODO this won't work if iclexwf==1
6816 : : ! Recheck this
6817 : : bw_plan2_lot = dplan_many_dft_2D(1, [n2], lot2, &
6818 : : zw, [ncache/2], lot2, 1, &
6819 : : zw, [ncache/2], lot2, 1, ABI_FFTW_BACKWARD, ABI_FFTW_ESTIMATE, nthreads)
6820 : :
6821 : : if (mod(n1eff, lot2) /= 0) then
6822 : : bw_plan2_rest = dplan_many_dft_2D(1, [n2], mod(n1eff,lot2), &
6823 : : zw, [ncache/2], lot2, 1, &
6824 : : zw, [ncache/2], lot2, 1, ABI_FFTW_BACKWARD, ABI_FFTW_ESTIMATE, nthreads)
6825 : : end if
6826 : :
6827 : : ! Create plans for G --> R (see forw_wf)
6828 : : fw_plan3_lot = dplan_many_dft_2D(1, [n3], lot3, &
6829 : : zw, [ncache/2], lot3, 1, &
6830 : : zw, [ncache/2], lot3, 1, ABI_FFTW_FORWARD, ABI_FFTW_ESTIMATE, nthreads)
6831 : :
6832 : : if (mod(m1o, lot3) /= 0) then
6833 : : fw_plan3_rest = dplan_many_dft_2D(1, [n3], mod(m1o, lot3),&
6834 : : zw, [ncache/2], lot3, 1, &
6835 : : zw, [ncache/2], lot3, 1, ABI_FFTW_FORWARD, ABI_FFTW_ESTIMATE, nthreads)
6836 : : end if
6837 : :
6838 : : fw_plan1_lot = dplan_many_dft_2D(1, [n1], lot1,&
6839 : : zt, [lzt, m1zt], lzt, 1, &
6840 : : zw, [ncache/2], lot1, 1, ABI_FFTW_FORWARD, ABI_FFTW_ESTIMATE, nthreads)
6841 : :
6842 : : if (mod(m2oeff, lot1) /= 0) then
6843 : : fw_plan1_rest = dplan_many_dft_2D(1, [n1], mod(m2oeff, lot1),&
6844 : : zt, [lzt, m1zt], lzt, 1, &
6845 : : zw, [ncache/2], lot1, 1, ABI_FFTW_FORWARD, ABI_FFTW_ESTIMATE, nthreads)
6846 : : end if
6847 : :
6848 : : fw_plan2_lot = dplan_many_dft_2D(1, [n2], lot2,&
6849 : : zw, [ncache/2], lot2, 1, &
6850 : : zw, [ncache/2], lot2, 1, ABI_FFTW_FORWARD, ABI_FFTW_ESTIMATE, nthreads)
6851 : :
6852 : : if (mod(n1eff, lot2) /= 0) then
6853 : : fw_plan2_rest = dplan_many_dft_2D(1, [n2], mod(n1eff,lot2),&
6854 : : zw, [ncache/2], lot2, 1, &
6855 : : zw, [ncache/2], lot2, 1, ABI_FFTW_FORWARD, ABI_FFTW_ESTIMATE, nthreads)
6856 : : end if
6857 : :
6858 : : ! Here we take advantage of non-blocking IALLTOALL:
6859 : : ! Perform the first step of MPI-FFT for ndat wavefunctions.
6860 : : do idat=1,ndat
6861 : : !
6862 : : ! transform along z axis
6863 : : ! input: G1,G3,G2,(Gp2)
6864 : : do j2=1,md2proc
6865 : : if (me_fft*md2proc+j2 <= m2ieff) then
6866 : : do i1=1,m1i,lot3
6867 : : ma=i1
6868 : : mb=min(i1+(lot3-1),m1i)
6869 : : n1dfft=mb-ma+1
6870 : :
6871 : : ! zero-pad n1dfft G_z lines
6872 : : ! input: G1,G3,G2,(Gp2)
6873 : : call fill_cent(md1,md3,lot3,n1dfft,max3i,m3i,n3,zf(1,i1,1,j2,idat),zw)
6874 : :
6875 : : if (n1dfft == lot3) then
6876 : : call dfftw_execute_dft(bw_plan3_lot, zw, zw)
6877 : : else
6878 : : call dfftw_execute_dft(bw_plan3_rest, zw, zw)
6879 : : end if
6880 : :
6881 : : ! Local rotation.
6882 : : ! input: G1,R3,G2,(Gp2)
6883 : : ! output: G1,G2,R3,(Gp2)
6884 : : call scramble(i1,j2,lot3,n1dfft,md1,n3,md2proc,nnd3,zw,zmpi2(:,:,:,:,idat))
6885 : : end do
6886 : : end if
6887 : : end do
6888 : :
6889 : : ! Interprocessor data transposition
6890 : : ! input: G1,G2,R3,Rp3,(Gp2)
6891 : : ! output: G1,G2,R3,Gp2,(Rp3)
6892 : : if (nproc_fft > 1) then
6893 : : call timab(543,1,tsec)
6894 : : call xmpi_ialltoall(zmpi2(:,:,:,:,idat),2*md1*md2proc*nd3proc,&
6895 : : zmpi1(:,:,:,:,idat),2*md1*md2proc*nd3proc,comm_fft,requests(idat))
6896 : : call timab(543,2,tsec)
6897 : : end if
6898 : : end do ! idat
6899 : :
6900 : : ! The second step of MPI-FFT
6901 : : do idat=1,ndat
6902 : : ! Make sure communication is completed.
6903 : : if (nproc_fft>1) call xmpi_wait(requests(idat),ierr)
6904 : :
6905 : : do j3=1,nd3proc
6906 : : j3glob = j3 + me_fft*nd3proc
6907 : : if (me_fft*nd3proc+j3 <= n3) then
6908 : : Jp2stb=1; J2stb=1
6909 : : Jp2stf=1; J2stf=1
6910 : :
6911 : : ! transform along x axis
6912 : : do j=1,m2ieff,lot1
6913 : : ma=j
6914 : : mb=min(j+(lot1-1),m2ieff)
6915 : : n1dfft=mb-ma+1
6916 : :
6917 : : ! Zero-pad input.
6918 : : ! input: G1,G2,R3,G2,(Rp3)
6919 : : ! output: G2,G1,R3,G2,(Rp3)
6920 : : if (nproc_fft == 1) then
6921 : : call mpiswitch_cent(j3,n1dfft,Jp2stb,J2stb,lot1,max1i,md1,m1i,n1,&
6922 : : md2proc,nd3proc,nproc_fft,ioption,zmpi2(:,:,:,:,idat),zw, unused0, unused0, unused0)
6923 : : else
6924 : : call mpiswitch_cent(j3,n1dfft,Jp2stb,J2stb,lot1,max1i,md1,m1i,n1,&
6925 : : md2proc,nd3proc,nproc_fft,ioption,zmpi1(:,:,:,:,idat),zw, unused0, unused0, unused0)
6926 : : end if
6927 : :
6928 : : ! Transform along x
6929 : : ! input: G2,G1,R3,(Rp3)
6930 : : ! output: G2,R1,R3,(Rp3)
6931 : : if (n1dfft == lot1) then
6932 : : call dfftw_execute_dft(bw_plan1_lot, zw, zt(1,j,1))
6933 : : else
6934 : : call dfftw_execute_dft(bw_plan1_rest, zw, zt(1,j,1))
6935 : : end if
6936 : : end do
6937 : :
6938 : : ! Transform along y axis (take into account c2c or c2r case).
6939 : : ! Must loop over the full box.
6940 : : !TODO this won't work
6941 : : if (cplexwf==1) then
6942 : : if(mod(lot2,2).ne.0) lot2=lot2-1 ! needed to introduce jeff
6943 : : end if
6944 : :
6945 : : do j=1,n1eff,lot2
6946 : : ma=j
6947 : : mb=min(j+(lot2-1),n1eff)
6948 : : n1dfft=mb-ma+1
6949 : : jeff=j
6950 : : includelast=1
6951 : :
6952 : : if (cplexwf==1) then
6953 : : jeff=2*j-1
6954 : : includelast=1
6955 : : if (mb==n1eff .and. n1eff*2/=n1) includelast=0
6956 : : end if
6957 : :
6958 : : ! Zero-pad the input.
6959 : : ! input: G2,R1,R3,(Rp3)
6960 : : ! output: R1,G2,R3,(Rp3)
6961 : : if (cplexwf==2) then
6962 : : call switch_cent(n1dfft,max2i,m2i,n2,lot2,n1,lzt,zt(1,1,jeff),zw)
6963 : : else
6964 : : call switchreal_cent(includelast,n1dfft,max2i,n2,lot2,m1zt,lzt,zt(1,1,jeff),zw)
6965 : : end if
6966 : :
6967 : : ! input: R1,G2,R3,(Rp3)
6968 : : ! output: R1,R2,R3,(Rp3)
6969 : : ! Be careful here
6970 : : if (n1dfft == lot2) then
6971 : : call dfftw_execute_dft(bw_plan2_lot, zw, zw)
6972 : : else
6973 : : call dfftw_execute_dft(bw_plan2_rest, zw, zw)
6974 : : end if
6975 : :
6976 : : ! Multiply with potential in real space
6977 : : jx=cplex*(jeff-1)+1
6978 : : call multpot(cplexwf,cplex,includelast,nd1,nd2,n2,lot2,n1dfft,pot(jx,1,j3glob),zw)
6979 : :
6980 : : ! TRANSFORM BACK IN FOURIER SPACE
6981 : : ! transform along y axis
6982 : : ! input: R1,R2,R3,(Rp3)
6983 : : if (n1dfft == lot2) then
6984 : : call dfftw_execute_dft(fw_plan2_lot, zw, zw)
6985 : : else
6986 : : call dfftw_execute_dft(fw_plan2_rest, zw, zw)
6987 : : end if
6988 : :
6989 : : ! input: R1,G2,R3,(Rp3)
6990 : : ! output: G2,R1,R3,(Rp3)
6991 : : if (cplexwf==2) then
6992 : : call unswitch_cent(n1dfft,max2o,m2o,n2,lot2,n1,lzt,zw,zt(1,1,jeff))
6993 : : else
6994 : : call unswitchreal_cent(n1dfft,max2o,n2,lot2,n1,lzt,zw,zt(1,1,jeff))
6995 : : end if
6996 : : end do ! j
6997 : :
6998 : : ! transform along x axis
6999 : : ! input: R2,R1,R3,(Rp3)
7000 : : ! output: R2,G1,R3,(Rp3)
7001 : : do j=1,m2oeff,lot1
7002 : : ma=j
7003 : : mb=min(j+(lot1-1),m2oeff)
7004 : : n1dfft=mb-ma+1
7005 : :
7006 : : if (n1dfft == lot1) then
7007 : : call dfftw_execute_dft(fw_plan1_lot, zt(1,j,1), zw)
7008 : : else
7009 : : call dfftw_execute_dft(fw_plan1_rest, zt(1,j,1), zw)
7010 : : end if
7011 : :
7012 : : ! input: G2,G1,R3,Gp2,(Rp3)
7013 : : ! output: G1,G2,R3,Gp2,(Rp3)
7014 : : if (nproc_fft == 1) then
7015 : : call unmpiswitch_cent(j3,n1dfft,Jp2stf,J2stf,lot1,max1o,md1,m1o,n1,&
7016 : : md2proc,nd3proc,nproc_fft,ioption,zw,zmpi2(:,:,:,:,idat))
7017 : : else
7018 : : call unmpiswitch_cent(j3,n1dfft,Jp2stf,J2stf,lot1,max1o,md1,m1o,n1,&
7019 : : md2proc,nd3proc,nproc_fft,ioption,zw,zmpi1(:,:,:,:,idat))
7020 : : end if
7021 : : end do ! j
7022 : : end if
7023 : : end do
7024 : :
7025 : : ! Interprocessor data transposition
7026 : : ! input: G1,G2,R3,Gp2,(Rp3)
7027 : : ! output: G1,G2,R3,Rp3,(Gp2)
7028 : : if (nproc_fft > 1) then
7029 : : call timab(544,1,tsec)
7030 : : call xmpi_ialltoall(zmpi1(:,:,:,:,idat),2*md1*md2proc*nd3proc, &
7031 : : zmpi2(:,:,:,:,idat),2*md1*md2proc*nd3proc,comm_fft,requests(idat))
7032 : : call timab(544,2,tsec)
7033 : : end if
7034 : : end do
7035 : :
7036 : : do idat=1,ndat
7037 : : if (nproc_fft>1) call xmpi_wait(requests(idat),ierr)
7038 : : ! transform along z axis
7039 : : ! input: G1,G2,R3,(Gp2)
7040 : : !lot=ncache/(4*n3)
7041 : : do j2=1,md2proc
7042 : : if (me_fft*md2proc+j2 <= m2oeff) then
7043 : : do i1=1,m1o,lot3
7044 : : ma=i1
7045 : : mb=min(i1+(lot3-1),m1o)
7046 : : n1dfft=mb-ma+1
7047 : :
7048 : : ! input: G1,G2,R3,(Gp2)
7049 : : ! output: G1,R3,G2,(Gp2)
7050 : : call unscramble(i1,j2,lot3,n1dfft,md1,n3,md2proc,nnd3,zmpi2(:,:,:,:,idat),zw)
7051 : :
7052 : : if (n1dfft == lot3) then
7053 : : call dfftw_execute_dft(fw_plan3_lot, zw, zw)
7054 : : else
7055 : : call dfftw_execute_dft(fw_plan3_rest, zw, zw)
7056 : : end if
7057 : :
7058 : : call unfill_cent(md1,md3,lot3,n1dfft,max3o,m3o,n3,zw,zf(1,i1,1,j2,idat))
7059 : : ! output: G1,G3,G2,(Gp2)
7060 : : end do
7061 : : end if
7062 : : end do
7063 : :
7064 : : ! Complete missing values with complex conjugate
7065 : : ! Inverse of ix is located at nx+2-ix , except for ix=1, for which it is 1.
7066 : : if (cplexwf==1) then
7067 : : do i3=1,m3o
7068 : : i3inv=m3o+2-i3
7069 : : if (i3==1) i3inv=1
7070 : : if (m2oeff>1)then
7071 : : do i2=2,m2oeff
7072 : : i2inv=m2o+2-i2
7073 : : zf(1,1,i3inv,i2inv,idat)= zf(1,1,i3,i2,idat)
7074 : : zf(2,1,i3inv,i2inv,idat)=-zf(2,1,i3,i2,idat)
7075 : : do i1=2,m1o
7076 : : i1inv=m1o+2-i1
7077 : : zf(1,i1inv,i3inv,i2inv,idat)= zf(1,i1,i3,i2,idat)
7078 : : zf(2,i1inv,i3inv,i2inv,idat)=-zf(2,i1,i3,i2,idat)
7079 : : end do
7080 : : end do
7081 : : end if
7082 : : end do
7083 : : end if
7084 : :
7085 : : end do ! idat
7086 : :
7087 : : call dfftw_destroy_plan(bw_plan3_lot)
7088 : : if (mod(m1i, lot3) /= 0) call dfftw_destroy_plan(bw_plan3_rest)
7089 : :
7090 : : call dfftw_destroy_plan(bw_plan1_lot)
7091 : : if (mod(m2ieff, lot1) /= 0) call dfftw_destroy_plan(bw_plan1_rest)
7092 : :
7093 : : call dfftw_destroy_plan(bw_plan2_lot)
7094 : : if (mod(n1eff, lot2) /= 0) call dfftw_destroy_plan(bw_plan2_rest)
7095 : :
7096 : : call dfftw_destroy_plan(fw_plan3_lot)
7097 : : if (mod(m1o, lot3) /= 0) call dfftw_destroy_plan(fw_plan3_rest)
7098 : :
7099 : : call dfftw_destroy_plan(fw_plan1_lot)
7100 : : if (mod(m2oeff, lot1) /= 0) call dfftw_destroy_plan(fw_plan1_rest)
7101 : :
7102 : : call dfftw_destroy_plan(fw_plan2_lot)
7103 : : if (mod(n1eff, lot2) /= 0) call dfftw_destroy_plan(fw_plan2_rest)
7104 : :
7105 : : ABI_FREE(zmpi2)
7106 : : ABI_FREE(zw)
7107 : : ABI_FREE(zt)
7108 : : if (nproc_fft > 1) then
7109 : : ABI_FREE(zmpi1)
7110 : : end if
7111 : :
7112 : : #else
7113 : 0 : ABI_ERROR("FFTW3 support not activated")
7114 : : ABI_UNUSED((/cplexwf,cplex,ndat,n1,n2,n3,nd1,nd2,nd3,nd3proc/))
7115 : : ABI_UNUSED((/max1i,max2i,max3i,m1i,m2i,m3i,md1,md2proc,md3/))
7116 : : ABI_UNUSED((/max1o,max2o,max3o,m1o,m2o,m3o,comm_fft,nproc_fft,me_fft/))
7117 : : ABI_UNUSED((/pot(1,1,1),zf(1,1,1,1,1)/))
7118 : : #endif
7119 : :
7120 : 0 : end subroutine fftw3_applypot_many
7121 : : !!***
7122 : :
7123 : : !----------------------------------------------------------------------
7124 : :
7125 : : !!****f* m_fftw3/fftw3_poisson
7126 : : !! NAME
7127 : : !! fftw3_poisson
7128 : : !!
7129 : : !! FUNCTION
7130 : : !! Solve the Poisson equation in G-space given the density, n(r),
7131 : : !! in real space of the FFT box.
7132 : : !!
7133 : : !! INPUTS
7134 : : !! cplex=1 if fofr is real, 2 if fofr is complex
7135 : : !! nx,ny,nz=Number of FFT points along the three directions.
7136 : : !! ldx,ldy,ldz=Leading dimension of the array nr and vg.
7137 : : !! ndat = Number of densities
7138 : : !! vg(nx*ny*nz)=Potential in reciprocal space.
7139 : : !!
7140 : : !! SIDE EFFECTS
7141 : : !! nr(cplex*ldx*ldy*ldz*ndat)
7142 : : !! input: n(r) (real or complex)
7143 : : !! output: the hartree potential in real space
7144 : : !!
7145 : : !! NOTES
7146 : : !! vg is given on the FFT mesh instead of the augmented mesh [ldx,ldy,ldz]
7147 : : !! in order to simplify the interface with the other routines operating of vg
7148 : : !!
7149 : : !! SOURCE
7150 : :
7151 : 0 : subroutine fftw3_poisson(cplex,nx,ny,nz,ldx,ldy,ldz,ndat,vg,nr)
7152 : :
7153 : : !Arguments ------------------------------------
7154 : : !scalars
7155 : : integer,intent(in) :: cplex,nx,ny,nz,ldx,ldy,ldz,ndat
7156 : : !arrays
7157 : : real(dp),intent(inout) :: nr(cplex*ldx*ldy*ldz*ndat)
7158 : : real(dp),intent(in) :: vg(nx*ny*nz)
7159 : :
7160 : : #ifdef HAVE_FFTW3
7161 : : !Local variables-------------------------------
7162 : : !scalars
7163 : : integer,parameter :: rank1=1,rank2=2
7164 : : integer :: ii,jj,kk,sidx,ig,ir,vgbase,ypad
7165 : : integer, parameter :: nthreads=1
7166 : : integer(KIND_FFTW_PLAN) :: bw_plan_xy,bw_plan3
7167 : : integer(KIND_FFTW_PLAN) :: fw_plan_xy,fw_plan3
7168 : : real(dp) :: fft_fact,vg_fftfact
7169 : : ! *************************************************************************
7170 : :
7171 : : !write(std_out,*)"in poisson"
7172 : : ABI_CHECK(cplex==2,"cplex!=2 not coded")
7173 : : ABI_CHECK(ndat==1,"ndat!=1 not coded")
7174 : :
7175 : : fft_fact = one/(nx*ny*nz)
7176 : :
7177 : : ! The prototype for sfftw_plan_many_dft is:
7178 : : ! sfftw_plan_many_dft(n, howmany,
7179 : : ! fin, iembed, istride, idist,
7180 : : ! fout, oembed, ostride, odist, isign, my_flags)
7181 : :
7182 : : ! 1) ldx*ldy transforms along Rz.
7183 : : fw_plan3 = fftw3_plan_many_dft(rank1, (/nz/), ldx*ldy, & ! We have to visit the entire augmented x-y plane!
7184 : : nr, (/ldx, ldy, ldz/), ldx*ldy, 1, &
7185 : : nr, (/ldx, ldy, ldz/), ldx*ldy, 1, ABI_FFTW_FORWARD, ABI_FFTW_ESTIMATE, nthreads)
7186 : :
7187 : : call fftw3_execute_dft(fw_plan3, nr, nr) ! Now we have nr(x,y,Gz)
7188 : : call fftw3_destroy_plan(fw_plan3)
7189 : :
7190 : : ! R --> G Transforms in x-y plane
7191 : : fw_plan_xy = fftw3_plan_many_dft(rank2, [nx,ny], 1, &
7192 : : nr, (/ldx, ldy, ldz/), 1, 1, &
7193 : : nr, (/ldx, ldy, ldz/), 1, 1, ABI_FFTW_FORWARD, ABI_FFTW_ESTIMATE, nthreads)
7194 : :
7195 : : ! G --> R Transforms in x-y plane
7196 : : bw_plan_xy = fftw3_plan_many_dft(rank2, [nx, ny], 1, &
7197 : : nr, (/ldx, ldy, ldz/), 1, 1, &
7198 : : nr, (/ldx, ldy, ldz/), 1, 1, ABI_FFTW_BACKWARD, ABI_FFTW_ESTIMATE, nthreads)
7199 : :
7200 : : ! Loop on z-planes.
7201 : : do kk=1,nz
7202 : : sidx = 1 + cplex*(kk-1)*ldx*ldy !+ cplex*(dat-1) * ldx*ldy*ldz
7203 : :
7204 : : call fftw3_execute_dft(fw_plan_xy, nr(sidx:), nr(sidx:))
7205 : :
7206 : : ! At this point we have nr(Gx,Gy,Gz) on the current plane.
7207 : : ! Multiply by vc(Gx,Gy,Gz) and then back transform immediately to get vc(x,y,Gz)
7208 : : ! Note that nr is complex whereas vg is real.
7209 : : ! Besides, FFTW returns not normalized FTs if sign=-1 so we have to scale by fft_fact
7210 : : vgbase = (kk-1)*nx*ny !;vgbase = (kk-1)*ldx*ldy
7211 : :
7212 : : ig = 0
7213 : : do jj=1,ny
7214 : : ypad = cplex*(jj-1)*ldx + sidx
7215 : : do ii=1,nx
7216 : : ig = ig + 1
7217 : : vg_fftfact = vg(vgbase+ig) * fft_fact
7218 : :
7219 : : ir = cplex*(ii-1) + ypad
7220 : : nr(ir:ir+1) = nr(ir:ir+1) * vg_fftfact
7221 : : end do
7222 : : end do
7223 : :
7224 : : call fftw3_execute_dft(bw_plan_xy, nr(sidx:), nr(sidx:))
7225 : : end do
7226 : :
7227 : : ! Free plans
7228 : : call fftw3_destroy_plan(fw_plan_xy)
7229 : : call fftw3_destroy_plan(bw_plan_xy)
7230 : :
7231 : : ! Final transforms of vc(x,y,Gz) along Gz to get vc(x,y,z)
7232 : : bw_plan3 = fftw3_plan_many_dft(rank1, (/nz/), ldx*ldy, & ! We have to visit the entire augmented x-y plane!
7233 : : nr, (/ldx, ldy, ldz/), ldx*ldy, 1, &
7234 : : nr, (/ldx, ldy, ldz/), ldx*ldy, 1, ABI_FFTW_BACKWARD, ABI_FFTW_ESTIMATE, nthreads)
7235 : :
7236 : : call fftw3_execute_dft(bw_plan3, nr, nr)
7237 : : call fftw3_destroy_plan(bw_plan3)
7238 : :
7239 : : #else
7240 : : ABI_UNUSED((/cplex,nx,ny,nz,ldx,ldy,ldz,ndat/))
7241 : : ABI_UNUSED((/nr(1),vg(1)/))
7242 : : #endif
7243 : :
7244 : 0 : end subroutine fftw3_poisson
7245 : : !!**
7246 : :
7247 : : !----------------------------------------------------------------------
7248 : :
7249 : : END MODULE m_fftw3
7250 : : !!***
|
