Home

Context Navigation

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

Last change on this file since 4371 was 4360, checked in by suehring, 5 years ago
Bugfix in output of time-averaged plant-canopy quanities; Output of plant-canopy data only where tall canopy is defined; land-surface model: fix wrong location strings; tests: update urban test case; all source code files: copyright update
Property svn:keywords set to `Id`
File size: 46.0 KB

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |