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 : !!***
|
