Home

Context Navigation

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

Last change on this file since 2788 was 2718, checked in by maronga, 7 years ago
deleting of deprecated files; headers updated where needed
Property svn:keywords set to `Id`
File size: 51.6 KB

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