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

Last change on this file since 1930 was 1930, checked in by suehring, 5 years ago

last commit documented

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