Home


About us
PALM
PALM-4U
Installation
Release notes
Documentation
Getting Help
Gallery
Developers area

Changeset 1359 for palm


Ignore:
Timestamp:
Apr 11, 2014 5:15:14 PM (11 years ago)
Author:
hoffmann
Message:

new Lagrangian particle structure integrated

Location:
palm/trunk/SOURCE
Files:
1 added
2 deleted
38 edited

Legend:

Unmodified
Added
Removed

  • TabularUnified palm/trunk/SOURCE/Makefile

    r1338 r1359  
    2020# Current revisions:
    2121# ------------------
    22 #
     22# mod_particle_attributes added, lpm_sort_arrays removed,
     23# lpm_extend_particle_array removed
    2324#
    2425# Former revisions:
    … …  
    174175        lpm_data_output_particles.f90 lpm_droplet_collision.f90 \
    175176        lpm_droplet_condensation.f90 lpm_exchange_horiz.f90 \
    176         lpm_extend_particle_array.f90 lpm_extend_tails.f90 \
     177        lpm_extend_tails.f90 \
    177178        lpm_extend_tail_array.f90 lpm_init.f90 lpm_init_sgs_tke.f90 \
    178179        lpm_pack_arrays.f90 lpm_read_restart_file.f90 lpm_release_set.f90 \
    179         lpm_set_attributes.f90 lpm_sort_arrays.f90 \
     180        lpm_set_attributes.f90 \
    180181        lpm_write_exchange_statistics.f90 lpm_write_restart_file.f90 \
    181182        ls_forcing.f90 message.f90 microphysics.f90 modules.f90 mod_kinds.f90 \
    182         netcdf.f90 nudging.f90 \
     183        mod_particle_attributes.f90 netcdf.f90 nudging.f90 \
    183184        package_parin.f90 palm.f90 parin.f90 plant_canopy_model.f90 poisfft.f90 \
    184185        poismg.f90 prandtl_fluxes.f90 pres.f90 print_1d.f90 \
    … …  
    261262data_log.o: modules.o mod_kinds.o
    262263data_output_dvrp.o: modules.o cpulog.o mod_kinds.o
    263 data_output_mask.o: modules.o cpulog.o mod_kinds.o
     264data_output_mask.o: modules.o cpulog.o mod_kinds.o mod_particle_attributes.o
    264265data_output_profiles.o: modules.o cpulog.o mod_kinds.o
    265 data_output_ptseries.o: modules.o cpulog.o mod_kinds.o
     266data_output_ptseries.o: modules.o cpulog.o mod_kinds.o mod_particle_attributes.o
    266267data_output_spectra.o: modules.o cpulog.o mod_kinds.o
    267268data_output_tseries.o: modules.o cpulog.o mod_kinds.o
    268 data_output_2d.o: modules.o cpulog.o mod_kinds.o
    269 data_output_3d.o: modules.o cpulog.o mod_kinds.o
     269data_output_2d.o: modules.o cpulog.o mod_kinds.o mod_particle_attributes.o
     270data_output_3d.o: modules.o cpulog.o mod_kinds.o mod_particle_attributes.o
    270271diffusion_e.o: modules.o mod_kinds.o
    271272diffusion_s.o: modules.o mod_kinds.o
    … …  
    286287inflow_turbulence.o: modules.o cpulog.o mod_kinds.o
    287288init_1d_model.o: modules.o mod_kinds.o
    288 init_3d_model.o: modules.o cpulog.o mod_kinds.o random_function.o advec_ws.o ls_forcing.o
     289init_3d_model.o: modules.o cpulog.o mod_kinds.o random_function.o advec_ws.o \
     290        ls_forcing.o lpm_init.o
    289291init_advec.o: modules.o mod_kinds.o
    290292init_cloud_physics.o: modules.o mod_kinds.o
    … …  
    304306local_tremain.o: modules.o cpulog.o mod_kinds.o
    305307local_tremain_ini.o: modules.o cpulog.o mod_kinds.o
    306 lpm.o: modules.o cpulog.o mod_kinds.o
    307 lpm_advec.o: modules.o mod_kinds.o
    308 lpm_boundary_conds.o: modules.o cpulog.o mod_kinds.o
    309 lpm_calc_liquid_water_content.o: modules.o cpulog.o mod_kinds.o
    310 lpm_collision_kernels.o: modules.o cpulog.o user_module.o mod_kinds.o
    311 lpm_data_output_particles.o: modules.o cpulog.o mod_kinds.o
    312 lpm_droplet_collision.o: modules.o cpulog.o lpm_collision_kernels.o mod_kinds.o
    313 lpm_droplet_condensation.o: modules.o cpulog.o lpm_collision_kernels.o mod_kinds.o
    314 lpm_exchange_horiz.o: modules.o cpulog.o mod_kinds.o
    315 lpm_extend_particle_array.o: modules.o mod_kinds.o
    316 lpm_extend_tails.o: modules.o mod_kinds.o
    317 lpm_extend_tail_array.o: modules.o mod_kinds.o
    318 lpm_init.o: modules.o lpm_collision_kernels.o mod_kinds.o random_function.o
    319 lpm_init_sgs_tke.o: modules.o mod_kinds.o
    320 lpm_pack_arrays.o: modules.o mod_kinds.o
    321 lpm_read_restart_file.o: modules.o mod_kinds.o
    322 lpm_release_set.o: modules.o mod_kinds.o random_function.o
    323 lpm_set_attributes.o: modules.o cpulog.o mod_kinds.o
    324 lpm_sort_arrays.o: modules.o cpulog.o mod_kinds.o
    325 lpm_write_exchange_statistics.o: modules.o mod_kinds.o
    326 lpm_write_restart_file.o: modules.o mod_kinds.o
     308lpm.o: modules.o cpulog.o lpm_exchange_horiz.o lpm_pack_arrays.o mod_kinds.o \
     309        mod_particle_attributes.o
     310lpm_advec.o: modules.o mod_kinds.o mod_particle_attributes.o
     311lpm_boundary_conds.o: modules.o cpulog.o mod_kinds.o mod_particle_attributes.o
     312lpm_calc_liquid_water_content.o: modules.o cpulog.o mod_kinds.o \
     313        mod_particle_attributes.o
     314lpm_collision_kernels.o: modules.o cpulog.o user_module.o mod_kinds.o \
     315        mod_particle_attributes.o
     316lpm_data_output_particles.o: modules.o cpulog.o mod_kinds.o \
     317        mod_particle_attributes.o
     318lpm_droplet_collision.o: modules.o cpulog.o lpm_collision_kernels.o \
     319        mod_kinds.o mod_particle_attributes.o
     320lpm_droplet_condensation.o: modules.o cpulog.o lpm_collision_kernels.o \
     321        mod_kinds.o mod_particle_attributes.o
     322lpm_exchange_horiz.o: modules.o cpulog.o lpm_pack_arrays.o mod_kinds.o \
     323        mod_particle_attributes.o
     324lpm_extend_tails.o: modules.o mod_kinds.o mod_particle_attributes.o
     325lpm_extend_tail_array.o: modules.o mod_kinds.o mod_particle_attributes.o
     326lpm_init.o: modules.o lpm_collision_kernels.o mod_kinds.o \
     327        random_function.o mod_particle_attributes.o lpm_exchange_horiz.o \
     328        lpm_pack_arrays.o
     329lpm_init_sgs_tke.o: modules.o mod_kinds.o mod_particle_attributes.o
     330lpm_pack_arrays.o: modules.o mod_kinds.o mod_particle_attributes.o
     331lpm_read_restart_file.o: modules.o mod_kinds.o mod_particle_attributes.o \
     332        lpm_pack_arrays.o
     333lpm_release_set.o: modules.o mod_kinds.o random_function.o \
     334        mod_particle_attributes.o lpm_init.o
     335lpm_set_attributes.o: modules.o cpulog.o mod_kinds.o mod_particle_attributes.o
     336lpm_write_exchange_statistics.o: modules.o mod_kinds.o mod_particle_attributes.o
     337lpm_write_restart_file.o: modules.o mod_kinds.o mod_particle_attributes.o
    327338ls_forcing.o: modules.o cpulog.o mod_kinds.o
    328339message.o: modules.o mod_kinds.o
    … …  
    330341modules.o: modules.f90 mod_kinds.o
    331342mod_kinds.o: mod_kinds.f90
     343mod_particle_attributes.o: mod_particle_attributes.f90 mod_kinds.o
    332344netcdf.o: modules.o mod_kinds.o
    333345nudging.o: modules.o buoyancy.o cpulog.o mod_kinds.o
    … …  
    343355production_e.o: modules.o mod_kinds.o wall_fluxes.o
    344356prognostic_equations.o: modules.o advec_s_pw.o advec_s_up.o advec_u_pw.o \
    345         advec_u_up.o advec_v_pw.o advec_v_up.o advec_w_pw.o advec_w_up.o  \
    346    advec_ws.o buoyancy.o calc_precipitation.o calc_radiation.o coriolis.o \
     357        advec_u_up.o advec_v_pw.o advec_v_up.o advec_w_pw.o advec_w_up.o \
     358        advec_ws.o buoyancy.o calc_precipitation.o calc_radiation.o coriolis.o \
    347359        cpulog.o diffusion_e.o diffusion_s.o diffusion_u.o diffusion_v.o diffusion_w.o \
    348360        eqn_state_seawater.o impact_of_latent_heat.o mod_kinds.o microphysics.o \
    349         nudging.o plant_canopy_model.o production_e.o subsidence.o user_actions.o
     361        nudging.o plant_canopy_model.o production_e.o subsidence.o user_actions.o
    350362random_function.o: mod_kinds.o
    351363random_gauss.o: mod_kinds.o random_function.o

  • TabularUnified palm/trunk/SOURCE/Makefile_check

    r1321 r1359  
    2020# Current revisions:
    2121# ------------------
    22 #
     22# mod_particle_attributes added
    2323#
    2424# Former revisions:
    … …  
    7575      exchange_horiz_2d.f90 fft_xy.f90 init_grid.f90 init_masks.f90 \
    7676      init_cloud_physics.f90 init_pegrid.f90 local_flush.f90 local_stop.f90 \
    77       local_system.f90 message.f90 modules.f90 mod_kinds.f90 package_parin.f90 \
     77      local_system.f90 message.f90 modules.f90 mod_kinds.f90 \
     78      mod_particle_attributes.f90 package_parin.f90 \
    7879      parin.f90 poisfft.f90 random_function.f90 singleton.f90 \
    7980      subsidence.f90 temperton_fft.f90 tridia_solver.f90 \
    … …  
    161162user_init_plant_canopy.o: modules.o mod_kinds.o user_module.o
    162163user_last_actions.o: modules.o mod_kinds.o user_module.o
    163 user_lpm_advec.o: modules.o mod_kinds.o user_module.o
    164 user_lpm_init.o: modules.o mod_kinds.o user_module.o
    165 user_lpm_set_attributes.o: modules.o mod_kinds.o user_module.o
     164user_lpm_advec.o: modules.o mod_kinds.o mod_particle_attributes.o user_module.o
     165user_lpm_init.o: modules.o mod_kinds.o mod_particle_attributes.o user_module.o
     166user_lpm_set_attributes.o: modules.o mod_kinds.o mod_particle_attributes.o \
     167      user_module.o
    166168user_module.o: mod_kinds.o user_module.f90
    167169user_parin.o: modules.o mod_kinds.o user_module.o

  • TabularUnified palm/trunk/SOURCE/check_open.f90

    r1354 r1359  
    2020! Current revisions:
    2121! -----------------
    22 !
     22! Format of particle exchange statistics extended to reasonable numbers of     
     23! particles.
    2324!
    2425! Former revisions:
    … …  
    9192
    9293    USE indices,                                                               &
    93         ONLY:  nbgp, nx, nxlg, nxrg, ny, nyng, nysg, nz, nzb
     94        ONLY:  nbgp, nx, nxl, nxlg, nxr, nxrg, ny, nyn, nyng, nys, nysg, nz,   &
     95               nzb, nzt
    9496
    9597    USE kinds
    … …  
    591593!--                     unit 85 is changed (see also in routine
    592594!--                     lpm_data_output_particles)
    593              rtext = 'data format version 3.0'
     595             rtext = 'data format version 3.1'
    594596             WRITE ( 85 )  rtext
    595597             WRITE ( 85 )  number_of_particle_groups,                          &
    596598                           max_number_of_particle_groups
    597599             WRITE ( 85 )  particle_groups
     600             WRITE ( 85 )  nxl, nxr, nys, nyn, nzb, nzt, nbgp
    598601          ENDIF
    599602
    … …  
    11361139             '#18 pt(zp)'/'#19 splptx'/'#20 splpty'/'#21 splptz')
    113711408000 FORMAT (A/                                                                &
    1138              '  step    time  # of parts   lPE sent/recv  rPE sent/recv  ',    &
    1139              'sPE sent/recv  nPE sent/recv  max # of parts'/                   &
    1140              103('-'))
     1141             '  step    time    # of parts     lPE sent/recv  rPE sent/recv  ',&
     1142             'sPE sent/recv  nPE sent/recv    max # of parts  '/               &
     1143             109('-'))
    11411144
    11421145 END SUBROUTINE check_open

  • TabularUnified palm/trunk/SOURCE/check_parameters.f90

    r1354 r1359  
    2020! Current revisions:
    2121! -----------------
    22 !
     22! Do not allow the execution of PALM with use_particle_tails, since particle
     23! tails are currently not supported by our new particle structure.
     24!
     25! PA0084 not necessary for new particle structure
    2326!
    2427! Former revisions:
    … …  
    512515                        'with particle advection.'
    513516       CALL message( 'check_parameters', 'PA0017', 1, 2, 0, 6, 0 )
     517    ENDIF
     518
     519!
     520!--
     521    IF ( use_particle_tails )  THEN
     522       message_string = 'Particle tails are currently not available due ' //   &
     523                        'to the new particle structure.'
     524       CALL message( 'check_parameters', 'PA0392', 1, 2, 0, 6, 0 )
    514525    ENDIF
    515526
    … …  
    18171828
    18181829!
    1819 !-- Check the interval for sorting particles.
    1820 !-- Using particles as cloud droplets requires sorting after each timestep.
    1821     IF ( dt_sort_particles /= 0.0_wp  .AND.  cloud_droplets )  THEN
    1822        dt_sort_particles = 0.0_wp
    1823        message_string = 'dt_sort_particles is reset to 0.0 because of cloud' //&
    1824                         '_droplets = .TRUE.'
    1825        CALL message( 'check_parameters', 'PA0084', 0, 1, 0, 6, 0 )
    1826     ENDIF
    1827 
    1828 !
    18291830!-- Set the default intervals for data output, if necessary
    18301831!-- NOTE: dt_dosp has already been set in package_parin

  • TabularUnified palm/trunk/SOURCE/data_output_2d.f90

    r1354 r1359  
    2020! Current revisions:
    2121! -----------------
    22 !
     22! New particle structure integrated.
    2323!
    2424! Former revisions:
    … …  
    128128
    129129    USE particle_attributes,                                                   &
    130         ONLY:  particle_advection_start, particles, prt_count,                 &
    131                prt_start_index
     130        ONLY:  grid_particles, number_of_particles, particle_advection_start,  &
     131               particles, prt_count
    132132   
    133133    USE pegrid
    … …  
    163163    LOGICAL ::  two_d          !:
    164164   
    165     REAL(wp) ::  mean_r         !:
    166     REAL(wp) ::  s_r3           !:
    167     REAL(wp) ::  s_r4           !:
     165    REAL(wp) ::  mean_r        !:
     166    REAL(wp) ::  s_r2          !:
     167    REAL(wp) ::  s_r3          !:
    168168   
    169     REAL(wp), DIMENSION(:), ALLOCATABLE ::      level_z     !:
    170     REAL(wp), DIMENSION(:,:), ALLOCATABLE ::    local_2d    !:
    171     REAL(wp), DIMENSION(:,:), ALLOCATABLE ::    local_2d_l  !:
    172     REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  local_pf    !:
     169    REAL(wp), DIMENSION(:), ALLOCATABLE     ::  level_z             !:
     170    REAL(wp), DIMENSION(:,:), ALLOCATABLE   ::  local_2d            !:
     171    REAL(wp), DIMENSION(:,:), ALLOCATABLE   ::  local_2d_l          !:
     172    REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  local_pf            !:
    173173    REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  local_2d_sections   !:
    174174    REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  local_2d_sections_l !:
     175
    175176#if defined( __parallel )
    176     REAL(wp), DIMENSION(:,:),   ALLOCATABLE ::  total_2d  !:
     177    REAL(wp), DIMENSION(:,:),   ALLOCATABLE ::  total_2d    !:
    177178#endif
    178179    REAL(wp), DIMENSION(:,:,:), POINTER ::  to_be_resorted  !:
    … …  
    418419                ENDIF
    419420
    420              CASE ( 'pr_xy', 'pr_xz', 'pr_yz' )  ! mean particle radius
     421             CASE ( 'pr_xy', 'pr_xz', 'pr_yz' )  ! mean particle radius (effective radius)
    421422                IF ( av == 0 )  THEN
    422423                   IF ( simulated_time >= particle_advection_start )  THEN
    … …  
    424425                         DO  j = nys, nyn
    425426                            DO  k = nzb, nzt+1
    426                                psi = prt_start_index(k,j,i)
     427                               number_of_particles = prt_count(k,j,i)
     428                               IF (number_of_particles <= 0)  CYCLE
     429                               particles => grid_particles(k,j,i)%particles(1:number_of_particles)
     430                               s_r2 = 0.0_wp
    427431                               s_r3 = 0.0_wp
    428                                s_r4 = 0.0_wp
    429                                DO  n = psi, psi+prt_count(k,j,i)-1
    430                                   s_r3 = s_r3 + particles(n)%radius**3 *       &
    431                                                 particles(n)%weight_factor
    432                                   s_r4 = s_r4 + particles(n)%radius**4 *       &
    433                                                 particles(n)%weight_factor
     432                               DO  n = 1, number_of_particles
     433                                  IF ( particles(n)%particle_mask )  THEN
     434                                     s_r2 = s_r2 + particles(n)%radius**2 * &
     435                                            particles(n)%weight_factor
     436                                     s_r3 = s_r3 + particles(n)%radius**3 * &
     437                                            particles(n)%weight_factor
     438                                  ENDIF
    434439                               ENDDO
    435                                IF ( s_r3 /= 0.0_wp )  THEN
    436                                   mean_r = s_r4 / s_r3
     440                               IF ( s_r2 > 0.0_wp )  THEN
     441                                  mean_r = s_r3 / s_r2
    437442                               ELSE
    438443                                  mean_r = 0.0_wp
    … …  
    445450                   ELSE
    446451                      tend = 0.0_wp
    447                    END IF
     452                   ENDIF
    448453                   DO  i = nxlg, nxrg
    449454                      DO  j = nysg, nyng
    … …  
    600605                         DO  j = nys, nyn
    601606                            DO  k = nzb, nzt+1
    602                                psi = prt_start_index(k,j,i)
    603                                DO  n = psi, psi+prt_count(k,j,i)-1
    604                                   tend(k,j,i) =  tend(k,j,i) +                 &
    605                                                  particles(n)%weight_factor /  &
    606                                                  prt_count(k,j,i)
     607                               number_of_particles = prt_count(k,j,i)
     608                               IF (number_of_particles <= 0)  CYCLE
     609                               particles => grid_particles(k,j,i)%particles(1:number_of_particles)
     610                               DO  n = 1, number_of_particles
     611                                  IF ( particles(n)%particle_mask )  THEN
     612                                     tend(k,j,i) =  tend(k,j,i) +                 &
     613                                                    particles(n)%weight_factor /  &
     614                                                    prt_count(k,j,i)
     615                                  ENDIF
    607616                               ENDDO
    608617                            ENDDO
    … …  
    612621                   ELSE
    613622                      tend = 0.0_wp
    614                    END IF
     623                   ENDIF
    615624                   DO  i = nxlg, nxrg
    616625                      DO  j = nysg, nyng

  • TabularUnified palm/trunk/SOURCE/data_output_3d.f90

    r1354 r1359  
    2020! Current revisions:
    2121! ------------------
    22 !
     22! New particle structure integrated.
    2323!
    2424! Former revisions:
    … …  
    112112       
    113113    USE particle_attributes,                                                   &
    114         ONLY:  particles, prt_count, prt_start_index
     114        ONLY:  grid_particles, number_of_particles, particles,                 &
     115               particle_advection_start, prt_count
    115116       
    116117    USE pegrid
    … …  
    134135
    135136    REAL(wp)     ::  mean_r    !:
     137    REAL(wp)     ::  s_r2      !:
    136138    REAL(wp)     ::  s_r3      !:
    137     REAL(wp)     ::  s_r4      !:
    138139
    139140    REAL(sp), DIMENSION(:,:,:), ALLOCATABLE ::  local_pf  !:
    … …  
    239240          CASE ( 'pc' )  ! particle concentration (requires ghostpoint exchange)
    240241             IF ( av == 0 )  THEN
    241                 tend = prt_count
    242                 CALL exchange_horiz( tend, nbgp )
     242                IF ( simulated_time >= particle_advection_start )  THEN
     243                   tend = prt_count
     244                   CALL exchange_horiz( tend, nbgp )
     245                ELSE
     246                   tend = 0.0_wp
     247                ENDIF
    243248                DO  i = nxlg, nxrg
    244249                   DO  j = nysg, nyng
    … …  
    254259             ENDIF
    255260
    256           CASE ( 'pr' )  ! mean particle radius
    257              IF ( av == 0 )  THEN
    258                 DO  i = nxl, nxr
    259                    DO  j = nys, nyn
    260                       DO  k = nzb, nz_do3d
    261                          psi = prt_start_index(k,j,i)
    262                          s_r3 = 0.0_wp
    263                          s_r4 = 0.0_wp
    264                          DO  n = psi, psi+prt_count(k,j,i)-1
    265                          s_r3 = s_r3 + particles(n)%radius**3 *                &
    266                                        particles(n)%weight_factor
    267                          s_r4 = s_r4 + particles(n)%radius**4 *                &
    268                                        particles(n)%weight_factor
     261          CASE ( 'pr' )  ! mean particle radius (effective radius)
     262             IF ( av == 0 )  THEN
     263                IF ( simulated_time >= particle_advection_start )  THEN
     264                   DO  i = nxl, nxr
     265                      DO  j = nys, nyn
     266                         DO  k = nzb, nz_do3d
     267                            number_of_particles = prt_count(k,j,i)
     268                            IF (number_of_particles <= 0)  CYCLE
     269                            particles => grid_particles(k,j,i)%particles(1:number_of_particles)
     270                            s_r2 = 0.0_wp
     271                            s_r3 = 0.0_wp
     272                            DO  n = 1, number_of_particles
     273                               IF ( particles(n)%particle_mask )  THEN
     274                                  s_r2 = s_r2 + particles(n)%radius**2 * &
     275                                         particles(n)%weight_factor
     276                                  s_r3 = s_r3 + particles(n)%radius**3 * &
     277                                         particles(n)%weight_factor
     278                               ENDIF
     279                            ENDDO
     280                            IF ( s_r2 > 0.0_wp )  THEN
     281                               mean_r = s_r3 / s_r2
     282                            ELSE
     283                               mean_r = 0.0_wp
     284                            ENDIF
     285                            tend(k,j,i) = mean_r
    269286                         ENDDO
    270                          IF ( s_r3 /= 0.0_wp )  THEN
    271                             mean_r = s_r4 / s_r3
    272                          ELSE
    273                             mean_r = 0.0_wp
    274                          ENDIF
    275                          tend(k,j,i) = mean_r
    276                       ENDDO
    277                    ENDDO
    278                 ENDDO
    279                 CALL exchange_horiz( tend, nbgp )
     287                      ENDDO
     288                   ENDDO
     289                   CALL exchange_horiz( tend, nbgp )
     290                ELSE
     291                   tend = 0.0_wp
     292                ENDIF
    280293                DO  i = nxlg, nxrg
    281294                   DO  j = nysg, nyng
    … …  
    370383          CASE ( 'ql_vp' )
    371384             IF ( av == 0 )  THEN
    372                 DO  i = nxl, nxr
    373                    DO  j = nys, nyn
    374                       DO  k = nzb, nz_do3d
    375                          psi = prt_start_index(k,j,i)
    376                          DO  n = psi, psi+prt_count(k,j,i)-1
    377                             tend(k,j,i) = tend(k,j,i) +                        &
    378                                           particles(n)%weight_factor /         &
    379                                           prt_count(k,j,i)
     385                IF ( simulated_time >= particle_advection_start )  THEN
     386                   DO  i = nxl, nxr
     387                      DO  j = nys, nyn
     388                         DO  k = nzb, nz_do3d
     389                            number_of_particles = prt_count(k,j,i)
     390                            IF (number_of_particles <= 0)  CYCLE
     391                            particles => grid_particles(k,j,i)%particles(1:number_of_particles)
     392                            DO  n = 1, number_of_particles
     393                               IF ( particles(n)%particle_mask )  THEN
     394                                  tend(k,j,i) =  tend(k,j,i) +                 &
     395                                                 particles(n)%weight_factor /  &
     396                                                 prt_count(k,j,i)
     397                               ENDIF
     398                            ENDDO
    380399                         ENDDO
    381400                      ENDDO
    382401                   ENDDO
    383                 ENDDO
    384                 CALL exchange_horiz( tend, nbgp )
     402                   CALL exchange_horiz( tend, nbgp )
     403                ELSE
     404                   tend = 0.0_wp
     405                ENDIF
    385406                DO  i = nxlg, nxrg
    386407                   DO  j = nysg, nyng

  • TabularUnified palm/trunk/SOURCE/data_output_mask.f90

    r1354 r1359  
    2020! Current revisions:
    2121! -----------------
    22 !
     22! New particle structure integrated.
    2323!
    2424! Former revisions:
    … …  
    9696   
    9797    USE particle_attributes,                                                   &
    98         ONLY:  particles, prt_count, prt_start_index
     98        ONLY:  grid_particles, number_of_particles, particles,                 &
     99               particle_advection_start, prt_count
    99100   
    100101    USE pegrid
    … …  
    117118   
    118119    REAL(wp) ::  mean_r       !:
     120    REAL(wp) ::  s_r2         !:
    119121    REAL(wp) ::  s_r3         !:
    120     REAL(wp) ::  s_r4         !:
    121122   
    122123    REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  local_pf    !:
    … …  
    215216             ENDIF
    216217
    217           CASE ( 'pr' )  ! mean particle radius
    218              IF ( av == 0 )  THEN
    219                 DO  i = nxl, nxr
    220                    DO  j = nys, nyn
    221                       DO  k = nzb, nzt+1
    222                          psi = prt_start_index(k,j,i)
    223                          s_r3 = 0.0_wp
    224                          s_r4 = 0.0_wp
    225                          DO  n = psi, psi+prt_count(k,j,i)-1
    226                             s_r3 = s_r3 + particles(n)%radius**3 * &
    227                                           particles(n)%weight_factor
    228                             s_r4 = s_r4 + particles(n)%radius**4 * &
    229                                           particles(n)%weight_factor
     218          CASE ( 'pr' )  ! mean particle radius (effective radius)
     219             IF ( av == 0 )  THEN
     220                IF ( simulated_time >= particle_advection_start )  THEN
     221                   DO  i = nxl, nxr
     222                      DO  j = nys, nyn
     223                         DO  k = nzb, nz_do3d
     224                            number_of_particles = prt_count(k,j,i)
     225                            IF (number_of_particles <= 0)  CYCLE
     226                            particles => grid_particles(k,j,i)%particles(1:number_of_particles)
     227                            s_r2 = 0.0_wp
     228                            s_r3 = 0.0_wp
     229                            DO  n = 1, number_of_particles
     230                               IF ( particles(n)%particle_mask )  THEN
     231                                  s_r2 = s_r2 + grid_particles(k,j,i)%particles(n)%radius**2 * &
     232                                         grid_particles(k,j,i)%particles(n)%weight_factor
     233                                  s_r3 = s_r3 + grid_particles(k,j,i)%particles(n)%radius**3 * &
     234                                         grid_particles(k,j,i)%particles(n)%weight_factor
     235                               ENDIF
     236                            ENDDO
     237                            IF ( s_r2 > 0.0_wp )  THEN
     238                               mean_r = s_r3 / s_r2
     239                            ELSE
     240                               mean_r = 0.0_wp
     241                            ENDIF
     242                            tend(k,j,i) = mean_r
    230243                         ENDDO
    231                          IF ( s_r3 /= 0.0_wp )  THEN
    232                             mean_r = s_r4 / s_r3
    233                          ELSE
    234                             mean_r = 0.0_wp
    235                          ENDIF
    236                          tend(k,j,i) = mean_r
    237                       ENDDO
    238                    ENDDO
    239                 ENDDO
    240                 CALL exchange_horiz( tend, nbgp )
     244                      ENDDO
     245                   ENDDO
     246                   CALL exchange_horiz( tend, nbgp )
     247                ELSE
     248                   tend = 0.0_wp
     249                ENDIF
    241250                DO  i = 1, mask_size_l(mid,1)
    242251                   DO  j = 1, mask_size_l(mid,2)
    … …  
    304313          CASE ( 'ql_vp' )
    305314             IF ( av == 0 )  THEN
    306                 DO  i = nxl, nxr
    307                    DO  j = nys, nyn
    308                       DO  k = nzb, nz_do3d
    309                          psi = prt_start_index(k,j,i)
    310                          DO  n = psi, psi+prt_count(k,j,i)-1
    311                             tend(k,j,i) = tend(k,j,i) + &
     315                IF ( simulated_time >= particle_advection_start )  THEN
     316                   DO  i = nxl, nxr
     317                      DO  j = nys, nyn
     318                         DO  k = nzb, nz_do3d
     319                            number_of_particles = prt_count(k,j,i)
     320                            IF (number_of_particles <= 0)  CYCLE
     321                            particles => grid_particles(k,j,i)%particles(1:number_of_particles)
     322                            DO  n = 1, number_of_particles
     323                               IF ( particles(n)%particle_mask )  THEN
     324                                  tend(k,j,i) = tend(k,j,i) + &
    312325                                          particles(n)%weight_factor / &
    313326                                          prt_count(k,j,i)
     327                               ENDIF
     328                            ENDDO
    314329                         ENDDO
    315330                      ENDDO
    316331                   ENDDO
    317                 ENDDO
    318                 CALL exchange_horiz( tend, nbgp )
     332                   CALL exchange_horiz( tend, nbgp )
     333                ELSE
     334                   tend = 0.0_wp
     335                ENDIF
    319336                DO  i = 1, mask_size_l(mid,1)
    320337                   DO  j = 1, mask_size_l(mid,2)

  • TabularUnified palm/trunk/SOURCE/data_output_ptseries.f90

    r1354 r1359  
    2020! Current revisions:
    2121! -----------------
    22 !
     22! New particle structure integrated.
    2323!
    2424! Former revisions:
    … …  
    7070
    7171    USE indices,                                                               &
    72         ONLY:
     72        ONLY: nxl, nxr, nys, nyn, nzb, nzt
    7373
    7474    USE kinds
    … …  
    7777
    7878    USE particle_attributes,                                                   &
    79         ONLY:  number_of_particles, number_of_particle_groups, particles
     79        ONLY:  grid_particles, number_of_particles, number_of_particle_groups, &
     80               particles, prt_count
    8081
    8182    USE pegrid
    … …  
    8788    INTEGER(iwp) ::  inum !:
    8889    INTEGER(iwp) ::  j    !:
     90    INTEGER(iwp) ::  jg   !:
     91    INTEGER(iwp) ::  k    !:
    8992    INTEGER(iwp) ::  n    !:
    9093
    … …  
    120123!-- Calculate or collect the particle time series quantities for all particles
    121124!-- and seperately for each particle group (if there is more than one group)
    122     DO  n = 1, number_of_particles
    123 
    124        pts_value_l(0,1)  = number_of_particles            ! total # of particles
    125        pts_value_l(0,2)  = pts_value_l(0,2) + &
    126                            ( particles(n)%x - particles(n)%origin_x )  ! mean x
    127        pts_value_l(0,3)  = pts_value_l(0,3) + &
    128                            ( particles(n)%y - particles(n)%origin_y )  ! mean y
    129        pts_value_l(0,4)  = pts_value_l(0,4) + &
    130                            ( particles(n)%z - particles(n)%origin_z )  ! mean z
    131        pts_value_l(0,5)  = pts_value_l(0,5) + particles(n)%z ! mean z (absolute)
    132        pts_value_l(0,6)  = pts_value_l(0,6) + particles(n)%speed_x     ! mean u
    133        pts_value_l(0,7)  = pts_value_l(0,7) + particles(n)%speed_y     ! mean v
    134        pts_value_l(0,8)  = pts_value_l(0,8) + particles(n)%speed_z     ! mean w
    135        IF ( .NOT. curvature_solution_effects )  THEN
    136           pts_value_l(0,9)  = pts_value_l(0,9) + particles(n)%rvar1  ! mean sgsu
    137           pts_value_l(0,10) = pts_value_l(0,10) + particles(n)%rvar2 ! mean sgsv
    138           pts_value_l(0,11) = pts_value_l(0,11) + particles(n)%rvar3 ! mean sgsw
    139        ENDIF
    140        IF ( particles(n)%speed_z > 0.0_wp )  THEN
    141           pts_value_l(0,12) = pts_value_l(0,12) + 1.0_wp  ! # of upward moving prts
    142           pts_value_l(0,13) = pts_value_l(0,13) + &
    143                                             particles(n)%speed_z ! mean w upw.
    144        ELSE
    145           pts_value_l(0,14) = pts_value_l(0,14) + &
    146                                             particles(n)%speed_z ! mean w down
    147        ENDIF
    148        pts_value_l(0,15) = pts_value_l(0,15) + particles(n)%radius ! mean rad
    149        pts_value_l(0,16) = MIN( pts_value_l(0,16), particles(n)%radius ) ! minrad
    150        pts_value_l(0,17) = MAX( pts_value_l(0,17), particles(n)%radius ) ! maxrad
    151        pts_value_l(0,18) = number_of_particles
    152        pts_value_l(0,19) = number_of_particles
    153 
    154 !
    155 !--    Repeat the same for the respective particle group
    156        IF ( number_of_particle_groups > 1 )  THEN
    157           j = particles(n)%group
    158 
    159           pts_value_l(j,1)  = pts_value_l(j,1)  + 1
    160           pts_value_l(j,2)  = pts_value_l(j,2)  + &
    161                               ( particles(n)%x - particles(n)%origin_x )
    162           pts_value_l(j,3)  = pts_value_l(j,3)  + &
    163                               ( particles(n)%y - particles(n)%origin_y )
    164           pts_value_l(j,4)  = pts_value_l(j,4)  + &
    165                               ( particles(n)%z - particles(n)%origin_z )
    166           pts_value_l(j,5)  = pts_value_l(j,5)  + particles(n)%z
    167           pts_value_l(j,6)  = pts_value_l(j,6)  + particles(n)%speed_x
    168           pts_value_l(j,7)  = pts_value_l(j,7)  + particles(n)%speed_y
    169           pts_value_l(j,8)  = pts_value_l(j,8)  + particles(n)%speed_z
    170           IF ( .NOT. curvature_solution_effects )  THEN
    171              pts_value_l(j,9)  = pts_value_l(j,9)  + particles(n)%rvar1
    172              pts_value_l(j,10) = pts_value_l(j,10) + particles(n)%rvar2
    173              pts_value_l(j,11) = pts_value_l(j,11) + particles(n)%rvar3
    174           ENDIF
    175           IF ( particles(n)%speed_z > 0.0_wp )  THEN
    176              pts_value_l(j,12) = pts_value_l(j,12) + 1.0_wp
    177              pts_value_l(j,13) = pts_value_l(j,13) + particles(n)%speed_z
    178           ELSE
    179              pts_value_l(j,14) = pts_value_l(j,14) + particles(n)%speed_z
    180           ENDIF
    181           pts_value_l(j,15) = pts_value_l(j,15) + particles(n)%radius
    182           pts_value_l(j,16) = MIN( pts_value(j,16), particles(n)%radius )
    183           pts_value_l(j,17) = MAX( pts_value(j,17), particles(n)%radius )
    184           pts_value_l(j,18) = pts_value_l(j,18) + 1.0_wp
    185           pts_value_l(j,19) = pts_value_l(j,19) + 1.0_wp
    186 
    187        ENDIF
    188 
     125    DO  i = nxl, nxr
     126       DO  j = nys, nyn
     127          DO  k = nzb, nzt
     128             number_of_particles = prt_count(k,j,i)
     129             IF (number_of_particles <= 0)  CYCLE
     130             particles => grid_particles(k,j,i)%particles(1:number_of_particles)
     131             DO  n = 1, number_of_particles
     132
     133                IF ( particles(n)%particle_mask )  THEN  ! Restrict analysis to active particles
     134
     135                   pts_value_l(0,1)  = pts_value_l(0,1) + 1.0_wp  ! total # of particles
     136                   pts_value_l(0,2)  = pts_value_l(0,2) +                      &
     137                          ( particles(n)%x - particles(n)%origin_x )  ! mean x
     138                   pts_value_l(0,3)  = pts_value_l(0,3) +                      &
     139                          ( particles(n)%y - particles(n)%origin_y )  ! mean y
     140                   pts_value_l(0,4)  = pts_value_l(0,4) +                      &
     141                          ( particles(n)%z - particles(n)%origin_z )  ! mean z
     142                   pts_value_l(0,5)  = pts_value_l(0,5) + particles(n)%z        ! mean z (absolute)
     143                   pts_value_l(0,6)  = pts_value_l(0,6) + particles(n)%speed_x  ! mean u
     144                   pts_value_l(0,7)  = pts_value_l(0,7) + particles(n)%speed_y  ! mean v
     145                   pts_value_l(0,8)  = pts_value_l(0,8) + particles(n)%speed_z  ! mean w
     146                   IF ( .NOT. curvature_solution_effects )  THEN
     147                      pts_value_l(0,9)  = pts_value_l(0,9)  + particles(n)%rvar1 ! mean sgsu
     148                      pts_value_l(0,10) = pts_value_l(0,10) + particles(n)%rvar2 ! mean sgsv
     149                      pts_value_l(0,11) = pts_value_l(0,11) + particles(n)%rvar3 ! mean sgsw
     150                   ENDIF
     151                   IF ( particles(n)%speed_z > 0.0_wp )  THEN
     152                      pts_value_l(0,12) = pts_value_l(0,12) + 1.0_wp  ! # of upward moving prts
     153                      pts_value_l(0,13) = pts_value_l(0,13) +                  &
     154                                              particles(n)%speed_z ! mean w upw.
     155                   ELSE
     156                      pts_value_l(0,14) = pts_value_l(0,14) +                  &
     157                                              particles(n)%speed_z ! mean w down
     158                   ENDIF
     159                   pts_value_l(0,15) = pts_value_l(0,15) + particles(n)%radius ! mean rad
     160                   pts_value_l(0,16) = MIN( pts_value_l(0,16), particles(n)%radius ) ! minrad
     161                   pts_value_l(0,17) = MAX( pts_value_l(0,17), particles(n)%radius ) ! maxrad
     162                   pts_value_l(0,18) = pts_value_l(0,18) + 1.0_wp
     163                   pts_value_l(0,19) = pts_value_l(0,18) + 1.0_wp
     164!
     165!--                Repeat the same for the respective particle group
     166                   IF ( number_of_particle_groups > 1 )  THEN
     167                      jg = particles(n)%group
     168
     169                      pts_value_l(jg,1)  = pts_value_l(jg,1) + 1.0_wp
     170                      pts_value_l(jg,2)  = pts_value_l(jg,2) +                   &
     171                           ( particles(n)%x - particles(n)%origin_x )
     172                      pts_value_l(jg,3)  = pts_value_l(jg,3) +                   &
     173                           ( particles(n)%y - particles(n)%origin_y )
     174                      pts_value_l(jg,4)  = pts_value_l(jg,4) +                   &
     175                           ( particles(n)%z - particles(n)%origin_z )
     176                      pts_value_l(jg,5)  = pts_value_l(jg,5) + particles(n)%z
     177                      pts_value_l(jg,6)  = pts_value_l(jg,6) + particles(n)%speed_x
     178                      pts_value_l(jg,7)  = pts_value_l(jg,7) + particles(n)%speed_y
     179                      pts_value_l(jg,8)  = pts_value_l(jg,8) + particles(n)%speed_z
     180                      IF ( .NOT. curvature_solution_effects )  THEN
     181                         pts_value_l(jg,9)  = pts_value_l(jg,9)  + particles(n)%rvar1
     182                         pts_value_l(jg,10) = pts_value_l(jg,10) + particles(n)%rvar2
     183                         pts_value_l(jg,11) = pts_value_l(jg,11) + particles(n)%rvar3
     184                      ENDIF
     185                      IF ( particles(n)%speed_z > 0.0_wp )  THEN
     186                         pts_value_l(jg,12) = pts_value_l(jg,12) + 1.0_wp
     187                         pts_value_l(jg,13) = pts_value_l(jg,13) + particles(n)%speed_z
     188                      ELSE
     189                         pts_value_l(jg,14) = pts_value_l(jg,14) + particles(n)%speed_z
     190                      ENDIF
     191                      pts_value_l(jg,15) = pts_value_l(jg,15) + particles(n)%radius
     192                      pts_value_l(jg,16) = MIN( pts_value(jg,16), particles(n)%radius )
     193                      pts_value_l(jg,17) = MAX( pts_value(jg,17), particles(n)%radius )
     194                      pts_value_l(jg,18) = pts_value_l(jg,18) + 1.0_wp
     195                      pts_value_l(jg,19) = pts_value_l(jg,19) + 1.0_wp
     196                   ENDIF
     197
     198                ENDIF
     199
     200             ENDDO
     201
     202          ENDDO
     203       ENDDO
    189204    ENDDO
     205
    190206
    191207#if defined( __parallel )
    … …  
    243259!-- Calculate higher order moments of particle time series quantities,
    244260!-- seperately for each particle group (if there is more than one group)
    245     DO  n = 1, number_of_particles
    246 
    247        pts_value_l(0,20) = pts_value_l(0,20) + ( particles(n)%x - &
    248                            particles(n)%origin_x - pts_value(0,2) )**2 ! x*2
    249        pts_value_l(0,21) = pts_value_l(0,21) + ( particles(n)%y - &
    250                            particles(n)%origin_y - pts_value(0,3) )**2 ! y*2
    251        pts_value_l(0,22) = pts_value_l(0,22) + ( particles(n)%z - &
    252                            particles(n)%origin_z - pts_value(0,4) )**2 ! z*2
    253        pts_value_l(0,23) = pts_value_l(0,23) + ( particles(n)%speed_x - &
    254                                                 pts_value(0,6) )**2   ! u*2
    255        pts_value_l(0,24) = pts_value_l(0,24) + ( particles(n)%speed_y - &
    256                                                  pts_value(0,7) )**2   ! v*2
    257        pts_value_l(0,25) = pts_value_l(0,25) + ( particles(n)%speed_z - &
    258                                                  pts_value(0,8) )**2   ! w*2
    259        IF ( .NOT. curvature_solution_effects )  THEN
    260           pts_value_l(0,26) = pts_value_l(0,26) + ( particles(n)%rvar1 - &
    261                                                     pts_value(0,9) )**2   ! u"2
    262           pts_value_l(0,27) = pts_value_l(0,27) + ( particles(n)%rvar2 - &
    263                                                     pts_value(0,10) )**2  ! v"2
    264           pts_value_l(0,28) = pts_value_l(0,28) + ( particles(n)%rvar3 - &
    265                                                     pts_value(0,11) )**2  ! w"2
    266        ENDIF
    267 !
    268 !--    Repeat the same for the respective particle group
    269        IF ( number_of_particle_groups > 1 )  THEN
    270           j = particles(n)%group
    271 
    272           pts_value_l(j,20) = pts_value_l(j,20) + ( particles(n)%x - &
    273                               particles(n)%origin_x - pts_value(j,2) )**2
    274           pts_value_l(j,21) = pts_value_l(j,21) + ( particles(n)%y - &
    275                               particles(n)%origin_y - pts_value(j,3) )**2
    276           pts_value_l(j,22) = pts_value_l(j,22) + ( particles(n)%z - &
    277                               particles(n)%origin_z - pts_value(j,4) )**2
    278           pts_value_l(j,23) = pts_value_l(j,23) + ( particles(n)%speed_x - &
    279                                                     pts_value(j,6) )**2
    280           pts_value_l(j,24) = pts_value_l(j,24) + ( particles(n)%speed_y - &
    281                                                     pts_value(j,7) )**2
    282           pts_value_l(j,25) = pts_value_l(j,25) + ( particles(n)%speed_z - &
    283                                                     pts_value(j,8) )**2
    284           IF ( .NOT. curvature_solution_effects )  THEN
    285              pts_value_l(j,26) = pts_value_l(j,26) + ( particles(n)%rvar1 - &
    286                                                        pts_value(j,9) )**2
    287              pts_value_l(j,27) = pts_value_l(j,27) + ( particles(n)%rvar2 - &
    288                                                        pts_value(j,10) )**2
    289              pts_value_l(j,28) = pts_value_l(j,28) + ( particles(n)%rvar3 - &
    290                                                        pts_value(j,11) )**2
    291           ENDIF
    292        ENDIF
    293 
     261    DO  i = nxl, nxr
     262       DO  j = nys, nyn
     263          DO  k = nzb, nzt
     264             number_of_particles = prt_count(k,j,i)
     265             IF (number_of_particles <= 0)  CYCLE
     266             particles => grid_particles(k,j,i)%particles(1:number_of_particles)
     267             DO  n = 1, number_of_particles
     268
     269                pts_value_l(0,20) = pts_value_l(0,20) + ( particles(n)%x - &
     270                                    particles(n)%origin_x - pts_value(0,2) )**2 ! x*2
     271                pts_value_l(0,21) = pts_value_l(0,21) + ( particles(n)%y - &
     272                                    particles(n)%origin_y - pts_value(0,3) )**2 ! y*2
     273                pts_value_l(0,22) = pts_value_l(0,22) + ( particles(n)%z - &
     274                                    particles(n)%origin_z - pts_value(0,4) )**2 ! z*2
     275                pts_value_l(0,23) = pts_value_l(0,23) + ( particles(n)%speed_x - &
     276                                                         pts_value(0,6) )**2   ! u*2
     277                pts_value_l(0,24) = pts_value_l(0,24) + ( particles(n)%speed_y - &
     278                                                          pts_value(0,7) )**2   ! v*2
     279                pts_value_l(0,25) = pts_value_l(0,25) + ( particles(n)%speed_z - &
     280                                                          pts_value(0,8) )**2   ! w*2
     281                IF ( .NOT. curvature_solution_effects )  THEN
     282                   pts_value_l(0,26) = pts_value_l(0,26) + ( particles(n)%rvar1 - &
     283                                                             pts_value(0,9) )**2   ! u"2
     284                   pts_value_l(0,27) = pts_value_l(0,27) + ( particles(n)%rvar2 - &
     285                                                             pts_value(0,10) )**2  ! v"2
     286                   pts_value_l(0,28) = pts_value_l(0,28) + ( particles(n)%rvar3 - &
     287                                                             pts_value(0,11) )**2  ! w"2
     288                ENDIF
     289!
     290!--             Repeat the same for the respective particle group
     291                IF ( number_of_particle_groups > 1 )  THEN
     292                   jg = particles(n)%group
     293
     294                   pts_value_l(jg,20) = pts_value_l(jg,20) + ( particles(n)%x - &
     295                                       particles(n)%origin_x - pts_value(jg,2) )**2
     296                   pts_value_l(jg,21) = pts_value_l(jg,21) + ( particles(n)%y - &
     297                                       particles(n)%origin_y - pts_value(jg,3) )**2
     298                   pts_value_l(jg,22) = pts_value_l(jg,22) + ( particles(n)%z - &
     299                                       particles(n)%origin_z - pts_value(jg,4) )**2
     300                   pts_value_l(jg,23) = pts_value_l(jg,23) + ( particles(n)%speed_x - &
     301                                                             pts_value(jg,6) )**2
     302                   pts_value_l(jg,24) = pts_value_l(jg,24) + ( particles(n)%speed_y - &
     303                                                             pts_value(jg,7) )**2
     304                   pts_value_l(jg,25) = pts_value_l(jg,25) + ( particles(n)%speed_z - &
     305                                                             pts_value(jg,8) )**2
     306                   IF ( .NOT. curvature_solution_effects )  THEN
     307                      pts_value_l(jg,26) = pts_value_l(jg,26) + ( particles(n)%rvar1 - &
     308                                                                pts_value(jg,9) )**2
     309                      pts_value_l(jg,27) = pts_value_l(jg,27) + ( particles(n)%rvar2 - &
     310                                                                pts_value(jg,10) )**2
     311                      pts_value_l(jg,28) = pts_value_l(jg,28) + ( particles(n)%rvar3 - &
     312                                                                pts_value(jg,11) )**2
     313                   ENDIF
     314                ENDIF
     315
     316             ENDDO
     317          ENDDO
     318       ENDDO
    294319    ENDDO
    295320

  • TabularUnified palm/trunk/SOURCE/header.f90

    r1354 r1359  
    2020! Current revisions:
    2121! -----------------
    22 !
     22! dt_sort_particles removed
    2323!
    2424! Former revisions:
    … …  
    174174        ONLY:  bc_par_b, bc_par_lr, bc_par_ns, bc_par_t, collision_kernel,     &
    175175               density_ratio, dissipation_classes, dt_min_part, dt_prel,       &
    176                dt_sort_particles, dt_write_particle_data, end_time_prel,       &
     176               dt_write_particle_data, end_time_prel,                          &
    177177               maximum_number_of_tailpoints, maximum_tailpoint_age,            &
    178178               minimum_tailpoint_distance, number_of_particle_groups,          &
    … …  
    15761576       WRITE ( io, 480 )  particle_advection_start, dt_prel, bc_par_lr, &
    15771577                          bc_par_ns, bc_par_b, bc_par_t, particle_maximum_age, &
    1578                           end_time_prel, dt_sort_particles
     1578                          end_time_prel
    15791579       IF ( use_sgs_for_particles )  WRITE ( io, 488 )  dt_min_part
    15801580       IF ( random_start_position )  WRITE ( io, 481 )
    … …  
    20472047            '                            bottom:     ', A, ' top:         ', A/&
    20482048            '       Maximum particle age:                 ',F9.1,' s'/ &
    2049             '       Advection stopped at t = ',F9.1,' s'/ &
    2050             '       Particles are sorted every ',F9.1,' s'/)
     2049            '       Advection stopped at t = ',F9.1,' s'/)
    20512050481 FORMAT ('       Particles have random start positions'/)
    20522051482 FORMAT ('          Particles are advected only horizontally'/)

  • TabularUnified palm/trunk/SOURCE/init_3d_model.f90

    r1354 r1359  
    2020! Current revisions:
    2121! ------------------
    22 !
     22! module lpm_init_mod added to use statements, because lpm_init has become a
     23! module
    2324!
    2425! Former revisions:
    … …  
    168169   
    169170    USE indices
     171
     172    USE lpm_init_mod,                                                              &
     173        ONLY:  lpm_init
    170174   
    171175    USE kinds

  • TabularUnified palm/trunk/SOURCE/lpm.f90

    r1321 r1359  
    2020! Current revisions:
    2121! ------------------
    22 !
     22! New particle structure integrated.
     23! Kind definition added to all floating point numbers.
    2324!
    2425! Former revisions:
    … …  
    8283    USE control_parameters,                                                    &
    8384        ONLY:  cloud_droplets, dt_3d, dt_3d_reached, dt_3d_reached_l,          &
    84                molecular_viscosity, simulated_time
     85               molecular_viscosity, simulated_time, topography
    8586
    8687    USE cpulog,                                                                &
    8788        ONLY:  cpu_log, log_point, log_point_s
    8889
     90    USE indices,                                                               &
     91        ONLY: nxl, nxr, nys, nyn, nzb, nzt
     92
    8993    USE kinds
    9094
     95    USE lpm_exchange_horiz_mod,                                                &
     96        ONLY:  lpm_exchange_horiz, lpm_move_particle
     97
     98    USE lpm_pack_arrays_mod,                                                   &
     99        ONLY:  lpm_pack_all_arrays
     100
    91101    USE particle_attributes,                                                   &
    92         ONLY:  collision_kernel, deleted_particles, dt_sort_particles,         &
    93                deleted_tails, dt_write_particle_data, dt_prel, end_time_prel,  &
    94                number_of_particles, number_of_particle_groups,particles,      &
    95                particle_groups, particle_mask, trlp_count_sum, tail_mask,      &
    96                time_prel, time_sort_particles, time_write_particle_data,       &
    97                trlp_count_recv_sum, trnp_count_sum, trnp_count_recv_sum,       &
    98                trrp_count_sum, trrp_count_recv_sum, trsp_count_sum,            &
    99                trsp_count_recv_sum, use_particle_tails, use_sgs_for_particles, &
    100                write_particle_statistics
     102        ONLY:  collision_kernel, deleted_particles, deleted_tails,             &
     103               dt_write_particle_data, dt_prel, end_time_prel,                 &
     104               grid_particles, number_of_particles, number_of_particle_groups, &
     105               particles, particle_groups, prt_count, trlp_count_sum,          &
     106               tail_mask, time_prel, time_sort_particles,                      &
     107               time_write_particle_data, trlp_count_recv_sum, trnp_count_sum,  &
     108               trnp_count_recv_sum, trrp_count_sum, trrp_count_recv_sum,       &
     109               trsp_count_sum, trsp_count_recv_sum, use_particle_tails,        &
     110               use_sgs_for_particles, write_particle_statistics
    101111
    102112    USE pegrid
    … …  
    104114    IMPLICIT NONE
    105115
    106     INTEGER(iwp) ::  m                       !:
    107 
     116    INTEGER(iwp)       ::  i                  !:
     117    INTEGER(iwp)       ::  ie                 !:
     118    INTEGER(iwp)       ::  is                 !:
     119    INTEGER(iwp)       ::  j                  !:
     120    INTEGER(iwp)       ::  je                 !:
     121    INTEGER(iwp)       ::  js                 !:
     122    INTEGER(iwp)       ::  k                  !:
     123    INTEGER(iwp)       ::  ke                 !:
     124    INTEGER(iwp)       ::  ks                 !:
     125    INTEGER(iwp)       ::  m                  !:
     126    INTEGER(iwp), SAVE ::  steps = 0          !:
     127
     128    LOGICAL            ::  first_loop_stride  !:
    108129
    109130    CALL cpu_log( log_point(25), 'lpm', 'start' )
    … …  
    125146    ENDIF
    126147
    127 
    128148!
    129149!-- Initialize arrays for marking those particles/tails to be deleted after the
    130150!-- (sub-) timestep
    131     particle_mask     = .TRUE.
    132151    deleted_particles = 0
    133152
    … …  
    157176!-- of the particle groups
    158177    DO  m = 1, number_of_particle_groups
    159        IF ( particle_groups(m)%density_ratio /= 0.0 )  THEN
     178       IF ( particle_groups(m)%density_ratio /= 0.0_wp )  THEN
    160179          particle_groups(m)%exp_arg  =                                        &
    161                     4.5 * particle_groups(m)%density_ratio *                   &
     180                    4.5_wp * particle_groups(m)%density_ratio *                &
    162181                    molecular_viscosity / ( particle_groups(m)%radius )**2
    163           particle_groups(m)%exp_term = EXP( -particle_groups(m)%exp_arg * &
    164                                              dt_3d )
     182
     183          particle_groups(m)%exp_term = EXP( -particle_groups(m)%exp_arg *     &
     184                    dt_3d )
    165185       ENDIF
    166186    ENDDO
    167187
    168 
    169 !
    170 !-- Particle (droplet) growth by condensation/evaporation and collision
    171     IF ( cloud_droplets )  THEN
    172 
    173 !
    174 !--    Reset summation arrays
    175        ql_c = 0.0;  ql_v = 0.0;  ql_vp = 0.0
    176 
    177 !
    178 !--    Droplet growth by condensation / evaporation
    179        CALL lpm_droplet_condensation
    180 
    181 !
    182 !--    Particle growth by collision
    183        IF ( collision_kernel /= 'none' )  CALL lpm_droplet_collision
    184 
    185     ENDIF
    186 
    187 
    188 !
    189 !-- If particle advection includes SGS velocity components, calculate the
    190 !-- required SGS quantities (i.e. gradients of the TKE, as well as horizontally
    191 !-- averaged profiles of the SGS TKE and the resolved-scale velocity variances)
    192     IF ( use_sgs_for_particles )  CALL lpm_init_sgs_tke
    193 
    194 
    195 !
    196 !-- Initialize the variable storing the total time that a particle has advanced
    197 !-- within the timestep procedure
    198     particles(1:number_of_particles)%dt_sum = 0.0
    199 
    200 
     188!
     189!-- If necessary, release new set of particles
     190    IF ( time_prel >= dt_prel  .AND.  end_time_prel > simulated_time )  THEN
     191
     192       CALL lpm_release_set
     193!
     194!--    The MOD function allows for changes in the output interval with
     195!--    restart runs.
     196       time_prel = MOD( time_prel, MAX( dt_prel, dt_3d ) )
     197
     198    ENDIF
     199!
     200!-- Reset summation arrays
     201    IF ( cloud_droplets)  THEN
     202       ql_c  = 0.0_wp
     203       ql_v  = 0.0_wp
     204       ql_vp = 0.0_wp
     205    ENDIF
     206
     207    first_loop_stride = .TRUE.
     208    grid_particles(:,:,:)%time_loop_done = .TRUE.
    201209!
    202210!-- Timestep loop for particle advection.
    … …  
    204212!-- (within the total domain!) has reached the LES timestep (dt_3d).
    205213!-- In case of including the SGS velocities, the particle timestep may be
    206 !-- smaller than the LES timestep (because of the Lagrangian timescale restric-
    207 !-- tion) and particles may require to undergo several particle timesteps,
    208 !-- before the LES timestep is reached. Because the number of these particle
    209 !-- timesteps to be carried out is unknown at first, these steps are carried
    210 !-- out in the following infinite loop with exit condition.
     214!-- smaller than the LES timestep (because of the Lagrangian timescale
     215!-- restriction) and particles may require to undergo several particle
     216!-- timesteps, before the LES timestep is reached. Because the number of these
     217!-- particle timesteps to be carried out is unknown at first, these steps are
     218!-- carried out in the following infinite loop with exit condition.
    211219    DO
    212 
    213220       CALL cpu_log( log_point_s(44), 'lpm_advec', 'start' )
    214 
    215 !
    216 !--    Initialize the switch used for the loop exit condition checked at the
    217 !--    end of this loop.
    218 !--    If at least one particle has failed to reach the LES timestep, this
    219 !--    switch will be set false.
    220        dt_3d_reached_l = .TRUE.
    221 
    222 !
    223 !--    Particle advection
    224        CALL lpm_advec
    225 
    226 !
    227 !--    Particle reflection from walls
    228        CALL lpm_boundary_conds( 'walls' )
    229 
    230 !
    231 !--    User-defined actions after the calculation of the new particle position
    232        CALL user_lpm_advec
     221       CALL cpu_log( log_point_s(44), 'lpm_advec', 'pause' )
     222!
     223!--    If particle advection includes SGS velocity components, calculate the
     224!--    required SGS quantities (i.e. gradients of the TKE, as well as
     225!--    horizontally averaged profiles of the SGS TKE and the resolved-scale
     226!--    velocity variances)
     227
     228       IF ( use_sgs_for_particles )  CALL lpm_init_sgs_tke
     229
     230       DO  i = nxl, nxr
     231          DO  j = nys, nyn
     232             DO  k = nzb+1, nzt
     233
     234                number_of_particles = prt_count(k,j,i)
     235!
     236!--             If grid cell gets empty, flag must be true
     237                IF ( number_of_particles <= 0 )  THEN
     238                   grid_particles(k,j,i)%time_loop_done = .TRUE.
     239                   CYCLE
     240                ENDIF
     241
     242                IF ( .NOT. first_loop_stride  .AND.  &
     243                     grid_particles(k,j,i)%time_loop_done ) CYCLE
     244
     245                particles => grid_particles(k,j,i)%particles(1:number_of_particles)
     246
     247                particles(1:number_of_particles)%particle_mask = .TRUE.
     248!
     249!--             Initialize the variable storing the total time that a particle
     250!--             has advanced within the timestep procedure
     251                IF ( first_loop_stride )  THEN
     252                   particles(1:number_of_particles)%dt_sum = 0.0_wp
     253                ENDIF
     254!
     255!--             Particle (droplet) growth by condensation/evaporation and
     256!--             collision
     257                IF ( cloud_droplets  .AND.  first_loop_stride)  THEN
     258!
     259!--                Droplet growth by condensation / evaporation
     260                   CALL lpm_droplet_condensation(i,j,k)
     261!
     262!--                Particle growth by collision
     263                   IF ( collision_kernel /= 'none' )  THEN
     264                      CALL lpm_droplet_collision(i,j,k)
     265                   ENDIF
     266
     267                ENDIF
     268!
     269!--             Initialize the switch used for the loop exit condition checked
     270!--             at the end of this loop. If at least one particle has failed to
     271!--             reach the LES timestep, this switch will be set false in
     272!--             lpm_advec.
     273                dt_3d_reached_l = .TRUE.
     274
     275!
     276!--             Particle advection
     277                CALL lpm_advec(i,j,k)
     278!
     279!--             Particle reflection from walls
     280                IF ( topography /= 'flat' )  THEN
     281                   CALL lpm_boundary_conds( 'walls' )
     282                ENDIF
     283!
     284!--             User-defined actions after the calculation of the new particle
     285!--             position
     286                CALL user_lpm_advec
     287!
     288!--             Apply boundary conditions to those particles that have crossed
     289!--             the top or bottom boundary and delete those particles, which are
     290!--             older than allowed
     291                CALL lpm_boundary_conds( 'bottom/top' )
     292!
     293!---            If not all particles of the actual grid cell have reached the
     294!--             LES timestep, this cell has to to another loop iteration. Due to
     295!--             the fact that particles can move into neighboring grid cell,
     296!--             these neighbor cells also have to perform another loop iteration
     297                IF ( .NOT. dt_3d_reached_l )  THEN
     298                   ks = MAX(nzb+1,k)
     299                   ke = MIN(nzt,k)
     300                   js = MAX(nys,j)
     301                   je = MIN(nyn,j)
     302                   is = MAX(nxl,i)
     303                   ie = MIN(nxr,i)
     304                   grid_particles(ks:ke,js:je,is:ie)%time_loop_done = .FALSE.
     305                ENDIF
     306
     307             ENDDO
     308          ENDDO
     309       ENDDO
     310
     311       steps = steps + 1
     312       dt_3d_reached_l = ALL(grid_particles(:,:,:)%time_loop_done)
    233313
    234314!
    … …  
    250330
    251331!
    252 !--    If necessary, release new set of particles
    253        IF ( time_prel >= dt_prel  .AND.  end_time_prel > simulated_time  .AND. &
    254             dt_3d_reached )  THEN
    255 
    256           CALL lpm_release_set
    257 
    258 !
    259 !--       The MOD function allows for changes in the output interval with
    260 !--       restart runs.
    261           time_prel = MOD( time_prel, MAX( dt_prel, dt_3d ) )
    262 
    263        ENDIF
     332!--    Move Particles local to PE to a different grid cell
     333       CALL lpm_move_particle
    264334
    265335!
    … …  
    268338
    269339!
    270 !--    Apply boundary conditions to those particles that have crossed the top or
    271 !--    bottom boundary and delete those particles, which are older than allowed
    272        CALL lpm_boundary_conds( 'bottom/top' )
    273 
    274 !
    275340!--    Pack particles (eliminate those marked for deletion),
    276341!--    determine new number of particles
    277        IF ( number_of_particles > 0  .AND.  deleted_particles > 0 )  THEN
    278           CALL lpm_pack_arrays
    279        ENDIF
    280 
    281 !
    282 !--    Initialize variables for the next (sub-) timestep, i.e. for marking those
    283 !--    particles to be deleted after the timestep
    284        particle_mask     = .TRUE.
     342       CALL lpm_pack_all_arrays
     343
     344!
     345!--    Initialize variables for the next (sub-) timestep, i.e., for marking
     346!--    those particles to be deleted after the timestep
    285347       deleted_particles = 0
    286348
    … …  
    293355       IF ( dt_3d_reached )  EXIT
    294356
     357       first_loop_stride = .FALSE.
    295358    ENDDO   ! timestep loop
    296359
    297 
    298 !
    299 !-- Sort particles in the sequence the gridboxes are stored in the memory
    300     time_sort_particles = time_sort_particles + dt_3d
    301     IF ( time_sort_particles >= dt_sort_particles )  THEN
    302        CALL lpm_sort_arrays
    303        time_sort_particles = MOD( time_sort_particles, &
    304                                   MAX( dt_sort_particles, dt_3d ) )
    305     ENDIF
    306 
    307 
    308360!
    309361!-- Calculate the new liquid water content for each grid box
    310     IF ( cloud_droplets )  CALL lpm_calc_liquid_water_content
     362    IF ( cloud_droplets )  THEN
     363       CALL lpm_calc_liquid_water_content
     364    ENDIF
     365
    311366
    312367
    … …  
    325380
    326381!
     382!-- particle tails currently not available
     383!
    327384!-- If required, add the current particle positions to the particle tails
    328     IF ( use_particle_tails )  CALL lpm_extend_tails
     385!   IF ( use_particle_tails )  CALL lpm_extend_tails
    329386
    330387
    … …  
    336393    CALL cpu_log( log_point(25), 'lpm', 'stop' )
    337394
    338 
    339395 END SUBROUTINE lpm

  • TabularUnified palm/trunk/SOURCE/lpm_advec.f90

    r1323 r1359  
    1  SUBROUTINE lpm_advec
     1 SUBROUTINE lpm_advec (ip,jp,kp)
    22
    33!--------------------------------------------------------------------------------!
    … …  
    2020! Current revisions:
    2121! ------------------
    22 !
     22! New particle structure integrated.
     23! Kind definition added to all floating point numbers.
    2324!
    2425! Former revisions:
    … …  
    5657
    5758    USE arrays_3d,                                                             &
    58         ONLY:  de_dx, de_dy, de_dz, diss, e, u, us, usws, v, vsws, w, z0, zu, zw
     59        ONLY:  de_dx, de_dy, de_dz, diss, e, u, us, usws, v, vsws, w, z0, zu,  &
     60               zw
     61
     62    USE cpulog
     63
     64    USE interfaces
     65
     66    USE pegrid
    5967
    6068    USE control_parameters,                                                    &
    6169        ONLY:  atmos_ocean_sign, cloud_droplets, dt_3d, dt_3d_reached_l, dz,   &
    6270               g, kappa, molecular_viscosity, prandtl_layer, topography,       &
    63                u_gtrans, v_gtrans
     71               u_gtrans, v_gtrans, simulated_time
    6472
    6573    USE grid_variables,                                                        &
    … …  
    7280   
    7381    USE particle_attributes,                                                   &
    74         ONLY:  c_0, density_ratio, dt_min_part, iran_part, log_z_z0,           &
    75                number_of_particles, number_of_sublayers, particles,            &
    76                particle_groups, offset_ocean_nzt, offset_ocean_nzt_m1,         &
    77                sgs_wfu_part, sgs_wfv_part, sgs_wfw_part, use_sgs_for_particles,&
    78                vertical_particle_advection, z0_av_global
     82        ONLY:  block_offset, c_0, density_ratio, dt_min_part, grid_particles,  &
     83               iran_part, log_z_z0, number_of_particles, number_of_sublayers,  &
     84               particles, particle_groups, offset_ocean_nzt,                   &
     85               offset_ocean_nzt_m1, sgs_wfu_part, sgs_wfv_part, sgs_wfw_part,  &
     86               use_sgs_for_particles, vertical_particle_advection, z0_av_global
    7987       
    8088    USE statistics,                                                            &
    8189        ONLY:  hom
    82        
    8390
    8491    IMPLICIT NONE
    … …  
    8794    INTEGER(iwp) ::  gp_outside_of_building(1:8) !:
    8895    INTEGER(iwp) ::  i                           !:
     96    INTEGER(iwp) ::  ip                          !:
    8997    INTEGER(iwp) ::  j                           !:
     98    INTEGER(iwp) ::  jp                          !:
    9099    INTEGER(iwp) ::  k                           !:
     100    INTEGER(iwp) ::  kp                          !:
    91101    INTEGER(iwp) ::  kw                          !:
    92102    INTEGER(iwp) ::  n                           !:
     103    INTEGER(iwp) ::  nb                          !:
    93104    INTEGER(iwp) ::  num_gp                      !:
     105
     106    INTEGER(iwp), DIMENSION(0:7) ::  start_index !:
     107    INTEGER(iwp), DIMENSION(0:7) ::  end_index   !:
    94108
    95109    REAL(wp) ::  aa                 !:
    … …  
    99113    REAL(wp) ::  d_z_p_z0           !:
    100114    REAL(wp) ::  dd                 !:
    101     REAL(wp) ::  de_dx_int          !:
    102115    REAL(wp) ::  de_dx_int_l        !:
    103116    REAL(wp) ::  de_dx_int_u        !:
    104     REAL(wp) ::  de_dy_int          !:
    105117    REAL(wp) ::  de_dy_int_l        !:
    106118    REAL(wp) ::  de_dy_int_u        !:
    107119    REAL(wp) ::  de_dt              !:
    108120    REAL(wp) ::  de_dt_min          !:
    109     REAL(wp) ::  de_dz_int          !:
    110121    REAL(wp) ::  de_dz_int_l        !:
    111122    REAL(wp) ::  de_dz_int_u        !:
    112     REAL(wp) ::  dens_ratio         !:
    113     REAL(wp) ::  diss_int           !:
    114123    REAL(wp) ::  diss_int_l         !:
    115124    REAL(wp) ::  diss_int_u         !:
    116125    REAL(wp) ::  dt_gap             !:
    117     REAL(wp) ::  dt_particle        !:
    118126    REAL(wp) ::  dt_particle_m      !:
    119     REAL(wp) ::  e_int              !:
    120127    REAL(wp) ::  e_int_l            !:
    121128    REAL(wp) ::  e_int_u            !:
    … …  
    123130    REAL(wp) ::  exp_arg            !:
    124131    REAL(wp) ::  exp_term           !:
    125     REAL(wp) ::  fs_int             !:
    126132    REAL(wp) ::  gg                 !:
    127133    REAL(wp) ::  height_int         !:
    … …  
    129135    REAL(wp) ::  lagr_timescale     !:
    130136    REAL(wp) ::  location(1:30,1:3) !:
    131     REAL(wp) ::  log_z_z0_int       !:
    132137    REAL(wp) ::  random_gauss       !:
    133     REAL(wp) ::  u_int              !:
    134138    REAL(wp) ::  u_int_l            !:
    135139    REAL(wp) ::  u_int_u            !:
    136140    REAL(wp) ::  us_int             !:
    137     REAL(wp) ::  v_int              !:
    138141    REAL(wp) ::  v_int_l            !:
    139142    REAL(wp) ::  v_int_u            !:
    140143    REAL(wp) ::  vv_int             !:
    141     REAL(wp) ::  w_int              !:
    142144    REAL(wp) ::  w_int_l            !:
    143145    REAL(wp) ::  w_int_u            !:
    … …  
    153155    REAL(wp), DIMENSION(1:30) ::  ei      !:
    154156
     157    REAL(wp), DIMENSION(number_of_particles) ::  dens_ratio   !:
     158    REAL(wp), DIMENSION(number_of_particles) ::  de_dx_int    !:
     159    REAL(wp), DIMENSION(number_of_particles) ::  de_dy_int    !:
     160    REAL(wp), DIMENSION(number_of_particles) ::  de_dz_int    !:
     161    REAL(wp), DIMENSION(number_of_particles) ::  diss_int     !:
     162    REAL(wp), DIMENSION(number_of_particles) ::  dt_particle  !:
     163    REAL(wp), DIMENSION(number_of_particles) ::  e_int        !:
     164    REAL(wp), DIMENSION(number_of_particles) ::  fs_int       !:
     165    REAL(wp), DIMENSION(number_of_particles) ::  log_z_z0_int !:
     166    REAL(wp), DIMENSION(number_of_particles) ::  u_int        !:
     167    REAL(wp), DIMENSION(number_of_particles) ::  v_int        !:
     168    REAL(wp), DIMENSION(number_of_particles) ::  w_int        !:
     169    REAL(wp), DIMENSION(number_of_particles) ::  xv           !:
     170    REAL(wp), DIMENSION(number_of_particles) ::  yv           !:
     171    REAL(wp), DIMENSION(number_of_particles) ::  zv           !:
     172
     173    REAL(wp), DIMENSION(number_of_particles, 3) ::  rg !:
     174
     175    CALL cpu_log( log_point_s(44), 'lpm_advec', 'continue' )
     176
    155177!
    156178!-- Determine height of Prandtl layer and distance between Prandtl-layer
    … …  
    159181!-- (for particles below first vertical grid level).
    160182    z_p      = zu(nzb+1) - zw(nzb)
    161     d_z_p_z0 = 1.0 / ( z_p - z0_av_global )
    162 
    163     DO  n = 1, number_of_particles
    164 
    165 !
    166 !--    Move particle only if the LES timestep has not (approximately) been
    167 !--    reached
    168        IF ( ( dt_3d - particles(n)%dt_sum ) < 1E-8 )  CYCLE
    169 !
    170 !--    Determine bottom index
    171        k = ( particles(n)%z + 0.5 * dz * atmos_ocean_sign ) / dz  &
    172               + offset_ocean_nzt       ! only exact if equidistant
    173 !
    174 !--    Interpolation of the u velocity component onto particle position. 
    175 !--    Particles are interpolation bi-linearly in the horizontal and a
    176 !--    linearly in the vertical. An exception is made for particles below
    177 !--    the first vertical grid level in case of a prandtl layer. In this
    178 !--    case the horizontal particle velocity components are determined using
    179 !--    Monin-Obukhov relations (if branch).
    180 !--    First, check if particle is located below first vertical grid level
    181 !--    (Prandtl-layer height)
    182        IF ( prandtl_layer .AND. particles(n)%z < z_p )  THEN
    183 !
    184 !--       Resolved-scale horizontal particle velocity is zero below z0.
    185           IF ( particles(n)%z < z0_av_global )  THEN
    186 
    187              u_int = 0.0
    188 
     183    d_z_p_z0 = 1.0_wp / ( z_p - z0_av_global )
     184
     185    start_index = grid_particles(kp,jp,ip)%start_index
     186    end_index   = grid_particles(kp,jp,ip)%end_index
     187
     188    xv = particles(1:number_of_particles)%x
     189    yv = particles(1:number_of_particles)%y
     190    zv = particles(1:number_of_particles)%z
     191
     192    DO  nb = 0, 7
     193
     194       i = ip
     195       j = jp + block_offset(nb)%j_off
     196       k = kp + block_offset(nb)%k_off
     197
     198!
     199!--    Interpolate u velocity-component
     200       DO  n = start_index(nb), end_index(nb)
     201!
     202!--       Interpolation of the u velocity component onto particle position. 
     203!--       Particles are interpolation bi-linearly in the horizontal and a
     204!--       linearly in the vertical. An exception is made for particles below
     205!--       the first vertical grid level in case of a prandtl layer. In this
     206!--       case the horizontal particle velocity components are determined using
     207!--       Monin-Obukhov relations (if branch).
     208!--       First, check if particle is located below first vertical grid level
     209!--       (Prandtl-layer height)
     210          IF ( prandtl_layer  .AND.  particles(n)%z < z_p )  THEN
     211!
     212!--          Resolved-scale horizontal particle velocity is zero below z0.
     213             IF ( particles(n)%z < z0_av_global )  THEN
     214                u_int(n) = 0.0_wp
     215             ELSE
     216!
     217!--             Determine the sublayer. Further used as index.
     218                height_p     = ( particles(n)%z - z0_av_global )            &
     219                                     * REAL( number_of_sublayers, KIND=wp ) &
     220                                     * d_z_p_z0
     221!
     222!--             Calculate LOG(z/z0) for exact particle height. Therefore,   
     223!--             interpolate linearly between precalculated logarithm.
     224                log_z_z0_int(n) = log_z_z0(INT(height_p))                      &
     225                                 + ( height_p - INT(height_p) )                &
     226                                 * ( log_z_z0(INT(height_p)+1)                 &
     227                                      - log_z_z0(INT(height_p))                &
     228                                   )
     229!
     230!--             Neutral solution is applied for all situations, e.g. also for
     231!--             unstable and stable situations. Even though this is not exact
     232!--             this saves a lot of CPU time since several calls of intrinsic
     233!--             FORTRAN procedures (LOG, ATAN) are avoided, This is justified
     234!--             as sensitivity studies revealed no significant effect of
     235!--             using the neutral solution also for un/stable situations.
     236!--             Calculated left and bottom index on u grid.
     237                us_int = 0.5_wp * ( us(j,i) + us(j,i-1) ) 
     238
     239                u_int  = -usws(j,i) / ( us_int * kappa + 1E-10_wp )           &
     240                         * log_z_z0_int(n)
     241
     242             ENDIF
     243!
     244!--       Particle above the first grid level. Bi-linear interpolation in the
     245!--       horizontal and linear interpolation in the vertical direction.
    189246          ELSE
    190 !
    191 !--          Determine the sublayer. Further used as index.
    192              height_p     = ( particles(n)%z - z0_av_global )            &
    193                                   * REAL( number_of_sublayers, KIND=wp ) &
    194                                   * d_z_p_z0
    195 !
    196 !--          Calculate LOG(z/z0) for exact particle height. Therefore,   
    197 !--          interpolate linearly between precalculated logarithm.
    198              log_z_z0_int = log_z_z0(INT(height_p))                     &
    199                           + ( height_p - INT(height_p) )                &
    200                           * ( log_z_z0(INT(height_p)+1)                 &
    201                                - log_z_z0(INT(height_p))                &
    202                             )
    203 !
    204 !--          Neutral solution is applied for all situations, e.g. also for
    205 !--          unstable and stable situations. Even though this is not exact
    206 !--          this saves a lot of CPU time since several calls of intrinsic
    207 !--          FORTRAN procedures (LOG, ATAN) are avoided, This is justified
    208 !--          as sensitivity studies revealed no significant effect of
    209 !--          using the neutral solution also for un/stable situations.
    210 !--          Calculated left and bottom index on u grid.
    211              i      = ( particles(n)%x + 0.5 * dx ) * ddx
    212              j      =   particles(n)%y              * ddy
    213 
    214              us_int = 0.5 * ( us(j,i) + us(j,i-1) ) 
    215 
    216              u_int  = -usws(j,i) / ( us_int * kappa + 1E-10_wp )           &
    217                       * log_z_z0_int
    218 
    219           ENDIF
    220 !
    221 !--    Particle above the first grid level. Bi-linear interpolation in the
    222 !--    horizontal and linear interpolation in the vertical direction.
    223        ELSE
    224 !
    225 !--       Interpolate u velocity-component, determine left, front, bottom
    226 !--       index of u-array. Adopt k index from above
    227           i = ( particles(n)%x + 0.5 * dx ) * ddx
    228           j =   particles(n)%y * ddy
    229 !
    230 !--       Interpolation of the velocity components in the xy-plane
    231           x  = particles(n)%x + ( 0.5 - i ) * dx
    232           y  = particles(n)%y - j * dy
    233           aa = x**2          + y**2
    234           bb = ( dx - x )**2 + y**2
    235           cc = x**2          + ( dy - y )**2
    236           dd = ( dx - x )**2 + ( dy - y )**2
    237           gg = aa + bb + cc + dd
    238 
    239           u_int_l = ( ( gg - aa ) * u(k,j,i)   + ( gg - bb ) * u(k,j,i+1)  &
    240                     + ( gg - cc ) * u(k,j+1,i) + ( gg - dd ) * u(k,j+1,i+1)&
    241                     ) / ( 3.0 * gg ) - u_gtrans
    242 
    243           IF ( k+1 == nzt+1 )  THEN
    244 
    245              u_int = u_int_l
    246 
    247           ELSE
    248 
    249              u_int_u = ( ( gg-aa ) * u(k+1,j,i)   + ( gg-bb ) * u(k+1,j,i+1)   &
    250                        + ( gg-cc ) * u(k+1,j+1,i) + ( gg-dd ) * u(k+1,j+1,i+1) &
    251                        ) / ( 3.0 * gg ) - u_gtrans
    252 
    253              u_int = u_int_l + ( particles(n)%z - zu(k) ) / dz *            &
    254                             ( u_int_u - u_int_l )
    255 
    256           ENDIF
    257 
    258        ENDIF
    259 
    260 !
    261 !--    Same procedure for interpolation of the v velocity-component.
    262        IF ( prandtl_layer .AND. particles(n)%z < z_p )  THEN
    263 !
    264 !--       Resolved-scale horizontal particle velocity is zero below z0.
    265           IF ( particles(n)%z < z0_av_global )  THEN
    266 
    267              v_int = 0.0
    268 
    269           ELSE       
    270 !
    271 !--          Neutral solution is applied for all situations, e.g. also for
    272 !--          unstable and stable situations. Even though this is not exact
    273 !--          this saves a lot of CPU time since several calls of intrinsic
    274 !--          FORTRAN procedures (LOG, ATAN) are avoided, This is justified
    275 !--          as sensitivity studies revealed no significant effect of
    276 !--          using the neutral solution also for un/stable situations.
    277 !--          Calculated left and bottom index on v grid.
    278               i      =   particles(n)%x              * ddx
    279               j      = ( particles(n)%y + 0.5 * dy ) * ddy
    280 
    281               us_int = 0.5 * ( us(j,i) + us(j-1,i) )   
    282 
    283               v_int  = -vsws(j,i) / ( us_int * kappa + 1E-10_wp )             &
    284                        * log_z_z0_int
    285 
    286           ENDIF
    287 !
    288 !--    Particle above the first grid level. Bi-linear interpolation in the
    289 !--    horizontal and linear interpolation in the vertical direction.
    290        ELSE
    291           i =   particles(n)%x * ddx
    292           j = ( particles(n)%y + 0.5 * dy ) * ddy
    293           x  = particles(n)%x - i * dx
    294           y  = particles(n)%y + ( 0.5 - j ) * dy
    295           aa = x**2          + y**2
    296           bb = ( dx - x )**2 + y**2
    297           cc = x**2          + ( dy - y )**2
    298           dd = ( dx - x )**2 + ( dy - y )**2
    299           gg = aa + bb + cc + dd
    300 
    301           v_int_l = ( ( gg - aa ) * v(k,j,i)   + ( gg - bb ) * v(k,j,i+1)  &
    302                     + ( gg - cc ) * v(k,j+1,i) + ( gg - dd ) * v(k,j+1,i+1)&
    303                     ) / ( 3.0 * gg ) - v_gtrans
    304           IF ( k+1 == nzt+1 )  THEN
    305              v_int = v_int_l
    306           ELSE
    307              v_int_u = ( ( gg-aa ) * v(k+1,j,i)   + ( gg-bb ) * v(k+1,j,i+1)   &
    308                        + ( gg-cc ) * v(k+1,j+1,i) + ( gg-dd ) * v(k+1,j+1,i+1) &
    309                        ) / ( 3.0 * gg ) - v_gtrans
    310              v_int = v_int_l + ( particles(n)%z - zu(k) ) / dz *           &
    311                             ( v_int_u - v_int_l )
    312           ENDIF
    313 
    314        ENDIF
    315 
    316 !
    317 !--    Same procedure for interpolation of the w velocity-component
    318        IF ( vertical_particle_advection(particles(n)%group) )  THEN
    319           i = particles(n)%x * ddx
    320           j = particles(n)%y * ddy
    321           k = particles(n)%z / dz + offset_ocean_nzt_m1
    322 
    323           x  = particles(n)%x - i * dx
    324           y  = particles(n)%y - j * dy
    325           aa = x**2          + y**2
    326           bb = ( dx - x )**2 + y**2
    327           cc = x**2          + ( dy - y )**2
    328           dd = ( dx - x )**2 + ( dy - y )**2
    329           gg = aa + bb + cc + dd
    330 
    331           w_int_l = ( ( gg - aa ) * w(k,j,i)   + ( gg - bb ) * w(k,j,i+1)    &
    332                     + ( gg - cc ) * w(k,j+1,i) + ( gg - dd ) * w(k,j+1,i+1)  &
    333                        ) / ( 3.0 * gg )
    334           IF ( k+1 == nzt+1 )  THEN
    335              w_int = w_int_l
    336           ELSE
    337              w_int_u = ( ( gg-aa ) * w(k+1,j,i)   + &
    338                          ( gg-bb ) * w(k+1,j,i+1) + &
    339                          ( gg-cc ) * w(k+1,j+1,i) + &
    340                          ( gg-dd ) * w(k+1,j+1,i+1) &
    341                         ) / ( 3.0 * gg )
    342              w_int = w_int_l + ( particles(n)%z - zw(k) ) / dz * &
    343                                ( w_int_u - w_int_l )
    344           ENDIF
    345        ELSE
    346           w_int = 0.0
    347        ENDIF
    348 
    349 !
    350 !--    Interpolate and calculate quantities needed for calculating the SGS
    351 !--    velocities
    352        IF ( use_sgs_for_particles )  THEN
    353 !
    354 !--       Interpolate TKE
    355           i = particles(n)%x * ddx
    356           j = particles(n)%y * ddy
    357           k = ( particles(n)%z + 0.5 * dz * atmos_ocean_sign ) / dz  &
    358               + offset_ocean_nzt                      ! only exact if eq.dist
    359 
    360           IF ( topography == 'flat' )  THEN
    361 
    362              x  = particles(n)%x - i * dx
    363              y  = particles(n)%y - j * dy
     247
     248             x  = xv(n) + ( 0.5_wp - i ) * dx
     249             y  = yv(n) - j * dy
    364250             aa = x**2          + y**2
    365251             bb = ( dx - x )**2 + y**2
    … …  
    368254             gg = aa + bb + cc + dd
    369255
    370              e_int_l = ( ( gg-aa ) * e(k,j,i)   + ( gg-bb ) * e(k,j,i+1)   &
    371                        + ( gg-cc ) * e(k,j+1,i) + ( gg-dd ) * e(k,j+1,i+1) &
    372                        ) / ( 3.0 * gg )
    373 
    374              IF ( k+1 == nzt+1 )  THEN
    375                 e_int = e_int_l
     256             u_int_l = ( ( gg - aa ) * u(k,j,i)   + ( gg - bb ) * u(k,j,i+1)   &
     257                         + ( gg - cc ) * u(k,j+1,i) + ( gg - dd ) *            &
     258                         u(k,j+1,i+1) ) / ( 3.0_wp * gg ) - u_gtrans
     259
     260             IF ( k == nzt )  THEN
     261                u_int(n) = u_int_l
    376262             ELSE
    377                 e_int_u = ( ( gg - aa ) * e(k+1,j,i)   + &
    378                             ( gg - bb ) * e(k+1,j,i+1) + &
    379                             ( gg - cc ) * e(k+1,j+1,i) + &
    380                             ( gg - dd ) * e(k+1,j+1,i+1) &
    381                           ) / ( 3.0 * gg )
    382                 e_int = e_int_l + ( particles(n)%z - zu(k) ) / dz * &
    383                                   ( e_int_u - e_int_l )
    384              ENDIF
    385 
    386 !
    387 !--          Interpolate the TKE gradient along x (adopt incides i,j,k and
    388 !--          all position variables from above (TKE))
    389              de_dx_int_l = ( ( gg - aa ) * de_dx(k,j,i)   + &
    390                              ( gg - bb ) * de_dx(k,j,i+1) + &
    391                              ( gg - cc ) * de_dx(k,j+1,i) + &
    392                              ( gg - dd ) * de_dx(k,j+1,i+1) &
    393                            ) / ( 3.0 * gg )
    394 
    395              IF ( ( k+1 == nzt+1 )  .OR.  ( k == nzb ) )  THEN
    396                 de_dx_int = de_dx_int_l
     263                u_int_u = ( ( gg-aa ) * u(k+1,j,i) + ( gg-bb ) * u(k+1,j,i+1)  &
     264                            + ( gg-cc ) * u(k+1,j+1,i) + ( gg-dd ) *           &
     265                            u(k+1,j+1,i+1) ) / ( 3.0_wp * gg ) - u_gtrans
     266                u_int(n) = u_int_l + ( zv(n) - zu(k) ) / dz *                  &
     267                           ( u_int_u - u_int_l )
     268             ENDIF
     269          ENDIF
     270
     271       ENDDO
     272
     273       i = ip + block_offset(nb)%i_off
     274       j = jp
     275       k = kp + block_offset(nb)%k_off
     276!
     277!--    Same procedure for interpolation of the v velocity-component
     278       DO  n = start_index(nb), end_index(nb)
     279          IF ( prandtl_layer  .AND.  particles(n)%z < z_p )  THEN
     280
     281             IF ( particles(n)%z < z0_av_global )  THEN
     282!
     283!--             Resolved-scale horizontal particle velocity is zero below z0.
     284                v_int(n) = 0.0_wp
     285             ELSE       
     286!
     287!--             Neutral solution is applied for all situations, e.g. also for
     288!--             unstable and stable situations. Even though this is not exact
     289!--             this saves a lot of CPU time since several calls of intrinsic
     290!--             FORTRAN procedures (LOG, ATAN) are avoided, This is justified
     291!--             as sensitivity studies revealed no significant effect of
     292!--             using the neutral solution also for un/stable situations.
     293!--             Calculated left and bottom index on v grid.
     294                us_int = 0.5_wp * ( us(j,i) + us(j-1,i) )   
     295
     296                v_int  = -vsws(j,i) / ( us_int * kappa + 1E-10_wp )             &
     297                         * log_z_z0_int(n)
     298             ENDIF
     299          ELSE
     300             x  = xv(n) - i * dx
     301             y  = yv(n) + ( 0.5_wp - j ) * dy
     302             aa = x**2          + y**2
     303             bb = ( dx - x )**2 + y**2
     304             cc = x**2          + ( dy - y )**2
     305             dd = ( dx - x )**2 + ( dy - y )**2
     306             gg = aa + bb + cc + dd
     307
     308             v_int_l = ( ( gg - aa ) * v(k,j,i)   + ( gg - bb ) * v(k,j,i+1)   &
     309                       + ( gg - cc ) * v(k,j+1,i) + ( gg - dd ) * v(k,j+1,i+1) &
     310                       ) / ( 3.0_wp * gg ) - v_gtrans
     311
     312             IF ( k == nzt )  THEN
     313                v_int(n) = v_int_l
    397314             ELSE
    398                 de_dx_int_u = ( ( gg - aa ) * de_dx(k+1,j,i)   + &
    399                                 ( gg - bb ) * de_dx(k+1,j,i+1) + &
    400                                 ( gg - cc ) * de_dx(k+1,j+1,i) + &
    401                                 ( gg - dd ) * de_dx(k+1,j+1,i+1) &
    402                               ) / ( 3.0 * gg )
    403                 de_dx_int = de_dx_int_l + ( particles(n)%z - zu(k) ) / dz * &
    404                                           ( de_dx_int_u - de_dx_int_l )
    405              ENDIF
    406 
    407 !
    408 !--          Interpolate the TKE gradient along y
    409              de_dy_int_l = ( ( gg - aa ) * de_dy(k,j,i)   + &
    410                              ( gg - bb ) * de_dy(k,j,i+1) + &
    411                              ( gg - cc ) * de_dy(k,j+1,i) + &
    412                              ( gg - dd ) * de_dy(k,j+1,i+1) &
    413                            ) / ( 3.0 * gg )
    414              IF ( ( k+1 == nzt+1 )  .OR.  ( k == nzb ) )  THEN
    415                 de_dy_int = de_dy_int_l
     315                v_int_u = ( ( gg-aa ) * v(k+1,j,i)   + ( gg-bb ) * v(k+1,j,i+1)   &
     316                          + ( gg-cc ) * v(k+1,j+1,i) + ( gg-dd ) * v(k+1,j+1,i+1) &
     317                          ) / ( 3.0_wp * gg ) - v_gtrans
     318                v_int(n) = v_int_l + ( zv(n) - zu(k) ) / dz * &
     319                                  ( v_int_u - v_int_l )
     320             ENDIF
     321          ENDIF
     322
     323       ENDDO
     324
     325       i = ip + block_offset(nb)%i_off
     326       j = jp + block_offset(nb)%j_off
     327       k = kp-1
     328!
     329!--    Same procedure for interpolation of the w velocity-component
     330       DO  n = start_index(nb), end_index(nb)
     331
     332          IF ( vertical_particle_advection(particles(n)%group) )  THEN
     333
     334             x  = xv(n) - i * dx
     335             y  = yv(n) - j * dy
     336             aa = x**2          + y**2
     337             bb = ( dx - x )**2 + y**2
     338             cc = x**2          + ( dy - y )**2
     339             dd = ( dx - x )**2 + ( dy - y )**2
     340             gg = aa + bb + cc + dd
     341
     342             w_int_l = ( ( gg - aa ) * w(k,j,i)   + ( gg - bb ) * w(k,j,i+1)   &
     343                       + ( gg - cc ) * w(k,j+1,i) + ( gg - dd ) * w(k,j+1,i+1) &
     344                       ) / ( 3.0_wp * gg )
     345
     346             IF ( k == nzt )  THEN
     347                w_int(n) = w_int_l
    416348             ELSE
    417                 de_dy_int_u = ( ( gg - aa ) * de_dy(k+1,j,i)   + &
    418                                 ( gg - bb ) * de_dy(k+1,j,i+1) + &
    419                                 ( gg - cc ) * de_dy(k+1,j+1,i) + &
    420                                 ( gg - dd ) * de_dy(k+1,j+1,i+1) &
    421                               ) / ( 3.0 * gg )
    422                 de_dy_int = de_dy_int_l + ( particles(n)%z - zu(k) ) / dz * &
    423                                           ( de_dy_int_u - de_dy_int_l )
    424              ENDIF
    425 
    426 !
    427 !--          Interpolate the TKE gradient along z
    428              IF ( particles(n)%z < 0.5 * dz ) THEN
    429                 de_dz_int = 0.0
    430              ELSE
    431                 de_dz_int_l = ( ( gg - aa ) * de_dz(k,j,i)   + &
    432                                 ( gg - bb ) * de_dz(k,j,i+1) + &
    433                                 ( gg - cc ) * de_dz(k,j+1,i) + &
    434                                 ( gg - dd ) * de_dz(k,j+1,i+1) &
    435                               ) / ( 3.0 * gg )
     349                w_int_u = ( ( gg-aa ) * w(k+1,j,i)   + &
     350                            ( gg-bb ) * w(k+1,j,i+1) + &
     351                            ( gg-cc ) * w(k+1,j+1,i) + &
     352                            ( gg-dd ) * w(k+1,j+1,i+1) &
     353                          ) / ( 3.0_wp * gg )
     354                w_int(n) = w_int_l + ( zv(n) - zw(k) ) / dz * &
     355                           ( w_int_u - w_int_l )
     356             ENDIF
     357
     358          ELSE
     359
     360             w_int(n) = 0.0_wp
     361
     362          ENDIF
     363
     364       ENDDO
     365
     366    ENDDO
     367
     368!-- Interpolate and calculate quantities needed for calculating the SGS
     369!-- velocities
     370    IF ( use_sgs_for_particles )  THEN
     371
     372       IF ( topography == 'flat' )  THEN
     373
     374          DO  nb = 0,7
     375
     376             i = ip + block_offset(nb)%i_off
     377             j = jp + block_offset(nb)%j_off
     378             k = kp + block_offset(nb)%k_off
     379
     380             DO  n = start_index(nb), end_index(nb)
     381!
     382!--             Interpolate TKE
     383                x  = xv(n) - i * dx
     384                y  = yv(n) - j * dy
     385                aa = x**2          + y**2
     386                bb = ( dx - x )**2 + y**2
     387                cc = x**2          + ( dy - y )**2
     388                dd = ( dx - x )**2 + ( dy - y )**2
     389                gg = aa + bb + cc + dd
     390
     391                e_int_l = ( ( gg-aa ) * e(k,j,i)   + ( gg-bb ) * e(k,j,i+1)   &
     392                          + ( gg-cc ) * e(k,j+1,i) + ( gg-dd ) * e(k,j+1,i+1) &
     393                          ) / ( 3.0_wp * gg )
     394
     395                IF ( k+1 == nzt+1 )  THEN
     396                   e_int(n) = e_int_l
     397                ELSE
     398                   e_int_u = ( ( gg - aa ) * e(k+1,j,i)   + &
     399                               ( gg - bb ) * e(k+1,j,i+1) + &
     400                               ( gg - cc ) * e(k+1,j+1,i) + &
     401                               ( gg - dd ) * e(k+1,j+1,i+1) &
     402                            ) / ( 3.0_wp * gg )
     403                   e_int(n) = e_int_l + ( zv(n) - zu(k) ) / dz * &
     404                                     ( e_int_u - e_int_l )
     405                ENDIF
     406!
     407!--             Needed to avoid NaN particle velocities
     408                IF ( e_int(n) == 0.0_wp )  THEN
     409                   e_int(n) = 1.0E-20_wp
     410                ENDIF
     411!
     412!--             Interpolate the TKE gradient along x (adopt incides i,j,k and
     413!--             all position variables from above (TKE))
     414                de_dx_int_l = ( ( gg - aa ) * de_dx(k,j,i)   + &
     415                                ( gg - bb ) * de_dx(k,j,i+1) + &
     416                                ( gg - cc ) * de_dx(k,j+1,i) + &
     417                                ( gg - dd ) * de_dx(k,j+1,i+1) &
     418                               ) / ( 3.0_wp * gg )
    436419
    437420                IF ( ( k+1 == nzt+1 )  .OR.  ( k == nzb ) )  THEN
    438                    de_dz_int = de_dz_int_l
     421                   de_dx_int(n) = de_dx_int_l
    439422                ELSE
    440                    de_dz_int_u = ( ( gg - aa ) * de_dz(k+1,j,i)   + &
    441                                    ( gg - bb ) * de_dz(k+1,j,i+1) + &
    442                                    ( gg - cc ) * de_dz(k+1,j+1,i) + &
    443                                    ( gg - dd ) * de_dz(k+1,j+1,i+1) &
    444                                  ) / ( 3.0 * gg )
    445                    de_dz_int = de_dz_int_l + ( particles(n)%z - zu(k) ) / dz * &
    446                                              ( de_dz_int_u - de_dz_int_l )
    447                 ENDIF
    448              ENDIF
    449 
    450 !
    451 !--          Interpolate the dissipation of TKE
    452              diss_int_l = ( ( gg - aa ) * diss(k,j,i)   + &
    453                             ( gg - bb ) * diss(k,j,i+1) + &
    454                             ( gg - cc ) * diss(k,j+1,i) + &
    455                             ( gg - dd ) * diss(k,j+1,i+1) &
    456                            ) / ( 3.0 * gg )
    457 
    458              IF ( k+1 == nzt+1 )  THEN
    459                 diss_int = diss_int_l
    460              ELSE
    461                 diss_int_u = ( ( gg - aa ) * diss(k+1,j,i)   + &
    462                                ( gg - bb ) * diss(k+1,j,i+1) + &
    463                                ( gg - cc ) * diss(k+1,j+1,i) + &
    464                                ( gg - dd ) * diss(k+1,j+1,i+1) &
    465                               ) / ( 3.0 * gg )
    466                 diss_int = diss_int_l + ( particles(n)%z - zu(k) ) / dz * &
    467                                         ( diss_int_u - diss_int_l )
    468              ENDIF
    469 
    470           ELSE
    471 
     423                   de_dx_int_u = ( ( gg - aa ) * de_dx(k+1,j,i)   + &
     424                                   ( gg - bb ) * de_dx(k+1,j,i+1) + &
     425                                   ( gg - cc ) * de_dx(k+1,j+1,i) + &
     426                                   ( gg - dd ) * de_dx(k+1,j+1,i+1) &
     427                                  ) / ( 3.0_wp * gg )
     428                   de_dx_int(n) = de_dx_int_l + ( zv(n) - zu(k) ) / dz * &
     429                                              ( de_dx_int_u - de_dx_int_l )
     430                ENDIF
     431!
     432!--             Interpolate the TKE gradient along y
     433                de_dy_int_l = ( ( gg - aa ) * de_dy(k,j,i)   + &
     434                                ( gg - bb ) * de_dy(k,j,i+1) + &
     435                                ( gg - cc ) * de_dy(k,j+1,i) + &
     436                                ( gg - dd ) * de_dy(k,j+1,i+1) &
     437                               ) / ( 3.0_wp * gg )
     438                IF ( ( k+1 == nzt+1 )  .OR.  ( k == nzb ) )  THEN
     439                   de_dy_int(n) = de_dy_int_l
     440                ELSE
     441                   de_dy_int_u = ( ( gg - aa ) * de_dy(k+1,j,i)   + &
     442                                  ( gg - bb ) * de_dy(k+1,j,i+1) + &
     443                                  ( gg - cc ) * de_dy(k+1,j+1,i) + &
     444                                  ( gg - dd ) * de_dy(k+1,j+1,i+1) &
     445                                  ) / ( 3.0_wp * gg )
     446                   de_dy_int(n) = de_dy_int_l + ( zv(n) - zu(k) ) / dz * &
     447                                              ( de_dy_int_u - de_dy_int_l )
     448                ENDIF
     449
     450!
     451!--             Interpolate the TKE gradient along z
     452                IF ( zv(n) < 0.5_wp * dz )  THEN
     453                   de_dz_int(n) = 0.0_wp
     454                ELSE
     455                   de_dz_int_l = ( ( gg - aa ) * de_dz(k,j,i)   + &
     456                                   ( gg - bb ) * de_dz(k,j,i+1) + &
     457                                   ( gg - cc ) * de_dz(k,j+1,i) + &
     458                                   ( gg - dd ) * de_dz(k,j+1,i+1) &
     459                                  ) / ( 3.0_wp * gg )
     460
     461                   IF ( ( k+1 == nzt+1 )  .OR.  ( k == nzb ) )  THEN
     462                      de_dz_int(n) = de_dz_int_l
     463                   ELSE
     464                      de_dz_int_u = ( ( gg - aa ) * de_dz(k+1,j,i)   + &
     465                                      ( gg - bb ) * de_dz(k+1,j,i+1) + &
     466                                      ( gg - cc ) * de_dz(k+1,j+1,i) + &
     467                                      ( gg - dd ) * de_dz(k+1,j+1,i+1) &
     468                                     ) / ( 3.0_wp * gg )
     469                      de_dz_int(n) = de_dz_int_l + ( zv(n) - zu(k) ) / dz * &
     470                                                 ( de_dz_int_u - de_dz_int_l )
     471                   ENDIF
     472                ENDIF
     473
     474!
     475!--             Interpolate the dissipation of TKE
     476                diss_int_l = ( ( gg - aa ) * diss(k,j,i)   + &
     477                               ( gg - bb ) * diss(k,j,i+1) + &
     478                               ( gg - cc ) * diss(k,j+1,i) + &
     479                               ( gg - dd ) * diss(k,j+1,i+1) &
     480                              ) / ( 3.0_wp * gg )
     481
     482                IF ( k == nzt )  THEN
     483                   diss_int(n) = diss_int_l
     484                ELSE
     485                   diss_int_u = ( ( gg - aa ) * diss(k+1,j,i)   + &
     486                                  ( gg - bb ) * diss(k+1,j,i+1) + &
     487                                  ( gg - cc ) * diss(k+1,j+1,i) + &
     488                                  ( gg - dd ) * diss(k+1,j+1,i+1) &
     489                                 ) / ( 3.0_wp * gg )
     490                   diss_int(n) = diss_int_l + ( zv(n) - zu(k) ) / dz * &
     491                                           ( diss_int_u - diss_int_l )
     492                ENDIF
     493
     494             ENDDO
     495          ENDDO
     496
     497       ELSE ! non-flat topography, e.g., buildings
     498
     499          DO  n = 1, number_of_particles
     500
     501             i = particles(n)%x * ddx
     502             j = particles(n)%y * ddy
     503             k = ( zv(n) + 0.5_wp * dz * atmos_ocean_sign ) / dz  &
     504                 + offset_ocean_nzt                      ! only exact if eq.dist
    472505!
    473506!--          In case that there are buildings it has to be determined
    … …  
    484517
    485518             gp_outside_of_building = 0
    486              location = 0.0
     519             location = 0.0_wp
    487520             num_gp = 0
    488521
    … …  
    492525                location(num_gp,1) = i * dx
    493526                location(num_gp,2) = j * dy
    494                 location(num_gp,3) = k * dz - 0.5 * dz
     527                location(num_gp,3) = k * dz - 0.5_wp * dz
    495528                ei(num_gp)     = e(k,j,i)
    496529                dissi(num_gp)  = diss(k,j,i)
    … …  
    506539                location(num_gp,1) = i * dx
    507540                location(num_gp,2) = (j+1) * dy
    508                 location(num_gp,3) = k * dz - 0.5 * dz
     541                location(num_gp,3) = k * dz - 0.5_wp * dz
    509542                ei(num_gp)     = e(k,j+1,i)
    510543                dissi(num_gp)  = diss(k,j+1,i)
    … …  
    519552                location(num_gp,1) = i * dx
    520553                location(num_gp,2) = j * dy
    521                 location(num_gp,3) = (k+1) * dz - 0.5 * dz
     554                location(num_gp,3) = (k+1) * dz - 0.5_wp * dz
    522555                ei(num_gp)     = e(k+1,j,i)
    523556                dissi(num_gp)  = diss(k+1,j,i)
    … …  
    533566                location(num_gp,1) = i * dx
    534567                location(num_gp,2) = (j+1) * dy
    535                 location(num_gp,3) = (k+1) * dz - 0.5 * dz
     568                location(num_gp,3) = (k+1) * dz - 0.5_wp * dz
    536569                ei(num_gp)     = e(k+1,j+1,i)
    537570                dissi(num_gp)  = diss(k+1,j+1,i)
    … …  
    547580                location(num_gp,1) = (i+1) * dx
    548581                location(num_gp,2) = j * dy
    549                 location(num_gp,3) = k * dz - 0.5 * dz
     582                location(num_gp,3) = k * dz - 0.5_wp * dz
    550583                ei(num_gp)     = e(k,j,i+1)
    551584                dissi(num_gp)  = diss(k,j,i+1)
    … …  
    555588             ENDIF
    556589
    557              IF ( k > nzb_s_inner(j+1,i+1) .OR. nzb_s_inner(j+1,i+1) == 0 ) &
     590             IF ( k > nzb_s_inner(j+1,i+1)  .OR. nzb_s_inner(j+1,i+1) == 0 ) &
    558591             THEN
    559592                num_gp = num_gp + 1
    … …  
    561594                location(num_gp,1) = (i+1) * dx
    562595                location(num_gp,2) = (j+1) * dy
    563                 location(num_gp,3) = k * dz - 0.5 * dz
     596                location(num_gp,3) = k * dz - 0.5_wp * dz
    564597                ei(num_gp)     = e(k,j+1,i+1)
    565598                dissi(num_gp)  = diss(k,j+1,i+1)
    … …  
    575608                location(num_gp,1) = (i+1) * dx
    576609                location(num_gp,2) = j * dy
    577                 location(num_gp,3) = (k+1) * dz - 0.5 * dz
     610                location(num_gp,3) = (k+1) * dz - 0.5_wp * dz
    578611                ei(num_gp)     = e(k+1,j,i+1)
    579612                dissi(num_gp)  = diss(k+1,j,i+1)
    … …  
    583616             ENDIF
    584617
    585              IF ( k+1 > nzb_s_inner(j+1,i+1) .OR. nzb_s_inner(j+1,i+1) == 0)&
     618             IF ( k+1 > nzb_s_inner(j+1,i+1)  .OR. nzb_s_inner(j+1,i+1) == 0)&
    586619             THEN
    587620                num_gp = num_gp + 1
    … …  
    589622                location(num_gp,1) = (i+1) * dx
    590623                location(num_gp,2) = (j+1) * dy
    591                 location(num_gp,3) = (k+1) * dz - 0.5 * dz
     624                location(num_gp,3) = (k+1) * dz - 0.5_wp * dz
    592625                ei(num_gp)     = e(k+1,j+1,i+1)
    593626                dissi(num_gp)  = diss(k+1,j+1,i+1)
    … …  
    610643                gg = aa + bb + cc + dd
    611644
    612                 e_int_l = (( gg-aa ) * e(k,j,i)   + ( gg-bb ) * e(k,j,i+1) &
    613                          + ( gg-cc ) * e(k,j+1,i) + ( gg-dd ) * e(k,j+1,i+1)&
    614                           ) / ( 3.0 * gg )
    615 
    616                 IF ( k+1 == nzt+1 )  THEN
    617                    e_int = e_int_l
     645                e_int_l = ( ( gg - aa ) * e(k,j,i)   + ( gg - bb ) * e(k,j,i+1)  &
     646                          + ( gg - cc ) * e(k,j+1,i) + ( gg - dd ) * e(k,j+1,i+1) &
     647                          ) / ( 3.0_wp * gg )
     648
     649                IF ( k == nzt )  THEN
     650                   e_int(n) = e_int_l
    618651                ELSE
    619652                   e_int_u = ( ( gg - aa ) * e(k+1,j,i)   + &
    … …  
    621654                               ( gg - cc ) * e(k+1,j+1,i) + &
    622655                               ( gg - dd ) * e(k+1,j+1,i+1) &
    623                              ) / ( 3.0 * gg )
    624                    e_int = e_int_l + ( particles(n)%z - zu(k) ) / dz * &
     656                             ) / ( 3.0_wp * gg )
     657                   e_int(n) = e_int_l + ( zv(n) - zu(k) ) / dz * &
    625658                                     ( e_int_u - e_int_l )
    626659                ENDIF
    627 
     660!
     661!--             Needed to avoid NaN particle velocities
     662                IF ( e_int(n) == 0.0_wp )  THEN
     663                   e_int(n) = 1.0E-20_wp
     664                ENDIF
    628665!
    629666!--             Interpolate the TKE gradient along x (adopt incides i,j,k
    … …  
    633670                                ( gg - cc ) * de_dx(k,j+1,i) + &
    634671                                ( gg - dd ) * de_dx(k,j+1,i+1) &
    635                               ) / ( 3.0 * gg )
    636 
    637                 IF ( ( k+1 == nzt+1 )  .OR.  ( k == nzb ) )  THEN
    638                    de_dx_int = de_dx_int_l
     672                              ) / ( 3.0_wp * gg )
     673
     674                IF ( ( k == nzt )  .OR.  ( k == nzb ) )  THEN
     675                   de_dx_int(n) = de_dx_int_l
    639676                ELSE
    640677                   de_dx_int_u = ( ( gg - aa ) * de_dx(k+1,j,i)   + &
    … …  
    642679                                   ( gg - cc ) * de_dx(k+1,j+1,i) + &
    643680                                   ( gg - dd ) * de_dx(k+1,j+1,i+1) &
    644                                  ) / ( 3.0 * gg )
    645                    de_dx_int = de_dx_int_l + ( particles(n)%z - zu(k) ) / &
     681                                 ) / ( 3.0_wp * gg )
     682                   de_dx_int(n) = de_dx_int_l + ( zv(n) - zu(k) ) / &
    646683                                           dz * ( de_dx_int_u - de_dx_int_l )
    647684                ENDIF
    … …  
    653690                                ( gg - cc ) * de_dy(k,j+1,i) + &
    654691                                ( gg - dd ) * de_dy(k,j+1,i+1) &
    655                               ) / ( 3.0 * gg )
     692                              ) / ( 3.0_wp * gg )
    656693                IF ( ( k+1 == nzt+1 )  .OR.  ( k == nzb ) )  THEN
    657                    de_dy_int = de_dy_int_l
     694                   de_dy_int(n) = de_dy_int_l
    658695                ELSE
    659696                   de_dy_int_u = ( ( gg - aa ) * de_dy(k+1,j,i)   + &
    … …  
    661698                                   ( gg - cc ) * de_dy(k+1,j+1,i) + &
    662699                                   ( gg - dd ) * de_dy(k+1,j+1,i+1) &
    663                                  ) / ( 3.0 * gg )
    664                    de_dy_int = de_dy_int_l + ( particles(n)%z - zu(k) ) / &
     700                                 ) / ( 3.0_wp * gg )
     701                   de_dy_int(n) = de_dy_int_l + ( zv(n) - zu(k) ) / &
    665702                                           dz * ( de_dy_int_u - de_dy_int_l )
    666703                ENDIF
    … …  
    668705!
    669706!--             Interpolate the TKE gradient along z
    670                 IF ( particles(n)%z < 0.5 * dz )  THEN
    671                    de_dz_int = 0.0
     707                IF ( zv(n) < 0.5_wp * dz )  THEN
     708                   de_dz_int(n) = 0.0_wp
    672709                ELSE
    673710                   de_dz_int_l = ( ( gg - aa ) * de_dz(k,j,i)   + &
    … …  
    675712                                   ( gg - cc ) * de_dz(k,j+1,i) + &
    676713                                   ( gg - dd ) * de_dz(k,j+1,i+1) &
    677                                  ) / ( 3.0 * gg )
     714                                 ) / ( 3.0_wp * gg )
    678715
    679716                   IF ( ( k+1 == nzt+1 )  .OR.  ( k == nzb ) )  THEN
    680                       de_dz_int = de_dz_int_l
     717                      de_dz_int(n) = de_dz_int_l
    681718                   ELSE
    682719                      de_dz_int_u = ( ( gg - aa ) * de_dz(k+1,j,i)   + &
    … …  
    684721                                      ( gg - cc ) * de_dz(k+1,j+1,i) + &
    685722                                      ( gg - dd ) * de_dz(k+1,j+1,i+1) &
    686                                     ) / ( 3.0 * gg )
    687                       de_dz_int = de_dz_int_l + ( particles(n)%z - zu(k) ) /&
     723                                    ) / ( 3.0_wp * gg )
     724                      de_dz_int(n) = de_dz_int_l + ( zv(n) - zu(k) ) /&
    688725                                           dz * ( de_dz_int_u - de_dz_int_l )
    689726                   ENDIF
    … …  
    696733                               ( gg - cc ) * diss(k,j+1,i) + &
    697734                               ( gg - dd ) * diss(k,j+1,i+1) &
    698                              ) / ( 3.0 * gg )
    699 
    700                 IF ( k+1 == nzt+1 )  THEN
    701                    diss_int = diss_int_l
     735                             ) / ( 3.0_wp * gg )
     736
     737                IF ( k == nzt )  THEN
     738                   diss_int(n) = diss_int_l
    702739                ELSE
    703740                   diss_int_u = ( ( gg - aa ) * diss(k+1,j,i)   + &
    … …  
    705742                                  ( gg - cc ) * diss(k+1,j+1,i) + &
    706743                                  ( gg - dd ) * diss(k+1,j+1,i+1) &
    707                                 ) / ( 3.0 * gg )
    708                    diss_int = diss_int_l + ( particles(n)%z - zu(k) ) / dz *&
     744                                ) / ( 3.0_wp * gg )
     745                   diss_int(n) = diss_int_l + ( zv(n) - zu(k) ) / dz *&
    709746                                           ( diss_int_u - diss_int_l )
    710747                ENDIF
    … …  
    718755                     gp_outside_of_building(5) == 0 )  THEN
    719756                   num_gp = num_gp + 1
    720                    location(num_gp,1) = i * dx + 0.5 * dx
     757                   location(num_gp,1) = i * dx + 0.5_wp * dx
    721758                   location(num_gp,2) = j * dy
    722                    location(num_gp,3) = k * dz - 0.5 * dz
     759                   location(num_gp,3) = k * dz - 0.5_wp * dz
    723760                   ei(num_gp)     = e(k,j,i)
    724761                   dissi(num_gp)  = diss(k,j,i)
    725                    de_dxi(num_gp) = 0.0
     762                   de_dxi(num_gp) = 0.0_wp
    726763                   de_dyi(num_gp) = de_dy(k,j,i)
    727764                   de_dzi(num_gp) = de_dz(k,j,i)
    … …  
    731768                   gp_outside_of_building(1) == 0 )  THEN
    732769                   num_gp = num_gp + 1
    733                    location(num_gp,1) = i * dx + 0.5 * dx
     770                   location(num_gp,1) = i * dx + 0.5_wp * dx
    734771                   location(num_gp,2) = j * dy
    735                    location(num_gp,3) = k * dz - 0.5 * dz
     772                   location(num_gp,3) = k * dz - 0.5_wp * dz
    736773                   ei(num_gp)     = e(k,j,i+1)
    737774                   dissi(num_gp)  = diss(k,j,i+1)
    738                    de_dxi(num_gp) = 0.0
     775                   de_dxi(num_gp) = 0.0_wp
    739776                   de_dyi(num_gp) = de_dy(k,j,i+1)
    740777                   de_dzi(num_gp) = de_dz(k,j,i+1)
    … …  
    748785                   num_gp = num_gp + 1
    749786                   location(num_gp,1) = (i+1) * dx
    750                    location(num_gp,2) = j * dy + 0.5 * dy
    751                    location(num_gp,3) = k * dz - 0.5 * dz
     787                   location(num_gp,2) = j * dy + 0.5_wp * dy
     788                   location(num_gp,3) = k * dz - 0.5_wp * dz
    752789                   ei(num_gp)     = e(k,j,i+1)
    753790                   dissi(num_gp)  = diss(k,j,i+1)
    754791                   de_dxi(num_gp) = de_dx(k,j,i+1)
    755                    de_dyi(num_gp) = 0.0
     792                   de_dyi(num_gp) = 0.0_wp
    756793                   de_dzi(num_gp) = de_dz(k,j,i+1)
    757794                ENDIF
    … …  
    761798                   num_gp = num_gp + 1
    762799                   location(num_gp,1) = (i+1) * dx
    763                    location(num_gp,2) = j * dy + 0.5 * dy
    764                    location(num_gp,3) = k * dz - 0.5 * dz
     800                   location(num_gp,2) = j * dy + 0.5_wp * dy
     801                   location(num_gp,3) = k * dz - 0.5_wp * dz
    765802                   ei(num_gp)     = e(k,j+1,i+1)
    766803                   dissi(num_gp)  = diss(k,j+1,i+1)
    767804                   de_dxi(num_gp) = de_dx(k,j+1,i+1)
    768                    de_dyi(num_gp) = 0.0
     805                   de_dyi(num_gp) = 0.0_wp
    769806                   de_dzi(num_gp) = de_dz(k,j+1,i+1)
    770807                ENDIF
    … …  
    776813                     gp_outside_of_building(6) == 0 )  THEN
    777814                   num_gp = num_gp + 1
    778                    location(num_gp,1) = i * dx + 0.5 * dx
     815                   location(num_gp,1) = i * dx + 0.5_wp * dx
    779816                   location(num_gp,2) = (j+1) * dy
    780                    location(num_gp,3) = k * dz - 0.5 * dz
     817                   location(num_gp,3) = k * dz - 0.5_wp * dz
    781818                   ei(num_gp)     = e(k,j+1,i)
    782819                   dissi(num_gp)  = diss(k,j+1,i)
    783                    de_dxi(num_gp) = 0.0
     820                   de_dxi(num_gp) = 0.0_wp
    784821                   de_dyi(num_gp) = de_dy(k,j+1,i)
    785822                   de_dzi(num_gp) = de_dz(k,j+1,i)
    … …  
    789826                     gp_outside_of_building(2) == 0 )  THEN
    790827                   num_gp = num_gp + 1
    791                    location(num_gp,1) = i * dx + 0.5 * dx
     828                   location(num_gp,1) = i * dx + 0.5_wp * dx
    792829                   location(num_gp,2) = (j+1) * dy
    793                    location(num_gp,3) = k * dz - 0.5 * dz
     830                   location(num_gp,3) = k * dz - 0.5_wp * dz
    794831                   ei(num_gp)     = e(k,j+1,i+1)
    795832                   dissi(num_gp)  = diss(k,j+1,i+1)
    796                    de_dxi(num_gp) = 0.0
     833                   de_dxi(num_gp) = 0.0_wp
    797834                   de_dyi(num_gp) = de_dy(k,j+1,i+1)
    798835                   de_dzi(num_gp) = de_dz(k,j+1,i+1)
    … …  
    806843                   num_gp = num_gp + 1
    807844                   location(num_gp,1) = i * dx
    808                    location(num_gp,2) = j * dy + 0.5 * dy
    809                    location(num_gp,3) = k * dz - 0.5 * dz
     845                   location(num_gp,2) = j * dy + 0.5_wp * dy
     846                   location(num_gp,3) = k * dz - 0.5_wp * dz
    810847                   ei(num_gp)     = e(k,j,i)
    811848                   dissi(num_gp)  = diss(k,j,i)
    812849                   de_dxi(num_gp) = de_dx(k,j,i)
    813                    de_dyi(num_gp) = 0.0
     850                   de_dyi(num_gp) = 0.0_wp
    814851                   de_dzi(num_gp) = de_dz(k,j,i)
    815852                ENDIF
    … …  
    819856                   num_gp = num_gp + 1
    820857                   location(num_gp,1) = i * dx
    821                    location(num_gp,2) = j * dy + 0.5 * dy
    822                    location(num_gp,3) = k * dz - 0.5 * dz
     858                   location(num_gp,2) = j * dy + 0.5_wp * dy
     859                   location(num_gp,3) = k * dz - 0.5_wp * dz
    823860                   ei(num_gp)     = e(k,j+1,i)
    824861                   dissi(num_gp)  = diss(k,j+1,i)
    825862                   de_dxi(num_gp) = de_dx(k,j+1,i)
    826                    de_dyi(num_gp) = 0.0
     863                   de_dyi(num_gp) = 0.0_wp
    827864                   de_dzi(num_gp) = de_dz(k,j+1,i)
    828865                ENDIF
    … …  
    834871                     gp_outside_of_building(7) == 0 )  THEN
    835872                   num_gp = num_gp + 1
    836                    location(num_gp,1) = i * dx + 0.5 * dx
     873                   location(num_gp,1) = i * dx + 0.5_wp * dx
    837874                   location(num_gp,2) = j * dy
    838                    location(num_gp,3) = k * dz + 0.5 * dz
     875                   location(num_gp,3) = k * dz + 0.5_wp * dz
    839876                   ei(num_gp)     = e(k+1,j,i)
    840877                   dissi(num_gp)  = diss(k+1,j,i)
    841                    de_dxi(num_gp) = 0.0
     878                   de_dxi(num_gp) = 0.0_wp
    842879                   de_dyi(num_gp) = de_dy(k+1,j,i)
    843880                   de_dzi(num_gp) = de_dz(k+1,j,i)
    … …  
    847884                     gp_outside_of_building(3) == 0 )  THEN
    848885                   num_gp = num_gp + 1
    849                    location(num_gp,1) = i * dx + 0.5 * dx
     886                   location(num_gp,1) = i * dx + 0.5_wp * dx
    850887                   location(num_gp,2) = j * dy
    851                    location(num_gp,3) = k * dz + 0.5 * dz
     888                   location(num_gp,3) = k * dz + 0.5_wp * dz
    852889                   ei(num_gp)     = e(k+1,j,i+1)
    853890                   dissi(num_gp)  = diss(k+1,j,i+1)
    854                    de_dxi(num_gp) = 0.0
     891                   de_dxi(num_gp) = 0.0_wp
    855892                   de_dyi(num_gp) = de_dy(k+1,j,i+1)
    856893                   de_dzi(num_gp) = de_dz(k+1,j,i+1)
    … …  
    864901                   num_gp = num_gp + 1
    865902                   location(num_gp,1) = (i+1) * dx
    866                    location(num_gp,2) = j * dy + 0.5 * dy
    867                    location(num_gp,3) = k * dz + 0.5 * dz
     903                   location(num_gp,2) = j * dy + 0.5_wp * dy
     904                   location(num_gp,3) = k * dz + 0.5_wp * dz
    868905                   ei(num_gp)     = e(k+1,j,i+1)
    869906                   dissi(num_gp)  = diss(k+1,j,i+1)
    870907                   de_dxi(num_gp) = de_dx(k+1,j,i+1)
    871                    de_dyi(num_gp) = 0.0
     908                   de_dyi(num_gp) = 0.0_wp
    872909                   de_dzi(num_gp) = de_dz(k+1,j,i+1)
    873910                ENDIF
    … …  
    877914                   num_gp = num_gp + 1
    878915                   location(num_gp,1) = (i+1) * dx
    879                    location(num_gp,2) = j * dy + 0.5 * dy
    880                    location(num_gp,3) = k * dz + 0.5 * dz
     916                   location(num_gp,2) = j * dy + 0.5_wp * dy
     917                   location(num_gp,3) = k * dz + 0.5_wp * dz
    881918                   ei(num_gp)     = e(k+1,j+1,i+1)
    882919                   dissi(num_gp)  = diss(k+1,j+1,i+1)
    883920                   de_dxi(num_gp) = de_dx(k+1,j+1,i+1)
    884                    de_dyi(num_gp) = 0.0
     921                   de_dyi(num_gp) = 0.0_wp
    885922                   de_dzi(num_gp) = de_dz(k+1,j+1,i+1)
    886923                ENDIF
    … …  
    892929                     gp_outside_of_building(8) == 0 )  THEN
    893930                   num_gp = num_gp + 1
    894                    location(num_gp,1) = i * dx + 0.5 * dx
     931                   location(num_gp,1) = i * dx + 0.5_wp * dx
    895932                   location(num_gp,2) = (j+1) * dy
    896                    location(num_gp,3) = k * dz + 0.5 * dz
     933                   location(num_gp,3) = k * dz + 0.5_wp * dz
    897934                   ei(num_gp)     = e(k+1,j+1,i)
    898935                   dissi(num_gp)  = diss(k+1,j+1,i)
    899                    de_dxi(num_gp) = 0.0
     936                   de_dxi(num_gp) = 0.0_wp
    900937                   de_dyi(num_gp) = de_dy(k+1,j+1,i)
    901938                   de_dzi(num_gp) = de_dz(k+1,j+1,i)
    … …  
    905942                     gp_outside_of_building(4) == 0 )  THEN
    906943                   num_gp = num_gp + 1
    907                    location(num_gp,1) = i * dx + 0.5 * dx
     944                   location(num_gp,1) = i * dx + 0.5_wp * dx
    908945                   location(num_gp,2) = (j+1) * dy
    909                    location(num_gp,3) = k * dz + 0.5 * dz
     946                   location(num_gp,3) = k * dz + 0.5_wp * dz
    910947                   ei(num_gp)     = e(k+1,j+1,i+1)
    911948                   dissi(num_gp)  = diss(k+1,j+1,i+1)
    912                    de_dxi(num_gp) = 0.0
     949                   de_dxi(num_gp) = 0.0_wp
    913950                   de_dyi(num_gp) = de_dy(k+1,j+1,i+1)
    914951                   de_dzi(num_gp) = de_dz(k+1,j+1,i+1)
    … …  
    922959                   num_gp = num_gp + 1
    923960                   location(num_gp,1) = i * dx
    924                    location(num_gp,2) = j * dy + 0.5 * dy
    925                    location(num_gp,3) = k * dz + 0.5 * dz
     961                   location(num_gp,2) = j * dy + 0.5_wp * dy
     962                   location(num_gp,3) = k * dz + 0.5_wp * dz
    926963                   ei(num_gp)     = e(k+1,j,i)
    927964                   dissi(num_gp)  = diss(k+1,j,i)
    928965                   de_dxi(num_gp) = de_dx(k+1,j,i)
    929                    de_dyi(num_gp) = 0.0
     966                   de_dyi(num_gp) = 0.0_wp
    930967                   de_dzi(num_gp) = de_dz(k+1,j,i)
    931968                ENDIF
    … …  
    935972                   num_gp = num_gp + 1
    936973                   location(num_gp,1) = i * dx
    937                    location(num_gp,2) = j * dy + 0.5 * dy
    938                    location(num_gp,3) = k * dz + 0.5 * dz
     974                   location(num_gp,2) = j * dy + 0.5_wp * dy
     975                   location(num_gp,3) = k * dz + 0.5_wp * dz
    939976                   ei(num_gp)     = e(k+1,j+1,i)
    940977                   dissi(num_gp)  = diss(k+1,j+1,i)
    941978                   de_dxi(num_gp) = de_dx(k+1,j+1,i)
    942                    de_dyi(num_gp) = 0.0
     979                   de_dyi(num_gp) = 0.0_wp
    943980                   de_dzi(num_gp) = de_dz(k+1,j+1,i)
    944981                ENDIF
    … …  
    958995                   de_dxi(num_gp) = de_dx(k+1,j,i)
    959996                   de_dyi(num_gp) = de_dy(k+1,j,i)
    960                    de_dzi(num_gp) = 0.0
     997                   de_dzi(num_gp) = 0.0_wp
    961998                ENDIF
    962999
    … …  
    9751012                   de_dxi(num_gp) = de_dx(k+1,j,i+1)
    9761013                   de_dyi(num_gp) = de_dy(k+1,j,i+1)
    977                    de_dzi(num_gp) = 0.0
     1014                   de_dzi(num_gp) = 0.0_wp
    9781015                ENDIF
    9791016
    … …  
    9921029                   de_dxi(num_gp) = de_dx(k+1,j+1,i)
    9931030                   de_dyi(num_gp) = de_dy(k+1,j+1,i)
    994                    de_dzi(num_gp) = 0.0
     1031                   de_dzi(num_gp) = 0.0_wp
    9951032                ENDIF
    9961033
    … …  
    10091046                   de_dxi(num_gp) = de_dx(k+1,j+1,i+1)
    10101047                   de_dyi(num_gp) = de_dy(k+1,j+1,i+1)
    1011                    de_dzi(num_gp) = 0.0
     1048                   de_dzi(num_gp) = 0.0_wp
    10121049                ENDIF
    10131050
    … …  
    10191056!--                building, it follows that the values at the particle
    10201057!--                location are the same as the gridpoint values
    1021                    e_int     = ei(num_gp)
    1022                    diss_int  = dissi(num_gp)
    1023                    de_dx_int = de_dxi(num_gp)
    1024                    de_dy_int = de_dyi(num_gp)
    1025                    de_dz_int = de_dzi(num_gp)
     1058                   e_int(n)     = ei(num_gp)
     1059                   diss_int(n)  = dissi(num_gp)
     1060                   de_dx_int(n) = de_dxi(num_gp)
     1061                   de_dy_int(n) = de_dyi(num_gp)
     1062                   de_dz_int(n) = de_dzi(num_gp)
    10261063                ELSE IF ( num_gp > 1 )  THEN
    10271064
    1028                    d_sum = 0.0
     1065                   d_sum = 0.0_wp
    10291066!
    10301067!--                Evaluation of the distances between the gridpoints
    … …  
    10341071                      d_gp_pl(agp) = ( particles(n)%x-location(agp,1) )**2  &
    10351072                                   + ( particles(n)%y-location(agp,2) )**2  &
    1036                                    + ( particles(n)%z-location(agp,3) )**2
     1073                                   + ( zv(n)-location(agp,3) )**2
    10371074                      d_sum        = d_sum + d_gp_pl(agp)
    10381075                   ENDDO
    … …  
    10401077!
    10411078!--                Finally the interpolation can be carried out
    1042                    e_int     = 0.0
    1043                    diss_int  = 0.0
    1044                    de_dx_int = 0.0
    1045                    de_dy_int = 0.0
    1046                    de_dz_int = 0.0
     1079                   e_int(n)     = 0.0_wp
     1080                   diss_int(n)  = 0.0_wp
     1081                   de_dx_int(n) = 0.0_wp
     1082                   de_dy_int(n) = 0.0_wp
     1083                   de_dz_int(n) = 0.0_wp
    10471084                   DO  agp = 1, num_gp
    1048                       e_int     = e_int     + ( d_sum - d_gp_pl(agp) ) * &
     1085                      e_int(n)     = e_int(n)     + ( d_sum - d_gp_pl(agp) ) * &
    10491086                                             ei(agp) / ( (num_gp-1) * d_sum )
    1050                       diss_int  = diss_int  + ( d_sum - d_gp_pl(agp) ) * &
     1087                      diss_int(n)  = diss_int(n)  + ( d_sum - d_gp_pl(agp) ) * &
    10511088                                          dissi(agp) / ( (num_gp-1) * d_sum )
    1052                       de_dx_int = de_dx_int + ( d_sum - d_gp_pl(agp) ) * &
     1089                      de_dx_int(n) = de_dx_int(n) + ( d_sum - d_gp_pl(agp) ) * &
    10531090                                         de_dxi(agp) / ( (num_gp-1) * d_sum )
    1054                       de_dy_int = de_dy_int + ( d_sum - d_gp_pl(agp) ) * &
     1091                      de_dy_int(n) = de_dy_int(n) + ( d_sum - d_gp_pl(agp) ) * &
    10551092                                         de_dyi(agp) / ( (num_gp-1) * d_sum )
    1056                       de_dz_int = de_dz_int + ( d_sum - d_gp_pl(agp) ) * &
     1093                      de_dz_int(n) = de_dz_int(n) + ( d_sum - d_gp_pl(agp) ) * &
    10571094                                         de_dzi(agp) / ( (num_gp-1) * d_sum )
    10581095                   ENDDO
    … …  
    10611098
    10621099             ENDIF
    1063 
    1064           ENDIF 
    1065 
    1066 !
    1067 !--       Vertically interpolate the horizontally averaged SGS TKE and
    1068 !--       resolved-scale velocity variances and use the interpolated values
    1069 !--       to calculate the coefficient fs, which is a measure of the ratio
    1070 !--       of the subgrid-scale turbulent kinetic energy to the total amount
    1071 !--       of turbulent kinetic energy.
    1072           IF ( k == 0 )  THEN
    1073              e_mean_int = hom(0,1,8,0)
    1074           ELSE
    1075              e_mean_int = hom(k,1,8,0) +                                    &
    1076                                         ( hom(k+1,1,8,0) - hom(k,1,8,0) ) / &
    1077                                         ( zu(k+1) - zu(k) ) *               &
    1078                                         ( particles(n)%z - zu(k) )
    1079           ENDIF
    1080 
    1081           kw = particles(n)%z / dz
    1082 
    1083           IF ( k == 0 )  THEN
    1084              aa  = hom(k+1,1,30,0)  * ( particles(n)%z / &
    1085                                       ( 0.5 * ( zu(k+1) - zu(k) ) ) )
    1086              bb  = hom(k+1,1,31,0)  * ( particles(n)%z / &
    1087                                       ( 0.5 * ( zu(k+1) - zu(k) ) ) )
    1088              cc  = hom(kw+1,1,32,0) * ( particles(n)%z / &
    1089                                       ( 1.0 * ( zw(kw+1) - zw(kw) ) ) )
    1090           ELSE
    1091              aa  = hom(k,1,30,0) + ( hom(k+1,1,30,0) - hom(k,1,30,0) ) * &
    1092                         ( ( particles(n)%z - zu(k) ) / ( zu(k+1) - zu(k) ) )
    1093              bb  = hom(k,1,31,0) + ( hom(k+1,1,31,0) - hom(k,1,31,0) ) * &
    1094                         ( ( particles(n)%z - zu(k) ) / ( zu(k+1) - zu(k) ) )
    1095              cc  = hom(kw,1,32,0) + ( hom(kw+1,1,32,0)-hom(kw,1,32,0) ) *&
    1096                         ( ( particles(n)%z - zw(kw) ) / ( zw(kw+1)-zw(kw) ) )
    1097           ENDIF
    1098 
    1099           vv_int = ( 1.0_wp / 3.0_wp ) * ( aa + bb + cc )
    1100 
    1101           fs_int = ( 2.0_wp / 3.0_wp ) * e_mean_int / &
    1102                       ( vv_int + ( 2.0_wp / 3.0_wp ) * e_mean_int )
    1103 
     1100          ENDDO
     1101       ENDIF
     1102
     1103       DO nb = 0,7
     1104          i = ip + block_offset(nb)%i_off
     1105          j = jp + block_offset(nb)%j_off
     1106          k = kp + block_offset(nb)%k_off
     1107
     1108          DO  n = start_index(nb), end_index(nb)
     1109!
     1110!--          Vertical interpolation of the horizontally averaged SGS TKE and
     1111!--          resolved-scale velocity variances and use the interpolated values
     1112!--          to calculate the coefficient fs, which is a measure of the ratio
     1113!--          of the subgrid-scale turbulent kinetic energy to the total amount
     1114!--          of turbulent kinetic energy.
     1115             IF ( k == 0 )  THEN
     1116                e_mean_int = hom(0,1,8,0)
     1117             ELSE
     1118                e_mean_int = hom(k,1,8,0) +                                    &
     1119                                           ( hom(k+1,1,8,0) - hom(k,1,8,0) ) / &
     1120                                           ( zu(k+1) - zu(k) ) *               &
     1121                                           ( zv(n) - zu(k) )
     1122             ENDIF
     1123
     1124 !           kw = particles(n)%z / dz
     1125             kw = kp-1                                    ! ok for ocean??? ( + offset_ocean_nzt_m1 ???)
     1126
     1127             IF ( k == 0 )  THEN
     1128                aa  = hom(k+1,1,30,0)  * ( zv(n) / &
     1129                                         ( 0.5_wp * ( zu(k+1) - zu(k) ) ) )
     1130                bb  = hom(k+1,1,31,0)  * ( zv(n) / &
     1131                                         ( 0.5_wp * ( zu(k+1) - zu(k) ) ) )
     1132                cc  = hom(kw+1,1,32,0) * ( zv(n) / &
     1133                                         ( 1.0_wp * ( zw(kw+1) - zw(kw) ) ) )
     1134             ELSE
     1135                aa  = hom(k,1,30,0) + ( hom(k+1,1,30,0) - hom(k,1,30,0) ) *    &
     1136                           ( ( zv(n) - zu(k) ) / ( zu(k+1) - zu(k) ) )
     1137                bb  = hom(k,1,31,0) + ( hom(k+1,1,31,0) - hom(k,1,31,0) ) *    &
     1138                           ( ( zv(n) - zu(k) ) / ( zu(k+1) - zu(k) ) )
     1139                cc  = hom(kw,1,32,0) + ( hom(kw+1,1,32,0)-hom(kw,1,32,0) ) *   &
     1140                           ( ( zv(n) - zw(kw) ) / ( zw(kw+1)-zw(kw) ) )
     1141             ENDIF
     1142
     1143             vv_int = ( 1.0_wp / 3.0_wp ) * ( aa + bb + cc )
     1144!
     1145!--          Needed to avoid NaN particle velocities. The value of 1.0 is just
     1146!--          an educated guess for the given case.
     1147             IF ( vv_int + ( 2.0_wp / 3.0_wp ) * e_mean_int == 0.0_wp )  THEN
     1148                fs_int(n) = 1.0_wp
     1149             ELSE
     1150                fs_int(n) = ( 2.0_wp / 3.0_wp ) * e_mean_int /                 &
     1151                            ( vv_int + ( 2.0_wp / 3.0_wp ) * e_mean_int )
     1152             ENDIF
     1153
     1154          ENDDO
     1155       ENDDO
     1156
     1157       DO  n = 1, number_of_particles
     1158
     1159         rg(n,1) = random_gauss( iran_part, 5.0_wp )
     1160         rg(n,2) = random_gauss( iran_part, 5.0_wp )
     1161         rg(n,3) = random_gauss( iran_part, 5.0_wp )
     1162
     1163       ENDDO
     1164
     1165       DO  n = 1, number_of_particles
    11041166!
    11051167!--       Calculate the Lagrangian timescale according to Weil et al. (2004).
    1106           lagr_timescale = ( 4.0 * e_int ) / &
    1107                            ( 3.0 * fs_int * c_0 * diss_int )
     1168          lagr_timescale = ( 4.0_wp * e_int(n) ) / &
     1169                           ( 3.0_wp * fs_int(n) * c_0 * diss_int(n) )
    11081170
    11091171!
    … …  
    11111173!--       complete the current LES timestep.
    11121174          dt_gap = dt_3d - particles(n)%dt_sum
    1113           dt_particle = MIN( dt_3d, 0.025 * lagr_timescale, dt_gap )
     1175          dt_particle(n) = MIN( dt_3d, 0.025_wp * lagr_timescale, dt_gap )
    11141176
    11151177!
    11161178!--       The particle timestep should not be too small in order to prevent
    11171179!--       the number of particle timesteps of getting too large
    1118           IF ( dt_particle < dt_min_part   .AND.  dt_min_part < dt_gap ) &
    1119           THEN
    1120              dt_particle = dt_min_part
     1180          IF ( dt_particle(n) < dt_min_part  .AND.  dt_min_part < dt_gap )  THEN
     1181             dt_particle(n) = dt_min_part
    11211182          ENDIF
    11221183
    11231184!
    11241185!--       Calculate the SGS velocity components
    1125           IF ( particles(n)%age == 0.0 )  THEN
     1186          IF ( particles(n)%age == 0.0_wp )  THEN
    11261187!
    11271188!--          For new particles the SGS components are derived from the SGS
    … …  
    11291190!--          [-5.0*sigma, 5.0*sigma] in order to prevent the SGS velocities
    11301191!--          from becoming unrealistically large.
    1131              particles(n)%rvar1 = SQRT( 2.0 * sgs_wfu_part * e_int ) * &
    1132                                         ( random_gauss( iran_part, 5.0_wp ) - 1.0_wp )
    1133              particles(n)%rvar2 = SQRT( 2.0 * sgs_wfv_part * e_int ) * &
    1134                                         ( random_gauss( iran_part, 5.0_wp ) - 1.0_wp )
    1135              particles(n)%rvar3 = SQRT( 2.0 * sgs_wfw_part * e_int ) * &
    1136                                         ( random_gauss( iran_part, 5.0_wp ) - 1.0_wp )
     1192             particles(n)%rvar1 = SQRT( 2.0_wp * sgs_wfu_part * e_int(n) ) *  &
     1193                                  ( rg(n,1) - 1.0_wp )
     1194             particles(n)%rvar2 = SQRT( 2.0_wp * sgs_wfv_part * e_int(n) ) *  &
     1195                                  ( rg(n,2) - 1.0_wp )
     1196             particles(n)%rvar3 = SQRT( 2.0_wp * sgs_wfw_part * e_int(n) ) *  &
     1197                                  ( rg(n,3) - 1.0_wp )
    11371198
    11381199          ELSE
    1139 
    11401200!
    11411201!--          Restriction of the size of the new timestep: compared to the
    … …  
    11431203
    11441204             dt_particle_m = particles(n)%age - particles(n)%age_m
    1145              IF ( dt_particle > 2.0 * dt_particle_m )  THEN
    1146                 dt_particle = 2.0 * dt_particle_m
     1205             IF ( dt_particle(n) > 2.0_wp * dt_particle_m )  THEN
     1206                dt_particle(n) = 2.0_wp * dt_particle_m
    11471207             ENDIF
    11481208
    … …  
    11531213!--          As negative values for the subgrid TKE are not allowed, the
    11541214!--          change of the subgrid TKE with time cannot be smaller than
    1155 !--          -e_int/dt_particle. This value is used as a lower boundary
     1215!--          -e_int(n)/dt_particle. This value is used as a lower boundary
    11561216!--          value for the change of TKE
    11571217
    1158              de_dt_min = - e_int / dt_particle
    1159 
    1160              de_dt = ( e_int - particles(n)%e_m ) / dt_particle_m
     1218             de_dt_min = - e_int(n) / dt_particle(n)
     1219
     1220             de_dt = ( e_int(n) - particles(n)%e_m ) / dt_particle_m
    11611221
    11621222             IF ( de_dt < de_dt_min )  THEN
    … …  
    11641224             ENDIF
    11651225
    1166              particles(n)%rvar1 = particles(n)%rvar1 - fs_int * c_0 *          &
    1167                                   diss_int * particles(n)%rvar1 * dt_particle /&
    1168                                   ( 4.0 * sgs_wfu_part * e_int ) +             &
    1169                                   ( 2.0 * sgs_wfu_part * de_dt *               &
    1170                                     particles(n)%rvar1 /                       &
    1171                                     ( 2.0 * sgs_wfu_part * e_int ) + de_dx_int &
    1172                                   ) * dt_particle / 2.0          +             &
    1173                                   SQRT( fs_int * c_0 * diss_int ) *            &
    1174                                   ( random_gauss( iran_part, 5.0_wp ) - 1.0_wp ) *   &
    1175                                   SQRT( dt_particle )
    1176 
    1177              particles(n)%rvar2 = particles(n)%rvar2 - fs_int * c_0 *          &
    1178                                   diss_int * particles(n)%rvar2 * dt_particle /&
    1179                                   ( 4.0 * sgs_wfv_part * e_int ) +             &
    1180                                   ( 2.0 * sgs_wfv_part * de_dt *               &
    1181                                     particles(n)%rvar2 /                       &
    1182                                     ( 2.0 * sgs_wfv_part * e_int ) + de_dy_int &
    1183                                   ) * dt_particle / 2.0_wp          +             &
    1184                                   SQRT( fs_int * c_0 * diss_int ) *            &
    1185                                   ( random_gauss( iran_part, 5.0_wp ) - 1.0_wp ) *   &
    1186                                   SQRT( dt_particle )
    1187 
    1188              particles(n)%rvar3 = particles(n)%rvar3 - fs_int * c_0 *          &
    1189                                   diss_int * particles(n)%rvar3 * dt_particle /&
    1190                                   ( 4.0 * sgs_wfw_part * e_int ) +             &
    1191                                   ( 2.0 * sgs_wfw_part * de_dt *               &
    1192                                     particles(n)%rvar3 /                       &
    1193                                     ( 2.0 * sgs_wfw_part * e_int ) + de_dz_int &
    1194                                   ) * dt_particle / 2.0_wp         +             &
    1195                                   SQRT( fs_int * c_0 * diss_int ) *            &
    1196                                   ( random_gauss( iran_part, 5.0_wp ) - 1.0_wp ) *   &
    1197                                   SQRT( dt_particle )
     1226             particles(n)%rvar1 = particles(n)%rvar1 - fs_int(n) * c_0 *       &
     1227                           diss_int(n) * particles(n)%rvar1 * dt_particle(n) / &
     1228                           ( 4.0_wp * sgs_wfu_part * e_int(n) ) +              &
     1229                           ( 2.0_wp * sgs_wfu_part * de_dt *                   &
     1230                             particles(n)%rvar1 /                              &
     1231                             ( 2.0_wp * sgs_wfu_part * e_int(n) ) +            &
     1232                             de_dx_int(n)                                      &
     1233                           ) * dt_particle(n) / 2.0_wp          +              &
     1234                           SQRT( fs_int(n) * c_0 * diss_int(n) ) *             &
     1235                           ( rg(n,1) - 1.0_wp ) *                              &
     1236                           SQRT( dt_particle(n) )
     1237
     1238             particles(n)%rvar2 = particles(n)%rvar2 - fs_int(n) * c_0 *       &
     1239                           diss_int(n) * particles(n)%rvar2 * dt_particle(n) / &
     1240                           ( 4.0_wp * sgs_wfv_part * e_int(n) ) +              &
     1241                           ( 2.0_wp * sgs_wfv_part * de_dt *                   &
     1242                             particles(n)%rvar2 /                              &
     1243                             ( 2.0_wp * sgs_wfv_part * e_int(n) ) +            &
     1244                             de_dy_int(n)                                      &
     1245                           ) * dt_particle(n) / 2.0_wp          +              &
     1246                           SQRT( fs_int(n) * c_0 * diss_int(n) ) *             &
     1247                           ( rg(n,2) - 1.0_wp ) *                              &
     1248                           SQRT( dt_particle(n) )
     1249
     1250             particles(n)%rvar3 = particles(n)%rvar3 - fs_int(n) * c_0 *       &
     1251                           diss_int(n) * particles(n)%rvar3 * dt_particle(n) / &
     1252                           ( 4.0_wp * sgs_wfw_part * e_int(n) ) +              &
     1253                           ( 2.0_wp * sgs_wfw_part * de_dt *                   &
     1254                             particles(n)%rvar3 /                              &
     1255                             ( 2.0_wp * sgs_wfw_part * e_int(n) ) +            &
     1256                             de_dz_int(n)                                      &
     1257                           ) * dt_particle(n) / 2.0_wp          +              &
     1258                           SQRT( fs_int(n) * c_0 * diss_int(n) ) *             &
     1259                           ( rg(n,3) - 1.0_wp ) *                              &
     1260                           SQRT( dt_particle(n) )
    11981261
    11991262          ENDIF
    1200 
    1201           u_int = u_int + particles(n)%rvar1
    1202           v_int = v_int + particles(n)%rvar2
    1203           w_int = w_int + particles(n)%rvar3
     1263          u_int(n) = u_int(n) + particles(n)%rvar1
     1264          v_int(n) = v_int(n) + particles(n)%rvar2
     1265          w_int(n) = w_int(n) + particles(n)%rvar3
    12041266
    12051267!
    12061268!--       Store the SGS TKE of the current timelevel which is needed for
    12071269!--       for calculating the SGS particle velocities at the next timestep
    1208           particles(n)%e_m = e_int
    1209 
    1210        ELSE
    1211 !
    1212 !--       If no SGS velocities are used, only the particle timestep has to
    1213 !--       be set
    1214           dt_particle = dt_3d
    1215 
    1216        ENDIF
    1217 
    1218 !
    1219 !--    Store the old age of the particle ( needed to prevent that a
    1220 !--    particle crosses several PEs during one timestep, and for the
    1221 !--    evaluation of the subgrid particle velocity fluctuations )
    1222        particles(n)%age_m = particles(n)%age
    1223 
    1224 
    1225 !
    1226 !--    Particle advection
    1227        IF ( particle_groups(particles(n)%group)%density_ratio == 0.0 )  THEN
    1228 !
    1229 !--       Pure passive transport (without particle inertia)
    1230           particles(n)%x = particles(n)%x + u_int * dt_particle
    1231           particles(n)%y = particles(n)%y + v_int * dt_particle
    1232           particles(n)%z = particles(n)%z + w_int * dt_particle
    1233 
    1234           particles(n)%speed_x = u_int
    1235           particles(n)%speed_y = v_int
    1236           particles(n)%speed_z = w_int
    1237 
    1238        ELSE
    1239 !
     1270          particles(n)%e_m = e_int(n)
     1271       ENDDO
     1272
     1273    ELSE
     1274!
     1275!--    If no SGS velocities are used, only the particle timestep has to
     1276!--    be set
     1277       dt_particle = dt_3d
     1278
     1279    ENDIF
     1280!
     1281!-- Store the old age of the particle ( needed to prevent that a
     1282!-- particle crosses several PEs during one timestep, and for the
     1283!-- evaluation of the subgrid particle velocity fluctuations )
     1284    particles(1:number_of_particles)%age_m = particles(1:number_of_particles)%age
     1285
     1286    dens_ratio = particle_groups(particles(1:number_of_particles)%group)%density_ratio
     1287
     1288    IF ( ANY( dens_ratio == 0.0_wp ) )  THEN
     1289       DO  n = 1, number_of_particles
     1290
     1291!
     1292!--       Particle advection
     1293          IF ( dens_ratio(n) == 0.0_wp )  THEN
     1294!
     1295!--          Pure passive transport (without particle inertia)
     1296             particles(n)%x = xv(n) + u_int(n) * dt_particle(n)
     1297             particles(n)%y = yv(n) + v_int(n) * dt_particle(n)
     1298             particles(n)%z = zv(n) + w_int(n) * dt_particle(n)
     1299
     1300             particles(n)%speed_x = u_int(n)
     1301             particles(n)%speed_y = v_int(n)
     1302             particles(n)%speed_z = w_int(n)
     1303
     1304          ELSE
     1305!
     1306!--          Transport of particles with inertia
     1307             particles(n)%x = particles(n)%x + particles(n)%speed_x * &
     1308                                               dt_particle(n)
     1309             particles(n)%y = particles(n)%y + particles(n)%speed_y * &
     1310                                               dt_particle(n)
     1311             particles(n)%z = particles(n)%z + particles(n)%speed_z * &
     1312                                               dt_particle(n)
     1313
     1314!
     1315!--          Update of the particle velocity
     1316             IF ( cloud_droplets )  THEN
     1317                exp_arg  = 4.5_wp * dens_ratio(n) * molecular_viscosity /      &
     1318                           ( particles(n)%radius )**2 *                        &
     1319                           ( 1.0_wp + 0.15_wp * ( 2.0_wp * particles(n)%radius &
     1320                             * SQRT( ( u_int(n) - particles(n)%speed_x )**2 +  &
     1321                                     ( v_int(n) - particles(n)%speed_y )**2 +  &
     1322                                     ( w_int(n) - particles(n)%speed_z )**2 )  &
     1323                                          / molecular_viscosity )**0.687_wp    &
     1324                           )
     1325
     1326                exp_term = EXP( -exp_arg * dt_particle(n) )
     1327             ELSEIF ( use_sgs_for_particles )  THEN
     1328                exp_arg  = particle_groups(particles(n)%group)%exp_arg
     1329                exp_term = EXP( -exp_arg * dt_particle(n) )
     1330             ELSE
     1331                exp_arg  = particle_groups(particles(n)%group)%exp_arg
     1332                exp_term = particle_groups(particles(n)%group)%exp_term
     1333             ENDIF
     1334             particles(n)%speed_x = particles(n)%speed_x * exp_term +          &
     1335                                    u_int(n) * ( 1.0_wp - exp_term )
     1336             particles(n)%speed_y = particles(n)%speed_y * exp_term +          &
     1337                                    v_int(n) * ( 1.0_wp - exp_term )
     1338             particles(n)%speed_z = particles(n)%speed_z * exp_term +          &
     1339                                    ( w_int(n) - ( 1.0_wp - dens_ratio(n) ) *  &
     1340                                    g / exp_arg ) * ( 1.0_wp - exp_term )
     1341          ENDIF
     1342
     1343       ENDDO
     1344   
     1345    ELSE
     1346
     1347       DO  n = 1, number_of_particles
     1348
    12401349!--       Transport of particles with inertia
    1241           particles(n)%x = particles(n)%x + particles(n)%speed_x * &
    1242                                             dt_particle
    1243           particles(n)%y = particles(n)%y + particles(n)%speed_y * &
    1244                                             dt_particle
    1245           particles(n)%z = particles(n)%z + particles(n)%speed_z * &
    1246                                             dt_particle
    1247 
     1350          particles(n)%x = xv(n) + particles(n)%speed_x * dt_particle(n)
     1351          particles(n)%y = yv(n) + particles(n)%speed_y * dt_particle(n)
     1352          particles(n)%z = zv(n) + particles(n)%speed_z * dt_particle(n)
    12481353!
    12491354!--       Update of the particle velocity
    1250           dens_ratio = particle_groups(particles(n)%group)%density_ratio
    12511355          IF ( cloud_droplets )  THEN
    1252              exp_arg  = 4.5 * dens_ratio * molecular_viscosity /        &
    1253                         ( particles(n)%radius )**2 *                    &
    1254                         ( 1.0 + 0.15 * ( 2.0 * particles(n)%radius *    &
    1255                           SQRT( ( u_int - particles(n)%speed_x )**2 +   &
    1256                                 ( v_int - particles(n)%speed_y )**2 +   &
    1257                                 ( w_int - particles(n)%speed_z )**2 ) / &
    1258                                          molecular_viscosity )**0.687_wp   &
     1356
     1357             exp_arg  = 4.5_wp * dens_ratio(n) * molecular_viscosity /         &
     1358                        ( particles(n)%radius )**2 *                           &
     1359                        ( 1.0_wp + 0.15_wp * ( 2.0_wp * particles(n)%radius *  &
     1360                          SQRT( ( u_int(n) - particles(n)%speed_x )**2 +       &
     1361                                ( v_int(n) - particles(n)%speed_y )**2 +       &
     1362                                ( w_int(n) - particles(n)%speed_z )**2 ) /     &
     1363                                         molecular_viscosity )**0.687_wp       &
    12591364                        )
    1260              exp_term = EXP( -exp_arg * dt_particle )
     1365
     1366             exp_term = EXP( -exp_arg * dt_particle(n) )
    12611367          ELSEIF ( use_sgs_for_particles )  THEN
    12621368             exp_arg  = particle_groups(particles(n)%group)%exp_arg
    1263              exp_term = EXP( -exp_arg * dt_particle )
     1369             exp_term = EXP( -exp_arg * dt_particle(n) )
    12641370          ELSE
    12651371             exp_arg  = particle_groups(particles(n)%group)%exp_arg
    … …  
    12671373          ENDIF
    12681374          particles(n)%speed_x = particles(n)%speed_x * exp_term +             &
    1269                                  u_int * ( 1.0 - exp_term )
     1375                                 u_int(n) * ( 1.0_wp - exp_term )
    12701376          particles(n)%speed_y = particles(n)%speed_y * exp_term +             &
    1271                                  v_int * ( 1.0 - exp_term )
     1377                                 v_int(n) * ( 1.0_wp - exp_term )
    12721378          particles(n)%speed_z = particles(n)%speed_z * exp_term +             &
    1273                                  ( w_int - ( 1.0 - dens_ratio ) * g / exp_arg )&
    1274                                  * ( 1.0 - exp_term )
    1275        ENDIF
    1276 
     1379                                 ( w_int(n) - ( 1.0_wp - dens_ratio(n) ) * g / &
     1380                                 exp_arg ) * ( 1.0_wp - exp_term )
     1381       ENDDO
     1382
     1383    ENDIF
     1384
     1385    DO  n = 1, number_of_particles
    12771386!
    12781387!--    Increment the particle age and the total time that the particle
    12791388!--    has advanced within the particle timestep procedure
    1280        particles(n)%age    = particles(n)%age    + dt_particle
    1281        particles(n)%dt_sum = particles(n)%dt_sum + dt_particle
     1389       particles(n)%age    = particles(n)%age    + dt_particle(n)
     1390       particles(n)%dt_sum = particles(n)%dt_sum + dt_particle(n)
    12821391
    12831392!
    12841393!--    Check whether there is still a particle that has not yet completed
    12851394!--    the total LES timestep
    1286        IF ( ( dt_3d - particles(n)%dt_sum ) > 1E-8 )  THEN
     1395       IF ( ( dt_3d - particles(n)%dt_sum ) > 1E-8_wp )  THEN
    12871396          dt_3d_reached_l = .FALSE.
    12881397       ENDIF
    … …  
    12901399    ENDDO
    12911400
     1401    CALL cpu_log( log_point_s(44), 'lpm_advec', 'pause' )
    12921402
    12931403 END SUBROUTINE lpm_advec

  • TabularUnified palm/trunk/SOURCE/lpm_boundary_conds.f90

    r1321 r1359  
    2020! Current revisions:
    2121! -----------------
     22! New particle structure integrated.
     23! Kind definition added to all floating point numbers.
    2224!
    2325! Former revisions:
    … …  
    6668
    6769    USE control_parameters,                                                    &
    68         ONLY:  dz, message_string, particle_maximum_age
     70        ONLY:  dz, message_string, particle_maximum_age, simulated_time
    6971
    7072    USE cpulog,                                                                &
    … …  
    8183    USE particle_attributes,                                                   &
    8284        ONLY:  deleted_particles, deleted_tails, ibc_par_b, ibc_par_t,         &
    83                number_of_particles, particles, particle_mask,                  &
     85               number_of_particles, particles,                                 &
    8486               particle_tail_coordinates, particle_type, offset_ocean_nzt_m1,  &
    8587               tail_mask, use_particle_tails, use_sgs_for_particles
    … …  
    158160
    159161          IF ( particles(n)%age > particle_maximum_age  .AND.  &
    160                particle_mask(n) )                              &
     162               particles(n)%particle_mask )                              &
    161163          THEN
    162              particle_mask(n)  = .FALSE.
     164             particles(n)%particle_mask  = .FALSE.
    163165             deleted_particles = deleted_particles + 1
    164166             IF ( use_particle_tails  .AND.  nn /= 0 )  THEN
    … …  
    168170          ENDIF
    169171
    170           IF ( particles(n)%z >= zu(nz)  .AND.  particle_mask(n) )  THEN
     172          IF ( particles(n)%z >= zu(nz)  .AND.  particles(n)%particle_mask )  THEN
    171173             IF ( ibc_par_t == 1 )  THEN
    172174!
    173175!--             Particle absorption
    174                 particle_mask(n)  = .FALSE.
     176                particles(n)%particle_mask  = .FALSE.
    175177                deleted_particles = deleted_particles + 1
    176178                IF ( use_particle_tails  .AND.  nn /= 0 )  THEN
    … …  
    181183!
    182184!--             Particle reflection
    183                 particles(n)%z       = 2.0 * zu(nz) - particles(n)%z
     185                particles(n)%z       = 2.0_wp * zu(nz) - particles(n)%z
    184186                particles(n)%speed_z = -particles(n)%speed_z
    185187                IF ( use_sgs_for_particles  .AND. &
    186                      particles(n)%rvar3 > 0.0 )  THEN
     188                     particles(n)%rvar3 > 0.0_wp )  THEN
    187189                   particles(n)%rvar3 = -particles(n)%rvar3
    188190                ENDIF
    189191                IF ( use_particle_tails  .AND.  nn /= 0 )  THEN
    190                    particle_tail_coordinates(1,3,nn) = 2.0 * zu(nz) - &
     192                   particle_tail_coordinates(1,3,nn) = 2.0_wp * zu(nz) - &
    191193                                               particle_tail_coordinates(1,3,nn)
    192194                ENDIF
    193195             ENDIF
    194196          ENDIF
    195           IF ( particles(n)%z < zw(0)  .AND.  particle_mask(n) )  THEN
     197         
     198          IF ( particles(n)%z < zw(0)  .AND.  particles(n)%particle_mask )  THEN
    196199             IF ( ibc_par_b == 1 )  THEN
    197200!
    198201!--             Particle absorption
    199                 particle_mask(n)  = .FALSE.
     202                particles(n)%particle_mask  = .FALSE.
    200203                deleted_particles = deleted_particles + 1
    201204                IF ( use_particle_tails  .AND.  nn /= 0 )  THEN
    … …  
    206209!
    207210!--             Particle reflection
    208                 particles(n)%z       = 2.0 * zw(0) - particles(n)%z
     211                particles(n)%z       = 2.0_wp * zw(0) - particles(n)%z
    209212                particles(n)%speed_z = -particles(n)%speed_z
    210213                IF ( use_sgs_for_particles  .AND. &
    211                      particles(n)%rvar3 < 0.0 )  THEN
     214                     particles(n)%rvar3 < 0.0_wp )  THEN
    212215                   particles(n)%rvar3 = -particles(n)%rvar3
    213216                ENDIF
    214217                IF ( use_particle_tails  .AND.  nn /= 0 )  THEN
    215                    particle_tail_coordinates(1,3,nn) = 2.0 * zu(nz) - &
     218                   particle_tail_coordinates(1,3,nn) = 2.0_wp * zu(nz) - &
    216219                                               particle_tail_coordinates(1,3,nn)
    217220                ENDIF
    218221                IF ( use_particle_tails  .AND.  nn /= 0 )  THEN
    219                    particle_tail_coordinates(1,3,nn) = 2.0 * zw(0) - &
     222                   particle_tail_coordinates(1,3,nn) = 2.0_wp * zw(0) - &
    220223                                               particle_tail_coordinates(1,3,nn)
    221224                ENDIF
    … …  
    236239          dt_particle = particles(n)%age - particles(n)%age_m
    237240
    238           i2 = ( particles(n)%x + 0.5 * dx ) * ddx
    239           j2 = ( particles(n)%y + 0.5 * dy ) * ddy
     241          i2 = ( particles(n)%x + 0.5_wp * dx ) * ddx
     242          j2 = ( particles(n)%y + 0.5_wp * dy ) * ddy
    240243          k2 = particles(n)%z / dz + 1 + offset_ocean_nzt_m1
    241244
    … …  
    251254             pos_y_old = particles(n)%y - particles(n)%speed_y * dt_particle
    252255             pos_z_old = particles(n)%z - particles(n)%speed_z * dt_particle
    253              i1 = ( pos_x_old + 0.5 * dx ) * ddx
    254              j1 = ( pos_y_old + 0.5 * dy ) * ddy
     256             i1 = ( pos_x_old + 0.5_wp * dx ) * ddx
     257             j1 = ( pos_y_old + 0.5_wp * dy ) * ddy
    255258             k1 = pos_z_old / dz + offset_ocean_nzt_m1
    256259
    257260!
    258261!--          Case 1
    259              IF ( particles(n)%x > pos_x_old .AND. particles(n)%y > pos_y_old )&
     262             IF ( particles(n)%x > pos_x_old  .AND. particles(n)%y > pos_y_old )&
    260263             THEN
    261264                t_index = 1
    262265
    263266                DO  i = i1, i2
    264                    xline      = i * dx + 0.5 * dx
     267                   xline      = i * dx + 0.5_wp * dx
    265268                   t(t_index) = ( xline - pos_x_old ) / &
    266269                                ( particles(n)%x - pos_x_old )
    … …  
    269272
    270273                DO  j = j1, j2
    271                    yline      = j * dy + 0.5 * dy
     274                   yline      = j * dy + 0.5_wp * dy
    272275                   t(t_index) = ( yline - pos_y_old ) / &
    273276                                ( particles(n)%y - pos_y_old )
    … …  
    314317                   pos_z = pos_z_old + t(t_index) * ( prt_z - pos_z_old )
    315318
    316                    i3 = ( pos_x + 0.5 * dx ) * ddx   
    317                    j3 = ( pos_y + 0.5 * dy ) * ddy
     319                   i3 = ( pos_x + 0.5_wp * dx ) * ddx   
     320                   j3 = ( pos_y + 0.5_wp * dy ) * ddy
    318321                   k3 = pos_z / dz + offset_ocean_nzt_m1
    319322
    … …  
    353356                      ENDIF
    354357
    355                       IF ( pos_y == ( j3 * dy - 0.5 * dy )  .AND. &
     358                      IF ( pos_y == ( j3 * dy - 0.5_wp * dy )  .AND. &
    356359                           pos_z < nzb_s_inner(j3,i3) * dz )  THEN
    357360                         reflect_y = .TRUE.
    … …  
    359362                      ENDIF
    360363
    361                       IF ( pos_x == ( i3 * dx - 0.5 * dx )  .AND. &
     364                      IF ( pos_x == ( i3 * dx - 0.5_wp * dx )  .AND. &
    362365                           pos_z < nzb_s_inner(j3,i3) * dz )  THEN
    363366                         reflect_x = .TRUE.
    … …  
    377380
    378381                DO  i = i1, i2
    379                    xline      = i * dx + 0.5 * dx
     382                   xline      = i * dx + 0.5_wp * dx
    380383                   t(t_index) = ( xline - pos_x_old ) / &
    381384                                ( particles(n)%x - pos_x_old )
    … …  
    384387
    385388                DO  j = j1, j2, -1
    386                    yline      = j * dy - 0.5 * dy
     389                   yline      = j * dy - 0.5_wp * dy
    387390                   t(t_index) = ( pos_y_old - yline ) / &
    388391                                ( pos_y_old - particles(n)%y )
    … …  
    428431                   pos_z = pos_z_old + t(t_index) * ( prt_z - pos_z_old )
    429432
    430                    i3 = ( pos_x + 0.5 * dx ) * ddx
    431                    j3 = ( pos_y + 0.5 * dy ) * ddy
     433                   i3 = ( pos_x + 0.5_wp * dx ) * ddx
     434                   j3 = ( pos_y + 0.5_wp * dy ) * ddy
    432435                   k3 = pos_z / dz + offset_ocean_nzt_m1
    433436
    … …  
    456459                      ENDIF
    457460
    458                       IF ( pos_x == ( i3 * dx - 0.5 * dx )  .AND. &
     461                      IF ( pos_x == ( i3 * dx - 0.5_wp * dx )  .AND. &
    459462                           pos_z < nzb_s_inner(j3,i3) * dz )  THEN
    460463                         reflect_x = .TRUE.
    … …  
    473476                      ENDIF
    474477
    475                       IF ( pos_y == ( j5 * dy + 0.5 * dy )  .AND. &
     478                      IF ( pos_y == ( j5 * dy + 0.5_wp * dy )  .AND. &
    476479                           pos_z < nzb_s_inner(j5,i3) * dz )  THEN
    477480                         reflect_y = .TRUE.
    … …  
    491494
    492495                DO  i = i1, i2, -1
    493                    xline      = i * dx - 0.5 * dx
     496                   xline      = i * dx - 0.5_wp * dx
    494497                   t(t_index) = ( pos_x_old - xline ) / &
    495498                                ( pos_x_old - particles(n)%x )
    … …  
    498501
    499502                DO  j = j1, j2
    500                    yline      = j * dy + 0.5 * dy
     503                   yline      = j * dy + 0.5_wp * dy
    501504                   t(t_index) = ( yline - pos_y_old ) / &
    502505                                ( particles(n)%y - pos_y_old )
    … …  
    543546                   pos_z = pos_z_old + t(t_index) * ( prt_z - pos_z_old )
    544547
    545                    i3 = ( pos_x + 0.5 * dx ) * ddx
    546                    j3 = ( pos_y + 0.5 * dy ) * ddy
     548                   i3 = ( pos_x + 0.5_wp * dx ) * ddx
     549                   j3 = ( pos_y + 0.5_wp * dy ) * ddy
    547550                   k3 = pos_z / dz + offset_ocean_nzt_m1
    548551
    … …  
    571574                      ENDIF
    572575
    573                       IF ( pos_y == ( j3 * dy - 0.5 * dy )  .AND. &
     576                      IF ( pos_y == ( j3 * dy - 0.5_wp * dy )  .AND. &
    574577                           pos_z < nzb_s_inner(j3,i3) * dz )  THEN
    575578                         reflect_y = .TRUE.
    … …  
    588591                      ENDIF
    589592
    590                       IF ( pos_x == ( i5 * dx + 0.5 * dx )  .AND. &
     593                      IF ( pos_x == ( i5 * dx + 0.5_wp * dx )  .AND. &
    591594                           pos_z < nzb_s_inner(j3,i5) * dz )  THEN
    592595                         reflect_x = .TRUE.
    … …  
    606609
    607610                DO  i = i1, i2, -1
    608                    xline      = i * dx - 0.5 * dx
     611                   xline      = i * dx - 0.5_wp * dx
    609612                   t(t_index) = ( pos_x_old - xline ) / &
    610613                                ( pos_x_old - particles(n)%x )
    … …  
    613616
    614617                DO  j = j1, j2, -1
    615                    yline      = j * dy - 0.5 * dy
     618                   yline      = j * dy - 0.5_wp * dy
    616619                   t(t_index) = ( pos_y_old - yline ) / &
    617620                                ( pos_y_old - particles(n)%y )
    … …  
    658661                   pos_z = pos_z_old + t(t_index) * ( prt_z - pos_z_old )
    659662
    660                    i3 = ( pos_x + 0.5 * dx ) * ddx   
    661                    j3 = ( pos_y + 0.5 * dy ) * ddy
     663                   i3 = ( pos_x + 0.5_wp * dx ) * ddx   
     664                   j3 = ( pos_y + 0.5_wp * dy ) * ddy
    662665                   k3 = pos_z / dz + offset_ocean_nzt_m1
    663666
    … …  
    686689                      ENDIF
    687690
    688                       IF ( pos_x == ( i5 * dx + 0.5 * dx )  .AND. &
     691                      IF ( pos_x == ( i5 * dx + 0.5_wp * dx )  .AND. &
    689692                           nzb_s_inner(j3,i5) /=0  .AND.          &
    690693                           pos_z < nzb_s_inner(j3,i5) * dz )  THEN
    … …  
    704707                      ENDIF
    705708
    706                       IF ( pos_y == ( j5 * dy + 0.5 * dy )  .AND. &
     709                      IF ( pos_y == ( j5 * dy + 0.5_wp * dy )  .AND. &
    707710                           nzb_s_inner(j5,i3) /= 0  .AND.         &
    708711                           pos_z < nzb_s_inner(j5,i3) * dz )  THEN
    … …  
    724727          IF ( reflect_z )  THEN
    725728
    726              particles(n)%z       = 2.0 * pos_z - prt_z
     729             particles(n)%z       = 2.0_wp * pos_z - prt_z
    727730             particles(n)%speed_z = - particles(n)%speed_z
    728731
    … …  
    734737          ELSEIF ( reflect_y )  THEN
    735738
    736              particles(n)%y       = 2.0 * pos_y - prt_y
     739             particles(n)%y       = 2.0_wp * pos_y - prt_y
    737740             particles(n)%speed_y = - particles(n)%speed_y
    738741
    … …  
    744747          ELSEIF ( reflect_x )  THEN
    745748
    746              particles(n)%x       = 2.0 * pos_x - prt_x
     749             particles(n)%x       = 2.0_wp * pos_x - prt_x
    747750             particles(n)%speed_x = - particles(n)%speed_x
    748751

  • TabularUnified palm/trunk/SOURCE/lpm_calc_liquid_water_content.f90

    r1321 r1359  
    2020! Current revisions:
    2121! ------------------
     22! New particle structure integrated.
     23! Kind definition added to all floating point numbers.
    2224!
    2325! Former revisions:
    … …  
    6870
    6971    USE particle_attributes,                                                   &
    70         ONLY:  particles, prt_count, prt_start_index
     72        ONLY:  grid_particles, number_of_particles, particles, prt_count
    7173
    7274    IMPLICIT NONE
    … …  
    7880    INTEGER(iwp) ::  psi !:
    7981
    80 
    8182    CALL cpu_log( log_point_s(45), 'lpm_calc_ql', 'start' )
    8283
    8384!
    8485!-- Set water content initially to zero
    85     ql = 0.0;  ql_v = 0.0;  ql_vp = 0.0
     86    ql = 0.0_wp;  ql_v = 0.0_wp;  ql_vp = 0.0_wp
    8687
    8788!
    … …  
    8990    DO  i = nxl, nxr
    9091       DO  j = nys, nyn
    91           DO  k = nzb, nzt+1
     92          DO  k = nzb+1, nzt
     93
     94             number_of_particles = prt_count(k,j,i)
     95             IF ( number_of_particles <= 0 )  CYCLE
     96             particles => grid_particles(k,j,i)%particles(1:number_of_particles)
    9297
    9398!
    9499!--          Calculate the total volume in the boxes (ql_v, weighting factor
    95100!--          has to beincluded)
    96              psi = prt_start_index(k,j,i)
    97              DO  n = psi, psi+prt_count(k,j,i)-1
     101             DO  n = 1, prt_count(k,j,i)
    98102                ql_v(k,j,i)  = ql_v(k,j,i)  + particles(n)%weight_factor *  &
    99103                                              particles(n)%radius**3
    … …  
    102106!
    103107!--          Calculate the liquid water content
    104              IF ( ql_v(k,j,i) /= 0.0 )  THEN
    105                 ql(k,j,i) = ql(k,j,i) + rho_l * 1.33333333 * pi *           &
     108             IF ( ql_v(k,j,i) /= 0.0_wp )  THEN
     109                ql(k,j,i) = ql(k,j,i) + rho_l * 1.33333333_wp * pi *           &
    106110                                        ql_v(k,j,i) /                       &
    107111                                        ( rho_surface * dx * dy * dz )
    108112
    109                 IF ( ql(k,j,i) < 0.0 ) THEN
     113                IF ( ql(k,j,i) < 0.0_wp ) THEN
    110114                   WRITE( message_string, * )  'LWC out of range: ' , &
    111                                                ql(k,j,i)
     115                                               ql(k,j,i),i,j,k
    112116                   CALL message( 'lpm_calc_liquid_water_content', '', 2, 2, &
    113117                                 -1, 6, 1 )
    … …  
    116120             ELSE
    117121
    118                 ql(k,j,i) = 0.0
     122                ql(k,j,i) = 0.0_wp
    119123
    120124             ENDIF

  • TabularUnified palm/trunk/SOURCE/lpm_collision_kernels.f90

    r1347 r1359  
    2020! Current revisions:
    2121! -----------------
    22 !
     22! New particle structure integrated.
     23! Kind definition added to all floating point numbers.
    2324!
    2425! Former revisions:
    … …  
    177178          rclass_lbound = LOG( 1.0E-6_wp )
    178179          rclass_ubound = LOG( 2.0E-4_wp )
    179           radclass(1)   = 1.0E-6
     180          radclass(1)   = 1.0E-6_wp
    180181          DO  i = 2, radius_classes
    181182             radclass(i) = EXP( rclass_lbound +                                &
    182                                 ( rclass_ubound - rclass_lbound ) * ( i-1.0 ) /&
    183                                 ( radius_classes - 1.0 ) )
    184 !             IF ( myid == 0 )  THEN
    185 !                PRINT*, 'i=', i, ' r = ', radclass(i)*1.0E6
    186 !             ENDIF
     183                                ( rclass_ubound - rclass_lbound ) *            &
     184                                ( i - 1.0_wp ) / ( radius_classes - 1.0_wp ) )
    187185          ENDDO
    188186
    … …  
    190188!--       Set the class bounds for dissipation in interval [0.0, 0.1] m**2/s**3
    191189          DO  i = 1, dissipation_classes
    192              epsclass(i) = 0.1 * REAL( i, KIND=wp ) / dissipation_classes
    193 !             IF ( myid == 0 )  THEN
    194 !                PRINT*, 'i=', i, ' eps = ', epsclass(i)
    195 !             ENDIF
     190             epsclass(i) = 0.1_wp * REAL( i, KIND=wp ) / dissipation_classes
    196191          ENDDO
    197192!
    … …  
    205200
    206201             epsilon = epsclass(k)
    207              urms    = 2.02 * ( epsilon / 0.04_wp )**( 1.0_wp / 3.0_wp )
     202             urms    = 2.02_wp * ( epsilon / 0.04_wp )**( 1.0_wp / 3.0_wp )
    208203
    209204             CALL turbsd
    … …  
    240235
    241236             PRINT*, '*** Hall kernel'
    242              WRITE ( *,'(5X,20(F4.0,1X))' ) ( radclass(i)*1.0E6, &
     237             WRITE ( *,'(5X,20(F4.0,1X))' ) ( radclass(i)*1.0E6_wp, &
    243238                                              i = 1,radius_classes )
    244239             DO  j = 1, radius_classes
    … …  
    250245                DO  i = 1, radius_classes
    251246                   DO  j = 1, radius_classes
    252                       IF ( hkernel(i,j) == 0.0 )  THEN
    253                          hwratio(i,j) = 9999999.9
     247                      IF ( hkernel(i,j) == 0.0_wp )  THEN
     248                         hwratio(i,j) = 9999999.9_wp
    254249                      ELSE
    255250                         hwratio(i,j) = ckernel(i,j,k) / hkernel(i,j)
    … …  
    259254
    260255                PRINT*, '*** epsilon = ', epsclass(k)
    261                 WRITE ( *,'(5X,20(F4.0,1X))' ) ( radclass(i)*1.0E6, &
     256                WRITE ( *,'(5X,20(F4.0,1X))' ) ( radclass(i) * 1.0E6_wp, &
    262257                                                 i = 1,radius_classes )
    263258                DO  j = 1, radius_classes
    264 !                   WRITE ( *,'(F4.0,1X,20(F4.2,1X))' ) radclass(j)*1.0E6, &
    265 !                                       ( ckernel(i,j,k), i = 1,radius_classes )
    266                    WRITE ( *,'(F4.0,1X,20(F8.4,1X))' ) radclass(j)*1.0E6, &
     259                   WRITE ( *,'(F4.0,1X,20(F8.4,1X))' ) radclass(j) * 1.0E6_wp, &
    267260                                          ( hwratio(i,j), i = 1,radius_classes )
    268261                ENDDO
    … …  
    292285
    293286       USE particle_attributes,                                                &
    294            ONLY:  prt_count, prt_start_index, radius_classes, wang_kernel
     287           ONLY:  prt_count, radius_classes, wang_kernel
    295288
    296289       IMPLICIT NONE
    … …  
    305298
    306299
    307        pstart = prt_start_index(k1,j1,i1)
    308        pend   = prt_start_index(k1,j1,i1) + prt_count(k1,j1,i1) - 1
     300       pstart = 1
     301       pend   = prt_count(k1,j1,i1)
    309302       radius_classes = prt_count(k1,j1,i1)
    310303
    … …  
    319312          epsilon = diss(k1,j1,i1)   ! dissipation rate in m**2/s**3
    320313       ELSE
    321           epsilon = 0.0
     314          epsilon = 0.0_wp
    322315       ENDIF
    323        urms    = 2.02 * ( epsilon / 0.04_wp )**( 0.33333333333_wp )
    324 
    325        IF ( wang_kernel  .AND.  epsilon > 1.0E-7 )  THEN
     316       urms    = 2.02_wp * ( epsilon / 0.04_wp )**( 0.33333333333_wp )
     317
     318       IF ( wang_kernel  .AND.  epsilon > 1.0E-7_wp )  THEN
    326319!
    327320!--       Call routines to calculate efficiencies for the Wang kernel
    … …  
    442435       lambda_re = urms**2 * SQRT( 15.0_wp / epsilon / molecular_viscosity )
    443436       tl        = urms**2 / epsilon                       ! in s
    444        lf        = 0.5 * urms**3 / epsilon                 ! in m
     437       lf        = 0.5_wp * urms**3 / epsilon              ! in m
    445438       tauk      = SQRT( molecular_viscosity / epsilon )                  ! in s
    446439       eta       = ( molecular_viscosity**3 / epsilon )**0.25_wp          ! in m
    447440       vk        = eta / tauk
    448441
    449        ao = ( 11.0 + 7.0 * lambda_re ) / ( 205.0 + lambda_re )
    450        tt = SQRT( 2.0 * lambda_re / ( SQRT( 15.0_wp ) * ao ) ) * tauk   ! in s
     442       ao = ( 11.0_wp + 7.0_wp * lambda_re ) / ( 205.0_wp + lambda_re )
     443       tt = SQRT( 2.0_wp * lambda_re / ( SQRT( 15.0_wp ) * ao ) ) * tauk  ! in s
    451444
    452445       CALL fallg    ! gives winf in m/s
    … …  
    461454       z   = tt / tl
    462455       be  = SQRT( 2.0_wp ) * lambda / lf
    463        bbb = SQRT( 1.0 - 2.0 * be**2 )
    464        d1  = ( 1.0 + bbb ) / ( 2.0 * bbb )
    465        e1  = lf * ( 1.0 + bbb ) * 0.5   ! in m
    466        d2  = ( 1.0 - bbb ) * 0.5 / bbb
    467        e2  = lf * ( 1.0 - bbb ) * 0.5   ! in m
    468        ccc = SQRT( 1.0 - 2.0 * z**2 )
    469        b1  = ( 1.0 + ccc ) * 0.5 / ccc
    470        c1  = tl * ( 1.0 + ccc ) * 0.5   ! in s
    471        b2  = ( 1.0 - ccc ) * 0.5 / ccc
    472        c2  = tl * ( 1.0 - ccc ) * 0.5   ! in s
     456       bbb = SQRT( 1.0_wp - 2.0_wp * be**2 )
     457       d1  = ( 1.0_wp + bbb ) / ( 2.0_wp * bbb )
     458       e1  = lf * ( 1.0_wp + bbb ) * 0.5_wp   ! in m
     459       d2  = ( 1.0_wp - bbb ) * 0.5_wp / bbb
     460       e2  = lf * ( 1.0_wp - bbb ) * 0.5_wp   ! in m
     461       ccc = SQRT( 1.0_wp - 2.0_wp * z**2 )
     462       b1  = ( 1.0_wp + ccc ) * 0.5_wp / ccc
     463       c1  = tl * ( 1.0_wp + ccc ) * 0.5_wp   ! in s
     464       b2  = ( 1.0_wp - ccc ) * 0.5_wp / ccc
     465       c2  = tl * ( 1.0_wp - ccc ) * 0.5_wp   ! in s
    473466
    474467       DO  i = 1, radius_classes
    … …  
    509502                         b2 * d2* zhi(c2,e2,v1,t1,v2,t2)
    510503             fr       = d1 * EXP( -rrp / e1 ) - d2 * EXP( -rrp / e2 )
    511              v1v2xy   = v1v2xy * fr * urms**2 / tau(i) / tau(j)  ! in m**2/s**2
    512              wrtur2xy = vrms1xy**2 + vrms2xy**2 - 2.0 * v1v2xy  ! in m**2/s**2
    513              IF ( wrtur2xy < 0.0 )  wrtur2xy = 0.0
     504             v1v2xy   = v1v2xy * fr * urms**2 / tau(i) / tau(j)   ! in m**2/s**2
     505             wrtur2xy = vrms1xy**2 + vrms2xy**2 - 2.0_wp * v1v2xy ! in m**2/s**2
     506             IF ( wrtur2xy < 0.0_wp )  wrtur2xy = 0.0_wp
    514507             wrgrav2  = pi / 8.0_wp * ( winf(j) - winf(i) )**2
    515508             wrfin    = SQRT( ( 2.0_wp / pi ) * ( wrtur2xy + wrgrav2) ) ! in m/s
    … …  
    523516             ENDIF
    524517
    525              xx = -0.1988 * sst**4 + 1.5275 * sst**3 - 4.2942 * sst**2 + &
    526                    5.3406 * sst
    527              IF ( xx < 0.0 )  xx = 0.0
    528              yy = 0.1886 * EXP( 20.306_wp / lambda_re )
     518             xx = -0.1988_wp * sst**4 + 1.5275_wp * sst**3 - 4.2942_wp *      &
     519                   sst**2 + 5.3406_wp * sst
     520             IF ( xx < 0.0_wp )  xx = 0.0_wp
     521             yy = 0.1886_wp * EXP( 20.306_wp / lambda_re )
    529522
    530523             c1_gr  =  xx / ( g / vk * tauk )**yy
    531524
    532525             ao_gr  = ao + ( pi / 8.0_wp) * ( g / vk * tauk )**2
    533              fao_gr = 20.115 * SQRT( ao_gr / lambda_re )
     526             fao_gr = 20.115_wp * SQRT( ao_gr / lambda_re )
    534527             rc     = SQRT( fao_gr * ABS( st(j) - st(i) ) ) * eta   ! in cm
    535528
    536              grfin  = ( ( eta**2 + rc**2 ) / ( rrp**2 + rc**2) )**( c1_gr*0.5 )
    537              IF ( grfin < 1.0 )  grfin = 1.0
    538 
    539              gck(i,j) = 2.0 * pi * rrp**2 * wrfin * grfin           ! in cm**3/s
     529             grfin  = ( ( eta**2 + rc**2 ) / ( rrp**2 + rc**2) )**( c1_gr*0.5_wp )
     530             IF ( grfin < 1.0_wp )  grfin = 1.0_wp
     531
     532             gck(i,j) = 2.0_wp * pi * rrp**2 * wrfin * grfin        ! in cm**3/s
    540533             gck(j,i) = gck(i,j)
    541534
    … …  
    559552       REAL(wp) ::  vsett !:
    560553
    561        aa1 = 1.0 / tau0 + 1.0 / a + vsett / b
    562        phi_w = 1.0 / aa1  - 0.5 * vsett / b / aa1**2  ! in s
     554       aa1 = 1.0_wp / tau0 + 1.0_wp / a + vsett / b
     555       phi_w = 1.0_wp / aa1  - 0.5_wp * vsett / b / aa1**2  ! in s
    563556
    564557    END FUNCTION phi_w
    … …  
    585578       REAL(wp) ::  vsett2 !:
    586579
    587        aa1 = vsett2 / b - 1.0 / tau2 - 1.0 / a
    588        aa2 = vsett1 / b + 1.0 / tau1 + 1.0 / a
    589        aa3 = ( vsett1 - vsett2 ) / b + 1.0 / tau1 + 1.0 / tau2
    590        aa4 = ( vsett2 / b )**2 - ( 1.0 / tau2 + 1.0 / a )**2
    591        aa5 = vsett2 / b + 1.0 / tau2 + 1.0 / a
    592        aa6 = 1.0 / tau1 - 1.0 / a + ( 1.0 / tau2 + 1.0 / a) * vsett1 / vsett2
    593        zhi = (1.0 / aa1 - 1.0 / aa2 ) * ( vsett1 - vsett2 ) * 0.5 / b / aa3**2 &
    594            + (4.0 / aa4 - 1.0 / aa5**2 - 1.0 / aa1**2 ) * vsett2 * 0.5 / b /aa6&
    595            + (2.0 * ( b / aa2 - b / aa1 ) - vsett1 / aa2**2 + vsett2 / aa1**2 )&
    596            * 0.5 / b / aa3      ! in s**2
     580       aa1 = vsett2 / b - 1.0_wp / tau2 - 1.0_wp / a
     581       aa2 = vsett1 / b + 1.0_wp / tau1 + 1.0_wp / a
     582       aa3 = ( vsett1 - vsett2 ) / b + 1.0_wp / tau1 + 1.0_wp / tau2
     583       aa4 = ( vsett2 / b )**2 - ( 1.0_wp / tau2 + 1.0_wp / a )**2
     584       aa5 = vsett2 / b + 1.0_wp / tau2 + 1.0_wp / a
     585       aa6 = 1.0_wp / tau1 - 1.0_wp / a + ( 1.0_wp / tau2 + 1.0_wp / a) *      &
     586             vsett1 / vsett2
     587       zhi = (1.0_wp / aa1 - 1.0_wp / aa2 ) * ( vsett1 - vsett2 ) * 0.5_wp /   &
     588             b / aa3**2 + ( 4.0_wp / aa4 - 1.0_wp / aa5**2 - 1.0_wp / aa1**2 ) &
     589             * vsett2 * 0.5_wp / b /aa6 + ( 2.0_wp * ( b / aa2 - b / aa1 ) -   &
     590             vsett1 / aa2**2 + vsett2 / aa1**2 ) * 0.5_wp / b / aa3    ! in s**2
    597591
    598592    END FUNCTION zhi
    … …  
    645639
    646640          first = .FALSE.
    647           b = (/  -0.318657E1,  0.992696E0, -0.153193E-2, -0.987059E-3, &
    648                  -0.578878E-3, 0.855176E-4, -0.327815E-5 /)
    649           c = (/  -0.500015E1,  0.523778E1,  -0.204914E1,   0.475294E0, &
    650                  -0.542819E-1, 0.238449E-2 /)
     641          b = (/  -0.318657E1_wp,   0.992696E0_wp,  -0.153193E-2_wp, &
     642                  -0.987059E-3_wp, -0.578878E-3_wp,  0.855176E-4_wp, &
     643                  -0.327815E-5_wp /)
     644          c = (/  -0.500015E1_wp,   0.523778E1_wp,  -0.204914E1_wp,   &
     645                   0.475294E0_wp,  -0.542819E-1_wp,  0.238449E-2_wp /)
    651646
    652647!
    653648!--       Parameter values for p = 1013,25 hPa and T = 293,15 K
    654           eta   = 1.818E-5         ! in kg/(m s)
    655           xlamb = 6.6E-8           ! in m
    656           rho_a = 1.204            ! in kg/m**3
    657           cunh  = 1.26 * xlamb     ! in m
    658           sigma = 0.07363          ! in kg/s**2
    659           stok  = 2.0  * g * ( rho_l - rho_a ) / ( 9.0 * eta ) ! in 1/(m s)
    660           stb   = 32.0 * rho_a * ( rho_l - rho_a) * g / (3.0 * eta * eta)
     649          eta   = 1.818E-5_wp         ! in kg/(m s)
     650          xlamb = 6.6E-8_wp           ! in m
     651          rho_a = 1.204_wp            ! in kg/m**3
     652          cunh  = 1.26_wp * xlamb     ! in m
     653          sigma = 0.07363_wp          ! in kg/s**2
     654          stok  = 2.0_wp  * g * ( rho_l - rho_a ) / ( 9.0_wp * eta ) ! in 1/(m s)
     655          stb   = 32.0_wp * rho_a * ( rho_l - rho_a) * g / (3.0_wp * eta * eta)
    661656          phy   = sigma**3 * rho_a**2 / ( eta**4 * g * ( rho_l - rho_a ) )
    662657          py    = phy**( 1.0_wp / 6.0_wp )
    … …  
    666661       DO  j = 1, radius_classes
    667662
    668           IF ( radclass(j) <= 1.0E-5 ) THEN
     663          IF ( radclass(j) <= 1.0E-5_wp ) THEN
    669664
    670665             winf(j) = stok * ( radclass(j)**2 + cunh * radclass(j) )
    671666
    672           ELSEIF ( radclass(j) > 1.0E-5  .AND.  radclass(j) <= 5.35E-4 )  THEN
     667          ELSEIF ( radclass(j) > 1.0E-5_wp  .AND.  radclass(j) <= 5.35E-4_wp )  THEN
    673668
    674669             x = LOG( stb * radclass(j)**3 )
    675              y = 0.0
     670             y = 0.0_wp
    676671
    677672             DO  i = 1, 7
    … …  
    681676!--          Note: this Eq. is wrong in (Pruppacher and Klett, 1997, p. 418)
    682677!--          for correct version see (Beard, 1976)
    683              xrey = ( 1.0 + cunh / radclass(j) ) * EXP( y )
    684 
    685              winf(j) = xrey * eta / ( 2.0 * rho_a * radclass(j) )
    686 
    687           ELSEIF ( radclass(j) > 5.35E-4 )  THEN
    688 
    689              IF ( radclass(j) > 0.0035 )  THEN
    690                 bond = g * ( rho_l - rho_a ) * 0.0035**2 / sigma
     678             xrey = ( 1.0_wp + cunh / radclass(j) ) * EXP( y )
     679
     680             winf(j) = xrey * eta / ( 2.0_wp * rho_a * radclass(j) )
     681
     682          ELSEIF ( radclass(j) > 5.35E-4_wp )  THEN
     683
     684             IF ( radclass(j) > 0.0035_wp )  THEN
     685                bond = g * ( rho_l - rho_a ) * 0.0035_wp**2 / sigma
    691686             ELSE
    692687               bond = g * ( rho_l - rho_a ) * radclass(j)**2 / sigma
    693688             ENDIF
    694689
    695              x = LOG( 16.0 * bond * py / 3.0_wp )
    696              y = 0.0
     690             x = LOG( 16.0_wp * bond * py / 3.0_wp )
     691             y = 0.0_wp
    697692
    698693             DO  i = 1, 6
    … …  
    702697             xrey = py * EXP( y )
    703698
    704              IF ( radclass(j) > 0.0035 )  THEN
    705                 winf(j) = xrey * eta / ( 2.0 * rho_a * 0.0035_wp )
     699             IF ( radclass(j) > 0.0035_wp )  THEN
     700                winf(j) = xrey * eta / ( 2.0_wp * rho_a * 0.0035_wp )
    706701             ELSE
    707                 winf(j) = xrey * eta / ( 2.0 * rho_a * radclass(j) )
     702                winf(j) = xrey * eta / ( 2.0_wp * rho_a * radclass(j) )
    708703             ENDIF
    709704
    … …  
    752747
    753748         first = .FALSE.
    754          r0  = (/ 6.0, 8.0, 10.0, 15.0, 20.0, 25.0, 30.0, 40.0, 50.0, 60., &
    755                   70.0, 100.0, 150.0, 200.0, 300.0 /)
    756          rat = (/ 0.00, 0.05, 0.10, 0.15, 0.20, 0.25, 0.30, 0.35, 0.40, 0.45, &
    757                   0.50, 0.55, 0.60, 0.65, 0.70, 0.75, 0.80, 0.85, 0.90, 0.95, &
    758                   1.00 /)
    759 
    760          ecoll(:,1) = (/0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, &
    761                         0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001/)
    762          ecoll(:,2) = (/0.003, 0.003, 0.003, 0.004, 0.005, 0.005, 0.005, &
    763                         0.010, 0.100, 0.050, 0.200, 0.500, 0.770, 0.870, 0.970/)
    764          ecoll(:,3) = (/0.007, 0.007, 0.007, 0.008, 0.009, 0.010, 0.010, &
    765                         0.070, 0.400, 0.430, 0.580, 0.790, 0.930, 0.960, 1.000/)
    766          ecoll(:,4) = (/0.009, 0.009, 0.009, 0.012, 0.015, 0.010, 0.020, &
    767                         0.280, 0.600, 0.640, 0.750, 0.910, 0.970, 0.980, 1.000/)
    768          ecoll(:,5) = (/0.014, 0.014, 0.014, 0.015, 0.016, 0.030, 0.060, &
    769                         0.500, 0.700, 0.770, 0.840, 0.950, 0.970, 1.000, 1.000/)
    770          ecoll(:,6) = (/0.017, 0.017, 0.017, 0.020, 0.022, 0.060, 0.100, &
    771                         0.620, 0.780, 0.840, 0.880, 0.950, 1.000, 1.000, 1.000/)
    772          ecoll(:,7) = (/0.030, 0.030, 0.024, 0.022, 0.032, 0.062, 0.200, &
    773                         0.680, 0.830, 0.870, 0.900, 0.950, 1.000, 1.000, 1.000/)
    774          ecoll(:,8) = (/0.025, 0.025, 0.025, 0.036, 0.043, 0.130, 0.270, &
    775                         0.740, 0.860, 0.890, 0.920, 1.000, 1.000, 1.000, 1.000/)
    776          ecoll(:,9) = (/0.027, 0.027, 0.027, 0.040, 0.052, 0.200, 0.400, &
    777                         0.780, 0.880, 0.900, 0.940, 1.000, 1.000, 1.000, 1.000/)
    778          ecoll(:,10)= (/0.030, 0.030, 0.030, 0.047, 0.064, 0.250, 0.500, &
    779                         0.800, 0.900, 0.910, 0.950, 1.000, 1.000, 1.000, 1.000/)
    780          ecoll(:,11)= (/0.040, 0.040, 0.033, 0.037, 0.068, 0.240, 0.550, &
    781                         0.800, 0.900, 0.910, 0.950, 1.000, 1.000, 1.000, 1.000/)
    782          ecoll(:,12)= (/0.035, 0.035, 0.035, 0.055, 0.079, 0.290, 0.580, &
    783                         0.800, 0.900, 0.910, 0.950, 1.000, 1.000, 1.000, 1.000/)
    784          ecoll(:,13)= (/0.037, 0.037, 0.037, 0.062, 0.082, 0.290, 0.590, &
    785                         0.780, 0.900, 0.910, 0.950, 1.000, 1.000, 1.000, 1.000/)
    786          ecoll(:,14)= (/0.037, 0.037, 0.037, 0.060, 0.080, 0.290, 0.580, &
    787                         0.770, 0.890, 0.910, 0.950, 1.000, 1.000, 1.000, 1.000/)
    788          ecoll(:,15)= (/0.037, 0.037, 0.037, 0.041, 0.075, 0.250, 0.540, &
    789                         0.760, 0.880, 0.920, 0.950, 1.000, 1.000, 1.000, 1.000/)
    790          ecoll(:,16)= (/0.037, 0.037, 0.037, 0.052, 0.067, 0.250, 0.510, &
    791                         0.770, 0.880, 0.930, 0.970, 1.000, 1.000, 1.000, 1.000/)
    792          ecoll(:,17)= (/0.037, 0.037, 0.037, 0.047, 0.057, 0.250, 0.490, &
    793                         0.770, 0.890, 0.950, 1.000, 1.000, 1.000, 1.000, 1.000/)
    794          ecoll(:,18)= (/0.036, 0.036, 0.036, 0.042, 0.048, 0.230, 0.470, &
    795                         0.780, 0.920, 1.000, 1.020, 1.020, 1.020, 1.020, 1.020/)
    796          ecoll(:,19)= (/0.040, 0.040, 0.035, 0.033, 0.040, 0.112, 0.450, &
    797                         0.790, 1.010, 1.030, 1.040, 1.040, 1.040, 1.040, 1.040/)
    798          ecoll(:,20)= (/0.033, 0.033, 0.033, 0.033, 0.033, 0.119, 0.470, &
    799                         0.950, 1.300, 1.700, 2.300, 2.300, 2.300, 2.300, 2.300/)
    800          ecoll(:,21)= (/0.027, 0.027, 0.027, 0.027, 0.027, 0.125, 0.520, &
    801                         1.400, 2.300, 3.000, 4.000, 4.000, 4.000, 4.000, 4.000/)
     749         r0  = (/   6.0_wp,   8.0_wp,  10.0_wp, 15.0_wp,  20.0_wp,  25.0_wp,  &
     750                   30.0_wp,  40.0_wp,  50.0_wp, 60.0_wp,  70.0_wp, 100.0_wp,  &
     751                  150.0_wp, 200.0_wp, 300.0_wp /)
     752
     753         rat = (/ 0.00_wp, 0.05_wp, 0.10_wp, 0.15_wp, 0.20_wp, 0.25_wp,       &
     754                  0.30_wp, 0.35_wp, 0.40_wp, 0.45_wp, 0.50_wp, 0.55_wp,       &
     755                  0.60_wp, 0.65_wp, 0.70_wp, 0.75_wp, 0.80_wp, 0.85_wp,       &
     756                  0.90_wp, 0.95_wp, 1.00_wp /)
     757
     758         ecoll(:,1)  = (/ 0.001_wp, 0.001_wp, 0.001_wp, 0.001_wp, 0.001_wp, &
     759                          0.001_wp, 0.001_wp, 0.001_wp, 0.001_wp, 0.001_wp, &
     760                          0.001_wp, 0.001_wp, 0.001_wp, 0.001_wp, 0.001_wp /)
     761         ecoll(:,2)  = (/ 0.003_wp, 0.003_wp, 0.003_wp, 0.004_wp, 0.005_wp, &
     762                          0.005_wp, 0.005_wp, 0.010_wp, 0.100_wp, 0.050_wp, &
     763                          0.200_wp, 0.500_wp, 0.770_wp, 0.870_wp, 0.970_wp /)
     764         ecoll(:,3)  = (/ 0.007_wp, 0.007_wp, 0.007_wp, 0.008_wp, 0.009_wp, &
     765                          0.010_wp, 0.010_wp, 0.070_wp, 0.400_wp, 0.430_wp, &
     766                          0.580_wp, 0.790_wp, 0.930_wp, 0.960_wp, 1.000_wp /)
     767         ecoll(:,4)  = (/ 0.009_wp, 0.009_wp, 0.009_wp, 0.012_wp, 0.015_wp, &
     768                          0.010_wp, 0.020_wp, 0.280_wp, 0.600_wp, 0.640_wp, &
     769                          0.750_wp, 0.910_wp, 0.970_wp, 0.980_wp, 1.000_wp /)
     770         ecoll(:,5)  = (/ 0.014_wp, 0.014_wp, 0.014_wp, 0.015_wp, 0.016_wp, &
     771                          0.030_wp, 0.060_wp, 0.500_wp, 0.700_wp, 0.770_wp, &
     772                          0.840_wp, 0.950_wp, 0.970_wp, 1.000_wp, 1.000_wp /)
     773         ecoll(:,6)  = (/ 0.017_wp, 0.017_wp, 0.017_wp, 0.020_wp, 0.022_wp, &
     774                          0.060_wp, 0.100_wp, 0.620_wp, 0.780_wp, 0.840_wp, &
     775                          0.880_wp, 0.950_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
     776         ecoll(:,7)  = (/ 0.030_wp, 0.030_wp, 0.024_wp, 0.022_wp, 0.032_wp, &
     777                          0.062_wp, 0.200_wp, 0.680_wp, 0.830_wp, 0.870_wp, &
     778                          0.900_wp, 0.950_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
     779         ecoll(:,8)  = (/ 0.025_wp, 0.025_wp, 0.025_wp, 0.036_wp, 0.043_wp, &
     780                          0.130_wp, 0.270_wp, 0.740_wp, 0.860_wp, 0.890_wp, &
     781                          0.920_wp, 1.000_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
     782         ecoll(:,9)  = (/ 0.027_wp, 0.027_wp, 0.027_wp, 0.040_wp, 0.052_wp, &
     783                          0.200_wp, 0.400_wp, 0.780_wp, 0.880_wp, 0.900_wp, &
     784                          0.940_wp, 1.000_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
     785         ecoll(:,10) = (/ 0.030_wp, 0.030_wp, 0.030_wp, 0.047_wp, 0.064_wp, &
     786                          0.250_wp, 0.500_wp, 0.800_wp, 0.900_wp, 0.910_wp, &
     787                          0.950_wp, 1.000_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
     788         ecoll(:,11) = (/ 0.040_wp, 0.040_wp, 0.033_wp, 0.037_wp, 0.068_wp, &
     789                          0.240_wp, 0.550_wp, 0.800_wp, 0.900_wp, 0.910_wp, &
     790                          0.950_wp, 1.000_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
     791         ecoll(:,12) = (/ 0.035_wp, 0.035_wp, 0.035_wp, 0.055_wp, 0.079_wp, &
     792                          0.290_wp, 0.580_wp, 0.800_wp, 0.900_wp, 0.910_wp, &
     793                          0.950_wp, 1.000_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
     794         ecoll(:,13) = (/ 0.037_wp, 0.037_wp, 0.037_wp, 0.062_wp, 0.082_wp, &
     795                          0.290_wp, 0.590_wp, 0.780_wp, 0.900_wp, 0.910_wp, &
     796                          0.950_wp, 1.000_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
     797         ecoll(:,14) = (/ 0.037_wp, 0.037_wp, 0.037_wp, 0.060_wp, 0.080_wp, &
     798                          0.290_wp, 0.580_wp, 0.770_wp, 0.890_wp, 0.910_wp, &
     799                          0.950_wp, 1.000_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
     800         ecoll(:,15) = (/ 0.037_wp, 0.037_wp, 0.037_wp, 0.041_wp, 0.075_wp, &
     801                          0.250_wp, 0.540_wp, 0.760_wp, 0.880_wp, 0.920_wp, &
     802                          0.950_wp, 1.000_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
     803         ecoll(:,16) = (/ 0.037_wp, 0.037_wp, 0.037_wp, 0.052_wp, 0.067_wp, &
     804                          0.250_wp, 0.510_wp, 0.770_wp, 0.880_wp, 0.930_wp, &
     805                          0.970_wp, 1.000_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
     806         ecoll(:,17) = (/ 0.037_wp, 0.037_wp, 0.037_wp, 0.047_wp, 0.057_wp, &
     807                          0.250_wp, 0.490_wp, 0.770_wp, 0.890_wp, 0.950_wp, &
     808                          1.000_wp, 1.000_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
     809         ecoll(:,18) = (/ 0.036_wp, 0.036_wp, 0.036_wp, 0.042_wp, 0.048_wp, &
     810                          0.230_wp, 0.470_wp, 0.780_wp, 0.920_wp, 1.000_wp, &
     811                          1.020_wp, 1.020_wp, 1.020_wp, 1.020_wp, 1.020_wp /)
     812         ecoll(:,19) = (/ 0.040_wp, 0.040_wp, 0.035_wp, 0.033_wp, 0.040_wp, &
     813                          0.112_wp, 0.450_wp, 0.790_wp, 1.010_wp, 1.030_wp, &
     814                          1.040_wp, 1.040_wp, 1.040_wp, 1.040_wp, 1.040_wp /)
     815         ecoll(:,20) = (/ 0.033_wp, 0.033_wp, 0.033_wp, 0.033_wp, 0.033_wp, &
     816                          0.119_wp, 0.470_wp, 0.950_wp, 1.300_wp, 1.700_wp, &
     817                          2.300_wp, 2.300_wp, 2.300_wp, 2.300_wp, 2.300_wp /)
     818         ecoll(:,21) = (/ 0.027_wp, 0.027_wp, 0.027_wp, 0.027_wp, 0.027_wp, &
     819                          0.125_wp, 0.520_wp, 1.400_wp, 2.300_wp, 3.000_wp, &
     820                          4.000_wp, 4.000_wp, 4.000_wp, 4.000_wp, 4.000_wp /)
    802821       ENDIF
    803822
    … …  
    832851                   pp = ( ( radclass(j) * 1.0E06_wp ) - r0(ir-1) ) / &
    833852                        ( r0(ir) - r0(ir-1) )
    834                    qq = ( rq- rat(iq-1) ) / ( rat(iq) - rat(iq-1) )
    835                    ec(j,i) = ( 1.0-pp ) * ( 1.0-qq ) * ecoll(ir-1,iq-1)  &
    836                              + pp * ( 1.0-qq ) * ecoll(ir,iq-1)          &
    837                              + qq * ( 1.0-pp ) * ecoll(ir-1,iq)          &
     853                   qq = ( rq - rat(iq-1) ) / ( rat(iq) - rat(iq-1) )
     854                   ec(j,i) = ( 1.0_wp - pp ) * ( 1.0_wp - qq )                 &
     855                             * ecoll(ir-1,iq-1)                                &
     856                             + pp * ( 1.0_wp - qq ) * ecoll(ir,iq-1)           &
     857                             + qq * ( 1.0_wp - pp ) * ecoll(ir-1,iq)           &
    838858                             + pp * qq * ecoll(ir,iq)
    839859                ELSE
    840860                   qq = ( rq - rat(iq-1) ) / ( rat(iq) - rat(iq-1) )
    841                    ec(j,i) = (1.0-qq) * ecoll(1,iq-1) + qq * ecoll(1,iq)
     861                   ec(j,i) = ( 1.0_wp - qq ) * ecoll(1,iq-1) + qq * ecoll(1,iq)
    842862                ENDIF
    843863             ELSE
    844864                qq = ( rq - rat(iq-1) ) / ( rat(iq) - rat(iq-1) )
    845                 ek = ( 1.0 - qq ) * ecoll(15,iq-1) + qq * ecoll(15,iq)
     865                ek = ( 1.0_wp - qq ) * ecoll(15,iq-1) + qq * ecoll(15,iq)
    846866                ec(j,i) = MIN( ek, 1.0_wp )
    847867             ENDIF
    848868
    849              IF ( ec(j,i) < 1.0E-20 )  ec(j,i) = 0.0
     869             IF ( ec(j,i) < 1.0E-20_wp )  ec(j,i) = 0.0_wp
    850870
    851871             ec(i,j) = ec(j,i)
    … …  
    901921          first = .FALSE.
    902922
    903           r0  = (/ 10.0, 20.0, 30.0, 40.0, 50.0, 60.0, 100.0 /)
    904           rat = (/ 0.0, 0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.9, 1.0 /)
     923          r0  = (/  10.0_wp, 20.0_wp, 30.0_wp, 40.0_wp, 50.0_wp, 60.0_wp,  &
     924                   100.0_wp /)
     925
     926          rat = (/ 0.0_wp, 0.1_wp, 0.2_wp, 0.3_wp, 0.4_wp, 0.5_wp, 0.6_wp, &
     927                   0.7_wp, 0.8_wp, 0.9_wp, 1.0_wp /)
    905928!
    906929!--       for 100 cm**2/s**3
    907           ecoll_100(:,1) = (/1.74,  1.74,  1.773, 1.49,  1.207,  1.207,  1.0 /)
    908           ecoll_100(:,2) = (/1.46,  1.46,  1.421, 1.245, 1.069,  1.069,  1.0 /)
    909           ecoll_100(:,3) = (/1.32,  1.32,  1.245, 1.123, 1.000,  1.000,  1.0 /)
    910           ecoll_100(:,4) = (/1.250, 1.250, 1.148, 1.087, 1.025,  1.025,  1.0 /)
    911           ecoll_100(:,5) = (/1.186, 1.186, 1.066, 1.060, 1.056,  1.056,  1.0 /)
    912           ecoll_100(:,6) = (/1.045, 1.045, 1.000, 1.014, 1.028,  1.028,  1.0 /)
    913           ecoll_100(:,7) = (/1.070, 1.070, 1.030, 1.038, 1.046,  1.046,  1.0 /)
    914           ecoll_100(:,8) = (/1.000, 1.000, 1.054, 1.042, 1.029,  1.029,  1.0 /)
    915           ecoll_100(:,9) = (/1.223, 1.223, 1.117, 1.069, 1.021,  1.021,  1.0 /)
    916           ecoll_100(:,10)= (/1.570, 1.570, 1.244, 1.166, 1.088,  1.088,  1.0 /)
    917           ecoll_100(:,11)= (/20.3,  20.3,  14.6 , 8.61,  2.60,   2.60 ,  1.0 /)
     930          ecoll_100(:,1)  = (/  1.74_wp,   1.74_wp,   1.773_wp, 1.49_wp,  &
     931                                1.207_wp,  1.207_wp,  1.0_wp /)
     932          ecoll_100(:,2)  = (/  1.46_wp,   1.46_wp,   1.421_wp, 1.245_wp, &
     933                                1.069_wp,  1.069_wp,  1.0_wp /)
     934          ecoll_100(:,3)  = (/  1.32_wp,   1.32_wp,   1.245_wp, 1.123_wp, &
     935                                1.000_wp,  1.000_wp,  1.0_wp /)
     936          ecoll_100(:,4)  = (/  1.250_wp,  1.250_wp,  1.148_wp, 1.087_wp, &
     937                                1.025_wp,  1.025_wp,  1.0_wp /)
     938          ecoll_100(:,5)  = (/  1.186_wp,  1.186_wp,  1.066_wp, 1.060_wp, &
     939                                1.056_wp,  1.056_wp,  1.0_wp /)
     940          ecoll_100(:,6)  = (/  1.045_wp,  1.045_wp,  1.000_wp, 1.014_wp, &
     941                                1.028_wp,  1.028_wp,  1.0_wp /)
     942          ecoll_100(:,7)  = (/  1.070_wp,  1.070_wp,  1.030_wp, 1.038_wp, &
     943                                1.046_wp,  1.046_wp,  1.0_wp /)
     944          ecoll_100(:,8)  = (/  1.000_wp,  1.000_wp,  1.054_wp, 1.042_wp, &
     945                                1.029_wp,  1.029_wp,  1.0_wp /)
     946          ecoll_100(:,9)  = (/  1.223_wp,  1.223_wp,  1.117_wp, 1.069_wp, &
     947                                1.021_wp,  1.021_wp,  1.0_wp /)
     948          ecoll_100(:,10) = (/  1.570_wp,  1.570_wp,  1.244_wp, 1.166_wp, &
     949                                1.088_wp,  1.088_wp,  1.0_wp /)
     950          ecoll_100(:,11) = (/ 20.3_wp,   20.3_wp,   14.6_wp,  8.61_wp,  &
     951                                2.60_wp,   2.60_wp,   1.0_wp /)
    918952!
    919953!--       for 400 cm**2/s**3
    920           ecoll_400(:,1) = (/4.976, 4.976,  3.593, 2.519, 1.445,  1.445,  1.0 /)
    921           ecoll_400(:,2) = (/2.984, 2.984,  2.181, 1.691, 1.201,  1.201,  1.0 /)
    922           ecoll_400(:,3) = (/1.988, 1.988,  1.475, 1.313, 1.150,  1.150,  1.0 /)
    923           ecoll_400(:,4) = (/1.490, 1.490,  1.187, 1.156, 1.126,  1.126,  1.0 /)
    924           ecoll_400(:,5) = (/1.249, 1.249,  1.088, 1.090, 1.092,  1.092,  1.0 /)
    925           ecoll_400(:,6) = (/1.139, 1.139,  1.130, 1.091, 1.051,  1.051,  1.0 /)
    926           ecoll_400(:,7) = (/1.220, 1.220,  1.190, 1.138, 1.086,  1.086,  1.0 /)
    927           ecoll_400(:,8) = (/1.325, 1.325,  1.267, 1.165, 1.063,  1.063,  1.0 /)
    928           ecoll_400(:,9) = (/1.716, 1.716,  1.345, 1.223, 1.100,  1.100,  1.0 /)
    929           ecoll_400(:,10)= (/3.788, 3.788,  1.501, 1.311, 1.120,  1.120,  1.0 /)
    930           ecoll_400(:,11)= (/36.52, 36.52,  19.16, 22.80,  26.0,   26.0,  1.0 /)
     954          ecoll_400(:,1)  = (/  4.976_wp,  4.976_wp,  3.593_wp,  2.519_wp, &
     955                                1.445_wp,  1.445_wp,  1.0_wp /)
     956          ecoll_400(:,2)  = (/  2.984_wp,  2.984_wp,  2.181_wp,  1.691_wp, &
     957                                1.201_wp,  1.201_wp,  1.0_wp /)
     958          ecoll_400(:,3)  = (/  1.988_wp,  1.988_wp,  1.475_wp,  1.313_wp, &
     959                                1.150_wp,  1.150_wp,  1.0_wp /)
     960          ecoll_400(:,4)  = (/  1.490_wp,  1.490_wp,  1.187_wp,  1.156_wp, &
     961                                1.126_wp,  1.126_wp,  1.0_wp /)
     962          ecoll_400(:,5)  = (/  1.249_wp,  1.249_wp,  1.088_wp,  1.090_wp, &
     963                                1.092_wp,  1.092_wp,  1.0_wp /)
     964          ecoll_400(:,6)  = (/  1.139_wp,  1.139_wp,  1.130_wp,  1.091_wp, &
     965                                1.051_wp,  1.051_wp,  1.0_wp /)
     966          ecoll_400(:,7)  = (/  1.220_wp,  1.220_wp,  1.190_wp,  1.138_wp, &
     967                                1.086_wp,  1.086_wp,  1.0_wp /)
     968          ecoll_400(:,8)  = (/  1.325_wp,  1.325_wp,  1.267_wp,  1.165_wp, &
     969                                1.063_wp,  1.063_wp,  1.0_wp /)
     970          ecoll_400(:,9)  = (/  1.716_wp,  1.716_wp,  1.345_wp,  1.223_wp, &
     971                                1.100_wp,  1.100_wp,  1.0_wp /)
     972          ecoll_400(:,10) = (/  3.788_wp,  3.788_wp,  1.501_wp,  1.311_wp, &
     973                                1.120_wp,  1.120_wp,  1.0_wp /)
     974          ecoll_400(:,11) = (/ 36.52_wp,  36.52_wp,  19.16_wp,  22.80_wp,  &
     975                               26.0_wp,   26.0_wp,    1.0_wp /)
    931976
    932977       ENDIF
    … …  
    9641009             ENDDO
    9651010
    966              y1 = 0.0001      ! for 0 m**2/s**3
     1011             y1 = 0.0001_wp      ! for 0 m**2/s**3
    9671012
    9681013             IF ( ir < 8 )  THEN
    9691014                IF ( ir >= 2 )  THEN
    970                    pp = ( radclass(j)*1.0E6 - r0(ir-1) ) / ( r0(ir) - r0(ir-1) )
     1015                   pp = ( radclass(j)*1.0E6_wp - r0(ir-1) ) / ( r0(ir) - r0(ir-1) )
    9711016                   qq = ( rq - rat(iq-1) ) / ( rat(iq) - rat(iq-1) )
    972                    y2 = ( 1.0-pp ) * ( 1.0-qq ) * ecoll_100(ir-1,iq-1) + &
    973                                 pp * ( 1.0-qq ) * ecoll_100(ir,iq-1)   + &
    974                                 qq * ( 1.0-pp ) * ecoll_100(ir-1,iq)   + &
    975                                 pp * qq         * ecoll_100(ir,iq)
    976                    y3 = ( 1.0-pp ) * ( 1.0-qq ) * ecoll_400(ir-1,iq-1) + &
    977                                 pp * ( 1.0-qq ) * ecoll_400(ir,iq-1)   + &
    978                                 qq * ( 1.0-pp ) * ecoll_400(ir-1,iq)   + &
    979                                 pp * qq         * ecoll_400(ir,iq)
     1017                   y2 = ( 1.0_wp - pp ) * ( 1.0_wp - qq ) * ecoll_100(ir-1,iq-1) + &
     1018                                pp * ( 1.0_wp - qq ) * ecoll_100(ir,iq-1)        + &
     1019                                qq * ( 1.0_wp - pp ) * ecoll_100(ir-1,iq)        + &
     1020                                pp * qq              * ecoll_100(ir,iq)
     1021                   y3 = ( 1.0-pp ) * ( 1.0_wp - qq ) * ecoll_400(ir-1,iq-1)      + &
     1022                                pp * ( 1.0_wp - qq ) * ecoll_400(ir,iq-1)        + &
     1023                                qq * ( 1.0_wp - pp ) * ecoll_400(ir-1,iq)        + &
     1024                                pp * qq              * ecoll_400(ir,iq)
    9801025                ELSE
    9811026                   qq = ( rq - rat(iq-1) ) / ( rat(iq) - rat(iq-1) )
    982                    y2 = ( 1.0-qq ) * ecoll_100(1,iq-1) + qq * ecoll_100(1,iq)
    983                    y3 = ( 1.0-qq ) * ecoll_400(1,iq-1) + qq * ecoll_400(1,iq)
     1027                   y2 = ( 1.0_wp - qq ) * ecoll_100(1,iq-1) + qq * ecoll_100(1,iq)
     1028                   y3 = ( 1.0_wp - qq ) * ecoll_400(1,iq-1) + qq * ecoll_400(1,iq)
    9841029                ENDIF
    9851030             ELSE
    9861031                qq = ( rq - rat(iq-1) ) / ( rat(iq) - rat(iq-1) )
    987                 y2 = ( 1.0-qq ) * ecoll_100(7,iq-1) + qq * ecoll_100(7,iq)
    988                 y3 = ( 1.0-qq ) * ecoll_400(7,iq-1) + qq * ecoll_400(7,iq)
     1032                y2 = ( 1.0_wp - qq ) * ecoll_100(7,iq-1) + qq * ecoll_100(7,iq)
     1033                y3 = ( 1.0_wp - qq ) * ecoll_400(7,iq-1) + qq * ecoll_400(7,iq)
    9891034             ENDIF
    9901035!
    9911036!--          Linear interpolation of dissipation rate in m**2/s**3
    992              IF ( epsilon <= 0.01 )  THEN
    993                 ecf(j,i) = ( epsilon - 0.01 ) / (   0.0 - 0.01 ) * y1 &
    994                          + ( epsilon -   0.0 ) / ( 0.01 -   0.0 ) * y2
    995              ELSEIF ( epsilon <= 0.06 )  THEN
    996                 ecf(j,i) = ( epsilon - 0.04 ) / ( 0.01 - 0.04 ) * y2 &
    997                          + ( epsilon - 0.01 ) / ( 0.04 - 0.01 ) * y3
     1037             IF ( epsilon <= 0.01_wp )  THEN
     1038                ecf(j,i) = ( epsilon - 0.01_wp ) / ( 0.0_wp  - 0.01_wp ) * y1 &
     1039                         + ( epsilon - 0.0_wp  ) / ( 0.01_wp - 0.0_wp ) * y2
     1040             ELSEIF ( epsilon <= 0.06_wp )  THEN
     1041                ecf(j,i) = ( epsilon - 0.04_wp ) / ( 0.01_wp - 0.04_wp ) * y2 &
     1042                         + ( epsilon - 0.01_wp ) / ( 0.04_wp - 0.01_wp ) * y3
    9981043             ELSE
    999                 ecf(j,i) = (   0.06 - 0.04 ) / ( 0.01 - 0.04 ) * y2 &
    1000                          + (   0.06 - 0.01 ) / ( 0.04 - 0.01 ) * y3
     1044                ecf(j,i) = ( 0.06_wp - 0.04_wp ) / ( 0.01_wp - 0.04_wp ) * y2 &
     1045                         + ( 0.06_wp - 0.01_wp ) / ( 0.04_wp - 0.01_wp ) * y3
    10011046             ENDIF
    10021047
    1003              IF ( ecf(j,i) < 1.0 )  ecf(j,i) = 1.0
     1048             IF ( ecf(j,i) < 1.0_wp )  ecf(j,i) = 1.0_wp
    10041049
    10051050             ecf(i,j) = ecf(j,i)
    … …  
    10411086       REAL(wp)      ::  y       !:
    10421087 
    1043        REAL(wp), DIMENSION(1:9), SAVE      ::  collected_r = 0.0 !:
     1088       REAL(wp), DIMENSION(1:9), SAVE      ::  collected_r = 0.0_wp !:
    10441089       
    1045        REAL(wp), DIMENSION(1:19), SAVE     ::  collector_r = 0.0 !:
     1090       REAL(wp), DIMENSION(1:19), SAVE     ::  collector_r = 0.0_wp !:
    10461091       
    1047        REAL(wp), DIMENSION(1:9,1:19), SAVE ::  ef = 0.0          !:
     1092       REAL(wp), DIMENSION(1:9,1:19), SAVE ::  ef = 0.0_wp          !:
    10481093
    10491094       mean_rm = mean_r * 1.0E06_wp
    … …  
    10521097       IF ( first )  THEN
    10531098
    1054           collected_r = (/ 2.0, 3.0, 4.0, 6.0, 8.0, 10.0, 15.0, 20.0, 25.0 /)
    1055           collector_r = (/ 10.0, 20.0, 30.0, 40.0, 50.0, 60.0, 80.0, 100.0,  &
    1056                            150.0, 200.0, 300.0, 400.0, 500.0, 600.0, 1000.0, &
    1057                            1400.0, 1800.0, 2400.0, 3000.0 /)
    1058 
    1059           ef(:,1) = (/0.017, 0.027, 0.037, 0.052, 0.052, 0.052, 0.052, 0.0, &
    1060                       0.0 /)
    1061           ef(:,2) = (/0.001, 0.016, 0.027, 0.060, 0.12, 0.17, 0.17, 0.17, 0.0 /)
    1062           ef(:,3) = (/0.001, 0.001, 0.02,  0.13,  0.28, 0.37, 0.54, 0.55, 0.47/)
    1063           ef(:,4) = (/0.001, 0.001, 0.02,  0.23,  0.4,  0.55, 0.7,  0.75, 0.75/)
    1064           ef(:,5) = (/0.01,  0.01,  0.03,  0.3,   0.4,  0.58, 0.73, 0.75, 0.79/)
    1065           ef(:,6) = (/0.01,  0.01,  0.13,  0.38,  0.57, 0.68, 0.80, 0.86, 0.91/)
    1066           ef(:,7) = (/0.01,  0.085, 0.23,  0.52,  0.68, 0.76, 0.86, 0.92, 0.95/)
    1067           ef(:,8) = (/0.01,  0.14,  0.32,  0.60,  0.73, 0.81, 0.90, 0.94, 0.96/)
    1068           ef(:,9) = (/0.025, 0.25,  0.43,  0.66,  0.78, 0.83, 0.92, 0.95, 0.96/)
    1069           ef(:,10)= (/0.039, 0.3,   0.46,  0.69,  0.81, 0.87, 0.93, 0.95, 0.96/)
    1070           ef(:,11)= (/0.095, 0.33,  0.51,  0.72,  0.82, 0.87, 0.93, 0.96, 0.97/)
    1071           ef(:,12)= (/0.098, 0.36,  0.51,  0.73,  0.83, 0.88, 0.93, 0.96, 0.97/)
    1072           ef(:,13)= (/0.1,   0.36,  0.52,  0.74,  0.83, 0.88, 0.93, 0.96, 0.97/)
    1073           ef(:,14)= (/0.17,  0.4,   0.54,  0.72,  0.83, 0.88, 0.94, 0.98, 1.0 /)
    1074           ef(:,15)= (/0.15,  0.37,  0.52,  0.74,  0.82, 0.88, 0.94, 0.98, 1.0 /)
    1075           ef(:,16)= (/0.11,  0.34,  0.49,  0.71,  0.83, 0.88, 0.94, 0.95, 1.0 /)
    1076           ef(:,17)= (/0.08,  0.29,  0.45,  0.68,  0.8,  0.86, 0.96, 0.94, 1.0 /)
    1077           ef(:,18)= (/0.04,  0.22,  0.39,  0.62,  0.75, 0.83, 0.92, 0.96, 1.0 /)
    1078           ef(:,19)= (/0.02,  0.16,  0.33,  0.55,  0.71, 0.81, 0.90, 0.94, 1.0 /)
     1099          collected_r = (/    2.0_wp,    3.0_wp,    4.0_wp,    6.0_wp,    8.0_wp, &
     1100                             10.0_wp,   15.0_wp,   20.0_wp,   25.0_wp /)
     1101          collector_r = (/   10.0_wp,   20.0_wp,   30.0_wp,   40.0_wp,   50.0_wp, &
     1102                             60.0_wp,   80.0_wp,  100.0_wp,  150.0_wp,  200.0_wp, &
     1103                            300.0_wp,  400.0_wp,  500.0_wp,  600.0_wp, 1000.0_wp, &
     1104                           1400.0_wp, 1800.0_wp, 2400.0_wp, 3000.0_wp /)
     1105
     1106          ef(:,1)  = (/ 0.017_wp, 0.027_wp, 0.037_wp, 0.052_wp, 0.052_wp,      &
     1107                        0.052_wp, 0.052_wp, 0.0_wp,   0.0_wp /)
     1108          ef(:,2)  = (/ 0.001_wp, 0.016_wp, 0.027_wp, 0.060_wp, 0.12_wp,       &
     1109                        0.17_wp,  0.17_wp,  0.17_wp,  0.0_wp /)
     1110          ef(:,3)  = (/ 0.001_wp, 0.001_wp, 0.02_wp,  0.13_wp,  0.28_wp,       &
     1111                        0.37_wp,  0.54_wp,  0.55_wp,  0.47_wp/)
     1112          ef(:,4)  = (/ 0.001_wp, 0.001_wp, 0.02_wp,  0.23_wp,  0.4_wp,        &
     1113                        0.55_wp,  0.7_wp,   0.75_wp,  0.75_wp/)
     1114          ef(:,5)  = (/ 0.01_wp,  0.01_wp,  0.03_wp,  0.3_wp,   0.4_wp,        &
     1115                        0.58_wp,  0.73_wp,  0.75_wp,  0.79_wp/)
     1116          ef(:,6)  = (/ 0.01_wp,  0.01_wp,  0.13_wp,  0.38_wp,  0.57_wp,       &
     1117                        0.68_wp,  0.80_wp,  0.86_wp,  0.91_wp/)
     1118          ef(:,7)  = (/ 0.01_wp,  0.085_wp, 0.23_wp,  0.52_wp,  0.68_wp,       &
     1119                        0.76_wp,  0.86_wp,  0.92_wp,  0.95_wp/)
     1120          ef(:,8)  = (/ 0.01_wp,  0.14_wp,  0.32_wp,  0.60_wp,  0.73_wp,       &
     1121                        0.81_wp,  0.90_wp,  0.94_wp,  0.96_wp/)
     1122          ef(:,9)  = (/ 0.025_wp, 0.25_wp,  0.43_wp,  0.66_wp,  0.78_wp,       &
     1123                        0.83_wp,  0.92_wp,  0.95_wp,  0.96_wp/)
     1124          ef(:,10) = (/ 0.039_wp, 0.3_wp,   0.46_wp,  0.69_wp,  0.81_wp,       &
     1125                        0.87_wp,  0.93_wp,  0.95_wp,  0.96_wp/)
     1126          ef(:,11) = (/ 0.095_wp, 0.33_wp,  0.51_wp,  0.72_wp,  0.82_wp,       &
     1127                        0.87_wp,  0.93_wp,  0.96_wp,  0.97_wp/)
     1128          ef(:,12) = (/ 0.098_wp, 0.36_wp,  0.51_wp,  0.73_wp,  0.83_wp,       &
     1129                        0.88_wp,  0.93_wp,  0.96_wp,  0.97_wp/)
     1130          ef(:,13) = (/ 0.1_wp,   0.36_wp,  0.52_wp,  0.74_wp,  0.83_wp,       &
     1131                        0.88_wp,  0.93_wp,  0.96_wp,  0.97_wp/)
     1132          ef(:,14) = (/ 0.17_wp,  0.4_wp,   0.54_wp,  0.72_wp,  0.83_wp,       &
     1133                        0.88_wp,  0.94_wp,  0.98_wp,  1.0_wp /)
     1134          ef(:,15) = (/ 0.15_wp,  0.37_wp,  0.52_wp,  0.74_wp,  0.82_wp,       &
     1135                        0.88_wp,  0.94_wp,  0.98_wp,  1.0_wp /)
     1136          ef(:,16) = (/ 0.11_wp,  0.34_wp,  0.49_wp,  0.71_wp,  0.83_wp,       &
     1137                        0.88_wp,  0.94_wp,  0.95_wp,  1.0_wp /)
     1138          ef(:,17) = (/ 0.08_wp,  0.29_wp,  0.45_wp,  0.68_wp,  0.8_wp,        &
     1139                        0.86_wp,  0.96_wp,  0.94_wp,  1.0_wp /)
     1140          ef(:,18) = (/ 0.04_wp,  0.22_wp,  0.39_wp,  0.62_wp,  0.75_wp,       &
     1141                        0.83_wp,  0.92_wp,  0.96_wp,  1.0_wp /)
     1142          ef(:,19) = (/ 0.02_wp,  0.16_wp,  0.33_wp,  0.55_wp,  0.71_wp,       &
     1143                        0.81_wp,  0.90_wp,  0.94_wp,  1.0_wp /)
    10791144
    10801145       ENDIF
    … …  
    10881153       ENDDO
    10891154
    1090        IF ( rm < 10.0 )  THEN
    1091           e = 0.0
    1092        ELSEIF ( mean_rm < 2.0 )  THEN
    1093           e = 0.001
    1094        ELSEIF ( mean_rm >= 25.0 )  THEN
    1095           IF( j <= 2 )  e = 0.0
    1096           IF( j == 3 )  e = 0.47
    1097           IF( j == 4 )  e = 0.8
    1098           IF( j == 5 )  e = 0.9
    1099           IF( j >=6  )  e = 1.0
    1100        ELSEIF ( rm >= 3000.0 )  THEN
    1101           IF( i == 1 )  e = 0.02
    1102           IF( i == 2 )  e = 0.16
    1103           IF( i == 3 )  e = 0.33
    1104           IF( i == 4 )  e = 0.55
    1105           IF( i == 5 )  e = 0.71
    1106           IF( i == 6 )  e = 0.81
    1107           IF( i == 7 )  e = 0.90
    1108           IF( i >= 8 )  e = 0.94
     1155       IF ( rm < 10.0_wp )  THEN
     1156          e = 0.0_wp
     1157       ELSEIF ( mean_rm < 2.0_wp )  THEN
     1158          e = 0.001_wp
     1159       ELSEIF ( mean_rm >= 25.0_wp )  THEN
     1160          IF( j <= 2 )  e = 0.0_wp
     1161          IF( j == 3 )  e = 0.47_wp
     1162          IF( j == 4 )  e = 0.8_wp
     1163          IF( j == 5 )  e = 0.9_wp
     1164          IF( j >=6  )  e = 1.0_wp
     1165       ELSEIF ( rm >= 3000.0_wp )  THEN
     1166          IF( i == 1 )  e = 0.02_wp
     1167          IF( i == 2 )  e = 0.16_wp
     1168          IF( i == 3 )  e = 0.33_wp
     1169          IF( i == 4 )  e = 0.55_wp
     1170          IF( i == 5 )  e = 0.71_wp
     1171          IF( i == 6 )  e = 0.81_wp
     1172          IF( i == 7 )  e = 0.90_wp
     1173          IF( i >= 8 )  e = 0.94_wp
    11091174       ELSE
    11101175          x  = mean_rm - collected_r(i)
    … …  
    11191184
    11201185          e = ( (gg-aa)*ef(i,j) + (gg-bb)*ef(i+1,j) + (gg-cc)*ef(i,j+1) + &
    1121                 (gg-dd)*ef(i+1,j+1) ) / (3.0*gg)
     1186                (gg-dd)*ef(i+1,j+1) ) / (3.0_wp * gg)
    11221187       ENDIF
    11231188

  • TabularUnified palm/trunk/SOURCE/lpm_data_output_particles.f90

    r1329 r1359  
    2020! Current revisions:
    2121! ------------------
    22 !
     22! netCDF output currently not available
     23! output of particle data in binary format adopted to new particle structure
    2324!
    2425! Former revisions:
    … …  
    5253        ONLY:  cpu_log, log_point_s
    5354
     55    USE indices,                                                               &
     56        ONLY:  nxl, nxr, nyn, nys, nzb, nzt
     57
     58    USE kinds
     59
    5460    USE netcdf_control
    5561
    5662    USE particle_attributes,                                                   &
    57         ONLY:  maximum_number_of_particles, maximum_number_of_tailpoints,      &
    58                maximum_number_of_tails, number_of_particles, number_of_tails,  &
    59                particles, particle_tail_coordinates
     63        ONLY:  grid_particles, maximum_number_of_particles,                    &
     64               maximum_number_of_tailpoints, maximum_number_of_tails,          &
     65               number_of_particles, number_of_tails, particles,                &
     66               particle_tail_coordinates, prt_count
    6067
    6168    IMPLICIT NONE
    6269
     70    INTEGER(iwp) ::  ip !:
     71    INTEGER(iwp) ::  jp !:
     72    INTEGER(iwp) ::  kp !:
    6373
    6474    CALL cpu_log( log_point_s(40), 'lpm_data_output', 'start' )
    … …  
    6979    CALL check_open( 85 )
    7080
    71     WRITE ( 85 )  simulated_time, maximum_number_of_particles, &
    72                   number_of_particles
    73     WRITE ( 85 )  particles
    74     WRITE ( 85 )  maximum_number_of_tailpoints, maximum_number_of_tails, &
    75                   number_of_tails
    76     IF ( maximum_number_of_tails > 0 )  THEN
    77        WRITE ( 85 )  particle_tail_coordinates, prt_time_count
    78     ENDIF
     81    WRITE ( 85 )  simulated_time
     82    WRITE ( 85 )  prt_count
     83         
     84    DO  ip = nxl, nxr
     85       DO  jp = nys, nyn
     86          DO  kp = nzb+1, nzt
     87             number_of_particles = prt_count(kp,jp,ip)
     88             particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
     89             IF ( number_of_particles <= 0 )  CYCLE
     90             WRITE ( 85 )  particles
     91          ENDDO
     92       ENDDO
     93    ENDDO
     94!
     95!-- particle tails currently not available
     96!    WRITE ( 85 )  maximum_number_of_tailpoints, maximum_number_of_tails, &
     97!                  number_of_tails
     98!    IF ( maximum_number_of_tails > 0 )  THEN
     99!       WRITE ( 85 )  particle_tail_coordinates, prt_time_count
     100!    ENDIF
    79101
    80102    CALL close_file( 85 )
    … …  
    82104
    83105#if defined( __netcdf )
    84 !
    85 !-- Output in netCDF format
    86     CALL check_open( 108 )
    87 
    88 !
    89 !-- Update the NetCDF time axis
    90     prt_time_count = prt_time_count + 1
    91 
    92     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_time_prt, &
    93                             (/ simulated_time /),        &
    94                             start = (/ prt_time_count /), count = (/ 1 /) )
    95     CALL handle_netcdf_error( 'lpm_data_output_particles', 1 )
    96 
    97 !
    98 !-- Output the real number of particles used
    99     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_rnop_prt, &
    100                             (/ number_of_particles /),   &
    101                             start = (/ prt_time_count /), count = (/ 1 /) )
    102     CALL handle_netcdf_error( 'lpm_data_output_particles', 2 )
    103 
    104 !
    105 !-- Output all particle attributes
    106     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(1), particles%age,      &
    107                             start = (/ 1, prt_time_count /),               &
    108                             count = (/ maximum_number_of_particles /) )
    109     CALL handle_netcdf_error( 'lpm_data_output_particles', 3 )
    110 
    111     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(2), particles%dvrp_psize,&
    112                             start = (/ 1, prt_time_count /),                &
    113                             count = (/ maximum_number_of_particles /) )
    114     CALL handle_netcdf_error( 'lpm_data_output_particles', 4 )
    115 
    116     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(3), particles%origin_x, &
    117                             start = (/ 1, prt_time_count /),               &
    118                             count = (/ maximum_number_of_particles /) )
    119     CALL handle_netcdf_error( 'lpm_data_output_particles', 5 )
    120 
    121     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(4), particles%origin_y, &
    122                             start = (/ 1, prt_time_count /),               &
    123                             count = (/ maximum_number_of_particles /) )
    124     CALL handle_netcdf_error( 'lpm_data_output_particles', 6 )
    125 
    126     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(5), particles%origin_z, &
    127                             start = (/ 1, prt_time_count /),               &
    128                             count = (/ maximum_number_of_particles /) )
    129     CALL handle_netcdf_error( 'lpm_data_output_particles', 7 )
    130 
    131     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(6), particles%radius,   &
    132                             start = (/ 1, prt_time_count /),               &
    133                             count = (/ maximum_number_of_particles /) )
    134     CALL handle_netcdf_error( 'lpm_data_output_particles', 8 )
    135 
    136     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(7), particles%speed_x,  &
    137                             start = (/ 1, prt_time_count /),               &
    138                             count = (/ maximum_number_of_particles /) )
    139     CALL handle_netcdf_error( 'lpm_data_output_particles', 9 )
    140 
    141     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(8), particles%speed_y,  &
    142                             start = (/ 1, prt_time_count /),               &
    143                             count = (/ maximum_number_of_particles /) )
    144     CALL handle_netcdf_error( 'lpm_data_output_particles', 10 )
    145 
    146     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(9), particles%speed_z,  &
    147                             start = (/ 1, prt_time_count /),               &
    148                             count = (/ maximum_number_of_particles /) )
    149     CALL handle_netcdf_error( 'lpm_data_output_particles', 11 )
    150 
    151     nc_stat = NF90_PUT_VAR( id_set_prt,id_var_prt(10),                     &
    152                             particles%weight_factor,                       &
    153                             start = (/ 1, prt_time_count /),               &
    154                             count = (/ maximum_number_of_particles /) )
    155     CALL handle_netcdf_error( 'lpm_data_output_particles', 12 )
    156 
    157     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(11), particles%x,       &
    158                             start = (/ 1, prt_time_count /),               &
    159                             count = (/ maximum_number_of_particles /) )
    160     CALL handle_netcdf_error( 'lpm_data_output_particles', 13 )
    161 
    162     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(12), particles%y,       &
    163                             start = (/ 1, prt_time_count /),               &
    164                             count = (/ maximum_number_of_particles /) )
    165     CALL handle_netcdf_error( 'lpm_data_output_particles', 14 )
    166 
    167     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(13), particles%z,       &
    168                             start = (/ 1, prt_time_count /),               &
    169                             count = (/ maximum_number_of_particles /) )
    170     CALL handle_netcdf_error( 'lpm_data_output_particles', 15 )
    171 
    172     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(14), particles%class,   &
    173                             start = (/ 1, prt_time_count /),               &
    174                             count = (/ maximum_number_of_particles /) )
    175     CALL handle_netcdf_error( 'lpm_data_output_particles', 16 )
    176 
    177     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(15), particles%group,   &
    178                             start = (/ 1, prt_time_count /),               &
    179                             count = (/ maximum_number_of_particles /) )
    180     CALL handle_netcdf_error( 'lpm_data_output_particles', 17 )
    181 
    182     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(16),                    &
    183                             particles%tailpoints,                          &
    184                             start = (/ 1, prt_time_count /),               &
    185                             count = (/ maximum_number_of_particles /) )
    186     CALL handle_netcdf_error( 'lpm_data_output_particles', 18 )
    187 
    188     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(17), particles%tail_id, &
    189                             start = (/ 1, prt_time_count /),               &
    190                             count = (/ maximum_number_of_particles /) )
    191     CALL handle_netcdf_error( 'lpm_data_output_particles', 19 )
    192 
     106! !
     107! !-- Output in netCDF format
     108!     CALL check_open( 108 )
     109!
     110! !
     111! !-- Update the NetCDF time axis
     112!     prt_time_count = prt_time_count + 1
     113!
     114!     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_time_prt, &
     115!                             (/ simulated_time /),        &
     116!                             start = (/ prt_time_count /), count = (/ 1 /) )
     117!     CALL handle_netcdf_error( 'lpm_data_output_particles', 1 )
     118!
     119! !
     120! !-- Output the real number of particles used
     121!     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_rnop_prt, &
     122!                             (/ number_of_particles /),   &
     123!                             start = (/ prt_time_count /), count = (/ 1 /) )
     124!     CALL handle_netcdf_error( 'lpm_data_output_particles', 2 )
     125!
     126! !
     127! !-- Output all particle attributes
     128!     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(1), particles%age,      &
     129!                             start = (/ 1, prt_time_count /),               &
     130!                             count = (/ maximum_number_of_particles /) )
     131!     CALL handle_netcdf_error( 'lpm_data_output_particles', 3 )
     132!
     133!     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(2), particles%dvrp_psize,&
     134!                             start = (/ 1, prt_time_count /),                &
     135!                             count = (/ maximum_number_of_particles /) )
     136!     CALL handle_netcdf_error( 'lpm_data_output_particles', 4 )
     137!
     138!     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(3), particles%origin_x, &
     139!                             start = (/ 1, prt_time_count /),               &
     140!                             count = (/ maximum_number_of_particles /) )
     141!     CALL handle_netcdf_error( 'lpm_data_output_particles', 5 )
     142!
     143!     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(4), particles%origin_y, &
     144!                             start = (/ 1, prt_time_count /),               &
     145!                             count = (/ maximum_number_of_particles /) )
     146!     CALL handle_netcdf_error( 'lpm_data_output_particles', 6 )
     147!
     148!     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(5), particles%origin_z, &
     149!                             start = (/ 1, prt_time_count /),               &
     150!                             count = (/ maximum_number_of_particles /) )
     151!     CALL handle_netcdf_error( 'lpm_data_output_particles', 7 )
     152!
     153!     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(6), particles%radius,   &
     154!                             start = (/ 1, prt_time_count /),               &
     155!                             count = (/ maximum_number_of_particles /) )
     156!     CALL handle_netcdf_error( 'lpm_data_output_particles', 8 )
     157!
     158!     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(7), particles%speed_x,  &
     159!                             start = (/ 1, prt_time_count /),               &
     160!                             count = (/ maximum_number_of_particles /) )
     161!     CALL handle_netcdf_error( 'lpm_data_output_particles', 9 )
     162!
     163!     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(8), particles%speed_y,  &
     164!                             start = (/ 1, prt_time_count /),               &
     165!                             count = (/ maximum_number_of_particles /) )
     166!     CALL handle_netcdf_error( 'lpm_data_output_particles', 10 )
     167!
     168!     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(9), particles%speed_z,  &
     169!                             start = (/ 1, prt_time_count /),               &
     170!                             count = (/ maximum_number_of_particles /) )
     171!     CALL handle_netcdf_error( 'lpm_data_output_particles', 11 )
     172!
     173!     nc_stat = NF90_PUT_VAR( id_set_prt,id_var_prt(10),                     &
     174!                             particles%weight_factor,                       &
     175!                             start = (/ 1, prt_time_count /),               &
     176!                             count = (/ maximum_number_of_particles /) )
     177!     CALL handle_netcdf_error( 'lpm_data_output_particles', 12 )
     178!
     179!     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(11), particles%x,       &
     180!                             start = (/ 1, prt_time_count /),               &
     181!                             count = (/ maximum_number_of_particles /) )
     182!     CALL handle_netcdf_error( 'lpm_data_output_particles', 13 )
     183!
     184!     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(12), particles%y,       &
     185!                             start = (/ 1, prt_time_count /),               &
     186!                             count = (/ maximum_number_of_particles /) )
     187!     CALL handle_netcdf_error( 'lpm_data_output_particles', 14 )
     188!
     189!     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(13), particles%z,       &
     190!                             start = (/ 1, prt_time_count /),               &
     191!                             count = (/ maximum_number_of_particles /) )
     192!     CALL handle_netcdf_error( 'lpm_data_output_particles', 15 )
     193!
     194!     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(14), particles%class,   &
     195!                             start = (/ 1, prt_time_count /),               &
     196!                             count = (/ maximum_number_of_particles /) )
     197!     CALL handle_netcdf_error( 'lpm_data_output_particles', 16 )
     198!
     199!     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(15), particles%group,   &
     200!                             start = (/ 1, prt_time_count /),               &
     201!                             count = (/ maximum_number_of_particles /) )
     202!     CALL handle_netcdf_error( 'lpm_data_output_particles', 17 )
     203!
     204!     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(16),                    &
     205!                             particles%tailpoints,                          &
     206!                             start = (/ 1, prt_time_count /),               &
     207!                             count = (/ maximum_number_of_particles /) )
     208!     CALL handle_netcdf_error( 'lpm_data_output_particles', 18 )
     209!
     210!     nc_stat = NF90_PUT_VAR( id_set_prt, id_var_prt(17), particles%tail_id, &
     211!                             start = (/ 1, prt_time_count /),               &
     212!                             count = (/ maximum_number_of_particles /) )
     213!     CALL handle_netcdf_error( 'lpm_data_output_particles', 19 )
     214!
    193215#endif
    194216

  • TabularUnified palm/trunk/SOURCE/lpm_droplet_collision.f90

    r1323 r1359  
    1  SUBROUTINE lpm_droplet_collision
     1 SUBROUTINE lpm_droplet_collision (i,j,k)
    22
    33!--------------------------------------------------------------------------------!
    … …  
    2020! Current revisions:
    2121! ------------------
    22 !
     22! New particle structure integrated.
     23! Kind definition added to all floating point numbers.
    2324!
    2425! Former revisions:
    … …  
    7576!------------------------------------------------------------------------------!
    7677
     78
    7779    USE arrays_3d,                                                             &
    7880        ONLY:  diss, ql, ql_v, ql_vp, u, v, w, zu, zw
    … …  
    103105    USE particle_attributes,                                                   &
    104106        ONLY:  deleted_particles, dissipation_classes, hall_kernel,            &
    105                palm_kernel, particles, particle_mask, particle_type,           &
    106                prt_count, prt_start_index, use_kernel_tables, wang_kernel
     107               palm_kernel, particles, particle_type,                          &
     108               prt_count, use_kernel_tables, wang_kernel
     109
     110    USE pegrid
    107111
    108112    IMPLICIT NONE
    … …  
    124128    INTEGER(iwp) ::  rclass_s !:
    125129
     130    INTEGER(iwp), DIMENSION(prt_count(k,j,i)) ::  rclass_v !:
     131
     132    LOGICAL, SAVE ::  first_flag = .TRUE. !:
     133
     134    TYPE(particle_type) :: tmp_particle   !:
     135
    126136    REAL(wp) ::  aa       !:
     137    REAL(wp) ::  auxn     !: temporary variables
     138    REAL(wp) ::  auxs     !: temporary variables
    127139    REAL(wp) ::  bb       !:
    128140    REAL(wp) ::  cc       !:
    … …  
    158170    REAL(wp), DIMENSION(:), ALLOCATABLE ::  weight !:
    159171
    160 
    161     TYPE(particle_type) ::  tmp_particle           !:
    162 
    163 
     172    REAL, DIMENSION(prt_count(k,j,i))    :: ck
     173    REAL, DIMENSION(prt_count(k,j,i))    :: r3v
     174    REAL, DIMENSION(prt_count(k,j,i))    :: sum1v
     175    REAL, DIMENSION(prt_count(k,j,i))    :: sum2v
    164176
    165177    CALL cpu_log( log_point_s(43), 'lpm_droplet_coll', 'start' )
    166178
    167     DO  i = nxl, nxr
    168        DO  j = nys, nyn
    169           DO  k = nzb+1, nzt
    170 !
    171 !--          Collision requires at least two particles in the box
    172              IF ( prt_count(k,j,i) > 1 )  THEN
    173 !
    174 !--             First, sort particles within the gridbox by their size,
    175 !--             using Shell's method (see Numerical Recipes)
    176 !--             NOTE: In case of using particle tails, the re-sorting of
    177 !--             ----  tails would have to be included here!
    178                 psi = prt_start_index(k,j,i) - 1
    179                 inc = 1
    180                 DO WHILE ( inc <= prt_count(k,j,i) )
    181                    inc = 3 * inc + 1
     179!
     180!-- Collision requires at least two particles in the box
     181    IF ( prt_count(k,j,i) > 1 )  THEN
     182!
     183!--    First, sort particles within the gridbox by their size,
     184!--    using Shell's method (see Numerical Recipes)
     185!--    NOTE: In case of using particle tails, the re-sorting of
     186!--    ----  tails would have to be included here!
     187       IF ( .NOT. ( ( hall_kernel  .OR.  wang_kernel )  .AND.  &
     188       use_kernel_tables ) )  THEN
     189          psi = 0
     190          inc = 1
     191          DO WHILE ( inc <= prt_count(k,j,i) )
     192             inc = 3 * inc + 1
     193          ENDDO
     194
     195          DO WHILE ( inc > 1 )
     196             inc = inc / 3
     197             DO  is = inc+1, prt_count(k,j,i)
     198                tmp_particle = particles(psi+is)
     199                js = is
     200                DO WHILE ( particles(psi+js-inc)%radius >             &
     201                tmp_particle%radius )
     202                   particles(psi+js) = particles(psi+js-inc)
     203                   js = js - inc
     204                   IF ( js <= inc )  EXIT
    182205                ENDDO
    183 
    184                 DO WHILE ( inc > 1 )
    185                    inc = inc / 3
    186                    DO  is = inc+1, prt_count(k,j,i)
    187                       tmp_particle = particles(psi+is)
    188                       js = is
    189                       DO WHILE ( particles(psi+js-inc)%radius >             &
    190                                  tmp_particle%radius )
    191                          particles(psi+js) = particles(psi+js-inc)
    192                          js = js - inc
    193                          IF ( js <= inc )  EXIT
    194                       ENDDO
    195                       particles(psi+js) = tmp_particle
    196                    ENDDO
     206                particles(psi+js) = tmp_particle
     207             ENDDO
     208          ENDDO
     209       ENDIF
     210
     211       psi = 1
     212       pse = prt_count(k,j,i)
     213
     214!
     215!--    Now apply the different kernels
     216       IF ( ( hall_kernel  .OR.  wang_kernel )  .AND.  &
     217            use_kernel_tables )  THEN
     218!
     219!--       Fast method with pre-calculated efficiencies for
     220!--       discrete radius- and dissipation-classes.
     221!--
     222!--       Determine dissipation class index of this gridbox
     223          IF ( wang_kernel )  THEN
     224             eclass = INT( diss(k,j,i) * 1.0E4_wp / 1000.0_wp * &
     225                           dissipation_classes ) + 1
     226             epsilon = diss(k,j,i)
     227          ELSE
     228             epsilon = 0.0_wp
     229          ENDIF
     230          IF ( hall_kernel  .OR.  epsilon * 1.0E4_wp < 0.001_wp )  THEN
     231             eclass = 0   ! Hall kernel is used
     232          ELSE
     233             eclass = MIN( dissipation_classes, eclass )
     234          ENDIF
     235
     236!
     237!--       Droplet collision are calculated using collision-coalescence
     238!--       formulation proposed by Wang (see PALM documentation)
     239!--       Since new radii after collision are defined by radii of all
     240!--       droplets before collision, temporary fields for new radii and
     241!--       weighting factors are needed
     242          ALLOCATE(rad(1:prt_count(k,j,i)), weight(1:prt_count(k,j,i)))
     243
     244          rad    = 0.0_wp
     245          weight = 0.0_wp
     246
     247          sum1v(1:prt_count(k,j,i)) = 0.0_wp
     248          sum2v(1:prt_count(k,j,i)) = 0.0_wp
     249
     250          DO  n = 1, prt_count(k,j,i)
     251
     252             rclass_l = particles(n)%class
     253!
     254!--          Mass added due to collisions with smaller droplets
     255             DO  is = n+1, prt_count(k,j,i)
     256                rclass_s = particles(is)%class
     257                auxs = ckernel(rclass_l,rclass_s,eclass) * particles(is)%weight_factor
     258                auxn = ckernel(rclass_s,rclass_l,eclass) * particles(n)%weight_factor
     259                IF ( particles(is)%radius <  particles(n)%radius )  THEN
     260                   sum1v(n) =  sum1v(n)  + particles(is)%radius**3 * auxs
     261                   sum2v(is) = sum2v(is) + auxn
     262                ELSE
     263                   sum2v(n)  = sum2v(n)  + auxs
     264                   sum1v(is) = sum1v(is) + particles(n)%radius**3 * auxn
     265                ENDIF
     266             ENDDO
     267          ENDDO
     268          rclass_v = particles(1:prt_count(k,j,i))%class
     269          DO  n = 1, prt_count(k,j,i)
     270            ck(n)       = ckernel(rclass_v(n),rclass_v(n),eclass)
     271          ENDDO
     272          r3v      = particles(1:prt_count(k,j,i))%radius**3
     273          DO  n = 1, prt_count(k,j,i)
     274             sum3 = 0.0_wp
     275             ddV = ddx * ddy / dz
     276!
     277!--          Change of the current weighting factor
     278             sum3 = 1 - dt_3d * ddV *                                 &
     279                        ck(n) *                                       &
     280                        ( particles(n)%weight_factor - 1 ) * 0.5_wp - &
     281                    dt_3d * ddV * sum2v(n)
     282             weight(n) = particles(n)%weight_factor * sum3
     283!
     284!--          Change of the current droplet radius
     285             rad(n) = ( (r3v(n) + dt_3d * ddV * (sum1v(n) - sum2v(n) * r3v(n)) )/&
     286                              sum3 )**0.33333333333333_wp
     287
     288             ql_vp(k,j,i) = ql_vp(k,j,i) + weight(n) &
     289                                         * rad(n)**3
     290
     291          ENDDO
     292          IF ( ANY(weight < 0.0_wp) )  THEN
     293                WRITE( message_string, * ) 'negative weighting'
     294                CALL message( 'lpm_droplet_collision', 'PA0028',      &
     295                               2, 2, -1, 6, 1 )
     296          ENDIF
     297
     298          particles(psi:pse)%radius = rad(1:prt_count(k,j,i))
     299          particles(psi:pse)%weight_factor = weight(1:prt_count(k,j,i))
     300
     301          DEALLOCATE(rad, weight)
     302
     303       ELSEIF ( ( hall_kernel  .OR.  wang_kernel )  .AND.  &
     304                .NOT. use_kernel_tables )  THEN
     305!
     306!--       Collision efficiencies are calculated for every new
     307!--       grid box. First, allocate memory for kernel table.
     308!--       Third dimension is 1, because table is re-calculated for
     309!--       every new dissipation value.
     310          ALLOCATE( ckernel(1:prt_count(k,j,i),1:prt_count(k,j,i),1:1) )
     311!
     312!--       Now calculate collision efficiencies for this box
     313          CALL recalculate_kernel( i, j, k )
     314
     315!
     316!--       Droplet collision are calculated using collision-coalescence
     317!--       formulation proposed by Wang (see PALM documentation)
     318!--       Since new radii after collision are defined by radii of all
     319!--       droplets before collision, temporary fields for new radii and
     320!--       weighting factors are needed
     321          ALLOCATE(rad(1:prt_count(k,j,i)), weight(1:prt_count(k,j,i)))
     322
     323          rad = 0.0_wp
     324          weight = 0.0_wp
     325
     326          DO  n = psi, pse, 1
     327
     328             sum1 = 0.0_wp
     329             sum2 = 0.0_wp
     330             sum3 = 0.0_wp
     331!
     332!--          Mass added due to collisions with smaller droplets
     333             DO  is = psi, n-1
     334                sum1 = sum1 + ( particles(is)%radius**3 *            &
     335                                ckernel(n,is,1) *  &
     336                                particles(is)%weight_factor )
     337             ENDDO
     338!
     339!--          Rate of collisions with larger droplets
     340             DO  is = n+1, pse
     341                sum2 = sum2 + ( ckernel(n,is,1) *  &
     342                                particles(is)%weight_factor )
     343             ENDDO
     344
     345             r3 = particles(n)%radius**3
     346             ddV = ddx * ddy / dz
     347             is = 1
     348!
     349!--                   Change of the current weighting factor
     350             sum3 = 1 - dt_3d * ddV *                                 &
     351                        ckernel(n,n,1) *           &
     352                        ( particles(n)%weight_factor - 1 ) * 0.5_wp - &
     353                    dt_3d * ddV * sum2
     354             weight(n-is+1) = particles(n)%weight_factor * sum3
     355!
     356!--                   Change of the current droplet radius
     357             rad(n-is+1) = ( (r3 + dt_3d * ddV * (sum1 - sum2 * r3) )/&
     358                              sum3 )**0.33333333333333_wp
     359
     360             IF ( weight(n-is+1) < 0.0_wp )  THEN
     361                WRITE( message_string, * ) 'negative weighting',      &
     362                                           'factor: ', weight(n-is+1)
     363                CALL message( 'lpm_droplet_collision', 'PA0037',      &
     364                               2, 2, -1, 6, 1 )
     365             ENDIF
     366
     367             ql_vp(k,j,i) = ql_vp(k,j,i) + weight(n-is+1) &
     368                                         * rad(n-is+1)**3
     369
     370          ENDDO
     371
     372          particles(psi:pse)%radius = rad(1:prt_count(k,j,i))
     373          particles(psi:pse)%weight_factor = weight(1:prt_count(k,j,i))
     374
     375          DEALLOCATE( rad, weight, ckernel )
     376
     377       ELSEIF ( palm_kernel )  THEN
     378!
     379!--       PALM collision kernel
     380!
     381!--       Calculate the mean radius of all those particles which
     382!--       are of smaller size than the current particle and
     383!--       use this radius for calculating the collision efficiency
     384          DO  n = psi+prt_count(k,j,i)-1, psi+1, -1
     385
     386             sl_r3 = 0.0_wp
     387             sl_r4 = 0.0_wp
     388
     389             DO is = n-1, psi, -1
     390                IF ( particles(is)%radius < particles(n)%radius )  &
     391                THEN
     392                   sl_r3 = sl_r3 + particles(is)%weight_factor     &
     393                                   * particles(is)%radius**3
     394                   sl_r4 = sl_r4 + particles(is)%weight_factor     &
     395                                   * particles(is)%radius**4
     396                ENDIF
     397             ENDDO
     398
     399             IF ( ( sl_r3 ) > 0.0_wp )  THEN
     400                mean_r = ( sl_r4 ) / ( sl_r3 )
     401
     402                CALL collision_efficiency_rogers( mean_r,             &
     403                                           particles(n)%radius,       &
     404                                           effective_coll_efficiency )
     405
     406             ELSE
     407                effective_coll_efficiency = 0.0_wp
     408             ENDIF
     409
     410             IF ( effective_coll_efficiency > 1.0_wp  .OR.            &
     411                  effective_coll_efficiency < 0.0_wp )                &
     412             THEN
     413                WRITE( message_string, * )  'collision_efficien' , &
     414                          'cy out of range:' ,effective_coll_efficiency
     415                CALL message( 'lpm_droplet_collision', 'PA0145', 2, &
     416                              2, -1, 6, 1 )
     417             ENDIF
     418
     419!
     420!--          Interpolation of liquid water content
     421             ii = particles(n)%x * ddx
     422             jj = particles(n)%y * ddy
     423             kk = ( particles(n)%z + 0.5_wp * dz ) / dz
     424
     425             x  = particles(n)%x - ii * dx
     426             y  = particles(n)%y - jj * dy
     427             aa = x**2          + y**2
     428             bb = ( dx - x )**2 + y**2
     429             cc = x**2          + ( dy - y )**2
     430             dd = ( dx - x )**2 + ( dy - y )**2
     431             gg = aa + bb + cc + dd
     432
     433             ql_int_l = ( (gg-aa) * ql(kk,jj,ii)   + (gg-bb) *     &
     434                                                  ql(kk,jj,ii+1)   &
     435                        + (gg-cc) * ql(kk,jj+1,ii) + ( gg-dd ) *   &
     436                                                  ql(kk,jj+1,ii+1) &
     437                        ) / ( 3.0_wp * gg )
     438
     439             ql_int_u = ( (gg-aa) * ql(kk+1,jj,ii)   + (gg-bb) *   &
     440                                                ql(kk+1,jj,ii+1)   &
     441                        + (gg-cc) * ql(kk+1,jj+1,ii) + (gg-dd) *   &
     442                                                ql(kk+1,jj+1,ii+1) &
     443                        ) / ( 3.0_wp * gg )
     444
     445             ql_int = ql_int_l + ( particles(n)%z - zu(kk) ) / dz *&
     446                                 ( ql_int_u - ql_int_l )
     447
     448!
     449!--          Interpolate u velocity-component
     450             ii = ( particles(n)%x + 0.5_wp * dx ) * ddx
     451             jj =   particles(n)%y * ddy
     452             kk = ( particles(n)%z + 0.5_wp * dz ) / dz ! only if equidistant
     453
     454             IF ( ( particles(n)%z - zu(kk) ) > ( 0.5_wp * dz ) ) kk = kk+1
     455
     456             x  = particles(n)%x + ( 0.5_wp - ii ) * dx
     457             y  = particles(n)%y - jj * dy
     458             aa = x**2          + y**2
     459             bb = ( dx - x )**2 + y**2
     460             cc = x**2          + ( dy - y )**2
     461             dd = ( dx - x )**2 + ( dy - y )**2
     462             gg = aa + bb + cc + dd
     463
     464             u_int_l = ( (gg-aa) * u(kk,jj,ii)   + (gg-bb) *       &
     465                                                  u(kk,jj,ii+1)    &
     466                       + (gg-cc) * u(kk,jj+1,ii) + (gg-dd) *       &
     467                                                  u(kk,jj+1,ii+1)  &
     468                       ) / ( 3.0_wp * gg ) - u_gtrans
     469             IF ( kk+1 == nzt+1 )  THEN
     470                u_int = u_int_l
     471             ELSE
     472                u_int_u = ( (gg-aa) * u(kk+1,jj,ii)   + (gg-bb) *  &
     473                                                 u(kk+1,jj,ii+1)   &
     474                          + (gg-cc) * u(kk+1,jj+1,ii) + (gg-dd) *  &
     475                                                 u(kk+1,jj+1,ii+1) &
     476                          ) / ( 3.0_wp * gg ) - u_gtrans
     477                u_int = u_int_l + ( particles(n)%z - zu(kk) ) / dz &
     478                                  * ( u_int_u - u_int_l )
     479             ENDIF
     480
     481!
     482!--          Same procedure for interpolation of the v velocity-component
     483!--          (adopt index k from u velocity-component)
     484             ii =   particles(n)%x * ddx
     485             jj = ( particles(n)%y + 0.5_wp * dy ) * ddy
     486
     487             x  = particles(n)%x - ii * dx
     488             y  = particles(n)%y + ( 0.5_wp - jj ) * dy
     489             aa = x**2          + y**2
     490             bb = ( dx - x )**2 + y**2
     491             cc = x**2          + ( dy - y )**2
     492             dd = ( dx - x )**2 + ( dy - y )**2
     493             gg = aa + bb + cc + dd
     494
     495             v_int_l = ( ( gg-aa ) * v(kk,jj,ii)   + ( gg-bb ) *   &
     496                                                   v(kk,jj,ii+1)   &
     497                       + ( gg-cc ) * v(kk,jj+1,ii) + ( gg-dd ) *   &
     498                                                   v(kk,jj+1,ii+1) &
     499                       ) / ( 3.0_wp * gg ) - v_gtrans
     500             IF ( kk+1 == nzt+1 )  THEN
     501                v_int = v_int_l
     502             ELSE
     503                v_int_u = ( (gg-aa) * v(kk+1,jj,ii)   + (gg-bb) *  &
     504                                                   v(kk+1,jj,ii+1) &
     505                          + (gg-cc) * v(kk+1,jj+1,ii) + (gg-dd) *  &
     506                                                 v(kk+1,jj+1,ii+1) &
     507                          ) / ( 3.0_wp * gg ) - v_gtrans
     508                v_int = v_int_l + ( particles(n)%z - zu(kk) ) / dz &
     509                                  * ( v_int_u - v_int_l )
     510             ENDIF
     511
     512!
     513!--          Same procedure for interpolation of the w velocity-component
     514!--          (adopt index i from v velocity-component)
     515             jj = particles(n)%y * ddy
     516             kk = particles(n)%z / dz
     517
     518             x  = particles(n)%x - ii * dx
     519             y  = particles(n)%y - jj * dy
     520             aa = x**2          + y**2
     521             bb = ( dx - x )**2 + y**2
     522             cc = x**2          + ( dy - y )**2
     523             dd = ( dx - x )**2 + ( dy - y )**2
     524             gg = aa + bb + cc + dd
     525
     526             w_int_l = ( ( gg-aa ) * w(kk,jj,ii)   + ( gg-bb ) *   &
     527                                                     w(kk,jj,ii+1) &
     528                       + ( gg-cc ) * w(kk,jj+1,ii) + ( gg-dd ) *   &
     529                                                   w(kk,jj+1,ii+1) &
     530                       ) / ( 3.0_wp * gg )
     531             IF ( kk+1 == nzt+1 )  THEN
     532                w_int = w_int_l
     533             ELSE
     534                w_int_u = ( (gg-aa) * w(kk+1,jj,ii)   + (gg-bb) *  &
     535                                                   w(kk+1,jj,ii+1) &
     536                          + (gg-cc) * w(kk+1,jj+1,ii) + (gg-dd) *  &
     537                                                 w(kk+1,jj+1,ii+1) &
     538                          ) / ( 3.0_wp * gg )
     539                w_int = w_int_l + ( particles(n)%z - zw(kk) ) / dz &
     540                                  * ( w_int_u - w_int_l )
     541             ENDIF
     542
     543!
     544!--          Change in radius due to collision
     545             delta_r = effective_coll_efficiency / 3.0_wp          &
     546                       * pi * sl_r3 * ddx * ddy / dz               &
     547                       * SQRT( ( u_int - particles(n)%speed_x )**2 &
     548                             + ( v_int - particles(n)%speed_y )**2 &
     549                             + ( w_int - particles(n)%speed_z )**2 &
     550                             ) * dt_3d
     551!
     552!--          Change in volume due to collision
     553             delta_v = particles(n)%weight_factor                  &
     554                       * ( ( particles(n)%radius + delta_r )**3    &
     555                           - particles(n)%radius**3 )
     556
     557!
     558!--          Check if collected particles provide enough LWC for
     559!--          volume change of collector particle
     560             IF ( delta_v >= sl_r3  .AND.  sl_r3 > 0.0_wp )  THEN
     561
     562                delta_r = ( ( sl_r3/particles(n)%weight_factor )               &
     563                            + particles(n)%radius**3 )**( 1.0_wp / 3.0_wp )    &
     564                            - particles(n)%radius
     565
     566                DO  is = n-1, psi, -1
     567                   IF ( particles(is)%radius < particles(n)%radius )  THEN
     568                      particles(is)%weight_factor = 0.0_wp
     569                      particles(is)%particle_mask = .FALSE.
     570                      deleted_particles = deleted_particles + 1
     571                   ENDIF
    197572                ENDDO
    198573
    199                 psi = prt_start_index(k,j,i)
    200                 pse = psi + prt_count(k,j,i)-1
    201 
    202 !
    203 !--             Now apply the different kernels
    204                 IF ( ( hall_kernel .OR. wang_kernel )  .AND.  &
    205                      use_kernel_tables )  THEN
    206 !
    207 !--                Fast method with pre-calculated efficiencies for
    208 !--                discrete radius- and dissipation-classes.
    209 !
    210 !--                Determine dissipation class index of this gridbox
    211                    IF ( wang_kernel )  THEN
    212                       eclass = INT( diss(k,j,i) * 1.0E4_wp / 1000.0_wp * &
    213                                     dissipation_classes ) + 1
    214                       epsilon = diss(k,j,i)
    215                    ELSE
    216                       epsilon = 0.0
     574             ELSE IF ( delta_v < sl_r3  .AND.  sl_r3 > 0.0_wp )  THEN
     575
     576                DO  is = n-1, psi, -1
     577                   IF ( particles(is)%radius < particles(n)%radius &
     578                        .AND.  sl_r3 > 0.0_wp )  THEN
     579                      particles(is)%weight_factor =                &
     580                                   ( ( particles(is)%weight_factor &
     581                                   * ( particles(is)%radius**3 ) ) &
     582                                   - ( delta_v                     &
     583                                   * particles(is)%weight_factor   &
     584                                   * ( particles(is)%radius**3 )   &
     585                                   / sl_r3 ) )                     &
     586                                   / ( particles(is)%radius**3 )
     587
     588                      IF ( particles(is)%weight_factor < 0.0_wp )  THEN
     589                         WRITE( message_string, * ) 'negative ',   &
     590                                         'weighting factor: ',     &
     591                                         particles(is)%weight_factor
     592                         CALL message( 'lpm_droplet_collision', &
     593                                       'PA0039',                &
     594                                       2, 2, -1, 6, 1 )
     595                      ENDIF
    217596                   ENDIF
    218                    IF ( hall_kernel .OR. epsilon * 1.0E4_wp < 0.001 )  THEN
    219                       eclass = 0   ! Hall kernel is used
    220                    ELSE
    221                       eclass = MIN( dissipation_classes, eclass )
    222                    ENDIF
    223 
    224  !
    225 !--                Droplet collision are calculated using collision-coalescence
    226 !--                formulation proposed by Wang (see PALM documentation)
    227 !--                Since new radii after collision are defined by radii of all
    228 !--                droplets before collision, temporary fields for new radii and
    229 !--                weighting factors are needed
    230                    ALLOCATE(rad(1:prt_count(k,j,i)), weight(1:prt_count(k,j,i)))
    231 
    232                    rad = 0.0
    233                    weight = 0.0
    234 
    235                    DO  n = psi, pse, 1
    236 
    237                       sum1 = 0.0
    238                       sum2 = 0.0
    239                       sum3 = 0.0
    240 
    241                       rclass_l = particles(n)%class
    242 !
    243 !--                   Mass added due to collisions with smaller droplets
    244                       DO  is = psi, n-1
    245 
    246                          rclass_s = particles(is)%class
    247                          sum1 = sum1 + ( particles(is)%radius**3 *            &
    248                                          ckernel(rclass_l,rclass_s,eclass) *  &
    249                                          particles(is)%weight_factor )
    250 
    251                       ENDDO
    252 !
    253 !--                   Rate of collisions with larger droplets
    254                       DO  is = n+1, pse
    255 
    256                          rclass_s = particles(is)%class
    257                          sum2 = sum2 + ( ckernel(rclass_l,rclass_s,eclass) *  &
    258                                          particles(is)%weight_factor )
    259 
    260                       ENDDO
    261 
    262                       r3 = particles(n)%radius**3
    263                       ddV = ddx * ddy / dz
    264                       is = prt_start_index(k,j,i)
    265 !
    266 !--                   Change of the current weighting factor
    267                       sum3 = 1 - dt_3d * ddV *                                 &
    268                                  ckernel(rclass_l,rclass_l,eclass) *           &
    269                                  ( particles(n)%weight_factor - 1 ) * 0.5 -    &
    270                              dt_3d * ddV * sum2
    271                       weight(n-is+1) = particles(n)%weight_factor * sum3
    272 !
    273 !--                   Change of the current droplet radius
    274                       rad(n-is+1) = ( (r3 + dt_3d * ddV * (sum1 - sum2 * r3) )/&
    275                                        sum3 )**0.33333333333333_wp
    276 
    277                       IF ( weight(n-is+1) < 0.0 )  THEN
    278                          WRITE( message_string, * ) 'negative weighting',      &
    279                                                     'factor: ', weight(n-is+1)
    280                          CALL message( 'lpm_droplet_collision', 'PA0028',      &
    281                                         2, 2, -1, 6, 1 )
    282                       ENDIF
    283 
    284                       ql_vp(k,j,i) = ql_vp(k,j,i) + weight(n-is+1) &
    285                                                   * rad(n-is+1)**3
    286 
    287                    ENDDO
    288 
    289                    particles(psi:pse)%radius = rad(1:prt_count(k,j,i))
    290                    particles(psi:pse)%weight_factor = weight(1:prt_count(k,j,i))
    291 
    292                    DEALLOCATE(rad, weight)
    293 
    294                 ELSEIF ( ( hall_kernel .OR. wang_kernel )  .AND.  &
    295                          .NOT. use_kernel_tables )  THEN
    296 !
    297 !--                Collision efficiencies are calculated for every new
    298 !--                grid box. First, allocate memory for kernel table.
    299 !--                Third dimension is 1, because table is re-calculated for
    300 !--                every new dissipation value.
    301                    ALLOCATE( ckernel(prt_start_index(k,j,i):                 &
    302                              prt_start_index(k,j,i)+prt_count(k,j,i)-1,      &
    303                              prt_start_index(k,j,i):                         &
    304                              prt_start_index(k,j,i)+prt_count(k,j,i)-1,1:1) )
    305 !
    306 !--                Now calculate collision efficiencies for this box
    307                    CALL recalculate_kernel( i, j, k )
    308 
    309 !
    310 !--                Droplet collision are calculated using collision-coalescence
    311 !--                formulation proposed by Wang (see PALM documentation)
    312 !--                Since new radii after collision are defined by radii of all
    313 !--                droplets before collision, temporary fields for new radii and
    314 !--                weighting factors are needed
    315                    ALLOCATE(rad(1:prt_count(k,j,i)), weight(1:prt_count(k,j,i)))
    316 
    317                    rad = 0.0
    318                    weight = 0.0
    319 
    320                    DO  n = psi, pse, 1
    321 
    322                       sum1 = 0.0
    323                       sum2 = 0.0
    324                       sum3 = 0.0
    325 !
    326 !--                   Mass added due to collisions with smaller droplets
    327                       DO  is = psi, n-1
    328                          sum1 = sum1 + ( particles(is)%radius**3 *            &
    329                                          ckernel(n,is,1) *  &
    330                                          particles(is)%weight_factor )
    331                       ENDDO
    332 !
    333 !--                   Rate of collisions with larger droplets
    334                       DO  is = n+1, pse
    335                          sum2 = sum2 + ( ckernel(n,is,1) *  &
    336                                          particles(is)%weight_factor )
    337                       ENDDO
    338 
    339                       r3 = particles(n)%radius**3
    340                       ddV = ddx * ddy / dz
    341                       is = prt_start_index(k,j,i)
    342 !
    343 !--                   Change of the current weighting factor
    344                       sum3 = 1 - dt_3d * ddV *                                 &
    345                                  ckernel(n,n,1) *           &
    346                                  ( particles(n)%weight_factor - 1 ) * 0.5 -    &
    347                              dt_3d * ddV * sum2
    348                       weight(n-is+1) = particles(n)%weight_factor * sum3
    349 !
    350 !--                   Change of the current droplet radius
    351                       rad(n-is+1) = ( (r3 + dt_3d * ddV * (sum1 - sum2 * r3) )/&
    352                                        sum3 )**0.33333333333333_wp
    353 
    354                       IF ( weight(n-is+1) < 0.0 )  THEN
    355                          WRITE( message_string, * ) 'negative weighting',      &
    356                                                     'factor: ', weight(n-is+1)
    357                          CALL message( 'lpm_droplet_collision', 'PA0037',      &
    358                                         2, 2, -1, 6, 1 )
    359                       ENDIF
    360 
    361                       ql_vp(k,j,i) = ql_vp(k,j,i) + weight(n-is+1) &
    362                                                   * rad(n-is+1)**3
    363 
    364                    ENDDO
    365 
    366                    particles(psi:pse)%radius = rad(1:prt_count(k,j,i))
    367                    particles(psi:pse)%weight_factor = weight(1:prt_count(k,j,i))
    368 
    369                    DEALLOCATE( rad, weight, ckernel )
    370 
    371                 ELSEIF ( palm_kernel )  THEN
    372 !
    373 !--                PALM collision kernel
    374 !
    375 !--                Calculate the mean radius of all those particles which
    376 !--                are of smaller size than the current particle and
    377 !--                use this radius for calculating the collision efficiency
    378                    DO  n = psi+prt_count(k,j,i)-1, psi+1, -1
    379 
    380                       sl_r3 = 0.0
    381                       sl_r4 = 0.0
    382 
    383                       DO is = n-1, psi, -1
    384                          IF ( particles(is)%radius < particles(n)%radius )  &
    385                          THEN
    386                             sl_r3 = sl_r3 + particles(is)%weight_factor     &
    387                                             * particles(is)%radius**3
    388                             sl_r4 = sl_r4 + particles(is)%weight_factor     &
    389                                             * particles(is)%radius**4
    390                          ENDIF
    391                       ENDDO
    392 
    393                       IF ( ( sl_r3 ) > 0.0 )  THEN
    394                          mean_r = ( sl_r4 ) / ( sl_r3 )
    395 
    396                          CALL collision_efficiency_rogers( mean_r,             &
    397                                                     particles(n)%radius,       &
    398                                                     effective_coll_efficiency )
    399 
    400                       ELSE
    401                          effective_coll_efficiency = 0.0
    402                       ENDIF
    403 
    404                       IF ( effective_coll_efficiency > 1.0  .OR.            &
    405                            effective_coll_efficiency < 0.0 )                &
    406                       THEN
    407                          WRITE( message_string, * )  'collision_efficien' , &
    408                                    'cy out of range:' ,effective_coll_efficiency
    409                          CALL message( 'lpm_droplet_collision', 'PA0145', 2, &
    410                                        2, -1, 6, 1 )
    411                       ENDIF
    412 
    413 !
    414 !--                   Interpolation of ...
    415                       ii = particles(n)%x * ddx
    416                       jj = particles(n)%y * ddy
    417                       kk = ( particles(n)%z + 0.5 * dz ) / dz
    418 
    419                       x  = particles(n)%x - ii * dx
    420                       y  = particles(n)%y - jj * dy
    421                       aa = x**2          + y**2
    422                       bb = ( dx - x )**2 + y**2
    423                       cc = x**2          + ( dy - y )**2
    424                       dd = ( dx - x )**2 + ( dy - y )**2
    425                       gg = aa + bb + cc + dd
    426 
    427                       ql_int_l = ( (gg-aa) * ql(kk,jj,ii)   + (gg-bb) *     &
    428                                                            ql(kk,jj,ii+1)   &
    429                                  + (gg-cc) * ql(kk,jj+1,ii) + ( gg-dd ) *   &
    430                                                            ql(kk,jj+1,ii+1) &
    431                                  ) / ( 3.0 * gg )
    432 
    433                       ql_int_u = ( (gg-aa) * ql(kk+1,jj,ii)   + (gg-bb) *   &
    434                                                          ql(kk+1,jj,ii+1)   &
    435                                  + (gg-cc) * ql(kk+1,jj+1,ii) + (gg-dd) *   &
    436                                                          ql(kk+1,jj+1,ii+1) &
    437                                  ) / ( 3.0 * gg )
    438 
    439                       ql_int = ql_int_l + ( particles(n)%z - zu(kk) ) / dz *&
    440                                           ( ql_int_u - ql_int_l )
    441 
    442 !
    443 !--                   Interpolate u velocity-component
    444                       ii = ( particles(n)%x + 0.5 * dx ) * ddx
    445                       jj =   particles(n)%y * ddy
    446                       kk = ( particles(n)%z + 0.5 * dz ) / dz ! only if eqist
    447 
    448                       IF ( ( particles(n)%z - zu(kk) ) > (0.5*dz) ) kk = kk+1
    449 
    450                       x  = particles(n)%x + ( 0.5 - ii ) * dx
    451                       y  = particles(n)%y - jj * dy
    452                       aa = x**2          + y**2
    453                       bb = ( dx - x )**2 + y**2
    454                       cc = x**2          + ( dy - y )**2
    455                       dd = ( dx - x )**2 + ( dy - y )**2
    456                       gg = aa + bb + cc + dd
    457 
    458                       u_int_l = ( (gg-aa) * u(kk,jj,ii)   + (gg-bb) *       &
    459                                                            u(kk,jj,ii+1)    &
    460                                 + (gg-cc) * u(kk,jj+1,ii) + (gg-dd) *       &
    461                                                            u(kk,jj+1,ii+1)  &
    462                                 ) / ( 3.0 * gg ) - u_gtrans
    463                       IF ( kk+1 == nzt+1 )  THEN
    464                          u_int = u_int_l
    465                       ELSE
    466                          u_int_u = ( (gg-aa) * u(kk+1,jj,ii)   + (gg-bb) *  &
    467                                                           u(kk+1,jj,ii+1)   &
    468                                    + (gg-cc) * u(kk+1,jj+1,ii) + (gg-dd) *  &
    469                                                           u(kk+1,jj+1,ii+1) &
    470                                    ) / ( 3.0 * gg ) - u_gtrans
    471                          u_int = u_int_l + ( particles(n)%z - zu(kk) ) / dz &
    472                                            * ( u_int_u - u_int_l )
    473                       ENDIF
    474 
    475 !
    476 !--                   Same procedure for interpolation of the v velocity-com-
    477 !--                   ponent (adopt index k from u velocity-component)
    478                       ii =   particles(n)%x * ddx
    479                       jj = ( particles(n)%y + 0.5 * dy ) * ddy
    480 
    481                       x  = particles(n)%x - ii * dx
    482                       y  = particles(n)%y + ( 0.5 - jj ) * dy
    483                       aa = x**2          + y**2
    484                       bb = ( dx - x )**2 + y**2
    485                       cc = x**2          + ( dy - y )**2
    486                       dd = ( dx - x )**2 + ( dy - y )**2
    487                       gg = aa + bb + cc + dd
    488 
    489                       v_int_l = ( ( gg-aa ) * v(kk,jj,ii)   + ( gg-bb ) *   &
    490                                                             v(kk,jj,ii+1)   &
    491                                 + ( gg-cc ) * v(kk,jj+1,ii) + ( gg-dd ) *   &
    492                                                             v(kk,jj+1,ii+1) &
    493                                 ) / ( 3.0 * gg ) - v_gtrans
    494                       IF ( kk+1 == nzt+1 )  THEN
    495                          v_int = v_int_l
    496                       ELSE
    497                          v_int_u = ( (gg-aa) * v(kk+1,jj,ii)   + (gg-bb) *  &
    498                                                             v(kk+1,jj,ii+1) &
    499                                    + (gg-cc) * v(kk+1,jj+1,ii) + (gg-dd) *  &
    500                                                           v(kk+1,jj+1,ii+1) &
    501                                    ) / ( 3.0 * gg ) - v_gtrans
    502                          v_int = v_int_l + ( particles(n)%z - zu(kk) ) / dz &
    503                                            * ( v_int_u - v_int_l )
    504                       ENDIF
    505 
    506 !
    507 !--                   Same procedure for interpolation of the w velocity-com-
    508 !--                   ponent (adopt index i from v velocity-component)
    509                       jj = particles(n)%y * ddy
    510                       kk = particles(n)%z / dz
    511 
    512                       x  = particles(n)%x - ii * dx
    513                       y  = particles(n)%y - jj * dy
    514                       aa = x**2          + y**2
    515                       bb = ( dx - x )**2 + y**2
    516                       cc = x**2          + ( dy - y )**2
    517                       dd = ( dx - x )**2 + ( dy - y )**2
    518                       gg = aa + bb + cc + dd
    519 
    520                       w_int_l = ( ( gg-aa ) * w(kk,jj,ii)   + ( gg-bb ) *   &
    521                                                               w(kk,jj,ii+1) &
    522                                 + ( gg-cc ) * w(kk,jj+1,ii) + ( gg-dd ) *   &
    523                                                             w(kk,jj+1,ii+1) &
    524                                 ) / ( 3.0 * gg )
    525                       IF ( kk+1 == nzt+1 )  THEN
    526                          w_int = w_int_l
    527                       ELSE
    528                          w_int_u = ( (gg-aa) * w(kk+1,jj,ii)   + (gg-bb) *  &
    529                                                             w(kk+1,jj,ii+1) &
    530                                    + (gg-cc) * w(kk+1,jj+1,ii) + (gg-dd) *  &
    531                                                           w(kk+1,jj+1,ii+1) &
    532                                    ) / ( 3.0 * gg )
    533                          w_int = w_int_l + ( particles(n)%z - zw(kk) ) / dz &
    534                                            * ( w_int_u - w_int_l )
    535                       ENDIF
    536 
    537 !
    538 !--                   Change in radius due to collision
    539                       delta_r = effective_coll_efficiency / 3.0_wp          &
    540                                 * pi * sl_r3 * ddx * ddy / dz               &
    541                                 * SQRT( ( u_int - particles(n)%speed_x )**2 &
    542                                       + ( v_int - particles(n)%speed_y )**2 &
    543                                       + ( w_int - particles(n)%speed_z )**2 &
    544                                       ) * dt_3d
    545 !
    546 !--                   Change in volume due to collision
    547                       delta_v = particles(n)%weight_factor                  &
    548                                 * ( ( particles(n)%radius + delta_r )**3    &
    549                                     - particles(n)%radius**3 )
    550 
    551 !
    552 !--                   Check if collected particles provide enough LWC for
    553 !--                   volume change of collector particle
    554                       IF ( delta_v >= sl_r3  .AND.  sl_r3 > 0.0 )  THEN
    555 
    556                          delta_r = ( ( sl_r3/particles(n)%weight_factor )           &
    557                                      + particles(n)%radius**3 )**( 1.0_wp/3.0_wp )  &
    558                                      - particles(n)%radius
    559 
    560                          DO  is = n-1, psi, -1
    561                             IF ( particles(is)%radius < &
    562                                  particles(n)%radius )  THEN
    563                                particles(is)%weight_factor = 0.0
    564                                particle_mask(is) = .FALSE.
    565                                deleted_particles = deleted_particles + 1
    566                             ENDIF
    567                          ENDDO
    568 
    569                       ELSE IF ( delta_v < sl_r3  .AND.  sl_r3 > 0.0 )  THEN
    570 
    571                          DO  is = n-1, psi, -1
    572                             IF ( particles(is)%radius < particles(n)%radius &
    573                                  .AND.  sl_r3 > 0.0 )  THEN
    574                                particles(is)%weight_factor =                &
    575                                             ( ( particles(is)%weight_factor &
    576                                             * ( particles(is)%radius**3 ) ) &
    577                                             - ( delta_v                     &
    578                                             * particles(is)%weight_factor   &
    579                                             * ( particles(is)%radius**3 )   &
    580                                             / sl_r3 ) )                     &
    581                                             / ( particles(is)%radius**3 )
    582 
    583                                IF ( particles(is)%weight_factor < 0.0 )  THEN
    584                                   WRITE( message_string, * ) 'negative ',   &
    585                                                   'weighting factor: ',     &
    586                                                   particles(is)%weight_factor
    587                                   CALL message( 'lpm_droplet_collision', &
    588                                                 'PA0039',                &
    589                                                 2, 2, -1, 6, 1 )
    590                                ENDIF
    591                             ENDIF
    592                          ENDDO
    593 
    594                       ENDIF
    595 
    596                       particles(n)%radius = particles(n)%radius + delta_r
    597                       ql_vp(k,j,i) = ql_vp(k,j,i) +               &
    598                                      particles(n)%weight_factor * &
    599                                      ( particles(n)%radius**3 )
    600                    ENDDO
    601 
    602                 ql_vp(k,j,i) = ql_vp(k,j,i) + particles(psi)%weight_factor  &
    603                                               * particles(psi)%radius**3
    604 
    605                 ENDIF  ! collision kernel
    606 
    607              ELSE IF ( prt_count(k,j,i) == 1 )  THEN
    608 
    609                 psi = prt_start_index(k,j,i)
    610 
    611 !
    612 !--             Calculate change of weighting factor due to self collision
    613                 IF ( ( hall_kernel .OR. wang_kernel )  .AND.  &
    614                      use_kernel_tables )  THEN
    615 
    616                    IF ( wang_kernel )  THEN
    617                       eclass = INT( diss(k,j,i) * 1.0E4_wp / 1000.0_wp * &
    618                                     dissipation_classes ) + 1
    619                       epsilon = diss(k,j,i)
    620                    ELSE
    621                       epsilon = 0.0
    622                    ENDIF
    623                    IF ( hall_kernel .OR. epsilon * 1.0E4_wp < 0.001 )  THEN
    624                       eclass = 0   ! Hall kernel is used
    625                    ELSE
    626                       eclass = MIN( dissipation_classes, eclass )
    627                    ENDIF
    628 
    629                    ddV = ddx * ddy / dz
    630                    rclass_l = particles(psi)%class
    631                    sum3 = 1 - dt_3d * ddV *                                 &
    632                               ( ckernel(rclass_l,rclass_l,eclass) *         &
    633                                 ( particles(psi)%weight_factor-1 ) * 0.5 )
    634 
    635                    particles(psi)%radius = ( particles(psi)%radius**3 / &
    636                                              sum3 )**0.33333333333333_wp
    637                    particles(psi)%weight_factor = particles(psi)%weight_factor &
    638                                                   * sum3
    639 
    640                 ELSE IF ( ( hall_kernel .OR. wang_kernel )  .AND.  &
    641                            .NOT. use_kernel_tables )  THEN
    642 !
    643 !--                Collision efficiencies are calculated for every new
    644 !--                grid box. First, allocate memory for kernel table.
    645 !--                Third dimension is 1, because table is re-calculated for
    646 !--                every new dissipation value.
    647                    ALLOCATE( ckernel(psi:psi, psi:psi, 1:1) )
    648 !
    649 !--                Now calculate collision efficiencies for this box
    650                    CALL recalculate_kernel( i, j, k )
    651 
    652                    ddV = ddx * ddy / dz
    653                    sum3 = 1 - dt_3d * ddV * ( ckernel(psi,psi,1) *  &
    654                                 ( particles(psi)%weight_factor - 1 ) * 0.5 )
    655 
    656                    particles(psi)%radius = ( particles(psi)%radius**3 / &
    657                                              sum3 )**0.33333333333333_wp
    658                    particles(psi)%weight_factor = particles(psi)%weight_factor &
    659                                                   * sum3
    660 
    661                    DEALLOCATE( ckernel )
    662                 ENDIF
    663 
    664                ql_vp(k,j,i) =  particles(psi)%weight_factor *              &
    665                                 particles(psi)%radius**3
     597                ENDDO
     598
    666599             ENDIF
    667600
    668 !
    669 !--          Check if condensation of LWC was conserved during collision
    670 !--          process
    671              IF ( ql_v(k,j,i) /= 0.0 )  THEN
    672                 IF ( ql_vp(k,j,i) / ql_v(k,j,i) >= 1.0001  .OR.             &
    673                      ql_vp(k,j,i) / ql_v(k,j,i) <= 0.9999 )  THEN
    674                    WRITE( message_string, * ) 'LWC is not conserved during',&
    675                                               ' collision! ',               &
    676                                               'LWC after condensation: ',   &
    677                                               ql_v(k,j,i),                  &
    678                                               ' LWC after collision: ',     &
    679                                               ql_vp(k,j,i)
    680                    CALL message( 'lpm_droplet_collision', 'PA0040',         &
    681                                  2, 2, -1, 6, 1 )
    682                 ENDIF
    683              ENDIF
    684 
     601             particles(n)%radius = particles(n)%radius + delta_r
     602             ql_vp(k,j,i) = ql_vp(k,j,i) +               &
     603                            particles(n)%weight_factor * &
     604                            ( particles(n)%radius**3 )
    685605          ENDDO
    686        ENDDO
    687     ENDDO
     606
     607          ql_vp(k,j,i) = ql_vp(k,j,i) + particles(psi)%weight_factor  &
     608                                        * particles(psi)%radius**3
     609
     610       ENDIF  ! collision kernel
     611
     612    ELSE IF ( prt_count(k,j,i) == 1 )  THEN
     613
     614       psi = 1
     615
     616!
     617!--    Calculate change of weighting factor due to self collision
     618       IF ( ( hall_kernel  .OR.  wang_kernel )  .AND.  &
     619            use_kernel_tables )  THEN
     620
     621          IF ( wang_kernel )  THEN
     622             eclass = INT( diss(k,j,i) * 1.0E4_wp / 1000.0_wp * &
     623                           dissipation_classes ) + 1
     624             epsilon = diss(k,j,i)
     625          ELSE
     626             epsilon = 0.0_wp
     627          ENDIF
     628          IF ( hall_kernel  .OR.  epsilon * 1.0E4_wp < 0.001_wp )  THEN
     629             eclass = 0   ! Hall kernel is used
     630          ELSE
     631             eclass = MIN( dissipation_classes, eclass )
     632          ENDIF
     633
     634          ddV = ddx * ddy / dz
     635          rclass_l = particles(psi)%class
     636          sum3 = 1 - dt_3d * ddV *                                 &
     637                     ( ckernel(rclass_l,rclass_l,eclass) *         &
     638                       ( particles(psi)%weight_factor-1 ) * 0.5_wp )
     639
     640          particles(psi)%radius = ( particles(psi)%radius**3 / &
     641                                    sum3 )**0.33333333333333_wp
     642          particles(psi)%weight_factor = particles(psi)%weight_factor &
     643                                         * sum3
     644
     645       ELSE IF ( ( hall_kernel  .OR.  wang_kernel )  .AND.  &
     646                  .NOT. use_kernel_tables )  THEN
     647!
     648!--       Collision efficiencies are calculated for every new
     649!--       grid box. First, allocate memory for kernel table.
     650!--       Third dimension is 1, because table is re-calculated for
     651!--       every new dissipation value.
     652          ALLOCATE( ckernel(psi:psi, psi:psi, 1:1) )
     653!
     654!--       Now calculate collision efficiencies for this box
     655          CALL recalculate_kernel( i, j, k )
     656
     657          ddV = ddx * ddy / dz
     658          sum3 = 1 - dt_3d * ddV * ( ckernel(psi,psi,1) *  &
     659                       ( particles(psi)%weight_factor - 1 ) * 0.5_wp )
     660
     661          particles(psi)%radius = ( particles(psi)%radius**3 / &
     662                                    sum3 )**0.33333333333333_wp
     663          particles(psi)%weight_factor = particles(psi)%weight_factor &
     664                                         * sum3
     665
     666          DEALLOCATE( ckernel )
     667       ENDIF
     668
     669      ql_vp(k,j,i) =  particles(psi)%weight_factor *              &
     670                       particles(psi)%radius**3
     671    ENDIF
     672
     673!
     674!-- Check if condensation of LWC was conserved during collision process
     675    IF ( ql_v(k,j,i) /= 0.0_wp )  THEN
     676       IF ( ql_vp(k,j,i) / ql_v(k,j,i) >= 1.0001_wp  .OR.             &
     677            ql_vp(k,j,i) / ql_v(k,j,i) <= 0.9999_wp )  THEN
     678          WRITE( message_string, * ) 'LWC is not conserved during',&
     679                                     ' collision! ',               &
     680                                     'LWC after condensation: ',   &
     681                                     ql_v(k,j,i),                  &
     682                                     ' LWC after collision: ',     &
     683                                     ql_vp(k,j,i)
     684          CALL message( 'lpm_droplet_collision', 'PA0040',         &
     685                        2, 2, -1, 6, 1 )
     686       ENDIF
     687    ENDIF
    688688
    689689    CALL cpu_log( log_point_s(43), 'lpm_droplet_coll', 'stop' )
    690690
    691 
    692691 END SUBROUTINE lpm_droplet_collision

  • TabularUnified palm/trunk/SOURCE/lpm_droplet_condensation.f90

    r1347 r1359  
    1  SUBROUTINE lpm_droplet_condensation
     1 SUBROUTINE lpm_droplet_condensation (ip,jp,kp)
    22
    33!--------------------------------------------------------------------------------!
    … …  
    2020! Current revisions:
    2121! ------------------
    22 !
    23 !
     22! New particle structure integrated.
     23! Kind definition added to all floating point numbers.
     24!
    2425! Former revisions:
    2526! -----------------
    … …  
    100101
    101102    USE particle_attributes,                                                   &
    102         ONLY:  hall_kernel, number_of_particles, offset_ocean_nzt,            &
    103                offset_ocean_nzt_m1, particles, radius_classes,                 &
    104                use_kernel_tables, wang_kernel
     103        ONLY:  block_offset, grid_particles, hall_kernel, number_of_particles, &
     104               offset_ocean_nzt, offset_ocean_nzt_m1, particles,               &
     105               radius_classes, use_kernel_tables, wang_kernel
    105106
    106107
    … …  
    108109
    109110    INTEGER(iwp) :: i                          !:
     111    INTEGER(iwp) :: ip                         !:
    110112    INTEGER(iwp) :: internal_timestep_count    !:
    111113    INTEGER(iwp) :: j                          !:
     114    INTEGER(iwp) :: jp                         !:
    112115    INTEGER(iwp) :: jtry                       !:
    113116    INTEGER(iwp) :: k                          !:
     117    INTEGER(iwp) :: kp                         !:
    114118    INTEGER(iwp) :: n                          !:
     119    INTEGER(iwp) :: nb                         !:
    115120    INTEGER(iwp) :: ros_count                  !:
    116121 
    117     INTEGER(iwp), PARAMETER ::  maxtry = 40    !:
    118 
    119     LOGICAL ::  repeat                         !:
     122    INTEGER(iwp), PARAMETER ::  maxtry = 40      !:
     123
     124    INTEGER(iwp), DIMENSION(0:7) ::  end_index   !:
     125    INTEGER(iwp), DIMENSION(0:7) ::  start_index !:
     126
     127    LOGICAL ::  repeat                           !:
     128
     129    LOGICAL, DIMENSION(number_of_particles) ::  flag_1 !:
    120130
    121131    REAL(wp) ::  aa                            !:
    … …  
    140150    REAL(wp) ::  g3                            !:
    141151    REAL(wp) ::  g4                            !:
    142     REAL(wp) ::  e_a                           !:
    143     REAL(wp) ::  e_s                           !:
    144152    REAL(wp) ::  gg                            !:
    145     REAL(wp) ::  new_r                         !:
    146     REAL(wp) ::  p_int                         !:
    147153    REAL(wp) ::  pt_int                        !:
    148154    REAL(wp) ::  pt_int_l                      !:
    … …  
    154160    REAL(wp) ::  r_ros_ini                     !:
    155161    REAL(wp) ::  sigma                         !:
    156     REAL(wp) ::  t_int                         !:
    157162    REAL(wp) ::  x                             !:
    158163    REAL(wp) ::  y                             !:
    … …  
    160165 
    161166!-- Parameters for Rosenbrock method
    162     REAL(wp), PARAMETER ::  a21 = 2.0             !:
    163     REAL(wp), PARAMETER ::  a31 = 48.0/25.0_wp    !:
    164     REAL(wp), PARAMETER ::  a32 = 6.0/25.0_wp     !:
    165     REAL(wp), PARAMETER ::  b1 = 19.0/9.0_wp      !:
    166     REAL(wp), PARAMETER ::  b2 = 0.5              !:
    167     REAL(wp), PARAMETER ::  b3 = 25.0/108.0_wp    !:
    168     REAL(wp), PARAMETER ::  b4 = 125.0/108.0_wp   !:
    169     REAL(wp), PARAMETER ::  c21 = -8.0            !:
    170     REAL(wp), PARAMETER ::  c31 = 372.0/25.0_wp   !:
    171     REAL(wp), PARAMETER ::  c32 = 12.0/5.0_wp     !:
    172     REAL(wp), PARAMETER ::  c41 = -112.0/125.0_wp !:
    173     REAL(wp), PARAMETER ::  c42 = -54.0/125.0_wp  !:
    174     REAL(wp), PARAMETER ::  c43 = -2.0/5.0_wp     !:
    175     REAL(wp), PARAMETER ::  errcon = 0.1296       !:
    176     REAL(wp), PARAMETER ::  e1 = 17.0/54.0_wp     !:
    177     REAL(wp), PARAMETER ::  e2 = 7.0/36.0_wp      !:
    178     REAL(wp), PARAMETER ::  e3 = 0.0              !:
    179     REAL(wp), PARAMETER ::  e4 = 125.0/108.0_wp   !:
    180     REAL(wp), PARAMETER ::  gam = 0.5             !:
    181     REAL(wp), PARAMETER ::  grow = 1.5            !:
    182     REAL(wp), PARAMETER ::  pgrow = -0.25         !:
    183     REAL(wp), PARAMETER ::  pshrnk = -1.0/3.0_wp  !:
    184     REAL(wp), PARAMETER ::  shrnk = 0.5           !:
    185 
     167    REAL(wp), PARAMETER ::  a21 = 2.0_wp               !:
     168    REAL(wp), PARAMETER ::  a31 = 48.0_wp / 25.0_wp    !:
     169    REAL(wp), PARAMETER ::  a32 = 6.0_wp / 25.0_wp     !:
     170    REAL(wp), PARAMETER ::  b1 = 19.0_wp / 9.0_wp      !:
     171    REAL(wp), PARAMETER ::  b2 = 0.5_wp                !:
     172    REAL(wp), PARAMETER ::  b3 = 25.0_wp / 108.0_wp    !:
     173    REAL(wp), PARAMETER ::  b4 = 125.0_wp / 108.0_wp   !:
     174    REAL(wp), PARAMETER ::  c21 = -8.0_wp              !:
     175    REAL(wp), PARAMETER ::  c31 = 372.0_wp / 25.0_wp   !:
     176    REAL(wp), PARAMETER ::  c32 = 12.0_wp / 5.0_wp     !:
     177    REAL(wp), PARAMETER ::  c41 = -112.0_wp / 125.0_wp !:
     178    REAL(wp), PARAMETER ::  c42 = -54.0_wp / 125.0_wp  !:
     179    REAL(wp), PARAMETER ::  c43 = -2.0_wp / 5.0_wp     !:
     180    REAL(wp), PARAMETER ::  errcon = 0.1296_wp         !:
     181    REAL(wp), PARAMETER ::  e1 = 17.0_wp / 54.0_wp     !:
     182    REAL(wp), PARAMETER ::  e2 = 7.0_wp / 36.0_wp      !:
     183    REAL(wp), PARAMETER ::  e3 = 0.0_wp                !:
     184    REAL(wp), PARAMETER ::  e4 = 125.0_wp / 108.0_wp   !:
     185    REAL(wp), PARAMETER ::  gam = 0.5_wp               !:
     186    REAL(wp), PARAMETER ::  grow = 1.5_wp              !:
     187    REAL(wp), PARAMETER ::  pgrow = -0.25_wp           !:
     188    REAL(wp), PARAMETER ::  pshrnk = -1.0_wp /3.0_wp   !:
     189    REAL(wp), PARAMETER ::  shrnk = 0.5_wp             !:
     190
     191    REAL(wp), DIMENSION(number_of_particles) ::  afactor_v              !:
     192    REAL(wp), DIMENSION(number_of_particles) ::  diff_coeff_v           !:
     193    REAL(wp), DIMENSION(number_of_particles) ::  e_s                    !:
     194    REAL(wp), DIMENSION(number_of_particles) ::  e_a                    !:
     195    REAL(wp), DIMENSION(number_of_particles) ::  new_r                  !:
     196    REAL(wp), DIMENSION(number_of_particles) ::  p_int                  !:
     197    REAL(wp), DIMENSION(number_of_particles) ::  thermal_conductivity_v !:
     198    REAL(wp), DIMENSION(number_of_particles) ::  t_int                  !:
     199    REAL(wp), DIMENSION(number_of_particles) ::  xv                     !:
     200    REAL(wp), DIMENSION(number_of_particles) ::  yv                     !:
     201    REAL(wp), DIMENSION(number_of_particles) ::  zv                     !:
    186202
    187203
    188204    CALL cpu_log( log_point_s(42), 'lpm_droplet_condens', 'start' )
    189205
     206    start_index = grid_particles(kp,jp,ip)%start_index
     207    end_index   = grid_particles(kp,jp,ip)%end_index
     208
     209    xv = particles(1:number_of_particles)%x
     210    yv = particles(1:number_of_particles)%y
     211    zv = particles(1:number_of_particles)%z
     212
     213    DO  nb = 0,7
     214
     215       i = ip + block_offset(nb)%i_off
     216       j = jp + block_offset(nb)%j_off
     217       k = kp + block_offset(nb)%k_off
     218
     219       DO  n = start_index(nb), end_index(nb)
     220!
     221!--    Interpolate temperature and humidity.
     222          x  = xv(n) - i * dx
     223          y  = yv(n) - j * dy
     224          aa = x**2          + y**2
     225          bb = ( dx - x )**2 + y**2
     226          cc = x**2          + ( dy - y )**2
     227          dd = ( dx - x )**2 + ( dy - y )**2
     228          gg = aa + bb + cc + dd
     229
     230          pt_int_l = ( ( gg - aa ) * pt(k,j,i)   + ( gg - bb ) * pt(k,j,i+1)   &
     231                     + ( gg - cc ) * pt(k,j+1,i) + ( gg - dd ) * pt(k,j+1,i+1) &
     232                     ) / ( 3.0_wp * gg )
     233
     234          pt_int_u = ( ( gg-aa ) * pt(k+1,j,i)   + ( gg-bb ) * pt(k+1,j,i+1)   &
     235                     + ( gg-cc ) * pt(k+1,j+1,i) + ( gg-dd ) * pt(k+1,j+1,i+1) &
     236                     ) / ( 3.0_wp * gg )
     237
     238          pt_int = pt_int_l + ( particles(n)%z - zu(k) ) / dz *                &
     239                              ( pt_int_u - pt_int_l )
     240
     241          q_int_l = ( ( gg - aa ) * q(k,j,i)     + ( gg - bb ) * q(k,j,i+1)    &
     242                    + ( gg - cc ) * q(k,j+1,i)   + ( gg - dd ) * q(k,j+1,i+1)  &
     243                    ) / ( 3.0_wp * gg )
     244
     245          q_int_u = ( ( gg-aa ) * q(k+1,j,i)   + ( gg-bb ) * q(k+1,j,i+1)      &
     246                    + ( gg-cc ) * q(k+1,j+1,i) + ( gg-dd ) * q(k+1,j+1,i+1)    &
     247                    ) / ( 3.0_wp * gg )
     248
     249          q_int = q_int_l + ( zv(n) - zu(k) ) / dz *                           &
     250                            ( q_int_u - q_int_l )
     251
     252!
     253!--       Calculate real temperature and saturation vapor pressure
     254          p_int(n) = hyp(k) + ( particles(n)%z - zu(k) ) / dz *                &
     255                              ( hyp(k+1)-hyp(k) )
     256          t_int(n) = pt_int * ( p_int(n) / 100000.0_wp )**0.286_wp
     257
     258          e_s(n) = 611.0_wp * EXP( l_d_rv * ( 3.6609E-3_wp - 1.0_wp /          &
     259                                   t_int(n) ) )
     260
     261!
     262!--       Current vapor pressure
     263          e_a(n) = q_int * p_int(n) / ( 0.378_wp * q_int + 0.622_wp )
     264
     265       ENDDO
     266    ENDDO
     267
     268    new_r = 0.0_wp
     269    flag_1 = .false.
     270
    190271    DO  n = 1, number_of_particles
    191272!
    192 !--    Interpolate temperature and humidity.
    193 !--    First determine left, south, and bottom index of the arrays.
    194        i = particles(n)%x * ddx
    195        j = particles(n)%y * ddy
    196        k = ( particles(n)%z + 0.5 * dz * atmos_ocean_sign ) / dz  &
    197            + offset_ocean_nzt                     ! only exact if equidistant
    198 
    199        x  = particles(n)%x - i * dx
    200        y  = particles(n)%y - j * dy
    201        aa = x**2          + y**2
    202        bb = ( dx - x )**2 + y**2
    203        cc = x**2          + ( dy - y )**2
    204        dd = ( dx - x )**2 + ( dy - y )**2
    205        gg = aa + bb + cc + dd
    206 
    207        pt_int_l = ( ( gg - aa ) * pt(k,j,i)   + ( gg - bb ) * pt(k,j,i+1)   &
    208                   + ( gg - cc ) * pt(k,j+1,i) + ( gg - dd ) * pt(k,j+1,i+1) &
    209                   ) / ( 3.0 * gg )
    210 
    211        pt_int_u = ( ( gg-aa ) * pt(k+1,j,i)   + ( gg-bb ) * pt(k+1,j,i+1)   &
    212                   + ( gg-cc ) * pt(k+1,j+1,i) + ( gg-dd ) * pt(k+1,j+1,i+1) &
    213                   ) / ( 3.0 * gg )
    214 
    215        pt_int = pt_int_l + ( particles(n)%z - zu(k) ) / dz * &
    216                            ( pt_int_u - pt_int_l )
    217 
    218        q_int_l = ( ( gg - aa ) * q(k,j,i)   + ( gg - bb ) * q(k,j,i+1)   &
    219                  + ( gg - cc ) * q(k,j+1,i) + ( gg - dd ) * q(k,j+1,i+1) &
    220                  ) / ( 3.0 * gg )
    221 
    222        q_int_u = ( ( gg-aa ) * q(k+1,j,i)   + ( gg-bb ) * q(k+1,j,i+1)   &
    223                  + ( gg-cc ) * q(k+1,j+1,i) + ( gg-dd ) * q(k+1,j+1,i+1) &
    224                  ) / ( 3.0 * gg )
    225 
    226        q_int = q_int_l + ( particles(n)%z - zu(k) ) / dz * &
    227                            ( q_int_u - q_int_l )
    228 
    229 !
    230 !--    Calculate real temperature and saturation vapor pressure
    231        p_int = hyp(k) + ( particles(n)%z - zu(k) ) / dz * ( hyp(k+1)-hyp(k) )
    232        t_int = pt_int * ( p_int / 100000.0 )**0.286
    233 
    234        e_s = 611.0 * EXP( l_d_rv * ( 3.6609E-3 - 1.0 / t_int ) )
    235 
    236 !
    237 !--    Current vapor pressure
    238        e_a = q_int * p_int / ( 0.378 * q_int + 0.622 )
    239 
     273!--    Change in radius by condensation/evaporation
     274       IF ( particles(n)%radius >= 4.0E-5_wp  .AND.                            &
     275            e_a(n)/e_s(n) < 1.0_wp )  THEN
     276!
     277!--    Approximation for large radii, where curvature and solution effects
     278!--    can be neglected but ventilation effect has to be included in case of
     279!--    evaporation.
     280!--    First calculate the droplet's Reynolds number
     281          re_p = 2.0_wp * particles(n)%radius * ABS( particles(n)%speed_z ) /  &
     282                                                     molecular_viscosity
     283!
     284!--       Ventilation coefficient (Rogers and Yau, 1989):
     285          IF ( re_p > 2.5_wp )  THEN
     286             afactor_v(n) = 0.78_wp + 0.28_wp * SQRT( re_p )
     287          ELSE
     288             afactor_v(n) = 1.0_wp + 0.09_wp * re_p
     289          ENDIF
     290          flag_1(n) = .TRUE.
     291       ELSEIF ( particles(n)%radius >= 1.0E-6_wp  .OR.                         &
     292                .NOT. curvature_solution_effects )  THEN
     293!
     294!--    Approximation for larger radii in case that curvature and solution
     295!--    effects are neglected and ventilation effects does not play a role
     296          afactor_v(n) = 1.0_wp
     297          flag_1(n) = .TRUE.
     298       ENDIF
     299    ENDDO
     300
     301    DO  n = 1, number_of_particles
    240302!
    241303!--    Thermal conductivity for water (from Rogers and Yau, Table 7.1),
    242304!--    diffusivity for water vapor (after Hall und Pruppacher, 1976)
    243        thermal_conductivity_l = 7.94048E-05 * t_int + 0.00227011
    244        diff_coeff_l           = 0.211E-4 * ( t_int / 273.15 )**1.94 * &
    245                                 ( 101325.0 / p_int)
    246 !
    247 !--    Change in radius by condensation/evaporation
    248        IF ( particles(n)%radius >= 4.0E-5  .AND.  e_a/e_s < 1.0 )  THEN
    249 !
    250 !--       Approximation for large radii, where curvature and solution effects
    251 !--       can be neglected but ventilation effect has to be included in case of
    252 !--       evaporation.
    253 !--       First calculate the droplet's Reynolds number
    254           re_p = 2.0 * particles(n)%radius * ABS( particles(n)%speed_z ) / &
    255                  molecular_viscosity
    256 !
    257 !--       Ventilation coefficient after Rogers and Yau, 1989
    258           IF ( re_p > 2.5 )  THEN
    259              afactor = 0.78 + 0.28 * SQRT( re_p )
    260           ELSE
    261              afactor = 1.0 + 0.09 * re_p
    262           ENDIF
    263 
    264           arg = particles(n)%radius**2 + 2.0 * dt_3d * afactor *              &
    265                            ( e_a / e_s - 1.0 ) /                              &
    266                            ( ( l_d_rv / t_int - 1.0 ) * l_v * rho_l / t_int / &
    267                              thermal_conductivity_l +                         &
    268                              rho_l * r_v * t_int / diff_coeff_l / e_s )
    269 
    270           new_r = SQRT( arg )
    271 
    272        ELSEIF ( particles(n)%radius >= 1.0E-6  .OR.  &
    273                 .NOT. curvature_solution_effects )  THEN
    274 !
    275 !--       Approximation for larger radii in case that curvature and solution
    276 !--       effects are neglected and ventilation effects does not play a role
    277           arg = particles(n)%radius**2 + 2.0 * dt_3d *                        &
    278                            ( e_a / e_s - 1.0 ) /                              &
    279                            ( ( l_d_rv / t_int - 1.0 ) * l_v * rho_l / t_int / &
    280                              thermal_conductivity_l +                         &
    281                              rho_l * r_v * t_int / diff_coeff_l / e_s )
    282           IF ( arg < 1.0E-16 )  THEN
    283              new_r = 1.0E-8
    284           ELSE
    285              new_r = SQRT( arg )
    286           ENDIF
    287        ENDIF
    288 
    289        IF ( curvature_solution_effects  .AND.                              &
    290             ( ( particles(n)%radius < 1.0E-6 ) .OR. ( new_r < 1.0E-6 ) ) ) &
    291        THEN
     305       thermal_conductivity_v(n) = 7.94048E-05_wp * t_int(n) + 0.00227011_wp
     306       diff_coeff_v(n)           = 0.211E-4_wp *                               &
     307                   ( t_int(n) / 273.15_wp )**1.94_wp * ( 101325.0_wp / p_int(n))
     308
     309       IF(flag_1(n)) then
     310          arg = particles(n)%radius**2 + 2.0_wp * dt_3d * afactor_v(n) *       &
     311                  ( e_a(n) / e_s(n) - 1.0_wp ) /                               &
     312                  ( ( l_d_rv / t_int(n) - 1.0_wp ) * l_v * rho_l / t_int(n) /  &
     313                  thermal_conductivity_v(n) +                                  &
     314                  rho_l * r_v * t_int(n) / diff_coeff_v(n) / e_s(n) )
     315
     316          arg = MAX( arg, 1.0E-16_wp )
     317          new_r(n) = SQRT( arg )
     318        ENDIF
     319    ENDDO
     320
     321    DO  n = 1, number_of_particles
     322       IF ( curvature_solution_effects  .AND.                                  &
     323            ( ( particles(n)%radius < 1.0E-6_wp )  .OR.                        &
     324              ( new_r(n) < 1.0E-6_wp ) ) )  THEN
    292325!
    293326!--       Curvature and solutions effects are included in growth equation.
    … …  
    304337!--       the switch "repeat" will be set true and the algorithm will be carried
    305338!--       out again with the internal time step set to its initial (small) value.
    306 !--       Unreasonable results may occur if the external conditions, especially the
    307 !--       supersaturation, has significantly changed compared to the last PALM
    308 !--       timestep.
     339!--       Unreasonable results may occur if the external conditions, especially
     340!--       the supersaturation, has significantly changed compared to the last
     341!--       PALM timestep.
    309342          DO WHILE ( repeat )
    310343
    311344             repeat = .FALSE.
    312345!
    313 !--          Surface tension after (Straka, 2009)
    314              sigma = 0.0761 - 0.000155 * ( t_int - 273.15 )
     346!--          Surface tension (Straka, 2009):
     347             sigma = 0.0761_wp - 0.000155_wp * ( t_int(n) - 273.15_wp )
    315348
    316349             r_ros = particles(n)%radius
    317              dt_ros_sum  = 0.0      ! internal integrated time (s)
     350             dt_ros_sum  = 0.0_wp      ! internal integrated time (s)
    318351             internal_timestep_count = 0
    319352
    320              ddenom  = 1.0 / ( rho_l * r_v * t_int / ( e_s * diff_coeff_l ) +  &
    321                                ( l_v / ( r_v * t_int ) - 1.0 ) *               &
    322                                rho_l * l_v / ( thermal_conductivity_l * t_int )&
    323                              )
    324 
    325              afactor = 2.0 * sigma / ( rho_l * r_v * t_int )
     353             ddenom  = 1.0_wp / ( rho_l * r_v * t_int(n) / ( e_s(n) *          &
     354                                  diff_coeff_v(n) ) + ( l_v /                  &
     355                                  ( r_v * t_int(n) ) - 1.0_wp ) *              &
     356                                  rho_l * l_v / ( thermal_conductivity_v(n) *  &
     357                                  t_int(n) )                                   &
     358                                )
     359
     360             afactor = 2.0_wp * sigma / ( rho_l * r_v * t_int(n) )
    326361
    327362!
    … …  
    333368!--          because larger values may lead to secondary solutions which are
    334369!--          physically unlikely
    335              IF ( dt_ros_next > 1.0E-2  .AND.  e_a/e_s < 1.0 )  THEN
    336                 dt_ros_next = 1.0E-3
     370             IF ( dt_ros_next > 1.0E-2_wp  .AND.  e_a(n)/e_s(n) < 1.0_wp )  THEN
     371                dt_ros_next = 1.0E-3_wp
    337372             ENDIF
    338373!
    … …  
    341376!--          reduced
    342377             IF ( ros_count > 1 )  THEN
    343                 dt_ros_next = dt_ros_next - ( 0.2 * dt_ros_next )
     378                dt_ros_next = dt_ros_next - ( 0.2_wp * dt_ros_next )
    344379             ELSEIF ( ros_count > 5 )  THEN
    345380!
    … …  
    361396!
    362397!--             Derivative at starting value
    363                 drdt = ddenom / r_ros * ( e_a / e_s - 1.0 - afactor / r_ros + &
    364                                           bfactor / r_ros**3 )
     398                drdt = ddenom / r_ros * ( e_a(n) / e_s(n) - 1.0_wp - afactor / &
     399                                          r_ros + bfactor / r_ros**3 )
    365400                drdt_ini       = drdt
    366401                dt_ros_sum_ini = dt_ros_sum
    … …  
    369404!
    370405!--             Calculate radial derivative of dr/dt
    371                 d2rdtdr = ddenom * ( ( 1.0 - e_a/e_s ) / r_ros**2 + &
    372                                      2.0 * afactor / r_ros**3 -     &
    373                                      4.0 * bfactor / r_ros**5 )
     406                d2rdtdr = ddenom * ( ( 1.0_wp - e_a(n)/e_s(n) ) / r_ros**2 +  &
     407                                     2.0_wp * afactor / r_ros**3 -             &
     408                                     4.0_wp * bfactor / r_ros**5 )
    374409!
    375410!--             Adjust stepsize unless required accuracy is reached
    … …  
    378413                   IF ( jtry == maxtry+1 )  THEN
    379414                      message_string = 'maxtry > 40 in Rosenbrock method'
    380                       CALL message( 'lpm_droplet_condensation', 'PA0347', 2, 2, &
    381                                     0, 6, 0 )
     415                      CALL message( 'lpm_droplet_condensation', 'PA0347', 2,   &
     416                                    2, 0, 6, 0 )
    382417                   ENDIF
    383418
    384                    aa    = 1.0 / ( gam * dt_ros ) - d2rdtdr
     419                   aa    = 1.0_wp / ( gam * dt_ros ) - d2rdtdr
    385420                   g1    = drdt_ini / aa
    386421                   r_ros = r_ros_ini + a21 * g1
    387                    drdt  = ddenom / r_ros * ( e_a / e_s - 1.0 - &
    388                                               afactor / r_ros + &
     422                   drdt  = ddenom / r_ros * ( e_a(n) / e_s(n) - 1.0_wp -      &
     423                                              afactor / r_ros +                &
    389424                                              bfactor / r_ros**3 )
    390425
    … …  
    392427                           / aa
    393428                   r_ros = r_ros_ini + a31 * g1 + a32 * g2
    394                    drdt  = ddenom / r_ros * ( e_a / e_s - 1.0 - &
    395                                               afactor / r_ros + &
     429                   drdt  = ddenom / r_ros * ( e_a(n) / e_s(n) - 1.0_wp -      &
     430                                              afactor / r_ros +                &
    396431                                              bfactor / r_ros**3 )
    397432
    … …  
    406441                   IF ( dt_ros_sum == dt_ros_sum_ini )  THEN
    407442                      message_string = 'zero stepsize in Rosenbrock method'
    408                       CALL message( 'lpm_droplet_condensation', 'PA0348', 2, 2, &
    409                                     0, 6, 0 )
     443                      CALL message( 'lpm_droplet_condensation', 'PA0348', 2,   &
     444                                    2, 0, 6, 0 )
    410445                   ENDIF
    411446!
    412447!--                Calculate error
    413                    err_ros = e1*g1 + e2*g2 + e3*g3 + e4*g4
    414                    errmax  = 0.0
     448                   err_ros = e1 * g1 + e2 * g2 + e3 * g3 + e4 * g4
     449                   errmax  = 0.0_wp
    415450                   errmax  = MAX( errmax, ABS( err_ros / r_ros_ini ) ) / eps_ros
    416451!
    417452!--                Leave loop if accuracy is sufficient, otherwise try again
    418453!--                with a reduced stepsize
    419                    IF ( errmax <= 1.0 )  THEN
     454                   IF ( errmax <= 1.0_wp )  THEN
    420455                      EXIT
    421456                   ELSE
    422                       dt_ros = SIGN( MAX( ABS( 0.9 * dt_ros * errmax**pshrnk ), &
    423                                           shrnk * ABS( dt_ros ) ), dt_ros )
     457                      dt_ros = SIGN( MAX( ABS( 0.9_wp * dt_ros *               &
     458                                               errmax**pshrnk ),               &
     459                                               shrnk * ABS( dt_ros ) ), dt_ros )
    424460                   ENDIF
    425461
    … …  
    429465!--             Calculate next internal time step
    430466                IF ( errmax > errcon )  THEN
    431                    dt_ros_next = 0.9 * dt_ros * errmax**pgrow
     467                   dt_ros_next = 0.9_wp * dt_ros * errmax**pgrow
    432468                ELSE
    433469                   dt_ros_next = grow * dt_ros
    … …  
    447483             particles(n)%rvar1 = dt_ros_next
    448484
    449              new_r = r_ros
     485             new_r(n) = r_ros
    450486!
    451487!--          Radius should not fall below 1E-8 because Rosenbrock method may
    452488!--          lead to errors otherwise
    453              new_r = MAX( new_r, 1.0E-8_wp )
     489             new_r(n) = MAX( new_r(n), 1.0E-8_wp )
    454490!
    455491!--          Check if calculated droplet radius change is reasonable since in
    … …  
    457493!--          secondary solutions which are physically unlikely.
    458494!--          Due to the solution effect the droplets may grow for relative
    459 !--          humidities below 100%, but change of radius should not be too large.
    460 !--          In case of unreasonable droplet growth the Rosenbrock method is
    461 !--          recalculated using a smaller initial time step.
     495!--          humidities below 100%, but change of radius should not be too
     496!--          large. In case of unreasonable droplet growth the Rosenbrock
     497!--          method is recalculated using a smaller initial time step.
    462498!--          Limiting values are tested for droplets down to 1.0E-7
    463              IF ( new_r - particles(n)%radius >= 3.0E-7  .AND.  &
    464                   e_a/e_s < 0.97 )  THEN
     499             IF ( new_r(n) - particles(n)%radius >= 3.0E-7_wp  .AND.  &
     500                  e_a(n)/e_s(n) < 0.97_wp )  THEN
    465501                ros_count = ros_count + 1
    466502                repeat = .TRUE.
    … …  
    471507       ENDIF
    472508
    473        delta_r = new_r - particles(n)%radius
     509       delta_r = new_r(n) - particles(n)%radius
    474510
    475511!
    … …  
    477513!--    volume (this is needed later in lpm_calc_liquid_water_content for
    478514!--    calculating the release of latent heat)
    479        i = ( particles(n)%x + 0.5 * dx ) * ddx
    480        j = ( particles(n)%y + 0.5 * dy ) * ddy
    481        k = particles(n)%z / dz + 1 + offset_ocean_nzt_m1
     515       i = ip
     516       j = jp
     517       k = kp
    482518           ! only exact if equidistant
    483519
    484        ql_c(k,j,i) = ql_c(k,j,i) + particles(n)%weight_factor *            &
    485                                    rho_l * 1.33333333 * pi *               &
    486                                    ( new_r**3 - particles(n)%radius**3 ) / &
     520       ql_c(k,j,i) = ql_c(k,j,i) + particles(n)%weight_factor *                &
     521                                   rho_l * 1.33333333_wp * pi *                &
     522                                   ( new_r(n)**3 - particles(n)%radius**3 ) / &
    487523                                   ( rho_surface * dx * dy * dz )
    488        IF ( ql_c(k,j,i) > 100.0 )  THEN
     524       IF ( ql_c(k,j,i) > 100.0_wp )  THEN
    489525          WRITE( message_string, * ) 'k=',k,' j=',j,' i=',i,      &
    490526                       ' ql_c=',ql_c(k,j,i), ' &part(',n,')%wf=', &
    … …  
    495531!
    496532!--    Change the droplet radius
    497        IF ( ( new_r - particles(n)%radius ) < 0.0  .AND.  new_r < 0.0 ) &
    498        THEN
    499           WRITE( message_string, * ) '#1 k=',k,' j=',j,' i=',i,   &
    500                        ' e_s=',e_s, ' e_a=',e_a,' t_int=',t_int,  &
    501                        ' &delta_r=',delta_r,                      &
     533       IF ( ( new_r(n) - particles(n)%radius ) < 0.0_wp  .AND.                &
     534            new_r(n) < 0.0_wp )  THEN
     535          WRITE( message_string, * ) '#1 k=',k,' j=',j,' i=',i,                &
     536                       ' e_s=',e_s(n), ' e_a=',e_a(n),' t_int=',t_int(n),      &
     537                       ' &delta_r=',delta_r,                                   &
    502538                       ' particle_radius=',particles(n)%radius
    503539          CALL message( 'lpm_droplet_condensation', 'PA0144', 2, 2, -1, 6, 1 )
    … …  
    507543!--    Sum up the total volume of liquid water (needed below for
    508544!--    re-calculating the weighting factors)
    509        ql_v(k,j,i) = ql_v(k,j,i) + particles(n)%weight_factor * new_r**3
    510 
    511        particles(n)%radius = new_r
     545       ql_v(k,j,i) = ql_v(k,j,i) + particles(n)%weight_factor * new_r(n)**3
     546
     547       particles(n)%radius = new_r(n)
    512548
    513549!
    514550!--    Determine radius class of the particle needed for collision
    515        IF ( ( hall_kernel  .OR.  wang_kernel )  .AND.  use_kernel_tables ) &
     551       IF ( ( hall_kernel  .OR.  wang_kernel )  .AND.  use_kernel_tables )     &
    516552       THEN
    517           particles(n)%class = ( LOG( new_r ) - rclass_lbound ) /  &
    518                                ( rclass_ubound - rclass_lbound ) * &
     553          particles(n)%class = ( LOG( new_r(n) ) - rclass_lbound ) /           &
     554                               ( rclass_ubound - rclass_lbound ) *             &
    519555                               radius_classes
    520556          particles(n)%class = MIN( particles(n)%class, radius_classes )

  • TabularUnified palm/trunk/SOURCE/lpm_exchange_horiz.f90

    r1329 r1359  
    1  SUBROUTINE lpm_exchange_horiz
     1 MODULE lpm_exchange_horiz_mod
    22
    33!--------------------------------------------------------------------------------!
    … …  
    2020! Current revisions:
    2121! ------------------
    22 !
     22! New particle structure integrated.
     23! Kind definition added to all floating point numbers.
    2324!
    2425! Former revisions:
    … …  
    5657
    5758    USE control_parameters,                                                    &
    58         ONLY:  message_string, netcdf_data_format
     59        ONLY:  dz, message_string, netcdf_data_format, simulated_time
    5960
    6061    USE cpulog,                                                                &
    … …  
    6566
    6667    USE indices,                                                               &
    67         ONLY:  nx, nxl, nxr, ny, nyn, nys
     68        ONLY:  nx, nxl, nxr, ny, nyn, nys, nzb, nzt
    6869
    6970    USE kinds
    7071
     72    USE lpm_pack_arrays_mod,                                                   &
     73        ONLY:  lpm_pack_arrays
     74
    7175    USE particle_attributes,                                                   &
    72         ONLY:  deleted_particles, deleted_tails, ibc_par_lr, ibc_par_ns,       &
    73                maximum_number_of_particles, maximum_number_of_tails,           &
    74                maximum_number_of_tailpoints, mpi_particle_type,                &
    75                number_of_tails, number_of_particles, particles, particle_mask, &
    76                particle_tail_coordinates, particle_type, tail_mask,            &
    77                trlp_count_sum, trlp_count_recv_sum, trnp_count_sum,            &
    78                trnp_count_recv_sum, trrp_count_sum, trrp_count_recv_sum,       &
    79                trsp_count_sum, trsp_count_recv_sum, use_particle_tails
     76        ONLY:  alloc_factor, deleted_particles, deleted_tails, grid_particles, &
     77               ibc_par_lr, ibc_par_ns, maximum_number_of_tails,                &
     78               maximum_number_of_tailpoints, min_nr_particle,                  &
     79               mpi_particle_type, number_of_tails, number_of_particles,        &
     80               offset_ocean_nzt, offset_ocean_nzt_m1, particles,               &
     81               particle_tail_coordinates, particle_type, prt_count,            &
     82               tail_mask, trlp_count_sum,                                      &
     83               trlp_count_recv_sum, trnp_count_sum, trnp_count_recv_sum,       &
     84               trrp_count_sum, trrp_count_recv_sum, trsp_count_sum,            &
     85               trsp_count_recv_sum, use_particle_tails, zero_particle
    8086
    8187    USE pegrid
    … …  
    8389    IMPLICIT NONE
    8490
     91    INTEGER(iwp), PARAMETER ::  NR_2_direction_move = 10000 !:
     92    INTEGER(iwp)            ::  nr_move_north               !:
     93    INTEGER(iwp)            ::  nr_move_south               !:
     94
     95    TYPE(particle_type), DIMENSION(NR_2_direction_move) ::  move_also_north
     96    TYPE(particle_type), DIMENSION(NR_2_direction_move) ::  move_also_south
     97
     98    SAVE
     99
     100    PRIVATE
     101    PUBLIC lpm_exchange_horiz, lpm_move_particle, realloc_particles_array
     102
     103    INTERFACE lpm_exchange_horiz
     104       MODULE PROCEDURE lpm_exchange_horiz
     105    END INTERFACE lpm_exchange_horiz
     106
     107    INTERFACE lpm_move_particle
     108       MODULE PROCEDURE lpm_move_particle
     109    END INTERFACE lpm_move_particle
     110
     111    INTERFACE realloc_particles_array
     112       MODULE PROCEDURE realloc_particles_array
     113    END INTERFACE realloc_particles_array
     114
     115CONTAINS
     116
     117 SUBROUTINE lpm_exchange_horiz
     118
     119    IMPLICIT NONE
     120
    85121    INTEGER(iwp) ::  i                                       !:
     122    INTEGER(iwp) ::  ip                                      !:
    86123    INTEGER(iwp) ::  j                                       !:
     124    INTEGER(iwp) ::  jp                                      !:
     125    INTEGER(iwp) ::  k                                       !:
     126    INTEGER(iwp) ::  kp                                      !:
    87127    INTEGER(iwp) ::  n                                       !:
    88128    INTEGER(iwp) ::  nn                                      !:
    … …  
    110150    REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  trspt        !:
    111151
    112 
     152    TYPE(particle_type), DIMENSION(:), ALLOCATABLE ::  rvlp  !:
     153    TYPE(particle_type), DIMENSION(:), ALLOCATABLE ::  rvnp  !:
     154    TYPE(particle_type), DIMENSION(:), ALLOCATABLE ::  rvrp  !:
     155    TYPE(particle_type), DIMENSION(:), ALLOCATABLE ::  rvsp  !:
    113156    TYPE(particle_type), DIMENSION(:), ALLOCATABLE ::  trlp  !:
    114157    TYPE(particle_type), DIMENSION(:), ALLOCATABLE ::  trnp  !:
    115158    TYPE(particle_type), DIMENSION(:), ALLOCATABLE ::  trrp  !:
    116159    TYPE(particle_type), DIMENSION(:), ALLOCATABLE ::  trsp  !:
     160
     161    CALL cpu_log( log_point_s(23), 'lpm_exchange_horiz', 'start' )
    117162
    118163#if defined( __parallel )
    … …  
    141186    IF ( pdims(1) /= 1 )  THEN
    142187!
    143 !--    First calculate the storage necessary for sending and receiving the data
    144        DO  n = 1, number_of_particles
    145           i = ( particles(n)%x + 0.5 * dx ) * ddx
    146 !
    147 !--       Above calculation does not work for indices less than zero
    148           IF ( particles(n)%x < -0.5 * dx )  i = -1
    149 
    150           IF ( i < nxl )  THEN
    151              trlp_count = trlp_count + 1
    152              IF ( particles(n)%tail_id /= 0 )  trlpt_count = trlpt_count + 1
    153           ELSEIF ( i > nxr )  THEN
    154              trrp_count = trrp_count + 1
    155              IF ( particles(n)%tail_id /= 0 )  trrpt_count = trrpt_count + 1
    156           ENDIF
     188!--    First calculate the storage necessary for sending and receiving the data.
     189!--    Compute only first (nxl) and last (nxr) loop iterration.
     190       DO  ip = nxl, nxr, nxr - nxl
     191          DO  jp = nys, nyn
     192             DO  kp = nzb+1, nzt
     193
     194                number_of_particles = prt_count(kp,jp,ip)
     195                IF ( number_of_particles <= 0 )  CYCLE
     196                particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
     197                DO  n = 1, number_of_particles
     198                   IF ( particles(n)%particle_mask )  THEN
     199                      i = ( particles(n)%x + 0.5_wp * dx ) * ddx
     200   !
     201   !--                Above calculation does not work for indices less than zero
     202                      IF ( particles(n)%x < -0.5_wp * dx )  i = -1
     203
     204                      IF ( i < nxl )  THEN
     205                         trlp_count = trlp_count + 1
     206                         IF ( particles(n)%tail_id /= 0 )  trlpt_count = trlpt_count + 1
     207                      ELSEIF ( i > nxr )  THEN
     208                         trrp_count = trrp_count + 1
     209                         IF ( particles(n)%tail_id /= 0 )  trrpt_count = trrpt_count + 1
     210                      ENDIF
     211                   ENDIF
     212                ENDDO
     213
     214             ENDDO
     215          ENDDO
    157216       ENDDO
    158217
    … …  
    164223       ALLOCATE( trlp(trlp_count), trrp(trrp_count) )
    165224
    166        trlp = particle_type( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, &
    167                              0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, &
    168                              0.0, 0, 0, 0, 0 )
    169        trrp = particle_type( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, &
    170                              0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, &
    171                              0.0, 0, 0, 0, 0 )
     225       trlp = zero_particle
     226       trrp = zero_particle
    172227
    173228       IF ( use_particle_tails )  THEN
    … …  
    183238
    184239    ENDIF
    185 
    186     DO  n = 1, number_of_particles
    187 
    188        nn = particles(n)%tail_id
    189 
    190        i = ( particles(n)%x + 0.5 * dx ) * ddx
    191 !
    192 !--    Above calculation does not work for indices less than zero
    193        IF ( particles(n)%x < - 0.5 * dx )  i = -1
    194 
    195        IF ( i <  nxl )  THEN
    196           IF ( i < 0 )  THEN
    197 !
    198 !--          Apply boundary condition along x
    199              IF ( ibc_par_lr == 0 )  THEN
    200 !
    201 !--             Cyclic condition
    202                 IF ( pdims(1) == 1 )  THEN
    203                    particles(n)%x        = ( nx + 1 ) * dx + particles(n)%x
    204                    particles(n)%origin_x = ( nx + 1 ) * dx + &
    205                                            particles(n)%origin_x
    206                    IF ( use_particle_tails  .AND.  nn /= 0 )  THEN
    207                       i  = particles(n)%tailpoints
    208                       particle_tail_coordinates(1:i,1,nn) = ( nx + 1 ) * dx &
    209                                         + particle_tail_coordinates(1:i,1,nn)
    210                    ENDIF
    211                 ELSE
    212                    trlp_count = trlp_count + 1
    213                    trlp(trlp_count)   = particles(n)
    214                    trlp(trlp_count)%x = ( nx + 1 ) * dx + trlp(trlp_count)%x
    215                    trlp(trlp_count)%origin_x = trlp(trlp_count)%origin_x + &
    216                                                ( nx + 1 ) * dx
    217                    particle_mask(n)  = .FALSE.
    218                    deleted_particles = deleted_particles + 1
    219 
    220                    IF ( trlp(trlp_count)%x >= (nx + 0.5)* dx - 1.0E-12 ) THEN
    221                       trlp(trlp_count)%x = trlp(trlp_count)%x - 1.0E-10
    222 !++ why is 1 subtracted in next statement???
    223                       trlp(trlp_count)%origin_x = trlp(trlp_count)%origin_x - 1
    224                    ENDIF
    225 
    226                    IF ( use_particle_tails  .AND.  nn /= 0 )  THEN
    227                       trlpt_count = trlpt_count + 1
    228                       trlpt(:,:,trlpt_count) = particle_tail_coordinates(:,:,nn)
    229                       trlpt(:,1,trlpt_count) = ( nx + 1 ) * dx + &
    230                                                trlpt(:,1,trlpt_count)
    231                       tail_mask(nn) = .FALSE.
    232                       deleted_tails = deleted_tails + 1
     240!
     241!-- Compute only first (nxl) and last (nxr) loop iterration
     242    DO  ip = nxl, nxr,nxr-nxl
     243       DO  jp = nys, nyn
     244          DO  kp = nzb+1, nzt
     245             number_of_particles = prt_count(kp,jp,ip)
     246             IF ( number_of_particles <= 0 ) CYCLE
     247             particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
     248             DO  n = 1, number_of_particles
     249
     250                nn = particles(n)%tail_id
     251!
     252!--             Only those particles that have not been marked as 'deleted' may
     253!--             be moved.
     254                IF ( particles(n)%particle_mask )  THEN
     255
     256                   i = ( particles(n)%x + 0.5_wp * dx ) * ddx
     257   !
     258   !--             Above calculation does not work for indices less than zero
     259                   IF ( particles(n)%x < - 0.5_wp * dx )  i = -1
     260
     261                   IF ( i <  nxl )  THEN
     262                      IF ( i < 0 )  THEN
     263   !
     264   !--                   Apply boundary condition along x
     265                         IF ( ibc_par_lr == 0 )  THEN
     266   !
     267   !--                      Cyclic condition
     268                            IF ( pdims(1) == 1 )  THEN
     269                               particles(n)%x        = ( nx + 1 ) * dx + particles(n)%x
     270                               particles(n)%origin_x = ( nx + 1 ) * dx + &
     271                               particles(n)%origin_x
     272                               IF ( use_particle_tails  .AND.  nn /= 0 )  THEN
     273                                  i  = particles(n)%tailpoints
     274                                  particle_tail_coordinates(1:i,1,nn) = ( nx + 1 ) * dx &
     275                                  + particle_tail_coordinates(1:i,1,nn)
     276                               ENDIF
     277                            ELSE
     278                               trlp_count = trlp_count + 1
     279                               trlp(trlp_count)   = particles(n)
     280                               trlp(trlp_count)%x = ( nx + 1 ) * dx + trlp(trlp_count)%x
     281                               trlp(trlp_count)%origin_x = trlp(trlp_count)%origin_x + &
     282                               ( nx + 1 ) * dx
     283                               particles(n)%particle_mask  = .FALSE.
     284                               deleted_particles = deleted_particles + 1
     285
     286                               IF ( trlp(trlp_count)%x >= (nx + 0.5_wp)* dx - 1.0E-12_wp )  THEN
     287                                  trlp(trlp_count)%x = trlp(trlp_count)%x - 1.0E-10_wp
     288                                  !++ why is 1 subtracted in next statement???
     289                                  trlp(trlp_count)%origin_x = trlp(trlp_count)%origin_x - 1
     290                               ENDIF
     291
     292                               IF ( use_particle_tails  .AND.  nn /= 0 )  THEN
     293                                  trlpt_count = trlpt_count + 1
     294                                  trlpt(:,:,trlpt_count) = particle_tail_coordinates(:,:,nn)
     295                                  trlpt(:,1,trlpt_count) = ( nx + 1 ) * dx + &
     296                                  trlpt(:,1,trlpt_count)
     297                                  tail_mask(nn) = .FALSE.
     298                                  deleted_tails = deleted_tails + 1
     299                               ENDIF
     300                            ENDIF
     301
     302                         ELSEIF ( ibc_par_lr == 1 )  THEN
     303   !
     304   !--                      Particle absorption
     305                            particles(n)%particle_mask = .FALSE.
     306                            deleted_particles = deleted_particles + 1
     307                            IF ( use_particle_tails  .AND.  nn /= 0 )  THEN
     308                               tail_mask(nn) = .FALSE.
     309                               deleted_tails = deleted_tails + 1
     310                            ENDIF
     311
     312                         ELSEIF ( ibc_par_lr == 2 )  THEN
     313   !
     314   !--                      Particle reflection
     315                            particles(n)%x       = -particles(n)%x
     316                            particles(n)%speed_x = -particles(n)%speed_x
     317
     318                         ENDIF
     319                      ELSE
     320   !
     321   !--                   Store particle data in the transfer array, which will be
     322   !--                   send to the neighbouring PE
     323                         trlp_count = trlp_count + 1
     324                         trlp(trlp_count) = particles(n)
     325                         particles(n)%particle_mask = .FALSE.
     326                         deleted_particles = deleted_particles + 1
     327
     328                         IF ( use_particle_tails  .AND.  nn /= 0 )  THEN
     329                            trlpt_count = trlpt_count + 1
     330                            trlpt(:,:,trlpt_count) = particle_tail_coordinates(:,:,nn)
     331                            tail_mask(nn) = .FALSE.
     332                            deleted_tails = deleted_tails + 1
     333                         ENDIF
     334                      ENDIF
     335
     336                   ELSEIF ( i > nxr )  THEN
     337                      IF ( i > nx )  THEN
     338   !
     339   !--                   Apply boundary condition along x
     340                         IF ( ibc_par_lr == 0 )  THEN
     341   !
     342   !--                      Cyclic condition
     343                            IF ( pdims(1) == 1 )  THEN
     344                               particles(n)%x = particles(n)%x - ( nx + 1 ) * dx
     345                               particles(n)%origin_x = particles(n)%origin_x - &
     346                               ( nx + 1 ) * dx
     347                               IF ( use_particle_tails  .AND.  nn /= 0 )  THEN
     348                                  i = particles(n)%tailpoints
     349                                  particle_tail_coordinates(1:i,1,nn) = - ( nx+1 ) * dx &
     350                                  + particle_tail_coordinates(1:i,1,nn)
     351                               ENDIF
     352                            ELSE
     353                               trrp_count = trrp_count + 1
     354                               trrp(trrp_count) = particles(n)
     355                               trrp(trrp_count)%x = trrp(trrp_count)%x - ( nx + 1 ) * dx
     356                               trrp(trrp_count)%origin_x = trrp(trrp_count)%origin_x - &
     357                               ( nx + 1 ) * dx
     358                               particles(n)%particle_mask = .FALSE.
     359                               deleted_particles = deleted_particles + 1
     360
     361                               IF ( use_particle_tails  .AND.  nn /= 0 )  THEN
     362                                  trrpt_count = trrpt_count + 1
     363                                  trrpt(:,:,trrpt_count) = particle_tail_coordinates(:,:,nn)
     364                                  trrpt(:,1,trrpt_count) = trrpt(:,1,trrpt_count) - &
     365                                  ( nx + 1 ) * dx
     366                                  tail_mask(nn) = .FALSE.
     367                                  deleted_tails = deleted_tails + 1
     368                               ENDIF
     369                            ENDIF
     370
     371                         ELSEIF ( ibc_par_lr == 1 )  THEN
     372   !
     373   !--                      Particle absorption
     374                            particles(n)%particle_mask = .FALSE.
     375                            deleted_particles = deleted_particles + 1
     376                            IF ( use_particle_tails  .AND.  nn /= 0 )  THEN
     377                               tail_mask(nn) = .FALSE.
     378                               deleted_tails = deleted_tails + 1
     379                            ENDIF
     380
     381                         ELSEIF ( ibc_par_lr == 2 )  THEN
     382   !
     383   !--                      Particle reflection
     384                            particles(n)%x       = 2 * ( nx * dx ) - particles(n)%x
     385                            particles(n)%speed_x = -particles(n)%speed_x
     386
     387                         ENDIF
     388                      ELSE
     389   !
     390   !--                   Store particle data in the transfer array, which will be send
     391   !--                   to the neighbouring PE
     392                         trrp_count = trrp_count + 1
     393                         trrp(trrp_count) = particles(n)
     394                         particles(n)%particle_mask = .FALSE.
     395                         deleted_particles = deleted_particles + 1
     396
     397                         IF ( use_particle_tails  .AND.  nn /= 0 )  THEN
     398                            trrpt_count = trrpt_count + 1
     399                            trrpt(:,:,trrpt_count) = particle_tail_coordinates(:,:,nn)
     400                            tail_mask(nn) = .FALSE.
     401                            deleted_tails = deleted_tails + 1
     402                         ENDIF
     403                      ENDIF
     404
    233405                   ENDIF
    234406                ENDIF
    235 
    236              ELSEIF ( ibc_par_lr == 1 )  THEN
    237 !
    238 !--             Particle absorption
    239                 particle_mask(n) = .FALSE.
    240                 deleted_particles = deleted_particles + 1
    241                 IF ( use_particle_tails  .AND.  nn /= 0 )  THEN
    242                    tail_mask(nn) = .FALSE.
    243                    deleted_tails = deleted_tails + 1
    244                 ENDIF
    245 
    246              ELSEIF ( ibc_par_lr == 2 )  THEN
    247 !
    248 !--             Particle reflection
    249                 particles(n)%x       = -particles(n)%x
    250                 particles(n)%speed_x = -particles(n)%speed_x
    251 
    252              ENDIF
    253           ELSE
    254 !
    255 !--          Store particle data in the transfer array, which will be send
    256 !--          to the neighbouring PE
    257              trlp_count = trlp_count + 1
    258              trlp(trlp_count) = particles(n)
    259              particle_mask(n) = .FALSE.
    260              deleted_particles = deleted_particles + 1
    261 
    262              IF ( use_particle_tails  .AND.  nn /= 0 )  THEN
    263                 trlpt_count = trlpt_count + 1
    264                 trlpt(:,:,trlpt_count) = particle_tail_coordinates(:,:,nn)
    265                 tail_mask(nn) = .FALSE.
    266                 deleted_tails = deleted_tails + 1
    267              ENDIF
    268          ENDIF
    269 
    270        ELSEIF ( i > nxr )  THEN
    271           IF ( i > nx )  THEN
    272 !
    273 !--          Apply boundary condition along x
    274              IF ( ibc_par_lr == 0 )  THEN
    275 !
    276 !--             Cyclic condition
    277                 IF ( pdims(1) == 1 )  THEN
    278                    particles(n)%x = particles(n)%x - ( nx + 1 ) * dx
    279                    particles(n)%origin_x = particles(n)%origin_x - &
    280                                            ( nx + 1 ) * dx
    281                    IF ( use_particle_tails  .AND.  nn /= 0 )  THEN
    282                       i = particles(n)%tailpoints
    283                       particle_tail_coordinates(1:i,1,nn) = - ( nx+1 ) * dx &
    284                                            + particle_tail_coordinates(1:i,1,nn)
    285                    ENDIF
    286                 ELSE
    287                    trrp_count = trrp_count + 1
    288                    trrp(trrp_count) = particles(n)
    289                    trrp(trrp_count)%x = trrp(trrp_count)%x - ( nx + 1 ) * dx
    290                    trrp(trrp_count)%origin_x = trrp(trrp_count)%origin_x - &
    291                                                ( nx + 1 ) * dx
    292                    particle_mask(n) = .FALSE.
    293                    deleted_particles = deleted_particles + 1
    294 
    295                    IF ( use_particle_tails  .AND.  nn /= 0 )  THEN
    296                       trrpt_count = trrpt_count + 1
    297                       trrpt(:,:,trrpt_count) = particle_tail_coordinates(:,:,nn)
    298                       trrpt(:,1,trrpt_count) = trrpt(:,1,trrpt_count) - &
    299                                                ( nx + 1 ) * dx
    300                       tail_mask(nn) = .FALSE.
    301                       deleted_tails = deleted_tails + 1
    302                    ENDIF
    303                 ENDIF
    304 
    305              ELSEIF ( ibc_par_lr == 1 )  THEN
    306 !
    307 !--             Particle absorption
    308                 particle_mask(n) = .FALSE.
    309                 deleted_particles = deleted_particles + 1
    310                 IF ( use_particle_tails  .AND.  nn /= 0 )  THEN
    311                    tail_mask(nn) = .FALSE.
    312                    deleted_tails = deleted_tails + 1
    313                 ENDIF
    314 
    315              ELSEIF ( ibc_par_lr == 2 )  THEN
    316 !
    317 !--             Particle reflection
    318                 particles(n)%x       = 2 * ( nx * dx ) - particles(n)%x
    319                 particles(n)%speed_x = -particles(n)%speed_x
    320 
    321              ENDIF
    322           ELSE
    323 !
    324 !--          Store particle data in the transfer array, which will be send
    325 !--          to the neighbouring PE
    326              trrp_count = trrp_count + 1
    327              trrp(trrp_count) = particles(n)
    328              particle_mask(n) = .FALSE.
    329              deleted_particles = deleted_particles + 1
    330 
    331              IF ( use_particle_tails  .AND.  nn /= 0 )  THEN
    332                 trrpt_count = trrpt_count + 1
    333                 trrpt(:,:,trrpt_count) = particle_tail_coordinates(:,:,nn)
    334                 tail_mask(nn) = .FALSE.
    335                 deleted_tails = deleted_tails + 1
    336              ENDIF
    337           ENDIF
    338 
    339        ENDIF
     407             ENDDO
     408          ENDDO
     409       ENDDO
    340410    ENDDO
    341411
    … …  
    345415    IF ( pdims(1) /= 1 )  THEN
    346416
    347        CALL cpu_log( log_point_s(23), 'sendrcv_particles', 'start' )
    348417       CALL MPI_SENDRECV( trlp_count,      1, MPI_INTEGER, pleft,  0, &
    349418                          trrp_count_recv, 1, MPI_INTEGER, pright, 0, &
    350419                          comm2d, status, ierr )
    351420
    352        IF ( number_of_particles + trrp_count_recv > &
    353             maximum_number_of_particles )           &
    354        THEN
    355           IF ( netcdf_data_format < 3 )  THEN
    356               message_string = 'maximum_number_of_particles ' //    &
    357                                'needs to be increased ' //          &
    358                                '&but this is not allowed with ' //  &
    359                                'netcdf-data_format < 3'
    360              CALL message( 'lpm_exch_horiz', 'PA0146', 2, 2, -1, 6, 1 )
    361           ELSE
    362              CALL lpm_extend_particle_array( trrp_count_recv )
    363           ENDIF
    364        ENDIF
    365 
    366        CALL MPI_SENDRECV( trlp(1)%age, trlp_count, mpi_particle_type,     &
    367                           pleft, 1, particles(number_of_particles+1)%age, &
    368                           trrp_count_recv, mpi_particle_type, pright, 1,  &
     421       ALLOCATE(rvrp(MAX(1,trrp_count_recv)))
     422
     423       CALL MPI_SENDRECV( trlp(1)%radius, max(1,trlp_count), mpi_particle_type,&
     424                          pleft, 1, rvrp(1)%radius,                            &
     425                          max(1,trrp_count_recv), mpi_particle_type, pright, 1,&
    369426                          comm2d, status, ierr )
     427
     428       IF ( trrp_count_recv > 0 )  CALL Add_particles_to_gridcell(rvrp(1:trrp_count_recv))
     429
     430       DEALLOCATE(rvrp)
    370431
    371432       IF ( use_particle_tails )  THEN
    … …  
    405466       ENDIF
    406467
    407        number_of_particles = number_of_particles + trrp_count_recv
    408        number_of_tails     = number_of_tails     + trrpt_count_recv
    409 
    410468!
    411469!--    Send right boundary, receive left boundary
    … …  
    414472                          comm2d, status, ierr )
    415473
    416        IF ( number_of_particles + trlp_count_recv > &
    417             maximum_number_of_particles )           &
    418        THEN
    419           IF ( netcdf_data_format < 3 )  THEN
    420              message_string = 'maximum_number_of_particles ' //  &
    421                               'needs to be increased ' //        &
    422                               '&but this is not allowed with '// &
    423                               'netcdf_data_format < 3'
    424              CALL message( 'lpm_exch_horiz', 'PA0146', 2, 2, -1, 6, 1 )
    425           ELSE
    426              CALL lpm_extend_particle_array( trlp_count_recv )
    427           ENDIF
    428        ENDIF
    429 
    430        CALL MPI_SENDRECV( trrp(1)%age, trrp_count, mpi_particle_type,      &
    431                           pright, 1, particles(number_of_particles+1)%age, &
    432                           trlp_count_recv, mpi_particle_type, pleft, 1,    &
     474       ALLOCATE(rvlp(MAX(1,trlp_count_recv)))
     475
     476       CALL MPI_SENDRECV( trrp(1)%radius, max(1,trrp_count), mpi_particle_type,&
     477                          pright, 1, rvlp(1)%radius,                           &
     478                          max(1,trlp_count_recv), mpi_particle_type, pleft, 1, &
    433479                          comm2d, status, ierr )
     480
     481       IF ( trlp_count_recv > 0 )  CALL Add_particles_to_gridcell(rvlp(1:trlp_count_recv))
     482
     483       DEALLOCATE(rvlp)
    434484
    435485       IF ( use_particle_tails )  THEN
    … …  
    469519       ENDIF
    470520
    471        number_of_particles = number_of_particles + trlp_count_recv
    472        number_of_tails     = number_of_tails     + trlpt_count_recv
     521!       number_of_particles = number_of_particles + trlp_count_recv
     522!       number_of_tails     = number_of_tails     + trlpt_count_recv
    473523
    474524       IF ( use_particle_tails )  THEN
    475525          DEALLOCATE( trlpt, trrpt )
    476526       ENDIF
    477        DEALLOCATE( trlp, trrp )
    478 
    479        CALL cpu_log( log_point_s(23), 'sendrcv_particles', 'pause' )
     527       DEALLOCATE( trlp, trrp )
    480528
    481529    ENDIF
    … …  
    490538!-- For a one-dimensional decomposition along x, no transfer is necessary,
    491539!-- because the particle remains on the PE.
    492     trsp_count  = 0
     540    trsp_count  = nr_move_south
    493541    trspt_count = 0
    494     trnp_count  = 0
     542    trnp_count  = nr_move_north
    495543    trnpt_count = 0
    496544
    … …  
    504552!--    First calculate the storage necessary for sending and receiving the
    505553!--    data
    506        DO  n = 1, number_of_particles
    507           IF ( particle_mask(n) )  THEN
    508              j = ( particles(n)%y + 0.5 * dy ) * ddy
    509 !
    510 !--          Above calculation does not work for indices less than zero
    511              IF ( particles(n)%y < -0.5 * dy )  j = -1
    512 
    513              IF ( j < nys )  THEN
    514                 trsp_count = trsp_count + 1
    515                 IF ( particles(n)%tail_id /= 0 )  trspt_count = trspt_count+1
    516              ELSEIF ( j > nyn )  THEN
    517                 trnp_count = trnp_count + 1
    518                 IF ( particles(n)%tail_id /= 0 )  trnpt_count = trnpt_count+1
    519              ENDIF
    520           ENDIF
     554       DO  ip = nxl, nxr
     555          DO  jp = nys, nyn, nyn-nys                                 !compute only first (nys) and last (nyn) loop iterration
     556             DO  kp = nzb+1, nzt
     557                number_of_particles = prt_count(kp,jp,ip)
     558                IF ( number_of_particles <= 0 )  CYCLE
     559                particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
     560                DO  n = 1, number_of_particles
     561                   IF ( particles(n)%particle_mask )  THEN
     562                      j = ( particles(n)%y + 0.5_wp * dy ) * ddy
     563!
     564!--                   Above calculation does not work for indices less than zero
     565                      IF ( particles(n)%y < -0.5_wp * dy )  j = -1
     566
     567                      IF ( j < nys )  THEN
     568                         trsp_count = trsp_count + 1
     569                         IF ( particles(n)%tail_id /= 0 )  trspt_count = trspt_count + 1
     570                      ELSEIF ( j > nyn )  THEN
     571                         trnp_count = trnp_count + 1
     572                         IF ( particles(n)%tail_id /= 0 )  trnpt_count = trnpt_count + 1
     573                      ENDIF
     574                   ENDIF
     575                ENDDO
     576             ENDDO
     577          ENDDO
    521578       ENDDO
    522579
    … …  
    528585       ALLOCATE( trsp(trsp_count), trnp(trnp_count) )
    529586
    530        trsp = particle_type( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, &
    531                              0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, &
    532                              0.0, 0, 0, 0, 0 )
    533        trnp = particle_type( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, &
    534                              0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, &
    535                              0.0, 0, 0, 0, 0 )
     587       trsp = zero_particle
     588       trnp = zero_particle
    536589
    537590       IF ( use_particle_tails )  THEN
    … …  
    541594       ENDIF
    542595
    543        trsp_count  = 0
     596       trsp_count  = nr_move_south
    544597       trspt_count = 0
    545        trnp_count  = 0
     598       trnp_count  = nr_move_north
    546599       trnpt_count = 0
    547600
     601       trsp(1:nr_move_south) = move_also_south(1:nr_move_south)
     602       trnp(1:nr_move_north) = move_also_north(1:nr_move_north)
     603
    548604    ENDIF
    549605
    550     DO  n = 1, number_of_particles
    551 
    552        nn = particles(n)%tail_id
    553 !
    554 !--    Only those particles that have not been marked as 'deleted' may be
    555 !--    moved.
    556        IF ( particle_mask(n) )  THEN
    557           j = ( particles(n)%y + 0.5 * dy ) * ddy
    558 !
    559 !--       Above calculation does not work for indices less than zero
    560           IF ( particles(n)%y < -0.5 * dy )  j = -1
    561 
    562           IF ( j < nys )  THEN
    563              IF ( j < 0 )  THEN
    564 !
    565 !--             Apply boundary condition along y
    566                 IF ( ibc_par_ns == 0 )  THEN
    567 !
    568 !--                Cyclic condition
    569                    IF ( pdims(2) == 1 )  THEN
    570                       particles(n)%y = ( ny + 1 ) * dy + particles(n)%y
    571                       particles(n)%origin_y = ( ny + 1 ) * dy + &
    572                                               particles(n)%origin_y
    573                       IF ( use_particle_tails  .AND.  nn /= 0 )  THEN
    574                          i = particles(n)%tailpoints
    575                          particle_tail_coordinates(1:i,2,nn) = ( ny+1 ) * dy&
    576                                         + particle_tail_coordinates(1:i,2,nn)
     606    DO  ip = nxl, nxr
     607       DO  jp = nys, nyn, nyn-nys ! compute only first (nys) and last (nyn) loop iterration
     608          DO  kp = nzb+1, nzt
     609             number_of_particles = prt_count(kp,jp,ip)
     610             IF ( number_of_particles <= 0 )  CYCLE
     611             particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
     612             DO  n = 1, number_of_particles
     613
     614                nn = particles(n)%tail_id
     615!
     616!--             Only those particles that have not been marked as 'deleted' may
     617!--             be moved.
     618                IF ( particles(n)%particle_mask )  THEN
     619                   j = ( particles(n)%y + 0.5_wp * dy ) * ddy
     620!
     621!--                Above calculation does not work for indices less than zero
     622                   IF ( particles(n)%y < -0.5_wp * dy )  j = -1
     623
     624                   IF ( j < nys )  THEN
     625                      IF ( j < 0 )  THEN
     626!
     627!--                      Apply boundary condition along y
     628                         IF ( ibc_par_ns == 0 )  THEN
     629!
     630!--                         Cyclic condition
     631                            IF ( pdims(2) == 1 )  THEN
     632                               particles(n)%y = ( ny + 1 ) * dy + particles(n)%y
     633                               particles(n)%origin_y = ( ny + 1 ) * dy + &
     634                               particles(n)%origin_y
     635                               IF ( use_particle_tails  .AND.  nn /= 0 )  THEN
     636                                  i = particles(n)%tailpoints
     637                                  particle_tail_coordinates(1:i,2,nn) =        &
     638                                     ( ny+1 ) * dy + particle_tail_coordinates(1:i,2,nn)
     639                               ENDIF
     640                            ELSE
     641                               trsp_count = trsp_count + 1
     642                               trsp(trsp_count) = particles(n)
     643                               trsp(trsp_count)%y = ( ny + 1 ) * dy + &
     644                               trsp(trsp_count)%y
     645                               trsp(trsp_count)%origin_y = trsp(trsp_count)%origin_y &
     646                               + ( ny + 1 ) * dy
     647                               particles(n)%particle_mask = .FALSE.
     648                               deleted_particles = deleted_particles + 1
     649
     650                               IF ( trsp(trsp_count)%y >= (ny+0.5_wp)* dy - 1.0E-12_wp )  THEN
     651                                  trsp(trsp_count)%y = trsp(trsp_count)%y - 1.0E-10_wp
     652                                  !++ why is 1 subtracted in next statement???
     653                                  trsp(trsp_count)%origin_y =                        &
     654                                  trsp(trsp_count)%origin_y - 1
     655                               ENDIF
     656
     657                               IF ( use_particle_tails  .AND.  nn /= 0 )  THEN
     658                                  trspt_count = trspt_count + 1
     659                                  trspt(:,:,trspt_count) = &
     660                                  particle_tail_coordinates(:,:,nn)
     661                                  trspt(:,2,trspt_count) = ( ny + 1 ) * dy + &
     662                                  trspt(:,2,trspt_count)
     663                                  tail_mask(nn) = .FALSE.
     664                                  deleted_tails = deleted_tails + 1
     665                               ENDIF
     666                            ENDIF
     667
     668                         ELSEIF ( ibc_par_ns == 1 )  THEN
     669!
     670!--                         Particle absorption
     671                            particles(n)%particle_mask = .FALSE.
     672                            deleted_particles = deleted_particles + 1
     673                            IF ( use_particle_tails  .AND.  nn /= 0 )  THEN
     674                               tail_mask(nn) = .FALSE.
     675                               deleted_tails = deleted_tails + 1
     676                            ENDIF
     677
     678                         ELSEIF ( ibc_par_ns == 2 )  THEN
     679!
     680!--                         Particle reflection
     681                            particles(n)%y       = -particles(n)%y
     682                            particles(n)%speed_y = -particles(n)%speed_y
     683
     684                         ENDIF
     685                      ELSE
     686!
     687!--                      Store particle data in the transfer array, which will
     688!--                      be send to the neighbouring PE
     689                         trsp_count = trsp_count + 1
     690                         trsp(trsp_count) = particles(n)
     691                         particles(n)%particle_mask = .FALSE.
     692                         deleted_particles = deleted_particles + 1
     693
     694                         IF ( use_particle_tails  .AND.  nn /= 0 )  THEN
     695                            trspt_count = trspt_count + 1
     696                            trspt(:,:,trspt_count) = particle_tail_coordinates(:,:,nn)
     697                            tail_mask(nn) = .FALSE.
     698                            deleted_tails = deleted_tails + 1
     699                         ENDIF
    577700                      ENDIF
    578                    ELSE
    579                       trsp_count = trsp_count + 1
    580                       trsp(trsp_count) = particles(n)
    581                       trsp(trsp_count)%y = ( ny + 1 ) * dy + &
    582                                            trsp(trsp_count)%y
    583                       trsp(trsp_count)%origin_y = trsp(trsp_count)%origin_y &
    584                                                   + ( ny + 1 ) * dy
    585                       particle_mask(n) = .FALSE.
    586                       deleted_particles = deleted_particles + 1
    587 
    588                       IF ( trsp(trsp_count)%y >= (ny+0.5)* dy - 1.0E-12 ) THEN
    589                          trsp(trsp_count)%y = trsp(trsp_count)%y - 1.0E-10
    590 !++ why is 1 subtracted in next statement???
    591                          trsp(trsp_count)%origin_y =                        &
    592                                                    trsp(trsp_count)%origin_y - 1
     701
     702                   ELSEIF ( j > nyn )  THEN
     703                      IF ( j > ny )  THEN
     704!
     705!--                       Apply boundary condition along x
     706                         IF ( ibc_par_ns == 0 )  THEN
     707!
     708!--                         Cyclic condition
     709                            IF ( pdims(2) == 1 )  THEN
     710                               particles(n)%y = particles(n)%y - ( ny + 1 ) * dy
     711                               particles(n)%origin_y =                         &
     712                                  particles(n)%origin_y - ( ny + 1 ) * dy
     713                               IF ( use_particle_tails  .AND.  nn /= 0 )  THEN
     714                                  i = particles(n)%tailpoints
     715                                  particle_tail_coordinates(1:i,2,nn) =        &
     716                                     - (ny+1) * dy + particle_tail_coordinates(1:i,2,nn)
     717                               ENDIF
     718                            ELSE
     719                               trnp_count = trnp_count + 1
     720                               trnp(trnp_count) = particles(n)
     721                               trnp(trnp_count)%y =                            &
     722                                  trnp(trnp_count)%y - ( ny + 1 ) * dy
     723                               trnp(trnp_count)%origin_y =                     &
     724                                  trnp(trnp_count)%origin_y - ( ny + 1 ) * dy
     725                               particles(n)%particle_mask = .FALSE.
     726                               deleted_particles = deleted_particles + 1
     727                               IF ( use_particle_tails  .AND.  nn /= 0 )  THEN
     728                                  trnpt_count = trnpt_count + 1
     729                                  trnpt(:,:,trnpt_count) =                     &
     730                                     particle_tail_coordinates(:,:,nn)
     731                                  trnpt(:,2,trnpt_count) =                     &
     732                                     trnpt(:,2,trnpt_count) - ( ny + 1 ) * dy
     733                                  tail_mask(nn) = .FALSE.
     734                                  deleted_tails = deleted_tails + 1
     735                               ENDIF
     736                            ENDIF
     737
     738                         ELSEIF ( ibc_par_ns == 1 )  THEN
     739!
     740!--                         Particle absorption
     741                            particles(n)%particle_mask = .FALSE.
     742                            deleted_particles = deleted_particles + 1
     743                            IF ( use_particle_tails  .AND.  nn /= 0 )  THEN
     744                               tail_mask(nn) = .FALSE.
     745                               deleted_tails = deleted_tails + 1
     746                            ENDIF
     747
     748                         ELSEIF ( ibc_par_ns == 2 )  THEN
     749!
     750!--                         Particle reflection
     751                            particles(n)%y       = 2 * ( ny * dy ) - particles(n)%y
     752                            particles(n)%speed_y = -particles(n)%speed_y
     753
     754                         ENDIF
     755                      ELSE
     756!
     757!--                      Store particle data in the transfer array, which will
     758!--                      be send to the neighbouring PE
     759                         trnp_count = trnp_count + 1
     760                         trnp(trnp_count) = particles(n)
     761                         particles(n)%particle_mask = .FALSE.
     762                         deleted_particles = deleted_particles + 1
     763
     764                         IF ( use_particle_tails  .AND.  nn /= 0 )  THEN
     765                            trnpt_count = trnpt_count + 1
     766                            trnpt(:,:,trnpt_count) = particle_tail_coordinates(:,:,nn)
     767                            tail_mask(nn) = .FALSE.
     768                            deleted_tails = deleted_tails + 1
     769                         ENDIF
    593770                      ENDIF
    594771
    595                       IF ( use_particle_tails  .AND.  nn /= 0 )  THEN
    596                          trspt_count = trspt_count + 1
    597                          trspt(:,:,trspt_count) = &
    598                                                particle_tail_coordinates(:,:,nn)
    599                          trspt(:,2,trspt_count) = ( ny + 1 ) * dy + &
    600                                                   trspt(:,2,trspt_count)
    601                          tail_mask(nn) = .FALSE.
    602                          deleted_tails = deleted_tails + 1
    603                       ENDIF
    604772                   ENDIF
    605 
    606                 ELSEIF ( ibc_par_ns == 1 )  THEN
    607 !
    608 !--                Particle absorption
    609                    particle_mask(n) = .FALSE.
    610                    deleted_particles = deleted_particles + 1
    611                    IF ( use_particle_tails  .AND.  nn /= 0 )  THEN
    612                       tail_mask(nn) = .FALSE.
    613                       deleted_tails = deleted_tails + 1
    614                    ENDIF
    615 
    616                 ELSEIF ( ibc_par_ns == 2 )  THEN
    617 !
    618 !--                Particle reflection
    619                    particles(n)%y       = -particles(n)%y
    620                    particles(n)%speed_y = -particles(n)%speed_y
    621 
    622773                ENDIF
    623              ELSE
    624 !
    625 !--             Store particle data in the transfer array, which will be send
    626 !--             to the neighbouring PE
    627                 trsp_count = trsp_count + 1
    628                 trsp(trsp_count) = particles(n)
    629                 particle_mask(n) = .FALSE.
    630                 deleted_particles = deleted_particles + 1
    631 
    632                 IF ( use_particle_tails  .AND.  nn /= 0 )  THEN
    633                    trspt_count = trspt_count + 1
    634                    trspt(:,:,trspt_count) = particle_tail_coordinates(:,:,nn)
    635                    tail_mask(nn) = .FALSE.
    636                    deleted_tails = deleted_tails + 1
    637                 ENDIF
    638              ENDIF
    639 
    640           ELSEIF ( j > nyn )  THEN
    641              IF ( j > ny )  THEN
    642 !
    643 !--             Apply boundary condition along x
    644                 IF ( ibc_par_ns == 0 )  THEN
    645 !
    646 !--                Cyclic condition
    647                    IF ( pdims(2) == 1 )  THEN
    648                       particles(n)%y = particles(n)%y - ( ny + 1 ) * dy
    649                       particles(n)%origin_y = particles(n)%origin_y - &
    650                                               ( ny + 1 ) * dy
    651                       IF ( use_particle_tails  .AND.  nn /= 0 )  THEN
    652                          i = particles(n)%tailpoints
    653                          particle_tail_coordinates(1:i,2,nn) = - (ny+1) * dy &
    654                                            + particle_tail_coordinates(1:i,2,nn)
    655                       ENDIF
    656                    ELSE
    657                       trnp_count = trnp_count + 1
    658                       trnp(trnp_count) = particles(n)
    659                       trnp(trnp_count)%y = trnp(trnp_count)%y - &
    660                                            ( ny + 1 ) * dy
    661                       trnp(trnp_count)%origin_y = trnp(trnp_count)%origin_y &
    662                                                   - ( ny + 1 ) * dy
    663                       particle_mask(n) = .FALSE.
    664                       deleted_particles = deleted_particles + 1
    665 
    666                       IF ( use_particle_tails  .AND.  nn /= 0 )  THEN
    667                          trnpt_count = trnpt_count + 1
    668                          trnpt(:,:,trnpt_count) = &
    669                                                particle_tail_coordinates(:,:,nn)
    670                          trnpt(:,2,trnpt_count) = trnpt(:,2,trnpt_count) - &
    671                                                   ( ny + 1 ) * dy
    672                          tail_mask(nn) = .FALSE.
    673                          deleted_tails = deleted_tails + 1
    674                       ENDIF
    675                    ENDIF
    676 
    677                 ELSEIF ( ibc_par_ns == 1 )  THEN
    678 !
    679 !--                Particle absorption
    680                    particle_mask(n) = .FALSE.
    681                    deleted_particles = deleted_particles + 1
    682                    IF ( use_particle_tails  .AND.  nn /= 0 )  THEN
    683                       tail_mask(nn) = .FALSE.
    684                       deleted_tails = deleted_tails + 1
    685                    ENDIF
    686 
    687                 ELSEIF ( ibc_par_ns == 2 )  THEN
    688 !
    689 !--                Particle reflection
    690                    particles(n)%y       = 2 * ( ny * dy ) - particles(n)%y
    691                    particles(n)%speed_y = -particles(n)%speed_y
    692 
    693                 ENDIF
    694              ELSE
    695 !
    696 !--             Store particle data in the transfer array, which will be send
    697 !--             to the neighbouring PE
    698                 trnp_count = trnp_count + 1
    699                 trnp(trnp_count) = particles(n)
    700                 particle_mask(n) = .FALSE.
    701                 deleted_particles = deleted_particles + 1
    702 
    703                 IF ( use_particle_tails  .AND.  nn /= 0 )  THEN
    704                    trnpt_count = trnpt_count + 1
    705                    trnpt(:,:,trnpt_count) = particle_tail_coordinates(:,:,nn)
    706                    tail_mask(nn) = .FALSE.
    707                    deleted_tails = deleted_tails + 1
    708                 ENDIF
    709              ENDIF
    710 
    711           ENDIF
    712        ENDIF
     774             ENDDO
     775          ENDDO
     776       ENDDO
    713777    ENDDO
    714778
    … …  
    718782    IF ( pdims(2) /= 1 )  THEN
    719783
    720        CALL cpu_log( log_point_s(23), 'sendrcv_particles', 'continue' )
    721784       CALL MPI_SENDRECV( trsp_count,      1, MPI_INTEGER, psouth, 0, &
    722785                          trnp_count_recv, 1, MPI_INTEGER, pnorth, 0, &
    723786                          comm2d, status, ierr )
    724787
    725        IF ( number_of_particles + trnp_count_recv > &
    726             maximum_number_of_particles )           &
    727        THEN
    728           IF ( netcdf_data_format < 3 )  THEN
    729              message_string = 'maximum_number_of_particles ' //  &
    730                               'needs to be increased ' //        &
    731                               '&but this is not allowed with '// &
    732                               'netcdf_data_format < 3'
    733              CALL message( 'lpm_exch_horiz', 'PA0146', 2, 2, -1, 6, 1 )
    734           ELSE
    735              CALL lpm_extend_particle_array( trnp_count_recv )
    736           ENDIF
    737        ENDIF
    738 
    739        CALL MPI_SENDRECV( trsp(1)%age, trsp_count, mpi_particle_type,      &
    740                           psouth, 1, particles(number_of_particles+1)%age, &
     788       ALLOCATE(rvnp(MAX(1,trnp_count_recv)))
     789
     790       CALL MPI_SENDRECV( trsp(1)%radius, trsp_count, mpi_particle_type,      &
     791                          psouth, 1, rvnp(1)%radius,                             &
    741792                          trnp_count_recv, mpi_particle_type, pnorth, 1,   &
    742793                          comm2d, status, ierr )
     794
     795       IF ( trnp_count_recv  > 0 )  CALL Add_particles_to_gridcell(rvnp(1:trnp_count_recv))
     796
     797       DEALLOCATE(rvnp)
    743798
    744799       IF ( use_particle_tails )  THEN
    … …  
    779834       ENDIF
    780835
    781        number_of_particles = number_of_particles + trnp_count_recv
    782        number_of_tails     = number_of_tails     + trnpt_count_recv
     836!       number_of_particles = number_of_particles + trnp_count_recv
     837!       number_of_tails     = number_of_tails     + trnpt_count_recv
    783838
    784839!
    … …  
    788843                          comm2d, status, ierr )
    789844
    790        IF ( number_of_particles + trsp_count_recv > &
    791             maximum_number_of_particles )           &
    792        THEN
    793           IF ( netcdf_data_format < 3 )  THEN
    794              message_string = 'maximum_number_of_particles ' //   &
    795                               'needs to be increased ' //         &
    796                               '&but this is not allowed with ' // &
    797                               'netcdf_data_format < 3'
    798             CALL message( 'lpm_exch_horiz', 'PA0146', 2, 2, -1, 6, 1 ) 
    799           ELSE
    800              CALL lpm_extend_particle_array( trsp_count_recv )
    801           ENDIF
    802        ENDIF
    803 
    804        CALL MPI_SENDRECV( trnp(1)%age, trnp_count, mpi_particle_type,      &
    805                           pnorth, 1, particles(number_of_particles+1)%age, &
     845       ALLOCATE(rvsp(MAX(1,trsp_count_recv)))
     846
     847       CALL MPI_SENDRECV( trnp(1)%radius, trnp_count, mpi_particle_type,      &
     848                          pnorth, 1, rvsp(1)%radius,                          &
    806849                          trsp_count_recv, mpi_particle_type, psouth, 1,   &
    807850                          comm2d, status, ierr )
     851
     852       IF ( trsp_count_recv > 0 )  CALL Add_particles_to_gridcell(rvsp(1:trsp_count_recv))
     853
     854       DEALLOCATE(rvsp)
    808855
    809856       IF ( use_particle_tails )  THEN
    … …  
    851898       DEALLOCATE( trsp, trnp )
    852899
    853        CALL cpu_log( log_point_s(23), 'sendrcv_particles', 'stop' )
    854 
    855900    ENDIF
    856901
    … …  
    863908       nn = particles(n)%tail_id
    864909
    865        IF ( particles(n)%x < -0.5 * dx )  THEN
     910       IF ( particles(n)%x < -0.5_wp * dx )  THEN
    866911
    867912          IF ( ibc_par_lr == 0 )  THEN
    … …  
    877922!
    878923!--          Particle absorption
    879              particle_mask(n) = .FALSE.
     924             particles(n)%particle_mask = .FALSE.
    880925             deleted_particles = deleted_particles + 1
    881926             IF ( use_particle_tails  .AND.  nn /= 0 )  THEN
    … …  
    890935          ENDIF
    891936
    892        ELSEIF ( particles(n)%x >= ( nx + 0.5 ) * dx )  THEN
     937       ELSEIF ( particles(n)%x >= ( nx + 0.5_wp ) * dx )  THEN
    893938
    894939          IF ( ibc_par_lr == 0 )  THEN
    … …  
    904949!
    905950!--          Particle absorption
    906              particle_mask(n) = .FALSE.
     951             particles(n)%particle_mask = .FALSE.
    907952             deleted_particles = deleted_particles + 1
    908953             IF ( use_particle_tails  .AND.  nn /= 0 )  THEN
    … …  
    919964       ENDIF
    920965
    921        IF ( particles(n)%y < -0.5 * dy )  THEN
     966       IF ( particles(n)%y < -0.5_wp * dy )  THEN
    922967
    923968          IF ( ibc_par_ns == 0 )  THEN
    … …  
    933978!
    934979!--          Particle absorption
    935              particle_mask(n) = .FALSE.
     980             particles(n)%particle_mask = .FALSE.
    936981             deleted_particles = deleted_particles + 1
    937982             IF ( use_particle_tails  .AND.  nn /= 0 )  THEN
    … …  
    946991          ENDIF
    947992
    948        ELSEIF ( particles(n)%y >= ( ny + 0.5 ) * dy )  THEN
     993       ELSEIF ( particles(n)%y >= ( ny + 0.5_wp ) * dy )  THEN
    949994
    950995          IF ( ibc_par_ns == 0 )  THEN
    … …  
    9601005!
    9611006!--          Particle absorption
    962              particle_mask(n) = .FALSE.
     1007             particles(n)%particle_mask = .FALSE.
    9631008             deleted_particles = deleted_particles + 1
    9641009             IF ( use_particle_tails  .AND.  nn /= 0 )  THEN
    … …  
    9911036#endif
    9921037
     1038    CALL cpu_log( log_point_s(23), 'lpm_exchange_horiz', 'stop' )
    9931039
    9941040 END SUBROUTINE lpm_exchange_horiz
     1041
     1042 SUBROUTINE Add_particles_to_gridcell (particle_array)
     1043
     1044!
     1045!-- If a particle moves from one processor to another, this subroutine moves
     1046!-- the corresponding elements from the particle arrays of the old grid cells
     1047!-- to the particle arrays of the new grid cells.
     1048
     1049    IMPLICIT NONE
     1050
     1051    INTEGER(iwp)        ::  ip        !:
     1052    INTEGER(iwp)        ::  jp        !:
     1053    INTEGER(iwp)        ::  kp        !:
     1054    INTEGER(iwp)        ::  n         !:
     1055    INTEGER(iwp)        ::  pindex    !:
     1056
     1057    LOGICAL             ::  pack_done !:
     1058
     1059    TYPE(particle_type), DIMENSION(:), INTENT(IN)       :: particle_array
     1060
     1061    pack_done     = .FALSE.
     1062
     1063    nr_move_north = 0
     1064    nr_move_south = 0
     1065
     1066    DO n = 1, SIZE(particle_array)
     1067       ip = ( particle_array(n)%x + 0.5_wp * dx ) * ddx
     1068       jp = ( particle_array(n)%y + 0.5_wp * dy ) * ddy
     1069       kp = particle_array(n)%z / dz + 1 + offset_ocean_nzt_m1
     1070
     1071       IF ( ip >= nxl  .AND.  ip <= nxr  .AND.  jp >= nys  .AND.  jp <= nyn    &
     1072            .AND.  kp >= nzb+1  .AND.  kp <= nzt)  THEN ! particle stays on processor
     1073          number_of_particles = prt_count(kp,jp,ip)
     1074          particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
     1075
     1076          pindex = prt_count(kp,jp,ip)+1
     1077          IF( pindex > SIZE(grid_particles(kp,jp,ip)%particles) )  THEN
     1078             IF ( pack_done )  THEN
     1079                CALL realloc_particles_array (ip,jp,kp)
     1080             ELSE
     1081                CALL lpm_pack_arrays
     1082                prt_count(kp,jp,ip) = number_of_particles
     1083                pindex = prt_count(kp,jp,ip)+1
     1084                IF ( pindex > SIZE(grid_particles(kp,jp,ip)%particles) )  THEN
     1085                   CALL realloc_particles_array (ip,jp,kp)
     1086                ENDIF
     1087                pack_done = .TRUE.
     1088             ENDIF
     1089          ENDIF
     1090          grid_particles(kp,jp,ip)%particles(pindex) = particle_array(n)
     1091          prt_count(kp,jp,ip) = pindex
     1092       ELSE
     1093          IF ( jp == nys - 1 )  THEN
     1094             nr_move_south = nr_move_south+1
     1095             move_also_south(nr_move_south) = particle_array(n)
     1096             IF ( jp == -1 )  THEN
     1097                move_also_south(nr_move_south)%y =                             &
     1098                   move_also_south(nr_move_south)%y + ( ny + 1 ) * dy
     1099                move_also_south(nr_move_south)%origin_y =                      &
     1100                   move_also_south(nr_move_south)%origin_y + ( ny + 1 ) * dy
     1101             ENDIF
     1102          ELSEIF ( jp == nyn+1 )  THEN
     1103             nr_move_north = nr_move_north+1
     1104             move_also_north(nr_move_north) = particle_array(n)
     1105             IF ( jp == ny+1 )  THEN
     1106                move_also_north(nr_move_north)%y =                             &
     1107                   move_also_north(nr_move_north)%y - ( ny + 1 ) * dy
     1108                move_also_north(nr_move_north)%origin_y =                      &
     1109                   move_also_north(nr_move_north)%origin_y - ( ny + 1 ) * dy
     1110             ENDIF
     1111          ELSE
     1112             WRITE(0,'(a,8i7)') 'particle out of range ',myid,ip,jp,kp,nxl,nxr,nys,nyn
     1113          ENDIF
     1114       ENDIF
     1115    ENDDO
     1116
     1117    RETURN
     1118
     1119 END SUBROUTINE Add_particles_to_gridcell
     1120
     1121
     1122
     1123
     1124 SUBROUTINE lpm_move_particle
     1125
     1126!
     1127!-- If a particle moves from one grid cell to another (on the current
     1128!-- processor!), this subroutine moves the corresponding element from the
     1129!-- particle array of the old grid cell to the particle array of the new grid
     1130!-- cell.
     1131
     1132    IMPLICIT NONE
     1133
     1134    INTEGER(iwp)        ::  i           !:
     1135    INTEGER(iwp)        ::  ip          !:
     1136    INTEGER(iwp)        ::  j           !:
     1137    INTEGER(iwp)        ::  jp          !:
     1138    INTEGER(iwp)        ::  k           !:
     1139    INTEGER(iwp)        ::  kp          !:
     1140    INTEGER(iwp)        ::  n           !:
     1141    INTEGER(iwp)        ::  np_old_cell !:
     1142    INTEGER(iwp)        ::  n_start     !:
     1143    INTEGER(iwp)        ::  pindex      !:
     1144
     1145    LOGICAL             ::  pack_done   !:
     1146
     1147    TYPE(particle_type), DIMENSION(:), POINTER  ::  particles_old_cell !:
     1148
     1149    CALL cpu_log( log_point_s(41), 'lpm_move_particle', 'start' )
     1150
     1151    DO  ip = nxl, nxr
     1152       DO  jp = nys, nyn
     1153          DO  kp = nzb+1, nzt
     1154
     1155             np_old_cell = prt_count(kp,jp,ip)
     1156             IF ( np_old_cell <= 0 )  CYCLE
     1157             particles_old_cell => grid_particles(kp,jp,ip)%particles(1:np_old_cell)
     1158             n_start = -1
     1159             
     1160             DO  n = 1, np_old_cell
     1161                i = ( particles_old_cell(n)%x + 0.5_wp * dx ) * ddx
     1162                j = ( particles_old_cell(n)%y + 0.5_wp * dy ) * ddy
     1163                k = particles_old_cell(n)%z / dz + 1 + offset_ocean_nzt
     1164!
     1165!--             Check, if particle has moved to another grid cell.
     1166                IF ( i /= ip  .OR.  j /= jp  .OR.  k /= kp )  THEN
     1167!
     1168!--                The particle has moved to another grid cell. Now check, if
     1169!--                particle stays on the same processor.
     1170                   IF ( i >= nxl  .AND.  i <= nxr  .AND.  j >= nys  .AND.      &
     1171                        j <= nyn  .AND.  k >= nzb+1  .AND.  k <= nzt)  THEN
     1172!
     1173!--                   If the particle stays on the same processor, the particle
     1174!--                   will be added to the particle array of the new processor.
     1175                      number_of_particles = prt_count(k,j,i)
     1176                      particles => grid_particles(k,j,i)%particles(1:number_of_particles)
     1177
     1178                      pindex = prt_count(k,j,i)+1
     1179                      IF (  pindex > SIZE(grid_particles(k,j,i)%particles)  )  &
     1180                      THEN
     1181                         n_start = n
     1182                         EXIT
     1183                      ENDIF
     1184
     1185                      grid_particles(k,j,i)%particles(pindex) = particles_old_cell(n)
     1186                      prt_count(k,j,i) = pindex
     1187
     1188                      particles_old_cell(n)%particle_mask = .FALSE.
     1189                   ENDIF
     1190                ENDIF
     1191             ENDDO
     1192
     1193             IF ( n_start .GE. 0 )  THEN
     1194                pack_done = .FALSE.
     1195                DO  n = n_start, np_old_cell
     1196                   i = ( particles_old_cell(n)%x + 0.5_wp * dx ) * ddx
     1197                   j = ( particles_old_cell(n)%y + 0.5_wp * dy ) * ddy
     1198                   k = particles_old_cell(n)%z / dz + 1 + offset_ocean_nzt
     1199                   IF ( i /= ip  .OR.  j /= jp  .OR.  k /= kp )  THEN
     1200!
     1201!--                   Particle is in different box
     1202                      IF ( i >= nxl  .AND.  i <= nxr  .AND.  j >= nys  .AND.   &
     1203                           j <= nyn  .AND.  k >= nzb+1  .AND.  k <= nzt)  THEN
     1204!
     1205!--                      Particle stays on processor
     1206                         number_of_particles = prt_count(k,j,i)
     1207                         particles => grid_particles(k,j,i)%particles(1:number_of_particles)
     1208
     1209                         pindex = prt_count(k,j,i)+1
     1210                         IF ( pindex > SIZE(grid_particles(k,j,i)%particles) ) &
     1211                         THEN
     1212                            IF ( pack_done )  THEN
     1213                               CALL realloc_particles_array(i,j,k)
     1214                               pindex = prt_count(k,j,i)+1
     1215                            ELSE
     1216                               CALL lpm_pack_arrays
     1217                               prt_count(k,j,i) = number_of_particles
     1218
     1219                               pindex = prt_count(k,j,i)+1
     1220!
     1221!--                            If number of particles in the new grid box
     1222!--                            exceeds its allocated memory, the particle array
     1223!--                            will be reallocated
     1224                               IF ( pindex > SIZE(grid_particles(k,j,i)%particles) )  THEN
     1225                                  CALL realloc_particles_array(i,j,k)
     1226                                  pindex = prt_count(k,j,i)+1
     1227                               ENDIF
     1228
     1229                               pack_done = .TRUE.
     1230                            ENDIF
     1231                         ENDIF
     1232
     1233                         grid_particles(k,j,i)%particles(pindex) = particles_old_cell(n)
     1234                         prt_count(k,j,i) = pindex
     1235
     1236                         particles_old_cell(n)%particle_mask = .FALSE.
     1237                      ENDIF
     1238                   ENDIF
     1239                ENDDO
     1240             ENDIF
     1241          ENDDO
     1242       ENDDO
     1243    ENDDO
     1244
     1245    CALL cpu_log( log_point_s(41), 'lpm_move_particle', 'stop' )
     1246
     1247    RETURN
     1248
     1249 END SUBROUTINE lpm_move_particle
     1250
     1251 SUBROUTINE realloc_particles_array (i,j,k,size_in)
     1252
     1253    IMPLICIT NONE
     1254
     1255    INTEGER(iwp), INTENT(in)                       ::  i              !:
     1256    INTEGER(iwp), INTENT(in)                       ::  j              !:
     1257    INTEGER(iwp), INTENT(in)                       ::  k              !:
     1258    INTEGER(iwp), INTENT(in), optional             ::  size_in        !:
     1259
     1260    INTEGER(iwp)                                   :: old_size        !:
     1261    INTEGER(iwp)                                   :: new_size        !:
     1262    TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: tmp_particles_d !:
     1263    TYPE(particle_type), DIMENSION(500)            :: tmp_particles_s !:
     1264
     1265
     1266    old_size = SIZE(grid_particles(k,j,i)%particles)
     1267
     1268    IF ( PRESENT(size_in) )   THEN
     1269       new_size = size_in
     1270    ELSE
     1271       new_size = old_size * ( 1.0 + alloc_factor / 100.0 )
     1272    ENDIF
     1273
     1274    new_size = MAX( new_size, min_nr_particle )
     1275
     1276    IF ( old_size <= 500 )  THEN
     1277
     1278       tmp_particles_s(1:old_size) = grid_particles(k,j,i)%particles(1:old_size)
     1279
     1280       DEALLOCATE(grid_particles(k,j,i)%particles)
     1281       ALLOCATE(grid_particles(k,j,i)%particles(new_size))
     1282
     1283       grid_particles(k,j,i)%particles(1:old_size)          = tmp_particles_s(1:old_size)
     1284       grid_particles(k,j,i)%particles(old_size+1:new_size) = zero_particle
     1285
     1286    ELSE
     1287
     1288       ALLOCATE(tmp_particles_d(new_size))
     1289       tmp_particles_d(1:old_size) = grid_particles(k,j,i)%particles
     1290
     1291       DEALLOCATE(grid_particles(k,j,i)%particles)
     1292       ALLOCATE(grid_particles(k,j,i)%particles(new_size))
     1293
     1294       grid_particles(k,j,i)%particles(1:old_size)          = tmp_particles_d(1:old_size)
     1295       grid_particles(k,j,i)%particles(old_size+1:new_size) = zero_particle
     1296
     1297       DEALLOCATE(tmp_particles_d)
     1298
     1299    ENDIF
     1300    particles => grid_particles(k,j,i)%particles(1:number_of_particles)
     1301
     1302    RETURN
     1303 END SUBROUTINE realloc_particles_array
     1304
     1305END MODULE lpm_exchange_horiz_mod

  • TabularUnified palm/trunk/SOURCE/lpm_extend_tail_array.f90

    r1321 r1359  
    2020! Current revisions:
    2121! ------------------
    22 !
     22! New particle structure integrated.
     23! Kind definition added to all floating point numbers.
    2324!
    2425! Former revisions:
    … …  
    8687    maximum_number_of_tails = new_maximum_number
    8788
    88     particle_tail_coordinates = 0.0
     89    particle_tail_coordinates = 0.0_wp
    8990    particle_tail_coordinates(:,:,1:number_of_tails) = &
    9091                                                 tmp_tail(:,:,1:number_of_tails)

  • TabularUnified palm/trunk/SOURCE/lpm_extend_tails.f90

    r1321 r1359  
    2020! Current revisions:
    2121! ------------------
    22 !
     22! New particle structure integrated.
     23! Kind definition added to all floating point numbers.
    2324!
    2425! Former revisions:
    … …  
    6465
    6566
    66     distance = 0.0
     67    distance = 0.0_wp
    6768
    6869    DO  n = 1, number_of_particles
    … …  
    7475!--       Calculate the distance between the actual particle position and the
    7576!--       next tailpoint
    76           IF ( minimum_tailpoint_distance /= 0.0 )  THEN
     77          IF ( minimum_tailpoint_distance /= 0.0_wp )  THEN
    7778             distance = ( particle_tail_coordinates(1,1,nn) -      &
    7879                          particle_tail_coordinates(2,1,nn) )**2 + &
    … …  
    109110!
    110111!--       Increase the age of the tailpoints
    111           IF ( minimum_tailpoint_distance /= 0.0 )  THEN
     112          IF ( minimum_tailpoint_distance /= 0.0_wp )  THEN
    112113             particle_tail_coordinates(2:particles(n)%tailpoints,5,nn) =    &
    113114               particle_tail_coordinates(2:particles(n)%tailpoints,5,nn) + dt_3d

  • TabularUnified palm/trunk/SOURCE/lpm_init.f90

    r1329 r1359  
    1  SUBROUTINE lpm_init
     1 MODULE lpm_init_mod
    22
    33!--------------------------------------------------------------------------------!
    … …  
    2020! Current revisions:
    2121! -----------------
    22 !
     22! New particle structure integrated.
     23! Kind definition added to all floating point numbers.
     24! lpm_init changed form a subroutine to a module.
    2325!
    2426! Former revisions:
    … …  
    8587
    8688    USE control_parameters,                                                    &
    87         ONLY:  cloud_droplets, current_timestep_number, initializing_actions,  &
    88                message_string, netcdf_data_format, ocean,                      &
    89                prandtl_layer, simulated_time
     89        ONLY:  cloud_droplets, current_timestep_number, dz,                    &
     90               initializing_actions, message_string, netcdf_data_format,       &
     91               ocean, prandtl_layer, simulated_time
    9092
    9193    USE dvrp_variables,                                                        &
    … …  
    9395
    9496    USE grid_variables,                                                        &
    95         ONLY:  dx, dy
     97        ONLY:  ddx, dx, ddy, dy
    9698
    9799    USE indices,                                                               &
    … …  
    104106
    105107    USE particle_attributes,                                                   &
    106         ONLY:   bc_par_b, bc_par_lr, bc_par_ns, bc_par_t, collision_kernel,    &
    107                 density_ratio, dvrp_psize, initial_weighting_factor, ibc_par_b,&
    108                 ibc_par_lr, ibc_par_ns, ibc_par_t, initial_particles,          &
    109                 iran_part, log_z_z0, max_number_of_particle_groups,            &
    110                 maximum_number_of_particles, maximum_number_of_tailpoints,     &
    111                 minimum_tailpoint_distance, maximum_number_of_tails,           &
    112                 mpi_particle_type, new_tail_id, number_of_initial_particles,   &
     108        ONLY:   alloc_factor, bc_par_b, bc_par_lr, bc_par_ns, bc_par_t,        &
     109                block_offset, block_offset_def, collision_kernel,              &
     110                density_ratio, dvrp_psize, grid_particles,                     &
     111                initial_weighting_factor, ibc_par_b, ibc_par_lr, ibc_par_ns,   &
     112                ibc_par_t, iran_part, log_z_z0,                                &
     113                max_number_of_particle_groups, maximum_number_of_particles,    &
     114                maximum_number_of_tailpoints, maximum_number_of_tails,         &
     115                minimum_tailpoint_distance, min_nr_particle,                   &
     116                mpi_particle_type, new_tail_id,                                &
    113117                number_of_initial_tails, number_of_particles,                  &
    114118                number_of_particle_groups, number_of_sublayers,                &
    115                 number_of_tails, offset_ocean_nzt, offset_ocean_nzt_m1, part_1,&
    116                 part_2, particles, particle_advection_start, particle_groups,  &
    117                 particle_groups_type, particle_mask, particles_per_point,      &
     119                number_of_tails, offset_ocean_nzt, offset_ocean_nzt_m1,        &
     120                particles, particle_advection_start, particle_groups,          &
     121                particle_groups_type, particles_per_point,                     &
    118122                particle_tail_coordinates,  particle_type, pdx, pdy, pdz,      &
    119                 prt_count, prt_start_index, psb, psl, psn, psr, pss, pst,      &
     123                prt_count, psb, psl, psn, psr, pss, pst,                       &
    120124                radius, random_start_position, read_particles_from_restartfile,&
    121                 skip_particles_for_tail, sort_count, tail_mask,                &
    122                 total_number_of_particles, total_number_of_tails,              &
     125                skip_particles_for_tail, sort_count,                           &
     126                tail_mask, total_number_of_particles, total_number_of_tails,   &
    123127                use_particle_tails, use_sgs_for_particles,                     &
    124                 write_particle_statistics, uniform_particles, z0_av_global
     128                write_particle_statistics, uniform_particles, zero_particle,   &
     129                z0_av_global
    125130
    126131    USE pegrid
    … …  
    129134        ONLY:  random_function
    130135
    131 
    132136    IMPLICIT NONE
    133137
     138    PRIVATE
     139
     140    INTEGER(iwp), PARAMETER         :: PHASE_INIT    = 1  !:
     141    INTEGER(iwp), PARAMETER, PUBLIC :: PHASE_RELEASE = 2  !:
     142
     143    INTERFACE lpm_init
     144       MODULE PROCEDURE lpm_init
     145    END INTERFACE lpm_init
     146
     147    INTERFACE lpm_create_particle
     148       MODULE PROCEDURE lpm_create_particle
     149    END INTERFACE lpm_create_particle
     150
     151    PUBLIC lpm_init, lpm_create_particle
     152
     153CONTAINS
     154
     155 SUBROUTINE lpm_init
     156
     157    USE lpm_collision_kernels_mod,                                             &
     158        ONLY:  init_kernels
     159
     160    IMPLICIT NONE
     161
    134162    INTEGER(iwp) ::  i                           !:
     163    INTEGER(iwp) ::  ip                          !:
    135164    INTEGER(iwp) ::  j                           !:
     165    INTEGER(iwp) ::  jp                          !:
    136166    INTEGER(iwp) ::  k                           !:
     167    INTEGER(iwp) ::  kp                          !:
    137168    INTEGER(iwp) ::  n                           !:
    138169    INTEGER(iwp) ::  nn                          !:
    … …  
    145176    LOGICAL ::  uniform_particles_l              !:
    146177
    147     REAL(wp)    ::  height_int                   !:
    148     REAL(wp)    ::  height_p                     !:
    149     REAL(wp)    ::  pos_x                        !:
    150     REAL(wp)    ::  pos_y                        !:
    151     REAL(wp)    ::  pos_z                        !:
    152     REAL(wp)    ::  z_p                          !:
    153     REAL(wp)    ::  z0_av_local = 0.0            !:
    154 
    155                
    156 
     178    REAL(wp) ::  height_int                      !:
     179    REAL(wp) ::  height_p                        !:
     180    REAL(wp) ::  z_p                             !:
     181    REAL(wp) ::  z0_av_local                     !:
    157182
    158183#if defined( __parallel )
    … …  
    160185!-- Define MPI derived datatype for FORTRAN datatype particle_type (see module
    161186!-- particle_attributes). Integer length is 4 byte, Real is 8 byte
    162     blocklengths(1)  = 19;  blocklengths(2)  =   4;  blocklengths(3)  =   1
    163     displacements(1) =  0;  displacements(2) = 152;  displacements(3) = 168
     187#if defined( __twocachelines )
     188    blocklengths(1)  =  7;  blocklengths(2)  =  18;  blocklengths(3)  =   1
     189    displacements(1) =  0;  displacements(2) =  64;  displacements(3) = 128
     190
     191    types(1) = MPI_REAL                               ! 64 bit words
     192    types(2) = MPI_INTEGER                            ! 32 Bit words
     193    types(3) = MPI_UB
     194#else
     195    blocklengths(1)  = 19;  blocklengths(2)  =   6;  blocklengths(3)  =   1
     196    displacements(1) =  0;  displacements(2) = 152;  displacements(3) = 176
    164197
    165198    types(1) = MPI_REAL
    166199    types(2) = MPI_INTEGER
    167200    types(3) = MPI_UB
     201#endif
    168202    CALL MPI_TYPE_STRUCT( 3, blocklengths, displacements, types, &
    169203                          mpi_particle_type, ierr )
    … …  
    179213    ENDIF
    180214
    181 
     215!
     216!-- Define block offsets for dividing a gridcell in 8 sub cells
     217
     218    block_offset(0) = block_offset_def (-1,-1,-1)
     219    block_offset(1) = block_offset_def (-1,-1, 0)
     220    block_offset(2) = block_offset_def (-1, 0,-1)
     221    block_offset(3) = block_offset_def (-1, 0, 0)
     222    block_offset(4) = block_offset_def ( 0,-1,-1)
     223    block_offset(5) = block_offset_def ( 0,-1, 0)
     224    block_offset(6) = block_offset_def ( 0, 0,-1)
     225    block_offset(7) = block_offset_def ( 0, 0, 0)
    182226!
    183227!-- Check the number of particle groups.
    … …  
    193237!
    194238!-- Set default start positions, if necessary
    195     IF ( psl(1) == 9999999.9 )  psl(1) = -0.5 * dx
    196     IF ( psr(1) == 9999999.9 )  psr(1) = ( nx + 0.5 ) * dx
    197     IF ( pss(1) == 9999999.9 )  pss(1) = -0.5 * dy
    198     IF ( psn(1) == 9999999.9 )  psn(1) = ( ny + 0.5 ) * dy
    199     IF ( psb(1) == 9999999.9 )  psb(1) = zu(nz/2)
    200     IF ( pst(1) == 9999999.9 )  pst(1) = psb(1)
    201 
    202     IF ( pdx(1) == 9999999.9  .OR.  pdx(1) == 0.0 )  pdx(1) = dx
    203     IF ( pdy(1) == 9999999.9  .OR.  pdy(1) == 0.0 )  pdy(1) = dy
    204     IF ( pdz(1) == 9999999.9  .OR.  pdz(1) == 0.0 )  pdz(1) = zu(2) - zu(1)
     239    IF ( psl(1) == 9999999.9_wp )  psl(1) = -0.5_wp * dx
     240    IF ( psr(1) == 9999999.9_wp )  psr(1) = ( nx + 0.5_wp ) * dx
     241    IF ( pss(1) == 9999999.9_wp )  pss(1) = -0.5_wp * dy
     242    IF ( psn(1) == 9999999.9_wp )  psn(1) = ( ny + 0.5_wp ) * dy
     243    IF ( psb(1) == 9999999.9_wp )  psb(1) = zu(nz/2)
     244    IF ( pst(1) == 9999999.9_wp )  pst(1) = psb(1)
     245
     246    IF ( pdx(1) == 9999999.9_wp  .OR.  pdx(1) == 0.0_wp )  pdx(1) = dx
     247    IF ( pdy(1) == 9999999.9_wp  .OR.  pdy(1) == 0.0_wp )  pdy(1) = dy
     248    IF ( pdz(1) == 9999999.9_wp  .OR.  pdz(1) == 0.0_wp )  pdz(1) = zu(2) - zu(1)
    205249
    206250    DO  j = 2, number_of_particle_groups
    207        IF ( psl(j) == 9999999.9 )  psl(j) = psl(j-1)
    208        IF ( psr(j) == 9999999.9 )  psr(j) = psr(j-1)
    209        IF ( pss(j) == 9999999.9 )  pss(j) = pss(j-1)
    210        IF ( psn(j) == 9999999.9 )  psn(j) = psn(j-1)
    211        IF ( psb(j) == 9999999.9 )  psb(j) = psb(j-1)
    212        IF ( pst(j) == 9999999.9 )  pst(j) = pst(j-1)
    213        IF ( pdx(j) == 9999999.9  .OR.  pdx(j) == 0.0 )  pdx(j) = pdx(j-1)
    214        IF ( pdy(j) == 9999999.9  .OR.  pdy(j) == 0.0 )  pdy(j) = pdy(j-1)
    215        IF ( pdz(j) == 9999999.9  .OR.  pdz(j) == 0.0 )  pdz(j) = pdz(j-1)
     251       IF ( psl(j) == 9999999.9_wp )  psl(j) = psl(j-1)
     252       IF ( psr(j) == 9999999.9_wp )  psr(j) = psr(j-1)
     253       IF ( pss(j) == 9999999.9_wp )  pss(j) = pss(j-1)
     254       IF ( psn(j) == 9999999.9_wp )  psn(j) = psn(j-1)
     255       IF ( psb(j) == 9999999.9_wp )  psb(j) = psb(j-1)
     256       IF ( pst(j) == 9999999.9_wp )  pst(j) = pst(j-1)
     257       IF ( pdx(j) == 9999999.9_wp  .OR.  pdx(j) == 0.0_wp )  pdx(j) = pdx(j-1)
     258       IF ( pdy(j) == 9999999.9_wp  .OR.  pdy(j) == 0.0_wp )  pdy(j) = pdy(j-1)
     259       IF ( pdz(j) == 9999999.9_wp  .OR.  pdz(j) == 0.0_wp )  pdz(j) = pdz(j-1)
    216260    ENDDO
    217261
    … …  
    243287!--    negligible.
    244288       z0_av_local  = SUM( z0(nys:nyn,nxl:nxr) )
    245        z0_av_global = 0.0
     289       z0_av_global = 0.0_wp
    246290
    247291#if defined( __parallel )
    … …  
    255299!
    256300!--    Horizontal wind speed is zero below and at z0
    257        log_z_z0(0) = 0.0   
     301       log_z_z0(0) = 0.0_wp
    258302!
    259303!--    Calculate vertical depth of the sublayers
    … …  
    261305!
    262306!--    Precalculate LOG(z/z0)
    263        height_p    = 0.0
     307       height_p    = 0.0_wp
    264308       DO  k = 1, number_of_sublayers
    265309
    … …  
    269313       ENDDO
    270314
    271 
    272     ENDIF
    273 
    274 !
    275 !-- Initialize collision kernels
    276     IF ( collision_kernel /= 'none' )  CALL init_kernels
    277 
    278 !
    279 !-- For the first model run of a possible job chain initialize the
    280 !-- particles, otherwise read the particle data from restart file.
    281     IF ( TRIM( initializing_actions ) == 'read_restart_data'  &
    282          .AND.  read_particles_from_restartfile )  THEN
    283 
    284        CALL lpm_read_restart_file
    285 
    286     ELSE
    287 
    288 !
    289 !--    Allocate particle arrays and set attributes of the initial set of
    290 !--    particles, which can be also periodically released at later times.
    291 !--    Also allocate array for particle tail coordinates, if needed.
    292        ALLOCATE( prt_count(nzb:nzt+1,nysg:nyng,nxlg:nxrg),       &
    293                  prt_start_index(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &
    294                  particle_mask(maximum_number_of_particles),     &
    295                  part_1(maximum_number_of_particles),            &
    296                  part_2(maximum_number_of_particles)  )
    297 
    298        particles => part_1
    299 
    300        sort_count = 0
    301 
    302 !
    303 !--    Initialize all particles with dummy values (otherwise errors may
    304 !--    occur within restart runs). The reason for this is still not clear
    305 !--    and may be presumably caused by errors in the respective user-interface.
    306        particles = particle_type( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, &
    307                                   0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, &
    308                                   0.0, 0, 0, 0, 0 )
    309        particle_groups = particle_groups_type( 0.0, 0.0, 0.0, 0.0 )
    310 
    311 !
    312 !--    Set the default particle size used for dvrp plots
    313        IF ( dvrp_psize == 9999999.9 )  dvrp_psize = 0.2 * dx
    314 
    315 !
    316 !--    Set values for the density ratio and radius for all particle
    317 !--    groups, if necessary
    318        IF ( density_ratio(1) == 9999999.9 )  density_ratio(1) = 0.0
    319        IF ( radius(1)        == 9999999.9 )  radius(1) = 0.0
    320        DO  i = 2, number_of_particle_groups
    321           IF ( density_ratio(i) == 9999999.9 )  THEN
    322              density_ratio(i) = density_ratio(i-1)
    323           ENDIF
    324           IF ( radius(i) == 9999999.9 )  radius(i) = radius(i-1)
    325        ENDDO
    326 
    327        DO  i = 1, number_of_particle_groups
    328           IF ( density_ratio(i) /= 0.0  .AND.  radius(i) == 0 )  THEN
    329              WRITE( message_string, * ) 'particle group #', i, 'has a', &
    330                                         'density ratio /= 0 but radius = 0'
    331              CALL message( 'lpm_init', 'PA0215', 1, 2, 0, 6, 0 )
    332           ENDIF
    333           particle_groups(i)%density_ratio = density_ratio(i)
    334           particle_groups(i)%radius        = radius(i)
    335        ENDDO
    336 
    337 !
    338 !--    Calculate particle positions and store particle attributes, if
    339 !--    particle is situated on this PE
    340        n = 0
    341 
    342        DO  i = 1, number_of_particle_groups
    343 
    344           pos_z = psb(i)
    345 
    346           DO WHILE ( pos_z <= pst(i) )
    347 
    348              pos_y = pss(i)
    349 
    350              DO WHILE ( pos_y <= psn(i) )
    351 
    352                 IF ( pos_y >= ( nys - 0.5 ) * dy  .AND.  &
    353                      pos_y <  ( nyn + 0.5 ) * dy )  THEN
    354 
    355                    pos_x = psl(i)
    356 
    357                    DO WHILE ( pos_x <= psr(i) )
    358 
    359                       IF ( pos_x >= ( nxl - 0.5 ) * dx  .AND.  &
    360                            pos_x <  ( nxr + 0.5 ) * dx )  THEN
    361 
    362                          DO  j = 1, particles_per_point
    363 
    364                             n = n + 1
    365                             IF ( n > maximum_number_of_particles )  THEN
    366                                WRITE( message_string, * ) 'number of initial', &
    367                                       'particles (', n, ') exceeds',           &
    368                                       '&maximum_number_of_particles (',        &
    369                                       maximum_number_of_particles, ') on PE ', &
    370                                              myid
    371                                CALL message( 'lpm_init', 'PA0216', 2, 2, -1, 6,&
    372                                              1 )
    373                             ENDIF
    374                             particles(n)%x             = pos_x
    375                             particles(n)%y             = pos_y
    376                             particles(n)%z             = pos_z
    377                             particles(n)%age           = 0.0
    378                             particles(n)%age_m         = 0.0
    379                             particles(n)%dt_sum        = 0.0
    380                             particles(n)%dvrp_psize    = dvrp_psize
    381                             particles(n)%e_m           = 0.0
    382                             IF ( curvature_solution_effects )  THEN
    383 !
    384 !--                            Initial values (internal timesteps, derivative)
    385 !--                            for Rosenbrock method
    386                                particles(n)%rvar1      = 1.0E-12
    387                                particles(n)%rvar2      = 1.0E-3
    388                                particles(n)%rvar3      = -9999999.9
    389                             ELSE
    390 !
    391 !--                            Initial values for SGS velocities
    392                                particles(n)%rvar1      = 0.0
    393                                particles(n)%rvar2      = 0.0
    394                                particles(n)%rvar3      = 0.0
    395                             ENDIF
    396                             particles(n)%speed_x       = 0.0
    397                             particles(n)%speed_y       = 0.0
    398                             particles(n)%speed_z       = 0.0
    399                             particles(n)%origin_x      = pos_x
    400                             particles(n)%origin_y      = pos_y
    401                             particles(n)%origin_z      = pos_z
    402                             particles(n)%radius      = particle_groups(i)%radius
    403                             particles(n)%weight_factor =initial_weighting_factor
    404                             particles(n)%class         = 1
    405                             particles(n)%group         = i
    406                             particles(n)%tailpoints    = 0
    407                             IF ( use_particle_tails  .AND. &
    408                                  MOD( n, skip_particles_for_tail ) == 0 )  THEN
    409                                number_of_tails         = number_of_tails + 1
    410 !
    411 !--                            This is a temporary provisional setting (see
    412 !--                            further below!)
    413                                particles(n)%tail_id    = number_of_tails
    414                             ELSE
    415                                particles(n)%tail_id    = 0
    416                             ENDIF
    417 
    418                          ENDDO
    419 
    420                       ENDIF
    421 
    422                       pos_x = pos_x + pdx(i)
    423 
    424                    ENDDO
    425 
    426                 ENDIF
    427 
    428                 pos_y = pos_y + pdy(i)
    429 
    430              ENDDO
    431 
    432              pos_z = pos_z + pdz(i)
    433 
    434           ENDDO
    435 
    436        ENDDO
    437 
    438        number_of_initial_particles = n
    439        number_of_particles         = n
    440 
    441 !
    442 !--    Calculate the number of particles and tails of the total domain
    443 #if defined( __parallel )
    444        IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
    445        CALL MPI_ALLREDUCE( number_of_particles, total_number_of_particles, 1, &
    446                            MPI_INTEGER, MPI_SUM, comm2d, ierr )
    447        IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
    448        CALL MPI_ALLREDUCE( number_of_tails, total_number_of_tails, 1, &
    449                            MPI_INTEGER, MPI_SUM, comm2d, ierr )
    450 #else
    451        total_number_of_particles = number_of_particles
    452        total_number_of_tails     = number_of_tails
    453 #endif
    454 
    455 !
    456 !--    Set a seed value for the random number generator to be exclusively
    457 !--    used for the particle code. The generated random numbers should be
    458 !--    different on the different PEs.
    459        iran_part = iran_part + myid
    460 
    461 !
    462 !--    User modification of initial particles
    463        CALL user_lpm_init
    464 
    465 !
    466 !--    Store the initial set of particles for release at later times
    467        IF ( number_of_initial_particles /= 0 )  THEN
    468           ALLOCATE( initial_particles(1:number_of_initial_particles) )
    469           initial_particles(1:number_of_initial_particles) = &
    470                                         particles(1:number_of_initial_particles)
    471        ENDIF
    472 
    473 !
    474 !--    Add random fluctuation to particle positions
    475        IF ( random_start_position )  THEN
    476 
    477           DO  n = 1, number_of_initial_particles
    478              IF ( psl(particles(n)%group) /= psr(particles(n)%group) )  THEN
    479                 particles(n)%x = particles(n)%x + &
    480                                  ( random_function( iran_part ) - 0.5 ) * &
    481                                  pdx(particles(n)%group)
    482                 IF ( particles(n)%x  <=  ( nxl - 0.5 ) * dx )  THEN
    483                    particles(n)%x = ( nxl - 0.4999999999 ) * dx
    484                 ELSEIF ( particles(n)%x  >=  ( nxr + 0.5 ) * dx )  THEN
    485                    particles(n)%x = ( nxr + 0.4999999999 ) * dx
    486                 ENDIF
    487              ENDIF
    488              IF ( pss(particles(n)%group) /= psn(particles(n)%group) )  THEN
    489                 particles(n)%y = particles(n)%y + &
    490                                  ( random_function( iran_part ) - 0.5 ) * &
    491                                  pdy(particles(n)%group)
    492                 IF ( particles(n)%y  <=  ( nys - 0.5 ) * dy )  THEN
    493                    particles(n)%y = ( nys - 0.4999999999 ) * dy
    494                 ELSEIF ( particles(n)%y  >=  ( nyn + 0.5 ) * dy )  THEN
    495                    particles(n)%y = ( nyn + 0.4999999999 ) * dy
    496                 ENDIF
    497              ENDIF
    498              IF ( psb(particles(n)%group) /= pst(particles(n)%group) )  THEN
    499                 particles(n)%z = particles(n)%z + &
    500                                  ( random_function( iran_part ) - 0.5 ) * &
    501                                  pdz(particles(n)%group)
    502              ENDIF
    503           ENDDO
    504        ENDIF
    505 
    506 !
    507 !--    Sort particles in the sequence the gridboxes are stored in the memory.
    508 !--    Only required if cloud droplets are used.
    509        IF ( cloud_droplets )  CALL lpm_sort_arrays
    510 
    511 !
    512 !--    Open file for statistical informations about particle conditions
    513        IF ( write_particle_statistics )  THEN
    514           CALL check_open( 80 )
    515           WRITE ( 80, 8000 )  current_timestep_number, simulated_time, &
    516                               number_of_initial_particles,             &
    517                               maximum_number_of_particles
    518           CALL close_file( 80 )
    519        ENDIF
    520 
    521 !
    522 !--    Check if particles are really uniform in color and radius (dvrp_size)
    523 !--    (uniform_particles is preset TRUE)
    524        IF ( uniform_particles )  THEN
    525           IF ( number_of_initial_particles == 0 )  THEN
    526              uniform_particles_l = .TRUE.
    527           ELSE
    528              n = number_of_initial_particles
    529              IF ( MINVAL( particles(1:n)%dvrp_psize  ) ==     &
    530                   MAXVAL( particles(1:n)%dvrp_psize  )  .AND. &
    531                   MINVAL( particles(1:n)%class ) ==     &
    532                   MAXVAL( particles(1:n)%class ) )  THEN
    533                 uniform_particles_l = .TRUE.
    534              ELSE
    535                 uniform_particles_l = .FALSE.
    536              ENDIF
    537           ENDIF
    538 
    539 #if defined( __parallel )
    540           IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
    541           CALL MPI_ALLREDUCE( uniform_particles_l, uniform_particles, 1, &
    542                               MPI_LOGICAL, MPI_LAND, comm2d, ierr )
    543 #else
    544           uniform_particles = uniform_particles_l
    545 #endif
    546 
    547        ENDIF
    548 
    549 !
    550 !--    Particles will probably become none-uniform, if their size and color
    551 !--    will be determined by flow variables
    552        IF ( particle_color /= 'none'  .OR.  particle_dvrpsize /= 'none' )  THEN
    553           uniform_particles = .FALSE.
    554        ENDIF
    555 
    556 !
    557 !--    Set the beginning of the particle tails and their age
    558        IF ( use_particle_tails )  THEN
    559 !
    560 !--       Choose the maximum number of tails with respect to the maximum number
    561 !--       of particles and skip_particles_for_tail
    562           maximum_number_of_tails = maximum_number_of_particles / &
    563                                     skip_particles_for_tail
    564 
    565 !
    566 !--       Create a minimum number of tails in case that there is no tail
    567 !--       initially (otherwise, index errors will occur when adressing the
    568 !--       arrays below)
    569           IF ( maximum_number_of_tails == 0 )  maximum_number_of_tails = 10
    570 
    571           ALLOCATE( particle_tail_coordinates(maximum_number_of_tailpoints,5, &
    572                     maximum_number_of_tails),                                 &
    573                     new_tail_id(maximum_number_of_tails),                     &
    574                     tail_mask(maximum_number_of_tails) )
    575 
    576           particle_tail_coordinates  = 0.0
    577           minimum_tailpoint_distance = minimum_tailpoint_distance**2
    578           number_of_initial_tails    = number_of_tails
    579 
    580           nn = 0
    581           DO  n = 1, number_of_particles
    582 !
    583 !--          Only for those particles marked above with a provisional tail_id
    584 !--          tails will be created. Particles now get their final tail_id.
    585              IF ( particles(n)%tail_id /= 0 )  THEN
    586 
    587                 nn = nn + 1
    588                 particles(n)%tail_id = nn
    589 
    590                 particle_tail_coordinates(1,1,nn) = particles(n)%x
    591                 particle_tail_coordinates(1,2,nn) = particles(n)%y
    592                 particle_tail_coordinates(1,3,nn) = particles(n)%z
    593                 particle_tail_coordinates(1,4,nn) = particles(n)%class
    594                 particles(n)%tailpoints = 1
    595                 IF ( minimum_tailpoint_distance /= 0.0 )  THEN
    596                    particle_tail_coordinates(2,1,nn) = particles(n)%x
    597                    particle_tail_coordinates(2,2,nn) = particles(n)%y
    598                    particle_tail_coordinates(2,3,nn) = particles(n)%z
    599                    particle_tail_coordinates(2,4,nn) = particles(n)%class
    600                    particle_tail_coordinates(1:2,5,nn) = 0.0
    601                    particles(n)%tailpoints = 2
    602                 ENDIF
    603 
    604              ENDIF
    605           ENDDO
    606        ENDIF
    607 
    608 !
    609 !--    Plot initial positions of particles (only if particle advection is
    610 !--    switched on from the beginning of the simulation (t=0))
    611        IF ( particle_advection_start == 0.0 )  CALL data_output_dvrp
    612315
    613316    ENDIF
    … …  
    677380         
    678381    END SELECT
     382
     383!
     384!-- Initialize collision kernels
     385    IF ( collision_kernel /= 'none' )  CALL init_kernels
     386
     387!
     388!-- For the first model run of a possible job chain initialize the
     389!-- particles, otherwise read the particle data from restart file.
     390    IF ( TRIM( initializing_actions ) == 'read_restart_data'  &
     391         .AND.  read_particles_from_restartfile )  THEN
     392
     393       CALL lpm_read_restart_file
     394
     395    ELSE
     396
     397!
     398!--    Allocate particle arrays and set attributes of the initial set of
     399!--    particles, which can be also periodically released at later times.
     400!--    Also allocate array for particle tail coordinates, if needed.
     401       ALLOCATE( prt_count(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &
     402                 grid_particles(nzb+1:nzt,nys:nyn,nxl:nxr) )
     403
     404       maximum_number_of_particles = 0
     405       number_of_particles         = 0
     406
     407       sort_count = 0
     408       prt_count  = 0
     409
     410!
     411!--    Initialize all particles with dummy values (otherwise errors may
     412!--    occur within restart runs). The reason for this is still not clear
     413!--    and may be presumably caused by errors in the respective user-interface.
     414#if defined( __twocachelines )
     415       zero_particle = particle_type( 0.0_wp, 0.0_sp, 0.0_sp, 0.0_sp, 0.0_sp,  &
     416                                      0.0_sp, 0.0_sp, 0.0_wp, 0.0_wp, 0.0_wp,  &
     417                                      0, .FALSE., 0.0_wp, 0.0_wp, 0.0_wp,      &
     418                                      0.0_sp, 0.0_sp, 0.0_sp, 0.0_sp, 0.0_sp,  &
     419                                      0.0_sp, 0, 0, 0, -1)
     420#else
     421       zero_particle = particle_type( 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp,  &
     422                                      0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp,  &
     423                                      0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp,  &
     424                                      0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 0, 0, 0, &
     425                                      0, .FALSE., -1)
     426#endif
     427       particle_groups = particle_groups_type( 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp )
     428
     429!
     430!--    Set the default particle size used for dvrp plots
     431       IF ( dvrp_psize == 9999999.9_wp )  dvrp_psize = 0.2_wp * dx
     432
     433!
     434!--    Set values for the density ratio and radius for all particle
     435!--    groups, if necessary
     436       IF ( density_ratio(1) == 9999999.9_wp )  density_ratio(1) = 0.0_wp
     437       IF ( radius(1)        == 9999999.9_wp )  radius(1) = 0.0_wp
     438       DO  i = 2, number_of_particle_groups
     439          IF ( density_ratio(i) == 9999999.9_wp )  THEN
     440             density_ratio(i) = density_ratio(i-1)
     441          ENDIF
     442          IF ( radius(i) == 9999999.9_wp )  radius(i) = radius(i-1)
     443       ENDDO
     444
     445       DO  i = 1, number_of_particle_groups
     446          IF ( density_ratio(i) /= 0.0_wp  .AND.  radius(i) == 0 )  THEN
     447             WRITE( message_string, * ) 'particle group #', i, 'has a', &
     448                                        'density ratio /= 0 but radius = 0'
     449             CALL message( 'lpm_init', 'PA0215', 1, 2, 0, 6, 0 )
     450          ENDIF
     451          particle_groups(i)%density_ratio = density_ratio(i)
     452          particle_groups(i)%radius        = radius(i)
     453       ENDDO
     454
     455       CALL lpm_create_particle (PHASE_INIT)
     456!
     457!--    Set a seed value for the random number generator to be exclusively
     458!--    used for the particle code. The generated random numbers should be
     459!--    different on the different PEs.
     460       iran_part = iran_part + myid
     461
     462!
     463!--    User modification of initial particles
     464       CALL user_lpm_init
     465
     466!
     467!--    Open file for statistical informations about particle conditions
     468       IF ( write_particle_statistics )  THEN
     469          CALL check_open( 80 )
     470          WRITE ( 80, 8000 )  current_timestep_number, simulated_time,         &
     471                              number_of_particles,                             &
     472                              maximum_number_of_particles
     473          CALL close_file( 80 )
     474       ENDIF
     475
     476!
     477!--    Check if particles are really uniform in color and radius (dvrp_size)
     478!--    (uniform_particles is preset TRUE)
     479       IF ( uniform_particles )  THEN
     480          DO  ip = nxl, nxr
     481             DO  jp = nys, nyn
     482                DO  kp = nzb+1, nzt
     483
     484                   n = prt_count(kp,jp,ip)
     485                   IF ( MINVAL( grid_particles(kp,jp,ip)%particles(1:n)%dvrp_psize  ) ==     &
     486                        MAXVAL( grid_particles(kp,jp,ip)%particles(1:n)%dvrp_psize  )  .AND. &
     487                        MINVAL( grid_particles(kp,jp,ip)%particles(1:n)%class ) ==           &
     488                        MAXVAL( grid_particles(kp,jp,ip)%particles(1:n)%class ) )  THEN
     489                      uniform_particles_l = .TRUE.
     490                   ELSE
     491                      uniform_particles_l = .FALSE.
     492                   ENDIF
     493
     494                ENDDO
     495             ENDDO
     496          ENDDO
     497
     498#if defined( __parallel )
     499          IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
     500          CALL MPI_ALLREDUCE( uniform_particles_l, uniform_particles, 1,       &
     501                              MPI_LOGICAL, MPI_LAND, comm2d, ierr )
     502#else
     503          uniform_particles = uniform_particles_l
     504#endif
     505
     506       ENDIF
     507
     508!
     509!--    Particles will probably become none-uniform, if their size and color
     510!--    will be determined by flow variables
     511       IF ( particle_color /= 'none'  .OR.  particle_dvrpsize /= 'none' )  THEN
     512          uniform_particles = .FALSE.
     513       ENDIF
     514
     515! !kk    Not implemented aft individual particle array fort every gridcell
     516! !
     517! !--    Set the beginning of the particle tails and their age
     518!        IF ( use_particle_tails )  THEN
     519! !
     520! !--       Choose the maximum number of tails with respect to the maximum number
     521! !--       of particles and skip_particles_for_tail
     522!           maximum_number_of_tails = maximum_number_of_particles / &
     523!                                     skip_particles_for_tail
     524!
     525! !
     526! !--       Create a minimum number of tails in case that there is no tail
     527! !--       initially (otherwise, index errors will occur when adressing the
     528! !--       arrays below)
     529!           IF ( maximum_number_of_tails == 0 )  maximum_number_of_tails = 10
     530!
     531!           ALLOCATE( particle_tail_coordinates(maximum_number_of_tailpoints,5, &
     532!                     maximum_number_of_tails),                                 &
     533!                     new_tail_id(maximum_number_of_tails),                     &
     534!                     tail_mask(maximum_number_of_tails) )
     535!
     536!           particle_tail_coordinates  = 0.0_wp
     537!           minimum_tailpoint_distance = minimum_tailpoint_distance**2
     538!           number_of_initial_tails    = number_of_tails
     539!
     540!           nn = 0
     541!           DO  n = 1, number_of_particles
     542! !
     543! !--          Only for those particles marked above with a provisional tail_id
     544! !--          tails will be created. Particles now get their final tail_id.
     545!              IF ( particles(n)%tail_id /= 0 )  THEN
     546!
     547!                 nn = nn + 1
     548!                 particles(n)%tail_id = nn
     549!
     550!                 particle_tail_coordinates(1,1,nn) = particles(n)%x
     551!                 particle_tail_coordinates(1,2,nn) = particles(n)%y
     552!                 particle_tail_coordinates(1,3,nn) = particles(n)%z
     553!                 particle_tail_coordinates(1,4,nn) = particles(n)%class
     554!                 particles(n)%tailpoints = 1
     555!                 IF ( minimum_tailpoint_distance /= 0.0_wp )  THEN
     556!                    particle_tail_coordinates(2,1,nn) = particles(n)%x
     557!                    particle_tail_coordinates(2,2,nn) = particles(n)%y
     558!                    particle_tail_coordinates(2,3,nn) = particles(n)%z
     559!                    particle_tail_coordinates(2,4,nn) = particles(n)%class
     560!                    particle_tail_coordinates(1:2,5,nn) = 0.0_wp
     561!                    particles(n)%tailpoints = 2
     562!                 ENDIF
     563!
     564!              ENDIF
     565!           ENDDO
     566!        ENDIF
     567!
     568! !
     569! !--    Plot initial positions of particles (only if particle advection is
     570! !--    switched on from the beginning of the simulation (t=0))
     571!        IF ( particle_advection_start == 0.0_wp )  CALL data_output_dvrp
     572
     573    ENDIF
     574
     575!
     576!-- To avoid programm abort, assign particles array to the local version of
     577!-- first grid cell
     578    number_of_particles = prt_count(nzb+1,nys,nxl)
     579    particles => grid_particles(nzb+1,nys,nxl)%particles(1:number_of_particles)
     580
    679581!
    680582!-- Formats
    681 8000 FORMAT (I6,1X,F7.2,4X,I6,71X,I6)
     5838000 FORMAT (I6,1X,F7.2,4X,I10,71X,I10)
    682584
    683585 END SUBROUTINE lpm_init
     586
     587 SUBROUTINE lpm_create_particle (phase)
     588
     589    USE lpm_exchange_horiz_mod,                                                &
     590        ONLY: lpm_exchange_horiz, lpm_move_particle, realloc_particles_array
     591
     592    USE lpm_pack_arrays_mod,                                                   &
     593        ONLY: lpm_pack_all_arrays
     594
     595    IMPLICIT  NONE
     596
     597    INTEGER(iwp)               ::  alloc_size  !:
     598    INTEGER(iwp)               ::  i           !:
     599    INTEGER(iwp)               ::  ip          !:
     600    INTEGER(iwp)               ::  j           !:
     601    INTEGER(iwp)               ::  jp          !:
     602    INTEGER(iwp)               ::  kp          !:
     603    INTEGER(iwp)               ::  loop_stride !:
     604    INTEGER(iwp)               ::  n           !:
     605    INTEGER(iwp)               ::  new_size    !:
     606    INTEGER(iwp)               ::  nn          !:
     607
     608    INTEGER(iwp), INTENT(IN)   ::  phase       !:
     609
     610    INTEGER(iwp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  local_count !:
     611    INTEGER(iwp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  local_start !:
     612
     613    LOGICAL                    ::  first_stride !:
     614
     615    REAL(wp)                   ::  pos_x !:
     616    REAL(wp)                   ::  pos_y !:
     617    REAL(wp)                   ::  pos_z !:
     618
     619    TYPE(particle_type),TARGET ::  tmp_particle !:
     620
     621!
     622!-- Calculate particle positions and store particle attributes, if
     623!-- particle is situated on this PE
     624    DO  loop_stride = 1, 2
     625       first_stride = (loop_stride == 1)
     626       IF ( first_stride )   THEN
     627          local_count = 0           ! count number of particles
     628       ELSE
     629          local_count = prt_count   ! Start address of new particles
     630       ENDIF
     631
     632       n = 0
     633       DO  i = 1, number_of_particle_groups
     634
     635          pos_z = psb(i)
     636
     637          DO WHILE ( pos_z <= pst(i) )
     638
     639             pos_y = pss(i)
     640
     641             DO WHILE ( pos_y <= psn(i) )
     642
     643                IF ( pos_y >= ( nys - 0.5_wp ) * dy  .AND.  &
     644                     pos_y <  ( nyn + 0.5_wp ) * dy )  THEN
     645
     646                   pos_x = psl(i)
     647
     648                   DO WHILE ( pos_x <= psr(i) )
     649
     650                      IF ( pos_x >= ( nxl - 0.5_wp ) * dx  .AND.  &
     651                           pos_x <  ( nxr + 0.5_wp ) * dx )  THEN
     652
     653                         DO  j = 1, particles_per_point
     654
     655                            n = n + 1
     656#if defined( __twocachelines )
     657                            tmp_particle%x             = pos_x
     658                            tmp_particle%y             = pos_y
     659                            tmp_particle%z             = pos_z
     660                            tmp_particle%age           = 0.0_sp
     661                            tmp_particle%age_m         = 0.0_sp
     662                            tmp_particle%dt_sum        = 0.0_wp
     663                            tmp_particle%dvrp_psize    = dvrp_psize
     664                            tmp_particle%e_m           = 0.0_sp
     665                            IF ( curvature_solution_effects )  THEN
     666!
     667!--                            Initial values (internal timesteps, derivative)
     668!--                            for Rosenbrock method
     669                               tmp_particle%rvar1      = 1.0E-12_wp
     670                               tmp_particle%rvar2      = 1.0E-3_wp
     671                               tmp_particle%rvar3      = -9999999.9_wp
     672                            ELSE
     673!
     674!--                            Initial values for SGS velocities
     675                               tmp_particle%rvar1      = 0.0_wp
     676                               tmp_particle%rvar2      = 0.0_wp
     677                               tmp_particle%rvar3      = 0.0_wp
     678                            ENDIF
     679                            tmp_particle%speed_x       = 0.0_sp
     680                            tmp_particle%speed_y       = 0.0_sp
     681                            tmp_particle%speed_z       = 0.0_sp
     682                            tmp_particle%origin_x      = pos_x
     683                            tmp_particle%origin_y      = pos_y
     684                            tmp_particle%origin_z      = pos_z
     685                            tmp_particle%radius        = particle_groups(i)%radius
     686                            tmp_particle%weight_factor = initial_weighting_factor
     687                            tmp_particle%class         = 1
     688                            tmp_particle%group         = i
     689                            tmp_particle%tailpoints    = 0
     690                            tmp_particle%particle_mask = .TRUE.
     691#else
     692                            tmp_particle%x             = pos_x
     693                            tmp_particle%y             = pos_y
     694                            tmp_particle%z             = pos_z
     695                            tmp_particle%age           = 0.0_wp
     696                            tmp_particle%age_m         = 0.0_wp
     697                            tmp_particle%dt_sum        = 0.0_wp
     698                            tmp_particle%dvrp_psize    = dvrp_psize
     699                            tmp_particle%e_m           = 0.0_wp
     700                            IF ( curvature_solution_effects )  THEN
     701!
     702!--                            Initial values (internal timesteps, derivative)
     703!--                            for Rosenbrock method
     704                               tmp_particle%rvar1      = 1.0E-12_wp
     705                               tmp_particle%rvar2      = 1.0E-3_wp
     706                               tmp_particle%rvar3      = -9999999.9_wp
     707                            ELSE
     708!
     709!--                            Initial values for SGS velocities
     710                               tmp_particle%rvar1      = 0.0_wp
     711                               tmp_particle%rvar2      = 0.0_wp
     712                               tmp_particle%rvar3      = 0.0_wp
     713                            ENDIF
     714                            tmp_particle%speed_x       = 0.0_wp
     715                            tmp_particle%speed_y       = 0.0_wp
     716                            tmp_particle%speed_z       = 0.0_wp
     717                            tmp_particle%origin_x      = pos_x
     718                            tmp_particle%origin_y      = pos_y
     719                            tmp_particle%origin_z      = pos_z
     720                            tmp_particle%radius        = particle_groups(i)%radius
     721                            tmp_particle%weight_factor = initial_weighting_factor
     722                            tmp_particle%class         = 1
     723                            tmp_particle%group         = i
     724                            tmp_particle%tailpoints    = 0
     725                            tmp_particle%particle_mask = .TRUE.
     726#endif
     727                            IF ( use_particle_tails  .AND. &
     728                                 MOD( n, skip_particles_for_tail ) == 0 )  THEN
     729                               number_of_tails         = number_of_tails + 1
     730!
     731!--                            This is a temporary provisional setting (see
     732!--                            further below!)
     733                               tmp_particle%tail_id    = number_of_tails
     734                            ELSE
     735                               tmp_particle%tail_id    = 0
     736                            ENDIF
     737                            ip = ( tmp_particle%x + 0.5_wp * dx ) * ddx
     738                            jp = ( tmp_particle%y + 0.5_wp * dy ) * ddy
     739                            kp = tmp_particle%z / dz + 1 + offset_ocean_nzt_m1
     740
     741                            local_count(kp,jp,ip) = local_count(kp,jp,ip) + 1
     742                            IF ( .NOT. first_stride )  THEN
     743                               IF ( ip < nxl  .OR.  jp < nys  .OR.  kp < nzb+1 )  THEN
     744                                  write(6,*) 'xl ',ip,jp,kp,nxl,nys,nzb+1
     745                               ENDIF
     746                               IF ( ip > nxr  .OR.  jp > nyn  .OR.  kp > nzt )  THEN
     747                                  write(6,*) 'xu ',ip,jp,kp,nxr,nyn,nzt
     748                               ENDIF
     749                               grid_particles(kp,jp,ip)%particles(local_count(kp,jp,ip)) = tmp_particle
     750                            ENDIF
     751                         ENDDO
     752
     753                      ENDIF
     754
     755                      pos_x = pos_x + pdx(i)
     756
     757                   ENDDO
     758
     759                ENDIF
     760
     761                pos_y = pos_y + pdy(i)
     762
     763             ENDDO
     764
     765             pos_z = pos_z + pdz(i)
     766
     767          ENDDO
     768
     769       ENDDO
     770
     771       IF ( first_stride )  THEN
     772          DO  ip = nxl, nxr
     773             DO  jp = nys, nyn
     774                DO  kp = nzb+1, nzt
     775                   IF ( phase == PHASE_INIT )  THEN
     776                      IF ( local_count(kp,jp,ip) > 0 )  THEN
     777                         alloc_size = MAX( INT( local_count(kp,jp,ip) *        &
     778                            ( 1.0_wp + alloc_factor / 100.0_wp ) ),            &
     779                            min_nr_particle )
     780                      ELSE
     781                         alloc_size = min_nr_particle
     782                      ENDIF
     783                      ALLOCATE(grid_particles(kp,jp,ip)%particles(1:alloc_size))
     784                      DO  n = 1, alloc_size
     785                         grid_particles(kp,jp,ip)%particles(n) = zero_particle
     786                      ENDDO
     787                   ELSEIF ( phase == PHASE_RELEASE )  THEN
     788                      IF ( local_count(kp,jp,ip) > 0 )  THEN
     789                         new_size   = local_count(kp,jp,ip) + prt_count(kp,jp,ip)
     790                         alloc_size = MAX( INT( new_size * ( 1.0_wp +          &
     791                            alloc_factor / 100.0_wp ) ), min_nr_particle )
     792                         IF( alloc_size > SIZE( grid_particles(kp,jp,ip)%particles) )  THEN
     793                           CALL realloc_particles_array(ip,jp,kp,alloc_size)
     794                         ENDIF
     795                      ENDIF
     796                   ENDIF
     797                ENDDO
     798             ENDDO
     799          ENDDO
     800       ENDIF
     801    ENDDO
     802
     803    local_start = prt_count+1
     804    prt_count   = local_count
     805!
     806!-- Add random fluctuation to particle positions
     807    IF ( random_start_position )  THEN
     808       DO  ip = nxl, nxr
     809          DO  jp = nys, nyn
     810             DO  kp = nzb+1, nzt
     811                number_of_particles = prt_count(kp,jp,ip)
     812                IF ( number_of_particles <= 0 )  CYCLE
     813                particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
     814
     815                DO  n = local_start(kp,jp,ip), number_of_particles              !Move only new particles
     816                   IF ( psl(particles(n)%group) /= psr(particles(n)%group) )  THEN
     817                      particles(n)%x = particles(n)%x +                        &
     818                                   ( random_function( iran_part ) - 0.5_wp ) * &
     819                                   pdx(particles(n)%group)
     820                   ENDIF
     821                   IF ( pss(particles(n)%group) /= psn(particles(n)%group) )  THEN
     822                      particles(n)%y = particles(n)%y +                        &
     823                                   ( random_function( iran_part ) - 0.5_wp ) * &
     824                                   pdy(particles(n)%group)
     825                   ENDIF
     826                   IF ( psb(particles(n)%group) /= pst(particles(n)%group) )  THEN
     827                      particles(n)%z = particles(n)%z +                        &
     828                                   ( random_function( iran_part ) - 0.5_wp ) * &
     829                                   pdz(particles(n)%group)
     830                   ENDIF
     831                ENDDO
     832!
     833!--             Identify particles located outside the model domain
     834                CALL lpm_boundary_conds( 'bottom/top' )
     835             ENDDO
     836          ENDDO
     837       ENDDO
     838!
     839!--    Exchange particles between grid cells and processors
     840       CALL lpm_move_particle
     841       CALL lpm_exchange_horiz
     842
     843    ENDIF
     844!
     845!-- In case of random_start_position, delete particles identified by
     846!-- lpm_exchange_horiz and lpm_boundary_conds. Then sort particles into blocks,
     847!-- which is needed for a fast interpolation of the LES fields on the particle
     848!-- position.
     849    CALL lpm_pack_all_arrays
     850
     851!
     852!-- Determine maximum number of particles (i.e., all possible particles that
     853!-- have been allocated) and the current number of particles
     854    DO  ip = nxl, nxr
     855       DO  jp = nys, nyn
     856          DO  kp = nzb+1, nzt
     857             maximum_number_of_particles = maximum_number_of_particles         &
     858                                           + SIZE(grid_particles(kp,jp,ip)%particles)
     859             number_of_particles         = number_of_particles                 &
     860                                           + prt_count(kp,jp,ip)
     861          ENDDO
     862       ENDDO
     863    ENDDO
     864!
     865!-- Calculate the number of particles and tails of the total domain
     866#if defined( __parallel )
     867    IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
     868    CALL MPI_ALLREDUCE( number_of_particles, total_number_of_particles, 1, &
     869    MPI_INTEGER, MPI_SUM, comm2d, ierr )
     870    IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
     871    CALL MPI_ALLREDUCE( number_of_tails, total_number_of_tails, 1, &
     872    MPI_INTEGER, MPI_SUM, comm2d, ierr )
     873#else
     874    total_number_of_particles = number_of_particles
     875    total_number_of_tails     = number_of_tails
     876#endif
     877
     878    RETURN
     879
     880 END SUBROUTINE lpm_create_particle
     881
     882END MODULE lpm_init_mod

  • TabularUnified palm/trunk/SOURCE/lpm_init_sgs_tke.f90

    r1321 r1359  
    2020! Current revisions:
    2121! ------------------
    22 !
     22! New particle structure integrated.
     23! Kind definition added to all floating point numbers.
    2324!
    2425! Former revisions:
    … …  
    8485                  k  > nzb_s_inner(j,i+1) )                                    &
    8586             THEN
    86                 de_dx(k,j,i) = 2.0 * sgs_wfu_part * ( e(k,j,i+1) - e(k,j,i) )  &
    87                                * ddx
     87                de_dx(k,j,i) = 2.0_wp * sgs_wfu_part *                         &
     88                               ( e(k,j,i+1) - e(k,j,i) ) * ddx
    8889             ELSEIF ( k  > nzb_s_inner(j,i-1)  .AND.  k > nzb_s_inner(j,i)     &
    8990                      .AND.  k <= nzb_s_inner(j,i+1) )                         &
    9091             THEN
    91                 de_dx(k,j,i) = 2.0 * sgs_wfu_part * ( e(k,j,i) - e(k,j,i-1) )  &
    92                                * ddx
     92                de_dx(k,j,i) = 2.0_wp * sgs_wfu_part *                         &
     93                               ( e(k,j,i) - e(k,j,i-1) ) * ddx
    9394             ELSEIF ( k < nzb_s_inner(j,i)  .AND.  k < nzb_s_inner(j,i+1) )    &
    9495             THEN
    95                 de_dx(k,j,i) = 0.0
     96                de_dx(k,j,i) = 0.0_wp
    9697             ELSEIF ( k < nzb_s_inner(j,i-1)  .AND.  k < nzb_s_inner(j,i) )    &
    9798             THEN
    98                 de_dx(k,j,i) = 0.0
     99                de_dx(k,j,i) = 0.0_wp
    99100             ELSE
    100101                de_dx(k,j,i) = sgs_wfu_part * ( e(k,j,i+1) - e(k,j,i-1) ) * ddx
    … …  
    104105                  k  > nzb_s_inner(j+1,i) )                                    &
    105106             THEN
    106                 de_dy(k,j,i) = 2.0 * sgs_wfv_part * ( e(k,j+1,i) - e(k,j,i) )  &
    107                                * ddy
     107                de_dy(k,j,i) = 2.0_wp * sgs_wfv_part *                         &
     108                               ( e(k,j+1,i) - e(k,j,i) ) * ddy
    108109             ELSEIF ( k  > nzb_s_inner(j-1,i)  .AND.  k  > nzb_s_inner(j,i)    &
    109110                      .AND.  k <= nzb_s_inner(j+1,i) )                         &
    110111             THEN
    111                 de_dy(k,j,i) = 2.0 * sgs_wfv_part * ( e(k,j,i) - e(k,j-1,i) )  &
    112                                * ddy
     112                de_dy(k,j,i) = 2.0_wp * sgs_wfv_part *                         &
     113                               ( e(k,j,i) - e(k,j-1,i) ) * ddy
    113114             ELSEIF ( k < nzb_s_inner(j,i)  .AND.  k < nzb_s_inner(j+1,i) )    &
    114115             THEN
    115                 de_dy(k,j,i) = 0.0
     116                de_dy(k,j,i) = 0.0_wp
    116117             ELSEIF ( k < nzb_s_inner(j-1,i)  .AND.  k < nzb_s_inner(j,i) )    &
    117118             THEN
    118                 de_dy(k,j,i) = 0.0
     119                de_dy(k,j,i) = 0.0_wp
    119120             ELSE
    120121                de_dy(k,j,i) = sgs_wfv_part * ( e(k,j+1,i) - e(k,j-1,i) ) * ddy
    … …  
    131132
    132133          DO  k = nzb_s_inner(j,i)+2, nzt-1
    133              de_dz(k,j,i)  = 2.0 * sgs_wfw_part * &
     134             de_dz(k,j,i)  = 2.0_wp * sgs_wfw_part *                          &
    134135                             ( e(k+1,j,i) - e(k-1,j,i) ) / ( zu(k+1)-zu(k-1) )
    135136          ENDDO
    136137
    137138          k = nzb_s_inner(j,i)
    138           de_dz(nzb:k,j,i) = 0.0
    139           de_dz(k+1,j,i)   = 2.0 * sgs_wfw_part * ( e(k+2,j,i) - e(k+1,j,i) ) &
    140                                                / ( zu(k+2) - zu(k+1) )
    141           de_dz(nzt,j,i)   = 0.0
    142           de_dz(nzt+1,j,i) = 0.0
     139          de_dz(nzb:k,j,i) = 0.0_wp
     140          de_dz(k+1,j,i)   = 2.0_wp * sgs_wfw_part *                          &
     141                             ( e(k+2,j,i) - e(k+1,j,i) ) / ( zu(k+2) - zu(k+1) )
     142          de_dz(nzt,j,i)   = 0.0_wp
     143          de_dz(nzt+1,j,i) = 0.0_wp
    143144       ENDDO
    144145    ENDDO
    … …  
    162163!--    First calculate horizontally averaged profiles of the horizontal
    163164!--    velocities.
    164        sums_l(:,1,0) = 0.0
    165        sums_l(:,2,0) = 0.0
     165       sums_l(:,1,0) = 0.0_wp
     166       sums_l(:,2,0) = 0.0_wp
    166167
    167168       DO  i = nxl, nxr
    … …  
    197198!--    Now calculate the profiles of SGS TKE and the resolved-scale
    198199!--    velocity variances
    199        sums_l(:,8,0)  = 0.0
    200        sums_l(:,30,0) = 0.0
    201        sums_l(:,31,0) = 0.0
    202        sums_l(:,32,0) = 0.0
     200       sums_l(:,8,0)  = 0.0_wp
     201       sums_l(:,30,0) = 0.0_wp
     202       sums_l(:,31,0) = 0.0_wp
     203       sums_l(:,32,0) = 0.0_wp
    203204       DO  i = nxl, nxr
    204205          DO  j = nys, nyn

  • TabularUnified palm/trunk/SOURCE/lpm_pack_arrays.f90

    r1321 r1359  
    1  SUBROUTINE lpm_pack_arrays
     1 MODULE lpm_pack_arrays_mod
    22
    33!--------------------------------------------------------------------------------!
    … …  
    2020! Current revisions:
    2121! ------------------
    22 !
     22! New particle structure integrated.
     23! Kind definition added to all floating point numbers.
    2324!
    2425! Former revisions:
    … …  
    4748!------------------------------------------------------------------------------!
    4849
    49     USE kinds
    50 
    5150    USE particle_attributes,                                                   &
    52         ONLY:  deleted_particles, deleted_tails, new_tail_id,                  &
    53                number_of_particles, number_of_tails, particles, particle_mask, &
     51        ONLY:  deleted_tails, grid_particles, new_tail_id,                     &
     52               number_of_particles, number_of_tails, offset_ocean_nzt,         &
     53               offset_ocean_nzt_m1, particles, particle_type, prt_count,       &
    5454               particle_tail_coordinates, tail_mask, use_particle_tails
    5555
    56 
    57     IMPLICIT NONE
    58 
    59     INTEGER(iwp) ::  n       !:
    60     INTEGER(iwp) ::  nd      !:
    61     INTEGER(iwp) ::  nn      !:
    62 !
    63 !-- Find out elements marked for deletion and move data with higher index
    64 !-- values to these free indices
    65     nn = 0
    66     nd = 0
    67 
    68     DO  n = 1, number_of_particles
    69 
    70        IF ( particle_mask(n) )  THEN
    71           nn = nn + 1
    72           particles(nn) = particles(n)
    73        ELSE
    74           nd = nd + 1
     56    PRIVATE
     57    PUBLIC lpm_pack_all_arrays, lpm_pack_arrays
     58
     59    INTERFACE lpm_pack_all_arrays
     60       MODULE PROCEDURE lpm_pack_all_arrays
     61    END INTERFACE lpm_pack_all_arrays
     62
     63    INTERFACE lpm_pack_arrays
     64       MODULE PROCEDURE lpm_pack_arrays
     65    END INTERFACE lpm_pack_arrays
     66
     67CONTAINS
     68
     69    SUBROUTINE lpm_pack_all_arrays
     70
     71       USE cpulog,                                                             &
     72           ONLY:  cpu_log, log_point_s
     73
     74       USE indices,                                                            &
     75           ONLY:  nxl, nxr, nys, nyn, nzb, nzt
     76
     77       USE kinds
     78
     79       IMPLICIT NONE
     80
     81       INTEGER(iwp) ::  i !:
     82       INTEGER(iwp) ::  j !:
     83       INTEGER(iwp) ::  k !:
     84
     85       CALL cpu_log( log_point_s(51), 'lpm_pack_all_arrays', 'start' )
     86       DO  i = nxl, nxr
     87          DO  j = nys, nyn
     88             DO  k = nzb+1, nzt
     89                number_of_particles = prt_count(k,j,i)
     90                IF ( number_of_particles <= 0 )  CYCLE
     91                particles => grid_particles(k,j,i)%particles(1:number_of_particles)
     92                CALL lpm_pack_and_sort(i,j,k)
     93                prt_count(k,j,i) = number_of_particles
     94             ENDDO
     95          ENDDO
     96       ENDDO
     97       CALL cpu_log( log_point_s(51), 'lpm_pack_all_arrays', 'stop' )
     98       RETURN
     99
     100    END SUBROUTINE lpm_pack_all_arrays
     101
     102    SUBROUTINE lpm_pack_arrays
     103
     104       USE kinds
     105
     106       IMPLICIT NONE
     107
     108       INTEGER(iwp) ::  n       !:
     109       INTEGER(iwp) ::  nd      !:
     110       INTEGER(iwp) ::  nn      !:
     111!
     112!--    Find out elements marked for deletion and move data from highest index
     113!--    values to these free indices
     114       nn = number_of_particles
     115
     116       DO WHILE ( .NOT. particles(nn)%particle_mask )
     117          nn = nn-1
     118          IF ( nn == 0 )  EXIT
     119       ENDDO
     120
     121       IF ( nn > 0 )  THEN
     122          DO  n = 1, number_of_particles
     123             IF ( .NOT. particles(n)%particle_mask )  THEN
     124                particles(n) = particles(nn)
     125                nn = nn - 1
     126                DO WHILE ( .NOT. particles(nn)%particle_mask )
     127                   nn = nn-1
     128                   IF ( n == nn )  EXIT
     129                ENDDO
     130             ENDIF
     131             IF ( n == nn )  EXIT
     132          ENDDO
    75133       ENDIF
    76134
    77     ENDDO
    78 !
    79 !-- The number of deleted particles has been determined in routines
    80 !-- lpm_boundary_conds, lpm_droplet_collision, and lpm_exchange_horiz
    81     number_of_particles = number_of_particles - deleted_particles
    82 
     135!
     136!--    The number of deleted particles has been determined in routines
     137!--    lpm_boundary_conds, lpm_droplet_collision, and lpm_exchange_horiz
     138       number_of_particles = nn
     139
     140!
     141!-- particle tails are currently not available
    83142!
    84143!-- Handle tail array in the same way, store the new tail ids and re-assign it
    85144!-- to the respective particles
    86     IF ( use_particle_tails )  THEN
    87 
    88        nn = 0
    89        nd = 0
    90 
    91        DO  n = 1, number_of_tails
    92 
    93           IF ( tail_mask(n) )  THEN
    94              nn = nn + 1
    95              particle_tail_coordinates(:,:,nn) = &
    96                                                 particle_tail_coordinates(:,:,n)
    97              new_tail_id(n) = nn
    98           ELSE
    99              nd = nd + 1
    100           ENDIF
    101 
    102        ENDDO
    103 
    104        DO  n = 1, number_of_particles
    105           IF ( particles(n)%tail_id /= 0 )  THEN
    106              particles(n)%tail_id = new_tail_id(particles(n)%tail_id)
    107           ENDIF
    108        ENDDO
    109 
    110     ENDIF
     145!    IF ( use_particle_tails )  THEN
     146!
     147!       nn = 0
     148!       nd = 0
     149!
     150!       DO  n = 1, number_of_tails
     151!
     152!          IF ( tail_mask(n) )  THEN
     153!             nn = nn + 1
     154!             particle_tail_coordinates(:,:,nn) = &
     155!                                                particle_tail_coordinates(:,:,n)
     156!             new_tail_id(n) = nn
     157!          ELSE
     158!             nd = nd + 1
     159!          ENDIF
     160!
     161!       ENDDO
     162!
     163!       DO  n = 1, number_of_particles
     164!          IF ( particles(n)%tail_id /= 0 )  THEN
     165!             particles(n)%tail_id = new_tail_id(particles(n)%tail_id)
     166!          ENDIF
     167!       ENDDO
     168!
     169!    ENDIF
    111170
    112171!
    113172!-- The number of deleted tails has been determined in routines
    114173!-- lpm_boundary_conds and lpm_exchange_horiz
    115     number_of_tails = number_of_tails - deleted_tails
    116 
    117 
    118  END SUBROUTINE lpm_pack_arrays
     174!   number_of_tails = number_of_tails - deleted_tails
     175
     176
     177    END SUBROUTINE lpm_pack_arrays
     178
     179    SUBROUTINE lpm_pack_and_sort (ip,jp,kp)
     180
     181      USE control_parameters,                                                  &
     182          ONLY: dz,  atmos_ocean_sign
     183
     184      USE indices,                                                             &
     185          ONLY: nxl, nxr, nys, nyn, nzb, nzt
     186
     187      USE kinds
     188
     189      USE grid_variables,                                                      &
     190          ONLY: ddx, ddy
     191
     192      IMPLICIT NONE
     193
     194      INTEGER(iwp), INTENT(IN)    :: ip
     195      INTEGER(iwp), INTENT(IN)    :: jp
     196      INTEGER(iwp), INTENT(IN)    :: kp
     197
     198      INTEGER(iwp)                :: i
     199      INTEGER(iwp)                :: j
     200      INTEGER(iwp)                :: k
     201      INTEGER(iwp)                :: n
     202      INTEGER(iwp)                :: nn
     203      INTEGER(iwp)                :: m
     204      INTEGER(iwp)                :: sort_index
     205      INTEGER(iwp)                :: is
     206      INTEGER(iwp)                :: kk
     207
     208      INTEGER(iwp),DIMENSION(0:7) :: sort_count
     209
     210      TYPE(particle_type), DIMENSION(number_of_particles,0:7) :: sort_particles
     211
     212       nn = 0
     213       sort_count = 0
     214
     215       DO  n = 1, number_of_particles
     216          sort_index = 0
     217
     218          IF ( particles(n)%particle_mask )  THEN
     219             nn = nn + 1
     220             i = particles(n)%x * ddx
     221             j = particles(n)%y * ddy
     222             k = ( particles(n)%z + 0.5_wp * dz * atmos_ocean_sign ) / dz +    &
     223                 offset_ocean_nzt
     224             kk= particles(n)%z / dz + 1 + offset_ocean_nzt_m1
     225             IF ( i == ip )  sort_index = sort_index+4
     226             IF ( j == jp )  sort_index = sort_index+2
     227             IF ( k == kp )  sort_index = sort_index+1
     228             sort_count(sort_index) = sort_count(sort_index)+1
     229             m = sort_count(sort_index)
     230             sort_particles(m,sort_index) = particles(n)
     231             sort_particles(m,sort_index)%block_nr = sort_index
     232          ENDIF
     233
     234       ENDDO
     235
     236       nn = 0
     237
     238       DO is = 0,7
     239          grid_particles(kp,jp,ip)%start_index(is) = nn + 1
     240          DO n = 1,sort_count(is)
     241             nn = nn+1
     242             particles(nn) = sort_particles(n,is)
     243          ENDDO
     244          grid_particles(kp,jp,ip)%end_index(is) = nn
     245       ENDDO
     246
     247       number_of_particles = nn
     248       RETURN
     249
     250    END SUBROUTINE lpm_pack_and_sort
     251
     252
     253 END module lpm_pack_arrays_mod

  • TabularUnified palm/trunk/SOURCE/lpm_read_restart_file.f90

    r1321 r1359  
    2020! Current revisions:
    2121! ------------------
    22 !
     22! New particle structure integrated.
    2323!
    2424! Former revisions:
    … …  
    4949        ONLY:  nx, nxl, nxlg, nxr, nxrg, ny, nyn, nyng, nys, nysg, nz, nzb, nzt
    5050
     51    USE kinds
     52
     53    USE lpm_pack_arrays_mod,                                                   &
     54        ONLY:  lpm_pack_all_arrays
     55
    5156    USE particle_attributes,                                                   &
    52         ONLY:  bc_par_b, bc_par_lr, bc_par_ns, bc_par_t, initial_particles,    &
    53                number_of_initial_particles, maximum_number_of_particles,       &
     57        ONLY:  alloc_factor, bc_par_b, bc_par_lr, bc_par_ns, bc_par_t,         &
     58               grid_particles, maximum_number_of_particles,                    &
    5459               maximum_number_of_tailpoints, maximum_number_of_tails,          &
    55                new_tail_id, number_of_particles, number_of_particle_groups,    &
    56                number_of_tails, particles, particle_groups, particle_mask,     &
    57                particle_tail_coordinates, particle_type, part_1, part_2,       &
    58                prt_count, prt_start_index,  sort_count, tail_mask, time_prel,  &
    59                time_write_particle_data, uniform_particles, use_particle_tails
    60 
     60               min_nr_particle, new_tail_id, number_of_particles,              &
     61               number_of_particle_groups, number_of_tails, particles,          &
     62               particle_groups, particle_tail_coordinates, particle_type,      &
     63               prt_count, sort_count, tail_mask, time_prel,                    &
     64               time_write_particle_data, uniform_particles,                    &
     65               use_particle_tails, zero_particle
    6166
    6267    USE pegrid
    … …  
    6671    CHARACTER (LEN=10) ::  particle_binary_version    !:
    6772    CHARACTER (LEN=10) ::  version_on_file            !:
     73
     74    INTEGER(iwp) :: alloc_size !:
     75    INTEGER(iwp) :: ip         !:
     76    INTEGER(iwp) :: jp         !:
     77    INTEGER(iwp) :: kp         !:
     78
     79    TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: tmp_particles !:
    6880
    6981!
    … …  
    8193!-- First compare the version numbers
    8294    READ ( 90 )  version_on_file
    83     particle_binary_version = '3.0'
     95    particle_binary_version = '3.2'
    8496    IF ( TRIM( version_on_file ) /= TRIM( particle_binary_version ) )  THEN
    8597       message_string = 'version mismatch concerning data from prior ' // &
    … …  
    92104
    93105!
     106!-- If less particles are stored on the restart file than prescribed by
     107!-- min_nr_particle, the remainder is initialized by zero_particle to avoid
     108!-- errors.
     109#if defined( __twocachelines )
     110    zero_particle = particle_type( 0.0_wp, 0.0_sp, 0.0_sp, 0.0_sp, 0.0_sp,  &
     111                                   0.0_sp, 0.0_sp, 0.0_wp, 0.0_wp, 0.0_wp,  &
     112                                   0, .FALSE., 0.0_wp, 0.0_wp, 0.0_wp,      &
     113                                   0.0_sp, 0.0_sp, 0.0_sp, 0.0_sp, 0.0_sp,  &
     114                                   0.0_sp, 0, 0, 0, -1)
     115#else
     116    zero_particle = particle_type( 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp,  &
     117                                   0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp,  &
     118                                   0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp,  &
     119                                   0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 0, 0, 0, &
     120                                   0, .FALSE., -1)
     121#endif
     122
     123!
    94124!-- Read some particle parameters and the size of the particle arrays,
    95125!-- allocate them and read their contents.
    96126    READ ( 90 )  bc_par_b, bc_par_lr, bc_par_ns, bc_par_t,                  &
    97                  maximum_number_of_particles, maximum_number_of_tailpoints, &
    98                  maximum_number_of_tails, number_of_initial_particles,      &
    99                  number_of_particles, number_of_particle_groups,            &
    100                  number_of_tails, particle_groups, time_prel,               &
    101                  time_write_particle_data, uniform_particles
     127                 maximum_number_of_tailpoints, maximum_number_of_tails,     &
     128                 number_of_particle_groups, number_of_tails,                &
     129                 particle_groups, time_prel, time_write_particle_data,      &
     130                 uniform_particles
    102131
    103     IF ( number_of_initial_particles /= 0 )  THEN
    104        ALLOCATE( initial_particles(1:number_of_initial_particles) )
    105        READ ( 90 )  initial_particles
    106     ENDIF
     132    ALLOCATE( prt_count(nzb:nzt+1,nysg:nyng,nxlg:nxrg),                     &
     133              grid_particles(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
    107134
    108     ALLOCATE( prt_count(nzb:nzt+1,nysg:nyng,nxlg:nxrg),       &
    109               prt_start_index(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &
    110               particle_mask(maximum_number_of_particles),     &
    111               part_1(maximum_number_of_particles),            &
    112               part_2(maximum_number_of_particles) )
     135    READ ( 90 )  prt_count
    113136
    114     part_1 = particle_type( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, &
    115                             0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, &
    116                             0.0, 0, 0, 0, 0 )
     137    maximum_number_of_particles = 0
     138    DO  ip = nxl, nxr
     139       DO  jp = nys, nyn
     140          DO  kp = nzb+1, nzt
    117141
    118     part_2 = particle_type( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, &
    119                             0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, &
    120                             0.0, 0, 0, 0, 0 )
     142             number_of_particles = prt_count(kp,jp,ip)
     143             IF ( number_of_particles > 0 )  THEN
     144                alloc_size = MAX( INT( number_of_particles *                   &
     145                             ( 1.0_wp + alloc_factor / 100.0_wp ) ),           &
     146                             min_nr_particle )
     147             ELSE
     148                alloc_size = min_nr_particle
     149             ENDIF
    121150
    122     sort_count = 0
     151             ALLOCATE( grid_particles(kp,jp,ip)%particles(1:alloc_size) )
    123152
    124     particles => part_1
     153             IF ( number_of_particles > 0 )  THEN
     154                ALLOCATE( tmp_particles(1:number_of_particles) )
     155                READ ( 90 )  tmp_particles
     156                grid_particles(kp,jp,ip)%particles(1:number_of_particles) = tmp_particles
     157                DEALLOCATE( tmp_particles )
     158                IF ( number_of_particles < alloc_size )  THEN
     159                   grid_particles(kp,jp,ip)%particles(number_of_particles+1:alloc_size) &
     160                      = zero_particle
     161                ENDIF
     162             ELSE
     163                grid_particles(kp,jp,ip)%particles(1:alloc_size) = zero_particle
     164             ENDIF
    125165
    126     READ ( 90 )  prt_count, prt_start_index
    127     READ ( 90 )  particles
     166             maximum_number_of_particles = maximum_number_of_particles + alloc_size
    128167
    129     IF ( use_particle_tails )  THEN
    130        ALLOCATE( particle_tail_coordinates(maximum_number_of_tailpoints,5, &
    131                  maximum_number_of_tails),                                 &
    132                  new_tail_id(maximum_number_of_tails),                     &
    133                  tail_mask(maximum_number_of_tails) )
    134        READ ( 90 )  particle_tail_coordinates
    135     ENDIF
     168          ENDDO
     169       ENDDO
     170    ENDDO
     171
     172!
     173!-- particle tails currently not available
     174!    IF ( use_particle_tails )  THEN
     175!       ALLOCATE( particle_tail_coordinates(maximum_number_of_tailpoints,5, &
     176!                 maximum_number_of_tails),                                 &
     177!                 new_tail_id(maximum_number_of_tails),                     &
     178!                 tail_mask(maximum_number_of_tails) )
     179!       READ ( 90 )  particle_tail_coordinates
     180!    ENDIF
    136181
    137182    CLOSE ( 90 )
     183!
     184!-- Must be called to sort particles into blocks, which is needed for a fast
     185!-- interpolation of the LES fields on the particle position.
     186    CALL lpm_pack_all_arrays
    138187
    139188

  • TabularUnified palm/trunk/SOURCE/lpm_release_set.f90

    r1329 r1359  
    2020! Current revisions:
    2121! ------------------
    22 !
     22! New particle structure integrated.
     23! Kind definition added to all floating point numbers.
     24! lpm_init changed form a subroutine to a module.
    2325!
    2426! Former revisions:
    … …  
    5355        ONLY:  iran, message_string, netcdf_data_format
    5456
     57    USE lpm_init_mod,                                                          &
     58        ONLY: lpm_create_particle, PHASE_RELEASE
     59
    5560    USE grid_variables,                                                        &
    5661        ONLY:  dx, dy
    … …  
    6267
    6368    USE particle_attributes,                                                   &
    64         ONLY:  initial_particles, iran_part, maximum_number_of_particles,      &
    65                maximum_number_of_tails, minimum_tailpoint_distance,            &
    66                number_of_initial_particles, number_of_initial_tails,           &
    67                number_of_particles, number_of_tails, particles,                &
    68                particle_tail_coordinates, pdx, pdy, pdz, psb, psl, psn, psr,   &
    69                pss, pst, random_start_position, use_particle_tails
    70 
    71     USE random_function_mod,                                                   &
    72         ONLY:  random_function
     69        ONLY:  minimum_tailpoint_distance, number_of_tails, particles,         &
     70               particle_tail_coordinates, use_particle_tails
    7371
    7472    IMPLICIT NONE
    … …  
    8078
    8179
     80    CALL lpm_create_particle(PHASE_RELEASE)
    8281!
    83 !-- Check, if particle storage must be extended
    84     IF ( number_of_particles + number_of_initial_particles > &
    85          maximum_number_of_particles  )  THEN
    86        IF ( netcdf_data_format < 3 )  THEN
    87           message_string = 'maximum_number_of_particles needs to be increa' // &
    88                            'sed &but this is not allowed with netcdf_data_' // &
    89                            'format < 3'
    90           CALL message( 'lpm_release_set', 'PA0146', 2, 2, -1, 6, 1 )
    91        ELSE
    92           CALL lpm_extend_particle_array( number_of_initial_particles )
    93        ENDIF
    94     ENDIF
     82!-- particle tails currently not available
     83! !
     84! !-- Set the beginning of the new particle tails and their age
     85!     IF ( use_particle_tails )  THEN
     86!
     87!        DO  n = is, ie
     88! !
     89! !--       New particles which should have a tail, already have got a
     90! !--       provisional tail id unequal zero (see lpm_init)
     91!           IF ( particles(n)%tail_id /= 0 )  THEN
     92!
     93!              number_of_tails = number_of_tails + 1
     94!              nn = number_of_tails
     95!              particles(n)%tail_id = nn   ! set the final tail id
     96!              particle_tail_coordinates(1,1,nn) = particles(n)%x
     97!              particle_tail_coordinates(1,2,nn) = particles(n)%y
     98!              particle_tail_coordinates(1,3,nn) = particles(n)%z
     99!              particle_tail_coordinates(1,4,nn) = particles(n)%class
     100!              particles(n)%tailpoints = 1
     101!
     102!              IF ( minimum_tailpoint_distance /= 0.0 )  THEN
     103!                 particle_tail_coordinates(2,1,nn) = particles(n)%x
     104!                 particle_tail_coordinates(2,2,nn) = particles(n)%y
     105!                 particle_tail_coordinates(2,3,nn) = particles(n)%z
     106!                 particle_tail_coordinates(2,4,nn) = particles(n)%class
     107!                 particle_tail_coordinates(1:2,5,nn) = 0.0_wp
     108!                 particles(n)%tailpoints = 2
     109!              ENDIF
     110!
     111!           ENDIF
     112!
     113!        ENDDO
     114!
     115!     ENDIF
    95116
    96 !
    97 !-- Check, if tail storage must be extended
    98     IF ( use_particle_tails )  THEN
    99        IF ( number_of_tails + number_of_initial_tails > &
    100             maximum_number_of_tails  )  THEN
    101           IF ( netcdf_data_format < 3 )  THEN
    102              message_string = 'maximum_number_of_tails needs to be increas' // &
    103                               'ed &but this is not allowed with netcdf_dat' // &
    104                               'a_format < 3'
    105              CALL message( 'lpm_release_set', 'PA0147', 2, 2, -1, 6, 1 )
    106           ELSE
    107              CALL lpm_extend_tail_array( number_of_initial_tails )
    108           ENDIF
    109        ENDIF
    110     ENDIF
    111 
    112     IF ( number_of_initial_particles /= 0 )  THEN
    113 
    114        is = number_of_particles + 1
    115        ie = number_of_particles + number_of_initial_particles
    116        particles(is:ie) = initial_particles(1:number_of_initial_particles)
    117 !
    118 !--    Add random fluctuation to particle positions. Particles should
    119 !--    remain in the subdomain.
    120        IF ( random_start_position )  THEN
    121 
    122           DO  n = is, ie
    123 
    124              IF ( psl(particles(n)%group) /= psr(particles(n)%group) )  THEN
    125                 particles(n)%x = particles(n)%x +                         &
    126                                  ( random_function( iran_part ) - 0.5 ) * &
    127                                  pdx(particles(n)%group)
    128                 IF ( particles(n)%x  <=  ( nxl - 0.5 ) * dx )  THEN
    129                    particles(n)%x = ( nxl - 0.4999999999 ) * dx
    130                 ELSEIF ( particles(n)%x  >=  ( nxr + 0.5 ) * dx )  THEN
    131                    particles(n)%x = ( nxr + 0.4999999999 ) * dx
    132                 ENDIF
    133              ENDIF
    134 
    135              IF ( pss(particles(n)%group) /= psn(particles(n)%group) )  THEN
    136                 particles(n)%y = particles(n)%y +                         &
    137                                  ( random_function( iran_part ) - 0.5 ) * &
    138                                  pdy(particles(n)%group)
    139                 IF ( particles(n)%y  <=  ( nys - 0.5 ) * dy )  THEN
    140                    particles(n)%y = ( nys - 0.4999999999 ) * dy
    141                 ELSEIF ( particles(n)%y  >=  ( nyn + 0.5 ) * dy )  THEN
    142                    particles(n)%y = ( nyn + 0.4999999999 ) * dy
    143                 ENDIF
    144              ENDIF
    145 
    146              IF ( psb(particles(n)%group) /= pst(particles(n)%group) )  THEN
    147                 particles(n)%z = particles(n)%z +                         &
    148                                  ( random_function( iran_part ) - 0.5 ) * &
    149                                  pdz(particles(n)%group)
    150              ENDIF
    151 
    152           ENDDO
    153 
    154        ENDIF
    155 
    156 !
    157 !--    Set the beginning of the new particle tails and their age
    158        IF ( use_particle_tails )  THEN
    159 
    160           DO  n = is, ie
    161 !
    162 !--          New particles which should have a tail, already have got a
    163 !--          provisional tail id unequal zero (see lpm_init)
    164              IF ( particles(n)%tail_id /= 0 )  THEN
    165 
    166                 number_of_tails = number_of_tails + 1
    167                 nn = number_of_tails
    168                 particles(n)%tail_id = nn   ! set the final tail id
    169                 particle_tail_coordinates(1,1,nn) = particles(n)%x
    170                 particle_tail_coordinates(1,2,nn) = particles(n)%y
    171                 particle_tail_coordinates(1,3,nn) = particles(n)%z
    172                 particle_tail_coordinates(1,4,nn) = particles(n)%class
    173                 particles(n)%tailpoints = 1
    174 
    175                 IF ( minimum_tailpoint_distance /= 0.0 )  THEN
    176                    particle_tail_coordinates(2,1,nn) = particles(n)%x
    177                    particle_tail_coordinates(2,2,nn) = particles(n)%y
    178                    particle_tail_coordinates(2,3,nn) = particles(n)%z
    179                    particle_tail_coordinates(2,4,nn) = particles(n)%class
    180                    particle_tail_coordinates(1:2,5,nn) = 0.0
    181                    particles(n)%tailpoints = 2
    182                 ENDIF
    183 
    184              ENDIF
    185 
    186           ENDDO
    187 
    188        ENDIF
    189 
    190        number_of_particles = number_of_particles + number_of_initial_particles
    191 
    192     ENDIF
    193117
    194118 END SUBROUTINE lpm_release_set

  • TabularUnified palm/trunk/SOURCE/lpm_set_attributes.f90

    r1321 r1359  
    2020! Current revisions:
    2121! -----------------
    22 !
     22! New particle structure integrated.
     23! Kind definition added to all floating point numbers.
    2324!
    2425! Former revisions:
    … …  
    7778
    7879    USE particle_attributes,                                                   &
    79         ONLY:  number_of_particles, offset_ocean_nzt, particles
     80        ONLY:  block_offset, grid_particles, number_of_particles,              &
     81               offset_ocean_nzt, particles, prt_count
    8082
    8183    USE pegrid
    … …  
    8789
    8890    INTEGER(iwp) ::  i        !:
     91    INTEGER(iwp) ::  ip       !:
    8992    INTEGER(iwp) ::  j        !:
     93    INTEGER(iwp) ::  jp       !:
    9094    INTEGER(iwp) ::  k        !:
     95    INTEGER(iwp) ::  kp       !:
    9196    INTEGER(iwp) ::  n        !:
     97    INTEGER(iwp) ::  nb       !:
     98
     99    INTEGER(iwp), DIMENSION(0:7) ::  start_index !:
     100    INTEGER(iwp), DIMENSION(0:7) ::  end_index   !:
    92101
    93102    REAL(wp)    ::  aa        !:
    … …  
    101110    REAL(wp)    ::  pt_int_l  !:
    102111    REAL(wp)    ::  pt_int_u  !:
    103     REAL(wp)    ::  u_int     !:
    104112    REAL(wp)    ::  u_int_l   !:
    105113    REAL(wp)    ::  u_int_u   !:
    106     REAL(wp)    ::  v_int     !:
    107114    REAL(wp)    ::  v_int_l   !:
    108115    REAL(wp)    ::  v_int_u   !:
    … …  
    113120    REAL(wp)    ::  y         !:
    114121
     122    REAL(wp), DIMENSION(:), ALLOCATABLE ::  u_int                  !:
     123    REAL(wp), DIMENSION(:), ALLOCATABLE ::  v_int                  !:
     124    REAL(wp), DIMENSION(:), ALLOCATABLE ::  xv                     !:
     125    REAL(wp), DIMENSION(:), ALLOCATABLE ::  yv                     !:
     126    REAL(wp), DIMENSION(:), ALLOCATABLE ::  zv                     !:
     127
    115128    CALL cpu_log( log_point_s(49), 'lpm_set_attributes', 'start' )
    116129
    … …  
    122135!--    Set particle color depending on the absolute value of the horizontal
    123136!--    velocity
    124        DO  n = 1, number_of_particles
    125 !
    126 !--       Interpolate u velocity-component, determine left, front, bottom
    127 !--       index of u-array
    128           i = ( particles(n)%x + 0.5 * dx ) * ddx
    129           j =   particles(n)%y * ddy
    130           k = ( particles(n)%z + 0.5 * dz * atmos_ocean_sign ) / dz  &
    131               + offset_ocean_nzt                     ! only exact if equidistant
    132 
    133 !
    134 !--       Interpolation of the velocity components in the xy-plane
    135           x  = particles(n)%x + ( 0.5 - i ) * dx
    136           y  = particles(n)%y - j * dy
    137           aa = x**2          + y**2
    138           bb = ( dx - x )**2 + y**2
    139           cc = x**2          + ( dy - y )**2
    140           dd = ( dx - x )**2 + ( dy - y )**2
    141           gg = aa + bb + cc + dd
    142 
    143           u_int_l = ( ( gg - aa ) * u(k,j,i)   + ( gg - bb ) * u(k,j,i+1)   &
    144                     + ( gg - cc ) * u(k,j+1,i) + ( gg - dd ) * u(k,j+1,i+1) &
    145                     ) / ( 3.0 * gg ) - u_gtrans
    146           IF ( k+1 == nzt+1 )  THEN
    147              u_int = u_int_l
    148           ELSE
    149              u_int_u = ( ( gg-aa ) * u(k+1,j,i)   + ( gg-bb ) * u(k+1,j,i+1)   &
    150                        + ( gg-cc ) * u(k+1,j+1,i) + ( gg-dd ) * u(k+1,j+1,i+1) &
    151                        ) / ( 3.0 * gg ) - u_gtrans
    152              u_int = u_int_l + ( particles(n)%z - zu(k) ) / dz * &
    153                                ( u_int_u - u_int_l )
    154           ENDIF
    155 
    156 !
    157 !--       Same procedure for interpolation of the v velocity-component (adopt
    158 !--       index k from u velocity-component)
    159           i =   particles(n)%x * ddx
    160           j = ( particles(n)%y + 0.5 * dy ) * ddy
    161 
    162           x  = particles(n)%x - i * dx
    163           y  = particles(n)%y + ( 0.5 - j ) * dy
    164           aa = x**2          + y**2
    165           bb = ( dx - x )**2 + y**2
    166           cc = x**2          + ( dy - y )**2
    167           dd = ( dx - x )**2 + ( dy - y )**2
    168           gg = aa + bb + cc + dd
    169 
    170           v_int_l = ( ( gg - aa ) * v(k,j,i)   + ( gg - bb ) * v(k,j,i+1)   &
    171                  + ( gg - cc ) * v(k,j+1,i) + ( gg - dd ) * v(k,j+1,i+1) &
    172                  ) / ( 3.0 * gg ) - v_gtrans
    173           IF ( k+1 == nzt+1 )  THEN
    174              v_int = v_int_l
    175           ELSE
    176              v_int_u = ( ( gg-aa ) * v(k+1,j,i)   + ( gg-bb ) * v(k+1,j,i+1)   &
    177                        + ( gg-cc ) * v(k+1,j+1,i) + ( gg-dd ) * v(k+1,j+1,i+1) &
    178                        ) / ( 3.0 * gg ) - v_gtrans
    179              v_int = v_int_l + ( particles(n)%z - zu(k) ) / dz * &
    180                                ( v_int_u - v_int_l )
    181           ENDIF
    182 
    183           absuv = SQRT( u_int**2 + v_int**2 )
    184 
    185 !
    186 !--       Limit values by the given interval and normalize to interval [0,1]
    187           absuv = MIN( absuv, color_interval(2) )
    188           absuv = MAX( absuv, color_interval(1) )
    189 
    190           absuv = ( absuv - color_interval(1) ) / &
    191                   ( color_interval(2) - color_interval(1) )
    192 
    193 !
    194 !--       Number of available colors is defined in init_dvrp
    195           particles(n)%class = 1 + absuv * ( dvrp_colortable_entries_prt - 1 )
    196 
     137       DO  ip = nxl, nxr
     138          DO  jp = nys, nyn
     139             DO  kp = nzb+1, nzt
     140
     141                number_of_particles = prt_count(kp,jp,ip)
     142                particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
     143                IF ( number_of_particles <= 0 )  CYCLE
     144                start_index = grid_particles(kp,jp,ip)%start_index
     145                end_index   = grid_particles(kp,jp,ip)%end_index
     146
     147                ALLOCATE( u_int(1:number_of_particles), &
     148                          v_int(1:number_of_particles), &
     149                          xv(1:number_of_particles),    &
     150                          yv(1:number_of_particles),    &
     151                          zv(1:number_of_particles) )
     152
     153                xv = particles(1:number_of_particles)%x
     154                yv = particles(1:number_of_particles)%y
     155                zv = particles(1:number_of_particles)%z
     156
     157                DO  nb = 0,7
     158
     159                   i = ip
     160                   j = jp + block_offset(nb)%j_off
     161                   k = kp + block_offset(nb)%k_off
     162
     163                   DO  n = start_index(nb), end_index(nb)
     164!
     165!--                   Interpolation of the velocity components in the xy-plane
     166                      x  = xv(n) + ( 0.5_wp - i ) * dx
     167                      y  = yv(n) - j * dy
     168                      aa = x**2          + y**2
     169                      bb = ( dx - x )**2 + y**2
     170                      cc = x**2          + ( dy - y )**2
     171                      dd = ( dx - x )**2 + ( dy - y )**2
     172                      gg = aa + bb + cc + dd
     173
     174                      u_int_l = ( ( gg - aa ) * u(k,j,i)   + ( gg - bb ) *     &
     175                                  u(k,j,i+1) + ( gg - cc ) * u(k,j+1,i) +      &
     176                                  ( gg - dd ) * u(k,j+1,i+1)                   &
     177                                ) / ( 3.0_wp * gg ) - u_gtrans
     178
     179                      IF ( k+1 == nzt+1 )  THEN
     180                         u_int(n) = u_int_l
     181                      ELSE
     182                         u_int_u = ( ( gg - aa ) * u(k+1,j,i)   + ( gg - bb ) *  &
     183                                     u(k+1,j,i+1) + ( gg - cc ) * u(k+1,j+1,i) + &
     184                                     ( gg - dd ) * u(k+1,j+1,i+1)                &
     185                                   ) / ( 3.0_wp * gg ) - u_gtrans
     186                         u_int(n) = u_int_l + ( zv(n) - zu(k) ) / dz *         &
     187                                           ( u_int_u - u_int_l )
     188                      ENDIF
     189
     190                   ENDDO
     191
     192                   i = ip + block_offset(nb)%i_off
     193                   j = jp
     194                   k = kp + block_offset(nb)%k_off
     195
     196                   DO  n = start_index(nb), end_index(nb)
     197!
     198!--                   Same procedure for interpolation of the v velocity-component
     199                      x  = xv(n) - i * dx
     200                      y  = yv(n) + ( 0.5_wp - j ) * dy
     201                      aa = x**2          + y**2
     202                      bb = ( dx - x )**2 + y**2
     203                      cc = x**2          + ( dy - y )**2
     204                      dd = ( dx - x )**2 + ( dy - y )**2
     205                      gg = aa + bb + cc + dd
     206
     207                      v_int_l = ( ( gg - aa ) * v(k,j,i)   + ( gg - bb ) *     &
     208                                  v(k,j,i+1) + ( gg - cc ) * v(k,j+1,i) +      &
     209                                  ( gg - dd ) * v(k,j+1,i+1)                   &
     210                                ) / ( 3.0_wp * gg ) - v_gtrans
     211
     212                      IF ( k+1 == nzt+1 )  THEN
     213                         v_int(n) = v_int_l
     214                      ELSE
     215                         v_int_u  = ( ( gg - aa ) * v(k+1,j,i) + ( gg - bb ) *    &
     216                                      v(k+1,j,i+1) + ( gg - cc ) * v(k+1,j+1,i) + &
     217                                      ( gg - dd ) * v(k+1,j+1,i+1)                &
     218                                    ) / ( 3.0_wp * gg ) - v_gtrans
     219                         v_int(n) = v_int_l + ( zv(n) - zu(k) ) / dz *         &
     220                                           ( v_int_u - v_int_l )
     221                      ENDIF
     222
     223                   ENDDO
     224
     225                ENDDO
     226
     227                DO  n = 1, number_of_particles
     228
     229                   absuv = SQRT( u_int(n)**2 + v_int(n)**2 )
     230
     231!
     232!--                Limit values by the given interval and normalize to
     233!--                interval [0,1]
     234                   absuv = MIN( absuv, color_interval(2) )
     235                   absuv = MAX( absuv, color_interval(1) )
     236
     237                   absuv = ( absuv - color_interval(1) ) / &
     238                           ( color_interval(2) - color_interval(1) )
     239
     240!
     241!--                Number of available colors is defined in init_dvrp
     242                   particles(n)%class = 1 + absuv *                            &
     243                                            ( dvrp_colortable_entries_prt - 1 )
     244
     245                ENDDO
     246
     247                DEALLOCATE( u_int, v_int, xv, yv, zv )
     248
     249             ENDDO
     250          ENDDO
    197251       ENDDO
    198252
    … …  
    204258!--    (This is also done in flow_statistics, but flow_statistics is called
    205259!--    after this routine.)
    206        sums_l(:,4,0) = 0.0
     260       sums_l(:,4,0) = 0.0_wp
    207261       DO  i = nxl, nxr
    208262          DO  j =  nys, nyn
    … …  
    214268
    215269#if defined( __parallel )
    216 
    217270       IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
    218271       CALL MPI_ALLREDUCE( sums_l(nzb,4,0), sums(nzb,4), nzt+2-nzb, &
    219272                           MPI_REAL, MPI_SUM, comm2d, ierr )
    220 
    221273#else
    222 
    223274       sums(:,4) = sums_l(:,4,0)
    224 
    225275#endif
    226 
    227276       sums(:,4) = sums(:,4) / ngp_2dh(0)
    228277
    229        DO  n = 1, number_of_particles
    230 !
    231 !--       Interpolate temperature to the current particle position
    232           i = particles(n)%x * ddx
    233           j = particles(n)%y * ddy
    234           k = ( particles(n)%z + 0.5 * dz * atmos_ocean_sign ) / dz  &
    235               + offset_ocean_nzt                     ! only exact if equidistant
    236 
    237           x  = particles(n)%x - i * dx
    238           y  = particles(n)%y - j * dy
    239           aa = x**2          + y**2
    240           bb = ( dx - x )**2 + y**2
    241           cc = x**2          + ( dy - y )**2
    242           dd = ( dx - x )**2 + ( dy - y )**2
    243           gg = aa + bb + cc + dd
    244 
    245           pt_int_l = ( ( gg - aa ) * pt(k,j,i)   + ( gg - bb ) * pt(k,j,i+1)   &
    246                      + ( gg - cc ) * pt(k,j+1,i) + ( gg - dd ) * pt(k,j+1,i+1) &
    247                      ) / ( 3.0 * gg ) - sums(k,4)
    248 
    249           pt_int_u = ( ( gg-aa ) * pt(k+1,j,i)   + ( gg-bb ) * pt(k+1,j,i+1)   &
    250                      + ( gg-cc ) * pt(k+1,j+1,i) + ( gg-dd ) * pt(k+1,j+1,i+1) &
    251                      ) / ( 3.0 * gg ) - sums(k,4)
    252 
    253           pt_int = pt_int_l + ( particles(n)%z - zu(k) ) / dz * &
    254                               ( pt_int_u - pt_int_l )
    255 
    256 !
    257 !--       Limit values by the given interval and normalize to interval [0,1]
    258           pt_int = MIN( pt_int, color_interval(2) )
    259           pt_int = MAX( pt_int, color_interval(1) )
    260 
    261           pt_int = ( pt_int - color_interval(1) ) / &
    262                    ( color_interval(2) - color_interval(1) )
    263 
    264 !
    265 !--       Number of available colors is defined in init_dvrp
    266           particles(n)%class = 1 + pt_int * ( dvrp_colortable_entries_prt - 1 )
    267 
     278       DO  ip = nxl, nxr
     279          DO  jp = nys, nyn
     280             DO  kp = nzb+1, nzt
     281
     282                number_of_particles = prt_count(kp,jp,ip)
     283                particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
     284                IF ( number_of_particles <= 0 )  CYCLE
     285                start_index = grid_particles(kp,jp,ip)%start_index
     286                end_index   = grid_particles(kp,jp,ip)%end_index
     287
     288                ALLOCATE( xv(1:number_of_particles), &
     289                          yv(1:number_of_particles), &
     290                          zv(1:number_of_particles) )
     291
     292                xv = particles(1:number_of_particles)%x
     293                yv = particles(1:number_of_particles)%y
     294                zv = particles(1:number_of_particles)%z
     295
     296                DO  nb = 0,7
     297
     298                   i = ip + block_offset(nb)%i_off
     299                   j = jp + block_offset(nb)%j_off
     300                   k = kp + block_offset(nb)%k_off
     301
     302                   DO  n = start_index(nb), end_index(nb)
     303!
     304!--                   Interpolate temperature to the current particle position
     305                      x  = xv(n) - i * dx
     306                      y  = yv(n) - j * dy
     307                      aa = x**2          + y**2
     308                      bb = ( dx - x )**2 + y**2
     309                      cc = x**2          + ( dy - y )**2
     310                      dd = ( dx - x )**2 + ( dy - y )**2
     311                      gg = aa + bb + cc + dd
     312
     313                      pt_int_l = ( ( gg - aa ) * pt(k,j,i)   + ( gg - bb ) *   &
     314                                   pt(k,j,i+1) + ( gg - cc ) * pt(k,j+1,i) +   &
     315                                   ( gg - dd ) * pt(k,j+1,i+1)                 &
     316                                 ) / ( 3.0_wp * gg ) - sums(k,4)
     317
     318                      pt_int_u = ( ( gg - aa ) * pt(k+1,j,i) + ( gg - bb ) *     &
     319                                   pt(k+1,j,i+1) + ( gg - cc ) * pt(k+1,j+1,i) + &
     320                                   ( gg - dd ) * pt(k+1,j+1,i+1)                 &
     321                                 ) / ( 3.0_wp * gg ) - sums(k,4)
     322
     323                      pt_int = pt_int_l + ( zv(n) - zu(k) ) / dz *    &
     324                                          ( pt_int_u - pt_int_l )
     325
     326!
     327!--                   Limit values by the given interval and normalize to
     328!--                   interval [0,1]
     329                      pt_int = MIN( pt_int, color_interval(2) )
     330                      pt_int = MAX( pt_int, color_interval(1) )
     331
     332                      pt_int = ( pt_int - color_interval(1) ) /                &
     333                               ( color_interval(2) - color_interval(1) )
     334
     335!
     336!--                   Number of available colors is defined in init_dvrp
     337                      particles(n)%class = 1 + pt_int *                        &
     338                                           ( dvrp_colortable_entries_prt - 1 )
     339
     340                   ENDDO
     341                ENDDO
     342
     343                DEALLOCATE( xv, yv, zv )
     344
     345             ENDDO
     346          ENDDO
    268347       ENDDO
    269348
    … …  
    272351!--    Set particle color depending on the height above the bottom
    273352!--    boundary (z=0)
    274        DO  n = 1, number_of_particles
    275 
    276           height = particles(n)%z
    277 !
    278 !--       Limit values by the given interval and normalize to interval [0,1]
    279           height = MIN( height, color_interval(2) )
    280           height = MAX( height, color_interval(1) )
    281 
    282           height = ( height - color_interval(1) ) / &
    283                    ( color_interval(2) - color_interval(1) )
    284 
    285 !
    286 !--       Number of available colors is defined in init_dvrp
    287           particles(n)%class = 1 + height * ( dvrp_colortable_entries_prt - 1 )
    288 
     353       DO  ip = nxl, nxr
     354          DO  jp = nys, nyn
     355             DO  kp = nzb+1, nzt
     356
     357                number_of_particles = prt_count(kp,jp,ip)
     358                particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
     359                IF ( number_of_particles <= 0 )  CYCLE
     360                DO  n = 1, number_of_particles
     361
     362                   height = particles(n)%z
     363!
     364!--                Limit values by the given interval and normalize to
     365!--                interval [0,1]
     366                   height = MIN( height, color_interval(2) )
     367                   height = MAX( height, color_interval(1) )
     368
     369                   height = ( height - color_interval(1) ) / &
     370                            ( color_interval(2) - color_interval(1) )
     371
     372!
     373!--                Number of available colors is defined in init_dvrp
     374                   particles(n)%class = 1 + height *                           &
     375                                            ( dvrp_colortable_entries_prt - 1 )
     376
     377                ENDDO
     378
     379             ENDDO
     380          ENDDO
    289381       ENDDO
    290382
    … …  
    295387    IF ( particle_dvrpsize == 'absw' )  THEN
    296388
    297        DO  n = 1, number_of_particles
    298 !
    299 !--       Interpolate w-component to the current particle position
    300           i = particles(n)%x * ddx
    301           j = particles(n)%y * ddy
    302           k = particles(n)%z / dz
    303 
    304           x  = particles(n)%x - i * dx
    305           y  = particles(n)%y - j * dy
    306           aa = x**2          + y**2
    307           bb = ( dx - x )**2 + y**2
    308           cc = x**2          + ( dy - y )**2
    309           dd = ( dx - x )**2 + ( dy - y )**2
    310           gg = aa + bb + cc + dd
    311 
    312           w_int_l = ( ( gg - aa ) * w(k,j,i)   + ( gg - bb ) * w(k,j,i+1)   &
    313                     + ( gg - cc ) * w(k,j+1,i) + ( gg - dd ) * w(k,j+1,i+1) &
    314                     ) / ( 3.0 * gg )
    315 
    316           IF ( k+1 == nzt+1 )  THEN
    317              w_int = w_int_l
    318           ELSE
    319              w_int_u = ( ( gg-aa ) * w(k+1,j,i)   + ( gg-bb ) * w(k+1,j,i+1)   &
    320                        + ( gg-cc ) * w(k+1,j+1,i) + ( gg-dd ) * w(k+1,j+1,i+1) &
    321                        ) / ( 3.0 * gg )
    322              w_int = w_int_l + ( particles(n)%z - zw(k) ) / dz * &
    323                                ( w_int_u - w_int_l )
    324           ENDIF
    325 
    326 !
    327 !--       Limit values by the given interval and normalize to interval [0,1]
    328           w_int = ABS( w_int )
    329           w_int = MIN( w_int, dvrpsize_interval(2) )
    330           w_int = MAX( w_int, dvrpsize_interval(1) )
    331 
    332           w_int = ( w_int - dvrpsize_interval(1) ) / &
    333                   ( dvrpsize_interval(2) - dvrpsize_interval(1) )
    334 
    335           particles(n)%dvrp_psize = ( 0.25 + w_int * 0.6 ) * dx
    336 
     389       DO  ip = nxl, nxr
     390          DO  jp = nys, nyn
     391             DO  kp = nzb+1, nzt
     392
     393                number_of_particles = prt_count(kp,jp,ip)
     394                particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
     395                IF ( number_of_particles <= 0 )  CYCLE
     396                start_index = grid_particles(kp,jp,ip)%start_index
     397                end_index   = grid_particles(kp,jp,ip)%end_index
     398
     399                ALLOCATE( xv(1:number_of_particles), &
     400                          yv(1:number_of_particles) )
     401
     402                xv = particles(1:number_of_particles)%x
     403                yv = particles(1:number_of_particles)%y
     404                zv = particles(1:number_of_particles)%z
     405
     406                DO  nb = 0,7
     407
     408                   i = ip + block_offset(nb)%i_off
     409                   j = jp + block_offset(nb)%j_off
     410                   k = kp-1
     411
     412                   DO  n = start_index(nb), end_index(nb)
     413!
     414!--                   Interpolate w-component to the current particle position
     415                      x  = xv(n) - i * dx
     416                      y  = yv(n) - j * dy
     417                      aa = x**2          + y**2
     418                      bb = ( dx - x )**2 + y**2
     419                      cc = x**2          + ( dy - y )**2
     420                      dd = ( dx - x )**2 + ( dy - y )**2
     421                      gg = aa + bb + cc + dd
     422
     423                      w_int_l = ( ( gg - aa ) * w(k,j,i)   + ( gg - bb ) *     &
     424                                  w(k,j,i+1) + ( gg - cc ) * w(k,j+1,i) +      &
     425                                  ( gg - dd ) * w(k,j+1,i+1)                   &
     426                                ) / ( 3.0_wp * gg )
     427
     428                      IF ( k+1 == nzt+1 )  THEN
     429                         w_int = w_int_l
     430                      ELSE
     431                         w_int_u = ( ( gg - aa ) * w(k+1,j,i)   + ( gg - bb ) *  &
     432                                     w(k+1,j,i+1) + ( gg - cc ) * w(k+1,j+1,i) + &
     433                                     ( gg - dd ) * w(k+1,j+1,i+1)                &
     434                                   ) / ( 3.0_wp * gg )
     435                         w_int = w_int_l + ( zv(n) - zw(k) ) / dz *     &
     436                                           ( w_int_u - w_int_l )
     437                      ENDIF
     438
     439!
     440!--                   Limit values by the given interval and normalize to
     441!--                   interval [0,1]
     442                      w_int = ABS( w_int )
     443                      w_int = MIN( w_int, dvrpsize_interval(2) )
     444                      w_int = MAX( w_int, dvrpsize_interval(1) )
     445
     446                      w_int = ( w_int - dvrpsize_interval(1) ) / &
     447                              ( dvrpsize_interval(2) - dvrpsize_interval(1) )
     448
     449                      particles(n)%dvrp_psize = ( 0.25_wp + w_int * 0.6_wp ) * &
     450                                                dx
     451
     452                   ENDDO
     453                ENDDO
     454
     455                DEALLOCATE( xv, yv, zv )
     456
     457             ENDDO
     458          ENDDO
    337459       ENDDO
    338460

  • TabularUnified palm/trunk/SOURCE/lpm_write_exchange_statistics.f90

    r1321 r1359  
    2020! Current revisions:
    2121! ------------------
    22 !
     22! New particle structure integrated.
    2323!
    2424! Former revisions:
    … …  
    4747!------------------------------------------------------------------------------!
    4848
    49     USE control_parameters,                                                     &
     49    USE control_parameters,                                                    &
    5050        ONLY:  current_timestep_number, dt_3d, simulated_time
    5151
    52     USE particle_attributes,                                                    &
    53         ONLY:  maximum_number_of_particles, number_of_particles, trlp_count_sum,&
    54                trlp_count_recv_sum, trnp_count_sum, trnp_count_recv_sum,        &
    55                trrp_count_sum, trrp_count_recv_sum, trsp_count_sum,             &
    56                trsp_count_recv_sum
     52    USE indices,                                                               &
     53        ONLY:  nxl, nxr, nys, nyn, nzb, nzt
     54
     55    USE particle_attributes,                                                   &
     56        ONLY:  grid_particles, maximum_number_of_particles,                    &
     57               number_of_particles, particles, prt_count,                      &
     58               trlp_count_sum, trlp_count_recv_sum, trnp_count_sum,            &
     59               trnp_count_recv_sum, trrp_count_sum, trrp_count_recv_sum,       &
     60               trsp_count_sum, trsp_count_recv_sum
    5761
    5862    USE pegrid
    … …  
    6064    IMPLICIT NONE
    6165
     66    INTEGER(iwp) :: ip         !:
     67    INTEGER(iwp) :: jp         !:
     68    INTEGER(iwp) :: kp         !:
     69
     70!
     71!-- Determine maximum number of particles (i.e., all possible particles that
     72!-- have been allocated) and the current number of particles
     73    number_of_particles         = 0
     74    maximum_number_of_particles = 0
     75    DO  ip = nxl, nxr
     76       DO  jp = nys, nyn
     77          DO  kp = nzb+1, nzt
     78             number_of_particles = number_of_particles                         &
     79                                     + prt_count(kp,jp,ip)
     80             maximum_number_of_particles = maximum_number_of_particles         &
     81                                     + SIZE(grid_particles(kp,jp,ip)%particles)
     82          ENDDO
     83       ENDDO
     84    ENDDO
    6285
    6386    CALL check_open( 80 )
    … …  
    77100!
    78101!-- Formats
    79 8000 FORMAT (I6,1X,F7.2,4X,I6,5X,4(I3,1X,I4,'/',I4,2X),6X,I6)
     1028000 FORMAT (I6,1X,F7.2,4X,I10,5X,4(I3,1X,I4,'/',I4,2X),6X,I10)
    80103
    81104

  • TabularUnified palm/trunk/SOURCE/lpm_write_restart_file.f90

    r1321 r1359  
    2020! Current revisions:
    2121! ------------------
    22 !
     22! New particle structure integrated.
    2323!
    2424! Former revisions:
    … …  
    4848        ONLY:  io_blocks, io_group
    4949
     50    USE indices,                                                               &
     51        ONLY:  nxl, nxr, nyn, nys, nzb, nzt
     52
    5053    USE kinds
    5154
    5255    USE particle_attributes,                                                   &
    53         ONLY:  bc_par_b, bc_par_lr, bc_par_ns, bc_par_t, initial_particles,    &
    54         maximum_number_of_particles,  maximum_number_of_tails,                 &
    55         maximum_number_of_tailpoints, number_of_initial_particles,             &
    56         number_of_particles, number_of_particle_groups, number_of_tails,       &
    57         particles, particle_groups, particle_tail_coordinates, prt_count,      &
    58         prt_start_index, time_prel, time_write_particle_data,                  &
    59         uniform_particles, use_particle_tails
     56        ONLY:  bc_par_b, bc_par_lr, bc_par_ns, bc_par_t, grid_particles,       &
     57               maximum_number_of_tails, maximum_number_of_tailpoints,          &
     58               number_of_particles, number_of_particle_groups,                 &
     59               number_of_tails, particles, particle_groups,                    &
     60               particle_tail_coordinates, prt_count, time_prel,                &
     61               time_write_particle_data, uniform_particles,                    &
     62               use_particle_tails, zero_particle
    6063
    6164    USE pegrid
    … …  
    6467
    6568    CHARACTER (LEN=10) ::  particle_binary_version   !:
     69
    6670    INTEGER(iwp) ::  i                               !:
     71    INTEGER(iwp) ::  ip                              !:
     72    INTEGER(iwp) ::  jp                              !:
     73    INTEGER(iwp) ::  kp                              !:
    6774
    6875!
    … …  
    8390    ENDIF
    8491
    85     DO  i = 0, io_blocks-1
     92!    DO  i = 0, io_blocks-1
    8693
    87        IF ( i == io_group )  THEN
     94!       IF ( i == io_group )  THEN
    8895
    8996!
    … …  
    94101!--                  to be read in lpm_read_restart_file must be adjusted
    95102!--                  accordingly.
    96           particle_binary_version = '3.0'
     103          particle_binary_version = '3.2'
    97104          WRITE ( 90 )  particle_binary_version
    98105
    … …  
    101108!--       well as other dvrp-plot variables.
    102109          WRITE ( 90 )  bc_par_b, bc_par_lr, bc_par_ns, bc_par_t,              &
    103                         maximum_number_of_particles,                           &
    104110                        maximum_number_of_tailpoints, maximum_number_of_tails, &
    105                         number_of_initial_particles, number_of_particles,      &
    106111                        number_of_particle_groups, number_of_tails,            &
    107112                        particle_groups, time_prel, time_write_particle_data,  &
    108113                        uniform_particles
    109114
    110           IF ( number_of_initial_particles /= 0 ) WRITE ( 90 ) initial_particles
     115          WRITE ( 90 )  prt_count
     116         
     117          DO  ip = nxl, nxr
     118             DO  jp = nys, nyn
     119                DO  kp = nzb+1, nzt
     120                   number_of_particles = prt_count(kp,jp,ip)
     121                   particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
     122                   IF ( number_of_particles <= 0 )  CYCLE
     123                   WRITE ( 90 )  particles
     124                ENDDO
     125             ENDDO
     126          ENDDO
    111127
    112           WRITE ( 90 )  prt_count, prt_start_index
    113           WRITE ( 90 )  particles
    114 
    115           IF ( use_particle_tails )  THEN
    116              WRITE ( 90 )  particle_tail_coordinates
    117           ENDIF
     128!
     129!--       particle tails currently not available
     130!          IF ( use_particle_tails )  THEN
     131!             WRITE ( 90 )  particle_tail_coordinates
     132!          ENDIF
    118133
    119134          CLOSE ( 90 )
    120135
    121        ENDIF
     136!       ENDIF
    122137
    123138#if defined( __parallel )
    … …  
    125140#endif
    126141
    127     ENDDO
     142 !   ENDDO
    128143
    129144

  • TabularUnified palm/trunk/SOURCE/modules.f90

    r1354 r1359  
    2020! Current revisions:
    2121! ------------------
    22 !
     22! particle_attributes moved to mod_particle_attributes.f90
    2323!
    2424! Former revisions:
    … …  
    11871187
    11881188
    1189  MODULE particle_attributes
    1190 
    1191 !------------------------------------------------------------------------------!
    1192 ! Description:
    1193 ! ------------
    1194 ! Definition of variables used to compute particle transport
    1195 !------------------------------------------------------------------------------!
    1196 
    1197     USE kinds
    1198 
    1199     CHARACTER (LEN=15)  ::  bc_par_lr = 'cyclic',  bc_par_ns = 'cyclic', &
    1200                             bc_par_b  = 'reflect', bc_par_t  = 'absorb', &
    1201                             collision_kernel = 'none'
    1202 
    1203     INTEGER(iwp) ::  deleted_particles = 0, deleted_tails = 0,                      &
    1204                      dissipation_classes = 10, ibc_par_lr,                          &
    1205                      ibc_par_ns, ibc_par_b, ibc_par_t, iran_part = -1234567,        &
    1206                      maximum_number_of_particles = 1000,                            &
    1207                      maximum_number_of_tailpoints = 100,                            &
    1208                      maximum_number_of_tails = 0,                                   &
    1209                      mpi_particle_type,                                             &
    1210                      number_of_sublayers = 20,                                      &
    1211                      number_of_initial_particles = 0, number_of_particles = 0,      &
    1212                      number_of_particle_groups = 1, number_of_tails = 0,            &
    1213                      number_of_initial_tails = 0, offset_ocean_nzt = 0,             &
    1214                      offset_ocean_nzt_m1 = 0, particles_per_point = 1,              &
    1215                      particle_file_count = 0, radius_classes = 20,                  &
    1216                      skip_particles_for_tail = 100, sort_count = 0,                 &
    1217                      total_number_of_particles, total_number_of_tails = 0,          &
    1218                      trlp_count_sum, trlp_count_recv_sum, trrp_count_sum,           &
    1219                      trrp_count_recv_sum, trsp_count_sum, trsp_count_recv_sum,      &
    1220                      trnp_count_sum, trnp_count_recv_sum
    1221 
    1222     INTEGER(iwp), PARAMETER ::  max_number_of_particle_groups = 10
    1223 
    1224     INTEGER(iwp), DIMENSION(:), ALLOCATABLE     ::  new_tail_id
    1225     INTEGER(iwp), DIMENSION(:,:,:), ALLOCATABLE ::  prt_count, prt_start_index
    1226 
    1227     LOGICAL ::  hall_kernel = .FALSE., palm_kernel = .FALSE.,                  &
    1228                 particle_advection = .FALSE., random_start_position = .FALSE., &
    1229                 read_particles_from_restartfile = .TRUE.,                      &
    1230                 uniform_particles = .TRUE., use_kernel_tables = .FALSE.,       &
    1231                 use_particle_tails = .FALSE., use_sgs_for_particles = .FALSE., &
    1232                 wang_kernel = .FALSE., write_particle_statistics = .FALSE.
    1233 
    1234     LOGICAL, DIMENSION(max_number_of_particle_groups) ::                       &
    1235                 vertical_particle_advection = .TRUE.
    1236 
    1237     LOGICAL, DIMENSION(:), ALLOCATABLE ::  particle_mask, tail_mask
    1238 
    1239     REAL(wp)    ::  c_0 = 3.0_wp, dt_min_part = 0.0002_wp, dt_prel = 9999999.9_wp,          &
    1240                     dt_sort_particles = 0.0_wp, dt_write_particle_data = 9999999.9_wp,   &
    1241                     dvrp_psize = 9999999.9_wp, end_time_prel = 9999999.9_wp,             &
    1242                     initial_weighting_factor = 1.0_wp,                                &
    1243                     maximum_tailpoint_age = 100000.0_wp,                              &
    1244                     minimum_tailpoint_distance = 0.0_wp,                              &
    1245                     particle_advection_start = 0.0_wp, sgs_wfu_part = 0.3333333_wp,      &
    1246                     sgs_wfv_part = 0.3333333_wp, sgs_wfw_part = 0.3333333_wp,            &
    1247                     time_prel = 0.0_wp, time_sort_particles = 0.0_wp,                    &
    1248                     time_write_particle_data = 0.0_wp, z0_av_global
    1249 
    1250     REAL(wp), DIMENSION(max_number_of_particle_groups) ::  &
    1251                     density_ratio = 9999999.9_wp, pdx = 9999999.9_wp, pdy = 9999999.9_wp, &
    1252                     pdz = 9999999.9_wp, psb = 9999999.9_wp, psl = 9999999.9_wp,           &
    1253                     psn = 9999999.9_wp, psr = 9999999.9_wp, pss = 9999999.9_wp,           &
    1254                     pst = 9999999.9_wp, radius = 9999999.9_wp
    1255 
    1256     REAL(wp), DIMENSION(:), ALLOCATABLE     ::  log_z_z0
    1257 
    1258     REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  particle_tail_coordinates
    1259 
    1260 
    1261     TYPE particle_type
    1262        SEQUENCE
    1263        REAL(wp)    ::  age, age_m, dt_sum, dvrp_psize, e_m, origin_x, origin_y, &
    1264                        origin_z, radius, rvar1, rvar2, rvar3, speed_x, speed_y, &
    1265                        speed_z, weight_factor, x, y, z
    1266        INTEGER(iwp) ::  class, group, tailpoints, tail_id
    1267     END TYPE particle_type
    1268 
    1269     TYPE(particle_type), DIMENSION(:), ALLOCATABLE ::  initial_particles
    1270     TYPE(particle_type), DIMENSION(:), ALLOCATABLE, TARGET ::  part_1, part_2
    1271     TYPE(particle_type), DIMENSION(:), POINTER  ::  particles
    1272 
    1273     TYPE particle_groups_type
    1274        SEQUENCE
    1275        REAL(wp)    ::  density_ratio, radius, exp_arg, exp_term
    1276     END TYPE particle_groups_type
    1277 
    1278     TYPE(particle_groups_type), DIMENSION(max_number_of_particle_groups) ::&
    1279                    particle_groups
    1280 
    1281     SAVE
    1282 
    1283  END MODULE particle_attributes
    1284 
    1285 
    1286 
    1287 
    12881189
    12891190 MODULE pegrid

  • TabularUnified palm/trunk/SOURCE/package_parin.f90

    r1341 r1359  
    2020! Current revisions:
    2121! -----------------
    22 !
     22! +alloc_factor, + min_nr_particle
     23! -dt_sort_particles, -maximum_number_of_particles
    2324!
    2425! Former revisions:
    … …  
    8081
    8182    USE particle_attributes,                                                   &
    82         ONLY:  bc_par_b, bc_par_lr, bc_par_ns, bc_par_t, collision_kernel,     &
    83                density_ratio, dissipation_classes, dt_min_part, dt_prel,       &
    84                dt_sort_particles, dt_write_particle_data, dvrp_psize,          &
     83        ONLY:  alloc_factor, bc_par_b, bc_par_lr, bc_par_ns, bc_par_t,         &
     84               collision_kernel, density_ratio, dissipation_classes,           &
     85               dt_min_part, dt_prel, dt_write_particle_data, dvrp_psize,       &
    8586               end_time_prel, initial_weighting_factor,                        &
    86                maximum_number_of_particles, maximum_number_of_tailpoints,      &
     87               maximum_number_of_tailpoints,                                   &
    8788               maximum_tailpoint_age, minimum_tailpoint_distance,              &
    88                number_of_particle_groups, particles_per_point,                 &
     89               min_nr_particle, number_of_particle_groups, particles_per_point,&
    8990               particle_advection, particle_advection_start, pdx, pdy, pdz,    &
    9091               psb, psl, psn, psr, pss, pst, radius, radius_classes,           &
    … …  
    118119                                  vc_size_y, vc_size_z
    119120
    120     NAMELIST /particles_par/      bc_par_b, bc_par_lr, bc_par_ns, bc_par_t,    &
    121                                   collision_kernel, density_ratio,             &
    122                                   dissipation_classes, dt_dopts,               &
    123                                   dt_min_part, dt_prel, dt_sort_particles,     &
     121    NAMELIST /particles_par/      alloc_factor, bc_par_b, bc_par_lr,           &
     122                                  bc_par_ns, bc_par_t, collision_kernel,       &
     123                                  density_ratio, dissipation_classes, dt_dopts,&
     124                                  dt_min_part, dt_prel,                        &
    124125                                  dt_write_particle_data,                      &
    125126                                  end_time_prel, initial_weighting_factor,     &
    126                                   maximum_number_of_particles,                 &
    127127                                  maximum_number_of_tailpoints,                &
    128128                                  maximum_tailpoint_age,                       &
    129129                                  minimum_tailpoint_distance,                  &
     130                                  min_nr_particle,                             &
    130131                                  number_of_particle_groups,                   &
    131132                                  particles_per_point,                         &

  • TabularUnified palm/trunk/SOURCE/parin.f90

    r1354 r1359  
    2020! Current revisions:
    2121! -----------------
    22 !
     22! REAL constants provided with KIND-attribute
    2323!
    2424! Former revisions:

  • TabularUnified palm/trunk/SOURCE/read_3d_binary.f90

    r1321 r1359  
    7777
    7878    USE control_parameters,                                                    &
    79         ONLY:  iran, humidity, passive_scalar, cloud_physics, cloud_droplets,  &
    80                icloud_scheme, message_string, outflow_l, outflow_n, outflow_r, &
    81                outflow_s, precipitation, ocean, topography
     79        ONLY:  iran, message_string, outflow_l, outflow_n, outflow_r, outflow_s
    8280
    8381    USE cpulog,                                                                &

  • TabularUnified palm/trunk/SOURCE/sum_up_3d_data.f90

    r1354 r1359  
    2020! Current revisions:
    2121! -----------------
    22 !
    23 ! 
     22! New particle structure integrated.
     23!
    2424! Former revisions:
    2525! -----------------
    … …  
    9292
    9393    USE particle_attributes,                                                   &
    94         ONLY:  particles, prt_count, prt_start_index
     94        ONLY:  grid_particles, number_of_particles, particles, prt_count
    9595
    9696    IMPLICIT NONE
    … …  
    104104
    105105    REAL(wp)     ::  mean_r !:
     106    REAL(wp)     ::  s_r2   !:
    106107    REAL(wp)     ::  s_r3   !:
    107     REAL(wp)     ::  s_r4   !:
    108108
    109109    CALL cpu_log (log_point(34),'sum_up_3d_data','start')
    … …  
    382382                DO  j = nys, nyn
    383383                   DO  k = nzb, nzt+1
    384                       psi = prt_start_index(k,j,i)
     384                      number_of_particles = prt_count(k,j,i)
     385                      IF ( number_of_particles <= 0 )  CYCLE
     386                      particles => grid_particles(k,j,i)%particles(1:number_of_particles)
     387                      s_r2 = 0.0_wp
    385388                      s_r3 = 0.0_wp
    386                       s_r4 = 0.0_wp
    387                       DO  n = psi, psi+prt_count(k,j,i)-1
    388                          s_r3 = s_r3 + particles(n)%radius**3 * &
    389                                        particles(n)%weight_factor
    390                          s_r4 = s_r4 + particles(n)%radius**4 * &
    391                                        particles(n)%weight_factor
     389
     390                      DO  n = 1, number_of_particles
     391                         IF ( particles(n)%particle_mask )  THEN
     392                            s_r2 = s_r2 + particles(n)%radius**2 * &
     393                                particles(n)%weight_factor
     394                            s_r3 = s_r3 + particles(n)%radius**3 * &
     395                                particles(n)%weight_factor
     396                         ENDIF
    392397                      ENDDO
    393                       IF ( s_r3 /= 0.0_wp )  THEN
    394                          mean_r = s_r4 / s_r3
     398
     399                      IF ( s_r2 > 0.0_wp )  THEN
     400                         mean_r = s_r3 / s_r2
    395401                      ELSE
    396402                         mean_r = 0.0_wp
    … …  
    401407             ENDDO
    402408
     409
    403410          CASE ( 'pr*' )
    404411             DO  i = nxlg, nxrg
    … …  
    478485                DO  j = nys, nyn
    479486                   DO  k = nzb, nzt+1
    480                       psi = prt_start_index(k,j,i)
    481                       DO  n = psi, psi+prt_count(k,j,i)-1
    482                          ql_vp_av(k,j,i) = ql_vp_av(k,j,i) + &
    483                                            particles(n)%weight_factor / &
    484                                            prt_count(k,j,i)
     487                      number_of_particles = prt_count(k,j,i)
     488                      IF ( number_of_particles <= 0 )  CYCLE
     489                      particles => grid_particles(k,j,i)%particles(1:number_of_particles)
     490                      DO  n = 1, number_of_particles
     491                         IF ( particles(n)%particle_mask )  THEN
     492                            ql_vp_av(k,j,i) = ql_vp_av(k,j,i) + &
     493                                              particles(n)%weight_factor / &
     494                                              number_of_particles
     495                         ENDIF
    485496                      ENDDO
    486497                   ENDDO

  • TabularUnified palm/trunk/SOURCE/user_lpm_advec.f90

    r1321 r1359  
    2020! Current revisions:
    2121! -----------------
    22 !
     22! New particle structure integrated.
    2323!
    2424! Former revisions:
    … …  
    5555    IMPLICIT NONE
    5656
    57     INTEGER(iwp) ::  n   !:
     57    INTEGER(iwp) ::  ip   !:
     58    INTEGER(iwp) ::  jp   !:
     59    INTEGER(iwp) ::  kp   !:
     60    INTEGER(iwp) ::  n    !:
    5861
    5962!
    6063!-- Here the user-defined actions follow
    61 !    DO  n = 1, number_of_initial_particles
    62 !    ENDDO
     64!     DO  ip = nxl, nxr
     65!        DO  jp = nys, nyn
     66!           DO  kp = nzb+1, nzt
     67!              number_of_particles = prt_count(kp,jp,ip)
     68!              particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
     69!              IF ( number_of_particles <= 0 )  CYCLE
     70!              DO  n = 1, number_of_particles
     71!
     72!              ENDDO
     73!           ENDDO
     74!        ENDDO
     75!     ENDDO
     76   
    6377
    6478 END SUBROUTINE user_lpm_advec

  • TabularUnified palm/trunk/SOURCE/user_lpm_init.f90

    r1321 r1359  
    2020! Current revisions:
    2121! -----------------
    22 !
     22! New particle structure integrated.
    2323!
    2424! Former revisions:
    … …  
    5555    IMPLICIT NONE
    5656
    57     INTEGER(iwp) ::  n   !:
     57    INTEGER(iwp) ::  ip   !:
     58    INTEGER(iwp) ::  jp   !:
     59    INTEGER(iwp) ::  kp   !:
     60    INTEGER(iwp) ::  n    !:
    5861
    5962!
    6063!-- Here the user-defined actions follow
    61 !    DO  n = 1, number_of_initial_particles
    62 !    ENDDO
     64!     DO  ip = nxl, nxr
     65!        DO  jp = nys, nyn
     66!           DO  kp = nzb+1, nzt
     67!              number_of_particles = prt_count(kp,jp,ip)
     68!              particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
     69!              IF ( number_of_particles <= 0 )  CYCLE
     70!              DO  n = 1, number_of_particles
     71!
     72!              ENDDO
     73!           ENDDO
     74!        ENDDO
     75!     ENDDO
    6376
    6477 END SUBROUTINE user_lpm_init

  • TabularUnified palm/trunk/SOURCE/user_lpm_set_attributes.f90

    r1321 r1359  
    2020! Current revisions:
    2121! -----------------
    22 !
     22! New particle structure integrated.
    2323!
    2424! Former revisions:
    … …  
    4747!------------------------------------------------------------------------------!
    4848
     49    USE indices,                                                               &
     50        ONLY:  nxl, nxr, nys, nyn, nzb, nzt
     51
    4952    USE kinds
    5053   
    … …  
    5558    IMPLICIT NONE
    5659
    57     INTEGER(iwp) ::  n   !:
     60    INTEGER(iwp) ::  ip   !:
     61    INTEGER(iwp) ::  jp   !:
     62    INTEGER(iwp) ::  kp   !:
     63    INTEGER(iwp) ::  n    !:
    5864
    5965!
    6066!-- Here the user-defined actions follow
    61 !    DO  n = 1, number_of_initial_particles
    62 !    ENDDO
     67!     DO  ip = nxl, nxr
     68!        DO  jp = nys, nyn
     69!           DO  kp = nzb+1, nzt
     70!              number_of_particles = prt_count(kp,jp,ip)
     71!              particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
     72!              IF ( number_of_particles <= 0 )  CYCLE
     73!              DO  n = 1, number_of_particles
     74!
     75!              ENDDO
     76!           ENDDO
     77!        ENDDO
     78!     ENDDO
     79   
    6380
    6481 END SUBROUTINE user_lpm_set_attributes

  • TabularUnified palm/trunk/SOURCE/write_3d_binary.f90

    r1353 r1359  
    2020! Current revisions:
    2121! -----------------
    22 !
     22! Bugfix using cloud_droplets solved. qc, qr*, nr* are no longer written in case
     23! of cloud_droplets = .TRUE.
    2324!
    2425! Former revisions:
    … …  
    160161       ENDIF
    161162       IF ( cloud_physics  .OR.  cloud_droplets )  THEN
    162           WRITE ( 14 )  'ql                  ';  WRITE ( 14 ) ql
     163          WRITE ( 14 )  'ql                  ';  WRITE ( 14 )  ql
    163164          IF ( ALLOCATED( ql_av ) )  THEN
    164165             WRITE ( 14 )  'ql_av               ';  WRITE ( 14 )  ql_av
    165166          ENDIF
    166           IF ( icloud_scheme == 0 )  THEN
    167              WRITE ( 14 )  'qc                  ';  WRITE ( 14 ) qc
     167          IF ( icloud_scheme == 0  .AND.  .NOT. cloud_droplets )  THEN
     168             WRITE ( 14 )  'qc                  ';  WRITE ( 14 )  qc
    168169             IF ( ALLOCATED( qc_av ) )  THEN
    169170                WRITE ( 14 )  'qc_av               ';  WRITE ( 14 )  qc_av
    170171             ENDIF
    171172             IF ( precipitation )  THEN
    172                 WRITE ( 14 )  'nr                  ';  WRITE ( 14 ) nr
     173                WRITE ( 14 )  'nr                  ';  WRITE ( 14 )  nr
    173174                IF ( ALLOCATED( nr_av ) )  THEN
    174175                   WRITE ( 14 )  'nr_av               ';  WRITE ( 14 )  nr_av
    175176                ENDIF
    176                 WRITE ( 14 )  'nrs                 ';  WRITE ( 14 ) nrs
    177                 WRITE ( 14 )  'nrsws               ';  WRITE ( 14 ) nrsws
    178                 WRITE ( 14 )  'nrswst              ';  WRITE ( 14 ) nrswst
    179                 WRITE ( 14 )  'qr                  ';  WRITE ( 14 ) qr
     177                WRITE ( 14 )  'nrs                 ';  WRITE ( 14 )  nrs
     178                WRITE ( 14 )  'nrsws               ';  WRITE ( 14 )  nrsws
     179                WRITE ( 14 )  'nrswst              ';  WRITE ( 14 )  nrswst
     180                WRITE ( 14 )  'qr                  ';  WRITE ( 14 )  qr
    180181                IF ( ALLOCATED( qr_av ) )  THEN
    181182                   WRITE ( 14 )  'qr_av               ';  WRITE ( 14 )  qr_av
    182183                ENDIF
    183                 WRITE ( 14 )  'qrs                 ';  WRITE ( 14 ) qrs
    184                 WRITE ( 14 )  'qrsws               ';  WRITE ( 14 ) qrsws
    185                 WRITE ( 14 )  'qrswst              ';  WRITE ( 14 ) qrswst
     184                WRITE ( 14 )  'qrs                 ';  WRITE ( 14 )  qrs
     185                WRITE ( 14 )  'qrsws               ';  WRITE ( 14 )  qrsws
     186                WRITE ( 14 )  'qrswst              ';  WRITE ( 14 )  qrswst
    186187             ENDIF
    187188          ENDIF
    188189       ENDIF
    189        WRITE ( 14 )  'qs                  ';  WRITE ( 14 ) qs
    190        WRITE ( 14 )  'qsws                ';  WRITE ( 14 ) qsws
     190       WRITE ( 14 )  'qs                  ';  WRITE ( 14 )  qs
     191       WRITE ( 14 )  'qsws                ';  WRITE ( 14 )  qsws
    191192       IF ( ALLOCATED( qsws_av ) )  THEN
    192193          WRITE ( 14 )  'qsws_av             ';  WRITE ( 14 )  qsws_av
Note: See TracChangeset for help on using the changeset viewer.
                                                                                                                                                                                                                                                                                                                                                                               
  | Impressum | ©Leibniz Universität Hannover |