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

Last change on this file since 4144 was 4144, checked in by raasch, 2 years ago

relational operators .EQ., .NE., etc. replaced by ==, /=, etc.

  • Property svn:keywords set to Id
File size: 352.2 KB
Line 
1!> @file lagrangian_particle_model_mod.f90
2!------------------------------------------------------------------------------!
3! This file is part of the PALM model system.
4!
5! PALM is free software: you can redistribute it and/or modify it under the
6! terms of the GNU General Public License as published by the Free Software
7! Foundation, either version 3 of the License, or (at your option) any later
8! version.
9!
10! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
11! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
12! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
13!
14! You should have received a copy of the GNU General Public License along with
15! PALM. If not, see <http://www.gnu.org/licenses/>.
16!
17! Copyright 1997-2019 Leibniz Universitaet Hannover
18!------------------------------------------------------------------------------!
19!
20! Current revisions:
21! ------------------
22!
23!
24! Former revisions:
25! -----------------
26! $Id: lagrangian_particle_model_mod.f90 4144 2019-08-06 09:11:47Z raasch $
27! relational operators .EQ., .NE., etc. replaced by ==, /=, etc.
28!
29! 4143 2019-08-05 15:14:53Z schwenkel
30! Rename variable and change select case to if statement
31!
32! 4122 2019-07-26 13:11:56Z schwenkel
33! Implement reset method as bottom boundary condition
34!
35! 4121 2019-07-26 10:01:22Z schwenkel
36! Implementation of an simple method for interpolating the velocities to
37! particle position
38!
39! 4114 2019-07-23 14:09:27Z schwenkel
40! Bugfix: Added working precision for if statement
41!
42! 4054 2019-06-27 07:42:18Z raasch
43! bugfix for calculating the minimum particle time step
44!
45! 4044 2019-06-19 12:28:27Z schwenkel
46! Bugfix in case of grid strecting: corrected calculation of k-Index
47!
48! 4043 2019-06-18 16:59:00Z schwenkel
49! Remove min_nr_particle, Add lpm_droplet_interactions_ptq into module
50!
51! 4028 2019-06-13 12:21:37Z schwenkel
52! Further modularization of particle code components
53!
54! 4020 2019-06-06 14:57:48Z schwenkel
55! Removing submodules
56!
57! 4018 2019-06-06 13:41:50Z eckhard
58! Bugfix for former revision
59!
60! 4017 2019-06-06 12:16:46Z schwenkel
61! Modularization of all lagrangian particle model code components
62!
63! 3655 2019-01-07 16:51:22Z knoop
64! bugfix to guarantee correct particle releases in case that the release
65! interval is smaller than the model timestep
66!
67! 2801 2018-02-14 16:01:55Z thiele
68! Changed lpm from subroutine to module.
69! Introduce particle transfer in nested models.
70!
71! 2718 2018-01-02 08:49:38Z maronga
72! Corrected "Former revisions" section
73!
74! 2701 2017-12-15 15:40:50Z suehring
75! Changes from last commit documented
76!
77! 2698 2017-12-14 18:46:24Z suehring
78! Grid indices passed to lpm_boundary_conds. (responsible Philipp Thiele)
79!
80! 2696 2017-12-14 17:12:51Z kanani
81! Change in file header (GPL part)
82!
83! 2606 2017-11-10 10:36:31Z schwenkel
84! Changed particle box locations: center of particle box now coincides
85! with scalar grid point of same index.
86! Renamed module and subroutines: lpm_pack_arrays_mod -> lpm_pack_and_sort_mod
87! lpm_pack_all_arrays -> lpm_sort_and_delete, lpm_pack_arrays -> lpm_pack
88! lpm_sort -> lpm_sort_timeloop_done
89!
90! 2418 2017-09-06 15:24:24Z suehring
91! Major bugfixes in modeling SGS particle speeds (since revision 1359).
92! Particle sorting added to distinguish between already completed and
93! non-completed particles.
94!
95! 2263 2017-06-08 14:59:01Z schwenkel
96! Implemented splitting and merging algorithm
97!
98! 2233 2017-05-30 18:08:54Z suehring
99!
100! 2232 2017-05-30 17:47:52Z suehring
101! Adjustments to new topography concept
102!
103! 2000 2016-08-20 18:09:15Z knoop
104! Forced header and separation lines into 80 columns
105!
106! 1936 2016-06-13 13:37:44Z suehring
107! Call routine for deallocation of unused memory.
108! Formatting adjustments
109!
110! 1929 2016-06-09 16:25:25Z suehring
111! Call wall boundary conditions only if particles are in the vertical range of
112! topography.
113!
114! 1822 2016-04-07 07:49:42Z hoffmann
115! Tails removed.
116!
117! Initialization of sgs model not necessary for the use of cloud_droplets and
118! use_sgs_for_particles.
119!
120! lpm_release_set integrated.
121!
122! Unused variabled removed.
123!
124! 1682 2015-10-07 23:56:08Z knoop
125! Code annotations made doxygen readable
126!
127! 1416 2014-06-04 16:04:03Z suehring
128! user_lpm_advec is called for each gridpoint.
129! Bugfix: in order to prevent an infinite loop, time_loop_done is set .TRUE.
130! at the head of the do-loop. 
131!
132! 1359 2014-04-11 17:15:14Z hoffmann
133! New particle structure integrated.
134! Kind definition added to all floating point numbers.
135!
136! 1320 2014-03-20 08:40:49Z raasch
137! ONLY-attribute added to USE-statements,
138! kind-parameters added to all INTEGER and REAL declaration statements,
139! kinds are defined in new module kinds,
140! revision history before 2012 removed,
141! comment fields (!:) to be used for variable explanations added to
142! all variable declaration statements
143!
144! 1318 2014-03-17 13:35:16Z raasch
145! module interfaces removed
146!
147! 1036 2012-10-22 13:43:42Z raasch
148! code put under GPL (PALM 3.9)
149!
150! 851 2012-03-15 14:32:58Z raasch
151! Bugfix: resetting of particle_mask and tail mask moved from routine
152! lpm_exchange_horiz to here (end of sub-timestep loop)
153!
154! 849 2012-03-15 10:35:09Z raasch
155! original routine advec_particles split into several subroutines and renamed
156! lpm
157!
158! 831 2012-02-22 00:29:39Z raasch
159! thermal_conductivity_l and diff_coeff_l now depend on temperature and
160! pressure
161!
162! 828 2012-02-21 12:00:36Z raasch
163! fast hall/wang kernels with fixed radius/dissipation classes added,
164! particle feature color renamed class, routine colker renamed
165! recalculate_kernel,
166! lower limit for droplet radius changed from 1E-7 to 1E-8
167!
168! Bugfix: transformation factor for dissipation changed from 1E5 to 1E4
169!
170! 825 2012-02-19 03:03:44Z raasch
171! droplet growth by condensation may include curvature and solution effects,
172! initialisation of temporary particle array for resorting removed,
173! particle attributes speed_x|y|z_sgs renamed rvar1|2|3,
174! module wang_kernel_mod renamed lpm_collision_kernels_mod,
175! wang_collision_kernel renamed wang_kernel
176!
177!
178! Revision 1.1  1999/11/25 16:16:06  raasch
179! Initial revision
180!
181!
182! Description:
183! ------------
184!> The embedded LPM allows for studying transport and dispersion processes within
185!> turbulent flows. This model including passive particles that do not show any
186!> feedback on the turbulent flow. Further also particles with inertia and
187!> cloud droplets ca be simulated explicitly.
188!>
189!> @todo test lcm
190!>       implement simple interpolation method for subgrid scale velocites
191!> @note <Enter notes on the module>
192!> @bug  <Enter bug on the module>
193!------------------------------------------------------------------------------!
194 MODULE lagrangian_particle_model_mod
195
196    USE, INTRINSIC ::  ISO_C_BINDING
197
198    USE arrays_3d,                                                             &
199        ONLY:  de_dx, de_dy, de_dz, dzw, zu, zw,  ql_c, ql_v, ql_vp, hyp,      &
200               pt, q, exner, ql, diss, e, u, v, w, km, ql_1, ql_2, pt_p, q_p,  &
201               d_exner, u_p, v_p, w_p
202 
203    USE averaging,                                                             &
204        ONLY:  ql_c_av, pr_av, pc_av, ql_vp_av, ql_v_av
205
206    USE basic_constants_and_equations_mod,                                     &
207        ONLY: molecular_weight_of_solute, molecular_weight_of_water, magnus,   &
208              pi, rd_d_rv, rho_l, r_v, rho_s, vanthoff, l_v, kappa, g, lv_d_cp
209
210    USE control_parameters,                                                    &
211        ONLY:  bc_dirichlet_l, bc_dirichlet_n, bc_dirichlet_r, bc_dirichlet_s, &
212               cloud_droplets, constant_flux_layer, current_timestep_number,   &
213               dt_3d, dt_3d_reached, humidity,                                 &
214               dt_3d_reached_l, dt_dopts, dz, initializing_actions,            &
215               message_string, molecular_viscosity, ocean_mode,                &
216               particle_maximum_age, iran,                                     & 
217               simulated_time, topography, dopts_time_count,                   &
218               time_since_reference_point, rho_surface, u_gtrans, v_gtrans,    &
219               dz_stretch_level, dz_stretch_level_start
220
221    USE cpulog,                                                                &
222        ONLY:  cpu_log, log_point, log_point_s
223
224    USE indices,                                                               &
225        ONLY:  nx, nxl, nxlg, nxrg, nxr, ny, nyn, nys, nyng, nysg, nz, nzb,    &
226               nzb_max, nzt, wall_flags_0,nbgp, ngp_2dh_outer
227
228    USE kinds
229
230    USE pegrid
231
232    USE particle_attributes
233
234    USE pmc_particle_interface,                                                &
235        ONLY: pmcp_c_get_particle_from_parent, pmcp_p_fill_particle_win,       &
236              pmcp_c_send_particle_to_parent, pmcp_p_empty_particle_win,       &
237              pmcp_p_delete_particles_in_fine_grid_area, pmcp_g_init,          &
238              pmcp_g_print_number_of_particles
239
240    USE pmc_interface,                                                         &
241        ONLY: nested_run
242
243    USE grid_variables,                                                        &
244        ONLY:  ddx, dx, ddy, dy
245
246    USE netcdf_interface,                                                      &
247        ONLY:  netcdf_data_format, netcdf_deflate, dopts_num, id_set_pts,      &
248               id_var_dopts, id_var_time_pts, nc_stat,                         &
249               netcdf_handle_error
250
251    USE random_function_mod,                                                   &
252        ONLY:  random_function
253
254    USE statistics,                                                            &
255        ONLY:  hom
256
257    USE surface_mod,                                                           &
258        ONLY:  get_topography_top_index_ji, surf_def_h, surf_lsm_h, surf_usm_h,&
259               bc_h
260
261#if defined( __parallel )  &&  !defined( __mpifh )
262    USE MPI
263#endif
264
265#if defined( __parallel )  &&  defined( __mpifh )
266    INCLUDE "mpif.h"
267#endif     
268
269#if defined( __netcdf )
270    USE NETCDF
271#endif
272
273    IMPLICIT NONE
274
275    CHARACTER(LEN=15) ::  aero_species = 'nacl'                   !< aerosol species
276    CHARACTER(LEN=15) ::  aero_type    = 'maritime'               !< aerosol type
277    CHARACTER(LEN=15) ::  bc_par_lr    = 'cyclic'                 !< left/right boundary condition
278    CHARACTER(LEN=15) ::  bc_par_ns    = 'cyclic'                 !< north/south boundary condition
279    CHARACTER(LEN=15) ::  bc_par_b     = 'reflect'                !< bottom boundary condition
280    CHARACTER(LEN=15) ::  bc_par_t     = 'absorb'                 !< top boundary condition
281    CHARACTER(LEN=15) ::  collision_kernel   = 'none'             !< collision kernel
282
283    CHARACTER(LEN=5)  ::  splitting_function = 'gamma'            !< function for calculation critical weighting factor
284    CHARACTER(LEN=5)  ::  splitting_mode     = 'const'            !< splitting mode
285
286    CHARACTER(LEN=25) ::  particle_advection_interpolation = 'trilinear' !< interpolation method for calculatin the particle
287
288    INTEGER(iwp) ::  deleted_particles = 0                        !< number of deleted particles per time step   
289    INTEGER(iwp) ::  i_splitting_mode                             !< dummy for splitting mode
290    INTEGER(iwp) ::  iran_part = -1234567                         !< number for random generator   
291    INTEGER(iwp) ::  max_number_particles_per_gridbox = 100       !< namelist parameter (see documentation)
292    INTEGER(iwp) ::  isf                                          !< dummy for splitting function
293    INTEGER(iwp) ::  number_particles_per_gridbox = -1            !< namelist parameter (see documentation)
294    INTEGER(iwp) ::  number_of_sublayers = 20                     !< number of sublayers for particle velocities betwenn surface and first grid level
295    INTEGER(iwp) ::  offset_ocean_nzt = 0                         !< in case of oceans runs, the vertical index calculations need an offset
296    INTEGER(iwp) ::  offset_ocean_nzt_m1 = 0                      !< in case of oceans runs, the vertical index calculations need an offset
297    INTEGER(iwp) ::  particles_per_point = 1                      !< namelist parameter (see documentation)
298    INTEGER(iwp) ::  radius_classes = 20                          !< namelist parameter (see documentation)
299    INTEGER(iwp) ::  splitting_factor = 2                         !< namelist parameter (see documentation)
300    INTEGER(iwp) ::  splitting_factor_max = 5                     !< namelist parameter (see documentation)
301    INTEGER(iwp) ::  step_dealloc = 100                           !< namelist parameter (see documentation)
302    INTEGER(iwp) ::  total_number_of_particles                    !< total number of particles in the whole model domain
303    INTEGER(iwp) ::  trlp_count_sum                               !< parameter for particle exchange of PEs
304    INTEGER(iwp) ::  trlp_count_recv_sum                          !< parameter for particle exchange of PEs
305    INTEGER(iwp) ::  trrp_count_sum                               !< parameter for particle exchange of PEs
306    INTEGER(iwp) ::  trrp_count_recv_sum                          !< parameter for particle exchange of PEs
307    INTEGER(iwp) ::  trsp_count_sum                               !< parameter for particle exchange of PEs
308    INTEGER(iwp) ::  trsp_count_recv_sum                          !< parameter for particle exchange of PEs
309    INTEGER(iwp) ::  trnp_count_sum                               !< parameter for particle exchange of PEs
310    INTEGER(iwp) ::  trnp_count_recv_sum                          !< parameter for particle exchange of PEs
311
312    LOGICAL ::  lagrangian_particle_model = .FALSE.       !< namelist parameter (see documentation)
313    LOGICAL ::  curvature_solution_effects = .FALSE.      !< namelist parameter (see documentation)
314    LOGICAL ::  deallocate_memory = .TRUE.                !< namelist parameter (see documentation)
315    LOGICAL ::  hall_kernel = .FALSE.                     !< flag for collision kernel
316    LOGICAL ::  merging = .FALSE.                         !< namelist parameter (see documentation)
317    LOGICAL ::  random_start_position = .FALSE.           !< namelist parameter (see documentation)
318    LOGICAL ::  read_particles_from_restartfile = .TRUE.  !< namelist parameter (see documentation)
319    LOGICAL ::  seed_follows_topography = .FALSE.         !< namelist parameter (see documentation)
320    LOGICAL ::  splitting = .FALSE.                       !< namelist parameter (see documentation)
321    LOGICAL ::  use_kernel_tables = .FALSE.               !< parameter, which turns on the use of precalculated collision kernels
322    LOGICAL ::  write_particle_statistics = .FALSE.       !< namelist parameter (see documentation)
323    LOGICAL ::  interpolation_simple_predictor = .FALSE.  !< flag for simple particle advection interpolation with predictor step
324    LOGICAL ::  interpolation_simple_corrector = .FALSE.  !< flag for simple particle advection interpolation with corrector step
325    LOGICAL ::  interpolation_trilinear = .FALSE.         !< flag for trilinear particle advection interpolation
326
327    LOGICAL, DIMENSION(max_number_of_particle_groups) ::   vertical_particle_advection = .TRUE. !< Switch for vertical particle transport
328
329    REAL(wp) ::  aero_weight = 1.0_wp                      !< namelist parameter (see documentation)
330    REAL(wp) ::  dt_min_part = 0.0002_wp                   !< minimum particle time step when SGS velocities are used (s)
331    REAL(wp) ::  dt_prel = 9999999.9_wp                    !< namelist parameter (see documentation)
332    REAL(wp) ::  dt_write_particle_data = 9999999.9_wp     !< namelist parameter (see documentation)
333    REAL(wp) ::  end_time_prel = 9999999.9_wp              !< namelist parameter (see documentation)
334    REAL(wp) ::  initial_weighting_factor = 1.0_wp         !< namelist parameter (see documentation)
335    REAL(wp) ::  last_particle_release_time = 0.0_wp       !< last time of particle release
336    REAL(wp) ::  log_sigma(3) = 1.0_wp                     !< namelist parameter (see documentation)
337    REAL(wp) ::  na(3) = 0.0_wp                            !< namelist parameter (see documentation)
338    REAL(wp) ::  number_concentration = -1.0_wp            !< namelist parameter (see documentation)
339    REAL(wp) ::  radius_merge = 1.0E-7_wp                  !< namelist parameter (see documentation)
340    REAL(wp) ::  radius_split = 40.0E-6_wp                 !< namelist parameter (see documentation)
341    REAL(wp) ::  rm(3) = 1.0E-6_wp                         !< namelist parameter (see documentation)
342    REAL(wp) ::  sgs_wf_part                               !< parameter for sgs
343    REAL(wp) ::  time_write_particle_data = 0.0_wp         !< write particle data at current time on file
344    REAL(wp) ::  weight_factor_merge = -1.0_wp             !< namelist parameter (see documentation)
345    REAL(wp) ::  weight_factor_split = -1.0_wp             !< namelist parameter (see documentation)
346    REAL(wp) ::  z0_av_global                              !< horizontal mean value of z0
347
348    REAL(wp) ::  rclass_lbound !<
349    REAL(wp) ::  rclass_ubound !<
350
351    REAL(wp), PARAMETER ::  c_0 = 3.0_wp         !< parameter for lagrangian timescale
352
353    REAL(wp), DIMENSION(max_number_of_particle_groups) ::  density_ratio = 9999999.9_wp  !< namelist parameter (see documentation)
354    REAL(wp), DIMENSION(max_number_of_particle_groups) ::  pdx = 9999999.9_wp            !< namelist parameter (see documentation)
355    REAL(wp), DIMENSION(max_number_of_particle_groups) ::  pdy = 9999999.9_wp            !< namelist parameter (see documentation)
356    REAL(wp), DIMENSION(max_number_of_particle_groups) ::  pdz = 9999999.9_wp            !< namelist parameter (see documentation)
357    REAL(wp), DIMENSION(max_number_of_particle_groups) ::  psb = 9999999.9_wp            !< namelist parameter (see documentation)
358    REAL(wp), DIMENSION(max_number_of_particle_groups) ::  psl = 9999999.9_wp            !< namelist parameter (see documentation)
359    REAL(wp), DIMENSION(max_number_of_particle_groups) ::  psn = 9999999.9_wp            !< namelist parameter (see documentation)
360    REAL(wp), DIMENSION(max_number_of_particle_groups) ::  psr = 9999999.9_wp            !< namelist parameter (see documentation)
361    REAL(wp), DIMENSION(max_number_of_particle_groups) ::  pss = 9999999.9_wp            !< namelist parameter (see documentation)
362    REAL(wp), DIMENSION(max_number_of_particle_groups) ::  pst = 9999999.9_wp            !< namelist parameter (see documentation).
363    REAL(wp), DIMENSION(max_number_of_particle_groups) ::  radius = 9999999.9_wp         !< namelist parameter (see documentation)
364
365    REAL(wp), DIMENSION(:), ALLOCATABLE     ::  log_z_z0   !< Precalculate LOG(z/z0) 
366
367    INTEGER(iwp), PARAMETER ::  NR_2_direction_move = 10000 !<
368    INTEGER(iwp)            ::  nr_move_north               !<
369    INTEGER(iwp)            ::  nr_move_south               !<
370
371    TYPE(particle_type), DIMENSION(:), ALLOCATABLE ::  move_also_north
372    TYPE(particle_type), DIMENSION(:), ALLOCATABLE ::  move_also_south
373
374    REAL(wp) ::  epsilon_collision !<
375    REAL(wp) ::  urms              !<
376
377    REAL(wp), DIMENSION(:),   ALLOCATABLE ::  epsclass  !< dissipation rate class
378    REAL(wp), DIMENSION(:),   ALLOCATABLE ::  radclass  !< radius class
379    REAL(wp), DIMENSION(:),   ALLOCATABLE ::  winf      !<
380
381    REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  ec        !<
382    REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  ecf       !<
383    REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  gck       !<
384    REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  hkernel   !<
385    REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  hwratio   !<
386
387    REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  ckernel !<
388
389    INTEGER(iwp), PARAMETER         :: PHASE_INIT    = 1  !<
390    INTEGER(iwp), PARAMETER, PUBLIC :: PHASE_RELEASE = 2  !<
391
392    SAVE
393
394    PRIVATE
395
396    PUBLIC lpm_parin,     &
397           lpm_header,    &
398           lpm_init_arrays,&
399           lpm_init,      &
400           lpm_actions,   &
401           lpm_data_output_ptseries, &
402           lpm_interaction_droplets_ptq, &
403           lpm_rrd_local_particles, &
404           lpm_wrd_local, &
405           lpm_rrd_global, &
406           lpm_wrd_global, &
407           lpm_rrd_local, &
408           lpm_check_parameters
409
410    PUBLIC lagrangian_particle_model
411
412    INTERFACE lpm_check_parameters
413       MODULE PROCEDURE lpm_check_parameters
414    END INTERFACE lpm_check_parameters
415
416    INTERFACE lpm_parin
417       MODULE PROCEDURE lpm_parin
418    END INTERFACE lpm_parin
419
420    INTERFACE lpm_header
421       MODULE PROCEDURE lpm_header
422    END INTERFACE lpm_header
423
424    INTERFACE lpm_init_arrays
425       MODULE PROCEDURE lpm_init_arrays
426    END INTERFACE lpm_init_arrays
427 
428    INTERFACE lpm_init
429       MODULE PROCEDURE lpm_init
430    END INTERFACE lpm_init
431
432    INTERFACE lpm_actions
433       MODULE PROCEDURE lpm_actions
434    END INTERFACE lpm_actions
435
436    INTERFACE lpm_data_output_ptseries
437       MODULE PROCEDURE lpm_data_output_ptseries
438    END INTERFACE
439
440    INTERFACE lpm_rrd_local_particles
441       MODULE PROCEDURE lpm_rrd_local_particles
442    END INTERFACE lpm_rrd_local_particles
443
444    INTERFACE lpm_rrd_global
445       MODULE PROCEDURE lpm_rrd_global
446    END INTERFACE lpm_rrd_global
447
448    INTERFACE lpm_rrd_local
449       MODULE PROCEDURE lpm_rrd_local
450    END INTERFACE lpm_rrd_local
451
452    INTERFACE lpm_wrd_local
453       MODULE PROCEDURE lpm_wrd_local
454    END INTERFACE lpm_wrd_local
455
456    INTERFACE lpm_wrd_global
457       MODULE PROCEDURE lpm_wrd_global
458    END INTERFACE lpm_wrd_global
459
460    INTERFACE lpm_advec
461       MODULE PROCEDURE lpm_advec
462    END INTERFACE lpm_advec
463
464    INTERFACE lpm_calc_liquid_water_content
465       MODULE PROCEDURE lpm_calc_liquid_water_content
466    END INTERFACE
467
468    INTERFACE lpm_interaction_droplets_ptq
469       MODULE PROCEDURE lpm_interaction_droplets_ptq
470       MODULE PROCEDURE lpm_interaction_droplets_ptq_ij
471    END INTERFACE lpm_interaction_droplets_ptq
472
473    INTERFACE lpm_boundary_conds
474       MODULE PROCEDURE lpm_boundary_conds
475    END INTERFACE lpm_boundary_conds
476
477    INTERFACE lpm_droplet_condensation
478       MODULE PROCEDURE lpm_droplet_condensation
479    END INTERFACE
480
481    INTERFACE lpm_droplet_collision
482       MODULE PROCEDURE lpm_droplet_collision
483    END INTERFACE lpm_droplet_collision
484
485    INTERFACE lpm_init_kernels
486       MODULE PROCEDURE lpm_init_kernels
487    END INTERFACE lpm_init_kernels
488
489    INTERFACE lpm_splitting
490       MODULE PROCEDURE lpm_splitting
491    END INTERFACE lpm_splitting
492
493    INTERFACE lpm_merging
494       MODULE PROCEDURE lpm_merging
495    END INTERFACE lpm_merging
496
497    INTERFACE lpm_exchange_horiz
498       MODULE PROCEDURE lpm_exchange_horiz
499    END INTERFACE lpm_exchange_horiz
500
501    INTERFACE lpm_move_particle
502       MODULE PROCEDURE lpm_move_particle
503    END INTERFACE lpm_move_particle
504
505    INTERFACE realloc_particles_array
506       MODULE PROCEDURE realloc_particles_array
507    END INTERFACE realloc_particles_array
508
509    INTERFACE dealloc_particles_array
510       MODULE PROCEDURE dealloc_particles_array
511    END INTERFACE dealloc_particles_array
512
513    INTERFACE lpm_sort_and_delete
514       MODULE PROCEDURE lpm_sort_and_delete
515    END INTERFACE lpm_sort_and_delete
516
517    INTERFACE lpm_sort_timeloop_done
518       MODULE PROCEDURE lpm_sort_timeloop_done
519    END INTERFACE lpm_sort_timeloop_done
520
521    INTERFACE lpm_pack
522       MODULE PROCEDURE lpm_pack
523    END INTERFACE lpm_pack
524
525 CONTAINS
526 
527
528!------------------------------------------------------------------------------!
529! Description:
530! ------------
531!> Parin for &particle_parameters for the Lagrangian particle model
532!------------------------------------------------------------------------------!
533 SUBROUTINE lpm_parin
534 
535    CHARACTER (LEN=80) ::  line  !<
536
537    NAMELIST /particles_par/ &
538       aero_species, &
539       aero_type, &
540       aero_weight, &
541       alloc_factor, &
542       bc_par_b, &
543       bc_par_lr, &
544       bc_par_ns, &
545       bc_par_t, &
546       collision_kernel, &
547       curvature_solution_effects, &
548       deallocate_memory, &
549       density_ratio, &
550       dissipation_classes, &
551       dt_dopts, &
552       dt_min_part, &
553       dt_prel, &
554       dt_write_particle_data, &
555       end_time_prel, &
556       initial_weighting_factor, &
557       log_sigma, &
558       max_number_particles_per_gridbox, &
559       merging, &
560       na, &
561       number_concentration, &
562       number_of_particle_groups, &
563       number_particles_per_gridbox, &
564       particles_per_point, &
565       particle_advection_start, &
566       particle_advection_interpolation, &
567       particle_maximum_age, &
568       pdx, &
569       pdy, &
570       pdz, &
571       psb, &
572       psl, &
573       psn, &
574       psr, &
575       pss, &
576       pst, &
577       radius, &
578       radius_classes, &
579       radius_merge, &
580       radius_split, &
581       random_start_position, &
582       read_particles_from_restartfile, &
583       rm, &
584       seed_follows_topography, &
585       splitting, &
586       splitting_factor, &
587       splitting_factor_max, &
588       splitting_function, &
589       splitting_mode, &
590       step_dealloc, &
591       use_sgs_for_particles, &
592       vertical_particle_advection, &
593       weight_factor_merge, &
594       weight_factor_split, &
595       write_particle_statistics
596
597       NAMELIST /particle_parameters/ &
598       aero_species, &
599       aero_type, &
600       aero_weight, &
601       alloc_factor, &
602       bc_par_b, &
603       bc_par_lr, &
604       bc_par_ns, &
605       bc_par_t, &
606       collision_kernel, &
607       curvature_solution_effects, &
608       deallocate_memory, &
609       density_ratio, &
610       dissipation_classes, &
611       dt_dopts, &
612       dt_min_part, &
613       dt_prel, &
614       dt_write_particle_data, &
615       end_time_prel, &
616       initial_weighting_factor, &
617       log_sigma, &
618       max_number_particles_per_gridbox, &
619       merging, &
620       na, &
621       number_concentration, &
622       number_of_particle_groups, &
623       number_particles_per_gridbox, &
624       particles_per_point, &
625       particle_advection_start, &
626       particle_advection_interpolation, &
627       particle_maximum_age, &
628       pdx, &
629       pdy, &
630       pdz, &
631       psb, &
632       psl, &
633       psn, &
634       psr, &
635       pss, &
636       pst, &
637       radius, &
638       radius_classes, &
639       radius_merge, &
640       radius_split, &
641       random_start_position, &
642       read_particles_from_restartfile, &
643       rm, &
644       seed_follows_topography, &
645       splitting, &
646       splitting_factor, &
647       splitting_factor_max, &
648       splitting_function, &
649       splitting_mode, &
650       step_dealloc, &
651       use_sgs_for_particles, &
652       vertical_particle_advection, &
653       weight_factor_merge, &
654       weight_factor_split, &
655       write_particle_statistics
656
657!
658!-- Position the namelist-file at the beginning (it was already opened in
659!-- parin), search for the namelist-group of the package and position the
660!-- file at this line. Do the same for each optionally used package.
661    line = ' '
662   
663!
664!-- Try to find particles package
665    REWIND ( 11 )
666    line = ' '
667    DO   WHILE ( INDEX( line, '&particle_parameters' ) == 0 )
668       READ ( 11, '(A)', END=12 )  line
669    ENDDO
670    BACKSPACE ( 11 )
671!
672!-- Read user-defined namelist
673    READ ( 11, particle_parameters, ERR = 10 )
674!
675!-- Set flag that indicates that particles are switched on
676    particle_advection = .TRUE.
677   
678    GOTO 14
679
68010  BACKSPACE( 11 )
681    READ( 11 , '(A)') line
682    CALL parin_fail_message( 'particle_parameters', line )
683!
684!-- Try to find particles package (old namelist)
68512  REWIND ( 11 )
686    line = ' '
687    DO WHILE ( INDEX( line, '&particles_par' ) == 0 )
688       READ ( 11, '(A)', END=14 )  line
689    ENDDO
690    BACKSPACE ( 11 )
691!
692!-- Read user-defined namelist
693    READ ( 11, particles_par, ERR = 13, END = 14 )
694
695    message_string = 'namelist particles_par is deprecated and will be ' //    &
696                     'removed in near future. Please use namelist ' //         &
697                     'particle_parameters instead'
698    CALL message( 'package_parin', 'PA0487', 0, 1, 0, 6, 0 )
699
700!
701!-- Set flag that indicates that particles are switched on
702    particle_advection = .TRUE.
703
704    GOTO 14
705
70613    BACKSPACE( 11 )
707       READ( 11 , '(A)') line
708       CALL parin_fail_message( 'particles_par', line )
709
71014 CONTINUE
711
712 END SUBROUTINE lpm_parin
713 
714!------------------------------------------------------------------------------!
715! Description:
716! ------------
717!> Writes used particle attributes in header file.
718!------------------------------------------------------------------------------!
719 SUBROUTINE lpm_header ( io )
720
721    CHARACTER (LEN=40) ::  output_format       !< netcdf format
722 
723    INTEGER(iwp) ::  i               !<
724    INTEGER(iwp), INTENT(IN) ::  io  !< Unit of the output file
725
726 
727     IF ( humidity  .AND.  cloud_droplets )  THEN
728       WRITE ( io, 433 )
729       IF ( curvature_solution_effects )  WRITE ( io, 434 )
730       IF ( collision_kernel /= 'none' )  THEN
731          WRITE ( io, 435 )  TRIM( collision_kernel )
732          IF ( collision_kernel(6:9) == 'fast' )  THEN
733             WRITE ( io, 436 )  radius_classes, dissipation_classes
734          ENDIF
735       ELSE
736          WRITE ( io, 437 )
737       ENDIF
738    ENDIF
739 
740    IF ( particle_advection )  THEN
741!
742!--    Particle attributes
743       WRITE ( io, 480 )  particle_advection_start, dt_prel, bc_par_lr, &
744                          bc_par_ns, bc_par_b, bc_par_t, particle_maximum_age, &
745                          end_time_prel
746       IF ( use_sgs_for_particles )  WRITE ( io, 488 )  dt_min_part
747       IF ( random_start_position )  WRITE ( io, 481 )
748       IF ( seed_follows_topography )  WRITE ( io, 496 )
749       IF ( particles_per_point > 1 )  WRITE ( io, 489 )  particles_per_point
750       WRITE ( io, 495 )  total_number_of_particles
751       IF ( dt_write_particle_data /= 9999999.9_wp )  THEN
752          WRITE ( io, 485 )  dt_write_particle_data
753          IF ( netcdf_data_format > 1 )  THEN
754             output_format = 'netcdf (64 bit offset) and binary'
755          ELSE
756             output_format = 'netcdf and binary'
757          ENDIF
758          IF ( netcdf_deflate == 0 )  THEN
759             WRITE ( io, 344 )  output_format
760          ELSE
761             WRITE ( io, 354 )  TRIM( output_format ), netcdf_deflate
762          ENDIF
763       ENDIF
764       IF ( dt_dopts /= 9999999.9_wp )  WRITE ( io, 494 )  dt_dopts
765       IF ( write_particle_statistics )  WRITE ( io, 486 )
766
767       WRITE ( io, 487 )  number_of_particle_groups
768
769       DO  i = 1, number_of_particle_groups
770          IF ( i == 1  .AND.  density_ratio(i) == 9999999.9_wp )  THEN
771             WRITE ( io, 490 )  i, 0.0_wp
772             WRITE ( io, 492 )
773          ELSE
774             WRITE ( io, 490 )  i, radius(i)
775             IF ( density_ratio(i) /= 0.0_wp )  THEN
776                WRITE ( io, 491 )  density_ratio(i)
777             ELSE
778                WRITE ( io, 492 )
779             ENDIF
780          ENDIF
781          WRITE ( io, 493 )  psl(i), psr(i), pss(i), psn(i), psb(i), pst(i), &
782                             pdx(i), pdy(i), pdz(i)
783          IF ( .NOT. vertical_particle_advection(i) )  WRITE ( io, 482 )
784       ENDDO
785
786    ENDIF
787   
788344 FORMAT ('       Output format: ',A/)
789354 FORMAT ('       Output format: ',A, '   compressed with level: ',I1/)
790
791433 FORMAT ('    Cloud droplets treated explicitly using the Lagrangian part', &
792                 'icle model')
793434 FORMAT ('    Curvature and solution effecs are considered for growth of', &
794                 ' droplets < 1.0E-6 m')
795435 FORMAT ('    Droplet collision is handled by ',A,'-kernel')
796436 FORMAT ('       Fast kernel with fixed radius- and dissipation classes ', &
797                    'are used'/ &
798            '          number of radius classes:       ',I3,'    interval ', &
799                       '[1.0E-6,2.0E-4] m'/ &
800            '          number of dissipation classes:   ',I2,'    interval ', &
801                       '[0,1000] cm**2/s**3')
802437 FORMAT ('    Droplet collision is switched off')
803
804480 FORMAT ('    Particles:'/ &
805            '    ---------'// &
806            '       Particle advection is active (switched on at t = ', F7.1, &
807                    ' s)'/ &
808            '       Start of new particle generations every  ',F6.1,' s'/ &
809            '       Boundary conditions: left/right: ', A, ' north/south: ', A/&
810            '                            bottom:     ', A, ' top:         ', A/&
811            '       Maximum particle age:                 ',F9.1,' s'/ &
812            '       Advection stopped at t = ',F9.1,' s'/)
813481 FORMAT ('       Particles have random start positions'/)
814482 FORMAT ('          Particles are advected only horizontally'/)
815485 FORMAT ('       Particle data are written on file every ', F9.1, ' s')
816486 FORMAT ('       Particle statistics are written on file'/)
817487 FORMAT ('       Number of particle groups: ',I2/)
818488 FORMAT ('       SGS velocity components are used for particle advection'/ &
819            '          minimum timestep for advection:', F8.5/)
820489 FORMAT ('       Number of particles simultaneously released at each ', &
821                    'point: ', I5/)
822490 FORMAT ('       Particle group ',I2,':'/ &
823            '          Particle radius: ',E10.3, 'm')
824491 FORMAT ('          Particle inertia is activated'/ &
825            '             density_ratio (rho_fluid/rho_particle) =',F6.3/)
826492 FORMAT ('          Particles are advected only passively (no inertia)'/)
827493 FORMAT ('          Boundaries of particle source: x:',F8.1,' - ',F8.1,' m'/&
828            '                                         y:',F8.1,' - ',F8.1,' m'/&
829            '                                         z:',F8.1,' - ',F8.1,' m'/&
830            '          Particle distances:  dx = ',F8.1,' m  dy = ',F8.1, &
831                       ' m  dz = ',F8.1,' m'/)
832494 FORMAT ('       Output of particle time series in NetCDF format every ', &
833                    F8.2,' s'/)
834495 FORMAT ('       Number of particles in total domain: ',I10/)
835496 FORMAT ('       Initial vertical particle positions are interpreted ', &
836                    'as relative to the given topography')
837   
838 END SUBROUTINE lpm_header
839 
840!------------------------------------------------------------------------------!
841! Description:
842! ------------
843!> Writes used particle attributes in header file.
844!------------------------------------------------------------------------------! 
845 SUBROUTINE lpm_check_parameters
846 
847!
848!-- Collision kernels:
849    SELECT CASE ( TRIM( collision_kernel ) )
850
851       CASE ( 'hall', 'hall_fast' )
852          hall_kernel = .TRUE.
853
854       CASE ( 'wang', 'wang_fast' )
855          wang_kernel = .TRUE.
856
857       CASE ( 'none' )
858
859
860       CASE DEFAULT
861          message_string = 'unknown collision kernel: collision_kernel = "' // &
862                           TRIM( collision_kernel ) // '"'
863          CALL message( 'check_parameters', 'PA0350', 1, 2, 0, 6, 0 )
864
865    END SELECT
866    IF ( collision_kernel(6:9) == 'fast' )  use_kernel_tables = .TRUE.
867
868!
869!-- Subgrid scale velocites with the simple interpolation method for resolved
870!-- velocites is not implemented for passive particles. However, for cloud
871!-- it can be combined as the sgs-velocites for active particles are
872!-- calculated differently, i.e. no subboxes are needed.
873    IF ( .NOT. TRIM(particle_advection_interpolation) == 'trilinear'  .AND.              &
874       use_sgs_for_particles .AND.  .NOT. cloud_droplets )  THEN
875          message_string = 'subrgrid scale velocities in combination with ' // &
876                           'simple interpolation method is not '            // &
877                           'implemented'
878          CALL message( 'check_parameters', 'PA0659', 1, 2, 0, 6, 0 )
879    ENDIF
880
881 END SUBROUTINE
882 
883!------------------------------------------------------------------------------!
884! Description:
885! ------------
886!> Initialize arrays for lpm
887!------------------------------------------------------------------------------!   
888 SUBROUTINE lpm_init_arrays
889 
890    IF ( cloud_droplets )  THEN
891!
892!--    Liquid water content, change in liquid water content
893       ALLOCATE ( ql_1(nzb:nzt+1,nysg:nyng,nxlg:nxrg),                      &
894                  ql_2(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
895!
896!--    Real volume of particles (with weighting), volume of particles
897       ALLOCATE ( ql_v(nzb:nzt+1,nysg:nyng,nxlg:nxrg),                      &
898                     ql_vp(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
899    ENDIF
900   
901!
902!--    Initial assignment of the pointers   
903    IF ( cloud_droplets )  THEN
904       ql   => ql_1
905       ql_c => ql_2
906    ENDIF
907   
908 END SUBROUTINE lpm_init_arrays
909 
910!------------------------------------------------------------------------------!
911! Description:
912! ------------
913!> Initialize Lagrangian particle model
914!------------------------------------------------------------------------------!
915 SUBROUTINE lpm_init
916
917    INTEGER(iwp) ::  i                           !<
918    INTEGER(iwp) ::  j                           !<
919    INTEGER(iwp) ::  k                           !<
920
921    REAL(wp) ::  div                             !<
922    REAL(wp) ::  height_int                      !<
923    REAL(wp) ::  height_p                        !<
924    REAL(wp) ::  z_p                             !<
925    REAL(wp) ::  z0_av_local                     !<
926
927!
928!-- In case of oceans runs, the vertical index calculations need an offset,
929!-- because otherwise the k indices will become negative
930    IF ( ocean_mode )  THEN
931       offset_ocean_nzt    = nzt
932       offset_ocean_nzt_m1 = nzt - 1
933    ENDIF
934
935!
936!-- Define block offsets for dividing a gridcell in 8 sub cells
937!-- See documentation for List of subgrid boxes
938!-- See pack_and_sort in lpm_pack_arrays.f90 for assignment of the subgrid boxes
939    block_offset(0) = block_offset_def ( 0, 0, 0)
940    block_offset(1) = block_offset_def ( 0, 0,-1)
941    block_offset(2) = block_offset_def ( 0,-1, 0)
942    block_offset(3) = block_offset_def ( 0,-1,-1)
943    block_offset(4) = block_offset_def (-1, 0, 0)
944    block_offset(5) = block_offset_def (-1, 0,-1)
945    block_offset(6) = block_offset_def (-1,-1, 0)
946    block_offset(7) = block_offset_def (-1,-1,-1)
947!
948!-- Check the number of particle groups.
949    IF ( number_of_particle_groups > max_number_of_particle_groups )  THEN
950       WRITE( message_string, * ) 'max_number_of_particle_groups =',           &
951                                  max_number_of_particle_groups ,              &
952                                  '&number_of_particle_groups reset to ',      &
953                                  max_number_of_particle_groups
954       CALL message( 'lpm_init', 'PA0213', 0, 1, 0, 6, 0 )
955       number_of_particle_groups = max_number_of_particle_groups
956    ENDIF
957!
958!-- Check if downward-facing walls exist. This case, reflection boundary
959!-- conditions (as well as subgrid-scale velocities) may do not work
960!-- propably (not realized so far).
961    IF ( surf_def_h(1)%ns >= 1 )  THEN
962       WRITE( message_string, * ) 'Overhanging topography do not work '//      &
963                                  'with particles'
964       CALL message( 'lpm_init', 'PA0212', 0, 1, 0, 6, 0 )
965
966    ENDIF
967
968!
969!-- Set default start positions, if necessary
970    IF ( psl(1) == 9999999.9_wp )  psl(1) = 0.0_wp
971    IF ( psr(1) == 9999999.9_wp )  psr(1) = ( nx +1 ) * dx
972    IF ( pss(1) == 9999999.9_wp )  pss(1) = 0.0_wp
973    IF ( psn(1) == 9999999.9_wp )  psn(1) = ( ny +1 ) * dy
974    IF ( psb(1) == 9999999.9_wp )  psb(1) = zu(nz/2)
975    IF ( pst(1) == 9999999.9_wp )  pst(1) = psb(1)
976
977    IF ( pdx(1) == 9999999.9_wp  .OR.  pdx(1) == 0.0_wp )  pdx(1) = dx
978    IF ( pdy(1) == 9999999.9_wp  .OR.  pdy(1) == 0.0_wp )  pdy(1) = dy
979    IF ( pdz(1) == 9999999.9_wp  .OR.  pdz(1) == 0.0_wp )  pdz(1) = zu(2) - zu(1)
980
981!
982!-- If number_particles_per_gridbox is set, the parametres pdx, pdy and pdz are
983!-- calculated diagnostically. Therfore an isotropic distribution is prescribed.
984    IF ( number_particles_per_gridbox /= -1 .AND.   &
985         number_particles_per_gridbox >= 1 )    THEN
986       pdx(1) = (( dx * dy * ( zu(2) - zu(1) ) ) /  &
987             REAL(number_particles_per_gridbox))**0.3333333_wp
988!
989!--    Ensure a smooth value (two significant digits) of distance between
990!--    particles (pdx, pdy, pdz).
991       div = 1000.0_wp
992       DO  WHILE ( pdx(1) < div )
993          div = div / 10.0_wp
994       ENDDO
995       pdx(1) = NINT( pdx(1) * 100.0_wp / div ) * div / 100.0_wp
996       pdy(1) = pdx(1)
997       pdz(1) = pdx(1)
998
999    ENDIF
1000
1001    DO  j = 2, number_of_particle_groups
1002       IF ( psl(j) == 9999999.9_wp )  psl(j) = psl(j-1)
1003       IF ( psr(j) == 9999999.9_wp )  psr(j) = psr(j-1)
1004       IF ( pss(j) == 9999999.9_wp )  pss(j) = pss(j-1)
1005       IF ( psn(j) == 9999999.9_wp )  psn(j) = psn(j-1)
1006       IF ( psb(j) == 9999999.9_wp )  psb(j) = psb(j-1)
1007       IF ( pst(j) == 9999999.9_wp )  pst(j) = pst(j-1)
1008       IF ( pdx(j) == 9999999.9_wp  .OR.  pdx(j) == 0.0_wp )  pdx(j) = pdx(j-1)
1009       IF ( pdy(j) == 9999999.9_wp  .OR.  pdy(j) == 0.0_wp )  pdy(j) = pdy(j-1)
1010       IF ( pdz(j) == 9999999.9_wp  .OR.  pdz(j) == 0.0_wp )  pdz(j) = pdz(j-1)
1011    ENDDO
1012
1013!
1014!-- Allocate arrays required for calculating particle SGS velocities.
1015!-- Initialize prefactor required for stoachastic Weil equation.
1016    IF ( use_sgs_for_particles  .AND.  .NOT. cloud_droplets )  THEN
1017       ALLOCATE( de_dx(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &
1018                 de_dy(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &
1019                 de_dz(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
1020
1021       de_dx = 0.0_wp
1022       de_dy = 0.0_wp
1023       de_dz = 0.0_wp
1024
1025       sgs_wf_part = 1.0_wp / 3.0_wp
1026    ENDIF
1027
1028!
1029!-- Allocate array required for logarithmic vertical interpolation of
1030!-- horizontal particle velocities between the surface and the first vertical
1031!-- grid level. In order to avoid repeated CPU cost-intensive CALLS of
1032!-- intrinsic FORTRAN procedure LOG(z/z0), LOG(z/z0) is precalculated for
1033!-- several heights. Splitting into 20 sublayers turned out to be sufficient.
1034!-- To obtain exact height levels of particles, linear interpolation is applied
1035!-- (see lpm_advec.f90).
1036    IF ( constant_flux_layer )  THEN
1037
1038       ALLOCATE ( log_z_z0(0:number_of_sublayers) )
1039       z_p = zu(nzb+1) - zw(nzb)
1040
1041!
1042!--    Calculate horizontal mean value of z0 used for logartihmic
1043!--    interpolation. Note: this is not exact for heterogeneous z0.
1044!--    However, sensitivity studies showed that the effect is
1045!--    negligible.
1046       z0_av_local  = SUM( surf_def_h(0)%z0 ) + SUM( surf_lsm_h%z0 ) +         &
1047                      SUM( surf_usm_h%z0 )
1048       z0_av_global = 0.0_wp
1049
1050#if defined( __parallel )
1051       CALL MPI_ALLREDUCE(z0_av_local, z0_av_global, 1, MPI_REAL, MPI_SUM, &
1052                          comm2d, ierr )
1053#else
1054       z0_av_global = z0_av_local
1055#endif
1056
1057       z0_av_global = z0_av_global  / ( ( ny + 1 ) * ( nx + 1 ) )
1058!
1059!--    Horizontal wind speed is zero below and at z0
1060       log_z_z0(0) = 0.0_wp
1061!
1062!--    Calculate vertical depth of the sublayers
1063       height_int  = ( z_p - z0_av_global ) / REAL( number_of_sublayers, KIND=wp )
1064!
1065!--    Precalculate LOG(z/z0)
1066       height_p    = z0_av_global
1067       DO  k = 1, number_of_sublayers
1068
1069          height_p    = height_p + height_int
1070          log_z_z0(k) = LOG( height_p / z0_av_global )
1071
1072       ENDDO
1073
1074    ENDIF
1075
1076!
1077!-- Check which particle interpolation method should be used
1078    IF ( TRIM(particle_advection_interpolation)  ==  'trilinear' )  THEN
1079       interpolation_simple_corrector = .FALSE.
1080       interpolation_simple_predictor = .FALSE.
1081       interpolation_trilinear        = .TRUE.
1082    ELSEIF ( TRIM(particle_advection_interpolation)  ==  'simple_corrector' )  THEN
1083       interpolation_simple_corrector = .TRUE.
1084       interpolation_simple_predictor = .FALSE.
1085       interpolation_trilinear        = .FALSE.
1086    ELSEIF ( TRIM(particle_advection_interpolation)  ==  'simple_predictor' )  THEN
1087       interpolation_simple_corrector = .FALSE.
1088       interpolation_simple_predictor = .TRUE.
1089       interpolation_trilinear        = .FALSE.
1090    ENDIF
1091
1092!
1093!-- Check boundary condition and set internal variables
1094    SELECT CASE ( bc_par_b )
1095
1096       CASE ( 'absorb' )
1097          ibc_par_b = 1
1098
1099       CASE ( 'reflect' )
1100          ibc_par_b = 2
1101
1102       CASE ( 'reset' )
1103          ibc_par_b = 3
1104
1105       CASE DEFAULT
1106          WRITE( message_string, * )  'unknown boundary condition ',           &
1107                                       'bc_par_b = "', TRIM( bc_par_b ), '"'
1108          CALL message( 'lpm_init', 'PA0217', 1, 2, 0, 6, 0 )
1109
1110    END SELECT
1111    SELECT CASE ( bc_par_t )
1112
1113       CASE ( 'absorb' )
1114          ibc_par_t = 1
1115
1116       CASE ( 'reflect' )
1117          ibc_par_t = 2
1118
1119       CASE ( 'nested' )
1120          ibc_par_t = 3
1121
1122       CASE DEFAULT
1123          WRITE( message_string, * ) 'unknown boundary condition ',            &
1124                                     'bc_par_t = "', TRIM( bc_par_t ), '"'
1125          CALL message( 'lpm_init', 'PA0218', 1, 2, 0, 6, 0 )
1126
1127    END SELECT
1128    SELECT CASE ( bc_par_lr )
1129
1130       CASE ( 'cyclic' )
1131          ibc_par_lr = 0
1132
1133       CASE ( 'absorb' )
1134          ibc_par_lr = 1
1135
1136       CASE ( 'reflect' )
1137          ibc_par_lr = 2
1138
1139       CASE ( 'nested' )
1140          ibc_par_lr = 3
1141
1142       CASE DEFAULT
1143          WRITE( message_string, * ) 'unknown boundary condition ',   &
1144                                     'bc_par_lr = "', TRIM( bc_par_lr ), '"'
1145          CALL message( 'lpm_init', 'PA0219', 1, 2, 0, 6, 0 )
1146
1147    END SELECT
1148    SELECT CASE ( bc_par_ns )
1149
1150       CASE ( 'cyclic' )
1151          ibc_par_ns = 0
1152
1153       CASE ( 'absorb' )
1154          ibc_par_ns = 1
1155
1156       CASE ( 'reflect' )
1157          ibc_par_ns = 2
1158
1159       CASE ( 'nested' )
1160          ibc_par_ns = 3
1161
1162       CASE DEFAULT
1163          WRITE( message_string, * ) 'unknown boundary condition ',   &
1164                                     'bc_par_ns = "', TRIM( bc_par_ns ), '"'
1165          CALL message( 'lpm_init', 'PA0220', 1, 2, 0, 6, 0 )
1166
1167    END SELECT
1168    SELECT CASE ( splitting_mode )
1169
1170       CASE ( 'const' )
1171          i_splitting_mode = 1
1172
1173       CASE ( 'cl_av' )
1174          i_splitting_mode = 2
1175
1176       CASE ( 'gb_av' )
1177          i_splitting_mode = 3
1178
1179       CASE DEFAULT
1180          WRITE( message_string, * )  'unknown splitting_mode = "',            &
1181                                      TRIM( splitting_mode ), '"'
1182          CALL message( 'lpm_init', 'PA0146', 1, 2, 0, 6, 0 )
1183
1184    END SELECT
1185    SELECT CASE ( splitting_function )
1186
1187       CASE ( 'gamma' )
1188          isf = 1
1189
1190       CASE ( 'log' )
1191          isf = 2
1192
1193       CASE ( 'exp' )
1194          isf = 3
1195
1196       CASE DEFAULT
1197          WRITE( message_string, * )  'unknown splitting function = "',        &
1198                                       TRIM( splitting_function ), '"'
1199          CALL message( 'lpm_init', 'PA0147', 1, 2, 0, 6, 0 )
1200
1201    END SELECT
1202!
1203!-- Initialize collision kernels
1204    IF ( collision_kernel /= 'none' )  CALL lpm_init_kernels
1205!
1206!-- For the first model run of a possible job chain initialize the
1207!-- particles, otherwise read the particle data from restart file.
1208    IF ( TRIM( initializing_actions ) == 'read_restart_data'  &
1209         .AND.  read_particles_from_restartfile )  THEN
1210       CALL lpm_rrd_local_particles
1211    ELSE
1212!
1213!--    Allocate particle arrays and set attributes of the initial set of
1214!--    particles, which can be also periodically released at later times.
1215       ALLOCATE( prt_count(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &
1216                 grid_particles(nzb+1:nzt,nys:nyn,nxl:nxr) )
1217
1218       number_of_particles = 0
1219       prt_count           = 0
1220!
1221!--    initialize counter for particle IDs
1222       grid_particles%id_counter = 1
1223!
1224!--    Initialize all particles with dummy values (otherwise errors may
1225!--    occur within restart runs). The reason for this is still not clear
1226!--    and may be presumably caused by errors in the respective user-interface.
1227       zero_particle = particle_type( 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp,  &
1228                                      0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp,  &
1229                                      0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp,  &
1230                                      0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp,  &
1231                                      0, 0, 0_idp, .FALSE., -1 )
1232
1233       particle_groups = particle_groups_type( 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp )
1234!
1235!--    Set values for the density ratio and radius for all particle
1236!--    groups, if necessary
1237       IF ( density_ratio(1) == 9999999.9_wp )  density_ratio(1) = 0.0_wp
1238       IF ( radius(1)        == 9999999.9_wp )  radius(1) = 0.0_wp
1239       DO  i = 2, number_of_particle_groups
1240          IF ( density_ratio(i) == 9999999.9_wp )  THEN
1241             density_ratio(i) = density_ratio(i-1)
1242          ENDIF
1243          IF ( radius(i) == 9999999.9_wp )  radius(i) = radius(i-1)
1244       ENDDO
1245
1246       DO  i = 1, number_of_particle_groups
1247          IF ( density_ratio(i) /= 0.0_wp  .AND.  radius(i) == 0 )  THEN
1248             WRITE( message_string, * ) 'particle group #', i, ' has a',       &
1249                                        'density ratio /= 0 but radius = 0'
1250             CALL message( 'lpm_init', 'PA0215', 1, 2, 0, 6, 0 )
1251          ENDIF
1252          particle_groups(i)%density_ratio = density_ratio(i)
1253          particle_groups(i)%radius        = radius(i)
1254       ENDDO
1255!
1256!--    Set a seed value for the random number generator to be exclusively
1257!--    used for the particle code. The generated random numbers should be
1258!--    different on the different PEs.
1259       iran_part = iran_part + myid
1260!
1261!--    Create the particle set, and set the initial particles
1262       CALL lpm_create_particle( phase_init )
1263       last_particle_release_time = particle_advection_start
1264!
1265!--    User modification of initial particles
1266       CALL user_lpm_init
1267!
1268!--    Open file for statistical informations about particle conditions
1269       IF ( write_particle_statistics )  THEN
1270          CALL check_open( 80 )
1271          WRITE ( 80, 8000 )  current_timestep_number, simulated_time,         &
1272                              number_of_particles
1273          CALL close_file( 80 )
1274       ENDIF
1275
1276    ENDIF
1277
1278    IF ( nested_run )  CALL pmcp_g_init
1279!
1280!-- To avoid programm abort, assign particles array to the local version of
1281!-- first grid cell
1282    number_of_particles = prt_count(nzb+1,nys,nxl)
1283    particles => grid_particles(nzb+1,nys,nxl)%particles(1:number_of_particles)
1284!
1285!-- Formats
12868000 FORMAT (I6,1X,F7.2,4X,I10,71X,I10)
1287
1288 END SUBROUTINE lpm_init
1289 
1290!------------------------------------------------------------------------------!
1291! Description:
1292! ------------
1293!> Create Lagrangian particles
1294!------------------------------------------------------------------------------! 
1295 SUBROUTINE lpm_create_particle (phase)
1296
1297    INTEGER(iwp)               ::  alloc_size  !< relative increase of allocated memory for particles
1298    INTEGER(iwp)               ::  i           !< loop variable ( particle groups )
1299    INTEGER(iwp)               ::  ip          !< index variable along x
1300    INTEGER(iwp)               ::  j           !< loop variable ( particles per point )
1301    INTEGER(iwp)               ::  jp          !< index variable along y
1302    INTEGER(iwp)               ::  k           !< index variable along z
1303    INTEGER(iwp)               ::  k_surf      !< index of surface grid point
1304    INTEGER(iwp)               ::  kp          !< index variable along z
1305    INTEGER(iwp)               ::  loop_stride !< loop variable for initialization
1306    INTEGER(iwp)               ::  n           !< loop variable ( number of particles )
1307    INTEGER(iwp)               ::  new_size    !< new size of allocated memory for particles
1308
1309    INTEGER(iwp), INTENT(IN)   ::  phase       !< mode of inititialization
1310
1311    INTEGER(iwp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  local_count !< start address of new particle
1312    INTEGER(iwp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  local_start !< start address of new particle
1313
1314    LOGICAL                    ::  first_stride !< flag for initialization
1315
1316    REAL(wp)                   ::  pos_x      !< increment for particle position in x
1317    REAL(wp)                   ::  pos_y      !< increment for particle position in y
1318    REAL(wp)                   ::  pos_z      !< increment for particle position in z
1319    REAL(wp)                   ::  rand_contr !< dummy argument for random position
1320
1321    TYPE(particle_type),TARGET ::  tmp_particle !< temporary particle used for initialization
1322
1323!
1324!-- Calculate particle positions and store particle attributes, if
1325!-- particle is situated on this PE
1326    DO  loop_stride = 1, 2
1327       first_stride = (loop_stride == 1)
1328       IF ( first_stride )   THEN
1329          local_count = 0           ! count number of particles
1330       ELSE
1331          local_count = prt_count   ! Start address of new particles
1332       ENDIF
1333
1334!
1335!--    Calculate initial_weighting_factor diagnostically
1336       IF ( number_concentration /= -1.0_wp .AND. number_concentration > 0.0_wp )  THEN
1337          initial_weighting_factor =  number_concentration  *                         &
1338                                      pdx(1) * pdy(1) * pdz(1)
1339       END IF
1340
1341       n = 0
1342       DO  i = 1, number_of_particle_groups
1343          pos_z = psb(i)
1344          DO WHILE ( pos_z <= pst(i) )
1345             IF ( pos_z >= zw(0) .AND.  pos_z < zw(nzt) )  THEN
1346                pos_y = pss(i)
1347                DO WHILE ( pos_y <= psn(i) )
1348                   IF ( pos_y >= nys * dy  .AND.                  &
1349                        pos_y <  ( nyn + 1 ) * dy  )  THEN
1350                      pos_x = psl(i)
1351               xloop: DO WHILE ( pos_x <= psr(i) )
1352                         IF ( pos_x >= nxl * dx  .AND.            &
1353                              pos_x <  ( nxr + 1) * dx )  THEN
1354                            DO  j = 1, particles_per_point
1355                               n = n + 1
1356                               tmp_particle%x             = pos_x
1357                               tmp_particle%y             = pos_y
1358                               tmp_particle%z             = pos_z
1359                               tmp_particle%age           = 0.0_wp
1360                               tmp_particle%age_m         = 0.0_wp
1361                               tmp_particle%dt_sum        = 0.0_wp
1362                               tmp_particle%e_m           = 0.0_wp
1363                               tmp_particle%rvar1         = 0.0_wp
1364                               tmp_particle%rvar2         = 0.0_wp
1365                               tmp_particle%rvar3         = 0.0_wp
1366                               tmp_particle%speed_x       = 0.0_wp
1367                               tmp_particle%speed_y       = 0.0_wp
1368                               tmp_particle%speed_z       = 0.0_wp
1369                               tmp_particle%origin_x      = pos_x
1370                               tmp_particle%origin_y      = pos_y
1371                               tmp_particle%origin_z      = pos_z
1372                               IF ( curvature_solution_effects )  THEN
1373                                  tmp_particle%aux1      = 0.0_wp    ! dry aerosol radius
1374                                  tmp_particle%aux2      = dt_3d     ! last Rosenbrock timestep
1375                               ELSE
1376                                  tmp_particle%aux1      = 0.0_wp    ! free to use
1377                                  tmp_particle%aux2      = 0.0_wp    ! free to use
1378                               ENDIF
1379                               tmp_particle%radius        = particle_groups(i)%radius
1380                               tmp_particle%weight_factor = initial_weighting_factor
1381                               tmp_particle%class         = 1
1382                               tmp_particle%group         = i
1383                               tmp_particle%id            = 0_idp
1384                               tmp_particle%particle_mask = .TRUE.
1385                               tmp_particle%block_nr      = -1
1386!
1387!--                            Determine the grid indices of the particle position
1388                               ip = INT( tmp_particle%x * ddx )
1389                               jp = INT( tmp_particle%y * ddy )
1390!
1391!--                            In case of stretching the actual k index is found iteratively
1392                               IF ( dz_stretch_level /= -9999999.9_wp  .OR.           &
1393                                    dz_stretch_level_start(1) /= -9999999.9_wp )  THEN
1394                                  kp = MINLOC( ABS( tmp_particle%z - zu ), DIM = 1 ) - 1
1395                               ELSE
1396                                  kp = INT( tmp_particle%z / dz(1) + 1 + offset_ocean_nzt )
1397                               ENDIF
1398!
1399!--                            Determine surface level. Therefore, check for
1400!--                            upward-facing wall on w-grid.
1401                               k_surf = get_topography_top_index_ji( jp, ip, 'w' )
1402                               IF ( seed_follows_topography )  THEN
1403!
1404!--                               Particle height is given relative to topography
1405                                  kp = kp + k_surf
1406                                  tmp_particle%z = tmp_particle%z + zw(k_surf)
1407!--                               Skip particle release if particle position is
1408!--                               above model top, or within topography in case
1409!--                               of overhanging structures.
1410                                  IF ( kp > nzt  .OR.                          &
1411                                 .NOT. BTEST( wall_flags_0(kp,jp,ip), 0 ) )  THEN
1412                                     pos_x = pos_x + pdx(i)
1413                                     CYCLE xloop
1414                                  ENDIF
1415!
1416!--                            Skip particle release if particle position is
1417!--                            below surface, or within topography in case
1418!--                            of overhanging structures.
1419                               ELSEIF ( .NOT. seed_follows_topography .AND.    &
1420                                         tmp_particle%z <= zw(k_surf)  .OR.    &
1421                                        .NOT. BTEST( wall_flags_0(kp,jp,ip), 0 ) )&
1422                               THEN
1423                                  pos_x = pos_x + pdx(i)
1424                                  CYCLE xloop
1425                               ENDIF
1426
1427                               local_count(kp,jp,ip) = local_count(kp,jp,ip) + 1
1428
1429                               IF ( .NOT. first_stride )  THEN
1430                                  IF ( ip < nxl  .OR.  jp < nys  .OR.  kp < nzb+1 )  THEN
1431                                     write(6,*) 'xl ',ip,jp,kp,nxl,nys,nzb+1
1432                                  ENDIF
1433                                  IF ( ip > nxr  .OR.  jp > nyn  .OR.  kp > nzt )  THEN
1434                                     write(6,*) 'xu ',ip,jp,kp,nxr,nyn,nzt
1435                                  ENDIF
1436                                  grid_particles(kp,jp,ip)%particles(local_count(kp,jp,ip)) = tmp_particle
1437                               ENDIF
1438                            ENDDO
1439                         ENDIF
1440                         pos_x = pos_x + pdx(i)
1441                      ENDDO xloop
1442                   ENDIF
1443                   pos_y = pos_y + pdy(i)
1444                ENDDO
1445             ENDIF
1446
1447             pos_z = pos_z + pdz(i)
1448          ENDDO
1449       ENDDO
1450
1451       IF ( first_stride )  THEN
1452          DO  ip = nxl, nxr
1453             DO  jp = nys, nyn
1454                DO  kp = nzb+1, nzt
1455                   IF ( phase == PHASE_INIT )  THEN
1456                      IF ( local_count(kp,jp,ip) > 0 )  THEN
1457                         alloc_size = MAX( INT( local_count(kp,jp,ip) *        &
1458                            ( 1.0_wp + alloc_factor / 100.0_wp ) ),            &
1459                            1 )
1460                      ELSE
1461                         alloc_size = 1
1462                      ENDIF
1463                      ALLOCATE(grid_particles(kp,jp,ip)%particles(1:alloc_size))
1464                      DO  n = 1, alloc_size
1465                         grid_particles(kp,jp,ip)%particles(n) = zero_particle
1466                      ENDDO
1467                   ELSEIF ( phase == PHASE_RELEASE )  THEN
1468                      IF ( local_count(kp,jp,ip) > 0 )  THEN
1469                         new_size   = local_count(kp,jp,ip) + prt_count(kp,jp,ip)
1470                         alloc_size = MAX( INT( new_size * ( 1.0_wp +          &
1471                            alloc_factor / 100.0_wp ) ), 1 )
1472                         IF( alloc_size > SIZE( grid_particles(kp,jp,ip)%particles) )  THEN
1473                            CALL realloc_particles_array(ip,jp,kp,alloc_size)
1474                         ENDIF
1475                      ENDIF
1476                   ENDIF
1477                ENDDO
1478             ENDDO
1479          ENDDO
1480       ENDIF
1481
1482    ENDDO
1483
1484    local_start = prt_count+1
1485    prt_count   = local_count
1486!
1487!-- Calculate particle IDs
1488    DO  ip = nxl, nxr
1489       DO  jp = nys, nyn
1490          DO  kp = nzb+1, nzt
1491             number_of_particles = prt_count(kp,jp,ip)
1492             IF ( number_of_particles <= 0 )  CYCLE
1493             particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
1494
1495             DO  n = local_start(kp,jp,ip), number_of_particles  !only new particles
1496
1497                particles(n)%id = 10000_idp**3 * grid_particles(kp,jp,ip)%id_counter + &
1498                                  10000_idp**2 * kp + 10000_idp * jp + ip
1499!
1500!--             Count the number of particles that have been released before
1501                grid_particles(kp,jp,ip)%id_counter =                          &
1502                                         grid_particles(kp,jp,ip)%id_counter + 1
1503
1504             ENDDO
1505
1506          ENDDO
1507       ENDDO
1508    ENDDO
1509!
1510!-- Initialize aerosol background spectrum
1511    IF ( curvature_solution_effects )  THEN
1512       CALL lpm_init_aerosols(local_start)
1513    ENDIF
1514!
1515!-- Add random fluctuation to particle positions.
1516    IF ( random_start_position )  THEN
1517       DO  ip = nxl, nxr
1518          DO  jp = nys, nyn
1519             DO  kp = nzb+1, nzt
1520                number_of_particles = prt_count(kp,jp,ip)
1521                IF ( number_of_particles <= 0 )  CYCLE
1522                particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
1523!
1524!--             Move only new particles. Moreover, limit random fluctuation
1525!--             in order to prevent that particles move more than one grid box,
1526!--             which would lead to problems concerning particle exchange
1527!--             between processors in case pdx/pdy are larger than dx/dy,
1528!--             respectively.
1529                DO  n = local_start(kp,jp,ip), number_of_particles
1530                   IF ( psl(particles(n)%group) /= psr(particles(n)%group) )  THEN
1531                      rand_contr = ( random_function( iran_part ) - 0.5_wp ) * &
1532                                     pdx(particles(n)%group)
1533                      particles(n)%x = particles(n)%x +                        &
1534                              MERGE( rand_contr, SIGN( dx, rand_contr ),       &
1535                                     ABS( rand_contr ) < dx                    &
1536                                   )
1537                   ENDIF
1538                   IF ( pss(particles(n)%group) /= psn(particles(n)%group) )  THEN
1539                      rand_contr = ( random_function( iran_part ) - 0.5_wp ) * &
1540                                     pdy(particles(n)%group)
1541                      particles(n)%y = particles(n)%y +                        &
1542                              MERGE( rand_contr, SIGN( dy, rand_contr ),       &
1543                                     ABS( rand_contr ) < dy                    &
1544                                   )
1545                   ENDIF
1546                   IF ( psb(particles(n)%group) /= pst(particles(n)%group) )  THEN
1547                      rand_contr = ( random_function( iran_part ) - 0.5_wp ) * &
1548                                     pdz(particles(n)%group)
1549                      particles(n)%z = particles(n)%z +                        &
1550                              MERGE( rand_contr, SIGN( dzw(kp), rand_contr ),  &
1551                                     ABS( rand_contr ) < dzw(kp)               &
1552                                   )
1553                   ENDIF
1554                ENDDO
1555!
1556!--             Identify particles located outside the model domain and reflect
1557!--             or absorb them if necessary.
1558                CALL lpm_boundary_conds( 'bottom/top', i, j, k )
1559!
1560!--             Furthermore, remove particles located in topography. Note, as
1561!--             the particle speed is still zero at this point, wall
1562!--             reflection boundary conditions will not work in this case.
1563                particles =>                                                   &
1564                       grid_particles(kp,jp,ip)%particles(1:number_of_particles)
1565                DO  n = local_start(kp,jp,ip), number_of_particles
1566                   i = particles(n)%x * ddx
1567                   j = particles(n)%y * ddy
1568                   k = particles(n)%z / dz(1) + 1 + offset_ocean_nzt
1569                   DO WHILE( zw(k) < particles(n)%z )
1570                      k = k + 1
1571                   ENDDO
1572                   DO WHILE( zw(k-1) > particles(n)%z )
1573                      k = k - 1
1574                   ENDDO
1575!
1576!--                Check if particle is within topography
1577                   IF ( .NOT. BTEST( wall_flags_0(k,j,i), 0 ) )  THEN
1578                      particles(n)%particle_mask = .FALSE.
1579                      deleted_particles = deleted_particles + 1
1580                   ENDIF
1581
1582                ENDDO
1583             ENDDO
1584          ENDDO
1585       ENDDO
1586!
1587!--    Exchange particles between grid cells and processors
1588       CALL lpm_move_particle
1589       CALL lpm_exchange_horiz
1590
1591    ENDIF
1592!
1593!-- In case of random_start_position, delete particles identified by
1594!-- lpm_exchange_horiz and lpm_boundary_conds. Then sort particles into blocks,
1595!-- which is needed for a fast interpolation of the LES fields on the particle
1596!-- position.
1597    CALL lpm_sort_and_delete
1598!
1599!-- Determine the current number of particles
1600    DO  ip = nxl, nxr
1601       DO  jp = nys, nyn
1602          DO  kp = nzb+1, nzt
1603             number_of_particles         = number_of_particles                 &
1604                                           + prt_count(kp,jp,ip)
1605          ENDDO
1606       ENDDO
1607    ENDDO
1608!
1609!-- Calculate the number of particles of the total domain
1610#if defined( __parallel )
1611    IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
1612    CALL MPI_ALLREDUCE( number_of_particles, total_number_of_particles, 1, &
1613    MPI_INTEGER, MPI_SUM, comm2d, ierr )
1614#else
1615    total_number_of_particles = number_of_particles
1616#endif
1617
1618    RETURN
1619
1620 END SUBROUTINE lpm_create_particle
1621 
1622 
1623!------------------------------------------------------------------------------!
1624! Description:
1625! ------------
1626!> This routine initialize the particles as aerosols with physio-chemical
1627!> properties.
1628!------------------------------------------------------------------------------!   
1629 SUBROUTINE lpm_init_aerosols(local_start)
1630
1631    REAL(wp)  :: afactor            !< curvature effects
1632    REAL(wp)  :: bfactor            !< solute effects
1633    REAL(wp)  :: dlogr              !< logarithmic width of radius bin
1634    REAL(wp)  :: e_a                !< vapor pressure
1635    REAL(wp)  :: e_s                !< saturation vapor pressure
1636    REAL(wp)  :: rmin = 0.005e-6_wp !< minimum aerosol radius
1637    REAL(wp)  :: rmax = 10.0e-6_wp  !< maximum aerosol radius
1638    REAL(wp)  :: r_mid              !< mean radius of bin
1639    REAL(wp)  :: r_l                !< left radius of bin
1640    REAL(wp)  :: r_r                !< right radius of bin
1641    REAL(wp)  :: sigma              !< surface tension
1642    REAL(wp)  :: t_int              !< temperature
1643
1644    INTEGER(iwp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg), INTENT(IN) ::  local_start !<
1645
1646    INTEGER(iwp)  :: n              !<
1647    INTEGER(iwp)  :: ip             !<
1648    INTEGER(iwp)  :: jp             !<
1649    INTEGER(iwp)  :: kp             !<
1650
1651!
1652!-- Set constants for different aerosol species
1653    IF ( TRIM(aero_species) == 'nacl' )  THEN
1654       molecular_weight_of_solute = 0.05844_wp 
1655       rho_s                      = 2165.0_wp
1656       vanthoff                   = 2.0_wp
1657    ELSEIF ( TRIM(aero_species) == 'c3h4o4' )  THEN
1658       molecular_weight_of_solute = 0.10406_wp 
1659       rho_s                      = 1600.0_wp
1660       vanthoff                   = 1.37_wp
1661    ELSEIF ( TRIM(aero_species) == 'nh4o3' )  THEN
1662       molecular_weight_of_solute = 0.08004_wp 
1663       rho_s                      = 1720.0_wp
1664       vanthoff                   = 2.31_wp
1665    ELSE
1666       WRITE( message_string, * ) 'unknown aerosol species ',   &
1667                                'aero_species = "', TRIM( aero_species ), '"'
1668       CALL message( 'lpm_init', 'PA0470', 1, 2, 0, 6, 0 )
1669    ENDIF
1670!
1671!-- The following typical aerosol spectra are taken from Jaenicke (1993):
1672!-- Tropospheric aerosols. Published in Aerosol-Cloud-Climate Interactions.
1673    IF ( TRIM(aero_type) == 'polar' )  THEN
1674       na        = (/ 2.17e1, 1.86e-1, 3.04e-4 /) * 1.0E6_wp
1675       rm        = (/ 0.0689, 0.375, 4.29 /) * 1.0E-6_wp
1676       log_sigma = (/ 0.245, 0.300, 0.291 /)
1677    ELSEIF ( TRIM(aero_type) == 'background' )  THEN
1678       na        = (/ 1.29e2, 5.97e1, 6.35e1 /) * 1.0E6_wp
1679       rm        = (/ 0.0036, 0.127, 0.259 /) * 1.0E-6_wp
1680       log_sigma = (/ 0.645, 0.253, 0.425 /)
1681    ELSEIF ( TRIM(aero_type) == 'maritime' )  THEN
1682       na        = (/ 1.33e2, 6.66e1, 3.06e0 /) * 1.0E6_wp
1683       rm        = (/ 0.0039, 0.133, 0.29 /) * 1.0E-6_wp
1684       log_sigma = (/ 0.657, 0.210, 0.396 /)
1685    ELSEIF ( TRIM(aero_type) == 'continental' )  THEN
1686       na        = (/ 3.20e3, 2.90e3, 3.00e-1 /) * 1.0E6_wp
1687       rm        = (/ 0.01, 0.058, 0.9 /) * 1.0E-6_wp
1688       log_sigma = (/ 0.161, 0.217, 0.380 /)
1689    ELSEIF ( TRIM(aero_type) == 'desert' )  THEN
1690       na        = (/ 7.26e2, 1.14e3, 1.78e-1 /) * 1.0E6_wp
1691       rm        = (/ 0.001, 0.0188, 10.8 /) * 1.0E-6_wp
1692       log_sigma = (/ 0.247, 0.770, 0.438 /)
1693    ELSEIF ( TRIM(aero_type) == 'rural' )  THEN
1694       na        = (/ 6.65e3, 1.47e2, 1.99e3 /) * 1.0E6_wp
1695       rm        = (/ 0.00739, 0.0269, 0.0419 /) * 1.0E-6_wp
1696       log_sigma = (/ 0.225, 0.557, 0.266 /)
1697    ELSEIF ( TRIM(aero_type) == 'urban' )  THEN
1698       na        = (/ 9.93e4, 1.11e3, 3.64e4 /) * 1.0E6_wp
1699       rm        = (/ 0.00651, 0.00714, 0.0248 /) * 1.0E-6_wp
1700       log_sigma = (/ 0.245, 0.666, 0.337 /)
1701    ELSEIF ( TRIM(aero_type) == 'user' )  THEN
1702       CONTINUE
1703    ELSE
1704       WRITE( message_string, * ) 'unknown aerosol type ',   &
1705                                'aero_type = "', TRIM( aero_type ), '"'
1706       CALL message( 'lpm_init', 'PA0459', 1, 2, 0, 6, 0 )
1707    ENDIF
1708
1709    DO  ip = nxl, nxr
1710       DO  jp = nys, nyn
1711          DO  kp = nzb+1, nzt
1712
1713             number_of_particles = prt_count(kp,jp,ip)
1714             IF ( number_of_particles <= 0 )  CYCLE
1715             particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
1716
1717             dlogr   = ( LOG10(rmax) - LOG10(rmin) ) / ( number_of_particles - local_start(kp,jp,ip) + 1 )
1718!
1719!--          Initialize the aerosols with a predefined spectral distribution
1720!--          of the dry radius (logarithmically increasing bins) and a varying
1721!--          weighting factor
1722             DO  n = local_start(kp,jp,ip), number_of_particles  !only new particles
1723
1724                r_l   = 10.0**( LOG10( rmin ) + (n-1) * dlogr )
1725                r_r   = 10.0**( LOG10( rmin ) + n * dlogr )
1726                r_mid = SQRT( r_l * r_r )
1727
1728                particles(n)%aux1          = r_mid
1729                particles(n)%weight_factor =                                           &
1730                   ( na(1) / ( SQRT( 2.0_wp * pi ) * log_sigma(1) ) *                     &
1731                     EXP( - LOG10( r_mid / rm(1) )**2 / ( 2.0_wp * log_sigma(1)**2 ) ) +  &
1732                     na(2) / ( SQRT( 2.0_wp * pi ) * log_sigma(2) ) *                     &
1733                     EXP( - LOG10( r_mid / rm(2) )**2 / ( 2.0_wp * log_sigma(2)**2 ) ) +  &
1734                     na(3) / ( SQRT( 2.0_wp * pi ) * log_sigma(3) ) *                     &
1735                     EXP( - LOG10( r_mid / rm(3) )**2 / ( 2.0_wp * log_sigma(3)**2 ) )    &
1736                   ) * ( LOG10(r_r) - LOG10(r_l) ) * ( dx * dy * dzw(kp) )
1737
1738!
1739!--             Multiply weight_factor with the namelist parameter aero_weight
1740!--             to increase or decrease the number of simulated aerosols
1741                particles(n)%weight_factor = particles(n)%weight_factor * aero_weight
1742
1743                IF ( particles(n)%weight_factor - FLOOR(particles(n)%weight_factor,KIND=wp) &
1744                     > random_function( iran_part ) )  THEN
1745                   particles(n)%weight_factor = FLOOR(particles(n)%weight_factor,KIND=wp) + 1.0_wp
1746                ELSE
1747                   particles(n)%weight_factor = FLOOR(particles(n)%weight_factor,KIND=wp)
1748                ENDIF
1749!
1750!--             Unnecessary particles will be deleted
1751                IF ( particles(n)%weight_factor <= 0.0_wp )  particles(n)%particle_mask = .FALSE.
1752
1753             ENDDO
1754!
1755!--          Set particle radius to equilibrium radius based on the environmental
1756!--          supersaturation (Khvorostyanov and Curry, 2007, JGR). This avoids
1757!--          the sometimes lengthy growth toward their equilibrium radius within
1758!--          the simulation.
1759             t_int  = pt(kp,jp,ip) * exner(kp)
1760
1761             e_s = magnus( t_int )
1762             e_a = q(kp,jp,ip) * hyp(kp) / ( q(kp,jp,ip) + rd_d_rv )
1763
1764             sigma   = 0.0761_wp - 0.000155_wp * ( t_int - 273.15_wp )
1765             afactor = 2.0_wp * sigma / ( rho_l * r_v * t_int )
1766
1767             bfactor = vanthoff * molecular_weight_of_water *    &
1768                       rho_s / ( molecular_weight_of_solute * rho_l )
1769!
1770!--          The formula is only valid for subsaturated environments. For
1771!--          supersaturations higher than -5 %, the supersaturation is set to -5%.
1772             IF ( e_a / e_s >= 0.95_wp )  e_a = 0.95_wp * e_s
1773
1774             DO  n = local_start(kp,jp,ip), number_of_particles  !only new particles
1775!
1776!--             For details on this equation, see Eq. (14) of Khvorostyanov and
1777!--             Curry (2007, JGR)
1778                particles(n)%radius = bfactor**0.3333333_wp *                  &
1779                   particles(n)%aux1 / ( 1.0_wp - e_a / e_s )**0.3333333_wp / &
1780                   ( 1.0_wp + ( afactor / ( 3.0_wp * bfactor**0.3333333_wp *   &
1781                     particles(n)%aux1 ) ) /                                  &
1782                     ( 1.0_wp - e_a / e_s )**0.6666666_wp                      &
1783                   )
1784
1785             ENDDO
1786
1787          ENDDO
1788       ENDDO
1789    ENDDO
1790
1791 END SUBROUTINE lpm_init_aerosols
1792
1793
1794!------------------------------------------------------------------------------!
1795! Description:
1796! ------------
1797!> Calculates quantities required for considering the SGS velocity fluctuations
1798!> in the particle transport by a stochastic approach. The respective
1799!> quantities are: SGS-TKE gradients and horizontally averaged profiles of the
1800!> SGS TKE and the resolved-scale velocity variances.
1801!------------------------------------------------------------------------------!
1802 SUBROUTINE lpm_init_sgs_tke
1803
1804    USE statistics,                                                            &
1805        ONLY:  flow_statistics_called, hom, sums, sums_l
1806
1807    INTEGER(iwp) ::  i      !< index variable along x
1808    INTEGER(iwp) ::  j      !< index variable along y
1809    INTEGER(iwp) ::  k      !< index variable along z
1810    INTEGER(iwp) ::  m      !< running index for the surface elements
1811
1812    REAL(wp) ::  flag1      !< flag to mask topography
1813
1814!
1815!-- TKE gradient along x and y
1816    DO  i = nxl, nxr
1817       DO  j = nys, nyn
1818          DO  k = nzb, nzt+1
1819
1820             IF ( .NOT. BTEST( wall_flags_0(k,j,i-1), 0 )  .AND.               &
1821                        BTEST( wall_flags_0(k,j,i), 0   )  .AND.               &
1822                        BTEST( wall_flags_0(k,j,i+1), 0 ) )                    &
1823             THEN
1824                de_dx(k,j,i) = 2.0_wp * sgs_wf_part *                          &
1825                               ( e(k,j,i+1) - e(k,j,i) ) * ddx
1826             ELSEIF ( BTEST( wall_flags_0(k,j,i-1), 0 )  .AND.                 &
1827                      BTEST( wall_flags_0(k,j,i), 0   )  .AND.                 &
1828                .NOT. BTEST( wall_flags_0(k,j,i+1), 0 ) )                      &
1829             THEN
1830                de_dx(k,j,i) = 2.0_wp * sgs_wf_part *                          &
1831                               ( e(k,j,i) - e(k,j,i-1) ) * ddx
1832             ELSEIF ( .NOT. BTEST( wall_flags_0(k,j,i), 22   )  .AND.          &
1833                      .NOT. BTEST( wall_flags_0(k,j,i+1), 22 ) )               &   
1834             THEN
1835                de_dx(k,j,i) = 0.0_wp
1836             ELSEIF ( .NOT. BTEST( wall_flags_0(k,j,i-1), 22 )  .AND.          &
1837                      .NOT. BTEST( wall_flags_0(k,j,i), 22   ) )               &
1838             THEN
1839                de_dx(k,j,i) = 0.0_wp
1840             ELSE
1841                de_dx(k,j,i) = sgs_wf_part * ( e(k,j,i+1) - e(k,j,i-1) ) * ddx
1842             ENDIF
1843
1844             IF ( .NOT. BTEST( wall_flags_0(k,j-1,i), 0 )  .AND.               &
1845                        BTEST( wall_flags_0(k,j,i), 0   )  .AND.               &
1846                        BTEST( wall_flags_0(k,j+1,i), 0 ) )                    &
1847             THEN
1848                de_dy(k,j,i) = 2.0_wp * sgs_wf_part *                          &
1849                               ( e(k,j+1,i) - e(k,j,i) ) * ddy
1850             ELSEIF ( BTEST( wall_flags_0(k,j-1,i), 0 )  .AND.                 &
1851                      BTEST( wall_flags_0(k,j,i), 0   )  .AND.                 &
1852                .NOT. BTEST( wall_flags_0(k,j+1,i), 0 ) )                      &
1853             THEN
1854                de_dy(k,j,i) = 2.0_wp * sgs_wf_part *                          &
1855                               ( e(k,j,i) - e(k,j-1,i) ) * ddy
1856             ELSEIF ( .NOT. BTEST( wall_flags_0(k,j,i), 22   )  .AND.          &
1857                      .NOT. BTEST( wall_flags_0(k,j+1,i), 22 ) )               &   
1858             THEN
1859                de_dy(k,j,i) = 0.0_wp
1860             ELSEIF ( .NOT. BTEST( wall_flags_0(k,j-1,i), 22 )  .AND.          &
1861                      .NOT. BTEST( wall_flags_0(k,j,i), 22   ) )               &
1862             THEN
1863                de_dy(k,j,i) = 0.0_wp
1864             ELSE
1865                de_dy(k,j,i) = sgs_wf_part * ( e(k,j+1,i) - e(k,j-1,i) ) * ddy
1866             ENDIF
1867
1868          ENDDO
1869       ENDDO
1870    ENDDO
1871
1872!
1873!-- TKE gradient along z at topograhy and  including bottom and top boundary conditions
1874    DO  i = nxl, nxr
1875       DO  j = nys, nyn
1876          DO  k = nzb+1, nzt-1
1877!
1878!--          Flag to mask topography
1879             flag1 = MERGE( 1.0_wp, 0.0_wp, BTEST( wall_flags_0(k,j,i), 0  ) )
1880
1881             de_dz(k,j,i) = 2.0_wp * sgs_wf_part *                             &
1882                           ( e(k+1,j,i) - e(k-1,j,i) ) / ( zu(k+1) - zu(k-1) ) &
1883                                                 * flag1
1884          ENDDO
1885!
1886!--       upward-facing surfaces
1887          DO  m = bc_h(0)%start_index(j,i), bc_h(0)%end_index(j,i)
1888             k            = bc_h(0)%k(m)
1889             de_dz(k,j,i) = 2.0_wp * sgs_wf_part *                             &
1890                           ( e(k+1,j,i) - e(k,j,i)   ) / ( zu(k+1) - zu(k) )
1891          ENDDO
1892!
1893!--       downward-facing surfaces
1894          DO  m = bc_h(1)%start_index(j,i), bc_h(1)%end_index(j,i)
1895             k            = bc_h(1)%k(m)
1896             de_dz(k,j,i) = 2.0_wp * sgs_wf_part *                             &
1897                           ( e(k,j,i) - e(k-1,j,i)   ) / ( zu(k) - zu(k-1) )
1898          ENDDO
1899
1900          de_dz(nzb,j,i)   = 0.0_wp
1901          de_dz(nzt,j,i)   = 0.0_wp
1902          de_dz(nzt+1,j,i) = 0.0_wp
1903       ENDDO
1904    ENDDO
1905!
1906!-- Ghost point exchange
1907    CALL exchange_horiz( de_dx, nbgp )
1908    CALL exchange_horiz( de_dy, nbgp )
1909    CALL exchange_horiz( de_dz, nbgp )
1910    CALL exchange_horiz( diss, nbgp  )
1911!
1912!-- Set boundary conditions at non-periodic boundaries. Note, at non-period
1913!-- boundaries zero-gradient boundary conditions are set for the subgrid TKE.
1914!-- Thus, TKE gradients normal to the respective lateral boundaries are zero,
1915!-- while tangetial TKE gradients then must be the same as within the prognostic
1916!-- domain. 
1917    IF ( bc_dirichlet_l )  THEN
1918       de_dx(:,:,-1) = 0.0_wp
1919       de_dy(:,:,-1) = de_dy(:,:,0) 
1920       de_dz(:,:,-1) = de_dz(:,:,0)
1921    ENDIF
1922    IF ( bc_dirichlet_r )  THEN
1923       de_dx(:,:,nxr+1) = 0.0_wp
1924       de_dy(:,:,nxr+1) = de_dy(:,:,nxr) 
1925       de_dz(:,:,nxr+1) = de_dz(:,:,nxr)
1926    ENDIF
1927    IF ( bc_dirichlet_n )  THEN
1928       de_dx(:,nyn+1,:) = de_dx(:,nyn,:)
1929       de_dy(:,nyn+1,:) = 0.0_wp 
1930       de_dz(:,nyn+1,:) = de_dz(:,nyn,:)
1931    ENDIF
1932    IF ( bc_dirichlet_s )  THEN
1933       de_dx(:,nys-1,:) = de_dx(:,nys,:)
1934       de_dy(:,nys-1,:) = 0.0_wp 
1935       de_dz(:,nys-1,:) = de_dz(:,nys,:)
1936    ENDIF 
1937!
1938!-- Calculate the horizontally averaged profiles of SGS TKE and resolved
1939!-- velocity variances (they may have been already calculated in routine
1940!-- flow_statistics).
1941    IF ( .NOT. flow_statistics_called )  THEN
1942
1943!
1944!--    First calculate horizontally averaged profiles of the horizontal
1945!--    velocities.
1946       sums_l(:,1,0) = 0.0_wp
1947       sums_l(:,2,0) = 0.0_wp
1948
1949       DO  i = nxl, nxr
1950          DO  j =  nys, nyn
1951             DO  k = nzb, nzt+1
1952!
1953!--             Flag indicating vicinity of wall
1954                flag1 = MERGE( 1.0_wp, 0.0_wp, BTEST( wall_flags_0(k,j,i), 24 ) )
1955
1956                sums_l(k,1,0)  = sums_l(k,1,0)  + u(k,j,i) * flag1
1957                sums_l(k,2,0)  = sums_l(k,2,0)  + v(k,j,i) * flag1
1958             ENDDO
1959          ENDDO
1960       ENDDO
1961
1962#if defined( __parallel )
1963!
1964!--    Compute total sum from local sums
1965       IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
1966       CALL MPI_ALLREDUCE( sums_l(nzb,1,0), sums(nzb,1), nzt+2-nzb, &
1967                           MPI_REAL, MPI_SUM, comm2d, ierr )
1968       IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
1969       CALL MPI_ALLREDUCE( sums_l(nzb,2,0), sums(nzb,2), nzt+2-nzb, &
1970                              MPI_REAL, MPI_SUM, comm2d, ierr )
1971#else
1972       sums(:,1) = sums_l(:,1,0)
1973       sums(:,2) = sums_l(:,2,0)
1974#endif
1975
1976!
1977!--    Final values are obtained by division by the total number of grid
1978!--    points used for the summation.
1979       hom(:,1,1,0) = sums(:,1) / ngp_2dh_outer(:,0)   ! u
1980       hom(:,1,2,0) = sums(:,2) / ngp_2dh_outer(:,0)   ! v
1981
1982!
1983!--    Now calculate the profiles of SGS TKE and the resolved-scale
1984!--    velocity variances
1985       sums_l(:,8,0)  = 0.0_wp
1986       sums_l(:,30,0) = 0.0_wp
1987       sums_l(:,31,0) = 0.0_wp
1988       sums_l(:,32,0) = 0.0_wp
1989       DO  i = nxl, nxr
1990          DO  j = nys, nyn
1991             DO  k = nzb, nzt+1
1992!
1993!--             Flag indicating vicinity of wall
1994                flag1 = MERGE( 1.0_wp, 0.0_wp, BTEST( wall_flags_0(k,j,i), 24 ) )
1995
1996                sums_l(k,8,0)  = sums_l(k,8,0)  + e(k,j,i)                       * flag1
1997                sums_l(k,30,0) = sums_l(k,30,0) + ( u(k,j,i) - hom(k,1,1,0) )**2 * flag1
1998                sums_l(k,31,0) = sums_l(k,31,0) + ( v(k,j,i) - hom(k,1,2,0) )**2 * flag1
1999                sums_l(k,32,0) = sums_l(k,32,0) + w(k,j,i)**2                    * flag1
2000             ENDDO
2001          ENDDO
2002       ENDDO
2003
2004#if defined( __parallel )
2005!
2006!--    Compute total sum from local sums
2007       IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
2008       CALL MPI_ALLREDUCE( sums_l(nzb,8,0), sums(nzb,8), nzt+2-nzb, &
2009                           MPI_REAL, MPI_SUM, comm2d, ierr )
2010       IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
2011       CALL MPI_ALLREDUCE( sums_l(nzb,30,0), sums(nzb,30), nzt+2-nzb, &
2012                           MPI_REAL, MPI_SUM, comm2d, ierr )
2013       IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
2014       CALL MPI_ALLREDUCE( sums_l(nzb,31,0), sums(nzb,31), nzt+2-nzb, &
2015                           MPI_REAL, MPI_SUM, comm2d, ierr )
2016       IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
2017       CALL MPI_ALLREDUCE( sums_l(nzb,32,0), sums(nzb,32), nzt+2-nzb, &
2018                           MPI_REAL, MPI_SUM, comm2d, ierr )
2019
2020#else
2021       sums(:,8)  = sums_l(:,8,0)
2022       sums(:,30) = sums_l(:,30,0)
2023       sums(:,31) = sums_l(:,31,0)
2024       sums(:,32) = sums_l(:,32,0)
2025#endif
2026
2027!
2028!--    Final values are obtained by division by the total number of grid
2029!--    points used for the summation.
2030       hom(:,1,8,0)  = sums(:,8)  / ngp_2dh_outer(:,0)   ! e
2031       hom(:,1,30,0) = sums(:,30) / ngp_2dh_outer(:,0)   ! u*2
2032       hom(:,1,31,0) = sums(:,31) / ngp_2dh_outer(:,0)   ! v*2
2033       hom(:,1,32,0) = sums(:,32) / ngp_2dh_outer(:,0)   ! w*2
2034
2035    ENDIF
2036
2037 END SUBROUTINE lpm_init_sgs_tke
2038 
2039 
2040!------------------------------------------------------------------------------!
2041! Description:
2042! ------------
2043!> Sobroutine control lpm actions, i.e. all actions during one time step.
2044!------------------------------------------------------------------------------! 
2045 SUBROUTINE lpm_actions( location )
2046
2047    CHARACTER (LEN=*), INTENT(IN) ::  location !< call location string
2048
2049    INTEGER(iwp)       ::  i                  !<
2050    INTEGER(iwp)       ::  ie                 !<
2051    INTEGER(iwp)       ::  is                 !<
2052    INTEGER(iwp)       ::  j                  !<
2053    INTEGER(iwp)       ::  je                 !<
2054    INTEGER(iwp)       ::  js                 !<
2055    INTEGER(iwp), SAVE ::  lpm_count = 0      !<
2056    INTEGER(iwp)       ::  k                  !<
2057    INTEGER(iwp)       ::  ke                 !<
2058    INTEGER(iwp)       ::  ks                 !<
2059    INTEGER(iwp)       ::  m                  !<
2060    INTEGER(iwp), SAVE ::  steps = 0          !<
2061
2062    LOGICAL            ::  first_loop_stride  !<
2063
2064
2065    SELECT CASE ( location )
2066
2067       CASE ( 'after_prognostic_equations' )
2068
2069          CALL cpu_log( log_point(25), 'lpm', 'start' )
2070!
2071!--       Write particle data at current time on file.
2072!--       This has to be done here, before particles are further processed,
2073!--       because they may be deleted within this timestep (in case that
2074!--       dt_write_particle_data = dt_prel = particle_maximum_age).
2075          time_write_particle_data = time_write_particle_data + dt_3d
2076          IF ( time_write_particle_data >= dt_write_particle_data )  THEN
2077
2078             CALL lpm_data_output_particles
2079!
2080!--       The MOD function allows for changes in the output interval with restart
2081!--       runs.
2082             time_write_particle_data = MOD( time_write_particle_data, &
2083                                        MAX( dt_write_particle_data, dt_3d ) )
2084          ENDIF
2085
2086!
2087!--       Initialize arrays for marking those particles to be deleted after the
2088!--       (sub-) timestep
2089          deleted_particles = 0
2090
2091!
2092!--       Initialize variables used for accumulating the number of particles
2093!--       xchanged between the subdomains during all sub-timesteps (if sgs
2094!--       velocities are included). These data are output further below on the
2095!--       particle statistics file.
2096          trlp_count_sum      = 0
2097          trlp_count_recv_sum = 0
2098          trrp_count_sum      = 0
2099          trrp_count_recv_sum = 0
2100          trsp_count_sum      = 0
2101          trsp_count_recv_sum = 0
2102          trnp_count_sum      = 0
2103          trnp_count_recv_sum = 0
2104!
2105!--       Calculate exponential term used in case of particle inertia for each
2106!--       of the particle groups
2107          DO  m = 1, number_of_particle_groups
2108             IF ( particle_groups(m)%density_ratio /= 0.0_wp )  THEN
2109                particle_groups(m)%exp_arg  =                                        &
2110                          4.5_wp * particle_groups(m)%density_ratio *                &
2111                          molecular_viscosity / ( particle_groups(m)%radius )**2
2112
2113                particle_groups(m)%exp_term = EXP( -particle_groups(m)%exp_arg *     &
2114                          dt_3d )
2115             ENDIF
2116          ENDDO
2117!
2118!--       If necessary, release new set of particles
2119          IF ( ( simulated_time - last_particle_release_time ) >= dt_prel  .AND. end_time_prel > simulated_time ) &
2120          THEN
2121             DO WHILE ( ( simulated_time - last_particle_release_time ) >= dt_prel )
2122                CALL lpm_create_particle( PHASE_RELEASE )
2123                last_particle_release_time = last_particle_release_time + dt_prel
2124             ENDDO
2125          ENDIF
2126!
2127!--       Reset summation arrays
2128          IF ( cloud_droplets )  THEN
2129             ql_c  = 0.0_wp
2130             ql_v  = 0.0_wp
2131             ql_vp = 0.0_wp
2132          ENDIF
2133
2134          first_loop_stride = .TRUE.
2135          grid_particles(:,:,:)%time_loop_done = .TRUE.
2136!
2137!--       Timestep loop for particle advection.
2138!--       This loop has to be repeated until the advection time of every particle
2139!--       (within the total domain!) has reached the LES timestep (dt_3d).
2140!--       In case of including the SGS velocities, the particle timestep may be
2141!--       smaller than the LES timestep (because of the Lagrangian timescale
2142!--       restriction) and particles may require to undergo several particle
2143!--       timesteps, before the LES timestep is reached. Because the number of these
2144!--       particle timesteps to be carried out is unknown at first, these steps are
2145!--       carried out in the following infinite loop with exit condition.
2146          DO
2147             CALL cpu_log( log_point_s(44), 'lpm_advec', 'start' )
2148             CALL cpu_log( log_point_s(44), 'lpm_advec', 'pause' )
2149
2150!
2151!--          If particle advection includes SGS velocity components, calculate the
2152!--          required SGS quantities (i.e. gradients of the TKE, as well as
2153!--          horizontally averaged profiles of the SGS TKE and the resolved-scale
2154!--          velocity variances)
2155             IF ( use_sgs_for_particles  .AND.  .NOT. cloud_droplets )  THEN
2156                CALL lpm_init_sgs_tke
2157             ENDIF
2158!
2159!--          In case SGS-particle speed is considered, particles may carry out
2160!--          several particle timesteps. In order to prevent unnecessary
2161!--          treatment of particles that already reached the final time level,
2162!--          particles are sorted into contiguous blocks of finished and
2163!--          not-finished particles, in addition to their already sorting
2164!--          according to their sub-boxes.
2165             IF ( .NOT. first_loop_stride  .AND.  use_sgs_for_particles )            &
2166                CALL lpm_sort_timeloop_done
2167             DO  i = nxl, nxr
2168                DO  j = nys, nyn
2169                   DO  k = nzb+1, nzt
2170
2171                      number_of_particles = prt_count(k,j,i)
2172!
2173!--                   If grid cell gets empty, flag must be true
2174                      IF ( number_of_particles <= 0 )  THEN
2175                         grid_particles(k,j,i)%time_loop_done = .TRUE.
2176                         CYCLE
2177                      ENDIF
2178
2179                      IF ( .NOT. first_loop_stride  .AND.  &
2180                           grid_particles(k,j,i)%time_loop_done )  CYCLE
2181
2182                      particles => grid_particles(k,j,i)%particles(1:number_of_particles)
2183
2184                      particles(1:number_of_particles)%particle_mask = .TRUE.
2185!
2186!--                   Initialize the variable storing the total time that a particle
2187!--                   has advanced within the timestep procedure
2188                      IF ( first_loop_stride )  THEN
2189                         particles(1:number_of_particles)%dt_sum = 0.0_wp
2190                      ENDIF
2191!
2192!--                   Particle (droplet) growth by condensation/evaporation and
2193!--                   collision
2194                      IF ( cloud_droplets  .AND.  first_loop_stride)  THEN
2195!
2196!--                      Droplet growth by condensation / evaporation
2197                         CALL lpm_droplet_condensation(i,j,k)
2198!
2199!--                      Particle growth by collision
2200                         IF ( collision_kernel /= 'none' )  THEN
2201                            CALL lpm_droplet_collision(i,j,k)
2202                         ENDIF
2203
2204                      ENDIF
2205!
2206!--                   Initialize the switch used for the loop exit condition checked
2207!--                   at the end of this loop. If at least one particle has failed to
2208!--                   reach the LES timestep, this switch will be set false in
2209!--                   lpm_advec.
2210                      dt_3d_reached_l = .TRUE.
2211
2212!
2213!--                   Particle advection
2214                      CALL lpm_advec(i,j,k)
2215!
2216!--                   Particle reflection from walls. Only applied if the particles
2217!--                   are in the vertical range of the topography. (Here, some
2218!--                   optimization is still possible.)
2219                      IF ( topography /= 'flat' .AND. k < nzb_max + 2 )  THEN
2220                         CALL  lpm_boundary_conds( 'walls', i, j, k )
2221                      ENDIF
2222!
2223!--                   User-defined actions after the calculation of the new particle
2224!--                   position
2225                      CALL user_lpm_advec(i,j,k)
2226!
2227!--                   Apply boundary conditions to those particles that have crossed
2228!--                   the top or bottom boundary and delete those particles, which are
2229!--                   older than allowed
2230                      CALL lpm_boundary_conds( 'bottom/top', i, j, k )
2231!
2232!---                  If not all particles of the actual grid cell have reached the
2233!--                   LES timestep, this cell has to do another loop iteration. Due to
2234!--                   the fact that particles can move into neighboring grid cells,
2235!--                   these neighbor cells also have to perform another loop iteration.
2236!--                   Please note, this realization does not work properly if
2237!--                   particles move into another subdomain.
2238                      IF ( .NOT. dt_3d_reached_l )  THEN
2239                         ks = MAX(nzb+1,k-1)
2240                         ke = MIN(nzt,k+1)
2241                         js = MAX(nys,j-1)
2242                         je = MIN(nyn,j+1)
2243                         is = MAX(nxl,i-1)
2244                         ie = MIN(nxr,i+1)
2245                         grid_particles(ks:ke,js:je,is:ie)%time_loop_done = .FALSE.
2246                      ELSE
2247                         grid_particles(k,j,i)%time_loop_done = .TRUE.
2248                      ENDIF
2249
2250                   ENDDO
2251                ENDDO
2252             ENDDO
2253             steps = steps + 1
2254             dt_3d_reached_l = ALL(grid_particles(:,:,:)%time_loop_done)
2255!
2256!--          Find out, if all particles on every PE have completed the LES timestep
2257!--          and set the switch corespondingly
2258#if defined( __parallel )
2259             IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
2260             CALL MPI_ALLREDUCE( dt_3d_reached_l, dt_3d_reached, 1, MPI_LOGICAL, &
2261                                 MPI_LAND, comm2d, ierr )
2262#else
2263             dt_3d_reached = dt_3d_reached_l
2264#endif
2265             CALL cpu_log( log_point_s(44), 'lpm_advec', 'stop' )
2266
2267!
2268!--          Apply splitting and merging algorithm
2269             IF ( cloud_droplets )  THEN
2270                IF ( splitting )  THEN
2271                   CALL lpm_splitting
2272                ENDIF
2273                IF ( merging )  THEN
2274                   CALL lpm_merging
2275                ENDIF
2276             ENDIF
2277!
2278!--          Move Particles local to PE to a different grid cell
2279             CALL lpm_move_particle
2280!
2281!--          Horizontal boundary conditions including exchange between subdmains
2282             CALL lpm_exchange_horiz
2283
2284!
2285!--          IF .FALSE., lpm_sort_and_delete is done inside pcmp
2286             IF ( .NOT. dt_3d_reached .OR. .NOT. nested_run )   THEN   
2287!
2288!--             Pack particles (eliminate those marked for deletion),
2289!--             determine new number of particles
2290                CALL lpm_sort_and_delete
2291
2292!--             Initialize variables for the next (sub-) timestep, i.e., for marking
2293!--             those particles to be deleted after the timestep
2294                deleted_particles = 0
2295             ENDIF
2296
2297             IF ( dt_3d_reached )  EXIT
2298
2299             first_loop_stride = .FALSE.
2300          ENDDO   ! timestep loop
2301!
2302!--       in case of nested runs do the transfer of particles after every full model time step
2303          IF ( nested_run )   THEN
2304             CALL particles_from_parent_to_child
2305             CALL particles_from_child_to_parent
2306             CALL pmcp_p_delete_particles_in_fine_grid_area
2307
2308             CALL lpm_sort_and_delete
2309
2310             deleted_particles = 0
2311          ENDIF
2312
2313!
2314!--       Calculate the new liquid water content for each grid box
2315          IF ( cloud_droplets )  CALL lpm_calc_liquid_water_content
2316
2317!
2318!--       Deallocate unused memory
2319          IF ( deallocate_memory  .AND.  lpm_count == step_dealloc )  THEN
2320             CALL dealloc_particles_array
2321             lpm_count = 0
2322          ELSEIF ( deallocate_memory )  THEN
2323             lpm_count = lpm_count + 1
2324          ENDIF
2325
2326!
2327!--       Write particle statistics (in particular the number of particles
2328!--       exchanged between the subdomains) on file
2329          IF ( write_particle_statistics )  CALL lpm_write_exchange_statistics
2330
2331          CALL cpu_log( log_point(25), 'lpm', 'stop' )
2332
2333! !
2334! !--       Output of particle time series
2335!           IF ( particle_advection )  THEN
2336!              IF ( time_dopts >= dt_dopts  .OR.                                                        &
2337!                   ( time_since_reference_point >= particle_advection_start  .AND.                     &
2338!                    first_call_lpm ) )  THEN
2339!                 CALL lpm_data_output_ptseries
2340!                 time_dopts = MOD( time_dopts, MAX( dt_dopts, dt_3d ) )
2341!              ENDIF
2342!           ENDIF
2343
2344       CASE DEFAULT
2345          CONTINUE
2346
2347    END SELECT
2348
2349 END SUBROUTINE lpm_actions
2350 
2351 
2352!------------------------------------------------------------------------------!
2353! Description:
2354! ------------
2355!
2356!------------------------------------------------------------------------------!
2357 SUBROUTINE particles_from_parent_to_child
2358    IMPLICIT NONE
2359
2360    CALL pmcp_c_get_particle_from_parent                         ! Child actions
2361    CALL pmcp_p_fill_particle_win                                ! Parent actions
2362
2363    RETURN
2364 END SUBROUTINE particles_from_parent_to_child
2365
2366 
2367!------------------------------------------------------------------------------!
2368! Description:
2369! ------------
2370!
2371!------------------------------------------------------------------------------!
2372 SUBROUTINE particles_from_child_to_parent
2373    IMPLICIT NONE
2374
2375    CALL pmcp_c_send_particle_to_parent                         ! Child actions
2376    CALL pmcp_p_empty_particle_win                              ! Parent actions
2377
2378    RETURN
2379 END SUBROUTINE particles_from_child_to_parent
2380 
2381!------------------------------------------------------------------------------!
2382! Description:
2383! ------------
2384!> This routine write exchange statistics of the lpm in a ascii file.
2385!------------------------------------------------------------------------------!
2386 SUBROUTINE lpm_write_exchange_statistics
2387
2388    INTEGER(iwp) :: ip         !<
2389    INTEGER(iwp) :: jp         !<
2390    INTEGER(iwp) :: kp         !<
2391    INTEGER(iwp) :: tot_number_of_particles
2392
2393!
2394!-- Determine the current number of particles
2395    number_of_particles         = 0
2396    DO  ip = nxl, nxr
2397       DO  jp = nys, nyn
2398          DO  kp = nzb+1, nzt
2399             number_of_particles = number_of_particles                         &
2400                                     + prt_count(kp,jp,ip)
2401          ENDDO
2402       ENDDO
2403    ENDDO
2404
2405    CALL check_open( 80 )
2406#if defined( __parallel )
2407    WRITE ( 80, 8000 )  current_timestep_number+1, simulated_time+dt_3d, &
2408                        number_of_particles, pleft, trlp_count_sum,      &
2409                        trlp_count_recv_sum, pright, trrp_count_sum,     &
2410                        trrp_count_recv_sum, psouth, trsp_count_sum,     &
2411                        trsp_count_recv_sum, pnorth, trnp_count_sum,     &
2412                        trnp_count_recv_sum
2413#else
2414    WRITE ( 80, 8000 )  current_timestep_number+1, simulated_time+dt_3d, &
2415                        number_of_particles
2416#endif
2417    CALL close_file( 80 )
2418
2419    IF ( number_of_particles > 0 )  THEN
2420        WRITE(9,*) 'number_of_particles ', number_of_particles,                &
2421                    current_timestep_number + 1, simulated_time + dt_3d
2422    ENDIF
2423
2424#if defined( __parallel )
2425    CALL MPI_ALLREDUCE( number_of_particles, tot_number_of_particles, 1,       &
2426                        MPI_INTEGER, MPI_SUM, comm2d, ierr )
2427#else
2428    tot_number_of_particles = number_of_particles
2429#endif
2430
2431    IF ( nested_run )  THEN
2432       CALL pmcp_g_print_number_of_particles( simulated_time+dt_3d,            &
2433                                              tot_number_of_particles)
2434    ENDIF
2435
2436!
2437!-- Formats
24388000 FORMAT (I6,1X,F7.2,4X,I10,5X,4(I3,1X,I4,'/',I4,2X),6X,I10)
2439
2440
2441 END SUBROUTINE lpm_write_exchange_statistics
2442 
2443
2444!------------------------------------------------------------------------------!
2445! Description:
2446! ------------
2447!> Write particle data in FORTRAN binary and/or netCDF format
2448!------------------------------------------------------------------------------!
2449 SUBROUTINE lpm_data_output_particles
2450 
2451    INTEGER(iwp) ::  ip !<
2452    INTEGER(iwp) ::  jp !<
2453    INTEGER(iwp) ::  kp !<
2454
2455    CALL cpu_log( log_point_s(40), 'lpm_data_output', 'start' )
2456
2457!
2458!-- Attention: change version number for unit 85 (in routine check_open)
2459!--            whenever the output format for this unit is changed!
2460    CALL check_open( 85 )
2461
2462    WRITE ( 85 )  simulated_time
2463    WRITE ( 85 )  prt_count
2464         
2465    DO  ip = nxl, nxr
2466       DO  jp = nys, nyn
2467          DO  kp = nzb+1, nzt
2468             number_of_particles = prt_count(kp,jp,ip)
2469             particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
2470             IF ( number_of_particles <= 0 )  CYCLE
2471             WRITE ( 85 )  particles
2472          ENDDO
2473       ENDDO
2474    ENDDO
2475
2476    CALL close_file( 85 )
2477
2478
2479#if defined( __netcdf )
2480! !
2481! !-- Output in netCDF format
2482!     CALL check_open( 108 )
2483!
2484! !
2485! !-- Update the NetCDF time axis
2486!     prt_time_count = prt_time_count + 1
2487!
2488!     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_time_prt, &
2489!                             (/ simulated_time /),        &
2490!                             start = (/ prt_time_count /), count = (/ 1 /) )
2491!     CALL netcdf_handle_error( 'lpm_data_output_particles', 1 )
2492!
2493! !
2494! !-- Output the real number of particles used
2495!     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_rnop_prt, &
2496!                             (/ number_of_particles /),   &
2497!                             start = (/ prt_time_count /), count = (/ 1 /) )
2498!     CALL netcdf_handle_error( 'lpm_data_output_particles', 2 )
2499!
2500! !
2501! !-- Output all particle attributes
2502!     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(1), particles%age,      &
2503!                             start = (/ 1, prt_time_count /),               &
2504!                             count = (/ maximum_number_of_particles /) )
2505!     CALL netcdf_handle_error( 'lpm_data_output_particles', 3 )
2506!
2507!     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(2), particles%user,     &
2508!                             start = (/ 1, prt_time_count /),               &
2509!                             count = (/ maximum_number_of_particles /) )
2510!     CALL netcdf_handle_error( 'lpm_data_output_particles', 4 )
2511!
2512!     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(3), particles%origin_x, &
2513!                             start = (/ 1, prt_time_count /),               &
2514!                             count = (/ maximum_number_of_particles /) )
2515!     CALL netcdf_handle_error( 'lpm_data_output_particles', 5 )
2516!
2517!     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(4), particles%origin_y, &
2518!                             start = (/ 1, prt_time_count /),               &
2519!                             count = (/ maximum_number_of_particles /) )
2520!     CALL netcdf_handle_error( 'lpm_data_output_particles', 6 )
2521!
2522!     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(5), particles%origin_z, &
2523!                             start = (/ 1, prt_time_count /),               &
2524!                             count = (/ maximum_number_of_particles /) )
2525!     CALL netcdf_handle_error( 'lpm_data_output_particles', 7 )
2526!
2527!     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(6), particles%radius,   &
2528!                             start = (/ 1, prt_time_count /),               &
2529!                             count = (/ maximum_number_of_particles /) )
2530!     CALL netcdf_handle_error( 'lpm_data_output_particles', 8 )
2531!
2532!     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(7), particles%speed_x,  &
2533!                             start = (/ 1, prt_time_count /),               &
2534!                             count = (/ maximum_number_of_particles /) )
2535!     CALL netcdf_handle_error( 'lpm_data_output_particles', 9 )
2536!
2537!     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(8), particles%speed_y,  &
2538!                             start = (/ 1, prt_time_count /),               &
2539!                             count = (/ maximum_number_of_particles /) )
2540!     CALL netcdf_handle_error( 'lpm_data_output_particles', 10 )
2541!
2542!     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(9), particles%speed_z,  &
2543!                             start = (/ 1, prt_time_count /),               &
2544!                             count = (/ maximum_number_of_particles /) )
2545!     CALL netcdf_handle_error( 'lpm_data_output_particles', 11 )
2546!
2547!     nc_stat = NF90_PUT_VAR( id_set_prt,id_var_prt(10),                     &
2548!                             particles%weight_factor,                       &
2549!                             start = (/ 1, prt_time_count /),               &
2550!                             count = (/ maximum_number_of_particles /) )
2551!     CALL netcdf_handle_error( 'lpm_data_output_particles', 12 )
2552!
2553!     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(11), particles%x,       &
2554!                             start = (/ 1, prt_time_count /),               &
2555!                             count = (/ maximum_number_of_particles /) )
2556!     CALL netcdf_handle_error( 'lpm_data_output_particles', 13 )
2557!
2558!     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(12), particles%y,       &
2559!                             start = (/ 1, prt_time_count /),               &
2560!                             count = (/ maximum_number_of_particles /) )
2561!     CALL netcdf_handle_error( 'lpm_data_output_particles', 14 )
2562!
2563!     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(13), particles%z,       &
2564!                             start = (/ 1, prt_time_count /),               &
2565!                             count = (/ maximum_number_of_particles /) )
2566!     CALL netcdf_handle_error( 'lpm_data_output_particles', 15 )
2567!
2568!     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(14), particles%class,   &
2569!                             start = (/ 1, prt_time_count /),               &
2570!                             count = (/ maximum_number_of_particles /) )
2571!     CALL netcdf_handle_error( 'lpm_data_output_particles', 16 )
2572!
2573!     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(15), particles%group,   &
2574!                             start = (/ 1, prt_time_count /),               &
2575!                             count = (/ maximum_number_of_particles /) )
2576!     CALL netcdf_handle_error( 'lpm_data_output_particles', 17 )
2577!
2578!     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(16),                    &
2579!                             particles%id2,                                 &
2580!                             start = (/ 1, prt_time_count /),               &
2581!                             count = (/ maximum_number_of_particles /) )
2582!     CALL netcdf_handle_error( 'lpm_data_output_particles', 18 )
2583!
2584!     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(17), particles%id1,     &
2585!                             start = (/ 1, prt_time_count /),               &
2586!                             count = (/ maximum_number_of_particles /) )
2587!     CALL netcdf_handle_error( 'lpm_data_output_particles', 19 )
2588!
2589#endif
2590
2591    CALL cpu_log( log_point_s(40), 'lpm_data_output', 'stop' )
2592
2593 END SUBROUTINE lpm_data_output_particles
2594 
2595!------------------------------------------------------------------------------!
2596! Description:
2597! ------------
2598!> This routine calculates and provide particle timeseries output.
2599!------------------------------------------------------------------------------!
2600 SUBROUTINE lpm_data_output_ptseries
2601 
2602    INTEGER(iwp) ::  i    !<
2603    INTEGER(iwp) ::  inum !<
2604    INTEGER(iwp) ::  j    !<
2605    INTEGER(iwp) ::  jg   !<
2606    INTEGER(iwp) ::  k    !<
2607    INTEGER(iwp) ::  n    !<
2608
2609    REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  pts_value   !<
2610    REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  pts_value_l !<
2611
2612
2613    CALL cpu_log( log_point(36), 'data_output_ptseries', 'start' )
2614
2615    IF ( myid == 0 )  THEN
2616!
2617!--    Open file for time series output in NetCDF format
2618       dopts_time_count = dopts_time_count + 1
2619       CALL check_open( 109 )
2620#if defined( __netcdf )
2621!
2622!--    Update the particle time series time axis
2623       nc_stat = NF90_PUT_VAR( id_set_pts, id_var_time_pts,      &
2624                               (/ time_since_reference_point /), &
2625                               start = (/ dopts_time_count /), count = (/ 1 /) )
2626       CALL netcdf_handle_error( 'data_output_ptseries', 391 )
2627#endif
2628
2629    ENDIF
2630
2631    ALLOCATE( pts_value(0:number_of_particle_groups,dopts_num), &
2632              pts_value_l(0:number_of_particle_groups,dopts_num) )
2633
2634    pts_value_l = 0.0_wp
2635    pts_value_l(:,16) = 9999999.9_wp    ! for calculation of minimum radius
2636
2637!
2638!-- Calculate or collect the particle time series quantities for all particles
2639!-- and seperately for each particle group (if there is more than one group)
2640    DO  i = nxl, nxr
2641       DO  j = nys, nyn
2642          DO  k = nzb, nzt
2643             number_of_particles = prt_count(k,j,i)
2644             IF (number_of_particles <= 0)  CYCLE
2645             particles => grid_particles(k,j,i)%particles(1:number_of_particles)
2646             DO  n = 1, number_of_particles
2647
2648                IF ( particles(n)%particle_mask )  THEN  ! Restrict analysis to active particles
2649
2650                   pts_value_l(0,1)  = pts_value_l(0,1) + 1.0_wp  ! total # of particles
2651                   pts_value_l(0,2)  = pts_value_l(0,2) +                      &
2652                          ( particles(n)%x - particles(n)%origin_x )  ! mean x
2653                   pts_value_l(0,3)  = pts_value_l(0,3) +                      &
2654                          ( particles(n)%y - particles(n)%origin_y )  ! mean y
2655                   pts_value_l(0,4)  = pts_value_l(0,4) +                      &
2656                          ( particles(n)%z - particles(n)%origin_z )  ! mean z
2657                   pts_value_l(0,5)  = pts_value_l(0,5) + particles(n)%z        ! mean z (absolute)
2658                   pts_value_l(0,6)  = pts_value_l(0,6) + particles(n)%speed_x  ! mean u
2659                   pts_value_l(0,7)  = pts_value_l(0,7) + particles(n)%speed_y  ! mean v
2660                   pts_value_l(0,8)  = pts_value_l(0,8) + particles(n)%speed_z  ! mean w
2661                   pts_value_l(0,9)  = pts_value_l(0,9)  + particles(n)%rvar1 ! mean sgsu
2662                   pts_value_l(0,10) = pts_value_l(0,10) + particles(n)%rvar2 ! mean sgsv
2663                   pts_value_l(0,11) = pts_value_l(0,11) + particles(n)%rvar3 ! mean sgsw
2664                   IF ( particles(n)%speed_z > 0.0_wp )  THEN
2665                      pts_value_l(0,12) = pts_value_l(0,12) + 1.0_wp  ! # of upward moving prts
2666                      pts_value_l(0,13) = pts_value_l(0,13) +                  &
2667                                              particles(n)%speed_z ! mean w upw.
2668                   ELSE
2669                      pts_value_l(0,14) = pts_value_l(0,14) +                  &
2670                                              particles(n)%speed_z ! mean w down
2671                   ENDIF
2672                   pts_value_l(0,15) = pts_value_l(0,15) + particles(n)%radius ! mean rad
2673                   pts_value_l(0,16) = MIN( pts_value_l(0,16), particles(n)%radius ) ! minrad
2674                   pts_value_l(0,17) = MAX( pts_value_l(0,17), particles(n)%radius ) ! maxrad
2675                   pts_value_l(0,18) = pts_value_l(0,18) + 1.0_wp
2676                   pts_value_l(0,19) = pts_value_l(0,18) + 1.0_wp
2677!
2678!--                Repeat the same for the respective particle group
2679                   IF ( number_of_particle_groups > 1 )  THEN
2680                      jg = particles(n)%group
2681
2682                      pts_value_l(jg,1)  = pts_value_l(jg,1) + 1.0_wp
2683                      pts_value_l(jg,2)  = pts_value_l(jg,2) +                   &
2684                           ( particles(n)%x - particles(n)%origin_x )
2685                      pts_value_l(jg,3)  = pts_value_l(jg,3) +                   &
2686                           ( particles(n)%y - particles(n)%origin_y )
2687                      pts_value_l(jg,4)  = pts_value_l(jg,4) +                   &
2688                           ( particles(n)%z - particles(n)%origin_z )
2689                      pts_value_l(jg,5)  = pts_value_l(jg,5) + particles(n)%z
2690                      pts_value_l(jg,6)  = pts_value_l(jg,6) + particles(n)%speed_x
2691                      pts_value_l(jg,7)  = pts_value_l(jg,7) + particles(n)%speed_y
2692                      pts_value_l(jg,8)  = pts_value_l(jg,8) + particles(n)%speed_z
2693                      pts_value_l(jg,9)  = pts_value_l(jg,9)  + particles(n)%rvar1
2694                      pts_value_l(jg,10) = pts_value_l(jg,10) + particles(n)%rvar2
2695                      pts_value_l(jg,11) = pts_value_l(jg,11) + particles(n)%rvar3
2696                      IF ( particles(n)%speed_z > 0.0_wp )  THEN
2697                         pts_value_l(jg,12) = pts_value_l(jg,12) + 1.0_wp
2698                         pts_value_l(jg,13) = pts_value_l(jg,13) + particles(n)%speed_z
2699                      ELSE
2700                         pts_value_l(jg,14) = pts_value_l(jg,14) + particles(n)%speed_z
2701                      ENDIF
2702                      pts_value_l(jg,15) = pts_value_l(jg,15) + particles(n)%radius
2703                      pts_value_l(jg,16) = MIN( pts_value(jg,16), particles(n)%radius )
2704                      pts_value_l(jg,17) = MAX( pts_value(jg,17), particles(n)%radius )
2705                      pts_value_l(jg,18) = pts_value_l(jg,18) + 1.0_wp
2706                      pts_value_l(jg,19) = pts_value_l(jg,19) + 1.0_wp
2707                   ENDIF
2708
2709                ENDIF
2710
2711             ENDDO
2712
2713          ENDDO
2714       ENDDO
2715    ENDDO
2716
2717
2718#if defined( __parallel )
2719!
2720!-- Sum values of the subdomains
2721    inum = number_of_particle_groups + 1
2722
2723    IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
2724    CALL MPI_ALLREDUCE( pts_value_l(0,1), pts_value(0,1), 15*inum, MPI_REAL, &
2725                        MPI_SUM, comm2d, ierr )
2726    IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
2727    CALL MPI_ALLREDUCE( pts_value_l(0,16), pts_value(0,16), inum, MPI_REAL, &
2728                        MPI_MIN, comm2d, ierr )
2729    IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
2730    CALL MPI_ALLREDUCE( pts_value_l(0,17), pts_value(0,17), inum, MPI_REAL, &
2731                        MPI_MAX, comm2d, ierr )
2732    IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
2733    CALL MPI_ALLREDUCE( pts_value_l(0,18), pts_value(0,18), inum, MPI_REAL, &
2734                        MPI_MAX, comm2d, ierr )
2735    IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
2736    CALL MPI_ALLREDUCE( pts_value_l(0,19), pts_value(0,19), inum, MPI_REAL, &
2737                        MPI_MIN, comm2d, ierr )
2738#else
2739    pts_value(:,1:19) = pts_value_l(:,1:19)
2740#endif
2741
2742!
2743!-- Normalize the above calculated quantities (except min/max values) with the
2744!-- total number of particles
2745    IF ( number_of_particle_groups > 1 )  THEN
2746       inum = number_of_particle_groups
2747    ELSE
2748       inum = 0
2749    ENDIF
2750
2751    DO  j = 0, inum
2752
2753       IF ( pts_value(j,1) > 0.0_wp )  THEN
2754
2755          pts_value(j,2:15) = pts_value(j,2:15) / pts_value(j,1)
2756          IF ( pts_value(j,12) > 0.0_wp  .AND.  pts_value(j,12) < 1.0_wp )  THEN
2757             pts_value(j,13) = pts_value(j,13) / pts_value(j,12)
2758             pts_value(j,14) = pts_value(j,14) / ( 1.0_wp - pts_value(j,12) )
2759          ELSEIF ( pts_value(j,12) == 0.0_wp )  THEN
2760             pts_value(j,13) = -1.0_wp
2761          ELSE
2762             pts_value(j,14) = -1.0_wp
2763          ENDIF
2764
2765       ENDIF
2766
2767    ENDDO
2768
2769!
2770!-- Calculate higher order moments of particle time series quantities,
2771!-- seperately for each particle group (if there is more than one group)
2772    DO  i = nxl, nxr
2773       DO  j = nys, nyn
2774          DO  k = nzb, nzt
2775             number_of_particles = prt_count(k,j,i)
2776             IF (number_of_particles <= 0)  CYCLE
2777             particles => grid_particles(k,j,i)%particles(1:number_of_particles)
2778             DO  n = 1, number_of_particles
2779
2780                pts_value_l(0,20) = pts_value_l(0,20) + ( particles(n)%x - &
2781                                    particles(n)%origin_x - pts_value(0,2) )**2 ! x*2
2782                pts_value_l(0,21) = pts_value_l(0,21) + ( particles(n)%y - &
2783                                    particles(n)%origin_y - pts_value(0,3) )**2 ! y*2
2784                pts_value_l(0,22) = pts_value_l(0,22) + ( particles(n)%z - &
2785                                    particles(n)%origin_z - pts_value(0,4) )**2 ! z*2
2786                pts_value_l(0,23) = pts_value_l(0,23) + ( particles(n)%speed_x - &
2787                                                         pts_value(0,6) )**2   ! u*2
2788                pts_value_l(0,24) = pts_value_l(0,24) + ( particles(n)%speed_y - &
2789                                                          pts_value(0,7) )**2   ! v*2
2790                pts_value_l(0,25) = pts_value_l(0,25) + ( particles(n)%speed_z - &
2791                                                          pts_value(0,8) )**2   ! w*2
2792                pts_value_l(0,26) = pts_value_l(0,26) + ( particles(n)%rvar1 - &
2793                                                          pts_value(0,9) )**2   ! u"2
2794                pts_value_l(0,27) = pts_value_l(0,27) + ( particles(n)%rvar2 - &
2795                                                          pts_value(0,10) )**2  ! v"2
2796                pts_value_l(0,28) = pts_value_l(0,28) + ( particles(n)%rvar3 - &
2797                                                          pts_value(0,11) )**2  ! w"2
2798!
2799!--             Repeat the same for the respective particle group
2800                IF ( number_of_particle_groups > 1 )  THEN
2801                   jg = particles(n)%group
2802
2803                   pts_value_l(jg,20) = pts_value_l(jg,20) + ( particles(n)%x - &
2804                                       particles(n)%origin_x - pts_value(jg,2) )**2
2805                   pts_value_l(jg,21) = pts_value_l(jg,21) + ( particles(n)%y - &
2806                                       particles(n)%origin_y - pts_value(jg,3) )**2
2807                   pts_value_l(jg,22) = pts_value_l(jg,22) + ( particles(n)%z - &
2808                                       particles(n)%origin_z - pts_value(jg,4) )**2
2809                   pts_value_l(jg,23) = pts_value_l(jg,23) + ( particles(n)%speed_x - &
2810                                                             pts_value(jg,6) )**2
2811                   pts_value_l(jg,24) = pts_value_l(jg,24) + ( particles(n)%speed_y - &
2812                                                             pts_value(jg,7) )**2
2813                   pts_value_l(jg,25) = pts_value_l(jg,25) + ( particles(n)%speed_z - &
2814                                                             pts_value(jg,8) )**2
2815                   pts_value_l(jg,26) = pts_value_l(jg,26) + ( particles(n)%rvar1 - &
2816                                                             pts_value(jg,9) )**2
2817                   pts_value_l(jg,27) = pts_value_l(jg,27) + ( particles(n)%rvar2 - &
2818                                                             pts_value(jg,10) )**2
2819                   pts_value_l(jg,28) = pts_value_l(jg,28) + ( particles(n)%rvar3 - &
2820                                                             pts_value(jg,11) )**2
2821                ENDIF
2822
2823             ENDDO
2824          ENDDO
2825       ENDDO
2826    ENDDO
2827
2828    pts_value_l(0,29) = ( number_of_particles - pts_value(0,1) / numprocs )**2
2829                                                 ! variance of particle numbers
2830    IF ( number_of_particle_groups > 1 )  THEN
2831       DO  j = 1, number_of_particle_groups
2832          pts_value_l(j,29) = ( pts_value_l(j,1) - &
2833                                pts_value(j,1) / numprocs )**2
2834       ENDDO
2835    ENDIF
2836
2837#if defined( __parallel )
2838!
2839!-- Sum values of the subdomains
2840    inum = number_of_particle_groups + 1
2841
2842    IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
2843    CALL MPI_ALLREDUCE( pts_value_l(0,20), pts_value(0,20), inum*10, MPI_REAL, &
2844                        MPI_SUM, comm2d, ierr )
2845#else
2846    pts_value(:,20:29) = pts_value_l(:,20:29)
2847#endif
2848
2849!
2850!-- Normalize the above calculated quantities with the total number of
2851!-- particles
2852    IF ( number_of_particle_groups > 1 )  THEN
2853       inum = number_of_particle_groups
2854    ELSE
2855       inum = 0
2856    ENDIF
2857
2858    DO  j = 0, inum
2859
2860       IF ( pts_value(j,1) > 0.0_wp )  THEN
2861          pts_value(j,20:28) = pts_value(j,20:28) / pts_value(j,1)
2862       ENDIF
2863       pts_value(j,29) = pts_value(j,29) / numprocs
2864
2865    ENDDO
2866
2867#if defined( __netcdf )
2868!
2869!-- Output particle time series quantities in NetCDF format
2870    IF ( myid == 0 )  THEN
2871       DO  j = 0, inum
2872          DO  i = 1, dopts_num
2873             nc_stat = NF90_PUT_VAR( id_set_pts, id_var_dopts(i,j),  &
2874                                     (/ pts_value(j,i) /),           &
2875                                     start = (/ dopts_time_count /), &
2876                                     count = (/ 1 /) )
2877             CALL netcdf_handle_error( 'data_output_ptseries', 392 )
2878          ENDDO
2879       ENDDO
2880    ENDIF
2881#endif
2882
2883    DEALLOCATE( pts_value, pts_value_l )
2884
2885    CALL cpu_log( log_point(36), 'data_output_ptseries', 'stop' )
2886
2887END SUBROUTINE lpm_data_output_ptseries
2888
2889 
2890!------------------------------------------------------------------------------!
2891! Description:
2892! ------------
2893!> This routine reads the respective restart data for the lpm.
2894!------------------------------------------------------------------------------!
2895 SUBROUTINE lpm_rrd_local_particles
2896
2897    CHARACTER (LEN=10) ::  particle_binary_version    !<
2898    CHARACTER (LEN=10) ::  version_on_file            !<
2899
2900    INTEGER(iwp) :: alloc_size !<
2901    INTEGER(iwp) :: ip         !<
2902    INTEGER(iwp) :: jp         !<
2903    INTEGER(iwp) :: kp         !<
2904
2905    TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: tmp_particles !<
2906
2907!
2908!-- Read particle data from previous model run.
2909!-- First open the input unit.
2910    IF ( myid_char == '' )  THEN
2911       OPEN ( 90, FILE='PARTICLE_RESTART_DATA_IN'//myid_char,                  &
2912                  FORM='UNFORMATTED' )
2913    ELSE
2914       OPEN ( 90, FILE='PARTICLE_RESTART_DATA_IN/'//myid_char,                 &
2915                  FORM='UNFORMATTED' )
2916    ENDIF
2917
2918!
2919!-- First compare the version numbers
2920    READ ( 90 )  version_on_file
2921    particle_binary_version = '4.0'
2922    IF ( TRIM( version_on_file ) /= TRIM( particle_binary_version ) )  THEN
2923       message_string = 'version mismatch concerning data from prior ' //      &
2924                        'run &version on file = "' //                          &
2925                                      TRIM( version_on_file ) //               &
2926                        '&version in program = "' //                           &
2927                                      TRIM( particle_binary_version ) // '"'
2928       CALL message( 'lpm_read_restart_file', 'PA0214', 1, 2, 0, 6, 0 )
2929    ENDIF
2930
2931!
2932!-- If less particles are stored on the restart file than prescribed by
2933!-- 1, the remainder is initialized by zero_particle to avoid
2934!-- errors.
2935    zero_particle = particle_type( 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp,     &
2936                                   0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp,     &
2937                                   0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp,     &
2938                                   0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp,     &
2939                                   0, 0, 0_idp, .FALSE., -1 )
2940!
2941!-- Read some particle parameters and the size of the particle arrays,
2942!-- allocate them and read their contents.
2943    READ ( 90 )  bc_par_b, bc_par_lr, bc_par_ns, bc_par_t,                     &
2944                 last_particle_release_time, number_of_particle_groups,        &
2945                 particle_groups, time_write_particle_data
2946
2947    ALLOCATE( prt_count(nzb:nzt+1,nysg:nyng,nxlg:nxrg),                        &
2948              grid_particles(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2949
2950    READ ( 90 )  prt_count
2951
2952    DO  ip = nxl, nxr
2953       DO  jp = nys, nyn
2954          DO  kp = nzb+1, nzt
2955
2956             number_of_particles = prt_count(kp,jp,ip)
2957             IF ( number_of_particles > 0 )  THEN
2958                alloc_size = MAX( INT( number_of_particles *                   &
2959                             ( 1.0_wp + alloc_factor / 100.0_wp ) ),           &
2960                             1 )
2961             ELSE
2962                alloc_size = 1
2963             ENDIF
2964
2965             ALLOCATE( grid_particles(kp,jp,ip)%particles(1:alloc_size) )
2966
2967             IF ( number_of_particles > 0 )  THEN
2968                ALLOCATE( tmp_particles(1:number_of_particles) )
2969                READ ( 90 )  tmp_particles
2970                grid_particles(kp,jp,ip)%particles(1:number_of_particles) = tmp_particles
2971                DEALLOCATE( tmp_particles )
2972                IF ( number_of_particles < alloc_size )  THEN
2973                   grid_particles(kp,jp,ip)%particles(number_of_particles+1:alloc_size) &
2974                      = zero_particle
2975                ENDIF
2976             ELSE
2977                grid_particles(kp,jp,ip)%particles(1:alloc_size) = zero_particle
2978             ENDIF
2979
2980          ENDDO
2981       ENDDO
2982    ENDDO
2983
2984    CLOSE ( 90 )
2985!
2986!-- Must be called to sort particles into blocks, which is needed for a fast
2987!-- interpolation of the LES fields on the particle position.
2988    CALL lpm_sort_and_delete
2989
2990
2991 END SUBROUTINE lpm_rrd_local_particles
2992 
2993 
2994 SUBROUTINE lpm_rrd_local( k, nxlf, nxlc, nxl_on_file, nxrf, nxrc,          &
2995                              nxr_on_file, nynf, nync, nyn_on_file, nysf,  &
2996                              nysc, nys_on_file, tmp_3d, found )
2997
2998
2999   USE control_parameters,                                                 &
3000       ONLY: length, restart_string
3001
3002    INTEGER(iwp) ::  k               !<
3003    INTEGER(iwp) ::  nxlc            !<
3004    INTEGER(iwp) ::  nxlf            !<
3005    INTEGER(iwp) ::  nxl_on_file     !<
3006    INTEGER(iwp) ::  nxrc            !<
3007    INTEGER(iwp) ::  nxrf            !<
3008    INTEGER(iwp) ::  nxr_on_file     !<
3009    INTEGER(iwp) ::  nync            !<
3010    INTEGER(iwp) ::  nynf            !<
3011    INTEGER(iwp) ::  nyn_on_file     !<
3012    INTEGER(iwp) ::  nysc            !<
3013    INTEGER(iwp) ::  nysf            !<
3014    INTEGER(iwp) ::  nys_on_file     !<
3015
3016    LOGICAL, INTENT(OUT)  ::  found
3017
3018    REAL(wp), DIMENSION(nzb:nzt+1,nys_on_file-nbgp:nyn_on_file+nbgp,nxl_on_file-nbgp:nxr_on_file+nbgp) :: tmp_3d   !<
3019
3020
3021    found = .TRUE.
3022
3023    SELECT CASE ( restart_string(1:length) )
3024
3025       CASE ( 'iran' ) ! matching random numbers is still unresolved issue
3026          IF ( k == 1 )  READ ( 13 )  iran, iran_part
3027
3028        CASE ( 'pc_av' )
3029           IF ( .NOT. ALLOCATED( pc_av ) )  THEN
3030              ALLOCATE( pc_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
3031           ENDIF
3032           IF ( k == 1 )  READ ( 13 )  tmp_3d
3033           pc_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =          &
3034              tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
3035
3036        CASE ( 'pr_av' )
3037           IF ( .NOT. ALLOCATED( pr_av ) )  THEN
3038              ALLOCATE( pr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
3039           ENDIF
3040           IF ( k == 1 )  READ ( 13 )  tmp_3d
3041           pr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =          &
3042              tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
3043 
3044         CASE ( 'ql_c_av' )
3045            IF ( .NOT. ALLOCATED( ql_c_av ) )  THEN
3046               ALLOCATE( ql_c_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
3047            ENDIF
3048            IF ( k == 1 )  READ ( 13 )  tmp_3d
3049            ql_c_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =        &
3050               tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
3051
3052         CASE ( 'ql_v_av' )
3053            IF ( .NOT. ALLOCATED( ql_v_av ) )  THEN
3054               ALLOCATE( ql_v_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
3055            ENDIF
3056            IF ( k == 1 )  READ ( 13 )  tmp_3d
3057            ql_v_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =        &
3058               tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
3059
3060         CASE ( 'ql_vp_av' )
3061            IF ( .NOT. ALLOCATED( ql_vp_av ) )  THEN
3062               ALLOCATE( ql_vp_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
3063            ENDIF
3064            IF ( k == 1 )  READ ( 13 )  tmp_3d
3065            ql_vp_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =       &
3066               tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
3067
3068          CASE DEFAULT
3069
3070             found = .FALSE.
3071
3072       END SELECT
3073               
3074
3075 END SUBROUTINE lpm_rrd_local
3076 
3077!------------------------------------------------------------------------------!
3078! Description:
3079! ------------
3080!> This routine writes the respective restart data for the lpm.
3081!------------------------------------------------------------------------------!
3082 SUBROUTINE lpm_wrd_local
3083 
3084    CHARACTER (LEN=10) ::  particle_binary_version   !<
3085
3086    INTEGER(iwp) ::  ip                              !<
3087    INTEGER(iwp) ::  jp                              !<
3088    INTEGER(iwp) ::  kp                              !<
3089!
3090!-- First open the output unit.
3091    IF ( myid_char == '' )  THEN
3092       OPEN ( 90, FILE='PARTICLE_RESTART_DATA_OUT'//myid_char, &
3093                  FORM='UNFORMATTED')
3094    ELSE
3095       IF ( myid == 0 )  CALL local_system( 'mkdir PARTICLE_RESTART_DATA_OUT' )
3096#if defined( __parallel )
3097!
3098!--    Set a barrier in order to allow that thereafter all other processors
3099!--    in the directory created by PE0 can open their file
3100       CALL MPI_BARRIER( comm2d, ierr )
3101#endif
3102       OPEN ( 90, FILE='PARTICLE_RESTART_DATA_OUT/'//myid_char, &
3103                  FORM='UNFORMATTED' )
3104    ENDIF
3105
3106!
3107!-- Write the version number of the binary format.
3108!-- Attention: After changes to the following output commands the version
3109!-- ---------  number of the variable particle_binary_version must be
3110!--            changed! Also, the version number and the list of arrays
3111!--            to be read in lpm_read_restart_file must be adjusted
3112!--            accordingly.
3113    particle_binary_version = '4.0'
3114    WRITE ( 90 )  particle_binary_version
3115
3116!
3117!-- Write some particle parameters, the size of the particle arrays
3118    WRITE ( 90 )  bc_par_b, bc_par_lr, bc_par_ns, bc_par_t,                    &
3119                  last_particle_release_time, number_of_particle_groups,       &
3120                  particle_groups, time_write_particle_data
3121
3122    WRITE ( 90 )  prt_count
3123         
3124    DO  ip = nxl, nxr
3125       DO  jp = nys, nyn
3126          DO  kp = nzb+1, nzt
3127             number_of_particles = prt_count(kp,jp,ip)
3128             particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
3129             IF ( number_of_particles <= 0 )  CYCLE
3130             WRITE ( 90 )  particles
3131          ENDDO
3132       ENDDO
3133    ENDDO
3134
3135    CLOSE ( 90 )
3136
3137#if defined( __parallel )
3138       CALL MPI_BARRIER( comm2d, ierr )
3139#endif
3140
3141    CALL wrd_write_string( 'iran' ) 
3142    WRITE ( 14 )  iran, iran_part
3143
3144
3145 END SUBROUTINE lpm_wrd_local
3146
3147
3148!------------------------------------------------------------------------------!
3149! Description:
3150! ------------
3151!> This routine writes the respective restart data for the lpm.
3152!------------------------------------------------------------------------------!
3153 SUBROUTINE lpm_wrd_global
3154 
3155    CALL wrd_write_string( 'curvature_solution_effects' ) 
3156    WRITE ( 14 )  curvature_solution_effects
3157
3158    CALL wrd_write_string( 'interpolation_simple_corrector' )
3159    WRITE ( 14 )  interpolation_simple_corrector
3160
3161    CALL wrd_write_string( 'interpolation_simple_predictor' )
3162    WRITE ( 14 )  interpolation_simple_predictor
3163
3164    CALL wrd_write_string( 'interpolation_trilinear' )
3165    WRITE ( 14 )  interpolation_trilinear
3166
3167 END SUBROUTINE lpm_wrd_global
3168 
3169
3170!------------------------------------------------------------------------------!
3171! Description:
3172! ------------
3173!> This routine writes the respective restart data for the lpm.
3174!------------------------------------------------------------------------------!
3175 SUBROUTINE lpm_rrd_global( found )
3176 
3177    USE control_parameters,                            &
3178        ONLY: length, restart_string
3179
3180    LOGICAL, INTENT(OUT)  ::  found
3181
3182    found = .TRUE.
3183
3184    SELECT CASE ( restart_string(1:length) )
3185
3186       CASE ( 'curvature_solution_effects' )
3187          READ ( 13 )  curvature_solution_effects
3188
3189       CASE ( 'interpolation_simple_corrector' )
3190          READ ( 13 )  interpolation_simple_corrector
3191
3192       CASE ( 'interpolation_simple_predictor' )
3193          READ ( 13 )  interpolation_simple_predictor
3194
3195       CASE ( 'interpolation_trilinear' )
3196          READ ( 13 )  interpolation_trilinear
3197
3198!          CASE ( 'global_paramter' )
3199!             READ ( 13 )  global_parameter
3200!          CASE ( 'global_array' )
3201!             IF ( .NOT. ALLOCATED( global_array ) )  ALLOCATE( global_array(1:10) )
3202!             READ ( 13 )  global_array
3203
3204       CASE DEFAULT
3205
3206          found = .FALSE.
3207
3208    END SELECT
3209   
3210 END SUBROUTINE lpm_rrd_global
3211
3212
3213!------------------------------------------------------------------------------!
3214! Description:
3215! ------------
3216!> This is a submodule of the lagrangian particle model. It contains all
3217!> dynamic processes of the lpm. This includes the advection (resolved and sub-
3218!> grid scale) as well as the boundary conditions of particles. As a next step
3219!> this submodule should be excluded as an own file.
3220!------------------------------------------------------------------------------!
3221 SUBROUTINE lpm_advec (ip,jp,kp)
3222
3223    LOGICAL ::  subbox_at_wall !< flag to see if the current subgridbox is adjacent to a wall
3224
3225    INTEGER(iwp) ::  i                           !< index variable along x
3226    INTEGER(iwp) ::  i_next                      !< index variable along x
3227    INTEGER(iwp) ::  ip                          !< index variable along x
3228    INTEGER(iwp) ::  iteration_steps = 1         !< amount of iterations steps for corrector step
3229    INTEGER(iwp) ::  j                           !< index variable along y
3230    INTEGER(iwp) ::  j_next                      !< index variable along y
3231    INTEGER(iwp) ::  jp                          !< index variable along y
3232    INTEGER(iwp) ::  k                           !< index variable along z
3233    INTEGER(iwp) ::  k_wall                      !< vertical index of topography top
3234    INTEGER(iwp) ::  kp                          !< index variable along z
3235    INTEGER(iwp) ::  k_next                      !< index variable along z
3236    INTEGER(iwp) ::  kw                          !< index variable along z
3237    INTEGER(iwp) ::  kkw                         !< index variable along z
3238    INTEGER(iwp) ::  n                           !< loop variable over all particles in a grid box
3239    INTEGER(iwp) ::  nb                          !< block number particles are sorted in
3240    INTEGER(iwp) ::  particle_end                !< end index for partilce loop
3241    INTEGER(iwp) ::  particle_start              !< start index for particle loop
3242    INTEGER(iwp) ::  surf_start                  !< Index on surface data-type for current grid box
3243    INTEGER(iwp) ::  subbox_end                  !< end index for loop over subboxes in particle advection
3244    INTEGER(iwp) ::  subbox_start                !< start index for loop over subboxes in particle advection
3245    INTEGER(iwp) ::  nn                          !< loop variable over iterations steps
3246
3247    INTEGER(iwp), DIMENSION(0:7) ::  start_index !< start particle index for current block
3248    INTEGER(iwp), DIMENSION(0:7) ::  end_index   !< start particle index for current block
3249
3250    REAL(wp) ::  aa                 !< dummy argument for horizontal particle interpolation
3251    REAL(wp) ::  alpha              !< interpolation facor for x-direction
3252
3253    REAL(wp) ::  bb                 !< dummy argument for horizontal particle interpolation
3254    REAL(wp) ::  beta               !< interpolation facor for y-direction
3255    REAL(wp) ::  cc                 !< dummy argument for horizontal particle interpolation
3256    REAL(wp) ::  d_z_p_z0           !< inverse of interpolation length for logarithmic interpolation
3257    REAL(wp) ::  dd                 !< dummy argument for horizontal particle interpolation
3258    REAL(wp) ::  de_dx_int_l        !< x/y-interpolated TKE gradient (x) at particle position at lower vertical level
3259    REAL(wp) ::  de_dx_int_u        !< x/y-interpolated TKE gradient (x) at particle position at upper vertical level
3260    REAL(wp) ::  de_dy_int_l        !< x/y-interpolated TKE gradient (y) at particle position at lower vertical level
3261    REAL(wp) ::  de_dy_int_u        !< x/y-interpolated TKE gradient (y) at particle position at upper vertical level
3262    REAL(wp) ::  de_dt              !< temporal derivative of TKE experienced by the particle
3263    REAL(wp) ::  de_dt_min          !< lower level for temporal TKE derivative
3264    REAL(wp) ::  de_dz_int_l        !< x/y-interpolated TKE gradient (z) at particle position at lower vertical level
3265    REAL(wp) ::  de_dz_int_u        !< x/y-interpolated TKE gradient (z) at particle position at upper vertical level
3266    REAL(wp) ::  diameter           !< diamter of droplet
3267    REAL(wp) ::  diss_int_l         !< x/y-interpolated dissipation at particle position at lower vertical level
3268    REAL(wp) ::  diss_int_u         !< x/y-interpolated dissipation at particle position at upper vertical level
3269    REAL(wp) ::  dt_particle_m      !< previous particle time step
3270    REAL(wp) ::  dz_temp            !< dummy for the vertical grid spacing
3271    REAL(wp) ::  e_int_l            !< x/y-interpolated TKE at particle position at lower vertical level
3272    REAL(wp) ::  e_int_u            !< x/y-interpolated TKE at particle position at upper vertical level
3273    REAL(wp) ::  e_mean_int         !< horizontal mean TKE at particle height
3274    REAL(wp) ::  exp_arg            !< argument in the exponent - particle radius
3275    REAL(wp) ::  exp_term           !< exponent term
3276    REAL(wp) ::  gamma              !< interpolation facor for z-direction
3277    REAL(wp) ::  gg                 !< dummy argument for horizontal particle interpolation
3278    REAL(wp) ::  height_p           !< dummy argument for logarithmic interpolation
3279    REAL(wp) ::  log_z_z0_int       !< logarithmus used for surface_layer interpolation
3280    REAL(wp) ::  random_gauss       !< Gaussian-distributed random number used for SGS particle advection
3281    REAL(wp) ::  RL                 !< Lagrangian autocorrelation coefficient
3282    REAL(wp) ::  rg1                !< Gaussian distributed random number
3283    REAL(wp) ::  rg2                !< Gaussian distributed random number
3284    REAL(wp) ::  rg3                !< Gaussian distributed random number
3285    REAL(wp) ::  sigma              !< velocity standard deviation
3286    REAL(wp) ::  u_int_l            !< x/y-interpolated u-component at particle position at lower vertical level
3287    REAL(wp) ::  u_int_u            !< x/y-interpolated u-component at particle position at upper vertical level
3288    REAL(wp) ::  unext              !< calculated particle u-velocity of corrector step
3289    REAL(wp) ::  us_int             !< friction velocity at particle grid box
3290    REAL(wp) ::  usws_int           !< surface momentum flux (u component) at particle grid box
3291    REAL(wp) ::  v_int_l            !< x/y-interpolated v-component at particle position at lower vertical level
3292    REAL(wp) ::  v_int_u            !< x/y-interpolated v-component at particle position at upper vertical level
3293    REAL(wp) ::  vsws_int           !< surface momentum flux (u component) at particle grid box
3294    REAL(wp) ::  vnext              !< calculated particle v-velocity of corrector step
3295    REAL(wp) ::  vv_int             !< dummy to compute interpolated mean SGS TKE, used to scale SGS advection
3296    REAL(wp) ::  w_int_l            !< x/y-interpolated w-component at particle position at lower vertical level
3297    REAL(wp) ::  w_int_u            !< x/y-interpolated w-component at particle position at upper vertical level
3298    REAL(wp) ::  wnext              !< calculated particle w-velocity of corrector step
3299    REAL(wp) ::  w_s                !< terminal velocity of droplets
3300    REAL(wp) ::  x                  !< dummy argument for horizontal particle interpolation
3301    REAL(wp) ::  xp                 !< calculated particle position in x of predictor step
3302    REAL(wp) ::  y                  !< dummy argument for horizontal particle interpolation
3303    REAL(wp) ::  yp                 !< calculated particle position in y of predictor step
3304    REAL(wp) ::  z_p                !< surface layer height (0.5 dz)
3305    REAL(wp) ::  zp                 !< calculated particle position in z of predictor step
3306
3307    REAL(wp), PARAMETER ::  a_rog = 9.65_wp      !< parameter for fall velocity
3308    REAL(wp), PARAMETER ::  b_rog = 10.43_wp     !< parameter for fall velocity
3309    REAL(wp), PARAMETER ::  c_rog = 0.6_wp       !< parameter for fall velocity
3310    REAL(wp), PARAMETER ::  k_cap_rog = 4.0_wp   !< parameter for fall velocity
3311    REAL(wp), PARAMETER ::  k_low_rog = 12.0_wp  !< parameter for fall velocity
3312    REAL(wp), PARAMETER ::  d0_rog = 0.745_wp    !< separation diameter
3313
3314    REAL(wp), DIMENSION(number_of_particles) ::  term_1_2       !< flag to communicate whether a particle is near topography or not
3315    REAL(wp), DIMENSION(number_of_particles) ::  dens_ratio     !< ratio between the density of the fluid and the density of the particles
3316    REAL(wp), DIMENSION(number_of_particles) ::  de_dx_int      !< horizontal TKE gradient along x at particle position
3317    REAL(wp), DIMENSION(number_of_particles) ::  de_dy_int      !< horizontal TKE gradient along y at particle position
3318    REAL(wp), DIMENSION(number_of_particles) ::  de_dz_int      !< horizontal TKE gradient along z at particle position
3319    REAL(wp), DIMENSION(number_of_particles) ::  diss_int       !< dissipation at particle position
3320    REAL(wp), DIMENSION(number_of_particles) ::  dt_gap         !< remaining time until particle time integration reaches LES time
3321    REAL(wp), DIMENSION(number_of_particles) ::  dt_particle    !< particle time step
3322    REAL(wp), DIMENSION(number_of_particles) ::  e_int          !< TKE at particle position
3323    REAL(wp), DIMENSION(number_of_particles) ::  fs_int         !< weighting factor for subgrid-scale particle speed
3324    REAL(wp), DIMENSION(number_of_particles) ::  lagr_timescale !< Lagrangian timescale
3325    REAL(wp), DIMENSION(number_of_particles) ::  rvar1_temp     !< SGS particle velocity - u-component
3326    REAL(wp), DIMENSION(number_of_particles) ::  rvar2_temp     !< SGS particle velocity - v-component
3327    REAL(wp), DIMENSION(number_of_particles) ::  rvar3_temp     !< SGS particle velocity - w-component
3328    REAL(wp), DIMENSION(number_of_particles) ::  u_int          !< u-component of particle speed
3329    REAL(wp), DIMENSION(number_of_particles) ::  v_int          !< v-component of particle speed
3330    REAL(wp), DIMENSION(number_of_particles) ::  w_int          !< w-component of particle speed
3331    REAL(wp), DIMENSION(number_of_particles) ::  xv             !< x-position
3332    REAL(wp), DIMENSION(number_of_particles) ::  yv             !< y-position
3333    REAL(wp), DIMENSION(number_of_particles) ::  zv             !< z-position
3334
3335    REAL(wp), DIMENSION(number_of_particles, 3) ::  rg !< vector of Gaussian distributed random numbers
3336
3337    CALL cpu_log( log_point_s(44), 'lpm_advec', 'continue' )
3338!
3339!-- Determine height of Prandtl layer and distance between Prandtl-layer
3340!-- height and horizontal mean roughness height, which are required for
3341!-- vertical logarithmic interpolation of horizontal particle speeds
3342!-- (for particles below first vertical grid level).
3343    z_p      = zu(nzb+1) - zw(nzb)
3344    d_z_p_z0 = 1.0_wp / ( z_p - z0_av_global )
3345
3346    xv = particles(1:number_of_particles)%x
3347    yv = particles(1:number_of_particles)%y
3348    zv = particles(1:number_of_particles)%z
3349    dt_particle = dt_3d
3350
3351!
3352!-- This case uses a simple interpolation method for the particle velocites,
3353!-- and applying a predictor-corrector method. @attention: for the corrector
3354!-- step the velocities of t(n+1) are required. However, at this moment of
3355!-- the time integration they are not free of divergence. This interpolation
3356!-- method is described in more detail in Grabowski et al., 2018 (GMD).
3357    IF ( interpolation_simple_corrector )  THEN
3358!
3359!--    Predictor step
3360       kkw = kp - 1
3361       DO n = 1, number_of_particles
3362
3363          alpha = MAX( MIN( ( particles(n)%x - ip * dx ) * ddx, 1.0_wp ), 0.0_wp )
3364          u_int(n) = u(kp,jp,ip) * ( 1.0_wp - alpha ) + u(kp,jp,ip+1) * alpha
3365
3366          beta  = MAX( MIN( ( particles(n)%y - jp * dy ) * ddy, 1.0_wp ), 0.0_wp )
3367          v_int(n) = v(kp,jp,ip) * ( 1.0_wp - beta ) + v(kp,jp+1,ip) * beta
3368
3369          gamma = MAX( MIN( ( particles(n)%z - zw(kkw) ) /                   &
3370                            ( zw(kkw+1) - zw(kkw) ), 1.0_wp ), 0.0_wp )
3371          w_int(n) = w(kkw,jp,ip) * ( 1.0_wp - gamma ) + w(kkw+1,jp,ip) * gamma
3372
3373       ENDDO
3374!
3375!--    Corrector step
3376       DO n = 1, number_of_particles
3377
3378          IF ( .NOT. particles(n)%particle_mask )  CYCLE
3379
3380          DO nn = 1, iteration_steps
3381
3382!
3383!--          Guess new position
3384             xp = particles(n)%x + u_int(n) * dt_particle(n)
3385             yp = particles(n)%y + v_int(n) * dt_particle(n)
3386             zp = particles(n)%z + w_int(n) * dt_particle(n)
3387!
3388!--          x direction
3389             i_next = FLOOR( xp * ddx , KIND=iwp)
3390             alpha  = MAX( MIN( ( xp - i_next * dx ) * ddx, 1.0_wp ), 0.0_wp )
3391!
3392!--          y direction
3393             j_next = FLOOR( yp * ddy )
3394             beta   = MAX( MIN( ( yp - j_next * dy ) * ddy, 1.0_wp ), 0.0_wp )
3395!
3396!--          z_direction
3397             k_next = MAX( MIN( FLOOR( zp / (zw(kkw+1)-zw(kkw)) ), nzt ), 0)
3398             gamma = MAX( MIN( ( zp - zw(k_next) ) /                      &
3399                               ( zw(k_next+1) - zw(k_next) ), 1.0_wp ), 0.0_wp )
3400!
3401!--          Calculate part of the corrector step
3402             unext = u_p(k_next+1, j_next, i_next) * ( 1.0_wp - alpha ) +    &
3403                     u_p(k_next+1, j_next,   i_next+1) * alpha
3404
3405             vnext = v_p(k_next+1, j_next, i_next) * ( 1.0_wp - beta  ) +    &
3406                     v_p(k_next+1, j_next+1, i_next  ) * beta
3407
3408             wnext = w_p(k_next,   j_next, i_next) * ( 1.0_wp - gamma ) +    &
3409                     w_p(k_next+1, j_next, i_next  ) * gamma
3410
3411!
3412!--          Calculate interpolated particle velocity with predictor
3413!--          corrector step. u_int, v_int and w_int describes the part of
3414!--          the predictor step. unext, vnext and wnext is the part of the
3415!--          corrector step. The resulting new position is set below. The
3416!--          implementation is based on Grabowski et al., 2018 (GMD).
3417             u_int(n) = 0.5_wp * ( u_int(n) + unext )
3418             v_int(n) = 0.5_wp * ( v_int(n) + vnext )
3419             w_int(n) = 0.5_wp * ( w_int(n) + wnext )
3420
3421          ENDDO
3422       ENDDO
3423!
3424!-- This case uses a simple interpolation method for the particle velocites,
3425!-- and applying a predictor.
3426    ELSEIF ( interpolation_simple_predictor )  THEN
3427!
3428!--    The particle position for the w velociy is based on the value of kp and kp-1
3429       kkw = kp - 1
3430       DO n = 1, number_of_particles
3431          IF ( .NOT. particles(n)%particle_mask )  CYCLE
3432
3433          alpha    = MAX( MIN( ( particles(n)%x - ip * dx ) * ddx, 1.0_wp ), 0.0_wp )
3434          u_int(n) = u(kp,jp,ip) * ( 1.0_wp - alpha ) + u(kp,jp,ip+1) * alpha
3435
3436          beta     = MAX( MIN( ( particles(n)%y - jp * dy ) * ddy, 1.0_wp ), 0.0_wp )
3437          v_int(n) = v(kp,jp,ip) * ( 1.0_wp - beta ) + v(kp,jp+1,ip) * beta
3438
3439          gamma    = MAX( MIN( ( particles(n)%z - zw(kkw) ) /                   &
3440                               ( zw(kkw+1) - zw(kkw) ), 1.0_wp ), 0.0_wp )
3441          w_int(n) = w(kkw,jp,ip) * ( 1.0_wp - gamma ) + w(kkw+1,jp,ip) * gamma
3442       ENDDO
3443!
3444!-- The trilinear interpolation.
3445    ELSEIF ( interpolation_trilinear )  THEN
3446
3447       start_index = grid_particles(kp,jp,ip)%start_index
3448       end_index   = grid_particles(kp,jp,ip)%end_index
3449
3450       DO  nb = 0, 7
3451!
3452!--       Interpolate u velocity-component
3453          i = ip
3454          j = jp + block_offset(nb)%j_off
3455          k = kp + block_offset(nb)%k_off
3456
3457          DO  n = start_index(nb), end_index(nb)
3458!
3459!--          Interpolation of the u velocity component onto particle position.
3460!--          Particles are interpolation bi-linearly in the horizontal and a
3461!--          linearly in the vertical. An exception is made for particles below
3462!--          the first vertical grid level in case of a prandtl layer. In this
3463!--          case the horizontal particle velocity components are determined using
3464!--          Monin-Obukhov relations (if branch).
3465!--          First, check if particle is located below first vertical grid level
3466!--          above topography (Prandtl-layer height)
3467!--          Determine vertical index of topography top
3468             k_wall = get_topography_top_index_ji( jp, ip, 's' )
3469
3470             IF ( constant_flux_layer  .AND.  zv(n) - zw(k_wall) < z_p )  THEN
3471!
3472!--             Resolved-scale horizontal particle velocity is zero below z0.
3473                IF ( zv(n) - zw(k_wall) < z0_av_global )  THEN
3474                   u_int(n) = 0.0_wp
3475                ELSE
3476!
3477!--                Determine the sublayer. Further used as index.
3478                   height_p = ( zv(n) - zw(k_wall) - z0_av_global ) &
3479                                        * REAL( number_of_sublayers, KIND=wp )    &
3480                                        * d_z_p_z0
3481!
3482!--                Calculate LOG(z/z0) for exact particle height. Therefore,
3483!--                interpolate linearly between precalculated logarithm.
3484                   log_z_z0_int = log_z_z0(INT(height_p))                         &
3485                                    + ( height_p - INT(height_p) )                &
3486                                    * ( log_z_z0(INT(height_p)+1)                 &
3487                                         - log_z_z0(INT(height_p))                &
3488                                      )
3489!
3490!--                Get friction velocity and momentum flux from new surface data
3491!--                types.
3492                   IF ( surf_def_h(0)%start_index(jp,ip) <=                   &
3493                        surf_def_h(0)%end_index(jp,ip) )  THEN
3494                      surf_start = surf_def_h(0)%start_index(jp,ip)
3495!--                   Limit friction velocity. In narrow canyons or holes the
3496!--                   friction velocity can become very small, resulting in a too
3497!--                   large particle speed.
3498                      us_int    = MAX( surf_def_h(0)%us(surf_start), 0.01_wp )
3499                      usws_int  = surf_def_h(0)%usws(surf_start)
3500                   ELSEIF ( surf_lsm_h%start_index(jp,ip) <=                  &
3501                            surf_lsm_h%end_index(jp,ip) )  THEN
3502                      surf_start = surf_lsm_h%start_index(jp,ip)
3503                      us_int    = MAX( surf_lsm_h%us(surf_start), 0.01_wp )
3504                      usws_int  = surf_lsm_h%usws(surf_start)
3505                   ELSEIF ( surf_usm_h%start_index(jp,ip) <=                  &
3506                            surf_usm_h%end_index(jp,ip) )  THEN
3507                      surf_start = surf_usm_h%start_index(jp,ip)
3508                      us_int    = MAX( surf_usm_h%us(surf_start), 0.01_wp )
3509                      usws_int  = surf_usm_h%usws(surf_start)
3510                   ENDIF
3511!
3512!--                Neutral solution is applied for all situations, e.g. also for
3513!--                unstable and stable situations. Even though this is not exact
3514!--                this saves a lot of CPU time since several calls of intrinsic
3515!--                FORTRAN procedures (LOG, ATAN) are avoided, This is justified
3516!--                as sensitivity studies revealed no significant effect of
3517!--                using the neutral solution also for un/stable situations.
3518                   u_int(n) = -usws_int / ( us_int * kappa + 1E-10_wp )           &
3519                               * log_z_z0_int - u_gtrans
3520                ENDIF
3521!
3522!--          Particle above the first grid level. Bi-linear interpolation in the
3523!--          horizontal and linear interpolation in the vertical direction.
3524             ELSE
3525                = xv(n) - i * dx
3526                y  = yv(n) + ( 0.5_wp - j ) * dy
3527                aa = x**2          + y**2
3528                bb = ( dx - x )**2 + y**2
3529                cc = x**2          + ( dy - y )**2
3530                dd = ( dx - x )**2 + ( dy - y )**2
3531                gg = aa + bb + cc + dd
3532
3533                u_int_l = ( ( gg - aa ) * u(k,j,i)   + ( gg - bb ) * u(k,j,i+1)   &
3534                            + ( gg - cc ) * u(k,j+1,i) + ( gg - dd ) *            &
3535                            u(k,j+1,i+1) ) / ( 3.0_wp * gg ) - u_gtrans
3536
3537                IF ( k == nzt )  THEN
3538                   u_int(n) = u_int_l
3539                ELSE
3540                   u_int_u = ( ( gg-aa ) * u(k+1,j,i) + ( gg-bb ) * u(k+1,j,i+1)  &
3541                               + ( gg-cc ) * u(k+1,j+1,i) + ( gg-dd ) *           &
3542                               u(k+1,j+1,i+1) ) / ( 3.0_wp * gg ) - u_gtrans
3543                   u_int(n) = u_int_l + ( zv(n) - zu(k) ) / dzw(k+1) *            &
3544                              ( u_int_u - u_int_l )
3545                ENDIF
3546             ENDIF
3547          ENDDO
3548!
3549!--       Same procedure for interpolation of the v velocity-component
3550          i = ip + block_offset(nb)%i_off
3551          j = jp
3552          k = kp + block_offset(nb)%k_off
3553
3554          DO  n = start_index(nb), end_index(nb)
3555!
3556!--          Determine vertical index of topography top
3557             k_wall = get_topography_top_index_ji( jp,ip, 's' )
3558
3559             IF ( constant_flux_layer  .AND.  zv(n) - zw(k_wall) < z_p )  THEN
3560                IF ( zv(n) - zw(k_wall) < z0_av_global )  THEN
3561!
3562!--                Resolved-scale horizontal particle velocity is zero below z0.
3563                   v_int(n) = 0.0_wp
3564                ELSE
3565!
3566!--                Determine the sublayer. Further used as index. Please note,
3567!--                logarithmus can not be reused from above, as in in case of
3568!--                topography particle on u-grid can be above surface-layer height,
3569!--                whereas it can be below on v-grid.
3570                   height_p = ( zv(n) - zw(k_wall) - z0_av_global ) &
3571                                     * REAL( number_of_sublayers, KIND=wp )       &
3572                                     * d_z_p_z0
3573!
3574!--                Calculate LOG(z/z0) for exact particle height. Therefore,
3575!--                interpolate linearly between precalculated logarithm.
3576                   log_z_z0_int = log_z_z0(INT(height_p))                         &
3577                                    + ( height_p - INT(height_p) )                &
3578                                    * ( log_z_z0(INT(height_p)+1)                 &
3579                                         - log_z_z0(INT(height_p))                &
3580                                      )
3581!
3582!--                Get friction velocity and momentum flux from new surface data
3583!--                types.
3584                   IF ( surf_def_h(0)%start_index(jp,ip) <=                   &
3585                        surf_def_h(0)%end_index(jp,ip) )  THEN
3586                      surf_start = surf_def_h(0)%start_index(jp,ip)
3587!--                   Limit friction velocity. In narrow canyons or holes the
3588!--                   friction velocity can become very small, resulting in a too
3589!--                   large particle speed.
3590                      us_int    = MAX( surf_def_h(0)%us(surf_start), 0.01_wp )
3591                      vsws_int  = surf_def_h(0)%vsws(surf_start)
3592                   ELSEIF ( surf_lsm_h%start_index(jp,ip) <=                  &
3593                            surf_lsm_h%end_index(jp,ip) )  THEN
3594                      surf_start = surf_lsm_h%start_index(jp,ip)
3595                      us_int    = MAX( surf_lsm_h%us(surf_start), 0.01_wp )
3596                      vsws_int  = surf_lsm_h%vsws(surf_start)
3597                   ELSEIF ( surf_usm_h%start_index(jp,ip) <=                  &
3598                            surf_usm_h%end_index(jp,ip) )  THEN
3599                      surf_start = surf_usm_h%start_index(jp,ip)
3600                      us_int    = MAX( surf_usm_h%us(surf_start), 0.01_wp )
3601                      vsws_int  = surf_usm_h%vsws(surf_start)
3602                   ENDIF
3603!
3604!--                Neutral solution is applied for all situations, e.g. also for
3605!--                unstable and stable situations. Even though this is not exact
3606!--                this saves a lot of CPU time since several calls of intrinsic
3607!--                FORTRAN procedures (LOG, ATAN) are avoided, This is justified
3608!--                as sensitivity studies revealed no significant effect of
3609!--                using the neutral solution also for un/stable situations.
3610                   v_int(n) = -vsws_int / ( us_int * kappa + 1E-10_wp )           &
3611                            * log_z_z0_int - v_gtrans
3612
3613                ENDIF
3614             ELSE
3615                = xv(n) + ( 0.5_wp - i ) * dx
3616                y  = yv(n) - j * dy
3617                aa = x**2          + y**2
3618                bb = ( dx - x )**2 + y**2
3619                cc = x**2          + ( dy - y )**2
3620                dd = ( dx - x )**2 + ( dy - y )**2
3621                gg = aa + bb + cc + dd
3622
3623                v_int_l = ( ( gg - aa ) * v(k,j,i)   + ( gg - bb ) * v(k,j,i+1)   &
3624                          + ( gg - cc ) * v(k,j+1,i) + ( gg - dd ) * v(k,j+1,i+1) &
3625                          ) / ( 3.0_wp * gg ) - v_gtrans
3626
3627                IF ( k == nzt )  THEN
3628                   v_int(n) = v_int_l
3629                ELSE
3630                   v_int_u = ( ( gg-aa ) * v(k+1,j,i)   + ( gg-bb ) * v(k+1,j,i+1)   &
3631                             + ( gg-cc ) * v(k+1,j+1,i) + ( gg-dd ) * v(k+1,j+1,i+1) &
3632                             ) / ( 3.0_wp * gg ) - v_gtrans
3633                   v_int(n) = v_int_l + ( zv(n) - zu(k) ) / dzw(k+1) *               &
3634                                     ( v_int_u - v_int_l )
3635                ENDIF
3636             ENDIF
3637          ENDDO
3638!
3639!--       Same procedure for interpolation of the w velocity-component
3640          i = ip + block_offset(nb)%i_off
3641          j = jp + block_offset(nb)%j_off
3642          k = kp - 1
3643
3644          DO  n = start_index(nb), end_index(nb)
3645             IF ( vertical_particle_advection(particles(n)%group) )  THEN
3646                = xv(n) + ( 0.5_wp - i ) * dx
3647                y  = yv(n) + ( 0.5_wp - j ) * dy
3648                aa = x**2          + y**2
3649                bb = ( dx - x )**2 + y**2
3650                cc = x**2          + ( dy - y )**2
3651                dd = ( dx - x )**2 + ( dy - y )**2
3652                gg = aa + bb + cc + dd
3653
3654                w_int_l = ( ( gg - aa ) * w(k,j,i)   + ( gg - bb ) * w(k,j,i+1)   &
3655                          + ( gg - cc ) * w(k,j+1,i) + ( gg - dd ) * w(k,j+1,i+1) &
3656                          ) / ( 3.0_wp * gg )
3657
3658                IF ( k == nzt )  THEN
3659                   w_int(n) = w_int_l
3660                ELSE
3661                   w_int_u = ( ( gg-aa ) * w(k+1,j,i)   + &
3662                               ( gg-bb ) * w(k+1,j,i+1) + &
3663                               ( gg-cc ) * w(k+1,j+1,i) + &
3664                               ( gg-dd ) * w(k+1,j+1,i+1) &
3665                             ) / ( 3.0_wp * gg )
3666                   w_int(n) = w_int_l + ( zv(n) - zw(k) ) / dzw(k+1) *               &
3667                              ( w_int_u - w_int_l )
3668                ENDIF
3669             ELSE
3670                w_int(n) = 0.0_wp
3671             ENDIF
3672          ENDDO
3673       ENDDO
3674    ENDIF
3675
3676!-- Interpolate and calculate quantities needed for calculating the SGS
3677!-- velocities
3678    IF ( use_sgs_for_particles  .AND.  .NOT. cloud_droplets )  THEN
3679
3680       DO  nb = 0,7
3681
3682          subbox_at_wall = .FALSE.
3683!
3684!--       In case of topography check if subbox is adjacent to a wall
3685          IF ( .NOT. topography == 'flat' )  THEN
3686             i = ip + MERGE( -1_iwp , 1_iwp, BTEST( nb, 2 ) )
3687             j = jp + MERGE( -1_iwp , 1_iwp, BTEST( nb, 1 ) )
3688             k = kp + MERGE( -1_iwp , 1_iwp, BTEST( nb, 0 ) )
3689             IF ( .NOT. BTEST(wall_flags_0(k,  jp, ip), 0) .OR.                &
3690                  .NOT. BTEST(wall_flags_0(kp, j,  ip), 0) .OR.                &
3691                  .NOT. BTEST(wall_flags_0(kp, jp, i ), 0) )                   &
3692             THEN
3693                subbox_at_wall = .TRUE.
3694             ENDIF
3695          ENDIF
3696          IF ( subbox_at_wall )  THEN
3697             e_int(start_index(nb):end_index(nb))     = e(kp,jp,ip) 
3698             diss_int(start_index(nb):end_index(nb))  = diss(kp,jp,ip)
3699             de_dx_int(start_index(nb):end_index(nb)) = de_dx(kp,jp,ip)
3700             de_dy_int(start_index(nb):end_index(nb)) = de_dy(kp,jp,ip)
3701             de_dz_int(start_index(nb):end_index(nb)) = de_dz(kp,jp,ip)
3702!
3703!--          Set flag for stochastic equation.
3704             term_1_2(start_index(nb):end_index(nb)) = 0.0_wp
3705          ELSE
3706             i = ip + block_offset(nb)%i_off
3707             j = jp + block_offset(nb)%j_off
3708             k = kp + block_offset(nb)%k_off
3709
3710             DO  n = start_index(nb), end_index(nb)
3711!
3712!--             Interpolate TKE
3713                x  = xv(n) + ( 0.5_wp - i ) * dx
3714                y  = yv(n) + ( 0.5_wp - j ) * dy
3715                aa = x**2          + y**2
3716                bb = ( dx - x )**2 + y**2
3717                cc = x**2          + ( dy - y )**2
3718                dd = ( dx - x )**2 + ( dy - y )**2
3719                gg = aa + bb + cc + dd
3720
3721                e_int_l = ( ( gg-aa ) * e(k,j,i)   + ( gg-bb ) * e(k,j,i+1)   &
3722                          + ( gg-cc ) * e(k,j+1,i) + ( gg-dd ) * e(k,j+1,i+1) &
3723                          ) / ( 3.0_wp * gg )
3724
3725                IF ( k+1 == nzt+1 )  THEN
3726                   e_int(n) = e_int_l
3727                ELSE
3728                   e_int_u = ( ( gg - aa ) * e(k+1,j,i)   + &
3729                               ( gg - bb ) * e(k+1,j,i+1) + &
3730                               ( gg - cc ) * e(k+1,j+1,i) + &
3731                               ( gg - dd ) * e(k+1,j+1,i+1) &
3732                            ) / ( 3.0_wp * gg )
3733                   e_int(n) = e_int_l + ( zv(n) - zu(k) ) / dzw(k+1) *            &
3734                                     ( e_int_u - e_int_l )
3735                ENDIF
3736!
3737!--             Needed to avoid NaN particle velocities (this might not be
3738!--             required any more)
3739                IF ( e_int(n) <= 0.0_wp )  THEN
3740                   e_int(n) = 1.0E-20_wp
3741                ENDIF
3742!
3743!--             Interpolate the TKE gradient along x (adopt incides i,j,k and
3744!--             all position variables from above (TKE))
3745                de_dx_int_l = ( ( gg - aa ) * de_dx(k,j,i)   + &
3746                                ( gg - bb ) * de_dx(k,j,i+1) + &
3747                                ( gg - cc ) * de_dx(k,j+1,i) + &
3748                                ( gg - dd ) * de_dx(k,j+1,i+1) &
3749                               ) / ( 3.0_wp * gg )
3750
3751                IF ( ( k+1 == nzt+1 )  .OR.  ( k == nzb ) )  THEN
3752                   de_dx_int(n) = de_dx_int_l
3753                ELSE
3754                   de_dx_int_u = ( ( gg - aa ) * de_dx(k+1,j,i)   + &
3755                                   ( gg - bb ) * de_dx(k+1,j,i+1) + &
3756                                   ( gg - cc ) * de_dx(k+1,j+1,i) + &
3757                                   ( gg - dd ) * de_dx(k+1,j+1,i+1) &
3758                                  ) / ( 3.0_wp * gg )
3759                   de_dx_int(n) = de_dx_int_l + ( zv(n) - zu(k) ) / dzw(k+1) *    &
3760                                              ( de_dx_int_u - de_dx_int_l )
3761                ENDIF
3762!
3763!--             Interpolate the TKE gradient along y
3764                de_dy_int_l = ( ( gg - aa ) * de_dy(k,j,i)   + &
3765                                ( gg - bb ) * de_dy(k,j,i+1) + &
3766                                ( gg - cc ) * de_dy(k,j+1,i) + &
3767                                ( gg - dd ) * de_dy(k,j+1,i+1) &
3768                               ) / ( 3.0_wp * gg )
3769                IF ( ( k+1 == nzt+1 )  .OR.  ( k == nzb ) )  THEN
3770                   de_dy_int(n) = de_dy_int_l
3771                ELSE
3772                   de_dy_int_u = ( ( gg - aa ) * de_dy(k+1,j,i)   + &
3773                                   ( gg - bb ) * de_dy(k+1,j,i+1) + &
3774                                   ( gg - cc ) * de_dy(k+1,j+1,i) + &
3775                                   ( gg - dd ) * de_dy(k+1,j+1,i+1) &
3776                                  ) / ( 3.0_wp * gg )
3777                      de_dy_int(n) = de_dy_int_l + ( zv(n) - zu(k) ) / dzw(k+1) * &
3778                                                 ( de_dy_int_u - de_dy_int_l )
3779                ENDIF
3780
3781!
3782!--             Interpolate the TKE gradient along z
3783                IF ( zv(n) < 0.5_wp * dz(1) )  THEN
3784                   de_dz_int(n) = 0.0_wp
3785                ELSE
3786                   de_dz_int_l = ( ( gg - aa ) * de_dz(k,j,i)   + &
3787                                   ( gg - bb ) * de_dz(k,j,i+1) + &
3788                                   ( gg - cc ) * de_dz(k,j+1,i) + &
3789                                   ( gg - dd ) * de_dz(k,j+1,i+1) &
3790                                  ) / ( 3.0_wp * gg )
3791
3792                   IF ( ( k+1 == nzt+1 )  .OR.  ( k == nzb ) )  THEN
3793                      de_dz_int(n) = de_dz_int_l
3794                   ELSE
3795                      de_dz_int_u = ( ( gg - aa ) * de_dz(k+1,j,i)   + &
3796                                      ( gg - bb ) * de_dz(k+1,j,i+1) + &
3797                                      ( gg - cc ) * de_dz(k+1,j+1,i) + &
3798                                      ( gg - dd ) * de_dz(k+1,j+1,i+1) &
3799                                     ) / ( 3.0_wp * gg )
3800                      de_dz_int(n) = de_dz_int_l + ( zv(n) - zu(k) ) / dzw(k+1) * &
3801                                                 ( de_dz_int_u - de_dz_int_l )
3802                   ENDIF
3803                ENDIF
3804
3805!
3806!--             Interpolate the dissipation of TKE
3807                diss_int_l = ( ( gg - aa ) * diss(k,j,i)   + &
3808                               ( gg - bb ) * diss(k,j,i+1) + &
3809                               ( gg - cc ) * diss(k,j+1,i) + &
3810                               ( gg - dd ) * diss(k,j+1,i+1) &
3811                               ) / ( 3.0_wp * gg )
3812
3813                IF ( k == nzt )  THEN
3814                   diss_int(n) = diss_int_l
3815                ELSE
3816                   diss_int_u = ( ( gg - aa ) * diss(k+1,j,i)   + &
3817                                  ( gg - bb ) * diss(k+1,j,i+1) + &
3818                                  ( gg - cc ) * diss(k+1,j+1,i) + &
3819                                  ( gg - dd ) * diss(k+1,j+1,i+1) &
3820                                 ) / ( 3.0_wp * gg )
3821                   diss_int(n) = diss_int_l + ( zv(n) - zu(k) ) / dzw(k+1) *      &
3822                                            ( diss_int_u - diss_int_l )
3823                ENDIF
3824
3825!
3826!--             Set flag for stochastic equation.
3827                term_1_2(n) = 1.0_wp
3828             ENDDO
3829          ENDIF
3830       ENDDO
3831
3832       DO nb = 0,7
3833          i = ip + block_offset(nb)%i_off
3834          j = jp + block_offset(nb)%j_off
3835          k = kp + block_offset(nb)%k_off
3836
3837          DO  n = start_index(nb), end_index(nb)
3838!
3839!--          Vertical interpolation of the horizontally averaged SGS TKE and
3840!--          resolved-scale velocity variances and use the interpolated values
3841!--          to calculate the coefficient fs, which is a measure of the ratio
3842!--          of the subgrid-scale turbulent kinetic energy to the total amount
3843!--          of turbulent kinetic energy.
3844             IF ( k == 0 )  THEN
3845                e_mean_int = hom(0,1,8,0)
3846             ELSE
3847                e_mean_int = hom(k,1,8,0) +                                    &
3848                                           ( hom(k+1,1,8,0) - hom(k,1,8,0) ) / &
3849                                           ( zu(k+1) - zu(k) ) *               &
3850                                           ( zv(n) - zu(k) )
3851             ENDIF
3852
3853             kw = kp - 1
3854
3855             IF ( k == 0 )  THEN
3856                aa  = hom(k+1,1,30,0)  * ( zv(n) / &
3857                                         ( 0.5_wp * ( zu(k+1) - zu(k) ) ) )
3858                bb  = hom(k+1,1,31,0)  * ( zv(n) / &
3859                                         ( 0.5_wp * ( zu(k+1) - zu(k) ) ) )
3860                cc  = hom(kw+1,1,32,0) * ( zv(n) / &
3861                                         ( 1.0_wp * ( zw(kw+1) - zw(kw) ) ) )
3862             ELSE
3863                aa  = hom(k,1,30,0) + ( hom(k+1,1,30,0) - hom(k,1,30,0) ) *    &
3864                           ( ( zv(n) - zu(k) ) / ( zu(k+1) - zu(k) ) )
3865                bb  = hom(k,1,31,0) + ( hom(k+1,1,31,0) - hom(k,1,31,0) ) *    &
3866                           ( ( zv(n) - zu(k) ) / ( zu(k+1) - zu(k) ) )
3867                cc  = hom(kw,1,32,0) + ( hom(kw+1,1,32,0)-hom(kw,1,32,0) ) *   &
3868                           ( ( zv(n) - zw(kw) ) / ( zw(kw+1)-zw(kw) ) )
3869             ENDIF
3870
3871             vv_int = ( 1.0_wp / 3.0_wp ) * ( aa + bb + cc )
3872!
3873!--          Needed to avoid NaN particle velocities. The value of 1.0 is just
3874!--          an educated guess for the given case.
3875             IF ( vv_int + ( 2.0_wp / 3.0_wp ) * e_mean_int == 0.0_wp )  THEN
3876                fs_int(n) = 1.0_wp
3877             ELSE
3878                fs_int(n) = ( 2.0_wp / 3.0_wp ) * e_mean_int /                 &
3879                            ( vv_int + ( 2.0_wp / 3.0_wp ) * e_mean_int )
3880             ENDIF
3881
3882          ENDDO
3883       ENDDO
3884
3885       DO  nb = 0, 7
3886          DO  n = start_index(nb), end_index(nb)
3887             rg(n,1) = random_gauss( iran_part, 5.0_wp )
3888             rg(n,2) = random_gauss( iran_part, 5.0_wp )
3889             rg(n,3) = random_gauss( iran_part, 5.0_wp )
3890          ENDDO
3891       ENDDO
3892
3893       DO  nb = 0, 7
3894          DO  n = start_index(nb), end_index(nb)
3895
3896!
3897!--          Calculate the Lagrangian timescale according to Weil et al. (2004).
3898             lagr_timescale(n) = ( 4.0_wp * e_int(n) + 1E-20_wp ) / &
3899                              ( 3.0_wp * fs_int(n) * c_0 * diss_int(n) + 1E-20_wp )
3900
3901!
3902!--          Calculate the next particle timestep. dt_gap is the time needed to
3903!--          complete the current LES timestep.
3904             dt_gap(n) = dt_3d - particles(n)%dt_sum
3905             dt_particle(n) = MIN( dt_3d, 0.025_wp * lagr_timescale(n), dt_gap(n) )
3906             particles(n)%aux1 = lagr_timescale(n)
3907             particles(n)%aux2 = dt_gap(n)
3908!
3909!--          The particle timestep should not be too small in order to prevent
3910!--          the number of particle timesteps of getting too large
3911             IF ( dt_particle(n) < dt_min_part )  THEN
3912                IF ( dt_min_part < dt_gap(n) )  THEN
3913                   dt_particle(n) = dt_min_part
3914                ELSE
3915                   dt_particle(n) = dt_gap(n)
3916                ENDIF
3917             ENDIF
3918             rvar1_temp(n) = particles(n)%rvar1
3919             rvar2_temp(n) = particles(n)%rvar2
3920             rvar3_temp(n) = particles(n)%rvar3
3921!
3922!--          Calculate the SGS velocity components
3923             IF ( particles(n)%age == 0.0_wp )  THEN
3924!
3925!--             For new particles the SGS components are derived from the SGS
3926!--             TKE. Limit the Gaussian random number to the interval
3927!--             [-5.0*sigma, 5.0*sigma] in order to prevent the SGS velocities
3928!--             from becoming unrealistically large.
3929                rvar1_temp(n) = SQRT( 2.0_wp * sgs_wf_part * e_int(n)          &
3930                                          + 1E-20_wp ) * ( rg(n,1) - 1.0_wp )
3931                rvar2_temp(n) = SQRT( 2.0_wp * sgs_wf_part * e_int(n)          &
3932                                          + 1E-20_wp ) * ( rg(n,2) - 1.0_wp )
3933                rvar3_temp(n) = SQRT( 2.0_wp * sgs_wf_part * e_int(n)          &
3934                                          + 1E-20_wp ) * ( rg(n,3) - 1.0_wp )
3935
3936             ELSE
3937!
3938!--             Restriction of the size of the new timestep: compared to the
3939!--             previous timestep the increase must not exceed 200%. First,
3940!--             check if age > age_m, in order to prevent that particles get zero
3941!--             timestep.
3942                dt_particle_m = MERGE( dt_particle(n),                         &
3943                                       particles(n)%age - particles(n)%age_m,  &
3944                                       particles(n)%age - particles(n)%age_m < &
3945                                       1E-8_wp )
3946                IF ( dt_particle(n) > 2.0_wp * dt_particle_m )  THEN
3947                   dt_particle(n) = 2.0_wp * dt_particle_m
3948                ENDIF
3949
3950!--             For old particles the SGS components are correlated with the
3951!--             values from the previous timestep. Random numbers have also to
3952!--             be limited (see above).
3953!--             As negative values for the subgrid TKE are not allowed, the
3954!--             change of the subgrid TKE with time cannot be smaller than
3955!--             -e_int(n)/dt_particle. This value is used as a lower boundary
3956!--             value for the change of TKE
3957                de_dt_min = - e_int(n) / dt_particle(n)
3958
3959                de_dt = ( e_int(n) - particles(n)%e_m ) / dt_particle_m
3960
3961                IF ( de_dt < de_dt_min )  THEN
3962                   de_dt = de_dt_min
3963                ENDIF
3964
3965                CALL weil_stochastic_eq(rvar1_temp(n), fs_int(n), e_int(n),& 
3966                                        de_dx_int(n), de_dt, diss_int(n),       &
3967                                        dt_particle(n), rg(n,1), term_1_2(n) )
3968
3969                CALL weil_stochastic_eq(rvar2_temp(n), fs_int(n), e_int(n),& 
3970                                        de_dy_int(n), de_dt, diss_int(n),       &
3971                                        dt_particle(n), rg(n,2), term_1_2(n) )
3972
3973                CALL weil_stochastic_eq(rvar3_temp(n), fs_int(n), e_int(n),& 
3974                                        de_dz_int(n), de_dt, diss_int(n),       &
3975                                        dt_particle(n), rg(n,3), term_1_2(n) )
3976
3977             ENDIF
3978
3979          ENDDO
3980       ENDDO
3981!
3982!--    Check if the added SGS velocities result in a violation of the CFL-
3983!--    criterion. If yes choose a smaller timestep based on the new velocities
3984!--    and calculate SGS velocities again
3985       dz_temp = zw(kp)-zw(kp-1)
3986
3987       DO  nb = 0, 7
3988          DO  n = start_index(nb), end_index(nb)
3989             IF ( .NOT. particles(n)%age == 0.0_wp .AND.                       &
3990                (ABS( u_int(n) + rvar1_temp(n) ) > (dx/dt_particle(n))  .OR.   &
3991                 ABS( v_int(n) + rvar2_temp(n) ) > (dy/dt_particle(n))  .OR.   &
3992                 ABS( w_int(n) + rvar3_temp(n) ) > (dz_temp/dt_particle(n))))  THEN
3993
3994                dt_particle(n) = 0.9_wp * MIN(                                 &
3995                                 ( dx / ABS( u_int(n) + rvar1_temp(n) ) ),     &
3996                                 ( dy / ABS( v_int(n) + rvar2_temp(n) ) ),     &
3997                                 ( dz_temp / ABS( w_int(n) + rvar3_temp(n) ) ) )
3998
3999!
4000!--             Reset temporary SGS velocites to "current" ones
4001                rvar1_temp(n) = particles(n)%rvar1
4002                rvar2_temp(n) = particles(n)%rvar2
4003                rvar3_temp(n) = particles(n)%rvar3
4004
4005                de_dt_min = - e_int(n) / dt_particle(n)
4006
4007                de_dt = ( e_int(n) - particles(n)%e_m ) / dt_particle_m
4008
4009                IF ( de_dt < de_dt_min )  THEN
4010                   de_dt = de_dt_min
4011                ENDIF
4012
4013                CALL weil_stochastic_eq(rvar1_temp(n), fs_int(n), e_int(n),& 
4014                                        de_dx_int(n), de_dt, diss_int(n),       &
4015                                        dt_particle(n), rg(n,1), term_1_2(n) )
4016
4017                CALL weil_stochastic_eq(rvar2_temp(n), fs_int(n), e_int(n),& 
4018                                        de_dy_int(n), de_dt, diss_int(n),       &
4019                                        dt_particle(n), rg(n,2), term_1_2(n) )
4020
4021                CALL weil_stochastic_eq(rvar3_temp(n), fs_int(n), e_int(n),& 
4022                                        de_dz_int(n), de_dt, diss_int(n),       &
4023                                        dt_particle(n), rg(n,3), term_1_2(n) )
4024             ENDIF
4025
4026!
4027!--          Update particle velocites
4028             particles(n)%rvar1 = rvar1_temp(n)
4029             particles(n)%rvar2 = rvar2_temp(n)
4030             particles(n)%rvar3 = rvar3_temp(n)
4031             u_int(n) = u_int(n) + particles(n)%rvar1
4032             v_int(n) = v_int(n) + particles(n)%rvar2
4033             w_int(n) = w_int(n) + particles(n)%rvar3
4034!
4035!--          Store the SGS TKE of the current timelevel which is needed for
4036!--          for calculating the SGS particle velocities at the next timestep
4037             particles(n)%e_m = e_int(n)
4038          ENDDO
4039       ENDDO
4040
4041    ELSE
4042!
4043!--    If no SGS velocities are used, only the particle timestep has to
4044!--    be set
4045       dt_particle = dt_3d
4046
4047    ENDIF
4048
4049    dens_ratio = particle_groups(particles(1:number_of_particles)%group)%density_ratio
4050    IF ( ANY( dens_ratio == 0.0_wp ) )  THEN
4051!
4052!--    Decide whether the particle loop runs over the subboxes or only over 1,
4053!--    number_of_particles. This depends on the selected interpolation method.
4054!--    If particle interpolation method is not trilinear, then the sorting within
4055!--    subboxes is not required. However, therefore the index start_index(nb) and
4056!--    end_index(nb) are not defined and the loops are still over
4057!--    number_of_particles. @todo find a more generic way to write this loop or
4058!--    delete trilinear interpolation
4059       IF ( interpolation_trilinear )  THEN
4060          subbox_start = 0
4061          subbox_end   = 7
4062       ELSE
4063          subbox_start = 1
4064          subbox_end   = 1
4065       ENDIF
4066!
4067!--    loop over subboxes. In case of simple interpolation scheme no subboxes
4068!--    are introduced, as they are not required. Accordingly, this loops goes
4069!--    from 1 to 1.
4070       DO  nb = subbox_start, subbox_end
4071          IF ( interpolation_trilinear )  THEN
4072             particle_start = start_index(nb)
4073             particle_end   = end_index(nb)
4074          ELSE
4075             particle_start = 1
4076             particle_end   = number_of_particles
4077          ENDIF
4078!
4079!--         Loop from particle start to particle end
4080            DO  n = particle_start, particle_end
4081
4082!
4083!--          Particle advection
4084             IF ( dens_ratio(n) == 0.0_wp )  THEN
4085!
4086!--             Pure passive transport (without particle inertia)
4087                particles(n)%x = xv(n) + u_int(n) * dt_particle(n)
4088                particles(n)%y = yv(n) + v_int(n) * dt_particle(n)
4089                particles(n)%z = zv(n) + w_int(n) * dt_particle(n)
4090
4091                particles(n)%speed_x = u_int(n)
4092                particles(n)%speed_y = v_int(n)
4093                particles(n)%speed_z = w_int(n)
4094
4095             ELSE
4096!
4097!--             Transport of particles with inertia
4098                particles(n)%x = particles(n)%x + particles(n)%speed_x * &
4099                                                  dt_particle(n)
4100                particles(n)%y = particles(n)%y + particles(n)%speed_y * &
4101                                                  dt_particle(n)
4102                particles(n)%z = particles(n)%z + particles(n)%speed_z * &
4103                                                  dt_particle(n)
4104
4105!
4106!--             Update of the particle velocity
4107                IF ( cloud_droplets )  THEN
4108!
4109!--                Terminal velocity is computed for vertical direction (Rogers et
4110!--                al., 1993, J. Appl. Meteorol.)
4111                   diameter = particles(n)%radius * 2000.0_wp !diameter in mm
4112                   IF ( diameter <= d0_rog )  THEN
4113                      w_s = k_cap_rog * diameter * ( 1.0_wp - EXP( -k_low_rog * diameter ) )
4114                   ELSE
4115                      w_s = a_rog - b_rog * EXP( -c_rog * diameter )
4116                   ENDIF
4117
4118!
4119!--                If selected, add random velocities following Soelch and Kaercher
4120!--                (2010, Q. J. R. Meteorol. Soc.)
4121                   IF ( use_sgs_for_particles )  THEN
4122                      lagr_timescale(n) = km(kp,jp,ip) / MAX( e(kp,jp,ip), 1.0E-20_wp )
4123                      RL             = EXP( -1.0_wp * dt_3d / MAX( lagr_timescale(n), &
4124                                             1.0E-20_wp ) )
4125                      sigma          = SQRT( e(kp,jp,ip) )
4126
4127                      rg1 = random_gauss( iran_part, 5.0_wp ) - 1.0_wp
4128                      rg2 = random_gauss( iran_part, 5.0_wp ) - 1.0_wp
4129                      rg3 = random_gauss( iran_part, 5.0_wp ) - 1.0_wp
4130
4131                      particles(n)%rvar1 = RL * particles(n)%rvar1 +              &
4132                                           SQRT( 1.0_wp - RL**2 ) * sigma * rg1
4133                      particles(n)%rvar2 = RL * particles(n)%rvar2 +              &
4134                                           SQRT( 1.0_wp - RL**2 ) * sigma * rg2
4135                      particles(n)%rvar3 = RL * particles(n)%rvar3 +              &
4136                                           SQRT( 1.0_wp - RL**2 ) * sigma * rg3
4137
4138                      particles(n)%speed_x = u_int(n) + particles(n)%rvar1
4139                      particles(n)%speed_y = v_int(n) + particles(n)%rvar2
4140                      particles(n)%speed_z = w_int(n) + particles(n)%rvar3 - w_s
4141                   ELSE
4142                      particles(n)%speed_x = u_int(n)
4143                      particles(n)%speed_y = v_int(n)
4144                      particles(n)%speed_z = w_int(n) - w_s
4145                   ENDIF
4146
4147                ELSE
4148
4149                   IF ( use_sgs_for_particles )  THEN
4150                      exp_arg  = particle_groups(particles(n)%group)%exp_arg
4151                      exp_term = EXP( -exp_arg * dt_particle(n) )
4152                   ELSE
4153                      exp_arg  = particle_groups(particles(n)%group)%exp_arg
4154                      exp_term = particle_groups(particles(n)%group)%exp_term
4155                   ENDIF
4156                   particles(n)%speed_x = particles(n)%speed_x * exp_term +         &
4157                                          u_int(n) * ( 1.0_wp - exp_term )
4158                   particles(n)%speed_y = particles(n)%speed_y * exp_term +         &
4159                                          v_int(n) * ( 1.0_wp - exp_term )
4160                   particles(n)%speed_z = particles(n)%speed_z * exp_term +         &
4161                                          ( w_int(n) - ( 1.0_wp - dens_ratio(n) ) * &
4162                                          g / exp_arg ) * ( 1.0_wp - exp_term )
4163                ENDIF
4164
4165             ENDIF
4166          ENDDO
4167       ENDDO
4168
4169    ELSE
4170!
4171!--    Decide whether the particle loop runs over the subboxes or only over 1,
4172!--    number_of_particles. This depends on the selected interpolation method.
4173       IF ( interpolation_trilinear )  THEN
4174          subbox_start = 0
4175          subbox_end   = 7
4176       ELSE
4177          subbox_start = 1
4178          subbox_end   = 1
4179       ENDIF
4180!--    loop over subboxes. In case of simple interpolation scheme no subboxes
4181!--    are introduced, as they are not required. Accordingly, this loops goes
4182!--    from 1 to 1.
4183       DO  nb = subbox_start, subbox_end
4184          IF ( interpolation_trilinear )  THEN
4185             particle_start = start_index(nb)
4186             particle_end   = end_index(nb)
4187          ELSE
4188             particle_start = 1
4189             particle_end   = number_of_particles
4190          ENDIF
4191!
4192!--         Loop from particle start to particle end
4193            DO  n = particle_start, particle_end
4194
4195!
4196!--          Transport of particles with inertia
4197             particles(n)%x = xv(n) + particles(n)%speed_x * dt_particle(n)
4198             particles(n)%y = yv(n) + particles(n)%speed_y * dt_particle(n)
4199             particles(n)%z = zv(n) + particles(n)%speed_z * dt_particle(n)
4200!
4201!--          Update of the particle velocity
4202             IF ( cloud_droplets )  THEN
4203!
4204!--             Terminal velocity is computed for vertical direction (Rogers et al.,
4205!--             1993, J. Appl. Meteorol.)
4206                diameter = particles(n)%radius * 2000.0_wp !diameter in mm
4207                IF ( diameter <= d0_rog )  THEN
4208                   w_s = k_cap_rog * diameter * ( 1.0_wp - EXP( -k_low_rog * diameter ) )
4209                ELSE
4210                   w_s = a_rog - b_rog * EXP( -c_rog * diameter )
4211                ENDIF
4212
4213!
4214!--             If selected, add random velocities following Soelch and Kaercher
4215!--             (2010, Q. J. R. Meteorol. Soc.)
4216                IF ( use_sgs_for_particles )  THEN
4217                    lagr_timescale(n) = km(kp,jp,ip) / MAX( e(kp,jp,ip), 1.0E-20_wp )
4218                     RL             = EXP( -1.0_wp * dt_3d / MAX( lagr_timescale(n), &
4219                                             1.0E-20_wp ) )
4220                    sigma          = SQRT( e(kp,jp,ip) )
4221
4222                    rg1 = random_gauss( iran_part, 5.0_wp ) - 1.0_wp
4223                    rg2 = random_gauss( iran_part, 5.0_wp ) - 1.0_wp
4224                    rg3 = random_gauss( iran_part, 5.0_wp ) - 1.0_wp
4225
4226                    particles(n)%rvar1 = RL * particles(n)%rvar1 +                &
4227                                         SQRT( 1.0_wp - RL**2 ) * sigma * rg1
4228                    particles(n)%rvar2 = RL * particles(n)%rvar2 +                &
4229                                         SQRT( 1.0_wp - RL**2 ) * sigma * rg2
4230                    particles(n)%rvar3 = RL * particles(n)%rvar3 +                &
4231                                         SQRT( 1.0_wp - RL**2 ) * sigma * rg3
4232
4233                    particles(n)%speed_x = u_int(n) + particles(n)%rvar1
4234                    particles(n)%speed_y = v_int(n) + particles(n)%rvar2
4235                    particles(n)%speed_z = w_int(n) + particles(n)%rvar3 - w_s
4236                ELSE
4237                    particles(n)%speed_x = u_int(n)
4238                    particles(n)%speed_y = v_int(n)
4239                    particles(n)%speed_z = w_int(n) - w_s
4240                ENDIF
4241
4242             ELSE
4243
4244                IF ( use_sgs_for_particles )  THEN
4245                   exp_arg  = particle_groups(particles(n)%group)%exp_arg
4246                   exp_term = EXP( -exp_arg * dt_particle(n) )
4247                ELSE
4248                   exp_arg  = particle_groups(particles(n)%group)%exp_arg
4249                   exp_term = particle_groups(particles(n)%group)%exp_term
4250                ENDIF
4251                particles(n)%speed_x = particles(n)%speed_x * exp_term +             &
4252                                       u_int(n) * ( 1.0_wp - exp_term )
4253                particles(n)%speed_y = particles(n)%speed_y * exp_term +             &
4254                                       v_int(n) * ( 1.0_wp - exp_term )
4255                particles(n)%speed_z = particles(n)%speed_z * exp_term +             &
4256                                       ( w_int(n) - ( 1.0_wp - dens_ratio(n) ) * g / &
4257                                       exp_arg ) * ( 1.0_wp - exp_term )
4258             ENDIF
4259          ENDDO
4260       ENDDO
4261
4262    ENDIF
4263
4264!
4265!-- Store the old age of the particle ( needed to prevent that a
4266!-- particle crosses several PEs during one timestep, and for the
4267!-- evaluation of the subgrid particle velocity fluctuations )
4268    particles(1:number_of_particles)%age_m = particles(1:number_of_particles)%age
4269
4270!
4271!--    loop over subboxes. In case of simple interpolation scheme no subboxes
4272!--    are introduced, as they are not required. Accordingly, this loops goes
4273!--    from 1 to 1.
4274!
4275!-- Decide whether the particle loop runs over the subboxes or only over 1,
4276!-- number_of_particles. This depends on the selected interpolation method.
4277    IF ( interpolation_trilinear )  THEN
4278       subbox_start = 0
4279       subbox_end   = 7
4280    ELSE
4281       subbox_start = 1
4282       subbox_end   = 1
4283    ENDIF
4284    DO  nb = subbox_start, subbox_end
4285       IF ( interpolation_trilinear )  THEN
4286          particle_start = start_index(nb)
4287          particle_end   = end_index(nb)
4288       ELSE
4289          particle_start = 1
4290          particle_end   = number_of_particles
4291       ENDIF
4292!
4293!--    Loop from particle start to particle end
4294       DO  n = particle_start, particle_end
4295!
4296!--       Increment the particle age and the total time that the particle
4297!--       has advanced within the particle timestep procedure
4298          particles(n)%age    = particles(n)%age    + dt_particle(n)
4299          particles(n)%dt_sum = particles(n)%dt_sum + dt_particle(n)
4300
4301!
4302!--       Check whether there is still a particle that has not yet completed
4303!--       the total LES timestep
4304          IF ( ( dt_3d - particles(n)%dt_sum ) > 1E-8_wp )  THEN
4305             dt_3d_reached_l = .FALSE.
4306          ENDIF
4307
4308       ENDDO
4309    ENDDO
4310
4311    CALL cpu_log( log_point_s(44), 'lpm_advec', 'pause' )
4312
4313
4314 END SUBROUTINE lpm_advec
4315
4316 
4317!------------------------------------------------------------------------------! 
4318! Description:
4319! ------------
4320!> Calculation of subgrid-scale particle speed using the stochastic model
4321!> of Weil et al. (2004, JAS, 61, 2877-2887).
4322!------------------------------------------------------------------------------!
4323 SUBROUTINE weil_stochastic_eq( v_sgs, fs_n, e_n, dedxi_n, dedt_n, diss_n,     &
4324                                dt_n, rg_n, fac )
4325
4326    REAL(wp) ::  a1      !< dummy argument
4327    REAL(wp) ::  dedt_n  !< time derivative of TKE at particle position
4328    REAL(wp) ::  dedxi_n !< horizontal derivative of TKE at particle position
4329    REAL(wp) ::  diss_n  !< dissipation at particle position
4330    REAL(wp) ::  dt_n    !< particle timestep
4331    REAL(wp) ::  e_n     !< TKE at particle position
4332    REAL(wp) ::  fac     !< flag to identify adjacent topography
4333    REAL(wp) ::  fs_n    !< weighting factor to prevent that subgrid-scale particle speed becomes too large
4334    REAL(wp) ::  rg_n    !< random number
4335    REAL(wp) ::  term1   !< memory term
4336    REAL(wp) ::  term2   !< drift correction term
4337    REAL(wp) ::  term3   !< random term
4338    REAL(wp) ::  v_sgs   !< subgrid-scale velocity component
4339
4340!-- At first, limit TKE to a small non-zero number, in order to prevent
4341!-- the occurrence of extremely large SGS-velocities in case TKE is zero,
4342!-- (could occur at the simulation begin).
4343    e_n = MAX( e_n, 1E-20_wp )
4344!
4345!-- Please note, terms 1 and 2 (drift and memory term, respectively) are
4346!-- multiplied by a flag to switch of both terms near topography.
4347!-- This is necessary, as both terms may cause a subgrid-scale velocity build up
4348!-- if particles are trapped in regions with very small TKE, e.g. in narrow street
4349!-- canyons resolved by only a few grid points. Hence, term 1 and term 2 are
4350!-- disabled if one of the adjacent grid points belongs to topography.
4351!-- Moreover, in this case, the  previous subgrid-scale component is also set
4352!-- to zero.
4353
4354    a1 = fs_n * c_0 * diss_n
4355!
4356!-- Memory term
4357    term1 = - a1 * v_sgs * dt_n / ( 4.0_wp * sgs_wf_part * e_n + 1E-20_wp )    &
4358                 * fac
4359!
4360!-- Drift correction term
4361    term2 = ( ( dedt_n * v_sgs / e_n ) + dedxi_n ) * 0.5_wp * dt_n              &
4362                 * fac
4363!
4364!-- Random term
4365    term3 = SQRT( MAX( a1, 1E-20_wp ) ) * ( rg_n - 1.0_wp ) * SQRT( dt_n )
4366!
4367!-- In cese one of the adjacent grid-boxes belongs to topograhy, the previous
4368!-- subgrid-scale velocity component is set to zero, in order to prevent a
4369!-- velocity build-up.
4370!-- This case, set also previous subgrid-scale component to zero.
4371    v_sgs = v_sgs * fac + term1 + term2 + term3
4372
4373 END SUBROUTINE weil_stochastic_eq
4374 
4375 
4376!------------------------------------------------------------------------------! 
4377! Description:
4378! ------------
4379!> Boundary conditions for the Lagrangian particles.
4380!> The routine consists of two different parts. One handles the bottom (flat)
4381!> and top boundary. In this part, also particles which exceeded their lifetime
4382!> are deleted.
4383!> The other part handles the reflection of particles from vertical walls.
4384!> This part was developed by Jin Zhang during 2006-2007.
4385!>
4386!> To do: Code structure for finding the t_index values and for checking the
4387!> -----  reflection conditions is basically the same for all four cases, so it
4388!>        should be possible to further simplify/shorten it.
4389!>
4390!> THE WALLS PART OF THIS ROUTINE HAS NOT BEEN TESTED FOR OCEAN RUNS SO FAR!!!!
4391!> (see offset_ocean_*)
4392!------------------------------------------------------------------------------!
4393 SUBROUTINE lpm_boundary_conds( location_bc , i, j, k )
4394
4395    CHARACTER (LEN=*), INTENT(IN) ::  location_bc !< general mode: boundary conditions at bottom/top of the model domain
4396                                   !< or at vertical surfaces (buildings, terrain steps)   
4397    INTEGER(iwp), INTENT(IN) ::  i !< grid index of particle box along x
4398    INTEGER(iwp), INTENT(IN) ::  j !< grid index of particle box along y
4399    INTEGER(iwp), INTENT(IN) ::  k !< grid index of particle box along z
4400
4401    INTEGER(iwp) ::  inc            !< dummy for sorting algorithmus
4402    INTEGER(iwp) ::  ir             !< dummy for sorting algorithmus
4403    INTEGER(iwp) ::  i1             !< grid index (x) of old particle position
4404    INTEGER(iwp) ::  i2             !< grid index (x) of current particle position
4405    INTEGER(iwp) ::  i3             !< grid index (x) of intermediate particle position
4406    INTEGER(iwp) ::  index_reset    !< index reset height
4407    INTEGER(iwp) ::  jr             !< dummy for sorting algorithmus
4408    INTEGER(iwp) ::  j1             !< grid index (y) of old particle position
4409    INTEGER(iwp) ::  j2             !< grid index (y) of current particle position
4410    INTEGER(iwp) ::  j3             !< grid index (y) of intermediate particle position
4411    INTEGER(iwp) ::  k1             !< grid index (z) of old particle position
4412    INTEGER(iwp) ::  k2             !< grid index (z) of current particle position
4413    INTEGER(iwp) ::  k3             !< grid index (z) of intermediate particle position
4414    INTEGER(iwp) ::  n              !< particle number
4415    INTEGER(iwp) ::  particles_top  !< maximum reset height
4416    INTEGER(iwp) ::  t_index        !< running index for intermediate particle timesteps in reflection algorithmus
4417    INTEGER(iwp) ::  t_index_number !< number of intermediate particle timesteps in reflection algorithmus
4418    INTEGER(iwp) ::  tmp_x          !< dummy for sorting algorithm
4419    INTEGER(iwp) ::  tmp_y          !< dummy for sorting algorithm
4420    INTEGER(iwp) ::  tmp_z          !< dummy for sorting algorithm
4421
4422    INTEGER(iwp), DIMENSION(0:10) :: x_ind(0:10) = 0 !< index array (x) of intermediate particle positions
4423    INTEGER(iwp), DIMENSION(0:10) :: y_ind(0:10) = 0 !< index array (y) of intermediate particle positions
4424    INTEGER(iwp), DIMENSION(0:10) :: z_ind(0:10) = 0 !< index array (z) of intermediate particle positions
4425
4426    LOGICAL  ::  cross_wall_x    !< flag to check if particle reflection along x is necessary
4427    LOGICAL  ::  cross_wall_y    !< flag to check if particle reflection along y is necessary
4428    LOGICAL  ::  cross_wall_z    !< flag to check if particle reflection along z is necessary
4429    LOGICAL  ::  reflect_x       !< flag to check if particle is already reflected along x
4430    LOGICAL  ::  reflect_y       !< flag to check if particle is already reflected along y
4431    LOGICAL  ::  reflect_z       !< flag to check if particle is already reflected along z
4432    LOGICAL  ::  tmp_reach_x     !< dummy for sorting algorithmus
4433    LOGICAL  ::  tmp_reach_y     !< dummy for sorting algorithmus
4434    LOGICAL  ::  tmp_reach_z     !< dummy for sorting algorithmus
4435    LOGICAL  ::  x_wall_reached  !< flag to check if particle has already reached wall
4436    LOGICAL  ::  y_wall_reached  !< flag to check if particle has already reached wall
4437    LOGICAL  ::  z_wall_reached  !< flag to check if particle has already reached wall
4438
4439    LOGICAL, DIMENSION(0:10) ::  reach_x  !< flag to check if particle is at a yz-wall
4440    LOGICAL, DIMENSION(0:10) ::  reach_y  !< flag to check if particle is at a xz-wall
4441    LOGICAL, DIMENSION(0:10) ::  reach_z  !< flag to check if particle is at a xy-wall
4442
4443    REAL(wp) ::  dt_particle    !< particle timestep
4444    REAL(wp) ::  eps = 1E-10_wp !< security number to check if particle has reached a wall
4445    REAL(wp) ::  pos_x          !< intermediate particle position (x)
4446    REAL(wp) ::  pos_x_old      !< particle position (x) at previous particle timestep
4447    REAL(wp) ::  pos_y          !< intermediate particle position (y)
4448    REAL(wp) ::  pos_y_old      !< particle position (y) at previous particle timestep
4449    REAL(wp) ::  pos_z          !< intermediate particle position (z)
4450    REAL(wp) ::  pos_z_old      !< particle position (z) at previous particle timestep
4451    REAL(wp) ::  prt_x          !< current particle position (x)
4452    REAL(wp) ::  prt_y          !< current particle position (y)
4453    REAL(wp) ::  prt_z          !< current particle position (z)
4454    REAL(wp) ::  ran_val        !< location of wall in z
4455    REAL(wp) ::  reset_top      !< location of wall in z
4456    REAL(wp) ::  t_old          !< previous reflection time
4457    REAL(wp) ::  tmp_t          !< dummy for sorting algorithmus
4458    REAL(wp) ::  xwall          !< location of wall in x
4459    REAL(wp) ::  ywall          !< location of wall in y
4460    REAL(wp) ::  zwall          !< location of wall in z
4461
4462    REAL(wp), DIMENSION(0:10) ::  t  !< reflection time
4463
4464    SELECT CASE ( location_bc )
4465
4466       CASE ( 'bottom/top' )
4467
4468!
4469!--    Apply boundary conditions to those particles that have crossed the top or
4470!--    bottom boundary and delete those particles, which are older than allowed
4471       DO  n = 1, number_of_particles
4472
4473!
4474!--       Stop if particles have moved further than the length of one
4475!--       PE subdomain (newly released particles have age = age_m!)
4476          IF ( particles(n)%age /= particles(n)%age_m )  THEN
4477             IF ( ABS(particles(n)%speed_x) >                                  &
4478                  ((nxr-nxl+2)*dx)/(particles(n)%age-particles(n)%age_m)  .OR. &
4479                  ABS(particles(n)%speed_y) >                                  &
4480                  ((nyn-nys+2)*dy)/(particles(n)%age-particles(n)%age_m) )  THEN
4481
4482                  WRITE( message_string, * )  'particle too fast.  n = ',  n
4483                  CALL message( 'lpm_boundary_conds', 'PA0148', 2, 2, -1, 6, 1 )
4484             ENDIF
4485          ENDIF
4486
4487          IF ( particles(n)%age > particle_maximum_age  .AND.  &
4488               particles(n)%particle_mask )                              &
4489          THEN
4490             particles(n)%particle_mask  = .FALSE.
4491             deleted_particles = deleted_particles + 1
4492          ENDIF
4493
4494          IF ( particles(n)%z >= zw(nz)  .AND.  particles(n)%particle_mask )  THEN
4495             IF ( ibc_par_t == 1 )  THEN
4496!
4497!--             Particle absorption
4498                particles(n)%particle_mask  = .FALSE.
4499                deleted_particles = deleted_particles + 1
4500             ELSEIF ( ibc_par_t == 2 )  THEN
4501!
4502!--             Particle reflection
4503                particles(n)%z       = 2.0_wp * zw(nz) - particles(n)%z
4504                particles(n)%speed_z = -particles(n)%speed_z
4505                IF ( use_sgs_for_particles  .AND. &
4506                     particles(n)%rvar3 > 0.0_wp )  THEN
4507                   particles(n)%rvar3 = -particles(n)%rvar3
4508                ENDIF
4509             ENDIF
4510          ENDIF
4511
4512          IF ( particles(n)%z < zw(0)  .AND.  particles(n)%particle_mask )  THEN
4513             IF ( ibc_par_b == 1 )  THEN
4514!
4515!--             Particle absorption
4516                particles(n)%particle_mask  = .FALSE.
4517                deleted_particles = deleted_particles + 1
4518             ELSEIF ( ibc_par_b == 2 )  THEN
4519!
4520!--             Particle reflection
4521                particles(n)%z       = 2.0_wp * zw(0) - particles(n)%z
4522                particles(n)%speed_z = -particles(n)%speed_z
4523                IF ( use_sgs_for_particles  .AND. &
4524                     particles(n)%rvar3 < 0.0_wp )  THEN
4525                   particles(n)%rvar3 = -particles(n)%rvar3
4526                ENDIF
4527             ELSEIF ( ibc_par_b == 3 )  THEN
4528!
4529!--             Find reset height. @note this works only in non-strechted cases
4530                particles_top = INT( pst(1) / dz(1) )
4531                index_reset = MINLOC( prt_count(nzb+1:particles_top,j,i), DIM = 1 )
4532                reset_top = zu(index_reset)
4533                iran_part = iran_part + myid
4534                ran_val = random_function( iran_part )
4535                particles(n)%z       = reset_top *  ( 1.0  + ( ran_val / 10.0_wp) )
4536                particles(n)%speed_z = 0.0_wp
4537                IF ( curvature_solution_effects )  THEN
4538                   particles(n)%radius = particles(n)%aux1
4539                ELSE
4540                   particles(n)%radius = 1.0E-8
4541                ENDIF
4542             ENDIF
4543          ENDIF
4544       ENDDO
4545
4546      CASE ( 'walls' )
4547
4548       CALL cpu_log( log_point_s(48), 'lpm_wall_reflect', 'start' )
4549
4550       DO  n = 1, number_of_particles
4551!
4552!--       Recalculate particle timestep
4553          dt_particle = particles(n)%age - particles(n)%age_m
4554!
4555!--       Obtain x/y indices for current particle position
4556          i2 = particles(n)%x * ddx
4557          j2 = particles(n)%y * ddy
4558          IF (zw(k)   < particles(n)%z ) k2 = k + 1
4559          IF (zw(k)   > particles(n)%z .AND. zw(k-1) < particles(n)%z ) k2 = k
4560          IF (zw(k-1) > particles(n)%z ) k2 = k - 1 
4561!
4562!--       Save current particle positions
4563          prt_x = particles(n)%x
4564          prt_y = particles(n)%y
4565          prt_z = particles(n)%z
4566!
4567!--       Recalculate old particle positions
4568          pos_x_old = particles(n)%x - particles(n)%speed_x * dt_particle
4569          pos_y_old = particles(n)%y - particles(n)%speed_y * dt_particle
4570          pos_z_old = particles(n)%z - particles(n)%speed_z * dt_particle
4571!
4572!--       Obtain x/y indices for old particle positions
4573          i1 = i
4574          j1 = j
4575          k1 = k
4576!
4577!--       Determine horizontal as well as vertical walls at which particle can
4578!--       be potentially reflected.
4579!--       Start with walls aligned in yz layer.
4580!--       Wall to the right
4581          IF ( prt_x > pos_x_old )  THEN
4582             xwall = ( i1 + 1 ) * dx
4583!
4584!--       Wall to the left
4585          ELSE
4586             xwall = i1 * dx
4587          ENDIF
4588!
4589!--       Walls aligned in xz layer
4590!--       Wall to the north
4591          IF ( prt_y > pos_y_old )  THEN
4592             ywall = ( j1 +1 ) * dy
4593!--       Wall to the south
4594          ELSE
4595             ywall = j1 * dy
4596          ENDIF
4597
4598          IF ( prt_z > pos_z_old )  THEN
4599             zwall = zw(k)
4600          ELSE
4601             zwall = zw(k-1)
4602          ENDIF
4603!
4604!--       Initialize flags to check if particle reflection is necessary
4605          cross_wall_x = .FALSE.
4606          cross_wall_y = .FALSE.
4607          cross_wall_z = .FALSE.
4608!
4609!--       Initialize flags to check if a wall is reached
4610          reach_x      = .FALSE.
4611          reach_y      = .FALSE.
4612          reach_z      = .FALSE.
4613!
4614!--       Initialize flags to check if a particle was already reflected
4615          reflect_x    = .FALSE.
4616          reflect_y    = .FALSE.
4617          reflect_z    = .FALSE.
4618!
4619!--       Initialize flags to check if a wall is already crossed.
4620!--       ( Required to obtain correct indices. )
4621          x_wall_reached = .FALSE.
4622          y_wall_reached = .FALSE.
4623          z_wall_reached = .FALSE.
4624!
4625!--       Initialize time array
4626          t     = 0.0_wp
4627!
4628!--       Check if particle can reach any wall. This case, calculate the
4629!--       fractional time needed to reach this wall. Store this fractional
4630!--       timestep in array t. Moreover, store indices for these grid
4631!--       boxes where the respective wall belongs to. 
4632!--       Start with x-direction.
4633          t_index    = 1
4634          t(t_index) = ( xwall - pos_x_old )                                   &
4635                     / MERGE( MAX( prt_x - pos_x_old,  1E-30_wp ),             &
4636                              MIN( prt_x - pos_x_old, -1E-30_wp ),             &
4637                              prt_x > pos_x_old )
4638          x_ind(t_index)   = i2
4639          y_ind(t_index)   = j1
4640          z_ind(t_index)   = k1
4641          reach_x(t_index) = .TRUE.
4642          reach_y(t_index) = .FALSE.
4643          reach_z(t_index) = .FALSE.
4644!
4645!--       Store these values only if particle really reaches any wall. t must
4646!--       be in a interval between [0:1].
4647          IF ( t(t_index) <= 1.0_wp .AND. t(t_index) >= 0.0_wp )  THEN
4648             t_index      = t_index + 1
4649             cross_wall_x = .TRUE.
4650          ENDIF
4651!
4652!--       y-direction
4653          t(t_index) = ( ywall - pos_y_old )                                   &
4654                     / MERGE( MAX( prt_y - pos_y_old,  1E-30_wp ),             &
4655                              MIN( prt_y - pos_y_old, -1E-30_wp ),             &
4656                              prt_y > pos_y_old )
4657          x_ind(t_index)   = i1
4658          y_ind(t_index)   = j2
4659          z_ind(t_index)   = k1
4660          reach_x(t_index) = .FALSE.
4661          reach_y(t_index) = .TRUE.
4662          reach_z(t_index) = .FALSE.
4663          IF ( t(t_index) <= 1.0_wp .AND. t(t_index) >= 0.0_wp )  THEN
4664             t_index      = t_index + 1
4665             cross_wall_y = .TRUE.
4666          ENDIF
4667!
4668!--       z-direction
4669          t(t_index) = (zwall - pos_z_old )                                    &
4670                     / MERGE( MAX( prt_z - pos_z_old,  1E-30_wp ),             &
4671                              MIN( prt_z - pos_z_old, -1E-30_wp ),             &
4672                              prt_z > pos_z_old )
4673
4674          x_ind(t_index)   = i1
4675          y_ind(t_index)   = j1
4676          z_ind(t_index)   = k2
4677          reach_x(t_index) = .FALSE.
4678          reach_y(t_index) = .FALSE.
4679          reach_z(t_index) = .TRUE.
4680          IF( t(t_index) <= 1.0_wp .AND. t(t_index) >= 0.0_wp)  THEN
4681             t_index      = t_index + 1
4682             cross_wall_z = .TRUE.
4683          ENDIF
4684
4685          t_index_number = t_index - 1
4686!
4687!--       Carry out reflection only if particle reaches any wall
4688          IF ( cross_wall_x .OR. cross_wall_y .OR. cross_wall_z )  THEN
4689!
4690!--          Sort fractional timesteps in ascending order. Also sort the
4691!--          corresponding indices and flag according to the time interval a 
4692!--          particle reaches the respective wall.
4693             inc = 1
4694             jr  = 1
4695             DO WHILE ( inc <= t_index_number )
4696                inc = 3 * inc + 1
4697             ENDDO
4698
4699             DO WHILE ( inc > 1 )
4700                inc = inc / 3
4701                DO  ir = inc+1, t_index_number
4702                   tmp_t       = t(ir)
4703                   tmp_x       = x_ind(ir)
4704                   tmp_y       = y_ind(ir)
4705                   tmp_z       = z_ind(ir)
4706                   tmp_reach_x = reach_x(ir)
4707                   tmp_reach_y = reach_y(ir)
4708                   tmp_reach_z = reach_z(ir)
4709                   jr    = ir
4710                   DO WHILE ( t(jr-inc) > tmp_t )
4711                      t(jr)       = t(jr-inc)
4712                      x_ind(jr)   = x_ind(jr-inc)
4713                      y_ind(jr)   = y_ind(jr-inc)
4714                      z_ind(jr)   = z_ind(jr-inc)
4715                      reach_x(jr) = reach_x(jr-inc)
4716                      reach_y(jr) = reach_y(jr-inc)
4717                      reach_z(jr) = reach_z(jr-inc)
4718                      jr    = jr - inc
4719                      IF ( jr <= inc )  EXIT
4720                   ENDDO
4721                   t(jr)       = tmp_t
4722                   x_ind(jr)   = tmp_x
4723                   y_ind(jr)   = tmp_y
4724                   z_ind(jr)   = tmp_z
4725                   reach_x(jr) = tmp_reach_x
4726                   reach_y(jr) = tmp_reach_y
4727                   reach_z(jr) = tmp_reach_z
4728                ENDDO
4729             ENDDO
4730!
4731!--          Initialize temporary particle positions
4732             pos_x = pos_x_old
4733             pos_y = pos_y_old
4734             pos_z = pos_z_old
4735!
4736!--          Loop over all times a particle possibly moves into a new grid box
4737             t_old = 0.0_wp
4738             DO t_index = 1, t_index_number
4739!
4740!--             Calculate intermediate particle position according to the
4741!--             timesteps a particle reaches any wall.
4742                pos_x = pos_x + ( t(t_index) - t_old ) * dt_particle           &
4743                                                       * particles(n)%speed_x
4744                pos_y = pos_y + ( t(t_index) - t_old ) * dt_particle           &
4745                                                       * particles(n)%speed_y
4746                pos_z = pos_z + ( t(t_index) - t_old ) * dt_particle           &
4747                                                       * particles(n)%speed_z
4748!
4749!--             Obtain x/y grid indices for intermediate particle position from
4750!--             sorted index array
4751                i3 = x_ind(t_index)
4752                j3 = y_ind(t_index)
4753                k3 = z_ind(t_index)
4754!
4755!--             Check which wall is already reached
4756                IF ( .NOT. x_wall_reached )  x_wall_reached = reach_x(t_index) 
4757                IF ( .NOT. y_wall_reached )  y_wall_reached = reach_y(t_index)
4758                IF ( .NOT. z_wall_reached )  z_wall_reached = reach_z(t_index)
4759!
4760!--             Check if a particle needs to be reflected at any yz-wall. If
4761!--             necessary, carry out reflection. Please note, a security
4762!--             constant is required, as the particle position does not
4763!--             necessarily exactly match the wall location due to rounding
4764!--             errors.
4765                IF ( reach_x(t_index)                      .AND.               & 
4766                     ABS( pos_x - xwall ) < eps            .AND.               &
4767                     .NOT. BTEST(wall_flags_0(k3,j3,i3),0) .AND.               &
4768                     .NOT. reflect_x )  THEN
4769!
4770!
4771!--                Reflection in x-direction.
4772!--                Ensure correct reflection by MIN/MAX functions, depending on
4773!--                direction of particle transport.
4774!--                Due to rounding errors pos_x does not exactly match the wall
4775!--                location, leading to erroneous reflection.             
4776                   pos_x = MERGE( MIN( 2.0_wp * xwall - pos_x, xwall ),        &
4777                                  MAX( 2.0_wp * xwall - pos_x, xwall ),        &
4778                                  particles(n)%x > xwall )
4779!
4780!--                Change sign of particle speed                     
4781                   particles(n)%speed_x = - particles(n)%speed_x
4782!
4783!--                Also change sign of subgrid-scale particle speed
4784                   particles(n)%rvar1 = - particles(n)%rvar1
4785!
4786!--                Set flag that reflection along x is already done
4787                   reflect_x          = .TRUE.
4788!
4789!--                As the particle does not cross any further yz-wall during
4790!--                this timestep, set further x-indices to the current one.
4791                   x_ind(t_index:t_index_number) = i1
4792!
4793!--             If particle already reached the wall but was not reflected,
4794!--             set further x-indices to the new one.
4795                ELSEIF ( x_wall_reached .AND. .NOT. reflect_x )  THEN
4796                    x_ind(t_index:t_index_number) = i2
4797                ENDIF !particle reflection in x direction done
4798
4799!
4800!--             Check if a particle needs to be reflected at any xz-wall. If
4801!--             necessary, carry out reflection. Please note, a security
4802!--             constant is required, as the particle position does not
4803!--             necessarily exactly match the wall location due to rounding
4804!--             errors.
4805                IF ( reach_y(t_index)                      .AND.               & 
4806                     ABS( pos_y - ywall ) < eps            .AND.               &
4807                     .NOT. BTEST(wall_flags_0(k3,j3,i3),0) .AND.               &
4808                     .NOT. reflect_y )  THEN
4809!
4810!
4811!--                Reflection in y-direction.
4812!--                Ensure correct reflection by MIN/MAX functions, depending on
4813!--                direction of particle transport.
4814!--                Due to rounding errors pos_y does not exactly match the wall
4815!--                location, leading to erroneous reflection.             
4816                   pos_y = MERGE( MIN( 2.0_wp * ywall - pos_y, ywall ),        &
4817                                  MAX( 2.0_wp * ywall - pos_y, ywall ),        &
4818                                  particles(n)%y > ywall )
4819!
4820!--                Change sign of particle speed                     
4821                   particles(n)%speed_y = - particles(n)%speed_y
4822!
4823!--                Also change sign of subgrid-scale particle speed
4824                   particles(n)%rvar2 = - particles(n)%rvar2
4825!
4826!--                Set flag that reflection along y is already done
4827                   reflect_y          = .TRUE.
4828!
4829!--                As the particle does not cross any further xz-wall during
4830!--                this timestep, set further y-indices to the current one.
4831                   y_ind(t_index:t_index_number) = j1
4832!
4833!--             If particle already reached the wall but was not reflected,
4834!--             set further y-indices to the new one.
4835                ELSEIF ( y_wall_reached .AND. .NOT. reflect_y )  THEN
4836                    y_ind(t_index:t_index_number) = j2
4837                ENDIF !particle reflection in y direction done
4838
4839!
4840!--             Check if a particle needs to be reflected at any xy-wall. If
4841!--             necessary, carry out reflection. Please note, a security
4842!--             constant is required, as the particle position does not
4843!--             necessarily exactly match the wall location due to rounding
4844!--             errors.
4845                IF ( reach_z(t_index)                      .AND.               & 
4846                     ABS( pos_z - zwall ) < eps            .AND.               &
4847                     .NOT. BTEST(wall_flags_0(k3,j3,i3),0) .AND.               &
4848                     .NOT. reflect_z )  THEN
4849!
4850!
4851!--                Reflection in z-direction.
4852!--                Ensure correct reflection by MIN/MAX functions, depending on
4853!--                direction of particle transport.
4854!--                Due to rounding errors pos_z does not exactly match the wall
4855!--                location, leading to erroneous reflection.             
4856                   pos_z = MERGE( MIN( 2.0_wp * zwall - pos_z, zwall ),        &
4857                                  MAX( 2.0_wp * zwall - pos_z, zwall ),        &
4858                                  particles(n)%z > zwall )
4859!
4860!--                Change sign of particle speed                     
4861                   particles(n)%speed_z = - particles(n)%speed_z
4862!
4863!--                Also change sign of subgrid-scale particle speed
4864                   particles(n)%rvar3 = - particles(n)%rvar3
4865!
4866!--                Set flag that reflection along z is already done
4867                   reflect_z          = .TRUE.
4868!
4869!--                As the particle does not cross any further xy-wall during
4870!--                this timestep, set further z-indices to the current one.
4871                   z_ind(t_index:t_index_number) = k1
4872!
4873!--             If particle already reached the wall but was not reflected,
4874!--             set further z-indices to the new one.
4875                ELSEIF ( z_wall_reached .AND. .NOT. reflect_z )  THEN
4876                    z_ind(t_index:t_index_number) = k2
4877                ENDIF !particle reflection in z direction done               
4878
4879!
4880!--             Swap time
4881                t_old = t(t_index)
4882
4883             ENDDO
4884!
4885!--          If a particle was reflected, calculate final position from last
4886!--          intermediate position.
4887             IF ( reflect_x .OR. reflect_y .OR. reflect_z )  THEN
4888
4889                particles(n)%x = pos_x + ( 1.0_wp - t_old ) * dt_particle      &
4890                                                         * particles(n)%speed_x
4891                particles(n)%y = pos_y + ( 1.0_wp - t_old ) * dt_particle      &
4892                                                         * particles(n)%speed_y
4893                particles(n)%z = pos_z + ( 1.0_wp - t_old ) * dt_particle      &
4894                                                         * particles(n)%speed_z
4895
4896             ENDIF
4897
4898          ENDIF
4899
4900       ENDDO
4901
4902       CALL cpu_log( log_point_s(48), 'lpm_wall_reflect', 'stop' )
4903
4904       CASE DEFAULT
4905          CONTINUE
4906
4907    END SELECT
4908
4909 END SUBROUTINE lpm_boundary_conds
4910
4911
4912!------------------------------------------------------------------------------!
4913! Description:
4914! ------------
4915!> Calculates change in droplet radius by condensation/evaporation, using
4916!> either an analytic formula or by numerically integrating the radius growth
4917!> equation including curvature and solution effects using Rosenbrocks method
4918!> (see Numerical recipes in FORTRAN, 2nd edition, p. 731).
4919!> The analytical formula and growth equation follow those given in
4920!> Rogers and Yau (A short course in cloud physics, 3rd edition, p. 102/103).
4921!------------------------------------------------------------------------------!
4922 SUBROUTINE lpm_droplet_condensation (i,j,k)
4923
4924    INTEGER(iwp), INTENT(IN) :: i              !<
4925    INTEGER(iwp), INTENT(IN) :: j              !<
4926    INTEGER(iwp), INTENT(IN) :: k              !<
4927    INTEGER(iwp) :: n                          !<
4928
4929    REAL(wp) ::  afactor                       !< curvature effects
4930    REAL(wp) ::  arg                           !<
4931    REAL(wp) ::  bfactor                       !< solute effects
4932    REAL(wp) ::  ddenom                        !<
4933    REAL(wp) ::  delta_r                       !<
4934    REAL(wp) ::  diameter                      !< diameter of cloud droplets
4935    REAL(wp) ::  diff_coeff                    !< diffusivity for water vapor
4936    REAL(wp) ::  drdt                          !<
4937    REAL(wp) ::  dt_ros                        !<
4938    REAL(wp) ::  dt_ros_sum                    !<
4939    REAL(wp) ::  d2rdtdr                       !<
4940    REAL(wp) ::  e_a                           !< current vapor pressure
4941    REAL(wp) ::  e_s                           !< current saturation vapor pressure
4942    REAL(wp) ::  error                         !< local truncation error in Rosenbrock
4943    REAL(wp) ::  k1                            !<
4944    REAL(wp) ::  k2                            !<
4945    REAL(wp) ::  r_err                         !< First order estimate of Rosenbrock radius
4946    REAL(wp) ::  r_ros                         !< Rosenbrock radius
4947    REAL(wp) ::  r_ros_ini                     !< initial Rosenbrock radius
4948    REAL(wp) ::  r0                            !< gas-kinetic lengthscale
4949    REAL(wp) ::  sigma                         !< surface tension of water
4950    REAL(wp) ::  thermal_conductivity          !< thermal conductivity for water
4951    REAL(wp) ::  t_int                         !< temperature
4952    REAL(wp) ::  w_s                           !< terminal velocity of droplets
4953    REAL(wp) ::  re_p                          !< particle Reynolds number
4954!