Home

Context Navigation

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

Last change on this file since 3068 was 3049, checked in by Giersch, 7 years ago
Revision history corrected
Property svn:keywords set to `Id`
File size: 44.0 KB

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |