Home

Context Navigation

source: palm/trunk/SOURCE/advec_ws.f90 @ 1661

Last change on this file since 1661 was 1640, checked in by knoop, 10 years ago
last commit documented
Property svn:executable set to ``* Property svn:keywords set to `Id`
File size: 360.0 KB

Line
1	MODULE advec_ws
2
3	!--------------------------------------------------------------------------------!
4	! This file is part of PALM.
5	!
6	! PALM is free software: you can redistribute it and/or modify it under the terms
7	! of the GNU General Public License as published by the Free Software Foundation,
8	! either version 3 of the License, or (at your option) any later version.
9	!
10	! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
11	! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
12	! A PARTICULAR PURPOSE. See the GNU General Public License for more details.
13	!
14	! You should have received a copy of the GNU General Public License along with
15	! PALM. If not, see <http://www.gnu.org/licenses/>.
16	!
17	! Copyright 1997-2014 Leibniz Universitaet Hannover
18	!--------------------------------------------------------------------------------!
19	!
20	! Current revisions:
21	! ------------------
22	!
23	!
24	! Former revisions:
25	! -----------------
26	! $Id: advec_ws.f90 1640 2015-08-31 14:51:04Z raasch $
27	!
28	! 1630 2015-08-26 16:57:23Z suehring
29	!
30	!
31	! 1629 2015-08-26 16:56:11Z suehring
32	! Bugfix concerning wall_flags at left and south PE boundaries
33	!
34	! 1581 2015-04-10 13:45:59Z suehring
35	!
36	!
37	! 1580 2015-04-10 13:43:49Z suehring
38	! Bugfix: statistical evaluation of scalar fluxes in case of monotonic limiter
39	!
40	! 1567 2015-03-10 17:57:55Z suehring
41	! Bugfixes in monotonic limiter.
42	!
43	! 2015-03-09 13:10:37Z heinze
44	! Bugfix: REAL constants provided with KIND-attribute in call of
45	! intrinsic functions like MAX and MIN
46	!
47	! 1557 2015-03-05 16:43:04Z suehring
48	! Enable monotone advection for scalars using monotonic limiter
49	!
50	! 1374 2014-04-25 12:55:07Z raasch
51	! missing variables added to ONLY list
52	!
53	! 1361 2014-04-16 15:17:48Z hoffmann
54	! accelerator and vector version for qr and nr added
55	!
56	! 1353 2014-04-08 15:21:23Z heinze
57	! REAL constants provided with KIND-attribute,
58	! module kinds added
59	! some formatting adjustments
60	!
61	! 1322 2014-03-20 16:38:49Z raasch
62	! REAL constants defined as wp-kind
63	!
64	! 1320 2014-03-20 08:40:49Z raasch
65	! ONLY-attribute added to USE-statements,
66	! kind-parameters added to all INTEGER and REAL declaration statements,
67	! kinds are defined in new module kinds,
68	! old module precision_kind is removed,
69	! revision history before 2012 removed,
70	! comment fields (!:) to be used for variable explanations added to
71	! all variable declaration statements
72	!
73	! 1257 2013-11-08 15:18:40Z raasch
74	! accelerator loop directives removed
75	!
76	! 1221 2013-09-10 08:59:13Z raasch
77	! wall_flags_00 introduced, which holds bits 32-...
78	!
79	! 1128 2013-04-12 06:19:32Z raasch
80	! loop index bounds in accelerator version replaced by i_left, i_right, j_south,
81	! j_north
82	!
83	! 1115 2013-03-26 18:16:16Z hoffmann
84	! calculation of qr and nr is restricted to precipitation
85	!
86	! 1053 2012-11-13 17:11:03Z hoffmann
87	! necessary expansions according to the two new prognostic equations (nr, qr)
88	! of the two-moment cloud physics scheme:
89	! +flux_l_, flux_s_, diss_l_, diss_s_, sums_ws*s_ws_l
90	!
91	! 1036 2012-10-22 13:43:42Z raasch
92	! code put under GPL (PALM 3.9)
93	!
94	! 1027 2012-10-15 17:18:39Z suehring
95	! Bugfix in calculation indices k_mm, k_pp in accelerator version
96	!
97	! 1019 2012-09-28 06:46:45Z raasch
98	! small change in comment lines
99	!
100	! 1015 2012-09-27 09:23:24Z raasch
101	! accelerator versions (*_acc) added
102	!
103	! 1010 2012-09-20 07:59:54Z raasch
104	! cpp switch __nopointer added for pointer free version
105	!
106	! 888 2012-04-20 15:03:46Z suehring
107	! Number of IBITS() calls with identical arguments is reduced.
108	!
109	! 862 2012-03-26 14:21:38Z suehring
110	! ws-scheme also work with topography in combination with vector version.
111	! ws-scheme also work with outflow boundaries in combination with
112	! vector version.
113	! Degradation of the applied order of scheme is now steered by multiplying with
114	! Integer wall_flags_0. 2nd order scheme, WS3 and WS5 are calculated on each
115	! grid point and mulitplied with the appropriate flag.
116	! 2nd order numerical dissipation term changed. Now the appropriate 2nd order
117	! term derived according to the 4th and 6th order terms is applied. It turns
118	! out that diss_2nd does not provide sufficient dissipation near walls.
119	! Therefore, the function diss_2nd is removed.
120	! Near walls a divergence correction is necessary to overcome numerical
121	! instabilities due to too less divergence reduction of the velocity field.
122	! boundary_flags and logicals steering the degradation are removed.
123	! Empty SUBROUTINE local_diss removed.
124	! Further formatting adjustments.
125	!
126	! 801 2012-01-10 17:30:36Z suehring
127	! Bugfix concerning OpenMP parallelization. Summation of sums_wsus_ws_l,
128	! sums_wsvs_ws_l, sums_us2_ws_l, sums_vs2_ws_l, sums_ws2_ws_l, sums_wspts_ws_l,
129	! sums_wsqs_ws_l, sums_wssas_ws_l is now thread-safe by adding an additional
130	! dimension.
131	!
132	! Initial revision
133	!
134	! 411 2009-12-11 12:31:43 Z suehring
135	!
136	! Description:
137	! ------------
138	! Advection scheme for scalars and momentum using the flux formulation of
139	! Wicker and Skamarock 5th order. Additionally the module contains of a
140	! routine using for initialisation and steering of the statical evaluation.
141	! The computation of turbulent fluxes takes place inside the advection
142	! routines.
143	! Near non-cyclic boundaries the order of the applied advection scheme is
144	! degraded.
145	! A divergence correction is applied. It is necessary for topography, since
146	! the divergence is not sufficiently reduced, resulting in erroneous fluxes and
147	! partly numerical instabilities.
148	!-----------------------------------------------------------------------------!
149
150	PRIVATE
151	PUBLIC advec_s_ws, advec_s_ws_acc, advec_u_ws, advec_u_ws_acc, &
152	advec_v_ws, advec_v_ws_acc, advec_w_ws, advec_w_ws_acc, &
153	ws_init, ws_statistics
154
155	INTERFACE ws_init
156	MODULE PROCEDURE ws_init
157	END INTERFACE ws_init
158
159	INTERFACE ws_statistics
160	MODULE PROCEDURE ws_statistics
161	END INTERFACE ws_statistics
162
163	INTERFACE advec_s_ws
164	MODULE PROCEDURE advec_s_ws
165	MODULE PROCEDURE advec_s_ws_ij
166	END INTERFACE advec_s_ws
167
168	INTERFACE advec_u_ws
169	MODULE PROCEDURE advec_u_ws
170	MODULE PROCEDURE advec_u_ws_ij
171	END INTERFACE advec_u_ws
172
173	INTERFACE advec_u_ws_acc
174	MODULE PROCEDURE advec_u_ws_acc
175	END INTERFACE advec_u_ws_acc
176
177	INTERFACE advec_v_ws
178	MODULE PROCEDURE advec_v_ws
179	MODULE PROCEDURE advec_v_ws_ij
180	END INTERFACE advec_v_ws
181
182	INTERFACE advec_v_ws_acc
183	MODULE PROCEDURE advec_v_ws_acc
184	END INTERFACE advec_v_ws_acc
185
186	INTERFACE advec_w_ws
187	MODULE PROCEDURE advec_w_ws
188	MODULE PROCEDURE advec_w_ws_ij
189	END INTERFACE advec_w_ws
190
191	INTERFACE advec_w_ws_acc
192	MODULE PROCEDURE advec_w_ws_acc
193	END INTERFACE advec_w_ws_acc
194
195	CONTAINS
196
197
198	!------------------------------------------------------------------------------!
199	! Initialization of WS-scheme
200	!------------------------------------------------------------------------------!
201	SUBROUTINE ws_init
202
203	USE arrays_3d, &
204	ONLY: diss_l_e, diss_l_nr, diss_l_pt, diss_l_q, diss_l_qr, &
205	diss_l_sa, diss_l_u, diss_l_v, diss_l_w, flux_l_e, &
206	flux_l_nr, flux_l_pt, flux_l_q, flux_l_qr, flux_l_sa, &
207	flux_l_u, flux_l_v, flux_l_w, diss_s_e, diss_s_nr, diss_s_pt,&
208	diss_s_q, diss_s_qr, diss_s_sa, diss_s_u, diss_s_v, diss_s_w,&
209	flux_s_e, flux_s_nr, flux_s_pt, flux_s_q, flux_s_qr, &
210	flux_s_sa, flux_s_u, flux_s_v, flux_s_w
211
212	USE constants, &
213	ONLY: adv_mom_1, adv_mom_3, adv_mom_5, adv_sca_1, adv_sca_3, &
214	adv_sca_5
215
216	USE control_parameters, &
217	ONLY: cloud_physics, humidity, icloud_scheme, loop_optimization, &
218	monotonic_adjustment, passive_scalar, precipitation, ocean, &
219	ws_scheme_mom, ws_scheme_sca
220
221	USE indices, &
222	ONLY: nyn, nys, nzb, nzt
223
224	USE kinds
225
226	USE pegrid
227
228	USE statistics, &
229	ONLY: sums_us2_ws_l, sums_vs2_ws_l, sums_ws2_ws_l, sums_wsnrs_ws_l,&
230	sums_wspts_ws_l, sums_wsqrs_ws_l, sums_wsqs_ws_l, &
231	sums_wssas_ws_l, sums_wsus_ws_l, sums_wsvs_ws_l
232
233	!
234	!-- Set the appropriate factors for scalar and momentum advection.
235	adv_sca_5 = 1.0_wp / 60.0_wp
236	adv_sca_3 = 1.0_wp / 12.0_wp
237	adv_sca_1 = 1.0_wp / 2.0_wp
238	adv_mom_5 = 1.0_wp / 120.0_wp
239	adv_mom_3 = 1.0_wp / 24.0_wp
240	adv_mom_1 = 1.0_wp / 4.0_wp
241	!
242	!-- Arrays needed for statical evaluation of fluxes.
243	IF ( ws_scheme_mom ) THEN
244
245	ALLOCATE( sums_wsus_ws_l(nzb:nzt+1,0:threads_per_task-1), &
246	sums_wsvs_ws_l(nzb:nzt+1,0:threads_per_task-1), &
247	sums_us2_ws_l(nzb:nzt+1,0:threads_per_task-1), &
248	sums_vs2_ws_l(nzb:nzt+1,0:threads_per_task-1), &
249	sums_ws2_ws_l(nzb:nzt+1,0:threads_per_task-1) )
250
251	sums_wsus_ws_l = 0.0_wp
252	sums_wsvs_ws_l = 0.0_wp
253	sums_us2_ws_l = 0.0_wp
254	sums_vs2_ws_l = 0.0_wp
255	sums_ws2_ws_l = 0.0_wp
256
257	ENDIF
258
259	IF ( ws_scheme_sca ) THEN
260
261	ALLOCATE( sums_wspts_ws_l(nzb:nzt+1,0:threads_per_task-1) )
262	sums_wspts_ws_l = 0.0_wp
263
264	IF ( humidity .OR. passive_scalar ) THEN
265	ALLOCATE( sums_wsqs_ws_l(nzb:nzt+1,0:threads_per_task-1) )
266	sums_wsqs_ws_l = 0.0_wp
267	ENDIF
268
269	IF ( cloud_physics .AND. icloud_scheme == 0 .AND. &
270	precipitation ) THEN
271	ALLOCATE( sums_wsqrs_ws_l(nzb:nzt+1,0:threads_per_task-1) )
272	ALLOCATE( sums_wsnrs_ws_l(nzb:nzt+1,0:threads_per_task-1) )
273	sums_wsqrs_ws_l = 0.0_wp
274	sums_wsnrs_ws_l = 0.0_wp
275	ENDIF
276
277	IF ( ocean ) THEN
278	ALLOCATE( sums_wssas_ws_l(nzb:nzt+1,0:threads_per_task-1) )
279	sums_wssas_ws_l = 0.0_wp
280	ENDIF
281
282	ENDIF
283
284	!
285	!-- Arrays needed for reasons of speed optimization for cache version.
286	!-- For the vector version the buffer arrays are not necessary,
287	!-- because the the fluxes can swapped directly inside the loops of the
288	!-- advection routines.
289	IF ( loop_optimization /= 'vector' ) THEN
290
291	IF ( ws_scheme_mom ) THEN
292
293	ALLOCATE( flux_s_u(nzb+1:nzt,0:threads_per_task-1), &
294	flux_s_v(nzb+1:nzt,0:threads_per_task-1), &
295	flux_s_w(nzb+1:nzt,0:threads_per_task-1), &
296	diss_s_u(nzb+1:nzt,0:threads_per_task-1), &
297	diss_s_v(nzb+1:nzt,0:threads_per_task-1), &
298	diss_s_w(nzb+1:nzt,0:threads_per_task-1) )
299	ALLOCATE( flux_l_u(nzb+1:nzt,nys:nyn,0:threads_per_task-1), &
300	flux_l_v(nzb+1:nzt,nys:nyn,0:threads_per_task-1), &
301	flux_l_w(nzb+1:nzt,nys:nyn,0:threads_per_task-1), &
302	diss_l_u(nzb+1:nzt,nys:nyn,0:threads_per_task-1), &
303	diss_l_v(nzb+1:nzt,nys:nyn,0:threads_per_task-1), &
304	diss_l_w(nzb+1:nzt,nys:nyn,0:threads_per_task-1) )
305
306	ENDIF
307
308	IF ( ws_scheme_sca ) THEN
309
310	ALLOCATE( flux_s_pt(nzb+1:nzt,0:threads_per_task-1), &
311	flux_s_e(nzb+1:nzt,0:threads_per_task-1), &
312	diss_s_pt(nzb+1:nzt,0:threads_per_task-1), &
313	diss_s_e(nzb+1:nzt,0:threads_per_task-1) )
314	ALLOCATE( flux_l_pt(nzb+1:nzt,nys:nyn,0:threads_per_task-1), &
315	flux_l_e(nzb+1:nzt,nys:nyn,0:threads_per_task-1), &
316	diss_l_pt(nzb+1:nzt,nys:nyn,0:threads_per_task-1), &
317	diss_l_e(nzb+1:nzt,nys:nyn,0:threads_per_task-1) )
318
319	IF ( humidity .OR. passive_scalar ) THEN
320	ALLOCATE( flux_s_q(nzb+1:nzt,0:threads_per_task-1), &
321	diss_s_q(nzb+1:nzt,0:threads_per_task-1) )
322	ALLOCATE( flux_l_q(nzb+1:nzt,nys:nyn,0:threads_per_task-1), &
323	diss_l_q(nzb+1:nzt,nys:nyn,0:threads_per_task-1) )
324	ENDIF
325
326	IF ( cloud_physics .AND. icloud_scheme == 0 .AND. &
327	precipitation ) THEN
328	ALLOCATE( flux_s_qr(nzb+1:nzt,0:threads_per_task-1), &
329	diss_s_qr(nzb+1:nzt,0:threads_per_task-1), &
330	flux_s_nr(nzb+1:nzt,0:threads_per_task-1), &
331	diss_s_nr(nzb+1:nzt,0:threads_per_task-1) )
332	ALLOCATE( flux_l_qr(nzb+1:nzt,nys:nyn,0:threads_per_task-1), &
333	diss_l_qr(nzb+1:nzt,nys:nyn,0:threads_per_task-1), &
334	flux_l_nr(nzb+1:nzt,nys:nyn,0:threads_per_task-1), &
335	diss_l_nr(nzb+1:nzt,nys:nyn,0:threads_per_task-1) )
336	ENDIF
337
338	IF ( ocean ) THEN
339	ALLOCATE( flux_s_sa(nzb+1:nzt,0:threads_per_task-1), &
340	diss_s_sa(nzb+1:nzt,0:threads_per_task-1) )
341	ALLOCATE( flux_l_sa(nzb+1:nzt,nys:nyn,0:threads_per_task-1), &
342	diss_l_sa(nzb+1:nzt,nys:nyn,0:threads_per_task-1) )
343	ENDIF
344
345	ENDIF
346
347	ENDIF
348
349	END SUBROUTINE ws_init
350
351
352	!------------------------------------------------------------------------------!
353	! Initialize variables used for storing statistic quantities (fluxes, variances)
354	!------------------------------------------------------------------------------!
355	SUBROUTINE ws_statistics
356
357	USE control_parameters, &
358	ONLY: cloud_physics, humidity, icloud_scheme, passive_scalar, &
359	precipitation, ocean, ws_scheme_mom, ws_scheme_sca
360
361	USE kinds
362
363	USE statistics, &
364	ONLY: sums_us2_ws_l, sums_vs2_ws_l, sums_ws2_ws_l, sums_wsnrs_ws_l,&
365	sums_wspts_ws_l, sums_wsqrs_ws_l, sums_wsqs_ws_l, &
366	sums_wssas_ws_l, sums_wsus_ws_l, sums_wsvs_ws_l
367
368	IMPLICIT NONE
369
370	!
371	!-- The arrays needed for statistical evaluation are set to to 0 at the
372	!-- beginning of prognostic_equations.
373	IF ( ws_scheme_mom ) THEN
374	sums_wsus_ws_l = 0.0_wp
375	sums_wsvs_ws_l = 0.0_wp
376	sums_us2_ws_l = 0.0_wp
377	sums_vs2_ws_l = 0.0_wp
378	sums_ws2_ws_l = 0.0_wp
379	ENDIF
380
381	IF ( ws_scheme_sca ) THEN
382	sums_wspts_ws_l = 0.0_wp
383	IF ( humidity .OR. passive_scalar ) sums_wsqs_ws_l = 0.0_wp
384	IF ( cloud_physics .AND. icloud_scheme == 0 .AND. &
385	precipitation ) THEN
386	sums_wsqrs_ws_l = 0.0_wp
387	sums_wsnrs_ws_l = 0.0_wp
388	ENDIF
389	IF ( ocean ) sums_wssas_ws_l = 0.0_wp
390
391	ENDIF
392
393	END SUBROUTINE ws_statistics
394
395
396	!------------------------------------------------------------------------------!
397	! Scalar advection - Call for grid point i,j
398	!------------------------------------------------------------------------------!
399	SUBROUTINE advec_s_ws_ij( i, j, sk, sk_char, swap_flux_y_local, &
400	swap_diss_y_local, swap_flux_x_local, &
401	swap_diss_x_local, i_omp, tn )
402
403	USE arrays_3d, &
404	ONLY: ddzw, tend, u, v, w
405
406	USE constants, &
407	ONLY: adv_sca_1, adv_sca_3, adv_sca_5
408
409	USE control_parameters, &
410	ONLY: intermediate_timestep_count, monotonic_adjustment, u_gtrans, &
411	v_gtrans
412
413	USE grid_variables, &
414	ONLY: ddx, ddy
415
416	USE indices, &
417	ONLY: nxl, nxlg, nxr, nxrg, nyn, nyng, nys, nysg, nzb, nzb_max, &
418	nzt, wall_flags_0
419
420	USE kinds
421
422	USE pegrid
423
424	USE statistics, &
425	ONLY: sums_wsnrs_ws_l, sums_wspts_ws_l, sums_wsqrs_ws_l, &
426	sums_wsqs_ws_l, sums_wssas_ws_l, weight_substep
427
428	IMPLICIT NONE
429
430	CHARACTER (LEN = *), INTENT(IN) :: sk_char !:
431
432	INTEGER(iwp) :: i !:
433	INTEGER(iwp) :: ibit0 !:
434	INTEGER(iwp) :: ibit1 !:
435	INTEGER(iwp) :: ibit2 !:
436	INTEGER(iwp) :: ibit3 !:
437	INTEGER(iwp) :: ibit4 !:
438	INTEGER(iwp) :: ibit5 !:
439	INTEGER(iwp) :: ibit6 !:
440	INTEGER(iwp) :: ibit7 !:
441	INTEGER(iwp) :: ibit8 !:
442	INTEGER(iwp) :: i_omp !:
443	INTEGER(iwp) :: j !:
444	INTEGER(iwp) :: k !:
445	INTEGER(iwp) :: k_mm !:
446	INTEGER(iwp) :: k_mmm !:
447	INTEGER(iwp) :: k_pp !:
448	INTEGER(iwp) :: k_ppp !:
449	INTEGER(iwp) :: tn !:
450
451	REAL(wp) :: diss_d !:
452	REAL(wp) :: div !:
453	REAL(wp) :: flux_d !:
454	REAL(wp) :: fd_1 !:
455	REAL(wp) :: fl_1 !:
456	REAL(wp) :: fn_1 !:
457	REAL(wp) :: fr_1 !:
458	REAL(wp) :: fs_1 !:
459	REAL(wp) :: ft_1 !:
460	REAL(wp) :: phi_d !:
461	REAL(wp) :: phi_l !:
462	REAL(wp) :: phi_n !:
463	REAL(wp) :: phi_r !:
464	REAL(wp) :: phi_s !:
465	REAL(wp) :: phi_t !:
466	REAL(wp) :: rd !:
467	REAL(wp) :: rl !:
468	REAL(wp) :: rn !:
469	REAL(wp) :: rr !:
470	REAL(wp) :: rs !:
471	REAL(wp) :: rt !:
472	REAL(wp) :: u_comp !:
473	REAL(wp) :: v_comp !:
474
475	#if defined( __nopointer )
476	REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: sk !:
477	#else
478	REAL(wp), DIMENSION(:,:,:), POINTER :: sk !:
479	#endif
480	REAL(wp), DIMENSION(nzb:nzt+1) :: diss_n !:
481	REAL(wp), DIMENSION(nzb:nzt+1) :: diss_r !:
482	REAL(wp), DIMENSION(nzb:nzt+1) :: diss_t !:
483	REAL(wp), DIMENSION(nzb:nzt+1) :: flux_n !:
484	REAL(wp), DIMENSION(nzb:nzt+1) :: flux_r !:
485	REAL(wp), DIMENSION(nzb:nzt+1) :: flux_t !:
486
487	REAL(wp), DIMENSION(nzb+1:nzt,0:threads_per_task-1) :: swap_diss_y_local !:
488	REAL(wp), DIMENSION(nzb+1:nzt,0:threads_per_task-1) :: swap_flux_y_local !:
489
490	REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn,0:threads_per_task-1) :: swap_diss_x_local !:
491	REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn,0:threads_per_task-1) :: swap_flux_x_local !:
492
493
494	!
495	!-- Compute southside fluxes of the respective PE bounds.
496	IF ( j == nys ) THEN
497	!
498	!-- Up to the top of the highest topography.
499	DO k = nzb+1, nzb_max
500
501	ibit5 = IBITS(wall_flags_0(k,j-1,i),5,1)
502	ibit4 = IBITS(wall_flags_0(k,j-1,i),4,1)
503	ibit3 = IBITS(wall_flags_0(k,j-1,i),3,1)
504
505	v_comp = v(k,j,i) - v_gtrans
506	swap_flux_y_local(k,tn) = v_comp * ( &
507	( 37.0_wp * ibit5 * adv_sca_5 &
508	+ 7.0_wp * ibit4 * adv_sca_3 &
509	+ ibit3 * adv_sca_1 &
510	) * &
511	( sk(k,j,i) + sk(k,j-1,i) ) &
512	- ( 8.0_wp * ibit5 * adv_sca_5 &
513	+ ibit4 * adv_sca_3 &
514	) * &
515	( sk(k,j+1,i) + sk(k,j-2,i) ) &
516	+ ( ibit5 * adv_sca_5 &
517	) * &
518	( sk(k,j+2,i) + sk(k,j-3,i) ) &
519	)
520
521	swap_diss_y_local(k,tn) = -ABS( v_comp ) * ( &
522	( 10.0_wp * ibit5 * adv_sca_5 &
523	+ 3.0_wp * ibit4 * adv_sca_3 &
524	+ ibit3 * adv_sca_1 &
525	) * &
526	( sk(k,j,i) - sk(k,j-1,i) ) &
527	- ( 5.0_wp * ibit5 * adv_sca_5 &
528	+ ibit4 * adv_sca_3 &
529	) * &
530	( sk(k,j+1,i) - sk(k,j-2,i) ) &
531	+ ( ibit5 * adv_sca_5 &
532	) * &
533	( sk(k,j+2,i) - sk(k,j-3,i) ) &
534	)
535
536	ENDDO
537	!
538	!-- Above to the top of the highest topography. No degradation necessary.
539	DO k = nzb_max+1, nzt
540
541	v_comp = v(k,j,i) - v_gtrans
542	swap_flux_y_local(k,tn) = v_comp * ( &
543	37.0_wp * ( sk(k,j,i) + sk(k,j-1,i) ) &
544	- 8.0_wp * ( sk(k,j+1,i) + sk(k,j-2,i) ) &
545	+ ( sk(k,j+2,i) + sk(k,j-3,i) ) &
546	) * adv_sca_5
547	swap_diss_y_local(k,tn) = -ABS( v_comp ) * ( &
548	10.0_wp * ( sk(k,j,i) - sk(k,j-1,i) ) &
549	- 5.0_wp * ( sk(k,j+1,i) - sk(k,j-2,i) ) &
550	+ sk(k,j+2,i) - sk(k,j-3,i) &
551	) * adv_sca_5
552
553	ENDDO
554
555	ENDIF
556	!
557	!-- Compute leftside fluxes of the respective PE bounds.
558	IF ( i == i_omp ) THEN
559
560	DO k = nzb+1, nzb_max
561
562	ibit2 = IBITS(wall_flags_0(k,j,i-1),2,1)
563	ibit1 = IBITS(wall_flags_0(k,j,i-1),1,1)
564	ibit0 = IBITS(wall_flags_0(k,j,i-1),0,1)
565
566	u_comp = u(k,j,i) - u_gtrans
567	swap_flux_x_local(k,j,tn) = u_comp * ( &
568	( 37.0_wp * ibit2 * adv_sca_5 &
569	+ 7.0_wp * ibit1 * adv_sca_3 &
570	+ ibit0 * adv_sca_1 &
571	) * &
572	( sk(k,j,i) + sk(k,j,i-1) ) &
573	- ( 8.0_wp * ibit2 * adv_sca_5 &
574	+ ibit1 * adv_sca_3 &
575	) * &
576	( sk(k,j,i+1) + sk(k,j,i-2) ) &
577	+ ( ibit2 * adv_sca_5 &
578	) * &
579	( sk(k,j,i+2) + sk(k,j,i-3) ) &
580	)
581
582	swap_diss_x_local(k,j,tn) = -ABS( u_comp ) * ( &
583	( 10.0_wp * ibit2 * adv_sca_5 &
584	+ 3.0_wp * ibit1 * adv_sca_3 &
585	+ ibit0 * adv_sca_1 &
586	) * &
587	( sk(k,j,i) - sk(k,j,i-1) ) &
588	- ( 5.0_wp * ibit2 * adv_sca_5 &
589	+ ibit1 * adv_sca_3 &
590	) * &
591	( sk(k,j,i+1) - sk(k,j,i-2) ) &
592	+ ( ibit2 * adv_sca_5 &
593	) * &
594	( sk(k,j,i+2) - sk(k,j,i-3) ) &
595	)
596
597	ENDDO
598
599	DO k = nzb_max+1, nzt
600
601	u_comp = u(k,j,i) - u_gtrans
602	swap_flux_x_local(k,j,tn) = u_comp * ( &
603	37.0_wp * ( sk(k,j,i) + sk(k,j,i-1) ) &
604	- 8.0_wp * ( sk(k,j,i+1) + sk(k,j,i-2) ) &
605	+ ( sk(k,j,i+2) + sk(k,j,i-3) ) &
606	) * adv_sca_5
607
608	swap_diss_x_local(k,j,tn) = -ABS( u_comp ) * ( &
609	10.0_wp * ( sk(k,j,i) - sk(k,j,i-1) ) &
610	- 5.0_wp * ( sk(k,j,i+1) - sk(k,j,i-2) ) &
611	+ ( sk(k,j,i+2) - sk(k,j,i-3) ) &
612	) * adv_sca_5
613
614	ENDDO
615
616	ENDIF
617
618	flux_t(0) = 0.0_wp
619	diss_t(0) = 0.0_wp
620	flux_d = 0.0_wp
621	diss_d = 0.0_wp
622	!
623	!-- Now compute the fluxes and tendency terms for the horizontal and
624	!-- vertical parts up to the top of the highest topography.
625	DO k = nzb+1, nzb_max
626	!
627	!-- Note: It is faster to conduct all multiplications explicitly, e.g.
628	!-- * adv_sca_5 ... than to determine a factor and multiplicate the
629	!-- flux at the end.
630
631	ibit2 = IBITS(wall_flags_0(k,j,i),2,1)
632	ibit1 = IBITS(wall_flags_0(k,j,i),1,1)
633	ibit0 = IBITS(wall_flags_0(k,j,i),0,1)
634
635	u_comp = u(k,j,i+1) - u_gtrans
636	flux_r(k) = u_comp * ( &
637	( 37.0_wp * ibit2 * adv_sca_5 &
638	+ 7.0_wp * ibit1 * adv_sca_3 &
639	+ ibit0 * adv_sca_1 &
640	) * &
641	( sk(k,j,i+1) + sk(k,j,i) ) &
642	- ( 8.0_wp * ibit2 * adv_sca_5 &
643	+ ibit1 * adv_sca_3 &
644	) * &
645	( sk(k,j,i+2) + sk(k,j,i-1) ) &
646	+ ( ibit2 * adv_sca_5 &
647	) * &
648	( sk(k,j,i+3) + sk(k,j,i-2) ) &
649	)
650
651	diss_r(k) = -ABS( u_comp ) * ( &
652	( 10.0_wp * ibit2 * adv_sca_5 &
653	+ 3.0_wp * ibit1 * adv_sca_3 &
654	+ ibit0 * adv_sca_1 &
655	) * &
656	( sk(k,j,i+1) - sk(k,j,i) ) &
657	- ( 5.0_wp * ibit2 * adv_sca_5 &
658	+ ibit1 * adv_sca_3 &
659	) * &
660	( sk(k,j,i+2) - sk(k,j,i-1) ) &
661	+ ( ibit2 * adv_sca_5 &
662	) * &
663	( sk(k,j,i+3) - sk(k,j,i-2) ) &
664	)
665
666	ibit5 = IBITS(wall_flags_0(k,j,i),5,1)
667	ibit4 = IBITS(wall_flags_0(k,j,i),4,1)
668	ibit3 = IBITS(wall_flags_0(k,j,i),3,1)
669
670	v_comp = v(k,j+1,i) - v_gtrans
671	flux_n(k) = v_comp * ( &
672	( 37.0_wp * ibit5 * adv_sca_5 &
673	+ 7.0_wp * ibit4 * adv_sca_3 &
674	+ ibit3 * adv_sca_1 &
675	) * &
676	( sk(k,j+1,i) + sk(k,j,i) ) &
677	- ( 8.0_wp * ibit5 * adv_sca_5 &
678	+ ibit4 * adv_sca_3 &
679	) * &
680	( sk(k,j+2,i) + sk(k,j-1,i) ) &
681	+ ( ibit5 * adv_sca_5 &
682	) * &
683	( sk(k,j+3,i) + sk(k,j-2,i) ) &
684	)
685
686	diss_n(k) = -ABS( v_comp ) * ( &
687	( 10.0_wp * ibit5 * adv_sca_5 &
688	+ 3.0_wp * ibit4 * adv_sca_3 &
689	+ ibit3 * adv_sca_1 &
690	) * &
691	( sk(k,j+1,i) - sk(k,j,i) ) &
692	- ( 5.0_wp * ibit5 * adv_sca_5 &
693	+ ibit4 * adv_sca_3 &
694	) * &
695	( sk(k,j+2,i) - sk(k,j-1,i) ) &
696	+ ( ibit5 * adv_sca_5 &
697	) * &
698	( sk(k,j+3,i) - sk(k,j-2,i) ) &
699	)
700	!
701	!-- k index has to be modified near bottom and top, else array
702	!-- subscripts will be exceeded.
703	ibit8 = IBITS(wall_flags_0(k,j,i),8,1)
704	ibit7 = IBITS(wall_flags_0(k,j,i),7,1)
705	ibit6 = IBITS(wall_flags_0(k,j,i),6,1)
706
707	k_ppp = k + 3 * ibit8
708	k_pp = k + 2 * ( 1 - ibit6 )
709	k_mm = k - 2 * ibit8
710
711
712	flux_t(k) = w(k,j,i) * ( &
713	( 37.0_wp * ibit8 * adv_sca_5 &
714	+ 7.0_wp * ibit7 * adv_sca_3 &
715	+ ibit6 * adv_sca_1 &
716	) * &
717	( sk(k+1,j,i) + sk(k,j,i) ) &
718	- ( 8.0_wp * ibit8 * adv_sca_5 &
719	+ ibit7 * adv_sca_3 &
720	) * &
721	( sk(k_pp,j,i) + sk(k-1,j,i) ) &
722	+ ( ibit8 * adv_sca_5 &
723	) * ( sk(k_ppp,j,i)+ sk(k_mm,j,i) ) &
724	)
725
726	diss_t(k) = -ABS( w(k,j,i) ) * ( &
727	( 10.0_wp * ibit8 * adv_sca_5 &
728	+ 3.0_wp * ibit7 * adv_sca_3 &
729	+ ibit6 * adv_sca_1 &
730	) * &
731	( sk(k+1,j,i) - sk(k,j,i) ) &
732	- ( 5.0_wp * ibit8 * adv_sca_5 &
733	+ ibit7 * adv_sca_3 &
734	) * &
735	( sk(k_pp,j,i) - sk(k-1,j,i) ) &
736	+ ( ibit8 * adv_sca_5 &
737	) * &
738	( sk(k_ppp,j,i) - sk(k_mm,j,i) ) &
739	)
740	!
741	!-- Apply monotonic adjustment.
742	IF ( monotonic_adjustment ) THEN
743	!
744	!-- At first, calculate first order fluxes.
745	u_comp = u(k,j,i) - u_gtrans
746	fl_1 = ( u_comp * ( sk(k,j,i) + sk(k,j,i-1) ) &
747	-ABS( u_comp ) * ( sk(k,j,i) - sk(k,j,i-1) ) &
748	) * adv_sca_1
749
750	u_comp = u(k,j,i+1) - u_gtrans
751	fr_1 = ( u_comp * ( sk(k,j,i+1) + sk(k,j,i) ) &
752	-ABS( u_comp ) * ( sk(k,j,i+1) - sk(k,j,i) ) &
753	) * adv_sca_1
754
755	v_comp = v(k,j,i) - v_gtrans
756	fs_1 = ( v_comp * ( sk(k,j,i) + sk(k,j-1,i) ) &
757	-ABS( v_comp ) * ( sk(k,j,i) - sk(k,j-1,i) ) &
758	) * adv_sca_1
759
760	v_comp = v(k,j+1,i) - v_gtrans
761	fn_1 = ( v_comp * ( sk(k,j+1,i) + sk(k,j,i) ) &
762	-ABS( v_comp ) * ( sk(k,j+1,i) - sk(k,j,i) ) &
763	) * adv_sca_1
764
765	fd_1 = ( w(k-1,j,i) * ( sk(k,j,i) + sk(k-1,j,i) ) &
766	-ABS( w(k-1,j,i) ) * ( sk(k,j,i) - sk(k-1,j,i) ) &
767	) * adv_sca_1
768
769	ft_1 = ( w(k,j,i) * ( sk(k+1,j,i) + sk(k,j,i) ) &
770	-ABS( w(k,j,i) ) * ( sk(k+1,j,i) - sk(k,j,i) ) &
771	) * adv_sca_1
772	!
773	!-- Calculate ratio of upwind gradients. Note, Min/Max is just to
774	!-- avoid if statements.
775	rl = ( MAX( 0.0_wp, u(k,j,i) - u_gtrans ) * &
776	ABS( ( sk(k,j,i-1) - sk(k,j,i-2) ) / &
777	( sk(k,j,i) - sk(k,j,i-1) + 1E-20_wp ) &
778	) + &
779	MIN( 0.0_wp, u(k,j,i) - u_gtrans ) * &
780	ABS( ( sk(k,j,i) - sk(k,j,i+1) ) / &
781	( sk(k,j,i-1) - sk(k,j,i) + 1E-20_wp ) &
782	) &
783	) / ABS( u(k,j,i) - u_gtrans + 1E-20_wp )
784
785	rr = ( MAX( 0.0_wp, u(k,j,i+1) - u_gtrans ) * &
786	ABS( ( sk(k,j,i) - sk(k,j,i-1) ) / &
787	( sk(k,j,i+1) - sk(k,j,i) + 1E-20_wp ) &
788	) + &
789	MIN( 0.0_wp, u(k,j,i+1) - u_gtrans ) * &
790	ABS( ( sk(k,j,i+1) - sk(k,j,i+2) ) / &
791	( sk(k,j,i) - sk(k,j,i+1) + 1E-20_wp ) &
792	) &
793	) / ABS( u(k,j,i+1) - u_gtrans + 1E-20_wp )
794
795	rs = ( MAX( 0.0_wp, v(k,j,i) - v_gtrans ) * &
796	ABS( ( sk(k,j-1,i) - sk(k,j-2,i) ) / &
797	( sk(k,j,i) - sk(k,j-1,i) + 1E-20_wp ) &
798	) + &
799	MIN( 0.0_wp, v(k,j,i) - v_gtrans ) * &
800	ABS( ( sk(k,j,i) - sk(k,j+1,i) ) / &
801	( sk(k,j-1,i) - sk(k,j,i) + 1E-20_wp ) &
802	) &
803	) / ABS( v(k,j,i) - v_gtrans + 1E-20_wp )
804
805	rn = ( MAX( 0.0_wp, v(k,j+1,i) - v_gtrans ) * &
806	ABS( ( sk(k,j,i) - sk(k,j-1,i) ) / &
807	( sk(k,j+1,i) - sk(k,j,i) + 1E-20_wp ) &
808	) + &
809	MIN( 0.0_wp, v(k,j+1,i) - v_gtrans ) * &
810	ABS( ( sk(k,j+1,i) - sk(k,j+2,i) ) / &
811	( sk(k,j,i) - sk(k,j+1,i) + 1E-20_wp ) &
812	) &
813	) / ABS( v(k,j+1,i) - v_gtrans + 1E-20_wp )
814	!
815	!-- Reuse k_mm and compute k_mmm for the vertical gradient ratios.
816	!-- Note, for vertical advection below the third grid point above
817	!-- surface ( or below the model top) rd and rt are set to 0, i.e.
818	!-- use of first order scheme is enforced.
819	k_mmm = k - 3 * ibit8
820
821	rd = ( MAX( 0.0_wp, w(k-1,j,i) ) * &
822	ABS( ( sk(k_mm,j,i) - sk(k_mmm,j,i) ) / &
823	( sk(k-1,j,i) - sk(k_mm,j,i) + 1E-20_wp ) &
824	) + &
825	MIN( 0.0_wp, w(k-1,j,i) ) * &
826	ABS( ( sk(k-1,j,i) - sk(k,j,i) ) / &
827	( sk(k_mm,j,i) - sk(k-1,j,i) + 1E-20_wp ) &
828	) &
829	) * ibit8 / ABS( w(k-1,j,i) + 1E-20_wp )
830
831	rt = ( MAX( 0.0_wp, w(k,j,i) ) * &
832	ABS( ( sk(k,j,i) - sk(k-1,j,i) ) / &
833	( sk(k+1,j,i) - sk(k,j,i) + 1E-20_wp ) &
834	) + &
835	MIN( 0.0_wp, w(k,j,i) ) * &
836	ABS( ( sk(k+1,j,i) - sk(k_pp,j,i) ) / &
837	( sk(k,j,i) - sk(k+1,j,i) + 1E-20_wp ) &
838	) &
839	) * ibit8 / ABS( w(k,j,i) + 1E-20_wp )
840	!
841	!-- Calculate empirical limiter function (van Albada2 limiter).
842	phi_l = MIN( 1.0_wp, ( 2.0_wp * ABS( rl ) ) / &
843	( rl**2 + 1.0_wp ) )
844	phi_r = MIN( 1.0_wp, ( 2.0_wp * ABS( rr ) ) / &
845	( rr**2 + 1.0_wp ) )
846	phi_s = MIN( 1.0_wp, ( 2.0_wp * ABS( rs ) ) / &
847	( rs**2 + 1.0_wp ) )
848	phi_n = MIN( 1.0_wp, ( 2.0_wp * ABS( rn ) ) / &
849	( rn**2 + 1.0_wp ) )
850	phi_d = MIN( 1.0_wp, ( 2.0_wp * ABS( rd ) ) / &
851	( rd**2 + 1.0_wp ) )
852	phi_t = MIN( 1.0_wp, ( 2.0_wp * ABS( rt ) ) / &
853	( rt**2 + 1.0_wp ) )
854	!
855	!-- Calculate the resulting monotone flux.
856	swap_flux_x_local(k,j,tn) = fl_1 - phi_l * &
857	( fl_1 - swap_flux_x_local(k,j,tn) )
858	flux_r(k) = fr_1 - phi_r * &
859	( fr_1 - flux_r(k) )
860	swap_flux_y_local(k,tn) = fs_1 - phi_s * &
861	( fs_1 - swap_flux_y_local(k,tn) )
862	flux_n(k) = fn_1 - phi_n * &
863	( fn_1 - flux_n(k) )
864	flux_d = fd_1 - phi_d * &
865	( fd_1 - flux_d )
866	flux_t(k) = ft_1 - phi_t * &
867	( ft_1 - flux_t(k) )
868	!
869	!-- Moreover, modify dissipation flux according to the limiter.
870	swap_diss_x_local(k,j,tn) = swap_diss_x_local(k,j,tn) * phi_l
871	diss_r(k) = diss_r(k) * phi_r
872	swap_diss_y_local(k,tn) = swap_diss_y_local(k,tn) * phi_s
873	diss_n(k) = diss_n(k) * phi_n
874	diss_d = diss_d * phi_d
875	diss_t(k) = diss_t(k) * phi_t
876
877	ENDIF
878	!
879	!-- Calculate the divergence of the velocity field. A respective
880	!-- correction is needed to overcome numerical instabilities caused
881	!-- by a not sufficient reduction of divergences near topography.
882	div = ( u(k,j,i+1) * ( ibit0 + ibit1 + ibit2 ) &
883	- u(k,j,i) * ( IBITS(wall_flags_0(k,j,i-1),0,1) &
884	+ IBITS(wall_flags_0(k,j,i-1),1,1) &
885	+ IBITS(wall_flags_0(k,j,i-1),2,1) &
886	) &
887	) * ddx &
888	+ ( v(k,j+1,i) * ( ibit3 + ibit4 + ibit5 ) &
889	- v(k,j,i) * ( IBITS(wall_flags_0(k,j-1,i),3,1) &
890	+ IBITS(wall_flags_0(k,j-1,i),4,1) &
891	+ IBITS(wall_flags_0(k,j-1,i),5,1) &
892	) &
893	) * ddy &
894	+ ( w(k,j,i) * ( ibit6 + ibit7 + ibit8 ) &
895	- w(k-1,j,i) * ( IBITS(wall_flags_0(k-1,j,i),6,1) &
896	+ IBITS(wall_flags_0(k-1,j,i),7,1) &
897	+ IBITS(wall_flags_0(k-1,j,i),8,1) &
898	) &
899	) * ddzw(k)
900
901
902	tend(k,j,i) = tend(k,j,i) - ( &
903	( flux_r(k) + diss_r(k) - swap_flux_x_local(k,j,tn) - &
904	swap_diss_x_local(k,j,tn) ) * ddx &
905	+ ( flux_n(k) + diss_n(k) - swap_flux_y_local(k,tn) - &
906	swap_diss_y_local(k,tn) ) * ddy &
907	+ ( flux_t(k) + diss_t(k) - flux_d - diss_d &
908	) * ddzw(k) &
909	) + sk(k,j,i) * div
910
911	swap_flux_y_local(k,tn) = flux_n(k)
912	swap_diss_y_local(k,tn) = diss_n(k)
913	swap_flux_x_local(k,j,tn) = flux_r(k)
914	swap_diss_x_local(k,j,tn) = diss_r(k)
915	flux_d = flux_t(k)
916	diss_d = diss_t(k)
917
918	ENDDO
919	!
920	!-- Now compute the fluxes and tendency terms for the horizontal and
921	!-- vertical parts above the top of the highest topography. No degradation
922	!-- for the horizontal parts, but for the vertical it is stell needed.
923	DO k = nzb_max+1, nzt
924
925	u_comp = u(k,j,i+1) - u_gtrans
926	flux_r(k) = u_comp * ( &
927	37.0_wp * ( sk(k,j,i+1) + sk(k,j,i) ) &
928	- 8.0_wp * ( sk(k,j,i+2) + sk(k,j,i-1) ) &
929	+ ( sk(k,j,i+3) + sk(k,j,i-2) ) ) * adv_sca_5
930	diss_r(k) = -ABS( u_comp ) * ( &
931	10.0_wp * ( sk(k,j,i+1) - sk(k,j,i) ) &
932	- 5.0_wp * ( sk(k,j,i+2) - sk(k,j,i-1) ) &
933	+ ( sk(k,j,i+3) - sk(k,j,i-2) ) ) * adv_sca_5
934
935	v_comp = v(k,j+1,i) - v_gtrans
936	flux_n(k) = v_comp * ( &
937	37.0_wp * ( sk(k,j+1,i) + sk(k,j,i) ) &
938	- 8.0_wp * ( sk(k,j+2,i) + sk(k,j-1,i) ) &
939	+ ( sk(k,j+3,i) + sk(k,j-2,i) ) ) * adv_sca_5
940	diss_n(k) = -ABS( v_comp ) * ( &
941	10.0_wp * ( sk(k,j+1,i) - sk(k,j,i) ) &
942	- 5.0_wp * ( sk(k,j+2,i) - sk(k,j-1,i) ) &
943	+ ( sk(k,j+3,i) - sk(k,j-2,i) ) ) * adv_sca_5
944	!
945	!-- k index has to be modified near bottom and top, else array
946	!-- subscripts will be exceeded.
947	ibit8 = IBITS(wall_flags_0(k,j,i),8,1)
948	ibit7 = IBITS(wall_flags_0(k,j,i),7,1)
949	ibit6 = IBITS(wall_flags_0(k,j,i),6,1)
950
951	k_ppp = k + 3 * ibit8
952	k_pp = k + 2 * ( 1 - ibit6 )
953	k_mm = k - 2 * ibit8
954
955	flux_t(k) = w(k,j,i) * ( &
956	( 37.0_wp * ibit8 * adv_sca_5 &
957	+ 7.0_wp * ibit7 * adv_sca_3 &
958	+ ibit6 * adv_sca_1 &
959	) * &
960	( sk(k+1,j,i) + sk(k,j,i) ) &
961	- ( 8.0_wp * ibit8 * adv_sca_5 &
962	+ ibit7 * adv_sca_3 &
963	) * &
964	( sk(k_pp,j,i) + sk(k-1,j,i) ) &
965	+ ( ibit8 * adv_sca_5 &
966	) * ( sk(k_ppp,j,i)+ sk(k_mm,j,i) ) &
967	)
968
969	diss_t(k) = -ABS( w(k,j,i) ) * ( &
970	( 10.0_wp * ibit8 * adv_sca_5 &
971	+ 3.0_wp * ibit7 * adv_sca_3 &
972	+ ibit6 * adv_sca_1 &
973	) * &
974	( sk(k+1,j,i) - sk(k,j,i) ) &
975	- ( 5.0_wp * ibit8 * adv_sca_5 &
976	+ ibit7 * adv_sca_3 &
977	) * &
978	( sk(k_pp,j,i) - sk(k-1,j,i) ) &
979	+ ( ibit8 * adv_sca_5 &
980	) * &
981	( sk(k_ppp,j,i) - sk(k_mm,j,i) ) &
982	)
983
984
985	!
986	!-- Apply monotonic adjustment.
987	IF ( monotonic_adjustment ) THEN
988	!
989	!-- At first, calculate first order fluxes.
990	u_comp = u(k,j,i) - u_gtrans
991	fl_1 = ( u_comp * ( sk(k,j,i) + sk(k,j,i-1) ) &
992	-ABS( u_comp ) * ( sk(k,j,i) - sk(k,j,i-1) ) &
993	) * adv_sca_1
994
995	u_comp = u(k,j,i+1) - u_gtrans
996	fr_1 = ( u_comp * ( sk(k,j,i+1) + sk(k,j,i) ) &
997	-ABS( u_comp ) * ( sk(k,j,i+1) - sk(k,j,i) ) &
998	) * adv_sca_1
999
1000	v_comp = v(k,j,i) - v_gtrans
1001	fs_1 = ( v_comp * ( sk(k,j,i) + sk(k,j-1,i) ) &
1002	-ABS( v_comp ) * ( sk(k,j,i) - sk(k,j-1,i) ) &
1003	) * adv_sca_1
1004
1005	v_comp = v(k,j+1,i) - v_gtrans
1006	fn_1 = ( v_comp * ( sk(k,j+1,i) + sk(k,j,i) ) &
1007	-ABS( v_comp ) * ( sk(k,j+1,i) - sk(k,j,i) ) &
1008	) * adv_sca_1
1009
1010	fd_1 = ( w(k-1,j,i) * ( sk(k,j,i) + sk(k-1,j,i) ) &
1011	-ABS( w(k-1,j,i) ) * ( sk(k,j,i) - sk(k-1,j,i) ) &
1012	) * adv_sca_1
1013
1014	ft_1 = ( w(k,j,i) * ( sk(k+1,j,i) + sk(k,j,i) ) &
1015	-ABS( w(k,j,i) ) * ( sk(k+1,j,i) - sk(k,j,i) ) &
1016	) * adv_sca_1
1017	!
1018	!-- Calculate ratio of upwind gradients. Note, Min/Max is just to
1019	!-- avoid if statements.
1020	rl = ( MAX( 0.0_wp, u(k,j,i) - u_gtrans ) * &
1021	ABS( ( sk(k,j,i-1) - sk(k,j,i-2) ) / &
1022	( sk(k,j,i) - sk(k,j,i-1) + 1E-20_wp ) &
1023	) + &
1024	MIN( 0.0_wp, u(k,j,i) - u_gtrans ) * &
1025	ABS( ( sk(k,j,i) - sk(k,j,i+1) ) / &
1026	( sk(k,j,i-1) - sk(k,j,i) + 1E-20_wp ) &
1027	) &
1028	) / ABS( u(k,j,i) - u_gtrans + 1E-20_wp )
1029
1030	rr = ( MAX( 0.0_wp, u(k,j,i+1) - u_gtrans ) * &
1031	ABS( ( sk(k,j,i) - sk(k,j,i-1) ) / &
1032	( sk(k,j,i+1) - sk(k,j,i) + 1E-20_wp ) &
1033	) + &
1034	MIN( 0.0_wp, u(k,j,i+1) - u_gtrans ) * &
1035	ABS( ( sk(k,j,i+1) - sk(k,j,i+2) ) / &
1036	( sk(k,j,i) - sk(k,j,i+1) + 1E-20_wp ) &
1037	) &
1038	) / ABS( u(k,j,i+1) - u_gtrans + 1E-20_wp )
1039
1040	rs = ( MAX( 0.0_wp, v(k,j,i) - v_gtrans ) * &
1041	ABS( ( sk(k,j-1,i) - sk(k,j-2,i) ) / &
1042	( sk(k,j,i) - sk(k,j-1,i) + 1E-20_wp ) &
1043	) + &
1044	MIN( 0.0_wp, v(k,j,i) - v_gtrans ) * &
1045	ABS( ( sk(k,j,i) - sk(k,j+1,i) ) / &
1046	( sk(k,j-1,i) - sk(k,j,i) + 1E-20_wp ) &
1047	) &
1048	) / ABS( v(k,j,i) - v_gtrans + 1E-20_wp )
1049
1050	rn = ( MAX( 0.0_wp, v(k,j+1,i) - v_gtrans ) * &
1051	ABS( ( sk(k,j,i) - sk(k,j-1,i) ) / &
1052	( sk(k,j+1,i) - sk(k,j,i) + 1E-20_wp ) &
1053	) + &
1054	MIN( 0.0_wp, v(k,j+1,i) - v_gtrans ) * &
1055	ABS( ( sk(k,j+1,i) - sk(k,j+2,i) ) / &
1056	( sk(k,j,i) - sk(k,j+1,i) + 1E-20_wp ) &
1057	) &
1058	) / ABS( v(k,j+1,i) - v_gtrans + 1E-20_wp )
1059	!
1060	!-- Reuse k_mm and compute k_mmm for the vertical gradient ratios.
1061	!-- Note, for vertical advection below the third grid point above
1062	!-- surface ( or below the model top) rd and rt are set to 0, i.e.
1063	!-- use of first order scheme is enforced.
1064	k_mmm = k - 3 * ibit8
1065
1066	rd = ( MAX( 0.0_wp, w(k-1,j,i) ) * &
1067	ABS( ( sk(k_mm,j,i) - sk(k_mmm,j,i) ) / &
1068	( sk(k-1,j,i) - sk(k_mm,j,i) + 1E-20_wp ) &
1069	) + &
1070	MIN( 0.0_wp, w(k-1,j,i) ) * &
1071	ABS( ( sk(k-1,j,i) - sk(k,j,i) ) / &
1072	( sk(k_mm,j,i) - sk(k-1,j,i) + 1E-20_wp ) &
1073	) &
1074	) * ibit8 / ABS( w(k-1,j,i) + 1E-20_wp )
1075
1076	rt = ( MAX( 0.0_wp, w(k,j,i) ) * &
1077	ABS( ( sk(k,j,i) - sk(k-1,j,i) ) / &
1078	( sk(k+1,j,i) - sk(k,j,i) + 1E-20_wp ) &
1079	) + &
1080	MIN( 0.0_wp, w(k,j,i) ) * &
1081	ABS( ( sk(k+1,j,i) - sk(k_pp,j,i) ) / &
1082	( sk(k,j,i) - sk(k+1,j,i) + 1E-20_wp ) &
1083	) &
1084	) * ibit8 / ABS( w(k,j,i) + 1E-20_wp )
1085	!
1086	!-- Calculate empirical limiter function (van Albada2 limiter).
1087	phi_l = MIN( 1.0_wp, ( 2.0_wp * ABS( rl ) ) / &
1088	( rl**2 + 1.0_wp ) )
1089	phi_r = MIN( 1.0_wp, ( 2.0_wp * ABS( rr ) ) / &
1090	( rr**2 + 1.0_wp ) )
1091	phi_s = MIN( 1.0_wp, ( 2.0_wp * ABS( rs ) ) / &
1092	( rs**2 + 1.0_wp ) )
1093	phi_n = MIN( 1.0_wp, ( 2.0_wp * ABS( rn ) ) / &
1094	( rn**2 + 1.0_wp ) )
1095	phi_d = MIN( 1.0_wp, ( 2.0_wp * ABS( rd ) ) / &
1096	( rd**2 + 1.0_wp ) )
1097	phi_t = MIN( 1.0_wp, ( 2.0_wp * ABS( rt ) ) / &
1098	( rt**2 + 1.0_wp ) )
1099	!
1100	!-- Calculate the resulting monotone flux.
1101	swap_flux_x_local(k,j,tn) = fl_1 - phi_l * &
1102	( fl_1 - swap_flux_x_local(k,j,tn) )
1103	flux_r(k) = fr_1 - phi_r * &
1104	( fr_1 - flux_r(k) )
1105	swap_flux_y_local(k,tn) = fs_1 - phi_s * &
1106	( fs_1 - swap_flux_y_local(k,tn) )
1107	flux_n(k) = fn_1 - phi_n * &
1108	( fn_1 - flux_n(k) )
1109	flux_d = fd_1 - phi_d * &
1110	( fd_1 - flux_d )
1111	flux_t(k) = ft_1 - phi_t * &
1112	( ft_1 - flux_t(k) )
1113	!
1114	!-- Moreover, modify dissipation flux according to the limiter.
1115	swap_diss_x_local(k,j,tn) = swap_diss_x_local(k,j,tn) * phi_l
1116	diss_r(k) = diss_r(k) * phi_r
1117	swap_diss_y_local(k,tn) = swap_diss_y_local(k,tn) * phi_s
1118	diss_n(k) = diss_n(k) * phi_n
1119	diss_d = diss_d * phi_d
1120	diss_t(k) = diss_t(k) * phi_t
1121
1122	ENDIF
1123	!
1124	!-- Calculate the divergence of the velocity field. A respective
1125	!-- correction is needed to overcome numerical instabilities introduced
1126	!-- by a not sufficient reduction of divergences near topography.
1127	div = ( u(k,j,i+1) - u(k,j,i) ) * ddx &
1128	+ ( v(k,j+1,i) - v(k,j,i) ) * ddy &
1129	+ ( w(k,j,i) - w(k-1,j,i) ) * ddzw(k)
1130
1131	tend(k,j,i) = tend(k,j,i) - ( &
1132	( flux_r(k) + diss_r(k) - swap_flux_x_local(k,j,tn) - &
1133	swap_diss_x_local(k,j,tn) ) * ddx &
1134	+ ( flux_n(k) + diss_n(k) - swap_flux_y_local(k,tn) - &
1135	swap_diss_y_local(k,tn) ) * ddy &
1136	+ ( flux_t(k) + diss_t(k) - flux_d - diss_d &
1137	) * ddzw(k) &
1138	) + sk(k,j,i) * div
1139
1140
1141	swap_flux_y_local(k,tn) = flux_n(k)
1142	swap_diss_y_local(k,tn) = diss_n(k)
1143	swap_flux_x_local(k,j,tn) = flux_r(k)
1144	swap_diss_x_local(k,j,tn) = diss_r(k)
1145	flux_d = flux_t(k)
1146	diss_d = diss_t(k)
1147
1148	ENDDO
1149
1150	!
1151	!-- Evaluation of statistics.
1152	SELECT CASE ( sk_char )
1153
1154	CASE ( 'pt' )
1155
1156	DO k = nzb, nzt
1157	sums_wspts_ws_l(k,tn) = sums_wspts_ws_l(k,tn) + &
1158	( flux_t(k) + diss_t(k) ) &
1159	* weight_substep(intermediate_timestep_count)
1160	ENDDO
1161
1162	CASE ( 'sa' )
1163
1164	DO k = nzb, nzt
1165	sums_wssas_ws_l(k,tn) = sums_wssas_ws_l(k,tn) + &
1166	( flux_t(k) + diss_t(k) ) &
1167	* weight_substep(intermediate_timestep_count)
1168	ENDDO
1169
1170	CASE ( 'q' )
1171
1172	DO k = nzb, nzt
1173	sums_wsqs_ws_l(k,tn) = sums_wsqs_ws_l(k,tn) + &
1174	( flux_t(k) + diss_t(k) ) &
1175	* weight_substep(intermediate_timestep_count)
1176	ENDDO
1177
1178	CASE ( 'qr' )
1179
1180	DO k = nzb, nzt
1181	sums_wsqrs_ws_l(k,tn) = sums_wsqrs_ws_l(k,tn) + &
1182	( flux_t(k) + diss_t(k) ) &
1183	* weight_substep(intermediate_timestep_count)
1184	ENDDO
1185
1186	CASE ( 'nr' )
1187
1188	DO k = nzb, nzt
1189	sums_wsnrs_ws_l(k,tn) = sums_wsnrs_ws_l(k,tn) + &
1190	( flux_t(k) + diss_t(k) ) &
1191	* weight_substep(intermediate_timestep_count)
1192	ENDDO
1193
1194	END SELECT
1195
1196	END SUBROUTINE advec_s_ws_ij
1197
1198
1199
1200
1201	!------------------------------------------------------------------------------!
1202	! Advection of u-component - Call for grid point i,j
1203	!------------------------------------------------------------------------------!
1204	SUBROUTINE advec_u_ws_ij( i, j, i_omp, tn )
1205
1206	USE arrays_3d, &
1207	ONLY: ddzw, diss_l_u, diss_s_u, flux_l_u, flux_s_u, tend, u, v, w
1208
1209	USE constants, &
1210	ONLY: adv_mom_1, adv_mom_3, adv_mom_5
1211
1212	USE control_parameters, &
1213	ONLY: intermediate_timestep_count, u_gtrans, v_gtrans
1214
1215	USE grid_variables, &
1216	ONLY: ddx, ddy
1217
1218	USE indices, &
1219	ONLY: nxl, nxr, nyn, nys, nzb, nzb_max, nzt, wall_flags_0
1220
1221	USE kinds
1222
1223	USE statistics, &
1224	ONLY: hom, sums_us2_ws_l, sums_wsus_ws_l, weight_substep
1225
1226	IMPLICIT NONE
1227
1228	INTEGER(iwp) :: i !:
1229	INTEGER(iwp) :: ibit9 !:
1230	INTEGER(iwp) :: ibit10 !:
1231	INTEGER(iwp) :: ibit11 !:
1232	INTEGER(iwp) :: ibit12 !:
1233	INTEGER(iwp) :: ibit13 !:
1234	INTEGER(iwp) :: ibit14 !:
1235	INTEGER(iwp) :: ibit15 !:
1236	INTEGER(iwp) :: ibit16 !:
1237	INTEGER(iwp) :: ibit17 !:
1238	INTEGER(iwp) :: i_omp !:
1239	INTEGER(iwp) :: j !:
1240	INTEGER(iwp) :: k !:
1241	INTEGER(iwp) :: k_mm !:
1242	INTEGER(iwp) :: k_pp !:
1243	INTEGER(iwp) :: k_ppp !:
1244	INTEGER(iwp) :: tn !:
1245
1246	REAL(wp) :: diss_d !:
1247	REAL(wp) :: div !:
1248	REAL(wp) :: flux_d !:
1249	REAL(wp) :: gu !:
1250	REAL(wp) :: gv !:
1251	REAL(wp) :: u_comp_l !:
1252	REAL(wp) :: v_comp !:
1253	REAL(wp) :: w_comp !:
1254
1255	REAL(wp), DIMENSION(nzb:nzt+1) :: diss_n !:
1256	REAL(wp), DIMENSION(nzb:nzt+1) :: diss_r !:
1257	REAL(wp), DIMENSION(nzb:nzt+1) :: diss_t !:
1258	REAL(wp), DIMENSION(nzb:nzt+1) :: flux_n !:
1259	REAL(wp), DIMENSION(nzb:nzt+1) :: flux_r !:
1260	REAL(wp), DIMENSION(nzb:nzt+1) :: flux_t !:
1261	REAL(wp), DIMENSION(nzb:nzt+1) :: u_comp !:
1262
1263	gu = 2.0_wp * u_gtrans
1264	gv = 2.0_wp * v_gtrans
1265	!
1266	!-- Compute southside fluxes for the respective boundary of PE
1267	IF ( j == nys ) THEN
1268
1269	DO k = nzb+1, nzb_max
1270
1271	ibit14 = IBITS(wall_flags_0(k,j-1,i),14,1)
1272	ibit13 = IBITS(wall_flags_0(k,j-1,i),13,1)
1273	ibit12 = IBITS(wall_flags_0(k,j-1,i),12,1)
1274
1275	v_comp = v(k,j,i) + v(k,j,i-1) - gv
1276	flux_s_u(k,tn) = v_comp * ( &
1277	( 37.0_wp * ibit14 * adv_mom_5 &
1278	+ 7.0_wp * ibit13 * adv_mom_3 &
1279	+ ibit12 * adv_mom_1 &
1280	) * &
1281	( u(k,j,i) + u(k,j-1,i) ) &
1282	- ( 8.0_wp * ibit14 * adv_mom_5 &
1283	+ ibit13 * adv_mom_3 &
1284	) * &
1285	( u(k,j+1,i) + u(k,j-2,i) ) &
1286	+ ( ibit14 * adv_mom_5 &
1287	) * &
1288	( u(k,j+2,i) + u(k,j-3,i) ) &
1289	)
1290
1291	diss_s_u(k,tn) = - ABS ( v_comp ) * ( &
1292	( 10.0_wp * ibit14 * adv_mom_5 &
1293	+ 3.0_wp * ibit13 * adv_mom_3 &
1294	+ ibit12 * adv_mom_1 &
1295	) * &
1296	( u(k,j,i) - u(k,j-1,i) ) &
1297	- ( 5.0_wp * ibit14 * adv_mom_5 &
1298	+ ibit13 * adv_mom_3 &
1299	) * &
1300	( u(k,j+1,i) - u(k,j-2,i) ) &
1301	+ ( ibit14 * adv_mom_5 &
1302	) * &
1303	( u(k,j+2,i) - u(k,j-3,i) ) &
1304	)
1305
1306	ENDDO
1307
1308	DO k = nzb_max+1, nzt
1309
1310	v_comp = v(k,j,i) + v(k,j,i-1) - gv
1311	flux_s_u(k,tn) = v_comp * ( &
1312	37.0_wp * ( u(k,j,i) + u(k,j-1,i) ) &
1313	- 8.0_wp * ( u(k,j+1,i) + u(k,j-2,i) ) &
1314	+ ( u(k,j+2,i) + u(k,j-3,i) ) ) * adv_mom_5
1315	diss_s_u(k,tn) = - ABS(v_comp) * ( &
1316	10.0_wp * ( u(k,j,i) - u(k,j-1,i) ) &
1317	- 5.0_wp * ( u(k,j+1,i) - u(k,j-2,i) ) &
1318	+ ( u(k,j+2,i) - u(k,j-3,i) ) ) * adv_mom_5
1319
1320	ENDDO
1321
1322	ENDIF
1323	!
1324	!-- Compute leftside fluxes for the respective boundary of PE
1325	IF ( i == i_omp ) THEN
1326
1327	DO k = nzb+1, nzb_max
1328
1329	ibit11 = IBITS(wall_flags_0(k,j,i-1),11,1)
1330	ibit10 = IBITS(wall_flags_0(k,j,i-1),10,1)
1331	ibit9 = IBITS(wall_flags_0(k,j,i-1),9,1)
1332
1333	u_comp_l = u(k,j,i) + u(k,j,i-1) - gu
1334	flux_l_u(k,j,tn) = u_comp_l * ( &
1335	( 37.0_wp * ibit11 * adv_mom_5 &
1336	+ 7.0_wp * ibit10 * adv_mom_3 &
1337	+ ibit9 * adv_mom_1 &
1338	) * &
1339	( u(k,j,i) + u(k,j,i-1) ) &
1340	- ( 8.0_wp * ibit11 * adv_mom_5 &
1341	+ ibit10 * adv_mom_3 &
1342	) * &
1343	( u(k,j,i+1) + u(k,j,i-2) ) &
1344	+ ( ibit11 * adv_mom_5 &
1345	) * &
1346	( u(k,j,i+2) + u(k,j,i-3) ) &
1347	)
1348
1349	diss_l_u(k,j,tn) = - ABS( u_comp_l ) * ( &
1350	( 10.0_wp * ibit11 * adv_mom_5 &
1351	+ 3.0_wp * ibit10 * adv_mom_3 &
1352	+ ibit9 * adv_mom_1 &
1353	) * &
1354	( u(k,j,i) - u(k,j,i-1) ) &
1355	- ( 5.0_wp * ibit11 * adv_mom_5 &
1356	+ ibit10 * adv_mom_3 &
1357	) * &
1358	( u(k,j,i+1) - u(k,j,i-2) ) &
1359	+ ( ibit11 * adv_mom_5 &
1360	) * &
1361	( u(k,j,i+2) - u(k,j,i-3) ) &
1362	)
1363
1364	ENDDO
1365
1366	DO k = nzb_max+1, nzt
1367
1368	u_comp_l = u(k,j,i) + u(k,j,i-1) - gu
1369	flux_l_u(k,j,tn) = u_comp_l * ( &
1370	37.0_wp * ( u(k,j,i) + u(k,j,i-1) ) &
1371	- 8.0_wp * ( u(k,j,i+1) + u(k,j,i-2) ) &
1372	+ ( u(k,j,i+2) + u(k,j,i-3) ) ) * adv_mom_5
1373	diss_l_u(k,j,tn) = - ABS(u_comp_l) * ( &
1374	10.0_wp * ( u(k,j,i) - u(k,j,i-1) ) &
1375	- 5.0_wp * ( u(k,j,i+1) - u(k,j,i-2) ) &
1376	+ ( u(k,j,i+2) - u(k,j,i-3) ) ) * adv_mom_5
1377
1378	ENDDO
1379
1380	ENDIF
1381
1382	flux_t(0) = 0.0_wp
1383	diss_t(0) = 0.0_wp
1384	flux_d = 0.0_wp
1385	diss_d = 0.0_wp
1386	!
1387	!-- Now compute the fluxes tendency terms for the horizontal and
1388	!-- vertical parts.
1389	DO k = nzb+1, nzb_max
1390
1391	ibit11 = IBITS(wall_flags_0(k,j,i),11,1)
1392	ibit10 = IBITS(wall_flags_0(k,j,i),10,1)
1393	ibit9 = IBITS(wall_flags_0(k,j,i),9,1)
1394
1395	u_comp(k) = u(k,j,i+1) + u(k,j,i)
1396	flux_r(k) = ( u_comp(k) - gu ) * ( &
1397	( 37.0_wp * ibit11 * adv_mom_5 &
1398	+ 7.0_wp * ibit10 * adv_mom_3 &
1399	+ ibit9 * adv_mom_1 &
1400	) * &
1401	( u(k,j,i+1) + u(k,j,i) ) &
1402	- ( 8.0_wp * ibit11 * adv_mom_5 &
1403	+ ibit10 * adv_mom_3 &
1404	) * &
1405	( u(k,j,i+2) + u(k,j,i-1) ) &
1406	+ ( ibit11 * adv_mom_5 &
1407	) * &
1408	( u(k,j,i+3) + u(k,j,i-2) ) &
1409	)
1410
1411	diss_r(k) = - ABS( u_comp(k) - gu ) * ( &
1412	( 10.0_wp * ibit11 * adv_mom_5 &
1413	+ 3.0_wp * ibit10 * adv_mom_3 &
1414	+ ibit9 * adv_mom_1 &
1415	) * &
1416	( u(k,j,i+1) - u(k,j,i) ) &
1417	- ( 5.0_wp * ibit11 * adv_mom_5 &
1418	+ ibit10 * adv_mom_3 &
1419	) * &
1420	( u(k,j,i+2) - u(k,j,i-1) ) &
1421	+ ( ibit11 * adv_mom_5 &
1422	) * &
1423	( u(k,j,i+3) - u(k,j,i-2) ) &
1424	)
1425
1426	ibit14 = IBITS(wall_flags_0(k,j,i),14,1)
1427	ibit13 = IBITS(wall_flags_0(k,j,i),13,1)
1428	ibit12 = IBITS(wall_flags_0(k,j,i),12,1)
1429
1430	v_comp = v(k,j+1,i) + v(k,j+1,i-1) - gv
1431	flux_n(k) = v_comp * ( &
1432	( 37.0_wp * ibit14 * adv_mom_5 &
1433	+ 7.0_wp * ibit13 * adv_mom_3 &
1434	+ ibit12 * adv_mom_1 &
1435	) * &
1436	( u(k,j+1,i) + u(k,j,i) ) &
1437	- ( 8.0_wp * ibit14 * adv_mom_5 &
1438	+ ibit13 * adv_mom_3 &
1439	) * &
1440	( u(k,j+2,i) + u(k,j-1,i) ) &
1441	+ ( ibit14 * adv_mom_5 &
1442	) * &
1443	( u(k,j+3,i) + u(k,j-2,i) ) &
1444	)
1445
1446	diss_n(k) = - ABS ( v_comp ) * ( &
1447	( 10.0_wp * ibit14 * adv_mom_5 &
1448	+ 3.0_wp * ibit13 * adv_mom_3 &
1449	+ ibit12 * adv_mom_1 &
1450	) * &
1451	( u(k,j+1,i) - u(k,j,i) ) &
1452	- ( 5.0_wp * ibit14 * adv_mom_5 &
1453	+ ibit13 * adv_mom_3 &
1454	) * &
1455	( u(k,j+2,i) - u(k,j-1,i) ) &
1456	+ ( ibit14 * adv_mom_5 &
1457	) * &
1458	( u(k,j+3,i) - u(k,j-2,i) ) &
1459	)
1460	!
1461	!-- k index has to be modified near bottom and top, else array
1462	!-- subscripts will be exceeded.
1463	ibit17 = IBITS(wall_flags_0(k,j,i),17,1)
1464	ibit16 = IBITS(wall_flags_0(k,j,i),16,1)
1465	ibit15 = IBITS(wall_flags_0(k,j,i),15,1)
1466
1467	k_ppp = k + 3 * ibit17
1468	k_pp = k + 2 * ( 1 - ibit15 )
1469	k_mm = k - 2 * ibit17
1470
1471	w_comp = w(k,j,i) + w(k,j,i-1)
1472	flux_t(k) = w_comp * ( &
1473	( 37.0_wp * ibit17 * adv_mom_5 &
1474	+ 7.0_wp * ibit16 * adv_mom_3 &
1475	+ ibit15 * adv_mom_1 &
1476	) * &
1477	( u(k+1,j,i) + u(k,j,i) ) &
1478	- ( 8.0_wp * ibit17 * adv_mom_5 &
1479	+ ibit16 * adv_mom_3 &
1480	) * &
1481	( u(k_pp,j,i) + u(k-1,j,i) ) &
1482	+ ( ibit17 * adv_mom_5 &
1483	) * &
1484	( u(k_ppp,j,i) + u(k_mm,j,i) ) &
1485	)
1486
1487	diss_t(k) = - ABS( w_comp ) * ( &
1488	( 10.0_wp * ibit17 * adv_mom_5 &
1489	+ 3.0_wp * ibit16 * adv_mom_3 &
1490	+ ibit15 * adv_mom_1 &
1491	) * &
1492	( u(k+1,j,i) - u(k,j,i) ) &
1493	- ( 5.0_wp * ibit17 * adv_mom_5 &
1494	+ ibit16 * adv_mom_3 &
1495	) * &
1496	( u(k_pp,j,i) - u(k-1,j,i) ) &
1497	+ ( ibit17 * adv_mom_5 &
1498	) * &
1499	( u(k_ppp,j,i) - u(k_mm,j,i) ) &
1500	)
1501	!
1502	!-- Calculate the divergence of the velocity field. A respective
1503	!-- correction is needed to overcome numerical instabilities introduced
1504	!-- by a not sufficient reduction of divergences near topography.
1505	div = ( ( u_comp(k) * ( ibit9 + ibit10 + ibit11 ) &
1506	- ( u(k,j,i) + u(k,j,i-1) ) &
1507	* ( IBITS(wall_flags_0(k,j,i-1),9,1) &
1508	+ IBITS(wall_flags_0(k,j,i-1),10,1) &
1509	+ IBITS(wall_flags_0(k,j,i-1),11,1) &
1510	) &
1511	) * ddx &
1512	+ ( ( v_comp + gv ) * ( ibit12 + ibit13 + ibit14 ) &
1513	- ( v(k,j,i) + v(k,j,i-1 ) ) &
1514	* ( IBITS(wall_flags_0(k,j-1,i),12,1) &
1515	+ IBITS(wall_flags_0(k,j-1,i),13,1) &
1516	+ IBITS(wall_flags_0(k,j-1,i),14,1) &
1517	) &
1518	) * ddy &
1519	+ ( w_comp * ( ibit15 + ibit16 + ibit17 ) &
1520	- ( w(k-1,j,i) + w(k-1,j,i-1) ) &
1521	* ( IBITS(wall_flags_0(k-1,j,i),15,1) &
1522	+ IBITS(wall_flags_0(k-1,j,i),16,1) &
1523	+ IBITS(wall_flags_0(k-1,j,i),17,1) &
1524	) &
1525	) * ddzw(k) &
1526	) * 0.5_wp
1527
1528
1529	tend(k,j,i) = tend(k,j,i) - ( &
1530	( flux_r(k) + diss_r(k) &
1531	- flux_l_u(k,j,tn) - diss_l_u(k,j,tn) ) * ddx &
1532	+ ( flux_n(k) + diss_n(k) &
1533	- flux_s_u(k,tn) - diss_s_u(k,tn) ) * ddy &
1534	+ ( flux_t(k) + diss_t(k) &
1535	- flux_d - diss_d ) * ddzw(k) &
1536	) + div * u(k,j,i)
1537
1538	flux_l_u(k,j,tn) = flux_r(k)
1539	diss_l_u(k,j,tn) = diss_r(k)
1540	flux_s_u(k,tn) = flux_n(k)
1541	diss_s_u(k,tn) = diss_n(k)
1542	flux_d = flux_t(k)
1543	diss_d = diss_t(k)
1544	!
1545	!-- Statistical Evaluation of u'u'. The factor has to be applied for
1546	!-- right evaluation when gallilei_trans = .T. .
1547	sums_us2_ws_l(k,tn) = sums_us2_ws_l(k,tn) &
1548	+ ( flux_r(k) * &
1549	( u_comp(k) - 2.0_wp * hom(k,1,1,0) ) &
1550	/ ( u_comp(k) - gu + 1.0E-20_wp ) &
1551	+ diss_r(k) * &
1552	ABS( u_comp(k) - 2.0_wp * hom(k,1,1,0) ) &
1553	/ ( ABS( u_comp(k) - gu ) + 1.0E-20_wp ) ) &
1554	* weight_substep(intermediate_timestep_count)
1555	!
1556	!-- Statistical Evaluation of w'u'.
1557	sums_wsus_ws_l(k,tn) = sums_wsus_ws_l(k,tn) &
1558	+ ( flux_t(k) + diss_t(k) ) &
1559	* weight_substep(intermediate_timestep_count)
1560	ENDDO
1561
1562	DO k = nzb_max+1, nzt
1563
1564	u_comp(k) = u(k,j,i+1) + u(k,j,i)
1565	flux_r(k) = ( u_comp(k) - gu ) * ( &
1566	37.0_wp * ( u(k,j,i+1) + u(k,j,i) ) &
1567	- 8.0_wp * ( u(k,j,i+2) + u(k,j,i-1) ) &
1568	+ ( u(k,j,i+3) + u(k,j,i-2) ) ) * adv_mom_5
1569	diss_r(k) = - ABS( u_comp(k) - gu ) * ( &
1570	10.0_wp * ( u(k,j,i+1) - u(k,j,i) ) &
1571	- 5.0_wp * ( u(k,j,i+2) - u(k,j,i-1) ) &
1572	+ ( u(k,j,i+3) - u(k,j,i-2) ) ) * adv_mom_5
1573
1574	v_comp = v(k,j+1,i) + v(k,j+1,i-1) - gv
1575	flux_n(k) = v_comp * ( &
1576	37.0_wp * ( u(k,j+1,i) + u(k,j,i) ) &
1577	- 8.0_wp * ( u(k,j+2,i) + u(k,j-1,i) ) &
1578	+ ( u(k,j+3,i) + u(k,j-2,i) ) ) * adv_mom_5
1579	diss_n(k) = - ABS( v_comp ) * ( &
1580	10.0_wp * ( u(k,j+1,i) - u(k,j,i) ) &
1581	- 5.0_wp * ( u(k,j+2,i) - u(k,j-1,i) ) &
1582	+ ( u(k,j+3,i) - u(k,j-2,i) ) ) * adv_mom_5
1583	!
1584	!-- k index has to be modified near bottom and top, else array
1585	!-- subscripts will be exceeded.
1586	ibit17 = IBITS(wall_flags_0(k,j,i),17,1)
1587	ibit16 = IBITS(wall_flags_0(k,j,i),16,1)
1588	ibit15 = IBITS(wall_flags_0(k,j,i),15,1)
1589
1590	k_ppp = k + 3 * ibit17
1591	k_pp = k + 2 * ( 1 - ibit15 )
1592	k_mm = k - 2 * ibit17
1593
1594	w_comp = w(k,j,i) + w(k,j,i-1)
1595	flux_t(k) = w_comp * ( &
1596	( 37.0_wp * ibit17 * adv_mom_5 &
1597	+ 7.0_wp * ibit16 * adv_mom_3 &
1598	+ ibit15 * adv_mom_1 &
1599	) * &
1600	( u(k+1,j,i) + u(k,j,i) ) &
1601	- ( 8.0_wp * ibit17 * adv_mom_5 &
1602	+ ibit16 * adv_mom_3 &
1603	) * &
1604	( u(k_pp,j,i) + u(k-1,j,i) ) &
1605	+ ( ibit17 * adv_mom_5 &
1606	) * &
1607	( u(k_ppp,j,i) + u(k_mm,j,i) ) &
1608	)
1609
1610	diss_t(k) = - ABS( w_comp ) * ( &
1611	( 10.0_wp * ibit17 * adv_mom_5 &
1612	+ 3.0_wp * ibit16 * adv_mom_3 &
1613	+ ibit15 * adv_mom_1 &
1614	) * &
1615	( u(k+1,j,i) - u(k,j,i) ) &
1616	- ( 5.0_wp * ibit17 * adv_mom_5 &
1617	+ ibit16 * adv_mom_3 &
1618	) * &
1619	( u(k_pp,j,i) - u(k-1,j,i) ) &
1620	+ ( ibit17 * adv_mom_5 &
1621	) * &
1622	( u(k_ppp,j,i) - u(k_mm,j,i) ) &
1623	)
1624	!
1625	!-- Calculate the divergence of the velocity field. A respective
1626	!-- correction is needed to overcome numerical instabilities introduced
1627	!-- by a not sufficient reduction of divergences near topography.
1628	div = ( ( u_comp(k) - ( u(k,j,i) + u(k,j,i-1) ) ) * ddx &
1629	+ ( v_comp + gv - ( v(k,j,i) + v(k,j,i-1 ) ) ) * ddy &
1630	+ ( w_comp - ( w(k-1,j,i) + w(k-1,j,i-1) ) ) * ddzw(k) &
1631	) * 0.5_wp
1632
1633	tend(k,j,i) = tend(k,j,i) - ( &
1634	( flux_r(k) + diss_r(k) &
1635	- flux_l_u(k,j,tn) - diss_l_u(k,j,tn) ) * ddx &
1636	+ ( flux_n(k) + diss_n(k) &
1637	- flux_s_u(k,tn) - diss_s_u(k,tn) ) * ddy &
1638	+ ( flux_t(k) + diss_t(k) &
1639	- flux_d - diss_d ) * ddzw(k) &
1640	) + div * u(k,j,i)
1641
1642	flux_l_u(k,j,tn) = flux_r(k)
1643	diss_l_u(k,j,tn) = diss_r(k)
1644	flux_s_u(k,tn) = flux_n(k)
1645	diss_s_u(k,tn) = diss_n(k)
1646	flux_d = flux_t(k)
1647	diss_d = diss_t(k)
1648	!
1649	!-- Statistical Evaluation of u'u'. The factor has to be applied for
1650	!-- right evaluation when gallilei_trans = .T. .
1651	sums_us2_ws_l(k,tn) = sums_us2_ws_l(k,tn) &
1652	+ ( flux_r(k) * &
1653	( u_comp(k) - 2.0_wp * hom(k,1,1,0) ) &
1654	/ ( u_comp(k) - gu + 1.0E-20_wp ) &
1655	+ diss_r(k) * &
1656	ABS( u_comp(k) - 2.0_wp * hom(k,1,1,0) ) &
1657	/ ( ABS( u_comp(k) - gu ) + 1.0E-20_wp ) ) &
1658	* weight_substep(intermediate_timestep_count)
1659	!
1660	!-- Statistical Evaluation of w'u'.
1661	sums_wsus_ws_l(k,tn) = sums_wsus_ws_l(k,tn) &
1662	+ ( flux_t(k) + diss_t(k) ) &
1663	* weight_substep(intermediate_timestep_count)
1664	ENDDO
1665
1666	sums_us2_ws_l(nzb,tn) = sums_us2_ws_l(nzb+1,tn)
1667
1668
1669
1670	END SUBROUTINE advec_u_ws_ij
1671
1672
1673
1674	!-----------------------------------------------------------------------------!
1675	! Advection of v-component - Call for grid point i,j
1676	!-----------------------------------------------------------------------------!
1677	SUBROUTINE advec_v_ws_ij( i, j, i_omp, tn )
1678
1679	USE arrays_3d, &
1680	ONLY: ddzw, diss_l_v, diss_s_v, flux_l_v, flux_s_v, tend, u, v, w
1681
1682	USE constants, &
1683	ONLY: adv_mom_1, adv_mom_3, adv_mom_5
1684
1685	USE control_parameters, &
1686	ONLY: intermediate_timestep_count, u_gtrans, v_gtrans
1687
1688	USE grid_variables, &
1689	ONLY: ddx, ddy
1690
1691	USE indices, &
1692	ONLY: nxl, nxr, nyn, nys, nysv, nzb, nzb_max, nzt, wall_flags_0
1693
1694	USE kinds
1695
1696	USE statistics, &
1697	ONLY: hom, sums_vs2_ws_l, sums_wsvs_ws_l, weight_substep
1698
1699	IMPLICIT NONE
1700
1701	INTEGER(iwp) :: i !:
1702	INTEGER(iwp) :: ibit18 !:
1703	INTEGER(iwp) :: ibit19 !:
1704	INTEGER(iwp) :: ibit20 !:
1705	INTEGER(iwp) :: ibit21 !:
1706	INTEGER(iwp) :: ibit22 !:
1707	INTEGER(iwp) :: ibit23 !:
1708	INTEGER(iwp) :: ibit24 !:
1709	INTEGER(iwp) :: ibit25 !:
1710	INTEGER(iwp) :: ibit26 !:
1711	INTEGER(iwp) :: i_omp !:
1712	INTEGER(iwp) :: j !:
1713	INTEGER(iwp) :: k !:
1714	INTEGER(iwp) :: k_mm !:
1715	INTEGER(iwp) :: k_pp !:
1716	INTEGER(iwp) :: k_ppp !:
1717	INTEGER(iwp) :: tn !:
1718
1719	REAL(wp) :: diss_d !:
1720	REAL(wp) :: div !:
1721	REAL(wp) :: flux_d !:
1722	REAL(wp) :: gu !:
1723	REAL(wp) :: gv !:
1724	REAL(wp) :: u_comp !:
1725	REAL(wp) :: v_comp_l !:
1726	REAL(wp) :: w_comp !:
1727
1728	REAL(wp), DIMENSION(nzb:nzt+1) :: diss_n !:
1729	REAL(wp), DIMENSION(nzb:nzt+1) :: diss_r !:
1730	REAL(wp), DIMENSION(nzb:nzt+1) :: diss_t !:
1731	REAL(wp), DIMENSION(nzb:nzt+1) :: flux_n !:
1732	REAL(wp), DIMENSION(nzb:nzt+1) :: flux_r !:
1733	REAL(wp), DIMENSION(nzb:nzt+1) :: flux_t !:
1734	REAL(wp), DIMENSION(nzb:nzt+1) :: v_comp !:
1735
1736	gu = 2.0_wp * u_gtrans
1737	gv = 2.0_wp * v_gtrans
1738
1739	!
1740	!-- Compute leftside fluxes for the respective boundary.
1741	IF ( i == i_omp ) THEN
1742
1743	DO k = nzb+1, nzb_max
1744
1745	ibit20 = IBITS(wall_flags_0(k,j,i-1),20,1)
1746	ibit19 = IBITS(wall_flags_0(k,j,i-1),19,1)
1747	ibit18 = IBITS(wall_flags_0(k,j,i-1),18,1)
1748
1749	u_comp = u(k,j-1,i) + u(k,j,i) - gu
1750	flux_l_v(k,j,tn) = u_comp * ( &
1751	( 37.0_wp * ibit20 * adv_mom_5 &
1752	+ 7.0_wp * ibit19 * adv_mom_3 &
1753	+ ibit18 * adv_mom_1 &
1754	) * &
1755	( v(k,j,i) + v(k,j,i-1) ) &
1756	- ( 8.0_wp * ibit20 * adv_mom_5 &
1757	+ ibit19 * adv_mom_3 &
1758	) * &
1759	( v(k,j,i+1) + v(k,j,i-2) ) &
1760	+ ( ibit20 * adv_mom_5 &
1761	) * &
1762	( v(k,j,i+2) + v(k,j,i-3) ) &
1763	)
1764
1765	diss_l_v(k,j,tn) = - ABS( u_comp ) * ( &
1766	( 10.0_wp * ibit20 * adv_mom_5 &
1767	+ 3.0_wp * ibit19 * adv_mom_3 &
1768	+ ibit18 * adv_mom_1 &
1769	) * &
1770	( v(k,j,i) - v(k,j,i-1) ) &
1771	- ( 5.0_wp * ibit20 * adv_mom_5 &
1772	+ ibit19 * adv_mom_3 &
1773	) * &
1774	( v(k,j,i+1) - v(k,j,i-2) ) &
1775	+ ( ibit20 * adv_mom_5 &
1776	) * &
1777	( v(k,j,i+2) - v(k,j,i-3) ) &
1778	)
1779
1780	ENDDO
1781
1782	DO k = nzb_max+1, nzt
1783
1784	u_comp = u(k,j-1,i) + u(k,j,i) - gu
1785	flux_l_v(k,j,tn) = u_comp * ( &
1786	37.0_wp * ( v(k,j,i) + v(k,j,i-1) ) &
1787	- 8.0_wp * ( v(k,j,i+1) + v(k,j,i-2) ) &
1788	+ ( v(k,j,i+2) + v(k,j,i-3) ) ) * adv_mom_5
1789	diss_l_v(k,j,tn) = - ABS( u_comp ) * ( &
1790	10.0_wp * ( v(k,j,i) - v(k,j,i-1) ) &
1791	- 5.0_wp * ( v(k,j,i+1) - v(k,j,i-2) ) &
1792	+ ( v(k,j,i+2) - v(k,j,i-3) ) ) * adv_mom_5
1793
1794	ENDDO
1795
1796	ENDIF
1797	!
1798	!-- Compute southside fluxes for the respective boundary.
1799	IF ( j == nysv ) THEN
1800
1801	DO k = nzb+1, nzb_max
1802
1803	ibit23 = IBITS(wall_flags_0(k,j-1,i),23,1)
1804	ibit22 = IBITS(wall_flags_0(k,j-1,i),22,1)
1805	ibit21 = IBITS(wall_flags_0(k,j-1,i),21,1)
1806
1807	v_comp_l = v(k,j,i) + v(k,j-1,i) - gv
1808	flux_s_v(k,tn) = v_comp_l * ( &
1809	( 37.0_wp * ibit23 * adv_mom_5 &
1810	+ 7.0_wp * ibit22 * adv_mom_3 &
1811	+ ibit21 * adv_mom_1 &
1812	) * &
1813	( v(k,j,i) + v(k,j-1,i) ) &
1814	- ( 8.0_wp * ibit23 * adv_mom_5 &
1815	+ ibit22 * adv_mom_3 &
1816	) * &
1817	( v(k,j+1,i) + v(k,j-2,i) ) &
1818	+ ( ibit23 * adv_mom_5 &
1819	) * &
1820	( v(k,j+2,i) + v(k,j-3,i) ) &
1821	)
1822
1823	diss_s_v(k,tn) = - ABS( v_comp_l ) * ( &
1824	( 10.0_wp * ibit23 * adv_mom_5 &
1825	+ 3.0_wp * ibit22 * adv_mom_3 &
1826	+ ibit21 * adv_mom_1 &
1827	) * &
1828	( v(k,j,i) - v(k,j-1,i) ) &
1829	- ( 5.0_wp * ibit23 * adv_mom_5 &
1830	+ ibit22 * adv_mom_3 &
1831	) * &
1832	( v(k,j+1,i) - v(k,j-2,i) ) &
1833	+ ( ibit23 * adv_mom_5 &
1834	) * &
1835	( v(k,j+2,i) - v(k,j-3,i) ) &
1836	)
1837
1838	ENDDO
1839
1840	DO k = nzb_max+1, nzt
1841
1842	v_comp_l = v(k,j,i) + v(k,j-1,i) - gv
1843	flux_s_v(k,tn) = v_comp_l * ( &
1844	37.0_wp * ( v(k,j,i) + v(k,j-1,i) ) &
1845	- 8.0_wp * ( v(k,j+1,i) + v(k,j-2,i) ) &
1846	+ ( v(k,j+2,i) + v(k,j-3,i) ) ) * adv_mom_5
1847	diss_s_v(k,tn) = - ABS( v_comp_l ) * ( &
1848	10.0_wp * ( v(k,j,i) - v(k,j-1,i) ) &
1849	- 5.0_wp * ( v(k,j+1,i) - v(k,j-2,i) ) &
1850	+ ( v(k,j+2,i) - v(k,j-3,i) ) ) * adv_mom_5
1851
1852	ENDDO
1853
1854	ENDIF
1855
1856	flux_t(0) = 0.0_wp
1857	diss_t(0) = 0.0_wp
1858	flux_d = 0.0_wp
1859	diss_d = 0.0_wp
1860	!
1861	!-- Now compute the fluxes and tendency terms for the horizontal and
1862	!-- verical parts.
1863	DO k = nzb+1, nzb_max
1864
1865	ibit20 = IBITS(wall_flags_0(k,j,i),20,1)
1866	ibit19 = IBITS(wall_flags_0(k,j,i),19,1)
1867	ibit18 = IBITS(wall_flags_0(k,j,i),18,1)
1868
1869	u_comp = u(k,j-1,i+1) + u(k,j,i+1) - gu
1870	flux_r(k) = u_comp * ( &
1871	( 37.0_wp * ibit20 * adv_mom_5 &
1872	+ 7.0_wp * ibit19 * adv_mom_3 &
1873	+ ibit18 * adv_mom_1 &
1874	) * &
1875	( v(k,j,i+1) + v(k,j,i) ) &
1876	- ( 8.0_wp * ibit20 * adv_mom_5 &
1877	+ ibit19 * adv_mom_3 &
1878	) * &
1879	( v(k,j,i+2) + v(k,j,i-1) ) &
1880	+ ( ibit20 * adv_mom_5 &
1881	) * &
1882	( v(k,j,i+3) + v(k,j,i-2) ) &
1883	)
1884
1885	diss_r(k) = - ABS( u_comp ) * ( &
1886	( 10.0_wp * ibit20 * adv_mom_5 &
1887	+ 3.0_wp * ibit19 * adv_mom_3 &
1888	+ ibit18 * adv_mom_1 &
1889	) * &
1890	( v(k,j,i+1) - v(k,j,i) ) &
1891	- ( 5.0_wp * ibit20 * adv_mom_5 &
1892	+ ibit19 * adv_mom_3 &
1893	) * &
1894	( v(k,j,i+2) - v(k,j,i-1) ) &
1895	+ ( ibit20 * adv_mom_5 &
1896	) * &
1897	( v(k,j,i+3) - v(k,j,i-2) ) &
1898	)
1899
1900	ibit23 = IBITS(wall_flags_0(k,j,i),23,1)
1901	ibit22 = IBITS(wall_flags_0(k,j,i),22,1)
1902	ibit21 = IBITS(wall_flags_0(k,j,i),21,1)
1903
1904
1905	v_comp(k) = v(k,j+1,i) + v(k,j,i)
1906	flux_n(k) = ( v_comp(k) - gv ) * ( &
1907	( 37.0_wp * ibit23 * adv_mom_5 &
1908	+ 7.0_wp * ibit22 * adv_mom_3 &
1909	+ ibit21 * adv_mom_1 &
1910	) * &
1911	( v(k,j+1,i) + v(k,j,i) ) &
1912	- ( 8.0_wp * ibit23 * adv_mom_5 &
1913	+ ibit22 * adv_mom_3 &
1914	) * &
1915	( v(k,j+2,i) + v(k,j-1,i) ) &
1916	+ ( ibit23 * adv_mom_5 &
1917	) * &
1918	( v(k,j+3,i) + v(k,j-2,i) ) &
1919	)
1920
1921	diss_n(k) = - ABS( v_comp(k) - gv ) * ( &
1922	( 10.0_wp * ibit23 * adv_mom_5 &
1923	+ 3.0_wp * ibit22 * adv_mom_3 &
1924	+ ibit21 * adv_mom_1 &
1925	) * &
1926	( v(k,j+1,i) - v(k,j,i) ) &
1927	- ( 5.0_wp * ibit23 * adv_mom_5 &
1928	+ ibit22 * adv_mom_3 &
1929	) * &
1930	( v(k,j+2,i) - v(k,j-1,i) ) &
1931	+ ( ibit23 * adv_mom_5 &
1932	) * &
1933	( v(k,j+3,i) - v(k,j-2,i) ) &
1934	)
1935	!
1936	!-- k index has to be modified near bottom and top, else array
1937	!-- subscripts will be exceeded.
1938	ibit26 = IBITS(wall_flags_0(k,j,i),26,1)
1939	ibit25 = IBITS(wall_flags_0(k,j,i),25,1)
1940	ibit24 = IBITS(wall_flags_0(k,j,i),24,1)
1941
1942	k_ppp = k + 3 * ibit26
1943	k_pp = k + 2 * ( 1 - ibit24 )
1944	k_mm = k - 2 * ibit26
1945
1946	w_comp = w(k,j-1,i) + w(k,j,i)
1947	flux_t(k) = w_comp * ( &
1948	( 37.0_wp * ibit26 * adv_mom_5 &
1949	+ 7.0_wp * ibit25 * adv_mom_3 &
1950	+ ibit24 * adv_mom_1 &
1951	) * &
1952	( v(k+1,j,i) + v(k,j,i) ) &
1953	- ( 8.0_wp * ibit26 * adv_mom_5 &
1954	+ ibit25 * adv_mom_3 &
1955	) * &
1956	( v(k_pp,j,i) + v(k-1,j,i) ) &
1957	+ ( ibit26 * adv_mom_5 &
1958	) * &
1959	( v(k_ppp,j,i) + v(k_mm,j,i) ) &
1960	)
1961
1962	diss_t(k) = - ABS( w_comp ) * ( &
1963	( 10.0_wp * ibit26 * adv_mom_5 &
1964	+ 3.0_wp * ibit25 * adv_mom_3 &
1965	+ ibit24 * adv_mom_1 &
1966	) * &
1967	( v(k+1,j,i) - v(k,j,i) ) &
1968	- ( 5.0_wp * ibit26 * adv_mom_5 &
1969	+ ibit25 * adv_mom_3 &
1970	) * &
1971	( v(k_pp,j,i) - v(k-1,j,i) ) &
1972	+ ( ibit26 * adv_mom_5 &
1973	) * &
1974	( v(k_ppp,j,i) - v(k_mm,j,i) ) &
1975	)
1976	!
1977	!-- Calculate the divergence of the velocity field. A respective
1978	!-- correction is needed to overcome numerical instabilities introduced
1979	!-- by a not sufficient reduction of divergences near topography.
1980	div = ( ( ( u_comp + gu ) &
1981	* ( ibit18 + ibit19 + ibit20 ) &
1982	- ( u(k,j-1,i) + u(k,j,i) ) &
1983	* ( IBITS(wall_flags_0(k,j,i-1),18,1) &
1984	+ IBITS(wall_flags_0(k,j,i-1),19,1) &
1985	+ IBITS(wall_flags_0(k,j,i-1),20,1) &
1986	) &
1987	) * ddx &
1988	+ ( v_comp(k) &
1989	* ( ibit21 + ibit22 + ibit23 ) &
1990	- ( v(k,j,i) + v(k,j-1,i) ) &
1991	* ( IBITS(wall_flags_0(k,j-1,i),21,1) &
1992	+ IBITS(wall_flags_0(k,j-1,i),22,1) &
1993	+ IBITS(wall_flags_0(k,j-1,i),23,1) &
1994	) &
1995	) * ddy &
1996	+ ( w_comp &
1997	* ( ibit24 + ibit25 + ibit26 ) &
1998	- ( w(k-1,j-1,i) + w(k-1,j,i) ) &
1999	* ( IBITS(wall_flags_0(k-1,j,i),24,1) &
2000	+ IBITS(wall_flags_0(k-1,j,i),25,1) &
2001	+ IBITS(wall_flags_0(k-1,j,i),26,1) &
2002	) &
2003	) * ddzw(k) &
2004	) * 0.5_wp
2005
2006
2007	tend(k,j,i) = tend(k,j,i) - ( &
2008	( flux_r(k) + diss_r(k) &
2009	- flux_l_v(k,j,tn) - diss_l_v(k,j,tn) ) * ddx &
2010	+ ( flux_n(k) + diss_n(k) &
2011	- flux_s_v(k,tn) - diss_s_v(k,tn) ) * ddy &
2012	+ ( flux_t(k) + diss_t(k) &
2013	- flux_d - diss_d ) * ddzw(k) &
2014	) + v(k,j,i) * div
2015
2016	flux_l_v(k,j,tn) = flux_r(k)
2017	diss_l_v(k,j,tn) = diss_r(k)
2018	flux_s_v(k,tn) = flux_n(k)
2019	diss_s_v(k,tn) = diss_n(k)
2020	flux_d = flux_t(k)
2021	diss_d = diss_t(k)
2022
2023	!
2024	!-- Statistical Evaluation of v'v'. The factor has to be applied for
2025	!-- right evaluation when gallilei_trans = .T. .
2026	sums_vs2_ws_l(k,tn) = sums_vs2_ws_l(k,tn) &
2027	+ ( flux_n(k) &
2028	* ( v_comp(k) - 2.0_wp * hom(k,1,2,0) ) &
2029	/ ( v_comp(k) - gv + 1.0E-20_wp ) &
2030	+ diss_n(k) &
2031	* ABS( v_comp(k) - 2.0_wp * hom(k,1,2,0) ) &
2032	/ ( ABS( v_comp(k) - gv ) +1.0E-20_wp ) ) &
2033	* weight_substep(intermediate_timestep_count)
2034	!
2035	!-- Statistical Evaluation of w'v'.
2036	sums_wsvs_ws_l(k,tn) = sums_wsvs_ws_l(k,tn) &
2037	+ ( flux_t(k) + diss_t(k) ) &
2038	* weight_substep(intermediate_timestep_count)
2039
2040	ENDDO
2041
2042	DO k = nzb_max+1, nzt
2043
2044	u_comp = u(k,j-1,i+1) + u(k,j,i+1) - gu
2045	flux_r(k) = u_comp * ( &
2046	37.0_wp * ( v(k,j,i+1) + v(k,j,i) ) &
2047	- 8.0_wp * ( v(k,j,i+2) + v(k,j,i-1) ) &
2048	+ ( v(k,j,i+3) + v(k,j,i-2) ) ) * adv_mom_5
2049
2050	diss_r(k) = - ABS( u_comp ) * ( &
2051	10.0_wp * ( v(k,j,i+1) - v(k,j,i) ) &
2052	- 5.0_wp * ( v(k,j,i+2) - v(k,j,i-1) ) &
2053	+ ( v(k,j,i+3) - v(k,j,i-2) ) ) * adv_mom_5
2054
2055
2056	v_comp(k) = v(k,j+1,i) + v(k,j,i)
2057	flux_n(k) = ( v_comp(k) - gv ) * ( &
2058	37.0_wp * ( v(k,j+1,i) + v(k,j,i) ) &
2059	- 8.0_wp * ( v(k,j+2,i) + v(k,j-1,i) ) &
2060	+ ( v(k,j+3,i) + v(k,j-2,i) ) ) * adv_mom_5
2061
2062	diss_n(k) = - ABS( v_comp(k) - gv ) * ( &
2063	10.0_wp * ( v(k,j+1,i) - v(k,j,i) ) &
2064	- 5.0_wp * ( v(k,j+2,i) - v(k,j-1,i) ) &
2065	+ ( v(k,j+3,i) - v(k,j-2,i) ) ) * adv_mom_5
2066	!
2067	!-- k index has to be modified near bottom and top, else array
2068	!-- subscripts will be exceeded.
2069	ibit26 = IBITS(wall_flags_0(k,j,i),26,1)
2070	ibit25 = IBITS(wall_flags_0(k,j,i),25,1)
2071	ibit24 = IBITS(wall_flags_0(k,j,i),24,1)
2072
2073	k_ppp = k + 3 * ibit26
2074	k_pp = k + 2 * ( 1 - ibit24 )
2075	k_mm = k - 2 * ibit26
2076
2077	w_comp = w(k,j-1,i) + w(k,j,i)
2078	flux_t(k) = w_comp * ( &
2079	( 37.0_wp * ibit26 * adv_mom_5 &
2080	+ 7.0_wp * ibit25 * adv_mom_3 &
2081	+ ibit24 * adv_mom_1 &
2082	) * &
2083	( v(k+1,j,i) + v(k,j,i) ) &
2084	- ( 8.0_wp * ibit26 * adv_mom_5 &
2085	+ ibit25 * adv_mom_3 &
2086	) * &
2087	( v(k_pp,j,i) + v(k-1,j,i) ) &
2088	+ ( ibit26 * adv_mom_5 &
2089	) * &
2090	( v(k_ppp,j,i) + v(k_mm,j,i) ) &
2091	)
2092
2093	diss_t(k) = - ABS( w_comp ) * ( &
2094	( 10.0_wp * ibit26 * adv_mom_5 &
2095	+ 3.0_wp * ibit25 * adv_mom_3 &
2096	+ ibit24 * adv_mom_1 &
2097	) * &
2098	( v(k+1,j,i) - v(k,j,i) ) &
2099	- ( 5.0_wp * ibit26 * adv_mom_5 &
2100	+ ibit25 * adv_mom_3 &
2101	) * &
2102	( v(k_pp,j,i) - v(k-1,j,i) ) &
2103	+ ( ibit26 * adv_mom_5 &
2104	) * &
2105	( v(k_ppp,j,i) - v(k_mm,j,i) ) &
2106	)
2107	!
2108	!-- Calculate the divergence of the velocity field. A respective
2109	!-- correction is needed to overcome numerical instabilities introduced
2110	!-- by a not sufficient reduction of divergences near topography.
2111	div = ( ( u_comp + gu - ( u(k,j-1,i) + u(k,j,i) ) ) * ddx &
2112	+ ( v_comp(k) - ( v(k,j,i) + v(k,j-1,i) ) ) * ddy &
2113	+ ( w_comp - ( w(k-1,j-1,i) + w(k-1,j,i) ) ) * ddzw(k) &
2114	) * 0.5_wp
2115
2116	tend(k,j,i) = tend(k,j,i) - ( &
2117	( flux_r(k) + diss_r(k) &
2118	- flux_l_v(k,j,tn) - diss_l_v(k,j,tn) ) * ddx &
2119	+ ( flux_n(k) + diss_n(k) &
2120	- flux_s_v(k,tn) - diss_s_v(k,tn) ) * ddy &
2121	+ ( flux_t(k) + diss_t(k) &
2122	- flux_d - diss_d ) * ddzw(k) &
2123	) + v(k,j,i) * div
2124
2125	flux_l_v(k,j,tn) = flux_r(k)
2126	diss_l_v(k,j,tn) = diss_r(k)
2127	flux_s_v(k,tn) = flux_n(k)
2128	diss_s_v(k,tn) = diss_n(k)
2129	flux_d = flux_t(k)
2130	diss_d = diss_t(k)
2131
2132	!
2133	!-- Statistical Evaluation of v'v'. The factor has to be applied for
2134	!-- right evaluation when gallilei_trans = .T. .
2135	sums_vs2_ws_l(k,tn) = sums_vs2_ws_l(k,tn) &
2136	+ ( flux_n(k) &
2137	* ( v_comp(k) - 2.0_wp * hom(k,1,2,0) ) &
2138	/ ( v_comp(k) - gv + 1.0E-20_wp ) &
2139	+ diss_n(k) &
2140	* ABS( v_comp(k) - 2.0_wp * hom(k,1,2,0) ) &
2141	/ ( ABS( v_comp(k) - gv ) +1.0E-20_wp ) ) &
2142	* weight_substep(intermediate_timestep_count)
2143	!
2144	!-- Statistical Evaluation of w'v'.
2145	sums_wsvs_ws_l(k,tn) = sums_wsvs_ws_l(k,tn) &
2146	+ ( flux_t(k) + diss_t(k) ) &
2147	* weight_substep(intermediate_timestep_count)
2148
2149	ENDDO
2150	sums_vs2_ws_l(nzb,tn) = sums_vs2_ws_l(nzb+1,tn)
2151
2152
2153	END SUBROUTINE advec_v_ws_ij
2154
2155
2156
2157	!------------------------------------------------------------------------------!
2158	! Advection of w-component - Call for grid point i,j
2159	!------------------------------------------------------------------------------!
2160	SUBROUTINE advec_w_ws_ij( i, j, i_omp, tn )
2161
2162	USE arrays_3d, &
2163	ONLY: ddzu, diss_l_w, diss_s_w, flux_l_w, flux_s_w, tend, u, v, w
2164
2165	USE constants, &
2166	ONLY: adv_mom_1, adv_mom_3, adv_mom_5
2167
2168	USE control_parameters, &
2169	ONLY: intermediate_timestep_count, u_gtrans, v_gtrans
2170
2171	USE grid_variables, &
2172	ONLY: ddx, ddy
2173
2174	USE indices, &
2175	ONLY: nxl, nxr, nyn, nys, nzb, nzb_max, nzt, wall_flags_0, &
2176	wall_flags_00
2177
2178	USE kinds
2179
2180	USE statistics, &
2181	ONLY: hom, sums_ws2_ws_l, weight_substep
2182
2183	IMPLICIT NONE
2184
2185	INTEGER(iwp) :: i !:
2186	INTEGER(iwp) :: ibit27 !:
2187	INTEGER(iwp) :: ibit28 !:
2188	INTEGER(iwp) :: ibit29 !:
2189	INTEGER(iwp) :: ibit30 !:
2190	INTEGER(iwp) :: ibit31 !:
2191	INTEGER(iwp) :: ibit32 !:
2192	INTEGER(iwp) :: ibit33 !:
2193	INTEGER(iwp) :: ibit34 !:
2194	INTEGER(iwp) :: ibit35 !:
2195	INTEGER(iwp) :: i_omp !:
2196	INTEGER(iwp) :: j !:
2197	INTEGER(iwp) :: k !:
2198	INTEGER(iwp) :: k_mm !:
2199	INTEGER(iwp) :: k_pp !:
2200	INTEGER(iwp) :: k_ppp !:
2201	INTEGER(iwp) :: tn !:
2202
2203	REAL(wp) :: diss_d !:
2204	REAL(wp) :: div !:
2205	REAL(wp) :: flux_d !:
2206	REAL(wp) :: gu !:
2207	REAL(wp) :: gv !:
2208	REAL(wp) :: u_comp !:
2209	REAL(wp) :: v_comp !:
2210	REAL(wp) :: w_comp !:
2211
2212	REAL(wp), DIMENSION(nzb:nzt+1) :: diss_n !:
2213	REAL(wp), DIMENSION(nzb:nzt+1) :: diss_r !:
2214	REAL(wp), DIMENSION(nzb:nzt+1) :: diss_t !:
2215	REAL(wp), DIMENSION(nzb:nzt+1) :: flux_n !:
2216	REAL(wp), DIMENSION(nzb:nzt+1) :: flux_r !:
2217	REAL(wp), DIMENSION(nzb:nzt+1) :: flux_t !:
2218
2219	gu = 2.0_wp * u_gtrans
2220	gv = 2.0_wp * v_gtrans
2221
2222	!
2223	!-- Compute southside fluxes for the respective boundary.
2224	IF ( j == nys ) THEN
2225
2226	DO k = nzb+1, nzb_max
2227	ibit32 = IBITS(wall_flags_00(k,j-1,i),0,1)
2228	ibit31 = IBITS(wall_flags_0(k,j-1,i),31,1)
2229	ibit30 = IBITS(wall_flags_0(k,j-1,i),30,1)
2230
2231	v_comp = v(k+1,j,i) + v(k,j,i) - gv
2232	flux_s_w(k,tn) = v_comp * ( &
2233	( 37.0_wp * ibit32 * adv_mom_5 &
2234	+ 7.0_wp * ibit31 * adv_mom_3 &
2235	+ ibit30 * adv_mom_1 &
2236	) * &
2237	( w(k,j,i) + w(k,j-1,i) ) &
2238	- ( 8.0_wp * ibit32 * adv_mom_5 &
2239	+ ibit31 * adv_mom_3 &
2240	) * &
2241	( w(k,j+1,i) + w(k,j-2,i) ) &
2242	+ ( ibit32 * adv_mom_5 &
2243	) * &
2244	( w(k,j+2,i) + w(k,j-3,i) ) &
2245	)
2246
2247	diss_s_w(k,tn) = - ABS( v_comp ) * ( &
2248	( 10.0_wp * ibit32 * adv_mom_5 &
2249	+ 3.0_wp * ibit31 * adv_mom_3 &
2250	+ ibit30 * adv_mom_1 &
2251	) * &
2252	( w(k,j,i) - w(k,j-1,i) ) &
2253	- ( 5.0_wp * ibit32 * adv_mom_5 &
2254	+ ibit31 * adv_mom_3 &
2255	) * &
2256	( w(k,j+1,i) - w(k,j-2,i) ) &
2257	+ ( ibit32 * adv_mom_5 &
2258	) * &
2259	( w(k,j+2,i) - w(k,j-3,i) ) &
2260	)
2261
2262	ENDDO
2263
2264	DO k = nzb_max+1, nzt
2265
2266	v_comp = v(k+1,j,i) + v(k,j,i) - gv
2267	flux_s_w(k,tn) = v_comp * ( &
2268	37.0_wp * ( w(k,j,i) + w(k,j-1,i) ) &
2269	- 8.0_wp * ( w(k,j+1,i) +w(k,j-2,i) ) &
2270	+ ( w(k,j+2,i) + w(k,j-3,i) ) ) * adv_mom_5
2271	diss_s_w(k,tn) = - ABS( v_comp ) * ( &
2272	10.0_wp * ( w(k,j,i) - w(k,j-1,i) ) &
2273	- 5.0_wp * ( w(k,j+1,i) - w(k,j-2,i) ) &
2274	+ ( w(k,j+2,i) - w(k,j-3,i) ) ) * adv_mom_5
2275
2276	ENDDO
2277
2278	ENDIF
2279	!
2280	!-- Compute leftside fluxes for the respective boundary.
2281	IF ( i == i_omp ) THEN
2282
2283	DO k = nzb+1, nzb_max
2284
2285	ibit29 = IBITS(wall_flags_0(k,j,i-1),29,1)
2286	ibit28 = IBITS(wall_flags_0(k,j,i-1),28,1)
2287	ibit27 = IBITS(wall_flags_0(k,j,i-1),27,1)
2288
2289	u_comp = u(k+1,j,i) + u(k,j,i) - gu
2290	flux_l_w(k,j,tn) = u_comp * ( &
2291	( 37.0_wp * ibit29 * adv_mom_5 &
2292	+ 7.0_wp * ibit28 * adv_mom_3 &
2293	+ ibit27 * adv_mom_1 &
2294	) * &
2295	( w(k,j,i) + w(k,j,i-1) ) &
2296	- ( 8.0_wp * ibit29 * adv_mom_5 &
2297	+ ibit28 * adv_mom_3 &
2298	) * &
2299	( w(k,j,i+1) + w(k,j,i-2) ) &
2300	+ ( ibit29 * adv_mom_5 &
2301	) * &
2302	( w(k,j,i+2) + w(k,j,i-3) ) &
2303	)
2304
2305	diss_l_w(k,j,tn) = - ABS( u_comp ) * ( &
2306	( 10.0_wp * ibit29 * adv_mom_5 &
2307	+ 3.0_wp * ibit28 * adv_mom_3 &
2308	+ ibit27 * adv_mom_1 &
2309	) * &
2310	( w(k,j,i) - w(k,j,i-1) ) &
2311	- ( 5.0_wp * ibit29 * adv_mom_5 &
2312	+ ibit28 * adv_mom_3 &
2313	) * &
2314	( w(k,j,i+1) - w(k,j,i-2) ) &
2315	+ ( ibit29 * adv_mom_5 &
2316	) * &
2317	( w(k,j,i+2) - w(k,j,i-3) ) &
2318	)
2319
2320	ENDDO
2321
2322	DO k = nzb_max+1, nzt
2323
2324	u_comp = u(k+1,j,i) + u(k,j,i) - gu
2325	flux_l_w(k,j,tn) = u_comp * ( &
2326	37.0_wp * ( w(k,j,i) + w(k,j,i-1) ) &
2327	- 8.0_wp * ( w(k,j,i+1) + w(k,j,i-2) ) &
2328	+ ( w(k,j,i+2) + w(k,j,i-3) ) ) * adv_mom_5
2329	diss_l_w(k,j,tn) = - ABS( u_comp ) * ( &
2330	10.0_wp * ( w(k,j,i) - w(k,j,i-1) ) &
2331	- 5.0_wp * ( w(k,j,i+1) - w(k,j,i-2) ) &
2332	+ ( w(k,j,i+2) - w(k,j,i-3) ) ) * adv_mom_5
2333
2334	ENDDO
2335
2336	ENDIF
2337	!
2338	!-- The lower flux has to be calculated explicetely for the tendency at
2339	!-- the first w-level. For topography wall this is done implicitely by
2340	!-- wall_flags_0.
2341	k = nzb + 1
2342	w_comp = w(k,j,i) + w(k-1,j,i)
2343	flux_t(0) = w_comp * ( w(k,j,i) + w(k-1,j,i) ) * adv_mom_1
2344	diss_t(0) = -ABS(w_comp) * ( w(k,j,i) - w(k-1,j,i) ) * adv_mom_1
2345	flux_d = flux_t(0)
2346	diss_d = diss_t(0)
2347	!
2348	!-- Now compute the fluxes and tendency terms for the horizontal
2349	!-- and vertical parts.
2350	DO k = nzb+1, nzb_max
2351
2352	ibit29 = IBITS(wall_flags_0(k,j,i),29,1)
2353	ibit28 = IBITS(wall_flags_0(k,j,i),28,1)
2354	ibit27 = IBITS(wall_flags_0(k,j,i),27,1)
2355
2356	u_comp = u(k+1,j,i+1) + u(k,j,i+1) - gu
2357	flux_r(k) = u_comp * ( &
2358	( 37.0_wp * ibit29 * adv_mom_5 &
2359	+ 7.0_wp * ibit28 * adv_mom_3 &
2360	+ ibit27 * adv_mom_1 &
2361	) * &
2362	( w(k,j,i+1) + w(k,j,i) ) &
2363	- ( 8.0_wp * ibit29 * adv_mom_5 &
2364	+ ibit28 * adv_mom_3 &
2365	) * &
2366	( w(k,j,i+2) + w(k,j,i-1) ) &
2367	+ ( ibit29 * adv_mom_5 &
2368	) * &
2369	( w(k,j,i+3) + w(k,j,i-2) ) &
2370	)
2371
2372	diss_r(k) = - ABS( u_comp ) * ( &
2373	( 10.0_wp * ibit29 * adv_mom_5 &
2374	+ 3.0_wp * ibit28 * adv_mom_3 &
2375	+ ibit27 * adv_mom_1 &
2376	) * &
2377	( w(k,j,i+1) - w(k,j,i) ) &
2378	- ( 5.0_wp * ibit29 * adv_mom_5 &
2379	+ ibit28 * adv_mom_3 &
2380	) * &
2381	( w(k,j,i+2) - w(k,j,i-1) ) &
2382	+ ( ibit29 * adv_mom_5 &
2383	) * &
2384	( w(k,j,i+3) - w(k,j,i-2) ) &
2385	)
2386
2387	ibit32 = IBITS(wall_flags_00(k,j,i),0,1)
2388	ibit31 = IBITS(wall_flags_0(k,j,i),31,1)
2389	ibit30 = IBITS(wall_flags_0(k,j,i),30,1)
2390
2391	v_comp = v(k+1,j+1,i) + v(k,j+1,i) - gv
2392	flux_n(k) = v_comp * ( &
2393	( 37.0_wp * ibit32 * adv_mom_5 &
2394	+ 7.0_wp * ibit31 * adv_mom_3 &
2395	+ ibit30 * adv_mom_1 &
2396	) * &
2397	( w(k,j+1,i) + w(k,j,i) ) &
2398	- ( 8.0_wp * ibit32 * adv_mom_5 &
2399	+ ibit31 * adv_mom_3 &
2400	) * &
2401	( w(k,j+2,i) + w(k,j-1,i) ) &
2402	+ ( ibit32 * adv_mom_5 &
2403	) * &
2404	( w(k,j+3,i) + w(k,j-2,i) ) &
2405	)
2406
2407	diss_n(k) = - ABS( v_comp ) * ( &
2408	( 10.0_wp * ibit32 * adv_mom_5 &
2409	+ 3.0_wp * ibit31 * adv_mom_3 &
2410	+ ibit30 * adv_mom_1 &
2411	) * &
2412	( w(k,j+1,i) - w(k,j,i) ) &
2413	- ( 5.0_wp * ibit32 * adv_mom_5 &
2414	+ ibit31 * adv_mom_3 &
2415	) * &
2416	( w(k,j+2,i) - w(k,j-1,i) ) &
2417	+ ( ibit32 * adv_mom_5 &
2418	) * &
2419	( w(k,j+3,i) - w(k,j-2,i) ) &
2420	)
2421	!
2422	!-- k index has to be modified near bottom and top, else array
2423	!-- subscripts will be exceeded.
2424	ibit35 = IBITS(wall_flags_00(k,j,i),3,1)
2425	ibit34 = IBITS(wall_flags_00(k,j,i),2,1)
2426	ibit33 = IBITS(wall_flags_00(k,j,i),1,1)
2427
2428	k_ppp = k + 3 * ibit35
2429	k_pp = k + 2 * ( 1 - ibit33 )
2430	k_mm = k - 2 * ibit35
2431
2432	w_comp = w(k+1,j,i) + w(k,j,i)
2433	flux_t(k) = w_comp * ( &
2434	( 37.0_wp * ibit35 * adv_mom_5 &
2435	+ 7.0_wp * ibit34 * adv_mom_3 &
2436	+ ibit33 * adv_mom_1 &
2437	) * &
2438	( w(k+1,j,i) + w(k,j,i) ) &
2439	- ( 8.0_wp * ibit35 * adv_mom_5 &
2440	+ ibit34 * adv_mom_3 &
2441	) * &
2442	( w(k_pp,j,i) + w(k-1,j,i) ) &
2443	+ ( ibit35 * adv_mom_5 &
2444	) * &
2445	( w(k_ppp,j,i) + w(k_mm,j,i) ) &
2446	)
2447
2448	diss_t(k) = - ABS( w_comp ) * ( &
2449	( 10.0_wp * ibit35 * adv_mom_5 &
2450	+ 3.0_wp * ibit34 * adv_mom_3 &
2451	+ ibit33 * adv_mom_1 &
2452	) * &
2453	( w(k+1,j,i) - w(k,j,i) ) &
2454	- ( 5.0_wp * ibit35 * adv_mom_5 &
2455	+ ibit34 * adv_mom_3 &
2456	) * &
2457	( w(k_pp,j,i) - w(k-1,j,i) ) &
2458	+ ( ibit35 * adv_mom_5 &
2459	) * &
2460	( w(k_ppp,j,i) - w(k_mm,j,i) ) &
2461	)
2462
2463	!
2464	!-- Calculate the divergence of the velocity field. A respective
2465	!-- correction is needed to overcome numerical instabilities introduced
2466	!-- by a not sufficient reduction of divergences near topography.
2467	div = ( ( ( u_comp + gu ) * ( ibit27 + ibit28 + ibit29 ) &
2468	- ( u(k+1,j,i) + u(k,j,i) ) &
2469	* ( IBITS(wall_flags_0(k,j,i-1),27,1) &
2470	+ IBITS(wall_flags_0(k,j,i-1),28,1) &
2471	+ IBITS(wall_flags_0(k,j,i-1),29,1) &
2472	) &
2473	) * ddx &
2474	+ ( ( v_comp + gv ) * ( ibit30 + ibit31 + ibit32 ) &
2475	- ( v(k+1,j,i) + v(k,j,i) ) &
2476	* ( IBITS(wall_flags_0(k,j-1,i),30,1) &
2477	+ IBITS(wall_flags_0(k,j-1,i),31,1) &
2478	+ IBITS(wall_flags_00(k,j-1,i),0,1) &
2479	) &
2480	) * ddy &
2481	+ ( w_comp * ( ibit33 + ibit34 + ibit35 ) &
2482	- ( w(k,j,i) + w(k-1,j,i) ) &
2483	* ( IBITS(wall_flags_00(k-1,j,i),1,1) &
2484	+ IBITS(wall_flags_00(k-1,j,i),2,1) &
2485	+ IBITS(wall_flags_00(k-1,j,i),3,1) &
2486	) &
2487	) * ddzu(k+1) &
2488	) * 0.5_wp
2489
2490
2491	tend(k,j,i) = tend(k,j,i) - ( &
2492	( flux_r(k) + diss_r(k) &
2493	- flux_l_w(k,j,tn) - diss_l_w(k,j,tn) ) * ddx &
2494	+ ( flux_n(k) + diss_n(k) &
2495	- flux_s_w(k,tn) - diss_s_w(k,tn) ) * ddy &
2496	+ ( flux_t(k) + diss_t(k) &
2497	- flux_d - diss_d ) * ddzu(k+1) &
2498	) + div * w(k,j,i)
2499
2500	flux_l_w(k,j,tn) = flux_r(k)
2501	diss_l_w(k,j,tn) = diss_r(k)
2502	flux_s_w(k,tn) = flux_n(k)
2503	diss_s_w(k,tn) = diss_n(k)
2504	flux_d = flux_t(k)
2505	diss_d = diss_t(k)
2506	!
2507	!-- Statistical Evaluation of w'w'.
2508	sums_ws2_ws_l(k,tn) = sums_ws2_ws_l(k,tn) &
2509	+ ( flux_t(k) + diss_t(k) ) &
2510	* weight_substep(intermediate_timestep_count)
2511
2512	ENDDO
2513
2514	DO k = nzb_max+1, nzt
2515
2516	u_comp = u(k+1,j,i+1) + u(k,j,i+1) - gu
2517	flux_r(k) = u_comp * ( &
2518	37.0_wp * ( w(k,j,i+1) + w(k,j,i) ) &
2519	- 8.0_wp * ( w(k,j,i+2) + w(k,j,i-1) ) &
2520	+ ( w(k,j,i+3) + w(k,j,i-2) ) ) * adv_mom_5
2521
2522	diss_r(k) = - ABS( u_comp ) * ( &
2523	10.0_wp * ( w(k,j,i+1) - w(k,j,i) ) &
2524	- 5.0_wp * ( w(k,j,i+2) - w(k,j,i-1) ) &
2525	+ ( w(k,j,i+3) - w(k,j,i-2) ) ) * adv_mom_5
2526
2527	v_comp = v(k+1,j+1,i) + v(k,j+1,i) - gv
2528	flux_n(k) = v_comp * ( &
2529	37.0_wp * ( w(k,j+1,i) + w(k,j,i) ) &
2530	- 8.0_wp * ( w(k,j+2,i) + w(k,j-1,i) ) &
2531	+ ( w(k,j+3,i) + w(k,j-2,i) ) ) * adv_mom_5
2532
2533	diss_n(k) = - ABS( v_comp ) * ( &
2534	10.0_wp * ( w(k,j+1,i) - w(k,j,i) ) &
2535	- 5.0_wp * ( w(k,j+2,i) - w(k,j-1,i) ) &
2536	+ ( w(k,j+3,i) - w(k,j-2,i) ) ) * adv_mom_5
2537	!
2538	!-- k index has to be modified near bottom and top, else array
2539	!-- subscripts will be exceeded.
2540	ibit35 = IBITS(wall_flags_00(k,j,i),3,1)
2541	ibit34 = IBITS(wall_flags_00(k,j,i),2,1)
2542	ibit33 = IBITS(wall_flags_00(k,j,i),1,1)
2543
2544	k_ppp = k + 3 * ibit35
2545	k_pp = k + 2 * ( 1 - ibit33 )
2546	k_mm = k - 2 * ibit35
2547
2548	w_comp = w(k+1,j,i) + w(k,j,i)
2549	flux_t(k) = w_comp * ( &
2550	( 37.0_wp * ibit35 * adv_mom_5 &
2551	+ 7.0_wp * ibit34 * adv_mom_3 &
2552	+ ibit33 * adv_mom_1 &
2553	) * &
2554	( w(k+1,j,i) + w(k,j,i) ) &
2555	- ( 8.0_wp * ibit35 * adv_mom_5 &
2556	+ ibit34 * adv_mom_3 &
2557	) * &
2558	( w(k_pp,j,i) + w(k-1,j,i) ) &
2559	+ ( ibit35 * adv_mom_5 &
2560	) * &
2561	( w(k_ppp,j,i) + w(k_mm,j,i) ) &
2562	)
2563
2564	diss_t(k) = - ABS( w_comp ) * ( &
2565	( 10.0_wp * ibit35 * adv_mom_5 &
2566	+ 3.0_wp * ibit34 * adv_mom_3 &
2567	+ ibit33 * adv_mom_1 &
2568	) * &
2569	( w(k+1,j,i) - w(k,j,i) ) &
2570	- ( 5.0_wp * ibit35 * adv_mom_5 &
2571	+ ibit34 * adv_mom_3 &
2572	) * &
2573	( w(k_pp,j,i) - w(k-1,j,i) ) &
2574	+ ( ibit35 * adv_mom_5 &
2575	) * &
2576	( w(k_ppp,j,i) - w(k_mm,j,i) ) &
2577	)
2578	!
2579	!-- Calculate the divergence of the velocity field. A respective
2580	!-- correction is needed to overcome numerical instabilities introduced
2581	!-- by a not sufficient reduction of divergences near topography.
2582	div = ( ( u_comp + gu - ( u(k+1,j,i) + u(k,j,i) ) ) * ddx &
2583	+ ( v_comp + gv - ( v(k+1,j,i) + v(k,j,i) ) ) * ddy &
2584	+ ( w_comp - ( w(k,j,i) + w(k-1,j,i) ) ) * ddzu(k+1) &
2585	) * 0.5_wp
2586
2587	tend(k,j,i) = tend(k,j,i) - ( &
2588	( flux_r(k) + diss_r(k) &
2589	- flux_l_w(k,j,tn) - diss_l_w(k,j,tn) ) * ddx &
2590	+ ( flux_n(k) + diss_n(k) &
2591	- flux_s_w(k,tn) - diss_s_w(k,tn) ) * ddy &
2592	+ ( flux_t(k) + diss_t(k) &
2593	- flux_d - diss_d ) * ddzu(k+1) &
2594	) + div * w(k,j,i)
2595
2596	flux_l_w(k,j,tn) = flux_r(k)
2597	diss_l_w(k,j,tn) = diss_r(k)
2598	flux_s_w(k,tn) = flux_n(k)
2599	diss_s_w(k,tn) = diss_n(k)
2600	flux_d = flux_t(k)
2601	diss_d = diss_t(k)
2602	!
2603	!-- Statistical Evaluation of w'w'.
2604	sums_ws2_ws_l(k,tn) = sums_ws2_ws_l(k,tn) &
2605	+ ( flux_t(k) + diss_t(k) ) &
2606	* weight_substep(intermediate_timestep_count)
2607
2608	ENDDO
2609
2610
2611	END SUBROUTINE advec_w_ws_ij
2612
2613
2614	!------------------------------------------------------------------------------!
2615	! Scalar advection - Call for all grid points
2616	!------------------------------------------------------------------------------!
2617	SUBROUTINE advec_s_ws( sk, sk_char )
2618
2619	USE arrays_3d, &
2620	ONLY: ddzw, tend, u, v, w
2621
2622	USE constants, &
2623	ONLY: adv_sca_1, adv_sca_3, adv_sca_5
2624
2625	USE control_parameters, &
2626	ONLY: intermediate_timestep_count, monotonic_adjustment, u_gtrans,&
2627	v_gtrans
2628
2629	USE grid_variables, &
2630	ONLY: ddx, ddy
2631
2632	USE indices, &
2633	ONLY: nxl, nxlg, nxr, nxrg, nyn, nyng, nys, nysg, nzb, nzb_max, &
2634	nzt, wall_flags_0
2635
2636	USE kinds
2637
2638	USE statistics, &
2639	ONLY: sums_wspts_ws_l, sums_wsqs_ws_l, sums_wssas_ws_l, &
2640	sums_wsqrs_ws_l, sums_wsnrs_ws_l, weight_substep
2641
2642	IMPLICIT NONE
2643
2644	CHARACTER (LEN = *), INTENT(IN) :: sk_char !:
2645
2646	INTEGER(iwp) :: i !:
2647	INTEGER(iwp) :: ibit0 !:
2648	INTEGER(iwp) :: ibit1 !:
2649	INTEGER(iwp) :: ibit2 !:
2650	INTEGER(iwp) :: ibit3 !:
2651	INTEGER(iwp) :: ibit4 !:
2652	INTEGER(iwp) :: ibit5 !:
2653	INTEGER(iwp) :: ibit6 !:
2654	INTEGER(iwp) :: ibit7 !:
2655	INTEGER(iwp) :: ibit8 !:
2656	INTEGER(iwp) :: j !:
2657	INTEGER(iwp) :: k !:
2658	INTEGER(iwp) :: k_mm !:
2659	INTEGER(iwp) :: k_mmm !:
2660	INTEGER(iwp) :: k_pp !:
2661	INTEGER(iwp) :: k_ppp !:
2662	INTEGER(iwp) :: tn = 0 !:
2663
2664	#if defined( __nopointer )
2665	REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: sk !:
2666	#else
2667	REAL(wp), DIMENSION(:,:,:), POINTER :: sk !:
2668	#endif
2669
2670	REAL(wp) :: diss_d !:
2671	REAL(wp) :: div !:
2672	REAL(wp) :: flux_d !:
2673	REAL(wp) :: fd_1 !:
2674	REAL(wp) :: fl_1 !:
2675	REAL(wp) :: fn_1 !:
2676	REAL(wp) :: fr_1 !:
2677	REAL(wp) :: fs_1 !:
2678	REAL(wp) :: ft_1 !:
2679	REAL(wp) :: phi_d !:
2680	REAL(wp) :: phi_l !:
2681	REAL(wp) :: phi_n !:
2682	REAL(wp) :: phi_r !:
2683	REAL(wp) :: phi_s !:
2684	REAL(wp) :: phi_t !:
2685	REAL(wp) :: rd !:
2686	REAL(wp) :: rl !:
2687	REAL(wp) :: rn !:
2688	REAL(wp) :: rr !:
2689	REAL(wp) :: rs !:
2690	REAL(wp) :: rt !:
2691	REAL(wp) :: u_comp !:
2692	REAL(wp) :: v_comp !:
2693
2694	REAL(wp), DIMENSION(nzb:nzt) :: diss_n !:
2695	REAL(wp), DIMENSION(nzb:nzt) :: diss_r !:
2696	REAL(wp), DIMENSION(nzb:nzt) :: diss_t !:
2697	REAL(wp), DIMENSION(nzb:nzt) :: flux_n !:
2698	REAL(wp), DIMENSION(nzb:nzt) :: flux_r !:
2699	REAL(wp), DIMENSION(nzb:nzt) :: flux_t !:
2700
2701	REAL(wp), DIMENSION(nzb+1:nzt) :: swap_diss_y_local !:
2702	REAL(wp), DIMENSION(nzb+1:nzt) :: swap_flux_y_local !:
2703
2704	REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn) :: swap_diss_x_local !:
2705	REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn) :: swap_flux_x_local !:
2706
2707
2708	!
2709	!-- Compute the fluxes for the whole left boundary of the processor domain.
2710	i = nxl
2711	DO j = nys, nyn
2712
2713	DO k = nzb+1, nzb_max
2714
2715	ibit2 = IBITS(wall_flags_0(k,j,i-1),2,1)
2716	ibit1 = IBITS(wall_flags_0(k,j,i-1),1,1)
2717	ibit0 = IBITS(wall_flags_0(k,j,i-1),0,1)
2718
2719	u_comp = u(k,j,i) - u_gtrans
2720	swap_flux_x_local(k,j) = u_comp * ( &
2721	( 37.0_wp * ibit2 * adv_sca_5 &
2722	+ 7.0_wp * ibit1 * adv_sca_3 &
2723	+ ibit0 * adv_sca_1 &
2724	) * &
2725	( sk(k,j,i) + sk(k,j,i-1) ) &
2726	- ( 8.0_wp * ibit2 * adv_sca_5 &
2727	+ ibit1 * adv_sca_3 &
2728	) * &
2729	( sk(k,j,i+1) + sk(k,j,i-2) ) &
2730	+ ( ibit2 * adv_sca_5 &
2731	) * &
2732	( sk(k,j,i+2) + sk(k,j,i-3) ) &
2733	)
2734
2735	swap_diss_x_local(k,j) = -ABS( u_comp ) * ( &
2736	( 10.0_wp * ibit2 * adv_sca_5 &
2737	+ 3.0_wp * ibit1 * adv_sca_3 &
2738	+ ibit0 * adv_sca_1 &
2739	) * &
2740	( sk(k,j,i) - sk(k,j,i-1) ) &
2741	- ( 5.0_wp * ibit2 * adv_sca_5 &
2742	+ ibit1 * adv_sca_3 &
2743	) * &
2744	( sk(k,j,i+1) - sk(k,j,i-2) ) &
2745	+ ( ibit2 * adv_sca_5 &
2746	) * &
2747	( sk(k,j,i+2) - sk(k,j,i-3) ) &
2748	)
2749
2750	ENDDO
2751
2752	DO k = nzb_max+1, nzt
2753
2754	u_comp = u(k,j,i) - u_gtrans
2755	swap_flux_x_local(k,j) = u_comp * ( &
2756	37.0_wp * ( sk(k,j,i) + sk(k,j,i-1) ) &
2757	- 8.0_wp * ( sk(k,j,i+1) + sk(k,j,i-2) ) &
2758	+ ( sk(k,j,i+2) + sk(k,j,i-3) ) &
2759	) * adv_sca_5
2760
2761	swap_diss_x_local(k,j) = -ABS( u_comp ) * ( &
2762	10.0_wp * ( sk(k,j,i) - sk(k,j,i-1) ) &
2763	- 5.0_wp * ( sk(k,j,i+1) - sk(k,j,i-2) ) &
2764	+ ( sk(k,j,i+2) - sk(k,j,i-3) ) &
2765	) * adv_sca_5
2766
2767	ENDDO
2768
2769	ENDDO
2770
2771	DO i = nxl, nxr
2772
2773	j = nys
2774	DO k = nzb+1, nzb_max
2775
2776	ibit5 = IBITS(wall_flags_0(k,j-1,i),5,1)
2777	ibit4 = IBITS(wall_flags_0(k,j-1,i),4,1)
2778	ibit3 = IBITS(wall_flags_0(k,j-1,i),3,1)
2779
2780	v_comp = v(k,j,i) - v_gtrans
2781	swap_flux_y_local(k) = v_comp * ( &
2782	( 37.0_wp * ibit5 * adv_sca_5 &
2783	+ 7.0_wp * ibit4 * adv_sca_3 &
2784	+ ibit3 * adv_sca_1 &
2785	) * &
2786	( sk(k,j,i) + sk(k,j-1,i) ) &
2787	- ( 8.0_wp * ibit5 * adv_sca_5 &
2788	+ ibit4 * adv_sca_3 &
2789	) * &
2790	( sk(k,j+1,i) + sk(k,j-2,i) ) &
2791	+ ( ibit5 * adv_sca_5 &
2792	) * &
2793	( sk(k,j+2,i) + sk(k,j-3,i) ) &
2794	)
2795
2796	swap_diss_y_local(k) = -ABS( v_comp ) * ( &
2797	( 10.0_wp * ibit5 * adv_sca_5 &
2798	+ 3.0_wp * ibit4 * adv_sca_3 &
2799	+ ibit3 * adv_sca_1 &
2800	) * &
2801	( sk(k,j,i) - sk(k,j-1,i) ) &
2802	- ( 5.0_wp * ibit5 * adv_sca_5 &
2803	+ ibit4 * adv_sca_3 &
2804	) * &
2805	( sk(k,j+1,i) - sk(k,j-2,i) ) &
2806	+ ( ibit5 * adv_sca_5 &
2807	) * &
2808	( sk(k,j+2,i) - sk(k,j-3,i) ) &
2809	)
2810
2811	ENDDO
2812	!
2813	!-- Above to the top of the highest topography. No degradation necessary.
2814	DO k = nzb_max+1, nzt
2815
2816	v_comp = v(k,j,i) - v_gtrans
2817	swap_flux_y_local(k) = v_comp * ( &
2818	37.0_wp * ( sk(k,j,i) + sk(k,j-1,i) ) &
2819	- 8.0_wp * ( sk(k,j+1,i) + sk(k,j-2,i) ) &
2820	+ ( sk(k,j+2,i) + sk(k,j-3,i) ) &
2821	) * adv_sca_5
2822	swap_diss_y_local(k) = -ABS( v_comp ) * ( &
2823	10.0_wp * ( sk(k,j,i) - sk(k,j-1,i) ) &
2824	- 5.0_wp * ( sk(k,j+1,i) - sk(k,j-2,i) ) &
2825	+ sk(k,j+2,i) - sk(k,j-3,i) &
2826	) * adv_sca_5
2827
2828	ENDDO
2829
2830	DO j = nys, nyn
2831
2832	flux_t(0) = 0.0_wp
2833	diss_t(0) = 0.0_wp
2834	flux_d = 0.0_wp
2835	diss_d = 0.0_wp
2836
2837	DO k = nzb+1, nzb_max
2838
2839	ibit2 = IBITS(wall_flags_0(k,j,i),2,1)
2840	ibit1 = IBITS(wall_flags_0(k,j,i),1,1)
2841	ibit0 = IBITS(wall_flags_0(k,j,i),0,1)
2842
2843	u_comp = u(k,j,i+1) - u_gtrans
2844	flux_r(k) = u_comp * ( &
2845	( 37.0_wp * ibit2 * adv_sca_5 &
2846	+ 7.0_wp * ibit1 * adv_sca_3 &
2847	+ ibit0 * adv_sca_1 &
2848	) * &
2849	( sk(k,j,i+1) + sk(k,j,i) ) &
2850	- ( 8.0_wp * ibit2 * adv_sca_5 &
2851	+ ibit1 * adv_sca_3 &
2852	) * &
2853	( sk(k,j,i+2) + sk(k,j,i-1) ) &
2854	+ ( ibit2 * adv_sca_5 &
2855	) * &
2856	( sk(k,j,i+3) + sk(k,j,i-2) ) &
2857	)
2858
2859	diss_r(k) = -ABS( u_comp ) * ( &
2860	( 10.0_wp * ibit2 * adv_sca_5 &
2861	+ 3.0_wp * ibit1 * adv_sca_3 &
2862	+ ibit0 * adv_sca_1 &
2863	) * &
2864	( sk(k,j,i+1) - sk(k,j,i) ) &
2865	- ( 5.0_wp * ibit2 * adv_sca_5 &
2866	+ ibit1 * adv_sca_3 &
2867	) * &
2868	( sk(k,j,i+2) - sk(k,j,i-1) ) &
2869	+ ( ibit2 * adv_sca_5 &
2870	) * &
2871	( sk(k,j,i+3) - sk(k,j,i-2) ) &
2872	)
2873
2874	ibit5 = IBITS(wall_flags_0(k,j,i),5,1)
2875	ibit4 = IBITS(wall_flags_0(k,j,i),4,1)
2876	ibit3 = IBITS(wall_flags_0(k,j,i),3,1)
2877
2878	v_comp = v(k,j+1,i) - v_gtrans
2879	flux_n(k) = v_comp * ( &
2880	( 37.0_wp * ibit5 * adv_sca_5 &
2881	+ 7.0_wp * ibit4 * adv_sca_3 &
2882	+ ibit3 * adv_sca_1 &
2883	) * &
2884	( sk(k,j+1,i) + sk(k,j,i) ) &
2885	- ( 8.0_wp * ibit5 * adv_sca_5 &
2886	+ ibit4 * adv_sca_3 &
2887	) * &
2888	( sk(k,j+2,i) + sk(k,j-1,i) ) &
2889	+ ( ibit5 * adv_sca_5 &
2890	) * &
2891	( sk(k,j+3,i) + sk(k,j-2,i) ) &
2892	)
2893
2894	diss_n(k) = -ABS( v_comp ) * ( &
2895	( 10.0_wp * ibit5 * adv_sca_5 &
2896	+ 3.0_wp * ibit4 * adv_sca_3 &
2897	+ ibit3 * adv_sca_1 &
2898	) * &
2899	( sk(k,j+1,i) - sk(k,j,i) ) &
2900	- ( 5.0_wp * ibit5 * adv_sca_5 &
2901	+ ibit4 * adv_sca_3 &
2902	) * &
2903	( sk(k,j+2,i) - sk(k,j-1,i) ) &
2904	+ ( ibit5 * adv_sca_5 &
2905	) * &
2906	( sk(k,j+3,i) - sk(k,j-2,i) ) &
2907	)
2908	!
2909	!-- k index has to be modified near bottom and top, else array
2910	!-- subscripts will be exceeded.
2911	ibit8 = IBITS(wall_flags_0(k,j,i),8,1)
2912	ibit7 = IBITS(wall_flags_0(k,j,i),7,1)
2913	ibit6 = IBITS(wall_flags_0(k,j,i),6,1)
2914
2915	k_ppp = k + 3 * ibit8
2916	k_pp = k + 2 * ( 1 - ibit6 )
2917	k_mm = k - 2 * ibit8
2918
2919
2920	flux_t(k) = w(k,j,i) * ( &
2921	( 37.0_wp * ibit8 * adv_sca_5 &
2922	+ 7.0_wp * ibit7 * adv_sca_3 &
2923	+ ibit6 * adv_sca_1 &
2924	) * &
2925	( sk(k+1,j,i) + sk(k,j,i) ) &
2926	- ( 8.0_wp * ibit8 * adv_sca_5 &
2927	+ ibit7 * adv_sca_3 &
2928	) * &
2929	( sk(k_pp,j,i) + sk(k-1,j,i) ) &
2930	+ ( ibit8 * adv_sca_5 &
2931	) * ( sk(k_ppp,j,i)+ sk(k_mm,j,i) ) &
2932	)
2933
2934	diss_t(k) = -ABS( w(k,j,i) ) * ( &
2935	( 10.0_wp * ibit8 * adv_sca_5 &
2936	+ 3.0_wp * ibit7 * adv_sca_3 &
2937	+ ibit6 * adv_sca_1 &
2938	) * &
2939	( sk(k+1,j,i) - sk(k,j,i) ) &
2940	- ( 5.0_wp * ibit8 * adv_sca_5 &
2941	+ ibit7 * adv_sca_3 &
2942	) * &
2943	( sk(k_pp,j,i) - sk(k-1,j,i) ) &
2944	+ ( ibit8 * adv_sca_5 &
2945	) * &
2946	( sk(k_ppp,j,i) - sk(k_mm,j,i) ) &
2947	)
2948	!
2949	!-- Apply monotonic adjustment.
2950	IF ( monotonic_adjustment ) THEN
2951	!
2952	!-- At first, calculate first order fluxes.
2953	u_comp = u(k,j,i) - u_gtrans
2954	fl_1 = ( u_comp * ( sk(k,j,i) + sk(k,j,i-1) ) &
2955	-ABS( u_comp ) * ( sk(k,j,i) - sk(k,j,i-1) ) &
2956	) * adv_sca_1
2957
2958	u_comp = u(k,j,i+1) - u_gtrans
2959	fr_1 = ( u_comp * ( sk(k,j,i+1) + sk(k,j,i) ) &
2960	-ABS( u_comp ) * ( sk(k,j,i+1) - sk(k,j,i) ) &
2961	) * adv_sca_1
2962
2963	v_comp = v(k,j,i) - v_gtrans
2964	fs_1 = ( v_comp * ( sk(k,j,i) + sk(k,j-1,i) ) &
2965	-ABS( v_comp ) * ( sk(k,j,i) - sk(k,j-1,i) ) &
2966	) * adv_sca_1
2967
2968	v_comp = v(k,j+1,i) - v_gtrans
2969	fn_1 = ( v_comp * ( sk(k,j+1,i) + sk(k,j,i) ) &
2970	-ABS( v_comp ) * ( sk(k,j+1,i) - sk(k,j,i) ) &
2971	) * adv_sca_1
2972
2973	fd_1 = ( w(k-1,j,i) * ( sk(k,j,i) + sk(k-1,j,i) ) &
2974	-ABS( w(k-1,j,i) ) * ( sk(k,j,i) - sk(k-1,j,i) ) &
2975	) * adv_sca_1
2976
2977	ft_1 = ( w(k,j,i) * ( sk(k+1,j,i) + sk(k,j,i) ) &
2978	-ABS( w(k,j,i) ) * ( sk(k+1,j,i) - sk(k,j,i) ) &
2979	) * adv_sca_1
2980	!
2981	!-- Calculate ratio of upwind gradients. Note, Min/Max is just
2982	!-- to avoid if statements.
2983	rl = ( MAX( 0.0_wp, u(k,j,i) - u_gtrans ) * &
2984	ABS( ( sk(k,j,i-1) - sk(k,j,i-2) ) /&
2985	( sk(k,j,i) - sk(k,j,i-1) + 1E-20_wp ) &
2986	) + &
2987	MIN( 0.0_wp, u(k,j,i) - u_gtrans ) * &
2988	ABS( ( sk(k,j,i) - sk(k,j,i+1) ) /&
2989	( sk(k,j,i-1) - sk(k,j,i) + 1E-20_wp ) &
2990	) &
2991	) / ABS( u(k,j,i) - u_gtrans + 1E-20_wp )
2992
2993	rr = ( MAX( 0.0_wp, u(k,j,i+1) - u_gtrans ) * &
2994	ABS( ( sk(k,j,i) - sk(k,j,i-1) ) /&
2995	( sk(k,j,i+1) - sk(k,j,i) + 1E-20_wp ) &
2996	) + &
2997	MIN( 0.0_wp, u(k,j,i+1) - u_gtrans ) * &
2998	ABS( ( sk(k,j,i+1) - sk(k,j,i+2) ) /&
2999	( sk(k,j,i) - sk(k,j,i+1) + 1E-20_wp ) &
3000	) &
3001	) / ABS( u(k,j,i+1) - u_gtrans + 1E-20_wp )
3002
3003	rs = ( MAX( 0.0_wp, v(k,j,i) - v_gtrans ) * &
3004	ABS( ( sk(k,j-1,i) - sk(k,j-2,i) ) /&
3005	( sk(k,j,i) - sk(k,j-1,i) + 1E-20_wp ) &
3006	) + &
3007	MIN( 0.0_wp, v(k,j,i) - v_gtrans ) * &
3008	ABS( ( sk(k,j,i) - sk(k,j+1,i) ) /&
3009	( sk(k,j-1,i) - sk(k,j,i) + 1E-20_wp ) &
3010	) &
3011	) / ABS( v(k,j,i) - v_gtrans + 1E-20_wp )
3012
3013	rn = ( MAX( 0.0_wp, v(k,j+1,i) - v_gtrans ) * &
3014	ABS( ( sk(k,j,i) - sk(k,j-1,i) ) /&
3015	( sk(k,j+1,i) - sk(k,j,i) + 1E-20_wp ) &
3016	) + &
3017	MIN( 0.0_wp, v(k,j+1,i) - v_gtrans ) * &
3018	ABS( ( sk(k,j+1,i) - sk(k,j+2,i) ) /&
3019	( sk(k,j,i) - sk(k,j+1,i) + 1E-20_wp ) &
3020	) &
3021	) / ABS( v(k,j+1,i) - v_gtrans + 1E-20_wp )
3022	!
3023	!-- Reuse k_mm and compute k_mmm for the vertical gradient ratios.
3024	!-- Note, for vertical advection below the third grid point above
3025	!-- surface ( or below the model top) rd and rt are set to 0, i.e.
3026	!-- use of first order scheme is enforced.
3027	k_mmm = k - 3 * ibit8
3028
3029	rd = ( MAX( 0.0_wp, w(k-1,j,i) ) * &
3030	ABS( ( sk(k_mm,j,i) - sk(k_mmm,j,i) ) / &
3031	( sk(k-1,j,i) - sk(k_mm,j,i) + 1E-20_wp ) &
3032	) + &
3033	MIN( 0.0_wp, w(k-1,j,i) ) * &
3034	ABS( ( sk(k-1,j,i) - sk(k,j,i) ) / &
3035	( sk(k_mm,j,i) - sk(k-1,j,i) + 1E-20_wp ) &
3036	) &
3037	) * ibit8 / ABS( w(k-1,j,i) + 1E-20_wp )
3038
3039	rt = ( MAX( 0.0_wp, w(k,j,i) ) * &
3040	ABS( ( sk(k,j,i) - sk(k-1,j,i) ) / &
3041	( sk(k+1,j,i) - sk(k,j,i) + 1E-20_wp ) &
3042	) + &
3043	MIN( 0.0_wp, w(k,j,i) ) * &
3044	ABS( ( sk(k+1,j,i) - sk(k_pp,j,i) ) / &
3045	( sk(k,j,i) - sk(k+1,j,i) + 1E-20_wp ) &
3046	) &
3047	) * ibit8 / ABS( w(k,j,i) + 1E-20_wp )
3048	!
3049	!-- Calculate empirical limiter function (van Albada2 limiter).
3050	phi_l = MIN( 1.0_wp, ( 2.0_wp * ABS( rl ) ) / &
3051	( rl**2 + 1.0_wp ) )
3052	phi_r = MIN( 1.0_wp, ( 2.0_wp * ABS( rr ) ) / &
3053	( rr**2 + 1.0_wp ) )
3054	phi_s = MIN( 1.0_wp, ( 2.0_wp * ABS( rs ) ) / &
3055	( rs**2 + 1.0_wp ) )
3056	phi_n = MIN( 1.0_wp, ( 2.0_wp * ABS( rn ) ) / &
3057	( rn**2 + 1.0_wp ) )
3058	phi_d = MIN( 1.0_wp, ( 2.0_wp * ABS( rd ) ) / &
3059	( rd**2 + 1.0_wp ) )
3060	phi_t = MIN( 1.0_wp, ( 2.0_wp * ABS( rt ) ) / &
3061	( rt**2 + 1.0_wp ) )
3062	!
3063	!-- Calculate the resulting monotone flux.
3064	swap_flux_x_local(k,j) = fl_1 - phi_l * &
3065	( fl_1 - swap_flux_x_local(k,j) )
3066	flux_r(k) = fr_1 - phi_r * &
3067	( fr_1 - flux_r(k) )
3068	swap_flux_y_local(k) = fs_1 - phi_s * &
3069	( fs_1 - swap_flux_y_local(k) )
3070	flux_n(k) = fn_1 - phi_n * &
3071	( fn_1 - flux_n(k) )
3072	flux_d = fd_1 - phi_d * &
3073	( fd_1 - flux_d )
3074	flux_t(k) = ft_1 - phi_t * &
3075	( ft_1 - flux_t(k) )
3076	!
3077	!-- Moreover, modify dissipation flux according to the limiter.
3078	swap_diss_x_local(k,j) = swap_diss_x_local(k,j) * phi_l
3079	diss_r(k) = diss_r(k) * phi_r
3080	swap_diss_y_local(k) = swap_diss_y_local(k) * phi_s
3081	diss_n(k) = diss_n(k) * phi_n
3082	diss_d = diss_d * phi_d
3083	diss_t(k) = diss_t(k) * phi_t
3084
3085	ENDIF
3086	!
3087	!-- Calculate the divergence of the velocity field. A respective
3088	!-- correction is needed to overcome numerical instabilities caused
3089	!-- by a not sufficient reduction of divergences near topography.
3090	div = ( u(k,j,i+1) * ( ibit0 + ibit1 + ibit2 ) &
3091	- u(k,j,i) * ( IBITS(wall_flags_0(k,j,i-1),0,1) &
3092	+ IBITS(wall_flags_0(k,j,i-1),1,1) &
3093	+ IBITS(wall_flags_0(k,j,i-1),2,1) &
3094	) &
3095	) * ddx &
3096	+ ( v(k,j+1,i) * ( ibit3 + ibit4 + ibit5 ) &
3097	- v(k,j,i) * ( IBITS(wall_flags_0(k,j-1,i),3,1) &
3098	+ IBITS(wall_flags_0(k,j-1,i),4,1) &
3099	+ IBITS(wall_flags_0(k,j-1,i),5,1) &
3100	) &
3101	) * ddy &
3102	+ ( w(k,j,i) * ( ibit6 + ibit7 + ibit8 ) &
3103	- w(k-1,j,i) * ( IBITS(wall_flags_0(k-1,j,i),6,1) &
3104	+ IBITS(wall_flags_0(k-1,j,i),7,1) &
3105	+ IBITS(wall_flags_0(k-1,j,i),8,1) &
3106	) &
3107	) * ddzw(k)
3108
3109
3110	tend(k,j,i) = tend(k,j,i) - ( &
3111	( flux_r(k) + diss_r(k) - swap_flux_x_local(k,j) - &
3112	swap_diss_x_local(k,j) ) * ddx &
3113	+ ( flux_n(k) + diss_n(k) - swap_flux_y_local(k) - &
3114	swap_diss_y_local(k) ) * ddy &
3115	+ ( flux_t(k) + diss_t(k) - flux_d - diss_d &
3116	) * ddzw(k) &
3117	) + sk(k,j,i) * div
3118
3119	swap_flux_y_local(k) = flux_n(k)
3120	swap_diss_y_local(k) = diss_n(k)
3121	swap_flux_x_local(k,j) = flux_r(k)
3122	swap_diss_x_local(k,j) = diss_r(k)
3123	flux_d = flux_t(k)
3124	diss_d = diss_t(k)
3125
3126	ENDDO
3127
3128	DO k = nzb_max+1, nzt
3129
3130	u_comp = u(k,j,i+1) - u_gtrans
3131	flux_r(k) = u_comp * ( &
3132	37.0_wp * ( sk(k,j,i+1) + sk(k,j,i) ) &
3133	- 8.0_wp * ( sk(k,j,i+2) + sk(k,j,i-1) ) &
3134	+ ( sk(k,j,i+3) + sk(k,j,i-2) ) ) * adv_sca_5
3135	diss_r(k) = -ABS( u_comp ) * ( &
3136	10.0_wp * ( sk(k,j,i+1) - sk(k,j,i) ) &
3137	- 5.0_wp * ( sk(k,j,i+2) - sk(k,j,i-1) ) &
3138	+ ( sk(k,j,i+3) - sk(k,j,i-2) ) ) * adv_sca_5
3139
3140	v_comp = v(k,j+1,i) - v_gtrans
3141	flux_n(k) = v_comp * ( &
3142	37.0_wp * ( sk(k,j+1,i) + sk(k,j,i) ) &
3143	- 8.0_wp * ( sk(k,j+2,i) + sk(k,j-1,i) ) &
3144	+ ( sk(k,j+3,i) + sk(k,j-2,i) ) ) * adv_sca_5
3145	diss_n(k) = -ABS( v_comp ) * ( &
3146	10.0_wp * ( sk(k,j+1,i) - sk(k,j,i) ) &
3147	- 5.0_wp * ( sk(k,j+2,i) - sk(k,j-1,i) ) &
3148	+ ( sk(k,j+3,i) - sk(k,j-2,i) ) ) * adv_sca_5
3149	!
3150	!-- k index has to be modified near bottom and top, else array
3151	!-- subscripts will be exceeded.
3152	ibit8 = IBITS(wall_flags_0(k,j,i),8,1)
3153	ibit7 = IBITS(wall_flags_0(k,j,i),7,1)
3154	ibit6 = IBITS(wall_flags_0(k,j,i),6,1)
3155
3156	k_ppp = k + 3 * ibit8
3157	k_pp = k + 2 * ( 1 - ibit6 )
3158	k_mm = k - 2 * ibit8
3159
3160
3161	flux_t(k) = w(k,j,i) * ( &
3162	( 37.0_wp * ibit8 * adv_sca_5 &
3163	+ 7.0_wp * ibit7 * adv_sca_3 &
3164	+ ibit6 * adv_sca_1 &
3165	) * &
3166	( sk(k+1,j,i) + sk(k,j,i) ) &
3167	- ( 8.0_wp * ibit8 * adv_sca_5 &
3168	+ ibit7 * adv_sca_3 &
3169	) * &
3170	( sk(k_pp,j,i) + sk(k-1,j,i) ) &
3171	+ ( ibit8 * adv_sca_5 &
3172	) * ( sk(k_ppp,j,i)+ sk(k_mm,j,i) ) &
3173	)
3174
3175	diss_t(k) = -ABS( w(k,j,i) ) * ( &
3176	( 10.0_wp * ibit8 * adv_sca_5 &
3177	+ 3.0_wp * ibit7 * adv_sca_3 &
3178	+ ibit6 * adv_sca_1 &
3179	) * &
3180	( sk(k+1,j,i) - sk(k,j,i) ) &
3181	- ( 5.0_wp * ibit8 * adv_sca_5 &
3182	+ ibit7 * adv_sca_3 &
3183	) * &
3184	( sk(k_pp,j,i) - sk(k-1,j,i) ) &
3185	+ ( ibit8 * adv_sca_5 &
3186	) * &
3187	( sk(k_ppp,j,i) - sk(k_mm,j,i) ) &
3188	)
3189	!
3190	!-- Apply monotonic adjustment.
3191	IF ( monotonic_adjustment ) THEN
3192	!
3193	!-- At first, calculate first order fluxes.
3194	u_comp = u(k,j,i) - u_gtrans
3195	fl_1 = ( u_comp * ( sk(k,j,i) + sk(k,j,i-1) ) &
3196	-ABS( u_comp ) * ( sk(k,j,i) - sk(k,j,i-1) ) &
3197	) * adv_sca_1
3198
3199	u_comp = u(k,j,i+1) - u_gtrans
3200	fr_1 = ( u_comp * ( sk(k,j,i+1) + sk(k,j,i) ) &
3201	-ABS( u_comp ) * ( sk(k,j,i+1) - sk(k,j,i) ) &
3202	) * adv_sca_1
3203
3204	v_comp = v(k,j,i) - v_gtrans
3205	fs_1 = ( v_comp * ( sk(k,j,i) + sk(k,j-1,i) ) &
3206	-ABS( v_comp ) * ( sk(k,j,i) - sk(k,j-1,i) ) &
3207	) * adv_sca_1
3208
3209	v_comp = v(k,j+1,i) - v_gtrans
3210	fn_1 = ( v_comp * ( sk(k,j+1,i) + sk(k,j,i) ) &
3211	-ABS( v_comp ) * ( sk(k,j+1,i) - sk(k,j,i) ) &
3212	) * adv_sca_1
3213
3214	fd_1 = ( w(k-1,j,i) * ( sk(k,j,i) + sk(k-1,j,i) ) &
3215	-ABS( w(k-1,j,i) ) * ( sk(k,j,i) - sk(k-1,j,i) ) &
3216	) * adv_sca_1
3217
3218	ft_1 = ( w(k,j,i) * ( sk(k+1,j,i) + sk(k,j,i) ) &
3219	-ABS( w(k,j,i) ) * ( sk(k+1,j,i) - sk(k,j,i) ) &
3220	) * adv_sca_1
3221	!
3222	!-- Calculate ratio of upwind gradients. Note, Min/Max is just
3223	!-- to avoid if statements.
3224	rl = ( MAX( 0.0_wp, u(k,j,i) - u_gtrans ) * &
3225	ABS( ( sk(k,j,i-1) - sk(k,j,i-2) ) /&
3226	( sk(k,j,i) - sk(k,j,i-1) + 1E-20_wp ) &
3227	) + &
3228	MIN( 0.0_wp, u(k,j,i) - u_gtrans ) * &
3229	ABS( ( sk(k,j,i) - sk(k,j,i+1) ) /&
3230	( sk(k,j,i-1) - sk(k,j,i) + 1E-20_wp ) &
3231	) &
3232	) / ABS( u(k,j,i) - u_gtrans + 1E-20_wp )
3233
3234	rr = ( MAX( 0.0_wp, u(k,j,i+1) - u_gtrans ) * &
3235	ABS( ( sk(k,j,i) - sk(k,j,i-1) ) /&
3236	( sk(k,j,i+1) - sk(k,j,i) + 1E-20_wp ) &
3237	) + &
3238	MIN( 0.0_wp, u(k,j,i+1) - u_gtrans ) * &
3239	ABS( ( sk(k,j,i+1) - sk(k,j,i+2) ) /&
3240	( sk(k,j,i) - sk(k,j,i+1) + 1E-20_wp ) &
3241	) &
3242	) / ABS( u(k,j,i+1) - u_gtrans + 1E-20_wp )
3243
3244	rs = ( MAX( 0.0_wp, v(k,j,i) - v_gtrans ) * &
3245	ABS( ( sk(k,j-1,i) - sk(k,j-2,i) ) /&
3246	( sk(k,j,i) - sk(k,j-1,i) + 1E-20_wp ) &
3247	) + &
3248	MIN( 0.0_wp, v(k,j,i) - v_gtrans ) * &
3249	ABS( ( sk(k,j,i) - sk(k,j+1,i) ) /&
3250	( sk(k,j-1,i) - sk(k,j,i) + 1E-20_wp ) &
3251	) &
3252	) / ABS( v(k,j,i) - v_gtrans + 1E-20_wp )
3253
3254	rn = ( MAX( 0.0_wp, v(k,j+1,i) - v_gtrans ) * &
3255	ABS( ( sk(k,j,i) - sk(k,j-1,i) ) /&
3256	( sk(k,j+1,i) - sk(k,j,i) + 1E-20_wp ) &
3257	) + &
3258	MIN( 0.0_wp, v(k,j+1,i) - v_gtrans ) * &
3259	ABS( ( sk(k,j+1,i) - sk(k,j+2,i) ) /&
3260	( sk(k,j,i) - sk(k,j+1,i) + 1E-20_wp ) &
3261	) &
3262	) / ABS( v(k,j+1,i) - v_gtrans + 1E-20_wp )
3263	!
3264	!-- Reuse k_mm and compute k_mmm for the vertical gradient ratios.
3265	!-- Note, for vertical advection below the third grid point above
3266	!-- surface ( or below the model top) rd and rt are set to 0, i.e.
3267	!-- use of first order scheme is enforced.
3268	k_mmm = k - 3 * ibit8
3269
3270	rd = ( MAX( 0.0_wp, w(k-1,j,i) ) * &
3271	ABS( ( sk(k_mm,j,i) - sk(k_mmm,j,i) ) / &
3272	( sk(k-1,j,i) - sk(k_mm,j,i) + 1E-20_wp ) &
3273	) + &
3274	MIN( 0.0_wp, w(k-1,j,i) ) * &
3275	ABS( ( sk(k-1,j,i) - sk(k,j,i) ) / &
3276	( sk(k_mm,j,i) - sk(k-1,j,i) + 1E-20_wp ) &
3277	) &
3278	) * ibit8 / ABS( w(k-1,j,i) + 1E-20_wp )
3279
3280	rt = ( MAX( 0.0_wp, w(k,j,i) ) * &
3281	ABS( ( sk(k,j,i) - sk(k-1,j,i) ) / &
3282	( sk(k+1,j,i) - sk(k,j,i) + 1E-20_wp ) &
3283	) + &
3284	MIN( 0.0_wp, w(k,j,i) ) * &
3285	ABS( ( sk(k+1,j,i) - sk(k_pp,j,i) ) / &
3286	( sk(k,j,i) - sk(k+1,j,i) + 1E-20_wp ) &
3287	) &
3288	) * ibit8 / ABS( w(k,j,i) + 1E-20_wp )
3289	!
3290	!-- Calculate empirical limiter function (van Albada2 limiter).
3291	phi_l = MIN( 1.0_wp, ( 2.0_wp * ABS( rl ) ) / &
3292	( rl**2 + 1.0_wp ) )
3293	phi_r = MIN( 1.0_wp, ( 2.0_wp * ABS( rr ) ) / &
3294	( rr**2 + 1.0_wp ) )
3295	phi_s = MIN( 1.0_wp, ( 2.0_wp * ABS( rs ) ) / &
3296	( rs**2 + 1.0_wp ) )
3297	phi_n = MIN( 1.0_wp, ( 2.0_wp * ABS( rn ) ) / &
3298	( rn**2 + 1.0_wp ) )
3299	phi_d = MIN( 1.0_wp, ( 2.0_wp * ABS( rd ) ) / &
3300	( rd**2 + 1.0_wp ) )
3301	phi_t = MIN( 1.0_wp, ( 2.0_wp * ABS( rt ) ) / &
3302	( rt**2 + 1.0_wp ) )
3303	!
3304	!-- Calculate the resulting monotone flux.
3305	swap_flux_x_local(k,j) = fl_1 - phi_l * &
3306	( fl_1 - swap_flux_x_local(k,j) )
3307	flux_r(k) = fr_1 - phi_r * &
3308	( fr_1 - flux_r(k) )
3309	swap_flux_y_local(k) = fs_1 - phi_s * &
3310	( fs_1 - swap_flux_y_local(k) )
3311	flux_n(k) = fn_1 - phi_n * &
3312	( fn_1 - flux_n(k) )
3313	flux_d = fd_1 - phi_d * &
3314	( fd_1 - flux_d )
3315	flux_t(k) = ft_1 - phi_t * &
3316	( ft_1 - flux_t(k) )
3317	!
3318	!-- Moreover, modify dissipation flux according to the limiter.
3319	swap_diss_x_local(k,j) = swap_diss_x_local(k,j) * phi_l
3320	diss_r(k) = diss_r(k) * phi_r
3321	swap_diss_y_local(k) = swap_diss_y_local(k) * phi_s
3322	diss_n(k) = diss_n(k) * phi_n
3323	diss_d = diss_d * phi_d
3324	diss_t(k) = diss_t(k) * phi_t
3325
3326	ENDIF
3327	!
3328	!-- Calculate the divergence of the velocity field. A respective
3329	!-- correction is needed to overcome numerical instabilities introduced
3330	!-- by a not sufficient reduction of divergences near topography.
3331	div = ( u(k,j,i+1) - u(k,j,i) ) * ddx &
3332	+ ( v(k,j+1,i) - v(k,j,i) ) * ddy &
3333	+ ( w(k,j,i) - w(k-1,j,i) ) * ddzw(k)
3334
3335	tend(k,j,i) = tend(k,j,i) - ( &
3336	( flux_r(k) + diss_r(k) - swap_flux_x_local(k,j) - &
3337	swap_diss_x_local(k,j) ) * ddx &
3338	+ ( flux_n(k) + diss_n(k) - swap_flux_y_local(k) - &
3339	swap_diss_y_local(k) ) * ddy &
3340	+ ( flux_t(k) + diss_t(k) - flux_d - diss_d &
3341	) * ddzw(k) &
3342	) + sk(k,j,i) * div
3343
3344	swap_flux_y_local(k) = flux_n(k)
3345	swap_diss_y_local(k) = diss_n(k)
3346	swap_flux_x_local(k,j) = flux_r(k)
3347	swap_diss_x_local(k,j) = diss_r(k)
3348	flux_d = flux_t(k)
3349	diss_d = diss_t(k)
3350
3351	ENDDO
3352	!
3353	!-- Evaluation of statistics.
3354	SELECT CASE ( sk_char )
3355
3356	CASE ( 'pt' )
3357	DO k = nzb, nzt
3358	sums_wspts_ws_l(k,tn) = sums_wspts_ws_l(k,tn) &
3359	+ ( flux_t(k) + diss_t(k) ) &
3360	* weight_substep(intermediate_timestep_count)
3361	ENDDO
3362	CASE ( 'sa' )
3363	DO k = nzb, nzt
3364	sums_wssas_ws_l(k,tn) = sums_wssas_ws_l(k,tn) &
3365	+ ( flux_t(k) + diss_t(k) ) &
3366	* weight_substep(intermediate_timestep_count)
3367	ENDDO
3368	CASE ( 'q' )
3369	DO k = nzb, nzt
3370	sums_wsqs_ws_l(k,tn) = sums_wsqs_ws_l(k,tn) &
3371	+ ( flux_t(k) + diss_t(k) ) &
3372	* weight_substep(intermediate_timestep_count)
3373	ENDDO
3374	CASE ( 'qr' )
3375	DO k = nzb, nzt
3376	sums_wsqrs_ws_l(k,tn) = sums_wsqrs_ws_l(k,tn) &
3377	+ ( flux_t(k) + diss_t(k) ) &
3378	* weight_substep(intermediate_timestep_count)
3379	ENDDO
3380	CASE ( 'nr' )
3381	DO k = nzb, nzt
3382	sums_wsnrs_ws_l(k,tn) = sums_wsnrs_ws_l(k,tn) &
3383	+ ( flux_t(k) + diss_t(k) ) &
3384	* weight_substep(intermediate_timestep_count)
3385	ENDDO
3386
3387	END SELECT
3388
3389	ENDDO
3390	ENDDO
3391
3392	END SUBROUTINE advec_s_ws
3393
3394
3395	!------------------------------------------------------------------------------!
3396	! Scalar advection - Call for all grid points - accelerator version
3397	!------------------------------------------------------------------------------!
3398	SUBROUTINE advec_s_ws_acc ( sk, sk_char )
3399
3400	USE arrays_3d, &
3401	ONLY: ddzw, tend, u, v, w
3402
3403	USE constants, &
3404	ONLY: adv_sca_1, adv_sca_3, adv_sca_5
3405
3406	USE control_parameters, &
3407	ONLY: intermediate_timestep_count, monotonic_adjustment, u_gtrans,&
3408	v_gtrans
3409
3410	USE grid_variables, &
3411	ONLY: ddx, ddy
3412
3413	USE indices, &
3414	ONLY: i_left, i_right, j_north, j_south, nxlg, nxrg, nyng, nysg, &
3415	nzb, nzb_max, nzt, wall_flags_0
3416
3417	USE kinds
3418
3419	! USE statistics, &
3420	! ONLY: sums_wspts_ws_l, sums_wsqs_ws_l, sums_wssas_ws_l, &
3421	! sums_wsqrs_ws_l, sums_wsnrs_ws_l, weight_substep
3422
3423	IMPLICIT NONE
3424
3425	CHARACTER (LEN = *), INTENT(IN) :: sk_char !:
3426
3427	INTEGER(iwp) :: i !:
3428	INTEGER(iwp) :: ibit0 !:
3429	INTEGER(iwp) :: ibit1 !:
3430	INTEGER(iwp) :: ibit2 !:
3431	INTEGER(iwp) :: ibit3 !:
3432	INTEGER(iwp) :: ibit4 !:
3433	INTEGER(iwp) :: ibit5 !:
3434	INTEGER(iwp) :: ibit6 !:
3435	INTEGER(iwp) :: ibit7 !:
3436	INTEGER(iwp) :: ibit8 !:
3437	INTEGER(iwp) :: j !:
3438	INTEGER(iwp) :: k !:
3439	INTEGER(iwp) :: k_mm !:
3440	INTEGER(iwp) :: k_mmm !:
3441	INTEGER(iwp) :: k_pp !:
3442	INTEGER(iwp) :: k_ppp !:
3443	INTEGER(iwp) :: tn = 0 !:
3444
3445	REAL(wp) :: diss_d !:
3446	REAL(wp) :: diss_l !:
3447	REAL(wp) :: diss_n !:
3448	REAL(wp) :: diss_r !:
3449	REAL(wp) :: diss_s !:
3450	REAL(wp) :: diss_t !:
3451	REAL(wp) :: div !:
3452	REAL(wp) :: flux_d !:
3453	REAL(wp) :: flux_l !:
3454	REAL(wp) :: flux_n !:
3455	REAL(wp) :: flux_r !:
3456	REAL(wp) :: flux_s !:
3457	REAL(wp) :: flux_t !:
3458	REAL(wp) :: fd_1 !:
3459	REAL(wp) :: fl_1 !:
3460	REAL(wp) :: fn_1 !:
3461	REAL(wp) :: fr_1 !:
3462	REAL(wp) :: fs_1 !:
3463	REAL(wp) :: ft_1 !:
3464	REAL(wp) :: phi_d !:
3465	REAL(wp) :: phi_l !:
3466	REAL(wp) :: phi_n !:
3467	REAL(wp) :: phi_r !:
3468	REAL(wp) :: phi_s !:
3469	REAL(wp) :: phi_t !:
3470	REAL(wp) :: rd !:
3471	REAL(wp) :: rl !:
3472	REAL(wp) :: rn !:
3473	REAL(wp) :: rr !:
3474	REAL(wp) :: rs !:
3475	REAL(wp) :: rt !:
3476	REAL(wp) :: u_comp !:
3477	REAL(wp) :: v_comp !:
3478
3479	REAL(wp), INTENT(IN), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: sk !:
3480
3481	!
3482	!-- Computation of fluxes and tendency terms
3483	!$acc kernels present( ddzw, sk, tend, u, v, w, wall_flags_0 )
3484	DO i = i_left, i_right
3485	DO j = j_south, j_north
3486	DO k = nzb+1, nzt
3487
3488	ibit2 = IBITS(wall_flags_0(k,j,i-1),2,1)
3489	ibit1 = IBITS(wall_flags_0(k,j,i-1),1,1)
3490	ibit0 = IBITS(wall_flags_0(k,j,i-1),0,1)
3491
3492	u_comp = u(k,j,i) - u_gtrans
3493	flux_l = u_comp * ( &
3494	( 37.0_wp * ibit2 * adv_sca_5 &
3495	+ 7.0_wp * ibit1 * adv_sca_3 &
3496	+ ibit0 * adv_sca_1 &
3497	) * &
3498	( sk(k,j,i) + sk(k,j,i-1) ) &
3499	- ( 8.0_wp * ibit2 * adv_sca_5 &
3500	+ ibit1 * adv_sca_3 &
3501	) * &
3502	( sk(k,j,i+1) + sk(k,j,i-2) ) &
3503	+ ( ibit2 * adv_sca_5 &
3504	) * &
3505	( sk(k,j,i+2) + sk(k,j,i-3) ) &
3506	)
3507
3508	diss_l = -ABS( u_comp ) * ( &
3509	( 10.0_wp * ibit2 * adv_sca_5 &
3510	+ 3.0_wp * ibit1 * adv_sca_3 &
3511	+ ibit0 * adv_sca_1 &
3512	) * &
3513	( sk(k,j,i) - sk(k,j,i-1) ) &
3514	- ( 5.0_wp * ibit2 * adv_sca_5 &
3515	+ ibit1 * adv_sca_3 &
3516	) * &
3517	( sk(k,j,i+1) - sk(k,j,i-2) ) &
3518	+ ( ibit2 * adv_sca_5 &
3519	) * &
3520	( sk(k,j,i+2) - sk(k,j,i-3) ) &
3521	)
3522
3523	ibit2 = IBITS(wall_flags_0(k,j,i),2,1)
3524	ibit1 = IBITS(wall_flags_0(k,j,i),1,1)
3525	ibit0 = IBITS(wall_flags_0(k,j,i),0,1)
3526
3527	u_comp = u(k,j,i+1) - u_gtrans
3528	flux_r = u_comp * ( &
3529	( 37.0_wp * ibit2 * adv_sca_5 &
3530	+ 7.0_wp * ibit1 * adv_sca_3 &
3531	+ ibit0 * adv_sca_1 &
3532	) * &
3533	( sk(k,j,i+1) + sk(k,j,i) ) &
3534	- ( 8.0_wp * ibit2 * adv_sca_5 &
3535	+ ibit1 * adv_sca_3 &
3536	) * &
3537	( sk(k,j,i+2) + sk(k,j,i-1) ) &
3538	+ ( ibit2 * adv_sca_5 &
3539	) * &
3540	( sk(k,j,i+3) + sk(k,j,i-2) ) &
3541	)
3542
3543	diss_r = -ABS( u_comp ) * ( &
3544	( 10.0_wp * ibit2 * adv_sca_5 &
3545	+ 3.0_wp * ibit1 * adv_sca_3 &
3546	+ ibit0 * adv_sca_1 &
3547	) * &
3548	( sk(k,j,i+1) - sk(k,j,i) ) &
3549	- ( 5.0_wp * ibit2 * adv_sca_5 &
3550	+ ibit1 * adv_sca_3 &
3551	) * &
3552	( sk(k,j,i+2) - sk(k,j,i-1) ) &
3553	+ ( ibit2 * adv_sca_5 &
3554	) * &
3555	( sk(k,j,i+3) - sk(k,j,i-2) ) &
3556	)
3557
3558	ibit5 = IBITS(wall_flags_0(k,j-1,i),5,1)
3559	ibit4 = IBITS(wall_flags_0(k,j-1,i),4,1)
3560	ibit3 = IBITS(wall_flags_0(k,j-1,i),3,1)
3561
3562	v_comp = v(k,j,i) - v_gtrans
3563	flux_s = v_comp * ( &
3564	( 37.0_wp * ibit5 * adv_sca_5 &
3565	+ 7.0_wp * ibit4 * adv_sca_3 &
3566	+ ibit3 * adv_sca_1 &
3567	) * &
3568	( sk(k,j,i) + sk(k,j-1,i) ) &
3569	- ( 8.0_wp * ibit5 * adv_sca_5 &
3570	+ ibit4 * adv_sca_3 &
3571	) * &
3572	( sk(k,j+1,i) + sk(k,j-2,i) ) &
3573	+ ( ibit5 * adv_sca_5 &
3574	) * &
3575	( sk(k,j+2,i) + sk(k,j-3,i) ) &
3576	)
3577
3578	diss_s = -ABS( v_comp ) * ( &
3579	( 10.0_wp * ibit5 * adv_sca_5 &
3580	+ 3.0_wp * ibit4 * adv_sca_3 &
3581	+ ibit3 * adv_sca_1 &
3582	) * &
3583	( sk(k,j,i) - sk(k,j-1,i) ) &
3584	- ( 5.0_wp * ibit5 * adv_sca_5 &
3585	+ ibit4 * adv_sca_3 &
3586	) * &
3587	( sk(k,j+1,i) - sk(k,j-2,i) ) &
3588	+ ( ibit5 * adv_sca_5 &
3589	) * &
3590	( sk(k,j+2,i) - sk(k,j-3,i) ) &
3591	)
3592
3593	ibit5 = IBITS(wall_flags_0(k,j,i),5,1)
3594	ibit4 = IBITS(wall_flags_0(k,j,i),4,1)
3595	ibit3 = IBITS(wall_flags_0(k,j,i),3,1)
3596
3597	v_comp = v(k,j+1,i) - v_gtrans
3598	flux_n = v_comp * ( &
3599	( 37.0_wp * ibit5 * adv_sca_5 &
3600	+ 7.0_wp * ibit4 * adv_sca_3 &
3601	+ ibit3 * adv_sca_1 &
3602	) * &
3603	( sk(k,j+1,i) + sk(k,j,i) ) &
3604	- ( 8.0_wp * ibit5 * adv_sca_5 &
3605	+ ibit4 * adv_sca_3 &
3606	) * &
3607	( sk(k,j+2,i) + sk(k,j-1,i) ) &
3608	+ ( ibit5 * adv_sca_5 &
3609	) * &
3610	( sk(k,j+3,i) + sk(k,j-2,i) ) &
3611	)
3612
3613	diss_n = -ABS( v_comp ) * ( &
3614	( 10.0_wp * ibit5 * adv_sca_5 &
3615	+ 3.0_wp * ibit4 * adv_sca_3 &
3616	+ ibit3 * adv_sca_1 &
3617	) * &
3618	( sk(k,j+1,i) - sk(k,j,i) ) &
3619	- ( 5.0_wp * ibit5 * adv_sca_5 &
3620	+ ibit4 * adv_sca_3 &
3621	) * &
3622	( sk(k,j+2,i) - sk(k,j-1,i) ) &
3623	+ ( ibit5 * adv_sca_5 &
3624	) * &
3625	( sk(k,j+3,i) - sk(k,j-2,i) ) &
3626	)
3627
3628	!
3629	!-- indizes k_m, k_mm, ... should be known at these point
3630	ibit8 = IBITS(wall_flags_0(k-1,j,i),8,1)
3631	ibit7 = IBITS(wall_flags_0(k-1,j,i),7,1)
3632	ibit6 = IBITS(wall_flags_0(k-1,j,i),6,1)
3633
3634	k_pp = k + 2 * ibit8
3635	k_mm = k - 2 * ( ibit7 + ibit8 )
3636	k_mmm = k - 3 * ibit8
3637
3638	flux_d = w(k-1,j,i) * ( &
3639	( 37.0_wp * ibit8 * adv_sca_5 &
3640	+ 7.0_wp * ibit7 * adv_sca_3 &
3641	+ ibit6 * adv_sca_1 &
3642	) * &
3643	( sk(k,j,i) + sk(k-1,j,i) ) &
3644	- ( 8.0_wp * ibit8 * adv_sca_5 &
3645	+ ibit7 * adv_sca_3 &
3646	) * &
3647	( sk(k+1,j,i) + sk(k_mm,j,i) ) &
3648	+ ( ibit8 * adv_sca_5 &
3649	) * ( sk(k_pp,j,i)+ sk(k_mmm,j,i) ) &
3650	)
3651
3652	diss_d = -ABS( w(k-1,j,i) ) * ( &
3653	( 10.0_wp * ibit8 * adv_sca_5 &
3654	+ 3.0_wp * ibit7 * adv_sca_3 &
3655	+ ibit6 * adv_sca_1 &
3656	) * &
3657	( sk(k,j,i) - sk(k-1,j,i) ) &
3658	- ( 5.0_wp * ibit8 * adv_sca_5 &
3659	+ ibit7 * adv_sca_3 &
3660	) * &
3661	( sk(k+1,j,i) - sk(k_mm,j,i) ) &
3662	+ ( ibit8 * adv_sca_5 &
3663	) * &
3664	( sk(k_pp,j,i) - sk(k_mmm,j,i) ) &
3665	)
3666
3667	ibit8 = IBITS(wall_flags_0(k,j,i),8,1)
3668	ibit7 = IBITS(wall_flags_0(k,j,i),7,1)
3669	ibit6 = IBITS(wall_flags_0(k,j,i),6,1)
3670
3671	k_ppp = k + 3 * ibit8
3672	k_pp = k + 2 * ( 1 - ibit6 )
3673	k_mm = k - 2 * ibit8
3674
3675	flux_t = w(k,j,i) * ( &
3676	( 37.0_wp * ibit8 * adv_sca_5 &
3677	+ 7.0_wp * ibit7 * adv_sca_3 &
3678	+ ibit6 * adv_sca_1 &
3679	) * &
3680	( sk(k+1,j,i) + sk(k,j,i) ) &
3681	- ( 8.0_wp * ibit8 * adv_sca_5 &
3682	+ ibit7 * adv_sca_3 &
3683	) * &
3684	( sk(k_pp,j,i) + sk(k-1,j,i) ) &
3685	+ ( ibit8 * adv_sca_5 &
3686	) * ( sk(k_ppp,j,i)+ sk(k_mm,j,i) ) &
3687	)
3688
3689	diss_t = -ABS( w(k,j,i) ) * ( &
3690	( 10.0_wp * ibit8 * adv_sca_5 &
3691	+ 3.0_wp * ibit7 * adv_sca_3 &
3692	+ ibit6 * adv_sca_1 &
3693	) * &
3694	( sk(k+1,j,i) - sk(k,j,i) ) &
3695	- ( 5.0_wp * ibit8 * adv_sca_5 &
3696	+ ibit7 * adv_sca_3 &
3697	) * &
3698	( sk(k_pp,j,i) - sk(k-1,j,i) ) &
3699	+ ( ibit8 * adv_sca_5 &
3700	) * &
3701	( sk(k_ppp,j,i) - sk(k_mm,j,i) ) &
3702	)
3703	!
3704	!-- Apply monotonic adjustment.
3705	IF ( monotonic_adjustment ) THEN
3706	!
3707	!-- At first, calculate first order fluxes.
3708	u_comp = u(k,j,i) - u_gtrans
3709	fl_1 = ( u_comp * ( sk(k,j,i) + sk(k,j,i-1) ) &
3710	-ABS( u_comp ) * ( sk(k,j,i) - sk(k,j,i-1) ) &
3711	) * adv_sca_1
3712
3713	u_comp = u(k,j,i+1) - u_gtrans
3714	fr_1 = ( u_comp * ( sk(k,j,i+1) + sk(k,j,i) ) &
3715	-ABS( u_comp ) * ( sk(k,j,i+1) - sk(k,j,i) ) &
3716	) * adv_sca_1
3717
3718	v_comp = v(k,j,i) - v_gtrans
3719	fs_1 = ( v_comp * ( sk(k,j,i) + sk(k,j-1,i) ) &
3720	-ABS( v_comp ) * ( sk(k,j,i) - sk(k,j-1,i) ) &
3721	) * adv_sca_1
3722
3723	v_comp = v(k,j+1,i) - v_gtrans
3724	fn_1 = ( v_comp * ( sk(k,j+1,i) + sk(k,j,i) ) &
3725	-ABS( v_comp ) * ( sk(k,j+1,i) - sk(k,j,i) ) &
3726	) * adv_sca_1
3727
3728	fd_1 = ( w(k-1,j,i) * ( sk(k,j,i) + sk(k-1,j,i) ) &
3729	-ABS( w(k-1,j,i) ) * ( sk(k,j,i) - sk(k-1,j,i) ) &
3730	) * adv_sca_1
3731
3732	ft_1 = ( w(k,j,i) * ( sk(k+1,j,i) + sk(k,j,i) ) &
3733	-ABS( w(k,j,i) ) * ( sk(k+1,j,i) - sk(k,j,i) ) &
3734	) * adv_sca_1
3735	!
3736	!-- Calculate ratio of upwind gradients. Note, Min/Max is just
3737	!-- to avoid if statements.
3738	rl = ( MAX( 0.0_wp, u(k,j,i) - u_gtrans ) * &
3739	ABS( ( sk(k,j,i-1) - sk(k,j,i-2) ) /&
3740	( sk(k,j,i) - sk(k,j,i-1) + 1E-20_wp ) &
3741	) + &
3742	MIN( 0.0_wp, u(k,j,i) - u_gtrans ) * &
3743	ABS( ( sk(k,j,i) - sk(k,j,i+1) ) /&
3744	( sk(k,j,i-1) - sk(k,j,i) + 1E-20_wp ) &
3745	) &
3746	) / ABS( u(k,j,i) - u_gtrans + 1E-20_wp )
3747
3748	rr = ( MAX( 0.0_wp, u(k,j,i+1) - u_gtrans ) * &
3749	ABS( ( sk(k,j,i) - sk(k,j,i-1) ) /&
3750	( sk(k,j,i+1) - sk(k,j,i) + 1E-20_wp ) &
3751	) + &
3752	MIN( 0.0_wp, u(k,j,i+1) - u_gtrans ) * &
3753	ABS( ( sk(k,j,i+1) - sk(k,j,i+2) ) /&
3754	( sk(k,j,i) - sk(k,j,i+1) + 1E-20_wp ) &
3755	) &
3756	) / ABS( u(k,j,i+1) - u_gtrans + 1E-20_wp )
3757
3758	rs = ( MAX( 0.0_wp, v(k,j,i) - v_gtrans ) * &
3759	ABS( ( sk(k,j-1,i) - sk(k,j-2,i) ) /&
3760	( sk(k,j,i) - sk(k,j-1,i) + 1E-20_wp ) &
3761	) + &
3762	MIN( 0.0_wp, v(k,j,i) - v_gtrans ) * &
3763	ABS( ( sk(k,j,i) - sk(k,j+1,i) ) /&
3764	( sk(k,j-1,i) - sk(k,j,i) + 1E-20_wp ) &
3765	) &
3766	) / ABS( v(k,j,i) - v_gtrans + 1E-20_wp )
3767
3768	rn = ( MAX( 0.0_wp, v(k,j+1,i) - v_gtrans ) * &
3769	ABS( ( sk(k,j,i) - sk(k,j-1,i) ) /&
3770	( sk(k,j+1,i) - sk(k,j,i) + 1E-20_wp ) &
3771	) + &
3772	MIN( 0.0_wp, v(k,j+1,i) - v_gtrans ) * &
3773	ABS( ( sk(k,j+1,i) - sk(k,j+2,i) ) /&
3774	( sk(k,j,i) - sk(k,j+1,i) + 1E-20_wp ) &
3775	) &
3776	) / ABS( v(k,j+1,i) - v_gtrans + 1E-20_wp )
3777	!
3778	!-- Reuse k_mm and compute k_mmm for the vertical gradient ratios.
3779	!-- Note, for vertical advection below the third grid point above
3780	!-- surface ( or below the model top) rd and rt are set to 0, i.e.
3781	!-- use of first order scheme is enforced.
3782	k_mmm = k - 3 * ibit8
3783
3784	rd = ( MAX( 0.0_wp, w(k-1,j,i) ) * &
3785	ABS( ( sk(k_mm,j,i) - sk(k_mmm,j,i) ) / &
3786	( sk(k-1,j,i) - sk(k_mm,j,i) + 1E-20_wp ) &
3787	) + &
3788	MIN( 0.0_wp, w(k-1,j,i) ) * &
3789	ABS( ( sk(k-1,j,i) - sk(k,j,i) ) / &
3790	( sk(k_mm,j,i) - sk(k-1,j,i) + 1E-20_wp ) &
3791	) &
3792	) * ibit8 / ABS( w(k-1,j,i) + 1E-20_wp )
3793
3794	rt = ( MAX( 0.0_wp, w(k,j,i) ) * &
3795	ABS( ( sk(k,j,i) - sk(k-1,j,i) ) / &
3796	( sk(k+1,j,i) - sk(k,j,i) + 1E-20_wp ) &
3797	) + &
3798	MIN( 0.0_wp, w(k,j,i) ) * &
3799	ABS( ( sk(k+1,j,i) - sk(k_pp,j,i) ) / &
3800	( sk(k,j,i) - sk(k+1,j,i) + 1E-20_wp ) &
3801	) &
3802	) * ibit8 / ABS( w(k,j,i) + 1E-20_wp )
3803	!
3804	!-- Calculate empirical limiter function (van Albada2 limiter).
3805	phi_l = MIN( 1.0_wp, ( 2.0_wp * ABS( rl ) ) / &
3806	( rl**2 + 1.0_wp ) )
3807	phi_r = MIN( 1.0_wp, ( 2.0_wp * ABS( rr ) ) / &
3808	( rr**2 + 1.0_wp ) )
3809	phi_s = MIN( 1.0_wp, ( 2.0_wp * ABS( rs ) ) / &
3810	( rs**2 + 1.0_wp ) )
3811	phi_n = MIN( 1.0_wp, ( 2.0_wp * ABS( rn ) ) / &
3812	( rn**2 + 1.0_wp ) )
3813	phi_d = MIN( 1.0_wp, ( 2.0_wp * ABS( rd ) ) / &
3814	( rd**2 + 1.0_wp ) )
3815	phi_t = MIN( 1.0_wp, ( 2.0_wp * ABS( rt ) ) / &
3816	( rt**2 + 1.0_wp ) )
3817	!
3818	!-- Calculate the resulting monotone flux.
3819	flux_l = fl_1 - phi_l * ( fl_1 - flux_l )
3820	flux_r = fr_1 - phi_r * ( fr_1 - flux_r )
3821	flux_s = fs_1 - phi_s * ( fs_1 - flux_s )
3822	flux_n = fn_1 - phi_n * ( fn_1 - flux_n )
3823	flux_d = fd_1 - phi_d * ( fd_1 - flux_d )
3824	flux_t = ft_1 - phi_t * ( ft_1 - flux_t )
3825	!
3826	!-- Moreover, modify dissipation flux according to the limiter.
3827	diss_l = diss_l * phi_l
3828	diss_r = diss_r * phi_r
3829	diss_s = diss_s * phi_s
3830	diss_n = diss_n * phi_n
3831	diss_d = diss_d * phi_d
3832	diss_t = diss_t * phi_t
3833
3834	ENDIF
3835	!
3836	!-- Calculate the divergence of the velocity field. A respective
3837	!-- correction is needed to overcome numerical instabilities caused
3838	!-- by a not sufficient reduction of divergences near topography.
3839	div = ( u(k,j,i+1) * ( ibit0 + ibit1 + ibit2 ) &
3840	- u(k,j,i) * ( IBITS(wall_flags_0(k,j,i-1),0,1) &
3841	+ IBITS(wall_flags_0(k,j,i-1),1,1) &
3842	+ IBITS(wall_flags_0(k,j,i-1),2,1) &
3843	) &
3844	) * ddx &
3845	+ ( v(k,j+1,i) * ( ibit3 + ibit4 + ibit5 ) &
3846	- v(k,j,i) * ( IBITS(wall_flags_0(k,j-1,i),3,1) &
3847	+ IBITS(wall_flags_0(k,j-1,i),4,1) &
3848	+ IBITS(wall_flags_0(k,j-1,i),5,1) &
3849	) &
3850	) * ddy &
3851	+ ( w(k,j,i) * ( ibit6 + ibit7 + ibit8 ) &
3852	- w(k-1,j,i) * ( IBITS(wall_flags_0(k-1,j,i),6,1) &
3853	+ IBITS(wall_flags_0(k-1,j,i),7,1) &
3854	+ IBITS(wall_flags_0(k-1,j,i),8,1) &
3855	) &
3856	) * ddzw(k)
3857
3858
3859	tend(k,j,i) = - ( &
3860	( flux_r + diss_r - flux_l - diss_l ) * ddx &
3861	+ ( flux_n + diss_n - flux_s - diss_s ) * ddy &
3862	+ ( flux_t + diss_t - flux_d - diss_d ) * ddzw(k)&
3863	) + div * sk(k,j,i)
3864
3865	!++
3866	!-- Evaluation of statistics
3867	! SELECT CASE ( sk_char )
3868	!
3869	! CASE ( 'pt' )
3870	! sums_wspts_ws_l(k,tn) = sums_wspts_ws_l(k,tn) &
3871	! + ( flux_t + diss_t ) &
3872	! * weight_substep(intermediate_timestep_count)
3873	! CASE ( 'sa' )
3874	! sums_wssas_ws_l(k,tn) = sums_wssas_ws_l(k,tn) &
3875	! + ( flux_t + diss_t ) &
3876	! * weight_substep(intermediate_timestep_count)
3877	! CASE ( 'q' )
3878	! sums_wsqs_ws_l(k,tn) = sums_wsqs_ws_l(k,tn) &
3879	! + ( flux_t + diss_t ) &
3880	! * weight_substep(intermediate_timestep_count)
3881	! CASE ( 'qr' )
3882	! sums_wsqrs_ws_l(k,tn) = sums_wsqrs_ws_l(k,tn) &
3883	! + ( flux_t + diss_t ) &
3884	! * weight_substep(intermediate_timestep_count)
3885	! CASE ( 'nr' )
3886	! sums_wsnrs_ws_l(k,tn) = sums_wsnrs_ws_l(k,tn) &
3887	! + ( flux_t + diss_t ) &
3888	! * weight_substep(intermediate_timestep_count)
3889	!
3890	! END SELECT
3891
3892	ENDDO
3893	ENDDO
3894	ENDDO
3895	!$acc end kernels
3896
3897	END SUBROUTINE advec_s_ws_acc
3898
3899
3900	!------------------------------------------------------------------------------!
3901	! Advection of u - Call for all grid points
3902	!------------------------------------------------------------------------------!
3903	SUBROUTINE advec_u_ws
3904
3905	USE arrays_3d, &
3906	ONLY: ddzw, tend, u, v, w
3907
3908	USE constants, &
3909	ONLY: adv_mom_1, adv_mom_3, adv_mom_5
3910
3911	USE control_parameters, &
3912	ONLY: intermediate_timestep_count, u_gtrans, v_gtrans
3913
3914	USE grid_variables, &
3915	ONLY: ddx, ddy
3916
3917	USE indices, &
3918	ONLY: nxl, nxlu, nxr, nyn, nys, nzb, nzb_max, nzt, wall_flags_0
3919
3920	USE kinds
3921
3922	USE statistics, &
3923	ONLY: hom, sums_us2_ws_l, sums_wsus_ws_l, weight_substep
3924
3925	IMPLICIT NONE
3926
3927	INTEGER(iwp) :: i !:
3928	INTEGER(iwp) :: ibit9 !:
3929	INTEGER(iwp) :: ibit10 !:
3930	INTEGER(iwp) :: ibit11 !:
3931	INTEGER(iwp) :: ibit12 !:
3932	INTEGER(iwp) :: ibit13 !:
3933	INTEGER(iwp) :: ibit14 !:
3934	INTEGER(iwp) :: ibit15 !:
3935	INTEGER(iwp) :: ibit16 !:
3936	INTEGER(iwp) :: ibit17 !:
3937	INTEGER(iwp) :: j !:
3938	INTEGER(iwp) :: k !:
3939	INTEGER(iwp) :: k_mm !:
3940	INTEGER(iwp) :: k_pp !:
3941	INTEGER(iwp) :: k_ppp !:
3942	INTEGER(iwp) :: tn = 0 !:
3943
3944	REAL(wp) :: diss_d !:
3945	REAL(wp) :: div !:
3946	REAL(wp) :: flux_d !:
3947	REAL(wp) :: gu !:
3948	REAL(wp) :: gv !:
3949	REAL(wp) :: v_comp !:
3950	REAL(wp) :: w_comp !:
3951
3952	REAL(wp), DIMENSION(nzb+1:nzt) :: swap_diss_y_local_u !:
3953	REAL(wp), DIMENSION(nzb+1:nzt) :: swap_flux_y_local_u !:
3954
3955	REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn) :: swap_diss_x_local_u !:
3956	REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn) :: swap_flux_x_local_u !:
3957
3958	REAL(wp), DIMENSION(nzb:nzt) :: diss_n !:
3959	REAL(wp), DIMENSION(nzb:nzt) :: diss_r !:
3960	REAL(wp), DIMENSION(nzb:nzt) :: diss_t !:
3961	REAL(wp), DIMENSION(nzb:nzt) :: flux_n !:
3962	REAL(wp), DIMENSION(nzb:nzt) :: flux_r !:
3963	REAL(wp), DIMENSION(nzb:nzt) :: flux_t !:
3964	REAL(wp), DIMENSION(nzb:nzt) :: u_comp !:
3965
3966	gu = 2.0_wp * u_gtrans
3967	gv = 2.0_wp * v_gtrans
3968
3969	!
3970	!-- Compute the fluxes for the whole left boundary of the processor domain.
3971	i = nxlu
3972	DO j = nys, nyn
3973	DO k = nzb+1, nzb_max
3974
3975	ibit11 = IBITS(wall_flags_0(k,j,i-1),11,1)
3976	ibit10 = IBITS(wall_flags_0(k,j,i-1),10,1)
3977	ibit9 = IBITS(wall_flags_0(k,j,i-1),9,1)
3978
3979	u_comp(k) = u(k,j,i) + u(k,j,i-1) - gu
3980	swap_flux_x_local_u(k,j) = u_comp(k) * ( &
3981	( 37.0_wp * ibit11 * adv_mom_5 &
3982	+ 7.0_wp * ibit10 * adv_mom_3 &
3983	+ ibit9 * adv_mom_1 &
3984	) * &
3985	( u(k,j,i) + u(k,j,i-1) ) &
3986	- ( 8.0_wp * ibit11 * adv_mom_5 &
3987	+ ibit10 * adv_mom_3 &
3988	) * &
3989	( u(k,j,i+1) + u(k,j,i-2) ) &
3990	+ ( ibit11 * adv_mom_5 &
3991	) * &
3992	( u(k,j,i+2) + u(k,j,i-3) ) &
3993	)
3994
3995	swap_diss_x_local_u(k,j) = - ABS( u_comp(k) ) * ( &
3996	( 10.0_wp * ibit11 * adv_mom_5 &
3997	+ 3.0_wp * ibit10 * adv_mom_3 &
3998	+ ibit9 * adv_mom_1 &
3999	) * &
4000	( u(k,j,i) - u(k,j,i-1) ) &
4001	- ( 5.0_wp * ibit11 * adv_mom_5 &
4002	+ ibit10 * adv_mom_3 &
4003	) * &
4004	( u(k,j,i+1) - u(k,j,i-2) ) &
4005	+ ( ibit11 * adv_mom_5 &
4006	) * &
4007	( u(k,j,i+2) - u(k,j,i-3) ) &
4008	)
4009
4010	ENDDO
4011
4012	DO k = nzb_max+1, nzt
4013
4014	u_comp(k) = u(k,j,i) + u(k,j,i-1) - gu
4015	swap_flux_x_local_u(k,j) = u_comp(k) * ( &
4016	37.0_wp * ( u(k,j,i) + u(k,j,i-1) ) &
4017	- 8.0_wp * ( u(k,j,i+1) + u(k,j,i-2) ) &
4018	+ ( u(k,j,i+2) + u(k,j,i-3) ) ) * adv_mom_5
4019	swap_diss_x_local_u(k,j) = - ABS(u_comp(k)) * ( &
4020	10.0_wp * ( u(k,j,i) - u(k,j,i-1) ) &
4021	- 5.0_wp * ( u(k,j,i+1) - u(k,j,i-2) ) &
4022	+ ( u(k,j,i+2) - u(k,j,i-3) ) ) * adv_mom_5
4023
4024	ENDDO
4025	ENDDO
4026
4027	DO i = nxlu, nxr
4028	!
4029	!-- The following loop computes the fluxes for the south boundary points
4030	j = nys
4031	DO k = nzb+1, nzb_max
4032
4033	ibit14 = IBITS(wall_flags_0(k,j-1,i),14,1)
4034	ibit13 = IBITS(wall_flags_0(k,j-1,i),13,1)
4035	ibit12 = IBITS(wall_flags_0(k,j-1,i),12,1)
4036
4037	v_comp = v(k,j,i) + v(k,j,i-1) - gv
4038	swap_flux_y_local_u(k) = v_comp * ( &
4039	( 37.0_wp * ibit14 * adv_mom_5 &
4040	+ 7.0_wp * ibit13 * adv_mom_3 &
4041	+ ibit12 * adv_mom_1 &
4042	) * &
4043	( u(k,j,i) + u(k,j-1,i) ) &
4044	- ( 8.0_wp * ibit14 * adv_mom_5 &
4045	+ ibit13 * adv_mom_3 &
4046	) * &
4047	( u(k,j+1,i) + u(k,j-2,i) ) &
4048	+ ( ibit14 * adv_mom_5 &
4049	) * &
4050	( u(k,j+2,i) + u(k,j-3,i) ) &
4051	)
4052
4053	swap_diss_y_local_u(k) = - ABS ( v_comp ) * ( &
4054	( 10.0_wp * ibit14 * adv_mom_5 &
4055	+ 3.0_wp * ibit13 * adv_mom_3 &
4056	+ ibit12 * adv_mom_1 &
4057	) * &
4058	( u(k,j,i) - u(k,j-1,i) ) &
4059	- ( 5.0_wp * ibit14 * adv_mom_5 &
4060	+ ibit13 * adv_mom_3 &
4061	) * &
4062	( u(k,j+1,i) - u(k,j-2,i) ) &
4063	+ ( ibit14 * adv_mom_5 &
4064	) * &
4065	( u(k,j+2,i) - u(k,j-3,i) ) &
4066	)
4067
4068	ENDDO
4069
4070	DO k = nzb_max+1, nzt
4071
4072	v_comp = v(k,j,i) + v(k,j,i-1) - gv
4073	swap_flux_y_local_u(k) = v_comp * ( &
4074	37.0_wp * ( u(k,j,i) + u(k,j-1,i) ) &
4075	- 8.0_wp * ( u(k,j+1,i) + u(k,j-2,i) ) &
4076	+ ( u(k,j+2,i) + u(k,j-3,i) ) ) * adv_mom_5
4077	swap_diss_y_local_u(k) = - ABS(v_comp) * ( &
4078	10.0_wp * ( u(k,j,i) - u(k,j-1,i) ) &
4079	- 5.0_wp * ( u(k,j+1,i) - u(k,j-2,i) ) &
4080	+ ( u(k,j+2,i) - u(k,j-3,i) ) ) * adv_mom_5
4081
4082	ENDDO
4083	!
4084	!-- Computation of interior fluxes and tendency terms
4085	DO j = nys, nyn
4086
4087	flux_t(0) = 0.0_wp
4088	diss_t(0) = 0.0_wp
4089	flux_d = 0.0_wp
4090	diss_d = 0.0_wp
4091
4092	DO k = nzb+1, nzb_max
4093
4094	ibit11 = IBITS(wall_flags_0(k,j,i),11,1)
4095	ibit10 = IBITS(wall_flags_0(k,j,i),10,1)
4096	ibit9 = IBITS(wall_flags_0(k,j,i),9,1)
4097
4098	u_comp(k) = u(k,j,i+1) + u(k,j,i)
4099	flux_r(k) = ( u_comp(k) - gu ) * ( &
4100	( 37.0_wp * ibit11 * adv_mom_5 &
4101	+ 7.0_wp * ibit10 * adv_mom_3 &
4102	+ ibit9 * adv_mom_1 &
4103	) * &
4104	( u(k,j,i+1) + u(k,j,i) ) &
4105	- ( 8.0_wp * ibit11 * adv_mom_5 &
4106	+ ibit10 * adv_mom_3 &
4107	) * &
4108	( u(k,j,i+2) + u(k,j,i-1) ) &
4109	+ ( ibit11 * adv_mom_5 &
4110	) * &
4111	( u(k,j,i+3) + u(k,j,i-2) ) &
4112	)
4113
4114	diss_r(k) = - ABS( u_comp(k) - gu ) * ( &
4115	( 10.0_wp * ibit11 * adv_mom_5 &
4116	+ 3.0_wp * ibit10 * adv_mom_3 &
4117	+ ibit9 * adv_mom_1 &
4118	) * &
4119	( u(k,j,i+1) - u(k,j,i) ) &
4120	- ( 5.0_wp * ibit11 * adv_mom_5 &
4121	+ ibit10 * adv_mom_3 &
4122	) * &
4123	( u(k,j,i+2) - u(k,j,i-1) ) &
4124	+ ( ibit11 * adv_mom_5 &
4125	) * &
4126	( u(k,j,i+3) - u(k,j,i-2) ) &
4127	)
4128
4129	ibit14 = IBITS(wall_flags_0(k,j,i),14,1)
4130	ibit13 = IBITS(wall_flags_0(k,j,i),13,1)
4131	ibit12 = IBITS(wall_flags_0(k,j,i),12,1)
4132
4133	v_comp = v(k,j+1,i) + v(k,j+1,i-1) - gv
4134	flux_n(k) = v_comp * ( &
4135	( 37.0_wp * ibit14 * adv_mom_5 &
4136	+ 7.0_wp * ibit13 * adv_mom_3 &
4137	+ ibit12 * adv_mom_1 &
4138	) * &
4139	( u(k,j+1,i) + u(k,j,i) ) &
4140	- ( 8.0_wp * ibit14 * adv_mom_5 &
4141	+ ibit13 * adv_mom_3 &
4142	) * &
4143	( u(k,j+2,i) + u(k,j-1,i) ) &
4144	+ ( ibit14 * adv_mom_5 &
4145	) * &
4146	( u(k,j+3,i) + u(k,j-2,i) ) &
4147	)
4148
4149	diss_n(k) = - ABS ( v_comp ) * ( &
4150	( 10.0_wp * ibit14 * adv_mom_5 &
4151	+ 3.0_wp * ibit13 * adv_mom_3 &
4152	+ ibit12 * adv_mom_1 &
4153	) * &
4154	( u(k,j+1,i) - u(k,j,i) ) &
4155	- ( 5.0_wp * ibit14 * adv_mom_5 &
4156	+ ibit13 * adv_mom_3 &
4157	) * &
4158	( u(k,j+2,i) - u(k,j-1,i) ) &
4159	+ ( ibit14 * adv_mom_5 &
4160	) * &
4161	( u(k,j+3,i) - u(k,j-2,i) ) &
4162	)
4163	!
4164	!-- k index has to be modified near bottom and top, else array
4165	!-- subscripts will be exceeded.
4166	ibit17 = IBITS(wall_flags_0(k,j,i),17,1)
4167	ibit16 = IBITS(wall_flags_0(k,j,i),16,1)
4168	ibit15 = IBITS(wall_flags_0(k,j,i),15,1)
4169
4170	k_ppp = k + 3 * ibit17
4171	k_pp = k + 2 * ( 1 - ibit15 )
4172	k_mm = k - 2 * ibit17
4173
4174	w_comp = w(k,j,i) + w(k,j,i-1)
4175	flux_t(k) = w_comp * ( &
4176	( 37.0_wp * ibit17 * adv_mom_5 &
4177	+ 7.0_wp * ibit16 * adv_mom_3 &
4178	+ ibit15 * adv_mom_1 &
4179	) * &
4180	( u(k+1,j,i) + u(k,j,i) ) &
4181	- ( 8.0_wp * ibit17 * adv_mom_5 &
4182	+ ibit16 * adv_mom_3 &
4183	) * &
4184	( u(k_pp,j,i) + u(k-1,j,i) ) &
4185	+ ( ibit17 * adv_mom_5 &
4186	) * &
4187	( u(k_ppp,j,i) + u(k_mm,j,i) ) &
4188	)
4189
4190	diss_t(k) = - ABS( w_comp ) * ( &
4191	( 10.0_wp * ibit17 * adv_mom_5 &
4192	+ 3.0_wp * ibit16 * adv_mom_3 &
4193	+ ibit15 * adv_mom_1 &
4194	) * &
4195	( u(k+1,j,i) - u(k,j,i) ) &
4196	- ( 5.0_wp * ibit17 * adv_mom_5 &
4197	+ ibit16 * adv_mom_3 &
4198	) * &
4199	( u(k_pp,j,i) - u(k-1,j,i) ) &
4200	+ ( ibit17 * adv_mom_5 &
4201	) * &
4202	( u(k_ppp,j,i) - u(k_mm,j,i) ) &
4203	)
4204	!
4205	!-- Calculate the divergence of the velocity field. A respective
4206	!-- correction is needed to overcome numerical instabilities caused
4207	!-- by a not sufficient reduction of divergences near topography.
4208	div = ( ( u_comp(k) * ( ibit9 + ibit10 + ibit11 ) &
4209	- ( u(k,j,i) + u(k,j,i-1) ) &
4210	* ( IBITS(wall_flags_0(k,j,i-1),9,1) &
4211	+ IBITS(wall_flags_0(k,j,i-1),10,1) &
4212	+ IBITS(wall_flags_0(k,j,i-1),11,1) &
4213	) &
4214	) * ddx &
4215	+ ( ( v_comp + gv ) * ( ibit12 + ibit13 + ibit14 ) &
4216	- ( v(k,j,i) + v(k,j,i-1 ) ) &
4217	* ( IBITS(wall_flags_0(k,j-1,i),12,1) &
4218	+ IBITS(wall_flags_0(k,j-1,i),13,1) &
4219	+ IBITS(wall_flags_0(k,j-1,i),14,1) &
4220	) &
4221	) * ddy &
4222	+ ( w_comp * ( ibit15 + ibit16 + ibit17 ) &
4223	- ( w(k-1,j,i) + w(k-1,j,i-1) ) &
4224	* ( IBITS(wall_flags_0(k-1,j,i),15,1) &
4225	+ IBITS(wall_flags_0(k-1,j,i),16,1) &
4226	+ IBITS(wall_flags_0(k-1,j,i),17,1) &
4227	) &
4228	) * ddzw(k) &
4229	) * 0.5_wp
4230
4231
4232
4233	tend(k,j,i) = tend(k,j,i) - ( &
4234	( flux_r(k) + diss_r(k) &
4235	- swap_flux_x_local_u(k,j) - swap_diss_x_local_u(k,j) ) * ddx &
4236	+ ( flux_n(k) + diss_n(k) &
4237	- swap_flux_y_local_u(k) - swap_diss_y_local_u(k) ) * ddy &
4238	+ ( flux_t(k) + diss_t(k) &
4239	- flux_d - diss_d &
4240	) * ddzw(k) &
4241	) + div * u(k,j,i)
4242
4243	swap_flux_x_local_u(k,j) = flux_r(k)
4244	swap_diss_x_local_u(k,j) = diss_r(k)
4245	swap_flux_y_local_u(k) = flux_n(k)
4246	swap_diss_y_local_u(k) = diss_n(k)
4247	flux_d = flux_t(k)
4248	diss_d = diss_t(k)
4249	!
4250	!-- Statistical Evaluation of u'u'. The factor has to be applied
4251	!-- for right evaluation when gallilei_trans = .T. .
4252	sums_us2_ws_l(k,tn) = sums_us2_ws_l(k,tn) &
4253	+ ( flux_r(k) * &
4254	( u_comp(k) - 2.0_wp * hom(k,1,1,0) ) &
4255	/ ( u_comp(k) - gu + 1.0E-20_wp ) &
4256	+ diss_r(k) * &
4257	ABS( u_comp(k) - 2.0_wp * hom(k,1,1,0) ) &
4258	/ ( ABS( u_comp(k) - gu ) + 1.0E-20_wp ) ) &
4259	* weight_substep(intermediate_timestep_count)
4260	!
4261	!-- Statistical Evaluation of w'u'.
4262	sums_wsus_ws_l(k,tn) = sums_wsus_ws_l(k,tn) &
4263	+ ( flux_t(k) + diss_t(k) ) &
4264	* weight_substep(intermediate_timestep_count)
4265	ENDDO
4266
4267	DO k = nzb_max+1, nzt
4268
4269	u_comp(k) = u(k,j,i+1) + u(k,j,i)
4270	flux_r(k) = ( u_comp(k) - gu ) * ( &
4271	37.0_wp * ( u(k,j,i+1) + u(k,j,i) ) &
4272	- 8.0_wp * ( u(k,j,i+2) + u(k,j,i-1) ) &
4273	+ ( u(k,j,i+3) + u(k,j,i-2) ) ) * adv_mom_5
4274	diss_r(k) = - ABS( u_comp(k) - gu ) * ( &
4275	10.0_wp * ( u(k,j,i+1) - u(k,j,i) ) &
4276	- 5.0_wp * ( u(k,j,i+2) - u(k,j,i-1) ) &
4277	+ ( u(k,j,i+3) - u(k,j,i-2) ) ) * adv_mom_5
4278
4279	v_comp = v(k,j+1,i) + v(k,j+1,i-1) - gv
4280	flux_n(k) = v_comp * ( &
4281	37.0_wp * ( u(k,j+1,i) + u(k,j,i) ) &
4282	- 8.0_wp * ( u(k,j+2,i) + u(k,j-1,i) ) &
4283	+ ( u(k,j+3,i) + u(k,j-2,i) ) ) * adv_mom_5
4284	diss_n(k) = - ABS( v_comp ) * ( &
4285	10.0_wp * ( u(k,j+1,i) - u(k,j,i) ) &
4286	- 5.0_wp * ( u(k,j+2,i) - u(k,j-1,i) ) &
4287	+ ( u(k,j+3,i) - u(k,j-2,i) ) ) * adv_mom_5
4288	!
4289	!-- k index has to be modified near bottom and top, else array
4290	!-- subscripts will be exceeded.
4291	ibit17 = IBITS(wall_flags_0(k,j,i),17,1)
4292	ibit16 = IBITS(wall_flags_0(k,j,i),16,1)
4293	ibit15 = IBITS(wall_flags_0(k,j,i),15,1)
4294
4295	k_ppp = k + 3 * ibit17
4296	k_pp = k + 2 * ( 1 - ibit15 )
4297	k_mm = k - 2 * ibit17
4298
4299	w_comp = w(k,j,i) + w(k,j,i-1)
4300	flux_t(k) = w_comp * ( &
4301	( 37.0_wp * ibit17 * adv_mom_5 &
4302	+ 7.0_wp * ibit16 * adv_mom_3 &
4303	+ ibit15 * adv_mom_1 &
4304	) * &
4305	( u(k+1,j,i) + u(k,j,i) ) &
4306	- ( 8.0_wp * ibit17 * adv_mom_5 &
4307	+ ibit16 * adv_mom_3 &
4308	) * &
4309	( u(k_pp,j,i) + u(k-1,j,i) ) &
4310	+ ( ibit17 * adv_mom_5 &
4311	) * &
4312	( u(k_ppp,j,i) + u(k_mm,j,i) ) &
4313	)
4314
4315	diss_t(k) = - ABS( w_comp ) * ( &
4316	( 10.0_wp * ibit17 * adv_mom_5 &
4317	+ 3.0_wp * ibit16 * adv_mom_3 &
4318	+ ibit15 * adv_mom_1 &
4319	) * &
4320	( u(k+1,j,i) - u(k,j,i) ) &
4321	- ( 5.0_wp * ibit17 * adv_mom_5 &
4322	+ ibit16 * adv_mom_3 &
4323	) * &
4324	( u(k_pp,j,i) - u(k-1,j,i) ) &
4325	+ ( ibit17 * adv_mom_5 &
4326	) * &
4327	( u(k_ppp,j,i) - u(k_mm,j,i) ) &
4328	)
4329	!
4330	!-- Calculate the divergence of the velocity field. A respective
4331	!-- correction is needed to overcome numerical instabilities caused
4332	!-- by a not sufficient reduction of divergences near topography.
4333	div = ( ( u_comp(k) - ( u(k,j,i) + u(k,j,i-1) ) ) * ddx &
4334	+ ( v_comp + gv - ( v(k,j,i) + v(k,j,i-1 ) ) ) * ddy &
4335	+ ( w_comp - ( w(k-1,j,i) + w(k-1,j,i-1) ) ) &
4336	* ddzw(k) &
4337	) * 0.5_wp
4338
4339	tend(k,j,i) = tend(k,j,i) - ( &
4340	( flux_r(k) + diss_r(k) &
4341	- swap_flux_x_local_u(k,j) - swap_diss_x_local_u(k,j) ) * ddx &
4342	+ ( flux_n(k) + diss_n(k) &
4343	- swap_flux_y_local_u(k) - swap_diss_y_local_u(k) ) * ddy &
4344	+ ( flux_t(k) + diss_t(k) &
4345	- flux_d - diss_d &
4346	) * ddzw(k) &
4347	) + div * u(k,j,i)
4348
4349	swap_flux_x_local_u(k,j) = flux_r(k)
4350	swap_diss_x_local_u(k,j) = diss_r(k)
4351	swap_flux_y_local_u(k) = flux_n(k)
4352	swap_diss_y_local_u(k) = diss_n(k)
4353	flux_d = flux_t(k)
4354	diss_d = diss_t(k)
4355	!
4356	!-- Statistical Evaluation of u'u'. The factor has to be applied
4357	!-- for right evaluation when gallilei_trans = .T. .
4358	sums_us2_ws_l(k,tn) = sums_us2_ws_l(k,tn) &
4359	+ ( flux_r(k) * &
4360	( u_comp(k) - 2.0_wp * hom(k,1,1,0) ) &
4361	/ ( u_comp(k) - gu + 1.0E-20_wp ) &
4362	+ diss_r(k) * &
4363	ABS( u_comp(k) - 2.0_wp * hom(k,1,1,0) ) &
4364	/ ( ABS( u_comp(k) - gu ) + 1.0E-20_wp ) ) &
4365	* weight_substep(intermediate_timestep_count)
4366	!
4367	!-- Statistical Evaluation of w'u'.
4368	sums_wsus_ws_l(k,tn) = sums_wsus_ws_l(k,tn) &
4369	+ ( flux_t(k) + diss_t(k) ) &
4370	* weight_substep(intermediate_timestep_count)
4371	ENDDO
4372	ENDDO
4373	ENDDO
4374	sums_us2_ws_l(nzb,tn) = sums_us2_ws_l(nzb+1,tn)
4375
4376
4377	END SUBROUTINE advec_u_ws
4378
4379
4380	!------------------------------------------------------------------------------!
4381	! Advection of u - Call for all grid points - accelerator version
4382	!------------------------------------------------------------------------------!
4383	SUBROUTINE advec_u_ws_acc
4384
4385	USE arrays_3d, &
4386	ONLY: ddzw, tend, u, v, w
4387
4388	USE constants, &
4389	ONLY: adv_mom_1, adv_mom_3, adv_mom_5
4390
4391	USE control_parameters, &
4392	ONLY: intermediate_timestep_count, u_gtrans, v_gtrans
4393
4394	USE grid_variables, &
4395	ONLY: ddx, ddy
4396
4397	USE indices, &
4398	ONLY: i_left, i_right, j_north, j_south, nxl, nxr, nyn, nys, nzb, &
4399	nzb_max, nzt, wall_flags_0
4400
4401	USE kinds
4402
4403	! USE statistics, &
4404	! ONLY: hom, sums_us2_ws_l, sums_wsus_ws_l, weight_substep
4405
4406	IMPLICIT NONE
4407
4408	INTEGER(iwp) :: i !:
4409	INTEGER(iwp) :: ibit9 !:
4410	INTEGER(iwp) :: ibit10 !:
4411	INTEGER(iwp) :: ibit11 !:
4412	INTEGER(iwp) :: ibit12 !:
4413	INTEGER(iwp) :: ibit13 !:
4414	INTEGER(iwp) :: ibit14 !:
4415	INTEGER(iwp) :: ibit15 !:
4416	INTEGER(iwp) :: ibit16 !:
4417	INTEGER(iwp) :: ibit17 !:
4418	INTEGER(iwp) :: j !:
4419	INTEGER(iwp) :: k !:
4420	INTEGER(iwp) :: k_mmm !:
4421	INTEGER(iwp) :: k_mm !:
4422	INTEGER(iwp) :: k_pp !:
4423	INTEGER(iwp) :: k_ppp !:
4424	INTEGER(iwp) :: tn = 0 !:
4425
4426	REAL(wp) :: diss_d !:
4427	REAL(wp) :: diss_l !:
4428	REAL(wp) :: diss_n !:
4429	REAL(wp) :: diss_r !:
4430	REAL(wp) :: diss_s !:
4431	REAL(wp) :: diss_t !:
4432	REAL(wp) :: div !:
4433	REAL(wp) :: flux_d !:
4434	REAL(wp) :: flux_l !:
4435	REAL(wp) :: flux_n !:
4436	REAL(wp) :: flux_r !:
4437	REAL(wp) :: flux_s !:
4438	REAL(wp) :: flux_t !:
4439	REAL(wp) :: gu !:
4440	REAL(wp) :: gv !:
4441	REAL(wp) :: u_comp !:
4442	REAL(wp) :: u_comp_l !:
4443	REAL(wp) :: v_comp !:
4444	REAL(wp) :: v_comp_s !:
4445	REAL(wp) :: w_comp !:
4446
4447
4448	gu = 2.0_wp * u_gtrans
4449	gv = 2.0_wp * v_gtrans
4450
4451	!
4452	!-- Computation of fluxes and tendency terms
4453	!$acc kernels present( ddzw, tend, u, v, w, wall_flags_0 )
4454	DO i = i_left, i_right
4455	DO j = j_south, j_north
4456	DO k = nzb+1, nzt
4457
4458	ibit11 = IBITS(wall_flags_0(k,j,i-1),11,1)
4459	ibit10 = IBITS(wall_flags_0(k,j,i-1),10,1)
4460	ibit9 = IBITS(wall_flags_0(k,j,i-1),9,1)
4461
4462	u_comp_l = u(k,j,i) + u(k,j,i-1) - gu
4463	flux_l = u_comp_l * ( &
4464	( 37.0_wp * ibit11 * adv_mom_5 &
4465	+ 7.0_wp * ibit10 * adv_mom_3 &
4466	+ ibit9 * adv_mom_1 &
4467	) * &
4468	( u(k,j,i) + u(k,j,i-1) ) &
4469	- ( 8.0_wp * ibit11 * adv_mom_5 &
4470	+ ibit10 * adv_mom_3 &
4471	) * &
4472	( u(k,j,i+1) + u(k,j,i-2) ) &
4473	+ ( ibit11 * adv_mom_5 &
4474	) * &
4475	( u(k,j,i+2) + u(k,j,i-3) ) &
4476	)
4477
4478	diss_l = - ABS( u_comp_l ) * ( &
4479	( 10.0_wp * ibit11 * adv_mom_5 &
4480	+ 3.0_wp * ibit10 * adv_mom_3 &
4481	+ ibit9 * adv_mom_1 &
4482	) * &
4483	( u(k,j,i) - u(k,j,i-1) ) &
4484	- ( 5.0_wp * ibit11 * adv_mom_5 &
4485	+ ibit10 * adv_mom_3 &
4486	) * &
4487	( u(k,j,i+1) - u(k,j,i-2) ) &
4488	+ ( ibit11 * adv_mom_5 &
4489	) * &
4490	( u(k,j,i+2) - u(k,j,i-3) ) &
4491	)
4492
4493	ibit11 = IBITS(wall_flags_0(k,j,i),11,1)
4494	ibit10 = IBITS(wall_flags_0(k,j,i),10,1)
4495	ibit9 = IBITS(wall_flags_0(k,j,i),9,1)
4496
4497	u_comp = u(k,j,i+1) + u(k,j,i)
4498	flux_r = ( u_comp - gu ) * ( &
4499	( 37.0_wp * ibit11 * adv_mom_5 &
4500	+ 7.0_wp * ibit10 * adv_mom_3 &
4501	+ ibit9 * adv_mom_1 &
4502	) * &
4503	( u(k,j,i+1) + u(k,j,i) ) &
4504	- ( 8.0_wp * ibit11 * adv_mom_5 &
4505	+ ibit10 * adv_mom_3 &
4506	) * &
4507	( u(k,j,i+2) + u(k,j,i-1) ) &
4508	+ ( ibit11 * adv_mom_5 &
4509	) * &
4510	( u(k,j,i+3) + u(k,j,i-2) ) &
4511	)
4512
4513	diss_r = - ABS( u_comp - gu ) * ( &
4514	( 10.0_wp * ibit11 * adv_mom_5 &
4515	+ 3.0_wp * ibit10 * adv_mom_3 &
4516	+ ibit9 * adv_mom_1 &
4517	) * &
4518	( u(k,j,i+1) - u(k,j,i) ) &
4519	- ( 5.0_wp * ibit11 * adv_mom_5 &
4520	+ ibit10 * adv_mom_3 &
4521	) * &
4522	( u(k,j,i+2) - u(k,j,i-1) ) &
4523	+ ( ibit11 * adv_mom_5 &
4524	) * &
4525	( u(k,j,i+3) - u(k,j,i-2) ) &
4526	)
4527
4528	ibit14 = IBITS(wall_flags_0(k,j-1,i),14,1)
4529	ibit13 = IBITS(wall_flags_0(k,j-1,i),13,1)
4530	ibit12 = IBITS(wall_flags_0(k,j-1,i),12,1)
4531
4532	v_comp_s = v(k,j,i) + v(k,j,i-1) - gv
4533	flux_s = v_comp_s * ( &
4534	( 37.0_wp * ibit14 * adv_mom_5 &
4535	+ 7.0_wp * ibit13 * adv_mom_3 &
4536	+ ibit12 * adv_mom_1 &
4537	) * &
4538	( u(k,j,i) + u(k,j-1,i) ) &
4539	- ( 8.0_wp * ibit14 * adv_mom_5 &
4540	+ ibit13 * adv_mom_3 &
4541	) * &
4542	( u(k,j+1,i) + u(k,j-2,i) ) &
4543	+ ( ibit14 * adv_mom_5 &
4544	) * &
4545	( u(k,j+2,i) + u(k,j-3,i) ) &
4546	)
4547
4548	diss_s = - ABS ( v_comp_s ) * ( &
4549	( 10.0_wp * ibit14 * adv_mom_5 &
4550	+ 3.0_wp * ibit13 * adv_mom_3 &
4551	+ ibit12 * adv_mom_1 &
4552	) * &
4553	( u(k,j,i) - u(k,j-1,i) ) &
4554	- ( 5.0_wp * ibit14 * adv_mom_5 &
4555	+ ibit13 * adv_mom_3 &
4556	) * &
4557	( u(k,j+1,i) - u(k,j-2,i) ) &
4558	+ ( ibit14 * adv_mom_5 &
4559	) * &
4560	( u(k,j+2,i) - u(k,j-3,i) ) &
4561	)
4562
4563
4564	ibit14 = IBITS(wall_flags_0(k,j,i),14,1)
4565	ibit13 = IBITS(wall_flags_0(k,j,i),13,1)
4566	ibit12 = IBITS(wall_flags_0(k,j,i),12,1)
4567
4568	v_comp = v(k,j+1,i) + v(k,j+1,i-1) - gv
4569	flux_n = v_comp * ( &
4570	( 37.0_wp * ibit14 * adv_mom_5 &
4571	+ 7.0_wp * ibit13 * adv_mom_3 &
4572	+ ibit12 * adv_mom_1 &
4573	) * &
4574	( u(k,j+1,i) + u(k,j,i) ) &
4575	- ( 8.0_wp * ibit14 * adv_mom_5 &
4576	+ ibit13 * adv_mom_3 &
4577	) * &
4578	( u(k,j+2,i) + u(k,j-1,i) ) &
4579	+ ( ibit14 * adv_mom_5 &
4580	) * &
4581	( u(k,j+3,i) + u(k,j-2,i) ) &
4582	)
4583
4584	diss_n = - ABS ( v_comp ) * ( &
4585	( 10.0_wp * ibit14 * adv_mom_5 &
4586	+ 3.0_wp * ibit13 * adv_mom_3 &
4587	+ ibit12 * adv_mom_1 &
4588	) * &
4589	( u(k,j+1,i) - u(k,j,i) ) &
4590	- ( 5.0_wp * ibit14 * adv_mom_5 &
4591	+ ibit13 * adv_mom_3 &
4592	) * &
4593	( u(k,j+2,i) - u(k,j-1,i) ) &
4594	+ ( ibit14 * adv_mom_5 &
4595	) * &
4596	( u(k,j+3,i) - u(k,j-2,i) ) &
4597	)
4598
4599	ibit17 = IBITS(wall_flags_0(k-1,j,i),17,1)
4600	ibit16 = IBITS(wall_flags_0(k-1,j,i),16,1)
4601	ibit15 = IBITS(wall_flags_0(k-1,j,i),15,1)
4602
4603	k_pp = k + 2 * ibit17
4604	k_mm = k - 2 * ( ibit16 + ibit17 )
4605	k_mmm = k - 3 * ibit17
4606
4607	w_comp = w(k-1,j,i) + w(k-1,j,i-1)
4608	flux_d = w_comp * ( &
4609	( 37.0_wp * ibit17 * adv_mom_5 &
4610	+ 7.0_wp * ibit16 * adv_mom_3 &
4611	+ ibit15 * adv_mom_1 &
4612	) * &
4613	( u(k,j,i) + u(k-1,j,i) ) &
4614	- ( 8.0_wp * ibit17 * adv_mom_5 &
4615	+ ibit16 * adv_mom_3 &
4616	) * &
4617	( u(k+1,j,i) + u(k_mm,j,i) ) &
4618	+ ( ibit17 * adv_mom_5 &
4619	) * &
4620	( u(k_pp,j,i) + u(k_mmm,j,i) ) &
4621	)
4622
4623	diss_d = - ABS( w_comp ) * ( &
4624	( 10.0_wp * ibit17 * adv_mom_5 &
4625	+ 3.0_wp * ibit16 * adv_mom_3 &
4626	+ ibit15 * adv_mom_1 &
4627	) * &
4628	( u(k,j,i) - u(k-1,j,i) ) &
4629	- ( 5.0_wp * ibit17 * adv_mom_5 &
4630	+ ibit16 * adv_mom_3 &
4631	) * &
4632	( u(k+1,j,i) - u(k_mm,j,i) ) &
4633	+ ( ibit17 * adv_mom_5 &
4634	) * &
4635	( u(k_pp,j,i) - u(k_mmm,j,i) ) &
4636	)
4637	!
4638	!-- k index has to be modified near bottom and top, else array
4639	!-- subscripts will be exceeded.
4640	ibit17 = IBITS(wall_flags_0(k,j,i),17,1)
4641	ibit16 = IBITS(wall_flags_0(k,j,i),16,1)
4642	ibit15 = IBITS(wall_flags_0(k,j,i),15,1)
4643
4644	k_ppp = k + 3 * ibit17
4645	k_pp = k + 2 * ( 1 - ibit15 )
4646	k_mm = k - 2 * ibit17
4647
4648	w_comp = w(k,j,i) + w(k,j,i-1)
4649	flux_t = w_comp * ( &
4650	( 37.0_wp * ibit17 * adv_mom_5 &
4651	+ 7.0_wp * ibit16 * adv_mom_3 &
4652	+ ibit15 * adv_mom_1 &
4653	) * &
4654	( u(k+1,j,i) + u(k,j,i) ) &
4655	- ( 8.0_wp * ibit17 * adv_mom_5 &
4656	+ ibit16 * adv_mom_3 &
4657	) * &
4658	( u(k_pp,j,i) + u(k-1,j,i) ) &
4659	+ ( ibit17 * adv_mom_5 &
4660	) * &
4661	( u(k_ppp,j,i) + u(k_mm,j,i) ) &
4662	)
4663
4664	diss_t = - ABS( w_comp ) * ( &
4665	( 10.0_wp * ibit17 * adv_mom_5 &
4666	+ 3.0_wp * ibit16 * adv_mom_3 &
4667	+ ibit15 * adv_mom_1 &
4668	) * &
4669	( u(k+1,j,i) - u(k,j,i) ) &
4670	- ( 5.0_wp * ibit17 * adv_mom_5 &
4671	+ ibit16 * adv_mom_3 &
4672	) * &
4673	( u(k_pp,j,i) - u(k-1,j,i) ) &
4674	+ ( ibit17 * adv_mom_5 &
4675	) * &
4676	( u(k_ppp,j,i) - u(k_mm,j,i) ) &
4677	)
4678	!
4679	!-- Calculate the divergence of the velocity field. A respective
4680	!-- correction is needed to overcome numerical instabilities caused
4681	!-- by a not sufficient reduction of divergences near topography.
4682	div = ( ( u_comp * ( ibit9 + ibit10 + ibit11 ) &
4683	- ( u(k,j,i) + u(k,j,i-1) ) &
4684	* ( IBITS(wall_flags_0(k,j,i-1),9,1) &
4685	+ IBITS(wall_flags_0(k,j,i-1),10,1) &
4686	+ IBITS(wall_flags_0(k,j,i-1),11,1) &
4687	) &
4688	) * ddx &
4689	+ ( ( v_comp + gv ) * ( ibit12 + ibit13 + ibit14 ) &
4690	- ( v(k,j,i) + v(k,j,i-1 ) ) &
4691	* ( IBITS(wall_flags_0(k,j-1,i),12,1) &
4692	+ IBITS(wall_flags_0(k,j-1,i),13,1) &
4693	+ IBITS(wall_flags_0(k,j-1,i),14,1) &
4694	) &
4695	) * ddy &
4696	+ ( w_comp * ( ibit15 + ibit16 + ibit17 ) &
4697	- ( w(k-1,j,i) + w(k-1,j,i-1) ) &
4698	* ( IBITS(wall_flags_0(k-1,j,i),15,1) &
4699	+ IBITS(wall_flags_0(k-1,j,i),16,1) &
4700	+ IBITS(wall_flags_0(k-1,j,i),17,1) &
4701	) &
4702	) * ddzw(k) &
4703	) * 0.5_wp
4704
4705
4706	tend(k,j,i) = - ( &
4707	( flux_r + diss_r - flux_l - diss_l ) * ddx &
4708	+ ( flux_n + diss_n - flux_s - diss_s ) * ddy &
4709	+ ( flux_t + diss_t - flux_d - diss_d ) * ddzw(k) &
4710	) + div * u(k,j,i)
4711
4712	!++
4713	!-- Statistical Evaluation of u'u'. The factor has to be applied
4714	!-- for right evaluation when gallilei_trans = .T. .
4715	! sums_us2_ws_l(k,tn) = sums_us2_ws_l(k,tn) &
4716	! + ( flux_r * &
4717	! ( u_comp - 2.0_wp * hom(k,1,1,0) ) &
4718	! / ( u_comp - gu + 1.0E-20_wp ) &
4719	! + diss_r * &
4720	! ABS( u_comp - 2.0_wp * hom(k,1,1,0) ) &
4721	! / ( ABS( u_comp - gu ) + 1.0E-20_wp ) ) &
4722	! * weight_substep(intermediate_timestep_count)
4723	!
4724	!-- Statistical Evaluation of w'u'.
4725	! sums_wsus_ws_l(k,tn) = sums_wsus_ws_l(k,tn) &
4726	! + ( flux_t + diss_t ) &
4727	! * weight_substep(intermediate_timestep_count)
4728	ENDDO
4729	ENDDO
4730	ENDDO
4731	!$acc end kernels
4732
4733	!++
4734	! sums_us2_ws_l(nzb,tn) = sums_us2_ws_l(nzb+1,tn)
4735
4736	END SUBROUTINE advec_u_ws_acc
4737
4738
4739	!------------------------------------------------------------------------------!
4740	! Advection of v - Call for all grid points
4741	!------------------------------------------------------------------------------!
4742	SUBROUTINE advec_v_ws
4743
4744	USE arrays_3d, &
4745	ONLY: ddzw, tend, u, v, w
4746
4747	USE constants, &
4748	ONLY: adv_mom_1, adv_mom_3, adv_mom_5
4749
4750	USE control_parameters, &
4751	ONLY: intermediate_timestep_count, u_gtrans, v_gtrans
4752
4753	USE grid_variables, &
4754	ONLY: ddx, ddy
4755
4756	USE indices, &
4757	ONLY: nxl, nxr, nyn, nys, nysv, nzb, nzb_max, nzt, wall_flags_0
4758
4759	USE kinds
4760
4761	USE statistics, &
4762	ONLY: hom, sums_vs2_ws_l, sums_wsvs_ws_l, weight_substep
4763
4764	IMPLICIT NONE
4765
4766
4767	INTEGER(iwp) :: i !:
4768	INTEGER(iwp) :: ibit18 !:
4769	INTEGER(iwp) :: ibit19 !:
4770	INTEGER(iwp) :: ibit20 !:
4771	INTEGER(iwp) :: ibit21 !:
4772	INTEGER(iwp) :: ibit22 !:
4773	INTEGER(iwp) :: ibit23 !:
4774	INTEGER(iwp) :: ibit24 !:
4775	INTEGER(iwp) :: ibit25 !:
4776	INTEGER(iwp) :: ibit26 !:
4777	INTEGER(iwp) :: j !:
4778	INTEGER(iwp) :: k !:
4779	INTEGER(iwp) :: k_mm !:
4780	INTEGER(iwp) :: k_pp !:
4781	INTEGER(iwp) :: k_ppp !:
4782	INTEGER(iwp) :: tn = 0 !:
4783
4784	REAL(wp) :: diss_d !:
4785	REAL(wp) :: div !:
4786	REAL(wp) :: flux_d !:
4787	REAL(wp) :: gu !:
4788	REAL(wp) :: gv !:
4789	REAL(wp) :: u_comp !:
4790	REAL(wp) :: w_comp !:
4791
4792	REAL(wp), DIMENSION(nzb+1:nzt) :: swap_diss_y_local_v !:
4793	REAL(wp), DIMENSION(nzb+1:nzt) :: swap_flux_y_local_v !:
4794
4795	REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn) :: swap_diss_x_local_v !:
4796	REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn) :: swap_flux_x_local_v !:
4797
4798	REAL(wp), DIMENSION(nzb:nzt) :: diss_n !:
4799	REAL(wp), DIMENSION(nzb:nzt) :: diss_r !:
4800	REAL(wp), DIMENSION(nzb:nzt) :: diss_t !:
4801	REAL(wp), DIMENSION(nzb:nzt) :: flux_n !:
4802	REAL(wp), DIMENSION(nzb:nzt) :: flux_r !:
4803	REAL(wp), DIMENSION(nzb:nzt) :: flux_t !:
4804	REAL(wp), DIMENSION(nzb:nzt) :: v_comp !:
4805
4806	gu = 2.0_wp * u_gtrans
4807	gv = 2.0_wp * v_gtrans
4808	!
4809	!-- First compute the whole left boundary of the processor domain
4810	i = nxl
4811	DO j = nysv, nyn
4812	DO k = nzb+1, nzb_max
4813
4814	ibit20 = IBITS(wall_flags_0(k,j,i-1),20,1)
4815	ibit19 = IBITS(wall_flags_0(k,j,i-1),19,1)
4816	ibit18 = IBITS(wall_flags_0(k,j,i-1),18,1)
4817
4818	u_comp = u(k,j-1,i) + u(k,j,i) - gu
4819	swap_flux_x_local_v(k,j) = u_comp * ( &
4820	( 37.0_wp * ibit20 * adv_mom_5 &
4821	+ 7.0_wp * ibit19 * adv_mom_3 &
4822	+ ibit18 * adv_mom_1 &
4823	) * &
4824	( v(k,j,i) + v(k,j,i-1) ) &
4825	- ( 8.0_wp * ibit20 * adv_mom_5 &
4826	+ ibit19 * adv_mom_3 &
4827	) * &
4828	( v(k,j,i+1) + v(k,j,i-2) ) &
4829	+ ( ibit20 * adv_mom_5 &
4830	) * &
4831	( v(k,j,i+2) + v(k,j,i-3) ) &
4832	)
4833
4834	swap_diss_x_local_v(k,j) = - ABS( u_comp ) * ( &
4835	( 10.0_wp * ibit20 * adv_mom_5 &
4836	+ 3.0_wp * ibit19 * adv_mom_3 &
4837	+ ibit18 * adv_mom_1 &
4838	) * &
4839	( v(k,j,i) - v(k,j,i-1) ) &
4840	- ( 5.0_wp * ibit20 * adv_mom_5 &
4841	+ ibit19 * adv_mom_3 &
4842	) * &
4843	( v(k,j,i+1) - v(k,j,i-2) ) &
4844	+ ( ibit20 * adv_mom_5 &
4845	) * &
4846	( v(k,j,i+2) - v(k,j,i-3) ) &
4847	)
4848
4849	ENDDO
4850
4851	DO k = nzb_max+1, nzt
4852
4853	u_comp = u(k,j-1,i) + u(k,j,i) - gu
4854	swap_flux_x_local_v(k,j) = u_comp * ( &
4855	37.0_wp * ( v(k,j,i) + v(k,j,i-1) ) &
4856	- 8.0_wp * ( v(k,j,i+1) + v(k,j,i-2) ) &
4857	+ ( v(k,j,i+2) + v(k,j,i-3) ) ) * adv_mom_5
4858	swap_diss_x_local_v(k,j) = - ABS( u_comp ) * ( &
4859	10.0_wp * ( v(k,j,i) - v(k,j,i-1) ) &
4860	- 5.0_wp * ( v(k,j,i+1) - v(k,j,i-2) ) &
4861	+ ( v(k,j,i+2) - v(k,j,i-3) ) ) * adv_mom_5
4862
4863	ENDDO
4864
4865	ENDDO
4866
4867	DO i = nxl, nxr
4868
4869	j = nysv
4870	DO k = nzb+1, nzb_max
4871
4872	ibit23 = IBITS(wall_flags_0(k,j-1,i),23,1)
4873	ibit22 = IBITS(wall_flags_0(k,j-1,i),22,1)
4874	ibit21 = IBITS(wall_flags_0(k,j-1,i),21,1)
4875
4876	v_comp(k) = v(k,j,i) + v(k,j-1,i) - gv
4877	swap_flux_y_local_v(k) = v_comp(k) * ( &
4878	( 37.0_wp * ibit23 * adv_mom_5 &
4879	+ 7.0_wp * ibit22 * adv_mom_3 &
4880	+ ibit21 * adv_mom_1 &
4881	) * &
4882	( v(k,j,i) + v(k,j-1,i) ) &
4883	- ( 8.0_wp * ibit23 * adv_mom_5 &
4884	+ ibit22 * adv_mom_3 &
4885	) * &
4886	( v(k,j+1,i) + v(k,j-2,i) ) &
4887	+ ( ibit23 * adv_mom_5 &
4888	) * &
4889	( v(k,j+2,i) + v(k,j-3,i) ) &
4890	)
4891
4892	swap_diss_y_local_v(k) = - ABS( v_comp(k) ) * ( &
4893	( 10.0_wp * ibit23 * adv_mom_5 &
4894	+ 3.0_wp * ibit22 * adv_mom_3 &
4895	+ ibit21 * adv_mom_1 &
4896	) * &
4897	( v(k,j,i) - v(k,j-1,i) ) &
4898	- ( 5.0_wp * ibit23 * adv_mom_5 &
4899	+ ibit22 * adv_mom_3 &
4900	) * &
4901	( v(k,j+1,i) - v(k,j-2,i) ) &
4902	+ ( ibit23 * adv_mom_5 &
4903	) * &
4904	( v(k,j+2,i) - v(k,j-3,i) ) &
4905	)
4906
4907	ENDDO
4908
4909	DO k = nzb_max+1, nzt
4910
4911	v_comp(k) = v(k,j,i) + v(k,j-1,i) - gv
4912	swap_flux_y_local_v(k) = v_comp(k) * ( &
4913	37.0_wp * ( v(k,j,i) + v(k,j-1,i) ) &
4914	- 8.0_wp * ( v(k,j+1,i) + v(k,j-2,i) ) &
4915	+ ( v(k,j+2,i) + v(k,j-3,i) ) ) * adv_mom_5
4916	swap_diss_y_local_v(k) = - ABS( v_comp(k) ) * ( &
4917	10.0_wp * ( v(k,j,i) - v(k,j-1,i) ) &
4918	- 5.0_wp * ( v(k,j+1,i) - v(k,j-2,i) ) &
4919	+ ( v(k,j+2,i) - v(k,j-3,i) ) ) * adv_mom_5
4920
4921	ENDDO
4922
4923	DO j = nysv, nyn
4924
4925	flux_t(0) = 0.0_wp
4926	diss_t(0) = 0.0_wp
4927	flux_d = 0.0_wp
4928	diss_d = 0.0_wp
4929
4930	DO k = nzb+1, nzb_max
4931
4932	ibit20 = IBITS(wall_flags_0(k,j,i),20,1)
4933	ibit19 = IBITS(wall_flags_0(k,j,i),19,1)
4934	ibit18 = IBITS(wall_flags_0(k,j,i),18,1)
4935
4936	u_comp = u(k,j-1,i+1) + u(k,j,i+1) - gu
4937	flux_r(k) = u_comp * ( &
4938	( 37.0_wp * ibit20 * adv_mom_5 &
4939	+ 7.0_wp * ibit19 * adv_mom_3 &
4940	+ ibit18 * adv_mom_1 &
4941	) * &
4942	( v(k,j,i+1) + v(k,j,i) ) &
4943	- ( 8.0_wp * ibit20 * adv_mom_5 &
4944	+ ibit19 * adv_mom_3 &
4945	) * &
4946	( v(k,j,i+2) + v(k,j,i-1) ) &
4947	+ ( ibit20 * adv_mom_5 &
4948	) * &
4949	( v(k,j,i+3) + v(k,j,i-2) ) &
4950	)
4951
4952	diss_r(k) = - ABS( u_comp ) * ( &
4953	( 10.0_wp * ibit20 * adv_mom_5 &
4954	+ 3.0_wp * ibit19 * adv_mom_3 &
4955	+ ibit18 * adv_mom_1 &
4956	) * &
4957	( v(k,j,i+1) - v(k,j,i) ) &
4958	- ( 5.0_wp * ibit20 * adv_mom_5 &
4959	+ ibit19 * adv_mom_3 &
4960	) * &
4961	( v(k,j,i+2) - v(k,j,i-1) ) &
4962	+ ( ibit20 * adv_mom_5 &
4963	) * &
4964	( v(k,j,i+3) - v(k,j,i-2) ) &
4965	)
4966
4967	ibit23 = IBITS(wall_flags_0(k,j,i),23,1)
4968	ibit22 = IBITS(wall_flags_0(k,j,i),22,1)
4969	ibit21 = IBITS(wall_flags_0(k,j,i),21,1)
4970
4971	v_comp(k) = v(k,j+1,i) + v(k,j,i)
4972	flux_n(k) = ( v_comp(k) - gv ) * ( &
4973	( 37.0_wp * ibit23 * adv_mom_5 &
4974	+ 7.0_wp * ibit22 * adv_mom_3 &
4975	+ ibit21 * adv_mom_1 &
4976	) * &
4977	( v(k,j+1,i) + v(k,j,i) ) &
4978	- ( 8.0_wp * ibit23 * adv_mom_5 &
4979	+ ibit22 * adv_mom_3 &
4980	) * &
4981	( v(k,j+2,i) + v(k,j-1,i) ) &
4982	+ ( ibit23 * adv_mom_5 &
4983	) * &
4984	( v(k,j+3,i) + v(k,j-2,i) ) &
4985	)
4986
4987	diss_n(k) = - ABS( v_comp(k) - gv ) * ( &
4988	( 10.0_wp * ibit23 * adv_mom_5 &
4989	+ 3.0_wp * ibit22 * adv_mom_3 &
4990	+ ibit21 * adv_mom_1 &
4991	) * &
4992	( v(k,j+1,i) - v(k,j,i) ) &
4993	- ( 5.0_wp * ibit23 * adv_mom_5 &
4994	+ ibit22 * adv_mom_3 &
4995	) * &
4996	( v(k,j+2,i) - v(k,j-1,i) ) &
4997	+ ( ibit23 * adv_mom_5 &
4998	) * &
4999	( v(k,j+3,i) - v(k,j-2,i) ) &
5000	)
5001	!
5002	!-- k index has to be modified near bottom and top, else array
5003	!-- subscripts will be exceeded.
5004	ibit26 = IBITS(wall_flags_0(k,j,i),26,1)
5005	ibit25 = IBITS(wall_flags_0(k,j,i),25,1)
5006	ibit24 = IBITS(wall_flags_0(k,j,i),24,1)
5007
5008	k_ppp = k + 3 * ibit26
5009	k_pp = k + 2 * ( 1 - ibit24 )
5010	k_mm = k - 2 * ibit26
5011
5012	w_comp = w(k,j-1,i) + w(k,j,i)
5013	flux_t(k) = w_comp * ( &
5014	( 37.0_wp * ibit26 * adv_mom_5 &
5015	+ 7.0_wp * ibit25 * adv_mom_3 &
5016	+ ibit24 * adv_mom_1 &
5017	) * &
5018	( v(k+1,j,i) + v(k,j,i) ) &
5019	- ( 8.0_wp * ibit26 * adv_mom_5 &
5020	+ ibit25 * adv_mom_3 &
5021	) * &
5022	( v(k_pp,j,i) + v(k-1,j,i) ) &
5023	+ ( ibit26 * adv_mom_5 &
5024	) * &
5025	( v(k_ppp,j,i) + v(k_mm,j,i) ) &
5026	)
5027
5028	diss_t(k) = - ABS( w_comp ) * ( &
5029	( 10.0_wp * ibit26 * adv_mom_5 &
5030	+ 3.0_wp * ibit25 * adv_mom_3 &
5031	+ ibit24 * adv_mom_1 &
5032	) * &
5033	( v(k+1,j,i) - v(k,j,i) ) &
5034	- ( 5.0_wp * ibit26 * adv_mom_5 &
5035	+ ibit25 * adv_mom_3 &
5036	) * &
5037	( v(k_pp,j,i) - v(k-1,j,i) ) &
5038	+ ( ibit26 * adv_mom_5 &
5039	) * &
5040	( v(k_ppp,j,i) - v(k_mm,j,i) ) &
5041	)
5042	!
5043	!-- Calculate the divergence of the velocity field. A respective
5044	!-- correction is needed to overcome numerical instabilities caused
5045	!-- by a not sufficient reduction of divergences near topography.
5046	div = ( ( ( u_comp + gu ) &
5047	* ( ibit18 + ibit19 + ibit20 ) &
5048	- ( u(k,j-1,i) + u(k,j,i) ) &
5049	* ( IBITS(wall_flags_0(k,j,i-1),18,1) &
5050	+ IBITS(wall_flags_0(k,j,i-1),19,1) &
5051	+ IBITS(wall_flags_0(k,j,i-1),20,1) &
5052	) &
5053	) * ddx &
5054	+ ( v_comp(k) &
5055	* ( ibit21 + ibit22 + ibit23 ) &
5056	- ( v(k,j,i) + v(k,j-1,i) ) &
5057	* ( IBITS(wall_flags_0(k,j-1,i),21,1) &
5058	+ IBITS(wall_flags_0(k,j-1,i),22,1) &
5059	+ IBITS(wall_flags_0(k,j-1,i),23,1) &
5060	) &
5061	) * ddy &
5062	+ ( w_comp &
5063	* ( ibit24 + ibit25 + ibit26 ) &
5064	- ( w(k-1,j-1,i) + w(k-1,j,i) ) &
5065	* ( IBITS(wall_flags_0(k-1,j,i),24,1) &
5066	+ IBITS(wall_flags_0(k-1,j,i),25,1) &
5067	+ IBITS(wall_flags_0(k-1,j,i),26,1) &
5068	) &
5069	) * ddzw(k) &
5070	) * 0.5_wp
5071
5072
5073	tend(k,j,i) = tend(k,j,i) - ( &
5074	( flux_r(k) + diss_r(k) &
5075	- swap_flux_x_local_v(k,j) - swap_diss_x_local_v(k,j) &
5076	) * ddx &
5077	+ ( flux_n(k) + diss_n(k) &
5078	- swap_flux_y_local_v(k) - swap_diss_y_local_v(k) &
5079	) * ddy &
5080	+ ( flux_t(k) + diss_t(k) &
5081	- flux_d - diss_d &
5082	) * ddzw(k) &
5083	) + v(k,j,i) * div
5084
5085	swap_flux_x_local_v(k,j) = flux_r(k)
5086	swap_diss_x_local_v(k,j) = diss_r(k)
5087	swap_flux_y_local_v(k) = flux_n(k)
5088	swap_diss_y_local_v(k) = diss_n(k)
5089	flux_d = flux_t(k)
5090	diss_d = diss_t(k)
5091
5092	!
5093	!-- Statistical Evaluation of v'v'. The factor has to be applied
5094	!-- for right evaluation when gallilei_trans = .T. .
5095	sums_vs2_ws_l(k,tn) = sums_vs2_ws_l(k,tn) &
5096	+ ( flux_n(k) &
5097	* ( v_comp(k) - 2.0_wp * hom(k,1,2,0) ) &
5098	/ ( v_comp(k) - gv + 1.0E-20_wp ) &
5099	+ diss_n(k) &
5100	* ABS( v_comp(k) - 2.0_wp * hom(k,1,2,0) ) &
5101	/ ( ABS( v_comp(k) - gv ) +1.0E-20_wp ) ) &
5102	* weight_substep(intermediate_timestep_count)
5103	!
5104	!-- Statistical Evaluation of w'v'.
5105	sums_wsvs_ws_l(k,tn) = sums_wsvs_ws_l(k,tn) &
5106	+ ( flux_t(k) + diss_t(k) ) &
5107	* weight_substep(intermediate_timestep_count)
5108
5109	ENDDO
5110
5111	DO k = nzb_max+1, nzt
5112
5113	u_comp = u(k,j-1,i+1) + u(k,j,i+1) - gu
5114	flux_r(k) = u_comp * ( &
5115	37.0_wp * ( v(k,j,i+1) + v(k,j,i) ) &
5116	- 8.0_wp * ( v(k,j,i+2) + v(k,j,i-1) ) &
5117	+ ( v(k,j,i+3) + v(k,j,i-2) ) ) * adv_mom_5
5118
5119	diss_r(k) = - ABS( u_comp ) * ( &
5120	10.0_wp * ( v(k,j,i+1) - v(k,j,i) ) &
5121	- 5.0_wp * ( v(k,j,i+2) - v(k,j,i-1) ) &
5122	+ ( v(k,j,i+3) - v(k,j,i-2) ) ) * adv_mom_5
5123
5124
5125	v_comp(k) = v(k,j+1,i) + v(k,j,i)
5126	flux_n(k) = ( v_comp(k) - gv ) * ( &
5127	37.0_wp * ( v(k,j+1,i) + v(k,j,i) ) &
5128	- 8.0_wp * ( v(k,j+2,i) + v(k,j-1,i) ) &
5129	+ ( v(k,j+3,i) + v(k,j-2,i) ) ) * adv_mom_5
5130
5131	diss_n(k) = - ABS( v_comp(k) - gv ) * ( &
5132	10.0_wp * ( v(k,j+1,i) - v(k,j,i) ) &
5133	- 5.0_wp * ( v(k,j+2,i) - v(k,j-1,i) ) &
5134	+ ( v(k,j+3,i) - v(k,j-2,i) ) ) * adv_mom_5
5135	!
5136	!-- k index has to be modified near bottom and top, else array
5137	!-- subscripts will be exceeded.
5138	ibit26 = IBITS(wall_flags_0(k,j,i),26,1)
5139	ibit25 = IBITS(wall_flags_0(k,j,i),25,1)
5140	ibit24 = IBITS(wall_flags_0(k,j,i),24,1)
5141
5142	k_ppp = k + 3 * ibit26
5143	k_pp = k + 2 * ( 1 - ibit24 )
5144	k_mm = k - 2 * ibit26
5145
5146	w_comp = w(k,j-1,i) + w(k,j,i)
5147	flux_t(k) = w_comp * ( &
5148	( 37.0_wp * ibit26 * adv_mom_5 &
5149	+ 7.0_wp * ibit25 * adv_mom_3 &
5150	+ ibit24 * adv_mom_1 &
5151	) * &
5152	( v(k+1,j,i) + v(k,j,i) ) &
5153	- ( 8.0_wp * ibit26 * adv_mom_5 &
5154	+ ibit25 * adv_mom_3 &
5155	) * &
5156	( v(k_pp,j,i) + v(k-1,j,i) ) &
5157	+ ( ibit26 * adv_mom_5 &
5158	) * &
5159	( v(k_ppp,j,i) + v(k_mm,j,i) ) &
5160	)
5161
5162	diss_t(k) = - ABS( w_comp ) * ( &
5163	( 10.0_wp * ibit26 * adv_mom_5 &
5164	+ 3.0_wp * ibit25 * adv_mom_3 &
5165	+ ibit24 * adv_mom_1 &
5166	) * &
5167	( v(k+1,j,i) - v(k,j,i) ) &
5168	- ( 5.0_wp * ibit26 * adv_mom_5 &
5169	+ ibit25 * adv_mom_3 &
5170	) * &
5171	( v(k_pp,j,i) - v(k-1,j,i) ) &
5172	+ ( ibit26 * adv_mom_5 &
5173	) * &
5174	( v(k_ppp,j,i) - v(k_mm,j,i) ) &
5175	)
5176	!
5177	!-- Calculate the divergence of the velocity field. A respective
5178	!-- correction is needed to overcome numerical instabilities caused
5179	!-- by a not sufficient reduction of divergences near topography.
5180	div = ( ( u_comp + gu - ( u(k,j-1,i) + u(k,j,i) ) ) * ddx &
5181	+ ( v_comp(k) - ( v(k,j,i) + v(k,j-1,i) ) ) * ddy &
5182	+ ( w_comp - ( w(k-1,j-1,i) + w(k-1,j,i) ) ) &
5183	* ddzw(k) &
5184	) * 0.5_wp
5185
5186	tend(k,j,i) = tend(k,j,i) - ( &
5187	( flux_r(k) + diss_r(k) &
5188	- swap_flux_x_local_v(k,j) - swap_diss_x_local_v(k,j) &
5189	) * ddx &
5190	+ ( flux_n(k) + diss_n(k) &
5191	- swap_flux_y_local_v(k) - swap_diss_y_local_v(k) &
5192	) * ddy &
5193	+ ( flux_t(k) + diss_t(k) &
5194	- flux_d - diss_d &
5195	) * ddzw(k) &
5196	) + v(k,j,i) * div
5197
5198	swap_flux_x_local_v(k,j) = flux_r(k)
5199	swap_diss_x_local_v(k,j) = diss_r(k)
5200	swap_flux_y_local_v(k) = flux_n(k)
5201	swap_diss_y_local_v(k) = diss_n(k)
5202	flux_d = flux_t(k)
5203	diss_d = diss_t(k)
5204
5205	!
5206	!-- Statistical Evaluation of v'v'. The factor has to be applied
5207	!-- for right evaluation when gallilei_trans = .T. .
5208	sums_vs2_ws_l(k,tn) = sums_vs2_ws_l(k,tn) &
5209	+ ( flux_n(k) &
5210	* ( v_comp(k) - 2.0_wp * hom(k,1,2,0) ) &
5211	/ ( v_comp(k) - gv + 1.0E-20_wp ) &
5212	+ diss_n(k) &
5213	* ABS( v_comp(k) - 2.0_wp * hom(k,1,2,0) ) &
5214	/ ( ABS( v_comp(k) - gv ) +1.0E-20_wp ) ) &
5215	* weight_substep(intermediate_timestep_count)
5216	!
5217	!-- Statistical Evaluation of w'v'.
5218	sums_wsvs_ws_l(k,tn) = sums_wsvs_ws_l(k,tn) &
5219	+ ( flux_t(k) + diss_t(k) ) &
5220	* weight_substep(intermediate_timestep_count)
5221
5222	ENDDO
5223	ENDDO
5224	ENDDO
5225	sums_vs2_ws_l(nzb,tn) = sums_vs2_ws_l(nzb+1,tn)
5226
5227
5228	END SUBROUTINE advec_v_ws
5229
5230
5231	!------------------------------------------------------------------------------!
5232	! Advection of v - Call for all grid points - accelerator version
5233	!------------------------------------------------------------------------------!
5234	SUBROUTINE advec_v_ws_acc
5235
5236	USE arrays_3d, &
5237	ONLY: ddzw, tend, u, v, w
5238
5239	USE constants, &
5240	ONLY: adv_mom_1, adv_mom_3, adv_mom_5
5241
5242	USE control_parameters, &
5243	ONLY: intermediate_timestep_count, u_gtrans, v_gtrans
5244
5245	USE grid_variables, &
5246	ONLY: ddx, ddy
5247
5248	USE indices, &
5249	ONLY: i_left, i_right, j_north, j_south, nxl, nxr, nyn, nys, nzb, &
5250	nzb_max, nzt, wall_flags_0
5251
5252	USE kinds
5253
5254	! USE statistics, &
5255	! ONLY: hom, sums_vs2_ws_l, sums_wsvs_ws_l, weight_substep
5256
5257	IMPLICIT NONE
5258
5259
5260	INTEGER(iwp) :: i !:
5261	INTEGER(iwp) :: ibit18 !:
5262	INTEGER(iwp) :: ibit19 !:
5263	INTEGER(iwp) :: ibit20 !:
5264	INTEGER(iwp) :: ibit21 !:
5265	INTEGER(iwp) :: ibit22 !:
5266	INTEGER(iwp) :: ibit23 !:
5267	INTEGER(iwp) :: ibit24 !:
5268	INTEGER(iwp) :: ibit25 !:
5269	INTEGER(iwp) :: ibit26 !:
5270	INTEGER(iwp) :: j !:
5271	INTEGER(iwp) :: k !:
5272	INTEGER(iwp) :: k_mm !:
5273	INTEGER(iwp) :: k_mmm !:
5274	INTEGER(iwp) :: k_pp !:
5275	INTEGER(iwp) :: k_ppp !:
5276	INTEGER(iwp) :: tn = 0 !:
5277
5278	REAL(wp) :: diss_d !:
5279	REAL(wp) :: diss_l !:
5280	REAL(wp) :: diss_n !:
5281	REAL(wp) :: diss_r !:
5282	REAL(wp) :: diss_s !:
5283	REAL(wp) :: diss_t !:
5284	REAL(wp) :: div !:
5285	REAL(wp) :: flux_d !:
5286	REAL(wp) :: flux_l !:
5287	REAL(wp) :: flux_n !:
5288	REAL(wp) :: flux_r !:
5289	REAL(wp) :: flux_s !:
5290	REAL(wp) :: flux_t !:
5291	REAL(wp) :: gu !:
5292	REAL(wp) :: gv !:
5293	REAL(wp) :: u_comp !:
5294	REAL(wp) :: u_comp_l !:
5295	REAL(wp) :: v_comp !:
5296	REAL(wp) :: v_comp_s !:
5297	REAL(wp) :: w_comp !:
5298
5299	gu = 2.0_wp * u_gtrans
5300	gv = 2.0_wp * v_gtrans
5301
5302	!
5303	!-- Computation of fluxes and tendency terms
5304	!$acc kernels present( ddzw, tend, u, v, w, wall_flags_0 )
5305	DO i = i_left, i_right
5306	DO j = j_south, j_north
5307	DO k = nzb+1, nzt
5308
5309	ibit20 = IBITS(wall_flags_0(k,j,i-1),20,1)
5310	ibit19 = IBITS(wall_flags_0(k,j,i-1),19,1)
5311	ibit18 = IBITS(wall_flags_0(k,j,i-1),18,1)
5312
5313	u_comp_l = u(k,j-1,i) + u(k,j,i) - gu
5314	flux_l = u_comp_l * ( &
5315	( 37.0_wp * ibit20 * adv_mom_5 &
5316	+ 7.0_wp * ibit19 * adv_mom_3 &
5317	+ ibit18 * adv_mom_1 &
5318	) * &
5319	( v(k,j,i) + v(k,j,i-1) ) &
5320	- ( 8.0_wp * ibit20 * adv_mom_5 &
5321	+ ibit19 * adv_mom_3 &
5322	) * &
5323	( v(k,j,i+1) + v(k,j,i-2) ) &
5324	+ ( ibit20 * adv_mom_5 &
5325	) * &
5326	( v(k,j,i+2) + v(k,j,i-3) ) &
5327	)
5328
5329	diss_l = - ABS( u_comp_l ) * ( &
5330	( 10.0_wp * ibit20 * adv_mom_5 &
5331	+ 3.0_wp * ibit19 * adv_mom_3 &
5332	+ ibit18 * adv_mom_1 &
5333	) * &
5334	( v(k,j,i) - v(k,j,i-1) ) &
5335	- ( 5.0_wp * ibit20 * adv_mom_5 &
5336	+ ibit19 * adv_mom_3 &
5337	) * &
5338	( v(k,j,i+1) - v(k,j,i-2) ) &
5339	+ ( ibit20 * adv_mom_5 &
5340	) * &
5341	( v(k,j,i+2) - v(k,j,i-3) ) &
5342	)
5343
5344	ibit20 = IBITS(wall_flags_0(k,j,i),20,1)
5345	ibit19 = IBITS(wall_flags_0(k,j,i),19,1)
5346	ibit18 = IBITS(wall_flags_0(k,j,i),18,1)
5347
5348	u_comp = u(k,j-1,i+1) + u(k,j,i+1) - gu
5349	flux_r = u_comp * ( &
5350	( 37.0_wp * ibit20 * adv_mom_5 &
5351	+ 7.0_wp * ibit19 * adv_mom_3 &
5352	+ ibit18 * adv_mom_1 &
5353	) * &
5354	( v(k,j,i+1) + v(k,j,i) ) &
5355	- ( 8.0_wp * ibit20 * adv_mom_5 &
5356	+ ibit19 * adv_mom_3 &
5357	) * &
5358	( v(k,j,i+2) + v(k,j,i-1) ) &
5359	+ ( ibit20 * adv_mom_5 &
5360	) * &
5361	( v(k,j,i+3) + v(k,j,i-2) ) &
5362	)
5363
5364	diss_r = - ABS( u_comp ) * ( &
5365	( 10.0_wp * ibit20 * adv_mom_5 &
5366	+ 3.0_wp * ibit19 * adv_mom_3 &
5367	+ ibit18 * adv_mom_1 &
5368	) * &
5369	( v(k,j,i+1) - v(k,j,i) ) &
5370	- ( 5.0_wp * ibit20 * adv_mom_5 &
5371	+ ibit19 * adv_mom_3 &
5372	) * &
5373	( v(k,j,i+2) - v(k,j,i-1) ) &
5374	+ ( ibit20 * adv_mom_5 &
5375	) * &
5376	( v(k,j,i+3) - v(k,j,i-2) ) &
5377	)
5378
5379	ibit23 = IBITS(wall_flags_0(k,j-1,i),23,1)
5380	ibit22 = IBITS(wall_flags_0(k,j-1,i),22,1)
5381	ibit21 = IBITS(wall_flags_0(k,j-1,i),21,1)
5382
5383
5384	v_comp_s = v(k,j,i) + v(k,j-1,i) - gv
5385	flux_s = v_comp_s * ( &
5386	( 37.0_wp * ibit23 * adv_mom_5 &
5387	+ 7.0_wp * ibit22 * adv_mom_3 &
5388	+ ibit21 * adv_mom_1 &
5389	) * &
5390	( v(k,j,i) + v(k,j-1,i) ) &
5391	- ( 8.0_wp * ibit23 * adv_mom_5 &
5392	+ ibit22 * adv_mom_3 &
5393	) * &
5394	( v(k,j+1,i) + v(k,j-2,i) ) &
5395	+ ( ibit23 * adv_mom_5 &
5396	) * &
5397	( v(k,j+2,i) + v(k,j-3,i) ) &
5398	)
5399
5400	diss_s = - ABS( v_comp_s ) * ( &
5401	( 10.0_wp * ibit23 * adv_mom_5 &
5402	+ 3.0_wp * ibit22 * adv_mom_3 &
5403	+ ibit21 * adv_mom_1 &
5404	) * &
5405	( v(k,j,i) - v(k,j-1,i) ) &
5406	- ( 5.0_wp * ibit23 * adv_mom_5 &
5407	+ ibit22 * adv_mom_3 &
5408	) * &
5409	( v(k,j+1,i) - v(k,j-2,i) ) &
5410	+ ( ibit23 * adv_mom_5 &
5411	) * &
5412	( v(k,j+2,i) - v(k,j-3,i) ) &
5413	)
5414
5415	ibit23 = IBITS(wall_flags_0(k,j,i),23,1)
5416	ibit22 = IBITS(wall_flags_0(k,j,i),22,1)
5417	ibit21 = IBITS(wall_flags_0(k,j,i),21,1)
5418
5419	v_comp = v(k,j+1,i) + v(k,j,i)
5420	flux_n = ( v_comp - gv ) * ( &
5421	( 37.0_wp * ibit23 * adv_mom_5 &
5422	+ 7.0_wp * ibit22 * adv_mom_3 &
5423	+ ibit21 * adv_mom_1 &
5424	) * &
5425	( v(k,j+1,i) + v(k,j,i) ) &
5426	- ( 8.0_wp * ibit23 * adv_mom_5 &
5427	+ ibit22 * adv_mom_3 &
5428	) * &
5429	( v(k,j+2,i) + v(k,j-1,i) ) &
5430	+ ( ibit23 * adv_mom_5 &
5431	) * &
5432	( v(k,j+3,i) + v(k,j-2,i) ) &
5433	)
5434
5435	diss_n = - ABS( v_comp - gv ) * ( &
5436	( 10.0_wp * ibit23 * adv_mom_5 &
5437	+ 3.0_wp * ibit22 * adv_mom_3 &
5438	+ ibit21 * adv_mom_1 &
5439	) * &
5440	( v(k,j+1,i) - v(k,j,i) ) &
5441	- ( 5.0_wp * ibit23 * adv_mom_5 &
5442	+ ibit22 * adv_mom_3 &
5443	) * &
5444	( v(k,j+2,i) - v(k,j-1,i) ) &
5445	+ ( ibit23 * adv_mom_5 &
5446	) * &
5447	( v(k,j+3,i) - v(k,j-2,i) ) &
5448	)
5449
5450	ibit26 = IBITS(wall_flags_0(k-1,j,i),26,1)
5451	ibit25 = IBITS(wall_flags_0(k-1,j,i),25,1)
5452	ibit24 = IBITS(wall_flags_0(k-1,j,i),24,1)
5453
5454	k_pp = k + 2 * ibit26
5455	k_mm = k - 2 * ( ibit25 + ibit26 )
5456	k_mmm = k - 3 * ibit26
5457
5458	w_comp = w(k-1,j-1,i) + w(k-1,j,i)
5459	flux_d = w_comp * ( &
5460	( 37.0_wp * ibit26 * adv_mom_5 &
5461	+ 7.0_wp * ibit25 * adv_mom_3 &
5462	+ ibit24 * adv_mom_1 &
5463	) * &
5464	( v(k,j,i) + v(k-1,j,i) ) &
5465	- ( 8.0_wp * ibit26 * adv_mom_5 &
5466	+ ibit25 * adv_mom_3 &
5467	) * &
5468	( v(k+1,j,i) + v(k_mm,j,i) ) &
5469	+ ( ibit26 * adv_mom_5 &
5470	) * &
5471	( v(k_pp,j,i) + v(k_mmm,j,i) ) &
5472	)
5473
5474	diss_d = - ABS( w_comp ) * ( &
5475	( 10.0_wp * ibit26 * adv_mom_5 &
5476	+ 3.0_wp * ibit25 * adv_mom_3 &
5477	+ ibit24 * adv_mom_1 &
5478	) * &
5479	( v(k,j,i) - v(k-1,j,i) ) &
5480	- ( 5.0_wp * ibit26 * adv_mom_5 &
5481	+ ibit25 * adv_mom_3 &
5482	) * &
5483	( v(k+1,j,i) - v(k_mm,j,i) ) &
5484	+ ( ibit26 * adv_mom_5 &
5485	) * &
5486	( v(k_pp,j,i) - v(k_mmm,j,i) ) &
5487	)
5488	!
5489	!-- k index has to be modified near bottom and top, else array
5490	!-- subscripts will be exceeded.
5491	ibit26 = IBITS(wall_flags_0(k,j,i),26,1)
5492	ibit25 = IBITS(wall_flags_0(k,j,i),25,1)
5493	ibit24 = IBITS(wall_flags_0(k,j,i),24,1)
5494
5495	k_ppp = k + 3 * ibit26
5496	k_pp = k + 2 * ( 1 - ibit24 )
5497	k_mm = k - 2 * ibit26
5498
5499	w_comp = w(k,j-1,i) + w(k,j,i)
5500	flux_t = w_comp * ( &
5501	( 37.0_wp * ibit26 * adv_mom_5 &
5502	+ 7.0_wp * ibit25 * adv_mom_3 &
5503	+ ibit24 * adv_mom_1 &
5504	) * &
5505	( v(k+1,j,i) + v(k,j,i) ) &
5506	- ( 8.0_wp * ibit26 * adv_mom_5 &
5507	+ ibit25 * adv_mom_3 &
5508	) * &
5509	( v(k_pp,j,i) + v(k-1,j,i) ) &
5510	+ ( ibit26 * adv_mom_5 &
5511	) * &
5512	( v(k_ppp,j,i) + v(k_mm,j,i) ) &
5513	)
5514
5515	diss_t = - ABS( w_comp ) * ( &
5516	( 10.0_wp * ibit26 * adv_mom_5 &
5517	+ 3.0_wp * ibit25 * adv_mom_3 &
5518	+ ibit24 * adv_mom_1 &
5519	) * &
5520	( v(k+1,j,i) - v(k,j,i) ) &
5521	- ( 5.0_wp * ibit26 * adv_mom_5 &
5522	+ ibit25 * adv_mom_3 &
5523	) * &
5524	( v(k_pp,j,i) - v(k-1,j,i) ) &
5525	+ ( ibit26 * adv_mom_5 &
5526	) * &
5527	( v(k_ppp,j,i) - v(k_mm,j,i) ) &
5528	)
5529	!
5530	!-- Calculate the divergence of the velocity field. A respective
5531	!-- correction is needed to overcome numerical instabilities caused
5532	!-- by a not sufficient reduction of divergences near topography.
5533	div = ( ( ( u_comp + gu ) &
5534	* ( ibit18 + ibit19 + ibit20 ) &
5535	- ( u(k,j-1,i) + u(k,j,i) ) &
5536	* ( IBITS(wall_flags_0(k,j,i-1),18,1) &
5537	+ IBITS(wall_flags_0(k,j,i-1),19,1) &
5538	+ IBITS(wall_flags_0(k,j,i-1),20,1) &
5539	) &
5540	) * ddx &
5541	+ ( v_comp &
5542	* ( ibit21 + ibit22 + ibit23 ) &
5543	- ( v(k,j,i) + v(k,j-1,i) ) &
5544	* ( IBITS(wall_flags_0(k,j-1,i),21,1) &
5545	+ IBITS(wall_flags_0(k,j-1,i),22,1) &
5546	+ IBITS(wall_flags_0(k,j-1,i),23,1) &
5547	) &
5548	) * ddy &
5549	+ ( w_comp &
5550	* ( ibit24 + ibit25 + ibit26 ) &
5551	- ( w(k-1,j-1,i) + w(k-1,j,i) ) &
5552	* ( IBITS(wall_flags_0(k-1,j,i),24,1) &
5553	+ IBITS(wall_flags_0(k-1,j,i),25,1) &
5554	+ IBITS(wall_flags_0(k-1,j,i),26,1) &
5555	) &
5556	) * ddzw(k) &
5557	) * 0.5_wp
5558
5559
5560	tend(k,j,i) = - ( &
5561	( flux_r + diss_r - flux_l - diss_l ) * ddx &
5562	+ ( flux_n + diss_n - flux_s - diss_s ) * ddy &
5563	+ ( flux_t + diss_t - flux_d - diss_d ) * ddzw(k) &
5564	) + div * v(k,j,i)
5565
5566
5567	!++
5568	!-- Statistical Evaluation of v'v'. The factor has to be applied
5569	!-- for right evaluation when gallilei_trans = .T. .
5570	! sums_vs2_ws_l(k,tn) = sums_vs2_ws_l(k,tn) &
5571	! + ( flux_n &
5572	! * ( v_comp - 2.0_wp * hom(k,1,2,0) ) &
5573	! / ( v_comp - gv + 1.0E-20_wp ) &
5574	! + diss_n &
5575	! * ABS( v_comp - 2.0_wp * hom(k,1,2,0) ) &
5576	! / ( ABS( v_comp - gv ) +1.0E-20_wp ) ) &
5577	! * weight_substep(intermediate_timestep_count)
5578	!
5579	!-- Statistical Evaluation of w'v'.
5580	! sums_wsvs_ws_l(k,tn) = sums_wsvs_ws_l(k,tn) &
5581	! + ( flux_t + diss_t ) &
5582	! * weight_substep(intermediate_timestep_count)
5583
5584	ENDDO
5585	ENDDO
5586	ENDDO
5587	!$acc end kernels
5588
5589	!++
5590	! sums_vs2_ws_l(nzb,tn) = sums_vs2_ws_l(nzb+1,tn)
5591
5592	END SUBROUTINE advec_v_ws_acc
5593
5594
5595	!------------------------------------------------------------------------------!
5596	! Advection of w - Call for all grid points
5597	!------------------------------------------------------------------------------!
5598	SUBROUTINE advec_w_ws
5599
5600	USE arrays_3d, &
5601	ONLY: ddzu, tend, u, v, w
5602
5603	USE constants, &
5604	ONLY: adv_mom_1, adv_mom_3, adv_mom_5
5605
5606	USE control_parameters, &
5607	ONLY: intermediate_timestep_count, u_gtrans, v_gtrans
5608
5609	USE grid_variables, &
5610	ONLY: ddx, ddy
5611
5612	USE indices, &
5613	ONLY: nxl, nxr, nyn, nys, nzb, nzb_max, nzt, wall_flags_0, &
5614	wall_flags_00
5615
5616	USE kinds
5617
5618	USE statistics, &
5619	ONLY: hom, sums_ws2_ws_l, weight_substep
5620
5621	IMPLICIT NONE
5622
5623	INTEGER(iwp) :: i !:
5624	INTEGER(iwp) :: ibit27 !:
5625	INTEGER(iwp) :: ibit28 !:
5626	INTEGER(iwp) :: ibit29 !:
5627	INTEGER(iwp) :: ibit30 !:
5628	INTEGER(iwp) :: ibit31 !:
5629	INTEGER(iwp) :: ibit32 !:
5630	INTEGER(iwp) :: ibit33 !:
5631	INTEGER(iwp) :: ibit34 !:
5632	INTEGER(iwp) :: ibit35 !:
5633	INTEGER(iwp) :: j !:
5634	INTEGER(iwp) :: k !:
5635	INTEGER(iwp) :: k_mm !:
5636	INTEGER(iwp) :: k_pp !:
5637	INTEGER(iwp) :: k_ppp !:
5638	INTEGER(iwp) :: tn = 0 !:
5639
5640	REAL(wp) :: diss_d !:
5641	REAL(wp) :: div !:
5642	REAL(wp) :: flux_d !:
5643	REAL(wp) :: gu !:
5644	REAL(wp) :: gv !:
5645	REAL(wp) :: u_comp !:
5646	REAL(wp) :: v_comp !:
5647	REAL(wp) :: w_comp !:
5648
5649	REAL(wp), DIMENSION(nzb:nzt) :: diss_t !:
5650	REAL(wp), DIMENSION(nzb:nzt) :: flux_t !:
5651
5652	REAL(wp), DIMENSION(nzb+1:nzt) :: diss_n !:
5653	REAL(wp), DIMENSION(nzb+1:nzt) :: diss_r !:
5654	REAL(wp), DIMENSION(nzb+1:nzt) :: flux_n !:
5655	REAL(wp), DIMENSION(nzb+1:nzt) :: flux_r !:
5656	REAL(wp), DIMENSION(nzb+1:nzt) :: swap_diss_y_local_w !:
5657	REAL(wp), DIMENSION(nzb+1:nzt) :: swap_flux_y_local_w !:
5658
5659	REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn) :: swap_diss_x_local_w !:
5660	REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn) :: swap_flux_x_local_w !:
5661
5662	gu = 2.0_wp * u_gtrans
5663	gv = 2.0_wp * v_gtrans
5664	!
5665	!-- compute the whole left boundary of the processor domain
5666	i = nxl
5667	DO j = nys, nyn
5668	DO k = nzb+1, nzb_max
5669
5670	ibit29 = IBITS(wall_flags_0(k,j,i-1),29,1)
5671	ibit28 = IBITS(wall_flags_0(k,j,i-1),28,1)
5672	ibit27 = IBITS(wall_flags_0(k,j,i-1),27,1)
5673
5674	u_comp = u(k+1,j,i) + u(k,j,i) - gu
5675	swap_flux_x_local_w(k,j) = u_comp * ( &
5676	( 37.0_wp * ibit29 * adv_mom_5 &
5677	+ 7.0_wp * ibit28 * adv_mom_3 &
5678	+ ibit27 * adv_mom_1 &
5679	) * &
5680	( w(k,j,i) + w(k,j,i-1) ) &
5681	- ( 8.0_wp * ibit29 * adv_mom_5 &
5682	+ ibit28 * adv_mom_3 &
5683	) * &
5684	( w(k,j,i+1) + w(k,j,i-2) ) &
5685	+ ( ibit29 * adv_mom_5 &
5686	) * &
5687	( w(k,j,i+2) + w(k,j,i-3) ) &
5688	)
5689
5690	swap_diss_x_local_w(k,j) = - ABS( u_comp ) * ( &
5691	( 10.0_wp * ibit29 * adv_mom_5 &
5692	+ 3.0_wp * ibit28 * adv_mom_3 &
5693	+ ibit27 * adv_mom_1 &
5694	) * &
5695	( w(k,j,i) - w(k,j,i-1) ) &
5696	- ( 5.0_wp * ibit29 * adv_mom_5 &
5697	+ ibit28 * adv_mom_3 &
5698	) * &
5699	( w(k,j,i+1) - w(k,j,i-2) ) &
5700	+ ( ibit29 * adv_mom_5 &
5701	) * &
5702	( w(k,j,i+2) - w(k,j,i-3) ) &
5703	)
5704
5705	ENDDO
5706
5707	DO k = nzb_max+1, nzt
5708
5709	u_comp = u(k+1,j,i) + u(k,j,i) - gu
5710	swap_flux_x_local_w(k,j) = u_comp * ( &
5711	37.0_wp * ( w(k,j,i) + w(k,j,i-1) ) &
5712	- 8.0_wp * ( w(k,j,i+1) + w(k,j,i-2) ) &
5713	+ ( w(k,j,i+2) + w(k,j,i-3) ) ) * adv_mom_5
5714	swap_diss_x_local_w(k,j) = - ABS( u_comp ) * ( &
5715	10.0_wp * ( w(k,j,i) - w(k,j,i-1) ) &
5716	- 5.0_wp * ( w(k,j,i+1) - w(k,j,i-2) ) &
5717	+ ( w(k,j,i+2) - w(k,j,i-3) ) ) * adv_mom_5
5718
5719	ENDDO
5720
5721	ENDDO
5722
5723	DO i = nxl, nxr
5724
5725	j = nys
5726	DO k = nzb+1, nzb_max
5727
5728	ibit32 = IBITS(wall_flags_00(k,j-1,i),0,1)
5729	ibit31 = IBITS(wall_flags_0(k,j-1,i),31,1)
5730	ibit30 = IBITS(wall_flags_0(k,j-1,i),30,1)
5731
5732	v_comp = v(k+1,j,i) + v(k,j,i) - gv
5733	swap_flux_y_local_w(k) = v_comp * ( &
5734	( 37.0_wp * ibit32 * adv_mom_5 &
5735	+ 7.0_wp * ibit31 * adv_mom_3 &
5736	+ ibit30 * adv_mom_1 &
5737	) * &
5738	( w(k,j,i) + w(k,j-1,i) ) &
5739	- ( 8.0_wp * ibit32 * adv_mom_5 &
5740	+ ibit31 * adv_mom_3 &
5741	) * &
5742	( w(k,j+1,i) + w(k,j-2,i) ) &
5743	+ ( ibit32 * adv_mom_5 &
5744	) * &
5745	( w(k,j+2,i) + w(k,j-3,i) ) &
5746	)
5747
5748	swap_diss_y_local_w(k) = - ABS( v_comp ) * ( &
5749	( 10.0_wp * ibit32 * adv_mom_5 &
5750	+ 3.0_wp * ibit31 * adv_mom_3 &
5751	+ ibit30 * adv_mom_1 &
5752	) * &
5753	( w(k,j,i) - w(k,j-1,i) ) &
5754	- ( 5.0_wp * ibit32 * adv_mom_5 &
5755	+ ibit31 * adv_mom_3 &
5756	) * &
5757	( w(k,j+1,i) - w(k,j-2,i) ) &
5758	+ ( ibit32 * adv_mom_5 &
5759	) * &
5760	( w(k,j+2,i) - w(k,j-3,i) ) &
5761	)
5762
5763	ENDDO
5764
5765	DO k = nzb_max+1, nzt
5766
5767	v_comp = v(k+1,j,i) + v(k,j,i) - gv
5768	swap_flux_y_local_w(k) = v_comp * ( &
5769	37.0_wp * ( w(k,j,i) + w(k,j-1,i) ) &
5770	- 8.0_wp * ( w(k,j+1,i) +w(k,j-2,i) ) &
5771	+ ( w(k,j+2,i) + w(k,j-3,i) ) ) * adv_mom_5
5772	swap_diss_y_local_w(k) = - ABS( v_comp ) * ( &
5773	10.0_wp * ( w(k,j,i) - w(k,j-1,i) ) &
5774	- 5.0_wp * ( w(k,j+1,i) - w(k,j-2,i) ) &
5775	+ ( w(k,j+2,i) - w(k,j-3,i) ) ) * adv_mom_5
5776
5777	ENDDO
5778
5779	DO j = nys, nyn
5780
5781	!
5782	!-- The lower flux has to be calculated explicetely for the tendency
5783	!-- at the first w-level. For topography wall this is done implicitely
5784	!-- by wall_flags_0.
5785	k = nzb + 1
5786	w_comp = w(k,j,i) + w(k-1,j,i)
5787	flux_t(0) = w_comp * ( w(k,j,i) + w(k-1,j,i) ) * adv_mom_1
5788	diss_t(0) = -ABS(w_comp) * ( w(k,j,i) - w(k-1,j,i) ) * adv_mom_1
5789	flux_d = flux_t(0)
5790	diss_d = diss_t(0)
5791
5792	DO k = nzb+1, nzb_max
5793
5794	ibit29 = IBITS(wall_flags_0(k,j,i),29,1)
5795	ibit28 = IBITS(wall_flags_0(k,j,i),28,1)
5796	ibit27 = IBITS(wall_flags_0(k,j,i),27,1)
5797
5798	u_comp = u(k+1,j,i+1) + u(k,j,i+1) - gu
5799	flux_r(k) = u_comp * ( &
5800	( 37.0_wp * ibit29 * adv_mom_5 &
5801	+ 7.0_wp * ibit28 * adv_mom_3 &
5802	+ ibit27 * adv_mom_1 &
5803	) * &
5804	( w(k,j,i+1) + w(k,j,i) ) &
5805	- ( 8.0_wp * ibit29 * adv_mom_5 &
5806	+ ibit28 * adv_mom_3 &
5807	) * &
5808	( w(k,j,i+2) + w(k,j,i-1) ) &
5809	+ ( ibit29 * adv_mom_5 &
5810	) * &
5811	( w(k,j,i+3) + w(k,j,i-2) ) &
5812	)
5813
5814	diss_r(k) = - ABS( u_comp ) * ( &
5815	( 10.0_wp * ibit29 * adv_mom_5 &
5816	+ 3.0_wp * ibit28 * adv_mom_3 &
5817	+ ibit27 * adv_mom_1 &
5818	) * &
5819	( w(k,j,i+1) - w(k,j,i) ) &
5820	- ( 5.0_wp * ibit29 * adv_mom_5 &
5821	+ ibit28 * adv_mom_3 &
5822	) * &
5823	( w(k,j,i+2) - w(k,j,i-1) ) &
5824	+ ( ibit29 * adv_mom_5 &
5825	) * &
5826	( w(k,j,i+3) - w(k,j,i-2) ) &
5827	)
5828
5829	ibit32 = IBITS(wall_flags_00(k,j,i),0,1)
5830	ibit31 = IBITS(wall_flags_0(k,j,i),31,1)
5831	ibit30 = IBITS(wall_flags_0(k,j,i),30,1)
5832
5833	v_comp = v(k+1,j+1,i) + v(k,j+1,i) - gv
5834	flux_n(k) = v_comp * ( &
5835	( 37.0_wp * ibit32 * adv_mom_5 &
5836	+ 7.0_wp * ibit31 * adv_mom_3 &
5837	+ ibit30 * adv_mom_1 &
5838	) * &
5839	( w(k,j+1,i) + w(k,j,i) ) &
5840	- ( 8.0_wp * ibit32 * adv_mom_5 &
5841	+ ibit31 * adv_mom_3 &
5842	) * &
5843	( w(k,j+2,i) + w(k,j-1,i) ) &
5844	+ ( ibit32 * adv_mom_5 &
5845	) * &
5846	( w(k,j+3,i) + w(k,j-2,i) ) &
5847	)
5848
5849	diss_n(k) = - ABS( v_comp ) * ( &
5850	( 10.0_wp * ibit32 * adv_mom_5 &
5851	+ 3.0_wp * ibit31 * adv_mom_3 &
5852	+ ibit30 * adv_mom_1 &
5853	) * &
5854	( w(k,j+1,i) - w(k,j,i) ) &
5855	- ( 5.0_wp * ibit32 * adv_mom_5 &
5856	+ ibit31 * adv_mom_3 &
5857	) * &
5858	( w(k,j+2,i) - w(k,j-1,i) ) &
5859	+ ( ibit32 * adv_mom_5 &
5860	) * &
5861	( w(k,j+3,i) - w(k,j-2,i) ) &
5862	)
5863	!
5864	!-- k index has to be modified near bottom and top, else array
5865	!-- subscripts will be exceeded.
5866	ibit35 = IBITS(wall_flags_00(k,j,i),3,1)
5867	ibit34 = IBITS(wall_flags_00(k,j,i),2,1)
5868	ibit33 = IBITS(wall_flags_00(k,j,i),1,1)
5869
5870	k_ppp = k + 3 * ibit35
5871	k_pp = k + 2 * ( 1 - ibit33 )
5872	k_mm = k - 2 * ibit35
5873
5874	w_comp = w(k+1,j,i) + w(k,j,i)
5875	flux_t(k) = w_comp * ( &
5876	( 37.0_wp * ibit35 * adv_mom_5 &
5877	+ 7.0_wp * ibit34 * adv_mom_3 &
5878	+ ibit33 * adv_mom_1 &
5879	) * &
5880	( w(k+1,j,i) + w(k,j,i) ) &
5881	- ( 8.0_wp * ibit35 * adv_mom_5 &
5882	+ ibit34 * adv_mom_3 &
5883	) * &
5884	( w(k_pp,j,i) + w(k-1,j,i) ) &
5885	+ ( ibit35 * adv_mom_5 &
5886	) * &
5887	( w(k_ppp,j,i) + w(k_mm,j,i) ) &
5888	)
5889
5890	diss_t(k) = - ABS( w_comp ) * ( &
5891	( 10.0_wp * ibit35 * adv_mom_5 &
5892	+ 3.0_wp * ibit34 * adv_mom_3 &
5893	+ ibit33 * adv_mom_1 &
5894	) * &
5895	( w(k+1,j,i) - w(k,j,i) ) &
5896	- ( 5.0_wp * ibit35 * adv_mom_5 &
5897	+ ibit34 * adv_mom_3 &
5898	) * &
5899	( w(k_pp,j,i) - w(k-1,j,i) ) &
5900	+ ( ibit35 * adv_mom_5 &
5901	) * &
5902	( w(k_ppp,j,i) - w(k_mm,j,i) ) &
5903	)
5904	!
5905	!-- Calculate the divergence of the velocity field. A respective
5906	!-- correction is needed to overcome numerical instabilities caused
5907	!-- by a not sufficient reduction of divergences near topography.
5908	div = ( ( ( u_comp + gu ) * ( ibit27 + ibit28 + ibit29 ) &
5909	- ( u(k+1,j,i) + u(k,j,i) ) &
5910	* ( IBITS(wall_flags_0(k,j,i-1),27,1) &
5911	+ IBITS(wall_flags_0(k,j,i-1),28,1) &
5912	+ IBITS(wall_flags_0(k,j,i-1),29,1) &
5913	) &
5914	) * ddx &
5915	+ ( ( v_comp + gv ) * ( ibit30 + ibit31 + ibit32 ) &
5916	- ( v(k+1,j,i) + v(k,j,i) ) &
5917	* ( IBITS(wall_flags_0(k,j-1,i),30,1) &
5918	+ IBITS(wall_flags_0(k,j-1,i),31,1) &
5919	+ IBITS(wall_flags_00(k,j-1,i),0,1) &
5920	) &
5921	) * ddy &
5922	+ ( w_comp * ( ibit33 + ibit34 + ibit35 ) &
5923	- ( w(k,j,i) + w(k-1,j,i) ) &
5924	* ( IBITS(wall_flags_00(k-1,j,i),1,1) &
5925	+ IBITS(wall_flags_00(k-1,j,i),2,1) &
5926	+ IBITS(wall_flags_00(k-1,j,i),3,1) &
5927	) &
5928	) * ddzu(k+1) &
5929	) * 0.5_wp
5930
5931
5932
5933	tend(k,j,i) = tend(k,j,i) - ( &
5934	( flux_r(k) + diss_r(k) &
5935	- swap_flux_x_local_w(k,j) - swap_diss_x_local_w(k,j) &
5936	) * ddx &
5937	+ ( flux_n(k) + diss_n(k) &
5938	- swap_flux_y_local_w(k) - swap_diss_y_local_w(k) &
5939	) * ddy &
5940	+ ( flux_t(k) + diss_t(k) &
5941	- flux_d - diss_d &
5942	) * ddzu(k+1) &
5943	) + div * w(k,j,i)
5944
5945	swap_flux_x_local_w(k,j) = flux_r(k)
5946	swap_diss_x_local_w(k,j) = diss_r(k)
5947	swap_flux_y_local_w(k) = flux_n(k)
5948	swap_diss_y_local_w(k) = diss_n(k)
5949	flux_d = flux_t(k)
5950	diss_d = diss_t(k)
5951
5952	sums_ws2_ws_l(k,tn) = sums_ws2_ws_l(k,tn) &
5953	+ ( flux_t(k) + diss_t(k) ) &
5954	* weight_substep(intermediate_timestep_count)
5955
5956	ENDDO
5957
5958	DO k = nzb_max+1, nzt
5959
5960	u_comp = u(k+1,j,i+1) + u(k,j,i+1) - gu
5961	flux_r(k) = u_comp * ( &
5962	37.0_wp * ( w(k,j,i+1) + w(k,j,i) ) &
5963	- 8.0_wp * ( w(k,j,i+2) + w(k,j,i-1) ) &
5964	+ ( w(k,j,i+3) + w(k,j,i-2) ) ) * adv_mom_5
5965
5966	diss_r(k) = - ABS( u_comp ) * ( &
5967	10.0_wp * ( w(k,j,i+1) - w(k,j,i) ) &
5968	- 5.0_wp * ( w(k,j,i+2) - w(k,j,i-1) ) &
5969	+ ( w(k,j,i+3) - w(k,j,i-2) ) ) * adv_mom_5
5970
5971	v_comp = v(k+1,j+1,i) + v(k,j+1,i) - gv
5972	flux_n(k) = v_comp * ( &
5973	37.0_wp * ( w(k,j+1,i) + w(k,j,i) ) &
5974	- 8.0_wp * ( w(k,j+2,i) + w(k,j-1,i) ) &
5975	+ ( w(k,j+3,i) + w(k,j-2,i) ) ) * adv_mom_5
5976
5977	diss_n(k) = - ABS( v_comp ) * ( &
5978	10.0_wp * ( w(k,j+1,i) - w(k,j,i) ) &
5979	- 5.0_wp * ( w(k,j+2,i) - w(k,j-1,i) ) &
5980	+ ( w(k,j+3,i) - w(k,j-2,i) ) ) * adv_mom_5
5981	!
5982	!-- k index has to be modified near bottom and top, else array
5983	!-- subscripts will be exceeded.
5984	ibit35 = IBITS(wall_flags_00(k,j,i),3,1)
5985	ibit34 = IBITS(wall_flags_00(k,j,i),2,1)
5986	ibit33 = IBITS(wall_flags_00(k,j,i),1,1)
5987
5988	k_ppp = k + 3 * ibit35
5989	k_pp = k + 2 * ( 1 - ibit33 )
5990	k_mm = k - 2 * ibit35
5991
5992	w_comp = w(k+1,j,i) + w(k,j,i)
5993	flux_t(k) = w_comp * ( &
5994	( 37.0_wp * ibit35 * adv_mom_5 &
5995	+ 7.0_wp * ibit34 * adv_mom_3 &
5996	+ ibit33 * adv_mom_1 &
5997	) * &
5998	( w(k+1,j,i) + w(k,j,i) ) &
5999	- ( 8.0_wp * ibit35 * adv_mom_5 &
6000	+ ibit34 * adv_mom_3 &
6001	) * &
6002	( w(k_pp,j,i) + w(k-1,j,i) ) &
6003	+ ( ibit35 * adv_mom_5 &
6004	) * &
6005	( w(k_ppp,j,i) + w(k_mm,j,i) ) &
6006	)
6007
6008	diss_t(k) = - ABS( w_comp ) * ( &
6009	( 10.0_wp * ibit35 * adv_mom_5 &
6010	+ 3.0_wp * ibit34 * adv_mom_3 &
6011	+ ibit33 * adv_mom_1 &
6012	) * &
6013	( w(k+1,j,i) - w(k,j,i) ) &
6014	- ( 5.0_wp * ibit35 * adv_mom_5 &
6015	+ ibit34 * adv_mom_3 &
6016	) * &
6017	( w(k_pp,j,i) - w(k-1,j,i) ) &
6018	+ ( ibit35 * adv_mom_5 &
6019	) * &
6020	( w(k_ppp,j,i) - w(k_mm,j,i) ) &
6021	)
6022	!
6023	!-- Calculate the divergence of the velocity field. A respective
6024	!-- correction is needed to overcome numerical instabilities caused
6025	!-- by a not sufficient reduction of divergences near topography.
6026	div = ( ( u_comp + gu - ( u(k+1,j,i) + u(k,j,i) ) ) * ddx &
6027	+ ( v_comp + gv - ( v(k+1,j,i) + v(k,j,i) ) ) * ddy &
6028	+ ( w_comp - ( w(k,j,i) + w(k-1,j,i) ) ) &
6029	* ddzu(k+1) &
6030	) * 0.5_wp
6031
6032	tend(k,j,i) = tend(k,j,i) - ( &
6033	( flux_r(k) + diss_r(k) &
6034	- swap_flux_x_local_w(k,j) - swap_diss_x_local_w(k,j) &
6035	) * ddx &
6036	+ ( flux_n(k) + diss_n(k) &
6037	- swap_flux_y_local_w(k) - swap_diss_y_local_w(k) &
6038	) * ddy &
6039	+ ( flux_t(k) + diss_t(k) &
6040	- flux_d - diss_d &
6041	) * ddzu(k+1) &
6042	) + div * w(k,j,i)
6043
6044	swap_flux_x_local_w(k,j) = flux_r(k)
6045	swap_diss_x_local_w(k,j) = diss_r(k)
6046	swap_flux_y_local_w(k) = flux_n(k)
6047	swap_diss_y_local_w(k) = diss_n(k)
6048	flux_d = flux_t(k)
6049	diss_d = diss_t(k)
6050
6051	sums_ws2_ws_l(k,tn) = sums_ws2_ws_l(k,tn) &
6052	+ ( flux_t(k) + diss_t(k) ) &
6053	* weight_substep(intermediate_timestep_count)
6054
6055	ENDDO
6056	ENDDO
6057	ENDDO
6058
6059	END SUBROUTINE advec_w_ws
6060
6061
6062	!------------------------------------------------------------------------------!
6063	! Advection of w - Call for all grid points - accelerator version
6064	!------------------------------------------------------------------------------!
6065	SUBROUTINE advec_w_ws_acc
6066
6067	USE arrays_3d, &
6068	ONLY: ddzu, tend, u, v, w
6069
6070	USE constants, &
6071	ONLY: adv_mom_1, adv_mom_3, adv_mom_5
6072
6073	USE control_parameters, &
6074	ONLY: intermediate_timestep_count, u_gtrans, v_gtrans
6075
6076	USE grid_variables, &
6077	ONLY: ddx, ddy
6078
6079	USE indices, &
6080	ONLY: i_left, i_right, j_north, j_south, nxl, nxr, nyn, nys, nzb, &
6081	nzb_max, nzt, wall_flags_0, wall_flags_00
6082
6083	USE kinds
6084
6085	! USE statistics, &
6086	! ONLY: hom, sums_ws2_ws_l, weight_substep
6087
6088	IMPLICIT NONE
6089
6090	INTEGER(iwp) :: i !:
6091	INTEGER(iwp) :: ibit27 !:
6092	INTEGER(iwp) :: ibit28 !:
6093	INTEGER(iwp) :: ibit29 !:
6094	INTEGER(iwp) :: ibit30 !:
6095	INTEGER(iwp) :: ibit31 !:
6096	INTEGER(iwp) :: ibit32 !:
6097	INTEGER(iwp) :: ibit33 !:
6098	INTEGER(iwp) :: ibit34 !:
6099	INTEGER(iwp) :: ibit35 !:
6100	INTEGER(iwp) :: j !:
6101	INTEGER(iwp) :: k !:
6102	INTEGER(iwp) :: k_mmm !:
6103	INTEGER(iwp) :: k_mm !:
6104	INTEGER(iwp) :: k_pp !:
6105	INTEGER(iwp) :: k_ppp !:
6106	INTEGER(iwp) :: tn = 0 !:
6107
6108	REAL(wp) :: diss_d !:
6109	REAL(wp) :: diss_l !:
6110	REAL(wp) :: diss_n !:
6111	REAL(wp) :: diss_r !:
6112	REAL(wp) :: diss_s !:
6113	REAL(wp) :: diss_t !:
6114	REAL(wp) :: div !:
6115	REAL(wp) :: flux_d !:
6116	REAL(wp) :: flux_l !:
6117	REAL(wp) :: flux_n !:
6118	REAL(wp) :: flux_r !:
6119	REAL(wp) :: flux_s !:
6120	REAL(wp) :: flux_t !:
6121	REAL(wp) :: gu !:
6122	REAL(wp) :: gv !:
6123	REAL(wp) :: u_comp !:
6124	REAL(wp) :: u_comp_l !:
6125	REAL(wp) :: v_comp !:
6126	REAL(wp) :: v_comp_s !:
6127	REAL(wp) :: w_comp !:
6128
6129	gu = 2.0_wp * u_gtrans
6130	gv = 2.0_wp * v_gtrans
6131
6132
6133	!
6134	!-- Computation of fluxes and tendency terms
6135	!$acc kernels present( ddzu, tend, u, v, w, wall_flags_0, wall_flags_00 )
6136	DO i = i_left, i_right
6137	DO j = j_south, j_north
6138	DO k = nzb+1, nzt
6139
6140	ibit27 = IBITS(wall_flags_0(k,j,i-1),27,1)
6141	ibit28 = IBITS(wall_flags_0(k,j,i-1),28,1)
6142	ibit29 = IBITS(wall_flags_0(k,j,i-1),29,1)
6143
6144	u_comp_l = u(k+1,j,i) + u(k,j,i) - gu
6145	flux_l = u_comp_l * ( &
6146	( 37.0_wp * ibit29 * adv_mom_5 &
6147	+ 7.0_wp * ibit28 * adv_mom_3 &
6148	+ ibit27 * adv_mom_1 &
6149	) * &
6150	( w(k,j,i) + w(k,j,i-1) ) &
6151	- ( 8.0_wp * ibit29 * adv_mom_5 &
6152	+ ibit28 * adv_mom_3 &
6153	) * &
6154	( w(k,j,i+1) + w(k,j,i-2) ) &
6155	+ ( ibit29 * adv_mom_5 &
6156	) * &
6157	( w(k,j,i+2) + w(k,j,i-3) ) &
6158	)
6159
6160	diss_l = - ABS( u_comp_l ) * ( &
6161	( 10.0_wp * ibit29 * adv_mom_5 &
6162	+ 3.0_wp * ibit28 * adv_mom_3 &
6163	+ ibit27 * adv_mom_1 &
6164	) * &
6165	( w(k,j,i) - w(k,j,i-1) ) &
6166	- ( 5.0_wp * ibit29 * adv_mom_5 &
6167	+ ibit28 * adv_mom_3 &
6168	) * &
6169	( w(k,j,i+1) - w(k,j,i-2) ) &
6170	+ ( ibit29 * adv_mom_5 &
6171	) * &
6172	( w(k,j,i+2) - w(k,j,i-3) ) &
6173	)
6174
6175	ibit27 = IBITS(wall_flags_0(k,j,i),27,1)
6176	ibit28 = IBITS(wall_flags_0(k,j,i),28,1)
6177	ibit29 = IBITS(wall_flags_0(k,j,i),29,1)
6178
6179	u_comp = u(k+1,j,i+1) + u(k,j,i+1) - gu
6180	flux_r = u_comp * ( &
6181	( 37.0_wp * ibit29 * adv_mom_5 &
6182	+ 7.0_wp * ibit28 * adv_mom_3 &
6183	+ ibit27 * adv_mom_1 &
6184	) * &
6185	( w(k,j,i+1) + w(k,j,i) ) &
6186	- ( 8.0_wp * ibit29 * adv_mom_5 &
6187	+ ibit28 * adv_mom_3 &
6188	) * &
6189	( w(k,j,i+2) + w(k,j,i-1) ) &
6190	+ ( ibit29 * adv_mom_5 &
6191	) * &
6192	( w(k,j,i+3) + w(k,j,i-2) ) &
6193	)
6194
6195	diss_r = - ABS( u_comp ) * ( &
6196	( 10.0_wp * ibit29 * adv_mom_5 &
6197	+ 3.0_wp * ibit28 * adv_mom_3 &
6198	+ ibit27 * adv_mom_1 &
6199	) * &
6200	( w(k,j,i+1) - w(k,j,i) ) &
6201	- ( 5.0_wp * ibit29 * adv_mom_5 &
6202	+ ibit28 * adv_mom_3 &
6203	) * &
6204	( w(k,j,i+2) - w(k,j,i-1) ) &
6205	+ ( ibit29 * adv_mom_5 &
6206	) * &
6207	( w(k,j,i+3) - w(k,j,i-2) ) &
6208	)
6209	ibit32 = IBITS(wall_flags_00(k,j-1,i),0,1)
6210	ibit31 = IBITS(wall_flags_0(k,j-1,i),31,1)
6211	ibit30 = IBITS(wall_flags_0(k,j-1,i),30,1)
6212
6213	v_comp_s = v(k+1,j,i) + v(k,j,i) - gv
6214	flux_s = v_comp_s * ( &
6215	( 37.0_wp * ibit32 * adv_mom_5 &
6216	+ 7.0_wp * ibit31 * adv_mom_3 &
6217	+ ibit30 * adv_mom_1 &
6218	) * &
6219	( w(k,j,i) + w(k,j-1,i) ) &
6220	- ( 8.0_wp * ibit32 * adv_mom_5 &
6221	+ ibit31 * adv_mom_3 &
6222	) * &
6223	( w(k,j+1,i) + w(k,j-2,i) ) &
6224	+ ( ibit32 * adv_mom_5 &
6225	) * &
6226	( w(k,j+2,i) + w(k,j-3,i) ) &
6227	)
6228
6229	diss_s = - ABS( v_comp_s ) * ( &
6230	( 10.0_wp * ibit32 * adv_mom_5 &
6231	+ 3.0_wp * ibit31 * adv_mom_3 &
6232	+ ibit30 * adv_mom_1 &
6233	) * &
6234	( w(k,j,i) - w(k,j-1,i) ) &
6235	- ( 5.0_wp * ibit32 * adv_mom_5 &
6236	+ ibit31 * adv_mom_3 &
6237	) * &
6238	( w(k,j+1,i) - w(k,j-2,i) ) &
6239	+ ( ibit32 * adv_mom_5 &
6240	) * &
6241	( w(k,j+2,i) - w(k,j-3,i) ) &
6242	)
6243
6244	ibit32 = IBITS(wall_flags_00(k,j,i),0,1)
6245	ibit31 = IBITS(wall_flags_0(k,j,i),31,1)
6246	ibit30 = IBITS(wall_flags_0(k,j,i),30,1)
6247
6248	v_comp = v(k+1,j+1,i) + v(k,j+1,i) - gv
6249	flux_n = v_comp * ( &
6250	( 37.0_wp * ibit32 * adv_mom_5 &
6251	+ 7.0_wp * ibit31 * adv_mom_3 &
6252	+ ibit30 * adv_mom_1 &
6253	) * &
6254	( w(k,j+1,i) + w(k,j,i) ) &
6255	- ( 8.0_wp * ibit32 * adv_mom_5 &
6256	+ ibit31 * adv_mom_3 &
6257	) * &
6258	( w(k,j+2,i) + w(k,j-1,i) ) &
6259	+ ( ibit32 * adv_mom_5 &
6260	) * &
6261	( w(k,j+3,i) + w(k,j-2,i) ) &
6262	)
6263
6264	diss_n = - ABS( v_comp ) * ( &
6265	( 10.0_wp * ibit32 * adv_mom_5 &
6266	+ 3.0_wp * ibit31 * adv_mom_3 &
6267	+ ibit30 * adv_mom_1 &
6268	) * &
6269	( w(k,j+1,i) - w(k,j,i) ) &
6270	- ( 5.0_wp * ibit32 * adv_mom_5 &
6271	+ ibit31 * adv_mom_3 &
6272	) * &
6273	( w(k,j+2,i) - w(k,j-1,i) ) &
6274	+ ( ibit32 * adv_mom_5 &
6275	) * &
6276	( w(k,j+3,i) - w(k,j-2,i) ) &
6277	)
6278
6279	ibit35 = IBITS(wall_flags_00(k-1,j,i),3,1)
6280	ibit34 = IBITS(wall_flags_00(k-1,j,i),2,1)
6281	ibit33 = IBITS(wall_flags_00(k-1,j,i),1,1)
6282
6283	k_pp = k + 2 * ibit35
6284	k_mm = k - 2 * ( ibit34 + ibit35 )
6285	k_mmm = k - 3 * ibit35
6286
6287	w_comp = w(k,j,i) + w(k-1,j,i)
6288	flux_d = w_comp * ( &
6289	( 37.0_wp * ibit35 * adv_mom_5 &
6290	+ 7.0_wp * ibit34 * adv_mom_3 &
6291	+ ibit33 * adv_mom_1 &
6292	) * &
6293	( w(k,j,i) + w(k-1,j,i) ) &
6294	- ( 8.0_wp * ibit35 * adv_mom_5 &
6295	+ ibit34 * adv_mom_3 &
6296	) * &
6297	( w(k+1,j,i) + w(k_mm,j,i) ) &
6298	+ ( ibit35 * adv_mom_5 &
6299	) * &
6300	( w(k_pp,j,i) + w(k_mmm,j,i) ) &
6301	)
6302
6303	diss_d = - ABS( w_comp ) * ( &
6304	( 10.0_wp * ibit35 * adv_mom_5 &
6305	+ 3.0_wp * ibit34 * adv_mom_3 &
6306	+ ibit33 * adv_mom_1 &
6307	) * &
6308	( w(k,j,i) - w(k-1,j,i) ) &
6309	- ( 5.0_wp * ibit35 * adv_mom_5 &
6310	+ ibit34 * adv_mom_3 &
6311	) * &
6312	( w(k+1,j,i) - w(k_mm,j,i) ) &
6313	+ ( ibit35 * adv_mom_5 &
6314	) * &
6315	( w(k_pp,j,i) - w(k_mmm,j,i) ) &
6316	)
6317
6318	!
6319	!-- k index has to be modified near bottom and top, else array
6320	!-- subscripts will be exceeded.
6321	ibit35 = IBITS(wall_flags_00(k,j,i),3,1)
6322	ibit34 = IBITS(wall_flags_00(k,j,i),2,1)
6323	ibit33 = IBITS(wall_flags_00(k,j,i),1,1)
6324
6325	k_ppp = k + 3 * ibit35
6326	k_pp = k + 2 * ( 1 - ibit33 )
6327	k_mm = k - 2 * ibit35
6328
6329	w_comp = w(k+1,j,i) + w(k,j,i)
6330	flux_t = w_comp * ( &
6331	( 37.0_wp * ibit35 * adv_mom_5 &
6332	+ 7.0_wp * ibit34 * adv_mom_3 &
6333	+ ibit33 * adv_mom_1 &
6334	) * &
6335	( w(k+1,j,i) + w(k,j,i) ) &
6336	- ( 8.0_wp * ibit35 * adv_mom_5 &
6337	+ ibit34 * adv_mom_3 &
6338	) * &
6339	( w(k_pp,j,i) + w(k-1,j,i) ) &
6340	+ ( ibit35 * adv_mom_5 &
6341	) * &
6342	( w(k_ppp,j,i) + w(k_mm,j,i) ) &
6343	)
6344
6345	diss_t = - ABS( w_comp ) * ( &
6346	( 10.0_wp * ibit35 * adv_mom_5 &
6347	+ 3.0_wp * ibit34 * adv_mom_3 &
6348	+ ibit33 * adv_mom_1 &
6349	) * &
6350	( w(k+1,j,i) - w(k,j,i) ) &
6351	- ( 5.0_wp * ibit35 * adv_mom_5 &
6352	+ ibit34 * adv_mom_3 &
6353	) * &
6354	( w(k_pp,j,i) - w(k-1,j,i) ) &
6355	+ ( ibit35 * adv_mom_5 &
6356	) * &
6357	( w(k_ppp,j,i) - w(k_mm,j,i) ) &
6358	)
6359	!
6360	!-- Calculate the divergence of the velocity field. A respective
6361	!-- correction is needed to overcome numerical instabilities caused
6362	!-- by a not sufficient reduction of divergences near topography.
6363	div = ( ( ( u_comp + gu ) * ( ibit27 + ibit28 + ibit29 ) &
6364	- ( u(k+1,j,i) + u(k,j,i) ) &
6365	* ( IBITS(wall_flags_0(k,j,i-1),27,1) &
6366	+ IBITS(wall_flags_0(k,j,i-1),28,1) &
6367	+ IBITS(wall_flags_0(k,j,i-1),29,1) &
6368	) &
6369	) * ddx &
6370	+ ( ( v_comp + gv ) * ( ibit30 + ibit31 + ibit32 ) &
6371	- ( v(k+1,j,i) + v(k,j,i) ) &
6372	* ( IBITS(wall_flags_0(k,j-1,i),30,1) &
6373	+ IBITS(wall_flags_0(k,j-1,i),31,1) &
6374	+ IBITS(wall_flags_00(k,j-1,i),0,1) &
6375	) &
6376	) * ddy &
6377	+ ( w_comp * ( ibit33 + ibit34 + ibit35 ) &
6378	- ( w(k,j,i) + w(k-1,j,i) ) &
6379	* ( IBITS(wall_flags_00(k-1,j,i),1,1) &
6380	+ IBITS(wall_flags_00(k-1,j,i),2,1) &
6381	+ IBITS(wall_flags_00(k-1,j,i),3,1) &
6382	) &
6383	) * ddzu(k+1) &
6384	) * 0.5_wp
6385
6386
6387	tend(k,j,i) = - ( &
6388	( flux_r + diss_r - flux_l - diss_l ) * ddx &
6389	+ ( flux_n + diss_n - flux_s - diss_s ) * ddy &
6390	+ ( flux_t + diss_t - flux_d - diss_d ) * ddzu(k+1) &
6391	) + div * w(k,j,i)
6392
6393
6394	!++
6395	!-- Statistical Evaluation of w'w'.
6396	! sums_ws2_ws_l(k,tn) = sums_ws2_ws_l(k,tn) &
6397	! + ( flux_t + diss_t ) &
6398	! * weight_substep(intermediate_timestep_count)
6399
6400	ENDDO
6401	ENDDO
6402	ENDDO
6403	!$acc end kernels
6404
6405	END SUBROUTINE advec_w_ws_acc
6406
6407	END MODULE advec_ws

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |