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

Last change on this file since 2808 was 2808, checked in by thiele, 3 years ago

Bugfixes gfortran C_SIZEOF(zero_particle)

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