source: palm/trunk/SOURCE/fft_xy.f90 @ 1112

Last change on this file since 1112 was 1112, checked in by raasch, 9 years ago

last commit documented

  • Property svn:keywords set to Id
File size: 45.7 KB
Line 
1 MODULE fft_xy
2
3!--------------------------------------------------------------------------------!
4! This file is part of PALM.
5!
6! PALM is free software: you can redistribute it and/or modify it under the terms
7! of the GNU General Public License as published by the Free Software Foundation,
8! either version 3 of the License, or (at your option) any later 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-2012  Leibniz University Hannover
18!--------------------------------------------------------------------------------!
19!
20! Current revisions:
21! -----------------
22!
23!
24! Former revisions:
25! -----------------
26! $Id: fft_xy.f90 1112 2013-03-09 00:34:37Z raasch $
27!
28! 1111 2013-03-08 23:54:10Z raasch
29! further openACC statements added, CUDA branch completely runs on GPU
30! bugfix: CUDA fft plans adjusted for domain decomposition (before they always
31! used total domain)
32!
33! 1106 2013-03-04 05:31:38Z raasch
34! CUDA fft added
35! array_kind renamed precision_kind, 3D- instead of 1D-loops in fft_x and fft_y
36! old fft_x, fft_y become fft_x_1d, fft_y_1d and are used for 1D-decomposition
37!
38! 1092 2013-02-02 11:24:22Z raasch
39! variable sizw declared for NEC case only
40!
41! 1036 2012-10-22 13:43:42Z raasch
42! code put under GPL (PALM 3.9)
43!
44! 274 2009-03-26 15:11:21Z heinze
45! Output of messages replaced by message handling routine.
46!
47! Feb. 2007
48! RCS Log replace by Id keyword, revision history cleaned up
49!
50! Revision 1.4  2006/03/28 12:27:09  raasch
51! Stop when system-specific fft is selected on NEC. For unknown reasons this
52! causes a program abort during first allocation in init_grid.
53!
54! Revision 1.2  2004/04/30 11:44:27  raasch
55! Module renamed from fft_for_1d_decomp to fft_xy, 1d-routines renamed to
56! fft_x and fft_y,
57! function FFT replaced by subroutine FFTN due to problems with 64-bit
58! mode on ibm,
59! shape of array cwork is explicitly stored in ishape/jshape and handled
60! to routine FFTN instead of shape-function (due to compiler error on
61! decalpha),
62! non vectorized FFT for nec included
63!
64! Revision 1.1  2002/06/11 13:00:49  raasch
65! Initial revision
66!
67!
68! Description:
69! ------------
70! Fast Fourier transformation along x and y for 1d domain decomposition along x.
71! Original version: Klaus Ketelsen (May 2002)
72!------------------------------------------------------------------------------!
73
74    USE control_parameters
75    USE indices
76    USE precision_kind
77    USE singleton
78    USE temperton_fft
79    USE transpose_indices
80
81    IMPLICIT NONE
82
83    PRIVATE
84    PUBLIC fft_x, fft_x_1d, fft_y, fft_y_1d, fft_init, fft_x_m, fft_y_m
85
86    INTEGER, DIMENSION(:), ALLOCATABLE, SAVE ::  ifax_x, ifax_y
87
88    LOGICAL, SAVE                            ::  init_fft = .FALSE.
89
90    REAL, SAVE ::  dnx, dny, sqr_dnx, sqr_dny
91    REAL, DIMENSION(:), ALLOCATABLE, SAVE    ::  trigs_x, trigs_y
92
93#if defined( __ibm )
94    INTEGER, PARAMETER ::  nau1 = 20000, nau2 = 22000
95!
96!-- The following working arrays contain tables and have to be "save" and
97!-- shared in OpenMP sense
98    REAL, DIMENSION(nau1), SAVE ::  aux1, auy1, aux3, auy3
99#elif defined( __nec )
100    INTEGER, SAVE ::  nz1
101    REAL, DIMENSION(:), ALLOCATABLE, SAVE ::  trig_xb, trig_xf, trig_yb, &
102                                              trig_yf
103#elif defined( __cuda_fft )
104    INTEGER, SAVE ::  plan_xf, plan_xi, plan_yf, plan_yi, total_points_x_transpo, &
105                      total_points_y_transpo
106#endif
107
108!
109!-- Public interfaces
110    INTERFACE fft_init
111       MODULE PROCEDURE fft_init
112    END INTERFACE fft_init
113
114    INTERFACE fft_x
115       MODULE PROCEDURE fft_x
116    END INTERFACE fft_x
117
118    INTERFACE fft_x_1d
119       MODULE PROCEDURE fft_x_1d
120    END INTERFACE fft_x_1d
121
122    INTERFACE fft_y
123       MODULE PROCEDURE fft_y
124    END INTERFACE fft_y
125
126    INTERFACE fft_y_1d
127       MODULE PROCEDURE fft_y_1d
128    END INTERFACE fft_y_1d
129
130    INTERFACE fft_x_m
131       MODULE PROCEDURE fft_x_m
132    END INTERFACE fft_x_m
133
134    INTERFACE fft_y_m
135       MODULE PROCEDURE fft_y_m
136    END INTERFACE fft_y_m
137
138 CONTAINS
139
140
141    SUBROUTINE fft_init
142
143       USE cuda_fft_interfaces
144
145       IMPLICIT NONE
146
147!
148!--    The following temporary working arrays have to be on stack or private
149!--    in OpenMP sense
150#if defined( __ibm )
151       REAL, DIMENSION(0:nx+2) :: workx
152       REAL, DIMENSION(0:ny+2) :: worky
153       REAL, DIMENSION(nau2)   :: aux2, auy2, aux4, auy4
154#elif defined( __nec )
155       REAL, DIMENSION(0:nx+3,nz+1)   ::  work_x
156       REAL, DIMENSION(0:ny+3,nz+1)   ::  work_y
157       REAL, DIMENSION(6*(nx+3),nz+1) ::  workx
158       REAL, DIMENSION(6*(ny+3),nz+1) ::  worky
159#endif
160
161!
162!--    Return, if already called
163       IF ( init_fft )  THEN
164          RETURN
165       ELSE
166          init_fft = .TRUE.
167       ENDIF
168
169       IF ( fft_method == 'system-specific' )  THEN
170
171          dnx = 1.0 / ( nx + 1.0 )
172          dny = 1.0 / ( ny + 1.0 )
173          sqr_dnx = SQRT( dnx )
174          sqr_dny = SQRT( dny )
175#if defined( __ibm )  &&  ! defined( __ibmy_special )
176!
177!--       Initialize tables for fft along x
178          CALL DRCFT( 1, workx, 1, workx, 1, nx+1, 1,  1, sqr_dnx, aux1, nau1, &
179                      aux2, nau2 )
180          CALL DCRFT( 1, workx, 1, workx, 1, nx+1, 1, -1, sqr_dnx, aux3, nau1, &
181                      aux4, nau2 )
182!
183!--       Initialize tables for fft along y
184          CALL DRCFT( 1, worky, 1, worky, 1, ny+1, 1,  1, sqr_dny, auy1, nau1, &
185                      auy2, nau2 )
186          CALL DCRFT( 1, worky, 1, worky, 1, ny+1, 1, -1, sqr_dny, auy3, nau1, &
187                      auy4, nau2 )
188#elif defined( __nec )
189          message_string = 'fft method "' // TRIM( fft_method) // &
190                           '" currently does not work on NEC'
191          CALL message( 'fft_init', 'PA0187', 1, 2, 0, 6, 0 )
192
193          ALLOCATE( trig_xb(2*(nx+1)), trig_xf(2*(nx+1)), &
194                    trig_yb(2*(ny+1)), trig_yf(2*(ny+1)) )
195
196          work_x = 0.0
197          work_y = 0.0
198          nz1  = nz + MOD( nz+1, 2 )  ! odd nz slows down fft significantly
199                                      ! when using the NEC ffts
200
201!
202!--       Initialize tables for fft along x (non-vector and vector case (M))
203          CALL DZFFT( 0, nx+1, sqr_dnx, work_x, work_x, trig_xf, workx, 0 )
204          CALL ZDFFT( 0, nx+1, sqr_dnx, work_x, work_x, trig_xb, workx, 0 )
205          CALL DZFFTM( 0, nx+1, nz1, sqr_dnx, work_x, nx+4, work_x, nx+4, &
206                       trig_xf, workx, 0 )
207          CALL ZDFFTM( 0, nx+1, nz1, sqr_dnx, work_x, nx+4, work_x, nx+4, &
208                       trig_xb, workx, 0 )
209!
210!--       Initialize tables for fft along y (non-vector and vector case (M))
211          CALL DZFFT( 0, ny+1, sqr_dny, work_y, work_y, trig_yf, worky, 0 )
212          CALL ZDFFT( 0, ny+1, sqr_dny, work_y, work_y, trig_yb, worky, 0 )
213          CALL DZFFTM( 0, ny+1, nz1, sqr_dny, work_y, ny+4, work_y, ny+4, &
214                       trig_yf, worky, 0 )
215          CALL ZDFFTM( 0, ny+1, nz1, sqr_dny, work_y, ny+4, work_y, ny+4, &
216                       trig_yb, worky, 0 )
217#elif defined( __cuda_fft )
218          total_points_x_transpo = (nx+1) * (nyn_x-nys_x+1) * (nzt_x-nzb_x+1)
219          total_points_y_transpo = (ny+1) * (nxr_y-nxl_y+1) * (nzt_y-nzb_y+1)
220          CALL CUFFTPLAN1D( plan_xf, nx+1, CUFFT_D2Z, (nyn_x-nys_x+1) * (nzt_x-nzb_x+1) )
221          CALL CUFFTPLAN1D( plan_xi, nx+1, CUFFT_Z2D, (nyn_x-nys_x+1) * (nzt_x-nzb_x+1) )
222          CALL CUFFTPLAN1D( plan_yf, ny+1, CUFFT_D2Z, (nxr_y-nxl_y+1) * (nzt_y-nzb_y+1) )
223          CALL CUFFTPLAN1D( plan_yi, ny+1, CUFFT_Z2D, (nxr_y-nxl_y+1) * (nzt_y-nzb_y+1) )
224#else
225          message_string = 'no system-specific fft-call available'
226          CALL message( 'fft_init', 'PA0188', 1, 2, 0, 6, 0 )
227#endif
228       ELSEIF ( fft_method == 'temperton-algorithm' )  THEN
229!
230!--       Temperton-algorithm
231!--       Initialize tables for fft along x and y
232          ALLOCATE( ifax_x(nx+1), ifax_y(ny+1), trigs_x(nx+1), trigs_y(ny+1) )
233
234          CALL set99( trigs_x, ifax_x, nx+1 )
235          CALL set99( trigs_y, ifax_y, ny+1 )
236
237       ELSEIF ( fft_method == 'singleton-algorithm' )  THEN
238
239          CONTINUE
240
241       ELSE
242
243          message_string = 'fft method "' // TRIM( fft_method) // &
244                           '" not available'
245          CALL message( 'fft_init', 'PA0189', 1, 2, 0, 6, 0 )
246       ENDIF
247
248    END SUBROUTINE fft_init
249
250
251    SUBROUTINE fft_x( ar, direction )
252
253!----------------------------------------------------------------------!
254!                                 fft_x                                !
255!                                                                      !
256!               Fourier-transformation along x-direction               !
257!                     Version for 2D-decomposition                     !
258!                                                                      !
259!      fft_x uses internal algorithms (Singleton or Temperton) or      !
260!           system-specific routines, if they are available            !
261!----------------------------------------------------------------------!
262
263       USE cuda_fft_interfaces
264
265       IMPLICIT NONE
266
267       CHARACTER (LEN=*) ::  direction
268       INTEGER ::  i, ishape(1), j, k
269
270       LOGICAL ::  forward_fft
271
272       REAL, DIMENSION(0:nx+2)   ::  work
273       REAL, DIMENSION(nx+2)     ::  work1
274       COMPLEX, DIMENSION(:), ALLOCATABLE ::  cwork
275#if defined( __ibm )
276       REAL, DIMENSION(nau2)     ::  aux2, aux4
277#elif defined( __nec )
278       REAL, DIMENSION(6*(nx+1)) ::  work2
279#elif defined( __cuda_fft )
280       !$acc declare create( ar_tmp )
281       COMPLEX(dpk), DIMENSION(0:(nx+1)/2,nys_x:nyn_x,nzb_x:nzt_x) ::  ar_tmp
282#endif
283       REAL, DIMENSION(0:nx,nys_x:nyn_x,nzb_x:nzt_x) ::  ar
284
285       IF ( direction == 'forward' )  THEN
286          forward_fft = .TRUE.
287       ELSE
288          forward_fft = .FALSE.
289       ENDIF
290
291       IF ( fft_method == 'singleton-algorithm' )  THEN
292
293!
294!--       Performing the fft with singleton's software works on every system,
295!--       since it is part of the model
296          ALLOCATE( cwork(0:nx) )
297     
298          IF ( forward_fft )   then
299
300             !$OMP PARALLEL PRIVATE ( cwork, i, ishape, j, k )
301             !$OMP DO
302             DO  k = nzb_x, nzt_x
303                DO  j = nys_x, nyn_x
304
305                   DO  i = 0, nx
306                      cwork(i) = CMPLX( ar(i,j,k) )
307                   ENDDO
308
309                   ishape = SHAPE( cwork )
310                   CALL FFTN( cwork, ishape )
311
312                   DO  i = 0, (nx+1)/2
313                      ar(i,j,k) = REAL( cwork(i) )
314                   ENDDO
315                   DO  i = 1, (nx+1)/2 - 1
316                      ar(nx+1-i,j,k) = -AIMAG( cwork(i) )
317                   ENDDO
318
319                ENDDO
320             ENDDO
321             !$OMP END PARALLEL
322
323          ELSE
324
325             !$OMP PARALLEL PRIVATE ( cwork, i, ishape, j, k )
326             !$OMP DO
327             DO  k = nzb_x, nzt_x
328                DO  j = nys_x, nyn_x
329
330                   cwork(0) = CMPLX( ar(0,j,k), 0.0 )
331                   DO  i = 1, (nx+1)/2 - 1
332                      cwork(i)      = CMPLX( ar(i,j,k), -ar(nx+1-i,j,k) )
333                      cwork(nx+1-i) = CMPLX( ar(i,j,k),  ar(nx+1-i,j,k) )
334                   ENDDO
335                   cwork((nx+1)/2) = CMPLX( ar((nx+1)/2,j,k), 0.0 )
336
337                   ishape = SHAPE( cwork )
338                   CALL FFTN( cwork, ishape, inv = .TRUE. )
339
340                   DO  i = 0, nx
341                      ar(i,j,k) = REAL( cwork(i) )
342                   ENDDO
343
344                ENDDO
345             ENDDO
346             !$OMP END PARALLEL
347
348          ENDIF
349
350          DEALLOCATE( cwork )
351
352       ELSEIF ( fft_method == 'temperton-algorithm' )  THEN
353
354!
355!--       Performing the fft with Temperton's software works on every system,
356!--       since it is part of the model
357          IF ( forward_fft )  THEN
358
359             !$OMP PARALLEL PRIVATE ( work, i, j, k )
360             !$OMP DO
361             DO  k = nzb_x, nzt_x
362                DO  j = nys_x, nyn_x
363
364                   work(0:nx) = ar(0:nx,j,k)
365                   CALL fft991cy( work, work1, trigs_x, ifax_x, 1, nx+1, nx+1, 1, -1 )
366
367                   DO  i = 0, (nx+1)/2
368                      ar(i,j,k) = work(2*i)
369                   ENDDO
370                   DO  i = 1, (nx+1)/2 - 1
371                      ar(nx+1-i,j,k) = work(2*i+1)
372                   ENDDO
373
374                ENDDO
375             ENDDO
376             !$OMP END PARALLEL
377
378          ELSE
379
380             !$OMP PARALLEL PRIVATE ( work, i, j, k )
381             !$OMP DO
382             DO  k = nzb_x, nzt_x
383                DO  j = nys_x, nyn_x
384
385                   DO  i = 0, (nx+1)/2
386                      work(2*i) = ar(i,j,k)
387                   ENDDO
388                   DO  i = 1, (nx+1)/2 - 1
389                      work(2*i+1) = ar(nx+1-i,j,k)
390                   ENDDO
391                   work(1)    = 0.0
392                   work(nx+2) = 0.0
393
394                   CALL fft991cy( work, work1, trigs_x, ifax_x, 1, nx+1, nx+1, 1, 1 )
395                   ar(0:nx,j,k) = work(0:nx)
396
397                ENDDO
398             ENDDO
399             !$OMP END PARALLEL
400
401          ENDIF
402
403       ELSEIF ( fft_method == 'system-specific' )  THEN
404
405#if defined( __ibm )  &&  ! defined( __ibmy_special )
406          IF ( forward_fft )  THEN
407
408             !$OMP PARALLEL PRIVATE ( work, i, j, k )
409             !$OMP DO
410             DO  k = nzb_x, nzt_x
411                DO  j = nys_x, nyn_x
412
413                   CALL DRCFT( 0, ar, 1, work, 1, nx+1, 1, 1, sqr_dnx, aux1, nau1, &
414                               aux2, nau2 )
415
416                   DO  i = 0, (nx+1)/2
417                      ar(i,j,k) = work(2*i)
418                   ENDDO
419                   DO  i = 1, (nx+1)/2 - 1
420                      ar(nx+1-i,j,k) = work(2*i+1)
421                   ENDDO
422
423                ENDDO
424             ENDDO
425             !$OMP END PARALLEL
426
427          ELSE
428
429             !$OMP PARALLEL PRIVATE ( work, i, j, k )
430             !$OMP DO
431             DO  k = nzb_x, nzt_x
432                DO  j = nys_x, nyn_x
433
434                   DO  i = 0, (nx+1)/2
435                      work(2*i) = ar(i,j,k)
436                   ENDDO
437                   DO  i = 1, (nx+1)/2 - 1
438                      work(2*i+1) = ar(nx+1-i,j,k)
439                   ENDDO
440                   work(1) = 0.0
441                   work(nx+2) = 0.0
442
443                   CALL DCRFT( 0, work, 1, work, 1, nx+1, 1, -1, sqr_dnx, aux3, nau1, &
444                               aux4, nau2 )
445
446                   DO  i = 0, nx
447                      ar(i,j,k) = work(i)
448                   ENDDO
449
450                ENDDO
451             ENDDO
452             !$OMP END PARALLEL
453
454          ENDIF
455
456#elif defined( __nec )
457
458          IF ( forward_fft )  THEN
459
460             !$OMP PARALLEL PRIVATE ( work, i, j, k )
461             !$OMP DO
462             DO  k = nzb_x, nzt_x
463                DO  j = nys_x, nyn_x
464
465                   work(0:nx) = ar(0:nx,j,k)
466
467                   CALL DZFFT( 1, nx+1, sqr_dnx, work, work, trig_xf, work2, 0 )
468     
469                   DO  i = 0, (nx+1)/2
470                      ar(i,j,k) = work(2*i)
471                   ENDDO
472                   DO  i = 1, (nx+1)/2 - 1
473                      ar(nx+1-i,j,k) = work(2*i+1)
474                   ENDDO
475
476                ENDDO
477             ENDDO
478             !$END OMP PARALLEL
479
480          ELSE
481
482             !$OMP PARALLEL PRIVATE ( work, i, j, k )
483             !$OMP DO
484             DO  k = nzb_x, nzt_x
485                DO  j = nys_x, nyn_x
486
487                   DO  i = 0, (nx+1)/2
488                      work(2*i) = ar(i,j,k)
489                   ENDDO
490                   DO  i = 1, (nx+1)/2 - 1
491                      work(2*i+1) = ar(nx+1-i,j,k)
492                   ENDDO
493                   work(1) = 0.0
494                   work(nx+2) = 0.0
495
496                   CALL ZDFFT( -1, nx+1, sqr_dnx, work, work, trig_xb, work2, 0 )
497
498                   ar(0:nx,j,k) = work(0:nx)
499
500                ENDDO
501             ENDDO
502             !$OMP END PARALLEL
503
504          ENDIF
505
506#elif defined( __cuda_fft )
507
508          IF ( forward_fft )  THEN
509
510             !$acc data present( ar )
511             CALL CUFFTEXECD2Z( plan_xf, ar, ar_tmp )
512
513             !$acc kernels
514             !$acc loop
515             DO  k = nzb_x, nzt_x
516                DO  j = nys_x, nyn_x
517
518                   !$acc loop vector( 32 )
519                   DO  i = 0, (nx+1)/2
520                      ar(i,j,k)      = REAL( ar_tmp(i,j,k) )  * dnx
521                   ENDDO
522
523                   !$acc loop vector( 32 )
524                   DO  i = 1, (nx+1)/2 - 1
525                      ar(nx+1-i,j,k) = AIMAG( ar_tmp(i,j,k) ) * dnx
526                   ENDDO
527
528                ENDDO
529             ENDDO
530             !$acc end kernels
531             !$acc end data
532
533          ELSE
534
535             !$acc data present( ar )
536             !$acc kernels
537             !$acc loop
538             DO  k = nzb_x, nzt_x
539                DO  j = nys_x, nyn_x
540
541                   ar_tmp(0,j,k) = CMPLX( ar(0,j,k), 0.0 )
542
543                   !$acc loop vector( 32 )
544                   DO  i = 1, (nx+1)/2 - 1
545                      ar_tmp(i,j,k) = CMPLX( ar(i,j,k), ar(nx+1-i,j,k) )
546                   ENDDO
547                   ar_tmp((nx+1)/2,j,k) = CMPLX( ar((nx+1)/2,j,k), 0.0 )
548
549                ENDDO
550             ENDDO
551             !$acc end kernels
552
553             CALL CUFFTEXECZ2D( plan_xi, ar_tmp, ar )
554             !$acc end data
555
556          ENDIF
557
558#else
559          message_string = 'no system-specific fft-call available'
560          CALL message( 'fft_x', 'PA0188', 1, 2, 0, 6, 0 )
561#endif
562
563       ELSE
564
565          message_string = 'fft method "' // TRIM( fft_method) // &
566                           '" not available'
567          CALL message( 'fft_x', 'PA0189', 1, 2, 0, 6, 0 )
568
569       ENDIF
570
571    END SUBROUTINE fft_x
572
573    SUBROUTINE fft_x_1d( ar, direction )
574
575!----------------------------------------------------------------------!
576!                               fft_x_1d                               !
577!                                                                      !
578!               Fourier-transformation along x-direction               !
579!                     Version for 1D-decomposition                     !
580!                                                                      !
581!      fft_x uses internal algorithms (Singleton or Temperton) or      !
582!           system-specific routines, if they are available            !
583!----------------------------------------------------------------------!
584
585       IMPLICIT NONE
586
587       CHARACTER (LEN=*) ::  direction
588       INTEGER ::  i, ishape(1)
589
590       LOGICAL ::  forward_fft
591
592       REAL, DIMENSION(0:nx)     ::  ar
593       REAL, DIMENSION(0:nx+2)   ::  work
594       REAL, DIMENSION(nx+2)     ::  work1
595       COMPLEX, DIMENSION(:), ALLOCATABLE ::  cwork
596#if defined( __ibm )
597       REAL, DIMENSION(nau2)     ::  aux2, aux4
598#elif defined( __nec )
599       REAL, DIMENSION(6*(nx+1)) ::  work2
600#endif
601
602       IF ( direction == 'forward' )  THEN
603          forward_fft = .TRUE.
604       ELSE
605          forward_fft = .FALSE.
606       ENDIF
607
608       IF ( fft_method == 'singleton-algorithm' )  THEN
609
610!
611!--       Performing the fft with singleton's software works on every system,
612!--       since it is part of the model
613          ALLOCATE( cwork(0:nx) )
614     
615          IF ( forward_fft )   then
616
617             DO  i = 0, nx
618                cwork(i) = CMPLX( ar(i) )
619             ENDDO
620             ishape = SHAPE( cwork )
621             CALL FFTN( cwork, ishape )
622             DO  i = 0, (nx+1)/2
623                ar(i) = REAL( cwork(i) )
624             ENDDO
625             DO  i = 1, (nx+1)/2 - 1
626                ar(nx+1-i) = -AIMAG( cwork(i) )
627             ENDDO
628
629          ELSE
630
631             cwork(0) = CMPLX( ar(0), 0.0 )
632             DO  i = 1, (nx+1)/2 - 1
633                cwork(i)      = CMPLX( ar(i), -ar(nx+1-i) )
634                cwork(nx+1-i) = CMPLX( ar(i),  ar(nx+1-i) )
635             ENDDO
636             cwork((nx+1)/2) = CMPLX( ar((nx+1)/2), 0.0 )
637
638             ishape = SHAPE( cwork )
639             CALL FFTN( cwork, ishape, inv = .TRUE. )
640
641             DO  i = 0, nx
642                ar(i) = REAL( cwork(i) )
643             ENDDO
644
645          ENDIF
646
647          DEALLOCATE( cwork )
648
649       ELSEIF ( fft_method == 'temperton-algorithm' )  THEN
650
651!
652!--       Performing the fft with Temperton's software works on every system,
653!--       since it is part of the model
654          IF ( forward_fft )  THEN
655
656             work(0:nx) = ar
657             CALL fft991cy( work, work1, trigs_x, ifax_x, 1, nx+1, nx+1, 1, -1 )
658
659             DO  i = 0, (nx+1)/2
660                ar(i) = work(2*i)
661             ENDDO
662             DO  i = 1, (nx+1)/2 - 1
663                ar(nx+1-i) = work(2*i+1)
664             ENDDO
665
666          ELSE
667
668             DO  i = 0, (nx+1)/2
669                work(2*i) = ar(i)
670             ENDDO
671             DO  i = 1, (nx+1)/2 - 1
672                work(2*i+1) = ar(nx+1-i)
673             ENDDO
674             work(1)    = 0.0
675             work(nx+2) = 0.0
676
677             CALL fft991cy( work, work1, trigs_x, ifax_x, 1, nx+1, nx+1, 1, 1 )
678             ar = work(0:nx)
679
680          ENDIF
681
682       ELSEIF ( fft_method == 'system-specific' )  THEN
683
684#if defined( __ibm )  &&  ! defined( __ibmy_special )
685          IF ( forward_fft )  THEN
686
687             CALL DRCFT( 0, ar, 1, work, 1, nx+1, 1, 1, sqr_dnx, aux1, nau1, &
688                         aux2, nau2 )
689
690             DO  i = 0, (nx+1)/2
691                ar(i) = work(2*i)
692             ENDDO
693             DO  i = 1, (nx+1)/2 - 1
694                ar(nx+1-i) = work(2*i+1)
695             ENDDO
696
697          ELSE
698
699             DO  i = 0, (nx+1)/2
700                work(2*i) = ar(i)
701             ENDDO
702             DO  i = 1, (nx+1)/2 - 1
703                work(2*i+1) = ar(nx+1-i)
704             ENDDO
705             work(1) = 0.0
706             work(nx+2) = 0.0
707
708             CALL DCRFT( 0, work, 1, work, 1, nx+1, 1, -1, sqr_dnx, aux3, nau1, &
709                         aux4, nau2 )
710
711             DO  i = 0, nx
712                ar(i) = work(i)
713             ENDDO
714
715          ENDIF
716#elif defined( __nec )
717          IF ( forward_fft )  THEN
718
719             work(0:nx) = ar(0:nx)
720
721             CALL DZFFT( 1, nx+1, sqr_dnx, work, work, trig_xf, work2, 0 )
722     
723             DO  i = 0, (nx+1)/2
724                ar(i) = work(2*i)
725             ENDDO
726             DO  i = 1, (nx+1)/2 - 1
727                ar(nx+1-i) = work(2*i+1)
728             ENDDO
729
730          ELSE
731
732             DO  i = 0, (nx+1)/2
733                work(2*i) = ar(i)
734             ENDDO
735             DO  i = 1, (nx+1)/2 - 1
736                work(2*i+1) = ar(nx+1-i)
737             ENDDO
738             work(1) = 0.0
739             work(nx+2) = 0.0
740
741             CALL ZDFFT( -1, nx+1, sqr_dnx, work, work, trig_xb, work2, 0 )
742
743             ar(0:nx) = work(0:nx)
744
745          ENDIF
746#else
747          message_string = 'no system-specific fft-call available'
748          CALL message( 'fft_x_1d', 'PA0188', 1, 2, 0, 6, 0 )
749#endif
750       ELSE
751          message_string = 'fft method "' // TRIM( fft_method) // &
752                           '" not available'
753          CALL message( 'fft_x_1d', 'PA0189', 1, 2, 0, 6, 0 )
754
755       ENDIF
756
757    END SUBROUTINE fft_x_1d
758
759    SUBROUTINE fft_y( ar, direction )
760
761!----------------------------------------------------------------------!
762!                                 fft_y                                !
763!                                                                      !
764!               Fourier-transformation along y-direction               !
765!                     Version for 2D-decomposition                     !
766!                                                                      !
767!      fft_y uses internal algorithms (Singleton or Temperton) or      !
768!           system-specific routines, if they are available            !
769!----------------------------------------------------------------------!
770
771       USE cuda_fft_interfaces
772
773       IMPLICIT NONE
774
775       CHARACTER (LEN=*) ::  direction
776       INTEGER ::  i, j, jshape(1), k
777
778       LOGICAL ::  forward_fft
779
780       REAL, DIMENSION(0:ny+2)   ::  work
781       REAL, DIMENSION(ny+2)     ::  work1
782       COMPLEX, DIMENSION(:), ALLOCATABLE ::  cwork
783#if defined( __ibm )
784       REAL, DIMENSION(nau2)     ::  auy2, auy4
785#elif defined( __nec )
786       REAL, DIMENSION(6*(ny+1)) ::  work2
787#elif defined( __cuda_fft )
788       !$acc declare create( ar_tmp )
789       COMPLEX(dpk), DIMENSION(0:(ny+1)/2,nxl_y:nxr_y,nzb_y:nzt_y) ::  ar_tmp
790#endif
791       REAL, DIMENSION(0:ny,nxl_y:nxr_y,nzb_y:nzt_y) ::  ar
792
793       IF ( direction == 'forward' )  THEN
794          forward_fft = .TRUE.
795       ELSE
796          forward_fft = .FALSE.
797       ENDIF
798
799       IF ( fft_method == 'singleton-algorithm' )  THEN
800
801!
802!--       Performing the fft with singleton's software works on every system,
803!--       since it is part of the model
804          ALLOCATE( cwork(0:ny) )
805
806          IF ( forward_fft )   then
807
808             !$OMP PARALLEL PRIVATE ( cwork, i, jshape, j, k )
809             !$OMP DO
810             DO  k = nzb_y, nzt_y
811                DO  i = nxl_y, nxr_y
812
813                   DO  j = 0, ny
814                      cwork(j) = CMPLX( ar(j,i,k) )
815                   ENDDO
816
817                   jshape = SHAPE( cwork )
818                   CALL FFTN( cwork, jshape )
819
820                   DO  j = 0, (ny+1)/2
821                      ar(j,i,k) = REAL( cwork(j) )
822                   ENDDO
823                   DO  j = 1, (ny+1)/2 - 1
824                      ar(ny+1-j,i,k) = -AIMAG( cwork(j) )
825                   ENDDO
826
827                ENDDO
828             ENDDO
829             !$OMP END PARALLEL
830
831          ELSE
832
833             !$OMP PARALLEL PRIVATE ( cwork, i, jshape, j, k )
834             !$OMP DO
835             DO  k = nzb_y, nzt_y
836                DO  i = nxl_y, nxr_y
837
838                   cwork(0) = CMPLX( ar(0,i,k), 0.0 )
839                   DO  j = 1, (ny+1)/2 - 1
840                      cwork(j)      = CMPLX( ar(j,i,k), -ar(ny+1-j,i,k) )
841                      cwork(ny+1-j) = CMPLX( ar(j,i,k),  ar(ny+1-j,i,k) )
842                   ENDDO
843                   cwork((ny+1)/2) = CMPLX( ar((ny+1)/2,i,k), 0.0 )
844
845                   jshape = SHAPE( cwork )
846                   CALL FFTN( cwork, jshape, inv = .TRUE. )
847
848                   DO  j = 0, ny
849                      ar(j,i,k) = REAL( cwork(j) )
850                   ENDDO
851
852                ENDDO
853             ENDDO
854             !$OMP END PARALLEL
855
856          ENDIF
857
858          DEALLOCATE( cwork )
859
860       ELSEIF ( fft_method == 'temperton-algorithm' )  THEN
861
862!
863!--       Performing the fft with Temperton's software works on every system,
864!--       since it is part of the model
865          IF ( forward_fft )  THEN
866
867             !$OMP PARALLEL PRIVATE ( work, i, j, k )
868             !$OMP DO
869             DO  k = nzb_y, nzt_y
870                DO  i = nxl_y, nxr_y
871
872                   work(0:ny) = ar(0:ny,i,k)
873                   CALL fft991cy( work, work1, trigs_y, ifax_y, 1, ny+1, ny+1, 1, -1 )
874
875                   DO  j = 0, (ny+1)/2
876                      ar(j,i,k) = work(2*j)
877                   ENDDO
878                   DO  j = 1, (ny+1)/2 - 1
879                      ar(ny+1-j,i,k) = work(2*j+1)
880                   ENDDO
881
882                ENDDO
883             ENDDO
884             !$OMP END PARALLEL
885
886          ELSE
887
888             !$OMP PARALLEL PRIVATE ( work, i, j, k )
889             !$OMP DO
890             DO  k = nzb_y, nzt_y
891                DO  i = nxl_y, nxr_y
892
893                   DO  j = 0, (ny+1)/2
894                      work(2*j) = ar(j,i,k)
895                   ENDDO
896                   DO  j = 1, (ny+1)/2 - 1
897                      work(2*j+1) = ar(ny+1-j,i,k)
898                   ENDDO
899                   work(1)    = 0.0
900                   work(ny+2) = 0.0
901
902                   CALL fft991cy( work, work1, trigs_y, ifax_y, 1, ny+1, ny+1, 1, 1 )
903                   ar(0:ny,i,k) = work(0:ny)
904
905                ENDDO
906             ENDDO
907             !$OMP END PARALLEL
908
909          ENDIF
910
911       ELSEIF ( fft_method == 'system-specific' )  THEN
912
913#if defined( __ibm )  &&  ! defined( __ibmy_special )
914          IF ( forward_fft)  THEN
915
916             !$OMP PARALLEL PRIVATE ( work, i, j, k )
917             !$OMP DO
918             DO  k = nzb_y, nzt_y
919                DO  i = nxl_y, nxr_y
920
921                   CALL DRCFT( 0, ar, 1, work, 1, ny+1, 1, 1, sqr_dny, auy1, nau1, &
922                               auy2, nau2 )
923
924                   DO  j = 0, (ny+1)/2
925                      ar(j,i,k) = work(2*j)
926                   ENDDO
927                   DO  j = 1, (ny+1)/2 - 1
928                      ar(ny+1-j,i,k) = work(2*j+1)
929                   ENDDO
930
931                ENDDO
932             ENDDO
933             !$OMP END PARALLEL
934
935          ELSE
936
937             !$OMP PARALLEL PRIVATE ( work, i, j, k )
938             !$OMP DO
939             DO  k = nzb_y, nzt_y
940                DO  i = nxl_y, nxr_y
941
942                   DO  j = 0, (ny+1)/2
943                      work(2*j) = ar(j,i,k)
944                   ENDDO
945                   DO  j = 1, (ny+1)/2 - 1
946                      work(2*j+1) = ar(ny+1-j,i,k)
947                   ENDDO
948                   work(1)    = 0.0
949                   work(ny+2) = 0.0
950
951                   CALL DCRFT( 0, work, 1, work, 1, ny+1, 1, -1, sqr_dny, auy3, nau1, &
952                               auy4, nau2 )
953
954                   DO  j = 0, ny
955                      ar(j,i,k) = work(j)
956                   ENDDO
957
958                ENDDO
959             ENDDO
960             !$OMP END PARALLEL
961
962          ENDIF
963#elif defined( __nec )
964          IF ( forward_fft )  THEN
965
966             !$OMP PARALLEL PRIVATE ( work, i, j, k )
967             !$OMP DO
968             DO  k = nzb_y, nzt_y
969                DO  i = nxl_y, nxr_y
970
971                   work(0:ny) = ar(0:ny,i,k)
972
973                   CALL DZFFT( 1, ny+1, sqr_dny, work, work, trig_yf, work2, 0 )
974
975                   DO  j = 0, (ny+1)/2
976                      ar(j,i,k) = work(2*j)
977                   ENDDO
978                   DO  j = 1, (ny+1)/2 - 1
979                      ar(ny+1-j,i,k) = work(2*j+1)
980                   ENDDO
981
982                ENDDO
983             ENDDO
984             !$END OMP PARALLEL
985
986          ELSE
987
988             !$OMP PARALLEL PRIVATE ( work, i, j, k )
989             !$OMP DO
990             DO  k = nzb_y, nzt_y
991                DO  i = nxl_y, nxr_y
992
993                   DO  j = 0, (ny+1)/2
994                      work(2*j) = ar(j,i,k)
995                   ENDDO
996                   DO  j = 1, (ny+1)/2 - 1
997                      work(2*j+1) = ar(ny+1-j,i,k)
998                   ENDDO
999                   work(1) = 0.0
1000                   work(ny+2) = 0.0
1001
1002                   CALL ZDFFT( -1, ny+1, sqr_dny, work, work, trig_yb, work2, 0 )
1003
1004                   ar(0:ny,i,k) = work(0:ny)
1005
1006                ENDDO
1007             ENDDO
1008             !$OMP END PARALLEL
1009
1010          ENDIF
1011#elif defined( __cuda_fft )
1012
1013          IF ( forward_fft )  THEN
1014
1015             !$acc data present( ar )
1016             CALL CUFFTEXECD2Z( plan_yf, ar, ar_tmp )
1017
1018             !$acc kernels
1019             !$acc loop
1020             DO  k = nzb_y, nzt_y
1021                DO  i = nxl_y, nxr_y
1022
1023                   !$acc loop vector( 32 )
1024                   DO  j = 0, (ny+1)/2
1025                      ar(j,i,k)      = REAL( ar_tmp(j,i,k) )  * dny
1026                   ENDDO
1027
1028                   !$acc loop vector( 32 )
1029                   DO  j = 1, (ny+1)/2 - 1
1030                      ar(ny+1-j,i,k) = AIMAG( ar_tmp(j,i,k) ) * dny
1031                   ENDDO
1032
1033                ENDDO
1034             ENDDO
1035             !$acc end kernels
1036             !$acc end data
1037
1038          ELSE
1039
1040             !$acc data present( ar )
1041             !$acc kernels
1042             !$acc loop
1043             DO  k = nzb_y, nzt_y
1044                DO  i = nxl_y, nxr_y
1045
1046                   ar_tmp(0,i,k) = CMPLX( ar(0,i,k), 0.0 )
1047
1048                   !$acc loop vector( 32 )
1049                   DO  j = 1, (ny+1)/2 - 1
1050                      ar_tmp(j,i,k) = CMPLX( ar(j,i,k), ar(ny+1-j,i,k) )
1051                   ENDDO
1052                   ar_tmp((ny+1)/2,i,k) = CMPLX( ar((ny+1)/2,i,k), 0.0 )
1053
1054                ENDDO
1055             ENDDO
1056             !$acc end kernels
1057
1058             CALL CUFFTEXECZ2D( plan_yi, ar_tmp, ar )
1059             !$acc end data
1060
1061          ENDIF
1062
1063#else
1064          message_string = 'no system-specific fft-call available'
1065          CALL message( 'fft_y', 'PA0188', 1, 2, 0, 6, 0 ) 
1066#endif
1067
1068       ELSE
1069
1070          message_string = 'fft method "' // TRIM( fft_method) // &
1071                           '" not available'
1072          CALL message( 'fft_y', 'PA0189', 1, 2, 0, 6, 0 )
1073
1074       ENDIF
1075
1076    END SUBROUTINE fft_y
1077
1078    SUBROUTINE fft_y_1d( ar, direction )
1079
1080!----------------------------------------------------------------------!
1081!                               fft_y_1d                               !
1082!                                                                      !
1083!               Fourier-transformation along y-direction               !
1084!                     Version for 1D-decomposition                     !
1085!                                                                      !
1086!      fft_y uses internal algorithms (Singleton or Temperton) or      !
1087!           system-specific routines, if they are available            !
1088!----------------------------------------------------------------------!
1089
1090       IMPLICIT NONE
1091
1092       CHARACTER (LEN=*) ::  direction
1093       INTEGER ::  j, jshape(1)
1094
1095       LOGICAL ::  forward_fft
1096
1097       REAL, DIMENSION(0:ny)     ::  ar
1098       REAL, DIMENSION(0:ny+2)   ::  work
1099       REAL, DIMENSION(ny+2)     ::  work1
1100       COMPLEX, DIMENSION(:), ALLOCATABLE ::  cwork
1101#if defined( __ibm )
1102       REAL, DIMENSION(nau2)     ::  auy2, auy4
1103#elif defined( __nec )
1104       REAL, DIMENSION(6*(ny+1)) ::  work2
1105#endif
1106
1107       IF ( direction == 'forward' )  THEN
1108          forward_fft = .TRUE.
1109       ELSE
1110          forward_fft = .FALSE.
1111       ENDIF
1112
1113       IF ( fft_method == 'singleton-algorithm' )  THEN
1114
1115!
1116!--       Performing the fft with singleton's software works on every system,
1117!--       since it is part of the model
1118          ALLOCATE( cwork(0:ny) )
1119
1120          IF ( forward_fft )  THEN
1121
1122             DO  j = 0, ny
1123                cwork(j) = CMPLX( ar(j) )
1124             ENDDO
1125
1126             jshape = SHAPE( cwork )
1127             CALL FFTN( cwork, jshape )
1128
1129             DO  j = 0, (ny+1)/2
1130                ar(j) = REAL( cwork(j) )
1131             ENDDO
1132             DO  j = 1, (ny+1)/2 - 1
1133                ar(ny+1-j) = -AIMAG( cwork(j) )
1134             ENDDO
1135
1136          ELSE
1137
1138             cwork(0) = CMPLX( ar(0), 0.0 )
1139             DO  j = 1, (ny+1)/2 - 1
1140                cwork(j)      = CMPLX( ar(j), -ar(ny+1-j) )
1141                cwork(ny+1-j) = CMPLX( ar(j),  ar(ny+1-j) )
1142             ENDDO
1143             cwork((ny+1)/2) = CMPLX( ar((ny+1)/2), 0.0 )
1144
1145             jshape = SHAPE( cwork )
1146             CALL FFTN( cwork, jshape, inv = .TRUE. )
1147
1148             DO  j = 0, ny
1149                ar(j) = REAL( cwork(j) )
1150             ENDDO
1151
1152          ENDIF
1153
1154          DEALLOCATE( cwork )
1155
1156       ELSEIF ( fft_method == 'temperton-algorithm' )  THEN
1157
1158!
1159!--       Performing the fft with Temperton's software works on every system,
1160!--       since it is part of the model
1161          IF ( forward_fft )  THEN
1162
1163             work(0:ny) = ar
1164             CALL fft991cy( work, work1, trigs_y, ifax_y, 1, ny+1, ny+1, 1, -1 )
1165
1166             DO  j = 0, (ny+1)/2
1167                ar(j) = work(2*j)
1168             ENDDO
1169             DO  j = 1, (ny+1)/2 - 1
1170                ar(ny+1-j) = work(2*j+1)
1171             ENDDO
1172
1173          ELSE
1174
1175             DO  j = 0, (ny+1)/2
1176                work(2*j) = ar(j)
1177             ENDDO
1178             DO  j = 1, (ny+1)/2 - 1
1179                work(2*j+1) = ar(ny+1-j)
1180             ENDDO
1181             work(1)    = 0.0
1182             work(ny+2) = 0.0
1183
1184             CALL fft991cy( work, work1, trigs_y, ifax_y, 1, ny+1, ny+1, 1, 1 )
1185             ar = work(0:ny)
1186
1187          ENDIF
1188
1189       ELSEIF ( fft_method == 'system-specific' )  THEN
1190
1191#if defined( __ibm )  &&  ! defined( __ibmy_special )
1192          IF ( forward_fft )  THEN
1193
1194             CALL DRCFT( 0, ar, 1, work, 1, ny+1, 1, 1, sqr_dny, auy1, nau1, &
1195                         auy2, nau2 )
1196
1197             DO  j = 0, (ny+1)/2
1198                ar(j) = work(2*j)
1199             ENDDO
1200             DO  j = 1, (ny+1)/2 - 1
1201                ar(ny+1-j) = work(2*j+1)
1202             ENDDO
1203
1204          ELSE
1205
1206             DO  j = 0, (ny+1)/2
1207                work(2*j) = ar(j)
1208             ENDDO
1209             DO  j = 1, (ny+1)/2 - 1
1210                work(2*j+1) = ar(ny+1-j)
1211             ENDDO
1212             work(1)    = 0.0
1213             work(ny+2) = 0.0
1214
1215             CALL DCRFT( 0, work, 1, work, 1, ny+1, 1, -1, sqr_dny, auy3, nau1, &
1216                         auy4, nau2 )
1217
1218             DO  j = 0, ny
1219                ar(j) = work(j)
1220             ENDDO
1221
1222          ENDIF
1223#elif defined( __nec )
1224          IF ( forward_fft )  THEN
1225
1226             work(0:ny) = ar(0:ny)
1227
1228             CALL DZFFT( 1, ny+1, sqr_dny, work, work, trig_yf, work2, 0 )
1229
1230             DO  j = 0, (ny+1)/2
1231                ar(j) = work(2*j)
1232             ENDDO
1233             DO  j = 1, (ny+1)/2 - 1
1234                ar(ny+1-j) = work(2*j+1)
1235             ENDDO
1236
1237          ELSE
1238
1239             DO  j = 0, (ny+1)/2
1240                work(2*j) = ar(j)
1241             ENDDO
1242             DO  j = 1, (ny+1)/2 - 1
1243                work(2*j+1) = ar(ny+1-j)
1244             ENDDO
1245             work(1) = 0.0
1246             work(ny+2) = 0.0
1247
1248             CALL ZDFFT( -1, ny+1, sqr_dny, work, work, trig_yb, work2, 0 )
1249
1250             ar(0:ny) = work(0:ny)
1251
1252          ENDIF
1253#else
1254          message_string = 'no system-specific fft-call available'
1255          CALL message( 'fft_y_1d', 'PA0188', 1, 2, 0, 6, 0 ) 
1256
1257#endif
1258
1259       ELSE
1260
1261          message_string = 'fft method "' // TRIM( fft_method) // &
1262                           '" not available'
1263          CALL message( 'fft_y_1d', 'PA0189', 1, 2, 0, 6, 0 )
1264
1265       ENDIF
1266
1267    END SUBROUTINE fft_y_1d
1268
1269    SUBROUTINE fft_x_m( ar, direction )
1270
1271!----------------------------------------------------------------------!
1272!                               fft_x_m                                !
1273!                                                                      !
1274!               Fourier-transformation along x-direction               !
1275!                 Version for 1d domain decomposition                  !
1276!             using multiple 1D FFT from Math Keisan on NEC            !
1277!                       or Temperton-algorithm                         !
1278!       (no singleton-algorithm on NEC because it does not vectorize)  !
1279!                                                                      !
1280!----------------------------------------------------------------------!
1281
1282       IMPLICIT NONE
1283
1284       CHARACTER (LEN=*)              ::  direction
1285       INTEGER                        ::  i, k, siza
1286
1287       REAL, DIMENSION(0:nx,nz)       ::  ar
1288       REAL, DIMENSION(0:nx+3,nz+1)   ::  ai
1289       REAL, DIMENSION(6*(nx+4),nz+1) ::  work1
1290#if defined( __nec )
1291       INTEGER                             ::  sizw
1292       COMPLEX, DIMENSION((nx+4)/2+1,nz+1) ::  work
1293#endif
1294
1295       IF ( fft_method == 'temperton-algorithm' )  THEN
1296
1297          siza = SIZE( ai, 1 )
1298
1299          IF ( direction == 'forward')  THEN
1300
1301             ai(0:nx,1:nz) = ar(0:nx,1:nz)
1302             ai(nx+1:,:)   = 0.0
1303
1304             CALL fft991cy( ai, work1, trigs_x, ifax_x, 1, siza, nx+1, nz, -1 )
1305
1306             DO  k = 1, nz
1307                DO  i = 0, (nx+1)/2
1308                   ar(i,k) = ai(2*i,k)
1309                ENDDO
1310                DO  i = 1, (nx+1)/2 - 1
1311                   ar(nx+1-i,k) = ai(2*i+1,k)
1312                ENDDO
1313             ENDDO
1314
1315          ELSE
1316
1317             DO  k = 1, nz
1318                DO  i = 0, (nx+1)/2
1319                   ai(2*i,k) = ar(i,k)
1320                ENDDO
1321                DO  i = 1, (nx+1)/2 - 1
1322                   ai(2*i+1,k) = ar(nx+1-i,k)
1323                ENDDO
1324                ai(1,k) = 0.0
1325                ai(nx+2,k) = 0.0
1326             ENDDO
1327
1328             CALL fft991cy( ai, work1, trigs_x, ifax_x, 1, siza, nx+1, nz, 1 )
1329
1330             ar(0:nx,1:nz) = ai(0:nx,1:nz)
1331
1332          ENDIF
1333
1334       ELSEIF ( fft_method == 'system-specific' )  THEN
1335
1336#if defined( __nec )
1337          siza = SIZE( ai, 1 )
1338          sizw = SIZE( work, 1 )
1339
1340          IF ( direction == 'forward')  THEN
1341
1342!
1343!--          Tables are initialized once more. This call should not be
1344!--          necessary, but otherwise program aborts in asymmetric case
1345             CALL DZFFTM( 0, nx+1, nz1, sqr_dnx, work, nx+4, work, nx+4, &
1346                          trig_xf, work1, 0 )
1347
1348             ai(0:nx,1:nz) = ar(0:nx,1:nz)
1349             IF ( nz1 > nz )  THEN
1350                ai(:,nz1) = 0.0
1351             ENDIF
1352
1353             CALL DZFFTM( 1, nx+1, nz1, sqr_dnx, ai, siza, work, sizw, &
1354                          trig_xf, work1, 0 )
1355
1356             DO  k = 1, nz
1357                DO  i = 0, (nx+1)/2
1358                   ar(i,k) = REAL( work(i+1,k) )
1359                ENDDO
1360                DO  i = 1, (nx+1)/2 - 1
1361                   ar(nx+1-i,k) = AIMAG( work(i+1,k) )
1362                ENDDO
1363             ENDDO
1364
1365          ELSE
1366
1367!
1368!--          Tables are initialized once more. This call should not be
1369!--          necessary, but otherwise program aborts in asymmetric case
1370             CALL ZDFFTM( 0, nx+1, nz1, sqr_dnx, work, nx+4, work, nx+4, &
1371                          trig_xb, work1, 0 )
1372
1373             IF ( nz1 > nz )  THEN
1374                work(:,nz1) = 0.0
1375             ENDIF
1376             DO  k = 1, nz
1377                work(1,k) = CMPLX( ar(0,k), 0.0 )
1378                DO  i = 1, (nx+1)/2 - 1
1379                   work(i+1,k) = CMPLX( ar(i,k), ar(nx+1-i,k) )
1380                ENDDO
1381                work(((nx+1)/2)+1,k) = CMPLX( ar((nx+1)/2,k), 0.0 )
1382             ENDDO
1383
1384             CALL ZDFFTM( -1, nx+1, nz1, sqr_dnx, work, sizw, ai, siza, &
1385                          trig_xb, work1, 0 )
1386
1387             ar(0:nx,1:nz) = ai(0:nx,1:nz)
1388
1389          ENDIF
1390
1391#else
1392          message_string = 'no system-specific fft-call available'
1393          CALL message( 'fft_x_m', 'PA0188', 1, 2, 0, 6, 0 ) 
1394#endif
1395
1396       ELSE
1397
1398          message_string = 'fft method "' // TRIM( fft_method) // &
1399                           '" not available'
1400          CALL message( 'fft_x_m', 'PA0189', 1, 2, 0, 6, 0 )
1401
1402       ENDIF
1403
1404    END SUBROUTINE fft_x_m
1405
1406    SUBROUTINE fft_y_m( ar, ny1, direction )
1407
1408!----------------------------------------------------------------------!
1409!                               fft_y_m                                !
1410!                                                                      !
1411!               Fourier-transformation along y-direction               !
1412!                 Version for 1d domain decomposition                  !
1413!             using multiple 1D FFT from Math Keisan on NEC            !
1414!                       or Temperton-algorithm                         !
1415!       (no singleton-algorithm on NEC because it does not vectorize)  !
1416!                                                                      !
1417!----------------------------------------------------------------------!
1418
1419       IMPLICIT NONE
1420
1421       CHARACTER (LEN=*)              ::  direction
1422       INTEGER                        ::  j, k, ny1, siza
1423
1424       REAL, DIMENSION(0:ny1,nz)      ::  ar
1425       REAL, DIMENSION(0:ny+3,nz+1)   ::  ai
1426       REAL, DIMENSION(6*(ny+4),nz+1) ::  work1
1427#if defined( __nec )
1428       INTEGER                             ::  sizw
1429       COMPLEX, DIMENSION((ny+4)/2+1,nz+1) ::  work
1430#endif
1431
1432       IF ( fft_method == 'temperton-algorithm' )  THEN
1433
1434          siza = SIZE( ai, 1 )
1435
1436          IF ( direction == 'forward')  THEN
1437
1438             ai(0:ny,1:nz) = ar(0:ny,1:nz)
1439             ai(ny+1:,:)   = 0.0
1440
1441             CALL fft991cy( ai, work1, trigs_y, ifax_y, 1, siza, ny+1, nz, -1 )
1442
1443             DO  k = 1, nz
1444                DO  j = 0, (ny+1)/2
1445                   ar(j,k) = ai(2*j,k)
1446                ENDDO
1447                DO  j = 1, (ny+1)/2 - 1
1448                   ar(ny+1-j,k) = ai(2*j+1,k)
1449                ENDDO
1450             ENDDO
1451
1452          ELSE
1453
1454             DO  k = 1, nz
1455                DO  j = 0, (ny+1)/2
1456                   ai(2*j,k) = ar(j,k)
1457                ENDDO
1458                DO  j = 1, (ny+1)/2 - 1
1459                   ai(2*j+1,k) = ar(ny+1-j,k)
1460                ENDDO
1461                ai(1,k) = 0.0
1462                ai(ny+2,k) = 0.0
1463             ENDDO
1464
1465             CALL fft991cy( ai, work1, trigs_y, ifax_y, 1, siza, ny+1, nz, 1 )
1466
1467             ar(0:ny,1:nz) = ai(0:ny,1:nz)
1468
1469          ENDIF
1470
1471       ELSEIF ( fft_method == 'system-specific' )  THEN
1472
1473#if defined( __nec )
1474          siza = SIZE( ai, 1 )
1475          sizw = SIZE( work, 1 )
1476
1477          IF ( direction == 'forward')  THEN
1478
1479!
1480!--          Tables are initialized once more. This call should not be
1481!--          necessary, but otherwise program aborts in asymmetric case
1482             CALL DZFFTM( 0, ny+1, nz1, sqr_dny, work, ny+4, work, ny+4, &
1483                          trig_yf, work1, 0 )
1484
1485             ai(0:ny,1:nz) = ar(0:ny,1:nz)
1486             IF ( nz1 > nz )  THEN
1487                ai(:,nz1) = 0.0
1488             ENDIF
1489
1490             CALL DZFFTM( 1, ny+1, nz1, sqr_dny, ai, siza, work, sizw, &
1491                          trig_yf, work1, 0 )
1492
1493             DO  k = 1, nz
1494                DO  j = 0, (ny+1)/2
1495                   ar(j,k) = REAL( work(j+1,k) )
1496                ENDDO
1497                DO  j = 1, (ny+1)/2 - 1
1498                   ar(ny+1-j,k) = AIMAG( work(j+1,k) )
1499                ENDDO
1500             ENDDO
1501
1502          ELSE
1503
1504!
1505!--          Tables are initialized once more. This call should not be
1506!--          necessary, but otherwise program aborts in asymmetric case
1507             CALL ZDFFTM( 0, ny+1, nz1, sqr_dny, work, ny+4, work, ny+4, &
1508                          trig_yb, work1, 0 )
1509
1510             IF ( nz1 > nz )  THEN
1511                work(:,nz1) = 0.0
1512             ENDIF
1513             DO  k = 1, nz
1514                work(1,k) = CMPLX( ar(0,k), 0.0 )
1515                DO  j = 1, (ny+1)/2 - 1
1516                   work(j+1,k) = CMPLX( ar(j,k), ar(ny+1-j,k) )
1517                ENDDO
1518                work(((ny+1)/2)+1,k) = CMPLX( ar((ny+1)/2,k), 0.0 )
1519             ENDDO
1520
1521             CALL ZDFFTM( -1, ny+1, nz1, sqr_dny, work, sizw, ai, siza, &
1522                          trig_yb, work1, 0 )
1523
1524             ar(0:ny,1:nz) = ai(0:ny,1:nz)
1525
1526          ENDIF
1527
1528#else
1529          message_string = 'no system-specific fft-call available'
1530          CALL message( 'fft_y_m', 'PA0188', 1, 2, 0, 6, 0 ) 
1531#endif
1532
1533       ELSE
1534         
1535          message_string = 'fft method "' // TRIM( fft_method) // &
1536                           '" not available'
1537          CALL message( 'fft_x_m', 'PA0189', 1, 2, 0, 6, 0 )
1538
1539       ENDIF
1540
1541    END SUBROUTINE fft_y_m
1542
1543
1544 END MODULE fft_xy
Note: See TracBrowser for help on using the repository browser.