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
|
