Home

Context Navigation

lpm_exchange_horiz_mod.f90 @ 1859

Last change on this file since 1859 was 1851, checked in by maronga, 9 years ago
last commit documented
Property svn:keywords set to `Id`
File size: 39.4 KB

Rev	Line
[1850]	1	!> @file lpm_exchange_horiz_mod.f90
[1036]	2	!--------------------------------------------------------------------------------!
	3	! This file is part of PALM.
	4	!
	5	! PALM is free software: you can redistribute it and/or modify it under the terms
	6	! of the GNU General Public License as published by the Free Software Foundation,
	7	! either version 3 of the License, or (at your option) any later version.
	8	!
	9	! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
	10	! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
	11	! A PARTICULAR PURPOSE. See the GNU General Public License for more details.
	12	!
	13	! You should have received a copy of the GNU General Public License along with
	14	! PALM. If not, see <http://www.gnu.org/licenses/>.
	15	!
[1818]	16	! Copyright 1997-2016 Leibniz Universitaet Hannover
[1036]	17	!--------------------------------------------------------------------------------!
	18	!
[849]	19	! Current revisions:
	20	! ------------------
[1851]	21	!
	22	!
[1321]	23	! Former revisions:
	24	! -----------------
	25	! $Id: lpm_exchange_horiz_mod.f90 1851 2016-04-08 13:32:50Z hoffmann $
	26	!
[1851]	27	! 1850 2016-04-08 13:29:27Z maronga
	28	! Module renamed
	29	!
	30	!
[1823]	31	! 1822 2016-04-07 07:49:42Z hoffmann
	32	! Tails removed. Unused variables removed.
	33	!
[1784]	34	! 1783 2016-03-06 18:36:17Z raasch
	35	! new netcdf-module included
	36	!
[1692]	37	! 1691 2015-10-26 16:17:44Z maronga
	38	! Formatting corrections.
	39	!
[1686]	40	! 1685 2015-10-08 07:32:13Z raasch
	41	! bugfix concerning vertical index offset in case of ocean
	42	!
[1683]	43	! 1682 2015-10-07 23:56:08Z knoop
	44	! Code annotations made doxygen readable
	45	!
[1360]	46	! 1359 2014-04-11 17:15:14Z hoffmann
	47	! New particle structure integrated.
	48	! Kind definition added to all floating point numbers.
	49	!
[1329]	50	! 1327 2014-03-21 11:00:16Z raasch
	51	! -netcdf output queries
	52	!
[1321]	53	! 1320 2014-03-20 08:40:49Z raasch
[1320]	54	! ONLY-attribute added to USE-statements,
	55	! kind-parameters added to all INTEGER and REAL declaration statements,
	56	! kinds are defined in new module kinds,
	57	! comment fields (!:) to be used for variable explanations added to
	58	! all variable declaration statements
[849]	59	!
[1319]	60	! 1318 2014-03-17 13:35:16Z raasch
	61	! module interfaces removed
	62	!
[1037]	63	! 1036 2012-10-22 13:43:42Z raasch
	64	! code put under GPL (PALM 3.9)
	65	!
[852]	66	! 851 2012-03-15 14:32:58Z raasch
	67	! Bugfix: resetting of particle_mask and tail mask moved from end of this
	68	! routine to lpm
	69	!
[850]	70	! 849 2012-03-15 10:35:09Z raasch
	71	! initial revision (former part of advec_particles)
[849]	72	!
[850]	73	!
[849]	74	! Description:
	75	! ------------
[1822]	76	! Exchange of particles between the subdomains.
[849]	77	!------------------------------------------------------------------------------!
[1682]	78	MODULE lpm_exchange_horiz_mod
	79
[849]	80
[1320]	81	USE control_parameters, &
[1783]	82	ONLY: dz, message_string, simulated_time
[1320]	83
	84	USE cpulog, &
	85	ONLY: cpu_log, log_point_s
	86
	87	USE grid_variables, &
	88	ONLY: ddx, ddy, dx, dy
	89
	90	USE indices, &
[1359]	91	ONLY: nx, nxl, nxr, ny, nyn, nys, nzb, nzt
[1320]	92
	93	USE kinds
	94
[1359]	95	USE lpm_pack_arrays_mod, &
	96	ONLY: lpm_pack_arrays
	97
[1783]	98	USE netcdf_interface, &
	99	ONLY: netcdf_data_format
	100
[1320]	101	USE particle_attributes, &
[1822]	102	ONLY: alloc_factor, deleted_particles, grid_particles, &
	103	ibc_par_lr, ibc_par_ns, min_nr_particle, &
	104	mpi_particle_type, number_of_particles, &
	105	offset_ocean_nzt, offset_ocean_nzt_m1, particles, &
	106	particle_type, prt_count, trlp_count_sum, &
[1359]	107	trlp_count_recv_sum, trnp_count_sum, trnp_count_recv_sum, &
	108	trrp_count_sum, trrp_count_recv_sum, trsp_count_sum, &
[1822]	109	trsp_count_recv_sum, zero_particle
[1320]	110
[849]	111	USE pegrid
	112
	113	IMPLICIT NONE
	114
[1682]	115	INTEGER(iwp), PARAMETER :: NR_2_direction_move = 10000 !<
	116	INTEGER(iwp) :: nr_move_north !<
	117	INTEGER(iwp) :: nr_move_south !<
[1359]	118
	119	TYPE(particle_type), DIMENSION(NR_2_direction_move) :: move_also_north
	120	TYPE(particle_type), DIMENSION(NR_2_direction_move) :: move_also_south
	121
	122	SAVE
	123
	124	PRIVATE
	125	PUBLIC lpm_exchange_horiz, lpm_move_particle, realloc_particles_array
	126
	127	INTERFACE lpm_exchange_horiz
	128	MODULE PROCEDURE lpm_exchange_horiz
	129	END INTERFACE lpm_exchange_horiz
	130
	131	INTERFACE lpm_move_particle
	132	MODULE PROCEDURE lpm_move_particle
	133	END INTERFACE lpm_move_particle
	134
	135	INTERFACE realloc_particles_array
	136	MODULE PROCEDURE realloc_particles_array
	137	END INTERFACE realloc_particles_array
	138
	139	CONTAINS
	140
[1682]	141	!------------------------------------------------------------------------------!
	142	! Description:
	143	! ------------
	144	!> Exchange between subdomains.
	145	!> As soon as one particle has moved beyond the boundary of the domain, it
	146	!> is included in the relevant transfer arrays and marked for subsequent
	147	!> deletion on this PE.
	148	!> First sweep for crossings in x direction. Find out first the number of
	149	!> particles to be transferred and allocate temporary arrays needed to store
	150	!> them.
	151	!> For a one-dimensional decomposition along y, no transfer is necessary,
	152	!> because the particle remains on the PE, but the particle coordinate has to
	153	!> be adjusted.
	154	!------------------------------------------------------------------------------!
[1359]	155	SUBROUTINE lpm_exchange_horiz
	156
	157	IMPLICIT NONE
	158
[1682]	159	INTEGER(iwp) :: i !<
	160	INTEGER(iwp) :: ip !<
	161	INTEGER(iwp) :: j !<
	162	INTEGER(iwp) :: jp !<
	163	INTEGER(iwp) :: kp !<
	164	INTEGER(iwp) :: n !<
	165	INTEGER(iwp) :: trlp_count !<
	166	INTEGER(iwp) :: trlp_count_recv !<
	167	INTEGER(iwp) :: trlpt_count !<
	168	INTEGER(iwp) :: trlpt_count_recv !<
	169	INTEGER(iwp) :: trnp_count !<
	170	INTEGER(iwp) :: trnp_count_recv !<
	171	INTEGER(iwp) :: trnpt_count !<
	172	INTEGER(iwp) :: trnpt_count_recv !<
	173	INTEGER(iwp) :: trrp_count !<
	174	INTEGER(iwp) :: trrp_count_recv !<
	175	INTEGER(iwp) :: trrpt_count !<
	176	INTEGER(iwp) :: trrpt_count_recv !<
	177	INTEGER(iwp) :: trsp_count !<
	178	INTEGER(iwp) :: trsp_count_recv !<
	179	INTEGER(iwp) :: trspt_count !<
	180	INTEGER(iwp) :: trspt_count_recv !<
[849]	181
[1682]	182	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: rvlp !<
	183	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: rvnp !<
	184	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: rvrp !<
	185	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: rvsp !<
	186	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: trlp !<
	187	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: trnp !<
	188	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: trrp !<
	189	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: trsp !<
[849]	190
[1359]	191	CALL cpu_log( log_point_s(23), 'lpm_exchange_horiz', 'start' )
	192
[849]	193	#if defined( __parallel )
	194
[1822]	195	!
	196	!-- Exchange between subdomains.
	197	!-- As soon as one particle has moved beyond the boundary of the domain, it
	198	!-- is included in the relevant transfer arrays and marked for subsequent
	199	!-- deletion on this PE.
	200	!-- First sweep for crossings in x direction. Find out first the number of
	201	!-- particles to be transferred and allocate temporary arrays needed to store
	202	!-- them.
	203	!-- For a one-dimensional decomposition along y, no transfer is necessary,
	204	!-- because the particle remains on the PE, but the particle coordinate has to
	205	!-- be adjusted.
[849]	206	trlp_count = 0
	207	trlpt_count = 0
	208	trrp_count = 0
	209	trrpt_count = 0
	210
	211	trlp_count_recv = 0
	212	trlpt_count_recv = 0
	213	trrp_count_recv = 0
	214	trrpt_count_recv = 0
	215
	216	IF ( pdims(1) /= 1 ) THEN
	217	!
[1359]	218	!-- First calculate the storage necessary for sending and receiving the data.
	219	!-- Compute only first (nxl) and last (nxr) loop iterration.
	220	DO ip = nxl, nxr, nxr - nxl
	221	DO jp = nys, nyn
	222	DO kp = nzb+1, nzt
[849]	223
[1359]	224	number_of_particles = prt_count(kp,jp,ip)
	225	IF ( number_of_particles <= 0 ) CYCLE
	226	particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
	227	DO n = 1, number_of_particles
	228	IF ( particles(n)%particle_mask ) THEN
	229	i = ( particles(n)%x + 0.5_wp * dx ) * ddx
	230	!
	231	!-- Above calculation does not work for indices less than zero
	232	IF ( particles(n)%x < -0.5_wp * dx ) i = -1
	233
	234	IF ( i < nxl ) THEN
	235	trlp_count = trlp_count + 1
	236	ELSEIF ( i > nxr ) THEN
	237	trrp_count = trrp_count + 1
	238	ENDIF
	239	ENDIF
	240	ENDDO
	241
	242	ENDDO
	243	ENDDO
[849]	244	ENDDO
	245
	246	IF ( trlp_count == 0 ) trlp_count = 1
	247	IF ( trlpt_count == 0 ) trlpt_count = 1
	248	IF ( trrp_count == 0 ) trrp_count = 1
	249	IF ( trrpt_count == 0 ) trrpt_count = 1
	250
	251	ALLOCATE( trlp(trlp_count), trrp(trrp_count) )
	252
[1359]	253	trlp = zero_particle
	254	trrp = zero_particle
[849]	255
	256	trlp_count = 0
	257	trlpt_count = 0
	258	trrp_count = 0
	259	trrpt_count = 0
	260
	261	ENDIF
[1359]	262	!
	263	!-- Compute only first (nxl) and last (nxr) loop iterration
	264	DO ip = nxl, nxr,nxr-nxl
	265	DO jp = nys, nyn
	266	DO kp = nzb+1, nzt
	267	number_of_particles = prt_count(kp,jp,ip)
	268	IF ( number_of_particles <= 0 ) CYCLE
	269	particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
	270	DO n = 1, number_of_particles
	271	!
	272	!-- Only those particles that have not been marked as 'deleted' may
	273	!-- be moved.
	274	IF ( particles(n)%particle_mask ) THEN
[849]	275
[1359]	276	i = ( particles(n)%x + 0.5_wp * dx ) * ddx
	277	!
	278	!-- Above calculation does not work for indices less than zero
	279	IF ( particles(n)%x < - 0.5_wp * dx ) i = -1
[849]	280
[1359]	281	IF ( i < nxl ) THEN
	282	IF ( i < 0 ) THEN
	283	!
	284	!-- Apply boundary condition along x
	285	IF ( ibc_par_lr == 0 ) THEN
	286	!
	287	!-- Cyclic condition
	288	IF ( pdims(1) == 1 ) THEN
	289	particles(n)%x = ( nx + 1 ) * dx + particles(n)%x
	290	particles(n)%origin_x = ( nx + 1 ) * dx + &
	291	particles(n)%origin_x
	292	ELSE
	293	trlp_count = trlp_count + 1
	294	trlp(trlp_count) = particles(n)
	295	trlp(trlp_count)%x = ( nx + 1 ) * dx + trlp(trlp_count)%x
	296	trlp(trlp_count)%origin_x = trlp(trlp_count)%origin_x + &
	297	( nx + 1 ) * dx
	298	particles(n)%particle_mask = .FALSE.
	299	deleted_particles = deleted_particles + 1
[849]	300
[1359]	301	IF ( trlp(trlp_count)%x >= (nx + 0.5_wp)* dx - 1.0E-12_wp ) THEN
	302	trlp(trlp_count)%x = trlp(trlp_count)%x - 1.0E-10_wp
	303	!++ why is 1 subtracted in next statement???
	304	trlp(trlp_count)%origin_x = trlp(trlp_count)%origin_x - 1
	305	ENDIF
[849]	306
[1359]	307	ENDIF
[849]	308
[1359]	309	ELSEIF ( ibc_par_lr == 1 ) THEN
	310	!
	311	!-- Particle absorption
	312	particles(n)%particle_mask = .FALSE.
	313	deleted_particles = deleted_particles + 1
[849]	314
[1359]	315	ELSEIF ( ibc_par_lr == 2 ) THEN
	316	!
	317	!-- Particle reflection
	318	particles(n)%x = -particles(n)%x
	319	particles(n)%speed_x = -particles(n)%speed_x
[849]	320
[1359]	321	ENDIF
	322	ELSE
	323	!
	324	!-- Store particle data in the transfer array, which will be
	325	!-- send to the neighbouring PE
	326	trlp_count = trlp_count + 1
	327	trlp(trlp_count) = particles(n)
	328	particles(n)%particle_mask = .FALSE.
	329	deleted_particles = deleted_particles + 1
[849]	330
[1359]	331	ENDIF
[849]	332
[1359]	333	ELSEIF ( i > nxr ) THEN
	334	IF ( i > nx ) THEN
	335	!
	336	!-- Apply boundary condition along x
	337	IF ( ibc_par_lr == 0 ) THEN
	338	!
	339	!-- Cyclic condition
	340	IF ( pdims(1) == 1 ) THEN
	341	particles(n)%x = particles(n)%x - ( nx + 1 ) * dx
	342	particles(n)%origin_x = particles(n)%origin_x - &
	343	( nx + 1 ) * dx
	344	ELSE
	345	trrp_count = trrp_count + 1
	346	trrp(trrp_count) = particles(n)
	347	trrp(trrp_count)%x = trrp(trrp_count)%x - ( nx + 1 ) * dx
	348	trrp(trrp_count)%origin_x = trrp(trrp_count)%origin_x - &
	349	( nx + 1 ) * dx
	350	particles(n)%particle_mask = .FALSE.
	351	deleted_particles = deleted_particles + 1
[849]	352
[1359]	353	ENDIF
[849]	354
[1359]	355	ELSEIF ( ibc_par_lr == 1 ) THEN
	356	!
	357	!-- Particle absorption
	358	particles(n)%particle_mask = .FALSE.
	359	deleted_particles = deleted_particles + 1
[849]	360
[1359]	361	ELSEIF ( ibc_par_lr == 2 ) THEN
	362	!
	363	!-- Particle reflection
	364	particles(n)%x = 2 * ( nx * dx ) - particles(n)%x
	365	particles(n)%speed_x = -particles(n)%speed_x
[849]	366
[1359]	367	ENDIF
	368	ELSE
	369	!
	370	!-- Store particle data in the transfer array, which will be send
	371	!-- to the neighbouring PE
	372	trrp_count = trrp_count + 1
	373	trrp(trrp_count) = particles(n)
	374	particles(n)%particle_mask = .FALSE.
	375	deleted_particles = deleted_particles + 1
[849]	376
[1359]	377	ENDIF
[849]	378
[1359]	379	ENDIF
	380	ENDIF
	381	ENDDO
	382	ENDDO
	383	ENDDO
[849]	384	ENDDO
	385
	386	!
	387	!-- Send left boundary, receive right boundary (but first exchange how many
	388	!-- and check, if particle storage must be extended)
	389	IF ( pdims(1) /= 1 ) THEN
	390
	391	CALL MPI_SENDRECV( trlp_count, 1, MPI_INTEGER, pleft, 0, &
	392	trrp_count_recv, 1, MPI_INTEGER, pright, 0, &
	393	comm2d, status, ierr )
	394
[1359]	395	ALLOCATE(rvrp(MAX(1,trrp_count_recv)))
[849]	396
[1359]	397	CALL MPI_SENDRECV( trlp(1)%radius, max(1,trlp_count), mpi_particle_type,&
	398	pleft, 1, rvrp(1)%radius, &
	399	max(1,trrp_count_recv), mpi_particle_type, pright, 1,&
[849]	400	comm2d, status, ierr )
	401
[1359]	402	IF ( trrp_count_recv > 0 ) CALL Add_particles_to_gridcell(rvrp(1:trrp_count_recv))
	403
	404	DEALLOCATE(rvrp)
	405
[849]	406	!
	407	!-- Send right boundary, receive left boundary
	408	CALL MPI_SENDRECV( trrp_count, 1, MPI_INTEGER, pright, 0, &
	409	trlp_count_recv, 1, MPI_INTEGER, pleft, 0, &
	410	comm2d, status, ierr )
	411
[1359]	412	ALLOCATE(rvlp(MAX(1,trlp_count_recv)))
[849]	413
[1359]	414	CALL MPI_SENDRECV( trrp(1)%radius, max(1,trrp_count), mpi_particle_type,&
	415	pright, 1, rvlp(1)%radius, &
	416	max(1,trlp_count_recv), mpi_particle_type, pleft, 1, &
[849]	417	comm2d, status, ierr )
	418
[1359]	419	IF ( trlp_count_recv > 0 ) CALL Add_particles_to_gridcell(rvlp(1:trlp_count_recv))
	420
[1822]	421	DEALLOCATE( rvlp )
[1359]	422	DEALLOCATE( trlp, trrp )
[849]	423
	424	ENDIF
	425
	426
	427	!
	428	!-- Check whether particles have crossed the boundaries in y direction. Note
	429	!-- that this case can also apply to particles that have just been received
	430	!-- from the adjacent right or left PE.
	431	!-- Find out first the number of particles to be transferred and allocate
	432	!-- temporary arrays needed to store them.
	433	!-- For a one-dimensional decomposition along x, no transfer is necessary,
	434	!-- because the particle remains on the PE.
[1359]	435	trsp_count = nr_move_south
[849]	436	trspt_count = 0
[1359]	437	trnp_count = nr_move_north
[849]	438	trnpt_count = 0
	439
	440	trsp_count_recv = 0
	441	trspt_count_recv = 0
	442	trnp_count_recv = 0
	443	trnpt_count_recv = 0
	444
	445	IF ( pdims(2) /= 1 ) THEN
	446	!
	447	!-- First calculate the storage necessary for sending and receiving the
	448	!-- data
[1359]	449	DO ip = nxl, nxr
	450	DO jp = nys, nyn, nyn-nys !compute only first (nys) and last (nyn) loop iterration
	451	DO kp = nzb+1, nzt
	452	number_of_particles = prt_count(kp,jp,ip)
	453	IF ( number_of_particles <= 0 ) CYCLE
	454	particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
	455	DO n = 1, number_of_particles
	456	IF ( particles(n)%particle_mask ) THEN
	457	j = ( particles(n)%y + 0.5_wp * dy ) * ddy
[849]	458	!
[1359]	459	!-- Above calculation does not work for indices less than zero
	460	IF ( particles(n)%y < -0.5_wp * dy ) j = -1
[849]	461
[1359]	462	IF ( j < nys ) THEN
	463	trsp_count = trsp_count + 1
	464	ELSEIF ( j > nyn ) THEN
	465	trnp_count = trnp_count + 1
	466	ENDIF
	467	ENDIF
	468	ENDDO
	469	ENDDO
	470	ENDDO
[849]	471	ENDDO
	472
	473	IF ( trsp_count == 0 ) trsp_count = 1
	474	IF ( trspt_count == 0 ) trspt_count = 1
	475	IF ( trnp_count == 0 ) trnp_count = 1
	476	IF ( trnpt_count == 0 ) trnpt_count = 1
	477
	478	ALLOCATE( trsp(trsp_count), trnp(trnp_count) )
	479
[1359]	480	trsp = zero_particle
	481	trnp = zero_particle
[849]	482
[1359]	483	trsp_count = nr_move_south
[849]	484	trspt_count = 0
[1359]	485	trnp_count = nr_move_north
[849]	486	trnpt_count = 0
	487
[1359]	488	trsp(1:nr_move_south) = move_also_south(1:nr_move_south)
	489	trnp(1:nr_move_north) = move_also_north(1:nr_move_north)
	490
[849]	491	ENDIF
	492
[1359]	493	DO ip = nxl, nxr
	494	DO jp = nys, nyn, nyn-nys ! compute only first (nys) and last (nyn) loop iterration
	495	DO kp = nzb+1, nzt
	496	number_of_particles = prt_count(kp,jp,ip)
	497	IF ( number_of_particles <= 0 ) CYCLE
	498	particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
	499	DO n = 1, number_of_particles
[849]	500	!
[1359]	501	!-- Only those particles that have not been marked as 'deleted' may
	502	!-- be moved.
	503	IF ( particles(n)%particle_mask ) THEN
	504	j = ( particles(n)%y + 0.5_wp * dy ) * ddy
[849]	505	!
[1359]	506	!-- Above calculation does not work for indices less than zero
	507	IF ( particles(n)%y < -0.5_wp * dy ) j = -1
[849]	508
[1359]	509	IF ( j < nys ) THEN
	510	IF ( j < 0 ) THEN
[849]	511	!
[1359]	512	!-- Apply boundary condition along y
	513	IF ( ibc_par_ns == 0 ) THEN
[849]	514	!
[1359]	515	!-- Cyclic condition
	516	IF ( pdims(2) == 1 ) THEN
	517	particles(n)%y = ( ny + 1 ) * dy + particles(n)%y
	518	particles(n)%origin_y = ( ny + 1 ) * dy + &
	519	particles(n)%origin_y
	520	ELSE
	521	trsp_count = trsp_count + 1
	522	trsp(trsp_count) = particles(n)
	523	trsp(trsp_count)%y = ( ny + 1 ) * dy + &
	524	trsp(trsp_count)%y
	525	trsp(trsp_count)%origin_y = trsp(trsp_count)%origin_y &
	526	+ ( ny + 1 ) * dy
	527	particles(n)%particle_mask = .FALSE.
	528	deleted_particles = deleted_particles + 1
[849]	529
[1359]	530	IF ( trsp(trsp_count)%y >= (ny+0.5_wp)* dy - 1.0E-12_wp ) THEN
	531	trsp(trsp_count)%y = trsp(trsp_count)%y - 1.0E-10_wp
	532	!++ why is 1 subtracted in next statement???
	533	trsp(trsp_count)%origin_y = &
	534	trsp(trsp_count)%origin_y - 1
	535	ENDIF
[849]	536
[1359]	537	ENDIF
[849]	538
[1359]	539	ELSEIF ( ibc_par_ns == 1 ) THEN
[849]	540	!
[1359]	541	!-- Particle absorption
	542	particles(n)%particle_mask = .FALSE.
	543	deleted_particles = deleted_particles + 1
[849]	544
[1359]	545	ELSEIF ( ibc_par_ns == 2 ) THEN
[849]	546	!
[1359]	547	!-- Particle reflection
	548	particles(n)%y = -particles(n)%y
	549	particles(n)%speed_y = -particles(n)%speed_y
[849]	550
[1359]	551	ENDIF
	552	ELSE
[849]	553	!
[1359]	554	!-- Store particle data in the transfer array, which will
	555	!-- be send to the neighbouring PE
	556	trsp_count = trsp_count + 1
	557	trsp(trsp_count) = particles(n)
	558	particles(n)%particle_mask = .FALSE.
	559	deleted_particles = deleted_particles + 1
[849]	560
[1359]	561	ENDIF
[849]	562
[1359]	563	ELSEIF ( j > nyn ) THEN
	564	IF ( j > ny ) THEN
[849]	565	!
[1359]	566	!-- Apply boundary condition along x
	567	IF ( ibc_par_ns == 0 ) THEN
[849]	568	!
[1359]	569	!-- Cyclic condition
	570	IF ( pdims(2) == 1 ) THEN
	571	particles(n)%y = particles(n)%y - ( ny + 1 ) * dy
	572	particles(n)%origin_y = &
	573	particles(n)%origin_y - ( ny + 1 ) * dy
	574	ELSE
	575	trnp_count = trnp_count + 1
	576	trnp(trnp_count) = particles(n)
	577	trnp(trnp_count)%y = &
	578	trnp(trnp_count)%y - ( ny + 1 ) * dy
	579	trnp(trnp_count)%origin_y = &
	580	trnp(trnp_count)%origin_y - ( ny + 1 ) * dy
	581	particles(n)%particle_mask = .FALSE.
	582	deleted_particles = deleted_particles + 1
	583	ENDIF
[849]	584
[1359]	585	ELSEIF ( ibc_par_ns == 1 ) THEN
[849]	586	!
[1359]	587	!-- Particle absorption
	588	particles(n)%particle_mask = .FALSE.
	589	deleted_particles = deleted_particles + 1
[849]	590
[1359]	591	ELSEIF ( ibc_par_ns == 2 ) THEN
[849]	592	!
[1359]	593	!-- Particle reflection
	594	particles(n)%y = 2 * ( ny * dy ) - particles(n)%y
	595	particles(n)%speed_y = -particles(n)%speed_y
[849]	596
[1359]	597	ENDIF
	598	ELSE
[849]	599	!
[1359]	600	!-- Store particle data in the transfer array, which will
	601	!-- be send to the neighbouring PE
	602	trnp_count = trnp_count + 1
	603	trnp(trnp_count) = particles(n)
	604	particles(n)%particle_mask = .FALSE.
	605	deleted_particles = deleted_particles + 1
[849]	606
[1359]	607	ENDIF
	608
	609	ENDIF
[849]	610	ENDIF
[1359]	611	ENDDO
	612	ENDDO
	613	ENDDO
[849]	614	ENDDO
	615
	616	!
	617	!-- Send front boundary, receive back boundary (but first exchange how many
	618	!-- and check, if particle storage must be extended)
	619	IF ( pdims(2) /= 1 ) THEN
	620
	621	CALL MPI_SENDRECV( trsp_count, 1, MPI_INTEGER, psouth, 0, &
	622	trnp_count_recv, 1, MPI_INTEGER, pnorth, 0, &
	623	comm2d, status, ierr )
	624
[1359]	625	ALLOCATE(rvnp(MAX(1,trnp_count_recv)))
[849]	626
[1359]	627	CALL MPI_SENDRECV( trsp(1)%radius, trsp_count, mpi_particle_type, &
	628	psouth, 1, rvnp(1)%radius, &
[849]	629	trnp_count_recv, mpi_particle_type, pnorth, 1, &
	630	comm2d, status, ierr )
	631
[1359]	632	IF ( trnp_count_recv > 0 ) CALL Add_particles_to_gridcell(rvnp(1:trnp_count_recv))
	633
	634	DEALLOCATE(rvnp)
	635
[849]	636	!
	637	!-- Send back boundary, receive front boundary
	638	CALL MPI_SENDRECV( trnp_count, 1, MPI_INTEGER, pnorth, 0, &
	639	trsp_count_recv, 1, MPI_INTEGER, psouth, 0, &
	640	comm2d, status, ierr )
	641
[1359]	642	ALLOCATE(rvsp(MAX(1,trsp_count_recv)))
[849]	643
[1359]	644	CALL MPI_SENDRECV( trnp(1)%radius, trnp_count, mpi_particle_type, &
	645	pnorth, 1, rvsp(1)%radius, &
[849]	646	trsp_count_recv, mpi_particle_type, psouth, 1, &
	647	comm2d, status, ierr )
	648
[1359]	649	IF ( trsp_count_recv > 0 ) CALL Add_particles_to_gridcell(rvsp(1:trsp_count_recv))
	650
	651	DEALLOCATE(rvsp)
	652
[849]	653	number_of_particles = number_of_particles + trsp_count_recv
	654
	655	DEALLOCATE( trsp, trnp )
	656
	657	ENDIF
	658
	659	#else
	660
	661	!
	662	!-- Apply boundary conditions
	663	DO n = 1, number_of_particles
	664
[1359]	665	IF ( particles(n)%x < -0.5_wp * dx ) THEN
[849]	666
	667	IF ( ibc_par_lr == 0 ) THEN
	668	!
	669	!-- Cyclic boundary. Relevant coordinate has to be changed.
	670	particles(n)%x = ( nx + 1 ) * dx + particles(n)%x
[1822]	671
[849]	672	ELSEIF ( ibc_par_lr == 1 ) THEN
	673	!
	674	!-- Particle absorption
[1359]	675	particles(n)%particle_mask = .FALSE.
[849]	676	deleted_particles = deleted_particles + 1
[1822]	677
[849]	678	ELSEIF ( ibc_par_lr == 2 ) THEN
	679	!
	680	!-- Particle reflection
	681	particles(n)%x = -dx - particles(n)%x
	682	particles(n)%speed_x = -particles(n)%speed_x
	683	ENDIF
	684
[1359]	685	ELSEIF ( particles(n)%x >= ( nx + 0.5_wp ) * dx ) THEN
[849]	686
	687	IF ( ibc_par_lr == 0 ) THEN
	688	!
	689	!-- Cyclic boundary. Relevant coordinate has to be changed.
	690	particles(n)%x = particles(n)%x - ( nx + 1 ) * dx
[1822]	691
[849]	692	ELSEIF ( ibc_par_lr == 1 ) THEN
	693	!
	694	!-- Particle absorption
[1359]	695	particles(n)%particle_mask = .FALSE.
[849]	696	deleted_particles = deleted_particles + 1
[1822]	697
[849]	698	ELSEIF ( ibc_par_lr == 2 ) THEN
	699	!
	700	!-- Particle reflection
	701	particles(n)%x = ( nx + 1 ) * dx - particles(n)%x
	702	particles(n)%speed_x = -particles(n)%speed_x
	703	ENDIF
	704
	705	ENDIF
	706
[1359]	707	IF ( particles(n)%y < -0.5_wp * dy ) THEN
[849]	708
	709	IF ( ibc_par_ns == 0 ) THEN
	710	!
	711	!-- Cyclic boundary. Relevant coordinate has to be changed.
	712	particles(n)%y = ( ny + 1 ) * dy + particles(n)%y
[1822]	713
[849]	714	ELSEIF ( ibc_par_ns == 1 ) THEN
	715	!
	716	!-- Particle absorption
[1359]	717	particles(n)%particle_mask = .FALSE.
[849]	718	deleted_particles = deleted_particles + 1
[1822]	719
[849]	720	ELSEIF ( ibc_par_ns == 2 ) THEN
	721	!
	722	!-- Particle reflection
	723	particles(n)%y = -dy - particles(n)%y
	724	particles(n)%speed_y = -particles(n)%speed_y
	725	ENDIF
	726
[1359]	727	ELSEIF ( particles(n)%y >= ( ny + 0.5_wp ) * dy ) THEN
[849]	728
	729	IF ( ibc_par_ns == 0 ) THEN
	730	!
	731	!-- Cyclic boundary. Relevant coordinate has to be changed.
	732	particles(n)%y = particles(n)%y - ( ny + 1 ) * dy
[1822]	733
[849]	734	ELSEIF ( ibc_par_ns == 1 ) THEN
	735	!
	736	!-- Particle absorption
[1359]	737	particles(n)%particle_mask = .FALSE.
[849]	738	deleted_particles = deleted_particles + 1
[1822]	739
[849]	740	ELSEIF ( ibc_par_ns == 2 ) THEN
	741	!
	742	!-- Particle reflection
	743	particles(n)%y = ( ny + 1 ) * dy - particles(n)%y
	744	particles(n)%speed_y = -particles(n)%speed_y
	745	ENDIF
	746
	747	ENDIF
	748	ENDDO
	749
	750	#endif
	751
	752	!
	753	!-- Accumulate the number of particles transferred between the subdomains
	754	#if defined( __parallel )
	755	trlp_count_sum = trlp_count_sum + trlp_count
	756	trlp_count_recv_sum = trlp_count_recv_sum + trlp_count_recv
	757	trrp_count_sum = trrp_count_sum + trrp_count
	758	trrp_count_recv_sum = trrp_count_recv_sum + trrp_count_recv
	759	trsp_count_sum = trsp_count_sum + trsp_count
	760	trsp_count_recv_sum = trsp_count_recv_sum + trsp_count_recv
	761	trnp_count_sum = trnp_count_sum + trnp_count
	762	trnp_count_recv_sum = trnp_count_recv_sum + trnp_count_recv
	763	#endif
	764
[1359]	765	CALL cpu_log( log_point_s(23), 'lpm_exchange_horiz', 'stop' )
[849]	766
	767	END SUBROUTINE lpm_exchange_horiz
[1359]	768
[1682]	769	!------------------------------------------------------------------------------!
	770	! Description:
	771	! ------------
	772	!> If a particle moves from one processor to another, this subroutine moves
	773	!> the corresponding elements from the particle arrays of the old grid cells
	774	!> to the particle arrays of the new grid cells.
	775	!------------------------------------------------------------------------------!
[1359]	776	SUBROUTINE Add_particles_to_gridcell (particle_array)
	777
	778	IMPLICIT NONE
	779
[1682]	780	INTEGER(iwp) :: ip !<
	781	INTEGER(iwp) :: jp !<
	782	INTEGER(iwp) :: kp !<
	783	INTEGER(iwp) :: n !<
	784	INTEGER(iwp) :: pindex !<
[1359]	785
[1682]	786	LOGICAL :: pack_done !<
[1359]	787
	788	TYPE(particle_type), DIMENSION(:), INTENT(IN) :: particle_array
	789
	790	pack_done = .FALSE.
	791
	792	nr_move_north = 0
	793	nr_move_south = 0
	794
	795	DO n = 1, SIZE(particle_array)
	796	ip = ( particle_array(n)%x + 0.5_wp * dx ) * ddx
	797	jp = ( particle_array(n)%y + 0.5_wp * dy ) * ddy
[1685]	798	kp = particle_array(n)%z / dz + 1 + offset_ocean_nzt
[1359]	799
	800	IF ( ip >= nxl .AND. ip <= nxr .AND. jp >= nys .AND. jp <= nyn &
	801	.AND. kp >= nzb+1 .AND. kp <= nzt) THEN ! particle stays on processor
	802	number_of_particles = prt_count(kp,jp,ip)
	803	particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
	804
	805	pindex = prt_count(kp,jp,ip)+1
	806	IF( pindex > SIZE(grid_particles(kp,jp,ip)%particles) ) THEN
	807	IF ( pack_done ) THEN
	808	CALL realloc_particles_array (ip,jp,kp)
	809	ELSE
	810	CALL lpm_pack_arrays
	811	prt_count(kp,jp,ip) = number_of_particles
	812	pindex = prt_count(kp,jp,ip)+1
	813	IF ( pindex > SIZE(grid_particles(kp,jp,ip)%particles) ) THEN
	814	CALL realloc_particles_array (ip,jp,kp)
	815	ENDIF
	816	pack_done = .TRUE.
	817	ENDIF
	818	ENDIF
	819	grid_particles(kp,jp,ip)%particles(pindex) = particle_array(n)
	820	prt_count(kp,jp,ip) = pindex
	821	ELSE
	822	IF ( jp == nys - 1 ) THEN
	823	nr_move_south = nr_move_south+1
	824	move_also_south(nr_move_south) = particle_array(n)
	825	IF ( jp == -1 ) THEN
	826	move_also_south(nr_move_south)%y = &
	827	move_also_south(nr_move_south)%y + ( ny + 1 ) * dy
	828	move_also_south(nr_move_south)%origin_y = &
	829	move_also_south(nr_move_south)%origin_y + ( ny + 1 ) * dy
	830	ENDIF
	831	ELSEIF ( jp == nyn+1 ) THEN
	832	nr_move_north = nr_move_north+1
	833	move_also_north(nr_move_north) = particle_array(n)
	834	IF ( jp == ny+1 ) THEN
	835	move_also_north(nr_move_north)%y = &
	836	move_also_north(nr_move_north)%y - ( ny + 1 ) * dy
	837	move_also_north(nr_move_north)%origin_y = &
	838	move_also_north(nr_move_north)%origin_y - ( ny + 1 ) * dy
	839	ENDIF
	840	ELSE
	841	WRITE(0,'(a,8i7)') 'particle out of range ',myid,ip,jp,kp,nxl,nxr,nys,nyn
	842	ENDIF
	843	ENDIF
	844	ENDDO
	845
	846	RETURN
	847
	848	END SUBROUTINE Add_particles_to_gridcell
	849
	850
	851
	852
[1682]	853	!------------------------------------------------------------------------------!
	854	! Description:
	855	! ------------
	856	!> If a particle moves from one grid cell to another (on the current
	857	!> processor!), this subroutine moves the corresponding element from the
	858	!> particle array of the old grid cell to the particle array of the new grid
	859	!> cell.
	860	!------------------------------------------------------------------------------!
[1359]	861	SUBROUTINE lpm_move_particle
	862
	863	IMPLICIT NONE
	864
[1682]	865	INTEGER(iwp) :: i !<
	866	INTEGER(iwp) :: ip !<
	867	INTEGER(iwp) :: j !<
	868	INTEGER(iwp) :: jp !<
	869	INTEGER(iwp) :: k !<
	870	INTEGER(iwp) :: kp !<
	871	INTEGER(iwp) :: n !<
	872	INTEGER(iwp) :: np_old_cell !<
	873	INTEGER(iwp) :: n_start !<
	874	INTEGER(iwp) :: pindex !<
[1359]	875
[1682]	876	LOGICAL :: pack_done !<
[1359]	877
[1682]	878	TYPE(particle_type), DIMENSION(:), POINTER :: particles_old_cell !<
[1359]	879
	880	CALL cpu_log( log_point_s(41), 'lpm_move_particle', 'start' )
	881
	882	DO ip = nxl, nxr
	883	DO jp = nys, nyn
	884	DO kp = nzb+1, nzt
	885
	886	np_old_cell = prt_count(kp,jp,ip)
	887	IF ( np_old_cell <= 0 ) CYCLE
	888	particles_old_cell => grid_particles(kp,jp,ip)%particles(1:np_old_cell)
	889	n_start = -1
	890
	891	DO n = 1, np_old_cell
	892	i = ( particles_old_cell(n)%x + 0.5_wp * dx ) * ddx
	893	j = ( particles_old_cell(n)%y + 0.5_wp * dy ) * ddy
	894	k = particles_old_cell(n)%z / dz + 1 + offset_ocean_nzt
	895	!
	896	!-- Check, if particle has moved to another grid cell.
	897	IF ( i /= ip .OR. j /= jp .OR. k /= kp ) THEN
	898	!
	899	!-- The particle has moved to another grid cell. Now check, if
	900	!-- particle stays on the same processor.
	901	IF ( i >= nxl .AND. i <= nxr .AND. j >= nys .AND. &
	902	j <= nyn .AND. k >= nzb+1 .AND. k <= nzt) THEN
	903	!
	904	!-- If the particle stays on the same processor, the particle
	905	!-- will be added to the particle array of the new processor.
	906	number_of_particles = prt_count(k,j,i)
	907	particles => grid_particles(k,j,i)%particles(1:number_of_particles)
	908
	909	pindex = prt_count(k,j,i)+1
	910	IF ( pindex > SIZE(grid_particles(k,j,i)%particles) ) &
	911	THEN
	912	n_start = n
	913	EXIT
	914	ENDIF
	915
	916	grid_particles(k,j,i)%particles(pindex) = particles_old_cell(n)
	917	prt_count(k,j,i) = pindex
	918
	919	particles_old_cell(n)%particle_mask = .FALSE.
	920	ENDIF
	921	ENDIF
	922	ENDDO
	923
[1691]	924	IF ( n_start >= 0 ) THEN
[1359]	925	pack_done = .FALSE.
	926	DO n = n_start, np_old_cell
	927	i = ( particles_old_cell(n)%x + 0.5_wp * dx ) * ddx
	928	j = ( particles_old_cell(n)%y + 0.5_wp * dy ) * ddy
	929	k = particles_old_cell(n)%z / dz + 1 + offset_ocean_nzt
	930	IF ( i /= ip .OR. j /= jp .OR. k /= kp ) THEN
	931	!
	932	!-- Particle is in different box
	933	IF ( i >= nxl .AND. i <= nxr .AND. j >= nys .AND. &
	934	j <= nyn .AND. k >= nzb+1 .AND. k <= nzt) THEN
	935	!
	936	!-- Particle stays on processor
	937	number_of_particles = prt_count(k,j,i)
	938	particles => grid_particles(k,j,i)%particles(1:number_of_particles)
	939
	940	pindex = prt_count(k,j,i)+1
	941	IF ( pindex > SIZE(grid_particles(k,j,i)%particles) ) &
	942	THEN
	943	IF ( pack_done ) THEN
	944	CALL realloc_particles_array(i,j,k)
	945	pindex = prt_count(k,j,i)+1
	946	ELSE
	947	CALL lpm_pack_arrays
	948	prt_count(k,j,i) = number_of_particles
	949
	950	pindex = prt_count(k,j,i)+1
	951	!
	952	!-- If number of particles in the new grid box
	953	!-- exceeds its allocated memory, the particle array
	954	!-- will be reallocated
	955	IF ( pindex > SIZE(grid_particles(k,j,i)%particles) ) THEN
	956	CALL realloc_particles_array(i,j,k)
	957	pindex = prt_count(k,j,i)+1
	958	ENDIF
	959
	960	pack_done = .TRUE.
	961	ENDIF
	962	ENDIF
	963
	964	grid_particles(k,j,i)%particles(pindex) = particles_old_cell(n)
	965	prt_count(k,j,i) = pindex
	966
	967	particles_old_cell(n)%particle_mask = .FALSE.
	968	ENDIF
	969	ENDIF
	970	ENDDO
	971	ENDIF
	972	ENDDO
	973	ENDDO
	974	ENDDO
	975
	976	CALL cpu_log( log_point_s(41), 'lpm_move_particle', 'stop' )
	977
	978	RETURN
	979
	980	END SUBROUTINE lpm_move_particle
	981
[1682]	982	!------------------------------------------------------------------------------!
	983	! Description:
	984	! ------------
	985	!> @todo Missing subroutine description.
	986	!------------------------------------------------------------------------------!
[1359]	987	SUBROUTINE realloc_particles_array (i,j,k,size_in)
	988
	989	IMPLICIT NONE
	990
[1682]	991	INTEGER(iwp), INTENT(in) :: i !<
	992	INTEGER(iwp), INTENT(in) :: j !<
	993	INTEGER(iwp), INTENT(in) :: k !<
[1822]	994	INTEGER(iwp), INTENT(in), OPTIONAL :: size_in !<
[1359]	995
[1682]	996	INTEGER(iwp) :: old_size !<
	997	INTEGER(iwp) :: new_size !<
	998	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: tmp_particles_d !<
	999	TYPE(particle_type), DIMENSION(500) :: tmp_particles_s !<
[1359]	1000
	1001
	1002	old_size = SIZE(grid_particles(k,j,i)%particles)
	1003
	1004	IF ( PRESENT(size_in) ) THEN
	1005	new_size = size_in
	1006	ELSE
[1822]	1007	new_size = old_size * ( 1.0_wp + alloc_factor / 100.0_wp )
[1359]	1008	ENDIF
	1009
	1010	new_size = MAX( new_size, min_nr_particle )
	1011
	1012	IF ( old_size <= 500 ) THEN
	1013
	1014	tmp_particles_s(1:old_size) = grid_particles(k,j,i)%particles(1:old_size)
	1015
	1016	DEALLOCATE(grid_particles(k,j,i)%particles)
	1017	ALLOCATE(grid_particles(k,j,i)%particles(new_size))
	1018
	1019	grid_particles(k,j,i)%particles(1:old_size) = tmp_particles_s(1:old_size)
	1020	grid_particles(k,j,i)%particles(old_size+1:new_size) = zero_particle
	1021
	1022	ELSE
	1023
	1024	ALLOCATE(tmp_particles_d(new_size))
	1025	tmp_particles_d(1:old_size) = grid_particles(k,j,i)%particles
	1026
	1027	DEALLOCATE(grid_particles(k,j,i)%particles)
	1028	ALLOCATE(grid_particles(k,j,i)%particles(new_size))
	1029
	1030	grid_particles(k,j,i)%particles(1:old_size) = tmp_particles_d(1:old_size)
	1031	grid_particles(k,j,i)%particles(old_size+1:new_size) = zero_particle
	1032
	1033	DEALLOCATE(tmp_particles_d)
	1034
	1035	ENDIF
	1036	particles => grid_particles(k,j,i)%particles(1:number_of_particles)
	1037
	1038	RETURN
	1039	END SUBROUTINE realloc_particles_array
	1040
	1041	END MODULE lpm_exchange_horiz_mod

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

Context Navigation

source: palm/trunk/SOURCE/lpm_exchange_horiz_mod.f90 @ 1859

Download in other formats: