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

Last change on this file since 2875 was 2841, checked in by knoop, 7 years ago

Bugfix: wrong placement of include 'mpif.h' corrected

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