Changeset 1929 for palm/trunk/SOURCE/lpm_exchange_horiz.f90
- Timestamp:
- Jun 9, 2016 4:25:25 PM (8 years ago)
- File:
-
- 1 edited
-
palm/trunk/SOURCE/lpm_exchange_horiz.f90 (modified) (35 diffs)
Legend:
- Unmodified
- Added
- Removed
-
palm/trunk/SOURCE/lpm_exchange_horiz.f90
r1874 r1929 19 19 ! Current revisions: 20 20 ! ------------------ 21 ! 21 ! Bugfixes: 22 ! - reallocation of new particles 23 ! ( did not work for small number of min_nr_particle ) 24 ! - dynamical reallocation of north-south exchange arrays ( particles got lost ) 25 ! - north-south exchange ( nr_move_north, nr_move_south were overwritten by zero ) 26 ! - horizontal particle boundary conditions in serial mode 27 ! 28 ! Remove unused variables 29 ! Descriptions in variable declaration blocks added 22 30 ! 23 31 ! Former revisions: … … 121 129 INTEGER(iwp) :: nr_move_south !< 122 130 123 TYPE(particle_type), DIMENSION( NR_2_direction_move):: move_also_north124 TYPE(particle_type), DIMENSION( NR_2_direction_move):: move_also_south131 TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: move_also_north 132 TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: move_also_south 125 133 126 134 SAVE … … 161 169 IMPLICIT NONE 162 170 163 INTEGER(iwp) :: i !< 164 INTEGER(iwp) :: ip !< 165 INTEGER(iwp) :: j !< 166 INTEGER(iwp) :: jp !< 167 INTEGER(iwp) :: kp !< 168 INTEGER(iwp) :: n !< 169 INTEGER(iwp) :: trlp_count !< 170 INTEGER(iwp) :: trlp_count_recv !< 171 INTEGER(iwp) :: trlpt_count !< 172 INTEGER(iwp) :: trlpt_count_recv !< 173 INTEGER(iwp) :: trnp_count !< 174 INTEGER(iwp) :: trnp_count_recv !< 175 INTEGER(iwp) :: trnpt_count !< 176 INTEGER(iwp) :: trnpt_count_recv !< 177 INTEGER(iwp) :: trrp_count !< 178 INTEGER(iwp) :: trrp_count_recv !< 179 INTEGER(iwp) :: trrpt_count !< 180 INTEGER(iwp) :: trrpt_count_recv !< 181 INTEGER(iwp) :: trsp_count !< 182 INTEGER(iwp) :: trsp_count_recv !< 183 INTEGER(iwp) :: trspt_count !< 184 INTEGER(iwp) :: trspt_count_recv !< 185 186 TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: rvlp !< 187 TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: rvnp !< 188 TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: rvrp !< 189 TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: rvsp !< 190 TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: trlp !< 191 TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: trnp !< 192 TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: trrp !< 193 TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: trsp !< 171 INTEGER(iwp) :: i !< grid index (x) of particle positition 172 INTEGER(iwp) :: ip !< index variable along x 173 INTEGER(iwp) :: j !< grid index (y) of particle positition 174 INTEGER(iwp) :: jp !< index variable along y 175 INTEGER(iwp) :: kp !< index variable along z 176 INTEGER(iwp) :: n !< particle index variable 177 INTEGER(iwp) :: trlp_count !< number of particles send to left PE 178 INTEGER(iwp) :: trlp_count_recv !< number of particles receive from right PE 179 INTEGER(iwp) :: trnp_count !< number of particles send to north PE 180 INTEGER(iwp) :: trnp_count_recv !< number of particles receive from south PE 181 INTEGER(iwp) :: trrp_count !< number of particles send to right PE 182 INTEGER(iwp) :: trrp_count_recv !< number of particles receive from left PE 183 INTEGER(iwp) :: trsp_count !< number of particles send to south PE 184 INTEGER(iwp) :: trsp_count_recv !< number of particles receive from north PE 185 186 TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: rvlp !< particles received from right PE 187 TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: rvnp !< particles received from south PE 188 TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: rvrp !< particles received from left PE 189 TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: rvsp !< particles received from north PE 190 TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: trlp !< particles send to left PE 191 TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: trnp !< particles send to north PE 192 TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: trrp !< particles send to right PE 193 TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: trsp !< particles send to south PE 194 194 195 195 CALL cpu_log( log_point_s(23), 'lpm_exchange_horiz', 'start' ) … … 209 209 !-- be adjusted. 210 210 trlp_count = 0 211 trlpt_count = 0212 211 trrp_count = 0 213 trrpt_count = 0214 212 215 213 trlp_count_recv = 0 216 trlpt_count_recv = 0217 214 trrp_count_recv = 0 218 trrpt_count_recv = 0219 215 220 216 IF ( pdims(1) /= 1 ) THEN … … 232 228 IF ( particles(n)%particle_mask ) THEN 233 229 i = ( particles(n)%x + 0.5_wp * dx ) * ddx 234 235 !--Above calculation does not work for indices less than zero230 ! 231 !-- Above calculation does not work for indices less than zero 236 232 IF ( particles(n)%x < -0.5_wp * dx ) i = -1 237 233 … … 249 245 250 246 IF ( trlp_count == 0 ) trlp_count = 1 251 IF ( trlpt_count == 0 ) trlpt_count = 1252 247 IF ( trrp_count == 0 ) trrp_count = 1 253 IF ( trrpt_count == 0 ) trrpt_count = 1254 248 255 249 ALLOCATE( trlp(trlp_count), trrp(trrp_count) ) … … 259 253 260 254 trlp_count = 0 261 trlpt_count = 0262 255 trrp_count = 0 263 trrpt_count = 0264 256 265 257 ENDIF 266 258 ! 267 259 !-- Compute only first (nxl) and last (nxr) loop iterration 268 DO ip = nxl, nxr, nxr-nxl260 DO ip = nxl, nxr, nxr-nxl 269 261 DO jp = nys, nyn 270 262 DO kp = nzb+1, nzt … … 279 271 280 272 i = ( particles(n)%x + 0.5_wp * dx ) * ddx 281 282 !--Above calculation does not work for indices less than zero273 ! 274 !-- Above calculation does not work for indices less than zero 283 275 IF ( particles(n)%x < - 0.5_wp * dx ) i = -1 284 276 285 277 IF ( i < nxl ) THEN 286 278 IF ( i < 0 ) THEN 287 288 279 ! 280 !-- Apply boundary condition along x 289 281 IF ( ibc_par_lr == 0 ) THEN 290 291 !--Cyclic condition282 ! 283 !-- Cyclic condition 292 284 IF ( pdims(1) == 1 ) THEN 293 285 particles(n)%x = ( nx + 1 ) * dx + particles(n)%x … … 312 304 313 305 ELSEIF ( ibc_par_lr == 1 ) THEN 314 315 !--Particle absorption306 ! 307 !-- Particle absorption 316 308 particles(n)%particle_mask = .FALSE. 317 309 deleted_particles = deleted_particles + 1 318 310 319 311 ELSEIF ( ibc_par_lr == 2 ) THEN 320 321 !--Particle reflection312 ! 313 !-- Particle reflection 322 314 particles(n)%x = -particles(n)%x 323 315 particles(n)%speed_x = -particles(n)%speed_x … … 325 317 ENDIF 326 318 ELSE 327 328 !--Store particle data in the transfer array, which will be329 !--send to the neighbouring PE319 ! 320 !-- Store particle data in the transfer array, which will be 321 !-- send to the neighbouring PE 330 322 trlp_count = trlp_count + 1 331 323 trlp(trlp_count) = particles(n) … … 337 329 ELSEIF ( i > nxr ) THEN 338 330 IF ( i > nx ) THEN 339 340 !--Apply boundary condition along x331 ! 332 !-- Apply boundary condition along x 341 333 IF ( ibc_par_lr == 0 ) THEN 342 343 !--Cyclic condition334 ! 335 !-- Cyclic condition 344 336 IF ( pdims(1) == 1 ) THEN 345 337 particles(n)%x = particles(n)%x - ( nx + 1 ) * dx … … 358 350 359 351 ELSEIF ( ibc_par_lr == 1 ) THEN 360 361 !--Particle absorption352 ! 353 !-- Particle absorption 362 354 particles(n)%particle_mask = .FALSE. 363 355 deleted_particles = deleted_particles + 1 364 356 365 357 ELSEIF ( ibc_par_lr == 2 ) THEN 366 367 !--Particle reflection358 ! 359 !-- Particle reflection 368 360 particles(n)%x = 2 * ( nx * dx ) - particles(n)%x 369 361 particles(n)%speed_x = -particles(n)%speed_x … … 371 363 ENDIF 372 364 ELSE 373 374 !--Store particle data in the transfer array, which will be send375 !--to the neighbouring PE365 ! 366 !-- Store particle data in the transfer array, which will be send 367 !-- to the neighbouring PE 376 368 trrp_count = trrp_count + 1 377 369 trrp(trrp_count) = particles(n) … … 383 375 ENDIF 384 376 ENDIF 377 385 378 ENDDO 386 379 ENDDO … … 389 382 390 383 ! 384 !-- Allocate arrays required for north-south exchange, as these 385 !-- are used directly after particles are exchange along x-direction. 386 ALLOCATE( move_also_north(1:NR_2_direction_move) ) 387 ALLOCATE( move_also_south(1:NR_2_direction_move) ) 388 389 nr_move_north = 0 390 nr_move_south = 0 391 ! 391 392 !-- Send left boundary, receive right boundary (but first exchange how many 392 393 !-- and check, if particle storage must be extended) … … 427 428 428 429 ENDIF 429 430 430 431 431 ! … … 435 435 !-- Find out first the number of particles to be transferred and allocate 436 436 !-- temporary arrays needed to store them. 437 !-- For a one-dimensional decomposition along x, no transfer is necessary,437 !-- For a one-dimensional decomposition along y, no transfer is necessary, 438 438 !-- because the particle remains on the PE. 439 439 trsp_count = nr_move_south 440 trspt_count = 0441 440 trnp_count = nr_move_north 442 trnpt_count = 0443 441 444 442 trsp_count_recv = 0 445 trspt_count_recv = 0446 443 trnp_count_recv = 0 447 trnpt_count_recv = 0448 444 449 445 IF ( pdims(2) /= 1 ) THEN … … 452 448 !-- data 453 449 DO ip = nxl, nxr 454 DO jp = nys, nyn, nyn-nys 450 DO jp = nys, nyn, nyn-nys !compute only first (nys) and last (nyn) loop iterration 455 451 DO kp = nzb+1, nzt 456 452 number_of_particles = prt_count(kp,jp,ip) … … 476 472 477 473 IF ( trsp_count == 0 ) trsp_count = 1 478 IF ( trspt_count == 0 ) trspt_count = 1479 474 IF ( trnp_count == 0 ) trnp_count = 1 480 IF ( trnpt_count == 0 ) trnpt_count = 1481 475 482 476 ALLOCATE( trsp(trsp_count), trnp(trnp_count) ) … … 486 480 487 481 trsp_count = nr_move_south 488 trspt_count = 0489 482 trnp_count = nr_move_north 490 trnpt_count = 0 491 483 492 484 trsp(1:nr_move_south) = move_also_south(1:nr_move_south) 493 485 trnp(1:nr_move_north) = move_also_north(1:nr_move_north) … … 506 498 !-- be moved. 507 499 IF ( particles(n)%particle_mask ) THEN 500 508 501 j = ( particles(n)%y + 0.5_wp * dy ) * ddy 509 502 ! … … 521 514 particles(n)%y = ( ny + 1 ) * dy + particles(n)%y 522 515 particles(n)%origin_y = ( ny + 1 ) * dy + & 523 particles(n)%origin_y516 particles(n)%origin_y 524 517 ELSE 525 trsp_count = trsp_count + 1526 trsp(trsp_count) = particles(n)518 trsp_count = trsp_count + 1 519 trsp(trsp_count) = particles(n) 527 520 trsp(trsp_count)%y = ( ny + 1 ) * dy + & 528 trsp(trsp_count)%y521 trsp(trsp_count)%y 529 522 trsp(trsp_count)%origin_y = trsp(trsp_count)%origin_y & 530 + ( ny + 1 ) * dy523 + ( ny + 1 ) * dy 531 524 particles(n)%particle_mask = .FALSE. 532 525 deleted_particles = deleted_particles + 1 … … 536 529 !++ why is 1 subtracted in next statement??? 537 530 trsp(trsp_count)%origin_y = & 538 trsp(trsp_count)%origin_y - 1531 trsp(trsp_count)%origin_y - 1 539 532 ENDIF 540 533 … … 545 538 !-- Particle absorption 546 539 particles(n)%particle_mask = .FALSE. 547 deleted_particles = deleted_particles + 1540 deleted_particles = deleted_particles + 1 548 541 549 542 ELSEIF ( ibc_par_ns == 2 ) THEN … … 568 561 IF ( j > ny ) THEN 569 562 ! 570 !-- Apply boundary condition along x563 !-- Apply boundary condition along y 571 564 IF ( ibc_par_ns == 0 ) THEN 572 565 ! 573 566 !-- Cyclic condition 574 567 IF ( pdims(2) == 1 ) THEN 575 particles(n)%y = particles(n)%y - ( ny + 1 ) * dy568 particles(n)%y = particles(n)%y - ( ny + 1 ) * dy 576 569 particles(n)%origin_y = & 577 particles(n)%origin_y - ( ny + 1 ) * dy570 particles(n)%origin_y - ( ny + 1 ) * dy 578 571 ELSE 579 trnp_count = trnp_count + 1580 trnp(trnp_count) = particles(n)572 trnp_count = trnp_count + 1 573 trnp(trnp_count) = particles(n) 581 574 trnp(trnp_count)%y = & 582 trnp(trnp_count)%y - ( ny + 1 ) * dy575 trnp(trnp_count)%y - ( ny + 1 ) * dy 583 576 trnp(trnp_count)%origin_y = & 584 trnp(trnp_count)%origin_y - ( ny + 1 ) * dy577 trnp(trnp_count)%origin_y - ( ny + 1 ) * dy 585 578 particles(n)%particle_mask = .FALSE. 586 deleted_particles = deleted_particles + 1579 deleted_particles = deleted_particles + 1 587 580 ENDIF 588 581 … … 628 621 629 622 ALLOCATE(rvnp(MAX(1,trnp_count_recv))) 630 623 631 624 CALL MPI_SENDRECV( trsp(1)%radius, trsp_count, mpi_particle_type, & 632 625 psouth, 1, rvnp(1)%radius, & … … 661 654 ENDIF 662 655 656 DEALLOCATE( move_also_north ) 657 DEALLOCATE( move_also_south ) 658 663 659 #else 664 660 665 ! 666 !-- Apply boundary conditions 667 DO n = 1, number_of_particles 668 669 IF ( particles(n)%x < -0.5_wp * dx ) THEN 670 671 IF ( ibc_par_lr == 0 ) THEN 672 ! 673 !-- Cyclic boundary. Relevant coordinate has to be changed. 674 particles(n)%x = ( nx + 1 ) * dx + particles(n)%x 675 676 ELSEIF ( ibc_par_lr == 1 ) THEN 677 ! 678 !-- Particle absorption 679 particles(n)%particle_mask = .FALSE. 680 deleted_particles = deleted_particles + 1 681 682 ELSEIF ( ibc_par_lr == 2 ) THEN 683 ! 684 !-- Particle reflection 685 particles(n)%x = -dx - particles(n)%x 686 particles(n)%speed_x = -particles(n)%speed_x 687 ENDIF 688 689 ELSEIF ( particles(n)%x >= ( nx + 0.5_wp ) * dx ) THEN 690 691 IF ( ibc_par_lr == 0 ) THEN 692 ! 693 !-- Cyclic boundary. Relevant coordinate has to be changed. 694 particles(n)%x = particles(n)%x - ( nx + 1 ) * dx 695 696 ELSEIF ( ibc_par_lr == 1 ) THEN 697 ! 698 !-- Particle absorption 699 particles(n)%particle_mask = .FALSE. 700 deleted_particles = deleted_particles + 1 701 702 ELSEIF ( ibc_par_lr == 2 ) THEN 703 ! 704 !-- Particle reflection 705 particles(n)%x = ( nx + 1 ) * dx - particles(n)%x 706 particles(n)%speed_x = -particles(n)%speed_x 707 ENDIF 708 709 ENDIF 710 711 IF ( particles(n)%y < -0.5_wp * dy ) THEN 712 713 IF ( ibc_par_ns == 0 ) THEN 714 ! 715 !-- Cyclic boundary. Relevant coordinate has to be changed. 716 particles(n)%y = ( ny + 1 ) * dy + particles(n)%y 717 718 ELSEIF ( ibc_par_ns == 1 ) THEN 719 ! 720 !-- Particle absorption 721 particles(n)%particle_mask = .FALSE. 722 deleted_particles = deleted_particles + 1 723 724 ELSEIF ( ibc_par_ns == 2 ) THEN 725 ! 726 !-- Particle reflection 727 particles(n)%y = -dy - particles(n)%y 728 particles(n)%speed_y = -particles(n)%speed_y 729 ENDIF 730 731 ELSEIF ( particles(n)%y >= ( ny + 0.5_wp ) * dy ) THEN 732 733 IF ( ibc_par_ns == 0 ) THEN 734 ! 735 !-- Cyclic boundary. Relevant coordinate has to be changed. 736 particles(n)%y = particles(n)%y - ( ny + 1 ) * dy 737 738 ELSEIF ( ibc_par_ns == 1 ) THEN 739 ! 740 !-- Particle absorption 741 particles(n)%particle_mask = .FALSE. 742 deleted_particles = deleted_particles + 1 743 744 ELSEIF ( ibc_par_ns == 2 ) THEN 745 ! 746 !-- Particle reflection 747 particles(n)%y = ( ny + 1 ) * dy - particles(n)%y 748 particles(n)%speed_y = -particles(n)%speed_y 749 ENDIF 750 751 ENDIF 661 DO ip = nxl, nxr, nxr-nxl 662 DO jp = nys, nyn 663 DO kp = nzb+1, nzt 664 number_of_particles = prt_count(kp,jp,ip) 665 IF ( number_of_particles <= 0 ) CYCLE 666 particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles) 667 DO n = 1, number_of_particles 668 ! 669 !-- Apply boundary conditions 670 671 IF ( particles(n)%x < -0.5_wp * dx ) THEN 672 673 IF ( ibc_par_lr == 0 ) THEN 674 ! 675 !-- Cyclic boundary. Relevant coordinate has to be changed. 676 particles(n)%x = ( nx + 1 ) * dx + particles(n)%x 677 678 ELSEIF ( ibc_par_lr == 1 ) THEN 679 ! 680 !-- Particle absorption 681 particles(n)%particle_mask = .FALSE. 682 deleted_particles = deleted_particles + 1 683 684 ELSEIF ( ibc_par_lr == 2 ) THEN 685 ! 686 !-- Particle reflection 687 particles(n)%x = -dx - particles(n)%x 688 particles(n)%speed_x = -particles(n)%speed_x 689 ENDIF 690 691 ELSEIF ( particles(n)%x >= ( nx + 0.5_wp ) * dx ) THEN 692 693 IF ( ibc_par_lr == 0 ) THEN 694 ! 695 !-- Cyclic boundary. Relevant coordinate has to be changed. 696 particles(n)%x = particles(n)%x - ( nx + 1 ) * dx 697 698 ELSEIF ( ibc_par_lr == 1 ) THEN 699 ! 700 !-- Particle absorption 701 particles(n)%particle_mask = .FALSE. 702 deleted_particles = deleted_particles + 1 703 704 ELSEIF ( ibc_par_lr == 2 ) THEN 705 ! 706 !-- Particle reflection 707 particles(n)%x = ( nx + 1 ) * dx - particles(n)%x 708 particles(n)%speed_x = -particles(n)%speed_x 709 ENDIF 710 711 ENDIF 712 ENDDO 713 ENDDO 714 ENDDO 752 715 ENDDO 753 716 717 DO ip = nxl, nxr 718 DO jp = nys, nyn, nyn-nys 719 DO kp = nzb+1, nzt 720 number_of_particles = prt_count(kp,jp,ip) 721 IF ( number_of_particles <= 0 ) CYCLE 722 particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles) 723 DO n = 1, number_of_particles 724 725 IF ( particles(n)%y < -0.5_wp * dy ) THEN 726 727 IF ( ibc_par_ns == 0 ) THEN 728 ! 729 !-- Cyclic boundary. Relevant coordinate has to be changed. 730 particles(n)%y = ( ny + 1 ) * dy + particles(n)%y 731 732 ELSEIF ( ibc_par_ns == 1 ) THEN 733 ! 734 !-- Particle absorption 735 particles(n)%particle_mask = .FALSE. 736 deleted_particles = deleted_particles + 1 737 738 ELSEIF ( ibc_par_ns == 2 ) THEN 739 ! 740 !-- Particle reflection 741 particles(n)%y = -dy - particles(n)%y 742 particles(n)%speed_y = -particles(n)%speed_y 743 ENDIF 744 745 ELSEIF ( particles(n)%y >= ( ny + 0.5_wp ) * dy ) THEN 746 747 IF ( ibc_par_ns == 0 ) THEN 748 ! 749 !-- Cyclic boundary. Relevant coordinate has to be changed. 750 particles(n)%y = particles(n)%y - ( ny + 1 ) * dy 751 752 ELSEIF ( ibc_par_ns == 1 ) THEN 753 ! 754 !-- Particle absorption 755 particles(n)%particle_mask = .FALSE. 756 deleted_particles = deleted_particles + 1 757 758 ELSEIF ( ibc_par_ns == 2 ) THEN 759 ! 760 !-- Particle reflection 761 particles(n)%y = ( ny + 1 ) * dy - particles(n)%y 762 particles(n)%speed_y = -particles(n)%speed_y 763 ENDIF 764 765 ENDIF 766 767 ENDDO 768 ENDDO 769 ENDDO 770 ENDDO 754 771 #endif 755 772 … … 782 799 IMPLICIT NONE 783 800 784 INTEGER(iwp) :: ip !< 785 INTEGER(iwp) :: jp !< 786 INTEGER(iwp) :: kp !< 787 INTEGER(iwp) :: n !< 788 INTEGER(iwp) :: pindex !< 801 INTEGER(iwp) :: ip !< grid index (x) of particle 802 INTEGER(iwp) :: jp !< grid index (x) of particle 803 INTEGER(iwp) :: kp !< grid index (x) of particle 804 INTEGER(iwp) :: n !< index variable of particle 805 INTEGER(iwp) :: pindex !< dummy argument for new number of particles per grid box 789 806 790 807 LOGICAL :: pack_done !< 791 808 792 TYPE(particle_type), DIMENSION(:), INTENT(IN) :: particle_array 809 TYPE(particle_type), DIMENSION(:), INTENT(IN) :: particle_array !< new particles in a grid box 810 TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: temp_ns !< temporary particle array for reallocation 793 811 794 812 pack_done = .FALSE. 795 813 796 nr_move_north = 0797 nr_move_south = 0798 799 814 DO n = 1, SIZE(particle_array) 815 816 IF ( .NOT. particle_array(n)%particle_mask ) CYCLE 817 800 818 ip = ( particle_array(n)%x + 0.5_wp * dx ) * ddx 801 819 jp = ( particle_array(n)%y + 0.5_wp * dy ) * ddy 802 kp = particle_array(n)%z / dz + 1 + offset_ocean_nzt820 kp = particle_array(n)%z / dz + 1 + offset_ocean_nzt 803 821 804 822 IF ( ip >= nxl .AND. ip <= nxr .AND. jp >= nys .AND. jp <= nyn & … … 824 842 prt_count(kp,jp,ip) = pindex 825 843 ELSE 826 IF ( jp == nys - 1 ) THEN844 IF ( jp <= nys - 1 ) THEN 827 845 nr_move_south = nr_move_south+1 846 ! 847 !-- Before particle information is swapped to exchange-array, check 848 !-- if enough memory is allocated. If required, reallocate exchange 849 !-- array. 850 IF ( nr_move_south > SIZE(move_also_south) ) THEN 851 ! 852 !-- At first, allocate further temporary array to swap particle 853 !-- information. 854 ALLOCATE( temp_ns(SIZE(move_also_south)+NR_2_direction_move) ) 855 temp_ns(1:nr_move_south-1) = move_also_south(1:nr_move_south-1) 856 DEALLOCATE( move_also_south ) 857 ALLOCATE( move_also_south(SIZE(temp_ns)) ) 858 move_also_south(1:nr_move_south-1) = temp_ns(1:nr_move_south-1) 859 DEALLOCATE( temp_ns ) 860 861 ENDIF 862 828 863 move_also_south(nr_move_south) = particle_array(n) 864 829 865 IF ( jp == -1 ) THEN 830 866 move_also_south(nr_move_south)%y = & … … 833 869 move_also_south(nr_move_south)%origin_y + ( ny + 1 ) * dy 834 870 ENDIF 835 ELSEIF ( jp == nyn+1 ) THEN871 ELSEIF ( jp >= nyn+1 ) THEN 836 872 nr_move_north = nr_move_north+1 873 ! 874 !-- Before particle information is swapped to exchange-array, check 875 !-- if enough memory is allocated. If required, reallocate exchange 876 !-- array. 877 IF ( nr_move_north > SIZE(move_also_north) ) THEN 878 ! 879 !-- At first, allocate further temporary array to swap particle 880 !-- information. 881 ALLOCATE( temp_ns(SIZE(move_also_north)+NR_2_direction_move) ) 882 temp_ns(1:nr_move_north-1) = move_also_south(1:nr_move_north-1) 883 DEALLOCATE( move_also_north ) 884 ALLOCATE( move_also_north(SIZE(temp_ns)) ) 885 move_also_north(1:nr_move_north-1) = temp_ns(1:nr_move_north-1) 886 DEALLOCATE( temp_ns ) 887 888 ENDIF 889 837 890 move_also_north(nr_move_north) = particle_array(n) 838 891 IF ( jp == ny+1 ) THEN … … 867 920 IMPLICIT NONE 868 921 869 INTEGER(iwp) :: i !< 870 INTEGER(iwp) :: ip !< 871 INTEGER(iwp) :: j !< 872 INTEGER(iwp) :: jp !< 873 INTEGER(iwp) :: k !< 874 INTEGER(iwp) :: kp !< 875 INTEGER(iwp) :: n !< 876 INTEGER(iwp) :: np_old_cell !< 877 INTEGER(iwp) :: n_start !< 878 INTEGER(iwp) :: pindex !< 922 INTEGER(iwp) :: i !< grid index (x) of particle position 923 INTEGER(iwp) :: ip !< index variable along x 924 INTEGER(iwp) :: j !< grid index (y) of particle position 925 INTEGER(iwp) :: jp !< index variable along y 926 INTEGER(iwp) :: k !< grid index (z) of particle position 927 INTEGER(iwp) :: kp !< index variable along z 928 INTEGER(iwp) :: n !< index variable for particle array 929 INTEGER(iwp) :: np_old_cell !< number of particles per grid box before moving 930 INTEGER(iwp) :: n_start !< start index 931 INTEGER(iwp) :: pindex !< dummy argument for number of new particle per grid box 879 932 880 933 LOGICAL :: pack_done !< 881 934 882 TYPE(particle_type), DIMENSION(:), POINTER :: particles_old_cell !< 935 TYPE(particle_type), DIMENSION(:), POINTER :: particles_old_cell !< particles before moving 883 936 884 937 CALL cpu_log( log_point_s(41), 'lpm_move_particle', 'start' ) … … 947 1000 IF ( pack_done ) THEN 948 1001 CALL realloc_particles_array(i,j,k) 949 pindex = prt_count(k,j,i)+1950 1002 ELSE 951 1003 CALL lpm_pack_arrays 952 1004 prt_count(k,j,i) = number_of_particles 953 954 pindex = prt_count(k,j,i)+1955 1005 ! 956 1006 !-- If number of particles in the new grid box … … 959 1009 IF ( pindex > SIZE(grid_particles(k,j,i)%particles) ) THEN 960 1010 CALL realloc_particles_array(i,j,k) 961 pindex = prt_count(k,j,i)+1962 1011 ENDIF 963 1012 … … 987 1036 ! Description: 988 1037 ! ------------ 989 !> @todo Missing subroutine description. 1038 !> If the allocated memory for the particle array do not suffice to add arriving 1039 !> particles from neighbour grid cells, this subrouting reallocates the 1040 !> particle array to assure enough memory is available. 990 1041 !------------------------------------------------------------------------------! 991 1042 SUBROUTINE realloc_particles_array (i,j,k,size_in) … … 1012 1063 ENDIF 1013 1064 1014 new_size = MAX( new_size, min_nr_particle )1065 new_size = MAX( new_size, min_nr_particle, old_size + 1 ) 1015 1066 1016 1067 IF ( old_size <= 500 ) THEN
Note: See TracChangeset
for help on using the changeset viewer.
