Home

Context Navigation

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

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |