Home

Context Navigation

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

Last change on this file since 2675 was 2632, checked in by schwenkel, 7 years ago
bugfix in write statement
Property svn:keywords set to `Id`
File size: 50.5 KB

Rev	Line
[1873]	1	!> @file lpm_exchange_horiz.f90
[2000]	2	!------------------------------------------------------------------------------!
[1036]	3	! This file is part of PALM.
	4	!
[2000]	5	! PALM is free software: you can redistribute it and/or modify it under the
	6	! terms of the GNU General Public License as published by the Free Software
	7	! Foundation, either version 3 of the License, or (at your option) any later
	8	! version.
[1036]	9	!
	10	! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
	11	! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
	12	! A PARTICULAR PURPOSE. See the GNU General Public License for more details.
	13	!
	14	! You should have received a copy of the GNU General Public License along with
	15	! PALM. If not, see <http://www.gnu.org/licenses/>.
	16	!
[2101]	17	! Copyright 1997-2017 Leibniz Universitaet Hannover
[2000]	18	!------------------------------------------------------------------------------!
[1036]	19	!
[849]	20	! Current revisions:
	21	! ------------------
[1930]	22	!
[2245]	23	!
[1930]	24	! Former revisions:
	25	! -----------------
	26	! $Id: lpm_exchange_horiz.f90 2632 2017-11-20 15:35:52Z basit $
[2632]	27	! Bugfix in write statement
	28	!
	29	! 2630 2017-11-20 12:58:20Z schwenkel
[2628]	30	! Enabled particle advection with grid stretching. Furthermore, the CFL-
	31	! criterion is checked for every particle at every time step.
	32	!
	33	! 2606 2017-11-10 10:36:31Z schwenkel
[2606]	34	! Changed particle box locations: center of particle box now coincides
	35	! with scalar grid point of same index.
	36	! lpm_move_particle now moves inner particles that would leave the core
	37	! to the respective boundary gridbox. Afterwards they get transferred by
	38	! lpm_exchange_horiz. This allows particles to move more than one gridbox
	39	! independent of domain composition.
	40	! Renamed module and subroutines: lpm_pack_arrays_mod -> lpm_pack_and_sort_mod
	41	! lpm_pack_all_arrays -> lpm_sort_in_subboxes, lpm_pack_arrays -> lpm_pack
	42	! lpm_sort -> lpm_sort_timeloop_done
	43	!
	44	! 2330 2017-08-03 14:26:02Z schwenkel
[2330]	45	! Bugfix: Also for gfortran compilable, function c_sizeof is not used.
	46	!
	47	! 2305 2017-07-06 11:18:47Z hoffmann
[2305]	48	! Improved calculation of particle IDs.
	49	!
	50	! 2245 2017-06-02 14:37:10Z schwenkel
[2245]	51	! Bugfix in Add_particles_to_gridcell:
	52	! Apply boundary conditions also in y-direction
	53	!
	54	! 2151 2017-02-15 10:42:16Z schwenkel
	55	! Bugfix in lpm_move_particle that prevents
	56	! false production of additional particles
[1930]	57	!
[2001]	58	! 2000 2016-08-20 18:09:15Z knoop
	59	! Forced header and separation lines into 80 columns
	60	!
[1937]	61	! 1936 2016-06-13 13:37:44Z suehring
	62	! Deallocation of unused memory
	63	!
[1930]	64	! 1929 2016-06-09 16:25:25Z suehring
[1929]	65	! Bugfixes:
	66	! - reallocation of new particles
	67	! ( did not work for small number of min_nr_particle )
	68	! - dynamical reallocation of north-south exchange arrays ( particles got lost )
	69	! - north-south exchange ( nr_move_north, nr_move_south were overwritten by zero )
	70	! - horizontal particle boundary conditions in serial mode
	71	!
	72	! Remove unused variables
	73	! Descriptions in variable declaration blocks added
[1321]	74	!
[1874]	75	! 1873 2016-04-18 14:50:06Z maronga
	76	! Module renamed (removed _mod)
	77	!
	78	!
[1851]	79	! 1850 2016-04-08 13:29:27Z maronga
	80	! Module renamed
	81	!
	82	!
[1823]	83	! 1822 2016-04-07 07:49:42Z hoffmann
	84	! Tails removed. Unused variables removed.
	85	!
[1784]	86	! 1783 2016-03-06 18:36:17Z raasch
	87	! new netcdf-module included
	88	!
[1692]	89	! 1691 2015-10-26 16:17:44Z maronga
	90	! Formatting corrections.
	91	!
[1686]	92	! 1685 2015-10-08 07:32:13Z raasch
	93	! bugfix concerning vertical index offset in case of ocean
	94	!
[1683]	95	! 1682 2015-10-07 23:56:08Z knoop
	96	! Code annotations made doxygen readable
	97	!
[1360]	98	! 1359 2014-04-11 17:15:14Z hoffmann
	99	! New particle structure integrated.
	100	! Kind definition added to all floating point numbers.
	101	!
[1329]	102	! 1327 2014-03-21 11:00:16Z raasch
	103	! -netcdf output queries
	104	!
[1321]	105	! 1320 2014-03-20 08:40:49Z raasch
[1320]	106	! ONLY-attribute added to USE-statements,
	107	! kind-parameters added to all INTEGER and REAL declaration statements,
	108	! kinds are defined in new module kinds,
	109	! comment fields (!:) to be used for variable explanations added to
	110	! all variable declaration statements
[849]	111	!
[1319]	112	! 1318 2014-03-17 13:35:16Z raasch
	113	! module interfaces removed
	114	!
[1037]	115	! 1036 2012-10-22 13:43:42Z raasch
	116	! code put under GPL (PALM 3.9)
	117	!
[852]	118	! 851 2012-03-15 14:32:58Z raasch
	119	! Bugfix: resetting of particle_mask and tail mask moved from end of this
	120	! routine to lpm
	121	!
[850]	122	! 849 2012-03-15 10:35:09Z raasch
	123	! initial revision (former part of advec_particles)
[849]	124	!
[850]	125	!
[849]	126	! Description:
	127	! ------------
[1822]	128	! Exchange of particles between the subdomains.
[849]	129	!------------------------------------------------------------------------------!
[1682]	130	MODULE lpm_exchange_horiz_mod
	131
[2305]	132	USE, INTRINSIC :: ISO_C_BINDING
[2628]	133
	134	USE arrays_3d, &
	135	ONLY: zw
	136
[1320]	137	USE control_parameters, &
[1783]	138	ONLY: dz, message_string, simulated_time
[1320]	139
	140	USE cpulog, &
	141	ONLY: cpu_log, log_point_s
	142
	143	USE grid_variables, &
	144	ONLY: ddx, ddy, dx, dy
	145
	146	USE indices, &
[1359]	147	ONLY: nx, nxl, nxr, ny, nyn, nys, nzb, nzt
[1320]	148
	149	USE kinds
	150
[2606]	151	USE lpm_pack_and_sort_mod, &
	152	ONLY: lpm_pack
[1359]	153
[1783]	154	USE netcdf_interface, &
	155	ONLY: netcdf_data_format
	156
[1320]	157	USE particle_attributes, &
[1822]	158	ONLY: alloc_factor, deleted_particles, grid_particles, &
	159	ibc_par_lr, ibc_par_ns, min_nr_particle, &
[2305]	160	number_of_particles, &
[1822]	161	offset_ocean_nzt, offset_ocean_nzt_m1, particles, &
	162	particle_type, prt_count, trlp_count_sum, &
[1359]	163	trlp_count_recv_sum, trnp_count_sum, trnp_count_recv_sum, &
	164	trrp_count_sum, trrp_count_recv_sum, trsp_count_sum, &
[1822]	165	trsp_count_recv_sum, zero_particle
[1320]	166
[849]	167	USE pegrid
	168
	169	IMPLICIT NONE
	170
[1682]	171	INTEGER(iwp), PARAMETER :: NR_2_direction_move = 10000 !<
	172	INTEGER(iwp) :: nr_move_north !<
	173	INTEGER(iwp) :: nr_move_south !<
[1359]	174
[1929]	175	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: move_also_north
	176	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: move_also_south
[1359]	177
	178	SAVE
	179
	180	PRIVATE
[1936]	181	PUBLIC lpm_exchange_horiz, lpm_move_particle, realloc_particles_array, &
	182	dealloc_particles_array
[1359]	183
	184	INTERFACE lpm_exchange_horiz
	185	MODULE PROCEDURE lpm_exchange_horiz
	186	END INTERFACE lpm_exchange_horiz
	187
	188	INTERFACE lpm_move_particle
	189	MODULE PROCEDURE lpm_move_particle
	190	END INTERFACE lpm_move_particle
	191
	192	INTERFACE realloc_particles_array
	193	MODULE PROCEDURE realloc_particles_array
	194	END INTERFACE realloc_particles_array
	195
[1936]	196	INTERFACE dealloc_particles_array
	197	MODULE PROCEDURE dealloc_particles_array
	198	END INTERFACE dealloc_particles_array
[1359]	199	CONTAINS
	200
[1682]	201	!------------------------------------------------------------------------------!
	202	! Description:
	203	! ------------
	204	!> Exchange between subdomains.
	205	!> As soon as one particle has moved beyond the boundary of the domain, it
	206	!> is included in the relevant transfer arrays and marked for subsequent
	207	!> deletion on this PE.
	208	!> First sweep for crossings in x direction. Find out first the number of
	209	!> particles to be transferred and allocate temporary arrays needed to store
	210	!> them.
	211	!> For a one-dimensional decomposition along y, no transfer is necessary,
	212	!> because the particle remains on the PE, but the particle coordinate has to
	213	!> be adjusted.
	214	!------------------------------------------------------------------------------!
[1359]	215	SUBROUTINE lpm_exchange_horiz
	216
	217	IMPLICIT NONE
	218
[1929]	219	INTEGER(iwp) :: i !< grid index (x) of particle positition
	220	INTEGER(iwp) :: ip !< index variable along x
	221	INTEGER(iwp) :: j !< grid index (y) of particle positition
	222	INTEGER(iwp) :: jp !< index variable along y
	223	INTEGER(iwp) :: kp !< index variable along z
	224	INTEGER(iwp) :: n !< particle index variable
[2305]	225	INTEGER(iwp) :: par_size !< Particle size in bytes
[1929]	226	INTEGER(iwp) :: trlp_count !< number of particles send to left PE
	227	INTEGER(iwp) :: trlp_count_recv !< number of particles receive from right PE
	228	INTEGER(iwp) :: trnp_count !< number of particles send to north PE
	229	INTEGER(iwp) :: trnp_count_recv !< number of particles receive from south PE
	230	INTEGER(iwp) :: trrp_count !< number of particles send to right PE
	231	INTEGER(iwp) :: trrp_count_recv !< number of particles receive from left PE
	232	INTEGER(iwp) :: trsp_count !< number of particles send to south PE
	233	INTEGER(iwp) :: trsp_count_recv !< number of particles receive from north PE
[849]	234
[1929]	235	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: rvlp !< particles received from right PE
	236	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: rvnp !< particles received from south PE
	237	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: rvrp !< particles received from left PE
	238	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: rvsp !< particles received from north PE
	239	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: trlp !< particles send to left PE
	240	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: trnp !< particles send to north PE
	241	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: trrp !< particles send to right PE
	242	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: trsp !< particles send to south PE
[849]	243
[1359]	244	CALL cpu_log( log_point_s(23), 'lpm_exchange_horiz', 'start' )
	245
[849]	246	#if defined( __parallel )
	247
[1822]	248	!
	249	!-- Exchange between subdomains.
	250	!-- As soon as one particle has moved beyond the boundary of the domain, it
	251	!-- is included in the relevant transfer arrays and marked for subsequent
	252	!-- deletion on this PE.
	253	!-- First sweep for crossings in x direction. Find out first the number of
	254	!-- particles to be transferred and allocate temporary arrays needed to store
	255	!-- them.
	256	!-- For a one-dimensional decomposition along y, no transfer is necessary,
	257	!-- because the particle remains on the PE, but the particle coordinate has to
	258	!-- be adjusted.
[849]	259	trlp_count = 0
	260	trrp_count = 0
	261
	262	trlp_count_recv = 0
	263	trrp_count_recv = 0
	264
	265	IF ( pdims(1) /= 1 ) THEN
	266	!
[1359]	267	!-- First calculate the storage necessary for sending and receiving the data.
	268	!-- Compute only first (nxl) and last (nxr) loop iterration.
	269	DO ip = nxl, nxr, nxr - nxl
	270	DO jp = nys, nyn
	271	DO kp = nzb+1, nzt
[849]	272
[1359]	273	number_of_particles = prt_count(kp,jp,ip)
	274	IF ( number_of_particles <= 0 ) CYCLE
	275	particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
	276	DO n = 1, number_of_particles
	277	IF ( particles(n)%particle_mask ) THEN
[2606]	278	i = particles(n)%x * ddx
[1929]	279	!
	280	!-- Above calculation does not work for indices less than zero
[2606]	281	IF ( particles(n)%x < 0.0_wp) i = -1
[1359]	282
	283	IF ( i < nxl ) THEN
	284	trlp_count = trlp_count + 1
	285	ELSEIF ( i > nxr ) THEN
	286	trrp_count = trrp_count + 1
	287	ENDIF
	288	ENDIF
	289	ENDDO
	290
	291	ENDDO
	292	ENDDO
[849]	293	ENDDO
	294
	295	IF ( trlp_count == 0 ) trlp_count = 1
	296	IF ( trrp_count == 0 ) trrp_count = 1
	297
	298	ALLOCATE( trlp(trlp_count), trrp(trrp_count) )
	299
[1359]	300	trlp = zero_particle
	301	trrp = zero_particle
[849]	302
	303	trlp_count = 0
	304	trrp_count = 0
	305
	306	ENDIF
[1359]	307	!
	308	!-- Compute only first (nxl) and last (nxr) loop iterration
[1929]	309	DO ip = nxl, nxr, nxr-nxl
[1359]	310	DO jp = nys, nyn
	311	DO kp = nzb+1, nzt
	312	number_of_particles = prt_count(kp,jp,ip)
	313	IF ( number_of_particles <= 0 ) CYCLE
	314	particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
	315	DO n = 1, number_of_particles
	316	!
	317	!-- Only those particles that have not been marked as 'deleted' may
	318	!-- be moved.
	319	IF ( particles(n)%particle_mask ) THEN
[849]	320
[2606]	321	i = particles(n)%x * ddx
[1929]	322	!
	323	!-- Above calculation does not work for indices less than zero
[2606]	324	IF ( particles(n)%x < 0.0_wp ) i = -1
[849]	325
[1359]	326	IF ( i < nxl ) THEN
	327	IF ( i < 0 ) THEN
[1929]	328	!
	329	!-- Apply boundary condition along x
[1359]	330	IF ( ibc_par_lr == 0 ) THEN
[1929]	331	!
	332	!-- Cyclic condition
[1359]	333	IF ( pdims(1) == 1 ) THEN
	334	particles(n)%x = ( nx + 1 ) * dx + particles(n)%x
	335	particles(n)%origin_x = ( nx + 1 ) * dx + &
	336	particles(n)%origin_x
	337	ELSE
	338	trlp_count = trlp_count + 1
	339	trlp(trlp_count) = particles(n)
	340	trlp(trlp_count)%x = ( nx + 1 ) * dx + trlp(trlp_count)%x
	341	trlp(trlp_count)%origin_x = trlp(trlp_count)%origin_x + &
	342	( nx + 1 ) * dx
	343	particles(n)%particle_mask = .FALSE.
	344	deleted_particles = deleted_particles + 1
[849]	345
[2606]	346	IF ( trlp(trlp_count)%x >= (nx + 1)* dx - 1.0E-12_wp ) THEN
[1359]	347	trlp(trlp_count)%x = trlp(trlp_count)%x - 1.0E-10_wp
	348	!++ why is 1 subtracted in next statement???
	349	trlp(trlp_count)%origin_x = trlp(trlp_count)%origin_x - 1
	350	ENDIF
[849]	351
[1359]	352	ENDIF
[849]	353
[1359]	354	ELSEIF ( ibc_par_lr == 1 ) THEN
[1929]	355	!
	356	!-- Particle absorption
[1359]	357	particles(n)%particle_mask = .FALSE.
	358	deleted_particles = deleted_particles + 1
[849]	359
[1359]	360	ELSEIF ( ibc_par_lr == 2 ) THEN
[1929]	361	!
	362	!-- Particle reflection
[1359]	363	particles(n)%x = -particles(n)%x
	364	particles(n)%speed_x = -particles(n)%speed_x
[849]	365
[1359]	366	ENDIF
	367	ELSE
[1929]	368	!
	369	!-- Store particle data in the transfer array, which will be
	370	!-- send to the neighbouring PE
[1359]	371	trlp_count = trlp_count + 1
	372	trlp(trlp_count) = particles(n)
	373	particles(n)%particle_mask = .FALSE.
	374	deleted_particles = deleted_particles + 1
[849]	375
[1359]	376	ENDIF
[849]	377
[1359]	378	ELSEIF ( i > nxr ) THEN
	379	IF ( i > nx ) THEN
[1929]	380	!
	381	!-- Apply boundary condition along x
[1359]	382	IF ( ibc_par_lr == 0 ) THEN
[1929]	383	!
	384	!-- Cyclic condition
[1359]	385	IF ( pdims(1) == 1 ) THEN
	386	particles(n)%x = particles(n)%x - ( nx + 1 ) * dx
	387	particles(n)%origin_x = particles(n)%origin_x - &
	388	( nx + 1 ) * dx
	389	ELSE
	390	trrp_count = trrp_count + 1
	391	trrp(trrp_count) = particles(n)
	392	trrp(trrp_count)%x = trrp(trrp_count)%x - ( nx + 1 ) * dx
	393	trrp(trrp_count)%origin_x = trrp(trrp_count)%origin_x - &
	394	( nx + 1 ) * dx
	395	particles(n)%particle_mask = .FALSE.
	396	deleted_particles = deleted_particles + 1
[849]	397
[1359]	398	ENDIF
[849]	399
[1359]	400	ELSEIF ( ibc_par_lr == 1 ) THEN
[1929]	401	!
	402	!-- Particle absorption
[1359]	403	particles(n)%particle_mask = .FALSE.
	404	deleted_particles = deleted_particles + 1
[849]	405
[1359]	406	ELSEIF ( ibc_par_lr == 2 ) THEN
[1929]	407	!
	408	!-- Particle reflection
[1359]	409	particles(n)%x = 2 * ( nx * dx ) - particles(n)%x
	410	particles(n)%speed_x = -particles(n)%speed_x
[849]	411
[1359]	412	ENDIF
	413	ELSE
[1929]	414	!
	415	!-- Store particle data in the transfer array, which will be send
	416	!-- to the neighbouring PE
[1359]	417	trrp_count = trrp_count + 1
	418	trrp(trrp_count) = particles(n)
	419	particles(n)%particle_mask = .FALSE.
	420	deleted_particles = deleted_particles + 1
[849]	421
[1359]	422	ENDIF
[849]	423
[1359]	424	ENDIF
	425	ENDIF
[1929]	426
[1359]	427	ENDDO
	428	ENDDO
	429	ENDDO
[849]	430	ENDDO
	431
[2330]	432	#if defined( __gfortran )
[849]	433	!
[2330]	434	!-- For the gfortran compiler the function c_sizeof produces strange erros
	435	!-- which can probably be attributed to an error in the gfortran compiler.
	436	!-- Therefore the particle size in bytes is set manually. Attention: A
	437	!-- change of the size of the particle type requires an adjustment of
	438	!-- this value
	439	par_size = 184
	440	#else
	441	!
	442	!-- This MPI_SENDRECV should work even with odd mixture on 32 and 64 Bit
	443	!-- variables in structure particle_type (due to the calculation of par_size)
	444	par_size = c_sizeof(trlp(1))
	445	#endif
	446
	447
	448	!
[1929]	449	!-- Allocate arrays required for north-south exchange, as these
	450	!-- are used directly after particles are exchange along x-direction.
	451	ALLOCATE( move_also_north(1:NR_2_direction_move) )
	452	ALLOCATE( move_also_south(1:NR_2_direction_move) )
	453
	454	nr_move_north = 0
	455	nr_move_south = 0
	456	!
[849]	457	!-- Send left boundary, receive right boundary (but first exchange how many
	458	!-- and check, if particle storage must be extended)
	459	IF ( pdims(1) /= 1 ) THEN
	460
	461	CALL MPI_SENDRECV( trlp_count, 1, MPI_INTEGER, pleft, 0, &
	462	trrp_count_recv, 1, MPI_INTEGER, pright, 0, &
	463	comm2d, status, ierr )
	464
[1359]	465	ALLOCATE(rvrp(MAX(1,trrp_count_recv)))
[2330]	466
[2305]	467	CALL MPI_SENDRECV( trlp, max(1,trlp_count)*par_size, MPI_BYTE,&
	468	pleft, 1, rvrp, &
	469	max(1,trrp_count_recv)*par_size, MPI_BYTE, pright, 1,&
[849]	470	comm2d, status, ierr )
	471
[1359]	472	IF ( trrp_count_recv > 0 ) CALL Add_particles_to_gridcell(rvrp(1:trrp_count_recv))
	473
	474	DEALLOCATE(rvrp)
	475
[849]	476	!
	477	!-- Send right boundary, receive left boundary
	478	CALL MPI_SENDRECV( trrp_count, 1, MPI_INTEGER, pright, 0, &
	479	trlp_count_recv, 1, MPI_INTEGER, pleft, 0, &
	480	comm2d, status, ierr )
	481
[1359]	482	ALLOCATE(rvlp(MAX(1,trlp_count_recv)))
[2305]	483	!
	484	!-- This MPI_SENDRECV should work even with odd mixture on 32 and 64 Bit
	485	!-- variables in structure particle_type (due to the calculation of par_size)
	486	CALL MPI_SENDRECV( trrp, max(1,trrp_count)*par_size, MPI_BYTE,&
	487	pright, 1, rvlp, &
	488	max(1,trlp_count_recv)*par_size, MPI_BYTE, pleft, 1, &
[849]	489	comm2d, status, ierr )
	490
[1359]	491	IF ( trlp_count_recv > 0 ) CALL Add_particles_to_gridcell(rvlp(1:trlp_count_recv))
	492
[1822]	493	DEALLOCATE( rvlp )
[1359]	494	DEALLOCATE( trlp, trrp )
[849]	495
	496	ENDIF
	497
	498	!
	499	!-- Check whether particles have crossed the boundaries in y direction. Note
	500	!-- that this case can also apply to particles that have just been received
	501	!-- from the adjacent right or left PE.
	502	!-- Find out first the number of particles to be transferred and allocate
	503	!-- temporary arrays needed to store them.
[1929]	504	!-- For a one-dimensional decomposition along y, no transfer is necessary,
[849]	505	!-- because the particle remains on the PE.
[1359]	506	trsp_count = nr_move_south
	507	trnp_count = nr_move_north
[849]	508
	509	trsp_count_recv = 0
	510	trnp_count_recv = 0
	511
	512	IF ( pdims(2) /= 1 ) THEN
	513	!
	514	!-- First calculate the storage necessary for sending and receiving the
	515	!-- data
[1359]	516	DO ip = nxl, nxr
[1929]	517	DO jp = nys, nyn, nyn-nys !compute only first (nys) and last (nyn) loop iterration
[1359]	518	DO kp = nzb+1, nzt
	519	number_of_particles = prt_count(kp,jp,ip)
	520	IF ( number_of_particles <= 0 ) CYCLE
	521	particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
	522	DO n = 1, number_of_particles
	523	IF ( particles(n)%particle_mask ) THEN
[2606]	524	j = particles(n)%y * ddy
[849]	525	!
[1359]	526	!-- Above calculation does not work for indices less than zero
[2606]	527	IF ( particles(n)%y < 0.0_wp) j = -1
[849]	528
[1359]	529	IF ( j < nys ) THEN
	530	trsp_count = trsp_count + 1
	531	ELSEIF ( j > nyn ) THEN
	532	trnp_count = trnp_count + 1
	533	ENDIF
	534	ENDIF
	535	ENDDO
	536	ENDDO
	537	ENDDO
[849]	538	ENDDO
	539
	540	IF ( trsp_count == 0 ) trsp_count = 1
	541	IF ( trnp_count == 0 ) trnp_count = 1
	542
	543	ALLOCATE( trsp(trsp_count), trnp(trnp_count) )
	544
[1359]	545	trsp = zero_particle
	546	trnp = zero_particle
[849]	547
[1359]	548	trsp_count = nr_move_south
	549	trnp_count = nr_move_north
[1929]	550
[1359]	551	trsp(1:nr_move_south) = move_also_south(1:nr_move_south)
	552	trnp(1:nr_move_north) = move_also_north(1:nr_move_north)
	553
[849]	554	ENDIF
	555
[1359]	556	DO ip = nxl, nxr
	557	DO jp = nys, nyn, nyn-nys ! compute only first (nys) and last (nyn) loop iterration
	558	DO kp = nzb+1, nzt
	559	number_of_particles = prt_count(kp,jp,ip)
	560	IF ( number_of_particles <= 0 ) CYCLE
	561	particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
	562	DO n = 1, number_of_particles
[849]	563	!
[1359]	564	!-- Only those particles that have not been marked as 'deleted' may
	565	!-- be moved.
	566	IF ( particles(n)%particle_mask ) THEN
[1929]	567
[2606]	568	j = particles(n)%y * ddy
[849]	569	!
[1359]	570	!-- Above calculation does not work for indices less than zero
[2606]	571	IF ( particles(n)%y < 0.0_wp ) j = -1
[849]	572
[1359]	573	IF ( j < nys ) THEN
	574	IF ( j < 0 ) THEN
[849]	575	!
[1359]	576	!-- Apply boundary condition along y
	577	IF ( ibc_par_ns == 0 ) THEN
[849]	578	!
[1359]	579	!-- Cyclic condition
	580	IF ( pdims(2) == 1 ) THEN
	581	particles(n)%y = ( ny + 1 ) * dy + particles(n)%y
	582	particles(n)%origin_y = ( ny + 1 ) * dy + &
[1929]	583	particles(n)%origin_y
[1359]	584	ELSE
[1929]	585	trsp_count = trsp_count + 1
	586	trsp(trsp_count) = particles(n)
[1359]	587	trsp(trsp_count)%y = ( ny + 1 ) * dy + &
[1929]	588	trsp(trsp_count)%y
[1359]	589	trsp(trsp_count)%origin_y = trsp(trsp_count)%origin_y &
[1929]	590	+ ( ny + 1 ) * dy
[1359]	591	particles(n)%particle_mask = .FALSE.
	592	deleted_particles = deleted_particles + 1
[849]	593
[2606]	594	IF ( trsp(trsp_count)%y >= (ny+1)* dy - 1.0E-12_wp ) THEN
[1359]	595	trsp(trsp_count)%y = trsp(trsp_count)%y - 1.0E-10_wp
	596	!++ why is 1 subtracted in next statement???
	597	trsp(trsp_count)%origin_y = &
[1929]	598	trsp(trsp_count)%origin_y - 1
[1359]	599	ENDIF
[849]	600
[1359]	601	ENDIF
[849]	602
[1359]	603	ELSEIF ( ibc_par_ns == 1 ) THEN
[849]	604	!
[1359]	605	!-- Particle absorption
	606	particles(n)%particle_mask = .FALSE.
[1929]	607	deleted_particles = deleted_particles + 1
[849]	608
[1359]	609	ELSEIF ( ibc_par_ns == 2 ) THEN
[849]	610	!
[1359]	611	!-- Particle reflection
	612	particles(n)%y = -particles(n)%y
	613	particles(n)%speed_y = -particles(n)%speed_y
[849]	614
[1359]	615	ENDIF
	616	ELSE
[849]	617	!
[1359]	618	!-- Store particle data in the transfer array, which will
	619	!-- be send to the neighbouring PE
	620	trsp_count = trsp_count + 1
	621	trsp(trsp_count) = particles(n)
	622	particles(n)%particle_mask = .FALSE.
	623	deleted_particles = deleted_particles + 1
[849]	624
[1359]	625	ENDIF
[849]	626
[1359]	627	ELSEIF ( j > nyn ) THEN
	628	IF ( j > ny ) THEN
[849]	629	!
[1929]	630	!-- Apply boundary condition along y
[1359]	631	IF ( ibc_par_ns == 0 ) THEN
[849]	632	!
[1359]	633	!-- Cyclic condition
	634	IF ( pdims(2) == 1 ) THEN
[1929]	635	particles(n)%y = particles(n)%y - ( ny + 1 ) * dy
[1359]	636	particles(n)%origin_y = &
[1929]	637	particles(n)%origin_y - ( ny + 1 ) * dy
[1359]	638	ELSE
[1929]	639	trnp_count = trnp_count + 1
	640	trnp(trnp_count) = particles(n)
[1359]	641	trnp(trnp_count)%y = &
[1929]	642	trnp(trnp_count)%y - ( ny + 1 ) * dy
[1359]	643	trnp(trnp_count)%origin_y = &
[1929]	644	trnp(trnp_count)%origin_y - ( ny + 1 ) * dy
[1359]	645	particles(n)%particle_mask = .FALSE.
[1929]	646	deleted_particles = deleted_particles + 1
[1359]	647	ENDIF
[849]	648
[1359]	649	ELSEIF ( ibc_par_ns == 1 ) THEN
[849]	650	!
[1359]	651	!-- Particle absorption
	652	particles(n)%particle_mask = .FALSE.
	653	deleted_particles = deleted_particles + 1
[849]	654
[1359]	655	ELSEIF ( ibc_par_ns == 2 ) THEN
[849]	656	!
[1359]	657	!-- Particle reflection
	658	particles(n)%y = 2 * ( ny * dy ) - particles(n)%y
	659	particles(n)%speed_y = -particles(n)%speed_y
[849]	660
[1359]	661	ENDIF
	662	ELSE
[849]	663	!
[1359]	664	!-- Store particle data in the transfer array, which will
	665	!-- be send to the neighbouring PE
	666	trnp_count = trnp_count + 1
	667	trnp(trnp_count) = particles(n)
	668	particles(n)%particle_mask = .FALSE.
	669	deleted_particles = deleted_particles + 1
[849]	670
[1359]	671	ENDIF
	672
	673	ENDIF
[849]	674	ENDIF
[1359]	675	ENDDO
	676	ENDDO
	677	ENDDO
[849]	678	ENDDO
	679
	680	!
	681	!-- Send front boundary, receive back boundary (but first exchange how many
	682	!-- and check, if particle storage must be extended)
	683	IF ( pdims(2) /= 1 ) THEN
	684
	685	CALL MPI_SENDRECV( trsp_count, 1, MPI_INTEGER, psouth, 0, &
	686	trnp_count_recv, 1, MPI_INTEGER, pnorth, 0, &
	687	comm2d, status, ierr )
	688
[1359]	689	ALLOCATE(rvnp(MAX(1,trnp_count_recv)))
[2305]	690	!
	691	!-- This MPI_SENDRECV should work even with odd mixture on 32 and 64 Bit
	692	!-- variables in structure particle_type (due to the calculation of par_size)
	693	CALL MPI_SENDRECV( trsp, trsp_count*par_size, MPI_BYTE, &
	694	psouth, 1, rvnp, &
	695	trnp_count_recv*par_size, MPI_BYTE, pnorth, 1, &
[849]	696	comm2d, status, ierr )
	697
[1359]	698	IF ( trnp_count_recv > 0 ) CALL Add_particles_to_gridcell(rvnp(1:trnp_count_recv))
	699
	700	DEALLOCATE(rvnp)
	701
[849]	702	!
	703	!-- Send back boundary, receive front boundary
	704	CALL MPI_SENDRECV( trnp_count, 1, MPI_INTEGER, pnorth, 0, &
	705	trsp_count_recv, 1, MPI_INTEGER, psouth, 0, &
	706	comm2d, status, ierr )
	707
[1359]	708	ALLOCATE(rvsp(MAX(1,trsp_count_recv)))
[2305]	709	!
	710	!-- This MPI_SENDRECV should work even with odd mixture on 32 and 64 Bit
	711	!-- variables in structure particle_type (due to the calculation of par_size)
	712	CALL MPI_SENDRECV( trnp, trnp_count*par_size, MPI_BYTE, &
	713	pnorth, 1, rvsp, &
	714	trsp_count_recv*par_size, MPI_BYTE, psouth, 1, &
[849]	715	comm2d, status, ierr )
	716
[1359]	717	IF ( trsp_count_recv > 0 ) CALL Add_particles_to_gridcell(rvsp(1:trsp_count_recv))
	718
	719	DEALLOCATE(rvsp)
	720
[849]	721	number_of_particles = number_of_particles + trsp_count_recv
	722
	723	DEALLOCATE( trsp, trnp )
	724
	725	ENDIF
	726
[1929]	727	DEALLOCATE( move_also_north )
	728	DEALLOCATE( move_also_south )
	729
[849]	730	#else
	731
[1929]	732	DO ip = nxl, nxr, nxr-nxl
	733	DO jp = nys, nyn
	734	DO kp = nzb+1, nzt
	735	number_of_particles = prt_count(kp,jp,ip)
	736	IF ( number_of_particles <= 0 ) CYCLE
	737	particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
	738	DO n = 1, number_of_particles
[849]	739	!
[1929]	740	!-- Apply boundary conditions
[849]	741
[2606]	742	IF ( particles(n)%x < 0.0_wp ) THEN
[849]	743
[1929]	744	IF ( ibc_par_lr == 0 ) THEN
[849]	745	!
[1929]	746	!-- Cyclic boundary. Relevant coordinate has to be changed.
	747	particles(n)%x = ( nx + 1 ) * dx + particles(n)%x
[2606]	748	particles(n)%origin_x = ( nx + 1 ) * dx + &
	749	particles(n)%origin_x
[1929]	750	ELSEIF ( ibc_par_lr == 1 ) THEN
[849]	751	!
[1929]	752	!-- Particle absorption
	753	particles(n)%particle_mask = .FALSE.
	754	deleted_particles = deleted_particles + 1
[1822]	755
[1929]	756	ELSEIF ( ibc_par_lr == 2 ) THEN
[849]	757	!
[1929]	758	!-- Particle reflection
	759	particles(n)%x = -dx - particles(n)%x
	760	particles(n)%speed_x = -particles(n)%speed_x
	761	ENDIF
[849]	762
[2606]	763	ELSEIF ( particles(n)%x >= ( nx + 1) * dx ) THEN
[849]	764
[1929]	765	IF ( ibc_par_lr == 0 ) THEN
[849]	766	!
[1929]	767	!-- Cyclic boundary. Relevant coordinate has to be changed.
	768	particles(n)%x = particles(n)%x - ( nx + 1 ) * dx
[2606]	769	particles(n)%origin_x = particles(n)%origin_x - &
	770	( nx + 1 ) * dx
[1822]	771
[1929]	772	ELSEIF ( ibc_par_lr == 1 ) THEN
[849]	773	!
[1929]	774	!-- Particle absorption
	775	particles(n)%particle_mask = .FALSE.
	776	deleted_particles = deleted_particles + 1
[1822]	777
[1929]	778	ELSEIF ( ibc_par_lr == 2 ) THEN
[849]	779	!
[1929]	780	!-- Particle reflection
	781	particles(n)%x = ( nx + 1 ) * dx - particles(n)%x
	782	particles(n)%speed_x = -particles(n)%speed_x
	783	ENDIF
[849]	784
[1929]	785	ENDIF
	786	ENDDO
	787	ENDDO
	788	ENDDO
	789	ENDDO
[849]	790
[1929]	791	DO ip = nxl, nxr
	792	DO jp = nys, nyn, nyn-nys
	793	DO kp = nzb+1, nzt
	794	number_of_particles = prt_count(kp,jp,ip)
	795	IF ( number_of_particles <= 0 ) CYCLE
	796	particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
	797	DO n = 1, number_of_particles
[849]	798
[2606]	799	IF ( particles(n)%y < 0.0_wp) THEN
[1929]	800
	801	IF ( ibc_par_ns == 0 ) THEN
[849]	802	!
[1929]	803	!-- Cyclic boundary. Relevant coordinate has to be changed.
	804	particles(n)%y = ( ny + 1 ) * dy + particles(n)%y
[2606]	805	particles(n)%origin_y = ( ny + 1 ) * dy + &
	806	particles(n)%origin_y
[1822]	807
[1929]	808	ELSEIF ( ibc_par_ns == 1 ) THEN
[849]	809	!
[1929]	810	!-- Particle absorption
	811	particles(n)%particle_mask = .FALSE.
	812	deleted_particles = deleted_particles + 1
[1822]	813
[1929]	814	ELSEIF ( ibc_par_ns == 2 ) THEN
[849]	815	!
[1929]	816	!-- Particle reflection
	817	particles(n)%y = -dy - particles(n)%y
	818	particles(n)%speed_y = -particles(n)%speed_y
	819	ENDIF
[849]	820
[2606]	821	ELSEIF ( particles(n)%y >= ( ny + 1) * dy ) THEN
[849]	822
[1929]	823	IF ( ibc_par_ns == 0 ) THEN
[849]	824	!
[1929]	825	!-- Cyclic boundary. Relevant coordinate has to be changed.
	826	particles(n)%y = particles(n)%y - ( ny + 1 ) * dy
[2606]	827	particles(n)%origin_y = particles(n)%origin_y - &
	828	( ny + 1 ) * dy
[1822]	829
[1929]	830	ELSEIF ( ibc_par_ns == 1 ) THEN
[849]	831	!
[1929]	832	!-- Particle absorption
	833	particles(n)%particle_mask = .FALSE.
	834	deleted_particles = deleted_particles + 1
[1822]	835
[1929]	836	ELSEIF ( ibc_par_ns == 2 ) THEN
[849]	837	!
[1929]	838	!-- Particle reflection
	839	particles(n)%y = ( ny + 1 ) * dy - particles(n)%y
	840	particles(n)%speed_y = -particles(n)%speed_y
	841	ENDIF
[849]	842
[1929]	843	ENDIF
	844
	845	ENDDO
	846	ENDDO
	847	ENDDO
[849]	848	ENDDO
	849	#endif
	850
	851	!
	852	!-- Accumulate the number of particles transferred between the subdomains
	853	#if defined( __parallel )
	854	trlp_count_sum = trlp_count_sum + trlp_count
	855	trlp_count_recv_sum = trlp_count_recv_sum + trlp_count_recv
	856	trrp_count_sum = trrp_count_sum + trrp_count
	857	trrp_count_recv_sum = trrp_count_recv_sum + trrp_count_recv
	858	trsp_count_sum = trsp_count_sum + trsp_count
	859	trsp_count_recv_sum = trsp_count_recv_sum + trsp_count_recv
	860	trnp_count_sum = trnp_count_sum + trnp_count
	861	trnp_count_recv_sum = trnp_count_recv_sum + trnp_count_recv
	862	#endif
	863
[1359]	864	CALL cpu_log( log_point_s(23), 'lpm_exchange_horiz', 'stop' )
[849]	865
	866	END SUBROUTINE lpm_exchange_horiz
[1359]	867
[1682]	868	!------------------------------------------------------------------------------!
	869	! Description:
	870	! ------------
	871	!> If a particle moves from one processor to another, this subroutine moves
	872	!> the corresponding elements from the particle arrays of the old grid cells
	873	!> to the particle arrays of the new grid cells.
	874	!------------------------------------------------------------------------------!
[1359]	875	SUBROUTINE Add_particles_to_gridcell (particle_array)
	876
	877	IMPLICIT NONE
	878
[1929]	879	INTEGER(iwp) :: ip !< grid index (x) of particle
	880	INTEGER(iwp) :: jp !< grid index (x) of particle
	881	INTEGER(iwp) :: kp !< grid index (x) of particle
	882	INTEGER(iwp) :: n !< index variable of particle
	883	INTEGER(iwp) :: pindex !< dummy argument for new number of particles per grid box
[1359]	884
[1682]	885	LOGICAL :: pack_done !<
[1359]	886
[1929]	887	TYPE(particle_type), DIMENSION(:), INTENT(IN) :: particle_array !< new particles in a grid box
	888	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: temp_ns !< temporary particle array for reallocation
[1359]	889
	890	pack_done = .FALSE.
	891
[1929]	892	DO n = 1, SIZE(particle_array)
[1359]	893
[1929]	894	IF ( .NOT. particle_array(n)%particle_mask ) CYCLE
	895
[2606]	896	ip = particle_array(n)%x * ddx
	897	jp = particle_array(n)%y * ddy
	898	kp = particle_array(n)%z / dz + 1 + offset_ocean_nzt
[2628]	899	!
	900	!-- In case of grid stretching a particle might be above or below the
	901	!-- previously calculated particle grid box (indices).
	902	DO WHILE( zw(kp) < particle_array(n)%z )
	903	kp = kp + 1
	904	ENDDO
[1359]	905
[2628]	906	DO WHILE( zw(kp-1) > particle_array(n)%z )
	907	kp = kp - 1
	908	ENDDO
	909
[1359]	910	IF ( ip >= nxl .AND. ip <= nxr .AND. jp >= nys .AND. jp <= nyn &
	911	.AND. kp >= nzb+1 .AND. kp <= nzt) THEN ! particle stays on processor
	912	number_of_particles = prt_count(kp,jp,ip)
	913	particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
	914
	915	pindex = prt_count(kp,jp,ip)+1
	916	IF( pindex > SIZE(grid_particles(kp,jp,ip)%particles) ) THEN
	917	IF ( pack_done ) THEN
	918	CALL realloc_particles_array (ip,jp,kp)
	919	ELSE
[2606]	920	CALL lpm_pack
[1359]	921	prt_count(kp,jp,ip) = number_of_particles
	922	pindex = prt_count(kp,jp,ip)+1
	923	IF ( pindex > SIZE(grid_particles(kp,jp,ip)%particles) ) THEN
	924	CALL realloc_particles_array (ip,jp,kp)
	925	ENDIF
	926	pack_done = .TRUE.
	927	ENDIF
	928	ENDIF
	929	grid_particles(kp,jp,ip)%particles(pindex) = particle_array(n)
	930	prt_count(kp,jp,ip) = pindex
	931	ELSE
[1929]	932	IF ( jp <= nys - 1 ) THEN
[1359]	933	nr_move_south = nr_move_south+1
[1929]	934	!
	935	!-- Before particle information is swapped to exchange-array, check
	936	!-- if enough memory is allocated. If required, reallocate exchange
	937	!-- array.
	938	IF ( nr_move_south > SIZE(move_also_south) ) THEN
	939	!
	940	!-- At first, allocate further temporary array to swap particle
	941	!-- information.
	942	ALLOCATE( temp_ns(SIZE(move_also_south)+NR_2_direction_move) )
	943	temp_ns(1:nr_move_south-1) = move_also_south(1:nr_move_south-1)
	944	DEALLOCATE( move_also_south )
	945	ALLOCATE( move_also_south(SIZE(temp_ns)) )
	946	move_also_south(1:nr_move_south-1) = temp_ns(1:nr_move_south-1)
	947	DEALLOCATE( temp_ns )
	948
	949	ENDIF
	950
[1359]	951	move_also_south(nr_move_south) = particle_array(n)
[1929]	952
[1359]	953	IF ( jp == -1 ) THEN
[2245]	954	!
	955	!-- Apply boundary condition along y
	956	IF ( ibc_par_ns == 0 ) THEN
	957	move_also_south(nr_move_south)%y = &
	958	move_also_south(nr_move_south)%y + ( ny + 1 ) * dy
	959	move_also_south(nr_move_south)%origin_y = &
	960	move_also_south(nr_move_south)%origin_y + ( ny + 1 ) * dy
	961	ELSEIF ( ibc_par_ns == 1 ) THEN
	962	!
	963	!-- Particle absorption
	964	move_also_south(nr_move_south)%particle_mask = .FALSE.
	965	deleted_particles = deleted_particles + 1
	966
	967	ELSEIF ( ibc_par_ns == 2 ) THEN
	968	!
	969	!-- Particle reflection
	970	move_also_south(nr_move_south)%y = &
	971	-move_also_south(nr_move_south)%y
	972	move_also_south(nr_move_south)%speed_y = &
	973	-move_also_south(nr_move_south)%speed_y
	974
	975	ENDIF
[1359]	976	ENDIF
[1929]	977	ELSEIF ( jp >= nyn+1 ) THEN
[1359]	978	nr_move_north = nr_move_north+1
[1929]	979	!
	980	!-- Before particle information is swapped to exchange-array, check
	981	!-- if enough memory is allocated. If required, reallocate exchange
	982	!-- array.
	983	IF ( nr_move_north > SIZE(move_also_north) ) THEN
	984	!
	985	!-- At first, allocate further temporary array to swap particle
	986	!-- information.
	987	ALLOCATE( temp_ns(SIZE(move_also_north)+NR_2_direction_move) )
	988	temp_ns(1:nr_move_north-1) = move_also_south(1:nr_move_north-1)
	989	DEALLOCATE( move_also_north )
	990	ALLOCATE( move_also_north(SIZE(temp_ns)) )
	991	move_also_north(1:nr_move_north-1) = temp_ns(1:nr_move_north-1)
	992	DEALLOCATE( temp_ns )
	993
	994	ENDIF
	995
[1359]	996	move_also_north(nr_move_north) = particle_array(n)
	997	IF ( jp == ny+1 ) THEN
[2245]	998	!
	999	!-- Apply boundary condition along y
	1000	IF ( ibc_par_ns == 0 ) THEN
	1001
	1002	move_also_north(nr_move_north)%y = &
	1003	move_also_north(nr_move_north)%y - ( ny + 1 ) * dy
	1004	move_also_north(nr_move_north)%origin_y = &
	1005	move_also_north(nr_move_north)%origin_y - ( ny + 1 ) * dy
	1006	ELSEIF ( ibc_par_ns == 1 ) THEN
	1007	!
	1008	!-- Particle absorption
	1009	move_also_north(nr_move_north)%particle_mask = .FALSE.
	1010	deleted_particles = deleted_particles + 1
	1011
	1012	ELSEIF ( ibc_par_ns == 2 ) THEN
	1013	!
	1014	!-- Particle reflection
	1015	move_also_north(nr_move_north)%y = &
	1016	-move_also_north(nr_move_north)%y
	1017	move_also_north(nr_move_north)%speed_y = &
	1018	-move_also_north(nr_move_north)%speed_y
	1019
	1020	ENDIF
[1359]	1021	ENDIF
	1022	ELSE
	1023	WRITE(0,'(a,8i7)') 'particle out of range ',myid,ip,jp,kp,nxl,nxr,nys,nyn
	1024	ENDIF
	1025	ENDIF
	1026	ENDDO
	1027
	1028	RETURN
	1029
	1030	END SUBROUTINE Add_particles_to_gridcell
	1031
	1032
	1033
	1034
[1682]	1035	!------------------------------------------------------------------------------!
	1036	! Description:
	1037	! ------------
	1038	!> If a particle moves from one grid cell to another (on the current
	1039	!> processor!), this subroutine moves the corresponding element from the
	1040	!> particle array of the old grid cell to the particle array of the new grid
	1041	!> cell.
	1042	!------------------------------------------------------------------------------!
[1359]	1043	SUBROUTINE lpm_move_particle
[2628]	1044
[1359]	1045	IMPLICIT NONE
	1046
[1929]	1047	INTEGER(iwp) :: i !< grid index (x) of particle position
	1048	INTEGER(iwp) :: ip !< index variable along x
	1049	INTEGER(iwp) :: j !< grid index (y) of particle position
	1050	INTEGER(iwp) :: jp !< index variable along y
	1051	INTEGER(iwp) :: k !< grid index (z) of particle position
	1052	INTEGER(iwp) :: kp !< index variable along z
	1053	INTEGER(iwp) :: n !< index variable for particle array
[2606]	1054	INTEGER(iwp) :: np_before_move !< number of particles per grid box before moving
[1929]	1055	INTEGER(iwp) :: pindex !< dummy argument for number of new particle per grid box
[1359]	1056
[2606]	1057	TYPE(particle_type), DIMENSION(:), POINTER :: particles_before_move !< particles before moving
[1359]	1058
	1059	CALL cpu_log( log_point_s(41), 'lpm_move_particle', 'start' )
[2628]	1060	CALL lpm_check_cfl
[1359]	1061	DO ip = nxl, nxr
	1062	DO jp = nys, nyn
	1063	DO kp = nzb+1, nzt
	1064
[2606]	1065	np_before_move = prt_count(kp,jp,ip)
	1066	IF ( np_before_move <= 0 ) CYCLE
	1067	particles_before_move => grid_particles(kp,jp,ip)%particles(1:np_before_move)
[1359]	1068
[2606]	1069	DO n = 1, np_before_move
	1070	i = particles_before_move(n)%x * ddx
	1071	j = particles_before_move(n)%y * ddy
[2628]	1072	k = kp
	1073	!
	1074	!-- Find correct vertical particle grid box (necessary in case of grid stretching)
	1075	!-- Due to the CFL limitations only the neighbouring grid boxes are considered.
	1076	IF( zw(k) < particles_before_move(n)%z ) k = k + 1
	1077	IF( zw(k-1) > particles_before_move(n)%z ) k = k - 1
	1078
[2606]	1079	!-- For lpm_exchange_horiz to work properly particles need to be moved to the outermost gridboxes
	1080	!-- of the respective processor. If the particle index is inside the processor the following lines
	1081	!-- will not change the index
	1082	i = MIN ( i , nxr )
	1083	i = MAX ( i , nxl )
	1084	j = MIN ( j , nyn )
	1085	j = MAX ( j , nys )
[2628]	1086
[2606]	1087	k = MIN ( k , nzt )
	1088	k = MAX ( k , nzb+1 )
[2628]	1089
[1359]	1090	!
	1091	!-- Check, if particle has moved to another grid cell.
	1092	IF ( i /= ip .OR. j /= jp .OR. k /= kp ) THEN
[2606]	1093	!!
	1094	!-- If the particle stays on the same processor, the particle
	1095	!-- will be added to the particle array of the new processor.
	1096	number_of_particles = prt_count(k,j,i)
	1097	particles => grid_particles(k,j,i)%particles(1:number_of_particles)
[1359]	1098
[2606]	1099	pindex = prt_count(k,j,i)+1
	1100	IF ( pindex > SIZE(grid_particles(k,j,i)%particles) ) &
	1101	THEN
	1102	CALL realloc_particles_array(i,j,k)
	1103	ENDIF
[1359]	1104
[2606]	1105	grid_particles(k,j,i)%particles(pindex) = particles_before_move(n)
	1106	prt_count(k,j,i) = pindex
[1359]	1107
[2606]	1108	particles_before_move(n)%particle_mask = .FALSE.
[1359]	1109	ENDIF
	1110	ENDDO
	1111
	1112	ENDDO
	1113	ENDDO
	1114	ENDDO
	1115
	1116	CALL cpu_log( log_point_s(41), 'lpm_move_particle', 'stop' )
	1117
	1118	RETURN
	1119
	1120	END SUBROUTINE lpm_move_particle
[2628]	1121
	1122	!------------------------------------------------------------------------------!
	1123	! Description:
	1124	! ------------
	1125	!> Check CFL-criterion for each particle. If one particle violated the
	1126	!> criterion the particle will be deleted and a warning message is given.
	1127	!------------------------------------------------------------------------------!
	1128	SUBROUTINE lpm_check_cfl
	1129
	1130	IMPLICIT NONE
	1131
	1132	INTEGER(iwp) :: i
	1133	INTEGER(iwp) :: j
	1134	INTEGER(iwp) :: k
	1135	INTEGER(iwp) :: n
	1136
	1137	DO i = nxl, nxr
	1138	DO j = nys, nyn
	1139	DO k = nzb+1, nzt
	1140	number_of_particles = prt_count(k,j,i)
	1141	IF ( number_of_particles <= 0 ) CYCLE
	1142	particles => grid_particles(k,j,i)%particles(1:number_of_particles)
	1143	DO n = 1, number_of_particles
	1144	IF(ABS(particles(n)%speed_x) > &
	1145	(dx/(particles(n)%age-particles(n)%age_m)) .OR. &
	1146	ABS(particles(n)%speed_y) > &
	1147	(dx/(particles(n)%age-particles(n)%age_m)) .OR. &
	1148	ABS(particles(n)%speed_z) > &
	1149	((zw(k)-zw(k-1))/(particles(n)%age-particles(n)%age_m))) THEN
[2632]	1150	WRITE( message_string, * ) &
	1151	'Particle violated CFL-criterion: particle with id ', &
	1152	particles(n)%id,' will be deleted!'
[2630]	1153	CALL message( 'lpm_check_cfl', 'PA0475', 0, 1, 0, 6, 0 )
[2628]	1154	particles(n)%particle_mask= .FALSE.
	1155	ENDIF
	1156	ENDDO
	1157	ENDDO
	1158	ENDDO
	1159	ENDDO
[1359]	1160
[2628]	1161	END SUBROUTINE lpm_check_cfl
	1162
[1682]	1163	!------------------------------------------------------------------------------!
	1164	! Description:
	1165	! ------------
[1929]	1166	!> If the allocated memory for the particle array do not suffice to add arriving
	1167	!> particles from neighbour grid cells, this subrouting reallocates the
	1168	!> particle array to assure enough memory is available.
[1682]	1169	!------------------------------------------------------------------------------!
[1359]	1170	SUBROUTINE realloc_particles_array (i,j,k,size_in)
	1171
	1172	IMPLICIT NONE
	1173
[1682]	1174	INTEGER(iwp), INTENT(in) :: i !<
	1175	INTEGER(iwp), INTENT(in) :: j !<
	1176	INTEGER(iwp), INTENT(in) :: k !<
[1822]	1177	INTEGER(iwp), INTENT(in), OPTIONAL :: size_in !<
[1359]	1178
[1682]	1179	INTEGER(iwp) :: old_size !<
	1180	INTEGER(iwp) :: new_size !<
	1181	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: tmp_particles_d !<
	1182	TYPE(particle_type), DIMENSION(500) :: tmp_particles_s !<
[1359]	1183
	1184	old_size = SIZE(grid_particles(k,j,i)%particles)
	1185
	1186	IF ( PRESENT(size_in) ) THEN
	1187	new_size = size_in
	1188	ELSE
[1822]	1189	new_size = old_size * ( 1.0_wp + alloc_factor / 100.0_wp )
[1359]	1190	ENDIF
	1191
[1929]	1192	new_size = MAX( new_size, min_nr_particle, old_size + 1 )
[1359]	1193
	1194	IF ( old_size <= 500 ) THEN
	1195
	1196	tmp_particles_s(1:old_size) = grid_particles(k,j,i)%particles(1:old_size)
	1197
	1198	DEALLOCATE(grid_particles(k,j,i)%particles)
	1199	ALLOCATE(grid_particles(k,j,i)%particles(new_size))
	1200
	1201	grid_particles(k,j,i)%particles(1:old_size) = tmp_particles_s(1:old_size)
	1202	grid_particles(k,j,i)%particles(old_size+1:new_size) = zero_particle
	1203
	1204	ELSE
	1205
	1206	ALLOCATE(tmp_particles_d(new_size))
	1207	tmp_particles_d(1:old_size) = grid_particles(k,j,i)%particles
	1208
	1209	DEALLOCATE(grid_particles(k,j,i)%particles)
	1210	ALLOCATE(grid_particles(k,j,i)%particles(new_size))
	1211
	1212	grid_particles(k,j,i)%particles(1:old_size) = tmp_particles_d(1:old_size)
	1213	grid_particles(k,j,i)%particles(old_size+1:new_size) = zero_particle
	1214
	1215	DEALLOCATE(tmp_particles_d)
	1216
	1217	ENDIF
	1218	particles => grid_particles(k,j,i)%particles(1:number_of_particles)
	1219
	1220	RETURN
	1221	END SUBROUTINE realloc_particles_array
	1222
[1936]	1223
	1224
	1225
	1226
	1227	SUBROUTINE dealloc_particles_array
	1228
	1229	IMPLICIT NONE
	1230
	1231	INTEGER(iwp) :: i
	1232	INTEGER(iwp) :: j
	1233	INTEGER(iwp) :: k
	1234	INTEGER(iwp) :: old_size !<
	1235	INTEGER(iwp) :: new_size !<
	1236
	1237	LOGICAL :: dealloc
	1238
	1239	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: tmp_particles_d !<
	1240	TYPE(particle_type), DIMENSION(500) :: tmp_particles_s !<
	1241
	1242	DO i = nxl, nxr
	1243	DO j = nys, nyn
	1244	DO k = nzb+1, nzt
	1245	!
	1246	!-- Determine number of active particles
	1247	number_of_particles = prt_count(k,j,i)
	1248	!
	1249	!-- Determine allocated memory size
	1250	old_size = SIZE( grid_particles(k,j,i)%particles )
	1251	!
	1252	!-- Check for large unused memory
	1253	dealloc = ( ( number_of_particles < min_nr_particle .AND. &
	1254	old_size > min_nr_particle ) .OR. &
	1255	( number_of_particles > min_nr_particle .AND. &
	1256	old_size - number_of_particles * &
	1257	( 1.0_wp + 0.01_wp * alloc_factor ) > 0.0_wp ) )
	1258
	1259
	1260	IF ( dealloc ) THEN
	1261	IF ( number_of_particles < min_nr_particle ) THEN
	1262	new_size = min_nr_particle
	1263	ELSE
	1264	new_size = INT( number_of_particles * ( 1.0_wp + 0.01_wp * alloc_factor ) )
	1265	ENDIF
	1266
	1267	IF ( number_of_particles <= 500 ) THEN
	1268
	1269	tmp_particles_s(1:number_of_particles) = grid_particles(k,j,i)%particles(1:number_of_particles)
	1270
	1271	DEALLOCATE(grid_particles(k,j,i)%particles)
	1272	ALLOCATE(grid_particles(k,j,i)%particles(new_size))
	1273
	1274	grid_particles(k,j,i)%particles(1:number_of_particles) = tmp_particles_s(1:number_of_particles)
	1275	grid_particles(k,j,i)%particles(number_of_particles+1:new_size) = zero_particle
	1276
	1277	ELSE
	1278
	1279	ALLOCATE(tmp_particles_d(number_of_particles))
	1280	tmp_particles_d(1:number_of_particles) = grid_particles(k,j,i)%particles(1:number_of_particles)
	1281
	1282	DEALLOCATE(grid_particles(k,j,i)%particles)
	1283	ALLOCATE(grid_particles(k,j,i)%particles(new_size))
	1284
	1285	grid_particles(k,j,i)%particles(1:number_of_particles) = tmp_particles_d(1:number_of_particles)
	1286	grid_particles(k,j,i)%particles(number_of_particles+1:new_size) = zero_particle
	1287
	1288	DEALLOCATE(tmp_particles_d)
	1289
	1290	ENDIF
	1291
	1292	ENDIF
	1293	ENDDO
	1294	ENDDO
	1295	ENDDO
	1296
	1297	END SUBROUTINE dealloc_particles_array
	1298
	1299
[1359]	1300	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 |