Home

Context Navigation

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

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |