Home

Context Navigation

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

Last change on this file since 3661 was 3661, checked in by suehring, 6 years ago
Split loops in advec_ws in order to reduce bit queries; Introduce new parameter to better control order degradation of advection scheme at non-cyclic boundaries; Remove setting of Neumann conditions for horizontal velocity variances; Minor bugfix in divergence correction in advection scheme (only has implications at downward-facing wall surfaces)
Property svn:keywords set to `Id`
File size: 365.9 KB

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |