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

Last change on this file since 4747 was 4731, checked in by schwenkel, 5 years ago

Move exchange_horiz from time_integration to modules

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