Home

Context Navigation

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

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |