Home

Context Navigation

advec_ws_mod.f90 @ 1853

Last change on this file since 1853 was 1851, checked in by maronga, 9 years ago
last commit documented
Property svn:executable set to ``* Property svn:keywords set to `Id`
File size: 360.6 KB

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

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

Context Navigation

source: palm/trunk/SOURCE/advec_ws_mod.f90 @ 1853

Download in other formats: