Home


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

Ignore:
Timestamp:
Aug 25, 2020 12:11:17 PM (4 years ago)
Author:
raasch
Message:

files re-formatted to follow the PALM coding standard

File:
1 edited

Legend:

Unmodified
Added
Removed

  • palm/trunk/SOURCE/pmc_particle_interface.f90

    r4629 r4649  
    11MODULE pmc_particle_interface
    2 
    3 !------------------------------------------------------------------------------!
    4 ! This file is part of PALM.
    5 !
    6 ! PALM is free software: you can redistribute it and/or modify it under the
    7 ! terms of the GNU General Public License as published by the Free Software
    8 ! Foundation, either version 3 of the License, or (at your option) any later
    9 ! version.
    10 !
    11 ! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
    12 ! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
    13 ! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
    14 !
    15 ! You should have received a copy of the GNU General Public License along with
    16 ! PALM. If not, see <http://www.gnu.org/licenses/>.
     2!--------------------------------------------------------------------------------------------------!
     3! This file is part of the PALM model system.
     4!
     5! PALM is free software: you can redistribute it and/or modify it under the terms of the GNU General
     6! Public License as published by the Free Software Foundation, either version 3 of the License, or
     7! (at your option) any later version.
     8!
     9! PALM is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the
     10! implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General
     11! Public License for more details.
     12!
     13! You should have received a copy of the GNU General Public License along with PALM. If not, see
     14! <http://www.gnu.org/licenses/>.
    1715!
    1816! Copyright 1997-2020 Leibniz Universitaet Hannover
    19 !------------------------------------------------------------------------------!
     17!--------------------------------------------------------------------------------------------------!
     18!
    2019!
    2120! Current revisions:
    22 ! ------------------
     21! -----------------
    2322!
    2423!
    … …  
    2625! -----------------
    2726! $Id$
    28 ! support for MPI Fortran77 interface (mpif.h) removed
    29 !
     27! File re-formatted to follow the PALM coding standard
     28!
     29!
     30! 4629 2020-07-29 09:37:56Z raasch
     31! Support for MPI Fortran77 interface (mpif.h) removed
     32!
    3033! 4444 2020-03-05 15:59:50Z raasch
    31 ! bugfix: preprocessor directives for serial mode added
    32 ! 
     34! Bugfix: preprocessor directives for serial mode added
     35!
    3336! 4360 2020-01-07 11:25:50Z suehring
    3437! Corrected "Former revisions" section
    35 ! 
     38!
    3639! 4043 2019-06-18 16:59:00Z schwenkel
    3740! Remove min_nr_particle
    38 ! 
     41!
    3942! 4017 2019-06-06 12:16:46Z schwenkel
    40 ! coarse bound renamed as parent_bound and icl, icr, jcs, jcn as ipl, ipr, jps, jpn.
    41 ! 
     43! Coarse bound renamed as parent_bound and icl, icr, jcs, jcn as ipl, ipr, jps, jpn.
     44!
    4245! 3883 2019-04-10 12:51:50Z hellstea
    43 ! Function get_number_of_childs renamed to get_number_of_children and cg
    44 ! renamed to pg according to their definitions in pmc_interface_mod
    45 ! 
     46! Function get_number_of_childs renamed to get_number_of_children and cg renamed to pg according to
     47! their definitions in pmc_interface_mod
     48!
    4649! 3655 2019-01-07 16:51:22Z knoop
    47 ! unused variables removed
     50! Unused variables removed
    4851!
    4952! Initial Version (by Klaus Ketelsen)
    5053!
    51 ! 
    52 ! Description:
    53 ! ------------
    54 ! Introduce particle transfer in nested models.
    55 ! Interface to palm lpm model to handel particle transfer between parent and
    56 ! child model.
    57 !------------------------------------------------------------------------------!
     54!
     55!--------------------------------------------------------------------------------------------------!
     56! Description:
     57! ------------
     58! Introduce particle transfer in nested models.
     59! Interface to palm lpm model to handel particle transfer between parent and child model.
     60!--------------------------------------------------------------------------------------------------!
    5861#if defined( __parallel )
    5962
    … …  
    6467   USE kinds
    6568
    66    USE pegrid,                                                                 &
    67        ONLY: myidx,myidy
    68 
    69    USE indices,                                                                &
    70        ONLY: nx, ny, nxl, nxr, nys, nyn, nzb, nzt, nxlg, nxrg, nysg, nyng, nbgp
    71 
    72    USE grid_variables,                                                         &
    73        ONLY:  dx, dy
    74 
    75    USE arrays_3d,                                                              &
     69   USE pegrid,                                                                                     &
     70       ONLY: myidx,                                                                                &
     71             myidy
     72
     73   USE indices,                                                                                    &
     74       ONLY: nbgp,                                                                                 &
     75             nx,                                                                                   &
     76             nxl,                                                                                  &
     77             nxr,                                                                                  &
     78             nxlg,                                                                                 &
     79             nxrg,                                                                                 &
     80             ny,                                                                                   &
     81             nys,                                                                                  &
     82             nyn,                                                                                  &
     83             nysg,                                                                                 &
     84             nyng,                                                                                 &
     85             nzb,                                                                                  &
     86             nzt
     87
     88
     89   USE grid_variables,                                                                             &
     90       ONLY:  dx,                                                                                  &
     91              dy
     92
     93   USE arrays_3d,                                                                                  &
    7694        ONLY: zw
    7795
    78    USE control_parameters,                                                     &
     96   USE control_parameters,                                                                         &
    7997       ONLY:  message_string
    8098
    81    USE particle_attributes,                                                    &
    82        ONLY:  prt_count, particles, grid_particles,                            &
    83               particle_type, number_of_particles, zero_particle,               &
    84               ibc_par_t, ibc_par_lr, ibc_par_ns, alloc_factor
     99   USE particle_attributes,                                                                        &
     100       ONLY:  alloc_factor,                                                                        &
     101              grid_particles,                                                                      &
     102              ibc_par_lr,                                                                          &
     103              ibc_par_ns,                                                                          &
     104              ibc_par_t,                                                                           &
     105              particles,                                                                           &
     106              particle_type,                                                                       &
     107              prt_count,                                                                           &
     108              number_of_particles,                                                                 &
     109              zero_particle
     110
     111
     112
     113
    85114
    86115!    USE lpm_pack_and_sort_mod
    87116
    88117#if defined( __parallel )
    89    USE pmc_general,                                                            &
     118   USE pmc_general,                                                                                &
    90119       ONLY: pedef
    91120
    92    USE pmc_parent,                                                             &
    93        ONLY: children, pmc_s_fillbuffer, pmc_s_getdata_from_buffer,            &
     121   USE pmc_parent,                                                                                 &
     122       ONLY: children,                                                                             &
     123             pmc_s_fillbuffer,                                                                     &
     124             pmc_s_getdata_from_buffer,                                                            &
    94125             pmc_s_get_child_npes
    95126
    96    USE pmc_child,                                                              &
    97        ONLY:  me, pmc_c_getbuffer, pmc_c_putbuffer
    98 
    99    USE pmc_interface,                                                          &
    100        ONLY: cpl_id, get_number_of_children, nr_part, part_adr, nested_run,    &
    101              get_childid, get_child_edges, nr_partc, part_adrc,                &
    102              parent_bound, coord_x, coord_y, pg, get_child_gridspacing,        &
    103              lower_left_coord_x, lower_left_coord_y
    104 
    105     USE pmc_handle_communicator,                                               &
     127   USE pmc_child,                                                                                  &
     128       ONLY:  me,                                                                                  &
     129              pmc_c_getbuffer,                                                                     &
     130              pmc_c_putbuffer
     131
     132   USE pmc_interface,                                                                              &
     133       ONLY:  coord_x,                                                                             &
     134              coord_y,                                                                             &
     135              cpl_id,                                                                              &
     136              get_childid,                                                                         &
     137              get_child_edges,                                                                     &
     138              get_child_gridspacing,                                                               &
     139              get_number_of_children,                                                              &
     140              lower_left_coord_x,                                                                  &
     141              lower_left_coord_y,                                                                  &
     142              nr_part,                                                                             &
     143              nr_partc,                                                                            &
     144              parent_bound,                                                                        &
     145              part_adr,                                                                            &
     146              part_adrc,                                                                           &
     147              pg,                                                                                  &
     148              nested_run
     149
     150
     151    USE pmc_handle_communicator,                                                                   &
    106152        ONLY:  pmc_parent_for_child
    107153
    108    USE pmc_mpi_wrapper,                                                        &
    109        ONLY: pmc_send_to_parent, pmc_recv_from_child
     154   USE pmc_mpi_wrapper,                                                                            &
     155       ONLY:   pmc_recv_from_child,                                                                &
     156               pmc_send_to_parent
    110157
    111158#endif
    … …  
    118165
    119166   TYPE  coarse_particle_def
    120       INTEGER(iwp) ::  nr_particle
    121      
    122       TYPE(particle_type),ALLOCATABLE,DIMENSION(:) ::  parent_particles
     167      INTEGER(iwp) ::  nr_particle  !<
     168
     169      TYPE(particle_type),ALLOCATABLE,DIMENSION(:) ::  parent_particles  !<
    123170   END TYPE  coarse_particle_def
    124171
    125    INTEGER(iwp),PARAMETER ::  Min_particles_per_column = 100      !<
    126    INTEGER(iwp),PARAMETER ::  max_nr_particle_in_rma_win = 100000 !<
    127 
    128    INTEGER(iwp) ::  nr_fine_in_coarse  !< Number of fine grid cells in coarse grid (one direction)
    129    INTEGER(iwp) ::  particle_win_child !<
    130 
    131    INTEGER(iwp),ALLOCATABLE,DIMENSION(:) ::  particle_win_parent !<
    132    
    133    TYPE(C_PTR), ALLOCATABLE,DIMENSION(:) ::  buf_ptr !<
    134    
    135    TYPE(particle_type), DIMENSION(:),POINTER ::  particle_in_win !<
    136 
    137    TYPE(coarse_particle_def),ALLOCATABLE,DIMENSION(:,:) ::  coarse_particles !<
    138 
    139    
     172   INTEGER(iwp),PARAMETER ::  max_nr_particle_in_rma_win = 100000  !<
     173   INTEGER(iwp),PARAMETER ::  min_particles_per_column   = 100     !<
     174
     175
     176   INTEGER(iwp) ::  nr_fine_in_coarse   !< Number of fine grid cells in coarse grid (one direction)
     177   INTEGER(iwp) ::  particle_win_child  !<
     178
     179   INTEGER(iwp),ALLOCATABLE,DIMENSION(:) ::  particle_win_parent  !<
     180
     181   TYPE(C_PTR), ALLOCATABLE,DIMENSION(:) ::  buf_ptr  !<
     182
     183   TYPE(particle_type), DIMENSION(:),POINTER ::  particle_in_win  !<
     184
     185   TYPE(coarse_particle_def),ALLOCATABLE,DIMENSION(:,:) ::  coarse_particles  !<
     186
     187
    140188
    141189   INTERFACE pmcp_g_init
    … …  
    177225 CONTAINS
    178226
    179 !------------------------------------------------------------------------------!
    180 ! Description:
    181 ! ------------
    182 !> general routine:
    183 !> Initializing actions of the particle interface
    184 !> check particle boundary conditions for the child models
    185 !------------------------------------------------------------------------------!
     227!--------------------------------------------------------------------------------------------------!
     228! Description:
     229! ------------
     230!> General routine:
     231!> Initializing actions of the particle interface check particle boundary conditions for the child
     232!> models
     233!--------------------------------------------------------------------------------------------------!
    186234 SUBROUTINE pmcp_g_init
    187  
     235
    188236    IMPLICIT NONE
    189  
    190     INTEGER(iwp) ::  nr_childs !< Number of child models of the current model
     237
     238    INTEGER(iwp) ::  nr_childs  !< Number of child models of the current model
    191239
    192240#if defined( __parallel )
    … …  
    195243!
    196244!-- Check if the current model has child models
    197     IF ( nr_childs > 0 )   THEN
     245    IF ( nr_childs > 0 )  THEN
    198246       ALLOCATE( nr_part(nysg:nyng, nxlg:nxrg) )
    199247       ALLOCATE( part_adr(nysg:nyng, nxlg:nxrg) )
    200        nr_part = 0
    201        part_adr   = 0
     248       nr_part  = 0
     249       part_adr = 0
    202250    ENDIF
    203251
    204252!
    205253!-- Set the boundary conditions to nested for all non root (i.e child) models
    206     IF ( cpl_id > 1 )  THEN 
    207    
    208        IF ( ibc_par_t /= 3 )   THEN
     254    IF ( cpl_id > 1 )  THEN
     255
     256       IF ( ibc_par_t /= 3 )  THEN
    209257          ibc_par_t  = 3
    210258          message_string = 'In Child model:  ibc_par_t is automatically set to nested '
    211259          CALL message( 'pmcp_g_init ', 'PA0477', 0, 1, 0, 6, 0 )
    212260       ENDIF
    213    
    214        IF ( ibc_par_lr /= 3 )   THEN
     261
     262       IF ( ibc_par_lr /= 3 )  THEN
    215263          ibc_par_lr = 3
    216264          message_string = 'In Child model:  ibc_par_lr is automatically set to nested '
    217265          CALL message( 'pmcp_g_init ', 'PA0478', 0, 1, 0, 6, 0 )
    218266       ENDIF
    219        
    220        IF ( ibc_par_ns /= 3 )   THEN
     267
     268       IF ( ibc_par_ns /= 3 )  THEN
    221269          ibc_par_ns = 3
    222270          message_string = 'In Child model:  ibc_par_ns is automatically set to nested '
    223271          CALL message( 'pmcp_g_init ', 'PA0479', 0, 1, 0, 6, 0 )
    224272       ENDIF
    225        
     273
    226274    ENDIF
    227275
    228276#endif
    229277 END SUBROUTINE pmcp_g_init
    230 !------------------------------------------------------------------------------!
    231 ! Description:
    232 ! ------------
    233 !> general routine:
    234 !> allocate the MPI windows
    235 !------------------------------------------------------------------------------!
     278!--------------------------------------------------------------------------------------------------!
     279! Description:
     280! ------------
     281!> General routine:
     282!> Allocate the MPI windows
     283!--------------------------------------------------------------------------------------------------!
    236284 SUBROUTINE pmcp_g_alloc_win
    237  
     285
    238286    IMPLICIT NONE
    239    
    240     INTEGER(iwp) ::  m         !< loop index
    241     INTEGER(iwp) ::  ierr      !< error code
    242     INTEGER(iwp) ::  ipl       !< left boundary in coarse(parent) index space
    243     INTEGER(iwp) ::  ipr       !< right boundary in coarse(parent) index space
    244     INTEGER(iwp) ::  jps       !< south boundary in coarse(parent) index space
    245     INTEGER(iwp) ::  jpn       !< north boundary in coarse(parent) index space
    246     INTEGER(iwp) ::  child_id  !< Id of a child model
    247     INTEGER(iwp) ::  nr_childs !< Number of child models of the current model
    248    
    249     INTEGER ::  parsize !<
    250     TYPE(C_PTR), SAVE ::  ptr !<
    251    
    252     TYPE(particle_type),DIMENSION(:),POINTER ::  win_buffer !<
    253    
    254     INTEGER(iwp),DIMENSION(1) ::  buf_shape !<
    255 
    256 #if defined( __parallel )
    257     INTEGER(KIND=MPI_ADDRESS_KIND) ::  parsize_mpi_address_kind !<
    258     INTEGER(KIND=MPI_ADDRESS_KIND) ::  winsize !<
     287
     288    INTEGER(iwp) ::  child_id   !< Id of a child model
     289    INTEGER(iwp) ::  ierr       !< error code
     290    INTEGER(iwp) ::  ipl        !< left boundary in coarse(parent) index space
     291    INTEGER(iwp) ::  ipr        !< right boundary in coarse(parent) index space
     292    INTEGER(iwp) ::  jps        !< south boundary in coarse(parent) index space
     293    INTEGER(iwp) ::  jpn        !< north boundary in coarse(parent) index space
     294    INTEGER(iwp) ::  m          !< loop index
     295    INTEGER(iwp) ::  nr_childs  !< Number of child models of the current model
     296
     297    INTEGER ::  parsize  !<
     298
     299    INTEGER(iwp),DIMENSION(1) ::  buf_shape  !<
     300
     301    TYPE(C_PTR), SAVE ::  ptr  !<
     302
     303    TYPE(particle_type),DIMENSION(:),POINTER ::  win_buffer  !<
     304
     305
     306#if defined( __parallel )
     307    INTEGER(KIND=MPI_ADDRESS_KIND) ::  parsize_mpi_address_kind  !<
     308    INTEGER(KIND=MPI_ADDRESS_KIND) ::  winsize                   !<
    259309
    260310!
    261311!-- If the model has a parent model prepare the structures for transfer
    262     IF ( cpl_id > 1 )  THEN 
    263 
    264        parsize_mpi_address_kind = STORAGE_SIZE(zero_particle)/8
     312    IF ( cpl_id > 1 )  THEN
     313
     314       parsize_mpi_address_kind = STORAGE_SIZE(zero_particle) / 8
    265315
    266316       CALL MPI_ALLOC_MEM( parsize_mpi_address_kind , MPI_INFO_NULL, ptr, ierr )
    … …  
    268318       buf_shape(1) = 1
    269319       CALL C_F_POINTER( ptr, win_buffer, buf_shape )
    270        CALL MPI_WIN_CREATE( win_buffer, parsize_mpi_address_kind, parsize,     &
    271                             MPI_INFO_NULL, me%intra_comm, particle_win_child,  &
    272                             ierr )
     320       CALL MPI_WIN_CREATE( win_buffer, parsize_mpi_address_kind, parsize, MPI_INFO_NULL,          &
     321                            me%intra_comm, particle_win_child, ierr )
    273322
    274323!
    … …  
    292341       DO  m = 1, nr_childs
    293342          child_id = get_childid(m)
    294           parsize_mpi_address_kind = STORAGE_SIZE(zero_particle)/8
     343          parsize_mpi_address_kind = STORAGE_SIZE(zero_particle) / 8
    295344          parsize = parsize_mpi_address_kind
    296345
    … …  
    299348          buf_shape(1) = max_nr_particle_in_rma_win
    300349          CALL C_F_POINTER( buf_ptr(m), win_buffer, buf_shape )
    301           CALL MPI_WIN_CREATE( win_buffer, winsize, parsize, MPI_INFO_NULL,    &
    302                                children(child_id)%intra_comm,                  &
    303                                particle_win_parent(m), ierr )
     350          CALL MPI_WIN_CREATE( win_buffer, winsize, parsize, MPI_INFO_NULL,                        &
     351                               children(child_id)%intra_comm, particle_win_parent(m), ierr )
    304352          ENDDO
    305353    ENDIF
    … …  
    309357
    310358
    311 !------------------------------------------------------------------------------!
    312 ! Description:
    313 ! ------------
    314 !> child routine:
    315 !> Read/get particles out of the parent MPI window 
    316 !------------------------------------------------------------------------------!
     359!--------------------------------------------------------------------------------------------------!
     360! Description:
     361! ------------
     362!> Child routine:
     363!> Read/get particles out of the parent MPI window
     364!--------------------------------------------------------------------------------------------------!
    317365 SUBROUTINE pmcp_c_get_particle_from_parent
    318  
     366
    319367    IMPLICIT NONE
    320368
    321     INTEGER(iwp) ::  i    !< x grid index
    322     INTEGER(iwp) ::  ipl  !< left boundary in coarse(parent) index space
    323     INTEGER(iwp) ::  ierr !< error code
    324     INTEGER(iwp) ::  ij   !< combined xy index for the buffer array
    325     INTEGER(iwp) ::  ip   !< loop index (child PEs)
    326     INTEGER(iwp) ::  j    !< y grid index
    327     INTEGER(iwp) ::  jps  !< south boundary in coarse(parent) index space
    328     INTEGER(iwp) ::  nr   !< number of particles to receive from a parent box
    329    
     369    INTEGER(iwp) ::  i     !< x grid index
     370    INTEGER(iwp) ::  ierr  !< error code
     371    INTEGER(iwp) ::  ij    !< combined xy index for the buffer array
     372    INTEGER(iwp) ::  ip    !< loop index (child PEs)
     373    INTEGER(iwp) ::  ipl   !< left boundary in coarse(parent) index space
     374    INTEGER(iwp) ::  j     !< y grid index
     375    INTEGER(iwp) ::  jps   !< south boundary in coarse(parent) index space
     376    INTEGER(iwp) ::  nr    !< number of particles to receive from a parent box
     377
    330378    INTEGER ::  parsize !<
    331379
    332380#if defined( __parallel )
    333     TYPE(pedef), POINTER ::  ape !< TO_DO Klaus: give a description and better name of the variable
    334 
    335     INTEGER(KIND=MPI_ADDRESS_KIND) ::  parsize_mpi_address_kind !<
    336     INTEGER(KIND=MPI_ADDRESS_KIND) ::  target_disp !<
     381    TYPE(pedef), POINTER ::  ape  !< TO_DO Klaus: give a description and better name of the variable
     382
     383    INTEGER(KIND=MPI_ADDRESS_KIND) ::  parsize_mpi_address_kind  !<
     384    INTEGER(KIND=MPI_ADDRESS_KIND) ::  target_disp               !<
    337385
    338386    IF ( cpl_id > 1 )  THEN
    339    
     387
    340388       CALL pmc_c_getbuffer( particle_transfer = .TRUE. ) !Get number of particle/column and offset in RMA window xx
    341389
    … …  
    343391!--    Wait for buffer to fill.
    344392!
    345 !--    The parent side (in pmc_s_fillbuffer) is filling the buffer in the MPI RMA window
    346 !--    When the filling is complete, a MPI_BARRIER is called.
    347 !--    The child is not allowd to access the parent-buffer before it is completely filled
    348 !--    Synchronization is done implicitely in pmc_c_getbuffer and pmc_s_fillbuffer on the parent side
     393!--    The parent side (in pmc_s_fillbuffer) is filling the buffer in the MPI RMA window. When the
     394!--    filling is complete, a MPI_BARRIER is called. The child is not allowd to access the
     395!--    parent-buffer before it is completely filled. Synchronization is done implicitely in
     396!--    pmc_c_getbuffer and pmc_s_fillbuffer on the parent side.
    349397
    350398       ipl = parent_bound(1)
    … …  
    356404
    357405          DO  ij = 1, ape%nrele
    358               j = ape%locind(ij)%j + jps - 1
    359               i = ape%locind(ij)%i + ipl - 1
     406              j  = ape%locind(ij)%j + jps - 1
     407              i  = ape%locind(ij)%i + ipl - 1
    360408              nr = nr_partc(j,i)
    361409              IF ( nr > 0 )  THEN
    362410
    363411                 CALL check_and_alloc_coarse_particle (i, j, nr)
    364                  parsize_mpi_address_kind = STORAGE_SIZE(zero_particle)/8
     412                 parsize_mpi_address_kind = STORAGE_SIZE(zero_particle) / 8
    365413                 parsize = parsize_mpi_address_kind
    366414                 target_disp = part_adrc(j,i) - 1
    367                  CALL MPI_WIN_LOCK( MPI_LOCK_SHARED , ip - 1, 0,               &
    368                                     particle_win_child, ierr )
    369                  CALL MPI_GET( coarse_particles(j,i)%parent_particles,         &
    370                                nr * parsize, MPI_BYTE, ip - 1, target_disp,    &
    371                                nr * parsize, MPI_BYTE, particle_win_child, ierr )
     415                 CALL MPI_WIN_LOCK( MPI_LOCK_SHARED , ip - 1, 0, particle_win_child, ierr )
     416                 CALL MPI_GET( coarse_particles(j,i)%parent_particles, nr * parsize, MPI_BYTE,     &
     417                               ip - 1, target_disp, nr * parsize, MPI_BYTE, particle_win_child,    &
     418                               ierr )
    372419                 CALL MPI_WIN_UNLOCK( ip - 1, particle_win_child, ierr )
    373420             ENDIF
    … …  
    383430
    384431
    385 !------------------------------------------------------------------------------!
    386 ! Description:
    387 ! ------------
    388 !> child routine:
     432!--------------------------------------------------------------------------------------------------!
     433! Description:
     434! ------------
     435!> Child routine:
    389436!> Write/put particles into the parent MPI window
    390 !------------------------------------------------------------------------------!
    391   SUBROUTINE pmcp_c_send_particle_to_parent
    392  
     437!--------------------------------------------------------------------------------------------------!
     438 SUBROUTINE pmcp_c_send_particle_to_parent
     439
    393440    IMPLICIT NONE
    394    
    395     INTEGER(iwp) ::  disp_offset            !<
    396     INTEGER(iwp) ::  i                      !< x loop index
    397     INTEGER(iwp) ::  ipl                    !< left boundary in coarse(parent) index space
    398     INTEGER(iwp) ::  ipr                    !< right boundary in coarse(parent) index space
    399     INTEGER(iwp) ::  ierr                   !< error code
    400     INTEGER(iwp) ::  ij                     !< combined xy index for the buffer array
    401     INTEGER(iwp) ::  ip                     !< loop index (child PEs)
    402     INTEGER(iwp) ::  j                      !< y loop index
    403     INTEGER(iwp) ::  jps                    !< south boundary in coarse(parent) index space
    404     INTEGER(iwp) ::  jpn                    !< north boundary in coarse(parent) index space
    405     INTEGER(iwp) ::  max_nr_particle_per_pe !< maximum number of particles per PE (depending on grid apect ratio)
    406     INTEGER(iwp) ::  n                      !< shorter variable name for nr_fine_in_coarse
    407     INTEGER(iwp) ::  nr                     !< shorter variabel name for nr_partc
    408     INTEGER(iwp) ::  pe_offset              !< offset index of the current PE
    409    
    410     INTEGER ::  parsize !<
    411    
    412     REAL(wp) ::  eps=0.00001 !< used in calculations to avoid rounding errors
    413     REAL(wp) ::  xx          !< number of fine grid cells inside a coarse grid cell in x-direction
    414     REAL(wp) ::  yy          !< number of fine grid cells inside a coarse grid cell in y-direction
     441
     442    INTEGER(iwp) ::  disp_offset             !<
     443    INTEGER(iwp) ::  i                       !< x loop index
     444    INTEGER(iwp) ::  ierr                    !< error code
     445    INTEGER(iwp) ::  ij                      !< combined xy index for the buffer array
     446    INTEGER(iwp) ::  ip                      !< loop index (child PEs)
     447    INTEGER(iwp) ::  ipl                     !< left boundary in coarse(parent) index space
     448    INTEGER(iwp) ::  ipr                     !< right boundary in coarse(parent) index space
     449    INTEGER(iwp) ::  j                       !< y loop index
     450    INTEGER(iwp) ::  jpn                     !< north boundary in coarse(parent) index space
     451    INTEGER(iwp) ::  jps                     !< south boundary in coarse(parent) index space
     452    INTEGER(iwp) ::  max_nr_particle_per_pe  !< maximum number of particles per PE (depending on grid apect ratio)
     453    INTEGER(iwp) ::  n                       !< shorter variable name for nr_fine_in_coarse
     454    INTEGER(iwp) ::  nr                      !< shorter variabel name for nr_partc
     455    INTEGER(iwp) ::  pe_offset               !< offset index of the current PE
     456
     457    INTEGER ::  parsize  !<
     458
     459    REAL(wp) ::  eps=0.00001  !< used in calculations to avoid rounding errors
     460    REAL(wp) ::  xx           !< number of fine grid cells inside a coarse grid cell in x-direction
     461    REAL(wp) ::  yy           !< number of fine grid cells inside a coarse grid cell in y-direction
    415462
    416463 !   TYPE(particle_type) ::  dummy_part !< dummy particle (needed for size calculations)
    417464
    418465#if defined( __parallel )
    419     TYPE(pedef), POINTER ::  ape !< TO_DO Klaus: give a description and better name of the variable
    420 
    421     INTEGER(KIND=MPI_ADDRESS_KIND) ::  parsize_mpi_address_kind !<
    422     INTEGER(KIND=MPI_ADDRESS_KIND) ::  target_disp !<
    423    
    424    
     466    TYPE(pedef), POINTER ::  ape  !< TO_DO Klaus: give a description and better name of the variable
     467
     468    INTEGER(KIND=MPI_ADDRESS_KIND) ::  parsize_mpi_address_kind  !<
     469    INTEGER(KIND=MPI_ADDRESS_KIND) ::  target_disp               !<
     470
     471
    425472    IF ( cpl_id > 1 )  THEN
    426473       CALL c_copy_particle_to_coarse_grid
    … …  
    435482
    436483       nr_partc = 0
    437        
     484
    438485       DO i = ipl, ipr
    439486          DO j = jps, jpn
    … …  
    444491
    445492!
    446 !--    compute number of fine grid cells in coarse grid (one direction)
     493!--    Compute number of fine grid cells in coarse grid (one direction)
    447494       xx = ( pg%dx + eps ) / dx ! +eps to avoid rounding error
    448495       yy = ( pg%dy + eps ) / dy
    449        nr_fine_in_coarse = MAX( INT(xx), INT(yy) )
    450 
    451        IF ( MOD( coord_x(0), pg%dx ) /= 0.0 .OR. MOD( coord_y(0), pg%dy ) /= 0.0 ) THEN
     496       nr_fine_in_coarse = MAX( INT( xx ), INT( yy ) )
     497
     498       IF ( MOD( coord_x(0), pg%dx ) /= 0.0 .OR. MOD( coord_y(0), pg%dy ) /= 0.0 )  THEN
    452499          nr_fine_in_coarse = nr_fine_in_coarse + 1
    453500       ENDIF
    … …  
    457504!--    With this number a square of child PEs is defined which share the same coarse grid cells
    458505
    459        n           = nr_fine_in_coarse ! local variable n to make folloing statements shorter
     506       n           = nr_fine_in_coarse ! Local variable n to make folloing statements shorter
    460507       pe_offset   = MOD( myidx, n ) * n + MOD( myidy, n)
    461508       max_nr_particle_per_pe = max_nr_particle_in_rma_win / ( n * n )
    462509       disp_offset            = pe_offset * max_nr_particle_per_pe
    463        parsize_mpi_address_kind = STORAGE_SIZE(zero_particle)/8
     510       parsize_mpi_address_kind = STORAGE_SIZE(zero_particle) /8
    464511       parsize = parsize_mpi_address_kind
    465512       DO  ip = 1, me%inter_npes
    … …  
    468515
    469516          target_disp = disp_offset
    470           DO ij = 1, ape%nrele
     517          DO  ij = 1, ape%nrele
    471518             j  = ape%locind(ij)%j + jps - 1
    472519             i  = ape%locind(ij)%i + ipl - 1
    473520             nr = nr_partc(j,i)
    474              IF( nr > 0 ) THEN
    475                 IF ( target_disp + nr - disp_offset >= max_nr_particle_per_pe ) THEN
    476                    WRITE(9,*) 'RMA window too small on child ',                &
    477                               target_disp + nr - disp_offset,                  &
    478                               max_nr_particle_per_pe, max_nr_particle_in_rma_win
     521             IF( nr > 0 )  THEN
     522                IF ( target_disp + nr - disp_offset >= max_nr_particle_per_pe )  THEN
     523                   WRITE( 9, * ) 'RMA window too small on child ',                                 &
     524                                 target_disp + nr - disp_offset, max_nr_particle_per_pe,           &
     525                                max_nr_particle_in_rma_win
    479526                   message_string = 'RMA window too small on child'
    480527                   CALL message( 'pmci_create_child_arrays', 'PA0480', 3, 2, 0, 6, 0 )
    481528                ENDIF
    482                 CALL MPI_WIN_LOCK( MPI_LOCK_SHARED , ip - 1, 0,                &
    483                                    particle_win_child, ierr )
    484                 CALL MPI_PUT( coarse_particles(j,i)%parent_particles,          &
    485                               nr * parsize, MPI_BYTE, ip - 1, target_disp,     &
    486                               nr * parsize, MPI_BYTE,  particle_win_child, ierr )
     529                CALL MPI_WIN_LOCK( MPI_LOCK_SHARED , ip - 1, 0, particle_win_child, ierr )
     530                CALL MPI_PUT( coarse_particles(j,i)%parent_particles, nr * parsize, MPI_BYTE,      &
     531                              ip - 1, target_disp, nr * parsize, MPI_BYTE,  particle_win_child,    &
     532                              ierr )
    487533                CALL MPI_WIN_UNLOCK( ip - 1, particle_win_child, ierr )
    488534                part_adrc(j,i) = target_disp + 1
    … …  
    500546
    501547
    502 !------------------------------------------------------------------------------!
    503 ! Description:
    504 ! ------------
    505 !> parent routine:
    506 !> write particles into the MPI window
    507 !------------------------------------------------------------------------------!
     548!--------------------------------------------------------------------------------------------------!
     549! Description:
     550! ------------
     551!> Parent routine:
     552!> Write particles into the MPI window
     553!--------------------------------------------------------------------------------------------------!
    508554 SUBROUTINE pmcp_p_fill_particle_win
    509  
     555
    510556    IMPLICIT NONE
    511557
    512     LOGICAL      ::  active_particle !< Particles located in the fine/child grid area are marked as active (to be transferred)
    513     LOGICAL,SAVE ::  lfirst = .TRUE. !<
    514    
    515     INTEGER(iwp) ::  child_id            !< id of the child model
    516     INTEGER(iwp) ::  i                   !< x grid box index
    517     INTEGER(iwp) ::  ij                  !< combined xy index for the buffer array
    518     INTEGER(iwp) ::  ip                  !< loop index (child PEs)
    519     INTEGER(iwp) ::  j                   !< y grid box index
    520     INTEGER(iwp) ::  k                   !< z grid box index
    521     INTEGER(iwp) ::  m                   !< loop index (number of childs)
    522     INTEGER(iwp) ::  n                   !< loop index (number of particles)
    523     INTEGER(iwp) ::  nr_part_col         !< Number of particles to transfer per column
    524     INTEGER(iwp) ::  number_of_particles !<
    525     INTEGER(iwp) ::  pindex              !<
    526     INTEGER(iwp) ::  tot_particle_count  !< Total number of particles per child
    527    
    528     REAL(wp) ::  dx_child   !< child grid spacing
    529     REAL(wp) ::  dy_child   !< child grid spacing
    530     REAL(wp) ::  dz_child   !< child grid spacing
    531     REAL(wp) ::  ny_coord   !< north coordinate of child grid
    532     REAL(wp) ::  ny_coord_b !< north coordinate of child grid boundary
    533     REAL(wp) ::  lx_coord   !< left coordinate of child grid
    534     REAL(wp) ::  lx_coord_b !< left coordinate of child grid boundary
    535     REAL(wp) ::  rx_coord   !< right coordinate of child grid
    536     REAL(wp) ::  rx_coord_b !< right coordinate of child grid boundary
    537     REAL(wp) ::  sy_coord   !< south coordinate of child grid
    538     REAL(wp) ::  sy_coord_b !< south coordinate of child grid boundary
    539     REAL(wp) ::  uz_coord   !< upper coordinate of child grid
    540     REAL(wp) ::  uz_coord_b !< upper coordinate of child grid boundary
    541     REAL(wp) ::  x          !< particle position
    542     REAL(wp) ::  y          !< particle position
    543     REAL(wp) ::  z          !< particle position
    544    
    545     INTEGER(iwp),DIMENSION(1) ::  buf_shape !<
    546    
    547 #if defined( __parallel )
    548     TYPE(pedef), POINTER ::  ape !< TO_DO Klaus: give a description and better name of the variable
     558    INTEGER(iwp) ::  child_id             !< id of the child model
     559    INTEGER(iwp) ::  i                    !< x grid box index
     560    INTEGER(iwp) ::  ij                   !< combined xy index for the buffer array
     561    INTEGER(iwp) ::  ip                   !< loop index (child PEs)
     562    INTEGER(iwp) ::  j                    !< y grid box index
     563    INTEGER(iwp) ::  k                    !< z grid box index
     564    INTEGER(iwp) ::  m                    !< loop index (number of childs)
     565    INTEGER(iwp) ::  n                    !< loop index (number of particles)
     566    INTEGER(iwp) ::  nr_part_col          !< Number of particles to transfer per column
     567    INTEGER(iwp) ::  number_of_particles  !<
     568    INTEGER(iwp) ::  pindex               !<
     569    INTEGER(iwp) ::  tot_particle_count   !< Total number of particles per child
     570
     571    INTEGER(iwp),DIMENSION(1) ::  buf_shape  !<
     572
     573    LOGICAL      ::  active_particle  !< Particles located in the fine/child grid area are marked as active (to be transferred)
     574    LOGICAL,SAVE ::  lfirst = .TRUE.  !<
     575
     576    REAL(wp) ::  dx_child    !< child grid spacing
     577    REAL(wp) ::  dy_child    !< child grid spacing
     578    REAL(wp) ::  dz_child    !< child grid spacing
     579    REAL(wp) ::  ny_coord    !< north coordinate of child grid
     580    REAL(wp) ::  ny_coord_b  !< north coordinate of child grid boundary
     581    REAL(wp) ::  lx_coord    !< left coordinate of child grid
     582    REAL(wp) ::  lx_coord_b  !< left coordinate of child grid boundary
     583    REAL(wp) ::  rx_coord    !< right coordinate of child grid
     584    REAL(wp) ::  rx_coord_b  !< right coordinate of child grid boundary
     585    REAL(wp) ::  sy_coord    !< south coordinate of child grid
     586    REAL(wp) ::  sy_coord_b  !< south coordinate of child grid boundary
     587    REAL(wp) ::  uz_coord    !< upper coordinate of child grid
     588    REAL(wp) ::  uz_coord_b  !< upper coordinate of child grid boundary
     589    REAL(wp) ::  x           !< particle position
     590    REAL(wp) ::  y           !< particle position
     591    REAL(wp) ::  z           !< particle position
     592
     593
     594#if defined( __parallel )
     595    TYPE(pedef), POINTER ::  ape  !< TO_DO Klaus: give a description and better name of the variable
    549596
    550597    DO  m = 1, get_number_of_children()
    … …  
    552599       child_id = get_childid(m)
    553600
    554        CALL get_child_edges( m, lx_coord, lx_coord_b, rx_coord, rx_coord_b,    &
    555                                 sy_coord, sy_coord_b, ny_coord, ny_coord_b,    &
    556                                 uz_coord, uz_coord_b)
     601       CALL get_child_edges( m, lx_coord, lx_coord_b, rx_coord, rx_coord_b, sy_coord, sy_coord_b,  &
     602                             ny_coord, ny_coord_b, uz_coord, uz_coord_b)
    557603
    558604       CALL get_child_gridspacing( m, dx_child, dy_child, dz_child )
    559605
    560606       IF ( lfirst )   THEN
    561           WRITE(9,'(a,5f10.2)') 'edges          ',lx_coord,rx_coord,sy_coord,ny_coord,uz_coord
    562           WRITE(9,'(a,5f10.2)') 'edges boundary ',lx_coord_b,rx_coord_b,sy_coord_b,ny_coord_b,uz_coord_b
    563           WRITE(9,'(a,5f10.2)') 'child spacing  ',dx_child, dy_child, dz_child,lower_left_coord_x,lower_left_coord_y
    564        ENDIF
    565 !
    566 !--    reset values for every child
    567        tot_particle_count = 0
    568        nr_part  = 0           
     607          WRITE( 9, '(a,5f10.2)' ) 'edges          ', lx_coord,rx_coord, sy_coord, ny_coord,       &
     608                                                      uz_coord
     609          WRITE( 9, '(a,5f10.2)' ) 'edges boundary ', lx_coord_b, rx_coord_b, sy_coord_b,          &
     610                                                      ny_coord_b, uz_coord_b
     611          WRITE( 9, '(a,5f10.2)' ) 'child spacing  ', dx_child, dy_child, dz_child,                &
     612                                                      lower_left_coord_x,lower_left_coord_y
     613     ENDIF
     614!
     615!--    Reset values for every child
     616       tot_particle_count = 0
     617       nr_part  = 0
    569618       part_adr = 0
    570619       pindex   = 1
    … …  
    577626          ape => children(child_id)%pes(ip)
    578627
    579           nr_part_col   = 0 
    580          
     628          nr_part_col   = 0
     629
    581630          DO  ij = 1, ape%nrele
    582              
     631
    583632!
    584633!--          Inside the PMC adressing of 3d arrays starts with 1
    … …  
    587636             nr_part_col = 0   ! Number of particles to transfer per column
    588637             part_adr(j,i) = pindex
    589              
     638
    590639             DO  k = nzb + 1, nzt
    591640                number_of_particles = prt_count(k,j,i)
    592                
     641
    593642                IF ( number_of_particles <= 0 )  CYCLE
    594                
     643
    595644                particles => grid_particles(k,j,i)%particles(1:number_of_particles)
    596645
    597646                ! Select particles within boundary area
    598647
    599                 DO n = 1, number_of_particles
     648                DO  n = 1, number_of_particles
    600649                   x = particles(n)%x
    601650                   y = particles(n)%y
    602651                   z = particles(n)%z
    603652!
    604 !--                check if the particle is located in the fine grid area
    605                    active_particle = ((x > lx_coord .AND. x < rx_coord) .AND.  & 
    606                                       (y > sy_coord .AND. y < ny_coord) .AND.  &
    607                                       (z > 0.000000001 .AND. z < uz_coord))
     653!--                Check if the particle is located in the fine grid area
     654                   active_particle = ( (x > lx_coord .AND. x < rx_coord) .AND.                     &
     655                                       (y > sy_coord .AND. y < ny_coord) .AND.                     &
     656                                       (z > 0.000000001 .AND. z < uz_coord) )
    608657                   IF ( active_particle .AND. particles(n)%particle_mask )  THEN
    609                      
     658
    610659                      particle_in_win(pindex) = particles(n)
    611660!
    … …  
    613662                      particle_in_win(pindex)%x = particle_in_win(pindex)%x + lower_left_coord_x
    614663                      particle_in_win(pindex)%y = particle_in_win(pindex)%y + lower_left_coord_y
    615                       particle_in_win(pindex)%origin_x = particle_in_win(pindex)%origin_x + lower_left_coord_x
    616                       particle_in_win(pindex)%origin_y = particle_in_win(pindex)%origin_y + lower_left_coord_y
     664                      particle_in_win(pindex)%origin_x = particle_in_win(pindex)%origin_x          &
     665                                                         + lower_left_coord_x
     666                      particle_in_win(pindex)%origin_y = particle_in_win(pindex)%origin_y          &
     667                                                         + lower_left_coord_y
    617668
    618669                      tot_particle_count = tot_particle_count + 1
    619670                      nr_part_col        = nr_part_col + 1
    620671                      pindex             = pindex + 1
    621                       IF ( pindex > max_nr_particle_in_rma_win ) THEN
    622                          WRITE(9,*) 'RMA window too small on parent ',pindex, max_nr_particle_in_rma_win
     672                      IF ( pindex > max_nr_particle_in_rma_win )  THEN
     673                         WRITE( 9, * ) 'RMA window too small on parent ', pindex,                  &
     674                                                                          max_nr_particle_in_rma_win
    623675                         message_string = 'RMA window too small on parent'
    624676                         CALL message( 'pmci_create_child_arrays', 'PA0481', 3, 2, 0, 6, 0 )   ! PA number has to be adjusted
    … …  
    639691 END SUBROUTINE pmcp_p_fill_particle_win
    640692
    641  
    642 !------------------------------------------------------------------------------!
    643 ! Description:
    644 ! ------------
    645 !> parent routine:
    646 !> delete particles from the MPI window
    647 !------------------------------------------------------------------------------!
     693
     694!--------------------------------------------------------------------------------------------------!
     695! Description:
     696! ------------
     697!> Parent routine:
     698!> Delete particles from the MPI window
     699!--------------------------------------------------------------------------------------------------!
    648700 SUBROUTINE pmcp_p_empty_particle_win
    649701
    650702    IMPLICIT NONE
    651703
    652     INTEGER(iwp) ::  child_id           !< model id of the child
    653     INTEGER(iwp) ::  ip                 !< loop index (child PEs)
    654     INTEGER(iwp) ::  m                  !< loop index (number of childs)
    655 
    656     INTEGER(iwp),DIMENSION(1) ::  buf_shape !<
     704    INTEGER(iwp) ::  child_id  !< model id of the child
     705    INTEGER(iwp) ::  ip        !< loop index (child PEs)
     706    INTEGER(iwp) ::  m         !< loop index (number of childs)
     707
     708    INTEGER(iwp),DIMENSION(1) ::  buf_shape  !<
    657709
    658710#if defined( __parallel )
    … …  
    665717
    666718!
    667 !--    In some cells of the coarse grid, there are contributions from more than
    668 !--    one child process. Therefore p_copy_particle_to_org_grid is done for one
    669 !--    child process per call
    670        DO ip = 1, pmc_s_get_child_npes( child_id )
     719!--    In some cells of the coarse grid, there are contributions from more than one child process.
     720!--    Therefore p_copy_particle_to_org_grid is done for one child process per call
     721       DO  ip = 1, pmc_s_get_child_npes( child_id )
    671722
    672723          nr_part  = 0
    673724          part_adr = 0
    674725
    675           CALL pmc_s_getdata_from_buffer( child_id, particle_transfer = .TRUE.,&
     726          CALL pmc_s_getdata_from_buffer( child_id, particle_transfer = .TRUE.,                    &
    676727                                          child_process_nr = ip )
    677728          CALL p_copy_particle_to_org_grid( m )
    … …  
    684735
    685736
    686 !------------------------------------------------------------------------------!
    687 ! Description:
    688 ! ------------
    689 !> parent routine:
    690 !> After the transfer mark all parent particles that are still inside on of the
    691 !> child areas for deletion.
    692 !------------------------------------------------------------------------------!
     737!--------------------------------------------------------------------------------------------------!
     738! Description:
     739! ------------
     740!> Parent routine:
     741!> After the transfer mark all parent particles that are still inside on of the child areas for
     742!> deletion.
     743!--------------------------------------------------------------------------------------------------!
    693744 SUBROUTINE pmcp_p_delete_particles_in_fine_grid_area
    694745
    695746    IMPLICIT NONE
    696747
    697     LOGICAL ::  to_delete !< particles outside of model domain are marked as to_delete
    698    
    699     INTEGER(iwp) ::  i !< loop index (x grid)
    700     INTEGER(iwp) ::  j !< loop index (y grid)
    701     INTEGER(iwp) ::  k !< loop index (z grid)
    702     INTEGER(iwp) ::  m !< loop index (number of particles)
    703     INTEGER(iwp) ::  n !< loop index (number of childs)
    704    
    705     REAL(wp) ::  dx_child   !< child grid spacing
    706     REAL(wp) ::  dy_child   !< child grid spacing
    707     REAL(wp) ::  dz_child   !< child grid spacing
    708     REAL(wp) ::  ny_coord   !< north coordinate of child grid
    709     REAL(wp) ::  ny_coord_b !< north coordinate of child grid boundary
    710     REAL(wp) ::  lx_coord   !< left coordinate of child grid
    711     REAL(wp) ::  lx_coord_b !< left coordinate of child grid boundary
    712     REAL(wp) ::  rx_coord   !< right coordinate of child grid
    713     REAL(wp) ::  rx_coord_b !< right coordinate of child grid boundary
    714     REAL(wp) ::  sy_coord   !< south coordinate of child grid
    715     REAL(wp) ::  sy_coord_b !< south coordinate of child grid boundary
    716     REAL(wp) ::  uz_coord   !< upper coordinate of child grid
    717     REAL(wp) ::  uz_coord_b !< upper coordinate of child grid boundary
    718     REAL(wp) ::  x          !< particle position
    719     REAL(wp) ::  y          !< particle position
    720     REAL(wp) ::  z          !< particle position
    721    
     748    INTEGER(iwp) ::  i  !< loop index (x grid)
     749    INTEGER(iwp) ::  j  !< loop index (y grid)
     750    INTEGER(iwp) ::  k  !< loop index (z grid)
     751    INTEGER(iwp) ::  m  !< loop index (number of particles)
     752    INTEGER(iwp) ::  n  !< loop index (number of childs)
     753
     754    LOGICAL ::  to_delete  !< particles outside of model domain are marked as to_delete
     755
     756    REAL(wp) ::  dx_child    !< child grid spacing
     757    REAL(wp) ::  dy_child    !< child grid spacing
     758    REAL(wp) ::  dz_child    !< child grid spacing
     759    REAL(wp) ::  ny_coord    !< north coordinate of child grid
     760    REAL(wp) ::  ny_coord_b  !< north coordinate of child grid boundary
     761    REAL(wp) ::  lx_coord    !< left coordinate of child grid
     762    REAL(wp) ::  lx_coord_b  !< left coordinate of child grid boundary
     763    REAL(wp) ::  rx_coord    !< right coordinate of child grid
     764    REAL(wp) ::  rx_coord_b  !< right coordinate of child grid boundary
     765    REAL(wp) ::  sy_coord    !< south coordinate of child grid
     766    REAL(wp) ::  sy_coord_b  !< south coordinate of child grid boundary
     767    REAL(wp) ::  uz_coord    !< upper coordinate of child grid
     768    REAL(wp) ::  uz_coord_b  !< upper coordinate of child grid boundary
     769    REAL(wp) ::  x           !< particle position
     770    REAL(wp) ::  y           !< particle position
     771    REAL(wp) ::  z           !< particle position
     772
    722773#if defined( __parallel )
    723774    DO  m = 1, get_number_of_children()
    724        CALL get_child_edges( m, lx_coord, lx_coord_b, rx_coord, rx_coord_b,    &
    725                                 sy_coord, sy_coord_b, ny_coord, ny_coord_b,    &
    726                                 uz_coord, uz_coord_b )
    727 
    728 
    729        CALL get_child_gridspacing( m, dx_child, dy_child, dz_child )
    730 
    731        DO i = nxl, nxr
    732           DO j = nys, nyn
    733              DO k = nzb, nzt
     775       CALL get_child_edges( m, lx_coord, lx_coord_b, rx_coord, rx_coord_b, sy_coord, sy_coord_b,  &
     776                             ny_coord, ny_coord_b, uz_coord, uz_coord_b )
     777
     778
     779       CALL get_child_gridspacing( m, dx_child, dy_child, dz_child )
     780
     781       DO  i = nxl, nxr
     782          DO  j = nys, nyn
     783             DO  k = nzb, nzt
    734784                number_of_particles = prt_count(k,j,i)
    735785
    736                 IF ( number_of_particles == 0 ) CYCLE
     786                IF ( number_of_particles == 0 )  CYCLE
    737787
    738788                particles => grid_particles(k,j,i)%particles(1:number_of_particles)
    739789
    740                 DO n = 1, number_of_particles
     790                DO  n = 1, number_of_particles
    741791                   x = particles(n)%x
    742792                   y = particles(n)%y
    743793                   z = particles(n)%z
    744794
    745                    to_delete = ((x > lx_coord .AND. x < rx_coord) .AND.        &
    746                                 (y > sy_coord .AND. y < ny_coord) .AND.        &
    747                                 (z > 0.000000001 .AND. z < uz_coord))
    748 
    749                    IF ( to_delete ) THEN
     795                   to_delete = ( (x > lx_coord .AND. x < rx_coord) .AND.                           &
     796                                 (y > sy_coord .AND. y < ny_coord) .AND.                           &
     797                                 (z > 0.000000001 .AND. z < uz_coord) )
     798
     799                   IF ( to_delete )  THEN
    750800                      particles(n)%particle_mask = .FALSE.
    751801                   ENDIF
    … …  
    761811
    762812
    763 !------------------------------------------------------------------------------!
    764 ! Description:
    765 ! ------------
    766 !> general routine:
    767 !> print the total number of of the current model and its child models into a file
    768 !------------------------------------------------------------------------------!
    769  SUBROUTINE pmcp_g_print_number_of_particles (my_time,local_nr_particles)
    770  
    771     USE pegrid,                                                                &
     813!--------------------------------------------------------------------------------------------------!
     814! Description:
     815! ------------
     816!> General routine:
     817!> Print the total number of of the current model and its child models into a file
     818!--------------------------------------------------------------------------------------------------!
     819 SUBROUTINE pmcp_g_print_number_of_particles( my_time, local_nr_particles )
     820
     821    USE pegrid,                                                                                    &
    772822        ONLY: myid
    773  
     823
    774824    IMPLICIT NONE
    775825
    776     INTEGER(iwp),INTENT(IN) ::  local_nr_particles !<
    777    
    778     REAL(wp),INTENT(IN) ::  my_time !<
    779      
    780     LOGICAL, SAVE ::  is_file_open=.FALSE. !<
    781    
    782     INTEGER(iwp) ::  child_id           !<
    783     INTEGER(iwp) ::  child_nr_particles !< total number of particles in all child models
    784     INTEGER(iwp) ::  ierr               !< error code
    785     INTEGER(iwp) ::  m                  !< loop index (number of childs)
    786    
    787     CHARACTER(LEN=16) ::  fname !< filename
    788    
    789     INTEGER(iwp),DIMENSION(2) ::  ivalr !< integer value to be received
    790     INTEGER(iwp),DIMENSION(2) ::  ivals !< integer value to be send
    791    
     826    CHARACTER(LEN=16) ::  fname  !< filename
     827
     828    INTEGER(iwp) ::  child_id            !<
     829    INTEGER(iwp) ::  child_nr_particles  !< total number of particles in all child models
     830    INTEGER(iwp) ::  ierr                !< error code
     831    INTEGER(iwp) ::  m                   !< loop index (number of childs
     832
     833    INTEGER(iwp),INTENT(IN) ::  local_nr_particles  !<
     834
     835    INTEGER(iwp),DIMENSION(2) ::  ivalr  !< integer value to be received
     836    INTEGER(iwp),DIMENSION(2) ::  ivals  !< integer value to be send
     837
     838    LOGICAL, SAVE ::  is_file_open=.FALSE.  !<
     839
     840    REAL(wp),INTENT(IN) ::  my_time  !<
     841
     842
    792843#if defined( __parallel )
    793844    child_nr_particles = 0
    794845    IF ( myid == 0 )  THEN
    795        IF ( cpl_id > 1 )  THEN 
     846       IF ( cpl_id > 1 )  THEN
    796847          ivals(1) = local_nr_particles
    797848          CALL pmc_send_to_parent( ivals, 1, 0, 400, ierr )
    … …  
    804855       ENDDO
    805856
    806        IF ( SIZE( pmc_parent_for_child ) > 1 ) THEN
    807           IF ( .NOT. is_file_open )  THEN !kk muss noch auf file_open umgestellt werden
    808              WRITE(fname,'(a,i2.2)') 'nr_particles_',cpl_id
    809              OPEN (333,file = fname)
     857       IF ( SIZE( pmc_parent_for_child ) > 1 )  THEN
     858          IF ( .NOT. is_file_open )  THEN  !kk muss noch auf file_open umgestellt werden
     859             WRITE( fname, '(a,i2.2)' ) 'nr_particles_', cpl_id
     860             OPEN ( 333, FILE = fname )
    810861             is_file_open = .true.
    811862          ENDIF
    812           WRITE(333,'(f12.2,3i10)') my_time,local_nr_particles + child_nr_particles,local_nr_particles,child_nr_particles
     863          WRITE( 333, '(f12.2,3i10)' ) my_time, local_nr_particles + child_nr_particles,           &
     864                                       local_nr_particles, child_nr_particles
    813865       ENDIF
    814866    ENDIF
    … …  
    818870
    819871
    820 !------------------------------------------------------------------------------!
    821 !------------------------------------------------------------------------------!
     872!--------------------------------------------------------------------------------------------------!
     873!--------------------------------------------------------------------------------------------------!
    822874! Private subroutines
    823 !------------------------------------------------------------------------------!
    824 !------------------------------------------------------------------------------!
    825 
    826 !------------------------------------------------------------------------------!
    827 ! Description:
    828 ! ------------
    829 !> child routine
    830 !> update the size of the local buffer (coarse_particles)
    831 !------------------------------------------------------------------------------!
    832  SUBROUTINE check_and_alloc_coarse_particle (ic,jc,nr,with_copy)
    833    
     875!--------------------------------------------------------------------------------------------------!
     876!--------------------------------------------------------------------------------------------------!
     877
     878!--------------------------------------------------------------------------------------------------!
     879! Description:
     880! ------------
     881!> Child routine
     882!> Update the size of the local buffer (coarse_particles)
     883!--------------------------------------------------------------------------------------------------!
     884 SUBROUTINE check_and_alloc_coarse_particle( ic, jc, nr, with_copy )
     885
    834886    IMPLICIT NONE
    835    
    836     INTEGER(iwp),INTENT(IN) ::  ic !< coarse x grid index
    837     INTEGER(iwp),INTENT(IN) ::  jc !< coarse y grid index
    838     INTEGER(iwp),INTENT(IN) ::  nr !< number of particles to be transferred/stored in local buffer
    839    
    840     LOGICAL,INTENT(IN),OPTIONAL ::  with_copy !< copy particles in buffer? or reallocate empty buffer
    841 
    842     LOGICAL :: with_copy_lo !< local variable of with copy
    843    
    844     INTEGER(iwp) ::  new_size !< new size of the local buffer
    845     INTEGER(iwp) ::  old_size !< old size of the local buffer
    846    
    847     TYPE(particle_type), DIMENSION(:), ALLOCATABLE ::  tmp_particles_d !<
     887
     888    INTEGER(iwp),INTENT(IN) ::  ic  !< coarse x grid index
     889    INTEGER(iwp),INTENT(IN) ::  jc  !< coarse y grid index
     890    INTEGER(iwp),INTENT(IN) ::  nr  !< number of particles to be transferred/stored in local buffer
     891
     892    INTEGER(iwp) ::  new_size  !< new size of the local buffer
     893    INTEGER(iwp) ::  old_size  !< old size of the local buffer
     894
     895    LOGICAL :: with_copy_lo  !< local variable of with copy
     896
     897    LOGICAL,INTENT(IN),OPTIONAL ::  with_copy  !< copy particles in buffer? or reallocate empty buffer
     898
     899    TYPE(particle_type), DIMENSION(:), ALLOCATABLE ::  tmp_particles_d  !<
    848900
    849901#if defined( __parallel )
    850902    with_copy_lo = .FALSE.
    851     IF ( PRESENT( with_copy ) ) with_copy_lo = with_copy
    852 
    853     IF ( .NOT. ALLOCATED( coarse_particles(jc,ic)%parent_particles ) ) THEN
    854        new_size = MAX( nr, Min_particles_per_column )
     903    IF ( PRESENT( with_copy ) )  with_copy_lo = with_copy
     904
     905    IF ( .NOT. ALLOCATED( coarse_particles(jc,ic)%parent_particles ) )  THEN
     906       new_size = MAX( nr, min_particles_per_column )
    855907       ALLOCATE( coarse_particles(jc,ic)%parent_particles(new_size) )
    856     ELSEIF ( nr > SIZE( coarse_particles(jc,ic)%parent_particles ) ) THEN
     908    ELSEIF ( nr > SIZE( coarse_particles(jc,ic)%parent_particles ) )  THEN
    857909
    858910       old_size = SIZE( coarse_particles(jc,ic)%parent_particles )
    859911       new_size = old_size * ( 1.0_wp + alloc_factor / 100.0_wp )
    860        new_size = MAX( nr, new_size, old_size + Min_particles_per_column )
     912       new_size = MAX( nr, new_size, old_size + min_particles_per_column )
    861913
    862914!
    863915!--    Copy existing particles to new particle buffer
    864        IF ( with_copy_lo ) THEN
     916       IF ( with_copy_lo )  THEN
    865917          ALLOCATE( tmp_particles_d(old_size) )
    866918          tmp_particles_d(1:old_size) = coarse_particles(jc,ic)%parent_particles
    … …  
    875927!
    876928!--    allocate or reallocate an empty buffer
    877        ELSE 
     929       ELSE
    878930          DEALLOCATE( coarse_particles(jc,ic)%parent_particles )
    879931          ALLOCATE( coarse_particles(jc,ic)%parent_particles(new_size) )
    … …  
    885937
    886938
    887 !------------------------------------------------------------------------------!
    888 ! Description:
    889 ! ------------
    890 !> child routine:
    891 !> copy/sort particles out of the local buffer into the respective grid boxes
    892 !------------------------------------------------------------------------------!
     939!--------------------------------------------------------------------------------------------------!
     940! Description:
     941! ------------
     942!> Child routine:
     943!> Copy/sort particles out of the local buffer into the respective grid boxes
     944!--------------------------------------------------------------------------------------------------!
    893945 SUBROUTINE c_copy_particle_to_child_grid
    894  
     946
    895947    IMPLICIT NONE
    896  
    897     INTEGER(iwp) ::  ic  !< coarse x grid index
    898     INTEGER(iwp) ::  ipl !< left boundary in coarse(parent) index space
    899     INTEGER(iwp) ::  ipr !< right boundary in coarse(parent) index space
    900     INTEGER(iwp) ::  ip  !< x grid index
    901     INTEGER(iwp) ::  jc  !< coarse y grid index
    902     INTEGER(iwp) ::  jpn !< north boundary in coarse(parent) index space
    903     INTEGER(iwp) ::  jps !< south boundary in coarse(parent) index space
    904     INTEGER(iwp) ::  jp  !< y grid index
    905     INTEGER(iwp) ::  kp  !< z grid index
    906     INTEGER(iwp) ::  n   !< loop index (number of particles)
    907     INTEGER(iwp) ::  nr  !< short variable for name number or particles
    908    
    909     REAL(wp) ::  xc  !< child x coordinate
    910     REAL(wp) ::  xoc !< child x origin
    911     REAL(wp) ::  yc  !< child y coordinate
    912     REAL(wp) ::  yoc !< child y origin
    913     REAL(wp) ::  zc  !< child z coordinate
     948
     949    INTEGER(iwp) ::  ic   !< coarse x grid index
     950    INTEGER(iwp) ::  ipl  !< left boundary in coarse(parent) index space
     951    INTEGER(iwp) ::  ipr  !< right boundary in coarse(parent) index space
     952    INTEGER(iwp) ::  ip   !< x grid index
     953    INTEGER(iwp) ::  jc   !< coarse y grid index
     954    INTEGER(iwp) ::  jpn  !< north boundary in coarse(parent) index space
     955    INTEGER(iwp) ::  jps  !< south boundary in coarse(parent) index space
     956    INTEGER(iwp) ::  jp   !< y grid index
     957    INTEGER(iwp) ::  kp   !< z grid index
     958    INTEGER(iwp) ::  n    !< loop index (number of particles)
     959    INTEGER(iwp) ::  nr   !< short variable for name number or particles
     960
     961    REAL(wp) ::  xc   !< child x coordinate
     962    REAL(wp) ::  xoc  !< child x origin
     963    REAL(wp) ::  yc   !< child y coordinate
     964    REAL(wp) ::  yoc  !< child y origin
     965    REAL(wp) ::  zc   !< child z coordinate
    914966
    915967#if defined( __parallel )
    … …  
    921973    jpn = parent_bound(4)
    922974
    923     DO ic = ipl, ipr
    924        DO jc = jps, jpn
     975    DO  ic = ipl, ipr
     976       DO  jc = jps, jpn
    925977          nr = coarse_particles(jc,ic)%nr_particle
    926978
    927           IF ( nr > 0 ) THEN
    928              DO n = 1, nr
     979          IF ( nr > 0 )  THEN
     980             DO  n = 1, nr
    929981                xc =  coarse_particles(jc,ic)%parent_particles(n)%x-lower_left_coord_x
    930982                yc =  coarse_particles(jc,ic)%parent_particles(n)%y-lower_left_coord_y
    … …  
    935987                jp = yc / dy
    936988                kp = nzt
    937                 DO WHILE ( zw(kp-1) > zc .AND. kp > nzb + 1 )         ! kk search loop has to be optimzed !!!
     989                DO WHILE ( zw(kp-1) > zc .AND. kp > nzb + 1 )  ! kk search loop has to be optimzed !!!
    938990                   kp = kp - 1
    939                 ENDDO 
    940 
    941                 IF ( ip >= nxl .AND. ip <= nxr .AND. jp >= nys .AND. jp <= nyn ) THEN
     991                ENDDO
     992
     993                IF ( ip >= nxl  .AND.  ip <= nxr  .AND.  jp >= nys  .AND.  jp <= nyn ) THEN
    942994                   prt_count(kp,jp,ip) = prt_count(kp,jp,ip) + 1
    943                    IF ( prt_count(kp,jp,ip) > SIZE( grid_particles(kp,jp,ip)%particles ) ) THEN
     995                   IF ( prt_count(kp,jp,ip) > SIZE( grid_particles(kp,jp,ip)%particles ) )  THEN
    944996                      CALL pmc_realloc_particles_array( ip, jp, kp )
    945997                   ENDIF
    946                    coarse_particles(jc,ic)%parent_particles(n)%x = xc                   ! Adjust coordinates to child grid
     998                   coarse_particles(jc,ic)%parent_particles(n)%x = xc         ! Adjust coordinates to child grid
    947999                   coarse_particles(jc,ic)%parent_particles(n)%y = yc
    948                    coarse_particles(jc,ic)%parent_particles(n)%origin_x = xoc           ! Adjust origins to child grid
     1000                   coarse_particles(jc,ic)%parent_particles(n)%origin_x = xoc ! Adjust origins to child grid
    9491001                   coarse_particles(jc,ic)%parent_particles(n)%origin_y = yoc
    950                    grid_particles(kp,jp,ip)%particles(prt_count(kp,jp,ip)) = coarse_particles(jc,ic)%parent_particles(n)
     1002                   grid_particles(kp,jp,ip)%particles(prt_count(kp,jp,ip))                         &
     1003                                                       = coarse_particles(jc,ic)%parent_particles(n)
    9511004                ENDIF
    9521005             ENDDO
    … …  
    9591012
    9601013
    961 !------------------------------------------------------------------------------!
    962 ! Description:
    963 ! ------------
    964 !> child routine:
    965 !> copy particles which left the model area into the local buffer
    966 !------------------------------------------------------------------------------!
     1014!--------------------------------------------------------------------------------------------------!
     1015! Description:
     1016! ------------
     1017!> Child routine:
     1018!> Copy particles which left the model area into the local buffer
     1019!--------------------------------------------------------------------------------------------------!
    9671020 SUBROUTINE c_copy_particle_to_coarse_grid
    968  
     1021
    9691022    IMPLICIT NONE
    970    
    971     LOGICAL ::  boundary_particle !<
    972    
    973     INTEGER(iwp) ::  i    !< loop index (x grid)
    974     INTEGER(iwp) ::  ic   !< loop index (coarse x grid)
    975     INTEGER(iwp) ::  ipl  !< left boundary in coarse(parent) index space
    976     INTEGER(iwp) ::  ipr  !< left boundary in coarse(parent) index space
    977     INTEGER(iwp) ::  ierr !< error code
    978     INTEGER(iwp) ::  j    !< loop index (y grid)
    979     INTEGER(iwp) ::  jc   !< loop index (coarse y grid)
    980     INTEGER(iwp) ::  jps  !< south boundary in coarse(parent) index space
    981     INTEGER(iwp) ::  jpn  !< north boundary in coarse(parent) index space
    982     INTEGER(iwp) ::  k    !< loop index (z grid)
    983     INTEGER(iwp) ::  n    !< loop index (number of particles)
    984    
    985     REAL(wp) ::  x       !< x coordinate
    986     REAL(wp) ::  xo      !< x origin
    987     REAL(wp) ::  x_left  !< absolute left boundary
    988     REAL(wp) ::  x_right !< absolute right boundary
    989     REAL(wp) ::  y       !< left boundary in coarse(parent) index space
    990     REAL(wp) ::  yo      !< y origin
    991     REAL(wp) ::  y_north !< absolute north boundary
    992     REAL(wp) ::  y_south !< absoulte south boundary
    993     REAL(wp) ::  z       !< z coordinate
     1023
     1024    INTEGER(iwp) ::  i     !< loop index (x grid)
     1025    INTEGER(iwp) ::  ic    !< loop index (coarse x grid)
     1026    INTEGER(iwp) ::  ipl   !< left boundary in coarse(parent) index space
     1027    INTEGER(iwp) ::  ipr   !< left boundary in coarse(parent) index space
     1028    INTEGER(iwp) ::  ierr  !< error code
     1029    INTEGER(iwp) ::  j     !< loop index (y grid)
     1030    INTEGER(iwp) ::  jc    !< loop index (coarse y grid)
     1031    INTEGER(iwp) ::  jps   !< south boundary in coarse(parent) index space
     1032    INTEGER(iwp) ::  jpn   !< north boundary in coarse(parent) index space
     1033    INTEGER(iwp) ::  k     !< loop index (z grid)
     1034    INTEGER(iwp) ::  n     !< loop index (number of particles)
     1035
     1036    LOGICAL ::  boundary_particle  !<
     1037
     1038    REAL(wp) ::  x        !< x coordinate
     1039    REAL(wp) ::  xo       !< x origin
     1040    REAL(wp) ::  x_left   !< absolute left boundary
     1041    REAL(wp) ::  x_right  !< absolute right boundary
     1042    REAL(wp) ::  y        !< left boundary in coarse(parent) index space
     1043    REAL(wp) ::  yo       !< y origin
     1044    REAL(wp) ::  y_north  !< absolute north boundary
     1045    REAL(wp) ::  y_south  !< absoulte south boundary
     1046    REAL(wp) ::  z        !< z coordinate
    9941047
    9951048#if defined( __parallel )
    … …  
    10031056
    10041057!
    1005 !-- absolute coordinates
     1058!-- Absolute coordinates
    10061059    x_left  = coord_x(0)
    10071060    x_right = coord_x(nx) + dx
    10081061    y_south = coord_y(0)
    10091062    y_north = coord_y(ny) + dy
    1010 
    1011 !   Clear Particle Buffer
    1012 
    1013     DO ic = ipl, ipr
    1014        DO jc = jps, jpn
     1063!
     1064!-- Clear Particle Buffer
     1065    DO  ic = ipl, ipr
     1066       DO  jc = jps, jpn
    10151067          coarse_particles(jc,ic)%nr_particle = 0
    10161068       ENDDO
    … …  
    10181070
    10191071!
    1020 !-- Determine particles which leave the inner area in east or west dirextion
     1072!-- Determine particles which leave the inner area in east or west dirextion.
    10211073!-- Compute only first (nxl) and last (nxr) loop iterration.
    10221074    DO  i = nxl, nxr
    … …  
    10281080             DO  n = 1, number_of_particles
    10291081                IF ( particles(n)%particle_mask )  THEN
    1030                    x =  particles(n)%x+ lower_left_coord_x 
    1031                    y =  particles(n)%y+ lower_left_coord_y
     1082                   x  = particles(n)%x+ lower_left_coord_x
     1083                   y  = particles(n)%y+ lower_left_coord_y
    10321084                   xo = particles(n)%origin_x + lower_left_coord_x
    10331085                   yo = particles(n)%origin_y + lower_left_coord_y
    1034                    z = particles(n)%z
    1035                    
     1086                   z  = particles(n)%z
     1087
    10361088                   boundary_particle = .FALSE.
    1037                    boundary_particle = boundary_particle .OR. (x < x_left  .OR. x > x_right)
    1038                    boundary_particle = boundary_particle .OR. (y < y_south .OR. y > y_north)
    1039                    boundary_particle = boundary_particle .OR. (z > zw(nzt))
    1040 
    1041                    IF ( boundary_particle ) THEN                     
     1089                   boundary_particle = boundary_particle .OR. ( x < x_left  .OR. x > x_right )
     1090                   boundary_particle = boundary_particle .OR. ( y < y_south .OR. y > y_north )
     1091                   boundary_particle = boundary_particle .OR. ( z > zw(nzt) )
     1092
     1093                   IF ( boundary_particle )  THEN
    10421094                      ic = x / pg%dx                     !TODO anpassen auf Mehrfachnesting
    10431095                      jc = y / pg%dy
    10441096
    1045                       IF ( ic >= ipl .AND. ic <= ipr .AND. jc >= jps .AND. jc <= jpn ) THEN
    1046                          coarse_particles(jc,ic)%nr_particle = coarse_particles(jc,ic)%nr_particle + 1
    1047                          CALL check_and_alloc_coarse_particle( ic, jc, coarse_particles(jc,ic)%nr_particle, with_copy=.TRUE. )
    1048 
    1049                          coarse_particles(jc,ic)%parent_particles(coarse_particles(jc,ic)%nr_particle)   = particles(n)
    1050                          coarse_particles(jc,ic)%parent_particles(coarse_particles(jc,ic)%nr_particle)%x = x   !adapt to global coordinates
    1051                          coarse_particles(jc,ic)%parent_particles(coarse_particles(jc,ic)%nr_particle)%y = y
    1052                          coarse_particles(jc,ic)%parent_particles(coarse_particles(jc,ic)%nr_particle)%origin_x = xo
    1053                          coarse_particles(jc,ic)%parent_particles(coarse_particles(jc,ic)%nr_particle)%origin_y = yo
     1097                      IF ( ic >= ipl  .AND.  ic <= ipr  .AND.  jc >= jps  .AND.  jc <= jpn )  THEN
     1098                         coarse_particles(jc,ic)%nr_particle = coarse_particles(jc,ic)%nr_particle &
     1099                                                               + 1
     1100                         CALL check_and_alloc_coarse_particle( ic, jc,                             &
     1101                                                               coarse_particles(jc,ic)%nr_particle,&
     1102                                                               with_copy = .TRUE. )
     1103
     1104                         coarse_particles(jc,ic)%parent_particles(                                 &
     1105                         coarse_particles(jc,ic)%nr_particle) = particles(n)
     1106                         coarse_particles(jc,ic)%parent_particles(                                 &
     1107                         coarse_particles(jc,ic)%nr_particle)%x = x   !Adapt to global coordinates
     1108                         coarse_particles(jc,ic)%parent_particles(                                 &
     1109                         coarse_particles(jc,ic)%nr_particle)%y = y
     1110                         coarse_particles(jc,ic)%parent_particles(                                 &
     1111                         coarse_particles(jc,ic)%nr_particle)%origin_x = xo
     1112                         coarse_particles(jc,ic)%parent_particles(                                 &
     1113                         coarse_particles(jc,ic)%nr_particle)%origin_y = yo
     1114!
    10541115!--                      Mark particle as deleted after copying it to the transfer buffer
    10551116                         grid_particles(k,j,i)%particles(n)%particle_mask = .FALSE.
    10561117                      ELSE
    1057                          WRITE(9,'(a,10i6)') 'This should not happen ',i,j,k,ic,jc,ipl,ipr,jps,jpn
     1118                         WRITE( 9, '(a,10i6)' ) 'This should not happen ', i, j, k, ic, jc, ipl,   &
     1119                                                                           ipr, jps, jpn
    10581120                         CALL MPI_Abort( MPI_COMM_WORLD, 9999, ierr )
    10591121                      ENDIF
    … …  
    10661128
    10671129!
    1068 !- Pack particles (eliminate those marked for deletion),
    1069 !- determine new number of particles
     1130!-- Pack particles (eliminate those marked for deletion), determine new number of particles
    10701131!    CALL lpm_sort_in_subboxes
    10711132
    … …  
    10741135
    10751136
    1076 !------------------------------------------------------------------------------!
    1077 ! Description:
    1078 ! ------------
    1079 !> parent routine:
    1080 !> copy/sort particles from the MPI window into the respective grid boxes
    1081 !------------------------------------------------------------------------------!
     1137!--------------------------------------------------------------------------------------------------!
     1138! Description:
     1139! ------------
     1140!> Parent routine:
     1141!> Copy/sort particles from the MPI window into the respective grid boxes
     1142!--------------------------------------------------------------------------------------------------!
    10821143 SUBROUTINE p_copy_particle_to_org_grid( m )
    10831144
    10841145    IMPLICIT NONE
    10851146
    1086     INTEGER(iwp),INTENT(IN) ::  m        !<
    1087 
    1088     INTEGER(iwp) ::  i      !< loop index (x grid)
    1089     INTEGER(iwp) ::  j      !< loop index (y grid)
    1090     INTEGER(iwp) ::  k      !< loop index (z grid)
    1091     INTEGER(iwp) ::  n      !< loop index (nr part)
    1092     INTEGER(iwp) ::  nr     !< short variable name for nr_part
    1093     INTEGER(iwp) ::  pindex !< short variable name part_adr
    1094    
    1095     REAL(wp) ::  x  !< x coordinate
    1096     REAL(wp) ::  xo !< x origin
    1097     REAL(wp) ::  y  !< y coordinate
    1098     REAL(wp) ::  yo !< y origin
    1099     REAL(wp) ::  z  !< z coordinate
    1100    
    1101     INTEGER(iwp),DIMENSION(1) ::  buf_shape !<
     1147    INTEGER(iwp) ::  i       !< loop index (x grid)
     1148    INTEGER(iwp) ::  j       !< loop index (y grid)
     1149    INTEGER(iwp) ::  k       !< loop index (z grid)
     1150    INTEGER(iwp) ::  n       !< loop index (nr part)
     1151    INTEGER(iwp) ::  nr      !< short variable name for nr_part
     1152    INTEGER(iwp) ::  pindex  !< short variable name part_adr
     1153
     1154    INTEGER(iwp),INTENT(IN) ::  m  !<
     1155
     1156    INTEGER(iwp),DIMENSION(1) ::  buf_shape  !<
     1157
     1158    REAL(wp) ::  x   !< x coordinate
     1159    REAL(wp) ::  xo  !< x origin
     1160    REAL(wp) ::  y   !< y coordinate
     1161    REAL(wp) ::  yo  !< y origin
     1162    REAL(wp) ::  z   !< z coordinate
     1163
    11021164
    11031165#if defined( __parallel )
    … …  
    11051167    CALL C_F_POINTER( buf_ptr(m), particle_in_win , buf_shape )
    11061168
    1107     DO i = nxl, nxr
    1108        DO j = nys, nyn
     1169    DO  i = nxl, nxr
     1170       DO  j = nys, nyn
    11091171          nr = nr_part(j,i)
    1110           IF ( nr > 0 ) THEN
     1172          IF ( nr > 0 )  THEN
    11111173             pindex = part_adr(j,i)
    1112              DO n = 1, nr
     1174             DO  n = 1, nr
    11131175                x = particle_in_win(pindex)%x-lower_left_coord_x
    11141176                y = particle_in_win(pindex)%y-lower_left_coord_y
    … …  
    11171179                yo = particle_in_win(pindex)%origin_y-lower_left_coord_y
    11181180                k = nzt + 1
    1119                 DO WHILE ( zw(k-1) > z .AND. k > nzb + 1 )           ! kk search loop has to be optimzed !!!
     1181                DO WHILE ( zw(k-1) > z .AND. k > nzb + 1 )  ! kk search loop has to be optimzed !!!
    11201182                   k = k - 1
    11211183                END DO
    11221184
    11231185                prt_count(k,j,i) = prt_count(k,j,i) + 1
    1124                 IF ( prt_count(k,j,i) > SIZE( grid_particles(k,j,i)%particles ) ) THEN
     1186                IF ( prt_count(k,j,i) > SIZE( grid_particles(k,j,i)%particles ) )  THEN
    11251187                   CALL pmc_realloc_particles_array( i, j, k )
    11261188                ENDIF
    11271189                grid_particles(k,j,i)%particles(prt_count(k,j,i)) = particle_in_win(pindex)
    1128                
     1190
    11291191!
    11301192!--             Update particle positions and origins relative to parent domain
    … …  
    11411203#endif
    11421204 END SUBROUTINE p_copy_particle_to_org_grid
    1143  
    1144 !------------------------------------------------------------------------------!
    1145 ! Description:
    1146 ! ------------
    1147 !> If the allocated memory for the particle array do not suffice to add arriving
    1148 !> particles from neighbour grid cells, this subrouting reallocates the
    1149 !> particle array to assure enough memory is available.
    1150 !------------------------------------------------------------------------------!
    1151  SUBROUTINE pmc_realloc_particles_array ( i, j, k, size_in )
    1152 
    1153     INTEGER(iwp), INTENT(IN)                       ::  i              !<
    1154     INTEGER(iwp), INTENT(IN)                       ::  j              !<
    1155     INTEGER(iwp), INTENT(IN)                       ::  k              !<
    1156     INTEGER(iwp), INTENT(IN), OPTIONAL             ::  size_in        !<
    1157 
    1158     INTEGER(iwp)                                   ::  old_size        !<
    1159     INTEGER(iwp)                                   ::  new_size        !<
    1160     TYPE(particle_type), DIMENSION(:), ALLOCATABLE ::  tmp_particles_d !<
    1161     TYPE(particle_type), DIMENSION(500)            ::  tmp_particles_s !<
    1162 
    1163     old_size = SIZE(grid_particles(k,j,i)%particles)
    1164 
    1165     IF ( PRESENT(size_in) )   THEN
     1205
     1206!--------------------------------------------------------------------------------------------------!
     1207! Description:
     1208! ------------
     1209!> If the allocated memory for the particle array do not suffice to add arriving particles from
     1210!> neighbour grid cells, this subrouting reallocates the particle array to assure enough memory is
     1211!> available.
     1212!--------------------------------------------------------------------------------------------------!
     1213 SUBROUTINE pmc_realloc_particles_array( i, j, k, size_in )
     1214
     1215
     1216    INTEGER(iwp) ::  new_size  !<
     1217    INTEGER(iwp) ::  old_size  !<
     1218
     1219    INTEGER(iwp), INTENT(IN) ::  i  !<
     1220    INTEGER(iwp), INTENT(IN) ::  j  !<
     1221    INTEGER(iwp), INTENT(IN) ::  k  !<
     1222
     1223    INTEGER(iwp), INTENT(IN), OPTIONAL ::  size_in  !<
     1224
     1225
     1226    TYPE(particle_type), DIMENSION(:), ALLOCATABLE ::  tmp_particles_d  !<
     1227
     1228    TYPE(particle_type), DIMENSION(500)            ::  tmp_particles_s  !<
     1229
     1230    old_size = SIZE( grid_particles(k,j,i)%particles )
     1231
     1232    IF ( PRESENT( size_in ) )  THEN
    11661233       new_size = size_in
    11671234    ELSE
    … …  
    11751242       tmp_particles_s(1:old_size) = grid_particles(k,j,i)%particles(1:old_size)
    11761243
    1177        DEALLOCATE(grid_particles(k,j,i)%particles)
    1178        ALLOCATE(grid_particles(k,j,i)%particles(new_size))
     1244       DEALLOCATE( grid_particles(k,j,i)%particles )
     1245       ALLOCATE( grid_particles(k,j,i)%particles(new_size) )
    11791246
    11801247       grid_particles(k,j,i)%particles(1:old_size)          = tmp_particles_s(1:old_size)
    … …  
    11831250    ELSE
    11841251
    1185        ALLOCATE(tmp_particles_d(new_size))
     1252       ALLOCATE( tmp_particles_d(new_size) )
    11861253       tmp_particles_d(1:old_size) = grid_particles(k,j,i)%particles
    11871254
    1188        DEALLOCATE(grid_particles(k,j,i)%particles)
    1189        ALLOCATE(grid_particles(k,j,i)%particles(new_size))
     1255       DEALLOCATE( grid_particles(k,j,i)%particles )
     1256       ALLOCATE( grid_particles(k,j,i)%particles(new_size) )
    11901257
    11911258       grid_particles(k,j,i)%particles(1:old_size)          = tmp_particles_d(1:old_size)
    11921259       grid_particles(k,j,i)%particles(old_size+1:new_size) = zero_particle
    11931260
    1194        DEALLOCATE(tmp_particles_d)
     1261       DEALLOCATE( tmp_particles_d )
    11951262
    11961263    ENDIF
    … …  
    11981265
    11991266    RETURN
    1200    
     1267
    12011268 END SUBROUTINE pmc_realloc_particles_array
    12021269
Note: See TracChangeset for help on using the changeset viewer.
                                                                                                                                                                                                                                                                                                                                                                               
  | Impressum | ©Leibniz Universität Hannover |