NewIpe = .TRUE.      Num    = 0      Inc    = 0!! Parse through all the tags in the local segment      DO J = 1, SIZE( DB%Head(iam+1)%StartTags )        OldPe     = -1         ! Set PE undefined        DO Tag=DB%Head(iam+1)%StartTags(J), DB%Head(iam+1)%EndTags(J)!! Determine the index and PE of this entry on A. This might be inlined later!          CALL DecompGlobalToLocal( DA, Tag, Local, Pe )!! If ipe-1 is my id, then this is an entry ipe will receive from Pe!          IF ( Pe /= OldPe ) THEN            OldPe   = Pe            IF ( jb > 0 ) THEN              BlockSizesB(jb) = LenB              LenB = 0            ENDIF            jb = jb+1                     ! increment the segment index            DisplacementsB(jb) = Inc      ! Zero-based offset of local segment            LocalB(jb) = Local-1          ! The local index (zero-based)            PeB(jb) = Pe                  ! Note the ID of the sender            Count(Pe+1) = Count(Pe+1)+1 ! Increment counter of segments          ENDIF          LenB = LenB+1                   ! Good -- segment is getting longer          Inc = Inc+1                     ! Increment local index        ENDDO      ENDDO!! Clean up!      BlockSizesB(jb) = LenB#if defined(DEBUG_PARPATTERNDECOMPTODECOMP)      print *, iam, "BlockSizes", BlockSizesB(1:jb), DisplacementsB(1:jb), PeB(1:jb), Count#endif      CPP_ASSERT_F90( JB .LE. GlobalSize )!! Now create the pattern from the displacements and block sizes!      Inc = 0      DO ipe = 1, GroupSize!! Find the segments which are relevant for the sender ipe! Make compact arrays BlockSizes and Displacements !        DO j = 1, jb          IF ( PeB(j) == ipe-1 ) THEN            Inc = Inc + 1            BlockSizesA(Inc) = BlockSizesB(j)            DisplacementsA(Inc) = DisplacementsB(j)            LocalA(Inc)      = LocalB(j)          ENDIF        ENDDO      ENDDO!! Create the receiver communication pattern!      Off = 0      DO ipe = 1, GroupSize        Num = Count(ipe)#if defined(DEBUG_PARPATTERNDECOMPTODECOMP)        print *, "Receiver Iam", Iam, "Ipe", Ipe-1, "Num", Num,         &                 "Displacements", DisplacementsA(Off+1:Off+Num),        &                 "BlockSizes", BlockSizesA(Off+1:Off+Num)#endif#if defined( USE_ARENAS )        ALLOCATE( Pattern%RecvDesc(ipe)%Displacements(Num) )        ALLOCATE( Pattern%RecvDesc(ipe)%BlockSizes(Num) )        DO i=1, Num          Pattern%RecvDesc(ipe)%Displacements(i) = DisplacementsA(i+Off)          Pattern%RecvDesc(ipe)%BlockSizes(i)    = BlockSizesA(i+Off)        ENDDO#else        CALL MPI_TYPE_INDEXED( Num, BlockSizesA(Off+1),                 &                               DisplacementsA(Off+1),                   &                               CPP_MPI_REAL8, Ptr, Ierror )        Pattern%RecvDesc( ipe ) = Ptr#endif        Off = Off + Num      ENDDO!! Now communicate what the receiver is expecting from the sender!      CALL ParExchangeVectorInt( InComm, Count, LocalA,                 &                                 CountOut, DisplacementsB  )      CALL ParExchangeVectorInt( InComm, Count, BlockSizesA,            &                                 CountOut, BlockSizesB )!! Sender A: BlockSizes and Displacements can now be stored!      Off = 0      DO ipe=1, GroupSize        Num = CountOut(ipe)#if defined(DEBUG_PARPATTERNDECOMPTODECOMP)        print *, "Sender Iam", Iam, "Ipe", Ipe-1, "Num", Num,           &                 "Displacements", DisplacementsB(Off+1:Off+Num),        &                 "BlockSizes", BlockSizesB(Off+1:Off+Num)#endif#if defined( USE_ARENAS )        ALLOCATE( Pattern%SendDesc(ipe)%Displacements(Num) )        ALLOCATE( Pattern%SendDesc(ipe)%BlockSizes(Num) )        DO i=1, Num          Pattern%SendDesc(ipe)%Displacements(i) = DisplacementsB(i+Off)          Pattern%SendDesc(ipe)%BlockSizes(i)    = BlockSizesB(i+Off)        ENDDO#else        CALL MPI_TYPE_INDEXED( Num, BlockSizesB(Off+1),                 &                               DisplacementsB(Off+1),                   &                               CPP_MPI_REAL8, Ptr, Ierror )        Pattern%SendDesc( ipe ) = Ptr#endif        Off = Off + Num      ENDDO      DEALLOCATE( CountOut )      DEALLOCATE( Count )      DEALLOCATE( PeB )      DEALLOCATE( LocalB )      DEALLOCATE( BlockSizesB )      DEALLOCATE( DisplacementsB )      DEALLOCATE( LocalA )      DEALLOCATE( BlockSizesA )      DEALLOCATE( DisplacementsA )      CPP_LEAVE_PROCEDURE( "PARPATTERNDECOMPTODECOMP" )      RETURN!EOC      END SUBROUTINE ParPatternDecompToDecomp!-----------------------------------------------------------------------!-----------------------------------------------------------------------!BOP! !IROUTINE:   ParPatternDecompToGhost --- Create pattern decomp to ghost!! !INTERFACE:      SUBROUTINE ParPatternDecompToGhost( InComm, DA, GB, Pattern )!! !USES:      USE decompmodule, ONLY : DecompType, DecompGlobalToLocal,         &                               DecompInfo      USE ghostmodule, ONLY : GhostType, GhostInfo      IMPLICIT NONE! !INPUT PARAMETERS:      INTEGER,  INTENT( IN )               :: InComm  ! # of PEs      TYPE(DecompType),  INTENT( IN )      :: DA      ! Source Ghost Desc      TYPE(GhostType),  INTENT( IN )       :: GB      ! Target Ghost Desc! !OUTPUT PARAMETERS:      TYPE(ParPatternType), INTENT( OUT )  :: Pattern ! Comm Pattern!! !DESCRIPTION:!     This routine contructs a communication pattern for a transformation!     from decomposition to a ghosted decomposition, i.e., a so-called !     "transpose".  The resulting communication pattern can be used in !     ParBegin/EndTransfer with the decomposed arrays as inputs.  !! !SYSTEM ROUTINES:!! !BUGS:!     Under development!! !REVISION HISTORY:!   12.07.01   Sawyer     Creation from ParPatternDecompToDecomp!!EOP!-----------------------------------------------------------------------!BOC! !LOCAL VARIABLES:      LOGICAL NewIpe      INTEGER I, J, Tag, Local, Pe, LenB, JB, Ipe, Num, Inc, Off      INTEGER Ptr                                ! Pointer type      INTEGER GroupSize, Iam, Ierror      INTEGER OldPe, TotalPtsA, NpesA      INTEGER GlobalSizeB, LocalSizeB, BorderSizeB, NpesB      INTEGER, ALLOCATABLE :: Count(:)           ! # segments for each recv PE      INTEGER, ALLOCATABLE :: CountOut(:)        ! # segments for each send PE      INTEGER, ALLOCATABLE :: DisplacementsA(:)  ! Generic displacements      INTEGER, ALLOCATABLE :: BlockSizesA(:)     ! Generic block sizes      INTEGER, ALLOCATABLE :: LocalA(:)          ! Generic Local indices      INTEGER, ALLOCATABLE :: DisplacementsB(:)  ! Displacements for B      INTEGER, ALLOCATABLE :: BlockSizesB(:)     ! Block sizes for B      INTEGER, ALLOCATABLE :: LocalB(:)          ! Local indices for B      INTEGER, ALLOCATABLE :: PeB(:)             ! Processor element numbers      CPP_ENTER_PROCEDURE( "PARPATTERNDECOMPTOGHOST" )      CALL DecompInfo( DA, NpesA, TotalPtsA )      CALL GhostInfo( GB, NpesB, GlobalSizeB, LocalSizeB, BorderSizeB )#if defined( USE_ARENAS )! Communicator is assumed to be over all PEs for now      GroupSize = Gsize      Iam = gid      Pattern%Comm = 0#else      CALL MPI_COMM_SIZE( InComm, GroupSize, Ierror )      CALL MPI_COMM_RANK( InComm, Iam, Ierror )      CALL MPI_COMM_DUP( InComm, Pattern%Comm, Ierror )#endif      Pattern%Size = GroupSize      Pattern%Iam  = Iam!! Allocate the number of entries and list head arrays!      CPP_ASSERT_F90( NpesA .EQ. GroupSize )      CPP_ASSERT_F90( NpesB .EQ. GroupSize )!! Allocate the patterns!      ALLOCATE( Pattern%SendDesc( GroupSize ) )      ALLOCATE( Pattern%RecvDesc( GroupSize ) )!! Local allocations!      ALLOCATE( DisplacementsA( TotalPtsA ) )   ! Allocate for worst case      ALLOCATE( BlockSizesA( TotalPtsA ) )      ! Allocate for worst case      ALLOCATE( LocalA( TotalPtsA ) )           ! Allocate for worst case      ALLOCATE( DisplacementsB( GlobalSizeB ) ) ! Allocate for worst case      ALLOCATE( BlockSizesB( GlobalSizeB ) )    ! Allocate for worst case      ALLOCATE( LocalB( GlobalSizeB ) )         ! Allocate for worst case      ALLOCATE( PeB( GlobalSizeB ) )            ! Allocate for worst case      ALLOCATE( Count( GroupSize ) )      ALLOCATE( CountOut( GroupSize ) )      JB        = 0      Count     = 0      LenB      = 0      NewIpe = .TRUE.      Num    = 0      Inc    = 0!! Parse through all the tags in the local segment      DO J = 1, SIZE( GB%Local%Head(iam+1)%StartTags )        OldPe     = -1         ! Set PE undefined        DO Tag=GB%Local%Head(iam+1)%StartTags(J),                         &                GB%Local%Head(iam+1)%EndTags(J)!! Determine the index and PE of this entry on A. This might be inlined later!          CALL DecompGlobalToLocal( DA, Tag, Local, Pe )!! If ipe-1 is my id, then this is an entry ipe will receive from Pe!          IF ( Pe /= OldPe ) THEN            OldPe   = Pe            IF ( jb > 0 ) THEN              BlockSizesB(jb) = LenB              LenB = 0            ENDIF            jb = jb+1                     ! increment the segment index            DisplacementsB(jb) = Inc      ! Zero-based offset of local segment            LocalB(jb) = Local-1          ! Local indices (zero-based)            PeB(jb) = Pe                  ! Note the ID of the sender            Count(Pe+1) = Count(Pe+1)+1 ! Increment counter of segments          ENDIF          LenB = LenB+1                   ! Good -- segment is getting longer          Inc = Inc+1                     ! Increment local index        ENDDO      ENDDO!! Clean up!      BlockSizesB(jb) = LenB      CPP_ASSERT_F90( JB .LE. GlobalSize )!! Now create the pattern from the displacements and block sizes!      Inc = 0      DO ipe = 1, GroupSize!! Find the segments which are relevant for the sender ipe! Make compact arrays BlockSizes and Displacements !        DO j = 1, jb          IF ( PeB(j) == ipe-1 ) THEN            Inc = Inc + 1            BlockSizesA(Inc) = BlockSizesB(j)            DisplacementsA(Inc) = DisplacementsB(j)            LocalA(Inc)      = LocalB(j)          ENDIF        ENDDO      ENDDO      Off = 0      DO ipe = 1, GroupSize        Num = Count(ipe)        print *, "Receiver Iam", Iam, "Ipe", Ipe-1, "Num", Num, &                 "Displacements", DisplacementsA(Off+1:Off+Num), &                 "BlockSizes", BlockSizesA(Off+1:Off+Num)!! Create the receiver communication pattern!#if defined( USE_ARENAS )        ALLOCATE( Pattern%RecvDesc(ipe)%Displacements(Num) )        ALLOCATE( Pattern%RecvDesc(ipe)%BlockSizes(Num) )        DO i=1, Num          Pattern%RecvDesc(ipe)%Displacements(i) = DisplacementsA(i+Off)          Pattern%RecvDesc(ipe)%BlockSizes(i)    = BlockSizesA(i+Off)        ENDDO#else        CALL MPI_TYPE_INDEXED( Num, BlockSizesA(Off+1),DisplacementsA(Off+1), &     &                         CPP_MPI_REAL8, Ptr, Ierror )        Pattern%RecvDesc( ipe ) = Ptr#endif        Off = Off + Num      ENDDO!! Now communicate what the receiver is expecting to the sender!      CALL ParExchangeVectorInt( InComm, Count, LocalA,                 &     &                           CountOut, DisplacementsB  )      CALL ParExchangeVectorInt( InComm, Count, BlockSizesA,            &     &                           CountOut, BlockSizesB )!! Sender A: BlockSizes and Displacements can now be stored!      Off = 0      DO ipe=1, GroupSize        Num = CountOut(ipe)        print *, "Sender Iam", Iam, "Ipe", Ipe-1, "Num", Num,           &                 "Displacements", DisplacementsB(Off+1:Off+Num),        &                 "BlockSizes", BlockSizesB(Off+1:Off+Num)#if defined( USE_ARENAS )        ALLOCATE( Pattern%SendDesc(ipe)%Displacements(Num) )        ALLOCATE( Pattern%SendDesc(ipe)%BlockSizes(Num) )        DO i=1, Num          Pattern%SendDesc(ipe)%Displacements(i) = DisplacementsB(i+Off)          Pattern%SendDesc(ipe)%BlockSizes(i)    = BlockSizesB(i+Off)        ENDDO#else        CALL MPI_TYPE_INDEXED( Num, BlockSizesB(Off+1), DisplacementsB(Off+1),&                               CPP_MPI_REAL8, Ptr, Ierror )        Pattern%SendDesc( ipe ) = Ptr#endif      ENDDO      DEALLOCATE( CountOut )      DEALLOCATE( Count )      DEALLOCATE( PeB )      DEALLOCATE( LocalB )      DEALLOCATE( BlockSizesB )      DEALLOCATE( DisplacementsB )      DEALLOCATE( LocalA )      DEALLOCATE( BlockSizesA )      DEALLOCATE( DisplacementsA )      CPP_LEAVE_PROCEDURE( "PARPATTERNDECOMPTOGHOST" )      RETURN!EOC      END SUBROUTINE ParPatternDecompToGhost!-----------------------------------------------------------------------!-----------------------------------------------------------------------!BOP! !IROUTINE:   ParPatternGhostToDecomp --- Create pattern between decomps!! !INTERFACE:      SUBROUTINE ParPatternGhostToDecomp( InComm, GA, DB, Pattern )!! !USES: