Home

Context Navigation

source: palm/trunk/SOURCE/lagrangian_particle_model_mod.f90 @ 4399

Last change on this file since 4399 was 4360, checked in by suehring, 5 years ago
Bugfix in output of time-averaged plant-canopy quanities; Output of plant-canopy data only where tall canopy is defined; land-surface model: fix wrong location strings; tests: update urban test case; all source code files: copyright update
Property svn:keywords set to `Id`
File size: 353.9 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 4360 2020-01-07 11:25:50Z monakurppa $
27	! Introduction of wall_flags_total_0, which currently sets bits based on static
28	! topography information used in wall_flags_static_0
29	!
30	! 4336 2019-12-13 10:12:05Z raasch
31	! bugfix: wrong header output of particle group features (density ratio) in case
32	! of restarts corrected
33	!
34	! 4329 2019-12-10 15:46:36Z motisi
35	! Renamed wall_flags_0 to wall_flags_static_0
36	!
37	! 4282 2019-10-29 16:18:46Z schwenkel
38	! Bugfix of particle timeseries in case of more than one particle group
39	!
40	! 4277 2019-10-28 16:53:23Z schwenkel
41	! Bugfix: Added first_call_lpm in use statement
42	!
43	! 4276 2019-10-28 16:03:29Z schwenkel
44	! Modularize lpm: Move conditions in time intergration to module
45	!
46	! 4275 2019-10-28 15:34:55Z schwenkel
47	! Change call of simple predictor corrector method, i.e. two divergence free
48	! velocitiy fields are now used.
49	!
50	! 4232 2019-09-20 09:34:22Z knoop
51	! Removed INCLUDE "mpif.h", as it is not needed because of USE pegrid
52	!
53	! 4195 2019-08-28 13:44:27Z schwenkel
54	! Bugfix for simple_corrector interpolation method in case of ocean runs and
55	! output particle advection interpolation method into header
56	!
57	! 4182 2019-08-22 15:20:23Z scharf
58	! Corrected "Former revisions" section
59	!
60	! 4168 2019-08-16 13:50:17Z suehring
61	! Replace function get_topography_top_index by topo_top_ind
62	!
63	! 4145 2019-08-06 09:55:22Z schwenkel
64	! Some reformatting
65	!
66	! 4144 2019-08-06 09:11:47Z raasch
67	! relational operators .EQ., .NE., etc. replaced by ==, /=, etc.
68	!
69	! 4143 2019-08-05 15:14:53Z schwenkel
70	! Rename variable and change select case to if statement
71	!
72	! 4122 2019-07-26 13:11:56Z schwenkel
73	! Implement reset method as bottom boundary condition
74	!
75	! 4121 2019-07-26 10:01:22Z schwenkel
76	! Implementation of an simple method for interpolating the velocities to
77	! particle position
78	!
79	! 4114 2019-07-23 14:09:27Z schwenkel
80	! Bugfix: Added working precision for if statement
81	!
82	! 4054 2019-06-27 07:42:18Z raasch
83	! bugfix for calculating the minimum particle time step
84	!
85	! 4044 2019-06-19 12:28:27Z schwenkel
86	! Bugfix in case of grid strecting: corrected calculation of k-Index
87	!
88	! 4043 2019-06-18 16:59:00Z schwenkel
89	! Remove min_nr_particle, Add lpm_droplet_interactions_ptq into module
90	!
91	! 4028 2019-06-13 12:21:37Z schwenkel
92	! Further modularization of particle code components
93	!
94	! 4020 2019-06-06 14:57:48Z schwenkel
95	! Removing submodules
96	!
97	! 4018 2019-06-06 13:41:50Z eckhard
98	! Bugfix for former revision
99	!
100	! 4017 2019-06-06 12:16:46Z schwenkel
101	! Modularization of all lagrangian particle model code components
102	!
103	! 3655 2019-01-07 16:51:22Z knoop
104	! bugfix to guarantee correct particle releases in case that the release
105	! interval is smaller than the model timestep
106	!
107	! Revision 1.1 1999/11/25 16:16:06 raasch
108	! Initial revision
109	!
110	!
111	! Description:
112	! ------------
113	!> The embedded LPM allows for studying transport and dispersion processes within
114	!> turbulent flows. This model including passive particles that do not show any
115	!> feedback on the turbulent flow. Further also particles with inertia and
116	!> cloud droplets ca be simulated explicitly.
117	!>
118	!> @todo test lcm
119	!> implement simple interpolation method for subgrid scale velocites
120	!> @note <Enter notes on the module>
121	!> @bug <Enter bug on the module>
122	!------------------------------------------------------------------------------!
123	MODULE lagrangian_particle_model_mod
124
125	USE, INTRINSIC :: ISO_C_BINDING
126
127	USE arrays_3d, &
128	ONLY: de_dx, de_dy, de_dz, dzw, zu, zw, ql_c, ql_v, ql_vp, hyp, &
129	pt, q, exner, ql, diss, e, u, v, w, km, ql_1, ql_2, pt_p, q_p, &
130	d_exner
131
132	USE averaging, &
133	ONLY: ql_c_av, pr_av, pc_av, ql_vp_av, ql_v_av
134
135	USE basic_constants_and_equations_mod, &
136	ONLY: molecular_weight_of_solute, molecular_weight_of_water, magnus, &
137	pi, rd_d_rv, rho_l, r_v, rho_s, vanthoff, l_v, kappa, g, lv_d_cp
138
139	USE control_parameters, &
140	ONLY: bc_dirichlet_l, bc_dirichlet_n, bc_dirichlet_r, bc_dirichlet_s, &
141	cloud_droplets, constant_flux_layer, current_timestep_number, &
142	dt_3d, dt_3d_reached, first_call_lpm, humidity, &
143	dt_3d_reached_l, dt_dopts, dz, initializing_actions, &
144	intermediate_timestep_count, intermediate_timestep_count_max, &
145	message_string, molecular_viscosity, ocean_mode, &
146	particle_maximum_age, iran, &
147	simulated_time, topography, dopts_time_count, &
148	time_since_reference_point, rho_surface, u_gtrans, v_gtrans, &
149	dz_stretch_level, dz_stretch_level_start
150
151	USE cpulog, &
152	ONLY: cpu_log, log_point, log_point_s
153
154	USE indices, &
155	ONLY: nx, nxl, nxlg, nxrg, nxr, ny, nyn, nys, nyng, nysg, nz, nzb, &
156	nzb_max, nzt,nbgp, ngp_2dh_outer, &
157	topo_top_ind, &
158	wall_flags_total_0
159
160	USE kinds
161
162	USE pegrid
163
164	USE particle_attributes
165
166	USE pmc_particle_interface, &
167	ONLY: pmcp_c_get_particle_from_parent, pmcp_p_fill_particle_win, &
168	pmcp_c_send_particle_to_parent, pmcp_p_empty_particle_win, &
169	pmcp_p_delete_particles_in_fine_grid_area, pmcp_g_init, &
170	pmcp_g_print_number_of_particles
171
172	USE pmc_interface, &
173	ONLY: nested_run
174
175	USE grid_variables, &
176	ONLY: ddx, dx, ddy, dy
177
178	USE netcdf_interface, &
179	ONLY: netcdf_data_format, netcdf_deflate, dopts_num, id_set_pts, &
180	id_var_dopts, id_var_time_pts, nc_stat, &
181	netcdf_handle_error
182
183	USE random_function_mod, &
184	ONLY: random_function
185
186	USE statistics, &
187	ONLY: hom
188
189	USE surface_mod, &
190	ONLY: bc_h, &
191	surf_def_h, &
192	surf_lsm_h, &
193	surf_usm_h
194
195	#if defined( __parallel ) && !defined( __mpifh )
196	USE MPI
197	#endif
198
199	#if defined( __netcdf )
200	USE NETCDF
201	#endif
202
203	IMPLICIT NONE
204
205	CHARACTER(LEN=15) :: aero_species = 'nacl' !< aerosol species
206	CHARACTER(LEN=15) :: aero_type = 'maritime' !< aerosol type
207	CHARACTER(LEN=15) :: bc_par_lr = 'cyclic' !< left/right boundary condition
208	CHARACTER(LEN=15) :: bc_par_ns = 'cyclic' !< north/south boundary condition
209	CHARACTER(LEN=15) :: bc_par_b = 'reflect' !< bottom boundary condition
210	CHARACTER(LEN=15) :: bc_par_t = 'absorb' !< top boundary condition
211	CHARACTER(LEN=15) :: collision_kernel = 'none' !< collision kernel
212
213	CHARACTER(LEN=5) :: splitting_function = 'gamma' !< function for calculation critical weighting factor
214	CHARACTER(LEN=5) :: splitting_mode = 'const' !< splitting mode
215
216	CHARACTER(LEN=25) :: particle_advection_interpolation = 'trilinear' !< interpolation method for calculatin the particle
217
218	INTEGER(iwp) :: deleted_particles = 0 !< number of deleted particles per time step
219	INTEGER(iwp) :: i_splitting_mode !< dummy for splitting mode
220	INTEGER(iwp) :: iran_part = -1234567 !< number for random generator
221	INTEGER(iwp) :: max_number_particles_per_gridbox = 100 !< namelist parameter (see documentation)
222	INTEGER(iwp) :: isf !< dummy for splitting function
223	INTEGER(iwp) :: number_particles_per_gridbox = -1 !< namelist parameter (see documentation)
224	INTEGER(iwp) :: number_of_sublayers = 20 !< number of sublayers for particle velocities betwenn surface and first grid level
225	INTEGER(iwp) :: offset_ocean_nzt = 0 !< in case of oceans runs, the vertical index calculations need an offset
226	INTEGER(iwp) :: offset_ocean_nzt_m1 = 0 !< in case of oceans runs, the vertical index calculations need an offset
227	INTEGER(iwp) :: particles_per_point = 1 !< namelist parameter (see documentation)
228	INTEGER(iwp) :: radius_classes = 20 !< namelist parameter (see documentation)
229	INTEGER(iwp) :: splitting_factor = 2 !< namelist parameter (see documentation)
230	INTEGER(iwp) :: splitting_factor_max = 5 !< namelist parameter (see documentation)
231	INTEGER(iwp) :: step_dealloc = 100 !< namelist parameter (see documentation)
232	INTEGER(iwp) :: total_number_of_particles !< total number of particles in the whole model domain
233	INTEGER(iwp) :: trlp_count_sum !< parameter for particle exchange of PEs
234	INTEGER(iwp) :: trlp_count_recv_sum !< parameter for particle exchange of PEs
235	INTEGER(iwp) :: trrp_count_sum !< parameter for particle exchange of PEs
236	INTEGER(iwp) :: trrp_count_recv_sum !< parameter for particle exchange of PEs
237	INTEGER(iwp) :: trsp_count_sum !< parameter for particle exchange of PEs
238	INTEGER(iwp) :: trsp_count_recv_sum !< parameter for particle exchange of PEs
239	INTEGER(iwp) :: trnp_count_sum !< parameter for particle exchange of PEs
240	INTEGER(iwp) :: trnp_count_recv_sum !< parameter for particle exchange of PEs
241
242	LOGICAL :: lagrangian_particle_model = .FALSE. !< namelist parameter (see documentation)
243	LOGICAL :: curvature_solution_effects = .FALSE. !< namelist parameter (see documentation)
244	LOGICAL :: deallocate_memory = .TRUE. !< namelist parameter (see documentation)
245	LOGICAL :: hall_kernel = .FALSE. !< flag for collision kernel
246	LOGICAL :: merging = .FALSE. !< namelist parameter (see documentation)
247	LOGICAL :: random_start_position = .FALSE. !< namelist parameter (see documentation)
248	LOGICAL :: read_particles_from_restartfile = .TRUE. !< namelist parameter (see documentation)
249	LOGICAL :: seed_follows_topography = .FALSE. !< namelist parameter (see documentation)
250	LOGICAL :: splitting = .FALSE. !< namelist parameter (see documentation)
251	LOGICAL :: use_kernel_tables = .FALSE. !< parameter, which turns on the use of precalculated collision kernels
252	LOGICAL :: write_particle_statistics = .FALSE. !< namelist parameter (see documentation)
253	LOGICAL :: interpolation_simple_predictor = .FALSE. !< flag for simple particle advection interpolation with predictor step
254	LOGICAL :: interpolation_simple_corrector = .FALSE. !< flag for simple particle advection interpolation with corrector step
255	LOGICAL :: interpolation_trilinear = .FALSE. !< flag for trilinear particle advection interpolation
256
257	LOGICAL, DIMENSION(max_number_of_particle_groups) :: vertical_particle_advection = .TRUE. !< Switch for vertical particle transport
258
259	REAL(wp) :: aero_weight = 1.0_wp !< namelist parameter (see documentation)
260	REAL(wp) :: dt_min_part = 0.0002_wp !< minimum particle time step when SGS velocities are used (s)
261	REAL(wp) :: dt_prel = 9999999.9_wp !< namelist parameter (see documentation)
262	REAL(wp) :: dt_write_particle_data = 9999999.9_wp !< namelist parameter (see documentation)
263	REAL(wp) :: end_time_prel = 9999999.9_wp !< namelist parameter (see documentation)
264	REAL(wp) :: initial_weighting_factor = 1.0_wp !< namelist parameter (see documentation)
265	REAL(wp) :: last_particle_release_time = 0.0_wp !< last time of particle release
266	REAL(wp) :: log_sigma(3) = 1.0_wp !< namelist parameter (see documentation)
267	REAL(wp) :: na(3) = 0.0_wp !< namelist parameter (see documentation)
268	REAL(wp) :: number_concentration = -1.0_wp !< namelist parameter (see documentation)
269	REAL(wp) :: radius_merge = 1.0E-7_wp !< namelist parameter (see documentation)
270	REAL(wp) :: radius_split = 40.0E-6_wp !< namelist parameter (see documentation)
271	REAL(wp) :: rm(3) = 1.0E-6_wp !< namelist parameter (see documentation)
272	REAL(wp) :: sgs_wf_part !< parameter for sgs
273	REAL(wp) :: time_write_particle_data = 0.0_wp !< write particle data at current time on file
274	REAL(wp) :: weight_factor_merge = -1.0_wp !< namelist parameter (see documentation)
275	REAL(wp) :: weight_factor_split = -1.0_wp !< namelist parameter (see documentation)
276	REAL(wp) :: z0_av_global !< horizontal mean value of z0
277
278	REAL(wp) :: rclass_lbound !<
279	REAL(wp) :: rclass_ubound !<
280
281	REAL(wp), PARAMETER :: c_0 = 3.0_wp !< parameter for lagrangian timescale
282
283	REAL(wp), DIMENSION(max_number_of_particle_groups) :: density_ratio = 9999999.9_wp !< namelist parameter (see documentation)
284	REAL(wp), DIMENSION(max_number_of_particle_groups) :: pdx = 9999999.9_wp !< namelist parameter (see documentation)
285	REAL(wp), DIMENSION(max_number_of_particle_groups) :: pdy = 9999999.9_wp !< namelist parameter (see documentation)
286	REAL(wp), DIMENSION(max_number_of_particle_groups) :: pdz = 9999999.9_wp !< namelist parameter (see documentation)
287	REAL(wp), DIMENSION(max_number_of_particle_groups) :: psb = 9999999.9_wp !< namelist parameter (see documentation)
288	REAL(wp), DIMENSION(max_number_of_particle_groups) :: psl = 9999999.9_wp !< namelist parameter (see documentation)
289	REAL(wp), DIMENSION(max_number_of_particle_groups) :: psn = 9999999.9_wp !< namelist parameter (see documentation)
290	REAL(wp), DIMENSION(max_number_of_particle_groups) :: psr = 9999999.9_wp !< namelist parameter (see documentation)
291	REAL(wp), DIMENSION(max_number_of_particle_groups) :: pss = 9999999.9_wp !< namelist parameter (see documentation)
292	REAL(wp), DIMENSION(max_number_of_particle_groups) :: pst = 9999999.9_wp !< namelist parameter (see documentation).
293	REAL(wp), DIMENSION(max_number_of_particle_groups) :: radius = 9999999.9_wp !< namelist parameter (see documentation)
294
295	REAL(wp), DIMENSION(:), ALLOCATABLE :: log_z_z0 !< Precalculate LOG(z/z0)
296
297	INTEGER(iwp), PARAMETER :: NR_2_direction_move = 10000 !<
298	INTEGER(iwp) :: nr_move_north !<
299	INTEGER(iwp) :: nr_move_south !<
300
301	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: move_also_north
302	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: move_also_south
303
304	REAL(wp) :: epsilon_collision !<
305	REAL(wp) :: urms !<
306
307	REAL(wp), DIMENSION(:), ALLOCATABLE :: epsclass !< dissipation rate class
308	REAL(wp), DIMENSION(:), ALLOCATABLE :: radclass !< radius class
309	REAL(wp), DIMENSION(:), ALLOCATABLE :: winf !<
310
311	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ec !<
312	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ecf !<
313	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: gck !<
314	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: hkernel !<
315	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: hwratio !<
316
317	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ckernel !<
318	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: u_t !< u value of old timelevel t
319	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: v_t !< v value of old timelevel t
320	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: w_t !< w value of old timelevel t
321
322
323	INTEGER(iwp), PARAMETER :: PHASE_INIT = 1 !<
324	INTEGER(iwp), PARAMETER, PUBLIC :: PHASE_RELEASE = 2 !<
325
326	SAVE
327
328	PRIVATE
329
330	PUBLIC lpm_parin, &
331	lpm_header, &
332	lpm_init_arrays,&
333	lpm_init, &
334	lpm_actions, &
335	lpm_data_output_ptseries, &
336	lpm_interaction_droplets_ptq, &
337	lpm_rrd_local_particles, &
338	lpm_wrd_local, &
339	lpm_rrd_global, &
340	lpm_wrd_global, &
341	lpm_rrd_local, &
342	lpm_check_parameters
343
344	PUBLIC lagrangian_particle_model
345
346	INTERFACE lpm_check_parameters
347	MODULE PROCEDURE lpm_check_parameters
348	END INTERFACE lpm_check_parameters
349
350	INTERFACE lpm_parin
351	MODULE PROCEDURE lpm_parin
352	END INTERFACE lpm_parin
353
354	INTERFACE lpm_header
355	MODULE PROCEDURE lpm_header
356	END INTERFACE lpm_header
357
358	INTERFACE lpm_init_arrays
359	MODULE PROCEDURE lpm_init_arrays
360	END INTERFACE lpm_init_arrays
361
362	INTERFACE lpm_init
363	MODULE PROCEDURE lpm_init
364	END INTERFACE lpm_init
365
366	INTERFACE lpm_actions
367	MODULE PROCEDURE lpm_actions
368	END INTERFACE lpm_actions
369
370	INTERFACE lpm_data_output_ptseries
371	MODULE PROCEDURE lpm_data_output_ptseries
372	END INTERFACE
373
374	INTERFACE lpm_rrd_local_particles
375	MODULE PROCEDURE lpm_rrd_local_particles
376	END INTERFACE lpm_rrd_local_particles
377
378	INTERFACE lpm_rrd_global
379	MODULE PROCEDURE lpm_rrd_global
380	END INTERFACE lpm_rrd_global
381
382	INTERFACE lpm_rrd_local
383	MODULE PROCEDURE lpm_rrd_local
384	END INTERFACE lpm_rrd_local
385
386	INTERFACE lpm_wrd_local
387	MODULE PROCEDURE lpm_wrd_local
388	END INTERFACE lpm_wrd_local
389
390	INTERFACE lpm_wrd_global
391	MODULE PROCEDURE lpm_wrd_global
392	END INTERFACE lpm_wrd_global
393
394	INTERFACE lpm_advec
395	MODULE PROCEDURE lpm_advec
396	END INTERFACE lpm_advec
397
398	INTERFACE lpm_calc_liquid_water_content
399	MODULE PROCEDURE lpm_calc_liquid_water_content
400	END INTERFACE
401
402	INTERFACE lpm_interaction_droplets_ptq
403	MODULE PROCEDURE lpm_interaction_droplets_ptq
404	MODULE PROCEDURE lpm_interaction_droplets_ptq_ij
405	END INTERFACE lpm_interaction_droplets_ptq
406
407	INTERFACE lpm_boundary_conds
408	MODULE PROCEDURE lpm_boundary_conds
409	END INTERFACE lpm_boundary_conds
410
411	INTERFACE lpm_droplet_condensation
412	MODULE PROCEDURE lpm_droplet_condensation
413	END INTERFACE
414
415	INTERFACE lpm_droplet_collision
416	MODULE PROCEDURE lpm_droplet_collision
417	END INTERFACE lpm_droplet_collision
418
419	INTERFACE lpm_init_kernels
420	MODULE PROCEDURE lpm_init_kernels
421	END INTERFACE lpm_init_kernels
422
423	INTERFACE lpm_splitting
424	MODULE PROCEDURE lpm_splitting
425	END INTERFACE lpm_splitting
426
427	INTERFACE lpm_merging
428	MODULE PROCEDURE lpm_merging
429	END INTERFACE lpm_merging
430
431	INTERFACE lpm_exchange_horiz
432	MODULE PROCEDURE lpm_exchange_horiz
433	END INTERFACE lpm_exchange_horiz
434
435	INTERFACE lpm_move_particle
436	MODULE PROCEDURE lpm_move_particle
437	END INTERFACE lpm_move_particle
438
439	INTERFACE realloc_particles_array
440	MODULE PROCEDURE realloc_particles_array
441	END INTERFACE realloc_particles_array
442
443	INTERFACE dealloc_particles_array
444	MODULE PROCEDURE dealloc_particles_array
445	END INTERFACE dealloc_particles_array
446
447	INTERFACE lpm_sort_and_delete
448	MODULE PROCEDURE lpm_sort_and_delete
449	END INTERFACE lpm_sort_and_delete
450
451	INTERFACE lpm_sort_timeloop_done
452	MODULE PROCEDURE lpm_sort_timeloop_done
453	END INTERFACE lpm_sort_timeloop_done
454
455	INTERFACE lpm_pack
456	MODULE PROCEDURE lpm_pack
457	END INTERFACE lpm_pack
458
459	CONTAINS
460
461
462	!------------------------------------------------------------------------------!
463	! Description:
464	! ------------
465	!> Parin for &particle_parameters for the Lagrangian particle model
466	!------------------------------------------------------------------------------!
467	SUBROUTINE lpm_parin
468
469	CHARACTER (LEN=80) :: line !<
470
471	NAMELIST /particles_par/ &
472	aero_species, &
473	aero_type, &
474	aero_weight, &
475	alloc_factor, &
476	bc_par_b, &
477	bc_par_lr, &
478	bc_par_ns, &
479	bc_par_t, &
480	collision_kernel, &
481	curvature_solution_effects, &
482	deallocate_memory, &
483	density_ratio, &
484	dissipation_classes, &
485	dt_dopts, &
486	dt_min_part, &
487	dt_prel, &
488	dt_write_particle_data, &
489	end_time_prel, &
490	initial_weighting_factor, &
491	log_sigma, &
492	max_number_particles_per_gridbox, &
493	merging, &
494	na, &
495	number_concentration, &
496	number_of_particle_groups, &
497	number_particles_per_gridbox, &
498	particles_per_point, &
499	particle_advection_start, &
500	particle_advection_interpolation, &
501	particle_maximum_age, &
502	pdx, &
503	pdy, &
504	pdz, &
505	psb, &
506	psl, &
507	psn, &
508	psr, &
509	pss, &
510	pst, &
511	radius, &
512	radius_classes, &
513	radius_merge, &
514	radius_split, &
515	random_start_position, &
516	read_particles_from_restartfile, &
517	rm, &
518	seed_follows_topography, &
519	splitting, &
520	splitting_factor, &
521	splitting_factor_max, &
522	splitting_function, &
523	splitting_mode, &
524	step_dealloc, &
525	use_sgs_for_particles, &
526	vertical_particle_advection, &
527	weight_factor_merge, &
528	weight_factor_split, &
529	write_particle_statistics
530
531	NAMELIST /particle_parameters/ &
532	aero_species, &
533	aero_type, &
534	aero_weight, &
535	alloc_factor, &
536	bc_par_b, &
537	bc_par_lr, &
538	bc_par_ns, &
539	bc_par_t, &
540	collision_kernel, &
541	curvature_solution_effects, &
542	deallocate_memory, &
543	density_ratio, &
544	dissipation_classes, &
545	dt_dopts, &
546	dt_min_part, &
547	dt_prel, &
548	dt_write_particle_data, &
549	end_time_prel, &
550	initial_weighting_factor, &
551	log_sigma, &
552	max_number_particles_per_gridbox, &
553	merging, &
554	na, &
555	number_concentration, &
556	number_of_particle_groups, &
557	number_particles_per_gridbox, &
558	particles_per_point, &
559	particle_advection_start, &
560	particle_advection_interpolation, &
561	particle_maximum_age, &
562	pdx, &
563	pdy, &
564	pdz, &
565	psb, &
566	psl, &
567	psn, &
568	psr, &
569	pss, &
570	pst, &
571	radius, &
572	radius_classes, &
573	radius_merge, &
574	radius_split, &
575	random_start_position, &
576	read_particles_from_restartfile, &
577	rm, &
578	seed_follows_topography, &
579	splitting, &
580	splitting_factor, &
581	splitting_factor_max, &
582	splitting_function, &
583	splitting_mode, &
584	step_dealloc, &
585	use_sgs_for_particles, &
586	vertical_particle_advection, &
587	weight_factor_merge, &
588	weight_factor_split, &
589	write_particle_statistics
590
591	!
592	!-- Position the namelist-file at the beginning (it was already opened in
593	!-- parin), search for the namelist-group of the package and position the
594	!-- file at this line. Do the same for each optionally used package.
595	line = ' '
596
597	!
598	!-- Try to find particles package
599	REWIND ( 11 )
600	line = ' '
601	DO WHILE ( INDEX( line, '&particle_parameters' ) == 0 )
602	READ ( 11, '(A)', END=12 ) line
603	ENDDO
604	BACKSPACE ( 11 )
605	!
606	!-- Read user-defined namelist
607	READ ( 11, particle_parameters, ERR = 10 )
608	!
609	!-- Set flag that indicates that particles are switched on
610	particle_advection = .TRUE.
611
612	GOTO 14
613
614	10 BACKSPACE( 11 )
615	READ( 11 , '(A)') line
616	CALL parin_fail_message( 'particle_parameters', line )
617	!
618	!-- Try to find particles package (old namelist)
619	12 REWIND ( 11 )
620	line = ' '
621	DO WHILE ( INDEX( line, '&particles_par' ) == 0 )
622	READ ( 11, '(A)', END=14 ) line
623	ENDDO
624	BACKSPACE ( 11 )
625	!
626	!-- Read user-defined namelist
627	READ ( 11, particles_par, ERR = 13, END = 14 )
628
629	message_string = 'namelist particles_par is deprecated and will be ' // &
630	'removed in near future. Please use namelist ' // &
631	'particle_parameters instead'
632	CALL message( 'package_parin', 'PA0487', 0, 1, 0, 6, 0 )
633
634	!
635	!-- Set flag that indicates that particles are switched on
636	particle_advection = .TRUE.
637
638	GOTO 14
639
640	13 BACKSPACE( 11 )
641	READ( 11 , '(A)') line
642	CALL parin_fail_message( 'particles_par', line )
643
644	14 CONTINUE
645
646	END SUBROUTINE lpm_parin
647
648	!------------------------------------------------------------------------------!
649	! Description:
650	! ------------
651	!> Writes used particle attributes in header file.
652	!------------------------------------------------------------------------------!
653	SUBROUTINE lpm_header ( io )
654
655	CHARACTER (LEN=40) :: output_format !< netcdf format
656
657	INTEGER(iwp) :: i !<
658	INTEGER(iwp), INTENT(IN) :: io !< Unit of the output file
659
660
661	IF ( humidity .AND. cloud_droplets ) THEN
662	WRITE ( io, 433 )
663	IF ( curvature_solution_effects ) WRITE ( io, 434 )
664	IF ( collision_kernel /= 'none' ) THEN
665	WRITE ( io, 435 ) TRIM( collision_kernel )
666	IF ( collision_kernel(6:9) == 'fast' ) THEN
667	WRITE ( io, 436 ) radius_classes, dissipation_classes
668	ENDIF
669	ELSE
670	WRITE ( io, 437 )
671	ENDIF
672	ENDIF
673
674	IF ( particle_advection ) THEN
675	!
676	!-- Particle attributes
677	WRITE ( io, 480 ) particle_advection_start, TRIM(particle_advection_interpolation), &
678	dt_prel, bc_par_lr, &
679	bc_par_ns, bc_par_b, bc_par_t, particle_maximum_age, &
680	end_time_prel
681	IF ( use_sgs_for_particles ) WRITE ( io, 488 ) dt_min_part
682	IF ( random_start_position ) WRITE ( io, 481 )
683	IF ( seed_follows_topography ) WRITE ( io, 496 )
684	IF ( particles_per_point > 1 ) WRITE ( io, 489 ) particles_per_point
685	WRITE ( io, 495 ) total_number_of_particles
686	IF ( dt_write_particle_data /= 9999999.9_wp ) THEN
687	WRITE ( io, 485 ) dt_write_particle_data
688	IF ( netcdf_data_format > 1 ) THEN
689	output_format = 'netcdf (64 bit offset) and binary'
690	ELSE
691	output_format = 'netcdf and binary'
692	ENDIF
693	IF ( netcdf_deflate == 0 ) THEN
694	WRITE ( io, 344 ) output_format
695	ELSE
696	WRITE ( io, 354 ) TRIM( output_format ), netcdf_deflate
697	ENDIF
698	ENDIF
699	IF ( dt_dopts /= 9999999.9_wp ) WRITE ( io, 494 ) dt_dopts
700	IF ( write_particle_statistics ) WRITE ( io, 486 )
701
702	WRITE ( io, 487 ) number_of_particle_groups
703
704	DO i = 1, number_of_particle_groups
705	WRITE ( io, 490 ) i, radius(i)
706	IF ( density_ratio(i) /= 0.0_wp ) THEN
707	WRITE ( io, 491 ) density_ratio(i)
708	ELSE
709	WRITE ( io, 492 )
710	ENDIF
711	WRITE ( io, 493 ) psl(i), psr(i), pss(i), psn(i), psb(i), pst(i), &
712	pdx(i), pdy(i), pdz(i)
713	IF ( .NOT. vertical_particle_advection(i) ) WRITE ( io, 482 )
714	ENDDO
715
716	ENDIF
717
718	344 FORMAT (' Output format: ',A/)
719	354 FORMAT (' Output format: ',A, ' compressed with level: ',I1/)
720
721	433 FORMAT (' Cloud droplets treated explicitly using the Lagrangian part', &
722	'icle model')
723	434 FORMAT (' Curvature and solution effecs are considered for growth of', &
724	' droplets < 1.0E-6 m')
725	435 FORMAT (' Droplet collision is handled by ',A,'-kernel')
726	436 FORMAT (' Fast kernel with fixed radius- and dissipation classes ', &
727	'are used'/ &
728	' number of radius classes: ',I3,' interval ', &
729	'[1.0E-6,2.0E-4] m'/ &
730	' number of dissipation classes: ',I2,' interval ', &
731	'[0,1000] cm2/s3')
732	437 FORMAT (' Droplet collision is switched off')
733
734	480 FORMAT (' Particles:'/ &
735	' ---------'// &
736	' Particle advection is active (switched on at t = ', F7.1, &
737	' s)'/ &
738	' Interpolation of particle velocities is done by using ', A, &
739	' method'/ &
740	' Start of new particle generations every ',F6.1,' s'/ &
741	' Boundary conditions: left/right: ', A, ' north/south: ', A/&
742	' bottom: ', A, ' top: ', A/&
743	' Maximum particle age: ',F9.1,' s'/ &
744	' Advection stopped at t = ',F9.1,' s'/)
745	481 FORMAT (' Particles have random start positions'/)
746	482 FORMAT (' Particles are advected only horizontally'/)
747	485 FORMAT (' Particle data are written on file every ', F9.1, ' s')
748	486 FORMAT (' Particle statistics are written on file'/)
749	487 FORMAT (' Number of particle groups: ',I2/)
750	488 FORMAT (' SGS velocity components are used for particle advection'/ &
751	' minimum timestep for advection:', F8.5/)
752	489 FORMAT (' Number of particles simultaneously released at each ', &
753	'point: ', I5/)
754	490 FORMAT (' Particle group ',I2,':'/ &
755	' Particle radius: ',E10.3, 'm')
756	491 FORMAT (' Particle inertia is activated'/ &
757	' density_ratio (rho_fluid/rho_particle) =',F6.3/)
758	492 FORMAT (' Particles are advected only passively (no inertia)'/)
759	493 FORMAT (' Boundaries of particle source: x:',F8.1,' - ',F8.1,' m'/&
760	' y:',F8.1,' - ',F8.1,' m'/&
761	' z:',F8.1,' - ',F8.1,' m'/&
762	' Particle distances: dx = ',F8.1,' m dy = ',F8.1, &
763	' m dz = ',F8.1,' m'/)
764	494 FORMAT (' Output of particle time series in NetCDF format every ', &
765	F8.2,' s'/)
766	495 FORMAT (' Number of particles in total domain: ',I10/)
767	496 FORMAT (' Initial vertical particle positions are interpreted ', &
768	'as relative to the given topography')
769
770	END SUBROUTINE lpm_header
771
772	!------------------------------------------------------------------------------!
773	! Description:
774	! ------------
775	!> Writes used particle attributes in header file.
776	!------------------------------------------------------------------------------!
777	SUBROUTINE lpm_check_parameters
778
779	!
780	!-- Collision kernels:
781	SELECT CASE ( TRIM( collision_kernel ) )
782
783	CASE ( 'hall', 'hall_fast' )
784	hall_kernel = .TRUE.
785
786	CASE ( 'wang', 'wang_fast' )
787	wang_kernel = .TRUE.
788
789	CASE ( 'none' )
790
791
792	CASE DEFAULT
793	message_string = 'unknown collision kernel: collision_kernel = "' // &
794	TRIM( collision_kernel ) // '"'
795	CALL message( 'lpm_check_parameters', 'PA0350', 1, 2, 0, 6, 0 )
796
797	END SELECT
798	IF ( collision_kernel(6:9) == 'fast' ) use_kernel_tables = .TRUE.
799
800	!
801	!-- Subgrid scale velocites with the simple interpolation method for resolved
802	!-- velocites is not implemented for passive particles. However, for cloud
803	!-- it can be combined as the sgs-velocites for active particles are
804	!-- calculated differently, i.e. no subboxes are needed.
805	IF ( .NOT. TRIM( particle_advection_interpolation ) == 'trilinear' .AND. &
806	use_sgs_for_particles .AND. .NOT. cloud_droplets ) THEN
807	message_string = 'subrgrid scale velocities in combination with ' // &
808	'simple interpolation method is not ' // &
809	'implemented'
810	CALL message( 'lpm_check_parameters', 'PA0659', 1, 2, 0, 6, 0 )
811	ENDIF
812
813	IF ( nested_run .AND. cloud_droplets ) THEN
814	message_string = 'nested runs in combination with cloud droplets ' // &
815	'is not implemented'
816	CALL message( 'lpm_check_parameters', 'PA0687', 1, 2, 0, 6, 0 )
817	ENDIF
818
819
820	END SUBROUTINE lpm_check_parameters
821
822	!------------------------------------------------------------------------------!
823	! Description:
824	! ------------
825	!> Initialize arrays for lpm
826	!------------------------------------------------------------------------------!
827	SUBROUTINE lpm_init_arrays
828
829	IF ( cloud_droplets ) THEN
830	!
831	!-- Liquid water content, change in liquid water content
832	ALLOCATE ( ql_1(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &
833	ql_2(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
834	!
835	!-- Real volume of particles (with weighting), volume of particles
836	ALLOCATE ( ql_v(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &
837	ql_vp(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
838	ENDIF
839
840
841	ALLOCATE( u_t(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &
842	v_t(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &
843	w_t(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
844	!
845	!-- Initialize values with current time step
846	u_t = u
847	v_t = v
848	w_t = w
849	!
850	!-- Initial assignment of the pointers
851	IF ( cloud_droplets ) THEN
852	ql => ql_1
853	ql_c => ql_2
854	ENDIF
855
856	END SUBROUTINE lpm_init_arrays
857
858	!------------------------------------------------------------------------------!
859	! Description:
860	! ------------
861	!> Initialize Lagrangian particle model
862	!------------------------------------------------------------------------------!
863	SUBROUTINE lpm_init
864
865	INTEGER(iwp) :: i !<
866	INTEGER(iwp) :: j !<
867	INTEGER(iwp) :: k !<
868
869	REAL(wp) :: div !<
870	REAL(wp) :: height_int !<
871	REAL(wp) :: height_p !<
872	REAL(wp) :: z_p !<
873	REAL(wp) :: z0_av_local !<
874
875	!
876	!-- In case of oceans runs, the vertical index calculations need an offset,
877	!-- because otherwise the k indices will become negative
878	IF ( ocean_mode ) THEN
879	offset_ocean_nzt = nzt
880	offset_ocean_nzt_m1 = nzt - 1
881	ENDIF
882
883	!
884	!-- Define block offsets for dividing a gridcell in 8 sub cells
885	!-- See documentation for List of subgrid boxes
886	!-- See pack_and_sort in lpm_pack_arrays.f90 for assignment of the subgrid boxes
887	block_offset(0) = block_offset_def ( 0, 0, 0)
888	block_offset(1) = block_offset_def ( 0, 0,-1)
889	block_offset(2) = block_offset_def ( 0,-1, 0)
890	block_offset(3) = block_offset_def ( 0,-1,-1)
891	block_offset(4) = block_offset_def (-1, 0, 0)
892	block_offset(5) = block_offset_def (-1, 0,-1)
893	block_offset(6) = block_offset_def (-1,-1, 0)
894	block_offset(7) = block_offset_def (-1,-1,-1)
895	!
896	!-- Check the number of particle groups.
897	IF ( number_of_particle_groups > max_number_of_particle_groups ) THEN
898	WRITE( message_string, * ) 'max_number_of_particle_groups =', &
899	max_number_of_particle_groups , &
900	'&number_of_particle_groups reset to ', &
901	max_number_of_particle_groups
902	CALL message( 'lpm_init', 'PA0213', 0, 1, 0, 6, 0 )
903	number_of_particle_groups = max_number_of_particle_groups
904	ENDIF
905	!
906	!-- Check if downward-facing walls exist. This case, reflection boundary
907	!-- conditions (as well as subgrid-scale velocities) may do not work
908	!-- propably (not realized so far).
909	IF ( surf_def_h(1)%ns >= 1 ) THEN
910	WRITE( message_string, * ) 'Overhanging topography do not work '// &
911	'with particles'
912	CALL message( 'lpm_init', 'PA0212', 0, 1, 0, 6, 0 )
913
914	ENDIF
915
916	!
917	!-- Set default start positions, if necessary
918	IF ( psl(1) == 9999999.9_wp ) psl(1) = 0.0_wp
919	IF ( psr(1) == 9999999.9_wp ) psr(1) = ( nx +1 ) * dx
920	IF ( pss(1) == 9999999.9_wp ) pss(1) = 0.0_wp
921	IF ( psn(1) == 9999999.9_wp ) psn(1) = ( ny +1 ) * dy
922	IF ( psb(1) == 9999999.9_wp ) psb(1) = zu(nz/2)
923	IF ( pst(1) == 9999999.9_wp ) pst(1) = psb(1)
924
925	IF ( pdx(1) == 9999999.9_wp .OR. pdx(1) == 0.0_wp ) pdx(1) = dx
926	IF ( pdy(1) == 9999999.9_wp .OR. pdy(1) == 0.0_wp ) pdy(1) = dy
927	IF ( pdz(1) == 9999999.9_wp .OR. pdz(1) == 0.0_wp ) pdz(1) = zu(2) - zu(1)
928
929	!
930	!-- If number_particles_per_gridbox is set, the parametres pdx, pdy and pdz are
931	!-- calculated diagnostically. Therfore an isotropic distribution is prescribed.
932	IF ( number_particles_per_gridbox /= -1 .AND. &
933	number_particles_per_gridbox >= 1 ) THEN
934	pdx(1) = (( dx * dy * ( zu(2) - zu(1) ) ) / &
935	REAL(number_particles_per_gridbox))**0.3333333_wp
936	!
937	!-- Ensure a smooth value (two significant digits) of distance between
938	!-- particles (pdx, pdy, pdz).
939	div = 1000.0_wp
940	DO WHILE ( pdx(1) < div )
941	div = div / 10.0_wp
942	ENDDO
943	pdx(1) = NINT( pdx(1) * 100.0_wp / div ) * div / 100.0_wp
944	pdy(1) = pdx(1)
945	pdz(1) = pdx(1)
946
947	ENDIF
948
949	DO j = 2, number_of_particle_groups
950	IF ( psl(j) == 9999999.9_wp ) psl(j) = psl(j-1)
951	IF ( psr(j) == 9999999.9_wp ) psr(j) = psr(j-1)
952	IF ( pss(j) == 9999999.9_wp ) pss(j) = pss(j-1)
953	IF ( psn(j) == 9999999.9_wp ) psn(j) = psn(j-1)
954	IF ( psb(j) == 9999999.9_wp ) psb(j) = psb(j-1)
955	IF ( pst(j) == 9999999.9_wp ) pst(j) = pst(j-1)
956	IF ( pdx(j) == 9999999.9_wp .OR. pdx(j) == 0.0_wp ) pdx(j) = pdx(j-1)
957	IF ( pdy(j) == 9999999.9_wp .OR. pdy(j) == 0.0_wp ) pdy(j) = pdy(j-1)
958	IF ( pdz(j) == 9999999.9_wp .OR. pdz(j) == 0.0_wp ) pdz(j) = pdz(j-1)
959	ENDDO
960
961	!
962	!-- Allocate arrays required for calculating particle SGS velocities.
963	!-- Initialize prefactor required for stoachastic Weil equation.
964	IF ( use_sgs_for_particles .AND. .NOT. cloud_droplets ) THEN
965	ALLOCATE( de_dx(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &
966	de_dy(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &
967	de_dz(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
968
969	de_dx = 0.0_wp
970	de_dy = 0.0_wp
971	de_dz = 0.0_wp
972
973	sgs_wf_part = 1.0_wp / 3.0_wp
974	ENDIF
975
976	!
977	!-- Allocate array required for logarithmic vertical interpolation of
978	!-- horizontal particle velocities between the surface and the first vertical
979	!-- grid level. In order to avoid repeated CPU cost-intensive CALLS of
980	!-- intrinsic FORTRAN procedure LOG(z/z0), LOG(z/z0) is precalculated for
981	!-- several heights. Splitting into 20 sublayers turned out to be sufficient.
982	!-- To obtain exact height levels of particles, linear interpolation is applied
983	!-- (see lpm_advec.f90).
984	IF ( constant_flux_layer ) THEN
985
986	ALLOCATE ( log_z_z0(0:number_of_sublayers) )
987	z_p = zu(nzb+1) - zw(nzb)
988
989	!
990	!-- Calculate horizontal mean value of z0 used for logartihmic
991	!-- interpolation. Note: this is not exact for heterogeneous z0.
992	!-- However, sensitivity studies showed that the effect is
993	!-- negligible.
994	z0_av_local = SUM( surf_def_h(0)%z0 ) + SUM( surf_lsm_h%z0 ) + &
995	SUM( surf_usm_h%z0 )
996	z0_av_global = 0.0_wp
997
998	#if defined( __parallel )
999	CALL MPI_ALLREDUCE(z0_av_local, z0_av_global, 1, MPI_REAL, MPI_SUM, &
1000	comm2d, ierr )
1001	#else
1002	z0_av_global = z0_av_local
1003	#endif
1004
1005	z0_av_global = z0_av_global / ( ( ny + 1 ) * ( nx + 1 ) )
1006	!
1007	!-- Horizontal wind speed is zero below and at z0
1008	log_z_z0(0) = 0.0_wp
1009	!
1010	!-- Calculate vertical depth of the sublayers
1011	height_int = ( z_p - z0_av_global ) / REAL( number_of_sublayers, KIND=wp )
1012	!
1013	!-- Precalculate LOG(z/z0)
1014	height_p = z0_av_global
1015	DO k = 1, number_of_sublayers
1016
1017	height_p = height_p + height_int
1018	log_z_z0(k) = LOG( height_p / z0_av_global )
1019
1020	ENDDO
1021
1022	ENDIF
1023
1024	!
1025	!-- Check which particle interpolation method should be used
1026	IF ( TRIM( particle_advection_interpolation ) == 'trilinear' ) THEN
1027	interpolation_simple_corrector = .FALSE.
1028	interpolation_simple_predictor = .FALSE.
1029	interpolation_trilinear = .TRUE.
1030	ELSEIF ( TRIM( particle_advection_interpolation ) == 'simple_corrector' ) THEN
1031	interpolation_simple_corrector = .TRUE.
1032	interpolation_simple_predictor = .FALSE.
1033	interpolation_trilinear = .FALSE.
1034	ELSEIF ( TRIM( particle_advection_interpolation ) == 'simple_predictor' ) THEN
1035	interpolation_simple_corrector = .FALSE.
1036	interpolation_simple_predictor = .TRUE.
1037	interpolation_trilinear = .FALSE.
1038	ENDIF
1039
1040	!
1041	!-- Check boundary condition and set internal variables
1042	SELECT CASE ( bc_par_b )
1043
1044	CASE ( 'absorb' )
1045	ibc_par_b = 1
1046
1047	CASE ( 'reflect' )
1048	ibc_par_b = 2
1049
1050	CASE ( 'reset' )
1051	ibc_par_b = 3
1052
1053	CASE DEFAULT
1054	WRITE( message_string, * ) 'unknown boundary condition ', &
1055	'bc_par_b = "', TRIM( bc_par_b ), '"'
1056	CALL message( 'lpm_init', 'PA0217', 1, 2, 0, 6, 0 )
1057
1058	END SELECT
1059	SELECT CASE ( bc_par_t )
1060
1061	CASE ( 'absorb' )
1062	ibc_par_t = 1
1063
1064	CASE ( 'reflect' )
1065	ibc_par_t = 2
1066
1067	CASE ( 'nested' )
1068	ibc_par_t = 3
1069
1070	CASE DEFAULT
1071	WRITE( message_string, * ) 'unknown boundary condition ', &
1072	'bc_par_t = "', TRIM( bc_par_t ), '"'
1073	CALL message( 'lpm_init', 'PA0218', 1, 2, 0, 6, 0 )
1074
1075	END SELECT
1076	SELECT CASE ( bc_par_lr )
1077
1078	CASE ( 'cyclic' )
1079	ibc_par_lr = 0
1080
1081	CASE ( 'absorb' )
1082	ibc_par_lr = 1
1083
1084	CASE ( 'reflect' )
1085	ibc_par_lr = 2
1086
1087	CASE ( 'nested' )
1088	ibc_par_lr = 3
1089
1090	CASE DEFAULT
1091	WRITE( message_string, * ) 'unknown boundary condition ', &
1092	'bc_par_lr = "', TRIM( bc_par_lr ), '"'
1093	CALL message( 'lpm_init', 'PA0219', 1, 2, 0, 6, 0 )
1094
1095	END SELECT
1096	SELECT CASE ( bc_par_ns )
1097
1098	CASE ( 'cyclic' )
1099	ibc_par_ns = 0
1100
1101	CASE ( 'absorb' )
1102	ibc_par_ns = 1
1103
1104	CASE ( 'reflect' )
1105	ibc_par_ns = 2
1106
1107	CASE ( 'nested' )
1108	ibc_par_ns = 3
1109
1110	CASE DEFAULT
1111	WRITE( message_string, * ) 'unknown boundary condition ', &
1112	'bc_par_ns = "', TRIM( bc_par_ns ), '"'
1113	CALL message( 'lpm_init', 'PA0220', 1, 2, 0, 6, 0 )
1114
1115	END SELECT
1116	SELECT CASE ( splitting_mode )
1117
1118	CASE ( 'const' )
1119	i_splitting_mode = 1
1120
1121	CASE ( 'cl_av' )
1122	i_splitting_mode = 2
1123
1124	CASE ( 'gb_av' )
1125	i_splitting_mode = 3
1126
1127	CASE DEFAULT
1128	WRITE( message_string, * ) 'unknown splitting_mode = "', &
1129	TRIM( splitting_mode ), '"'
1130	CALL message( 'lpm_init', 'PA0146', 1, 2, 0, 6, 0 )
1131
1132	END SELECT
1133	SELECT CASE ( splitting_function )
1134
1135	CASE ( 'gamma' )
1136	isf = 1
1137
1138	CASE ( 'log' )
1139	isf = 2
1140
1141	CASE ( 'exp' )
1142	isf = 3
1143
1144	CASE DEFAULT
1145	WRITE( message_string, * ) 'unknown splitting function = "', &
1146	TRIM( splitting_function ), '"'
1147	CALL message( 'lpm_init', 'PA0147', 1, 2, 0, 6, 0 )
1148
1149	END SELECT
1150	!
1151	!-- Initialize collision kernels
1152	IF ( collision_kernel /= 'none' ) CALL lpm_init_kernels
1153	!
1154	!-- For the first model run of a possible job chain initialize the
1155	!-- particles, otherwise read the particle data from restart file.
1156	IF ( TRIM( initializing_actions ) == 'read_restart_data' &
1157	.AND. read_particles_from_restartfile ) THEN
1158	CALL lpm_rrd_local_particles
1159	ELSE
1160	!
1161	!-- Allocate particle arrays and set attributes of the initial set of
1162	!-- particles, which can be also periodically released at later times.
1163	ALLOCATE( prt_count(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &
1164	grid_particles(nzb+1:nzt,nys:nyn,nxl:nxr) )
1165
1166	number_of_particles = 0
1167	prt_count = 0
1168	!
1169	!-- initialize counter for particle IDs
1170	grid_particles%id_counter = 1
1171	!
1172	!-- Initialize all particles with dummy values (otherwise errors may
1173	!-- occur within restart runs). The reason for this is still not clear
1174	!-- and may be presumably caused by errors in the respective user-interface.
1175	zero_particle = particle_type( 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, &
1176	0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, &
1177	0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, &
1178	0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, &
1179	0, 0, 0_idp, .FALSE., -1 )
1180
1181	particle_groups = particle_groups_type( 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp )
1182	!
1183	!-- Set values for the density ratio and radius for all particle
1184	!-- groups, if necessary
1185	IF ( density_ratio(1) == 9999999.9_wp ) density_ratio(1) = 0.0_wp
1186	IF ( radius(1) == 9999999.9_wp ) radius(1) = 0.0_wp
1187	DO i = 2, number_of_particle_groups
1188	IF ( density_ratio(i) == 9999999.9_wp ) THEN
1189	density_ratio(i) = density_ratio(i-1)
1190	ENDIF
1191	IF ( radius(i) == 9999999.9_wp ) radius(i) = radius(i-1)
1192	ENDDO
1193
1194	DO i = 1, number_of_particle_groups
1195	IF ( density_ratio(i) /= 0.0_wp .AND. radius(i) == 0 ) THEN
1196	WRITE( message_string, * ) 'particle group #', i, ' has a', &
1197	'density ratio /= 0 but radius = 0'
1198	CALL message( 'lpm_init', 'PA0215', 1, 2, 0, 6, 0 )
1199	ENDIF
1200	particle_groups(i)%density_ratio = density_ratio(i)
1201	particle_groups(i)%radius = radius(i)
1202	ENDDO
1203	!
1204	!-- Set a seed value for the random number generator to be exclusively
1205	!-- used for the particle code. The generated random numbers should be
1206	!-- different on the different PEs.
1207	iran_part = iran_part + myid
1208	!
1209	!-- Create the particle set, and set the initial particles
1210	CALL lpm_create_particle( phase_init )
1211	last_particle_release_time = particle_advection_start
1212	!
1213	!-- User modification of initial particles
1214	CALL user_lpm_init
1215	!
1216	!-- Open file for statistical informations about particle conditions
1217	IF ( write_particle_statistics ) THEN
1218	CALL check_open( 80 )
1219	WRITE ( 80, 8000 ) current_timestep_number, simulated_time, &
1220	number_of_particles
1221	CALL close_file( 80 )
1222	ENDIF
1223
1224	ENDIF
1225
1226	IF ( nested_run ) CALL pmcp_g_init
1227	!
1228	!-- To avoid programm abort, assign particles array to the local version of
1229	!-- first grid cell
1230	number_of_particles = prt_count(nzb+1,nys,nxl)
1231	particles => grid_particles(nzb+1,nys,nxl)%particles(1:number_of_particles)
1232	!
1233	!-- Formats
1234	8000 FORMAT (I6,1X,F7.2,4X,I10,71X,I10)
1235
1236	END SUBROUTINE lpm_init
1237
1238	!------------------------------------------------------------------------------!
1239	! Description:
1240	! ------------
1241	!> Create Lagrangian particles
1242	!------------------------------------------------------------------------------!
1243	SUBROUTINE lpm_create_particle (phase)
1244
1245	INTEGER(iwp) :: alloc_size !< relative increase of allocated memory for particles
1246	INTEGER(iwp) :: i !< loop variable ( particle groups )
1247	INTEGER(iwp) :: ip !< index variable along x
1248	INTEGER(iwp) :: j !< loop variable ( particles per point )
1249	INTEGER(iwp) :: jp !< index variable along y
1250	INTEGER(iwp) :: k !< index variable along z
1251	INTEGER(iwp) :: k_surf !< index of surface grid point
1252	INTEGER(iwp) :: kp !< index variable along z
1253	INTEGER(iwp) :: loop_stride !< loop variable for initialization
1254	INTEGER(iwp) :: n !< loop variable ( number of particles )
1255	INTEGER(iwp) :: new_size !< new size of allocated memory for particles
1256
1257	INTEGER(iwp), INTENT(IN) :: phase !< mode of inititialization
1258
1259	INTEGER(iwp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: local_count !< start address of new particle
1260	INTEGER(iwp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: local_start !< start address of new particle
1261
1262	LOGICAL :: first_stride !< flag for initialization
1263
1264	REAL(wp) :: pos_x !< increment for particle position in x
1265	REAL(wp) :: pos_y !< increment for particle position in y
1266	REAL(wp) :: pos_z !< increment for particle position in z
1267	REAL(wp) :: rand_contr !< dummy argument for random position
1268
1269	TYPE(particle_type),TARGET :: tmp_particle !< temporary particle used for initialization
1270
1271
1272	!
1273	!-- Calculate particle positions and store particle attributes, if
1274	!-- particle is situated on this PE
1275	DO loop_stride = 1, 2
1276	first_stride = (loop_stride == 1)
1277	IF ( first_stride ) THEN
1278	local_count = 0 ! count number of particles
1279	ELSE
1280	local_count = prt_count ! Start address of new particles
1281	ENDIF
1282
1283	!
1284	!-- Calculate initial_weighting_factor diagnostically
1285	IF ( number_concentration /= -1.0_wp .AND. number_concentration > 0.0_wp ) THEN
1286	initial_weighting_factor = number_concentration * &
1287	pdx(1) * pdy(1) * pdz(1)
1288	END IF
1289
1290	n = 0
1291	DO i = 1, number_of_particle_groups
1292	pos_z = psb(i)
1293	DO WHILE ( pos_z <= pst(i) )
1294	IF ( pos_z >= zw(0) .AND. pos_z < zw(nzt) ) THEN
1295	pos_y = pss(i)
1296	DO WHILE ( pos_y <= psn(i) )
1297	IF ( pos_y >= nys * dy .AND. &
1298	pos_y < ( nyn + 1 ) * dy ) THEN
1299	pos_x = psl(i)
1300	xloop: DO WHILE ( pos_x <= psr(i) )
1301	IF ( pos_x >= nxl * dx .AND. &
1302	pos_x < ( nxr + 1) * dx ) THEN
1303	DO j = 1, particles_per_point
1304	n = n + 1
1305	tmp_particle%x = pos_x
1306	tmp_particle%y = pos_y
1307	tmp_particle%z = pos_z
1308	tmp_particle%age = 0.0_wp
1309	tmp_particle%age_m = 0.0_wp
1310	tmp_particle%dt_sum = 0.0_wp
1311	tmp_particle%e_m = 0.0_wp
1312	tmp_particle%rvar1 = 0.0_wp
1313	tmp_particle%rvar2 = 0.0_wp
1314	tmp_particle%rvar3 = 0.0_wp
1315	tmp_particle%speed_x = 0.0_wp
1316	tmp_particle%speed_y = 0.0_wp
1317	tmp_particle%speed_z = 0.0_wp
1318	tmp_particle%origin_x = pos_x
1319	tmp_particle%origin_y = pos_y
1320	tmp_particle%origin_z = pos_z
1321	IF ( curvature_solution_effects ) THEN
1322	tmp_particle%aux1 = 0.0_wp ! dry aerosol radius
1323	tmp_particle%aux2 = dt_3d ! last Rosenbrock timestep
1324	ELSE
1325	tmp_particle%aux1 = 0.0_wp ! free to use
1326	tmp_particle%aux2 = 0.0_wp ! free to use
1327	ENDIF
1328	tmp_particle%radius = particle_groups(i)%radius
1329	tmp_particle%weight_factor = initial_weighting_factor
1330	tmp_particle%class = 1
1331	tmp_particle%group = i
1332	tmp_particle%id = 0_idp
1333	tmp_particle%particle_mask = .TRUE.
1334	tmp_particle%block_nr = -1
1335	!
1336	!-- Determine the grid indices of the particle position
1337	ip = INT( tmp_particle%x * ddx )
1338	jp = INT( tmp_particle%y * ddy )
1339	!
1340	!-- In case of stretching the actual k index is found iteratively
1341	IF ( dz_stretch_level /= -9999999.9_wp .OR. &
1342	dz_stretch_level_start(1) /= -9999999.9_wp ) THEN
1343	kp = MINLOC( ABS( tmp_particle%z - zu ), DIM = 1 ) - 1
1344	ELSE
1345	kp = INT( tmp_particle%z / dz(1) + 1 + offset_ocean_nzt )
1346	ENDIF
1347	!
1348	!-- Determine surface level. Therefore, check for
1349	!-- upward-facing wall on w-grid.
1350	k_surf = topo_top_ind(jp,ip,3)
1351	IF ( seed_follows_topography ) THEN
1352	!
1353	!-- Particle height is given relative to topography
1354	kp = kp + k_surf
1355	tmp_particle%z = tmp_particle%z + zw(k_surf)
1356	!-- Skip particle release if particle position is
1357	!-- above model top, or within topography in case
1358	!-- of overhanging structures.
1359	IF ( kp > nzt .OR. &
1360	.NOT. BTEST( wall_flags_total_0(kp,jp,ip), 0 ) ) THEN
1361	pos_x = pos_x + pdx(i)
1362	CYCLE xloop
1363	ENDIF
1364	!
1365	!-- Skip particle release if particle position is
1366	!-- below surface, or within topography in case
1367	!-- of overhanging structures.
1368	ELSEIF ( .NOT. seed_follows_topography .AND. &
1369	tmp_particle%z <= zw(k_surf) .OR. &
1370	.NOT. BTEST( wall_flags_total_0(kp,jp,ip), 0 ) )&
1371	THEN
1372	pos_x = pos_x + pdx(i)
1373	CYCLE xloop
1374	ENDIF
1375
1376	local_count(kp,jp,ip) = local_count(kp,jp,ip) + 1
1377
1378	IF ( .NOT. first_stride ) THEN
1379	IF ( ip < nxl .OR. jp < nys .OR. kp < nzb+1 ) THEN
1380	write(6,*) 'xl ',ip,jp,kp,nxl,nys,nzb+1
1381	ENDIF
1382	IF ( ip > nxr .OR. jp > nyn .OR. kp > nzt ) THEN
1383	write(6,*) 'xu ',ip,jp,kp,nxr,nyn,nzt
1384	ENDIF
1385	grid_particles(kp,jp,ip)%particles(local_count(kp,jp,ip)) = tmp_particle
1386	ENDIF
1387	ENDDO
1388	ENDIF
1389	pos_x = pos_x + pdx(i)
1390	ENDDO xloop
1391	ENDIF
1392	pos_y = pos_y + pdy(i)
1393	ENDDO
1394	ENDIF
1395
1396	pos_z = pos_z + pdz(i)
1397	ENDDO
1398	ENDDO
1399
1400	IF ( first_stride ) THEN
1401	DO ip = nxl, nxr
1402	DO jp = nys, nyn
1403	DO kp = nzb+1, nzt
1404	IF ( phase == PHASE_INIT ) THEN
1405	IF ( local_count(kp,jp,ip) > 0 ) THEN
1406	alloc_size = MAX( INT( local_count(kp,jp,ip) * &
1407	( 1.0_wp + alloc_factor / 100.0_wp ) ), &
1408	1 )
1409	ELSE
1410	alloc_size = 1
1411	ENDIF
1412	ALLOCATE(grid_particles(kp,jp,ip)%particles(1:alloc_size))
1413	DO n = 1, alloc_size
1414	grid_particles(kp,jp,ip)%particles(n) = zero_particle
1415	ENDDO
1416	ELSEIF ( phase == PHASE_RELEASE ) THEN
1417	IF ( local_count(kp,jp,ip) > 0 ) THEN
1418	new_size = local_count(kp,jp,ip) + prt_count(kp,jp,ip)
1419	alloc_size = MAX( INT( new_size * ( 1.0_wp + &
1420	alloc_factor / 100.0_wp ) ), 1 )
1421	IF( alloc_size > SIZE( grid_particles(kp,jp,ip)%particles) ) THEN
1422	CALL realloc_particles_array( ip, jp, kp, alloc_size )
1423	ENDIF
1424	ENDIF
1425	ENDIF
1426	ENDDO
1427	ENDDO
1428	ENDDO
1429	ENDIF
1430
1431	ENDDO
1432
1433	local_start = prt_count+1
1434	prt_count = local_count
1435	!
1436	!-- Calculate particle IDs
1437	DO ip = nxl, nxr
1438	DO jp = nys, nyn
1439	DO kp = nzb+1, nzt
1440	number_of_particles = prt_count(kp,jp,ip)
1441	IF ( number_of_particles <= 0 ) CYCLE
1442	particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
1443
1444	DO n = local_start(kp,jp,ip), number_of_particles !only new particles
1445
1446	particles(n)%id = 10000_idp*3 grid_particles(kp,jp,ip)%id_counter + &
1447	10000_idp*2 kp + 10000_idp * jp + ip
1448	!
1449	!-- Count the number of particles that have been released before
1450	grid_particles(kp,jp,ip)%id_counter = &
1451	grid_particles(kp,jp,ip)%id_counter + 1
1452
1453	ENDDO
1454
1455	ENDDO
1456	ENDDO
1457	ENDDO
1458	!
1459	!-- Initialize aerosol background spectrum
1460	IF ( curvature_solution_effects ) THEN
1461	CALL lpm_init_aerosols( local_start )
1462	ENDIF
1463	!
1464	!-- Add random fluctuation to particle positions.
1465	IF ( random_start_position ) THEN
1466	DO ip = nxl, nxr
1467	DO jp = nys, nyn
1468	DO kp = nzb+1, nzt
1469	number_of_particles = prt_count(kp,jp,ip)
1470	IF ( number_of_particles <= 0 ) CYCLE
1471	particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
1472	!
1473	!-- Move only new particles. Moreover, limit random fluctuation
1474	!-- in order to prevent that particles move more than one grid box,
1475	!-- which would lead to problems concerning particle exchange
1476	!-- between processors in case pdx/pdy are larger than dx/dy,
1477	!-- respectively.
1478	DO n = local_start(kp,jp,ip), number_of_particles
1479	IF ( psl(particles(n)%group) /= psr(particles(n)%group) ) THEN
1480	rand_contr = ( random_function( iran_part ) - 0.5_wp ) * &
1481	pdx(particles(n)%group)
1482	particles(n)%x = particles(n)%x + &
1483	MERGE( rand_contr, SIGN( dx, rand_contr ), &
1484	ABS( rand_contr ) < dx &
1485	)
1486	ENDIF
1487	IF ( pss(particles(n)%group) /= psn(particles(n)%group) ) THEN
1488	rand_contr = ( random_function( iran_part ) - 0.5_wp ) * &
1489	pdy(particles(n)%group)
1490	particles(n)%y = particles(n)%y + &
1491	MERGE( rand_contr, SIGN( dy, rand_contr ), &
1492	ABS( rand_contr ) < dy &
1493	)
1494	ENDIF
1495	IF ( psb(particles(n)%group) /= pst(particles(n)%group) ) THEN
1496	rand_contr = ( random_function( iran_part ) - 0.5_wp ) * &
1497	pdz(particles(n)%group)
1498	particles(n)%z = particles(n)%z + &
1499	MERGE( rand_contr, SIGN( dzw(kp), rand_contr ), &
1500	ABS( rand_contr ) < dzw(kp) &
1501	)
1502	ENDIF
1503	ENDDO
1504	!
1505	!-- Identify particles located outside the model domain and reflect
1506	!-- or absorb them if necessary.
1507	CALL lpm_boundary_conds( 'bottom/top', i, j, k )
1508	!
1509	!-- Furthermore, remove particles located in topography. Note, as
1510	!-- the particle speed is still zero at this point, wall
1511	!-- reflection boundary conditions will not work in this case.
1512	particles => &
1513	grid_particles(kp,jp,ip)%particles(1:number_of_particles)
1514	DO n = local_start(kp,jp,ip), number_of_particles
1515	i = particles(n)%x * ddx
1516	j = particles(n)%y * ddy
1517	k = particles(n)%z / dz(1) + 1 + offset_ocean_nzt
1518	DO WHILE( zw(k) < particles(n)%z )
1519	k = k + 1
1520	ENDDO
1521	DO WHILE( zw(k-1) > particles(n)%z )
1522	k = k - 1
1523	ENDDO
1524	!
1525	!-- Check if particle is within topography
1526	IF ( .NOT. BTEST( wall_flags_total_0(k,j,i), 0 ) ) THEN
1527	particles(n)%particle_mask = .FALSE.
1528	deleted_particles = deleted_particles + 1
1529	ENDIF
1530
1531	ENDDO
1532	ENDDO
1533	ENDDO
1534	ENDDO
1535	!
1536	!-- Exchange particles between grid cells and processors
1537	CALL lpm_move_particle
1538	CALL lpm_exchange_horiz
1539
1540	ENDIF
1541	!
1542	!-- In case of random_start_position, delete particles identified by
1543	!-- lpm_exchange_horiz and lpm_boundary_conds. Then sort particles into blocks,
1544	!-- which is needed for a fast interpolation of the LES fields on the particle
1545	!-- position.
1546	CALL lpm_sort_and_delete
1547	!
1548	!-- Determine the current number of particles
1549	DO ip = nxl, nxr
1550	DO jp = nys, nyn
1551	DO kp = nzb+1, nzt
1552	number_of_particles = number_of_particles &
1553	+ prt_count(kp,jp,ip)
1554	ENDDO
1555	ENDDO
1556	ENDDO
1557	!
1558	!-- Calculate the number of particles of the total domain
1559	#if defined( __parallel )
1560	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
1561	CALL MPI_ALLREDUCE( number_of_particles, total_number_of_particles, 1, &
1562	MPI_INTEGER, MPI_SUM, comm2d, ierr )
1563	#else
1564	total_number_of_particles = number_of_particles
1565	#endif
1566
1567	RETURN
1568
1569	END SUBROUTINE lpm_create_particle
1570
1571
1572	!------------------------------------------------------------------------------!
1573	! Description:
1574	! ------------
1575	!> This routine initialize the particles as aerosols with physio-chemical
1576	!> properties.
1577	!------------------------------------------------------------------------------!
1578	SUBROUTINE lpm_init_aerosols(local_start)
1579
1580	REAL(wp) :: afactor !< curvature effects
1581	REAL(wp) :: bfactor !< solute effects
1582	REAL(wp) :: dlogr !< logarithmic width of radius bin
1583	REAL(wp) :: e_a !< vapor pressure
1584	REAL(wp) :: e_s !< saturation vapor pressure
1585	REAL(wp) :: rmin = 0.005e-6_wp !< minimum aerosol radius
1586	REAL(wp) :: rmax = 10.0e-6_wp !< maximum aerosol radius
1587	REAL(wp) :: r_mid !< mean radius of bin
1588	REAL(wp) :: r_l !< left radius of bin
1589	REAL(wp) :: r_r !< right radius of bin
1590	REAL(wp) :: sigma !< surface tension
1591	REAL(wp) :: t_int !< temperature
1592
1593	INTEGER(iwp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg), INTENT(IN) :: local_start !<
1594
1595	INTEGER(iwp) :: n !<
1596	INTEGER(iwp) :: ip !<
1597	INTEGER(iwp) :: jp !<
1598	INTEGER(iwp) :: kp !<
1599
1600	!
1601	!-- Set constants for different aerosol species
1602	IF ( TRIM( aero_species ) == 'nacl' ) THEN
1603	molecular_weight_of_solute = 0.05844_wp
1604	rho_s = 2165.0_wp
1605	vanthoff = 2.0_wp
1606	ELSEIF ( TRIM( aero_species ) == 'c3h4o4' ) THEN
1607	molecular_weight_of_solute = 0.10406_wp
1608	rho_s = 1600.0_wp
1609	vanthoff = 1.37_wp
1610	ELSEIF ( TRIM( aero_species ) == 'nh4o3' ) THEN
1611	molecular_weight_of_solute = 0.08004_wp
1612	rho_s = 1720.0_wp
1613	vanthoff = 2.31_wp
1614	ELSE
1615	WRITE( message_string, * ) 'unknown aerosol species ', &
1616	'aero_species = "', TRIM( aero_species ), '"'
1617	CALL message( 'lpm_init', 'PA0470', 1, 2, 0, 6, 0 )
1618	ENDIF
1619	!
1620	!-- The following typical aerosol spectra are taken from Jaenicke (1993):
1621	!-- Tropospheric aerosols. Published in Aerosol-Cloud-Climate Interactions.
1622	IF ( TRIM( aero_type ) == 'polar' ) THEN
1623	na = (/ 2.17e1, 1.86e-1, 3.04e-4 /) * 1.0E6_wp
1624	rm = (/ 0.0689, 0.375, 4.29 /) * 1.0E-6_wp
1625	log_sigma = (/ 0.245, 0.300, 0.291 /)
1626	ELSEIF ( TRIM( aero_type ) == 'background' ) THEN
1627	na = (/ 1.29e2, 5.97e1, 6.35e1 /) * 1.0E6_wp
1628	rm = (/ 0.0036, 0.127, 0.259 /) * 1.0E-6_wp
1629	log_sigma = (/ 0.645, 0.253, 0.425 /)
1630	ELSEIF ( TRIM( aero_type ) == 'maritime' ) THEN
1631	na = (/ 1.33e2, 6.66e1, 3.06e0 /) * 1.0E6_wp
1632	rm = (/ 0.0039, 0.133, 0.29 /) * 1.0E-6_wp
1633	log_sigma = (/ 0.657, 0.210, 0.396 /)
1634	ELSEIF ( TRIM( aero_type ) == 'continental' ) THEN
1635	na = (/ 3.20e3, 2.90e3, 3.00e-1 /) * 1.0E6_wp
1636	rm = (/ 0.01, 0.058, 0.9 /) * 1.0E-6_wp
1637	log_sigma = (/ 0.161, 0.217, 0.380 /)
1638	ELSEIF ( TRIM( aero_type ) == 'desert' ) THEN
1639	na = (/ 7.26e2, 1.14e3, 1.78e-1 /) * 1.0E6_wp
1640	rm = (/ 0.001, 0.0188, 10.8 /) * 1.0E-6_wp
1641	log_sigma = (/ 0.247, 0.770, 0.438 /)
1642	ELSEIF ( TRIM( aero_type ) == 'rural' ) THEN
1643	na = (/ 6.65e3, 1.47e2, 1.99e3 /) * 1.0E6_wp
1644	rm = (/ 0.00739, 0.0269, 0.0419 /) * 1.0E-6_wp
1645	log_sigma = (/ 0.225, 0.557, 0.266 /)
1646	ELSEIF ( TRIM( aero_type ) == 'urban' ) THEN
1647	na = (/ 9.93e4, 1.11e3, 3.64e4 /) * 1.0E6_wp
1648	rm = (/ 0.00651, 0.00714, 0.0248 /) * 1.0E-6_wp
1649	log_sigma = (/ 0.245, 0.666, 0.337 /)
1650	ELSEIF ( TRIM( aero_type ) == 'user' ) THEN
1651	CONTINUE
1652	ELSE
1653	WRITE( message_string, * ) 'unknown aerosol type ', &
1654	'aero_type = "', TRIM( aero_type ), '"'
1655	CALL message( 'lpm_init', 'PA0459', 1, 2, 0, 6, 0 )
1656	ENDIF
1657
1658	DO ip = nxl, nxr
1659	DO jp = nys, nyn
1660	DO kp = nzb+1, nzt
1661
1662	number_of_particles = prt_count(kp,jp,ip)
1663	IF ( number_of_particles <= 0 ) CYCLE
1664	particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
1665
1666	dlogr = ( LOG10(rmax) - LOG10(rmin) ) / ( number_of_particles - local_start(kp,jp,ip) + 1 )
1667	!
1668	!-- Initialize the aerosols with a predefined spectral distribution
1669	!-- of the dry radius (logarithmically increasing bins) and a varying
1670	!-- weighting factor
1671	DO n = local_start(kp,jp,ip), number_of_particles !only new particles
1672
1673	r_l = 10.0*( LOG10( rmin ) + (n-1) dlogr )
1674	r_r = 10.0*( LOG10( rmin ) + n dlogr )
1675	r_mid = SQRT( r_l * r_r )
1676
1677	particles(n)%aux1 = r_mid
1678	particles(n)%weight_factor = &
1679	( na(1) / ( SQRT( 2.0_wp * pi ) * log_sigma(1) ) * &
1680	EXP( - LOG10( r_mid / rm(1) )*2 / ( 2.0_wp log_sigma(1)**2 ) ) + &
1681	na(2) / ( SQRT( 2.0_wp * pi ) * log_sigma(2) ) * &
1682	EXP( - LOG10( r_mid / rm(2) )*2 / ( 2.0_wp log_sigma(2)**2 ) ) + &
1683	na(3) / ( SQRT( 2.0_wp * pi ) * log_sigma(3) ) * &
1684	EXP( - LOG10( r_mid / rm(3) )*2 / ( 2.0_wp log_sigma(3)**2 ) ) &
1685	) * ( LOG10(r_r) - LOG10(r_l) ) * ( dx * dy * dzw(kp) )
1686
1687	!
1688	!-- Multiply weight_factor with the namelist parameter aero_weight
1689	!-- to increase or decrease the number of simulated aerosols
1690	particles(n)%weight_factor = particles(n)%weight_factor * aero_weight
1691
1692	IF ( particles(n)%weight_factor - FLOOR(particles(n)%weight_factor,KIND=wp) &
1693	> random_function( iran_part ) ) THEN
1694	particles(n)%weight_factor = FLOOR(particles(n)%weight_factor,KIND=wp) + 1.0_wp
1695	ELSE
1696	particles(n)%weight_factor = FLOOR(particles(n)%weight_factor,KIND=wp)
1697	ENDIF
1698	!
1699	!-- Unnecessary particles will be deleted
1700	IF ( particles(n)%weight_factor <= 0.0_wp ) particles(n)%particle_mask = .FALSE.
1701
1702	ENDDO
1703	!
1704	!-- Set particle radius to equilibrium radius based on the environmental
1705	!-- supersaturation (Khvorostyanov and Curry, 2007, JGR). This avoids
1706	!-- the sometimes lengthy growth toward their equilibrium radius within
1707	!-- the simulation.
1708	t_int = pt(kp,jp,ip) * exner(kp)
1709
1710	e_s = magnus( t_int )
1711	e_a = q(kp,jp,ip) * hyp(kp) / ( q(kp,jp,ip) + rd_d_rv )
1712
1713	sigma = 0.0761_wp - 0.000155_wp * ( t_int - 273.15_wp )
1714	afactor = 2.0_wp * sigma / ( rho_l * r_v * t_int )
1715
1716	bfactor = vanthoff * molecular_weight_of_water * &
1717	rho_s / ( molecular_weight_of_solute * rho_l )
1718	!
1719	!-- The formula is only valid for subsaturated environments. For
1720	!-- supersaturations higher than -5 %, the supersaturation is set to -5%.
1721	IF ( e_a / e_s >= 0.95_wp ) e_a = 0.95_wp * e_s
1722
1723	DO n = local_start(kp,jp,ip), number_of_particles !only new particles
1724	!
1725	!-- For details on this equation, see Eq. (14) of Khvorostyanov and
1726	!-- Curry (2007, JGR)
1727	particles(n)%radius = bfactor*0.3333333_wp &
1728	particles(n)%aux1 / ( 1.0_wp - e_a / e_s )**0.3333333_wp / &
1729	( 1.0_wp + ( afactor / ( 3.0_wp * bfactor*0.3333333_wp &
1730	particles(n)%aux1 ) ) / &
1731	( 1.0_wp - e_a / e_s )**0.6666666_wp &
1732	)
1733
1734	ENDDO
1735
1736	ENDDO
1737	ENDDO
1738	ENDDO
1739
1740	END SUBROUTINE lpm_init_aerosols
1741
1742
1743	!------------------------------------------------------------------------------!
1744	! Description:
1745	! ------------
1746	!> Calculates quantities required for considering the SGS velocity fluctuations
1747	!> in the particle transport by a stochastic approach. The respective
1748	!> quantities are: SGS-TKE gradients and horizontally averaged profiles of the
1749	!> SGS TKE and the resolved-scale velocity variances.
1750	!------------------------------------------------------------------------------!
1751	SUBROUTINE lpm_init_sgs_tke
1752
1753	USE statistics, &
1754	ONLY: flow_statistics_called, hom, sums, sums_l
1755
1756	INTEGER(iwp) :: i !< index variable along x
1757	INTEGER(iwp) :: j !< index variable along y
1758	INTEGER(iwp) :: k !< index variable along z
1759	INTEGER(iwp) :: m !< running index for the surface elements
1760
1761	REAL(wp) :: flag1 !< flag to mask topography
1762
1763	!
1764	!-- TKE gradient along x and y
1765	DO i = nxl, nxr
1766	DO j = nys, nyn
1767	DO k = nzb, nzt+1
1768
1769	IF ( .NOT. BTEST( wall_flags_total_0(k,j,i-1), 0 ) .AND. &
1770	BTEST( wall_flags_total_0(k,j,i), 0 ) .AND. &
1771	BTEST( wall_flags_total_0(k,j,i+1), 0 ) ) &
1772	THEN
1773	de_dx(k,j,i) = 2.0_wp * sgs_wf_part * &
1774	( e(k,j,i+1) - e(k,j,i) ) * ddx
1775	ELSEIF ( BTEST( wall_flags_total_0(k,j,i-1), 0 ) .AND. &
1776	BTEST( wall_flags_total_0(k,j,i), 0 ) .AND. &
1777	.NOT. BTEST( wall_flags_total_0(k,j,i+1), 0 ) ) &
1778	THEN
1779	de_dx(k,j,i) = 2.0_wp * sgs_wf_part * &
1780	( e(k,j,i) - e(k,j,i-1) ) * ddx
1781	ELSEIF ( .NOT. BTEST( wall_flags_total_0(k,j,i), 22 ) .AND. &
1782	.NOT. BTEST( wall_flags_total_0(k,j,i+1), 22 ) ) &
1783	THEN
1784	de_dx(k,j,i) = 0.0_wp
1785	ELSEIF ( .NOT. BTEST( wall_flags_total_0(k,j,i-1), 22 ) .AND. &
1786	.NOT. BTEST( wall_flags_total_0(k,j,i), 22 ) ) &
1787	THEN
1788	de_dx(k,j,i) = 0.0_wp
1789	ELSE
1790	de_dx(k,j,i) = sgs_wf_part * ( e(k,j,i+1) - e(k,j,i-1) ) * ddx
1791	ENDIF
1792
1793	IF ( .NOT. BTEST( wall_flags_total_0(k,j-1,i), 0 ) .AND. &
1794	BTEST( wall_flags_total_0(k,j,i), 0 ) .AND. &
1795	BTEST( wall_flags_total_0(k,j+1,i), 0 ) ) &
1796	THEN
1797	de_dy(k,j,i) = 2.0_wp * sgs_wf_part * &
1798	( e(k,j+1,i) - e(k,j,i) ) * ddy
1799	ELSEIF ( BTEST( wall_flags_total_0(k,j-1,i), 0 ) .AND. &
1800	BTEST( wall_flags_total_0(k,j,i), 0 ) .AND. &
1801	.NOT. BTEST( wall_flags_total_0(k,j+1,i), 0 ) ) &
1802	THEN
1803	de_dy(k,j,i) = 2.0_wp * sgs_wf_part * &
1804	( e(k,j,i) - e(k,j-1,i) ) * ddy
1805	ELSEIF ( .NOT. BTEST( wall_flags_total_0(k,j,i), 22 ) .AND. &
1806	.NOT. BTEST( wall_flags_total_0(k,j+1,i), 22 ) ) &
1807	THEN
1808	de_dy(k,j,i) = 0.0_wp
1809	ELSEIF ( .NOT. BTEST( wall_flags_total_0(k,j-1,i), 22 ) .AND. &
1810	.NOT. BTEST( wall_flags_total_0(k,j,i), 22 ) ) &
1811	THEN
1812	de_dy(k,j,i) = 0.0_wp
1813	ELSE
1814	de_dy(k,j,i) = sgs_wf_part * ( e(k,j+1,i) - e(k,j-1,i) ) * ddy
1815	ENDIF
1816
1817	ENDDO
1818	ENDDO
1819	ENDDO
1820
1821	!
1822	!-- TKE gradient along z at topograhy and including bottom and top boundary conditions
1823	DO i = nxl, nxr
1824	DO j = nys, nyn
1825	DO k = nzb+1, nzt-1
1826	!
1827	!-- Flag to mask topography
1828	flag1 = MERGE( 1.0_wp, 0.0_wp, BTEST( wall_flags_total_0(k,j,i), 0 ) )
1829
1830	de_dz(k,j,i) = 2.0_wp * sgs_wf_part * &
1831	( e(k+1,j,i) - e(k-1,j,i) ) / ( zu(k+1) - zu(k-1) ) &
1832	* flag1
1833	ENDDO
1834	!
1835	!-- upward-facing surfaces
1836	DO m = bc_h(0)%start_index(j,i), bc_h(0)%end_index(j,i)
1837	k = bc_h(0)%k(m)
1838	de_dz(k,j,i) = 2.0_wp * sgs_wf_part * &
1839	( e(k+1,j,i) - e(k,j,i) ) / ( zu(k+1) - zu(k) )
1840	ENDDO
1841	!
1842	!-- downward-facing surfaces
1843	DO m = bc_h(1)%start_index(j,i), bc_h(1)%end_index(j,i)
1844	k = bc_h(1)%k(m)
1845	de_dz(k,j,i) = 2.0_wp * sgs_wf_part * &
1846	( e(k,j,i) - e(k-1,j,i) ) / ( zu(k) - zu(k-1) )
1847	ENDDO
1848
1849	de_dz(nzb,j,i) = 0.0_wp
1850	de_dz(nzt,j,i) = 0.0_wp
1851	de_dz(nzt+1,j,i) = 0.0_wp
1852	ENDDO
1853	ENDDO
1854	!
1855	!-- Ghost point exchange
1856	CALL exchange_horiz( de_dx, nbgp )
1857	CALL exchange_horiz( de_dy, nbgp )
1858	CALL exchange_horiz( de_dz, nbgp )
1859	CALL exchange_horiz( diss, nbgp )
1860	!
1861	!-- Set boundary conditions at non-periodic boundaries. Note, at non-period
1862	!-- boundaries zero-gradient boundary conditions are set for the subgrid TKE.
1863	!-- Thus, TKE gradients normal to the respective lateral boundaries are zero,
1864	!-- while tangetial TKE gradients then must be the same as within the prognostic
1865	!-- domain.
1866	IF ( bc_dirichlet_l ) THEN
1867	de_dx(:,:,-1) = 0.0_wp
1868	de_dy(:,:,-1) = de_dy(:,:,0)
1869	de_dz(:,:,-1) = de_dz(:,:,0)
1870	ENDIF
1871	IF ( bc_dirichlet_r ) THEN
1872	de_dx(:,:,nxr+1) = 0.0_wp
1873	de_dy(:,:,nxr+1) = de_dy(:,:,nxr)
1874	de_dz(:,:,nxr+1) = de_dz(:,:,nxr)
1875	ENDIF
1876	IF ( bc_dirichlet_n ) THEN
1877	de_dx(:,nyn+1,:) = de_dx(:,nyn,:)
1878	de_dy(:,nyn+1,:) = 0.0_wp
1879	de_dz(:,nyn+1,:) = de_dz(:,nyn,:)
1880	ENDIF
1881	IF ( bc_dirichlet_s ) THEN
1882	de_dx(:,nys-1,:) = de_dx(:,nys,:)
1883	de_dy(:,nys-1,:) = 0.0_wp
1884	de_dz(:,nys-1,:) = de_dz(:,nys,:)
1885	ENDIF
1886	!
1887	!-- Calculate the horizontally averaged profiles of SGS TKE and resolved
1888	!-- velocity variances (they may have been already calculated in routine
1889	!-- flow_statistics).
1890	IF ( .NOT. flow_statistics_called ) THEN
1891
1892	!
1893	!-- First calculate horizontally averaged profiles of the horizontal
1894	!-- velocities.
1895	sums_l(:,1,0) = 0.0_wp
1896	sums_l(:,2,0) = 0.0_wp
1897
1898	DO i = nxl, nxr
1899	DO j = nys, nyn
1900	DO k = nzb, nzt+1
1901	!
1902	!-- Flag indicating vicinity of wall
1903	flag1 = MERGE( 1.0_wp, 0.0_wp, BTEST( wall_flags_total_0(k,j,i), 24 ) )
1904
1905	sums_l(k,1,0) = sums_l(k,1,0) + u(k,j,i) * flag1
1906	sums_l(k,2,0) = sums_l(k,2,0) + v(k,j,i) * flag1
1907	ENDDO
1908	ENDDO
1909	ENDDO
1910
1911	#if defined( __parallel )
1912	!
1913	!-- Compute total sum from local sums
1914	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
1915	CALL MPI_ALLREDUCE( sums_l(nzb,1,0), sums(nzb,1), nzt+2-nzb, &
1916	MPI_REAL, MPI_SUM, comm2d, ierr )
1917	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
1918	CALL MPI_ALLREDUCE( sums_l(nzb,2,0), sums(nzb,2), nzt+2-nzb, &
1919	MPI_REAL, MPI_SUM, comm2d, ierr )
1920	#else
1921	sums(:,1) = sums_l(:,1,0)
1922	sums(:,2) = sums_l(:,2,0)
1923	#endif
1924
1925	!
1926	!-- Final values are obtained by division by the total number of grid
1927	!-- points used for the summation.
1928	hom(:,1,1,0) = sums(:,1) / ngp_2dh_outer(:,0) ! u
1929	hom(:,1,2,0) = sums(:,2) / ngp_2dh_outer(:,0) ! v
1930
1931	!
1932	!-- Now calculate the profiles of SGS TKE and the resolved-scale
1933	!-- velocity variances
1934	sums_l(:,8,0) = 0.0_wp
1935	sums_l(:,30,0) = 0.0_wp
1936	sums_l(:,31,0) = 0.0_wp
1937	sums_l(:,32,0) = 0.0_wp
1938	DO i = nxl, nxr
1939	DO j = nys, nyn
1940	DO k = nzb, nzt+1
1941	!
1942	!-- Flag indicating vicinity of wall
1943	flag1 = MERGE( 1.0_wp, 0.0_wp, BTEST( wall_flags_total_0(k,j,i), 24 ) )
1944
1945	sums_l(k,8,0) = sums_l(k,8,0) + e(k,j,i) * flag1
1946	sums_l(k,30,0) = sums_l(k,30,0) + ( u(k,j,i) - hom(k,1,1,0) )*2 flag1
1947	sums_l(k,31,0) = sums_l(k,31,0) + ( v(k,j,i) - hom(k,1,2,0) )*2 flag1
1948	sums_l(k,32,0) = sums_l(k,32,0) + w(k,j,i)*2 flag1
1949	ENDDO
1950	ENDDO
1951	ENDDO
1952
1953	#if defined( __parallel )
1954	!
1955	!-- Compute total sum from local sums
1956	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
1957	CALL MPI_ALLREDUCE( sums_l(nzb,8,0), sums(nzb,8), nzt+2-nzb, &
1958	MPI_REAL, MPI_SUM, comm2d, ierr )
1959	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
1960	CALL MPI_ALLREDUCE( sums_l(nzb,30,0), sums(nzb,30), nzt+2-nzb, &
1961	MPI_REAL, MPI_SUM, comm2d, ierr )
1962	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
1963	CALL MPI_ALLREDUCE( sums_l(nzb,31,0), sums(nzb,31), nzt+2-nzb, &
1964	MPI_REAL, MPI_SUM, comm2d, ierr )
1965	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
1966	CALL MPI_ALLREDUCE( sums_l(nzb,32,0), sums(nzb,32), nzt+2-nzb, &
1967	MPI_REAL, MPI_SUM, comm2d, ierr )
1968
1969	#else
1970	sums(:,8) = sums_l(:,8,0)
1971	sums(:,30) = sums_l(:,30,0)
1972	sums(:,31) = sums_l(:,31,0)
1973	sums(:,32) = sums_l(:,32,0)
1974	#endif
1975
1976	!
1977	!-- Final values are obtained by division by the total number of grid
1978	!-- points used for the summation.
1979	hom(:,1,8,0) = sums(:,8) / ngp_2dh_outer(:,0) ! e
1980	hom(:,1,30,0) = sums(:,30) / ngp_2dh_outer(:,0) ! u*2
1981	hom(:,1,31,0) = sums(:,31) / ngp_2dh_outer(:,0) ! v*2
1982	hom(:,1,32,0) = sums(:,32) / ngp_2dh_outer(:,0) ! w*2
1983
1984	ENDIF
1985
1986	END SUBROUTINE lpm_init_sgs_tke
1987
1988
1989	!------------------------------------------------------------------------------!
1990	! Description:
1991	! ------------
1992	!> Sobroutine control lpm actions, i.e. all actions during one time step.
1993	!------------------------------------------------------------------------------!
1994	SUBROUTINE lpm_actions( location )
1995
1996	CHARACTER (LEN=*), INTENT(IN) :: location !< call location string
1997
1998	INTEGER(iwp) :: i !<
1999	INTEGER(iwp) :: ie !<
2000	INTEGER(iwp) :: is !<
2001	INTEGER(iwp) :: j !<
2002	INTEGER(iwp) :: je !<
2003	INTEGER(iwp) :: js !<
2004	INTEGER(iwp), SAVE :: lpm_count = 0 !<
2005	INTEGER(iwp) :: k !<
2006	INTEGER(iwp) :: ke !<
2007	INTEGER(iwp) :: ks !<
2008	INTEGER(iwp) :: m !<
2009	INTEGER(iwp), SAVE :: steps = 0 !<
2010
2011	LOGICAL :: first_loop_stride !<
2012
2013
2014	SELECT CASE ( location )
2015
2016	CASE ( 'after_pressure_solver' )
2017	!
2018	!-- The particle model is executed if particle advection start is reached and only at the end
2019	!-- of the intermediate time step loop.
2020	IF ( time_since_reference_point >= particle_advection_start &
2021	.AND. intermediate_timestep_count == intermediate_timestep_count_max ) &
2022	THEN
2023	CALL cpu_log( log_point(25), 'lpm', 'start' )
2024	!
2025	!-- Write particle data at current time on file.
2026	!-- This has to be done here, before particles are further processed,
2027	!-- because they may be deleted within this timestep (in case that
2028	!-- dt_write_particle_data = dt_prel = particle_maximum_age).
2029	time_write_particle_data = time_write_particle_data + dt_3d
2030	IF ( time_write_particle_data >= dt_write_particle_data ) THEN
2031
2032	CALL lpm_data_output_particles
2033	!
2034	!-- The MOD function allows for changes in the output interval with restart
2035	!-- runs.
2036	time_write_particle_data = MOD( time_write_particle_data, &
2037	MAX( dt_write_particle_data, dt_3d ) )
2038	ENDIF
2039
2040	!
2041	!-- Initialize arrays for marking those particles to be deleted after the
2042	!-- (sub-) timestep
2043	deleted_particles = 0
2044
2045	!
2046	!-- Initialize variables used for accumulating the number of particles
2047	!-- xchanged between the subdomains during all sub-timesteps (if sgs
2048	!-- velocities are included). These data are output further below on the
2049	!-- particle statistics file.
2050	trlp_count_sum = 0
2051	trlp_count_recv_sum = 0
2052	trrp_count_sum = 0
2053	trrp_count_recv_sum = 0
2054	trsp_count_sum = 0
2055	trsp_count_recv_sum = 0
2056	trnp_count_sum = 0
2057	trnp_count_recv_sum = 0
2058	!
2059	!-- Calculate exponential term used in case of particle inertia for each
2060	!-- of the particle groups
2061	DO m = 1, number_of_particle_groups
2062	IF ( particle_groups(m)%density_ratio /= 0.0_wp ) THEN
2063	particle_groups(m)%exp_arg = &
2064	4.5_wp * particle_groups(m)%density_ratio * &
2065	molecular_viscosity / ( particle_groups(m)%radius )**2
2066
2067	particle_groups(m)%exp_term = EXP( -particle_groups(m)%exp_arg * &
2068	dt_3d )
2069	ENDIF
2070	ENDDO
2071	!
2072	!-- If necessary, release new set of particles
2073	IF ( ( simulated_time - last_particle_release_time ) >= dt_prel .AND. &
2074	end_time_prel > simulated_time ) THEN
2075	DO WHILE ( ( simulated_time - last_particle_release_time ) >= dt_prel )
2076	CALL lpm_create_particle( PHASE_RELEASE )
2077	last_particle_release_time = last_particle_release_time + dt_prel
2078	ENDDO
2079	ENDIF
2080	!
2081	!-- Reset summation arrays
2082	IF ( cloud_droplets ) THEN
2083	ql_c = 0.0_wp
2084	ql_v = 0.0_wp
2085	ql_vp = 0.0_wp
2086	ENDIF
2087
2088	first_loop_stride = .TRUE.
2089	grid_particles(:,:,:)%time_loop_done = .TRUE.
2090	!
2091	!-- Timestep loop for particle advection.
2092	!-- This loop has to be repeated until the advection time of every particle
2093	!-- (within the total domain!) has reached the LES timestep (dt_3d).
2094	!-- In case of including the SGS velocities, the particle timestep may be
2095	!-- smaller than the LES timestep (because of the Lagrangian timescale
2096	!-- restriction) and particles may require to undergo several particle
2097	!-- timesteps, before the LES timestep is reached. Because the number of these
2098	!-- particle timesteps to be carried out is unknown at first, these steps are
2099	!-- carried out in the following infinite loop with exit condition.
2100	DO
2101	CALL cpu_log( log_point_s(44), 'lpm_advec', 'start' )
2102	CALL cpu_log( log_point_s(44), 'lpm_advec', 'pause' )
2103
2104	!
2105	!-- If particle advection includes SGS velocity components, calculate the
2106	!-- required SGS quantities (i.e. gradients of the TKE, as well as
2107	!-- horizontally averaged profiles of the SGS TKE and the resolved-scale
2108	!-- velocity variances)
2109	IF ( use_sgs_for_particles .AND. .NOT. cloud_droplets ) THEN
2110	CALL lpm_init_sgs_tke
2111	ENDIF
2112	!
2113	!-- In case SGS-particle speed is considered, particles may carry out
2114	!-- several particle timesteps. In order to prevent unnecessary
2115	!-- treatment of particles that already reached the final time level,
2116	!-- particles are sorted into contiguous blocks of finished and
2117	!-- not-finished particles, in addition to their already sorting
2118	!-- according to their sub-boxes.
2119	IF ( .NOT. first_loop_stride .AND. use_sgs_for_particles ) &
2120	CALL lpm_sort_timeloop_done
2121	DO i = nxl, nxr
2122	DO j = nys, nyn
2123	DO k = nzb+1, nzt
2124
2125	number_of_particles = prt_count(k,j,i)
2126	!
2127	!-- If grid cell gets empty, flag must be true
2128	IF ( number_of_particles <= 0 ) THEN
2129	grid_particles(k,j,i)%time_loop_done = .TRUE.
2130	CYCLE
2131	ENDIF
2132
2133	IF ( .NOT. first_loop_stride .AND. &
2134	grid_particles(k,j,i)%time_loop_done ) CYCLE
2135
2136	particles => grid_particles(k,j,i)%particles(1:number_of_particles)
2137
2138	particles(1:number_of_particles)%particle_mask = .TRUE.
2139	!
2140	!-- Initialize the variable storing the total time that a particle
2141	!-- has advanced within the timestep procedure
2142	IF ( first_loop_stride ) THEN
2143	particles(1:number_of_particles)%dt_sum = 0.0_wp
2144	ENDIF
2145	!
2146	!-- Particle (droplet) growth by condensation/evaporation and
2147	!-- collision
2148	IF ( cloud_droplets .AND. first_loop_stride) THEN
2149	!
2150	!-- Droplet growth by condensation / evaporation
2151	CALL lpm_droplet_condensation(i,j,k)
2152	!
2153	!-- Particle growth by collision
2154	IF ( collision_kernel /= 'none' ) THEN
2155	CALL lpm_droplet_collision(i,j,k)
2156	ENDIF
2157
2158	ENDIF
2159	!
2160	!-- Initialize the switch used for the loop exit condition checked
2161	!-- at the end of this loop. If at least one particle has failed to
2162	!-- reach the LES timestep, this switch will be set false in
2163	!-- lpm_advec.
2164	dt_3d_reached_l = .TRUE.
2165
2166	!
2167	!-- Particle advection
2168	CALL lpm_advec( i, j, k )
2169	!
2170	!-- Particle reflection from walls. Only applied if the particles
2171	!-- are in the vertical range of the topography. (Here, some
2172	!-- optimization is still possible.)
2173	IF ( topography /= 'flat' .AND. k < nzb_max + 2 ) THEN
2174	CALL lpm_boundary_conds( 'walls', i, j, k )
2175	ENDIF
2176	!
2177	!-- User-defined actions after the calculation of the new particle
2178	!-- position
2179	CALL user_lpm_advec( i, j, k )
2180	!
2181	!-- Apply boundary conditions to those particles that have crossed
2182	!-- the top or bottom boundary and delete those particles, which are
2183	!-- older than allowed
2184	CALL lpm_boundary_conds( 'bottom/top', i, j, k )
2185	!
2186	!--- If not all particles of the actual grid cell have reached the
2187	!-- LES timestep, this cell has to do another loop iteration. Due to
2188	!-- the fact that particles can move into neighboring grid cells,
2189	!-- these neighbor cells also have to perform another loop iteration.
2190	!-- Please note, this realization does not work properly if
2191	!-- particles move into another subdomain.
2192	IF ( .NOT. dt_3d_reached_l ) THEN
2193	ks = MAX(nzb+1,k-1)
2194	ke = MIN(nzt,k+1)
2195	js = MAX(nys,j-1)
2196	je = MIN(nyn,j+1)
2197	is = MAX(nxl,i-1)
2198	ie = MIN(nxr,i+1)
2199	grid_particles(ks:ke,js:je,is:ie)%time_loop_done = .FALSE.
2200	ELSE
2201	grid_particles(k,j,i)%time_loop_done = .TRUE.
2202	ENDIF
2203
2204	ENDDO
2205	ENDDO
2206	ENDDO
2207	steps = steps + 1
2208	dt_3d_reached_l = ALL(grid_particles(:,:,:)%time_loop_done)
2209	!
2210	!-- Find out, if all particles on every PE have completed the LES timestep
2211	!-- and set the switch corespondingly
2212	#if defined( __parallel )
2213	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
2214	CALL MPI_ALLREDUCE( dt_3d_reached_l, dt_3d_reached, 1, MPI_LOGICAL, &
2215	MPI_LAND, comm2d, ierr )
2216	#else
2217	dt_3d_reached = dt_3d_reached_l
2218	#endif
2219	CALL cpu_log( log_point_s(44), 'lpm_advec', 'stop' )
2220
2221	!
2222	!-- Apply splitting and merging algorithm
2223	IF ( cloud_droplets ) THEN
2224	IF ( splitting ) THEN
2225	CALL lpm_splitting
2226	ENDIF
2227	IF ( merging ) THEN
2228	CALL lpm_merging
2229	ENDIF
2230	ENDIF
2231	!
2232	!-- Move Particles local to PE to a different grid cell
2233	CALL lpm_move_particle
2234	!
2235	!-- Horizontal boundary conditions including exchange between subdmains
2236	CALL lpm_exchange_horiz
2237
2238	!
2239	!-- IF .FALSE., lpm_sort_and_delete is done inside pcmp
2240	IF ( .NOT. dt_3d_reached .OR. .NOT. nested_run ) THEN
2241	!
2242	!-- Pack particles (eliminate those marked for deletion),
2243	!-- determine new number of particles
2244	CALL lpm_sort_and_delete
2245
2246	!-- Initialize variables for the next (sub-) timestep, i.e., for marking
2247	!-- those particles to be deleted after the timestep
2248	deleted_particles = 0
2249	ENDIF
2250
2251	IF ( dt_3d_reached ) EXIT
2252
2253	first_loop_stride = .FALSE.
2254	ENDDO ! timestep loop
2255	!
2256	!-- in case of nested runs do the transfer of particles after every full model time step
2257	IF ( nested_run ) THEN
2258	CALL particles_from_parent_to_child
2259	CALL particles_from_child_to_parent
2260	CALL pmcp_p_delete_particles_in_fine_grid_area
2261
2262	CALL lpm_sort_and_delete
2263
2264	deleted_particles = 0
2265	ENDIF
2266
2267	!
2268	!-- Calculate the new liquid water content for each grid box
2269	IF ( cloud_droplets ) CALL lpm_calc_liquid_water_content
2270
2271	!
2272	!-- At the end all arrays are exchanged
2273	IF ( cloud_droplets ) THEN
2274	CALL exchange_horiz( ql, nbgp )
2275	CALL exchange_horiz( ql_c, nbgp )
2276	CALL exchange_horiz( ql_v, nbgp )
2277	CALL exchange_horiz( ql_vp, nbgp )
2278	ENDIF
2279
2280	!
2281	!-- Deallocate unused memory
2282	IF ( deallocate_memory .AND. lpm_count == step_dealloc ) THEN
2283	CALL dealloc_particles_array
2284	lpm_count = 0
2285	ELSEIF ( deallocate_memory ) THEN
2286	lpm_count = lpm_count + 1
2287	ENDIF
2288
2289	!
2290	!-- Write particle statistics (in particular the number of particles
2291	!-- exchanged between the subdomains) on file
2292	IF ( write_particle_statistics ) CALL lpm_write_exchange_statistics
2293	!
2294	!-- Execute Interactions of condnesation and evaporation to humidity and
2295	!-- temperature field
2296	IF ( cloud_droplets ) THEN
2297	CALL lpm_interaction_droplets_ptq
2298	CALL exchange_horiz( pt, nbgp )
2299	CALL exchange_horiz( q, nbgp )
2300	ENDIF
2301
2302	CALL cpu_log( log_point(25), 'lpm', 'stop' )
2303
2304	! !
2305	! !-- Output of particle time series
2306	! IF ( particle_advection ) THEN
2307	! IF ( time_dopts >= dt_dopts .OR. &
2308	! ( time_since_reference_point >= particle_advection_start .AND. &
2309	! first_call_lpm ) ) THEN
2310	! CALL lpm_data_output_ptseries
2311	! time_dopts = MOD( time_dopts, MAX( dt_dopts, dt_3d ) )
2312	! ENDIF
2313	! ENDIF
2314
2315	!
2316	!-- Set this switch to .false. @todo: maybe find better solution.
2317	first_call_lpm = .FALSE.
2318	ENDIF! ENDIF statement of lpm_actions('after_pressure_solver')
2319
2320	CASE ( 'after_integration' )
2321	!
2322	!-- Call at the end of timestep routine to save particle velocities fields
2323	!-- for the next timestep
2324	CALL lpm_swap_timelevel_for_particle_advection
2325
2326	CASE DEFAULT
2327	CONTINUE
2328
2329	END SELECT
2330
2331	END SUBROUTINE lpm_actions
2332
2333
2334	!------------------------------------------------------------------------------!
2335	! Description:
2336	! ------------
2337	!
2338	!------------------------------------------------------------------------------!
2339	SUBROUTINE particles_from_parent_to_child
2340	IMPLICIT NONE
2341
2342	CALL pmcp_c_get_particle_from_parent ! Child actions
2343	CALL pmcp_p_fill_particle_win ! Parent actions
2344
2345	RETURN
2346	END SUBROUTINE particles_from_parent_to_child
2347
2348
2349	!------------------------------------------------------------------------------!
2350	! Description:
2351	! ------------
2352	!
2353	!------------------------------------------------------------------------------!
2354	SUBROUTINE particles_from_child_to_parent
2355	IMPLICIT NONE
2356
2357	CALL pmcp_c_send_particle_to_parent ! Child actions
2358	CALL pmcp_p_empty_particle_win ! Parent actions
2359
2360	RETURN
2361	END SUBROUTINE particles_from_child_to_parent
2362
2363	!------------------------------------------------------------------------------!
2364	! Description:
2365	! ------------
2366	!> This routine write exchange statistics of the lpm in a ascii file.
2367	!------------------------------------------------------------------------------!
2368	SUBROUTINE lpm_write_exchange_statistics
2369
2370	INTEGER(iwp) :: ip !<
2371	INTEGER(iwp) :: jp !<
2372	INTEGER(iwp) :: kp !<
2373	INTEGER(iwp) :: tot_number_of_particles !<
2374
2375	!
2376	!-- Determine the current number of particles
2377	number_of_particles = 0
2378	DO ip = nxl, nxr
2379	DO jp = nys, nyn
2380	DO kp = nzb+1, nzt
2381	number_of_particles = number_of_particles &
2382	+ prt_count(kp,jp,ip)
2383	ENDDO
2384	ENDDO
2385	ENDDO
2386
2387	CALL check_open( 80 )
2388	#if defined( __parallel )
2389	WRITE ( 80, 8000 ) current_timestep_number+1, simulated_time+dt_3d, &
2390	number_of_particles, pleft, trlp_count_sum, &
2391	trlp_count_recv_sum, pright, trrp_count_sum, &
2392	trrp_count_recv_sum, psouth, trsp_count_sum, &
2393	trsp_count_recv_sum, pnorth, trnp_count_sum, &
2394	trnp_count_recv_sum
2395	#else
2396	WRITE ( 80, 8000 ) current_timestep_number+1, simulated_time+dt_3d, &
2397	number_of_particles
2398	#endif
2399	CALL close_file( 80 )
2400
2401	IF ( number_of_particles > 0 ) THEN
2402	WRITE(9,*) 'number_of_particles ', number_of_particles, &
2403	current_timestep_number + 1, simulated_time + dt_3d
2404	ENDIF
2405
2406	#if defined( __parallel )
2407	CALL MPI_ALLREDUCE( number_of_particles, tot_number_of_particles, 1, &
2408	MPI_INTEGER, MPI_SUM, comm2d, ierr )
2409	#else
2410	tot_number_of_particles = number_of_particles
2411	#endif
2412
2413	IF ( nested_run ) THEN
2414	CALL pmcp_g_print_number_of_particles( simulated_time+dt_3d, &
2415	tot_number_of_particles)
2416	ENDIF
2417
2418	!
2419	!-- Formats
2420	8000 FORMAT (I6,1X,F7.2,4X,I10,5X,4(I3,1X,I4,'/',I4,2X),6X,I10)
2421
2422
2423	END SUBROUTINE lpm_write_exchange_statistics
2424
2425
2426	!------------------------------------------------------------------------------!
2427	! Description:
2428	! ------------
2429	!> Write particle data in FORTRAN binary and/or netCDF format
2430	!------------------------------------------------------------------------------!
2431	SUBROUTINE lpm_data_output_particles
2432
2433	INTEGER(iwp) :: ip !<
2434	INTEGER(iwp) :: jp !<
2435	INTEGER(iwp) :: kp !<
2436
2437	CALL cpu_log( log_point_s(40), 'lpm_data_output', 'start' )
2438
2439	!
2440	!-- Attention: change version number for unit 85 (in routine check_open)
2441	!-- whenever the output format for this unit is changed!
2442	CALL check_open( 85 )
2443
2444	WRITE ( 85 ) simulated_time
2445	WRITE ( 85 ) prt_count
2446
2447	DO ip = nxl, nxr
2448	DO jp = nys, nyn
2449	DO kp = nzb+1, nzt
2450	number_of_particles = prt_count(kp,jp,ip)
2451	particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
2452	IF ( number_of_particles <= 0 ) CYCLE
2453	WRITE ( 85 ) particles
2454	ENDDO
2455	ENDDO
2456	ENDDO
2457
2458	CALL close_file( 85 )
2459
2460
2461	#if defined( __netcdf )
2462	! !
2463	! !-- Output in netCDF format
2464	! CALL check_open( 108 )
2465	!
2466	! !
2467	! !-- Update the NetCDF time axis
2468	! prt_time_count = prt_time_count + 1
2469	!
2470	! nc_stat = NF90_PUT_VAR( id_set_prt, id_var_time_prt, &
2471	! (/ simulated_time /), &
2472	! start = (/ prt_time_count /), count = (/ 1 /) )
2473	! CALL netcdf_handle_error( 'lpm_data_output_particles', 1 )
2474	!
2475	! !
2476	! !-- Output the real number of particles used
2477	! nc_stat = NF90_PUT_VAR( id_set_prt, id_var_rnop_prt, &
2478	! (/ number_of_particles /), &
2479	! start = (/ prt_time_count /), count = (/ 1 /) )
2480	! CALL netcdf_handle_error( 'lpm_data_output_particles', 2 )
2481	!
2482	! !
2483	! !-- Output all particle attributes
2484	! nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(1), particles%age, &
2485	! start = (/ 1, prt_time_count /), &
2486	! count = (/ maximum_number_of_particles /) )
2487	! CALL netcdf_handle_error( 'lpm_data_output_particles', 3 )
2488	!
2489	! nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(2), particles%user, &
2490	! start = (/ 1, prt_time_count /), &
2491	! count = (/ maximum_number_of_particles /) )
2492	! CALL netcdf_handle_error( 'lpm_data_output_particles', 4 )
2493	!
2494	! nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(3), particles%origin_x, &
2495	! start = (/ 1, prt_time_count /), &
2496	! count = (/ maximum_number_of_particles /) )
2497	! CALL netcdf_handle_error( 'lpm_data_output_particles', 5 )
2498	!
2499	! nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(4), particles%origin_y, &
2500	! start = (/ 1, prt_time_count /), &
2501	! count = (/ maximum_number_of_particles /) )
2502	! CALL netcdf_handle_error( 'lpm_data_output_particles', 6 )
2503	!
2504	! nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(5), particles%origin_z, &
2505	! start = (/ 1, prt_time_count /), &
2506	! count = (/ maximum_number_of_particles /) )
2507	! CALL netcdf_handle_error( 'lpm_data_output_particles', 7 )
2508	!
2509	! nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(6), particles%radius, &
2510	! start = (/ 1, prt_time_count /), &
2511	! count = (/ maximum_number_of_particles /) )
2512	! CALL netcdf_handle_error( 'lpm_data_output_particles', 8 )
2513	!
2514	! nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(7), particles%speed_x, &
2515	! start = (/ 1, prt_time_count /), &
2516	! count = (/ maximum_number_of_particles /) )
2517	! CALL netcdf_handle_error( 'lpm_data_output_particles', 9 )
2518	!
2519	! nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(8), particles%speed_y, &
2520	! start = (/ 1, prt_time_count /), &
2521	! count = (/ maximum_number_of_particles /) )
2522	! CALL netcdf_handle_error( 'lpm_data_output_particles', 10 )
2523	!
2524	! nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(9), particles%speed_z, &
2525	! start = (/ 1, prt_time_count /), &
2526	! count = (/ maximum_number_of_particles /) )
2527	! CALL netcdf_handle_error( 'lpm_data_output_particles', 11 )
2528	!
2529	! nc_stat = NF90_PUT_VAR( id_set_prt,id_var_prt(10), &
2530	! particles%weight_factor, &
2531	! start = (/ 1, prt_time_count /), &
2532	! count = (/ maximum_number_of_particles /) )
2533	! CALL netcdf_handle_error( 'lpm_data_output_particles', 12 )
2534	!
2535	! nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(11), particles%x, &
2536	! start = (/ 1, prt_time_count /), &
2537	! count = (/ maximum_number_of_particles /) )
2538	! CALL netcdf_handle_error( 'lpm_data_output_particles', 13 )
2539	!
2540	! nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(12), particles%y, &
2541	! start = (/ 1, prt_time_count /), &
2542	! count = (/ maximum_number_of_particles /) )
2543	! CALL netcdf_handle_error( 'lpm_data_output_particles', 14 )
2544	!
2545	! nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(13), particles%z, &
2546	! start = (/ 1, prt_time_count /), &
2547	! count = (/ maximum_number_of_particles /) )
2548	! CALL netcdf_handle_error( 'lpm_data_output_particles', 15 )
2549	!
2550	! nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(14), particles%class, &
2551	! start = (/ 1, prt_time_count /), &
2552	! count = (/ maximum_number_of_particles /) )
2553	! CALL netcdf_handle_error( 'lpm_data_output_particles', 16 )
2554	!
2555	! nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(15), particles%group, &
2556	! start = (/ 1, prt_time_count /), &
2557	! count = (/ maximum_number_of_particles /) )
2558	! CALL netcdf_handle_error( 'lpm_data_output_particles', 17 )
2559	!
2560	! nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(16), &
2561	! particles%id2, &
2562	! start = (/ 1, prt_time_count /), &
2563	! count = (/ maximum_number_of_particles /) )
2564	! CALL netcdf_handle_error( 'lpm_data_output_particles', 18 )
2565	!
2566	! nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(17), particles%id1, &
2567	! start = (/ 1, prt_time_count /), &
2568	! count = (/ maximum_number_of_particles /) )
2569	! CALL netcdf_handle_error( 'lpm_data_output_particles', 19 )
2570	!
2571	#endif
2572
2573	CALL cpu_log( log_point_s(40), 'lpm_data_output', 'stop' )
2574
2575	END SUBROUTINE lpm_data_output_particles
2576
2577	!------------------------------------------------------------------------------!
2578	! Description:
2579	! ------------
2580	!> This routine calculates and provide particle timeseries output.
2581	!------------------------------------------------------------------------------!
2582	SUBROUTINE lpm_data_output_ptseries
2583
2584	INTEGER(iwp) :: i !<
2585	INTEGER(iwp) :: inum !<
2586	INTEGER(iwp) :: j !<
2587	INTEGER(iwp) :: jg !<
2588	INTEGER(iwp) :: k !<
2589	INTEGER(iwp) :: n !<
2590
2591	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: pts_value !<
2592	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: pts_value_l !<
2593
2594
2595	CALL cpu_log( log_point(36), 'data_output_ptseries', 'start' )
2596
2597	IF ( myid == 0 ) THEN
2598	!
2599	!-- Open file for time series output in NetCDF format
2600	dopts_time_count = dopts_time_count + 1
2601	CALL check_open( 109 )
2602	#if defined( __netcdf )
2603	!
2604	!-- Update the particle time series time axis
2605	nc_stat = NF90_PUT_VAR( id_set_pts, id_var_time_pts, &
2606	(/ time_since_reference_point /), &
2607	start = (/ dopts_time_count /), count = (/ 1 /) )
2608	CALL netcdf_handle_error( 'data_output_ptseries', 391 )
2609	#endif
2610
2611	ENDIF
2612
2613	ALLOCATE( pts_value(0:number_of_particle_groups,dopts_num), &
2614	pts_value_l(0:number_of_particle_groups,dopts_num) )
2615
2616	pts_value_l = 0.0_wp
2617	pts_value_l(:,16) = 9999999.9_wp ! for calculation of minimum radius
2618
2619	!
2620	!-- Calculate or collect the particle time series quantities for all particles
2621	!-- and seperately for each particle group (if there is more than one group)
2622	DO i = nxl, nxr
2623	DO j = nys, nyn
2624	DO k = nzb, nzt
2625	number_of_particles = prt_count(k,j,i)
2626	IF (number_of_particles <= 0) CYCLE
2627	particles => grid_particles(k,j,i)%particles(1:number_of_particles)
2628	DO n = 1, number_of_particles
2629
2630	IF ( particles(n)%particle_mask ) THEN ! Restrict analysis to active particles
2631
2632	pts_value_l(0,1) = pts_value_l(0,1) + 1.0_wp ! total # of particles
2633	pts_value_l(0,2) = pts_value_l(0,2) + &
2634	( particles(n)%x - particles(n)%origin_x ) ! mean x
2635	pts_value_l(0,3) = pts_value_l(0,3) + &
2636	( particles(n)%y - particles(n)%origin_y ) ! mean y
2637	pts_value_l(0,4) = pts_value_l(0,4) + &
2638	( particles(n)%z - particles(n)%origin_z ) ! mean z
2639	pts_value_l(0,5) = pts_value_l(0,5) + particles(n)%z ! mean z (absolute)
2640	pts_value_l(0,6) = pts_value_l(0,6) + particles(n)%speed_x ! mean u
2641	pts_value_l(0,7) = pts_value_l(0,7) + particles(n)%speed_y ! mean v
2642	pts_value_l(0,8) = pts_value_l(0,8) + particles(n)%speed_z ! mean w
2643	pts_value_l(0,9) = pts_value_l(0,9) + particles(n)%rvar1 ! mean sgsu
2644	pts_value_l(0,10) = pts_value_l(0,10) + particles(n)%rvar2 ! mean sgsv
2645	pts_value_l(0,11) = pts_value_l(0,11) + particles(n)%rvar3 ! mean sgsw
2646	IF ( particles(n)%speed_z > 0.0_wp ) THEN
2647	pts_value_l(0,12) = pts_value_l(0,12) + 1.0_wp ! # of upward moving prts
2648	pts_value_l(0,13) = pts_value_l(0,13) + &
2649	particles(n)%speed_z ! mean w upw.
2650	ELSE
2651	pts_value_l(0,14) = pts_value_l(0,14) + &
2652	particles(n)%speed_z ! mean w down
2653	ENDIF
2654	pts_value_l(0,15) = pts_value_l(0,15) + particles(n)%radius ! mean rad
2655	pts_value_l(0,16) = MIN( pts_value_l(0,16), particles(n)%radius ) ! minrad
2656	pts_value_l(0,17) = MAX( pts_value_l(0,17), particles(n)%radius ) ! maxrad
2657	pts_value_l(0,18) = pts_value_l(0,18) + 1.0_wp
2658	pts_value_l(0,19) = pts_value_l(0,18) + 1.0_wp
2659	!
2660	!-- Repeat the same for the respective particle group
2661	IF ( number_of_particle_groups > 1 ) THEN
2662	jg = particles(n)%group
2663
2664	pts_value_l(jg,1) = pts_value_l(jg,1) + 1.0_wp
2665	pts_value_l(jg,2) = pts_value_l(jg,2) + &
2666	( particles(n)%x - particles(n)%origin_x )
2667	pts_value_l(jg,3) = pts_value_l(jg,3) + &
2668	( particles(n)%y - particles(n)%origin_y )
2669	pts_value_l(jg,4) = pts_value_l(jg,4) + &
2670	( particles(n)%z - particles(n)%origin_z )
2671	pts_value_l(jg,5) = pts_value_l(jg,5) + particles(n)%z
2672	pts_value_l(jg,6) = pts_value_l(jg,6) + particles(n)%speed_x
2673	pts_value_l(jg,7) = pts_value_l(jg,7) + particles(n)%speed_y
2674	pts_value_l(jg,8) = pts_value_l(jg,8) + particles(n)%speed_z
2675	pts_value_l(jg,9) = pts_value_l(jg,9) + particles(n)%rvar1
2676	pts_value_l(jg,10) = pts_value_l(jg,10) + particles(n)%rvar2
2677	pts_value_l(jg,11) = pts_value_l(jg,11) + particles(n)%rvar3
2678	IF ( particles(n)%speed_z > 0.0_wp ) THEN
2679	pts_value_l(jg,12) = pts_value_l(jg,12) + 1.0_wp
2680	pts_value_l(jg,13) = pts_value_l(jg,13) + particles(n)%speed_z
2681	ELSE
2682	pts_value_l(jg,14) = pts_value_l(jg,14) + particles(n)%speed_z
2683	ENDIF
2684	pts_value_l(jg,15) = pts_value_l(jg,15) + particles(n)%radius
2685	pts_value_l(jg,16) = MIN( pts_value_l(jg,16), particles(n)%radius )
2686	pts_value_l(jg,17) = MAX( pts_value_l(jg,17), particles(n)%radius )
2687	pts_value_l(jg,18) = pts_value_l(jg,18) + 1.0_wp
2688	pts_value_l(jg,19) = pts_value_l(jg,19) + 1.0_wp
2689	ENDIF
2690
2691	ENDIF
2692
2693	ENDDO
2694
2695	ENDDO
2696	ENDDO
2697	ENDDO
2698
2699
2700	#if defined( __parallel )
2701	!
2702	!-- Sum values of the subdomains
2703	inum = number_of_particle_groups + 1
2704
2705	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
2706	CALL MPI_ALLREDUCE( pts_value_l(0,1), pts_value(0,1), 15*inum, MPI_REAL, &
2707	MPI_SUM, comm2d, ierr )
2708	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
2709	CALL MPI_ALLREDUCE( pts_value_l(0,16), pts_value(0,16), inum, MPI_REAL, &
2710	MPI_MIN, comm2d, ierr )
2711	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
2712	CALL MPI_ALLREDUCE( pts_value_l(0,17), pts_value(0,17), inum, MPI_REAL, &
2713	MPI_MAX, comm2d, ierr )
2714	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
2715	CALL MPI_ALLREDUCE( pts_value_l(0,18), pts_value(0,18), inum, MPI_REAL, &
2716	MPI_MAX, comm2d, ierr )
2717	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
2718	CALL MPI_ALLREDUCE( pts_value_l(0,19), pts_value(0,19), inum, MPI_REAL, &
2719	MPI_MIN, comm2d, ierr )
2720	#else
2721	pts_value(:,1:19) = pts_value_l(:,1:19)
2722	#endif
2723
2724	!
2725	!-- Normalize the above calculated quantities (except min/max values) with the
2726	!-- total number of particles
2727	IF ( number_of_particle_groups > 1 ) THEN
2728	inum = number_of_particle_groups
2729	ELSE
2730	inum = 0
2731	ENDIF
2732
2733	DO j = 0, inum
2734
2735	IF ( pts_value(j,1) > 0.0_wp ) THEN
2736
2737	pts_value(j,2:15) = pts_value(j,2:15) / pts_value(j,1)
2738	IF ( pts_value(j,12) > 0.0_wp .AND. pts_value(j,12) < 1.0_wp ) THEN
2739	pts_value(j,13) = pts_value(j,13) / pts_value(j,12)
2740	pts_value(j,14) = pts_value(j,14) / ( 1.0_wp - pts_value(j,12) )
2741	ELSEIF ( pts_value(j,12) == 0.0_wp ) THEN
2742	pts_value(j,13) = -1.0_wp
2743	ELSE
2744	pts_value(j,14) = -1.0_wp
2745	ENDIF
2746
2747	ENDIF
2748
2749	ENDDO
2750
2751	!
2752	!-- Calculate higher order moments of particle time series quantities,
2753	!-- seperately for each particle group (if there is more than one group)
2754	DO i = nxl, nxr
2755	DO j = nys, nyn
2756	DO k = nzb, nzt
2757	number_of_particles = prt_count(k,j,i)
2758	IF (number_of_particles <= 0) CYCLE
2759	particles => grid_particles(k,j,i)%particles(1:number_of_particles)
2760	DO n = 1, number_of_particles
2761
2762	pts_value_l(0,20) = pts_value_l(0,20) + ( particles(n)%x - &
2763	particles(n)%origin_x - pts_value(0,2) )*2 ! x2
2764	pts_value_l(0,21) = pts_value_l(0,21) + ( particles(n)%y - &
2765	particles(n)%origin_y - pts_value(0,3) )*2 ! y2
2766	pts_value_l(0,22) = pts_value_l(0,22) + ( particles(n)%z - &
2767	particles(n)%origin_z - pts_value(0,4) )*2 ! z2
2768	pts_value_l(0,23) = pts_value_l(0,23) + ( particles(n)%speed_x - &
2769	pts_value(0,6) )*2 ! u2
2770	pts_value_l(0,24) = pts_value_l(0,24) + ( particles(n)%speed_y - &
2771	pts_value(0,7) )*2 ! v2
2772	pts_value_l(0,25) = pts_value_l(0,25) + ( particles(n)%speed_z - &
2773	pts_value(0,8) )*2 ! w2
2774	pts_value_l(0,26) = pts_value_l(0,26) + ( particles(n)%rvar1 - &
2775	pts_value(0,9) )**2 ! u"2
2776	pts_value_l(0,27) = pts_value_l(0,27) + ( particles(n)%rvar2 - &
2777	pts_value(0,10) )**2 ! v"2
2778	pts_value_l(0,28) = pts_value_l(0,28) + ( particles(n)%rvar3 - &
2779	pts_value(0,11) )**2 ! w"2
2780	!
2781	!-- Repeat the same for the respective particle group
2782	IF ( number_of_particle_groups > 1 ) THEN
2783	jg = particles(n)%group
2784
2785	pts_value_l(jg,20) = pts_value_l(jg,20) + ( particles(n)%x - &
2786	particles(n)%origin_x - pts_value(jg,2) )**2
2787	pts_value_l(jg,21) = pts_value_l(jg,21) + ( particles(n)%y - &
2788	particles(n)%origin_y - pts_value(jg,3) )**2
2789	pts_value_l(jg,22) = pts_value_l(jg,22) + ( particles(n)%z - &
2790	particles(n)%origin_z - pts_value(jg,4) )**2
2791	pts_value_l(jg,23) = pts_value_l(jg,23) + ( particles(n)%speed_x - &
2792	pts_value(jg,6) )**2
2793	pts_value_l(jg,24) = pts_value_l(jg,24) + ( particles(n)%speed_y - &
2794	pts_value(jg,7) )**2
2795	pts_value_l(jg,25) = pts_value_l(jg,25) + ( particles(n)%speed_z - &
2796	pts_value(jg,8) )**2
2797	pts_value_l(jg,26) = pts_value_l(jg,26) + ( particles(n)%rvar1 - &
2798	pts_value(jg,9) )**2
2799	pts_value_l(jg,27) = pts_value_l(jg,27) + ( particles(n)%rvar2 - &
2800	pts_value(jg,10) )**2
2801	pts_value_l(jg,28) = pts_value_l(jg,28) + ( particles(n)%rvar3 - &
2802	pts_value(jg,11) )**2
2803	ENDIF
2804
2805	ENDDO
2806	ENDDO
2807	ENDDO
2808	ENDDO
2809
2810	pts_value_l(0,29) = ( number_of_particles - pts_value(0,1) / numprocs )**2
2811	! variance of particle numbers
2812	IF ( number_of_particle_groups > 1 ) THEN
2813	DO j = 1, number_of_particle_groups
2814	pts_value_l(j,29) = ( pts_value_l(j,1) - &
2815	pts_value(j,1) / numprocs )**2
2816	ENDDO
2817	ENDIF
2818
2819	#if defined( __parallel )
2820	!
2821	!-- Sum values of the subdomains
2822	inum = number_of_particle_groups + 1
2823
2824	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
2825	CALL MPI_ALLREDUCE( pts_value_l(0,20), pts_value(0,20), inum*10, MPI_REAL, &
2826	MPI_SUM, comm2d, ierr )
2827	#else
2828	pts_value(:,20:29) = pts_value_l(:,20:29)
2829	#endif
2830
2831	!
2832	!-- Normalize the above calculated quantities with the total number of
2833	!-- particles
2834	IF ( number_of_particle_groups > 1 ) THEN
2835	inum = number_of_particle_groups
2836	ELSE
2837	inum = 0
2838	ENDIF
2839
2840	DO j = 0, inum
2841
2842	IF ( pts_value(j,1) > 0.0_wp ) THEN
2843	pts_value(j,20:28) = pts_value(j,20:28) / pts_value(j,1)
2844	ENDIF
2845	pts_value(j,29) = pts_value(j,29) / numprocs
2846
2847	ENDDO
2848
2849	#if defined( __netcdf )
2850	!
2851	!-- Output particle time series quantities in NetCDF format
2852	IF ( myid == 0 ) THEN
2853	DO j = 0, inum
2854	DO i = 1, dopts_num
2855	nc_stat = NF90_PUT_VAR( id_set_pts, id_var_dopts(i,j), &
2856	(/ pts_value(j,i) /), &
2857	start = (/ dopts_time_count /), &
2858	count = (/ 1 /) )
2859	CALL netcdf_handle_error( 'data_output_ptseries', 392 )
2860	ENDDO
2861	ENDDO
2862	ENDIF
2863	#endif
2864
2865	DEALLOCATE( pts_value, pts_value_l )
2866
2867	CALL cpu_log( log_point(36), 'data_output_ptseries', 'stop' )
2868
2869	END SUBROUTINE lpm_data_output_ptseries
2870
2871
2872	!------------------------------------------------------------------------------!
2873	! Description:
2874	! ------------
2875	!> This routine reads the respective restart data for the lpm.
2876	!------------------------------------------------------------------------------!
2877	SUBROUTINE lpm_rrd_local_particles
2878
2879	CHARACTER (LEN=10) :: particle_binary_version !<
2880	CHARACTER (LEN=10) :: version_on_file !<
2881
2882	INTEGER(iwp) :: alloc_size !<
2883	INTEGER(iwp) :: ip !<
2884	INTEGER(iwp) :: jp !<
2885	INTEGER(iwp) :: kp !<
2886
2887	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: tmp_particles !<
2888
2889	!
2890	!-- Read particle data from previous model run.
2891	!-- First open the input unit.
2892	IF ( myid_char == '' ) THEN
2893	OPEN ( 90, FILE='PARTICLE_RESTART_DATA_IN'//myid_char, &
2894	FORM='UNFORMATTED' )
2895	ELSE
2896	OPEN ( 90, FILE='PARTICLE_RESTART_DATA_IN/'//myid_char, &
2897	FORM='UNFORMATTED' )
2898	ENDIF
2899
2900	!
2901	!-- First compare the version numbers
2902	READ ( 90 ) version_on_file
2903	particle_binary_version = '4.0'
2904	IF ( TRIM( version_on_file ) /= TRIM( particle_binary_version ) ) THEN
2905	message_string = 'version mismatch concerning data from prior ' // &
2906	'run &version on file = "' // &
2907	TRIM( version_on_file ) // &
2908	'&version in program = "' // &
2909	TRIM( particle_binary_version ) // '"'
2910	CALL message( 'lpm_read_restart_file', 'PA0214', 1, 2, 0, 6, 0 )
2911	ENDIF
2912
2913	!
2914	!-- If less particles are stored on the restart file than prescribed by
2915	!-- 1, the remainder is initialized by zero_particle to avoid
2916	!-- errors.
2917	zero_particle = particle_type( 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, &
2918	0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, &
2919	0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, &
2920	0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, &
2921	0, 0, 0_idp, .FALSE., -1 )
2922	!
2923	!-- Read some particle parameters and the size of the particle arrays,
2924	!-- allocate them and read their contents.
2925	READ ( 90 ) bc_par_b, bc_par_lr, bc_par_ns, bc_par_t, &
2926	last_particle_release_time, number_of_particle_groups, &
2927	particle_groups, time_write_particle_data
2928
2929	ALLOCATE( prt_count(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &
2930	grid_particles(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2931
2932	READ ( 90 ) prt_count
2933
2934	DO ip = nxl, nxr
2935	DO jp = nys, nyn
2936	DO kp = nzb+1, nzt
2937
2938	number_of_particles = prt_count(kp,jp,ip)
2939	IF ( number_of_particles > 0 ) THEN
2940	alloc_size = MAX( INT( number_of_particles * &
2941	( 1.0_wp + alloc_factor / 100.0_wp ) ), &
2942	1 )
2943	ELSE
2944	alloc_size = 1
2945	ENDIF
2946
2947	ALLOCATE( grid_particles(kp,jp,ip)%particles(1:alloc_size) )
2948
2949	IF ( number_of_particles > 0 ) THEN
2950	ALLOCATE( tmp_particles(1:number_of_particles) )
2951	READ ( 90 ) tmp_particles
2952	grid_particles(kp,jp,ip)%particles(1:number_of_particles) = tmp_particles
2953	DEALLOCATE( tmp_particles )
2954	IF ( number_of_particles < alloc_size ) THEN
2955	grid_particles(kp,jp,ip)%particles(number_of_particles+1:alloc_size) &
2956	= zero_particle
2957	ENDIF
2958	ELSE
2959	grid_particles(kp,jp,ip)%particles(1:alloc_size) = zero_particle
2960	ENDIF
2961
2962	ENDDO
2963	ENDDO
2964	ENDDO
2965
2966	CLOSE ( 90 )
2967	!
2968	!-- Must be called to sort particles into blocks, which is needed for a fast
2969	!-- interpolation of the LES fields on the particle position.
2970	CALL lpm_sort_and_delete
2971
2972
2973	END SUBROUTINE lpm_rrd_local_particles
2974
2975
2976	SUBROUTINE lpm_rrd_local( k, nxlf, nxlc, nxl_on_file, nxrf, nxrc, &
2977	nxr_on_file, nynf, nync, nyn_on_file, nysf, &
2978	nysc, nys_on_file, tmp_3d, found )
2979
2980
2981	USE control_parameters, &
2982	ONLY: length, restart_string
2983
2984	INTEGER(iwp) :: k !<
2985	INTEGER(iwp) :: nxlc !<
2986	INTEGER(iwp) :: nxlf !<
2987	INTEGER(iwp) :: nxl_on_file !<
2988	INTEGER(iwp) :: nxrc !<
2989	INTEGER(iwp) :: nxrf !<
2990	INTEGER(iwp) :: nxr_on_file !<
2991	INTEGER(iwp) :: nync !<
2992	INTEGER(iwp) :: nynf !<
2993	INTEGER(iwp) :: nyn_on_file !<
2994	INTEGER(iwp) :: nysc !<
2995	INTEGER(iwp) :: nysf !<
2996	INTEGER(iwp) :: nys_on_file !<
2997
2998	LOGICAL, INTENT(OUT) :: found
2999
3000	REAL(wp), DIMENSION(nzb:nzt+1,nys_on_file-nbgp:nyn_on_file+nbgp,nxl_on_file-nbgp:nxr_on_file+nbgp) :: tmp_3d !<
3001
3002
3003	found = .TRUE.
3004
3005	SELECT CASE ( restart_string(1:length) )
3006
3007	CASE ( 'iran' ) ! matching random numbers is still unresolved issue
3008	IF ( k == 1 ) READ ( 13 ) iran, iran_part
3009
3010	CASE ( 'pc_av' )
3011	IF ( .NOT. ALLOCATED( pc_av ) ) THEN
3012	ALLOCATE( pc_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
3013	ENDIF
3014	IF ( k == 1 ) READ ( 13 ) tmp_3d
3015	pc_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
3016	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
3017
3018	CASE ( 'pr_av' )
3019	IF ( .NOT. ALLOCATED( pr_av ) ) THEN
3020	ALLOCATE( pr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
3021	ENDIF
3022	IF ( k == 1 ) READ ( 13 ) tmp_3d
3023	pr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
3024	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
3025
3026	CASE ( 'ql_c_av' )
3027	IF ( .NOT. ALLOCATED( ql_c_av ) ) THEN
3028	ALLOCATE( ql_c_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
3029	ENDIF
3030	IF ( k == 1 ) READ ( 13 ) tmp_3d
3031	ql_c_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
3032	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
3033
3034	CASE ( 'ql_v_av' )
3035	IF ( .NOT. ALLOCATED( ql_v_av ) ) THEN
3036	ALLOCATE( ql_v_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
3037	ENDIF
3038	IF ( k == 1 ) READ ( 13 ) tmp_3d
3039	ql_v_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
3040	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
3041
3042	CASE ( 'ql_vp_av' )
3043	IF ( .NOT. ALLOCATED( ql_vp_av ) ) THEN
3044	ALLOCATE( ql_vp_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
3045	ENDIF
3046	IF ( k == 1 ) READ ( 13 ) tmp_3d
3047	ql_vp_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
3048	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
3049
3050	CASE DEFAULT
3051
3052	found = .FALSE.
3053
3054	END SELECT
3055
3056
3057	END SUBROUTINE lpm_rrd_local
3058
3059	!------------------------------------------------------------------------------!
3060	! Description:
3061	! ------------
3062	!> This routine writes the respective restart data for the lpm.
3063	!------------------------------------------------------------------------------!
3064	SUBROUTINE lpm_wrd_local
3065
3066	CHARACTER (LEN=10) :: particle_binary_version !<
3067
3068	INTEGER(iwp) :: ip !<
3069	INTEGER(iwp) :: jp !<
3070	INTEGER(iwp) :: kp !<
3071	!
3072	!-- First open the output unit.
3073	IF ( myid_char == '' ) THEN
3074	OPEN ( 90, FILE='PARTICLE_RESTART_DATA_OUT'//myid_char, &
3075	FORM='UNFORMATTED')
3076	ELSE
3077	IF ( myid == 0 ) CALL local_system( 'mkdir PARTICLE_RESTART_DATA_OUT' )
3078	#if defined( __parallel )
3079	!
3080	!-- Set a barrier in order to allow that thereafter all other processors
3081	!-- in the directory created by PE0 can open their file
3082	CALL MPI_BARRIER( comm2d, ierr )
3083	#endif
3084	OPEN ( 90, FILE='PARTICLE_RESTART_DATA_OUT/'//myid_char, &
3085	FORM='UNFORMATTED' )
3086	ENDIF
3087
3088	!
3089	!-- Write the version number of the binary format.
3090	!-- Attention: After changes to the following output commands the version
3091	!-- --------- number of the variable particle_binary_version must be
3092	!-- changed! Also, the version number and the list of arrays
3093	!-- to be read in lpm_read_restart_file must be adjusted
3094	!-- accordingly.
3095	particle_binary_version = '4.0'
3096	WRITE ( 90 ) particle_binary_version
3097
3098	!
3099	!-- Write some particle parameters, the size of the particle arrays
3100	WRITE ( 90 ) bc_par_b, bc_par_lr, bc_par_ns, bc_par_t, &
3101	last_particle_release_time, number_of_particle_groups, &
3102	particle_groups, time_write_particle_data
3103
3104	WRITE ( 90 ) prt_count
3105
3106	DO ip = nxl, nxr
3107	DO jp = nys, nyn
3108	DO kp = nzb+1, nzt
3109	number_of_particles = prt_count(kp,jp,ip)
3110	particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
3111	IF ( number_of_particles <= 0 ) CYCLE
3112	WRITE ( 90 ) particles
3113	ENDDO
3114	ENDDO
3115	ENDDO
3116
3117	CLOSE ( 90 )
3118
3119	#if defined( __parallel )
3120	CALL MPI_BARRIER( comm2d, ierr )
3121	#endif
3122
3123	CALL wrd_write_string( 'iran' )
3124	WRITE ( 14 ) iran, iran_part
3125
3126
3127	END SUBROUTINE lpm_wrd_local
3128
3129
3130	!------------------------------------------------------------------------------!
3131	! Description:
3132	! ------------
3133	!> This routine writes the respective restart data for the lpm.
3134	!------------------------------------------------------------------------------!
3135	SUBROUTINE lpm_wrd_global
3136
3137	CALL wrd_write_string( 'curvature_solution_effects' )
3138	WRITE ( 14 ) curvature_solution_effects
3139
3140	CALL wrd_write_string( 'interpolation_simple_corrector' )
3141	WRITE ( 14 ) interpolation_simple_corrector
3142
3143	CALL wrd_write_string( 'interpolation_simple_predictor' )
3144	WRITE ( 14 ) interpolation_simple_predictor
3145
3146	CALL wrd_write_string( 'interpolation_trilinear' )
3147	WRITE ( 14 ) interpolation_trilinear
3148
3149	END SUBROUTINE lpm_wrd_global
3150
3151
3152	!------------------------------------------------------------------------------!
3153	! Description:
3154	! ------------
3155	!> This routine writes the respective restart data for the lpm.
3156	!------------------------------------------------------------------------------!
3157	SUBROUTINE lpm_rrd_global( found )
3158
3159	USE control_parameters, &
3160	ONLY: length, restart_string
3161
3162	LOGICAL, INTENT(OUT) :: found
3163
3164	found = .TRUE.
3165
3166	SELECT CASE ( restart_string(1:length) )
3167
3168	CASE ( 'curvature_solution_effects' )
3169	READ ( 13 ) curvature_solution_effects
3170
3171	CASE ( 'interpolation_simple_corrector' )
3172	READ ( 13 ) interpolation_simple_corrector
3173
3174	CASE ( 'interpolation_simple_predictor' )
3175	READ ( 13 ) interpolation_simple_predictor
3176
3177	CASE ( 'interpolation_trilinear' )
3178	READ ( 13 ) interpolation_trilinear
3179
3180	! CASE ( 'global_paramter' )
3181	! READ ( 13 ) global_parameter
3182	! CASE ( 'global_array' )
3183	! IF ( .NOT. ALLOCATED( global_array ) ) ALLOCATE( global_array(1:10) )
3184	! READ ( 13 ) global_array
3185
3186	CASE DEFAULT
3187
3188	found = .FALSE.
3189
3190	END SELECT
3191
3192	END SUBROUTINE lpm_rrd_global
3193
3194
3195	!------------------------------------------------------------------------------!
3196	! Description:
3197	! ------------
3198	!> This is a submodule of the lagrangian particle model. It contains all
3199	!> dynamic processes of the lpm. This includes the advection (resolved and sub-
3200	!> grid scale) as well as the boundary conditions of particles. As a next step
3201	!> this submodule should be excluded as an own file.
3202	!------------------------------------------------------------------------------!
3203	SUBROUTINE lpm_advec (ip,jp,kp)
3204
3205	LOGICAL :: subbox_at_wall !< flag to see if the current subgridbox is adjacent to a wall
3206
3207	INTEGER(iwp) :: i !< index variable along x
3208	INTEGER(iwp) :: i_next !< index variable along x
3209	INTEGER(iwp) :: ip !< index variable along x
3210	INTEGER(iwp) :: iteration_steps = 1 !< amount of iterations steps for corrector step
3211	INTEGER(iwp) :: j !< index variable along y
3212	INTEGER(iwp) :: j_next !< index variable along y
3213	INTEGER(iwp) :: jp !< index variable along y
3214	INTEGER(iwp) :: k !< index variable along z
3215	INTEGER(iwp) :: k_wall !< vertical index of topography top
3216	INTEGER(iwp) :: kp !< index variable along z
3217	INTEGER(iwp) :: k_next !< index variable along z
3218	INTEGER(iwp) :: kw !< index variable along z
3219	INTEGER(iwp) :: kkw !< index variable along z
3220	INTEGER(iwp) :: n !< loop variable over all particles in a grid box
3221	INTEGER(iwp) :: nb !< block number particles are sorted in
3222	INTEGER(iwp) :: particle_end !< end index for partilce loop
3223	INTEGER(iwp) :: particle_start !< start index for particle loop
3224	INTEGER(iwp) :: surf_start !< Index on surface data-type for current grid box
3225	INTEGER(iwp) :: subbox_end !< end index for loop over subboxes in particle advection
3226	INTEGER(iwp) :: subbox_start !< start index for loop over subboxes in particle advection
3227	INTEGER(iwp) :: nn !< loop variable over iterations steps
3228
3229	INTEGER(iwp), DIMENSION(0:7) :: start_index !< start particle index for current block
3230	INTEGER(iwp), DIMENSION(0:7) :: end_index !< start particle index for current block
3231
3232	REAL(wp) :: aa !< dummy argument for horizontal particle interpolation
3233	REAL(wp) :: alpha !< interpolation facor for x-direction
3234
3235	REAL(wp) :: bb !< dummy argument for horizontal particle interpolation
3236	REAL(wp) :: beta !< interpolation facor for y-direction
3237	REAL(wp) :: cc !< dummy argument for horizontal particle interpolation
3238	REAL(wp) :: d_z_p_z0 !< inverse of interpolation length for logarithmic interpolation
3239	REAL(wp) :: dd !< dummy argument for horizontal particle interpolation
3240	REAL(wp) :: de_dx_int_l !< x/y-interpolated TKE gradient (x) at particle position at lower vertical level
3241	REAL(wp) :: de_dx_int_u !< x/y-interpolated TKE gradient (x) at particle position at upper vertical level
3242	REAL(wp) :: de_dy_int_l !< x/y-interpolated TKE gradient (y) at particle position at lower vertical level
3243	REAL(wp) :: de_dy_int_u !< x/y-interpolated TKE gradient (y) at particle position at upper vertical level
3244	REAL(wp) :: de_dt !< temporal derivative of TKE experienced by the particle
3245	REAL(wp) :: de_dt_min !< lower level for temporal TKE derivative
3246	REAL(wp) :: de_dz_int_l !< x/y-interpolated TKE gradient (z) at particle position at lower vertical level
3247	REAL(wp) :: de_dz_int_u !< x/y-interpolated TKE gradient (z) at particle position at upper vertical level
3248	REAL(wp) :: diameter !< diamter of droplet
3249	REAL(wp) :: diss_int_l !< x/y-interpolated dissipation at particle position at lower vertical level
3250	REAL(wp) :: diss_int_u !< x/y-interpolated dissipation at particle position at upper vertical level
3251	REAL(wp) :: dt_particle_m !< previous particle time step
3252	REAL(wp) :: dz_temp !< dummy for the vertical grid spacing
3253	REAL(wp) :: e_int_l !< x/y-interpolated TKE at particle position at lower vertical level
3254	REAL(wp) :: e_int_u !< x/y-interpolated TKE at particle position at upper vertical level
3255	REAL(wp) :: e_mean_int !< horizontal mean TKE at particle height
3256	REAL(wp) :: exp_arg !< argument in the exponent - particle radius
3257	REAL(wp) :: exp_term !< exponent term
3258	REAL(wp) :: gamma !< interpolation facor for z-direction
3259	REAL(wp) :: gg !< dummy argument for horizontal particle interpolation
3260	REAL(wp) :: height_p !< dummy argument for logarithmic interpolation
3261	REAL(wp) :: log_z_z0_int !< logarithmus used for surface_layer interpolation
3262	REAL(wp) :: random_gauss !< Gaussian-distributed random number used for SGS particle advection
3263	REAL(wp) :: RL !< Lagrangian autocorrelation coefficient
3264	REAL(wp) :: rg1 !< Gaussian distributed random number
3265	REAL(wp) :: rg2 !< Gaussian distributed random number
3266	REAL(wp) :: rg3 !< Gaussian distributed random number
3267	REAL(wp) :: sigma !< velocity standard deviation
3268	REAL(wp) :: u_int_l !< x/y-interpolated u-component at particle position at lower vertical level
3269	REAL(wp) :: u_int_u !< x/y-interpolated u-component at particle position at upper vertical level
3270	REAL(wp) :: unext !< calculated particle u-velocity of corrector step
3271	REAL(wp) :: us_int !< friction velocity at particle grid box
3272	REAL(wp) :: usws_int !< surface momentum flux (u component) at particle grid box
3273	REAL(wp) :: v_int_l !< x/y-interpolated v-component at particle position at lower vertical level
3274	REAL(wp) :: v_int_u !< x/y-interpolated v-component at particle position at upper vertical level
3275	REAL(wp) :: vsws_int !< surface momentum flux (u component) at particle grid box
3276	REAL(wp) :: vnext !< calculated particle v-velocity of corrector step
3277	REAL(wp) :: vv_int !< dummy to compute interpolated mean SGS TKE, used to scale SGS advection
3278	REAL(wp) :: w_int_l !< x/y-interpolated w-component at particle position at lower vertical level
3279	REAL(wp) :: w_int_u !< x/y-interpolated w-component at particle position at upper vertical level
3280	REAL(wp) :: wnext !< calculated particle w-velocity of corrector step
3281	REAL(wp) :: w_s !< terminal velocity of droplets
3282	REAL(wp) :: x !< dummy argument for horizontal particle interpolation
3283	REAL(wp) :: xp !< calculated particle position in x of predictor step
3284	REAL(wp) :: y !< dummy argument for horizontal particle interpolation
3285	REAL(wp) :: yp !< calculated particle position in y of predictor step
3286	REAL(wp) :: z_p !< surface layer height (0.5 dz)
3287	REAL(wp) :: zp !< calculated particle position in z of predictor step
3288
3289	REAL(wp), PARAMETER :: a_rog = 9.65_wp !< parameter for fall velocity
3290	REAL(wp), PARAMETER :: b_rog = 10.43_wp !< parameter for fall velocity
3291	REAL(wp), PARAMETER :: c_rog = 0.6_wp !< parameter for fall velocity
3292	REAL(wp), PARAMETER :: k_cap_rog = 4.0_wp !< parameter for fall velocity
3293	REAL(wp), PARAMETER :: k_low_rog = 12.0_wp !< parameter for fall velocity
3294	REAL(wp), PARAMETER :: d0_rog = 0.745_wp !< separation diameter
3295
3296	REAL(wp), DIMENSION(number_of_particles) :: term_1_2 !< flag to communicate whether a particle is near topography or not
3297	REAL(wp), DIMENSION(number_of_particles) :: dens_ratio !< ratio between the density of the fluid and the density of the particles
3298	REAL(wp), DIMENSION(number_of_particles) :: de_dx_int !< horizontal TKE gradient along x at particle position
3299	REAL(wp), DIMENSION(number_of_particles) :: de_dy_int !< horizontal TKE gradient along y at particle position
3300	REAL(wp), DIMENSION(number_of_particles) :: de_dz_int !< horizontal TKE gradient along z at particle position
3301	REAL(wp), DIMENSION(number_of_particles) :: diss_int !< dissipation at particle position
3302	REAL(wp), DIMENSION(number_of_particles) :: dt_gap !< remaining time until particle time integration reaches LES time
3303	REAL(wp), DIMENSION(number_of_particles) :: dt_particle !< particle time step
3304	REAL(wp), DIMENSION(number_of_particles) :: e_int !< TKE at particle position
3305	REAL(wp), DIMENSION(number_of_particles) :: fs_int !< weighting factor for subgrid-scale particle speed
3306	REAL(wp), DIMENSION(number_of_particles) :: lagr_timescale !< Lagrangian timescale
3307	REAL(wp), DIMENSION(number_of_particles) :: rvar1_temp !< SGS particle velocity - u-component
3308	REAL(wp), DIMENSION(number_of_particles) :: rvar2_temp !< SGS particle velocity - v-component
3309	REAL(wp), DIMENSION(number_of_particles) :: rvar3_temp !< SGS particle velocity - w-component
3310	REAL(wp), DIMENSION(number_of_particles) :: u_int !< u-component of particle speed
3311	REAL(wp), DIMENSION(number_of_particles) :: v_int !< v-component of particle speed
3312	REAL(wp), DIMENSION(number_of_particles) :: w_int !< w-component of particle speed
3313	REAL(wp), DIMENSION(number_of_particles) :: xv !< x-position
3314	REAL(wp), DIMENSION(number_of_particles) :: yv !< y-position
3315	REAL(wp), DIMENSION(number_of_particles) :: zv !< z-position
3316
3317	REAL(wp), DIMENSION(number_of_particles, 3) :: rg !< vector of Gaussian distributed random numbers
3318
3319	CALL cpu_log( log_point_s(44), 'lpm_advec', 'continue' )
3320	!
3321	!-- Determine height of Prandtl layer and distance between Prandtl-layer
3322	!-- height and horizontal mean roughness height, which are required for
3323	!-- vertical logarithmic interpolation of horizontal particle speeds
3324	!-- (for particles below first vertical grid level).
3325	z_p = zu(nzb+1) - zw(nzb)
3326	d_z_p_z0 = 1.0_wp / ( z_p - z0_av_global )
3327
3328	xv = particles(1:number_of_particles)%x
3329	yv = particles(1:number_of_particles)%y
3330	zv = particles(1:number_of_particles)%z
3331	dt_particle = dt_3d
3332
3333	!
3334	!-- This case uses a simple interpolation method for the particle velocites,
3335	!-- and applying a predictor-corrector method. @note the current time divergence
3336	!-- free time step is denoted with u_t etc.; the velocities of the time level of
3337	!-- t+1 wit u,v, and w, as the model is called after swap timelevel
3338	!-- @attention: for the corrector step the velocities of t(n+1) are required.
3339	!-- Therefore the particle code is executed at the end of the time intermediate
3340	!-- timestep routine. This interpolation method is described in more detail
3341	!-- in Grabowski et al., 2018 (GMD).
3342	IF ( interpolation_simple_corrector ) THEN
3343	!
3344	!-- Predictor step
3345	kkw = kp - 1
3346	DO n = 1, number_of_particles
3347
3348	alpha = MAX( MIN( ( particles(n)%x - ip * dx ) * ddx, 1.0_wp ), 0.0_wp )
3349	u_int(n) = u_t(kp,jp,ip) * ( 1.0_wp - alpha ) + u_t(kp,jp,ip+1) * alpha
3350
3351	beta = MAX( MIN( ( particles(n)%y - jp * dy ) * ddy, 1.0_wp ), 0.0_wp )
3352	v_int(n) = v_t(kp,jp,ip) * ( 1.0_wp - beta ) + v_t(kp,jp+1,ip) * beta
3353
3354	gamma = MAX( MIN( ( particles(n)%z - zw(kkw) ) / &
3355	( zw(kkw+1) - zw(kkw) ), 1.0_wp ), 0.0_wp )
3356	w_int(n) = w_t(kkw,jp,ip) * ( 1.0_wp - gamma ) + w_t(kkw+1,jp,ip) * gamma
3357
3358	ENDDO
3359	!
3360	!-- Corrector step
3361	DO n = 1, number_of_particles
3362
3363	IF ( .NOT. particles(n)%particle_mask ) CYCLE
3364
3365	DO nn = 1, iteration_steps
3366
3367	!
3368	!-- Guess new position
3369	xp = particles(n)%x + u_int(n) * dt_particle(n)
3370	yp = particles(n)%y + v_int(n) * dt_particle(n)
3371	zp = particles(n)%z + w_int(n) * dt_particle(n)
3372	!
3373	!-- x direction
3374	i_next = FLOOR( xp * ddx , KIND=iwp)
3375	alpha = MAX( MIN( ( xp - i_next * dx ) * ddx, 1.0_wp ), 0.0_wp )
3376	!
3377	!-- y direction
3378	j_next = FLOOR( yp * ddy )
3379	beta = MAX( MIN( ( yp - j_next * dy ) * ddy, 1.0_wp ), 0.0_wp )
3380	!
3381	!-- z_direction
3382	k_next = MAX( MIN( FLOOR( zp / (zw(kkw+1)-zw(kkw)) + offset_ocean_nzt ), nzt ), 0)
3383	gamma = MAX( MIN( ( zp - zw(k_next) ) / &
3384	( zw(k_next+1) - zw(k_next) ), 1.0_wp ), 0.0_wp )
3385	!
3386	!-- Calculate part of the corrector step
3387	unext = u(k_next+1, j_next, i_next) * ( 1.0_wp - alpha ) + &
3388	u(k_next+1, j_next, i_next+1) * alpha
3389
3390	vnext = v(k_next+1, j_next, i_next) * ( 1.0_wp - beta ) + &
3391	v(k_next+1, j_next+1, i_next ) * beta
3392
3393	wnext = w(k_next, j_next, i_next) * ( 1.0_wp - gamma ) + &
3394	w(k_next+1, j_next, i_next ) * gamma
3395
3396	!
3397	!-- Calculate interpolated particle velocity with predictor
3398	!-- corrector step. u_int, v_int and w_int describes the part of
3399	!-- the predictor step. unext, vnext and wnext is the part of the
3400	!-- corrector step. The resulting new position is set below. The
3401	!-- implementation is based on Grabowski et al., 2018 (GMD).
3402	u_int(n) = 0.5_wp * ( u_int(n) + unext )
3403	v_int(n) = 0.5_wp * ( v_int(n) + vnext )
3404	w_int(n) = 0.5_wp * ( w_int(n) + wnext )
3405
3406	ENDDO
3407	ENDDO
3408	!
3409	!-- This case uses a simple interpolation method for the particle velocites,
3410	!-- and applying a predictor.
3411	ELSEIF ( interpolation_simple_predictor ) THEN
3412	!
3413	!-- The particle position for the w velociy is based on the value of kp and kp-1
3414	kkw = kp - 1
3415	DO n = 1, number_of_particles
3416	IF ( .NOT. particles(n)%particle_mask ) CYCLE
3417
3418	alpha = MAX( MIN( ( particles(n)%x - ip * dx ) * ddx, 1.0_wp ), 0.0_wp )
3419	u_int(n) = u(kp,jp,ip) * ( 1.0_wp - alpha ) + u(kp,jp,ip+1) * alpha
3420
3421	beta = MAX( MIN( ( particles(n)%y - jp * dy ) * ddy, 1.0_wp ), 0.0_wp )
3422	v_int(n) = v(kp,jp,ip) * ( 1.0_wp - beta ) + v(kp,jp+1,ip) * beta
3423
3424	gamma = MAX( MIN( ( particles(n)%z - zw(kkw) ) / &
3425	( zw(kkw+1) - zw(kkw) ), 1.0_wp ), 0.0_wp )
3426	w_int(n) = w(kkw,jp,ip) * ( 1.0_wp - gamma ) + w(kkw+1,jp,ip) * gamma
3427	ENDDO
3428	!
3429	!-- The trilinear interpolation.
3430	ELSEIF ( interpolation_trilinear ) THEN
3431
3432	start_index = grid_particles(kp,jp,ip)%start_index
3433	end_index = grid_particles(kp,jp,ip)%end_index
3434
3435	DO nb = 0, 7
3436	!
3437	!-- Interpolate u velocity-component
3438	i = ip
3439	j = jp + block_offset(nb)%j_off
3440	k = kp + block_offset(nb)%k_off
3441
3442	DO n = start_index(nb), end_index(nb)
3443	!
3444	!-- Interpolation of the u velocity component onto particle position.
3445	!-- Particles are interpolation bi-linearly in the horizontal and a
3446	!-- linearly in the vertical. An exception is made for particles below
3447	!-- the first vertical grid level in case of a prandtl layer. In this
3448	!-- case the horizontal particle velocity components are determined using
3449	!-- Monin-Obukhov relations (if branch).
3450	!-- First, check if particle is located below first vertical grid level
3451	!-- above topography (Prandtl-layer height)
3452	!-- Determine vertical index of topography top
3453	k_wall = topo_top_ind(jp,ip,0)
3454
3455	IF ( constant_flux_layer .AND. zv(n) - zw(k_wall) < z_p ) THEN
3456	!
3457	!-- Resolved-scale horizontal particle velocity is zero below z0.
3458	IF ( zv(n) - zw(k_wall) < z0_av_global ) THEN
3459	u_int(n) = 0.0_wp
3460	ELSE
3461	!
3462	!-- Determine the sublayer. Further used as index.
3463	height_p = ( zv(n) - zw(k_wall) - z0_av_global ) &
3464	* REAL( number_of_sublayers, KIND=wp ) &
3465	* d_z_p_z0
3466	!
3467	!-- Calculate LOG(z/z0) for exact particle height. Therefore,
3468	!-- interpolate linearly between precalculated logarithm.
3469	log_z_z0_int = log_z_z0(INT(height_p)) &
3470	+ ( height_p - INT(height_p) ) &
3471	* ( log_z_z0(INT(height_p)+1) &
3472	- log_z_z0(INT(height_p)) &
3473	)
3474	!
3475	!-- Get friction velocity and momentum flux from new surface data
3476	!-- types.
3477	IF ( surf_def_h(0)%start_index(jp,ip) <= &
3478	surf_def_h(0)%end_index(jp,ip) ) THEN
3479	surf_start = surf_def_h(0)%start_index(jp,ip)
3480	!-- Limit friction velocity. In narrow canyons or holes the
3481	!-- friction velocity can become very small, resulting in a too
3482	!-- large particle speed.
3483	us_int = MAX( surf_def_h(0)%us(surf_start), 0.01_wp )
3484	usws_int = surf_def_h(0)%usws(surf_start)
3485	ELSEIF ( surf_lsm_h%start_index(jp,ip) <= &
3486	surf_lsm_h%end_index(jp,ip) ) THEN
3487	surf_start = surf_lsm_h%start_index(jp,ip)
3488	us_int = MAX( surf_lsm_h%us(surf_start), 0.01_wp )
3489	usws_int = surf_lsm_h%usws(surf_start)
3490	ELSEIF ( surf_usm_h%start_index(jp,ip) <= &
3491	surf_usm_h%end_index(jp,ip) ) THEN
3492	surf_start = surf_usm_h%start_index(jp,ip)
3493	us_int = MAX( surf_usm_h%us(surf_start), 0.01_wp )
3494	usws_int = surf_usm_h%usws(surf_start)
3495	ENDIF
3496	!
3497	!-- Neutral solution is applied for all situations, e.g. also for
3498	!-- unstable and stable situations. Even though this is not exact
3499	!-- this saves a lot of CPU time since several calls of intrinsic
3500	!-- FORTRAN procedures (LOG, ATAN) are avoided, This is justified
3501	!-- as sensitivity studies revealed no significant effect of
3502	!-- using the neutral solution also for un/stable situations.
3503	u_int(n) = -usws_int / ( us_int * kappa + 1E-10_wp ) &
3504	* log_z_z0_int - u_gtrans
3505	ENDIF
3506	!
3507	!-- Particle above the first grid level. Bi-linear interpolation in the
3508	!-- horizontal and linear interpolation in the vertical direction.
3509	ELSE
3510	x = xv(n) - i * dx
3511	y = yv(n) + ( 0.5_wp - j ) * dy
3512	aa = x2 + y2
3513	bb = ( dx - x )2 + y2
3514	cc = x2 + ( dy - y )2
3515	dd = ( dx - x )2 + ( dy - y )2
3516	gg = aa + bb + cc + dd
3517
3518	u_int_l = ( ( gg - aa ) * u(k,j,i) + ( gg - bb ) * u(k,j,i+1) &
3519	+ ( gg - cc ) * u(k,j+1,i) + ( gg - dd ) * &
3520	u(k,j+1,i+1) ) / ( 3.0_wp * gg ) - u_gtrans
3521
3522	IF ( k == nzt ) THEN
3523	u_int(n) = u_int_l
3524	ELSE
3525	u_int_u = ( ( gg-aa ) * u(k+1,j,i) + ( gg-bb ) * u(k+1,j,i+1) &
3526	+ ( gg-cc ) * u(k+1,j+1,i) + ( gg-dd ) * &
3527	u(k+1,j+1,i+1) ) / ( 3.0_wp * gg ) - u_gtrans
3528	u_int(n) = u_int_l + ( zv(n) - zu(k) ) / dzw(k+1) * &
3529	( u_int_u - u_int_l )
3530	ENDIF
3531	ENDIF
3532	ENDDO
3533	!
3534	!-- Same procedure for interpolation of the v velocity-component
3535	i = ip + block_offset(nb)%i_off
3536	j = jp
3537	k = kp + block_offset(nb)%k_off
3538
3539	DO n = start_index(nb), end_index(nb)
3540	!
3541	!-- Determine vertical index of topography top
3542	k_wall = topo_top_ind(jp,ip,0)
3543
3544	IF ( constant_flux_layer .AND. zv(n) - zw(k_wall) < z_p ) THEN
3545	IF ( zv(n) - zw(k_wall) < z0_av_global ) THEN
3546	!
3547	!-- Resolved-scale horizontal particle velocity is zero below z0.
3548	v_int(n) = 0.0_wp
3549	ELSE
3550	!
3551	!-- Determine the sublayer. Further used as index. Please note,
3552	!-- logarithmus can not be reused from above, as in in case of
3553	!-- topography particle on u-grid can be above surface-layer height,
3554	!-- whereas it can be below on v-grid.
3555	height_p = ( zv(n) - zw(k_wall) - z0_av_global ) &
3556	* REAL( number_of_sublayers, KIND=wp ) &
3557	* d_z_p_z0
3558	!
3559	!-- Calculate LOG(z/z0) for exact particle height. Therefore,
3560	!-- interpolate linearly between precalculated logarithm.
3561	log_z_z0_int = log_z_z0(INT(height_p)) &
3562	+ ( height_p - INT(height_p) ) &
3563	* ( log_z_z0(INT(height_p)+1) &
3564	- log_z_z0(INT(height_p)) &
3565	)
3566	!
3567	!-- Get friction velocity and momentum flux from new surface data
3568	!-- types.
3569	IF ( surf_def_h(0)%start_index(jp,ip) <= &
3570	surf_def_h(0)%end_index(jp,ip) ) THEN
3571	surf_start = surf_def_h(0)%start_index(jp,ip)
3572	!-- Limit friction velocity. In narrow canyons or holes the
3573	!-- friction velocity can become very small, resulting in a too
3574	!-- large particle speed.
3575	us_int = MAX( surf_def_h(0)%us(surf_start), 0.01_wp )
3576	vsws_int = surf_def_h(0)%vsws(surf_start)
3577	ELSEIF ( surf_lsm_h%start_index(jp,ip) <= &
3578	surf_lsm_h%end_index(jp,ip) ) THEN
3579	surf_start = surf_lsm_h%start_index(jp,ip)
3580	us_int = MAX( surf_lsm_h%us(surf_start), 0.01_wp )
3581	vsws_int = surf_lsm_h%vsws(surf_start)
3582	ELSEIF ( surf_usm_h%start_index(jp,ip) <= &
3583	surf_usm_h%end_index(jp,ip) ) THEN
3584	surf_start = surf_usm_h%start_index(jp,ip)
3585	us_int = MAX( surf_usm_h%us(surf_start), 0.01_wp )
3586	vsws_int = surf_usm_h%vsws(surf_start)
3587	ENDIF
3588	!
3589	!-- Neutral solution is applied for all situations, e.g. also for
3590	!-- unstable and stable situations. Even though this is not exact
3591	!-- this saves a lot of CPU time since several calls of intrinsic
3592	!-- FORTRAN procedures (LOG, ATAN) are avoided, This is justified
3593	!-- as sensitivity studies revealed no significant effect of
3594	!-- using the neutral solution also for un/stable situations.
3595	v_int(n) = -vsws_int / ( us_int * kappa + 1E-10_wp ) &
3596	* log_z_z0_int - v_gtrans
3597
3598	ENDIF
3599	ELSE
3600	x = xv(n) + ( 0.5_wp - i ) * dx
3601	y = yv(n) - j * dy
3602	aa = x2 + y2
3603	bb = ( dx - x )2 + y2
3604	cc = x2 + ( dy - y )2
3605	dd = ( dx - x )2 + ( dy - y )2
3606	gg = aa + bb + cc + dd
3607
3608	v_int_l = ( ( gg - aa ) * v(k,j,i) + ( gg - bb ) * v(k,j,i+1) &
3609	+ ( gg - cc ) * v(k,j+1,i) + ( gg - dd ) * v(k,j+1,i+1) &
3610	) / ( 3.0_wp * gg ) - v_gtrans
3611
3612	IF ( k == nzt ) THEN
3613	v_int(n) = v_int_l
3614	ELSE
3615	v_int_u = ( ( gg-aa ) * v(k+1,j,i) + ( gg-bb ) * v(k+1,j,i+1) &
3616	+ ( gg-cc ) * v(k+1,j+1,i) + ( gg-dd ) * v(k+1,j+1,i+1) &
3617	) / ( 3.0_wp * gg ) - v_gtrans
3618	v_int(n) = v_int_l + ( zv(n) - zu(k) ) / dzw(k+1) * &
3619	( v_int_u - v_int_l )
3620	ENDIF
3621	ENDIF
3622	ENDDO
3623	!
3624	!-- Same procedure for interpolation of the w velocity-component
3625	i = ip + block_offset(nb)%i_off
3626	j = jp + block_offset(nb)%j_off
3627	k = kp - 1
3628
3629	DO n = start_index(nb), end_index(nb)
3630	IF ( vertical_particle_advection(particles(n)%group) ) THEN
3631	x = xv(n) + ( 0.5_wp - i ) * dx
3632	y = yv(n) + ( 0.5_wp - j ) * dy
3633	aa = x2 + y2
3634	bb = ( dx - x )2 + y2
3635	cc = x2 + ( dy - y )2
3636	dd = ( dx - x )2 + ( dy - y )2
3637	gg = aa + bb + cc + dd
3638
3639	w_int_l = ( ( gg - aa ) * w(k,j,i) + ( gg - bb ) * w(k,j,i+1) &
3640	+ ( gg - cc ) * w(k,j+1,i) + ( gg - dd ) * w(k,j+1,i+1) &
3641	) / ( 3.0_wp * gg )
3642
3643	IF ( k == nzt ) THEN
3644	w_int(n) = w_int_l
3645	ELSE
3646	w_int_u = ( ( gg-aa ) * w(k+1,j,i) + &
3647	( gg-bb ) * w(k+1,j,i+1) + &
3648	( gg-cc ) * w(k+1,j+1,i) + &
3649	( gg-dd ) * w(k+1,j+1,i+1) &
3650	) / ( 3.0_wp * gg )
3651	w_int(n) = w_int_l + ( zv(n) - zw(k) ) / dzw(k+1) * &
3652	( w_int_u - w_int_l )
3653	ENDIF
3654	ELSE
3655	w_int(n) = 0.0_wp
3656	ENDIF
3657	ENDDO
3658	ENDDO
3659	ENDIF
3660
3661	!-- Interpolate and calculate quantities needed for calculating the SGS
3662	!-- velocities
3663	IF ( use_sgs_for_particles .AND. .NOT. cloud_droplets ) THEN
3664
3665	DO nb = 0,7
3666
3667	subbox_at_wall = .FALSE.
3668	!
3669	!-- In case of topography check if subbox is adjacent to a wall
3670	IF ( .NOT. topography == 'flat' ) THEN
3671	i = ip + MERGE( -1_iwp , 1_iwp, BTEST( nb, 2 ) )
3672	j = jp + MERGE( -1_iwp , 1_iwp, BTEST( nb, 1 ) )
3673	k = kp + MERGE( -1_iwp , 1_iwp, BTEST( nb, 0 ) )
3674	IF ( .NOT. BTEST(wall_flags_total_0(k, jp, ip), 0) .OR. &
3675	.NOT. BTEST(wall_flags_total_0(kp, j, ip), 0) .OR. &
3676	.NOT. BTEST(wall_flags_total_0(kp, jp, i ), 0) ) &
3677	THEN
3678	subbox_at_wall = .TRUE.
3679	ENDIF
3680	ENDIF
3681	IF ( subbox_at_wall ) THEN
3682	e_int(start_index(nb):end_index(nb)) = e(kp,jp,ip)
3683	diss_int(start_index(nb):end_index(nb)) = diss(kp,jp,ip)
3684	de_dx_int(start_index(nb):end_index(nb)) = de_dx(kp,jp,ip)
3685	de_dy_int(start_index(nb):end_index(nb)) = de_dy(kp,jp,ip)
3686	de_dz_int(start_index(nb):end_index(nb)) = de_dz(kp,jp,ip)
3687	!
3688	!-- Set flag for stochastic equation.
3689	term_1_2(start_index(nb):end_index(nb)) = 0.0_wp
3690	ELSE
3691	i = ip + block_offset(nb)%i_off
3692	j = jp + block_offset(nb)%j_off
3693	k = kp + block_offset(nb)%k_off
3694
3695	DO n = start_index(nb), end_index(nb)
3696	!
3697	!-- Interpolate TKE
3698	x = xv(n) + ( 0.5_wp - i ) * dx
3699	y = yv(n) + ( 0.5_wp - j ) * dy
3700	aa = x2 + y2
3701	bb = ( dx - x )2 + y2
3702	cc = x2 + ( dy - y )2
3703	dd = ( dx - x )2 + ( dy - y )2
3704	gg = aa + bb + cc + dd
3705
3706	e_int_l = ( ( gg-aa ) * e(k,j,i) + ( gg-bb ) * e(k,j,i+1) &
3707	+ ( gg-cc ) * e(k,j+1,i) + ( gg-dd ) * e(k,j+1,i+1) &
3708	) / ( 3.0_wp * gg )
3709
3710	IF ( k+1 == nzt+1 ) THEN
3711	e_int(n) = e_int_l
3712	ELSE
3713	e_int_u = ( ( gg - aa ) * e(k+1,j,i) + &
3714	( gg - bb ) * e(k+1,j,i+1) + &
3715	( gg - cc ) * e(k+1,j+1,i) + &
3716	( gg - dd ) * e(k+1,j+1,i+1) &
3717	) / ( 3.0_wp * gg )
3718	e_int(n) = e_int_l + ( zv(n) - zu(k) ) / dzw(k+1) * &
3719	( e_int_u - e_int_l )
3720	ENDIF
3721	!
3722	!-- Needed to avoid NaN particle velocities (this might not be
3723	!-- required any more)
3724	IF ( e_int(n) <= 0.0_wp ) THEN
3725	e_int(n) = 1.0E-20_wp
3726	ENDIF
3727	!
3728	!-- Interpolate the TKE gradient along x (adopt incides i,j,k and
3729	!-- all position variables from above (TKE))
3730	de_dx_int_l = ( ( gg - aa ) * de_dx(k,j,i) + &
3731	( gg - bb ) * de_dx(k,j,i+1) + &
3732	( gg - cc ) * de_dx(k,j+1,i) + &
3733	( gg - dd ) * de_dx(k,j+1,i+1) &
3734	) / ( 3.0_wp * gg )
3735
3736	IF ( ( k+1 == nzt+1 ) .OR. ( k == nzb ) ) THEN
3737	de_dx_int(n) = de_dx_int_l
3738	ELSE
3739	de_dx_int_u = ( ( gg - aa ) * de_dx(k+1,j,i) + &
3740	( gg - bb ) * de_dx(k+1,j,i+1) + &
3741	( gg - cc ) * de_dx(k+1,j+1,i) + &
3742	( gg - dd ) * de_dx(k+1,j+1,i+1) &
3743	) / ( 3.0_wp * gg )
3744	de_dx_int(n) = de_dx_int_l + ( zv(n) - zu(k) ) / dzw(k+1) * &
3745	( de_dx_int_u - de_dx_int_l )
3746	ENDIF
3747	!
3748	!-- Interpolate the TKE gradient along y
3749	de_dy_int_l = ( ( gg - aa ) * de_dy(k,j,i) + &
3750	( gg - bb ) * de_dy(k,j,i+1) + &
3751	( gg - cc ) * de_dy(k,j+1,i) + &
3752	( gg - dd ) * de_dy(k,j+1,i+1) &
3753	) / ( 3.0_wp * gg )
3754	IF ( ( k+1 == nzt+1 ) .OR. ( k == nzb ) ) THEN
3755	de_dy_int(n) = de_dy_int_l
3756	ELSE
3757	de_dy_int_u = ( ( gg - aa ) * de_dy(k+1,j,i) + &
3758	( gg - bb ) * de_dy(k+1,j,i+1) + &
3759	( gg - cc ) * de_dy(k+1,j+1,i) + &
3760	( gg - dd ) * de_dy(k+1,j+1,i+1) &
3761	) / ( 3.0_wp * gg )
3762	de_dy_int(n) = de_dy_int_l + ( zv(n) - zu(k) ) / dzw(k+1) * &
3763	( de_dy_int_u - de_dy_int_l )
3764	ENDIF
3765
3766	!
3767	!-- Interpolate the TKE gradient along z
3768	IF ( zv(n) < 0.5_wp * dz(1) ) THEN
3769	de_dz_int(n) = 0.0_wp
3770	ELSE
3771	de_dz_int_l = ( ( gg - aa ) * de_dz(k,j,i) + &
3772	( gg - bb ) * de_dz(k,j,i+1) + &
3773	( gg - cc ) * de_dz(k,j+1,i) + &
3774	( gg - dd ) * de_dz(k,j+1,i+1) &
3775	) / ( 3.0_wp * gg )
3776
3777	IF ( ( k+1 == nzt+1 ) .OR. ( k == nzb ) ) THEN
3778	de_dz_int(n) = de_dz_int_l
3779	ELSE
3780	de_dz_int_u = ( ( gg - aa ) * de_dz(k+1,j,i) + &
3781	( gg - bb ) * de_dz(k+1,j,i+1) + &
3782	( gg - cc ) * de_dz(k+1,j+1,i) + &
3783	( gg - dd ) * de_dz(k+1,j+1,i+1) &
3784	) / ( 3.0_wp * gg )
3785	de_dz_int(n) = de_dz_int_l + ( zv(n) - zu(k) ) / dzw(k+1) * &
3786	( de_dz_int_u - de_dz_int_l )
3787	ENDIF
3788	ENDIF
3789
3790	!
3791	!-- Interpolate the dissipation of TKE
3792	diss_int_l = ( ( gg - aa ) * diss(k,j,i) + &
3793	( gg - bb ) * diss(k,j,i+1) + &
3794	( gg - cc ) * diss(k,j+1,i) + &
3795	( gg - dd ) * diss(k,j+1,i+1) &
3796	) / ( 3.0_wp * gg )
3797
3798	IF ( k == nzt ) THEN
3799	diss_int(n) = diss_int_l
3800	ELSE
3801	diss_int_u = ( ( gg - aa ) * diss(k+1,j,i) + &
3802	( gg - bb ) * diss(k+1,j,i+1) + &
3803	( gg - cc ) * diss(k+1,j+1,i) + &
3804	( gg - dd ) * diss(k+1,j+1,i+1) &
3805	) / ( 3.0_wp * gg )
3806	diss_int(n) = diss_int_l + ( zv(n) - zu(k) ) / dzw(k+1) * &
3807	( diss_int_u - diss_int_l )
3808	ENDIF
3809
3810	!
3811	!-- Set flag for stochastic equation.
3812	term_1_2(n) = 1.0_wp
3813	ENDDO
3814	ENDIF
3815	ENDDO
3816
3817	DO nb = 0,7
3818	i = ip + block_offset(nb)%i_off
3819	j = jp + block_offset(nb)%j_off
3820	k = kp + block_offset(nb)%k_off
3821
3822	DO n = start_index(nb), end_index(nb)
3823	!
3824	!-- Vertical interpolation of the horizontally averaged SGS TKE and
3825	!-- resolved-scale velocity variances and use the interpolated values
3826	!-- to calculate the coefficient fs, which is a measure of the ratio
3827	!-- of the subgrid-scale turbulent kinetic energy to the total amount
3828	!-- of turbulent kinetic energy.
3829	IF ( k == 0 ) THEN
3830	e_mean_int = hom(0,1,8,0)
3831	ELSE
3832	e_mean_int = hom(k,1,8,0) + &
3833	( hom(k+1,1,8,0) - hom(k,1,8,0) ) / &
3834	( zu(k+1) - zu(k) ) * &
3835	( zv(n) - zu(k) )
3836	ENDIF
3837
3838	kw = kp - 1
3839
3840	IF ( k == 0 ) THEN
3841	aa = hom(k+1,1,30,0) * ( zv(n) / &
3842	( 0.5_wp * ( zu(k+1) - zu(k) ) ) )
3843	bb = hom(k+1,1,31,0) * ( zv(n) / &
3844	( 0.5_wp * ( zu(k+1) - zu(k) ) ) )
3845	cc = hom(kw+1,1,32,0) * ( zv(n) / &
3846	( 1.0_wp * ( zw(kw+1) - zw(kw) ) ) )
3847	ELSE
3848	aa = hom(k,1,30,0) + ( hom(k+1,1,30,0) - hom(k,1,30,0) ) * &
3849	( ( zv(n) - zu(k) ) / ( zu(k+1) - zu(k) ) )
3850	bb = hom(k,1,31,0) + ( hom(k+1,1,31,0) - hom(k,1,31,0) ) * &
3851	( ( zv(n) - zu(k) ) / ( zu(k+1) - zu(k) ) )
3852	cc = hom(kw,1,32,0) + ( hom(kw+1,1,32,0)-hom(kw,1,32,0) ) * &
3853	( ( zv(n) - zw(kw) ) / ( zw(kw+1)-zw(kw) ) )
3854	ENDIF
3855
3856	vv_int = ( 1.0_wp / 3.0_wp ) * ( aa + bb + cc )
3857	!
3858	!-- Needed to avoid NaN particle velocities. The value of 1.0 is just
3859	!-- an educated guess for the given case.
3860	IF ( vv_int + ( 2.0_wp / 3.0_wp ) * e_mean_int == 0.0_wp ) THEN
3861	fs_int(n) = 1.0_wp
3862	ELSE
3863	fs_int(n) = ( 2.0_wp / 3.0_wp ) * e_mean_int / &
3864	( vv_int + ( 2.0_wp / 3.0_wp ) * e_mean_int )
3865	ENDIF
3866
3867	ENDDO
3868	ENDDO
3869
3870	DO nb = 0, 7
3871	DO n = start_index(nb), end_index(nb)
3872	rg(n,1) = random_gauss( iran_part, 5.0_wp )
3873	rg(n,2) = random_gauss( iran_part, 5.0_wp )
3874	rg(n,3) = random_gauss( iran_part, 5.0_wp )
3875	ENDDO
3876	ENDDO
3877
3878	DO nb = 0, 7
3879	DO n = start_index(nb), end_index(nb)
3880
3881	!
3882	!-- Calculate the Lagrangian timescale according to Weil et al. (2004).
3883	lagr_timescale(n) = ( 4.0_wp * e_int(n) + 1E-20_wp ) / &
3884	( 3.0_wp * fs_int(n) * c_0 * diss_int(n) + 1E-20_wp )
3885
3886	!
3887	!-- Calculate the next particle timestep. dt_gap is the time needed to
3888	!-- complete the current LES timestep.
3889	dt_gap(n) = dt_3d - particles(n)%dt_sum
3890	dt_particle(n) = MIN( dt_3d, 0.025_wp * lagr_timescale(n), dt_gap(n) )
3891	particles(n)%aux1 = lagr_timescale(n)
3892	particles(n)%aux2 = dt_gap(n)
3893	!
3894	!-- The particle timestep should not be too small in order to prevent
3895	!-- the number of particle timesteps of getting too large
3896	IF ( dt_particle(n) < dt_min_part ) THEN
3897	IF ( dt_min_part < dt_gap(n) ) THEN
3898	dt_particle(n) = dt_min_part
3899	ELSE
3900	dt_particle(n) = dt_gap(n)
3901	ENDIF
3902	ENDIF
3903	rvar1_temp(n) = particles(n)%rvar1
3904	rvar2_temp(n) = particles(n)%rvar2
3905	rvar3_temp(n) = particles(n)%rvar3
3906	!
3907	!-- Calculate the SGS velocity components
3908	IF ( particles(n)%age == 0.0_wp ) THEN
3909	!
3910	!-- For new particles the SGS components are derived from the SGS
3911	!-- TKE. Limit the Gaussian random number to the interval
3912	!-- [-5.0sigma, 5.0sigma] in order to prevent the SGS velocities
3913	!-- from becoming unrealistically large.
3914	rvar1_temp(n) = SQRT( 2.0_wp * sgs_wf_part * e_int(n) &
3915	+ 1E-20_wp ) * ( rg(n,1) - 1.0_wp )
3916	rvar2_temp(n) = SQRT( 2.0_wp * sgs_wf_part * e_int(n) &
3917	+ 1E-20_wp ) * ( rg(n,2) - 1.0_wp )
3918	rvar3_temp(n) = SQRT( 2.0_wp * sgs_wf_part * e_int(n) &
3919	+ 1E-20_wp ) * ( rg(n,3) - 1.0_wp )
3920
3921	ELSE
3922	!
3923	!-- Restriction of the size of the new timestep: compared to the
3924	!-- previous timestep the increase must not exceed 200%. First,
3925	!-- check if age > age_m, in order to prevent that particles get zero
3926	!-- timestep.
3927	dt_particle_m = MERGE( dt_particle(n), &
3928	particles(n)%age - particles(n)%age_m, &
3929	particles(n)%age - particles(n)%age_m < &
3930	1E-8_wp )
3931	IF ( dt_particle(n) > 2.0_wp * dt_particle_m ) THEN
3932	dt_particle(n) = 2.0_wp * dt_particle_m
3933	ENDIF
3934
3935	!-- For old particles the SGS components are correlated with the
3936	!-- values from the previous timestep. Random numbers have also to
3937	!-- be limited (see above).
3938	!-- As negative values for the subgrid TKE are not allowed, the
3939	!-- change of the subgrid TKE with time cannot be smaller than
3940	!-- -e_int(n)/dt_particle. This value is used as a lower boundary
3941	!-- value for the change of TKE
3942	de_dt_min = - e_int(n) / dt_particle(n)
3943
3944	de_dt = ( e_int(n) - particles(n)%e_m ) / dt_particle_m
3945
3946	IF ( de_dt < de_dt_min ) THEN
3947	de_dt = de_dt_min
3948	ENDIF
3949
3950	CALL weil_stochastic_eq( rvar1_temp(n), fs_int(n), e_int(n), &
3951	de_dx_int(n), de_dt, diss_int(n), &
3952	dt_particle(n), rg(n,1), term_1_2(n) )
3953
3954	CALL weil_stochastic_eq( rvar2_temp(n), fs_int(n), e_int(n), &
3955	de_dy_int(n), de_dt, diss_int(n), &
3956	dt_particle(n), rg(n,2), term_1_2(n) )
3957
3958	CALL weil_stochastic_eq( rvar3_temp(n), fs_int(n), e_int(n), &
3959	de_dz_int(n), de_dt, diss_int(n), &
3960	dt_particle(n), rg(n,3), term_1_2(n) )
3961
3962	ENDIF
3963
3964	ENDDO
3965	ENDDO
3966	!
3967	!-- Check if the added SGS velocities result in a violation of the CFL-
3968	!-- criterion. If yes choose a smaller timestep based on the new velocities
3969	!-- and calculate SGS velocities again
3970	dz_temp = zw(kp)-zw(kp-1)
3971
3972	DO nb = 0, 7
3973	DO n = start_index(nb), end_index(nb)
3974	IF ( .NOT. particles(n)%age == 0.0_wp .AND. &
3975	(ABS( u_int(n) + rvar1_temp(n) ) > (dx/dt_particle(n)) .OR. &
3976	ABS( v_int(n) + rvar2_temp(n) ) > (dy/dt_particle(n)) .OR. &
3977	ABS( w_int(n) + rvar3_temp(n) ) > (dz_temp/dt_particle(n)))) THEN
3978
3979	dt_particle(n) = 0.9_wp * MIN( &
3980	( dx / ABS( u_int(n) + rvar1_temp(n) ) ), &
3981	( dy / ABS( v_int(n) + rvar2_temp(n) ) ), &
3982	( dz_temp / ABS( w_int(n) + rvar3_temp(n) ) ) )
3983
3984	!
3985	!-- Reset temporary SGS velocites to "current" ones
3986	rvar1_temp(n) = particles(n)%rvar1
3987	rvar2_temp(n) = particles(n)%rvar2
3988	rvar3_temp(n) = particles(n)%rvar3
3989
3990	de_dt_min = - e_int(n) / dt_particle(n)
3991
3992	de_dt = ( e_int(n) - particles(n)%e_m ) / dt_particle_m
3993
3994	IF ( de_dt < de_dt_min ) THEN
3995	de_dt = de_dt_min
3996	ENDIF
3997
3998	CALL weil_stochastic_eq( rvar1_temp(n), fs_int(n), e_int(n), &
3999	de_dx_int(n), de_dt, diss_int(n), &
4000	dt_particle(n), rg(n,1), term_1_2(n) )
4001
4002	CALL weil_stochastic_eq( rvar2_temp(n), fs_int(n), e_int(n), &
4003	de_dy_int(n), de_dt, diss_int(n), &
4004	dt_particle(n), rg(n,2), term_1_2(n) )
4005
4006	CALL weil_stochastic_eq( rvar3_temp(n), fs_int(n), e_int(n), &
4007	de_dz_int(n), de_dt, diss_int(n), &
4008	dt_particle(n), rg(n,3), term_1_2(n) )
4009	ENDIF
4010
4011	!
4012	!-- Update particle velocites
4013	particles(n)%rvar1 = rvar1_temp(n)
4014	particles(n)%rvar2 = rvar2_temp(n)
4015	particles(n)%rvar3 = rvar3_temp(n)
4016	u_int(n) = u_int(n) + particles(n)%rvar1
4017	v_int(n) = v_int(n) + particles(n)%rvar2
4018	w_int(n) = w_int(n) + particles(n)%rvar3
4019	!
4020	!-- Store the SGS TKE of the current timelevel which is needed for
4021	!-- for calculating the SGS particle velocities at the next timestep
4022	particles(n)%e_m = e_int(n)
4023	ENDDO
4024	ENDDO
4025
4026	ELSE
4027	!
4028	!-- If no SGS velocities are used, only the particle timestep has to
4029	!-- be set
4030	dt_particle = dt_3d
4031
4032	ENDIF
4033
4034	dens_ratio = particle_groups(particles(1:number_of_particles)%group)%density_ratio
4035	IF ( ANY( dens_ratio == 0.0_wp ) ) THEN
4036	!
4037	!-- Decide whether the particle loop runs over the subboxes or only over 1,
4038	!-- number_of_particles. This depends on the selected interpolation method.
4039	!-- If particle interpolation method is not trilinear, then the sorting within
4040	!-- subboxes is not required. However, therefore the index start_index(nb) and
4041	!-- end_index(nb) are not defined and the loops are still over
4042	!-- number_of_particles. @todo find a more generic way to write this loop or
4043	!-- delete trilinear interpolation
4044	IF ( interpolation_trilinear ) THEN
4045	subbox_start = 0
4046	subbox_end = 7
4047	ELSE
4048	subbox_start = 1
4049	subbox_end = 1
4050	ENDIF
4051	!
4052	!-- loop over subboxes. In case of simple interpolation scheme no subboxes
4053	!-- are introduced, as they are not required. Accordingly, this loops goes
4054	!-- from 1 to 1.
4055	DO nb = subbox_start, subbox_end
4056	IF ( interpolation_trilinear ) THEN
4057	particle_start = start_index(nb)
4058	particle_end = end_index(nb)
4059	ELSE
4060	particle_start = 1
4061	particle_end = number_of_particles
4062	ENDIF
4063	!
4064	!-- Loop from particle start to particle end
4065	DO n = particle_start, particle_end
4066
4067	!
4068	!-- Particle advection
4069	IF ( dens_ratio(n) == 0.0_wp ) THEN
4070	!
4071	!-- Pure passive transport (without particle inertia)
4072	particles(n)%x = xv(n) + u_int(n) * dt_particle(n)
4073	particles(n)%y = yv(n) + v_int(n) * dt_particle(n)
4074	particles(n)%z = zv(n) + w_int(n) * dt_particle(n)
4075
4076	particles(n)%speed_x = u_int(n)
4077	particles(n)%speed_y = v_int(n)
4078	particles(n)%speed_z = w_int(n)
4079
4080	ELSE
4081	!
4082	!-- Transport of particles with inertia
4083	particles(n)%x = particles(n)%x + particles(n)%speed_x * &
4084	dt_particle(n)
4085	particles(n)%y = particles(n)%y + particles(n)%speed_y * &
4086	dt_particle(n)
4087	particles(n)%z = particles(n)%z + particles(n)%speed_z * &
4088	dt_particle(n)
4089
4090	!
4091	!-- Update of the particle velocity
4092	IF ( cloud_droplets ) THEN
4093	!
4094	!-- Terminal velocity is computed for vertical direction (Rogers et
4095	!-- al., 1993, J. Appl. Meteorol.)
4096	diameter = particles(n)%radius * 2000.0_wp !diameter in mm
4097	IF ( diameter <= d0_rog ) THEN
4098	w_s = k_cap_rog * diameter * ( 1.0_wp - EXP( -k_low_rog * diameter ) )
4099	ELSE
4100	w_s = a_rog - b_rog * EXP( -c_rog * diameter )
4101	ENDIF
4102
4103	!
4104	!-- If selected, add random velocities following Soelch and Kaercher
4105	!-- (2010, Q. J. R. Meteorol. Soc.)
4106	IF ( use_sgs_for_particles ) THEN
4107	lagr_timescale(n) = km(kp,jp,ip) / MAX( e(kp,jp,ip), 1.0E-20_wp )
4108	RL = EXP( -1.0_wp * dt_3d / MAX( lagr_timescale(n), &
4109	1.0E-20_wp ) )
4110	sigma = SQRT( e(kp,jp,ip) )
4111
4112	rg1 = random_gauss( iran_part, 5.0_wp ) - 1.0_wp
4113	rg2 = random_gauss( iran_part, 5.0_wp ) - 1.0_wp
4114	rg3 = random_gauss( iran_part, 5.0_wp ) - 1.0_wp
4115
4116	particles(n)%rvar1 = RL * particles(n)%rvar1 + &
4117	SQRT( 1.0_wp - RL*2 ) sigma * rg1
4118	particles(n)%rvar2 = RL * particles(n)%rvar2 + &
4119	SQRT( 1.0_wp - RL*2 ) sigma * rg2
4120	particles(n)%rvar3 = RL * particles(n)%rvar3 + &
4121	SQRT( 1.0_wp - RL*2 ) sigma * rg3
4122
4123	particles(n)%speed_x = u_int(n) + particles(n)%rvar1
4124	particles(n)%speed_y = v_int(n) + particles(n)%rvar2
4125	particles(n)%speed_z = w_int(n) + particles(n)%rvar3 - w_s
4126	ELSE
4127	particles(n)%speed_x = u_int(n)
4128	particles(n)%speed_y = v_int(n)
4129	particles(n)%speed_z = w_int(n) - w_s
4130	ENDIF
4131
4132	ELSE
4133
4134	IF ( use_sgs_for_particles ) THEN
4135	exp_arg = particle_groups(particles(n)%group)%exp_arg
4136	exp_term = EXP( -exp_arg * dt_particle(n) )
4137	ELSE
4138	exp_arg = particle_groups(particles(n)%group)%exp_arg
4139	exp_term = particle_groups(particles(n)%group)%exp_term
4140	ENDIF
4141	particles(n)%speed_x = particles(n)%speed_x * exp_term + &
4142	u_int(n) * ( 1.0_wp - exp_term )
4143	particles(n)%speed_y = particles(n)%speed_y * exp_term + &
4144	v_int(n) * ( 1.0_wp - exp_term )
4145	particles(n)%speed_z = particles(n)%speed_z * exp_term + &
4146	( w_int(n) - ( 1.0_wp - dens_ratio(n) ) * &
4147	g / exp_arg ) * ( 1.0_wp - exp_term )
4148	ENDIF
4149
4150	ENDIF
4151	ENDDO
4152	ENDDO
4153
4154	ELSE
4155	!
4156	!-- Decide whether the particle loop runs over the subboxes or only over 1,
4157	!-- number_of_particles. This depends on the selected interpolation method.
4158	IF ( interpolation_trilinear ) THEN
4159	subbox_start = 0
4160	subbox_end = 7
4161	ELSE
4162	subbox_start = 1
4163	subbox_end = 1
4164	ENDIF
4165	!-- loop over subboxes. In case of simple interpolation scheme no subboxes
4166	!-- are introduced, as they are not required. Accordingly, this loops goes
4167	!-- from 1 to 1.
4168	DO nb = subbox_start, subbox_end
4169	IF ( interpolation_trilinear ) THEN
4170	particle_start = start_index(nb)
4171	particle_end = end_index(nb)
4172	ELSE
4173	particle_start = 1
4174	particle_end = number_of_particles
4175	ENDIF
4176	!
4177	!-- Loop from particle start to particle end
4178	DO n = particle_start, particle_end
4179
4180	!
4181	!-- Transport of particles with inertia
4182	particles(n)%x = xv(n) + particles(n)%speed_x * dt_particle(n)
4183	particles(n)%y = yv(n) + particles(n)%speed_y * dt_particle(n)
4184	particles(n)%z = zv(n) + particles(n)%speed_z * dt_particle(n)
4185	!
4186	!-- Update of the particle velocity
4187	IF ( cloud_droplets ) THEN
4188	!
4189	!-- Terminal velocity is computed for vertical direction (Rogers et al.,
4190	!-- 1993, J. Appl. Meteorol.)
4191	diameter = particles(n)%radius * 2000.0_wp !diameter in mm
4192	IF ( diameter <= d0_rog ) THEN
4193	w_s = k_cap_rog * diameter * ( 1.0_wp - EXP( -k_low_rog * diameter ) )
4194	ELSE
4195	w_s = a_rog - b_rog * EXP( -c_rog * diameter )
4196	ENDIF
4197
4198	!
4199	!-- If selected, add random velocities following Soelch and Kaercher
4200	!-- (2010, Q. J. R. Meteorol. Soc.)
4201	IF ( use_sgs_for_particles ) THEN
4202	lagr_timescale(n) = km(kp,jp,ip) / MAX( e(kp,jp,ip), 1.0E-20_wp )
4203	RL = EXP( -1.0_wp * dt_3d / MAX( lagr_timescale(n), &
4204	1.0E-20_wp ) )
4205	sigma = SQRT( e(kp,jp,ip) )
4206
4207	rg1 = random_gauss( iran_part, 5.0_wp ) - 1.0_wp
4208	rg2 = random_gauss( iran_part, 5.0_wp ) - 1.0_wp
4209	rg3 = random_gauss( iran_part, 5.0_wp ) - 1.0_wp
4210
4211	particles(n)%rvar1 = RL * particles(n)%rvar1 + &
4212	SQRT( 1.0_wp - RL*2 ) sigma * rg1
4213	particles(n)%rvar2 = RL * particles(n)%rvar2 + &
4214	SQRT( 1.0_wp - RL*2 ) sigma * rg2
4215	particles(n)%rvar3 = RL * particles(n)%rvar3 + &
4216	SQRT( 1.0_wp - RL*2 ) sigma * rg3
4217
4218	particles(n)%speed_x = u_int(n) + particles(n)%rvar1
4219	particles(n)%speed_y = v_int(n) + particles(n)%rvar2
4220	particles(n)%speed_z = w_int(n) + particles(n)%rvar3 - w_s
4221	ELSE
4222	particles(n)%speed_x = u_int(n)
4223	particles(n)%speed_y = v_int(n)
4224	particles(n)%speed_z = w_int(n) - w_s
4225	ENDIF
4226
4227	ELSE
4228
4229	IF ( use_sgs_for_particles ) THEN
4230	exp_arg = particle_groups(particles(n)%group)%exp_arg
4231	exp_term = EXP( -exp_arg * dt_particle(n) )
4232	ELSE
4233	exp_arg = particle_groups(particles(n)%group)%exp_arg
4234	exp_term = particle_groups(particles(n)%group)%exp_term
4235	ENDIF
4236	particles(n)%speed_x = particles(n)%speed_x * exp_term + &
4237	u_int(n) * ( 1.0_wp - exp_term )
4238	particles(n)%speed_y = particles(n)%speed_y * exp_term + &
4239	v_int(n) * ( 1.0_wp - exp_term )
4240	particles(n)%speed_z = particles(n)%speed_z * exp_term + &
4241	( w_int(n) - ( 1.0_wp - dens_ratio(n) ) * g / &
4242	exp_arg ) * ( 1.0_wp - exp_term )
4243	ENDIF
4244	ENDDO
4245	ENDDO
4246
4247	ENDIF
4248
4249	!
4250	!-- Store the old age of the particle ( needed to prevent that a
4251	!-- particle crosses several PEs during one timestep, and for the
4252	!-- evaluation of the subgrid particle velocity fluctuations )
4253	particles(1:number_of_particles)%age_m = particles(1:number_of_particles)%age
4254
4255	!
4256	!-- loop over subboxes. In case of simple interpolation scheme no subboxes
4257	!-- are introduced, as they are not required. Accordingly, this loops goes
4258	!-- from 1 to 1.
4259	!
4260	!-- Decide whether the particle loop runs over the subboxes or only over 1,
4261	!-- number_of_particles. This depends on the selected interpolation method.
4262	IF ( interpolation_trilinear ) THEN
4263	subbox_start = 0
4264	subbox_end = 7
4265	ELSE
4266	subbox_start = 1
4267	subbox_end = 1
4268	ENDIF
4269	DO nb = subbox_start, subbox_end
4270	IF ( interpolation_trilinear ) THEN
4271	particle_start = start_index(nb)
4272	particle_end = end_index(nb)
4273	ELSE
4274	particle_start = 1
4275	particle_end = number_of_particles
4276	ENDIF
4277	!
4278	!-- Loop from particle start to particle end
4279	DO n = particle_start, particle_end
4280	!
4281	!-- Increment the particle age and the total time that the particle
4282	!-- has advanced within the particle timestep procedure
4283	particles(n)%age = particles(n)%age + dt_particle(n)
4284	particles(n)%dt_sum = particles(n)%dt_sum + dt_particle(n)
4285
4286	!
4287	!-- Check whether there is still a particle that has not yet completed
4288	!-- the total LES timestep
4289	IF ( ( dt_3d - particles(n)%dt_sum ) > 1E-8_wp ) THEN
4290	dt_3d_reached_l = .FALSE.
4291	ENDIF
4292
4293	ENDDO
4294	ENDDO
4295
4296	CALL cpu_log( log_point_s(44), 'lpm_advec', 'pause' )
4297
4298
4299	END SUBROUTINE lpm_advec
4300
4301
4302	!------------------------------------------------------------------------------!
4303	! Description:
4304	! ------------
4305	!> Calculation of subgrid-scale particle speed using the stochastic model
4306	!> of Weil et al. (2004, JAS, 61, 2877-2887).
4307	!------------------------------------------------------------------------------!
4308	SUBROUTINE weil_stochastic_eq( v_sgs, fs_n, e_n, dedxi_n, dedt_n, diss_n, &
4309	dt_n, rg_n, fac )
4310
4311	REAL(wp) :: a1 !< dummy argument
4312	REAL(wp) :: dedt_n !< time derivative of TKE at particle position
4313	REAL(wp) :: dedxi_n !< horizontal derivative of TKE at particle position
4314	REAL(wp) :: diss_n !< dissipation at particle position
4315	REAL(wp) :: dt_n !< particle timestep
4316	REAL(wp) :: e_n !< TKE at particle position
4317	REAL(wp) :: fac !< flag to identify adjacent topography
4318	REAL(wp) :: fs_n !< weighting factor to prevent that subgrid-scale particle speed becomes too large
4319	REAL(wp) :: rg_n !< random number
4320	REAL(wp) :: term1 !< memory term
4321	REAL(wp) :: term2 !< drift correction term
4322	REAL(wp) :: term3 !< random term
4323	REAL(wp) :: v_sgs !< subgrid-scale velocity component
4324
4325	!-- At first, limit TKE to a small non-zero number, in order to prevent
4326	!-- the occurrence of extremely large SGS-velocities in case TKE is zero,
4327	!-- (could occur at the simulation begin).
4328	e_n = MAX( e_n, 1E-20_wp )
4329	!
4330	!-- Please note, terms 1 and 2 (drift and memory term, respectively) are
4331	!-- multiplied by a flag to switch of both terms near topography.
4332	!-- This is necessary, as both terms may cause a subgrid-scale velocity build up
4333	!-- if particles are trapped in regions with very small TKE, e.g. in narrow street
4334	!-- canyons resolved by only a few grid points. Hence, term 1 and term 2 are
4335	!-- disabled if one of the adjacent grid points belongs to topography.
4336	!-- Moreover, in this case, the previous subgrid-scale component is also set
4337	!-- to zero.
4338
4339	a1 = fs_n * c_0 * diss_n
4340	!
4341	!-- Memory term
4342	term1 = - a1 * v_sgs * dt_n / ( 4.0_wp * sgs_wf_part * e_n + 1E-20_wp ) &
4343	* fac
4344	!
4345	!-- Drift correction term
4346	term2 = ( ( dedt_n * v_sgs / e_n ) + dedxi_n ) * 0.5_wp * dt_n &
4347	* fac
4348	!
4349	!-- Random term
4350	term3 = SQRT( MAX( a1, 1E-20_wp ) ) * ( rg_n - 1.0_wp ) * SQRT( dt_n )
4351	!
4352	!-- In cese one of the adjacent grid-boxes belongs to topograhy, the previous
4353	!-- subgrid-scale velocity component is set to zero, in order to prevent a
4354	!-- velocity build-up.
4355	!-- This case, set also previous subgrid-scale component to zero.
4356	v_sgs = v_sgs * fac + term1 + term2 + term3
4357
4358	END SUBROUTINE weil_stochastic_eq
4359
4360
4361	!------------------------------------------------------------------------------!
4362	! Description:
4363	! ------------
4364	!> swap timelevel in case of particle advection interpolation 'simple-corrector'
4365	!> This routine is called at the end of one timestep, the velocities are then
4366	!> used for the next timestep
4367	!------------------------------------------------------------------------------!
4368	SUBROUTINE lpm_swap_timelevel_for_particle_advection
4369
4370	!
4371	!-- save the divergence free velocites of t+1 to use them at the end of the
4372	!-- next time step
4373	u_t = u
4374	v_t = v
4375	w_t = w
4376
4377	END SUBROUTINE lpm_swap_timelevel_for_particle_advection
4378
4379
4380	!------------------------------------------------------------------------------!
4381	! Description:
4382	! ------------
4383	!> Boundary conditions for the Lagrangian particles.
4384	!> The routine consists of two different parts. One handles the bottom (flat)
4385	!> and top boundary. In this part, also particles which exceeded their lifetime
4386	!> are deleted.
4387	!> The other part handles the reflection of particles from vertical walls.
4388	!> This part was developed by Jin Zhang during 2006-2007.
4389	!>
4390	!> To do: Code structure for finding the t_index values and for checking the
4391	!> ----- reflection conditions is basically the same for all four cases, so it
4392	!> should be possible to further simplify/shorten it.
4393	!>
4394	!> THE WALLS PART OF THIS ROUTINE HAS NOT BEEN TESTED FOR OCEAN RUNS SO FAR!!!!
4395	!> (see offset_ocean_*)
4396	!------------------------------------------------------------------------------!
4397	SUBROUTINE lpm_boundary_conds( location_bc , i, j, k )
4398
4399	CHARACTER (LEN=*), INTENT(IN) :: location_bc !< general mode: boundary conditions at bottom/top of the model domain
4400	!< or at vertical surfaces (buildings, terrain steps)
4401	INTEGER(iwp), INTENT(IN) :: i !< grid index of particle box along x
4402	INTEGER(iwp), INTENT(IN) :: j !< grid index of particle box along y
4403	INTEGER(iwp), INTENT(IN) :: k !< grid index of particle box along z
4404
4405	INTEGER(iwp) :: inc !< dummy for sorting algorithmus
4406	INTEGER(iwp) :: ir !< dummy for sorting algorithmus
4407	INTEGER(iwp) :: i1 !< grid index (x) of old particle position
4408	INTEGER(iwp) :: i2 !< grid index (x) of current particle position
4409	INTEGER(iwp) :: i3 !< grid index (x) of intermediate particle position
4410	INTEGER(iwp) :: index_reset !< index reset height
4411	INTEGER(iwp) :: jr !< dummy for sorting algorithmus
4412	INTEGER(iwp) :: j1 !< grid index (y) of old particle position
4413	INTEGER(iwp) :: j2 !< grid index (y) of current particle position
4414	INTEGER(iwp) :: j3 !< grid index (y) of intermediate particle position
4415	INTEGER(iwp) :: k1 !< grid index (z) of old particle position
4416	INTEGER(iwp) :: k2 !< grid index (z) of current particle position
4417	INTEGER(iwp) :: k3 !< grid index (z) of intermediate particle position
4418	INTEGER(iwp) :: n !< particle number
4419	INTEGER(iwp) :: particles_top !< maximum reset height
4420	INTEGER(iwp) :: t_index !< running index for intermediate particle timesteps in reflection algorithmus
4421	INTEGER(iwp) :: t_index_number !< number of intermediate particle timesteps in reflection algorithmus
4422	INTEGER(iwp) :: tmp_x !< dummy for sorting algorithm
4423	INTEGER(iwp) :: tmp_y !< dummy for sorting algorithm
4424	INTEGER(iwp) :: tmp_z !< dummy for sorting algorithm
4425
4426	INTEGER(iwp), DIMENSION(0:10) :: x_ind(0:10) = 0 !< index array (x) of intermediate particle positions
4427	INTEGER(iwp), DIMENSION(0:10) :: y_ind(0:10) = 0 !< index array (y) of intermediate particle positions
4428	INTEGER(iwp), DIMENSION(0:10) :: z_ind(0:10) = 0 !< index array (z) of intermediate particle positions
4429
4430	LOGICAL :: cross_wall_x !< flag to check if particle reflection along x is necessary
4431	LOGICAL :: cross_wall_y !< flag to check if particle reflection along y is necessary
4432	LOGICAL :: cross_wall_z !< flag to check if particle reflection along z is necessary
4433	LOGICAL :: reflect_x !< flag to check if particle is already reflected along x
4434	LOGICAL :: reflect_y !< flag to check if particle is already reflected along y
4435	LOGICAL :: reflect_z !< flag to check if particle is already reflected along z
4436	LOGICAL :: tmp_reach_x !< dummy for sorting algorithmus
4437	LOGICAL :: tmp_reach_y !< dummy for sorting algorithmus
4438	LOGICAL :: tmp_reach_z !< dummy for sorting algorithmus
4439	LOGICAL :: x_wall_reached !< flag to check if particle has already reached wall
4440	LOGICAL :: y_wall_reached !< flag to check if particle has already reached wall
4441	LOGICAL :: z_wall_reached !< flag to check if particle has already reached wall
4442
4443	LOGICAL, DIMENSION(0:10) :: reach_x !< flag to check if particle is at a yz-wall
4444	LOGICAL, DIMENSION(0:10) :: reach_y !< flag to check if particle is at a xz-wall
4445	LOGICAL, DIMENSION(0:10) :: reach_z !< flag to check if particle is at a xy-wall
4446
4447	REAL(wp) :: dt_particle !< particle timestep
4448	REAL(wp) :: eps = 1E-10_wp !< security number to check if particle has reached a wall
4449	REAL(wp) :: pos_x !< intermediate particle position (x)
4450	REAL(wp) :: pos_x_old !< particle position (x) at previous particle timestep
4451	REAL(wp) :: pos_y !< intermediate particle position (y)
4452	REAL(wp) :: pos_y_old !< particle position (y) at previous particle timestep
4453	REAL(wp) :: pos_z !< intermediate particle position (z)
4454	REAL(wp) :: pos_z_old !< particle position (z) at previous particle timestep
4455	REAL(wp) :: prt_x !< current particle position (x)
4456	REAL(wp) :: prt_y !< current particle position (y)
4457	REAL(wp) :: prt_z !< current particle position (z)
4458	REAL(wp) :: ran_val !< location of wall in z
4459	REAL(wp) :: reset_top !< location of wall in z
4460	REAL(wp) :: t_old !< previous reflection time
4461	REAL(wp) :: tmp_t !< dummy for sorting algorithmus
4462	REAL(wp) :: xwall !< location of wall in x
4463	REAL(wp) :: ywall !< location of wall in y
4464	REAL(wp) :: zwall !< location of wall in z
4465
4466	REAL(wp), DIMENSION(0:10) :: t !< reflection time
4467
4468	SELECT CASE ( location_bc )
4469
4470	CASE ( 'bottom/top' )
4471
4472	!
4473	!-- Apply boundary conditions to those particles that have crossed the top or
4474	!-- bottom boundary and delete those particles, which are older than allowed
4475	DO n = 1, number_of_particles
4476
4477	!
4478	!-- Stop if particles have moved further than the length of one
4479	!-- PE subdomain (newly released particles have age = age_m!)
4480	IF ( particles(n)%age /= particles(n)%age_m ) THEN
4481	IF ( ABS(particles(n)%speed_x) > &
4482	((nxr-nxl+2)*dx)/(particles(n)%age-particles(n)%age_m) .OR. &
4483	ABS(particles(n)%speed_y) > &
4484	((nyn-nys+2)*dy)/(particles(n)%age-particles(n)%age_m) ) THEN
4485
4486	WRITE( message_string, * ) 'particle too fast. n = ', n
4487	CALL message( 'lpm_boundary_conds', 'PA0148', 2, 2, -1, 6, 1 )
4488	ENDIF
4489	ENDIF
4490
4491	IF ( particles(n)%age > particle_maximum_age .AND. &
4492	particles(n)%particle_mask ) &
4493	THEN
4494	particles(n)%particle_mask = .FALSE.
4495	deleted_particles = deleted_particles + 1
4496	ENDIF
4497
4498	IF ( particles(n)%z >= zw(nz) .AND. particles(n)%particle_mask ) THEN
4499	IF ( ibc_par_t == 1 ) THEN
4500	!
4501	!-- Particle absorption
4502	particles(n)%particle_mask = .FALSE.
4503	deleted_particles = deleted_particles + 1
4504	ELSEIF ( ibc_par_t == 2 ) THEN
4505	!
4506	!-- Particle reflection
4507	particles(n)%z = 2.0_wp * zw(nz) - particles(n)%z
4508	particles(n)%speed_z = -particles(n)%speed_z
4509	IF ( use_sgs_for_particles .AND. &
4510	particles(n)%rvar3 > 0.0_wp ) THEN
4511	particles(n)%rvar3 = -particles(n)%rvar3
4512	ENDIF
4513	ENDIF
4514	ENDIF
4515
4516	IF ( particles(n)%z < zw(0) .AND. particles(n)%particle_mask ) THEN
4517	IF ( ibc_par_b == 1 ) THEN
4518	!
4519	!-- Particle absorption
4520	particles(n)%particle_mask = .FALSE.
4521	deleted_particles = deleted_particles + 1
4522	ELSEIF ( ibc_par_b == 2 ) THEN
4523	!
4524	!-- Particle reflection
4525	particles(n)%z = 2.0_wp * zw(0) - particles(n)%z
4526	particles(n)%speed_z = -particles(n)%speed_z
4527	IF ( use_sgs_for_particles .AND. &
4528	particles(n)%rvar3 < 0.0_wp ) THEN
4529	particles(n)%rvar3 = -particles(n)%rvar3
4530	ENDIF
4531	ELSEIF ( ibc_par_b == 3 ) THEN
4532	!
4533	!-- Find reset height. @note this works only in non-strechted cases
4534	particles_top = INT( pst(1) / dz(1) )
4535	index_reset = MINLOC( prt_count(nzb+1:particles_top,j,i), DIM = 1 )
4536	reset_top = zu(index_reset)
4537	iran_part = iran_part + myid
4538	ran_val = random_function( iran_part )
4539	particles(n)%z = reset_top * ( 1.0 + ( ran_val / 10.0_wp) )
4540	particles(n)%speed_z = 0.0_wp
4541	IF ( curvature_solution_effects ) THEN
4542	particles(n)%radius = particles(n)%aux1
4543	ELSE
4544	particles(n)%radius = 1.0E-8
4545	ENDIF
4546	ENDIF
4547	ENDIF
4548	ENDDO
4549
4550	CASE ( 'walls' )
4551
4552	CALL cpu_log( log_point_s(48), 'lpm_wall_reflect', 'start' )
4553
4554	DO n = 1, number_of_particles
4555	!
4556	!-- Recalculate particle timestep
4557	dt_particle = particles(n)%age - particles(n)%age_m
4558	!
4559	!-- Obtain x/y indices for current particle position
4560	i2 = particles(n)%x * ddx
4561	j2 = particles(n)%y * ddy
4562	IF ( zw(k) < particles(n)%z ) k2 = k + 1
4563	IF ( zw(k) > particles(n)%z .AND. zw(k-1) < particles(n)%z ) k2 = k
4564	IF ( zw(k-1) > particles(n)%z ) k2 = k - 1
4565	!
4566	!-- Save current particle positions
4567	prt_x = particles(n)%x
4568	prt_y = particles(n)%y
4569	prt_z = particles(n)%z
4570	!
4571	!-- Recalculate old particle positions
4572	pos_x_old = particles(n)%x - particles(n)%speed_x * dt_particle
4573	pos_y_old = particles(n)%y - particles(n)%speed_y * dt_particle
4574	pos_z_old = particles(n)%z - particles(n)%speed_z * dt_particle
4575	!
4576	!-- Obtain x/y indices for old particle positions
4577	i1 = i
4578	j1 = j
4579	k1 = k
4580	!
4581	!-- Determine horizontal as well as vertical walls at which particle can
4582	!-- be potentially reflected.
4583	!-- Start with walls aligned in yz layer.
4584	!-- Wall to the right
4585	IF ( prt_x > pos_x_old ) THEN
4586	xwall = ( i1 + 1 ) * dx
4587	!
4588	!-- Wall to the left
4589	ELSE
4590	xwall = i1 * dx
4591	ENDIF
4592	!
4593	!-- Walls aligned in xz layer
4594	!-- Wall to the north
4595	IF ( prt_y > pos_y_old ) THEN
4596	ywall = ( j1 + 1 ) * dy
4597	!-- Wall to the south
4598	ELSE
4599	ywall = j1 * dy
4600	ENDIF
4601
4602	IF ( prt_z > pos_z_old ) THEN
4603	zwall = zw(k)
4604	ELSE
4605	zwall = zw(k-1)
4606	ENDIF
4607	!
4608	!-- Initialize flags to check if particle reflection is necessary
4609	cross_wall_x = .FALSE.
4610	cross_wall_y = .FALSE.
4611	cross_wall_z = .FALSE.
4612	!
4613	!-- Initialize flags to check if a wall is reached
4614	reach_x = .FALSE.
4615	reach_y = .FALSE.
4616	reach_z = .FALSE.
4617	!
4618	!-- Initialize flags to check if a particle was already reflected
4619	reflect_x = .FALSE.
4620	reflect_y = .FALSE.
4621	reflect_z = .FALSE.
4622	!
4623	!-- Initialize flags to check if a wall is already crossed.
4624	!-- ( Required to obtain correct indices. )
4625	x_wall_reached = .FALSE.
4626	y_wall_reached = .FALSE.
4627	z_wall_reached = .FALSE.
4628	!
4629	!-- Initialize time array
4630	t = 0.0_wp
4631	!
4632	!-- Check if particle can reach any wall. This case, calculate the
4633	!-- fractional time needed to reach this wall. Store this fractional
4634	!-- timestep in array t. Moreover, store indices for these grid
4635	!-- boxes where the respective wall belongs to.
4636	!-- Start with x-direction.
4637	t_index = 1
4638	t(t_index) = ( xwall - pos_x_old ) &
4639	/ MERGE( MAX( prt_x - pos_x_old, 1E-30_wp ), &
4640	MIN( prt_x - pos_x_old, -1E-30_wp ), &
4641	prt_x > pos_x_old )
4642	x_ind(t_index) = i2
4643	y_ind(t_index) = j1
4644	z_ind(t_index) = k1
4645	reach_x(t_index) = .TRUE.
4646	reach_y(t_index) = .FALSE.
4647	reach_z(t_index) = .FALSE.
4648	!
4649	!-- Store these values only if particle really reaches any wall. t must
4650	!-- be in a interval between [0:1].
4651	IF ( t(t_index) <= 1.0_wp .AND. t(t_index) >= 0.0_wp ) THEN
4652	t_index = t_index + 1
4653	cross_wall_x = .TRUE.
4654	ENDIF
4655	!
4656	!-- y-direction
4657	t(t_index) = ( ywall - pos_y_old ) &
4658	/ MERGE( MAX( prt_y - pos_y_old, 1E-30_wp ), &
4659	MIN( prt_y - pos_y_old, -1E-30_wp ), &
4660	prt_y > pos_y_old )
4661	x_ind(t_index) = i1
4662	y_ind(t_index) = j2
4663	z_ind(t_index) = k1
4664	reach_x(t_index) = .FALSE.
4665	reach_y(t_index) = .TRUE.
4666	reach_z(t_index) = .FALSE.
4667	IF ( t(t_index) <= 1.0_wp .AND. t(t_index) >= 0.0_wp ) THEN
4668	t_index = t_index + 1
4669	cross_wall_y = .TRUE.
4670	ENDIF
4671	!
4672	!-- z-direction
4673	t(t_index) = (zwall - pos_z_old ) &
4674	/ MERGE( MAX( prt_z - pos_z_old, 1E-30_wp ), &
4675	MIN( prt_z - pos_z_old, -1E-30_wp ), &
4676	prt_z > pos_z_old )
4677
4678	x_ind(t_index) = i1
4679	y_ind(t_index) = j1
4680	z_ind(t_index) = k2
4681	reach_x(t_index) = .FALSE.
4682	reach_y(t_index) = .FALSE.
4683	reach_z(t_index) = .TRUE.
4684	IF( t(t_index) <= 1.0_wp .AND. t(t_index) >= 0.0_wp) THEN
4685	t_index = t_index + 1
4686	cross_wall_z = .TRUE.
4687	ENDIF
4688
4689	t_index_number = t_index - 1
4690	!
4691	!-- Carry out reflection only if particle reaches any wall
4692	IF ( cross_wall_x .OR. cross_wall_y .OR. cross_wall_z ) THEN
4693	!
4694	!-- Sort fractional timesteps in ascending order. Also sort the
4695	!-- corresponding indices and flag according to the time interval a
4696	!-- particle reaches the respective wall.
4697	inc = 1
4698	jr = 1
4699	DO WHILE ( inc <= t_index_number )
4700	inc = 3 * inc + 1
4701	ENDDO
4702
4703	DO WHILE ( inc > 1 )
4704	inc = inc / 3
4705	DO ir = inc+1, t_index_number
4706	tmp_t = t(ir)
4707	tmp_x = x_ind(ir)
4708	tmp_y = y_ind(ir)
4709	tmp_z = z_ind(ir)
4710	tmp_reach_x = reach_x(ir)
4711	tmp_reach_y = reach_y(ir)
4712	tmp_reach_z = reach_z(ir)
4713	jr = ir
4714	DO WHILE ( t(jr-inc) > tmp_t )
4715	t(jr) = t(jr-inc)
4716	x_ind(jr) = x_ind(jr-inc)
4717	y_ind(jr) = y_ind(jr-inc)
4718	z_ind(jr) = z_ind(jr-inc)
4719	reach_x(jr) = reach_x(jr-inc)
4720	reach_y(jr) = reach_y(jr-inc)
4721	reach_z(jr) = reach_z(jr-inc)
4722	jr = jr - inc
4723	IF ( jr <= inc ) EXIT
4724	ENDDO
4725	t(jr) = tmp_t
4726	x_ind(jr) = tmp_x
4727	y_ind(jr) = tmp_y
4728	z_ind(jr) = tmp_z
4729	reach_x(jr) = tmp_reach_x
4730	reach_y(jr) = tmp_reach_y
4731	reach_z(jr) = tmp_reach_z
4732	ENDDO
4733	ENDDO
4734	!
4735	!-- Initialize temporary particle positions
4736	pos_x = pos_x_old
4737	pos_y = pos_y_old
4738	pos_z = pos_z_old
4739	!
4740	!-- Loop over all times a particle possibly moves into a new grid box
4741	t_old = 0.0_wp
4742	DO t_index = 1, t_index_number
4743	!
4744	!-- Calculate intermediate particle position according to the
4745	!-- timesteps a particle reaches any wall.
4746	pos_x = pos_x + ( t(t_index) - t_old ) * dt_particle &
4747	* particles(n)%speed_x
4748	pos_y = pos_y + ( t(t_index) - t_old ) * dt_particle &
4749	* particles(n)%speed_y
4750	pos_z = pos_z + ( t(t_index) - t_old ) * dt_particle &
4751	* particles(n)%speed_z
4752	!
4753	!-- Obtain x/y grid indices for intermediate particle position from
4754	!-- sorted index array
4755	i3 = x_ind(t_index)
4756	j3 = y_ind(t_index)
4757	k3 = z_ind(t_index)
4758	!
4759	!-- Check which wall is already reached
4760	IF ( .NOT. x_wall_reached ) x_wall_reached = reach_x(t_index)
4761	IF ( .NOT. y_wall_reached ) y_wall_reached = reach_y(t_index)
4762	IF ( .NOT. z_wall_reached ) z_wall_reached = reach_z(t_index)
4763	!
4764	!-- Check if a particle needs to be reflected at any yz-wall. If
4765	!-- necessary, carry out reflection. Please note, a security
4766	!-- constant is required, as the particle position does not
4767	!-- necessarily exactly match the wall location due to rounding
4768	!-- errors.
4769	IF ( reach_x(t_index) .AND. &
4770	ABS( pos_x - xwall ) < eps .AND. &
4771	.NOT. BTEST(wall_flags_total_0(k3,j3,i3),0) .AND. &
4772	.NOT. reflect_x ) THEN
4773	!
4774	!
4775	!-- Reflection in x-direction.
4776	!-- Ensure correct reflection by MIN/MAX functions, depending on
4777	!-- direction of particle transport.
4778	!-- Due to rounding errors pos_x does not exactly match the wall
4779	!-- location, leading to erroneous reflection.
4780	pos_x = MERGE( MIN( 2.0_wp * xwall - pos_x, xwall ), &
4781	MAX( 2.0_wp * xwall - pos_x, xwall ), &
4782	particles(n)%x > xwall )
4783	!
4784	!-- Change sign of particle speed
4785	particles(n)%speed_x = - particles(n)%speed_x
4786	!
4787	!-- Also change sign of subgrid-scale particle speed
4788	particles(n)%rvar1 = - particles(n)%rvar1
4789	!
4790	!-- Set flag that reflection along x is already done
4791	reflect_x = .TRUE.
4792	!
4793	!-- As the particle does not cross any further yz-wall during
4794	!-- this timestep, set further x-indices to the current one.
4795	x_ind(t_index:t_index_number) = i1
4796	!
4797	!-- If particle already reached the wall but was not reflected,
4798	!-- set further x-indices to the new one.
4799	ELSEIF ( x_wall_reached .AND. .NOT. reflect_x ) THEN
4800	x_ind(t_index:t_index_number) = i2
4801	ENDIF !particle reflection in x direction done
4802
4803	!
4804	!-- Check if a particle needs to be reflected at any xz-wall. If
4805	!-- necessary, carry out reflection. Please note, a security
4806	!-- constant is required, as the particle position does not
4807	!-- necessarily exactly match the wall location due to rounding
4808	!-- errors.
4809	IF ( reach_y(t_index) .AND. &
4810	ABS( pos_y - ywall ) < eps .AND. &
4811	.NOT. BTEST(wall_flags_total_0(k3,j3,i3),0) .AND. &
4812	.NOT. reflect_y ) THEN
4813	!
4814	!
4815	!-- Reflection in y-direction.
4816	!-- Ensure correct reflection by MIN/MAX functions, depending on
4817	!-- direction of particle transport.
4818	!-- Due to rounding errors pos_y does not exactly match the wall
4819	!-- location, leading to erroneous reflection.
4820	pos_y = MERGE( MIN( 2.0_wp * ywall - pos_y, ywall ), &
4821	MAX( 2.0_wp * ywall - pos_y, ywall ), &
4822	particles(n)%y > ywall )
4823	!
4824	!-- Change sign of particle speed
4825	particles(n)%speed_y = - particles(n)%speed_y
4826	!
4827	!-- Also change sign of subgrid-scale particle speed
4828	particles(n)%rvar2 = - particles(n)%rvar2
4829	!
4830	!-- Set flag that reflection along y is already done
4831	reflect_y = .TRUE.
4832	!
4833	!-- As the particle does not cross any further xz-wall during
4834	!-- this timestep, set further y-indices to the current one.
4835	y_ind(t_index:t_index_number) = j1
4836	!
4837	!-- If particle already reached the wall but was not reflected,
4838	!-- set further y-indices to the new one.
4839	ELSEIF ( y_wall_reached .AND. .NOT. reflect_y ) THEN
4840	y_ind(t_index:t_index_number) = j2
4841	ENDIF !particle reflection in y direction done
4842
4843	!
4844	!-- Check if a particle needs to be reflected at any xy-wall. If
4845	!-- necessary, carry out reflection. Please note, a security
4846	!-- constant is required, as the particle position does not
4847	!-- necessarily exactly match the wall location due to rounding
4848	!-- errors.
4849	IF ( reach_z(t_index) .AND. &
4850	ABS( pos_z - zwall ) < eps .AND. &
4851	.NOT. BTEST(wall_flags_total_0(k3,j3,i3),0) .AND. &
4852	.NOT. reflect_z ) THEN
4853	!
4854	!
4855	!-- Reflection in z-direction.
4856	!-- Ensure correct reflection by MIN/MAX functions, depending on
4857	!-- direction of particle transport.
4858	!-- Due to rounding errors pos_z does not exactly match the wall
4859	!-- location, leading to erroneous reflection.
4860	pos_z = MERGE( MIN( 2.0_wp * zwall - pos_z, zwall ), &
4861	MAX( 2.0_wp * zwall - pos_z, zwall ), &
4862	particles(n)%z > zwall )
4863	!
4864	!-- Change sign of particle speed
4865	particles(n)%speed_z = - particles(n)%speed_z
4866	!
4867	!-- Also change sign of subgrid-scale particle speed
4868	particles(n)%rvar3 = - particles(n)%rvar3
4869	!
4870	!-- Set flag that reflection along z is already done
4871	reflect_z = .TRUE.
4872	!
4873	!-- As the particle does not cross any further xy-wall during
4874	!-- this timestep, set further z-indices to the current one.
4875	z_ind(t_index:t_index_number) = k1
4876	!
4877	!-- If particle already reached the wall but was not reflected,
4878	!-- set further z-indices to the new one.
4879	ELSEIF ( z_wall_reached .AND. .NOT. reflect_z ) THEN
4880	z_ind(t_index:t_index_number) = k2
4881	ENDIF !particle reflection in z direction done
4882
4883	!
4884	!-- Swap time
4885	t_old = t(t_index)
4886
4887	ENDDO
4888	!
4889	!-- If a particle was reflected, calculate final position from last
4890	!-- intermediate position.
4891	IF ( reflect_x .OR. reflect_y .OR. reflect_z ) THEN
4892
4893	particles(n)%x = pos_x + ( 1.0_wp - t_old ) * dt_particle &
4894	* particles(n)%speed_x
4895	particles(n)%y = pos_y + ( 1.0_wp - t_old ) * dt_particle &
4896	* particles(n)%speed_y
4897	particles(n)%z = pos_z + ( 1.0_wp - t_old ) * dt_particle &
4898	* particles(n)%speed_z
4899
4900	ENDIF
4901
4902	ENDIF
4903
4904	ENDDO
4905
4906	CALL cpu_log( log_point_s(48), 'lpm_wall_reflect', 'stop' )
4907
4908	CASE DEFAULT
4909	CONTINUE
4910
4911	END SELECT
4912
4913	END SUBROUTINE lpm_boundary_conds
4914
4915
4916	!------------------------------------------------------------------------------!
4917	! Description:
4918	! ------------
4919	!> Calculates change in droplet radius by condensation/evaporation, using
4920	!> either an analytic formula or by numerically integrating the radius growth
4921	!> equation including curvature and solution effects using Rosenbrocks method
4922	!> (see Numerical recipes in FORTRAN, 2nd edition, p. 731).
4923	!> The analytical formula and growth equation follow those given in
4924	!> Rogers and Yau (A short course in cloud physics, 3rd edition, p. 102/103).
4925	!------------------------------------------------------------------------------!
4926	SUBROUTINE lpm_droplet_condensation (i,j,k)
4927
4928	INTEGER(iwp), INTENT(IN) :: i !<
4929	INTEGER(iwp), INTENT(IN) :: j !<
4930	INTEGER(iwp), INTENT(IN) :: k !<
4931	INTEGER(iwp) :: n !<
4932
4933	REAL(wp) :: afactor !< curvature effects
4934	REAL(wp) :: arg !<
4935	REAL(wp) :: bfactor !< solute effects
4936	REAL(wp) :: ddenom !<
4937	REAL(wp) :: delta_r !<
4938	REAL(wp) :: diameter !< diameter of cloud droplets
4939	REAL(wp) :: diff_coeff !< diffusivity for water vapor
4940	REAL(wp) :: drdt !<
4941	REAL(wp) :: dt_ros !<
4942	REAL(wp) :: dt_ros_sum !<
4943	REAL(wp) :: d2rdtdr !<
4944	REAL(wp) :: e_a !< current vapor pressure
4945	REAL(wp) :: e_s !< current saturation vapor pressure
4946	REAL(wp) :: error !< local truncation error in Rosenbrock
4947	REAL(wp) :: k1 !<
4948	REAL(wp) :: k2 !<
4949	REAL(wp) :: r_err !< First order estimate of Rosenbrock radius
4950	REAL(wp) :: r_ros !< Rosenbrock radius
4951	REAL(wp) :: r_ros_ini !< initial Rosenbrock radius
4952	REAL(wp) :: r0 !< gas-kinetic lengthscale
4953	REAL(wp) :: sigma !< surface tension of water
4954	REAL(wp) :: thermal_conductivity !< thermal conductivity for water
4955	REAL(wp) :: t_int !< temperature
4956	REAL(wp) :: w_s !< terminal velocity of droplets
4957	REAL(wp) :: re_p !< particle Reynolds number
4958	!
4959	!-- Parameters for Rosenbrock method (see Verwer et al., 1999)
4960	REAL(wp), PARAMETER :: prec = 1.0E-3_wp !< precision of Rosenbrock solution
4961	REAL(wp), PARAMETER :: q_increase = 1.5_wp !< increase factor in timestep
4962	REAL(wp), PARAMETER :: q_decrease = 0.9_wp !< decrease factor in timestep
4963	REAL(wp), PARAMETER :: gamma = 0.292893218814_wp !< = 1.0 - 1.0 / SQRT(2.0)
4964	!
4965	!-- Parameters for terminal velocity
4966	REAL(wp), PARAMETER :: a_rog = 9.65_wp !< parameter for fall velocity
4967	REAL(wp), PARAMETER :: b_rog = 10.43_wp !< parameter for fall velocity
4968	REAL(wp), PARAMETER :: c_rog = 0.6_wp !< parameter for fall velocity
4969	REAL(wp), PARAMETER :: k_cap_rog = 4.0_wp !< parameter for fall velocity
4970	REAL(wp), PARAMETER :: k_low_rog = 12.0_wp !< parameter for fall velocity
4971	REAL(wp), PARAMETER :: d0_rog = 0.745_wp !< separation diameter
4972
4973	REAL(wp), DIMENSION(number_of_particles) :: ventilation_effect !<
4974	REAL(wp), DIMENSION(number_of_particles) :: new_r !<
4975
4976	CALL cpu_log( log_point_s(42), 'lpm_droplet_condens', 'start' )
4977
4978	!
4979	!-- Absolute temperature
4980	t_int = pt(k,j,i) * exner(k)
4981	!
4982	!-- Saturation vapor pressure (Eq. 10 in Bolton, 1980)
4983	e_s = magnus( t_int )
4984	!
4985	!-- Current vapor pressure
4986	e_a = q(k,j,i) * hyp(k) / ( q(k,j,i) + rd_d_rv )
4987	!
4988	!-- Thermal conductivity for water (from Rogers and Yau, Table 7.1)
4989	thermal_conductivity = 7.94048E-05_wp * t_int + 0.00227011_wp
4990	!
4991	!-- Moldecular diffusivity of water vapor in air (Hall und Pruppacher, 1976)
4992	diff_coeff = 0.211E-4_wp * ( t_int / 273.15_wp )*1.94_wp &
4993	( 101325.0_wp / hyp(k) )
4994	!
4995	!-- Lengthscale for gas-kinetic effects (from Mordy, 1959, p. 23):
4996	r0 = diff_coeff / 0.036_wp * SQRT( 2.0_wp * pi / ( r_v * t_int ) )
4997	!
4998	!-- Calculate effects of heat conductivity and diffusion of water vapor on the
4999	!-- diffusional growth process (usually known as 1.0 / (F_k + F_d) )
5000	ddenom = 1.0_wp / ( rho_l * r_v * t_int / ( e_s * diff_coeff ) + &
5001	( l_v / ( r_v * t_int ) - 1.0_wp ) * rho_l * &
5002	l_v / ( thermal_conductivity * t_int ) &
5003	)
5004	new_r = 0.0_wp
5005	!
5006	!-- Determine ventilation effect on evaporation of large drops
5007	DO n = 1, number_of_particles
5008
5009	IF ( particles(n)%radius >= 4.0E-5_wp .AND. e_a / e_s < 1.0_wp ) THEN
5010	!
5011	!-- Terminal velocity is computed for vertical direction (Rogers et al.,
5012	!-- 1993, J. Appl. Meteorol.)
5013	diameter = particles(n)%radius * 2000.0_wp !diameter in mm
5014	IF ( diameter <= d0_rog ) THEN
5015	w_s = k_cap_rog * diameter * ( 1.0_wp - EXP( -k_low_rog * diameter ) )
5016	ELSE
5017	w_s = a_rog - b_rog * EXP( -c_rog * diameter )
5018	ENDIF
5019	!
5020	!-- Calculate droplet's Reynolds number
5021	re_p = 2.0_wp * particles(n)%radius * w_s / molecular_viscosity
5022	!
5023	!-- Ventilation coefficient (Rogers and Yau, 1989):
5024	IF ( re_p > 2.5_wp ) THEN
5025	ventilation_effect(n) = 0.78_wp + 0.28_wp * SQRT( re_p )
5026	ELSE
5027	ventilation_effect(n) = 1.0_wp + 0.09_wp * re_p
5028	ENDIF
5029	ELSE
5030	!
5031	!-- For small droplets or in supersaturated environments, the ventilation
5032	!-- effect does not play a role
5033	ventilation_effect(n) = 1.0_wp
5034	ENDIF
5035	ENDDO
5036
5037	IF( .NOT. curvature_solution_effects ) THEN
5038	!
5039	!-- Use analytic model for diffusional growth including gas-kinetic
5040	!-- effects (Mordy, 1959) but without the impact of aerosols.
5041	DO n = 1, number_of_particles
5042	arg = ( particles(n)%radius + r0 )*2 + 2.0_wp dt_3d * ddenom * &
5043	ventilation_effect(n) * &
5044	( e_a / e_s - 1.0_wp )
5045	arg = MAX( arg, ( 0.01E-6 + r0 )**2 )
5046	new_r(n) = SQRT( arg ) - r0
5047	ENDDO
5048
5049	ELSE
5050	!
5051	!-- Integrate the diffusional growth including gas-kinetic (Mordy, 1959),
5052	!-- as well as curvature and solute effects (e.g., KÃ¶hler, 1936).
5053	!
5054	!-- Curvature effect (afactor) with surface tension (sigma) by Straka (2009)
5055	sigma = 0.0761_wp - 0.000155_wp * ( t_int - 273.15_wp )
5056	!
5057	!-- Solute effect (afactor)
5058	afactor = 2.0_wp * sigma / ( rho_l * r_v * t_int )
5059
5060	DO n = 1, number_of_particles
5061	!
5062	!-- Solute effect (bfactor)
5063	bfactor = vanthoff * rho_s * particles(n)%aux1*3 &
5064	molecular_weight_of_water / ( rho_l * molecular_weight_of_solute )
5065
5066	dt_ros = particles(n)%aux2 ! use previously stored Rosenbrock timestep
5067	dt_ros_sum = 0.0_wp
5068
5069	r_ros = particles(n)%radius ! initialize Rosenbrock particle radius
5070	r_ros_ini = r_ros
5071	!
5072	!-- Integrate growth equation using a 2nd-order Rosenbrock method
5073	!-- (see Verwer et al., 1999, Eq. (3.2)). The Rosenbrock method adjusts
5074	!-- its with internal timestep to minimize the local truncation error.
5075	DO WHILE ( dt_ros_sum < dt_3d )
5076
5077	dt_ros = MIN( dt_ros, dt_3d - dt_ros_sum )
5078
5079	DO
5080
5081	drdt = ddenom * ventilation_effect(n) * ( e_a / e_s - 1.0_wp - &
5082	afactor / r_ros + &
5083	bfactor / r_ros**3 &
5084	) / ( r_ros + r0 )
5085
5086	d2rdtdr = -ddenom * ventilation_effect(n) * ( &
5087	(e_a / e_s - 1.0_wp ) * r_ros**4 - &
5088	afactor * r0 * r_ros**2 - &
5089	2.0_wp * afactor * r_ros**3 + &
5090	3.0_wp * bfactor * r0 + &
5091	4.0_wp * bfactor * r_ros &
5092	) &
5093	/ ( r_ros*4 ( r_ros + r0 )**2 )
5094
5095	k1 = drdt / ( 1.0_wp - gamma * dt_ros * d2rdtdr )
5096
5097	r_ros = MAX(r_ros_ini + k1 * dt_ros, particles(n)%aux1)
5098	r_err = r_ros
5099
5100	drdt = ddenom * ventilation_effect(n) * ( e_a / e_s - 1.0_wp - &
5101	afactor / r_ros + &
5102	bfactor / r_ros**3 &
5103	) / ( r_ros + r0 )
5104
5105	k2 = ( drdt - dt_ros * 2.0 * gamma * d2rdtdr * k1 ) / &
5106	( 1.0_wp - dt_ros * gamma * d2rdtdr )
5107
5108	r_ros = MAX(r_ros_ini + dt_ros * ( 1.5_wp * k1 + 0.5_wp * k2), particles(n)%aux1)
5109	!
5110	!-- Check error of the solution, and reduce dt_ros if necessary.
5111	error = ABS(r_err - r_ros) / r_ros
5112	IF ( error > prec ) THEN
5113	dt_ros = SQRT( q_decrease * prec / error ) * dt_ros
5114	r_ros = r_ros_ini
5115	ELSE
5116	dt_ros_sum = dt_ros_sum + dt_ros
5117	dt_ros = q_increase * dt_ros
5118	r_ros_ini = r_ros
5119	EXIT
5120	ENDIF
5121
5122	END DO
5123
5124	END DO !Rosenbrock loop
5125	!
5126	!-- Store new particle radius
5127	new_r(n) = r_ros
5128	!
5129	!-- Store internal time step value for next PALM step
5130	particles(n)%aux2 = dt_ros
5131
5132	ENDDO !Particle loop
5133
5134	ENDIF
5135
5136	DO n = 1, number_of_particles
5137	!
5138	!-- Sum up the change in liquid water for the respective grid
5139	!-- box for the computation of the release/depletion of water vapor
5140	!-- and heat.
5141	ql_c(k,j,i) = ql_c(k,j,i) + particles(n)%weight_factor * &
5142	rho_l * 1.33333333_wp * pi * &
5143	( new_r(n)3 - particles(n)%radius3 ) / &
5144	( rho_surface * dx * dy * dzw(k) )
5145	!
5146	!-- Check if the increase in liqid water is not too big. If this is the case,
5147	!-- the model timestep might be too long.
5148	IF ( ql_c(k,j,i) > 100.0_wp ) THEN
5149	WRITE( message_string, * ) 'k=',k,' j=',j,' i=',i, &
5150	' ql_c=',ql_c(k,j,i), '&part(',n,')%wf=', &
5151	particles(n)%weight_factor,' delta_r=',delta_r
5152	CALL message( 'lpm_droplet_condensation', 'PA0143', 2, 2, -1, 6, 1 )
5153	ENDIF
5154	!
5155	!-- Check if the change in the droplet radius is not too big. If this is the
5156	!-- case, the model timestep might be too long.
5157	delta_r = new_r(n) - particles(n)%radius
5158	IF ( delta_r < 0.0_wp .AND. new_r(n) < 0.0_wp ) THEN
5159	WRITE( message_string, * ) '#1 k=',k,' j=',j,' i=',i, &
5160	' e_s=',e_s, ' e_a=',e_a,' t_int=',t_int, &
5161	'&delta_r=',delta_r, &
5162	' particle_radius=',particles(n)%radius
5163	CALL message( 'lpm_droplet_condensation', 'PA0144', 2, 2, -1, 6, 1 )
5164	ENDIF
5165	!
5166	!-- Sum up the total volume of liquid water (needed below for
5167	!-- re-calculating the weighting factors)
5168	ql_v(k,j,i) = ql_v(k,j,i) + particles(n)%weight_factor * new_r(n)**3
5169	!
5170	!-- Determine radius class of the particle needed for collision
5171	IF ( use_kernel_tables ) THEN
5172	particles(n)%class = ( LOG( new_r(n) ) - rclass_lbound ) / &
5173	( rclass_ubound - rclass_lbound ) * &
5174	radius_classes
5175	particles(n)%class = MIN( particles(n)%class, radius_classes )
5176	particles(n)%class = MAX( particles(n)%class, 1 )
5177	ENDIF
5178	!
5179	!-- Store new radius to particle features
5180	particles(n)%radius = new_r(n)
5181
5182	ENDDO
5183
5184	CALL cpu_log( log_point_s(42), 'lpm_droplet_condens', 'stop' )
5185
5186
5187	END SUBROUTINE lpm_droplet_condensation
5188
5189
5190	!------------------------------------------------------------------------------!
5191	! Description:
5192	! ------------
5193	!> Release of latent heat and change of mixing ratio due to condensation /
5194	!> evaporation of droplets.
5195	!------------------------------------------------------------------------------!
5196	SUBROUTINE lpm_interaction_droplets_ptq
5197
5198	INTEGER(iwp) :: i !< running index x direction
5199	INTEGER(iwp) :: j !< running index y direction
5200	INTEGER(iwp) :: k !< running index z direction
5201
5202	REAL(wp) :: flag !< flag to mask topography grid points
5203
5204	DO i = nxl, nxr
5205	DO j = nys, nyn
5206	DO k = nzb+1, nzt
5207	!
5208	!-- Predetermine flag to mask topography
5209	flag = MERGE( 1.0_wp, 0.0_wp, BTEST( wall_flags_total_0(k,j,i), 0 ) )
5210
5211	q(k,j,i) = q_p(k,j,i) - ql_c(k,j,i) * flag
5212	pt(k,j,i) = pt(k,j,i) + lv_d_cp * ql_c(k,j,i) * d_exner(k) &
5213	* flag
5214	ENDDO
5215	ENDDO
5216	ENDDO
5217
5218	END SUBROUTINE lpm_interaction_droplets_ptq
5219
5220
5221	!------------------------------------------------------------------------------!
5222	! Description:
5223	! ------------
5224	!> Release of latent heat and change of mixing ratio due to condensation /
5225	!> evaporation of droplets. Call for grid point i,j
5226	!------------------------------------------------------------------------------!
5227	SUBROUTINE lpm_interaction_droplets_ptq_ij( i, j )
5228
5229	INTEGER(iwp) :: i !< running index x direction
5230	INTEGER(iwp) :: j !< running index y direction
5231	INTEGER(iwp) :: k !< running index z direction
5232
5233	REAL(wp) :: flag !< flag to mask topography grid points
5234
5235
5236	DO k = nzb+1, nzt
5237	!
5238	!-- Predetermine flag to mask topography
5239	flag = MERGE( 1.0_wp, 0.0_wp, BTEST( wall_flags_total_0(k,j,i), 0 ) )
5240
5241	q(k,j,i) = q(k,j,i) - ql_c(k,j,i) * flag
5242	pt(k,j,i) = pt(k,j,i) + lv_d_cp * ql_c(k,j,i) * d_exner(k) * flag
5243	ENDDO
5244
5245	END SUBROUTINE lpm_interaction_droplets_ptq_ij
5246
5247
5248	!------------------------------------------------------------------------------!
5249	! Description:
5250	! ------------
5251	!> Calculate the liquid water content for each grid box.
5252	!------------------------------------------------------------------------------!
5253	SUBROUTINE lpm_calc_liquid_water_content
5254
5255
5256	INTEGER(iwp) :: i !<
5257	INTEGER(iwp) :: j !<
5258	INTEGER(iwp) :: k !<
5259	INTEGER(iwp) :: n !<
5260
5261	CALL cpu_log( log_point_s(45), 'lpm_calc_ql', 'start' )
5262
5263	!
5264	!-- Set water content initially to zero
5265	ql = 0.0_wp; ql_v = 0.0_wp; ql_vp = 0.0_wp
5266
5267	!
5268	!-- Calculate for each grid box
5269	DO i = nxl, nxr
5270	DO j = nys, nyn
5271	DO k = nzb+1, nzt
5272	number_of_particles = prt_count(k,j,i)
5273	IF ( number_of_particles <= 0 ) CYCLE
5274	particles => grid_particles(k,j,i)%particles(1:number_of_particles)
5275	!
5276	!-- Calculate the total volume in the boxes (ql_v, weighting factor
5277	!-- has to beincluded)
5278	DO n = 1, prt_count(k,j,i)
5279	ql_v(k,j,i) = ql_v(k,j,i) + particles(n)%weight_factor * &
5280	particles(n)%radius**3
5281	ENDDO
5282	!
5283	!-- Calculate the liquid water content
5284	IF ( ql_v(k,j,i) /= 0.0_wp ) THEN
5285	ql(k,j,i) = ql(k,j,i) + rho_l * 1.33333333_wp * pi * &
5286	ql_v(k,j,i) / &
5287	( rho_surface * dx * dy * dzw(k) )
5288	IF ( ql(k,j,i) < 0.0_wp ) THEN
5289	WRITE( message_string, * ) 'LWC out of range: ' , &
5290	ql(k,j,i),i,j,k
5291	CALL message( 'lpm_calc_liquid_water_content', '', 2, 2, &
5292	-1, 6, 1 )
5293	ENDIF
5294	ELSE
5295	ql(k,j,i) = 0.0_wp
5296	ENDIF
5297	ENDDO
5298	ENDDO
5299	ENDDO
5300
5301	CALL cpu_log( log_point_s(45), 'lpm_calc_ql', 'stop' )
5302
5303	END SUBROUTINE lpm_calc_liquid_water_content
5304
5305
5306	!------------------------------------------------------------------------------!
5307	! Description:
5308	! ------------
5309	!> Calculates change in droplet radius by collision. Droplet collision is
5310	!> calculated for each grid box seperately. Collision is parameterized by
5311	!> using collision kernels. Two different kernels are available:
5312	!> Hall kernel: Kernel from Hall (1980, J. Atmos. Sci., 2486-2507), which
5313	!> considers collision due to pure gravitational effects.
5314	!> Wang kernel: Beside gravitational effects (treated with the Hall-kernel) also
5315	!> the effects of turbulence on the collision are considered using
5316	!> parameterizations of Ayala et al. (2008, New J. Phys., 10,
5317	!> 075015) and Wang and Grabowski (2009, Atmos. Sci. Lett., 10,
5318	!> 1-8). This kernel includes three possible effects of turbulence:
5319	!> the modification of the relative velocity between the droplets,
5320	!> the effect of preferential concentration, and the enhancement of
5321	!> collision efficiencies.
5322	!------------------------------------------------------------------------------!
5323	SUBROUTINE lpm_droplet_collision (i,j,k)
5324
5325	INTEGER(iwp), INTENT(IN) :: i !<
5326	INTEGER(iwp), INTENT(IN) :: j !<
5327	INTEGER(iwp), INTENT(IN) :: k !<
5328
5329	INTEGER(iwp) :: eclass !<
5330	INTEGER(iwp) :: n !<
5331	INTEGER(iwp) :: m !<
5332	INTEGER(iwp) :: rclass_l !<
5333	INTEGER(iwp) :: rclass_s !<
5334
5335	REAL(wp) :: collection_probability !< probability for collection
5336	REAL(wp) :: ddV !< inverse grid box volume
5337	REAL(wp) :: epsilon_collision !< dissipation rate
5338	REAL(wp) :: factor_volume_to_mass !< 4.0 / 3.0 * pi * rho_l
5339	REAL(wp) :: xm !< droplet mass of super-droplet m
5340	REAL(wp) :: xn !< droplet mass of super-droplet n
5341	REAL(wp) :: xsm !< aerosol mass of super-droplet m
5342	REAL(wp) :: xsn !< aerosol mass of super-droplet n
5343
5344	REAL(wp), DIMENSION(:), ALLOCATABLE :: weight !< weighting factor
5345	REAL(wp), DIMENSION(:), ALLOCATABLE :: mass !< total mass of super droplet
5346	REAL(wp), DIMENSION(:), ALLOCATABLE :: aero_mass !< total aerosol mass of super droplet
5347
5348	CALL cpu_log( log_point_s(43), 'lpm_droplet_coll', 'start' )
5349
5350	number_of_particles = prt_count(k,j,i)
5351	factor_volume_to_mass = 4.0_wp / 3.0_wp * pi * rho_l
5352	ddV = 1.0_wp / ( dx * dy * dzw(k) )
5353	!
5354	!-- Collision requires at least one super droplet inside the box
5355	IF ( number_of_particles > 0 ) THEN
5356
5357	IF ( use_kernel_tables ) THEN
5358	!
5359	!-- Fast method with pre-calculated collection kernels for
5360	!-- discrete radius- and dissipation-classes.
5361	IF ( wang_kernel ) THEN
5362	eclass = INT( diss(k,j,i) * 1.0E4_wp / 600.0_wp * &
5363	dissipation_classes ) + 1
5364	epsilon_collision = diss(k,j,i)
5365	ELSE
5366	epsilon_collision = 0.0_wp
5367	ENDIF
5368
5369	IF ( hall_kernel .OR. epsilon_collision * 1.0E4_wp < 0.001_wp ) THEN
5370	eclass = 0 ! Hall kernel is used
5371	ELSE
5372	eclass = MIN( dissipation_classes, eclass )
5373	ENDIF
5374
5375	ELSE
5376	!
5377	!-- Collection kernels are re-calculated for every new
5378	!-- grid box. First, allocate memory for kernel table.
5379	!-- Third dimension is 1, because table is re-calculated for
5380	!-- every new dissipation value.
5381	ALLOCATE( ckernel(1:number_of_particles,1:number_of_particles,1:1) )
5382	!
5383	!-- Now calculate collection kernel for this box. Note that
5384	!-- the kernel is based on the previous time step
5385	CALL recalculate_kernel( i, j, k )
5386
5387	ENDIF
5388	!
5389	!-- Temporary fields for total mass of super-droplet, aerosol mass, and
5390	!-- weighting factor are allocated.
5391	ALLOCATE(mass(1:number_of_particles), weight(1:number_of_particles))
5392	IF ( curvature_solution_effects ) ALLOCATE(aero_mass(1:number_of_particles))
5393
5394	mass(1:number_of_particles) = particles(1:number_of_particles)%weight_factor * &
5395	particles(1:number_of_particles)%radius*3 &
5396	factor_volume_to_mass
5397
5398	weight(1:number_of_particles) = particles(1:number_of_particles)%weight_factor
5399
5400	IF ( curvature_solution_effects ) THEN
5401	aero_mass(1:number_of_particles) = particles(1:number_of_particles)%weight_factor * &
5402	particles(1:number_of_particles)%aux1*3 &
5403	4.0_wp / 3.0_wp * pi * rho_s
5404	ENDIF
5405	!
5406	!-- Calculate collision/coalescence
5407	DO n = 1, number_of_particles
5408
5409	DO m = n, number_of_particles
5410	!
5411	!-- For collisions, the weighting factor of at least one super-droplet
5412	!-- needs to be larger or equal to one.
5413	IF ( MIN( weight(n), weight(m) ) < 1.0_wp ) CYCLE
5414	!
5415	!-- Get mass of individual droplets (aerosols)
5416	xn = mass(n) / weight(n)
5417	xm = mass(m) / weight(m)
5418	IF ( curvature_solution_effects ) THEN
5419	xsn = aero_mass(n) / weight(n)
5420	xsm = aero_mass(m) / weight(m)
5421	ENDIF
5422	!
5423	!-- Probability that the necessary collisions take place
5424	IF ( use_kernel_tables ) THEN
5425	rclass_l = particles(n)%class
5426	rclass_s = particles(m)%class
5427
5428	collection_probability = MAX( weight(n), weight(m) ) * &
5429	ckernel(rclass_l,rclass_s,eclass) * ddV * dt_3d
5430	ELSE
5431	collection_probability = MAX( weight(n), weight(m) ) * &
5432	ckernel(n,m,1) * ddV * dt_3d
5433	ENDIF
5434	!
5435	!-- Calculate the number of collections and consider multiple collections.
5436	!-- (Accordingly, p_crit will be 0.0, 1.0, 2.0, ...)
5437	IF ( collection_probability - FLOOR(collection_probability) &
5438	> random_function( iran_part ) ) THEN
5439	collection_probability = FLOOR(collection_probability) + 1.0_wp
5440	ELSE
5441	collection_probability = FLOOR(collection_probability)
5442	ENDIF
5443
5444	IF ( collection_probability > 0.0_wp ) THEN
5445	!
5446	!-- Super-droplet n collects droplets of super-droplet m
5447	IF ( weight(n) < weight(m) ) THEN
5448
5449	mass(n) = mass(n) + weight(n) * xm * collection_probability
5450	weight(m) = weight(m) - weight(n) * collection_probability
5451	mass(m) = mass(m) - weight(n) * xm * collection_probability
5452	IF ( curvature_solution_effects ) THEN
5453	aero_mass(n) = aero_mass(n) + weight(n) * xsm * collection_probability
5454	aero_mass(m) = aero_mass(m) - weight(n) * xsm * collection_probability
5455	ENDIF
5456
5457	ELSEIF ( weight(m) < weight(n) ) THEN
5458
5459	mass(m) = mass(m) + weight(m) * xn * collection_probability
5460	weight(n) = weight(n) - weight(m) * collection_probability
5461	mass(n) = mass(n) - weight(m) * xn * collection_probability
5462	IF ( curvature_solution_effects ) THEN
5463	aero_mass(m) = aero_mass(m) + weight(m) * xsn * collection_probability
5464	aero_mass(n) = aero_mass(n) - weight(m) * xsn * collection_probability
5465	ENDIF
5466
5467	ELSE
5468	!
5469	!-- Collisions of particles of the same weighting factor.
5470	!-- Particle n collects 1/2 weight(n) droplets of particle m,
5471	!-- particle m collects 1/2 weight(m) droplets of particle n.
5472	!-- The total mass mass changes accordingly.
5473	!-- If n = m, the first half of the droplets coalesces with the
5474	!-- second half of the droplets; mass is unchanged because
5475	!-- xm = xn for n = m.
5476	!--
5477	!-- Note: For m = n this equation is an approximation only
5478	!-- valid for weight >> 1 (which is usually the case). The
5479	!-- approximation is weight(n)-1 = weight(n).
5480	mass(n) = mass(n) + 0.5_wp * weight(n) * ( xm - xn )
5481	mass(m) = mass(m) + 0.5_wp * weight(m) * ( xn - xm )
5482	IF ( curvature_solution_effects ) THEN
5483	aero_mass(n) = aero_mass(n) + 0.5_wp * weight(n) * ( xsm - xsn )
5484	aero_mass(m) = aero_mass(m) + 0.5_wp * weight(m) * ( xsn - xsm )
5485	ENDIF
5486	weight(n) = weight(n) - 0.5_wp * weight(m)
5487	weight(m) = weight(n)
5488
5489	ENDIF
5490
5491	ENDIF
5492
5493	ENDDO
5494
5495	ql_vp(k,j,i) = ql_vp(k,j,i) + mass(n) / factor_volume_to_mass
5496
5497	ENDDO
5498
5499	IF ( ANY(weight < 0.0_wp) ) THEN
5500	WRITE( message_string, * ) 'negative weighting factor'
5501	CALL message( 'lpm_droplet_collision', 'PA0028', &
5502	2, 2, -1, 6, 1 )
5503	ENDIF
5504
5505	particles(1:number_of_particles)%radius = ( mass(1:number_of_particles) / &
5506	( weight(1:number_of_particles) &
5507	* factor_volume_to_mass &
5508	) &
5509	)**0.33333333333333_wp
5510
5511	IF ( curvature_solution_effects ) THEN
5512	particles(1:number_of_particles)%aux1 = ( aero_mass(1:number_of_particles) / &
5513	( weight(1:number_of_particles) &
5514	* 4.0_wp / 3.0_wp * pi * rho_s &
5515	) &
5516	)**0.33333333333333_wp
5517	ENDIF
5518
5519	particles(1:number_of_particles)%weight_factor = weight(1:number_of_particles)
5520
5521	DEALLOCATE( weight, mass )
5522	IF ( curvature_solution_effects ) DEALLOCATE( aero_mass )
5523	IF ( .NOT. use_kernel_tables ) DEALLOCATE( ckernel )
5524
5525	!
5526	!-- Check if LWC is conserved during collision process
5527	IF ( ql_v(k,j,i) /= 0.0_wp ) THEN
5528	IF ( ql_vp(k,j,i) / ql_v(k,j,i) >= 1.0001_wp .OR. &
5529	ql_vp(k,j,i) / ql_v(k,j,i) <= 0.9999_wp ) THEN
5530	WRITE( message_string, * ) ' LWC is not conserved during', &
5531	' collision! ', &
5532	' LWC after condensation: ', ql_v(k,j,i), &
5533	' LWC after collision: ', ql_vp(k,j,i)
5534	CALL message( 'lpm_droplet_collision', 'PA0040', 2, 2, -1, 6, 1 )
5535	ENDIF
5536	ENDIF
5537
5538	ENDIF
5539
5540	CALL cpu_log( log_point_s(43), 'lpm_droplet_coll', 'stop' )
5541
5542	END SUBROUTINE lpm_droplet_collision
5543
5544	!------------------------------------------------------------------------------!
5545	! Description:
5546	! ------------
5547	!> Initialization of the collision efficiency matrix with fixed radius and
5548	!> dissipation classes, calculated at simulation start only.
5549	!------------------------------------------------------------------------------!
5550	SUBROUTINE lpm_init_kernels
5551
5552	INTEGER(iwp) :: i !<
5553	INTEGER(iwp) :: j !<
5554	INTEGER(iwp) :: k !<
5555
5556	!
5557	!-- Calculate collision efficiencies for fixed radius- and dissipation
5558	!-- classes
5559	IF ( collision_kernel(6:9) == 'fast' ) THEN
5560
5561	ALLOCATE( ckernel(1:radius_classes,1:radius_classes, &
5562	0:dissipation_classes), epsclass(1:dissipation_classes), &
5563	radclass(1:radius_classes) )
5564
5565	!
5566	!-- Calculate the radius class bounds with logarithmic distances
5567	!-- in the interval [1.0E-6, 1000.0E-6] m
5568	rclass_lbound = LOG( 1.0E-6_wp )
5569	rclass_ubound = LOG( 1000.0E-6_wp )
5570	radclass(1) = EXP( rclass_lbound )
5571	DO i = 2, radius_classes
5572	radclass(i) = EXP( rclass_lbound + &
5573	( rclass_ubound - rclass_lbound ) * &
5574	( i - 1.0_wp ) / ( radius_classes - 1.0_wp ) )
5575	ENDDO
5576
5577	!
5578	!-- Set the class bounds for dissipation in interval [0.0, 600.0] cm2/s3
5579	DO i = 1, dissipation_classes
5580	epsclass(i) = 0.06_wp * REAL( i, KIND=wp ) / dissipation_classes
5581	ENDDO
5582	!
5583	!-- Calculate collision efficiencies of the Wang/ayala kernel
5584	ALLOCATE( ec(1:radius_classes,1:radius_classes), &
5585	ecf(1:radius_classes,1:radius_classes), &
5586	gck(1:radius_classes,1:radius_classes), &
5587	winf(1:radius_classes) )
5588
5589	DO k = 1, dissipation_classes
5590
5591	epsilon_collision = epsclass(k)
5592	urms = 2.02_wp * ( epsilon_collision / 0.04_wp )**( 1.0_wp / 3.0_wp )
5593
5594	CALL turbsd
5595	CALL turb_enhance_eff
5596	CALL effic
5597
5598	DO j = 1, radius_classes
5599	DO i = 1, radius_classes
5600	ckernel(i,j,k) = ec(i,j) * gck(i,j) * ecf(i,j)
5601	ENDDO
5602	ENDDO
5603
5604	ENDDO
5605
5606	!
5607	!-- Calculate collision efficiencies of the Hall kernel
5608	ALLOCATE( hkernel(1:radius_classes,1:radius_classes), &
5609	hwratio(1:radius_classes,1:radius_classes) )
5610
5611	CALL fallg
5612	CALL effic
5613
5614	DO j = 1, radius_classes
5615	DO i = 1, radius_classes
5616	hkernel(i,j) = pi * ( radclass(j) + radclass(i) )**2 &
5617	* ec(i,j) * ABS( winf(j) - winf(i) )
5618	ckernel(i,j,0) = hkernel(i,j) ! hall kernel stored on index 0
5619	ENDDO
5620	ENDDO
5621
5622	!
5623	!-- Test output of efficiencies
5624	IF ( j == -1 ) THEN
5625	PRINT, '** Hall kernel'
5626	WRITE ( ,'(5X,20(F4.0,1X))' ) ( radclass(i)1.0E6_wp, &
5627	i = 1,radius_classes )
5628	DO j = 1, radius_classes
5629	WRITE ( *,'(F4.0,1X,20(F8.4,1X))' ) radclass(j), &
5630	( hkernel(i,j), i = 1,radius_classes )
5631	ENDDO
5632
5633	DO k = 1, dissipation_classes
5634	DO i = 1, radius_classes
5635	DO j = 1, radius_classes
5636	IF ( hkernel(i,j) == 0.0_wp ) THEN
5637	hwratio(i,j) = 9999999.9_wp
5638	ELSE
5639	hwratio(i,j) = ckernel(i,j,k) / hkernel(i,j)
5640	ENDIF
5641	ENDDO
5642	ENDDO
5643
5644	PRINT, '** epsilon = ', epsclass(k)
5645	WRITE ( ,'(5X,20(F4.0,1X))' ) ( radclass(i) 1.0E6_wp, &
5646	i = 1,radius_classes )
5647	DO j = 1, radius_classes
5648	WRITE ( ,'(F4.0,1X,20(F8.4,1X))' ) radclass(j) 1.0E6_wp, &
5649	( hwratio(i,j), i = 1,radius_classes )
5650	ENDDO
5651	ENDDO
5652	ENDIF
5653
5654	DEALLOCATE( ec, ecf, epsclass, gck, hkernel, winf )
5655
5656	ENDIF
5657
5658	END SUBROUTINE lpm_init_kernels
5659
5660	!------------------------------------------------------------------------------!
5661	! Description:
5662	! ------------
5663	!> Calculation of collision kernels during each timestep and for each grid box
5664	!------------------------------------------------------------------------------!
5665	SUBROUTINE recalculate_kernel( i1, j1, k1 )
5666
5667
5668	INTEGER(iwp) :: i !<
5669	INTEGER(iwp) :: i1 !<
5670	INTEGER(iwp) :: j !<
5671	INTEGER(iwp) :: j1 !<
5672	INTEGER(iwp) :: k1 !<
5673
5674
5675	number_of_particles = prt_count(k1,j1,i1)
5676	radius_classes = number_of_particles ! necessary to use the same
5677	! subroutines as for
5678	! precalculated kernels
5679
5680	ALLOCATE( ec(1:number_of_particles,1:number_of_particles), &
5681	radclass(1:number_of_particles), winf(1:number_of_particles) )
5682
5683	!
5684	!-- Store particle radii on the radclass array
5685	radclass(1:number_of_particles) = particles(1:number_of_particles)%radius
5686
5687	IF ( wang_kernel ) THEN
5688	epsilon_collision = diss(k1,j1,i1) ! dissipation rate in m2/s3
5689	ELSE
5690	epsilon_collision = 0.0_wp
5691	ENDIF
5692	urms = 2.02_wp * ( epsilon_collision / 0.04_wp )**( 0.33333333333_wp )
5693
5694	IF ( wang_kernel .AND. epsilon_collision > 1.0E-7_wp ) THEN
5695	!
5696	!-- Call routines to calculate efficiencies for the Wang kernel
5697	ALLOCATE( gck(1:number_of_particles,1:number_of_particles), &
5698	ecf(1:number_of_particles,1:number_of_particles) )
5699
5700	CALL turbsd
5701	CALL turb_enhance_eff
5702	CALL effic
5703
5704	DO j = 1, number_of_particles
5705	DO i = 1, number_of_particles
5706	ckernel(1+i-1,1+j-1,1) = ec(i,j) * gck(i,j) * ecf(i,j)
5707	ENDDO
5708	ENDDO
5709
5710	DEALLOCATE( gck, ecf )
5711	ELSE
5712	!
5713	!-- Call routines to calculate efficiencies for the Hall kernel
5714	CALL fallg
5715	CALL effic
5716
5717	DO j = 1, number_of_particles
5718	DO i = 1, number_of_particles
5719	ckernel(i,j,1) = pi * ( radclass(j) + radclass(i) )**2 &
5720	* ec(i,j) * ABS( winf(j) - winf(i) )
5721	ENDDO
5722	ENDDO
5723	ENDIF
5724
5725	DEALLOCATE( ec, radclass, winf )
5726
5727	END SUBROUTINE recalculate_kernel
5728
5729	!------------------------------------------------------------------------------!
5730	! Description:
5731	! ------------
5732	!> Calculation of effects of turbulence on the geometric collision kernel
5733	!> (by including the droplets' average radial relative velocities and their
5734	!> radial distribution function) following the analytic model by Aayala et al.
5735	!> (2008, New J. Phys.). For details check the second part 2 of the publication,
5736	!> page 37ff.
5737	!>
5738	!> Input parameters, which need to be replaced by PALM parameters:
5739	!> water density, air density
5740	!------------------------------------------------------------------------------!
5741	SUBROUTINE turbsd
5742
5743	INTEGER(iwp) :: i !<
5744	INTEGER(iwp) :: j !<
5745
5746	REAL(wp) :: ao !<
5747	REAL(wp) :: ao_gr !<
5748	REAL(wp) :: bbb !<
5749	REAL(wp) :: be !<
5750	REAL(wp) :: b1 !<
5751	REAL(wp) :: b2 !<
5752	REAL(wp) :: ccc !<
5753	REAL(wp) :: c1 !<
5754	REAL(wp) :: c1_gr !<
5755	REAL(wp) :: c2 !<
5756	REAL(wp) :: d1 !<
5757	REAL(wp) :: d2 !<
5758	REAL(wp) :: eta !<
5759	REAL(wp) :: e1 !<
5760	REAL(wp) :: e2 !<
5761	REAL(wp) :: fao_gr !<
5762	REAL(wp) :: fr !<
5763	REAL(wp) :: grfin !<
5764	REAL(wp) :: lambda !<
5765	REAL(wp) :: lambda_re !<
5766	REAL(wp) :: lf !<
5767	REAL(wp) :: rc !<
5768	REAL(wp) :: rrp !<
5769	REAL(wp) :: sst !<
5770	REAL(wp) :: tauk !<
5771	REAL(wp) :: tl !<
5772	REAL(wp) :: t2 !<
5773	REAL(wp) :: tt !<
5774	REAL(wp) :: t1 !<
5775	REAL(wp) :: vk !<
5776	REAL(wp) :: vrms1xy !<
5777	REAL(wp) :: vrms2xy !<
5778	REAL(wp) :: v1 !<
5779	REAL(wp) :: v1v2xy !<
5780	REAL(wp) :: v1xysq !<
5781	REAL(wp) :: v2 !<
5782	REAL(wp) :: v2xysq !<
5783	REAL(wp) :: wrfin !<
5784	REAL(wp) :: wrgrav2 !<
5785	REAL(wp) :: wrtur2xy !<
5786	REAL(wp) :: xx !<
5787	REAL(wp) :: yy !<
5788	REAL(wp) :: z !<
5789
5790	REAL(wp), DIMENSION(1:radius_classes) :: st !< Stokes number
5791	REAL(wp), DIMENSION(1:radius_classes) :: tau !< inertial time scale
5792
5793	lambda = urms * SQRT( 15.0_wp * molecular_viscosity / epsilon_collision )
5794	lambda_re = urms*2 SQRT( 15.0_wp / epsilon_collision / molecular_viscosity )
5795	tl = urms**2 / epsilon_collision
5796	lf = 0.5_wp * urms**3 / epsilon_collision
5797	tauk = SQRT( molecular_viscosity / epsilon_collision )
5798	eta = ( molecular_viscosity3 / epsilon_collision )0.25_wp
5799	vk = eta / tauk
5800
5801	ao = ( 11.0_wp + 7.0_wp * lambda_re ) / ( 205.0_wp + lambda_re )
5802	tt = SQRT( 2.0_wp * lambda_re / ( SQRT( 15.0_wp ) * ao ) ) * tauk
5803
5804	!
5805	!-- Get terminal velocity of droplets
5806	CALL fallg
5807
5808	DO i = 1, radius_classes
5809	tau(i) = winf(i) / g ! inertial time scale
5810	st(i) = tau(i) / tauk ! Stokes number
5811	ENDDO
5812
5813	!
5814	!-- Calculate average radial relative velocity at contact (wrfin)
5815	z = tt / tl
5816	be = SQRT( 2.0_wp ) * lambda / lf
5817	bbb = SQRT( 1.0_wp - 2.0_wp * be**2 )
5818	d1 = ( 1.0_wp + bbb ) / ( 2.0_wp * bbb )
5819	e1 = lf * ( 1.0_wp + bbb ) * 0.5_wp
5820	d2 = ( 1.0_wp - bbb ) * 0.5_wp / bbb
5821	e2 = lf * ( 1.0_wp - bbb ) * 0.5_wp
5822	ccc = SQRT( 1.0_wp - 2.0_wp * z**2 )
5823	b1 = ( 1.0_wp + ccc ) * 0.5_wp / ccc
5824	c1 = tl * ( 1.0_wp + ccc ) * 0.5_wp
5825	b2 = ( 1.0_wp - ccc ) * 0.5_wp / ccc
5826	c2 = tl * ( 1.0_wp - ccc ) * 0.5_wp
5827
5828	DO i = 1, radius_classes
5829
5830	v1 = winf(i)
5831	t1 = tau(i)
5832
5833	DO j = 1, i
5834	rrp = radclass(i) + radclass(j)
5835	v2 = winf(j)
5836	t2 = tau(j)
5837
5838	v1xysq = b1 * d1 * phi_w(c1,e1,v1,t1) - b1 * d2 * phi_w(c1,e2,v1,t1) &
5839	- b2 * d1 * phi_w(c2,e1,v1,t1) + b2 * d2 * phi_w(c2,e2,v1,t1)
5840	v1xysq = v1xysq * urms**2 / t1
5841	vrms1xy = SQRT( v1xysq )
5842
5843	v2xysq = b1 * d1 * phi_w(c1,e1,v2,t2) - b1 * d2 * phi_w(c1,e2,v2,t2) &
5844	- b2 * d1 * phi_w(c2,e1,v2,t2) + b2 * d2 * phi_w(c2,e2,v2,t2)
5845	v2xysq = v2xysq * urms**2 / t2
5846	vrms2xy = SQRT( v2xysq )
5847
5848	IF ( winf(i) >= winf(j) ) THEN
5849	v1 = winf(i)
5850	t1 = tau(i)
5851	v2 = winf(j)
5852	t2 = tau(j)
5853	ELSE
5854	v1 = winf(j)
5855	t1 = tau(j)
5856	v2 = winf(i)
5857	t2 = tau(i)
5858	ENDIF
5859
5860	v1v2xy = b1 * d1 * zhi(c1,e1,v1,t1,v2,t2) - &
5861	b1 * d2 * zhi(c1,e2,v1,t1,v2,t2) - &
5862	b2 * d1 * zhi(c2,e1,v1,t1,v2,t2) + &
5863	b2 * d2* zhi(c2,e2,v1,t1,v2,t2)
5864	fr = d1 * EXP( -rrp / e1 ) - d2 * EXP( -rrp / e2 )
5865	v1v2xy = v1v2xy * fr * urms**2 / tau(i) / tau(j)
5866	wrtur2xy = vrms1xy2 + vrms2xy2 - 2.0_wp * v1v2xy
5867	IF ( wrtur2xy < 0.0_wp ) wrtur2xy = 0.0_wp
5868	wrgrav2 = pi / 8.0_wp * ( winf(j) - winf(i) )**2
5869	wrfin = SQRT( ( 2.0_wp / pi ) * ( wrtur2xy + wrgrav2) )
5870
5871	!
5872	!-- Calculate radial distribution function (grfin)
5873	IF ( st(j) > st(i) ) THEN
5874	sst = st(j)
5875	ELSE
5876	sst = st(i)
5877	ENDIF
5878
5879	xx = -0.1988_wp * sst*4 + 1.5275_wp sst*3 - 4.2942_wp &
5880	sst*2 + 5.3406_wp sst
5881	IF ( xx < 0.0_wp ) xx = 0.0_wp
5882	yy = 0.1886_wp * EXP( 20.306_wp / lambda_re )
5883
5884	c1_gr = xx / ( g / vk * tauk )**yy
5885
5886	ao_gr = ao + ( pi / 8.0_wp) * ( g / vk * tauk )**2
5887	fao_gr = 20.115_wp * SQRT( ao_gr / lambda_re )
5888	rc = SQRT( fao_gr * ABS( st(j) - st(i) ) ) * eta
5889
5890	grfin = ( ( eta2 + rc2 ) / ( rrp2 + rc2) )*( c1_gr0.5_wp )
5891	IF ( grfin < 1.0_wp ) grfin = 1.0_wp
5892
5893	!
5894	!-- Calculate general collection kernel (without the consideration of
5895	!-- collection efficiencies)
5896	gck(i,j) = 2.0_wp * pi * rrp*2 wrfin * grfin
5897	gck(j,i) = gck(i,j)
5898
5899	ENDDO
5900	ENDDO
5901
5902	END SUBROUTINE turbsd
5903
5904	REAL(wp) FUNCTION phi_w( a, b, vsett, tau0 )
5905	!
5906	!-- Function used in the Ayala et al. (2008) analytical model for turbulent
5907	!-- effects on the collision kernel
5908
5909
5910	REAL(wp) :: a !<
5911	REAL(wp) :: aa1 !<
5912	REAL(wp) :: b !<
5913	REAL(wp) :: tau0 !<
5914	REAL(wp) :: vsett !<
5915
5916	aa1 = 1.0_wp / tau0 + 1.0_wp / a + vsett / b
5917	phi_w = 1.0_wp / aa1 - 0.5_wp * vsett / b / aa1**2
5918
5919	END FUNCTION phi_w
5920
5921	REAL(wp) FUNCTION zhi( a, b, vsett1, tau1, vsett2, tau2 )
5922	!
5923	!-- Function used in the Ayala et al. (2008) analytical model for turbulent
5924	!-- effects on the collision kernel
5925
5926	REAL(wp) :: a !<
5927	REAL(wp) :: aa1 !<
5928	REAL(wp) :: aa2 !<
5929	REAL(wp) :: aa3 !<
5930	REAL(wp) :: aa4 !<
5931	REAL(wp) :: aa5 !<
5932	REAL(wp) :: aa6 !<
5933	REAL(wp) :: b !<
5934	REAL(wp) :: tau1 !<
5935	REAL(wp) :: tau2 !<
5936	REAL(wp) :: vsett1 !<
5937	REAL(wp) :: vsett2 !<
5938
5939	aa1 = vsett2 / b - 1.0_wp / tau2 - 1.0_wp / a
5940	aa2 = vsett1 / b + 1.0_wp / tau1 + 1.0_wp / a
5941	aa3 = ( vsett1 - vsett2 ) / b + 1.0_wp / tau1 + 1.0_wp / tau2
5942	aa4 = ( vsett2 / b )2 - ( 1.0_wp / tau2 + 1.0_wp / a )2
5943	aa5 = vsett2 / b + 1.0_wp / tau2 + 1.0_wp / a
5944	aa6 = 1.0_wp / tau1 - 1.0_wp / a + ( 1.0_wp / tau2 + 1.0_wp / a) * &
5945	vsett1 / vsett2
5946	zhi = (1.0_wp / aa1 - 1.0_wp / aa2 ) * ( vsett1 - vsett2 ) * 0.5_wp / &
5947	b / aa32 + ( 4.0_wp / aa4 - 1.0_wp / aa52 - 1.0_wp / aa1**2 ) &
5948	* vsett2 * 0.5_wp / b /aa6 + ( 2.0_wp * ( b / aa2 - b / aa1 ) - &
5949	vsett1 / aa22 + vsett2 / aa12 ) * 0.5_wp / b / aa3
5950
5951	END FUNCTION zhi
5952
5953
5954	!------------------------------------------------------------------------------!
5955	! Description:
5956	! ------------
5957	!> Parameterization of terminal velocity following Rogers et al. (1993, J. Appl.
5958	!> Meteorol.)
5959	!------------------------------------------------------------------------------!
5960	SUBROUTINE fallg
5961
5962	INTEGER(iwp) :: j !<
5963
5964	REAL(wp), PARAMETER :: k_cap_rog = 4.0_wp !< parameter
5965	REAL(wp), PARAMETER :: k_low_rog = 12.0_wp !< parameter
5966	REAL(wp), PARAMETER :: a_rog = 9.65_wp !< parameter
5967	REAL(wp), PARAMETER :: b_rog = 10.43_wp !< parameter
5968	REAL(wp), PARAMETER :: c_rog = 0.6_wp !< parameter
5969	REAL(wp), PARAMETER :: d0_rog = 0.745_wp !< seperation diameter
5970
5971	REAL(wp) :: diameter !< droplet diameter in mm
5972
5973
5974	DO j = 1, radius_classes
5975
5976	diameter = radclass(j) * 2000.0_wp
5977
5978	IF ( diameter <= d0_rog ) THEN
5979	winf(j) = k_cap_rog * diameter * ( 1.0_wp - &
5980	EXP( -k_low_rog * diameter ) )
5981	ELSE
5982	winf(j) = a_rog - b_rog * EXP( -c_rog * diameter )
5983	ENDIF
5984
5985	ENDDO
5986
5987	END SUBROUTINE fallg
5988
5989
5990	!------------------------------------------------------------------------------!
5991	! Description:
5992	! ------------
5993	!> Interpolation of collision efficiencies (Hall, 1980, J. Atmos. Sci.)
5994	!------------------------------------------------------------------------------!
5995	SUBROUTINE effic
5996
5997	INTEGER(iwp) :: i !<
5998	INTEGER(iwp) :: iq !<
5999	INTEGER(iwp) :: ir !<
6000	INTEGER(iwp) :: j !<
6001	INTEGER(iwp) :: k !<
6002
6003	INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: ira !<
6004
6005	LOGICAL, SAVE :: first = .TRUE. !<
6006
6007	REAL(wp) :: ek !<
6008	REAL(wp) :: particle_radius !<
6009	REAL(wp) :: pp !<
6010	REAL(wp) :: qq !<
6011	REAL(wp) :: rq !<
6012
6013	REAL(wp), DIMENSION(1:21), SAVE :: rat !<
6014
6015	REAL(wp), DIMENSION(1:15), SAVE :: r0 !<
6016
6017	REAL(wp), DIMENSION(1:15,1:21), SAVE :: ecoll !<
6018
6019	!
6020	!-- Initial assignment of constants
6021	IF ( first ) THEN
6022
6023	first = .FALSE.
6024	r0 = (/ 6.0_wp, 8.0_wp, 10.0_wp, 15.0_wp, 20.0_wp, 25.0_wp, &
6025	30.0_wp, 40.0_wp, 50.0_wp, 60.0_wp, 70.0_wp, 100.0_wp, &
6026	150.0_wp, 200.0_wp, 300.0_wp /)
6027
6028	rat = (/ 0.00_wp, 0.05_wp, 0.10_wp, 0.15_wp, 0.20_wp, 0.25_wp, &
6029	0.30_wp, 0.35_wp, 0.40_wp, 0.45_wp, 0.50_wp, 0.55_wp, &
6030	0.60_wp, 0.65_wp, 0.70_wp, 0.75_wp, 0.80_wp, 0.85_wp, &
6031	0.90_wp, 0.95_wp, 1.00_wp /)
6032
6033	ecoll(:,1) = (/ 0.001_wp, 0.001_wp, 0.001_wp, 0.001_wp, 0.001_wp, &
6034	0.001_wp, 0.001_wp, 0.001_wp, 0.001_wp, 0.001_wp, &
6035	0.001_wp, 0.001_wp, 0.001_wp, 0.001_wp, 0.001_wp /)
6036	ecoll(:,2) = (/ 0.003_wp, 0.003_wp, 0.003_wp, 0.004_wp, 0.005_wp, &
6037	0.005_wp, 0.005_wp, 0.010_wp, 0.100_wp, 0.050_wp, &
6038	0.200_wp, 0.500_wp, 0.770_wp, 0.870_wp, 0.970_wp /)
6039	ecoll(:,3) = (/ 0.007_wp, 0.007_wp, 0.007_wp, 0.008_wp, 0.009_wp, &
6040	0.010_wp, 0.010_wp, 0.070_wp, 0.400_wp, 0.430_wp, &
6041	0.580_wp, 0.790_wp, 0.930_wp, 0.960_wp, 1.000_wp /)
6042	ecoll(:,4) = (/ 0.009_wp, 0.009_wp, 0.009_wp, 0.012_wp, 0.015_wp, &
6043	0.010_wp, 0.020_wp, 0.280_wp, 0.600_wp, 0.640_wp, &
6044	0.750_wp, 0.910_wp, 0.970_wp, 0.980_wp, 1.000_wp /)
6045	ecoll(:,5) = (/ 0.014_wp, 0.014_wp, 0.014_wp, 0.015_wp, 0.016_wp, &
6046	0.030_wp, 0.060_wp, 0.500_wp, 0.700_wp, 0.770_wp, &
6047	0.840_wp, 0.950_wp, 0.970_wp, 1.000_wp, 1.000_wp /)
6048	ecoll(:,6) = (/ 0.017_wp, 0.017_wp, 0.017_wp, 0.020_wp, 0.022_wp, &
6049	0.060_wp, 0.100_wp, 0.620_wp, 0.780_wp, 0.840_wp, &
6050	0.880_wp, 0.950_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
6051	ecoll(:,7) = (/ 0.030_wp, 0.030_wp, 0.024_wp, 0.022_wp, 0.032_wp, &
6052	0.062_wp, 0.200_wp, 0.680_wp, 0.830_wp, 0.870_wp, &
6053	0.900_wp, 0.950_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
6054	ecoll(:,8) = (/ 0.025_wp, 0.025_wp, 0.025_wp, 0.036_wp, 0.043_wp, &
6055	0.130_wp, 0.270_wp, 0.740_wp, 0.860_wp, 0.890_wp, &
6056	0.920_wp, 1.000_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
6057	ecoll(:,9) = (/ 0.027_wp, 0.027_wp, 0.027_wp, 0.040_wp, 0.052_wp, &
6058	0.200_wp, 0.400_wp, 0.780_wp, 0.880_wp, 0.900_wp, &
6059	0.940_wp, 1.000_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
6060	ecoll(:,10) = (/ 0.030_wp, 0.030_wp, 0.030_wp, 0.047_wp, 0.064_wp, &
6061	0.250_wp, 0.500_wp, 0.800_wp, 0.900_wp, 0.910_wp, &
6062	0.950_wp, 1.000_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
6063	ecoll(:,11) = (/ 0.040_wp, 0.040_wp, 0.033_wp, 0.037_wp, 0.068_wp, &
6064	0.240_wp, 0.550_wp, 0.800_wp, 0.900_wp, 0.910_wp, &
6065	0.950_wp, 1.000_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
6066	ecoll(:,12) = (/ 0.035_wp, 0.035_wp, 0.035_wp, 0.055_wp, 0.079_wp, &
6067	0.290_wp, 0.580_wp, 0.800_wp, 0.900_wp, 0.910_wp, &
6068	0.950_wp, 1.000_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
6069	ecoll(:,13) = (/ 0.037_wp, 0.037_wp, 0.037_wp, 0.062_wp, 0.082_wp, &
6070	0.290_wp, 0.590_wp, 0.780_wp, 0.900_wp, 0.910_wp, &
6071	0.950_wp, 1.000_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
6072	ecoll(:,14) = (/ 0.037_wp, 0.037_wp, 0.037_wp, 0.060_wp, 0.080_wp, &
6073	0.290_wp, 0.580_wp, 0.770_wp, 0.890_wp, 0.910_wp, &
6074	0.950_wp, 1.000_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
6075	ecoll(:,15) = (/ 0.037_wp, 0.037_wp, 0.037_wp, 0.041_wp, 0.075_wp, &
6076	0.250_wp, 0.540_wp, 0.760_wp, 0.880_wp, 0.920_wp, &
6077	0.950_wp, 1.000_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
6078	ecoll(:,16) = (/ 0.037_wp, 0.037_wp, 0.037_wp, 0.052_wp, 0.067_wp, &
6079	0.250_wp, 0.510_wp, 0.770_wp, 0.880_wp, 0.930_wp, &
6080	0.970_wp, 1.000_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
6081	ecoll(:,17) = (/ 0.037_wp, 0.037_wp, 0.037_wp, 0.047_wp, 0.057_wp, &
6082	0.250_wp, 0.490_wp, 0.770_wp, 0.890_wp, 0.950_wp, &
6083	1.000_wp, 1.000_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
6084	ecoll(:,18) = (/ 0.036_wp, 0.036_wp, 0.036_wp, 0.042_wp, 0.048_wp, &
6085	0.230_wp, 0.470_wp, 0.780_wp, 0.920_wp, 1.000_wp, &
6086	1.020_wp, 1.020_wp, 1.020_wp, 1.020_wp, 1.020_wp /)
6087	ecoll(:,19) = (/ 0.040_wp, 0.040_wp, 0.035_wp, 0.033_wp, 0.040_wp, &
6088	0.112_wp, 0.450_wp, 0.790_wp, 1.010_wp, 1.030_wp, &
6089	1.040_wp, 1.040_wp, 1.040_wp, 1.040_wp, 1.040_wp /)
6090	ecoll(:,20) = (/ 0.033_wp, 0.033_wp, 0.033_wp, 0.033_wp, 0.033_wp, &
6091	0.119_wp, 0.470_wp, 0.950_wp, 1.300_wp, 1.700_wp, &
6092	2.300_wp, 2.300_wp, 2.300_wp, 2.300_wp, 2.300_wp /)
6093	ecoll(:,21) = (/ 0.027_wp, 0.027_wp, 0.027_wp, 0.027_wp, 0.027_wp, &
6094	0.125_wp, 0.520_wp, 1.400_wp, 2.300_wp, 3.000_wp, &
6095	4.000_wp, 4.000_wp, 4.000_wp, 4.000_wp, 4.000_wp /)
6096	ENDIF
6097
6098	!
6099	!-- Calculate the radius class index of particles with respect to array r
6100	!-- Radius has to be in microns
6101	ALLOCATE( ira(1:radius_classes) )
6102	DO j = 1, radius_classes
6103	particle_radius = radclass(j) * 1.0E6_wp
6104	DO k = 1, 15
6105	IF ( particle_radius < r0(k) ) THEN
6106	ira(j) = k
6107	EXIT
6108	ENDIF
6109	ENDDO
6110	IF ( particle_radius >= r0(15) ) ira(j) = 16
6111	ENDDO
6112
6113	!
6114	!-- Two-dimensional linear interpolation of the collision efficiency.
6115	!-- Radius has to be in microns
6116	DO j = 1, radius_classes
6117	DO i = 1, j
6118
6119	ir = MAX( ira(i), ira(j) )
6120	rq = MIN( radclass(i) / radclass(j), radclass(j) / radclass(i) )
6121	iq = INT( rq * 20 ) + 1
6122	iq = MAX( iq , 2)
6123
6124	IF ( ir < 16 ) THEN
6125	IF ( ir >= 2 ) THEN
6126	pp = ( ( MAX( radclass(j), radclass(i) ) * 1.0E6_wp ) - &
6127	r0(ir-1) ) / ( r0(ir) - r0(ir-1) )
6128	qq = ( rq - rat(iq-1) ) / ( rat(iq) - rat(iq-1) )
6129	ec(j,i) = ( 1.0_wp - pp ) * ( 1.0_wp - qq ) &
6130	* ecoll(ir-1,iq-1) &
6131	+ pp * ( 1.0_wp - qq ) * ecoll(ir,iq-1) &
6132	+ qq * ( 1.0_wp - pp ) * ecoll(ir-1,iq) &
6133	+ pp * qq * ecoll(ir,iq)
6134	ELSE
6135	qq = ( rq - rat(iq-1) ) / ( rat(iq) - rat(iq-1) )
6136	ec(j,i) = ( 1.0_wp - qq ) * ecoll(1,iq-1) + qq * ecoll(1,iq)
6137	ENDIF
6138	ELSE
6139	qq = ( rq - rat(iq-1) ) / ( rat(iq) - rat(iq-1) )
6140	ek = ( 1.0_wp - qq ) * ecoll(15,iq-1) + qq * ecoll(15,iq)
6141	ec(j,i) = MIN( ek, 1.0_wp )
6142	ENDIF
6143
6144	IF ( ec(j,i) < 1.0E-20_wp ) ec(j,i) = 0.0_wp
6145
6146	ec(i,j) = ec(j,i)
6147
6148	ENDDO
6149	ENDDO
6150
6151	DEALLOCATE( ira )
6152
6153	END SUBROUTINE effic
6154
6155
6156	!------------------------------------------------------------------------------!
6157	! Description:
6158	! ------------
6159	!> Interpolation of turbulent enhancement factor for collision efficencies
6160	!> following Wang and Grabowski (2009, Atmos. Sci. Let.)
6161	!------------------------------------------------------------------------------!
6162	SUBROUTINE turb_enhance_eff
6163
6164	INTEGER(iwp) :: i !<
6165	INTEGER(iwp) :: iq !<
6166	INTEGER(iwp) :: ir !<
6167	INTEGER(iwp) :: j !<
6168	INTEGER(iwp) :: k !<
6169	INTEGER(iwp) :: kk !<
6170
6171	INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: ira !<
6172
6173	LOGICAL, SAVE :: first = .TRUE. !<
6174
6175	REAL(wp) :: particle_radius !<
6176	REAL(wp) :: pp !<
6177	REAL(wp) :: qq !<
6178	REAL(wp) :: rq !<
6179	REAL(wp) :: y1 !<
6180	REAL(wp) :: y2 !<
6181	REAL(wp) :: y3 !<
6182
6183	REAL(wp), DIMENSION(1:11), SAVE :: rat !<
6184	REAL(wp), DIMENSION(1:7), SAVE :: r0 !<
6185
6186	REAL(wp), DIMENSION(1:7,1:11), SAVE :: ecoll_100 !<
6187	REAL(wp), DIMENSION(1:7,1:11), SAVE :: ecoll_400 !<
6188
6189	!
6190	!-- Initial assignment of constants
6191	IF ( first ) THEN
6192
6193	first = .FALSE.
6194
6195	r0 = (/ 10.0_wp, 20.0_wp, 30.0_wp, 40.0_wp, 50.0_wp, 60.0_wp, &
6196	100.0_wp /)
6197
6198	rat = (/ 0.0_wp, 0.1_wp, 0.2_wp, 0.3_wp, 0.4_wp, 0.5_wp, 0.6_wp, &
6199	0.7_wp, 0.8_wp, 0.9_wp, 1.0_wp /)
6200	!
6201	!-- Tabulated turbulent enhancement factor at 100 cm2/s3
6202	ecoll_100(:,1) = (/ 1.74_wp, 1.74_wp, 1.773_wp, 1.49_wp, &
6203	1.207_wp, 1.207_wp, 1.0_wp /)
6204	ecoll_100(:,2) = (/ 1.46_wp, 1.46_wp, 1.421_wp, 1.245_wp, &
6205	1.069_wp, 1.069_wp, 1.0_wp /)
6206	ecoll_100(:,3) = (/ 1.32_wp, 1.32_wp, 1.245_wp, 1.123_wp, &
6207	1.000_wp, 1.000_wp, 1.0_wp /)
6208	ecoll_100(:,4) = (/ 1.250_wp, 1.250_wp, 1.148_wp, 1.087_wp, &
6209	1.025_wp, 1.025_wp, 1.0_wp /)
6210	ecoll_100(:,5) = (/ 1.186_wp, 1.186_wp, 1.066_wp, 1.060_wp, &
6211	1.056_wp, 1.056_wp, 1.0_wp /)
6212	ecoll_100(:,6) = (/ 1.045_wp, 1.045_wp, 1.000_wp, 1.014_wp, &
6213	1.028_wp, 1.028_wp, 1.0_wp /)
6214	ecoll_100(:,7) = (/ 1.070_wp, 1.070_wp, 1.030_wp, 1.038_wp, &
6215	1.046_wp, 1.046_wp, 1.0_wp /)
6216	ecoll_100(:,8) = (/ 1.000_wp, 1.000_wp, 1.054_wp, 1.042_wp, &
6217	1.029_wp, 1.029_wp, 1.0_wp /)
6218	ecoll_100(:,9) = (/ 1.223_wp, 1.223_wp, 1.117_wp, 1.069_wp, &
6219	1.021_wp, 1.021_wp, 1.0_wp /)
6220	ecoll_100(:,10) = (/ 1.570_wp, 1.570_wp, 1.244_wp, 1.166_wp, &
6221	1.088_wp, 1.088_wp, 1.0_wp /)
6222	ecoll_100(:,11) = (/ 20.3_wp, 20.3_wp, 14.6_wp, 8.61_wp, &
6223	2.60_wp, 2.60_wp, 1.0_wp /)
6224	!
6225	!-- Tabulated turbulent enhancement factor at 400 cm2/s3
6226	ecoll_400(:,1) = (/ 4.976_wp, 4.976_wp, 3.593_wp, 2.519_wp, &
6227	1.445_wp, 1.445_wp, 1.0_wp /)
6228	ecoll_400(:,2) = (/ 2.984_wp, 2.984_wp, 2.181_wp, 1.691_wp, &
6229	1.201_wp, 1.201_wp, 1.0_wp /)
6230	ecoll_400(:,3) = (/ 1.988_wp, 1.988_wp, 1.475_wp, 1.313_wp, &
6231	1.150_wp, 1.150_wp, 1.0_wp /)
6232	ecoll_400(:,4) = (/ 1.490_wp, 1.490_wp, 1.187_wp, 1.156_wp, &
6233	1.126_wp, 1.126_wp, 1.0_wp /)
6234	ecoll_400(:,5) = (/ 1.249_wp, 1.249_wp, 1.088_wp, 1.090_wp, &
6235	1.092_wp, 1.092_wp, 1.0_wp /)
6236	ecoll_400(:,6) = (/ 1.139_wp, 1.139_wp, 1.130_wp, 1.091_wp, &
6237	1.051_wp, 1.051_wp, 1.0_wp /)
6238	ecoll_400(:,7) = (/ 1.220_wp, 1.220_wp, 1.190_wp, 1.138_wp, &
6239	1.086_wp, 1.086_wp, 1.0_wp /)
6240	ecoll_400(:,8) = (/ 1.325_wp, 1.325_wp, 1.267_wp, 1.165_wp, &
6241	1.063_wp, 1.063_wp, 1.0_wp /)
6242	ecoll_400(:,9) = (/ 1.716_wp, 1.716_wp, 1.345_wp, 1.223_wp, &
6243	1.100_wp, 1.100_wp, 1.0_wp /)
6244	ecoll_400(:,10) = (/ 3.788_wp, 3.788_wp, 1.501_wp, 1.311_wp, &
6245	1.120_wp, 1.120_wp, 1.0_wp /)
6246	ecoll_400(:,11) = (/ 36.52_wp, 36.52_wp, 19.16_wp, 22.80_wp, &
6247	26.0_wp, 26.0_wp, 1.0_wp /)
6248
6249	ENDIF
6250
6251	!
6252	!-- Calculate the radius class index of particles with respect to array r0
6253	!-- The droplet radius has to be given in microns.
6254	ALLOCATE( ira(1:radius_classes) )
6255
6256	DO j = 1, radius_classes
6257	particle_radius = radclass(j) * 1.0E6_wp
6258	DO k = 1, 7
6259	IF ( particle_radius < r0(k) ) THEN
6260	ira(j) = k
6261	EXIT
6262	ENDIF
6263	ENDDO
6264	IF ( particle_radius >= r0(7) ) ira(j) = 8
6265	ENDDO
6266
6267	!
6268	!-- Two-dimensional linear interpolation of the turbulent enhancement factor.
6269	!-- The droplet radius has to be given in microns.
6270	DO j = 1, radius_classes
6271	DO i = 1, j
6272
6273	ir = MAX( ira(i), ira(j) )
6274	rq = MIN( radclass(i) / radclass(j), radclass(j) / radclass(i) )
6275
6276	DO kk = 2, 11
6277	IF ( rq <= rat(kk) ) THEN
6278	iq = kk
6279	EXIT
6280	ENDIF
6281	ENDDO
6282
6283	y1 = 1.0_wp ! turbulent enhancement factor at 0 m2/s3
6284
6285	IF ( ir < 8 ) THEN
6286	IF ( ir >= 2 ) THEN
6287	pp = ( MAX( radclass(j), radclass(i) ) * 1.0E6_wp - &
6288	r0(ir-1) ) / ( r0(ir) - r0(ir-1) )
6289	qq = ( rq - rat(iq-1) ) / ( rat(iq) - rat(iq-1) )
6290	y2 = ( 1.0_wp - pp ) * ( 1.0_wp - qq ) * ecoll_100(ir-1,iq-1) + &
6291	pp * ( 1.0_wp - qq ) * ecoll_100(ir,iq-1) + &
6292	qq * ( 1.0_wp - pp ) * ecoll_100(ir-1,iq) + &
6293	pp * qq * ecoll_100(ir,iq)
6294	y3 = ( 1.0-pp ) * ( 1.0_wp - qq ) * ecoll_400(ir-1,iq-1) + &
6295	pp * ( 1.0_wp - qq ) * ecoll_400(ir,iq-1) + &
6296	qq * ( 1.0_wp - pp ) * ecoll_400(ir-1,iq) + &
6297	pp * qq * ecoll_400(ir,iq)
6298	ELSE
6299	qq = ( rq - rat(iq-1) ) / ( rat(iq) - rat(iq-1) )
6300	y2 = ( 1.0_wp - qq ) * ecoll_100(1,iq-1) + qq * ecoll_100(1,iq)
6301	y3 = ( 1.0_wp - qq ) * ecoll_400(1,iq-1) + qq * ecoll_400(1,iq)
6302	ENDIF
6303	ELSE
6304	qq = ( rq - rat(iq-1) ) / ( rat(iq) - rat(iq-1) )
6305	y2 = ( 1.0_wp - qq ) * ecoll_100(7,iq-1) + qq * ecoll_100(7,iq)
6306	y3 = ( 1.0_wp - qq ) * ecoll_400(7,iq-1) + qq * ecoll_400(7,iq)
6307	ENDIF
6308	!
6309	!-- Linear interpolation of turbulent enhancement factor
6310	IF ( epsilon_collision <= 0.01_wp ) THEN
6311	ecf(j,i) = ( epsilon_collision - 0.01_wp ) / ( 0.0_wp - 0.01_wp ) * y1 &
6312	+ ( epsilon_collision - 0.0_wp ) / ( 0.01_wp - 0.0_wp ) * y2
6313	ELSEIF ( epsilon_collision <= 0.06_wp ) THEN
6314	ecf(j,i) = ( epsilon_collision - 0.04_wp ) / ( 0.01_wp - 0.04_wp ) * y2 &
6315	+ ( epsilon_collision - 0.01_wp ) / ( 0.04_wp - 0.01_wp ) * y3
6316	ELSE
6317	ecf(j,i) = ( 0.06_wp - 0.04_wp ) / ( 0.01_wp - 0.04_wp ) * y2 &
6318	+ ( 0.06_wp - 0.01_wp ) / ( 0.04_wp - 0.01_wp ) * y3
6319	ENDIF
6320
6321	IF ( ecf(j,i) < 1.0_wp ) ecf(j,i) = 1.0_wp
6322
6323	ecf(i,j) = ecf(j,i)
6324
6325	ENDDO
6326	ENDDO
6327
6328	END SUBROUTINE turb_enhance_eff
6329
6330
6331	!------------------------------------------------------------------------------!
6332	! Description:
6333	! ------------
6334	! This routine is a part of the Lagrangian particle model. Super droplets which
6335	! fulfill certain criterion's (e.g. a big weighting factor and a large radius)
6336	! can be split into several super droplets with a reduced number of
6337	! represented particles of every super droplet. This mechanism ensures an
6338	! improved representation of the right tail of the drop size distribution with
6339	! a feasible amount of computational costs. The limits of particle creation
6340	! should be chosen carefully! The idea of this algorithm is based on
6341	! Unterstrasser and Soelch, 2014.
6342	!------------------------------------------------------------------------------!
6343	SUBROUTINE lpm_splitting
6344
6345	INTEGER(iwp) :: i !<
6346	INTEGER(iwp) :: j !<
6347	INTEGER(iwp) :: jpp !<
6348	INTEGER(iwp) :: k !<
6349	INTEGER(iwp) :: n !<
6350	INTEGER(iwp) :: new_particles_gb !< counter of created particles within one grid box
6351	INTEGER(iwp) :: new_size !< new particle array size
6352	INTEGER(iwp) :: np !<
6353	INTEGER(iwp) :: old_size !< old particle array size
6354
6355	INTEGER(iwp), PARAMETER :: n_max = 100 !< number of radii bin for splitting functions
6356
6357	LOGICAL :: first_loop_stride_sp = .TRUE. !< flag to calculate constants only once
6358
6359	REAL(wp) :: diameter !< diameter of droplet
6360	REAL(wp) :: dlog !< factor for DSD calculation
6361	REAL(wp) :: factor_volume_to_mass !< pre calculate factor volume to mass
6362	REAL(wp) :: lambda !< slope parameter of gamma-distribution
6363	REAL(wp) :: lwc !< liquid water content of grid box
6364	REAL(wp) :: lwc_total !< average liquid water content of cloud
6365	REAL(wp) :: m1 !< first moment of DSD
6366	REAL(wp) :: m1_total !< average over all PEs of first moment of DSD
6367	REAL(wp) :: m2 !< second moment of DSD
6368	REAL(wp) :: m2_total !< average average over all PEs second moment of DSD
6369	REAL(wp) :: m3 !< third moment of DSD
6370	REAL(wp) :: m3_total !< average average over all PEs third moment of DSD
6371	REAL(wp) :: mu !< spectral shape parameter of gamma distribution
6372	REAL(wp) :: nrclgb !< number of cloudy grid boxes (ql >= 1.0E-5 kg/kg)
6373	REAL(wp) :: nrclgb_total !< average over all PEs of number of cloudy grid boxes
6374	REAL(wp) :: nr !< number concentration of cloud droplets
6375	REAL(wp) :: nr_total !< average over all PEs of number of cloudy grid boxes
6376	REAL(wp) :: nr0 !< intercept parameter of gamma distribution
6377	REAL(wp) :: pirho_l !< pi * rho_l / 6.0
6378	REAL(wp) :: ql_crit = 1.0E-5_wp !< threshold lwc for cloudy grid cells
6379	!< (Siebesma et al 2003, JAS, 60)
6380	REAL(wp) :: rm !< volume averaged mean radius
6381	REAL(wp) :: rm_total !< average over all PEs of volume averaged mean radius
6382	REAL(wp) :: r_min = 1.0E-6_wp !< minimum radius of approximated spectra
6383	REAL(wp) :: r_max = 1.0E-3_wp !< maximum radius of approximated spectra
6384	REAL(wp) :: sigma_log = 1.5_wp !< standard deviation of the LOG-distribution
6385	REAL(wp) :: zeta !< Parameter for DSD calculation of Seifert
6386
6387	REAL(wp), DIMENSION(0:n_max-1) :: an_spl !< size dependent critical weight factor
6388	REAL(wp), DIMENSION(0:n_max-1) :: r_bin_mid !< mass weighted mean radius of a bin
6389	REAL(wp), DIMENSION(0:n_max) :: r_bin !< boundaries of a radius bin
6390
6391	TYPE(particle_type) :: tmp_particle !< temporary particle TYPE
6392
6393	CALL cpu_log( log_point_s(80), 'lpm_splitting', 'start' )
6394
6395	IF ( first_loop_stride_sp ) THEN
6396	IF ( i_splitting_mode == 2 .OR. i_splitting_mode == 3 ) THEN
6397	dlog = ( LOG10(r_max) - LOG10(r_min) ) / ( n_max - 1 )
6398	DO i = 0, n_max-1
6399	r_bin(i) = 10.0_wp*( LOG10(r_min) + i dlog - 0.5_wp * dlog )
6400	r_bin_mid(i) = 10.0_wp*( LOG10(r_min) + i dlog )
6401	ENDDO
6402	r_bin(n_max) = 10.0_wp*( LOG10(r_min) + n_max dlog - 0.5_wp * dlog )
6403	ENDIF
6404	factor_volume_to_mass = 4.0_wp / 3.0_wp * pi * rho_l
6405	pirho_l = pi * rho_l / 6.0_wp
6406	IF ( weight_factor_split == -1.0_wp ) THEN
6407	weight_factor_split = 0.1_wp * initial_weighting_factor
6408	ENDIF
6409	ENDIF
6410
6411
6412	IF ( i_splitting_mode == 1 ) THEN
6413
6414	DO i = nxl, nxr
6415	DO j = nys, nyn
6416	DO k = nzb+1, nzt
6417
6418	new_particles_gb = 0
6419	number_of_particles = prt_count(k,j,i)
6420	IF ( number_of_particles <= 0 .OR. &
6421	ql(k,j,i) < ql_crit ) CYCLE
6422	particles => grid_particles(k,j,i)%particles(1:number_of_particles)
6423	!
6424	!-- Start splitting operations. Each particle is checked if it
6425	!-- fulfilled the splitting criterion's. In splitting mode 'const'
6426	!-- a critical radius (radius_split) a critical weighting factor
6427	!-- (weight_factor_split) and a splitting factor (splitting_factor)
6428	!-- must be prescribed (see particle_parameters). Super droplets
6429	!-- which have a larger radius and larger weighting factor are split
6430	!-- into 'splitting_factor' super droplets. Therefore, the weighting
6431	!-- factor of the super droplet and all created clones is reduced
6432	!-- by the factor of 'splitting_factor'.
6433	DO n = 1, number_of_particles
6434	IF ( particles(n)%particle_mask .AND. &
6435	particles(n)%radius >= radius_split .AND. &
6436	particles(n)%weight_factor >= weight_factor_split ) &
6437	THEN
6438	!
6439	!-- Calculate the new number of particles.
6440	new_size = prt_count(k,j,i) + splitting_factor - 1
6441	!
6442	!-- Cycle if maximum number of particles per grid box
6443	!-- is greater than the allowed maximum number.
6444	IF ( new_size >= max_number_particles_per_gridbox ) CYCLE
6445	!
6446	!-- Reallocate particle array if necessary.
6447	IF ( new_size > SIZE(particles) ) THEN
6448	CALL realloc_particles_array( i, j, k, new_size )
6449	ENDIF
6450	old_size = prt_count(k,j,i)
6451	!
6452	!-- Calculate new weighting factor.
6453	particles(n)%weight_factor = &
6454	particles(n)%weight_factor / splitting_factor
6455	tmp_particle = particles(n)
6456	!
6457	!-- Create splitting_factor-1 new particles.
6458	DO jpp = 1, splitting_factor-1
6459	grid_particles(k,j,i)%particles(jpp+old_size) = &
6460	tmp_particle
6461	ENDDO
6462	new_particles_gb = new_particles_gb + splitting_factor - 1
6463	!
6464	!-- Save the new number of super droplets for every grid box.
6465	prt_count(k,j,i) = prt_count(k,j,i) + &
6466	splitting_factor - 1
6467	ENDIF
6468	ENDDO
6469
6470	ENDDO
6471	ENDDO
6472	ENDDO
6473
6474	ELSEIF ( i_splitting_mode == 2 ) THEN
6475	!
6476	!-- Initialize summing variables.
6477	lwc = 0.0_wp
6478	lwc_total = 0.0_wp
6479	m1 = 0.0_wp
6480	m1_total = 0.0_wp
6481	m2 = 0.0_wp
6482	m2_total = 0.0_wp
6483	m3 = 0.0_wp
6484	m3_total = 0.0_wp
6485	nr = 0.0_wp
6486	nrclgb = 0.0_wp
6487	nrclgb_total = 0.0_wp
6488	nr_total = 0.0_wp
6489	rm = 0.0_wp
6490	rm_total = 0.0_wp
6491
6492	DO i = nxl, nxr
6493	DO j = nys, nyn
6494	DO k = nzb+1, nzt
6495	number_of_particles = prt_count(k,j,i)
6496	IF ( number_of_particles <= 0 .OR. &
6497	ql(k,j,i) < ql_crit ) CYCLE
6498	particles => grid_particles(k,j,i)%particles(1:number_of_particles)
6499	nrclgb = nrclgb + 1.0_wp
6500	!
6501	!-- Calculate moments of DSD.
6502	DO n = 1, number_of_particles
6503	IF ( particles(n)%particle_mask .AND. &
6504	particles(n)%radius >= r_min ) &
6505	THEN
6506	nr = nr + particles(n)%weight_factor
6507	rm = rm + factor_volume_to_mass * &
6508	particles(n)%radius*3 &
6509	particles(n)%weight_factor
6510	IF ( isf == 1 ) THEN
6511	diameter = particles(n)%radius * 2.0_wp
6512	lwc = lwc + factor_volume_to_mass * &
6513	particles(n)%radius*3 &
6514	particles(n)%weight_factor
6515	m1 = m1 + particles(n)%weight_factor * diameter
6516	m2 = m2 + particles(n)%weight_factor * diameter**2
6517	m3 = m3 + particles(n)%weight_factor * diameter**3
6518	ENDIF
6519	ENDIF
6520	ENDDO
6521	ENDDO
6522	ENDDO
6523	ENDDO
6524
6525	#if defined( __parallel )
6526	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
6527	CALL MPI_ALLREDUCE( nr, nr_total, 1 , &
6528	MPI_REAL, MPI_SUM, comm2d, ierr )
6529	CALL MPI_ALLREDUCE( rm, rm_total, 1 , &
6530	MPI_REAL, MPI_SUM, comm2d, ierr )
6531	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
6532	CALL MPI_ALLREDUCE( nrclgb, nrclgb_total, 1 , &
6533	MPI_REAL, MPI_SUM, comm2d, ierr )
6534	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
6535	CALL MPI_ALLREDUCE( lwc, lwc_total, 1 , &
6536	MPI_REAL, MPI_SUM, comm2d, ierr )
6537	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
6538	CALL MPI_ALLREDUCE( m1, m1_total, 1 , &
6539	MPI_REAL, MPI_SUM, comm2d, ierr )
6540	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
6541	CALL MPI_ALLREDUCE( m2, m2_total, 1 , &
6542	MPI_REAL, MPI_SUM, comm2d, ierr )
6543	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
6544	CALL MPI_ALLREDUCE( m3, m3_total, 1 , &
6545	MPI_REAL, MPI_SUM, comm2d, ierr )
6546	#endif
6547
6548	!
6549	!-- Calculate number concentration and mean volume averaged radius.
6550	nr_total = MERGE( nr_total / nrclgb_total, &
6551	0.0_wp, nrclgb_total > 0.0_wp &
6552	)
6553	rm_total = MERGE( ( rm_total / &
6554	( nr_total * factor_volume_to_mass ) &
6555	)**0.3333333_wp, 0.0_wp, nrclgb_total > 0.0_wp &
6556	)
6557	!
6558	!-- Check which function should be used to approximate the DSD.
6559	IF ( isf == 1 ) THEN
6560	lwc_total = MERGE( lwc_total / nrclgb_total, &
6561	0.0_wp, nrclgb_total > 0.0_wp &
6562	)
6563	m1_total = MERGE( m1_total / nrclgb_total, &
6564	0.0_wp, nrclgb_total > 0.0_wp &
6565	)
6566	m2_total = MERGE( m2_total / nrclgb_total, &
6567	0.0_wp, nrclgb_total > 0.0_wp &
6568	)
6569	m3_total = MERGE( m3_total / nrclgb_total, &
6570	0.0_wp, nrclgb_total > 0.0_wp &
6571	)
6572	zeta = m1_total * m3_total / m2_total**2
6573	mu = MAX( ( ( 1.0_wp - zeta ) * 2.0_wp + 1.0_wp ) / &
6574	( zeta - 1.0_wp ), 0.0_wp &
6575	)
6576
6577	lambda = ( pirho_l * nr_total / lwc_total * &
6578	( mu + 3.0_wp ) * ( mu + 2.0_wp ) * ( mu + 1.0_wp ) &
6579	)**0.3333333_wp
6580	nr0 = nr_total / gamma( mu + 1.0_wp ) * lambda**( mu + 1.0_wp )
6581
6582	DO n = 0, n_max-1
6583	diameter = r_bin_mid(n) * 2.0_wp
6584	an_spl(n) = nr0 * diameter*mu EXP( -lambda * diameter ) * &
6585	( r_bin(n+1) - r_bin(n) ) * 2.0_wp
6586	ENDDO
6587	ELSEIF ( isf == 2 ) THEN
6588	DO n = 0, n_max-1
6589	an_spl(n) = nr_total / ( SQRT( 2.0_wp * pi ) * &
6590	LOG(sigma_log) * r_bin_mid(n) &
6591	) * &
6592	EXP( -( LOG( r_bin_mid(n) / rm_total )**2 ) / &
6593	( 2.0_wp * LOG(sigma_log)**2 ) &
6594	) * &
6595	( r_bin(n+1) - r_bin(n) )
6596	ENDDO
6597	ELSEIF( isf == 3 ) THEN
6598	DO n = 0, n_max-1
6599	an_spl(n) = 3.0_wp * nr_total * r_bin_mid(n)2 / rm_total3 * &
6600	EXP( - ( r_bin_mid(n)3 / rm_total3 ) ) * &
6601	( r_bin(n+1) - r_bin(n) )
6602	ENDDO
6603	ENDIF
6604	!
6605	!-- Criterion to avoid super droplets with a weighting factor < 1.0.
6606	an_spl = MAX(an_spl, 1.0_wp)
6607
6608	DO i = nxl, nxr
6609	DO j = nys, nyn
6610	DO k = nzb+1, nzt
6611	number_of_particles = prt_count(k,j,i)
6612	IF ( number_of_particles <= 0 .OR. &
6613	ql(k,j,i) < ql_crit ) CYCLE
6614	particles => grid_particles(k,j,i)%particles(1:number_of_particles)
6615	new_particles_gb = 0
6616	!
6617	!-- Start splitting operations. Each particle is checked if it
6618	!-- fulfilled the splitting criterion's. In splitting mode 'cl_av'
6619	!-- a critical radius (radius_split) and a splitting function must
6620	!-- be prescribed (see particles_par). The critical weighting factor
6621	!-- is calculated while approximating a 'gamma', 'log' or 'exp'-
6622	!-- drop size distribution. In this mode the DSD is calculated as
6623	!-- an average over all cloudy grid boxes. Super droplets which
6624	!-- have a larger radius and larger weighting factor are split into
6625	!-- 'splitting_factor' super droplets. In this case the splitting
6626	!-- factor is calculated of weighting factor of the super droplet
6627	!-- and the approximated number concentration for droplet of such
6628	!-- a size. Due to the splitting, the weighting factor of the
6629	!-- super droplet and all created clones is reduced by the factor
6630	!-- of 'splitting_facor'.
6631	DO n = 1, number_of_particles
6632	DO np = 0, n_max-1
6633	IF ( r_bin(np) >= radius_split .AND. &
6634	particles(n)%particle_mask .AND. &
6635	particles(n)%radius >= r_bin(np) .AND. &
6636	particles(n)%radius < r_bin(np+1) .AND. &
6637	particles(n)%weight_factor >= an_spl(np) ) &
6638	THEN
6639	!
6640	!-- Calculate splitting factor
6641	splitting_factor = &
6642	MIN( INT( particles(n)%weight_factor / &
6643	an_spl(np) &
6644	), splitting_factor_max &
6645	)
6646	IF ( splitting_factor < 2 ) CYCLE
6647	!
6648	!-- Calculate the new number of particles.
6649	new_size = prt_count(k,j,i) + splitting_factor - 1
6650	!
6651	!-- Cycle if maximum number of particles per grid box
6652	!-- is greater than the allowed maximum number.
6653	IF ( new_size >= max_number_particles_per_gridbox ) &
6654	CYCLE
6655	!
6656	!-- Reallocate particle array if necessary.
6657	IF ( new_size > SIZE(particles) ) THEN
6658	CALL realloc_particles_array( i, j, k, new_size )
6659	ENDIF
6660	old_size = prt_count(k,j,i)
6661	new_particles_gb = new_particles_gb + &
6662	splitting_factor - 1
6663	!
6664	!-- Calculate new weighting factor.
6665	particles(n)%weight_factor = &
6666	particles(n)%weight_factor / splitting_factor
6667	tmp_particle = particles(n)
6668	!
6669	!-- Create splitting_factor-1 new particles.
6670	DO jpp = 1, splitting_factor-1
6671	grid_particles(k,j,i)%particles(jpp+old_size) = &
6672	tmp_particle
6673	ENDDO
6674	!
6675	!-- Save the new number of super droplets.
6676	prt_count(k,j,i) = prt_count(k,j,i) + &
6677	splitting_factor - 1
6678	ENDIF
6679	ENDDO
6680	ENDDO
6681
6682	ENDDO
6683	ENDDO
6684	ENDDO
6685
6686	ELSEIF ( i_splitting_mode == 3 ) THEN
6687
6688	DO i = nxl, nxr
6689	DO j = nys, nyn
6690	DO k = nzb+1, nzt
6691
6692	!
6693	!-- Initialize summing variables.
6694	lwc = 0.0_wp
6695	m1 = 0.0_wp
6696	m2 = 0.0_wp
6697	m3 = 0.0_wp
6698	nr = 0.0_wp
6699	rm = 0.0_wp
6700
6701	new_particles_gb = 0
6702	number_of_particles = prt_count(k,j,i)
6703	IF ( number_of_particles <= 0 .OR. &
6704	ql(k,j,i) < ql_crit ) CYCLE
6705	particles => grid_particles(k,j,i)%particles
6706	!
6707	!-- Calculate moments of DSD.
6708	DO n = 1, number_of_particles
6709	IF ( particles(n)%particle_mask .AND. &
6710	particles(n)%radius >= r_min ) &
6711	THEN
6712	nr = nr + particles(n)%weight_factor
6713	rm = rm + factor_volume_to_mass * &
6714	particles(n)%radius*3 &
6715	particles(n)%weight_factor
6716	IF ( isf == 1 ) THEN
6717	diameter = particles(n)%radius * 2.0_wp
6718	lwc = lwc + factor_volume_to_mass * &
6719	particles(n)%radius*3 &
6720	particles(n)%weight_factor
6721	m1 = m1 + particles(n)%weight_factor * diameter
6722	m2 = m2 + particles(n)%weight_factor * diameter**2
6723	m3 = m3 + particles(n)%weight_factor * diameter**3
6724	ENDIF
6725	ENDIF
6726	ENDDO
6727
6728	IF ( nr <= 0.0_wp .OR. rm <= 0.0_wp ) CYCLE
6729	!
6730	!-- Calculate mean volume averaged radius.
6731	rm = ( rm / ( nr * factor_volume_to_mass ) )**0.3333333_wp
6732	!
6733	!-- Check which function should be used to approximate the DSD.
6734	IF ( isf == 1 ) THEN
6735	!
6736	!-- Gamma size distribution to calculate
6737	!-- critical weight_factor (e.g. Marshall + Palmer, 1948).
6738	zeta = m1 * m3 / m2**2
6739	mu = MAX( ( ( 1.0_wp - zeta ) * 2.0_wp + 1.0_wp ) / &
6740	( zeta - 1.0_wp ), 0.0_wp &
6741	)
6742	lambda = ( pirho_l * nr / lwc * &
6743	( mu + 3.0_wp ) * ( mu + 2.0_wp ) * &
6744	( mu + 1.0_wp ) &
6745	)**0.3333333_wp
6746	nr0 = ( nr / (gamma( mu + 1.0_wp ) ) ) * &
6747	lambda**( mu + 1.0_wp )
6748
6749	DO n = 0, n_max-1
6750	diameter = r_bin_mid(n) * 2.0_wp
6751	an_spl(n) = nr0 * diameter*mu &
6752	EXP( -lambda * diameter ) * &
6753	( r_bin(n+1) - r_bin(n) ) * 2.0_wp
6754	ENDDO
6755	ELSEIF ( isf == 2 ) THEN
6756	!
6757	!-- Lognormal size distribution to calculate critical
6758	!-- weight_factor (e.g. Levin, 1971, Bradley + Stow, 1974).
6759	DO n = 0, n_max-1
6760	an_spl(n) = nr / ( SQRT( 2.0_wp * pi ) * &
6761	LOG(sigma_log) * r_bin_mid(n) &
6762	) * &
6763	EXP( -( LOG( r_bin_mid(n) / rm )**2 ) / &
6764	( 2.0_wp * LOG(sigma_log)**2 ) &
6765	) * &
6766	( r_bin(n+1) - r_bin(n) )
6767	ENDDO
6768	ELSEIF ( isf == 3 ) THEN
6769	!
6770	!-- Exponential size distribution to calculate critical
6771	!-- weight_factor (e.g. Berry + Reinhardt, 1974).
6772	DO n = 0, n_max-1
6773	an_spl(n) = 3.0_wp * nr * r_bin_mid(n)2 / rm3 * &
6774	EXP( - ( r_bin_mid(n)3 / rm3 ) ) * &
6775	( r_bin(n+1) - r_bin(n) )
6776	ENDDO
6777	ENDIF
6778
6779	!
6780	!-- Criterion to avoid super droplets with a weighting factor < 1.0.
6781	an_spl = MAX(an_spl, 1.0_wp)
6782	!
6783	!-- Start splitting operations. Each particle is checked if it
6784	!-- fulfilled the splitting criterion's. In splitting mode 'gb_av'
6785	!-- a critical radius (radius_split) and a splitting function must
6786	!-- be prescribed (see particles_par). The critical weighting factor
6787	!-- is calculated while appoximating a 'gamma', 'log' or 'exp'-
6788	!-- drop size distribution. In this mode a DSD is calculated for
6789	!-- every cloudy grid box. Super droplets which have a larger
6790	!-- radius and larger weighting factor are split into
6791	!-- 'splitting_factor' super droplets. In this case the splitting
6792	!-- factor is calculated of weighting factor of the super droplet
6793	!-- and theapproximated number concentration for droplet of such
6794	!-- a size. Due to the splitting, the weighting factor of the
6795	!-- super droplet and all created clones is reduced by the factor
6796	!-- of 'splitting_facor'.
6797	DO n = 1, number_of_particles
6798	DO np = 0, n_max-1
6799	IF ( r_bin(np) >= radius_split .AND. &
6800	particles(n)%particle_mask .AND. &
6801	particles(n)%radius >= r_bin(np) .AND. &
6802	particles(n)%radius < r_bin(np+1) .AND. &
6803	particles(n)%weight_factor >= an_spl(np) ) &
6804	THEN
6805	!
6806	!-- Calculate splitting factor.
6807	splitting_factor = &
6808	MIN( INT( particles(n)%weight_factor / &
6809	an_spl(np) &
6810	), splitting_factor_max &
6811	)
6812	IF ( splitting_factor < 2 ) CYCLE
6813
6814	!
6815	!-- Calculate the new number of particles.
6816	new_size = prt_count(k,j,i) + splitting_factor - 1
6817	!
6818	!-- Cycle if maximum number of particles per grid box
6819	!-- is greater than the allowed maximum number.
6820	IF ( new_size >= max_number_particles_per_gridbox ) &
6821	CYCLE
6822	!
6823	!-- Reallocate particle array if necessary.
6824	IF ( new_size > SIZE(particles) ) THEN
6825	CALL realloc_particles_array( i, j, k, new_size )
6826	ENDIF
6827	!
6828	!-- Calculate new weighting factor.
6829	particles(n)%weight_factor = &
6830	particles(n)%weight_factor / splitting_factor
6831	tmp_particle = particles(n)
6832	old_size = prt_count(k,j,i)
6833	!
6834	!-- Create splitting_factor-1 new particles.
6835	DO jpp = 1, splitting_factor-1
6836	grid_particles(k,j,i)%particles( jpp + old_size ) = &
6837	tmp_particle
6838	ENDDO
6839	!
6840	!-- Save the new number of droplets for every grid box.
6841	prt_count(k,j,i) = prt_count(k,j,i) + &
6842	splitting_factor - 1
6843	new_particles_gb = new_particles_gb + &
6844	splitting_factor - 1
6845	ENDIF
6846	ENDDO
6847	ENDDO
6848	ENDDO
6849	ENDDO
6850	ENDDO
6851	ENDIF
6852
6853	CALL cpu_log( log_point_s(80), 'lpm_splitting', 'stop' )
6854
6855	END SUBROUTINE lpm_splitting
6856
6857
6858	!------------------------------------------------------------------------------!
6859	! Description:
6860	! ------------
6861	! This routine is a part of the Lagrangian particle model. Two Super droplets
6862	! which fulfill certain criterion's (e.g. a big weighting factor and a small
6863	! radius) can be merged into one super droplet with a increased number of
6864	! represented particles of the super droplet. This mechanism ensures an
6865	! improved a feasible amount of computational costs. The limits of particle
6866	! creation should be chosen carefully! The idea of this algorithm is based on
6867	! Unterstrasser and Soelch, 2014.
6868	!------------------------------------------------------------------------------!
6869	SUBROUTINE lpm_merging
6870
6871	INTEGER(iwp) :: i !<
6872	INTEGER(iwp) :: j !<
6873	INTEGER(iwp) :: k !<
6874	INTEGER(iwp) :: n !<
6875	INTEGER(iwp) :: merge_drp = 0 !< number of merged droplets
6876
6877
6878	REAL(wp) :: ql_crit = 1.0E-5_wp !< threshold lwc for cloudy grid cells
6879	!< (e.g. Siebesma et al 2003, JAS, 60)
6880
6881	CALL cpu_log( log_point_s(81), 'lpm_merging', 'start' )
6882
6883	merge_drp = 0
6884
6885	IF ( weight_factor_merge == -1.0_wp ) THEN
6886	weight_factor_merge = 0.5_wp * initial_weighting_factor
6887	ENDIF
6888
6889	DO i = nxl, nxr
6890	DO j = nys, nyn
6891	DO k = nzb+1, nzt
6892
6893	number_of_particles = prt_count(k,j,i)
6894	IF ( number_of_particles <= 0 .OR. &
6895	ql(k,j,i) >= ql_crit ) CYCLE
6896	particles => grid_particles(k,j,i)%particles(1:number_of_particles)
6897	!
6898	!-- Start merging operations: This routine delete super droplets with
6899	!-- a small radius (radius <= radius_merge) and a low weighting
6900	!-- factor (weight_factor <= weight_factor_merge). The number of
6901	!-- represented particles will be added to the next particle of the
6902	!-- particle array. Tests showed that this simplified method can be
6903	!-- used because it will only take place outside of cloudy grid
6904	!-- boxes where ql <= 1.0E-5 kg/kg. Therefore, especially former cloned
6905	!-- and subsequent evaporated super droplets will be merged.
6906	DO n = 1, number_of_particles-1
6907	IF ( particles(n)%particle_mask .AND. &
6908	particles(n+1)%particle_mask .AND. &
6909	particles(n)%radius <= radius_merge .AND. &
6910	particles(n)%weight_factor <= weight_factor_merge ) &
6911	THEN
6912	particles(n+1)%weight_factor = &
6913	particles(n+1)%weight_factor + &
6914	( particles(n)%radius**3 / &
6915	particles(n+1)%radius*3 &
6916	particles(n)%weight_factor &
6917	)
6918	particles(n)%particle_mask = .FALSE.
6919	deleted_particles = deleted_particles + 1
6920	merge_drp = merge_drp + 1
6921
6922	ENDIF
6923	ENDDO
6924	ENDDO
6925	ENDDO
6926	ENDDO
6927
6928
6929	CALL cpu_log( log_point_s(81), 'lpm_merging', 'stop' )
6930
6931	END SUBROUTINE lpm_merging
6932
6933
6934
6935
6936	!------------------------------------------------------------------------------!
6937	! Description:
6938	! ------------
6939	!> Exchange between subdomains.
6940	!> As soon as one particle has moved beyond the boundary of the domain, it
6941	!> is included in the relevant transfer arrays and marked for subsequent
6942	!> deletion on this PE.
6943	!> First sweep for crossings in x direction. Find out first the number of
6944	!> particles to be transferred and allocate temporary arrays needed to store
6945	!> them.
6946	!> For a one-dimensional decomposition along y, no transfer is necessary,
6947	!> because the particle remains on the PE, but the particle coordinate has to
6948	!> be adjusted.
6949	!------------------------------------------------------------------------------!
6950	SUBROUTINE lpm_exchange_horiz
6951
6952	INTEGER(iwp) :: i !< grid index (x) of particle positition
6953	INTEGER(iwp) :: ip !< index variable along x
6954	INTEGER(iwp) :: j !< grid index (y) of particle positition
6955	INTEGER(iwp) :: jp !< index variable along y
6956	INTEGER(iwp) :: kp !< index variable along z
6957	INTEGER(iwp) :: n !< particle index variable
6958	INTEGER(iwp) :: par_size !< Particle size in bytes
6959	INTEGER(iwp) :: trlp_count !< number of particles send to left PE
6960	INTEGER(iwp) :: trlp_count_recv !< number of particles receive from right PE
6961	INTEGER(iwp) :: trnp_count !< number of particles send to north PE
6962	INTEGER(iwp) :: trnp_count_recv !< number of particles receive from south PE
6963	INTEGER(iwp) :: trrp_count !< number of particles send to right PE
6964	INTEGER(iwp) :: trrp_count_recv !< number of particles receive from left PE
6965	INTEGER(iwp) :: trsp_count !< number of particles send to south PE
6966	INTEGER(iwp) :: trsp_count_recv !< number of particles receive from north PE
6967
6968	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: rvlp !< particles received from right PE
6969	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: rvnp !< particles received from south PE
6970	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: rvrp !< particles received from left PE
6971	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: rvsp !< particles received from north PE
6972	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: trlp !< particles send to left PE
6973	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: trnp !< particles send to north PE
6974	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: trrp !< particles send to right PE
6975	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: trsp !< particles send to south PE
6976
6977	CALL cpu_log( log_point_s(23), 'lpm_exchange_horiz', 'start' )
6978
6979	#if defined( __parallel )
6980
6981	!
6982	!-- Exchange between subdomains.
6983	!-- As soon as one particle has moved beyond the boundary of the domain, it
6984	!-- is included in the relevant transfer arrays and marked for subsequent
6985	!-- deletion on this PE.
6986	!-- First sweep for crossings in x direction. Find out first the number of
6987	!-- particles to be transferred and allocate temporary arrays needed to store
6988	!-- them.
6989	!-- For a one-dimensional decomposition along y, no transfer is necessary,
6990	!-- because the particle remains on the PE, but the particle coordinate has to
6991	!-- be adjusted.
6992	trlp_count = 0
6993	trrp_count = 0
6994
6995	trlp_count_recv = 0
6996	trrp_count_recv = 0
6997
6998	IF ( pdims(1) /= 1 ) THEN
6999	!
7000	!-- First calculate the storage necessary for sending and receiving the data.
7001	!-- Compute only first (nxl) and last (nxr) loop iterration.
7002	DO ip = nxl, nxr, nxr - nxl
7003	DO jp = nys, nyn
7004	DO kp = nzb+1, nzt
7005
7006	number_of_particles = prt_count(kp,jp,ip)
7007	IF ( number_of_particles <= 0 ) CYCLE
7008	particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
7009	DO n = 1, number_of_particles
7010	IF ( particles(n)%particle_mask ) THEN
7011	i = particles(n)%x * ddx
7012	!
7013	!-- Above calculation does not work for indices less than zero
7014	IF ( particles(n)%x < 0.0_wp) i = -1
7015
7016	IF ( i < nxl ) THEN
7017	trlp_count = trlp_count + 1
7018	ELSEIF ( i > nxr ) THEN
7019	trrp_count = trrp_count + 1
7020	ENDIF
7021	ENDIF
7022	ENDDO
7023
7024	ENDDO
7025	ENDDO
7026	ENDDO
7027
7028	IF ( trlp_count == 0 ) trlp_count = 1
7029	IF ( trrp_count == 0 ) trrp_count = 1
7030
7031	ALLOCATE( trlp(trlp_count), trrp(trrp_count) )
7032
7033	trlp = zero_particle
7034	trrp = zero_particle
7035
7036	trlp_count = 0
7037	trrp_count = 0
7038
7039	ENDIF
7040	!
7041	!-- Compute only first (nxl) and last (nxr) loop iterration
7042	DO ip = nxl, nxr, nxr-nxl
7043	DO jp = nys, nyn
7044	DO kp = nzb+1, nzt
7045	number_of_particles = prt_count(kp,jp,ip)
7046	IF ( number_of_particles <= 0 ) CYCLE
7047	particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
7048	DO n = 1, number_of_particles
7049	!
7050	!-- Only those particles that have not been marked as 'deleted' may
7051	!-- be moved.
7052	IF ( particles(n)%particle_mask ) THEN
7053
7054	i = particles(n)%x * ddx
7055	!
7056	!-- Above calculation does not work for indices less than zero
7057	IF ( particles(n)%x < 0.0_wp ) i = -1
7058
7059	IF ( i < nxl ) THEN
7060	IF ( i < 0 ) THEN
7061	!
7062	!-- Apply boundary condition along x
7063	IF ( ibc_par_lr == 0 ) THEN
7064	!
7065	!-- Cyclic condition
7066	IF ( pdims(1) == 1 ) THEN
7067	particles(n)%x = ( nx + 1 ) * dx + particles(n)%x
7068	particles(n)%origin_x = ( nx + 1 ) * dx + &
7069	particles(n)%origin_x
7070	ELSE
7071	trlp_count = trlp_count + 1
7072	trlp(trlp_count) = particles(n)
7073	trlp(trlp_count)%x = ( nx + 1 ) * dx + trlp(trlp_count)%x
7074	trlp(trlp_count)%origin_x = trlp(trlp_count)%origin_x + &
7075	( nx + 1 ) * dx
7076	particles(n)%particle_mask = .FALSE.
7077	deleted_particles = deleted_particles + 1
7078
7079	IF ( trlp(trlp_count)%x >= (nx + 1)* dx - 1.0E-12_wp ) THEN
7080	trlp(trlp_count)%x = trlp(trlp_count)%x - 1.0E-10_wp
7081	!++ why is 1 subtracted in next statement???
7082	trlp(trlp_count)%origin_x = trlp(trlp_count)%origin_x - 1
7083	ENDIF
7084
7085	ENDIF
7086
7087	ELSEIF ( ibc_par_lr == 1 ) THEN
7088	!
7089	!-- Particle absorption
7090	particles(n)%particle_mask = .FALSE.
7091	deleted_particles = deleted_particles + 1
7092
7093	ELSEIF ( ibc_par_lr == 2 ) THEN
7094	!
7095	!-- Particle reflection
7096	particles(n)%x = -particles(n)%x
7097	particles(n)%speed_x = -particles(n)%speed_x
7098
7099	ENDIF
7100	ELSE
7101	!
7102	!-- Store particle data in the transfer array, which will be
7103	!-- send to the neighbouring PE
7104	trlp_count = trlp_count + 1
7105	trlp(trlp_count) = particles(n)
7106	particles(n)%particle_mask = .FALSE.
7107	deleted_particles = deleted_particles + 1
7108
7109	ENDIF
7110
7111	ELSEIF ( i > nxr ) THEN
7112	IF ( i > nx ) THEN
7113	!
7114	!-- Apply boundary condition along x
7115	IF ( ibc_par_lr == 0 ) THEN
7116	!
7117	!-- Cyclic condition
7118	IF ( pdims(1) == 1 ) THEN
7119	particles(n)%x = particles(n)%x - ( nx + 1 ) * dx
7120	particles(n)%origin_x = particles(n)%origin_x - &
7121	( nx + 1 ) * dx
7122	ELSE
7123	trrp_count = trrp_count + 1
7124	trrp(trrp_count) = particles(n)
7125	trrp(trrp_count)%x = trrp(trrp_count)%x - ( nx + 1 ) * dx
7126	trrp(trrp_count)%origin_x = trrp(trrp_count)%origin_x - &
7127	( nx + 1 ) * dx
7128	particles(n)%particle_mask = .FALSE.
7129	deleted_particles = deleted_particles + 1
7130
7131	ENDIF
7132
7133	ELSEIF ( ibc_par_lr == 1 ) THEN
7134	!
7135	!-- Particle absorption
7136	particles(n)%particle_mask = .FALSE.
7137	deleted_particles = deleted_particles + 1
7138
7139	ELSEIF ( ibc_par_lr == 2 ) THEN
7140	!
7141	!-- Particle reflection
7142	particles(n)%x = 2 * ( nx * dx ) - particles(n)%x
7143	particles(n)%speed_x = -particles(n)%speed_x
7144
7145	ENDIF
7146	ELSE
7147	!
7148	!-- Store particle data in the transfer array, which will be send
7149	!-- to the neighbouring PE
7150	trrp_count = trrp_count + 1
7151	trrp(trrp_count) = particles(n)
7152	particles(n)%particle_mask = .FALSE.
7153	deleted_particles = deleted_particles + 1
7154
7155	ENDIF
7156
7157	ENDIF
7158	ENDIF
7159
7160	ENDDO
7161	ENDDO
7162	ENDDO
7163	ENDDO
7164
7165	!
7166	!-- STORAGE_SIZE returns the storage size of argument A in bits. However , it
7167	!-- is needed in bytes. The function C_SIZEOF which produces this value directly
7168	!-- causes problems with gfortran. For this reason the use of C_SIZEOF is avoided
7169	par_size = STORAGE_SIZE(trlp(1))/8
7170
7171
7172	!
7173	!-- Allocate arrays required for north-south exchange, as these
7174	!-- are used directly after particles are exchange along x-direction.
7175	ALLOCATE( move_also_north(1:NR_2_direction_move) )
7176	ALLOCATE( move_also_south(1:NR_2_direction_move) )
7177
7178	nr_move_north = 0
7179	nr_move_south = 0
7180	!
7181	!-- Send left boundary, receive right boundary (but first exchange how many
7182	!-- and check, if particle storage must be extended)
7183	IF ( pdims(1) /= 1 ) THEN
7184
7185	CALL MPI_SENDRECV( trlp_count, 1, MPI_INTEGER, pleft, 0, &
7186	trrp_count_recv, 1, MPI_INTEGER, pright, 0, &
7187	comm2d, status, ierr )
7188
7189	ALLOCATE(rvrp(MAX(1,trrp_count_recv)))
7190
7191	CALL MPI_SENDRECV( trlp, max(1,trlp_count)*par_size, MPI_BYTE,&
7192	pleft, 1, rvrp, &
7193	max(1,trrp_count_recv)*par_size, MPI_BYTE, pright, 1,&
7194	comm2d, status, ierr )
7195
7196	IF ( trrp_count_recv > 0 ) CALL lpm_add_particles_to_gridcell(rvrp(1:trrp_count_recv))
7197
7198	DEALLOCATE(rvrp)
7199
7200	!
7201	!-- Send right boundary, receive left boundary
7202	CALL MPI_SENDRECV( trrp_count, 1, MPI_INTEGER, pright, 0, &
7203	trlp_count_recv, 1, MPI_INTEGER, pleft, 0, &
7204	comm2d, status, ierr )
7205
7206	ALLOCATE(rvlp(MAX(1,trlp_count_recv)))
7207	!
7208	!-- This MPI_SENDRECV should work even with odd mixture on 32 and 64 Bit
7209	!-- variables in structure particle_type (due to the calculation of par_size)
7210	CALL MPI_SENDRECV( trrp, max(1,trrp_count)*par_size, MPI_BYTE,&
7211	pright, 1, rvlp, &
7212	max(1,trlp_count_recv)*par_size, MPI_BYTE, pleft, 1, &
7213	comm2d, status, ierr )
7214
7215	IF ( trlp_count_recv > 0 ) CALL lpm_add_particles_to_gridcell(rvlp(1:trlp_count_recv))
7216
7217	DEALLOCATE( rvlp )
7218	DEALLOCATE( trlp, trrp )
7219
7220	ENDIF
7221
7222	!
7223	!-- Check whether particles have crossed the boundaries in y direction. Note
7224	!-- that this case can also apply to particles that have just been received
7225	!-- from the adjacent right or left PE.
7226	!-- Find out first the number of particles to be transferred and allocate
7227	!-- temporary arrays needed to store them.
7228	!-- For a one-dimensional decomposition along y, no transfer is necessary,
7229	!-- because the particle remains on the PE.
7230	trsp_count = nr_move_south
7231	trnp_count = nr_move_north
7232
7233	trsp_count_recv = 0
7234	trnp_count_recv = 0
7235
7236	IF ( pdims(2) /= 1 ) THEN
7237	!
7238	!-- First calculate the storage necessary for sending and receiving the
7239	!-- data
7240	DO ip = nxl, nxr
7241	DO jp = nys, nyn, nyn-nys !compute only first (nys) and last (nyn) loop iterration
7242	DO kp = nzb+1, nzt
7243	number_of_particles = prt_count(kp,jp,ip)
7244	IF ( number_of_particles <= 0 ) CYCLE
7245	particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
7246	DO n = 1, number_of_particles
7247	IF ( particles(n)%particle_mask ) THEN
7248	j = particles(n)%y * ddy
7249	!
7250	!-- Above calculation does not work for indices less than zero
7251	IF ( particles(n)%y < 0.0_wp) j = -1
7252
7253	IF ( j < nys ) THEN
7254	trsp_count = trsp_count + 1
7255	ELSEIF ( j > nyn ) THEN
7256	trnp_count = trnp_count + 1
7257	ENDIF
7258	ENDIF
7259	ENDDO
7260	ENDDO
7261	ENDDO
7262	ENDDO
7263
7264	IF ( trsp_count == 0 ) trsp_count = 1
7265	IF ( trnp_count == 0 ) trnp_count = 1
7266
7267	ALLOCATE( trsp(trsp_count), trnp(trnp_count) )
7268
7269	trsp = zero_particle
7270	trnp = zero_particle
7271
7272	trsp_count = nr_move_south
7273	trnp_count = nr_move_north
7274
7275	trsp(1:nr_move_south) = move_also_south(1:nr_move_south)
7276	trnp(1:nr_move_north) = move_also_north(1:nr_move_north)
7277
7278	ENDIF
7279
7280	DO ip = nxl, nxr
7281	DO jp = nys, nyn, nyn-nys ! compute only first (nys) and last (nyn) loop iterration
7282	DO kp = nzb+1, nzt
7283	number_of_particles = prt_count(kp,jp,ip)
7284	IF ( number_of_particles <= 0 ) CYCLE
7285	particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
7286	DO n = 1, number_of_particles
7287	!
7288	!-- Only those particles that have not been marked as 'deleted' may
7289	!-- be moved.
7290	IF ( particles(n)%particle_mask ) THEN
7291
7292	j = particles(n)%y * ddy
7293	!
7294	!-- Above calculation does not work for indices less than zero
7295	IF ( particles(n)%y < 0.0_wp ) j = -1
7296
7297	IF ( j < nys ) THEN
7298	IF ( j < 0 ) THEN
7299	!
7300	!-- Apply boundary condition along y
7301	IF ( ibc_par_ns == 0 ) THEN
7302	!
7303	!-- Cyclic condition
7304	IF ( pdims(2) == 1 ) THEN
7305	particles(n)%y = ( ny + 1 ) * dy + particles(n)%y
7306	particles(n)%origin_y = ( ny + 1 ) * dy + &
7307	particles(n)%origin_y
7308	ELSE
7309	trsp_count = trsp_count + 1
7310	trsp(trsp_count) = particles(n)
7311	trsp(trsp_count)%y = ( ny + 1 ) * dy + &
7312	trsp(trsp_count)%y
7313	trsp(trsp_count)%origin_y = trsp(trsp_count)%origin_y &
7314	+ ( ny + 1 ) * dy
7315	particles(n)%particle_mask = .FALSE.
7316	deleted_particles = deleted_particles + 1
7317
7318	IF ( trsp(trsp_count)%y >= (ny+1)* dy - 1.0E-12_wp ) THEN
7319	trsp(trsp_count)%y = trsp(trsp_count)%y - 1.0E-10_wp
7320	!++ why is 1 subtracted in next statement???
7321	trsp(trsp_count)%origin_y = &
7322	trsp(trsp_count)%origin_y - 1
7323	ENDIF
7324
7325	ENDIF
7326
7327	ELSEIF ( ibc_par_ns == 1 ) THEN
7328	!
7329	!-- Particle absorption
7330	particles(n)%particle_mask = .FALSE.
7331	deleted_particles = deleted_particles + 1
7332
7333	ELSEIF ( ibc_par_ns == 2 ) THEN
7334	!
7335	!-- Particle reflection
7336	particles(n)%y = -particles(n)%y
7337	particles(n)%speed_y = -particles(n)%speed_y
7338
7339	ENDIF
7340	ELSE
7341	!
7342	!-- Store particle data in the transfer array, which will
7343	!-- be send to the neighbouring PE
7344	trsp_count = trsp_count + 1
7345	trsp(trsp_count) = particles(n)
7346	particles(n)%particle_mask = .FALSE.
7347	deleted_particles = deleted_particles + 1
7348
7349	ENDIF
7350
7351	ELSEIF ( j > nyn ) THEN
7352	IF ( j > ny ) THEN
7353	!
7354	!-- Apply boundary condition along y
7355	IF ( ibc_par_ns == 0 ) THEN
7356	!
7357	!-- Cyclic condition
7358	IF ( pdims(2) == 1 ) THEN
7359	particles(n)%y = particles(n)%y - ( ny + 1 ) * dy
7360	particles(n)%origin_y = &
7361	particles(n)%origin_y - ( ny + 1 ) * dy
7362	ELSE
7363	trnp_count = trnp_count + 1
7364	trnp(trnp_count) = particles(n)
7365	trnp(trnp_count)%y = &
7366	trnp(trnp_count)%y - ( ny + 1 ) * dy
7367	trnp(trnp_count)%origin_y = &
7368	trnp(trnp_count)%origin_y - ( ny + 1 ) * dy
7369	particles(n)%particle_mask = .FALSE.
7370	deleted_particles = deleted_particles + 1
7371	ENDIF
7372
7373	ELSEIF ( ibc_par_ns == 1 ) THEN
7374	!
7375	!-- Particle absorption
7376	particles(n)%particle_mask = .FALSE.
7377	deleted_particles = deleted_particles + 1
7378
7379	ELSEIF ( ibc_par_ns == 2 ) THEN
7380	!
7381	!-- Particle reflection
7382	particles(n)%y = 2 * ( ny * dy ) - particles(n)%y
7383	particles(n)%speed_y = -particles(n)%speed_y
7384
7385	ENDIF
7386	ELSE
7387	!
7388	!-- Store particle data in the transfer array, which will
7389	!-- be send to the neighbouring PE
7390	trnp_count = trnp_count + 1
7391	trnp(trnp_count) = particles(n)
7392	particles(n)%particle_mask = .FALSE.
7393	deleted_particles = deleted_particles + 1
7394
7395	ENDIF
7396
7397	ENDIF
7398	ENDIF
7399	ENDDO
7400	ENDDO
7401	ENDDO
7402	ENDDO
7403
7404	!
7405	!-- Send front boundary, receive back boundary (but first exchange how many
7406	!-- and check, if particle storage must be extended)
7407	IF ( pdims(2) /= 1 ) THEN
7408
7409	CALL MPI_SENDRECV( trsp_count, 1, MPI_INTEGER, psouth, 0, &
7410	trnp_count_recv, 1, MPI_INTEGER, pnorth, 0, &
7411	comm2d, status, ierr )
7412
7413	ALLOCATE(rvnp(MAX(1,trnp_count_recv)))
7414	!
7415	!-- This MPI_SENDRECV should work even with odd mixture on 32 and 64 Bit
7416	!-- variables in structure particle_type (due to the calculation of par_size)
7417	CALL MPI_SENDRECV( trsp, trsp_count*par_size, MPI_BYTE, &
7418	psouth, 1, rvnp, &
7419	trnp_count_recv*par_size, MPI_BYTE, pnorth, 1, &
7420	comm2d, status, ierr )
7421
7422	IF ( trnp_count_recv > 0 ) CALL lpm_add_particles_to_gridcell(rvnp(1:trnp_count_recv))
7423
7424	DEALLOCATE(rvnp)
7425
7426	!
7427	!-- Send back boundary, receive front boundary
7428	CALL MPI_SENDRECV( trnp_count, 1, MPI_INTEGER, pnorth, 0, &
7429	trsp_count_recv, 1, MPI_INTEGER, psouth, 0, &
7430	comm2d, status, ierr )
7431
7432	ALLOCATE(rvsp(MAX(1,trsp_count_recv)))
7433	!
7434	!-- This MPI_SENDRECV should work even with odd mixture on 32 and 64 Bit
7435	!-- variables in structure particle_type (due to the calculation of par_size)
7436	CALL MPI_SENDRECV( trnp, trnp_count*par_size, MPI_BYTE, &
7437	pnorth, 1, rvsp, &
7438	trsp_count_recv*par_size, MPI_BYTE, psouth, 1, &
7439	comm2d, status, ierr )
7440
7441	IF ( trsp_count_recv > 0 ) CALL lpm_add_particles_to_gridcell(rvsp(1:trsp_count_recv))
7442
7443	DEALLOCATE(rvsp)
7444
7445	number_of_particles = number_of_particles + trsp_count_recv
7446
7447	DEALLOCATE( trsp, trnp )
7448
7449	ENDIF
7450
7451	DEALLOCATE( move_also_north )
7452	DEALLOCATE( move_also_south )
7453
7454	#else
7455
7456	DO ip = nxl, nxr, nxr-nxl
7457	DO jp = nys, nyn
7458	DO kp = nzb+1, nzt
7459	number_of_particles = prt_count(kp,jp,ip)
7460	IF ( number_of_particles <= 0 ) CYCLE
7461	particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
7462	DO n = 1, number_of_particles
7463	!
7464	!-- Apply boundary conditions
7465
7466	IF ( particles(n)%x < 0.0_wp ) THEN
7467
7468	IF ( ibc_par_lr == 0 ) THEN
7469	!
7470	!-- Cyclic boundary. Relevant coordinate has to be changed.
7471	particles(n)%x = ( nx + 1 ) * dx + particles(n)%x
7472	particles(n)%origin_x = ( nx + 1 ) * dx + &
7473	particles(n)%origin_x
7474	ELSEIF ( ibc_par_lr == 1 ) THEN
7475	!
7476	!-- Particle absorption
7477	particles(n)%particle_mask = .FALSE.
7478	deleted_particles = deleted_particles + 1
7479
7480	ELSEIF ( ibc_par_lr == 2 ) THEN
7481	!
7482	!-- Particle reflection
7483	particles(n)%x = -dx - particles(n)%x
7484	particles(n)%speed_x = -particles(n)%speed_x
7485	ENDIF
7486
7487	ELSEIF ( particles(n)%x >= ( nx + 1) * dx ) THEN
7488
7489	IF ( ibc_par_lr == 0 ) THEN
7490	!
7491	!-- Cyclic boundary. Relevant coordinate has to be changed.
7492	particles(n)%x = particles(n)%x - ( nx + 1 ) * dx
7493	particles(n)%origin_x = particles(n)%origin_x - &
7494	( nx + 1 ) * dx
7495
7496	ELSEIF ( ibc_par_lr == 1 ) THEN
7497	!
7498	!-- Particle absorption
7499	particles(n)%particle_mask = .FALSE.
7500	deleted_particles = deleted_particles + 1
7501
7502	ELSEIF ( ibc_par_lr == 2 ) THEN
7503	!
7504	!-- Particle reflection
7505	particles(n)%x = ( nx + 1 ) * dx - particles(n)%x
7506	particles(n)%speed_x = -particles(n)%speed_x
7507	ENDIF
7508
7509	ENDIF
7510	ENDDO
7511	ENDDO
7512	ENDDO
7513	ENDDO
7514
7515	DO ip = nxl, nxr
7516	DO jp = nys, nyn, nyn-nys
7517	DO kp = nzb+1, nzt
7518	number_of_particles = prt_count(kp,jp,ip)
7519	IF ( number_of_particles <= 0 ) CYCLE
7520	particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
7521	DO n = 1, number_of_particles
7522
7523	IF ( particles(n)%y < 0.0_wp) THEN
7524
7525	IF ( ibc_par_ns == 0 ) THEN
7526	!
7527	!-- Cyclic boundary. Relevant coordinate has to be changed.
7528	particles(n)%y = ( ny + 1 ) * dy + particles(n)%y
7529	particles(n)%origin_y = ( ny + 1 ) * dy + &
7530	particles(n)%origin_y
7531
7532	ELSEIF ( ibc_par_ns == 1 ) THEN
7533	!
7534	!-- Particle absorption
7535	particles(n)%particle_mask = .FALSE.
7536	deleted_particles = deleted_particles + 1
7537
7538	ELSEIF ( ibc_par_ns == 2 ) THEN
7539	!
7540	!-- Particle reflection
7541	particles(n)%y = -dy - particles(n)%y
7542	particles(n)%speed_y = -particles(n)%speed_y
7543	ENDIF
7544
7545	ELSEIF ( particles(n)%y >= ( ny + 1) * dy ) THEN
7546
7547	IF ( ibc_par_ns == 0 ) THEN
7548	!
7549	!-- Cyclic boundary. Relevant coordinate has to be changed.
7550	particles(n)%y = particles(n)%y - ( ny + 1 ) * dy
7551	particles(n)%origin_y = particles(n)%origin_y - &
7552	( ny + 1 ) * dy
7553
7554	ELSEIF ( ibc_par_ns == 1 ) THEN
7555	!
7556	!-- Particle absorption
7557	particles(n)%particle_mask = .FALSE.
7558	deleted_particles = deleted_particles + 1
7559
7560	ELSEIF ( ibc_par_ns == 2 ) THEN
7561	!
7562	!-- Particle reflection
7563	particles(n)%y = ( ny + 1 ) * dy - particles(n)%y
7564	particles(n)%speed_y = -particles(n)%speed_y
7565	ENDIF
7566
7567	ENDIF
7568
7569	ENDDO
7570	ENDDO
7571	ENDDO
7572	ENDDO
7573	#endif
7574
7575	!
7576	!-- Accumulate the number of particles transferred between the subdomains
7577	#if defined( __parallel )
7578	trlp_count_sum = trlp_count_sum + trlp_count
7579	trlp_count_recv_sum = trlp_count_recv_sum + trlp_count_recv
7580	trrp_count_sum = trrp_count_sum + trrp_count
7581	trrp_count_recv_sum = trrp_count_recv_sum + trrp_count_recv
7582	trsp_count_sum = trsp_count_sum + trsp_count
7583	trsp_count_recv_sum = trsp_count_recv_sum + trsp_count_recv
7584	trnp_count_sum = trnp_count_sum + trnp_count
7585	trnp_count_recv_sum = trnp_count_recv_sum + trnp_count_recv
7586	#endif
7587
7588	CALL cpu_log( log_point_s(23), 'lpm_exchange_horiz', 'stop' )
7589
7590	END SUBROUTINE lpm_exchange_horiz
7591
7592	!------------------------------------------------------------------------------!
7593	! Description:
7594	! ------------
7595	!> If a particle moves from one processor to another, this subroutine moves
7596	!> the corresponding elements from the particle arrays of the old grid cells
7597	!> to the particle arrays of the new grid cells.
7598	!------------------------------------------------------------------------------!
7599	SUBROUTINE lpm_add_particles_to_gridcell (particle_array)
7600
7601	IMPLICIT NONE
7602
7603	INTEGER(iwp) :: ip !< grid index (x) of particle
7604	INTEGER(iwp) :: jp !< grid index (x) of particle
7605	INTEGER(iwp) :: kp !< grid index (x) of particle
7606	INTEGER(iwp) :: n !< index variable of particle
7607	INTEGER(iwp) :: pindex !< dummy argument for new number of particles per grid box
7608
7609	LOGICAL :: pack_done !<
7610
7611	TYPE(particle_type), DIMENSION(:), INTENT(IN) :: particle_array !< new particles in a grid box
7612	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: temp_ns !< temporary particle array for reallocation
7613
7614	pack_done = .FALSE.
7615
7616	DO n = 1, SIZE(particle_array)
7617
7618	IF ( .NOT. particle_array(n)%particle_mask ) CYCLE
7619
7620	ip = particle_array(n)%x * ddx
7621	jp = particle_array(n)%y * ddy
7622	!
7623	!-- In case of stretching the actual k index must be found
7624	IF ( dz_stretch_level /= -9999999.9_wp .OR. &
7625	dz_stretch_level_start(1) /= -9999999.9_wp ) THEN
7626	kp = MINLOC( ABS( particle_array(n)%z - zu ), DIM = 1 ) - 1
7627	ELSE
7628	kp = INT( particle_array(n)%z / dz(1) + 1 + offset_ocean_nzt )
7629	ENDIF
7630
7631	IF ( ip >= nxl .AND. ip <= nxr .AND. jp >= nys .AND. jp <= nyn &
7632	.AND. kp >= nzb+1 .AND. kp <= nzt) THEN ! particle stays on processor
7633	number_of_particles = prt_count(kp,jp,ip)
7634	particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
7635
7636	pindex = prt_count(kp,jp,ip)+1
7637	IF( pindex > SIZE(grid_particles(kp,jp,ip)%particles) ) THEN
7638	IF ( pack_done ) THEN
7639	CALL realloc_particles_array ( ip, jp, kp )
7640	ELSE
7641	CALL lpm_pack
7642	prt_count(kp,jp,ip) = number_of_particles
7643	pindex = prt_count(kp,jp,ip)+1
7644	IF ( pindex > SIZE(grid_particles(kp,jp,ip)%particles) ) THEN
7645	CALL realloc_particles_array ( ip, jp, kp )
7646	ENDIF
7647	pack_done = .TRUE.
7648	ENDIF
7649	ENDIF
7650	grid_particles(kp,jp,ip)%particles(pindex) = particle_array(n)
7651	prt_count(kp,jp,ip) = pindex
7652	ELSE
7653	IF ( jp <= nys - 1 ) THEN
7654	nr_move_south = nr_move_south+1
7655	!
7656	!-- Before particle information is swapped to exchange-array, check
7657	!-- if enough memory is allocated. If required, reallocate exchange
7658	!-- array.
7659	IF ( nr_move_south > SIZE(move_also_south) ) THEN
7660	!
7661	!-- At first, allocate further temporary array to swap particle
7662	!-- information.
7663	ALLOCATE( temp_ns(SIZE(move_also_south)+NR_2_direction_move) )
7664	temp_ns(1:nr_move_south-1) = move_also_south(1:nr_move_south-1)
7665	DEALLOCATE( move_also_south )
7666	ALLOCATE( move_also_south(SIZE(temp_ns)) )
7667	move_also_south(1:nr_move_south-1) = temp_ns(1:nr_move_south-1)
7668	DEALLOCATE( temp_ns )
7669
7670	ENDIF
7671
7672	move_also_south(nr_move_south) = particle_array(n)
7673
7674	IF ( jp == -1 ) THEN
7675	!
7676	!-- Apply boundary condition along y
7677	IF ( ibc_par_ns == 0 ) THEN
7678	move_also_south(nr_move_south)%y = &
7679	move_also_south(nr_move_south)%y + ( ny + 1 ) * dy
7680	move_also_south(nr_move_south)%origin_y = &
7681	move_also_south(nr_move_south)%origin_y + ( ny + 1 ) * dy
7682	ELSEIF ( ibc_par_ns == 1 ) THEN
7683	!
7684	!-- Particle absorption
7685	move_also_south(nr_move_south)%particle_mask = .FALSE.
7686	deleted_particles = deleted_particles + 1
7687
7688	ELSEIF ( ibc_par_ns == 2 ) THEN
7689	!
7690	!-- Particle reflection
7691	move_also_south(nr_move_south)%y = &
7692	-move_also_south(nr_move_south)%y
7693	move_also_south(nr_move_south)%speed_y = &
7694	-move_also_south(nr_move_south)%speed_y
7695
7696	ENDIF
7697	ENDIF
7698	ELSEIF ( jp >= nyn+1 ) THEN
7699	nr_move_north = nr_move_north+1
7700	!
7701	!-- Before particle information is swapped to exchange-array, check
7702	!-- if enough memory is allocated. If required, reallocate exchange
7703	!-- array.
7704	IF ( nr_move_north > SIZE(move_also_north) ) THEN
7705	!
7706	!-- At first, allocate further temporary array to swap particle
7707	!-- information.
7708	ALLOCATE( temp_ns(SIZE(move_also_north)+NR_2_direction_move) )
7709	temp_ns(1:nr_move_north-1) = move_also_south(1:nr_move_north-1)
7710	DEALLOCATE( move_also_north )
7711	ALLOCATE( move_also_north(SIZE(temp_ns)) )
7712	move_also_north(1:nr_move_north-1) = temp_ns(1:nr_move_north-1)
7713	DEALLOCATE( temp_ns )
7714
7715	ENDIF
7716
7717	move_also_north(nr_move_north) = particle_array(n)
7718	IF ( jp == ny+1 ) THEN
7719	!
7720	!-- Apply boundary condition along y
7721	IF ( ibc_par_ns == 0 ) THEN
7722
7723	move_also_north(nr_move_north)%y = &
7724	move_also_north(nr_move_north)%y - ( ny + 1 ) * dy
7725	move_also_north(nr_move_north)%origin_y = &
7726	move_also_north(nr_move_north)%origin_y - ( ny + 1 ) * dy
7727	ELSEIF ( ibc_par_ns == 1 ) THEN
7728	!
7729	!-- Particle absorption
7730	move_also_north(nr_move_north)%particle_mask = .FALSE.
7731	deleted_particles = deleted_particles + 1
7732
7733	ELSEIF ( ibc_par_ns == 2 ) THEN
7734	!
7735	!-- Particle reflection
7736	move_also_north(nr_move_north)%y = &
7737	-move_also_north(nr_move_north)%y
7738	move_also_north(nr_move_north)%speed_y = &
7739	-move_also_north(nr_move_north)%speed_y
7740
7741	ENDIF
7742	ENDIF
7743	ELSE
7744	WRITE(0,'(a,8i7)') 'particle out of range ',myid,ip,jp,kp,nxl,nxr,nys,nyn
7745	ENDIF
7746	ENDIF
7747	ENDDO
7748
7749	RETURN
7750
7751	END SUBROUTINE lpm_add_particles_to_gridcell
7752
7753
7754	!------------------------------------------------------------------------------!
7755	! Description:
7756	! ------------
7757	!> If a particle moves from one grid cell to another (on the current
7758	!> processor!), this subroutine moves the corresponding element from the
7759	!> particle array of the old grid cell to the particle array of the new grid
7760	!> cell.
7761	!------------------------------------------------------------------------------!
7762	SUBROUTINE lpm_move_particle
7763
7764	INTEGER(iwp) :: i !< grid index (x) of particle position
7765	INTEGER(iwp) :: ip !< index variable along x
7766	INTEGER(iwp) :: j !< grid index (y) of particle position
7767	INTEGER(iwp) :: jp !< index variable along y
7768	INTEGER(iwp) :: k !< grid index (z) of particle position
7769	INTEGER(iwp) :: kp !< index variable along z
7770	INTEGER(iwp) :: n !< index variable for particle array
7771	INTEGER(iwp) :: np_before_move !< number of particles per grid box before moving
7772	INTEGER(iwp) :: pindex !< dummy argument for number of new particle per grid box
7773
7774	TYPE(particle_type), DIMENSION(:), POINTER :: particles_before_move !< particles before moving
7775
7776	CALL cpu_log( log_point_s(41), 'lpm_move_particle', 'start' )
7777	CALL lpm_check_cfl
7778	DO ip = nxl, nxr
7779	DO jp = nys, nyn
7780	DO kp = nzb+1, nzt
7781
7782	np_before_move = prt_count(kp,jp,ip)
7783	IF ( np_before_move <= 0 ) CYCLE
7784	particles_before_move => grid_particles(kp,jp,ip)%particles(1:np_before_move)
7785
7786	DO n = 1, np_before_move
7787	i = particles_before_move(n)%x * ddx
7788	j = particles_before_move(n)%y * ddy
7789	k = kp
7790	!
7791	!-- Find correct vertical particle grid box (necessary in case of grid stretching)
7792	!-- Due to the CFL limitations only the neighbouring grid boxes are considered.
7793	IF( zw(k) < particles_before_move(n)%z ) k = k + 1
7794	IF( zw(k-1) > particles_before_move(n)%z ) k = k - 1
7795
7796	!-- For lpm_exchange_horiz to work properly particles need to be moved to the outermost gridboxes
7797	!-- of the respective processor. If the particle index is inside the processor the following lines
7798	!-- will not change the index
7799	i = MIN ( i , nxr )
7800	i = MAX ( i , nxl )
7801	j = MIN ( j , nyn )
7802	j = MAX ( j , nys )
7803
7804	k = MIN ( k , nzt )
7805	k = MAX ( k , nzb+1 )
7806
7807	!
7808	!-- Check, if particle has moved to another grid cell.
7809	IF ( i /= ip .OR. j /= jp .OR. k /= kp ) THEN
7810	!!
7811	!-- If the particle stays on the same processor, the particle
7812	!-- will be added to the particle array of the new processor.
7813	number_of_particles = prt_count(k,j,i)
7814	particles => grid_particles(k,j,i)%particles(1:number_of_particles)
7815
7816	pindex = prt_count(k,j,i)+1
7817	IF ( pindex > SIZE(grid_particles(k,j,i)%particles) ) &
7818	THEN
7819	CALL realloc_particles_array( i, j, k )
7820	ENDIF
7821
7822	grid_particles(k,j,i)%particles(pindex) = particles_before_move(n)
7823	prt_count(k,j,i) = pindex
7824
7825	particles_before_move(n)%particle_mask = .FALSE.
7826	ENDIF
7827	ENDDO
7828
7829	ENDDO
7830	ENDDO
7831	ENDDO
7832
7833	CALL cpu_log( log_point_s(41), 'lpm_move_particle', 'stop' )
7834
7835	RETURN
7836
7837	END SUBROUTINE lpm_move_particle
7838
7839
7840	!------------------------------------------------------------------------------!
7841	! Description:
7842	! ------------
7843	!> Check CFL-criterion for each particle. If one particle violated the
7844	!> criterion the particle will be deleted and a warning message is given.
7845	!------------------------------------------------------------------------------!
7846	SUBROUTINE lpm_check_cfl
7847
7848	IMPLICIT NONE
7849
7850	INTEGER(iwp) :: i !< running index, x-direction
7851	INTEGER(iwp) :: j !< running index, y-direction
7852	INTEGER(iwp) :: k !< running index, z-direction
7853	INTEGER(iwp) :: n !< running index, number of particles
7854
7855	DO i = nxl, nxr
7856	DO j = nys, nyn
7857	DO k = nzb+1, nzt
7858	number_of_particles = prt_count(k,j,i)
7859	IF ( number_of_particles <= 0 ) CYCLE
7860	particles => grid_particles(k,j,i)%particles(1:number_of_particles)
7861	DO n = 1, number_of_particles
7862	!
7863	!-- Note, check for CFL does not work at first particle timestep
7864	!-- when both, age and age_m are zero.
7865	IF ( particles(n)%age - particles(n)%age_m > 0.0_wp ) THEN
7866	IF(ABS(particles(n)%speed_x) > &
7867	(dx/(particles(n)%age-particles(n)%age_m)) .OR. &
7868	ABS(particles(n)%speed_y) > &
7869	(dy/(particles(n)%age-particles(n)%age_m)) .OR. &
7870	ABS(particles(n)%speed_z) > &
7871	((zw(k)-zw(k-1))/(particles(n)%age-particles(n)%age_m))) &
7872	THEN
7873	WRITE( message_string, * ) &
7874	'Particle violated CFL-criterion: &particle with id ', &
7875	particles(n)%id, ' will be deleted!'
7876	CALL message( 'lpm_check_cfl', 'PA0475', 0, 1, -1, 6, 0 )
7877	particles(n)%particle_mask= .FALSE.
7878	ENDIF
7879	ENDIF
7880	ENDDO
7881	ENDDO
7882	ENDDO
7883	ENDDO
7884
7885	END SUBROUTINE lpm_check_cfl
7886
7887
7888	!------------------------------------------------------------------------------!
7889	! Description:
7890	! ------------
7891	!> If the allocated memory for the particle array do not suffice to add arriving
7892	!> particles from neighbour grid cells, this subrouting reallocates the
7893	!> particle array to assure enough memory is available.
7894	!------------------------------------------------------------------------------!
7895	SUBROUTINE realloc_particles_array ( i, j, k, size_in )
7896
7897	INTEGER(iwp), INTENT(IN) :: i !<
7898	INTEGER(iwp), INTENT(IN) :: j !<
7899	INTEGER(iwp), INTENT(IN) :: k !<
7900	INTEGER(iwp), INTENT(IN), OPTIONAL :: size_in !<
7901
7902	INTEGER(iwp) :: old_size !<
7903	INTEGER(iwp) :: new_size !<
7904	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: tmp_particles_d !<
7905	TYPE(particle_type), DIMENSION(500) :: tmp_particles_s !<
7906
7907	old_size = SIZE(grid_particles(k,j,i)%particles)
7908
7909	IF ( PRESENT(size_in) ) THEN
7910	new_size = size_in
7911	ELSE
7912	new_size = old_size * ( 1.0_wp + alloc_factor / 100.0_wp )
7913	ENDIF
7914
7915	new_size = MAX( new_size, 1, old_size + 1 )
7916
7917	IF ( old_size <= 500 ) THEN
7918
7919	tmp_particles_s(1:old_size) = grid_particles(k,j,i)%particles(1:old_size)
7920
7921	DEALLOCATE(grid_particles(k,j,i)%particles)
7922	ALLOCATE(grid_particles(k,j,i)%particles(new_size))
7923
7924	grid_particles(k,j,i)%particles(1:old_size) = tmp_particles_s(1:old_size)
7925	grid_particles(k,j,i)%particles(old_size+1:new_size) = zero_particle
7926
7927	ELSE
7928
7929	ALLOCATE(tmp_particles_d(new_size))
7930	tmp_particles_d(1:old_size) = grid_particles(k,j,i)%particles
7931
7932	DEALLOCATE(grid_particles(k,j,i)%particles)
7933	ALLOCATE(grid_particles(k,j,i)%particles(new_size))
7934
7935	grid_particles(k,j,i)%particles(1:old_size) = tmp_particles_d(1:old_size)
7936	grid_particles(k,j,i)%particles(old_size+1:new_size) = zero_particle
7937
7938	DEALLOCATE(tmp_particles_d)
7939
7940	ENDIF
7941	particles => grid_particles(k,j,i)%particles(1:new_size)
7942
7943	RETURN
7944
7945	END SUBROUTINE realloc_particles_array
7946
7947
7948	!------------------------------------------------------------------------------!
7949	! Description:
7950	! ------------
7951	!> Not needed but allocated space for particles is dealloced.
7952	!------------------------------------------------------------------------------!
7953	SUBROUTINE dealloc_particles_array
7954
7955
7956	INTEGER(iwp) :: i !<
7957	INTEGER(iwp) :: j !<
7958	INTEGER(iwp) :: k !<
7959	INTEGER(iwp) :: old_size !<
7960	INTEGER(iwp) :: new_size !<
7961
7962	LOGICAL :: dealloc
7963
7964	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: tmp_particles_d !<
7965	TYPE(particle_type), DIMENSION(500) :: tmp_particles_s !<
7966
7967	DO i = nxl, nxr
7968	DO j = nys, nyn
7969	DO k = nzb+1, nzt
7970	!
7971	!-- Determine number of active particles
7972	number_of_particles = prt_count(k,j,i)
7973	!
7974	!-- Determine allocated memory size
7975	old_size = SIZE( grid_particles(k,j,i)%particles )
7976	!
7977	!-- Check for large unused memory
7978	dealloc = ( ( number_of_particles < 1 .AND. &
7979	old_size > 1 ) .OR. &
7980	( number_of_particles > 1 .AND. &
7981	old_size - number_of_particles * &
7982	( 1.0_wp + 0.01_wp * alloc_factor ) > 0.0_wp ) )
7983
7984	IF ( dealloc ) THEN
7985	IF ( number_of_particles < 1 ) THEN
7986	new_size = 1
7987	ELSE
7988	new_size = INT( number_of_particles * ( 1.0_wp + 0.01_wp * alloc_factor ) )
7989	ENDIF
7990
7991	IF ( number_of_particles <= 500 ) THEN
7992
7993	tmp_particles_s(1:number_of_particles) = grid_particles(k,j,i)%particles(1:number_of_particles)
7994
7995	DEALLOCATE(grid_particles(k,j,i)%particles)
7996	ALLOCATE(grid_particles(k,j,i)%particles(new_size))
7997
7998	grid_particles(k,j,i)%particles(1:number_of_particles) = tmp_particles_s(1:number_of_particles)
7999	grid_particles(k,j,i)%particles(number_of_particles+1:new_size) = zero_particle
8000
8001	ELSE
8002
8003	ALLOCATE(tmp_particles_d(number_of_particles))
8004	tmp_particles_d(1:number_of_particles) = grid_particles(k,j,i)%particles(1:number_of_particles)
8005
8006	DEALLOCATE(grid_particles(k,j,i)%particles)
8007	ALLOCATE(grid_particles(k,j,i)%particles(new_size))
8008
8009	grid_particles(k,j,i)%particles(1:number_of_particles) = tmp_particles_d(1:number_of_particles)
8010	grid_particles(k,j,i)%particles(number_of_particles+1:new_size) = zero_particle
8011
8012	DEALLOCATE(tmp_particles_d)
8013
8014	ENDIF
8015
8016	ENDIF
8017	ENDDO
8018	ENDDO
8019	ENDDO
8020
8021	END SUBROUTINE dealloc_particles_array
8022
8023
8024	!------------------------------------------------------------------------------!
8025	! Description:
8026	! -----------
8027	!> Routine for the whole processor
8028	!> Sort all particles into the 8 respective subgrid boxes (in case of trilinear
8029	!> interpolation method) and free space of particles which has been marked for
8030	!> deletion.
8031	!------------------------------------------------------------------------------!
8032	SUBROUTINE lpm_sort_and_delete
8033
8034	INTEGER(iwp) :: i !<
8035	INTEGER(iwp) :: ip !<
8036	INTEGER(iwp) :: is !<
8037	INTEGER(iwp) :: j !<
8038	INTEGER(iwp) :: jp !<
8039	INTEGER(iwp) :: kp !<
8040	INTEGER(iwp) :: m !<
8041	INTEGER(iwp) :: n !<
8042	INTEGER(iwp) :: nn !<
8043	INTEGER(iwp) :: sort_index !<
8044
8045	INTEGER(iwp), DIMENSION(0:7) :: sort_count !<
8046
8047	TYPE(particle_type), DIMENSION(:,:), ALLOCATABLE :: sort_particles !<
8048
8049	CALL cpu_log( log_point_s(51), 'lpm_sort_and_delete', 'start' )
8050	IF ( interpolation_trilinear ) THEN
8051	DO ip = nxl, nxr
8052	DO jp = nys, nyn
8053	DO kp = nzb+1, nzt
8054	number_of_particles = prt_count(kp,jp,ip)
8055	IF ( number_of_particles <= 0 ) CYCLE
8056	particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
8057	nn = 0
8058	sort_count = 0
8059	ALLOCATE( sort_particles(number_of_particles, 0:7) )
8060
8061	DO n = 1, number_of_particles
8062	sort_index = 0
8063
8064	IF ( particles(n)%particle_mask ) THEN
8065	nn = nn + 1
8066	!
8067	!-- Sorting particles with a binary scheme
8068	!-- sort_index=111_2=7_10 -> particle at the left,south,bottom subgridbox
8069	!-- sort_index=000_2=0_10 -> particle at the right,north,top subgridbox
8070	!-- For this the center of the gridbox is calculated
8071	i = (particles(n)%x + 0.5_wp * dx) * ddx
8072	j = (particles(n)%y + 0.5_wp * dy) * ddy
8073
8074	IF ( i == ip ) sort_index = sort_index + 4
8075	IF ( j == jp ) sort_index = sort_index + 2
8076	IF ( zu(kp) > particles(n)%z ) sort_index = sort_index + 1
8077
8078	sort_count(sort_index) = sort_count(sort_index) + 1
8079	m = sort_count(sort_index)
8080	sort_particles(m,sort_index) = particles(n)
8081	sort_particles(m,sort_index)%block_nr = sort_index
8082	ENDIF
8083	ENDDO
8084	!
8085	!-- Delete and resort particles by overwritting and set
8086	!-- the number_of_particles to the actual value.
8087	nn = 0
8088	DO is = 0,7
8089	grid_particles(kp,jp,ip)%start_index(is) = nn + 1
8090	DO n = 1,sort_count(is)
8091	nn = nn + 1
8092	particles(nn) = sort_particles(n,is)
8093	ENDDO
8094	grid_particles(kp,jp,ip)%end_index(is) = nn
8095	ENDDO
8096
8097	number_of_particles = nn
8098	prt_count(kp,jp,ip) = number_of_particles
8099	DEALLOCATE(sort_particles)
8100	ENDDO
8101	ENDDO
8102	ENDDO
8103
8104	!-- In case of the simple interpolation method the particles must not
8105	!-- be sorted in subboxes. Particles marked for deletion however, must be
8106	!-- deleted and number of particles must be recalculated as it is also
8107	!-- done for the trilinear particle advection interpolation method.
8108	ELSE
8109
8110	DO ip = nxl, nxr
8111	DO jp = nys, nyn
8112	DO kp = nzb+1, nzt
8113
8114	number_of_particles = prt_count(kp,jp,ip)
8115	IF ( number_of_particles <= 0 ) CYCLE
8116	particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
8117	!
8118	!-- Repack particles array, i.e. delete particles and recalculate
8119	!-- number of particles
8120	CALL lpm_pack
8121	prt_count(kp,jp,ip) = number_of_particles
8122	ENDDO
8123	ENDDO
8124	ENDDO
8125	ENDIF
8126	CALL cpu_log( log_point_s(51), 'lpm_sort_and_delete', 'stop' )
8127
8128	END SUBROUTINE lpm_sort_and_delete
8129
8130
8131	!------------------------------------------------------------------------------!
8132	! Description:
8133	! ------------
8134	!> Move all particles not marked for deletion to lowest indices (packing)
8135	!------------------------------------------------------------------------------!
8136	SUBROUTINE lpm_pack
8137
8138	INTEGER(iwp) :: n !<
8139	INTEGER(iwp) :: nn !<
8140	!
8141	!-- Find out elements marked for deletion and move data from highest index
8142	!-- values to these free indices
8143	nn = number_of_particles
8144
8145	DO WHILE ( .NOT. particles(nn)%particle_mask )
8146	nn = nn-1
8147	IF ( nn == 0 ) EXIT
8148	ENDDO
8149
8150	IF ( nn > 0 ) THEN
8151	DO n = 1, number_of_particles
8152	IF ( .NOT. particles(n)%particle_mask ) THEN
8153	particles(n) = particles(nn)
8154	nn = nn - 1
8155	DO WHILE ( .NOT. particles(nn)%particle_mask )
8156	nn = nn-1
8157	IF ( n == nn ) EXIT
8158	ENDDO
8159	ENDIF
8160	IF ( n == nn ) EXIT
8161	ENDDO
8162	ENDIF
8163
8164	!
8165	!-- The number of deleted particles has been determined in routines
8166	!-- lpm_boundary_conds, lpm_droplet_collision, and lpm_exchange_horiz
8167	number_of_particles = nn
8168
8169	END SUBROUTINE lpm_pack
8170
8171
8172	!------------------------------------------------------------------------------!
8173	! Description:
8174	! ------------
8175	!> Sort particles in each sub-grid box into two groups: particles that already
8176	!> completed the LES timestep, and particles that need further timestepping to
8177	!> complete the LES timestep.
8178	!------------------------------------------------------------------------------!
8179	SUBROUTINE lpm_sort_timeloop_done
8180
8181	INTEGER(iwp) :: end_index !< particle end index for each sub-box
8182	INTEGER(iwp) :: i !< index of particle grid box in x-direction
8183	INTEGER(iwp) :: j !< index of particle grid box in y-direction
8184	INTEGER(iwp) :: k !< index of particle grid box in z-direction
8185	INTEGER(iwp) :: n !< running index for number of particles
8186	INTEGER(iwp) :: nb !< index of subgrid boux
8187	INTEGER(iwp) :: nf !< indices for particles in each sub-box that already finalized their substeps
8188	INTEGER(iwp) :: nnf !< indices for particles in each sub-box that need further treatment
8189	INTEGER(iwp) :: num_finalized !< number of particles in each sub-box that already finalized their substeps
8190	INTEGER(iwp) :: start_index !< particle start index for each sub-box
8191
8192	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: sort_particles !< temporary particle array
8193
8194	DO i = nxl, nxr
8195	DO j = nys, nyn
8196	DO k = nzb+1, nzt
8197
8198	number_of_particles = prt_count(k,j,i)
8199	IF ( number_of_particles <= 0 ) CYCLE
8200	particles => grid_particles(k,j,i)%particles(1:number_of_particles)
8201
8202	DO nb = 0, 7
8203	!
8204	!-- Obtain start and end index for each subgrid box
8205	start_index = grid_particles(k,j,i)%start_index(nb)
8206	end_index = grid_particles(k,j,i)%end_index(nb)
8207	!
8208	!-- Allocate temporary array used for sorting.
8209	ALLOCATE( sort_particles(start_index:end_index) )
8210	!
8211	!-- Determine number of particles already completed the LES
8212	!-- timestep, and write them into a temporary array.
8213	nf = start_index
8214	num_finalized = 0
8215	DO n = start_index, end_index
8216	IF ( dt_3d - particles(n)%dt_sum < 1E-8_wp ) THEN
8217	sort_particles(nf) = particles(n)
8218	nf = nf + 1
8219	num_finalized = num_finalized + 1
8220	ENDIF
8221	ENDDO
8222	!
8223	!-- Determine number of particles that not completed the LES
8224	!-- timestep, and write them into a temporary array.
8225	nnf = nf
8226	DO n = start_index, end_index
8227	IF ( dt_3d - particles(n)%dt_sum > 1E-8_wp ) THEN
8228	sort_particles(nnf) = particles(n)
8229	nnf = nnf + 1
8230	ENDIF
8231	ENDDO
8232	!
8233	!-- Write back sorted particles
8234	particles(start_index:end_index) = &
8235	sort_particles(start_index:end_index)
8236	!
8237	!-- Determine updated start_index, used to masked already
8238	!-- completed particles.
8239	grid_particles(k,j,i)%start_index(nb) = &
8240	grid_particles(k,j,i)%start_index(nb) &
8241	+ num_finalized
8242	!
8243	!-- Deallocate dummy array
8244	DEALLOCATE ( sort_particles )
8245	!
8246	!-- Finally, if number of non-completed particles is non zero
8247	!-- in any of the sub-boxes, set control flag appropriately.
8248	IF ( nnf > nf ) &
8249	grid_particles(k,j,i)%time_loop_done = .FALSE.
8250
8251	ENDDO
8252	ENDDO
8253	ENDDO
8254	ENDDO
8255
8256	END SUBROUTINE lpm_sort_timeloop_done
8257
8258	END MODULE lagrangian_particle_model_mod

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |