Home

Context Navigation

lagrangian_particle_model_mod.f90 @ 4043

Last change on this file since 4043 was 4043, checked in by schwenkel, 4 years ago
further modularization of lpm and delete min_nr_particle
Property svn:keywords set to `Id`
File size: 338.6 KB

Line
1	!> @file lagrangian_particle_model_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	!------------------------------------------------------------------------------!
19	!
20	! Current revisions:
21	! ------------------
22	!
23	!
24	! Former revisions:
25	! -----------------
26	! $Id: lagrangian_particle_model_mod.f90 4043 2019-06-18 16:59:00Z schwenkel $
27	! Remove min_nr_particle, Add lpm_droplet_interactions_ptq into module
28	!
29	! 4028 2019-06-13 12:21:37Z schwenkel
30	! Further modularization of particle code components
31	!
32	! 4020 2019-06-06 14:57:48Z schwenkel
33	! Removing submodules
34	!
35	! 4018 2019-06-06 13:41:50Z eckhard
36	! Bugfix for former revision
37	!
38	! 4017 2019-06-06 12:16:46Z schwenkel
39	! Modularization of all lagrangian particle model code components
40	!
41	! 3655 2019-01-07 16:51:22Z knoop
42	! bugfix to guarantee correct particle releases in case that the release
43	! interval is smaller than the model timestep
44	!
45	! 2801 2018-02-14 16:01:55Z thiele
46	! Changed lpm from subroutine to module.
47	! Introduce particle transfer in nested models.
48	!
49	! 2718 2018-01-02 08:49:38Z maronga
50	! Corrected "Former revisions" section
51	!
52	! 2701 2017-12-15 15:40:50Z suehring
53	! Changes from last commit documented
54	!
55	! 2698 2017-12-14 18:46:24Z suehring
56	! Grid indices passed to lpm_boundary_conds. (responsible Philipp Thiele)
57	!
58	! 2696 2017-12-14 17:12:51Z kanani
59	! Change in file header (GPL part)
60	!
61	! 2606 2017-11-10 10:36:31Z schwenkel
62	! Changed particle box locations: center of particle box now coincides
63	! with scalar grid point of same index.
64	! Renamed module and subroutines: lpm_pack_arrays_mod -> lpm_pack_and_sort_mod
65	! lpm_pack_all_arrays -> lpm_sort_in_subboxes, lpm_pack_arrays -> lpm_pack
66	! lpm_sort -> lpm_sort_timeloop_done
67	!
68	! 2418 2017-09-06 15:24:24Z suehring
69	! Major bugfixes in modeling SGS particle speeds (since revision 1359).
70	! Particle sorting added to distinguish between already completed and
71	! non-completed particles.
72	!
73	! 2263 2017-06-08 14:59:01Z schwenkel
74	! Implemented splitting and merging algorithm
75	!
76	! 2233 2017-05-30 18:08:54Z suehring
77	!
78	! 2232 2017-05-30 17:47:52Z suehring
79	! Adjustments to new topography concept
80	!
81	! 2000 2016-08-20 18:09:15Z knoop
82	! Forced header and separation lines into 80 columns
83	!
84	! 1936 2016-06-13 13:37:44Z suehring
85	! Call routine for deallocation of unused memory.
86	! Formatting adjustments
87	!
88	! 1929 2016-06-09 16:25:25Z suehring
89	! Call wall boundary conditions only if particles are in the vertical range of
90	! topography.
91	!
92	! 1822 2016-04-07 07:49:42Z hoffmann
93	! Tails removed.
94	!
95	! Initialization of sgs model not necessary for the use of cloud_droplets and
96	! use_sgs_for_particles.
97	!
98	! lpm_release_set integrated.
99	!
100	! Unused variabled removed.
101	!
102	! 1682 2015-10-07 23:56:08Z knoop
103	! Code annotations made doxygen readable
104	!
105	! 1416 2014-06-04 16:04:03Z suehring
106	! user_lpm_advec is called for each gridpoint.
107	! Bugfix: in order to prevent an infinite loop, time_loop_done is set .TRUE.
108	! at the head of the do-loop.
109	!
110	! 1359 2014-04-11 17:15:14Z hoffmann
111	! New particle structure integrated.
112	! Kind definition added to all floating point numbers.
113	!
114	! 1320 2014-03-20 08:40:49Z raasch
115	! ONLY-attribute added to USE-statements,
116	! kind-parameters added to all INTEGER and REAL declaration statements,
117	! kinds are defined in new module kinds,
118	! revision history before 2012 removed,
119	! comment fields (!:) to be used for variable explanations added to
120	! all variable declaration statements
121	!
122	! 1318 2014-03-17 13:35:16Z raasch
123	! module interfaces removed
124	!
125	! 1036 2012-10-22 13:43:42Z raasch
126	! code put under GPL (PALM 3.9)
127	!
128	! 851 2012-03-15 14:32:58Z raasch
129	! Bugfix: resetting of particle_mask and tail mask moved from routine
130	! lpm_exchange_horiz to here (end of sub-timestep loop)
131	!
132	! 849 2012-03-15 10:35:09Z raasch
133	! original routine advec_particles split into several subroutines and renamed
134	! lpm
135	!
136	! 831 2012-02-22 00:29:39Z raasch
137	! thermal_conductivity_l and diff_coeff_l now depend on temperature and
138	! pressure
139	!
140	! 828 2012-02-21 12:00:36Z raasch
141	! fast hall/wang kernels with fixed radius/dissipation classes added,
142	! particle feature color renamed class, routine colker renamed
143	! recalculate_kernel,
144	! lower limit for droplet radius changed from 1E-7 to 1E-8
145	!
146	! Bugfix: transformation factor for dissipation changed from 1E5 to 1E4
147	!
148	! 825 2012-02-19 03:03:44Z raasch
149	! droplet growth by condensation may include curvature and solution effects,
150	! initialisation of temporary particle array for resorting removed,
151	! particle attributes speed_x\|y\|z_sgs renamed rvar1\|2\|3,
152	! module wang_kernel_mod renamed lpm_collision_kernels_mod,
153	! wang_collision_kernel renamed wang_kernel
154	!
155	!
156	! Revision 1.1 1999/11/25 16:16:06 raasch
157	! Initial revision
158	!
159	!
160	! Description:
161	! ------------
162	!>
163	!------------------------------------------------------------------------------!
164	MODULE lagrangian_particle_model_mod
165
166	USE, INTRINSIC :: ISO_C_BINDING
167
168	USE arrays_3d, &
169	ONLY: de_dx, de_dy, de_dz, dzw, zu, zw, ql_c, ql_v, ql_vp, hyp, &
170	pt, q, exner, ql, diss, e, u, v, w, km, ql_1, ql_2, pt_p, q_p, &
171	d_exner
172
173	USE averaging, &
174	ONLY: ql_c_av, pr_av, pc_av, ql_vp_av, ql_v_av
175
176	USE basic_constants_and_equations_mod, &
177	ONLY: molecular_weight_of_solute, molecular_weight_of_water, magnus, &
178	pi, rd_d_rv, rho_l, r_v, rho_s, vanthoff, l_v, kappa, g, lv_d_cp
179
180	USE control_parameters, &
181	ONLY: bc_dirichlet_l, bc_dirichlet_n, bc_dirichlet_r, bc_dirichlet_s, &
182	cloud_droplets, constant_flux_layer, current_timestep_number, &
183	dt_3d, dt_3d_reached, humidity, &
184	dt_3d_reached_l, dt_dopts, dz, initializing_actions, &
185	message_string, molecular_viscosity, ocean_mode, &
186	particle_maximum_age, iran, &
187	simulated_time, topography, dopts_time_count, &
188	time_since_reference_point, rho_surface, u_gtrans, v_gtrans
189
190	USE cpulog, &
191	ONLY: cpu_log, log_point, log_point_s
192
193	USE indices, &
194	ONLY: nx, nxl, nxlg, nxrg, nxr, ny, nyn, nys, nyng, nysg, nz, nzb, &
195	nzb_max, nzt, wall_flags_0,nbgp, ngp_2dh_outer
196
197	USE kinds
198
199	USE pegrid
200
201	USE particle_attributes
202
203	USE pmc_particle_interface, &
204	ONLY: pmcp_c_get_particle_from_parent, pmcp_p_fill_particle_win, &
205	pmcp_c_send_particle_to_parent, pmcp_p_empty_particle_win, &
206	pmcp_p_delete_particles_in_fine_grid_area, pmcp_g_init, &
207	pmcp_g_print_number_of_particles
208
209	USE pmc_interface, &
210	ONLY: nested_run
211
212	USE grid_variables, &
213	ONLY: ddx, dx, ddy, dy
214
215	USE netcdf_interface, &
216	ONLY: netcdf_data_format, netcdf_deflate, dopts_num, id_set_pts, &
217	id_var_dopts, id_var_time_pts, nc_stat, &
218	netcdf_handle_error
219
220	USE random_function_mod, &
221	ONLY: random_function
222
223	USE statistics, &
224	ONLY: hom
225
226	USE surface_mod, &
227	ONLY: get_topography_top_index_ji, surf_def_h, surf_lsm_h, surf_usm_h,&
228	bc_h
229
230	#if defined( __parallel ) && !defined( __mpifh )
231	USE MPI
232	#endif
233
234	#if defined( __parallel ) && defined( __mpifh )
235	INCLUDE "mpif.h"
236	#endif
237
238	#if defined( __netcdf )
239	USE NETCDF
240	#endif
241
242
243	USE arrays_3d, &
244	ONLY:
245
246	USE indices, &
247	ONLY: nxl, nxr, nyn, nys, nzb, nzt, wall_flags_0
248
249	USE kinds
250
251	USE pegrid
252
253	IMPLICIT NONE
254
255	CHARACTER(LEN=15) :: aero_species = 'nacl' !< aerosol species
256	CHARACTER(LEN=15) :: aero_type = 'maritime' !< aerosol type
257	CHARACTER(LEN=15) :: bc_par_lr = 'cyclic' !< left/right boundary condition
258	CHARACTER(LEN=15) :: bc_par_ns = 'cyclic' !< north/south boundary condition
259	CHARACTER(LEN=15) :: bc_par_b = 'reflect' !< bottom boundary condition
260	CHARACTER(LEN=15) :: bc_par_t = 'absorb' !< top boundary condition
261	CHARACTER(LEN=15) :: collision_kernel = 'none' !< collision kernel
262
263	CHARACTER(LEN=5) :: splitting_function = 'gamma' !< function for calculation critical weighting factor
264	CHARACTER(LEN=5) :: splitting_mode = 'const' !< splitting mode
265
266	INTEGER(iwp) :: deleted_particles = 0 !< number of deleted particles per time step
267	INTEGER(iwp) :: i_splitting_mode !< dummy for splitting mode
268	INTEGER(iwp) :: iran_part = -1234567 !< number for random generator
269	INTEGER(iwp) :: max_number_particles_per_gridbox = 100 !< namelist parameter (see documentation)
270	INTEGER(iwp) :: isf !< dummy for splitting function
271	INTEGER(iwp) :: number_particles_per_gridbox = -1 !< namelist parameter (see documentation)
272	INTEGER(iwp) :: number_of_sublayers = 20 !< number of sublayers for particle velocities betwenn surface and first grid level
273	INTEGER(iwp) :: offset_ocean_nzt = 0 !< in case of oceans runs, the vertical index calculations need an offset
274	INTEGER(iwp) :: offset_ocean_nzt_m1 = 0 !< in case of oceans runs, the vertical index calculations need an offset
275	INTEGER(iwp) :: particles_per_point = 1 !< namelist parameter (see documentation)
276	INTEGER(iwp) :: radius_classes = 20 !< namelist parameter (see documentation)
277	INTEGER(iwp) :: splitting_factor = 2 !< namelist parameter (see documentation)
278	INTEGER(iwp) :: splitting_factor_max = 5 !< namelist parameter (see documentation)
279	INTEGER(iwp) :: step_dealloc = 100 !< namelist parameter (see documentation)
280	INTEGER(iwp) :: total_number_of_particles !< total number of particles in the whole model domain
281	INTEGER(iwp) :: trlp_count_sum !< parameter for particle exchange of PEs
282	INTEGER(iwp) :: trlp_count_recv_sum !< parameter for particle exchange of PEs
283	INTEGER(iwp) :: trrp_count_sum !< parameter for particle exchange of PEs
284	INTEGER(iwp) :: trrp_count_recv_sum !< parameter for particle exchange of PEs
285	INTEGER(iwp) :: trsp_count_sum !< parameter for particle exchange of PEs
286	INTEGER(iwp) :: trsp_count_recv_sum !< parameter for particle exchange of PEs
287	INTEGER(iwp) :: trnp_count_sum !< parameter for particle exchange of PEs
288	INTEGER(iwp) :: trnp_count_recv_sum !< parameter for particle exchange of PEs
289
290	LOGICAL :: lagrangian_particle_model = .FALSE. !< namelist parameter (see documentation)
291	LOGICAL :: curvature_solution_effects = .FALSE. !< namelist parameter (see documentation)
292	LOGICAL :: deallocate_memory = .TRUE. !< namelist parameter (see documentation)
293	LOGICAL :: hall_kernel = .FALSE. !< flag for collision kernel
294	LOGICAL :: merging = .FALSE. !< namelist parameter (see documentation)
295	LOGICAL :: random_start_position = .FALSE. !< namelist parameter (see documentation)
296	LOGICAL :: read_particles_from_restartfile = .TRUE. !< namelist parameter (see documentation)
297	LOGICAL :: seed_follows_topography = .FALSE. !< namelist parameter (see documentation)
298	LOGICAL :: splitting = .FALSE. !< namelist parameter (see documentation)
299	LOGICAL :: use_kernel_tables = .FALSE. !< parameter, which turns on the use of precalculated collision kernels
300	LOGICAL :: write_particle_statistics = .FALSE. !< namelist parameter (see documentation)
301
302	LOGICAL, DIMENSION(max_number_of_particle_groups) :: vertical_particle_advection = .TRUE. !< Switch for vertical particle transport
303
304	REAL(wp) :: aero_weight = 1.0_wp !< namelist parameter (see documentation)
305	REAL(wp) :: dt_min_part = 0.0002_wp !< minimum particle time step when SGS velocities are used (s)
306	REAL(wp) :: dt_prel = 9999999.9_wp !< namelist parameter (see documentation)
307	REAL(wp) :: dt_write_particle_data = 9999999.9_wp !< namelist parameter (see documentation)
308	REAL(wp) :: end_time_prel = 9999999.9_wp !< namelist parameter (see documentation)
309	REAL(wp) :: initial_weighting_factor = 1.0_wp !< namelist parameter (see documentation)
310	REAL(wp) :: last_particle_release_time = 0.0_wp !< last time of particle release
311	REAL(wp) :: log_sigma(3) = 1.0_wp !< namelist parameter (see documentation)
312	REAL(wp) :: na(3) = 0.0_wp !< namelist parameter (see documentation)
313	REAL(wp) :: number_concentration = -1.0_wp !< namelist parameter (see documentation)
314	REAL(wp) :: radius_merge = 1.0E-7_wp !< namelist parameter (see documentation)
315	REAL(wp) :: radius_split = 40.0E-6_wp !< namelist parameter (see documentation)
316	REAL(wp) :: rm(3) = 1.0E-6_wp !< namelist parameter (see documentation)
317	REAL(wp) :: sgs_wf_part !< parameter for sgs
318	REAL(wp) :: time_write_particle_data = 0.0_wp !< write particle data at current time on file
319	REAL(wp) :: weight_factor_merge = -1.0_wp !< namelist parameter (see documentation)
320	REAL(wp) :: weight_factor_split = -1.0_wp !< namelist parameter (see documentation)
321	REAL(wp) :: z0_av_global !< horizontal mean value of z0
322
323	REAL(wp) :: rclass_lbound !<
324	REAL(wp) :: rclass_ubound !<
325
326	REAL(wp), PARAMETER :: c_0 = 3.0_wp !< parameter for lagrangian timescale
327
328	REAL(wp), DIMENSION(max_number_of_particle_groups) :: density_ratio = 9999999.9_wp !< namelist parameter (see documentation)
329	REAL(wp), DIMENSION(max_number_of_particle_groups) :: pdx = 9999999.9_wp !< namelist parameter (see documentation)
330	REAL(wp), DIMENSION(max_number_of_particle_groups) :: pdy = 9999999.9_wp !< namelist parameter (see documentation)
331	REAL(wp), DIMENSION(max_number_of_particle_groups) :: pdz = 9999999.9_wp !< namelist parameter (see documentation)
332	REAL(wp), DIMENSION(max_number_of_particle_groups) :: psb = 9999999.9_wp !< namelist parameter (see documentation)
333	REAL(wp), DIMENSION(max_number_of_particle_groups) :: psl = 9999999.9_wp !< namelist parameter (see documentation)
334	REAL(wp), DIMENSION(max_number_of_particle_groups) :: psn = 9999999.9_wp !< namelist parameter (see documentation)
335	REAL(wp), DIMENSION(max_number_of_particle_groups) :: psr = 9999999.9_wp !< namelist parameter (see documentation)
336	REAL(wp), DIMENSION(max_number_of_particle_groups) :: pss = 9999999.9_wp !< namelist parameter (see documentation)
337	REAL(wp), DIMENSION(max_number_of_particle_groups) :: pst = 9999999.9_wp !< namelist parameter (see documentation).
338	REAL(wp), DIMENSION(max_number_of_particle_groups) :: radius = 9999999.9_wp !< namelist parameter (see documentation)
339
340	REAL(wp), DIMENSION(:), ALLOCATABLE :: log_z_z0 !< Precalculate LOG(z/z0)
341
342	INTEGER(iwp), PARAMETER :: NR_2_direction_move = 10000 !<
343	INTEGER(iwp) :: nr_move_north !<
344	INTEGER(iwp) :: nr_move_south !<
345
346	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: move_also_north
347	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: move_also_south
348
349	REAL(wp) :: epsilon_collision !<
350	REAL(wp) :: urms !<
351
352	REAL(wp), DIMENSION(:), ALLOCATABLE :: epsclass !< dissipation rate class
353	REAL(wp), DIMENSION(:), ALLOCATABLE :: radclass !< radius class
354	REAL(wp), DIMENSION(:), ALLOCATABLE :: winf !<
355
356	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ec !<
357	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ecf !<
358	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: gck !<
359	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: hkernel !<
360	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: hwratio !<
361
362	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ckernel !<
363
364	INTEGER(iwp), PARAMETER :: PHASE_INIT = 1 !<
365	INTEGER(iwp), PARAMETER, PUBLIC :: PHASE_RELEASE = 2 !<
366
367	SAVE
368
369	PRIVATE
370
371	PUBLIC lpm_parin, &
372	lpm_header, &
373	lpm_init_arrays,&
374	lpm_init, &
375	lpm_actions, &
376	lpm_data_output_ptseries, &
377	lpm_interaction_droplets_ptq, &
378	lpm_rrd_local_particles, &
379	lpm_wrd_local, &
380	lpm_rrd_global, &
381	lpm_wrd_global, &
382	lpm_rrd_local, &
383	lpm_check_parameters
384
385	PUBLIC lagrangian_particle_model
386
387	INTERFACE lpm_check_parameters
388	MODULE PROCEDURE lpm_check_parameters
389	END INTERFACE lpm_check_parameters
390
391	INTERFACE lpm_parin
392	MODULE PROCEDURE lpm_parin
393	END INTERFACE lpm_parin
394
395	INTERFACE lpm_header
396	MODULE PROCEDURE lpm_header
397	END INTERFACE lpm_header
398
399	INTERFACE lpm_init_arrays
400	MODULE PROCEDURE lpm_init_arrays
401	END INTERFACE lpm_init_arrays
402
403	INTERFACE lpm_init
404	MODULE PROCEDURE lpm_init
405	END INTERFACE lpm_init
406
407	INTERFACE lpm_actions
408	MODULE PROCEDURE lpm_actions
409	END INTERFACE lpm_actions
410
411	INTERFACE lpm_data_output_ptseries
412	MODULE PROCEDURE lpm_data_output_ptseries
413	END INTERFACE
414
415	INTERFACE lpm_rrd_local_particles
416	MODULE PROCEDURE lpm_rrd_local_particles
417	END INTERFACE lpm_rrd_local_particles
418
419	INTERFACE lpm_rrd_global
420	MODULE PROCEDURE lpm_rrd_global
421	END INTERFACE lpm_rrd_global
422
423	INTERFACE lpm_rrd_local
424	MODULE PROCEDURE lpm_rrd_local
425	END INTERFACE lpm_rrd_local
426
427	INTERFACE lpm_wrd_local
428	MODULE PROCEDURE lpm_wrd_local
429	END INTERFACE lpm_wrd_local
430
431	INTERFACE lpm_wrd_global
432	MODULE PROCEDURE lpm_wrd_global
433	END INTERFACE lpm_wrd_global
434
435	INTERFACE lpm_advec
436	MODULE PROCEDURE lpm_advec
437	END INTERFACE lpm_advec
438
439	INTERFACE lpm_calc_liquid_water_content
440	MODULE PROCEDURE lpm_calc_liquid_water_content
441	END INTERFACE
442
443	INTERFACE lpm_interaction_droplets_ptq
444	MODULE PROCEDURE lpm_interaction_droplets_ptq
445	MODULE PROCEDURE lpm_interaction_droplets_ptq_ij
446	END INTERFACE lpm_interaction_droplets_ptq
447
448	INTERFACE lpm_boundary_conds
449	MODULE PROCEDURE lpm_boundary_conds
450	END INTERFACE lpm_boundary_conds
451
452	INTERFACE lpm_droplet_condensation
453	MODULE PROCEDURE lpm_droplet_condensation
454	END INTERFACE
455
456	INTERFACE lpm_droplet_collision
457	MODULE PROCEDURE lpm_droplet_collision
458	END INTERFACE lpm_droplet_collision
459
460	INTERFACE lpm_init_kernels
461	MODULE PROCEDURE lpm_init_kernels
462	END INTERFACE lpm_init_kernels
463
464	INTERFACE lpm_splitting
465	MODULE PROCEDURE lpm_splitting
466	END INTERFACE lpm_splitting
467
468	INTERFACE lpm_merging
469	MODULE PROCEDURE lpm_merging
470	END INTERFACE lpm_merging
471
472	INTERFACE lpm_exchange_horiz
473	MODULE PROCEDURE lpm_exchange_horiz
474	END INTERFACE lpm_exchange_horiz
475
476	INTERFACE lpm_move_particle
477	MODULE PROCEDURE lpm_move_particle
478	END INTERFACE lpm_move_particle
479
480	INTERFACE realloc_particles_array
481	MODULE PROCEDURE realloc_particles_array
482	END INTERFACE realloc_particles_array
483
484	INTERFACE dealloc_particles_array
485	MODULE PROCEDURE dealloc_particles_array
486	END INTERFACE dealloc_particles_array
487
488	INTERFACE lpm_sort_in_subboxes
489	MODULE PROCEDURE lpm_sort_in_subboxes
490	END INTERFACE lpm_sort_in_subboxes
491
492	INTERFACE lpm_sort_timeloop_done
493	MODULE PROCEDURE lpm_sort_timeloop_done
494	END INTERFACE lpm_sort_timeloop_done
495
496	INTERFACE lpm_pack
497	MODULE PROCEDURE lpm_pack
498	END INTERFACE lpm_pack
499
500	CONTAINS
501
502
503	!------------------------------------------------------------------------------!
504	! Description:
505	! ------------
506	!> Parin for &particle_parameters for the Lagrangian particle model
507	!------------------------------------------------------------------------------!
508	SUBROUTINE lpm_parin
509
510	CHARACTER (LEN=80) :: line !<
511
512	NAMELIST /particles_par/ &
513	aero_species, &
514	aero_type, &
515	aero_weight, &
516	alloc_factor, &
517	bc_par_b, &
518	bc_par_lr, &
519	bc_par_ns, &
520	bc_par_t, &
521	collision_kernel, &
522	curvature_solution_effects, &
523	deallocate_memory, &
524	density_ratio, &
525	dissipation_classes, &
526	dt_dopts, &
527	dt_min_part, &
528	dt_prel, &
529	dt_write_particle_data, &
530	end_time_prel, &
531	initial_weighting_factor, &
532	log_sigma, &
533	max_number_particles_per_gridbox, &
534	merging, &
535	na, &
536	number_concentration, &
537	number_of_particle_groups, &
538	number_particles_per_gridbox, &
539	particles_per_point, &
540	particle_advection_start, &
541	particle_maximum_age, &
542	pdx, &
543	pdy, &
544	pdz, &
545	psb, &
546	psl, &
547	psn, &
548	psr, &
549	pss, &
550	pst, &
551	radius, &
552	radius_classes, &
553	radius_merge, &
554	radius_split, &
555	random_start_position, &
556	read_particles_from_restartfile, &
557	rm, &
558	seed_follows_topography, &
559	splitting, &
560	splitting_factor, &
561	splitting_factor_max, &
562	splitting_function, &
563	splitting_mode, &
564	step_dealloc, &
565	use_sgs_for_particles, &
566	vertical_particle_advection, &
567	weight_factor_merge, &
568	weight_factor_split, &
569	write_particle_statistics
570
571	NAMELIST /particle_parameters/ &
572	aero_species, &
573	aero_type, &
574	aero_weight, &
575	alloc_factor, &
576	bc_par_b, &
577	bc_par_lr, &
578	bc_par_ns, &
579	bc_par_t, &
580	collision_kernel, &
581	curvature_solution_effects, &
582	deallocate_memory, &
583	density_ratio, &
584	dissipation_classes, &
585	dt_dopts, &
586	dt_min_part, &
587	dt_prel, &
588	dt_write_particle_data, &
589	end_time_prel, &
590	initial_weighting_factor, &
591	log_sigma, &
592	max_number_particles_per_gridbox, &
593	merging, &
594	na, &
595	number_concentration, &
596	number_of_particle_groups, &
597	number_particles_per_gridbox, &
598	particles_per_point, &
599	particle_advection_start, &
600	particle_maximum_age, &
601	pdx, &
602	pdy, &
603	pdz, &
604	psb, &
605	psl, &
606	psn, &
607	psr, &
608	pss, &
609	pst, &
610	radius, &
611	radius_classes, &
612	radius_merge, &
613	radius_split, &
614	random_start_position, &
615	read_particles_from_restartfile, &
616	rm, &
617	seed_follows_topography, &
618	splitting, &
619	splitting_factor, &
620	splitting_factor_max, &
621	splitting_function, &
622	splitting_mode, &
623	step_dealloc, &
624	use_sgs_for_particles, &
625	vertical_particle_advection, &
626	weight_factor_merge, &
627	weight_factor_split, &
628	write_particle_statistics
629
630	!
631	!-- Position the namelist-file at the beginning (it was already opened in
632	!-- parin), search for the namelist-group of the package and position the
633	!-- file at this line. Do the same for each optionally used package.
634	line = ' '
635
636	!
637	!-- Try to find particles package
638	REWIND ( 11 )
639	line = ' '
640	DO WHILE ( INDEX( line, '&particle_parameters' ) == 0 )
641	READ ( 11, '(A)', END=12 ) line
642	ENDDO
643	BACKSPACE ( 11 )
644	!
645	!-- Read user-defined namelist
646	READ ( 11, particle_parameters, ERR = 10 )
647	!
648	!-- Set flag that indicates that particles are switched on
649	particle_advection = .TRUE.
650
651	GOTO 14
652
653	10 BACKSPACE( 11 )
654	READ( 11 , '(A)') line
655	CALL parin_fail_message( 'particle_parameters', line )
656	!
657	!-- Try to find particles package (old namelist)
658	12 REWIND ( 11 )
659	line = ' '
660	DO WHILE ( INDEX( line, '&particles_par' ) == 0 )
661	READ ( 11, '(A)', END=14 ) line
662	ENDDO
663	BACKSPACE ( 11 )
664	!
665	!-- Read user-defined namelist
666	READ ( 11, particles_par, ERR = 13, END = 14 )
667
668	message_string = 'namelist particles_par is deprecated and will be ' // &
669	'removed in near future. Please use namelist ' // &
670	'particle_parameters instead'
671	CALL message( 'package_parin', 'PA0487', 0, 1, 0, 6, 0 )
672
673	!
674	!-- Set flag that indicates that particles are switched on
675	particle_advection = .TRUE.
676
677	GOTO 14
678
679	13 BACKSPACE( 11 )
680	READ( 11 , '(A)') line
681	CALL parin_fail_message( 'particles_par', line )
682
683	14 CONTINUE
684
685	END SUBROUTINE lpm_parin
686
687	!------------------------------------------------------------------------------!
688	! Description:
689	! ------------
690	!> Writes used particle attributes in header file.
691	!------------------------------------------------------------------------------!
692	SUBROUTINE lpm_header ( io )
693
694	CHARACTER (LEN=40) :: output_format !< netcdf format
695
696	INTEGER(iwp) :: i !<
697	INTEGER(iwp), INTENT(IN) :: io !< Unit of the output file
698
699
700	IF ( humidity .AND. cloud_droplets ) THEN
701	WRITE ( io, 433 )
702	IF ( curvature_solution_effects ) WRITE ( io, 434 )
703	IF ( collision_kernel /= 'none' ) THEN
704	WRITE ( io, 435 ) TRIM( collision_kernel )
705	IF ( collision_kernel(6:9) == 'fast' ) THEN
706	WRITE ( io, 436 ) radius_classes, dissipation_classes
707	ENDIF
708	ELSE
709	WRITE ( io, 437 )
710	ENDIF
711	ENDIF
712
713	IF ( particle_advection ) THEN
714	!
715	!-- Particle attributes
716	WRITE ( io, 480 ) particle_advection_start, dt_prel, bc_par_lr, &
717	bc_par_ns, bc_par_b, bc_par_t, particle_maximum_age, &
718	end_time_prel
719	IF ( use_sgs_for_particles ) WRITE ( io, 488 ) dt_min_part
720	IF ( random_start_position ) WRITE ( io, 481 )
721	IF ( seed_follows_topography ) WRITE ( io, 496 )
722	IF ( particles_per_point > 1 ) WRITE ( io, 489 ) particles_per_point
723	WRITE ( io, 495 ) total_number_of_particles
724	IF ( dt_write_particle_data /= 9999999.9_wp ) THEN
725	WRITE ( io, 485 ) dt_write_particle_data
726	IF ( netcdf_data_format > 1 ) THEN
727	output_format = 'netcdf (64 bit offset) and binary'
728	ELSE
729	output_format = 'netcdf and binary'
730	ENDIF
731	IF ( netcdf_deflate == 0 ) THEN
732	WRITE ( io, 344 ) output_format
733	ELSE
734	WRITE ( io, 354 ) TRIM( output_format ), netcdf_deflate
735	ENDIF
736	ENDIF
737	IF ( dt_dopts /= 9999999.9_wp ) WRITE ( io, 494 ) dt_dopts
738	IF ( write_particle_statistics ) WRITE ( io, 486 )
739
740	WRITE ( io, 487 ) number_of_particle_groups
741
742	DO i = 1, number_of_particle_groups
743	IF ( i == 1 .AND. density_ratio(i) == 9999999.9_wp ) THEN
744	WRITE ( io, 490 ) i, 0.0_wp
745	WRITE ( io, 492 )
746	ELSE
747	WRITE ( io, 490 ) i, radius(i)
748	IF ( density_ratio(i) /= 0.0_wp ) THEN
749	WRITE ( io, 491 ) density_ratio(i)
750	ELSE
751	WRITE ( io, 492 )
752	ENDIF
753	ENDIF
754	WRITE ( io, 493 ) psl(i), psr(i), pss(i), psn(i), psb(i), pst(i), &
755	pdx(i), pdy(i), pdz(i)
756	IF ( .NOT. vertical_particle_advection(i) ) WRITE ( io, 482 )
757	ENDDO
758
759	ENDIF
760
761	344 FORMAT (' Output format: ',A/)
762	354 FORMAT (' Output format: ',A, ' compressed with level: ',I1/)
763
764	433 FORMAT (' Cloud droplets treated explicitly using the Lagrangian part', &
765	'icle model')
766	434 FORMAT (' Curvature and solution effecs are considered for growth of', &
767	' droplets < 1.0E-6 m')
768	435 FORMAT (' Droplet collision is handled by ',A,'-kernel')
769	436 FORMAT (' Fast kernel with fixed radius- and dissipation classes ', &
770	'are used'/ &
771	' number of radius classes: ',I3,' interval ', &
772	'[1.0E-6,2.0E-4] m'/ &
773	' number of dissipation classes: ',I2,' interval ', &
774	'[0,1000] cm2/s3')
775	437 FORMAT (' Droplet collision is switched off')
776
777	480 FORMAT (' Particles:'/ &
778	' ---------'// &
779	' Particle advection is active (switched on at t = ', F7.1, &
780	' s)'/ &
781	' Start of new particle generations every ',F6.1,' s'/ &
782	' Boundary conditions: left/right: ', A, ' north/south: ', A/&
783	' bottom: ', A, ' top: ', A/&
784	' Maximum particle age: ',F9.1,' s'/ &
785	' Advection stopped at t = ',F9.1,' s'/)
786	481 FORMAT (' Particles have random start positions'/)
787	482 FORMAT (' Particles are advected only horizontally'/)
788	485 FORMAT (' Particle data are written on file every ', F9.1, ' s')
789	486 FORMAT (' Particle statistics are written on file'/)
790	487 FORMAT (' Number of particle groups: ',I2/)
791	488 FORMAT (' SGS velocity components are used for particle advection'/ &
792	' minimum timestep for advection:', F8.5/)
793	489 FORMAT (' Number of particles simultaneously released at each ', &
794	'point: ', I5/)
795	490 FORMAT (' Particle group ',I2,':'/ &
796	' Particle radius: ',E10.3, 'm')
797	491 FORMAT (' Particle inertia is activated'/ &
798	' density_ratio (rho_fluid/rho_particle) =',F6.3/)
799	492 FORMAT (' Particles are advected only passively (no inertia)'/)
800	493 FORMAT (' Boundaries of particle source: x:',F8.1,' - ',F8.1,' m'/&
801	' y:',F8.1,' - ',F8.1,' m'/&
802	' z:',F8.1,' - ',F8.1,' m'/&
803	' Particle distances: dx = ',F8.1,' m dy = ',F8.1, &
804	' m dz = ',F8.1,' m'/)
805	494 FORMAT (' Output of particle time series in NetCDF format every ', &
806	F8.2,' s'/)
807	495 FORMAT (' Number of particles in total domain: ',I10/)
808	496 FORMAT (' Initial vertical particle positions are interpreted ', &
809	'as relative to the given topography')
810
811	END SUBROUTINE lpm_header
812
813	!------------------------------------------------------------------------------!
814	! Description:
815	! ------------
816	!> Writes used particle attributes in header file.
817	!------------------------------------------------------------------------------!
818	SUBROUTINE lpm_check_parameters
819
820	!
821	!-- Collision kernels:
822	SELECT CASE ( TRIM( collision_kernel ) )
823
824	CASE ( 'hall', 'hall_fast' )
825	hall_kernel = .TRUE.
826
827	CASE ( 'wang', 'wang_fast' )
828	wang_kernel = .TRUE.
829
830	CASE ( 'none' )
831
832
833	CASE DEFAULT
834	message_string = 'unknown collision kernel: collision_kernel = "' // &
835	TRIM( collision_kernel ) // '"'
836	CALL message( 'check_parameters', 'PA0350', 1, 2, 0, 6, 0 )
837
838	END SELECT
839	IF ( collision_kernel(6:9) == 'fast' ) use_kernel_tables = .TRUE.
840
841	END SUBROUTINE
842
843	!------------------------------------------------------------------------------!
844	! Description:
845	! ------------
846	!> Initialize arrays for lpm
847	!------------------------------------------------------------------------------!
848	SUBROUTINE lpm_init_arrays
849
850	IF ( cloud_droplets ) THEN
851	!
852	!-- Liquid water content, change in liquid water content
853	ALLOCATE ( ql_1(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &
854	ql_2(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
855	!
856	!-- Real volume of particles (with weighting), volume of particles
857	ALLOCATE ( ql_v(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &
858	ql_vp(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
859	ENDIF
860
861	!
862	!-- Initial assignment of the pointers
863	IF ( cloud_droplets ) THEN
864	ql => ql_1
865	ql_c => ql_2
866	ENDIF
867
868	END SUBROUTINE lpm_init_arrays
869
870	!------------------------------------------------------------------------------!
871	! Description:
872	! ------------
873	!> Initialize Lagrangian particle model
874	!------------------------------------------------------------------------------!
875	SUBROUTINE lpm_init
876
877	INTEGER(iwp) :: i !<
878	INTEGER(iwp) :: j !<
879	INTEGER(iwp) :: k !<
880
881	REAL(wp) :: div !<
882	REAL(wp) :: height_int !<
883	REAL(wp) :: height_p !<
884	REAL(wp) :: z_p !<
885	REAL(wp) :: z0_av_local !<
886
887	!
888	!-- In case of oceans runs, the vertical index calculations need an offset,
889	!-- because otherwise the k indices will become negative
890	IF ( ocean_mode ) THEN
891	offset_ocean_nzt = nzt
892	offset_ocean_nzt_m1 = nzt - 1
893	ENDIF
894
895	!
896	!-- Define block offsets for dividing a gridcell in 8 sub cells
897	!-- See documentation for List of subgrid boxes
898	!-- See pack_and_sort in lpm_pack_arrays.f90 for assignment of the subgrid boxes
899	block_offset(0) = block_offset_def ( 0, 0, 0)
900	block_offset(1) = block_offset_def ( 0, 0,-1)
901	block_offset(2) = block_offset_def ( 0,-1, 0)
902	block_offset(3) = block_offset_def ( 0,-1,-1)
903	block_offset(4) = block_offset_def (-1, 0, 0)
904	block_offset(5) = block_offset_def (-1, 0,-1)
905	block_offset(6) = block_offset_def (-1,-1, 0)
906	block_offset(7) = block_offset_def (-1,-1,-1)
907	!
908	!-- Check the number of particle groups.
909	IF ( number_of_particle_groups > max_number_of_particle_groups ) THEN
910	WRITE( message_string, * ) 'max_number_of_particle_groups =', &
911	max_number_of_particle_groups , &
912	'&number_of_particle_groups reset to ', &
913	max_number_of_particle_groups
914	CALL message( 'lpm_init', 'PA0213', 0, 1, 0, 6, 0 )
915	number_of_particle_groups = max_number_of_particle_groups
916	ENDIF
917	!
918	!-- Check if downward-facing walls exist. This case, reflection boundary
919	!-- conditions (as well as subgrid-scale velocities) may do not work
920	!-- propably (not realized so far).
921	IF ( surf_def_h(1)%ns >= 1 ) THEN
922	WRITE( message_string, * ) 'Overhanging topography do not work '// &
923	'with particles'
924	CALL message( 'lpm_init', 'PA0212', 0, 1, 0, 6, 0 )
925
926	ENDIF
927
928	!
929	!-- Set default start positions, if necessary
930	IF ( psl(1) == 9999999.9_wp ) psl(1) = 0.0_wp
931	IF ( psr(1) == 9999999.9_wp ) psr(1) = ( nx +1 ) * dx
932	IF ( pss(1) == 9999999.9_wp ) pss(1) = 0.0_wp
933	IF ( psn(1) == 9999999.9_wp ) psn(1) = ( ny +1 ) * dy
934	IF ( psb(1) == 9999999.9_wp ) psb(1) = zu(nz/2)
935	IF ( pst(1) == 9999999.9_wp ) pst(1) = psb(1)
936
937	IF ( pdx(1) == 9999999.9_wp .OR. pdx(1) == 0.0_wp ) pdx(1) = dx
938	IF ( pdy(1) == 9999999.9_wp .OR. pdy(1) == 0.0_wp ) pdy(1) = dy
939	IF ( pdz(1) == 9999999.9_wp .OR. pdz(1) == 0.0_wp ) pdz(1) = zu(2) - zu(1)
940
941	!
942	!-- If number_particles_per_gridbox is set, the parametres pdx, pdy and pdz are
943	!-- calculated diagnostically. Therfore an isotropic distribution is prescribed.
944	IF ( number_particles_per_gridbox /= -1 .AND. &
945	number_particles_per_gridbox >= 1 ) THEN
946	pdx(1) = (( dx * dy * ( zu(2) - zu(1) ) ) / &
947	REAL(number_particles_per_gridbox))**0.3333333_wp
948	!
949	!-- Ensure a smooth value (two significant digits) of distance between
950	!-- particles (pdx, pdy, pdz).
951	div = 1000.0_wp
952	DO WHILE ( pdx(1) < div )
953	div = div / 10.0_wp
954	ENDDO
955	pdx(1) = NINT( pdx(1) * 100.0_wp / div ) * div / 100.0_wp
956	pdy(1) = pdx(1)
957	pdz(1) = pdx(1)
958
959	ENDIF
960
961	DO j = 2, number_of_particle_groups
962	IF ( psl(j) == 9999999.9_wp ) psl(j) = psl(j-1)
963	IF ( psr(j) == 9999999.9_wp ) psr(j) = psr(j-1)
964	IF ( pss(j) == 9999999.9_wp ) pss(j) = pss(j-1)
965	IF ( psn(j) == 9999999.9_wp ) psn(j) = psn(j-1)
966	IF ( psb(j) == 9999999.9_wp ) psb(j) = psb(j-1)
967	IF ( pst(j) == 9999999.9_wp ) pst(j) = pst(j-1)
968	IF ( pdx(j) == 9999999.9_wp .OR. pdx(j) == 0.0_wp ) pdx(j) = pdx(j-1)
969	IF ( pdy(j) == 9999999.9_wp .OR. pdy(j) == 0.0_wp ) pdy(j) = pdy(j-1)
970	IF ( pdz(j) == 9999999.9_wp .OR. pdz(j) == 0.0_wp ) pdz(j) = pdz(j-1)
971	ENDDO
972
973	!
974	!-- Allocate arrays required for calculating particle SGS velocities.
975	!-- Initialize prefactor required for stoachastic Weil equation.
976	IF ( use_sgs_for_particles .AND. .NOT. cloud_droplets ) THEN
977	ALLOCATE( de_dx(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &
978	de_dy(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &
979	de_dz(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
980
981	de_dx = 0.0_wp
982	de_dy = 0.0_wp
983	de_dz = 0.0_wp
984
985	sgs_wf_part = 1.0_wp / 3.0_wp
986	ENDIF
987
988	!
989	!-- Allocate array required for logarithmic vertical interpolation of
990	!-- horizontal particle velocities between the surface and the first vertical
991	!-- grid level. In order to avoid repeated CPU cost-intensive CALLS of
992	!-- intrinsic FORTRAN procedure LOG(z/z0), LOG(z/z0) is precalculated for
993	!-- several heights. Splitting into 20 sublayers turned out to be sufficient.
994	!-- To obtain exact height levels of particles, linear interpolation is applied
995	!-- (see lpm_advec.f90).
996	IF ( constant_flux_layer ) THEN
997
998	ALLOCATE ( log_z_z0(0:number_of_sublayers) )
999	z_p = zu(nzb+1) - zw(nzb)
1000
1001	!
1002	!-- Calculate horizontal mean value of z0 used for logartihmic
1003	!-- interpolation. Note: this is not exact for heterogeneous z0.
1004	!-- However, sensitivity studies showed that the effect is
1005	!-- negligible.
1006	z0_av_local = SUM( surf_def_h(0)%z0 ) + SUM( surf_lsm_h%z0 ) + &
1007	SUM( surf_usm_h%z0 )
1008	z0_av_global = 0.0_wp
1009
1010	#if defined( __parallel )
1011	CALL MPI_ALLREDUCE(z0_av_local, z0_av_global, 1, MPI_REAL, MPI_SUM, &
1012	comm2d, ierr )
1013	#else
1014	z0_av_global = z0_av_local
1015	#endif
1016
1017	z0_av_global = z0_av_global / ( ( ny + 1 ) * ( nx + 1 ) )
1018	!
1019	!-- Horizontal wind speed is zero below and at z0
1020	log_z_z0(0) = 0.0_wp
1021	!
1022	!-- Calculate vertical depth of the sublayers
1023	height_int = ( z_p - z0_av_global ) / REAL( number_of_sublayers, KIND=wp )
1024	!
1025	!-- Precalculate LOG(z/z0)
1026	height_p = z0_av_global
1027	DO k = 1, number_of_sublayers
1028
1029	height_p = height_p + height_int
1030	log_z_z0(k) = LOG( height_p / z0_av_global )
1031
1032	ENDDO
1033
1034	ENDIF
1035
1036	!
1037	!-- Check boundary condition and set internal variables
1038	SELECT CASE ( bc_par_b )
1039
1040	CASE ( 'absorb' )
1041	ibc_par_b = 1
1042
1043	CASE ( 'reflect' )
1044	ibc_par_b = 2
1045
1046	CASE DEFAULT
1047	WRITE( message_string, * ) 'unknown boundary condition ', &
1048	'bc_par_b = "', TRIM( bc_par_b ), '"'
1049	CALL message( 'lpm_init', 'PA0217', 1, 2, 0, 6, 0 )
1050
1051	END SELECT
1052	SELECT CASE ( bc_par_t )
1053
1054	CASE ( 'absorb' )
1055	ibc_par_t = 1
1056
1057	CASE ( 'reflect' )
1058	ibc_par_t = 2
1059
1060	CASE ( 'nested' )
1061	ibc_par_t = 3
1062
1063	CASE DEFAULT
1064	WRITE( message_string, * ) 'unknown boundary condition ', &
1065	'bc_par_t = "', TRIM( bc_par_t ), '"'
1066	CALL message( 'lpm_init', 'PA0218', 1, 2, 0, 6, 0 )
1067
1068	END SELECT
1069	SELECT CASE ( bc_par_lr )
1070
1071	CASE ( 'cyclic' )
1072	ibc_par_lr = 0
1073
1074	CASE ( 'absorb' )
1075	ibc_par_lr = 1
1076
1077	CASE ( 'reflect' )
1078	ibc_par_lr = 2
1079
1080	CASE ( 'nested' )
1081	ibc_par_lr = 3
1082
1083	CASE DEFAULT
1084	WRITE( message_string, * ) 'unknown boundary condition ', &
1085	'bc_par_lr = "', TRIM( bc_par_lr ), '"'
1086	CALL message( 'lpm_init', 'PA0219', 1, 2, 0, 6, 0 )
1087
1088	END SELECT
1089	SELECT CASE ( bc_par_ns )
1090
1091	CASE ( 'cyclic' )
1092	ibc_par_ns = 0
1093
1094	CASE ( 'absorb' )
1095	ibc_par_ns = 1
1096
1097	CASE ( 'reflect' )
1098	ibc_par_ns = 2
1099
1100	CASE ( 'nested' )
1101	ibc_par_ns = 3
1102
1103	CASE DEFAULT
1104	WRITE( message_string, * ) 'unknown boundary condition ', &
1105	'bc_par_ns = "', TRIM( bc_par_ns ), '"'
1106	CALL message( 'lpm_init', 'PA0220', 1, 2, 0, 6, 0 )
1107
1108	END SELECT
1109	SELECT CASE ( splitting_mode )
1110
1111	CASE ( 'const' )
1112	i_splitting_mode = 1
1113
1114	CASE ( 'cl_av' )
1115	i_splitting_mode = 2
1116
1117	CASE ( 'gb_av' )
1118	i_splitting_mode = 3
1119
1120	CASE DEFAULT
1121	WRITE( message_string, * ) 'unknown splitting_mode = "', &
1122	TRIM( splitting_mode ), '"'
1123	CALL message( 'lpm_init', 'PA0146', 1, 2, 0, 6, 0 )
1124
1125	END SELECT
1126	SELECT CASE ( splitting_function )
1127
1128	CASE ( 'gamma' )
1129	isf = 1
1130
1131	CASE ( 'log' )
1132	isf = 2
1133
1134	CASE ( 'exp' )
1135	isf = 3
1136
1137	CASE DEFAULT
1138	WRITE( message_string, * ) 'unknown splitting function = "', &
1139	TRIM( splitting_function ), '"'
1140	CALL message( 'lpm_init', 'PA0147', 1, 2, 0, 6, 0 )
1141
1142	END SELECT
1143	!
1144	!-- Initialize collision kernels
1145	IF ( collision_kernel /= 'none' ) CALL lpm_init_kernels
1146	!
1147	!-- For the first model run of a possible job chain initialize the
1148	!-- particles, otherwise read the particle data from restart file.
1149	IF ( TRIM( initializing_actions ) == 'read_restart_data' &
1150	.AND. read_particles_from_restartfile ) THEN
1151	CALL lpm_rrd_local_particles
1152	ELSE
1153	!
1154	!-- Allocate particle arrays and set attributes of the initial set of
1155	!-- particles, which can be also periodically released at later times.
1156	ALLOCATE( prt_count(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &
1157	grid_particles(nzb+1:nzt,nys:nyn,nxl:nxr) )
1158
1159	number_of_particles = 0
1160	prt_count = 0
1161	!
1162	!-- initialize counter for particle IDs
1163	grid_particles%id_counter = 1
1164	!
1165	!-- Initialize all particles with dummy values (otherwise errors may
1166	!-- occur within restart runs). The reason for this is still not clear
1167	!-- and may be presumably caused by errors in the respective user-interface.
1168	zero_particle = particle_type( 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, &
1169	0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, &
1170	0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, &
1171	0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, &
1172	0, 0, 0_idp, .FALSE., -1 )
1173
1174	particle_groups = particle_groups_type( 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp )
1175	!
1176	!-- Set values for the density ratio and radius for all particle
1177	!-- groups, if necessary
1178	IF ( density_ratio(1) == 9999999.9_wp ) density_ratio(1) = 0.0_wp
1179	IF ( radius(1) == 9999999.9_wp ) radius(1) = 0.0_wp
1180	DO i = 2, number_of_particle_groups
1181	IF ( density_ratio(i) == 9999999.9_wp ) THEN
1182	density_ratio(i) = density_ratio(i-1)
1183	ENDIF
1184	IF ( radius(i) == 9999999.9_wp ) radius(i) = radius(i-1)
1185	ENDDO
1186
1187	DO i = 1, number_of_particle_groups
1188	IF ( density_ratio(i) /= 0.0_wp .AND. radius(i) == 0 ) THEN
1189	WRITE( message_string, * ) 'particle group #', i, ' has a', &
1190	'density ratio /= 0 but radius = 0'
1191	CALL message( 'lpm_init', 'PA0215', 1, 2, 0, 6, 0 )
1192	ENDIF
1193	particle_groups(i)%density_ratio = density_ratio(i)
1194	particle_groups(i)%radius = radius(i)
1195	ENDDO
1196	!
1197	!-- Set a seed value for the random number generator to be exclusively
1198	!-- used for the particle code. The generated random numbers should be
1199	!-- different on the different PEs.
1200	iran_part = iran_part + myid
1201	!
1202	!-- Create the particle set, and set the initial particles
1203	CALL lpm_create_particle( phase_init )
1204	last_particle_release_time = particle_advection_start
1205	!
1206	!-- User modification of initial particles
1207	CALL user_lpm_init
1208	!
1209	!-- Open file for statistical informations about particle conditions
1210	IF ( write_particle_statistics ) THEN
1211	CALL check_open( 80 )
1212	WRITE ( 80, 8000 ) current_timestep_number, simulated_time, &
1213	number_of_particles
1214	CALL close_file( 80 )
1215	ENDIF
1216
1217	ENDIF
1218
1219	IF ( nested_run ) CALL pmcp_g_init
1220	!
1221	!-- To avoid programm abort, assign particles array to the local version of
1222	!-- first grid cell
1223	number_of_particles = prt_count(nzb+1,nys,nxl)
1224	particles => grid_particles(nzb+1,nys,nxl)%particles(1:number_of_particles)
1225	!
1226	!-- Formats
1227	8000 FORMAT (I6,1X,F7.2,4X,I10,71X,I10)
1228
1229	END SUBROUTINE lpm_init
1230
1231	!------------------------------------------------------------------------------!
1232	! Description:
1233	! ------------
1234	!> Create Lagrangian particles
1235	!------------------------------------------------------------------------------!
1236	SUBROUTINE lpm_create_particle (phase)
1237
1238	INTEGER(iwp) :: alloc_size !< relative increase of allocated memory for particles
1239	INTEGER(iwp) :: i !< loop variable ( particle groups )
1240	INTEGER(iwp) :: ip !< index variable along x
1241	INTEGER(iwp) :: j !< loop variable ( particles per point )
1242	INTEGER(iwp) :: jp !< index variable along y
1243	INTEGER(iwp) :: k !< index variable along z
1244	INTEGER(iwp) :: k_surf !< index of surface grid point
1245	INTEGER(iwp) :: kp !< index variable along z
1246	INTEGER(iwp) :: loop_stride !< loop variable for initialization
1247	INTEGER(iwp) :: n !< loop variable ( number of particles )
1248	INTEGER(iwp) :: new_size !< new size of allocated memory for particles
1249
1250	INTEGER(iwp), INTENT(IN) :: phase !< mode of inititialization
1251
1252	INTEGER(iwp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: local_count !< start address of new particle
1253	INTEGER(iwp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: local_start !< start address of new particle
1254
1255	LOGICAL :: first_stride !< flag for initialization
1256
1257	REAL(wp) :: pos_x !< increment for particle position in x
1258	REAL(wp) :: pos_y !< increment for particle position in y
1259	REAL(wp) :: pos_z !< increment for particle position in z
1260	REAL(wp) :: rand_contr !< dummy argument for random position
1261
1262	TYPE(particle_type),TARGET :: tmp_particle !< temporary particle used for initialization
1263
1264	!
1265	!-- Calculate particle positions and store particle attributes, if
1266	!-- particle is situated on this PE
1267	DO loop_stride = 1, 2
1268	first_stride = (loop_stride == 1)
1269	IF ( first_stride ) THEN
1270	local_count = 0 ! count number of particles
1271	ELSE
1272	local_count = prt_count ! Start address of new particles
1273	ENDIF
1274
1275	!
1276	!-- Calculate initial_weighting_factor diagnostically
1277	IF ( number_concentration /= -1.0_wp .AND. number_concentration > 0.0_wp ) THEN
1278	initial_weighting_factor = number_concentration * &
1279	pdx(1) * pdy(1) * pdz(1)
1280	END IF
1281
1282	n = 0
1283	DO i = 1, number_of_particle_groups
1284	pos_z = psb(i)
1285	DO WHILE ( pos_z <= pst(i) )
1286	IF ( pos_z >= zw(0) .AND. pos_z < zw(nzt) ) THEN
1287	pos_y = pss(i)
1288	DO WHILE ( pos_y <= psn(i) )
1289	IF ( pos_y >= nys * dy .AND. &
1290	pos_y < ( nyn + 1 ) * dy ) THEN
1291	pos_x = psl(i)
1292	xloop: DO WHILE ( pos_x <= psr(i) )
1293	IF ( pos_x >= nxl * dx .AND. &
1294	pos_x < ( nxr + 1) * dx ) THEN
1295	DO j = 1, particles_per_point
1296	n = n + 1
1297	tmp_particle%x = pos_x
1298	tmp_particle%y = pos_y
1299	tmp_particle%z = pos_z
1300	tmp_particle%age = 0.0_wp
1301	tmp_particle%age_m = 0.0_wp
1302	tmp_particle%dt_sum = 0.0_wp
1303	tmp_particle%e_m = 0.0_wp
1304	tmp_particle%rvar1 = 0.0_wp
1305	tmp_particle%rvar2 = 0.0_wp
1306	tmp_particle%rvar3 = 0.0_wp
1307	tmp_particle%speed_x = 0.0_wp
1308	tmp_particle%speed_y = 0.0_wp
1309	tmp_particle%speed_z = 0.0_wp
1310	tmp_particle%origin_x = pos_x
1311	tmp_particle%origin_y = pos_y
1312	tmp_particle%origin_z = pos_z
1313	IF ( curvature_solution_effects ) THEN
1314	tmp_particle%aux1 = 0.0_wp ! dry aerosol radius
1315	tmp_particle%aux2 = dt_3d ! last Rosenbrock timestep
1316	ELSE
1317	tmp_particle%aux1 = 0.0_wp ! free to use
1318	tmp_particle%aux2 = 0.0_wp ! free to use
1319	ENDIF
1320	tmp_particle%radius = particle_groups(i)%radius
1321	tmp_particle%weight_factor = initial_weighting_factor
1322	tmp_particle%class = 1
1323	tmp_particle%group = i
1324	tmp_particle%id = 0_idp
1325	tmp_particle%particle_mask = .TRUE.
1326	tmp_particle%block_nr = -1
1327	!
1328	!-- Determine the grid indices of the particle position
1329	ip = INT( tmp_particle%x * ddx )
1330	jp = INT( tmp_particle%y * ddy )
1331	kp = INT( tmp_particle%z / dz(1) + 1 + offset_ocean_nzt )
1332	DO WHILE( zw(kp) < tmp_particle%z )
1333	kp = kp + 1
1334	ENDDO
1335	DO WHILE( zw(kp-1) > tmp_particle%z )
1336	kp = kp - 1
1337	ENDDO
1338	!
1339	!-- Determine surface level. Therefore, check for
1340	!-- upward-facing wall on w-grid.
1341	k_surf = get_topography_top_index_ji( jp, ip, 'w' )
1342	IF ( seed_follows_topography ) THEN
1343	!
1344	!-- Particle height is given relative to topography
1345	kp = kp + k_surf
1346	tmp_particle%z = tmp_particle%z + zw(k_surf)
1347	!-- Skip particle release if particle position is
1348	!-- above model top, or within topography in case
1349	!-- of overhanging structures.
1350	IF ( kp > nzt .OR. &
1351	.NOT. BTEST( wall_flags_0(kp,jp,ip), 0 ) ) THEN
1352	pos_x = pos_x + pdx(i)
1353	CYCLE xloop
1354	ENDIF
1355	!
1356	!-- Skip particle release if particle position is
1357	!-- below surface, or within topography in case
1358	!-- of overhanging structures.
1359	ELSEIF ( .NOT. seed_follows_topography .AND. &
1360	tmp_particle%z <= zw(k_surf) .OR. &
1361	.NOT. BTEST( wall_flags_0(kp,jp,ip), 0 ) )&
1362	THEN
1363	pos_x = pos_x + pdx(i)
1364	CYCLE xloop
1365	ENDIF
1366
1367	local_count(kp,jp,ip) = local_count(kp,jp,ip) + 1
1368
1369	IF ( .NOT. first_stride ) THEN
1370	IF ( ip < nxl .OR. jp < nys .OR. kp < nzb+1 ) THEN
1371	write(6,*) 'xl ',ip,jp,kp,nxl,nys,nzb+1
1372	ENDIF
1373	IF ( ip > nxr .OR. jp > nyn .OR. kp > nzt ) THEN
1374	write(6,*) 'xu ',ip,jp,kp,nxr,nyn,nzt
1375	ENDIF
1376	grid_particles(kp,jp,ip)%particles(local_count(kp,jp,ip)) = tmp_particle
1377	ENDIF
1378	ENDDO
1379	ENDIF
1380	pos_x = pos_x + pdx(i)
1381	ENDDO xloop
1382	ENDIF
1383	pos_y = pos_y + pdy(i)
1384	ENDDO
1385	ENDIF
1386
1387	pos_z = pos_z + pdz(i)
1388	ENDDO
1389	ENDDO
1390
1391	IF ( first_stride ) THEN
1392	DO ip = nxl, nxr
1393	DO jp = nys, nyn
1394	DO kp = nzb+1, nzt
1395	IF ( phase == PHASE_INIT ) THEN
1396	IF ( local_count(kp,jp,ip) > 0 ) THEN
1397	alloc_size = MAX( INT( local_count(kp,jp,ip) * &
1398	( 1.0_wp + alloc_factor / 100.0_wp ) ), &
1399	1 )
1400	ELSE
1401	alloc_size = 1
1402	ENDIF
1403	ALLOCATE(grid_particles(kp,jp,ip)%particles(1:alloc_size))
1404	DO n = 1, alloc_size
1405	grid_particles(kp,jp,ip)%particles(n) = zero_particle
1406	ENDDO
1407	ELSEIF ( phase == PHASE_RELEASE ) THEN
1408	IF ( local_count(kp,jp,ip) > 0 ) THEN
1409	new_size = local_count(kp,jp,ip) + prt_count(kp,jp,ip)
1410	alloc_size = MAX( INT( new_size * ( 1.0_wp + &
1411	alloc_factor / 100.0_wp ) ), 1 )
1412	IF( alloc_size > SIZE( grid_particles(kp,jp,ip)%particles) ) THEN
1413	CALL realloc_particles_array(ip,jp,kp,alloc_size)
1414	ENDIF
1415	ENDIF
1416	ENDIF
1417	ENDDO
1418	ENDDO
1419	ENDDO
1420	ENDIF
1421
1422	ENDDO
1423
1424	local_start = prt_count+1
1425	prt_count = local_count
1426	!
1427	!-- Calculate particle IDs
1428	DO ip = nxl, nxr
1429	DO jp = nys, nyn
1430	DO kp = nzb+1, nzt
1431	number_of_particles = prt_count(kp,jp,ip)
1432	IF ( number_of_particles <= 0 ) CYCLE
1433	particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
1434
1435	DO n = local_start(kp,jp,ip), number_of_particles !only new particles
1436
1437	particles(n)%id = 10000_idp*3 grid_particles(kp,jp,ip)%id_counter + &
1438	10000_idp*2 kp + 10000_idp * jp + ip
1439	!
1440	!-- Count the number of particles that have been released before
1441	grid_particles(kp,jp,ip)%id_counter = &
1442	grid_particles(kp,jp,ip)%id_counter + 1
1443
1444	ENDDO
1445
1446	ENDDO
1447	ENDDO
1448	ENDDO
1449	!
1450	!-- Initialize aerosol background spectrum
1451	IF ( curvature_solution_effects ) THEN
1452	CALL lpm_init_aerosols(local_start)
1453	ENDIF
1454	!
1455	!-- Add random fluctuation to particle positions.
1456	IF ( random_start_position ) THEN
1457	DO ip = nxl, nxr
1458	DO jp = nys, nyn
1459	DO kp = nzb+1, nzt
1460	number_of_particles = prt_count(kp,jp,ip)
1461	IF ( number_of_particles <= 0 ) CYCLE
1462	particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
1463	!
1464	!-- Move only new particles. Moreover, limit random fluctuation
1465	!-- in order to prevent that particles move more than one grid box,
1466	!-- which would lead to problems concerning particle exchange
1467	!-- between processors in case pdx/pdy are larger than dx/dy,
1468	!-- respectively.
1469	DO n = local_start(kp,jp,ip), number_of_particles
1470	IF ( psl(particles(n)%group) /= psr(particles(n)%group) ) THEN
1471	rand_contr = ( random_function( iran_part ) - 0.5_wp ) * &
1472	pdx(particles(n)%group)
1473	particles(n)%x = particles(n)%x + &
1474	MERGE( rand_contr, SIGN( dx, rand_contr ), &
1475	ABS( rand_contr ) < dx &
1476	)
1477	ENDIF
1478	IF ( pss(particles(n)%group) /= psn(particles(n)%group) ) THEN
1479	rand_contr = ( random_function( iran_part ) - 0.5_wp ) * &
1480	pdy(particles(n)%group)
1481	particles(n)%y = particles(n)%y + &
1482	MERGE( rand_contr, SIGN( dy, rand_contr ), &
1483	ABS( rand_contr ) < dy &
1484	)
1485	ENDIF
1486	IF ( psb(particles(n)%group) /= pst(particles(n)%group) ) THEN
1487	rand_contr = ( random_function( iran_part ) - 0.5_wp ) * &
1488	pdz(particles(n)%group)
1489	particles(n)%z = particles(n)%z + &
1490	MERGE( rand_contr, SIGN( dzw(kp), rand_contr ), &
1491	ABS( rand_contr ) < dzw(kp) &
1492	)
1493	ENDIF
1494	ENDDO
1495	!
1496	!-- Identify particles located outside the model domain and reflect
1497	!-- or absorb them if necessary.
1498	CALL lpm_boundary_conds( 'bottom/top', i, j, k )
1499	!
1500	!-- Furthermore, remove particles located in topography. Note, as
1501	!-- the particle speed is still zero at this point, wall
1502	!-- reflection boundary conditions will not work in this case.
1503	particles => &
1504	grid_particles(kp,jp,ip)%particles(1:number_of_particles)
1505	DO n = local_start(kp,jp,ip), number_of_particles
1506	i = particles(n)%x * ddx
1507	j = particles(n)%y * ddy
1508	k = particles(n)%z / dz(1) + 1 + offset_ocean_nzt
1509	DO WHILE( zw(k) < particles(n)%z )
1510	k = k + 1
1511	ENDDO
1512	DO WHILE( zw(k-1) > particles(n)%z )
1513	k = k - 1
1514	ENDDO
1515	!
1516	!-- Check if particle is within topography
1517	IF ( .NOT. BTEST( wall_flags_0(k,j,i), 0 ) ) THEN
1518	particles(n)%particle_mask = .FALSE.
1519	deleted_particles = deleted_particles + 1
1520	ENDIF
1521
1522	ENDDO
1523	ENDDO
1524	ENDDO
1525	ENDDO
1526	!
1527	!-- Exchange particles between grid cells and processors
1528	CALL lpm_move_particle
1529	CALL lpm_exchange_horiz
1530
1531	ENDIF
1532	!
1533	!-- In case of random_start_position, delete particles identified by
1534	!-- lpm_exchange_horiz and lpm_boundary_conds. Then sort particles into blocks,
1535	!-- which is needed for a fast interpolation of the LES fields on the particle
1536	!-- position.
1537	CALL lpm_sort_in_subboxes
1538	!
1539	!-- Determine the current number of particles
1540	DO ip = nxl, nxr
1541	DO jp = nys, nyn
1542	DO kp = nzb+1, nzt
1543	number_of_particles = number_of_particles &
1544	+ prt_count(kp,jp,ip)
1545	ENDDO
1546	ENDDO
1547	ENDDO
1548	!
1549	!-- Calculate the number of particles of the total domain
1550	#if defined( __parallel )
1551	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
1552	CALL MPI_ALLREDUCE( number_of_particles, total_number_of_particles, 1, &
1553	MPI_INTEGER, MPI_SUM, comm2d, ierr )
1554	#else
1555	total_number_of_particles = number_of_particles
1556	#endif
1557
1558	RETURN
1559
1560	END SUBROUTINE lpm_create_particle
1561
1562
1563	!------------------------------------------------------------------------------!
1564	! Description:
1565	! ------------
1566	!> This routine initialize the particles as aerosols with physio-chemical
1567	!> properties.
1568	!------------------------------------------------------------------------------!
1569	SUBROUTINE lpm_init_aerosols(local_start)
1570
1571	REAL(wp) :: afactor !< curvature effects
1572	REAL(wp) :: bfactor !< solute effects
1573	REAL(wp) :: dlogr !< logarithmic width of radius bin
1574	REAL(wp) :: e_a !< vapor pressure
1575	REAL(wp) :: e_s !< saturation vapor pressure
1576	REAL(wp) :: rmin = 0.005e-6_wp !< minimum aerosol radius
1577	REAL(wp) :: rmax = 10.0e-6_wp !< maximum aerosol radius
1578	REAL(wp) :: r_mid !< mean radius of bin
1579	REAL(wp) :: r_l !< left radius of bin
1580	REAL(wp) :: r_r !< right radius of bin
1581	REAL(wp) :: sigma !< surface tension
1582	REAL(wp) :: t_int !< temperature
1583
1584	INTEGER(iwp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg), INTENT(IN) :: local_start !<
1585
1586	INTEGER(iwp) :: n !<
1587	INTEGER(iwp) :: ip !<
1588	INTEGER(iwp) :: jp !<
1589	INTEGER(iwp) :: kp !<
1590
1591	!
1592	!-- Set constants for different aerosol species
1593	IF ( TRIM(aero_species) .EQ. 'nacl' ) THEN
1594	molecular_weight_of_solute = 0.05844_wp
1595	rho_s = 2165.0_wp
1596	vanthoff = 2.0_wp
1597	ELSEIF ( TRIM(aero_species) .EQ. 'c3h4o4' ) THEN
1598	molecular_weight_of_solute = 0.10406_wp
1599	rho_s = 1600.0_wp
1600	vanthoff = 1.37_wp
1601	ELSEIF ( TRIM(aero_species) .EQ. 'nh4o3' ) THEN
1602	molecular_weight_of_solute = 0.08004_wp
1603	rho_s = 1720.0_wp
1604	vanthoff = 2.31_wp
1605	ELSE
1606	WRITE( message_string, * ) 'unknown aerosol species ', &
1607	'aero_species = "', TRIM( aero_species ), '"'
1608	CALL message( 'lpm_init', 'PA0470', 1, 2, 0, 6, 0 )
1609	ENDIF
1610	!
1611	!-- The following typical aerosol spectra are taken from Jaenicke (1993):
1612	!-- Tropospheric aerosols. Published in Aerosol-Cloud-Climate Interactions.
1613	IF ( TRIM(aero_type) .EQ. 'polar' ) THEN
1614	na = (/ 2.17e1, 1.86e-1, 3.04e-4 /) * 1.0E6
1615	rm = (/ 0.0689, 0.375, 4.29 /) * 1.0E-6
1616	log_sigma = (/ 0.245, 0.300, 0.291 /)
1617	ELSEIF ( TRIM(aero_type) .EQ. 'background' ) THEN
1618	na = (/ 1.29e2, 5.97e1, 6.35e1 /) * 1.0E6
1619	rm = (/ 0.0036, 0.127, 0.259 /) * 1.0E-6
1620	log_sigma = (/ 0.645, 0.253, 0.425 /)
1621	ELSEIF ( TRIM(aero_type) .EQ. 'maritime' ) THEN
1622	na = (/ 1.33e2, 6.66e1, 3.06e0 /) * 1.0E6
1623	rm = (/ 0.0039, 0.133, 0.29 /) * 1.0E-6
1624	log_sigma = (/ 0.657, 0.210, 0.396 /)
1625	ELSEIF ( TRIM(aero_type) .EQ. 'continental' ) THEN
1626	na = (/ 3.20e3, 2.90e3, 3.00e-1 /) * 1.0E6
1627	rm = (/ 0.01, 0.058, 0.9 /) * 1.0E-6
1628	log_sigma = (/ 0.161, 0.217, 0.380 /)
1629	ELSEIF ( TRIM(aero_type) .EQ. 'desert' ) THEN
1630	na = (/ 7.26e2, 1.14e3, 1.78e-1 /) * 1.0E6
1631	rm = (/ 0.001, 0.0188, 10.8 /) * 1.0E-6
1632	log_sigma = (/ 0.247, 0.770, 0.438 /)
1633	ELSEIF ( TRIM(aero_type) .EQ. 'rural' ) THEN
1634	na = (/ 6.65e3, 1.47e2, 1.99e3 /) * 1.0E6
1635	rm = (/ 0.00739, 0.0269, 0.0419 /) * 1.0E-6
1636	log_sigma = (/ 0.225, 0.557, 0.266 /)
1637	ELSEIF ( TRIM(aero_type) .EQ. 'urban' ) THEN
1638	na = (/ 9.93e4, 1.11e3, 3.64e4 /) * 1.0E6
1639	rm = (/ 0.00651, 0.00714, 0.0248 /) * 1.0E-6
1640	log_sigma = (/ 0.245, 0.666, 0.337 /)
1641	ELSEIF ( TRIM(aero_type) .EQ. 'user' ) THEN
1642	CONTINUE
1643	ELSE
1644	WRITE( message_string, * ) 'unknown aerosol type ', &
1645	'aero_type = "', TRIM( aero_type ), '"'
1646	CALL message( 'lpm_init', 'PA0459', 1, 2, 0, 6, 0 )
1647	ENDIF
1648
1649	DO ip = nxl, nxr
1650	DO jp = nys, nyn
1651	DO kp = nzb+1, nzt
1652
1653	number_of_particles = prt_count(kp,jp,ip)
1654	IF ( number_of_particles <= 0 ) CYCLE
1655	particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
1656
1657	dlogr = ( LOG10(rmax) - LOG10(rmin) ) / ( number_of_particles - local_start(kp,jp,ip) + 1 )
1658	!
1659	!-- Initialize the aerosols with a predefined spectral distribution
1660	!-- of the dry radius (logarithmically increasing bins) and a varying
1661	!-- weighting factor
1662	DO n = local_start(kp,jp,ip), number_of_particles !only new particles
1663
1664	r_l = 10.0*( LOG10( rmin ) + (n-1) dlogr )
1665	r_r = 10.0*( LOG10( rmin ) + n dlogr )
1666	r_mid = SQRT( r_l * r_r )
1667
1668	particles(n)%aux1 = r_mid
1669	particles(n)%weight_factor = &
1670	( na(1) / ( SQRT( 2.0 * pi ) * log_sigma(1) ) * &
1671	EXP( - LOG10( r_mid / rm(1) )*2 / ( 2.0 log_sigma(1)**2 ) ) + &
1672	na(2) / ( SQRT( 2.0 * pi ) * log_sigma(2) ) * &
1673	EXP( - LOG10( r_mid / rm(2) )*2 / ( 2.0 log_sigma(2)**2 ) ) + &
1674	na(3) / ( SQRT( 2.0 * pi ) * log_sigma(3) ) * &
1675	EXP( - LOG10( r_mid / rm(3) )*2 / ( 2.0 log_sigma(3)**2 ) ) &
1676	) * ( LOG10(r_r) - LOG10(r_l) ) * ( dx * dy * dzw(kp) )
1677
1678	!
1679	!-- Multiply weight_factor with the namelist parameter aero_weight
1680	!-- to increase or decrease the number of simulated aerosols
1681	particles(n)%weight_factor = particles(n)%weight_factor * aero_weight
1682
1683	IF ( particles(n)%weight_factor - FLOOR(particles(n)%weight_factor,KIND=wp) &
1684	.GT. random_function( iran_part ) ) THEN
1685	particles(n)%weight_factor = FLOOR(particles(n)%weight_factor,KIND=wp) + 1.0_wp
1686	ELSE
1687	particles(n)%weight_factor = FLOOR(particles(n)%weight_factor,KIND=wp)
1688	ENDIF
1689	!
1690	!-- Unnecessary particles will be deleted
1691	IF ( particles(n)%weight_factor .LE. 0.0 ) particles(n)%particle_mask = .FALSE.
1692
1693	ENDDO
1694	!
1695	!-- Set particle radius to equilibrium radius based on the environmental
1696	!-- supersaturation (Khvorostyanov and Curry, 2007, JGR). This avoids
1697	!-- the sometimes lengthy growth toward their equilibrium radius within
1698	!-- the simulation.
1699	t_int = pt(kp,jp,ip) * exner(kp)
1700
1701	e_s = magnus( t_int )
1702	e_a = q(kp,jp,ip) * hyp(kp) / ( q(kp,jp,ip) + rd_d_rv )
1703
1704	sigma = 0.0761_wp - 0.000155_wp * ( t_int - 273.15_wp )
1705	afactor = 2.0_wp * sigma / ( rho_l * r_v * t_int )
1706
1707	bfactor = vanthoff * molecular_weight_of_water * &
1708	rho_s / ( molecular_weight_of_solute * rho_l )
1709	!
1710	!-- The formula is only valid for subsaturated environments. For
1711	!-- supersaturations higher than -5 %, the supersaturation is set to -5%.
1712	IF ( e_a / e_s >= 0.95_wp ) e_a = 0.95_wp * e_s
1713
1714	DO n = local_start(kp,jp,ip), number_of_particles !only new particles
1715	!
1716	!-- For details on this equation, see Eq. (14) of Khvorostyanov and
1717	!-- Curry (2007, JGR)
1718	particles(n)%radius = bfactor*0.3333333_wp &
1719	particles(n)%aux1 / ( 1.0_wp - e_a / e_s )**0.3333333_wp / &
1720	( 1.0_wp + ( afactor / ( 3.0_wp * bfactor*0.3333333_wp &
1721	particles(n)%aux1 ) ) / &
1722	( 1.0_wp - e_a / e_s )**0.6666666_wp &
1723	)
1724
1725	ENDDO
1726
1727	ENDDO
1728	ENDDO
1729	ENDDO
1730
1731	END SUBROUTINE lpm_init_aerosols
1732
1733
1734	!------------------------------------------------------------------------------!
1735	! Description:
1736	! ------------
1737	!> Calculates quantities required for considering the SGS velocity fluctuations
1738	!> in the particle transport by a stochastic approach. The respective
1739	!> quantities are: SGS-TKE gradients and horizontally averaged profiles of the
1740	!> SGS TKE and the resolved-scale velocity variances.
1741	!------------------------------------------------------------------------------!
1742	SUBROUTINE lpm_init_sgs_tke
1743
1744	USE statistics, &
1745	ONLY: flow_statistics_called, hom, sums, sums_l
1746
1747	INTEGER(iwp) :: i !< index variable along x
1748	INTEGER(iwp) :: j !< index variable along y
1749	INTEGER(iwp) :: k !< index variable along z
1750	INTEGER(iwp) :: m !< running index for the surface elements
1751
1752	REAL(wp) :: flag1 !< flag to mask topography
1753
1754	!
1755	!-- TKE gradient along x and y
1756	DO i = nxl, nxr
1757	DO j = nys, nyn
1758	DO k = nzb, nzt+1
1759
1760	IF ( .NOT. BTEST( wall_flags_0(k,j,i-1), 0 ) .AND. &
1761	BTEST( wall_flags_0(k,j,i), 0 ) .AND. &
1762	BTEST( wall_flags_0(k,j,i+1), 0 ) ) &
1763	THEN
1764	de_dx(k,j,i) = 2.0_wp * sgs_wf_part * &
1765	( e(k,j,i+1) - e(k,j,i) ) * ddx
1766	ELSEIF ( BTEST( wall_flags_0(k,j,i-1), 0 ) .AND. &
1767	BTEST( wall_flags_0(k,j,i), 0 ) .AND. &
1768	.NOT. BTEST( wall_flags_0(k,j,i+1), 0 ) ) &
1769	THEN
1770	de_dx(k,j,i) = 2.0_wp * sgs_wf_part * &
1771	( e(k,j,i) - e(k,j,i-1) ) * ddx
1772	ELSEIF ( .NOT. BTEST( wall_flags_0(k,j,i), 22 ) .AND. &
1773	.NOT. BTEST( wall_flags_0(k,j,i+1), 22 ) ) &
1774	THEN
1775	de_dx(k,j,i) = 0.0_wp
1776	ELSEIF ( .NOT. BTEST( wall_flags_0(k,j,i-1), 22 ) .AND. &
1777	.NOT. BTEST( wall_flags_0(k,j,i), 22 ) ) &
1778	THEN
1779	de_dx(k,j,i) = 0.0_wp
1780	ELSE
1781	de_dx(k,j,i) = sgs_wf_part * ( e(k,j,i+1) - e(k,j,i-1) ) * ddx
1782	ENDIF
1783
1784	IF ( .NOT. BTEST( wall_flags_0(k,j-1,i), 0 ) .AND. &
1785	BTEST( wall_flags_0(k,j,i), 0 ) .AND. &
1786	BTEST( wall_flags_0(k,j+1,i), 0 ) ) &
1787	THEN
1788	de_dy(k,j,i) = 2.0_wp * sgs_wf_part * &
1789	( e(k,j+1,i) - e(k,j,i) ) * ddy
1790	ELSEIF ( BTEST( wall_flags_0(k,j-1,i), 0 ) .AND. &
1791	BTEST( wall_flags_0(k,j,i), 0 ) .AND. &
1792	.NOT. BTEST( wall_flags_0(k,j+1,i), 0 ) ) &
1793	THEN
1794	de_dy(k,j,i) = 2.0_wp * sgs_wf_part * &
1795	( e(k,j,i) - e(k,j-1,i) ) * ddy
1796	ELSEIF ( .NOT. BTEST( wall_flags_0(k,j,i), 22 ) .AND. &
1797	.NOT. BTEST( wall_flags_0(k,j+1,i), 22 ) ) &
1798	THEN
1799	de_dy(k,j,i) = 0.0_wp
1800	ELSEIF ( .NOT. BTEST( wall_flags_0(k,j-1,i), 22 ) .AND. &
1801	.NOT. BTEST( wall_flags_0(k,j,i), 22 ) ) &
1802	THEN
1803	de_dy(k,j,i) = 0.0_wp
1804	ELSE
1805	de_dy(k,j,i) = sgs_wf_part * ( e(k,j+1,i) - e(k,j-1,i) ) * ddy
1806	ENDIF
1807
1808	ENDDO
1809	ENDDO
1810	ENDDO
1811
1812	!
1813	!-- TKE gradient along z at topograhy and including bottom and top boundary conditions
1814	DO i = nxl, nxr
1815	DO j = nys, nyn
1816	DO k = nzb+1, nzt-1
1817	!
1818	!-- Flag to mask topography
1819	flag1 = MERGE( 1.0_wp, 0.0_wp, BTEST( wall_flags_0(k,j,i), 0 ) )
1820
1821	de_dz(k,j,i) = 2.0_wp * sgs_wf_part * &
1822	( e(k+1,j,i) - e(k-1,j,i) ) / ( zu(k+1) - zu(k-1) ) &
1823	* flag1
1824	ENDDO
1825	!
1826	!-- upward-facing surfaces
1827	DO m = bc_h(0)%start_index(j,i), bc_h(0)%end_index(j,i)
1828	k = bc_h(0)%k(m)
1829	de_dz(k,j,i) = 2.0_wp * sgs_wf_part * &
1830	( e(k+1,j,i) - e(k,j,i) ) / ( zu(k+1) - zu(k) )
1831	ENDDO
1832	!
1833	!-- downward-facing surfaces
1834	DO m = bc_h(1)%start_index(j,i), bc_h(1)%end_index(j,i)
1835	k = bc_h(1)%k(m)
1836	de_dz(k,j,i) = 2.0_wp * sgs_wf_part * &
1837	( e(k,j,i) - e(k-1,j,i) ) / ( zu(k) - zu(k-1) )
1838	ENDDO
1839
1840	de_dz(nzb,j,i) = 0.0_wp
1841	de_dz(nzt,j,i) = 0.0_wp
1842	de_dz(nzt+1,j,i) = 0.0_wp
1843	ENDDO
1844	ENDDO
1845	!
1846	!-- Ghost point exchange
1847	CALL exchange_horiz( de_dx, nbgp )
1848	CALL exchange_horiz( de_dy, nbgp )
1849	CALL exchange_horiz( de_dz, nbgp )
1850	CALL exchange_horiz( diss, nbgp )
1851	!
1852	!-- Set boundary conditions at non-periodic boundaries. Note, at non-period
1853	!-- boundaries zero-gradient boundary conditions are set for the subgrid TKE.
1854	!-- Thus, TKE gradients normal to the respective lateral boundaries are zero,
1855	!-- while tangetial TKE gradients then must be the same as within the prognostic
1856	!-- domain.
1857	IF ( bc_dirichlet_l ) THEN
1858	de_dx(:,:,-1) = 0.0_wp
1859	de_dy(:,:,-1) = de_dy(:,:,0)
1860	de_dz(:,:,-1) = de_dz(:,:,0)
1861	ENDIF
1862	IF ( bc_dirichlet_r ) THEN
1863	de_dx(:,:,nxr+1) = 0.0_wp
1864	de_dy(:,:,nxr+1) = de_dy(:,:,nxr)
1865	de_dz(:,:,nxr+1) = de_dz(:,:,nxr)
1866	ENDIF
1867	IF ( bc_dirichlet_n ) THEN
1868	de_dx(:,nyn+1,:) = de_dx(:,nyn,:)
1869	de_dy(:,nyn+1,:) = 0.0_wp
1870	de_dz(:,nyn+1,:) = de_dz(:,nyn,:)
1871	ENDIF
1872	IF ( bc_dirichlet_s ) THEN
1873	de_dx(:,nys-1,:) = de_dx(:,nys,:)
1874	de_dy(:,nys-1,:) = 0.0_wp
1875	de_dz(:,nys-1,:) = de_dz(:,nys,:)
1876	ENDIF
1877	!
1878	!-- Calculate the horizontally averaged profiles of SGS TKE and resolved
1879	!-- velocity variances (they may have been already calculated in routine
1880	!-- flow_statistics).
1881	IF ( .NOT. flow_statistics_called ) THEN
1882
1883	!
1884	!-- First calculate horizontally averaged profiles of the horizontal
1885	!-- velocities.
1886	sums_l(:,1,0) = 0.0_wp
1887	sums_l(:,2,0) = 0.0_wp
1888
1889	DO i = nxl, nxr
1890	DO j = nys, nyn
1891	DO k = nzb, nzt+1
1892	!
1893	!-- Flag indicating vicinity of wall
1894	flag1 = MERGE( 1.0_wp, 0.0_wp, BTEST( wall_flags_0(k,j,i), 24 ) )
1895
1896	sums_l(k,1,0) = sums_l(k,1,0) + u(k,j,i) * flag1
1897	sums_l(k,2,0) = sums_l(k,2,0) + v(k,j,i) * flag1
1898	ENDDO
1899	ENDDO
1900	ENDDO
1901
1902	#if defined( __parallel )
1903	!
1904	!-- Compute total sum from local sums
1905	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
1906	CALL MPI_ALLREDUCE( sums_l(nzb,1,0), sums(nzb,1), nzt+2-nzb, &
1907	MPI_REAL, MPI_SUM, comm2d, ierr )
1908	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
1909	CALL MPI_ALLREDUCE( sums_l(nzb,2,0), sums(nzb,2), nzt+2-nzb, &
1910	MPI_REAL, MPI_SUM, comm2d, ierr )
1911	#else
1912	sums(:,1) = sums_l(:,1,0)
1913	sums(:,2) = sums_l(:,2,0)
1914	#endif
1915
1916	!
1917	!-- Final values are obtained by division by the total number of grid
1918	!-- points used for the summation.
1919	hom(:,1,1,0) = sums(:,1) / ngp_2dh_outer(:,0) ! u
1920	hom(:,1,2,0) = sums(:,2) / ngp_2dh_outer(:,0) ! v
1921
1922	!
1923	!-- Now calculate the profiles of SGS TKE and the resolved-scale
1924	!-- velocity variances
1925	sums_l(:,8,0) = 0.0_wp
1926	sums_l(:,30,0) = 0.0_wp
1927	sums_l(:,31,0) = 0.0_wp
1928	sums_l(:,32,0) = 0.0_wp
1929	DO i = nxl, nxr
1930	DO j = nys, nyn
1931	DO k = nzb, nzt+1
1932	!
1933	!-- Flag indicating vicinity of wall
1934	flag1 = MERGE( 1.0_wp, 0.0_wp, BTEST( wall_flags_0(k,j,i), 24 ) )
1935
1936	sums_l(k,8,0) = sums_l(k,8,0) + e(k,j,i) * flag1
1937	sums_l(k,30,0) = sums_l(k,30,0) + ( u(k,j,i) - hom(k,1,1,0) )*2 flag1
1938	sums_l(k,31,0) = sums_l(k,31,0) + ( v(k,j,i) - hom(k,1,2,0) )*2 flag1
1939	sums_l(k,32,0) = sums_l(k,32,0) + w(k,j,i)*2 flag1
1940	ENDDO
1941	ENDDO
1942	ENDDO
1943
1944	#if defined( __parallel )
1945	!
1946	!-- Compute total sum from local sums
1947	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
1948	CALL MPI_ALLREDUCE( sums_l(nzb,8,0), sums(nzb,8), nzt+2-nzb, &
1949	MPI_REAL, MPI_SUM, comm2d, ierr )
1950	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
1951	CALL MPI_ALLREDUCE( sums_l(nzb,30,0), sums(nzb,30), nzt+2-nzb, &
1952	MPI_REAL, MPI_SUM, comm2d, ierr )
1953	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
1954	CALL MPI_ALLREDUCE( sums_l(nzb,31,0), sums(nzb,31), nzt+2-nzb, &
1955	MPI_REAL, MPI_SUM, comm2d, ierr )
1956	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
1957	CALL MPI_ALLREDUCE( sums_l(nzb,32,0), sums(nzb,32), nzt+2-nzb, &
1958	MPI_REAL, MPI_SUM, comm2d, ierr )
1959
1960	#else
1961	sums(:,8) = sums_l(:,8,0)
1962	sums(:,30) = sums_l(:,30,0)
1963	sums(:,31) = sums_l(:,31,0)
1964	sums(:,32) = sums_l(:,32,0)
1965	#endif
1966
1967	!
1968	!-- Final values are obtained by division by the total number of grid
1969	!-- points used for the summation.
1970	hom(:,1,8,0) = sums(:,8) / ngp_2dh_outer(:,0) ! e
1971	hom(:,1,30,0) = sums(:,30) / ngp_2dh_outer(:,0) ! u*2
1972	hom(:,1,31,0) = sums(:,31) / ngp_2dh_outer(:,0) ! v*2
1973	hom(:,1,32,0) = sums(:,32) / ngp_2dh_outer(:,0) ! w*2
1974
1975	ENDIF
1976
1977	END SUBROUTINE lpm_init_sgs_tke
1978
1979
1980	!------------------------------------------------------------------------------!
1981	! Description:
1982	! ------------
1983	!> Sobroutine control lpm actions, i.e. all actions during one time step.
1984	!------------------------------------------------------------------------------!
1985	SUBROUTINE lpm_actions( location )
1986
1987	CHARACTER (LEN=*), INTENT(IN) :: location !< call location string
1988
1989	INTEGER(iwp) :: i !<
1990	INTEGER(iwp) :: ie !<
1991	INTEGER(iwp) :: is !<
1992	INTEGER(iwp) :: j !<
1993	INTEGER(iwp) :: je !<
1994	INTEGER(iwp) :: js !<
1995	INTEGER(iwp), SAVE :: lpm_count = 0 !<
1996	INTEGER(iwp) :: k !<
1997	INTEGER(iwp) :: ke !<
1998	INTEGER(iwp) :: ks !<
1999	INTEGER(iwp) :: m !<
2000	INTEGER(iwp), SAVE :: steps = 0 !<
2001
2002	LOGICAL :: first_loop_stride !<
2003
2004
2005	SELECT CASE ( location )
2006
2007	CASE ( 'after_prognostic_equations' )
2008
2009	CALL cpu_log( log_point(25), 'lpm', 'start' )
2010	!
2011	!-- Write particle data at current time on file.
2012	!-- This has to be done here, before particles are further processed,
2013	!-- because they may be deleted within this timestep (in case that
2014	!-- dt_write_particle_data = dt_prel = particle_maximum_age).
2015	time_write_particle_data = time_write_particle_data + dt_3d
2016	IF ( time_write_particle_data >= dt_write_particle_data ) THEN
2017
2018	CALL lpm_data_output_particles
2019	!
2020	!-- The MOD function allows for changes in the output interval with restart
2021	!-- runs.
2022	time_write_particle_data = MOD( time_write_particle_data, &
2023	MAX( dt_write_particle_data, dt_3d ) )
2024	ENDIF
2025
2026	!
2027	!-- Initialize arrays for marking those particles to be deleted after the
2028	!-- (sub-) timestep
2029	deleted_particles = 0
2030
2031	!
2032	!-- Initialize variables used for accumulating the number of particles
2033	!-- xchanged between the subdomains during all sub-timesteps (if sgs
2034	!-- velocities are included). These data are output further below on the
2035	!-- particle statistics file.
2036	trlp_count_sum = 0
2037	trlp_count_recv_sum = 0
2038	trrp_count_sum = 0
2039	trrp_count_recv_sum = 0
2040	trsp_count_sum = 0
2041	trsp_count_recv_sum = 0
2042	trnp_count_sum = 0
2043	trnp_count_recv_sum = 0
2044	!
2045	!-- Calculate exponential term used in case of particle inertia for each
2046	!-- of the particle groups
2047	DO m = 1, number_of_particle_groups
2048	IF ( particle_groups(m)%density_ratio /= 0.0_wp ) THEN
2049	particle_groups(m)%exp_arg = &
2050	4.5_wp * particle_groups(m)%density_ratio * &
2051	molecular_viscosity / ( particle_groups(m)%radius )**2
2052
2053	particle_groups(m)%exp_term = EXP( -particle_groups(m)%exp_arg * &
2054	dt_3d )
2055	ENDIF
2056	ENDDO
2057	!
2058	!-- If necessary, release new set of particles
2059	IF ( ( simulated_time - last_particle_release_time ) >= dt_prel .AND. end_time_prel > simulated_time ) &
2060	THEN
2061	DO WHILE ( ( simulated_time - last_particle_release_time ) >= dt_prel )
2062	CALL lpm_create_particle( PHASE_RELEASE )
2063	last_particle_release_time = last_particle_release_time + dt_prel
2064	ENDDO
2065	ENDIF
2066	!
2067	!-- Reset summation arrays
2068	IF ( cloud_droplets ) THEN
2069	ql_c = 0.0_wp
2070	ql_v = 0.0_wp
2071	ql_vp = 0.0_wp
2072	ENDIF
2073
2074	first_loop_stride = .TRUE.
2075	grid_particles(:,:,:)%time_loop_done = .TRUE.
2076	!
2077	!-- Timestep loop for particle advection.
2078	!-- This loop has to be repeated until the advection time of every particle
2079	!-- (within the total domain!) has reached the LES timestep (dt_3d).
2080	!-- In case of including the SGS velocities, the particle timestep may be
2081	!-- smaller than the LES timestep (because of the Lagrangian timescale
2082	!-- restriction) and particles may require to undergo several particle
2083	!-- timesteps, before the LES timestep is reached. Because the number of these
2084	!-- particle timesteps to be carried out is unknown at first, these steps are
2085	!-- carried out in the following infinite loop with exit condition.
2086	DO
2087	CALL cpu_log( log_point_s(44), 'lpm_advec', 'start' )
2088	CALL cpu_log( log_point_s(44), 'lpm_advec', 'pause' )
2089
2090	!
2091	!-- If particle advection includes SGS velocity components, calculate the
2092	!-- required SGS quantities (i.e. gradients of the TKE, as well as
2093	!-- horizontally averaged profiles of the SGS TKE and the resolved-scale
2094	!-- velocity variances)
2095	IF ( use_sgs_for_particles .AND. .NOT. cloud_droplets ) THEN
2096	CALL lpm_init_sgs_tke
2097	ENDIF
2098	!
2099	!-- In case SGS-particle speed is considered, particles may carry out
2100	!-- several particle timesteps. In order to prevent unnecessary
2101	!-- treatment of particles that already reached the final time level,
2102	!-- particles are sorted into contiguous blocks of finished and
2103	!-- not-finished particles, in addition to their already sorting
2104	!-- according to their sub-boxes.
2105	IF ( .NOT. first_loop_stride .AND. use_sgs_for_particles ) &
2106	CALL lpm_sort_timeloop_done
2107
2108	DO i = nxl, nxr
2109	DO j = nys, nyn
2110	DO k = nzb+1, nzt
2111
2112	number_of_particles = prt_count(k,j,i)
2113	!
2114	!-- If grid cell gets empty, flag must be true
2115	IF ( number_of_particles <= 0 ) THEN
2116	grid_particles(k,j,i)%time_loop_done = .TRUE.
2117	CYCLE
2118	ENDIF
2119
2120	IF ( .NOT. first_loop_stride .AND. &
2121	grid_particles(k,j,i)%time_loop_done ) CYCLE
2122
2123	particles => grid_particles(k,j,i)%particles(1:number_of_particles)
2124
2125	particles(1:number_of_particles)%particle_mask = .TRUE.
2126	!
2127	!-- Initialize the variable storing the total time that a particle
2128	!-- has advanced within the timestep procedure
2129	IF ( first_loop_stride ) THEN
2130	particles(1:number_of_particles)%dt_sum = 0.0_wp
2131	ENDIF
2132	!
2133	!-- Particle (droplet) growth by condensation/evaporation and
2134	!-- collision
2135	IF ( cloud_droplets .AND. first_loop_stride) THEN
2136	!
2137	!-- Droplet growth by condensation / evaporation
2138	CALL lpm_droplet_condensation(i,j,k)
2139	!
2140	!-- Particle growth by collision
2141	IF ( collision_kernel /= 'none' ) THEN
2142	CALL lpm_droplet_collision(i,j,k)
2143	ENDIF
2144
2145	ENDIF
2146	!
2147	!-- Initialize the switch used for the loop exit condition checked
2148	!-- at the end of this loop. If at least one particle has failed to
2149	!-- reach the LES timestep, this switch will be set false in
2150	!-- lpm_advec.
2151	dt_3d_reached_l = .TRUE.
2152
2153	!
2154	!-- Particle advection
2155	CALL lpm_advec(i,j,k)
2156	!
2157	!-- Particle reflection from walls. Only applied if the particles
2158	!-- are in the vertical range of the topography. (Here, some
2159	!-- optimization is still possible.)
2160	IF ( topography /= 'flat' .AND. k < nzb_max + 2 ) THEN
2161	CALL lpm_boundary_conds( 'walls', i, j, k )
2162	ENDIF
2163	!
2164	!-- User-defined actions after the calculation of the new particle
2165	!-- position
2166	CALL user_lpm_advec(i,j,k)
2167	!
2168	!-- Apply boundary conditions to those particles that have crossed
2169	!-- the top or bottom boundary and delete those particles, which are
2170	!-- older than allowed
2171	CALL lpm_boundary_conds( 'bottom/top', i, j, k )
2172	!
2173	!--- If not all particles of the actual grid cell have reached the
2174	!-- LES timestep, this cell has to do another loop iteration. Due to
2175	!-- the fact that particles can move into neighboring grid cells,
2176	!-- these neighbor cells also have to perform another loop iteration.
2177	!-- Please note, this realization does not work properly if
2178	!-- particles move into another subdomain.
2179	IF ( .NOT. dt_3d_reached_l ) THEN
2180	ks = MAX(nzb+1,k-1)
2181	ke = MIN(nzt,k+1)
2182	js = MAX(nys,j-1)
2183	je = MIN(nyn,j+1)
2184	is = MAX(nxl,i-1)
2185	ie = MIN(nxr,i+1)
2186	grid_particles(ks:ke,js:je,is:ie)%time_loop_done = .FALSE.
2187	ELSE
2188	grid_particles(k,j,i)%time_loop_done = .TRUE.
2189	ENDIF
2190
2191	ENDDO
2192	ENDDO
2193	ENDDO
2194
2195	steps = steps + 1
2196	dt_3d_reached_l = ALL(grid_particles(:,:,:)%time_loop_done)
2197	!
2198	!-- Find out, if all particles on every PE have completed the LES timestep
2199	!-- and set the switch corespondingly
2200	#if defined( __parallel )
2201	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
2202	CALL MPI_ALLREDUCE( dt_3d_reached_l, dt_3d_reached, 1, MPI_LOGICAL, &
2203	MPI_LAND, comm2d, ierr )
2204	#else
2205	dt_3d_reached = dt_3d_reached_l
2206	#endif
2207
2208	CALL cpu_log( log_point_s(44), 'lpm_advec', 'stop' )
2209
2210	!
2211	!-- Apply splitting and merging algorithm
2212	IF ( cloud_droplets ) THEN
2213	IF ( splitting ) THEN
2214	CALL lpm_splitting
2215	ENDIF
2216	IF ( merging ) THEN
2217	CALL lpm_merging
2218	ENDIF
2219	ENDIF
2220	!
2221	!-- Move Particles local to PE to a different grid cell
2222	CALL lpm_move_particle
2223	!
2224	!-- Horizontal boundary conditions including exchange between subdmains
2225	CALL lpm_exchange_horiz
2226
2227	!
2228	!-- IF .FALSE., lpm_sort_in_subboxes is done inside pcmp
2229	IF ( .NOT. dt_3d_reached .OR. .NOT. nested_run ) THEN
2230	!
2231	!-- Pack particles (eliminate those marked for deletion),
2232	!-- determine new number of particles
2233	CALL lpm_sort_in_subboxes
2234	!
2235	!-- Initialize variables for the next (sub-) timestep, i.e., for marking
2236	!-- those particles to be deleted after the timestep
2237	deleted_particles = 0
2238	ENDIF
2239
2240	IF ( dt_3d_reached ) EXIT
2241
2242	first_loop_stride = .FALSE.
2243	ENDDO ! timestep loop
2244	!
2245	!-- in case of nested runs do the transfer of particles after every full model time step
2246	IF ( nested_run ) THEN
2247	CALL particles_from_parent_to_child
2248	CALL particles_from_child_to_parent
2249	CALL pmcp_p_delete_particles_in_fine_grid_area
2250
2251	CALL lpm_sort_in_subboxes
2252
2253	deleted_particles = 0
2254	ENDIF
2255
2256	!
2257	!-- Calculate the new liquid water content for each grid box
2258	IF ( cloud_droplets ) CALL lpm_calc_liquid_water_content
2259
2260	!
2261	!-- Deallocate unused memory
2262	IF ( deallocate_memory .AND. lpm_count == step_dealloc ) THEN
2263	CALL dealloc_particles_array
2264	lpm_count = 0
2265	ELSEIF ( deallocate_memory ) THEN
2266	lpm_count = lpm_count + 1
2267	ENDIF
2268
2269	!
2270	!-- Write particle statistics (in particular the number of particles
2271	!-- exchanged between the subdomains) on file
2272	IF ( write_particle_statistics ) CALL lpm_write_exchange_statistics
2273
2274	CALL cpu_log( log_point(25), 'lpm', 'stop' )
2275
2276	! !
2277	! !-- Output of particle time series
2278	! IF ( particle_advection ) THEN
2279	! IF ( time_dopts >= dt_dopts .OR. &
2280	! ( time_since_reference_point >= particle_advection_start .AND. &
2281	! first_call_lpm ) ) THEN
2282	! CALL lpm_data_output_ptseries
2283	! time_dopts = MOD( time_dopts, MAX( dt_dopts, dt_3d ) )
2284	! ENDIF
2285	! ENDIF
2286
2287	CASE DEFAULT
2288	CONTINUE
2289
2290	END SELECT
2291
2292	END SUBROUTINE lpm_actions
2293
2294
2295	!------------------------------------------------------------------------------!
2296	! Description:
2297	! ------------
2298	!
2299	!------------------------------------------------------------------------------!
2300	SUBROUTINE particles_from_parent_to_child
2301	IMPLICIT NONE
2302
2303	CALL pmcp_c_get_particle_from_parent ! Child actions
2304	CALL pmcp_p_fill_particle_win ! Parent actions
2305
2306	RETURN
2307	END SUBROUTINE particles_from_parent_to_child
2308
2309
2310	!------------------------------------------------------------------------------!
2311	! Description:
2312	! ------------
2313	!
2314	!------------------------------------------------------------------------------!
2315	SUBROUTINE particles_from_child_to_parent
2316	IMPLICIT NONE
2317
2318	CALL pmcp_c_send_particle_to_parent ! Child actions
2319	CALL pmcp_p_empty_particle_win ! Parent actions
2320
2321	RETURN
2322	END SUBROUTINE particles_from_child_to_parent
2323
2324	!------------------------------------------------------------------------------!
2325	! Description:
2326	! ------------
2327	!> This routine write exchange statistics of the lpm in a ascii file.
2328	!------------------------------------------------------------------------------!
2329	SUBROUTINE lpm_write_exchange_statistics
2330
2331	INTEGER(iwp) :: ip !<
2332	INTEGER(iwp) :: jp !<
2333	INTEGER(iwp) :: kp !<
2334	INTEGER(iwp) :: tot_number_of_particles
2335
2336	!
2337	!-- Determine the current number of particles
2338	number_of_particles = 0
2339	DO ip = nxl, nxr
2340	DO jp = nys, nyn
2341	DO kp = nzb+1, nzt
2342	number_of_particles = number_of_particles &
2343	+ prt_count(kp,jp,ip)
2344	ENDDO
2345	ENDDO
2346	ENDDO
2347
2348	CALL check_open( 80 )
2349	#if defined( __parallel )
2350	WRITE ( 80, 8000 ) current_timestep_number+1, simulated_time+dt_3d, &
2351	number_of_particles, pleft, trlp_count_sum, &
2352	trlp_count_recv_sum, pright, trrp_count_sum, &
2353	trrp_count_recv_sum, psouth, trsp_count_sum, &
2354	trsp_count_recv_sum, pnorth, trnp_count_sum, &
2355	trnp_count_recv_sum
2356	#else
2357	WRITE ( 80, 8000 ) current_timestep_number+1, simulated_time+dt_3d, &
2358	number_of_particles
2359	#endif
2360	CALL close_file( 80 )
2361
2362	IF ( number_of_particles > 0 ) THEN
2363	WRITE(9,*) 'number_of_particles ', number_of_particles, &
2364	current_timestep_number + 1, simulated_time + dt_3d
2365	ENDIF
2366
2367	#if defined( __parallel )
2368	CALL MPI_ALLREDUCE( number_of_particles, tot_number_of_particles, 1, &
2369	MPI_INTEGER, MPI_SUM, comm2d, ierr )
2370	#else
2371	tot_number_of_particles = number_of_particles
2372	#endif
2373
2374	IF ( nested_run ) THEN
2375	CALL pmcp_g_print_number_of_particles( simulated_time+dt_3d, &
2376	tot_number_of_particles)
2377	ENDIF
2378
2379	!
2380	!-- Formats
2381	8000 FORMAT (I6,1X,F7.2,4X,I10,5X,4(I3,1X,I4,'/',I4,2X),6X,I10)
2382
2383
2384	END SUBROUTINE lpm_write_exchange_statistics
2385
2386
2387	!------------------------------------------------------------------------------!
2388	! Description:
2389	! ------------
2390	!> Write particle data in FORTRAN binary and/or netCDF format
2391	!------------------------------------------------------------------------------!
2392	SUBROUTINE lpm_data_output_particles
2393
2394	INTEGER(iwp) :: ip !<
2395	INTEGER(iwp) :: jp !<
2396	INTEGER(iwp) :: kp !<
2397
2398	CALL cpu_log( log_point_s(40), 'lpm_data_output', 'start' )
2399
2400	!
2401	!-- Attention: change version number for unit 85 (in routine check_open)
2402	!-- whenever the output format for this unit is changed!
2403	CALL check_open( 85 )
2404
2405	WRITE ( 85 ) simulated_time
2406	WRITE ( 85 ) prt_count
2407
2408	DO ip = nxl, nxr
2409	DO jp = nys, nyn
2410	DO kp = nzb+1, nzt
2411	number_of_particles = prt_count(kp,jp,ip)
2412	particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
2413	IF ( number_of_particles <= 0 ) CYCLE
2414	WRITE ( 85 ) particles
2415	ENDDO
2416	ENDDO
2417	ENDDO
2418
2419	CALL close_file( 85 )
2420
2421
2422	#if defined( __netcdf )
2423	! !
2424	! !-- Output in netCDF format
2425	! CALL check_open( 108 )
2426	!
2427	! !
2428	! !-- Update the NetCDF time axis
2429	! prt_time_count = prt_time_count + 1
2430	!
2431	! nc_stat = NF90_PUT_VAR( id_set_prt, id_var_time_prt, &
2432	! (/ simulated_time /), &
2433	! start = (/ prt_time_count /), count = (/ 1 /) )
2434	! CALL netcdf_handle_error( 'lpm_data_output_particles', 1 )
2435	!
2436	! !
2437	! !-- Output the real number of particles used
2438	! nc_stat = NF90_PUT_VAR( id_set_prt, id_var_rnop_prt, &
2439	! (/ number_of_particles /), &
2440	! start = (/ prt_time_count /), count = (/ 1 /) )
2441	! CALL netcdf_handle_error( 'lpm_data_output_particles', 2 )
2442	!
2443	! !
2444	! !-- Output all particle attributes
2445	! nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(1), particles%age, &
2446	! start = (/ 1, prt_time_count /), &
2447	! count = (/ maximum_number_of_particles /) )
2448	! CALL netcdf_handle_error( 'lpm_data_output_particles', 3 )
2449	!
2450	! nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(2), particles%user, &
2451	! start = (/ 1, prt_time_count /), &
2452	! count = (/ maximum_number_of_particles /) )
2453	! CALL netcdf_handle_error( 'lpm_data_output_particles', 4 )
2454	!
2455	! nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(3), particles%origin_x, &
2456	! start = (/ 1, prt_time_count /), &
2457	! count = (/ maximum_number_of_particles /) )
2458	! CALL netcdf_handle_error( 'lpm_data_output_particles', 5 )
2459	!
2460	! nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(4), particles%origin_y, &
2461	! start = (/ 1, prt_time_count /), &
2462	! count = (/ maximum_number_of_particles /) )
2463	! CALL netcdf_handle_error( 'lpm_data_output_particles', 6 )
2464	!
2465	! nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(5), particles%origin_z, &
2466	! start = (/ 1, prt_time_count /), &
2467	! count = (/ maximum_number_of_particles /) )
2468	! CALL netcdf_handle_error( 'lpm_data_output_particles', 7 )
2469	!
2470	! nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(6), particles%radius, &
2471	! start = (/ 1, prt_time_count /), &
2472	! count = (/ maximum_number_of_particles /) )
2473	! CALL netcdf_handle_error( 'lpm_data_output_particles', 8 )
2474	!
2475	! nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(7), particles%speed_x, &
2476	! start = (/ 1, prt_time_count /), &
2477	! count = (/ maximum_number_of_particles /) )
2478	! CALL netcdf_handle_error( 'lpm_data_output_particles', 9 )
2479	!
2480	! nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(8), particles%speed_y, &
2481	! start = (/ 1, prt_time_count /), &
2482	! count = (/ maximum_number_of_particles /) )
2483	! CALL netcdf_handle_error( 'lpm_data_output_particles', 10 )
2484	!
2485	! nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(9), particles%speed_z, &
2486	! start = (/ 1, prt_time_count /), &
2487	! count = (/ maximum_number_of_particles /) )
2488	! CALL netcdf_handle_error( 'lpm_data_output_particles', 11 )
2489	!
2490	! nc_stat = NF90_PUT_VAR( id_set_prt,id_var_prt(10), &
2491	! particles%weight_factor, &
2492	! start = (/ 1, prt_time_count /), &
2493	! count = (/ maximum_number_of_particles /) )
2494	! CALL netcdf_handle_error( 'lpm_data_output_particles', 12 )
2495	!
2496	! nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(11), particles%x, &
2497	! start = (/ 1, prt_time_count /), &
2498	! count = (/ maximum_number_of_particles /) )
2499	! CALL netcdf_handle_error( 'lpm_data_output_particles', 13 )
2500	!
2501	! nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(12), particles%y, &
2502	! start = (/ 1, prt_time_count /), &
2503	! count = (/ maximum_number_of_particles /) )
2504	! CALL netcdf_handle_error( 'lpm_data_output_particles', 14 )
2505	!
2506	! nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(13), particles%z, &
2507	! start = (/ 1, prt_time_count /), &
2508	! count = (/ maximum_number_of_particles /) )
2509	! CALL netcdf_handle_error( 'lpm_data_output_particles', 15 )
2510	!
2511	! nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(14), particles%class, &
2512	! start = (/ 1, prt_time_count /), &
2513	! count = (/ maximum_number_of_particles /) )
2514	! CALL netcdf_handle_error( 'lpm_data_output_particles', 16 )
2515	!
2516	! nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(15), particles%group, &
2517	! start = (/ 1, prt_time_count /), &
2518	! count = (/ maximum_number_of_particles /) )
2519	! CALL netcdf_handle_error( 'lpm_data_output_particles', 17 )
2520	!
2521	! nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(16), &
2522	! particles%id2, &
2523	! start = (/ 1, prt_time_count /), &
2524	! count = (/ maximum_number_of_particles /) )
2525	! CALL netcdf_handle_error( 'lpm_data_output_particles', 18 )
2526	!
2527	! nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(17), particles%id1, &
2528	! start = (/ 1, prt_time_count /), &
2529	! count = (/ maximum_number_of_particles /) )
2530	! CALL netcdf_handle_error( 'lpm_data_output_particles', 19 )
2531	!
2532	#endif
2533
2534	CALL cpu_log( log_point_s(40), 'lpm_data_output', 'stop' )
2535
2536	END SUBROUTINE lpm_data_output_particles
2537
2538	!------------------------------------------------------------------------------!
2539	! Description:
2540	! ------------
2541	!> This routine calculates and provide particle timeseries output.
2542	!------------------------------------------------------------------------------!
2543	SUBROUTINE lpm_data_output_ptseries
2544
2545	INTEGER(iwp) :: i !<
2546	INTEGER(iwp) :: inum !<
2547	INTEGER(iwp) :: j !<
2548	INTEGER(iwp) :: jg !<
2549	INTEGER(iwp) :: k !<
2550	INTEGER(iwp) :: n !<
2551
2552	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: pts_value !<
2553	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: pts_value_l !<
2554
2555
2556	CALL cpu_log( log_point(36), 'data_output_ptseries', 'start' )
2557
2558	IF ( myid == 0 ) THEN
2559	!
2560	!-- Open file for time series output in NetCDF format
2561	dopts_time_count = dopts_time_count + 1
2562	CALL check_open( 109 )
2563	#if defined( __netcdf )
2564	!
2565	!-- Update the particle time series time axis
2566	nc_stat = NF90_PUT_VAR( id_set_pts, id_var_time_pts, &
2567	(/ time_since_reference_point /), &
2568	start = (/ dopts_time_count /), count = (/ 1 /) )
2569	CALL netcdf_handle_error( 'data_output_ptseries', 391 )
2570	#endif
2571
2572	ENDIF
2573
2574	ALLOCATE( pts_value(0:number_of_particle_groups,dopts_num), &
2575	pts_value_l(0:number_of_particle_groups,dopts_num) )
2576
2577	pts_value_l = 0.0_wp
2578	pts_value_l(:,16) = 9999999.9_wp ! for calculation of minimum radius
2579
2580	!
2581	!-- Calculate or collect the particle time series quantities for all particles
2582	!-- and seperately for each particle group (if there is more than one group)
2583	DO i = nxl, nxr
2584	DO j = nys, nyn
2585	DO k = nzb, nzt
2586	number_of_particles = prt_count(k,j,i)
2587	IF (number_of_particles <= 0) CYCLE
2588	particles => grid_particles(k,j,i)%particles(1:number_of_particles)
2589	DO n = 1, number_of_particles
2590
2591	IF ( particles(n)%particle_mask ) THEN ! Restrict analysis to active particles
2592
2593	pts_value_l(0,1) = pts_value_l(0,1) + 1.0_wp ! total # of particles
2594	pts_value_l(0,2) = pts_value_l(0,2) + &
2595	( particles(n)%x - particles(n)%origin_x ) ! mean x
2596	pts_value_l(0,3) = pts_value_l(0,3) + &
2597	( particles(n)%y - particles(n)%origin_y ) ! mean y
2598	pts_value_l(0,4) = pts_value_l(0,4) + &
2599	( particles(n)%z - particles(n)%origin_z ) ! mean z
2600	pts_value_l(0,5) = pts_value_l(0,5) + particles(n)%z ! mean z (absolute)
2601	pts_value_l(0,6) = pts_value_l(0,6) + particles(n)%speed_x ! mean u
2602	pts_value_l(0,7) = pts_value_l(0,7) + particles(n)%speed_y ! mean v
2603	pts_value_l(0,8) = pts_value_l(0,8) + particles(n)%speed_z ! mean w
2604	pts_value_l(0,9) = pts_value_l(0,9) + particles(n)%rvar1 ! mean sgsu
2605	pts_value_l(0,10) = pts_value_l(0,10) + particles(n)%rvar2 ! mean sgsv
2606	pts_value_l(0,11) = pts_value_l(0,11) + particles(n)%rvar3 ! mean sgsw
2607	IF ( particles(n)%speed_z > 0.0_wp ) THEN
2608	pts_value_l(0,12) = pts_value_l(0,12) + 1.0_wp ! # of upward moving prts
2609	pts_value_l(0,13) = pts_value_l(0,13) + &
2610	particles(n)%speed_z ! mean w upw.
2611	ELSE
2612	pts_value_l(0,14) = pts_value_l(0,14) + &
2613	particles(n)%speed_z ! mean w down
2614	ENDIF
2615	pts_value_l(0,15) = pts_value_l(0,15) + particles(n)%radius ! mean rad
2616	pts_value_l(0,16) = MIN( pts_value_l(0,16), particles(n)%radius ) ! minrad
2617	pts_value_l(0,17) = MAX( pts_value_l(0,17), particles(n)%radius ) ! maxrad
2618	pts_value_l(0,18) = pts_value_l(0,18) + 1.0_wp
2619	pts_value_l(0,19) = pts_value_l(0,18) + 1.0_wp
2620	!
2621	!-- Repeat the same for the respective particle group
2622	IF ( number_of_particle_groups > 1 ) THEN
2623	jg = particles(n)%group
2624
2625	pts_value_l(jg,1) = pts_value_l(jg,1) + 1.0_wp
2626	pts_value_l(jg,2) = pts_value_l(jg,2) + &
2627	( particles(n)%x - particles(n)%origin_x )
2628	pts_value_l(jg,3) = pts_value_l(jg,3) + &
2629	( particles(n)%y - particles(n)%origin_y )
2630	pts_value_l(jg,4) = pts_value_l(jg,4) + &
2631	( particles(n)%z - particles(n)%origin_z )
2632	pts_value_l(jg,5) = pts_value_l(jg,5) + particles(n)%z
2633	pts_value_l(jg,6) = pts_value_l(jg,6) + particles(n)%speed_x
2634	pts_value_l(jg,7) = pts_value_l(jg,7) + particles(n)%speed_y
2635	pts_value_l(jg,8) = pts_value_l(jg,8) + particles(n)%speed_z
2636	pts_value_l(jg,9) = pts_value_l(jg,9) + particles(n)%rvar1
2637	pts_value_l(jg,10) = pts_value_l(jg,10) + particles(n)%rvar2
2638	pts_value_l(jg,11) = pts_value_l(jg,11) + particles(n)%rvar3
2639	IF ( particles(n)%speed_z > 0.0_wp ) THEN
2640	pts_value_l(jg,12) = pts_value_l(jg,12) + 1.0_wp
2641	pts_value_l(jg,13) = pts_value_l(jg,13) + particles(n)%speed_z
2642	ELSE
2643	pts_value_l(jg,14) = pts_value_l(jg,14) + particles(n)%speed_z
2644	ENDIF
2645	pts_value_l(jg,15) = pts_value_l(jg,15) + particles(n)%radius
2646	pts_value_l(jg,16) = MIN( pts_value(jg,16), particles(n)%radius )
2647	pts_value_l(jg,17) = MAX( pts_value(jg,17), particles(n)%radius )
2648	pts_value_l(jg,18) = pts_value_l(jg,18) + 1.0_wp
2649	pts_value_l(jg,19) = pts_value_l(jg,19) + 1.0_wp
2650	ENDIF
2651
2652	ENDIF
2653
2654	ENDDO
2655
2656	ENDDO
2657	ENDDO
2658	ENDDO
2659
2660
2661	#if defined( __parallel )
2662	!
2663	!-- Sum values of the subdomains
2664	inum = number_of_particle_groups + 1
2665
2666	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
2667	CALL MPI_ALLREDUCE( pts_value_l(0,1), pts_value(0,1), 15*inum, MPI_REAL, &
2668	MPI_SUM, comm2d, ierr )
2669	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
2670	CALL MPI_ALLREDUCE( pts_value_l(0,16), pts_value(0,16), inum, MPI_REAL, &
2671	MPI_MIN, comm2d, ierr )
2672	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
2673	CALL MPI_ALLREDUCE( pts_value_l(0,17), pts_value(0,17), inum, MPI_REAL, &
2674	MPI_MAX, comm2d, ierr )
2675	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
2676	CALL MPI_ALLREDUCE( pts_value_l(0,18), pts_value(0,18), inum, MPI_REAL, &
2677	MPI_MAX, comm2d, ierr )
2678	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
2679	CALL MPI_ALLREDUCE( pts_value_l(0,19), pts_value(0,19), inum, MPI_REAL, &
2680	MPI_MIN, comm2d, ierr )
2681	#else
2682	pts_value(:,1:19) = pts_value_l(:,1:19)
2683	#endif
2684
2685	!
2686	!-- Normalize the above calculated quantities (except min/max values) with the
2687	!-- total number of particles
2688	IF ( number_of_particle_groups > 1 ) THEN
2689	inum = number_of_particle_groups
2690	ELSE
2691	inum = 0
2692	ENDIF
2693
2694	DO j = 0, inum
2695
2696	IF ( pts_value(j,1) > 0.0_wp ) THEN
2697
2698	pts_value(j,2:15) = pts_value(j,2:15) / pts_value(j,1)
2699	IF ( pts_value(j,12) > 0.0_wp .AND. pts_value(j,12) < 1.0_wp ) THEN
2700	pts_value(j,13) = pts_value(j,13) / pts_value(j,12)
2701	pts_value(j,14) = pts_value(j,14) / ( 1.0_wp - pts_value(j,12) )
2702	ELSEIF ( pts_value(j,12) == 0.0_wp ) THEN
2703	pts_value(j,13) = -1.0_wp
2704	ELSE
2705	pts_value(j,14) = -1.0_wp
2706	ENDIF
2707
2708	ENDIF
2709
2710	ENDDO
2711
2712	!
2713	!-- Calculate higher order moments of particle time series quantities,
2714	!-- seperately for each particle group (if there is more than one group)
2715	DO i = nxl, nxr
2716	DO j = nys, nyn
2717	DO k = nzb, nzt
2718	number_of_particles = prt_count(k,j,i)
2719	IF (number_of_particles <= 0) CYCLE
2720	particles => grid_particles(k,j,i)%particles(1:number_of_particles)
2721	DO n = 1, number_of_particles
2722
2723	pts_value_l(0,20) = pts_value_l(0,20) + ( particles(n)%x - &
2724	particles(n)%origin_x - pts_value(0,2) )*2 ! x2
2725	pts_value_l(0,21) = pts_value_l(0,21) + ( particles(n)%y - &
2726	particles(n)%origin_y - pts_value(0,3) )*2 ! y2
2727	pts_value_l(0,22) = pts_value_l(0,22) + ( particles(n)%z - &
2728	particles(n)%origin_z - pts_value(0,4) )*2 ! z2
2729	pts_value_l(0,23) = pts_value_l(0,23) + ( particles(n)%speed_x - &
2730	pts_value(0,6) )*2 ! u2
2731	pts_value_l(0,24) = pts_value_l(0,24) + ( particles(n)%speed_y - &
2732	pts_value(0,7) )*2 ! v2
2733	pts_value_l(0,25) = pts_value_l(0,25) + ( particles(n)%speed_z - &
2734	pts_value(0,8) )*2 ! w2
2735	pts_value_l(0,26) = pts_value_l(0,26) + ( particles(n)%rvar1 - &
2736	pts_value(0,9) )**2 ! u"2
2737	pts_value_l(0,27) = pts_value_l(0,27) + ( particles(n)%rvar2 - &
2738	pts_value(0,10) )**2 ! v"2
2739	pts_value_l(0,28) = pts_value_l(0,28) + ( particles(n)%rvar3 - &
2740	pts_value(0,11) )**2 ! w"2
2741	!
2742	!-- Repeat the same for the respective particle group
2743	IF ( number_of_particle_groups > 1 ) THEN
2744	jg = particles(n)%group
2745
2746	pts_value_l(jg,20) = pts_value_l(jg,20) + ( particles(n)%x - &
2747	particles(n)%origin_x - pts_value(jg,2) )**2
2748	pts_value_l(jg,21) = pts_value_l(jg,21) + ( particles(n)%y - &
2749	particles(n)%origin_y - pts_value(jg,3) )**2
2750	pts_value_l(jg,22) = pts_value_l(jg,22) + ( particles(n)%z - &
2751	particles(n)%origin_z - pts_value(jg,4) )**2
2752	pts_value_l(jg,23) = pts_value_l(jg,23) + ( particles(n)%speed_x - &
2753	pts_value(jg,6) )**2
2754	pts_value_l(jg,24) = pts_value_l(jg,24) + ( particles(n)%speed_y - &
2755	pts_value(jg,7) )**2
2756	pts_value_l(jg,25) = pts_value_l(jg,25) + ( particles(n)%speed_z - &
2757	pts_value(jg,8) )**2
2758	pts_value_l(jg,26) = pts_value_l(jg,26) + ( particles(n)%rvar1 - &
2759	pts_value(jg,9) )**2
2760	pts_value_l(jg,27) = pts_value_l(jg,27) + ( particles(n)%rvar2 - &
2761	pts_value(jg,10) )**2
2762	pts_value_l(jg,28) = pts_value_l(jg,28) + ( particles(n)%rvar3 - &
2763	pts_value(jg,11) )**2
2764	ENDIF
2765
2766	ENDDO
2767	ENDDO
2768	ENDDO
2769	ENDDO
2770
2771	pts_value_l(0,29) = ( number_of_particles - pts_value(0,1) / numprocs )**2
2772	! variance of particle numbers
2773	IF ( number_of_particle_groups > 1 ) THEN
2774	DO j = 1, number_of_particle_groups
2775	pts_value_l(j,29) = ( pts_value_l(j,1) - &
2776	pts_value(j,1) / numprocs )**2
2777	ENDDO
2778	ENDIF
2779
2780	#if defined( __parallel )
2781	!
2782	!-- Sum values of the subdomains
2783	inum = number_of_particle_groups + 1
2784
2785	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
2786	CALL MPI_ALLREDUCE( pts_value_l(0,20), pts_value(0,20), inum*10, MPI_REAL, &
2787	MPI_SUM, comm2d, ierr )
2788	#else
2789	pts_value(:,20:29) = pts_value_l(:,20:29)
2790	#endif
2791
2792	!
2793	!-- Normalize the above calculated quantities with the total number of
2794	!-- particles
2795	IF ( number_of_particle_groups > 1 ) THEN
2796	inum = number_of_particle_groups
2797	ELSE
2798	inum = 0
2799	ENDIF
2800
2801	DO j = 0, inum
2802
2803	IF ( pts_value(j,1) > 0.0_wp ) THEN
2804	pts_value(j,20:28) = pts_value(j,20:28) / pts_value(j,1)
2805	ENDIF
2806	pts_value(j,29) = pts_value(j,29) / numprocs
2807
2808	ENDDO
2809
2810	#if defined( __netcdf )
2811	!
2812	!-- Output particle time series quantities in NetCDF format
2813	IF ( myid == 0 ) THEN
2814	DO j = 0, inum
2815	DO i = 1, dopts_num
2816	nc_stat = NF90_PUT_VAR( id_set_pts, id_var_dopts(i,j), &
2817	(/ pts_value(j,i) /), &
2818	start = (/ dopts_time_count /), &
2819	count = (/ 1 /) )
2820	CALL netcdf_handle_error( 'data_output_ptseries', 392 )
2821	ENDDO
2822	ENDDO
2823	ENDIF
2824	#endif
2825
2826	DEALLOCATE( pts_value, pts_value_l )
2827
2828	CALL cpu_log( log_point(36), 'data_output_ptseries', 'stop' )
2829
2830	END SUBROUTINE lpm_data_output_ptseries
2831
2832
2833	!------------------------------------------------------------------------------!
2834	! Description:
2835	! ------------
2836	!> This routine reads the respective restart data for the lpm.
2837	!------------------------------------------------------------------------------!
2838	SUBROUTINE lpm_rrd_local_particles
2839
2840	CHARACTER (LEN=10) :: particle_binary_version !<
2841	CHARACTER (LEN=10) :: version_on_file !<
2842
2843	INTEGER(iwp) :: alloc_size !<
2844	INTEGER(iwp) :: ip !<
2845	INTEGER(iwp) :: jp !<
2846	INTEGER(iwp) :: kp !<
2847
2848	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: tmp_particles !<
2849
2850	!
2851	!-- Read particle data from previous model run.
2852	!-- First open the input unit.
2853	IF ( myid_char == '' ) THEN
2854	OPEN ( 90, FILE='PARTICLE_RESTART_DATA_IN'//myid_char, &
2855	FORM='UNFORMATTED' )
2856	ELSE
2857	OPEN ( 90, FILE='PARTICLE_RESTART_DATA_IN/'//myid_char, &
2858	FORM='UNFORMATTED' )
2859	ENDIF
2860
2861	!
2862	!-- First compare the version numbers
2863	READ ( 90 ) version_on_file
2864	particle_binary_version = '4.0'
2865	IF ( TRIM( version_on_file ) /= TRIM( particle_binary_version ) ) THEN
2866	message_string = 'version mismatch concerning data from prior ' // &
2867	'run &version on file = "' // &
2868	TRIM( version_on_file ) // &
2869	'&version in program = "' // &
2870	TRIM( particle_binary_version ) // '"'
2871	CALL message( 'lpm_read_restart_file', 'PA0214', 1, 2, 0, 6, 0 )
2872	ENDIF
2873
2874	!
2875	!-- If less particles are stored on the restart file than prescribed by
2876	!-- 1, the remainder is initialized by zero_particle to avoid
2877	!-- errors.
2878	zero_particle = particle_type( 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, &
2879	0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, &
2880	0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, &
2881	0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, &
2882	0, 0, 0_idp, .FALSE., -1 )
2883	!
2884	!-- Read some particle parameters and the size of the particle arrays,
2885	!-- allocate them and read their contents.
2886	READ ( 90 ) bc_par_b, bc_par_lr, bc_par_ns, bc_par_t, &
2887	last_particle_release_time, number_of_particle_groups, &
2888	particle_groups, time_write_particle_data
2889
2890	ALLOCATE( prt_count(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &
2891	grid_particles(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2892
2893	READ ( 90 ) prt_count
2894
2895	DO ip = nxl, nxr
2896	DO jp = nys, nyn
2897	DO kp = nzb+1, nzt
2898
2899	number_of_particles = prt_count(kp,jp,ip)
2900	IF ( number_of_particles > 0 ) THEN
2901	alloc_size = MAX( INT( number_of_particles * &
2902	( 1.0_wp + alloc_factor / 100.0_wp ) ), &
2903	1 )
2904	ELSE
2905	alloc_size = 1
2906	ENDIF
2907
2908	ALLOCATE( grid_particles(kp,jp,ip)%particles(1:alloc_size) )
2909
2910	IF ( number_of_particles > 0 ) THEN
2911	ALLOCATE( tmp_particles(1:number_of_particles) )
2912	READ ( 90 ) tmp_particles
2913	grid_particles(kp,jp,ip)%particles(1:number_of_particles) = tmp_particles
2914	DEALLOCATE( tmp_particles )
2915	IF ( number_of_particles < alloc_size ) THEN
2916	grid_particles(kp,jp,ip)%particles(number_of_particles+1:alloc_size) &
2917	= zero_particle
2918	ENDIF
2919	ELSE
2920	grid_particles(kp,jp,ip)%particles(1:alloc_size) = zero_particle
2921	ENDIF
2922
2923	ENDDO
2924	ENDDO
2925	ENDDO
2926
2927	CLOSE ( 90 )
2928	!
2929	!-- Must be called to sort particles into blocks, which is needed for a fast
2930	!-- interpolation of the LES fields on the particle position.
2931	CALL lpm_sort_in_subboxes
2932
2933
2934	END SUBROUTINE lpm_rrd_local_particles
2935
2936
2937	SUBROUTINE lpm_rrd_local( k, nxlf, nxlc, nxl_on_file, nxrf, nxrc, &
2938	nxr_on_file, nynf, nync, nyn_on_file, nysf, &
2939	nysc, nys_on_file, tmp_3d, found )
2940
2941
2942	USE control_parameters, &
2943	ONLY: length, restart_string
2944
2945	INTEGER(iwp) :: k !<
2946	INTEGER(iwp) :: nxlc !<
2947	INTEGER(iwp) :: nxlf !<
2948	INTEGER(iwp) :: nxl_on_file !<
2949	INTEGER(iwp) :: nxrc !<
2950	INTEGER(iwp) :: nxrf !<
2951	INTEGER(iwp) :: nxr_on_file !<
2952	INTEGER(iwp) :: nync !<
2953	INTEGER(iwp) :: nynf !<
2954	INTEGER(iwp) :: nyn_on_file !<
2955	INTEGER(iwp) :: nysc !<
2956	INTEGER(iwp) :: nysf !<
2957	INTEGER(iwp) :: nys_on_file !<
2958
2959	LOGICAL, INTENT(OUT) :: found
2960
2961	REAL(wp), DIMENSION(nzb:nzt+1,nys_on_file-nbgp:nyn_on_file+nbgp,nxl_on_file-nbgp:nxr_on_file+nbgp) :: tmp_3d !<
2962
2963
2964	found = .TRUE.
2965
2966	SELECT CASE ( restart_string(1:length) )
2967
2968	CASE ( 'iran' ) ! matching random numbers is still unresolved issue
2969	IF ( k == 1 ) READ ( 13 ) iran, iran_part
2970
2971	CASE ( 'pc_av' )
2972	IF ( .NOT. ALLOCATED( pc_av ) ) THEN
2973	ALLOCATE( pc_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2974	ENDIF
2975	IF ( k == 1 ) READ ( 13 ) tmp_3d
2976	pc_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
2977	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
2978
2979	CASE ( 'pr_av' )
2980	IF ( .NOT. ALLOCATED( pr_av ) ) THEN
2981	ALLOCATE( pr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2982	ENDIF
2983	IF ( k == 1 ) READ ( 13 ) tmp_3d
2984	pr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
2985	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
2986
2987	CASE ( 'ql_c_av' )
2988	IF ( .NOT. ALLOCATED( ql_c_av ) ) THEN
2989	ALLOCATE( ql_c_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2990	ENDIF
2991	IF ( k == 1 ) READ ( 13 ) tmp_3d
2992	ql_c_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
2993	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
2994
2995	CASE ( 'ql_v_av' )
2996	IF ( .NOT. ALLOCATED( ql_v_av ) ) THEN
2997	ALLOCATE( ql_v_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2998	ENDIF
2999	IF ( k == 1 ) READ ( 13 ) tmp_3d
3000	ql_v_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
3001	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
3002
3003	CASE ( 'ql_vp_av' )
3004	IF ( .NOT. ALLOCATED( ql_vp_av ) ) THEN
3005	ALLOCATE( ql_vp_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
3006	ENDIF
3007	IF ( k == 1 ) READ ( 13 ) tmp_3d
3008	ql_vp_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
3009	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
3010
3011	CASE DEFAULT
3012
3013	found = .FALSE.
3014
3015	END SELECT
3016
3017
3018	END SUBROUTINE lpm_rrd_local
3019
3020	!------------------------------------------------------------------------------!
3021	! Description:
3022	! ------------
3023	!> This routine writes the respective restart data for the lpm.
3024	!------------------------------------------------------------------------------!
3025	SUBROUTINE lpm_wrd_local
3026
3027	CHARACTER (LEN=10) :: particle_binary_version !<
3028
3029	INTEGER(iwp) :: ip !<
3030	INTEGER(iwp) :: jp !<
3031	INTEGER(iwp) :: kp !<
3032	!
3033	!-- First open the output unit.
3034	IF ( myid_char == '' ) THEN
3035	OPEN ( 90, FILE='PARTICLE_RESTART_DATA_OUT'//myid_char, &
3036	FORM='UNFORMATTED')
3037	ELSE
3038	IF ( myid == 0 ) CALL local_system( 'mkdir PARTICLE_RESTART_DATA_OUT' )
3039	#if defined( __parallel )
3040	!
3041	!-- Set a barrier in order to allow that thereafter all other processors
3042	!-- in the directory created by PE0 can open their file
3043	CALL MPI_BARRIER( comm2d, ierr )
3044	#endif
3045	OPEN ( 90, FILE='PARTICLE_RESTART_DATA_OUT/'//myid_char, &
3046	FORM='UNFORMATTED' )
3047	ENDIF
3048
3049	!
3050	!-- Write the version number of the binary format.
3051	!-- Attention: After changes to the following output commands the version
3052	!-- --------- number of the variable particle_binary_version must be
3053	!-- changed! Also, the version number and the list of arrays
3054	!-- to be read in lpm_read_restart_file must be adjusted
3055	!-- accordingly.
3056	particle_binary_version = '4.0'
3057	WRITE ( 90 ) particle_binary_version
3058
3059	!
3060	!-- Write some particle parameters, the size of the particle arrays
3061	WRITE ( 90 ) bc_par_b, bc_par_lr, bc_par_ns, bc_par_t, &
3062	last_particle_release_time, number_of_particle_groups, &
3063	particle_groups, time_write_particle_data
3064
3065	WRITE ( 90 ) prt_count
3066
3067	DO ip = nxl, nxr
3068	DO jp = nys, nyn
3069	DO kp = nzb+1, nzt
3070	number_of_particles = prt_count(kp,jp,ip)
3071	particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
3072	IF ( number_of_particles <= 0 ) CYCLE
3073	WRITE ( 90 ) particles
3074	ENDDO
3075	ENDDO
3076	ENDDO
3077
3078	CLOSE ( 90 )
3079
3080	#if defined( __parallel )
3081	CALL MPI_BARRIER( comm2d, ierr )
3082	#endif
3083
3084	CALL wrd_write_string( 'iran' )
3085	WRITE ( 14 ) iran, iran_part
3086
3087
3088	END SUBROUTINE lpm_wrd_local
3089
3090
3091	!------------------------------------------------------------------------------!
3092	! Description:
3093	! ------------
3094	!> This routine writes the respective restart data for the lpm.
3095	!------------------------------------------------------------------------------!
3096	SUBROUTINE lpm_wrd_global
3097
3098	CALL wrd_write_string( 'curvature_solution_effects' )
3099	WRITE ( 14 ) curvature_solution_effects
3100
3101	END SUBROUTINE lpm_wrd_global
3102
3103
3104	!------------------------------------------------------------------------------!
3105	! Description:
3106	! ------------
3107	!> This routine writes the respective restart data for the lpm.
3108	!------------------------------------------------------------------------------!
3109	SUBROUTINE lpm_rrd_global( found )
3110
3111	USE control_parameters, &
3112	ONLY: length, restart_string
3113
3114	LOGICAL, INTENT(OUT) :: found
3115
3116	found = .TRUE.
3117
3118	SELECT CASE ( restart_string(1:length) )
3119
3120	CASE ( 'curvature_solution_effects' )
3121	READ ( 13 ) curvature_solution_effects
3122
3123	! CASE ( 'global_paramter' )
3124	! READ ( 13 ) global_parameter
3125	! CASE ( 'global_array' )
3126	! IF ( .NOT. ALLOCATED( global_array ) ) ALLOCATE( global_array(1:10) )
3127	! READ ( 13 ) global_array
3128
3129	CASE DEFAULT
3130
3131	found = .FALSE.
3132
3133	END SELECT
3134
3135	END SUBROUTINE lpm_rrd_global
3136
3137
3138	!------------------------------------------------------------------------------!
3139	! Description:
3140	! ------------
3141	!> This is a submodule of the lagrangian particle model. It contains all
3142	!> dynamic processes of the lpm. This includes the advection (resolved and sub-
3143	!> grid scale) as well as the boundary conditions of particles. As a next step
3144	!> this submodule should be excluded as an own file.
3145	!------------------------------------------------------------------------------!
3146	SUBROUTINE lpm_advec (ip,jp,kp)
3147
3148	LOGICAL :: subbox_at_wall !< flag to see if the current subgridbox is adjacent to a wall
3149
3150	INTEGER(iwp) :: i !< index variable along x
3151	INTEGER(iwp) :: ip !< index variable along x
3152	INTEGER(iwp) :: j !< index variable along y
3153	INTEGER(iwp) :: jp !< index variable along y
3154	INTEGER(iwp) :: k !< index variable along z
3155	INTEGER(iwp) :: k_wall !< vertical index of topography top
3156	INTEGER(iwp) :: kp !< index variable along z
3157	INTEGER(iwp) :: kw !< index variable along z
3158	INTEGER(iwp) :: n !< loop variable over all particles in a grid box
3159	INTEGER(iwp) :: nb !< block number particles are sorted in
3160	INTEGER(iwp) :: surf_start !< Index on surface data-type for current grid box
3161
3162	INTEGER(iwp), DIMENSION(0:7) :: start_index !< start particle index for current block
3163	INTEGER(iwp), DIMENSION(0:7) :: end_index !< start particle index for current block
3164
3165	REAL(wp) :: aa !< dummy argument for horizontal particle interpolation
3166	REAL(wp) :: bb !< dummy argument for horizontal particle interpolation
3167	REAL(wp) :: cc !< dummy argument for horizontal particle interpolation
3168	REAL(wp) :: d_z_p_z0 !< inverse of interpolation length for logarithmic interpolation
3169	REAL(wp) :: dd !< dummy argument for horizontal particle interpolation
3170	REAL(wp) :: de_dx_int_l !< x/y-interpolated TKE gradient (x) at particle position at lower vertical level
3171	REAL(wp) :: de_dx_int_u !< x/y-interpolated TKE gradient (x) at particle position at upper vertical level
3172	REAL(wp) :: de_dy_int_l !< x/y-interpolated TKE gradient (y) at particle position at lower vertical level
3173	REAL(wp) :: de_dy_int_u !< x/y-interpolated TKE gradient (y) at particle position at upper vertical level
3174	REAL(wp) :: de_dt !< temporal derivative of TKE experienced by the particle
3175	REAL(wp) :: de_dt_min !< lower level for temporal TKE derivative
3176	REAL(wp) :: de_dz_int_l !< x/y-interpolated TKE gradient (z) at particle position at lower vertical level
3177	REAL(wp) :: de_dz_int_u !< x/y-interpolated TKE gradient (z) at particle position at upper vertical level
3178	REAL(wp) :: diameter !< diamter of droplet
3179	REAL(wp) :: diss_int_l !< x/y-interpolated dissipation at particle position at lower vertical level
3180	REAL(wp) :: diss_int_u !< x/y-interpolated dissipation at particle position at upper vertical level
3181	REAL(wp) :: dt_particle_m !< previous particle time step
3182	REAL(wp) :: dz_temp !< dummy for the vertical grid spacing
3183	REAL(wp) :: e_int_l !< x/y-interpolated TKE at particle position at lower vertical level
3184	REAL(wp) :: e_int_u !< x/y-interpolated TKE at particle position at upper vertical level
3185	REAL(wp) :: e_mean_int !< horizontal mean TKE at particle height
3186	REAL(wp) :: exp_arg !< argument in the exponent - particle radius
3187	REAL(wp) :: exp_term !< exponent term
3188	REAL(wp) :: gg !< dummy argument for horizontal particle interpolation
3189	REAL(wp) :: height_p !< dummy argument for logarithmic interpolation
3190	REAL(wp) :: log_z_z0_int !< logarithmus used for surface_layer interpolation
3191	REAL(wp) :: random_gauss !< Gaussian-distributed random number used for SGS particle advection
3192	REAL(wp) :: RL !< Lagrangian autocorrelation coefficient
3193	REAL(wp) :: rg1 !< Gaussian distributed random number
3194	REAL(wp) :: rg2 !< Gaussian distributed random number
3195	REAL(wp) :: rg3 !< Gaussian distributed random number
3196	REAL(wp) :: sigma !< velocity standard deviation
3197	REAL(wp) :: u_int_l !< x/y-interpolated u-component at particle position at lower vertical level
3198	REAL(wp) :: u_int_u !< x/y-interpolated u-component at particle position at upper vertical level
3199	REAL(wp) :: us_int !< friction velocity at particle grid box
3200	REAL(wp) :: usws_int !< surface momentum flux (u component) at particle grid box
3201	REAL(wp) :: v_int_l !< x/y-interpolated v-component at particle position at lower vertical level
3202	REAL(wp) :: v_int_u !< x/y-interpolated v-component at particle position at upper vertical level
3203	REAL(wp) :: vsws_int !< surface momentum flux (u component) at particle grid box
3204	REAL(wp) :: vv_int !< dummy to compute interpolated mean SGS TKE, used to scale SGS advection
3205	REAL(wp) :: w_int_l !< x/y-interpolated w-component at particle position at lower vertical level
3206	REAL(wp) :: w_int_u !< x/y-interpolated w-component at particle position at upper vertical level
3207	REAL(wp) :: w_s !< terminal velocity of droplets
3208	REAL(wp) :: x !< dummy argument for horizontal particle interpolation
3209	REAL(wp) :: y !< dummy argument for horizontal particle interpolation
3210	REAL(wp) :: z_p !< surface layer height (0.5 dz)
3211
3212	REAL(wp), PARAMETER :: a_rog = 9.65_wp !< parameter for fall velocity
3213	REAL(wp), PARAMETER :: b_rog = 10.43_wp !< parameter for fall velocity
3214	REAL(wp), PARAMETER :: c_rog = 0.6_wp !< parameter for fall velocity
3215	REAL(wp), PARAMETER :: k_cap_rog = 4.0_wp !< parameter for fall velocity
3216	REAL(wp), PARAMETER :: k_low_rog = 12.0_wp !< parameter for fall velocity
3217	REAL(wp), PARAMETER :: d0_rog = 0.745_wp !< separation diameter
3218
3219	REAL(wp), DIMENSION(number_of_particles) :: term_1_2 !< flag to communicate whether a particle is near topography or not
3220	REAL(wp), DIMENSION(number_of_particles) :: dens_ratio !< ratio between the density of the fluid and the density of the particles
3221	REAL(wp), DIMENSION(number_of_particles) :: de_dx_int !< horizontal TKE gradient along x at particle position
3222	REAL(wp), DIMENSION(number_of_particles) :: de_dy_int !< horizontal TKE gradient along y at particle position
3223	REAL(wp), DIMENSION(number_of_particles) :: de_dz_int !< horizontal TKE gradient along z at particle position
3224	REAL(wp), DIMENSION(number_of_particles) :: diss_int !< dissipation at particle position
3225	REAL(wp), DIMENSION(number_of_particles) :: dt_gap !< remaining time until particle time integration reaches LES time
3226	REAL(wp), DIMENSION(number_of_particles) :: dt_particle !< particle time step
3227	REAL(wp), DIMENSION(number_of_particles) :: e_int !< TKE at particle position
3228	REAL(wp), DIMENSION(number_of_particles) :: fs_int !< weighting factor for subgrid-scale particle speed
3229	REAL(wp), DIMENSION(number_of_particles) :: lagr_timescale !< Lagrangian timescale
3230	REAL(wp), DIMENSION(number_of_particles) :: rvar1_temp !< SGS particle velocity - u-component
3231	REAL(wp), DIMENSION(number_of_particles) :: rvar2_temp !< SGS particle velocity - v-component
3232	REAL(wp), DIMENSION(number_of_particles) :: rvar3_temp !< SGS particle velocity - w-component
3233	REAL(wp), DIMENSION(number_of_particles) :: u_int !< u-component of particle speed
3234	REAL(wp), DIMENSION(number_of_particles) :: v_int !< v-component of particle speed
3235	REAL(wp), DIMENSION(number_of_particles) :: w_int !< w-component of particle speed
3236	REAL(wp), DIMENSION(number_of_particles) :: xv !< x-position
3237	REAL(wp), DIMENSION(number_of_particles) :: yv !< y-position
3238	REAL(wp), DIMENSION(number_of_particles) :: zv !< z-position
3239
3240	REAL(wp), DIMENSION(number_of_particles, 3) :: rg !< vector of Gaussian distributed random numbers
3241
3242	CALL cpu_log( log_point_s(44), 'lpm_advec', 'continue' )
3243
3244	!
3245	!-- Determine height of Prandtl layer and distance between Prandtl-layer
3246	!-- height and horizontal mean roughness height, which are required for
3247	!-- vertical logarithmic interpolation of horizontal particle speeds
3248	!-- (for particles below first vertical grid level).
3249	z_p = zu(nzb+1) - zw(nzb)
3250	d_z_p_z0 = 1.0_wp / ( z_p - z0_av_global )
3251
3252	start_index = grid_particles(kp,jp,ip)%start_index
3253	end_index = grid_particles(kp,jp,ip)%end_index
3254
3255	xv = particles(1:number_of_particles)%x
3256	yv = particles(1:number_of_particles)%y
3257	zv = particles(1:number_of_particles)%z
3258
3259	DO nb = 0, 7
3260	!
3261	!-- Interpolate u velocity-component
3262	i = ip
3263	j = jp + block_offset(nb)%j_off
3264	k = kp + block_offset(nb)%k_off
3265
3266	DO n = start_index(nb), end_index(nb)
3267	!
3268	!-- Interpolation of the u velocity component onto particle position.
3269	!-- Particles are interpolation bi-linearly in the horizontal and a
3270	!-- linearly in the vertical. An exception is made for particles below
3271	!-- the first vertical grid level in case of a prandtl layer. In this
3272	!-- case the horizontal particle velocity components are determined using
3273	!-- Monin-Obukhov relations (if branch).
3274	!-- First, check if particle is located below first vertical grid level
3275	!-- above topography (Prandtl-layer height)
3276	!-- Determine vertical index of topography top
3277	k_wall = get_topography_top_index_ji( jp, ip, 's' )
3278
3279	IF ( constant_flux_layer .AND. zv(n) - zw(k_wall) < z_p ) THEN
3280	!
3281	!-- Resolved-scale horizontal particle velocity is zero below z0.
3282	IF ( zv(n) - zw(k_wall) < z0_av_global ) THEN
3283	u_int(n) = 0.0_wp
3284	ELSE
3285	!
3286	!-- Determine the sublayer. Further used as index.
3287	height_p = ( zv(n) - zw(k_wall) - z0_av_global ) &
3288	* REAL( number_of_sublayers, KIND=wp ) &
3289	* d_z_p_z0
3290	!
3291	!-- Calculate LOG(z/z0) for exact particle height. Therefore,
3292	!-- interpolate linearly between precalculated logarithm.
3293	log_z_z0_int = log_z_z0(INT(height_p)) &
3294	+ ( height_p - INT(height_p) ) &
3295	* ( log_z_z0(INT(height_p)+1) &
3296	- log_z_z0(INT(height_p)) &
3297	)
3298	!
3299	!-- Get friction velocity and momentum flux from new surface data
3300	!-- types.
3301	IF ( surf_def_h(0)%start_index(jp,ip) <= &
3302	surf_def_h(0)%end_index(jp,ip) ) THEN
3303	surf_start = surf_def_h(0)%start_index(jp,ip)
3304	!-- Limit friction velocity. In narrow canyons or holes the
3305	!-- friction velocity can become very small, resulting in a too
3306	!-- large particle speed.
3307	us_int = MAX( surf_def_h(0)%us(surf_start), 0.01_wp )
3308	usws_int = surf_def_h(0)%usws(surf_start)
3309	ELSEIF ( surf_lsm_h%start_index(jp,ip) <= &
3310	surf_lsm_h%end_index(jp,ip) ) THEN
3311	surf_start = surf_lsm_h%start_index(jp,ip)
3312	us_int = MAX( surf_lsm_h%us(surf_start), 0.01_wp )
3313	usws_int = surf_lsm_h%usws(surf_start)
3314	ELSEIF ( surf_usm_h%start_index(jp,ip) <= &
3315	surf_usm_h%end_index(jp,ip) ) THEN
3316	surf_start = surf_usm_h%start_index(jp,ip)
3317	us_int = MAX( surf_usm_h%us(surf_start), 0.01_wp )
3318	usws_int = surf_usm_h%usws(surf_start)
3319	ENDIF
3320
3321	!
3322	!-- Neutral solution is applied for all situations, e.g. also for
3323	!-- unstable and stable situations. Even though this is not exact
3324	!-- this saves a lot of CPU time since several calls of intrinsic
3325	!-- FORTRAN procedures (LOG, ATAN) are avoided, This is justified
3326	!-- as sensitivity studies revealed no significant effect of
3327	!-- using the neutral solution also for un/stable situations.
3328	u_int(n) = -usws_int / ( us_int * kappa + 1E-10_wp ) &
3329	* log_z_z0_int - u_gtrans
3330
3331	ENDIF
3332	!
3333	!-- Particle above the first grid level. Bi-linear interpolation in the
3334	!-- horizontal and linear interpolation in the vertical direction.
3335	ELSE
3336
3337	x = xv(n) - i * dx
3338	y = yv(n) + ( 0.5_wp - j ) * dy
3339	aa = x2 + y2
3340	bb = ( dx - x )2 + y2
3341	cc = x2 + ( dy - y )2
3342	dd = ( dx - x )2 + ( dy - y )2
3343	gg = aa + bb + cc + dd
3344
3345	u_int_l = ( ( gg - aa ) * u(k,j,i) + ( gg - bb ) * u(k,j,i+1) &
3346	+ ( gg - cc ) * u(k,j+1,i) + ( gg - dd ) * &
3347	u(k,j+1,i+1) ) / ( 3.0_wp * gg ) - u_gtrans
3348
3349	IF ( k == nzt ) THEN
3350	u_int(n) = u_int_l
3351	ELSE
3352	u_int_u = ( ( gg-aa ) * u(k+1,j,i) + ( gg-bb ) * u(k+1,j,i+1) &
3353	+ ( gg-cc ) * u(k+1,j+1,i) + ( gg-dd ) * &
3354	u(k+1,j+1,i+1) ) / ( 3.0_wp * gg ) - u_gtrans
3355	u_int(n) = u_int_l + ( zv(n) - zu(k) ) / dzw(k+1) * &
3356	( u_int_u - u_int_l )
3357	ENDIF
3358
3359	ENDIF
3360
3361	ENDDO
3362	!
3363	!-- Same procedure for interpolation of the v velocity-component
3364	i = ip + block_offset(nb)%i_off
3365	j = jp
3366	k = kp + block_offset(nb)%k_off
3367
3368	DO n = start_index(nb), end_index(nb)
3369
3370	!
3371	!-- Determine vertical index of topography top
3372	k_wall = get_topography_top_index_ji( jp,ip, 's' )
3373
3374	IF ( constant_flux_layer .AND. zv(n) - zw(k_wall) < z_p ) THEN
3375	IF ( zv(n) - zw(k_wall) < z0_av_global ) THEN
3376	!
3377	!-- Resolved-scale horizontal particle velocity is zero below z0.
3378	v_int(n) = 0.0_wp
3379	ELSE
3380	!
3381	!-- Determine the sublayer. Further used as index. Please note,
3382	!-- logarithmus can not be reused from above, as in in case of
3383	!-- topography particle on u-grid can be above surface-layer height,
3384	!-- whereas it can be below on v-grid.
3385	height_p = ( zv(n) - zw(k_wall) - z0_av_global ) &
3386	* REAL( number_of_sublayers, KIND=wp ) &
3387	* d_z_p_z0
3388	!
3389	!-- Calculate LOG(z/z0) for exact particle height. Therefore,
3390	!-- interpolate linearly between precalculated logarithm.
3391	log_z_z0_int = log_z_z0(INT(height_p)) &
3392	+ ( height_p - INT(height_p) ) &
3393	* ( log_z_z0(INT(height_p)+1) &
3394	- log_z_z0(INT(height_p)) &
3395	)
3396	!
3397	!-- Get friction velocity and momentum flux from new surface data
3398	!-- types.
3399	IF ( surf_def_h(0)%start_index(jp,ip) <= &
3400	surf_def_h(0)%end_index(jp,ip) ) THEN
3401	surf_start = surf_def_h(0)%start_index(jp,ip)
3402	!-- Limit friction velocity. In narrow canyons or holes the
3403	!-- friction velocity can become very small, resulting in a too
3404	!-- large particle speed.
3405	us_int = MAX( surf_def_h(0)%us(surf_start), 0.01_wp )
3406	vsws_int = surf_def_h(0)%vsws(surf_start)
3407	ELSEIF ( surf_lsm_h%start_index(jp,ip) <= &
3408	surf_lsm_h%end_index(jp,ip) ) THEN
3409	surf_start = surf_lsm_h%start_index(jp,ip)
3410	us_int = MAX( surf_lsm_h%us(surf_start), 0.01_wp )
3411	vsws_int = surf_lsm_h%vsws(surf_start)
3412	ELSEIF ( surf_usm_h%start_index(jp,ip) <= &
3413	surf_usm_h%end_index(jp,ip) ) THEN
3414	surf_start = surf_usm_h%start_index(jp,ip)
3415	us_int = MAX( surf_usm_h%us(surf_start), 0.01_wp )
3416	vsws_int = surf_usm_h%vsws(surf_start)
3417	ENDIF
3418	!
3419	!-- Neutral solution is applied for all situations, e.g. also for
3420	!-- unstable and stable situations. Even though this is not exact
3421	!-- this saves a lot of CPU time since several calls of intrinsic
3422	!-- FORTRAN procedures (LOG, ATAN) are avoided, This is justified
3423	!-- as sensitivity studies revealed no significant effect of
3424	!-- using the neutral solution also for un/stable situations.
3425	v_int(n) = -vsws_int / ( us_int * kappa + 1E-10_wp ) &
3426	* log_z_z0_int - v_gtrans
3427
3428	ENDIF
3429
3430	ELSE
3431	x = xv(n) + ( 0.5_wp - i ) * dx
3432	y = yv(n) - j * dy
3433	aa = x2 + y2
3434	bb = ( dx - x )2 + y2
3435	cc = x2 + ( dy - y )2
3436	dd = ( dx - x )2 + ( dy - y )2
3437	gg = aa + bb + cc + dd
3438
3439	v_int_l = ( ( gg - aa ) * v(k,j,i) + ( gg - bb ) * v(k,j,i+1) &
3440	+ ( gg - cc ) * v(k,j+1,i) + ( gg - dd ) * v(k,j+1,i+1) &
3441	) / ( 3.0_wp * gg ) - v_gtrans
3442
3443	IF ( k == nzt ) THEN
3444	v_int(n) = v_int_l
3445	ELSE
3446	v_int_u = ( ( gg-aa ) * v(k+1,j,i) + ( gg-bb ) * v(k+1,j,i+1) &
3447	+ ( gg-cc ) * v(k+1,j+1,i) + ( gg-dd ) * v(k+1,j+1,i+1) &
3448	) / ( 3.0_wp * gg ) - v_gtrans
3449	v_int(n) = v_int_l + ( zv(n) - zu(k) ) / dzw(k+1) * &
3450	( v_int_u - v_int_l )
3451	ENDIF
3452
3453	ENDIF
3454
3455	ENDDO
3456	!
3457	!-- Same procedure for interpolation of the w velocity-component
3458	i = ip + block_offset(nb)%i_off
3459	j = jp + block_offset(nb)%j_off
3460	k = kp - 1
3461
3462	DO n = start_index(nb), end_index(nb)
3463
3464	IF ( vertical_particle_advection(particles(n)%group) ) THEN
3465
3466	x = xv(n) + ( 0.5_wp - i ) * dx
3467	y = yv(n) + ( 0.5_wp - j ) * dy
3468	aa = x2 + y2
3469	bb = ( dx - x )2 + y2
3470	cc = x2 + ( dy - y )2
3471	dd = ( dx - x )2 + ( dy - y )2
3472	gg = aa + bb + cc + dd
3473
3474	w_int_l = ( ( gg - aa ) * w(k,j,i) + ( gg - bb ) * w(k,j,i+1) &
3475	+ ( gg - cc ) * w(k,j+1,i) + ( gg - dd ) * w(k,j+1,i+1) &
3476	) / ( 3.0_wp * gg )
3477
3478	IF ( k == nzt ) THEN
3479	w_int(n) = w_int_l
3480	ELSE
3481	w_int_u = ( ( gg-aa ) * w(k+1,j,i) + &
3482	( gg-bb ) * w(k+1,j,i+1) + &
3483	( gg-cc ) * w(k+1,j+1,i) + &
3484	( gg-dd ) * w(k+1,j+1,i+1) &
3485	) / ( 3.0_wp * gg )
3486	w_int(n) = w_int_l + ( zv(n) - zw(k) ) / dzw(k+1) * &
3487	( w_int_u - w_int_l )
3488	ENDIF
3489
3490	ELSE
3491
3492	w_int(n) = 0.0_wp
3493
3494	ENDIF
3495
3496	ENDDO
3497
3498	ENDDO
3499
3500	!-- Interpolate and calculate quantities needed for calculating the SGS
3501	!-- velocities
3502	IF ( use_sgs_for_particles .AND. .NOT. cloud_droplets ) THEN
3503
3504	DO nb = 0,7
3505
3506	subbox_at_wall = .FALSE.
3507	!
3508	!-- In case of topography check if subbox is adjacent to a wall
3509	IF ( .NOT. topography == 'flat' ) THEN
3510	i = ip + MERGE( -1_iwp , 1_iwp, BTEST( nb, 2 ) )
3511	j = jp + MERGE( -1_iwp , 1_iwp, BTEST( nb, 1 ) )
3512	k = kp + MERGE( -1_iwp , 1_iwp, BTEST( nb, 0 ) )
3513	IF ( .NOT. BTEST(wall_flags_0(k, jp, ip), 0) .OR. &
3514	.NOT. BTEST(wall_flags_0(kp, j, ip), 0) .OR. &
3515	.NOT. BTEST(wall_flags_0(kp, jp, i ), 0) ) &
3516	THEN
3517	subbox_at_wall = .TRUE.
3518	ENDIF
3519	ENDIF
3520	IF ( subbox_at_wall ) THEN
3521	e_int(start_index(nb):end_index(nb)) = e(kp,jp,ip)
3522	diss_int(start_index(nb):end_index(nb)) = diss(kp,jp,ip)
3523	de_dx_int(start_index(nb):end_index(nb)) = de_dx(kp,jp,ip)
3524	de_dy_int(start_index(nb):end_index(nb)) = de_dy(kp,jp,ip)
3525	de_dz_int(start_index(nb):end_index(nb)) = de_dz(kp,jp,ip)
3526	!
3527	!-- Set flag for stochastic equation.
3528	term_1_2(start_index(nb):end_index(nb)) = 0.0_wp
3529	ELSE
3530	i = ip + block_offset(nb)%i_off
3531	j = jp + block_offset(nb)%j_off
3532	k = kp + block_offset(nb)%k_off
3533
3534	DO n = start_index(nb), end_index(nb)
3535	!
3536	!-- Interpolate TKE
3537	x = xv(n) + ( 0.5_wp - i ) * dx
3538	y = yv(n) + ( 0.5_wp - j ) * dy
3539	aa = x2 + y2
3540	bb = ( dx - x )2 + y2
3541	cc = x2 + ( dy - y )2
3542	dd = ( dx - x )2 + ( dy - y )2
3543	gg = aa + bb + cc + dd
3544
3545	e_int_l = ( ( gg-aa ) * e(k,j,i) + ( gg-bb ) * e(k,j,i+1) &
3546	+ ( gg-cc ) * e(k,j+1,i) + ( gg-dd ) * e(k,j+1,i+1) &
3547	) / ( 3.0_wp * gg )
3548
3549	IF ( k+1 == nzt+1 ) THEN
3550	e_int(n) = e_int_l
3551	ELSE
3552	e_int_u = ( ( gg - aa ) * e(k+1,j,i) + &
3553	( gg - bb ) * e(k+1,j,i+1) + &
3554	( gg - cc ) * e(k+1,j+1,i) + &
3555	( gg - dd ) * e(k+1,j+1,i+1) &
3556	) / ( 3.0_wp * gg )
3557	e_int(n) = e_int_l + ( zv(n) - zu(k) ) / dzw(k+1) * &
3558	( e_int_u - e_int_l )
3559	ENDIF
3560	!
3561	!-- Needed to avoid NaN particle velocities (this might not be
3562	!-- required any more)
3563	IF ( e_int(n) <= 0.0_wp ) THEN
3564	e_int(n) = 1.0E-20_wp
3565	ENDIF
3566	!
3567	!-- Interpolate the TKE gradient along x (adopt incides i,j,k and
3568	!-- all position variables from above (TKE))
3569	de_dx_int_l = ( ( gg - aa ) * de_dx(k,j,i) + &
3570	( gg - bb ) * de_dx(k,j,i+1) + &
3571	( gg - cc ) * de_dx(k,j+1,i) + &
3572	( gg - dd ) * de_dx(k,j+1,i+1) &
3573	) / ( 3.0_wp * gg )
3574
3575	IF ( ( k+1 == nzt+1 ) .OR. ( k == nzb ) ) THEN
3576	de_dx_int(n) = de_dx_int_l
3577	ELSE
3578	de_dx_int_u = ( ( gg - aa ) * de_dx(k+1,j,i) + &
3579	( gg - bb ) * de_dx(k+1,j,i+1) + &
3580	( gg - cc ) * de_dx(k+1,j+1,i) + &
3581	( gg - dd ) * de_dx(k+1,j+1,i+1) &
3582	) / ( 3.0_wp * gg )
3583	de_dx_int(n) = de_dx_int_l + ( zv(n) - zu(k) ) / dzw(k+1) * &
3584	( de_dx_int_u - de_dx_int_l )
3585	ENDIF
3586	!
3587	!-- Interpolate the TKE gradient along y
3588	de_dy_int_l = ( ( gg - aa ) * de_dy(k,j,i) + &
3589	( gg - bb ) * de_dy(k,j,i+1) + &
3590	( gg - cc ) * de_dy(k,j+1,i) + &
3591	( gg - dd ) * de_dy(k,j+1,i+1) &
3592	) / ( 3.0_wp * gg )
3593	IF ( ( k+1 == nzt+1 ) .OR. ( k == nzb ) ) THEN
3594	de_dy_int(n) = de_dy_int_l
3595	ELSE
3596	de_dy_int_u = ( ( gg - aa ) * de_dy(k+1,j,i) + &
3597	( gg - bb ) * de_dy(k+1,j,i+1) + &
3598	( gg - cc ) * de_dy(k+1,j+1,i) + &
3599	( gg - dd ) * de_dy(k+1,j+1,i+1) &
3600	) / ( 3.0_wp * gg )
3601	de_dy_int(n) = de_dy_int_l + ( zv(n) - zu(k) ) / dzw(k+1) * &
3602	( de_dy_int_u - de_dy_int_l )
3603	ENDIF
3604
3605	!
3606	!-- Interpolate the TKE gradient along z
3607	IF ( zv(n) < 0.5_wp * dz(1) ) THEN
3608	de_dz_int(n) = 0.0_wp
3609	ELSE
3610	de_dz_int_l = ( ( gg - aa ) * de_dz(k,j,i) + &
3611	( gg - bb ) * de_dz(k,j,i+1) + &
3612	( gg - cc ) * de_dz(k,j+1,i) + &
3613	( gg - dd ) * de_dz(k,j+1,i+1) &
3614	) / ( 3.0_wp * gg )
3615
3616	IF ( ( k+1 == nzt+1 ) .OR. ( k == nzb ) ) THEN
3617	de_dz_int(n) = de_dz_int_l
3618	ELSE
3619	de_dz_int_u = ( ( gg - aa ) * de_dz(k+1,j,i) + &
3620	( gg - bb ) * de_dz(k+1,j,i+1) + &
3621	( gg - cc ) * de_dz(k+1,j+1,i) + &
3622	( gg - dd ) * de_dz(k+1,j+1,i+1) &
3623	) / ( 3.0_wp * gg )
3624	de_dz_int(n) = de_dz_int_l + ( zv(n) - zu(k) ) / dzw(k+1) * &
3625	( de_dz_int_u - de_dz_int_l )
3626	ENDIF
3627	ENDIF
3628
3629	!
3630	!-- Interpolate the dissipation of TKE
3631	diss_int_l = ( ( gg - aa ) * diss(k,j,i) + &
3632	( gg - bb ) * diss(k,j,i+1) + &
3633	( gg - cc ) * diss(k,j+1,i) + &
3634	( gg - dd ) * diss(k,j+1,i+1) &
3635	) / ( 3.0_wp * gg )
3636
3637	IF ( k == nzt ) THEN
3638	diss_int(n) = diss_int_l
3639	ELSE
3640	diss_int_u = ( ( gg - aa ) * diss(k+1,j,i) + &
3641	( gg - bb ) * diss(k+1,j,i+1) + &
3642	( gg - cc ) * diss(k+1,j+1,i) + &
3643	( gg - dd ) * diss(k+1,j+1,i+1) &
3644	) / ( 3.0_wp * gg )
3645	diss_int(n) = diss_int_l + ( zv(n) - zu(k) ) / dzw(k+1) * &
3646	( diss_int_u - diss_int_l )
3647	ENDIF
3648
3649	!
3650	!-- Set flag for stochastic equation.
3651	term_1_2(n) = 1.0_wp
3652	ENDDO
3653	ENDIF
3654	ENDDO
3655
3656	DO nb = 0,7
3657	i = ip + block_offset(nb)%i_off
3658	j = jp + block_offset(nb)%j_off
3659	k = kp + block_offset(nb)%k_off
3660
3661	DO n = start_index(nb), end_index(nb)
3662	!
3663	!-- Vertical interpolation of the horizontally averaged SGS TKE and
3664	!-- resolved-scale velocity variances and use the interpolated values
3665	!-- to calculate the coefficient fs, which is a measure of the ratio
3666	!-- of the subgrid-scale turbulent kinetic energy to the total amount
3667	!-- of turbulent kinetic energy.
3668	IF ( k == 0 ) THEN
3669	e_mean_int = hom(0,1,8,0)
3670	ELSE
3671	e_mean_int = hom(k,1,8,0) + &
3672	( hom(k+1,1,8,0) - hom(k,1,8,0) ) / &
3673	( zu(k+1) - zu(k) ) * &
3674	( zv(n) - zu(k) )
3675	ENDIF
3676
3677	kw = kp - 1
3678
3679	IF ( k == 0 ) THEN
3680	aa = hom(k+1,1,30,0) * ( zv(n) / &
3681	( 0.5_wp * ( zu(k+1) - zu(k) ) ) )
3682	bb = hom(k+1,1,31,0) * ( zv(n) / &
3683	( 0.5_wp * ( zu(k+1) - zu(k) ) ) )
3684	cc = hom(kw+1,1,32,0) * ( zv(n) / &
3685	( 1.0_wp * ( zw(kw+1) - zw(kw) ) ) )
3686	ELSE
3687	aa = hom(k,1,30,0) + ( hom(k+1,1,30,0) - hom(k,1,30,0) ) * &
3688	( ( zv(n) - zu(k) ) / ( zu(k+1) - zu(k) ) )
3689	bb = hom(k,1,31,0) + ( hom(k+1,1,31,0) - hom(k,1,31,0) ) * &
3690	( ( zv(n) - zu(k) ) / ( zu(k+1) - zu(k) ) )
3691	cc = hom(kw,1,32,0) + ( hom(kw+1,1,32,0)-hom(kw,1,32,0) ) * &
3692	( ( zv(n) - zw(kw) ) / ( zw(kw+1)-zw(kw) ) )
3693	ENDIF
3694
3695	vv_int = ( 1.0_wp / 3.0_wp ) * ( aa + bb + cc )
3696	!
3697	!-- Needed to avoid NaN particle velocities. The value of 1.0 is just
3698	!-- an educated guess for the given case.
3699	IF ( vv_int + ( 2.0_wp / 3.0_wp ) * e_mean_int == 0.0_wp ) THEN
3700	fs_int(n) = 1.0_wp
3701	ELSE
3702	fs_int(n) = ( 2.0_wp / 3.0_wp ) * e_mean_int / &
3703	( vv_int + ( 2.0_wp / 3.0_wp ) * e_mean_int )
3704	ENDIF
3705
3706	ENDDO
3707	ENDDO
3708
3709	DO nb = 0, 7
3710	DO n = start_index(nb), end_index(nb)
3711	rg(n,1) = random_gauss( iran_part, 5.0_wp )
3712	rg(n,2) = random_gauss( iran_part, 5.0_wp )
3713	rg(n,3) = random_gauss( iran_part, 5.0_wp )
3714	ENDDO
3715	ENDDO
3716
3717	DO nb = 0, 7
3718	DO n = start_index(nb), end_index(nb)
3719
3720	!
3721	!-- Calculate the Lagrangian timescale according to Weil et al. (2004).
3722	lagr_timescale(n) = ( 4.0_wp * e_int(n) + 1E-20_wp ) / &
3723	( 3.0_wp * fs_int(n) * c_0 * diss_int(n) + 1E-20_wp )
3724
3725	!
3726	!-- Calculate the next particle timestep. dt_gap is the time needed to
3727	!-- complete the current LES timestep.
3728	dt_gap(n) = dt_3d - particles(n)%dt_sum
3729	dt_particle(n) = MIN( dt_3d, 0.025_wp * lagr_timescale(n), dt_gap(n) )
3730	particles(n)%aux1 = lagr_timescale(n)
3731	particles(n)%aux2 = dt_gap(n)
3732	!
3733	!-- The particle timestep should not be too small in order to prevent
3734	!-- the number of particle timesteps of getting too large
3735	IF ( dt_particle(n) < dt_min_part .AND. dt_min_part < dt_gap(n) ) THEN
3736	dt_particle(n) = dt_min_part
3737	ENDIF
3738	rvar1_temp(n) = particles(n)%rvar1
3739	rvar2_temp(n) = particles(n)%rvar2
3740	rvar3_temp(n) = particles(n)%rvar3
3741	!
3742	!-- Calculate the SGS velocity components
3743	IF ( particles(n)%age == 0.0_wp ) THEN
3744	!
3745	!-- For new particles the SGS components are derived from the SGS
3746	!-- TKE. Limit the Gaussian random number to the interval
3747	!-- [-5.0sigma, 5.0sigma] in order to prevent the SGS velocities
3748	!-- from becoming unrealistically large.
3749	rvar1_temp(n) = SQRT( 2.0_wp * sgs_wf_part * e_int(n) &
3750	+ 1E-20_wp ) * ( rg(n,1) - 1.0_wp )
3751	rvar2_temp(n) = SQRT( 2.0_wp * sgs_wf_part * e_int(n) &
3752	+ 1E-20_wp ) * ( rg(n,2) - 1.0_wp )
3753	rvar3_temp(n) = SQRT( 2.0_wp * sgs_wf_part * e_int(n) &
3754	+ 1E-20_wp ) * ( rg(n,3) - 1.0_wp )
3755
3756	ELSE
3757	!
3758	!-- Restriction of the size of the new timestep: compared to the
3759	!-- previous timestep the increase must not exceed 200%. First,
3760	!-- check if age > age_m, in order to prevent that particles get zero
3761	!-- timestep.
3762	dt_particle_m = MERGE( dt_particle(n), &
3763	particles(n)%age - particles(n)%age_m, &
3764	particles(n)%age - particles(n)%age_m < &
3765	1E-8_wp )
3766	IF ( dt_particle(n) > 2.0_wp * dt_particle_m ) THEN
3767	dt_particle(n) = 2.0_wp * dt_particle_m
3768	ENDIF
3769
3770	!-- For old particles the SGS components are correlated with the
3771	!-- values from the previous timestep. Random numbers have also to
3772	!-- be limited (see above).
3773	!-- As negative values for the subgrid TKE are not allowed, the
3774	!-- change of the subgrid TKE with time cannot be smaller than
3775	!-- -e_int(n)/dt_particle. This value is used as a lower boundary
3776	!-- value for the change of TKE
3777	de_dt_min = - e_int(n) / dt_particle(n)
3778
3779	de_dt = ( e_int(n) - particles(n)%e_m ) / dt_particle_m
3780
3781	IF ( de_dt < de_dt_min ) THEN
3782	de_dt = de_dt_min
3783	ENDIF
3784
3785	CALL weil_stochastic_eq(rvar1_temp(n), fs_int(n), e_int(n),&
3786	de_dx_int(n), de_dt, diss_int(n), &
3787	dt_particle(n), rg(n,1), term_1_2(n) )
3788
3789	CALL weil_stochastic_eq(rvar2_temp(n), fs_int(n), e_int(n),&
3790	de_dy_int(n), de_dt, diss_int(n), &
3791	dt_particle(n), rg(n,2), term_1_2(n) )
3792
3793	CALL weil_stochastic_eq(rvar3_temp(n), fs_int(n), e_int(n),&
3794	de_dz_int(n), de_dt, diss_int(n), &
3795	dt_particle(n), rg(n,3), term_1_2(n) )
3796
3797	ENDIF
3798
3799	ENDDO
3800	ENDDO
3801	!
3802	!-- Check if the added SGS velocities result in a violation of the CFL-
3803	!-- criterion. If yes choose a smaller timestep based on the new velocities
3804	!-- and calculate SGS velocities again
3805	dz_temp = zw(kp)-zw(kp-1)
3806
3807	DO nb = 0, 7
3808	DO n = start_index(nb), end_index(nb)
3809	IF ( .NOT. particles(n)%age == 0.0_wp .AND. &
3810	(ABS( u_int(n) + rvar1_temp(n) ) > (dx/dt_particle(n)) .OR. &
3811	ABS( v_int(n) + rvar2_temp(n) ) > (dy/dt_particle(n)) .OR. &
3812	ABS( w_int(n) + rvar3_temp(n) ) > (dz_temp/dt_particle(n)))) THEN
3813
3814	dt_particle(n) = 0.9_wp * MIN( &
3815	( dx / ABS( u_int(n) + rvar1_temp(n) ) ), &
3816	( dy / ABS( v_int(n) + rvar2_temp(n) ) ), &
3817	( dz_temp / ABS( w_int(n) + rvar3_temp(n) ) ) )
3818
3819	!
3820	!-- Reset temporary SGS velocites to "current" ones
3821	rvar1_temp(n) = particles(n)%rvar1
3822	rvar2_temp(n) = particles(n)%rvar2
3823	rvar3_temp(n) = particles(n)%rvar3
3824
3825	de_dt_min = - e_int(n) / dt_particle(n)
3826
3827	de_dt = ( e_int(n) - particles(n)%e_m ) / dt_particle_m
3828
3829	IF ( de_dt < de_dt_min ) THEN
3830	de_dt = de_dt_min
3831	ENDIF
3832
3833	CALL weil_stochastic_eq(rvar1_temp(n), fs_int(n), e_int(n),&
3834	de_dx_int(n), de_dt, diss_int(n), &
3835	dt_particle(n), rg(n,1), term_1_2(n) )
3836
3837	CALL weil_stochastic_eq(rvar2_temp(n), fs_int(n), e_int(n),&
3838	de_dy_int(n), de_dt, diss_int(n), &
3839	dt_particle(n), rg(n,2), term_1_2(n) )
3840
3841	CALL weil_stochastic_eq(rvar3_temp(n), fs_int(n), e_int(n),&
3842	de_dz_int(n), de_dt, diss_int(n), &
3843	dt_particle(n), rg(n,3), term_1_2(n) )
3844	ENDIF
3845
3846	!
3847	!-- Update particle velocites
3848	particles(n)%rvar1 = rvar1_temp(n)
3849	particles(n)%rvar2 = rvar2_temp(n)
3850	particles(n)%rvar3 = rvar3_temp(n)
3851	u_int(n) = u_int(n) + particles(n)%rvar1
3852	v_int(n) = v_int(n) + particles(n)%rvar2
3853	w_int(n) = w_int(n) + particles(n)%rvar3
3854	!
3855	!-- Store the SGS TKE of the current timelevel which is needed for
3856	!-- for calculating the SGS particle velocities at the next timestep
3857	particles(n)%e_m = e_int(n)
3858	ENDDO
3859	ENDDO
3860
3861	ELSE
3862	!
3863	!-- If no SGS velocities are used, only the particle timestep has to
3864	!-- be set
3865	dt_particle = dt_3d
3866
3867	ENDIF
3868
3869	dens_ratio = particle_groups(particles(1:number_of_particles)%group)%density_ratio
3870
3871	IF ( ANY( dens_ratio == 0.0_wp ) ) THEN
3872	DO nb = 0, 7
3873	DO n = start_index(nb), end_index(nb)
3874
3875	!
3876	!-- Particle advection
3877	IF ( dens_ratio(n) == 0.0_wp ) THEN
3878	!
3879	!-- Pure passive transport (without particle inertia)
3880	particles(n)%x = xv(n) + u_int(n) * dt_particle(n)
3881	particles(n)%y = yv(n) + v_int(n) * dt_particle(n)
3882	particles(n)%z = zv(n) + w_int(n) * dt_particle(n)
3883
3884	particles(n)%speed_x = u_int(n)
3885	particles(n)%speed_y = v_int(n)
3886	particles(n)%speed_z = w_int(n)
3887
3888	ELSE
3889	!
3890	!-- Transport of particles with inertia
3891	particles(n)%x = particles(n)%x + particles(n)%speed_x * &
3892	dt_particle(n)
3893	particles(n)%y = particles(n)%y + particles(n)%speed_y * &
3894	dt_particle(n)
3895	particles(n)%z = particles(n)%z + particles(n)%speed_z * &
3896	dt_particle(n)
3897
3898	!
3899	!-- Update of the particle velocity
3900	IF ( cloud_droplets ) THEN
3901	!
3902	!-- Terminal velocity is computed for vertical direction (Rogers et
3903	!-- al., 1993, J. Appl. Meteorol.)
3904	diameter = particles(n)%radius * 2000.0_wp !diameter in mm
3905	IF ( diameter <= d0_rog ) THEN
3906	w_s = k_cap_rog * diameter * ( 1.0_wp - EXP( -k_low_rog * diameter ) )
3907	ELSE
3908	w_s = a_rog - b_rog * EXP( -c_rog * diameter )
3909	ENDIF
3910
3911	!
3912	!-- If selected, add random velocities following Soelch and Kaercher
3913	!-- (2010, Q. J. R. Meteorol. Soc.)
3914	IF ( use_sgs_for_particles ) THEN
3915	lagr_timescale(n) = km(kp,jp,ip) / MAX( e(kp,jp,ip), 1.0E-20_wp )
3916	RL = EXP( -1.0_wp * dt_3d / MAX( lagr_timescale(n), &
3917	1.0E-20_wp ) )
3918	sigma = SQRT( e(kp,jp,ip) )
3919
3920	rg1 = random_gauss( iran_part, 5.0_wp ) - 1.0_wp
3921	rg2 = random_gauss( iran_part, 5.0_wp ) - 1.0_wp
3922	rg3 = random_gauss( iran_part, 5.0_wp ) - 1.0_wp
3923
3924	particles(n)%rvar1 = RL * particles(n)%rvar1 + &
3925	SQRT( 1.0_wp - RL*2 ) sigma * rg1
3926	particles(n)%rvar2 = RL * particles(n)%rvar2 + &
3927	SQRT( 1.0_wp - RL*2 ) sigma * rg2
3928	particles(n)%rvar3 = RL * particles(n)%rvar3 + &
3929	SQRT( 1.0_wp - RL*2 ) sigma * rg3
3930
3931	particles(n)%speed_x = u_int(n) + particles(n)%rvar1
3932	particles(n)%speed_y = v_int(n) + particles(n)%rvar2
3933	particles(n)%speed_z = w_int(n) + particles(n)%rvar3 - w_s
3934	ELSE
3935	particles(n)%speed_x = u_int(n)
3936	particles(n)%speed_y = v_int(n)
3937	particles(n)%speed_z = w_int(n) - w_s
3938	ENDIF
3939
3940	ELSE
3941
3942	IF ( use_sgs_for_particles ) THEN
3943	exp_arg = particle_groups(particles(n)%group)%exp_arg
3944	exp_term = EXP( -exp_arg * dt_particle(n) )
3945	ELSE
3946	exp_arg = particle_groups(particles(n)%group)%exp_arg
3947	exp_term = particle_groups(particles(n)%group)%exp_term
3948	ENDIF
3949	particles(n)%speed_x = particles(n)%speed_x * exp_term + &
3950	u_int(n) * ( 1.0_wp - exp_term )
3951	particles(n)%speed_y = particles(n)%speed_y * exp_term + &
3952	v_int(n) * ( 1.0_wp - exp_term )
3953	particles(n)%speed_z = particles(n)%speed_z * exp_term + &
3954	( w_int(n) - ( 1.0_wp - dens_ratio(n) ) * &
3955	g / exp_arg ) * ( 1.0_wp - exp_term )
3956	ENDIF
3957
3958	ENDIF
3959	ENDDO
3960	ENDDO
3961
3962	ELSE
3963
3964	DO nb = 0, 7
3965	DO n = start_index(nb), end_index(nb)
3966	!
3967	!-- Transport of particles with inertia
3968	particles(n)%x = xv(n) + particles(n)%speed_x * dt_particle(n)
3969	particles(n)%y = yv(n) + particles(n)%speed_y * dt_particle(n)
3970	particles(n)%z = zv(n) + particles(n)%speed_z * dt_particle(n)
3971	!
3972	!-- Update of the particle velocity
3973	IF ( cloud_droplets ) THEN
3974	!
3975	!-- Terminal velocity is computed for vertical direction (Rogers et al.,
3976	!-- 1993, J. Appl. Meteorol.)
3977	diameter = particles(n)%radius * 2000.0_wp !diameter in mm
3978	IF ( diameter <= d0_rog ) THEN
3979	w_s = k_cap_rog * diameter * ( 1.0_wp - EXP( -k_low_rog * diameter ) )
3980	ELSE
3981	w_s = a_rog - b_rog * EXP( -c_rog * diameter )
3982	ENDIF
3983
3984	!
3985	!-- If selected, add random velocities following Soelch and Kaercher
3986	!-- (2010, Q. J. R. Meteorol. Soc.)
3987	IF ( use_sgs_for_particles ) THEN
3988	lagr_timescale(n) = km(kp,jp,ip) / MAX( e(kp,jp,ip), 1.0E-20_wp )
3989	RL = EXP( -1.0_wp * dt_3d / MAX( lagr_timescale(n), &
3990	1.0E-20_wp ) )
3991	sigma = SQRT( e(kp,jp,ip) )
3992
3993	rg1 = random_gauss( iran_part, 5.0_wp ) - 1.0_wp
3994	rg2 = random_gauss( iran_part, 5.0_wp ) - 1.0_wp
3995	rg3 = random_gauss( iran_part, 5.0_wp ) - 1.0_wp
3996
3997	particles(n)%rvar1 = RL * particles(n)%rvar1 + &
3998	SQRT( 1.0_wp - RL*2 ) sigma * rg1
3999	particles(n)%rvar2 = RL * particles(n)%rvar2 + &
4000	SQRT( 1.0_wp - RL*2 ) sigma * rg2
4001	particles(n)%rvar3 = RL * particles(n)%rvar3 + &
4002	SQRT( 1.0_wp - RL*2 ) sigma * rg3
4003
4004	particles(n)%speed_x = u_int(n) + particles(n)%rvar1
4005	particles(n)%speed_y = v_int(n) + particles(n)%rvar2
4006	particles(n)%speed_z = w_int(n) + particles(n)%rvar3 - w_s
4007	ELSE
4008	particles(n)%speed_x = u_int(n)
4009	particles(n)%speed_y = v_int(n)
4010	particles(n)%speed_z = w_int(n) - w_s
4011	ENDIF
4012
4013	ELSE
4014
4015	IF ( use_sgs_for_particles ) THEN
4016	exp_arg = particle_groups(particles(n)%group)%exp_arg
4017	exp_term = EXP( -exp_arg * dt_particle(n) )
4018	ELSE
4019	exp_arg = particle_groups(particles(n)%group)%exp_arg
4020	exp_term = particle_groups(particles(n)%group)%exp_term
4021	ENDIF
4022	particles(n)%speed_x = particles(n)%speed_x * exp_term + &
4023	u_int(n) * ( 1.0_wp - exp_term )
4024	particles(n)%speed_y = particles(n)%speed_y * exp_term + &
4025	v_int(n) * ( 1.0_wp - exp_term )
4026	particles(n)%speed_z = particles(n)%speed_z * exp_term + &
4027	( w_int(n) - ( 1.0_wp - dens_ratio(n) ) * g / &
4028	exp_arg ) * ( 1.0_wp - exp_term )
4029	ENDIF
4030	ENDDO
4031	ENDDO
4032
4033	ENDIF
4034
4035	!
4036	!-- Store the old age of the particle ( needed to prevent that a
4037	!-- particle crosses several PEs during one timestep, and for the
4038	!-- evaluation of the subgrid particle velocity fluctuations )
4039	particles(1:number_of_particles)%age_m = particles(1:number_of_particles)%age
4040
4041	DO nb = 0, 7
4042	DO n = start_index(nb), end_index(nb)
4043	!
4044	!-- Increment the particle age and the total time that the particle
4045	!-- has advanced within the particle timestep procedure
4046	particles(n)%age = particles(n)%age + dt_particle(n)
4047	particles(n)%dt_sum = particles(n)%dt_sum + dt_particle(n)
4048
4049	!
4050	!-- Check whether there is still a particle that has not yet completed
4051	!-- the total LES timestep
4052	IF ( ( dt_3d - particles(n)%dt_sum ) > 1E-8_wp ) THEN
4053	dt_3d_reached_l = .FALSE.
4054	ENDIF
4055
4056	ENDDO
4057	ENDDO
4058
4059	CALL cpu_log( log_point_s(44), 'lpm_advec', 'pause' )
4060
4061
4062	END SUBROUTINE lpm_advec
4063
4064
4065	!------------------------------------------------------------------------------!
4066	! Description:
4067	! ------------
4068	!> Calculation of subgrid-scale particle speed using the stochastic model
4069	!> of Weil et al. (2004, JAS, 61, 2877-2887).
4070	!------------------------------------------------------------------------------!
4071	SUBROUTINE weil_stochastic_eq( v_sgs, fs_n, e_n, dedxi_n, dedt_n, diss_n, &
4072	dt_n, rg_n, fac )
4073
4074	REAL(wp) :: a1 !< dummy argument
4075	REAL(wp) :: dedt_n !< time derivative of TKE at particle position
4076	REAL(wp) :: dedxi_n !< horizontal derivative of TKE at particle position
4077	REAL(wp) :: diss_n !< dissipation at particle position
4078	REAL(wp) :: dt_n !< particle timestep
4079	REAL(wp) :: e_n !< TKE at particle position
4080	REAL(wp) :: fac !< flag to identify adjacent topography
4081	REAL(wp) :: fs_n !< weighting factor to prevent that subgrid-scale particle speed becomes too large
4082	REAL(wp) :: rg_n !< random number
4083	REAL(wp) :: term1 !< memory term
4084	REAL(wp) :: term2 !< drift correction term
4085	REAL(wp) :: term3 !< random term
4086	REAL(wp) :: v_sgs !< subgrid-scale velocity component
4087
4088	!-- At first, limit TKE to a small non-zero number, in order to prevent
4089	!-- the occurrence of extremely large SGS-velocities in case TKE is zero,
4090	!-- (could occur at the simulation begin).
4091	e_n = MAX( e_n, 1E-20_wp )
4092	!
4093	!-- Please note, terms 1 and 2 (drift and memory term, respectively) are
4094	!-- multiplied by a flag to switch of both