Home

Context Navigation

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

Last change on this file since 4118 was 4043, checked in by schwenkel, 5 years ago
further modularization of lpm and delete min_nr_particle
Property svn:keywords set to `Id`
File size: 46.4 KB

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |