Home

Context Navigation

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

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |