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

Last change on this file since 4360 was 4360, checked in by suehring, 5 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
Line 
1!> @file poisfft_mod.f90
2!------------------------------------------------------------------------------!
3! This file is part of the PALM model system.
4!
5! PALM is free software: you can redistribute it and/or modify it under the
6! terms of the GNU General Public License as published by the Free Software
7! Foundation, either version 3 of the License, or (at your option) any later
8! version.
9!
10! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
11! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
12! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
13!
14! You should have received a copy of the GNU General Public License along with
15! PALM. If not, see <http://www.gnu.org/licenses/>.
16!
17! Copyright 1997-2020 Leibniz Universitaet Hannover
18!------------------------------------------------------------------------------!
19!
20! Current revisions:
21! -----------------
22!
23!
24! Former revisions:
25! -----------------
26! $Id: poisfft_mod.f90 4360 2020-01-07 11:25:50Z suehring $
27! Corrected "Former revisions" section
28!
29! 3690 2019-01-22 22:56:42Z knoop
30! OpenACC port for SPEC
31!
32! Revision 1.1  1997/07/24 11:24:14  raasch
33! Initial revision
34!
35!
36! Description:
37! ------------
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
47!------------------------------------------------------------------------------!
48 MODULE poisfft_mod
49 
50
51    USE fft_xy,                                                                &
52        ONLY:  fft_init, fft_y, fft_y_1d, fft_y_m, fft_x, fft_x_1d, fft_x_m
53
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
64    IMPLICIT NONE
65
66    LOGICAL, SAVE ::  poisfft_initialized = .FALSE.
67
68    PRIVATE
69
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
80
81 CONTAINS
82
83!------------------------------------------------------------------------------!
84! Description:
85! ------------
86!> Setup coefficients for FFT and the tridiagonal solver
87!------------------------------------------------------------------------------!
88    SUBROUTINE poisfft_init
89
90       IMPLICIT NONE
91
92
93       CALL fft_init
94
95       CALL tridia_init
96
97       poisfft_initialized = .TRUE.
98
99    END SUBROUTINE poisfft_init
100
101
102
103!------------------------------------------------------------------------------!
104! Description:
105! ------------
106!> Two-dimensional Fourier Transformation in x- and y-direction.
107!------------------------------------------------------------------------------!
108    SUBROUTINE poisfft( ar )
109
110       USE control_parameters,                                                 &
111           ONLY:  transpose_compute_overlap
112
113       USE cpulog,                                                             &
114           ONLY:  cpu_log, cpu_log_nowait, log_point_s
115
116       USE kinds
117
118       USE pegrid
119
120       IMPLICIT NONE
121
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  !<
138
139       INTEGER(iwp), DIMENSION(4) ::  isave  !<
140
141       REAL(wp), DIMENSION(1:nz,nys:nyn,nxl:nxr) ::  ar      !<
142       REAL(wp), DIMENSION(nys:nyn,nxl:nxr,1:nz) ::  ar_inv  !<
143
144#define __acc_fft_device ( defined( _OPENACC ) && ( defined ( __cuda_fft ) ) )
145#if __acc_fft_device
146       !$ACC DECLARE CREATE(ar_inv)
147#endif
148
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  !<
154
155
156       CALL cpu_log( log_point_s(3), 'poisfft', 'start' )
157
158       IF ( .NOT. poisfft_initialized )  CALL poisfft_init
159
160#if !__acc_fft_device
161       !$ACC UPDATE HOST(ar)
162#endif
163
164#ifndef _OPENACC
165!
166!--    Two-dimensional Fourier Transformation in x- and y-direction.
167       IF ( pdims(2) == 1  .AND.  pdims(1) > 1 )  THEN
168
169!
170!--       1d-domain-decomposition along x:
171!--       FFT along y and transposition y --> x
172          CALL ffty_tr_yx( ar, ar )
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
180          CALL tr_xy_ffty( ar, ar )
181
182       ELSEIF ( pdims(1) == 1 .AND. pdims(2) > 1 )  THEN
183
184!
185!--       1d-domain-decomposition along y:
186!--       FFT along x and transposition x --> y
187          CALL fftx_tr_xy( ar, ar )
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
195          CALL tr_yx_fftx( ar, ar )
196
197       ELSEIF ( .NOT. transpose_compute_overlap )  THEN
198#endif
199
200!
201!--       2d-domain-decomposition or no decomposition (1 PE run)
202!--       Transposition z --> x
203          CALL cpu_log( log_point_s(5), 'transpo forward', 'start' )
204          CALL resort_for_zx( ar, ar_inv )
205          CALL transpose_zx( ar_inv, ar )
206          CALL cpu_log( log_point_s(5), 'transpo forward', 'pause' )
207
208          CALL cpu_log( log_point_s(4), 'fft_x', 'start' )
209          CALL fft_x( ar, 'forward' )
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' )
215          CALL resort_for_xy( ar, ar_inv )
216          CALL transpose_xy( ar_inv, ar )
217          CALL cpu_log( log_point_s(5), 'transpo forward', 'pause' )
218
219          CALL cpu_log( log_point_s(7), 'fft_y', 'start' )
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 )
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' )
228          CALL resort_for_yz( ar, ar_inv )
229          CALL transpose_yz( ar_inv, ar )
230          CALL cpu_log( log_point_s(5), 'transpo forward', 'stop' )
231
232!
233!--       Solve the tridiagonal equation system along z
234          CALL cpu_log( log_point_s(6), 'tridia', 'start' )
235          CALL tridia_substi( ar )
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' )
242          CALL transpose_zy( ar, ar_inv )
243          CALL resort_for_zy( ar_inv, ar )
244          CALL cpu_log( log_point_s(8), 'transpo invers', 'pause' )
245
246          CALL cpu_log( log_point_s(7), 'fft_y', 'continue' )
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 )
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' )
255          CALL transpose_yx( ar, ar_inv )
256          CALL resort_for_yx( ar_inv, ar )
257          CALL cpu_log( log_point_s(8), 'transpo invers', 'pause' )
258
259          CALL cpu_log( log_point_s(4), 'fft_x', 'continue' )
260          CALL fft_x( ar, 'backward' )
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' )
266          CALL transpose_xz( ar, ar_inv )
267          CALL resort_for_xz( ar_inv, ar )
268          CALL cpu_log( log_point_s(8), 'transpo invers', 'stop' )
269
270#ifndef _OPENACC
271       ELSE
272
273!
274!--       2d-domain-decomposition or no decomposition (1 PE run) with
275!--       overlapping transposition / fft
276!--       cputime logging must not use barriers, which would prevent overlapping
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
298          ALLOCATE( ar1(0:nx,nys_x:nyn_x,nzb_x:nzt_x) )
299          ALLOCATE( f_in(nys:nyn,nxl:nxr,1:nz) )
300
301          DO  kk = 1, nblk
302
303             IF ( kk == 1 )  THEN
304                CALL cpu_log( log_point_s(5), 'transpo forward', 'start', cpu_log_nowait )
305             ELSE
306                CALL cpu_log( log_point_s(5), 'transpo forward', 'continue', cpu_log_nowait )
307             ENDIF
308
309             DO  knew = 1, nz
310                ki = kk + nblk * ( knew - 1 )
311                f_in(:,:,knew) = f_inv(:,:,ki)
312             ENDDO
313
314             CALL transpose_zx( f_in, ar1(:,:,:))
315             CALL cpu_log( log_point_s(5), 'transpo forward', 'pause' )
316
317             IF ( kk == 1 )  THEN
318                CALL cpu_log( log_point_s(4), 'fft_x', 'start', cpu_log_nowait )
319             ELSE
320                CALL cpu_log( log_point_s(4), 'fft_x', 'continue', cpu_log_nowait )
321             ENDIF
322
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' )
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
356          ALLOCATE( ar1(0:ny,nxl_y:nxr_y,nzb_y:nzt_y) )
357          ALLOCATE( f_in(nys_x:nyn_x,nzb_x:nzt_x,0:nx) )
358
359          DO  ii = 0, nblk
360
361             CALL cpu_log( log_point_s(5), 'transpo forward', 'continue', cpu_log_nowait )
362
363             DO  inew = 0, nx-1
364                iind = ii + ( nblk + 1 ) * inew
365                f_in(:,:,inew) = f_inv(:,:,iind)
366             ENDDO
367
368             CALL transpose_xy( f_in, ar1(:,:,:) )
369
370             CALL cpu_log( log_point_s(5), 'transpo forward', 'pause' )
371
372             IF ( ii == 1 )  THEN
373                CALL cpu_log( log_point_s(7), 'fft_y', 'start', cpu_log_nowait )
374             ELSE
375                CALL cpu_log( log_point_s(7), 'fft_y', 'continue', cpu_log_nowait )
376             ENDIF
377
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 )
384
385             CALL cpu_log( log_point_s(7), 'fft_y', 'pause' )
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
416          ALLOCATE( ar1(nxl_z:nxr_z,nys_z:nyn_z,1:nz) )
417          ALLOCATE( f_in(nxl_y:nxr_y,nzb_y:nzt_y,0:ny) )
418
419          DO  jj = 0, nblk
420!
421!--          Forward Fourier Transformation
422!--          Transposition y --> z
423             CALL cpu_log( log_point_s(5), 'transpo forward', 'continue', cpu_log_nowait )
424
425             DO  jnew = 0, ny-1
426                jind = jj + ( nblk + 1 ) * jnew
427                f_in(:,:,jnew) = f_inv(:,:,jind)
428             ENDDO
429
430             CALL transpose_yz( f_in, ar1(:,:,:) )
431
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' )
436             ENDIF
437
438!
439!--          Solve the tridiagonal equation system along z
440             CALL cpu_log( log_point_s(6), 'tridia', 'start', cpu_log_nowait )
441
442             n = isave(2) + jj
443             CALL tridia_substi_overlap( ar1(:,:,:), n )
444
445             CALL cpu_log( log_point_s(6), 'tridia', 'stop' )
446
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
453                CALL cpu_log( log_point_s(8), 'transpo invers', 'start', cpu_log_nowait )
454             ELSE
455                CALL cpu_log( log_point_s(8), 'transpo invers', 'continue', cpu_log_nowait )
456             ENDIF
457
458             CALL transpose_zy( ar1(:,:,:), f_in )
459
460             DO  jnew = 0, ny-1
461                jind = jj + ( nblk + 1 ) * jnew
462                f_inv(:,:,jind) = f_in(:,:,jnew)
463             ENDDO
464
465             CALL cpu_log( log_point_s(8), 'transpo invers', 'pause' )
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
497          ALLOCATE( ar1(0:ny,nxl_y:nxr_y,nzb_y:nzt_y) )
498          ALLOCATE( f_in(nys_x:nyn_x,nzb_x:nzt_x,0:nx) )
499
500          DO  ii = 0, nblk
501
502             CALL cpu_log( log_point_s(7), 'fft_y', 'continue', cpu_log_nowait )
503
504             n = isave(2) + ii
505             nxl_y_bound = isave(2)
506             nxr_y_bound = isave(3)
507
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 )
511
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' )
516             ENDIF
517
518             CALL cpu_log( log_point_s(8), 'transpo invers', 'continue', cpu_log_nowait )
519
520             CALL transpose_yx( ar1(:,:,:), f_in )
521
522             DO  inew = 0, nx-1
523                iind = ii + (nblk+1) * inew
524                f_inv(:,:,iind) = f_in(:,:,inew)
525             ENDDO
526
527             CALL cpu_log( log_point_s(8), 'transpo invers', 'pause' )
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
559          ALLOCATE( ar1(0:nx,nys_x:nyn_x,nzb_x:nzt_x) )
560          ALLOCATE( f_in(nys:nyn,nxl:nxr,1:nz) )
561
562          DO  kk = 1, nblk
563
564             CALL cpu_log( log_point_s(4), 'fft_x', 'continue', cpu_log_nowait )
565
566             n = isave(2) + kk - 1
567             CALL fft_x( ar1(:,:,:), 'backward', f_out_z(:,:,n))
568
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' )
573             ENDIF
574
575             CALL cpu_log( log_point_s(8), 'transpo invers', 'continue', cpu_log_nowait )
576
577             CALL transpose_xz( ar1(:,:,:), f_in )
578
579             DO  knew = 1, nz
580                ki = kk + nblk * (knew-1)
581                f_inv(:,:,ki) = f_in(:,:,knew)
582             ENDDO
583
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' )
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
602       ENDIF
603#endif
604
605#if !__acc_fft_device
606       !$ACC UPDATE DEVICE(ar)
607#endif
608
609       CALL cpu_log( log_point_s(3), 'poisfft', 'stop' )
610
611    END SUBROUTINE poisfft
612
613
614!------------------------------------------------------------------------------!
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.
627!------------------------------------------------------------------------------!
628    SUBROUTINE ffty_tr_yx( f_in, f_out )
629
630       USE control_parameters,                                                 &
631           ONLY:  loop_optimization
632
633       USE cpulog,                                                             &
634           ONLY:  cpu_log, log_point_s
635
636       USE kinds
637
638       USE pegrid
639
640       IMPLICIT NONE
641
642       INTEGER(iwp)            ::  i            !<
643       INTEGER(iwp)            ::  iend         !<
644       INTEGER(iwp)            ::  iouter       !<
645       INTEGER(iwp)            ::  ir           !<
646       INTEGER(iwp)            ::  j            !<
647       INTEGER(iwp)            ::  k            !<
648
649       INTEGER(iwp), PARAMETER ::  stridex = 4  !<
650
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   !<
654
655       REAL(wp), DIMENSION(:,:), ALLOCATABLE   ::  work_ffty      !<
656       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  work_ffty_vec  !<
657
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.
662       CALL cpu_log( log_point_s(7), 'fft_y_1d', 'start' )
663
664       IF ( loop_optimization == 'vector' )  THEN
665
666          ALLOCATE( work_ffty_vec(0:ny+1,1:nz,nxl:nxr) )
667!
668!--       Code optimized for vector processors
669          !$OMP PARALLEL PRIVATE ( i, j, k )
670          !$OMP DO
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
683          !$OMP DO
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
691          !$OMP END PARALLEL
692
693          DEALLOCATE( work_ffty_vec )
694
695       ELSE
696!
697!--       Cache optimized code.
698          ALLOCATE( work_ffty(0:ny,stridex) )
699!
700!--       The i-(x-)direction is split into a strided outer loop and an inner
701!--       loop for better cache performance
702          !$OMP PARALLEL PRIVATE (i,iend,iouter,ir,j,k,work_ffty)
703          !$OMP DO
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
718                   CALL fft_y_1d( work_ffty(:,ir), 'forward' )
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
733          !$OMP END PARALLEL
734
735          DEALLOCATE( work_ffty )
736
737       ENDIF
738
739       CALL cpu_log( log_point_s(7), 'fft_y_1d', 'pause' )
740
741!
742!--    Transpose array
743#if defined( __parallel )
744       CALL cpu_log( log_point_s(32), 'mpi_alltoall', 'start' )
745       IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
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' )
750#endif
751
752    END SUBROUTINE ffty_tr_yx
753
754
755!------------------------------------------------------------------------------!
756! Description:
757! ------------
758!>  Transposition x --> y with a subsequent backward Fourier transformation for
759!>  a 1d-decomposition along x
760!------------------------------------------------------------------------------!
761    SUBROUTINE tr_xy_ffty( f_in, f_out )
762
763       USE control_parameters,                                                 &
764           ONLY:  loop_optimization
765
766       USE cpulog,                                                             &
767           ONLY:  cpu_log, log_point_s
768
769       USE kinds
770
771       USE pegrid
772
773       IMPLICIT NONE
774
775       INTEGER(iwp)            ::  i            !<
776       INTEGER(iwp)            ::  iend         !<
777       INTEGER(iwp)            ::  iouter       !<
778       INTEGER(iwp)            ::  ir           !<
779       INTEGER(iwp)            ::  j            !<
780       INTEGER(iwp)            ::  k            !<
781
782       INTEGER(iwp), PARAMETER ::  stridex = 4  !<
783
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   !<
787
788       REAL(wp), DIMENSION(:,:), ALLOCATABLE   ::  work_ffty         !<
789       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  work_ffty_vec     !<
790
791!
792!--    Transpose array
793#if defined( __parallel )
794       CALL cpu_log( log_point_s(32), 'mpi_alltoall', 'start' )
795       IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
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' )
800#endif
801
802!
803!--    Resort the data in a way that y becomes the first index and carry out the
804!--    backward fft along y.
805       CALL cpu_log( log_point_s(7), 'fft_y_1d', 'continue' )
806
807       IF ( loop_optimization == 'vector' )  THEN
808
809          ALLOCATE( work_ffty_vec(0:ny+1,1:nz,nxl:nxr) )
810!
811!--       Code optimized for vector processors
812          !$OMP PARALLEL PRIVATE ( i, j, k )
813          !$OMP DO
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
822          !$OMP DO
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
834          !$OMP END PARALLEL
835
836          DEALLOCATE( work_ffty_vec )
837
838       ELSE
839!
840!--       Cache optimized code.
841          ALLOCATE( work_ffty(0:ny,stridex) )
842!
843!--       The i-(x-)direction is split into a strided outer loop and an inner
844!--       loop for better cache performance
845          !$OMP PARALLEL PRIVATE ( i, iend, iouter, ir, j, k, work_ffty )
846          !$OMP DO
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
865                   CALL fft_y_1d( work_ffty(:,ir), 'backward' )
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
875          !$OMP END PARALLEL
876
877          DEALLOCATE( work_ffty )
878
879       ENDIF
880
881       CALL cpu_log( log_point_s(7), 'fft_y_1d', 'stop' )
882
883    END SUBROUTINE tr_xy_ffty
884
885
886!------------------------------------------------------------------------------!
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)
895!------------------------------------------------------------------------------!
896    SUBROUTINE fftx_tri_fftx( ar )
897
898       USE control_parameters,                                                 &
899           ONLY:  loop_optimization
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
909       USE pegrid
910
911       IMPLICIT NONE
912
913       INTEGER(iwp) ::  i                   !<
914       INTEGER(iwp) ::  j                   !<
915       INTEGER(iwp) ::  k                   !<
916       INTEGER(iwp) ::  m                   !<
917       INTEGER(iwp) ::  n                   !<
918!$     INTEGER(iwp) ::  omp_get_thread_num  !<
919       INTEGER(iwp) ::  tn                  !<
920
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        !<
925
926
927       CALL cpu_log( log_point_s(33), 'fft_x_1d + tridia', 'start' )
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
937          IF ( loop_optimization == 'vector' )  THEN
938!
939!--          Code optimized for vector processors
940             DO  k = 1, nz
941
942                m = 0
943                DO  n = 1, pdims(1)
944                   DO  i = 1, nnx
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)
961                   DO  i = 1, nnx
962                      work_fftx(m) = ar(i,k,j,n)
963                      m = m + 1
964                   ENDDO
965                ENDDO
966
967                CALL fft_x_1d( work_fftx, 'forward' )
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
981          IF ( loop_optimization == 'vector' )  THEN
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)
990                   DO  i = 1, nnx
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
1007                CALL fft_x_1d( work_fftx, 'backward' )
1008
1009                m = 0
1010                DO  n = 1, pdims(1)
1011                   DO  i = 1, nnx
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
1025       CALL cpu_log( log_point_s(33), 'fft_x_1d + tridia', 'stop' )
1026
1027    END SUBROUTINE fftx_tri_fftx
1028
1029
1030!------------------------------------------------------------------------------!
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).
1039!------------------------------------------------------------------------------!
1040    SUBROUTINE fftx_tr_xy( f_in, f_out )
1041
1042
1043       USE control_parameters,                                                 &
1044           ONLY:  loop_optimization
1045
1046       USE cpulog,                                                             &
1047           ONLY:  cpu_log, log_point_s
1048
1049       USE kinds
1050
1051       USE pegrid
1052
1053       IMPLICIT NONE
1054
1055       INTEGER(iwp) ::  i  !<
1056       INTEGER(iwp) ::  j  !<
1057       INTEGER(iwp) ::  k  !<
1058
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       !<
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.
1068       CALL cpu_log( log_point_s(4), 'fft_x_1d', 'start' )
1069
1070       IF ( loop_optimization == 'vector' )  THEN
1071!
1072!--       Code for vector processors
1073!$OMP     PARALLEL PRIVATE ( i, j, k )
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).
1104!$OMP     PARALLEL PRIVATE (i,j,k)
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
1120                CALL fft_x_1d( work_fftx(0:nx,k,j), 'forward' )
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
1131       CALL cpu_log( log_point_s(4), 'fft_x_1d', 'pause' )
1132
1133!
1134!--    Transpose array
1135#if defined( __parallel )
1136       CALL cpu_log( log_point_s(32), 'mpi_alltoall', 'start' )
1137       IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
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' )
1142#endif
1143
1144    END SUBROUTINE fftx_tr_xy
1145
1146
1147!------------------------------------------------------------------------------!
1148! Description:
1149! ------------
1150!> Transposition y --> x with a subsequent backward Fourier transformation for
1151!> a 1d-decomposition along x.
1152!------------------------------------------------------------------------------!
1153    SUBROUTINE tr_yx_fftx( f_in, f_out )
1154
1155
1156       USE control_parameters,                                                 &
1157           ONLY:  loop_optimization
1158
1159       USE cpulog,                                                             &
1160           ONLY:  cpu_log, log_point_s
1161
1162       USE kinds
1163
1164       USE pegrid
1165
1166       IMPLICIT NONE
1167
1168       INTEGER(iwp) ::  i  !<
1169       INTEGER(iwp) ::  j  !<
1170       INTEGER(iwp) ::  k  !<
1171
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       !<
1176
1177!
1178!--    Transpose array
1179#if defined( __parallel )
1180       CALL cpu_log( log_point_s(32), 'mpi_alltoall', 'start' )
1181       IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
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' )
1186#endif
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.
1192       CALL cpu_log( log_point_s(4), 'fft_x_1d', 'continue' )
1193
1194       IF ( loop_optimization == 'vector' )  THEN
1195!
1196!--       Code optimized for vector processors
1197!$OMP     PARALLEL PRIVATE ( i, j, k )
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).
1226!$OMP     PARALLEL PRIVATE (i,j,k)
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
1235                CALL fft_x_1d( work_fftx(0:nx,k,j), 'backward' )
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
1251       CALL cpu_log( log_point_s(4), 'fft_x_1d', 'stop' )
1252
1253    END SUBROUTINE tr_yx_fftx
1254
1255
1256!------------------------------------------------------------------------------!
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)
1265!------------------------------------------------------------------------------!
1266    SUBROUTINE ffty_tri_ffty( ar )
1267
1268
1269       USE control_parameters,                                                 &
1270           ONLY:  loop_optimization
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
1280       USE pegrid
1281
1282       IMPLICIT NONE
1283
1284       INTEGER(iwp) ::  i                   !<
1285       INTEGER(iwp) ::  j                   !<
1286       INTEGER(iwp) ::  k                   !<
1287       INTEGER(iwp) ::  m                   !<
1288       INTEGER(iwp) ::  n                   !<
1289!$     INTEGER(iwp) ::  omp_get_thread_num  !<
1290       INTEGER(iwp) ::  tn                  !<
1291
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        !<
1296
1297
1298       CALL cpu_log( log_point_s(39), 'fft_y_1d + tridia', 'start' )
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
1303!$OMP  PARALLEL DO PRIVATE ( i, j, k, m, n, tn, work_ffty, work_triy )
1304       DO  i = nxl_y, nxr_y
1305
1306!$        tn = omp_get_thread_num()
1307
1308          IF ( loop_optimization == 'vector' )  THEN
1309!
1310!--          Code optimized for vector processors
1311             DO  k = 1, nz
1312
1313                m = 0
1314                DO  n = 1, pdims(2)
1315                   DO  j = 1, nny
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)
1332                   DO  j = 1, nny
1333                      work_ffty(m) = ar(j,k,i,n)
1334                      m = m + 1
1335                   ENDDO
1336                ENDDO
1337
1338                CALL fft_y_1d( work_ffty, 'forward' )
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
1352          IF ( loop_optimization == 'vector' )  THEN
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)
1361                   DO  j = 1, nny
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
1378                CALL fft_y_1d( work_ffty, 'backward' )
1379
1380                m = 0
1381                DO  n = 1, pdims(2)
1382                   DO  j = 1, nny
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
1396       CALL cpu_log( log_point_s(39), 'fft_y_1d + tridia', 'stop' )
1397
1398    END SUBROUTINE ffty_tri_ffty
1399
1400 END MODULE poisfft_mod
Note: See TracBrowser for help on using the repository browser.