source: palm/trunk/SOURCE/poisfft_mod.f90 @ 4360

Last change on this file since 4360 was 4360, checked in by suehring, 4 years ago

Bugfix in output of time-averaged plant-canopy quanities; Output of plant-canopy data only where tall canopy is defined; land-surface model: fix wrong location strings; tests: update urban test case; all source code files: copyright update

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