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

Last change on this file since 850 was 850, checked in by raasch, 10 years ago

last commit documented

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