Home

Context Navigation

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

Last change on this file since 1936 was 1936, checked in by suehring, 8 years ago
deallocation of unused particle memory, formatting adjustments
Property svn:keywords set to `Id`
File size: 46.0 KB

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