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

Last change on this file since 3611 was 3241, checked in by raasch, 6 years ago

various changes to avoid compiler warnings (mainly removal of unused variables)

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