Home

Context Navigation

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

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