redistributemodule.f90

来自「CCSM Research Tools: Community Atmospher」· F90 代码 · 共 506 行

#include <misc.h>
#include "pilgrim.h"
!-------------------------------------------------------------------------
!         NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS
!-------------------------------------------------------------------------
      MODULE redistributemodule
#if defined( SPMD )
!BOP
!
! !MODULE: redistributemodule
!
! !USES:
#include "debug.h"
      use precision, only: r8
      IMPLICIT NONE

!
! !DESCRIPTION:
!
!
! !REVISION HISTORY:
!   99.01.18   Sawyer     Creation
!   99.11.17   Sawyer     Added RedistributeStart, RedistributeFinish
!   00.07.20   Sawyer     Minor cosmetic changes
!   00.08.28   Sawyer     Accommodated change to ParEndTranfer interface
!   01.02.12   Sawyer     Converted to free format
!
! !PUBLIC TYPES:
      PUBLIC RedistributeType
      PUBLIC RedistributeCreate, RedistributeFree, RedistributePerform
      PUBLIC RedistributeStart, RedistributeFinish
 
! Redistribution info

      TYPE RedistributeType
        INTEGER, POINTER     :: CountA(:) ! Per PE counts in Decomp A
        INTEGER, POINTER     :: CountB(:) ! Per PE counts in Decomp B
        INTEGER, POINTER     :: PermA(:)  ! Permutation in Decomp A
        INTEGER, POINTER     :: PermB(:)  ! Permutation in Decomp B
      END TYPE RedistributeType
!EOP
      REAL(CPP_REAL8), ALLOCATABLE, SAVE :: InStatic(:), OutStatic(:)

      CONTAINS

!-----------------------------------------------------------------------
!BOP
! !IROUTINE: RedistributeCreate --- Create an inter-decomp. structure
!
! !INTERFACE:
      SUBROUTINE RedistributeCreate( DecompA, DecompB, Inter )
! !USES:
      USE decompmodule, ONLY:  DecompType, DecompGlobalToLocal
      USE parutilitiesmodule, ONLY:  GID, Gsize
      IMPLICIT NONE
#include "mpif.h"

!
! !INPUT PARAMETERS:
      TYPE(DecompType), INTENT( IN ) :: DecompA       ! Decomposition A
      TYPE(DecompType), INTENT( IN ) :: DecompB       ! Decomposition B

! !OUTPUT PARAMETERS:
      TYPE(RedistributeType), INTENT( OUT ) :: Inter  ! Inter info.

!
! !DESCRIPTION:
!
!     This routine constructs a RedistributeType structure which
!     can be efficiently used in the RedistributePerform routine.
!
! !SYSTEM ROUTINES:
!     ALLOCATE
!
! !REVISION HISTORY:
!   99.01.15   Sawyer     Creation
!
! !BUGS:
!    Currently untested.
!   
!EOP
!---------------------------------------------------------------------
!BOC
!
! !LOCAL VARIABLES:
      INTEGER IndexA, IndexB, I, J, K, Tag, Local, Pe, Offsets( Gsize )
      LOGICAL Found, First, Search

      CPP_ENTER_PROCEDURE( "REDISTRIBUTECREATE" )
!
! Allocate the number of entries and list head arrays
!
      CPP_ASSERT_F90( SIZE( DecompA%NumEntries ).EQ. Gsize )

      CPP_ASSERT_F90( SIZE( DecompB%NumEntries ).EQ. Gsize )

      ALLOCATE( Inter%CountA( Gsize ) )
      ALLOCATE( Inter%CountB( Gsize ) )

      ALLOCATE( Inter%PermA( DecompA%NumEntries( GID+1 ) ) )
      ALLOCATE( Inter%PermB( DecompB%NumEntries( GID+1 ) ) )

      Inter%CountA = 0
      Inter%CountB = 0
      IndexA       = 0
      IndexB       = 0

      DO I = 1, Gsize
        DO J = 1, SIZE( DecompB%Head(I)%StartTags )
          First = .TRUE.
          DO Tag=DecompB%Head(I)%StartTags(J),DecompB%Head(I)%EndTags(J)

!
! CODE INLINED FOR PERFORMANCE
!
!!!            CALL DecompGlobalToLocal( DecompA, Tag, Local, Pe )

            Search = .TRUE.
            IF ( .NOT. First )                                           &
              Search = First .OR. Tag .GT. DecompA%Head(Pe+1)%EndTags(K)

            IF ( Search ) THEN
              First = .FALSE.

!
! Search over all the PEs
!
              Pe = -1
              Found = .FALSE.
              DO WHILE ( .NOT. Found )
!
! Copy the number of entries on each PE
!
                Pe = Pe + 1
!
! Search through the local data segment
!
                Local = 1
                K = 1
                DO WHILE ( .NOT. Found .AND.                             &
                    K .LE. SIZE( DecompA%Head(Pe+1)%StartTags ) )
                  IF ( Tag .GE. DecompA%Head(Pe+1)%StartTags(K) .AND.    &
                       Tag .LE. DecompA%Head(Pe+1)%EndTags(K) ) THEN
                    Local = Local+Tag - DecompA%Head(Pe+1)%StartTags(K)
                    Found = .TRUE.
                  ELSE
                    Local = Local + DecompA%Head(Pe+1)%EndTags(K) -      &
                            DecompA%Head(Pe+1)%StartTags(K) + 1
                    K = K+1
                  ENDIF
                ENDDO
!
! Emergency brake
!
                IF ( Pe.EQ.(SIZE(DecompA%Head)-1).AND. .NOT.Found ) THEN
                  Found = .TRUE.
                  Local = 0
                  Pe    = -1
                ENDIF
              ENDDO
          
!
! END OF INLINING
!
            ELSE
              Local = Local + 1
            ENDIF
!
! Calculate the sorting permutation for A
!
            IF ( Pe .EQ. GID ) THEN
              Inter%CountA( I ) = Inter%CountA( I ) + 1
              IndexA = IndexA + 1
              Inter%PermA( IndexA ) = local
            ENDIF
!
! Calculate the sorting permutation for B
!
            IF ( I-1 .EQ. GID ) THEN
              Inter%CountB( Pe+1 ) = Inter%CountB( Pe+1 ) + 1
              IndexB = IndexB + 1
              Inter%PermB( IndexB ) = Inter%CountB( Pe+1 )*Gsize + Pe
            ENDIF
          ENDDO
        ENDDO
      ENDDO

!
! Finally decode PermB and add in the proper offsets
!
      Offsets = 0
      DO I=1, Gsize-1
        Offsets( I+1 ) = Offsets( I ) + Inter%CountB( I )
      ENDDO
      DO I=1, IndexB
        Pe = MOD( Inter%PermB( I ), Gsize )
        Inter%PermB( I ) = Inter%PermB(I)/Gsize + Offsets( Pe+1 )
      ENDDO
        
      CPP_LEAVE_PROCEDURE( "REDISTRIBUTECREATE" )
      RETURN
!EOC
      END SUBROUTINE RedistributeCreate
!-----------------------------------------------------------------------


!-----------------------------------------------------------------------
!BOP
! !IROUTINE: RedistributePerform --- Perform the Redistribution
!
! !INTERFACE:
      SUBROUTINE RedistributePerform( Inter, Forward, Input, Output )
! !USES:
      USE parutilitiesmodule, ONLY : CommGlobal, Gsize,                  &
                                     ParExchangeVector,GID
      IMPLICIT NONE

!
! !INPUT PARAMETERS:
      TYPE(RedistributeType), INTENT( INOUT ) :: Inter ! Inter info.
      LOGICAL             :: Forward     ! True: A -> B  False: B -> A
      REAL(CPP_REAL8), INTENT( IN )  :: Input( * )  ! Input Array
! !OUTPUT PARAMETERS:
      REAL(CPP_REAL8), INTENT( OUT ) :: Output( * ) ! Output Array
!
! !DESCRIPTION:
!
!     This routine performs the redistribution of Input to Output
!     according to the RedistributionType data structure Inter.
!     The redistribution can be from A -> B ("forward") or B -> A
!     ("backward").  This feature has been added to avoid the
!     need of a separate Inter (which requires considerable
!     memory) to perform the backward redistribution.
!
! !SYSTEM ROUTINES:
!     ALLOCATE, DEALLOCATE
!
! !BUGS:
!     Currently limited to the global communicator.
!
! !REVISION HISTORY:
!   99.01.15   Sawyer     Creation
!
!EOP
!-----------------------------------------------------------------------
!BOC

! !LOCAL VARIABLES:
      INTEGER I, Ierr, LenOutBuf( Gsize )
      REAL(CPP_REAL8), ALLOCATABLE :: InBuf(:), OutBuf(:)

      CPP_ENTER_PROCEDURE( "REDISTRIBUTEPERFORM" )

      IF ( Forward ) THEN
!
! Forward redistribution
!
        ALLOCATE( InBuf( SUM( Inter%CountA ) ) )
        ALLOCATE( OutBuf( SUM( Inter%CountB ) ) )
        DO I = 1, SUM( Inter%CountA )
          InBuf( I ) = Input( Inter%PermA( I ) )
        ENDDO

        CALL ParExchangeVector( CommGlobal, Inter%CountA, InBuf,         &
                                LenOutBuf, OutBuf )
        DO I = 1, SUM( Inter%CountB )
          Output( I ) = OutBuf( Inter%PermB( I ) )
        ENDDO
        DEALLOCATE( OutBuf )
        DEALLOCATE( InBuf )

      ELSE
!
! Backward redistribution
!
        ALLOCATE( InBuf( SUM( Inter%CountB ) ) )
        ALLOCATE( OutBuf( SUM( Inter%CountA ) ) )
        DO I = 1, SUM( Inter%CountB )
          InBuf( Inter%PermB( I ) ) = Input( I )
        ENDDO

        CALL ParExchangeVector( CommGlobal, Inter%CountB, InBuf,         &
                                LenOutBuf, OutBuf )
        DO I = 1, SUM( Inter%CountA )
          Output( Inter%PermA( I ) ) = OutBuf( I )
        ENDDO
        DEALLOCATE( OutBuf )
        DEALLOCATE( InBuf )
     
      ENDIF
      CPP_LEAVE_PROCEDURE( "REDISTRIBUTEPERFORM" )
      RETURN
!EOC
      END SUBROUTINE RedistributePerform
!-----------------------------------------------------------------------

!-----------------------------------------------------------------------
!BOP
! !IROUTINE: RedistributeFree --- Free an inter-decomp. structure
!
! !INTERFACE:
      SUBROUTINE RedistributeFree( Inter )
! !USES:
      IMPLICIT NONE
!
! !INPUT/OUTPUT PARAMETERS:
      TYPE(RedistributeType), INTENT( INOUT ) :: Inter ! Inter info.
!
! !DESCRIPTION:
!
!     This routine frees a RedistributeType structure.
!
! !SYSTEM ROUTINES:
!     DEALLOCATE
!
! !REVISION HISTORY:
!   99.01.15   Sawyer     Creation
!
! !BUGS:
!    Currently untested.
!   
!EOP
!-----------------------------------------------------------------------
!BOC

! !LOCAL VARIABLES:
      INTEGER Ierr

      CPP_ENTER_PROCEDURE( "REDISTRIBUTEFREE" )

      DEALLOCATE( Inter%PermB  )
      DEALLOCATE( Inter%PermA  )
      DEALLOCATE( Inter%CountB )
      DEALLOCATE( Inter%CountA )

      CPP_LEAVE_PROCEDURE( "REDISTRIBUTEFREE" )
      RETURN
!EOC
      END SUBROUTINE RedistributeFree
!-----------------------------------------------------------------------


!-----------------------------------------------------------------------
!BOP
! !IROUTINE: RedistributeStart --- Perform Asynchronous Redistribution
!
! !INTERFACE:
      SUBROUTINE RedistributeStart( Inter, Forward, Input )
! !USES:
      USE parutilitiesmodule, ONLY : CommGlobal, Gsize,                  &
                                     ParBeginTransfer,GID
      IMPLICIT NONE
!
! !INPUT PARAMETERS:
      TYPE(RedistributeType), INTENT( INOUT ) :: Inter ! Inter info.
      LOGICAL             :: Forward     ! True: A -> B  False: B -> A
      REAL(CPP_REAL8), INTENT( IN )  :: Input( * )  ! Input Array
!
! !DESCRIPTION:
!
!     This routine starts an asynchronous redistribution of Input 
!     to Output according to the RedistributionType data structure Inter.
!     The redistribution can be from A -> B ("forward") or B -> A
!     ("backward").  This feature has been added to avoid the
!     need of a separate Inter (which requires considerable
!     memory) to perform the backward redistribution.
!
!     Beware: both RedistributeStart and RedistributeFinish *must*
!     be called with the same values of Inter and Forward.  Nesting
!     of asynchronous distributions is forbidden.  In addition, any
!     other communication in the between RedistributeStart and
!     RedistributeFinish cannot used the communicator "CommGlobal" 
!     provided by parutilitiesmodule.
!
! !SYSTEM ROUTINES:
!     ALLOCATE
!
! !REVISION HISTORY:
!   99.11.17   Sawyer     Creation from RedistributePerform
!
! !BUGS:
!     Currently limited to the global communicator.
!   
!EOP
!-----------------------------------------------------------------------
!BOC

! !LOCAL VARIABLES:
      INTEGER I, Ierr, Dest( Gsize ), Src( Gsize )

      CPP_ENTER_PROCEDURE( "REDISTRIBUTESTART" )

      DO I = 1, Gsize
        Dest( I ) = I-1
        Src( I )  = I-1
      ENDDO

      IF ( Forward ) THEN
!
! Forward redistribution
!
        ALLOCATE( InStatic( SUM( Inter%CountA ) ) )
        ALLOCATE( OutStatic( SUM( Inter%CountB ) ) )
        DO I = 1, SUM( Inter%CountA )
          InStatic( I ) = Input( Inter%PermA( I ) )
        ENDDO
        CALL ParBeginTransfer( CommGlobal, Gsize, Gsize, Dest, Src,      &
                               InStatic, Inter%CountA,                   &
                               OutStatic, Inter%CountB )

      ELSE
!
! Backward redistribution
!
        ALLOCATE( InStatic( SUM( Inter%CountB ) ) )
        ALLOCATE( OutStatic( SUM( Inter%CountA ) ) )
        DO I = 1, SUM( Inter%CountB )
          InStatic( Inter%PermB( I ) ) = Input( I )
        ENDDO
        CALL ParBeginTransfer( CommGlobal, Gsize, Gsize, Dest, Src,      &
                               InStatic, Inter%CountB,                   &
                               OutStatic, Inter%CountA )

      ENDIF
      CPP_LEAVE_PROCEDURE( "REDISTRIBUTESTART" )
      RETURN
!EOC
      END SUBROUTINE RedistributeStart
!-----------------------------------------------------------------------

!-----------------------------------------------------------------------
!BOP
! !IROUTINE: RedistributeFinish --- Complete Asynchronous Redistribution
!
! !INTERFACE:
      SUBROUTINE RedistributeFinish( Inter, Forward, Output )
! !USES:
      USE parutilitiesmodule, ONLY: CommGlobal,Gsize,ParEndTransfer,GID
      IMPLICIT NONE
!
! !INPUT PARAMETERS:
      TYPE(RedistributeType), INTENT( INOUT ) :: Inter ! Inter info.
      LOGICAL             :: Forward     ! True: A -> B  False: B -> A
! !OUTPUT PARAMETERS:
      REAL(CPP_REAL8), INTENT( OUT ) :: Output( * ) ! Output Array
!
! !DESCRIPTION:
!
!     This routine completes an asynchronous redistribution of Input 
!     to Output according to the RedistributionType data structure Inter.
!     The redistribution can be from A -> B ("forward") or B -> A
!     ("backward").  This feature has been added to avoid the
!     need of a separate Inter (which requires considerable
!     memory) to perform the backward redistribution.
!
!     See additional documentation in RedistributeStart.
!
! !SYSTEM ROUTINES:
!     DEALLOCATE
!
! !REVISION HISTORY:
!   99.11.17   Sawyer     Creation from RedistributePerform
!
! !BUGS:
!     Currently limited to the global communicator.
!   
!EOP
!-----------------------------------------------------------------------
!BOC

! !LOCAL VARIABLES:
      INTEGER I, Dest( Gsize ), Src( Gsize )

      CPP_ENTER_PROCEDURE( "REDISTRIBUTEFINISH" )

      DO I = 1, Gsize
        Dest( I ) = I-1
        Src( I )  = I-1
      ENDDO

      IF ( Forward ) THEN
        CALL ParEndTransfer( CommGlobal, Gsize, Gsize, Dest, Src,        &
                             InStatic, Inter%CountA,                     &
                             OutStatic, Inter%CountB )
        DO I = 1, SUM( Inter%CountB )
          Output( I ) = OutStatic( Inter%PermB( I ) )
        ENDDO
      ELSE
        CALL ParEndTransfer( CommGlobal, Gsize, Gsize, Dest, Src,        &
                             InStatic, Inter%CountB,                     &
                             OutStatic, Inter%CountA )
        DO I = 1, SUM( Inter%CountA )
          Output( Inter%PermA( I ) ) = OutStatic( I )
        ENDDO
      ENDIF
      DEALLOCATE( OutStatic )
      DEALLOCATE( InStatic )

      CPP_LEAVE_PROCEDURE( "REDISTRIBUTEFINISH" )
      RETURN
!EOC
      END SUBROUTINE RedistributeFinish
!-----------------------------------------------------------------------
#endif
      END MODULE redistributemodule