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

Last change on this file since 3049 was 3049, checked in by Giersch, 3 years ago

Revision history corrected

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