Home

Context Navigation

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

Last change on this file since 986 was 852, checked in by raasch, 13 years ago
last commit documented
Property svn:keywords set to `Id`
File size: 35.9 KB

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |