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

Last change on this file since 4362 was 4360, checked in by suehring, 5 years ago

Bugfix in output of time-averaged plant-canopy quanities; Output of plant-canopy data only where tall canopy is defined; land-surface model: fix wrong location strings; tests: update urban test case; all source code files: copyright update

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