Home

Context Navigation

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

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

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |