Home

Context Navigation

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

Last change on this file since 4067 was 4054, checked in by raasch, 6 years ago
bugfix for calculating the minimum particle time step
Property svn:keywords set to `Id`
File size: 339.0 KB

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