Home

Context Navigation

source: palm/trunk/SOURCE/vertical_nesting_mod.f90 @ 4204

Last change on this file since 4204 was 4182, checked in by scharf, 5 years ago
corrected "Former revisions" section minor formatting in "Former revisions" section added "Author" section
Property svn:keywords set to `Id`
File size: 149.7 KB

Line
1	!> @file vertical_nesting_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-2019 Leibniz Universitaet Hannover
18	! Copyright 2017-2018 Karlsruhe Institute of Technology
19	!------------------------------------------------------------------------------!
20	!
21	! Current revisions:
22	! -----------------
23	!
24	!
25	! Former revisions:
26	! -----------------
27	! $Id: vertical_nesting_mod.f90 4182 2019-08-22 15:20:23Z knoop $
28	! Corrected "Former revisions" section
29	!
30	! 4102 2019-07-17 16:00:03Z suehring
31	! - Slightly revise setting of boundary conditions at horizontal walls, use
32	! data-structure offset index instead of pre-calculate it for each facing
33	!
34	! 4101 2019-07-17 15:14:26Z gronemeier
35	! remove old_dt
36	!
37	! 3802 2019-03-17 13:33:42Z raasch
38	! unused subroutines commented out
39	!
40	! 3655 2019-01-07 16:51:22Z knoop
41	! unused variables removed
42	!
43	! 2365 2017-08-21 14:59:59Z kanani
44	! Initial revision (SadiqHuq)
45	!
46	!
47	! Description:
48	! ------------
49	!> Module for vertical nesting.
50	!>
51	!> Definition of parameters and variables for vertical nesting
52	!> The horizontal extent of the parent (Coarse Grid) and the child (Fine Grid)
53	!> have to be identical. The vertical extent of the FG should be smaller than CG.
54	!> Only integer nesting ratio supported. Odd nesting ratio preferred
55	!> The code follows MPI-1 standards. The available processors are split into
56	!> two groups using MPI_COMM_SPLIT. Exchange of data from CG to FG is called
57	!> interpolation. FG initialization by interpolation is done once at the start.
58	!> FG boundary conditions are set by interpolated at every timestep.
59	!> Exchange of data from CG to FG is called anterpolation, the two-way interaction
60	!> occurs at every timestep.
61	!> vnest_start_time set in PARIN allows delayed start of the coupling
62	!> after spin-up of the CG
63	!>
64	!> @todo Replace dz(1) appropriatly to account for grid stretching
65	!> @todo Ensure that code can be compiled for serial and parallel mode. Please
66	!> check the placement of the directive "__parallel".
67	!> @todo Add descriptions for all declared variables/parameters, one declaration
68	!> statement per variable
69	!> @todo Add a descriptive header above each subroutine (see land_surface_model)
70	!> @todo FORTRAN language statements must not be used as names for variables
71	!> (e.g. if). Please rename it.
72	!> @todo Revise code according to PALM Coding Standard
73	!------------------------------------------------------------------------------!
74	MODULE vertical_nesting_mod
75
76	USE kinds
77
78	IMPLICIT NONE
79
80	LOGICAL :: vnested = .FALSE. !> set to true if palmrun
81	!> provides specific information via stdin
82	LOGICAL :: vnest_init = .FALSE. !> set to true when FG is initialized
83	REAL(wp) :: vnest_start_time = 9999999.9 !> simulated time when FG should be
84	!> initialized. Should be
85	!> identical in PARIN & PARIN_N
86
87
88
89	INTEGER(iwp),DIMENSION(3,2) :: bdims = 0 !> sub-domain grid topology of current PE
90	INTEGER(iwp),DIMENSION(3,2) :: bdims_rem = 0 !> sub-domain grid topology of partner PE
91	INTEGER(iwp) :: cg_nprocs !> no. of PE in CG. Set by palmrun -Y
92	INTEGER(iwp) :: fg_nprocs !> no. of PE in FG. Set by palmrun -Y
93	INTEGER(iwp) :: TYPE_VNEST_BC !> derived contiguous data type for interpolation
94	INTEGER(iwp) :: TYPE_VNEST_ANTER !> derived contiguous data type for anterpolation
95	INTEGER(iwp),DIMENSION(:,:,:),ALLOCATABLE :: c2f_dims_cg !> One CG PE sends data to multiple FG PEs
96	!> list of grid-topology of partners
97	INTEGER(iwp),DIMENSION(:,:,:),ALLOCATABLE :: f2c_dims_cg !> One CG PE receives data from multiple FG PEs
98	!> list of grid-topology of partners
99	INTEGER(iwp),DIMENSION(:),ALLOCATABLE :: c2f_dims_fg !> One FG PE sends data to multiple CG PE
100	!> list of grid-topology of partner
101	INTEGER(iwp),DIMENSION(:),ALLOCATABLE :: f2c_dims_fg !> One FG PE sends data to only one CG PE
102	!> list of grid-topology of partner
103
104	INTEGER(iwp),DIMENSION(:,:),ALLOCATABLE :: f_rnk_lst !> list storing rank of FG PE denoted by pdims
105	INTEGER(iwp),DIMENSION(:,:),ALLOCATABLE :: c_rnk_lst !> list storing rank of CG PE denoted by pdims
106	INTEGER(iwp),DIMENSION(3) :: cfratio !> Nesting ratio in x,y and z-directions
107
108	INTEGER(iwp) :: nxc !> no. of CG grid points in x-direction
109	INTEGER(iwp) :: nxf !> no. of FG grid points in x-direction
110	INTEGER(iwp) :: nyc !> no. of CG grid points in y-direction
111	INTEGER(iwp) :: nyf !> no. of FG grid points in y-direction
112	INTEGER(iwp) :: nzc !> no. of CG grid points in z-direction
113	INTEGER(iwp) :: nzf !> no. of FG grid points in z-direction
114	INTEGER(iwp) :: ngp_c !> no. of CG grid points in one vertical level
115	INTEGER(iwp) :: ngp_f !> no. of FG grid points in one vertical level
116
117	INTEGER(iwp) :: n_cell_c !> total no. of CG grid points in a PE
118	INTEGER(iwp),DIMENSION(2) :: pdims_partner !> processor topology of partner PE
119	INTEGER(iwp) :: target_idex !> temporary variable
120	INTEGER(iwp),DIMENSION(2) :: offset !> temporary variable
121	INTEGER(iwp),DIMENSION(2) :: map_coord !> temporary variable
122
123	REAL(wp) :: dxc !> CG grid pacing in x-direction
124	REAL(wp) :: dyc !> FG grid pacing in x-direction
125	REAL(wp) :: dxf !> CG grid pacing in y-direction
126	REAL(wp) :: dyf !> FG grid pacing in y-direction
127	REAL(wp) :: dzc !> CG grid pacing in z-direction
128	REAL(wp) :: dzf !> FG grid pacing in z-direction
129	REAL(wp) :: dtc !> dt calculated for CG
130	REAL(wp) :: dtf !> dt calculated for FG
131
132	REAL(wp), DIMENSION(:), ALLOCATABLE :: zuc !> CG vertical u-levels
133	REAL(wp), DIMENSION(:), ALLOCATABLE :: zuf !> FG vertical u-levels
134	REAL(wp), DIMENSION(:), ALLOCATABLE :: zwc !> CG vertical w-levels
135	REAL(wp), DIMENSION(:), ALLOCATABLE :: zwf !> FG vertical w-levels
136	REAL(wp), DIMENSION(:,:,:), POINTER :: interpol3d !> pointers to simplify function calls
137	REAL(wp), DIMENSION(:,:,:), POINTER :: anterpol3d !> pointers to simplify function calls
138
139
140	REAL(wp),DIMENSION(:,:,:), ALLOCATABLE :: work3d !> temporary array for exchange of 3D data
141	REAL(wp),DIMENSION(:,:), ALLOCATABLE :: work2dusws !> temporary array for exchange of 2D data
142	REAL(wp),DIMENSION(:,:), ALLOCATABLE :: work2dvsws !> temporary array for exchange of 2D data
143	REAL(wp),DIMENSION(:,:), ALLOCATABLE :: work2dts !> temporary array for exchange of 2D data
144	REAL(wp),DIMENSION(:,:), ALLOCATABLE :: work2dus !> temporary array for exchange of 2D data
145
146	SAVE
147
148	!-- Public functions
149	PUBLIC vnest_init_fine, vnest_boundary_conds, vnest_anterpolate, &
150	vnest_boundary_conds_khkm, vnest_anterpolate_e, &
151	vnest_init_pegrid_rank, vnest_init_pegrid_domain, vnest_init_grid, &
152	vnest_timestep_sync, vnest_deallocate
153
154	!-- Public constants and variables
155	PUBLIC vnested, vnest_init, vnest_start_time
156
157	PRIVATE bdims, bdims_rem, &
158	work3d, work2dusws, work2dvsws, work2dts, work2dus, &
159	dxc, dyc, dxf, dyf, dzc, dzf, dtc, dtf, &
160	zuc, zuf, zwc, zwf, interpol3d, anterpol3d, &
161	cg_nprocs, fg_nprocs, &
162	c2f_dims_cg, c2f_dims_fg, f2c_dims_cg, f2c_dims_fg, &
163	f_rnk_lst, c_rnk_lst, cfratio, pdims_partner, &
164	nxc, nxf, nyc, nyf, nzc, nzf, &
165	ngp_c, ngp_f, target_idex, n_cell_c, &
166	offset, map_coord, TYPE_VNEST_BC, TYPE_VNEST_ANTER
167
168	INTERFACE vnest_anterpolate
169	MODULE PROCEDURE vnest_anterpolate
170	END INTERFACE vnest_anterpolate
171
172	INTERFACE vnest_anterpolate_e
173	MODULE PROCEDURE vnest_anterpolate_e
174	END INTERFACE vnest_anterpolate_e
175
176	INTERFACE vnest_boundary_conds
177	MODULE PROCEDURE vnest_boundary_conds
178	END INTERFACE vnest_boundary_conds
179
180	INTERFACE vnest_boundary_conds_khkm
181	MODULE PROCEDURE vnest_boundary_conds_khkm
182	END INTERFACE vnest_boundary_conds_khkm
183
184	INTERFACE vnest_check_parameters
185	MODULE PROCEDURE vnest_check_parameters
186	END INTERFACE vnest_check_parameters
187
188	INTERFACE vnest_deallocate
189	MODULE PROCEDURE vnest_deallocate
190	END INTERFACE vnest_deallocate
191
192	INTERFACE vnest_init_fine
193	MODULE PROCEDURE vnest_init_fine
194	END INTERFACE vnest_init_fine
195
196	INTERFACE vnest_init_grid
197	MODULE PROCEDURE vnest_init_grid
198	END INTERFACE vnest_init_grid
199
200	INTERFACE vnest_init_pegrid_domain
201	MODULE PROCEDURE vnest_init_pegrid_domain
202	END INTERFACE vnest_init_pegrid_domain
203
204	INTERFACE vnest_init_pegrid_rank
205	MODULE PROCEDURE vnest_init_pegrid_rank
206	END INTERFACE vnest_init_pegrid_rank
207
208	INTERFACE vnest_timestep_sync
209	MODULE PROCEDURE vnest_timestep_sync
210	END INTERFACE vnest_timestep_sync
211
212	CONTAINS
213
214
215
216	SUBROUTINE vnest_init_fine
217	#if defined( __parallel )
218
219	!--------------------------------------------------------------------------------!
220	! Description:
221	! ------------
222	! At the specified vnest_start_time initialize the Fine Grid based on the coarse
223	! grid values
224	!------------------------------------------------------------------------------!
225
226
227	USE arrays_3d
228	USE control_parameters
229	USE grid_variables
230	USE indices
231	USE interfaces
232	USE pegrid
233	USE turbulence_closure_mod, &
234	ONLY : tcm_diffusivities
235
236
237	IMPLICIT NONE
238
239	REAL(wp) :: time_since_reference_point_rem
240	INTEGER(iwp) :: i
241	INTEGER(iwp) :: j
242	INTEGER(iwp) :: iif
243	INTEGER(iwp) :: jjf
244	INTEGER(iwp) :: kkf
245
246
247	if (myid ==0 ) print *, ' TIME TO INIT FINE from COARSE', simulated_time
248
249	!
250	!-- In case of model termination initiated by the remote model
251	!-- (terminate_coupled_remote > 0), initiate termination of the local model.
252	!-- The rest of the coupler must then be skipped because it would cause an MPI
253	!-- intercomminucation hang.
254	!-- If necessary, the coupler will be called at the beginning of the next
255	!-- restart run.
256
257	IF ( myid == 0) THEN
258	CALL MPI_SENDRECV( terminate_coupled, 1, MPI_INTEGER, &
259	target_id, 0, &
260	terminate_coupled_remote, 1, MPI_INTEGER, &
261	target_id, 0, &
262	comm_inter, status, ierr )
263	ENDIF
264	CALL MPI_BCAST( terminate_coupled_remote, 1, MPI_INTEGER, 0, comm2d, &
265	ierr )
266
267	IF ( terminate_coupled_remote > 0 ) THEN
268	WRITE( message_string, * ) 'remote model "', &
269	TRIM( coupling_mode_remote ), &
270	'" terminated', &
271	'&with terminate_coupled_remote = ', &
272	terminate_coupled_remote, &
273	'&local model "', TRIM( coupling_mode ), &
274	'" has', &
275	'&terminate_coupled = ', &
276	terminate_coupled
277	CALL message( 'vnest_init_fine', 'PA0310', 1, 2, 0, 6, 0 )
278	RETURN
279	ENDIF
280
281
282	!
283	!-- Exchange the current simulated time between the models,
284	!-- currently just for total_2ding
285	IF ( myid == 0 ) THEN
286
287	CALL MPI_SEND( time_since_reference_point, 1, MPI_REAL, target_id, &
288	11, comm_inter, ierr )
289	CALL MPI_RECV( time_since_reference_point_rem, 1, MPI_REAL, &
290	target_id, 11, comm_inter, status, ierr )
291
292	ENDIF
293
294	CALL MPI_BCAST( time_since_reference_point_rem, 1, MPI_REAL, 0, comm2d, &
295	ierr )
296
297
298	IF ( coupling_mode == 'vnested_crse' ) THEN
299	!-- Send data to fine grid for initialization
300
301	offset(1) = ( pdims_partner(1) / pdims(1) ) * pcoord(1)
302	offset(2) = ( pdims_partner(2) / pdims(2) ) * pcoord(2)
303
304	do j = 0, ( pdims_partner(2) / pdims(2) ) - 1
305	do i = 0, ( pdims_partner(1) / pdims(1) ) - 1
306	map_coord(1) = i+offset(1)
307	map_coord(2) = j+offset(2)
308
309	target_idex = f_rnk_lst(map_coord(1),map_coord(2)) + numprocs
310
311	CALL MPI_RECV( bdims_rem, 6, MPI_INTEGER, target_idex, 10, &
312	comm_inter,status, ierr )
313
314	bdims (1,1) = bdims_rem (1,1) / cfratio(1)
315	bdims (1,2) = bdims_rem (1,2) / cfratio(1)
316	bdims (2,1) = bdims_rem (2,1) / cfratio(2)
317	bdims (2,2) = bdims_rem (2,2) / cfratio(2)
318	bdims (3,1) = bdims_rem (3,1)
319	bdims (3,2) = bdims_rem (3,2) / cfratio(3)
320
321
322	CALL MPI_SEND( bdims, 6, MPI_INTEGER, target_idex, 9, &
323	comm_inter, ierr )
324
325
326	n_cell_c = (bdims(1,2)-bdims(1,1)+3) * &
327	(bdims(2,2)-bdims(2,1)+3) * &
328	(bdims(3,2)-bdims(3,1)+3)
329
330	CALL MPI_SEND( u( bdims(3,1):bdims(3,2)+2, &
331	bdims(2,1)-1:bdims(2,2)+1, &
332	bdims(1,1)-1:bdims(1,2)+1),&
333	n_cell_c, MPI_REAL, target_idex, &
334	101, comm_inter, ierr)
335
336	CALL MPI_SEND( v( bdims(3,1):bdims(3,2)+2, &
337	bdims(2,1)-1:bdims(2,2)+1, &
338	bdims(1,1)-1:bdims(1,2)+1),&
339	n_cell_c, MPI_REAL, target_idex, &
340	102, comm_inter, ierr)
341
342	CALL MPI_SEND( w( bdims(3,1):bdims(3,2)+2, &
343	bdims(2,1)-1:bdims(2,2)+1, &
344	bdims(1,1)-1:bdims(1,2)+1),&
345	n_cell_c, MPI_REAL, target_idex, &
346	103, comm_inter, ierr)
347
348	CALL MPI_SEND( pt(bdims(3,1):bdims(3,2)+2, &
349	bdims(2,1)-1:bdims(2,2)+1, &
350	bdims(1,1)-1:bdims(1,2)+1),&
351	n_cell_c, MPI_REAL, target_idex, &
352	105, comm_inter, ierr)
353
354	IF ( humidity ) THEN
355	CALL MPI_SEND( q(bdims(3,1):bdims(3,2)+2, &
356	bdims(2,1)-1:bdims(2,2)+1, &
357	bdims(1,1)-1:bdims(1,2)+1),&
358	n_cell_c, MPI_REAL, target_idex, &
359	116, comm_inter, ierr)
360	ENDIF
361
362	CALL MPI_SEND( e( bdims(3,1):bdims(3,2)+2, &
363	bdims(2,1)-1:bdims(2,2)+1, &
364	bdims(1,1)-1:bdims(1,2)+1),&
365	n_cell_c, MPI_REAL, target_idex, &
366	104, comm_inter, ierr)
367
368	CALL MPI_SEND(kh( bdims(3,1):bdims(3,2)+2, &
369	bdims(2,1)-1:bdims(2,2)+1, &
370	bdims(1,1)-1:bdims(1,2)+1),&
371	n_cell_c, MPI_REAL, target_idex, &
372	106, comm_inter, ierr)
373
374	CALL MPI_SEND(km( bdims(3,1):bdims(3,2)+2, &
375	bdims(2,1)-1:bdims(2,2)+1, &
376	bdims(1,1)-1:bdims(1,2)+1),&
377	n_cell_c, MPI_REAL, target_idex, &
378	107, comm_inter, ierr)
379
380	!-- Send Surface fluxes
381	IF ( use_surface_fluxes ) THEN
382
383	n_cell_c = (bdims(1,2)-bdims(1,1)+3) * &
384	(bdims(2,2)-bdims(2,1)+3)
385
386	!
387	!-- shf and z0 for CG / FG need to initialized in input file or user_code
388	!-- TODO
389	!-- initialization of usws, vsws, ts and us not vital to vnest FG
390	!-- variables are not compatible with the new surface layer module
391	!
392	! CALL MPI_SEND(surf_def_h(0)%usws( bdims(2,1)-1:bdims(2,2)+1, &
393	! bdims(1,1)-1:bdims(1,2)+1),&
394	! n_cell_c, MPI_REAL, target_idex, &
395	! 110, comm_inter, ierr )
396	!
397	! CALL MPI_SEND(surf_def_h(0)%vsws( bdims(2,1)-1:bdims(2,2)+1, &
398	! bdims(1,1)-1:bdims(1,2)+1),&
399	! n_cell_c, MPI_REAL, target_idex, &
400	! 111, comm_inter, ierr )
401	!
402	! CALL MPI_SEND(ts ( bdims(2,1)-1:bdims(2,2)+1, &
403	! bdims(1,1)-1:bdims(1,2)+1),&
404	! n_cell_c, MPI_REAL, target_idex, &
405	! 112, comm_inter, ierr )
406	!
407	! CALL MPI_SEND(us ( bdims(2,1)-1:bdims(2,2)+1, &
408	! bdims(1,1)-1:bdims(1,2)+1),&
409	! n_cell_c, MPI_REAL, target_idex, &
410	! 113, comm_inter, ierr )
411	!
412	ENDIF
413
414
415
416
417	end do
418	end do
419
420	ELSEIF ( coupling_mode == 'vnested_fine' ) THEN
421	!-- Receive data from coarse grid for initialization
422
423	offset(1) = pcoord(1) / ( pdims(1)/pdims_partner(1) )
424	offset(2) = pcoord(2) / ( pdims(2)/pdims_partner(2) )
425	map_coord(1) = offset(1)
426	map_coord(2) = offset(2)
427	target_idex = c_rnk_lst(map_coord(1),map_coord(2))
428
429	bdims (1,1) = nxl
430	bdims (1,2) = nxr
431	bdims (2,1) = nys
432	bdims (2,2) = nyn
433	bdims (3,1) = nzb
434	bdims (3,2) = nzt
435
436	CALL MPI_SEND( bdims, 6, MPI_INTEGER, target_idex, 10, &
437	comm_inter, ierr )
438
439	CALL MPI_RECV( bdims_rem, 6, MPI_INTEGER, target_idex, 9, &
440	comm_inter,status, ierr )
441
442	n_cell_c = (bdims_rem(1,2)-bdims_rem(1,1)+3) * &
443	(bdims_rem(2,2)-bdims_rem(2,1)+3) * &
444	(bdims_rem(3,2)-bdims_rem(3,1)+3)
445
446	ALLOCATE( work3d ( bdims_rem(3,1) :bdims_rem(3,2)+2, &
447	bdims_rem(2,1)-1:bdims_rem(2,2)+1, &
448	bdims_rem(1,1)-1:bdims_rem(1,2)+1))
449
450
451	CALL MPI_RECV( work3d,n_cell_c, MPI_REAL, target_idex, 101, &
452	comm_inter,status, ierr )
453	interpol3d => u
454	call interpolate_to_fine_u
455
456	CALL MPI_RECV( work3d,n_cell_c, MPI_REAL, target_idex, 102, &
457	comm_inter,status, ierr )
458	interpol3d => v
459	call interpolate_to_fine_v
460
461	CALL MPI_RECV( work3d,n_cell_c, MPI_REAL, target_idex, 103, &
462	comm_inter,status, ierr )
463	interpol3d => w
464	call interpolate_to_fine_w
465
466	CALL MPI_RECV( work3d,n_cell_c, MPI_REAL, target_idex, 105, &
467	comm_inter,status, ierr )
468	interpol3d => pt
469	call interpolate_to_fine_s
470
471	IF ( humidity ) THEN
472	CALL MPI_RECV( work3d,n_cell_c, MPI_REAL, target_idex, 116, &
473	comm_inter,status, ierr )
474	interpol3d => q
475	call interpolate_to_fine_s
476	ENDIF
477
478	CALL MPI_RECV( work3d,n_cell_c, MPI_REAL, target_idex, 104, &
479	comm_inter,status, ierr )
480	interpol3d => e
481	call interpolate_to_fine_s
482
483	!-- kh,km no target attribute, use of pointer not possible
484	CALL MPI_RECV( work3d,n_cell_c, MPI_REAL, target_idex, 106, &
485	comm_inter,status, ierr )
486	call interpolate_to_fine_kh
487
488	CALL MPI_RECV( work3d,n_cell_c, MPI_REAL, target_idex, 107, &
489	comm_inter,status, ierr )
490	call interpolate_to_fine_km
491
492	DEALLOCATE( work3d )
493	NULLIFY ( interpol3d )
494
495	!-- Recv Surface Fluxes
496	IF ( use_surface_fluxes ) THEN
497	n_cell_c = (bdims_rem(1,2)-bdims_rem(1,1)+3) * &
498	(bdims_rem(2,2)-bdims_rem(2,1)+3)
499
500	ALLOCATE( work2dusws ( bdims_rem(2,1)-1:bdims_rem(2,2)+1, &
501	bdims_rem(1,1)-1:bdims_rem(1,2)+1) )
502	ALLOCATE( work2dvsws ( bdims_rem(2,1)-1:bdims_rem(2,2)+1, &
503	bdims_rem(1,1)-1:bdims_rem(1,2)+1) )
504	ALLOCATE( work2dts ( bdims_rem(2,1)-1:bdims_rem(2,2)+1, &
505	bdims_rem(1,1)-1:bdims_rem(1,2)+1) )
506	ALLOCATE( work2dus ( bdims_rem(2,1)-1:bdims_rem(2,2)+1, &
507	bdims_rem(1,1)-1:bdims_rem(1,2)+1) )
508
509	!
510	!-- shf and z0 for CG / FG need to initialized in input file or user_code
511	!-- TODO
512	!-- initialization of usws, vsws, ts and us not vital to vnest FG
513	!-- variables are not compatible with the new surface layer module
514	!
515	! CALL MPI_RECV( work2dusws,n_cell_c, MPI_REAL, target_idex, 110, &
516	! comm_inter,status, ierr )
517	!
518	! CALL MPI_RECV( work2dvsws,n_cell_c, MPI_REAL, target_idex, 111, &
519	! comm_inter,status, ierr )
520	!
521	! CALL MPI_RECV( work2dts ,n_cell_c, MPI_REAL, target_idex, 112, &
522	! comm_inter,status, ierr )
523	!
524	! CALL MPI_RECV( work2dus ,n_cell_c, MPI_REAL, target_idex, 113, &
525	! comm_inter,status, ierr )
526	!
527	! CALL interpolate_to_fine_flux ( 108 )
528
529	DEALLOCATE( work2dusws )
530	DEALLOCATE( work2dvsws )
531	DEALLOCATE( work2dts )
532	DEALLOCATE( work2dus )
533	ENDIF
534
535	IF ( .NOT. constant_diffusion ) THEN
536	DO kkf = bdims(3,1)+1,bdims(3,2)+1
537	DO jjf = bdims(2,1),bdims(2,2)
538	DO iif = bdims(1,1),bdims(1,2)
539
540	IF ( e(kkf,jjf,iif) < 0.0 ) THEN
541	e(kkf,jjf,iif) = 1E-15_wp
542	END IF
543
544	END DO
545	END DO
546	END DO
547	ENDIF
548
549	w(nzt+1,:,:) = w(nzt,:,:)
550
551	CALL exchange_horiz( u, nbgp )
552	CALL exchange_horiz( v, nbgp )
553	CALL exchange_horiz( w, nbgp )
554	CALL exchange_horiz( pt, nbgp )
555	IF ( .NOT. constant_diffusion ) CALL exchange_horiz( e, nbgp )
556	IF ( humidity ) CALL exchange_horiz( q, nbgp )
557
558	!
559	!-- Velocity boundary conditions at the bottom boundary
560	IF ( ibc_uv_b == 0 ) THEN
561	u(nzb,:,:) = 0.0_wp
562	v(nzb,:,:) = 0.0_wp
563	ELSE
564	u(nzb,:,:) = u(nzb+1,:,:)
565	v(nzb,:,:) = v(nzb+1,:,:)
566	END IF
567
568
569	w(nzb,:,:) = 0.0_wp
570
571	!
572	!-- Temperature boundary conditions at the bottom boundary
573	IF ( ibc_pt_b /= 0 ) THEN
574	pt(nzb,:,:) = pt(nzb+1,:,:)
575	END IF
576
577	!
578	!-- Bottom boundary condition for the turbulent kinetic energy
579	!-- Generally a Neumann condition with de/dz=0 is assumed
580	IF ( .NOT. constant_diffusion ) THEN
581	e(nzb,:,:) = e(nzb+1,:,:)
582	END IF
583
584	!
585	!-- Bottom boundary condition for turbulent diffusion coefficients
586	km(nzb,:,:) = km(nzb+1,:,:)
587	kh(nzb,:,:) = kh(nzb+1,:,:)
588
589	!diffusivities required
590	IF ( .NOT. humidity ) THEN
591	CALL tcm_diffusivities( pt, pt_reference )
592	ELSE
593	CALL tcm_diffusivities( vpt, pt_reference )
594	ENDIF
595
596
597	!
598	!-- Reset Fine Grid top Boundary Condition
599	!-- At the top of the FG, the scalars always follow Dirichlet condition
600
601	ibc_pt_t = 0
602
603	!-- Initialize old time levels
604	pt_p = pt; u_p = u; v_p = v; w_p = w
605	IF ( .NOT. constant_diffusion ) e_p = e
606	IF ( humidity ) THEN
607	ibc_q_t = 0
608	q_p = q
609	ENDIF
610
611	ENDIF
612
613
614	if (myid==0) print , '* Fine Initalized ** simulated_time:', simulated_time
615
616	CONTAINS
617
618	SUBROUTINE interpolate_to_fine_w
619
620	USE arrays_3d
621	USE control_parameters
622	USE grid_variables
623	USE indices
624	USE pegrid
625
626
627	IMPLICIT NONE
628
629	INTEGER(iwp) :: i
630	INTEGER(iwp) :: j
631	INTEGER(iwp) :: k
632	INTEGER(iwp) :: iif
633	INTEGER(iwp) :: jjf
634	INTEGER(iwp) :: kkf
635	INTEGER(iwp) :: nzbottom
636	INTEGER(iwp) :: nztop
637	INTEGER(iwp) :: bottomx
638	INTEGER(iwp) :: bottomy
639	INTEGER(iwp) :: bottomz
640	INTEGER(iwp) :: topx
641	INTEGER(iwp) :: topy
642	INTEGER(iwp) :: topz
643	REAL(wp) :: eps
644	REAL(wp) :: alpha
645	REAL(wp) :: eminus
646	REAL(wp) :: edot
647	REAL(wp) :: eplus
648	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: wprs
649	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: wprf
650
651
652	nzbottom = bdims_rem (3,1)
653	nztop = bdims_rem (3,2)
654
655	ALLOCATE( wprf(nzbottom:nztop, bdims_rem(2,1)-1: bdims_rem(2,2)+1,nxl:nxr) )
656	ALLOCATE( wprs(nzbottom:nztop,nys:nyn,nxl:nxr) )
657
658
659	!
660	!-- Initialisation of the velocity component w
661	!
662	!-- Interpolation in x-direction
663	DO k = nzbottom, nztop
664	DO j = bdims_rem(2,1)-1, bdims_rem(2,2)+1
665	DO i = bdims_rem(1,1),bdims_rem(1,2)
666
667	bottomx = (nxf+1)/(nxc+1) * i
668	topx = (nxf+1)/(nxc+1) * (i+1) - 1
669
670	DO iif = bottomx, topx
671
672	eps = ( iif * dxf + 0.5 * dxf - i * dxc - 0.5 * dxc ) / dxc
673	alpha = ( ( dxf / dxc )**2.0 - 1.0 ) / 24.0
674	eminus = eps * ( eps - 1.0 ) / 2.0 + alpha
675	edot = ( 1.0 - eps*2.0 ) - 2.0 alpha
676	eplus = eps * ( eps + 1.0 ) / 2.0 + alpha
677
678	wprf(k,j,iif) = eminus * work3d(k,j,i-1) &
679	+ edot * work3d(k,j,i) &
680	+ eplus * work3d(k,j,i+1)
681	END DO
682
683	END DO
684	END DO
685	END DO
686
687	!
688	!-- Interpolation in y-direction (quadratic, Clark and Farley)
689	DO k = nzbottom, nztop
690	DO j = bdims_rem(2,1), bdims_rem(2,2)
691
692	bottomy = (nyf+1)/(nyc+1) * j
693	topy = (nyf+1)/(nyc+1) * (j+1) - 1
694
695	DO iif = nxl, nxr
696	DO jjf = bottomy, topy
697
698	eps = ( jjf * dyf + 0.5 * dyf - j * dyc - 0.5 * dyc ) / dyc
699	alpha = ( ( dyf / dyc )**2.0 - 1.0 ) / 24.0
700	eminus = eps * ( eps - 1.0 ) / 2.0 + alpha
701	edot = ( 1.0 - eps*2.0 ) - 2.0 alpha
702	eplus = eps * ( eps + 1.0 ) / 2.0 + alpha
703
704	wprs(k,jjf,iif) = eminus * wprf(k,j-1,iif) &
705	+ edot * wprf(k,j,iif) &
706	+ eplus * wprf(k,j+1,iif)
707
708	END DO
709	END DO
710
711	END DO
712	END DO
713
714	!
715	!-- Interpolation in z-direction (linear)
716
717	DO k = nzbottom, nztop-1
718
719	bottomz = (dzc/dzf) * k
720	topz = (dzc/dzf) * (k+1) - 1
721
722	DO jjf = nys, nyn
723	DO iif = nxl, nxr
724	DO kkf = bottomz, topz
725
726	w(kkf,jjf,iif) = wprs(k,jjf,iif) + ( zwf(kkf) - zwc(k) ) &
727	* ( wprs(k+1,jjf,iif) - wprs(k,jjf,iif) ) / dzc
728
729	END DO
730	END DO
731	END DO
732
733	END DO
734
735	DO jjf = nys, nyn
736	DO iif = nxl, nxr
737
738	w(nzt,jjf,iif) = wprs(nztop,jjf,iif)
739
740	END DO
741	END DO
742	!
743	! w(nzb:nzt+1,nys:nyn,nxl:nxr) = 0
744
745	DEALLOCATE( wprf, wprs )
746
747	END SUBROUTINE interpolate_to_fine_w
748
749	SUBROUTINE interpolate_to_fine_u
750
751
752	USE arrays_3d
753	USE control_parameters
754	USE grid_variables
755	USE indices
756	USE pegrid
757
758
759	IMPLICIT NONE
760
761	INTEGER(iwp) :: i
762	INTEGER(iwp) :: j
763	INTEGER(iwp) :: k
764	INTEGER(iwp) :: iif
765	INTEGER(iwp) :: jjf
766	INTEGER(iwp) :: kkf
767	INTEGER(iwp) :: nzbottom
768	INTEGER(iwp) :: nztop
769	INTEGER(iwp) :: bottomx
770	INTEGER(iwp) :: bottomy
771	INTEGER(iwp) :: bottomz
772	INTEGER(iwp) :: topx
773	INTEGER(iwp) :: topy
774	INTEGER(iwp) :: topz
775	REAL(wp) :: eps
776	REAL(wp) :: alpha
777	REAL(wp) :: eminus
778	REAL(wp) :: edot
779	REAL(wp) :: eplus
780	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: uprf
781	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: uprs
782
783
784
785	nzbottom = bdims_rem (3,1)
786	nztop = bdims_rem (3,2)
787
788	ALLOCATE( uprf(nzbottom:nztop+2,nys:nyn,bdims_rem(1,1)-1:bdims_rem(1,2)+1) )
789	ALLOCATE( uprs(nzb+1:nzt+1,nys:nyn,bdims_rem(1,1)-1:bdims_rem(1,2)+1) )
790
791	!
792	!-- Initialisation of the velocity component uf
793
794	!
795	!-- Interpolation in y-direction (quadratic, Clark and Farley)
796
797	DO k = nzbottom, nztop+2
798	DO j = bdims_rem(2,1), bdims_rem(2,2)
799
800	bottomy = (nyf+1)/(nyc+1) * j
801	topy = (nyf+1)/(nyc+1) * (j+1) - 1
802
803	DO i = bdims_rem(1,1)-1, bdims_rem(1,2)+1
804	DO jjf = bottomy, topy
805
806	eps = ( jjf * dyf + 0.5 * dyf - j * dyc - 0.5 * dyc ) / dyc
807	alpha = ( ( dyf / dyc )**2.0 - 1.0 ) / 24.0
808	eminus = eps * ( eps - 1.0 ) / 2.0 + alpha
809	edot = ( 1.0 - eps*2.0 ) - 2.0 alpha
810	eplus = eps * ( eps + 1.0 ) / 2.0 + alpha
811
812	uprf(k,jjf,i) = eminus * work3d(k,j-1,i) &
813	+ edot * work3d(k,j,i) &
814	+ eplus * work3d(k,j+1,i)
815
816	END DO
817	END DO
818
819	END DO
820	END DO
821
822	!
823	!-- Interpolation in z-direction (quadratic, Clark and Farley)
824
825	DO k = nzbottom+1, nztop
826
827	bottomz = (dzc/dzf) * (k-1) + 1
828	topz = (dzc/dzf) * k
829
830	DO jjf = nys, nyn
831	DO i = bdims_rem(1,1)-1, bdims_rem(1,2)+1
832	DO kkf = bottomz, topz
833
834	eps = ( zuf(kkf) - zuc(k) ) / dzc
835	alpha = ( ( dzf / dzc )**2.0 - 1.0 ) / 24.0
836	eminus = eps * ( eps - 1.0 ) / 2.0 + alpha
837	edot = ( 1.0 - eps*2.0 ) - 2.0 alpha
838	eplus = eps * ( eps + 1.0 ) / 2.0 + alpha
839
840	uprs(kkf,jjf,i) = eminus * uprf(k-1,jjf,i) &
841	+ edot * uprf(k,jjf,i) &
842	+ eplus * uprf(k+1,jjf,i)
843
844	END DO
845	END DO
846	END DO
847
848	END DO
849
850	DO jjf = nys, nyn
851	DO i = bdims_rem(1,1)-1, bdims_rem(1,2)+1
852
853	eps = ( zuf(nzt+1) - zuc(nztop+1) ) / dzc
854	alpha = ( ( dzf / dzc )**2.0 - 1.0 ) / 24.0
855	eminus = eps * ( eps - 1.0 ) / 2.0 + alpha
856	edot = ( 1.0 - eps*2.0 ) - 2.0 alpha
857	eplus = eps * ( eps + 1.0 ) / 2.0 + alpha
858
859	uprs(nzt+1,jjf,i) = eminus * uprf(nztop,jjf,i) &
860	+ edot * uprf(nztop+1,jjf,i) &
861	+ eplus * uprf(nztop+2,jjf,i)
862
863	END DO
864	END DO
865
866	!
867	!-- Interpolation in x-direction (linear)
868
869	DO kkf = nzb+1, nzt+1
870	DO jjf = nys, nyn
871	DO i = bdims_rem(1,1), bdims_rem(1,2)
872
873	bottomx = (nxf+1)/(nxc+1) * i
874	topx = (nxf+1)/(nxc+1) * (i+1) - 1
875
876	DO iif = bottomx, topx
877	u(kkf,jjf,iif) = uprs(kkf,jjf,i) + ( iif * dxf - i * dxc ) &
878	* ( uprs(kkf,jjf,i+1) - uprs(kkf,jjf,i) ) / dxc
879	END DO
880
881	END DO
882	END DO
883	END DO
884	!
885	!-- Determination of uf at the bottom boundary
886
887
888
889	DEALLOCATE( uprf, uprs )
890
891	END SUBROUTINE interpolate_to_fine_u
892
893
894	SUBROUTINE interpolate_to_fine_v
895
896
897	USE arrays_3d
898	USE control_parameters
899	USE grid_variables
900	USE indices
901	USE pegrid
902
903
904	IMPLICIT NONE
905
906	INTEGER(iwp) :: i
907	INTEGER(iwp) :: j
908	INTEGER(iwp) :: k
909	INTEGER(iwp) :: iif
910	INTEGER(iwp) :: jjf
911	INTEGER(iwp) :: kkf
912	INTEGER(iwp) :: nzbottom
913	INTEGER(iwp) :: nztop
914	INTEGER(iwp) :: bottomx
915	INTEGER(iwp) :: bottomy
916	INTEGER(iwp) :: bottomz
917	INTEGER(iwp) :: topx
918	INTEGER(iwp) :: topy
919	INTEGER(iwp) :: topz
920	REAL(wp) :: eps
921	REAL(wp) :: alpha
922	REAL(wp) :: eminus
923	REAL(wp) :: edot
924	REAL(wp) :: eplus
925	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: vprs
926	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: vprf
927
928
929	nzbottom = bdims_rem (3,1)
930	nztop = bdims_rem (3,2)
931
932	ALLOCATE( vprf(nzbottom:nztop+2,bdims_rem(2,1)-1:bdims_rem(2,2)+1,nxl:nxr) )
933	ALLOCATE( vprs(nzb+1:nzt+1, bdims_rem(2,1)-1:bdims_rem(2,2)+1,nxl:nxr) )
934	!
935	!-- Initialisation of the velocity component vf
936
937	!
938	!-- Interpolation in x-direction (quadratic, Clark and Farley)
939
940	DO k = nzbottom, nztop+2
941	DO j = bdims_rem(2,1)-1, bdims_rem(2,2)+1
942	DO i = bdims_rem(1,1), bdims_rem(1,2)
943
944	bottomx = (nxf+1)/(nxc+1) * i
945	topx = (nxf+1)/(nxc+1) * (i+1) - 1
946
947	DO iif = bottomx, topx
948
949	eps = ( iif * dxf + 0.5 * dxf - i * dxc - 0.5 * dxc ) / dxc
950	alpha = ( ( dxf / dxc )**2.0 - 1.0 ) / 24.0
951	eminus = eps * ( eps - 1.0 ) / 2.0 + alpha
952	edot = ( 1.0 - eps*2.0 ) - 2.0 alpha
953	eplus = eps * ( eps + 1.0 ) / 2.0 + alpha
954
955	vprf(k,j,iif) = eminus * work3d(k,j,i-1) &
956	+ edot * work3d(k,j,i) &
957	+ eplus * work3d(k,j,i+1)
958
959	END DO
960
961	END DO
962	END DO
963	END DO
964
965	!
966	!-- Interpolation in z-direction (quadratic, Clark and Farley)
967
968	DO k = nzbottom+1, nztop
969
970	bottomz = (dzc/dzf) * (k-1) + 1
971	topz = (dzc/dzf) * k
972
973	DO j = bdims_rem(2,1)-1, bdims_rem(2,2)+1
974	DO iif = nxl, nxr
975	DO kkf = bottomz, topz
976
977	eps = ( zuf(kkf) - zuc(k) ) / dzc
978	alpha = ( ( dzf / dzc )**2.0 - 1.0 ) / 24.0
979	eminus = eps * ( eps - 1.0 ) / 2.0 + alpha
980	edot = ( 1.0 - eps*2.0 ) - 2.0 alpha
981	eplus = eps * ( eps + 1.0 ) / 2.0 + alpha
982
983	vprs(kkf,j,iif) = eminus * vprf(k-1,j,iif) &
984	+ edot * vprf(k,j,iif) &
985	+ eplus * vprf(k+1,j,iif)
986
987	END DO
988	END DO
989	END DO
990
991	END DO
992
993	DO j = bdims_rem(2,1)-1, bdims_rem(2,2)+1
994	DO iif = nxl, nxr
995
996	eps = ( zuf(nzt+1) - zuc(nztop+1) ) / dzc
997	alpha = ( ( dzf / dzc )**2.0 - 1.0 ) / 24.0
998	eminus = eps * ( eps - 1.0 ) / 2.0 + alpha
999	edot = ( 1.0 - eps*2.0 ) - 2.0 alpha
1000	eplus = eps * ( eps + 1.0 ) / 2.0 + alpha
1001
1002	vprs(nzt+1,j,iif) = eminus * vprf(nztop,j,iif) &
1003	+ edot * vprf(nztop+1,j,iif) &
1004	+ eplus * vprf(nztop+2,j,iif)
1005
1006	END DO
1007	END DO
1008
1009	!
1010	!-- Interpolation in y-direction (linear)
1011
1012	DO kkf = nzb+1, nzt+1
1013	DO j = bdims_rem(2,1), bdims_rem(2,2)
1014
1015	bottomy = (nyf+1)/(nyc+1) * j
1016	topy = (nyf+1)/(nyc+1) * (j+1) - 1
1017
1018	DO iif = nxl, nxr
1019	DO jjf = bottomy, topy
1020	v (kkf,jjf,iif) = vprs(kkf,j,iif) + ( jjf * dyf - j * dyc ) &
1021	* ( vprs(kkf,j+1,iif) - vprs(kkf,j,iif) ) / dyc
1022	END DO
1023	END DO
1024
1025	END DO
1026	END DO
1027
1028	!
1029	!-- Determination of vf at the bottom boundary
1030
1031
1032	DEALLOCATE( vprf, vprs )
1033
1034	END SUBROUTINE interpolate_to_fine_v
1035
1036
1037	SUBROUTINE interpolate_to_fine_s
1038
1039
1040	USE arrays_3d
1041	USE control_parameters
1042	USE grid_variables
1043	USE indices
1044	USE pegrid
1045
1046
1047	IMPLICIT NONE
1048
1049	INTEGER(iwp) :: i
1050	INTEGER(iwp) :: j
1051	INTEGER(iwp) :: k
1052	INTEGER(iwp) :: iif
1053	INTEGER(iwp) :: jjf
1054	INTEGER(iwp) :: kkf
1055	INTEGER(iwp) :: nzbottom
1056	INTEGER(iwp) :: nztop
1057	INTEGER(iwp) :: bottomx
1058	INTEGER(iwp) :: bottomy
1059	INTEGER(iwp) :: bottomz
1060	INTEGER(iwp) :: topx
1061	INTEGER(iwp) :: topy
1062	INTEGER(iwp) :: topz
1063	REAL(wp) :: eps
1064	REAL(wp) :: alpha
1065	REAL(wp) :: eminus
1066	REAL(wp) :: edot
1067	REAL(wp) :: eplus
1068	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ptprs
1069	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ptprf
1070
1071
1072	nzbottom = bdims_rem (3,1)
1073	nztop = bdims_rem (3,2)
1074
1075	ALLOCATE( ptprf(nzbottom:nztop+2,bdims_rem(2,1)-1:bdims_rem(2,2)+1,nxl:nxr) )
1076	ALLOCATE( ptprs(nzbottom:nztop+2,nys:nyn,nxl:nxr) )
1077
1078	!
1079	!-- Initialisation of scalar variables
1080
1081	!
1082	!-- Interpolation in x-direction (quadratic, Clark and Farley)
1083
1084	DO k = nzbottom, nztop+2
1085	DO j = bdims_rem(2,1)-1, bdims_rem(2,2)+1
1086	DO i = bdims_rem(1,1), bdims_rem(1,2)
1087
1088	bottomx = (nxf+1)/(nxc+1) * i
1089	topx = (nxf+1)/(nxc+1) * (i+1) - 1
1090
1091	DO iif = bottomx, topx
1092
1093	eps = ( iif * dxf + 0.5 * dxf - i * dxc - 0.5 * dxc ) / dxc
1094	alpha = ( ( dxf / dxc )**2.0 - 1.0 ) / 24.0
1095	eminus = eps * ( eps - 1.0 ) / 2.0 + alpha
1096	edot = ( 1.0 - eps*2.0 ) - 2.0 alpha
1097	eplus = eps * ( eps + 1.0 ) / 2.0 + alpha
1098
1099	ptprf(k,j,iif) = eminus * work3d(k,j,i-1) &
1100	+ edot * work3d(k,j,i) &
1101	+ eplus * work3d(k,j,i+1)
1102	END DO
1103
1104	END DO
1105	END DO
1106	END DO
1107
1108	!
1109	!-- Interpolation in y-direction (quadratic, Clark and Farley)
1110
1111	DO k = nzbottom, nztop+2
1112	DO j = bdims_rem(2,1), bdims_rem(2,2)
1113
1114	bottomy = (nyf+1)/(nyc+1) * j
1115	topy = (nyf+1)/(nyc+1) * (j+1) - 1
1116
1117	DO iif = nxl, nxr
1118	DO jjf = bottomy, topy
1119
1120	eps = ( jjf * dyf + 0.5 * dyf - j * dyc - 0.5 * dyc ) / dyc
1121	alpha = ( ( dyf / dyc )**2.0 - 1.0 ) / 24.0
1122	eminus = eps * ( eps - 1.0 ) / 2.0 + alpha
1123	edot = ( 1.0 - eps*2.0 ) - 2.0 alpha
1124	eplus = eps * ( eps + 1.0 ) / 2.0 + alpha
1125
1126	ptprs(k,jjf,iif) = eminus * ptprf(k,j-1,iif) &
1127	+ edot * ptprf(k,j,iif) &
1128	+ eplus * ptprf(k,j+1,iif)
1129
1130	END DO
1131	END DO
1132
1133	END DO
1134	END DO
1135
1136	!
1137	!-- Interpolation in z-direction (quadratic, Clark and Farley)
1138
1139	DO k = nzbottom+1, nztop
1140
1141	bottomz = (dzc/dzf) * (k-1) + 1
1142	topz = (dzc/dzf) * k
1143
1144	DO jjf = nys, nyn
1145	DO iif = nxl, nxr
1146	DO kkf = bottomz, topz
1147
1148	eps = ( zuf(kkf) - zuc(k) ) / dzc
1149	alpha = ( ( dzf / dzc )**2.0 - 1.0 ) / 24.0
1150	eminus = eps * ( eps - 1.0 ) / 2.0 + alpha
1151	edot = ( 1.0 - eps*2.0 ) - 2.0 alpha
1152	eplus = eps * ( eps + 1.0 ) / 2.0 + alpha
1153
1154	interpol3d(kkf,jjf,iif) = eminus * ptprs(k-1,jjf,iif) &
1155	+ edot * ptprs(k,jjf,iif) &
1156	+ eplus * ptprs(k+1,jjf,iif)
1157
1158	END DO
1159	END DO
1160	END DO
1161
1162	END DO
1163
1164	DO jjf = nys, nyn
1165	DO iif = nxl, nxr
1166
1167	eps = ( zuf(nzt+1) - zuc(nztop+1) ) / dzc
1168	alpha = ( ( dzf / dzc )**2.0 - 1.0 ) / 24.0
1169	eminus = eps * ( eps - 1.0 ) / 2.0 + alpha
1170	edot = ( 1.0 - eps*2.0 ) - 2.0 alpha
1171	eplus = eps * ( eps + 1.0 ) / 2.0 + alpha
1172
1173	interpol3d(nzt+1,jjf,iif) = eminus * ptprs(nztop,jjf,iif) &
1174	+ edot * ptprs(nztop+1,jjf,iif) &
1175	+ eplus * ptprs(nztop+2,jjf,iif)
1176
1177	END DO
1178	END DO
1179
1180
1181	DEALLOCATE( ptprf, ptprs )
1182
1183	END SUBROUTINE interpolate_to_fine_s
1184
1185
1186	SUBROUTINE interpolate_to_fine_kh
1187
1188
1189	USE arrays_3d
1190	USE control_parameters
1191	USE grid_variables
1192	USE indices
1193	USE pegrid
1194
1195
1196	IMPLICIT NONE
1197
1198	INTEGER(iwp) :: i
1199	INTEGER(iwp) :: j
1200	INTEGER(iwp) :: k
1201	INTEGER(iwp) :: iif
1202	INTEGER(iwp) :: jjf
1203	INTEGER(iwp) :: kkf
1204	INTEGER(iwp) :: nzbottom
1205	INTEGER(iwp) :: nztop
1206	INTEGER(iwp) :: bottomx
1207	INTEGER(iwp) :: bottomy
1208	INTEGER(iwp) :: bottomz
1209	INTEGER(iwp) :: topx
1210	INTEGER(iwp) :: topy
1211	INTEGER(iwp) :: topz
1212	REAL(wp) :: eps
1213	REAL(wp) :: alpha
1214	REAL(wp) :: eminus
1215	REAL(wp) :: edot
1216	REAL(wp) :: eplus
1217	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ptprs
1218	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ptprf
1219
1220
1221	nzbottom = bdims_rem (3,1)
1222	nztop = bdims_rem (3,2)
1223	! nztop = blk_dim_rem (3,2)+1
1224
1225
1226	ALLOCATE( ptprf(nzbottom:nztop+2,bdims_rem(2,1)-1:bdims_rem(2,2)+1,nxl:nxr) )
1227	ALLOCATE( ptprs(nzbottom:nztop+2,nys:nyn,nxl:nxr) )
1228
1229
1230	!
1231	!-- Initialisation of scalar variables
1232
1233	!
1234	!-- Interpolation in x-direction (quadratic, Clark and Farley)
1235
1236	DO k = nzbottom, nztop+2
1237	DO j = bdims_rem(2,1)-1, bdims_rem(2,2)+1
1238	DO i = bdims_rem(1,1), bdims_rem(1,2)
1239
1240	bottomx = (nxf+1)/(nxc+1) * i
1241	topx = (nxf+1)/(nxc+1) * (i+1) - 1
1242
1243	DO iif = bottomx, topx
1244
1245	eps = ( iif * dxf + 0.5 * dxf - i * dxc - 0.5 * dxc ) / dxc
1246	alpha = ( ( dxf / dxc )**2.0 - 1.0 ) / 24.0
1247	eminus = eps * ( eps - 1.0 ) / 2.0 + alpha
1248	edot = ( 1.0 - eps*2.0 ) - 2.0 alpha
1249	eplus = eps * ( eps + 1.0 ) / 2.0 + alpha
1250
1251	ptprf(k,j,iif) = eminus * work3d(k,j,i-1) &
1252	+ edot * work3d(k,j,i) &
1253	+ eplus * work3d(k,j,i+1)
1254	END DO
1255
1256	END DO
1257	END DO
1258	END DO
1259
1260	!
1261	!-- Interpolation in y-direction (quadratic, Clark and Farley)
1262
1263	DO k = nzbottom, nztop+2
1264	DO j = bdims_rem(2,1), bdims_rem(2,2)
1265
1266	bottomy = (nyf+1)/(nyc+1) * j
1267	topy = (nyf+1)/(nyc+1) * (j+1) - 1
1268
1269	DO iif = nxl, nxr
1270	DO jjf = bottomy, topy
1271
1272	eps = ( jjf * dyf + 0.5 * dyf - j * dyc - 0.5 * dyc ) / dyc
1273	alpha = ( ( dyf / dyc )**2.0 - 1.0 ) / 24.0
1274	eminus = eps * ( eps - 1.0 ) / 2.0 + alpha
1275	edot = ( 1.0 - eps*2.0 ) - 2.0 alpha
1276	eplus = eps * ( eps + 1.0 ) / 2.0 + alpha
1277
1278	ptprs(k,jjf,iif) = eminus * ptprf(k,j-1,iif) &
1279	+ edot * ptprf(k,j,iif) &
1280	+ eplus * ptprf(k,j+1,iif)
1281
1282	END DO
1283	END DO
1284
1285	END DO
1286	END DO
1287
1288	!
1289	!-- Interpolation in z-direction (quadratic, Clark and Farley)
1290
1291	DO k = nzbottom+1, nztop
1292
1293	bottomz = (dzc/dzf) * (k-1) + 1
1294	topz = (dzc/dzf) * k
1295
1296	DO jjf = nys, nyn
1297	DO iif = nxl, nxr
1298	DO kkf = bottomz, topz
1299
1300	eps = ( zuf(kkf) - zuc(k) ) / dzc
1301	alpha = ( ( dzf / dzc )**2.0 - 1.0 ) / 24.0
1302	eminus = eps * ( eps - 1.0 ) / 2.0 + alpha
1303	edot = ( 1.0 - eps*2.0 ) - 2.0 alpha
1304	eplus = eps * ( eps + 1.0 ) / 2.0 + alpha
1305
1306	kh(kkf,jjf,iif) = eminus * ptprs(k-1,jjf,iif) &
1307	+ edot * ptprs(k,jjf,iif) &
1308	+ eplus * ptprs(k+1,jjf,iif)
1309
1310	END DO
1311	END DO
1312	END DO
1313
1314	END DO
1315
1316	DO jjf = nys, nyn
1317	DO iif = nxl, nxr
1318
1319	eps = ( zuf(nzt+1) - zuc(nztop+1) ) / dzc
1320	alpha = ( ( dzf / dzc )**2.0 - 1.0 ) / 24.0
1321	eminus = eps * ( eps - 1.0 ) / 2.0 + alpha
1322	edot = ( 1.0 - eps*2.0 ) - 2.0 alpha
1323	eplus = eps * ( eps + 1.0 ) / 2.0 + alpha
1324
1325	kh(nzt+1,jjf,iif) = eminus * ptprs(nztop,jjf,iif) &
1326	+ edot * ptprs(nztop+1,jjf,iif) &
1327	+ eplus * ptprs(nztop+2,jjf,iif)
1328
1329	END DO
1330	END DO
1331
1332
1333	DEALLOCATE( ptprf, ptprs )
1334
1335	END SUBROUTINE interpolate_to_fine_kh
1336
1337	SUBROUTINE interpolate_to_fine_km
1338
1339
1340	USE arrays_3d
1341	USE control_parameters
1342	USE grid_variables
1343	USE indices
1344	USE pegrid
1345
1346
1347	IMPLICIT NONE
1348
1349	INTEGER(iwp) :: i
1350	INTEGER(iwp) :: j
1351	INTEGER(iwp) :: k
1352	INTEGER(iwp) :: iif
1353	INTEGER(iwp) :: jjf
1354	INTEGER(iwp) :: kkf
1355	INTEGER(iwp) :: nzbottom
1356	INTEGER(iwp) :: nztop
1357	INTEGER(iwp) :: bottomx
1358	INTEGER(iwp) :: bottomy
1359	INTEGER(iwp) :: bottomz
1360	INTEGER(iwp) :: topx
1361	INTEGER(iwp) :: topy
1362	INTEGER(iwp) :: topz
1363	REAL(wp) :: eps
1364	REAL(wp) :: alpha
1365	REAL(wp) :: eminus
1366	REAL(wp) :: edot
1367	REAL(wp) :: eplus
1368	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ptprs
1369	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ptprf
1370
1371
1372	nzbottom = bdims_rem (3,1)
1373	nztop = bdims_rem (3,2)
1374	! nztop = blk_dim_rem (3,2)+1
1375
1376
1377	ALLOCATE( ptprf(nzbottom:nztop+2,bdims_rem(2,1)-1:bdims_rem(2,2)+1,nxl:nxr) )
1378	ALLOCATE( ptprs(nzbottom:nztop+2,nys:nyn,nxl:nxr) )
1379
1380
1381	!
1382	!-- Initialisation of scalar variables
1383
1384	!
1385	!-- Interpolation in x-direction (quadratic, Clark and Farley)
1386
1387	DO k = nzbottom, nztop+2
1388	DO j = bdims_rem(2,1)-1, bdims_rem(2,2)+1
1389	DO i = bdims_rem(1,1), bdims_rem(1,2)
1390
1391	bottomx = (nxf+1)/(nxc+1) * i
1392	topx = (nxf+1)/(nxc+1) * (i+1) - 1
1393
1394	DO iif = bottomx, topx
1395
1396	eps = ( iif * dxf + 0.5 * dxf - i * dxc - 0.5 * dxc ) / dxc
1397	alpha = ( ( dxf / dxc )**2.0 - 1.0 ) / 24.0
1398	eminus = eps * ( eps - 1.0 ) / 2.0 + alpha
1399	edot = ( 1.0 - eps*2.0 ) - 2.0 alpha
1400	eplus = eps * ( eps + 1.0 ) / 2.0 + alpha
1401
1402	ptprf(k,j,iif) = eminus * work3d(k,j,i-1) &
1403	+ edot * work3d(k,j,i) &
1404	+ eplus * work3d(k,j,i+1)
1405	END DO
1406
1407	END DO
1408	END DO
1409	END DO
1410
1411	!
1412	!-- Interpolation in y-direction (quadratic, Clark and Farley)
1413
1414	DO k = nzbottom, nztop+2
1415	DO j = bdims_rem(2,1), bdims_rem(2,2)
1416
1417	bottomy = (nyf+1)/(nyc+1) * j
1418	topy = (nyf+1)/(nyc+1) * (j+1) - 1
1419
1420	DO iif = nxl, nxr
1421	DO jjf = bottomy, topy
1422
1423	eps = ( jjf * dyf + 0.5 * dyf - j * dyc - 0.5 * dyc ) / dyc
1424	alpha = ( ( dyf / dyc )**2.0 - 1.0 ) / 24.0
1425	eminus = eps * ( eps - 1.0 ) / 2.0 + alpha
1426	edot = ( 1.0 - eps*2.0 ) - 2.0 alpha
1427	eplus = eps * ( eps + 1.0 ) / 2.0 + alpha
1428
1429	ptprs(k,jjf,iif) = eminus * ptprf(k,j-1,iif) &
1430	+ edot * ptprf(k,j,iif) &
1431	+ eplus * ptprf(k,j+1,iif)
1432
1433	END DO
1434	END DO
1435
1436	END DO
1437	END DO
1438
1439	!
1440	!-- Interpolation in z-direction (quadratic, Clark and Farley)
1441
1442	DO k = nzbottom+1, nztop
1443
1444	bottomz = (dzc/dzf) * (k-1) + 1
1445	topz = (dzc/dzf) * k
1446
1447	DO jjf = nys, nyn
1448	DO iif = nxl, nxr
1449	DO kkf = bottomz, topz
1450
1451	eps = ( zuf(kkf) - zuc(k) ) / dzc
1452	alpha = ( ( dzf / dzc )**2.0 - 1.0 ) / 24.0
1453	eminus = eps * ( eps - 1.0 ) / 2.0 + alpha
1454	edot = ( 1.0 - eps*2.0 ) - 2.0 alpha
1455	eplus = eps * ( eps + 1.0 ) / 2.0 + alpha
1456
1457	km(kkf,jjf,iif) = eminus * ptprs(k-1,jjf,iif) &
1458	+ edot * ptprs(k,jjf,iif) &
1459	+ eplus * ptprs(k+1,jjf,iif)
1460
1461	END DO
1462	END DO
1463	END DO
1464
1465	END DO
1466
1467	DO jjf = nys, nyn
1468	DO iif = nxl, nxr
1469
1470	eps = ( zuf(nzt+1) - zuc(nztop+1) ) / dzc
1471	alpha = ( ( dzf / dzc )**2.0 - 1.0 ) / 24.0
1472	eminus = eps * ( eps - 1.0 ) / 2.0 + alpha
1473	edot = ( 1.0 - eps*2.0 ) - 2.0 alpha
1474	eplus = eps * ( eps + 1.0 ) / 2.0 + alpha
1475
1476	km(nzt+1,jjf,iif) = eminus * ptprs(nztop,jjf,iif) &
1477	+ edot * ptprs(nztop+1,jjf,iif) &
1478	+ eplus * ptprs(nztop+2,jjf,iif)
1479
1480	END DO
1481	END DO
1482
1483
1484	DEALLOCATE( ptprf, ptprs )
1485
1486	END SUBROUTINE interpolate_to_fine_km
1487
1488
1489
1490
1491	! SUBROUTINE interpolate_to_fine_flux
1492	!
1493	!
1494	! USE arrays_3d
1495	! USE control_parameters
1496	! USE grid_variables
1497	! USE indices
1498	! USE pegrid
1499	!
1500	!
1501	! IMPLICIT NONE
1502	!
1503	! INTEGER(iwp) :: i
1504	! INTEGER(iwp) :: j
1505	! INTEGER(iwp) :: iif
1506	! INTEGER(iwp) :: jjf
1507	! INTEGER(iwp) :: bottomx
1508	! INTEGER(iwp) :: bottomy
1509	! INTEGER(iwp) :: topx
1510	! INTEGER(iwp) :: topy
1511	! REAL(wp) :: eps
1512	! REAL(wp) :: alpha
1513	! REAL(wp) :: eminus
1514	! REAL(wp) :: edot
1515	! REAL(wp) :: eplus
1516	! REAL(wp), DIMENSION(:,:), ALLOCATABLE :: uswspr
1517	! REAL(wp), DIMENSION(:,:), ALLOCATABLE :: vswspr
1518	! REAL(wp), DIMENSION(:,:), ALLOCATABLE :: tspr
1519	! REAL(wp), DIMENSION(:,:), ALLOCATABLE :: uspr
1520	!
1521	! ALLOCATE( uswspr(bdims_rem(2,1)-1:bdims_rem(2,2)+1,nxl:nxr) )
1522	! ALLOCATE( vswspr(bdims_rem(2,1)-1:bdims_rem(2,2)+1,nxl:nxr) )
1523	! ALLOCATE( tspr (bdims_rem(2,1)-1:bdims_rem(2,2)+1,nxl:nxr) )
1524	! ALLOCATE( uspr (bdims_rem(2,1)-1:bdims_rem(2,2)+1,nxl:nxr) )
1525	!
1526	! !
1527	! !-- Initialisation of scalar variables (2D)
1528	!
1529	! !
1530	! !-- Interpolation in x-direction (quadratic, Clark and Farley)
1531	!
1532	! DO j = bdims_rem(2,1)-1, bdims_rem(2,2)+1
1533	! DO i = bdims_rem(1,1), bdims_rem(1,2)
1534	!
1535	! bottomx = (nxf+1)/(nxc+1) * i
1536	! topx = (nxf+1)/(nxc+1) * (i+1) - 1
1537	!
1538	! DO iif = bottomx, topx
1539	!
1540	! eps = ( iif * dxf + 0.5 * dxf - i * dxc - 0.5 * dxc ) / dxc
1541	! alpha = ( ( dxf / dxc )**2.0 - 1.0 ) / 24.0
1542	! eminus = eps * ( eps - 1.0 ) / 2.0 + alpha
1543	! edot = ( 1.0 - eps*2.0 ) - 2.0 alpha
1544	! eplus = eps * ( eps + 1.0 ) / 2.0 + alpha
1545	!
1546	! uswspr(j,iif) = eminus * work2dusws(j,i-1) &
1547	! + edot * work2dusws(j,i) &
1548	! + eplus * work2dusws(j,i+1)
1549	!
1550	! vswspr(j,iif) = eminus * work2dvsws(j,i-1) &
1551	! + edot * work2dvsws(j,i) &
1552	! + eplus * work2dvsws(j,i+1)
1553	!
1554	! tspr(j,iif) = eminus * work2dts(j,i-1) &
1555	! + edot * work2dts(j,i) &
1556	! + eplus * work2dts(j,i+1)
1557	!
1558	! uspr(j,iif) = eminus * work2dus(j,i-1) &
1559	! + edot * work2dus(j,i) &
1560	! + eplus * work2dus(j,i+1)
1561	!
1562	! END DO
1563	!
1564	! END DO
1565	! END DO
1566	!
1567	! !
1568	! !-- Interpolation in y-direction (quadratic, Clark and Farley)
1569	!
1570	! DO j = bdims_rem(2,1), bdims_rem(2,2)
1571	!
1572	! bottomy = (nyf+1)/(nyc+1) * j
1573	! topy = (nyf+1)/(nyc+1) * (j+1) - 1
1574	!
1575	! DO iif = nxl, nxr
1576	! DO jjf = bottomy, topy
1577	!
1578	! eps = ( jjf * dyf + 0.5 * dyf - j * dyc - 0.5 * dyc ) / dyc
1579	! alpha = ( ( dyf / dyc )**2.0 - 1.0 ) / 24.0
1580	! eminus = eps * ( eps - 1.0 ) / 2.0 + alpha
1581	! edot = ( 1.0 - eps*2.0 ) - 2.0 alpha
1582	! eplus = eps * ( eps + 1.0 ) / 2.0 + alpha
1583	!
1584	!!
1585	!!-- TODO
1586	!-- variables are not compatible with the new surface layer module
1587	!
1588	! surf_def_h(0)%usws(jjf,iif) = eminus * uswspr(j-1,if) &
1589	! + edot * uswspr(j,iif) &
1590	! + eplus * uswspr(j+1,iif)
1591	!
1592	! surf_def_h(0)%vsws(jjf,iif) = eminus * vswspr(j-1,if) &
1593	! + edot * vswspr(j,iif) &
1594	! + eplus * vswspr(j+1,iif)
1595	!
1596	! ts(jjf,iif) = eminus * tspr(j-1,if) &
1597	! + edot * tspr(j,iif) &
1598	! + eplus * tspr(j+1,iif)
1599	!
1600	! us(jjf,iif) = eminus * uspr(j-1,if) &
1601	! + edot * uspr(j,iif) &
1602	! + eplus * uspr(j+1,iif)
1603	!
1604	! END DO
1605	! END DO
1606	!
1607	! END DO
1608	!
1609	!
1610	! DEALLOCATE( uswspr, vswspr )
1611	! DEALLOCATE( tspr, uspr )
1612	!
1613	!
1614	! END SUBROUTINE interpolate_to_fine_flux
1615
1616
1617	#endif
1618	END SUBROUTINE vnest_init_fine
1619
1620	SUBROUTINE vnest_boundary_conds
1621	#if defined( __parallel )
1622	!------------------------------------------------------------------------------!
1623	! Description:
1624	! ------------
1625	! Boundary conditions for the prognostic quantities.
1626	! One additional bottom boundary condition is applied for the TKE (=(u)*2)
1627	! in prandtl_fluxes. The cyclic lateral boundary conditions are implicitly
1628	! handled in routine exchange_horiz. Pressure boundary conditions are
1629	! explicitly set in routines pres, poisfft, poismg and sor.
1630	!------------------------------------------------------------------------------!
1631
1632	USE arrays_3d
1633	USE control_parameters
1634	USE grid_variables
1635	USE indices
1636	USE pegrid
1637
1638
1639	IMPLICIT NONE
1640
1641	INTEGER(iwp) :: i
1642	INTEGER(iwp) :: j
1643	INTEGER(iwp) :: iif
1644	INTEGER(iwp) :: jjf
1645
1646
1647	!
1648	!-- vnest: top boundary conditions
1649
1650	IF ( coupling_mode == 'vnested_crse' ) THEN
1651	!-- Send data to fine grid for TOP BC
1652
1653	offset(1) = ( pdims_partner(1) / pdims(1) ) * pcoord(1)
1654	offset(2) = ( pdims_partner(2) / pdims(2) ) * pcoord(2)
1655
1656	do j = 0, ( pdims_partner(2) / pdims(2) ) - 1
1657	do i = 0, ( pdims_partner(1) / pdims(1) ) - 1
1658	map_coord(1) = i+offset(1)
1659	map_coord(2) = j+offset(2)
1660
1661	target_idex = f_rnk_lst(map_coord(1),map_coord(2)) + numprocs
1662
1663	bdims (1,1) = c2f_dims_cg (0,map_coord(1),map_coord(2))
1664	bdims (1,2) = c2f_dims_cg (1,map_coord(1),map_coord(2))
1665	bdims (2,1) = c2f_dims_cg (2,map_coord(1),map_coord(2))
1666	bdims (2,2) = c2f_dims_cg (3,map_coord(1),map_coord(2))
1667	bdims (3,1) = c2f_dims_cg (4,map_coord(1),map_coord(2))
1668	bdims (3,2) = c2f_dims_cg (5,map_coord(1),map_coord(2))
1669
1670	n_cell_c = ( (bdims(1,2)-bdims(1,1)) + 3 ) * &
1671	( (bdims(2,2)-bdims(2,1)) + 3 ) * &
1672	( (bdims(3,2)-bdims(3,1)) + 1 )
1673
1674	CALL MPI_SEND(u (bdims(3,1), bdims(2,1)-1, bdims(1,1)-1), &
1675	1, TYPE_VNEST_BC, target_idex, &
1676	201, comm_inter, ierr)
1677
1678	CALL MPI_SEND(v(bdims(3,1), bdims(2,1)-1, bdims(1,1)-1),&
1679	1, TYPE_VNEST_BC, target_idex, &
1680	202, comm_inter, ierr)
1681
1682	CALL MPI_SEND(w(bdims(3,1), bdims(2,1)-1, bdims(1,1)-1),&
1683	1, TYPE_VNEST_BC, target_idex, &
1684	203, comm_inter, ierr)
1685
1686	CALL MPI_SEND(pt(bdims(3,1), bdims(2,1)-1, bdims(1,1)-1),&
1687	1, TYPE_VNEST_BC, target_idex, &
1688	205, comm_inter, ierr)
1689
1690	IF ( humidity ) THEN
1691	CALL MPI_SEND(q(bdims(3,1), bdims(2,1)-1, bdims(1,1)-1),&
1692	1, TYPE_VNEST_BC, target_idex, &
1693	209, comm_inter, ierr)
1694	ENDIF
1695
1696	end do
1697	end do
1698
1699	ELSEIF ( coupling_mode == 'vnested_fine' ) THEN
1700	!-- Receive data from coarse grid for TOP BC
1701
1702	offset(1) = pcoord(1) / ( pdims(1)/pdims_partner(1) )
1703	offset(2) = pcoord(2) / ( pdims(2)/pdims_partner(2) )
1704	map_coord(1) = offset(1)
1705	map_coord(2) = offset(2)
1706	target_idex = c_rnk_lst(map_coord(1),map_coord(2))
1707
1708	bdims_rem (1,1) = c2f_dims_fg(0)
1709	bdims_rem (1,2) = c2f_dims_fg(1)
1710	bdims_rem (2,1) = c2f_dims_fg(2)
1711	bdims_rem (2,2) = c2f_dims_fg(3)
1712	bdims_rem (3,1) = c2f_dims_fg(4)
1713	bdims_rem (3,2) = c2f_dims_fg(5)
1714
1715	n_cell_c = &
1716	( (bdims_rem(1,2)-bdims_rem(1,1)) + 3 ) * &
1717	( (bdims_rem(2,2)-bdims_rem(2,1)) + 3 ) * &
1718	( (bdims_rem(3,2)-bdims_rem(3,1)) + 1 )
1719
1720	ALLOCATE( work3d ( &
1721	bdims_rem(3,1) :bdims_rem(3,2) , &
1722	bdims_rem(2,1)-1:bdims_rem(2,2)+1, &
1723	bdims_rem(1,1)-1:bdims_rem(1,2)+1))
1724
1725
1726	CALL MPI_RECV( work3d ,n_cell_c, MPI_REAL, target_idex, 201, &
1727	comm_inter,status, ierr )
1728	interpol3d => u
1729	call vnest_set_topbc_u
1730
1731	CALL MPI_RECV( work3d ,n_cell_c, MPI_REAL, target_idex, 202, &
1732	comm_inter,status, ierr )
1733	interpol3d => v
1734	call vnest_set_topbc_v
1735
1736	CALL MPI_RECV( work3d ,n_cell_c, MPI_REAL, target_idex, 203, &
1737	comm_inter,status, ierr )
1738	interpol3d => w
1739	call vnest_set_topbc_w
1740
1741	CALL MPI_RECV( work3d,n_cell_c, MPI_REAL, target_idex, 205, &
1742	comm_inter,status, ierr )
1743	interpol3d => pt
1744	call vnest_set_topbc_s
1745
1746	IF ( humidity ) THEN
1747	CALL MPI_RECV( work3d,n_cell_c, MPI_REAL, target_idex, 209, &
1748	comm_inter,status, ierr )
1749	interpol3d => q
1750	call vnest_set_topbc_s
1751
1752	CALL exchange_horiz_2d(q (nzt+1,:,:) )
1753	ENDIF
1754
1755	!-- TKE Neumann BC for FG top
1756	DO jjf = nys, nyn
1757	DO iif = nxl, nxr
1758	e(nzt+1,jjf,iif) = e(nzt,jjf,iif)
1759	END DO
1760	END DO
1761
1762	!
1763	!-- w level nzt+1 does not impact results. Only to avoid jumps while
1764	!-- plotting profiles
1765	w(nzt+1,:,:) = w(nzt,:,:)
1766
1767	CALL exchange_horiz_2d(u (nzt+1,:,:) )
1768	CALL exchange_horiz_2d(v (nzt+1,:,:) )
1769	CALL exchange_horiz_2d(pt(nzt+1,:,:) )
1770	CALL exchange_horiz_2d(e (nzt+1,:,:) )
1771	CALL exchange_horiz_2d(w (nzt+1,:,:) )
1772	CALL exchange_horiz_2d(w (nzt ,:,:) )
1773
1774	NULLIFY ( interpol3d )
1775	DEALLOCATE ( work3d )
1776
1777	ENDIF
1778
1779
1780	CONTAINS
1781
1782	SUBROUTINE vnest_set_topbc_w
1783
1784
1785	USE arrays_3d
1786	USE control_parameters
1787	USE grid_variables
1788	USE indices
1789	USE pegrid
1790
1791
1792	IMPLICIT NONE
1793
1794	INTEGER(iwp) :: i
1795	INTEGER(iwp) :: j
1796	INTEGER(iwp) :: iif
1797	INTEGER(iwp) :: jjf
1798	INTEGER(iwp) :: bottomx
1799	INTEGER(iwp) :: bottomy
1800	INTEGER(iwp) :: topx
1801	INTEGER(iwp) :: topy
1802	REAL(wp) :: eps
1803	REAL(wp) :: alpha
1804	REAL(wp) :: eminus
1805	REAL(wp) :: edot
1806	REAL(wp) :: eplus
1807	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: wprf
1808
1809
1810	ALLOCATE( wprf(bdims_rem(2,1)-1:bdims_rem(2,2)+1,nxl:nxr) )
1811
1812	!
1813	!-- Determination of a boundary condition for the vertical velocity component w:
1814	!-- In this case only interpolation in x- and y- direction is necessary, as the
1815	!-- boundary w-node of the fine grid coincides with a w-node in the coarse grid.
1816	!-- For both interpolations the scheme of Clark and Farley is used.
1817
1818	!
1819	!-- Interpolation in x-direction
1820
1821	DO j = bdims_rem(2,1)-1, bdims_rem(2,2)+1
1822
1823	DO i = bdims_rem(1,1), bdims_rem(1,2)
1824
1825	bottomx = (nxf+1)/(nxc+1) * i
1826	topx = (nxf+1)/(nxc+1) * (i+1) - 1
1827
1828	DO iif = bottomx, topx
1829
1830	eps = (iif * dxf + 0.5 * dxf - i * dxc - 0.5 * dxc) / dxc
1831	alpha = ( (dxf/dxc)**2.0 - 1.0) / 24.0
1832	eminus = eps * ( eps - 1.0 ) / 2.0 + alpha
1833	edot = ( 1.0 - eps*2.0 ) - 2.0 alpha
1834	eplus = eps * ( eps + 1.0 ) / 2.0 + alpha
1835	wprf(j,iif) = eminus * work3d(bdims_rem(3,1),j,i-1) &
1836	+ edot * work3d(bdims_rem(3,1),j,i) &
1837	+ eplus * work3d(bdims_rem(3,1),j,i+1)
1838
1839	END DO
1840
1841	END DO
1842
1843	END DO
1844
1845	!
1846	!-- Interpolation in y-direction
1847
1848	DO j = bdims_rem(2,1), bdims_rem(2,2)
1849
1850	bottomy = (nyf+1)/(nyc+1) * j
1851	topy = (nyf+1)/(nyc+1) * (j+1) - 1
1852
1853	DO iif = nxl, nxr
1854
1855	DO jjf = bottomy, topy
1856
1857	eps = (jjf * dyf + 0.5 * dyf - j * dyc - 0.5 * dyc) / dyc
1858
1859	alpha = ( (dyf/dyc)**2.0 - 1.0) / 24.0
1860
1861	eminus = eps * ( eps - 1.0 ) / 2.0 + alpha
1862
1863	edot = ( 1.0 - eps*2.0 ) - 2.0 alpha
1864
1865	eplus = eps * ( eps + 1.0 ) / 2.0 + alpha
1866
1867	w(nzt,jjf,iif) = eminus * wprf(j-1,iif) &
1868	+ edot * wprf(j,iif) &
1869	+ eplus * wprf(j+1,iif)
1870
1871	END DO
1872
1873	END DO
1874
1875	END DO
1876
1877	DEALLOCATE( wprf )
1878
1879	END SUBROUTINE vnest_set_topbc_w
1880
1881
1882	SUBROUTINE vnest_set_topbc_u
1883
1884
1885	USE arrays_3d
1886	USE control_parameters
1887	USE grid_variables
1888	USE indices
1889	USE pegrid
1890
1891
1892	IMPLICIT NONE
1893
1894	INTEGER(iwp) :: i
1895	INTEGER(iwp) :: j
1896	INTEGER(iwp) :: k
1897	INTEGER(iwp) :: iif
1898	INTEGER(iwp) :: jjf
1899	INTEGER(iwp) :: bottomx
1900	INTEGER(iwp) :: bottomy
1901	INTEGER(iwp) :: topx
1902	INTEGER(iwp) :: topy
1903	REAL(wp) :: eps
1904	REAL(wp) :: alpha
1905	REAL(wp) :: eminus
1906	REAL(wp) :: edot
1907	REAL(wp) :: eplus
1908	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: uprf
1909	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: uprs
1910
1911	ALLOCATE( uprf(bdims_rem(3,1):bdims_rem(3,2),nys:nyn,bdims_rem(1,1)-1:bdims_rem(1,2)+1) )
1912	ALLOCATE( uprs(nys:nyn,bdims_rem(1,1)-1:bdims_rem(1,2)+1) )
1913
1914
1915	!
1916	!-- Interpolation in y-direction
1917
1918	DO k = bdims_rem(3,1), bdims_rem(3,2)
1919	DO j = bdims_rem(2,1), bdims_rem(2,2)
1920
1921	bottomy = (nyf+1)/(nyc+1) * j
1922	topy = (nyf+1)/(nyc+1) * (j+1) - 1
1923
1924	DO i = bdims_rem(1,1)-1, bdims_rem(1,2)+1
1925	DO jjf = bottomy, topy
1926
1927	eps = (jjf * dyf + 0.5 * dyf - j * dyc - 0.5 * dyc) / dyc
1928	alpha = ( (dyf/dyc)**2.0 - 1.0) / 24.0
1929	eminus = eps * ( eps - 1.0 ) / 2.0 + alpha
1930	edot = ( 1.0 - eps*2.0 ) - 2.0 alpha
1931	eplus = eps * ( eps + 1.0 ) / 2.0 + alpha
1932
1933	uprf(k,jjf,i) = eminus * work3d(k,j-1,i) &
1934	+ edot * work3d(k,j,i) &
1935	+ eplus * work3d(k,j+1,i)
1936	END DO
1937	END DO
1938
1939	END DO
1940	END DO
1941
1942	!
1943	!-- Interpolation in z-direction
1944
1945	DO jjf = nys, nyn
1946	DO i = bdims_rem(1,1)-1, bdims_rem(1,2)+1
1947	eps = ( zuf(nzt+1) - zuc(bdims_rem(3,1)+1) ) / dzc
1948	alpha = ( (dzf/dzc)**2.0 - 1.0) / 24.0
1949	eminus = eps * ( eps - 1.0 ) / 2.0 + alpha
1950	edot = ( 1.0 - eps*2.0 ) - 2.0 alpha
1951	eplus = eps * ( eps + 1.0 ) / 2.0 + alpha
1952	uprs(jjf,i) = eminus * uprf(bdims_rem(3,1),jjf,i) &
1953	+ edot * uprf(bdims_rem(3,1)+1,jjf,i) &
1954	+ eplus * uprf(bdims_rem(3,1)+2,jjf,i)
1955	END DO
1956	END DO
1957
1958	!
1959	!-- Interpolation in x-direction
1960
1961	DO jjf = nys, nyn
1962	DO i = bdims_rem(1,1), bdims_rem(1,2)
1963
1964	bottomx = (nxf+1)/(nxc+1) * i
1965	topx = (nxf+1)/(nxc+1) * (i+1) - 1
1966
1967	DO iif = bottomx, topx
1968	u(nzt+1,jjf,iif) = uprs(jjf,i) + ( iif * dxf - i * dxc ) * ( uprs(jjf,i+1) - uprs(jjf,i) ) / dxc
1969	END DO
1970
1971	END DO
1972	END DO
1973
1974
1975
1976	DEALLOCATE ( uprf, uprs )
1977
1978	END SUBROUTINE vnest_set_topbc_u
1979
1980
1981	SUBROUTINE vnest_set_topbc_v
1982
1983
1984	USE arrays_3d
1985	USE control_parameters
1986	USE grid_variables
1987	USE indices
1988	USE pegrid
1989
1990
1991	IMPLICIT NONE
1992
1993	INTEGER(iwp) :: i
1994	INTEGER(iwp) :: j
1995	INTEGER(iwp) :: k
1996	INTEGER(iwp) :: iif
1997	INTEGER(iwp) :: jjf
1998	INTEGER(iwp) :: bottomx
1999	INTEGER(iwp) :: bottomy
2000	INTEGER(iwp) :: topx
2001	INTEGER(iwp) :: topy
2002	REAL(wp) :: eps
2003	REAL(wp) :: alpha
2004	REAL(wp) :: eminus
2005	REAL(wp) :: edot
2006	REAL(wp) :: eplus
2007	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: vprf
2008	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: vprs
2009
2010
2011
2012	ALLOCATE( vprf(bdims_rem(3,1):bdims_rem(3,2),bdims_rem(2,1)-1:bdims_rem(2,2)+1,nxl:nxr) )
2013	ALLOCATE( vprs(bdims_rem(2,1)-1:bdims_rem(2,2)+1,nxl:nxr) )
2014	!
2015	!-- Determination of a boundary condition for the horizontal velocity component v:
2016	!-- Interpolation in x- and z-direction is carried out by using the scheme,
2017	!-- which was derived by Clark and Farley (1984). In y-direction a
2018	!-- linear interpolation is carried out.
2019
2020	!
2021	!-- Interpolation in x-direction
2022
2023	DO k = bdims_rem(3,1), bdims_rem(3,2)
2024	DO j = bdims_rem(2,1)-1, bdims_rem(2,2)+1
2025	DO i = bdims_rem(1,1), bdims_rem(1,2)
2026
2027	bottomx = (nxf+1)/(nxc+1) * i
2028	topx = (nxf+1)/(nxc+1) * (i+1) - 1
2029
2030	DO iif = bottomx, topx
2031
2032	eps = (iif * dxf + 0.5 * dxf - i * dxc - 0.5 * dxc) / dxc
2033	alpha = ( (dxf/dxc)**2.0 - 1.0) / 24.0
2034	eminus = eps * ( eps - 1.0 ) / 2.0 + alpha
2035	edot = ( 1.0 - eps*2.0 ) - 2.0 alpha
2036	eplus = eps * ( eps + 1.0 ) / 2.0 + alpha
2037	vprf(k,j,iif) = eminus * work3d(k,j,i-1) &
2038	+ edot * work3d(k,j,i) &
2039	+ eplus * work3d(k,j,i+1)
2040	END DO
2041
2042	END DO
2043	END DO
2044	END DO
2045
2046	!
2047	!-- Interpolation in z-direction
2048
2049	DO j = bdims_rem(2,1)-1, bdims_rem(2,2)+1
2050	DO iif = nxl, nxr
2051
2052	eps = ( zuf(nzt+1) - zuc(bdims_rem(3,1)+1) ) / dzc
2053	alpha = ( (dzf/dzc)**2.0 - 1.0) / 24.0
2054	eminus = eps * ( eps - 1.0 ) / 2.0 + alpha
2055	edot = ( 1.0 - eps*2.0 ) - 2.0 alpha
2056	eplus = eps * ( eps + 1.0 ) / 2.0 + alpha
2057	vprs(j,iif) = eminus * vprf(bdims_rem(3,1),j,iif) &
2058	+ edot * vprf(bdims_rem(3,1)+1,j,iif) &
2059	+ eplus * vprf(bdims_rem(3,1)+2,j,iif)
2060
2061	END DO
2062	END DO
2063
2064	!
2065	!-- Interpolation in y-direction
2066
2067	DO j = bdims_rem(2,1), bdims_rem(2,2)
2068	DO iif = nxl, nxr
2069
2070	bottomy = (nyf+1)/(nyc+1) * j
2071	topy = (nyf+1)/(nyc+1) * (j+1) - 1
2072
2073	DO jjf = bottomy, topy
2074
2075	v(nzt+1,jjf,iif) = vprs(j,iif) + ( jjf * dyf - j * dyc ) * ( vprs(j+1,iif) - vprs(j,iif) ) / dyc
2076
2077	END DO
2078	END DO
2079	END DO
2080
2081
2082	DEALLOCATE ( vprf, vprs)
2083
2084
2085
2086	END SUBROUTINE vnest_set_topbc_v
2087
2088
2089	SUBROUTINE vnest_set_topbc_s
2090
2091
2092	USE arrays_3d
2093	USE control_parameters
2094	USE grid_variables
2095	USE indices
2096	USE pegrid
2097
2098
2099	IMPLICIT NONE
2100
2101	INTEGER(iwp) :: i
2102	INTEGER(iwp) :: j
2103	INTEGER(iwp) :: k
2104	INTEGER(iwp) :: iif
2105	INTEGER(iwp) :: jjf
2106	INTEGER(iwp) :: bottomx
2107	INTEGER(iwp) :: bottomy
2108	INTEGER(iwp) :: topx
2109	INTEGER(iwp) :: topy
2110	REAL(wp) :: eps
2111	REAL(wp) :: alpha
2112	REAL(wp) :: eminus
2113	REAL(wp) :: edot
2114	REAL(wp) :: eplus
2115	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ptprf
2116	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ptprs
2117
2118
2119
2120	ALLOCATE( ptprf(bdims_rem(3,1):bdims_rem(3,2),bdims_rem(2,1)-1:bdims_rem(2,2)+1,nxl:nxr) )
2121	ALLOCATE( ptprs(bdims_rem(3,1):bdims_rem(3,2),nys:nyn,nxl:nxr) )
2122
2123	!
2124	!-- Determination of a boundary condition for the potential temperature pt:
2125	!-- The scheme derived by Clark and Farley can be used in all three dimensions.
2126
2127	!
2128	!-- Interpolation in x-direction
2129
2130	DO k = bdims_rem(3,1), bdims_rem(3,2)
2131
2132	DO j = bdims_rem(2,1)-1, bdims_rem(2,2)+1
2133
2134	DO i = bdims_rem(1,1), bdims_rem(1,2)
2135
2136	bottomx = (nxf+1)/(nxc+1) * i
2137	topx = (nxf+1)/(nxc+1) *(i+1) - 1
2138
2139	DO iif = bottomx, topx
2140
2141	eps = (iif * dxf + 0.5 * dxf - i * dxc - 0.5 * dxc) / dxc
2142
2143	alpha = ( (dxf/dxc)**2.0 - 1.0) / 24.0
2144
2145	eminus = eps * (eps - 1.0 ) / 2.0 + alpha
2146
2147	edot = ( 1.0 - eps*2.0 ) - 2.0 alpha
2148
2149	eplus = eps * ( eps + 1.0 ) / 2.0 + alpha
2150
2151	ptprf(k,j,iif) = eminus * work3d(k,j,i-1) &
2152	+ edot * work3d(k,j,i) &
2153	+ eplus * work3d(k,j,i+1)
2154	END DO
2155
2156	END DO
2157
2158	END DO
2159
2160	END DO
2161
2162	!
2163	!-- Interpolation in y-direction
2164
2165	DO k = bdims_rem(3,1), bdims_rem(3,2)
2166
2167	DO j = bdims_rem(2,1), bdims_rem(2,2)
2168
2169	bottomy = (nyf+1)/(nyc+1) * j
2170	topy = (nyf+1)/(nyc+1) * (j+1) - 1
2171
2172	DO iif = nxl, nxr
2173
2174	DO jjf = bottomy, topy
2175
2176	eps = (jjf * dyf + 0.5 * dyf - j * dyc - 0.5 * dyc) / dyc
2177
2178	alpha = ( (dyf/dyc)**2.0 - 1.0) / 24.0
2179
2180	eminus = eps * (eps - 1.0) / 2.0 + alpha
2181
2182	edot = ( 1.0 - eps*2.0 ) - 2.0 alpha
2183
2184	eplus = eps * ( eps + 1.0 ) / 2.0 + alpha
2185
2186	ptprs(k,jjf,iif) = eminus * ptprf(k,j-1,iif) &
2187	+ edot * ptprf(k,j,iif) &
2188	+ eplus * ptprf(k,j+1,iif)
2189	END DO
2190
2191	END DO
2192
2193	END DO
2194
2195	END DO
2196
2197	!
2198	!-- Interpolation in z-direction
2199
2200	DO jjf = nys, nyn
2201	DO iif = nxl, nxr
2202
2203	eps = ( zuf(nzt+1) - zuc(bdims_rem(3,1)+1) ) / dzc
2204
2205	alpha = ( (dzf/dzc)**2.0 - 1.0) / 24.0
2206
2207	eminus = eps * ( eps - 1.0 ) / 2.0 + alpha
2208
2209	edot = ( 1.0 - eps*2.0 ) - 2.0 alpha
2210
2211	eplus = eps * ( eps + 1.0 ) / 2.0 + alpha
2212
2213	interpol3d (nzt+1,jjf,iif) = eminus * ptprs(bdims_rem(3,1),jjf,iif) &
2214	+ edot * ptprs(bdims_rem(3,1)+1,jjf,iif) &
2215	+ eplus * ptprs(bdims_rem(3,1)+2,jjf,iif)
2216
2217	END DO
2218	END DO
2219
2220	DEALLOCATE ( ptprf, ptprs )
2221
2222
2223
2224	END SUBROUTINE vnest_set_topbc_s
2225	#endif
2226	END SUBROUTINE vnest_boundary_conds
2227
2228
2229	SUBROUTINE vnest_boundary_conds_khkm
2230	#if defined( __parallel )
2231
2232	!--------------------------------------------------------------------------------!
2233	! Description:
2234	! ------------
2235	! Boundary conditions for the prognostic quantities.
2236	! One additional bottom boundary condition is applied for the TKE (=(u)*2)
2237	! in prandtl_fluxes. The cyclic lateral boundary conditions are implicitly
2238	! handled in routine exchange_horiz. Pressure boundary conditions are
2239	! explicitly set in routines pres, poisfft, poismg and sor.
2240	!------------------------------------------------------------------------------!
2241
2242	USE arrays_3d
2243	USE control_parameters
2244	USE grid_variables
2245	USE indices
2246	USE pegrid
2247
2248
2249	IMPLICIT NONE
2250
2251	INTEGER(iwp) :: i
2252	INTEGER(iwp) :: j
2253	INTEGER(iwp) :: iif
2254	INTEGER(iwp) :: jjf
2255
2256
2257	IF ( coupling_mode == 'vnested_crse' ) THEN
2258	! Send data to fine grid for TOP BC
2259
2260	offset(1) = ( pdims_partner(1) / pdims(1) ) * pcoord(1)
2261	offset(2) = ( pdims_partner(2) / pdims(2) ) * pcoord(2)
2262
2263	do j = 0, ( pdims_partner(2) / pdims(2) ) - 1
2264	do i = 0, ( pdims_partner(1) / pdims(1) ) - 1
2265	map_coord(1) = i+offset(1)
2266	map_coord(2) = j+offset(2)
2267
2268	target_idex = f_rnk_lst(map_coord(1),map_coord(2)) + numprocs
2269
2270	CALL MPI_RECV( bdims_rem, 6, MPI_INTEGER, target_idex, 10, &
2271	comm_inter,status, ierr )
2272
2273	bdims (1,1) = bdims_rem (1,1) / cfratio(1)
2274	bdims (1,2) = bdims_rem (1,2) / cfratio(1)
2275	bdims (2,1) = bdims_rem (2,1) / cfratio(2)
2276	bdims (2,2) = bdims_rem (2,2) / cfratio(2)
2277	bdims (3,1) = bdims_rem (3,2) / cfratio(3)
2278	bdims (3,2) = bdims (3,1) + 2
2279
2280	CALL MPI_SEND( bdims, 6, MPI_INTEGER, target_idex, 9, &
2281	comm_inter, ierr )
2282
2283
2284	n_cell_c = ( (bdims(1,2)-bdims(1,1)) + 3 ) * &
2285	( (bdims(2,2)-bdims(2,1)) + 3 ) * &
2286	( (bdims(3,2)-bdims(3,1)) + 1 )
2287
2288	CALL MPI_SEND(kh(bdims(3,1) :bdims(3,2) , &
2289	bdims(2,1)-1:bdims(2,2)+1, &
2290	bdims(1,1)-1:bdims(1,2)+1),&
2291	n_cell_c, MPI_REAL, target_idex, &
2292	207, comm_inter, ierr)
2293
2294	CALL MPI_SEND(km(bdims(3,1) :bdims(3,2) , &
2295	bdims(2,1)-1:bdims(2,2)+1, &
2296	bdims(1,1)-1:bdims(1,2)+1),&
2297	n_cell_c, MPI_REAL, target_idex, &
2298	208, comm_inter, ierr)
2299
2300
2301
2302	end do
2303	end do
2304
2305	ELSEIF ( coupling_mode == 'vnested_fine' ) THEN
2306	! Receive data from coarse grid for TOP BC
2307
2308	offset(1) = pcoord(1) / ( pdims(1)/pdims_partner(1) )
2309	offset(2) = pcoord(2) / ( pdims(2)/pdims_partner(2) )
2310	map_coord(1) = offset(1)
2311	map_coord(2) = offset(2)
2312	target_idex = c_rnk_lst(map_coord(1),map_coord(2))
2313
2314	bdims (1,1) = nxl
2315	bdims (1,2) = nxr
2316	bdims (2,1) = nys
2317	bdims (2,2) = nyn
2318	bdims (3,1) = nzb
2319	bdims (3,2) = nzt
2320
2321	CALL MPI_SEND( bdims, 6, MPI_INTEGER, target_idex, 10, &
2322	comm_inter, ierr )
2323
2324	CALL MPI_RECV( bdims_rem, 6, MPI_INTEGER, target_idex, 9, &
2325	comm_inter,status, ierr )
2326
2327	n_cell_c = ( (bdims_rem(1,2)-bdims_rem(1,1)) + 3 ) * &
2328	( (bdims_rem(2,2)-bdims_rem(2,1)) + 3 ) * &
2329	( (bdims_rem(3,2)-bdims_rem(3,1)) + 1 )
2330
2331	ALLOCATE( work3d ( bdims_rem(3,1) :bdims_rem(3,2) , &
2332	bdims_rem(2,1)-1:bdims_rem(2,2)+1, &
2333	bdims_rem(1,1)-1:bdims_rem(1,2)+1))
2334
2335
2336	CALL MPI_RECV( work3d,n_cell_c, MPI_REAL, target_idex, 207, &
2337	comm_inter,status, ierr )
2338
2339	! Neumann BC for FG kh
2340	DO jjf = nys, nyn
2341	DO iif = nxl, nxr
2342	kh(nzt+1,jjf,iif) = kh(nzt,jjf,iif)
2343	END DO
2344	END DO
2345
2346	CALL MPI_RECV( work3d,n_cell_c, MPI_REAL, target_idex, 208, &
2347	comm_inter,status, ierr )
2348
2349	! Neumann BC for FG kh
2350	DO jjf = nys, nyn
2351	DO iif = nxl, nxr
2352	km(nzt+1,jjf,iif) = km(nzt,jjf,iif)
2353	END DO
2354	END DO
2355
2356
2357	!
2358	!-- The following evaluation can only be performed, if the fine grid is situated below the inversion
2359	!! DO jjf = nys-1, nyn+1
2360	!! DO iif = nxl-1, nxr+1
2361	!!
2362	!! km(nzt+1,jjf,iif) = 0.1 * l_grid(nzt+1) * SQRT( e(nzt+1,jjf,iif) )
2363	!! kh(nzt+1,jjf,iif) = 3.0 * km(nzt+1,jjf,iif)
2364	!!
2365	!! END DO
2366	!! END DO
2367
2368	CALL exchange_horiz_2d(km(nzt+1,:,:) )
2369	CALL exchange_horiz_2d(kh(nzt+1,:,:) )
2370
2371	DEALLOCATE ( work3d )
2372
2373	ENDIF
2374
2375
2376	! CONTAINS
2377	!
2378	! SUBROUTINE vnest_set_topbc_kh
2379	!
2380	!
2381	! USE arrays_3d
2382	! USE control_parameters
2383	! USE grid_variables
2384	! USE indices
2385	! USE pegrid
2386	!
2387	!
2388	! IMPLICIT NONE
2389	!
2390	! INTEGER(iwp) :: i
2391	! INTEGER(iwp) :: j
2392	! INTEGER(iwp) :: k
2393	! INTEGER(iwp) :: iif
2394	! INTEGER(iwp) :: jjf
2395	! INTEGER(iwp) :: bottomx
2396	! INTEGER(iwp) :: bottomy
2397	! INTEGER(iwp) :: topx
2398	! INTEGER(iwp) :: topy
2399	! REAL(wp) :: eps
2400	! REAL(wp) :: alpha
2401	! REAL(wp) :: eminus
2402	! REAL(wp) :: edot
2403	! REAL(wp) :: eplus
2404	! REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ptprf
2405	! REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ptprs
2406	!
2407	!
2408	!
2409	! ALLOCATE( ptprf(bdims_rem(3,1):bdims_rem(3,2),bdims_rem(2,1)-1:bdims_rem(2,2)+1,nxl:nxr) )
2410	! ALLOCATE( ptprs(bdims_rem(3,1):bdims_rem(3,2),nys:nyn,nxl:nxr) )
2411	!
2412	! !
2413	! !-- Determination of a boundary condition for the potential temperature pt:
2414	! !-- The scheme derived by Clark and Farley can be used in all three dimensions.
2415	!
2416	! !
2417	! !-- Interpolation in x-direction
2418	!
2419	! DO k = bdims_rem(3,1), bdims_rem(3,2)
2420	!
2421	! DO j = bdims_rem(2,1)-1, bdims_rem(2,2)+1
2422	!
2423	! DO i = bdims_rem(1,1), bdims_rem(1,2)
2424	!
2425	! bottomx = (nxf+1)/(nxc+1) * i
2426	! topx = (nxf+1)/(nxc+1) *(i+1) - 1
2427	!
2428	! DO iif = bottomx, topx
2429	!
2430	! eps = (iif * dxf + 0.5 * dxf - i * dxc - 0.5 * dxc) / dxc
2431	!
2432	! alpha = ( (dxf/dxc)**2.0 - 1.0) / 24.0
2433	!
2434	! eminus = eps * (eps - 1.0 ) / 2.0 + alpha
2435	!
2436	! edot = ( 1.0 - eps*2.0 ) - 2.0 alpha
2437	!
2438	! eplus = eps * ( eps + 1.0 ) / 2.0 + alpha
2439	!
2440	! ptprf(k,j,iif) = eminus * work3d(k,j,i-1) &
2441	! + edot * work3d(k,j,i) &
2442	! + eplus * work3d(k,j,i+1)
2443	! END DO
2444	!
2445	! END DO
2446	!
2447	! END DO
2448	!
2449	! END DO
2450	!
2451	! !
2452	! !-- Interpolation in y-direction
2453	!
2454	! DO k = bdims_rem(3,1), bdims_rem(3,2)
2455	!
2456	! DO j = bdims_rem(2,1), bdims_rem(2,2)
2457	!
2458	! bottomy = (nyf+1)/(nyc+1) * j
2459	! topy = (nyf+1)/(nyc+1) * (j+1) - 1
2460	!
2461	! DO iif = nxl, nxr
2462	!
2463	! DO jjf = bottomy, topy
2464	!
2465	! eps = (jjf * dyf + 0.5 * dyf - j * dyc - 0.5 * dyc) / dyc
2466	!
2467	! alpha = ( (dyf/dyc)**2.0 - 1.0) / 24.0
2468	!
2469	! eminus = eps * (eps - 1.0) / 2.0 + alpha
2470	!
2471	! edot = ( 1.0 - eps*2.0 ) - 2.0 alpha
2472	!
2473	! eplus = eps * ( eps + 1.0 ) / 2.0 + alpha
2474	!
2475	! ptprs(k,jjf,iif) = eminus * ptprf(k,j-1,iif) &
2476	! + edot * ptprf(k,j,iif) &
2477	! + eplus * ptprf(k,j+1,iif)
2478	! END DO
2479	!
2480	! END DO
2481	!
2482	! END DO
2483	!
2484	! END DO
2485	!
2486	! !
2487	! !-- Interpolation in z-direction
2488	!
2489	! DO jjf = nys, nyn
2490	! DO iif = nxl, nxr
2491	!
2492	! eps = ( zuf(nzt+1) - zuc(bdims_rem(3,1)+1) ) / dzc
2493	!
2494	! alpha = ( (dzf/dzc)**2.0 - 1.0) / 24.0
2495	!
2496	! eminus = eps * ( eps - 1.0 ) / 2.0 + alpha
2497	!
2498	! edot = ( 1.0 - eps*2.0 ) - 2.0 alpha
2499	!
2500	! eplus = eps * ( eps + 1.0 ) / 2.0 + alpha
2501	!
2502	! kh (nzt+1,jjf,iif) = eminus * ptprs(bdims_rem(3,1),jjf,iif) &
2503	! + edot * ptprs(bdims_rem(3,1)+1,jjf,iif) &
2504	! + eplus * ptprs(bdims_rem(3,1)+2,jjf,iif)
2505	!
2506	! END DO
2507	! END DO
2508	!
2509	! DEALLOCATE ( ptprf, ptprs )
2510	!
2511	!
2512	!
2513	! END SUBROUTINE vnest_set_topbc_kh
2514
2515	! SUBROUTINE vnest_set_topbc_km
2516	!
2517	!
2518	! USE arrays_3d
2519	! USE control_parameters
2520	! USE grid_variables
2521	! USE indices
2522	! USE pegrid
2523	!
2524	!
2525	! IMPLICIT NONE
2526	!
2527	! INTEGER(iwp) :: i
2528	! INTEGER(iwp) :: j
2529	! INTEGER(iwp) :: k
2530	! INTEGER(iwp) :: iif
2531	! INTEGER(iwp) :: jjf
2532	! INTEGER(iwp) :: bottomx
2533	! INTEGER(iwp) :: bottomy
2534	! INTEGER(iwp) :: topx
2535	! INTEGER(iwp) :: topy
2536	! REAL(wp) :: eps
2537	! REAL(wp) :: alpha
2538	! REAL(wp) :: eminus
2539	! REAL(wp) :: edot
2540	! REAL(wp) :: eplus
2541	! REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ptprf
2542	! REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ptprs
2543	!
2544	!
2545	!
2546	! ALLOCATE( ptprf(bdims_rem(3,1):bdims_rem(3,2),bdims_rem(2,1)-1:bdims_rem(2,2)+1,nxl:nxr) )
2547	! ALLOCATE( ptprs(bdims_rem(3,1):bdims_rem(3,2),nys:nyn,nxl:nxr) )
2548	!
2549	! !
2550	! !-- Determination of a boundary condition for the potential temperature pt:
2551	! !-- The scheme derived by Clark and Farley can be used in all three dimensions.
2552	!
2553	! !
2554	! !-- Interpolation in x-direction
2555	!
2556	! DO k = bdims_rem(3,1), bdims_rem(3,2)
2557	!
2558	! DO j = bdims_rem(2,1)-1, bdims_rem(2,2)+1
2559	!
2560	! DO i = bdims_rem(1,1), bdims_rem(1,2)
2561	!
2562	! bottomx = (nxf+1)/(nxc+1) * i
2563	! topx = (nxf+1)/(nxc+1) *(i+1) - 1
2564	!
2565	! DO iif = bottomx, topx
2566	!
2567	! eps = (iif * dxf + 0.5 * dxf - i * dxc - 0.5 * dxc) / dxc
2568	!
2569	! alpha = ( (dxf/dxc)**2.0 - 1.0) / 24.0
2570	!
2571	! eminus = eps * (eps - 1.0 ) / 2.0 + alpha
2572	!
2573	! edot = ( 1.0 - eps*2.0 ) - 2.0 alpha
2574	!
2575	! eplus = eps * ( eps + 1.0 ) / 2.0 + alpha
2576	!
2577	! ptprf(k,j,iif) = eminus * work3d(k,j,i-1) &
2578	! + edot * work3d(k,j,i) &
2579	! + eplus * work3d(k,j,i+1)
2580	! END DO
2581	!
2582	! END DO
2583	!
2584	! END DO
2585	!
2586	! END DO
2587	!
2588	! !
2589	! !-- Interpolation in y-direction
2590	!
2591	! DO k = bdims_rem(3,1), bdims_rem(3,2)
2592	!
2593	! DO j = bdims_rem(2,1), bdims_rem(2,2)
2594	!
2595	! bottomy = (nyf+1)/(nyc+1) * j
2596	! topy = (nyf+1)/(nyc+1) * (j+1) - 1
2597	!
2598	! DO iif = nxl, nxr
2599	!
2600	! DO jjf = bottomy, topy
2601	!
2602	! eps = (jjf * dyf + 0.5 * dyf - j * dyc - 0.5 * dyc) / dyc
2603	!
2604	! alpha = ( (dyf/dyc)**2.0 - 1.0) / 24.0
2605	!
2606	! eminus = eps * (eps - 1.0) / 2.0 + alpha
2607	!
2608	! edot = ( 1.0 - eps*2.0 ) - 2.0 alpha
2609	!
2610	! eplus = eps * ( eps + 1.0 ) / 2.0 + alpha
2611	!
2612	! ptprs(k,jjf,iif) = eminus * ptprf(k,j-1,iif) &
2613	! + edot * ptprf(k,j,iif) &
2614	! + eplus * ptprf(k,j+1,iif)
2615	! END DO
2616	!
2617	! END DO
2618	!
2619	! END DO
2620	!
2621	! END DO
2622	!
2623	! !
2624	! !-- Interpolation in z-direction
2625	!
2626	! DO jjf = nys, nyn
2627	! DO iif = nxl, nxr
2628	!
2629	! eps = ( zuf(nzt+1) - zuc(bdims_rem(3,1)+1) ) / dzc
2630	!
2631	! alpha = ( (dzf/dzc)**2.0 - 1.0) / 24.0
2632	!
2633	! eminus = eps * ( eps - 1.0 ) / 2.0 + alpha
2634	!
2635	! edot = ( 1.0 - eps*2.0 ) - 2.0 alpha
2636	!
2637	! eplus = eps * ( eps + 1.0 ) / 2.0 + alpha
2638	!
2639	! km (nzt+1,jjf,iif) = eminus * ptprs(bdims_rem(3,1),jjf,iif) &
2640	! + edot * ptprs(bdims_rem(3,1)+1,jjf,iif) &
2641	! + eplus * ptprs(bdims_rem(3,1)+2,jjf,iif)
2642	!
2643	! END DO
2644	! END DO
2645	!
2646	! DEALLOCATE ( ptprf, ptprs )
2647	!
2648	!
2649	!
2650	! END SUBROUTINE vnest_set_topbc_km
2651
2652
2653	#endif
2654	END SUBROUTINE vnest_boundary_conds_khkm
2655
2656
2657
2658	SUBROUTINE vnest_anterpolate
2659
2660	#if defined( __parallel )
2661
2662	!--------------------------------------------------------------------------------!
2663	! Description:
2664	! ------------
2665	! Anterpolate data from fine grid to coarse grid.
2666	!------------------------------------------------------------------------------!
2667
2668	USE arrays_3d
2669	USE control_parameters
2670	USE grid_variables
2671	USE indices
2672	USE interfaces
2673	USE pegrid
2674	USE surface_mod, &
2675	ONLY : bc_h
2676
2677
2678	IMPLICIT NONE
2679
2680	REAL(wp) :: time_since_reference_point_rem
2681	INTEGER(iwp) :: i
2682	INTEGER(iwp) :: j
2683	INTEGER(iwp) :: k
2684	INTEGER(iwp) :: l !< running index boundary type, for up- and downward-facing walls
2685	INTEGER(iwp) :: m !< running index surface elements
2686
2687
2688
2689	!
2690	!-- In case of model termination initiated by the remote model
2691	!-- (terminate_coupled_remote > 0), initiate termination of the local model.
2692	!-- The rest of the coupler must then be skipped because it would cause an MPI
2693	!-- intercomminucation hang.
2694	!-- If necessary, the coupler will be called at the beginning of the next
2695	!-- restart run.
2696
2697	IF ( myid == 0) THEN
2698	CALL MPI_SENDRECV( terminate_coupled, 1, MPI_INTEGER, &
2699	target_id, 0, &
2700	terminate_coupled_remote, 1, MPI_INTEGER, &
2701	target_id, 0, &
2702	comm_inter, status, ierr )
2703	ENDIF
2704	CALL MPI_BCAST( terminate_coupled_remote, 1, MPI_INTEGER, 0, comm2d, &
2705	ierr )
2706
2707	IF ( terminate_coupled_remote > 0 ) THEN
2708	WRITE( message_string, * ) 'remote model "', &
2709	TRIM( coupling_mode_remote ), &
2710	'" terminated', &
2711	'&with terminate_coupled_remote = ', &
2712	terminate_coupled_remote, &
2713	'&local model "', TRIM( coupling_mode ), &
2714	'" has', &
2715	'&terminate_coupled = ', &
2716	terminate_coupled
2717	CALL message( 'vnest_anterpolate', 'PA0310', 1, 2, 0, 6, 0 )
2718	RETURN
2719	ENDIF
2720
2721
2722	!
2723	!-- Exchange the current simulated time between the models
2724
2725	IF ( myid == 0 ) THEN
2726
2727	CALL MPI_SEND( time_since_reference_point, 1, MPI_REAL, target_id, &
2728	11, comm_inter, ierr )
2729	CALL MPI_RECV( time_since_reference_point_rem, 1, MPI_REAL, &
2730	target_id, 11, comm_inter, status, ierr )
2731
2732	ENDIF
2733
2734	CALL MPI_BCAST( time_since_reference_point_rem, 1, MPI_REAL, 0, comm2d, &
2735	ierr )
2736
2737	IF ( coupling_mode == 'vnested_crse' ) THEN
2738	! Receive data from fine grid for anterpolation
2739
2740	offset(1) = ( pdims_partner(1) / pdims(1) ) * pcoord(1)
2741	offset(2) = ( pdims_partner(2) / pdims(2) ) * pcoord(2)
2742
2743	do j = 0, ( pdims_partner(2) / pdims(2) ) - 1
2744	do i = 0, ( pdims_partner(1) / pdims(1) ) - 1
2745	map_coord(1) = i+offset(1)
2746	map_coord(2) = j+offset(2)
2747
2748	target_idex = f_rnk_lst(map_coord(1),map_coord(2)) + numprocs
2749
2750	CALL MPI_RECV( bdims_rem, 6, MPI_INTEGER, target_idex, 10, &
2751	comm_inter,status, ierr )
2752
2753	bdims (1,1) = bdims_rem (1,1) / cfratio(1)
2754	bdims (1,2) = bdims_rem (1,2) / cfratio(1)
2755	bdims (2,1) = bdims_rem (2,1) / cfratio(2)
2756	bdims (2,2) = bdims_rem (2,2) / cfratio(2)
2757	bdims (3,1) = bdims_rem (3,1)
2758	bdims (3,2) = bdims_rem (3,2) / cfratio(3)
2759
2760	CALL MPI_SEND( bdims, 6, MPI_INTEGER, target_idex, 9, &
2761	comm_inter, ierr )
2762
2763	n_cell_c = &
2764	(bdims(1,2)-bdims(1,1)+1) * &
2765	(bdims(2,2)-bdims(2,1)+1) * &
2766	(bdims(3,2)-bdims(3,1)+0)
2767
2768	CALL MPI_RECV( u( &
2769	bdims(3,1)+1:bdims(3,2), &
2770	bdims(2,1) :bdims(2,2), &
2771	bdims(1,1) :bdims(1,2)),&
2772	n_cell_c, MPI_REAL, target_idex, 101, &
2773	comm_inter,status, ierr )
2774
2775	CALL MPI_RECV( v( &
2776	bdims(3,1)+1:bdims(3,2), &
2777	bdims(2,1) :bdims(2,2), &
2778	bdims(1,1) :bdims(1,2)),&
2779	n_cell_c, MPI_REAL, target_idex, 102, &
2780	comm_inter,status, ierr )
2781
2782	CALL MPI_RECV(pt( &
2783	bdims(3,1)+1:bdims(3,2), &
2784	bdims(2,1) :bdims(2,2), &
2785	bdims(1,1) :bdims(1,2)),&
2786	n_cell_c, MPI_REAL, target_idex, 105, &
2787	comm_inter,status, ierr )
2788
2789	IF ( humidity ) THEN
2790	CALL MPI_RECV(q( &
2791	bdims(3,1)+1:bdims(3,2), &
2792	bdims(2,1) :bdims(2,2), &
2793	bdims(1,1) :bdims(1,2)),&
2794	n_cell_c, MPI_REAL, target_idex, 106, &
2795	comm_inter,status, ierr )
2796	ENDIF
2797
2798	CALL MPI_RECV( w( &
2799	bdims(3,1) :bdims(3,2)-1, &
2800	bdims(2,1) :bdims(2,2), &
2801	bdims(1,1) :bdims(1,2)), &
2802	n_cell_c, MPI_REAL, target_idex, 103, &
2803	comm_inter,status, ierr )
2804
2805	end do
2806	end do
2807
2808
2809
2810	!
2811	!-- Boundary conditions for the velocity components u and v
2812
2813
2814	IF ( ibc_uv_b == 0 ) THEN
2815	u(nzb,:,:) = 0.0_wp
2816	v(nzb,:,:) = 0.0_wp
2817	ELSE
2818	u(nzb,:,:) = u(nzb+1,:,:)
2819	v(nzb,:,:) = v(nzb+1,:,:)
2820	END IF
2821	!
2822	!-- Boundary conditions for the velocity components w
2823
2824	w(nzb,:,:) = 0.0_wp
2825
2826	!
2827	!-- Temperature at bottom boundary.
2828	!-- Neumann, zero-gradient
2829	IF ( ibc_pt_b == 1 ) THEN
2830	DO l = 0, 1
2831	DO m = 1, bc_h(l)%ns
2832	i = bc_h(l)%i(m)
2833	j = bc_h(l)%j(m)
2834	k = bc_h(l)%k(m)
2835	pt(k+bc_h(l)%koff,j,i) = pt(k,j,i)
2836	ENDDO
2837	ENDDO
2838	ENDIF
2839
2840
2841	CALL exchange_horiz( u, nbgp )
2842	CALL exchange_horiz( v, nbgp )
2843	CALL exchange_horiz( w, nbgp )
2844	CALL exchange_horiz( pt, nbgp )
2845
2846
2847	ELSEIF ( coupling_mode == 'vnested_fine' ) THEN
2848	! Send data to coarse grid for anterpolation
2849
2850	offset(1) = pcoord(1) / ( pdims(1)/pdims_partner(1) )
2851	offset(2) = pcoord(2) / ( pdims(2)/pdims_partner(2) )
2852	map_coord(1) = offset(1)
2853	map_coord(2) = offset(2)
2854	target_idex = c_rnk_lst(map_coord(1),map_coord(2))
2855
2856	!-- Limit anterpolation level to nzt - z nesting ratio (a pseudo-buffer layer)
2857	bdims (1,1) = nxl
2858	bdims (1,2) = nxr
2859	bdims (2,1) = nys
2860	bdims (2,2) = nyn
2861	bdims (3,1) = nzb
2862	bdims (3,2) = nzt-cfratio(3)
2863
2864	CALL MPI_SEND( bdims, 6, MPI_INTEGER, target_idex, 10, &
2865	comm_inter, ierr )
2866
2867	CALL MPI_RECV( bdims_rem, 6, MPI_INTEGER, target_idex, 9, &
2868	comm_inter,status, ierr )
2869
2870
2871	ALLOCATE( work3d ( &
2872	bdims_rem(3,1)+1:bdims_rem(3,2), &
2873	bdims_rem(2,1) :bdims_rem(2,2), &
2874	bdims_rem(1,1) :bdims_rem(1,2)))
2875
2876
2877	anterpol3d => u
2878
2879	CALL anterpolate_to_crse_u
2880	CALL MPI_SEND( work3d, 1, TYPE_VNEST_ANTER, target_idex, &
2881	101, comm_inter, ierr)
2882
2883	anterpol3d => v
2884
2885	CALL anterpolate_to_crse_v
2886	CALL MPI_SEND( work3d, 1, TYPE_VNEST_ANTER, target_idex, &
2887	102, comm_inter, ierr)
2888
2889	anterpol3d => pt
2890
2891	CALL anterpolate_to_crse_s
2892	CALL MPI_SEND( work3d, 1, TYPE_VNEST_ANTER, target_idex, &
2893	105, comm_inter, ierr)
2894
2895
2896	IF ( humidity ) THEN
2897
2898	anterpol3d => q
2899
2900	CALL anterpolate_to_crse_s
2901	CALL MPI_SEND( work3d, 1, TYPE_VNEST_ANTER, target_idex, &
2902	106, comm_inter, ierr)
2903	ENDIF
2904
2905
2906	DEALLOCATE( work3d )
2907	ALLOCATE( work3d ( bdims_rem(3,1) :bdims_rem(3,2)-1, &
2908	bdims_rem(2,1) :bdims_rem(2,2), &
2909	bdims_rem(1,1) :bdims_rem(1,2)))
2910	anterpol3d => w
2911	CALL anterpolate_to_crse_w
2912	CALL MPI_SEND( work3d, 1, TYPE_VNEST_ANTER, target_idex, &
2913	103, comm_inter, ierr)
2914
2915	NULLIFY ( anterpol3d )
2916	DEALLOCATE( work3d )
2917
2918	ENDIF
2919
2920
2921
2922	CONTAINS
2923	SUBROUTINE anterpolate_to_crse_u
2924
2925
2926	USE arrays_3d
2927	USE control_parameters
2928	USE grid_variables
2929	USE indices
2930	USE pegrid
2931
2932
2933	IMPLICIT NONE
2934
2935	INTEGER(iwp) :: i
2936	INTEGER(iwp) :: j
2937	INTEGER(iwp) :: k
2938	INTEGER(iwp) :: iif
2939	INTEGER(iwp) :: jjf
2940	INTEGER(iwp) :: kkf
2941	INTEGER(iwp) :: bottomy
2942	INTEGER(iwp) :: bottomz
2943	INTEGER(iwp) :: topy
2944	INTEGER(iwp) :: topz
2945	REAL(wp) :: aweight
2946
2947	!
2948	!-- Anterpolation of the velocity components u
2949	!-- only values in yz-planes that coincide in the fine and
2950	!-- the coarse grid are considered
2951
2952	DO k = bdims_rem(3,1)+1, bdims_rem(3,2)
2953
2954	bottomz = (dzc/dzf) * (k-1) + 1
2955	topz = (dzc/dzf) * k
2956
2957	DO j = bdims_rem(2,1),bdims_rem(2,2)
2958
2959	bottomy = (nyf+1) / (nyc+1) * j
2960	topy = (nyf+1) / (nyc+1) * (j+1) - 1
2961
2962	DO i = bdims_rem(1,1),bdims_rem(1,2)
2963
2964	iif = (nxf+1) / (nxc+1) * i
2965
2966	aweight = 0.0
2967
2968	DO kkf = bottomz, topz
2969	DO jjf = bottomy, topy
2970
2971	aweight = aweight + anterpol3d(kkf,jjf,iif) * &
2972	(dzf/dzc) * (dyf/dyc)
2973
2974	END DO
2975	END DO
2976
2977	work3d(k,j,i) = aweight
2978
2979	END DO
2980
2981	END DO
2982
2983	END DO
2984
2985
2986
2987	END SUBROUTINE anterpolate_to_crse_u
2988
2989
2990	SUBROUTINE anterpolate_to_crse_v
2991
2992
2993	USE arrays_3d
2994	USE control_parameters
2995	USE grid_variables
2996	USE indices
2997	USE pegrid
2998
2999
3000	IMPLICIT NONE
3001
3002	INTEGER(iwp) :: i
3003	INTEGER(iwp) :: j
3004	INTEGER(iwp) :: k
3005	INTEGER(iwp) :: iif
3006	INTEGER(iwp) :: jjf
3007	INTEGER(iwp) :: kkf
3008	INTEGER(iwp) :: bottomx
3009	INTEGER(iwp) :: bottomz
3010	INTEGER(iwp) :: topx
3011	INTEGER(iwp) :: topz
3012	REAL(wp) :: aweight
3013
3014	!
3015	!-- Anterpolation of the velocity components v
3016	!-- only values in xz-planes that coincide in the fine and
3017	!-- the coarse grid are considered
3018
3019	DO k = bdims_rem(3,1)+1, bdims_rem(3,2)
3020
3021	bottomz = (dzc/dzf) * (k-1) + 1
3022	topz = (dzc/dzf) * k
3023
3024	DO j = bdims_rem(2,1), bdims_rem(2,2)
3025
3026	jjf = (nyf+1) / (nyc+1) * j
3027
3028	DO i = bdims_rem(1,1), bdims_rem(1,2)
3029
3030	bottomx = (nxf+1) / (nxc+1) * i
3031	topx = (nxf+1) / (nxc+1) * (i+1) - 1
3032
3033	aweight = 0.0
3034
3035	DO kkf = bottomz, topz
3036	DO iif = bottomx, topx
3037
3038	aweight = aweight + anterpol3d(kkf,jjf,iif) * &
3039	(dzf/dzc) * (dxf/dxc)
3040
3041
3042	END DO
3043	END DO
3044
3045	work3d(k,j,i) = aweight
3046
3047	END DO
3048	END DO
3049	END DO
3050
3051
3052
3053	END SUBROUTINE anterpolate_to_crse_v
3054
3055
3056	SUBROUTINE anterpolate_to_crse_w
3057
3058
3059	USE arrays_3d
3060	USE control_parameters
3061	USE grid_variables
3062	USE indices
3063	USE pegrid
3064
3065
3066	IMPLICIT NONE
3067
3068	INTEGER(iwp) :: i
3069	INTEGER(iwp) :: j
3070	INTEGER(iwp) :: k
3071	INTEGER(iwp) :: iif
3072	INTEGER(iwp) :: jjf
3073	INTEGER(iwp) :: kkf
3074	INTEGER(iwp) :: bottomx
3075	INTEGER(iwp) :: bottomy
3076	INTEGER(iwp) :: topx
3077	INTEGER(iwp) :: topy
3078	REAL(wp) :: aweight
3079
3080	!
3081	!-- Anterpolation of the velocity components w
3082	!-- only values in xy-planes that coincide in the fine and
3083	!-- the coarse grid are considered
3084
3085	DO k = bdims_rem(3,1), bdims_rem(3,2)-1
3086
3087	kkf = cfratio(3) * k
3088
3089	DO j = bdims_rem(2,1), bdims_rem(2,2)
3090
3091	bottomy = (nyf+1) / (nyc+1) * j
3092	topy = (nyf+1) / (nyc+1) * (j+1) - 1
3093
3094	DO i = bdims_rem(1,1), bdims_rem(1,2)
3095
3096	bottomx = (nxf+1) / (nxc+1) * i
3097	topx = (nxf+1) / (nxc+1) * (i+1) - 1
3098
3099	aweight = 0.0
3100
3101	DO jjf = bottomy, topy
3102	DO iif = bottomx, topx
3103
3104	aweight = aweight + anterpol3d (kkf,jjf,iif) * &
3105	(dxf/dxc) * (dyf/dyc)
3106
3107	END DO
3108	END DO
3109
3110	work3d(k,j,i) = aweight
3111
3112	END DO
3113
3114	END DO
3115
3116	END DO
3117
3118
3119	END SUBROUTINE anterpolate_to_crse_w
3120
3121
3122	SUBROUTINE anterpolate_to_crse_s
3123
3124
3125	USE arrays_3d
3126	USE control_parameters
3127	USE grid_variables
3128	USE indices
3129	USE pegrid
3130
3131
3132	IMPLICIT NONE
3133
3134	INTEGER(iwp) :: i
3135	INTEGER(iwp) :: j
3136	INTEGER(iwp) :: k
3137	INTEGER(iwp) :: iif
3138	INTEGER(iwp) :: jjf
3139	INTEGER(iwp) :: kkf
3140	INTEGER(iwp) :: bottomx
3141	INTEGER(iwp) :: bottomy
3142	INTEGER(iwp) :: bottomz
3143	INTEGER(iwp) :: topx
3144	INTEGER(iwp) :: topy
3145	INTEGER(iwp) :: topz
3146	REAL(wp) :: aweight
3147
3148	!
3149	!-- Anterpolation of the potential temperature pt
3150	!-- all fine grid values are considered
3151
3152	DO k = bdims_rem(3,1)+1, bdims_rem(3,2)
3153
3154	bottomz = (dzc/dzf) * (k-1) + 1
3155	topz = (dzc/dzf) * k
3156
3157	DO j = bdims_rem(2,1), bdims_rem(2,2)
3158
3159	bottomy = (nyf+1) / (nyc+1) * j
3160	topy = (nyf+1) / (nyc+1) * (j+1) - 1
3161
3162	DO i = bdims_rem(1,1), bdims_rem(1,2)
3163
3164	bottomx = (nxf+1) / (nxc+1) * i
3165	topx = (nxf+1) / (nxc+1) * (i+1) - 1
3166
3167	aweight = 0.0
3168
3169	DO kkf = bottomz, topz
3170	DO jjf = bottomy, topy
3171	DO iif = bottomx, topx
3172
3173	aweight = aweight + anterpol3d(kkf,jjf,iif) * &
3174	(dzf/dzc) * (dyf/dyc) * (dxf/dxc)
3175
3176	END DO
3177	END DO
3178	END DO
3179
3180	work3d(k,j,i) = aweight
3181
3182	END DO
3183
3184	END DO
3185
3186	END DO
3187
3188
3189	END SUBROUTINE anterpolate_to_crse_s
3190	#endif
3191	END SUBROUTINE vnest_anterpolate
3192
3193
3194
3195	SUBROUTINE vnest_anterpolate_e
3196	#if defined( __parallel )
3197
3198	!--------------------------------------------------------------------------------!
3199	! Description:
3200	! ------------
3201	! Anterpolate TKE from fine grid to coarse grid.
3202	!------------------------------------------------------------------------------!
3203
3204	USE arrays_3d
3205	USE control_parameters
3206	USE grid_variables
3207	USE indices
3208	USE interfaces
3209	USE pegrid
3210
3211
3212	IMPLICIT NONE
3213
3214	REAL(wp) :: time_since_reference_point_rem
3215	INTEGER(iwp) :: i
3216	INTEGER(iwp) :: j
3217
3218	!
3219	!-- In case of model termination initiated by the remote model
3220	!-- (terminate_coupled_remote > 0), initiate termination of the local model.
3221	!-- The rest of the coupler must then be skipped because it would cause an MPI
3222	!-- intercomminucation hang.
3223	!-- If necessary, the coupler will be called at the beginning of the next
3224	!-- restart run.
3225
3226	IF ( myid == 0) THEN
3227	CALL MPI_SENDRECV( terminate_coupled, 1, MPI_INTEGER, &
3228	target_id, 0, &
3229	terminate_coupled_remote, 1, MPI_INTEGER, &
3230	target_id, 0, &
3231	comm_inter, status, ierr )
3232	ENDIF
3233	CALL MPI_BCAST( terminate_coupled_remote, 1, MPI_INTEGER, 0, comm2d, &
3234	ierr )
3235
3236	IF ( terminate_coupled_remote > 0 ) THEN
3237	WRITE( message_string, * ) 'remote model "', &
3238	TRIM( coupling_mode_remote ), &
3239	'" terminated', &
3240	'&with terminate_coupled_remote = ', &
3241	terminate_coupled_remote, &
3242	'&local model "', TRIM( coupling_mode ), &
3243	'" has', &
3244	'&terminate_coupled = ', &
3245	terminate_coupled
3246	CALL message( 'vnest_anterpolate_e', 'PA0310', 1, 2, 0, 6, 0 )
3247	RETURN
3248	ENDIF
3249
3250
3251	!
3252	!-- Exchange the current simulated time between the models
3253	IF ( myid == 0 ) THEN
3254
3255	CALL MPI_SEND( time_since_reference_point, 1, MPI_REAL, target_id, &
3256	11, comm_inter, ierr )
3257	CALL MPI_RECV( time_since_reference_point_rem, 1, MPI_REAL, &
3258	target_id, 11, comm_inter, status, ierr )
3259
3260	ENDIF
3261
3262	CALL MPI_BCAST( time_since_reference_point_rem, 1, MPI_REAL, 0, comm2d, &
3263	ierr )
3264
3265	IF ( coupling_mode == 'vnested_crse' ) THEN
3266	! Receive data from fine grid for anterpolation
3267
3268	offset(1) = ( pdims_partner(1) / pdims(1) ) * pcoord(1)
3269	offset(2) = ( pdims_partner(2) / pdims(2) ) * pcoord(2)
3270
3271	do j = 0, ( pdims_partner(2) / pdims(2) ) - 1
3272	do i = 0, ( pdims_partner(1) / pdims(1) ) - 1
3273	map_coord(1) = i+offset(1)
3274	map_coord(2) = j+offset(2)
3275
3276	target_idex = f_rnk_lst(map_coord(1),map_coord(2)) + numprocs
3277
3278	bdims (1,1) = f2c_dims_cg (0,map_coord(1),map_coord(2))
3279	bdims (1,2) = f2c_dims_cg (1,map_coord(1),map_coord(2))
3280	bdims (2,1) = f2c_dims_cg (2,map_coord(1),map_coord(2))
3281	bdims (2,2) = f2c_dims_cg (3,map_coord(1),map_coord(2))
3282	bdims (3,1) = f2c_dims_cg (4,map_coord(1),map_coord(2))
3283	bdims (3,2) = f2c_dims_cg (5,map_coord(1),map_coord(2))
3284
3285
3286	n_cell_c = (bdims(1,2)-bdims(1,1)+1) * &
3287	(bdims(2,2)-bdims(2,1)+1) * &
3288	(bdims(3,2)-bdims(3,1)+0)
3289
3290
3291	CALL MPI_RECV( e( bdims(3,1)+1:bdims(3,2), &
3292	bdims(2,1) :bdims(2,2), &
3293	bdims(1,1) :bdims(1,2)),&
3294	n_cell_c, MPI_REAL, target_idex, 104, &
3295	comm_inter,status, ierr )
3296	end do
3297	end do
3298
3299
3300	!
3301	!-- Boundary conditions
3302
3303	IF ( .NOT. constant_diffusion ) THEN
3304	e(nzb,:,:) = e(nzb+1,:,:)
3305	END IF
3306
3307	IF ( .NOT. constant_diffusion ) CALL exchange_horiz( e, nbgp )
3308
3309	ELSEIF ( coupling_mode == 'vnested_fine' ) THEN
3310	! Send data to coarse grid for anterpolation
3311
3312	offset(1) = pcoord(1) / ( pdims(1)/pdims_partner(1) )
3313	offset(2) = pcoord(2) / ( pdims(2)/pdims_partner(2) )
3314	map_coord(1) = offset(1)
3315	map_coord(2) = offset(2)
3316	target_idex = c_rnk_lst(map_coord(1),map_coord(2))
3317
3318	bdims_rem (1,1) = f2c_dims_fg (0)
3319	bdims_rem (1,2) = f2c_dims_fg (1)
3320	bdims_rem (2,1) = f2c_dims_fg (2)
3321	bdims_rem (2,2) = f2c_dims_fg (3)
3322	bdims_rem (3,1) = f2c_dims_fg (4)
3323	bdims_rem (3,2) = f2c_dims_fg (5)
3324
3325	ALLOCATE( work3d ( &
3326	bdims_rem(3,1)+1:bdims_rem(3,2), &
3327	bdims_rem(2,1) :bdims_rem(2,2), &
3328	bdims_rem(1,1) :bdims_rem(1,2)))
3329
3330	anterpol3d => e
3331
3332	CALL anterpolate_to_crse_e
3333
3334	CALL MPI_SEND( work3d, 1, TYPE_VNEST_ANTER, target_idex, &
3335	104, comm_inter, ierr)
3336
3337	NULLIFY ( anterpol3d )
3338	DEALLOCATE( work3d )
3339	ENDIF
3340
3341
3342	CONTAINS
3343
3344
3345
3346
3347
3348	SUBROUTINE anterpolate_to_crse_e
3349
3350
3351	USE arrays_3d
3352	USE control_parameters
3353	USE grid_variables
3354	USE indices
3355	USE pegrid
3356
3357
3358	IMPLICIT NONE
3359
3360	INTEGER(iwp) :: i
3361	INTEGER(iwp) :: j
3362	INTEGER(iwp) :: k
3363	INTEGER(iwp) :: iif
3364	INTEGER(iwp) :: jjf
3365	INTEGER(iwp) :: kkf
3366	INTEGER(iwp) :: bottomx
3367	INTEGER(iwp) :: bottomy
3368	INTEGER(iwp) :: bottomz
3369	INTEGER(iwp) :: topx
3370	INTEGER(iwp) :: topy
3371	INTEGER(iwp) :: topz
3372	REAL(wp) :: aweight_a
3373	REAL(wp) :: aweight_b
3374	REAL(wp) :: aweight_c
3375	REAL(wp) :: aweight_d
3376	REAL(wp) :: aweight_e
3377	REAL(wp) :: energ
3378
3379	DO k = bdims_rem(3,1)+1, bdims_rem(3,2)
3380
3381	bottomz = (dzc/dzf) * (k-1) + 1
3382	topz = (dzc/dzf) * k
3383
3384	DO j = bdims_rem(2,1), bdims_rem(2,2)
3385
3386	bottomy = (nyf+1) / (nyc+1) * j
3387	topy = (nyf+1) / (nyc+1) * (j+1) - 1
3388
3389	DO i = bdims_rem(1,1), bdims_rem(1,2)
3390
3391	bottomx = (nxf+1) / (nxc+1) * i
3392	topx = (nxf+1) / (nxc+1) * (i+1) - 1
3393
3394	aweight_a = 0.0
3395	aweight_b = 0.0
3396	aweight_c = 0.0
3397	aweight_d = 0.0
3398	aweight_e = 0.0
3399
3400	DO kkf = bottomz, topz
3401	DO jjf = bottomy, topy
3402	DO iif = bottomx, topx
3403
3404	aweight_a = aweight_a + anterpol3d(kkf,jjf,iif) * &
3405	(dzf/dzc) * (dyf/dyc) * (dxf/dxc)
3406
3407
3408	energ = ( 0.5 * ( u(kkf,jjf,iif) + u(kkf,jjf,iif+1) ) )**2.0 + &
3409	( 0.5 * ( v(kkf,jjf,iif) + v(kkf,jjf+1,iif) ) )**2.0 + &
3410	( 0.5 * ( w(kkf-1,jjf,iif) + w(kkf,jjf,iif) ) )**2.0
3411
3412	aweight_b = aweight_b + energ * &
3413	(dzf/dzc) * (dyf/dyc) * (dxf/dxc)
3414
3415	aweight_c = aweight_c + 0.5 * ( u(kkf,jjf,iif) + u(kkf,jjf,iif+1) ) * &
3416	(dzf/dzc) * (dyf/dyc) * (dxf/dxc)
3417
3418	aweight_d = aweight_d + 0.5 * ( v(kkf,jjf,iif) + v(kkf,jjf+1,iif) ) * &
3419	(dzf/dzc) * (dyf/dyc) * (dxf/dxc)
3420
3421	aweight_e = aweight_e + 0.5 * ( w(kkf-1,jjf,iif) + w(kkf,jjf,iif) ) * &
3422	(dzf/dzc) * (dyf/dyc) * (dxf/dxc)
3423
3424
3425	END DO
3426	END DO
3427	END DO
3428
3429	work3d(k,j,i) = aweight_a + 0.5 * ( aweight_b - &
3430	aweight_c**2.0 - &
3431	aweight_d**2.0 - &
3432	aweight_e**2.0 )
3433
3434	END DO
3435
3436	END DO
3437
3438	END DO
3439
3440
3441
3442	END SUBROUTINE anterpolate_to_crse_e
3443	#endif
3444	END SUBROUTINE vnest_anterpolate_e
3445
3446	SUBROUTINE vnest_init_pegrid_rank
3447	#if defined( __parallel )
3448	! Domain decomposition and exchange of grid variables between coarse and fine
3449	! Given processor coordinates as index f_rnk_lst(pcoord(1), pcoord(2))
3450	! returns the rank. A single coarse block will have to send data to multiple
3451	! fine blocks. In the coarse grid the pcoords of the remote block is first found and then using
3452	! f_rnk_lst the target_idex is identified.
3453	! blk_dim stores the index limits of a given block. blk_dim_remote is received
3454	! from the asscoiated nest partner.
3455	! cf_ratio(1:3) is the ratio between fine and coarse grid: nxc/nxf, nyc/nyf and
3456	! ceiling(dxc/dxf)
3457
3458
3459	USE control_parameters, &
3460	ONLY: coupling_mode
3461
3462	USE kinds
3463
3464	USE pegrid
3465
3466
3467	IMPLICIT NONE
3468
3469	INTEGER(iwp) :: dest_rnk
3470	INTEGER(iwp) :: i !<
3471
3472	IF (myid == 0) THEN
3473	IF ( coupling_mode == 'vnested_crse') THEN
3474	CALL MPI_SEND( pdims, 2, MPI_INTEGER, numprocs, 33, comm_inter, &
3475	ierr )
3476	CALL MPI_RECV( pdims_partner, 2, MPI_INTEGER, numprocs, 66, &
3477	comm_inter, status, ierr )
3478	ELSEIF ( coupling_mode == 'vnested_fine') THEN
3479	CALL MPI_RECV( pdims_partner, 2, MPI_INTEGER, 0, 33, &
3480	comm_inter, status, ierr )
3481	CALL MPI_SEND( pdims, 2, MPI_INTEGER, 0, 66, comm_inter, &
3482	ierr )
3483	ENDIF
3484	ENDIF
3485
3486
3487	IF ( coupling_mode == 'vnested_crse') THEN
3488	CALL MPI_BCAST( pdims_partner, 2, MPI_INTEGER, 0, comm2d, ierr )
3489	ALLOCATE( c_rnk_lst( 0:(pdims(1)-1) ,0:(pdims(2)-1) ) )
3490	ALLOCATE( f_rnk_lst( 0:(pdims_partner(1)-1) ,0:(pdims_partner(2)-1) ) )
3491	do i=0,numprocs-1
3492	CALL MPI_CART_COORDS( comm2d, i, ndim, pcoord, ierr )
3493	call MPI_Cart_rank(comm2d, pcoord, dest_rnk, ierr)
3494	c_rnk_lst(pcoord(1),pcoord(2)) = dest_rnk
3495	end do
3496	ELSEIF ( coupling_mode == 'vnested_fine') THEN
3497	CALL MPI_BCAST( pdims_partner, 2, MPI_INTEGER, 0, comm2d, ierr )
3498	ALLOCATE( c_rnk_lst( 0:(pdims_partner(1)-1) ,0:(pdims_partner(2)-1) ) )
3499	ALLOCATE( f_rnk_lst( 0:(pdims(1)-1) ,0:(pdims(2)-1) ) )
3500
3501	do i=0,numprocs-1
3502	CALL MPI_CART_COORDS( comm2d, i, ndim, pcoord, ierr )
3503	call MPI_Cart_rank(comm2d, pcoord, dest_rnk, ierr)
3504	f_rnk_lst(pcoord(1),pcoord(2)) = dest_rnk
3505	enddo
3506	ENDIF
3507
3508
3509	IF ( coupling_mode == 'vnested_crse') THEN
3510	if (myid == 0) then
3511	CALL MPI_SEND( c_rnk_lst, pdims(1)*pdims(2), MPI_INTEGER, numprocs, 0, comm_inter, ierr )
3512	CALL MPI_RECV( f_rnk_lst, pdims_partner(1)*pdims_partner(2), MPI_INTEGER, numprocs, 4, comm_inter,status, ierr )
3513	end if
3514	CALL MPI_BCAST( f_rnk_lst, pdims_partner(1)*pdims_partner(2), MPI_INTEGER, 0, comm2d, ierr )
3515	ELSEIF ( coupling_mode == 'vnested_fine') THEN
3516	if (myid == 0) then
3517	CALL MPI_RECV( c_rnk_lst, pdims_partner(1)*pdims_partner(2), MPI_INTEGER, 0, 0, comm_inter,status, ierr )
3518	CALL MPI_SEND( f_rnk_lst, pdims(1)*pdims(2), MPI_INTEGER, 0, 4, comm_inter, ierr )
3519	end if
3520	CALL MPI_BCAST( c_rnk_lst, pdims_partner(1)*pdims_partner(2), MPI_INTEGER, 0, comm2d, ierr )
3521	ENDIF
3522
3523	!-- Reason for MPI error unknown; solved if three lines duplicated
3524	CALL MPI_CART_COORDS( comm2d, myid, ndim, pcoord, ierr )
3525	CALL MPI_CART_SHIFT( comm2d, 0, 1, pleft, pright, ierr )
3526	CALL MPI_CART_SHIFT( comm2d, 1, 1, psouth, pnorth, ierr )
3527
3528
3529	#endif
3530
3531	END SUBROUTINE vnest_init_pegrid_rank
3532
3533
3534	SUBROUTINE vnest_init_pegrid_domain
3535	#if defined( __parallel )
3536
3537	USE control_parameters, &
3538	ONLY: coupling_mode, coupling_topology, dz, &
3539	dz_stretch_level_start, message_string
3540
3541	USE grid_variables, &
3542	ONLY: dx, dy
3543
3544	USE indices, &
3545	ONLY: nbgp, nx, ny, nz, nxl, nxr, nys, nyn, nzb, nzt
3546
3547	USE kinds
3548
3549	USE pegrid
3550
3551	IMPLICIT NONE
3552
3553	INTEGER(iwp) :: i !<
3554	INTEGER(iwp) :: j !<
3555	INTEGER(iwp) :: tempx
3556	INTEGER(iwp) :: tempy
3557	INTEGER(iwp) :: TYPE_INT_YZ
3558	INTEGER(iwp) :: SIZEOFREAL
3559	INTEGER(iwp) :: MTV_X
3560	INTEGER(iwp) :: MTV_Y
3561	INTEGER(iwp) :: MTV_Z
3562	INTEGER(iwp) :: MTV_RX
3563	INTEGER(iwp) :: MTV_RY
3564	INTEGER(iwp) :: MTV_RZ
3565
3566	!
3567	!-- Pass the number of grid points of the coarse model to
3568	!-- the nested model and vice versa
3569	IF ( coupling_mode == 'vnested_crse' ) THEN
3570
3571	nxc = nx
3572	nyc = ny
3573	nzc = nz
3574	dxc = dx
3575	dyc = dy
3576	dzc = dz(1)
3577	cg_nprocs = numprocs
3578
3579	IF ( myid == 0 ) THEN
3580
3581	CALL MPI_SEND( nxc, 1, MPI_INTEGER , numprocs, 1, comm_inter, &
3582	ierr )
3583	CALL MPI_SEND( nyc, 1, MPI_INTEGER , numprocs, 2, comm_inter, &
3584	ierr )
3585	CALL MPI_SEND( nzc, 1, MPI_INTEGER , numprocs, 3, comm_inter, &
3586	ierr )
3587	CALL MPI_SEND( dxc, 1, MPI_REAL , numprocs, 4, comm_inter, &
3588	ierr )
3589	CALL MPI_SEND( dyc, 1, MPI_REAL , numprocs, 5, comm_inter, &
3590	ierr )
3591	CALL MPI_SEND( dzc, 1, MPI_REAL , numprocs, 6, comm_inter, &
3592	ierr )
3593	CALL MPI_SEND( pdims, 2, MPI_INTEGER, numprocs, 7, comm_inter, &
3594	ierr )
3595	CALL MPI_SEND( cg_nprocs, 1, MPI_INTEGER, numprocs, 8, comm_inter, &
3596	ierr )
3597	CALL MPI_RECV( nxf, 1, MPI_INTEGER, numprocs, 21, comm_inter, &
3598	status, ierr )
3599	CALL MPI_RECV( nyf, 1, MPI_INTEGER, numprocs, 22, comm_inter, &
3600	status, ierr )
3601	CALL MPI_RECV( nzf, 1, MPI_INTEGER, numprocs, 23, comm_inter, &
3602	status, ierr )
3603	CALL MPI_RECV( dxf, 1, MPI_REAL, numprocs, 24, comm_inter, &
3604	status, ierr )
3605	CALL MPI_RECV( dyf, 1, MPI_REAL, numprocs, 25, comm_inter, &
3606	status, ierr )
3607	CALL MPI_RECV( dzf, 1, MPI_REAL, numprocs, 26, comm_inter, &
3608	status, ierr )
3609	CALL MPI_RECV( pdims_partner, 2, MPI_INTEGER, &
3610	numprocs, 27, comm_inter, status, ierr )
3611	CALL MPI_RECV( fg_nprocs, 1, MPI_INTEGER, &
3612	numprocs, 28, comm_inter, status, ierr )
3613	ENDIF
3614
3615	CALL MPI_BCAST( nxf, 1, MPI_INTEGER, 0, comm2d, ierr )
3616	CALL MPI_BCAST( nyf, 1, MPI_INTEGER, 0, comm2d, ierr )
3617	CALL MPI_BCAST( nzf, 1, MPI_INTEGER, 0, comm2d, ierr )
3618	CALL MPI_BCAST( dxf, 1, MPI_REAL, 0, comm2d, ierr )
3619	CALL MPI_BCAST( dyf, 1, MPI_REAL, 0, comm2d, ierr )
3620	CALL MPI_BCAST( dzf, 1, MPI_REAL, 0, comm2d, ierr )
3621	CALL MPI_BCAST( pdims_partner, 2, MPI_INTEGER, 0, comm2d, ierr )
3622	CALL MPI_BCAST( fg_nprocs, 1, MPI_INTEGER, 0, comm2d, ierr )
3623
3624	!
3625	!-- Check if stretching is used within the nested domain. ABS(...) is
3626	!-- necessary because of the default value of -9999999.9_wp (negative)
3627	IF ( ABS( dz_stretch_level_start(1) ) <= (nzf+1)*dzf ) THEN
3628	message_string = 'Stretching in the parent domain is '// &
3629	'only allowed above the nested domain'
3630	CALL message( 'vnest_init_pegrid_domain', 'PA0497', 1, 2, 0, 6, 0 )
3631	ENDIF
3632
3633	ELSEIF ( coupling_mode == 'vnested_fine' ) THEN
3634
3635	nxf = nx
3636	nyf = ny
3637	nzf = nz
3638	dxf = dx
3639	dyf = dy
3640	dzf = dz(1)
3641	fg_nprocs = numprocs
3642
3643	IF ( myid == 0 ) THEN
3644
3645	CALL MPI_RECV( nxc, 1, MPI_INTEGER, 0, 1, comm_inter, status, &
3646	ierr )
3647	CALL MPI_RECV( nyc, 1, MPI_INTEGER, 0, 2, comm_inter, status, &
3648	ierr )
3649	CALL MPI_RECV( nzc, 1, MPI_INTEGER, 0, 3, comm_inter, status, &
3650	ierr )
3651	CALL MPI_RECV( dxc, 1, MPI_REAL, 0, 4, comm_inter, status, &
3652	ierr )
3653	CALL MPI_RECV( dyc, 1, MPI_REAL, 0, 5, comm_inter, status, &
3654	ierr )
3655	CALL MPI_RECV( dzc, 1, MPI_REAL, 0, 6, comm_inter, status, &
3656	ierr )
3657	CALL MPI_RECV( pdims_partner, 2, MPI_INTEGER, 0, 7, comm_inter, &
3658	status, ierr )
3659	CALL MPI_RECV( cg_nprocs, 1, MPI_INTEGER, 0, 8, comm_inter, &
3660	status, ierr )
3661	CALL MPI_SEND( nxf, 1, MPI_INTEGER, 0, 21, comm_inter, ierr )
3662	CALL MPI_SEND( nyf, 1, MPI_INTEGER, 0, 22, comm_inter, ierr )
3663	CALL MPI_SEND( nzf, 1, MPI_INTEGER, 0, 23, comm_inter, ierr )
3664	CALL MPI_SEND( dxf, 1, MPI_REAL, 0, 24, comm_inter, ierr )
3665	CALL MPI_SEND( dyf, 1, MPI_REAL, 0, 25, comm_inter, ierr )
3666	CALL MPI_SEND( dzf, 1, MPI_REAL, 0, 26, comm_inter, ierr )
3667	CALL MPI_SEND( pdims,2,MPI_INTEGER, 0, 27, comm_inter, ierr )
3668	CALL MPI_SEND( fg_nprocs,1,MPI_INTEGER, 0, 28, comm_inter, ierr )
3669	ENDIF
3670
3671	CALL MPI_BCAST( nxc, 1, MPI_INTEGER, 0, comm2d, ierr)
3672	CALL MPI_BCAST( nyc, 1, MPI_INTEGER, 0, comm2d, ierr)
3673	CALL MPI_BCAST( nzc, 1, MPI_INTEGER, 0, comm2d, ierr)
3674	CALL MPI_BCAST( dxc, 1, MPI_REAL, 0, comm2d, ierr)
3675	CALL MPI_BCAST( dyc, 1, MPI_REAL, 0, comm2d, ierr)
3676	CALL MPI_BCAST( dzc, 1, MPI_REAL, 0, comm2d, ierr)
3677	CALL MPI_BCAST( pdims_partner, 2, MPI_INTEGER, 0, comm2d, ierr)
3678	CALL MPI_BCAST( cg_nprocs, 1, MPI_INTEGER, 0, comm2d, ierr)
3679
3680	ENDIF
3681
3682	ngp_c = ( nxc+1 + 2 * nbgp ) * ( nyc+1 + 2 * nbgp )
3683	ngp_f = ( nxf+1 + 2 * nbgp ) * ( nyf+1 + 2 * nbgp )
3684
3685	IF ( coupling_mode(1:8) == 'vnested_') coupling_topology = 1
3686
3687
3688	!-- Nesting Ratio: For each coarse grid cell how many fine grid cells exist
3689	cfratio(1) = INT ( (nxf+1) / (nxc+1) )
3690	cfratio(2) = INT ( (nyf+1) / (nyc+1) )
3691	cfratio(3) = CEILING ( dzc / dzf )
3692
3693	!-- target_id is used only for exhange of information like simulated_time
3694	!-- which are then MPI_BCAST to other processors in the group
3695	IF ( myid == 0 ) THEN
3696
3697	IF ( TRIM( coupling_mode ) == 'vnested_crse' ) THEN
3698	target_id = numprocs
3699	ELSE IF ( TRIM( coupling_mode ) == 'vnested_fine' ) THEN
3700	target_id = 0
3701	ENDIF
3702
3703	ENDIF
3704
3705	!-- Store partner grid dimenstions and create MPI derived types
3706
3707	IF ( coupling_mode == 'vnested_crse' ) THEN
3708
3709	offset(1) = ( pdims_partner(1) / pdims(1) ) * pcoord(1)
3710	offset(2) = ( pdims_partner(2) / pdims(2) ) * pcoord(2)
3711
3712	tempx = ( pdims_partner(1) / pdims(1) ) - 1
3713	tempy = ( pdims_partner(2) / pdims(2) ) - 1
3714	ALLOCATE( c2f_dims_cg (0:5,offset(1):tempx+offset(1),offset(2):tempy+offset(2) ) )
3715	ALLOCATE( f2c_dims_cg (0:5,offset(1):tempx+offset(1),offset(2):tempy+offset(2) ) )
3716
3717	do j = 0, ( pdims_partner(2) / pdims(2) ) - 1
3718	do i = 0, ( pdims_partner(1) / pdims(1) ) - 1
3719	map_coord(1) = i+offset(1)
3720	map_coord(2) = j+offset(2)
3721
3722	target_idex = f_rnk_lst(map_coord(1),map_coord(2)) + numprocs
3723
3724	CALL MPI_RECV( bdims_rem, 6, MPI_INTEGER, target_idex, 10, &
3725	comm_inter,status, ierr )
3726
3727	!-- Store the CG dimensions that correspond to the FG partner; needed for FG top BC
3728	!-- One CG can have multiple FG partners. The 3D array is mapped by partner proc co-ord
3729	c2f_dims_cg (0,map_coord(1),map_coord(2)) = bdims_rem (1,1) / cfratio(1)
3730	c2f_dims_cg (1,map_coord(1),map_coord(2)) = bdims_rem (1,2) / cfratio(1)
3731	c2f_dims_cg (2,map_coord(1),map_coord(2)) = bdims_rem (2,1) / cfratio(2)
3732	c2f_dims_cg (3,map_coord(1),map_coord(2)) = bdims_rem (2,2) / cfratio(2)
3733	c2f_dims_cg (4,map_coord(1),map_coord(2)) = bdims_rem (3,2) / cfratio(3)
3734	c2f_dims_cg (5,map_coord(1),map_coord(2)) =(bdims_rem (3,2) / cfratio(3)) + 2
3735
3736	!-- Store the CG dimensions that correspond to the FG partner; needed for anterpolation
3737	f2c_dims_cg (0,map_coord(1),map_coord(2)) = bdims_rem (1,1) / cfratio(1)
3738	f2c_dims_cg (1,map_coord(1),map_coord(2)) = bdims_rem (1,2) / cfratio(1)
3739	f2c_dims_cg (2,map_coord(1),map_coord(2)) = bdims_rem (2,1) / cfratio(2)
3740	f2c_dims_cg (3,map_coord(1),map_coord(2)) = bdims_rem (2,2) / cfratio(2)
3741	f2c_dims_cg (4,map_coord(1),map_coord(2)) = bdims_rem (3,1)
3742	f2c_dims_cg (5,map_coord(1),map_coord(2)) =(bdims_rem (3,2)-cfratio(3))/ cfratio(3)
3743
3744	CALL MPI_SEND( c2f_dims_cg (:,map_coord(1),map_coord(2)), 6, &
3745	MPI_INTEGER, target_idex, 100, comm_inter, ierr )
3746
3747	CALL MPI_SEND( f2c_dims_cg (:,map_coord(1),map_coord(2)), 6, &
3748	MPI_INTEGER, target_idex, 101, comm_inter, ierr )
3749
3750	end do
3751	end do
3752
3753	!-- A derived data type to pack 3 Z-levels of CG to set FG top BC
3754	MTV_X = ( nxr - nxl + 1 ) + 2*nbgp
3755	MTV_Y = ( nyn - nys + 1 ) + 2*nbgp
3756	MTV_Z = nzt+1 - nzb +1
3757
3758	MTV_RX = ( c2f_dims_cg (1,offset(1),offset(2)) - c2f_dims_cg (0,offset(1),offset(2)) ) +1+2
3759	MTV_RY = ( c2f_dims_cg (3,offset(1),offset(2)) - c2f_dims_cg (2,offset(1),offset(2)) ) +1+2
3760	MTV_RZ = ( c2f_dims_cg (5,offset(1),offset(2)) - c2f_dims_cg (4,offset(1),offset(2)) ) +1
3761
3762	CALL MPI_TYPE_EXTENT(MPI_REAL, SIZEOFREAL, IERR)
3763
3764	CALL MPI_TYPE_VECTOR ( MTV_RY, MTV_RZ, MTV_Z, MPI_REAL, TYPE_INT_YZ, IERR)
3765	CALL MPI_TYPE_HVECTOR( MTV_RX, 1, MTV_ZMTV_YSIZEOFREAL, &
3766	TYPE_INT_YZ, TYPE_VNEST_BC, IERR)
3767	CALL MPI_TYPE_FREE(TYPE_INT_YZ, IERR)
3768	CALL MPI_TYPE_COMMIT(TYPE_VNEST_BC, IERR)
3769
3770
3771	ELSEIF ( coupling_mode == 'vnested_fine' ) THEN
3772
3773	ALLOCATE( c2f_dims_fg (0:5) )
3774	ALLOCATE( f2c_dims_fg (0:5) )
3775
3776	offset(1) = pcoord(1) / ( pdims(1)/pdims_partner(1) )
3777	offset(2) = pcoord(2) / ( pdims(2)/pdims_partner(2) )
3778	map_coord(1) = offset(1)
3779	map_coord(2) = offset(2)
3780	target_idex = c_rnk_lst(map_coord(1),map_coord(2))
3781
3782	bdims (1,1) = nxl
3783	bdims (1,2) = nxr
3784	bdims (2,1) = nys
3785	bdims (2,2) = nyn
3786	bdims (3,1) = nzb
3787	bdims (3,2) = nzt
3788
3789	CALL MPI_SEND( bdims, 6, MPI_INTEGER, target_idex, 10, &
3790	comm_inter, ierr )
3791
3792	!-- Store the CG dimensions that correspond to the FG partner; needed for FG top BC
3793	!-- One FG can have only one CG partner
3794	CALL MPI_RECV( c2f_dims_fg, 6, MPI_INTEGER, target_idex, 100, &
3795	comm_inter,status, ierr )
3796
3797	CALL MPI_RECV( f2c_dims_fg, 6, MPI_INTEGER, target_idex, 101, &
3798	comm_inter,status, ierr )
3799
3800	!-- Store the CG dimensions that correspond to the FG partner; needed for anterpolation
3801
3802	n_cell_c = (f2c_dims_fg(1)-f2c_dims_fg(0)+1) * &
3803	(f2c_dims_fg(3)-f2c_dims_fg(2)+1) * &
3804	(f2c_dims_fg(5)-f2c_dims_fg(4)+0)
3805
3806	CALL MPI_TYPE_CONTIGUOUS(n_cell_c, MPI_REAL, TYPE_VNEST_ANTER, IERR)
3807	CALL MPI_TYPE_COMMIT(TYPE_VNEST_ANTER, ierr)
3808
3809	ENDIF
3810	#endif
3811	END SUBROUTINE vnest_init_pegrid_domain
3812
3813
3814	SUBROUTINE vnest_init_grid
3815
3816	#if defined( __parallel )
3817	USE arrays_3d, &
3818	ONLY: zu, zw
3819
3820	USE control_parameters, &
3821	ONLY: coupling_mode, message_string, number_stretch_level_start
3822
3823	USE indices, &
3824	ONLY: nzt
3825
3826	USE kinds
3827
3828	USE pegrid
3829
3830	IMPLICIT NONE
3831
3832	!
3833	!-- Allocate and Exchange zuc and zuf, zwc and zwf
3834	IF ( coupling_mode(1:8) == 'vnested_' ) THEN
3835
3836	ALLOCATE( zuc(0:nzc+1), zuf(0:nzf+1) )
3837	ALLOCATE( zwc(0:nzc+1), zwf(0:nzf+1) )
3838
3839	IF ( coupling_mode == 'vnested_crse' ) THEN
3840
3841	zuc = zu
3842	zwc = zw
3843
3844	IF ( myid == 0 ) THEN
3845
3846	CALL MPI_SEND( zuc, nzt+2, MPI_REAL, numprocs, 41, comm_inter, &
3847	ierr )
3848	CALL MPI_RECV( zuf, nzf+2, MPI_REAL, numprocs, 42, comm_inter, &
3849	status, ierr )
3850
3851	CALL MPI_SEND( zwc, nzt+2, MPI_REAL, numprocs, 43, comm_inter, &
3852	ierr )
3853	CALL MPI_RECV( zwf, nzf+2, MPI_REAL, numprocs, 44, comm_inter, &
3854	status, ierr )
3855
3856	ENDIF
3857
3858	CALL MPI_BCAST( zuf,nzf+2,MPI_REAL, 0, comm2d, ierr )
3859	CALL MPI_BCAST( zwf,nzf+2,MPI_REAL, 0, comm2d, ierr )
3860
3861	ELSEIF ( coupling_mode == 'vnested_fine' ) THEN
3862
3863	!
3864	!-- Check if stretching is used within the nested domain
3865	IF ( number_stretch_level_start > 0 ) THEN
3866	message_string = 'Stretching in the nested domain is not '//&
3867	'allowed'
3868	CALL message( 'vnest_init_grid', 'PA0498', 1, 2, 0, 6, 0 )
3869	ENDIF
3870
3871	zuf = zu
3872	zwf = zw
3873
3874	IF ( myid == 0 ) THEN
3875
3876	CALL MPI_RECV( zuc,nzc+2, MPI_REAL, 0, 41, comm_inter, status, &
3877	ierr )
3878	CALL MPI_SEND( zuf,nzt+2, MPI_REAL, 0, 42, comm_inter, ierr )
3879
3880	CALL MPI_RECV( zwc,nzc+2, MPI_REAL, 0, 43, comm_inter, status, &
3881	ierr )
3882	CALL MPI_SEND( zwf,nzt+2, MPI_REAL, 0, 44, comm_inter, ierr )
3883	ENDIF
3884
3885	CALL MPI_BCAST( zuc,nzc+2,MPI_REAL, 0, comm2d, ierr )
3886	CALL MPI_BCAST( zwc,nzc+2,MPI_REAL, 0, comm2d, ierr )
3887
3888	ENDIF
3889	ENDIF
3890
3891	#endif
3892	END SUBROUTINE vnest_init_grid
3893
3894
3895	SUBROUTINE vnest_check_parameters
3896	#if defined( __parallel )
3897
3898	USE pegrid, &
3899	ONLY: myid
3900
3901	IMPLICIT NONE
3902
3903	IF (myid==0) PRINT, ' vnest: check parameters not implemented yet *'
3904
3905	#endif
3906	END SUBROUTINE vnest_check_parameters
3907
3908
3909	SUBROUTINE vnest_timestep_sync
3910
3911	#if defined( __parallel )
3912	USE control_parameters, &
3913	ONLY: coupling_mode, dt_3d
3914
3915	USE interfaces
3916
3917	USE kinds
3918
3919	USE pegrid
3920
3921	IMPLICIT NONE
3922
3923	IF ( coupling_mode == 'vnested_crse') THEN
3924	dtc = dt_3d
3925	if (myid == 0) then
3926	CALL MPI_SEND( dt_3d, 1, MPI_REAL, target_id, &
3927	31, comm_inter, ierr )
3928	CALL MPI_RECV( dtf, 1, MPI_REAL, &
3929	target_id, 32, comm_inter, status, ierr )
3930
3931	endif
3932	CALL MPI_BCAST( dtf, 1, MPI_REAL, 0, comm2d, ierr )
3933	ELSE
3934	dtf = dt_3d
3935	if (myid == 0) then
3936	CALL MPI_RECV( dtc, 1, MPI_REAL, &
3937	target_id, 31, comm_inter, status, ierr )
3938	CALL MPI_SEND( dt_3d, 1, MPI_REAL, target_id, &
3939	32, comm_inter, ierr )
3940
3941	endif
3942	CALL MPI_BCAST( dtc, 1, MPI_REAL, 0, comm2d, ierr )
3943
3944	ENDIF
3945	!-- Identical timestep for coarse and fine grids
3946	dt_3d = MIN( dtc, dtf )
3947	#endif
3948	END SUBROUTINE vnest_timestep_sync
3949
3950	SUBROUTINE vnest_deallocate
3951	#if defined( __parallel )
3952	USE control_parameters, &
3953	ONLY: coupling_mode
3954
3955	IMPLICIT NONE
3956
3957	IF ( ALLOCATED(c_rnk_lst) ) DEALLOCATE (c_rnk_lst)
3958	IF ( ALLOCATED(f_rnk_lst) ) DEALLOCATE (f_rnk_lst)
3959
3960	IF ( coupling_mode == 'vnested_crse') THEN
3961	IF ( ALLOCATED (c2f_dims_cg) ) DEALLOCATE (c2f_dims_cg)
3962	IF ( ALLOCATED (f2c_dims_cg) ) DEALLOCATE (f2c_dims_cg)
3963	ELSEIF( coupling_mode == 'vnested_fine' ) THEN
3964	IF ( ALLOCATED (c2f_dims_fg) ) DEALLOCATE (c2f_dims_fg)
3965	IF ( ALLOCATED (f2c_dims_fg) ) DEALLOCATE (f2c_dims_fg)
3966	ENDIF
3967	#endif
3968	END SUBROUTINE vnest_deallocate
3969
3970	END MODULE vertical_nesting_mod

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |