source: palm/trunk/SOURCE/fft_xy_mod.f90 @ 4182

Last change on this file since 4182 was 4182, checked in by scharf, 5 years ago
  • corrected "Former revisions" section
  • minor formatting in "Former revisions" section
  • added "Author" section
  • Property svn:keywords set to Id
File size: 52.5 KB
Line 
1!> @file fft_xy_mod.f90
2!------------------------------------------------------------------------------!
3! This file is part of the PALM model system.
4!
5! PALM is free software: you can redistribute it and/or modify it under the
6! terms of the GNU General Public License as published by the Free Software
7! Foundation, either version 3 of the License, or (at your option) any later
8! version.
9!
10! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
11! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
12! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
13!
14! You should have received a copy of the GNU General Public License along with
15! PALM. If not, see <http://www.gnu.org/licenses/>.
16!
17! Copyright 1997-2019 Leibniz Universitaet Hannover
18!------------------------------------------------------------------------------!
19!
20! Current revisions:
21! -----------------
22!
23!
24! Former revisions:
25! -----------------
26! $Id: fft_xy_mod.f90 4182 2019-08-22 15:20:23Z scharf $
27! Corrected "Former revisions" section
28!
29! 4069 2019-07-01 14:05:51Z Giersch
30! Code added to avoid compiler warnings
31!
32! 3655 2019-01-07 16:51:22Z knoop
33! OpenACC port for SPEC
34!
35! Revision 1.1  2002/06/11 13:00:49  raasch
36! Initial revision
37!
38!
39! Description:
40! ------------
41!> Fast Fourier transformation along x and y for 1d domain decomposition along x.
42!> Original version: Klaus Ketelsen (May 2002)
43!------------------------------------------------------------------------------!
44 MODULE fft_xy
45 
46
47    USE control_parameters,                                                    &
48        ONLY:  fft_method, message_string
49       
50    USE cuda_fft_interfaces
51       
52    USE indices,                                                               &
53        ONLY:  nx, ny, nz
54       
55#if defined( __cuda_fft )
56    USE ISO_C_BINDING
57#elif defined( __fftw )
58    USE, INTRINSIC ::  ISO_C_BINDING
59#endif
60
61    USE kinds
62   
63    USE singleton,                                                             &
64        ONLY: fftn
65   
66    USE temperton_fft
67   
68    USE transpose_indices,                                                     &
69        ONLY:  nxl_y, nxr_y, nyn_x, nys_x, nzb_x, nzb_y, nzt_x, nzt_y
70
71    IMPLICIT NONE
72
73    PRIVATE
74    PUBLIC fft_x, fft_x_1d, fft_y, fft_y_1d, fft_init, fft_x_m, fft_y_m
75
76    INTEGER(iwp), DIMENSION(:), ALLOCATABLE, SAVE ::  ifax_x  !<
77    INTEGER(iwp), DIMENSION(:), ALLOCATABLE, SAVE ::  ifax_y  !<
78
79    LOGICAL, SAVE ::  init_fft = .FALSE.  !<
80
81    REAL(wp), SAVE ::  dnx      !<
82    REAL(wp), SAVE ::  dny      !<
83    REAL(wp), SAVE ::  sqr_dnx  !<
84    REAL(wp), SAVE ::  sqr_dny  !<
85   
86    REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE ::  trigs_x  !<
87    REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE ::  trigs_y  !<
88
89#if defined( __ibm )
90    INTEGER(iwp), PARAMETER ::  nau1 = 20000  !<
91    INTEGER(iwp), PARAMETER ::  nau2 = 22000  !<
92!
93!-- The following working arrays contain tables and have to be "save" and
94!-- shared in OpenMP sense
95    REAL(wp), DIMENSION(nau1), SAVE ::  aux1  !<
96    REAL(wp), DIMENSION(nau1), SAVE ::  auy1  !<
97    REAL(wp), DIMENSION(nau1), SAVE ::  aux3  !<
98    REAL(wp), DIMENSION(nau1), SAVE ::  auy3  !<
99   
100#elif defined( __nec )
101    INTEGER(iwp), SAVE ::  nz1  !<
102   
103    REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE ::  trig_xb  !<
104    REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE ::  trig_xf  !<
105    REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE ::  trig_yb  !<
106    REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE ::  trig_yf  !<
107   
108#elif defined( __cuda_fft )
109    INTEGER(C_INT), SAVE ::  plan_xf  !<
110    INTEGER(C_INT), SAVE ::  plan_xi  !<
111    INTEGER(C_INT), SAVE ::  plan_yf  !<
112    INTEGER(C_INT), SAVE ::  plan_yi  !<
113
114#endif
115
116#if defined( __fftw )
117    INCLUDE  'fftw3.f03'
118    INTEGER(KIND=C_INT) ::  nx_c  !<
119    INTEGER(KIND=C_INT) ::  ny_c  !<
120   
121    COMPLEX(KIND=C_DOUBLE_COMPLEX), DIMENSION(:), ALLOCATABLE, SAVE ::  x_out  !<
122    COMPLEX(KIND=C_DOUBLE_COMPLEX), DIMENSION(:), ALLOCATABLE, SAVE ::         &
123       y_out  !<
124   
125    REAL(KIND=C_DOUBLE), DIMENSION(:), ALLOCATABLE, SAVE ::                    &
126       x_in   !<
127    REAL(KIND=C_DOUBLE), DIMENSION(:), ALLOCATABLE, SAVE ::                    &
128       y_in   !<
129    !$OMP THREADPRIVATE( x_out, y_out, x_in, y_in )
130   
131   
132    TYPE(C_PTR), SAVE ::  plan_xf, plan_xi, plan_yf, plan_yi
133#endif
134
135!
136!-- Public interfaces
137    INTERFACE fft_init
138       MODULE PROCEDURE fft_init
139    END INTERFACE fft_init
140
141    INTERFACE fft_x
142       MODULE PROCEDURE fft_x
143    END INTERFACE fft_x
144
145    INTERFACE fft_x_1d
146       MODULE PROCEDURE fft_x_1d
147    END INTERFACE fft_x_1d
148
149    INTERFACE fft_y
150       MODULE PROCEDURE fft_y
151    END INTERFACE fft_y
152
153    INTERFACE fft_y_1d
154       MODULE PROCEDURE fft_y_1d
155    END INTERFACE fft_y_1d
156
157    INTERFACE fft_x_m
158       MODULE PROCEDURE fft_x_m
159    END INTERFACE fft_x_m
160
161    INTERFACE fft_y_m
162       MODULE PROCEDURE fft_y_m
163    END INTERFACE fft_y_m
164
165 CONTAINS
166
167
168!------------------------------------------------------------------------------!
169! Description:
170! ------------
171!> @todo Missing subroutine description.
172!------------------------------------------------------------------------------!
173    SUBROUTINE fft_init
174
175       IMPLICIT NONE
176
177!
178!--    The following temporary working arrays have to be on stack or private
179!--    in OpenMP sense
180#if defined( __ibm )
181       REAL(wp), DIMENSION(0:nx+2) ::  workx  !<
182       REAL(wp), DIMENSION(0:ny+2) ::  worky  !<
183       REAL(wp), DIMENSION(nau2)   ::  aux2   !<
184       REAL(wp), DIMENSION(nau2)   ::  auy2   !<
185       REAL(wp), DIMENSION(nau2)   ::  aux4   !<
186       REAL(wp), DIMENSION(nau2)   ::  auy4   !<
187#elif defined( __nec )
188       REAL(wp), DIMENSION(0:nx+3,nz+1)   ::  work_x  !<
189       REAL(wp), DIMENSION(0:ny+3,nz+1)   ::  work_y  !<
190       REAL(wp), DIMENSION(6*(nx+3),nz+1) ::  workx   !<
191       REAL(wp), DIMENSION(6*(ny+3),nz+1) ::  worky   !<
192#endif 
193
194!
195!--    Return, if already called
196       IF ( init_fft )  THEN
197          RETURN
198       ELSE
199          init_fft = .TRUE.
200       ENDIF
201
202#if defined( _OPENACC ) && defined( __cuda_fft )
203       fft_method = 'system-specific'
204#endif
205
206       IF ( fft_method == 'system-specific' )  THEN
207
208          dnx = 1.0_wp / ( nx + 1.0_wp )
209          dny = 1.0_wp / ( ny + 1.0_wp )
210          sqr_dnx = SQRT( dnx )
211          sqr_dny = SQRT( dny )
212#if defined( __ibm )
213!
214!--       Initialize tables for fft along x
215          CALL DRCFT( 1, workx, 1, workx, 1, nx+1, 1,  1, sqr_dnx, aux1, nau1, &
216                      aux2, nau2 )
217          CALL DCRFT( 1, workx, 1, workx, 1, nx+1, 1, -1, sqr_dnx, aux3, nau1, &
218                      aux4, nau2 )
219!
220!--       Initialize tables for fft along y
221          CALL DRCFT( 1, worky, 1, worky, 1, ny+1, 1,  1, sqr_dny, auy1, nau1, &
222                      auy2, nau2 )
223          CALL DCRFT( 1, worky, 1, worky, 1, ny+1, 1, -1, sqr_dny, auy3, nau1, &
224                      auy4, nau2 )
225#elif defined( __nec )
226          message_string = 'fft method "' // TRIM( fft_method) // &
227                           '" currently does not work on NEC'
228          CALL message( 'fft_init', 'PA0187', 1, 2, 0, 6, 0 )
229
230          ALLOCATE( trig_xb(2*(nx+1)), trig_xf(2*(nx+1)),                      &
231                    trig_yb(2*(ny+1)), trig_yf(2*(ny+1)) )
232
233          work_x = 0.0_wp
234          work_y = 0.0_wp
235          nz1  = nz + MOD( nz+1, 2 )  ! odd nz slows down fft significantly
236                                      ! when using the NEC ffts
237
238!
239!--       Initialize tables for fft along x (non-vector and vector case (M))
240          CALL DZFFT( 0, nx+1, sqr_dnx, work_x, work_x, trig_xf, workx, 0 )
241          CALL ZDFFT( 0, nx+1, sqr_dnx, work_x, work_x, trig_xb, workx, 0 )
242          CALL DZFFTM( 0, nx+1, nz1, sqr_dnx, work_x, nx+4, work_x, nx+4,      &
243                       trig_xf, workx, 0 )
244          CALL ZDFFTM( 0, nx+1, nz1, sqr_dnx, work_x, nx+4, work_x, nx+4,      &
245                       trig_xb, workx, 0 )
246!
247!--       Initialize tables for fft along y (non-vector and vector case (M))
248          CALL DZFFT( 0, ny+1, sqr_dny, work_y, work_y, trig_yf, worky, 0 )
249          CALL ZDFFT( 0, ny+1, sqr_dny, work_y, work_y, trig_yb, worky, 0 )
250          CALL DZFFTM( 0, ny+1, nz1, sqr_dny, work_y, ny+4, work_y, ny+4,      &
251                       trig_yf, worky, 0 )
252          CALL ZDFFTM( 0, ny+1, nz1, sqr_dny, work_y, ny+4, work_y, ny+4,      &
253                       trig_yb, worky, 0 )
254#elif defined( __cuda_fft )
255          CALL CUFFTPLAN1D( plan_xf, nx+1, CUFFT_D2Z, (nyn_x-nys_x+1) * (nzt_x-nzb_x+1) )
256          CALL CUFFTPLAN1D( plan_xi, nx+1, CUFFT_Z2D, (nyn_x-nys_x+1) * (nzt_x-nzb_x+1) )
257          CALL CUFFTPLAN1D( plan_yf, ny+1, CUFFT_D2Z, (nxr_y-nxl_y+1) * (nzt_y-nzb_y+1) )
258          CALL CUFFTPLAN1D( plan_yi, ny+1, CUFFT_Z2D, (nxr_y-nxl_y+1) * (nzt_y-nzb_y+1) )
259#else
260          message_string = 'no system-specific fft-call available'
261          CALL message( 'fft_init', 'PA0188', 1, 2, 0, 6, 0 )
262#endif
263       ELSEIF ( fft_method == 'temperton-algorithm' )  THEN
264!
265!--       Temperton-algorithm
266!--       Initialize tables for fft along x and y
267          ALLOCATE( ifax_x(nx+1), ifax_y(ny+1), trigs_x(nx+1), trigs_y(ny+1) )
268
269          CALL set99( trigs_x, ifax_x, nx+1 )
270          CALL set99( trigs_y, ifax_y, ny+1 )
271
272       ELSEIF ( fft_method == 'fftw' )  THEN
273!
274!--       FFTW
275#if defined( __fftw )
276          nx_c = nx+1
277          ny_c = ny+1
278          !$OMP PARALLEL
279          ALLOCATE( x_in(0:nx+2), y_in(0:ny+2), x_out(0:(nx+1)/2),             &
280                    y_out(0:(ny+1)/2) )
281          !$OMP END PARALLEL
282          plan_xf = FFTW_PLAN_DFT_R2C_1D( nx_c, x_in, x_out, FFTW_ESTIMATE )
283          plan_xi = FFTW_PLAN_DFT_C2R_1D( nx_c, x_out, x_in, FFTW_ESTIMATE )
284          plan_yf = FFTW_PLAN_DFT_R2C_1D( ny_c, y_in, y_out, FFTW_ESTIMATE )
285          plan_yi = FFTW_PLAN_DFT_C2R_1D( ny_c, y_out, y_in, FFTW_ESTIMATE )
286#else
287          message_string = 'preprocessor switch for fftw is missing'
288          CALL message( 'fft_init', 'PA0080', 1, 2, 0, 6, 0 )
289#endif
290
291       ELSEIF ( fft_method == 'singleton-algorithm' )  THEN
292
293          CONTINUE
294
295       ELSE
296
297          message_string = 'fft method "' // TRIM( fft_method) // &
298                           '" not available'
299          CALL message( 'fft_init', 'PA0189', 1, 2, 0, 6, 0 )
300       ENDIF
301
302    END SUBROUTINE fft_init
303
304
305!------------------------------------------------------------------------------!
306! Description:
307! ------------
308!> Fourier-transformation along x-direction.                 
309!> Version for 2D-decomposition.
310!> It uses internal algorithms (Singleton or Temperton) or     
311!> system-specific routines, if they are available           
312!------------------------------------------------------------------------------!
313 
314    SUBROUTINE fft_x( ar, direction, ar_2d )
315
316
317       IMPLICIT NONE
318
319       CHARACTER (LEN=*) ::  direction  !<
320       
321       COMPLEX(wp), DIMENSION(:), ALLOCATABLE ::  cwork  !<
322
323       INTEGER(iwp) ::  i          !<
324       INTEGER(iwp) ::  ishape(1)  !<
325       INTEGER(iwp) ::  j          !<
326       INTEGER(iwp) ::  k          !<
327
328       LOGICAL ::  forward_fft !<
329       
330       REAL(wp), DIMENSION(0:nx+2) ::  work   !<
331       REAL(wp), DIMENSION(nx+2)   ::  work1  !<
332       
333#if defined( __ibm )
334       REAL(wp), DIMENSION(nau2) ::  aux2  !<
335       REAL(wp), DIMENSION(nau2) ::  aux4  !<
336#elif defined( __nec )
337       REAL(wp), DIMENSION(6*(nx+1)) ::  work2  !<
338#elif defined( __cuda_fft )
339       COMPLEX(dp), DIMENSION(0:(nx+1)/2,nys_x:nyn_x,nzb_x:nzt_x) ::           &
340          ar_tmp  !<
341       !$ACC DECLARE CREATE(ar_tmp)
342#endif
343
344       REAL(wp), DIMENSION(0:nx,nys_x:nyn_x), OPTIONAL   ::                    &
345          ar_2d   !<
346       REAL(wp), DIMENSION(0:nx,nys_x:nyn_x,nzb_x:nzt_x) ::                    &
347          ar      !<
348
349!
350!--    To avoid compiler warning: Unused dummy argument ‘ar_2d’
351       IF ( PRESENT( ar_2d ) )  CONTINUE
352
353       IF ( direction == 'forward' )  THEN
354          forward_fft = .TRUE.
355       ELSE
356          forward_fft = .FALSE.
357       ENDIF
358
359       IF ( fft_method == 'singleton-algorithm' )  THEN
360
361!
362!--       Performing the fft with singleton's software works on every system,
363!--       since it is part of the model
364          ALLOCATE( cwork(0:nx) )
365     
366          IF ( forward_fft )   then
367
368             !$OMP PARALLEL PRIVATE ( cwork, i, ishape, j, k )
369             !$OMP DO
370             DO  k = nzb_x, nzt_x
371                DO  j = nys_x, nyn_x
372
373                   DO  i = 0, nx
374                      cwork(i) = CMPLX( ar(i,j,k), KIND=wp )
375                   ENDDO
376
377                   ishape = SHAPE( cwork )
378                   CALL FFTN( cwork, ishape )
379
380                   DO  i = 0, (nx+1)/2
381                      ar(i,j,k) = REAL( cwork(i), KIND=wp )
382                   ENDDO
383                   DO  i = 1, (nx+1)/2 - 1
384                      ar(nx+1-i,j,k) = -AIMAG( cwork(i) )
385                   ENDDO
386
387                ENDDO
388             ENDDO
389             !$OMP END PARALLEL
390
391          ELSE
392
393             !$OMP PARALLEL PRIVATE ( cwork, i, ishape, j, k )
394             !$OMP DO
395             DO  k = nzb_x, nzt_x
396                DO  j = nys_x, nyn_x
397
398                   cwork(0) = CMPLX( ar(0,j,k), 0.0_wp, KIND=wp )
399                   DO  i = 1, (nx+1)/2 - 1
400                      cwork(i)      = CMPLX( ar(i,j,k), -ar(nx+1-i,j,k),       &
401                                             KIND=wp )
402                      cwork(nx+1-i) = CMPLX( ar(i,j,k),  ar(nx+1-i,j,k),       &
403                                             KIND=wp )
404                   ENDDO
405                   cwork((nx+1)/2) = CMPLX( ar((nx+1)/2,j,k), 0.0_wp, KIND=wp )
406
407                   ishape = SHAPE( cwork )
408                   CALL FFTN( cwork, ishape, inv = .TRUE. )
409
410                   DO  i = 0, nx
411                      ar(i,j,k) = REAL( cwork(i), KIND=wp )
412                   ENDDO
413
414                ENDDO
415             ENDDO
416             !$OMP END PARALLEL
417
418          ENDIF
419
420          DEALLOCATE( cwork )
421
422       ELSEIF ( fft_method == 'temperton-algorithm' )  THEN
423
424!
425!--       Performing the fft with Temperton's software works on every system,
426!--       since it is part of the model
427          IF ( forward_fft )  THEN
428
429             !$OMP PARALLEL PRIVATE ( work, work1, i, j, k )
430             !$OMP DO
431             DO  k = nzb_x, nzt_x
432                DO  j = nys_x, nyn_x
433
434                   work(0:nx) = ar(0:nx,j,k)
435                   CALL fft991cy( work, work1, trigs_x, ifax_x, 1, nx+1, nx+1, 1, -1 )
436
437                   DO  i = 0, (nx+1)/2
438                      ar(i,j,k) = work(2*i)
439                   ENDDO
440                   DO  i = 1, (nx+1)/2 - 1
441                      ar(nx+1-i,j,k) = work(2*i+1)
442                   ENDDO
443
444                ENDDO
445             ENDDO
446             !$OMP END PARALLEL
447
448          ELSE
449
450             !$OMP PARALLEL PRIVATE ( work, work1, i, j, k )
451             !$OMP DO
452             DO  k = nzb_x, nzt_x
453                DO  j = nys_x, nyn_x
454
455                   DO  i = 0, (nx+1)/2
456                      work(2*i) = ar(i,j,k)
457                   ENDDO
458                   DO  i = 1, (nx+1)/2 - 1
459                      work(2*i+1) = ar(nx+1-i,j,k)
460                   ENDDO
461                   work(1)    = 0.0_wp
462                   work(nx+2) = 0.0_wp
463
464                   CALL fft991cy( work, work1, trigs_x, ifax_x, 1, nx+1, nx+1, 1, 1 )
465                   ar(0:nx,j,k) = work(0:nx)
466
467                ENDDO
468             ENDDO
469             !$OMP END PARALLEL
470
471          ENDIF
472
473       ELSEIF ( fft_method == 'fftw' )  THEN
474
475#if defined( __fftw )
476          IF ( forward_fft )  THEN
477
478             !$OMP PARALLEL PRIVATE ( work, i, j, k )
479             !$OMP DO
480             DO  k = nzb_x, nzt_x
481                DO  j = nys_x, nyn_x
482
483                   x_in(0:nx) = ar(0:nx,j,k)
484                   CALL FFTW_EXECUTE_DFT_R2C( plan_xf, x_in, x_out )
485
486                   IF ( PRESENT( ar_2d ) )  THEN
487
488                      DO  i = 0, (nx+1)/2
489                         ar_2d(i,j) = REAL( x_out(i), KIND=wp ) / ( nx+1 )
490                      ENDDO
491                      DO  i = 1, (nx+1)/2 - 1
492                         ar_2d(nx+1-i,j) = AIMAG( x_out(i) ) / ( nx+1 )
493                      ENDDO
494
495                   ELSE
496
497                      DO  i = 0, (nx+1)/2
498                         ar(i,j,k) = REAL( x_out(i), KIND=wp ) / ( nx+1 )
499                      ENDDO
500                      DO  i = 1, (nx+1)/2 - 1
501                         ar(nx+1-i,j,k) = AIMAG( x_out(i) ) / ( nx+1 )
502                      ENDDO
503
504                   ENDIF
505
506                ENDDO
507             ENDDO
508             !$OMP END PARALLEL
509
510          ELSE
511             !$OMP PARALLEL PRIVATE ( work, i, j, k )
512             !$OMP DO
513             DO  k = nzb_x, nzt_x
514                DO  j = nys_x, nyn_x
515
516                   IF ( PRESENT( ar_2d ) )  THEN
517
518                      x_out(0) = CMPLX( ar_2d(0,j), 0.0_wp, KIND=wp )
519                      DO  i = 1, (nx+1)/2 - 1
520                         x_out(i) = CMPLX( ar_2d(i,j), ar_2d(nx+1-i,j),        &
521                                           KIND=wp )
522                      ENDDO
523                      x_out((nx+1)/2) = CMPLX( ar_2d((nx+1)/2,j), 0.0_wp,      &
524                                               KIND=wp )
525
526                   ELSE
527
528                      x_out(0) = CMPLX( ar(0,j,k), 0.0_wp, KIND=wp )
529                      DO  i = 1, (nx+1)/2 - 1
530                         x_out(i) = CMPLX( ar(i,j,k), ar(nx+1-i,j,k), KIND=wp )
531                      ENDDO
532                      x_out((nx+1)/2) = CMPLX( ar((nx+1)/2,j,k), 0.0_wp,       &
533                                               KIND=wp )
534
535                   ENDIF
536
537                   CALL FFTW_EXECUTE_DFT_C2R( plan_xi, x_out, x_in)
538                   ar(0:nx,j,k) = x_in(0:nx)
539
540                ENDDO
541             ENDDO
542             !$OMP END PARALLEL
543
544          ENDIF
545#endif
546
547       ELSEIF ( fft_method == 'system-specific' )  THEN
548
549#if defined( __ibm )
550          IF ( forward_fft )  THEN
551
552             !$OMP PARALLEL PRIVATE ( work, i, j, k )
553             !$OMP DO
554             DO  k = nzb_x, nzt_x
555                DO  j = nys_x, nyn_x
556
557                   CALL DRCFT( 0, ar, 1, work, 1, nx+1, 1, 1, sqr_dnx, aux1,   &
558                               nau1, aux2, nau2 )
559
560                   DO  i = 0, (nx+1)/2
561                      ar(i,j,k) = work(2*i)
562                   ENDDO
563                   DO  i = 1, (nx+1)/2 - 1
564                      ar(nx+1-i,j,k) = work(2*i+1)
565                   ENDDO
566
567                ENDDO
568             ENDDO
569             !$OMP END PARALLEL
570
571          ELSE
572
573             !$OMP PARALLEL PRIVATE ( work, i, j, k )
574             !$OMP DO
575             DO  k = nzb_x, nzt_x
576                DO  j = nys_x, nyn_x
577
578                   DO  i = 0, (nx+1)/2
579                      work(2*i) = ar(i,j,k)
580                   ENDDO
581                   DO  i = 1, (nx+1)/2 - 1
582                      work(2*i+1) = ar(nx+1-i,j,k)
583                   ENDDO
584                   work(1) = 0.0_wp
585                   work(nx+2) = 0.0_wp
586
587                   CALL DCRFT( 0, work, 1, work, 1, nx+1, 1, -1, sqr_dnx,      & 
588                               aux3, nau1, aux4, nau2 )
589
590                   DO  i = 0, nx
591                      ar(i,j,k) = work(i)
592                   ENDDO
593
594                ENDDO
595             ENDDO
596             !$OMP END PARALLEL
597
598          ENDIF
599
600#elif defined( __nec )
601
602          IF ( forward_fft )  THEN
603
604             !$OMP PARALLEL PRIVATE ( work, i, j, k )
605             !$OMP DO
606             DO  k = nzb_x, nzt_x
607                DO  j = nys_x, nyn_x
608
609                   work(0:nx) = ar(0:nx,j,k)
610
611                   CALL DZFFT( 1, nx+1, sqr_dnx, work, work, trig_xf, work2, 0 )
612     
613                   DO  i = 0, (nx+1)/2
614                      ar(i,j,k) = work(2*i)
615                   ENDDO
616                   DO  i = 1, (nx+1)/2 - 1
617                      ar(nx+1-i,j,k) = work(2*i+1)
618                   ENDDO
619
620                ENDDO
621             ENDDO
622             !$END OMP PARALLEL
623
624          ELSE
625
626             !$OMP PARALLEL PRIVATE ( work, i, j, k )
627             !$OMP DO
628             DO  k = nzb_x, nzt_x
629                DO  j = nys_x, nyn_x
630
631                   DO  i = 0, (nx+1)/2
632                      work(2*i) = ar(i,j,k)
633                   ENDDO
634                   DO  i = 1, (nx+1)/2 - 1
635                      work(2*i+1) = ar(nx+1-i,j,k)
636                   ENDDO
637                   work(1) = 0.0_wp
638                   work(nx+2) = 0.0_wp
639
640                   CALL ZDFFT( -1, nx+1, sqr_dnx, work, work, trig_xb, work2, 0 )
641
642                   ar(0:nx,j,k) = work(0:nx)
643
644                ENDDO
645             ENDDO
646             !$OMP END PARALLEL
647
648          ENDIF
649
650#elif defined( __cuda_fft )
651
652          IF ( forward_fft )  THEN
653
654             !$ACC HOST_DATA USE_DEVICE(ar, ar_tmp)
655             CALL CUFFTEXECD2Z( plan_xf, ar, ar_tmp )
656             !$ACC END HOST_DATA
657
658             !$ACC PARALLEL LOOP COLLAPSE(2) PRIVATE(i,j,k) &
659             !$ACC PRESENT(ar, ar_tmp)
660             DO  k = nzb_x, nzt_x
661                DO  j = nys_x, nyn_x
662
663                   DO  i = 0, (nx+1)/2
664                      ar(i,j,k)      = REAL( ar_tmp(i,j,k), KIND=wp )  * dnx
665                   ENDDO
666
667                   DO  i = 1, (nx+1)/2 - 1
668                      ar(nx+1-i,j,k) = AIMAG( ar_tmp(i,j,k) ) * dnx
669                   ENDDO
670
671                ENDDO
672             ENDDO
673
674          ELSE
675
676             !$ACC PARALLEL LOOP COLLAPSE(2) PRIVATE(i,j,k) &
677             !$ACC PRESENT(ar, ar_tmp)
678             DO  k = nzb_x, nzt_x
679                DO  j = nys_x, nyn_x
680
681                   ar_tmp(0,j,k) = CMPLX( ar(0,j,k), 0.0_wp, KIND=wp )
682
683                   DO  i = 1, (nx+1)/2 - 1
684                      ar_tmp(i,j,k) = CMPLX( ar(i,j,k), ar(nx+1-i,j,k),        &
685                                             KIND=wp )
686                   ENDDO
687                   ar_tmp((nx+1)/2,j,k) = CMPLX( ar((nx+1)/2,j,k), 0.0_wp,     &
688                                                 KIND=wp )
689
690                ENDDO
691             ENDDO
692
693             !$ACC HOST_DATA USE_DEVICE(ar, ar_tmp)
694             CALL CUFFTEXECZ2D( plan_xi, ar_tmp, ar )
695             !$ACC END HOST_DATA
696
697          ENDIF
698
699#endif
700
701       ENDIF
702
703    END SUBROUTINE fft_x
704
705!------------------------------------------------------------------------------!
706! Description:
707! ------------
708!> Fourier-transformation along x-direction.
709!> Version for 1D-decomposition.
710!> It uses internal algorithms (Singleton or Temperton) or
711!> system-specific routines, if they are available
712!------------------------------------------------------------------------------!
713 
714    SUBROUTINE fft_x_1d( ar, direction )
715
716
717       IMPLICIT NONE
718
719       CHARACTER (LEN=*) ::  direction  !<
720       
721       INTEGER(iwp) ::  i               !<
722       INTEGER(iwp) ::  ishape(1)       !<
723
724       LOGICAL ::  forward_fft          !<
725
726       REAL(wp), DIMENSION(0:nx)   ::  ar     !<
727       REAL(wp), DIMENSION(0:nx+2) ::  work   !<
728       REAL(wp), DIMENSION(nx+2)   ::  work1  !<
729       
730       COMPLEX(wp), DIMENSION(:), ALLOCATABLE ::  cwork  !<
731       
732#if defined( __ibm )
733       REAL(wp), DIMENSION(nau2) ::  aux2       !<
734       REAL(wp), DIMENSION(nau2) ::  aux4       !<
735#elif defined( __nec )
736       REAL(wp), DIMENSION(6*(nx+1)) ::  work2  !<
737#endif
738
739       IF ( direction == 'forward' )  THEN
740          forward_fft = .TRUE.
741       ELSE
742          forward_fft = .FALSE.
743       ENDIF
744
745       IF ( fft_method == 'singleton-algorithm' )  THEN
746
747!
748!--       Performing the fft with singleton's software works on every system,
749!--       since it is part of the model
750          ALLOCATE( cwork(0:nx) )
751     
752          IF ( forward_fft )   then
753
754             DO  i = 0, nx
755                cwork(i) = CMPLX( ar(i), KIND=wp )
756             ENDDO
757             ishape = SHAPE( cwork )
758             CALL FFTN( cwork, ishape )
759             DO  i = 0, (nx+1)/2
760                ar(i) = REAL( cwork(i), KIND=wp )
761             ENDDO
762             DO  i = 1, (nx+1)/2 - 1
763                ar(nx+1-i) = -AIMAG( cwork(i) )
764             ENDDO
765
766          ELSE
767
768             cwork(0) = CMPLX( ar(0), 0.0_wp, KIND=wp )
769             DO  i = 1, (nx+1)/2 - 1
770                cwork(i)      = CMPLX( ar(i), -ar(nx+1-i), KIND=wp )
771                cwork(nx+1-i) = CMPLX( ar(i),  ar(nx+1-i), KIND=wp )
772             ENDDO
773             cwork((nx+1)/2) = CMPLX( ar((nx+1)/2), 0.0_wp, KIND=wp )
774
775             ishape = SHAPE( cwork )
776             CALL FFTN( cwork, ishape, inv = .TRUE. )
777
778             DO  i = 0, nx
779                ar(i) = REAL( cwork(i), KIND=wp )
780             ENDDO
781
782          ENDIF
783
784          DEALLOCATE( cwork )
785
786       ELSEIF ( fft_method == 'temperton-algorithm' )  THEN
787
788!
789!--       Performing the fft with Temperton's software works on every system,
790!--       since it is part of the model
791          IF ( forward_fft )  THEN
792
793             work(0:nx) = ar
794             CALL fft991cy( work, work1, trigs_x, ifax_x, 1, nx+1, nx+1, 1, -1 )
795
796             DO  i = 0, (nx+1)/2
797                ar(i) = work(2*i)
798             ENDDO
799             DO  i = 1, (nx+1)/2 - 1
800                ar(nx+1-i) = work(2*i+1)
801             ENDDO
802
803          ELSE
804
805             DO  i = 0, (nx+1)/2
806                work(2*i) = ar(i)
807             ENDDO
808             DO  i = 1, (nx+1)/2 - 1
809                work(2*i+1) = ar(nx+1-i)
810             ENDDO
811             work(1)    = 0.0_wp
812             work(nx+2) = 0.0_wp
813
814             CALL fft991cy( work, work1, trigs_x, ifax_x, 1, nx+1, nx+1, 1, 1 )
815             ar = work(0:nx)
816
817          ENDIF
818
819       ELSEIF ( fft_method == 'fftw' )  THEN
820
821#if defined( __fftw )
822          IF ( forward_fft )  THEN
823
824             x_in(0:nx) = ar(0:nx)
825             CALL FFTW_EXECUTE_DFT_R2C( plan_xf, x_in, x_out )
826
827             DO  i = 0, (nx+1)/2
828                ar(i) = REAL( x_out(i), KIND=wp ) / ( nx+1 )
829             ENDDO
830             DO  i = 1, (nx+1)/2 - 1
831                ar(nx+1-i) = AIMAG( x_out(i) ) / ( nx+1 )
832             ENDDO
833
834         ELSE
835
836             x_out(0) = CMPLX( ar(0), 0.0_wp, KIND=wp )
837             DO  i = 1, (nx+1)/2 - 1
838                x_out(i) = CMPLX( ar(i), ar(nx+1-i), KIND=wp )
839             ENDDO
840             x_out((nx+1)/2) = CMPLX( ar((nx+1)/2), 0.0_wp, KIND=wp )
841
842             CALL FFTW_EXECUTE_DFT_C2R( plan_xi, x_out, x_in)
843             ar(0:nx) = x_in(0:nx)
844
845         ENDIF
846#endif
847
848       ELSEIF ( fft_method == 'system-specific' )  THEN
849
850#if defined( __ibm )
851          IF ( forward_fft )  THEN
852
853             CALL DRCFT( 0, ar, 1, work, 1, nx+1, 1, 1, sqr_dnx, aux1, nau1,   &
854                         aux2, nau2 )
855
856             DO  i = 0, (nx+1)/2
857                ar(i) = work(2*i)
858             ENDDO
859             DO  i = 1, (nx+1)/2 - 1
860                ar(nx+1-i) = work(2*i+1)
861             ENDDO
862
863          ELSE
864
865             DO  i = 0, (nx+1)/2
866                work(2*i) = ar(i)
867             ENDDO
868             DO  i = 1, (nx+1)/2 - 1
869                work(2*i+1) = ar(nx+1-i)
870             ENDDO
871             work(1) = 0.0_wp
872             work(nx+2) = 0.0_wp
873
874             CALL DCRFT( 0, work, 1, work, 1, nx+1, 1, -1, sqr_dnx, aux3, nau1, &
875                         aux4, nau2 )
876
877             DO  i = 0, nx
878                ar(i) = work(i)
879             ENDDO
880
881          ENDIF
882#elif defined( __nec )
883          IF ( forward_fft )  THEN
884
885             work(0:nx) = ar(0:nx)
886
887             CALL DZFFT( 1, nx+1, sqr_dnx, work, work, trig_xf, work2, 0 )
888     
889             DO  i = 0, (nx+1)/2
890                ar(i) = work(2*i)
891             ENDDO
892             DO  i = 1, (nx+1)/2 - 1
893                ar(nx+1-i) = work(2*i+1)
894             ENDDO
895
896          ELSE
897
898             DO  i = 0, (nx+1)/2
899                work(2*i) = ar(i)
900             ENDDO
901             DO  i = 1, (nx+1)/2 - 1
902                work(2*i+1) = ar(nx+1-i)
903             ENDDO
904             work(1) = 0.0_wp
905             work(nx+2) = 0.0_wp
906
907             CALL ZDFFT( -1, nx+1, sqr_dnx, work, work, trig_xb, work2, 0 )
908
909             ar(0:nx) = work(0:nx)
910
911          ENDIF
912#endif
913
914       ENDIF
915
916    END SUBROUTINE fft_x_1d
917
918!------------------------------------------------------------------------------!
919! Description:
920! ------------
921!> Fourier-transformation along y-direction.
922!> Version for 2D-decomposition.
923!> It uses internal algorithms (Singleton or Temperton) or
924!> system-specific routines, if they are available.
925!>
926!> direction:  'forward' or 'backward'
927!> ar, ar_tr:  3D data arrays
928!>             forward:   ar: before  ar_tr: after transformation
929!>             backward:  ar_tr: before  ar: after transfosition
930!>
931!> In case of non-overlapping transposition/transformation:
932!> nxl_y_bound = nxl_y_l = nxl_y
933!> nxr_y_bound = nxr_y_l = nxr_y
934!>
935!> In case of overlapping transposition/transformation
936!> - nxl_y_bound  and  nxr_y_bound have the original values of
937!>   nxl_y, nxr_y.  ar_tr is dimensioned using these values.
938!> - nxl_y_l = nxr_y_r.  ar is dimensioned with these values, so that
939!>   transformation is carried out for a 2D-plane only.
940!------------------------------------------------------------------------------!
941 
942    SUBROUTINE fft_y( ar, direction, ar_tr, nxl_y_bound, nxr_y_bound, nxl_y_l, &
943                      nxr_y_l )
944
945
946       IMPLICIT NONE
947
948       CHARACTER (LEN=*) ::  direction  !<
949       
950       INTEGER(iwp) ::  i            !<
951       INTEGER(iwp) ::  j            !<
952       INTEGER(iwp) ::  jshape(1)    !<
953       INTEGER(iwp) ::  k            !<
954       INTEGER(iwp) ::  nxl_y_bound  !<
955       INTEGER(iwp) ::  nxl_y_l      !<
956       INTEGER(iwp) ::  nxr_y_bound  !<
957       INTEGER(iwp) ::  nxr_y_l      !<
958
959       LOGICAL ::  forward_fft  !<
960
961       REAL(wp), DIMENSION(0:ny+2) ::  work   !<
962       REAL(wp), DIMENSION(ny+2)   ::  work1  !<
963       
964       COMPLEX(wp), DIMENSION(:), ALLOCATABLE ::  cwork  !<
965       
966#if defined( __ibm )
967       REAL(wp), DIMENSION(nau2) ::  auy2  !<
968       REAL(wp), DIMENSION(nau2) ::  auy4  !<
969#elif defined( __nec )
970       REAL(wp), DIMENSION(6*(ny+1)) ::  work2  !<
971#elif defined( __cuda_fft )
972       COMPLEX(dp), DIMENSION(0:(ny+1)/2,nxl_y:nxr_y,nzb_y:nzt_y) ::           &
973          ar_tmp  !<
974       !$ACC DECLARE CREATE(ar_tmp)
975#endif
976
977       REAL(wp), DIMENSION(0:ny,nxl_y_l:nxr_y_l,nzb_y:nzt_y)         ::        &
978          ar     !<
979       REAL(wp), DIMENSION(0:ny,nxl_y_bound:nxr_y_bound,nzb_y:nzt_y) ::        &
980          ar_tr  !<
981
982       IF ( direction == 'forward' )  THEN
983          forward_fft = .TRUE.
984       ELSE
985          forward_fft = .FALSE.
986       ENDIF
987
988       IF ( fft_method == 'singleton-algorithm' )  THEN
989
990!
991!--       Performing the fft with singleton's software works on every system,
992!--       since it is part of the model
993          ALLOCATE( cwork(0:ny) )
994
995          IF ( forward_fft )   then
996
997             !$OMP PARALLEL PRIVATE ( cwork, i, jshape, j, k )
998             !$OMP DO
999             DO  k = nzb_y, nzt_y
1000                DO  i = nxl_y_l, nxr_y_l
1001
1002                   DO  j = 0, ny
1003                      cwork(j) = CMPLX( ar(j,i,k), KIND=wp )
1004                   ENDDO
1005
1006                   jshape = SHAPE( cwork )
1007                   CALL FFTN( cwork, jshape )
1008
1009                   DO  j = 0, (ny+1)/2
1010                      ar_tr(j,i,k) = REAL( cwork(j), KIND=wp )
1011                   ENDDO
1012                   DO  j = 1, (ny+1)/2 - 1
1013                      ar_tr(ny+1-j,i,k) = -AIMAG( cwork(j) )
1014                   ENDDO
1015
1016                ENDDO
1017             ENDDO
1018             !$OMP END PARALLEL
1019
1020          ELSE
1021
1022             !$OMP PARALLEL PRIVATE ( cwork, i, jshape, j, k )
1023             !$OMP DO
1024             DO  k = nzb_y, nzt_y
1025                DO  i = nxl_y_l, nxr_y_l
1026
1027                   cwork(0) = CMPLX( ar_tr(0,i,k), 0.0_wp, KIND=wp )
1028                   DO  j = 1, (ny+1)/2 - 1
1029                      cwork(j)      = CMPLX( ar_tr(j,i,k), -ar_tr(ny+1-j,i,k), &
1030                                             KIND=wp )
1031                      cwork(ny+1-j) = CMPLX( ar_tr(j,i,k),  ar_tr(ny+1-j,i,k), &
1032                                             KIND=wp )
1033                   ENDDO
1034                   cwork((ny+1)/2) = CMPLX( ar_tr((ny+1)/2,i,k), 0.0_wp,       &
1035                                            KIND=wp )
1036
1037                   jshape = SHAPE( cwork )
1038                   CALL FFTN( cwork, jshape, inv = .TRUE. )
1039
1040                   DO  j = 0, ny
1041                      ar(j,i,k) = REAL( cwork(j), KIND=wp )
1042                   ENDDO
1043
1044                ENDDO
1045             ENDDO
1046             !$OMP END PARALLEL
1047
1048          ENDIF
1049
1050          DEALLOCATE( cwork )
1051
1052       ELSEIF ( fft_method == 'temperton-algorithm' )  THEN
1053
1054!
1055!--       Performing the fft with Temperton's software works on every system,
1056!--       since it is part of the model
1057          IF ( forward_fft )  THEN
1058
1059             !$OMP PARALLEL PRIVATE ( work, work1, i, j, k )
1060             !$OMP DO
1061             DO  k = nzb_y, nzt_y
1062                DO  i = nxl_y_l, nxr_y_l
1063
1064                   work(0:ny) = ar(0:ny,i,k)
1065                   CALL fft991cy( work, work1, trigs_y, ifax_y, 1, ny+1, ny+1, 1, -1 )
1066
1067                   DO  j = 0, (ny+1)/2
1068                      ar_tr(j,i,k) = work(2*j)
1069                   ENDDO
1070                   DO  j = 1, (ny+1)/2 - 1
1071                      ar_tr(ny+1-j,i,k) = work(2*j+1)
1072                   ENDDO
1073
1074                ENDDO
1075             ENDDO
1076             !$OMP END PARALLEL
1077
1078          ELSE
1079
1080             !$OMP PARALLEL PRIVATE ( work, work1, i, j, k )
1081             !$OMP DO
1082             DO  k = nzb_y, nzt_y
1083                DO  i = nxl_y_l, nxr_y_l
1084
1085                   DO  j = 0, (ny+1)/2
1086                      work(2*j) = ar_tr(j,i,k)
1087                   ENDDO
1088                   DO  j = 1, (ny+1)/2 - 1
1089                      work(2*j+1) = ar_tr(ny+1-j,i,k)
1090                   ENDDO
1091                   work(1)    = 0.0_wp
1092                   work(ny+2) = 0.0_wp
1093
1094                   CALL fft991cy( work, work1, trigs_y, ifax_y, 1, ny+1, ny+1, 1, 1 )
1095                   ar(0:ny,i,k) = work(0:ny)
1096
1097                ENDDO
1098             ENDDO
1099             !$OMP END PARALLEL
1100
1101          ENDIF
1102
1103       ELSEIF ( fft_method == 'fftw' )  THEN
1104
1105#if defined( __fftw )
1106          IF ( forward_fft )  THEN
1107
1108             !$OMP PARALLEL PRIVATE ( work, i, j, k )
1109             !$OMP DO
1110             DO  k = nzb_y, nzt_y
1111                DO  i = nxl_y_l, nxr_y_l
1112
1113                   y_in(0:ny) = ar(0:ny,i,k)
1114                   CALL FFTW_EXECUTE_DFT_R2C( plan_yf, y_in, y_out )
1115
1116                   DO  j = 0, (ny+1)/2
1117                      ar_tr(j,i,k) = REAL( y_out(j), KIND=wp ) / (ny+1)
1118                   ENDDO
1119                   DO  j = 1, (ny+1)/2 - 1
1120                      ar_tr(ny+1-j,i,k) = AIMAG( y_out(j) ) / (ny+1)
1121                   ENDDO
1122
1123                ENDDO
1124             ENDDO
1125             !$OMP END PARALLEL
1126
1127          ELSE
1128
1129             !$OMP PARALLEL PRIVATE ( work, i, j, k )
1130             !$OMP DO
1131             DO  k = nzb_y, nzt_y
1132                DO  i = nxl_y_l, nxr_y_l
1133
1134                   y_out(0) = CMPLX( ar_tr(0,i,k), 0.0_wp, KIND=wp )
1135                   DO  j = 1, (ny+1)/2 - 1
1136                      y_out(j) = CMPLX( ar_tr(j,i,k), ar_tr(ny+1-j,i,k),       &
1137                                        KIND=wp )
1138                   ENDDO
1139                   y_out((ny+1)/2) = CMPLX( ar_tr((ny+1)/2,i,k), 0.0_wp,       &
1140                                            KIND=wp )
1141
1142                   CALL FFTW_EXECUTE_DFT_C2R( plan_yi, y_out, y_in )
1143                   ar(0:ny,i,k) = y_in(0:ny)
1144
1145                ENDDO
1146             ENDDO
1147             !$OMP END PARALLEL
1148
1149          ENDIF
1150#endif
1151
1152       ELSEIF ( fft_method == 'system-specific' )  THEN
1153
1154#if defined( __ibm )
1155          IF ( forward_fft)  THEN
1156
1157             !$OMP PARALLEL PRIVATE ( work, i, j, k )
1158             !$OMP DO
1159             DO  k = nzb_y, nzt_y
1160                DO  i = nxl_y_l, nxr_y_l
1161
1162                   CALL DRCFT( 0, ar, 1, work, 1, ny+1, 1, 1, sqr_dny, auy1,   & 
1163                               nau1, auy2, nau2 )
1164
1165                   DO  j = 0, (ny+1)/2
1166                      ar_tr(j,i,k) = work(2*j)
1167                   ENDDO
1168                   DO  j = 1, (ny+1)/2 - 1
1169                      ar_tr(ny+1-j,i,k) = work(2*j+1)
1170                   ENDDO
1171
1172                ENDDO
1173             ENDDO
1174             !$OMP END PARALLEL
1175
1176          ELSE
1177
1178             !$OMP PARALLEL PRIVATE ( work, i, j, k )
1179             !$OMP DO
1180             DO  k = nzb_y, nzt_y
1181                DO  i = nxl_y_l, nxr_y_l
1182
1183                   DO  j = 0, (ny+1)/2
1184                      work(2*j) = ar_tr(j,i,k)
1185                   ENDDO
1186                   DO  j = 1, (ny+1)/2 - 1
1187                      work(2*j+1) = ar_tr(ny+1-j,i,k)
1188                   ENDDO
1189                   work(1)    = 0.0_wp
1190                   work(ny+2) = 0.0_wp
1191
1192                   CALL DCRFT( 0, work, 1, work, 1, ny+1, 1, -1, sqr_dny,      &
1193                               auy3, nau1, auy4, nau2 )
1194
1195                   DO  j = 0, ny
1196                      ar(j,i,k) = work(j)
1197                   ENDDO
1198
1199                ENDDO
1200             ENDDO
1201             !$OMP END PARALLEL
1202
1203          ENDIF
1204#elif defined( __nec )
1205          IF ( forward_fft )  THEN
1206
1207             !$OMP PARALLEL PRIVATE ( work, i, j, k )
1208             !$OMP DO
1209             DO  k = nzb_y, nzt_y
1210                DO  i = nxl_y_l, nxr_y_l
1211
1212                   work(0:ny) = ar(0:ny,i,k)
1213
1214                   CALL DZFFT( 1, ny+1, sqr_dny, work, work, trig_yf, work2, 0 )
1215
1216                   DO  j = 0, (ny+1)/2
1217                      ar_tr(j,i,k) = work(2*j)
1218                   ENDDO
1219                   DO  j = 1, (ny+1)/2 - 1
1220                      ar_tr(ny+1-j,i,k) = work(2*j+1)
1221                   ENDDO
1222
1223                ENDDO
1224             ENDDO
1225             !$END OMP PARALLEL
1226
1227          ELSE
1228
1229             !$OMP PARALLEL PRIVATE ( work, i, j, k )
1230             !$OMP DO
1231             DO  k = nzb_y, nzt_y
1232                DO  i = nxl_y_l, nxr_y_l
1233
1234                   DO  j = 0, (ny+1)/2
1235                      work(2*j) = ar_tr(j,i,k)
1236                   ENDDO
1237                   DO  j = 1, (ny+1)/2 - 1
1238                      work(2*j+1) = ar_tr(ny+1-j,i,k)
1239                   ENDDO
1240                   work(1) = 0.0_wp
1241                   work(ny+2) = 0.0_wp
1242
1243                   CALL ZDFFT( -1, ny+1, sqr_dny, work, work, trig_yb, work2, 0 )
1244
1245                   ar(0:ny,i,k) = work(0:ny)
1246
1247                ENDDO
1248             ENDDO
1249             !$OMP END PARALLEL
1250
1251          ENDIF
1252#elif defined( __cuda_fft )
1253
1254          IF ( forward_fft )  THEN
1255
1256             !$ACC HOST_DATA USE_DEVICE(ar, ar_tmp)
1257             CALL CUFFTEXECD2Z( plan_yf, ar, ar_tmp )
1258             !$ACC END HOST_DATA
1259
1260             !$ACC PARALLEL LOOP COLLAPSE(2) PRIVATE(i,j,k) &
1261             !$ACC PRESENT(ar, ar_tmp)
1262             DO  k = nzb_y, nzt_y
1263                DO  i = nxl_y, nxr_y
1264
1265                   DO  j = 0, (ny+1)/2
1266                      ar(j,i,k)      = REAL( ar_tmp(j,i,k), KIND=wp )  * dny
1267                   ENDDO
1268
1269                   DO  j = 1, (ny+1)/2 - 1
1270                      ar(ny+1-j,i,k) = AIMAG( ar_tmp(j,i,k) ) * dny
1271                   ENDDO
1272
1273                ENDDO
1274             ENDDO
1275
1276          ELSE
1277
1278             !$ACC PARALLEL LOOP COLLAPSE(2) PRIVATE(i,j,k) &
1279             !$ACC PRESENT(ar, ar_tmp)
1280             DO  k = nzb_y, nzt_y
1281                DO  i = nxl_y, nxr_y
1282
1283                   ar_tmp(0,i,k) = CMPLX( ar(0,i,k), 0.0_wp, KIND=wp )
1284
1285                   DO  j = 1, (ny+1)/2 - 1
1286                      ar_tmp(j,i,k) = CMPLX( ar(j,i,k), ar(ny+1-j,i,k),        &
1287                                             KIND=wp )
1288                   ENDDO
1289                   ar_tmp((ny+1)/2,i,k) = CMPLX( ar((ny+1)/2,i,k), 0.0_wp,     &
1290                                                 KIND=wp )
1291
1292                ENDDO
1293             ENDDO
1294
1295             !$ACC HOST_DATA USE_DEVICE(ar, ar_tmp)
1296             CALL CUFFTEXECZ2D( plan_yi, ar_tmp, ar )
1297             !$ACC END HOST_DATA
1298
1299          ENDIF
1300
1301#endif
1302
1303       ENDIF
1304
1305    END SUBROUTINE fft_y
1306
1307!------------------------------------------------------------------------------!
1308! Description:
1309! ------------
1310!> Fourier-transformation along y-direction.
1311!> Version for 1D-decomposition.
1312!> It uses internal algorithms (Singleton or Temperton) or
1313!> system-specific routines, if they are available.
1314!------------------------------------------------------------------------------!
1315 
1316    SUBROUTINE fft_y_1d( ar, direction )
1317
1318
1319       IMPLICIT NONE
1320
1321       CHARACTER (LEN=*) ::  direction
1322       
1323       INTEGER(iwp) ::  j          !<
1324       INTEGER(iwp) ::  jshape(1)  !<
1325
1326       LOGICAL ::  forward_fft  !<
1327
1328       REAL(wp), DIMENSION(0:ny)    ::  ar     !<
1329       REAL(wp), DIMENSION(0:ny+2)  ::  work   !<
1330       REAL(wp), DIMENSION(ny+2)    ::  work1  !<
1331       
1332       COMPLEX(wp), DIMENSION(:), ALLOCATABLE ::  cwork  !<
1333       
1334#if defined( __ibm )
1335       REAL(wp), DIMENSION(nau2) ::  auy2  !<
1336       REAL(wp), DIMENSION(nau2) ::  auy4  !<
1337#elif defined( __nec )
1338       REAL(wp), DIMENSION(6*(ny+1)) ::  work2  !<
1339#endif
1340
1341       IF ( direction == 'forward' )  THEN
1342          forward_fft = .TRUE.
1343       ELSE
1344          forward_fft = .FALSE.
1345       ENDIF
1346
1347       IF ( fft_method == 'singleton-algorithm' )  THEN
1348
1349!
1350!--       Performing the fft with singleton's software works on every system,
1351!--       since it is part of the model
1352          ALLOCATE( cwork(0:ny) )
1353
1354          IF ( forward_fft )  THEN
1355
1356             DO  j = 0, ny
1357                cwork(j) = CMPLX( ar(j), KIND=wp )
1358             ENDDO
1359
1360             jshape = SHAPE( cwork )
1361             CALL FFTN( cwork, jshape )
1362
1363             DO  j = 0, (ny+1)/2
1364                ar(j) = REAL( cwork(j), KIND=wp )
1365             ENDDO
1366             DO  j = 1, (ny+1)/2 - 1
1367                ar(ny+1-j) = -AIMAG( cwork(j) )
1368             ENDDO
1369
1370          ELSE
1371
1372             cwork(0) = CMPLX( ar(0), 0.0_wp, KIND=wp )
1373             DO  j = 1, (ny+1)/2 - 1
1374                cwork(j)      = CMPLX( ar(j), -ar(ny+1-j), KIND=wp )
1375                cwork(ny+1-j) = CMPLX( ar(j),  ar(ny+1-j), KIND=wp )
1376             ENDDO
1377             cwork((ny+1)/2) = CMPLX( ar((ny+1)/2), 0.0_wp, KIND=wp )
1378
1379             jshape = SHAPE( cwork )
1380             CALL FFTN( cwork, jshape, inv = .TRUE. )
1381
1382             DO  j = 0, ny
1383                ar(j) = REAL( cwork(j), KIND=wp )
1384             ENDDO
1385
1386          ENDIF
1387
1388          DEALLOCATE( cwork )
1389
1390       ELSEIF ( fft_method == 'temperton-algorithm' )  THEN
1391
1392!
1393!--       Performing the fft with Temperton's software works on every system,
1394!--       since it is part of the model
1395          IF ( forward_fft )  THEN
1396
1397             work(0:ny) = ar
1398             CALL fft991cy( work, work1, trigs_y, ifax_y, 1, ny+1, ny+1, 1, -1 )
1399
1400             DO  j = 0, (ny+1)/2
1401                ar(j) = work(2*j)
1402             ENDDO
1403             DO  j = 1, (ny+1)/2 - 1
1404                ar(ny+1-j) = work(2*j+1)
1405             ENDDO
1406
1407          ELSE
1408
1409             DO  j = 0, (ny+1)/2
1410                work(2*j) = ar(j)
1411             ENDDO
1412             DO  j = 1, (ny+1)/2 - 1
1413                work(2*j+1) = ar(ny+1-j)
1414             ENDDO
1415             work(1)    = 0.0_wp
1416             work(ny+2) = 0.0_wp
1417
1418             CALL fft991cy( work, work1, trigs_y, ifax_y, 1, ny+1, ny+1, 1, 1 )
1419             ar = work(0:ny)
1420
1421          ENDIF
1422
1423       ELSEIF ( fft_method == 'fftw' )  THEN
1424
1425#if defined( __fftw )
1426          IF ( forward_fft )  THEN
1427
1428             y_in(0:ny) = ar(0:ny)
1429             CALL FFTW_EXECUTE_DFT_R2C( plan_yf, y_in, y_out )
1430
1431             DO  j = 0, (ny+1)/2
1432                ar(j) = REAL( y_out(j), KIND=wp ) / (ny+1)
1433             ENDDO
1434             DO  j = 1, (ny+1)/2 - 1
1435                ar(ny+1-j) = AIMAG( y_out(j) ) / (ny+1)
1436             ENDDO
1437
1438          ELSE
1439
1440             y_out(0) = CMPLX( ar(0), 0.0_wp, KIND=wp )
1441             DO  j = 1, (ny+1)/2 - 1
1442                y_out(j) = CMPLX( ar(j), ar(ny+1-j), KIND=wp )
1443             ENDDO
1444             y_out((ny+1)/2) = CMPLX( ar((ny+1)/2), 0.0_wp, KIND=wp )
1445
1446             CALL FFTW_EXECUTE_DFT_C2R( plan_yi, y_out, y_in )
1447             ar(0:ny) = y_in(0:ny)
1448
1449          ENDIF
1450#endif
1451
1452       ELSEIF ( fft_method == 'system-specific' )  THEN
1453
1454#if defined( __ibm )
1455          IF ( forward_fft )  THEN
1456
1457             CALL DRCFT( 0, ar, 1, work, 1, ny+1, 1, 1, sqr_dny, auy1, nau1,   &
1458                         auy2, nau2 )
1459
1460             DO  j = 0, (ny+1)/2
1461                ar(j) = work(2*j)
1462             ENDDO
1463             DO  j = 1, (ny+1)/2 - 1
1464                ar(ny+1-j) = work(2*j+1)
1465             ENDDO
1466
1467          ELSE
1468
1469             DO  j = 0, (ny+1)/2
1470                work(2*j) = ar(j)
1471             ENDDO
1472             DO  j = 1, (ny+1)/2 - 1
1473                work(2*j+1) = ar(ny+1-j)
1474             ENDDO
1475             work(1)    = 0.0_wp
1476             work(ny+2) = 0.0_wp
1477
1478             CALL DCRFT( 0, work, 1, work, 1, ny+1, 1, -1, sqr_dny, auy3,      &
1479                         nau1, auy4, nau2 )
1480
1481             DO  j = 0, ny
1482                ar(j) = work(j)
1483             ENDDO
1484
1485          ENDIF
1486#elif defined( __nec )
1487          IF ( forward_fft )  THEN
1488
1489             work(0:ny) = ar(0:ny)
1490
1491             CALL DZFFT( 1, ny+1, sqr_dny, work, work, trig_yf, work2, 0 )
1492
1493             DO  j = 0, (ny+1)/2
1494                ar(j) = work(2*j)
1495             ENDDO
1496             DO  j = 1, (ny+1)/2 - 1
1497                ar(ny+1-j) = work(2*j+1)
1498             ENDDO
1499
1500          ELSE
1501
1502             DO  j = 0, (ny+1)/2
1503                work(2*j) = ar(j)
1504             ENDDO
1505             DO  j = 1, (ny+1)/2 - 1
1506                work(2*j+1) = ar(ny+1-j)
1507             ENDDO
1508             work(1) = 0.0_wp
1509             work(ny+2) = 0.0_wp
1510
1511             CALL ZDFFT( -1, ny+1, sqr_dny, work, work, trig_yb, work2, 0 )
1512
1513             ar(0:ny) = work(0:ny)
1514
1515          ENDIF
1516#endif
1517
1518       ENDIF
1519
1520    END SUBROUTINE fft_y_1d
1521
1522!------------------------------------------------------------------------------!
1523! Description:
1524! ------------
1525!> Fourier-transformation along x-direction.
1526!> Version for 1d domain decomposition
1527!> using multiple 1D FFT from Math Keisan on NEC or Temperton-algorithm
1528!> (no singleton-algorithm on NEC because it does not vectorize)
1529!------------------------------------------------------------------------------!
1530 
1531    SUBROUTINE fft_x_m( ar, direction )
1532
1533
1534       IMPLICIT NONE
1535
1536       CHARACTER (LEN=*) ::  direction  !<
1537       
1538       INTEGER(iwp) ::  i     !<
1539       INTEGER(iwp) ::  k     !<
1540       INTEGER(iwp) ::  siza  !<
1541#if defined( __nec )
1542       INTEGER(iwp) ::  sizw
1543#endif
1544
1545       REAL(wp), DIMENSION(0:nx,nz)       ::  ar     !<
1546       REAL(wp), DIMENSION(0:nx+3,nz+1)   ::  ai     !<
1547       REAL(wp), DIMENSION(6*(nx+4),nz+1) ::  work1  !<
1548       
1549#if defined( __nec )
1550       COMPLEX(wp), DIMENSION(:,:), ALLOCATABLE ::  work
1551#endif
1552
1553       IF ( fft_method == 'temperton-algorithm' )  THEN
1554
1555          siza = SIZE( ai, 1 )
1556
1557          IF ( direction == 'forward')  THEN
1558
1559             ai(0:nx,1:nz) = ar(0:nx,1:nz)
1560             ai(nx+1:,:)   = 0.0_wp
1561
1562             CALL fft991cy( ai, work1, trigs_x, ifax_x, 1, siza, nx+1, nz, -1 )
1563
1564             DO  k = 1, nz
1565                DO  i = 0, (nx+1)/2
1566                   ar(i,k) = ai(2*i,k)
1567                ENDDO
1568                DO  i = 1, (nx+1)/2 - 1
1569                   ar(nx+1-i,k) = ai(2*i+1,k)
1570                ENDDO
1571             ENDDO
1572
1573          ELSE
1574
1575             DO  k = 1, nz
1576                DO  i = 0, (nx+1)/2
1577                   ai(2*i,k) = ar(i,k)
1578                ENDDO
1579                DO  i = 1, (nx+1)/2 - 1
1580                   ai(2*i+1,k) = ar(nx+1-i,k)
1581                ENDDO
1582                ai(1,k) = 0.0_wp
1583                ai(nx+2,k) = 0.0_wp
1584             ENDDO
1585
1586             CALL fft991cy( ai, work1, trigs_x, ifax_x, 1, siza, nx+1, nz, 1 )
1587
1588             ar(0:nx,1:nz) = ai(0:nx,1:nz)
1589
1590          ENDIF
1591
1592       ELSEIF ( fft_method == 'system-specific' )  THEN
1593
1594#if defined( __nec )
1595          ALLOCATE( work((nx+4)/2+1,nz+1) )
1596          siza = SIZE( ai, 1 )
1597          sizw = SIZE( work, 1 )
1598
1599          IF ( direction == 'forward')  THEN
1600
1601!
1602!--          Tables are initialized once more. This call should not be
1603!--          necessary, but otherwise program aborts in asymmetric case
1604             CALL DZFFTM( 0, nx+1, nz1, sqr_dnx, work, nx+4, work, nx+4,       &
1605                          trig_xf, work1, 0 )
1606
1607             ai(0:nx,1:nz) = ar(0:nx,1:nz)
1608             IF ( nz1 > nz )  THEN
1609                ai(:,nz1) = 0.0_wp
1610             ENDIF
1611
1612             CALL DZFFTM( 1, nx+1, nz1, sqr_dnx, ai, siza, work, sizw,         &
1613                          trig_xf, work1, 0 )
1614
1615             DO  k = 1, nz
1616                DO  i = 0, (nx+1)/2
1617                   ar(i,k) = REAL( work(i+1,k), KIND=wp )
1618                ENDDO
1619                DO  i = 1, (nx+1)/2 - 1
1620                   ar(nx+1-i,k) = AIMAG( work(i+1,k) )
1621                ENDDO
1622             ENDDO
1623
1624          ELSE
1625
1626!
1627!--          Tables are initialized once more. This call should not be
1628!--          necessary, but otherwise program aborts in asymmetric case
1629             CALL ZDFFTM( 0, nx+1, nz1, sqr_dnx, work, nx+4, work, nx+4,       &
1630                          trig_xb, work1, 0 )
1631
1632             IF ( nz1 > nz )  THEN
1633                work(:,nz1) = 0.0_wp
1634             ENDIF
1635             DO  k = 1, nz
1636                work(1,k) = CMPLX( ar(0,k), 0.0_wp, KIND=wp )
1637                DO  i = 1, (nx+1)/2 - 1
1638                   work(i+1,k) = CMPLX( ar(i,k), ar(nx+1-i,k), KIND=wp )
1639                ENDDO
1640                work(((nx+1)/2)+1,k) = CMPLX( ar((nx+1)/2,k), 0.0_wp, KIND=wp )
1641             ENDDO
1642
1643             CALL ZDFFTM( -1, nx+1, nz1, sqr_dnx, work, sizw, ai, siza, &
1644                          trig_xb, work1, 0 )
1645
1646             ar(0:nx,1:nz) = ai(0:nx,1:nz)
1647
1648          ENDIF
1649
1650          DEALLOCATE( work )
1651#endif
1652
1653       ENDIF
1654
1655    END SUBROUTINE fft_x_m
1656
1657!------------------------------------------------------------------------------!
1658! Description:
1659! ------------
1660!> Fourier-transformation along y-direction.
1661!> Version for 1d domain decomposition
1662!> using multiple 1D FFT from Math Keisan on NEC or Temperton-algorithm
1663!> (no singleton-algorithm on NEC because it does not vectorize)
1664!------------------------------------------------------------------------------!
1665 
1666    SUBROUTINE fft_y_m( ar, ny1, direction )
1667
1668
1669       IMPLICIT NONE
1670
1671       CHARACTER (LEN=*) ::  direction  !<
1672       
1673       INTEGER(iwp) ::  j     !<
1674       INTEGER(iwp) ::  k     !<
1675       INTEGER(iwp) ::  ny1   !<
1676       INTEGER(iwp) ::  siza  !<
1677#if defined( __nec )
1678       INTEGER(iwp) ::  sizw
1679#endif
1680
1681       REAL(wp), DIMENSION(0:ny1,nz)      ::  ar     !<
1682       REAL(wp), DIMENSION(0:ny+3,nz+1)   ::  ai     !<
1683       REAL(wp), DIMENSION(6*(ny+4),nz+1) ::  work1  !<
1684
1685#if defined( __nec )
1686       COMPLEX(wp), DIMENSION(:,:), ALLOCATABLE ::  work
1687#endif
1688
1689
1690       IF ( fft_method == 'temperton-algorithm' )  THEN
1691
1692          siza = SIZE( ai, 1 )
1693
1694          IF ( direction == 'forward')  THEN
1695
1696             ai(0:ny,1:nz) = ar(0:ny,1:nz)
1697             ai(ny+1:,:)   = 0.0_wp
1698
1699             CALL fft991cy( ai, work1, trigs_y, ifax_y, 1, siza, ny+1, nz, -1 )
1700
1701             DO  k = 1, nz
1702                DO  j = 0, (ny+1)/2
1703                   ar(j,k) = ai(2*j,k)
1704                ENDDO
1705                DO  j = 1, (ny+1)/2 - 1
1706                   ar(ny+1-j,k) = ai(2*j+1,k)
1707                ENDDO
1708             ENDDO
1709
1710          ELSE
1711
1712             DO  k = 1, nz
1713                DO  j = 0, (ny+1)/2
1714                   ai(2*j,k) = ar(j,k)
1715                ENDDO
1716                DO  j = 1, (ny+1)/2 - 1
1717                   ai(2*j+1,k) = ar(ny+1-j,k)
1718                ENDDO
1719                ai(1,k) = 0.0_wp
1720                ai(ny+2,k) = 0.0_wp
1721             ENDDO
1722
1723             CALL fft991cy( ai, work1, trigs_y, ifax_y, 1, siza, ny+1, nz, 1 )
1724
1725             ar(0:ny,1:nz) = ai(0:ny,1:nz)
1726
1727          ENDIF
1728
1729       ELSEIF ( fft_method == 'system-specific' )  THEN
1730
1731#if defined( __nec )
1732          ALLOCATE( work((ny+4)/2+1,nz+1) )
1733          siza = SIZE( ai, 1 )
1734          sizw = SIZE( work, 1 )
1735
1736          IF ( direction == 'forward')  THEN
1737
1738!
1739!--          Tables are initialized once more. This call should not be
1740!--          necessary, but otherwise program aborts in asymmetric case
1741             CALL DZFFTM( 0, ny+1, nz1, sqr_dny, work, ny+4, work, ny+4, &
1742                          trig_yf, work1, 0 )
1743
1744             ai(0:ny,1:nz) = ar(0:ny,1:nz)
1745             IF ( nz1 > nz )  THEN
1746                ai(:,nz1) = 0.0_wp
1747             ENDIF
1748
1749             CALL DZFFTM( 1, ny+1, nz1, sqr_dny, ai, siza, work, sizw, &
1750                          trig_yf, work1, 0 )
1751
1752             DO  k = 1, nz
1753                DO  j = 0, (ny+1)/2
1754                   ar(j,k) = REAL( work(j+1,k), KIND=wp )
1755                ENDDO
1756                DO  j = 1, (ny+1)/2 - 1
1757                   ar(ny+1-j,k) = AIMAG( work(j+1,k) )
1758                ENDDO
1759             ENDDO
1760
1761          ELSE
1762
1763!
1764!--          Tables are initialized once more. This call should not be
1765!--          necessary, but otherwise program aborts in asymmetric case
1766             CALL ZDFFTM( 0, ny+1, nz1, sqr_dny, work, ny+4, work, ny+4, &
1767                          trig_yb, work1, 0 )
1768
1769             IF ( nz1 > nz )  THEN
1770                work(:,nz1) = 0.0_wp
1771             ENDIF
1772             DO  k = 1, nz
1773                work(1,k) = CMPLX( ar(0,k), 0.0_wp, KIND=wp )
1774                DO  j = 1, (ny+1)/2 - 1
1775                   work(j+1,k) = CMPLX( ar(j,k), ar(ny+1-j,k), KIND=wp )
1776                ENDDO
1777                work(((ny+1)/2)+1,k) = CMPLX( ar((ny+1)/2,k), 0.0_wp, KIND=wp )
1778             ENDDO
1779
1780             CALL ZDFFTM( -1, ny+1, nz1, sqr_dny, work, sizw, ai, siza, &
1781                          trig_yb, work1, 0 )
1782
1783             ar(0:ny,1:nz) = ai(0:ny,1:nz)
1784
1785          ENDIF
1786
1787          DEALLOCATE( work )
1788#endif
1789
1790       ENDIF
1791
1792    END SUBROUTINE fft_y_m
1793
1794
1795 END MODULE fft_xy
Note: See TracBrowser for help on using the repository browser.