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

Last change on this file since 2946 was 2884, checked in by scharf, 7 years ago

Bugfix: corrected KIND of variable "parsize" for some MPI calls

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