source: palm/trunk/SOURCE/poisfft.f90 @ 1321

Last change on this file since 1321 was 1321, checked in by raasch, 7 years ago

last commit documented

  • Property svn:keywords set to Id
File size: 44.8 KB
Line 
1 MODULE poisfft_mod
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-2014  Leibniz Universitaet Hannover
18!--------------------------------------------------------------------------------!
19!
20! Current revisions:
21! -----------------
22!
23!
24! Former revisions:
25! -----------------
26! $Id: poisfft.f90 1321 2014-03-20 09:40:40Z raasch $
27!
28! 1320 2014-03-20 08:40:49Z raasch
29! ONLY-attribute added to USE-statements,
30! kind-parameters added to all INTEGER and REAL declaration statements,
31! kinds are defined in new module kinds,
32! old module precision_kind is removed,
33! revision history before 2012 removed,
34! comment fields (!:) to be used for variable explanations added to
35! all variable declaration statements
36!
37! 1318 2014-03-17 13:35:16Z raasch
38! module interfaces removed
39!
40! 1306 2014-03-13 14:30:59Z raasch
41! openmp sections removed from the overlap branch,
42! second argument removed from parameter list
43!
44! 1216 2013-08-26 09:31:42Z raasch
45! resorting of arrays moved to separate routines resort_for_...,
46! one argument, used as temporary work array, removed from all transpose
47! routines
48! overlapping fft / transposition implemented
49!
50! 1212 2013-08-15 08:46:27Z raasch
51! tridia routines moved to seperate module tridia_solver
52!
53! 1208 2013-08-13 06:41:49Z raasch
54! acc-update clauses added for "ar" so that ffts other than cufft can also be
55! used (although they are not ported and will give a poor performance)
56!
57! 1111 2013-03-08 23:54:10Z raasch
58! further openACC porting of non-parallel (MPI) branch:
59! tridiagonal routines split into extermal subroutines (instead using CONTAINS),
60! no distinction between parallel/non-parallel in poisfft and tridia any more,
61! tridia routines moved to end of file because of probable bug in PGI compiler 12.5
62! (otherwise "invalid device function" is indicated during runtime),
63! optimization of tridia routines: constant elements and coefficients of tri are
64! stored in seperate arrays ddzuw and tric, last dimension of tri reduced from 5
65! to 2,
66! poisfft_init is now called internally from poisfft, maketri is called from
67! poisfft_init,
68! ibc_p_b = 2 removed
69!
70! 1106 2013-03-04 05:31:38Z raasch
71! routines fftx, ffty, fftxp, fftyp removed, calls replaced by fft_x, fft_y,
72! in the 1D-decomposition routines fft_x, ffty are replaced by fft_x_1d,
73! fft_y_1d
74!
75! 1103 2013-02-20 02:15:53Z raasch
76! tri, ar, and ar1 arguments in tridia-routines (2d) are removed because they
77! sometimes cause segmentation faults with intel 12.1 compiler
78!
79! 1092 2013-02-02 11:24:22Z raasch
80! unused variables removed
81!
82! 1036 2012-10-22 13:43:42Z raasch
83! code put under GPL (PALM 3.9)
84!
85! 2012-09-21 07:03:55Z raasch
86! FLOAT type conversion replaced by REAL
87!
88! 1003 2012-09-14 14:35:53Z raasch
89! indices nxa, nya, etc. replaced by nx, ny, etc.
90!
91! 940 2012-07-09 14:31:00Z raasch
92! special handling of tri-array as an argument in tridia_1dd routines switched
93! off because it caused segmentation faults with intel 12.1 compiler
94!
95! 877 2012-04-03 11:21:44Z suehring
96! Bugfix: Avoid divisions by zero in case of using a 'neumann' bc for the
97! pressure at the top of the model domain.
98!
99! 809 2012-01-30 13:32:58Z maronga
100! Bugfix: replaced .AND. and .NOT. with && and ! in the preprocessor directives
101!
102! 807 2012-01-25 11:53:51Z maronga
103! New cpp directive "__check" implemented which is used by check_namelist_files
104! (most of the code is unneeded by check_namelist_files).
105!
106! Revision 1.1  1997/07/24 11:24:14  raasch
107! Initial revision
108!
109!
110! Description:
111! ------------
112! Original version by Stephan Siano (pois3d), as of July 23, 1996
113! Adapted for 2D-domain-decomposition by Siegfried Raasch, July 3, 1997
114!
115! Solves the Poisson equation with a 2D spectral method
116!        d^2 p / dx^2 + d^2 p / dy^2 + d^2 p / dz^2 = s
117!
118! Input:
119! real    ar   contains (nnz,nny,nnx) elements of the velocity divergence,
120!              starting from (1,nys,nxl)
121!
122! Output:
123! real    ar   contains the solution for perturbation pressure p
124!------------------------------------------------------------------------------!
125
126    USE fft_xy,                                                                &
127        ONLY:  fft_init, fft_y, fft_y_1d, fft_y_m, fft_x, fft_x_1d, fft_x_m
128
129    USE indices,                                                               &
130        ONLY:  nnx, nny, nx, nxl, nxr, ny, nys, nyn, nz
131
132    USE transpose_indices,                                                     &
133        ONLY:  nxl_y, nxl_z, nxr_y, nxr_z, nys_x, nys_z, nyn_x, nyn_z, nzb_x,  &
134               nzb_y, nzt_x, nzt_y
135
136    USE tridia_solver,                                                         &
137        ONLY:  tridia_1dd, tridia_init, tridia_substi, tridia_substi_overlap
138
139    IMPLICIT NONE
140
141    LOGICAL, SAVE ::  poisfft_initialized = .FALSE.
142
143    PRIVATE
144
145#if ! defined ( __check )
146    PUBLIC  poisfft, poisfft_init
147
148    INTERFACE poisfft
149       MODULE PROCEDURE poisfft
150    END INTERFACE poisfft
151
152    INTERFACE poisfft_init
153       MODULE PROCEDURE poisfft_init
154    END INTERFACE poisfft_init
155#else
156    PUBLIC  poisfft_init
157
158    INTERFACE poisfft_init
159       MODULE PROCEDURE poisfft_init
160    END INTERFACE poisfft_init
161#endif
162
163 CONTAINS
164
165    SUBROUTINE poisfft_init
166
167       USE arrays_3d,                                                          &
168           ONLY:  ddzu_pres, ddzw
169
170       USE kinds
171
172       IMPLICIT NONE
173
174       INTEGER(iwp) ::  k  !:
175
176
177       CALL fft_init
178
179       CALL tridia_init
180
181       poisfft_initialized = .TRUE.
182
183    END SUBROUTINE poisfft_init
184
185
186#if ! defined ( __check )
187    SUBROUTINE poisfft( ar )
188
189       USE control_parameters,                                                 &
190           ONLY:  fft_method, transpose_compute_overlap
191
192       USE cpulog,                                                             &
193           ONLY:  cpu_log, cpu_log_nowait, log_point_s
194
195       USE kinds
196
197       USE pegrid
198
199       IMPLICIT NONE
200
201       INTEGER(iwp) ::  ii           !:
202       INTEGER(iwp) ::  iind         !:
203       INTEGER(iwp) ::  inew         !:
204       INTEGER(iwp) ::  jj           !:
205       INTEGER(iwp) ::  jind         !:
206       INTEGER(iwp) ::  jnew         !:
207       INTEGER(iwp) ::  ki           !:
208       INTEGER(iwp) ::  kk           !:
209       INTEGER(iwp) ::  knew         !:
210       INTEGER(iwp) ::  n            !:
211       INTEGER(iwp) ::  nblk         !:
212       INTEGER(iwp) ::  nnx_y        !:
213       INTEGER(iwp) ::  nny_z        !:
214       INTEGER(iwp) ::  nnz_t        !:
215       INTEGER(iwp) ::  nnz_x        !:
216       INTEGER(iwp) ::  nxl_y_bound  !:
217       INTEGER(iwp) ::  nxr_y_bound  !:
218
219       INTEGER(iwp), DIMENSION(4) ::  isave  !:
220
221       REAL(wp), DIMENSION(1:nz,nys:nyn,nxl:nxr) ::  ar      !:
222       !$acc declare create( ar_inv )
223       REAL(wp), DIMENSION(nys:nyn,nxl:nxr,1:nz) ::  ar_inv  !:
224
225       REAL(wp), DIMENSION(:,:,:),   ALLOCATABLE ::  ar1      !:
226       REAL(wp), DIMENSION(:,:,:),   ALLOCATABLE ::  f_in     !:
227       REAL(wp), DIMENSION(:,:,:),   ALLOCATABLE ::  f_inv    !:
228       REAL(wp), DIMENSION(:,:,:),   ALLOCATABLE ::  f_out_y  !:
229       REAL(wp), DIMENSION(:,:,:),   ALLOCATABLE ::  f_out_z  !:
230
231
232       CALL cpu_log( log_point_s(3), 'poisfft', 'start' )
233
234       IF ( .NOT. poisfft_initialized )  CALL poisfft_init
235
236!
237!--    Two-dimensional Fourier Transformation in x- and y-direction.
238       IF ( pdims(2) == 1  .AND.  pdims(1) > 1 )  THEN
239
240!
241!--       1d-domain-decomposition along x:
242!--       FFT along y and transposition y --> x
243          CALL ffty_tr_yx( ar, ar )
244
245!
246!--       FFT along x, solving the tridiagonal system and backward FFT
247          CALL fftx_tri_fftx( ar )
248
249!
250!--       Transposition x --> y and backward FFT along y
251          CALL tr_xy_ffty( ar, ar )
252
253       ELSEIF ( pdims(1) == 1  .AND.  pdims(2) > 1 )  THEN
254
255!
256!--       1d-domain-decomposition along y:
257!--       FFT along x and transposition x --> y
258          CALL fftx_tr_xy( ar, ar )
259
260!
261!--       FFT along y, solving the tridiagonal system and backward FFT
262          CALL ffty_tri_ffty( ar )
263
264!
265!--       Transposition y --> x and backward FFT along x
266          CALL tr_yx_fftx( ar, ar )
267
268       ELSEIF ( .NOT. transpose_compute_overlap )  THEN
269
270!
271!--       2d-domain-decomposition or no decomposition (1 PE run)
272!--       Transposition z --> x
273          CALL cpu_log( log_point_s(5), 'transpo forward', 'start' )
274          CALL resort_for_zx( ar, ar_inv )
275          CALL transpose_zx( ar_inv, ar )
276          CALL cpu_log( log_point_s(5), 'transpo forward', 'pause' )
277
278          CALL cpu_log( log_point_s(4), 'fft_x', 'start' )
279          IF ( fft_method /= 'system-specific' )  THEN
280             !$acc update host( ar )
281          ENDIF
282          CALL fft_x( ar, 'forward' )
283          IF ( fft_method /= 'system-specific' )  THEN
284             !$acc update device( ar )
285          ENDIF
286          CALL cpu_log( log_point_s(4), 'fft_x', 'pause' )
287
288!
289!--       Transposition x --> y
290          CALL cpu_log( log_point_s(5), 'transpo forward', 'continue' )
291          CALL resort_for_xy( ar, ar_inv )
292          CALL transpose_xy( ar_inv, ar )
293          CALL cpu_log( log_point_s(5), 'transpo forward', 'pause' )
294
295          CALL cpu_log( log_point_s(7), 'fft_y', 'start' )
296          IF ( fft_method /= 'system-specific' )  THEN
297             !$acc update host( ar )
298          ENDIF
299          CALL fft_y( ar, 'forward', ar_tr = ar,                &
300                      nxl_y_bound = nxl_y, nxr_y_bound = nxr_y, &
301                      nxl_y_l = nxl_y, nxr_y_l = nxr_y )
302          IF ( fft_method /= 'system-specific' )  THEN
303             !$acc update device( ar )
304          ENDIF
305          CALL cpu_log( log_point_s(7), 'fft_y', 'pause' )
306
307!
308!--       Transposition y --> z
309          CALL cpu_log( log_point_s(5), 'transpo forward', 'continue' )
310          CALL resort_for_yz( ar, ar_inv )
311          CALL transpose_yz( ar_inv, ar )
312          CALL cpu_log( log_point_s(5), 'transpo forward', 'stop' )
313
314!
315!--       Solve the tridiagonal equation system along z
316          CALL cpu_log( log_point_s(6), 'tridia', 'start' )
317          CALL tridia_substi( ar )
318          CALL cpu_log( log_point_s(6), 'tridia', 'stop' )
319
320!
321!--       Inverse Fourier Transformation
322!--       Transposition z --> y
323          CALL cpu_log( log_point_s(8), 'transpo invers', 'start' )
324          CALL transpose_zy( ar, ar_inv )
325          CALL resort_for_zy( ar_inv, ar )
326          CALL cpu_log( log_point_s(8), 'transpo invers', 'pause' )
327
328          CALL cpu_log( log_point_s(7), 'fft_y', 'continue' )
329          IF ( fft_method /= 'system-specific' )  THEN
330             !$acc update host( ar )
331          ENDIF
332          CALL fft_y( ar, 'backward', ar_tr = ar,               &
333                      nxl_y_bound = nxl_y, nxr_y_bound = nxr_y, &
334                      nxl_y_l = nxl_y, nxr_y_l = nxr_y )
335          IF ( fft_method /= 'system-specific' )  THEN
336             !$acc update device( ar )
337          ENDIF
338          CALL cpu_log( log_point_s(7), 'fft_y', 'stop' )
339
340!
341!--       Transposition y --> x
342          CALL cpu_log( log_point_s(8), 'transpo invers', 'continue' )
343          CALL transpose_yx( ar, ar_inv )
344          CALL resort_for_yx( ar_inv, ar )
345          CALL cpu_log( log_point_s(8), 'transpo invers', 'pause' )
346
347          CALL cpu_log( log_point_s(4), 'fft_x', 'continue' )
348          IF ( fft_method /= 'system-specific' )  THEN
349             !$acc update host( ar )
350          ENDIF
351          CALL fft_x( ar, 'backward' )
352          IF ( fft_method /= 'system-specific' )  THEN
353             !$acc update device( ar )
354          ENDIF
355          CALL cpu_log( log_point_s(4), 'fft_x', 'stop' )
356
357!
358!--       Transposition x --> z
359          CALL cpu_log( log_point_s(8), 'transpo invers', 'continue' )
360          CALL transpose_xz( ar, ar_inv )
361          CALL resort_for_xz( ar_inv, ar )
362          CALL cpu_log( log_point_s(8), 'transpo invers', 'stop' )
363
364       ELSE
365
366!
367!--       2d-domain-decomposition or no decomposition (1 PE run) with
368!--       overlapping transposition / fft
369!--       cputime logging must not use barriers, which would prevent overlapping
370          ALLOCATE( f_out_y(0:ny,nxl_y:nxr_y,nzb_y:nzt_y), &
371                    f_out_z(0:nx,nys_x:nyn_x,nzb_x:nzt_x) )
372!
373!--       Transposition z --> x + subsequent fft along x
374          ALLOCATE( f_inv(nys:nyn,nxl:nxr,1:nz) )
375          CALL resort_for_zx( ar, f_inv )
376!
377!--       Save original indices and gridpoint counter
378          isave(1) = nz
379          isave(2) = nzb_x
380          isave(3) = nzt_x
381          isave(4) = sendrecvcount_zx
382!
383!--       Set new indices for transformation
384          nblk  = nz / pdims(1)
385          nz    = pdims(1)
386          nnz_x = 1
387          nzb_x = 1 + myidx * nnz_x
388          nzt_x = ( myidx + 1 ) * nnz_x
389          sendrecvcount_zx = nnx * nny * nnz_x
390
391          ALLOCATE( ar1(0:nx,nys_x:nyn_x,nzb_x:nzt_x) )
392          ALLOCATE( f_in(nys:nyn,nxl:nxr,1:nz) )
393
394          DO  kk = 1, nblk
395
396             IF ( kk == 1 )  THEN
397                CALL cpu_log( log_point_s(5), 'transpo forward', 'start', cpu_log_nowait )
398             ELSE
399                CALL cpu_log( log_point_s(5), 'transpo forward', 'continue', cpu_log_nowait )
400             ENDIF
401
402             DO  knew = 1, nz
403                ki = kk + nblk * ( knew - 1 )
404                f_in(:,:,knew) = f_inv(:,:,ki)
405             ENDDO
406
407             CALL transpose_zx( f_in, ar1(:,:,:))
408             CALL cpu_log( log_point_s(5), 'transpo forward', 'pause' )
409
410             IF ( kk == 1 )  THEN
411                CALL cpu_log( log_point_s(4), 'fft_x', 'start', cpu_log_nowait )
412             ELSE
413                CALL cpu_log( log_point_s(4), 'fft_x', 'continue', cpu_log_nowait )
414             ENDIF
415
416             n = isave(2) + kk - 1
417             CALL fft_x( ar1(:,:,:), 'forward',  ar_2d = f_out_z(:,:,n))
418             CALL cpu_log( log_point_s(4), 'fft_x', 'pause' )
419
420          ENDDO
421!
422!--       Restore original indices/counters
423          nz               = isave(1)
424          nzb_x            = isave(2)
425          nzt_x            = isave(3)
426          sendrecvcount_zx = isave(4)
427
428          DEALLOCATE( ar1, f_in, f_inv )
429
430!
431!--       Transposition x --> y + subsequent fft along y
432          ALLOCATE( f_inv(nys_x:nyn_x,nzb_x:nzt_x,0:nx) )
433          CALL resort_for_xy( f_out_z, f_inv )
434!
435!--       Save original indices and gridpoint counter
436          isave(1) = nx
437          isave(2) = nxl_y
438          isave(3) = nxr_y
439          isave(4) = sendrecvcount_xy
440!
441!--       Set new indices for transformation
442          nblk  = ( ( nx+1 ) / pdims(2) ) - 1
443          nx    = pdims(2)
444          nnx_y = 1
445          nxl_y = myidy * nnx_y
446          nxr_y = ( myidy + 1 ) * nnx_y - 1
447          sendrecvcount_xy = nnx_y * ( nyn_x-nys_x+1 ) * ( nzt_x-nzb_x+1 )
448
449          ALLOCATE( ar1(0:ny,nxl_y:nxr_y,nzb_y:nzt_y) )
450          ALLOCATE( f_in(nys_x:nyn_x,nzb_x:nzt_x,0:nx) )
451
452          DO  ii = 0, nblk
453
454             CALL cpu_log( log_point_s(5), 'transpo forward', 'continue', cpu_log_nowait )
455
456             DO  inew = 0, nx-1
457                iind = ii + ( nblk + 1 ) * inew
458                f_in(:,:,inew) = f_inv(:,:,iind)
459             ENDDO
460
461             CALL transpose_xy( f_in, ar1(:,:,:) )
462
463             CALL cpu_log( log_point_s(5), 'transpo forward', 'pause' )
464
465             IF ( ii == 1 )  THEN
466                CALL cpu_log( log_point_s(7), 'fft_y', 'start', cpu_log_nowait )
467             ELSE
468                CALL cpu_log( log_point_s(7), 'fft_y', 'continue', cpu_log_nowait )
469             ENDIF
470
471             nxl_y_bound = isave(2)
472             nxr_y_bound = isave(3)
473             n           = isave(2) + ii
474             CALL fft_y( ar1(:,:,:), 'forward', ar_tr = f_out_y,               &
475                         nxl_y_bound = nxl_y_bound, nxr_y_bound = nxr_y_bound, &
476                         nxl_y_l = n, nxr_y_l = n )
477
478             CALL cpu_log( log_point_s(7), 'fft_y', 'pause' )
479
480          ENDDO
481!
482!--       Restore original indices/counters
483          nx               = isave(1)
484          nxl_y            = isave(2)
485          nxr_y            = isave(3)
486          sendrecvcount_xy = isave(4)
487
488          DEALLOCATE( ar1, f_in, f_inv )
489
490!
491!--       Transposition y --> z + subsequent tridia + resort for z --> y
492          ALLOCATE( f_inv(nxl_y:nxr_y,nzb_y:nzt_y,0:ny) )
493          CALL resort_for_yz( f_out_y, f_inv )
494!
495!--       Save original indices and gridpoint counter
496          isave(1) = ny
497          isave(2) = nys_z
498          isave(3) = nyn_z
499          isave(4) = sendrecvcount_yz
500!
501!--       Set new indices for transformation
502          nblk             = ( ( ny+1 ) / pdims(1) ) - 1
503          ny               = pdims(1)
504          nny_z            = 1
505          nys_z            = myidx * nny_z
506          nyn_z            = ( myidx + 1 ) * nny_z - 1
507          sendrecvcount_yz = ( nxr_y-nxl_y+1 ) * nny_z * ( nzt_y-nzb_y+1 )
508
509          ALLOCATE( ar1(nxl_z:nxr_z,nys_z:nyn_z,1:nz) )
510          ALLOCATE( f_in(nxl_y:nxr_y,nzb_y:nzt_y,0:ny) )
511
512          DO  jj = 0, nblk
513!
514!--          Forward Fourier Transformation
515!--          Transposition y --> z
516             CALL cpu_log( log_point_s(5), 'transpo forward', 'continue', cpu_log_nowait )
517
518             DO  jnew = 0, ny-1
519                jind = jj + ( nblk + 1 ) * jnew
520                f_in(:,:,jnew) = f_inv(:,:,jind)
521             ENDDO
522
523             CALL transpose_yz( f_in, ar1(:,:,:) )
524
525             IF ( jj == nblk )  THEN
526                CALL cpu_log( log_point_s(5), 'transpo forward', 'stop' )
527             ELSE
528                CALL cpu_log( log_point_s(5), 'transpo forward', 'pause' )
529             ENDIF
530
531!
532!--          Solve the tridiagonal equation system along z
533             CALL cpu_log( log_point_s(6), 'tridia', 'start', cpu_log_nowait )
534
535             n = isave(2) + jj
536             CALL tridia_substi_overlap( ar1(:,:,:), n )
537
538             CALL cpu_log( log_point_s(6), 'tridia', 'stop' )
539
540!
541!--          Inverse Fourier Transformation
542!--          Transposition z --> y
543!--          Only one thread should call MPI routines, therefore forward and
544!--          backward tranpose are in the same section
545             IF ( jj == 0 )  THEN
546                CALL cpu_log( log_point_s(8), 'transpo invers', 'start', cpu_log_nowait )
547             ELSE
548                CALL cpu_log( log_point_s(8), 'transpo invers', 'continue', cpu_log_nowait )
549             ENDIF
550
551             CALL transpose_zy( ar1(:,:,:), f_in )
552
553             DO  jnew = 0, ny-1
554                jind = jj + ( nblk + 1 ) * jnew
555                f_inv(:,:,jind) = f_in(:,:,jnew)
556             ENDDO
557
558             CALL cpu_log( log_point_s(8), 'transpo invers', 'pause' )
559
560          ENDDO
561!
562!--       Restore original indices/counters
563          ny               = isave(1)
564          nys_z            = isave(2)
565          nyn_z            = isave(3)
566          sendrecvcount_yz = isave(4)
567
568          CALL resort_for_zy( f_inv, f_out_y )
569
570          DEALLOCATE( ar1, f_in, f_inv )
571
572!
573!--       fft along y backward + subsequent transposition y --> x
574          ALLOCATE( f_inv(nys_x:nyn_x,nzb_x:nzt_x,0:nx) )
575!
576!--       Save original indices and gridpoint counter
577          isave(1) = nx
578          isave(2) = nxl_y
579          isave(3) = nxr_y
580          isave(4) = sendrecvcount_xy
581!
582!--       Set new indices for transformation
583          nblk             = (( nx+1 ) / pdims(2) ) - 1
584          nx               = pdims(2)
585          nnx_y            = 1
586          nxl_y            = myidy * nnx_y
587          nxr_y            = ( myidy + 1 ) * nnx_y - 1
588          sendrecvcount_xy = nnx_y * ( nyn_x-nys_x+1 ) * ( nzt_x-nzb_x+1 )
589
590          ALLOCATE( ar1(0:ny,nxl_y:nxr_y,nzb_y:nzt_y) )
591          ALLOCATE( f_in(nys_x:nyn_x,nzb_x:nzt_x,0:nx) )
592
593          DO  ii = 0, nblk
594
595             CALL cpu_log( log_point_s(7), 'fft_y', 'continue', cpu_log_nowait )
596
597             n = isave(2) + ii
598             nxl_y_bound = isave(2)
599             nxr_y_bound = isave(3)
600
601             CALL fft_y( ar1(:,:,:), 'backward', ar_tr = f_out_y,              &
602                         nxl_y_bound = nxl_y_bound, nxr_y_bound = nxr_y_bound, &
603                         nxl_y_l = n, nxr_y_l = n )
604
605             IF ( ii == nblk )  THEN
606                CALL cpu_log( log_point_s(7), 'fft_y', 'stop' )
607             ELSE
608                CALL cpu_log( log_point_s(7), 'fft_y', 'pause' )
609             ENDIF
610
611             CALL cpu_log( log_point_s(8), 'transpo invers', 'continue', cpu_log_nowait )
612
613             CALL transpose_yx( ar1(:,:,:), f_in )
614
615             DO  inew = 0, nx-1
616                iind = ii + (nblk+1) * inew
617                f_inv(:,:,iind) = f_in(:,:,inew)
618             ENDDO
619
620             CALL cpu_log( log_point_s(8), 'transpo invers', 'pause' )
621
622          ENDDO
623!
624!--       Restore original indices/counters
625          nx               = isave(1)
626          nxl_y            = isave(2)
627          nxr_y            = isave(3)
628          sendrecvcount_xy = isave(4)
629
630          CALL resort_for_yx( f_inv, f_out_z )
631
632          DEALLOCATE( ar1, f_in, f_inv )
633
634!
635!--       fft along x backward + subsequent final transposition x --> z
636          ALLOCATE( f_inv(nys:nyn,nxl:nxr,1:nz) )
637!
638!--       Save original indices and gridpoint counter
639          isave(1) = nz
640          isave(2) = nzb_x
641          isave(3) = nzt_x
642          isave(4) = sendrecvcount_zx
643!
644!--       Set new indices for transformation
645          nblk             = nz / pdims(1)
646          nz               = pdims(1)
647          nnz_x            = 1
648          nzb_x            = 1 + myidx * nnz_x
649          nzt_x            = ( myidx + 1 ) * nnz_x
650          sendrecvcount_zx = nnx * nny * nnz_x
651
652          ALLOCATE( ar1(0:nx,nys_x:nyn_x,nzb_x:nzt_x) )
653          ALLOCATE( f_in(nys:nyn,nxl:nxr,1:nz) )
654
655          DO  kk = 1, nblk
656
657             CALL cpu_log( log_point_s(4), 'fft_x', 'continue', cpu_log_nowait )
658
659             n = isave(2) + kk - 1
660             CALL fft_x( ar1(:,:,:), 'backward', f_out_z(:,:,n))
661
662             IF ( kk == nblk )  THEN
663                CALL cpu_log( log_point_s(4), 'fft_x', 'stop' )
664             ELSE
665                CALL cpu_log( log_point_s(4), 'fft_x', 'pause' )
666             ENDIF
667
668             CALL cpu_log( log_point_s(8), 'transpo invers', 'continue', cpu_log_nowait )
669
670             CALL transpose_xz( ar1(:,:,:), f_in )
671
672             DO  knew = 1, nz
673                ki = kk + nblk * (knew-1)
674                f_inv(:,:,ki) = f_in(:,:,knew)
675             ENDDO
676
677             IF ( kk == nblk )  THEN
678                CALL cpu_log( log_point_s(8), 'transpo invers', 'stop' )
679             ELSE
680                CALL cpu_log( log_point_s(8), 'transpo invers', 'pause' )
681             ENDIF
682
683          ENDDO
684!
685!--       Restore original indices/counters
686          nz               = isave(1)
687          nzb_x            = isave(2)
688          nzt_x            = isave(3)
689          sendrecvcount_zx = isave(4)
690
691          CALL resort_for_xz( f_inv, ar )
692
693          DEALLOCATE( ar1, f_in, f_inv )
694
695       ENDIF
696
697       CALL cpu_log( log_point_s(3), 'poisfft', 'stop' )
698
699    END SUBROUTINE poisfft
700
701
702
703    SUBROUTINE ffty_tr_yx( f_in, f_out )
704
705!------------------------------------------------------------------------------!
706!  Fourier-transformation along y with subsequent transposition y --> x for
707!  a 1d-decomposition along x
708!
709!  ATTENTION: The performance of this routine is much faster on the NEC-SX6,
710!             if the first index of work_ffty_vec is odd. Otherwise
711!             memory bank conflicts may occur (especially if the index is a
712!             multiple of 128). That's why work_ffty_vec is dimensioned as
713!             0:ny+1.
714!             Of course, this will not work if users are using an odd number
715!             of gridpoints along y.
716!------------------------------------------------------------------------------!
717
718       USE control_parameters,                                                 &
719           ONLY:  host
720
721       USE cpulog,                                                             &
722           ONLY:  cpu_log, log_point_s
723
724       USE kinds
725
726       USE pegrid
727
728       IMPLICIT NONE
729
730       INTEGER(iwp)            ::  i            !:
731       INTEGER(iwp)            ::  iend         !:
732       INTEGER(iwp)            ::  iouter       !:
733       INTEGER(iwp)            ::  ir           !:
734       INTEGER(iwp)            ::  j            !:
735       INTEGER(iwp)            ::  k            !:
736
737       INTEGER(iwp), PARAMETER ::  stridex = 4  !:
738
739       REAL(wp), DIMENSION(0:ny,stridex)        ::  work_ffty      !:
740#if defined( __nec )
741       REAL(wp), DIMENSION(0:ny+1,1:nz,nxl:nxr) ::  work_ffty_vec  !:
742#endif
743       REAL(wp), DIMENSION(1:nz,0:ny,nxl:nxr)             ::  f_in   !:
744       REAL(wp), DIMENSION(nnx,1:nz,nys_x:nyn_x,pdims(1)) ::  f_out  !:
745       REAL(wp), DIMENSION(nxl:nxr,1:nz,0:ny)             ::  work   !:
746
747!
748!--    Carry out the FFT along y, where all data are present due to the
749!--    1d-decomposition along x. Resort the data in a way that x becomes
750!--    the first index.
751       CALL cpu_log( log_point_s(7), 'fft_y_1d', 'start' )
752
753       IF ( host(1:3) == 'nec' )  THEN
754#if defined( __nec )
755!
756!--       Code optimized for vector processors
757!$OMP     PARALLEL PRIVATE ( i, j, k )
758!$OMP     DO
759          DO  i = nxl, nxr
760
761             DO  j = 0, ny
762                DO  k = 1, nz
763                   work_ffty_vec(j,k,i) = f_in(k,j,i)
764                ENDDO
765             ENDDO
766
767             CALL fft_y_m( work_ffty_vec(:,:,i), ny+1, 'forward' )
768
769          ENDDO
770
771!$OMP     DO
772          DO  k = 1, nz
773             DO  j = 0, ny
774                DO  i = nxl, nxr
775                   work(i,k,j) = work_ffty_vec(j,k,i)
776                ENDDO
777             ENDDO
778          ENDDO
779!$OMP     END PARALLEL
780#endif
781
782       ELSE
783
784!
785!--       Cache optimized code.
786!--       The i-(x-)direction is split into a strided outer loop and an inner
787!--       loop for better cache performance
788!$OMP     PARALLEL PRIVATE (i,iend,iouter,ir,j,k,work_ffty)
789!$OMP     DO
790          DO  iouter = nxl, nxr, stridex
791
792             iend = MIN( iouter+stridex-1, nxr )  ! Upper bound for inner i loop
793
794             DO  k = 1, nz
795
796                DO  i = iouter, iend
797
798                   ir = i-iouter+1  ! counter within a stride
799                   DO  j = 0, ny
800                      work_ffty(j,ir) = f_in(k,j,i)
801                   ENDDO
802!
803!--                FFT along y
804                   CALL fft_y_1d( work_ffty(:,ir), 'forward' )
805
806                ENDDO
807
808!
809!--             Resort
810                DO  j = 0, ny
811                   DO  i = iouter, iend
812                      work(i,k,j) = work_ffty(j,i-iouter+1)
813                   ENDDO
814                ENDDO
815
816             ENDDO
817
818          ENDDO
819!$OMP     END PARALLEL
820
821       ENDIF
822       CALL cpu_log( log_point_s(7), 'fft_y_1d', 'pause' )
823
824!
825!--    Transpose array
826#if defined( __parallel )
827       CALL cpu_log( log_point_s(32), 'mpi_alltoall', 'start' )
828       IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
829       CALL MPI_ALLTOALL( work(nxl,1,0),      sendrecvcount_xy, MPI_REAL, &
830                          f_out(1,1,nys_x,1), sendrecvcount_xy, MPI_REAL, &
831                          comm1dx, ierr )
832       CALL cpu_log( log_point_s(32), 'mpi_alltoall', 'stop' )
833#endif
834
835    END SUBROUTINE ffty_tr_yx
836
837
838    SUBROUTINE tr_xy_ffty( f_in, f_out )
839
840!------------------------------------------------------------------------------!
841!  Transposition x --> y with a subsequent backward Fourier transformation for
842!  a 1d-decomposition along x
843!------------------------------------------------------------------------------!
844
845       USE control_parameters,                                                 &
846           ONLY:  host
847
848       USE cpulog,                                                             &
849           ONLY:  cpu_log, log_point_s
850
851       USE kinds
852
853       USE pegrid
854
855       IMPLICIT NONE
856
857       INTEGER(iwp)            ::  i            !:
858       INTEGER(iwp)            ::  iend         !:
859       INTEGER(iwp)            ::  iouter       !:
860       INTEGER(iwp)            ::  ir           !:
861       INTEGER(iwp)            ::  j            !:
862       INTEGER(iwp)            ::  k            !:
863
864       INTEGER(iwp), PARAMETER ::  stridex = 4  !:
865
866       REAL(wp), DIMENSION(0:ny,stridex)        ::  work_ffty      !:
867#if defined( __nec )
868       REAL(wp), DIMENSION(0:ny+1,1:nz,nxl:nxr) ::  work_ffty_vec  !:
869#endif
870       REAL(wp), DIMENSION(nnx,1:nz,nys_x:nyn_x,pdims(1)) ::  f_in   !:
871       REAL(wp), DIMENSION(1:nz,0:ny,nxl:nxr)             ::  f_out  !:
872       REAL(wp), DIMENSION(nxl:nxr,1:nz,0:ny)             ::  work   !:
873
874!
875!--    Transpose array
876#if defined( __parallel )
877       CALL cpu_log( log_point_s(32), 'mpi_alltoall', 'start' )
878       IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
879       CALL MPI_ALLTOALL( f_in(1,1,nys_x,1), sendrecvcount_xy, MPI_REAL, &
880                          work(nxl,1,0),     sendrecvcount_xy, MPI_REAL, &
881                          comm1dx, ierr )
882       CALL cpu_log( log_point_s(32), 'mpi_alltoall', 'stop' )
883#endif
884
885!
886!--    Resort the data in a way that y becomes the first index and carry out the
887!--    backward fft along y.
888       CALL cpu_log( log_point_s(7), 'fft_y_1d', 'continue' )
889
890       IF ( host(1:3) == 'nec' )  THEN
891#if defined( __nec )
892!
893!--       Code optimized for vector processors
894!$OMP     PARALLEL PRIVATE ( i, j, k )
895!$OMP     DO
896          DO  k = 1, nz
897             DO  j = 0, ny
898                DO  i = nxl, nxr
899                   work_ffty_vec(j,k,i) = work(i,k,j)
900                ENDDO
901             ENDDO
902          ENDDO
903
904!$OMP     DO
905          DO  i = nxl, nxr
906
907             CALL fft_y_m( work_ffty_vec(:,:,i), ny+1, 'backward' )
908
909             DO  j = 0, ny
910                DO  k = 1, nz
911                   f_out(k,j,i) = work_ffty_vec(j,k,i)
912                ENDDO
913             ENDDO
914
915          ENDDO
916!$OMP     END PARALLEL
917#endif
918
919       ELSE
920
921!
922!--       Cache optimized code.
923!--       The i-(x-)direction is split into a strided outer loop and an inner
924!--       loop for better cache performance
925!$OMP     PARALLEL PRIVATE ( i, iend, iouter, ir, j, k, work_ffty )
926!$OMP     DO
927          DO  iouter = nxl, nxr, stridex
928
929             iend = MIN( iouter+stridex-1, nxr )  ! Upper bound for inner i loop
930
931             DO  k = 1, nz
932!
933!--             Resort
934                DO  j = 0, ny
935                   DO  i = iouter, iend
936                      work_ffty(j,i-iouter+1) = work(i,k,j)
937                   ENDDO
938                ENDDO
939
940                DO  i = iouter, iend
941
942!
943!--                FFT along y
944                   ir = i-iouter+1  ! counter within a stride
945                   CALL fft_y_1d( work_ffty(:,ir), 'backward' )
946
947                   DO  j = 0, ny
948                      f_out(k,j,i) = work_ffty(j,ir)
949                   ENDDO
950                ENDDO
951
952             ENDDO
953
954          ENDDO
955!$OMP     END PARALLEL
956
957       ENDIF
958
959       CALL cpu_log( log_point_s(7), 'fft_y_1d', 'stop' )
960
961    END SUBROUTINE tr_xy_ffty
962
963
964    SUBROUTINE fftx_tri_fftx( ar )
965
966!------------------------------------------------------------------------------!
967!  FFT along x, solution of the tridiagonal system and backward FFT for
968!  a 1d-decomposition along x
969!
970!  WARNING: this subroutine may still not work for hybrid parallelization
971!           with OpenMP (for possible necessary changes see the original
972!           routine poisfft_hybrid, developed by Klaus Ketelsen, May 2002)
973!------------------------------------------------------------------------------!
974
975       USE control_parameters,                                                 &
976           ONLY:  host
977
978       USE cpulog,                                                             &
979           ONLY:  cpu_log, log_point_s
980
981       USE grid_variables,                                                     &
982           ONLY:  ddx2, ddy2
983
984       USE kinds
985
986       USE pegrid
987
988       IMPLICIT NONE
989
990       INTEGER(iwp) ::  i                   !:
991       INTEGER(iwp) ::  j                   !:
992       INTEGER(iwp) ::  k                   !:
993       INTEGER(iwp) ::  m                   !:
994       INTEGER(iwp) ::  n                   !:
995       INTEGER(iwp) ::  omp_get_thread_num  !:
996       INTEGER(iwp) ::  tn                  !:
997
998       REAL(wp), DIMENSION(0:nx)                          ::  work_fftx  !:
999       REAL(wp), DIMENSION(0:nx,1:nz)                     ::  work_trix  !:
1000       REAL(wp), DIMENSION(nnx,1:nz,nys_x:nyn_x,pdims(1)) ::  ar         !:
1001       REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE          ::  tri        !:
1002
1003
1004       CALL cpu_log( log_point_s(33), 'fft_x_1d + tridia', 'start' )
1005
1006       ALLOCATE( tri(5,0:nx,0:nz-1,0:threads_per_task-1) )
1007
1008       tn = 0              ! Default thread number in case of one thread
1009!$OMP  PARALLEL DO PRIVATE ( i, j, k, m, n, tn, work_fftx, work_trix )
1010       DO  j = nys_x, nyn_x
1011
1012!$        tn = omp_get_thread_num()
1013
1014          IF ( host(1:3) == 'nec' )  THEN
1015!
1016!--          Code optimized for vector processors
1017             DO  k = 1, nz
1018
1019                m = 0
1020                DO  n = 1, pdims(1)
1021                   DO  i = 1, nnx
1022                      work_trix(m,k) = ar(i,k,j,n)
1023                      m = m + 1
1024                   ENDDO
1025                ENDDO
1026
1027             ENDDO
1028
1029             CALL fft_x_m( work_trix, 'forward' )
1030
1031          ELSE
1032!
1033!--          Cache optimized code
1034             DO  k = 1, nz
1035
1036                m = 0
1037                DO  n = 1, pdims(1)
1038                   DO  i = 1, nnx
1039                      work_fftx(m) = ar(i,k,j,n)
1040                      m = m + 1
1041                   ENDDO
1042                ENDDO
1043
1044                CALL fft_x_1d( work_fftx, 'forward' )
1045
1046                DO  i = 0, nx
1047                   work_trix(i,k) = work_fftx(i)
1048                ENDDO
1049
1050             ENDDO
1051
1052          ENDIF
1053
1054!
1055!--       Solve the linear equation system
1056          CALL tridia_1dd( ddx2, ddy2, nx, ny, j, work_trix, tri(:,:,:,tn) )
1057
1058          IF ( host(1:3) == 'nec' )  THEN
1059!
1060!--          Code optimized for vector processors
1061             CALL fft_x_m( work_trix, 'backward' )
1062
1063             DO  k = 1, nz
1064
1065                m = 0
1066                DO  n = 1, pdims(1)
1067                   DO  i = 1, nnx
1068                      ar(i,k,j,n) = work_trix(m,k)
1069                      m = m + 1
1070                   ENDDO
1071                ENDDO
1072
1073             ENDDO
1074
1075          ELSE
1076!
1077!--          Cache optimized code
1078             DO  k = 1, nz
1079
1080                DO  i = 0, nx
1081                   work_fftx(i) = work_trix(i,k)
1082                ENDDO
1083
1084                CALL fft_x_1d( work_fftx, 'backward' )
1085
1086                m = 0
1087                DO  n = 1, pdims(1)
1088                   DO  i = 1, nnx
1089                      ar(i,k,j,n) = work_fftx(m)
1090                      m = m + 1
1091                   ENDDO
1092                ENDDO
1093
1094             ENDDO
1095
1096          ENDIF
1097
1098       ENDDO
1099
1100       DEALLOCATE( tri )
1101
1102       CALL cpu_log( log_point_s(33), 'fft_x_1d + tridia', 'stop' )
1103
1104    END SUBROUTINE fftx_tri_fftx
1105
1106
1107    SUBROUTINE fftx_tr_xy( f_in, f_out )
1108
1109!------------------------------------------------------------------------------!
1110!  Fourier-transformation along x with subsequent transposition x --> y for
1111!  a 1d-decomposition along y
1112!
1113!  ATTENTION: The NEC-branch of this routine may significantly profit from
1114!             further optimizations. So far, performance is much worse than
1115!             for routine ffty_tr_yx (more than three times slower).
1116!------------------------------------------------------------------------------!
1117
1118       USE control_parameters,                                                 &
1119           ONLY:  host
1120
1121       USE cpulog,                                                             &
1122           ONLY:  cpu_log, log_point_s
1123
1124       USE kinds
1125
1126       USE pegrid
1127
1128       IMPLICIT NONE
1129
1130       INTEGER(iwp) ::  i  !:
1131       INTEGER(iwp) ::  j  !:
1132       INTEGER(iwp) ::  k  !:
1133
1134       REAL(wp), DIMENSION(0:nx,1:nz,nys:nyn)             ::  work_fftx  !:
1135       REAL(wp), DIMENSION(1:nz,nys:nyn,0:nx)             ::  f_in       !:
1136       REAL(wp), DIMENSION(nny,1:nz,nxl_y:nxr_y,pdims(2)) ::  f_out      !:
1137       REAL(wp), DIMENSION(nys:nyn,1:nz,0:nx)             ::  work       !:
1138
1139!
1140!--    Carry out the FFT along x, where all data are present due to the
1141!--    1d-decomposition along y. Resort the data in a way that y becomes
1142!--    the first index.
1143       CALL cpu_log( log_point_s(4), 'fft_x_1d', 'start' )
1144
1145       IF ( host(1:3) == 'nec' )  THEN
1146!
1147!--       Code for vector processors
1148!$OMP     PARALLEL PRIVATE ( i, j, k )
1149!$OMP     DO
1150          DO  i = 0, nx
1151
1152             DO  j = nys, nyn
1153                DO  k = 1, nz
1154                   work_fftx(i,k,j) = f_in(k,j,i)
1155                ENDDO
1156             ENDDO
1157
1158          ENDDO
1159
1160!$OMP     DO
1161          DO  j = nys, nyn
1162
1163             CALL fft_x_m( work_fftx(:,:,j), 'forward' )
1164
1165             DO  k = 1, nz
1166                DO  i = 0, nx
1167                   work(j,k,i) = work_fftx(i,k,j)
1168                ENDDO
1169             ENDDO
1170
1171          ENDDO
1172!$OMP     END PARALLEL
1173
1174       ELSE
1175
1176!
1177!--       Cache optimized code (there might be still a potential for better
1178!--       optimization).
1179!$OMP     PARALLEL PRIVATE (i,j,k)
1180!$OMP     DO
1181          DO  i = 0, nx
1182
1183             DO  j = nys, nyn
1184                DO  k = 1, nz
1185                   work_fftx(i,k,j) = f_in(k,j,i)
1186                ENDDO
1187             ENDDO
1188
1189          ENDDO
1190
1191!$OMP     DO
1192          DO  j = nys, nyn
1193             DO  k = 1, nz
1194
1195                CALL fft_x_1d( work_fftx(0:nx,k,j), 'forward' )
1196
1197                DO  i = 0, nx
1198                   work(j,k,i) = work_fftx(i,k,j)
1199                ENDDO
1200             ENDDO
1201
1202          ENDDO
1203!$OMP     END PARALLEL
1204
1205       ENDIF
1206       CALL cpu_log( log_point_s(4), 'fft_x_1d', 'pause' )
1207
1208!
1209!--    Transpose array
1210#if defined( __parallel )
1211       CALL cpu_log( log_point_s(32), 'mpi_alltoall', 'start' )
1212       IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
1213       CALL MPI_ALLTOALL( work(nys,1,0),      sendrecvcount_xy, MPI_REAL, &
1214                          f_out(1,1,nxl_y,1), sendrecvcount_xy, MPI_REAL, &
1215                          comm1dy, ierr )
1216       CALL cpu_log( log_point_s(32), 'mpi_alltoall', 'stop' )
1217#endif
1218
1219    END SUBROUTINE fftx_tr_xy
1220
1221
1222    SUBROUTINE tr_yx_fftx( f_in, f_out )
1223
1224!------------------------------------------------------------------------------!
1225!  Transposition y --> x with a subsequent backward Fourier transformation for
1226!  a 1d-decomposition along x
1227!------------------------------------------------------------------------------!
1228
1229       USE control_parameters,                                                 &
1230           ONLY:  host
1231
1232       USE cpulog,                                                             &
1233           ONLY:  cpu_log, log_point_s
1234
1235       USE kinds
1236
1237       USE pegrid
1238
1239       IMPLICIT NONE
1240
1241       INTEGER(iwp) ::  i  !:
1242       INTEGER(iwp) ::  j  !:
1243       INTEGER(iwp) ::  k  !:
1244
1245       REAL(wp), DIMENSION(0:nx,1:nz,nys:nyn)             ::  work_fftx  !:
1246       REAL(wp), DIMENSION(nny,1:nz,nxl_y:nxr_y,pdims(2)) ::  f_in       !:
1247       REAL(wp), DIMENSION(1:nz,nys:nyn,0:nx)             ::  f_out      !:
1248       REAL(wp), DIMENSION(nys:nyn,1:nz,0:nx)             ::  work       !:
1249
1250!
1251!--    Transpose array
1252#if defined( __parallel )
1253       CALL cpu_log( log_point_s(32), 'mpi_alltoall', 'start' )
1254       IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
1255       CALL MPI_ALLTOALL( f_in(1,1,nxl_y,1), sendrecvcount_xy, MPI_REAL, &
1256                          work(nys,1,0),     sendrecvcount_xy, MPI_REAL, &
1257                          comm1dy, ierr )
1258       CALL cpu_log( log_point_s(32), 'mpi_alltoall', 'stop' )
1259#endif
1260
1261!
1262!--    Carry out the FFT along x, where all data are present due to the
1263!--    1d-decomposition along y. Resort the data in a way that y becomes
1264!--    the first index.
1265       CALL cpu_log( log_point_s(4), 'fft_x_1d', 'continue' )
1266
1267       IF ( host(1:3) == 'nec' )  THEN
1268!
1269!--       Code optimized for vector processors
1270!$OMP     PARALLEL PRIVATE ( i, j, k )
1271!$OMP     DO
1272          DO  j = nys, nyn
1273
1274             DO  k = 1, nz
1275                DO  i = 0, nx
1276                   work_fftx(i,k,j) = work(j,k,i)
1277                ENDDO
1278             ENDDO
1279
1280             CALL fft_x_m( work_fftx(:,:,j), 'backward' )
1281
1282          ENDDO
1283
1284!$OMP     DO
1285          DO  i = 0, nx
1286             DO  j = nys, nyn
1287                DO  k = 1, nz
1288                   f_out(k,j,i) = work_fftx(i,k,j)
1289                ENDDO
1290             ENDDO
1291          ENDDO
1292!$OMP     END PARALLEL
1293
1294       ELSE
1295
1296!
1297!--       Cache optimized code (there might be still a potential for better
1298!--       optimization).
1299!$OMP     PARALLEL PRIVATE (i,j,k)
1300!$OMP     DO
1301          DO  j = nys, nyn
1302             DO  k = 1, nz
1303
1304                DO  i = 0, nx
1305                   work_fftx(i,k,j) = work(j,k,i)
1306                ENDDO
1307
1308                CALL fft_x_1d( work_fftx(0:nx,k,j), 'backward' )
1309
1310             ENDDO
1311          ENDDO
1312
1313!$OMP     DO
1314          DO  i = 0, nx
1315             DO  j = nys, nyn
1316                DO  k = 1, nz
1317                   f_out(k,j,i) = work_fftx(i,k,j)
1318                ENDDO
1319             ENDDO
1320          ENDDO
1321!$OMP     END PARALLEL
1322
1323       ENDIF
1324       CALL cpu_log( log_point_s(4), 'fft_x_1d', 'stop' )
1325
1326    END SUBROUTINE tr_yx_fftx
1327
1328
1329    SUBROUTINE ffty_tri_ffty( ar )
1330
1331!------------------------------------------------------------------------------!
1332!  FFT along y, solution of the tridiagonal system and backward FFT for
1333!  a 1d-decomposition along y
1334!
1335!  WARNING: this subroutine may still not work for hybrid parallelization
1336!           with OpenMP (for possible necessary changes see the original
1337!           routine poisfft_hybrid, developed by Klaus Ketelsen, May 2002)
1338!------------------------------------------------------------------------------!
1339
1340       USE control_parameters,                                                 &
1341           ONLY:  host
1342
1343       USE cpulog,                                                             &
1344           ONLY:  cpu_log, log_point_s
1345
1346       USE grid_variables,                                                     &
1347           ONLY:  ddx2, ddy2
1348
1349       USE kinds
1350
1351       USE pegrid
1352
1353       IMPLICIT NONE
1354
1355       INTEGER(iwp) ::  i                   !:
1356       INTEGER(iwp) ::  j                   !:
1357       INTEGER(iwp) ::  k                   !:
1358       INTEGER(iwp) ::  m                   !:
1359       INTEGER(iwp) ::  n                   !:
1360       INTEGER(iwp) ::  omp_get_thread_num  !:
1361       INTEGER(iwp) ::  tn                  !:
1362
1363       REAL(wp), DIMENSION(0:ny)                          ::  work_ffty  !:
1364       REAL(wp), DIMENSION(0:ny,1:nz)                     ::  work_triy  !:
1365       REAL(wp), DIMENSION(nny,1:nz,nxl_y:nxr_y,pdims(2)) ::  ar         !:
1366       REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE          ::  tri        !:
1367
1368
1369       CALL cpu_log( log_point_s(39), 'fft_y_1d + tridia', 'start' )
1370
1371       ALLOCATE( tri(5,0:ny,0:nz-1,0:threads_per_task-1) )
1372
1373       tn = 0           ! Default thread number in case of one thread
1374!$OMP  PARALLEL DO PRIVATE ( i, j, k, m, n, tn, work_ffty, work_triy )
1375       DO  i = nxl_y, nxr_y
1376
1377!$        tn = omp_get_thread_num()
1378
1379          IF ( host(1:3) == 'nec' )  THEN
1380!
1381!--          Code optimized for vector processors
1382             DO  k = 1, nz
1383
1384                m = 0
1385                DO  n = 1, pdims(2)
1386                   DO  j = 1, nny
1387                      work_triy(m,k) = ar(j,k,i,n)
1388                      m = m + 1
1389                   ENDDO
1390                ENDDO
1391
1392             ENDDO
1393
1394             CALL fft_y_m( work_triy, ny, 'forward' )
1395
1396          ELSE
1397!
1398!--          Cache optimized code
1399             DO  k = 1, nz
1400
1401                m = 0
1402                DO  n = 1, pdims(2)
1403                   DO  j = 1, nny
1404                      work_ffty(m) = ar(j,k,i,n)
1405                      m = m + 1
1406                   ENDDO
1407                ENDDO
1408
1409                CALL fft_y_1d( work_ffty, 'forward' )
1410
1411                DO  j = 0, ny
1412                   work_triy(j,k) = work_ffty(j)
1413                ENDDO
1414
1415             ENDDO
1416
1417          ENDIF
1418
1419!
1420!--       Solve the linear equation system
1421          CALL tridia_1dd( ddy2, ddx2, ny, nx, i, work_triy, tri(:,:,:,tn) )
1422
1423          IF ( host(1:3) == 'nec' )  THEN
1424!
1425!--          Code optimized for vector processors
1426             CALL fft_y_m( work_triy, ny, 'backward' )
1427
1428             DO  k = 1, nz
1429
1430                m = 0
1431                DO  n = 1, pdims(2)
1432                   DO  j = 1, nny
1433                      ar(j,k,i,n) = work_triy(m,k)
1434                      m = m + 1
1435                   ENDDO
1436                ENDDO
1437
1438             ENDDO
1439
1440          ELSE
1441!
1442!--          Cache optimized code
1443             DO  k = 1, nz
1444
1445                DO  j = 0, ny
1446                   work_ffty(j) = work_triy(j,k)
1447                ENDDO
1448
1449                CALL fft_y_1d( work_ffty, 'backward' )
1450
1451                m = 0
1452                DO  n = 1, pdims(2)
1453                   DO  j = 1, nny
1454                      ar(j,k,i,n) = work_ffty(m)
1455                      m = m + 1
1456                   ENDDO
1457                ENDDO
1458
1459             ENDDO
1460
1461          ENDIF
1462
1463       ENDDO
1464
1465       DEALLOCATE( tri )
1466
1467       CALL cpu_log( log_point_s(39), 'fft_y_1d + tridia', 'stop' )
1468
1469    END SUBROUTINE ffty_tri_ffty
1470
1471#endif
1472
1473 END MODULE poisfft_mod
Note: See TracBrowser for help on using the repository browser.