Home

Context Navigation

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

Last change on this file since 1932 was 1930, checked in by suehring, 9 years ago
last commit documented
Property svn:keywords set to `Id`
File size: 43.1 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	!
22	!
23	! Former revisions:
24	! -----------------
25	! $Id: lpm_exchange_horiz.f90 1930 2016-06-09 16:32:12Z 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
142	INTERFACE lpm_exchange_horiz
143	MODULE PROCEDURE lpm_exchange_horiz
144	END INTERFACE lpm_exchange_horiz
145
146	INTERFACE lpm_move_particle
147	MODULE PROCEDURE lpm_move_particle
148	END INTERFACE lpm_move_particle
149
150	INTERFACE realloc_particles_array
151	MODULE PROCEDURE realloc_particles_array
152	END INTERFACE realloc_particles_array
153
154	CONTAINS
155
156	!------------------------------------------------------------------------------!
157	! Description:
158	! ------------
159	!> Exchange between subdomains.
160	!> As soon as one particle has moved beyond the boundary of the domain, it
161	!> is included in the relevant transfer arrays and marked for subsequent
162	!> deletion on this PE.
163	!> First sweep for crossings in x direction. Find out first the number of
164	!> particles to be transferred and allocate temporary arrays needed to store
165	!> them.
166	!> For a one-dimensional decomposition along y, no transfer is necessary,
167	!> because the particle remains on the PE, but the particle coordinate has to
168	!> be adjusted.
169	!------------------------------------------------------------------------------!
170	SUBROUTINE lpm_exchange_horiz
171
172	IMPLICIT NONE
173
174	INTEGER(iwp) :: i !< grid index (x) of particle positition
175	INTEGER(iwp) :: ip !< index variable along x
176	INTEGER(iwp) :: j !< grid index (y) of particle positition
177	INTEGER(iwp) :: jp !< index variable along y
178	INTEGER(iwp) :: kp !< index variable along z
179	INTEGER(iwp) :: n !< particle index variable
180	INTEGER(iwp) :: trlp_count !< number of particles send to left PE
181	INTEGER(iwp) :: trlp_count_recv !< number of particles receive from right PE
182	INTEGER(iwp) :: trnp_count !< number of particles send to north PE
183	INTEGER(iwp) :: trnp_count_recv !< number of particles receive from south PE
184	INTEGER(iwp) :: trrp_count !< number of particles send to right PE
185	INTEGER(iwp) :: trrp_count_recv !< number of particles receive from left PE
186	INTEGER(iwp) :: trsp_count !< number of particles send to south PE
187	INTEGER(iwp) :: trsp_count_recv !< number of particles receive from north PE
188
189	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: rvlp !< particles received from right PE
190	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: rvnp !< particles received from south PE
191	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: rvrp !< particles received from left PE
192	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: rvsp !< particles received from north PE
193	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: trlp !< particles send to left PE
194	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: trnp !< particles send to north PE
195	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: trrp !< particles send to right PE
196	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: trsp !< particles send to south PE
197
198	CALL cpu_log( log_point_s(23), 'lpm_exchange_horiz', 'start' )
199
200	#if defined( __parallel )
201
202	!
203	!-- Exchange between subdomains.
204	!-- As soon as one particle has moved beyond the boundary of the domain, it
205	!-- is included in the relevant transfer arrays and marked for subsequent
206	!-- deletion on this PE.
207	!-- First sweep for crossings in x direction. Find out first the number of
208	!-- particles to be transferred and allocate temporary arrays needed to store
209	!-- them.
210	!-- For a one-dimensional decomposition along y, no transfer is necessary,
211	!-- because the particle remains on the PE, but the particle coordinate has to
212	!-- be adjusted.
213	trlp_count = 0
214	trrp_count = 0
215
216	trlp_count_recv = 0
217	trrp_count_recv = 0
218
219	IF ( pdims(1) /= 1 ) THEN
220	!
221	!-- First calculate the storage necessary for sending and receiving the data.
222	!-- Compute only first (nxl) and last (nxr) loop iterration.
223	DO ip = nxl, nxr, nxr - nxl
224	DO jp = nys, nyn
225	DO kp = nzb+1, nzt
226
227	number_of_particles = prt_count(kp,jp,ip)
228	IF ( number_of_particles <= 0 ) CYCLE
229	particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
230	DO n = 1, number_of_particles
231	IF ( particles(n)%particle_mask ) THEN
232	i = ( particles(n)%x + 0.5_wp * dx ) * ddx
233	!
234	!-- Above calculation does not work for indices less than zero
235	IF ( particles(n)%x < -0.5_wp * dx ) i = -1
236
237	IF ( i < nxl ) THEN
238	trlp_count = trlp_count + 1
239	ELSEIF ( i > nxr ) THEN
240	trrp_count = trrp_count + 1
241	ENDIF
242	ENDIF
243	ENDDO
244
245	ENDDO
246	ENDDO
247	ENDDO
248
249	IF ( trlp_count == 0 ) trlp_count = 1
250	IF ( trrp_count == 0 ) trrp_count = 1
251
252	ALLOCATE( trlp(trlp_count), trrp(trrp_count) )
253
254	trlp = zero_particle
255	trrp = zero_particle
256
257	trlp_count = 0
258	trrp_count = 0
259
260	ENDIF
261	!
262	!-- Compute only first (nxl) and last (nxr) loop iterration
263	DO ip = nxl, nxr, nxr-nxl
264	DO jp = nys, nyn
265	DO kp = nzb+1, nzt
266	number_of_particles = prt_count(kp,jp,ip)
267	IF ( number_of_particles <= 0 ) CYCLE
268	particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
269	DO n = 1, number_of_particles
270	!
271	!-- Only those particles that have not been marked as 'deleted' may
272	!-- be moved.
273	IF ( particles(n)%particle_mask ) THEN
274
275	i = ( particles(n)%x + 0.5_wp * dx ) * ddx
276	!
277	!-- Above calculation does not work for indices less than zero
278	IF ( particles(n)%x < - 0.5_wp * dx ) i = -1
279
280	IF ( i < nxl ) THEN
281	IF ( i < 0 ) THEN
282	!
283	!-- Apply boundary condition along x
284	IF ( ibc_par_lr == 0 ) THEN
285	!
286	!-- Cyclic condition
287	IF ( pdims(1) == 1 ) THEN
288	particles(n)%x = ( nx + 1 ) * dx + particles(n)%x
289	particles(n)%origin_x = ( nx + 1 ) * dx + &
290	particles(n)%origin_x
291	ELSE
292	trlp_count = trlp_count + 1
293	trlp(trlp_count) = particles(n)
294	trlp(trlp_count)%x = ( nx + 1 ) * dx + trlp(trlp_count)%x
295	trlp(trlp_count)%origin_x = trlp(trlp_count)%origin_x + &
296	( nx + 1 ) * dx
297	particles(n)%particle_mask = .FALSE.
298	deleted_particles = deleted_particles + 1
299
300	IF ( trlp(trlp_count)%x >= (nx + 0.5_wp)* dx - 1.0E-12_wp ) THEN
301	trlp(trlp_count)%x = trlp(trlp_count)%x - 1.0E-10_wp
302	!++ why is 1 subtracted in next statement???
303	trlp(trlp_count)%origin_x = trlp(trlp_count)%origin_x - 1
304	ENDIF
305
306	ENDIF
307
308	ELSEIF ( ibc_par_lr == 1 ) THEN
309	!
310	!-- Particle absorption
311	particles(n)%particle_mask = .FALSE.
312	deleted_particles = deleted_particles + 1
313
314	ELSEIF ( ibc_par_lr == 2 ) THEN
315	!
316	!-- Particle reflection
317	particles(n)%x = -particles(n)%x
318	particles(n)%speed_x = -particles(n)%speed_x
319
320	ENDIF
321	ELSE
322	!
323	!-- Store particle data in the transfer array, which will be
324	!-- send to the neighbouring PE
325	trlp_count = trlp_count + 1
326	trlp(trlp_count) = particles(n)
327	particles(n)%particle_mask = .FALSE.
328	deleted_particles = deleted_particles + 1
329
330	ENDIF
331
332	ELSEIF ( i > nxr ) THEN
333	IF ( i > nx ) THEN
334	!
335	!-- Apply boundary condition along x
336	IF ( ibc_par_lr == 0 ) THEN
337	!
338	!-- Cyclic condition
339	IF ( pdims(1) == 1 ) THEN
340	particles(n)%x = particles(n)%x - ( nx + 1 ) * dx
341	particles(n)%origin_x = particles(n)%origin_x - &
342	( nx + 1 ) * dx
343	ELSE
344	trrp_count = trrp_count + 1
345	trrp(trrp_count) = particles(n)
346	trrp(trrp_count)%x = trrp(trrp_count)%x - ( nx + 1 ) * dx
347	trrp(trrp_count)%origin_x = trrp(trrp_count)%origin_x - &
348	( nx + 1 ) * dx
349	particles(n)%particle_mask = .FALSE.
350	deleted_particles = deleted_particles + 1
351
352	ENDIF
353
354	ELSEIF ( ibc_par_lr == 1 ) THEN
355	!
356	!-- Particle absorption
357	particles(n)%particle_mask = .FALSE.
358	deleted_particles = deleted_particles + 1
359
360	ELSEIF ( ibc_par_lr == 2 ) THEN
361	!
362	!-- Particle reflection
363	particles(n)%x = 2 * ( nx * dx ) - particles(n)%x
364	particles(n)%speed_x = -particles(n)%speed_x
365
366	ENDIF
367	ELSE
368	!
369	!-- Store particle data in the transfer array, which will be send
370	!-- to the neighbouring PE
371	trrp_count = trrp_count + 1
372	trrp(trrp_count) = particles(n)
373	particles(n)%particle_mask = .FALSE.
374	deleted_particles = deleted_particles + 1
375
376	ENDIF
377
378	ENDIF
379	ENDIF
380
381	ENDDO
382	ENDDO
383	ENDDO
384	ENDDO
385
386	!
387	!-- Allocate arrays required for north-south exchange, as these
388	!-- are used directly after particles are exchange along x-direction.
389	ALLOCATE( move_also_north(1:NR_2_direction_move) )
390	ALLOCATE( move_also_south(1:NR_2_direction_move) )
391
392	nr_move_north = 0
393	nr_move_south = 0
394	!
395	!-- Send left boundary, receive right boundary (but first exchange how many
396	!-- and check, if particle storage must be extended)
397	IF ( pdims(1) /= 1 ) THEN
398
399	CALL MPI_SENDRECV( trlp_count, 1, MPI_INTEGER, pleft, 0, &
400	trrp_count_recv, 1, MPI_INTEGER, pright, 0, &
401	comm2d, status, ierr )
402
403	ALLOCATE(rvrp(MAX(1,trrp_count_recv)))
404
405	CALL MPI_SENDRECV( trlp(1)%radius, max(1,trlp_count), mpi_particle_type,&
406	pleft, 1, rvrp(1)%radius, &
407	max(1,trrp_count_recv), mpi_particle_type, pright, 1,&
408	comm2d, status, ierr )
409
410	IF ( trrp_count_recv > 0 ) CALL Add_particles_to_gridcell(rvrp(1:trrp_count_recv))
411
412	DEALLOCATE(rvrp)
413
414	!
415	!-- Send right boundary, receive left boundary
416	CALL MPI_SENDRECV( trrp_count, 1, MPI_INTEGER, pright, 0, &
417	trlp_count_recv, 1, MPI_INTEGER, pleft, 0, &
418	comm2d, status, ierr )
419
420	ALLOCATE(rvlp(MAX(1,trlp_count_recv)))
421
422	CALL MPI_SENDRECV( trrp(1)%radius, max(1,trrp_count), mpi_particle_type,&
423	pright, 1, rvlp(1)%radius, &
424	max(1,trlp_count_recv), mpi_particle_type, pleft, 1, &
425	comm2d, status, ierr )
426
427	IF ( trlp_count_recv > 0 ) CALL Add_particles_to_gridcell(rvlp(1:trlp_count_recv))
428
429	DEALLOCATE( rvlp )
430	DEALLOCATE( trlp, trrp )
431
432	ENDIF
433
434	!
435	!-- Check whether particles have crossed the boundaries in y direction. Note
436	!-- that this case can also apply to particles that have just been received
437	!-- from the adjacent right or left PE.
438	!-- Find out first the number of particles to be transferred and allocate
439	!-- temporary arrays needed to store them.
440	!-- For a one-dimensional decomposition along y, no transfer is necessary,
441	!-- because the particle remains on the PE.
442	trsp_count = nr_move_south
443	trnp_count = nr_move_north
444
445	trsp_count_recv = 0
446	trnp_count_recv = 0
447
448	IF ( pdims(2) /= 1 ) THEN
449	!
450	!-- First calculate the storage necessary for sending and receiving the
451	!-- data
452	DO ip = nxl, nxr
453	DO jp = nys, nyn, nyn-nys !compute only first (nys) and last (nyn) loop iterration
454	DO kp = nzb+1, nzt
455	number_of_particles = prt_count(kp,jp,ip)
456	IF ( number_of_particles <= 0 ) CYCLE
457	particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
458	DO n = 1, number_of_particles
459	IF ( particles(n)%particle_mask ) THEN
460	j = ( particles(n)%y + 0.5_wp * dy ) * ddy
461	!
462	!-- Above calculation does not work for indices less than zero
463	IF ( particles(n)%y < -0.5_wp * dy ) j = -1
464
465	IF ( j < nys ) THEN
466	trsp_count = trsp_count + 1
467	ELSEIF ( j > nyn ) THEN
468	trnp_count = trnp_count + 1
469	ENDIF
470	ENDIF
471	ENDDO
472	ENDDO
473	ENDDO
474	ENDDO
475
476	IF ( trsp_count == 0 ) trsp_count = 1
477	IF ( trnp_count == 0 ) trnp_count = 1
478
479	ALLOCATE( trsp(trsp_count), trnp(trnp_count) )
480
481	trsp = zero_particle
482	trnp = zero_particle
483
484	trsp_count = nr_move_south
485	trnp_count = nr_move_north
486
487	trsp(1:nr_move_south) = move_also_south(1:nr_move_south)
488	trnp(1:nr_move_north) = move_also_north(1:nr_move_north)
489
490	ENDIF
491
492	DO ip = nxl, nxr
493	DO jp = nys, nyn, nyn-nys ! compute only first (nys) and last (nyn) loop iterration
494	DO kp = nzb+1, nzt
495	number_of_particles = prt_count(kp,jp,ip)
496	IF ( number_of_particles <= 0 ) CYCLE
497	particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
498	DO n = 1, number_of_particles
499	!
500	!-- Only those particles that have not been marked as 'deleted' may
501	!-- be moved.
502	IF ( particles(n)%particle_mask ) THEN
503
504	j = ( particles(n)%y + 0.5_wp * dy ) * ddy
505	!
506	!-- Above calculation does not work for indices less than zero
507	IF ( particles(n)%y < -0.5_wp * dy ) j = -1
508
509	IF ( j < nys ) THEN
510	IF ( j < 0 ) THEN
511	!
512	!-- Apply boundary condition along y
513	IF ( ibc_par_ns == 0 ) THEN
514	!
515	!-- Cyclic condition
516	IF ( pdims(2) == 1 ) THEN
517	particles(n)%y = ( ny + 1 ) * dy + particles(n)%y
518	particles(n)%origin_y = ( ny + 1 ) * dy + &
519	particles(n)%origin_y
520	ELSE
521	trsp_count = trsp_count + 1
522	trsp(trsp_count) = particles(n)
523	trsp(trsp_count)%y = ( ny + 1 ) * dy + &
524	trsp(trsp_count)%y
525	trsp(trsp_count)%origin_y = trsp(trsp_count)%origin_y &
526	+ ( ny + 1 ) * dy
527	particles(n)%particle_mask = .FALSE.
528	deleted_particles = deleted_particles + 1
529
530	IF ( trsp(trsp_count)%y >= (ny+0.5_wp)* dy - 1.0E-12_wp ) THEN
531	trsp(trsp_count)%y = trsp(trsp_count)%y - 1.0E-10_wp
532	!++ why is 1 subtracted in next statement???
533	trsp(trsp_count)%origin_y = &
534	trsp(trsp_count)%origin_y - 1
535	ENDIF
536
537	ENDIF
538
539	ELSEIF ( ibc_par_ns == 1 ) THEN
540	!
541	!-- Particle absorption
542	particles(n)%particle_mask = .FALSE.
543	deleted_particles = deleted_particles + 1
544
545	ELSEIF ( ibc_par_ns == 2 ) THEN
546	!
547	!-- Particle reflection
548	particles(n)%y = -particles(n)%y
549	particles(n)%speed_y = -particles(n)%speed_y
550
551	ENDIF
552	ELSE
553	!
554	!-- Store particle data in the transfer array, which will
555	!-- be send to the neighbouring PE
556	trsp_count = trsp_count + 1
557	trsp(trsp_count) = particles(n)
558	particles(n)%particle_mask = .FALSE.
559	deleted_particles = deleted_particles + 1
560
561	ENDIF
562
563	ELSEIF ( j > nyn ) THEN
564	IF ( j > ny ) THEN
565	!
566	!-- Apply boundary condition along y
567	IF ( ibc_par_ns == 0 ) THEN
568	!
569	!-- Cyclic condition
570	IF ( pdims(2) == 1 ) THEN
571	particles(n)%y = particles(n)%y - ( ny + 1 ) * dy
572	particles(n)%origin_y = &
573	particles(n)%origin_y - ( ny + 1 ) * dy
574	ELSE
575	trnp_count = trnp_count + 1
576	trnp(trnp_count) = particles(n)
577	trnp(trnp_count)%y = &
578	trnp(trnp_count)%y - ( ny + 1 ) * dy
579	trnp(trnp_count)%origin_y = &
580	trnp(trnp_count)%origin_y - ( ny + 1 ) * dy
581	particles(n)%particle_mask = .FALSE.
582	deleted_particles = deleted_particles + 1
583	ENDIF
584
585	ELSEIF ( ibc_par_ns == 1 ) THEN
586	!
587	!-- Particle absorption
588	particles(n)%particle_mask = .FALSE.
589	deleted_particles = deleted_particles + 1
590
591	ELSEIF ( ibc_par_ns == 2 ) THEN
592	!
593	!-- Particle reflection
594	particles(n)%y = 2 * ( ny * dy ) - particles(n)%y
595	particles(n)%speed_y = -particles(n)%speed_y
596
597	ENDIF
598	ELSE
599	!
600	!-- Store particle data in the transfer array, which will
601	!-- be send to the neighbouring PE
602	trnp_count = trnp_count + 1
603	trnp(trnp_count) = particles(n)
604	particles(n)%particle_mask = .FALSE.
605	deleted_particles = deleted_particles + 1
606
607	ENDIF
608
609	ENDIF
610	ENDIF
611	ENDDO
612	ENDDO
613	ENDDO
614	ENDDO
615
616	!
617	!-- Send front boundary, receive back boundary (but first exchange how many
618	!-- and check, if particle storage must be extended)
619	IF ( pdims(2) /= 1 ) THEN
620
621	CALL MPI_SENDRECV( trsp_count, 1, MPI_INTEGER, psouth, 0, &
622	trnp_count_recv, 1, MPI_INTEGER, pnorth, 0, &
623	comm2d, status, ierr )
624
625	ALLOCATE(rvnp(MAX(1,trnp_count_recv)))
626
627	CALL MPI_SENDRECV( trsp(1)%radius, trsp_count, mpi_particle_type, &
628	psouth, 1, rvnp(1)%radius, &
629	trnp_count_recv, mpi_particle_type, pnorth, 1, &
630	comm2d, status, ierr )
631
632	IF ( trnp_count_recv > 0 ) CALL Add_particles_to_gridcell(rvnp(1:trnp_count_recv))
633
634	DEALLOCATE(rvnp)
635
636	!
637	!-- Send back boundary, receive front boundary
638	CALL MPI_SENDRECV( trnp_count, 1, MPI_INTEGER, pnorth, 0, &
639	trsp_count_recv, 1, MPI_INTEGER, psouth, 0, &
640	comm2d, status, ierr )
641
642	ALLOCATE(rvsp(MAX(1,trsp_count_recv)))
643
644	CALL MPI_SENDRECV( trnp(1)%radius, trnp_count, mpi_particle_type, &
645	pnorth, 1, rvsp(1)%radius, &
646	trsp_count_recv, mpi_particle_type, psouth, 1, &
647	comm2d, status, ierr )
648
649	IF ( trsp_count_recv > 0 ) CALL Add_particles_to_gridcell(rvsp(1:trsp_count_recv))
650
651	DEALLOCATE(rvsp)
652
653	number_of_particles = number_of_particles + trsp_count_recv
654
655	DEALLOCATE( trsp, trnp )
656
657	ENDIF
658
659	DEALLOCATE( move_also_north )
660	DEALLOCATE( move_also_south )
661
662	#else
663
664	DO ip = nxl, nxr, nxr-nxl
665	DO jp = nys, nyn
666	DO kp = nzb+1, nzt
667	number_of_particles = prt_count(kp,jp,ip)
668	IF ( number_of_particles <= 0 ) CYCLE
669	particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
670	DO n = 1, number_of_particles
671	!
672	!-- Apply boundary conditions
673
674	IF ( particles(n)%x < -0.5_wp * dx ) THEN
675
676	IF ( ibc_par_lr == 0 ) THEN
677	!
678	!-- Cyclic boundary. Relevant coordinate has to be changed.
679	particles(n)%x = ( nx + 1 ) * dx + particles(n)%x
680
681	ELSEIF ( ibc_par_lr == 1 ) THEN
682	!
683	!-- Particle absorption
684	particles(n)%particle_mask = .FALSE.
685	deleted_particles = deleted_particles + 1
686
687	ELSEIF ( ibc_par_lr == 2 ) THEN
688	!
689	!-- Particle reflection
690	particles(n)%x = -dx - particles(n)%x
691	particles(n)%speed_x = -particles(n)%speed_x
692	ENDIF
693
694	ELSEIF ( particles(n)%x >= ( nx + 0.5_wp ) * dx ) THEN
695
696	IF ( ibc_par_lr == 0 ) THEN
697	!
698	!-- Cyclic boundary. Relevant coordinate has to be changed.
699	particles(n)%x = particles(n)%x - ( nx + 1 ) * dx
700
701	ELSEIF ( ibc_par_lr == 1 ) THEN
702	!
703	!-- Particle absorption
704	particles(n)%particle_mask = .FALSE.
705	deleted_particles = deleted_particles + 1
706
707	ELSEIF ( ibc_par_lr == 2 ) THEN
708	!
709	!-- Particle reflection
710	particles(n)%x = ( nx + 1 ) * dx - particles(n)%x
711	particles(n)%speed_x = -particles(n)%speed_x
712	ENDIF
713
714	ENDIF
715	ENDDO
716	ENDDO
717	ENDDO
718	ENDDO
719
720	DO ip = nxl, nxr
721	DO jp = nys, nyn, nyn-nys
722	DO kp = nzb+1, nzt
723	number_of_particles = prt_count(kp,jp,ip)
724	IF ( number_of_particles <= 0 ) CYCLE
725	particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
726	DO n = 1, number_of_particles
727
728	IF ( particles(n)%y < -0.5_wp * dy ) THEN
729
730	IF ( ibc_par_ns == 0 ) THEN
731	!
732	!-- Cyclic boundary. Relevant coordinate has to be changed.
733	particles(n)%y = ( ny + 1 ) * dy + particles(n)%y
734
735	ELSEIF ( ibc_par_ns == 1 ) THEN
736	!
737	!-- Particle absorption
738	particles(n)%particle_mask = .FALSE.
739	deleted_particles = deleted_particles + 1
740
741	ELSEIF ( ibc_par_ns == 2 ) THEN
742	!
743	!-- Particle reflection
744	particles(n)%y = -dy - particles(n)%y
745	particles(n)%speed_y = -particles(n)%speed_y
746	ENDIF
747
748	ELSEIF ( particles(n)%y >= ( ny + 0.5_wp ) * dy ) THEN
749
750	IF ( ibc_par_ns == 0 ) THEN
751	!
752	!-- Cyclic boundary. Relevant coordinate has to be changed.
753	particles(n)%y = particles(n)%y - ( ny + 1 ) * dy
754
755	ELSEIF ( ibc_par_ns == 1 ) THEN
756	!
757	!-- Particle absorption
758	particles(n)%particle_mask = .FALSE.
759	deleted_particles = deleted_particles + 1
760
761	ELSEIF ( ibc_par_ns == 2 ) THEN
762	!
763	!-- Particle reflection
764	particles(n)%y = ( ny + 1 ) * dy - particles(n)%y
765	particles(n)%speed_y = -particles(n)%speed_y
766	ENDIF
767
768	ENDIF
769
770	ENDDO
771	ENDDO
772	ENDDO
773	ENDDO
774	#endif
775
776	!
777	!-- Accumulate the number of particles transferred between the subdomains
778	#if defined( __parallel )
779	trlp_count_sum = trlp_count_sum + trlp_count
780	trlp_count_recv_sum = trlp_count_recv_sum + trlp_count_recv
781	trrp_count_sum = trrp_count_sum + trrp_count
782	trrp_count_recv_sum = trrp_count_recv_sum + trrp_count_recv
783	trsp_count_sum = trsp_count_sum + trsp_count
784	trsp_count_recv_sum = trsp_count_recv_sum + trsp_count_recv
785	trnp_count_sum = trnp_count_sum + trnp_count
786	trnp_count_recv_sum = trnp_count_recv_sum + trnp_count_recv
787	#endif
788
789	CALL cpu_log( log_point_s(23), 'lpm_exchange_horiz', 'stop' )
790
791	END SUBROUTINE lpm_exchange_horiz
792
793	!------------------------------------------------------------------------------!
794	! Description:
795	! ------------
796	!> If a particle moves from one processor to another, this subroutine moves
797	!> the corresponding elements from the particle arrays of the old grid cells
798	!> to the particle arrays of the new grid cells.
799	!------------------------------------------------------------------------------!
800	SUBROUTINE Add_particles_to_gridcell (particle_array)
801
802	IMPLICIT NONE
803
804	INTEGER(iwp) :: ip !< grid index (x) of particle
805	INTEGER(iwp) :: jp !< grid index (x) of particle
806	INTEGER(iwp) :: kp !< grid index (x) of particle
807	INTEGER(iwp) :: n !< index variable of particle
808	INTEGER(iwp) :: pindex !< dummy argument for new number of particles per grid box
809
810	LOGICAL :: pack_done !<
811
812	TYPE(particle_type), DIMENSION(:), INTENT(IN) :: particle_array !< new particles in a grid box
813	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: temp_ns !< temporary particle array for reallocation
814
815	pack_done = .FALSE.
816
817	DO n = 1, SIZE(particle_array)
818
819	IF ( .NOT. particle_array(n)%particle_mask ) CYCLE
820
821	ip = ( particle_array(n)%x + 0.5_wp * dx ) * ddx
822	jp = ( particle_array(n)%y + 0.5_wp * dy ) * ddy
823	kp = particle_array(n)%z / dz + 1 + offset_ocean_nzt
824
825	IF ( ip >= nxl .AND. ip <= nxr .AND. jp >= nys .AND. jp <= nyn &
826	.AND. kp >= nzb+1 .AND. kp <= nzt) THEN ! particle stays on processor
827	number_of_particles = prt_count(kp,jp,ip)
828	particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
829
830	pindex = prt_count(kp,jp,ip)+1
831	IF( pindex > SIZE(grid_particles(kp,jp,ip)%particles) ) THEN
832	IF ( pack_done ) THEN
833	CALL realloc_particles_array (ip,jp,kp)
834	ELSE
835	CALL lpm_pack_arrays
836	prt_count(kp,jp,ip) = number_of_particles
837	pindex = prt_count(kp,jp,ip)+1
838	IF ( pindex > SIZE(grid_particles(kp,jp,ip)%particles) ) THEN
839	CALL realloc_particles_array (ip,jp,kp)
840	ENDIF
841	pack_done = .TRUE.
842	ENDIF
843	ENDIF
844	grid_particles(kp,jp,ip)%particles(pindex) = particle_array(n)
845	prt_count(kp,jp,ip) = pindex
846	ELSE
847	IF ( jp <= nys - 1 ) THEN
848	nr_move_south = nr_move_south+1
849	!
850	!-- Before particle information is swapped to exchange-array, check
851	!-- if enough memory is allocated. If required, reallocate exchange
852	!-- array.
853	IF ( nr_move_south > SIZE(move_also_south) ) THEN
854	!
855	!-- At first, allocate further temporary array to swap particle
856	!-- information.
857	ALLOCATE( temp_ns(SIZE(move_also_south)+NR_2_direction_move) )
858	temp_ns(1:nr_move_south-1) = move_also_south(1:nr_move_south-1)
859	DEALLOCATE( move_also_south )
860	ALLOCATE( move_also_south(SIZE(temp_ns)) )
861	move_also_south(1:nr_move_south-1) = temp_ns(1:nr_move_south-1)
862	DEALLOCATE( temp_ns )
863
864	ENDIF
865
866	move_also_south(nr_move_south) = particle_array(n)
867
868	IF ( jp == -1 ) THEN
869	move_also_south(nr_move_south)%y = &
870	move_also_south(nr_move_south)%y + ( ny + 1 ) * dy
871	move_also_south(nr_move_south)%origin_y = &
872	move_also_south(nr_move_south)%origin_y + ( ny + 1 ) * dy
873	ENDIF
874	ELSEIF ( jp >= nyn+1 ) THEN
875	nr_move_north = nr_move_north+1
876	!
877	!-- Before particle information is swapped to exchange-array, check
878	!-- if enough memory is allocated. If required, reallocate exchange
879	!-- array.
880	IF ( nr_move_north > SIZE(move_also_north) ) THEN
881	!
882	!-- At first, allocate further temporary array to swap particle
883	!-- information.
884	ALLOCATE( temp_ns(SIZE(move_also_north)+NR_2_direction_move) )
885	temp_ns(1:nr_move_north-1) = move_also_south(1:nr_move_north-1)
886	DEALLOCATE( move_also_north )
887	ALLOCATE( move_also_north(SIZE(temp_ns)) )
888	move_also_north(1:nr_move_north-1) = temp_ns(1:nr_move_north-1)
889	DEALLOCATE( temp_ns )
890
891	ENDIF
892
893	move_also_north(nr_move_north) = particle_array(n)
894	IF ( jp == ny+1 ) THEN
895	move_also_north(nr_move_north)%y = &
896	move_also_north(nr_move_north)%y - ( ny + 1 ) * dy
897	move_also_north(nr_move_north)%origin_y = &
898	move_also_north(nr_move_north)%origin_y - ( ny + 1 ) * dy
899	ENDIF
900	ELSE
901	WRITE(0,'(a,8i7)') 'particle out of range ',myid,ip,jp,kp,nxl,nxr,nys,nyn
902	ENDIF
903	ENDIF
904	ENDDO
905
906	RETURN
907
908	END SUBROUTINE Add_particles_to_gridcell
909
910
911
912
913	!------------------------------------------------------------------------------!
914	! Description:
915	! ------------
916	!> If a particle moves from one grid cell to another (on the current
917	!> processor!), this subroutine moves the corresponding element from the
918	!> particle array of the old grid cell to the particle array of the new grid
919	!> cell.
920	!------------------------------------------------------------------------------!
921	SUBROUTINE lpm_move_particle
922
923	IMPLICIT NONE
924
925	INTEGER(iwp) :: i !< grid index (x) of particle position
926	INTEGER(iwp) :: ip !< index variable along x
927	INTEGER(iwp) :: j !< grid index (y) of particle position
928	INTEGER(iwp) :: jp !< index variable along y
929	INTEGER(iwp) :: k !< grid index (z) of particle position
930	INTEGER(iwp) :: kp !< index variable along z
931	INTEGER(iwp) :: n !< index variable for particle array
932	INTEGER(iwp) :: np_old_cell !< number of particles per grid box before moving
933	INTEGER(iwp) :: n_start !< start index
934	INTEGER(iwp) :: pindex !< dummy argument for number of new particle per grid box
935
936	LOGICAL :: pack_done !<
937
938	TYPE(particle_type), DIMENSION(:), POINTER :: particles_old_cell !< particles before moving
939
940	CALL cpu_log( log_point_s(41), 'lpm_move_particle', 'start' )
941
942	DO ip = nxl, nxr
943	DO jp = nys, nyn
944	DO kp = nzb+1, nzt
945
946	np_old_cell = prt_count(kp,jp,ip)
947	IF ( np_old_cell <= 0 ) CYCLE
948	particles_old_cell => grid_particles(kp,jp,ip)%particles(1:np_old_cell)
949	n_start = -1
950
951	DO n = 1, np_old_cell
952	i = ( particles_old_cell(n)%x + 0.5_wp * dx ) * ddx
953	j = ( particles_old_cell(n)%y + 0.5_wp * dy ) * ddy
954	k = particles_old_cell(n)%z / dz + 1 + offset_ocean_nzt
955	!
956	!-- Check, if particle has moved to another grid cell.
957	IF ( i /= ip .OR. j /= jp .OR. k /= kp ) THEN
958	!
959	!-- The particle has moved to another grid cell. Now check, if
960	!-- particle stays on the same processor.
961	IF ( i >= nxl .AND. i <= nxr .AND. j >= nys .AND. &
962	j <= nyn .AND. k >= nzb+1 .AND. k <= nzt) THEN
963	!
964	!-- If the particle stays on the same processor, the particle
965	!-- will be added to the particle array of the new processor.
966	number_of_particles = prt_count(k,j,i)
967	particles => grid_particles(k,j,i)%particles(1:number_of_particles)
968
969	pindex = prt_count(k,j,i)+1
970	IF ( pindex > SIZE(grid_particles(k,j,i)%particles) ) &
971	THEN
972	n_start = n
973	EXIT
974	ENDIF
975
976	grid_particles(k,j,i)%particles(pindex) = particles_old_cell(n)
977	prt_count(k,j,i) = pindex
978
979	particles_old_cell(n)%particle_mask = .FALSE.
980	ENDIF
981	ENDIF
982	ENDDO
983
984	IF ( n_start >= 0 ) THEN
985	pack_done = .FALSE.
986	DO n = n_start, np_old_cell
987	i = ( particles_old_cell(n)%x + 0.5_wp * dx ) * ddx
988	j = ( particles_old_cell(n)%y + 0.5_wp * dy ) * ddy
989	k = particles_old_cell(n)%z / dz + 1 + offset_ocean_nzt
990	IF ( i /= ip .OR. j /= jp .OR. k /= kp ) THEN
991	!
992	!-- Particle is in different box
993	IF ( i >= nxl .AND. i <= nxr .AND. j >= nys .AND. &
994	j <= nyn .AND. k >= nzb+1 .AND. k <= nzt) THEN
995	!
996	!-- Particle stays on processor
997	number_of_particles = prt_count(k,j,i)
998	particles => grid_particles(k,j,i)%particles(1:number_of_particles)
999
1000	pindex = prt_count(k,j,i)+1
1001	IF ( pindex > SIZE(grid_particles(k,j,i)%particles) ) &
1002	THEN
1003	IF ( pack_done ) THEN
1004	CALL realloc_particles_array(i,j,k)
1005	ELSE
1006	CALL lpm_pack_arrays
1007	prt_count(k,j,i) = number_of_particles
1008	!
1009	!-- If number of particles in the new grid box
1010	!-- exceeds its allocated memory, the particle array
1011	!-- will be reallocated
1012	IF ( pindex > SIZE(grid_particles(k,j,i)%particles) ) THEN
1013	CALL realloc_particles_array(i,j,k)
1014	ENDIF
1015
1016	pack_done = .TRUE.
1017	ENDIF
1018	ENDIF
1019
1020	grid_particles(k,j,i)%particles(pindex) = particles_old_cell(n)
1021	prt_count(k,j,i) = pindex
1022
1023	particles_old_cell(n)%particle_mask = .FALSE.
1024	ENDIF
1025	ENDIF
1026	ENDDO
1027	ENDIF
1028	ENDDO
1029	ENDDO
1030	ENDDO
1031
1032	CALL cpu_log( log_point_s(41), 'lpm_move_particle', 'stop' )
1033
1034	RETURN
1035
1036	END SUBROUTINE lpm_move_particle
1037
1038	!------------------------------------------------------------------------------!
1039	! Description:
1040	! ------------
1041	!> If the allocated memory for the particle array do not suffice to add arriving
1042	!> particles from neighbour grid cells, this subrouting reallocates the
1043	!> particle array to assure enough memory is available.
1044	!------------------------------------------------------------------------------!
1045	SUBROUTINE realloc_particles_array (i,j,k,size_in)
1046
1047	IMPLICIT NONE
1048
1049	INTEGER(iwp), INTENT(in) :: i !<
1050	INTEGER(iwp), INTENT(in) :: j !<
1051	INTEGER(iwp), INTENT(in) :: k !<
1052	INTEGER(iwp), INTENT(in), OPTIONAL :: size_in !<
1053
1054	INTEGER(iwp) :: old_size !<
1055	INTEGER(iwp) :: new_size !<
1056	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: tmp_particles_d !<
1057	TYPE(particle_type), DIMENSION(500) :: tmp_particles_s !<
1058
1059
1060	old_size = SIZE(grid_particles(k,j,i)%particles)
1061
1062	IF ( PRESENT(size_in) ) THEN
1063	new_size = size_in
1064	ELSE
1065	new_size = old_size * ( 1.0_wp + alloc_factor / 100.0_wp )
1066	ENDIF
1067
1068	new_size = MAX( new_size, min_nr_particle, old_size + 1 )
1069
1070	IF ( old_size <= 500 ) THEN
1071
1072	tmp_particles_s(1:old_size) = grid_particles(k,j,i)%particles(1:old_size)
1073
1074	DEALLOCATE(grid_particles(k,j,i)%particles)
1075	ALLOCATE(grid_particles(k,j,i)%particles(new_size))
1076
1077	grid_particles(k,j,i)%particles(1:old_size) = tmp_particles_s(1:old_size)
1078	grid_particles(k,j,i)%particles(old_size+1:new_size) = zero_particle
1079
1080	ELSE
1081
1082	ALLOCATE(tmp_particles_d(new_size))
1083	tmp_particles_d(1:old_size) = grid_particles(k,j,i)%particles
1084
1085	DEALLOCATE(grid_particles(k,j,i)%particles)
1086	ALLOCATE(grid_particles(k,j,i)%particles(new_size))
1087
1088	grid_particles(k,j,i)%particles(1:old_size) = tmp_particles_d(1:old_size)
1089	grid_particles(k,j,i)%particles(old_size+1:new_size) = zero_particle
1090
1091	DEALLOCATE(tmp_particles_d)
1092
1093	ENDIF
1094	particles => grid_particles(k,j,i)%particles(1:number_of_particles)
1095
1096	RETURN
1097	END SUBROUTINE realloc_particles_array
1098
1099	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 |