Home

Context Navigation

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

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |