Home

Context Navigation

source: palm/trunk/SOURCE/lpm_exchange_horiz.f90 @ 1876

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

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |