Home

Context Navigation

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

Last change on this file since 3997 was 3655, checked in by knoop, 6 years ago
Bugfix: made "unit" and "found" intend INOUT in module interface subroutines + automatic copyright update
Property svn:keywords set to `Id`
File size: 51.4 KB

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