Home

Context Navigation

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

Last change on this file since 4380 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

Rev	Line
[2801]	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	!
[4360]	18	! Copyright 1997-2020 Leibniz Universitaet Hannover
[2801]	19	!------------------------------------------------------------------------------!
	20	!
	21	! Current revisions:
	22	! ------------------
	23	!
[3049]	24	!
[2801]	25	! Former revisions:
[2809]	26	! -----------------!
	27	! $Id: pmc_particle_interface.f90 4360 2020-01-07 11:25:50Z monakurppa $
[4182]	28	! Corrected "Former revisions" section
	29	!
	30	! 4043 2019-06-18 16:59:00Z schwenkel
[4043]	31	! Remove min_nr_particle
	32	!
	33	! 4017 2019-06-06 12:16:46Z schwenkel
[3948]	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
[3883]	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
[3241]	41	! unused variables removed
[4182]	42	!
	43	! Initial Version (by Klaus Ketelsen)
	44	!
[3241]	45	!
[2801]	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
[2841]	54
[2967]	55	#if defined( __parallel ) && !defined( __mpifh )
[2801]	56	USE MPI
[2841]	57	#endif
[2801]	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, &
[4043]	79	ibc_par_t, ibc_par_lr, ibc_par_ns, alloc_factor
[2801]	80
[4017]	81	! USE lpm_pack_and_sort_mod
[2801]	82
[2967]	83	#if defined( __parallel )
[2801]	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, &
[3883]	95	ONLY: cpl_id, get_number_of_children, nr_part, part_adr, nested_run, &
	96	get_childid, get_child_edges, nr_partc, part_adrc, &
[3948]	97	parent_bound, coord_x, coord_y, pg, get_child_gridspacing, &
[2801]	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
[2967]	106	#endif
[2801]	107
	108	IMPLICIT NONE
[2841]	109
[2967]	110	#if defined( __parallel ) && defined( __mpifh )
[2841]	111	INCLUDE "mpif.h"
	112	#endif
	113
[2801]	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
[2967]	190	#if defined( __parallel )
	191
[3883]	192	nr_childs = get_number_of_children()
[2801]	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
[3046]	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 )
[2801]	210	ENDIF
	211
	212	IF ( ibc_par_lr /= 3 ) THEN
	213	ibc_par_lr = 3
[3046]	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 )
[2801]	216	ENDIF
	217
	218	IF ( ibc_par_ns /= 3 ) THEN
	219	ibc_par_ns = 3
[3046]	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 )
[2801]	222	ENDIF
	223
	224	ENDIF
	225
[2967]	226	#endif
[2801]	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
[3948]	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
[2801]	244	INTEGER(iwp) :: child_id !< Id of a child model
	245	INTEGER(iwp) :: nr_childs !< Number of child models of the current model
	246
[2884]	247	INTEGER :: parsize !<
[2801]	248	TYPE(C_PTR), SAVE :: ptr !<
	249
	250	TYPE(particle_type),DIMENSION(:),POINTER :: win_buffer !<
	251
	252	INTEGER(iwp),DIMENSION(1) :: buf_shape !<
	253
[2967]	254	#if defined( __parallel )
	255	INTEGER(KIND=MPI_ADDRESS_KIND) :: parsize_mpi_address_kind !<
	256	INTEGER(KIND=MPI_ADDRESS_KIND) :: winsize !<
	257
[2801]	258	!
	259	!-- If the model has a parent model prepare the structures for transfer
	260	IF ( cpl_id > 1 ) THEN
[2809]	261
[2884]	262	parsize_mpi_address_kind = STORAGE_SIZE(zero_particle)/8
[2809]	263
[2884]	264	CALL MPI_ALLOC_MEM( parsize_mpi_address_kind , MPI_INFO_NULL, ptr, ierr )
	265	parsize = parsize_mpi_address_kind
[2801]	266	buf_shape(1) = 1
	267	CALL C_F_POINTER( ptr, win_buffer, buf_shape )
[2884]	268	CALL MPI_WIN_CREATE( win_buffer, parsize_mpi_address_kind, parsize, &
[2801]	269	MPI_INFO_NULL, me%intra_comm, particle_win_child, &
	270	ierr )
	271
	272	!
	273	!-- Child domain boundaries in the parent index space
[3948]	274	ipl = parent_bound(1)
	275	ipr = parent_bound(2)
	276	jps = parent_bound(3)
	277	jpn = parent_bound(4)
[2801]	278
[3948]	279	ALLOCATE( coarse_particles(jps:jpn,ipl:ipr) )
[2801]	280
	281	coarse_particles(:,:)%nr_particle = 0
	282	ENDIF
	283
	284	!
	285	!-- If the model has child models prepare the structures for transfer
[3883]	286	nr_childs = get_number_of_children()
[2801]	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)
[2884]	292	parsize_mpi_address_kind = STORAGE_SIZE(zero_particle)/8
	293	parsize = parsize_mpi_address_kind
[2809]	294
[2884]	295	winsize = max_nr_particle_in_rma_win * parsize_mpi_address_kind
[2801]	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 )
[2884]	299	CALL MPI_WIN_CREATE( win_buffer, winsize, parsize, MPI_INFO_NULL, &
	300	children(child_id)%intra_comm, &
[2801]	301	particle_win_parent(m), ierr )
	302	ENDDO
	303	ENDIF
	304
[2967]	305	#endif
[2801]	306	END SUBROUTINE pmcp_g_alloc_win
[2967]	307
	308
[2801]	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
[3948]	320	INTEGER(iwp) :: ipl !< left boundary in coarse(parent) index space
[2801]	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
[3948]	325	INTEGER(iwp) :: jps !< south boundary in coarse(parent) index space
[2801]	326	INTEGER(iwp) :: nr !< number of particles to receive from a parent box
	327
[2884]	328	INTEGER :: parsize !<
[2967]	329
	330	#if defined( __parallel )
	331	TYPE(pedef), POINTER :: ape !< TO_DO Klaus: give a description and better name of the variable
	332
[2884]	333	INTEGER(KIND=MPI_ADDRESS_KIND) :: parsize_mpi_address_kind !<
[2801]	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
[3948]	348	ipl = parent_bound(1)
	349	jps = parent_bound(3)
[2801]	350
	351	DO ip = 1, me%inter_npes
	352
	353	ape => me%pes(ip)
	354
	355	DO ij = 1, ape%nrele
[3948]	356	j = ape%locind(ij)%j + jps - 1
	357	i = ape%locind(ij)%i + ipl - 1
[2801]	358	nr = nr_partc(j,i)
	359	IF ( nr > 0 ) THEN
	360
	361	CALL check_and_alloc_coarse_particle (i, j, nr)
[2884]	362	parsize_mpi_address_kind = STORAGE_SIZE(zero_particle)/8
	363	parsize = parsize_mpi_address_kind
[2801]	364	target_disp = part_adrc(j,i) - 1
[2884]	365	CALL MPI_WIN_LOCK( MPI_LOCK_SHARED , ip - 1, 0, &
	366	particle_win_child, ierr )
[2801]	367	CALL MPI_GET( coarse_particles(j,i)%parent_particles, &
[2884]	368	nr * parsize, MPI_BYTE, ip - 1, target_disp, &
	369	nr * parsize, MPI_BYTE, particle_win_child, ierr )
[2801]	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
[2967]	379	#endif
[2801]	380	END SUBROUTINE pmcp_c_get_particle_from_parent
[2967]	381
	382
[2801]	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
[3948]	395	INTEGER(iwp) :: ipl !< left boundary in coarse(parent) index space
	396	INTEGER(iwp) :: ipr !< right boundary in coarse(parent) index space
[2801]	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
[3948]	401	INTEGER(iwp) :: jps !< south boundary in coarse(parent) index space
	402	INTEGER(iwp) :: jpn !< north boundary in coarse(parent) index space
[2801]	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
[2884]	408	INTEGER :: parsize !<
[2801]	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
[2967]	414	! TYPE(particle_type) :: dummy_part !< dummy particle (needed for size calculations)
	415
	416	#if defined( __parallel )
[2801]	417	TYPE(pedef), POINTER :: ape !< TO_DO Klaus: give a description and better name of the variable
[2967]	418
	419	INTEGER(KIND=MPI_ADDRESS_KIND) :: parsize_mpi_address_kind !<
	420	INTEGER(KIND=MPI_ADDRESS_KIND) :: target_disp !<
[2801]	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
[3948]	429	ipl = parent_bound(1)
	430	ipr = parent_bound(2)
	431	jps = parent_bound(3)
	432	jpn = parent_bound(4)
[2801]	433
	434	nr_partc = 0
	435
[3948]	436	DO i = ipl, ipr
	437	DO j = jps, jpn
[2801]	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)
[3883]	445	xx = ( pg%dx + eps ) / dx ! +eps to avoid rounding error
	446	yy = ( pg%dy + eps ) / dy
[2801]	447	nr_fine_in_coarse = MAX( INT(xx), INT(yy) )
	448
[3883]	449	IF ( MOD( coord_x(0), pg%dx ) /= 0.0 .OR. MOD( coord_y(0), pg%dy ) /= 0.0 ) THEN
[2801]	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
[2884]	461	parsize_mpi_address_kind = STORAGE_SIZE(zero_particle)/8
	462	parsize = parsize_mpi_address_kind
[2801]	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
[3948]	469	j = ape%locind(ij)%j + jps - 1
	470	i = ape%locind(ij)%i + ipl - 1
[2801]	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'
[3046]	478	CALL message( 'pmci_create_child_arrays', 'PA0480', 3, 2, 0, 6, 0 )
[2801]	479	ENDIF
[2884]	480	CALL MPI_WIN_LOCK( MPI_LOCK_SHARED , ip - 1, 0, &
	481	particle_win_child, ierr )
[2801]	482	CALL MPI_PUT( coarse_particles(j,i)%parent_particles, &
[2884]	483	nr * parsize, MPI_BYTE, ip - 1, target_disp, &
	484	nr * parsize, MPI_BYTE, particle_win_child, ierr )
[2801]	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
[2967]	496	#endif
[2801]	497	END SUBROUTINE pmcp_c_send_particle_to_parent
[2967]	498
	499
[2801]	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
[2967]	545	#if defined( __parallel )
[2801]	546	TYPE(pedef), POINTER :: ape !< TO_DO Klaus: give a description and better name of the variable
	547
[3883]	548	DO m = 1, get_number_of_children()
[2801]	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
[3241]	585	nr_part_col = 0 ! Number of particles to transfer per column
[2801]	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
[2967]	636	#endif
[2801]	637	END SUBROUTINE pmcp_p_fill_particle_win
[2967]	638
[2801]	639
	640	!------------------------------------------------------------------------------!
	641	! Description:
	642	! ------------
	643	!> parent routine:
	644	!> delete particles from the MPI window
	645	!------------------------------------------------------------------------------!
	646	SUBROUTINE pmcp_p_empty_particle_win
[2967]	647
[2801]	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
[2967]	656	#if defined( __parallel )
[3883]	657	DO m = 1, get_number_of_children()
[2801]	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	!
[3241]	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 )
[2801]	669
	670	nr_part = 0
	671	part_adr = 0
	672
[3241]	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 )
[2801]	676	ENDDO
	677
	678	ENDDO
	679
[2967]	680	#endif
[2801]	681	END SUBROUTINE pmcp_p_empty_particle_win
[2967]	682
	683
[2801]	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
[2967]	720	#if defined( __parallel )
[3883]	721	DO m = 1, get_number_of_children()
[2801]	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
[2967]	757	#endif
[2801]	758	END SUBROUTINE pmcp_p_delete_particles_in_fine_grid_area
[2967]	759
	760
[2801]	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
[2967]	790	#if defined( __parallel )
[2801]	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
[2967]	814	#endif
[2801]	815	END SUBROUTINE pmcp_g_print_number_of_particles
	816
[2967]	817
[2801]	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
[2967]	847	#if defined( __parallel )
[2801]	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
[2967]	881	#endif
[2801]	882	END SUBROUTINE check_and_alloc_coarse_particle
	883
[2967]	884
[2801]	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
[3948]	896	INTEGER(iwp) :: ipl !< left boundary in coarse(parent) index space
	897	INTEGER(iwp) :: ipr !< right boundary in coarse(parent) index space
[2801]	898	INTEGER(iwp) :: ip !< x grid index
	899	INTEGER(iwp) :: jc !< coarse y grid index
[3948]	900	INTEGER(iwp) :: jpn !< north boundary in coarse(parent) index space
	901	INTEGER(iwp) :: jps !< south boundary in coarse(parent) index space
[2801]	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
[2967]	913	#if defined( __parallel )
[2801]	914	!
	915	!-- Child domain boundaries in the parent index space
[3948]	916	ipl = parent_bound(1)
	917	ipr = parent_bound(2)
	918	jps = parent_bound(3)
	919	jpn = parent_bound(4)
[2801]	920
[3948]	921	DO ic = ipl, ipr
	922	DO jc = jps, jpn
[2801]	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
[4017]	942	CALL pmc_realloc_particles_array( ip, jp, kp )
[2801]	943	ENDIF
	944	coarse_particles(jc,ic)%parent_particles(n)%x = xc ! Adjust coordinates to child grid
[3241]	945	coarse_particles(jc,ic)%parent_particles(n)%y = yc
[2801]	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
[2967]	955	#endif
[2801]	956	END SUBROUTINE c_copy_particle_to_child_grid
[2967]	957
	958
[2801]	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)
[3948]	973	INTEGER(iwp) :: ipl !< left boundary in coarse(parent) index space
	974	INTEGER(iwp) :: ipr !< left boundary in coarse(parent) index space
[2801]	975	INTEGER(iwp) :: ierr !< error code
	976	INTEGER(iwp) :: j !< loop index (y grid)
	977	INTEGER(iwp) :: jc !< loop index (coarse y grid)
[3948]	978	INTEGER(iwp) :: jps !< south boundary in coarse(parent) index space
	979	INTEGER(iwp) :: jpn !< north boundary in coarse(parent) index space
[2801]	980	INTEGER(iwp) :: k !< loop index (z grid)
	981	INTEGER(iwp) :: n !< loop index (number of particles)
	982
[3123]	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
[2801]	992
[2967]	993	#if defined( __parallel )
[2801]	994	!
	995	!-- Child domain boundaries in the parent index space
	996
[3948]	997	ipl = parent_bound(1)
	998	ipr = parent_bound(2)
	999	jps = parent_bound(3)
	1000	jpn = parent_bound(4)
[2801]	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
[3948]	1011	DO ic = ipl, ipr
	1012	DO jc = jps, jpn
[2801]	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
[3883]	1040	ic = x / pg%dx !TODO anpassen auf Mehrfachnesting
	1041	jc = y / pg%dy
[2801]	1042
[3948]	1043	IF ( ic >= ipl .AND. ic <= ipr .AND. jc >= jps .AND. jc <= jpn ) THEN
[2801]	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
[3948]	1055	WRITE(9,'(a,10i6)') 'This should not happen ',i,j,k,ic,jc,ipl,ipr,jps,jpn
[2801]	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
[4017]	1068	! CALL lpm_sort_in_subboxes
[2801]	1069
[2967]	1070	#endif
[2801]	1071	END SUBROUTINE c_copy_particle_to_coarse_grid
[2967]	1072
	1073
[2801]	1074	!------------------------------------------------------------------------------!
	1075	! Description:
	1076	! ------------
	1077	!> parent routine:
	1078	!> copy/sort particles from the MPI window into the respective grid boxes
	1079	!------------------------------------------------------------------------------!
[3241]	1080	SUBROUTINE p_copy_particle_to_org_grid( m )
[2801]	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
[3123]	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
[2801]	1098
	1099	INTEGER(iwp),DIMENSION(1) :: buf_shape !<
	1100
[2967]	1101	#if defined( __parallel )
[2801]	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
[3948]	1117	DO WHILE ( zw(k-1) > z .AND. k > nzb + 1 ) ! kk search loop has to be optimzed !!!
[2801]	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
[4017]	1123	CALL pmc_realloc_particles_array( i, j, k )
[2801]	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
[2967]	1138
	1139	#endif
[2801]	1140	END SUBROUTINE p_copy_particle_to_org_grid
[4017]	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 )
[2801]	1150
[4017]	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 !<
[2801]	1155
[4017]	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
[4043]	1169	new_size = MAX( new_size, 1, old_size + 1 )
[4017]	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
[2801]	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 |