Home

Context Navigation

source: palm/trunk/SOURCE/poismg.f90 @ 196

Last change on this file since 196 was 181, checked in by raasch, 16 years ago
bugfixes + adjustments for SGI ICE system
Property svn:keywords set to `Id`
File size: 54.1 KB

Line
1	SUBROUTINE poismg( r )
2
3	!------------------------------------------------------------------------------!
4	! Attention: Loop unrolling and cache optimization in SOR-Red/Black method
5	! still does not bring the expected speedup on ibm! Further work
6	! is required.
7	!
8	! Actual revisions:
9	! -----------------
10	! Bugfix: grid_level+1 has to be used in restrict for flags-array
11	!
12	! Former revisions:
13	! -----------------
14	! $Id: poismg.f90 181 2008-07-30 07:07:47Z raasch $
15	!
16	! 114 2007-10-10 00:03:15Z raasch
17	! Boundary conditions at walls are implicitly set using flag arrays. Only
18	! Neumann BC is allowed. Upper walls are still not realized.
19	! Bottom and top BCs for array f_mg in restrict removed because boundary
20	! values are not needed (right hand side of SOR iteration).
21	!
22	! 75 2007-03-22 09:54:05Z raasch
23	! 2nd+3rd argument removed from exchange horiz
24	!
25	! RCS Log replace by Id keyword, revision history cleaned up
26	!
27	! Revision 1.6 2005/03/26 20:55:54 raasch
28	! Implementation of non-cyclic (Neumann) horizontal boundary conditions,
29	! routine prolong simplified (one call of exchange_horiz spared)
30	!
31	! Revision 1.1 2001/07/20 13:10:51 raasch
32	! Initial revision
33	!
34	!
35	! Description:
36	! ------------
37	! Solves the Poisson equation for the perturbation pressure with a multigrid
38	! V- or W-Cycle scheme.
39	!
40	! This multigrid method was originally developed for PALM by Joerg Uhlenbrock,
41	! September 2000 - July 2001.
42	!------------------------------------------------------------------------------!
43
44	USE arrays_3d
45	USE control_parameters
46	USE cpulog
47	USE grid_variables
48	USE indices
49	USE interfaces
50	USE pegrid
51
52	IMPLICIT NONE
53
54	REAL :: maxerror, maximum_mgcycles, residual_norm
55
56	REAL, DIMENSION(nzb:nzt+1,nys-1:nyn+1,nxl-1:nxr+1) :: r
57
58	REAL, DIMENSION(:,:,:), ALLOCATABLE :: p3
59
60
61	CALL cpu_log( log_point_s(29), 'poismg', 'start' )
62
63
64	!
65	!-- Initialize arrays and variables used in this subroutine
66	ALLOCATE ( p3(nzb:nzt+1,nys-1:nyn+1,nxl-1:nxr+1) )
67
68
69	!
70	!-- Some boundaries have to be added to divergence array
71	CALL exchange_horiz( d )
72	d(nzb,:,:) = d(nzb+1,:,:)
73
74	!
75	!-- Initiation of the multigrid scheme. Does n cycles until the
76	!-- residual is smaller than the given limit. The accuracy of the solution
77	!-- of the poisson equation will increase with the number of cycles.
78	!-- If the number of cycles is preset by the user, this number will be
79	!-- carried out regardless of the accuracy.
80	grid_level_count = 0
81	mgcycles = 0
82	IF ( mg_cycles == -1 ) THEN
83	maximum_mgcycles = 0
84	residual_norm = 1.0
85	ELSE
86	maximum_mgcycles = mg_cycles
87	residual_norm = 0.0
88	ENDIF
89
90	DO WHILE ( residual_norm > residual_limit .OR. &
91	mgcycles < maximum_mgcycles )
92
93	CALL next_mg_level( d, p, p3, r)
94
95	!
96	!-- Calculate the residual if the user has not preset the number of
97	!-- cycles to be performed
98	IF ( maximum_mgcycles == 0 ) THEN
99	CALL resid( d, p, r )
100	maxerror = SUM( r(nzb+1:nzt,nys:nyn,nxl:nxr)**2 )
101	#if defined( __parallel )
102	CALL MPI_ALLREDUCE( maxerror, residual_norm, 1, MPI_REAL, MPI_SUM, &
103	comm2d, ierr)
104	#else
105	residual_norm = maxerror
106	#endif
107	residual_norm = SQRT( residual_norm )
108	ENDIF
109
110	mgcycles = mgcycles + 1
111
112	!
113	!-- If the user has not limited the number of cycles, stop the run in case
114	!-- of insufficient convergence
115	IF ( mgcycles > 1000 .AND. mg_cycles == -1 ) THEN
116	IF ( myid == 0 ) THEN
117	PRINT*, '+++ poismg: no sufficient convergence within 1000 cycles'
118	ENDIF
119	CALL local_stop
120	ENDIF
121
122	ENDDO
123
124	DEALLOCATE( p3 )
125
126	CALL cpu_log( log_point_s(29), 'poismg', 'stop' )
127
128	END SUBROUTINE poismg
129
130
131
132	SUBROUTINE resid( f_mg, p_mg, r )
133
134	!------------------------------------------------------------------------------!
135	! Description:
136	! ------------
137	! Computes the residual of the perturbation pressure.
138	!------------------------------------------------------------------------------!
139
140	USE arrays_3d
141	USE control_parameters
142	USE grid_variables
143	USE indices
144	USE pegrid
145
146	IMPLICIT NONE
147
148	INTEGER :: i, j, k, l
149
150	REAL, DIMENSION(nzb:nzt_mg(grid_level)+1, &
151	nys_mg(grid_level)-1:nyn_mg(grid_level)+1, &
152	nxl_mg(grid_level)-1:nxr_mg(grid_level)+1) :: f_mg, p_mg, r
153
154	!
155	!-- Calculate the residual
156	l = grid_level
157
158	!
159	!-- Choose flag array of this level
160	SELECT CASE ( l )
161	CASE ( 1 )
162	flags => wall_flags_1
163	CASE ( 2 )
164	flags => wall_flags_2
165	CASE ( 3 )
166	flags => wall_flags_3
167	CASE ( 4 )
168	flags => wall_flags_4
169	CASE ( 5 )
170	flags => wall_flags_5
171	CASE ( 6 )
172	flags => wall_flags_6
173	CASE ( 7 )
174	flags => wall_flags_7
175	CASE ( 8 )
176	flags => wall_flags_8
177	CASE ( 9 )
178	flags => wall_flags_9
179	CASE ( 10 )
180	flags => wall_flags_10
181	END SELECT
182
183	!$OMP PARALLEL PRIVATE (i,j,k)
184	!$OMP DO
185	DO i = nxl_mg(l), nxr_mg(l)
186	DO j = nys_mg(l), nyn_mg(l)
187	DO k = nzb+1, nzt_mg(l)
188	r(k,j,i) = f_mg(k,j,i) &
189	- ddx2_mg(l) * &
190	( p_mg(k,j,i+1) + IBITS( flags(k,j,i), 5, 1 ) * &
191	( p_mg(k,j,i) - p_mg(k,j,i+1) ) + &
192	p_mg(k,j,i-1) + IBITS( flags(k,j,i), 4, 1 ) * &
193	( p_mg(k,j,i) - p_mg(k,j,i-1) ) ) &
194	- ddy2_mg(l) * &
195	( p_mg(k,j+1,i) + IBITS( flags(k,j,i), 3, 1 ) * &
196	( p_mg(k,j,i) - p_mg(k,j+1,i) ) + &
197	p_mg(k,j-1,i) + IBITS( flags(k,j,i), 2, 1 ) * &
198	( p_mg(k,j,i) - p_mg(k,j-1,i) ) ) &
199	- f2_mg(k,l) * p_mg(k+1,j,i) &
200	- f3_mg(k,l) * &
201	( p_mg(k-1,j,i) + IBITS( flags(k,j,i), 0, 1 ) * &
202	( p_mg(k,j,i) - p_mg(k-1,j,i) ) ) &
203	+ f1_mg(k,l) * p_mg(k,j,i)
204	!
205	!-- Residual within topography should be zero
206	r(k,j,i) = r(k,j,i) * ( 1.0 - IBITS( flags(k,j,i), 6, 1 ) )
207	ENDDO
208	ENDDO
209	ENDDO
210	!$OMP END PARALLEL
211
212	!
213	!-- Horizontal boundary conditions
214	CALL exchange_horiz( r )
215
216	IF ( bc_lr /= 'cyclic' ) THEN
217	IF ( inflow_l .OR. outflow_l ) r(:,:,nxl_mg(l)-1) = r(:,:,nxl_mg(l))
218	IF ( inflow_r .OR. outflow_r ) r(:,:,nxr_mg(l)+1) = r(:,:,nxr_mg(l))
219	ENDIF
220
221	IF ( bc_ns /= 'cyclic' ) THEN
222	IF ( inflow_n .OR. outflow_n ) r(:,nyn_mg(l)+1,:) = r(:,nyn_mg(l),:)
223	IF ( inflow_s .OR. outflow_s ) r(:,nys_mg(l)-1,:) = r(:,nys_mg(l),:)
224	ENDIF
225
226	!
227	!-- Top boundary condition
228	!-- A Neumann boundary condition for r is implicitly set in routine restrict
229	IF ( ibc_p_t == 1 ) THEN
230	r(nzt_mg(l)+1,:,: ) = r(nzt_mg(l),:,:)
231	ELSE
232	r(nzt_mg(l)+1,:,: ) = 0.0
233	ENDIF
234
235
236	END SUBROUTINE resid
237
238
239
240	SUBROUTINE restrict( f_mg, r )
241
242	!------------------------------------------------------------------------------!
243	! Description:
244	! ------------
245	! Interpolates the residual on the next coarser grid with "full weighting"
246	! scheme
247	!------------------------------------------------------------------------------!
248
249	USE control_parameters
250	USE grid_variables
251	USE indices
252	USE pegrid
253
254	IMPLICIT NONE
255
256	INTEGER :: i, ic, j, jc, k, kc, l
257
258	REAL :: rkjim, rkjip, rkjmi, rkjmim, rkjmip, rkjpi, rkjpim, rkjpip, &
259	rkmji, rkmjim, rkmjip, rkmjmi, rkmjmim, rkmjmip, rkmjpi, rkmjpim, &
260	rkmjpip
261
262	REAL, DIMENSION(nzb:nzt_mg(grid_level)+1, &
263	nys_mg(grid_level)-1:nyn_mg(grid_level)+1, &
264	nxl_mg(grid_level)-1:nxr_mg(grid_level)+1) :: f_mg
265
266	REAL, DIMENSION(nzb:nzt_mg(grid_level+1)+1, &
267	nys_mg(grid_level+1)-1:nyn_mg(grid_level+1)+1, &
268	nxl_mg(grid_level+1)-1:nxr_mg(grid_level+1)+1) :: r
269
270	!
271	!-- Interpolate the residual
272	l = grid_level
273
274	!
275	!-- Choose flag array of the upper level
276	SELECT CASE ( l+1 )
277	CASE ( 1 )
278	flags => wall_flags_1
279	CASE ( 2 )
280	flags => wall_flags_2
281	CASE ( 3 )
282	flags => wall_flags_3
283	CASE ( 4 )
284	flags => wall_flags_4
285	CASE ( 5 )
286	flags => wall_flags_5
287	CASE ( 6 )
288	flags => wall_flags_6
289	CASE ( 7 )
290	flags => wall_flags_7
291	CASE ( 8 )
292	flags => wall_flags_8
293	CASE ( 9 )
294	flags => wall_flags_9
295	CASE ( 10 )
296	flags => wall_flags_10
297	END SELECT
298
299	!$OMP PARALLEL PRIVATE (i,j,k,ic,jc,kc)
300	!$OMP DO
301	DO ic = nxl_mg(l), nxr_mg(l)
302	i = 2*ic
303	DO jc = nys_mg(l), nyn_mg(l)
304	j = 2*jc
305	DO kc = nzb+1, nzt_mg(l)
306	k = 2*kc-1
307	!
308	!-- Use implicit Neumann BCs if the respective gridpoint is inside
309	!-- the building
310	rkjim = r(k,j,i-1) + IBITS( flags(k,j,i-1), 6, 1 ) * &
311	( r(k,j,i) - r(k,j,i-1) )
312	rkjip = r(k,j,i+1) + IBITS( flags(k,j,i+1), 6, 1 ) * &
313	( r(k,j,i) - r(k,j,i+1) )
314	rkjpi = r(k,j+1,i) + IBITS( flags(k,j+1,i), 6, 1 ) * &
315	( r(k,j,i) - r(k,j+1,i) )
316	rkjmi = r(k,j-1,i) + IBITS( flags(k,j-1,i), 6, 1 ) * &
317	( r(k,j,i) - r(k,j-1,i) )
318	rkjmim = r(k,j-1,i-1) + IBITS( flags(k,j-1,i-1), 6, 1 ) * &
319	( r(k,j,i) - r(k,j-1,i-1) )
320	rkjpim = r(k,j+1,i-1) + IBITS( flags(k,j+1,i-1), 6, 1 ) * &
321	( r(k,j,i) - r(k,j+1,i-1) )
322	rkjmip = r(k,j-1,i+1) + IBITS( flags(k,j-1,i+1), 6, 1 ) * &
323	( r(k,j,i) - r(k,j-1,i+1) )
324	rkjpip = r(k,j+1,i+1) + IBITS( flags(k,j+1,i+1), 6, 1 ) * &
325	( r(k,j,i) - r(k,j+1,i+1) )
326	rkmji = r(k-1,j,i) + IBITS( flags(k-1,j,i), 6, 1 ) * &
327	( r(k,j,i) - r(k-1,j,i) )
328	rkmjim = r(k-1,j,i-1) + IBITS( flags(k-1,j,i-1), 6, 1 ) * &
329	( r(k,j,i) - r(k-1,j,i-1) )
330	rkmjip = r(k-1,j,i+1) + IBITS( flags(k-1,j,i+1), 6, 1 ) * &
331	( r(k,j,i) - r(k-1,j,i+1) )
332	rkmjpi = r(k-1,j+1,i) + IBITS( flags(k-1,j+1,i), 6, 1 ) * &
333	( r(k,j,i) - r(k-1,j+1,i) )
334	rkmjmi = r(k-1,j-1,i) + IBITS( flags(k-1,j-1,i), 6, 1 ) * &
335	( r(k,j,i) - r(k-1,j-1,i) )
336	rkmjmim = r(k-1,j-1,i-1) + IBITS( flags(k-1,j-1,i-1), 6, 1 ) * &
337	( r(k,j,i) - r(k-1,j-1,i-1) )
338	rkmjpim = r(k-1,j+1,i-1) + IBITS( flags(k-1,j+1,i-1), 6, 1 ) * &
339	( r(k,j,i) - r(k-1,j+1,i-1) )
340	rkmjmip = r(k-1,j-1,i+1) + IBITS( flags(k-1,j-1,i+1), 6, 1 ) * &
341	( r(k,j,i) - r(k-1,j-1,i+1) )
342	rkmjpip = r(k-1,j+1,i+1) + IBITS( flags(k-1,j+1,i+1), 6, 1 ) * &
343	( r(k,j,i) - r(k-1,j+1,i+1) )
344
345	f_mg(kc,jc,ic) = 1.0 / 64.0 * ( &
346	8.0 * r(k,j,i) &
347	+ 4.0 * ( rkjim + rkjip + &
348	rkjpi + rkjmi ) &
349	+ 2.0 * ( rkjmim + rkjpim + &
350	rkjmip + rkjpip ) &
351	+ 4.0 * rkmji &
352	+ 2.0 * ( rkmjim + rkmjim + &
353	rkmjpi + rkmjmi ) &
354	+ ( rkmjmim + rkmjpim + &
355	rkmjmip + rkmjpip ) &
356	+ 4.0 * r(k+1,j,i) &
357	+ 2.0 * ( r(k+1,j,i-1) + r(k+1,j,i+1) + &
358	r(k+1,j+1,i) + r(k+1,j-1,i) ) &
359	+ ( r(k+1,j-1,i-1) + r(k+1,j+1,i-1) + &
360	r(k+1,j-1,i+1) + r(k+1,j+1,i+1) ) &
361	)
362
363	! f_mg(kc,jc,ic) = 1.0 / 64.0 * ( &
364	! 8.0 * r(k,j,i) &
365	! + 4.0 * ( r(k,j,i-1) + r(k,j,i+1) + &
366	! r(k,j+1,i) + r(k,j-1,i) ) &
367	! + 2.0 * ( r(k,j-1,i-1) + r(k,j+1,i-1) + &
368	! r(k,j-1,i+1) + r(k,j+1,i+1) ) &
369	! + 4.0 * r(k-1,j,i) &
370	! + 2.0 * ( r(k-1,j,i-1) + r(k-1,j,i+1) + &
371	! r(k-1,j+1,i) + r(k-1,j-1,i) ) &
372	! + ( r(k-1,j-1,i-1) + r(k-1,j+1,i-1) + &
373	! r(k-1,j-1,i+1) + r(k-1,j+1,i+1) ) &
374	! + 4.0 * r(k+1,j,i) &
375	! + 2.0 * ( r(k+1,j,i-1) + r(k+1,j,i+1) + &
376	! r(k+1,j+1,i) + r(k+1,j-1,i) ) &
377	! + ( r(k+1,j-1,i-1) + r(k+1,j+1,i-1) + &
378	! r(k+1,j-1,i+1) + r(k+1,j+1,i+1) ) &
379	! )
380	ENDDO
381	ENDDO
382	ENDDO
383	!$OMP END PARALLEL
384
385	!
386	!-- Horizontal boundary conditions
387	CALL exchange_horiz( f_mg )
388
389	IF ( bc_lr /= 'cyclic' ) THEN
390	IF (inflow_l .OR. outflow_l) f_mg(:,:,nxl_mg(l)-1) = f_mg(:,:,nxl_mg(l))
391	IF (inflow_r .OR. outflow_r) f_mg(:,:,nxr_mg(l)+1) = f_mg(:,:,nxr_mg(l))
392	ENDIF
393
394	IF ( bc_ns /= 'cyclic' ) THEN
395	IF (inflow_n .OR. outflow_n) f_mg(:,nyn_mg(l)+1,:) = f_mg(:,nyn_mg(l),:)
396	IF (inflow_s .OR. outflow_s) f_mg(:,nys_mg(l)-1,:) = f_mg(:,nys_mg(l),:)
397	ENDIF
398
399	!
400	!-- Bottom and top boundary conditions
401	! IF ( ibc_p_b == 1 ) THEN
402	! f_mg(nzb,:,: ) = f_mg(nzb+1,:,:)
403	! ELSE
404	! f_mg(nzb,:,: ) = 0.0
405	! ENDIF
406	!
407	! IF ( ibc_p_t == 1 ) THEN
408	! f_mg(nzt_mg(l)+1,:,: ) = f_mg(nzt_mg(l),:,:)
409	! ELSE
410	! f_mg(nzt_mg(l)+1,:,: ) = 0.0
411	! ENDIF
412
413
414	END SUBROUTINE restrict
415
416
417
418	SUBROUTINE prolong( p, temp )
419
420	!------------------------------------------------------------------------------!
421	! Description:
422	! ------------
423	! Interpolates the correction of the perturbation pressure
424	! to the next finer grid.
425	!------------------------------------------------------------------------------!
426
427	USE control_parameters
428	USE pegrid
429	USE indices
430
431	IMPLICIT NONE
432
433	INTEGER :: i, j, k, l
434
435	REAL, DIMENSION(nzb:nzt_mg(grid_level-1)+1, &
436	nys_mg(grid_level-1)-1:nyn_mg(grid_level-1)+1, &
437	nxl_mg(grid_level-1)-1:nxr_mg(grid_level-1)+1 ) :: p
438
439	REAL, DIMENSION(nzb:nzt_mg(grid_level)+1, &
440	nys_mg(grid_level)-1:nyn_mg(grid_level)+1, &
441	nxl_mg(grid_level)-1:nxr_mg(grid_level)+1) :: temp
442
443
444	!
445	!-- First, store elements of the coarser grid on the next finer grid
446	l = grid_level
447
448	!$OMP PARALLEL PRIVATE (i,j,k)
449	!$OMP DO
450	DO i = nxl_mg(l-1), nxr_mg(l-1)
451	DO j = nys_mg(l-1), nyn_mg(l-1)
452	!CDIR NODEP
453	DO k = nzb+1, nzt_mg(l-1)
454	!
455	!-- Points of the coarse grid are directly stored on the next finer
456	!-- grid
457	temp(2k-1,2j,2*i) = p(k,j,i)
458	!
459	!-- Points between two coarse-grid points
460	temp(2k-1,2j,2i+1) = 0.5 ( p(k,j,i) + p(k,j,i+1) )
461	temp(2k-1,2j+1,2i) = 0.5 ( p(k,j,i) + p(k,j+1,i) )
462	temp(2k,2j,2i) = 0.5 ( p(k,j,i) + p(k+1,j,i) )
463	!
464	!-- Points in the center of the planes stretched by four points
465	!-- of the coarse grid cube
466	temp(2k-1,2j+1,2i+1) = 0.25 ( p(k,j,i) + p(k,j,i+1) + &
467	p(k,j+1,i) + p(k,j+1,i+1) )
468	temp(2k,2j,2i+1) = 0.25 ( p(k,j,i) + p(k,j,i+1) + &
469	p(k+1,j,i) + p(k+1,j,i+1) )
470	temp(2k,2j+1,2i) = 0.25 ( p(k,j,i) + p(k,j+1,i) + &
471	p(k+1,j,i) + p(k+1,j+1,i) )
472	!
473	!-- Points in the middle of coarse grid cube
474	temp(2k,2j+1,2i+1) = 0.125 ( p(k,j,i) + p(k,j,i+1) + &
475	p(k,j+1,i) + p(k,j+1,i+1) + &
476	p(k+1,j,i) + p(k+1,j,i+1) + &
477	p(k+1,j+1,i) + p(k+1,j+1,i+1) )
478	ENDDO
479	ENDDO
480	ENDDO
481	!$OMP END PARALLEL
482
483	!
484	!-- Horizontal boundary conditions
485	CALL exchange_horiz( temp )
486
487	IF ( bc_lr /= 'cyclic' ) THEN
488	IF (inflow_l .OR. outflow_l) temp(:,:,nxl_mg(l)-1) = temp(:,:,nxl_mg(l))
489	IF (inflow_r .OR. outflow_r) temp(:,:,nxr_mg(l)+1) = temp(:,:,nxr_mg(l))
490	ENDIF
491
492	IF ( bc_ns /= 'cyclic' ) THEN
493	IF (inflow_n .OR. outflow_n) temp(:,nyn_mg(l)+1,:) = temp(:,nyn_mg(l),:)
494	IF (inflow_s .OR. outflow_s) temp(:,nys_mg(l)-1,:) = temp(:,nys_mg(l),:)
495	ENDIF
496
497	!
498	!-- Bottom and top boundary conditions
499	IF ( ibc_p_b == 1 ) THEN
500	temp(nzb,:,: ) = temp(nzb+1,:,:)
501	ELSE
502	temp(nzb,:,: ) = 0.0
503	ENDIF
504
505	IF ( ibc_p_t == 1 ) THEN
506	temp(nzt_mg(l)+1,:,: ) = temp(nzt_mg(l),:,:)
507	ELSE
508	temp(nzt_mg(l)+1,:,: ) = 0.0
509	ENDIF
510
511
512	END SUBROUTINE prolong
513
514
515	SUBROUTINE redblack( f_mg, p_mg )
516
517	!------------------------------------------------------------------------------!
518	! Description:
519	! ------------
520	! Relaxation method for the multigrid scheme. A Gauss-Seidel iteration with
521	! 3D-Red-Black decomposition (GS-RB) is used.
522	!------------------------------------------------------------------------------!
523
524	USE arrays_3d
525	USE control_parameters
526	USE cpulog
527	USE grid_variables
528	USE indices
529	USE interfaces
530	USE pegrid
531
532	IMPLICIT NONE
533
534	INTEGER :: colour, i, ic, j, jc, jj, k, l, n
535
536	LOGICAL :: unroll
537
538	REAL :: wall_left, wall_north, wall_right, wall_south, wall_total, wall_top
539
540	REAL, DIMENSION(nzb:nzt_mg(grid_level)+1, &
541	nys_mg(grid_level)-1:nyn_mg(grid_level)+1, &
542	nxl_mg(grid_level)-1:nxr_mg(grid_level)+1) :: f_mg, p_mg
543
544
545	l = grid_level
546
547	!
548	!-- Choose flag array of this level
549	SELECT CASE ( l )
550	CASE ( 1 )
551	flags => wall_flags_1
552	CASE ( 2 )
553	flags => wall_flags_2
554	CASE ( 3 )
555	flags => wall_flags_3
556	CASE ( 4 )
557	flags => wall_flags_4
558	CASE ( 5 )
559	flags => wall_flags_5
560	CASE ( 6 )
561	flags => wall_flags_6
562	CASE ( 7 )
563	flags => wall_flags_7
564	CASE ( 8 )
565	flags => wall_flags_8
566	CASE ( 9 )
567	flags => wall_flags_9
568	CASE ( 10 )
569	flags => wall_flags_10
570	END SELECT
571
572	unroll = ( MOD( nyn_mg(l)-nys_mg(l)+1, 4 ) == 0 .AND. &
573	MOD( nxr_mg(l)-nxl_mg(l)+1, 2 ) == 0 )
574
575	DO n = 1, ngsrb
576
577	DO colour = 1, 2
578
579	IF ( .NOT. unroll ) THEN
580	CALL cpu_log( log_point_s(36), 'redblack_no_unroll', 'start' )
581
582	!
583	!-- Without unrolling of loops, no cache optimization
584	DO i = nxl_mg(l), nxr_mg(l), 2
585	DO j = nys_mg(l) + 2 - colour, nyn_mg(l), 2
586	DO k = nzb+1, nzt_mg(l), 2
587	! p_mg(k,j,i) = 1.0 / f1_mg(k,l) * ( &
588	! ddx2_mg(l) * ( p_mg(k,j,i+1) + p_mg(k,j,i-1) ) &
589	! + ddy2_mg(l) * ( p_mg(k,j+1,i) + p_mg(k,j-1,i) ) &
590	! + f2_mg(k,l) * p_mg(k+1,j,i) &
591	! + f3_mg(k,l) * p_mg(k-1,j,i) - f_mg(k,j,i) &
592	! )
593
594	p_mg(k,j,i) = 1.0 / f1_mg(k,l) * ( &
595	ddx2_mg(l) * &
596	( p_mg(k,j,i+1) + IBITS( flags(k,j,i), 5, 1 ) * &
597	( p_mg(k,j,i) - p_mg(k,j,i+1) ) + &
598	p_mg(k,j,i-1) + IBITS( flags(k,j,i), 4, 1 ) * &
599	( p_mg(k,j,i) - p_mg(k,j,i-1) ) ) &
600	+ ddy2_mg(l) * &
601	( p_mg(k,j+1,i) + IBITS( flags(k,j,i), 3, 1 ) * &
602	( p_mg(k,j,i) - p_mg(k,j+1,i) ) + &
603	p_mg(k,j-1,i) + IBITS( flags(k,j,i), 2, 1 ) * &
604	( p_mg(k,j,i) - p_mg(k,j-1,i) ) ) &
605	+ f2_mg(k,l) * p_mg(k+1,j,i) &
606	+ f3_mg(k,l) * &
607	( p_mg(k-1,j,i) + IBITS( flags(k,j,i), 0, 1 ) * &
608	( p_mg(k,j,i) - p_mg(k-1,j,i) ) ) &
609	- f_mg(k,j,i) )
610	ENDDO
611	ENDDO
612	ENDDO
613
614	DO i = nxl_mg(l)+1, nxr_mg(l), 2
615	DO j = nys_mg(l) + (colour-1), nyn_mg(l), 2
616	DO k = nzb+1, nzt_mg(l), 2
617	p_mg(k,j,i) = 1.0 / f1_mg(k,l) * ( &
618	ddx2_mg(l) * &
619	( p_mg(k,j,i+1) + IBITS( flags(k,j,i), 5, 1 ) * &
620	( p_mg(k,j,i) - p_mg(k,j,i+1) ) + &
621	p_mg(k,j,i-1) + IBITS( flags(k,j,i), 4, 1 ) * &
622	( p_mg(k,j,i) - p_mg(k,j,i-1) ) ) &
623	+ ddy2_mg(l) * &
624	( p_mg(k,j+1,i) + IBITS( flags(k,j,i), 3, 1 ) * &
625	( p_mg(k,j,i) - p_mg(k,j+1,i) ) + &
626	p_mg(k,j-1,i) + IBITS( flags(k,j,i), 2, 1 ) * &
627	( p_mg(k,j,i) - p_mg(k,j-1,i) ) ) &
628	+ f2_mg(k,l) * p_mg(k+1,j,i) &
629	+ f3_mg(k,l) * &
630	( p_mg(k-1,j,i) + IBITS( flags(k,j,i), 0, 1 ) * &
631	( p_mg(k,j,i) - p_mg(k-1,j,i) ) ) &
632	- f_mg(k,j,i) )
633	ENDDO
634	ENDDO
635	ENDDO
636
637	DO i = nxl_mg(l), nxr_mg(l), 2
638	DO j = nys_mg(l) + (colour-1), nyn_mg(l), 2
639	DO k = nzb+2, nzt_mg(l), 2
640	p_mg(k,j,i) = 1.0 / f1_mg(k,l) * ( &
641	ddx2_mg(l) * &
642	( p_mg(k,j,i+1) + IBITS( flags(k,j,i), 5, 1 ) * &
643	( p_mg(k,j,i) - p_mg(k,j,i+1) ) + &
644	p_mg(k,j,i-1) + IBITS( flags(k,j,i), 4, 1 ) * &
645	( p_mg(k,j,i) - p_mg(k,j,i-1) ) ) &
646	+ ddy2_mg(l) * &
647	( p_mg(k,j+1,i) + IBITS( flags(k,j,i), 3, 1 ) * &
648	( p_mg(k,j,i) - p_mg(k,j+1,i) ) + &
649	p_mg(k,j-1,i) + IBITS( flags(k,j,i), 2, 1 ) * &
650	( p_mg(k,j,i) - p_mg(k,j-1,i) ) ) &
651	+ f2_mg(k,l) * p_mg(k+1,j,i) &
652	+ f3_mg(k,l) * &
653	( p_mg(k-1,j,i) + IBITS( flags(k,j,i), 0, 1 ) * &
654	( p_mg(k,j,i) - p_mg(k-1,j,i) ) ) &
655	- f_mg(k,j,i) )
656	ENDDO
657	ENDDO
658	ENDDO
659
660	DO i = nxl_mg(l)+1, nxr_mg(l), 2
661	DO j = nys_mg(l) + 2 - colour, nyn_mg(l), 2
662	DO k = nzb+2, nzt_mg(l), 2
663	p_mg(k,j,i) = 1.0 / f1_mg(k,l) * ( &
664	ddx2_mg(l) * &
665	( p_mg(k,j,i+1) + IBITS( flags(k,j,i), 5, 1 ) * &
666	( p_mg(k,j,i) - p_mg(k,j,i+1) ) + &
667	p_mg(k,j,i-1) + IBITS( flags(k,j,i), 4, 1 ) * &
668	( p_mg(k,j,i) - p_mg(k,j,i-1) ) ) &
669	+ ddy2_mg(l) * &
670	( p_mg(k,j+1,i) + IBITS( flags(k,j,i), 3, 1 ) * &
671	( p_mg(k,j,i) - p_mg(k,j+1,i) ) + &
672	p_mg(k,j-1,i) + IBITS( flags(k,j,i), 2, 1 ) * &
673	( p_mg(k,j,i) - p_mg(k,j-1,i) ) ) &
674	+ f2_mg(k,l) * p_mg(k+1,j,i) &
675	+ f3_mg(k,l) * &
676	( p_mg(k-1,j,i) + IBITS( flags(k,j,i), 0, 1 ) * &
677	( p_mg(k,j,i) - p_mg(k-1,j,i) ) ) &
678	- f_mg(k,j,i) )
679	ENDDO
680	ENDDO
681	ENDDO
682	CALL cpu_log( log_point_s(36), 'redblack_no_unroll', 'stop' )
683
684	ELSE
685
686	!
687	!-- Loop unrolling along y, only one i loop for better cache use
688	CALL cpu_log( log_point_s(38), 'redblack_unroll', 'start' )
689	DO ic = nxl_mg(l), nxr_mg(l), 2
690	DO jc = nys_mg(l), nyn_mg(l), 4
691	i = ic
692	jj = jc+2-colour
693	DO k = nzb+1, nzt_mg(l), 2
694	j = jj
695	p_mg(k,j,i) = 1.0 / f1_mg(k,l) * ( &
696	ddx2_mg(l) * &
697	( p_mg(k,j,i+1) + IBITS( flags(k,j,i), 5, 1 ) * &
698	( p_mg(k,j,i) - p_mg(k,j,i+1) ) + &
699	p_mg(k,j,i-1) + IBITS( flags(k,j,i), 4, 1 ) * &
700	( p_mg(k,j,i) - p_mg(k,j,i-1) ) ) &
701	+ ddy2_mg(l) * &
702	( p_mg(k,j+1,i) + IBITS( flags(k,j,i), 3, 1 ) * &
703	( p_mg(k,j,i) - p_mg(k,j+1,i) ) + &
704	p_mg(k,j-1,i) + IBITS( flags(k,j,i), 2, 1 ) * &
705	( p_mg(k,j,i) - p_mg(k,j-1,i) ) ) &
706	+ f2_mg(k,l) * p_mg(k+1,j,i) &
707	+ f3_mg(k,l) * &
708	( p_mg(k-1,j,i) + IBITS( flags(k,j,i), 0, 1 ) * &
709	( p_mg(k,j,i) - p_mg(k-1,j,i) ) ) &
710	- f_mg(k,j,i) )
711	j = jj+2
712	p_mg(k,j,i) = 1.0 / f1_mg(k,l) * ( &
713	ddx2_mg(l) * &
714	( p_mg(k,j,i+1) + IBITS( flags(k,j,i), 5, 1 ) * &
715	( p_mg(k,j,i) - p_mg(k,j,i+1) ) + &
716	p_mg(k,j,i-1) + IBITS( flags(k,j,i), 4, 1 ) * &
717	( p_mg(k,j,i) - p_mg(k,j,i-1) ) ) &
718	+ ddy2_mg(l) * &
719	( p_mg(k,j+1,i) + IBITS( flags(k,j,i), 3, 1 ) * &
720	( p_mg(k,j,i) - p_mg(k,j+1,i) ) + &
721	p_mg(k,j-1,i) + IBITS( flags(k,j,i), 2, 1 ) * &
722	( p_mg(k,j,i) - p_mg(k,j-1,i) ) ) &
723	+ f2_mg(k,l) * p_mg(k+1,j,i) &
724	+ f3_mg(k,l) * &
725	( p_mg(k-1,j,i) + IBITS( flags(k,j,i), 0, 1 ) * &
726	( p_mg(k,j,i) - p_mg(k-1,j,i) ) ) &
727	- f_mg(k,j,i) )
728	ENDDO
729
730	i = ic+1
731	jj = jc+colour-1
732	DO k = nzb+1, nzt_mg(l), 2
733	j =jj
734	p_mg(k,j,i) = 1.0 / f1_mg(k,l) * ( &
735	ddx2_mg(l) * &
736	( p_mg(k,j,i+1) + IBITS( flags(k,j,i), 5, 1 ) * &
737	( p_mg(k,j,i) - p_mg(k,j,i+1) ) + &
738	p_mg(k,j,i-1) + IBITS( flags(k,j,i), 4, 1 ) * &
739	( p_mg(k,j,i) - p_mg(k,j,i-1) ) ) &
740	+ ddy2_mg(l) * &
741	( p_mg(k,j+1,i) + IBITS( flags(k,j,i), 3, 1 ) * &
742	( p_mg(k,j,i) - p_mg(k,j+1,i) ) + &
743	p_mg(k,j-1,i) + IBITS( flags(k,j,i), 2, 1 ) * &
744	( p_mg(k,j,i) - p_mg(k,j-1,i) ) ) &
745	+ f2_mg(k,l) * p_mg(k+1,j,i) &
746	+ f3_mg(k,l) * &
747	( p_mg(k-1,j,i) + IBITS( flags(k,j,i), 0, 1 ) * &
748	( p_mg(k,j,i) - p_mg(k-1,j,i) ) ) &
749	- f_mg(k,j,i) )
750	j = jj+2
751	p_mg(k,j,i) = 1.0 / f1_mg(k,l) * ( &
752	ddx2_mg(l) * &
753	( p_mg(k,j,i+1) + IBITS( flags(k,j,i), 5, 1 ) * &
754	( p_mg(k,j,i) - p_mg(k,j,i+1) ) + &
755	p_mg(k,j,i-1) + IBITS( flags(k,j,i), 4, 1 ) * &
756	( p_mg(k,j,i) - p_mg(k,j,i-1) ) ) &
757	+ ddy2_mg(l) * &
758	( p_mg(k,j+1,i) + IBITS( flags(k,j,i), 3, 1 ) * &
759	( p_mg(k,j,i) - p_mg(k,j+1,i) ) + &
760	p_mg(k,j-1,i) + IBITS( flags(k,j,i), 2, 1 ) * &
761	( p_mg(k,j,i) - p_mg(k,j-1,i) ) ) &
762	+ f2_mg(k,l) * p_mg(k+1,j,i) &
763	+ f3_mg(k,l) * &
764	( p_mg(k-1,j,i) + IBITS( flags(k,j,i), 0, 1 ) * &
765	( p_mg(k,j,i) - p_mg(k-1,j,i) ) ) &
766	- f_mg(k,j,i) )
767	ENDDO
768
769	i = ic
770	jj = jc+colour-1
771	DO k = nzb+2, nzt_mg(l), 2
772	j =jj
773	p_mg(k,j,i) = 1.0 / f1_mg(k,l) * ( &
774	ddx2_mg(l) * &
775	( p_mg(k,j,i+1) + IBITS( flags(k,j,i), 5, 1 ) * &
776	( p_mg(k,j,i) - p_mg(k,j,i+1) ) + &
777	p_mg(k,j,i-1) + IBITS( flags(k,j,i), 4, 1 ) * &
778	( p_mg(k,j,i) - p_mg(k,j,i-1) ) ) &
779	+ ddy2_mg(l) * &
780	( p_mg(k,j+1,i) + IBITS( flags(k,j,i), 3, 1 ) * &
781	( p_mg(k,j,i) - p_mg(k,j+1,i) ) + &
782	p_mg(k,j-1,i) + IBITS( flags(k,j,i), 2, 1 ) * &
783	( p_mg(k,j,i) - p_mg(k,j-1,i) ) ) &
784	+ f2_mg(k,l) * p_mg(k+1,j,i) &
785	+ f3_mg(k,l) * &
786	( p_mg(k-1,j,i) + IBITS( flags(k,j,i), 0, 1 ) * &
787	( p_mg(k,j,i) - p_mg(k-1,j,i) ) ) &
788	- f_mg(k,j,i) )
789	j = jj+2
790	p_mg(k,j,i) = 1.0 / f1_mg(k,l) * ( &
791	ddx2_mg(l) * &
792	( p_mg(k,j,i+1) + IBITS( flags(k,j,i), 5, 1 ) * &
793	( p_mg(k,j,i) - p_mg(k,j,i+1) ) + &
794	p_mg(k,j,i-1) + IBITS( flags(k,j,i), 4, 1 ) * &
795	( p_mg(k,j,i) - p_mg(k,j,i-1) ) ) &
796	+ ddy2_mg(l) * &
797	( p_mg(k,j+1,i) + IBITS( flags(k,j,i), 3, 1 ) * &
798	( p_mg(k,j,i) - p_mg(k,j+1,i) ) + &
799	p_mg(k,j-1,i) + IBITS( flags(k,j,i), 2, 1 ) * &
800	( p_mg(k,j,i) - p_mg(k,j-1,i) ) ) &
801	+ f2_mg(k,l) * p_mg(k+1,j,i) &
802	+ f3_mg(k,l) * &
803	( p_mg(k-1,j,i) + IBITS( flags(k,j,i), 0, 1 ) * &
804	( p_mg(k,j,i) - p_mg(k-1,j,i) ) ) &
805	- f_mg(k,j,i) )
806	ENDDO
807
808	i = ic+1
809	jj = jc+2-colour
810	DO k = nzb+2, nzt_mg(l), 2
811	j =jj
812	p_mg(k,j,i) = 1.0 / f1_mg(k,l) * ( &
813	ddx2_mg(l) * &
814	( p_mg(k,j,i+1) + IBITS( flags(k,j,i), 5, 1 ) * &
815	( p_mg(k,j,i) - p_mg(k,j,i+1) ) + &
816	p_mg(k,j,i-1) + IBITS( flags(k,j,i), 4, 1 ) * &
817	( p_mg(k,j,i) - p_mg(k,j,i-1) ) ) &
818	+ ddy2_mg(l) * &
819	( p_mg(k,j+1,i) + IBITS( flags(k,j,i), 3, 1 ) * &
820	( p_mg(k,j,i) - p_mg(k,j+1,i) ) + &
821	p_mg(k,j-1,i) + IBITS( flags(k,j,i), 2, 1 ) * &
822	( p_mg(k,j,i) - p_mg(k,j-1,i) ) ) &
823	+ f2_mg(k,l) * p_mg(k+1,j,i) &
824	+ f3_mg(k,l) * &
825	( p_mg(k-1,j,i) + IBITS( flags(k,j,i), 0, 1 ) * &
826	( p_mg(k,j,i) - p_mg(k-1,j,i) ) ) &
827	- f_mg(k,j,i) )
828	j = jj+2
829	p_mg(k,j,i) = 1.0 / f1_mg(k,l) * ( &
830	ddx2_mg(l) * &
831	( p_mg(k,j,i+1) + IBITS( flags(k,j,i), 5, 1 ) * &
832	( p_mg(k,j,i) - p_mg(k,j,i+1) ) + &
833	p_mg(k,j,i-1) + IBITS( flags(k,j,i), 4, 1 ) * &
834	( p_mg(k,j,i) - p_mg(k,j,i-1) ) ) &
835	+ ddy2_mg(l) * &
836	( p_mg(k,j+1,i) + IBITS( flags(k,j,i), 3, 1 ) * &
837	( p_mg(k,j,i) - p_mg(k,j+1,i) ) + &
838	p_mg(k,j-1,i) + IBITS( flags(k,j,i), 2, 1 ) * &
839	( p_mg(k,j,i) - p_mg(k,j-1,i) ) ) &
840	+ f2_mg(k,l) * p_mg(k+1,j,i) &
841	+ f3_mg(k,l) * &
842	( p_mg(k-1,j,i) + IBITS( flags(k,j,i), 0, 1 ) * &
843	( p_mg(k,j,i) - p_mg(k-1,j,i) ) ) &
844	- f_mg(k,j,i) )
845	ENDDO
846
847	ENDDO
848	ENDDO
849	CALL cpu_log( log_point_s(38), 'redblack_unroll', 'stop' )
850
851	ENDIF
852
853	!
854	!-- Horizontal boundary conditions
855	CALL exchange_horiz( p_mg )
856
857	IF ( bc_lr /= 'cyclic' ) THEN
858	IF ( inflow_l .OR. outflow_l ) THEN
859	p_mg(:,:,nxl_mg(l)-1) = p_mg(:,:,nxl_mg(l))
860	ENDIF
861	IF ( inflow_r .OR. outflow_r ) THEN
862	p_mg(:,:,nxr_mg(l)+1) = p_mg(:,:,nxr_mg(l))
863	ENDIF
864	ENDIF
865
866	IF ( bc_ns /= 'cyclic' ) THEN
867	IF ( inflow_n .OR. outflow_n ) THEN
868	p_mg(:,nyn_mg(l)+1,:) = p_mg(:,nyn_mg(l),:)
869	ENDIF
870	IF ( inflow_s .OR. outflow_s ) THEN
871	p_mg(:,nys_mg(l)-1,:) = p_mg(:,nys_mg(l),:)
872	ENDIF
873	ENDIF
874
875	!
876	!-- Bottom and top boundary conditions
877	IF ( ibc_p_b == 1 ) THEN
878	p_mg(nzb,:,: ) = p_mg(nzb+1,:,:)
879	ELSE
880	p_mg(nzb,:,: ) = 0.0
881	ENDIF
882
883	IF ( ibc_p_t == 1 ) THEN
884	p_mg(nzt_mg(l)+1,:,: ) = p_mg(nzt_mg(l),:,:)
885	ELSE
886	p_mg(nzt_mg(l)+1,:,: ) = 0.0
887	ENDIF
888
889	ENDDO
890
891	ENDDO
892
893	!
894	!-- Set pressure within topography and at the topography surfaces
895	!$OMP PARALLEL PRIVATE (i,j,k,wall_left,wall_north,wall_right,wall_south,wall_top,wall_total)
896	!$OMP DO
897	DO i = nxl_mg(l), nxr_mg(l)
898	DO j = nys_mg(l), nyn_mg(l)
899	DO k = nzb, nzt_mg(l)
900	!
901	!-- First, set pressure inside topography to zero
902	p_mg(k,j,i) = p_mg(k,j,i) * ( 1.0 - IBITS( flags(k,j,i), 6, 1 ) )
903	!
904	!-- Second, determine if the gridpoint inside topography is adjacent
905	!-- to a wall and set its value to a value given by the average of
906	!-- those values obtained from Neumann boundary condition
907	wall_left = IBITS( flags(k,j,i-1), 5, 1 )
908	wall_right = IBITS( flags(k,j,i+1), 4, 1 )
909	wall_south = IBITS( flags(k,j-1,i), 3, 1 )
910	wall_north = IBITS( flags(k,j+1,i), 2, 1 )
911	wall_top = IBITS( flags(k+1,j,i), 0, 1 )
912	wall_total = wall_left + wall_right + wall_south + wall_north + &
913	wall_top
914
915	IF ( wall_total > 0.0 ) THEN
916	p_mg(k,j,i) = 1.0 / wall_total * &
917	( wall_left * p_mg(k,j,i-1) + &
918	wall_right * p_mg(k,j,i+1) + &
919	wall_south * p_mg(k,j-1,i) + &
920	wall_north * p_mg(k,j+1,i) + &
921	wall_top * p_mg(k+1,j,i) )
922	ENDIF
923	ENDDO
924	ENDDO
925	ENDDO
926	!$OMP END PARALLEL
927
928	!
929	!-- One more time horizontal boundary conditions
930	CALL exchange_horiz( p_mg )
931
932	END SUBROUTINE redblack
933
934
935
936	SUBROUTINE mg_gather( f2, f2_sub )
937
938	USE control_parameters
939	USE cpulog
940	USE indices
941	USE interfaces
942	USE pegrid
943
944	IMPLICIT NONE
945
946	INTEGER :: n, nwords, sender
947
948	REAL, DIMENSION(nzb:nzt_mg(grid_level)+1, &
949	nys_mg(grid_level)-1:nyn_mg(grid_level)+1, &
950	nxl_mg(grid_level)-1:nxr_mg(grid_level)+1) :: f2
951
952	REAL, DIMENSION(nzb:mg_loc_ind(5,myid)+1, &
953	mg_loc_ind(3,myid)-1:mg_loc_ind(4,myid)+1, &
954	mg_loc_ind(1,myid)-1:mg_loc_ind(2,myid)+1) :: f2_sub
955
956	!
957	!-- Find out the number of array elements of the subdomain array
958	nwords = SIZE( f2_sub )
959
960	#if defined( __parallel )
961	CALL cpu_log( log_point_s(34), 'mg_gather', 'start' )
962
963	IF ( myid == 0 ) THEN
964	!
965	!-- Store the local subdomain array on the total array
966	f2(:,mg_loc_ind(3,0)-1:mg_loc_ind(4,0)+1, &
967	mg_loc_ind(1,0)-1:mg_loc_ind(2,0)+1) = f2_sub
968
969	!
970	!-- Receive the subdomain arrays from all other PEs and store them on the
971	!-- total array
972	DO n = 1, numprocs-1
973	!
974	!-- Receive the arrays in arbitrary order from the PEs.
975	CALL MPI_RECV( f2_sub(nzb,mg_loc_ind(3,0)-1,mg_loc_ind(1,0)-1), &
976	nwords, MPI_REAL, MPI_ANY_SOURCE, 1, comm2d, status, &
977	ierr )
978	sender = status(MPI_SOURCE)
979	f2(:,mg_loc_ind(3,sender)-1:mg_loc_ind(4,sender)+1, &
980	mg_loc_ind(1,sender)-1:mg_loc_ind(2,sender)+1) = f2_sub
981	ENDDO
982
983	ELSE
984	!
985	!-- Send subdomain array to PE0
986	CALL MPI_SEND( f2_sub(nzb,mg_loc_ind(3,myid)-1,mg_loc_ind(1,myid)-1), &
987	nwords, MPI_REAL, 0, 1, comm2d, ierr )
988	ENDIF
989
990	CALL cpu_log( log_point_s(34), 'mg_gather', 'stop' )
991	#endif
992
993	END SUBROUTINE mg_gather
994
995
996
997	SUBROUTINE mg_scatter( p2, p2_sub )
998	!
999	!-- TODO: It may be possible to improve the speed of this routine by using
1000	!-- non-blocking communication
1001
1002	USE control_parameters
1003	USE cpulog
1004	USE indices
1005	USE interfaces
1006	USE pegrid
1007
1008	IMPLICIT NONE
1009
1010	INTEGER :: n, nwords, sender
1011
1012	REAL, DIMENSION(nzb:nzt_mg(grid_level-1)+1, &
1013	nys_mg(grid_level-1)-1:nyn_mg(grid_level-1)+1, &
1014	nxl_mg(grid_level-1)-1:nxr_mg(grid_level-1)+1) :: p2
1015
1016	REAL, DIMENSION(nzb:mg_loc_ind(5,myid)+1, &
1017	mg_loc_ind(3,myid)-1:mg_loc_ind(4,myid)+1, &
1018	mg_loc_ind(1,myid)-1:mg_loc_ind(2,myid)+1) :: p2_sub
1019
1020	!
1021	!-- Find out the number of array elements of the subdomain array
1022	nwords = SIZE( p2_sub )
1023
1024	#if defined( __parallel )
1025	CALL cpu_log( log_point_s(35), 'mg_scatter', 'start' )
1026
1027	IF ( myid == 0 ) THEN
1028	!
1029	!-- Scatter the subdomain arrays to the other PEs by blocking
1030	!-- communication
1031	DO n = 1, numprocs-1
1032
1033	p2_sub = p2(:,mg_loc_ind(3,n)-1:mg_loc_ind(4,n)+1, &
1034	mg_loc_ind(1,n)-1:mg_loc_ind(2,n)+1)
1035
1036	CALL MPI_SEND( p2_sub(nzb,mg_loc_ind(3,0)-1,mg_loc_ind(1,0)-1), &
1037	nwords, MPI_REAL, n, 1, comm2d, ierr )
1038
1039	ENDDO
1040
1041	!
1042	!-- Store data from the total array to the local subdomain array
1043	p2_sub = p2(:,mg_loc_ind(3,0)-1:mg_loc_ind(4,0)+1, &
1044	mg_loc_ind(1,0)-1:mg_loc_ind(2,0)+1)
1045
1046	ELSE
1047	!
1048	!-- Receive subdomain array from PE0
1049	CALL MPI_RECV( p2_sub(nzb,mg_loc_ind(3,myid)-1,mg_loc_ind(1,myid)-1), &
1050	nwords, MPI_REAL, 0, 1, comm2d, status, ierr )
1051
1052	ENDIF
1053
1054	CALL cpu_log( log_point_s(35), 'mg_scatter', 'stop' )
1055	#endif
1056
1057	END SUBROUTINE mg_scatter
1058
1059
1060
1061	RECURSIVE SUBROUTINE next_mg_level( f_mg, p_mg, p3, r )
1062
1063	!------------------------------------------------------------------------------!
1064	! Description:
1065	! ------------
1066	! This is where the multigrid technique takes place. V- and W- Cycle are
1067	! implemented and steered by the parameter "gamma". Parameter "nue" determines
1068	! the convergence of the multigrid iterative solution. There are nue times
1069	! RB-GS iterations. It should be set to "1" or "2", considering the time effort
1070	! one would like to invest. Last choice shows a very good converging factor,
1071	! but leads to an increase in computing time.
1072	!------------------------------------------------------------------------------!
1073
1074	USE arrays_3d
1075	USE control_parameters
1076	USE grid_variables
1077	USE indices
1078	USE pegrid
1079
1080	IMPLICIT NONE
1081
1082	INTEGER :: i, j, k, nxl_mg_save, nxr_mg_save, nyn_mg_save, nys_mg_save, &
1083	nzt_mg_save
1084
1085	LOGICAL :: restore_boundary_lr_on_pe0, restore_boundary_ns_on_pe0
1086
1087	REAL, DIMENSION(nzb:nzt_mg(grid_level)+1, &
1088	nys_mg(grid_level)-1:nyn_mg(grid_level)+1, &
1089	nxl_mg(grid_level)-1:nxr_mg(grid_level)+1) :: f_mg, p_mg, p3, r
1090
1091	REAL, DIMENSION(:,:,:), ALLOCATABLE :: f2, f2_sub, p2, p2_sub
1092
1093	!
1094	!-- Restriction to the coarsest grid
1095	10 IF ( grid_level == 1 ) THEN
1096
1097	!
1098	!-- Solution on the coarsest grid. Double the number of Gauss-Seidel
1099	!-- iterations in order to get a more accurate solution.
1100	ngsrb = 2 * ngsrb
1101	CALL redblack( f_mg, p_mg )
1102	ngsrb = ngsrb / 2
1103
1104	ELSEIF ( grid_level /= 1 ) THEN
1105
1106	grid_level_count(grid_level) = grid_level_count(grid_level) + 1
1107
1108	!
1109	!-- Solution on the actual grid level
1110	CALL redblack( f_mg, p_mg )
1111
1112	!
1113	!-- Determination of the actual residual
1114	CALL resid( f_mg, p_mg, r )
1115
1116	!
1117	!-- Restriction of the residual (finer grid values!) to the next coarser
1118	!-- grid. Therefore, the grid level has to be decremented now. nxl..nzt have
1119	!-- to be set to the coarse grid values, because these variables are needed
1120	!-- for the exchange of ghost points in routine exchange_horiz
1121	grid_level = grid_level - 1
1122	nxl = nxl_mg(grid_level)
1123	nxr = nxr_mg(grid_level)
1124	nys = nys_mg(grid_level)
1125	nyn = nyn_mg(grid_level)
1126	nzt = nzt_mg(grid_level)
1127
1128	ALLOCATE( f2(nzb:nzt_mg(grid_level)+1, &
1129	nys_mg(grid_level)-1:nyn_mg(grid_level)+1, &
1130	nxl_mg(grid_level)-1:nxr_mg(grid_level)+1), &
1131	p2(nzb:nzt_mg(grid_level)+1, &
1132	nys_mg(grid_level)-1:nyn_mg(grid_level)+1, &
1133	nxl_mg(grid_level)-1:nxr_mg(grid_level)+1) )
1134
1135	IF ( grid_level == mg_switch_to_pe0_level ) THEN
1136	! print*, 'myid=',myid, ' restrict and switch to PE0. level=', grid_level
1137	!
1138	!-- From this level on, calculations are done on PE0 only.
1139	!-- First, carry out restriction on the subdomain.
1140	!-- Therefore, indices of the level have to be changed to subdomain values
1141	!-- in between (otherwise, the restrict routine would expect
1142	!-- the gathered array)
1143	nxl_mg_save = nxl_mg(grid_level)
1144	nxr_mg_save = nxr_mg(grid_level)
1145	nys_mg_save = nys_mg(grid_level)
1146	nyn_mg_save = nyn_mg(grid_level)
1147	nzt_mg_save = nzt_mg(grid_level)
1148	nxl_mg(grid_level) = mg_loc_ind(1,myid)
1149	nxr_mg(grid_level) = mg_loc_ind(2,myid)
1150	nys_mg(grid_level) = mg_loc_ind(3,myid)
1151	nyn_mg(grid_level) = mg_loc_ind(4,myid)
1152	nzt_mg(grid_level) = mg_loc_ind(5,myid)
1153	nxl = mg_loc_ind(1,myid)
1154	nxr = mg_loc_ind(2,myid)
1155	nys = mg_loc_ind(3,myid)
1156	nyn = mg_loc_ind(4,myid)
1157	nzt = mg_loc_ind(5,myid)
1158
1159	ALLOCATE( f2_sub(nzb:nzt_mg(grid_level)+1, &
1160	nys_mg(grid_level)-1:nyn_mg(grid_level)+1, &
1161	nxl_mg(grid_level)-1:nxr_mg(grid_level)+1) )
1162
1163	CALL restrict( f2_sub, r )
1164
1165	!
1166	!-- Restore the correct indices of this level
1167	nxl_mg(grid_level) = nxl_mg_save
1168	nxr_mg(grid_level) = nxr_mg_save
1169	nys_mg(grid_level) = nys_mg_save
1170	nyn_mg(grid_level) = nyn_mg_save
1171	nzt_mg(grid_level) = nzt_mg_save
1172	nxl = nxl_mg(grid_level)
1173	nxr = nxr_mg(grid_level)
1174	nys = nys_mg(grid_level)
1175	nyn = nyn_mg(grid_level)
1176	nzt = nzt_mg(grid_level)
1177
1178	!
1179	!-- Gather all arrays from the subdomains on PE0
1180	CALL mg_gather( f2, f2_sub )
1181
1182	!
1183	!-- Set switch for routine exchange_horiz, that no ghostpoint exchange
1184	!-- has to be carried out from now on
1185	mg_switch_to_pe0 = .TRUE.
1186
1187	!
1188	!-- In case of non-cyclic lateral boundary conditions, both in- and
1189	!-- outflow conditions have to be used on PE0 after the switch, because
1190	!-- it then contains the total domain. Due to the virtual processor
1191	!-- grid, before the switch, PE0 can have in-/outflow at the left
1192	!-- and south wall only (or on opposite walls in case of a 1d
1193	!-- decomposition).
1194	restore_boundary_lr_on_pe0 = .FALSE.
1195	restore_boundary_ns_on_pe0 = .FALSE.
1196	IF ( myid == 0 ) THEN
1197	IF ( inflow_l .AND. .NOT. outflow_r ) THEN
1198	outflow_r = .TRUE.
1199	restore_boundary_lr_on_pe0 = .TRUE.
1200	ENDIF
1201	IF ( outflow_l .AND. .NOT. inflow_r ) THEN
1202	inflow_r = .TRUE.
1203	restore_boundary_lr_on_pe0 = .TRUE.
1204	ENDIF
1205	IF ( inflow_s .AND. .NOT. outflow_n ) THEN
1206	outflow_n = .TRUE.
1207	restore_boundary_ns_on_pe0 = .TRUE.
1208	ENDIF
1209	IF ( outflow_s .AND. .NOT. inflow_n ) THEN
1210	inflow_n = .TRUE.
1211	restore_boundary_ns_on_pe0 = .TRUE.
1212	ENDIF
1213	ENDIF
1214
1215	DEALLOCATE( f2_sub )
1216
1217	ELSE
1218
1219	CALL restrict( f2, r )
1220
1221	ENDIF
1222	p2 = 0.0
1223
1224	!
1225	!-- Repeat the same procedure till the coarsest grid is reached
1226	IF ( myid == 0 .OR. grid_level > mg_switch_to_pe0_level ) THEN
1227	CALL next_mg_level( f2, p2, p3, r )
1228	ENDIF
1229
1230	ENDIF
1231
1232	!
1233	!-- Now follows the prolongation
1234	IF ( grid_level >= 2 ) THEN
1235
1236	!
1237	!-- Grid level has to be incremented on the PEs where next_mg_level
1238	!-- has not been called before (normally it is incremented at the end
1239	!-- of next_mg_level)
1240	IF ( myid /= 0 .AND. grid_level == mg_switch_to_pe0_level ) THEN
1241	grid_level = grid_level + 1
1242	nxl = nxl_mg(grid_level)
1243	nxr = nxr_mg(grid_level)
1244	nys = nys_mg(grid_level)
1245	nyn = nyn_mg(grid_level)
1246	nzt = nzt_mg(grid_level)
1247	ENDIF
1248
1249	!
1250	!-- Prolongation of the new residual. The values are transferred
1251	!-- from the coarse to the next finer grid.
1252	IF ( grid_level == mg_switch_to_pe0_level+1 ) THEN
1253	!
1254	!-- At this level, the new residual first has to be scattered from
1255	!-- PE0 to the other PEs
1256	ALLOCATE( p2_sub(nzb:mg_loc_ind(5,myid)+1, &
1257	mg_loc_ind(3,myid)-1:mg_loc_ind(4,myid)+1, &
1258	mg_loc_ind(1,myid)-1:mg_loc_ind(2,myid)+1) )
1259
1260	CALL mg_scatter( p2, p2_sub )
1261
1262	!
1263	!-- Therefore, indices of the previous level have to be changed to
1264	!-- subdomain values in between (otherwise, the prolong routine would
1265	!-- expect the gathered array)
1266	nxl_mg_save = nxl_mg(grid_level-1)
1267	nxr_mg_save = nxr_mg(grid_level-1)
1268	nys_mg_save = nys_mg(grid_level-1)
1269	nyn_mg_save = nyn_mg(grid_level-1)
1270	nzt_mg_save = nzt_mg(grid_level-1)
1271	nxl_mg(grid_level-1) = mg_loc_ind(1,myid)
1272	nxr_mg(grid_level-1) = mg_loc_ind(2,myid)
1273	nys_mg(grid_level-1) = mg_loc_ind(3,myid)
1274	nyn_mg(grid_level-1) = mg_loc_ind(4,myid)
1275	nzt_mg(grid_level-1) = mg_loc_ind(5,myid)
1276
1277	!
1278	!-- Set switch for routine exchange_horiz, that ghostpoint exchange
1279	!-- has to be carried again out from now on
1280	mg_switch_to_pe0 = .FALSE.
1281
1282	!
1283	!-- In case of non-cyclic lateral boundary conditions, restore the
1284	!-- in-/outflow conditions on PE0
1285	IF ( myid == 0 ) THEN
1286	IF ( restore_boundary_lr_on_pe0 ) THEN
1287	IF ( inflow_l ) outflow_r = .FALSE.
1288	IF ( outflow_l ) inflow_r = .FALSE.
1289	ENDIF
1290	IF ( restore_boundary_ns_on_pe0 ) THEN
1291	IF ( inflow_s ) outflow_n = .FALSE.
1292	IF ( outflow_s ) inflow_n = .FALSE.
1293	ENDIF
1294	ENDIF
1295
1296	CALL prolong( p2_sub, p3 )
1297
1298	!
1299	!-- Restore the correct indices of the previous level
1300	nxl_mg(grid_level-1) = nxl_mg_save
1301	nxr_mg(grid_level-1) = nxr_mg_save
1302	nys_mg(grid_level-1) = nys_mg_save
1303	nyn_mg(grid_level-1) = nyn_mg_save
1304	nzt_mg(grid_level-1) = nzt_mg_save
1305
1306	DEALLOCATE( p2_sub )
1307
1308	ELSE
1309
1310	CALL prolong( p2, p3 )
1311
1312	ENDIF
1313
1314	!
1315	!-- Temporary arrays for the actual grid are not needed any more
1316	DEALLOCATE( p2, f2 )
1317
1318	!
1319	!-- Computation of the new pressure correction. Therefore,
1320	!-- values from prior grids are added up automatically stage by stage.
1321	DO i = nxl_mg(grid_level)-1, nxr_mg(grid_level)+1
1322	DO j = nys_mg(grid_level)-1, nyn_mg(grid_level)+1
1323	DO k = nzb, nzt_mg(grid_level)+1
1324	p_mg(k,j,i) = p_mg(k,j,i) + p3(k,j,i)
1325	ENDDO
1326	ENDDO
1327	ENDDO
1328
1329	!
1330	!-- Relaxation of the new solution
1331	CALL redblack( f_mg, p_mg )
1332
1333	ENDIF
1334
1335	!
1336	!-- The following few lines serve the steering of the multigrid scheme
1337	IF ( grid_level == maximum_grid_level ) THEN
1338
1339	GOTO 20
1340
1341	ELSEIF ( grid_level /= maximum_grid_level .AND. grid_level /= 1 .AND. &
1342	grid_level_count(grid_level) /= gamma_mg ) THEN
1343
1344	GOTO 10
1345
1346	ENDIF
1347
1348	!
1349	!-- Reset counter for the next call of poismg
1350	grid_level_count(grid_level) = 0
1351
1352	!
1353	!-- Continue with the next finer level. nxl..nzt have to be
1354	!-- set to the finer grid values, because these variables are needed for the
1355	!-- exchange of ghost points in routine exchange_horiz
1356	grid_level = grid_level + 1
1357	nxl = nxl_mg(grid_level)
1358	nxr = nxr_mg(grid_level)
1359	nys = nys_mg(grid_level)
1360	nyn = nyn_mg(grid_level)
1361	nzt = nzt_mg(grid_level)
1362
1363	20 CONTINUE
1364
1365	END SUBROUTINE next_mg_level

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |