Home

Context Navigation

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

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