Changeset 3962 for palm/trunk/SOURCE/pmc_child_mod.f90
- Timestamp:
- May 8, 2019 7:40:33 PM (5 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
palm/trunk/SOURCE/pmc_child_mod.f90
r3945 r3962 22 22 ! ------------------ 23 23 ! 24 ! 24 ! 25 25 ! Former revisions: 26 26 ! ----------------- 27 27 ! $Id$ 28 ! Bugfixes in initial settings of child and parent communication patterns. 29 ! 30 ! 3945 2019-05-02 11:29:27Z raasch 28 31 ! 29 32 ! 3932 2019-04-24 17:31:34Z suehring … … 583 586 !-- recv -> parent to child transfer 584 587 !-- send -> child to parent transfer 585 INTEGER(iwp) :: arlen !< 586 INTEGER(iwp) :: myindex !< 587 INTEGER(iwp) :: i !< 588 INTEGER(iwp) :: ierr !< 589 INTEGER(iwp) :: istat !< 590 INTEGER(iwp) :: j !< 591 INTEGER(iwp) :: rcount !< 592 INTEGER(iwp) :: tag !< 588 INTEGER(iwp) :: arlen !< 589 INTEGER(iwp) :: myindex !< 590 INTEGER(iwp) :: i !< 591 INTEGER(iwp) :: ierr !< 592 INTEGER(iwp) :: istat !< 593 INTEGER(iwp) :: j !< 594 INTEGER(iwp) :: lo_nr_arrays !< 595 INTEGER(iwp) :: rcount !< 596 INTEGER(iwp) :: tag !< 597 INTEGER(iwp) :: total_npes !< 593 598 594 599 INTEGER(iwp), PARAMETER :: noindex = -1 !< … … 596 601 INTEGER(idp) :: bufsize !< size of MPI data window 597 602 INTEGER(KIND=MPI_ADDRESS_KIND) :: winsize !< 603 604 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: myindex_s 605 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: myindex_r 598 606 599 607 INTEGER(iwp),DIMENSION(1024) :: req !< … … 606 614 Type(C_PTR) :: base_ptr !< 607 615 616 617 CALL MPI_COMM_SIZE (me%intra_comm, total_npes, ierr) 618 619 lo_nr_arrays = me%pes(1)%nr_arrays 620 621 ALLOCATE(myindex_s(lo_nr_arrays,0:total_npes-1)) 622 ALLOCATE(myindex_r(lo_nr_arrays,0:total_npes-1)) 623 624 myindex_s = 0 625 626 ! 627 !-- Receive indices from child 628 CALL MPI_ALLTOALL( myindex_s, lo_nr_arrays, MPI_INTEGER, & 629 myindex_r, lo_nr_arrays, MPI_INTEGER, & 630 me%intra_comm, ierr ) 608 631 609 632 myindex = 0 … … 614 637 DO i = 1, me%inter_npes 615 638 ape => me%pes(i) 616 tag = 200617 639 DO j = 1, ape%nr_arrays 618 640 ar => ape%array_list(j) 619 ! 620 !-- Receive index from child 621 tag = tag + 1 622 CALL MPI_RECV( myindex, 1, MPI_INTEGER, i-1, tag, me%inter_comm, & 623 MPI_STATUS_IGNORE, ierr ) 624 ar%recvindex = myindex 641 ar%recvindex = myindex_r(j,i-1) 625 642 ! 626 643 !-- Determine max, because child buffer is allocated only once … … 637 654 ENDDO 638 655 ENDDO 656 639 657 ! 640 658 !-- Create RMA (one sided communication) data buffer. … … 657 675 rcount = 0 658 676 bufsize = 8 677 678 myindex_s = 0 679 myindex_r = 0 659 680 660 681 DO i = 1, me%inter_npes … … 668 689 arlen = ape%nrele*ar%a_dim(1) 669 690 ENDIF 670 tag = tag + 1 671 rcount = rcount + 1 691 672 692 IF ( ape%nrele > 0 ) THEN 673 CALL MPI_ISEND( myindex, 1, MPI_INTEGER, i-1, tag, me%inter_comm, &674 req(rcount), ierr )675 693 ar%sendindex = myindex 676 694 ELSE 677 CALL MPI_ISEND( noindex, 1, MPI_INTEGER, i-1, tag, me%inter_comm, &678 req(rcount), ierr )679 695 ar%sendindex = noindex 680 696 ENDIF 681 ! 682 !-- Maximum of 1024 pending requests 683 ! 1024 is an arbitrary value just to make sure the number of pending 684 ! requests is getting too large. It is possible that this value has to 685 ! be adjusted in case of running the model on large number of cores. 686 687 IF ( rcount == 1024 ) THEN 688 CALL MPI_WAITALL( rcount, req, MPI_STATUSES_IGNORE, ierr ) 689 rcount = 0 690 ENDIF 697 698 myindex_s(j,i-1) = ar%sendindex 691 699 692 700 IF ( ape%nrele > 0 ) THEN … … 698 706 ENDDO 699 707 700 IF ( rcount > 0 ) THEN 701 CALL MPI_WAITALL( rcount, req, MPI_STATUSES_IGNORE, ierr ) 702 ENDIF 703 704 ENDDO 708 ENDDO 709 ! 710 !-- Send indices to parent 711 712 CALL MPI_ALLTOALL( myindex_s, lo_nr_arrays, MPI_INTEGER, & 713 myindex_r, lo_nr_arrays, MPI_INTEGER, & 714 me%intra_comm, ierr) 715 716 DEALLOCATE( myindex_s ) 717 DEALLOCATE( myindex_r ) 718 705 719 ! 706 720 !-- Create RMA (one sided communication) window for data buffer child to parent
Note: See TracChangeset
for help on using the changeset viewer.