Home

Context Navigation

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

Last change on this file since 4867 was 4828, checked in by Giersch, 4 years ago
Copyright updated to year 2021, interface pmc_sort removed to accelarate the nesting code
Property svn:keywords set to `Id`
File size: 51.6 KB

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |