source: palm/trunk/SOURCE/pmc_particle_interface.f90 @ 4554

Last change on this file since 4554 was 4444, checked in by raasch, 5 years ago

bugfix: cpp-directives for serial mode added

  • Property svn:keywords set to Id
File size: 46.1 KB
Line 
1MODULE 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/>.
17!
18! Copyright 1997-2020 Leibniz Universitaet Hannover
19!------------------------------------------------------------------------------!
20!
21! Current revisions:
22! ------------------
23!
24!
25! Former revisions:
26! -----------------!
27! $Id: pmc_particle_interface.f90 4444 2020-03-05 15:59:50Z eckhard $
28! bugfix: preprocessor directives for serial mode added
29!
30! 4360 2020-01-07 11:25:50Z suehring
31! Corrected "Former revisions" section
32!
33! 4043 2019-06-18 16:59:00Z schwenkel
34! Remove min_nr_particle
35!
36! 4017 2019-06-06 12:16:46Z schwenkel
37! coarse bound renamed as parent_bound and icl, icr, jcs, jcn as ipl, ipr, jps, jpn.
38!
39! 3883 2019-04-10 12:51:50Z hellstea
40! Function get_number_of_childs renamed to get_number_of_children and cg
41! renamed to pg according to their definitions in pmc_interface_mod
42!
43! 3655 2019-01-07 16:51:22Z knoop
44! unused variables removed
45!
46! Initial Version (by Klaus Ketelsen)
47!
48!
49! Description:
50! ------------
51! Introduce particle transfer in nested models.
52! Interface to palm lpm model to handel particle transfer between parent and
53! child model.
54!------------------------------------------------------------------------------!
55#if defined( __parallel )
56
57   USE, INTRINSIC ::  ISO_C_BINDING
58
59#if defined( __parallel )  &&  !defined( __mpifh )
60   USE MPI
61#endif
62
63   USE kinds
64
65   USE pegrid,                                                                 &
66       ONLY: myidx,myidy
67
68   USE indices,                                                                &
69       ONLY: nx, ny, nxl, nxr, nys, nyn, nzb, nzt, nxlg, nxrg, nysg, nyng, nbgp
70
71   USE grid_variables,                                                         &
72       ONLY:  dx, dy
73
74   USE arrays_3d,                                                              &
75        ONLY: zw
76
77   USE control_parameters,                                                     &
78       ONLY:  message_string
79
80   USE particle_attributes,                                                    &
81       ONLY:  prt_count, particles, grid_particles,                            &
82              particle_type, number_of_particles, zero_particle,               &
83              ibc_par_t, ibc_par_lr, ibc_par_ns, alloc_factor
84
85!    USE lpm_pack_and_sort_mod
86
87#if defined( __parallel )
88   USE pmc_general,                                                            &
89       ONLY: pedef
90
91   USE pmc_parent,                                                             &
92       ONLY: children, pmc_s_fillbuffer, pmc_s_getdata_from_buffer,            &
93             pmc_s_get_child_npes
94
95   USE pmc_child,                                                              &
96       ONLY:  me, pmc_c_getbuffer, pmc_c_putbuffer
97
98   USE pmc_interface,                                                          &
99       ONLY: cpl_id, get_number_of_children, nr_part, part_adr, nested_run,    &
100             get_childid, get_child_edges, nr_partc, part_adrc,                &
101             parent_bound, coord_x, coord_y, pg, get_child_gridspacing,        &
102             lower_left_coord_x, lower_left_coord_y
103
104    USE pmc_handle_communicator,                                               &
105        ONLY:  pmc_parent_for_child
106
107   USE pmc_mpi_wrapper,                                                        &
108       ONLY: pmc_send_to_parent, pmc_recv_from_child
109
110#endif
111
112   IMPLICIT NONE
113
114#if defined( __parallel )  &&  defined( __mpifh )
115   INCLUDE "mpif.h"
116#endif
117
118   PRIVATE
119   SAVE
120
121   TYPE  coarse_particle_def
122      INTEGER(iwp) ::  nr_particle
123     
124      TYPE(particle_type),ALLOCATABLE,DIMENSION(:) ::  parent_particles
125   END TYPE  coarse_particle_def
126
127   INTEGER(iwp),PARAMETER ::  Min_particles_per_column = 100      !<
128   INTEGER(iwp),PARAMETER ::  max_nr_particle_in_rma_win = 100000 !<
129
130   INTEGER(iwp) ::  nr_fine_in_coarse  !< Number of fine grid cells in coarse grid (one direction)
131   INTEGER(iwp) ::  particle_win_child !<
132
133   INTEGER(iwp),ALLOCATABLE,DIMENSION(:) ::  particle_win_parent !<
134   
135   TYPE(C_PTR), ALLOCATABLE,DIMENSION(:) ::  buf_ptr !<
136   
137   TYPE(particle_type), DIMENSION(:),POINTER ::  particle_in_win !<
138
139   TYPE(coarse_particle_def),ALLOCATABLE,DIMENSION(:,:) ::  coarse_particles !<
140
141   
142
143   INTERFACE pmcp_g_init
144      MODULE PROCEDURE pmcp_g_init
145   END  INTERFACE pmcp_g_init
146
147   INTERFACE pmcp_g_alloc_win
148      MODULE PROCEDURE pmcp_g_alloc_win
149   END  INTERFACE pmcp_g_alloc_win
150
151   INTERFACE pmcp_c_get_particle_from_parent
152      MODULE PROCEDURE pmcp_c_get_particle_from_parent
153   END  INTERFACE pmcp_c_get_particle_from_parent
154
155   INTERFACE pmcp_c_send_particle_to_parent
156      MODULE PROCEDURE pmcp_c_send_particle_to_parent
157   END  INTERFACE pmcp_c_send_particle_to_parent
158
159   INTERFACE pmcp_p_fill_particle_win
160      MODULE PROCEDURE pmcp_p_fill_particle_win
161   END  INTERFACE pmcp_p_fill_particle_win
162
163   INTERFACE pmcp_p_empty_particle_win
164      MODULE PROCEDURE pmcp_p_empty_particle_win
165   END  INTERFACE pmcp_p_empty_particle_win
166
167   INTERFACE pmcp_g_print_number_of_particles
168      MODULE PROCEDURE pmcp_g_print_number_of_particles
169   END  INTERFACE pmcp_g_print_number_of_particles
170
171   INTERFACE pmcp_p_delete_particles_in_fine_grid_area
172      MODULE PROCEDURE pmcp_p_delete_particles_in_fine_grid_area
173   END  INTERFACE pmcp_p_delete_particles_in_fine_grid_area
174
175   PUBLIC pmcp_g_init, pmcp_g_alloc_win, pmcp_c_get_particle_from_parent
176   PUBLIC pmcp_c_send_particle_to_parent, pmcp_p_fill_particle_win, pmcp_g_print_number_of_particles
177   PUBLIC pmcp_p_empty_particle_win, pmcp_p_delete_particles_in_fine_grid_area
178
179 CONTAINS
180
181!------------------------------------------------------------------------------!
182! Description:
183! ------------
184!> general routine:
185!> Initializing actions of the particle interface
186!> check particle boundary conditions for the child models
187!------------------------------------------------------------------------------!
188 SUBROUTINE pmcp_g_init
189 
190    IMPLICIT NONE
191 
192    INTEGER(iwp) ::  nr_childs !< Number of child models of the current model
193
194#if defined( __parallel )
195
196    nr_childs = get_number_of_children()
197!
198!-- Check if the current model has child models
199    IF ( nr_childs > 0 )   THEN
200       ALLOCATE( nr_part(nysg:nyng, nxlg:nxrg) )
201       ALLOCATE( part_adr(nysg:nyng, nxlg:nxrg) )
202       nr_part = 0
203       part_adr   = 0
204    ENDIF
205
206!
207!-- Set the boundary conditions to nested for all non root (i.e child) models
208    IF ( cpl_id > 1 )  THEN
209   
210       IF ( ibc_par_t /= 3 )   THEN
211          ibc_par_t  = 3
212          message_string = 'In Child model:  ibc_par_t is automatically set to nested '
213          CALL message( 'pmcp_g_init ', 'PA0477', 0, 1, 0, 6, 0 )
214       ENDIF
215   
216       IF ( ibc_par_lr /= 3 )   THEN
217          ibc_par_lr = 3
218          message_string = 'In Child model:  ibc_par_lr is automatically set to nested '
219          CALL message( 'pmcp_g_init ', 'PA0478', 0, 1, 0, 6, 0 )
220       ENDIF
221       
222       IF ( ibc_par_ns /= 3 )   THEN
223          ibc_par_ns = 3
224          message_string = 'In Child model:  ibc_par_ns is automatically set to nested '
225          CALL message( 'pmcp_g_init ', 'PA0479', 0, 1, 0, 6, 0 )
226       ENDIF
227       
228    ENDIF
229
230#endif
231 END SUBROUTINE pmcp_g_init
232!------------------------------------------------------------------------------!
233! Description:
234! ------------
235!> general routine:
236!> allocate the MPI windows
237!------------------------------------------------------------------------------!
238 SUBROUTINE pmcp_g_alloc_win
239 
240    IMPLICIT NONE
241   
242    INTEGER(iwp) ::  m         !< loop index
243    INTEGER(iwp) ::  ierr      !< error code
244    INTEGER(iwp) ::  ipl       !< left boundary in coarse(parent) index space
245    INTEGER(iwp) ::  ipr       !< right boundary in coarse(parent) index space
246    INTEGER(iwp) ::  jps       !< south boundary in coarse(parent) index space
247    INTEGER(iwp) ::  jpn       !< north boundary in coarse(parent) index space
248    INTEGER(iwp) ::  child_id  !< Id of a child model
249    INTEGER(iwp) ::  nr_childs !< Number of child models of the current model
250   
251    INTEGER ::  parsize !<
252    TYPE(C_PTR), SAVE ::  ptr !<
253   
254    TYPE(particle_type),DIMENSION(:),POINTER ::  win_buffer !<
255   
256    INTEGER(iwp),DIMENSION(1) ::  buf_shape !<
257
258#if defined( __parallel )
259    INTEGER(KIND=MPI_ADDRESS_KIND) ::  parsize_mpi_address_kind !<
260    INTEGER(KIND=MPI_ADDRESS_KIND) ::  winsize !<
261
262!
263!-- If the model has a parent model prepare the structures for transfer
264    IF ( cpl_id > 1 )  THEN
265
266       parsize_mpi_address_kind = STORAGE_SIZE(zero_particle)/8
267
268       CALL MPI_ALLOC_MEM( parsize_mpi_address_kind , MPI_INFO_NULL, ptr, ierr )
269       parsize = parsize_mpi_address_kind
270       buf_shape(1) = 1
271       CALL C_F_POINTER( ptr, win_buffer, buf_shape )
272       CALL MPI_WIN_CREATE( win_buffer, parsize_mpi_address_kind, parsize,     &
273                            MPI_INFO_NULL, me%intra_comm, particle_win_child,  &
274                            ierr )
275
276!
277!--    Child domain boundaries in the parent index space
278       ipl = parent_bound(1)
279       ipr = parent_bound(2)
280       jps = parent_bound(3)
281       jpn = parent_bound(4)
282
283       ALLOCATE( coarse_particles(jps:jpn,ipl:ipr) )
284
285       coarse_particles(:,:)%nr_particle = 0
286    ENDIF
287
288!
289!-- If the model has child models prepare the structures for transfer
290    nr_childs = get_number_of_children()
291    IF ( nr_childs > 0 )   THEN
292       ALLOCATE( particle_win_parent(nr_childs) )
293       ALLOCATE( buf_ptr(nr_childs) )
294       DO  m = 1, nr_childs
295          child_id = get_childid(m)
296          parsize_mpi_address_kind = STORAGE_SIZE(zero_particle)/8
297          parsize = parsize_mpi_address_kind
298
299          winsize = max_nr_particle_in_rma_win * parsize_mpi_address_kind
300          CALL MPI_ALLOC_MEM( winsize , MPI_INFO_NULL, buf_ptr(m), ierr )
301          buf_shape(1) = max_nr_particle_in_rma_win
302          CALL C_F_POINTER( buf_ptr(m), win_buffer, buf_shape )
303          CALL MPI_WIN_CREATE( win_buffer, winsize, parsize, MPI_INFO_NULL,    &
304                               children(child_id)%intra_comm,                  &
305                               particle_win_parent(m), ierr )
306          ENDDO
307    ENDIF
308
309#endif
310 END SUBROUTINE pmcp_g_alloc_win
311
312
313!------------------------------------------------------------------------------!
314! Description:
315! ------------
316!> child routine:
317!> Read/get particles out of the parent MPI window
318!------------------------------------------------------------------------------!
319 SUBROUTINE pmcp_c_get_particle_from_parent
320 
321    IMPLICIT NONE
322
323    INTEGER(iwp) ::  i    !< x grid index
324    INTEGER(iwp) ::  ipl  !< left boundary in coarse(parent) index space
325    INTEGER(iwp) ::  ierr !< error code
326    INTEGER(iwp) ::  ij   !< combined xy index for the buffer array
327    INTEGER(iwp) ::  ip   !< loop index (child PEs)
328    INTEGER(iwp) ::  j    !< y grid index
329    INTEGER(iwp) ::  jps  !< south boundary in coarse(parent) index space
330    INTEGER(iwp) ::  nr   !< number of particles to receive from a parent box
331   
332    INTEGER ::  parsize !<
333
334#if defined( __parallel )
335    TYPE(pedef), POINTER ::  ape !< TO_DO Klaus: give a description and better name of the variable
336
337    INTEGER(KIND=MPI_ADDRESS_KIND) ::  parsize_mpi_address_kind !<
338    INTEGER(KIND=MPI_ADDRESS_KIND) ::  target_disp !<
339
340    IF ( cpl_id > 1 )  THEN
341   
342       CALL pmc_c_getbuffer( particle_transfer = .TRUE. ) !Get number of particle/column and offset in RMA window xx
343
344!
345!--    Wait for buffer to fill.
346!
347!--    The parent side (in pmc_s_fillbuffer) is filling the buffer in the MPI RMA window
348!--    When the filling is complete, a MPI_BARRIER is called.
349!--    The child is not allowd to access the parent-buffer before it is completely filled
350!--    Synchronization is done implicitely in pmc_c_getbuffer and pmc_s_fillbuffer on the parent side
351
352       ipl = parent_bound(1)
353       jps = parent_bound(3)
354
355       DO  ip = 1, me%inter_npes
356
357          ape => me%pes(ip)
358
359          DO  ij = 1, ape%nrele
360              j = ape%locind(ij)%j + jps - 1
361              i = ape%locind(ij)%i + ipl - 1
362              nr = nr_partc(j,i)
363              IF ( nr > 0 )  THEN
364
365                 CALL check_and_alloc_coarse_particle (i, j, nr)
366                 parsize_mpi_address_kind = STORAGE_SIZE(zero_particle)/8
367                 parsize = parsize_mpi_address_kind
368                 target_disp = part_adrc(j,i) - 1
369                 CALL MPI_WIN_LOCK( MPI_LOCK_SHARED , ip - 1, 0,               &
370                                    particle_win_child, ierr )
371                 CALL MPI_GET( coarse_particles(j,i)%parent_particles,         &
372                               nr * parsize, MPI_BYTE, ip - 1, target_disp,    &
373                               nr * parsize, MPI_BYTE, particle_win_child, ierr )
374                 CALL MPI_WIN_UNLOCK( ip - 1, particle_win_child, ierr )
375             ENDIF
376             coarse_particles(j,i)%nr_particle = nr
377          ENDDO
378       ENDDO
379
380       CALL c_copy_particle_to_child_grid
381    ENDIF
382
383#endif
384 END SUBROUTINE pmcp_c_get_particle_from_parent
385
386
387!------------------------------------------------------------------------------!
388! Description:
389! ------------
390!> child routine:
391!> Write/put particles into the parent MPI window
392!------------------------------------------------------------------------------!
393  SUBROUTINE pmcp_c_send_particle_to_parent
394 
395    IMPLICIT NONE
396   
397    INTEGER(iwp) ::  disp_offset            !<
398    INTEGER(iwp) ::  i                      !< x loop index
399    INTEGER(iwp) ::  ipl                    !< left boundary in coarse(parent) index space
400    INTEGER(iwp) ::  ipr                    !< right boundary in coarse(parent) index space
401    INTEGER(iwp) ::  ierr                   !< error code
402    INTEGER(iwp) ::  ij                     !< combined xy index for the buffer array
403    INTEGER(iwp) ::  ip                     !< loop index (child PEs)
404    INTEGER(iwp) ::  j                      !< y loop index
405    INTEGER(iwp) ::  jps                    !< south boundary in coarse(parent) index space
406    INTEGER(iwp) ::  jpn                    !< north boundary in coarse(parent) index space
407    INTEGER(iwp) ::  max_nr_particle_per_pe !< maximum number of particles per PE (depending on grid apect ratio)
408    INTEGER(iwp) ::  n                      !< shorter variable name for nr_fine_in_coarse
409    INTEGER(iwp) ::  nr                     !< shorter variabel name for nr_partc
410    INTEGER(iwp) ::  pe_offset              !< offset index of the current PE
411   
412    INTEGER ::  parsize !<
413   
414    REAL(wp) ::  eps=0.00001 !< used in calculations to avoid rounding errors
415    REAL(wp) ::  xx          !< number of fine grid cells inside a coarse grid cell in x-direction
416    REAL(wp) ::  yy          !< number of fine grid cells inside a coarse grid cell in y-direction
417
418 !   TYPE(particle_type) ::  dummy_part !< dummy particle (needed for size calculations)
419
420#if defined( __parallel )
421    TYPE(pedef), POINTER ::  ape !< TO_DO Klaus: give a description and better name of the variable
422
423    INTEGER(KIND=MPI_ADDRESS_KIND) ::  parsize_mpi_address_kind !<
424    INTEGER(KIND=MPI_ADDRESS_KIND) ::  target_disp !<
425   
426   
427    IF ( cpl_id > 1 )  THEN
428       CALL c_copy_particle_to_coarse_grid
429
430!
431!--    Child domain boundaries in the parent index space
432
433       ipl = parent_bound(1)
434       ipr = parent_bound(2)
435       jps = parent_bound(3)
436       jpn = parent_bound(4)
437
438       nr_partc = 0
439       
440       DO i = ipl, ipr
441          DO j = jps, jpn
442             nr_partc(j,i) = coarse_particles(j,i)%nr_particle
443          ENDDO
444       ENDDO
445       part_adrc = 0
446
447!
448!--    compute number of fine grid cells in coarse grid (one direction)
449       xx = ( pg%dx + eps ) / dx ! +eps to avoid rounding error
450       yy = ( pg%dy + eps ) / dy
451       nr_fine_in_coarse = MAX( INT(xx), INT(yy) )
452
453       IF ( MOD( coord_x(0), pg%dx ) /= 0.0 .OR. MOD( coord_y(0), pg%dy ) /= 0.0 ) THEN
454          nr_fine_in_coarse = nr_fine_in_coarse + 1
455       ENDIF
456
457!
458!--    Assign a number to my child PE to select different areas in the RMA window on server side
459!--    With this number a square of child PEs is defined which share the same coarse grid cells
460
461       n           = nr_fine_in_coarse ! local variable n to make folloing statements shorter
462       pe_offset   = MOD( myidx, n ) * n + MOD( myidy, n)
463       max_nr_particle_per_pe = max_nr_particle_in_rma_win / ( n * n )
464       disp_offset            = pe_offset * max_nr_particle_per_pe
465       parsize_mpi_address_kind = STORAGE_SIZE(zero_particle)/8
466       parsize = parsize_mpi_address_kind
467       DO  ip = 1, me%inter_npes
468
469          ape => me%pes(ip)
470
471          target_disp = disp_offset
472          DO ij = 1, ape%nrele
473             j  = ape%locind(ij)%j + jps - 1
474             i  = ape%locind(ij)%i + ipl - 1
475             nr = nr_partc(j,i)
476             IF( nr > 0 ) THEN
477                IF ( target_disp + nr - disp_offset >= max_nr_particle_per_pe ) THEN
478                   WRITE(9,*) 'RMA window too small on child ',                &
479                              target_disp + nr - disp_offset,                  &
480                              max_nr_particle_per_pe, max_nr_particle_in_rma_win
481                   message_string = 'RMA window too small on child'
482                   CALL message( 'pmci_create_child_arrays', 'PA0480', 3, 2, 0, 6, 0 )
483                ENDIF
484                CALL MPI_WIN_LOCK( MPI_LOCK_SHARED , ip - 1, 0,                &
485                                   particle_win_child, ierr )
486                CALL MPI_PUT( coarse_particles(j,i)%parent_particles,          &
487                              nr * parsize, MPI_BYTE, ip - 1, target_disp,     &
488                              nr * parsize, MPI_BYTE,  particle_win_child, ierr )
489                CALL MPI_WIN_UNLOCK( ip - 1, particle_win_child, ierr )
490                part_adrc(j,i) = target_disp + 1
491                target_disp    = target_disp + nr
492             ENDIF
493          ENDDO
494       ENDDO
495
496       CALL pmc_c_putbuffer ( particle_transfer = .TRUE. )   !Send new number of particle/column and offset to parent
497
498    ENDIF
499
500#endif
501 END SUBROUTINE pmcp_c_send_particle_to_parent
502
503
504!------------------------------------------------------------------------------!
505! Description:
506! ------------
507!> parent routine:
508!> write particles into the MPI window
509!------------------------------------------------------------------------------!
510 SUBROUTINE pmcp_p_fill_particle_win
511 
512    IMPLICIT NONE
513
514    LOGICAL      ::  active_particle !< Particles located in the fine/child grid area are marked as active (to be transferred)
515    LOGICAL,SAVE ::  lfirst = .TRUE. !<
516   
517    INTEGER(iwp) ::  child_id            !< id of the child model
518    INTEGER(iwp) ::  i                   !< x grid box index
519    INTEGER(iwp) ::  ij                  !< combined xy index for the buffer array
520    INTEGER(iwp) ::  ip                  !< loop index (child PEs)
521    INTEGER(iwp) ::  j                   !< y grid box index
522    INTEGER(iwp) ::  k                   !< z grid box index
523    INTEGER(iwp) ::  m                   !< loop index (number of childs)
524    INTEGER(iwp) ::  n                   !< loop index (number of particles)
525    INTEGER(iwp) ::  nr_part_col         !< Number of particles to transfer per column
526    INTEGER(iwp) ::  number_of_particles !<
527    INTEGER(iwp) ::  pindex              !<
528    INTEGER(iwp) ::  tot_particle_count  !< Total number of particles per child
529   
530    REAL(wp) ::  dx_child   !< child grid spacing
531    REAL(wp) ::  dy_child   !< child grid spacing
532    REAL(wp) ::  dz_child   !< child grid spacing
533    REAL(wp) ::  ny_coord   !< north coordinate of child grid
534    REAL(wp) ::  ny_coord_b !< north coordinate of child grid boundary
535    REAL(wp) ::  lx_coord   !< left coordinate of child grid
536    REAL(wp) ::  lx_coord_b !< left coordinate of child grid boundary
537    REAL(wp) ::  rx_coord   !< right coordinate of child grid
538    REAL(wp) ::  rx_coord_b !< right coordinate of child grid boundary
539    REAL(wp) ::  sy_coord   !< south coordinate of child grid
540    REAL(wp) ::  sy_coord_b !< south coordinate of child grid boundary
541    REAL(wp) ::  uz_coord   !< upper coordinate of child grid
542    REAL(wp) ::  uz_coord_b !< upper coordinate of child grid boundary
543    REAL(wp) ::  x          !< particle position
544    REAL(wp) ::  y          !< particle position
545    REAL(wp) ::  z          !< particle position
546   
547    INTEGER(iwp),DIMENSION(1) ::  buf_shape !<
548   
549#if defined( __parallel )
550    TYPE(pedef), POINTER ::  ape !< TO_DO Klaus: give a description and better name of the variable
551
552    DO  m = 1, get_number_of_children()
553
554       child_id = get_childid(m)
555
556       CALL get_child_edges( m, lx_coord, lx_coord_b, rx_coord, rx_coord_b,    &
557                                sy_coord, sy_coord_b, ny_coord, ny_coord_b,    &
558                                uz_coord, uz_coord_b) 
559
560       CALL get_child_gridspacing( m, dx_child, dy_child, dz_child )
561
562       IF ( lfirst )   THEN
563          WRITE(9,'(a,5f10.2)') 'edges          ',lx_coord,rx_coord,sy_coord,ny_coord,uz_coord
564          WRITE(9,'(a,5f10.2)') 'edges boundary ',lx_coord_b,rx_coord_b,sy_coord_b,ny_coord_b,uz_coord_b
565          WRITE(9,'(a,5f10.2)') 'child spacing  ',dx_child, dy_child, dz_child,lower_left_coord_x,lower_left_coord_y
566       ENDIF
567!
568!--    reset values for every child
569       tot_particle_count = 0 
570       nr_part  = 0           
571       part_adr = 0
572       pindex   = 1
573
574       buf_shape(1) = max_nr_particle_in_rma_win
575       CALL C_F_POINTER( buf_ptr(m), particle_in_win , buf_shape )
576
577       DO  ip = 1, children(child_id)%inter_npes
578
579          ape => children(child_id)%pes(ip)
580
581          nr_part_col   = 0 
582         
583          DO  ij = 1, ape%nrele
584             
585!
586!--          Inside the PMC adressing of 3d arrays starts with 1
587             i = ape%locind(ij)%i + nxl - nbgp - 1
588             j = ape%locind(ij)%j + nys - nbgp - 1
589             nr_part_col = 0   ! Number of particles to transfer per column
590             part_adr(j,i) = pindex
591             
592             DO  k = nzb + 1, nzt
593                number_of_particles = prt_count(k,j,i)
594               
595                IF ( number_of_particles <= 0 )  CYCLE
596               
597                particles => grid_particles(k,j,i)%particles(1:number_of_particles)
598
599                ! Select particles within boundary area
600
601                DO n = 1, number_of_particles
602                   x = particles(n)%x
603                   y = particles(n)%y
604                   z = particles(n)%z
605!
606!--                check if the particle is located in the fine grid area
607                   active_particle = ((x > lx_coord .AND. x < rx_coord) .AND.  & 
608                                      (y > sy_coord .AND. y < ny_coord) .AND.  &
609                                      (z > 0.000000001 .AND. z < uz_coord))
610                   IF ( active_particle .AND. particles(n)%particle_mask )  THEN
611                     
612                      particle_in_win(pindex) = particles(n)
613!
614!--                   Change particle positions and origin relative to global origin
615                      particle_in_win(pindex)%x = particle_in_win(pindex)%x + lower_left_coord_x
616                      particle_in_win(pindex)%y = particle_in_win(pindex)%y + lower_left_coord_y
617                      particle_in_win(pindex)%origin_x = particle_in_win(pindex)%origin_x + lower_left_coord_x
618                      particle_in_win(pindex)%origin_y = particle_in_win(pindex)%origin_y + lower_left_coord_y
619
620                      tot_particle_count = tot_particle_count + 1
621                      nr_part_col        = nr_part_col + 1
622                      pindex             = pindex + 1
623                      IF ( pindex > max_nr_particle_in_rma_win ) THEN
624                         WRITE(9,*) 'RMA window too small on parent ',pindex, max_nr_particle_in_rma_win
625                         message_string = 'RMA window too small on parent'
626                         CALL message( 'pmci_create_child_arrays', 'PA0481', 3, 2, 0, 6, 0 )   ! PA number has to be adjusted
627                     ENDIF
628                   END IF
629                ENDDO
630             ENDDO
631             nr_part(j,i) = nr_part_col
632          ENDDO
633       ENDDO
634
635       CALL pmc_s_fillbuffer( child_id, particle_transfer = .TRUE. )
636    ENDDO
637
638    lfirst = .FALSE.
639
640#endif
641 END SUBROUTINE pmcp_p_fill_particle_win
642
643 
644!------------------------------------------------------------------------------!
645! Description:
646! ------------
647!> parent routine:
648!> delete particles from the MPI window
649!------------------------------------------------------------------------------!
650 SUBROUTINE pmcp_p_empty_particle_win
651
652    IMPLICIT NONE
653
654    INTEGER(iwp) ::  child_id           !< model id of the child
655    INTEGER(iwp) ::  ip                 !< loop index (child PEs)
656    INTEGER(iwp) ::  m                  !< loop index (number of childs)
657
658    INTEGER(iwp),DIMENSION(1) ::  buf_shape !<
659
660#if defined( __parallel )
661    DO  m = 1, get_number_of_children()
662
663       child_id = get_childid(m)
664
665       buf_shape(1) = max_nr_particle_in_rma_win
666       CALL C_F_POINTER( buf_ptr(m), particle_in_win , buf_shape )
667
668!
669!--    In some cells of the coarse grid, there are contributions from more than
670!--    one child process. Therefore p_copy_particle_to_org_grid is done for one
671!--    child process per call
672       DO ip = 1, pmc_s_get_child_npes( child_id )
673
674          nr_part  = 0
675          part_adr = 0
676
677          CALL pmc_s_getdata_from_buffer( child_id, particle_transfer = .TRUE.,&
678                                          child_process_nr = ip )
679          CALL p_copy_particle_to_org_grid( m )
680       ENDDO
681
682    ENDDO
683
684#endif
685 END SUBROUTINE pmcp_p_empty_particle_win
686
687
688!------------------------------------------------------------------------------!
689! Description:
690! ------------
691!> parent routine:
692!> After the transfer mark all parent particles that are still inside on of the
693!> child areas for deletion.
694!------------------------------------------------------------------------------!
695 SUBROUTINE pmcp_p_delete_particles_in_fine_grid_area
696
697    IMPLICIT NONE
698
699    LOGICAL ::  to_delete !< particles outside of model domain are marked as to_delete
700   
701    INTEGER(iwp) ::  i !< loop index (x grid)
702    INTEGER(iwp) ::  j !< loop index (y grid)
703    INTEGER(iwp) ::  k !< loop index (z grid)
704    INTEGER(iwp) ::  m !< loop index (number of particles)
705    INTEGER(iwp) ::  n !< loop index (number of childs)
706   
707    REAL(wp) ::  dx_child   !< child grid spacing
708    REAL(wp) ::  dy_child   !< child grid spacing
709    REAL(wp) ::  dz_child   !< child grid spacing
710    REAL(wp) ::  ny_coord   !< north coordinate of child grid
711    REAL(wp) ::  ny_coord_b !< north coordinate of child grid boundary
712    REAL(wp) ::  lx_coord   !< left coordinate of child grid
713    REAL(wp) ::  lx_coord_b !< left coordinate of child grid boundary
714    REAL(wp) ::  rx_coord   !< right coordinate of child grid
715    REAL(wp) ::  rx_coord_b !< right coordinate of child grid boundary
716    REAL(wp) ::  sy_coord   !< south coordinate of child grid
717    REAL(wp) ::  sy_coord_b !< south coordinate of child grid boundary
718    REAL(wp) ::  uz_coord   !< upper coordinate of child grid
719    REAL(wp) ::  uz_coord_b !< upper coordinate of child grid boundary
720    REAL(wp) ::  x          !< particle position
721    REAL(wp) ::  y          !< particle position
722    REAL(wp) ::  z          !< particle position
723   
724#if defined( __parallel )
725    DO  m = 1, get_number_of_children()
726       CALL get_child_edges( m, lx_coord, lx_coord_b, rx_coord, rx_coord_b,    &
727                                sy_coord, sy_coord_b, ny_coord, ny_coord_b,    &
728                                uz_coord, uz_coord_b )
729
730
731       CALL get_child_gridspacing( m, dx_child, dy_child, dz_child ) 
732
733       DO i = nxl, nxr
734          DO j = nys, nyn
735             DO k = nzb, nzt
736                number_of_particles = prt_count(k,j,i)
737
738                IF ( number_of_particles == 0 ) CYCLE
739
740                particles => grid_particles(k,j,i)%particles(1:number_of_particles)
741
742                DO n = 1, number_of_particles
743                   x = particles(n)%x
744                   y = particles(n)%y
745                   z = particles(n)%z
746
747                   to_delete = ((x > lx_coord .AND. x < rx_coord) .AND.        &
748                                (y > sy_coord .AND. y < ny_coord) .AND.        &
749                                (z > 0.000000001 .AND. z < uz_coord))
750
751                   IF ( to_delete ) THEN
752                      particles(n)%particle_mask = .FALSE.
753                   ENDIF
754                ENDDO
755             ENDDO
756          ENDDO
757       ENDDO
758
759    ENDDO
760
761#endif
762 END SUBROUTINE pmcp_p_delete_particles_in_fine_grid_area
763
764
765!------------------------------------------------------------------------------!
766! Description:
767! ------------
768!> general routine:
769!> print the total number of of the current model and its child models into a file
770!------------------------------------------------------------------------------!
771 SUBROUTINE pmcp_g_print_number_of_particles (my_time,local_nr_particles)
772 
773    USE pegrid,                                                                &
774        ONLY: myid
775 
776    IMPLICIT NONE
777
778    INTEGER(iwp),INTENT(IN) ::  local_nr_particles !<
779   
780    REAL(wp),INTENT(IN) ::  my_time !<
781     
782    LOGICAL, SAVE ::  is_file_open=.FALSE. !<
783   
784    INTEGER(iwp) ::  child_id           !<
785    INTEGER(iwp) ::  child_nr_particles !< total number of particles in all child models
786    INTEGER(iwp) ::  ierr               !< error code
787    INTEGER(iwp) ::  m                  !< loop index (number of childs)
788   
789    CHARACTER(LEN=16) ::  fname !< filename
790   
791    INTEGER(iwp),DIMENSION(2) ::  ivalr !< integer value to be received
792    INTEGER(iwp),DIMENSION(2) ::  ivals !< integer value to be send
793   
794#if defined( __parallel )
795    child_nr_particles = 0
796    IF ( myid == 0 )  THEN
797       IF ( cpl_id > 1 )  THEN
798          ivals(1) = local_nr_particles
799          CALL pmc_send_to_parent( ivals, 1, 0, 400, ierr )
800       ENDIF
801       DO  m = 1, SIZE( pmc_parent_for_child ) - 1
802
803          child_id = pmc_parent_for_child(m)
804          CALL pmc_recv_from_child( child_id, ivalr, 1, 0, 400, ierr )
805          child_nr_particles = child_nr_particles + ivalr(1)
806       ENDDO
807
808       IF ( SIZE( pmc_parent_for_child ) > 1 ) THEN
809          IF ( .NOT. is_file_open )  THEN !kk muss noch auf file_open umgestellt werden
810             WRITE(fname,'(a,i2.2)') 'nr_particles_',cpl_id
811             OPEN (333,file = fname)
812             is_file_open = .true.
813          ENDIF
814          WRITE(333,'(f12.2,3i10)') my_time,local_nr_particles + child_nr_particles,local_nr_particles,child_nr_particles
815       ENDIF
816    ENDIF
817
818#endif
819 END SUBROUTINE pmcp_g_print_number_of_particles
820
821
822!------------------------------------------------------------------------------!
823!------------------------------------------------------------------------------!
824! Private subroutines
825!------------------------------------------------------------------------------!
826!------------------------------------------------------------------------------!
827
828!------------------------------------------------------------------------------!
829! Description:
830! ------------
831!> child routine
832!> update the size of the local buffer (coarse_particles)
833!------------------------------------------------------------------------------!
834 SUBROUTINE check_and_alloc_coarse_particle (ic,jc,nr,with_copy)
835   
836    IMPLICIT NONE
837   
838    INTEGER(iwp),INTENT(IN) ::  ic !< coarse x grid index
839    INTEGER(iwp),INTENT(IN) ::  jc !< coarse y grid index
840    INTEGER(iwp),INTENT(IN) ::  nr !< number of particles to be transferred/stored in local buffer
841   
842    LOGICAL,INTENT(IN),OPTIONAL ::  with_copy !< copy particles in buffer? or reallocate empty buffer
843
844    LOGICAL :: with_copy_lo !< local variable of with copy
845   
846    INTEGER(iwp) ::  new_size !< new size of the local buffer
847    INTEGER(iwp) ::  old_size !< old size of the local buffer
848   
849    TYPE(particle_type), DIMENSION(:), ALLOCATABLE ::  tmp_particles_d !<
850
851#if defined( __parallel )
852    with_copy_lo = .FALSE.
853    IF ( PRESENT( with_copy ) ) with_copy_lo = with_copy
854
855    IF ( .NOT. ALLOCATED( coarse_particles(jc,ic)%parent_particles ) ) THEN
856       new_size = MAX( nr, Min_particles_per_column )
857       ALLOCATE( coarse_particles(jc,ic)%parent_particles(new_size) )
858    ELSEIF ( nr > SIZE( coarse_particles(jc,ic)%parent_particles ) ) THEN
859
860       old_size = SIZE( coarse_particles(jc,ic)%parent_particles )
861       new_size = old_size * ( 1.0_wp + alloc_factor / 100.0_wp )
862       new_size = MAX( nr, new_size, old_size + Min_particles_per_column )
863
864!
865!--    Copy existing particles to new particle buffer
866       IF ( with_copy_lo ) THEN
867          ALLOCATE( tmp_particles_d(old_size) )
868          tmp_particles_d(1:old_size) = coarse_particles(jc,ic)%parent_particles
869
870          DEALLOCATE( coarse_particles(jc,ic)%parent_particles )
871          ALLOCATE( coarse_particles(jc,ic)%parent_particles(new_size) )
872
873          coarse_particles(jc,ic)%parent_particles(1:old_size)          = tmp_particles_d(1:old_size)
874          coarse_particles(jc,ic)%parent_particles(old_size+1:new_size) = zero_particle
875
876          DEALLOCATE( tmp_particles_d )
877!
878!--    allocate or reallocate an empty buffer
879       ELSE
880          DEALLOCATE( coarse_particles(jc,ic)%parent_particles )
881          ALLOCATE( coarse_particles(jc,ic)%parent_particles(new_size) )
882       ENDIF
883    ENDIF
884
885#endif
886 END SUBROUTINE check_and_alloc_coarse_particle
887
888
889!------------------------------------------------------------------------------!
890! Description:
891! ------------
892!> child routine:
893!> copy/sort particles out of the local buffer into the respective grid boxes
894!------------------------------------------------------------------------------!
895 SUBROUTINE c_copy_particle_to_child_grid
896 
897    IMPLICIT NONE
898 
899    INTEGER(iwp) ::  ic  !< coarse x grid index
900    INTEGER(iwp) ::  ipl !< left boundary in coarse(parent) index space
901    INTEGER(iwp) ::  ipr !< right boundary in coarse(parent) index space
902    INTEGER(iwp) ::  ip  !< x grid index
903    INTEGER(iwp) ::  jc  !< coarse y grid index
904    INTEGER(iwp) ::  jpn !< north boundary in coarse(parent) index space
905    INTEGER(iwp) ::  jps !< south boundary in coarse(parent) index space
906    INTEGER(iwp) ::  jp  !< y grid index
907    INTEGER(iwp) ::  kp  !< z grid index
908    INTEGER(iwp) ::  n   !< loop index (number of particles)
909    INTEGER(iwp) ::  nr  !< short variable for name number or particles
910   
911    REAL(wp) ::  xc  !< child x coordinate
912    REAL(wp) ::  xoc !< child x origin
913    REAL(wp) ::  yc  !< child y coordinate
914    REAL(wp) ::  yoc !< child y origin
915    REAL(wp) ::  zc  !< child z coordinate
916
917#if defined( __parallel )
918!
919!-- Child domain boundaries in the parent index space
920    ipl = parent_bound(1)
921    ipr = parent_bound(2)
922    jps = parent_bound(3)
923    jpn = parent_bound(4)
924
925    DO ic = ipl, ipr
926       DO jc = jps, jpn
927          nr = coarse_particles(jc,ic)%nr_particle
928
929          IF ( nr > 0 ) THEN
930             DO n = 1, nr
931                xc =  coarse_particles(jc,ic)%parent_particles(n)%x-lower_left_coord_x
932                yc =  coarse_particles(jc,ic)%parent_particles(n)%y-lower_left_coord_y
933                zc =  coarse_particles(jc,ic)%parent_particles(n)%z
934                xoc = coarse_particles(jc,ic)%parent_particles(n)%origin_x-lower_left_coord_x
935                yoc = coarse_particles(jc,ic)%parent_particles(n)%origin_y-lower_left_coord_y
936                ip = xc / dx
937                jp = yc / dy
938                kp = nzt
939                DO WHILE ( zw(kp-1) > zc .AND. kp > nzb + 1 )         ! kk search loop has to be optimzed !!!
940                   kp = kp - 1
941                ENDDO 
942
943                IF ( ip >= nxl .AND. ip <= nxr .AND. jp >= nys .AND. jp <= nyn ) THEN
944                   prt_count(kp,jp,ip) = prt_count(kp,jp,ip) + 1
945                   IF ( prt_count(kp,jp,ip) > SIZE( grid_particles(kp,jp,ip)%particles ) ) THEN
946                      CALL pmc_realloc_particles_array( ip, jp, kp )
947                   ENDIF
948                   coarse_particles(jc,ic)%parent_particles(n)%x = xc                   ! Adjust coordinates to child grid
949                   coarse_particles(jc,ic)%parent_particles(n)%y = yc
950                   coarse_particles(jc,ic)%parent_particles(n)%origin_x = xoc           ! Adjust origins to child grid
951                   coarse_particles(jc,ic)%parent_particles(n)%origin_y = yoc
952                   grid_particles(kp,jp,ip)%particles(prt_count(kp,jp,ip)) = coarse_particles(jc,ic)%parent_particles(n)
953                ENDIF
954             ENDDO
955          ENDIF
956       ENDDO
957    ENDDO
958
959#endif
960 END SUBROUTINE c_copy_particle_to_child_grid
961
962
963!------------------------------------------------------------------------------!
964! Description:
965! ------------
966!> child routine:
967!> copy particles which left the model area into the local buffer
968!------------------------------------------------------------------------------!
969 SUBROUTINE c_copy_particle_to_coarse_grid
970 
971    IMPLICIT NONE
972   
973    LOGICAL ::  boundary_particle !<
974   
975    INTEGER(iwp) ::  i    !< loop index (x grid)
976    INTEGER(iwp) ::  ic   !< loop index (coarse x grid)
977    INTEGER(iwp) ::  ipl  !< left boundary in coarse(parent) index space
978    INTEGER(iwp) ::  ipr  !< left boundary in coarse(parent) index space
979    INTEGER(iwp) ::  ierr !< error code
980    INTEGER(iwp) ::  j    !< loop index (y grid)
981    INTEGER(iwp) ::  jc   !< loop index (coarse y grid)
982    INTEGER(iwp) ::  jps  !< south boundary in coarse(parent) index space
983    INTEGER(iwp) ::  jpn  !< north boundary in coarse(parent) index space
984    INTEGER(iwp) ::  k    !< loop index (z grid)
985    INTEGER(iwp) ::  n    !< loop index (number of particles)
986   
987    REAL(wp) ::  x       !< x coordinate
988    REAL(wp) ::  xo      !< x origin
989    REAL(wp) ::  x_left  !< absolute left boundary
990    REAL(wp) ::  x_right !< absolute right boundary
991    REAL(wp) ::  y       !< left boundary in coarse(parent) index space
992    REAL(wp) ::  yo      !< y origin
993    REAL(wp) ::  y_north !< absolute north boundary
994    REAL(wp) ::  y_south !< absoulte south boundary
995    REAL(wp) ::  z       !< z coordinate
996
997#if defined( __parallel )
998!
999!-- Child domain boundaries in the parent index space
1000
1001    ipl = parent_bound(1)
1002    ipr = parent_bound(2)
1003    jps = parent_bound(3)
1004    jpn = parent_bound(4)
1005
1006!
1007!-- absolute coordinates
1008    x_left  = coord_x(0)
1009    x_right = coord_x(nx) + dx
1010    y_south = coord_y(0)
1011    y_north = coord_y(ny) + dy
1012
1013!   Clear Particle Buffer
1014
1015    DO ic = ipl, ipr
1016       DO jc = jps, jpn
1017          coarse_particles(jc,ic)%nr_particle = 0
1018       ENDDO
1019    ENDDO
1020
1021!
1022!-- Determine particles which leave the inner area in east or west dirextion
1023!-- Compute only first (nxl) and last (nxr) loop iterration.
1024    DO  i = nxl, nxr
1025       DO  j = nys, nyn
1026          DO  k = nzb + 1, nzt
1027             number_of_particles = prt_count(k,j,i)
1028             IF ( number_of_particles <= 0 )  CYCLE
1029             particles => grid_particles(k,j,i)%particles(1:number_of_particles)
1030             DO  n = 1, number_of_particles
1031                IF ( particles(n)%particle_mask )  THEN
1032                   x =  particles(n)%x+ lower_left_coord_x 
1033                   y =  particles(n)%y+ lower_left_coord_y 
1034                   xo = particles(n)%origin_x + lower_left_coord_x
1035                   yo = particles(n)%origin_y + lower_left_coord_y
1036                   z =  particles(n)%z
1037                   
1038                   boundary_particle = .FALSE.
1039                   boundary_particle = boundary_particle .OR. (x < x_left  .OR. x > x_right)
1040                   boundary_particle = boundary_particle .OR. (y < y_south .OR. y > y_north)
1041                   boundary_particle = boundary_particle .OR. (z > zw(nzt))
1042
1043                   IF ( boundary_particle ) THEN                     
1044                      ic = x / pg%dx                     !TODO anpassen auf Mehrfachnesting
1045                      jc = y / pg%dy
1046
1047                      IF ( ic >= ipl .AND. ic <= ipr .AND. jc >= jps .AND. jc <= jpn ) THEN
1048                         coarse_particles(jc,ic)%nr_particle = coarse_particles(jc,ic)%nr_particle + 1
1049                         CALL check_and_alloc_coarse_particle( ic, jc, coarse_particles(jc,ic)%nr_particle, with_copy=.TRUE. )
1050
1051                         coarse_particles(jc,ic)%parent_particles(coarse_particles(jc,ic)%nr_particle)   = particles(n)
1052                         coarse_particles(jc,ic)%parent_particles(coarse_particles(jc,ic)%nr_particle)%x = x   !adapt to global coordinates
1053                         coarse_particles(jc,ic)%parent_particles(coarse_particles(jc,ic)%nr_particle)%y = y
1054                         coarse_particles(jc,ic)%parent_particles(coarse_particles(jc,ic)%nr_particle)%origin_x = xo
1055                         coarse_particles(jc,ic)%parent_particles(coarse_particles(jc,ic)%nr_particle)%origin_y = yo
1056!--                      Mark particle as deleted after copying it to the transfer buffer
1057                         grid_particles(k,j,i)%particles(n)%particle_mask = .FALSE.
1058                      ELSE
1059                         WRITE(9,'(a,10i6)') 'This should not happen ',i,j,k,ic,jc,ipl,ipr,jps,jpn
1060                         CALL MPI_Abort( MPI_COMM_WORLD, 9999, ierr )
1061                      ENDIF
1062                   ENDIF
1063                ENDIF
1064             ENDDO
1065          ENDDO
1066       ENDDO
1067    ENDDO
1068
1069!
1070!- Pack particles (eliminate those marked for deletion),
1071!- determine new number of particles
1072!    CALL lpm_sort_in_subboxes
1073
1074#endif
1075 END SUBROUTINE c_copy_particle_to_coarse_grid
1076
1077
1078!------------------------------------------------------------------------------!
1079! Description:
1080! ------------
1081!> parent routine:
1082!> copy/sort particles from the MPI window into the respective grid boxes
1083!------------------------------------------------------------------------------!
1084 SUBROUTINE p_copy_particle_to_org_grid( m )
1085
1086    IMPLICIT NONE
1087
1088    INTEGER(iwp),INTENT(IN) ::  m        !<
1089
1090    INTEGER(iwp) ::  i      !< loop index (x grid)
1091    INTEGER(iwp) ::  j      !< loop index (y grid)
1092    INTEGER(iwp) ::  k      !< loop index (z grid)
1093    INTEGER(iwp) ::  n      !< loop index (nr part)
1094    INTEGER(iwp) ::  nr     !< short variable name for nr_part
1095    INTEGER(iwp) ::  pindex !< short variable name part_adr
1096   
1097    REAL(wp) ::  x  !< x coordinate
1098    REAL(wp) ::  xo !< x origin
1099    REAL(wp) ::  y  !< y coordinate
1100    REAL(wp) ::  yo !< y origin
1101    REAL(wp) ::  z  !< z coordinate
1102   
1103    INTEGER(iwp),DIMENSION(1) ::  buf_shape !<
1104
1105#if defined( __parallel )
1106    buf_shape(1) = max_nr_particle_in_rma_win
1107    CALL C_F_POINTER( buf_ptr(m), particle_in_win , buf_shape )
1108
1109    DO i = nxl, nxr
1110       DO j = nys, nyn
1111          nr = nr_part(j,i)
1112          IF ( nr > 0 ) THEN
1113             pindex = part_adr(j,i)
1114             DO n = 1, nr
1115                x = particle_in_win(pindex)%x-lower_left_coord_x
1116                y = particle_in_win(pindex)%y-lower_left_coord_y
1117                z = particle_in_win(pindex)%z
1118                xo = particle_in_win(pindex)%origin_x-lower_left_coord_x
1119                yo = particle_in_win(pindex)%origin_y-lower_left_coord_y
1120                k = nzt + 1
1121                DO WHILE ( zw(k-1) > z .AND. k > nzb + 1 )           ! kk search loop has to be optimzed !!!
1122                   k = k - 1
1123                END DO
1124
1125                prt_count(k,j,i) = prt_count(k,j,i) + 1
1126                IF ( prt_count(k,j,i) > SIZE( grid_particles(k,j,i)%particles ) ) THEN
1127                   CALL pmc_realloc_particles_array( i, j, k )
1128                ENDIF
1129                grid_particles(k,j,i)%particles(prt_count(k,j,i)) = particle_in_win(pindex)
1130               
1131!
1132!--             Update particle positions and origins relative to parent domain
1133                grid_particles(k,j,i)%particles(prt_count(k,j,i))%x = x
1134                grid_particles(k,j,i)%particles(prt_count(k,j,i))%y = y
1135                grid_particles(k,j,i)%particles(prt_count(k,j,i))%origin_x = xo
1136                grid_particles(k,j,i)%particles(prt_count(k,j,i))%origin_y = yo
1137                pindex = pindex + 1
1138             ENDDO
1139          ENDIF
1140       ENDDO
1141    ENDDO
1142
1143#endif
1144 END SUBROUTINE p_copy_particle_to_org_grid
1145 
1146!------------------------------------------------------------------------------!
1147! Description:
1148! ------------
1149!> If the allocated memory for the particle array do not suffice to add arriving
1150!> particles from neighbour grid cells, this subrouting reallocates the
1151!> particle array to assure enough memory is available.
1152!------------------------------------------------------------------------------!
1153 SUBROUTINE pmc_realloc_particles_array ( i, j, k, size_in )
1154
1155    INTEGER(iwp), INTENT(IN)                       ::  i              !<
1156    INTEGER(iwp), INTENT(IN)                       ::  j              !<
1157    INTEGER(iwp), INTENT(IN)                       ::  k              !<
1158    INTEGER(iwp), INTENT(IN), OPTIONAL             ::  size_in        !<
1159
1160    INTEGER(iwp)                                   ::  old_size        !<
1161    INTEGER(iwp)                                   ::  new_size        !<
1162    TYPE(particle_type), DIMENSION(:), ALLOCATABLE ::  tmp_particles_d !<
1163    TYPE(particle_type), DIMENSION(500)            ::  tmp_particles_s !<
1164
1165    old_size = SIZE(grid_particles(k,j,i)%particles)
1166
1167    IF ( PRESENT(size_in) )   THEN
1168       new_size = size_in
1169    ELSE
1170       new_size = old_size * ( 1.0_wp + alloc_factor / 100.0_wp )
1171    ENDIF
1172
1173    new_size = MAX( new_size, 1, old_size + 1 )
1174
1175    IF ( old_size <= 500 )  THEN
1176
1177       tmp_particles_s(1:old_size) = grid_particles(k,j,i)%particles(1:old_size)
1178
1179       DEALLOCATE(grid_particles(k,j,i)%particles)
1180       ALLOCATE(grid_particles(k,j,i)%particles(new_size))
1181
1182       grid_particles(k,j,i)%particles(1:old_size)          = tmp_particles_s(1:old_size)
1183       grid_particles(k,j,i)%particles(old_size+1:new_size) = zero_particle
1184
1185    ELSE
1186
1187       ALLOCATE(tmp_particles_d(new_size))
1188       tmp_particles_d(1:old_size) = grid_particles(k,j,i)%particles
1189
1190       DEALLOCATE(grid_particles(k,j,i)%particles)
1191       ALLOCATE(grid_particles(k,j,i)%particles(new_size))
1192
1193       grid_particles(k,j,i)%particles(1:old_size)          = tmp_particles_d(1:old_size)
1194       grid_particles(k,j,i)%particles(old_size+1:new_size) = zero_particle
1195
1196       DEALLOCATE(tmp_particles_d)
1197
1198    ENDIF
1199    particles => grid_particles(k,j,i)%particles(1:new_size)
1200
1201    RETURN
1202   
1203 END SUBROUTINE pmc_realloc_particles_array
1204
1205#endif
1206END MODULE pmc_particle_interface
Note: See TracBrowser for help on using the repository browser.