Home

Context Navigation

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

Last change on this file since 1302 was 1037, checked in by raasch, 12 years ago
last commit documented
Property svn:keywords set to `Id`
File size: 36.7 KB

Line
1	SUBROUTINE lpm_exchange_horiz
2
3	!--------------------------------------------------------------------------------!
4	! This file is part of PALM.
5	!
6	! PALM is free software: you can redistribute it and/or modify it under the terms
7	! of the GNU General Public License as published by the Free Software Foundation,
8	! either version 3 of the License, or (at your option) any later 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-2012 Leibniz University Hannover
18	!--------------------------------------------------------------------------------!
19	!
20	! Current revisions:
21	! ------------------
22	!
23	!
24	! Former revisions:
25	! -----------------
26	! $Id: lpm_exchange_horiz.f90 1037 2012-10-22 14:10:22Z heinze $
27	!
28	! 1036 2012-10-22 13:43:42Z raasch
29	! code put under GPL (PALM 3.9)
30	!
31	! 851 2012-03-15 14:32:58Z raasch
32	! Bugfix: resetting of particle_mask and tail mask moved from end of this
33	! routine to lpm
34	!
35	! 849 2012-03-15 10:35:09Z raasch
36	! initial revision (former part of advec_particles)
37	!
38	!
39	! Description:
40	! ------------
41	! Exchange of particles (and tails) between the subdomains.
42	!------------------------------------------------------------------------------!
43
44	USE control_parameters
45	USE cpulog
46	USE grid_variables
47	USE indices
48	USE interfaces
49	USE particle_attributes
50	USE pegrid
51
52	IMPLICIT NONE
53
54	INTEGER :: i, j, n, nn, tlength, &
55	trlp_count, trlp_count_recv, trlpt_count, trlpt_count_recv, &
56	trnp_count, trnp_count_recv, trnpt_count, trnpt_count_recv, &
57	trrp_count, trrp_count_recv, trrpt_count, trrpt_count_recv, &
58	trsp_count, trsp_count_recv, trspt_count, trspt_count_recv
59
60	REAL, DIMENSION(:,:,:), ALLOCATABLE :: trlpt, trnpt, trrpt, trspt
61
62	TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: trlp, trnp, trrp, trsp
63
64
65	#if defined( __parallel )
66
67	!
68	!-- Exchange between subdomains.
69	!-- As soon as one particle has moved beyond the boundary of the domain, it
70	!-- is included in the relevant transfer arrays and marked for subsequent
71	!-- deletion on this PE.
72	!-- First sweep for crossings in x direction. Find out first the number of
73	!-- particles to be transferred and allocate temporary arrays needed to store
74	!-- them.
75	!-- For a one-dimensional decomposition along y, no transfer is necessary,
76	!-- because the particle remains on the PE, but the particle coordinate has to
77	!-- be adjusted.
78	trlp_count = 0
79	trlpt_count = 0
80	trrp_count = 0
81	trrpt_count = 0
82
83	trlp_count_recv = 0
84	trlpt_count_recv = 0
85	trrp_count_recv = 0
86	trrpt_count_recv = 0
87
88	IF ( pdims(1) /= 1 ) THEN
89	!
90	!-- First calculate the storage necessary for sending and receiving the data
91	DO n = 1, number_of_particles
92	i = ( particles(n)%x + 0.5 * dx ) * ddx
93	!
94	!-- Above calculation does not work for indices less than zero
95	IF ( particles(n)%x < -0.5 * dx ) i = -1
96
97	IF ( i < nxl ) THEN
98	trlp_count = trlp_count + 1
99	IF ( particles(n)%tail_id /= 0 ) trlpt_count = trlpt_count + 1
100	ELSEIF ( i > nxr ) THEN
101	trrp_count = trrp_count + 1
102	IF ( particles(n)%tail_id /= 0 ) trrpt_count = trrpt_count + 1
103	ENDIF
104	ENDDO
105
106	IF ( trlp_count == 0 ) trlp_count = 1
107	IF ( trlpt_count == 0 ) trlpt_count = 1
108	IF ( trrp_count == 0 ) trrp_count = 1
109	IF ( trrpt_count == 0 ) trrpt_count = 1
110
111	ALLOCATE( trlp(trlp_count), trrp(trrp_count) )
112
113	trlp = particle_type( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, &
114	0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, &
115	0.0, 0, 0, 0, 0 )
116	trrp = particle_type( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, &
117	0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, &
118	0.0, 0, 0, 0, 0 )
119
120	IF ( use_particle_tails ) THEN
121	ALLOCATE( trlpt(maximum_number_of_tailpoints,5,trlpt_count), &
122	trrpt(maximum_number_of_tailpoints,5,trrpt_count) )
123	tlength = maximum_number_of_tailpoints * 5
124	ENDIF
125
126	trlp_count = 0
127	trlpt_count = 0
128	trrp_count = 0
129	trrpt_count = 0
130
131	ENDIF
132
133	DO n = 1, number_of_particles
134
135	nn = particles(n)%tail_id
136
137	i = ( particles(n)%x + 0.5 * dx ) * ddx
138	!
139	!-- Above calculation does not work for indices less than zero
140	IF ( particles(n)%x < - 0.5 * dx ) i = -1
141
142	IF ( i < nxl ) THEN
143	IF ( i < 0 ) THEN
144	!
145	!-- Apply boundary condition along x
146	IF ( ibc_par_lr == 0 ) THEN
147	!
148	!-- Cyclic condition
149	IF ( pdims(1) == 1 ) THEN
150	particles(n)%x = ( nx + 1 ) * dx + particles(n)%x
151	particles(n)%origin_x = ( nx + 1 ) * dx + &
152	particles(n)%origin_x
153	IF ( use_particle_tails .AND. nn /= 0 ) THEN
154	i = particles(n)%tailpoints
155	particle_tail_coordinates(1:i,1,nn) = ( nx + 1 ) * dx &
156	+ particle_tail_coordinates(1:i,1,nn)
157	ENDIF
158	ELSE
159	trlp_count = trlp_count + 1
160	trlp(trlp_count) = particles(n)
161	trlp(trlp_count)%x = ( nx + 1 ) * dx + trlp(trlp_count)%x
162	trlp(trlp_count)%origin_x = trlp(trlp_count)%origin_x + &
163	( nx + 1 ) * dx
164	particle_mask(n) = .FALSE.
165	deleted_particles = deleted_particles + 1
166
167	IF ( trlp(trlp_count)%x >= (nx + 0.5)* dx - 1.0E-12 ) THEN
168	trlp(trlp_count)%x = trlp(trlp_count)%x - 1.0E-10
169	!++ why is 1 subtracted in next statement???
170	trlp(trlp_count)%origin_x = trlp(trlp_count)%origin_x - 1
171	ENDIF
172
173	IF ( use_particle_tails .AND. nn /= 0 ) THEN
174	trlpt_count = trlpt_count + 1
175	trlpt(:,:,trlpt_count) = particle_tail_coordinates(:,:,nn)
176	trlpt(:,1,trlpt_count) = ( nx + 1 ) * dx + &
177	trlpt(:,1,trlpt_count)
178	tail_mask(nn) = .FALSE.
179	deleted_tails = deleted_tails + 1
180	ENDIF
181	ENDIF
182
183	ELSEIF ( ibc_par_lr == 1 ) THEN
184	!
185	!-- Particle absorption
186	particle_mask(n) = .FALSE.
187	deleted_particles = deleted_particles + 1
188	IF ( use_particle_tails .AND. nn /= 0 ) THEN
189	tail_mask(nn) = .FALSE.
190	deleted_tails = deleted_tails + 1
191	ENDIF
192
193	ELSEIF ( ibc_par_lr == 2 ) THEN
194	!
195	!-- Particle reflection
196	particles(n)%x = -particles(n)%x
197	particles(n)%speed_x = -particles(n)%speed_x
198
199	ENDIF
200	ELSE
201	!
202	!-- Store particle data in the transfer array, which will be send
203	!-- to the neighbouring PE
204	trlp_count = trlp_count + 1
205	trlp(trlp_count) = particles(n)
206	particle_mask(n) = .FALSE.
207	deleted_particles = deleted_particles + 1
208
209	IF ( use_particle_tails .AND. nn /= 0 ) THEN
210	trlpt_count = trlpt_count + 1
211	trlpt(:,:,trlpt_count) = particle_tail_coordinates(:,:,nn)
212	tail_mask(nn) = .FALSE.
213	deleted_tails = deleted_tails + 1
214	ENDIF
215	ENDIF
216
217	ELSEIF ( i > nxr ) THEN
218	IF ( i > nx ) THEN
219	!
220	!-- Apply boundary condition along x
221	IF ( ibc_par_lr == 0 ) THEN
222	!
223	!-- Cyclic condition
224	IF ( pdims(1) == 1 ) THEN
225	particles(n)%x = particles(n)%x - ( nx + 1 ) * dx
226	particles(n)%origin_x = particles(n)%origin_x - &
227	( nx + 1 ) * dx
228	IF ( use_particle_tails .AND. nn /= 0 ) THEN
229	i = particles(n)%tailpoints
230	particle_tail_coordinates(1:i,1,nn) = - ( nx+1 ) * dx &
231	+ particle_tail_coordinates(1:i,1,nn)
232	ENDIF
233	ELSE
234	trrp_count = trrp_count + 1
235	trrp(trrp_count) = particles(n)
236	trrp(trrp_count)%x = trrp(trrp_count)%x - ( nx + 1 ) * dx
237	trrp(trrp_count)%origin_x = trrp(trrp_count)%origin_x - &
238	( nx + 1 ) * dx
239	particle_mask(n) = .FALSE.
240	deleted_particles = deleted_particles + 1
241
242	IF ( use_particle_tails .AND. nn /= 0 ) THEN
243	trrpt_count = trrpt_count + 1
244	trrpt(:,:,trrpt_count) = particle_tail_coordinates(:,:,nn)
245	trrpt(:,1,trrpt_count) = trrpt(:,1,trrpt_count) - &
246	( nx + 1 ) * dx
247	tail_mask(nn) = .FALSE.
248	deleted_tails = deleted_tails + 1
249	ENDIF
250	ENDIF
251
252	ELSEIF ( ibc_par_lr == 1 ) THEN
253	!
254	!-- Particle absorption
255	particle_mask(n) = .FALSE.
256	deleted_particles = deleted_particles + 1
257	IF ( use_particle_tails .AND. nn /= 0 ) THEN
258	tail_mask(nn) = .FALSE.
259	deleted_tails = deleted_tails + 1
260	ENDIF
261
262	ELSEIF ( ibc_par_lr == 2 ) THEN
263	!
264	!-- Particle reflection
265	particles(n)%x = 2 * ( nx * dx ) - particles(n)%x
266	particles(n)%speed_x = -particles(n)%speed_x
267
268	ENDIF
269	ELSE
270	!
271	!-- Store particle data in the transfer array, which will be send
272	!-- to the neighbouring PE
273	trrp_count = trrp_count + 1
274	trrp(trrp_count) = particles(n)
275	particle_mask(n) = .FALSE.
276	deleted_particles = deleted_particles + 1
277
278	IF ( use_particle_tails .AND. nn /= 0 ) THEN
279	trrpt_count = trrpt_count + 1
280	trrpt(:,:,trrpt_count) = particle_tail_coordinates(:,:,nn)
281	tail_mask(nn) = .FALSE.
282	deleted_tails = deleted_tails + 1
283	ENDIF
284	ENDIF
285
286	ENDIF
287	ENDDO
288
289	!
290	!-- Send left boundary, receive right boundary (but first exchange how many
291	!-- and check, if particle storage must be extended)
292	IF ( pdims(1) /= 1 ) THEN
293
294	CALL cpu_log( log_point_s(23), 'sendrcv_particles', 'start' )
295	CALL MPI_SENDRECV( trlp_count, 1, MPI_INTEGER, pleft, 0, &
296	trrp_count_recv, 1, MPI_INTEGER, pright, 0, &
297	comm2d, status, ierr )
298
299	IF ( number_of_particles + trrp_count_recv > &
300	maximum_number_of_particles ) &
301	THEN
302	IF ( netcdf_output .AND. netcdf_data_format < 3 ) THEN
303	message_string = 'maximum_number_of_particles ' // &
304	'needs to be increased ' // &
305	'&but this is not allowed with ' // &
306	'netcdf-data_format < 3'
307	CALL message( 'lpm_exch_horiz', 'PA0146', 2, 2, -1, 6, 1 )
308	ELSE
309	CALL lpm_extend_particle_array( trrp_count_recv )
310	ENDIF
311	ENDIF
312
313	CALL MPI_SENDRECV( trlp(1)%age, trlp_count, mpi_particle_type, &
314	pleft, 1, particles(number_of_particles+1)%age, &
315	trrp_count_recv, mpi_particle_type, pright, 1, &
316	comm2d, status, ierr )
317
318	IF ( use_particle_tails ) THEN
319
320	CALL MPI_SENDRECV( trlpt_count, 1, MPI_INTEGER, pleft, 0, &
321	trrpt_count_recv, 1, MPI_INTEGER, pright, 0, &
322	comm2d, status, ierr )
323
324	IF ( number_of_tails+trrpt_count_recv > maximum_number_of_tails ) &
325	THEN
326	IF ( netcdf_output .AND. netcdf_data_format < 3 ) THEN
327	message_string = 'maximum_number_of_tails ' // &
328	'needs to be increased ' // &
329	'&but this is not allowed wi'// &
330	'th netcdf_data_format < 3'
331	CALL message( 'lpm_exch_horiz', 'PA0147', 2, 2, -1, 6, 1 )
332	ELSE
333	CALL lpm_extend_tail_array( trrpt_count_recv )
334	ENDIF
335	ENDIF
336
337	CALL MPI_SENDRECV( trlpt(1,1,1), trlpt_count*tlength, MPI_REAL, &
338	pleft, 1, &
339	particle_tail_coordinates(1,1,number_of_tails+1), &
340	trrpt_count_recv*tlength, MPI_REAL, pright, 1, &
341	comm2d, status, ierr )
342	!
343	!-- Update the tail ids for the transferred particles
344	nn = number_of_tails
345	DO n = number_of_particles+1, number_of_particles+trrp_count_recv
346	IF ( particles(n)%tail_id /= 0 ) THEN
347	nn = nn + 1
348	particles(n)%tail_id = nn
349	ENDIF
350	ENDDO
351
352	ENDIF
353
354	number_of_particles = number_of_particles + trrp_count_recv
355	number_of_tails = number_of_tails + trrpt_count_recv
356
357	!
358	!-- Send right boundary, receive left boundary
359	CALL MPI_SENDRECV( trrp_count, 1, MPI_INTEGER, pright, 0, &
360	trlp_count_recv, 1, MPI_INTEGER, pleft, 0, &
361	comm2d, status, ierr )
362
363	IF ( number_of_particles + trlp_count_recv > &
364	maximum_number_of_particles ) &
365	THEN
366	IF ( netcdf_output .AND. netcdf_data_format < 3 ) THEN
367	message_string = 'maximum_number_of_particles ' // &
368	'needs to be increased ' // &
369	'&but this is not allowed with '// &
370	'netcdf_data_format < 3'
371	CALL message( 'lpm_exch_horiz', 'PA0146', 2, 2, -1, 6, 1 )
372	ELSE
373	CALL lpm_extend_particle_array( trlp_count_recv )
374	ENDIF
375	ENDIF
376
377	CALL MPI_SENDRECV( trrp(1)%age, trrp_count, mpi_particle_type, &
378	pright, 1, particles(number_of_particles+1)%age, &
379	trlp_count_recv, mpi_particle_type, pleft, 1, &
380	comm2d, status, ierr )
381
382	IF ( use_particle_tails ) THEN
383
384	CALL MPI_SENDRECV( trrpt_count, 1, MPI_INTEGER, pright, 0, &
385	trlpt_count_recv, 1, MPI_INTEGER, pleft, 0, &
386	comm2d, status, ierr )
387
388	IF ( number_of_tails+trlpt_count_recv > maximum_number_of_tails ) &
389	THEN
390	IF ( netcdf_output .AND. netcdf_data_format < 3 ) THEN
391	message_string = 'maximum_number_of_tails ' // &
392	'needs to be increased ' // &
393	'&but this is not allowed wi'// &
394	'th netcdf_data_format < 3'
395	CALL message( 'lpm_exch_horiz', 'PA0147', 2, 2, -1, 6, 1 )
396	ELSE
397	CALL lpm_extend_tail_array( trlpt_count_recv )
398	ENDIF
399	ENDIF
400
401	CALL MPI_SENDRECV( trrpt(1,1,1), trrpt_count*tlength, MPI_REAL, &
402	pright, 1, &
403	particle_tail_coordinates(1,1,number_of_tails+1), &
404	trlpt_count_recv*tlength, MPI_REAL, pleft, 1, &
405	comm2d, status, ierr )
406	!
407	!-- Update the tail ids for the transferred particles
408	nn = number_of_tails
409	DO n = number_of_particles+1, number_of_particles+trlp_count_recv
410	IF ( particles(n)%tail_id /= 0 ) THEN
411	nn = nn + 1
412	particles(n)%tail_id = nn
413	ENDIF
414	ENDDO
415
416	ENDIF
417
418	number_of_particles = number_of_particles + trlp_count_recv
419	number_of_tails = number_of_tails + trlpt_count_recv
420
421	IF ( use_particle_tails ) THEN
422	DEALLOCATE( trlpt, trrpt )
423	ENDIF
424	DEALLOCATE( trlp, trrp )
425
426	CALL cpu_log( log_point_s(23), 'sendrcv_particles', 'pause' )
427
428	ENDIF
429
430
431	!
432	!-- Check whether particles have crossed the boundaries in y direction. Note
433	!-- that this case can also apply to particles that have just been received
434	!-- from the adjacent right or left PE.
435	!-- Find out first the number of particles to be transferred and allocate
436	!-- temporary arrays needed to store them.
437	!-- For a one-dimensional decomposition along x, no transfer is necessary,
438	!-- because the particle remains on the PE.
439	trsp_count = 0
440	trspt_count = 0
441	trnp_count = 0
442	trnpt_count = 0
443
444	trsp_count_recv = 0
445	trspt_count_recv = 0
446	trnp_count_recv = 0
447	trnpt_count_recv = 0
448
449	IF ( pdims(2) /= 1 ) THEN
450	!
451	!-- First calculate the storage necessary for sending and receiving the
452	!-- data
453	DO n = 1, number_of_particles
454	IF ( particle_mask(n) ) THEN
455	j = ( particles(n)%y + 0.5 * dy ) * ddy
456	!
457	!-- Above calculation does not work for indices less than zero
458	IF ( particles(n)%y < -0.5 * dy ) j = -1
459
460	IF ( j < nys ) THEN
461	trsp_count = trsp_count + 1
462	IF ( particles(n)%tail_id /= 0 ) trspt_count = trspt_count+1
463	ELSEIF ( j > nyn ) THEN
464	trnp_count = trnp_count + 1
465	IF ( particles(n)%tail_id /= 0 ) trnpt_count = trnpt_count+1
466	ENDIF
467	ENDIF
468	ENDDO
469
470	IF ( trsp_count == 0 ) trsp_count = 1
471	IF ( trspt_count == 0 ) trspt_count = 1
472	IF ( trnp_count == 0 ) trnp_count = 1
473	IF ( trnpt_count == 0 ) trnpt_count = 1
474
475	ALLOCATE( trsp(trsp_count), trnp(trnp_count) )
476
477	trsp = particle_type( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, &
478	0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, &
479	0.0, 0, 0, 0, 0 )
480	trnp = particle_type( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, &
481	0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, &
482	0.0, 0, 0, 0, 0 )
483
484	IF ( use_particle_tails ) THEN
485	ALLOCATE( trspt(maximum_number_of_tailpoints,5,trspt_count), &
486	trnpt(maximum_number_of_tailpoints,5,trnpt_count) )
487	tlength = maximum_number_of_tailpoints * 5
488	ENDIF
489
490	trsp_count = 0
491	trspt_count = 0
492	trnp_count = 0
493	trnpt_count = 0
494
495	ENDIF
496
497	DO n = 1, number_of_particles
498
499	nn = particles(n)%tail_id
500	!
501	!-- Only those particles that have not been marked as 'deleted' may be
502	!-- moved.
503	IF ( particle_mask(n) ) THEN
504	j = ( particles(n)%y + 0.5 * dy ) * ddy
505	!
506	!-- Above calculation does not work for indices less than zero
507	IF ( particles(n)%y < -0.5 * 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	IF ( use_particle_tails .AND. nn /= 0 ) THEN
521	i = particles(n)%tailpoints
522	particle_tail_coordinates(1:i,2,nn) = ( ny+1 ) * dy&
523	+ particle_tail_coordinates(1:i,2,nn)
524	ENDIF
525	ELSE
526	trsp_count = trsp_count + 1
527	trsp(trsp_count) = particles(n)
528	trsp(trsp_count)%y = ( ny + 1 ) * dy + &
529	trsp(trsp_count)%y
530	trsp(trsp_count)%origin_y = trsp(trsp_count)%origin_y &
531	+ ( ny + 1 ) * dy
532	particle_mask(n) = .FALSE.
533	deleted_particles = deleted_particles + 1
534
535	IF ( trsp(trsp_count)%y >= (ny+0.5)* dy - 1.0E-12 ) THEN
536	trsp(trsp_count)%y = trsp(trsp_count)%y - 1.0E-10
537	!++ why is 1 subtracted in next statement???
538	trsp(trsp_count)%origin_y = &
539	trsp(trsp_count)%origin_y - 1
540	ENDIF
541
542	IF ( use_particle_tails .AND. nn /= 0 ) THEN
543	trspt_count = trspt_count + 1
544	trspt(:,:,trspt_count) = &
545	particle_tail_coordinates(:,:,nn)
546	trspt(:,2,trspt_count) = ( ny + 1 ) * dy + &
547	trspt(:,2,trspt_count)
548	tail_mask(nn) = .FALSE.
549	deleted_tails = deleted_tails + 1
550	ENDIF
551	ENDIF
552
553	ELSEIF ( ibc_par_ns == 1 ) THEN
554	!
555	!-- Particle absorption
556	particle_mask(n) = .FALSE.
557	deleted_particles = deleted_particles + 1
558	IF ( use_particle_tails .AND. nn /= 0 ) THEN
559	tail_mask(nn) = .FALSE.
560	deleted_tails = deleted_tails + 1
561	ENDIF
562
563	ELSEIF ( ibc_par_ns == 2 ) THEN
564	!
565	!-- Particle reflection
566	particles(n)%y = -particles(n)%y
567	particles(n)%speed_y = -particles(n)%speed_y
568
569	ENDIF
570	ELSE
571	!
572	!-- Store particle data in the transfer array, which will be send
573	!-- to the neighbouring PE
574	trsp_count = trsp_count + 1
575	trsp(trsp_count) = particles(n)
576	particle_mask(n) = .FALSE.
577	deleted_particles = deleted_particles + 1
578
579	IF ( use_particle_tails .AND. nn /= 0 ) THEN
580	trspt_count = trspt_count + 1
581	trspt(:,:,trspt_count) = particle_tail_coordinates(:,:,nn)
582	tail_mask(nn) = .FALSE.
583	deleted_tails = deleted_tails + 1
584	ENDIF
585	ENDIF
586
587	ELSEIF ( j > nyn ) THEN
588	IF ( j > ny ) THEN
589	!
590	!-- Apply boundary condition along x
591	IF ( ibc_par_ns == 0 ) THEN
592	!
593	!-- Cyclic condition
594	IF ( pdims(2) == 1 ) THEN
595	particles(n)%y = particles(n)%y - ( ny + 1 ) * dy
596	particles(n)%origin_y = particles(n)%origin_y - &
597	( ny + 1 ) * dy
598	IF ( use_particle_tails .AND. nn /= 0 ) THEN
599	i = particles(n)%tailpoints
600	particle_tail_coordinates(1:i,2,nn) = - (ny+1) * dy &
601	+ particle_tail_coordinates(1:i,2,nn)
602	ENDIF
603	ELSE
604	trnp_count = trnp_count + 1
605	trnp(trnp_count) = particles(n)
606	trnp(trnp_count)%y = trnp(trnp_count)%y - &
607	( ny + 1 ) * dy
608	trnp(trnp_count)%origin_y = trnp(trnp_count)%origin_y &
609	- ( ny + 1 ) * dy
610	particle_mask(n) = .FALSE.
611	deleted_particles = deleted_particles + 1
612
613	IF ( use_particle_tails .AND. nn /= 0 ) THEN
614	trnpt_count = trnpt_count + 1
615	trnpt(:,:,trnpt_count) = &
616	particle_tail_coordinates(:,:,nn)
617	trnpt(:,2,trnpt_count) = trnpt(:,2,trnpt_count) - &
618	( ny + 1 ) * dy
619	tail_mask(nn) = .FALSE.
620	deleted_tails = deleted_tails + 1
621	ENDIF
622	ENDIF
623
624	ELSEIF ( ibc_par_ns == 1 ) THEN
625	!
626	!-- Particle absorption
627	particle_mask(n) = .FALSE.
628	deleted_particles = deleted_particles + 1
629	IF ( use_particle_tails .AND. nn /= 0 ) THEN
630	tail_mask(nn) = .FALSE.
631	deleted_tails = deleted_tails + 1
632	ENDIF
633
634	ELSEIF ( ibc_par_ns == 2 ) THEN
635	!
636	!-- Particle reflection
637	particles(n)%y = 2 * ( ny * dy ) - particles(n)%y
638	particles(n)%speed_y = -particles(n)%speed_y
639
640	ENDIF
641	ELSE
642	!
643	!-- Store particle data in the transfer array, which will be send
644	!-- to the neighbouring PE
645	trnp_count = trnp_count + 1
646	trnp(trnp_count) = particles(n)
647	particle_mask(n) = .FALSE.
648	deleted_particles = deleted_particles + 1
649
650	IF ( use_particle_tails .AND. nn /= 0 ) THEN
651	trnpt_count = trnpt_count + 1
652	trnpt(:,:,trnpt_count) = particle_tail_coordinates(:,:,nn)
653	tail_mask(nn) = .FALSE.
654	deleted_tails = deleted_tails + 1
655	ENDIF
656	ENDIF
657
658	ENDIF
659	ENDIF
660	ENDDO
661
662	!
663	!-- Send front boundary, receive back boundary (but first exchange how many
664	!-- and check, if particle storage must be extended)
665	IF ( pdims(2) /= 1 ) THEN
666
667	CALL cpu_log( log_point_s(23), 'sendrcv_particles', 'continue' )
668	CALL MPI_SENDRECV( trsp_count, 1, MPI_INTEGER, psouth, 0, &
669	trnp_count_recv, 1, MPI_INTEGER, pnorth, 0, &
670	comm2d, status, ierr )
671
672	IF ( number_of_particles + trnp_count_recv > &
673	maximum_number_of_particles ) &
674	THEN
675	IF ( netcdf_output .AND. netcdf_data_format < 3 ) THEN
676	message_string = 'maximum_number_of_particles ' // &
677	'needs to be increased ' // &
678	'&but this is not allowed with '// &
679	'netcdf_data_format < 3'
680	CALL message( 'lpm_exch_horiz', 'PA0146', 2, 2, -1, 6, 1 )
681	ELSE
682	CALL lpm_extend_particle_array( trnp_count_recv )
683	ENDIF
684	ENDIF
685
686	CALL MPI_SENDRECV( trsp(1)%age, trsp_count, mpi_particle_type, &
687	psouth, 1, particles(number_of_particles+1)%age, &
688	trnp_count_recv, mpi_particle_type, pnorth, 1, &
689	comm2d, status, ierr )
690
691	IF ( use_particle_tails ) THEN
692
693	CALL MPI_SENDRECV( trspt_count, 1, MPI_INTEGER, psouth, 0, &
694	trnpt_count_recv, 1, MPI_INTEGER, pnorth, 0, &
695	comm2d, status, ierr )
696
697	IF ( number_of_tails+trnpt_count_recv > maximum_number_of_tails ) &
698	THEN
699	IF ( netcdf_output .AND. netcdf_data_format < 3 ) THEN
700	message_string = 'maximum_number_of_tails ' // &
701	'needs to be increased ' // &
702	'&but this is not allowed wi' // &
703	'th netcdf_data_format < 3'
704	CALL message( 'lpm_exch_horiz', 'PA0147', 2, 2, -1, 6, 1 )
705	ELSE
706	CALL lpm_extend_tail_array( trnpt_count_recv )
707	ENDIF
708	ENDIF
709
710	CALL MPI_SENDRECV( trspt(1,1,1), trspt_count*tlength, MPI_REAL, &
711	psouth, 1, &
712	particle_tail_coordinates(1,1,number_of_tails+1), &
713	trnpt_count_recv*tlength, MPI_REAL, pnorth, 1, &
714	comm2d, status, ierr )
715
716	!
717	!-- Update the tail ids for the transferred particles
718	nn = number_of_tails
719	DO n = number_of_particles+1, number_of_particles+trnp_count_recv
720	IF ( particles(n)%tail_id /= 0 ) THEN
721	nn = nn + 1
722	particles(n)%tail_id = nn
723	ENDIF
724	ENDDO
725
726	ENDIF
727
728	number_of_particles = number_of_particles + trnp_count_recv
729	number_of_tails = number_of_tails + trnpt_count_recv
730
731	!
732	!-- Send back boundary, receive front boundary
733	CALL MPI_SENDRECV( trnp_count, 1, MPI_INTEGER, pnorth, 0, &
734	trsp_count_recv, 1, MPI_INTEGER, psouth, 0, &
735	comm2d, status, ierr )
736
737	IF ( number_of_particles + trsp_count_recv > &
738	maximum_number_of_particles ) &
739	THEN
740	IF ( netcdf_output .AND. netcdf_data_format < 3 ) THEN
741	message_string = 'maximum_number_of_particles ' // &
742	'needs to be increased ' // &
743	'&but this is not allowed with ' // &
744	'netcdf_data_format < 3'
745	CALL message( 'lpm_exch_horiz', 'PA0146', 2, 2, -1, 6, 1 )
746	ELSE
747	CALL lpm_extend_particle_array( trsp_count_recv )
748	ENDIF
749	ENDIF
750
751	CALL MPI_SENDRECV( trnp(1)%age, trnp_count, mpi_particle_type, &
752	pnorth, 1, particles(number_of_particles+1)%age, &
753	trsp_count_recv, mpi_particle_type, psouth, 1, &
754	comm2d, status, ierr )
755
756	IF ( use_particle_tails ) THEN
757
758	CALL MPI_SENDRECV( trnpt_count, 1, MPI_INTEGER, pnorth, 0, &
759	trspt_count_recv, 1, MPI_INTEGER, psouth, 0, &
760	comm2d, status, ierr )
761
762	IF ( number_of_tails+trspt_count_recv > maximum_number_of_tails ) &
763	THEN
764	IF ( netcdf_output .AND. netcdf_data_format < 3 ) THEN
765	message_string = 'maximum_number_of_tails ' // &
766	'needs to be increased ' // &
767	'&but this is not allowed wi'// &
768	'th NetCDF output switched on'
769	CALL message( 'lpm_exch_horiz', 'PA0147', 2, 2, -1, 6, 1 )
770	ELSE
771	CALL lpm_extend_tail_array( trspt_count_recv )
772	ENDIF
773	ENDIF
774
775	CALL MPI_SENDRECV( trnpt(1,1,1), trnpt_count*tlength, MPI_REAL, &
776	pnorth, 1, &
777	particle_tail_coordinates(1,1,number_of_tails+1), &
778	trspt_count_recv*tlength, MPI_REAL, psouth, 1, &
779	comm2d, status, ierr )
780	!
781	!-- Update the tail ids for the transferred particles
782	nn = number_of_tails
783	DO n = number_of_particles+1, number_of_particles+trsp_count_recv
784	IF ( particles(n)%tail_id /= 0 ) THEN
785	nn = nn + 1
786	particles(n)%tail_id = nn
787	ENDIF
788	ENDDO
789
790	ENDIF
791
792	number_of_particles = number_of_particles + trsp_count_recv
793	number_of_tails = number_of_tails + trspt_count_recv
794
795	IF ( use_particle_tails ) THEN
796	DEALLOCATE( trspt, trnpt )
797	ENDIF
798	DEALLOCATE( trsp, trnp )
799
800	CALL cpu_log( log_point_s(23), 'sendrcv_particles', 'stop' )
801
802	ENDIF
803
804	#else
805
806	!
807	!-- Apply boundary conditions
808	DO n = 1, number_of_particles
809
810	nn = particles(n)%tail_id
811
812	IF ( particles(n)%x < -0.5 * dx ) THEN
813
814	IF ( ibc_par_lr == 0 ) THEN
815	!
816	!-- Cyclic boundary. Relevant coordinate has to be changed.
817	particles(n)%x = ( nx + 1 ) * dx + particles(n)%x
818	IF ( use_particle_tails .AND. nn /= 0 ) THEN
819	i = particles(n)%tailpoints
820	particle_tail_coordinates(1:i,1,nn) = ( nx + 1 ) * dx + &
821	particle_tail_coordinates(1:i,1,nn)
822	ENDIF
823	ELSEIF ( ibc_par_lr == 1 ) THEN
824	!
825	!-- Particle absorption
826	particle_mask(n) = .FALSE.
827	deleted_particles = deleted_particles + 1
828	IF ( use_particle_tails .AND. nn /= 0 ) THEN
829	tail_mask(nn) = .FALSE.
830	deleted_tails = deleted_tails + 1
831	ENDIF
832	ELSEIF ( ibc_par_lr == 2 ) THEN
833	!
834	!-- Particle reflection
835	particles(n)%x = -dx - particles(n)%x
836	particles(n)%speed_x = -particles(n)%speed_x
837	ENDIF
838
839	ELSEIF ( particles(n)%x >= ( nx + 0.5 ) * dx ) THEN
840
841	IF ( ibc_par_lr == 0 ) THEN
842	!
843	!-- Cyclic boundary. Relevant coordinate has to be changed.
844	particles(n)%x = particles(n)%x - ( nx + 1 ) * dx
845	IF ( use_particle_tails .AND. nn /= 0 ) THEN
846	i = particles(n)%tailpoints
847	particle_tail_coordinates(1:i,1,nn) = - ( nx + 1 ) * dx + &
848	particle_tail_coordinates(1:i,1,nn)
849	ENDIF
850	ELSEIF ( ibc_par_lr == 1 ) THEN
851	!
852	!-- Particle absorption
853	particle_mask(n) = .FALSE.
854	deleted_particles = deleted_particles + 1
855	IF ( use_particle_tails .AND. nn /= 0 ) THEN
856	tail_mask(nn) = .FALSE.
857	deleted_tails = deleted_tails + 1
858	ENDIF
859	ELSEIF ( ibc_par_lr == 2 ) THEN
860	!
861	!-- Particle reflection
862	particles(n)%x = ( nx + 1 ) * dx - particles(n)%x
863	particles(n)%speed_x = -particles(n)%speed_x
864	ENDIF
865
866	ENDIF
867
868	IF ( particles(n)%y < -0.5 * dy ) THEN
869
870	IF ( ibc_par_ns == 0 ) THEN
871	!
872	!-- Cyclic boundary. Relevant coordinate has to be changed.
873	particles(n)%y = ( ny + 1 ) * dy + particles(n)%y
874	IF ( use_particle_tails .AND. nn /= 0 ) THEN
875	i = particles(n)%tailpoints
876	particle_tail_coordinates(1:i,2,nn) = ( ny + 1 ) * dy + &
877	particle_tail_coordinates(1:i,2,nn)
878	ENDIF
879	ELSEIF ( ibc_par_ns == 1 ) THEN
880	!
881	!-- Particle absorption
882	particle_mask(n) = .FALSE.
883	deleted_particles = deleted_particles + 1
884	IF ( use_particle_tails .AND. nn /= 0 ) THEN
885	tail_mask(nn) = .FALSE.
886	deleted_tails = deleted_tails + 1
887	ENDIF
888	ELSEIF ( ibc_par_ns == 2 ) THEN
889	!
890	!-- Particle reflection
891	particles(n)%y = -dy - particles(n)%y
892	particles(n)%speed_y = -particles(n)%speed_y
893	ENDIF
894
895	ELSEIF ( particles(n)%y >= ( ny + 0.5 ) * dy ) THEN
896
897	IF ( ibc_par_ns == 0 ) THEN
898	!
899	!-- Cyclic boundary. Relevant coordinate has to be changed.
900	particles(n)%y = particles(n)%y - ( ny + 1 ) * dy
901	IF ( use_particle_tails .AND. nn /= 0 ) THEN
902	i = particles(n)%tailpoints
903	particle_tail_coordinates(1:i,2,nn) = - ( ny + 1 ) * dy + &
904	particle_tail_coordinates(1:i,2,nn)
905	ENDIF
906	ELSEIF ( ibc_par_ns == 1 ) THEN
907	!
908	!-- Particle absorption
909	particle_mask(n) = .FALSE.
910	deleted_particles = deleted_particles + 1
911	IF ( use_particle_tails .AND. nn /= 0 ) THEN
912	tail_mask(nn) = .FALSE.
913	deleted_tails = deleted_tails + 1
914	ENDIF
915	ELSEIF ( ibc_par_ns == 2 ) THEN
916	!
917	!-- Particle reflection
918	particles(n)%y = ( ny + 1 ) * dy - particles(n)%y
919	particles(n)%speed_y = -particles(n)%speed_y
920	ENDIF
921
922	ENDIF
923	ENDDO
924
925	#endif
926
927	!
928	!-- Accumulate the number of particles transferred between the subdomains
929	#if defined( __parallel )
930	trlp_count_sum = trlp_count_sum + trlp_count
931	trlp_count_recv_sum = trlp_count_recv_sum + trlp_count_recv
932	trrp_count_sum = trrp_count_sum + trrp_count
933	trrp_count_recv_sum = trrp_count_recv_sum + trrp_count_recv
934	trsp_count_sum = trsp_count_sum + trsp_count
935	trsp_count_recv_sum = trsp_count_recv_sum + trsp_count_recv
936	trnp_count_sum = trnp_count_sum + trnp_count
937	trnp_count_recv_sum = trnp_count_recv_sum + trnp_count_recv
938	#endif
939
940
941	END SUBROUTINE lpm_exchange_horiz

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |