Changeset 3241 for palm/trunk/SOURCE/pmc_particle_interface.f90
- Timestamp:
- Sep 12, 2018 3:02:00 PM (6 years ago)
- File:
-
- 1 edited
-
palm/trunk/SOURCE/pmc_particle_interface.f90 (modified) (6 diffs)
Legend:
- Unmodified
- Added
- Removed
-
palm/trunk/SOURCE/pmc_particle_interface.f90
r3123 r3241 26 26 ! -----------------! 27 27 ! $Id$ 28 ! unused variables removed 29 ! 30 ! 3123 2018-07-12 16:21:53Z suehring 28 31 ! Correct working precision for REAL numbers 29 32 ! … … 519 522 INTEGER(iwp) :: child_id !< id of the child model 520 523 INTEGER(iwp) :: i !< x grid box index 521 INTEGER(iwp) :: ierr !< error code522 524 INTEGER(iwp) :: ij !< combined xy index for the buffer array 523 525 INTEGER(iwp) :: ip !< loop index (child PEs) … … 530 532 INTEGER(iwp) :: pindex !< 531 533 INTEGER(iwp) :: tot_particle_count !< Total number of particles per child 532 533 REAL(wp) :: dx_child !< child grid spacing534 REAL(wp) :: dy_child !< child grid spacing535 REAL(wp) :: dz_child !< child grid spacing536 REAL(wp) :: ny_coord !< north coordinate of child grid537 REAL(wp) :: ny_coord_b !< north coordinate of child grid boundary538 REAL(wp) :: lx_coord !< left coordinate of child grid539 REAL(wp) :: lx_coord_b !< left coordinate of child grid boundary540 REAL(wp) :: rx_coord !< right coordinate of child grid541 REAL(wp) :: rx_coord_b !< right coordinate of child grid boundary542 REAL(wp) :: sy_coord !< south coordinate of child grid543 REAL(wp) :: sy_coord_b !< south coordinate of child grid boundary544 REAL(wp) :: uz_coord !< upper coordinate of child grid545 REAL(wp) :: uz_coord_b !< upper coordinate of child grid boundary546 REAL(wp) :: x !< particle position547 REAL(wp) :: xo !< origin of particle548 REAL(wp) :: y !< particle position549 REAL(wp) :: yo !< origin of particle550 REAL(wp) :: z !< particle position551 552 INTEGER(iwp),DIMENSION(1) :: buf_shape !<553 554 #if defined( __parallel )555 TYPE(pedef), POINTER :: ape !< TO_DO Klaus: give a description and better name of the variable556 557 DO m = 1, get_number_of_childs()558 559 child_id = get_childid(m)560 561 CALL get_child_edges( m, lx_coord, lx_coord_b, rx_coord, rx_coord_b, &562 sy_coord, sy_coord_b, ny_coord, ny_coord_b, &563 uz_coord, uz_coord_b)564 565 CALL get_child_gridspacing( m, dx_child, dy_child, dz_child )566 567 IF ( lfirst ) THEN568 WRITE(9,'(a,5f10.2)') 'edges ',lx_coord,rx_coord,sy_coord,ny_coord,uz_coord569 WRITE(9,'(a,5f10.2)') 'edges boundary ',lx_coord_b,rx_coord_b,sy_coord_b,ny_coord_b,uz_coord_b570 WRITE(9,'(a,5f10.2)') 'child spacing ',dx_child, dy_child, dz_child,lower_left_coord_x,lower_left_coord_y571 ENDIF572 !573 !-- reset values for every child574 tot_particle_count = 0575 nr_part = 0576 part_adr = 0577 pindex = 1578 579 buf_shape(1) = max_nr_particle_in_rma_win580 CALL C_F_POINTER( buf_ptr(m), particle_in_win , buf_shape )581 582 DO ip = 1, children(child_id)%inter_npes583 584 ape => children(child_id)%pes(ip)585 586 nr_part_col = 0587 588 DO ij = 1, ape%nrele589 590 !591 !-- Inside the PMC adressing of 3d arrays starts with 1592 i = ape%locind(ij)%i + nxl - nbgp - 1593 j = ape%locind(ij)%j + nys - nbgp - 1594 nr_part_col = 0 ! Number of particles to transfer per column595 part_adr(j,i) = pindex596 597 DO k = nzb + 1, nzt598 number_of_particles = prt_count(k,j,i)599 600 IF ( number_of_particles <= 0 ) CYCLE601 602 particles => grid_particles(k,j,i)%particles(1:number_of_particles)603 604 ! Select particles within boundary area605 606 DO n = 1, number_of_particles607 x = particles(n)%x608 y = particles(n)%y609 z = particles(n)%z610 !611 !-- check if the particle is located in the fine grid area612 active_particle = ((x > lx_coord .AND. x < rx_coord) .AND. &613 (y > sy_coord .AND. y < ny_coord) .AND. &614 (z > 0.000000001 .AND. z < uz_coord))615 IF ( active_particle .AND. particles(n)%particle_mask ) THEN616 617 particle_in_win(pindex) = particles(n)618 !619 !-- Change particle positions and origin relative to global origin620 particle_in_win(pindex)%x = particle_in_win(pindex)%x + lower_left_coord_x621 particle_in_win(pindex)%y = particle_in_win(pindex)%y + lower_left_coord_y622 particle_in_win(pindex)%origin_x = particle_in_win(pindex)%origin_x + lower_left_coord_x623 particle_in_win(pindex)%origin_y = particle_in_win(pindex)%origin_y + lower_left_coord_y624 625 tot_particle_count = tot_particle_count + 1626 nr_part_col = nr_part_col + 1627 pindex = pindex + 1628 IF ( pindex > max_nr_particle_in_rma_win ) THEN629 WRITE(9,*) 'RMA window too small on parent ',pindex, max_nr_particle_in_rma_win630 message_string = 'RMA window too small on parent'631 CALL message( 'pmci_create_child_arrays', 'PA0481', 3, 2, 0, 6, 0 ) ! PA number has to be adjusted632 ENDIF633 END IF634 ENDDO635 ENDDO636 nr_part(j,i) = nr_part_col637 ENDDO638 ENDDO639 640 CALL pmc_s_fillbuffer( child_id, particle_transfer = .TRUE. )641 ENDDO642 643 lfirst = .FALSE.644 645 #endif646 END SUBROUTINE pmcp_p_fill_particle_win647 648 649 !------------------------------------------------------------------------------!650 ! Description:651 ! ------------652 !> parent routine:653 !> delete particles from the MPI window654 !------------------------------------------------------------------------------!655 SUBROUTINE pmcp_p_empty_particle_win656 657 IMPLICIT NONE658 659 INTEGER(iwp) :: child_id !< model id of the child660 INTEGER(iwp) :: ip !< loop index (child PEs)661 INTEGER(iwp) :: m !< loop index (number of childs)662 663 INTEGER(iwp),DIMENSION(1) :: buf_shape !<664 665 #if defined( __parallel )666 DO m = 1, get_number_of_childs()667 668 child_id = get_childid(m)669 670 buf_shape(1) = max_nr_particle_in_rma_win671 CALL C_F_POINTER( buf_ptr(m), particle_in_win , buf_shape )672 673 !674 !-- In some cells of the coarse grid, there are contributions from more than one child process675 !-- Therfore p_copy_particle_to_org_grid is done for one child process per call676 677 DO ip = 1, pmc_s_get_child_npes( child_id )678 nr_part = 0679 part_adr = 0680 681 CALL pmc_s_getdata_from_buffer( child_id, particle_transfer = .TRUE., child_process_nr = ip )682 683 CALL p_copy_particle_to_org_grid( m, child_id )684 ENDDO685 686 ENDDO687 688 #endif689 END SUBROUTINE pmcp_p_empty_particle_win690 691 692 !------------------------------------------------------------------------------!693 ! Description:694 ! ------------695 !> parent routine:696 !> After the transfer mark all parent particles that are still inside on of the697 !> child areas for deletion.698 !------------------------------------------------------------------------------!699 SUBROUTINE pmcp_p_delete_particles_in_fine_grid_area700 701 IMPLICIT NONE702 703 LOGICAL :: to_delete !< particles outside of model domain are marked as to_delete704 705 INTEGER(iwp) :: i !< loop index (x grid)706 INTEGER(iwp) :: j !< loop index (y grid)707 INTEGER(iwp) :: k !< loop index (z grid)708 INTEGER(iwp) :: m !< loop index (number of particles)709 INTEGER(iwp) :: n !< loop index (number of childs)710 534 711 535 REAL(wp) :: dx_child !< child grid spacing … … 725 549 REAL(wp) :: y !< particle position 726 550 REAL(wp) :: z !< particle position 551 552 INTEGER(iwp),DIMENSION(1) :: buf_shape !< 553 554 #if defined( __parallel ) 555 TYPE(pedef), POINTER :: ape !< TO_DO Klaus: give a description and better name of the variable 556 557 DO m = 1, get_number_of_childs() 558 559 child_id = get_childid(m) 560 561 CALL get_child_edges( m, lx_coord, lx_coord_b, rx_coord, rx_coord_b, & 562 sy_coord, sy_coord_b, ny_coord, ny_coord_b, & 563 uz_coord, uz_coord_b) 564 565 CALL get_child_gridspacing( m, dx_child, dy_child, dz_child ) 566 567 IF ( lfirst ) THEN 568 WRITE(9,'(a,5f10.2)') 'edges ',lx_coord,rx_coord,sy_coord,ny_coord,uz_coord 569 WRITE(9,'(a,5f10.2)') 'edges boundary ',lx_coord_b,rx_coord_b,sy_coord_b,ny_coord_b,uz_coord_b 570 WRITE(9,'(a,5f10.2)') 'child spacing ',dx_child, dy_child, dz_child,lower_left_coord_x,lower_left_coord_y 571 ENDIF 572 ! 573 !-- reset values for every child 574 tot_particle_count = 0 575 nr_part = 0 576 part_adr = 0 577 pindex = 1 578 579 buf_shape(1) = max_nr_particle_in_rma_win 580 CALL C_F_POINTER( buf_ptr(m), particle_in_win , buf_shape ) 581 582 DO ip = 1, children(child_id)%inter_npes 583 584 ape => children(child_id)%pes(ip) 585 586 nr_part_col = 0 587 588 DO ij = 1, ape%nrele 589 590 ! 591 !-- Inside the PMC adressing of 3d arrays starts with 1 592 i = ape%locind(ij)%i + nxl - nbgp - 1 593 j = ape%locind(ij)%j + nys - nbgp - 1 594 nr_part_col = 0 ! Number of particles to transfer per column 595 part_adr(j,i) = pindex 596 597 DO k = nzb + 1, nzt 598 number_of_particles = prt_count(k,j,i) 599 600 IF ( number_of_particles <= 0 ) CYCLE 601 602 particles => grid_particles(k,j,i)%particles(1:number_of_particles) 603 604 ! Select particles within boundary area 605 606 DO n = 1, number_of_particles 607 x = particles(n)%x 608 y = particles(n)%y 609 z = particles(n)%z 610 ! 611 !-- check if the particle is located in the fine grid area 612 active_particle = ((x > lx_coord .AND. x < rx_coord) .AND. & 613 (y > sy_coord .AND. y < ny_coord) .AND. & 614 (z > 0.000000001 .AND. z < uz_coord)) 615 IF ( active_particle .AND. particles(n)%particle_mask ) THEN 616 617 particle_in_win(pindex) = particles(n) 618 ! 619 !-- Change particle positions and origin relative to global origin 620 particle_in_win(pindex)%x = particle_in_win(pindex)%x + lower_left_coord_x 621 particle_in_win(pindex)%y = particle_in_win(pindex)%y + lower_left_coord_y 622 particle_in_win(pindex)%origin_x = particle_in_win(pindex)%origin_x + lower_left_coord_x 623 particle_in_win(pindex)%origin_y = particle_in_win(pindex)%origin_y + lower_left_coord_y 624 625 tot_particle_count = tot_particle_count + 1 626 nr_part_col = nr_part_col + 1 627 pindex = pindex + 1 628 IF ( pindex > max_nr_particle_in_rma_win ) THEN 629 WRITE(9,*) 'RMA window too small on parent ',pindex, max_nr_particle_in_rma_win 630 message_string = 'RMA window too small on parent' 631 CALL message( 'pmci_create_child_arrays', 'PA0481', 3, 2, 0, 6, 0 ) ! PA number has to be adjusted 632 ENDIF 633 END IF 634 ENDDO 635 ENDDO 636 nr_part(j,i) = nr_part_col 637 ENDDO 638 ENDDO 639 640 CALL pmc_s_fillbuffer( child_id, particle_transfer = .TRUE. ) 641 ENDDO 642 643 lfirst = .FALSE. 644 645 #endif 646 END SUBROUTINE pmcp_p_fill_particle_win 647 648 649 !------------------------------------------------------------------------------! 650 ! Description: 651 ! ------------ 652 !> parent routine: 653 !> delete particles from the MPI window 654 !------------------------------------------------------------------------------! 655 SUBROUTINE pmcp_p_empty_particle_win 656 657 IMPLICIT NONE 658 659 INTEGER(iwp) :: child_id !< model id of the child 660 INTEGER(iwp) :: ip !< loop index (child PEs) 661 INTEGER(iwp) :: m !< loop index (number of childs) 662 663 INTEGER(iwp),DIMENSION(1) :: buf_shape !< 664 665 #if defined( __parallel ) 666 DO m = 1, get_number_of_childs() 667 668 child_id = get_childid(m) 669 670 buf_shape(1) = max_nr_particle_in_rma_win 671 CALL C_F_POINTER( buf_ptr(m), particle_in_win , buf_shape ) 672 673 ! 674 !-- In some cells of the coarse grid, there are contributions from more than 675 !-- one child process. Therefore p_copy_particle_to_org_grid is done for one 676 !-- child process per call 677 DO ip = 1, pmc_s_get_child_npes( child_id ) 678 679 nr_part = 0 680 part_adr = 0 681 682 CALL pmc_s_getdata_from_buffer( child_id, particle_transfer = .TRUE.,& 683 child_process_nr = ip ) 684 CALL p_copy_particle_to_org_grid( m ) 685 ENDDO 686 687 ENDDO 688 689 #endif 690 END SUBROUTINE pmcp_p_empty_particle_win 691 692 693 !------------------------------------------------------------------------------! 694 ! Description: 695 ! ------------ 696 !> parent routine: 697 !> After the transfer mark all parent particles that are still inside on of the 698 !> child areas for deletion. 699 !------------------------------------------------------------------------------! 700 SUBROUTINE pmcp_p_delete_particles_in_fine_grid_area 701 702 IMPLICIT NONE 703 704 LOGICAL :: to_delete !< particles outside of model domain are marked as to_delete 705 706 INTEGER(iwp) :: i !< loop index (x grid) 707 INTEGER(iwp) :: j !< loop index (y grid) 708 INTEGER(iwp) :: k !< loop index (z grid) 709 INTEGER(iwp) :: m !< loop index (number of particles) 710 INTEGER(iwp) :: n !< loop index (number of childs) 711 712 REAL(wp) :: dx_child !< child grid spacing 713 REAL(wp) :: dy_child !< child grid spacing 714 REAL(wp) :: dz_child !< child grid spacing 715 REAL(wp) :: ny_coord !< north coordinate of child grid 716 REAL(wp) :: ny_coord_b !< north coordinate of child grid boundary 717 REAL(wp) :: lx_coord !< left coordinate of child grid 718 REAL(wp) :: lx_coord_b !< left coordinate of child grid boundary 719 REAL(wp) :: rx_coord !< right coordinate of child grid 720 REAL(wp) :: rx_coord_b !< right coordinate of child grid boundary 721 REAL(wp) :: sy_coord !< south coordinate of child grid 722 REAL(wp) :: sy_coord_b !< south coordinate of child grid boundary 723 REAL(wp) :: uz_coord !< upper coordinate of child grid 724 REAL(wp) :: uz_coord_b !< upper coordinate of child grid boundary 725 REAL(wp) :: x !< particle position 726 REAL(wp) :: y !< particle position 727 REAL(wp) :: z !< particle position 727 728 728 729 #if defined( __parallel ) … … 951 952 ENDIF 952 953 coarse_particles(jc,ic)%parent_particles(n)%x = xc ! Adjust coordinates to child grid 953 954 coarse_particles(jc,ic)%parent_particles(n)%y = yc 954 955 coarse_particles(jc,ic)%parent_particles(n)%origin_x = xoc ! Adjust origins to child grid 955 956 coarse_particles(jc,ic)%parent_particles(n)%origin_y = yoc … … 1086 1087 !> copy/sort particles from the MPI window into the respective grid boxes 1087 1088 !------------------------------------------------------------------------------! 1088 SUBROUTINE p_copy_particle_to_org_grid( m , child_id)1089 SUBROUTINE p_copy_particle_to_org_grid( m ) 1089 1090 1090 1091 IMPLICIT NONE 1091 1092 1092 INTEGER(iwp),INTENT(IN) :: child_id !<1093 1093 INTEGER(iwp),INTENT(IN) :: m !< 1094 1094
Note: See TracChangeset
for help on using the changeset viewer.
