Home

Context Navigation

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

Last change on this file since 3129 was 3123, checked in by suehring, 6 years ago
Correct working precision for REAL and INTEGER numbers
Property svn:keywords set to `Id`
File size: 44.1 KB

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

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |