Home

Context Navigation

source: palm/trunk/SOURCE/pmc_interface_mod.f90 @ 3592

Last change on this file since 3592 was 3592, checked in by suehring, 6 years ago
Determine number of coupled arrays dynamically
Property svn:keywords set to `Id`
File size: 265.6 KB

Line
1	!> @file pmc_interface_mod.f90
2	!------------------------------------------------------------------------------!
3	! This file is part of the PALM model system.
4	!
5	! PALM is free software: you can redistribute it and/or modify it under the
6	! terms of the GNU General Public License as published by the Free Software
7	! Foundation, either version 3 of the License, or (at your option) any later
8	! version.
9	!
10	! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
11	! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
12	! A PARTICULAR PURPOSE. See the GNU General Public License for more details.
13	!
14	! You should have received a copy of the GNU General Public License along with
15	! PALM. If not, see <http://www.gnu.org/licenses/>.
16	!
17	! Copyright 1997-2018 Leibniz Universitaet Hannover
18	!------------------------------------------------------------------------------!
19	!
20	! Current revisions:
21	! ------------------
22	!
23	!
24	! Former revisions:
25	! -----------------
26	! $Id: pmc_interface_mod.f90 3592 2018-12-03 12:38:40Z suehring $
27	! Number of coupled arrays is determined dynamically (instead of a fixed value
28	! of 32)
29	!
30	! 3524 2018-11-14 13:36:44Z raasch
31	! declaration statements rearranged to avoid compile time errors
32	!
33	! 3484 2018-11-02 14:41:25Z hellstea
34	! Introduction of reversibility correction to the interpolation routines in order to
35	! guarantee mass and scalar conservation through the nest boundaries. Several errors
36	! are corrected and pmci_ensure_nest_mass_conservation is permanently removed.
37	!
38	! 3274 2018-09-24 15:42:55Z knoop
39	! Modularization of all bulk cloud physics code components
40	!
41	! 3241 2018-09-12 15:02:00Z raasch
42	! unused variables removed
43	!
44	! 3217 2018-08-29 12:53:59Z suehring
45	! Revise calculation of index bounds for array index_list, prevent compiler
46	! (cray) to delete the loop at high optimization level.
47	!
48	! 3215 2018-08-29 09:58:59Z suehring
49	! Apply an additional switch controlling the nesting of chemical species
50	!
51	! 3209 2018-08-27 16:58:37Z suehring
52	! Variable names for nest_bound_x replaced by bc_dirichlet_x.
53	! Remove commented prints into debug files.
54	!
55	! 3182 2018-07-27 13:36:03Z suehring
56	! dz was replaced by dz(1)
57	!
58	! 3049 2018-05-29 13:52:36Z Giersch
59	! Error messages revised
60	!
61	! 3045 2018-05-28 07:55:41Z Giersch
62	! Error messages revised
63	!
64	! 3022 2018-05-18 11:12:35Z suehring
65	! Minor fix - working precision added to real number
66	!
67	! 3021 2018-05-16 08:14:20Z maronga
68	! Bugfix: variable lcr was defined as INTENT(OUT) instead of INTENT(INOUT)
69	!
70	! 3020 2018-05-14 10:45:48Z hellstea
71	! Bugfix in pmci_define_loglaw_correction_parameters
72	!
73	! 3001 2018-04-20 12:27:13Z suehring
74	! Bugfix, replace MERGE function by an if-condition in the anterpolation (in
75	! order to avoid floating-point exceptions).
76	!
77	! 2997 2018-04-19 13:35:17Z suehring
78	! Mask topography grid points in anterpolation
79	!
80	! 2984 2018-04-18 11:51:30Z hellstea
81	! Bugfix in the log-law correction initialization. Pivot node cannot any more be
82	! selected from outside the subdomain in order to prevent array under/overflows.
83	!
84	! 2967 2018-04-13 11:22:08Z raasch
85	! bugfix: missing parallel cpp-directives added
86	!
87	! 2951 2018-04-06 09:05:08Z kanani
88	! Add log_point_s for pmci_model_configuration
89	!
90	! 2938 2018-03-27 15:52:42Z suehring
91	! - Nesting for RANS mode implemented
92	! - Interpolation of TKE onto child domain only if both parent and child are
93	! either in LES mode or in RANS mode
94	! - Interpolation of dissipation if both parent and child are in RANS mode
95	! and TKE-epsilon closure is applied
96	! - Enable anterpolation of TKE and dissipation rate in case parent and
97	! child operate in RANS mode
98	!
99	! - Some unused variables removed from ONLY list
100	! - Some formatting adjustments for particle nesting
101	!
102	! 2936 2018-03-27 14:49:27Z suehring
103	! Control logics improved to allow nesting also in cases with
104	! constant_flux_layer = .F. or constant_diffusion = .T.
105	!
106	! 2895 2018-03-15 10:26:12Z hellstea
107	! Change in the nest initialization (pmci_interp_tril_all). Bottom wall BC is no
108	! longer overwritten.
109	!
110	! 2868 2018-03-09 13:25:09Z hellstea
111	! Local conditional Neumann conditions for one-way coupling removed.
112	!
113	! 2853 2018-03-05 14:44:20Z suehring
114	! Bugfix in init log-law correction.
115	!
116	! 2841 2018-02-27 15:02:57Z knoop
117	! Bugfix: wrong placement of include 'mpif.h' corrected
118	!
119	! 2812 2018-02-16 13:40:25Z hellstea
120	! Bugfixes in computation of the interpolation loglaw-correction parameters
121	!
122	! 2809 2018-02-15 09:55:58Z schwenkel
123	! Bugfix for gfortran: Replace the function C_SIZEOF with STORAGE_SIZE
124	!
125	! 2806 2018-02-14 17:10:37Z thiele
126	! Bugfixing Write statements
127	!
128	! 2804 2018-02-14 16:57:03Z thiele
129	! preprocessor directive for c_sizeof in case of __gfortran added
130	!
131	! 2803 2018-02-14 16:56:32Z thiele
132	! Introduce particle transfer in nested models.
133	!
134	! 2795 2018-02-07 14:48:48Z hellstea
135	! Bugfix in computation of the anterpolation under-relaxation functions.
136	!
137	! 2773 2018-01-30 14:12:54Z suehring
138	! - Nesting for chemical species
139	! - Bugfix in setting boundary condition at downward-facing walls for passive
140	! scalar
141	! - Some formatting adjustments
142	!
143	! 2718 2018-01-02 08:49:38Z maronga
144	! Corrected "Former revisions" section
145	!
146	! 2701 2017-12-15 15:40:50Z suehring
147	! Changes from last commit documented
148	!
149	! 2698 2017-12-14 18:46:24Z suehring
150	! Bugfix in get_topography_top_index
151	!
152	! 2696 2017-12-14 17:12:51Z kanani
153	! Change in file header (GPL part)
154	! - Bugfix in init_tke_factor (MS)
155	!
156	! 2669 2017-12-06 16:03:27Z raasch
157	! file extension for nested domains changed to "_N##",
158	! created flag file in order to enable combine_plot_fields to process nest data
159	!
160	! 2663 2017-12-04 17:40:50Z suehring
161	! Bugfix, wrong coarse-grid index in init_tkefactor used.
162	!
163	! 2602 2017-11-03 11:06:41Z hellstea
164	! Index-limit related bug (occurred with nesting_mode='vertical') fixed in
165	! pmci_interp_tril_t. Check for too high nest domain added in pmci_setup_parent.
166	! Some cleaning up made.
167	!
168	! 2582 2017-10-26 13:19:46Z hellstea
169	! Resetting of e within buildings / topography in pmci_parent_datatrans removed
170	! as unnecessary since e is not anterpolated, and as incorrect since it overran
171	! the default Neumann condition (bc_e_b).
172	!
173	! 2359 2017-08-21 07:50:30Z hellstea
174	! A minor indexing error in pmci_init_loglaw_correction is corrected.
175	!
176	! 2351 2017-08-15 12:03:06Z kanani
177	! Removed check (PA0420) for nopointer version
178	!
179	! 2350 2017-08-15 11:48:26Z kanani
180	! Bugfix and error message for nopointer version.
181	!
182	! 2318 2017-07-20 17:27:44Z suehring
183	! Get topography top index via Function call
184	!
185	! 2317 2017-07-20 17:27:19Z suehring
186	! Set bottom boundary condition after anterpolation.
187	! Some variable description added.
188	!
189	! 2293 2017-06-22 12:59:12Z suehring
190	! In anterpolation, exclude grid points which are used for interpolation.
191	! This avoids the accumulation of numerical errors leading to increased
192	! variances for shallow child domains.
193	!
194	! 2292 2017-06-20 09:51:42Z schwenkel
195	! Implementation of new microphysic scheme: cloud_scheme = 'morrison'
196	! includes two more prognostic equations for cloud drop concentration (nc)
197	! and cloud water content (qc).
198	!
199	! 2285 2017-06-15 13:15:41Z suehring
200	! Consider multiple pure-vertical nest domains in overlap check
201	!
202	! 2283 2017-06-14 10:17:34Z suehring
203	! Bugfixes in inititalization of log-law correction concerning
204	! new topography concept
205	!
206	! 2281 2017-06-13 11:34:50Z suehring
207	! Bugfix, add pre-preprocessor directives to enable non-parrallel mode
208	!
209	! 2241 2017-06-01 13:46:13Z hellstea
210	! A minor indexing error in pmci_init_loglaw_correction is corrected.
211	!
212	! 2240 2017-06-01 13:45:34Z hellstea
213	!
214	! 2232 2017-05-30 17:47:52Z suehring
215	! Adjustments to new topography concept
216	!
217	! 2229 2017-05-30 14:52:52Z hellstea
218	! A minor indexing error in pmci_init_anterp_tophat is corrected.
219	!
220	! 2174 2017-03-13 08:18:57Z maronga
221	! Added support for cloud physics quantities, syntax layout improvements. Data
222	! transfer of qc and nc is prepared but currently deactivated until both
223	! quantities become prognostic variables.
224	! Some bugfixes.
225	!
226	! 2019 2016-09-30 13:40:09Z hellstea
227	! Bugfixes mainly in determining the anterpolation index bounds. These errors
228	! were detected when first time tested using 3:1 grid-spacing.
229	!
230	! 2003 2016-08-24 10:22:32Z suehring
231	! Humidity and passive scalar also separated in nesting mode
232	!
233	! 2000 2016-08-20 18:09:15Z knoop
234	! Forced header and separation lines into 80 columns
235	!
236	! 1938 2016-06-13 15:26:05Z hellstea
237	! Minor clean-up.
238	!
239	! 1901 2016-05-04 15:39:38Z raasch
240	! Initial version of purely vertical nesting introduced.
241	! Code clean up. The words server/client changed to parent/child.
242	!
243	! 1900 2016-05-04 15:27:53Z raasch
244	! unused variables removed
245	!
246	! 1894 2016-04-27 09:01:48Z raasch
247	! bugfix: pt interpolations are omitted in case that the temperature equation is
248	! switched off
249	!
250	! 1892 2016-04-26 13:49:47Z raasch
251	! bugfix: pt is not set as a data array in case that the temperature equation is
252	! switched off with neutral = .TRUE.
253	!
254	! 1882 2016-04-20 15:24:46Z hellstea
255	! The factor ijfc for nfc used in anterpolation is redefined as 2-D array
256	! and precomputed in pmci_init_anterp_tophat.
257	!
258	! 1878 2016-04-19 12:30:36Z hellstea
259	! Synchronization rewritten, logc-array index order changed for cache
260	! optimization
261	!
262	! 1850 2016-04-08 13:29:27Z maronga
263	! Module renamed
264	!
265	!
266	! 1808 2016-04-05 19:44:00Z raasch
267	! MPI module used by default on all machines
268	!
269	! 1801 2016-04-05 13:12:47Z raasch
270	! bugfix for r1797: zero setting of temperature within topography does not work
271	! and has been disabled
272	!
273	! 1797 2016-03-21 16:50:28Z raasch
274	! introduction of different datatransfer modes,
275	! further formatting cleanup, parameter checks added (including mismatches
276	! between root and nest model settings),
277	! +routine pmci_check_setting_mismatches
278	! comm_world_nesting introduced
279	!
280	! 1791 2016-03-11 10:41:25Z raasch
281	! routine pmci_update_new removed,
282	! pmc_get_local_model_info renamed pmc_get_model_info, some keywords also
283	! renamed,
284	! filling up redundant ghost points introduced,
285	! some index bound variables renamed,
286	! further formatting cleanup
287	!
288	! 1783 2016-03-06 18:36:17Z raasch
289	! calculation of nest top area simplified,
290	! interpolation and anterpolation moved to seperate wrapper subroutines
291	!
292	! 1781 2016-03-03 15:12:23Z raasch
293	! _p arrays are set zero within buildings too, t.._m arrays and respective
294	! settings within buildings completely removed
295	!
296	! 1779 2016-03-03 08:01:28Z raasch
297	! only the total number of PEs is given for the domains, npe_x and npe_y
298	! replaced by npe_total, two unused elements removed from array
299	! parent_grid_info_real,
300	! array management changed from linked list to sequential loop
301	!
302	! 1766 2016-02-29 08:37:15Z raasch
303	! modifications to allow for using PALM's pointer version,
304	! +new routine pmci_set_swaplevel
305	!
306	! 1764 2016-02-28 12:45:19Z raasch
307	! +cpl_parent_id,
308	! cpp-statements for nesting replaced by __parallel statements,
309	! errors output with message-subroutine,
310	! index bugfixes in pmci_interp_tril_all,
311	! some adjustments to PALM style
312	!
313	! 1762 2016-02-25 12:31:13Z hellstea
314	! Initial revision by A. Hellsten
315	!
316	! Description:
317	! ------------
318	! Domain nesting interface routines. The low-level inter-domain communication
319	! is conducted by the PMC-library routines.
320	!
321	! @todo Remove array_3d variables from USE statements thate not used in the
322	! routine
323	! @todo Data transfer of qc and nc is prepared but not activated
324	!------------------------------------------------------------------------------!
325	MODULE pmc_interface
326
327	USE ISO_C_BINDING
328
329
330	#if defined( __nopointer )
331	USE arrays_3d, &
332	ONLY: diss, dzu, dzw, e, e_p, nc, nr, pt, q, qc, qr, s, u, u_p, &
333	v, v_p, w, w_p, zu, zw
334	#else
335	USE arrays_3d, &
336	ONLY: diss, diss_2, dzu, dzw, e, e_p, e_2, nc, nc_2, nc_p, nr, nr_2, &
337	pt, pt_2, q, q_2, qc, qc_2, qr, qr_2, s, s_2, &
338	u, u_p, u_2, v, v_p, v_2, w, w_p, w_2, zu, zw
339	#endif
340
341	USE control_parameters, &
342	ONLY: air_chemistry, bc_dirichlet_l, bc_dirichlet_n, bc_dirichlet_r, &
343	bc_dirichlet_s, child_domain, &
344	constant_diffusion, constant_flux_layer, &
345	coupling_char, dt_3d, dz, humidity, message_string, &
346	neutral, passive_scalar, rans_mode, rans_tke_e, &
347	roughness_length, simulated_time, topography, volume_flow
348
349	USE chem_modules, &
350	ONLY: nspec
351
352	USE chemistry_model_mod, &
353	ONLY: chem_species, nest_chemistry, spec_conc_2
354
355	USE cpulog, &
356	ONLY: cpu_log, log_point_s
357
358	USE grid_variables, &
359	ONLY: dx, dy
360
361	USE indices, &
362	ONLY: nbgp, nx, nxl, nxlg, nxlu, nxr, nxrg, ny, nyn, nyng, nys, nysg, &
363	nysv, nz, nzb, nzt, wall_flags_0
364
365	USE bulk_cloud_model_mod, &
366	ONLY: bulk_cloud_model, microphysics_morrison, microphysics_seifert
367
368	USE particle_attributes, &
369	ONLY: particle_advection
370
371	USE kinds
372
373	#if defined( __parallel )
374	#if !defined( __mpifh )
375	USE MPI
376	#endif
377
378	USE pegrid, &
379	ONLY: collective_wait, comm1dx, comm1dy, comm2d, myid, myidx, myidy, &
380	numprocs, pleft, pnorth, pright, psouth, status
381
382	USE pmc_child, &
383	ONLY: pmc_childinit, pmc_c_clear_next_array_list, &
384	pmc_c_getnextarray, pmc_c_get_2d_index_list, pmc_c_getbuffer, &
385	pmc_c_putbuffer, pmc_c_setind_and_allocmem, &
386	pmc_c_set_dataarray, pmc_set_dataarray_name
387
388	USE pmc_general, &
389	ONLY: da_namelen
390
391	USE pmc_handle_communicator, &
392	ONLY: pmc_get_model_info, pmc_init_model, pmc_is_rootmodel, &
393	pmc_no_namelist_found, pmc_parent_for_child, m_couplers
394
395	USE pmc_mpi_wrapper, &
396	ONLY: pmc_bcast, pmc_recv_from_child, pmc_recv_from_parent, &
397	pmc_send_to_child, pmc_send_to_parent
398
399	USE pmc_parent, &
400	ONLY: pmc_parentinit, pmc_s_clear_next_array_list, pmc_s_fillbuffer, &
401	pmc_s_getdata_from_buffer, pmc_s_getnextarray, &
402	pmc_s_setind_and_allocmem, pmc_s_set_active_data_array, &
403	pmc_s_set_dataarray, pmc_s_set_2d_index_list
404
405	#endif
406
407	USE surface_mod, &
408	ONLY: get_topography_top_index_ji, surf_def_h, surf_lsm_h, surf_usm_h
409
410	IMPLICIT NONE
411
412	#if defined( __parallel )
413	#if defined( __mpifh )
414	INCLUDE "mpif.h"
415	#endif
416	#endif
417
418	PRIVATE
419	!
420	!-- Constants
421	INTEGER(iwp), PARAMETER :: child_to_parent = 2 !<
422	INTEGER(iwp), PARAMETER :: parent_to_child = 1 !<
423	!
424	!-- Coupler setup
425	INTEGER(iwp), SAVE :: comm_world_nesting !<
426	INTEGER(iwp), SAVE :: cpl_id = 1 !<
427	CHARACTER(LEN=32), SAVE :: cpl_name !<
428	INTEGER(iwp), SAVE :: cpl_npe_total !<
429	INTEGER(iwp), SAVE :: cpl_parent_id !<
430	!
431	!-- Control parameters
432	CHARACTER(LEN=7), SAVE :: nesting_datatransfer_mode = 'mixed' !< steering
433	!< parameter for data-
434	!< transfer mode
435	CHARACTER(LEN=8), SAVE :: nesting_mode = 'two-way' !< steering parameter
436	!< for 1- or 2-way nesting
437
438	LOGICAL, SAVE :: nested_run = .FALSE. !< general switch
439	LOGICAL :: rans_mode_parent = .FALSE. !< mode of parent model (.F. - LES mode, .T. - RANS mode)
440
441	REAL(wp), SAVE :: anterp_relax_length_l = -1.0_wp !<
442	REAL(wp), SAVE :: anterp_relax_length_r = -1.0_wp !<
443	REAL(wp), SAVE :: anterp_relax_length_s = -1.0_wp !<
444	REAL(wp), SAVE :: anterp_relax_length_n = -1.0_wp !<
445	REAL(wp), SAVE :: anterp_relax_length_t = -1.0_wp !<
446	!
447	!-- Geometry
448	REAL(wp), SAVE :: area_t !<
449	REAL(wp), SAVE, DIMENSION(:), ALLOCATABLE, PUBLIC :: coord_x !<
450	REAL(wp), SAVE, DIMENSION(:), ALLOCATABLE, PUBLIC :: coord_y !<
451	REAL(wp), SAVE, PUBLIC :: lower_left_coord_x !<
452	REAL(wp), SAVE, PUBLIC :: lower_left_coord_y !<
453
454	!
455	!-- Children's parent-grid arrays
456	INTEGER(iwp), SAVE, DIMENSION(5), PUBLIC :: coarse_bound !< subdomain index bounds for children's parent-grid arrays
457	INTEGER(iwp), SAVE, DIMENSION(4), PUBLIC :: coarse_bound_anterp !< subdomain index bounds for anterpolation
458
459	REAL(wp), SAVE :: xexl !<
460	REAL(wp), SAVE :: xexr !<
461	REAL(wp), SAVE :: yexs !<
462	REAL(wp), SAVE :: yexn !<
463	REAL(wp), SAVE, DIMENSION(:,:), ALLOCATABLE :: tkefactor_l !<
464	REAL(wp), SAVE, DIMENSION(:,:), ALLOCATABLE :: tkefactor_n !<
465	REAL(wp), SAVE, DIMENSION(:,:), ALLOCATABLE :: tkefactor_r !<
466	REAL(wp), SAVE, DIMENSION(:,:), ALLOCATABLE :: tkefactor_s !<
467	REAL(wp), SAVE, DIMENSION(:,:), ALLOCATABLE :: tkefactor_t !<
468
469	REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET :: dissc !< coarse grid array on child domain - dissipation rate
470	REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET :: ec !<
471	REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET :: ptc !<
472	REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET :: uc !<
473	REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET :: vc !<
474	REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET :: wc !<
475	REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET :: q_c !<
476	REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET :: qcc !<
477	REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET :: qrc !<
478	REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET :: nrc !<
479	REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET :: ncc !<
480	REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET :: sc !<
481	INTEGER(idp), SAVE, DIMENSION(:,:), ALLOCATABLE, TARGET, PUBLIC :: nr_partc !<
482	INTEGER(idp), SAVE, DIMENSION(:,:), ALLOCATABLE, TARGET, PUBLIC :: part_adrc !<
483
484	REAL(wp), SAVE, DIMENSION(:,:,:,:), ALLOCATABLE, TARGET :: chem_spec_c !< coarse grid array on child domain - chemical species
485
486	!
487	!-- Child interpolation coefficients and child-array indices to be
488	!-- precomputed and stored.
489	INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) :: ico !<
490	INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) :: icu !<
491	INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) :: jco !<
492	INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) :: jcv !<
493	INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) :: kco !<
494	INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) :: kcw !<
495	REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) :: r1xo !<
496	REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) :: r2xo !<
497	REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) :: r1xu !<
498	REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) :: r2xu !<
499	REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) :: r1yo !<
500	REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) :: r2yo !<
501	REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) :: r1yv !<
502	REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) :: r2yv !<
503	REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) :: r1zo !<
504	REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) :: r2zo !<
505	REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) :: r1zw !<
506	REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) :: r2zw !<
507	REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) :: celltmpd !<
508	!
509	!-- Child index arrays and log-ratio arrays for the log-law near-wall
510	!-- corrections. These are not truly 3-D arrays but multiple 2-D arrays.
511	INTEGER(iwp), SAVE :: ncorr !< 4th dimension of the log_ratio-arrays
512	INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: logc_u_l !<
513	INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: logc_u_n !<
514	INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: logc_u_r !<
515	INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: logc_u_s !<
516	INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: logc_v_l !<
517	INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: logc_v_n !<
518	INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: logc_v_r !<
519	INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: logc_v_s !<
520	INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: logc_w_l !<
521	INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: logc_w_n !<
522	INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: logc_w_r !<
523	INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: logc_w_s !<
524	INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: logc_kbounds_u_l !<
525	INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: logc_kbounds_u_n !<
526	INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: logc_kbounds_u_r !<
527	INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: logc_kbounds_u_s !<
528	INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: logc_kbounds_v_l !<
529	INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: logc_kbounds_v_n !<
530	INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: logc_kbounds_v_r !<
531	INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: logc_kbounds_v_s !<
532	INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: logc_kbounds_w_l !<
533	INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: logc_kbounds_w_n !<
534	INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: logc_kbounds_w_r !<
535	INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: logc_kbounds_w_s !<
536	REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:) :: logc_ratio_u_l !<
537	REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:) :: logc_ratio_u_n !<
538	REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:) :: logc_ratio_u_r !<
539	REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:) :: logc_ratio_u_s !<
540	REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:) :: logc_ratio_v_l !<
541	REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:) :: logc_ratio_v_n !<
542	REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:) :: logc_ratio_v_r !<
543	REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:) :: logc_ratio_v_s !<
544	REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:) :: logc_ratio_w_l !<
545	REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:) :: logc_ratio_w_n !<
546	REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:) :: logc_ratio_w_r !<
547	REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:) :: logc_ratio_w_s !<
548	!
549	!-- Upper bounds for k in anterpolation.
550	INTEGER(iwp), SAVE :: kcto !<
551	INTEGER(iwp), SAVE :: kctw !<
552	!
553	!-- Upper bound for k in log-law correction in interpolation.
554	INTEGER(iwp), SAVE :: nzt_topo_nestbc_l !<
555	INTEGER(iwp), SAVE :: nzt_topo_nestbc_n !<
556	INTEGER(iwp), SAVE :: nzt_topo_nestbc_r !<
557	INTEGER(iwp), SAVE :: nzt_topo_nestbc_s !<
558	!
559	!-- Number of ghost nodes in coarse-grid arrays for i and j in anterpolation.
560	INTEGER(iwp), SAVE :: nhll !<
561	INTEGER(iwp), SAVE :: nhlr !<
562	INTEGER(iwp), SAVE :: nhls !<
563	INTEGER(iwp), SAVE :: nhln !<
564	!
565	!-- Spatial under-relaxation coefficients for anterpolation.
566	REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) :: frax !<
567	REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) :: fray !<
568	REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) :: fraz !<
569	!
570	!-- Child-array indices to be precomputed and stored for anterpolation.
571	INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) :: iflu !< child index indicating left bound of parent grid box on u-grid
572	INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) :: ifuu !< child index indicating right bound of parent grid box on u-grid
573	INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) :: iflo !< child index indicating left bound of parent grid box on scalar-grid
574	INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) :: ifuo !< child index indicating right bound of parent grid box on scalar-grid
575	INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) :: jflv !< child index indicating south bound of parent grid box on v-grid
576	INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) :: jfuv !< child index indicating north bound of parent grid box on v-grid
577	INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) :: jflo !< child index indicating south bound of parent grid box on scalar-grid
578	INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) :: jfuo !< child index indicating north bound of parent grid box on scalar-grid
579	INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) :: kflw !< child index indicating lower bound of parent grid box on w-grid
580	INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) :: kfuw !< child index indicating upper bound of parent grid box on w-grid
581	INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) :: kflo !< child index indicating lower bound of parent grid box on scalar-grid
582	INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) :: kfuo !< child index indicating upper bound of parent grid box on scalar-grid
583	!
584	!-- Number of fine-grid nodes inside coarse-grid ij-faces
585	!-- to be precomputed for anterpolation.
586	INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: ijkfc_u !< number of child grid boxes contribution to a parent grid box, u-grid
587	INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: ijkfc_v !< number of child grid boxes contribution to a parent grid box, v-grid
588	INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: ijkfc_w !< number of child grid boxes contribution to a parent grid box, w-grid
589	INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: ijkfc_s !< number of child grid boxes contribution to a parent grid box, scalar-grid
590
591	INTEGER(iwp), DIMENSION(3) :: parent_grid_info_int !<
592	REAL(wp), DIMENSION(7) :: parent_grid_info_real !<
593	REAL(wp), DIMENSION(2) :: zmax_coarse !<
594
595	TYPE coarsegrid_def
596	INTEGER(iwp) :: nx !<
597	INTEGER(iwp) :: ny !<
598	INTEGER(iwp) :: nz !<
599	REAL(wp) :: dx !<
600	REAL(wp) :: dy !<
601	REAL(wp) :: dz !<
602	REAL(wp) :: lower_left_coord_x !<
603	REAL(wp) :: lower_left_coord_y !<
604	REAL(wp) :: xend !<
605	REAL(wp) :: yend !<
606	REAL(wp), DIMENSION(:), ALLOCATABLE :: coord_x !<
607	REAL(wp), DIMENSION(:), ALLOCATABLE :: coord_y !<
608	REAL(wp), DIMENSION(:), ALLOCATABLE :: dzu !<
609	REAL(wp), DIMENSION(:), ALLOCATABLE :: dzw !<
610	REAL(wp), DIMENSION(:), ALLOCATABLE :: zu !<
611	REAL(wp), DIMENSION(:), ALLOCATABLE :: zw !<
612	END TYPE coarsegrid_def
613
614	TYPE(coarsegrid_def), SAVE, PUBLIC :: cg !<
615	!
616	!-- Variables for particle coupling
617	TYPE, PUBLIC :: childgrid_def
618	INTEGER(iwp) :: nx !<
619	INTEGER(iwp) :: ny !<
620	INTEGER(iwp) :: nz !<
621	REAL(wp) :: dx !<
622	REAL(wp) :: dy !<
623	REAL(wp) :: dz !<
624	REAL(wp) :: lx_coord, lx_coord_b !<
625	REAL(wp) :: rx_coord, rx_coord_b !<
626	REAL(wp) :: sy_coord, sy_coord_b !<
627	REAL(wp) :: ny_coord, ny_coord_b !<
628	REAL(wp) :: uz_coord, uz_coord_b !<
629	END TYPE childgrid_def
630
631	TYPE(childgrid_def), SAVE, ALLOCATABLE, DIMENSION(:), PUBLIC :: childgrid !<
632
633	INTEGER(idp),ALLOCATABLE,DIMENSION(:,:),PUBLIC,TARGET :: nr_part !<
634	INTEGER(idp),ALLOCATABLE,DIMENSION(:,:),PUBLIC,TARGET :: part_adr !<
635
636	INTERFACE pmci_boundary_conds
637	MODULE PROCEDURE pmci_boundary_conds
638	END INTERFACE pmci_boundary_conds
639
640	INTERFACE pmci_check_setting_mismatches
641	MODULE PROCEDURE pmci_check_setting_mismatches
642	END INTERFACE
643
644	INTERFACE pmci_child_initialize
645	MODULE PROCEDURE pmci_child_initialize
646	END INTERFACE
647
648	INTERFACE pmci_synchronize
649	MODULE PROCEDURE pmci_synchronize
650	END INTERFACE
651
652	INTERFACE pmci_datatrans
653	MODULE PROCEDURE pmci_datatrans
654	END INTERFACE pmci_datatrans
655
656	INTERFACE pmci_init
657	MODULE PROCEDURE pmci_init
658	END INTERFACE
659
660	INTERFACE pmci_modelconfiguration
661	MODULE PROCEDURE pmci_modelconfiguration
662	END INTERFACE
663
664	INTERFACE pmci_parent_initialize
665	MODULE PROCEDURE pmci_parent_initialize
666	END INTERFACE
667
668	INTERFACE get_number_of_childs
669	MODULE PROCEDURE get_number_of_childs
670	END INTERFACE get_number_of_childs
671
672	INTERFACE get_childid
673	MODULE PROCEDURE get_childid
674	END INTERFACE get_childid
675
676	INTERFACE get_child_edges
677	MODULE PROCEDURE get_child_edges
678	END INTERFACE get_child_edges
679
680	INTERFACE get_child_gridspacing
681	MODULE PROCEDURE get_child_gridspacing
682	END INTERFACE get_child_gridspacing
683
684
685	INTERFACE pmci_set_swaplevel
686	MODULE PROCEDURE pmci_set_swaplevel
687	END INTERFACE pmci_set_swaplevel
688
689	PUBLIC anterp_relax_length_l, anterp_relax_length_r, &
690	anterp_relax_length_s, anterp_relax_length_n, &
691	anterp_relax_length_t, child_to_parent, comm_world_nesting, &
692	cpl_id, nested_run, nesting_datatransfer_mode, nesting_mode, &
693	parent_to_child, rans_mode_parent
694
695	PUBLIC pmci_boundary_conds
696	PUBLIC pmci_child_initialize
697	PUBLIC pmci_datatrans
698	PUBLIC pmci_init
699	PUBLIC pmci_modelconfiguration
700	PUBLIC pmci_parent_initialize
701	PUBLIC pmci_synchronize
702	PUBLIC pmci_set_swaplevel
703	PUBLIC get_number_of_childs, get_childid, get_child_edges, get_child_gridspacing
704
705
706
707	CONTAINS
708
709
710	SUBROUTINE pmci_init( world_comm )
711
712	USE control_parameters, &
713	ONLY: message_string
714
715	IMPLICIT NONE
716
717	INTEGER(iwp), INTENT(OUT) :: world_comm !<
718
719	#if defined( __parallel )
720
721	INTEGER(iwp) :: pmc_status !<
722
723
724	CALL pmc_init_model( world_comm, nesting_datatransfer_mode, nesting_mode, &
725	pmc_status )
726
727	IF ( pmc_status == pmc_no_namelist_found ) THEN
728	!
729	!-- This is not a nested run
730	world_comm = MPI_COMM_WORLD
731	cpl_id = 1
732	cpl_name = ""
733
734	RETURN
735
736	ENDIF
737	!
738	!-- Check steering parameter values
739	IF ( TRIM( nesting_mode ) /= 'one-way' .AND. &
740	TRIM( nesting_mode ) /= 'two-way' .AND. &
741	TRIM( nesting_mode ) /= 'vertical' ) &
742	THEN
743	message_string = 'illegal nesting mode: ' // TRIM( nesting_mode )
744	CALL message( 'pmci_init', 'PA0417', 3, 2, 0, 6, 0 )
745	ENDIF
746
747	IF ( TRIM( nesting_datatransfer_mode ) /= 'cascade' .AND. &
748	TRIM( nesting_datatransfer_mode ) /= 'mixed' .AND. &
749	TRIM( nesting_datatransfer_mode ) /= 'overlap' ) &
750	THEN
751	message_string = 'illegal nesting datatransfer mode: ' &
752	// TRIM( nesting_datatransfer_mode )
753	CALL message( 'pmci_init', 'PA0418', 3, 2, 0, 6, 0 )
754	ENDIF
755	!
756	!-- Set the general steering switch which tells PALM that its a nested run
757	nested_run = .TRUE.
758	!
759	!-- Get some variables required by the pmc-interface (and in some cases in the
760	!-- PALM code out of the pmci) out of the pmc-core
761	CALL pmc_get_model_info( comm_world_nesting = comm_world_nesting, &
762	cpl_id = cpl_id, cpl_parent_id = cpl_parent_id, &
763	cpl_name = cpl_name, npe_total = cpl_npe_total, &
764	lower_left_x = lower_left_coord_x, &
765	lower_left_y = lower_left_coord_y )
766	!
767	!-- Set the steering switch which tells the models that they are nested (of
768	!-- course the root domain (cpl_id = 1) is not nested)
769	IF ( cpl_id >= 2 ) THEN
770	child_domain = .TRUE.
771	WRITE( coupling_char, '(A2,I2.2)') '_N', cpl_id
772	ENDIF
773
774	!
775	!-- Message that communicators for nesting are initialized.
776	!-- Attention: myid has been set at the end of pmc_init_model in order to
777	!-- guarantee that only PE0 of the root domain does the output.
778	CALL location_message( 'finished', .TRUE. )
779	!
780	!-- Reset myid to its default value
781	myid = 0
782	#else
783	!
784	!-- Nesting cannot be used in serial mode. cpl_id is set to root domain (1)
785	!-- because no location messages would be generated otherwise.
786	!-- world_comm is given a dummy value to avoid compiler warnings (INTENT(OUT)
787	!-- should get an explicit value)
788	cpl_id = 1
789	nested_run = .FALSE.
790	world_comm = 1
791	#endif
792
793	END SUBROUTINE pmci_init
794
795
796
797	SUBROUTINE pmci_modelconfiguration
798
799	IMPLICIT NONE
800
801	INTEGER(iwp) :: ncpl !< number of nest domains
802
803	#if defined( __parallel )
804	CALL location_message( 'setup the nested model configuration', .FALSE. )
805	CALL cpu_log( log_point_s(79), 'pmci_model_config', 'start' )
806	!
807	!-- Compute absolute coordinates for all models
808	CALL pmci_setup_coordinates
809	!
810	!-- Determine the number of coupled arrays
811	CALL pmci_num_arrays
812	!
813	!-- Initialize the child (must be called before pmc_setup_parent)
814	CALL pmci_setup_child
815	!
816	!-- Initialize PMC parent
817	CALL pmci_setup_parent
818	!
819	!-- Check for mismatches between settings of master and child variables
820	!-- (e.g., all children have to follow the end_time settings of the root master)
821	CALL pmci_check_setting_mismatches
822	!
823	!-- Set flag file for combine_plot_fields for precessing the nest output data
824	OPEN( 90, FILE='3DNESTING', FORM='FORMATTED' )
825	CALL pmc_get_model_info( ncpl = ncpl )
826	WRITE( 90, '(I2)' ) ncpl
827	CLOSE( 90 )
828
829	CALL cpu_log( log_point_s(79), 'pmci_model_config', 'stop' )
830	CALL location_message( 'finished', .TRUE. )
831	#endif
832
833	END SUBROUTINE pmci_modelconfiguration
834
835
836
837	SUBROUTINE pmci_setup_parent
838
839	#if defined( __parallel )
840	IMPLICIT NONE
841
842	CHARACTER(LEN=32) :: myname
843
844	INTEGER(iwp) :: child_id !<
845	INTEGER(iwp) :: ierr !<
846	INTEGER(iwp) :: k !<
847	INTEGER(iwp) :: m !<
848	INTEGER(iwp) :: mid !<
849	INTEGER(iwp) :: mm !<
850	INTEGER(iwp) :: n = 1 !< running index for chemical species
851	INTEGER(iwp) :: nest_overlap !<
852	INTEGER(iwp) :: nomatch !<
853	INTEGER(iwp) :: nx_cl !<
854	INTEGER(iwp) :: ny_cl !<
855	INTEGER(iwp) :: nz_cl !<
856
857	INTEGER(iwp), DIMENSION(5) :: val !<
858
859
860	REAL(wp), DIMENSION(:), ALLOCATABLE :: ch_xl !<
861	REAL(wp), DIMENSION(:), ALLOCATABLE :: ch_xr !<
862	REAL(wp), DIMENSION(:), ALLOCATABLE :: ch_ys !<
863	REAL(wp), DIMENSION(:), ALLOCATABLE :: ch_yn !<
864	REAL(wp) :: cl_height !<
865	REAL(wp) :: dx_cl !<
866	REAL(wp) :: dy_cl !<
867	REAL(wp) :: dz_cl !<
868	REAL(wp) :: left_limit !<
869	REAL(wp) :: north_limit !<
870	REAL(wp) :: right_limit !<
871	REAL(wp) :: south_limit !<
872	REAL(wp) :: xez !<
873	REAL(wp) :: yez !<
874
875	REAL(wp), DIMENSION(5) :: fval !<
876
877	REAL(wp), DIMENSION(:), ALLOCATABLE :: cl_coord_x !<
878	REAL(wp), DIMENSION(:), ALLOCATABLE :: cl_coord_y !<
879
880	!
881	! Initialize the pmc parent
882	CALL pmc_parentinit
883
884	!
885	!-- Corners of all children of the present parent
886	IF ( ( SIZE( pmc_parent_for_child ) - 1 > 0 ) .AND. myid == 0 ) THEN
887	ALLOCATE( ch_xl(1:SIZE( pmc_parent_for_child ) - 1) )
888	ALLOCATE( ch_xr(1:SIZE( pmc_parent_for_child ) - 1) )
889	ALLOCATE( ch_ys(1:SIZE( pmc_parent_for_child ) - 1) )
890	ALLOCATE( ch_yn(1:SIZE( pmc_parent_for_child ) - 1) )
891	ENDIF
892	IF ( ( SIZE( pmc_parent_for_child ) - 1 > 0 ) ) THEN
893	ALLOCATE( childgrid(1:SIZE( pmc_parent_for_child ) - 1) )
894	ENDIF
895
896	!
897	!-- Get coordinates from all children
898	DO m = 1, SIZE( pmc_parent_for_child ) - 1
899
900	child_id = pmc_parent_for_child(m)
901
902	IF ( myid == 0 ) THEN
903
904	CALL pmc_recv_from_child( child_id, val, SIZE(val), 0, 123, ierr )
905	CALL pmc_recv_from_child( child_id, fval, SIZE(fval), 0, 124, ierr )
906
907	nx_cl = val(1)
908	ny_cl = val(2)
909	dx_cl = fval(3)
910	dy_cl = fval(4)
911	dz_cl = fval(5)
912	cl_height = fval(1)
913
914	nz_cl = nz
915	!
916	!-- Find the highest nest level in the coarse grid for the reduced z
917	!-- transfer
918	DO k = 1, nz
919	IF ( zw(k) > fval(1) ) THEN
920	nz_cl = k
921	EXIT
922	ENDIF
923	ENDDO
924
925	zmax_coarse = fval(1:2)
926	cl_height = fval(1)
927
928	!
929	!-- Get absolute coordinates from the child
930	ALLOCATE( cl_coord_x(-nbgp:nx_cl+nbgp) )
931	ALLOCATE( cl_coord_y(-nbgp:ny_cl+nbgp) )
932
933	CALL pmc_recv_from_child( child_id, cl_coord_x, SIZE( cl_coord_x ), &
934	0, 11, ierr )
935	CALL pmc_recv_from_child( child_id, cl_coord_y, SIZE( cl_coord_y ), &
936	0, 12, ierr )
937
938	parent_grid_info_real(1) = lower_left_coord_x
939	parent_grid_info_real(2) = lower_left_coord_y
940	parent_grid_info_real(3) = dx
941	parent_grid_info_real(4) = dy
942	parent_grid_info_real(5) = lower_left_coord_x + ( nx + 1 ) * dx
943	parent_grid_info_real(6) = lower_left_coord_y + ( ny + 1 ) * dy
944	parent_grid_info_real(7) = dz(1)
945
946	parent_grid_info_int(1) = nx
947	parent_grid_info_int(2) = ny
948	parent_grid_info_int(3) = nz_cl
949	!
950	!-- Check that the child domain matches parent domain.
951	nomatch = 0
952	IF ( nesting_mode == 'vertical' ) THEN
953	right_limit = parent_grid_info_real(5)
954	north_limit = parent_grid_info_real(6)
955	IF ( ( cl_coord_x(nx_cl+1) /= right_limit ) .OR. &
956	( cl_coord_y(ny_cl+1) /= north_limit ) ) THEN
957	nomatch = 1
958	ENDIF
959	ELSE
960	!
961	!-- Check that the child domain is completely inside the parent domain.
962	xez = ( nbgp + 1 ) * dx
963	yez = ( nbgp + 1 ) * dy
964	left_limit = lower_left_coord_x + xez
965	right_limit = parent_grid_info_real(5) - xez
966	south_limit = lower_left_coord_y + yez
967	north_limit = parent_grid_info_real(6) - yez
968	IF ( ( cl_coord_x(0) < left_limit ) .OR. &
969	( cl_coord_x(nx_cl+1) > right_limit ) .OR. &
970	( cl_coord_y(0) < south_limit ) .OR. &
971	( cl_coord_y(ny_cl+1) > north_limit ) ) THEN
972	nomatch = 1
973	ENDIF
974	ENDIF
975	!
976	!-- Child domain must be lower than the parent domain such
977	!-- that the top ghost layer of the child grid does not exceed
978	!-- the parent domain top boundary.
979
980	IF ( cl_height > zw(nz) ) THEN
981	nomatch = 1
982	ENDIF
983	!
984	!-- Check that parallel nest domains, if any, do not overlap.
985	nest_overlap = 0
986	IF ( SIZE( pmc_parent_for_child ) - 1 > 0 ) THEN
987	ch_xl(m) = cl_coord_x(-nbgp)
988	ch_xr(m) = cl_coord_x(nx_cl+nbgp)
989	ch_ys(m) = cl_coord_y(-nbgp)
990	ch_yn(m) = cl_coord_y(ny_cl+nbgp)
991
992	IF ( m > 1 ) THEN
993	DO mm = 1, m - 1
994	mid = pmc_parent_for_child(mm)
995	!
996	!-- Check only different nest levels
997	IF (m_couplers(child_id)%parent_id /= m_couplers(mid)%parent_id) THEN
998	IF ( ( ch_xl(m) < ch_xr(mm) .OR. &
999	ch_xr(m) > ch_xl(mm) ) .AND. &
1000	( ch_ys(m) < ch_yn(mm) .OR. &
1001	ch_yn(m) > ch_ys(mm) ) ) THEN
1002	nest_overlap = 1
1003	ENDIF
1004	ENDIF
1005	ENDDO
1006	ENDIF
1007	ENDIF
1008
1009	CALL set_child_edge_coords
1010
1011	DEALLOCATE( cl_coord_x )
1012	DEALLOCATE( cl_coord_y )
1013	!
1014	!-- Send information about operating mode (LES or RANS) to child. This will be
1015	!-- used to control TKE nesting and setting boundary conditions properly.
1016	CALL pmc_send_to_child( child_id, rans_mode, 1, 0, 19, ierr )
1017	!
1018	!-- Send coarse grid information to child
1019	CALL pmc_send_to_child( child_id, parent_grid_info_real, &
1020	SIZE( parent_grid_info_real ), 0, 21, &
1021	ierr )
1022	CALL pmc_send_to_child( child_id, parent_grid_info_int, 3, 0, &
1023	22, ierr )
1024	!
1025	!-- Send local grid to child
1026	CALL pmc_send_to_child( child_id, coord_x, nx+1+2*nbgp, 0, 24, &
1027	ierr )
1028	CALL pmc_send_to_child( child_id, coord_y, ny+1+2*nbgp, 0, 25, &
1029	ierr )
1030	!
1031	!-- Also send the dzu-, dzw-, zu- and zw-arrays here
1032	CALL pmc_send_to_child( child_id, dzu, nz_cl+1, 0, 26, ierr )
1033	CALL pmc_send_to_child( child_id, dzw, nz_cl+1, 0, 27, ierr )
1034	CALL pmc_send_to_child( child_id, zu, nz_cl+2, 0, 28, ierr )
1035	CALL pmc_send_to_child( child_id, zw, nz_cl+2, 0, 29, ierr )
1036
1037	ENDIF
1038
1039	CALL MPI_BCAST( nomatch, 1, MPI_INTEGER, 0, comm2d, ierr )
1040	IF ( nomatch /= 0 ) THEN
1041	WRITE ( message_string, * ) 'nested child domain does ', &
1042	'not fit into its parent domain'
1043	CALL message( 'pmci_setup_parent', 'PA0425', 3, 2, 0, 6, 0 )
1044	ENDIF
1045
1046	CALL MPI_BCAST( nest_overlap, 1, MPI_INTEGER, 0, comm2d, ierr )
1047	IF ( nest_overlap /= 0 .AND. nesting_mode /= 'vertical' ) THEN
1048	WRITE ( message_string, * ) 'nested parallel child domains overlap'
1049	CALL message( 'pmci_setup_parent', 'PA0426', 3, 2, 0, 6, 0 )
1050	ENDIF
1051
1052	CALL MPI_BCAST( nz_cl, 1, MPI_INTEGER, 0, comm2d, ierr )
1053
1054	CALL MPI_BCAST( childgrid(m), STORAGE_SIZE(childgrid(1))/8, MPI_BYTE, 0, comm2d, ierr )
1055	!
1056	!-- TO_DO: Klaus: please give a comment what is done here
1057	CALL pmci_create_index_list
1058	!
1059	!-- Include couple arrays into parent content
1060	!-- The adresses of the PALM 2D or 3D array (here server coarse grid) which are candidates
1061	!-- for coupling are stored once into the pmc context. While data transfer, the array do not
1062	!-- have to be specified again
1063
1064	CALL pmc_s_clear_next_array_list
1065	DO WHILE ( pmc_s_getnextarray( child_id, myname ) )
1066	IF ( INDEX( TRIM( myname ), 'chem_' ) /= 0 ) THEN
1067	CALL pmci_set_array_pointer( myname, child_id = child_id, &
1068	nz_cl = nz_cl, n = n )
1069	n = n + 1
1070	ELSE
1071	CALL pmci_set_array_pointer( myname, child_id = child_id, &
1072	nz_cl = nz_cl )
1073	ENDIF
1074	ENDDO
1075
1076	CALL pmc_s_setind_and_allocmem( child_id )
1077	ENDDO
1078
1079	IF ( ( SIZE( pmc_parent_for_child ) - 1 > 0 ) .AND. myid == 0 ) THEN
1080	DEALLOCATE( ch_xl )
1081	DEALLOCATE( ch_xr )
1082	DEALLOCATE( ch_ys )
1083	DEALLOCATE( ch_yn )
1084	ENDIF
1085
1086	CONTAINS
1087
1088
1089	SUBROUTINE pmci_create_index_list
1090
1091	IMPLICIT NONE
1092
1093	INTEGER(iwp) :: i !<
1094	INTEGER(iwp) :: ic !<
1095	INTEGER(iwp) :: ierr !<
1096	INTEGER(iwp) :: j !<
1097	INTEGER(iwp) :: k !<
1098	INTEGER(iwp) :: npx !<
1099	INTEGER(iwp) :: npy !<
1100	INTEGER(iwp) :: nrx !<
1101	INTEGER(iwp) :: nry !<
1102	INTEGER(iwp) :: px !<
1103	INTEGER(iwp) :: py !<
1104	INTEGER(iwp) :: parent_pe !<
1105
1106	INTEGER(iwp), DIMENSION(2) :: scoord !<
1107	INTEGER(iwp), DIMENSION(2) :: size_of_array !<
1108
1109	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: coarse_bound_all !<
1110	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: index_list !<
1111
1112	IF ( myid == 0 ) THEN
1113	!
1114	!-- TO_DO: Klaus: give more specific comment what size_of_array stands for
1115	CALL pmc_recv_from_child( child_id, size_of_array, 2, 0, 40, ierr )
1116	ALLOCATE( coarse_bound_all(size_of_array(1),size_of_array(2)) )
1117	CALL pmc_recv_from_child( child_id, coarse_bound_all, &
1118	SIZE( coarse_bound_all ), 0, 41, ierr )
1119	!
1120	!-- Compute size of index_list.
1121	ic = 0
1122	DO k = 1, size_of_array(2)
1123	ic = ic + ( coarse_bound_all(4,k) - coarse_bound_all(3,k) + 1 ) * &
1124	( coarse_bound_all(2,k) - coarse_bound_all(1,k) + 1 )
1125	ENDDO
1126
1127	ALLOCATE( index_list(6,ic) )
1128
1129	CALL MPI_COMM_SIZE( comm1dx, npx, ierr )
1130	CALL MPI_COMM_SIZE( comm1dy, npy, ierr )
1131	!
1132	!-- The +1 in index is because PALM starts with nx=0
1133	nrx = nxr - nxl + 1
1134	nry = nyn - nys + 1
1135	ic = 0
1136	!
1137	!-- Loop over all children PEs
1138	DO k = 1, size_of_array(2)
1139	!
1140	!-- Area along y required by actual child PE
1141	DO j = coarse_bound_all(3,k), coarse_bound_all(4,k)
1142	!
1143	!-- Area along x required by actual child PE
1144	DO i = coarse_bound_all(1,k), coarse_bound_all(2,k)
1145
1146	px = i / nrx
1147	py = j / nry
1148	scoord(1) = px
1149	scoord(2) = py
1150	CALL MPI_CART_RANK( comm2d, scoord, parent_pe, ierr )
1151
1152	ic = ic + 1
1153	!
1154	!-- First index in parent array
1155	index_list(1,ic) = i - ( px * nrx ) + 1 + nbgp
1156	!
1157	!-- Second index in parent array
1158	index_list(2,ic) = j - ( py * nry ) + 1 + nbgp
1159	!
1160	!-- x index of child coarse grid
1161	index_list(3,ic) = i - coarse_bound_all(1,k) + 1
1162	!
1163	!-- y index of child coarse grid
1164	index_list(4,ic) = j - coarse_bound_all(3,k) + 1
1165	!
1166	!-- PE number of child
1167	index_list(5,ic) = k - 1
1168	!
1169	!-- PE number of parent
1170	index_list(6,ic) = parent_pe
1171
1172	ENDDO
1173	ENDDO
1174	ENDDO
1175	!
1176	!-- TO_DO: Klaus: comment what is done here
1177	CALL pmc_s_set_2d_index_list( child_id, index_list(:,1:ic) )
1178
1179	ELSE
1180	!
1181	!-- TO_DO: Klaus: comment why this dummy allocation is required
1182	ALLOCATE( index_list(6,1) )
1183	CALL pmc_s_set_2d_index_list( child_id, index_list )
1184	ENDIF
1185
1186	DEALLOCATE(index_list)
1187
1188	END SUBROUTINE pmci_create_index_list
1189
1190	SUBROUTINE set_child_edge_coords
1191	IMPLICIT NONE
1192
1193	INTEGER(iwp) :: nbgp_lpm = 1
1194
1195	nbgp_lpm = min(nbgp_lpm, nbgp)
1196
1197	childgrid(m)%nx = nx_cl
1198	childgrid(m)%ny = ny_cl
1199	childgrid(m)%nz = nz_cl
1200	childgrid(m)%dx = dx_cl
1201	childgrid(m)%dy = dy_cl
1202	childgrid(m)%dz = dz_cl
1203
1204	childgrid(m)%lx_coord = cl_coord_x(0)
1205	childgrid(m)%lx_coord_b = cl_coord_x(-nbgp_lpm)
1206	childgrid(m)%rx_coord = cl_coord_x(nx_cl)+dx_cl
1207	childgrid(m)%rx_coord_b = cl_coord_x(nx_cl+nbgp_lpm)+dx_cl
1208	childgrid(m)%sy_coord = cl_coord_y(0)
1209	childgrid(m)%sy_coord_b = cl_coord_y(-nbgp_lpm)
1210	childgrid(m)%ny_coord = cl_coord_y(ny_cl)+dy_cl
1211	childgrid(m)%ny_coord_b = cl_coord_y(ny_cl+nbgp_lpm)+dy_cl
1212	childgrid(m)%uz_coord = zmax_coarse(2)
1213	childgrid(m)%uz_coord_b = zmax_coarse(1)
1214
1215	END SUBROUTINE set_child_edge_coords
1216
1217	#endif
1218	END SUBROUTINE pmci_setup_parent
1219
1220
1221
1222	SUBROUTINE pmci_setup_child
1223
1224
1225	#if defined( __parallel )
1226	IMPLICIT NONE
1227
1228	CHARACTER(LEN=da_namelen) :: myname !<
1229
1230	INTEGER(iwp) :: i !<
1231	INTEGER(iwp) :: ierr !<
1232	INTEGER(iwp) :: icl !< left index limit for children's parent-grid arrays
1233	INTEGER(iwp) :: icla !< left index limit for anterpolation
1234	INTEGER(iwp) :: icr !< left index limit for children's parent-grid arrays
1235	INTEGER(iwp) :: icra !< right index limit for anterpolation
1236	INTEGER(iwp) :: j !<
1237	INTEGER(iwp) :: jcn !< north index limit for children's parent-grid arrays
1238	INTEGER(iwp) :: jcna !< north index limit for anterpolation
1239	INTEGER(iwp) :: jcs !< sout index limit for children's parent-grid arrays
1240	INTEGER(iwp) :: jcsa !< south index limit for anterpolation
1241	INTEGER(iwp) :: n !< running index for number of chemical species
1242
1243	INTEGER(iwp), DIMENSION(5) :: val !<
1244
1245	REAL(wp) :: xcs !<
1246	REAL(wp) :: xce !<
1247	REAL(wp) :: ycs !<
1248	REAL(wp) :: yce !<
1249
1250	REAL(wp), DIMENSION(5) :: fval !<
1251
1252	!
1253	!-- Child setup
1254	!-- Root model does not have a parent and is not a child, therefore no child setup on root model
1255
1256	IF ( .NOT. pmc_is_rootmodel() ) THEN
1257
1258	CALL pmc_childinit
1259	!
1260	!-- Here AND ONLY HERE the arrays are defined, which actualy will be
1261	!-- exchanged between child and parent.
1262	!-- If a variable is removed, it only has to be removed from here.
1263	!-- Please check, if the arrays are in the list of POSSIBLE exchange arrays
1264	!-- in subroutines:
1265	!-- pmci_set_array_pointer (for parent arrays)
1266	!-- pmci_create_child_arrays (for child arrays)
1267	CALL pmc_set_dataarray_name( 'coarse', 'u' ,'fine', 'u', ierr )
1268	CALL pmc_set_dataarray_name( 'coarse', 'v' ,'fine', 'v', ierr )
1269	CALL pmc_set_dataarray_name( 'coarse', 'w' ,'fine', 'w', ierr )
1270	!
1271	!-- Set data array name for TKE. Please note, nesting of TKE is actually
1272	!-- only done if both parent and child are in LES or in RANS mode. Due to
1273	!-- design of model coupler, however, data array names must be already
1274	!-- available at this point.
1275	CALL pmc_set_dataarray_name( 'coarse', 'e' ,'fine', 'e', ierr )
1276	!
1277	!-- Nesting of dissipation rate only if both parent and child are in RANS
1278	!-- mode and TKE-epsilo closure is applied. Please so also comment for TKE
1279	!-- above.
1280	CALL pmc_set_dataarray_name( 'coarse', 'diss' ,'fine', 'diss', ierr )
1281
1282	IF ( .NOT. neutral ) THEN
1283	CALL pmc_set_dataarray_name( 'coarse', 'pt' ,'fine', 'pt', ierr )
1284	ENDIF
1285
1286	IF ( humidity ) THEN
1287
1288	CALL pmc_set_dataarray_name( 'coarse', 'q' ,'fine', 'q', ierr )
1289
1290	IF ( bulk_cloud_model .AND. microphysics_morrison ) THEN
1291	CALL pmc_set_dataarray_name( 'coarse', 'qc' ,'fine', 'qc', ierr )
1292	CALL pmc_set_dataarray_name( 'coarse', 'nc' ,'fine', 'nc', ierr )
1293	ENDIF
1294
1295	IF ( bulk_cloud_model .AND. microphysics_seifert ) THEN
1296	CALL pmc_set_dataarray_name( 'coarse', 'qr' ,'fine', 'qr', ierr )
1297	CALL pmc_set_dataarray_name( 'coarse', 'nr' ,'fine', 'nr', ierr )
1298	ENDIF
1299
1300	ENDIF
1301
1302	IF ( passive_scalar ) THEN
1303	CALL pmc_set_dataarray_name( 'coarse', 's' ,'fine', 's', ierr )
1304	ENDIF
1305
1306	IF( particle_advection ) THEN
1307	CALL pmc_set_dataarray_name( 'coarse', 'nr_part' ,'fine', &
1308	'nr_part', ierr )
1309	CALL pmc_set_dataarray_name( 'coarse', 'part_adr' ,'fine', &
1310	'part_adr', ierr )
1311	ENDIF
1312
1313	IF ( air_chemistry .AND. nest_chemistry ) THEN
1314	DO n = 1, nspec
1315	CALL pmc_set_dataarray_name( 'coarse', &
1316	'chem_' // &
1317	TRIM( chem_species(n)%name ), &
1318	'fine', &
1319	'chem_' // &
1320	TRIM( chem_species(n)%name ), &
1321	ierr )
1322	ENDDO
1323	ENDIF
1324
1325	CALL pmc_set_dataarray_name( lastentry = .TRUE. )
1326	!
1327	!-- Send grid to parent
1328	val(1) = nx
1329	val(2) = ny
1330	val(3) = nz
1331	val(4) = dx
1332	val(5) = dy
1333	fval(1) = zw(nzt+1)
1334	fval(2) = zw(nzt)
1335	fval(3) = dx
1336	fval(4) = dy
1337	fval(5) = dz(1)
1338
1339	IF ( myid == 0 ) THEN
1340
1341	CALL pmc_send_to_parent( val, SIZE( val ), 0, 123, ierr )
1342	CALL pmc_send_to_parent( fval, SIZE( fval ), 0, 124, ierr )
1343	CALL pmc_send_to_parent( coord_x, nx + 1 + 2 * nbgp, 0, 11, ierr )
1344	CALL pmc_send_to_parent( coord_y, ny + 1 + 2 * nbgp, 0, 12, ierr )
1345
1346	CALL pmc_recv_from_parent( rans_mode_parent, 1, 0, 19, ierr )
1347	!
1348	!
1349	!-- Receive Coarse grid information.
1350	CALL pmc_recv_from_parent( parent_grid_info_real, &
1351	SIZE(parent_grid_info_real), 0, 21, ierr )
1352	CALL pmc_recv_from_parent( parent_grid_info_int, 3, 0, 22, ierr )
1353	!
1354	!-- Debug-printouts - keep them
1355	! WRITE(0,*) 'Coarse grid from parent '
1356	! WRITE(0,*) 'startx_tot = ',parent_grid_info_real(1)
1357	! WRITE(0,*) 'starty_tot = ',parent_grid_info_real(2)
1358	! WRITE(0,*) 'endx_tot = ',parent_grid_info_real(5)
1359	! WRITE(0,*) 'endy_tot = ',parent_grid_info_real(6)
1360	! WRITE(0,*) 'dx = ',parent_grid_info_real(3)
1361	! WRITE(0,*) 'dy = ',parent_grid_info_real(4)
1362	! WRITE(0,*) 'dz = ',parent_grid_info_real(7)
1363	! WRITE(0,*) 'nx_coarse = ',parent_grid_info_int(1)
1364	! WRITE(0,*) 'ny_coarse = ',parent_grid_info_int(2)
1365	! WRITE(0,*) 'nz_coarse = ',parent_grid_info_int(3)
1366	ENDIF
1367
1368	CALL MPI_BCAST( parent_grid_info_real, SIZE(parent_grid_info_real), &
1369	MPI_REAL, 0, comm2d, ierr )
1370	CALL MPI_BCAST( parent_grid_info_int, 3, MPI_INTEGER, 0, comm2d, ierr )
1371
1372	cg%dx = parent_grid_info_real(3)
1373	cg%dy = parent_grid_info_real(4)
1374	cg%dz = parent_grid_info_real(7)
1375	cg%nx = parent_grid_info_int(1)
1376	cg%ny = parent_grid_info_int(2)
1377	cg%nz = parent_grid_info_int(3)
1378	!
1379	!-- Get parent coordinates on coarse grid
1380	ALLOCATE( cg%coord_x(-nbgp:cg%nx+nbgp) )
1381	ALLOCATE( cg%coord_y(-nbgp:cg%ny+nbgp) )
1382
1383	ALLOCATE( cg%dzu(1:cg%nz+1) )
1384	ALLOCATE( cg%dzw(1:cg%nz+1) )
1385	ALLOCATE( cg%zu(0:cg%nz+1) )
1386	ALLOCATE( cg%zw(0:cg%nz+1) )
1387	!
1388	!-- Get coarse grid coordinates and values of the z-direction from the parent
1389	IF ( myid == 0) THEN
1390	CALL pmc_recv_from_parent( cg%coord_x, cg%nx+1+2*nbgp, 0, 24, ierr )
1391	CALL pmc_recv_from_parent( cg%coord_y, cg%ny+1+2*nbgp, 0, 25, ierr )
1392	CALL pmc_recv_from_parent( cg%dzu, cg%nz+1, 0, 26, ierr )
1393	CALL pmc_recv_from_parent( cg%dzw, cg%nz+1, 0, 27, ierr )
1394	CALL pmc_recv_from_parent( cg%zu, cg%nz+2, 0, 28, ierr )
1395	CALL pmc_recv_from_parent( cg%zw, cg%nz+2, 0, 29, ierr )
1396	ENDIF
1397	!
1398	!-- Broadcast this information
1399	CALL MPI_BCAST( cg%coord_x, cg%nx+1+2*nbgp, MPI_REAL, 0, comm2d, ierr )
1400	CALL MPI_BCAST( cg%coord_y, cg%ny+1+2*nbgp, MPI_REAL, 0, comm2d, ierr )
1401	CALL MPI_BCAST( cg%dzu, cg%nz+1, MPI_REAL, 0, comm2d, ierr )
1402	CALL MPI_BCAST( cg%dzw, cg%nz+1, MPI_REAL, 0, comm2d, ierr )
1403	CALL MPI_BCAST( cg%zu, cg%nz+2, MPI_REAL, 0, comm2d, ierr )
1404	CALL MPI_BCAST( cg%zw, cg%nz+2, MPI_REAL, 0, comm2d, ierr )
1405	CALL MPI_BCAST( rans_mode_parent, 1, MPI_LOGICAL, 0, comm2d, ierr )
1406	!
1407	!-- Find the index bounds for the nest domain in the coarse-grid index space
1408	CALL pmci_map_fine_to_coarse_grid
1409	!
1410	!-- TO_DO: Klaus give a comment what is happening here
1411	CALL pmc_c_get_2d_index_list
1412	!
1413	!-- Include couple arrays into child content
1414	!-- TO_DO: Klaus: better explain the above comment (what is child content?)
1415	CALL pmc_c_clear_next_array_list
1416
1417	n = 1
1418	DO WHILE ( pmc_c_getnextarray( myname ) )
1419	!-- Note that cg%nz is not the original nz of parent, but the highest
1420	!-- parent-grid level needed for nesting.
1421	!-- Please note, in case of chemical species an additional parameter
1422	!-- need to be passed, which is required to set the pointer correctly
1423	!-- to the chemical-species data structure. Hence, first check if current
1424	!-- variable is a chemical species. If so, pass index id of respective
1425	!-- species and increment this subsequently.
1426	IF ( INDEX( TRIM( myname ), 'chem_' ) /= 0 ) THEN
1427	CALL pmci_create_child_arrays ( myname, icl, icr, jcs, jcn, cg%nz, n )
1428	n = n + 1
1429	ELSE
1430	CALL pmci_create_child_arrays ( myname, icl, icr, jcs, jcn, cg%nz )
1431	ENDIF
1432	ENDDO
1433	CALL pmc_c_setind_and_allocmem
1434	!
1435	!-- Precompute interpolation coefficients and child-array indices
1436	CALL pmci_init_interp_tril
1437	!
1438	!-- Precompute the log-law correction index- and ratio-arrays
1439	IF ( constant_flux_layer ) THEN
1440	CALL pmci_init_loglaw_correction
1441	ENDIF
1442	!
1443	!-- Define the SGS-TKE scaling factor based on the grid-spacing ratio. Only
1444	!-- if both parent and child are in LES mode or in RANS mode.
1445	!-- Please note, in case parent and child are in RANS mode, TKE weighting
1446	!-- factor is simply one.
1447	IF ( ( rans_mode_parent .AND. rans_mode ) .OR. &
1448	( .NOT. rans_mode_parent .AND. .NOT. rans_mode .AND. &
1449	.NOT. constant_diffusion ) ) CALL pmci_init_tkefactor
1450	!
1451	!-- Two-way coupling for general and vertical nesting.
1452	!-- Precompute the index arrays and relaxation functions for the
1453	!-- anterpolation
1454	!
1455	!-- Note that the anterpolation index bounds are needed also in case
1456	!-- of one-way coupling because of the reversibility correction
1457	!-- included in the interpolation algorithms.
1458	CALL pmci_init_anterp_tophat
1459	!
1460	!-- Finally, compute the total area of the top-boundary face of the domain.
1461	!-- This is needed in the pmc_ensure_nest_mass_conservation
1462	area_t = ( nx + 1 ) * (ny + 1 ) * dx * dy
1463
1464	ENDIF
1465
1466	CONTAINS
1467
1468
1469	SUBROUTINE pmci_map_fine_to_coarse_grid
1470	!
1471	!-- Determine index bounds of interpolation/anterpolation area in the coarse
1472	!-- grid index space
1473	IMPLICIT NONE
1474
1475	INTEGER(iwp), DIMENSION(5,numprocs) :: coarse_bound_all !<
1476	INTEGER(iwp), DIMENSION(2) :: size_of_array !<
1477
1478	INTEGER(iwp) :: i !<
1479	INTEGER(iwp) :: ijaux !<
1480	INTEGER(iwp) :: j !<
1481	REAL(wp) :: loffset !<
1482	REAL(wp) :: noffset !<
1483	REAL(wp) :: roffset !<
1484	REAL(wp) :: soffset !<
1485
1486	!
1487	!-- If the fine- and coarse grid nodes do not match:
1488	loffset = MOD( coord_x(nxl), cg%dx )
1489	xexl = cg%dx + loffset
1490	!
1491	!-- This is needed in the anterpolation phase
1492	nhll = CEILING( xexl / cg%dx )
1493	xcs = coord_x(nxl) - xexl
1494	DO i = 0, cg%nx
1495	IF ( cg%coord_x(i) > xcs ) THEN
1496	icl = MAX( -1, i-1 )
1497	EXIT
1498	ENDIF
1499	ENDDO
1500	!
1501	!-- If the fine- and coarse grid nodes do not match
1502	roffset = MOD( coord_x(nxr+1), cg%dx )
1503	xexr = cg%dx + roffset
1504	!
1505	!-- This is needed in the anterpolation phase
1506	nhlr = CEILING( xexr / cg%dx )
1507	xce = coord_x(nxr+1) + xexr
1508	!-- One "extra" layer is taken behind the right boundary
1509	!-- because it may be needed in cases of non-integer grid-spacing ratio
1510	DO i = cg%nx, 0 , -1
1511	IF ( cg%coord_x(i) < xce ) THEN
1512	icr = MIN( cg%nx+1, i+1 )
1513	EXIT
1514	ENDIF
1515	ENDDO
1516	!
1517	!-- If the fine- and coarse grid nodes do not match
1518	soffset = MOD( coord_y(nys), cg%dy )
1519	yexs = cg%dy + soffset
1520	!
1521	!-- This is needed in the anterpolation phase
1522	nhls = CEILING( yexs / cg%dy )
1523	ycs = coord_y(nys) - yexs
1524	DO j = 0, cg%ny
1525	IF ( cg%coord_y(j) > ycs ) THEN
1526	jcs = MAX( -nbgp, j-1 )
1527	EXIT
1528	ENDIF
1529	ENDDO
1530	!
1531	!-- If the fine- and coarse grid nodes do not match
1532	noffset = MOD( coord_y(nyn+1), cg%dy )
1533	yexn = cg%dy + noffset
1534	!
1535	!-- This is needed in the anterpolation phase
1536	nhln = CEILING( yexn / cg%dy )
1537	yce = coord_y(nyn+1) + yexn
1538	!-- One "extra" layer is taken behind the north boundary
1539	!-- because it may be needed in cases of non-integer grid-spacing ratio
1540	DO j = cg%ny, 0, -1
1541	IF ( cg%coord_y(j) < yce ) THEN
1542	jcn = MIN( cg%ny + nbgp, j+1 )
1543	EXIT
1544	ENDIF
1545	ENDDO
1546
1547	coarse_bound(1) = icl
1548	coarse_bound(2) = icr
1549	coarse_bound(3) = jcs
1550	coarse_bound(4) = jcn
1551	coarse_bound(5) = myid
1552	!
1553	!-- Determine the anterpolation index limits. If at least half of the
1554	!-- parent-grid cell is within the current child sub-domain, then it
1555	!-- is included in the current sub-domain's anterpolation domain.
1556	!-- Else the parent-grid cell is included in the neighbouring subdomain's
1557	!-- anterpolation domain, or not included at all if we are at the outer
1558	!-- edge of the child domain.
1559	DO i = 0, cg%nx
1560	IF ( cg%coord_x(i) + 0.5_wp * cg%dx >= coord_x(nxl) ) THEN
1561	icla = MAX( 0, i )
1562	EXIT
1563	ENDIF
1564	ENDDO
1565	DO i = cg%nx, 0 , -1
1566	IF ( cg%coord_x(i) + 0.5_wp * cg%dx <= coord_x(nxr+1) ) THEN
1567	icra = MIN( cg%nx, i )
1568	EXIT
1569	ENDIF
1570	ENDDO
1571	DO j = 0, cg%ny
1572	IF ( cg%coord_y(j) + 0.5_wp * cg%dy >= coord_y(nys) ) THEN
1573	jcsa = MAX( 0, j )
1574	EXIT
1575	ENDIF
1576	ENDDO
1577	DO j = cg%ny, 0 , -1
1578	IF ( cg%coord_y(j) + 0.5_wp * cg%dy <= coord_y(nyn+1) ) THEN
1579	jcna = MIN( cg%ny, j )
1580	EXIT
1581	ENDIF
1582	ENDDO
1583	!
1584	!-- Make sure that the indexing is contiguous
1585	IF ( nxl == 0 ) THEN
1586	CALL MPI_SEND( icra, 1, MPI_INTEGER, pright, 717, comm2d, ierr )
1587	ELSE IF ( nxr == nx ) THEN
1588	CALL MPI_RECV( ijaux, 1, MPI_INTEGER, pleft, 717, comm2d, status, ierr )
1589	icla = ijaux + 1
1590	ELSE
1591	CALL MPI_SEND( icra, 1, MPI_INTEGER, pright, 717, comm2d, ierr )
1592	CALL MPI_RECV( ijaux, 1, MPI_INTEGER, pleft, 717, comm2d, status, ierr )
1593	icla = ijaux + 1
1594	ENDIF
1595	IF ( nys == 0 ) THEN
1596	CALL MPI_SEND( jcna, 1, MPI_INTEGER, pnorth, 719, comm2d, ierr )
1597	ELSE IF ( nyn == ny ) THEN
1598	CALL MPI_RECV( ijaux, 1, MPI_INTEGER, psouth, 719, comm2d, status, ierr )
1599	jcsa = ijaux + 1
1600	ELSE
1601	CALL MPI_SEND( jcna, 1, MPI_INTEGER, pnorth, 719, comm2d, ierr )
1602	CALL MPI_RECV( ijaux, 1, MPI_INTEGER, psouth, 719, comm2d, status, ierr )
1603	jcsa = ijaux + 1
1604	ENDIF
1605
1606	write(9,"('Anterpolation bounds: ',4(i3,2x))") icla, icra, jcsa, jcna
1607	flush(9)
1608	coarse_bound_anterp(1) = icla
1609	coarse_bound_anterp(2) = icra
1610	coarse_bound_anterp(3) = jcsa
1611	coarse_bound_anterp(4) = jcna
1612	!
1613	!-- Note that MPI_Gather receives data from all processes in the rank order
1614	!-- TO_DO: refer to the line where this fact becomes important
1615	CALL MPI_GATHER( coarse_bound, 5, MPI_INTEGER, coarse_bound_all, 5, &
1616	MPI_INTEGER, 0, comm2d, ierr )
1617
1618	IF ( myid == 0 ) THEN
1619	size_of_array(1) = SIZE( coarse_bound_all, 1 )
1620	size_of_array(2) = SIZE( coarse_bound_all, 2 )
1621	CALL pmc_send_to_parent( size_of_array, 2, 0, 40, ierr )
1622	CALL pmc_send_to_parent( coarse_bound_all, SIZE( coarse_bound_all ), &
1623	0, 41, ierr )
1624	ENDIF
1625
1626	END SUBROUTINE pmci_map_fine_to_coarse_grid
1627
1628
1629
1630	SUBROUTINE pmci_init_interp_tril
1631	!
1632	!-- Precomputation of the interpolation coefficients and child-array indices
1633	!-- to be used by the interpolation routines interp_tril_lr, interp_tril_ns
1634	!-- and interp_tril_t.
1635
1636	IMPLICIT NONE
1637
1638	INTEGER(iwp) :: acsize !<
1639	INTEGER(iwp) :: i !<
1640	INTEGER(iwp) :: j !<
1641	INTEGER(iwp) :: k !<
1642	INTEGER(iwp) :: kc !<
1643	INTEGER(iwp) :: kdzo !<
1644	INTEGER(iwp) :: kdzw !<
1645
1646	REAL(wp) :: dzmin !<
1647	REAL(wp) :: parentdzmax !<
1648	REAL(wp) :: xb !<
1649	REAL(wp) :: xcsu !<
1650	REAL(wp) :: xfso !<
1651	REAL(wp) :: xcso !<
1652	REAL(wp) :: xfsu !<
1653	REAL(wp) :: yb !<
1654	REAL(wp) :: ycso !<
1655	REAL(wp) :: ycsv !<
1656	REAL(wp) :: yfso !<
1657	REAL(wp) :: yfsv !<
1658	REAL(wp) :: zcso !<
1659	REAL(wp) :: zcsw !<
1660	REAL(wp) :: zfso !<
1661	REAL(wp) :: zfsw !<
1662
1663
1664	xb = nxl * dx
1665	yb = nys * dy
1666
1667	ALLOCATE( icu(nxlg:nxrg) )
1668	ALLOCATE( ico(nxlg:nxrg) )
1669	ALLOCATE( jcv(nysg:nyng) )
1670	ALLOCATE( jco(nysg:nyng) )
1671	ALLOCATE( kcw(nzb:nzt+1) )
1672	ALLOCATE( kco(nzb:nzt+1) )
1673	ALLOCATE( r1xu(nxlg:nxrg) )
1674	ALLOCATE( r2xu(nxlg:nxrg) )
1675	ALLOCATE( r1xo(nxlg:nxrg) )
1676	ALLOCATE( r2xo(nxlg:nxrg) )
1677	ALLOCATE( r1yv(nysg:nyng) )
1678	ALLOCATE( r2yv(nysg:nyng) )
1679	ALLOCATE( r1yo(nysg:nyng) )
1680	ALLOCATE( r2yo(nysg:nyng) )
1681	ALLOCATE( r1zw(nzb:nzt+1) )
1682	ALLOCATE( r2zw(nzb:nzt+1) )
1683	ALLOCATE( r1zo(nzb:nzt+1) )
1684	ALLOCATE( r2zo(nzb:nzt+1) )
1685	!
1686	!-- Note that the node coordinates xfs... and xcs... are relative to the
1687	!-- lower-left-bottom corner of the fc-array, not the actual child domain
1688	!-- corner
1689	DO i = nxlg, nxrg
1690	xfsu = coord_x(i) - ( lower_left_coord_x + xb - xexl )
1691	xfso = coord_x(i) + 0.5_wp * dx - ( lower_left_coord_x + xb - xexl )
1692	icu(i) = icl + FLOOR( xfsu / cg%dx )
1693	ico(i) = icl + FLOOR( ( xfso - 0.5_wp * cg%dx ) / cg%dx )
1694	xcsu = ( icu(i) - icl ) * cg%dx
1695	xcso = ( ico(i) - icl ) * cg%dx + 0.5_wp * cg%dx
1696	r2xu(i) = ( xfsu - xcsu ) / cg%dx
1697	r2xo(i) = ( xfso - xcso ) / cg%dx
1698	r1xu(i) = 1.0_wp - r2xu(i)
1699	r1xo(i) = 1.0_wp - r2xo(i)
1700	ENDDO
1701
1702	DO j = nysg, nyng
1703	yfsv = coord_y(j) - ( lower_left_coord_y + yb - yexs )
1704	yfso = coord_y(j) + 0.5_wp * dy - ( lower_left_coord_y + yb - yexs )
1705	jcv(j) = jcs + FLOOR( yfsv / cg%dy )
1706	jco(j) = jcs + FLOOR( ( yfso -0.5_wp * cg%dy ) / cg%dy )
1707	ycsv = ( jcv(j) - jcs ) * cg%dy
1708	ycso = ( jco(j) - jcs ) * cg%dy + 0.5_wp * cg%dy
1709	r2yv(j) = ( yfsv - ycsv ) / cg%dy
1710	r2yo(j) = ( yfso - ycso ) / cg%dy
1711	r1yv(j) = 1.0_wp - r2yv(j)
1712	r1yo(j) = 1.0_wp - r2yo(j)
1713	ENDDO
1714
1715	DO k = nzb, nzt + 1
1716	zfsw = zw(k)
1717	zfso = zu(k)
1718
1719	DO kc = 0, cg%nz+1
1720	IF ( cg%zw(kc) > zfsw ) EXIT
1721	ENDDO
1722	kcw(k) = kc - 1
1723
1724	DO kc = 0, cg%nz+1
1725	IF ( cg%zu(kc) > zfso ) EXIT
1726	ENDDO
1727	kco(k) = kc - 1
1728
1729	zcsw = cg%zw(kcw(k))
1730	zcso = cg%zu(kco(k))
1731	kdzw = MIN( kcw(k)+1, cg%nz+1 )
1732	kdzo = MIN( kco(k)+1, cg%nz+1 )
1733	r2zw(k) = ( zfsw - zcsw ) / cg%dzw(kdzw)
1734	r2zo(k) = ( zfso - zcso ) / cg%dzu(kdzo)
1735	r1zw(k) = 1.0_wp - r2zw(k)
1736	r1zo(k) = 1.0_wp - r2zo(k)
1737	ENDDO
1738	!
1739	!-- Determine the maximum dimension of anterpolation cells and allocate the
1740	!-- work array celltmpd needed in the reversibility correction in the
1741	!-- interpolation
1742	dzmin = 999999.9_wp
1743	DO k = 1, nzt+1
1744	dzmin = MIN( dzmin, dzu(k), dzw(k) )
1745	ENDDO
1746	parentdzmax = 0.0_wp
1747	DO k = 1, cg%nz+1
1748	parentdzmax = MAX(parentdzmax , cg%dzu(k), cg%dzw(k) )
1749	ENDDO
1750	acsize = CEILING( cg%dx / dx ) * CEILING( cg%dy / dy ) * &
1751	CEILING( parentdzmax / dzmin )
1752	ALLOCATE( celltmpd(1:acsize) )
1753	! write(9,"('acsize: ',i3,2(e12.5,2x))") acsize, dzmin, parentdzmax
1754
1755	END SUBROUTINE pmci_init_interp_tril
1756
1757
1758
1759	SUBROUTINE pmci_init_loglaw_correction
1760	!
1761	!-- Precomputation of the index and log-ratio arrays for the log-law
1762	!-- corrections for near-wall nodes after the nest-BC interpolation.
1763	!-- These are used by the interpolation routines interp_tril_lr and
1764	!-- interp_tril_ns.
1765
1766	IMPLICIT NONE
1767
1768	INTEGER(iwp) :: direction !< Wall normal index: 1=k, 2=j, 3=i.
1769	INTEGER(iwp) :: dum !< dummy value for reduce operation
1770	INTEGER(iwp) :: i !<
1771	INTEGER(iwp) :: ierr !< MPI status
1772	INTEGER(iwp) :: inc !< Wall outward-normal index increment -1
1773	!< or 1, for direction=1, inc=1 always
1774	INTEGER(iwp) :: j !<
1775	INTEGER(iwp) :: k !<
1776	INTEGER(iwp) :: k_wall_u_ji !< topography top index on u-grid
1777	INTEGER(iwp) :: k_wall_u_ji_p !< topography top index on u-grid
1778	INTEGER(iwp) :: k_wall_u_ji_m !< topography top index on u-grid
1779	INTEGER(iwp) :: k_wall_v_ji !< topography top index on v-grid
1780	INTEGER(iwp) :: k_wall_v_ji_p !< topography top index on v-grid
1781	INTEGER(iwp) :: k_wall_v_ji_m !< topography top index on v-grid
1782	INTEGER(iwp) :: k_wall_w_ji !< topography top index on w-grid
1783	INTEGER(iwp) :: k_wall_w_ji_p !< topography top index on w-grid
1784	INTEGER(iwp) :: k_wall_w_ji_m !< topography top index on w-grid
1785	INTEGER(iwp) :: kb !<
1786	INTEGER(iwp) :: lc !<
1787	INTEGER(iwp) :: ni !<
1788	INTEGER(iwp) :: nj !<
1789	INTEGER(iwp) :: nk !<
1790	INTEGER(iwp) :: nzt_topo_max !<
1791	INTEGER(iwp) :: wall_index !< Index of the wall-node coordinate
1792
1793	REAL(wp) :: z0_topo !< roughness at vertical walls
1794	REAL(wp), ALLOCATABLE, DIMENSION(:) :: lcr !<
1795
1796	!
1797	!-- First determine the maximum k-index needed for the near-wall corrections.
1798	!-- This maximum is individual for each boundary to minimize the storage
1799	!-- requirements and to minimize the corresponding loop k-range in the
1800	!-- interpolation routines.
1801	nzt_topo_nestbc_l = nzb
1802	IF ( bc_dirichlet_l ) THEN
1803	DO i = nxl-1, nxl
1804	DO j = nys, nyn
1805	!
1806	!-- Concept need to be reconsidered for 3D-topography
1807	!-- Determine largest topography index on scalar grid
1808	nzt_topo_nestbc_l = MAX( nzt_topo_nestbc_l, &
1809	get_topography_top_index_ji( j, i, 's' ) )
1810	!
1811	!-- Determine largest topography index on u grid
1812	nzt_topo_nestbc_l = MAX( nzt_topo_nestbc_l, &
1813	get_topography_top_index_ji( j, i, 'u' ) )
1814	!
1815	!-- Determine largest topography index on v grid
1816	nzt_topo_nestbc_l = MAX( nzt_topo_nestbc_l, &
1817	get_topography_top_index_ji( j, i, 'v' ) )
1818	!
1819	!-- Determine largest topography index on w grid
1820	nzt_topo_nestbc_l = MAX( nzt_topo_nestbc_l, &
1821	get_topography_top_index_ji( j, i, 'w' ) )
1822	ENDDO
1823	ENDDO
1824	nzt_topo_nestbc_l = nzt_topo_nestbc_l + 1
1825	ENDIF
1826
1827	nzt_topo_nestbc_r = nzb
1828	IF ( bc_dirichlet_r ) THEN
1829	i = nxr + 1
1830	DO j = nys, nyn
1831	!
1832	!-- Concept need to be reconsidered for 3D-topography
1833	!-- Determine largest topography index on scalar grid
1834	nzt_topo_nestbc_r = MAX( nzt_topo_nestbc_r, &
1835	get_topography_top_index_ji( j, i, 's' ) )
1836	!
1837	!-- Determine largest topography index on u grid
1838	nzt_topo_nestbc_r = MAX( nzt_topo_nestbc_r, &
1839	get_topography_top_index_ji( j, i, 'u' ) )
1840	!
1841	!-- Determine largest topography index on v grid
1842	nzt_topo_nestbc_r = MAX( nzt_topo_nestbc_r, &
1843	get_topography_top_index_ji( j, i, 'v' ) )
1844	!
1845	!-- Determine largest topography index on w grid
1846	nzt_topo_nestbc_r = MAX( nzt_topo_nestbc_r, &
1847	get_topography_top_index_ji( j, i, 'w' ) )
1848	ENDDO
1849	nzt_topo_nestbc_r = nzt_topo_nestbc_r + 1
1850	ENDIF
1851
1852	nzt_topo_nestbc_s = nzb
1853	IF ( bc_dirichlet_s ) THEN
1854	DO j = nys-1, nys
1855	DO i = nxl, nxr
1856	!
1857	!-- Concept need to be reconsidered for 3D-topography
1858	!-- Determine largest topography index on scalar grid
1859	nzt_topo_nestbc_s = MAX( nzt_topo_nestbc_s, &
1860	get_topography_top_index_ji( j, i, 's' ) )
1861	!
1862	!-- Determine largest topography index on u grid
1863	nzt_topo_nestbc_s = MAX( nzt_topo_nestbc_s, &
1864	get_topography_top_index_ji( j, i, 'u' ) )
1865	!
1866	!-- Determine largest topography index on v grid
1867	nzt_topo_nestbc_s = MAX( nzt_topo_nestbc_s, &
1868	get_topography_top_index_ji( j, i, 'v' ) )
1869	!
1870	!-- Determine largest topography index on w grid
1871	nzt_topo_nestbc_s = MAX( nzt_topo_nestbc_s, &
1872	get_topography_top_index_ji( j, i, 'w' ) )
1873	ENDDO
1874	ENDDO
1875	nzt_topo_nestbc_s = nzt_topo_nestbc_s + 1
1876	ENDIF
1877
1878	nzt_topo_nestbc_n = nzb
1879	IF ( bc_dirichlet_n ) THEN
1880	j = nyn + 1
1881	DO i = nxl, nxr
1882	!
1883	!-- Concept need to be reconsidered for 3D-topography
1884	!-- Determine largest topography index on scalar grid
1885	nzt_topo_nestbc_n = MAX( nzt_topo_nestbc_n, &
1886	get_topography_top_index_ji( j, i, 's' ) )
1887	!
1888	!-- Determine largest topography index on u grid
1889	nzt_topo_nestbc_n = MAX( nzt_topo_nestbc_n, &
1890	get_topography_top_index_ji( j, i, 'u' ) )
1891	!
1892	!-- Determine largest topography index on v grid
1893	nzt_topo_nestbc_n = MAX( nzt_topo_nestbc_n, &
1894	get_topography_top_index_ji( j, i, 'v' ) )
1895	!
1896	!-- Determine largest topography index on w grid
1897	nzt_topo_nestbc_n = MAX( nzt_topo_nestbc_n, &
1898	get_topography_top_index_ji( j, i, 'w' ) )
1899	ENDDO
1900	nzt_topo_nestbc_n = nzt_topo_nestbc_n + 1
1901	ENDIF
1902
1903	#if defined( __parallel )
1904	!
1905	!-- Determine global topography-top index along child boundary.
1906	dum = nzb
1907	CALL MPI_ALLREDUCE( nzt_topo_nestbc_l, dum, 1, MPI_INTEGER, &
1908	MPI_MAX, comm1dy, ierr )
1909	nzt_topo_nestbc_l = dum
1910
1911	dum = nzb
1912	CALL MPI_ALLREDUCE( nzt_topo_nestbc_r, dum, 1, MPI_INTEGER, &
1913	MPI_MAX, comm1dy, ierr )
1914	nzt_topo_nestbc_r = dum
1915
1916	dum = nzb
1917	CALL MPI_ALLREDUCE( nzt_topo_nestbc_n, dum, 1, MPI_INTEGER, &
1918	MPI_MAX, comm1dx, ierr )
1919	nzt_topo_nestbc_n = dum
1920
1921	dum = nzb
1922	CALL MPI_ALLREDUCE( nzt_topo_nestbc_s, dum, 1, MPI_INTEGER, &
1923	MPI_MAX, comm1dx, ierr )
1924	nzt_topo_nestbc_s = dum
1925	#endif
1926	!
1927	!-- Then determine the maximum number of near-wall nodes per wall point based
1928	!-- on the grid-spacing ratios.
1929	nzt_topo_max = MAX( nzt_topo_nestbc_l, nzt_topo_nestbc_r, &
1930	nzt_topo_nestbc_s, nzt_topo_nestbc_n )
1931	!
1932	!-- Note that the outer division must be integer division.
1933	ni = CEILING( cg%dx / dx ) / 2
1934	nj = CEILING( cg%dy / dy ) / 2
1935	nk = 1
1936	DO k = 1, nzt_topo_max
1937	nk = MAX( nk, CEILING( cg%dzu(kco(k)+1) / dzu(k) ) )
1938	ENDDO
1939	nk = nk / 2 ! Note that this must be integer division.
1940	ncorr = MAX( ni, nj, nk )
1941
1942	ALLOCATE( lcr(0:ncorr-1) )
1943	lcr = 1.0_wp
1944
1945	z0_topo = roughness_length
1946	!
1947	!-- First horizontal walls. Note that also logc_w_? and logc_ratio_w_? and
1948	!-- logc_kbounds_* need to be allocated and initialized here.
1949	!-- Left boundary
1950	IF ( bc_dirichlet_l ) THEN
1951
1952	ALLOCATE( logc_u_l(1:2,nzb:nzt_topo_nestbc_l,nys:nyn) )
1953	ALLOCATE( logc_v_l(1:2,nzb:nzt_topo_nestbc_l,nys:nyn) )
1954	ALLOCATE( logc_w_l(1:2,nzb:nzt_topo_nestbc_l,nys:nyn) )
1955	ALLOCATE( logc_kbounds_u_l(1:2,nys:nyn) )
1956	ALLOCATE( logc_kbounds_v_l(1:2,nys:nyn) )
1957	ALLOCATE( logc_kbounds_w_l(1:2,nys:nyn) )
1958	ALLOCATE( logc_ratio_u_l(1:2,0:ncorr-1,nzb:nzt_topo_nestbc_l,nys:nyn) )
1959	ALLOCATE( logc_ratio_v_l(1:2,0:ncorr-1,nzb:nzt_topo_nestbc_l,nys:nyn) )
1960	ALLOCATE( logc_ratio_w_l(1:2,0:ncorr-1,nzb:nzt_topo_nestbc_l,nys:nyn) )
1961	logc_u_l = 0
1962	logc_v_l = 0
1963	logc_w_l = 0
1964	logc_ratio_u_l = 1.0_wp
1965	logc_ratio_v_l = 1.0_wp
1966	logc_ratio_w_l = 1.0_wp
1967	direction = 1
1968	inc = 1
1969
1970	DO j = nys, nyn
1971	!
1972	!-- Left boundary for u
1973	i = 0
1974	!
1975	!-- For loglaw correction the roughness z0 is required. z0, however,
1976	!-- is part of the surfacetypes now. Set default roughness instead.
1977	!-- Determine topography top index on u-grid
1978	kb = get_topography_top_index_ji( j, i, 'u' )
1979	k = kb + 1
1980	wall_index = kb
1981
1982	CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, &
1983	j, inc, wall_index, z0_topo, &
1984	kb, direction, ncorr )
1985
1986	logc_u_l(1,k,j) = lc
1987	logc_ratio_u_l(1,0:ncorr-1,k,j) = lcr(0:ncorr-1)
1988	lcr(0:ncorr-1) = 1.0_wp
1989	!
1990	!-- Left boundary for v
1991	i = -1
1992	!
1993	!-- Determine topography top index on v-grid
1994	kb = get_topography_top_index_ji( j, i, 'v' )
1995	k = kb + 1
1996	wall_index = kb
1997
1998	CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, &
1999	j, inc, wall_index, z0_topo, &
2000	kb, direction, ncorr )
2001
2002	logc_v_l(1,k,j) = lc
2003	logc_ratio_v_l(1,0:ncorr-1,k,j) = lcr(0:ncorr-1)
2004	lcr(0:ncorr-1) = 1.0_wp
2005
2006	ENDDO
2007
2008	ENDIF
2009	!
2010	!-- Right boundary
2011	IF ( bc_dirichlet_r ) THEN
2012
2013	ALLOCATE( logc_u_r(1:2,nzb:nzt_topo_nestbc_r,nys:nyn) )
2014	ALLOCATE( logc_v_r(1:2,nzb:nzt_topo_nestbc_r,nys:nyn) )
2015	ALLOCATE( logc_w_r(1:2,nzb:nzt_topo_nestbc_r,nys:nyn) )
2016	ALLOCATE( logc_kbounds_u_r(1:2,nys:nyn) )
2017	ALLOCATE( logc_kbounds_v_r(1:2,nys:nyn) )
2018	ALLOCATE( logc_kbounds_w_r(1:2,nys:nyn) )
2019	ALLOCATE( logc_ratio_u_r(1:2,0:ncorr-1,nzb:nzt_topo_nestbc_r,nys:nyn) )
2020	ALLOCATE( logc_ratio_v_r(1:2,0:ncorr-1,nzb:nzt_topo_nestbc_r,nys:nyn) )
2021	ALLOCATE( logc_ratio_w_r(1:2,0:ncorr-1,nzb:nzt_topo_nestbc_r,nys:nyn) )
2022	logc_u_r = 0
2023	logc_v_r = 0
2024	logc_w_r = 0
2025	logc_ratio_u_r = 1.0_wp
2026	logc_ratio_v_r = 1.0_wp
2027	logc_ratio_w_r = 1.0_wp
2028	direction = 1
2029	inc = 1
2030
2031	DO j = nys, nyn
2032	!
2033	!-- Right boundary for u
2034	i = nxr + 1
2035	!
2036	!-- For loglaw correction the roughness z0 is required. z0, however,
2037	!-- is part of the surfacetypes now, so call subroutine according
2038	!-- to the present surface tpye.
2039	!-- Determine topography top index on u-grid
2040	kb = get_topography_top_index_ji( j, i, 'u' )
2041	k = kb + 1
2042	wall_index = kb
2043
2044	CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, &
2045	j, inc, wall_index, z0_topo, &
2046	kb, direction, ncorr )
2047
2048	logc_u_r(1,k,j) = lc
2049	logc_ratio_u_r(1,0:ncorr-1,k,j) = lcr(0:ncorr-1)
2050	lcr(0:ncorr-1) = 1.0_wp
2051	!
2052	!-- Right boundary for v
2053	i = nxr + 1
2054	!
2055	!-- Determine topography top index on v-grid
2056	kb = get_topography_top_index_ji( j, i, 'v' )
2057	k = kb + 1
2058	wall_index = kb
2059
2060	CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, &
2061	j, inc, wall_index, z0_topo, &
2062	kb, direction, ncorr )
2063
2064	logc_v_r(1,k,j) = lc
2065	logc_ratio_v_r(1,0:ncorr-1,k,j) = lcr(0:ncorr-1)
2066	lcr(0:ncorr-1) = 1.0_wp
2067
2068	ENDDO
2069
2070	ENDIF
2071	!
2072	!-- South boundary
2073	IF ( bc_dirichlet_s ) THEN
2074
2075	ALLOCATE( logc_u_s(1:2,nzb:nzt_topo_nestbc_s,nxl:nxr) )
2076	ALLOCATE( logc_v_s(1:2,nzb:nzt_topo_nestbc_s,nxl:nxr) )
2077	ALLOCATE( logc_w_s(1:2,nzb:nzt_topo_nestbc_s,nxl:nxr) )
2078	ALLOCATE( logc_kbounds_u_s(1:2,nxl:nxr) )
2079	ALLOCATE( logc_kbounds_v_s(1:2,nxl:nxr) )
2080	ALLOCATE( logc_kbounds_w_s(1:2,nxl:nxr) )
2081	ALLOCATE( logc_ratio_u_s(1:2,0:ncorr-1,nzb:nzt_topo_nestbc_s,nxl:nxr) )
2082	ALLOCATE( logc_ratio_v_s(1:2,0:ncorr-1,nzb:nzt_topo_nestbc_s,nxl:nxr) )
2083	ALLOCATE( logc_ratio_w_s(1:2,0:ncorr-1,nzb:nzt_topo_nestbc_s,nxl:nxr) )
2084	logc_u_s = 0
2085	logc_v_s = 0
2086	logc_w_s = 0
2087	logc_ratio_u_s = 1.0_wp
2088	logc_ratio_v_s = 1.0_wp
2089	logc_ratio_w_s = 1.0_wp
2090	direction = 1
2091	inc = 1
2092
2093	DO i = nxl, nxr
2094	!
2095	!-- South boundary for u
2096	j = -1
2097	!
2098	!-- Determine topography top index on u-grid
2099	kb = get_topography_top_index_ji( j, i, 'u' )
2100	k = kb + 1
2101	wall_index = kb
2102
2103	CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, &
2104	j, inc, wall_index, z0_topo, &
2105	kb, direction, ncorr )
2106
2107	logc_u_s(1,k,i) = lc
2108	logc_ratio_u_s(1,0:ncorr-1,k,i) = lcr(0:ncorr-1)
2109	lcr(0:ncorr-1) = 1.0_wp
2110	!
2111	!-- South boundary for v
2112	j = 0
2113	!
2114	!-- Determine topography top index on v-grid
2115	kb = get_topography_top_index_ji( j, i, 'v' )
2116	k = kb + 1
2117	wall_index = kb
2118
2119	CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, &
2120	j, inc, wall_index, z0_topo, &
2121	kb, direction, ncorr )
2122
2123	logc_v_s(1,k,i) = lc
2124	logc_ratio_v_s(1,0:ncorr-1,k,i) = lcr(0:ncorr-1)
2125	lcr(0:ncorr-1) = 1.0_wp
2126
2127	ENDDO
2128
2129	ENDIF
2130	!
2131	!-- North boundary
2132	IF ( bc_dirichlet_n ) THEN
2133
2134	ALLOCATE( logc_u_n(1:2,nzb:nzt_topo_nestbc_n,nxl:nxr) )
2135	ALLOCATE( logc_v_n(1:2,nzb:nzt_topo_nestbc_n,nxl:nxr) )
2136	ALLOCATE( logc_w_n(1:2,nzb:nzt_topo_nestbc_n,nxl:nxr) )
2137	ALLOCATE( logc_kbounds_u_n(1:2,nxl:nxr) )
2138	ALLOCATE( logc_kbounds_v_n(1:2,nxl:nxr) )
2139	ALLOCATE( logc_kbounds_w_n(1:2,nxl:nxr) )
2140	ALLOCATE( logc_ratio_u_n(1:2,0:ncorr-1,nzb:nzt_topo_nestbc_n,nxl:nxr) )
2141	ALLOCATE( logc_ratio_v_n(1:2,0:ncorr-1,nzb:nzt_topo_nestbc_n,nxl:nxr) )
2142	ALLOCATE( logc_ratio_w_n(1:2,0:ncorr-1,nzb:nzt_topo_nestbc_n,nxl:nxr) )
2143	logc_u_n = 0
2144	logc_v_n = 0
2145	logc_w_n = 0
2146	logc_ratio_u_n = 1.0_wp
2147	logc_ratio_v_n = 1.0_wp
2148	logc_ratio_w_n = 1.0_wp
2149	direction = 1
2150	inc = 1
2151
2152	DO i = nxl, nxr
2153	!
2154	!-- North boundary for u
2155	j = nyn + 1
2156	!
2157	!-- Determine topography top index on u-grid
2158	kb = get_topography_top_index_ji( j, i, 'u' )
2159	k = kb + 1
2160	wall_index = kb
2161
2162	CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, &
2163	j, inc, wall_index, z0_topo, &
2164	kb, direction, ncorr )
2165
2166	logc_u_n(1,k,i) = lc
2167	logc_ratio_u_n(1,0:ncorr-1,k,i) = lcr(0:ncorr-1)
2168	lcr(0:ncorr-1) = 1.0_wp
2169	!
2170	!-- North boundary for v
2171	j = nyn + 1
2172	!
2173	!-- Determine topography top index on v-grid
2174	kb = get_topography_top_index_ji( j, i, 'v' )
2175	k = kb + 1
2176	wall_index = kb
2177
2178	CALL pmci_define_loglaw_correction_parameters( lc, lcr, k, &
2179	j, inc, wall_index, z0_topo, &
2180	kb, direction, ncorr )
2181	logc_v_n(1,k,i) = lc
2182	logc_ratio_v_n(1,0:ncorr-1,k,i) = lcr(0:ncorr-1)
2183	lcr(0:ncorr-1) = 1.0_wp
2184
2185	ENDDO
2186
2187	ENDIF
2188	!
2189	!-- Then vertical walls and corners if necessary
2190	IF ( topography /= 'flat' ) THEN
2191	!
2192	!-- Workaround, set z0 at vertical surfaces simply to the given roughness
2193	!-- lenth, which is required to determine the logarithmic correction
2194	!-- factors at the child boundaries, which are at the ghost-points.
2195	!-- The surface data type for vertical surfaces, however, is not defined
2196	!-- at ghost-points, so that no z0 can be retrieved at this point.
2197	!-- Maybe, revise this later and define vertical surface datattype also
2198	!-- at ghost-points.
2199	z0_topo = roughness_length
2200
2201	kb = 0 ! kb is not used when direction > 1
2202	!
2203	!-- Left boundary
2204	IF ( bc_dirichlet_l ) THEN
2205	logc_kbounds_u_l(1:2,nys:nyn) = 0
2206	logc_kbounds_v_l(1:2,nys:nyn) = 0
2207	logc_kbounds_w_l(1:2,nys:nyn) = 0
2208
2209	direction = 2
2210
2211	DO j = nys, nyn
2212	!
2213	!-- Determine the lowest k-indices for u at j,i, j+1,i and j-1,i.
2214	i = 0
2215	k_wall_u_ji = get_topography_top_index_ji( j, i, 'u' )
2216	k_wall_u_ji_p = get_topography_top_index_ji( j+1, i, 'u' )
2217	k_wall_u_ji_m = get_topography_top_index_ji( j-1, i, 'u' )
2218	!
2219	!-- Wall for u on the south side.
2220	IF ( ( k_wall_u_ji < k_wall_u_ji_m ) .AND. &
2221	( k_wall_u_ji >= k_wall_u_ji_p ) ) THEN
2222	inc = 1
2223	wall_index = j
2224	!
2225	!-- Store the kbounds for use in pmci_interp_tril_lr.
2226	logc_kbounds_u_l(1,j) = k_wall_u_ji + 1
2227	logc_kbounds_u_l(2,j) = k_wall_u_ji_m
2228	DO k = logc_kbounds_u_l(1,j), logc_kbounds_u_l(2,j)
2229	CALL pmci_define_loglaw_correction_parameters( lc, lcr, &
2230	k, j, inc, wall_index, z0_topo, kb, direction, &
2231	ncorr )
2232	IF ( lc == -99 ) THEN
2233	!
2234	!-- The pivot point is out of subdomain, skip the correction.
2235	logc_u_l(2,k,j) = 0
2236	logc_ratio_u_l(2,0:ncorr-1,k,j) = 1.0_wp
2237	ELSE
2238	!
2239	!-- The direction of the wall-normal index is stored as the
2240	!-- sign of the logc-element.
2241	logc_u_l(2,k,j) = inc * lc
2242	logc_ratio_u_l(2,0:ncorr-1,k,j) = lcr(0:ncorr-1)
2243	ENDIF
2244	lcr(0:ncorr-1) = 1.0_wp
2245	ENDDO
2246	ENDIF
2247	!
2248	!-- Wall for u on the north side.
2249	IF ( ( k_wall_u_ji < k_wall_u_ji_p ) .AND. &
2250	( k_wall_u_ji >= k_wall_u_ji_m ) ) THEN
2251	inc = -1
2252	wall_index = j + 1
2253	!
2254	!-- Store the kbounds for use in pmci_interp_tril_lr.
2255	logc_kbounds_u_l(1,j) = k_wall_u_ji + 1
2256	logc_kbounds_u_l(2,j) = k_wall_u_ji_p
2257	DO k = logc_kbounds_u_l(1,j), logc_kbounds_u_l(2,j)
2258	CALL pmci_define_loglaw_correction_parameters( lc, lcr, &
2259	k, j, inc, wall_index, z0_topo, kb, direction, &
2260	ncorr )
2261	IF ( lc == -99 ) THEN
2262	!
2263	!-- The pivot point is out of subdomain, skip the correction.
2264	logc_u_l(2,k,j) = 0
2265	logc_ratio_u_l(2,0:ncorr-1,k,j) = 1.0_wp
2266	ELSE
2267	!
2268	!-- The direction of the wall-normal index is stored as the
2269	!-- sign of the logc-element.
2270	logc_u_l(2,k,j) = inc * lc
2271	logc_ratio_u_l(2,0:ncorr-1,k,j) = lcr(0:ncorr-1)
2272	ENDIF
2273	lcr(0:ncorr-1) = 1.0_wp
2274	ENDDO
2275	ENDIF
2276	!
2277	!-- Determine the lowest k-indices for w at j,i, j+1,i and j-1,i.
2278	i = -1
2279	k_wall_w_ji = get_topography_top_index_ji( j, i, 'w' )
2280	k_wall_w_ji_p = get_topography_top_index_ji( j+1, i, 'w' )
2281	k_wall_w_ji_m = get_topography_top_index_ji( j-1, i, 'w' )
2282	!
2283	!-- Wall for w on the south side.
2284	IF ( ( k_wall_w_ji < k_wall_w_ji_m ) .AND. &
2285	( k_wall_w_ji >= k_wall_w_ji_p ) ) THEN
2286	inc = 1
2287	wall_index = j
2288	!
2289	!-- Store the kbounds for use in pmci_interp_tril_lr.
2290	logc_kbounds_w_l(1,j) = k_wall_w_ji + 1
2291	logc_kbounds_w_l(2,j) = k_wall_w_ji_m
2292	DO k = logc_kbounds_w_l(1,j), logc_kbounds_w_l(2,j)
2293	CALL pmci_define_loglaw_correction_parameters( lc, lcr, &
2294	k, j, inc, wall_index, z0_topo, kb, direction, &
2295	ncorr )
2296	IF ( lc == -99 ) THEN
2297	!
2298	!-- The pivot point is out of subdomain, skip the correction.
2299	logc_w_l(2,k,j) = 0
2300	logc_ratio_w_l(2,0:ncorr-1,k,j) = 1.0_wp
2301	ELSE
2302	!
2303	!-- The direction of the wall-normal index is stored as the
2304	!-- sign of the logc-element.
2305	logc_w_l(2,k,j) = inc * lc
2306	logc_ratio_w_l(2,0:ncorr-1,k,j) = lcr(0:ncorr-1)
2307	ENDIF
2308	lcr(0:ncorr-1) = 1.0_wp
2309	ENDDO
2310	ENDIF
2311	!
2312	!-- Wall for w on the north side.
2313	IF ( ( k_wall_w_ji < k_wall_w_ji_p ) .AND. &
2314	( k_wall_w_ji >= k_wall_w_ji_m ) ) THEN
2315	inc = -1
2316	wall_index = j+1
2317	!
2318	!-- Store the kbounds for use in pmci_interp_tril_lr.
2319	logc_kbounds_w_l(1,j) = k_wall_w_ji + 1
2320	logc_kbounds_w_l(2,j) = k_wall_w_ji_p
2321	DO k = logc_kbounds_w_l(1,j), logc_kbounds_w_l(2,j)
2322	CALL pmci_define_loglaw_correction_parameters( lc, lcr, &
2323	k, j, inc, wall_index, z0_topo, kb, direction, &
2324	ncorr )
2325	IF ( lc == -99 ) THEN
2326	!
2327	!-- The pivot point is out of subdomain, skip the correction.
2328	logc_w_l(2,k,j) = 0
2329	logc_ratio_w_l(2,0:ncorr-1,k,j) = 1.0_wp
2330	ELSE
2331	!
2332	!-- The direction of the wall-normal index is stored as the
2333	!-- sign of the logc-element.
2334	logc_w_l(2,k,j) = inc * lc
2335	logc_ratio_w_l(2,0:ncorr-1,k,j) = lcr(0:ncorr-1)
2336	ENDIF
2337	lcr(0:ncorr-1) = 1.0_wp
2338	ENDDO
2339	ENDIF
2340
2341	ENDDO
2342
2343	ENDIF ! IF ( bc_dirichlet_l )
2344	!
2345	!-- Right boundary
2346	IF ( bc_dirichlet_r ) THEN
2347	logc_kbounds_u_r(1:2,nys:nyn) = 0
2348	logc_kbounds_v_r(1:2,nys:nyn) = 0
2349	logc_kbounds_w_r(1:2,nys:nyn) = 0
2350
2351	direction = 2
2352	i = nx + 1
2353
2354	DO j = nys, nyn
2355	!
2356	!-- Determine the lowest k-indices for u at j,i, j+1,i and j-1,i.
2357	k_wall_u_ji = get_topography_top_index_ji( j, i, 'u' )
2358	k_wall_u_ji_p = get_topography_top_index_ji( j+1, i, 'u' )
2359	k_wall_u_ji_m = get_topography_top_index_ji( j-1, i, 'u' )
2360	!
2361	!-- Wall for u on the south side.
2362	IF ( ( k_wall_u_ji < k_wall_u_ji_m ) .AND. &
2363	( k_wall_u_ji >= k_wall_u_ji_p ) ) THEN
2364	inc = 1
2365	wall_index = j
2366	!
2367	!-- Store the kbounds for use in pmci_interp_tril_lr.
2368	logc_kbounds_u_r(1,j) = k_wall_u_ji + 1
2369	logc_kbounds_u_r(2,j) = k_wall_u_ji_m
2370	DO k = logc_kbounds_u_r(1,j), logc_kbounds_u_r(2,j)
2371	CALL pmci_define_loglaw_correction_parameters( lc, lcr, &
2372	k, j, inc, wall_index, z0_topo, kb, direction, ncorr )
2373	IF ( lc == -99 ) THEN
2374	!
2375	!-- The pivot point is out of subdomain, skip the correction.
2376	logc_u_r(2,k,j) = 0
2377	logc_ratio_u_r(2,0:ncorr-1,k,j) = 1.0_wp
2378	ELSE
2379	!
2380	!-- The direction of the wall-normal index is stored as the
2381	!-- sign of the logc-element.
2382	logc_u_r(2,k,j) = inc * lc
2383	logc_ratio_u_r(2,0:ncorr-1,k,j) = lcr(0:ncorr-1)
2384	ENDIF
2385	lcr(0:ncorr-1) = 1.0_wp
2386	ENDDO
2387	ENDIF
2388	!
2389	!-- Wall for u on the south side.
2390	IF ( ( k_wall_u_ji < k_wall_u_ji_p ) .AND. &
2391	( k_wall_u_ji >= k_wall_u_ji_m ) ) THEN
2392	inc = -1
2393	wall_index = j + 1
2394	!
2395	!-- Store the kbounds for use in pmci_interp_tril_lr.
2396	logc_kbounds_u_r(1,j) = k_wall_u_ji + 1
2397	logc_kbounds_u_r(2,j) = k_wall_u_ji_p
2398	DO k = logc_kbounds_u_r(1,j), logc_kbounds_u_r(2,j)
2399	CALL pmci_define_loglaw_correction_parameters( lc, lcr, &
2400	k, j, inc, wall_index, z0_topo, kb, direction, &
2401	ncorr )
2402	IF ( lc == -99 ) THEN
2403	!
2404	!-- The pivot point is out of subdomain, skip the correction.
2405	logc_u_r(2,k,j) = 0
2406	logc_ratio_u_r(2,0:ncorr-1,k,j) = 1.0_wp
2407	ELSE
2408	!
2409	!-- The direction of the wall-normal index is stored as the
2410	!-- sign of the logc-element.
2411	logc_u_r(2,k,j) = inc * lc
2412	logc_ratio_u_r(2,0:ncorr-1,k,j) = lcr(0:ncorr-1)
2413	ENDIF
2414	lcr(0:ncorr-1) = 1.0_wp
2415	ENDDO
2416	ENDIF
2417	!
2418	!-- Determine the lowest k-indices for w at j,i, j+1,i and j-1,i.
2419	k_wall_w_ji = get_topography_top_index_ji( j, i, 'w' )
2420	k_wall_w_ji_p = get_topography_top_index_ji( j+1, i, 'w' )
2421	k_wall_w_ji_m = get_topography_top_index_ji( j-1, i, 'w' )
2422	!
2423	!-- Wall for w on the south side.
2424	IF ( ( k_wall_w_ji < k_wall_w_ji_m ) .AND. &
2425	( k_wall_w_ji >= k_wall_w_ji_p ) ) THEN
2426	inc = 1
2427	wall_index = j
2428	!
2429	!-- Store the kbounds for use in pmci_interp_tril_lr.
2430	logc_kbounds_w_r(1,j) = k_wall_w_ji + 1
2431	logc_kbounds_w_r(2,j) = k_wall_w_ji_m
2432	DO k = logc_kbounds_w_r(1,j), logc_kbounds_w_r(2,j)
2433	CALL pmci_define_loglaw_correction_parameters( lc, lcr, &
2434	k, j, inc, wall_index, z0_topo, kb, direction, &
2435	ncorr )
2436	IF ( lc == -99 ) THEN
2437	!
2438	!-- The pivot point is out of subdomain, skip the correction.
2439	logc_w_r(2,k,j) = 0
2440	logc_ratio_w_r(2,0:ncorr-1,k,j) = 1.0_wp
2441	ELSE
2442	!
2443	!-- The direction of the wall-normal index is stored as the
2444	!-- sign of the logc-element.
2445	logc_w_r(2,k,j) = inc * lc
2446	logc_ratio_w_r(2,0:ncorr-1,k,j) = lcr(0:ncorr-1)
2447	ENDIF
2448	lcr(0:ncorr-1) = 1.0_wp
2449	ENDDO
2450	ENDIF
2451	!
2452	!-- Wall for w on the north side.
2453	IF ( ( k_wall_w_ji < k_wall_w_ji_p ) .AND. &
2454	( k_wall_w_ji >= k_wall_w_ji_m ) ) THEN
2455	inc = -1
2456	wall_index = j+1
2457	!
2458	!-- Store the kbounds for use in pmci_interp_tril_lr.
2459	logc_kbounds_w_r(1,j) = k_wall_w_ji + 1
2460	logc_kbounds_w_r(2,j) = k_wall_w_ji_p
2461	DO k = logc_kbounds_w_r(1,j), logc_kbounds_w_r(2,j)
2462	CALL pmci_define_loglaw_correction_parameters( lc, lcr, &
2463	k, j, inc, wall_index, z0_topo, kb, direction, &
2464	ncorr )
2465	IF ( lc == -99 ) THEN
2466	!
2467	!-- The pivot point is out of subdomain, skip the correction.
2468	logc_w_r(2,k,j) = 0
2469	logc_ratio_w_r(2,0:ncorr-1,k,j) = 1.0_wp
2470	ELSE
2471	!
2472	!-- The direction of the wall-normal index is stored as the
2473	!-- sign of the logc-element.
2474	logc_w_r(2,k,j) = inc * lc
2475	logc_ratio_w_r(2,0:ncorr-1,k,j) = lcr(0:ncorr-1)
2476	ENDIF
2477	lcr(0:ncorr-1) = 1.0_wp
2478	ENDDO
2479	ENDIF
2480
2481	ENDDO
2482
2483	ENDIF ! IF ( bc_dirichlet_r )
2484	!
2485	!-- South boundary
2486	IF ( bc_dirichlet_s ) THEN
2487	logc_kbounds_u_s(1:2,nxl:nxr) = 0
2488	logc_kbounds_v_s(1:2,nxl:nxr) = 0
2489	logc_kbounds_w_s(1:2,nxl:nxr) = 0
2490
2491	direction = 3
2492
2493	DO i = nxl, nxr
2494	!
2495	!-- Determine the lowest k-indices for v at j,i, j,i+1 and j,i-1.
2496	j = 0
2497	k_wall_v_ji = get_topography_top_index_ji( j, i, 'v' )
2498	k_wall_v_ji_p = get_topography_top_index_ji( j, i+1, 'v' )
2499	k_wall_v_ji_m = get_topography_top_index_ji( j, i-1, 'v' )
2500	!
2501	!-- Wall for v on the left side.
2502	IF ( ( k_wall_v_ji < k_wall_v_ji_m ) .AND. &
2503	( k_wall_v_ji >= k_wall_v_ji_p ) ) THEN
2504	inc = 1
2505	wall_index = i
2506	!
2507	!-- Store the kbounds for use in pmci_interp_tril_sn.
2508	logc_kbounds_v_s(1,i) = k_wall_v_ji + 1
2509	logc_kbounds_v_s(2,i) = k_wall_v_ji_m
2510	DO k = logc_kbounds_v_s(1,i), logc_kbounds_v_s(2,i)
2511	CALL pmci_define_loglaw_correction_parameters( lc, lcr, &
2512	k, i, inc, wall_index, z0_topo, kb, direction, &
2513	ncorr )
2514	IF ( lc == -99 ) THEN
2515	!
2516	!-- The pivot point is out of subdomain, skip the correction.
2517	logc_v_s(2,k,i) = 0
2518	logc_ratio_v_s(2,0:ncorr-1,k,i) = 1.0_wp
2519	ELSE
2520	!
2521	!-- The direction of the wall-normal index is stored as the
2522	!-- sign of the logc-element.
2523	logc_v_s(2,k,i) = inc * lc
2524	logc_ratio_v_s(2,0:ncorr-1,k,i) = lcr(0:ncorr-1)
2525	ENDIF
2526	lcr(0:ncorr-1) = 1.0_wp
2527	ENDDO
2528	ENDIF
2529	!
2530	!-- Wall for v on the right side.
2531	IF ( ( k_wall_v_ji < k_wall_v_ji_p ) .AND. &
2532	( k_wall_v_ji >= k_wall_v_ji_m ) ) THEN
2533	inc = -1
2534	wall_index = i+1
2535	!
2536	!-- Store the kbounds for use in pmci_interp_tril_sn.
2537	logc_kbounds_v_s(1,i) = k_wall_v_ji + 1
2538	logc_kbounds_v_s(2,i) = k_wall_v_ji_p
2539	DO k = logc_kbounds_v_s(1,i), logc_kbounds_v_s(2,i)
2540	CALL pmci_define_loglaw_correction_parameters( lc, lcr, &
2541	k, i, inc, wall_index, z0_topo, kb, direction, &
2542	ncorr )
2543	IF ( lc == -99 ) THEN
2544	!
2545	!-- The pivot point is out of subdomain, skip the correction.
2546	logc_v_s(2,k,i) = 0
2547	logc_ratio_v_s(2,0:ncorr-1,k,i) = 1.0_wp
2548	ELSE
2549	!
2550	!-- The direction of the wall-normal index is stored as the
2551	!-- sign of the logc-element.
2552	logc_v_s(2,k,i) = inc * lc
2553	logc_ratio_v_s(2,0:ncorr-1,k,i) = lcr(0:ncorr-1)
2554	ENDIF
2555	lcr(0:ncorr-1) = 1.0_wp
2556	ENDDO
2557	ENDIF
2558	!
2559	!-- Determine the lowest k-indices for w at j,i, j,i+1 and j,i-1.
2560	j = -1
2561	k_wall_w_ji = get_topography_top_index_ji( j, i, 'w' )
2562	k_wall_w_ji_p = get_topography_top_index_ji( j, i+1, 'w' )
2563	k_wall_w_ji_m = get_topography_top_index_ji( j, i-1, 'w' )
2564	!
2565	!-- Wall for w on the left side.
2566	IF ( ( k_wall_w_ji < k_wall_w_ji_m ) .AND. &
2567	( k_wall_w_ji >= k_wall_w_ji_p ) ) THEN
2568	inc = 1
2569	wall_index = i
2570	!
2571	!-- Store the kbounds for use in pmci_interp_tril_sn.
2572	logc_kbounds_w_s(1,i) = k_wall_w_ji + 1
2573	logc_kbounds_w_s(2,i) = k_wall_w_ji_m
2574	DO k = logc_kbounds_w_s(1,i), logc_kbounds_w_s(2,i)
2575	CALL pmci_define_loglaw_correction_parameters( lc, lcr, &
2576	k, i, inc, wall_index, z0_topo, kb, direction, &
2577	ncorr )
2578	IF ( lc == -99 ) THEN
2579	!
2580	!-- The pivot point is out of subdomain, skip the correction.
2581	logc_w_s(2,k,i) = 0
2582	logc_ratio_w_s(2,0:ncorr-1,k,i) = 1.0_wp
2583	ELSE
2584	!
2585	!-- The direction of the wall-normal index is stored as the
2586	!-- sign of the logc-element.
2587	logc_w_s(2,k,i) = inc * lc
2588	logc_ratio_w_s(2,0:ncorr-1,k,i) = lcr(0:ncorr-1)
2589	ENDIF
2590	lcr(0:ncorr-1) = 1.0_wp
2591	ENDDO
2592	ENDIF
2593	!
2594	!-- Wall for w on the right side.
2595	IF ( ( k_wall_w_ji < k_wall_w_ji_p ) .AND. &
2596	( k_wall_w_ji >= k_wall_w_ji_m ) ) THEN
2597	inc = -1
2598	wall_index = i+1
2599	!
2600	!-- Store the kbounds for use in pmci_interp_tril_sn.
2601	logc_kbounds_w_s(1,i) = k_wall_w_ji + 1
2602	logc_kbounds_w_s(2,i) = k_wall_w_ji_p
2603	DO k = logc_kbounds_w_s(1,i), logc_kbounds_w_s(2,i)
2604	CALL pmci_define_loglaw_correction_parameters( lc, lcr, &
2605	k, i, inc, wall_index, z0_topo, kb, direction, &
2606	ncorr )
2607	IF ( lc == -99 ) THEN
2608	!
2609	!-- The pivot point is out of subdomain, skip the correction.
2610	logc_w_s(2,k,i) = 0
2611	logc_ratio_w_s(2,0:ncorr-1,k,i) = 1.0_wp
2612	ELSE
2613	!
2614	!-- The direction of the wall-normal index is stored as the
2615	!-- sign of the logc-element.
2616	logc_w_s(2,k,i) = inc * lc
2617	logc_ratio_w_s(2,0:ncorr-1,k,i) = lcr(0:ncorr-1)
2618	ENDIF
2619	lcr(0:ncorr-1) = 1.0_wp
2620	ENDDO
2621	ENDIF
2622
2623	ENDDO
2624
2625	ENDIF ! IF (bc_dirichlet_s )
2626	!
2627	!-- North boundary
2628	IF ( bc_dirichlet_n ) THEN
2629	logc_kbounds_u_n(1:2,nxl:nxr) = 0
2630	logc_kbounds_v_n(1:2,nxl:nxr) = 0
2631	logc_kbounds_w_n(1:2,nxl:nxr) = 0
2632
2633	direction = 3
2634	j = ny + 1
2635
2636	DO i = nxl, nxr
2637	!
2638	!-- Determine the lowest k-indices for v at j,i, j,i+1 and j,i-1
2639	k_wall_v_ji = get_topography_top_index_ji( j, i, 'v' )
2640	k_wall_v_ji_p = get_topography_top_index_ji( j, i+1, 'v' )
2641	k_wall_v_ji_m = get_topography_top_index_ji( j, i-1, 'v' )
2642	!
2643	!-- Wall for v on the left side.
2644	IF ( ( k_wall_v_ji < k_wall_v_ji_m ) .AND. &
2645	( k_wall_v_ji >= k_wall_v_ji_p ) ) THEN
2646	inc = 1
2647	wall_index = i
2648	!
2649	!-- Store the kbounds for use in pmci_interp_tril_sn.
2650	logc_kbounds_v_n(1,i) = k_wall_v_ji + 1
2651	logc_kbounds_v_n(2,i) = k_wall_v_ji_m
2652	DO k = logc_kbounds_v_n(1,i), logc_kbounds_v_n(2,i)
2653	CALL pmci_define_loglaw_correction_parameters( lc, lcr, &
2654	k, i, inc, wall_index, z0_topo, kb, direction, &
2655	ncorr )
2656	IF ( lc == -99 ) THEN
2657	!
2658	!-- The pivot point is out of subdomain, skip the correction.
2659	logc_v_n(2,k,i) = 0
2660	logc_ratio_v_n(2,0:ncorr-1,k,i) = 1.0_wp
2661	ELSE
2662	!
2663	!-- The direction of the wall-normal index is stored as the
2664	!-- sign of the logc-element.
2665	logc_v_n(2,k,i) = inc * lc
2666	logc_ratio_v_n(2,0:ncorr-1,k,i) = lcr(0:ncorr-1)
2667	ENDIF
2668	lcr(0:ncorr-1) = 1.0_wp
2669	ENDDO
2670	ENDIF
2671	!
2672	!-- Wall for v on the right side.
2673	IF ( ( k_wall_v_ji < k_wall_v_ji_p ) .AND. &
2674	( k_wall_v_ji >= k_wall_v_ji_m ) ) THEN
2675	inc = -1
2676	wall_index = i + 1
2677	!
2678	!-- Store the kbounds for use in pmci_interp_tril_sn.
2679	logc_kbounds_v_n(1,i) = k_wall_v_ji + 1
2680	logc_kbounds_v_n(2,i) = k_wall_v_ji_p
2681	DO k = logc_kbounds_v_n(1,i), logc_kbounds_v_n(2,i)
2682	CALL pmci_define_loglaw_correction_parameters( lc, lcr, &
2683	k, i, inc, wall_index, z0_topo, kb, direction, &
2684	ncorr )
2685	IF ( lc == -99 ) THEN
2686	!
2687	!-- The pivot point is out of subdomain, skip the correction.
2688	logc_v_n(2,k,i) = 0
2689	logc_ratio_v_n(2,0:ncorr-1,k,i) = 1.0_wp
2690	ELSE
2691	!
2692	!-- The direction of the wall-normal index is stored as the
2693	!-- sign of the logc-element.
2694	logc_v_n(2,k,i) = inc * lc
2695	logc_ratio_v_n(2,0:ncorr-1,k,i) = lcr(0:ncorr-1)
2696	ENDIF
2697	lcr(0:ncorr-1) = 1.0_wp
2698	ENDDO
2699	ENDIF
2700	!
2701	!-- Determine the lowest k-indices for w at j,i, j,i+1 and j,i-1.
2702	k_wall_w_ji = get_topography_top_index_ji( j, i, 'w' )
2703	k_wall_w_ji_p = get_topography_top_index_ji( j, i+1, 'w' )
2704	k_wall_w_ji_m = get_topography_top_index_ji( j, i-1, 'w' )
2705	!
2706	!-- Wall for w on the left side.
2707	IF ( ( k_wall_w_ji < k_wall_w_ji_m ) .AND. &
2708	( k_wall_w_ji >= k_wall_w_ji_p ) ) THEN
2709	inc = 1
2710	wall_index = i
2711	!
2712	!-- Store the kbounds for use in pmci_interp_tril_sn.
2713	logc_kbounds_w_n(1,i) = k_wall_w_ji + 1
2714	logc_kbounds_w_n(2,i) = k_wall_w_ji_m
2715	DO k = logc_kbounds_w_n(1,i), logc_kbounds_w_n(2,i)
2716	CALL pmci_define_loglaw_correction_parameters( lc, lcr, &
2717	k, i, inc, wall_index, z0_topo, kb, direction, &
2718	ncorr )
2719	IF ( lc == -99 ) THEN
2720	!
2721	!-- The pivot point is out of subdomain, skip the correction.
2722	logc_w_n(2,k,i) = 0
2723	logc_ratio_w_n(2,0:ncorr-1,k,i) = 1.0_wp
2724	ELSE
2725	!
2726	!-- The direction of the wall-normal index is stored as the
2727	!-- sign of the logc-element.
2728	logc_w_n(2,k,i) = inc * lc
2729	logc_ratio_w_n(2,0:ncorr-1,k,i) = lcr(0:ncorr-1)
2730	ENDIF
2731	lcr(0:ncorr-1) = 1.0_wp
2732	ENDDO
2733	ENDIF
2734	!
2735	!-- Wall for w on the right side, but not on the left side
2736	IF ( ( k_wall_w_ji < k_wall_w_ji_p ) .AND. &
2737	( k_wall_w_ji >= k_wall_w_ji_m ) ) THEN
2738	inc = -1
2739	wall_index = i+1
2740	!
2741	!-- Store the kbounds for use in pmci_interp_tril_sn.
2742	logc_kbounds_w_n(1,i) = k_wall_w_ji + 1
2743	logc_kbounds_w_n(2,i) = k_wall_w_ji_p
2744	DO k = logc_kbounds_w_n(1,i), logc_kbounds_w_n(2,i)
2745	CALL pmci_define_loglaw_correction_parameters( lc, lcr, &
2746	k, i, inc, wall_index, z0_topo, kb, direction, &
2747	ncorr )
2748	IF ( lc == -99 ) THEN
2749	!
2750	!-- The pivot point is out of subdomain, skip the correction.
2751	logc_w_n(2,k,i) = 0
2752	logc_ratio_w_n(2,0:ncorr-1,k,i) = 1.0_wp
2753	ELSE
2754	!
2755	!-- The direction of the wall-normal index is stored as the
2756	!-- sign of the logc-element.
2757	logc_w_n(2,k,i) = inc * lc
2758	logc_ratio_w_n(2,0:ncorr-1,k,i) = lcr(0:ncorr-1)
2759	ENDIF
2760	lcr(0:ncorr-1) = 1.0_wp
2761	ENDDO
2762	ENDIF
2763
2764	ENDDO
2765
2766	ENDIF ! IF ( bc_dirichlet_n )
2767
2768	ENDIF ! IF ( topography /= 'flat' )
2769
2770	END SUBROUTINE pmci_init_loglaw_correction
2771
2772
2773
2774	SUBROUTINE pmci_define_loglaw_correction_parameters( lc, lcr, k, ij, inc, &
2775	wall_index, z0_l, kb, direction, ncorr )
2776
2777	IMPLICIT NONE
2778
2779	INTEGER(iwp), INTENT(IN) :: direction !<
2780	INTEGER(iwp), INTENT(IN) :: ij !<
2781	INTEGER(iwp), INTENT(IN) :: inc !<
2782	INTEGER(iwp), INTENT(IN) :: k !<
2783	INTEGER(iwp), INTENT(IN) :: kb !<
2784	INTEGER(iwp), INTENT(OUT) :: lc !<
2785	INTEGER(iwp), INTENT(IN) :: ncorr !<
2786	INTEGER(iwp), INTENT(IN) :: wall_index !<
2787
2788	INTEGER(iwp) :: alcorr !<
2789	INTEGER(iwp) :: corr_index !<
2790	INTEGER(iwp) :: lcorr !<
2791
2792	LOGICAL :: more !<
2793
2794	REAL(wp), DIMENSION(0:ncorr-1), INTENT(INOUT) :: lcr !<
2795	REAL(wp), INTENT(IN) :: z0_l !<
2796
2797	REAL(wp) :: logvelc1 !<
2798
2799
2800	SELECT CASE ( direction )
2801
2802	CASE (1) ! k
2803	more = .TRUE.
2804	lcorr = 0
2805	DO WHILE ( more .AND. lcorr <= ncorr-1 )
2806	corr_index = k + lcorr
2807	IF ( lcorr == 0 ) THEN
2808	CALL pmci_find_logc_pivot_k( lc, logvelc1, z0_l, kb )
2809	ENDIF
2810
2811	IF ( corr_index < lc ) THEN
2812	lcr(lcorr) = LOG( ( zu(k) - zw(kb) ) / z0_l ) / logvelc1
2813	more = .TRUE.
2814	ELSE
2815	lcr(lcorr) = 1.0_wp
2816	more = .FALSE.
2817	ENDIF
2818	lcorr = lcorr + 1
2819	ENDDO
2820
2821	CASE (2) ! j
2822	more = .TRUE.
2823	lcorr = 0
2824	alcorr = 0
2825	DO WHILE ( more .AND. alcorr <= ncorr-1 )
2826	corr_index = ij + lcorr ! In this case (direction = 2) ij is j
2827	IF ( lcorr == 0 ) THEN
2828	CALL pmci_find_logc_pivot_j( lc, logvelc1, ij, wall_index, &
2829	z0_l, inc )
2830	ENDIF
2831	!
2832	!-- The role of inc here is to make the comparison operation "<"
2833	!-- valid in both directions
2834	IF ( ( inc * corr_index < inc * lc ) .AND. ( lc /= -99 ) ) THEN
2835	lcr(alcorr) = LOG( ABS( coord_y(corr_index) + 0.5_wp * dy &
2836	- coord_y(wall_index) ) / z0_l ) &
2837	/ logvelc1
2838	more = .TRUE.
2839	ELSE
2840	lcr(alcorr) = 1.0_wp
2841	more = .FALSE.
2842	ENDIF
2843	lcorr = lcorr + inc
2844	alcorr = ABS( lcorr )
2845	ENDDO
2846
2847	CASE (3) ! i
2848	more = .TRUE.
2849	lcorr = 0
2850	alcorr = 0
2851	DO WHILE ( more .AND. alcorr <= ncorr-1 )
2852	corr_index = ij + lcorr ! In this case (direction = 3) ij is i
2853	IF ( lcorr == 0 ) THEN
2854	CALL pmci_find_logc_pivot_i( lc, logvelc1, ij, wall_index, &
2855	z0_l, inc )
2856	ENDIF
2857	!
2858	!-- The role of inc here is to make the comparison operation "<"
2859	!-- valid in both directions
2860	IF ( ( inc * corr_index < inc * lc ) .AND. ( lc /= -99 ) ) THEN
2861	lcr(alcorr) = LOG( ABS( coord_x(corr_index) + 0.5_wp * dx &
2862	- coord_x(wall_index) ) / z0_l ) &
2863	/ logvelc1
2864	more = .TRUE.
2865	ELSE
2866	lcr(alcorr) = 1.0_wp
2867	more = .FALSE.
2868	ENDIF
2869	lcorr = lcorr + inc
2870	alcorr = ABS( lcorr )
2871	ENDDO
2872
2873	END SELECT
2874
2875	END SUBROUTINE pmci_define_loglaw_correction_parameters
2876
2877
2878
2879	SUBROUTINE pmci_find_logc_pivot_k( lc, logzc1, z0_l, kb )
2880	!
2881	!-- Finds the pivot node and the log-law factor for near-wall nodes for
2882	!-- which the wall-parallel velocity components will be log-law corrected
2883	!-- after interpolation. This subroutine is only for horizontal walls.
2884
2885	IMPLICIT NONE
2886
2887	INTEGER(iwp), INTENT(IN) :: kb !<
2888	INTEGER(iwp), INTENT(OUT) :: lc !<
2889
2890	INTEGER(iwp) :: kbc !<
2891	INTEGER(iwp) :: k1 !<
2892
2893	REAL(wp), INTENT(OUT) :: logzc1 !<
2894	REAL(wp), INTENT(IN) :: z0_l !<
2895
2896	REAL(wp) :: zuc1 !<
2897
2898	!
2899	!-- kbc is the first coarse-grid point above the surface
2900	kbc = nzb + 1
2901	DO WHILE ( cg%zu(kbc) < zu(kb) )
2902	kbc = kbc + 1
2903	ENDDO
2904	zuc1 = cg%zu(kbc)
2905	k1 = kb + 1
2906	DO WHILE ( zu(k1) < zuc1 ) ! Important: must be <, not <=
2907	k1 = k1 + 1
2908	ENDDO
2909	logzc1 = LOG( (zu(k1) - zw(kb) ) / z0_l )
2910	lc = k1
2911
2912	END SUBROUTINE pmci_find_logc_pivot_k
2913
2914
2915
2916	SUBROUTINE pmci_find_logc_pivot_j( lc, logyc1, j, jw, z0_l, inc )
2917	!
2918	!-- Finds the pivot node and the log-law factor for near-wall nodes for
2919	!-- which the wall-parallel velocity components will be log-law corrected
2920	!-- after interpolation. This subroutine is only for vertical walls on
2921	!-- south/north sides of the node. If the pivot node is found to be outside
2922	!-- the subdomain, a marker value of -99 is set to lc and this tells
2923	!-- pmci_init_loglaw_correction to not do the correction in this case.
2924
2925	IMPLICIT NONE
2926
2927	INTEGER(iwp), INTENT(IN) :: inc !< increment must be 1 or -1.
2928	INTEGER(iwp), INTENT(IN) :: j !<
2929	INTEGER(iwp), INTENT(IN) :: jw !<
2930	INTEGER(iwp), INTENT(OUT) :: lc !<
2931
2932	INTEGER(iwp) :: jwc !<
2933	INTEGER(iwp) :: j1 !<
2934
2935	REAL(wp), INTENT(IN) :: z0_l !<
2936	REAL(wp), INTENT(OUT) :: logyc1 !<
2937
2938	REAL(wp) :: ycb !<
2939	REAL(wp) :: yc1 !<
2940
2941	!
2942	!-- yc1 is the y-coordinate of the first coarse-grid u- and w-nodes out from
2943	!-- the wall. Here we assume that the wall index in the coarse grid is the
2944	!-- closest one if they don't match.
2945	jwc = pmci_find_nearest_coarse_grid_index_j( jw )
2946	yc1 = cg%coord_y(jwc) - lower_left_coord_y + 0.5_wp * inc * cg%dy
2947	!
2948	!-- Check if yc1 is out of the subdomain y-range. In such case set the marker
2949	!-- value -99 for lc in order to skip the loglaw-correction locally.
2950	IF ( yc1 < ( REAL( nysg, KIND=wp ) + 0.5_wp ) * dy ) THEN
2951	lc = -99
2952	logyc1 = 1.0_wp
2953	ELSE IF ( yc1 > ( REAL( nyng, KIND=wp ) + 0.5_wp ) * dy ) THEN
2954	lc = -99
2955	logyc1 = 1.0_wp
2956	ELSE
2957	!
2958	!-- j1 is the first fine-grid index further away from the wall than yc1
2959	j1 = j
2960	!
2961	!-- Important: the binary relation must be <, not <=
2962	ycb = 0.5_wp * dy - lower_left_coord_y
2963	DO WHILE ( inc * ( coord_y(j1) + ycb ) < inc * yc1 )
2964	j1 = j1 + inc
2965	ENDDO
2966
2967	logyc1 = LOG( ABS( coord_y(j1) + 0.5_wp * dy - coord_y(jw) ) / z0_l )
2968	lc = j1
2969	ENDIF
2970
2971	END SUBROUTINE pmci_find_logc_pivot_j
2972
2973
2974
2975	SUBROUTINE pmci_find_logc_pivot_i( lc, logxc1, i, iw, z0_l, inc )
2976	!
2977	!-- Finds the pivot node and the log-law factor for near-wall nodes for
2978	!-- which the wall-parallel velocity components will be log-law corrected
2979	!-- after interpolation. This subroutine is only for vertical walls on
2980	!-- left/right sides of the node. If the pivot node is found to be outside
2981	!-- the subdomain, a marker value of -99 is set to lc and this tells
2982	!-- pmci_init_loglaw_correction to not do the correction in this case.
2983
2984	IMPLICIT NONE
2985
2986	INTEGER(iwp), INTENT(IN) :: i !<
2987	INTEGER(iwp), INTENT(IN) :: inc !< increment must be 1 or -1.
2988	INTEGER(iwp), INTENT(IN) :: iw !<
2989	INTEGER(iwp), INTENT(OUT) :: lc !<
2990
2991	INTEGER(iwp) :: iwc !<
2992	INTEGER(iwp) :: i1 !<
2993
2994	REAL(wp), INTENT(IN) :: z0_l !<
2995	REAL(wp), INTENT(OUT) :: logxc1 !<
2996
2997	REAL(wp) :: xcb !<
2998	REAL(wp) :: xc1 !<
2999
3000	!
3001	!-- xc1 is the x-coordinate of the first coarse-grid v- and w-nodes out from
3002	!-- the wall. Here we assume that the wall index in the coarse grid is the
3003	!-- closest one if they don't match.
3004	iwc = pmci_find_nearest_coarse_grid_index_i( iw )
3005	xc1 = cg%coord_x(iwc) - lower_left_coord_x + 0.5_wp * inc * cg%dx
3006	!
3007	!-- Check if xc1 is out of the subdomain x-range. In such case set the marker
3008	!-- value -99 for lc in order to skip the loglaw-correction locally.
3009	IF ( xc1 < ( REAL( nxlg, KIND=wp ) + 0.5_wp ) * dx ) THEN
3010	lc = -99
3011	logxc1 = 1.0_wp
3012	ELSE IF ( xc1 > ( REAL( nxrg, KIND=wp ) + 0.5_wp ) * dx ) THEN
3013	lc = -99
3014	logxc1 = 1.0_wp
3015	ELSE
3016	!
3017	!-- i1 is the first fine-grid index futher away from the wall than xc1.
3018	i1 = i
3019	!
3020	!-- Important: the binary relation must be <, not <=
3021	xcb = 0.5_wp * dx - lower_left_coord_x
3022	DO WHILE ( inc * ( coord_x(i1) + xcb ) < inc * xc1 )
3023	i1 = i1 + inc
3024	ENDDO
3025
3026	logxc1 = LOG( ABS( coord_x(i1) + 0.5_wp*dx - coord_x(iw) ) / z0_l )
3027	lc = i1
3028	ENDIF
3029
3030	END SUBROUTINE pmci_find_logc_pivot_i
3031
3032
3033
3034	FUNCTION pmci_find_nearest_coarse_grid_index_j( jw )
3035
3036	IMPLICIT NONE
3037	INTEGER(iwp) :: jw !< Fine-grid wall index
3038
3039	INTEGER(iwp) :: jc
3040	INTEGER(iwp) :: pmci_find_nearest_coarse_grid_index_j
3041	REAL(wp) :: dist
3042	REAL(wp) :: newdist
3043
3044
3045	dist = coord_y(nyn) - coord_y(nys)
3046	DO jc = jcs, jcn
3047	newdist = ABS( cg%coord_y(jc) - coord_y(jw) )
3048	IF ( newdist < dist ) THEN
3049	pmci_find_nearest_coarse_grid_index_j = jc
3050	dist = newdist
3051	ENDIF
3052	ENDDO
3053
3054	END FUNCTION pmci_find_nearest_coarse_grid_index_j
3055
3056
3057
3058	FUNCTION pmci_find_nearest_coarse_grid_index_i( iw )
3059
3060	IMPLICIT NONE
3061	INTEGER(iwp) :: iw !< Fine-grid wall index
3062
3063	INTEGER(iwp) :: ic
3064	INTEGER(iwp) :: pmci_find_nearest_coarse_grid_index_i
3065	REAL(wp) :: dist
3066	REAL(wp) :: newdist
3067
3068
3069	dist = coord_x(nxr) - coord_x(nxl)
3070	DO ic = icl, icr
3071	newdist = ABS( cg%coord_x(ic) - coord_x(iw) )
3072	IF ( newdist < dist ) THEN
3073	pmci_find_nearest_coarse_grid_index_i = ic
3074	dist = newdist
3075	ENDIF
3076	ENDDO
3077
3078	END FUNCTION pmci_find_nearest_coarse_grid_index_i
3079
3080
3081
3082	SUBROUTINE pmci_init_anterp_tophat
3083	!
3084	!-- Precomputation of the child-array indices for
3085	!-- corresponding coarse-grid array index and the
3086	!-- Under-relaxation coefficients to be used by anterp_tophat.
3087
3088	IMPLICIT NONE
3089
3090	INTEGER(iwp) :: i !< Fine-grid index
3091	INTEGER(iwp) :: ii !< Coarse-grid index
3092	INTEGER(iwp) :: istart !<
3093	INTEGER(iwp) :: ir !<
3094	INTEGER(iwp) :: j !< Fine-grid index
3095	INTEGER(iwp) :: jj !< Coarse-grid index
3096	INTEGER(iwp) :: jstart !<
3097	INTEGER(iwp) :: jr !<
3098	INTEGER(iwp) :: k !< Fine-grid index
3099	INTEGER(iwp) :: kk !< Coarse-grid index
3100	INTEGER(iwp) :: kstart !<
3101	REAL(wp) :: xi !<
3102	REAL(wp) :: eta !<
3103	REAL(wp) :: tolerance !<
3104	REAL(wp) :: zeta !<
3105
3106	!
3107	!-- Default values for under-relaxation lengths:
3108	IF ( anterp_relax_length_l < 0.0_wp ) THEN
3109	anterp_relax_length_l = 0.1_wp * ( nx + 1 ) * dx
3110	ENDIF
3111	IF ( anterp_relax_length_r < 0.0_wp ) THEN
3112	anterp_relax_length_r = 0.1_wp * ( nx + 1 ) * dx
3113	ENDIF
3114	IF ( anterp_relax_length_s < 0.0_wp ) THEN
3115	anterp_relax_length_s = 0.1_wp * ( ny + 1 ) * dy
3116	ENDIF
3117	IF ( anterp_relax_length_n < 0.0_wp ) THEN
3118	anterp_relax_length_n = 0.1_wp * ( ny + 1 ) * dy
3119	ENDIF
3120	IF ( anterp_relax_length_t < 0.0_wp ) THEN
3121	anterp_relax_length_t = 0.1_wp * zu(nzt)
3122	ENDIF
3123	!
3124	!-- First determine kcto and kctw that are the coarse-grid upper bounds for
3125	!-- index k
3126	kk = 0
3127	DO WHILE ( cg%zu(kk) <= zu(nzt) )
3128	kk = kk + 1
3129	ENDDO
3130	kcto = kk - 1
3131
3132	kk = 0
3133	DO WHILE ( cg%zw(kk) <= zw(nzt-1) )
3134	kk = kk + 1
3135	ENDDO
3136	kctw = kk - 1
3137
3138	ALLOCATE( iflu(icl:icr) )
3139	ALLOCATE( iflo(icl:icr) )
3140	ALLOCATE( ifuu(icl:icr) )
3141	ALLOCATE( ifuo(icl:icr) )
3142	ALLOCATE( jflv(jcs:jcn) )
3143	ALLOCATE( jflo(jcs:jcn) )
3144	ALLOCATE( jfuv(jcs:jcn) )
3145	ALLOCATE( jfuo(jcs:jcn) )
3146	ALLOCATE( kflw(0:cg%nz+1) )
3147	ALLOCATE( kflo(0:cg%nz+1) )
3148	ALLOCATE( kfuw(0:cg%nz+1) )
3149	ALLOCATE( kfuo(0:cg%nz+1) )
3150
3151	ALLOCATE( ijkfc_u(0:cg%nz+1,jcs:jcn,icl:icr) )
3152	ALLOCATE( ijkfc_v(0:cg%nz+1,jcs:jcn,icl:icr) )
3153	ALLOCATE( ijkfc_w(0:cg%nz+1,jcs:jcn,icl:icr) )
3154	ALLOCATE( ijkfc_s(0:cg%nz+1,jcs:jcn,icl:icr) )
3155
3156	ijkfc_u = 0
3157	ijkfc_v = 0
3158	ijkfc_w = 0
3159	ijkfc_s = 0
3160	!
3161	!-- i-indices of u for each ii-index value
3162	!-- ii=icr is redundant for anterpolation
3163	tolerance = 0.000001_wp * dx
3164	istart = nxlg
3165	DO ii = icl, icr-1
3166	!
3167	!-- In case the child and parent grid lines match in x
3168	!-- use only the local k,j-child-grid plane for the anterpolation,
3169	!-- i.e use 2-D anterpolation. Else, use a 3-D anterpolation.
3170	i = istart
3171	DO WHILE ( coord_x(i) < cg%coord_x(ii) - tolerance .AND. i < nxrg )
3172	i = i + 1
3173	ENDDO
3174	IF ( ABS( coord_x(i) - cg%coord_x(ii) ) < tolerance ) THEN
3175	i = istart
3176	DO WHILE ( coord_x(i) < cg%coord_x(ii) .AND. i < nxrg )
3177	i = i + 1
3178	ENDDO
3179	iflu(ii) = MIN( MAX( i, nxlg ), nxrg )
3180	ifuu(ii) = iflu(ii)
3181	istart = iflu(ii)
3182	ELSE
3183	i = istart
3184	DO WHILE ( ( coord_x(i) < cg%coord_x(ii) - 0.5_wp * cg%dx ) &
3185	.AND. ( i < nxrg ) )
3186	i = i + 1
3187	ENDDO
3188	iflu(ii) = MIN( MAX( i, nxlg ), nxrg )
3189	ir = i
3190	DO WHILE ( ( coord_x(ir) <= cg%coord_x(ii) + 0.5_wp * cg%dx ) &
3191	.AND. ( i < nxrg+1 ) )
3192	i = i + 1
3193	ir = MIN( i, nxrg )
3194	ENDDO
3195	ifuu(ii) = MIN( MAX( i-1, iflu(ii) ), nxrg )
3196	istart = iflu(ii)
3197	ENDIF
3198	!AH
3199	write(9,"('pmci_init_anterp_tophat, ii, iflu, ifuu: ', 3(i4,2x))") &
3200	ii, iflu(ii), ifuu(ii)
3201	flush(9)
3202
3203	ENDDO
3204	iflu(icr) = nxrg
3205	ifuu(icr) = nxrg
3206	!
3207	!-- i-indices of others for each ii-index value
3208	!-- ii=icr is redundant for anterpolation
3209	istart = nxlg
3210	DO ii = icl, icr-1
3211	i = istart
3212	DO WHILE ( ( coord_x(i) + 0.5_wp * dx < cg%coord_x(ii) ) .AND. &
3213	( i < nxrg ) )
3214	i = i + 1
3215	ENDDO
3216	iflo(ii) = MIN( MAX( i, nxlg ), nxrg )
3217	ir = i
3218	DO WHILE ( ( coord_x(ir) + 0.5_wp * dx <= cg%coord_x(ii) + cg%dx ) &
3219	.AND. ( i < nxrg+1 ) )
3220	i = i + 1
3221	ir = MIN( i, nxrg )
3222	ENDDO
3223	ifuo(ii) = MIN( MAX( i-1, iflo(ii) ), nxrg )
3224	istart = iflo(ii)
3225	ENDDO
3226	!AH
3227	write(9,"('pmci_init_anterp_tophat, ii, iflo, ifuo: ', 3(i4,2x))") &
3228	ii, iflo(ii), ifuo(ii)
3229	flush(9)
3230
3231	iflo(icr) = nxrg
3232	ifuo(icr) = nxrg
3233	!
3234	!-- j-indices of v for each jj-index value
3235	!-- jj=jcn is redundant for anterpolation
3236	tolerance = 0.000001_wp * dy
3237	jstart = nysg
3238	DO jj = jcs, jcn-1
3239	!
3240	!-- In case the child and parent grid lines match in y
3241	!-- use only the local k,i-child-grid plane for the anterpolation,
3242	!-- i.e use 2-D anterpolation. Else, use a 3-D anterpolation.
3243	j = jstart
3244	DO WHILE ( coord_y(j) < cg%coord_y(jj) - tolerance .AND. j < nyng )
3245	j = j + 1
3246	ENDDO
3247	IF ( ABS( coord_y(j) - cg%coord_y(jj) ) < tolerance ) THEN
3248	j = jstart
3249	DO WHILE ( coord_y(j) < cg%coord_y(jj) .AND. j < nyng )
3250	j = j + 1
3251	ENDDO
3252	jflv(jj) = MIN( MAX( j, nysg ), nyng )
3253	jfuv(jj) = jflv(jj)
3254	jstart = jflv(jj)
3255	ELSE
3256	j = jstart
3257	DO WHILE ( ( coord_y(j) < cg%coord_y(jj) - 0.5_wp * cg%dy ) &
3258	.AND. ( j < nyng ) )
3259	j = j + 1
3260	ENDDO
3261	jflv(jj) = MIN( MAX( j, nysg ), nyng )
3262	jr = j
3263	DO WHILE ( ( coord_y(jr) <= cg%coord_y(jj) + 0.5_wp * cg%dy ) &
3264	.AND. ( j < nyng+1 ) )
3265	j = j + 1
3266	jr = MIN( j, nyng )
3267	ENDDO
3268	jfuv(jj) = MIN( MAX( j-1, jflv(jj) ), nyng )
3269	jstart = jflv(jj)
3270	ENDIF
3271	!AH
3272	write(9,"('pmci_init_anterp_tophat, jj, jflv, jfuv: ', 3(i4,2x))") &
3273	jj, jflv(jj), jfuv(jj)
3274	flush(9)
3275
3276	ENDDO
3277	jflv(jcn) = nyng
3278	jfuv(jcn) = nyng
3279	!
3280	!-- j-indices of others for each jj-index value
3281	!-- jj=jcn is redundant for anterpolation
3282	jstart = nysg
3283	DO jj = jcs, jcn-1
3284	j = jstart
3285	DO WHILE ( ( coord_y(j) + 0.5_wp * dy < cg%coord_y(jj) ) .AND. &
3286	( j < nyng ) )
3287	j = j + 1
3288	ENDDO
3289	jflo(jj) = MIN( MAX( j, nysg ), nyng )
3290	jr = j
3291	DO WHILE ( ( coord_y(jr) + 0.5_wp * dy <= cg%coord_y(jj) + cg%dy ) &
3292	.AND. ( j < nyng+1 ) )
3293	j = j + 1
3294	jr = MIN( j, nyng )
3295	ENDDO
3296	jfuo(jj) = MIN( MAX( j-1, jflo(jj) ), nyng )
3297	jstart = jflo(jj)
3298	!AH
3299	write(9,"('pmci_init_anterp_tophat, ii, jflo, jfuo: ', 3(i4,2x))") &
3300	jj, jflo(jj), jfuo(jj)
3301	flush(9)
3302
3303	ENDDO
3304	jflo(jcn) = nyng
3305	jfuo(jcn) = nyng
3306	!
3307	!-- k-indices of w for each kk-index value
3308	!-- Note that anterpolation index limits are needed also for the top boundary
3309	!-- ghost cell level because of the reversibility correction in the interpolation.
3310	kstart = 0
3311	kflw(0) = 0
3312	kfuw(0) = 0
3313	tolerance = 0.000001_wp * dzw(1)
3314	DO kk = 1, cg%nz+1
3315	!
3316	!-- In case the child and parent grid lines match in z
3317	!-- use only the local j,i-child-grid plane for the anterpolation,
3318	!-- i.e use 2-D anterpolation. Else, use a 3-D anterpolation.
3319	k = kstart
3320	DO WHILE ( zw(k) < cg%zw(kk) - tolerance .AND. k < nzt+1 )
3321	k = k + 1
3322	ENDDO
3323	IF ( ABS( zw(k) - cg%zw(kk) ) < tolerance ) THEN
3324	k = kstart
3325	DO WHILE ( ( zw(k) < cg%zw(kk) ) .AND. ( k < nzt+1 ) )
3326	k = k + 1
3327	ENDDO
3328	kflw(kk) = MIN( MAX( k, 1 ), nzt + 1 )
3329	kfuw(kk) = kflw(kk)
3330	kstart = kflw(kk)
3331	ELSE
3332	k = kstart
3333	DO WHILE ( ( zw(k) < cg%zu(kk) ) .AND. ( k < nzt ) )
3334	k = k + 1
3335	ENDDO
3336	kflw(kk) = MIN( MAX( k, 1 ), nzt + 1 )
3337	IF ( kk+1 <= cg%nz+1 ) THEN
3338	DO WHILE ( ( zw(k) <= cg%zu(kk+1) ) .AND. ( k < nzt+1 ) )
3339	k = k + 1
3340	IF ( k > nzt + 1 ) EXIT ! This EXIT is to prevent zu(k) from flowing over.
3341	ENDDO
3342	kfuw(kk) = MIN( MAX( k-1, kflw(kk) ), nzt + 1 )
3343	ELSE
3344	kfuw(kk) = kflw(kk)
3345	ENDIF
3346	kstart = kflw(kk)
3347	ENDIF
3348	!AH
3349	write(9,"('pmci_init_anterp_tophat, kk, kflw, kfuw: ', 3(i4,2x))") &
3350	kk, kflw(kk), kfuw(kk)
3351	flush(9)
3352
3353	ENDDO
3354	!
3355	!-- k-indices of others for each kk-index value
3356	kstart = 0
3357	kflo(0) = 0
3358	kfuo(0) = 0
3359	!
3360	!-- Note that anterpolation index limits are needed also for the top boundary
3361	!-- ghost cell level because of the reversibility correction in the interpolation.
3362	!AH DO kk = 1, kcto+1
3363	DO kk = 1, cg%nz+1
3364	k = kstart
3365	!AH DO WHILE ( ( zu(k) < cg%zw(kk-1) ) .AND. ( k < nzt ) )
3366	!-- Note that this is an IMPORTANT correction for the reversibility correction
3367	DO WHILE ( ( zu(k) < cg%zw(kk-1) ) .AND. ( k <= nzt ) )
3368	k = k + 1
3369	ENDDO
3370	kflo(kk) = MIN( MAX( k, 1 ), nzt + 1 )
3371	!AH DO WHILE ( ( zu(k) <= cg%zw(kk) ) .AND. ( k < nzt+1 ) )
3372	!-- Note that this is an IMPORTANT correction for the reversibility correction
3373	DO WHILE ( ( zu(k) <= cg%zw(kk) ) .AND. ( k <= nzt+1 ) )
3374	k = k + 1
3375	IF ( k > nzt + 1 ) EXIT ! This EXIT is to prevent zu(k) from flowing over.
3376	ENDDO
3377	kfuo(kk) = MIN( MAX( k-1, kflo(kk) ), nzt + 1 )
3378	kstart = kflo(kk)
3379	!AH
3380	write(9,"('init kflo, kfuo: ', 4(i3,2x), e12.5)") kk, kflo(kk), kfuo(kk), nzt, cg%zw(kk)
3381	flush(9)
3382	ENDDO
3383	!
3384	!-- Precomputation of number of fine-grid nodes inside parent-grid cells.
3385	!-- Note that ii, jj, and kk are parent-grid indices.
3386	!-- This information is needed in anterpolation.
3387	DO ii = icl, icr
3388	DO jj = jcs, jcn
3389	!AH DO kk = 0, kcto+1
3390	DO kk = 0, cg%nz+1
3391	!
3392	!-- u-component
3393	DO i = iflu(ii), ifuu(ii)
3394	DO j = jflo(jj), jfuo(jj)
3395	DO k = kflo(kk), kfuo(kk)
3396	ijkfc_u(kk,jj,ii) = ijkfc_u(kk,jj,ii) + MERGE( 1, 0, &
3397	BTEST( wall_flags_0(k,j,i), 1 ) )
3398	ENDDO
3399	ENDDO
3400	ENDDO
3401	!
3402	!-- v-component
3403	DO i = iflo(ii), ifuo(ii)
3404	DO j = jflv(jj), jfuv(jj)
3405	DO k = kflo(kk), kfuo(kk)
3406	ijkfc_v(kk,jj,ii) = ijkfc_v(kk,jj,ii) + MERGE( 1, 0, &
3407	BTEST( wall_flags_0(k,j,i), 2 ) )
3408	ENDDO
3409	ENDDO
3410	ENDDO
3411	!
3412	!-- scalars
3413	DO i = iflo(ii), ifuo(ii)
3414	DO j = jflo(jj), jfuo(jj)
3415	DO k = kflo(kk), kfuo(kk)
3416	ijkfc_s(kk,jj,ii) = ijkfc_s(kk,jj,ii) + MERGE( 1, 0, &
3417	BTEST( wall_flags_0(k,j,i), 0 ) )
3418	ENDDO
3419	ENDDO
3420	ENDDO
3421	ENDDO
3422
3423	!AH DO kk = 0, kctw+1
3424	DO kk = 0, cg%nz+1
3425	!
3426	!-- w-component
3427	DO i = iflo(ii), ifuo(ii)
3428	DO j = jflo(jj), jfuo(jj)
3429	DO k = kflw(kk), kfuw(kk)
3430	ijkfc_w(kk,jj,ii) = ijkfc_w(kk,jj,ii) + MERGE( 1, 0, &
3431	BTEST( wall_flags_0(k,j,i), 3 ) )
3432	ENDDO
3433	ENDDO
3434	ENDDO
3435	ENDDO
3436
3437	ENDDO
3438	ENDDO
3439	!
3440	!-- Spatial under-relaxation coefficients
3441	ALLOCATE( frax(icl:icr) )
3442	ALLOCATE( fray(jcs:jcn) )
3443
3444	frax(icl:icr) = 1.0_wp
3445	fray(jcs:jcn) = 1.0_wp
3446
3447	IF ( nesting_mode /= 'vertical' ) THEN
3448	DO ii = icl, icr
3449	IF ( ifuu(ii) < ( nx + 1 ) / 2 ) THEN
3450	xi = ( MAX( 0.0_wp, ( cg%coord_x(ii) - &
3451	lower_left_coord_x ) ) / anterp_relax_length_l )**4
3452	frax(ii) = xi / ( 1.0_wp + xi )
3453	ELSE
3454	xi = ( MAX( 0.0_wp, ( lower_left_coord_x + ( nx + 1 ) * dx - &
3455	cg%coord_x(ii) ) ) / &
3456	anterp_relax_length_r )**4
3457	frax(ii) = xi / ( 1.0_wp + xi )
3458	ENDIF
3459	ENDDO
3460
3461	DO jj = jcs, jcn
3462	IF ( jfuv(jj) < ( ny + 1 ) / 2 ) THEN
3463	eta = ( MAX( 0.0_wp, ( cg%coord_y(jj) - &
3464	lower_left_coord_y ) ) / anterp_relax_length_s )**4
3465	fray(jj) = eta / ( 1.0_wp + eta )
3466	ELSE
3467	eta = ( MAX( 0.0_wp, ( lower_left_coord_y + ( ny + 1 ) * dy - &
3468	cg%coord_y(jj)) ) / &
3469	anterp_relax_length_n )**4
3470	fray(jj) = eta / ( 1.0_wp + eta )
3471	ENDIF
3472	ENDDO
3473	ENDIF
3474
3475	ALLOCATE( fraz(0:kcto) )
3476	DO kk = 0, kcto
3477	zeta = ( ( zu(nzt) - cg%zu(kk) ) / anterp_relax_length_t )**4
3478	fraz(kk) = zeta / ( 1.0_wp + zeta )
3479	ENDDO
3480
3481	END SUBROUTINE pmci_init_anterp_tophat
3482
3483
3484
3485	SUBROUTINE pmci_init_tkefactor
3486
3487	!
3488	!-- Computes the scaling factor for the SGS TKE from coarse grid to be used
3489	!-- as BC for the fine grid. Based on the Kolmogorov energy spectrum
3490	!-- for the inertial subrange and assumption of sharp cut-off of the resolved
3491	!-- energy spectrum. Near the surface, the reduction of TKE is made
3492	!-- smaller than further away from the surface.
3493	!-- Please note, in case parent and child model operate in RANS mode,
3494	!-- TKE is not grid depenedent and weighting factor is one.
3495
3496	IMPLICIT NONE
3497
3498	INTEGER(iwp) :: k !< index variable along z
3499	INTEGER(iwp) :: k_wall !< topography-top index along z
3500	INTEGER(iwp) :: kc !<
3501
3502	REAL(wp), PARAMETER :: cfw = 0.2_wp !<
3503	REAL(wp), PARAMETER :: c_tkef = 0.6_wp !<
3504	REAL(wp) :: fw !<
3505	REAL(wp), PARAMETER :: fw0 = 0.9_wp !<
3506	REAL(wp) :: glsf !<
3507	REAL(wp) :: glsc !<
3508	REAL(wp) :: height !<
3509	REAL(wp), PARAMETER :: p13 = 1.0_wp/3.0_wp !<
3510	REAL(wp), PARAMETER :: p23 = 2.0_wp/3.0_wp !<
3511
3512	!
3513	IF ( .NOT. rans_mode .AND. .NOT. rans_mode_parent ) THEN
3514	IF ( bc_dirichlet_l ) THEN
3515	ALLOCATE( tkefactor_l(nzb:nzt+1,nysg:nyng) )
3516	tkefactor_l = 0.0_wp
3517	i = nxl - 1
3518	DO j = nysg, nyng
3519	k_wall = get_topography_top_index_ji( j, i, 's' )
3520
3521	DO k = k_wall + 1, nzt
3522	kc = kco(k) + 1
3523	glsf = ( dx * dy * dzu(k) )**p13
3524	glsc = ( cg%dx * cg%dy cg%dzu(kc) )*p13
3525	height = zu(k) - zu(k_wall)
3526	fw = EXP( -cfw * height / glsf )
3527	tkefactor_l(k,j) = c_tkef * ( fw0 * fw + ( 1.0_wp - fw ) * &
3528	( glsf / glsc )**p23 )
3529	ENDDO
3530	tkefactor_l(k_wall,j) = c_tkef * fw0
3531	ENDDO
3532	ENDIF
3533
3534	IF ( bc_dirichlet_r ) THEN
3535	ALLOCATE( tkefactor_r(nzb:nzt+1,nysg:nyng) )
3536	tkefactor_r = 0.0_wp
3537	i = nxr + 1
3538	DO j = nysg, nyng
3539	k_wall = get_topography_top_index_ji( j, i, 's' )
3540
3541	DO k = k_wall + 1, nzt
3542	kc = kco(k) + 1
3543	glsf = ( dx * dy * dzu(k) )**p13
3544	glsc = ( cg%dx * cg%dy * cg%dzu(kc) )**p13
3545	height = zu(k) - zu(k_wall)
3546	fw = EXP( -cfw * height / glsf )
3547	tkefactor_r(k,j) = c_tkef * ( fw0 * fw + ( 1.0_wp - fw ) * &
3548	( glsf / glsc )**p23 )
3549	ENDDO
3550	tkefactor_r(k_wall,j) = c_tkef * fw0
3551	ENDDO
3552	ENDIF
3553
3554	IF ( bc_dirichlet_s ) THEN
3555	ALLOCATE( tkefactor_s(nzb:nzt+1,nxlg:nxrg) )
3556	tkefactor_s = 0.0_wp
3557	j = nys - 1
3558	DO i = nxlg, nxrg
3559	k_wall = get_topography_top_index_ji( j, i, 's' )
3560
3561	DO k = k_wall + 1, nzt
3562
3563	kc = kco(k) + 1
3564	glsf = ( dx * dy * dzu(k) )**p13
3565	glsc = ( cg%dx * cg%dy * cg%dzu(kc) ) ** p13
3566	height = zu(k) - zu(k_wall)
3567	fw = EXP( -cfw*height / glsf )
3568	tkefactor_s(k,i) = c_tkef * ( fw0 * fw + ( 1.0_wp - fw ) * &
3569	( glsf / glsc )**p23 )
3570	ENDDO
3571	tkefactor_s(k_wall,i) = c_tkef * fw0
3572	ENDDO
3573	ENDIF
3574
3575	IF ( bc_dirichlet_n ) THEN
3576	ALLOCATE( tkefactor_n(nzb:nzt+1,nxlg:nxrg) )
3577	tkefactor_n = 0.0_wp
3578	j = nyn + 1
3579	DO i = nxlg, nxrg
3580	k_wall = get_topography_top_index_ji( j, i, 's' )
3581
3582	DO k = k_wall + 1, nzt
3583
3584	kc = kco(k) + 1
3585	glsf = ( dx * dy * dzu(k) )**p13
3586	glsc = ( cg%dx * cg%dy * cg%dzu(kc) )**p13
3587	height = zu(k) - zu(k_wall)
3588	fw = EXP( -cfw * height / glsf )
3589	tkefactor_n(k,i) = c_tkef * ( fw0 * fw + ( 1.0_wp - fw ) * &
3590	( glsf / glsc )**p23 )
3591	ENDDO
3592	tkefactor_n(k_wall,i) = c_tkef * fw0
3593	ENDDO
3594	ENDIF
3595
3596	ALLOCATE( tkefactor_t(nysg:nyng,nxlg:nxrg) )
3597	k = nzt
3598
3599	DO i = nxlg, nxrg
3600	DO j = nysg, nyng
3601	!
3602	!-- Determine vertical index for local topography top
3603	k_wall = get_topography_top_index_ji( j, i, 's' )
3604
3605	kc = kco(k) + 1
3606	glsf = ( dx * dy * dzu(k) )**p13
3607	glsc = ( cg%dx * cg%dy * cg%dzu(kc) )**p13
3608	height = zu(k) - zu(k_wall)
3609	fw = EXP( -cfw * height / glsf )
3610	tkefactor_t(j,i) = c_tkef * ( fw0 * fw + ( 1.0_wp - fw ) * &
3611	( glsf / glsc )**p23 )
3612	ENDDO
3613	ENDDO
3614	!
3615	!-- RANS mode
3616	ELSE
3617	IF ( bc_dirichlet_l ) THEN
3618	ALLOCATE( tkefactor_l(nzb:nzt+1,nysg:nyng) )
3619	tkefactor_l = 1.0_wp
3620	ENDIF
3621	IF ( bc_dirichlet_r ) THEN
3622	ALLOCATE( tkefactor_r(nzb:nzt+1,nysg:nyng) )
3623	tkefactor_r = 1.0_wp
3624	ENDIF
3625	IF ( bc_dirichlet_s ) THEN
3626	ALLOCATE( tkefactor_s(nzb:nzt+1,nxlg:nxrg) )
3627	tkefactor_s = 1.0_wp
3628	ENDIF
3629	IF ( bc_dirichlet_n ) THEN
3630	ALLOCATE( tkefactor_n(nzb:nzt+1,nxlg:nxrg) )
3631	tkefactor_n = 1.0_wp
3632	ENDIF
3633
3634	ALLOCATE( tkefactor_t(nysg:nyng,nxlg:nxrg) )
3635	tkefactor_t = 1.0_wp
3636
3637	ENDIF
3638
3639	END SUBROUTINE pmci_init_tkefactor
3640
3641	#endif
3642	END SUBROUTINE pmci_setup_child
3643
3644
3645
3646	SUBROUTINE pmci_setup_coordinates
3647
3648	#if defined( __parallel )
3649	IMPLICIT NONE
3650
3651	INTEGER(iwp) :: i !<
3652	INTEGER(iwp) :: j !<
3653
3654	!
3655	!-- Create coordinate arrays.
3656	ALLOCATE( coord_x(-nbgp:nx+nbgp) )
3657	ALLOCATE( coord_y(-nbgp:ny+nbgp) )
3658
3659	DO i = -nbgp, nx + nbgp
3660	coord_x(i) = lower_left_coord_x + i * dx
3661	ENDDO
3662
3663	DO j = -nbgp, ny + nbgp
3664	coord_y(j) = lower_left_coord_y + j * dy
3665	ENDDO
3666
3667	#endif
3668	END SUBROUTINE pmci_setup_coordinates
3669
3670	!------------------------------------------------------------------------------!
3671	! Description:
3672	! ------------
3673	!> In this subroutine the number of coupled arrays is determined.
3674	!------------------------------------------------------------------------------!
3675	SUBROUTINE pmci_num_arrays
3676
3677	#if defined( __parallel )
3678	USE pmc_general, &
3679	ONLY: pmc_max_array
3680
3681	IMPLICIT NONE
3682	!
3683	!-- The number of coupled arrays depends on the model settings. At least
3684	!-- 5 arrays need to be coupled (u, v, w, e, diss). Please note, actually
3685	!-- e and diss (TKE and dissipation rate) are only required if RANS-RANS
3686	!-- nesting is applied, but memory is allocated nevertheless. This is because
3687	!-- the information whether they are needed or not is retrieved at a later
3688	!-- point in time. In case e and diss are not needed, they are also not
3689	!-- exchanged between parent and child.
3690	pmc_max_array = 5
3691	!
3692	!-- pt
3693	IF ( .NOT. neutral ) pmc_max_array = pmc_max_array + 1
3694
3695	IF ( humidity ) THEN
3696	!
3697	!-- q
3698	pmc_max_array = pmc_max_array + 1
3699	!
3700	!-- qc, nc
3701	IF ( bulk_cloud_model .AND. microphysics_morrison ) &
3702	pmc_max_array = pmc_max_array + 2
3703	!
3704	!-- qr, nr
3705	IF ( bulk_cloud_model .AND. microphysics_seifert ) &
3706	pmc_max_array = pmc_max_array + 2
3707	ENDIF
3708	!
3709	!-- s
3710	IF ( passive_scalar ) pmc_max_array = pmc_max_array + 1
3711	!
3712	!-- nr_part, part_adr
3713	IF ( particle_advection ) pmc_max_array = pmc_max_array + 2
3714	!
3715	!-- Chemistry, depends on number of species
3716	IF ( air_chemistry .AND. nest_chemistry ) &
3717	pmc_max_array = pmc_max_array + nspec
3718
3719
3720	#endif
3721	END SUBROUTINE pmci_num_arrays
3722
3723
3724
3725	SUBROUTINE pmci_set_array_pointer( name, child_id, nz_cl, n )
3726
3727	IMPLICIT NONE
3728
3729	INTEGER(iwp), INTENT(IN) :: child_id !<
3730	INTEGER(iwp), INTENT(IN) :: nz_cl !<
3731	INTEGER(iwp), INTENT(IN),OPTIONAL :: n !< index of chemical species
3732
3733	CHARACTER(LEN=*), INTENT(IN) :: name !<
3734
3735	#if defined( __parallel )
3736	INTEGER(iwp) :: ierr !<
3737
3738	REAL(wp), POINTER, DIMENSION(:,:) :: p_2d !<
3739	REAL(wp), POINTER, DIMENSION(:,:) :: p_2d_sec !<
3740	REAL(wp), POINTER, DIMENSION(:,:,:) :: p_3d !<
3741	REAL(wp), POINTER, DIMENSION(:,:,:) :: p_3d_sec !<
3742	INTEGER(idp), POINTER, DIMENSION(:,:) :: i_2d !<
3743
3744
3745	NULLIFY( p_3d )
3746	NULLIFY( p_2d )
3747	NULLIFY( i_2d )
3748
3749	!
3750	!-- List of array names, which can be coupled.
3751	!-- In case of 3D please change also the second array for the pointer version
3752	IF ( TRIM(name) == "u" ) p_3d => u
3753	IF ( TRIM(name) == "v" ) p_3d => v
3754	IF ( TRIM(name) == "w" ) p_3d => w
3755	IF ( TRIM(name) == "e" ) p_3d => e
3756	IF ( TRIM(name) == "pt" ) p_3d => pt
3757	IF ( TRIM(name) == "q" ) p_3d => q
3758	IF ( TRIM(name) == "qc" ) p_3d => qc
3759	IF ( TRIM(name) == "qr" ) p_3d => qr
3760	IF ( TRIM(name) == "nr" ) p_3d => nr
3761	IF ( TRIM(name) == "nc" ) p_3d => nc
3762	IF ( TRIM(name) == "s" ) p_3d => s
3763	IF ( TRIM(name) == "diss" ) p_3d => diss
3764	IF ( TRIM(name) == "nr_part" ) i_2d => nr_part
3765	IF ( TRIM(name) == "part_adr" ) i_2d => part_adr
3766	IF ( INDEX( TRIM(name), "chem_" ) /= 0 ) p_3d => chem_species(n)%conc
3767
3768	!
3769	!-- Next line is just an example for a 2D array (not active for coupling!)
3770	!-- Please note, that z0 has to be declared as TARGET array in modules.f90
3771	! IF ( TRIM(name) == "z0" ) p_2d => z0
3772
3773	#if defined( __nopointer )
3774	IF ( ASSOCIATED( p_3d ) ) THEN
3775	CALL pmc_s_set_dataarray( child_id, p_3d, nz_cl, nz )
3776	ELSEIF ( ASSOCIATED( p_2d ) ) THEN
3777	CALL pmc_s_set_dataarray( child_id, p_2d )
3778	ELSEIF ( ASSOCIATED( i_2d ) ) THEN
3779	CALL pmc_s_set_dataarray( child_id, i_2d )
3780	ELSE
3781	!
3782	!-- Give only one message for the root domain
3783	IF ( myid == 0 .AND. cpl_id == 1 ) THEN
3784
3785	message_string = 'pointer for array "' // TRIM( name ) // &
3786	'" can''t be associated'
3787	CALL message( 'pmci_set_array_pointer', 'PA0117', 3, 2, 0, 6, 0 )
3788	ELSE
3789	!
3790	!-- Avoid others to continue
3791	CALL MPI_BARRIER( comm2d, ierr )
3792	ENDIF
3793	ENDIF
3794	#else
3795	IF ( TRIM(name) == "u" ) p_3d_sec => u_2
3796	IF ( TRIM(name) == "v" ) p_3d_sec => v_2
3797	IF ( TRIM(name) == "w" ) p_3d_sec => w_2
3798	IF ( TRIM(name) == "e" ) p_3d_sec => e_2
3799	IF ( TRIM(name) == "pt" ) p_3d_sec => pt_2
3800	IF ( TRIM(name) == "q" ) p_3d_sec => q_2
3801	IF ( TRIM(name) == "qc" ) p_3d_sec => qc_2
3802	IF ( TRIM(name) == "qr" ) p_3d_sec => qr_2
3803	IF ( TRIM(name) == "nr" ) p_3d_sec => nr_2
3804	IF ( TRIM(name) == "nc" ) p_3d_sec => nc_2
3805	IF ( TRIM(name) == "s" ) p_3d_sec => s_2
3806	IF ( TRIM(name) == "diss" ) p_3d_sec => diss_2
3807	IF ( INDEX( TRIM(name), "chem_" ) /= 0 ) p_3d_sec => spec_conc_2(:,:,:,n)
3808
3809	IF ( ASSOCIATED( p_3d ) ) THEN
3810	CALL pmc_s_set_dataarray( child_id, p_3d, nz_cl, nz, &
3811	array_2 = p_3d_sec )
3812	ELSEIF ( ASSOCIATED( p_2d ) ) THEN
3813	CALL pmc_s_set_dataarray( child_id, p_2d )
3814	ELSEIF ( ASSOCIATED( i_2d ) ) THEN
3815	CALL pmc_s_set_dataarray( child_id, i_2d )
3816	ELSE
3817	!
3818	!-- Give only one message for the root domain
3819	IF ( myid == 0 .AND. cpl_id == 1 ) THEN
3820
3821	message_string = 'pointer for array "' // TRIM( name ) // &
3822	'" can''t be associated'
3823	CALL message( 'pmci_set_array_pointer', 'PA0117', 3, 2, 0, 6, 0 )
3824	ELSE
3825	!
3826	!-- Avoid others to continue
3827	CALL MPI_BARRIER( comm2d, ierr )
3828	ENDIF
3829
3830	ENDIF
3831	#endif
3832
3833	#endif
3834	END SUBROUTINE pmci_set_array_pointer
3835
3836
3837
3838	INTEGER FUNCTION get_number_of_childs ()
3839
3840	IMPLICIT NONE
3841
3842	#if defined( __parallel )
3843	get_number_of_childs = SIZE( pmc_parent_for_child ) - 1
3844	#else
3845	get_number_of_childs = 0
3846	#endif
3847
3848	RETURN
3849
3850	END FUNCTION get_number_of_childs
3851
3852
3853	INTEGER FUNCTION get_childid (id_index)
3854
3855	IMPLICIT NONE
3856
3857	INTEGER,INTENT(IN) :: id_index
3858
3859	#if defined( __parallel )
3860	get_childid = pmc_parent_for_child(id_index)
3861	#else
3862	get_childid = 0
3863	#endif
3864
3865	RETURN
3866
3867	END FUNCTION get_childid
3868
3869
3870
3871	SUBROUTINE get_child_edges (m, lx_coord, lx_coord_b, rx_coord, rx_coord_b, &
3872	sy_coord, sy_coord_b, ny_coord, ny_coord_b, &
3873	uz_coord, uz_coord_b)
3874	IMPLICIT NONE
3875	INTEGER,INTENT(IN) :: m
3876	REAL(wp),INTENT(OUT) :: lx_coord, lx_coord_b
3877	REAL(wp),INTENT(OUT) :: rx_coord, rx_coord_b
3878	REAL(wp),INTENT(OUT) :: sy_coord, sy_coord_b
3879	REAL(wp),INTENT(OUT) :: ny_coord, ny_coord_b
3880	REAL(wp),INTENT(OUT) :: uz_coord, uz_coord_b
3881
3882	lx_coord = childgrid(m)%lx_coord
3883	rx_coord = childgrid(m)%rx_coord
3884	sy_coord = childgrid(m)%sy_coord
3885	ny_coord = childgrid(m)%ny_coord
3886	uz_coord = childgrid(m)%uz_coord
3887
3888	lx_coord_b = childgrid(m)%lx_coord_b
3889	rx_coord_b = childgrid(m)%rx_coord_b
3890	sy_coord_b = childgrid(m)%sy_coord_b
3891	ny_coord_b = childgrid(m)%ny_coord_b
3892	uz_coord_b = childgrid(m)%uz_coord_b
3893
3894	END SUBROUTINE get_child_edges
3895
3896
3897
3898	SUBROUTINE get_child_gridspacing (m, dx,dy,dz)
3899
3900	IMPLICIT NONE
3901	INTEGER,INTENT(IN) :: m
3902	REAL(wp),INTENT(OUT) :: dx,dy
3903	REAL(wp),INTENT(OUT),OPTIONAL :: dz
3904
3905	dx = childgrid(m)%dx
3906	dy = childgrid(m)%dy
3907	IF(PRESENT(dz)) THEN
3908	dz = childgrid(m)%dz
3909	ENDIF
3910
3911	END SUBROUTINE get_child_gridspacing
3912
3913
3914
3915	SUBROUTINE pmci_create_child_arrays( name, is, ie, js, je, nzc, n )
3916
3917	IMPLICIT NONE
3918
3919	CHARACTER(LEN=*), INTENT(IN) :: name !<
3920
3921	INTEGER(iwp), INTENT(IN) :: ie !<
3922	INTEGER(iwp), INTENT(IN) :: is !<
3923	INTEGER(iwp), INTENT(IN) :: je !<
3924	INTEGER(iwp), INTENT(IN) :: js !<
3925	INTEGER(iwp), INTENT(IN) :: nzc !< nzc is cg%nz, but note that cg%nz is not the original nz of parent, but the highest parent-grid level needed for nesting.
3926
3927	INTEGER(iwp), INTENT(IN), OPTIONAL :: n !< number of chemical species
3928
3929	#if defined( __parallel )
3930	INTEGER(iwp) :: ierr !<
3931
3932	REAL(wp), POINTER,DIMENSION(:,:) :: p_2d !<
3933	REAL(wp), POINTER,DIMENSION(:,:,:) :: p_3d !<
3934	INTEGER(idp), POINTER,DIMENSION(:,:) :: i_2d !<
3935
3936
3937	NULLIFY( p_3d )
3938	NULLIFY( p_2d )
3939	NULLIFY( i_2d )
3940
3941	!
3942	!-- List of array names, which can be coupled
3943	IF ( TRIM( name ) == "u" ) THEN
3944	IF ( .NOT. ALLOCATED( uc ) ) ALLOCATE( uc(0:nzc+1,js:je,is:ie) )
3945	p_3d => uc
3946	ELSEIF ( TRIM( name ) == "v" ) THEN
3947	IF ( .NOT. ALLOCATED( vc ) ) ALLOCATE( vc(0:nzc+1,js:je,is:ie) )
3948	p_3d => vc
3949	ELSEIF ( TRIM( name ) == "w" ) THEN
3950	IF ( .NOT. ALLOCATED( wc ) ) ALLOCATE( wc(0:nzc+1,js:je,is:ie) )
3951	p_3d => wc
3952	ELSEIF ( TRIM( name ) == "e" ) THEN
3953	IF ( .NOT. ALLOCATED( ec ) ) ALLOCATE( ec(0:nzc+1,js:je,is:ie) )
3954	p_3d => ec
3955	ELSEIF ( TRIM( name ) == "diss" ) THEN
3956	IF ( .NOT. ALLOCATED( dissc ) ) ALLOCATE( dissc(0:nzc+1,js:je,is:ie) )
3957	p_3d => dissc
3958	ELSEIF ( TRIM( name ) == "pt") THEN
3959	IF ( .NOT. ALLOCATED( ptc ) ) ALLOCATE( ptc(0:nzc+1,js:je,is:ie) )
3960	p_3d => ptc
3961	ELSEIF ( TRIM( name ) == "q") THEN
3962	IF ( .NOT. ALLOCATED( q_c ) ) ALLOCATE( q_c(0:nzc+1,js:je,is:ie) )
3963	p_3d => q_c
3964	ELSEIF ( TRIM( name ) == "qc") THEN
3965	IF ( .NOT. ALLOCATED( qcc ) ) ALLOCATE( qcc(0:nzc+1,js:je,is:ie) )
3966	p_3d => qcc
3967	ELSEIF ( TRIM( name ) == "qr") THEN
3968	IF ( .NOT. ALLOCATED( qrc ) ) ALLOCATE( qrc(0:nzc+1,js:je,is:ie) )
3969	p_3d => qrc
3970	ELSEIF ( TRIM( name ) == "nr") THEN
3971	IF ( .NOT. ALLOCATED( nrc ) ) ALLOCATE( nrc(0:nzc+1,js:je,is:ie) )
3972	p_3d => nrc
3973	ELSEIF ( TRIM( name ) == "nc") THEN
3974	IF ( .NOT. ALLOCATED( ncc ) ) ALLOCATE( ncc(0:nzc+1,js:je,is:ie) )
3975	p_3d => ncc
3976	ELSEIF ( TRIM( name ) == "s") THEN
3977	IF ( .NOT. ALLOCATED( sc ) ) ALLOCATE( sc(0:nzc+1,js:je,is:ie) )
3978	p_3d => sc
3979	ELSEIF ( TRIM( name ) == "nr_part") THEN
3980	IF ( .NOT. ALLOCATED( nr_partc ) ) ALLOCATE( nr_partc(js:je,is:ie) )
3981	i_2d => nr_partc
3982	ELSEIF ( TRIM( name ) == "part_adr") THEN
3983	IF ( .NOT. ALLOCATED( part_adrc ) ) ALLOCATE( part_adrc(js:je,is:ie) )
3984	i_2d => part_adrc
3985	ELSEIF ( TRIM( name(1:5) ) == "chem_" ) THEN
3986	IF ( .NOT. ALLOCATED( chem_spec_c ) ) &
3987	ALLOCATE( chem_spec_c(0:nzc+1,js:je,is:ie,1:nspec) )
3988	p_3d => chem_spec_c(:,:,:,n)
3989	!ELSEIF (trim(name) == "z0") then
3990	!IF (.not.allocated(z0c)) allocate(z0c(js:je, is:ie))
3991	!p_2d => z0c
3992	ENDIF
3993
3994	IF ( ASSOCIATED( p_3d ) ) THEN
3995	CALL pmc_c_set_dataarray( p_3d )
3996	ELSEIF ( ASSOCIATED( p_2d ) ) THEN
3997	CALL pmc_c_set_dataarray( p_2d )
3998	ELSEIF ( ASSOCIATED( i_2d ) ) THEN
3999	CALL pmc_c_set_dataarray( i_2d )
4000	ELSE
4001	!
4002	!-- Give only one message for the first child domain
4003	IF ( myid == 0 .AND. cpl_id == 2 ) THEN
4004
4005	message_string = 'pointer for array "' // TRIM( name ) // &
4006	'" can''t be associated'
4007	CALL message( 'pmci_create_child_arrays', 'PA0170', 3, 2, 0, 6, 0 )
4008	ELSE
4009	!
4010	!-- Prevent others from continuing
4011	CALL MPI_BARRIER( comm2d, ierr )
4012	ENDIF
4013	ENDIF
4014
4015	#endif
4016	END SUBROUTINE pmci_create_child_arrays
4017
4018
4019
4020	SUBROUTINE pmci_parent_initialize
4021
4022	!
4023	!-- Send data for the children in order to let them create initial
4024	!-- conditions by interpolating the parent-domain fields.
4025	#if defined( __parallel )
4026	IMPLICIT NONE
4027
4028	INTEGER(iwp) :: child_id !<
4029	INTEGER(iwp) :: m !<
4030
4031	REAL(wp) :: waittime !<
4032
4033
4034	DO m = 1, SIZE( pmc_parent_for_child ) - 1
4035	child_id = pmc_parent_for_child(m)
4036	CALL pmc_s_fillbuffer( child_id, waittime=waittime )
4037	ENDDO
4038
4039	#endif
4040	END SUBROUTINE pmci_parent_initialize
4041
4042
4043
4044	SUBROUTINE pmci_child_initialize
4045
4046	!
4047	!-- Create initial conditions for the current child domain by interpolating
4048	!-- the parent-domain fields.
4049	#if defined( __parallel )
4050	IMPLICIT NONE
4051
4052	INTEGER(iwp) :: i !<
4053	INTEGER(iwp) :: icl !<
4054	INTEGER(iwp) :: icr !<
4055	INTEGER(iwp) :: j !<
4056	INTEGER(iwp) :: jcn !<
4057	INTEGER(iwp) :: jcs !<
4058	INTEGER(iwp) :: k !<
4059	INTEGER(iwp) :: n !< running index for chemical species
4060
4061	REAL(wp) :: waittime !<
4062
4063	!
4064	!-- Root model is never anyone's child
4065	IF ( cpl_id > 1 ) THEN
4066	!
4067	!-- Child domain boundaries in the parent index space
4068	icl = coarse_bound(1)
4069	icr = coarse_bound(2)
4070	jcs = coarse_bound(3)
4071	jcn = coarse_bound(4)
4072	!
4073	!-- Get data from the parent
4074	CALL pmc_c_getbuffer( waittime = waittime )
4075	!
4076	!-- The interpolation.
4077	CALL pmci_interp_tril_all ( u, uc, icu, jco, kco, r1xu, r2xu, r1yo, &
4078	r2yo, r1zo, r2zo, kcto, iflu, ifuu, &
4079	jflo, jfuo, kflo, kfuo, ijkfc_u, 'u' )
4080	CALL pmci_interp_tril_all ( v, vc, ico, jcv, kco, r1xo, r2xo, r1yv, &
4081	r2yv, r1zo, r2zo, kcto, iflo, ifuo, &
4082	jflv, jfuv, kflo, kfuo, ijkfc_v, 'v' )
4083	CALL pmci_interp_tril_all ( w, wc, ico, jco, kcw, r1xo, r2xo, r1yo, &
4084	r2yo, r1zw, r2zw, kctw, iflo, ifuo, &
4085	jflo, jfuo, kflw, kfuw, ijkfc_w, 'w' )
4086
4087	IF ( ( rans_mode_parent .AND. rans_mode ) .OR. &
4088	( .NOT. rans_mode_parent .AND. .NOT. rans_mode .AND. &
4089	.NOT. constant_diffusion ) ) THEN
4090	CALL pmci_interp_tril_all ( e, ec, ico, jco, kco, r1xo, r2xo, r1yo, &
4091	r2yo, r1zo, r2zo, kcto, iflo, ifuo, &
4092	jflo, jfuo, kflo, kfuo, ijkfc_s, 'e' )
4093	ENDIF
4094
4095	IF ( rans_mode_parent .AND. rans_mode .AND. rans_tke_e ) THEN
4096	CALL pmci_interp_tril_all ( diss, dissc, ico, jco, kco, r1xo, r2xo,&
4097	r1yo, r2yo, r1zo, r2zo, kcto, iflo, ifuo,&
4098	jflo, jfuo, kflo, kfuo, ijkfc_s, 's' )
4099	ENDIF
4100
4101	IF ( .NOT. neutral ) THEN
4102	CALL pmci_interp_tril_all ( pt, ptc, ico, jco, kco, r1xo, r2xo, &
4103	r1yo, r2yo, r1zo, r2zo, kcto, iflo, ifuo,&
4104	jflo, jfuo, kflo, kfuo, ijkfc_s, 's' )
4105	ENDIF
4106
4107	IF ( humidity ) THEN
4108
4109	CALL pmci_interp_tril_all ( q, q_c, ico, jco, kco, r1xo, r2xo, r1yo, &
4110	r2yo, r1zo, r2zo, kcto, iflo, ifuo, &
4111	jflo, jfuo, kflo, kfuo, ijkfc_s, 's' )
4112
4113	IF ( bulk_cloud_model .AND. microphysics_morrison ) THEN
4114	CALL pmci_interp_tril_all ( qc, qcc, ico, jco, kco, r1xo, r2xo, &
4115	r1yo, r2yo, r1zo, r2zo, kcto, &
4116	iflo, ifuo, jflo, jfuo, kflo, kfuo, &
4117	ijkfc_s, 's' )
4118	CALL pmci_interp_tril_all ( nc, ncc, ico, jco, kco, r1xo, r2xo, &
4119	r1yo, r2yo, r1zo, r2zo, kcto, &
4120	iflo, ifuo, jflo, jfuo, kflo, kfuo, &
4121	ijkfc_s, 's' )
4122	ENDIF
4123
4124	IF ( bulk_cloud_model .AND. microphysics_seifert ) THEN
4125	CALL pmci_interp_tril_all ( qr, qrc, ico, jco, kco, r1xo, r2xo, &
4126	r1yo, r2yo, r1zo, r2zo, kcto, &
4127	iflo, ifuo, jflo, jfuo, kflo, kfuo, &
4128	ijkfc_s, 's' )
4129	CALL pmci_interp_tril_all ( nr, nrc, ico, jco, kco, r1xo, r2xo, &
4130	r1yo, r2yo, r1zo, r2zo, kcto, &
4131	iflo, ifuo, jflo, jfuo, kflo, kfuo, &
4132	ijkfc_s, 's' )
4133	ENDIF
4134
4135	ENDIF
4136
4137	IF ( passive_scalar ) THEN
4138	CALL pmci_interp_tril_all ( s, sc, ico, jco, kco, r1xo, r2xo, r1yo, &
4139	r2yo, r1zo, r2zo, kcto, iflo, ifuo, &
4140	jflo, jfuo, kflo, kfuo, ijkfc_s, 's' )
4141	ENDIF
4142
4143	IF ( air_chemistry .AND. nest_chemistry ) THEN
4144	DO n = 1, nspec
4145	CALL pmci_interp_tril_all ( chem_species(n)%conc, &
4146	chem_spec_c(:,:,:,n), &
4147	ico, jco, kco, r1xo, r2xo, r1yo, &
4148	r2yo, r1zo, r2zo, kcto, iflo, ifuo, &
4149	jflo, jfuo, kflo, kfuo, ijkfc_s, 's' )
4150	ENDDO
4151	ENDIF
4152
4153	IF ( topography /= 'flat' ) THEN
4154	!
4155	!-- Inside buildings set velocities and TKE back to zero.
4156	!-- Other scalars (pt, q, s, km, kh, p, sa, ...) are ignored at present,
4157	!-- maybe revise later.
4158	DO i = nxlg, nxrg
4159	DO j = nysg, nyng
4160	DO k = nzb, nzt
4161	u(k,j,i) = MERGE( u(k,j,i), 0.0_wp, &
4162	BTEST( wall_flags_0(k,j,i), 1 ) )
4163	v(k,j,i) = MERGE( v(k,j,i), 0.0_wp, &
4164	BTEST( wall_flags_0(k,j,i), 2 ) )
4165	w(k,j,i) = MERGE( w(k,j,i), 0.0_wp, &
4166	BTEST( wall_flags_0(k,j,i), 3 ) )
4167	! e(k,j,i) = MERGE( e(k,j,i), 0.0_wp, &
4168	! BTEST( wall_flags_0(k,j,i), 0 ) )
4169	u_p(k,j,i) = MERGE( u_p(k,j,i), 0.0_wp, &
4170	BTEST( wall_flags_0(k,j,i), 1 ) )
4171	v_p(k,j,i) = MERGE( v_p(k,j,i), 0.0_wp, &
4172	BTEST( wall_flags_0(k,j,i), 2 ) )
4173	w_p(k,j,i) = MERGE( w_p(k,j,i), 0.0_wp, &
4174	BTEST( wall_flags_0(k,j,i), 3 ) )
4175	! e_p(k,j,i) = MERGE( e_p(k,j,i), 0.0_wp, &
4176	! BTEST( wall_flags_0(k,j,i), 0 ) )
4177	ENDDO
4178	ENDDO
4179	ENDDO
4180	ENDIF
4181	ENDIF
4182
4183
4184	CONTAINS
4185
4186
4187	SUBROUTINE pmci_interp_tril_all( f, fc, ic, jc, kc, r1x, r2x, r1y, r2y, &
4188	r1z, r2z, kct, ifl, ifu, jfl, jfu, &
4189	kfl, kfu, ijkfc, var )
4190	!
4191	!-- Interpolation of the internal values for the child-domain initialization
4192	!-- This subroutine is based on trilinear interpolation.
4193	!-- Coding based on interp_tril_lr/sn/t
4194	IMPLICIT NONE
4195
4196	CHARACTER(LEN=1), INTENT(IN) :: var !<
4197
4198	INTEGER(iwp), DIMENSION(nxlg:nxrg), INTENT(IN) :: ic !<
4199	INTEGER(iwp), DIMENSION(nysg:nyng), INTENT(IN) :: jc !<
4200	INTEGER(iwp), DIMENSION(nzb:nzt+1), INTENT(IN) :: kc !<
4201
4202	REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg), INTENT(INOUT) :: f !<
4203	REAL(wp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), INTENT(IN) :: fc !<
4204	REAL(wp), DIMENSION(nxlg:nxrg), INTENT(IN) :: r1x !<
4205	REAL(wp), DIMENSION(nxlg:nxrg), INTENT(IN) :: r2x !<
4206	REAL(wp), DIMENSION(nysg:nyng), INTENT(IN) :: r1y !<
4207	REAL(wp), DIMENSION(nysg:nyng), INTENT(IN) :: r2y !<
4208	REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN) :: r1z !<
4209	REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN) :: r2z !<
4210
4211	INTEGER(iwp) :: kct
4212	INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) :: ifl !< Indicates start index of child cells belonging to certain parent cell - x direction
4213	INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) :: ifu !< Indicates end index of child cells belonging to certain parent cell - x direction
4214	INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) :: jfl !< Indicates start index of child cells belonging to certain parent cell - y direction
4215	INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) :: jfu !< Indicates start index of child cells belonging to certain parent cell - y direction
4216	INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN) :: kfl !< Indicates start index of child cells belonging to certain parent cell - z direction
4217	INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN) :: kfu !< Indicates start index of child cells belonging to certain parent cell - z direction
4218	INTEGER(iwp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box
4219
4220	INTEGER(iwp) :: i !<
4221	INTEGER(iwp) :: ib !<
4222	INTEGER(iwp) :: ie !<
4223	INTEGER(iwp) :: ijk !<
4224	INTEGER(iwp) :: j !<
4225	INTEGER(iwp) :: jb !<
4226	INTEGER(iwp) :: je !<
4227	INTEGER(iwp) :: k !<
4228	INTEGER(iwp) :: k_wall !<
4229	INTEGER(iwp) :: k1 !<
4230	INTEGER(iwp) :: kb !<
4231	INTEGER(iwp) :: kbc !<
4232	INTEGER(iwp) :: l !<
4233	INTEGER(iwp) :: m !<
4234	INTEGER(iwp) :: n !<
4235	INTEGER(iwp) :: var_flag !<
4236
4237	REAL(wp) :: cellsum !<
4238	REAL(wp) :: cellsumd !<
4239	REAL(wp) :: fk !<
4240	REAL(wp) :: fkj !<
4241	REAL(wp) :: fkjp !<
4242	REAL(wp) :: fkp !<
4243	REAL(wp) :: fkpj !<
4244	REAL(wp) :: fkpjp !<
4245	REAL(wp) :: logratio !<
4246	REAL(wp) :: logzuc1 !<
4247	REAL(wp) :: rcorr !<
4248	REAL(wp) :: rcorr_ijk !<
4249	REAL(wp) :: zuc1 !<
4250	REAL(wp) :: z0_topo !< roughness at vertical walls
4251
4252
4253	ib = nxl
4254	ie = nxr
4255	jb = nys
4256	je = nyn
4257	kb = 0
4258	IF ( nesting_mode /= 'vertical' ) THEN
4259	IF ( bc_dirichlet_l ) THEN
4260	ib = nxl - 1
4261	!
4262	!-- For u, nxl is a ghost node, but not for the other variables
4263	IF ( var == 'u' ) THEN
4264	ib = nxl
4265	ENDIF
4266	ENDIF
4267	IF ( bc_dirichlet_s ) THEN
4268	jb = nys - 1
4269	!
4270	!-- For v, nys is a ghost node, but not for the other variables
4271	IF ( var == 'v' ) THEN
4272	jb = nys
4273	ENDIF
4274	ENDIF
4275	IF ( bc_dirichlet_r ) THEN
4276	ie = nxr + 1
4277	ENDIF
4278	IF ( bc_dirichlet_n ) THEN
4279	je = nyn + 1
4280	ENDIF
4281	ENDIF
4282
4283	IF ( var == 'u' ) THEN
4284	var_flag = 1
4285	ELSEIF ( var == 'v' ) THEN
4286	var_flag = 2
4287	ELSEIF ( var == 'w' ) THEN
4288	var_flag = 3
4289	ELSE
4290	var_flag = 0
4291	ENDIF
4292	!
4293	!-- Trilinear interpolation.
4294	DO i = ib, ie
4295	DO j = jb, je
4296	!
4297	!-- Determine the vertical index of the first node above the
4298	!-- topography top at grid point (j,i) in order to not overwrite
4299	!-- the bottom BC.
4300	! kb = get_topography_top_index_ji( j, i, TRIM ( var ) ) + 1
4301	DO k = kb, nzt + 1
4302	l = ic(i)
4303	m = jc(j)
4304	n = kc(k)
4305	fkj = r1x(i) * fc(n,m,l) + r2x(i) * fc(n,m,l+1)
4306	fkjp = r1x(i) * fc(n,m+1,l) + r2x(i) * fc(n,m+1,l+1)
4307	fkpj = r1x(i) * fc(n+1,m,l) + r2x(i) * fc(n+1,m,l+1)
4308	fkpjp = r1x(i) * fc(n+1,m+1,l) + r2x(i) * fc(n+1,m+1,l+1)
4309	fk = r1y(j) * fkj + r2y(j) * fkjp
4310	fkp = r1y(j) * fkpj + r2y(j) * fkpjp
4311	f(k,j,i) = r1z(k) * fk + r2z(k) * fkp
4312	ENDDO
4313	ENDDO
4314	ENDDO
4315	!
4316	!-- Correct the interpolated values of u and v in near-wall nodes, i.e. in
4317	!-- the nodes below the coarse-grid nodes with k=1. The corrction is only
4318	!-- made over horizontal wall surfaces in this phase. For the nest boundary
4319	!-- conditions, a corresponding correction is made for all vertical walls,
4320	!-- too.
4321	IF ( constant_flux_layer .AND. ( var == 'u' .OR. var == 'v' ) ) THEN
4322	z0_topo = roughness_length
4323	DO i = ib, nxr
4324	DO j = jb, nyn
4325	!
4326	!-- Determine vertical index of topography top at grid point (j,i)
4327	k_wall = get_topography_top_index_ji( j, i, TRIM ( var ) )
4328	!
4329	!-- kbc is the first coarse-grid point above the surface
4330	kbc = 1
4331	DO WHILE ( cg%zu(kbc) < zu(k_wall) )
4332	kbc = kbc + 1
4333	ENDDO
4334	zuc1 = cg%zu(kbc)
4335	k1 = k_wall + 1
4336	DO WHILE ( zu(k1) < zuc1 )
4337	k1 = k1 + 1
4338	ENDDO
4339	logzuc1 = LOG( ( zu(k1) - zu(k_wall) ) / z0_topo )
4340
4341	k = k_wall + 1
4342	DO WHILE ( zu(k) < zuc1 )
4343	logratio = ( LOG( ( zu(k) - zu(k_wall) ) / z0_topo ) ) / &
4344	logzuc1
4345	f(k,j,i) = logratio * f(k1,j,i)
4346	k = k + 1
4347	ENDDO
4348	f(k_wall,j,i) = 0.0_wp
4349	ENDDO
4350	ENDDO
4351
4352	ELSEIF ( var == 'w' ) THEN
4353
4354	DO i = ib, nxr
4355	DO j = jb, nyn
4356	!
4357	!-- Determine vertical index of topography top at grid point (j,i)
4358	k_wall = get_topography_top_index_ji( j, i, 'w' )
4359
4360	f(k_wall,j,i) = 0.0_wp
4361	ENDDO
4362	ENDDO
4363
4364	ENDIF
4365	!
4366	!-- Apply the reversibility correction.
4367	DO l = icl, icr
4368	DO m = jcs, jcn
4369	DO n = 0, kct+1
4370	ijk = 1
4371	cellsum = 0.0_wp
4372	cellsumd = 0.0_wp
4373	!
4374	!-- Note that the index name i must not be used here as a loop
4375	!-- index name since i is the constant boundary index, hence
4376	!-- the name ia.
4377	DO i = ifl(l), ifu(l)
4378	DO j = jfl(m), jfu(m)
4379	DO k = kfl(n), kfu(n)
4380	cellsum = cellsum + MERGE( f(k,j,i), 0.0_wp, &
4381	BTEST( wall_flags_0(k,j,i), var_flag ) )
4382	celltmpd(ijk) = ABS( fc(n,m,l) - f(k,j,i) )
4383	cellsumd = cellsumd + MERGE( celltmpd(ijk), &
4384	0.0_wp, BTEST( wall_flags_0(k,j,i), var_flag ) )
4385	ijk = ijk + 1
4386	ENDDO
4387	ENDDO
4388	ENDDO
4389
4390	IF ( ijkfc(n,m,l) /= 0 ) THEN
4391	cellsum = cellsum / REAL( ijkfc(n,m,l), KIND=wp )
4392	rcorr = fc(n,m,l) - cellsum
4393	cellsumd = cellsumd / REAL( ijkfc(n,m,l), KIND=wp )
4394	ELSE
4395	cellsum = 0.0_wp
4396	rcorr = 0.0_wp
4397	cellsumd = 1.0_wp
4398	celltmpd = 1.0_wp
4399	ENDIF
4400	!
4401	!-- Distribute the correction term to the child nodes according to
4402	!-- their relative difference to the parent value such that the
4403	!-- node with the largest difference gets the largest share of the
4404	!-- correction. The distribution is skipped if rcorr is negligibly
4405	!-- small in order to avoid division by zero.
4406	IF ( ABS(rcorr) < 0.000001_wp ) THEN
4407	cellsumd = 1.0_wp
4408	celltmpd = 1.0_wp
4409	ENDIF
4410
4411	ijk = 1
4412	DO i = ifl(l), ifu(l)
4413	DO j = jfl(m), jfu(m)
4414	DO k = kfl(n), kfu(n)
4415	rcorr_ijk = rcorr * celltmpd(ijk) / cellsumd
4416	f(k,j,i) = f(k,j,i) + rcorr_ijk
4417	ijk = ijk + 1
4418	ENDDO
4419	ENDDO
4420	ENDDO
4421
4422	ENDDO ! n
4423	ENDDO ! m
4424	ENDDO ! l
4425
4426	END SUBROUTINE pmci_interp_tril_all
4427
4428	#endif
4429	END SUBROUTINE pmci_child_initialize
4430
4431
4432
4433	SUBROUTINE pmci_check_setting_mismatches
4434	!
4435	!-- Check for mismatches between settings of master and child variables
4436	!-- (e.g., all children have to follow the end_time settings of the root model).
4437	!-- The root model overwrites variables in the other models, so these variables
4438	!-- only need to be set once in file PARIN.
4439
4440	#if defined( __parallel )
4441
4442	USE control_parameters, &
4443	ONLY: dt_restart, end_time, message_string, restart_time, time_restart
4444
4445	IMPLICIT NONE
4446
4447	INTEGER :: ierr
4448
4449	REAL(wp) :: dt_restart_root
4450	REAL(wp) :: end_time_root
4451	REAL(wp) :: restart_time_root
4452	REAL(wp) :: time_restart_root
4453
4454	!
4455	!-- Check the time to be simulated.
4456	!-- Here, and in the following, the root process communicates the respective
4457	!-- variable to all others, and its value will then be compared with the local
4458	!-- values.
4459	IF ( pmc_is_rootmodel() ) end_time_root = end_time
4460	CALL MPI_BCAST( end_time_root, 1, MPI_REAL, 0, comm_world_nesting, ierr )
4461
4462	IF ( .NOT. pmc_is_rootmodel() ) THEN
4463	IF ( end_time /= end_time_root ) THEN
4464	WRITE( message_string, * ) 'mismatch between root model and ', &
4465	'child settings:& end_time(root) = ', end_time_root, &
4466	'& end_time(child) = ', end_time, '& child value is set', &
4467	' to root value'
4468	CALL message( 'pmci_check_setting_mismatches', 'PA0419', 0, 1, 0, 6, &
4469	0 )
4470	end_time = end_time_root
4471	ENDIF
4472	ENDIF
4473	!
4474	!-- Same for restart time
4475	IF ( pmc_is_rootmodel() ) restart_time_root = restart_time
4476	CALL MPI_BCAST( restart_time_root, 1, MPI_REAL, 0, comm_world_nesting, ierr )
4477
4478	IF ( .NOT. pmc_is_rootmodel() ) THEN
4479	IF ( restart_time /= restart_time_root ) THEN
4480	WRITE( message_string, * ) 'mismatch between root model and ', &
4481	'child settings: & restart_time(root) = ', restart_time_root, &
4482	'& restart_time(child) = ', restart_time, '& child ', &
4483	'value is set to root value'
4484	CALL message( 'pmci_check_setting_mismatches', 'PA0419', 0, 1, 0, 6, &
4485	0 )
4486	restart_time = restart_time_root
4487	ENDIF
4488	ENDIF
4489	!
4490	!-- Same for dt_restart
4491	IF ( pmc_is_rootmodel() ) dt_restart_root = dt_restart
4492	CALL MPI_BCAST( dt_restart_root, 1, MPI_REAL, 0, comm_world_nesting, ierr )
4493
4494	IF ( .NOT. pmc_is_rootmodel() ) THEN
4495	IF ( dt_restart /= dt_restart_root ) THEN
4496	WRITE( message_string, * ) 'mismatch between root model and ', &
4497	'child settings: & dt_restart(root) = ', dt_restart_root, &
4498	'& dt_restart(child) = ', dt_restart, '& child ', &
4499	'value is set to root value'
4500	CALL message( 'pmci_check_setting_mismatches', 'PA0419', 0, 1, 0, 6, &
4501	0 )
4502	dt_restart = dt_restart_root
4503	ENDIF
4504	ENDIF
4505	!
4506	!-- Same for time_restart
4507	IF ( pmc_is_rootmodel() ) time_restart_root = time_restart
4508	CALL MPI_BCAST( time_restart_root, 1, MPI_REAL, 0, comm_world_nesting, ierr )
4509
4510	IF ( .NOT. pmc_is_rootmodel() ) THEN
4511	IF ( time_restart /= time_restart_root ) THEN
4512	WRITE( message_string, * ) 'mismatch between root model and ', &
4513	'child settings: & time_restart(root) = ', time_restart_root, &
4514	'& time_restart(child) = ', time_restart, '& child ', &
4515	'value is set to root value'
4516	CALL message( 'pmci_check_setting_mismatches', 'PA0419', 0, 1, 0, 6, &
4517	0 )
4518	time_restart = time_restart_root
4519	ENDIF
4520	ENDIF
4521
4522	#endif
4523
4524	END SUBROUTINE pmci_check_setting_mismatches
4525
4526
4527
4528	SUBROUTINE pmci_synchronize
4529
4530	#if defined( __parallel )
4531	!
4532	!-- Unify the time steps for each model and synchronize using
4533	!-- MPI_ALLREDUCE with the MPI_MIN operator over all processes using
4534	!-- the global communicator MPI_COMM_WORLD.
4535
4536	IMPLICIT NONE
4537
4538	INTEGER(iwp) :: ierr !<
4539	REAL(wp), DIMENSION(1) :: dtl !<
4540	REAL(wp), DIMENSION(1) :: dtg !<
4541
4542
4543	dtl(1) = dt_3d
4544	CALL MPI_ALLREDUCE( dtl, dtg, 1, MPI_REAL, MPI_MIN, MPI_COMM_WORLD, ierr )
4545	dt_3d = dtg(1)
4546
4547	#endif
4548	END SUBROUTINE pmci_synchronize
4549
4550
4551
4552	SUBROUTINE pmci_set_swaplevel( swaplevel )
4553
4554	!
4555	!-- After each Runge-Kutta sub-timestep, alternately set buffer one or buffer
4556	!-- two active
4557
4558	IMPLICIT NONE
4559
4560	INTEGER(iwp), INTENT(IN) :: swaplevel !< swaplevel (1 or 2) of PALM's
4561	!< timestep
4562
4563	INTEGER(iwp) :: child_id !<
4564	INTEGER(iwp) :: m !<
4565
4566	#if defined( __parallel )
4567	DO m = 1, SIZE( pmc_parent_for_child )-1
4568	child_id = pmc_parent_for_child(m)
4569	CALL pmc_s_set_active_data_array( child_id, swaplevel )
4570	ENDDO
4571	#endif
4572	END SUBROUTINE pmci_set_swaplevel
4573
4574
4575
4576	SUBROUTINE pmci_datatrans( local_nesting_mode )
4577	!
4578	!-- This subroutine controls the nesting according to the nestpar
4579	!-- parameter nesting_mode (two-way (default) or one-way) and the
4580	!-- order of anterpolations according to the nestpar parameter
4581	!-- nesting_datatransfer_mode (cascade, overlap or mixed (default)).
4582	!-- Although nesting_mode is a variable of this model, pass it as
4583	!-- an argument to allow for example to force one-way initialization
4584	!-- phase.
4585
4586	IMPLICIT NONE
4587
4588	CHARACTER(LEN=*), INTENT(IN) :: local_nesting_mode
4589
4590
4591	IF ( TRIM( local_nesting_mode ) == 'one-way' ) THEN
4592
4593	CALL pmci_child_datatrans( parent_to_child )
4594	CALL pmci_parent_datatrans( parent_to_child )
4595
4596	ELSE
4597
4598	IF( nesting_datatransfer_mode == 'cascade' ) THEN
4599
4600	CALL pmci_child_datatrans( parent_to_child )
4601	CALL pmci_parent_datatrans( parent_to_child )
4602
4603	CALL pmci_parent_datatrans( child_to_parent )
4604	CALL pmci_child_datatrans( child_to_parent )
4605
4606	ELSEIF( nesting_datatransfer_mode == 'overlap') THEN
4607
4608	CALL pmci_parent_datatrans( parent_to_child )
4609	CALL pmci_child_datatrans( parent_to_child )
4610
4611	CALL pmci_child_datatrans( child_to_parent )
4612	CALL pmci_parent_datatrans( child_to_parent )
4613
4614	ELSEIF( TRIM( nesting_datatransfer_mode ) == 'mixed' ) THEN
4615
4616	CALL pmci_parent_datatrans( parent_to_child )
4617	CALL pmci_child_datatrans( parent_to_child )
4618
4619	CALL pmci_parent_datatrans( child_to_parent )
4620	CALL pmci_child_datatrans( child_to_parent )
4621
4622	ENDIF
4623
4624	ENDIF
4625
4626	END SUBROUTINE pmci_datatrans
4627
4628
4629
4630	SUBROUTINE pmci_parent_datatrans( direction )
4631
4632	IMPLICIT NONE
4633
4634	INTEGER(iwp), INTENT(IN) :: direction !<
4635
4636	#if defined( __parallel )
4637	INTEGER(iwp) :: child_id !<
4638	INTEGER(iwp) :: i !<
4639	INTEGER(iwp) :: j !<
4640	INTEGER(iwp) :: k !<
4641	INTEGER(iwp) :: m !<
4642
4643
4644	DO m = 1, SIZE( pmc_parent_for_child ) - 1
4645	child_id = pmc_parent_for_child(m)
4646	IF ( direction == parent_to_child ) THEN
4647	CALL cpu_log( log_point_s(71), 'pmc parent send', 'start' )
4648	CALL pmc_s_fillbuffer( child_id )
4649	CALL cpu_log( log_point_s(71), 'pmc parent send', 'stop' )
4650	ELSE
4651	!
4652	!-- Communication from child to parent
4653	CALL cpu_log( log_point_s(72), 'pmc parent recv', 'start' )
4654	child_id = pmc_parent_for_child(m)
4655	CALL pmc_s_getdata_from_buffer( child_id )
4656	CALL cpu_log( log_point_s(72), 'pmc parent recv', 'stop' )
4657	!
4658	!-- The anterpolated data is now available in u etc
4659	IF ( topography /= 'flat' ) THEN
4660	!
4661	!-- Inside buildings/topography reset velocities back to zero.
4662	!-- Scalars (pt, q, s, km, kh, p, sa, ...) are ignored at
4663	!-- present, maybe revise later.
4664	!-- Resetting of e is removed as unnecessary since e is not
4665	!-- anterpolated, and as incorrect since it overran the default
4666	!-- Neumann condition (bc_e_b).
4667	DO i = nxlg, nxrg
4668	DO j = nysg, nyng
4669	DO k = nzb, nzt+1
4670	u(k,j,i) = MERGE( u(k,j,i), 0.0_wp, &
4671	BTEST( wall_flags_0(k,j,i), 1 ) )
4672	v(k,j,i) = MERGE( v(k,j,i), 0.0_wp, &
4673	BTEST( wall_flags_0(k,j,i), 2 ) )
4674	w(k,j,i) = MERGE( w(k,j,i), 0.0_wp, &
4675	BTEST( wall_flags_0(k,j,i), 3 ) )
4676	!
4677	!-- TO_DO: zero setting of temperature within topography creates
4678	!-- wrong results
4679	! pt(nzb:nzb_s_inner(j,i),j,i) = 0.0_wp
4680	! IF ( humidity .OR. passive_scalar ) THEN
4681	! q(nzb:nzb_s_inner(j,i),j,i) = 0.0_wp
4682	! ENDIF
4683	ENDDO
4684	ENDDO
4685	ENDDO
4686	ENDIF
4687	ENDIF
4688	ENDDO
4689
4690	#endif
4691	END SUBROUTINE pmci_parent_datatrans
4692
4693
4694
4695	SUBROUTINE pmci_child_datatrans( direction )
4696
4697	IMPLICIT NONE
4698
4699	INTEGER(iwp), INTENT(IN) :: direction !<
4700
4701	#if defined( __parallel )
4702	INTEGER(iwp) :: icl !<
4703	INTEGER(iwp) :: icr !<
4704	INTEGER(iwp) :: jcs !<
4705	INTEGER(iwp) :: jcn !<
4706
4707	REAL(wp), DIMENSION(1) :: dtl !<
4708
4709
4710	dtl = dt_3d
4711	IF ( cpl_id > 1 ) THEN
4712	!
4713	!-- Child domain boundaries in the parent indice space.
4714	icl = coarse_bound(1)
4715	icr = coarse_bound(2)
4716	jcs = coarse_bound(3)
4717	jcn = coarse_bound(4)
4718
4719	IF ( direction == parent_to_child ) THEN
4720
4721	CALL cpu_log( log_point_s(73), 'pmc child recv', 'start' )
4722	CALL pmc_c_getbuffer( )
4723	CALL cpu_log( log_point_s(73), 'pmc child recv', 'stop' )
4724
4725	CALL cpu_log( log_point_s(75), 'pmc interpolation', 'start' )
4726	CALL pmci_interpolation
4727	CALL cpu_log( log_point_s(75), 'pmc interpolation', 'stop' )
4728
4729	ELSE
4730	!
4731	!-- direction == child_to_parent
4732	CALL cpu_log( log_point_s(76), 'pmc anterpolation', 'start' )
4733	CALL pmci_anterpolation
4734	CALL cpu_log( log_point_s(76), 'pmc anterpolation', 'stop' )
4735
4736	CALL cpu_log( log_point_s(74), 'pmc child send', 'start' )
4737	CALL pmc_c_putbuffer( )
4738	CALL cpu_log( log_point_s(74), 'pmc child send', 'stop' )
4739
4740	ENDIF
4741	ENDIF
4742
4743	CONTAINS
4744
4745
4746	SUBROUTINE pmci_interpolation
4747
4748	!
4749	!-- A wrapper routine for all interpolation actions
4750
4751	IMPLICIT NONE
4752
4753	INTEGER(iwp) :: ibgp !< index running over the nbgp boundary ghost points in i-direction
4754	INTEGER(iwp) :: jbgp !< index running over the nbgp boundary ghost points in j-direction
4755	INTEGER(iwp) :: n !< running index for number of chemical species
4756
4757	!
4758	!-- In case of vertical nesting no interpolation is needed for the
4759	!-- horizontal boundaries
4760	IF ( nesting_mode /= 'vertical' ) THEN
4761
4762	!
4763	!-- Left border pe:
4764	IF ( bc_dirichlet_l ) THEN
4765
4766	CALL pmci_interp_tril_lr( u, uc, icu, jco, kco, r1xu, r2xu, &
4767	r1yo, r2yo, r1zo, r2zo, &
4768	logc_u_l, logc_ratio_u_l, &
4769	logc_kbounds_u_l, nzt_topo_nestbc_l, &
4770	kcto, iflu, ifuu, jflo, jfuo, kflo, &
4771	kfuo, ijkfc_u, 'l', 'u' )
4772
4773	CALL pmci_interp_tril_lr( v, vc, ico, jcv, kco, r1xo, r2xo, &
4774	r1yv, r2yv, r1zo, r2zo, &
4775	logc_v_l, logc_ratio_v_l, &
4776	logc_kbounds_v_l, nzt_topo_nestbc_l, &
4777	kcto, iflo, ifuo, jflv, jfuv, kflo, &
4778	kfuo, ijkfc_v, 'l', 'v' )
4779
4780	CALL pmci_interp_tril_lr( w, wc, ico, jco, kcw, r1xo, r2xo, &
4781	r1yo, r2yo, r1zw, r2zw, &
4782	logc_w_l, logc_ratio_w_l, &
4783	logc_kbounds_w_l, nzt_topo_nestbc_l, &
4784	kctw, iflo, ifuo, jflo, jfuo, kflw, &
4785	kfuw, ijkfc_w, 'l', 'w' )
4786
4787	IF ( ( rans_mode_parent .AND. rans_mode ) .OR. &
4788	( .NOT. rans_mode_parent .AND. .NOT. rans_mode .AND. &
4789	.NOT. constant_diffusion ) ) THEN
4790	! CALL pmci_interp_tril_lr( e, ec, ico, jco, kco, r1xo, r2xo, &
4791	! r1yo, r2yo, r1zo, r2zo, &
4792	! logc_w_l, logc_ratio_w_l, &
4793	! logc_kbounds_w_l, nzt_topo_nestbc_l, &
4794	! kcto, iflo, ifuo, jflo, jfuo, kflo, &
4795	! kfuo, ijkfc_s, 'l', 'e' )
4796	!
4797	!-- Interpolation of e is replaced by the Neumann condition.
4798	DO ibgp = -nbgp, -1
4799	e(nzb:nzt,nys:nyn,ibgp) = e(nzb:nzt,nys:nyn,0)
4800	ENDDO
4801
4802	ENDIF
4803
4804	IF ( rans_mode_parent .AND. rans_mode .AND. rans_tke_e ) THEN
4805	CALL pmci_interp_tril_lr( diss, dissc, ico, jco, kco, r1xo, &
4806	r2xo, r1yo, r2yo, r1zo, r2zo, &
4807	logc_w_l, logc_ratio_w_l, &
4808	logc_kbounds_w_l, nzt_topo_nestbc_l, &
4809	kcto, iflo, ifuo, jflo, jfuo, kflo, &
4810	kfuo, ijkfc_s, 'l', 's' )
4811	ENDIF
4812
4813	IF ( .NOT. neutral ) THEN
4814	CALL pmci_interp_tril_lr( pt, ptc, ico, jco, kco, r1xo, r2xo, &
4815	r1yo, r2yo, r1zo, r2zo, &
4816	logc_w_l, logc_ratio_w_l, &
4817	logc_kbounds_w_l, nzt_topo_nestbc_l, &
4818	kcto, iflo, ifuo, jflo, jfuo, kflo, &
4819	kfuo, ijkfc_s, 'l', 's' )
4820	ENDIF
4821
4822	IF ( humidity ) THEN
4823
4824	CALL pmci_interp_tril_lr( q, q_c, ico, jco, kco, r1xo, r2xo, &
4825	r1yo, r2yo, r1zo, r2zo, &
4826	logc_w_l, logc_ratio_w_l, &
4827	logc_kbounds_w_l, nzt_topo_nestbc_l, &
4828	kcto, iflo, ifuo, jflo, jfuo, kflo, &
4829	kfuo, ijkfc_s, 'l', 's' )
4830
4831	IF ( bulk_cloud_model .AND. microphysics_morrison ) THEN
4832	CALL pmci_interp_tril_lr( qc, qcc, ico, jco, kco, r1xo, &
4833	r2xo, r1yo, r2yo, r1zo, r2zo, &
4834	logc_w_l, logc_ratio_w_l, &
4835	logc_kbounds_w_l, &
4836	nzt_topo_nestbc_l, &
4837	kcto, iflo, ifuo, jflo, jfuo, &
4838	kflo, kfuo, ijkfc_s, 'l', 's' )
4839
4840	CALL pmci_interp_tril_lr( nc, ncc, ico, jco, kco, r1xo, &
4841	r2xo, r1yo, r2yo, r1zo, r2zo, &
4842	logc_w_l, logc_ratio_w_l, &
4843	logc_kbounds_w_l, &
4844	nzt_topo_nestbc_l, &
4845	kcto, iflo, ifuo, jflo, jfuo, &
4846	kflo, kfuo, ijkfc_s, 'l', 's' )
4847	ENDIF
4848
4849	IF ( bulk_cloud_model .AND. microphysics_seifert ) THEN
4850	CALL pmci_interp_tril_lr( qr, qrc, ico, jco, kco, r1xo, &
4851	r2xo, r1yo, r2yo, r1zo, r2zo, &
4852	logc_w_l, logc_ratio_w_l, &
4853	logc_kbounds_w_l, &
4854	nzt_topo_nestbc_l, &
4855	kcto, iflo, ifuo, jflo, jfuo, &
4856	kflo, kfuo, ijkfc_s, 'l', 's' )
4857
4858	CALL pmci_interp_tril_lr( nr, nrc, ico, jco, kco, r1xo, &
4859	r2xo, r1yo, r2yo, r1zo, r2zo, &
4860	logc_w_l, logc_ratio_w_l, &
4861	logc_kbounds_w_l, &
4862	nzt_topo_nestbc_l, &
4863	kcto, iflo, ifuo, jflo, jfuo, &
4864	kflo, kfuo, ijkfc_s, 'l', 's' )
4865	ENDIF
4866
4867	ENDIF
4868
4869	IF ( passive_scalar ) THEN
4870	CALL pmci_interp_tril_lr( s, sc, ico, jco, kco, r1xo, r2xo, &
4871	r1yo, r2yo, r1zo, r2zo, &
4872	logc_w_l, logc_ratio_w_l, &
4873	logc_kbounds_w_l, &
4874	nzt_topo_nestbc_l, &
4875	kcto, iflo, ifuo, jflo, jfuo, &
4876	kflo, kfuo, ijkfc_s, 'l', 's' )
4877	ENDIF
4878
4879	IF ( air_chemistry .AND. nest_chemistry ) THEN
4880	DO n = 1, nspec
4881	CALL pmci_interp_tril_lr( chem_species(n)%conc, &
4882	chem_spec_c(:,:,:,n), &
4883	ico, jco, kco, r1xo, r2xo, &
4884	r1yo, r2yo, r1zo, r2zo, &
4885	logc_w_l, logc_ratio_w_l, &
4886	logc_kbounds_w_l, &
4887	nzt_topo_nestbc_l, &
4888	kcto, iflo, ifuo, jflo, jfuo, &
4889	kflo, kfuo, ijkfc_s, 'l', 's' )
4890	ENDDO
4891	ENDIF
4892
4893	ENDIF
4894	!
4895	!-- Right border pe
4896	IF ( bc_dirichlet_r ) THEN
4897
4898	CALL pmci_interp_tril_lr( u, uc, icu, jco, kco, r1xu, r2xu, &
4899	r1yo, r2yo, r1zo, r2zo, &
4900	logc_u_r, logc_ratio_u_r, &
4901	logc_kbounds_u_r, nzt_topo_nestbc_r, &
4902	kcto, iflu, ifuu, jflo, jfuo, kflo, &
4903	kfuo, ijkfc_u, 'r', 'u' )
4904
4905	CALL pmci_interp_tril_lr( v, vc, ico, jcv, kco, r1xo, r2xo, &
4906	r1yv, r2yv, r1zo, r2zo, &
4907	logc_v_r, logc_ratio_v_r, &
4908	logc_kbounds_v_r, nzt_topo_nestbc_r, &
4909	kcto, iflo, ifuo, jflv, jfuv, kflo, &
4910	kfuo, ijkfc_v, 'r', 'v' )
4911
4912	CALL pmci_interp_tril_lr( w, wc, ico, jco, kcw, r1xo, r2xo, &
4913	r1yo, r2yo, r1zw, r2zw, &
4914	logc_w_r, logc_ratio_w_r, &
4915	logc_kbounds_w_r, nzt_topo_nestbc_r, &
4916	kctw, iflo, ifuo, jflo, jfuo, kflw, &
4917	kfuw, ijkfc_w, 'r', 'w' )
4918
4919	IF ( ( rans_mode_parent .AND. rans_mode ) .OR. &
4920	( .NOT. rans_mode_parent .AND. .NOT. rans_mode .AND. &
4921	.NOT. constant_diffusion ) ) THEN
4922	! CALL pmci_interp_tril_lr( e, ec, ico, jco, kco, r1xo, r2xo, &
4923	! r1yo,r2yo, r1zo, r2zo, &
4924	! logc_w_r, logc_ratio_w_r, &
4925	! logc_kbounds_w_r, nzt_topo_nestbc_r, &
4926	! kcto, iflo, ifuo, jflo, jfuo, kflo, &
4927	! kfuo, ijkfc_s, 'r', 'e' )
4928	!
4929	!-- Interpolation of e is replaced by the Neumann condition.
4930	DO ibgp = nx+1, nx+nbgp
4931	e(nzb:nzt,nys:nyn,ibgp) = e(nzb:nzt,nys:nyn,nx)
4932	ENDDO
4933	ENDIF
4934
4935	IF ( rans_mode_parent .AND. rans_mode .AND. rans_tke_e ) THEN
4936	CALL pmci_interp_tril_lr( diss, dissc, ico, jco, kco, r1xo, &
4937	r2xo, r1yo,r2yo, r1zo, r2zo, &
4938	logc_w_r, logc_ratio_w_r, &
4939	logc_kbounds_w_r, nzt_topo_nestbc_r, &
4940	kcto, iflo, ifuo, jflo, jfuo, kflo, &
4941	kfuo, ijkfc_s, 'r', 's' )
4942
4943	ENDIF
4944
4945	IF ( .NOT. neutral ) THEN
4946	CALL pmci_interp_tril_lr( pt, ptc, ico, jco, kco, r1xo, r2xo, &
4947	r1yo, r2yo, r1zo, r2zo, &
4948	logc_w_r, logc_ratio_w_r, &
4949	logc_kbounds_w_r, nzt_topo_nestbc_r, &
4950	kcto, iflo, ifuo, jflo, jfuo, kflo, &
4951	kfuo, ijkfc_s, 'r', 's' )
4952	ENDIF
4953
4954	IF ( humidity ) THEN
4955	CALL pmci_interp_tril_lr( q, q_c, ico, jco, kco, r1xo, r2xo, &
4956	r1yo, r2yo, r1zo, r2zo, &
4957	logc_w_r, logc_ratio_w_r, &
4958	logc_kbounds_w_r, nzt_topo_nestbc_r, &
4959	kcto, iflo, ifuo, jflo, jfuo, kflo, &
4960	kfuo, ijkfc_s, 'r', 's' )
4961
4962	IF ( bulk_cloud_model .AND. microphysics_morrison ) THEN
4963
4964	CALL pmci_interp_tril_lr( qc, qcc, ico, jco, kco, r1xo, &
4965	r2xo, r1yo, r2yo, r1zo, r2zo, &
4966	logc_w_r, logc_ratio_w_r, &
4967	logc_kbounds_w_r, &
4968	nzt_topo_nestbc_r, &
4969	kcto, iflo, ifuo, jflo, jfuo, &
4970	kflo, kfuo, ijkfc_s, 'r', 's' )
4971
4972	CALL pmci_interp_tril_lr( nc, ncc, ico, jco, kco, r1xo, &
4973	r2xo, r1yo, r2yo, r1zo, r2zo, &
4974	logc_w_r, logc_ratio_w_r, &
4975	logc_kbounds_w_r, &
4976	nzt_topo_nestbc_r, &
4977	kcto, iflo, ifuo, jflo, jfuo, &
4978	kflo, kfuo, ijkfc_s, 'r', 's' )
4979
4980	ENDIF
4981
4982	IF ( bulk_cloud_model .AND. microphysics_seifert ) THEN
4983
4984
4985	CALL pmci_interp_tril_lr( qr, qrc, ico, jco, kco, r1xo, &
4986	r2xo, r1yo, r2yo, r1zo, r2zo, &
4987	logc_w_r, logc_ratio_w_r, &
4988	logc_kbounds_w_r, &
4989	nzt_topo_nestbc_r, &
4990	kcto, iflo, ifuo, jflo, jfuo, &
4991	kflo, kfuo, ijkfc_s, &
4992	'r', 's' )
4993
4994	CALL pmci_interp_tril_lr( nr, nrc, ico, jco, kco, r1xo, &
4995	r2xo, r1yo, r2yo, r1zo, r2zo, &
4996	logc_w_r, logc_ratio_w_r, &
4997	logc_kbounds_w_r, &
4998	nzt_topo_nestbc_r, &
4999	kcto, iflo, ifuo, jflo, jfuo, &
5000	kflo, kfuo, ijkfc_s, 'r', 's' )
5001
5002	ENDIF
5003
5004	ENDIF
5005
5006	IF ( passive_scalar ) THEN
5007	CALL pmci_interp_tril_lr( s, sc, ico, jco, kco, r1xo, r2xo, &
5008	r1yo, r2yo, r1zo, r2zo, &
5009	logc_w_r, logc_ratio_w_r, &
5010	logc_kbounds_w_r, &
5011	nzt_topo_nestbc_r, &
5012	kcto, iflo, ifuo, jflo, jfuo, &
5013	kflo, kfuo, ijkfc_s, 'r', 's' )
5014	ENDIF
5015
5016	IF ( air_chemistry .AND. nest_chemistry ) THEN
5017	DO n = 1, nspec
5018	CALL pmci_interp_tril_lr( chem_species(n)%conc, &
5019	chem_spec_c(:,:,:,n), &
5020	ico, jco, kco, r1xo, r2xo, &
5021	r1yo, r2yo, r1zo, r2zo, &
5022	logc_w_r, logc_ratio_w_r, &
5023	logc_kbounds_w_r, &
5024	nzt_topo_nestbc_r, &
5025	kcto, iflo, ifuo, jflo, jfuo, &
5026	kflo, kfuo, ijkfc_s, 'r', 's' )
5027	ENDDO
5028	ENDIF
5029	ENDIF
5030	!
5031	!-- South border pe
5032	IF ( bc_dirichlet_s ) THEN
5033
5034	CALL pmci_interp_tril_sn( u, uc, icu, jco, kco, r1xu, r2xu, &
5035	r1yo, r2yo, r1zo, r2zo, &
5036	logc_u_s, logc_ratio_u_s, &
5037	logc_kbounds_u_s, nzt_topo_nestbc_s, &
5038	kcto, iflu, ifuu, jflo, jfuo, kflo, &
5039	kfuo, ijkfc_u, 's', 'u' )
5040
5041	CALL pmci_interp_tril_sn( v, vc, ico, jcv, kco, r1xo, r2xo, &
5042	r1yv, r2yv, r1zo, r2zo, &
5043	logc_v_s, logc_ratio_v_s, &
5044	logc_kbounds_v_s, nzt_topo_nestbc_s, &
5045	kcto, iflo, ifuo, jflv, jfuv, kflo, &
5046	kfuo, ijkfc_v, 's', 'v' )
5047
5048	CALL pmci_interp_tril_sn( w, wc, ico, jco, kcw, r1xo, r2xo, &
5049	r1yo, r2yo, r1zw, r2zw, &
5050	logc_w_s, logc_ratio_w_s, &
5051	logc_kbounds_w_s, nzt_topo_nestbc_s, &
5052	kctw, iflo, ifuo, jflo, jfuo, kflw, &
5053	kfuw, ijkfc_w, 's','w' )
5054
5055	IF ( ( rans_mode_parent .AND. rans_mode ) .OR. &
5056	( .NOT. rans_mode_parent .AND. .NOT. rans_mode .AND. &
5057	.NOT. constant_diffusion ) ) THEN
5058	! CALL pmci_interp_tril_sn( e, ec, ico, jco, kco, r1xo, r2xo, &
5059	! r1yo, r2yo, r1zo, r2zo, &
5060	! logc_w_s, logc_ratio_w_s, &
5061	! logc_kbounds_w_s, nzt_topo_nestbc_s, &
5062	! kcto, iflo, ifuo, jflo, jfuo, kflo, &
5063	! kfuo, ijkfc_s, 's', 'e' )
5064	!
5065	!-- Interpolation of e is replaced by the Neumann condition.
5066	DO jbgp = -nbgp, -1
5067	e(nzb:nzt,jbgp,nxl:nxr) = e(nzb:nzt,0,nxl:nxr)
5068	ENDDO
5069	ENDIF
5070
5071	IF ( rans_mode_parent .AND. rans_mode .AND. rans_tke_e ) THEN
5072	CALL pmci_interp_tril_sn( diss, dissc, ico, jco, kco, r1xo, &
5073	r2xo, r1yo, r2yo, r1zo, r2zo, &
5074	logc_w_s, logc_ratio_w_s, &
5075	logc_kbounds_w_s, nzt_topo_nestbc_s, &
5076	kcto, iflo, ifuo, jflo, jfuo, kflo, &
5077	kfuo, ijkfc_s, 's', 's' )
5078	ENDIF
5079
5080	IF ( .NOT. neutral ) THEN
5081	CALL pmci_interp_tril_sn( pt, ptc, ico, jco, kco, r1xo, r2xo, &
5082	r1yo, r2yo, r1zo, r2zo, &
5083	logc_w_s, logc_ratio_w_s, &
5084	logc_kbounds_w_s, nzt_topo_nestbc_s, &
5085	kcto, iflo, ifuo, jflo, jfuo, kflo, &
5086	kfuo, ijkfc_s, 's', 's' )
5087	ENDIF
5088
5089	IF ( humidity ) THEN
5090	CALL pmci_interp_tril_sn( q, q_c, ico, jco, kco, r1xo, r2xo, &
5091	r1yo,r2yo, r1zo, r2zo, &
5092	logc_w_s, logc_ratio_w_s, &
5093	logc_kbounds_w_s, nzt_topo_nestbc_s, &
5094	kcto, iflo, ifuo, jflo, jfuo, kflo, &
5095	kfuo, ijkfc_s, 's', 's' )
5096
5097	IF ( bulk_cloud_model .AND. microphysics_morrison ) THEN
5098
5099	CALL pmci_interp_tril_sn( qc, qcc, ico, jco, kco, r1xo, &
5100	r2xo, r1yo,r2yo, r1zo, r2zo, &
5101	logc_w_s, logc_ratio_w_s, &
5102	logc_kbounds_w_s, &
5103	nzt_topo_nestbc_s, &
5104	kcto, iflo, ifuo, jflo, jfuo, &
5105	kflo, kfuo, ijkfc_s, 's', 's' )
5106
5107	CALL pmci_interp_tril_sn( nc, ncc, ico, jco, kco, r1xo, &
5108	r2xo, r1yo,r2yo, r1zo, r2zo, &
5109	logc_w_s, logc_ratio_w_s, &
5110	logc_kbounds_w_s, &
5111	nzt_topo_nestbc_s, &
5112	kcto, iflo, ifuo, jflo, jfuo, &
5113	kflo, kfuo, ijkfc_s, 's', 's' )
5114
5115	ENDIF
5116
5117	IF ( bulk_cloud_model .AND. microphysics_seifert ) THEN
5118
5119	CALL pmci_interp_tril_sn( qr, qrc, ico, jco, kco, r1xo, &
5120	r2xo, r1yo,r2yo, r1zo, r2zo, &
5121	logc_w_s, logc_ratio_w_s, &
5122	logc_kbounds_w_s, &
5123	nzt_topo_nestbc_s, &
5124	kcto, iflo, ifuo, jflo, jfuo, &
5125	kflo, kfuo, ijkfc_s, 's', 's' )
5126
5127	CALL pmci_interp_tril_sn( nr, nrc, ico, jco, kco, r1xo, &
5128	r2xo, r1yo,r2yo, r1zo, r2zo, &
5129	logc_w_s, logc_ratio_w_s, &
5130	logc_kbounds_w_s, &
5131	nzt_topo_nestbc_s, &
5132	kcto, iflo, ifuo, jflo, jfuo, &
5133	kflo, kfuo, ijkfc_s, 's', 's' )
5134
5135	ENDIF
5136
5137	ENDIF
5138
5139	IF ( passive_scalar ) THEN
5140	CALL pmci_interp_tril_sn( s, sc, ico, jco, kco, r1xo, r2xo, &
5141	r1yo,r2yo, r1zo, r2zo, &
5142	logc_w_s, logc_ratio_w_s, &
5143	logc_kbounds_w_s, &
5144	nzt_topo_nestbc_s, &
5145	kcto, iflo, ifuo, jflo, jfuo, &
5146	kflo, kfuo, ijkfc_s, 's', 's' )
5147	ENDIF
5148
5149	IF ( air_chemistry .AND. nest_chemistry ) THEN
5150	DO n = 1, nspec
5151	CALL pmci_interp_tril_sn( chem_species(n)%conc, &
5152	chem_spec_c(:,:,:,n), &
5153	ico, jco, kco, r1xo, r2xo, &
5154	r1yo, r2yo, r1zo, r2zo, &
5155	logc_w_s, logc_ratio_w_s, &
5156	logc_kbounds_w_s, &
5157	nzt_topo_nestbc_s, &
5158	kcto, iflo, ifuo, jflo, jfuo, &
5159	kflo, kfuo, ijkfc_s, 's', 's' )
5160	ENDDO
5161	ENDIF
5162	ENDIF
5163	!
5164	!-- North border pe
5165	IF ( bc_dirichlet_n ) THEN
5166
5167	CALL pmci_interp_tril_sn( u, uc, icu, jco, kco, r1xu, r2xu, &
5168	r1yo, r2yo, r1zo, r2zo, &
5169	logc_u_n, logc_ratio_u_n, &
5170	logc_kbounds_u_n, nzt_topo_nestbc_n, &
5171	kcto, iflu, ifuu, jflo, jfuo, kflo, &
5172	kfuo, ijkfc_u, 'n', 'u' )
5173
5174	CALL pmci_interp_tril_sn( v, vc, ico, jcv, kco, r1xo, r2xo, &
5175	r1yv, r2yv, r1zo, r2zo, &
5176	logc_v_n, logc_ratio_v_n, &
5177	logc_kbounds_v_n, nzt_topo_nestbc_n, &
5178	kcto, iflo, ifuo, jflv, jfuv, kflo, &
5179	kfuo, ijkfc_v, 'n', 'v' )
5180
5181	CALL pmci_interp_tril_sn( w, wc, ico, jco, kcw, r1xo, r2xo, &
5182	r1yo, r2yo, r1zw, r2zw, &
5183	logc_w_n, logc_ratio_w_n, &
5184	logc_kbounds_w_n, nzt_topo_nestbc_n, &
5185	kctw, iflo, ifuo, jflo, jfuo, kflw, &
5186	kfuw, ijkfc_w, 'n', 'w' )
5187
5188	IF ( ( rans_mode_parent .AND. rans_mode ) .OR. &
5189	( .NOT. rans_mode_parent .AND. .NOT. rans_mode .AND. &
5190	.NOT. constant_diffusion ) ) THEN
5191	! CALL pmci_interp_tril_sn( e, ec, ico, jco, kco, r1xo, r2xo, &
5192	! r1yo, r2yo, r1zo, r2zo, &
5193	! logc_w_n, logc_ratio_w_n, &
5194	! logc_kbounds_w_n, nzt_topo_nestbc_n, &
5195	! kcto, iflo, ifuo, jflo, jfuo, kflo, &
5196	! kfuo, ijkfc_s, 'n', 'e' )
5197	!
5198	!-- Interpolation of e is replaced by the Neumann condition.
5199	DO jbgp = ny+1, ny+nbgp
5200	e(nzb:nzt,jbgp,nxl:nxr) = e(nzb:nzt,ny,nxl:nxr)
5201	ENDDO
5202	ENDIF
5203
5204	IF ( rans_mode_parent .AND. rans_mode .AND. rans_tke_e ) THEN
5205	CALL pmci_interp_tril_sn( diss, dissc, ico, jco, kco, r1xo, &
5206	r2xo, r1yo, r2yo, r1zo, r2zo, &
5207	logc_w_n, logc_ratio_w_n, &
5208	logc_kbounds_w_n, nzt_topo_nestbc_n, &
5209	kcto, iflo, ifuo, jflo, jfuo, kflo, &
5210	kfuo, ijkfc_s, 'n', 's' )
5211
5212	ENDIF
5213
5214	IF ( .NOT. neutral ) THEN
5215	CALL pmci_interp_tril_sn( pt, ptc, ico, jco, kco, r1xo, r2xo, &
5216	r1yo, r2yo, r1zo, r2zo, &
5217	logc_w_n, logc_ratio_w_n, &
5218	logc_kbounds_w_n, nzt_topo_nestbc_n, &
5219	kcto, iflo, ifuo, jflo, jfuo, kflo, &
5220	kfuo, ijkfc_s, 'n', 's' )
5221	ENDIF
5222
5223	IF ( humidity ) THEN
5224	CALL pmci_interp_tril_sn( q, q_c, ico, jco, kco, r1xo, r2xo, &
5225	r1yo, r2yo, r1zo, r2zo, &
5226	logc_w_n, logc_ratio_w_n, &
5227	logc_kbounds_w_n, nzt_topo_nestbc_n, &
5228	kcto, iflo, ifuo, jflo, jfuo, kflo, &
5229	kfuo, ijkfc_s, 'n', 's' )
5230
5231	IF ( bulk_cloud_model .AND. microphysics_morrison ) THEN
5232
5233	CALL pmci_interp_tril_sn( qc, qcc, ico, jco, kco, r1xo, &
5234	r2xo, r1yo, r2yo, r1zo, r2zo, &
5235	logc_w_n, logc_ratio_w_n, &
5236	logc_kbounds_w_n, &
5237	nzt_topo_nestbc_n, &
5238	kcto, iflo, ifuo, jflo, jfuo, &
5239	kflo, kfuo, ijkfc_s, 'n', 's' )
5240
5241	CALL pmci_interp_tril_sn( nc, ncc, ico, jco, kco, r1xo, &
5242	r2xo, r1yo, r2yo, r1zo, r2zo, &
5243	logc_u_n, logc_ratio_u_n, &
5244	logc_kbounds_w_n, &
5245	nzt_topo_nestbc_n, &
5246	kcto, iflo, ifuo, jflo, jfuo, &
5247	kflo, kfuo, ijkfc_s, 'n', 's' )
5248
5249	ENDIF
5250
5251	IF ( bulk_cloud_model .AND. microphysics_seifert ) THEN
5252
5253	CALL pmci_interp_tril_sn( qr, qrc, ico, jco, kco, r1xo, &
5254	r2xo, r1yo, r2yo, r1zo, r2zo, &
5255	logc_w_n, logc_ratio_w_n, &
5256	logc_kbounds_w_n, &
5257	nzt_topo_nestbc_n, &
5258	kcto, iflo, ifuo, jflo, jfuo, &
5259	kflo, kfuo, ijkfc_s, 'n', 's' )
5260
5261	CALL pmci_interp_tril_sn( nr, nrc, ico, jco, kco, r1xo, &
5262	r2xo, r1yo, r2yo, r1zo, r2zo, &
5263	logc_w_n, logc_ratio_w_n, &
5264	logc_kbounds_w_n, &
5265	nzt_topo_nestbc_n, &
5266	kcto, iflo, ifuo, jflo, jfuo, &
5267	kflo, kfuo, ijkfc_s, 'n', 's' )
5268
5269	ENDIF
5270
5271	ENDIF
5272
5273	IF ( passive_scalar ) THEN
5274	CALL pmci_interp_tril_sn( s, sc, ico, jco, kco, r1xo, r2xo, &
5275	r1yo, r2yo, r1zo, r2zo, &
5276	logc_w_n, logc_ratio_w_n, &
5277	logc_kbounds_w_n, &
5278	nzt_topo_nestbc_n, &
5279	kcto, iflo, ifuo, jflo, jfuo, &
5280	kflo, kfuo, ijkfc_s, 'n', 's' )
5281	ENDIF
5282
5283	IF ( air_chemistry .AND. nest_chemistry ) THEN
5284	DO n = 1, nspec
5285	CALL pmci_interp_tril_sn( chem_species(n)%conc, &
5286	chem_spec_c(:,:,:,n), &
5287	ico, jco, kco, r1xo, r2xo, &
5288	r1yo, r2yo, r1zo, r2zo, &
5289	logc_w_n, logc_ratio_w_n, &
5290	logc_kbounds_w_n, &
5291	nzt_topo_nestbc_n, &
5292	kcto, iflo, ifuo, jflo, jfuo, &
5293	kflo, kfuo, ijkfc_s, 'n', 's' )
5294	ENDDO
5295	ENDIF
5296	ENDIF
5297
5298	ENDIF ! IF ( nesting_mode /= 'vertical' )
5299	!
5300	!-- All PEs are top-border PEs
5301	CALL pmci_interp_tril_t( u, uc, icu, jco, kco, r1xu, r2xu, r1yo, &
5302	r2yo, r1zo, r2zo, kcto, iflu, ifuu, &
5303	jflo, jfuo, kflo, kfuo, ijkfc_u, 'u' )
5304	CALL pmci_interp_tril_t( v, vc, ico, jcv, kco, r1xo, r2xo, r1yv, &
5305	r2yv, r1zo, r2zo, kcto, iflo, ifuo, &
5306	jflv, jfuv, kflo, kfuo, ijkfc_v, 'v' )
5307	CALL pmci_interp_tril_t( w, wc, ico, jco, kcw, r1xo, r2xo, r1yo, &
5308	r2yo, r1zw, r2zw, kctw, iflo, ifuo, &
5309	jflo, jfuo, kflw, kfuw, ijkfc_w, 'w' )
5310
5311	IF ( ( rans_mode_parent .AND. rans_mode ) .OR. &
5312	( .NOT. rans_mode_parent .AND. .NOT. rans_mode .AND. &
5313	.NOT. constant_diffusion ) ) THEN
5314	! CALL pmci_interp_tril_t( e, ec, ico, jco, kco, r1xo, r2xo, r1yo, &
5315	! r2yo, r1zo, r2zo, kcto, iflo, ifuo, &
5316	! jflo, jfuo, kflo, kfuo, ijkfc_s, 'e' )
5317	!
5318	!-- Interpolation of e is replaced by the Neumann condition.
5319	e(nzt+1,nys:nyn,nxl:nxr) = e(nzt,nys:nyn,nxl:nxr)
5320
5321	ENDIF
5322
5323	IF ( rans_mode_parent .AND. rans_mode .AND. rans_tke_e ) THEN
5324	CALL pmci_interp_tril_t( diss, dissc, ico, jco, kco, r1xo, r2xo, &
5325	r1yo, r2yo, r1zo, r2zo, kcto, iflo, ifuo, &
5326	jflo, jfuo, kflo, kfuo, ijkfc_s, 's' )
5327	ENDIF
5328
5329	IF ( .NOT. neutral ) THEN
5330	CALL pmci_interp_tril_t( pt, ptc, ico, jco, kco, r1xo, r2xo, &
5331	r1yo, r2yo, r1zo, r2zo, kcto, iflo, ifuo, &
5332	jflo, jfuo, kflo, kfuo, ijkfc_s, 's' )
5333	ENDIF
5334
5335	IF ( humidity ) THEN
5336
5337	CALL pmci_interp_tril_t( q, q_c, ico, jco, kco, r1xo, r2xo, r1yo, &
5338	r2yo, r1zo, r2zo, kcto, iflo, ifuo, &
5339	jflo, jfuo, kflo, kfuo, ijkfc_s, 's' )
5340
5341	IF ( bulk_cloud_model .AND. microphysics_morrison ) THEN
5342
5343	CALL pmci_interp_tril_t( qc, qcc, ico, jco, kco, r1xo, r2xo, r1yo,&
5344	r2yo, r1zo, r2zo, kcto, iflo, ifuo, &
5345	jflo, jfuo, kflo, kfuo, ijkfc_s, 's' )
5346
5347	CALL pmci_interp_tril_t( nc, ncc, ico, jco, kco, r1xo, r2xo, r1yo,&
5348	r2yo, r1zo, r2zo, kcto, iflo, ifuo, &
5349	jflo, jfuo, kflo, kfuo, ijkfc_s, 's' )
5350
5351	ENDIF
5352
5353	IF ( bulk_cloud_model .AND. microphysics_seifert ) THEN
5354
5355
5356	CALL pmci_interp_tril_t( qr, qrc, ico, jco, kco, r1xo, r2xo, r1yo,&
5357	r2yo, r1zo, r2zo, kcto, iflo, ifuo, &
5358	jflo, jfuo, kflo, kfuo, ijkfc_s, 's' )
5359
5360	CALL pmci_interp_tril_t( nr, nrc, ico, jco, kco, r1xo, r2xo, r1yo,&
5361	r2yo, r1zo, r2zo, kcto, iflo, ifuo, &
5362	jflo, jfuo, kflo, kfuo, ijkfc_s, 's' )
5363
5364	ENDIF
5365
5366	ENDIF
5367
5368	IF ( passive_scalar ) THEN
5369	CALL pmci_interp_tril_t( s, sc, ico, jco, kco, r1xo, r2xo, r1yo, &
5370	r2yo, r1zo, r2zo, kcto, iflo, ifuo, &
5371	jflo, jfuo, kflo, kfuo, ijkfc_s, 's' )
5372	ENDIF
5373
5374	IF ( air_chemistry .AND. nest_chemistry ) THEN
5375	DO n = 1, nspec
5376	CALL pmci_interp_tril_t( chem_species(n)%conc, &
5377	chem_spec_c(:,:,:,n), &
5378	ico, jco, kco, r1xo, r2xo, &
5379	r1yo, r2yo, r1zo, r2zo, &
5380	kcto, iflo, ifuo, jflo, jfuo, &
5381	kflo, kfuo, ijkfc_s, 's' )
5382	ENDDO
5383	ENDIF
5384
5385	END SUBROUTINE pmci_interpolation
5386
5387
5388
5389	SUBROUTINE pmci_anterpolation
5390
5391	!
5392	!-- A wrapper routine for all anterpolation actions.
5393	!-- Note that TKE is not anterpolated.
5394	IMPLICIT NONE
5395
5396	INTEGER(iwp) :: n !< running index for number of chemical species
5397
5398	CALL pmci_anterp_tophat( u, uc, kcto, iflu, ifuu, jflo, jfuo, kflo, &
5399	kfuo, ijkfc_u, 'u' )
5400	CALL pmci_anterp_tophat( v, vc, kcto, iflo, ifuo, jflv, jfuv, kflo, &
5401	kfuo, ijkfc_v, 'v' )
5402	CALL pmci_anterp_tophat( w, wc, kctw, iflo, ifuo, jflo, jfuo, kflw, &
5403	kfuw, ijkfc_w, 'w' )
5404	!
5405	!-- Anterpolation of TKE and dissipation rate if parent and child are in
5406	!-- RANS mode.
5407	IF ( rans_mode_parent .AND. rans_mode ) THEN
5408	CALL pmci_anterp_tophat( e, ec, kcto, iflo, ifuo, jflo, jfuo, kflo, &
5409	kfuo, ijkfc_s, 'e' )
5410	!
5411	!-- Anterpolation of dissipation rate only if TKE-e closure is applied.
5412	IF ( rans_tke_e ) THEN
5413	CALL pmci_anterp_tophat( diss, dissc, kcto, iflo, ifuo, jflo, jfuo,&
5414	kflo, kfuo, ijkfc_s, 'diss' )
5415	ENDIF
5416
5417	ENDIF
5418
5419	IF ( .NOT. neutral ) THEN
5420	CALL pmci_anterp_tophat( pt, ptc, kcto, iflo, ifuo, jflo, jfuo, kflo, &
5421	kfuo, ijkfc_s, 'pt' )
5422	ENDIF
5423
5424	IF ( humidity ) THEN
5425
5426	CALL pmci_anterp_tophat( q, q_c, kcto, iflo, ifuo, jflo, jfuo, kflo, &
5427	kfuo, ijkfc_s, 'q' )
5428
5429	IF ( bulk_cloud_model .AND. microphysics_morrison ) THEN
5430
5431	CALL pmci_anterp_tophat( qc, qcc, kcto, iflo, ifuo, jflo, jfuo, &
5432	kflo, kfuo, ijkfc_s, 'qc' )
5433
5434	CALL pmci_anterp_tophat( nc, ncc, kcto, iflo, ifuo, jflo, jfuo, &
5435	kflo, kfuo, ijkfc_s, 'nc' )
5436
5437	ENDIF
5438
5439	IF ( bulk_cloud_model .AND. microphysics_seifert ) THEN
5440
5441	CALL pmci_anterp_tophat( qr, qrc, kcto, iflo, ifuo, jflo, jfuo, &
5442	kflo, kfuo, ijkfc_s, 'qr' )
5443
5444	CALL pmci_anterp_tophat( nr, nrc, kcto, iflo, ifuo, jflo, jfuo, &
5445	kflo, kfuo, ijkfc_s, 'nr' )
5446
5447	ENDIF
5448
5449	ENDIF
5450
5451	IF ( passive_scalar ) THEN
5452	CALL pmci_anterp_tophat( s, sc, kcto, iflo, ifuo, jflo, jfuo, kflo, &
5453	kfuo, ijkfc_s, 's' )
5454	ENDIF
5455
5456	IF ( air_chemistry .AND. nest_chemistry ) THEN
5457	DO n = 1, nspec
5458	CALL pmci_anterp_tophat( chem_species(n)%conc, &
5459	chem_spec_c(:,:,:,n), &
5460	kcto, iflo, ifuo, jflo, jfuo, kflo, &
5461	kfuo, ijkfc_s, 's' )
5462	ENDDO
5463	ENDIF
5464
5465	END SUBROUTINE pmci_anterpolation
5466
5467
5468
5469	SUBROUTINE pmci_interp_tril_lr( f, fc, ic, jc, kc, r1x, r2x, r1y, r2y, r1z, &
5470	r2z, logc, logc_ratio, logc_kbounds, &
5471	nzt_topo_nestbc, &
5472	kct, ifl, ifu, jfl, jfu, kfl, kfu, ijkfc, &
5473	edge, var )
5474	!
5475	!-- Interpolation of ghost-node values used as the child-domain boundary
5476	!-- conditions. This subroutine handles the left and right boundaries. It is
5477	!-- based on trilinear interpolation.
5478
5479	IMPLICIT NONE
5480
5481	INTEGER(iwp) :: nzt_topo_nestbc !<
5482
5483	REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &
5484	INTENT(INOUT) :: f !<
5485	REAL(wp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), &
5486	INTENT(IN) :: fc !<
5487	REAL(wp), DIMENSION(1:2,0:ncorr-1,nzb:nzt_topo_nestbc,nys:nyn), &
5488	INTENT(IN) :: logc_ratio !<
5489	REAL(wp), DIMENSION(nxlg:nxrg), INTENT(IN) :: r1x !<
5490	REAL(wp), DIMENSION(nxlg:nxrg), INTENT(IN) :: r2x !<
5491	REAL(wp), DIMENSION(nysg:nyng), INTENT(IN) :: r1y !<
5492	REAL(wp), DIMENSION(nysg:nyng), INTENT(IN) :: r2y !<
5493	REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN) :: r1z !<
5494	REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN) :: r2z !<
5495
5496	INTEGER(iwp), DIMENSION(nxlg:nxrg), INTENT(IN) :: ic !<
5497	INTEGER(iwp), DIMENSION(nysg:nyng), INTENT(IN) :: jc !<
5498	INTEGER(iwp), DIMENSION(nzb:nzt+1), INTENT(IN) :: kc !<
5499	INTEGER(iwp), DIMENSION(1:2,nzb:nzt_topo_nestbc,nys:nyn), &
5500	INTENT(IN) :: logc !<
5501	INTEGER(iwp), DIMENSION(1:2,nys:nyn), INTENT(IN) :: logc_kbounds !<
5502
5503	INTEGER(iwp) :: kct
5504	INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) :: ifl !< Indicates start index of child cells belonging to certain parent cell - x direction
5505	INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) :: ifu !< Indicates end index of child cells belonging to certain parent cell - x direction
5506	INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) :: jfl !< Indicates start index of child cells belonging to certain parent cell - y direction
5507	INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) :: jfu !< Indicates start index of child cells belonging to certain parent cell - y direction
5508	!AH INTEGER(iwp), DIMENSION(0:kct), INTENT(IN) :: kfl !< Indicates start index of child cells belonging to certain parent cell - z direction
5509	!AH INTEGER(iwp), DIMENSION(0:kct), INTENT(IN) :: kfu !< Indicates start index of child cells belonging to certain parent cell - z direction
5510	INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN) :: kfl !< Indicates start index of child cells belonging to certain parent cell - z direction
5511	INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN) :: kfu !< Indicates start index of child cells belonging to certain parent cell - z direction
5512
5513	!AH INTEGER(iwp), DIMENSION(0:kct,jcs:jcn,icl:icr), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box
5514	INTEGER(iwp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box
5515
5516	CHARACTER(LEN=1), INTENT(IN) :: edge !<
5517	CHARACTER(LEN=1), INTENT(IN) :: var !<
5518
5519	INTEGER(iwp) :: i !<
5520	INTEGER(iwp) :: ia !<
5521	INTEGER(iwp) :: ib !<
5522	INTEGER(iwp) :: ibgp !<
5523	INTEGER(iwp) :: ijk !<
5524	INTEGER(iwp) :: iw !<
5525	INTEGER(iwp) :: j !<
5526	INTEGER(iwp) :: jco !<
5527	INTEGER(iwp) :: jcorr !<
5528	INTEGER(iwp) :: jinc !<
5529	INTEGER(iwp) :: jw !<
5530	INTEGER(iwp) :: j1 !<
5531	INTEGER(iwp) :: k !<
5532	INTEGER(iwp) :: k_wall !< vertical index of topography top
5533	INTEGER(iwp) :: kco !<
5534	INTEGER(iwp) :: kcorr !<
5535	INTEGER(iwp) :: k1 !<
5536	INTEGER(iwp) :: l !<
5537	INTEGER(iwp) :: m !<
5538	INTEGER(iwp) :: n !<
5539	INTEGER(iwp) :: kbc !<
5540	INTEGER(iwp) :: var_flag !<
5541
5542	REAL(wp) :: cellsum !<
5543	REAL(wP) :: cellsumd !<
5544	REAL(wp) :: fkj !<
5545	REAL(wp) :: fkjp !<
5546	REAL(wp) :: fkpj !<
5547	REAL(wp) :: fkpjp !<
5548	REAL(wp) :: fk !<
5549	REAL(wp) :: fkp !<
5550	REAL(wp) :: rcorr !<
5551	REAL(wp) :: rcorr_ijk !<
5552
5553	!
5554	!-- Check which edge is to be handled
5555	IF ( edge == 'l' ) THEN
5556	!
5557	!-- For u, nxl is a ghost node, but not for the other variables
5558	IF ( var == 'u' ) THEN
5559	i = nxl
5560	ib = nxl - 1
5561	ELSE
5562	i = nxl - 1
5563	ib = nxl - 2
5564	ENDIF
5565	ELSEIF ( edge == 'r' ) THEN
5566	i = nxr + 1
5567	ib = nxr + 2
5568	ENDIF
5569
5570	IF ( var == 'u' ) THEN
5571	var_flag = 1
5572	ELSEIF ( var == 'v' ) THEN
5573	var_flag = 2
5574	ELSEIF ( var == 'w' ) THEN
5575	var_flag = 3
5576	ELSE
5577	var_flag = 0
5578	ENDIF
5579
5580	DO j = nys, nyn+1
5581	!
5582	!-- Determine vertical index of topography top at grid point (j,i)
5583	!AH k_wall = get_topography_top_index_ji( j, i, TRIM( var ) )
5584
5585	DO k = nzb, nzt+1 !k_wall, nzt+1
5586	l = ic(i)
5587	m = jc(j)
5588	n = kc(k)
5589	fkj = r1x(i) * fc(n,m,l) + r2x(i) * fc(n,m,l+1)
5590	fkjp = r1x(i) * fc(n,m+1,l) + r2x(i) * fc(n,m+1,l+1)
5591	fkpj = r1x(i) * fc(n+1,m,l) + r2x(i) * fc(n+1,m,l+1)
5592	fkpjp = r1x(i) * fc(n+1,m+1,l) + r2x(i) * fc(n+1,m+1,l+1)
5593	fk = r1y(j) * fkj + r2y(j) * fkjp
5594	fkp = r1y(j) * fkpj + r2y(j) * fkpjp
5595	f(k,j,i) = r1z(k) * fk + r2z(k) * fkp
5596	ENDDO
5597	ENDDO
5598	!
5599	!-- Generalized log-law-correction algorithm.
5600	!-- Doubly two-dimensional index arrays logc(1:2,:,:) and log-ratio arrays
5601	!-- logc_ratio(1:2,0:ncorr-1,:,:) have been precomputed in subroutine
5602	!-- pmci_init_loglaw_correction.
5603	!
5604	!-- Solid surface below the node
5605	IF ( constant_flux_layer .AND. ( var == 'u' .OR. var == 'v' ) ) THEN
5606	DO j = nys, nyn
5607	!
5608	!-- Determine vertical index of topography top at grid point (j,i)
5609	k_wall = get_topography_top_index_ji( j, i, TRIM ( var ) )
5610
5611	k = k_wall+1
5612	IF ( ( logc(1,k,j) /= 0 ) .AND. ( logc(2,k,j) == 0 ) ) THEN
5613	k1 = logc(1,k,j)
5614	DO kcorr = 0, ncorr - 1
5615	kco = k + kcorr
5616	!AH f(kco,j,i) = logc_ratio(1,kcorr,k,j) * f(k1,j,i)
5617	ENDDO
5618	ENDIF
5619	ENDDO
5620	ENDIF
5621	!
5622	!-- In case of non-flat topography, also vertical walls and corners need to be
5623	!-- treated. Only single and double wall nodes are corrected. Triple and
5624	!-- higher-multiple wall nodes are not corrected as the log law would not be
5625	!-- valid anyway in such locations.
5626	IF ( topography /= 'flat' ) THEN
5627
5628	IF ( constant_flux_layer .AND. ( var == 'u' .OR. var == 'w' ) ) THEN
5629	!
5630	!-- Solid surface only on south/north side of the node
5631	DO j = nys, nyn
5632	DO k = logc_kbounds(1,j), logc_kbounds(2,j)
5633	IF ( ( logc(2,k,j) /= 0 ) .AND. ( logc(1,k,j) == 0 ) ) THEN
5634	!
5635	!-- Direction of the wall-normal index is carried in as the
5636	!-- sign of logc
5637	jinc = SIGN( 1, logc(2,k,j) )
5638	j1 = ABS( logc(2,k,j) )
5639	DO jcorr = 0, ncorr-1
5640	jco = j + jinc * jcorr
5641	IF ( jco >= nys .AND. jco <= nyn ) THEN
5642	!AH f(k,jco,i) = logc_ratio(2,jcorr,k,j) * f(k,j1,i)
5643	ENDIF
5644	ENDDO
5645	ENDIF
5646	ENDDO
5647	ENDDO
5648	ENDIF
5649	!
5650	!-- Solid surface on both below and on south/north side of the node
5651	IF ( constant_flux_layer .AND. var == 'u' ) THEN
5652	DO j = nys, nyn
5653	k = logc_kbounds(1,j)
5654	IF ( ( logc(2,k,j) /= 0 ) .AND. ( logc(1,k,j) /= 0 ) ) THEN
5655	k1 = logc(1,k,j)
5656	jinc = SIGN( 1, logc(2,k,j) )
5657	j1 = ABS( logc(2,k,j) )
5658	DO jcorr = 0, ncorr-1
5659	jco = j + jinc * jcorr
5660	IF ( jco >= nys .AND. jco <= nyn ) THEN
5661	DO kcorr = 0, ncorr-1
5662	kco = k + kcorr
5663	!AH f(kco,jco,i) = 0.5_wp * ( logc_ratio(1,kcorr,k,j) * &
5664	!AH f(k1,j,i) &
5665	!AH + logc_ratio(2,jcorr,k,j) * &
5666	!AH f(k,j1,i) )
5667	ENDDO
5668	ENDIF
5669	ENDDO
5670	ENDIF
5671	ENDDO
5672	ENDIF
5673
5674	ENDIF ! ( topography /= 'flat' )
5675	!
5676	!-- Apply the reversibility correction to the boundary-normal velocity-
5677	!-- component u and the scalars. It must not be applied to the boundary-
5678	!-- tangential velocity components v and w because their 2-D anterpolation
5679	!-- cells do not cover all the child-grid nodes on the boundary.
5680	IF ( .NOT. ( ( var == 'v' ) .OR. ( var == 'w' ) ) ) THEN
5681	l = ic(i)
5682	DO m = jcs, jcn
5683	DO n = 0, kct+1
5684	ijk = 1
5685	cellsum = 0.0_wp
5686	cellsumd = 0.0_wp
5687	!
5688	!-- Note that the index name i must not be used here as a loop
5689	!-- index name since i is the constant boundary index, hence
5690	!-- the name ia.
5691	DO ia = ifl(l), ifu(l)
5692	DO j = jfl(m), jfu(m)
5693	DO k = kfl(n), kfu(n)
5694	cellsum = cellsum + MERGE( f(k,j,ia), 0.0_wp, &
5695	BTEST( wall_flags_0(k,j,ia), var_flag ) )
5696	celltmpd(ijk) = ABS( fc(n,m,l) - f(k,j,ia) )
5697	cellsumd = cellsumd + MERGE( celltmpd(ijk), &
5698	0.0_wp, BTEST( wall_flags_0(k,j,ia), var_flag ) )
5699	ijk = ijk + 1
5700	ENDDO
5701	ENDDO
5702	ENDDO
5703
5704	IF ( ijkfc(n,m,l) /= 0 ) THEN
5705	cellsum = cellsum / REAL( ijkfc(n,m,l), KIND=wp )
5706	rcorr = fc(n,m,l) - cellsum
5707	cellsumd = cellsumd / REAL( ijkfc(n,m,l), KIND=wp )
5708	ELSE
5709	cellsum = 0.0_wp
5710	rcorr = 0.0_wp
5711	cellsumd = 1.0_wp
5712	celltmpd = 1.0_wp
5713	ENDIF
5714	!
5715	!-- Distribute the correction term to the child nodes according to
5716	!-- their relative difference to the parent value such that the
5717	!-- node with the largest difference gets the largest share of the
5718	!-- correction. The distribution is skipped if rcorr is negligibly
5719	!-- small in order to avoid division by zero.
5720	IF ( ABS(rcorr) < 0.000001_wp ) THEN
5721	cellsumd = 1.0_wp
5722	celltmpd = 1.0_wp
5723	ENDIF
5724
5725	ijk = 1
5726	DO ia = ifl(l), ifu(l)
5727	DO j = jfl(m), jfu(m)
5728	DO k = kfl(n), kfu(n)
5729	rcorr_ijk = rcorr * celltmpd(ijk) / cellsumd
5730	f(k,j,ia) = f(k,j,ia) + rcorr_ijk
5731	ijk = ijk + 1
5732	ENDDO
5733	ENDDO
5734	ENDDO
5735
5736	ENDDO ! n
5737	ENDDO ! m
5738
5739	ENDIF ! var not v or w
5740	!
5741	!-- Store the boundary values also into the other redundant ghost node layers.
5742	!-- Note that in case of only one ghost node layer, e.g. for the PW
5743	!-- scheme, the following loops will not be entered.
5744	IF ( edge == 'l' ) THEN
5745	DO ibgp = -nbgp, ib
5746	f(0:nzt+1,nysg:nyng,ibgp) = f(0:nzt+1,nysg:nyng,i)
5747	ENDDO
5748	ELSEIF ( edge == 'r' ) THEN
5749	DO ibgp = ib, nx+nbgp
5750	f(0:nzt+1,nysg:nyng,ibgp) = f(0:nzt+1,nysg:nyng,i)
5751	ENDDO
5752	ENDIF
5753
5754	END SUBROUTINE pmci_interp_tril_lr
5755
5756
5757
5758	SUBROUTINE pmci_interp_tril_sn( f, fc, ic, jc, kc, r1x, r2x, r1y, r2y, r1z, &
5759	r2z, logc, logc_ratio, logc_kbounds, &
5760	nzt_topo_nestbc, &
5761	kct, ifl, ifu, jfl, jfu, kfl, kfu, ijkfc, &
5762	edge, var )
5763
5764	!
5765	!-- Interpolation of ghost-node values used as the child-domain boundary
5766	!-- conditions. This subroutine handles the south and north boundaries.
5767	!-- This subroutine is based on trilinear interpolation.
5768
5769	IMPLICIT NONE
5770
5771	INTEGER(iwp) :: nzt_topo_nestbc !<
5772
5773	REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &
5774	INTENT(INOUT) :: f !<
5775	REAL(wp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), &
5776	INTENT(IN) :: fc !<
5777	REAL(wp), DIMENSION(1:2,0:ncorr-1,nzb:nzt_topo_nestbc,nxl:nxr), &
5778	INTENT(IN) :: logc_ratio !<
5779	REAL(wp), DIMENSION(nxlg:nxrg), INTENT(IN) :: r1x !<
5780	REAL(wp), DIMENSION(nxlg:nxrg), INTENT(IN) :: r2x !<
5781	REAL(wp), DIMENSION(nysg:nyng), INTENT(IN) :: r1y !<
5782	REAL(wp), DIMENSION(nysg:nyng), INTENT(IN) :: r2y !<
5783	REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN) :: r1z !<
5784	REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN) :: r2z !<
5785
5786	INTEGER(iwp), DIMENSION(nxlg:nxrg), INTENT(IN) :: ic !<
5787	INTEGER(iwp), DIMENSION(nysg:nyng), INTENT(IN) :: jc !<
5788	INTEGER(iwp), DIMENSION(nzb:nzt+1), INTENT(IN) :: kc !<
5789	INTEGER(iwp), DIMENSION(1:2,nzb:nzt_topo_nestbc,nxl:nxr), &
5790	INTENT(IN) :: logc !<
5791	INTEGER(iwp), DIMENSION(1:2,nxl:nxr), INTENT(IN) :: logc_kbounds !<
5792
5793	INTEGER(iwp) :: kct
5794	INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) :: ifl !< Indicates start index of child cells belonging to certain parent cell - x direction
5795	INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) :: ifu !< Indicates end index of child cells belonging to certain parent cell - x direction
5796	INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) :: jfl !< Indicates start index of child cells belonging to certain parent cell - y direction
5797	INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) :: jfu !< Indicates start index of child cells belonging to certain parent cell - y direction
5798	!AH INTEGER(iwp), DIMENSION(0:kct), INTENT(IN) :: kfl !< Indicates start index of child cells belonging to certain parent cell - z direction
5799	!AH INTEGER(iwp), DIMENSION(0:kct), INTENT(IN) :: kfu !< Indicates start index of child cells belonging to certain parent cell - z direction
5800	INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN) :: kfl !< Indicates start index of child cells belonging to certain parent cell - z direction
5801	INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN) :: kfu !< Indicates start index of child cells belonging to certain parent cell - z direction
5802	!AH INTEGER(iwp), DIMENSION(0:kct,jcs:jcn,icl:icr), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box
5803	INTEGER(iwp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box
5804
5805	CHARACTER(LEN=1), INTENT(IN) :: edge !<
5806	CHARACTER(LEN=1), INTENT(IN) :: var !<
5807
5808	INTEGER(iwp) :: i !<
5809	INTEGER(iwp) :: iinc !<
5810	INTEGER(iwp) :: icorr !<
5811	INTEGER(iwp) :: ico !<
5812	INTEGER(iwp) :: ijk !<
5813	INTEGER(iwp) :: i1 !<
5814	INTEGER(iwp) :: j !<
5815	INTEGER(iwp) :: ja !<
5816	INTEGER(iwp) :: jb !<
5817	INTEGER(iwp) :: jbgp !<
5818	INTEGER(iwp) :: k !<
5819	INTEGER(iwp) :: k_wall !< vertical index of topography top
5820	INTEGER(iwp) :: kcorr !<
5821	INTEGER(iwp) :: kco !<
5822	INTEGER(iwp) :: k1 !<
5823	INTEGER(iwp) :: l !<
5824	INTEGER(iwp) :: m !<
5825	INTEGER(iwp) :: n !<
5826	INTEGER(iwp) :: var_flag !<
5827
5828	REAL(wp) :: cellsum !<
5829	REAL(wp) :: cellsumd !<
5830	REAL(wp) :: fk !<
5831	REAL(wp) :: fkj !<
5832	REAL(wp) :: fkjp !<
5833	REAL(wp) :: fkpj !<
5834	REAL(wp) :: fkpjp !<
5835	REAL(wp) :: fkp !<
5836	REAL(wp) :: rcorr !<
5837	REAL(wp) :: rcorr_ijk !<
5838
5839	!
5840	!-- Check which edge is to be handled: south or north
5841	IF ( edge == 's' ) THEN
5842	!
5843	!-- For v, nys is a ghost node, but not for the other variables
5844	IF ( var == 'v' ) THEN
5845	j = nys
5846	jb = nys - 1
5847	ELSE
5848	j = nys - 1
5849	jb = nys - 2
5850	ENDIF
5851	ELSEIF ( edge == 'n' ) THEN
5852	j = nyn + 1
5853	jb = nyn + 2
5854	ENDIF
5855
5856	IF ( var == 'u' ) THEN
5857	var_flag = 1
5858	ELSEIF ( var == 'v' ) THEN
5859	var_flag = 2
5860	ELSEIF ( var == 'w' ) THEN
5861	var_flag = 3
5862	ELSE
5863	var_flag = 0
5864	ENDIF
5865
5866	DO i = nxl, nxr+1
5867	!
5868	!-- Determine vertical index of topography top at grid point (j,i)
5869	!AH k_wall = get_topography_top_index_ji( j, i, TRIM( var ) )
5870
5871	DO k = nzb, nzt+1 !AH k_wall, nzt+1
5872	l = ic(i)
5873	m = jc(j)
5874	n = kc(k)
5875	fkj = r1x(i) * fc(n,m,l) + r2x(i) * fc(n,m,l+1)
5876	fkjp = r1x(i) * fc(n,m+1,l) + r2x(i) * fc(n,m+1,l+1)
5877	fkpj = r1x(i) * fc(n+1,m,l) + r2x(i) * fc(n+1,m,l+1)
5878	fkpjp = r1x(i) * fc(n+1,m+1,l) + r2x(i) * fc(n+1,m+1,l+1)
5879	fk = r1y(j) * fkj + r2y(j) * fkjp
5880	fkp = r1y(j) * fkpj + r2y(j) * fkpjp
5881	f(k,j,i) = r1z(k) * fk + r2z(k) * fkp
5882	ENDDO
5883	ENDDO
5884	!
5885	!-- Generalized log-law-correction algorithm.
5886	!-- Multiply two-dimensional index arrays logc(1:2,:,:) and log-ratio arrays
5887	!-- logc_ratio(1:2,0:ncorr-1,:,:) have been precomputed in subroutine
5888	!-- pmci_init_loglaw_correction.
5889	!
5890	!-- Solid surface below the node
5891	IF ( constant_flux_layer .AND. ( var == 'u' .OR. var == 'v' ) ) THEN
5892	DO i = nxl, nxr
5893	!
5894	!-- Determine vertical index of topography top at grid point (j,i)
5895	k_wall = get_topography_top_index_ji( j, i, TRIM( var ) )
5896
5897	k = k_wall + 1
5898	IF ( ( logc(1,k,i) /= 0 ) .AND. ( logc(2,k,i) == 0 ) ) THEN
5899	k1 = logc(1,k,i)
5900	DO kcorr = 0, ncorr-1
5901	kco = k + kcorr
5902	!AH f(kco,j,i) = logc_ratio(1,kcorr,k,i) * f(k1,j,i)
5903	ENDDO
5904	ENDIF
5905	ENDDO
5906	ENDIF
5907	!
5908	!-- In case of non-flat topography, also vertical walls and corners need to be
5909	!-- treated. Only single and double wall nodes are corrected.
5910	!-- Triple and higher-multiple wall nodes are not corrected as it would be
5911	!-- extremely complicated and the log law would not be valid anyway in such
5912	!-- locations.
5913	IF ( topography /= 'flat' ) THEN
5914
5915	IF ( constant_flux_layer .AND. ( var == 'v' .OR. var == 'w' ) ) THEN
5916	DO i = nxl, nxr
5917	DO k = logc_kbounds(1,i), logc_kbounds(2,i)
5918	!
5919	!-- Solid surface only on left/right side of the node
5920	IF ( ( logc(2,k,i) /= 0 ) .AND. ( logc(1,k,i) == 0 ) ) THEN
5921	!
5922	!-- Direction of the wall-normal index is carried in as the
5923	!-- sign of logc
5924	iinc = SIGN( 1, logc(2,k,i) )
5925	i1 = ABS( logc(2,k,i) )
5926	DO icorr = 0, ncorr-1
5927	ico = i + iinc * icorr
5928	IF ( ico >= nxl .AND. ico <= nxr ) THEN
5929	!AH f(k,j,ico) = logc_ratio(2,icorr,k,i) * f(k,j,i1)
5930	ENDIF
5931	ENDDO
5932	ENDIF
5933	ENDDO
5934	ENDDO
5935	ENDIF
5936	!
5937	!-- Solid surface on both below and on left/right side of the node
5938	IF ( constant_flux_layer .AND. var == 'v' ) THEN
5939	DO i = nxl, nxr
5940	k = logc_kbounds(1,i)
5941	IF ( ( logc(2,k,i) /= 0 ) .AND. ( logc(1,k,i) /= 0 ) ) THEN
5942	k1 = logc(1,k,i)
5943	iinc = SIGN( 1, logc(2,k,i) )
5944	i1 = ABS( logc(2,k,i) )
5945	DO icorr = 0, ncorr-1
5946	ico = i + iinc * icorr
5947	IF ( ico >= nxl .AND. ico <= nxr ) THEN
5948	DO kcorr = 0, ncorr-1
5949	kco = k + kcorr
5950	!AH f(kco,j,ico) = 0.5_wp * ( logc_ratio(1,kcorr,k,i) * &
5951	!AH f(k1,j,i) &
5952	!AH + logc_ratio(2,icorr,k,i) * &
5953	!AH f(k,j,i1) )
5954	ENDDO
5955	ENDIF
5956	ENDDO
5957	ENDIF
5958	ENDDO
5959	ENDIF
5960
5961	ENDIF ! ( topography /= 'flat' )
5962	!
5963	!-- Apply the reversibility correction to the boundary-normal velocity-
5964	!-- component v and the scalars. It must not be applied to the boundary-
5965	!-- tangential velocity components u and w because their 2-D anterpolation
5966	!-- cells do not cover all the child-grid nodes on the boundary.
5967	IF ( .NOT. ( ( var == 'u' ) .OR. ( var == 'w' ) ) ) THEN
5968	m = jc(j)
5969	DO l = icl, icr
5970	DO n = 0, kct+1
5971	ijk = 1
5972	cellsum = 0.0_wp
5973	cellsumd = 0.0_wp
5974	DO i = ifl(l), ifu(l)
5975	DO ja = jfl(m), jfu(m)
5976	DO k = kfl(n), kfu(n)
5977	cellsum = cellsum + MERGE( f(k,ja,i), 0.0_wp, &
5978	BTEST( wall_flags_0(k,ja,i), var_flag ) )
5979	celltmpd(ijk) = ABS( fc(n,m,l) - f(k,ja,i) )
5980	cellsumd = cellsumd + MERGE( celltmpd(ijk), &
5981	0.0_wp, BTEST( wall_flags_0(k,ja,i), var_flag ) )
5982	ijk = ijk + 1
5983	ENDDO
5984	ENDDO
5985	ENDDO
5986
5987	IF ( ijkfc(n,m,l) /= 0 ) THEN
5988	cellsum = cellsum / REAL( ijkfc(n,m,l), KIND=wp )
5989	rcorr = fc(n,m,l) - cellsum
5990	cellsumd = cellsumd / REAL( ijkfc(n,m,l), KIND=wp )
5991	ELSE
5992	cellsum = 0.0_wp
5993	rcorr = 0.0_wp
5994	cellsumd = 1.0_wp
5995	celltmpd = 1.0_wp
5996	ENDIF
5997	!
5998	!-- Distribute the correction term to the child nodes according to
5999	!-- their relative difference to the parent value such that the
6000	!-- node with the largest difference gets the largest share of the
6001	!-- correction. The distribution is skipped if rcorr is negligibly
6002	!-- small in order to avoid division by zero.
6003	IF ( ABS(rcorr) < 0.000001_wp ) THEN
6004	cellsumd = 1.0_wp
6005	celltmpd = 1.0_wp
6006	ENDIF
6007
6008	ijk = 1
6009	DO i = ifl(l), ifu(l)
6010	DO ja = jfl(m), jfu(m)
6011	DO k = kfl(n), kfu(n)
6012	rcorr_ijk = rcorr * celltmpd(ijk) / cellsumd
6013	f(k,ja,i) = f(k,ja,i) + rcorr_ijk
6014	ijk = ijk + 1
6015	ENDDO
6016	ENDDO
6017	ENDDO
6018
6019	ENDDO ! n
6020	ENDDO ! l
6021
6022	ENDIF ! var not u or w
6023	!
6024	!-- Store the boundary values also into the other redundant ghost node layers.
6025	!-- Note that in case of only one ghost node layer, e.g. for the PW
6026	!-- scheme, the following loops will not be entered.
6027	IF ( edge == 's' ) THEN
6028	DO jbgp = -nbgp, jb
6029	f(0:nzt+1,jbgp,nxlg:nxrg) = f(0:nzt+1,j,nxlg:nxrg)
6030	ENDDO
6031	ELSEIF ( edge == 'n' ) THEN
6032	DO jbgp = jb, ny+nbgp
6033	f(0:nzt+1,jbgp,nxlg:nxrg) = f(0:nzt+1,j,nxlg:nxrg)
6034	ENDDO
6035	ENDIF
6036
6037	END SUBROUTINE pmci_interp_tril_sn
6038
6039
6040
6041	SUBROUTINE pmci_interp_tril_t( f, fc, ic, jc, kc, r1x, r2x, r1y, r2y, &
6042	r1z, r2z, kct, ifl, ifu, jfl, jfu, kfl, kfu, &
6043	ijkfc, var )
6044
6045	!
6046	!-- Interpolation of ghost-node values used as the child-domain boundary
6047	!-- conditions. This subroutine handles the top boundary.
6048	!-- This subroutine is based on trilinear interpolation.
6049
6050	IMPLICIT NONE
6051
6052	REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &
6053	INTENT(INOUT) :: f !<
6054	REAL(wp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), &
6055	INTENT(IN) :: fc !<
6056	REAL(wp), DIMENSION(nxlg:nxrg), INTENT(IN) :: r1x !<
6057	REAL(wp), DIMENSION(nxlg:nxrg), INTENT(IN) :: r2x !<
6058	REAL(wp), DIMENSION(nysg:nyng), INTENT(IN) :: r1y !<
6059	REAL(wp), DIMENSION(nysg:nyng), INTENT(IN) :: r2y !<
6060	REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN) :: r1z !<
6061	REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN) :: r2z !<
6062
6063	INTEGER(iwp), DIMENSION(nxlg:nxrg), INTENT(IN) :: ic !<
6064	INTEGER(iwp), DIMENSION(nysg:nyng), INTENT(IN) :: jc !<
6065	INTEGER(iwp), DIMENSION(nzb:nzt+1), INTENT(IN) :: kc !<
6066
6067	INTEGER(iwp) :: kct
6068	INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) :: ifl !< Indicates start index of child cells belonging to certain parent cell - x direction
6069	INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) :: ifu !< Indicates end index of child cells belonging to certain parent cell - x direction
6070	INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) :: jfl !< Indicates start index of child cells belonging to certain parent cell - y direction
6071	INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) :: jfu !< Indicates start index of child cells belonging to certain parent cell - y direction
6072	!AH INTEGER(iwp), DIMENSION(0:kct), INTENT(IN) :: kfl !< Indicates start index of child cells belonging to certain parent cell - z direction
6073	!AH INTEGER(iwp), DIMENSION(0:kct), INTENT(IN) :: kfu !< Indicates start index of child cells belonging to certain parent cell - z direction
6074	INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN) :: kfl !< Indicates start index of child cells belonging to certain parent cell - z direction
6075	INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN) :: kfu !< Indicates start index of child cells belonging to certain parent cell - z direction
6076	!AH INTEGER(iwp), DIMENSION(0:kct,jcs:jcn,icl:icr), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box
6077	INTEGER(iwp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box
6078
6079	CHARACTER(LEN=1), INTENT(IN) :: var !<
6080
6081	INTEGER(iwp) :: i !<
6082	INTEGER(iwp) :: ib !<
6083	INTEGER(iwp) :: ie !<
6084	INTEGER(iwp) :: ijk !<
6085	INTEGER(iwp) :: j !<
6086	INTEGER(iwp) :: jb !<
6087	INTEGER(iwp) :: je !<
6088	INTEGER(iwp) :: k !<
6089	INTEGER(iwp) :: ka !<
6090	INTEGER(iwp) :: l !<
6091	INTEGER(iwp) :: m !<
6092	INTEGER(iwp) :: n !<
6093	INTEGER(iwp) :: var_flag !<
6094
6095	REAL(wp) :: cellsum !<
6096	REAL(wp) :: cellsumd !<
6097	REAL(wp) :: fk !<
6098	REAL(wp) :: fkj !<
6099	REAL(wp) :: fkjp !<
6100	REAL(wp) :: fkpj !<
6101	REAL(wp) :: fkpjp !<
6102	REAL(wp) :: fkp !<
6103	REAL(wp) :: rcorr !<
6104	REAL(wp) :: rcorr_ijk !<
6105
6106
6107	IF ( var == 'w' ) THEN
6108	k = nzt
6109	ELSE
6110	k = nzt + 1
6111	ENDIF
6112	!
6113	!-- These exceedings by one are needed only to avoid stripes
6114	!-- and spots in visualization. They have no effect on the
6115	!-- actual solution.
6116	ib = nxl-1
6117	ie = nxr+1
6118	jb = nys-1
6119	je = nyn+1
6120
6121	IF ( var == 'u' ) THEN
6122	var_flag = 1
6123	ELSEIF ( var == 'v' ) THEN
6124	var_flag = 2
6125	ELSEIF ( var == 'w' ) THEN
6126	var_flag = 3
6127	ELSE
6128	var_flag = 0
6129	ENDIF
6130
6131	DO i = ib, ie
6132	DO j = jb, je
6133	l = ic(i)
6134	m = jc(j)
6135	n = kc(k)
6136	fkj = r1x(i) * fc(n,m,l) + r2x(i) * fc(n,m,l+1)
6137	fkjp = r1x(i) * fc(n,m+1,l) + r2x(i) * fc(n,m+1,l+1)
6138	fkpj = r1x(i) * fc(n+1,m,l) + r2x(i) * fc(n+1,m,l+1)
6139	fkpjp = r1x(i) * fc(n+1,m+1,l) + r2x(i) * fc(n+1,m+1,l+1)
6140	fk = r1y(j) * fkj + r2y(j) * fkjp
6141	fkp = r1y(j) * fkpj + r2y(j) * fkpjp
6142	f(k,j,i) = r1z(k) * fk + r2z(k) * fkp
6143	ENDDO
6144	ENDDO
6145	!
6146	!-- Apply the reversibility correction to the boundary-normal velocity-
6147	!-- component w and scalars. It must not be applied to the boundary-
6148	!-- tangential velocity components u and v because their 2-D anterpolation
6149	!-- cells do not cover all the child-grid nodes on the boundary.
6150	IF ( .NOT. ( ( var == 'u' ) .OR. ( var == 'v' ) ) ) THEN
6151	IF ( var == 'w' ) THEN
6152	n = kc(k)
6153	ELSE
6154	n = kc(k) + 1
6155	ENDIF
6156
6157	DO l = icl, icr
6158	DO m = jcs, jcn
6159	ijk = 1
6160	cellsum = 0.0_wp
6161	cellsumd = 0.0_wp
6162	DO i = ifl(l), ifu(l)
6163	DO j = jfl(m), jfu(m)
6164	DO ka = kfl(n), kfu(n)
6165	cellsum = cellsum + MERGE( f(ka,j,i), 0.0_wp, &
6166	BTEST( wall_flags_0(ka,j,i), var_flag ) )
6167	celltmpd(ijk) = ABS( fc(n,m,l) - f(ka,j,i) )
6168	cellsumd = cellsumd + MERGE( celltmpd(ijk), &
6169	0.0_wp, BTEST( wall_flags_0(ka,j,i), var_flag ) )
6170	ijk = ijk + 1
6171	ENDDO
6172	ENDDO
6173	ENDDO
6174
6175	IF ( ijkfc(n,m,l) /= 0 ) THEN
6176	cellsum = cellsum / REAL( ijkfc(n,m,l), KIND=wp )
6177	rcorr = fc(n,m,l) - cellsum
6178	cellsumd = cellsumd / REAL( ijkfc(n,m,l), KIND=wp )
6179	ELSE
6180	cellsum = 0.0_wp
6181	rcorr = 0.0_wp
6182	cellsumd = 1.0_wp
6183	celltmpd = 1.0_wp
6184	ENDIF
6185
6186	IF ( ABS(rcorr) < 0.000001_wp ) THEN
6187	cellsumd = 1.0_wp
6188	celltmpd = 1.0_wp
6189	ENDIF
6190
6191	ijk = 1
6192	DO i = ifl(l), ifu(l)
6193	DO j = jfl(m), jfu(m)
6194	DO ka = kfl(n), kfu(n)
6195	rcorr_ijk = rcorr * celltmpd(ijk) / cellsumd
6196	f(ka,j,i) = f(ka,j,i) + rcorr_ijk
6197	ijk = ijk + 1
6198	ENDDO
6199	ENDDO
6200	ENDDO
6201
6202	ENDDO ! m
6203	ENDDO ! l
6204
6205	ENDIF ! var not u or v
6206	!
6207	!-- Just fill up the redundant second ghost-node layer for w.
6208	IF ( var == 'w' ) THEN
6209	f(nzt+1,:,:) = f(nzt,:,:)
6210	ENDIF
6211
6212	END SUBROUTINE pmci_interp_tril_t
6213
6214
6215
6216	SUBROUTINE pmci_anterp_tophat( f, fc, kct, ifl, ifu, jfl, jfu, kfl, kfu, &
6217	ijkfc, var )
6218	!
6219	!-- Anterpolation of internal-node values to be used as the parent-domain
6220	!-- values. This subroutine is based on the first-order numerical
6221	!-- integration of the fine-grid values contained within the coarse-grid
6222	!-- cell.
6223
6224	IMPLICIT NONE
6225
6226	CHARACTER(LEN=*), INTENT(IN) :: var !< identifyer for treated variable
6227
6228	!AH INTEGER(iwp), DIMENSION(0:kct,jcs:jcn,icl:icr), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box
6229	INTEGER(iwp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), INTENT(IN) :: ijkfc !< number of child grid points contributing to a parent grid box
6230
6231	INTEGER(iwp) :: i !< Running index x-direction - fine-grid
6232	INTEGER(iwp) :: icla !< Left boundary index for anterpolation along x
6233	INTEGER(iwp) :: icra !< Right boundary index for anterpolation along x
6234	INTEGER(iwp) :: ii !< Running index x-direction - coarse grid
6235	INTEGER(iwp) :: j !< Running index y-direction - fine-grid
6236	INTEGER(iwp) :: jcna !< North boundary index for anterpolation along y
6237	INTEGER(iwp) :: jcsa !< South boundary index for anterpolation along y
6238	INTEGER(iwp) :: jj !< Running index y-direction - coarse grid
6239	INTEGER(iwp) :: k !< Running index z-direction - fine-grid
6240	INTEGER(iwp) :: kcb = 0 !< Bottom boundary index for anterpolation along z
6241	INTEGER(iwp) :: kk !< Running index z-direction - coarse grid
6242	INTEGER(iwp) :: var_flag !< bit number used to flag topography on respective grid
6243
6244	INTEGER(iwp), INTENT(IN) :: kct !< Top boundary index for anterpolation along z
6245
6246	INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) :: ifl !< Indicates start index of child cells belonging to certain parent cell - x direction
6247	INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) :: ifu !< Indicates end index of child cells belonging to certain parent cell - x direction
6248	INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) :: jfl !< Indicates start index of child cells belonging to certain parent cell - y direction
6249	INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) :: jfu !< Indicates start index of child cells belonging to certain parent cell - y direction
6250	!AH INTEGER(iwp), DIMENSION(0:kct), INTENT(IN) :: kfl !< Indicates start index of child cells belonging to certain parent cell - z direction
6251	!AH INTEGER(iwp), DIMENSION(0:kct), INTENT(IN) :: kfu !< Indicates start index of child cells belonging to certain parent cell - z direction
6252	INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN) :: kfl !< Indicates start index of child cells belonging to certain parent cell - z direction
6253	INTEGER(iwp), DIMENSION(0:cg%nz+1), INTENT(IN) :: kfu !< Indicates start index of child cells belonging to certain parent cell - z direction
6254
6255	REAL(wp) :: cellsum !< sum of respective child cells belonging to parent cell
6256	REAL(wp) :: fra !< relaxation faction
6257
6258	REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg), INTENT(IN) :: f !< Treated variable - child domain
6259	REAL(wp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), INTENT(INOUT) :: fc !< Treated variable - parent domain
6260
6261	!
6262	!-- Define the index bounds icla, icra, jcsa and jcna.
6263	!-- Note that kcb is simply zero and kct enters here as a parameter and it is
6264	!-- determined in pmci_init_anterp_tophat.
6265	!-- Please note, grid points used also for interpolation (from parent to
6266	!-- child) are excluded in anterpolation, e.g. anterpolation is only from
6267	!-- nzb:kct-1, as kct is used for interpolation. Following this approach
6268	!-- avoids numerical problems which may accumulate, particularly for shallow
6269	!-- child domain, leading to increased velocity variances. A more
6270	!-- comprehensive explanation for this is still pending.
6271	icla = coarse_bound_anterp(1)
6272	icra = coarse_bound_anterp(2)
6273	jcsa = coarse_bound_anterp(3)
6274	jcna = coarse_bound_anterp(4)
6275	kcb = 0
6276	IF ( nesting_mode /= 'vertical' ) THEN
6277	IF ( bc_dirichlet_l ) THEN
6278	IF ( var == 'u' ) THEN
6279	icla = coarse_bound_anterp(1) + 2
6280	ELSE
6281	icla = coarse_bound_anterp(1) + 1
6282	ENDIF
6283	ENDIF
6284	IF ( bc_dirichlet_r ) THEN
6285	icra = coarse_bound_anterp(2) - 1
6286	ENDIF
6287
6288	IF ( bc_dirichlet_s ) THEN
6289	IF ( var == 'v' ) THEN
6290	jcsa = coarse_bound_anterp(3) + 2
6291	ELSE
6292	jcsa = coarse_bound_anterp(3) + 1
6293	ENDIF
6294	ENDIF
6295	IF ( bc_dirichlet_n ) THEN
6296	jcna = coarse_bound_anterp(4) - 1
6297	ENDIF
6298	ENDIF
6299
6300	! write(9,"('pmci_anterp_tophat: ',4(e12.5,2x))") &
6301	! cg%coord_x(icla), cg%coord_y(jcsa), cg%coord_x(icra), cg%coord_y(jcna)
6302	! flush(9)
6303	!
6304	!-- Set masking bit for topography flags
6305	IF ( var == 'u' ) THEN
6306	var_flag = 1
6307	ELSEIF ( var == 'v' ) THEN
6308	var_flag = 2
6309	ELSEIF ( var == 'w' ) THEN
6310	var_flag = 3
6311	ELSE
6312	var_flag = 0
6313	ENDIF
6314	!
6315	!-- Note that ii, jj, and kk are coarse-grid indices and i,j, and k
6316	!-- are fine-grid indices.
6317	DO ii = icla, icra
6318	DO jj = jcsa, jcna
6319	!
6320	!-- For simplicity anterpolate within buildings and under elevated
6321	!-- terrain too
6322	DO kk = kcb, kct - 1
6323	cellsum = 0.0_wp
6324	DO i = ifl(ii), ifu(ii)
6325	DO j = jfl(jj), jfu(jj)
6326	DO k = kfl(kk), kfu(kk)
6327	cellsum = cellsum + MERGE( f(k,j,i), 0.0_wp, &
6328	BTEST( wall_flags_0(k,j,i), var_flag ) )
6329	ENDDO
6330	ENDDO
6331	ENDDO
6332	!
6333	!-- Spatial under-relaxation.
6334	!-- The relaxation buffer zones are no longer needed with
6335	!-- the new reversible interpolation algorithm. 23.19.2018.
6336	! fra = frax(ii) * fray(jj) * fraz(kk)
6337	!
6338	!-- In case all child grid points are inside topography, i.e.
6339	!-- ijkfc and cellsum are zero, also parent solution would have
6340	!-- zero values at that grid point, which may cause problems in
6341	!-- particular for the temperature. Therefore, in case cellsum is
6342	!-- zero, keep the parent solution at this point.
6343	IF ( ijkfc(kk,jj,ii) /= 0 ) THEN
6344	! fc(kk,jj,ii) = ( 1.0_wp - fra ) * fc(kk,jj,ii) + &
6345	! fra * cellsum / &
6346	! REAL( ijkfc(kk,jj,ii), KIND=wp )
6347	fc(kk,jj,ii) = cellsum / REAL( ijkfc(kk,jj,ii), KIND=wp )
6348	ENDIF
6349
6350	ENDDO
6351
6352	ENDDO
6353	ENDDO
6354
6355	END SUBROUTINE pmci_anterp_tophat
6356
6357	#endif
6358
6359	END SUBROUTINE pmci_child_datatrans
6360
6361	! Description:
6362	! ------------
6363	!> Set boundary conditions for the prognostic quantities after interpolation
6364	!> and anterpolation at upward- and downward facing surfaces.
6365	!> @todo: add Dirichlet boundary conditions for pot. temperature, humdidity and
6366	!> passive scalar.
6367	!------------------------------------------------------------------------------!
6368	SUBROUTINE pmci_boundary_conds
6369
6370	USE chem_modules, &
6371	ONLY: ibc_cs_b
6372
6373	USE control_parameters, &
6374	ONLY: ibc_pt_b, ibc_q_b, ibc_s_b, ibc_uv_b
6375
6376	USE surface_mod, &
6377	ONLY: bc_h
6378
6379	IMPLICIT NONE
6380
6381	INTEGER(iwp) :: i !< Index along x-direction
6382	INTEGER(iwp) :: j !< Index along y-direction
6383	INTEGER(iwp) :: k !< Index along z-direction
6384	INTEGER(iwp) :: m !< Running index for surface type
6385	INTEGER(iwp) :: n !< running index for number of chemical species
6386
6387	!
6388	!-- Set Dirichlet boundary conditions for horizontal velocity components
6389	IF ( ibc_uv_b == 0 ) THEN
6390	!
6391	!-- Upward-facing surfaces
6392	DO m = 1, bc_h(0)%ns
6393	i = bc_h(0)%i(m)
6394	j = bc_h(0)%j(m)
6395	k = bc_h(0)%k(m)
6396	u(k-1,j,i) = 0.0_wp
6397	v(k-1,j,i) = 0.0_wp
6398	ENDDO
6399	!
6400	!-- Downward-facing surfaces
6401	DO m = 1, bc_h(1)%ns
6402	i = bc_h(1)%i(m)
6403	j = bc_h(1)%j(m)
6404	k = bc_h(1)%k(m)
6405	u(k+1,j,i) = 0.0_wp
6406	v(k+1,j,i) = 0.0_wp
6407	ENDDO
6408	ENDIF
6409	!
6410	!-- Set Dirichlet boundary conditions for vertical velocity component
6411	!-- Upward-facing surfaces
6412	DO m = 1, bc_h(0)%ns
6413	i = bc_h(0)%i(m)
6414	j = bc_h(0)%j(m)
6415	k = bc_h(0)%k(m)
6416	w(k-1,j,i) = 0.0_wp
6417	ENDDO
6418	!
6419	!-- Downward-facing surfaces
6420	DO m = 1, bc_h(1)%ns
6421	i = bc_h(1)%i(m)
6422	j = bc_h(1)%j(m)
6423	k = bc_h(1)%k(m)
6424	w(k+1,j,i) = 0.0_wp
6425	ENDDO
6426	!
6427	!-- Set Neumann boundary conditions for potential temperature
6428	IF ( .NOT. neutral ) THEN
6429	IF ( ibc_pt_b == 1 ) THEN
6430	DO m = 1, bc_h(0)%ns
6431	i = bc_h(0)%i(m)
6432	j = bc_h(0)%j(m)
6433	k = bc_h(0)%k(m)
6434	pt(k-1,j,i) = pt(k,j,i)
6435	ENDDO
6436	DO m = 1, bc_h(1)%ns
6437	i = bc_h(1)%i(m)
6438	j = bc_h(1)%j(m)
6439	k = bc_h(1)%k(m)
6440	pt(k+1,j,i) = pt(k,j,i)
6441	ENDDO
6442	ENDIF
6443	ENDIF
6444	!
6445	!-- Set Neumann boundary conditions for humidity and cloud-physical quantities
6446	IF ( humidity ) THEN
6447	IF ( ibc_q_b == 1 ) THEN
6448	DO m = 1, bc_h(0)%ns
6449	i = bc_h(0)%i(m)
6450	j = bc_h(0)%j(m)
6451	k = bc_h(0)%k(m)
6452	q(k-1,j,i) = q(k,j,i)
6453	ENDDO
6454	DO m = 1, bc_h(1)%ns
6455	i = bc_h(1)%i(m)
6456	j = bc_h(1)%j(m)
6457	k = bc_h(1)%k(m)
6458	q(k+1,j,i) = q(k,j,i)
6459	ENDDO
6460	ENDIF
6461	IF ( bulk_cloud_model .AND. microphysics_morrison ) THEN
6462	DO m = 1, bc_h(0)%ns
6463	i = bc_h(0)%i(m)
6464	j = bc_h(0)%j(m)
6465	k = bc_h(0)%k(m)
6466	nc(k-1,j,i) = 0.0_wp
6467	qc(k-1,j,i) = 0.0_wp
6468	ENDDO
6469	DO m = 1, bc_h(1)%ns
6470	i = bc_h(1)%i(m)
6471	j = bc_h(1)%j(m)
6472	k = bc_h(1)%k(m)
6473
6474	nc(k+1,j,i) = 0.0_wp
6475	qc(k+1,j,i) = 0.0_wp
6476	ENDDO
6477	ENDIF
6478
6479	IF ( bulk_cloud_model .AND. microphysics_seifert ) THEN
6480	DO m = 1, bc_h(0)%ns
6481	i = bc_h(0)%i(m)
6482	j = bc_h(0)%j(m)
6483	k = bc_h(0)%k(m)
6484	nr(k-1,j,i) = 0.0_wp
6485	qr(k-1,j,i) = 0.0_wp
6486	ENDDO
6487	DO m = 1, bc_h(1)%ns
6488	i = bc_h(1)%i(m)
6489	j = bc_h(1)%j(m)
6490	k = bc_h(1)%k(m)
6491	nr(k+1,j,i) = 0.0_wp
6492	qr(k+1,j,i) = 0.0_wp
6493	ENDDO
6494	ENDIF
6495
6496	ENDIF
6497	!
6498	!-- Set Neumann boundary conditions for passive scalar
6499	IF ( passive_scalar ) THEN
6500	IF ( ibc_s_b == 1 ) THEN
6501	DO m = 1, bc_h(0)%ns
6502	i = bc_h(0)%i(m)
6503	j = bc_h(0)%j(m)
6504	k = bc_h(0)%k(m)
6505	s(k-1,j,i) = s(k,j,i)
6506	ENDDO
6507	DO m = 1, bc_h(1)%ns
6508	i = bc_h(1)%i(m)
6509	j = bc_h(1)%j(m)
6510	k = bc_h(1)%k(m)
6511	s(k+1,j,i) = s(k,j,i)
6512	ENDDO
6513	ENDIF
6514	ENDIF
6515	!
6516	!-- Set Neumann boundary conditions for chemical species
6517	IF ( air_chemistry .AND. nest_chemistry ) THEN
6518	IF ( ibc_cs_b == 1 ) THEN
6519	DO n = 1, nspec
6520	DO m = 1, bc_h(0)%ns
6521	i = bc_h(0)%i(m)
6522	j = bc_h(0)%j(m)
6523	k = bc_h(0)%k(m)
6524	chem_species(n)%conc(k-1,j,i) = chem_species(n)%conc(k,j,i)
6525	ENDDO
6526	DO m = 1, bc_h(1)%ns
6527	i = bc_h(1)%i(m)
6528	j = bc_h(1)%j(m)
6529	k = bc_h(1)%k(m)
6530	chem_species(n)%conc(k+1,j,i) = chem_species(n)%conc(k,j,i)
6531	ENDDO
6532	ENDDO
6533	ENDIF
6534	ENDIF
6535
6536	END SUBROUTINE pmci_boundary_conds
6537
6538
6539	END MODULE pmc_interface

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |