Home

Context Navigation

lagrangian_particle_model_mod.f90 @ 4471

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