Branch data Line data Source code
1 : : block
2 : : !Local variables-------------------------------
3 : : !scalars
4 : : integer,parameter :: cplex0=0,option3=3,npwin0=0,ndat1=1
5 : : integer :: nx,ny,nz,ldx,ldy,ldz,fftalg,fftalga,fftalgc,fftcache
6 : : integer :: idat,rspad,gspad,ix,iy,iz,ifft,ipw
7 : : real(dp),parameter :: weight1_i=one,weight1_r=one
8 : : !arrays
9 : : integer :: kg_kin0(3,0)
10 : : real(dp) :: dum_denpot(0,0,0),dum_fofgin(0,0)
11 : 780045 : real(dp),allocatable :: fofgout(:,:),fofr(:,:,:,:),fg_box(:,:,:,:)
12 : : ! *************************************************************************
13 : :
14 : 780045 : fftalg=ngfft(7); fftalga=fftalg/100; fftalgc=MOD(fftalg,10); fftcache=ngfft(8)
15 : 780045 : nx=ngfft(1); ny=ngfft(2); nz=ngfft(3)
16 : :
17 : 0 : select case (fftalga)
18 : : case (FFT_FFTW3)
19 : 0 : ldx=nx; ldy=ny; ldz=nz ! No augmentation, the caller does not support it.
20 : : call fftw3_fftur(fftalg, fftcache, npw_k, nx, ny, nz, ldx, ldy, ldz, nspinor*ndat, istwf_k, mgfft, &
21 : 0 : kg_k, gbound_k, ur, ug)
22 : :
23 : : case (FFT_DFTI)
24 : 780004 : ldx=nx; ldy=ny; ldz=nz ! No augmentation, the caller does not support it.
25 : : call dfti_fftur(fftalg, fftcache, npw_k, nx, ny, nz, ldx, ldy, ldz, nspinor*ndat, istwf_k, mgfft, &
26 : 780004 : kg_k, gbound_k, ur, ug)
27 : :
28 : : case (FFT_SG, FFT_SG2002)
29 : : ! Goedecker routines.
30 : : ! 1) sg_fftrisc does not support istwkf >= 2 for the u(r) --> u(G) transform.
31 : 41 : ldx=ngfft(4); ldy=ngfft(5); ldz=ngfft(6)
32 [ - + + - : 123 : ABI_MALLOC(fofgout,(2,npw_k))
+ - + - -
+ - + - +
+ - + - +
- - + -
+ ]
33 [ - + + - : 205 : ABI_MALLOC(fofr,(2,ldx,ldy,ldz))
- + + - -
+ + - + -
+ - - + -
+ - + + -
- + + - -
+ + - + -
+ - - + -
+ ]
34 : :
35 [ + + + + ]: 41 : if (istwf_k/=1) then
36 [ - + + - : 128 : ABI_MALLOC(fg_box,(2,ldx,ldy,ldz))
- + + - -
+ + - - +
- + - + +
- - + + -
- + + - -
+ - + ]
37 : : end if
38 : :
39 [ + + + + ]: 136 : do idat=1,nspinor*ndat
40 : 95 : gspad = (idat-1)*npw_k
41 : 95 : rspad = (idat-1)*nfft
42 : : !
43 : : ! Fill fofr from input ur array.
44 [ + + + + ]: 9545 : do iz=1,nz
45 [ + + + + ]: 950045 : do iy=1,ny
46 [ + + + + ]: 94594950 : do ix=1,nx
47 : 93645000 : ifft = ix + (iy-1)*nx + (iz-1)*nx*ny + rspad
48 : 93645000 : fofr(1,ix,iy,iz) = REAL( ur(ifft))
49 : 94585500 : fofr(2,ix,iy,iz) = AIMAG(ur(ifft))
50 : : end do
51 : : end do
52 : : end do
53 : :
54 [ + + + + ]: 95 : if (istwf_k==1) then
55 : : !
56 : : ! option=3 --> real space to reciprocal space.
57 : : ! NOTE that in this case, istwf_k=1 must be used.
58 : : ! this is not thread-safe! use ndat1
59 : : call sg_fftrisc(cplex0,dum_denpot,dum_fofgin,fofgout,fofr,&
60 : : gbound_k,gbound_k,istwf_k,kg_kin0,kg_k,mgfft,ndat1,ngfft,npwin0,npw_k,ldx,ldy,ldz,&
61 : 15 : option3,weight1_r,weight1_i)
62 : :
63 : : else
64 : : ! Zero-padded on the Box, then transfer data from box to sphere. ndat=1 here.
65 : 80 : call sg_fftpad(fftcache,mgfft,nx,ny,nz,ldx,ldy,ldz,ndat1,gbound_k,-1,fofr,fg_box)
66 : :
67 : 80 : call cg_box2gsph(nx,ny,nz,ldx,ldy,ldz,ndat1,npw_k,kg_k,fg_box,fofgout,rscal=one/(nx*ny*nz))
68 : : end if
69 : :
70 [ + + + + ]: 3310966 : do ipw=1,npw_k ! Have to convert from REAL to CMPLX
71 : 3310925 : ug(ipw+gspad) = DCMPLX(fofgout(1,ipw), fofgout(2,ipw))
72 : : end do
73 : : !
74 : : end do ! idat
75 : :
76 [ - + - + ]: 41 : ABI_FREE(fofgout)
77 [ - + - + ]: 41 : ABI_FREE(fofr)
78 [ + + + + ]: 41 : ABI_SFREE(fg_box)
79 : :
80 : : case default
81 [ - + + - : 780045 : ABI_ERROR(sjoin("Wrong fftalga:", itoa(fftalga)))
- + + - ]
82 : : end select
83 : :
84 : : end block
|
