Branch data Line data Source code
1 : : !!****m* ABINIT/m_sgfft
2 : : !! NAME
3 : : !! m_sgfft
4 : : !!
5 : : !! FUNCTION
6 : : !! This module provides low-level interfaces to Goedecker's FFT library.
7 : : !!
8 : : !! COPYRIGHT
9 : : !! Copyright by Stefan Goedecker, Ithaca, NY USA, July 14, 1993
10 : : !! Copyright (C) 1998-2026 ABINIT group (DCA, XG)
11 : : !! This file is distributed under the terms of the
12 : : !! GNU General Public License, see ~abinit/COPYING
13 : : !! or http://www.gnu.org/copyleft/gpl.txt .
14 : : !!
15 : : !! SOURCE
16 : :
17 : : #if defined HAVE_CONFIG_H
18 : : #include "config.h"
19 : : #endif
20 : :
21 : : #include "abi_common.h"
22 : :
23 : : MODULE m_sgfft
24 : :
25 : : use defs_basis
26 : : use m_abicore
27 : : use m_errors
28 : : use m_fftcore
29 : :
30 : : use m_fstrings, only : sjoin, itoa
31 : : use defs_fftdata, only : mg
32 : :
33 : : implicit none
34 : :
35 : : private
36 : :
37 : : ! Public API.
38 : : public :: sg_fft_cc ! Complex-Complex version (full box)
39 : : public :: sg_fft_rc ! Real-Complex version (full box)
40 : : public :: sg_fftpad ! Zero-padding version of "fft".
41 : : public :: sg_fftrisc ! Fourier transforms of wavefunctions
42 : : public :: sg_fftrisc_2
43 : : public :: sg_poisson ! Solve the poisson equation in G-space starting from n(r).
44 : :
45 : : CONTAINS !====================================================================
46 : : !!***
47 : :
48 : :
49 : : !!****f* m_sgfft/sg_fft_cc
50 : : !! NAME
51 : : !! sg_fft_cc
52 : : !!
53 : : !! FUNCTION
54 : : !! Calculates the discrete Fourier transform:
55 : : !!
56 : : !! ftarr(i1,i2,i3)=exp(ris*i*2*pi*(j1*i1/n1+j2*i2/n2+j3*i3/n3)) arr(j1,j2,j3)
57 : : !!
58 : : !! INPUTS
59 : : !! fftcache=size of the cache (kB)
60 : : !! n1,n2,n3=physical dimension of the transform
61 : : !! nd1,nd2,nd3=memory dimension of arr and ftarr
62 : : !! ndat=Number of FFT transforms
63 : : !! isign=+1 for G-->R, -1 for R-->G
64 : : !! arr(2,nd1*nd2*nd3*ndat)=input complex array with alternating real and imaginary
65 : : !! elements; data resides in 2*n1*n2*n3 of this array, spread out.
66 : : !! (see SIDE FFECTS).
67 : : !!
68 : : !! OUTPUT
69 : : !! ftarr(2,nd1*nd2*nd3*ndat)=working space for transform and contains output
70 : : !!
71 : : !! SIDE EFFECTS
72 : : !! arr(2,nd1*nd2*nd3*ndat) is modified by sg_fftx,sg_ffty,sg_fftz.
73 : : !!
74 : : !! NOTES
75 : : !! ndi must always be greater or equal to ni. Recommended choice for nd1
76 : : !! and nd2 is: ni for ni=odd or ni+1 for ni=even (hence 2*(ni/2)+1);
77 : : !! nd3 should always be n3. Note that choosing nd1 or nd2 larger than
78 : : !! the recommended value can severely degrade efficiency of this routine.
79 : : !! Avoiding even ndi for nd1 and nd2 avoids cache conflicts on cache machines.
80 : : !! Each of n1,n2,n3 must be a
81 : : !! product of the prime factors 2,3,5. If two ni s are equal
82 : : !! it is recommended to place them behind each other.
83 : : !! The largest any of these may be is set by parameter "mg" below.
84 : : !! This fft is particularly efficient for cache architectures.
85 : : !! Note that the meaning of fftcache has changed from the original
86 : : !! ncache of SG (that was the maximum number of COMPLEX*16 in the cache)
87 : : !!
88 : : !! SOURCE
89 : :
90 : 37573 : subroutine sg_fft_cc(fftcache,n1,n2,n3,nd1,nd2,nd3,ndat,isign,arr,ftarr)
91 : :
92 : : !Arguments ------------------------------------
93 : : !scalars
94 : : integer,intent(in) :: fftcache,n1,n2,n3,nd1,nd2,nd3,ndat,isign
95 : : !arrays
96 : : real(dp),intent(inout) :: arr(2,nd1*nd2*nd3*ndat)
97 : : real(dp),intent(inout) :: ftarr(2,nd1*nd2*nd3*ndat)
98 : :
99 : : !Local variables-------------------------------
100 : : !scalars
101 : : integer :: idat,start
102 : :
103 : : ! *************************************************************************
104 : :
105 [ + + ]: 75188 : do idat=1,ndat
106 : 37615 : start = 1 + (idat-1)*nd1*nd2*nd3
107 : 75188 : call fft_cc_one_nothreadsafe(fftcache,nd1,nd2,nd3,n1,n2,n3,arr(1,start),ftarr(1,start),real(isign,kind=dp))
108 : : end do
109 : :
110 : 37573 : end subroutine sg_fft_cc
111 : : !!***
112 : :
113 : : !----------------------------------------------------------------------
114 : :
115 : : !!****f* m_sgfft/fft_cc_one_nothreadsafe
116 : : !! NAME
117 : : !! fft_cc_one_nothreadsafe
118 : : !!
119 : : !! FUNCTION
120 : : !! Calculates the discrete Fourier transform:
121 : : !!
122 : : !! ftarr(i1,i2,i3)=exp(ris*i*2*pi*(j1*i1/n1+j2*i2/n2+j3*i3/n3)) arr(j1,j2,j3)
123 : : !!
124 : : !! INPUTS
125 : : !! fftcache=size of the cache (kB)
126 : : !! nd1,nd2,nd3=memory dimension of arr and ftarr
127 : : !! n1,n2,n3=physical dimension of the transform
128 : : !! arr(2,nd1,nd2,nd3)=input complex array with alternating real and imaginary
129 : : !! elements; data resides in 2*n1*n2*n3 of this array, spread out.
130 : : !! (see SIDE FFECTS).
131 : : !! ris=(real(dp)) sign of exponential in transform
132 : : !!
133 : : !! OUTPUT
134 : : !! ftarr(2,nd1,nd2,nd3)=working space for transform and contains output
135 : : !!
136 : : !! SIDE EFFECTS
137 : : !! arr(2,nd1,nd2,nd3) is modified by sg_fftx,sg_ffty,sg_fftz.
138 : : !!
139 : : !! NOTES
140 : : !! ndi must always be greater or equal to ni. Recommended choice for nd1
141 : : !! and nd2 is: ni for ni=odd or ni+1 for ni=even (hence 2*(ni/2)+1);
142 : : !! nd3 should always be n3. Note that choosing nd1 or nd2 larger than
143 : : !! the recommended value can severely degrade efficiency of this routine.
144 : : !! Avoiding even ndi for nd1 and nd2 avoids cache conflicts on cache machines.
145 : : !! Each of n1,n2,n3 must be a
146 : : !! product of the prime factors 2,3,5. If two ni s are equal
147 : : !! it is recommended to place them behind each other.
148 : : !! The largest any of these may be is set by parameter "mg" below.
149 : : !! This fft is particularly efficient for cache architectures.
150 : : !! Note that the meaning of fftcache has changed from the original
151 : : !! ncache of SG (that was the maximum number of COMPLEX*16 in the cache)
152 : : !!
153 : : !! SOURCE
154 : :
155 : 37615 : subroutine fft_cc_one_nothreadsafe(fftcache,nd1,nd2,nd3,n1,n2,n3,arr,ftarr,ris)
156 : :
157 : : !Arguments ------------------------------------
158 : : !scalars
159 : : integer,intent(in) :: fftcache,n1,n2,n3,nd1,nd2,nd3
160 : : real(dp),intent(in) :: ris
161 : : !arrays
162 : : real(dp),intent(inout) :: arr(2,nd1,nd2,nd3)
163 : : real(dp),intent(inout) :: ftarr(2,nd1,nd2,nd3) !vz_i
164 : :
165 : : !Local variables-------------------------------
166 : : !mfac sets maximum number of factors (5, 4, 3, or 2) which may be
167 : : !contained within any n1, n2, or n3
168 : : !mg sets the maximum 1 dimensional fft length (any one of n1, n2, or n3)
169 : : !scalars
170 : : integer,parameter :: mfac=11
171 : : integer :: i2,ic,n1i,n3i
172 : : character(len=500) :: message
173 : : !arrays
174 : : integer :: aft(mfac),bef(mfac),ind(mg),now(mfac)
175 : : real(dp) :: trig(2,mg)
176 : :
177 : : ! *************************************************************************
178 : :
179 : : !Check that dimension is not exceeded
180 [ + - + - : 37615 : if (n1>mg.or.n2>mg.or.n3>mg) then
- + ]
181 : : write(message, '(a,3i10,a,i10,a)' )&
182 : 0 : & 'one of the dimensions n1,n2,n3=',n1,n2,n3,&
183 : 0 : & 'exceeds allowed dimension mg=',mg,ch10
184 : 0 : ABI_BUG(message)
185 : : end if
186 : :
187 : : !transform along x direction
188 : 37615 : call sg_ctrig(n1,trig,aft,bef,now,ris,ic,ind,mfac,mg)
189 : : call sg_fftx(fftcache,mfac,mg,nd1,nd2,nd3,n2,n3,&
190 : 37615 : & arr,ftarr,trig,aft,now,bef,ris,ind,ic)
191 : :
192 : : ! This to handle 1d FFTs
193 [ - + - - ]: 37615 : if (n2 == 1 .and. n3 == 1) then
194 : : !print *, "Returning as n2, n3:", n2, n3
195 : 0 : return
196 : : end if
197 : :
198 : : !transform along y direction
199 [ + + ]: 37615 : if (n2/=n1)then
200 : 1524 : call sg_ctrig(n2,trig,aft,bef,now,ris,ic,ind,mfac,mg)
201 : : end if
202 : 37615 : n1i=1 ; n3i=1
203 : : call sg_ffty(fftcache,mfac,mg,nd1,nd2,nd3,n1i,n1,n3i,n3,&
204 : 37615 : & ftarr,arr,trig,aft,now,bef,ris,ind,ic)
205 : :
206 : : !transform along z direction
207 [ + + ]: 37615 : if (n3/=n2)then
208 : 32367 : call sg_ctrig(n3,trig,aft,bef,now,ris,ic,ind,mfac,mg)
209 : : end if
210 : :
211 : : !$OMP PARALLEL DO SHARED(aft,arr,bef,ftarr,ind,ic)&
212 : : !$OMP SHARED(nd1,nd2,nd3,now,n1,n2,ris,trig)&
213 : : !$OMP PRIVATE(i2)
214 [ + + ]: 457182 : do i2=1,n2
215 : : call sg_fftz(mfac,mg,nd1,nd2,nd3,n1,i2,i2,arr,ftarr,&
216 : 457182 : & trig,aft,now,bef,ris,ind,ic)
217 : : end do
218 : : !$OMP END PARALLEL DO
219 : :
220 : : end subroutine fft_cc_one_nothreadsafe
221 : : !!***
222 : :
223 : : !----------------------------------------------------------------------
224 : :
225 : : !!****f* m_sgfft/sg_fft_rc
226 : : !! NAME
227 : : !! sg_fft_rc
228 : : !!
229 : : !! FUNCTION
230 : : !! Conduct Fourier transform of REAL or COMPLEX function f(r)=fofr defined on
231 : : !! fft grid in real space, to create complex f(G)=fofg defined on full fft grid
232 : : !! in reciprocal space, in full storage mode, or the reverse operation.
233 : : !! For the reverse operation, the final data is divided by nfftot.
234 : : !! REAL case when cplex=1, COMPLEX case when cplex=2. Usually used for density and potentials.
235 : : !!
236 : : !! There are two different possibilities :
237 : : !! fftalgb=0 means using the complex-to-complex FFT routine,
238 : : !! irrespective of the value of cplex
239 : : !! fftalgb=1 means using a real-to-complex FFT or a complex-to-complex FFT,
240 : : !! depending on the value of cplex.
241 : : !! The only real-to-complex FFT available is from SGoedecker library.
242 : : !!
243 : : !! INPUTS
244 : : !! cplex=1 if fofr is real, 2 if fofr is complex
245 : : !! isign=sign of Fourier transform exponent: current convention uses
246 : : !! +1 for transforming from G to r
247 : : !! -1 for transforming from r to G.
248 : : !! nfft=(effective) number of FFT grid points (for this processor)
249 : : !! ngfft(18)=contain all needed information about 3D FFT, see ~abinit/doc/variables/vargs.htm#ngfft
250 : : !!
251 : : !! OUTPUT
252 : : !! (see side effects)
253 : : !!
254 : : !! SIDE EFFECTS
255 : : !! Input/Output
256 : : !! fofg(2,nfft)=f(G), complex.
257 : : !! fofr(cplex*nfft)=input function f(r) (real or complex)
258 : : !!
259 : : !! SOURCE
260 : :
261 : 7692 : subroutine sg_fft_rc(cplex,fofg,fofr,isign,nfft,ngfft)
262 : :
263 : : !Arguments ------------------------------------
264 : : !scalars
265 : : integer,intent(in) :: cplex,isign,nfft
266 : : !arrays
267 : : integer,intent(in) :: ngfft(18)
268 : : real(dp),intent(inout) :: fofg(2,nfft),fofr(cplex*nfft)
269 : :
270 : : !Local variables-------------------------------
271 : : !scalars
272 : : integer,parameter :: mfac=11
273 : : integer :: fftalg,fftalga,fftalgb,fftcache,i1,i2,i3,ic1,ic2,ic3,index
274 : : integer :: n1,n1half1,n1halfm,n2,n2half1,n3,n4,n4half1,n5,n5half1,n6
275 : : real(dp) :: ris,xnorm
276 : : character(len=500) :: msg
277 : : !arrays
278 : : integer :: aft1(mfac),aft2(mfac),aft3(mfac),bef1(mfac),bef2(mfac),bef3(mfac)
279 : : integer :: ind1(mg),ind2(mg),ind3(mg),now1(mfac),now2(mfac),now3(mfac)
280 : : real(dp) :: trig1(2,mg),trig2(2,mg),trig3(3,mg)
281 : 7692 : real(dp),allocatable :: wk2d_a(:,:,:,:),wk2d_b(:,:,:,:),wk2d_c(:,:,:,:)
282 : 7692 : real(dp),allocatable :: wk2d_d(:,:,:,:),work1(:,:,:,:),work2(:,:,:,:)
283 : :
284 : : ! *************************************************************************
285 : :
286 : : !DBG_ENTER("COLL")
287 : :
288 : 7692 : n1=ngfft(1); n2=ngfft(2); n3=ngfft(3)
289 : 7692 : n4=ngfft(4); n5=ngfft(5); n6=ngfft(6)
290 : :
291 : 7692 : fftcache=ngfft(8)
292 : 7692 : fftalg =ngfft(7)
293 : 7692 : fftalga =fftalg/100
294 : 7692 : fftalgb =mod(fftalg,100)/10
295 : :
296 : 7692 : ris=dble(isign)
297 : 7692 : xnorm=1.0d0/dble(n1*n2*n3)
298 : :
299 [ - + ]: 7692 : if (fftalgb/=0 .and. fftalgb/=1) then
300 : : write(msg, '(a,i4,a,a,a,a,a)' )&
301 : 0 : & 'The input algorithm number fftalg=',fftalg,' is not allowed.',ch10,&
302 : 0 : & 'The second digit (fftalg(B)) must be 0 or 1.',ch10,&
303 : 0 : & 'Action: change fftalg in your input file.'
304 : 0 : ABI_BUG(msg)
305 : : end if
306 : :
307 [ + - - + : 7692 : if (fftalgb==1 .and. ALL(fftalga/=(/1,3,4/)) )then
- - ]
308 : : write(msg,'(a,i4,5a)')&
309 : 0 : & 'The input algorithm number fftalg=',fftalg,' is not allowed.',ch10,&
310 : 0 : & 'When fftalg(B) is 1, the allowed values for fftalg(A) are 1 and 4.',ch10,&
311 : 0 : & 'Action: change fftalg in your input file.'
312 : 0 : ABI_BUG(msg)
313 : : end if
314 : :
315 [ + - - + ]: 7692 : if (n4<n1.or.n5<n2.or.n6<n3) then
316 : 0 : write(msg,'(a,3i8,a,3i8)')' Each of n4,n5,n6=',n4,n5,n6,'must be >= n1, n2, n3 =',n1,n2,n3
317 : 0 : ABI_BUG(msg)
318 : : end if
319 : :
320 : : !---------------------------------------------------------
321 : : !Here sophisticated algorithm based on S. Goedecker routines, only for the REAL case.
322 : : !Take advantage of the fact that fofr is real, and that fofg has corresponding symmetry properties.
323 : :
324 : : #ifdef DEBUG_MODE
325 : : if (n1>mg .or. n2>mg .or. n3>mg) then
326 : : write(msg, '(a,3i10,a,a,a,i10,a)' )&
327 : : & 'One of the dimensions n1,n2,n3=',n1,n2,n3,',',ch10,&
328 : : & 'exceeds allowed dimension mg=',mg,'.'
329 : : ABI_BUG(msg)
330 : : end if
331 : : #endif
332 : :
333 : 7692 : n1half1=n1/2+1 ; n1halfm=(n1+1)/2
334 : 7692 : n2half1=n2/2+1
335 : : !n4half1 or n5half1 are the odd integers >= n1half1 or n2half1
336 : 7692 : n4half1=(n1half1/2)*2+1
337 : 7692 : n5half1=(n2half1/2)*2+1
338 : :
339 : : !This sophisticated algorithm allows to decrease the memory needs.
340 [ - + + - : 38460 : ABI_MALLOC(work1,(2,n4,n5half1,n6))
- + + - -
+ + - + -
+ - - + -
+ ]
341 [ - + + - : 30768 : ABI_MALLOC(work2,(2,n4,n5half1,n6))
- + + - -
+ + - - +
- + ]
342 : :
343 [ + + ]: 7692 : if(isign==1)then
344 : :
345 : : ! Compute auxiliary arrays needed for FFTs, here forward FFT
346 : 4052 : call sg_ctrig(n1,trig1,aft1,bef1,now1,one,ic1,ind1,mfac,mg)
347 : 4052 : call sg_ctrig(n2,trig2,aft2,bef2,now2,one,ic2,ind2,mfac,mg)
348 : 4052 : call sg_ctrig(n3,trig3,aft3,bef3,now3,one,ic3,ind3,mfac,mg)
349 : :
350 : : ! Transfer fofg to the expanded fft box (only half of it)
351 : :
352 : : !$OMP PARALLEL DO PRIVATE(i1,i2,i3,index) SHARED(fofg,n1,n2,n3,work1)
353 [ + + ]: 107768 : do i3=1,n3
354 [ + + ]: 1562292 : do i2=1,n2half1
355 : 1454524 : index=n1*(i2-1+n2*(i3-1))
356 [ + + ]: 45729432 : do i1=1,n1
357 : 44171192 : work1(1,i1,i2,i3)=fofg(1,i1+index)
358 : 45625716 : work1(2,i1,i2,i3)=fofg(2,i1+index)
359 : : end do
360 : : end do
361 : : end do
362 : :
363 : : !$OMP PARALLEL DO SHARED(aft3,bef3,ind3,ic3,now3,n1,n2half1,n4,n5half1,n6,ris,trig3,work1,work2) PRIVATE(i2)
364 [ + + ]: 54779 : do i2=1,n2half1
365 : : call sg_fftz(mfac,mg,n4,n5half1,n6,n1,i2,i2,work1,work2,&
366 : 54779 : & trig3,aft3,now3,bef3,ris,ind3,ic3)
367 : : end do
368 : :
369 : : ! Loop over x-y planes
370 : :
371 : : !$OMP PARALLEL PRIVATE(i1,i2,i3,index,wk2d_a,wk2d_b,wk2d_c,wk2d_d) &
372 : : !$OMP&SHARED(aft1,aft2,bef1,bef2,fftcache,fofg,fofr,ic1,ic2,ind1,ind2) &
373 : : !$OMP&SHARED(n1,n1half1,n1halfm,n2,n2half1,n3) &
374 : : !$OMP&SHARED(n4,n5,now1,now2,ris,trig1,trig2,work2)
375 : :
376 [ - + + - : 16208 : ABI_MALLOC(wk2d_a,(2,n4,n5,1))
- + + - +
- + - - +
- + ]
377 [ - + + - : 12156 : ABI_MALLOC(wk2d_b,(2,n4,n5,1))
- + + - -
+ - + ]
378 [ + - - + : 16208 : ABI_MALLOC(wk2d_c,(2,2*n1halfm+1,n5,1))
+ - - + +
- + - + -
- + - + ]
379 [ - + + - : 12156 : ABI_MALLOC(wk2d_d,(2,2*n1halfm+1,n5,1))
- + + - -
+ + - ]
380 : :
381 : : !$OMP DO
382 [ + + ]: 107768 : do i3=1,n3
383 : :
384 [ + + ]: 1558240 : do i2=1,n2half1
385 [ + + ]: 45729432 : do i1=1,n1
386 : 44171192 : wk2d_c(1,i1,i2,1)=work2(1,i1,i2,i3)
387 : 45625716 : wk2d_c(2,i1,i2,1)=work2(2,i1,i2,i3)
388 : : end do
389 : : end do
390 : :
391 : : call sg_fftx(fftcache,mfac,mg,2*n1halfm+1,n5,1,n2half1,1,wk2d_c,wk2d_d,&
392 : 103716 : & trig1,aft1,now1,bef1,ris,ind1,ic1)
393 : :
394 [ + + ]: 1461004 : do i1=1,n1half1-1 ! Compute symmetric and antisymmetric combinations
395 : 1357288 : wk2d_a(1,i1,1,1)=wk2d_d(1,2*i1-1,1,1)
396 : 1461004 : wk2d_a(2,i1,1,1)=wk2d_d(1,2*i1 ,1,1)
397 : : end do
398 : :
399 [ + + ]: 103716 : if((2*n1half1-2)/=n1)then ! If n1 odd, must add last data
400 : 11250 : wk2d_a(1,n1half1,1,1)=wk2d_d(1,n1,1,1)
401 : 11250 : wk2d_a(2,n1half1,1,1)=0.0d0
402 : : end if
403 : :
404 [ + + ]: 1454524 : do i2=2,n2half1
405 [ + + ]: 22034116 : do i1=1,n1half1-1
406 : 20683308 : wk2d_a(1,i1,i2,1) = wk2d_d(1,2*i1-1,i2,1)-wk2d_d(2,2*i1,i2,1)
407 : 20683308 : wk2d_a(2,i1,i2,1) = wk2d_d(2,2*i1-1,i2,1)+wk2d_d(1,2*i1,i2,1)
408 : 20683308 : wk2d_a(1,i1,n2+2-i2,1)= wk2d_d(1,2*i1-1,i2,1)+wk2d_d(2,2*i1,i2,1)
409 : 22034116 : wk2d_a(2,i1,n2+2-i2,1)=-wk2d_d(2,2*i1-1,i2,1)+wk2d_d(1,2*i1,i2,1)
410 : : end do
411 [ + + ]: 1454524 : if((2*n1half1-2)/=n1)then
412 : 78750 : wk2d_a(1,n1half1,i2,1) = wk2d_d(1,n1,i2,1)
413 : 78750 : wk2d_a(2,n1half1,i2,1) = wk2d_d(2,n1,i2,1)
414 : 78750 : wk2d_a(1,n1half1,n2+2-i2,1)= wk2d_d(1,n1,i2,1)
415 : 78750 : wk2d_a(2,n1half1,n2+2-i2,1)=-wk2d_d(2,n1,i2,1)
416 : : end if
417 : : end do
418 : :
419 : : call sg_ffty(fftcache,mfac,mg,n4,n5,1,1,n1halfm,1,1,wk2d_a,wk2d_b,&
420 : 103716 : & trig2,aft2,now2,bef2,ris,ind2,ic2)
421 : :
422 [ + + ]: 2820634 : do i2=1,n2 ! Take real part data from expanded box and put it in the original box.
423 : 2712866 : index=n1*(i2-1+n2*(i3-1))
424 [ + + ]: 44158232 : do i1=1,n1half1-1 ! copy data
425 : 41445366 : fofr(2*i1-1+index)=wk2d_b(1,i1,i2,1)
426 : 44158232 : fofr(2*i1 +index)=wk2d_b(2,i1,i2,1)
427 : : end do
428 [ + + ]: 2816582 : if((2*n1half1-2)/=n1)then ! If n1 odd, must add last data
429 : 168750 : fofr(n1+index)=wk2d_b(1,n1half1,i2,1)
430 : : end if
431 : : end do
432 : :
433 : : end do ! loop over x-y planes
434 : : !$OMP END DO
435 [ - + ]: 4052 : ABI_FREE(wk2d_a)
436 [ - + ]: 4052 : ABI_FREE(wk2d_b)
437 [ - + ]: 4052 : ABI_FREE(wk2d_c)
438 [ - + ]: 4052 : ABI_FREE(wk2d_d)
439 : : !$OMP END PARALLEL
440 : :
441 [ + - ]: 3640 : else if(isign==-1)then
442 : :
443 : : ! Compute auxiliary arrays needed for FFTs, here backward FFT
444 : 3640 : call sg_ctrig(n1,trig1,aft1,bef1,now1,-one,ic1,ind1,mfac,mg)
445 : 3640 : call sg_ctrig(n2,trig2,aft2,bef2,now2,-one,ic2,ind2,mfac,mg)
446 : 3640 : call sg_ctrig(n3,trig3,aft3,bef3,now3,-one,ic3,ind3,mfac,mg)
447 : :
448 : : ! Treat first x-transform in x-y plane, and multiply
449 : : ! by overall normalization factor 1/nfftot
450 : :
451 : : ! Loop over x-y planes
452 : :
453 : : !$OMP PARALLEL PRIVATE(i1,i2,i3,index,wk2d_a,wk2d_b,wk2d_c,wk2d_d) &
454 : : !$OMP&SHARED(aft1,aft2,bef1,bef2,fftcache,fofr,ic1,ic2,ind1,ind2) &
455 : : !$OMP&SHARED(n1,n1half1,n1halfm,n2,n2half1,n3) &
456 : : !$OMP&SHARED(n4,n5,now1,now2,ris,trig1,trig2,work1,xnorm)
457 : :
458 [ - + + - : 14560 : ABI_MALLOC(wk2d_a,(2,n4,n5,1))
- + + - +
- + - - +
- + ]
459 [ - + + - : 10920 : ABI_MALLOC(wk2d_b,(2,n4,n5,1))
- + + - -
+ - + ]
460 [ + - - + : 14560 : ABI_MALLOC(wk2d_c,(2,2*n1halfm+1,n5,1))
+ - - + +
- + - + -
- + - + ]
461 [ - + + - : 10920 : ABI_MALLOC(wk2d_d,(2,2*n1halfm+1,n5,1))
- + + - -
+ + - ]
462 : :
463 : : !$OMP DO
464 [ + + ]: 103612 : do i3=1,n3
465 [ + + ]: 2816610 : do i2=1,n2
466 : 2716638 : index=n1*(i2-1+n2*(i3-1))
467 [ + + ]: 45028224 : do i1=1,n1half1-1 ! copy and normalize data
468 : 42311586 : wk2d_a(1,i1,i2,1)=fofr(2*i1-1+index)*xnorm
469 : 45028224 : wk2d_a(2,i1,i2,1)=fofr(2*i1 +index)*xnorm
470 : : end do
471 : :
472 [ + + ]: 2816610 : if((2*n1half1-2)/=n1)then ! If n1 odd, must add last data
473 : 115650 : wk2d_a(1,n1half1,i2,1)=fofr(n1+index)*xnorm
474 : 115650 : wk2d_a(2,n1half1,i2,1)=zero
475 : : end if
476 : : end do
477 : :
478 : : call sg_ffty(fftcache,mfac,mg,n4,n5,1,1,n1halfm,1,1,wk2d_a,wk2d_b,&
479 : 99972 : & trig2,aft2,now2,bef2,ris,ind2,ic2)
480 : :
481 [ + + ]: 1467654 : do i1=1,n1halfm ! Decompose symmetric and antisymmetric parts
482 : 1367682 : wk2d_c(1,2*i1-1,1,1)=wk2d_b(1,i1,1,1)
483 : 1367682 : wk2d_c(2,2*i1-1,1,1)=0.0d0
484 : 1367682 : wk2d_c(1,2*i1,1,1)=wk2d_b(2,i1,1,1)
485 : 1467654 : wk2d_c(2,2*i1,1,1)=0.0d0
486 : : end do
487 : :
488 [ + + ]: 1454436 : do i2=2,n2half1
489 [ + + ]: 22637214 : do i1=1,n1halfm
490 : 21182778 : wk2d_c(1,2*i1-1,i2,1)= (wk2d_b(1,i1,i2,1)+wk2d_b(1,i1,n2+2-i2,1))*0.5d0
491 : 21182778 : wk2d_c(2,2*i1-1,i2,1)= (wk2d_b(2,i1,i2,1)-wk2d_b(2,i1,n2+2-i2,1))*0.5d0
492 : 21182778 : wk2d_c(1,2*i1,i2,1) = (wk2d_b(2,i1,i2,1)+wk2d_b(2,i1,n2+2-i2,1))*0.5d0
493 : 22537242 : wk2d_c(2,2*i1,i2,1) =-(wk2d_b(1,i1,i2,1)-wk2d_b(1,i1,n2+2-i2,1))*0.5d0
494 : : end do
495 : : end do
496 : :
497 : : call sg_fftx(fftcache,mfac,mg,2*n1halfm+1,n5,1,n2half1,1,wk2d_c,wk2d_d,&
498 : 99972 : & trig1,aft1,now1,bef1,ris,ind1,ic1)
499 : :
500 [ + + ]: 1558048 : do i2=1,n2half1
501 [ + + ]: 46593648 : do i1=1,n1
502 : 45039240 : work1(1,i1,i2,i3)=wk2d_d(1,i1,i2,1)
503 : 46493676 : work1(2,i1,i2,i3)=wk2d_d(2,i1,i2,1)
504 : : end do
505 : : end do
506 : :
507 : : end do
508 : : !$OMP END DO
509 [ - + ]: 3640 : ABI_FREE(wk2d_a)
510 [ - + ]: 3640 : ABI_FREE(wk2d_b)
511 [ - + ]: 3640 : ABI_FREE(wk2d_c)
512 [ - + ]: 3640 : ABI_FREE(wk2d_d)
513 : : !$OMP END PARALLEL
514 : :
515 : : !$OMP PARALLEL DO SHARED(aft3,bef3,ind3,ic3,now3,n1,n2half1,n4,n5half1,n6,ris,trig3,work1,work2) PRIVATE(i2)
516 [ + + ]: 51723 : do i2=1,n2half1
517 : : call sg_fftz(mfac,mg,n4,n5half1,n6,n1,i2,i2,work1,work2,&
518 : 51723 : & trig3,aft3,now3,bef3,ris,ind3,ic3)
519 : : end do
520 : :
521 : : ! Transfer fft output to the original fft box
522 : :
523 : : !$OMP PARALLEL DO PRIVATE(i1,i2,i3,index) SHARED(fofg,n1,n2,n2half1,n3,work2)
524 [ + + ]: 103612 : do i3=1,n3
525 [ + + ]: 1554408 : do i2=1,n2half1
526 : 1454436 : index=n1*(i2-1+n2*(i3-1))
527 [ + + ]: 46593648 : do i1=1,n1
528 : 45039240 : fofg(1,i1+index)=work2(1,i1,i2,i3)
529 : 46493676 : fofg(2,i1+index)=work2(2,i1,i2,i3)
530 : : end do
531 : : end do
532 : : ! Complete missing values with complex conjugate
533 : : ! Inverse of ix is located at nx+2-ix , except for ix=1, for which it is 1.
534 [ + - ]: 103612 : if(n2half1>2)then
535 [ + + ]: 1362174 : do i2=2,n2+1-n2half1
536 : 1262202 : index=n1*((n2+2-i2)-1)
537 [ + + ]: 1262202 : if(i3/=1)index=index+n1*n2*((n3+2-i3)-1)
538 : 1262202 : fofg(1,1+index)= work2(1,1,i2,i3)
539 : 1262202 : fofg(2,1+index)=-work2(2,1,i2,i3)
540 [ + + ]: 39799554 : do i1=2,n1
541 : 38437380 : fofg(1,n1+2-i1+index)= work2(1,i1,i2,i3)
542 : 39699582 : fofg(2,n1+2-i1+index)=-work2(2,i1,i2,i3)
543 : : end do
544 : : end do
545 : : end if
546 : : end do
547 : :
548 : : end if ! choice of isign
549 : :
550 [ - + ]: 7692 : ABI_FREE(work1)
551 [ - + ]: 7692 : ABI_FREE(work2)
552 : :
553 : : !DBG_EXIT("COLL")
554 : :
555 : 7692 : end subroutine sg_fft_rc
556 : : !!***
557 : :
558 : : !----------------------------------------------------------------------
559 : :
560 : : !!****f* m_sgfft/sg_fftpad
561 : : !! NAME
562 : : !! sg_fftpad
563 : : !!
564 : : !! FUNCTION
565 : : !! Fast Fourier transform. This is the zero-padding version of "fft".
566 : : !!
567 : : !! INPUTS
568 : : !! fftcache=size of the cache (kB)
569 : : !! mgfft=maximum size of 1D FFTs
570 : : !! n1,n2,n3=physical dimension of the transform
571 : : !! nd1,nd2,nd3=memory dimension of arr and ftarr
572 : : !! ndat=Number of FFT transforms.
573 : : !! isign= sign of exponential in transform
574 : : !! gbound(2*mgfft+8,2)=sphere boundary info
575 : : !!
576 : : !! OUTPUT
577 : : !! ftarr(2,nd1,nd2,nd3*ndat)=working space for transform and contains output
578 : : !!
579 : : !! SIDE EFFECTS
580 : : !! arr(2,nd1,nd2,nd3*ndat)=input complex array with alternating real and imaginary
581 : : !! elements; data resides in 2*n1*n2*n3 of this array, spread out.
582 : : !! arr(2,nd1,nd2,nd3*ndat) is modified by sg_fftpx,sg_ffty,sg_fftz.
583 : : !!
584 : : !! NOTES
585 : : !! mfac sets maximum number of factors (5, 4, 3, or 2) which may be
586 : : !! contained within any n1, n2, or n3
587 : : !! mg sets the maximum 1 dimensional fft length (any one of n1, n2, or n3)
588 : : !! XG: the signification of mg is changed with respect to fft3dp !!!
589 : : !!
590 : : !! SOURCE
591 : :
592 : 669 : subroutine sg_fftpad(fftcache,mgfft,n1,n2,n3,nd1,nd2,nd3,ndat,gbound,isign,arr,ftarr)
593 : :
594 : : !Arguments ------------------------------------
595 : : !scalars
596 : : integer,intent(in) :: fftcache,mgfft,n1,n2,n3,nd1,nd2,nd3,ndat,isign
597 : : !arrays
598 : : integer,intent(in) :: gbound(2*mgfft+8,2)
599 : : real(dp),intent(inout) :: arr(2,nd1,nd2,nd3*ndat)
600 : : real(dp),intent(out) :: ftarr(2,nd1,nd2,nd3*ndat)
601 : :
602 : : !Local variables-------------------------------
603 : : !scalars
604 : : integer :: idat,start
605 : :
606 : : ! *************************************************************************
607 : :
608 [ + + ]: 1386 : do idat=1,ndat
609 : 717 : start = 1 + (idat-1)*nd3
610 : : call fftpad_one_nothreadsafe(fftcache,mgfft,nd1,nd2,nd3,n1,n2,n3,&
611 : 1386 : & arr(1,1,1,start),ftarr(1,1,1,start),real(isign, kind=dp),gbound)
612 : : end do
613 : :
614 : 669 : end subroutine sg_fftpad
615 : : !!***
616 : :
617 : : !----------------------------------------------------------------------
618 : :
619 : : !!****f* m_sgfft/fftpad_one_nothreadsafe
620 : : !! NAME
621 : : !! fftpad_one_nothreadsafe
622 : : !!
623 : : !! FUNCTION
624 : : !! Fast Fourier transform. This is the zero-padding version of "fft" for a single array.
625 : : !! This version is not thread-safe.
626 : : !!
627 : : !! INPUTS
628 : : !! fftcache=size of the cache (kB)
629 : : !! mgfft=maximum size of 1D FFTs
630 : : !! nd1,nd2,nd3=memory dimension of arr and ftarr
631 : : !! n1,n2,n3=physical dimension of the transform
632 : : !! arr(2,nd1,nd2,nd3)=input complex array with alternating real and imaginary
633 : : !! elements; data resides in 2*n1*n2*n3 of this array, spread out.
634 : : !! ris=(real(dp)) sign of exponential in transform
635 : : !! gbound(2*mgfft+8,2)=sphere boundary info
636 : : !!
637 : : !! OUTPUT
638 : : !! ftarr(2,nd1,nd2,nd3)=working space for transform and contains output
639 : : !!
640 : : !! SIDE EFFECTS
641 : : !! arr(2,nd1,nd2,nd3) is modified by sg_fftpx,sg_ffty,sg_fftz.
642 : : !!
643 : : !! NOTES
644 : : !! mfac sets maximum number of factors (5, 4, 3, or 2) which may be
645 : : !! contained within any n1, n2, or n3
646 : : !! mg sets the maximum 1 dimensional fft length (any one of n1, n2, or n3)
647 : : !! XG: the signification of mg is changed with respect to fft3dp !!!
648 : : !!
649 : : !! SOURCE
650 : :
651 : 717 : subroutine fftpad_one_nothreadsafe(fftcache,mgfft,nd1,nd2,nd3,n1,n2,n3,arr,ftarr,ris,gbound)
652 : :
653 : : !Arguments ------------------------------------
654 : : !scalars
655 : : integer,intent(in) :: fftcache,mgfft,n1,n2,n3,nd1,nd2,nd3
656 : : real(dp),intent(in) :: ris
657 : : !arrays
658 : : integer,intent(in) :: gbound(2*mgfft+8,2)
659 : : real(dp),intent(inout) :: arr(2,nd1,nd2,nd3)
660 : : real(dp),intent(out) :: ftarr(2,nd1,nd2,nd3)
661 : :
662 : : !Local variables-------------------------------
663 : : !scalars
664 : : integer,parameter :: mfac=11
665 : : integer :: g3max,g3min,i2,ic,n1i,n3i,n3p
666 : : #ifdef DEBUG_MODE
667 : : character(len=500) :: message
668 : : #endif
669 : : !arrays
670 : : integer :: aft(mfac),bef(mfac),ind(mg),now(mfac)
671 : : real(dp) :: trig(2,mg)
672 : :
673 : : ! *************************************************************************
674 : :
675 : : #ifdef DEBUG_MODE
676 : : !Check that dimension is not exceeded
677 : : if (n1>mg.or.n2>mg.or.n3>mg) then
678 : : write(message, '(a,3i10,a,i10)')&
679 : : & 'one of the dimensions n1,n2,n3=',n1,n2,n3,' exceeds the allowed dimension mg=',mg
680 : : ABI_BUG(message)
681 : : end if
682 : : #endif
683 : :
684 : 717 : g3min=gbound(3,2)
685 : 717 : g3max=gbound(4,2)
686 : :
687 : : !--------------------------------------------------------------------------
688 : :
689 [ + + ]: 717 : if (abs(ris-one)<tol12) then
690 : :
691 : : ! Handle G -> r transform (G sphere to fft box)
692 : :
693 : : ! Transform along x direction
694 : 409 : call sg_ctrig(n1,trig,aft,bef,now,ris,ic,ind,mfac,mg)
695 : :
696 : : ! Zero out the untransformed (0) data part of the work array
697 : : ! -- at every (y,z) there are 0 s to be added to the ends of
698 : : ! the x data so have to zero whole thing.
699 [ + + + + : 583355323 : ftarr(:,:,:,:)=0.0d0
+ + + + ]
700 : :
701 : : ! Note the passing of the relevant part of gbound
702 : : call sg_fftpx(fftcache,mfac,mg,mgfft,nd1,nd2,nd3,n2,n3,&
703 : 409 : & arr,ftarr,trig,aft,now,bef,ris,ind,ic,gbound(3,2))
704 : :
705 : : ! Transform along y direction in two regions of z
706 [ + + ]: 409 : if (n2/=n1)then
707 : 128 : call sg_ctrig(n2,trig,aft,bef,now,ris,ic,ind,mfac,mg)
708 : : end if
709 : :
710 : : ! First y transform: z=1..g3max+1
711 : 409 : n3p=g3max+1
712 : 409 : n1i=1 ; n3i=1
713 : : call sg_ffty(fftcache,mfac,mg,nd1,nd2,nd3,n1i,n1,n3i,n3p,ftarr,arr,&
714 : 409 : & trig,aft,now,bef,ris,ind,ic)
715 : :
716 : : ! Zero out the untransformed (0) data part of the work array
717 : : ! -- only need to zero specified ranges of z
718 [ + + + + : 295831474 : arr(:,:,:,n3p+1:g3min+n3)=0.0d0
+ + + + ]
719 : :
720 : : ! Second y transform: z=g3min+1..0 (wrapped around)
721 : 409 : n3p=-g3min
722 [ + - ]: 409 : if (n3p>0) then
723 : 409 : n3i=1+g3min+n3 ; n1i=1
724 : : call sg_ffty(fftcache,mfac,mg,nd1,nd2,nd3,n1i,n1,n3i,n3,ftarr,arr,&
725 : 409 : & trig,aft,now,bef,ris,ind,ic)
726 : : end if
727 : :
728 : : ! Transform along z direction
729 [ + + ]: 409 : if (n3/=n2) then
730 : 128 : call sg_ctrig(n3,trig,aft,bef,now,ris,ic,ind,mfac,mg)
731 : : end if
732 : :
733 : : !$OMP PARALLEL DO
734 [ + + ]: 25699 : do i2=1,n2
735 : : call sg_fftz(mfac,mg,nd1,nd2,nd3,n1,i2,i2,arr,ftarr,&
736 : 25699 : & trig,aft,now,bef,ris,ind,ic)
737 : : end do
738 : :
739 : : else
740 : :
741 : : ! *************************************************
742 : : ! Handle r -> G transform (from fft box to G sphere)
743 : :
744 : : ! Transform along z direction
745 : 308 : call sg_ctrig(n3,trig,aft,bef,now,ris,ic,ind,mfac,mg)
746 : :
747 : : !$OMP PARALLEL DO
748 [ + + ]: 24692 : do i2=1,n2
749 : : call sg_fftz(mfac,mg,nd1,nd2,nd3,n1,i2,i2,arr,ftarr,&
750 : 24692 : & trig,aft,now,bef,ris,ind,ic)
751 : : end do
752 : :
753 : : ! Transform along y direction in two regions of z
754 [ + + ]: 308 : if (n2/=n3) then
755 : 122 : call sg_ctrig(n2,trig,aft,bef,now,ris,ic,ind,mfac,mg)
756 : : end if
757 : :
758 : : ! First y transform: z=1..g3max+1
759 : 308 : n3p=g3max+1
760 : 308 : n1i=1 ; n3i=1
761 : : call sg_ffty(fftcache,mfac,mg,nd1,nd2,nd3,n1i,n1,n3i,n3p,ftarr,arr,&
762 : 308 : & trig,aft,now,bef,ris,ind,ic)
763 : :
764 : : ! Second y transform: z=g3min+1..0 (wrapped around)
765 : 308 : n3p=-g3min
766 [ + - ]: 308 : if (n3p>0) then
767 : 308 : n1i=1 ; n3i=1+g3min+n3
768 : : call sg_ffty(fftcache,mfac,mg,nd1,nd2,nd3,n1i,n1,n3i,n3,ftarr,arr,&
769 : 308 : & trig,aft,now,bef,ris,ind,ic)
770 : : end if
771 : :
772 : : ! Transform along x direction
773 [ + + ]: 308 : if (n1/=n2) then
774 : 122 : call sg_ctrig(n1,trig,aft,bef,now,ris,ic,ind,mfac,mg)
775 : : end if
776 : :
777 : : ! Zero out the untransformed (0) data part of the work array
778 : : ! -- at every (y,z) there are 0 s to be added to the ends of
779 : : ! the x data so have to zero whole thing.
780 [ + + + + : 621364664 : ftarr(:,:,:,:)=0.0d0
+ + + + ]
781 : :
782 : : ! Note the passing of the relevant part of gbound
783 : : call sg_fftpx(fftcache,mfac,mg,mgfft,nd1,nd2,nd3,n2,n3,&
784 : 308 : & arr,ftarr,trig,aft,now,bef,ris,ind,ic,gbound(3,2))
785 : :
786 : : ! Data is now ready to be extracted from fft box to sphere
787 : : end if
788 : :
789 : 717 : end subroutine fftpad_one_nothreadsafe
790 : : !!***
791 : :
792 : : !----------------------------------------------------------------------
793 : :
794 : : !!****f* m_sgfft/sg_fftpx
795 : : !! NAME
796 : : !! sg_fftpx
797 : : !!
798 : : !! FUNCTION
799 : : !! This subroutine is called by the 3-dimensional fft to conduct the
800 : : !! "x" transforms for all y and z.
801 : : !! Accomodate more optimal treatment of
802 : : !! zero padding following the method of fft3dp.
803 : : !!
804 : : !! INPUTS
805 : : !! fftcache=size of the cache (kB)
806 : : !! mfac = maximum number of factors in 1D FFTs
807 : : !! mg = maximum length of 1D FFTs
808 : : !! mgfft = effective maximum length of 1D FFTs, for dimensioning gbound
809 : : !! nd1=first dimension of (complex) arrays z and zbr (treated as real within
810 : : !! this subroutine)
811 : : !! nd2=second dimension of (complex) arrays z and zbr (treated as real within
812 : : !! this subroutine)
813 : : !! nd3=third dimension of (complex) arrays z and zbr (treated as real within
814 : : !! this subroutine)
815 : : !! n2,n3=actual length of y and z transforms
816 : : !! z(2,nd1,nd2,nd3)=INPUT array; destroyed by transformation
817 : : !! trig, aft, now, bef, ind=provided by previous call to ctrig
818 : : !! Note that in this routine (and in ctrig) the values in array trig are
819 : : !! actually cos and tan, not cos and sin. Use of tan allows advantageous
820 : : !! use of FMA on the ibm rs6000.
821 : : !! ris=sign of exponential in transform (should be 1 or -1; real)
822 : : !! ic=number of (radix) factors of x transform length (from ctrig)
823 : : !! gbound(2*mgfft+4)=sphere boundary info
824 : : !!
825 : : !! OUTPUT
826 : : !! zbr(2,nd1,nd2,nd3)=OUTPUT transformed array; no scaling applied
827 : : !!
828 : : !! SIDE EFFECTS
829 : : !!
830 : : !! NOTES
831 : : !! This routine blocks the x transforms
832 : : !! so that all transforms under consideration at one step fit within
833 : : !! the cache memory, which is crucial for optimal performance.
834 : : !! The blocking factor is set by parameter "fftcache" below, which should
835 : : !! be adjusted to be somewhat smaller (say 3/4) than the actual cache size
836 : : !! of the machine.
837 : : !!
838 : : !! TODO
839 : : !! Use latex for the equation above
840 : : !!
841 : : !! SOURCE
842 : :
843 : 32997005 : subroutine sg_fftpx(fftcache,mfac,mg,mgfft,nd1,nd2,nd3,n2,n3,&
844 : 32997005 : & z,zbr,trig,aft,now,bef,ris,ind,ic,gbound)
845 : :
846 : : !Arguments ------------------------------------
847 : : !Dimensions of aft, now, bef, ind, and trig should agree with
848 : : !those in subroutine ctrig.
849 : : !scalars
850 : : integer,intent(in) :: fftcache,ic,mfac,mg,mgfft,n2,n3,nd1,nd2,nd3
851 : : real(dp),intent(in) :: ris
852 : : !arrays
853 : : integer,intent(in) :: aft(mfac),bef(mfac),gbound(2*mgfft+4),ind(mg),now(mfac)
854 : : real(dp),intent(in) :: trig(2,mg)
855 : : real(dp),intent(inout) :: z(2,nd1,nd2,nd3)
856 : : real(dp),intent(inout) :: zbr(2,nd1,nd2,nd3) !vz_i
857 : :
858 : : !Local variables-------------------------------
859 : : !scalars
860 : : integer :: g2,g2max,g2min,g3,g3max,g3min,gg3,i,ia,ib,igb,ihalfy,indx,j
861 : : integer :: len3,lot,lowlim,ma,mb,ntb,upplim
862 : : !no_abirules
863 : : real(dp),parameter :: &
864 : : & cos2=0.3090169943749474d0,& !cos(2.d0*pi/5.d0)
865 : : & cos4=-0.8090169943749474d0,& !cos(4.d0*pi/5.d0)
866 : : & sin42=0.6180339887498948d0 !sin(4.d0*pi/5.d0)/sin(2.d0*pi/5.d0)
867 : : real(dp) :: bb,cr2,cr2s,cr3,cr3p,cr4,cr5,ct2,ct3,ct4,ct5,&
868 : : & factor,r,r1,r2,r25,r3,r34,r4,r5,s,sin2,s1,s2,s25,s3,s34,s4,s5
869 : :
870 : : ! *************************************************************************
871 : :
872 : 32997005 : g3min=gbound(1)
873 : 32997005 : g3max=gbound(2)
874 : 32997005 : igb=3
875 : 32997005 : len3=g3max-g3min+1
876 : :
877 : :
878 : : !Do x transforms in blocks of size "lot" which is set by how
879 : : !many x transform arrays (of size nd1 each) fit into the nominal
880 : : !cache size "fftcache".
881 : : !Loop over blocks in the loop below.
882 : :
883 : 32997005 : factor=0.75d0
884 : 32997005 : lot=(fftcache*factor*1000d0)/(nd1*8*2)
885 : 32997005 : if(lot.lt.1) lot=1
886 : : !Express loop over y, z in terms of separate z and y loops
887 : :
888 : : !$OMP PARALLEL DO DEFAULT(PRIVATE)&
889 : : !$OMP SHARED(aft,bef,gbound,g3max,ic,ind,len3,lot)&
890 : : !$OMP SHARED(n2,n3,nd2,now,ris,trig,z,zbr)
891 [ + + ]: 66018532 : do gg3=1,len3
892 : :
893 [ + + ]: 33021527 : if (gg3<=g3max+1) then
894 : : g3=gg3
895 : : else
896 : : ! wrap around for negative gg3
897 : 12394 : g3=gg3-len3+n3
898 : : end if
899 : :
900 : 33021527 : igb=gg3*2+1
901 : 33021527 : g2min=gbound(igb)
902 : 33021527 : g2max=gbound(igb+1)
903 : :
904 : : ! Split the y loop into positive and wrapped-around negative parts
905 : :
906 [ + + ]: 132061586 : do ihalfy=1,2
907 : :
908 : : ! Start at 1 for ihalfy=1; g2min+1+n2 for ihalfy=2
909 : 66043054 : lowlim=1+(ihalfy-1)*(g2min+n2)
910 : : ! End at g2max+1 for ihalfy=1; n2 for ihalfy=2
911 : 66043054 : upplim=g2max+1+(ihalfy-1)*(n2-g2max-1)
912 : :
913 [ + + + + ]: 165247709 : do g2=lowlim,upplim,lot
914 : :
915 : : ! Find array starting address ma and ending address mb
916 : : ! modified xg 980107
917 : : ! ma=g2+(g3-1)*nd2
918 : 66183128 : ma=g2
919 : : ! Perform "lot" transforms at a time (until out of data)
920 : : ! mb=min(g2+(lot-1),upplim)+(g3-1)*nd2
921 : 66183128 : mb=min(g2+(lot-1),upplim)
922 : :
923 : : ! -------------------------------------------------------------------------
924 : : !
925 : : ! Direct transformation
926 : :
927 : : ! Run over all factors except the last (to ic-1), performing
928 : : ! x transform
929 : :
930 : : ! Note: fortran should skip this loop if ic=1; beware "onetrip"
931 : : ! compiler option which forces each loop at least once
932 : :
933 [ + + ]: 154027544 : do i=1,ic-1
934 : 87844416 : ntb=now(i)*bef(i)
935 : :
936 : : ! Treat radix 4
937 [ + + ]: 154027544 : if (now(i)==4) then
938 : 84693424 : ia=0
939 : :
940 : : ! First step of factor 4
941 [ + + ]: 84693424 : do ib=1,bef(i)
942 [ + + ]: 371005788 : do j=ma,mb
943 : 286312364 : r4=z(1,ia*ntb+3*bef(i)+ib,j,g3)
944 : 286312364 : s4=z(2,ia*ntb+3*bef(i)+ib,j,g3)
945 : 286312364 : r3=z(1,ia*ntb+2*bef(i)+ib,j,g3)
946 : 286312364 : s3=z(2,ia*ntb+2*bef(i)+ib,j,g3)
947 : 286312364 : r2=z(1,ia*ntb+bef(i)+ib,j,g3)
948 : 286312364 : s2=z(2,ia*ntb+bef(i)+ib,j,g3)
949 : 286312364 : r1=z(1,ia*ntb+ib,j,g3)
950 : 286312364 : s1=z(2,ia*ntb+ib,j,g3)
951 : :
952 : 286312364 : r=r1 + r3
953 : 286312364 : s=r2 + r4
954 : 286312364 : z(1,ia*ntb+ib,j,g3) = r + s
955 : 286312364 : z(1,ia*ntb+2*bef(i)+ib,j,g3) = r - s
956 : 286312364 : r=r1 - r3
957 : 286312364 : s=s2 - s4
958 : 286312364 : z(1,ia*ntb+bef(i)+ib,j,g3) = r - s*ris
959 : 286312364 : z(1,ia*ntb+3*bef(i)+ib,j,g3) = r + s*ris
960 : 286312364 : r=s1 + s3
961 : 286312364 : s=s2 + s4
962 : 286312364 : z(2,ia*ntb+ib,j,g3) = r + s
963 : 286312364 : z(2,ia*ntb+2*bef(i)+ib,j,g3) = r - s
964 : 286312364 : r=s1 - s3
965 : 286312364 : s=r2 - r4
966 : 286312364 : z(2,ia*ntb+bef(i)+ib,j,g3) = r + s*ris
967 : 355200440 : z(2,ia*ntb+3*bef(i)+ib,j,g3) = r - s*ris
968 : : end do
969 : : end do
970 : :
971 : : ! Second step of factor 4
972 [ + - ]: 15805348 : do ia=1,aft(i)-1
973 : 0 : indx=ind(ia*4*bef(i)+1)-1
974 : 0 : indx=indx*bef(i)
975 : 0 : cr2=trig(1,indx)
976 : 0 : ct2=trig(2,indx)
977 : 0 : cr3=trig(1,2*indx)
978 : 0 : ct3=trig(2,2*indx)
979 : 0 : cr4=trig(1,3*indx)
980 : 0 : ct4=trig(2,3*indx)
981 : 0 : cr4=cr4/cr2
982 : 0 : cr2s=cr2*ris
983 [ - - ]: 15805348 : do ib=1,bef(i)
984 [ # # ]: 0 : do j=ma,mb
985 : : r4=z(1,ia*ntb+3*bef(i)+ib,j,g3) - &
986 : 0 : & z(2,ia*ntb+3*bef(i)+ib,j,g3)*ct4
987 : : s4=z(1,ia*ntb+3*bef(i)+ib,j,g3)*ct4 + &
988 : 0 : & z(2,ia*ntb+3*bef(i)+ib,j,g3)
989 : : r3=z(1,ia*ntb+2*bef(i)+ib,j,g3) - &
990 : 0 : & z(2,ia*ntb+2*bef(i)+ib,j,g3)*ct3
991 : : s3=z(1,ia*ntb+2*bef(i)+ib,j,g3)*ct3 + &
992 : 0 : & z(2,ia*ntb+2*bef(i)+ib,j,g3)
993 : : r2=z(1,ia*ntb+bef(i)+ib,j,g3) - &
994 : 0 : & z(2,ia*ntb+bef(i)+ib,j,g3)*ct2
995 : : s2=z(1,ia*ntb+bef(i)+ib,j,g3)*ct2 + &
996 : 0 : & z(2,ia*ntb+bef(i)+ib,j,g3)
997 : 0 : r1=z(1,ia*ntb+ib,j,g3)
998 : 0 : s1=z(2,ia*ntb+ib,j,g3)
999 : :
1000 : 0 : r=r1 + r3*cr3
1001 : 0 : s=r2 + r4*cr4
1002 : 0 : z(1,ia*ntb+ib,j,g3) = r + s*cr2
1003 : 0 : z(1,ia*ntb+2*bef(i)+ib,j,g3) = r - s*cr2
1004 : 0 : r=r1 - r3*cr3
1005 : 0 : s=s2 - s4*cr4
1006 : 0 : z(1,ia*ntb+bef(i)+ib,j,g3) = r - s*cr2s
1007 : 0 : z(1,ia*ntb+3*bef(i)+ib,j,g3) = r + s*cr2s
1008 : 0 : r=s1 + s3*cr3
1009 : 0 : s=s2 + s4*cr4
1010 : 0 : z(2,ia*ntb+ib,j,g3) = r + s*cr2
1011 : 0 : z(2,ia*ntb+2*bef(i)+ib,j,g3) = r - s*cr2
1012 : 0 : r=s1 - s3*cr3
1013 : 0 : s=r2 - r4*cr4
1014 : 0 : z(2,ia*ntb+bef(i)+ib,j,g3) = r + s*cr2s
1015 : 0 : z(2,ia*ntb+3*bef(i)+ib,j,g3) = r - s*cr2s
1016 : : end do
1017 : : end do
1018 : : end do
1019 : :
1020 : : ! Treat radix 2
1021 [ - + ]: 72039068 : else if (now(i)==2) then
1022 : 0 : ia=0
1023 : :
1024 : : ! First step of factor 2
1025 [ # # ]: 0 : do ib=1,bef(i)
1026 [ # # ]: 0 : do j=ma,mb
1027 : 0 : r1=z(1,ia*ntb+ib,j,g3)
1028 : 0 : s1=z(2,ia*ntb+ib,j,g3)
1029 : 0 : r2=z(1,ia*ntb+bef(i)+ib,j,g3)
1030 : 0 : s2=z(2,ia*ntb+bef(i)+ib,j,g3)
1031 : 0 : z(1,ia*ntb+ib,j,g3) = r2 + r1
1032 : 0 : z(2,ia*ntb+ib,j,g3) = s2 + s1
1033 : 0 : z(1,ia*ntb+bef(i)+ib,j,g3) = -r2 + r1
1034 : 0 : z(2,ia*ntb+bef(i)+ib,j,g3) = -s2 + s1
1035 : : end do
1036 : : end do
1037 : :
1038 : : ! Second step of radix 2
1039 [ # # ]: 0 : do ia=1,aft(i)-1
1040 : 0 : indx=ind(ia*2*bef(i)+1)-1
1041 : 0 : indx=indx*bef(i)
1042 : 0 : cr2=trig(1,indx)
1043 : 0 : ct2=trig(2,indx)
1044 [ # # ]: 0 : do ib=1,bef(i)
1045 [ # # ]: 0 : do j=ma,mb
1046 : 0 : r1=z(1,ia*ntb+ib,j,g3)
1047 : 0 : s1=z(2,ia*ntb+ib,j,g3)
1048 : : r2=z(1,ia*ntb+bef(i)+ib,j,g3) - &
1049 : 0 : & z(2,ia*ntb+bef(i)+ib,j,g3)*ct2
1050 : : s2=z(1,ia*ntb+bef(i)+ib,j,g3)*ct2 + &
1051 : 0 : & z(2,ia*ntb+bef(i)+ib,j,g3)
1052 : 0 : z(1,ia*ntb+ib,j,g3) = r2*cr2 + r1
1053 : 0 : z(2,ia*ntb+ib,j,g3) = s2*cr2 + s1
1054 : 0 : z(1,ia*ntb+bef(i)+ib,j,g3) = -r2*cr2 + r1
1055 : 0 : z(2,ia*ntb+bef(i)+ib,j,g3) = -s2*cr2 + s1
1056 : : end do
1057 : : end do
1058 : : end do
1059 : :
1060 : : ! Treat radix 3
1061 [ + + ]: 72039068 : else if (now(i)==3) then
1062 : : ! .5d0*sqrt(3.d0)=0.8660254037844387d0
1063 : 37964184 : ia=0
1064 : 37964184 : bb=ris*0.8660254037844387d0
1065 : :
1066 : : ! First step of radix 3
1067 [ + + ]: 179939656 : do ib=1,bef(i)
1068 [ + + ]: 771422960 : do j=ma,mb
1069 : 591483304 : r1=z(1,ia*ntb+ib,j,g3)
1070 : 591483304 : s1=z(2,ia*ntb+ib,j,g3)
1071 : 591483304 : r2=z(1,ia*ntb+bef(i)+ib,j,g3)
1072 : 591483304 : s2=z(2,ia*ntb+bef(i)+ib,j,g3)
1073 : 591483304 : r3=z(1,ia*ntb+2*bef(i)+ib,j,g3)
1074 : 591483304 : s3=z(2,ia*ntb+2*bef(i)+ib,j,g3)
1075 : 591483304 : r=r2 + r3
1076 : 591483304 : s=s2 + s3
1077 : 591483304 : z(1,ia*ntb+ib,j,g3) = r + r1
1078 : 591483304 : z(2,ia*ntb+ib,j,g3) = s + s1
1079 : 591483304 : r1=r1 - r*.5d0
1080 : 591483304 : s1=s1 - s*.5d0
1081 : 591483304 : r2=r2-r3
1082 : 591483304 : s2=s2-s3
1083 : 591483304 : z(1,ia*ntb+bef(i)+ib,j,g3) = r1 - s2*bb
1084 : 591483304 : z(2,ia*ntb+bef(i)+ib,j,g3) = s1 + r2*bb
1085 : 591483304 : z(1,ia*ntb+2*bef(i)+ib,j,g3) = r1 + s2*bb
1086 : 733458776 : z(2,ia*ntb+2*bef(i)+ib,j,g3) = s1 - r2*bb
1087 : : end do
1088 : : end do
1089 : :
1090 : : ! Second step of radix 3
1091 [ + + ]: 85993824 : do ia=1,aft(i)-1
1092 : 48029640 : indx=ind(ia*3*bef(i)+1)-1
1093 : 48029640 : indx=indx*bef(i)
1094 : 48029640 : cr2=trig(1,indx)
1095 : 48029640 : ct2=trig(2,indx)
1096 : 48029640 : cr3=trig(1,2*indx)
1097 : 48029640 : ct3=trig(2,2*indx)
1098 : 48029640 : cr2=cr2/cr3
1099 : 48029640 : cr3p=.5d0*cr3
1100 : 48029640 : bb=ris*cr3*0.8660254037844387d0
1101 [ + + ]: 182147824 : do ib=1,bef(i)
1102 [ + + ]: 572011156 : do j=ma,mb
1103 : 427827516 : r1=z(1,ia*ntb+ib,j,g3)
1104 : 427827516 : s1=z(2,ia*ntb+ib,j,g3)
1105 : : r2=z(1,ia*ntb+bef(i)+ib,j,g3) - &
1106 : 427827516 : & z(2,ia*ntb+bef(i)+ib,j,g3)*ct2
1107 : : s2=z(1,ia*ntb+bef(i)+ib,j,g3)*ct2 + &
1108 : 427827516 : & z(2,ia*ntb+bef(i)+ib,j,g3)
1109 : : r3=z(1,ia*ntb+2*bef(i)+ib,j,g3) - &
1110 : 427827516 : & z(2,ia*ntb+2*bef(i)+ib,j,g3)*ct3
1111 : : s3=z(1,ia*ntb+2*bef(i)+ib,j,g3)*ct3 + &
1112 : 427827516 : & z(2,ia*ntb+2*bef(i)+ib,j,g3)
1113 : 427827516 : r=cr2*r2 + r3
1114 : 427827516 : s=cr2*s2 + s3
1115 : 427827516 : z(1,ia*ntb+ib,j,g3) = r*cr3 + r1
1116 : 427827516 : z(2,ia*ntb+ib,j,g3) = s*cr3 + s1
1117 : 427827516 : r1=r1 - r*cr3p
1118 : 427827516 : s1=s1 - s*cr3p
1119 : 427827516 : r2=cr2*r2-r3
1120 : 427827516 : s2=cr2*s2-s3
1121 : 427827516 : z(1,ia*ntb+bef(i)+ib,j,g3) = r1 - s2*bb
1122 : 427827516 : z(2,ia*ntb+bef(i)+ib,j,g3) = s1 + r2*bb
1123 : 427827516 : z(1,ia*ntb+2*bef(i)+ib,j,g3) = r1 + s2*bb
1124 : 523981516 : z(2,ia*ntb+2*bef(i)+ib,j,g3) = s1 - r2*bb
1125 : : end do
1126 : : end do
1127 : : end do
1128 : :
1129 : : ! Treat radix 5
1130 [ + - ]: 34074884 : else if (now(i)==5) then
1131 : : ! sin(2.d0*pi/5.d0)
1132 : 34074884 : sin2=ris*0.9510565162951536d0
1133 : 34074884 : ia=0
1134 : :
1135 : : ! First step of radix 5
1136 [ + + ]: 142541916 : do ib=1,bef(i)
1137 [ + + ]: 492315228 : do j=ma,mb
1138 : 349773312 : r1=z(1,ia*ntb+ib,j,g3)
1139 : 349773312 : s1=z(2,ia*ntb+ib,j,g3)
1140 : 349773312 : r2=z(1,ia*ntb+bef(i)+ib,j,g3)
1141 : 349773312 : s2=z(2,ia*ntb+bef(i)+ib,j,g3)
1142 : 349773312 : r3=z(1,ia*ntb+2*bef(i)+ib,j,g3)
1143 : 349773312 : s3=z(2,ia*ntb+2*bef(i)+ib,j,g3)
1144 : 349773312 : r4=z(1,ia*ntb+3*bef(i)+ib,j,g3)
1145 : 349773312 : s4=z(2,ia*ntb+3*bef(i)+ib,j,g3)
1146 : 349773312 : r5=z(1,ia*ntb+4*bef(i)+ib,j,g3)
1147 : 349773312 : s5=z(2,ia*ntb+4*bef(i)+ib,j,g3)
1148 : 349773312 : r25 = r2 + r5
1149 : 349773312 : r34 = r3 + r4
1150 : 349773312 : s25 = s2 - s5
1151 : 349773312 : s34 = s3 - s4
1152 : 349773312 : z(1,ia*ntb+ib,j,g3) = r1 + r25 + r34
1153 : 349773312 : r = r1 + cos2*r25 + cos4*r34
1154 : 349773312 : s = s25 + sin42*s34
1155 : 349773312 : z(1,ia*ntb+bef(i)+ib,j,g3) = r - sin2*s
1156 : 349773312 : z(1,ia*ntb+4*bef(i)+ib,j,g3) = r + sin2*s
1157 : 349773312 : r = r1 + cos4*r25 + cos2*r34
1158 : 349773312 : s = sin42*s25 - s34
1159 : 349773312 : z(1,ia*ntb+2*bef(i)+ib,j,g3) = r - sin2*s
1160 : 349773312 : z(1,ia*ntb+3*bef(i)+ib,j,g3) = r + sin2*s
1161 : 349773312 : r25 = r2 - r5
1162 : 349773312 : r34 = r3 - r4
1163 : 349773312 : s25 = s2 + s5
1164 : 349773312 : s34 = s3 + s4
1165 : 349773312 : z(2,ia*ntb+ib,j,g3) = s1 + s25 + s34
1166 : 349773312 : r = s1 + cos2*s25 + cos4*s34
1167 : 349773312 : s = r25 + sin42*r34
1168 : 349773312 : z(2,ia*ntb+bef(i)+ib,j,g3) = r + sin2*s
1169 : 349773312 : z(2,ia*ntb+4*bef(i)+ib,j,g3) = r - sin2*s
1170 : 349773312 : r = s1 + cos4*s25 + cos2*s34
1171 : 349773312 : s = sin42*r25 - r34
1172 : 349773312 : z(2,ia*ntb+2*bef(i)+ib,j,g3) = r + sin2*s
1173 : 458240344 : z(2,ia*ntb+3*bef(i)+ib,j,g3) = r - sin2*s
1174 : : end do
1175 : : end do
1176 : :
1177 : : ! Second step of radix 5
1178 [ + + ]: 34886724 : do ia=1,aft(i)-1
1179 : 811840 : indx=ind(ia*5*bef(i)+1)-1
1180 : 811840 : indx=indx*bef(i)
1181 : 811840 : cr2=trig(1,indx)
1182 : 811840 : ct2=trig(2,indx)
1183 : 811840 : cr3=trig(1,2*indx)
1184 : 811840 : ct3=trig(2,2*indx)
1185 : 811840 : cr4=trig(1,3*indx)
1186 : 811840 : ct4=trig(2,3*indx)
1187 : 811840 : cr5=trig(1,4*indx)
1188 : 811840 : ct5=trig(2,4*indx)
1189 [ + + ]: 37999684 : do ib=1,bef(i)
1190 [ + + ]: 23240848 : do j=ma,mb
1191 : 19316048 : r1=z(1,ia*ntb+ib,j,g3)
1192 : 19316048 : s1=z(2,ia*ntb+ib,j,g3)
1193 : : r2=cr2*(z(1,ia*ntb+bef(i)+ib,j,g3) - &
1194 : 19316048 : & z(2,ia*ntb+bef(i)+ib,j,g3)*ct2)
1195 : : s2=cr2*(z(1,ia*ntb+bef(i)+ib,j,g3)*ct2 + &
1196 : 19316048 : & z(2,ia*ntb+bef(i)+ib,j,g3))
1197 : : r3=cr3*(z(1,ia*ntb+2*bef(i)+ib,j,g3) - &
1198 : 19316048 : & z(2,ia*ntb+2*bef(i)+ib,j,g3)*ct3)
1199 : : s3=cr3*(z(1,ia*ntb+2*bef(i)+ib,j,g3)*ct3 + &
1200 : 19316048 : & z(2,ia*ntb+2*bef(i)+ib,j,g3))
1201 : : r4=z(1,ia*ntb+3*bef(i)+ib,j,g3) - &
1202 : 19316048 : & z(2,ia*ntb+3*bef(i)+ib,j,g3)*ct4
1203 : : s4=z(1,ia*ntb+3*bef(i)+ib,j,g3)*ct4 + &
1204 : 19316048 : & z(2,ia*ntb+3*bef(i)+ib,j,g3)
1205 : : r5=z(1,ia*ntb+4*bef(i)+ib,j,g3) - &
1206 : 19316048 : & z(2,ia*ntb+4*bef(i)+ib,j,g3)*ct5
1207 : : s5=z(1,ia*ntb+4*bef(i)+ib,j,g3)*ct5 + &
1208 : 19316048 : & z(2,ia*ntb+4*bef(i)+ib,j,g3)
1209 : 19316048 : r25 = r2 + r5*cr5
1210 : 19316048 : r34 = r3 + r4*cr4
1211 : 19316048 : s25 = s2 - s5*cr5
1212 : 19316048 : s34 = s3 - s4*cr4
1213 : 19316048 : z(1,ia*ntb+ib,j,g3) = r1 + r25 + r34
1214 : 19316048 : r = r1 + cos2*r25 + cos4*r34
1215 : 19316048 : s = s25 + sin42*s34
1216 : 19316048 : z(1,ia*ntb+bef(i)+ib,j,g3) = r - sin2*s
1217 : 19316048 : z(1,ia*ntb+4*bef(i)+ib,j,g3) = r + sin2*s
1218 : 19316048 : r = r1 + cos4*r25 + cos2*r34
1219 : 19316048 : s = sin42*s25 - s34
1220 : 19316048 : z(1,ia*ntb+2*bef(i)+ib,j,g3) = r - sin2*s
1221 : 19316048 : z(1,ia*ntb+3*bef(i)+ib,j,g3) = r + sin2*s
1222 : 19316048 : r25 = r2 - r5*cr5
1223 : 19316048 : r34 = r3 - r4*cr4
1224 : 19316048 : s25 = s2 + s5*cr5
1225 : 19316048 : s34 = s3 + s4*cr4
1226 : 19316048 : z(2,ia*ntb+ib,j,g3) = s1 + s25 + s34
1227 : 19316048 : r = s1 + cos2*s25 + cos4*s34
1228 : 19316048 : s = r25 + sin42*r34
1229 : 19316048 : z(2,ia*ntb+bef(i)+ib,j,g3) = r + sin2*s
1230 : 19316048 : z(2,ia*ntb+4*bef(i)+ib,j,g3) = r - sin2*s
1231 : 19316048 : r = s1 + cos4*s25 + cos2*s34
1232 : 19316048 : s = sin42*r25 - r34
1233 : 19316048 : z(2,ia*ntb+2*bef(i)+ib,j,g3) = r + sin2*s
1234 : 22429008 : z(2,ia*ntb+3*bef(i)+ib,j,g3) = r - sin2*s
1235 : : end do
1236 : : end do
1237 : : end do
1238 : :
1239 : : else
1240 : : ! All radices treated
1241 : 0 : ABI_BUG('called with factors other than 2, 3, and 5')
1242 : : end if
1243 : :
1244 : : end do ! End of direct transformation (loop over ic)
1245 : :
1246 : : ! -----------------------------------------------------------------
1247 : :
1248 : : ! Bitreversal
1249 : : ! Perform bit reversal on last factor of transformation
1250 : :
1251 : : ! Treat radix 4
1252 [ + + ]: 132226182 : if (now(ic)==4) then
1253 : 46815864 : ia=0
1254 : :
1255 : : ! First step of radix 4
1256 [ + + ]: 46815864 : do j=ma,mb
1257 : 37294432 : r4=z(1,ia*4+4,j,g3)
1258 : 37294432 : s4=z(2,ia*4+4,j,g3)
1259 : 37294432 : r3=z(1,ia*4+3,j,g3)
1260 : 37294432 : s3=z(2,ia*4+3,j,g3)
1261 : 37294432 : r2=z(1,ia*4+2,j,g3)
1262 : 37294432 : s2=z(2,ia*4+2,j,g3)
1263 : 37294432 : r1=z(1,ia*4+1,j,g3)
1264 : 37294432 : s1=z(2,ia*4+1,j,g3)
1265 : :
1266 : 37294432 : r=r1 + r3
1267 : 37294432 : s=r2 + r4
1268 : 37294432 : zbr(1,ind(ia*4+1),j,g3) = r + s
1269 : 37294432 : zbr(1,ind(ia*4+3),j,g3) = r - s
1270 : 37294432 : r=r1 - r3
1271 : 37294432 : s=s2 - s4
1272 : 37294432 : zbr(1,ind(ia*4+2),j,g3) = r - s*ris
1273 : 37294432 : zbr(1,ind(ia*4+4),j,g3) = r + s*ris
1274 : 37294432 : r=s1 + s3
1275 : 37294432 : s=s2 + s4
1276 : 37294432 : zbr(2,ind(ia*4+1),j,g3) = r + s
1277 : 37294432 : zbr(2,ind(ia*4+3),j,g3) = r - s
1278 : 37294432 : r=s1 - s3
1279 : 37294432 : s=r2 - r4
1280 : 37294432 : zbr(2,ind(ia*4+2),j,g3) = r + s*ris
1281 : 46815864 : zbr(2,ind(ia*4+4),j,g3) = r - s*ris
1282 : : end do
1283 : :
1284 : : ! Second step of radix 4
1285 [ + + ]: 44075808 : do ia=1,aft(ic)-1
1286 : 34554376 : indx=ind(ia*4+1)-1
1287 : 34554376 : cr2=trig(1,indx)
1288 : 34554376 : ct2=trig(2,indx)
1289 : 34554376 : cr3=trig(1,2*indx)
1290 : 34554376 : ct3=trig(2,2*indx)
1291 : 34554376 : cr4=trig(1,3*indx)
1292 : 34554376 : ct4=trig(2,3*indx)
1293 : 34554376 : cr4=cr4/cr2
1294 : 34554376 : cr2s=cr2*ris
1295 [ + + ]: 188750796 : do j=ma,mb
1296 : 144674988 : r4=z(1,ia*4+4,j,g3) - z(2,ia*4+4,j,g3)*ct4
1297 : 144674988 : s4=z(1,ia*4+4,j,g3)*ct4 + z(2,ia*4+4,j,g3)
1298 : 144674988 : r3=z(1,ia*4+3,j,g3) - z(2,ia*4+3,j,g3)*ct3
1299 : 144674988 : s3=z(1,ia*4+3,j,g3)*ct3 + z(2,ia*4+3,j,g3)
1300 : 144674988 : r2=z(1,ia*4+2,j,g3) - z(2,ia*4+2,j,g3)*ct2
1301 : 144674988 : s2=z(1,ia*4+2,j,g3)*ct2 + z(2,ia*4+2,j,g3)
1302 : 144674988 : r1=z(1,ia*4+1,j,g3)
1303 : 144674988 : s1=z(2,ia*4+1,j,g3)
1304 : :
1305 : 144674988 : r=r1 + r3*cr3
1306 : 144674988 : s=r2 + r4*cr4
1307 : 144674988 : zbr(1,ind(ia*4+1),j,g3) = r + s*cr2
1308 : 144674988 : zbr(1,ind(ia*4+3),j,g3) = r - s*cr2
1309 : 144674988 : r=r1 - r3*cr3
1310 : 144674988 : s=s2 - s4*cr4
1311 : 144674988 : zbr(1,ind(ia*4+2),j,g3) = r - s*cr2s
1312 : 144674988 : zbr(1,ind(ia*4+4),j,g3) = r + s*cr2s
1313 : 144674988 : r=s1 + s3*cr3
1314 : 144674988 : s=s2 + s4*cr4
1315 : 144674988 : zbr(2,ind(ia*4+1),j,g3) = r + s*cr2
1316 : 144674988 : zbr(2,ind(ia*4+3),j,g3) = r - s*cr2
1317 : 144674988 : r=s1 - s3*cr3
1318 : 144674988 : s=r2 - r4*cr4
1319 : 144674988 : zbr(2,ind(ia*4+2),j,g3) = r + s*cr2s
1320 : 179229364 : zbr(2,ind(ia*4+4),j,g3) = r - s*cr2s
1321 : : end do
1322 : : end do
1323 : :
1324 : : ! Treat radix 2
1325 [ + + ]: 56661696 : else if (now(ic)==2) then
1326 : :
1327 : 114741019 : ia=0
1328 : :
1329 : : ! First step of radix 2
1330 [ + + ]: 114741019 : do j=ma,mb
1331 : 93288575 : r1=z(1,ia*2+1,j,g3)
1332 : 93288575 : s1=z(2,ia*2+1,j,g3)
1333 : 93288575 : r2=z(1,ia*2+2,j,g3)
1334 : 93288575 : s2=z(2,ia*2+2,j,g3)
1335 : 93288575 : zbr(1,ind(ia*2+1),j,g3) = r2 + r1
1336 : 93288575 : zbr(2,ind(ia*2+1),j,g3) = s2 + s1
1337 : 93288575 : zbr(1,ind(ia*2+2),j,g3) = -r2 + r1
1338 : 114741019 : zbr(2,ind(ia*2+2),j,g3) = -s2 + s1
1339 : : end do
1340 : :
1341 : : ! Second step of radix 2
1342 [ + + ]: 208375284 : do ia=1,aft(ic)-1
1343 : 186922840 : indx=ind(ia*2+1)-1
1344 : 186922840 : cr2=trig(1,indx)
1345 : 186922840 : ct2=trig(2,indx)
1346 [ + + ]: 1035282544 : do j=ma,mb
1347 : 826907260 : r1=z(1,ia*2+1,j,g3)
1348 : 826907260 : s1=z(2,ia*2+1,j,g3)
1349 : 826907260 : r2=z(1,ia*2+2,j,g3) - z(2,ia*2+2,j,g3)*ct2
1350 : 826907260 : s2=z(1,ia*2+2,j,g3)*ct2 + z(2,ia*2+2,j,g3)
1351 : 826907260 : zbr(1,ind(ia*2+1),j,g3) = r2*cr2 + r1
1352 : 826907260 : zbr(2,ind(ia*2+1),j,g3) = s2*cr2 + s1
1353 : 826907260 : zbr(1,ind(ia*2+2),j,g3) = -r2*cr2 + r1
1354 : 1013830100 : zbr(2,ind(ia*2+2),j,g3) = -s2*cr2 + s1
1355 : : end do
1356 : : end do
1357 : :
1358 : : ! Treat radix 3
1359 [ + - ]: 35209252 : else if (now(ic)==3) then
1360 : : ! radix 3
1361 : : ! .5d0*sqrt(3.d0)=0.8660254037844387d0
1362 : 35209252 : ia=0
1363 : 35209252 : bb=ris*0.8660254037844387d0
1364 : :
1365 : : ! First step of radix 3
1366 [ + + ]: 137620102 : do j=ma,mb
1367 : 102410850 : r1=z(1,ia*3+1,j,g3)
1368 : 102410850 : s1=z(2,ia*3+1,j,g3)
1369 : 102410850 : r2=z(1,ia*3+2,j,g3)
1370 : 102410850 : s2=z(2,ia*3+2,j,g3)
1371 : 102410850 : r3=z(1,ia*3+3,j,g3)
1372 : 102410850 : s3=z(2,ia*3+3,j,g3)
1373 : 102410850 : r=r2 + r3
1374 : 102410850 : s=s2 + s3
1375 : 102410850 : zbr(1,ind(ia*3+1),j,g3) = r + r1
1376 : 102410850 : zbr(2,ind(ia*3+1),j,g3) = s + s1
1377 : 102410850 : r1=r1 - r*.5d0
1378 : 102410850 : s1=s1 - s*.5d0
1379 : 102410850 : r2=r2-r3
1380 : 102410850 : s2=s2-s3
1381 : 102410850 : zbr(1,ind(ia*3+2),j,g3) = r1 - s2*bb
1382 : 102410850 : zbr(2,ind(ia*3+2),j,g3) = s1 + r2*bb
1383 : 102410850 : zbr(1,ind(ia*3+3),j,g3) = r1 + s2*bb
1384 : 137620102 : zbr(2,ind(ia*3+3),j,g3) = s1 - r2*bb
1385 : : end do
1386 : :
1387 [ + + ]: 172682624 : do ia=1,aft(ic)-1
1388 : 137473372 : indx=ind(ia*3+1)-1
1389 : 137473372 : cr2=trig(1,indx)
1390 : 137473372 : ct2=trig(2,indx)
1391 : 137473372 : cr3=trig(1,2*indx)
1392 : 137473372 : ct3=trig(2,2*indx)
1393 : 137473372 : cr2=cr2/cr3
1394 : 137473372 : cr3p=.5d0*cr3
1395 : 137473372 : bb=ris*cr3*0.8660254037844387d0
1396 [ + + ]: 575510116 : do j=ma,mb
1397 : 402827492 : r1=z(1,ia*3+1,j,g3)
1398 : 402827492 : s1=z(2,ia*3+1,j,g3)
1399 : 402827492 : r2=z(1,ia*3+2,j,g3) - z(2,ia*3+2,j,g3)*ct2
1400 : 402827492 : s2=z(1,ia*3+2,j,g3)*ct2 + z(2,ia*3+2,j,g3)
1401 : 402827492 : r3=z(1,ia*3+3,j,g3) - z(2,ia*3+3,j,g3)*ct3
1402 : 402827492 : s3=z(1,ia*3+3,j,g3)*ct3 + z(2,ia*3+3,j,g3)
1403 : 402827492 : r=cr2*r2 + r3
1404 : 402827492 : s=cr2*s2 + s3
1405 : 402827492 : zbr(1,ind(ia*3+1),j,g3) = r*cr3 + r1
1406 : 402827492 : zbr(2,ind(ia*3+1),j,g3) = s*cr3 + s1
1407 : 402827492 : r1=r1 - r*cr3p
1408 : 402827492 : s1=s1 - s*cr3p
1409 : 402827492 : r2=cr2*r2-r3
1410 : 402827492 : s2=cr2*s2-s3
1411 : 402827492 : zbr(1,ind(ia*3+2),j,g3) = r1 - s2*bb
1412 : 402827492 : zbr(2,ind(ia*3+2),j,g3) = s1 + r2*bb
1413 : 402827492 : zbr(1,ind(ia*3+3),j,g3) = r1 + s2*bb
1414 : 540300864 : zbr(2,ind(ia*3+3),j,g3) = s1 - r2*bb
1415 : : end do
1416 : : end do
1417 : :
1418 : : ! Treat radix 5
1419 [ # # ]: 0 : else if (now(ic)==5) then
1420 : : ! radix 5
1421 : : ! sin(2.d0*pi/5.d0)
1422 : 0 : sin2=ris*0.9510565162951536d0
1423 : 0 : ia=0
1424 : :
1425 : : ! First step of radix 5
1426 [ # # ]: 0 : do j=ma,mb
1427 : 0 : r1=z(1,ia*5+1,j,g3)
1428 : 0 : s1=z(2,ia*5+1,j,g3)
1429 : 0 : r2=z(1,ia*5+2,j,g3)
1430 : 0 : s2=z(2,ia*5+2,j,g3)
1431 : 0 : r3=z(1,ia*5+3,j,g3)
1432 : 0 : s3=z(2,ia*5+3,j,g3)
1433 : 0 : r4=z(1,ia*5+4,j,g3)
1434 : 0 : s4=z(2,ia*5+4,j,g3)
1435 : 0 : r5=z(1,ia*5+5,j,g3)
1436 : 0 : s5=z(2,ia*5+5,j,g3)
1437 : 0 : r25 = r2 + r5
1438 : 0 : r34 = r3 + r4
1439 : 0 : s25 = s2 - s5
1440 : 0 : s34 = s3 - s4
1441 : 0 : zbr(1,ind(ia*5+1),j,g3) = r1 + r25 + r34
1442 : 0 : r = r1 + cos2*r25 + cos4*r34
1443 : 0 : s = s25 + sin42*s34
1444 : 0 : zbr(1,ind(ia*5+2),j,g3) = r - sin2*s
1445 : 0 : zbr(1,ind(ia*5+5),j,g3) = r + sin2*s
1446 : 0 : r = r1 + cos4*r25 + cos2*r34
1447 : 0 : s = sin42*s25 - s34
1448 : 0 : zbr(1,ind(ia*5+3),j,g3) = r - sin2*s
1449 : 0 : zbr(1,ind(ia*5+4),j,g3) = r + sin2*s
1450 : 0 : r25 = r2 - r5
1451 : 0 : r34 = r3 - r4
1452 : 0 : s25 = s2 + s5
1453 : 0 : s34 = s3 + s4
1454 : 0 : zbr(2,ind(ia*5+1),j,g3) = s1 + s25 + s34
1455 : 0 : r = s1 + cos2*s25 + cos4*s34
1456 : 0 : s = r25 + sin42*r34
1457 : 0 : zbr(2,ind(ia*5+2),j,g3) = r + sin2*s
1458 : 0 : zbr(2,ind(ia*5+5),j,g3) = r - sin2*s
1459 : 0 : r = s1 + cos4*s25 + cos2*s34
1460 : 0 : s = sin42*r25 - r34
1461 : 0 : zbr(2,ind(ia*5+3),j,g3) = r + sin2*s
1462 : 0 : zbr(2,ind(ia*5+4),j,g3) = r - sin2*s
1463 : : end do
1464 : :
1465 : : ! Second step of radix 5
1466 [ # # ]: 0 : do ia=1,aft(ic)-1
1467 : 0 : indx=ind(ia*5+1)-1
1468 : 0 : cr2=trig(1,indx)
1469 : 0 : ct2=trig(2,indx)
1470 : 0 : cr3=trig(1,2*indx)
1471 : 0 : ct3=trig(2,2*indx)
1472 : 0 : cr4=trig(1,3*indx)
1473 : 0 : ct4=trig(2,3*indx)
1474 : 0 : cr5=trig(1,4*indx)
1475 : 0 : ct5=trig(2,4*indx)
1476 [ # # ]: 0 : do j=ma,mb
1477 : 0 : r1=z(1,ia*5+1,j,g3)
1478 : 0 : s1=z(2,ia*5+1,j,g3)
1479 : 0 : r2=cr2*(z(1,ia*5+2,j,g3) - z(2,ia*5+2,j,g3)*ct2)
1480 : 0 : s2=cr2*(z(1,ia*5+2,j,g3)*ct2 + z(2,ia*5+2,j,g3))
1481 : 0 : r3=cr3*(z(1,ia*5+3,j,g3) - z(2,ia*5+3,j,g3)*ct3)
1482 : 0 : s3=cr3*(z(1,ia*5+3,j,g3)*ct3 + z(2,ia*5+3,j,g3))
1483 : 0 : r4=z(1,ia*5+4,j,g3) - z(2,ia*5+4,j,g3)*ct4
1484 : 0 : s4=z(1,ia*5+4,j,g3)*ct4 + z(2,ia*5+4,j,g3)
1485 : 0 : r5=z(1,ia*5+5,j,g3) - z(2,ia*5+5,j,g3)*ct5
1486 : 0 : s5=z(1,ia*5+5,j,g3)*ct5 + z(2,ia*5+5,j,g3)
1487 : 0 : r25 = r2 + r5*cr5
1488 : 0 : r34 = r3 + r4*cr4
1489 : 0 : s25 = s2 - s5*cr5
1490 : 0 : s34 = s3 - s4*cr4
1491 : 0 : zbr(1,ind(ia*5+1),j,g3) = r1 + r25 + r34
1492 : 0 : r = r1 + cos2*r25 + cos4*r34
1493 : 0 : s = s25 + sin42*s34
1494 : 0 : zbr(1,ind(ia*5+2),j,g3) = r - sin2*s
1495 : 0 : zbr(1,ind(ia*5+5),j,g3) = r + sin2*s
1496 : 0 : r = r1 + cos4*r25 + cos2*r34
1497 : 0 : s = sin42*s25 - s34
1498 : 0 : zbr(1,ind(ia*5+3),j,g3) = r - sin2*s
1499 : 0 : zbr(1,ind(ia*5+4),j,g3) = r + sin2*s
1500 : 0 : r25 = r2 - r5*cr5
1501 : 0 : r34 = r3 - r4*cr4
1502 : 0 : s25 = s2 + s5*cr5
1503 : 0 : s34 = s3 + s4*cr4
1504 : 0 : zbr(2,ind(ia*5+1),j,g3) = s1 + s25 + s34
1505 : 0 : r = s1 + cos2*s25 + cos4*s34
1506 : 0 : s = r25 + sin42*r34
1507 : 0 : zbr(2,ind(ia*5+2),j,g3) = r + sin2*s
1508 : 0 : zbr(2,ind(ia*5+5),j,g3) = r - sin2*s
1509 : 0 : r = s1 + cos4*s25 + cos2*s34
1510 : 0 : s = sin42*r25 - r34
1511 : 0 : zbr(2,ind(ia*5+3),j,g3) = r + sin2*s
1512 : 0 : zbr(2,ind(ia*5+4),j,g3) = r - sin2*s
1513 : : end do
1514 : : end do
1515 : :
1516 : : else
1517 : : ! All radices are treated
1518 : 0 : ABI_BUG('called with factors other than 2, 3, and 5')
1519 : : end if
1520 : :
1521 : : ! End of bit reversal
1522 : :
1523 : : ! -------------------------------------------------------------------
1524 : : end do
1525 : : end do
1526 : : end do
1527 : : !$OMP END PARALLEL DO
1528 : :
1529 : 32997005 : end subroutine sg_fftpx
1530 : : !!***
1531 : :
1532 : : !----------------------------------------------------------------------
1533 : :
1534 : : !!****f* m_sgfft/sg_fftx
1535 : : !! NAME
1536 : : !! sg_fftx
1537 : : !!
1538 : : !! FUNCTION
1539 : : !! This subroutine is called by the 3-dimensional fft to conduct the
1540 : : !! "x" transforms for all y and z.
1541 : : !!
1542 : : !! INPUTS
1543 : : !! fftcache=size of the cache (kB)
1544 : : !! mfac = maximum number of factors in 1D FFTs
1545 : : !! mg = maximum length of 1D FFTs
1546 : : !! nd1=first dimension of (complex) arrays z and zbr (treated as real within
1547 : : !! this subroutine)
1548 : : !! nd2=second dimension of (complex) arrays z and zbr (treated as real within
1549 : : !! this subroutine)
1550 : : !! nd3=third dimension of (complex) arrays z and zbr (treated as real within
1551 : : !! this subroutine)
1552 : : !! n2,n3=actual length of y and z transforms
1553 : : !! z(2,nd1,nd2,nd3)=INPUT array; destroyed by transformation
1554 : : !! trig, aft, now, bef, ind=provided by previous call to ctrig
1555 : : !! Note that in this routine (and in ctrig) the values in array trig are
1556 : : !! actually cos and tan, not cos and sin. Use of tan allows advantageous
1557 : : !! use of FMA on the ibm rs6000.
1558 : : !! ris=sign of exponential in transform (should be 1 or -1; real)
1559 : : !! ic=number of (radix) factors of x transform length (from ctrig)
1560 : : !!
1561 : : !! OUTPUT
1562 : : !! zbr(2,nd1,nd2,nd3)=OUTPUT transformed array; no scaling applied
1563 : : !!
1564 : : !! SIDE EFFECTS
1565 : : !!
1566 : : !! NOTES
1567 : : !! This routine blocks the x transforms
1568 : : !! so that all transforms under consideration at one step fit within
1569 : : !! the cache memory, which is crucial for optimal performance.
1570 : : !! The blocking factor is set by parameter "fftcache" below, which should
1571 : : !! be adjusted to be somewhat smaller (say 3/4) than the actual cache size
1572 : : !! of the machine.
1573 : : !!
1574 : : !! TODO
1575 : : !! Use latex for the equation above
1576 : : !!
1577 : : !! SOURCE
1578 : :
1579 : 281529 : subroutine sg_fftx(fftcache,mfac,mg,nd1,nd2,nd3,n2,n3,z,zbr,&
1580 : 281529 : & trig,aft,now,bef,ris,ind,ic)
1581 : :
1582 : : !Arguments ------------------------------------
1583 : : !Dimensions of aft, now, bef, ind, and trig should agree with
1584 : : !those in subroutine ctrig.
1585 : : !scalars
1586 : : integer,intent(in) :: fftcache,ic,mfac,mg,n2,n3,nd1,nd2,nd3
1587 : : real(dp),intent(in) :: ris
1588 : : !arrays
1589 : : integer,intent(in) :: aft(mfac),bef(mfac),ind(mg),now(mfac)
1590 : : real(dp),intent(in) :: trig(2,mg)
1591 : : real(dp),intent(inout) :: z(2,nd1,nd2,nd3),zbr(2,nd1,nd2,nd3)
1592 : :
1593 : : !Local variables-------------------------------
1594 : : !scalars
1595 : : integer :: i,i3,ia,ib,indx,j,jj,lot,ma,mb,ntb
1596 : : real(dp),parameter :: cos2=0.3090169943749474d0 !cos(2.d0*pi/5.d0)
1597 : : real(dp),parameter :: cos4=-0.8090169943749474d0 !cos(4.d0*pi/5.d0)
1598 : : real(dp),parameter :: sin42=0.6180339887498948d0 !sin(4.d0*pi/5.d0)/sin(2.d0*pi/5.d0)
1599 : : real(dp) :: bb,cr2,cr2s,cr3,cr3p,cr4,cr5,ct2,ct3,ct4,ct5
1600 : : real(dp) :: factor,r,r1,r2,r25,r3,r34,r4,r5,s,sin2,s1,s2,s25,s3,s34,s4,s5
1601 : :
1602 : : ! *************************************************************************
1603 : :
1604 : : !print *, "now", now(1:ic)
1605 : :
1606 : : !Do x transforms in blocks of size "lot" which is set by how
1607 : : !many x transform arrays (of size nd1 each) fit into the nominal
1608 : : !cache size "fftcache".
1609 : 281529 : factor=0.75d0
1610 : 281529 : lot=(fftcache*factor*1000d0)/(nd1*8*2)
1611 : :
1612 : : !XG : due to the dimension problems on the P6, I have slightly
1613 : : !modified this part of the code, with an external loop
1614 : : !on n3 ...
1615 : : !Modifications are indicated explicitely, or
1616 : : !are related to the increase of the number of dimensions of z and
1617 : : !zbr ...
1618 : :
1619 : 281529 : factor=0.75d0
1620 : 281529 : lot=(fftcache*factor*1000d0)/(nd1*8*2)
1621 : 281529 : if(lot.lt.1) lot=1 ! this may happen for very large cells
1622 : : !$OMP PARALLEL DO DEFAULT(PRIVATE) SHARED(aft,bef,ic,ind,lot,n2,n3,now,ris,trig,z,zbr)
1623 [ + + ]: 1876763 : do i3=1,n3
1624 [ + - + + ]: 4010203 : do jj=1,n2,lot
1625 : : ! end of modification
1626 : :
1627 : : ! For each jj, ma and mb give starting and ending addresses for fft
1628 : : ! ma starts where we left off after last block
1629 : 2133440 : ma=jj
1630 : : ! mb runs to the end of the block or else to the end of the data
1631 : : ! modified XG 980107
1632 : : ! mb=min(jj+(lot-1),n23)
1633 : 2133440 : mb=min(jj+(lot-1),n2)
1634 : :
1635 : : ! Run over all factors except the last (to ic-1), performing
1636 : : ! x transform
1637 : :
1638 : : ! Note: fortran should skip this loop if ic=1; beware "onetrip"
1639 : : ! compiler option which forces each loop at least once
1640 : :
1641 : : ! ------------------------------------------------------------------------
1642 : :
1643 : : ! Direct transformation (to be followed by bit reversal)
1644 : :
1645 [ + + ]: 5346800 : do i=1,ic-1
1646 : 3213360 : ntb=now(i)*bef(i)
1647 : : ! radix 4
1648 : :
1649 : : ! Treat radix 4
1650 [ + + ]: 5346800 : if (now(i)==4) then
1651 : 3897985 : ia=0
1652 : :
1653 : : ! First step of factor 4
1654 [ + + ]: 3897985 : do ib=1,bef(i)
1655 [ + + ]: 33781849 : do j=ma,mb
1656 : 29883864 : r4=z(1,ia*ntb+3*bef(i)+ib,j,i3)
1657 : 29883864 : s4=z(2,ia*ntb+3*bef(i)+ib,j,i3)
1658 : 29883864 : r3=z(1,ia*ntb+2*bef(i)+ib,j,i3)
1659 : 29883864 : s3=z(2,ia*ntb+2*bef(i)+ib,j,i3)
1660 : 29883864 : r2=z(1,ia*ntb+bef(i)+ib,j,i3)
1661 : 29883864 : s2=z(2,ia*ntb+bef(i)+ib,j,i3)
1662 : 29883864 : r1=z(1,ia*ntb+ib,j,i3)
1663 : 29883864 : s1=z(2,ia*ntb+ib,j,i3)
1664 : :
1665 : 29883864 : r=r1 + r3
1666 : 29883864 : s=r2 + r4
1667 : 29883864 : z(1,ia*ntb+ib,j,i3) = r + s
1668 : 29883864 : z(1,ia*ntb+2*bef(i)+ib,j,i3) = r - s
1669 : 29883864 : r=r1 - r3
1670 : 29883864 : s=s2 - s4
1671 : 29883864 : z(1,ia*ntb+bef(i)+ib,j,i3) = r - s*ris
1672 : 29883864 : z(1,ia*ntb+3*bef(i)+ib,j,i3) = r + s*ris
1673 : 29883864 : r=s1 + s3
1674 : 29883864 : s=s2 + s4
1675 : 29883864 : z(2,ia*ntb+ib,j,i3) = r + s
1676 : 29883864 : z(2,ia*ntb+2*bef(i)+ib,j,i3) = r - s
1677 : 29883864 : r=s1 - s3
1678 : 29883864 : s=r2 - r4
1679 : 29883864 : z(2,ia*ntb+bef(i)+ib,j,i3) = r + s*ris
1680 : 32682262 : z(2,ia*ntb+3*bef(i)+ib,j,i3) = r - s*ris
1681 : : end do
1682 : : end do
1683 : :
1684 : : ! Second step of factor 4
1685 [ + + ]: 1374787 : do ia=1,aft(i)-1
1686 : 275200 : indx=ind(ia*4*bef(i)+1)-1
1687 : 275200 : indx=indx*bef(i)
1688 : 275200 : cr2=trig(1,indx)
1689 : 275200 : ct2=trig(2,indx)
1690 : 275200 : cr3=trig(1,2*indx)
1691 : 275200 : ct3=trig(2,2*indx)
1692 : 275200 : cr4=trig(1,3*indx)
1693 : 275200 : ct4=trig(2,3*indx)
1694 : 275200 : cr4=cr4/cr2
1695 : 275200 : cr2s=cr2*ris
1696 [ + + ]: 1925187 : do ib=1,bef(i)
1697 [ + + ]: 6748416 : do j=ma,mb
1698 : : r4=z(1,ia*ntb+3*bef(i)+ib,j,i3) - &
1699 : 5922816 : & z(2,ia*ntb+3*bef(i)+ib,j,i3)*ct4
1700 : : s4=z(1,ia*ntb+3*bef(i)+ib,j,i3)*ct4 + &
1701 : 5922816 : & z(2,ia*ntb+3*bef(i)+ib,j,i3)
1702 : : r3=z(1,ia*ntb+2*bef(i)+ib,j,i3) - &
1703 : 5922816 : & z(2,ia*ntb+2*bef(i)+ib,j,i3)*ct3
1704 : : s3=z(1,ia*ntb+2*bef(i)+ib,j,i3)*ct3 + &
1705 : 5922816 : & z(2,ia*ntb+2*bef(i)+ib,j,i3)
1706 : : r2=z(1,ia*ntb+bef(i)+ib,j,i3) - &
1707 : 5922816 : & z(2,ia*ntb+bef(i)+ib,j,i3)*ct2
1708 : : s2=z(1,ia*ntb+bef(i)+ib,j,i3)*ct2 + &
1709 : 5922816 : & z(2,ia*ntb+bef(i)+ib,j,i3)
1710 : 5922816 : r1=z(1,ia*ntb+ib,j,i3)
1711 : 5922816 : s1=z(2,ia*ntb+ib,j,i3)
1712 : :
1713 : 5922816 : r=r1 + r3*cr3
1714 : 5922816 : s=r2 + r4*cr4
1715 : 5922816 : z(1,ia*ntb+ib,j,i3) = r + s*cr2
1716 : 5922816 : z(1,ia*ntb+2*bef(i)+ib,j,i3) = r - s*cr2
1717 : 5922816 : r=r1 - r3*cr3
1718 : 5922816 : s=s2 - s4*cr4
1719 : 5922816 : z(1,ia*ntb+bef(i)+ib,j,i3) = r - s*cr2s
1720 : 5922816 : z(1,ia*ntb+3*bef(i)+ib,j,i3) = r + s*cr2s
1721 : 5922816 : r=s1 + s3*cr3
1722 : 5922816 : s=s2 + s4*cr4
1723 : 5922816 : z(2,ia*ntb+ib,j,i3) = r + s*cr2
1724 : 5922816 : z(2,ia*ntb+2*bef(i)+ib,j,i3) = r - s*cr2
1725 : 5922816 : r=s1 - s3*cr3
1726 : 5922816 : s=r2 - r4*cr4
1727 : 5922816 : z(2,ia*ntb+bef(i)+ib,j,i3) = r + s*cr2s
1728 : 6473216 : z(2,ia*ntb+3*bef(i)+ib,j,i3) = r - s*cr2s
1729 : : end do
1730 : : end do
1731 : : end do
1732 : :
1733 : : ! Treat radix 2
1734 [ - + ]: 2113773 : else if (now(i)==2) then
1735 : 0 : ia=0
1736 : :
1737 : : ! First step of factor 2
1738 [ # # ]: 0 : do ib=1,bef(i)
1739 [ # # ]: 0 : do j=ma,mb
1740 : 0 : r1=z(1,ia*ntb+ib,j,i3)
1741 : 0 : s1=z(2,ia*ntb+ib,j,i3)
1742 : 0 : r2=z(1,ia*ntb+bef(i)+ib,j,i3)
1743 : 0 : s2=z(2,ia*ntb+bef(i)+ib,j,i3)
1744 : 0 : z(1,ia*ntb+ib,j,i3) = r2 + r1
1745 : 0 : z(2,ia*ntb+ib,j,i3) = s2 + s1
1746 : 0 : z(1,ia*ntb+bef(i)+ib,j,i3) = -r2 + r1
1747 : 0 : z(2,ia*ntb+bef(i)+ib,j,i3) = -s2 + s1
1748 : : end do
1749 : : end do
1750 : :
1751 : : ! Second step of factor 2
1752 [ # # ]: 0 : do ia=1,aft(i)-1
1753 : 0 : indx=ind(ia*2*bef(i)+1)-1
1754 : 0 : indx=indx*bef(i)
1755 : 0 : cr2=trig(1,indx)
1756 : 0 : ct2=trig(2,indx)
1757 [ # # ]: 0 : do ib=1,bef(i)
1758 [ # # ]: 0 : do j=ma,mb
1759 : 0 : r1=z(1,ia*ntb+ib,j,i3)
1760 : 0 : s1=z(2,ia*ntb+ib,j,i3)
1761 : : r2=z(1,ia*ntb+bef(i)+ib,j,i3) - &
1762 : 0 : & z(2,ia*ntb+bef(i)+ib,j,i3)*ct2
1763 : : s2=z(1,ia*ntb+bef(i)+ib,j,i3)*ct2 + &
1764 : 0 : & z(2,ia*ntb+bef(i)+ib,j,i3)
1765 : 0 : z(1,ia*ntb+ib,j,i3) = r2*cr2 + r1
1766 : 0 : z(2,ia*ntb+ib,j,i3) = s2*cr2 + s1
1767 : 0 : z(1,ia*ntb+bef(i)+ib,j,i3) = -r2*cr2 + r1
1768 : 0 : z(2,ia*ntb+bef(i)+ib,j,i3) = -s2*cr2 + s1
1769 : : end do
1770 : : end do
1771 : : end do
1772 : :
1773 : : ! Treat radix 3
1774 [ + + ]: 2113773 : else if (now(i)==3) then
1775 : : ! .5d0*sqrt(3.d0)=0.8660254037844387d0
1776 : 818116 : ia=0
1777 : 818116 : bb=ris*0.8660254037844387d0
1778 : :
1779 : : ! First step of factor 3
1780 [ + + ]: 5822012 : do ib=1,bef(i)
1781 [ + + ]: 61050432 : do j=ma,mb
1782 : 55228420 : r1=z(1,ia*ntb+ib,j,i3)
1783 : 55228420 : s1=z(2,ia*ntb+ib,j,i3)
1784 : 55228420 : r2=z(1,ia*ntb+bef(i)+ib,j,i3)
1785 : 55228420 : s2=z(2,ia*ntb+bef(i)+ib,j,i3)
1786 : 55228420 : r3=z(1,ia*ntb+2*bef(i)+ib,j,i3)
1787 : 55228420 : s3=z(2,ia*ntb+2*bef(i)+ib,j,i3)
1788 : 55228420 : r=r2 + r3
1789 : 55228420 : s=s2 + s3
1790 : 55228420 : z(1,ia*ntb+ib,j,i3) = r + r1
1791 : 55228420 : z(2,ia*ntb+ib,j,i3) = s + s1
1792 : 55228420 : r1=r1 - r*.5d0
1793 : 55228420 : s1=s1 - s*.5d0
1794 : 55228420 : r2=r2-r3
1795 : 55228420 : s2=s2-s3
1796 : 55228420 : z(1,ia*ntb+bef(i)+ib,j,i3) = r1 - s2*bb
1797 : 55228420 : z(2,ia*ntb+bef(i)+ib,j,i3) = s1 + r2*bb
1798 : 55228420 : z(1,ia*ntb+2*bef(i)+ib,j,i3) = r1 + s2*bb
1799 : 60232316 : z(2,ia*ntb+2*bef(i)+ib,j,i3) = s1 - r2*bb
1800 : : end do
1801 : : end do
1802 : :
1803 : : ! Second step of factor 3
1804 [ + + ]: 4516820 : do ia=1,aft(i)-1
1805 : 3698704 : indx=ind(ia*3*bef(i)+1)-1
1806 : 3698704 : indx=indx*bef(i)
1807 : 3698704 : cr2=trig(1,indx)
1808 : 3698704 : ct2=trig(2,indx)
1809 : 3698704 : cr3=trig(1,2*indx)
1810 : 3698704 : ct3=trig(2,2*indx)
1811 : 3698704 : cr2=cr2/cr3
1812 : 3698704 : cr3p=.5d0*cr3
1813 : 3698704 : bb=ris*cr3*0.8660254037844387d0
1814 [ + + ]: 14615668 : do ib=1,bef(i)
1815 [ + + ]: 115401272 : do j=ma,mb
1816 : 101603720 : r1=z(1,ia*ntb+ib,j,i3)
1817 : 101603720 : s1=z(2,ia*ntb+ib,j,i3)
1818 : : r2=z(1,ia*ntb+bef(i)+ib,j,i3) - &
1819 : 101603720 : & z(2,ia*ntb+bef(i)+ib,j,i3)*ct2
1820 : : s2=z(1,ia*ntb+bef(i)+ib,j,i3)*ct2 + &
1821 : 101603720 : & z(2,ia*ntb+bef(i)+ib,j,i3)
1822 : : r3=z(1,ia*ntb+2*bef(i)+ib,j,i3) - &
1823 : 101603720 : & z(2,ia*ntb+2*bef(i)+ib,j,i3)*ct3
1824 : : s3=z(1,ia*ntb+2*bef(i)+ib,j,i3)*ct3 + &
1825 : 101603720 : & z(2,ia*ntb+2*bef(i)+ib,j,i3)
1826 : 101603720 : r=cr2*r2 + r3
1827 : 101603720 : s=cr2*s2 + s3
1828 : 101603720 : z(1,ia*ntb+ib,j,i3) = r*cr3 + r1
1829 : 101603720 : z(2,ia*ntb+ib,j,i3) = s*cr3 + s1
1830 : 101603720 : r1=r1 - r*cr3p
1831 : 101603720 : s1=s1 - s*cr3p
1832 : 101603720 : r2=cr2*r2-r3
1833 : 101603720 : s2=cr2*s2-s3
1834 : 101603720 : z(1,ia*ntb+bef(i)+ib,j,i3) = r1 - s2*bb
1835 : 101603720 : z(2,ia*ntb+bef(i)+ib,j,i3) = s1 + r2*bb
1836 : 101603720 : z(1,ia*ntb+2*bef(i)+ib,j,i3) = r1 + s2*bb
1837 : 111702568 : z(2,ia*ntb+2*bef(i)+ib,j,i3) = s1 - r2*bb
1838 : : end do
1839 : : end do
1840 : : end do
1841 : :
1842 : : ! Treat radix 5
1843 [ + - ]: 1295657 : else if (now(i)==5) then
1844 : : ! sin(2.d0*pi/5.d0)
1845 : 1295657 : sin2=ris*0.9510565162951536d0
1846 : 1295657 : ia=0
1847 : :
1848 : : ! First step of factor 5
1849 [ + + ]: 11958176 : do ib=1,bef(i)
1850 [ + + ]: 99118513 : do j=ma,mb
1851 : 87160337 : r1=z(1,ia*ntb+ib,j,i3)
1852 : 87160337 : s1=z(2,ia*ntb+ib,j,i3)
1853 : 87160337 : r2=z(1,ia*ntb+bef(i)+ib,j,i3)
1854 : 87160337 : s2=z(2,ia*ntb+bef(i)+ib,j,i3)
1855 : 87160337 : r3=z(1,ia*ntb+2*bef(i)+ib,j,i3)
1856 : 87160337 : s3=z(2,ia*ntb+2*bef(i)+ib,j,i3)
1857 : 87160337 : r4=z(1,ia*ntb+3*bef(i)+ib,j,i3)
1858 : 87160337 : s4=z(2,ia*ntb+3*bef(i)+ib,j,i3)
1859 : 87160337 : r5=z(1,ia*ntb+4*bef(i)+ib,j,i3)
1860 : 87160337 : s5=z(2,ia*ntb+4*bef(i)+ib,j,i3)
1861 : 87160337 : r25 = r2 + r5
1862 : 87160337 : r34 = r3 + r4
1863 : 87160337 : s25 = s2 - s5
1864 : 87160337 : s34 = s3 - s4
1865 : 87160337 : z(1,ia*ntb+ib,j,i3) = r1 + r25 + r34
1866 : 87160337 : r = r1 + cos2*r25 + cos4*r34
1867 : 87160337 : s = s25 + sin42*s34
1868 : 87160337 : z(1,ia*ntb+bef(i)+ib,j,i3) = r - sin2*s
1869 : 87160337 : z(1,ia*ntb+4*bef(i)+ib,j,i3) = r + sin2*s
1870 : 87160337 : r = r1 + cos4*r25 + cos2*r34
1871 : 87160337 : s = sin42*s25 - s34
1872 : 87160337 : z(1,ia*ntb+2*bef(i)+ib,j,i3) = r - sin2*s
1873 : 87160337 : z(1,ia*ntb+3*bef(i)+ib,j,i3) = r + sin2*s
1874 : 87160337 : r25 = r2 - r5
1875 : 87160337 : r34 = r3 - r4
1876 : 87160337 : s25 = s2 + s5
1877 : 87160337 : s34 = s3 + s4
1878 : 87160337 : z(2,ia*ntb+ib,j,i3) = s1 + s25 + s34
1879 : 87160337 : r = s1 + cos2*s25 + cos4*s34
1880 : 87160337 : s = r25 + sin42*r34
1881 : 87160337 : z(2,ia*ntb+bef(i)+ib,j,i3) = r + sin2*s
1882 : 87160337 : z(2,ia*ntb+4*bef(i)+ib,j,i3) = r - sin2*s
1883 : 87160337 : r = s1 + cos4*s25 + cos2*s34
1884 : 87160337 : s = sin42*r25 - r34
1885 : 87160337 : z(2,ia*ntb+2*bef(i)+ib,j,i3) = r + sin2*s
1886 : 97822856 : z(2,ia*ntb+3*bef(i)+ib,j,i3) = r - sin2*s
1887 : : end do
1888 : : end do
1889 : :
1890 : : ! Second step of factor 5
1891 [ + + ]: 2704457 : do ia=1,aft(i)-1
1892 : 1408800 : indx=ind(ia*5*bef(i)+1)-1
1893 : 1408800 : indx=indx*bef(i)
1894 : 1408800 : cr2=trig(1,indx)
1895 : 1408800 : ct2=trig(2,indx)
1896 : 1408800 : cr3=trig(1,2*indx)
1897 : 1408800 : ct3=trig(2,2*indx)
1898 : 1408800 : cr4=trig(1,3*indx)
1899 : 1408800 : ct4=trig(2,3*indx)
1900 : 1408800 : cr5=trig(1,4*indx)
1901 : 1408800 : ct5=trig(2,4*indx)
1902 [ + + ]: 7602057 : do ib=1,bef(i)
1903 [ + + ]: 43823200 : do j=ma,mb
1904 : 37516800 : r1=z(1,ia*ntb+ib,j,i3)
1905 : 37516800 : s1=z(2,ia*ntb+ib,j,i3)
1906 : : r2=cr2*(z(1,ia*ntb+bef(i)+ib,j,i3) - &
1907 : 37516800 : & z(2,ia*ntb+bef(i)+ib,j,i3)*ct2)
1908 : : s2=cr2*(z(1,ia*ntb+bef(i)+ib,j,i3)*ct2 + &
1909 : 37516800 : & z(2,ia*ntb+bef(i)+ib,j,i3))
1910 : : r3=cr3*(z(1,ia*ntb+2*bef(i)+ib,j,i3) - &
1911 : 37516800 : & z(2,ia*ntb+2*bef(i)+ib,j,i3)*ct3)
1912 : : s3=cr3*(z(1,ia*ntb+2*bef(i)+ib,j,i3)*ct3 + &
1913 : 37516800 : & z(2,ia*ntb+2*bef(i)+ib,j,i3))
1914 : : r4=z(1,ia*ntb+3*bef(i)+ib,j,i3) - &
1915 : 37516800 : & z(2,ia*ntb+3*bef(i)+ib,j,i3)*ct4
1916 : : s4=z(1,ia*ntb+3*bef(i)+ib,j,i3)*ct4 + &
1917 : 37516800 : & z(2,ia*ntb+3*bef(i)+ib,j,i3)
1918 : : r5=z(1,ia*ntb+4*bef(i)+ib,j,i3) - &
1919 : 37516800 : & z(2,ia*ntb+4*bef(i)+ib,j,i3)*ct5
1920 : : s5=z(1,ia*ntb+4*bef(i)+ib,j,i3)*ct5 + &
1921 : 37516800 : & z(2,ia*ntb+4*bef(i)+ib,j,i3)
1922 : 37516800 : r25 = r2 + r5*cr5
1923 : 37516800 : r34 = r3 + r4*cr4
1924 : 37516800 : s25 = s2 - s5*cr5
1925 : 37516800 : s34 = s3 - s4*cr4
1926 : 37516800 : z(1,ia*ntb+ib,j,i3) = r1 + r25 + r34
1927 : 37516800 : r = r1 + cos2*r25 + cos4*r34
1928 : 37516800 : s = s25 + sin42*s34
1929 : 37516800 : z(1,ia*ntb+bef(i)+ib,j,i3) = r - sin2*s
1930 : 37516800 : z(1,ia*ntb+4*bef(i)+ib,j,i3) = r + sin2*s
1931 : 37516800 : r = r1 + cos4*r25 + cos2*r34
1932 : 37516800 : s = sin42*s25 - s34
1933 : 37516800 : z(1,ia*ntb+2*bef(i)+ib,j,i3) = r - sin2*s
1934 : 37516800 : z(1,ia*ntb+3*bef(i)+ib,j,i3) = r + sin2*s
1935 : 37516800 : r25 = r2 - r5*cr5
1936 : 37516800 : r34 = r3 - r4*cr4
1937 : 37516800 : s25 = s2 + s5*cr5
1938 : 37516800 : s34 = s3 + s4*cr4
1939 : 37516800 : z(2,ia*ntb+ib,j,i3) = s1 + s25 + s34
1940 : 37516800 : r = s1 + cos2*s25 + cos4*s34
1941 : 37516800 : s = r25 + sin42*r34
1942 : 37516800 : z(2,ia*ntb+bef(i)+ib,j,i3) = r + sin2*s
1943 : 37516800 : z(2,ia*ntb+4*bef(i)+ib,j,i3) = r - sin2*s
1944 : 37516800 : r = s1 + cos4*s25 + cos2*s34
1945 : 37516800 : s = sin42*r25 - r34
1946 : 37516800 : z(2,ia*ntb+2*bef(i)+ib,j,i3) = r + sin2*s
1947 : 42414400 : z(2,ia*ntb+3*bef(i)+ib,j,i3) = r - sin2*s
1948 : : end do
1949 : : end do
1950 : : end do
1951 : :
1952 : : else
1953 : : ! All factors have been treated
1954 : 0 : ABI_BUG('called with factors other than 2, 3, and 5')
1955 : : end if
1956 : :
1957 : : end do
1958 : :
1959 : : ! ---------------------------------------------------------------
1960 : :
1961 : : ! bitreversal
1962 : :
1963 : : ! Perform bit reversal on last factor of transformation
1964 : :
1965 : : ! Treat factor 4
1966 [ + + ]: 3728674 : if (now(ic)==4) then
1967 : : ! radix 4
1968 : 1737640 : ia=0
1969 : :
1970 : : ! First step of factor 4
1971 [ + + ]: 1737640 : do j=ma,mb
1972 : 1521592 : r4=z(1,ia*4+4,j,i3)
1973 : 1521592 : s4=z(2,ia*4+4,j,i3)
1974 : 1521592 : r3=z(1,ia*4+3,j,i3)
1975 : 1521592 : s3=z(2,ia*4+3,j,i3)
1976 : 1521592 : r2=z(1,ia*4+2,j,i3)
1977 : 1521592 : s2=z(2,ia*4+2,j,i3)
1978 : 1521592 : r1=z(1,ia*4+1,j,i3)
1979 : 1521592 : s1=z(2,ia*4+1,j,i3)
1980 : :
1981 : 1521592 : r=r1 + r3
1982 : 1521592 : s=r2 + r4
1983 : 1521592 : zbr(1,ind(ia*4+1),j,i3) = r + s
1984 : 1521592 : zbr(1,ind(ia*4+3),j,i3) = r - s
1985 : 1521592 : r=r1 - r3
1986 : 1521592 : s=s2 - s4
1987 : 1521592 : zbr(1,ind(ia*4+2),j,i3) = r - s*ris
1988 : 1521592 : zbr(1,ind(ia*4+4),j,i3) = r + s*ris
1989 : 1521592 : r=s1 + s3
1990 : 1521592 : s=s2 + s4
1991 : 1521592 : zbr(2,ind(ia*4+1),j,i3) = r + s
1992 : 1521592 : zbr(2,ind(ia*4+3),j,i3) = r - s
1993 : 1521592 : r=s1 - s3
1994 : 1521592 : s=r2 - r4
1995 : 1521592 : zbr(2,ind(ia*4+2),j,i3) = r + s*ris
1996 : 1737640 : zbr(2,ind(ia*4+4),j,i3) = r - s*ris
1997 : : end do
1998 : :
1999 : : ! Second step of factor 4
2000 [ + + ]: 4778272 : do ia=1,aft(ic)-1
2001 : 4562224 : indx=ind(ia*4+1)-1
2002 : 4562224 : cr2=trig(1,indx)
2003 : 4562224 : ct2=trig(2,indx)
2004 : 4562224 : cr3=trig(1,2*indx)
2005 : 4562224 : ct3=trig(2,2*indx)
2006 : 4562224 : cr4=trig(1,3*indx)
2007 : 4562224 : ct4=trig(2,3*indx)
2008 : 4562224 : cr4=cr4/cr2
2009 : 4562224 : cr2s=cr2*ris
2010 [ + + ]: 35366928 : do j=ma,mb
2011 : 30588656 : r4=z(1,ia*4+4,j,i3) - z(2,ia*4+4,j,i3)*ct4
2012 : 30588656 : s4=z(1,ia*4+4,j,i3)*ct4 + z(2,ia*4+4,j,i3)
2013 : 30588656 : r3=z(1,ia*4+3,j,i3) - z(2,ia*4+3,j,i3)*ct3
2014 : 30588656 : s3=z(1,ia*4+3,j,i3)*ct3 + z(2,ia*4+3,j,i3)
2015 : 30588656 : r2=z(1,ia*4+2,j,i3) - z(2,ia*4+2,j,i3)*ct2
2016 : 30588656 : s2=z(1,ia*4+2,j,i3)*ct2 + z(2,ia*4+2,j,i3)
2017 : 30588656 : r1=z(1,ia*4+1,j,i3)
2018 : 30588656 : s1=z(2,ia*4+1,j,i3)
2019 : :
2020 : 30588656 : r=r1 + r3*cr3
2021 : 30588656 : s=r2 + r4*cr4
2022 : 30588656 : zbr(1,ind(ia*4+1),j,i3) = r + s*cr2
2023 : 30588656 : zbr(1,ind(ia*4+3),j,i3) = r - s*cr2
2024 : 30588656 : r=r1 - r3*cr3
2025 : 30588656 : s=s2 - s4*cr4
2026 : 30588656 : zbr(1,ind(ia*4+2),j,i3) = r - s*cr2s
2027 : 30588656 : zbr(1,ind(ia*4+4),j,i3) = r + s*cr2s
2028 : 30588656 : r=s1 + s3*cr3
2029 : 30588656 : s=s2 + s4*cr4
2030 : 30588656 : zbr(2,ind(ia*4+1),j,i3) = r + s*cr2
2031 : 30588656 : zbr(2,ind(ia*4+3),j,i3) = r - s*cr2
2032 : 30588656 : r=s1 - s3*cr3
2033 : 30588656 : s=r2 - r4*cr4
2034 : 30588656 : zbr(2,ind(ia*4+2),j,i3) = r + s*cr2s
2035 : 35150880 : zbr(2,ind(ia*4+4),j,i3) = r - s*cr2s
2036 : : end do
2037 : : end do
2038 : :
2039 : : ! Treat factor 2
2040 [ + + ]: 1917392 : else if (now(ic)==2) then
2041 : : ! radix 2
2042 : 17935413 : ia=0
2043 : :
2044 : : ! First step of factor 2
2045 [ + + ]: 17935413 : do j=ma,mb
2046 : 16236578 : r1=z(1,ia*2+1,j,i3)
2047 : 16236578 : s1=z(2,ia*2+1,j,i3)
2048 : 16236578 : r2=z(1,ia*2+2,j,i3)
2049 : 16236578 : s2=z(2,ia*2+2,j,i3)
2050 : 16236578 : zbr(1,ind(ia*2+1),j,i3) = r2 + r1
2051 : 16236578 : zbr(2,ind(ia*2+1),j,i3) = s2 + s1
2052 : 16236578 : zbr(1,ind(ia*2+2),j,i3) = -r2 + r1
2053 : 17935413 : zbr(2,ind(ia*2+2),j,i3) = -s2 + s1
2054 : : end do
2055 : :
2056 : : ! Second step of factor 2
2057 [ + + ]: 17135484 : do ia=1,aft(ic)-1
2058 : 15436649 : indx=ind(ia*2+1)-1
2059 : 15436649 : cr2=trig(1,indx)
2060 : 15436649 : ct2=trig(2,indx)
2061 [ + + ]: 174426664 : do j=ma,mb
2062 : 157291180 : r1=z(1,ia*2+1,j,i3)
2063 : 157291180 : s1=z(2,ia*2+1,j,i3)
2064 : 157291180 : r2=z(1,ia*2+2,j,i3) - z(2,ia*2+2,j,i3)*ct2
2065 : 157291180 : s2=z(1,ia*2+2,j,i3)*ct2 + z(2,ia*2+2,j,i3)
2066 : 157291180 : zbr(1,ind(ia*2+1),j,i3) = r2*cr2 + r1
2067 : 157291180 : zbr(2,ind(ia*2+1),j,i3) = s2*cr2 + s1
2068 : 157291180 : zbr(1,ind(ia*2+2),j,i3) = -r2*cr2 + r1
2069 : 172727829 : zbr(2,ind(ia*2+2),j,i3) = -s2*cr2 + s1
2070 : : end do
2071 : : end do
2072 : :
2073 : : ! Treat factor 3
2074 [ + - ]: 218557 : else if (now(ic)==3) then
2075 : : ! radix 3
2076 : : ! .5d0*sqrt(3.d0)=0.8660254037844387d0
2077 : 218557 : ia=0
2078 : 218557 : bb=ris*0.8660254037844387d0
2079 : :
2080 : : ! First step of factor 3
2081 [ + + ]: 2339496 : do j=ma,mb
2082 : 2120939 : r1=z(1,ia*3+1,j,i3)
2083 : 2120939 : s1=z(2,ia*3+1,j,i3)
2084 : 2120939 : r2=z(1,ia*3+2,j,i3)
2085 : 2120939 : s2=z(2,ia*3+2,j,i3)
2086 : 2120939 : r3=z(1,ia*3+3,j,i3)
2087 : 2120939 : s3=z(2,ia*3+3,j,i3)
2088 : 2120939 : r=r2 + r3
2089 : 2120939 : s=s2 + s3
2090 : 2120939 : zbr(1,ind(ia*3+1),j,i3) = r + r1
2091 : 2120939 : zbr(2,ind(ia*3+1),j,i3) = s + s1
2092 : 2120939 : r1=r1 - r*.5d0
2093 : 2120939 : s1=s1 - s*.5d0
2094 : 2120939 : r2=r2-r3
2095 : 2120939 : s2=s2-s3
2096 : 2120939 : zbr(1,ind(ia*3+2),j,i3) = r1 - s2*bb
2097 : 2120939 : zbr(2,ind(ia*3+2),j,i3) = s1 + r2*bb
2098 : 2120939 : zbr(1,ind(ia*3+3),j,i3) = r1 + s2*bb
2099 : 2339496 : zbr(2,ind(ia*3+3),j,i3) = s1 - r2*bb
2100 : : end do
2101 : :
2102 : : ! Second step of factor 3
2103 [ + + ]: 4195513 : do ia=1,aft(ic)-1
2104 : 3976956 : indx=ind(ia*3+1)-1
2105 : 3976956 : cr2=trig(1,indx)
2106 : 3976956 : ct2=trig(2,indx)
2107 : 3976956 : cr3=trig(1,2*indx)
2108 : 3976956 : ct3=trig(2,2*indx)
2109 : 3976956 : cr2=cr2/cr3
2110 : 3976956 : cr3p=.5d0*cr3
2111 : 3976956 : bb=ris*cr3*0.8660254037844387d0
2112 [ + + ]: 41466445 : do j=ma,mb
2113 : 37270932 : r1=z(1,ia*3+1,j,i3)
2114 : 37270932 : s1=z(2,ia*3+1,j,i3)
2115 : 37270932 : r2=z(1,ia*3+2,j,i3) - z(2,ia*3+2,j,i3)*ct2
2116 : 37270932 : s2=z(1,ia*3+2,j,i3)*ct2 + z(2,ia*3+2,j,i3)
2117 : 37270932 : r3=z(1,ia*3+3,j,i3) - z(2,ia*3+3,j,i3)*ct3
2118 : 37270932 : s3=z(1,ia*3+3,j,i3)*ct3 + z(2,ia*3+3,j,i3)
2119 : 37270932 : r=cr2*r2 + r3
2120 : 37270932 : s=cr2*s2 + s3
2121 : 37270932 : zbr(1,ind(ia*3+1),j,i3) = r*cr3 + r1
2122 : 37270932 : zbr(2,ind(ia*3+1),j,i3) = s*cr3 + s1
2123 : 37270932 : r1=r1 - r*cr3p
2124 : 37270932 : s1=s1 - s*cr3p
2125 : 37270932 : r2=cr2*r2-r3
2126 : 37270932 : s2=cr2*s2-s3
2127 : 37270932 : zbr(1,ind(ia*3+2),j,i3) = r1 - s2*bb
2128 : 37270932 : zbr(2,ind(ia*3+2),j,i3) = s1 + r2*bb
2129 : 37270932 : zbr(1,ind(ia*3+3),j,i3) = r1 + s2*bb
2130 : 41247888 : zbr(2,ind(ia*3+3),j,i3) = s1 - r2*bb
2131 : : end do
2132 : : end do
2133 : :
2134 : : ! Treat factor 5
2135 [ # # ]: 0 : else if (now(ic)==5) then
2136 : : ! radix 5
2137 : : ! sin(2.d0*pi/5.d0)
2138 : 0 : sin2=ris*0.9510565162951536d0
2139 : 0 : ia=0
2140 : :
2141 : : ! First step of factor 5
2142 [ # # ]: 0 : do j=ma,mb
2143 : 0 : r1=z(1,ia*5+1,j,i3)
2144 : 0 : s1=z(2,ia*5+1,j,i3)
2145 : 0 : r2=z(1,ia*5+2,j,i3)
2146 : 0 : s2=z(2,ia*5+2,j,i3)
2147 : 0 : r3=z(1,ia*5+3,j,i3)
2148 : 0 : s3=z(2,ia*5+3,j,i3)
2149 : 0 : r4=z(1,ia*5+4,j,i3)
2150 : 0 : s4=z(2,ia*5+4,j,i3)
2151 : 0 : r5=z(1,ia*5+5,j,i3)
2152 : 0 : s5=z(2,ia*5+5,j,i3)
2153 : 0 : r25 = r2 + r5
2154 : 0 : r34 = r3 + r4
2155 : 0 : s25 = s2 - s5
2156 : 0 : s34 = s3 - s4
2157 : 0 : zbr(1,ind(ia*5+1),j,i3) = r1 + r25 + r34
2158 : 0 : r = r1 + cos2*r25 + cos4*r34
2159 : 0 : s = s25 + sin42*s34
2160 : 0 : zbr(1,ind(ia*5+2),j,i3) = r - sin2*s
2161 : 0 : zbr(1,ind(ia*5+5),j,i3) = r + sin2*s
2162 : 0 : r = r1 + cos4*r25 + cos2*r34
2163 : 0 : s = sin42*s25 - s34
2164 : 0 : zbr(1,ind(ia*5+3),j,i3) = r - sin2*s
2165 : 0 : zbr(1,ind(ia*5+4),j,i3) = r + sin2*s
2166 : 0 : r25 = r2 - r5
2167 : 0 : r34 = r3 - r4
2168 : 0 : s25 = s2 + s5
2169 : 0 : s34 = s3 + s4
2170 : 0 : zbr(2,ind(ia*5+1),j,i3) = s1 + s25 + s34
2171 : 0 : r = s1 + cos2*s25 + cos4*s34
2172 : 0 : s = r25 + sin42*r34
2173 : 0 : zbr(2,ind(ia*5+2),j,i3) = r + sin2*s
2174 : 0 : zbr(2,ind(ia*5+5),j,i3) = r - sin2*s
2175 : 0 : r = s1 + cos4*s25 + cos2*s34
2176 : 0 : s = sin42*r25 - r34
2177 : 0 : zbr(2,ind(ia*5+3),j,i3) = r + sin2*s
2178 : 0 : zbr(2,ind(ia*5+4),j,i3) = r - sin2*s
2179 : : end do
2180 : :
2181 : : ! Second step of factor 5
2182 [ # # ]: 0 : do ia=1,aft(ic)-1
2183 : 0 : indx=ind(ia*5+1)-1
2184 : 0 : cr2=trig(1,indx)
2185 : 0 : ct2=trig(2,indx)
2186 : 0 : cr3=trig(1,2*indx)
2187 : 0 : ct3=trig(2,2*indx)
2188 : 0 : cr4=trig(1,3*indx)
2189 : 0 : ct4=trig(2,3*indx)
2190 : 0 : cr5=trig(1,4*indx)
2191 : 0 : ct5=trig(2,4*indx)
2192 [ # # ]: 0 : do j=ma,mb
2193 : 0 : r1=z(1,ia*5+1,j,i3)
2194 : 0 : s1=z(2,ia*5+1,j,i3)
2195 : 0 : r2=cr2*(z(1,ia*5+2,j,i3) - z(2,ia*5+2,j,i3)*ct2)
2196 : 0 : s2=cr2*(z(1,ia*5+2,j,i3)*ct2 + z(2,ia*5+2,j,i3))
2197 : 0 : r3=cr3*(z(1,ia*5+3,j,i3) - z(2,ia*5+3,j,i3)*ct3)
2198 : 0 : s3=cr3*(z(1,ia*5+3,j,i3)*ct3 + z(2,ia*5+3,j,i3))
2199 : 0 : r4=z(1,ia*5+4,j,i3) - z(2,ia*5+4,j,i3)*ct4
2200 : 0 : s4=z(1,ia*5+4,j,i3)*ct4 + z(2,ia*5+4,j,i3)
2201 : 0 : r5=z(1,ia*5+5,j,i3) - z(2,ia*5+5,j,i3)*ct5
2202 : 0 : s5=z(1,ia*5+5,j,i3)*ct5 + z(2,ia*5+5,j,i3)
2203 : 0 : r25 = r2 + r5*cr5
2204 : 0 : r34 = r3 + r4*cr4
2205 : 0 : s25 = s2 - s5*cr5
2206 : 0 : s34 = s3 - s4*cr4
2207 : 0 : zbr(1,ind(ia*5+1),j,i3) = r1 + r25 + r34
2208 : 0 : r = r1 + cos2*r25 + cos4*r34
2209 : 0 : s = s25 + sin42*s34
2210 : 0 : zbr(1,ind(ia*5+2),j,i3) = r - sin2*s
2211 : 0 : zbr(1,ind(ia*5+5),j,i3) = r + sin2*s
2212 : 0 : r = r1 + cos4*r25 + cos2*r34
2213 : 0 : s = sin42*s25 - s34
2214 : 0 : zbr(1,ind(ia*5+3),j,i3) = r - sin2*s
2215 : 0 : zbr(1,ind(ia*5+4),j,i3) = r + sin2*s
2216 : 0 : r25 = r2 - r5*cr5
2217 : 0 : r34 = r3 - r4*cr4
2218 : 0 : s25 = s2 + s5*cr5
2219 : 0 : s34 = s3 + s4*cr4
2220 : 0 : zbr(2,ind(ia*5+1),j,i3) = s1 + s25 + s34
2221 : 0 : r = s1 + cos2*s25 + cos4*s34
2222 : 0 : s = r25 + sin42*r34
2223 : 0 : zbr(2,ind(ia*5+2),j,i3) = r + sin2*s
2224 : 0 : zbr(2,ind(ia*5+5),j,i3) = r - sin2*s
2225 : 0 : r = s1 + cos4*s25 + cos2*s34
2226 : 0 : s = sin42*r25 - r34
2227 : 0 : zbr(2,ind(ia*5+3),j,i3) = r + sin2*s
2228 : 0 : zbr(2,ind(ia*5+4),j,i3) = r - sin2*s
2229 : : end do
2230 : : end do
2231 : :
2232 : : else
2233 : : ! All factors treated
2234 : 0 : ABI_BUG('called with factors other than 2, 3, and 5')
2235 : : end if
2236 : :
2237 : : ! ---------------------------------------------------------------
2238 : :
2239 : : end do ! do i3=1,n3
2240 : : end do ! do jj=1,n2,lot
2241 : : !$OMP END PARALLEL DO
2242 : :
2243 : 281529 : end subroutine sg_fftx
2244 : : !!***
2245 : :
2246 : : !----------------------------------------------------------------------
2247 : :
2248 : : !!****f* m_sgfft/sg_ffty
2249 : : !! NAME
2250 : : !! sg_ffty
2251 : : !!
2252 : : !! FUNCTION
2253 : : !! This subroutine is called by the 3-dimensional fft to conduct the
2254 : : !! "y" transforms for all x and z.
2255 : : !!
2256 : : !! INPUTS
2257 : : !! fftcache=size of the cache (kB)
2258 : : !! mfac = maximum number of factors in 1D FFTs
2259 : : !! mg = maximum length of 1D FFTs
2260 : : !! nd1=first dimension of (complex) arrays z and zbr (treated as real within
2261 : : !! this subroutine)
2262 : : !! nd2=second dimension of (complex) arrays z and zbr (treated as real within
2263 : : !! this subroutine)
2264 : : !! nd3=third dimension of (complex) arrays z and zbr (treated as real within
2265 : : !! this subroutine)
2266 : : !! n1i=lower i1 index, used for blocking : the do-loop will be i1=n1i,n1
2267 : : !! put to 1 for usual ffty
2268 : : !! n1=upper i1 index, used for blocking, put usual n1 for usual ffty
2269 : : !! n3i=lower i3 index, used for blocking : the do-loop will be i3=n3i,n3
2270 : : !! put to 1 for usual ffty
2271 : : !! n3=upper i3 index, used for blocking, put usual n3 for usual ffty
2272 : : !! z(2,nd1,nd2,nd3)=INPUT array; destroyed by transformation
2273 : : !! trig, aft, now, bef, ind=provided by previous call to ctrig
2274 : : !! Note that in this routine (and in ctrig) the values in array trig are
2275 : : !! actually cos and tan, not cos and sin. Use of tan allows advantageous
2276 : : !! use of FMA on the ibm rs6000.
2277 : : !! ris=sign of exponential in transform (should be 1 or -1; real)
2278 : : !! ic=number of (radix) factors of x transform length (from ctrig)
2279 : : !!
2280 : : !! OUTPUT
2281 : : !! zbr(2,nd1,nd2,nd3)=OUTPUT transformed array; no scaling applied
2282 : : !!
2283 : : !! TODO
2284 : : !! Use latex for the equation above
2285 : : !!
2286 : : !! SOURCE
2287 : :
2288 : 39264765 : subroutine sg_ffty(fftcache,mfac,mg,nd1,nd2,nd3,n1i,n1,n3i,n3,&
2289 : 39264765 : & z,zbr,trig,aft,now,bef,ris,ind,ic)
2290 : :
2291 : : !Arguments ------------------------------------
2292 : : !Dimensions of aft, now, bef, ind, and trig should agree with
2293 : : !those in subroutine ctrig.
2294 : : !scalars
2295 : : integer,intent(in) :: fftcache,ic,mfac,mg,n1,n1i,n3,n3i,nd1,nd2,nd3
2296 : : real(dp),intent(in) :: ris
2297 : : !arrays
2298 : : integer,intent(in) :: aft(mfac),bef(mfac),ind(mg),now(mfac)
2299 : : real(dp),intent(in) :: trig(2,mg)
2300 : : real(dp),intent(inout) :: z(2,nd1,nd2,nd3),zbr(2,nd1,nd2,nd3)
2301 : :
2302 : : !Local variables-------------------------------
2303 : : !scalars
2304 : : integer :: i,ia,ib,indx,j1,j2,ntb
2305 : : real(dp),parameter :: cos2=0.3090169943749474d0 !cos(2.d0*pi/5.d0)
2306 : : real(dp),parameter :: cos4=-0.8090169943749474d0 !cos(4.d0*pi/5.d0)
2307 : : real(dp),parameter :: sin42=0.6180339887498948d0 !sin(4.d0*pi/5.d0)/sin(2.d0*pi/5.d0)
2308 : : real(dp) :: bb,cr2,cr2s,cr3,cr3p,cr4,cr5,ct2,ct3,ct4,ct5
2309 : : real(dp) :: r,r1,r2,r25,r3,r34,r4,r5,s,sin2,s1,s2,s25,s3,s34,s4,s5
2310 : :
2311 : : ! *************************************************************************
2312 : :
2313 [ - + ]: 39264765 : if (fftcache<0) then
2314 : 0 : ABI_ERROR('fftcache must be positive')
2315 : : end if
2316 : :
2317 : : !Outer loop over z planes (j2)--note range from n3i to n3
2318 : :
2319 : : !$OMP PARALLEL DO DEFAULT(PRIVATE) SHARED(aft,bef,ic,ind,n1,n1i,n3,n3i,now,ris,trig,z,zbr)
2320 [ + + ]: 79867040 : do j2=n3i,n3
2321 : :
2322 : : ! Direct transformation
2323 [ + + ]: 95595904 : do i=1,ic-1
2324 : 54993629 : ntb=now(i)*bef(i)
2325 : :
2326 : : ! Treat radix 4
2327 [ + + ]: 95595904 : if (now(i)==4) then
2328 : 60072359 : ia=0
2329 : :
2330 : : ! First step of radix 4
2331 [ + + ]: 60072359 : do ib=1,bef(i)
2332 : : ! Inner loop over all x values (j1) -- note range from n1i to n1
2333 : : ! y transform is performed for this range of x values repeatedly
2334 : : ! below
2335 : :
2336 [ + + ]: 873771999 : do j1=n1i,n1
2337 : 813699640 : r4=z(1,j1,ia*ntb+3*bef(i)+ib,j2)
2338 : 813699640 : s4=z(2,j1,ia*ntb+3*bef(i)+ib,j2)
2339 : 813699640 : r3=z(1,j1,ia*ntb+2*bef(i)+ib,j2)
2340 : 813699640 : s3=z(2,j1,ia*ntb+2*bef(i)+ib,j2)
2341 : 813699640 : r2=z(1,j1,ia*ntb+bef(i)+ib,j2)
2342 : 813699640 : s2=z(2,j1,ia*ntb+bef(i)+ib,j2)
2343 : 813699640 : r1=z(1,j1,ia*ntb+ib,j2)
2344 : 813699640 : s1=z(2,j1,ia*ntb+ib,j2)
2345 : :
2346 : 813699640 : r=r1 + r3
2347 : 813699640 : s=r2 + r4
2348 : 813699640 : z(1,j1,ia*ntb+ib,j2) = r + s
2349 : 813699640 : z(1,j1,ia*ntb+2*bef(i)+ib,j2) = r - s
2350 : 813699640 : r=r1 - r3
2351 : 813699640 : s=s2 - s4
2352 : 813699640 : z(1,j1,ia*ntb+bef(i)+ib,j2) = r - s*ris
2353 : 813699640 : z(1,j1,ia*ntb+3*bef(i)+ib,j2) = r + s*ris
2354 : 813699640 : r=s1 + s3
2355 : 813699640 : s=s2 + s4
2356 : 813699640 : z(2,j1,ia*ntb+ib,j2) = r + s
2357 : 813699640 : z(2,j1,ia*ntb+2*bef(i)+ib,j2) = r - s
2358 : 813699640 : r=s1 - s3
2359 : 813699640 : s=r2 - r4
2360 : 813699640 : z(2,j1,ia*ntb+bef(i)+ib,j2) = r + s*ris
2361 : 862573978 : z(2,j1,ia*ntb+3*bef(i)+ib,j2) = r - s*ris
2362 : : end do ! j1
2363 : : end do ! ib
2364 : :
2365 : : ! Second step of radix 4
2366 [ + + ]: 13015147 : do ia=1,aft(i)-1
2367 : 1817126 : indx=ind(ia*4*bef(i)+1)-1
2368 : 1817126 : indx=indx*bef(i)
2369 : 1817126 : cr2=trig(1,indx)
2370 : 1817126 : ct2=trig(2,indx)
2371 : 1817126 : cr3=trig(1,2*indx)
2372 : 1817126 : ct3=trig(2,2*indx)
2373 : 1817126 : cr4=trig(1,3*indx)
2374 : 1817126 : ct4=trig(2,3*indx)
2375 : 1817126 : cr4=cr4/cr2
2376 : 1817126 : cr2s=cr2*ris
2377 [ + + ]: 16770479 : do ib=1,bef(i)
2378 : : ! Range of x array again (also appears many times below)
2379 [ + + ]: 35244860 : do j1=n1i,n1
2380 : : r4=z(1,j1,ia*ntb+3*bef(i)+ib,j2) - &
2381 : 29672402 : & z(2,j1,ia*ntb+3*bef(i)+ib,j2)*ct4
2382 : : s4=z(1,j1,ia*ntb+3*bef(i)+ib,j2)*ct4 + &
2383 : 29672402 : & z(2,j1,ia*ntb+3*bef(i)+ib,j2)
2384 : : r3=z(1,j1,ia*ntb+2*bef(i)+ib,j2) - &
2385 : 29672402 : & z(2,j1,ia*ntb+2*bef(i)+ib,j2)*ct3
2386 : : s3=z(1,j1,ia*ntb+2*bef(i)+ib,j2)*ct3 + &
2387 : 29672402 : & z(2,j1,ia*ntb+2*bef(i)+ib,j2)
2388 : : r2=z(1,j1,ia*ntb+bef(i)+ib,j2) - &
2389 : 29672402 : & z(2,j1,ia*ntb+bef(i)+ib,j2)*ct2
2390 : : s2=z(1,j1,ia*ntb+bef(i)+ib,j2)*ct2 + &
2391 : 29672402 : & z(2,j1,ia*ntb+bef(i)+ib,j2)
2392 : 29672402 : r1=z(1,j1,ia*ntb+ib,j2)
2393 : 29672402 : s1=z(2,j1,ia*ntb+ib,j2)
2394 : :
2395 : 29672402 : r=r1 + r3*cr3
2396 : 29672402 : s=r2 + r4*cr4
2397 : 29672402 : z(1,j1,ia*ntb+ib,j2) = r + s*cr2
2398 : 29672402 : z(1,j1,ia*ntb+2*bef(i)+ib,j2) = r - s*cr2
2399 : 29672402 : r=r1 - r3*cr3
2400 : 29672402 : s=s2 - s4*cr4
2401 : 29672402 : z(1,j1,ia*ntb+bef(i)+ib,j2) = r - s*cr2s
2402 : 29672402 : z(1,j1,ia*ntb+3*bef(i)+ib,j2) = r + s*cr2s
2403 : 29672402 : r=s1 + s3*cr3
2404 : 29672402 : s=s2 + s4*cr4
2405 : 29672402 : z(2,j1,ia*ntb+ib,j2) = r + s*cr2
2406 : 29672402 : z(2,j1,ia*ntb+2*bef(i)+ib,j2) = r - s*cr2
2407 : 29672402 : r=s1 - s3*cr3
2408 : 29672402 : s=r2 - r4*cr4
2409 : 29672402 : z(2,j1,ia*ntb+bef(i)+ib,j2) = r + s*cr2s
2410 : 33427734 : z(2,j1,ia*ntb+3*bef(i)+ib,j2) = r - s*cr2s
2411 : : end do ! j1
2412 : : end do ! ib
2413 : : end do ! ia
2414 : :
2415 : : ! Treat radix 2
2416 [ - + ]: 43795608 : else if (now(i)==2) then
2417 : 0 : ia=0
2418 : :
2419 : : ! First step of radix 2
2420 [ # # ]: 0 : do ib=1,bef(i)
2421 [ # # ]: 0 : do j1=n1i,n1
2422 : 0 : r1=z(1,j1,ia*ntb+ib,j2)
2423 : 0 : s1=z(2,j1,ia*ntb+ib,j2)
2424 : 0 : r2=z(1,j1,ia*ntb+bef(i)+ib,j2)
2425 : 0 : s2=z(2,j1,ia*ntb+bef(i)+ib,j2)
2426 : 0 : z(1,j1,ia*ntb+ib,j2) = r2 + r1
2427 : 0 : z(2,j1,ia*ntb+ib,j2) = s2 + s1
2428 : 0 : z(1,j1,ia*ntb+bef(i)+ib,j2) = -r2 + r1
2429 : 0 : z(2,j1,ia*ntb+bef(i)+ib,j2) = -s2 + s1
2430 : : end do
2431 : : end do
2432 : :
2433 : : ! Second step of radix 2
2434 [ # # ]: 0 : do ia=1,aft(i)-1
2435 : 0 : indx=ind(ia*2*bef(i)+1)-1
2436 : 0 : indx=indx*bef(i)
2437 : 0 : cr2=trig(1,indx)
2438 : 0 : ct2=trig(2,indx)
2439 [ # # ]: 0 : do ib=1,bef(i)
2440 [ # # ]: 0 : do j1=n1i,n1
2441 : 0 : r1=z(1,j1,ia*ntb+ib,j2)
2442 : 0 : s1=z(2,j1,ia*ntb+ib,j2)
2443 : : r2=z(1,j1,ia*ntb+bef(i)+ib,j2) - &
2444 : 0 : & z(2,j1,ia*ntb+bef(i)+ib,j2)*ct2
2445 : : s2=z(1,j1,ia*ntb+bef(i)+ib,j2)*ct2 + &
2446 : 0 : & z(2,j1,ia*ntb+bef(i)+ib,j2)
2447 : 0 : z(1,j1,ia*ntb+ib,j2) = r2*cr2 + r1
2448 : 0 : z(2,j1,ia*ntb+ib,j2) = s2*cr2 + s1
2449 : 0 : z(1,j1,ia*ntb+bef(i)+ib,j2) = -r2*cr2 + r1
2450 : 0 : z(2,j1,ia*ntb+bef(i)+ib,j2) = -s2*cr2 + s1
2451 : : end do
2452 : : end do
2453 : : end do
2454 : :
2455 : : ! Treat radix 3
2456 [ + + ]: 43795608 : else if (now(i)==3) then
2457 : : ! .5d0*sqrt(3.d0)=0.8660254037844387d0
2458 : 23786181 : ia=0
2459 : 23786181 : bb=ris*0.8660254037844387d0
2460 : :
2461 : : ! First step of radix 3
2462 [ + + ]: 112029921 : do ib=1,bef(i)
2463 [ + + ]: 1644685107 : do j1=n1i,n1
2464 : 1532655186 : r1=z(1,j1,ia*ntb+ib,j2)
2465 : 1532655186 : s1=z(2,j1,ia*ntb+ib,j2)
2466 : 1532655186 : r2=z(1,j1,ia*ntb+bef(i)+ib,j2)
2467 : 1532655186 : s2=z(2,j1,ia*ntb+bef(i)+ib,j2)
2468 : 1532655186 : r3=z(1,j1,ia*ntb+2*bef(i)+ib,j2)
2469 : 1532655186 : s3=z(2,j1,ia*ntb+2*bef(i)+ib,j2)
2470 : 1532655186 : r=r2 + r3
2471 : 1532655186 : s=s2 + s3
2472 : 1532655186 : z(1,j1,ia*ntb+ib,j2) = r + r1
2473 : 1532655186 : z(2,j1,ia*ntb+ib,j2) = s + s1
2474 : 1532655186 : r1=r1 - r*.5d0
2475 : 1532655186 : s1=s1 - s*.5d0
2476 : 1532655186 : r2=r2-r3
2477 : 1532655186 : s2=s2-s3
2478 : 1532655186 : z(1,j1,ia*ntb+bef(i)+ib,j2) = r1 - s2*bb
2479 : 1532655186 : z(2,j1,ia*ntb+bef(i)+ib,j2) = s1 + r2*bb
2480 : 1532655186 : z(1,j1,ia*ntb+2*bef(i)+ib,j2) = r1 + s2*bb
2481 : 1620898926 : z(2,j1,ia*ntb+2*bef(i)+ib,j2) = s1 - r2*bb
2482 : : end do
2483 : : end do
2484 : :
2485 : : ! Second step of radix 3
2486 [ + + ]: 55333284 : do ia=1,aft(i)-1
2487 : 31547103 : indx=ind(ia*3*bef(i)+1)-1
2488 : 31547103 : indx=indx*bef(i)
2489 : 31547103 : cr2=trig(1,indx)
2490 : 31547103 : ct2=trig(2,indx)
2491 : 31547103 : cr3=trig(1,2*indx)
2492 : 31547103 : ct3=trig(2,2*indx)
2493 : 31547103 : cr2=cr2/cr3
2494 : 31547103 : cr3p=.5d0*cr3
2495 : 31547103 : bb=ris*cr3*0.8660254037844387d0
2496 [ + + ]: 119288394 : do ib=1,bef(i)
2497 [ + + ]: 1362709011 : do j1=n1i,n1
2498 : 1267206798 : r1=z(1,j1,ia*ntb+ib,j2)
2499 : 1267206798 : s1=z(2,j1,ia*ntb+ib,j2)
2500 : : r2=z(1,j1,ia*ntb+bef(i)+ib,j2) - &
2501 : 1267206798 : & z(2,j1,ia*ntb+bef(i)+ib,j2)*ct2
2502 : : s2=z(1,j1,ia*ntb+bef(i)+ib,j2)*ct2 + &
2503 : 1267206798 : & z(2,j1,ia*ntb+bef(i)+ib,j2)
2504 : : r3=z(1,j1,ia*ntb+2*bef(i)+ib,j2) - &
2505 : 1267206798 : & z(2,j1,ia*ntb+2*bef(i)+ib,j2)*ct3
2506 : : s3=z(1,j1,ia*ntb+2*bef(i)+ib,j2)*ct3 + &
2507 : 1267206798 : & z(2,j1,ia*ntb+2*bef(i)+ib,j2)
2508 : 1267206798 : r=cr2*r2 + r3
2509 : 1267206798 : s=cr2*s2 + s3
2510 : 1267206798 : z(1,j1,ia*ntb+ib,j2) = r*cr3 + r1
2511 : 1267206798 : z(2,j1,ia*ntb+ib,j2) = s*cr3 + s1
2512 : 1267206798 : r1=r1 - r*cr3p
2513 : 1267206798 : s1=s1 - s*cr3p
2514 : 1267206798 : r2=cr2*r2-r3
2515 : 1267206798 : s2=cr2*s2-s3
2516 : 1267206798 : z(1,j1,ia*ntb+bef(i)+ib,j2) = r1 - s2*bb
2517 : 1267206798 : z(2,j1,ia*ntb+bef(i)+ib,j2) = s1 + r2*bb
2518 : 1267206798 : z(1,j1,ia*ntb+2*bef(i)+ib,j2) = r1 + s2*bb
2519 : 1331161908 : z(2,j1,ia*ntb+2*bef(i)+ib,j2) = s1 - r2*bb
2520 : : end do
2521 : : end do
2522 : : end do
2523 : :
2524 : : ! Treat radix 5
2525 [ + - ]: 20009427 : else if (now(i)==5) then
2526 : : ! sin(2.d0*pi/5.d0)
2527 : 20009427 : sin2=ris*0.9510565162951536d0
2528 : 20009427 : ia=0
2529 : :
2530 : : ! First step of radix 5
2531 [ + + ]: 84458420 : do ib=1,bef(i)
2532 [ + + ]: 1127923158 : do j1=n1i,n1
2533 : 1043464738 : r1=z(1,j1,ia*ntb+ib,j2)
2534 : 1043464738 : s1=z(2,j1,ia*ntb+ib,j2)
2535 : 1043464738 : r2=z(1,j1,ia*ntb+bef(i)+ib,j2)
2536 : 1043464738 : s2=z(2,j1,ia*ntb+bef(i)+ib,j2)
2537 : 1043464738 : r3=z(1,j1,ia*ntb+2*bef(i)+ib,j2)
2538 : 1043464738 : s3=z(2,j1,ia*ntb+2*bef(i)+ib,j2)
2539 : 1043464738 : r4=z(1,j1,ia*ntb+3*bef(i)+ib,j2)
2540 : 1043464738 : s4=z(2,j1,ia*ntb+3*bef(i)+ib,j2)
2541 : 1043464738 : r5=z(1,j1,ia*ntb+4*bef(i)+ib,j2)
2542 : 1043464738 : s5=z(2,j1,ia*ntb+4*bef(i)+ib,j2)
2543 : 1043464738 : r25 = r2 + r5
2544 : 1043464738 : r34 = r3 + r4
2545 : 1043464738 : s25 = s2 - s5
2546 : 1043464738 : s34 = s3 - s4
2547 : 1043464738 : z(1,j1,ia*ntb+ib,j2) = r1 + r25 + r34
2548 : 1043464738 : r = r1 + cos2*r25 + cos4*r34
2549 : 1043464738 : s = s25 + sin42*s34
2550 : 1043464738 : z(1,j1,ia*ntb+bef(i)+ib,j2) = r - sin2*s
2551 : 1043464738 : z(1,j1,ia*ntb+4*bef(i)+ib,j2) = r + sin2*s
2552 : 1043464738 : r = r1 + cos4*r25 + cos2*r34
2553 : 1043464738 : s = sin42*s25 - s34
2554 : 1043464738 : z(1,j1,ia*ntb+2*bef(i)+ib,j2) = r - sin2*s
2555 : 1043464738 : z(1,j1,ia*ntb+3*bef(i)+ib,j2) = r + sin2*s
2556 : 1043464738 : r25 = r2 - r5
2557 : 1043464738 : r34 = r3 - r4
2558 : 1043464738 : s25 = s2 + s5
2559 : 1043464738 : s34 = s3 + s4
2560 : 1043464738 : z(2,j1,ia*ntb+ib,j2) = s1 + s25 + s34
2561 : 1043464738 : r = s1 + cos2*s25 + cos4*s34
2562 : 1043464738 : s = r25 + sin42*r34
2563 : 1043464738 : z(2,j1,ia*ntb+bef(i)+ib,j2) = r + sin2*s
2564 : 1043464738 : z(2,j1,ia*ntb+4*bef(i)+ib,j2) = r - sin2*s
2565 : 1043464738 : r = s1 + cos4*s25 + cos2*s34
2566 : 1043464738 : s = sin42*r25 - r34
2567 : 1043464738 : z(2,j1,ia*ntb+2*bef(i)+ib,j2) = r + sin2*s
2568 : 1107913731 : z(2,j1,ia*ntb+3*bef(i)+ib,j2) = r - sin2*s
2569 : : end do
2570 : : end do
2571 : :
2572 : : ! Second step of radix 5
2573 [ + + ]: 20487723 : do ia=1,aft(i)-1
2574 : 478296 : indx=ind(ia*5*bef(i)+1)-1
2575 : 478296 : indx=indx*bef(i)
2576 : 478296 : cr2=trig(1,indx)
2577 : 478296 : ct2=trig(2,indx)
2578 : 478296 : cr3=trig(1,2*indx)
2579 : 478296 : ct3=trig(2,2*indx)
2580 : 478296 : cr4=trig(1,3*indx)
2581 : 478296 : ct4=trig(2,3*indx)
2582 : 478296 : cr5=trig(1,4*indx)
2583 : 478296 : ct5=trig(2,4*indx)
2584 [ + + ]: 22328107 : do ib=1,bef(i)
2585 [ + + ]: 66632024 : do j1=n1i,n1
2586 : 64313344 : r1=z(1,j1,ia*ntb+ib,j2)
2587 : 64313344 : s1=z(2,j1,ia*ntb+ib,j2)
2588 : : r2=cr2*(z(1,j1,ia*ntb+bef(i)+ib,j2) - &
2589 : 64313344 : & z(2,j1,ia*ntb+bef(i)+ib,j2)*ct2)
2590 : : s2=cr2*(z(1,j1,ia*ntb+bef(i)+ib,j2)*ct2 + &
2591 : 64313344 : & z(2,j1,ia*ntb+bef(i)+ib,j2))
2592 : : r3=cr3*(z(1,j1,ia*ntb+2*bef(i)+ib,j2) - &
2593 : 64313344 : & z(2,j1,ia*ntb+2*bef(i)+ib,j2)*ct3)
2594 : : s3=cr3*(z(1,j1,ia*ntb+2*bef(i)+ib,j2)*ct3 + &
2595 : 64313344 : & z(2,j1,ia*ntb+2*bef(i)+ib,j2))
2596 : : r4=z(1,j1,ia*ntb+3*bef(i)+ib,j2) - &
2597 : 64313344 : & z(2,j1,ia*ntb+3*bef(i)+ib,j2)*ct4
2598 : : s4=z(1,j1,ia*ntb+3*bef(i)+ib,j2)*ct4 + &
2599 : 64313344 : & z(2,j1,ia*ntb+3*bef(i)+ib,j2)
2600 : : r5=z(1,j1,ia*ntb+4*bef(i)+ib,j2) - &
2601 : 64313344 : & z(2,j1,ia*ntb+4*bef(i)+ib,j2)*ct5
2602 : : s5=z(1,j1,ia*ntb+4*bef(i)+ib,j2)*ct5 + &
2603 : 64313344 : & z(2,j1,ia*ntb+4*bef(i)+ib,j2)
2604 : 64313344 : r25 = r2 + r5*cr5
2605 : 64313344 : r34 = r3 + r4*cr4
2606 : 64313344 : s25 = s2 - s5*cr5
2607 : 64313344 : s34 = s3 - s4*cr4
2608 : 64313344 : z(1,j1,ia*ntb+ib,j2) = r1 + r25 + r34
2609 : 64313344 : r = r1 + cos2*r25 + cos4*r34
2610 : 64313344 : s = s25 + sin42*s34
2611 : 64313344 : z(1,j1,ia*ntb+bef(i)+ib,j2) = r - sin2*s
2612 : 64313344 : z(1,j1,ia*ntb+4*bef(i)+ib,j2) = r + sin2*s
2613 : 64313344 : r = r1 + cos4*r25 + cos2*r34
2614 : 64313344 : s = sin42*s25 - s34
2615 : 64313344 : z(1,j1,ia*ntb+2*bef(i)+ib,j2) = r - sin2*s
2616 : 64313344 : z(1,j1,ia*ntb+3*bef(i)+ib,j2) = r + sin2*s
2617 : 64313344 : r25 = r2 - r5*cr5
2618 : 64313344 : r34 = r3 - r4*cr4
2619 : 64313344 : s25 = s2 + s5*cr5
2620 : 64313344 : s34 = s3 + s4*cr4
2621 : 64313344 : z(2,j1,ia*ntb+ib,j2) = s1 + s25 + s34
2622 : 64313344 : r = s1 + cos2*s25 + cos4*s34
2623 : 64313344 : s = r25 + sin42*r34
2624 : 64313344 : z(2,j1,ia*ntb+bef(i)+ib,j2) = r + sin2*s
2625 : 64313344 : z(2,j1,ia*ntb+4*bef(i)+ib,j2) = r - sin2*s
2626 : 64313344 : r = s1 + cos4*s25 + cos2*s34
2627 : 64313344 : s = sin42*r25 - r34
2628 : 64313344 : z(2,j1,ia*ntb+2*bef(i)+ib,j2) = r + sin2*s
2629 : 66153728 : z(2,j1,ia*ntb+3*bef(i)+ib,j2) = r - sin2*s
2630 : : end do
2631 : : end do
2632 : : end do
2633 : :
2634 : : else
2635 : : ! All radices treated
2636 : 0 : ABI_BUG('called with factors other than 2, 3, and 5')
2637 : : end if
2638 : :
2639 : : end do
2640 : :
2641 : : ! ---------------------------------------------------------------
2642 : :
2643 : : ! bitreversal
2644 : :
2645 : : ! Treat radix 4
2646 [ + + ]: 79867040 : if (now(ic)==4) then
2647 : 5138399 : ia=0
2648 : :
2649 : : ! First step of radix 4
2650 [ + + ]: 92640533 : do j1=n1i,n1
2651 : 87502134 : r4=z(1,j1,ia*4+4,j2)
2652 : 87502134 : s4=z(2,j1,ia*4+4,j2)
2653 : 87502134 : r3=z(1,j1,ia*4+3,j2)
2654 : 87502134 : s3=z(2,j1,ia*4+3,j2)
2655 : 87502134 : r2=z(1,j1,ia*4+2,j2)
2656 : 87502134 : s2=z(2,j1,ia*4+2,j2)
2657 : 87502134 : r1=z(1,j1,ia*4+1,j2)
2658 : 87502134 : s1=z(2,j1,ia*4+1,j2)
2659 : :
2660 : 87502134 : r=r1 + r3
2661 : 87502134 : s=r2 + r4
2662 : 87502134 : zbr(1,j1,ind(ia*4+1),j2) = r + s
2663 : 87502134 : zbr(1,j1,ind(ia*4+3),j2) = r - s
2664 : 87502134 : r=r1 - r3
2665 : 87502134 : s=s2 - s4
2666 : 87502134 : zbr(1,j1,ind(ia*4+2),j2) = r - s*ris
2667 : 87502134 : zbr(1,j1,ind(ia*4+4),j2) = r + s*ris
2668 : 87502134 : r=s1 + s3
2669 : 87502134 : s=s2 + s4
2670 : 87502134 : zbr(2,j1,ind(ia*4+1),j2) = r + s
2671 : 87502134 : zbr(2,j1,ind(ia*4+3),j2) = r - s
2672 : 87502134 : r=s1 - s3
2673 : 87502134 : s=r2 - r4
2674 : 87502134 : zbr(2,j1,ind(ia*4+2),j2) = r + s*ris
2675 : 92640533 : zbr(2,j1,ind(ia*4+4),j2) = r - s*ris
2676 : : end do
2677 : :
2678 : : ! Second step of radix 4
2679 [ + + ]: 24644714 : do ia=1,aft(ic)-1
2680 : 19506315 : indx=ind(ia*4+1)-1
2681 : 19506315 : cr2=trig(1,indx)
2682 : 19506315 : ct2=trig(2,indx)
2683 : 19506315 : cr3=trig(1,2*indx)
2684 : 19506315 : ct3=trig(2,2*indx)
2685 : 19506315 : cr4=trig(1,3*indx)
2686 : 19506315 : ct4=trig(2,3*indx)
2687 : 19506315 : cr4=cr4/cr2
2688 : 19506315 : cr2s=cr2*ris
2689 [ + + ]: 398121091 : do j1=n1i,n1
2690 : 373476377 : r4=z(1,j1,ia*4+4,j2) - z(2,j1,ia*4+4,j2)*ct4
2691 : 373476377 : s4=z(1,j1,ia*4+4,j2)*ct4 + z(2,j1,ia*4+4,j2)
2692 : 373476377 : r3=z(1,j1,ia*4+3,j2) - z(2,j1,ia*4+3,j2)*ct3
2693 : 373476377 : s3=z(1,j1,ia*4+3,j2)*ct3 + z(2,j1,ia*4+3,j2)
2694 : 373476377 : r2=z(1,j1,ia*4+2,j2) - z(2,j1,ia*4+2,j2)*ct2
2695 : 373476377 : s2=z(1,j1,ia*4+2,j2)*ct2 + z(2,j1,ia*4+2,j2)
2696 : 373476377 : r1=z(1,j1,ia*4+1,j2)
2697 : 373476377 : s1=z(2,j1,ia*4+1,j2)
2698 : :
2699 : 373476377 : r=r1 + r3*cr3
2700 : 373476377 : s=r2 + r4*cr4
2701 : 373476377 : zbr(1,j1,ind(ia*4+1),j2) = r + s*cr2
2702 : 373476377 : zbr(1,j1,ind(ia*4+3),j2) = r - s*cr2
2703 : 373476377 : r=r1 - r3*cr3
2704 : 373476377 : s=s2 - s4*cr4
2705 : 373476377 : zbr(1,j1,ind(ia*4+2),j2) = r - s*cr2s
2706 : 373476377 : zbr(1,j1,ind(ia*4+4),j2) = r + s*cr2s
2707 : 373476377 : r=s1 + s3*cr3
2708 : 373476377 : s=s2 + s4*cr4
2709 : 373476377 : zbr(2,j1,ind(ia*4+1),j2) = r + s*cr2
2710 : 373476377 : zbr(2,j1,ind(ia*4+3),j2) = r - s*cr2
2711 : 373476377 : r=s1 - s3*cr3
2712 : 373476377 : s=r2 - r4*cr4
2713 : 373476377 : zbr(2,j1,ind(ia*4+2),j2) = r + s*cr2s
2714 : 392982692 : zbr(2,j1,ind(ia*4+4),j2) = r - s*cr2s
2715 : : end do
2716 : : end do
2717 : :
2718 : : ! Treat radix 2
2719 [ + + ]: 35463876 : else if (now(ic)==2) then
2720 : 15371745 : ia=0
2721 : :
2722 : : ! First step of radix 2
2723 [ + + ]: 273885279 : do j1=n1i,n1
2724 : 258513534 : r1=z(1,j1,ia*2+1,j2)
2725 : 258513534 : s1=z(2,j1,ia*2+1,j2)
2726 : 258513534 : r2=z(1,j1,ia*2+2,j2)
2727 : 258513534 : s2=z(2,j1,ia*2+2,j2)
2728 : 258513534 : zbr(1,j1,ind(ia*2+1),j2) = r2 + r1
2729 : 258513534 : zbr(2,j1,ind(ia*2+1),j2) = s2 + s1
2730 : 258513534 : zbr(1,j1,ind(ia*2+2),j2) = -r2 + r1
2731 : 273885279 : zbr(2,j1,ind(ia*2+2),j2) = -s2 + s1
2732 : : end do
2733 : :
2734 : : ! Second step of radix 2
2735 [ + + ]: 148960297 : do ia=1,aft(ic)-1
2736 : 133588552 : indx=ind(ia*2+1)-1
2737 : 133588552 : cr2=trig(1,indx)
2738 : 133588552 : ct2=trig(2,indx)
2739 [ + + ]: 2514859337 : do j1=n1i,n1
2740 : 2365899040 : r1=z(1,j1,ia*2+1,j2)
2741 : 2365899040 : s1=z(2,j1,ia*2+1,j2)
2742 : 2365899040 : r2=z(1,j1,ia*2+2,j2) - z(2,j1,ia*2+2,j2)*ct2
2743 : 2365899040 : s2=z(1,j1,ia*2+2,j2)*ct2 + z(2,j1,ia*2+2,j2)
2744 : 2365899040 : zbr(1,j1,ind(ia*2+1),j2) = r2*cr2 + r1
2745 : 2365899040 : zbr(2,j1,ind(ia*2+1),j2) = s2*cr2 + s1
2746 : 2365899040 : zbr(1,j1,ind(ia*2+2),j2) = -r2*cr2 + r1
2747 : 2499487592 : zbr(2,j1,ind(ia*2+2),j2) = -s2*cr2 + s1
2748 : : end do
2749 : : end do
2750 : :
2751 : : ! Treat radix 3
2752 [ + - ]: 20092131 : else if (now(ic)==3) then
2753 : : ! .5d0*sqrt(3.d0)=0.8660254037844387d0
2754 : 20092131 : ia=0
2755 : 20092131 : bb=ris*0.8660254037844387d0
2756 : :
2757 : : ! First step of radix 3
2758 [ + + ]: 309231633 : do j1=n1i,n1
2759 : 289139502 : r1=z(1,j1,ia*3+1,j2)
2760 : 289139502 : s1=z(2,j1,ia*3+1,j2)
2761 : 289139502 : r2=z(1,j1,ia*3+2,j2)
2762 : 289139502 : s2=z(2,j1,ia*3+2,j2)
2763 : 289139502 : r3=z(1,j1,ia*3+3,j2)
2764 : 289139502 : s3=z(2,j1,ia*3+3,j2)
2765 : 289139502 : r=r2 + r3
2766 : 289139502 : s=s2 + s3
2767 : 289139502 : zbr(1,j1,ind(ia*3+1),j2) = r + r1
2768 : 289139502 : zbr(2,j1,ind(ia*3+1),j2) = s + s1
2769 : 289139502 : r1=r1 - r*.5d0
2770 : 289139502 : s1=s1 - s*.5d0
2771 : 289139502 : r2=r2-r3
2772 : 289139502 : s2=s2-s3
2773 : 289139502 : zbr(1,j1,ind(ia*3+2),j2) = r1 - s2*bb
2774 : 289139502 : zbr(2,j1,ind(ia*3+2),j2) = s1 + r2*bb
2775 : 289139502 : zbr(1,j1,ind(ia*3+3),j2) = r1 + s2*bb
2776 : 309231633 : zbr(2,j1,ind(ia*3+3),j2) = s1 - r2*bb
2777 : : end do
2778 : :
2779 : : ! Second step of radix 3
2780 [ + + ]: 98660165 : do ia=1,aft(ic)-1
2781 : 78568034 : indx=ind(ia*3+1)-1
2782 : 78568034 : cr2=trig(1,indx)
2783 : 78568034 : ct2=trig(2,indx)
2784 : 78568034 : cr3=trig(1,2*indx)
2785 : 78568034 : ct3=trig(2,2*indx)
2786 : 78568034 : cr2=cr2/cr3
2787 : 78568034 : cr3p=.5d0*cr3
2788 : 78568034 : bb=ris*cr3*0.8660254037844387d0
2789 [ + + ]: 1250181717 : do j1=n1i,n1
2790 : 1151521552 : r1=z(1,j1,ia*3+1,j2)
2791 : 1151521552 : s1=z(2,j1,ia*3+1,j2)
2792 : 1151521552 : r2=z(1,j1,ia*3+2,j2) - z(2,j1,ia*3+2,j2)*ct2
2793 : 1151521552 : s2=z(1,j1,ia*3+2,j2)*ct2 + z(2,j1,ia*3+2,j2)
2794 : 1151521552 : r3=z(1,j1,ia*3+3,j2) - z(2,j1,ia*3+3,j2)*ct3
2795 : 1151521552 : s3=z(1,j1,ia*3+3,j2)*ct3 + z(2,j1,ia*3+3,j2)
2796 : 1151521552 : r=cr2*r2 + r3
2797 : 1151521552 : s=cr2*s2 + s3
2798 : 1151521552 : zbr(1,j1,ind(ia*3+1),j2) = r*cr3 + r1
2799 : 1151521552 : zbr(2,j1,ind(ia*3+1),j2) = s*cr3 + s1
2800 : 1151521552 : r1=r1 - r*cr3p
2801 : 1151521552 : s1=s1 - s*cr3p
2802 : 1151521552 : r2=cr2*r2-r3
2803 : 1151521552 : s2=cr2*s2-s3
2804 : 1151521552 : zbr(1,j1,ind(ia*3+2),j2) = r1 - s2*bb
2805 : 1151521552 : zbr(2,j1,ind(ia*3+2),j2) = s1 + r2*bb
2806 : 1151521552 : zbr(1,j1,ind(ia*3+3),j2) = r1 + s2*bb
2807 : 1230089586 : zbr(2,j1,ind(ia*3+3),j2) = s1 - r2*bb
2808 : : end do
2809 : : end do
2810 : :
2811 : : ! Treat radix 5
2812 [ # # ]: 0 : else if (now(ic)==5) then
2813 : : ! sin(2.d0*pi/5.d0)
2814 : 0 : sin2=ris*0.9510565162951536d0
2815 : 0 : ia=0
2816 : :
2817 : : ! First step of radix 5
2818 [ # # ]: 0 : do j1=n1i,n1
2819 : 0 : r1=z(1,j1,ia*5+1,j2)
2820 : 0 : s1=z(2,j1,ia*5+1,j2)
2821 : 0 : r2=z(1,j1,ia*5+2,j2)
2822 : 0 : s2=z(2,j1,ia*5+2,j2)
2823 : 0 : r3=z(1,j1,ia*5+3,j2)
2824 : 0 : s3=z(2,j1,ia*5+3,j2)
2825 : 0 : r4=z(1,j1,ia*5+4,j2)
2826 : 0 : s4=z(2,j1,ia*5+4,j2)
2827 : 0 : r5=z(1,j1,ia*5+5,j2)
2828 : 0 : s5=z(2,j1,ia*5+5,j2)
2829 : 0 : r25 = r2 + r5
2830 : 0 : r34 = r3 + r4
2831 : 0 : s25 = s2 - s5
2832 : 0 : s34 = s3 - s4
2833 : 0 : zbr(1,j1,ind(ia*5+1),j2) = r1 + r25 + r34
2834 : 0 : r = r1 + cos2*r25 + cos4*r34
2835 : 0 : s = s25 + sin42*s34
2836 : 0 : zbr(1,j1,ind(ia*5+2),j2) = r - sin2*s
2837 : 0 : zbr(1,j1,ind(ia*5+5),j2) = r + sin2*s
2838 : 0 : r = r1 + cos4*r25 + cos2*r34
2839 : 0 : s = sin42*s25 - s34
2840 : 0 : zbr(1,j1,ind(ia*5+3),j2) = r - sin2*s
2841 : 0 : zbr(1,j1,ind(ia*5+4),j2) = r + sin2*s
2842 : 0 : r25 = r2 - r5
2843 : 0 : r34 = r3 - r4
2844 : 0 : s25 = s2 + s5
2845 : 0 : s34 = s3 + s4
2846 : 0 : zbr(2,j1,ind(ia*5+1),j2) = s1 + s25 + s34
2847 : 0 : r = s1 + cos2*s25 + cos4*s34
2848 : 0 : s = r25 + sin42*r34
2849 : 0 : zbr(2,j1,ind(ia*5+2),j2) = r + sin2*s
2850 : 0 : zbr(2,j1,ind(ia*5+5),j2) = r - sin2*s
2851 : 0 : r = s1 + cos4*s25 + cos2*s34
2852 : 0 : s = sin42*r25 - r34
2853 : 0 : zbr(2,j1,ind(ia*5+3),j2) = r + sin2*s
2854 : 0 : zbr(2,j1,ind(ia*5+4),j2) = r - sin2*s
2855 : : end do
2856 : :
2857 : : ! Second step of radix 5
2858 [ # # ]: 0 : do ia=1,aft(ic)-1
2859 : 0 : indx=ind(ia*5+1)-1
2860 : 0 : cr2=trig(1,indx)
2861 : 0 : ct2=trig(2,indx)
2862 : 0 : cr3=trig(1,2*indx)
2863 : 0 : ct3=trig(2,2*indx)
2864 : 0 : cr4=trig(1,3*indx)
2865 : 0 : ct4=trig(2,3*indx)
2866 : 0 : cr5=trig(1,4*indx)
2867 : 0 : ct5=trig(2,4*indx)
2868 [ # # ]: 0 : do j1=n1i,n1
2869 : 0 : r1=z(1,j1,ia*5+1,j2)
2870 : 0 : s1=z(2,j1,ia*5+1,j2)
2871 : 0 : r2=cr2*(z(1,j1,ia*5+2,j2) - z(2,j1,ia*5+2,j2)*ct2)
2872 : 0 : s2=cr2*(z(1,j1,ia*5+2,j2)*ct2 + z(2,j1,ia*5+2,j2))
2873 : 0 : r3=cr3*(z(1,j1,ia*5+3,j2) - z(2,j1,ia*5+3,j2)*ct3)
2874 : 0 : s3=cr3*(z(1,j1,ia*5+3,j2)*ct3 + z(2,j1,ia*5+3,j2))
2875 : 0 : r4=z(1,j1,ia*5+4,j2) - z(2,j1,ia*5+4,j2)*ct4
2876 : 0 : s4=z(1,j1,ia*5+4,j2)*ct4 + z(2,j1,ia*5+4,j2)
2877 : 0 : r5=z(1,j1,ia*5+5,j2) - z(2,j1,ia*5+5,j2)*ct5
2878 : 0 : s5=z(1,j1,ia*5+5,j2)*ct5 + z(2,j1,ia*5+5,j2)
2879 : 0 : r25 = r2 + r5*cr5
2880 : 0 : r34 = r3 + r4*cr4
2881 : 0 : s25 = s2 - s5*cr5
2882 : 0 : s34 = s3 - s4*cr4
2883 : 0 : zbr(1,j1,ind(ia*5+1),j2) = r1 + r25 + r34
2884 : 0 : r = r1 + cos2*r25 + cos4*r34
2885 : 0 : s = s25 + sin42*s34
2886 : 0 : zbr(1,j1,ind(ia*5+2),j2) = r - sin2*s
2887 : 0 : zbr(1,j1,ind(ia*5+5),j2) = r + sin2*s
2888 : 0 : r = r1 + cos4*r25 + cos2*r34
2889 : 0 : s = sin42*s25 - s34
2890 : 0 : zbr(1,j1,ind(ia*5+3),j2) = r - sin2*s
2891 : 0 : zbr(1,j1,ind(ia*5+4),j2) = r + sin2*s
2892 : 0 : r25 = r2 - r5*cr5
2893 : 0 : r34 = r3 - r4*cr4
2894 : 0 : s25 = s2 + s5*cr5
2895 : 0 : s34 = s3 + s4*cr4
2896 : 0 : zbr(2,j1,ind(ia*5+1),j2) = s1 + s25 + s34
2897 : 0 : r = s1 + cos2*s25 + cos4*s34
2898 : 0 : s = r25 + sin42*r34
2899 : 0 : zbr(2,j1,ind(ia*5+2),j2) = r + sin2*s
2900 : 0 : zbr(2,j1,ind(ia*5+5),j2) = r - sin2*s
2901 : 0 : r = s1 + cos4*s25 + cos2*s34
2902 : 0 : s = sin42*r25 - r34
2903 : 0 : zbr(2,j1,ind(ia*5+3),j2) = r + sin2*s
2904 : 0 : zbr(2,j1,ind(ia*5+4),j2) = r - sin2*s
2905 : : end do
2906 : : end do
2907 : :
2908 : : else
2909 : : ! All radices done
2910 : : !if (now(ic) /= 1) then
2911 : 0 : ABI_BUG(sjoin("Called with factors other than 2, 3, and 5. now(ic) = ", itoa(now(ic))))
2912 : : !end if
2913 : : end if
2914 : : end do
2915 : : !$OMP END PARALLEL DO
2916 : :
2917 : 39264765 : end subroutine sg_ffty
2918 : : !!***
2919 : :
2920 : : !----------------------------------------------------------------------
2921 : :
2922 : : !!****f* m_sgfft/sg_fftz
2923 : : !! NAME
2924 : : !! sg_fftz
2925 : : !!
2926 : : !! FUNCTION
2927 : : !! This subroutine is called by the 3-dimensional fft to conduct the
2928 : : !! "z" transforms for all x and y.
2929 : : !!
2930 : : !! INPUTS
2931 : : !! mfac = maximum number of factors in 1D FFTs
2932 : : !! mg = maximum length of 1D FFTs
2933 : : !! nd1=first dimension of (complex) arrays z and zbr (treated as real within
2934 : : !! this subroutine)
2935 : : !! nd2=second dimension of (complex) arrays z and zbr (treated as real within
2936 : : !! this subroutine)
2937 : : !! nd3=third dimension of (complex) arrays z and zbr (treated as real within
2938 : : !! this subroutine)
2939 : : !! n1=actual length of x and y transforms
2940 : : !! n2i=lower i2 index, used for blocking : the do-loop will be i2=n2i,n2
2941 : : !! put to 1 for usual ffty
2942 : : !! n2=upper i2 index, used for blocking, put usual n2 for usual ffty
2943 : : !! z(2,nd1,nd2,nd3)=INPUT array; destroyed by transformation
2944 : : !! trig, aft, now, bef, ind=provided by previous call to ctrig
2945 : : !! Note that in this routine (and in ctrig) the values in array trig are
2946 : : !! actually cos and tan, not cos and sin. Use of tan allows advantageous
2947 : : !! use of FMA on the ibm rs6000.
2948 : : !! ris=sign of exponential in transform (should be 1 or -1; real)
2949 : : !! ic=number of (radix) factors of x transform length (from ctrig)
2950 : : !!
2951 : : !! OUTPUT
2952 : : !! zbr(2,nd1,nd2,nd3)=OUTPUT transformed array; no scaling applied
2953 : : !!
2954 : : !! TODO
2955 : : !! Use latex for the equation above
2956 : : !!
2957 : : !! SOURCE
2958 : :
2959 : 568051 : subroutine sg_fftz(mfac,mg,nd1,nd2,nd3,n1,n2i,n2,z,zbr,trig,aft,now,bef,ris,ind,ic)
2960 : :
2961 : : !Arguments ------------------------------------
2962 : : !Dimensions of aft, now, bef, ind, and trig should agree with
2963 : : !those in subroutine ctrig.
2964 : : !scalars
2965 : : integer,intent(in) :: ic,mfac,mg,n1,n2,n2i,nd1,nd2,nd3
2966 : : real(dp),intent(in) :: ris
2967 : : !arrays
2968 : : integer,intent(in) :: aft(mfac),bef(mfac),ind(mg),now(mfac)
2969 : : real(dp),intent(in) :: trig(2,mg)
2970 : : real(dp),intent(inout) :: z(2,nd1,nd2,nd3),zbr(2,nd1,nd2,nd3)
2971 : :
2972 : : !Local variables-------------------------------
2973 : : !scalars
2974 : : integer :: b_i,i,i2,ia,ib,indx,j,ntb
2975 : : real(dp),parameter :: cos2=0.3090169943749474d0 !cos(2.d0*pi/5.d0)
2976 : : real(dp),parameter :: cos4=-0.8090169943749474d0 !cos(4.d0*pi/5.d0)
2977 : : real(dp),parameter :: sin42=0.6180339887498948d0 !sin(4.d0*pi/5.d0)/sin(2.d0*pi/5.d0)
2978 : : real(dp) :: bb,cr2,cr2s,cr3,cr3p,cr4,cr5,ct2,ct3,ct4,ct5
2979 : : real(dp) :: r,r1,r2,r25,r3,r34,r4,r5,s,sin2,s1,s2,s25,s3,s34,s4,s5
2980 : :
2981 : : ! *************************************************************************
2982 : :
2983 : : !n12 occurs as a loop index repeated below; do z transform while
2984 : : !looping over all n12 lines of data
2985 : :
2986 : : !Direct transformation (to ic-1), bitreversal will be in second part
2987 : : !of routine
2988 : :
2989 [ + + ]: 1661615 : do i=1,ic-1
2990 : 1093564 : ntb=now(i)*bef(i)
2991 : 1093564 : b_i=bef(i)
2992 : :
2993 : : ! Treat radix 4
2994 [ + + ]: 1661615 : if (now(i)==4) then
2995 : 2428804 : ia=0
2996 : :
2997 : : ! First step of radix 4
2998 [ + + ]: 2428804 : do ib=1,b_i
2999 : : !$OMP PARALLEL DO DEFAULT(PRIVATE)&
3000 : : !$OMP&SHARED(b_i,ia,ib,n1,n2i,n2,ntb,ris,z)
3001 [ + + ]: 4492374 : do i2=n2i,n2
3002 [ + + ]: 41891976 : do j=1,n1
3003 : 37764836 : r4=z(1,j,i2,ia*ntb+3*b_i+ib)
3004 : 37764836 : s4=z(2,j,i2,ia*ntb+3*b_i+ib)
3005 : 37764836 : r3=z(1,j,i2,ia*ntb+2*b_i+ib)
3006 : 37764836 : s3=z(2,j,i2,ia*ntb+2*b_i+ib)
3007 : 37764836 : r2=z(1,j,i2,ia*ntb+b_i+ib)
3008 : 37764836 : s2=z(2,j,i2,ia*ntb+b_i+ib)
3009 : 37764836 : r1=z(1,j,i2,ia*ntb+ib)
3010 : 37764836 : s1=z(2,j,i2,ia*ntb+ib)
3011 : :
3012 : 37764836 : r=r1 + r3
3013 : 37764836 : s=r2 + r4
3014 : 37764836 : z(1,j,i2,ia*ntb+ib) = r + s
3015 : 37764836 : z(1,j,i2,ia*ntb+2*b_i+ib) = r - s
3016 : 37764836 : r=r1 - r3
3017 : 37764836 : s=s2 - s4
3018 : 37764836 : z(1,j,i2,ia*ntb+b_i+ib) = r - s*ris
3019 : 37764836 : z(1,j,i2,ia*ntb+3*b_i+ib) = r + s*ris
3020 : 37764836 : r=s1 + s3
3021 : 37764836 : s=s2 + s4
3022 : 37764836 : z(2,j,i2,ia*ntb+ib) = r + s
3023 : 37764836 : z(2,j,i2,ia*ntb+2*b_i+ib) = r - s
3024 : 37764836 : r=s1 - s3
3025 : 37764836 : s=r2 - r4
3026 : 37764836 : z(2,j,i2,ia*ntb+b_i+ib) = r + s*ris
3027 : 39828406 : z(2,j,i2,ia*ntb+3*b_i+ib) = r - s*ris
3028 : : end do ! j
3029 : : end do ! i2
3030 : : !$OMP END PARALLEL DO
3031 : : end do ! ib
3032 : :
3033 : : ! Second step of radix 4
3034 [ + + ]: 1054530 : do ia=1,aft(i)-1
3035 : 689296 : indx=ind(ia*4*b_i+1)-1
3036 : 689296 : indx=indx*b_i
3037 : 689296 : cr2=trig(1,indx)
3038 : 689296 : ct2=trig(2,indx)
3039 : 689296 : cr3=trig(1,2*indx)
3040 : 689296 : ct3=trig(2,2*indx)
3041 : 689296 : cr4=trig(1,3*indx)
3042 : 689296 : ct4=trig(2,3*indx)
3043 : 689296 : cr4=cr4/cr2
3044 : 689296 : cr2s=cr2*ris
3045 [ + + ]: 2899832 : do ib=1,b_i
3046 : : !$OMP PARALLEL DO DEFAULT(PRIVATE)&
3047 : : !$OMP&SHARED(b_i,cr2,cr3,cr4,ct2,cr2s,ct3,ct4,i,ia,ib,n1,n2i,n2,ntb,ris,z)
3048 [ + + ]: 4379900 : do i2=n2i,n2
3049 [ + + ]: 59223476 : do j=1,n1
3050 : : r4=z(1,j,i2,ia*ntb+3*b_i+ib) - &
3051 : 55532872 : & z(2,j,i2,ia*ntb+3*b_i+ib)*ct4
3052 : : s4=z(1,j,i2,ia*ntb+3*b_i+ib)*ct4 + &
3053 : 55532872 : & z(2,j,i2,ia*ntb+3*b_i+ib)
3054 : : r3=z(1,j,i2,ia*ntb+2*b_i+ib) - &
3055 : 55532872 : & z(2,j,i2,ia*ntb+2*b_i+ib)*ct3
3056 : : s3=z(1,j,i2,ia*ntb+2*b_i+ib)*ct3 + &
3057 : 55532872 : & z(2,j,i2,ia*ntb+2*b_i+ib)
3058 : : r2=z(1,j,i2,ia*ntb+b_i+ib) - &
3059 : 55532872 : & z(2,j,i2,ia*ntb+b_i+ib)*ct2
3060 : : s2=z(1,j,i2,ia*ntb+b_i+ib)*ct2 + &
3061 : 55532872 : & z(2,j,i2,ia*ntb+b_i+ib)
3062 : 55532872 : r1=z(1,j,i2,ia*ntb+ib)
3063 : 55532872 : s1=z(2,j,i2,ia*ntb+ib)
3064 : :
3065 : 55532872 : r=r1 + r3*cr3
3066 : 55532872 : s=r2 + r4*cr4
3067 : 55532872 : z(1,j,i2,ia*ntb+ib) = r + s*cr2
3068 : 55532872 : z(1,j,i2,ia*ntb+2*b_i+ib) = r - s*cr2
3069 : 55532872 : r=r1 - r3*cr3
3070 : 55532872 : s=s2 - s4*cr4
3071 : 55532872 : z(1,j,i2,ia*ntb+b_i+ib) = r - s*cr2s
3072 : 55532872 : z(1,j,i2,ia*ntb+3*b_i+ib) = r + s*cr2s
3073 : 55532872 : r=s1 + s3*cr3
3074 : 55532872 : s=s2 + s4*cr4
3075 : 55532872 : z(2,j,i2,ia*ntb+ib) = r + s*cr2
3076 : 55532872 : z(2,j,i2,ia*ntb+2*b_i+ib) = r - s*cr2
3077 : 55532872 : r=s1 - s3*cr3
3078 : 55532872 : s=r2 - r4*cr4
3079 : 55532872 : z(2,j,i2,ia*ntb+b_i+ib) = r + s*cr2s
3080 : 57378174 : z(2,j,i2,ia*ntb+3*b_i+ib) = r - s*cr2s
3081 : : end do ! j
3082 : : end do ! i2
3083 : : !$OMP END PARALLEL DO
3084 : : end do ! ib
3085 : :
3086 : : end do ! ia
3087 : :
3088 : : ! Treat radix 2
3089 [ - + ]: 728330 : else if (now(i)==2) then
3090 : 0 : ia=0
3091 : :
3092 : : ! First step of radix 2
3093 [ # # ]: 0 : do ib=1,b_i
3094 : : !$OMP PARALLEL DO DEFAULT(PRIVATE)&
3095 : : !$OMP&SHARED(b_i,ia,ib,n1,n2,n2i,ntb,z)
3096 [ # # ]: 0 : do i2=n2i,n2
3097 [ # # ]: 0 : do j=1,n1
3098 : 0 : r1=z(1,j,i2,ia*ntb+ib)
3099 : 0 : s1=z(2,j,i2,ia*ntb+ib)
3100 : 0 : r2=z(1,j,i2,ia*ntb+b_i+ib)
3101 : 0 : s2=z(2,j,i2,ia*ntb+b_i+ib)
3102 : 0 : z(1,j,i2,ia*ntb+ib) = r2 + r1
3103 : 0 : z(2,j,i2,ia*ntb+ib) = s2 + s1
3104 : 0 : z(1,j,i2,ia*ntb+b_i+ib) = -r2 + r1
3105 : 0 : z(2,j,i2,ia*ntb+b_i+ib) = -s2 + s1
3106 : : end do ! j
3107 : : end do ! i2
3108 : : !$OMP END PARALLEL DO
3109 : : end do ! ib
3110 : :
3111 : : ! Second step of radix 2
3112 [ # # ]: 0 : do ia=1,aft(i)-1
3113 : 0 : indx=ind(ia*2*b_i+1)-1
3114 : 0 : indx=indx*b_i
3115 : 0 : cr2=trig(1,indx)
3116 : 0 : ct2=trig(2,indx)
3117 [ # # ]: 0 : do ib=1,b_i
3118 : : !$OMP PARALLEL DO DEFAULT(PRIVATE)&
3119 : : !$OMP&SHARED(b_i,cr2,ct2,ia,ib,n1,n2,n2i,ntb,z)
3120 [ # # ]: 0 : do i2=n2i,n2
3121 [ # # ]: 0 : do j=1,n1
3122 : 0 : r1=z(1,j,i2,ia*ntb+ib)
3123 : 0 : s1=z(2,j,i2,ia*ntb+ib)
3124 : : r2=z(1,j,i2,ia*ntb+b_i+ib) - &
3125 : 0 : & z(2,j,i2,ia*ntb+b_i+ib)*ct2
3126 : : s2=z(1,j,i2,ia*ntb+b_i+ib)*ct2 + &
3127 : 0 : & z(2,j,i2,ia*ntb+b_i+ib)
3128 : 0 : z(1,j,i2,ia*ntb+ib) = r2*cr2 + r1
3129 : 0 : z(2,j,i2,ia*ntb+ib) = s2*cr2 + s1
3130 : 0 : z(1,j,i2,ia*ntb+b_i+ib) = -r2*cr2 + r1
3131 : 0 : z(2,j,i2,ia*ntb+b_i+ib) = -s2*cr2 + s1
3132 : : end do ! j
3133 : : end do ! i2
3134 : : !$OMP END PARALLEL DO
3135 : : end do ! ib
3136 : :
3137 : : end do ! ia
3138 : :
3139 : : ! Treat radix 3
3140 [ + + ]: 728330 : else if (now(i)==3) then
3141 : : ! .5d0*sqrt(3.d0)=0.8660254037844387d0
3142 : 341419 : ia=0
3143 : 341419 : bb=ris*0.8660254037844387d0
3144 : :
3145 : : ! First step of radix 3
3146 [ + + ]: 1633851 : do ib=1,b_i
3147 : : !$OMP PARALLEL DO DEFAULT(PRIVATE)&
3148 : : !$OMP&SHARED(bb,b_i,ia,ib,n1,n2,n2i,ntb,z)
3149 [ + + ]: 2926283 : do i2=n2i,n2
3150 [ + + ]: 27359760 : do j=1,n1
3151 : 24774896 : r1=z(1,j,i2,ia*ntb+ib)
3152 : 24774896 : s1=z(2,j,i2,ia*ntb+ib)
3153 : 24774896 : r2=z(1,j,i2,ia*ntb+b_i+ib)
3154 : 24774896 : s2=z(2,j,i2,ia*ntb+b_i+ib)
3155 : 24774896 : r3=z(1,j,i2,ia*ntb+2*b_i+ib)
3156 : 24774896 : s3=z(2,j,i2,ia*ntb+2*b_i+ib)
3157 : 24774896 : r=r2 + r3
3158 : 24774896 : s=s2 + s3
3159 : 24774896 : z(1,j,i2,ia*ntb+ib) = r + r1
3160 : 24774896 : z(2,j,i2,ia*ntb+ib) = s + s1
3161 : 24774896 : r1=r1 - r*.5d0
3162 : 24774896 : s1=s1 - s*.5d0
3163 : 24774896 : r2=r2-r3
3164 : 24774896 : s2=s2-s3
3165 : 24774896 : z(1,j,i2,ia*ntb+b_i+ib) = r1 - s2*bb
3166 : 24774896 : z(2,j,i2,ia*ntb+b_i+ib) = s1 + r2*bb
3167 : 24774896 : z(1,j,i2,ia*ntb+2*b_i+ib) = r1 + s2*bb
3168 : 26067328 : z(2,j,i2,ia*ntb+2*b_i+ib) = s1 - r2*bb
3169 : : end do ! j
3170 : : end do ! i2
3171 : : !$OMP END PARALLEL DO
3172 : : end do ! ib
3173 : :
3174 : : ! Second step of radix 3
3175 [ + + ]: 1304172 : do ia=1,aft(i)-1
3176 : 962753 : indx=ind(ia*3*b_i+1)-1
3177 : 962753 : indx=indx*b_i
3178 : 962753 : cr2=trig(1,indx)
3179 : 962753 : ct2=trig(2,indx)
3180 : 962753 : cr3=trig(1,2*indx)
3181 : 962753 : ct3=trig(2,2*indx)
3182 : 962753 : cr2=cr2/cr3
3183 : 962753 : cr3p=.5d0*cr3
3184 : 962753 : bb=ris*cr3*0.8660254037844387d0
3185 [ + + ]: 3741094 : do ib=1,b_i
3186 : : !$OMP PARALLEL DO DEFAULT(PRIVATE)&
3187 : : !$OMP&SHARED(bb,b_i,cr2,cr3,cr3p,ct2,ct3,ia,ib,n1,n2,n2i,ntb,z)
3188 [ + + ]: 5836597 : do i2=n2i,n2
3189 [ + + ]: 91060992 : do j=1,n1
3190 : 86187148 : r1=z(1,j,i2,ia*ntb+ib)
3191 : 86187148 : s1=z(2,j,i2,ia*ntb+ib)
3192 : : r2=z(1,j,i2,ia*ntb+b_i+ib) - &
3193 : 86187148 : & z(2,j,i2,ia*ntb+b_i+ib)*ct2
3194 : : s2=z(1,j,i2,ia*ntb+b_i+ib)*ct2 + &
3195 : 86187148 : & z(2,j,i2,ia*ntb+b_i+ib)
3196 : : r3=z(1,j,i2,ia*ntb+2*b_i+ib) - &
3197 : 86187148 : & z(2,j,i2,ia*ntb+2*b_i+ib)*ct3
3198 : : s3=z(1,j,i2,ia*ntb+2*b_i+ib)*ct3 + &
3199 : 86187148 : & z(2,j,i2,ia*ntb+2*b_i+ib)
3200 : 86187148 : r=cr2*r2 + r3
3201 : 86187148 : s=cr2*s2 + s3
3202 : 86187148 : z(1,j,i2,ia*ntb+ib) = r*cr3 + r1
3203 : 86187148 : z(2,j,i2,ia*ntb+ib) = s*cr3 + s1
3204 : 86187148 : r1=r1 - r*cr3p
3205 : 86187148 : s1=s1 - s*cr3p
3206 : 86187148 : r2=cr2*r2-r3
3207 : 86187148 : s2=cr2*s2-s3
3208 : 86187148 : z(1,j,i2,ia*ntb+b_i+ib) = r1 - s2*bb
3209 : 86187148 : z(2,j,i2,ia*ntb+b_i+ib) = s1 + r2*bb
3210 : 86187148 : z(1,j,i2,ia*ntb+2*b_i+ib) = r1 + s2*bb
3211 : 88624070 : z(2,j,i2,ia*ntb+2*b_i+ib) = s1 - r2*bb
3212 : : end do ! j
3213 : : end do ! i2
3214 : : !$OMP END PARALLEL DO
3215 : : end do ! ib
3216 : :
3217 : : end do ! ia
3218 : :
3219 : : ! Treat radix 5
3220 [ + - ]: 386911 : else if (now(i)==5) then
3221 : 386911 : sin2=ris*0.9510565162951536d0
3222 : 386911 : ia=0
3223 : :
3224 : : ! First step of radix 5
3225 [ + + ]: 3759098 : do ib=1,b_i
3226 : : !$OMP PARALLEL DO DEFAULT(PRIVATE)&
3227 : : !$OMP&SHARED(b_i,ia,ib,n1,n2,n2i,ntb,sin2,z)
3228 [ + + ]: 7131285 : do i2=n2i,n2
3229 [ + + ]: 193795733 : do j=1,n1
3230 : 187051359 : r1=z(1,j,i2,ia*ntb+ib)
3231 : 187051359 : s1=z(2,j,i2,ia*ntb+ib)
3232 : 187051359 : r2=z(1,j,i2,ia*ntb+b_i+ib)
3233 : 187051359 : s2=z(2,j,i2,ia*ntb+b_i+ib)
3234 : 187051359 : r3=z(1,j,i2,ia*ntb+2*b_i+ib)
3235 : 187051359 : s3=z(2,j,i2,ia*ntb+2*b_i+ib)
3236 : 187051359 : r4=z(1,j,i2,ia*ntb+3*b_i+ib)
3237 : 187051359 : s4=z(2,j,i2,ia*ntb+3*b_i+ib)
3238 : 187051359 : r5=z(1,j,i2,ia*ntb+4*b_i+ib)
3239 : 187051359 : s5=z(2,j,i2,ia*ntb+4*b_i+ib)
3240 : 187051359 : r25 = r2 + r5
3241 : 187051359 : r34 = r3 + r4
3242 : 187051359 : s25 = s2 - s5
3243 : 187051359 : s34 = s3 - s4
3244 : 187051359 : z(1,j,i2,ia*ntb+ib) = r1 + r25 + r34
3245 : 187051359 : r = r1 + cos2*r25 + cos4*r34
3246 : 187051359 : s = s25 + sin42*s34
3247 : 187051359 : z(1,j,i2,ia*ntb+b_i+ib) = r - sin2*s
3248 : 187051359 : z(1,j,i2,ia*ntb+4*b_i+ib) = r + sin2*s
3249 : 187051359 : r = r1 + cos4*r25 + cos2*r34
3250 : 187051359 : s = sin42*s25 - s34
3251 : 187051359 : z(1,j,i2,ia*ntb+2*b_i+ib) = r - sin2*s
3252 : 187051359 : z(1,j,i2,ia*ntb+3*b_i+ib) = r + sin2*s
3253 : 187051359 : r25 = r2 - r5
3254 : 187051359 : r34 = r3 - r4
3255 : 187051359 : s25 = s2 + s5
3256 : 187051359 : s34 = s3 + s4
3257 : 187051359 : z(2,j,i2,ia*ntb+ib) = s1 + s25 + s34
3258 : 187051359 : r = s1 + cos2*s25 + cos4*s34
3259 : 187051359 : s = r25 + sin42*r34
3260 : 187051359 : z(2,j,i2,ia*ntb+b_i+ib) = r + sin2*s
3261 : 187051359 : z(2,j,i2,ia*ntb+4*b_i+ib) = r - sin2*s
3262 : 187051359 : r = s1 + cos4*s25 + cos2*s34
3263 : 187051359 : s = sin42*r25 - r34
3264 : 187051359 : z(2,j,i2,ia*ntb+2*b_i+ib) = r + sin2*s
3265 : 190423546 : z(2,j,i2,ia*ntb+3*b_i+ib) = r - sin2*s
3266 : : end do ! j
3267 : : end do ! i2
3268 : : !$OMP END PARALLEL DO
3269 : : end do ! ib
3270 : :
3271 : : ! Second step of radix 5
3272 [ + + ]: 619791 : do ia=1,aft(i)-1
3273 : 232880 : indx=ind(ia*5*b_i+1)-1
3274 : 232880 : indx=indx*b_i
3275 : 232880 : cr2=trig(1,indx)
3276 : 232880 : ct2=trig(2,indx)
3277 : 232880 : cr3=trig(1,2*indx)
3278 : 232880 : ct3=trig(2,2*indx)
3279 : 232880 : cr4=trig(1,3*indx)
3280 : 232880 : ct4=trig(2,3*indx)
3281 : 232880 : cr5=trig(1,4*indx)
3282 : 232880 : ct5=trig(2,4*indx)
3283 [ + + ]: 1405551 : do ib=1,b_i
3284 : : !$OMP PARALLEL DO DEFAULT(PRIVATE)&
3285 : : !$OMP&SHARED(b_i,cr2,cr3,cr4,cr5,ct2,ct3,ct4,ct5,ia,ib,n1,n2,n2i,ntb,sin2,z)
3286 [ + + ]: 1804400 : do i2=n2i,n2
3287 [ + + ]: 68327552 : do j=1,n1
3288 : 66756032 : r1=z(1,j,i2,ia*ntb+ib)
3289 : 66756032 : s1=z(2,j,i2,ia*ntb+ib)
3290 : : r2=cr2*(z(1,j,i2,ia*ntb+b_i+ib) - &
3291 : 66756032 : & z(2,j,i2,ia*ntb+b_i+ib)*ct2)
3292 : : s2=cr2*(z(1,j,i2,ia*ntb+b_i+ib)*ct2 + &
3293 : 66756032 : & z(2,j,i2,ia*ntb+b_i+ib))
3294 : : r3=cr3*(z(1,j,i2,ia*ntb+2*b_i+ib) - &
3295 : 66756032 : & z(2,j,i2,ia*ntb+2*b_i+ib)*ct3)
3296 : : s3=cr3*(z(1,j,i2,ia*ntb+2*b_i+ib)*ct3 + &
3297 : 66756032 : & z(2,j,i2,ia*ntb+2*b_i+ib))
3298 : : r4=z(1,j,i2,ia*ntb+3*b_i+ib) - &
3299 : 66756032 : & z(2,j,i2,ia*ntb+3*b_i+ib)*ct4
3300 : : s4=z(1,j,i2,ia*ntb+3*b_i+ib)*ct4 + &
3301 : 66756032 : & z(2,j,i2,ia*ntb+3*b_i+ib)
3302 : : r5=z(1,j,i2,ia*ntb+4*b_i+ib) - &
3303 : 66756032 : & z(2,j,i2,ia*ntb+4*b_i+ib)*ct5
3304 : : s5=z(1,j,i2,ia*ntb+4*b_i+ib)*ct5 + &
3305 : 66756032 : & z(2,j,i2,ia*ntb+4*b_i+ib)
3306 : 66756032 : r25 = r2 + r5*cr5
3307 : 66756032 : r34 = r3 + r4*cr4
3308 : 66756032 : s25 = s2 - s5*cr5
3309 : 66756032 : s34 = s3 - s4*cr4
3310 : 66756032 : z(1,j,i2,ia*ntb+ib) = r1 + r25 + r34
3311 : 66756032 : r = r1 + cos2*r25 + cos4*r34
3312 : 66756032 : s = s25 + sin42*s34
3313 : 66756032 : z(1,j,i2,ia*ntb+b_i+ib) = r - sin2*s
3314 : 66756032 : z(1,j,i2,ia*ntb+4*b_i+ib) = r + sin2*s
3315 : 66756032 : r = r1 + cos4*r25 + cos2*r34
3316 : 66756032 : s = sin42*s25 - s34
3317 : 66756032 : z(1,j,i2,ia*ntb+2*b_i+ib) = r - sin2*s
3318 : 66756032 : z(1,j,i2,ia*ntb+3*b_i+ib) = r + sin2*s
3319 : 66756032 : r25 = r2 - r5*cr5
3320 : 66756032 : r34 = r3 - r4*cr4
3321 : 66756032 : s25 = s2 + s5*cr5
3322 : 66756032 : s34 = s3 + s4*cr4
3323 : 66756032 : z(2,j,i2,ia*ntb+ib) = s1 + s25 + s34
3324 : 66756032 : r = s1 + cos2*s25 + cos4*s34
3325 : 66756032 : s = r25 + sin42*r34
3326 : 66756032 : z(2,j,i2,ia*ntb+b_i+ib) = r + sin2*s
3327 : 66756032 : z(2,j,i2,ia*ntb+4*b_i+ib) = r - sin2*s
3328 : 66756032 : r = s1 + cos4*s25 + cos2*s34
3329 : 66756032 : s = sin42*r25 - r34
3330 : 66756032 : z(2,j,i2,ia*ntb+2*b_i+ib) = r + sin2*s
3331 : 67541792 : z(2,j,i2,ia*ntb+3*b_i+ib) = r - sin2*s
3332 : : end do ! j
3333 : : end do ! i2
3334 : : !$OMP END PARALLEL DO
3335 : : end do ! ib
3336 : :
3337 : : end do ! ia
3338 : :
3339 : : ! All radices treated
3340 : : else
3341 : 0 : ABI_BUG('called with factors other than 2, 3, and 5')
3342 : : end if
3343 : :
3344 : : ! End of direct transformation
3345 : : end do
3346 : :
3347 : : !------------------------------------------------------------
3348 : : !bitreversal (zbr is for z"bit-reversed")
3349 : :
3350 : : !Treat radix 4
3351 [ + + ]: 568051 : if (now(ic)==4) then
3352 : 76645 : ia=0
3353 : :
3354 : : ! First step of radix 4
3355 : : !$OMP PARALLEL DO DEFAULT(PRIVATE)&
3356 : : !$OMP&SHARED(ia,ind,n1,n2,n2i,ntb,ris,z,zbr)
3357 [ + + ]: 153290 : do i2=n2i,n2
3358 [ + + ]: 6628426 : do j=1,n1
3359 : 6475136 : r4=z(1,j,i2,ia*4+4)
3360 : 6475136 : s4=z(2,j,i2,ia*4+4)
3361 : 6475136 : r3=z(1,j,i2,ia*4+3)
3362 : 6475136 : s3=z(2,j,i2,ia*4+3)
3363 : 6475136 : r2=z(1,j,i2,ia*4+2)
3364 : 6475136 : s2=z(2,j,i2,ia*4+2)
3365 : 6475136 : r1=z(1,j,i2,ia*4+1)
3366 : 6475136 : s1=z(2,j,i2,ia*4+1)
3367 : :
3368 : 6475136 : r=r1 + r3
3369 : 6475136 : s=r2 + r4
3370 : 6475136 : zbr(1,j,i2,ind(ia*4+1)) = r + s
3371 : 6475136 : zbr(1,j,i2,ind(ia*4+3)) = r - s
3372 : 6475136 : r=r1 - r3
3373 : 6475136 : s=s2 - s4
3374 : 6475136 : zbr(1,j,i2,ind(ia*4+2)) = r - s*ris
3375 : 6475136 : zbr(1,j,i2,ind(ia*4+4)) = r + s*ris
3376 : 6475136 : r=s1 + s3
3377 : 6475136 : s=s2 + s4
3378 : 6475136 : zbr(2,j,i2,ind(ia*4+1)) = r + s
3379 : 6475136 : zbr(2,j,i2,ind(ia*4+3)) = r - s
3380 : 6475136 : r=s1 - s3
3381 : 6475136 : s=r2 - r4
3382 : 6475136 : zbr(2,j,i2,ind(ia*4+2)) = r + s*ris
3383 : 6551781 : zbr(2,j,i2,ind(ia*4+4)) = r - s*ris
3384 : : end do ! j
3385 : : end do ! i2
3386 : : !$OMP END PARALLEL DO
3387 : :
3388 : : ! Second step of radix 4
3389 [ + + ]: 1658384 : do ia=1,aft(ic)-1
3390 : 1581739 : indx=ind(ia*4+1)-1
3391 : 1581739 : cr2=trig(1,indx)
3392 : 1581739 : ct2=trig(2,indx)
3393 : 1581739 : cr3=trig(1,2*indx)
3394 : 1581739 : ct3=trig(2,2*indx)
3395 : 1581739 : cr4=trig(1,3*indx)
3396 : 1581739 : ct4=trig(2,3*indx)
3397 : 1581739 : cr4=cr4/cr2
3398 : 1581739 : cr2s=cr2*ris
3399 : : !$OMP PARALLEL DO DEFAULT(PRIVATE)&
3400 : : !$OMP&SHARED(ia,cr2,cr2s,cr3,cr4,ct2,ct3,ct4,ind,n1,n2,n2i,z,zbr)
3401 [ + + ]: 3240123 : do i2=n2i,n2
3402 [ + + ]: 144703366 : do j=1,n1
3403 : 141539888 : r4=z(1,j,i2,ia*4+4) - z(2,j,i2,ia*4+4)*ct4
3404 : 141539888 : s4=z(1,j,i2,ia*4+4)*ct4 + z(2,j,i2,ia*4+4)
3405 : 141539888 : r3=z(1,j,i2,ia*4+3) - z(2,j,i2,ia*4+3)*ct3
3406 : 141539888 : s3=z(1,j,i2,ia*4+3)*ct3 + z(2,j,i2,ia*4+3)
3407 : 141539888 : r2=z(1,j,i2,ia*4+2) - z(2,j,i2,ia*4+2)*ct2
3408 : 141539888 : s2=z(1,j,i2,ia*4+2)*ct2 + z(2,j,i2,ia*4+2)
3409 : 141539888 : r1=z(1,j,i2,ia*4+1)
3410 : 141539888 : s1=z(2,j,i2,ia*4+1)
3411 : :
3412 : 141539888 : r=r1 + r3*cr3
3413 : 141539888 : s=r2 + r4*cr4
3414 : 141539888 : zbr(1,j,i2,ind(ia*4+1)) = r + s*cr2
3415 : 141539888 : zbr(1,j,i2,ind(ia*4+3)) = r - s*cr2
3416 : 141539888 : r=r1 - r3*cr3
3417 : 141539888 : s=s2 - s4*cr4
3418 : 141539888 : zbr(1,j,i2,ind(ia*4+2)) = r - s*cr2s
3419 : 141539888 : zbr(1,j,i2,ind(ia*4+4)) = r + s*cr2s
3420 : 141539888 : r=s1 + s3*cr3
3421 : 141539888 : s=s2 + s4*cr4
3422 : 141539888 : zbr(2,j,i2,ind(ia*4+1)) = r + s*cr2
3423 : 141539888 : zbr(2,j,i2,ind(ia*4+3)) = r - s*cr2
3424 : 141539888 : r=s1 - s3*cr3
3425 : 141539888 : s=r2 - r4*cr4
3426 : 141539888 : zbr(2,j,i2,ind(ia*4+2)) = r + s*cr2s
3427 : 143121627 : zbr(2,j,i2,ind(ia*4+4)) = r - s*cr2s
3428 : : end do ! j
3429 : : end do ! i2
3430 : : !$OMP END PARALLEL DO
3431 : :
3432 : : end do ! ia
3433 : :
3434 : : ! Treat radix 2
3435 [ + + ]: 491406 : else if (now(ic)==2) then
3436 : 255877 : ia=0
3437 : :
3438 : : ! First step of radix 2
3439 : : !$OMP PARALLEL DO DEFAULT(PRIVATE)&
3440 : : !$OMP&SHARED(ia,ind,n1,n2,n2i,z,zbr)
3441 [ + + ]: 511754 : do i2=n2i,n2
3442 [ + + ]: 5707820 : do j=1,n1
3443 : 5196066 : r1=z(1,j,i2,ia*2+1)
3444 : 5196066 : s1=z(2,j,i2,ia*2+1)
3445 : 5196066 : r2=z(1,j,i2,ia*2+2)
3446 : 5196066 : s2=z(2,j,i2,ia*2+2)
3447 : 5196066 : zbr(1,j,i2,ind(ia*2+1)) = r2 + r1
3448 : 5196066 : zbr(2,j,i2,ind(ia*2+1)) = s2 + s1
3449 : 5196066 : zbr(1,j,i2,ind(ia*2+2)) = -r2 + r1
3450 : 5451943 : zbr(2,j,i2,ind(ia*2+2)) = -s2 + s1
3451 : : end do ! j
3452 : : end do ! i2
3453 : : !$OMP END PARALLEL DO
3454 : :
3455 : : ! Second step of radix 2
3456 [ + + ]: 4326588 : do ia=1,aft(ic)-1
3457 : 4070711 : indx=ind(ia*2+1)-1
3458 : 4070711 : cr2=trig(1,indx)
3459 : 4070711 : ct2=trig(2,indx)
3460 : : !$OMP PARALLEL DO DEFAULT(PRIVATE)&
3461 : : !$OMP&SHARED(cr2,ct2,ia,ind,n1,n2,n2i,z,zbr)
3462 [ + + ]: 8397299 : do i2=n2i,n2
3463 [ + + ]: 106113284 : do j=1,n1
3464 : 97971862 : r1=z(1,j,i2,ia*2+1)
3465 : 97971862 : s1=z(2,j,i2,ia*2+1)
3466 : 97971862 : r2=z(1,j,i2,ia*2+2) - z(2,j,i2,ia*2+2)*ct2
3467 : 97971862 : s2=z(1,j,i2,ia*2+2)*ct2 + z(2,j,i2,ia*2+2)
3468 : 97971862 : zbr(1,j,i2,ind(ia*2+1)) = r2*cr2 + r1
3469 : 97971862 : zbr(2,j,i2,ind(ia*2+1)) = s2*cr2 + s1
3470 : 97971862 : zbr(1,j,i2,ind(ia*2+2)) = -r2*cr2 + r1
3471 : 102042573 : zbr(2,j,i2,ind(ia*2+2)) = -s2*cr2 + s1
3472 : : end do ! j
3473 : : end do ! i2
3474 : : !$OMP END PARALLEL DO
3475 : : end do ! ia
3476 : :
3477 : : ! Treat radix 3
3478 [ + - ]: 235529 : else if (now(ic)==3) then
3479 : : ! .5d0*sqrt(3.d0)=0.8660254037844387d0
3480 : 235529 : ia=0
3481 : 235529 : bb=ris*0.8660254037844387d0
3482 : :
3483 : : ! First step of radix 3
3484 : : !$OMP PARALLEL DO DEFAULT(PRIVATE)&
3485 : : !$OMP&SHARED(bb,ia,ind,n1,n2,n2i,z,zbr)
3486 [ + + ]: 471058 : do i2=n2i,n2
3487 [ + + ]: 4597599 : do j=1,n1
3488 : 4126541 : r1=z(1,j,i2,ia*3+1)
3489 : 4126541 : s1=z(2,j,i2,ia*3+1)
3490 : 4126541 : r2=z(1,j,i2,ia*3+2)
3491 : 4126541 : s2=z(2,j,i2,ia*3+2)
3492 : 4126541 : r3=z(1,j,i2,ia*3+3)
3493 : 4126541 : s3=z(2,j,i2,ia*3+3)
3494 : 4126541 : r=r2 + r3
3495 : 4126541 : s=s2 + s3
3496 : 4126541 : zbr(1,j,i2,ind(ia*3+1)) = r + r1
3497 : 4126541 : zbr(2,j,i2,ind(ia*3+1)) = s + s1
3498 : 4126541 : r1=r1 - r*.5d0
3499 : 4126541 : s1=s1 - s*.5d0
3500 : 4126541 : r2=r2-r3
3501 : 4126541 : s2=s2-s3
3502 : 4126541 : zbr(1,j,i2,ind(ia*3+2)) = r1 - s2*bb
3503 : 4126541 : zbr(2,j,i2,ind(ia*3+2)) = s1 + r2*bb
3504 : 4126541 : zbr(1,j,i2,ind(ia*3+3)) = r1 + s2*bb
3505 : 4362070 : zbr(2,j,i2,ind(ia*3+3)) = s1 - r2*bb
3506 : : end do ! j
3507 : : end do ! i2
3508 : : !$OMP END PARALLEL DO
3509 : :
3510 : : ! Second step of radix 3
3511 [ + + ]: 2834177 : do ia=1,aft(ic)-1
3512 : 2598648 : indx=ind(ia*3+1)-1
3513 : 2598648 : cr2=trig(1,indx)
3514 : 2598648 : ct2=trig(2,indx)
3515 : 2598648 : cr3=trig(1,2*indx)
3516 : 2598648 : ct3=trig(2,2*indx)
3517 : 2598648 : cr2=cr2/cr3
3518 : 2598648 : cr3p=.5d0*cr3
3519 : 2598648 : bb=ris*cr3*0.8660254037844387d0
3520 : : !$OMP PARALLEL DO DEFAULT(PRIVATE)&
3521 : : !$OMP&SHARED(bb,cr2,cr3,cr3p,ct2,ct3,ia,ind,n1,n2,n2i,z,zbr)
3522 [ + + ]: 5432825 : do i2=n2i,n2
3523 [ + + ]: 54846116 : do j=1,n1
3524 : 49648820 : r1=z(1,j,i2,ia*3+1)
3525 : 49648820 : s1=z(2,j,i2,ia*3+1)
3526 : 49648820 : r2=z(1,j,i2,ia*3+2) - z(2,j,i2,ia*3+2)*ct2
3527 : 49648820 : s2=z(1,j,i2,ia*3+2)*ct2 + z(2,j,i2,ia*3+2)
3528 : 49648820 : r3=z(1,j,i2,ia*3+3) - z(2,j,i2,ia*3+3)*ct3
3529 : 49648820 : s3=z(1,j,i2,ia*3+3)*ct3 + z(2,j,i2,ia*3+3)
3530 : 49648820 : r=cr2*r2 + r3
3531 : 49648820 : s=cr2*s2 + s3
3532 : 49648820 : zbr(1,j,i2,ind(ia*3+1)) = r*cr3 + r1
3533 : 49648820 : zbr(2,j,i2,ind(ia*3+1)) = s*cr3 + s1
3534 : 49648820 : r1=r1 - r*cr3p
3535 : 49648820 : s1=s1 - s*cr3p
3536 : 49648820 : r2=cr2*r2-r3
3537 : 49648820 : s2=cr2*s2-s3
3538 : 49648820 : zbr(1,j,i2,ind(ia*3+2)) = r1 - s2*bb
3539 : 49648820 : zbr(2,j,i2,ind(ia*3+2)) = s1 + r2*bb
3540 : 49648820 : zbr(1,j,i2,ind(ia*3+3)) = r1 + s2*bb
3541 : 52247468 : zbr(2,j,i2,ind(ia*3+3)) = s1 - r2*bb
3542 : : end do ! j
3543 : : end do ! i2
3544 : : !$OMP END PARALLEL DO
3545 : : end do ! ia
3546 : :
3547 : : ! Treat radix 5
3548 [ # # ]: 0 : else if (now(ic)==5) then
3549 : : ! sin(2.d0*pi/5.d0)
3550 : 0 : sin2=ris*0.9510565162951536d0
3551 : 0 : ia=0
3552 : :
3553 : : ! First step of radix 5
3554 : : !$OMP PARALLEL DO DEFAULT(PRIVATE)&
3555 : : !$OMP&SHARED(ia,ind,n1,n2,n2i,sin2,z,zbr)
3556 [ # # ]: 0 : do i2=n2i,n2
3557 [ # # ]: 0 : do j=1,n1
3558 : 0 : r1=z(1,j,i2,ia*5+1)
3559 : 0 : s1=z(2,j,i2,ia*5+1)
3560 : 0 : r2=z(1,j,i2,ia*5+2)
3561 : 0 : s2=z(2,j,i2,ia*5+2)
3562 : 0 : r3=z(1,j,i2,ia*5+3)
3563 : 0 : s3=z(2,j,i2,ia*5+3)
3564 : 0 : r4=z(1,j,i2,ia*5+4)
3565 : 0 : s4=z(2,j,i2,ia*5+4)
3566 : 0 : r5=z(1,j,i2,ia*5+5)
3567 : 0 : s5=z(2,j,i2,ia*5+5)
3568 : 0 : r25 = r2 + r5
3569 : 0 : r34 = r3 + r4
3570 : 0 : s25 = s2 - s5
3571 : 0 : s34 = s3 - s4
3572 : 0 : zbr(1,j,i2,ind(ia*5+1)) = r1 + r25 + r34
3573 : 0 : r = r1 + cos2*r25 + cos4*r34
3574 : 0 : s = s25 + sin42*s34
3575 : 0 : zbr(1,j,i2,ind(ia*5+2)) = r - sin2*s
3576 : 0 : zbr(1,j,i2,ind(ia*5+5)) = r + sin2*s
3577 : 0 : r = r1 + cos4*r25 + cos2*r34
3578 : 0 : s = sin42*s25 - s34
3579 : 0 : zbr(1,j,i2,ind(ia*5+3)) = r - sin2*s
3580 : 0 : zbr(1,j,i2,ind(ia*5+4)) = r + sin2*s
3581 : 0 : r25 = r2 - r5
3582 : 0 : r34 = r3 - r4
3583 : 0 : s25 = s2 + s5
3584 : 0 : s34 = s3 + s4
3585 : 0 : zbr(2,j,i2,ind(ia*5+1)) = s1 + s25 + s34
3586 : 0 : r = s1 + cos2*s25 + cos4*s34
3587 : 0 : s = r25 + sin42*r34
3588 : 0 : zbr(2,j,i2,ind(ia*5+2)) = r + sin2*s
3589 : 0 : zbr(2,j,i2,ind(ia*5+5)) = r - sin2*s
3590 : 0 : r = s1 + cos4*s25 + cos2*s34
3591 : 0 : s = sin42*r25 - r34
3592 : 0 : zbr(2,j,i2,ind(ia*5+3)) = r + sin2*s
3593 : 0 : zbr(2,j,i2,ind(ia*5+4)) = r - sin2*s
3594 : : end do ! j
3595 : : end do ! i2
3596 : : !$OMP END PARALLEL DO
3597 : :
3598 : : ! Second step of radix 5
3599 [ # # ]: 0 : do ia=1,aft(ic)-1
3600 : 0 : indx=ind(ia*5+1)-1
3601 : 0 : cr2=trig(1,indx)
3602 : 0 : ct2=trig(2,indx)
3603 : 0 : cr3=trig(1,2*indx)
3604 : 0 : ct3=trig(2,2*indx)
3605 : 0 : cr4=trig(1,3*indx)
3606 : 0 : ct4=trig(2,3*indx)
3607 : 0 : cr5=trig(1,4*indx)
3608 : 0 : ct5=trig(2,4*indx)
3609 : : !$OMP PARALLEL DO DEFAULT(PRIVATE)&
3610 : : !$OMP&SHARED(cr2,cr3,cr4,cr5,ct2,ct3,ct4,ct5,ia,ind,n1,n2,n2i,sin2,z,zbr)
3611 [ # # ]: 0 : do i2=n2i,n2
3612 [ # # ]: 0 : do j=1,n1
3613 : 0 : r1=z(1,j,i2,ia*5+1)
3614 : 0 : s1=z(2,j,i2,ia*5+1)
3615 : 0 : r2=cr2*(z(1,j,i2,ia*5+2) - z(2,j,i2,ia*5+2)*ct2)
3616 : 0 : s2=cr2*(z(1,j,i2,ia*5+2)*ct2 + z(2,j,i2,ia*5+2))
3617 : 0 : r3=cr3*(z(1,j,i2,ia*5+3) - z(2,j,i2,ia*5+3)*ct3)
3618 : 0 : s3=cr3*(z(1,j,i2,ia*5+3)*ct3 + z(2,j,i2,ia*5+3))
3619 : 0 : r4=z(1,j,i2,ia*5+4) - z(2,j,i2,ia*5+4)*ct4
3620 : 0 : s4=z(1,j,i2,ia*5+4)*ct4 + z(2,j,i2,ia*5+4)
3621 : 0 : r5=z(1,j,i2,ia*5+5) - z(2,j,i2,ia*5+5)*ct5
3622 : 0 : s5=z(1,j,i2,ia*5+5)*ct5 + z(2,j,i2,ia*5+5)
3623 : 0 : r25 = r2 + r5*cr5
3624 : 0 : r34 = r3 + r4*cr4
3625 : 0 : s25 = s2 - s5*cr5
3626 : 0 : s34 = s3 - s4*cr4
3627 : 0 : zbr(1,j,i2,ind(ia*5+1)) = r1 + r25 + r34
3628 : 0 : r = r1 + cos2*r25 + cos4*r34
3629 : 0 : s = s25 + sin42*s34
3630 : 0 : zbr(1,j,i2,ind(ia*5+2)) = r - sin2*s
3631 : 0 : zbr(1,j,i2,ind(ia*5+5)) = r + sin2*s
3632 : 0 : r = r1 + cos4*r25 + cos2*r34
3633 : 0 : s = sin42*s25 - s34
3634 : 0 : zbr(1,j,i2,ind(ia*5+3)) = r - sin2*s
3635 : 0 : zbr(1,j,i2,ind(ia*5+4)) = r + sin2*s
3636 : 0 : r25 = r2 - r5*cr5
3637 : 0 : r34 = r3 - r4*cr4
3638 : 0 : s25 = s2 + s5*cr5
3639 : 0 : s34 = s3 + s4*cr4
3640 : 0 : zbr(2,j,i2,ind(ia*5+1)) = s1 + s25 + s34
3641 : 0 : r = s1 + cos2*s25 + cos4*s34
3642 : 0 : s = r25 + sin42*r34
3643 : 0 : zbr(2,j,i2,ind(ia*5+2)) = r + sin2*s
3644 : 0 : zbr(2,j,i2,ind(ia*5+5)) = r - sin2*s
3645 : 0 : r = s1 + cos4*s25 + cos2*s34
3646 : 0 : s = sin42*r25 - r34
3647 : 0 : zbr(2,j,i2,ind(ia*5+3)) = r + sin2*s
3648 : 0 : zbr(2,j,i2,ind(ia*5+4)) = r - sin2*s
3649 : : end do ! j
3650 : : end do ! i2
3651 : : !$OMP END PARALLEL DO
3652 : : end do ! ia
3653 : :
3654 : : else ! All radices treated
3655 : : !if (now(ic) /= 1) then
3656 : 0 : ABI_BUG(sjoin("Called with factors other than 2, 3, and 5. now(ic) = ", itoa(now(ic))))
3657 : : !end if
3658 : : end if
3659 : :
3660 : 568051 : end subroutine sg_fftz
3661 : : !!***
3662 : :
3663 : : !----------------------------------------------------------------------
3664 : :
3665 : : !!****f* m_sgfft/sg_ctrig
3666 : : !! NAME
3667 : : !! sg_ctrig
3668 : : !!
3669 : : !! FUNCTION
3670 : : !! Precalculates trigonometric expressions and bitreversal key IND (Stefan Goedecker lib).
3671 : : !!
3672 : : !! INPUTS
3673 : : !! n=Number of FFT points for 1D FFT.
3674 : : !! ris = sign of exponential in transform (should be 1 or -1; real)
3675 : : !! mfac = maximum number of factors in 1D FFTs
3676 : : !! mg = maximum length of 1D FFTs
3677 : : !!
3678 : : !! OUTPUT
3679 : : !! trig(2,mg) TO BE DESCRIBED SB 090902
3680 : : !! aft(mfac) TO BE DESCRIBED SB 090902
3681 : : !! bef(mfac) TO BE DESCRIBED SB 090902
3682 : : !! now(mfac) TO BE DESCRIBED SB 090902
3683 : : !! ic = number of (radix) factors of x transform length (from ctrig)
3684 : : !! ind(mg) TO BE DESCRIBED SB 090902
3685 : : !!
3686 : : !! NOTES
3687 : : !! * This version of sg_ctrig produces cos and tan instead of sin and cos--
3688 : : !! this allows for much greater efficiency on the superscalar architecture
3689 : : !! of ibm rs6000 where floating point multiply and add (FMA) is used.
3690 : : !!
3691 : : !! * This routine is not thread-safe due to the presence of variables with the save attribute!
3692 : : !! DO NOT CALL THIS ROUTINE INSIDE A OPENMP PARALLEL REGION
3693 : : !!
3694 : : !! TODO
3695 : : !! Should describe arguments
3696 : : !! Should suppress one-letter variables
3697 : : !!
3698 : : !! SOURCE
3699 : :
3700 : 96285 : subroutine sg_ctrig(n,trig,aft,bef,now,ris,ic,ind,mfac,mg)
3701 : :
3702 : : !Arguments ------------------------------------
3703 : : !scalars
3704 : : integer,intent(in) :: mfac,mg,n
3705 : : integer,intent(out) :: ic
3706 : : real(dp),intent(in) :: ris
3707 : : !arrays
3708 : : integer,intent(out) :: aft(mfac),bef(mfac),ind(mg),now(mfac)
3709 : : real(dp),intent(out) :: trig(2,mg)
3710 : :
3711 : : !Local variables-------------------------------
3712 : : !scalars
3713 : : integer,save :: nextmx=4
3714 : : integer :: i,ii,inc,irep,j,k,l,next,nh
3715 : : integer,save :: prime(4)=(/5,4,3,2/) !"prime" is the set of radices coded elsewhere for fft
3716 : : real(dp) :: angle,trigc,trigs,twopi
3717 : : character(len=500) :: message
3718 : :
3719 : : ! *************************************************************************
3720 : :
3721 : : !**Note**
3722 : : !2*Pi must not be defined too accurately here or else
3723 : : !cos(twopi/2) will be exactly 0 and sin/cos below will be
3724 : : !infinite; if a small error is left in Pi, then sin/cos will
3725 : : !be about 10**14 and later cos * (sin/cos) will be 1 to within
3726 : : !about 10**(-14) and the fft routines will work
3727 : : !The precision on sgi causes the algorithm to fail if
3728 : : !twopi is defined as 8.d0*atan(1.0d0).
3729 : :
3730 : 96285 : twopi=6.2831853071795867d0
3731 : :
3732 : 96285 : angle=ris*twopi/n
3733 : : !trig(1,0)=1.d0
3734 : : !trig(2,0)=0.d0
3735 [ + + ]: 96285 : if (mod(n,2)==0) then
3736 : 81607 : nh=n/2
3737 : 81607 : trig(1,nh)=-1.d0
3738 : 81607 : trig(2,nh)=0.d0
3739 [ + + ]: 993734 : do i=1,nh-1
3740 : 912127 : trigc=cos(i*angle)
3741 : 912127 : trigs=sin(i*angle)
3742 : 912127 : trig(1,i)=trigc
3743 : 912127 : trig(2,i)=trigs/trigc
3744 : 912127 : trig(1,n-i)=trigc
3745 : 993734 : trig(2,n-i)=-trigs/trigc
3746 : : end do
3747 : : else
3748 : 14678 : nh=(n-1)/2
3749 [ + + ]: 204139 : do i=1,nh
3750 : 189461 : trigc=cos(i*angle)
3751 : 189461 : trigs=sin(i*angle)
3752 : 189461 : trig(1,i)=trigc
3753 : 189461 : trig(2,i)=trigs/trigc
3754 : 189461 : trig(1,n-i)=trigc
3755 : 204139 : trig(2,n-i)=-trigs/trigc
3756 : : end do
3757 : : end if
3758 : :
3759 : 96285 : ic=1
3760 : 96285 : aft(ic)=1
3761 : 96285 : bef(ic)=n
3762 : 96285 : next=1
3763 : :
3764 : : !An infinite loop, with exit or cycle instructions
3765 : : do
3766 [ + + ]: 502967 : if( (bef(ic)/prime(next))*prime(next)<bef(ic) ) then
3767 : 255365 : next=next+1
3768 [ + - ]: 255365 : if (next<=nextmx) then
3769 : : cycle
3770 : : else
3771 : 0 : now(ic)=bef(ic)
3772 : 0 : bef(ic)=1
3773 : : end if
3774 : : else
3775 : 247602 : now(ic)=prime(next)
3776 : 247602 : bef(ic)=bef(ic)/prime(next)
3777 : : end if
3778 : 247602 : aft(ic+1)=aft(ic)
3779 : 247602 : now(ic+1)=now(ic)
3780 : 247602 : bef(ic+1)=bef(ic)
3781 : 247602 : ic=ic+1
3782 [ - + ]: 247602 : if (ic>mfac) then
3783 : : write(message, '(a,i0,2a,i0)' )&
3784 : 0 : & 'number of factors ic=',ic,ch10,&
3785 : 0 : & 'exceeds dimensioned mfac=',mfac
3786 : 0 : ABI_BUG(message)
3787 : : end if
3788 [ + + ]: 247602 : if (bef(ic)/=1) then
3789 : 151317 : aft(ic)=aft(ic)*now(ic)
3790 : 151317 : cycle
3791 : : end if
3792 : : ! If not cycled, exit
3793 : 255365 : exit
3794 : : end do
3795 : :
3796 : 96285 : ic=ic-1
3797 : :
3798 : : !DEBUG
3799 : : !write(std_out,*) 'now',(now(i),i=1,ic)
3800 : : !write(std_out,*) 'aft',(aft(i),i=1,ic)
3801 : : !write(std_out,*) 'bef',(bef(i),i=1,ic)
3802 : : !ENDDEBUG
3803 : :
3804 [ + + ]: 2477353 : do i=1,n
3805 : 2477353 : ind(i)=1
3806 : : end do
3807 : :
3808 : 96285 : irep=1
3809 : 96285 : inc=n
3810 [ + + ]: 343887 : do l=ic,1,-1
3811 : 247602 : inc=inc/now(l)
3812 : 247602 : ii=0
3813 [ + + ]: 1602920 : do k=1,1+(n-1)/(now(l)*irep)
3814 [ + + ]: 5243021 : do j=0,now(l)-1
3815 [ + + ]: 11800574 : do i=1,irep
3816 : 6805155 : ii=ii+1
3817 : 10445256 : ind(ii)=ind(ii)+j*inc
3818 : : end do
3819 : : end do
3820 : : end do
3821 : 343887 : irep=irep*now(l)
3822 : : end do
3823 : :
3824 [ - + ]: 96285 : if (irep/=n) then
3825 : 0 : write(message,'(a,i0,a,i0)')' irep should equal n ; irep=',irep,' n=',n
3826 : 0 : ABI_BUG(message)
3827 : : end if
3828 : :
3829 [ - + ]: 96285 : if (inc/=1) then
3830 : 0 : write(message, '(a,i0)' )' inc should equal 1 in sg_ctrig; inc=',inc
3831 : 0 : ABI_BUG(message)
3832 : : end if
3833 : :
3834 : 96285 : end subroutine sg_ctrig
3835 : : !!***
3836 : :
3837 : : !----------------------------------------------------------------------
3838 : :
3839 : : !!****f* m_sgfft/sg_fftrisc
3840 : : !! NAME
3841 : : !! sg_fftrisc
3842 : : !!
3843 : : !! FUNCTION
3844 : : !! Wrapper around fftrisc_one_nothreadsafe that supports ndat transforms.
3845 : : !!
3846 : : !! * This routine is not thread-safe due to the presence of variables with the save attribute!
3847 : : !! DO NOT CALL THIS ROUTINE INSIDE A OPENMP PARALLEL REGION
3848 : : !!
3849 : : !! SOURCE
3850 : :
3851 : 1094182 : subroutine sg_fftrisc(cplex,denpot,fofgin,fofgout,fofr,gboundin,gboundout,istwf_k,&
3852 : 1094182 : & kg_kin,kg_kout,mgfft,ndat,ngfft,npwin,npwout,n4,n5,n6,option,weight_r, weight_i)
3853 : :
3854 : : !Arguments ------------------------------------
3855 : : !scalars
3856 : : integer,intent(in) :: cplex,istwf_k,mgfft,n4,n5,n6,ndat,npwin,npwout,option
3857 : : real(dp),intent(in) :: weight_i,weight_r
3858 : : !arrays
3859 : : integer,intent(in) :: gboundin(2*mgfft+8,2),gboundout(2*mgfft+8,2)
3860 : : integer,intent(in) :: kg_kin(3,npwin),kg_kout(3,npwout),ngfft(18)
3861 : : real(dp),intent(in) :: fofgin(2,npwin*ndat)
3862 : : real(dp),intent(inout) :: denpot(cplex*n4*n5*n6),fofr(2,n4*n5*n6*ndat)
3863 : : real(dp),intent(out) :: fofgout(2,npwout*ndat)
3864 : :
3865 : : !Local variables-------------------------------
3866 : : !scalars
3867 : : integer :: idat,fofgin_p,fofr_p,fofgout_p
3868 : : !arrays
3869 : : real(dp) :: dum_fofgin(0,0),dum_fofr(0,0),dum_fofgout(0,0)
3870 : :
3871 : : ! *************************************************************************
3872 : :
3873 [ + + ]: 2188388 : do idat=1,ndat
3874 : 1094206 : fofgin_p = 1 + (idat-1) * npwin
3875 : 1094206 : fofr_p = 1 + (idat - 1) * n4*n5*n6
3876 : 1094206 : fofgout_p = 1 + (idat-1) * npwout
3877 : :
3878 : 1094182 : select case (option)
3879 : : case (0)
3880 : : call fftrisc_one_nothreadsafe(&
3881 : : & cplex,denpot,fofgin(1,fofgin_p),dum_fofgout,fofr(1,fofr_p),&
3882 : : & gboundin,gboundout,istwf_k,&
3883 : 279232 : & kg_kin,kg_kout,mgfft,ngfft,npwin,npwout,n4,n5,n6,option,weight_r,weight_i)
3884 : :
3885 : : case (1)
3886 : : ! Don't know why but fofr is not touched by this option.
3887 : : call fftrisc_one_nothreadsafe(&
3888 : : & cplex,denpot,fofgin(1,fofgin_p),dum_fofgout,dum_fofr,&
3889 : : & gboundin,gboundout,istwf_k,&
3890 : 37245 : & kg_kin,kg_kout,mgfft,ngfft,npwin,npwout,n4,n5,n6,option,weight_r,weight_i)
3891 : :
3892 : : case (2)
3893 : : call fftrisc_one_nothreadsafe(&
3894 : : & cplex,denpot,fofgin(1,fofgin_p),fofgout(1,fofgout_p),dum_fofr,&
3895 : : & gboundin,gboundout,istwf_k,&
3896 : 777714 : & kg_kin,kg_kout,mgfft,ngfft,npwin,npwout,n4,n5,n6,option,weight_r,weight_i)
3897 : :
3898 : : case (3)
3899 : : call fftrisc_one_nothreadsafe(&
3900 : : & cplex,denpot,dum_fofgin,fofgout(1,fofgout_p),fofr(1,fofr_p),&
3901 : : & gboundin,gboundout,istwf_k,&
3902 : 15 : & kg_kin,kg_kout,mgfft,ngfft,npwin,npwout,n4,n5,n6,option,weight_r,weight_i)
3903 : :
3904 : : case default
3905 [ + + + + : 1094206 : ABI_ERROR("Wrong option")
- ]
3906 : : end select
3907 : : end do
3908 : :
3909 : 1094182 : end subroutine sg_fftrisc
3910 : : !!***
3911 : :
3912 : : !----------------------------------------------------------------------
3913 : :
3914 : : !!****f* m_sgfft/fftrisc_one_nothreadsafe
3915 : : !! NAME
3916 : : !! fftrisc_one_nothreadsafe
3917 : : !!
3918 : : !! FUNCTION
3919 : : !! Carry out Fourier transforms between real and reciprocal (G) space,
3920 : : !! for wavefunctions, contained in a sphere in reciprocal space,
3921 : : !! in both directions. Also accomplish some post-processing.
3922 : : !!
3923 : : !! NOTES
3924 : : !! Specifically uses rather sophisticated algorithms, based on S Goedecker
3925 : : !! routines, specialized for superscalar RISC architecture.
3926 : : !! Zero padding : saves 7/12 execution time
3927 : : !! Bi-dimensional data locality in most of the routine : cache reuse
3928 : : !! For k-point (0 0 0) : takes advantage of symmetry of data.
3929 : : !! Note however that no blocking is used, in both 1D z-transform
3930 : : !! or subsequent 2D transform. This should be improved.
3931 : : !!
3932 : : !! * This routine is not thread-safe due to the presence of variables with the save attribute!
3933 : : !! DO NOT CALL THIS ROUTINE INSIDE A OPENMP PARALLEL REGION
3934 : : !!
3935 : : !! INPUTS
3936 : : !! cplex= if 1 , denpot is real, if 2 , denpot is complex
3937 : : !! (cplex=2 only allowed for option=2 when istwf_k=1)
3938 : : !! one can also use cplex=0 if option=0 or option=3
3939 : : !! fofgin(2,npwin)=holds input wavefunction in G vector basis sphere.
3940 : : !! gboundin(2*mgfft+8,2)=sphere boundary info for reciprocal to real space
3941 : : !! gboundout(2*mgfft+8,2)=sphere boundary info for real to reciprocal space
3942 : : !! istwf_k=option parameter that describes the storage of wfs
3943 : : !! kg_kin(3,npwin)=reduced planewave coordinates, input
3944 : : !! kg_kout(3,npwout)=reduced planewave coordinates, output
3945 : : !! mgfft=maximum size of 1D FFTs
3946 : : !! ngfft(18)=contain all needed information about 3D FFT, see ~abinit/doc/variables/vargs.htm#ngfft
3947 : : !! npwin=number of elements in fofgin array (for option 0, 1 and 2)
3948 : : !! npwout=number of elements in fofgout array (for option 2 and 3)
3949 : : !! n4,n5,n6=ngfft(4),ngfft(5),ngfft(6), dimensions of fofr.
3950 : : !! option= if 0: do direct FFT
3951 : : !! if 1: do direct FFT, then sum the density
3952 : : !! if 2: do direct FFT, multiply by the potential, then do reverse FFT
3953 : : !! if 3: do reverse FFT only
3954 : : !! weight=weight to be used for the accumulation of the density in real space
3955 : : !! (needed only when option=1)
3956 : : !!
3957 : : !! OUTPUT
3958 : : !! (see side effects)
3959 : : !!
3960 : : !! OPTIONS
3961 : : !! The different options are:
3962 : : !! - reciprocal to real space and output the result (when option=0),
3963 : : !! - reciprocal to real space and accumulate the density (when option=1) or
3964 : : !! - reciprocal to real space, apply the local potential to the wavefunction
3965 : : !! in real space and produce the result in reciprocal space (when option=2)
3966 : : !! - real space to reciprocal space (when option=3).
3967 : : !! option=0 IS NOT ALLOWED when istwf_k>2
3968 : : !! option=3 IS NOT ALLOWED when istwf_k>=2
3969 : : !!
3970 : : !! SIDE EFFECTS
3971 : : !! for option==0, fofgin(2,npwin)=holds input wavefunction in G sphere;
3972 : : !! fofr(2,n4,n5,n6) contains the Fourier Transform of fofgin;
3973 : : !! no use of denpot, fofgout and npwout.
3974 : : !! for option==1, fofgin(2,npwin)=holds input wavefunction in G sphere;
3975 : : !! denpot(cplex*n4,n5,n6) contains the input density at input,
3976 : : !! and the updated density at output;
3977 : : !! no use of fofgout and npwout.
3978 : : !! for option==2, fofgin(2,npwin)=holds input wavefunction in G sphere;
3979 : : !! denpot(cplex*n4,n5,n6) contains the input local potential;
3980 : : !! fofgout(2,npwout) contains the output function;
3981 : : !! for option==3, fofr(2,n4,n5,n6) contains the real space wavefunction;
3982 : : !! fofgout(2,npwout) contains its Fourier transform;
3983 : : !! no use of fofgin and npwin.
3984 : : !!
3985 : : !! SOURCE
3986 : :
3987 : 1094206 : subroutine fftrisc_one_nothreadsafe(cplex,denpot,fofgin,fofgout,fofr,gboundin,gboundout,istwf_k,&
3988 : 1094206 : & kg_kin,kg_kout,mgfft,ngfft,npwin,npwout,n4,n5,n6,option,weight_r,weight_i)
3989 : :
3990 : : !Arguments ------------------------------------
3991 : : !scalars
3992 : : integer,intent(in) :: cplex,istwf_k,mgfft,n4,n5,n6,npwin,npwout,option
3993 : : real(dp),intent(in) :: weight_i,weight_r
3994 : : !arrays
3995 : : integer,intent(in) :: gboundin(2*mgfft+8,2),gboundout(2*mgfft+8,2)
3996 : : integer,intent(in) :: kg_kin(3,npwin),kg_kout(3,npwout),ngfft(18)
3997 : : real(dp),intent(in) :: fofgin(2,npwin)
3998 : : real(dp),intent(inout) :: denpot(cplex*n4,n5,n6),fofr(2,n4,n5,n6)
3999 : : real(dp),intent(out) :: fofgout(2,npwout)
4000 : :
4001 : : !Local variables-------------------------------
4002 : : !scalars
4003 : : integer,parameter :: mfac=11
4004 : : integer,save :: ic1,ic2,ic3,ic4,ic5,ic6,n1_save=0,n2_save=0,n3_save=0
4005 : : integer :: fftcache,g2max,g2min,i1,i1max,i2,i3,i3inv,ig,igb
4006 : : integer :: igb_inv,igbmax,ii2,lot,lotin,lotout,mgb,n1
4007 : : integer :: n1half1,n1halfm,n1i,n2,n2half1,n3,n4half1,n5half1,nfftot,ngbin
4008 : : integer :: ngbout,nlot,nproc_omp
4009 : : real(dp) :: ai,ar,fraction,norm,phai,phar,wkim,wkre
4010 : : character(len=500) :: message
4011 : : !arrays
4012 : : integer,save :: aft1(mfac),aft2(mfac),aft3(mfac),aft4(mfac),aft5(mfac)
4013 : : integer,save :: aft6(mfac),bef1(mfac),bef2(mfac),bef3(mfac),bef4(mfac)
4014 : : integer,save :: bef5(mfac),bef6(mfac),ind1(mg),ind2(mg),ind3(mg),ind4(mg)
4015 : : integer,save :: ind5(mg),ind6(mg),now1(mfac),now2(mfac),now3(mfac),now4(mfac)
4016 : : integer,save :: now5(mfac),now6(mfac)
4017 : : integer :: gbound_dum(4)
4018 : 1094206 : integer,allocatable :: indpw_kin(:,:),indpw_kout(:,:)
4019 : : real(dp),save :: trig1(2,mg),trig2(2,mg),trig3(2,mg),trig4(2,mg),trig5(2,mg)
4020 : : real(dp),save :: trig6(2,mg)
4021 : 1094206 : real(dp),allocatable :: pha1(:,:),pha2(:,:),pha3(:,:),wk1d_a(:,:,:,:)
4022 : 1094206 : real(dp),allocatable :: wk1d_b(:,:,:,:),wk2d_a(:,:,:,:),wk2d_b(:,:,:,:)
4023 : 1094206 : real(dp),allocatable :: wk2d_c(:,:,:,:),wk2d_d(:,:,:,:)
4024 : : #if defined HAVE_OPENMP
4025 : : integer,external :: OMP_GET_NUM_THREADS
4026 : : #endif
4027 : :
4028 : : ! *************************************************************************
4029 : :
4030 [ + + - + ]: 1094206 : if(istwf_k>2 .and. option==0)then
4031 : 0 : write(message,'(a,i0)')' option=0 is not allowed with istwf_k=',istwf_k
4032 : 0 : ABI_BUG(message)
4033 : : end if
4034 : :
4035 [ + + - + ]: 1094206 : if(istwf_k>=2 .and. option==3)then
4036 : 0 : write(message,'(a,i0)')' option=3 is not allowed with istwf_k=',istwf_k
4037 : 0 : ABI_BUG(message)
4038 : : end if
4039 : :
4040 : : !For all other tests of validity of inputs, assume that they
4041 : : !have been done in the calling routine
4042 : :
4043 : 1094206 : n1=ngfft(1) ; n2=ngfft(2) ; n3=ngfft(3) ; nfftot=n1*n2*n3
4044 : 1094206 : fftcache=ngfft(8)
4045 : :
4046 [ + + ]: 1094206 : if(option/=3)then
4047 [ - + + - : 3282573 : ABI_MALLOC(indpw_kin,(4,npwin))
+ - + - -
+ - + ]
4048 : 1094191 : call indfftrisc(gboundin(3:3+2*mgfft+4,1),indpw_kin,kg_kin,mgfft,ngbin,ngfft,npwin)
4049 : : end if
4050 [ + + ]: 1094206 : if(option==2 .or. option==3)then
4051 [ - + + - : 2333187 : ABI_MALLOC(indpw_kout,(4,npwout))
+ - + - -
+ - + ]
4052 : 777729 : call indfftrisc(gboundout(3:3+2*mgfft+4,1),indpw_kout,kg_kout,mgfft,ngbout,ngfft,npwout)
4053 : : end if
4054 : :
4055 : : !Define the dimension of the first work arrays, for 1D transforms along z ,
4056 : : !taking into account the need to avoid the cache trashing
4057 [ + + ]: 1094206 : if(option==2)then
4058 : 777714 : mgb=max(ngbin,ngbout)
4059 [ + + ]: 316492 : else if(option==0 .or. option==1)then
4060 : 316477 : mgb=ngbin ; ngbout=1
4061 [ + - ]: 15 : else if(option==3)then
4062 : 15 : mgb=ngbout ; ngbin=1
4063 : : end if
4064 : :
4065 [ + + ]: 1094206 : if(mod(mgb,2)/=1)mgb=mgb+1
4066 : :
4067 : : !Initialise openmp, if needed
4068 : : !$OMP PARALLEL
4069 : : !$OMP SINGLE
4070 : 1094206 : nproc_omp=1
4071 : : #if defined HAVE_OPENMP
4072 : : nproc_omp=OMP_GET_NUM_THREADS()
4073 : : #endif
4074 : : !$OMP END SINGLE
4075 : : !$OMP END PARALLEL
4076 : :
4077 : : !For the treatment of the z transform,
4078 : : !one tries to use only a fraction of the cache, since the
4079 : : !treatment of the array wk1d_a will not involve contiguous segments
4080 : 1094206 : fraction=0.25
4081 : : !First estimation of lot and nlot
4082 : 1094206 : lot=(fftcache*fraction*1000)/(n3*8*2)+1
4083 : : !Select the smallest integer multiple of nproc_omp, larger
4084 : : !or equal to nlot. In this way, the cache size is not exhausted,
4085 : : !and one takes care correctly of the number of processors.
4086 : : !Treat separately the in and out cases
4087 : 1094206 : nlot=(ngbin-1)/lot+1
4088 : 1094206 : nlot=nproc_omp*((nlot-1)/nproc_omp+1)
4089 : 1094206 : lotin=(ngbin-1)/nlot+1
4090 : 1094206 : nlot=(ngbout-1)/lot+1
4091 : 1094206 : nlot=nproc_omp*((nlot-1)/nproc_omp+1)
4092 : 1094206 : lotout=(ngbout-1)/nlot+1
4093 : : !The next line impose only one lot. Usually, comment it.
4094 : : !lotin=mgb ; lotout=mgb
4095 : :
4096 : : !Compute auxiliary arrays needed for FFTs
4097 [ + + ]: 1094206 : if(n1/=n1_save)then
4098 : 49 : call sg_ctrig(n1,trig1,aft1,bef1,now1,one,ic1,ind1,mfac,mg)
4099 : 49 : call sg_ctrig(n1,trig4,aft4,bef4,now4,-one,ic4,ind4,mfac,mg)
4100 : 49 : n1_save=n1
4101 : : end if
4102 [ + + ]: 1094206 : if(n2/=n2_save)then
4103 : 49 : call sg_ctrig(n2,trig2,aft2,bef2,now2,one,ic2,ind2,mfac,mg)
4104 : 49 : call sg_ctrig(n2,trig5,aft5,bef5,now5,-one,ic5,ind5,mfac,mg)
4105 : 49 : n2_save=n2
4106 : : end if
4107 [ + + ]: 1094206 : if(n3/=n3_save)then
4108 : 49 : call sg_ctrig(n3,trig3,aft3,bef3,now3,one,ic3,ind3,mfac,mg)
4109 : 49 : call sg_ctrig(n3,trig6,aft6,bef6,now6,-one,ic6,ind6,mfac,mg)
4110 : 49 : n3_save=n3
4111 : : end if
4112 : :
4113 : : !------------------------------------------------------------------
4114 : : !Here, call general k-point code
4115 : :
4116 [ + + ]: 1094206 : if(istwf_k==1)then
4117 : :
4118 : : ! Note that the z transform will appear as a y transform
4119 [ - + + - : 4373132 : ABI_MALLOC(wk1d_a,(2,mgb,n3,1))
- + + - +
- + - - +
- + ]
4120 [ - + + - : 3279849 : ABI_MALLOC(wk1d_b,(2,mgb,n3,1))
- + + - -
+ - + ]
4121 : :
4122 [ + + ]: 1093283 : if(option/=3)then
4123 : :
4124 : : !$OMP PARALLEL DO DEFAULT(PRIVATE) SHARED(n3,ngbin,wk1d_a)
4125 [ + + ]: 19191937 : do i3=1,n3
4126 [ + + ]: 648870515 : do igb=1,ngbin
4127 : 629678578 : wk1d_a(1,igb,i3,1)=zero
4128 : 647777247 : wk1d_a(2,igb,i3,1)=zero
4129 : : end do
4130 : : end do
4131 : : !$OMP END PARALLEL DO
4132 : :
4133 : : ! Insert fofgin into the work array
4134 : : !$OMP PARALLEL DO DEFAULT(PRIVATE) SHARED(fofgin,indpw_kin,npwin,wk1d_a)
4135 [ + + ]: 147962380 : do ig=1,npwin
4136 : 146869112 : igb=indpw_kin(4,ig) ; i3=indpw_kin(3,ig)
4137 : 146869112 : wk1d_a(1,igb,i3,1)=fofgin(1,ig)
4138 : 147962380 : wk1d_a(2,igb,i3,1)=fofgin(2,ig)
4139 : : end do
4140 : : !$OMP END PARALLEL DO
4141 : :
4142 : : ! Go from wk1d_a to wk1d_b, using 1D FFTs on the z direction
4143 : : ! However, due to special packing of data, use routine ffty
4144 : : !$OMP PARALLEL DO SHARED(aft3,bef3,fftcache,ind3,ic3,lotin,mgb)&
4145 : : !$OMP&SHARED(ngbin,now3,n3,trig3,wk1d_a,wk1d_b)&
4146 : : !$OMP&PRIVATE(igb,igbmax)
4147 [ - + - - : 4246621 : do igb=1,ngbin,lotin
- + + + ]
4148 : 3153353 : igbmax=min(igb+lotin-1,ngbin)
4149 : : ! Go from wk1d_a to wk1d_b, using 1D FFTs on the z direction
4150 : : ! However, due to special packing of data, use routine ffty
4151 : : call sg_ffty(fftcache,mfac,mg,mgb,n3,1,igb,igbmax,1,1,wk1d_a,wk1d_b, &
4152 : 4246621 : & trig3,aft3,now3,bef3,one,ind3,ic3)
4153 : : end do
4154 : : !$OMP END PARALLEL DO
4155 : :
4156 : : end if ! if(option/=3)
4157 : :
4158 : : ! Do-loop on the planes stacked in the z direction
4159 : : !$OMP PARALLEL DEFAULT(PRIVATE) &
4160 : : !$OMP&SHARED(aft1,aft2,aft4,aft5,bef1,bef2,bef4,bef5,cplex,denpot) &
4161 : : !$OMP&SHARED(fftcache,fofr,gboundin,gboundout)&
4162 : : !$OMP&SHARED(ic1,ic2,ic4,ic5,ind1,ind2,ind4) &
4163 : : !$OMP&SHARED(ind5,indpw_kin,indpw_kout,mgb,n1,n2,n3,n4,n5,ngbin) &
4164 : : !$OMP&SHARED(ngbout,now1,now2,now4,now5,option,trig1,trig2,trig4,trig5) &
4165 : : !$OMP&SHARED(weight_r,weight_i,wk1d_a,wk1d_b)
4166 : :
4167 : : ! Allocate two 2-dimensional work arrays
4168 [ - + + - : 4373132 : ABI_MALLOC(wk2d_a,(2,n4,n5,1))
- + + - +
- + - - +
- + ]
4169 [ - + + - : 3279849 : ABI_MALLOC(wk2d_b,(2,n4,n5,1))
- + + - -
+ - + ]
4170 : : !$OMP DO
4171 [ + + ]: 19193402 : do i3=1,n3
4172 : :
4173 [ + + ]: 18100119 : if(option/=3)then
4174 : : ! Zero the values on the current plane
4175 : : ! wk2d_a(1:2,1:n1,1:n2,1)=zero
4176 [ + + ]: 312441000 : do i2=1,n2
4177 [ + + ]: 5265756293 : do i1=1,n1
4178 : 4953315293 : wk2d_a(1,i1,i2,1)=zero
4179 : 5247657624 : wk2d_a(2,i1,i2,1)=zero
4180 : : end do
4181 : : end do
4182 : : ! Copy the data in the current plane
4183 [ + + ]: 647777247 : do igb=1,ngbin
4184 : 629678578 : i1=indpw_kin(1,igb) ; i2=indpw_kin(2,igb)
4185 : 629678578 : wk2d_a(1,i1,i2,1)=wk1d_b(1,igb,i3,1)
4186 : 647777247 : wk2d_a(2,i1,i2,1)=wk1d_b(2,igb,i3,1)
4187 : : end do
4188 : : ! Perform x transform, taking into account arrays of zeros
4189 : 18098669 : g2min=gboundin(3,1) ; g2max=gboundin(4,1)
4190 [ + - ]: 18098669 : if ( g2min+n2 >= g2max+2 ) then
4191 [ + + ]: 188349504 : do i2=g2max+2,g2min+n2
4192 [ + + ]: 3039458791 : do i1=1,n1
4193 : 2851109287 : wk2d_b(1,i1,i2,1)=zero
4194 : 3021360122 : wk2d_b(2,i1,i2,1)=zero
4195 : : end do
4196 : : end do
4197 : : end if
4198 : 18098669 : gbound_dum(1)=1 ; gbound_dum(2)=1
4199 : 18098669 : gbound_dum(3)=g2min ; gbound_dum(4)=g2max
4200 : : call sg_fftpx(fftcache,mfac,mg,0,n4,n5,1,n2,1,wk2d_a,wk2d_b,&
4201 : 18098669 : & trig1,aft1,now1,bef1,one,ind1,ic1,gbound_dum)
4202 : : ! Perform y transform
4203 : 18098669 : n1i=1
4204 : : call sg_ffty(fftcache,mfac,mg,n4,n5,1,n1i,n1,1,1,wk2d_b,wk2d_a, &
4205 : 18098669 : & trig2,aft2,now2,bef2,one,ind2,ic2)
4206 : : ! The wave function is now in real space, for the current plane
4207 : : end if
4208 : :
4209 [ + + ]: 18100119 : if(option==0)then ! Copy the transformed function at the right place
4210 [ + + ]: 63675490 : do i2=1,n2
4211 [ + + ]: 962390250 : do i1=1,n1
4212 : 898714760 : fofr(1,i1,i2,i3)=wk2d_a(1,i1,i2,1)
4213 : 958330540 : fofr(2,i1,i2,i3)=wk2d_a(2,i1,i2,1)
4214 : : end do
4215 : : end do
4216 : : end if
4217 : :
4218 [ + + ]: 18100119 : if(option==1)then ! Accumulate density
4219 [ + + ]: 14349936 : do i2=1,n2
4220 [ + + ]: 276920964 : do i1=1,n1
4221 : 276178104 : denpot(i1,i2,i3)=denpot(i1,i2,i3)+weight_r*wk2d_a(1,i1,i2,1)**2+weight_i*wk2d_a(2,i1,i2,1)**2
4222 : : end do
4223 : : end do
4224 : : end if
4225 : :
4226 [ + + ]: 18100119 : if(option==2)then ! Apply local potential
4227 [ + + ]: 13296099 : if(cplex==1)then
4228 [ + + ]: 208807794 : do i2=1,n2
4229 [ + + ]: 3606994739 : do i1=1,n1
4230 : 3398186945 : wk2d_a(1,i1,i2,1)=denpot(i1,i2,i3)*wk2d_a(1,i1,i2,1)
4231 : 3595217700 : wk2d_a(2,i1,i2,1)=denpot(i1,i2,i3)*wk2d_a(2,i1,i2,1)
4232 : : end do
4233 : : end do
4234 : : else
4235 [ + + ]: 25607780 : do i2=1,n2
4236 [ + + ]: 419450340 : do i1=1,n1
4237 : 393842560 : wkre=wk2d_a(1,i1,i2,1)
4238 : 393842560 : wkim=wk2d_a(2,i1,i2,1)
4239 : 393842560 : wk2d_a(1,i1,i2,1)=denpot(2*i1-1,i2,i3)*wkre -denpot(2*i1 ,i2,i3)*wkim
4240 : 417931280 : wk2d_a(2,i1,i2,1)=denpot(2*i1-1,i2,i3)*wkim +denpot(2*i1 ,i2,i3)*wkre
4241 : : end do
4242 : : end do
4243 : : end if
4244 : : end if
4245 : :
4246 [ + + ]: 18100119 : if(option==3)then ! Copy the function to be tranformed at the right place
4247 [ + + ]: 141950 : do i2=1,n2
4248 [ + + ]: 13786950 : do i1=1,n1
4249 : 13645000 : wk2d_a(1,i1,i2,1)=fofr(1,i1,i2,i3)
4250 : 13785500 : wk2d_a(2,i1,i2,1)=fofr(2,i1,i2,i3)
4251 : : end do
4252 : : end do
4253 : : end if
4254 : :
4255 [ + + ]: 19193402 : if(option==2 .or. option==3)then ! Perform y transform
4256 : 13297549 : n1i=1
4257 : : call sg_ffty(fftcache,mfac,mg,n4,n5,1,n1i,n1,1,1,wk2d_a,wk2d_b, &
4258 : 13297549 : & trig5,aft5,now5,bef5,-one,ind5,ic5)
4259 : : ! Perform x transform, taking into account arrays of zeros
4260 : 13297549 : gbound_dum(1)=1 ; gbound_dum(2)=1
4261 : 13297549 : gbound_dum(3)=gboundout(3,1) ; gbound_dum(4)=gboundout(4,1)
4262 : : call sg_fftpx(fftcache,mfac,mg,0,n4,n5,1,n2,1,wk2d_b,wk2d_a,&
4263 : 13297549 : & trig4,aft4,now4,bef4,-one,ind4,ic4,gbound_dum)
4264 : : ! Copy the data from the current plane to wk1d_b
4265 [ + + ]: 507115879 : do igb=1,ngbout
4266 : 493818330 : i1=indpw_kout(1,igb) ; i2=indpw_kout(2,igb)
4267 : 493818330 : wk1d_b(1,igb,i3,1)=wk2d_a(1,i1,i2,1)
4268 : 507115879 : wk1d_b(2,igb,i3,1)=wk2d_a(2,i1,i2,1)
4269 : : end do
4270 : : end if
4271 : :
4272 : : ! End loop on planes
4273 : : end do
4274 : : !$OMP END DO
4275 [ - + ]: 1093283 : ABI_FREE(wk2d_a)
4276 [ - + ]: 1093283 : ABI_FREE(wk2d_b)
4277 : : !$OMP END PARALLEL
4278 : :
4279 [ + + ]: 1093283 : if(option==2 .or. option==3)then
4280 : :
4281 : : ! Go from wk1d_b to wk1d_a, using 1D FFTs on the z direction
4282 : : ! However, due to special packing of data, use routine ffty
4283 : : !$OMP PARALLEL DO SHARED(aft6,bef6,fftcache,ind6,ic6,lotout,mgb)&
4284 : : !$OMP&SHARED(ngbout,now6,n3,trig6,wk1d_a,wk1d_b)&
4285 : : !$OMP&PRIVATE(igb,igbmax)
4286 [ - + - - : 3198687 : do igb=1,ngbout,lotout
- + + + ]
4287 : 2421384 : igbmax=min(igb+lotout-1,ngbout)
4288 : : ! Go from wk1d_b to wk1d_a, using 1D FFTs on the z direction
4289 : : ! However, due to special packing of data, use routine ffty
4290 : : call sg_ffty(fftcache,mfac,mg,mgb,n3,1,igb,igbmax,1,1,wk1d_b,wk1d_a, &
4291 : 3198687 : & trig6,aft6,now6,bef6,-one,ind6,ic6)
4292 : :
4293 : : end do
4294 : : !$OMP END PARALLEL DO
4295 : :
4296 : : ! Transfer the data in the output array, after normalization
4297 : 777303 : norm=1.d0/dble(nfftot)
4298 : : !$OMP PARALLEL DO DEFAULT(PRIVATE) SHARED(fofgout,indpw_kout,norm,npwout,wk1d_a)
4299 [ + + ]: 116753350 : do ig=1,npwout
4300 : 115976047 : igb=indpw_kout(4,ig) ; i3=indpw_kout(3,ig)
4301 : 115976047 : fofgout(1,ig)=wk1d_a(1,igb,i3,1)*norm
4302 : 116753350 : fofgout(2,ig)=wk1d_a(2,igb,i3,1)*norm
4303 : : end do
4304 : : !$OMP END PARALLEL DO
4305 : : end if
4306 : :
4307 [ - + ]: 1093283 : ABI_FREE(wk1d_a)
4308 [ - + ]: 1093283 : ABI_FREE(wk1d_b)
4309 : :
4310 : : ! End general k-point part
4311 : : end if
4312 : :
4313 : : !------------------------------------------------------------------
4314 : : !Here, use of time-reversal symmetry
4315 : :
4316 [ + + ]: 1094206 : if(istwf_k>=2)then
4317 : :
4318 : 923 : n1half1=n1/2+1 ; n1halfm=(n1+1)/2
4319 : 923 : n2half1=n2/2+1
4320 : : ! n4half1 or n5half1 are the odd integers >= n1half1 or n2half1
4321 : 923 : n4half1=(n1half1/2)*2+1
4322 : 923 : n5half1=(n2half1/2)*2+1
4323 : : ! Note that the z transform will appear as a y transform
4324 [ - + + - : 3692 : ABI_MALLOC(wk1d_a,(2,mgb,n3,1))
- + + - +
- + - - +
- + ]
4325 [ - + + - : 2769 : ABI_MALLOC(wk1d_b,(2,mgb,n3,1))
- + + - -
+ - + ]
4326 : :
4327 [ + + ]: 923 : if(istwf_k/=2)then
4328 [ - + + - : 1401 : ABI_MALLOC(pha1,(2,n1))
+ - + - -
+ - + ]
4329 [ - + + - : 1401 : ABI_MALLOC(pha2,(2,n2))
+ - + - -
+ - + ]
4330 [ - + + - : 1401 : ABI_MALLOC(pha3,(3,n3))
+ - + - -
+ - + ]
4331 [ + + ]: 11672 : do i1=1,n1
4332 : 11205 : pha1(1,i1)=cos(dble(i1-1)*pi/dble(n1))
4333 : 11672 : pha1(2,i1)=sin(dble(i1-1)*pi/dble(n1))
4334 : : end do
4335 [ + + ]: 11462 : do i2=1,n2
4336 : 10995 : pha2(1,i2)=cos(dble(i2-1)*pi/dble(n2))
4337 : 11462 : pha2(2,i2)=sin(dble(i2-1)*pi/dble(n2))
4338 : : end do
4339 [ + + ]: 12022 : do i3=1,n3
4340 : 11555 : pha3(1,i3)=cos(dble(i3-1)*pi/dble(n3))
4341 : 12022 : pha3(2,i3)=sin(dble(i3-1)*pi/dble(n3))
4342 : : end do
4343 : : end if
4344 : :
4345 [ + - ]: 923 : if(option/=3)then
4346 : :
4347 : : ! Zero the components of wk1d_a
4348 : : !$OMP PARALLEL DO DEFAULT(PRIVATE) SHARED(n3,ngbin,wk1d_a)
4349 [ + + ]: 30966 : do i3=1,n3
4350 [ + + ]: 8001269 : do igb=1,ngbin
4351 : 7970303 : wk1d_a(1,igb,i3,1)=zero
4352 : 8000346 : wk1d_a(2,igb,i3,1)=zero
4353 : : end do
4354 : : end do
4355 : : !$OMP END PARALLEL DO
4356 : :
4357 : : ! Insert fofgin into the work array
4358 : : !$OMP PARALLEL DO DEFAULT(PRIVATE) SHARED(fofgin,indpw_kin,npwin,wk1d_a)
4359 [ + + ]: 2495513 : do ig=1,npwin
4360 : 2494590 : igb=indpw_kin(4,ig) ; i3=indpw_kin(3,ig)
4361 : 2494590 : wk1d_a(1,igb,i3,1)=fofgin(1,ig)
4362 : 2495513 : wk1d_a(2,igb,i3,1)=fofgin(2,ig)
4363 : : end do
4364 : : !$OMP END PARALLEL DO
4365 : :
4366 : : ! Must complete the i2=1 plane when $k_y \equiv 0$
4367 : :
4368 : : ! Take care of i1=1 when $k_x \equiv 0$
4369 [ + + ]: 923 : if(istwf_k==2)then
4370 : : ! Take care of i1=1
4371 [ + + ]: 9766 : do i3=n3/2+1,n3
4372 : 9310 : i3inv=n3+2-i3
4373 : 9310 : wk1d_a(1,1,i3,1)= wk1d_a(1,1,i3inv,1)
4374 : 9766 : wk1d_a(2,1,i3,1)=-wk1d_a(2,1,i3inv,1)
4375 : : end do
4376 [ + + ]: 467 : else if(istwf_k==4)then
4377 : : ! Take care of i1=1
4378 [ + + ]: 896 : do i3=n3/2+1,n3
4379 : 832 : i3inv=n3+1-i3
4380 : 832 : wk1d_a(1,1,i3,1)= wk1d_a(1,1,i3inv,1)
4381 : 896 : wk1d_a(2,1,i3,1)=-wk1d_a(2,1,i3inv,1)
4382 : : end do
4383 : : end if
4384 : :
4385 : : ! Now, take care of other i1 values, except i3==1 when $k_z \equiv 0$
4386 : 923 : i1max=gboundin(6,1)+1
4387 [ + + ]: 923 : if(istwf_k==2)then
4388 : : !$OMP PARALLEL DO DEFAULT(PRIVATE) SHARED(i1max,n3,wk1d_a)
4389 [ + + ]: 9100 : do igb=2,2*i1max-1
4390 : 8644 : igb_inv=2*i1max+1-igb
4391 [ + + ]: 222860 : do i3=n3/2+1,n3
4392 : 213760 : i3inv=n3+2-i3
4393 : 213760 : wk1d_a(1,igb,i3,1)= wk1d_a(1,igb_inv,i3inv,1)
4394 : 222404 : wk1d_a(2,igb,i3,1)=-wk1d_a(2,igb_inv,i3inv,1)
4395 : : end do
4396 : : end do
4397 : : !$OMP END PARALLEL DO
4398 : :
4399 [ + + ]: 467 : else if(istwf_k==3)then
4400 : : !$OMP PARALLEL DO DEFAULT(PRIVATE) SHARED(i1max,n3,wk1d_a)
4401 [ + + ]: 755 : do igb=1,2*i1max
4402 : 690 : igb_inv=2*i1max+1-igb
4403 [ + + ]: 17795 : do i3=n3/2+1,n3
4404 : 17040 : i3inv=n3+2-i3
4405 : 17040 : wk1d_a(1,igb,i3,1)= wk1d_a(1,igb_inv,i3inv,1)
4406 : 17730 : wk1d_a(2,igb,i3,1)=-wk1d_a(2,igb_inv,i3inv,1)
4407 : : end do
4408 : : end do
4409 : : !$OMP END PARALLEL DO
4410 : :
4411 [ + + ]: 402 : else if(istwf_k==4)then
4412 : : !$OMP PARALLEL DO DEFAULT(PRIVATE) SHARED(i1max,n3,wk1d_a)
4413 [ + + ]: 748 : do igb=2,2*i1max-1
4414 : 684 : igb_inv=2*i1max+1-igb
4415 [ + + ]: 17740 : do i3=n3/2+1,n3
4416 : 16992 : i3inv=n3+1-i3
4417 : 16992 : wk1d_a(1,igb,i3,1)= wk1d_a(1,igb_inv,i3inv,1)
4418 : 17676 : wk1d_a(2,igb,i3,1)=-wk1d_a(2,igb_inv,i3inv,1)
4419 : : end do
4420 : : end do
4421 : : !$OMP END PARALLEL DO
4422 : :
4423 [ + + ]: 338 : else if(istwf_k==5)then
4424 : : !$OMP PARALLEL DO DEFAULT(PRIVATE) SHARED(i1max,n3,wk1d_a)
4425 [ + + ]: 790 : do igb=1,2*i1max
4426 : 720 : igb_inv=2*i1max+1-igb
4427 [ + + ]: 18070 : do i3=n3/2+1,n3
4428 : 17280 : i3inv=n3+1-i3
4429 : 17280 : wk1d_a(1,igb,i3,1)= wk1d_a(1,igb_inv,i3inv,1)
4430 : 18000 : wk1d_a(2,igb,i3,1)=-wk1d_a(2,igb_inv,i3inv,1)
4431 : : end do
4432 : : end do
4433 : : !$OMP END PARALLEL DO
4434 : :
4435 : : end if
4436 : :
4437 : : ! Now, i3==1
4438 [ + + ]: 923 : if(istwf_k==2)then
4439 [ + + ]: 4778 : do igb=2,i1max
4440 : 4322 : igb_inv=2*i1max+1-igb
4441 : 4322 : wk1d_a(1,igb_inv,1,1)= wk1d_a(1,igb,1,1)
4442 : 4778 : wk1d_a(2,igb_inv,1,1)=-wk1d_a(2,igb,1,1)
4443 : : end do
4444 [ + + ]: 467 : else if(istwf_k==3)then
4445 [ + + ]: 410 : do igb=1,i1max
4446 : 345 : igb_inv=2*i1max+1-igb
4447 : 345 : wk1d_a(1,igb_inv,1,1)= wk1d_a(1,igb,1,1)
4448 : 410 : wk1d_a(2,igb_inv,1,1)=-wk1d_a(2,igb,1,1)
4449 : : end do
4450 : : end if
4451 : :
4452 : : ! Go from wk1d_a to wk1d_b, using 1D FFTs on the z direction
4453 : : ! However, due to special packing of data, use routine ffty
4454 : : !$OMP PARALLEL DO SHARED(aft3,bef3,fftcache,ind3,ic3,lotin,mgb)&
4455 : : !$OMP&SHARED(ngbin,now3,n3,trig3,wk1d_a,wk1d_b)&
4456 : : !$OMP&PRIVATE(igb,igbmax)
4457 [ - + - - : 28173 : do igb=1,ngbin,lotin
- + + + ]
4458 : 27250 : igbmax=min(igb+lotin-1,ngbin)
4459 : : ! Go from wk1d_a to wk1d_b, using 1D FFTs on the z direction
4460 : : ! However, due to special packing of data, use routine ffty
4461 : : call sg_ffty(fftcache,mfac,mg,mgb,n3,1,igb,igbmax,1,1,wk1d_a,wk1d_b, &
4462 : 28173 : & trig3,aft3,now3,bef3,one,ind3,ic3)
4463 : : end do
4464 : : !$OMP END PARALLEL DO
4465 : :
4466 : : ! Change the phase if $k_z \neq 0$
4467 [ + + ]: 923 : if(istwf_k==4 .or. istwf_k==5 .or. istwf_k==8 .or. istwf_k==9 )then
4468 : : !$OMP PARALLEL DO DEFAULT(PRIVATE) SHARED(ngbin,n3,pha3,wk1d_b)
4469 [ + + ]: 6904 : do i3=1,n3
4470 : 6635 : phar=pha3(1,i3)
4471 : 6635 : phai=pha3(2,i3)
4472 [ + + ]: 1608459 : do igb=1,ngbin
4473 : 1601555 : ar=wk1d_b(1,igb,i3,1)
4474 : 1601555 : ai=wk1d_b(2,igb,i3,1)
4475 : 1601555 : wk1d_b(1,igb,i3,1)=phar*ar-phai*ai
4476 : 1608190 : wk1d_b(2,igb,i3,1)=phai*ar+phar*ai
4477 : : end do
4478 : : end do
4479 : : !$OMP END PARALLEL DO
4480 : : end if
4481 : :
4482 : : end if ! if(option/=3)
4483 : :
4484 : : ! Do-loop on the planes stacked in the z direction
4485 : :
4486 : : !$OMP PARALLEL DEFAULT(PRIVATE) &
4487 : : !$OMP&SHARED(aft1,aft2,aft4,aft5,bef1,bef2,bef4,bef5,denpot) &
4488 : : !$OMP&SHARED(fftcache,fofr,gboundin,ic1,ic2,ic4,ic5,ind1,ind2,ind4,ind5) &
4489 : : !$OMP&SHARED(indpw_kin,indpw_kout,istwf_k,mgb,n1,n1half1) &
4490 : : !$OMP&SHARED(n1halfm,n2,n2half1,n3,n4,n5,ngbin,ngbout) &
4491 : : !$OMP&SHARED(now1,now2,now4,now5,option,pha1,pha2,trig1) &
4492 : : !$OMP&SHARED(trig2,trig4,trig5,weight_r,weight_i,wk1d_a,wk1d_b)
4493 : :
4494 : : ! Allocate two 2-dimensional work arrays
4495 [ - + + - : 3692 : ABI_MALLOC(wk2d_a,(2,n4,n5,1))
- + + - +
- + - - +
- + ]
4496 [ - + + - : 2769 : ABI_MALLOC(wk2d_b,(2,n4,n5,1))
- + + - -
+ - + ]
4497 [ + - - + : 3692 : ABI_MALLOC(wk2d_c,(2,2*n1halfm,n5,1))
+ - - + +
- + - + -
- + - + ]
4498 [ - + + - : 2769 : ABI_MALLOC(wk2d_d,(2,2*n1halfm,n5,1))
- + + - -
+ - + ]
4499 : : !$OMP DO
4500 [ + + ]: 30966 : do i3=1,n3
4501 : :
4502 : 30043 : g2max=gboundin(4,1)
4503 : :
4504 [ + - ]: 30043 : if(option/=3)then
4505 : : ! Zero the values on the current plane : need only from i2=1 to g2max+1
4506 [ + + ]: 360827 : do i2=1,g2max+1
4507 [ + + ]: 21292195 : do i1=1,n1
4508 : 20931368 : wk2d_a(1,i1,i2,1)=zero
4509 : 21262152 : wk2d_a(2,i1,i2,1)=zero
4510 : : end do
4511 : : end do
4512 : :
4513 : : ! Copy the data in the current plane
4514 [ + + ]: 8000346 : do igb=1,ngbin
4515 : 7970303 : i1=indpw_kin(1,igb) ; i2=indpw_kin(2,igb)
4516 : 7970303 : wk2d_a(1,i1,i2,1)=wk1d_b(1,igb,i3,1)
4517 : 8000346 : wk2d_a(2,i1,i2,1)=wk1d_b(2,igb,i3,1)
4518 : : end do
4519 : :
4520 : : ! Perform x transform, taking into account arrays of zeros
4521 : : call sg_fftx(fftcache,mfac,mg,n4,n5,1,g2max+1,1,wk2d_a,wk2d_b,&
4522 : 30043 : & trig1,aft1,now1,bef1,one,ind1,ic1)
4523 : :
4524 : : ! Change the phase if $k_x \neq 0$
4525 [ + + ]: 30043 : if(istwf_k==3 .or. istwf_k==5 .or. istwf_k==7 .or. istwf_k==9)then
4526 [ + + ]: 298400 : do i1=1,n1
4527 : 291750 : phar=pha1(1,i1)
4528 : 291750 : phai=pha1(2,i1)
4529 [ + + ]: 4559525 : do i2=1,g2max+1
4530 : 4261125 : ar=wk2d_b(1,i1,i2,1)
4531 : 4261125 : ai=wk2d_b(2,i1,i2,1)
4532 : 4261125 : wk2d_b(1,i1,i2,1)=phar*ar-phai*ai
4533 : 4552875 : wk2d_b(2,i1,i2,1)=phai*ar+phar*ai
4534 : : end do
4535 : : end do
4536 : : end if
4537 : :
4538 : : ! Compute symmetric and antisymmetric combinations
4539 [ + + ]: 30043 : if(istwf_k>=2 .and. istwf_k<=5)then
4540 [ + + ]: 601436 : do i1=1,n1half1-1
4541 : 578013 : wk2d_a(1,i1,1,1)=wk2d_b(1,2*i1-1,1,1)
4542 : 601436 : wk2d_a(2,i1,1,1)=wk2d_b(1,2*i1 ,1,1)
4543 : : end do
4544 : : ! If n1 odd, must add last data
4545 [ + + ]: 23423 : if((2*n1half1-2)/=n1)then
4546 : 6135 : wk2d_a(1,n1half1,1,1)=wk2d_b(1,n1,1,1)
4547 : 6135 : wk2d_a(2,n1half1,1,1)=zero
4548 : : end if
4549 : : ii2=2
4550 : : else
4551 : : ii2=1
4552 : : end if
4553 [ + - ]: 30043 : if( g2max+1 >= ii2)then
4554 [ + + ]: 337404 : do i2=ii2,g2max+1
4555 [ + + ]: 10127032 : do i1=1,n1half1-1
4556 : 9819671 : wk2d_a(1,i1,i2,1)= wk2d_b(1,2*i1-1,i2,1)-wk2d_b(2,2*i1,i2,1)
4557 : 9819671 : wk2d_a(2,i1,i2,1)= wk2d_b(2,2*i1-1,i2,1)+wk2d_b(1,2*i1,i2,1)
4558 : 9819671 : wk2d_a(1,i1,n2+ii2-i2,1)= wk2d_b(1,2*i1-1,i2,1)+wk2d_b(2,2*i1,i2,1)
4559 : 10127032 : wk2d_a(2,i1,n2+ii2-i2,1)=-wk2d_b(2,2*i1-1,i2,1)+wk2d_b(1,2*i1,i2,1)
4560 : : end do
4561 [ + + ]: 337404 : if((2*n1half1-2)/=n1)then
4562 : 129865 : wk2d_a(1,n1half1,i2,1)= wk2d_b(1,n1,i2,1)
4563 : 129865 : wk2d_a(2,n1half1,i2,1)= wk2d_b(2,n1,i2,1)
4564 : 129865 : wk2d_a(1,n1half1,n2+ii2-i2,1)= wk2d_b(1,n1,i2,1)
4565 : 129865 : wk2d_a(2,n1half1,n2+ii2-i2,1)=-wk2d_b(2,n1,i2,1)
4566 : : end if
4567 : : end do
4568 : : end if
4569 [ + - ]: 30043 : if ( n2half1 >= g2max+2 ) then
4570 [ + + ]: 407755 : do i2=g2max+2,n2half1
4571 [ + + ]: 12042944 : do i1=1,n1half1-1
4572 : 11665232 : wk2d_a(1,i1,i2,1)=zero
4573 : 11665232 : wk2d_a(2,i1,i2,1)=zero
4574 : 11665232 : wk2d_a(1,i1,n2+ii2-i2,1)=zero
4575 : 12042944 : wk2d_a(2,i1,n2+ii2-i2,1)=zero
4576 : : end do
4577 [ + + ]: 407755 : if((2*n1half1-2)/=n1)then
4578 : 163240 : wk2d_a(1,n1half1,i2,1)=zero
4579 : 163240 : wk2d_a(2,n1half1,i2,1)=zero
4580 : 163240 : wk2d_a(1,n1half1,n2+ii2-i2,1)=zero
4581 : 163240 : wk2d_a(2,n1half1,n2+ii2-i2,1)=zero
4582 : : end if
4583 : : end do
4584 : : end if
4585 : :
4586 : 30043 : n1i=1
4587 : : call sg_ffty(fftcache,mfac,mg,n4,n5,1,n1i,n1halfm,1,1,wk2d_a,wk2d_b,&
4588 : 30043 : & trig2,aft2,now2,bef2,one,ind2,ic2)
4589 : :
4590 : : ! Change the phase if $k_y \neq 0$
4591 [ + + ]: 30043 : if(istwf_k>=6 .and. istwf_k<=9)then
4592 [ + + ]: 288320 : do i2=1,n2
4593 : 281700 : phar=pha2(1,i2)
4594 : 281700 : phai=pha2(2,i2)
4595 [ + + ]: 9453920 : do i1=1,n1halfm
4596 : 9165600 : ar=wk2d_b(1,i1,i2,1)
4597 : 9165600 : ai=wk2d_b(2,i1,i2,1)
4598 : 9165600 : wk2d_b(1,i1,i2,1)= phar*ar-phai*ai
4599 : 9447300 : wk2d_b(2,i1,i2,1)= phai*ar+phar*ai
4600 : : end do
4601 : : end do
4602 : : end if
4603 : :
4604 : : end if ! option/=3
4605 : :
4606 : : ! The wave function is now in real space, for the current plane,
4607 : : ! represented by REAL numbers, although packed in the complex array wk2d_b
4608 : :
4609 : 30043 : g2max=gboundin(4,1)
4610 : :
4611 [ + + ]: 30043 : if(option==0)then
4612 : : ! This option is only permitted for istwf_k==2 (Gamma point)
4613 : : ! Copy the transformed function at the right place
4614 [ + + ]: 681364 : do i2=1,n2
4615 [ + + ]: 20170672 : do i1=1,n1half1-1
4616 : 19503836 : fofr(1,2*i1-1,i2,i3)=wk2d_b(1,i1,i2,1)
4617 : 19503836 : fofr(1,2*i1 ,i2,i3)=wk2d_b(2,i1,i2,1)
4618 : 19503836 : fofr(2,2*i1-1,i2,i3)=zero
4619 : 20170672 : fofr(2,2*i1 ,i2,i3)=zero
4620 : : end do
4621 : : ! If n1 odd, must add last data
4622 [ + + ]: 681364 : if((2*n1half1-2)/=n1)then
4623 : 28800 : fofr(1,n1,i2,i3)=wk2d_b(1,n1half1,i2,1)
4624 : 28800 : fofr(2,n1,i2,i3)=zero
4625 : : end if
4626 : : end do
4627 : : end if
4628 : :
4629 [ + + ]: 30043 : if(option==1)then ! Accumulate density
4630 [ + + ]: 314100 : do i2=1,n2
4631 [ + + ]: 11601264 : do i1=1,n1half1-1
4632 : 11292496 : denpot(2*i1-1,i2,i3)=denpot(2*i1-1,i2,i3)+weight_r*wk2d_b(1,i1,i2,1)**2
4633 : 11601264 : denpot(2*i1 ,i2,i3)=denpot(2*i1 ,i2,i3)+weight_i*wk2d_b(2,i1,i2,1)**2
4634 : : end do
4635 : : ! If n1 odd, must add last data
4636 [ + + ]: 314100 : if((2*n1half1-2)/=n1)then
4637 : 248400 : denpot(n1,i2,i3)=denpot(n1,i2,i3)+weight_r*wk2d_b(1,n1half1,i2,1)**2
4638 : : end if
4639 : : end do
4640 : : end if
4641 : :
4642 [ + + ]: 30043 : if(option==2)then ! Apply local potential
4643 [ + + ]: 403380 : do i2=1,n2
4644 [ + + ]: 12484056 : do i1=1,n1half1-1
4645 : 12090859 : wk2d_a(1,i1,i2,1)=denpot(2*i1-1,i2,i3)*wk2d_b(1,i1,i2,1)
4646 : 12484056 : wk2d_a(2,i1,i2,1)=denpot(2*i1 ,i2,i3)*wk2d_b(2,i1,i2,1)
4647 : : end do
4648 : : ! If n1 odd, must add last data
4649 [ + + ]: 403380 : if((2*n1half1-2)/=n1)then
4650 : 301725 : wk2d_a(1,n1half1,i2,1)=denpot(n1,i2,i3)*wk2d_b(1,n1half1,i2,1)
4651 : 301725 : wk2d_a(2,n1half1,i2,1)=zero
4652 : : end if
4653 : : end do
4654 : : end if
4655 : :
4656 [ - + ]: 30043 : if(option==3)then
4657 : : ! This option is only permitted for istwf_k==2 (Gamma point)
4658 : : ! Copy the transformed function at the right place
4659 [ # # ]: 0 : do i2=1,n2
4660 [ # # ]: 0 : do i1=1,n1half1-1
4661 : 0 : wk2d_b(1,i1,i2,1)=fofr(1,2*i1-1,i2,i3)
4662 : 0 : wk2d_b(2,i1,i2,1)=fofr(1,2*i1 ,i2,i3)
4663 : : end do
4664 : : ! If n1 odd, must add last data
4665 [ # # ]: 0 : if((2*n1half1-2)/=n1)then
4666 : 0 : wk2d_b(1,n1half1,i2,1)=fofr(1,n1,i2,i3)
4667 : : end if
4668 : : end do
4669 : : end if
4670 : :
4671 [ + + ]: 30966 : if(option==2 .or. option==3)then ! Change the phase if $k_y \neq 0$
4672 [ + + ]: 10183 : if(istwf_k>=6 .and. istwf_k<=9)then
4673 [ + + ]: 160480 : do i2=1,n2
4674 : 156150 : phar=pha2(1,i2)
4675 : 156150 : phai=pha2(2,i2)
4676 [ + + ]: 4865680 : do i1=1,n1halfm
4677 : 4705200 : ar=wk2d_a(1,i1,i2,1)
4678 : 4705200 : ai=wk2d_a(2,i1,i2,1)
4679 : 4705200 : wk2d_a(1,i1,i2,1)= phar*ar+phai*ai
4680 : 4861350 : wk2d_a(2,i1,i2,1)=-phai*ar+phar*ai
4681 : : end do
4682 : : end do
4683 : : end if
4684 : :
4685 : : ! Perform y transform
4686 : 10183 : n1i=1
4687 : : call sg_ffty(fftcache,mfac,mg,n4,n5,1,n1i,n1halfm,1,1,wk2d_a,wk2d_b, &
4688 : 10183 : & trig5,aft5,now5,bef5,-one,ind5,ic5)
4689 : :
4690 : : ! Decompose symmetric and antisymmetric parts
4691 [ + + ]: 10183 : if(istwf_k>=2 .and. istwf_k<=5)then
4692 [ + + ]: 131469 : do i1=1,n1halfm
4693 : 125616 : wk2d_c(1,2*i1-1,1,1)=wk2d_b(1,i1,1,1)
4694 : 125616 : wk2d_c(2,2*i1-1,1,1)=zero
4695 : 125616 : wk2d_c(1,2*i1,1,1)=wk2d_b(2,i1,1,1)
4696 : 131469 : wk2d_c(2,2*i1,1,1)=zero
4697 : : end do
4698 : : ii2=2
4699 : : else
4700 : : ii2=1
4701 : : end if
4702 [ + + ]: 97888 : do i2=ii2,g2max+1
4703 [ + + ]: 2936488 : do i1=1,n1halfm
4704 : 2838600 : wk2d_c(1,2*i1-1,i2,1)=(wk2d_b(1,i1,i2,1)+wk2d_b(1,i1,n2+ii2-i2,1))*0.5d0
4705 : 2838600 : wk2d_c(2,2*i1-1,i2,1)=(wk2d_b(2,i1,i2,1)-wk2d_b(2,i1,n2+ii2-i2,1))*0.5d0
4706 : 2838600 : wk2d_c(1,2*i1,i2,1)= ( wk2d_b(2,i1,i2,1)+wk2d_b(2,i1,n2+ii2-i2,1))*0.5d0
4707 : 2926305 : wk2d_c(2,2*i1,i2,1)= (-wk2d_b(1,i1,i2,1)+wk2d_b(1,i1,n2+ii2-i2,1))*0.5d0
4708 : : end do
4709 : : end do
4710 : :
4711 : : ! Change the phase if $k_x \neq 0$
4712 [ + + ]: 10183 : if(istwf_k==3 .or. istwf_k==5 .or. istwf_k==7 .or. istwf_k==9 )then
4713 [ + + ]: 165760 : do i1=1,n1
4714 : 161400 : phar=pha1(1,i1)
4715 : 161400 : phai=pha1(2,i1)
4716 [ + + ]: 2350660 : do i2=1,g2max+1
4717 : 2184900 : ar=wk2d_c(1,i1,i2,1)
4718 : 2184900 : ai=wk2d_c(2,i1,i2,1)
4719 : 2184900 : wk2d_c(1,i1,i2,1)= phar*ar+phai*ai
4720 : 2346300 : wk2d_c(2,i1,i2,1)=-phai*ar+phar*ai
4721 : : end do
4722 : : end do
4723 : : end if
4724 : :
4725 : : ! Perform x transform : for y=1 to g2max+1, to benefit from zeros
4726 : : call sg_fftx(fftcache,mfac,mg,2*n1halfm,n5,1,g2max+1,1,wk2d_c,wk2d_d,&
4727 : 10183 : & trig4,aft4,now4,bef4,-one,ind4,ic4)
4728 : :
4729 : : ! Copy the data from the current plane to wk1d_b
4730 [ + + ]: 2206511 : do igb=1,ngbout
4731 : 2196328 : i1=indpw_kout(1,igb) ; i2=indpw_kout(2,igb)
4732 : 2196328 : wk1d_b(1,igb,i3,1)=wk2d_d(1,i1,i2,1)
4733 : 2206511 : wk1d_b(2,igb,i3,1)=wk2d_d(2,i1,i2,1)
4734 : : end do
4735 : :
4736 : : end if ! option==2 or 3
4737 : :
4738 : : ! End loop on planes
4739 : : end do
4740 : :
4741 : : !$OMP END DO
4742 [ - + ]: 923 : ABI_FREE(wk2d_a)
4743 [ - + ]: 923 : ABI_FREE(wk2d_b)
4744 [ - + ]: 923 : ABI_FREE(wk2d_c)
4745 [ - + ]: 923 : ABI_FREE(wk2d_d)
4746 : : !$OMP END PARALLEL
4747 : :
4748 [ + + ]: 923 : if(option==2 .or. option==3)then
4749 : :
4750 : : ! Change the phase if $k_z \neq 0$
4751 [ + + ]: 426 : if(istwf_k==4 .or. istwf_k==5 .or. istwf_k==8 .or. istwf_k==9 )then
4752 : : !$OMP PARALLEL DO DEFAULT(PRIVATE) SHARED(ngbout,n3,pha3,wk1d_b)
4753 [ + + ]: 4548 : do i3=1,n3
4754 : 4345 : phar=pha3(1,i3)
4755 : 4345 : phai=pha3(2,i3)
4756 [ + + ]: 822538 : do igb=1,ngbout
4757 : 817990 : ar=wk1d_b(1,igb,i3,1)
4758 : 817990 : ai=wk1d_b(2,igb,i3,1)
4759 : 817990 : wk1d_b(1,igb,i3,1)= phar*ar+phai*ai
4760 : 822335 : wk1d_b(2,igb,i3,1)=-phai*ar+phar*ai
4761 : : end do
4762 : : end do
4763 : : !$OMP END PARALLEL DO
4764 : : end if
4765 : :
4766 : : ! Go from wk1d_b to wk1d_a, using 1D FFTs on the z direction
4767 : : ! However, due to special packing of data, use routine ffty
4768 : : !$OMP PARALLEL DO SHARED(aft6,bef6,fftcache,ind6,ic6,lotout,mgb)&
4769 : : !$OMP&SHARED(ngbout,now6,n3,trig6,wk1d_a,wk1d_b)&
4770 : : !$OMP&PRIVATE(igb,igbmax)
4771 [ - + - - : 7695 : do igb=1,ngbout,lotout
- + + + ]
4772 : 7269 : igbmax=min(igb+lotout-1,ngbout)
4773 : : ! Go from wk1d_b to wk1d_a, using 1D FFTs on the z direction
4774 : : ! However, due to special packing of data, use routine ffty
4775 : : call sg_ffty(fftcache,mfac,mg,mgb,n3,1,igb,igbmax,1,1,wk1d_b,wk1d_a, &
4776 : 7695 : & trig6,aft6,now6,bef6,-one,ind6,ic6)
4777 : :
4778 : : end do
4779 : : !$OMP END PARALLEL DO
4780 : :
4781 : : ! Transfer the data in the output array, after normalization
4782 : 426 : norm=1.d0/dble(nfftot)
4783 : : !$OMP PARALLEL DO DEFAULT(PRIVATE) SHARED(fofgout,indpw_kout,norm,npwout,wk1d_a)
4784 [ + + ]: 688937 : do ig=1,npwout
4785 : 688511 : igb=indpw_kout(4,ig) ; i3=indpw_kout(3,ig)
4786 : 688511 : fofgout(1,ig)=wk1d_a(1,igb,i3,1)*norm
4787 : 688937 : fofgout(2,ig)=wk1d_a(2,igb,i3,1)*norm
4788 : : end do
4789 : : !$OMP END PARALLEL DO
4790 : :
4791 : : end if
4792 : :
4793 [ - + ]: 923 : ABI_FREE(wk1d_a)
4794 [ - + ]: 923 : ABI_FREE(wk1d_b)
4795 : :
4796 [ + + ]: 923 : if(istwf_k/=2)then
4797 [ - + ]: 467 : ABI_FREE(pha1)
4798 [ - + ]: 467 : ABI_FREE(pha2)
4799 [ - + ]: 467 : ABI_FREE(pha3)
4800 : : end if
4801 : :
4802 : : end if ! End time-reversal symmetry
4803 : :
4804 : : !------------------------------------------------------------------
4805 : :
4806 [ + + ]: 1094206 : if(option/=3) then
4807 [ - + ]: 1094191 : ABI_FREE(indpw_kin)
4808 : : end if
4809 [ + + ]: 1094206 : if(option==2 .or. option==3) then
4810 [ - + ]: 777729 : ABI_FREE(indpw_kout)
4811 : : end if
4812 : :
4813 [ - + - + : 1094206 : end subroutine fftrisc_one_nothreadsafe
- + - + -
+ ]
4814 : : !!***
4815 : :
4816 : : !----------------------------------------------------------------------
4817 : :
4818 : : !!****f* m_sgfft/sg_fftrisc_2
4819 : : !! NAME
4820 : : !! sg_fftrisc_2
4821 : : !!
4822 : : !! FUNCTION
4823 : : !! Carry out Fourier transforms between real and reciprocal (G) space,
4824 : : !! for wavefunctions, contained in a sphere in reciprocal space,
4825 : : !! in both directions. Also accomplish some post-processing.
4826 : : !! if luse_ndo is activated, do two FFT, and compute the density with
4827 : : !! non-diagonal occupations.
4828 : : !!
4829 : : !! NOTES
4830 : : !! * Specifically uses rather sophisticated algorithms, based on S Goedecker
4831 : : !! routines, specialized for superscalar RISC architecture.
4832 : : !! Zero padding : saves 7/12 execution time
4833 : : !! Bi-dimensional data locality in most of the routine : cache reuse
4834 : : !! For k-point (0 0 0) : takes advantage of symmetry of data.
4835 : : !! Note however that no blocking is used, in both 1D z-transform
4836 : : !! or subsequent 2D transform. This should be improved.
4837 : : !!
4838 : : !! * This routine is not thread-safe due to the presence of variables with the save attribute!
4839 : : !! DO NOT CALL THIS ROUTINE INSIDE A OPENMP PARALLEL REGION
4840 : : !!
4841 : : !! INPUTS
4842 : : !! cplex= if 1 , denpot is real, if 2 , denpot is complex
4843 : : !! (cplex=2 only allowed for option=2 when istwf_k=1)
4844 : : !! one can also use cplex=0 if option=0 or option=3
4845 : : !! fofgin(2,npwin)=holds input wavefunction in G vector basis sphere.
4846 : : !! fofgin_p(2,npwin) (optional) =holds second input wavefunction in G vector basis sphere.
4847 : : !! gboundin(2*mgfft+8,2)=sphere boundary info for reciprocal to real space
4848 : : !! gboundout(2*mgfft+8,2)=sphere boundary info for real to reciprocal space
4849 : : !! istwf_k=option parameter that describes the storage of wfs
4850 : : !! kg_kin(3,npwin)=reduced planewave coordinates, input
4851 : : !! kg_kout(3,npwout)=reduced planewave coordinates, output
4852 : : !! luse_ndo (optional) = use non diagonal occup (in this case, exists fofgin_p)
4853 : : !! npwin=number of elements in fofgin array (for option 0, 1 and 2)
4854 : : !! npwout=number of elements in fofgout array (for option 2 and 3)
4855 : : !! mgfft=maximum size of 1D FFTs
4856 : : !! ngfft(18)=contain all needed information about 3D FFT, see ~abinit/doc/variables/vargs.htm#ngfft
4857 : : !! n4,n5,n6=ngfft(4),ngfft(5),ngfft(6), dimensions of fofr.
4858 : : !! option= if 0: do direct FFT
4859 : : !! if 1: do direct FFT, then sum the density
4860 : : !! if 2: do direct FFT, multiply by the potential, then do reverse FFT
4861 : : !! if 3: do reverse FFT only
4862 : : !! weight=weight to be used for the accumulation of the density in real space
4863 : : !! (needed only when option=1)
4864 : : !!
4865 : : !! OUTPUT
4866 : : !! (see side effects)
4867 : : !!
4868 : : !! OPTIONS
4869 : : !! The different options are:
4870 : : !! - reciprocal to real space and output the result (when option=0),
4871 : : !! - reciprocal to real space and accumulate the density (when option=1) or
4872 : : !! - reciprocal to real space, apply the local potential to the wavefunction
4873 : : !! in real space and produce the result in reciprocal space (when option=2)
4874 : : !! - real space to reciprocal space (when option=3).
4875 : : !! option=0 IS NOT ALLOWED when istwf_k>2
4876 : : !! option=3 IS NOT ALLOWED when istwf_k>=2
4877 : : !! (this version can be used to compute fft of two wavefunction and
4878 : : !! compute the product in denpot)
4879 : : !!
4880 : : !! SIDE EFFECTS
4881 : : !! for option==0, fofgin(2,npwin)=holds input wavefunction in G sphere;
4882 : : !! fofr(2,n4,n5,n6) contains the Fourier Transform of fofgin;
4883 : : !! no use of denpot, fofgout and npwout.
4884 : : !! for option==1, fofgin(2,npwin)=holds input wavefunction in G sphere;
4885 : : !! denpot(cplex*n4,n5,n6) contains the input density at input,
4886 : : !! and the updated density at output;
4887 : : !! fofr(2,n4,n5,n6) contains the Fourier transform of fofgin,
4888 : : !! except in the case of the hp library subroutine;
4889 : : !! no use of fofgout and npwout.
4890 : : !! for option==2, fofgin(2,npwin)=holds input wavefunction in G sphere;
4891 : : !! denpot(cplex*n4,n5,n6) contains the input local potential;
4892 : : !! fofgout(2,npwout) contains the output function;
4893 : : !! fofr(2,n4,n5,n6) contains the Fourier transform of fofgin,
4894 : : !! except in the case of the hp library subroutine.
4895 : : !! for option==3, fofr(2,n4,n5,n6) contains the real space wavefunction;
4896 : : !! fofgout(2,npwout) contains its Fourier transform;
4897 : : !! no use of fofgin and npwin.
4898 : : !!
4899 : : !! TODO
4900 : : !! Complete input and output list.
4901 : : !!
4902 : : !! SOURCE
4903 : :
4904 : 66020 : subroutine sg_fftrisc_2(cplex,denpot,fofgin,fofgout,fofr,gboundin,gboundout,&
4905 : 33010 : & istwf_k,kg_kin,kg_kout,&
4906 : : & mgfft,ngfft,npwin,npwout,n4,n5,n6,option,weight_r,weight_2,&
4907 [ + - + - : 33010 : & luse_ndo,fofgin_p) ! optional
- + ]
4908 : :
4909 : : !Arguments ------------------------------------
4910 : : !scalars
4911 : : integer,intent(in) :: cplex,istwf_k,mgfft,n4,n5,n6,npwin,npwout,option
4912 : : real(dp),intent(in) :: weight_r
4913 : : real(dp),intent(in),optional :: weight_2
4914 : : !arrays
4915 : : integer,intent(in) :: gboundin(2*mgfft+8,2),gboundout(2*mgfft+8,2)
4916 : : integer,intent(in) :: kg_kin(3,npwin),kg_kout(3,npwout),ngfft(18)
4917 : : logical,intent(in),optional :: luse_ndo
4918 : : real(dp),intent(in) :: fofgin(2,npwin)
4919 : : real(dp),intent(in),optional :: fofgin_p(:,:)
4920 : : real(dp),intent(inout) :: denpot(cplex*n4,n5,n6),fofr(2,n4,n5,n6)
4921 : : real(dp),intent(out) :: fofgout(2,npwout)
4922 : :
4923 : : !Local variables-------------------------------
4924 : : !scalars
4925 : : integer,parameter :: mfac=11
4926 : : integer,save :: ic1,ic2,ic3,ic4,ic5,ic6,n1_save=0,n2_save=0,n3_save=0
4927 : : integer :: fftcache,g2max,g2min,i1,i1max,i2,i3,i3inv,ig,igb
4928 : : integer :: igb_inv,igbmax,ii2,lot,lotin,lotout,mgb,n1
4929 : : integer :: n1half1,n1halfm,n1i,n2,n2half1,n3,n4half1,n5half1,nfftot,ngbin
4930 : : integer :: ngbout,nlot,nproc_omp
4931 : : integer :: weight_i
4932 : : real(dp) :: ai,ar,fraction,norm,phai,phar,wkim,wkre
4933 : : character(len=500) :: message
4934 : : !arrays
4935 : : integer,save :: aft1(mfac),aft2(mfac),aft3(mfac),aft4(mfac),aft5(mfac)
4936 : : integer,save :: aft6(mfac),bef1(mfac),bef2(mfac),bef3(mfac),bef4(mfac)
4937 : : integer,save :: bef5(mfac),bef6(mfac),ind1(mg),ind2(mg),ind3(mg),ind4(mg)
4938 : : integer,save :: ind5(mg),ind6(mg),now1(mfac),now2(mfac),now3(mfac),now4(mfac)
4939 : : integer,save :: now5(mfac),now6(mfac)
4940 : : integer :: gbound_dum(4)
4941 : 33010 : integer,allocatable :: indpw_kin(:,:),indpw_kout(:,:)
4942 : : logical :: lluse_ndo
4943 : : real(dp),save :: trig1(2,mg),trig2(2,mg),trig3(2,mg),trig4(2,mg),trig5(2,mg)
4944 : : real(dp),save :: trig6(2,mg)
4945 : 33010 : real(dp),allocatable :: pha1(:,:),pha2(:,:),pha3(:,:),wk1d_a(:,:,:,:)
4946 : 33010 : real(dp),allocatable :: wk1d_b(:,:,:,:),wk2d_a(:,:,:,:),wk2d_b(:,:,:,:)
4947 : 33010 : real(dp),allocatable :: wk2d_c(:,:,:,:),wk2d_d(:,:,:,:)
4948 : 33010 : real(dp),allocatable :: wk1d_a_p(:,:,:,:),wk1d_b_p(:,:,:,:)
4949 : 33010 : real(dp),allocatable :: wk2d_a_p(:,:,:,:),wk2d_b_p(:,:,:,:)
4950 : : #if defined HAVE_OPENMP
4951 : : integer,external :: OMP_GET_NUM_THREADS
4952 : : #endif
4953 : :
4954 : : ! *************************************************************************
4955 : :
4956 : : !DBG_ENTER("COLL")
4957 : :
4958 : : !DEBUG
4959 : : !write(std_out,*)' sg_fftrisc_2 : enter, istwf_k= ',istwf_k
4960 : : !write(std_out,*)' sg_fftrisc_2 : option,mgfft=',option,mgfft
4961 : : !write(std_out,*)' sg_fftrisc_2 : gboundin(3:2*mgfft+6,1)='
4962 : : !do ii=1,mgfft+2
4963 : : !write(std_out,*)gboundin(2*ii+1,1),gboundin(2*ii+2,1)
4964 : : !end do
4965 : : !stop
4966 : : !ENDDEBUG
4967 : : !
4968 : 33010 : lluse_ndo=.true.
4969 [ - + ]: 33010 : if(istwf_k/=1)then
4970 : 0 : write(message,'(a,i0)' )' It is not yet allowed to use dmft with istwf_k=',istwf_k
4971 : 0 : ABI_BUG(message)
4972 : : end if
4973 : :
4974 [ - + - - ]: 33010 : if(istwf_k>2 .and. option==0)then
4975 : 0 : write(message, '(a,i0)' )' It is not allowed to use option=0 with istwf_k=',istwf_k
4976 : 0 : ABI_BUG(message)
4977 : : end if
4978 : :
4979 [ - + - - ]: 33010 : if(istwf_k>=2 .and. option==3)then
4980 : 0 : write(message, '(a,i0)' )' It is not allowed to use option=3 with istwf_k=',istwf_k
4981 : 0 : ABI_BUG(message)
4982 : : end if
4983 : :
4984 : 33010 : lluse_ndo=.false.
4985 [ + - ]: 33010 : if(present(luse_ndo).and.present(fofgin_p)) then
4986 [ + - ]: 33010 : if(luse_ndo) lluse_ndo=.true.
4987 : : end if
4988 : : if(lluse_ndo) then
4989 [ - + ]: 33010 : if((size(fofgin_p,2)==0).and.(luse_ndo)) then
4990 : : write(message, '(a,a,a,i4,i5)' )&
4991 : 0 : & 'fofgin_p has a dimension equal to zero and luse_ndo true',ch10,&
4992 : 0 : & 'Action: check dimension of fofgin_p',size(fofgin_p,2),luse_ndo
4993 : 0 : ABI_BUG(message)
4994 : : end if
4995 : : end if
4996 : :
4997 : 33010 : weight_i= weight_r
4998 [ + - ]: 33010 : if ( present (weight_2 )) then
4999 : 33010 : weight_i= weight_2
5000 [ + - - + ]: 33010 : if ( present(luse_ndo) .and. (luse_ndo) )weight_i=weight_r
5001 : : end if
5002 : :
5003 : : !For all other tests of validity of inputs, assume that they
5004 : : !have been done in the calling routine
5005 : :
5006 : 33010 : n1=ngfft(1) ; n2=ngfft(2) ; n3=ngfft(3) ; nfftot=n1*n2*n3
5007 : 33010 : fftcache=ngfft(8)
5008 : :
5009 [ + - ]: 33010 : if(option/=3)then
5010 [ - + + - : 99030 : ABI_MALLOC(indpw_kin,(4,npwin))
+ - + - -
+ - + ]
5011 : 33010 : call indfftrisc(gboundin(3:3+2*mgfft+4,1),indpw_kin,kg_kin,mgfft,ngbin,ngfft,npwin)
5012 : : end if
5013 [ - + ]: 33010 : if(option==2 .or. option==3)then
5014 [ # # # # : 0 : ABI_MALLOC(indpw_kout,(4,npwout))
# # # # #
# # # ]
5015 : 0 : call indfftrisc(gboundout(3:3+2*mgfft+4,1),indpw_kout,kg_kout,mgfft,ngbout,ngfft,npwout)
5016 : : end if
5017 : :
5018 : : !Define the dimension of the first work arrays, for 1D transforms along z ,
5019 : : !taking into account the need to avoid the cache trashing
5020 [ - + ]: 33010 : if(option==2)then
5021 : 0 : mgb=max(ngbin,ngbout)
5022 [ + - ]: 33010 : else if(option==0 .or. option==1)then
5023 : 33010 : mgb=ngbin ; ngbout=1
5024 [ # # ]: 0 : else if(option==3)then
5025 : 0 : mgb=ngbout ; ngbin=1
5026 : : end if
5027 : :
5028 [ + + ]: 33010 : if(mod(mgb,2)/=1)mgb=mgb+1
5029 : :
5030 : : !Initialise openmp, if needed
5031 : : !$OMP PARALLEL
5032 : : !$OMP SINGLE
5033 : 33010 : nproc_omp=1
5034 : : #if defined HAVE_OPENMP
5035 : : nproc_omp=OMP_GET_NUM_THREADS()
5036 : : #endif
5037 : : !$OMP END SINGLE
5038 : : !$OMP END PARALLEL
5039 : :
5040 : : !For the treatment of the z transform,
5041 : : !one tries to use only a fraction of the cache, since the
5042 : : !treatment of the array wk1d_a will not involve contiguous segments
5043 : 33010 : fraction=0.25
5044 : : !First estimation of lot and nlot
5045 : 33010 : lot=(fftcache*fraction*1000)/(n3*8*2)+1
5046 : : !Select the smallest integer multiple of nproc_omp, larger
5047 : : !or equal to nlot. In this way, the cache size is not exhausted,
5048 : : !and one takes care correctly of the number of processors.
5049 : : !Treat separately the in and out cases
5050 : 33010 : nlot=(ngbin-1)/lot+1
5051 : 33010 : nlot=nproc_omp*((nlot-1)/nproc_omp+1)
5052 : 33010 : lotin=(ngbin-1)/nlot+1
5053 : 33010 : nlot=(ngbout-1)/lot+1
5054 : 33010 : nlot=nproc_omp*((nlot-1)/nproc_omp+1)
5055 : 33010 : lotout=(ngbout-1)/nlot+1
5056 : : !The next line impose only one lot. Usually, comment it.
5057 : : !lotin=mgb ; lotout=mgb
5058 : :
5059 : : !Compute auxiliary arrays needed for FFTs
5060 [ + + ]: 33010 : if(n1/=n1_save)then
5061 : 32 : call sg_ctrig(n1,trig1,aft1,bef1,now1,one,ic1,ind1,mfac,mg)
5062 : 32 : call sg_ctrig(n1,trig4,aft4,bef4,now4,-one,ic4,ind4,mfac,mg)
5063 : 32 : n1_save=n1
5064 : : end if
5065 [ + + ]: 33010 : if(n2/=n2_save)then
5066 : 32 : call sg_ctrig(n2,trig2,aft2,bef2,now2,one,ic2,ind2,mfac,mg)
5067 : 32 : call sg_ctrig(n2,trig5,aft5,bef5,now5,-one,ic5,ind5,mfac,mg)
5068 : 32 : n2_save=n2
5069 : : end if
5070 [ + + ]: 33010 : if(n3/=n3_save)then
5071 : 32 : call sg_ctrig(n3,trig3,aft3,bef3,now3,one,ic3,ind3,mfac,mg)
5072 : 32 : call sg_ctrig(n3,trig6,aft6,bef6,now6,-one,ic6,ind6,mfac,mg)
5073 : 32 : n3_save=n3
5074 : : end if
5075 : :
5076 : : !------------------------------------------------------------------
5077 : : !Here, call general k-point code
5078 : :
5079 [ + - ]: 33010 : if(istwf_k==1)then
5080 : :
5081 : : ! Note that the z transform will appear as a y transform
5082 [ - + + - : 132040 : ABI_MALLOC(wk1d_a,(2,mgb,n3,1))
- + + - +
- + - - +
- + ]
5083 [ - + + - : 99030 : ABI_MALLOC(wk1d_b,(2,mgb,n3,1))
- + + - -
+ - + ]
5084 [ - + + - : 99030 : ABI_MALLOC(wk1d_a_p,(2,mgb,n3,1))
- + + - -
+ - + ]
5085 [ - + + - : 99030 : ABI_MALLOC(wk1d_b_p,(2,mgb,n3,1))
- + + - -
+ - + ]
5086 : :
5087 [ + - ]: 33010 : if(option/=3)then
5088 : :
5089 [ + - ]: 33010 : if(lluse_ndo) then
5090 : : !$OMP PARALLEL DO DEFAULT(PRIVATE) &
5091 : : !$OMP&SHARED(n3,ngbin,wk1d_a_p)
5092 [ + + ]: 833045 : do i3=1,n3
5093 [ + + ]: 45056731 : do igb=1,ngbin
5094 : 44223686 : wk1d_a_p(1,igb,i3,1)=zero
5095 : 45023721 : wk1d_a_p(2,igb,i3,1)=zero
5096 : : end do
5097 : : end do
5098 : : !$OMP END PARALLEL DO
5099 : :
5100 : : ! Insert fofgin_p into the work array
5101 : : !$OMP PARALLEL DO DEFAULT(PRIVATE) &
5102 : : !$OMP&SHARED(fofgin_p,indpw_kin,npwin,wk1d_a_p)
5103 [ + + ]: 10892636 : do ig=1,npwin
5104 : 10859626 : igb=indpw_kin(4,ig) ; i3=indpw_kin(3,ig)
5105 : 10859626 : wk1d_a_p(1,igb,i3,1)=fofgin_p(1,ig)
5106 : 10892636 : wk1d_a_p(2,igb,i3,1)=fofgin_p(2,ig)
5107 : : end do
5108 : : !$OMP END PARALLEL DO
5109 : :
5110 : : ! Go from wk1d_a_p to wk1d_b_p, using 1D FFTs on the z direction
5111 : : ! However, due to special packing of data, use routine ffty
5112 : : !$OMP PARALLEL DO SHARED(aft3,bef3,fftcache,ind3,ic3,lotin,mgb)&
5113 : : !$OMP&SHARED(ngbin,now3,n3,trig3,wk1d_a_p,wk1d_b_p)&
5114 : : !$OMP&PRIVATE(igb,igbmax)
5115 [ - + - - : 221139 : do igb=1,ngbin,lotin
- + + + ]
5116 : 188129 : igbmax=min(igb+lotin-1,ngbin)
5117 : : ! Go from wk1d_a_p to wk1d_b_p, using 1D FFTs on the z direction
5118 : : ! However, due to special packing of data, use routine ffty
5119 : : call sg_ffty(fftcache,mfac,mg,mgb,n3,1,igb,igbmax,1,1,wk1d_a_p,wk1d_b_p, &
5120 : 221139 : & trig3,aft3,now3,bef3,one,ind3,ic3)
5121 : : end do
5122 : : !$OMP END PARALLEL DO
5123 : :
5124 : : end if ! lluse_ndo
5125 : :
5126 : : !$OMP PARALLEL DO DEFAULT(PRIVATE) &
5127 : : !$OMP&SHARED(n3,ngbin,wk1d_a)
5128 [ + + ]: 833045 : do i3=1,n3
5129 [ + + ]: 45056731 : do igb=1,ngbin
5130 : 44223686 : wk1d_a(1,igb,i3,1)=zero
5131 : 45023721 : wk1d_a(2,igb,i3,1)=zero
5132 : : end do
5133 : : end do
5134 : : !$OMP END PARALLEL DO
5135 : :
5136 : : ! Insert fofgin into the work array
5137 : : !$OMP PARALLEL DO DEFAULT(PRIVATE) &
5138 : : !$OMP&SHARED(fofgin,indpw_kin,npwin,wk1d_a)
5139 [ + + ]: 10892636 : do ig=1,npwin
5140 : 10859626 : igb=indpw_kin(4,ig) ; i3=indpw_kin(3,ig)
5141 : 10859626 : wk1d_a(1,igb,i3,1)=fofgin(1,ig)
5142 : 10892636 : wk1d_a(2,igb,i3,1)=fofgin(2,ig)
5143 : : end do
5144 : : !$OMP END PARALLEL DO
5145 : :
5146 : : ! Go from wk1d_a to wk1d_b, using 1D FFTs on the z direction
5147 : : ! However, due to special packing of data, use routine ffty
5148 : : !$OMP PARALLEL DO SHARED(aft3,bef3,fftcache,ind3,ic3,lotin,mgb)&
5149 : : !$OMP&SHARED(ngbin,now3,n3,trig3,wk1d_a,wk1d_b)&
5150 : : !$OMP&PRIVATE(igb,igbmax)
5151 [ - + - - : 221139 : do igb=1,ngbin,lotin
- + + + ]
5152 : 188129 : igbmax=min(igb+lotin-1,ngbin)
5153 : : ! Go from wk1d_a to wk1d_b, using 1D FFTs on the z direction
5154 : : ! However, due to special packing of data, use routine ffty
5155 : : call sg_ffty(fftcache,mfac,mg,mgb,n3,1,igb,igbmax,1,1,wk1d_a,wk1d_b, &
5156 : 221139 : & trig3,aft3,now3,bef3,one,ind3,ic3)
5157 : : end do
5158 : : !$OMP END PARALLEL DO
5159 : :
5160 : : end if ! if(option/=3)
5161 : :
5162 : : ! Do-loop on the planes stacked in the z direction
5163 : : !$OMP PARALLEL DEFAULT(PRIVATE) &
5164 : : !$OMP&SHARED(aft1,aft2,aft4,aft5,bef1,bef2,bef4,bef5,cplex,denpot) &
5165 : : !$OMP&SHARED(fftcache,fofr,gboundin,gboundout)&
5166 : : !$OMP&SHARED(ic1,ic2,ic4,ic5,ind1,ind2,ind4) &
5167 : : !$OMP&SHARED(ind5,indpw_kin,indpw_kout,lluse_ndo,mgb,n1,n2,n3,n4,n5,ngbin) &
5168 : : !$OMP&SHARED(ngbout,now1,now2,now4,now5,option,trig1,trig2,trig4,trig5) &
5169 : : !$OMP&SHARED(weight_r,weight_i,weight_2,wk1d_a,wk1d_b,wk1d_b_p)
5170 : :
5171 : : ! Allocate two 2-dimensional work arrays
5172 [ - + + - : 132040 : ABI_MALLOC(wk2d_a,(2,n4,n5,1))
- + + - +
- + - - +
- + ]
5173 [ - + + - : 99030 : ABI_MALLOC(wk2d_b,(2,n4,n5,1))
- + + - -
+ - + ]
5174 [ - + + - : 99030 : ABI_MALLOC(wk2d_a_p,(2,n4,n5,1))
- + + - -
+ - + ]
5175 [ - + + - : 99030 : ABI_MALLOC(wk2d_b_p,(2,n4,n5,1))
- + + - -
+ - + ]
5176 : : !$OMP DO
5177 [ + + ]: 833045 : do i3=1,n3
5178 : :
5179 [ + - ]: 800035 : if(option/=3)then
5180 [ + - ]: 800035 : if(lluse_ndo) then
5181 : : ! Zero the values on the current plane
5182 : : ! wk2d_a_p(1:2,1:n1,1:n2,1)=zero
5183 [ + + ]: 16291308 : do i2=1,n2
5184 [ + + ]: 327807355 : do i1=1,n1
5185 : 311516047 : wk2d_a_p(1,i1,i2,1)=zero
5186 : 327007320 : wk2d_a_p(2,i1,i2,1)=zero
5187 : : end do
5188 : : end do
5189 : : ! Copy the data in the current plane
5190 [ + + ]: 45023721 : do igb=1,ngbin
5191 : 44223686 : i1=indpw_kin(1,igb) ; i2=indpw_kin(2,igb)
5192 : 44223686 : wk2d_a_p(1,i1,i2,1)=wk1d_b_p(1,igb,i3,1)
5193 : 45023721 : wk2d_a_p(2,i1,i2,1)=wk1d_b_p(2,igb,i3,1)
5194 : : end do
5195 : : ! Perform x transform, taking into account arrays of zeros
5196 : 800035 : g2min=gboundin(3,1) ; g2max=gboundin(4,1)
5197 [ + - ]: 800035 : if ( g2min+n2 >= g2max+2 ) then
5198 [ + + ]: 9397655 : do i2=g2max+2,g2min+n2
5199 [ + + ]: 182748847 : do i1=1,n1
5200 : 173351192 : wk2d_b_p(1,i1,i2,1)=zero
5201 : 181948812 : wk2d_b_p(2,i1,i2,1)=zero
5202 : : end do
5203 : : end do
5204 : : end if
5205 : 800035 : gbound_dum(1)=1 ; gbound_dum(2)=1
5206 : 800035 : gbound_dum(3)=g2min ; gbound_dum(4)=g2max
5207 : : call sg_fftpx(fftcache,mfac,mg,0,n4,n5,1,n2,1,wk2d_a_p,wk2d_b_p,&
5208 : 800035 : & trig1,aft1,now1,bef1,one,ind1,ic1,gbound_dum)
5209 : : ! Perform y transform
5210 : 800035 : n1i=1
5211 : : call sg_ffty(fftcache,mfac,mg,n4,n5,1,n1i,n1,1,1,wk2d_b_p,wk2d_a_p, &
5212 : 800035 : & trig2,aft2,now2,bef2,one,ind2,ic2)
5213 : : ! The wave function is now in real space, for the current plane
5214 : : end if ! lluse_ndo
5215 : :
5216 : : ! Zero the values on the current plane
5217 : : ! wk2d_a(1:2,1:n1,1:n2,1)=zero
5218 [ + + ]: 16291308 : do i2=1,n2
5219 [ + + ]: 327807355 : do i1=1,n1
5220 : 311516047 : wk2d_a(1,i1,i2,1)=zero
5221 : 327007320 : wk2d_a(2,i1,i2,1)=zero
5222 : : end do
5223 : : end do
5224 : : ! Copy the data in the current plane
5225 [ + + ]: 45023721 : do igb=1,ngbin
5226 : 44223686 : i1=indpw_kin(1,igb) ; i2=indpw_kin(2,igb)
5227 : 44223686 : wk2d_a(1,i1,i2,1)=wk1d_b(1,igb,i3,1)
5228 : 45023721 : wk2d_a(2,i1,i2,1)=wk1d_b(2,igb,i3,1)
5229 : : end do
5230 : : ! Perform x transform, taking into account arrays of zeros
5231 : 800035 : g2min=gboundin(3,1) ; g2max=gboundin(4,1)
5232 [ + - ]: 800035 : if ( g2min+n2 >= g2max+2 ) then
5233 [ + + ]: 9397655 : do i2=g2max+2,g2min+n2
5234 [ + + ]: 182748847 : do i1=1,n1
5235 : 173351192 : wk2d_b(1,i1,i2,1)=zero
5236 : 181948812 : wk2d_b(2,i1,i2,1)=zero
5237 : : end do
5238 : : end do
5239 : : end if
5240 : 800035 : gbound_dum(1)=1 ; gbound_dum(2)=1
5241 : 800035 : gbound_dum(3)=g2min ; gbound_dum(4)=g2max
5242 : : call sg_fftpx(fftcache,mfac,mg,0,n4,n5,1,n2,1,wk2d_a,wk2d_b,&
5243 : 800035 : & trig1,aft1,now1,bef1,one,ind1,ic1,gbound_dum)
5244 : : ! Perform y transform
5245 : 800035 : n1i=1
5246 : : call sg_ffty(fftcache,mfac,mg,n4,n5,1,n1i,n1,1,1,wk2d_b,wk2d_a, &
5247 : 800035 : & trig2,aft2,now2,bef2,one,ind2,ic2)
5248 : : ! The wave function is now in real space, for the current plane
5249 : : end if
5250 : :
5251 [ - + ]: 800035 : if(option==0)then
5252 : : ! Copy the transformed function at the right place
5253 [ # # ]: 0 : do i2=1,n2
5254 [ # # ]: 0 : do i1=1,n1
5255 : 0 : fofr(1,i1,i2,i3)=wk2d_a(1,i1,i2,1)
5256 : 0 : fofr(2,i1,i2,i3)=wk2d_a(2,i1,i2,1)
5257 : : end do
5258 : : end do
5259 : : end if
5260 : :
5261 [ + - ]: 800035 : if(option==1)then
5262 : : ! Accumulate density
5263 [ + + ]: 16291308 : do i2=1,n2
5264 [ + + ]: 327807355 : do i1=1,n1
5265 [ + - ]: 327007320 : if(lluse_ndo) then
5266 : : denpot(i1,i2,i3)=denpot(i1,i2,i3)+&
5267 : : & weight_r*(wk2d_a(1,i1,i2,1)*wk2d_a_p(1,i1,i2,1)&
5268 : 311516047 : & +wk2d_a(2,i1,i2,1)*wk2d_a_p(2,i1,i2,1))
5269 [ + - ]: 311516047 : if(present(weight_2)) then
5270 : : denpot(i1,i2,i3)=denpot(i1,i2,i3)+&
5271 : : & weight_2*(wk2d_a_p(2,i1,i2,1)*wk2d_a(1,i1,i2,1)&
5272 : 311516047 : & -wk2d_a_p(1,i1,i2,1)*wk2d_a(2,i1,i2,1))
5273 : : end if
5274 : : else
5275 : : denpot(i1,i2,i3)=denpot(i1,i2,i3)+&
5276 : 0 : & weight_r*wk2d_a(1,i1,i2,1)**2+ weight_i*wk2d_a(2,i1,i2,1)**2
5277 : : end if
5278 : : end do
5279 : : end do
5280 : : end if
5281 : :
5282 [ - + ]: 800035 : if(option==2)then
5283 : : ! Apply local potential
5284 [ # # ]: 0 : if(cplex==1)then
5285 [ # # ]: 0 : do i2=1,n2
5286 [ # # ]: 0 : do i1=1,n1
5287 : 0 : wk2d_a(1,i1,i2,1)=denpot(i1,i2,i3)*wk2d_a(1,i1,i2,1)
5288 : 0 : wk2d_a(2,i1,i2,1)=denpot(i1,i2,i3)*wk2d_a(2,i1,i2,1)
5289 : : end do
5290 : : end do
5291 : : else
5292 [ # # ]: 0 : do i2=1,n2
5293 [ # # ]: 0 : do i1=1,n1
5294 : 0 : wkre=wk2d_a(1,i1,i2,1)
5295 : 0 : wkim=wk2d_a(2,i1,i2,1)
5296 : : wk2d_a(1,i1,i2,1)=denpot(2*i1-1,i2,i3)*wkre &
5297 : 0 : & -denpot(2*i1 ,i2,i3)*wkim
5298 : : wk2d_a(2,i1,i2,1)=denpot(2*i1-1,i2,i3)*wkim &
5299 : 0 : & +denpot(2*i1 ,i2,i3)*wkre
5300 : : end do
5301 : : end do
5302 : : end if
5303 : : end if
5304 : :
5305 [ - + ]: 800035 : if(option==3)then
5306 : : ! Copy the function to be tranformed at the right place
5307 [ # # ]: 0 : do i2=1,n2
5308 [ # # ]: 0 : do i1=1,n1
5309 : 0 : wk2d_a(1,i1,i2,1)=fofr(1,i1,i2,i3)
5310 : 0 : wk2d_a(2,i1,i2,1)=fofr(2,i1,i2,i3)
5311 : : end do
5312 : : end do
5313 : : end if
5314 : :
5315 [ - + ]: 833045 : if(option==2 .or. option==3)then
5316 : : ! Perform y transform
5317 : 0 : n1i=1
5318 : : call sg_ffty(fftcache,mfac,mg,n4,n5,1,n1i,n1,1,1,wk2d_a,wk2d_b, &
5319 : 0 : & trig5,aft5,now5,bef5,-one,ind5,ic5)
5320 : : ! Perform x transform, taking into account arrays of zeros
5321 : 0 : gbound_dum(1)=1 ; gbound_dum(2)=1
5322 : 0 : gbound_dum(3)=gboundout(3,1) ; gbound_dum(4)=gboundout(4,1)
5323 : : call sg_fftpx(fftcache,mfac,mg,0,n4,n5,1,n2,1,wk2d_b,wk2d_a,&
5324 : 0 : & trig4,aft4,now4,bef4,-one,ind4,ic4,gbound_dum)
5325 : : ! Copy the data from the current plane to wk1d_b
5326 [ # # ]: 0 : do igb=1,ngbout
5327 : 0 : i1=indpw_kout(1,igb) ; i2=indpw_kout(2,igb)
5328 : 0 : wk1d_b(1,igb,i3,1)=wk2d_a(1,i1,i2,1)
5329 : 0 : wk1d_b(2,igb,i3,1)=wk2d_a(2,i1,i2,1)
5330 : : end do
5331 : : end if
5332 : :
5333 : : ! End loop on planes
5334 : : end do
5335 : : !$OMP END DO
5336 [ - + ]: 33010 : ABI_FREE(wk2d_a)
5337 [ - + ]: 33010 : ABI_FREE(wk2d_b)
5338 [ - + ]: 33010 : ABI_FREE(wk2d_a_p)
5339 [ - + ]: 33010 : ABI_FREE(wk2d_b_p)
5340 : : !$OMP END PARALLEL
5341 : :
5342 [ - + ]: 33010 : if(option==2 .or. option==3)then
5343 : :
5344 : : ! Go from wk1d_b to wk1d_a, using 1D FFTs on the z direction
5345 : : ! However, due to special packing of data, use routine ffty
5346 : : !$OMP PARALLEL DO SHARED(aft6,bef6,fftcache,ind6,ic6,lotout,mgb)&
5347 : : !$OMP&SHARED(ngbout,now6,n3,trig6,wk1d_a,wk1d_b)&
5348 : : !$OMP&PRIVATE(igb,igbmax)
5349 [ # # # # : 0 : do igb=1,ngbout,lotout
# # # # ]
5350 : 0 : igbmax=min(igb+lotout-1,ngbout)
5351 : : ! Go from wk1d_b to wk1d_a, using 1D FFTs on the z direction
5352 : : ! However, due to special packing of data, use routine ffty
5353 : : call sg_ffty(fftcache,mfac,mg,mgb,n3,1,igb,igbmax,1,1,wk1d_b,wk1d_a, &
5354 : 0 : & trig6,aft6,now6,bef6,-one,ind6,ic6)
5355 : :
5356 : : end do
5357 : : !$OMP END PARALLEL DO
5358 : :
5359 : : ! Transfer the data in the output array, after normalization
5360 : 0 : norm=1.d0/dble(nfftot)
5361 : : !$OMP PARALLEL DO DEFAULT(PRIVATE) &
5362 : : !$OMP&SHARED(fofgout,indpw_kout,norm,npwout,wk1d_a)
5363 [ # # ]: 0 : do ig=1,npwout
5364 : 0 : igb=indpw_kout(4,ig) ; i3=indpw_kout(3,ig)
5365 : 0 : fofgout(1,ig)=wk1d_a(1,igb,i3,1)*norm
5366 : 0 : fofgout(2,ig)=wk1d_a(2,igb,i3,1)*norm
5367 : : end do
5368 : : !$OMP END PARALLEL DO
5369 : : end if
5370 : :
5371 [ - + ]: 33010 : ABI_FREE(wk1d_a)
5372 [ - + ]: 33010 : ABI_FREE(wk1d_b)
5373 [ - + ]: 33010 : ABI_FREE(wk1d_a_p)
5374 [ - + ]: 33010 : ABI_FREE(wk1d_b_p)
5375 : :
5376 : : ! End general k-point part
5377 : : end if
5378 : :
5379 : : !------------------------------------------------------------------
5380 : : !Here, use of time-reversal symmetry
5381 : :
5382 [ + - ]: 33010 : if(istwf_k>=2)then
5383 : :
5384 : 0 : n1half1=n1/2+1 ; n1halfm=(n1+1)/2
5385 : 0 : n2half1=n2/2+1
5386 : : ! n4half1 or n5half1 are the odd integers >= n1half1 or n2half1
5387 : 0 : n4half1=(n1half1/2)*2+1
5388 : 0 : n5half1=(n2half1/2)*2+1
5389 : : ! Note that the z transform will appear as a y transform
5390 [ # # # # : 0 : ABI_MALLOC(wk1d_a,(2,mgb,n3,1))
# # # # #
# # # # #
# # ]
5391 [ # # # # : 0 : ABI_MALLOC(wk1d_b,(2,mgb,n3,1))
# # # # #
# # # ]
5392 : :
5393 [ # # ]: 0 : if(istwf_k/=2)then
5394 [ # # # # : 0 : ABI_MALLOC(pha1,(2,n1))
# # # # #
# # # ]
5395 [ # # # # : 0 : ABI_MALLOC(pha2,(2,n2))
# # # # #
# # # ]
5396 [ # # # # : 0 : ABI_MALLOC(pha3,(3,n3))
# # # # #
# # # ]
5397 [ # # ]: 0 : do i1=1,n1
5398 : 0 : pha1(1,i1)=cos(dble(i1-1)*pi/dble(n1))
5399 : 0 : pha1(2,i1)=sin(dble(i1-1)*pi/dble(n1))
5400 : : end do
5401 [ # # ]: 0 : do i2=1,n2
5402 : 0 : pha2(1,i2)=cos(dble(i2-1)*pi/dble(n2))
5403 : 0 : pha2(2,i2)=sin(dble(i2-1)*pi/dble(n2))
5404 : : end do
5405 [ # # ]: 0 : do i3=1,n3
5406 : 0 : pha3(1,i3)=cos(dble(i3-1)*pi/dble(n3))
5407 : 0 : pha3(2,i3)=sin(dble(i3-1)*pi/dble(n3))
5408 : : end do
5409 : : end if
5410 : :
5411 [ # # ]: 0 : if(option/=3)then
5412 : :
5413 : : ! Zero the components of wk1d_a
5414 : : !$OMP PARALLEL DO DEFAULT(PRIVATE) &
5415 : : !$OMP&SHARED(n3,ngbin,wk1d_a)
5416 [ # # ]: 0 : do i3=1,n3
5417 [ # # ]: 0 : do igb=1,ngbin
5418 : 0 : wk1d_a(1,igb,i3,1)=zero
5419 : 0 : wk1d_a(2,igb,i3,1)=zero
5420 : : end do
5421 : : end do
5422 : : !$OMP END PARALLEL DO
5423 : :
5424 : : ! Insert fofgin into the work array
5425 : : !$OMP PARALLEL DO DEFAULT(PRIVATE) &
5426 : : !$OMP&SHARED(fofgin,indpw_kin,npwin,wk1d_a)
5427 [ # # ]: 0 : do ig=1,npwin
5428 : 0 : igb=indpw_kin(4,ig) ; i3=indpw_kin(3,ig)
5429 : 0 : wk1d_a(1,igb,i3,1)=fofgin(1,ig)
5430 : 0 : wk1d_a(2,igb,i3,1)=fofgin(2,ig)
5431 : : end do
5432 : : !$OMP END PARALLEL DO
5433 : :
5434 : : ! Must complete the i2=1 plane when $k_y \equiv 0$
5435 : :
5436 : : ! Take care of i1=1 when $k_x \equiv 0$
5437 [ # # ]: 0 : if(istwf_k==2)then
5438 : : ! Take care of i1=1
5439 [ # # ]: 0 : do i3=n3/2+1,n3
5440 : 0 : i3inv=n3+2-i3
5441 : 0 : wk1d_a(1,1,i3,1)= wk1d_a(1,1,i3inv,1)
5442 : 0 : wk1d_a(2,1,i3,1)=-wk1d_a(2,1,i3inv,1)
5443 : : end do
5444 [ # # ]: 0 : else if(istwf_k==4)then
5445 : : ! Take care of i1=1
5446 [ # # ]: 0 : do i3=n3/2+1,n3
5447 : 0 : i3inv=n3+1-i3
5448 : 0 : wk1d_a(1,1,i3,1)= wk1d_a(1,1,i3inv,1)
5449 : 0 : wk1d_a(2,1,i3,1)=-wk1d_a(2,1,i3inv,1)
5450 : : end do
5451 : : end if
5452 : :
5453 : : ! Now, take care of other i1 values, except i3==1 when $k_z \equiv 0$
5454 : 0 : i1max=gboundin(6,1)+1
5455 [ # # ]: 0 : if(istwf_k==2)then
5456 : : !$OMP PARALLEL DO DEFAULT(PRIVATE) &
5457 : : !$OMP&SHARED(i1max,n3,wk1d_a)
5458 [ # # ]: 0 : do igb=2,2*i1max-1
5459 : 0 : igb_inv=2*i1max+1-igb
5460 [ # # ]: 0 : do i3=n3/2+1,n3
5461 : 0 : i3inv=n3+2-i3
5462 : 0 : wk1d_a(1,igb,i3,1)= wk1d_a(1,igb_inv,i3inv,1)
5463 : 0 : wk1d_a(2,igb,i3,1)=-wk1d_a(2,igb_inv,i3inv,1)
5464 : : end do
5465 : : end do
5466 : : !$OMP END PARALLEL DO
5467 : :
5468 [ # # ]: 0 : else if(istwf_k==3)then
5469 : : !$OMP PARALLEL DO DEFAULT(PRIVATE) &
5470 : : !$OMP&SHARED(i1max,n3,wk1d_a)
5471 [ # # ]: 0 : do igb=1,2*i1max
5472 : 0 : igb_inv=2*i1max+1-igb
5473 [ # # ]: 0 : do i3=n3/2+1,n3
5474 : 0 : i3inv=n3+2-i3
5475 : 0 : wk1d_a(1,igb,i3,1)= wk1d_a(1,igb_inv,i3inv,1)
5476 : 0 : wk1d_a(2,igb,i3,1)=-wk1d_a(2,igb_inv,i3inv,1)
5477 : : end do
5478 : : end do
5479 : : !$OMP END PARALLEL DO
5480 : :
5481 [ # # ]: 0 : else if(istwf_k==4)then
5482 : : !$OMP PARALLEL DO DEFAULT(PRIVATE) &
5483 : : !$OMP&SHARED(i1max,n3,wk1d_a)
5484 [ # # ]: 0 : do igb=2,2*i1max-1
5485 : 0 : igb_inv=2*i1max+1-igb
5486 [ # # ]: 0 : do i3=n3/2+1,n3
5487 : 0 : i3inv=n3+1-i3
5488 : 0 : wk1d_a(1,igb,i3,1)= wk1d_a(1,igb_inv,i3inv,1)
5489 : 0 : wk1d_a(2,igb,i3,1)=-wk1d_a(2,igb_inv,i3inv,1)
5490 : : end do
5491 : : end do
5492 : : !$OMP END PARALLEL DO
5493 : :
5494 [ # # ]: 0 : else if(istwf_k==5)then
5495 : : !$OMP PARALLEL DO DEFAULT(PRIVATE) &
5496 : : !$OMP&SHARED(i1max,n3,wk1d_a)
5497 [ # # ]: 0 : do igb=1,2*i1max
5498 : 0 : igb_inv=2*i1max+1-igb
5499 [ # # ]: 0 : do i3=n3/2+1,n3
5500 : 0 : i3inv=n3+1-i3
5501 : 0 : wk1d_a(1,igb,i3,1)= wk1d_a(1,igb_inv,i3inv,1)
5502 : 0 : wk1d_a(2,igb,i3,1)=-wk1d_a(2,igb_inv,i3inv,1)
5503 : : end do
5504 : : end do
5505 : : !$OMP END PARALLEL DO
5506 : :
5507 : : end if
5508 : :
5509 : : ! Now, i3==1
5510 [ # # ]: 0 : if(istwf_k==2)then
5511 [ # # ]: 0 : do igb=2,i1max
5512 : 0 : igb_inv=2*i1max+1-igb
5513 : 0 : wk1d_a(1,igb_inv,1,1)= wk1d_a(1,igb,1,1)
5514 : 0 : wk1d_a(2,igb_inv,1,1)=-wk1d_a(2,igb,1,1)
5515 : : end do
5516 [ # # ]: 0 : else if(istwf_k==3)then
5517 [ # # ]: 0 : do igb=1,i1max
5518 : 0 : igb_inv=2*i1max+1-igb
5519 : 0 : wk1d_a(1,igb_inv,1,1)= wk1d_a(1,igb,1,1)
5520 : 0 : wk1d_a(2,igb_inv,1,1)=-wk1d_a(2,igb,1,1)
5521 : : end do
5522 : : end if
5523 : :
5524 : : ! Go from wk1d_a to wk1d_b, using 1D FFTs on the z direction
5525 : : ! However, due to special packing of data, use routine ffty
5526 : : !$OMP PARALLEL DO SHARED(aft3,bef3,fftcache,ind3,ic3,lotin,mgb)&
5527 : : !$OMP&SHARED(ngbin,now3,n3,trig3,wk1d_a,wk1d_b)&
5528 : : !$OMP&PRIVATE(igb,igbmax)
5529 [ # # # # : 0 : do igb=1,ngbin,lotin
# # # # ]
5530 : 0 : igbmax=min(igb+lotin-1,ngbin)
5531 : : ! Go from wk1d_a to wk1d_b, using 1D FFTs on the z direction
5532 : : ! However, due to special packing of data, use routine ffty
5533 : : call sg_ffty(fftcache,mfac,mg,mgb,n3,1,igb,igbmax,1,1,wk1d_a,wk1d_b, &
5534 : 0 : & trig3,aft3,now3,bef3,one,ind3,ic3)
5535 : : end do
5536 : : !$OMP END PARALLEL DO
5537 : :
5538 : : ! Change the phase if $k_z \neq 0$
5539 [ # # ]: 0 : if(istwf_k==4 .or. istwf_k==5 .or. istwf_k==8 .or. istwf_k==9 )then
5540 : : !$OMP PARALLEL DO DEFAULT(PRIVATE) &
5541 : : !$OMP&SHARED(ngbin,n3,pha3,wk1d_b)
5542 [ # # ]: 0 : do i3=1,n3
5543 : 0 : phar=pha3(1,i3)
5544 : 0 : phai=pha3(2,i3)
5545 [ # # ]: 0 : do igb=1,ngbin
5546 : 0 : ar=wk1d_b(1,igb,i3,1)
5547 : 0 : ai=wk1d_b(2,igb,i3,1)
5548 : 0 : wk1d_b(1,igb,i3,1)=phar*ar-phai*ai
5549 : 0 : wk1d_b(2,igb,i3,1)=phai*ar+phar*ai
5550 : : end do
5551 : : end do
5552 : : !$OMP END PARALLEL DO
5553 : : end if
5554 : :
5555 : : end if ! if(option/=3)
5556 : :
5557 : : ! Do-loop on the planes stacked in the z direction
5558 : :
5559 : : !$OMP PARALLEL DEFAULT(PRIVATE) &
5560 : : !$OMP&SHARED(aft1,aft2,aft4,aft5,bef1,bef2,bef4,bef5,denpot) &
5561 : : !$OMP&SHARED(fftcache,fofr,gboundin,ic1,ic2,ic4,ic5,ind1,ind2,ind4,ind5) &
5562 : : !$OMP&SHARED(indpw_kin,indpw_kout,istwf_k,mgb,n1,n1half1) &
5563 : : !$OMP&SHARED(n1halfm,n2,n2half1,n3,n4,n5,ngbin,ngbout) &
5564 : : !$OMP&SHARED(now1,now2,now4,now5,option,pha1,pha2,trig1) &
5565 : : !$OMP&SHARED(trig2,trig4,trig5,weight_r,weight_i,wk1d_a,wk1d_b)
5566 : :
5567 : : ! Allocate two 2-dimensional work arrays
5568 [ # # # # : 0 : ABI_MALLOC(wk2d_a,(2,n4,n5,1))
# # # # #
# # # # #
# # ]
5569 [ # # # # : 0 : ABI_MALLOC(wk2d_b,(2,n4,n5,1))
# # # # #
# # # ]
5570 [ # # # # : 0 : ABI_MALLOC(wk2d_c,(2,2*n1halfm,n5,1))
# # # # #
# # # # #
# # # # ]
5571 [ # # # # : 0 : ABI_MALLOC(wk2d_d,(2,2*n1halfm,n5,1))
# # # # #
# # # ]
5572 : : !$OMP DO
5573 [ # # ]: 0 : do i3=1,n3
5574 : :
5575 : 0 : g2max=gboundin(4,1)
5576 : :
5577 [ # # ]: 0 : if(option/=3)then
5578 : : ! Zero the values on the current plane : need only from i2=1 to g2max+1
5579 [ # # ]: 0 : do i2=1,g2max+1
5580 [ # # ]: 0 : do i1=1,n1
5581 : 0 : wk2d_a(1,i1,i2,1)=zero
5582 : 0 : wk2d_a(2,i1,i2,1)=zero
5583 : : end do
5584 : : end do
5585 : :
5586 : : ! Copy the data in the current plane
5587 [ # # ]: 0 : do igb=1,ngbin
5588 : 0 : i1=indpw_kin(1,igb) ; i2=indpw_kin(2,igb)
5589 : 0 : wk2d_a(1,i1,i2,1)=wk1d_b(1,igb,i3,1)
5590 : 0 : wk2d_a(2,i1,i2,1)=wk1d_b(2,igb,i3,1)
5591 : : end do
5592 : :
5593 : : ! Perform x transform, taking into account arrays of zeros
5594 : : call sg_fftx(fftcache,mfac,mg,n4,n5,1,g2max+1,1,wk2d_a,wk2d_b,&
5595 : 0 : & trig1,aft1,now1,bef1,one,ind1,ic1)
5596 : :
5597 : : ! Change the phase if $k_x \neq 0$
5598 [ # # ]: 0 : if(istwf_k==3 .or. istwf_k==5 .or. istwf_k==7 .or. istwf_k==9)then
5599 [ # # ]: 0 : do i1=1,n1
5600 : 0 : phar=pha1(1,i1)
5601 : 0 : phai=pha1(2,i1)
5602 [ # # ]: 0 : do i2=1,g2max+1
5603 : 0 : ar=wk2d_b(1,i1,i2,1)
5604 : 0 : ai=wk2d_b(2,i1,i2,1)
5605 : 0 : wk2d_b(1,i1,i2,1)=phar*ar-phai*ai
5606 : 0 : wk2d_b(2,i1,i2,1)=phai*ar+phar*ai
5607 : : end do
5608 : : end do
5609 : : end if
5610 : :
5611 : : ! Compute symmetric and antisymmetric combinations
5612 [ # # ]: 0 : if(istwf_k>=2 .and. istwf_k<=5)then
5613 [ # # ]: 0 : do i1=1,n1half1-1
5614 : 0 : wk2d_a(1,i1,1,1)=wk2d_b(1,2*i1-1,1,1)
5615 : 0 : wk2d_a(2,i1,1,1)=wk2d_b(1,2*i1 ,1,1)
5616 : : end do
5617 : : ! If n1 odd, must add last data
5618 [ # # ]: 0 : if((2*n1half1-2)/=n1)then
5619 : 0 : wk2d_a(1,n1half1,1,1)=wk2d_b(1,n1,1,1)
5620 : 0 : wk2d_a(2,n1half1,1,1)=zero
5621 : : end if
5622 : : ii2=2
5623 : : else
5624 : : ii2=1
5625 : : end if
5626 [ # # ]: 0 : if( g2max+1 >= ii2)then
5627 [ # # ]: 0 : do i2=ii2,g2max+1
5628 [ # # ]: 0 : do i1=1,n1half1-1
5629 : 0 : wk2d_a(1,i1,i2,1)= wk2d_b(1,2*i1-1,i2,1)-wk2d_b(2,2*i1,i2,1)
5630 : 0 : wk2d_a(2,i1,i2,1)= wk2d_b(2,2*i1-1,i2,1)+wk2d_b(1,2*i1,i2,1)
5631 : 0 : wk2d_a(1,i1,n2+ii2-i2,1)= wk2d_b(1,2*i1-1,i2,1)+wk2d_b(2,2*i1,i2,1)
5632 : 0 : wk2d_a(2,i1,n2+ii2-i2,1)=-wk2d_b(2,2*i1-1,i2,1)+wk2d_b(1,2*i1,i2,1)
5633 : : end do
5634 [ # # ]: 0 : if((2*n1half1-2)/=n1)then
5635 : 0 : wk2d_a(1,n1half1,i2,1)= wk2d_b(1,n1,i2,1)
5636 : 0 : wk2d_a(2,n1half1,i2,1)= wk2d_b(2,n1,i2,1)
5637 : 0 : wk2d_a(1,n1half1,n2+ii2-i2,1)= wk2d_b(1,n1,i2,1)
5638 : 0 : wk2d_a(2,n1half1,n2+ii2-i2,1)=-wk2d_b(2,n1,i2,1)
5639 : : end if
5640 : : end do
5641 : : end if
5642 [ # # ]: 0 : if ( n2half1 >= g2max+2 ) then
5643 [ # # ]: 0 : do i2=g2max+2,n2half1
5644 [ # # ]: 0 : do i1=1,n1half1-1
5645 : 0 : wk2d_a(1,i1,i2,1)=zero
5646 : 0 : wk2d_a(2,i1,i2,1)=zero
5647 : 0 : wk2d_a(1,i1,n2+ii2-i2,1)=zero
5648 : 0 : wk2d_a(2,i1,n2+ii2-i2,1)=zero
5649 : : end do
5650 [ # # ]: 0 : if((2*n1half1-2)/=n1)then
5651 : 0 : wk2d_a(1,n1half1,i2,1)=zero
5652 : 0 : wk2d_a(2,n1half1,i2,1)=zero
5653 : 0 : wk2d_a(1,n1half1,n2+ii2-i2,1)=zero
5654 : 0 : wk2d_a(2,n1half1,n2+ii2-i2,1)=zero
5655 : : end if
5656 : : end do
5657 : : end if
5658 : :
5659 : 0 : n1i=1
5660 : : call sg_ffty(fftcache,mfac,mg,n4,n5,1,n1i,n1halfm,1,1,wk2d_a,wk2d_b,&
5661 : 0 : & trig2,aft2,now2,bef2,one,ind2,ic2)
5662 : :
5663 : : ! Change the phase if $k_y \neq 0$
5664 [ # # ]: 0 : if(istwf_k>=6 .and. istwf_k<=9)then
5665 [ # # ]: 0 : do i2=1,n2
5666 : 0 : phar=pha2(1,i2)
5667 : 0 : phai=pha2(2,i2)
5668 [ # # ]: 0 : do i1=1,n1halfm
5669 : 0 : ar=wk2d_b(1,i1,i2,1)
5670 : 0 : ai=wk2d_b(2,i1,i2,1)
5671 : 0 : wk2d_b(1,i1,i2,1)= phar*ar-phai*ai
5672 : 0 : wk2d_b(2,i1,i2,1)= phai*ar+phar*ai
5673 : : end do
5674 : : end do
5675 : : end if
5676 : :
5677 : : end if ! option/=3
5678 : :
5679 : : ! The wave function is now in real space, for the current plane,
5680 : : ! represented by REAL numbers, although packed in the complex array wk2d_b
5681 : :
5682 : 0 : g2max=gboundin(4,1)
5683 : :
5684 [ # # ]: 0 : if(option==0)then
5685 : : ! This option is only permitted for istwf_k==2 (Gamma point)
5686 : : ! Copy the transformed function at the right place
5687 [ # # ]: 0 : do i2=1,n2
5688 [ # # ]: 0 : do i1=1,n1half1-1
5689 : 0 : fofr(1,2*i1-1,i2,i3)=wk2d_b(1,i1,i2,1)
5690 : 0 : fofr(1,2*i1 ,i2,i3)=wk2d_b(2,i1,i2,1)
5691 : 0 : fofr(2,2*i1-1,i2,i3)=zero
5692 : 0 : fofr(2,2*i1 ,i2,i3)=zero
5693 : : end do
5694 : : ! If n1 odd, must add last data
5695 [ # # ]: 0 : if((2*n1half1-2)/=n1)then
5696 : 0 : fofr(1,n1,i2,i3)=wk2d_b(1,n1half1,i2,1)
5697 : 0 : fofr(2,n1,i2,i3)=zero
5698 : : end if
5699 : : end do
5700 : : end if
5701 : :
5702 [ # # ]: 0 : if(option==1)then
5703 : : ! Accumulate density
5704 [ # # ]: 0 : do i2=1,n2
5705 [ # # ]: 0 : do i1=1,n1half1-1
5706 : 0 : denpot(2*i1-1,i2,i3)=denpot(2*i1-1,i2,i3)+weight_r*wk2d_b(1,i1,i2,1)**2
5707 : 0 : denpot(2*i1 ,i2,i3)=denpot(2*i1 ,i2,i3)+weight_i*wk2d_b(2,i1,i2,1)**2
5708 : : end do
5709 : : ! If n1 odd, must add last data
5710 [ # # ]: 0 : if((2*n1half1-2)/=n1)then
5711 : 0 : denpot(n1,i2,i3)=denpot(n1,i2,i3)+weight_r*wk2d_b(1,n1half1,i2,1)**2
5712 : : ! not use in DMFT because istwfk required to be one.
5713 : : end if
5714 : : end do
5715 : : end if
5716 : :
5717 [ # # ]: 0 : if(option==2)then
5718 : : ! Apply local potential
5719 [ # # ]: 0 : do i2=1,n2
5720 [ # # ]: 0 : do i1=1,n1half1-1
5721 : 0 : wk2d_a(1,i1,i2,1)=denpot(2*i1-1,i2,i3)*wk2d_b(1,i1,i2,1)
5722 : 0 : wk2d_a(2,i1,i2,1)=denpot(2*i1 ,i2,i3)*wk2d_b(2,i1,i2,1)
5723 : : end do
5724 : : ! If n1 odd, must add last data
5725 [ # # ]: 0 : if((2*n1half1-2)/=n1)then
5726 : 0 : wk2d_a(1,n1half1,i2,1)=denpot(n1,i2,i3)*wk2d_b(1,n1half1,i2,1)
5727 : 0 : wk2d_a(2,n1half1,i2,1)=zero
5728 : : end if
5729 : : end do
5730 : : end if
5731 : :
5732 [ # # ]: 0 : if(option==3)then
5733 : : ! This option is only permitted for istwf_k==2 (Gamma point)
5734 : : ! Copy the transformed function at the right place
5735 [ # # ]: 0 : do i2=1,n2
5736 [ # # ]: 0 : do i1=1,n1half1-1
5737 : 0 : wk2d_b(1,i1,i2,1)=fofr(1,2*i1-1,i2,i3)
5738 : 0 : wk2d_b(2,i1,i2,1)=fofr(1,2*i1 ,i2,i3)
5739 : : end do
5740 : : ! If n1 odd, must add last data
5741 [ # # ]: 0 : if((2*n1half1-2)/=n1)then
5742 : 0 : wk2d_b(1,n1half1,i2,1)=fofr(1,n1,i2,i3)
5743 : : end if
5744 : : end do
5745 : : end if
5746 : :
5747 [ # # ]: 0 : if(option==2 .or. option==3)then
5748 : : ! Change the phase if $k_y \neq 0$
5749 [ # # ]: 0 : if(istwf_k>=6 .and. istwf_k<=9)then
5750 [ # # ]: 0 : do i2=1,n2
5751 : 0 : phar=pha2(1,i2)
5752 : 0 : phai=pha2(2,i2)
5753 [ # # ]: 0 : do i1=1,n1halfm
5754 : 0 : ar=wk2d_a(1,i1,i2,1)
5755 : 0 : ai=wk2d_a(2,i1,i2,1)
5756 : 0 : wk2d_a(1,i1,i2,1)= phar*ar+phai*ai
5757 : 0 : wk2d_a(2,i1,i2,1)=-phai*ar+phar*ai
5758 : : end do
5759 : : end do
5760 : : end if
5761 : :
5762 : : ! Perform y transform
5763 : 0 : n1i=1
5764 : : call sg_ffty(fftcache,mfac,mg,n4,n5,1,n1i,n1halfm,1,1,wk2d_a,wk2d_b, &
5765 : 0 : & trig5,aft5,now5,bef5,-one,ind5,ic5)
5766 : :
5767 : : ! Decompose symmetric and antisymmetric parts
5768 [ # # ]: 0 : if(istwf_k>=2 .and. istwf_k<=5)then
5769 [ # # ]: 0 : do i1=1,n1halfm
5770 : 0 : wk2d_c(1,2*i1-1,1,1)=wk2d_b(1,i1,1,1)
5771 : 0 : wk2d_c(2,2*i1-1,1,1)=zero
5772 : 0 : wk2d_c(1,2*i1,1,1)=wk2d_b(2,i1,1,1)
5773 : 0 : wk2d_c(2,2*i1,1,1)=zero
5774 : : end do
5775 : : ii2=2
5776 : : else
5777 : : ii2=1
5778 : : end if
5779 [ # # ]: 0 : do i2=ii2,g2max+1
5780 [ # # ]: 0 : do i1=1,n1halfm
5781 : 0 : wk2d_c(1,2*i1-1,i2,1)=(wk2d_b(1,i1,i2,1)+wk2d_b(1,i1,n2+ii2-i2,1))*0.5d0
5782 : 0 : wk2d_c(2,2*i1-1,i2,1)=(wk2d_b(2,i1,i2,1)-wk2d_b(2,i1,n2+ii2-i2,1))*0.5d0
5783 : 0 : wk2d_c(1,2*i1,i2,1)= ( wk2d_b(2,i1,i2,1)+wk2d_b(2,i1,n2+ii2-i2,1))*0.5d0
5784 : 0 : wk2d_c(2,2*i1,i2,1)= (-wk2d_b(1,i1,i2,1)+wk2d_b(1,i1,n2+ii2-i2,1))*0.5d0
5785 : : end do
5786 : : end do
5787 : :
5788 : : ! Change the phase if $k_x \neq 0$
5789 [ # # ]: 0 : if(istwf_k==3 .or. istwf_k==5 .or. istwf_k==7 .or. istwf_k==9 )then
5790 [ # # ]: 0 : do i1=1,n1
5791 : 0 : phar=pha1(1,i1)
5792 : 0 : phai=pha1(2,i1)
5793 [ # # ]: 0 : do i2=1,g2max+1
5794 : 0 : ar=wk2d_c(1,i1,i2,1)
5795 : 0 : ai=wk2d_c(2,i1,i2,1)
5796 : 0 : wk2d_c(1,i1,i2,1)= phar*ar+phai*ai
5797 : 0 : wk2d_c(2,i1,i2,1)=-phai*ar+phar*ai
5798 : : end do
5799 : : end do
5800 : : end if
5801 : :
5802 : : ! Perform x transform : for y=1 to g2max+1, to benefit from zeros
5803 : : call sg_fftx(fftcache,mfac,mg,2*n1halfm,n5,1,g2max+1,1,wk2d_c,wk2d_d,&
5804 : 0 : & trig4,aft4,now4,bef4,-one,ind4,ic4)
5805 : :
5806 : : ! Copy the data from the current plane to wk1d_b
5807 [ # # ]: 0 : do igb=1,ngbout
5808 : 0 : i1=indpw_kout(1,igb) ; i2=indpw_kout(2,igb)
5809 : 0 : wk1d_b(1,igb,i3,1)=wk2d_d(1,i1,i2,1)
5810 : 0 : wk1d_b(2,igb,i3,1)=wk2d_d(2,i1,i2,1)
5811 : : end do
5812 : :
5813 : : end if ! option==2 or 3
5814 : :
5815 : : ! End loop on planes
5816 : : end do
5817 : :
5818 : : !$OMP END DO
5819 [ # # ]: 0 : ABI_FREE(wk2d_a)
5820 [ # # ]: 0 : ABI_FREE(wk2d_b)
5821 [ # # ]: 0 : ABI_FREE(wk2d_c)
5822 [ # # ]: 0 : ABI_FREE(wk2d_d)
5823 : : !$OMP END PARALLEL
5824 : :
5825 [ # # ]: 0 : if(option==2 .or. option==3)then
5826 : :
5827 : : ! Change the phase if $k_z \neq 0$
5828 [ # # ]: 0 : if(istwf_k==4 .or. istwf_k==5 .or. istwf_k==8 .or. istwf_k==9 )then
5829 : : !$OMP PARALLEL DO DEFAULT(PRIVATE) &
5830 : : !$OMP&SHARED(ngbout,n3,pha3,wk1d_b)
5831 [ # # ]: 0 : do i3=1,n3
5832 : 0 : phar=pha3(1,i3)
5833 : 0 : phai=pha3(2,i3)
5834 [ # # ]: 0 : do igb=1,ngbout
5835 : 0 : ar=wk1d_b(1,igb,i3,1)
5836 : 0 : ai=wk1d_b(2,igb,i3,1)
5837 : 0 : wk1d_b(1,igb,i3,1)= phar*ar+phai*ai
5838 : 0 : wk1d_b(2,igb,i3,1)=-phai*ar+phar*ai
5839 : : end do
5840 : : end do
5841 : : !$OMP END PARALLEL DO
5842 : : end if
5843 : :
5844 : : ! Go from wk1d_b to wk1d_a, using 1D FFTs on the z direction
5845 : : ! However, due to special packing of data, use routine ffty
5846 : : !$OMP PARALLEL DO SHARED(aft6,bef6,fftcache,ind6,ic6,lotout,mgb)&
5847 : : !$OMP&SHARED(ngbout,now6,n3,trig6,wk1d_a,wk1d_b)&
5848 : : !$OMP&PRIVATE(igb,igbmax)
5849 [ # # # # : 0 : do igb=1,ngbout,lotout
# # # # ]
5850 : 0 : igbmax=min(igb+lotout-1,ngbout)
5851 : : ! Go from wk1d_b to wk1d_a, using 1D FFTs on the z direction
5852 : : ! However, due to special packing of data, use routine ffty
5853 : : call sg_ffty(fftcache,mfac,mg,mgb,n3,1,igb,igbmax,1,1,wk1d_b,wk1d_a, &
5854 : 0 : & trig6,aft6,now6,bef6,-one,ind6,ic6)
5855 : :
5856 : : end do
5857 : : !$OMP END PARALLEL DO
5858 : :
5859 : : ! Transfer the data in the output array, after normalization
5860 : 0 : norm=1.d0/dble(nfftot)
5861 : : !$OMP PARALLEL DO DEFAULT(PRIVATE) &
5862 : : !$OMP&SHARED(fofgout,indpw_kout,norm,npwout,wk1d_a)
5863 [ # # ]: 0 : do ig=1,npwout
5864 : 0 : igb=indpw_kout(4,ig) ; i3=indpw_kout(3,ig)
5865 : 0 : fofgout(1,ig)=wk1d_a(1,igb,i3,1)*norm
5866 : 0 : fofgout(2,ig)=wk1d_a(2,igb,i3,1)*norm
5867 : : end do
5868 : : !$OMP END PARALLEL DO
5869 : :
5870 : : end if
5871 : :
5872 [ # # ]: 0 : ABI_FREE(wk1d_a)
5873 [ # # ]: 0 : ABI_FREE(wk1d_b)
5874 : :
5875 [ # # ]: 0 : if(istwf_k/=2)then
5876 [ # # ]: 0 : ABI_FREE(pha1)
5877 [ # # ]: 0 : ABI_FREE(pha2)
5878 [ # # ]: 0 : ABI_FREE(pha3)
5879 : : end if
5880 : :
5881 : : ! End time-reversal symmetry
5882 : : end if
5883 : :
5884 [ + - ]: 33010 : if(option/=3) then
5885 [ - + ]: 33010 : ABI_FREE(indpw_kin)
5886 : : end if
5887 [ - + ]: 33010 : if(option==2 .or. option==3) then
5888 [ # # ]: 0 : ABI_FREE(indpw_kout)
5889 : : end if
5890 : :
5891 : : !DBG_EXIT("COLL")
5892 : :
5893 [ - + - + : 33010 : end subroutine sg_fftrisc_2
- + - + -
+ ]
5894 : : !!***
5895 : :
5896 : : !----------------------------------------------------------------------
5897 : :
5898 : : !!****f* m_sgfft/sg_poisson
5899 : : !! NAME
5900 : : !! sg_poisson
5901 : : !!
5902 : : !! FUNCTION
5903 : : !! Solve the Poisson equation in G-space given the density, n(r),
5904 : : !! in real space of the FFT box.
5905 : : !!
5906 : : !! INPUTS
5907 : : !! fftcache=size of the cache (kB)
5908 : : !! cplex=1 if fofr is real, 2 if fofr is complex
5909 : : !! nx,ny,nz=Number of FFT points along the three directions.
5910 : : !! ldx,ldy,ldz=Leading dimension of the array nr and vg.
5911 : : !! ndat = Number of densities
5912 : : !! vg(nx*ny*nz)=Potential in reciprocal space.
5913 : : !!
5914 : : !! SIDE EFFECTS
5915 : : !! nr(cplex*ldx*ldy*ldz*ndat)
5916 : : !! input: n(r) (real or complex)
5917 : : !! output: the hartree potential in real space
5918 : : !!
5919 : : !! NOTES
5920 : : !! vg is given on the FFT mesh instead of the augmented mesh [ldx,ldy,ldz]
5921 : : !! in order to simplify the interface with the other routines operating of vg
5922 : : !!
5923 : : !! SOURCE
5924 : :
5925 : 0 : subroutine sg_poisson(fftcache,cplex,nx,ny,nz,ldx,ldy,ldz,ndat,vg,nr)
5926 : :
5927 : : !Arguments ------------------------------------
5928 : : !scalars
5929 : : integer,intent(in) :: fftcache,cplex,nx,ny,nz,ldx,ldy,ldz,ndat
5930 : : !arrays
5931 : : real(dp),intent(inout) :: nr(cplex*ldx*ldy*ldz*ndat)
5932 : : real(dp),intent(in) :: vg(nx*ny*nz)
5933 : :
5934 : : !Local variables-------------------------------
5935 : : integer,parameter :: ndat1=1
5936 : : integer :: ii,jj,kk,ifft,dat,ptr,ig
5937 : : real(dp) :: fft_fact
5938 : : !arrays
5939 : 0 : real(dp),allocatable :: work(:,:)
5940 : :
5941 : : ! *************************************************************************
5942 : :
5943 : 0 : fft_fact = one/(nx*ny*nz)
5944 : :
5945 [ # # ]: 0 : ABI_CHECK(cplex==2,"cplex!=2 not coded")
5946 : :
5947 [ # # # # : 0 : ABI_MALLOC(work, (2,ldx*ldy*ldz))
# # # # #
# # # ]
5948 : :
5949 [ # # ]: 0 : do dat=1,ndat
5950 : : ! n(r) --> n(G)
5951 : 0 : ptr = 1 + (dat-1)*cplex*ldx*ldy*ldz
5952 : 0 : call sg_fft_cc(fftcache,nx,ny,nz,ldx,ldy,ldz,ndat1,-1,nr(ptr),work)
5953 : :
5954 : : ! Multiply by v(G)
5955 : 0 : ig = 0
5956 [ # # ]: 0 : do kk=1,nz
5957 [ # # ]: 0 : do jj=1,ny
5958 [ # # ]: 0 : do ii=1,nx
5959 : 0 : ig = ig + 1
5960 : 0 : ifft = ii + (jj-1)*ldx + (kk-1)*ldx*ldy
5961 [ # # ]: 0 : work(1:2,ifft) = work(1:2,ifft) * vg(ig) * fft_fact
5962 : : end do
5963 : : end do
5964 : : end do
5965 : :
5966 : : ! compute vh(r)
5967 : 0 : call sg_fft_cc(fftcache,nx,ny,nz,ldx,ldy,ldz,ndat1,+1,work,nr(ptr))
5968 : : end do
5969 : :
5970 [ # # ]: 0 : ABI_FREE(work)
5971 : :
5972 : 0 : end subroutine sg_poisson
5973 : : !!***
5974 : :
5975 : : END MODULE m_sgfft
|
