parutilitiestest.f90

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

!-------------------------------------------------------------------------
!         NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS
!-------------------------------------------------------------------------
!BOP
! !ROUTINE: ParUtilitiesTest --- Unit tester for the parallel utilities
!
! !INTERFACE:
      PROGRAM parutilitiestest

! !USES:
      USE  decompmodule, ONLY: DecompType, DecompFree, DecompCreate
      USE  parutilitiesmodule

      IMPLICIT NONE

! !DESCRIPTION:
!
!    This main program tests the functionality of the ParUtilitites
!    module.  It performs the following tests:
!
!      Test 1: ParSplit, DecompRegular3D
!
!      Test 2: DecompRegular2D, ParScatter and ParGather
!         
!      Test 3: ParExchangeVector   
!
!    Validation check:
!
!         mpirun -np 7 ParUtilitiesTest
!
!    Should yield a single message (if -DDEBUG_ON is *not* defined):
!
!         Passed all tests
!
! !REVISION HISTORY:
!   00.07.20   Sawyer     Creation, from GEOS3_DAS_CORE version
!   00.08.21   Sawyer     Tests for ParCollective, ParGather/Scatter
!   01.05.01   Sawyer     free format, new decompmodule interfaces
!
!EOP
!-------------------------------------------------------------------------
!BOC
! !LOCAL VARIABLES:
      INTEGER GlobalPEs, GlobalRank, I, J, K, Ierror
      TYPE (DecompType)  :: Y3D, Z3D, YZ3D, XY2D, XY3D, ObsDecomp
      INTEGER BlockLen, Ipe, Comm_1, Comm_2
      INTEGER myid_1, myid_2, npr_1, npr_2, size_1, size_2, rank_1, rank_2
      LOGICAL Passed

! For the 2D and 3D decompositions
      INTEGER   Im, Jm, Km
      PARAMETER ( Im = 72, Jm = 46, Km = 18 )
      REAL      Tolerance

      REAL, ALLOCATABLE :: Aglobal2d(:), Bglobal2d(:)
      REAL, ALLOCATABLE :: Aglobal3d(:), Bglobal3d(:)
      REAL, ALLOCATABLE :: Rsemiglobal3d(:)
      REAL, ALLOCATABLE :: Rlocal2d(:), Rlocal3d(:)
      REAL, ALLOCATABLE :: Rtmp(:), Rlocal(:), Rglobal(:)
      REAL :: Scalar, Q, Array1D(Im), Array2D(Im,Jm), Array3D(Im,Jm,Km)
      INTEGER :: Inc, pe, IScalar, IArray1D(Im)
      INTEGER, ALLOCATABLE :: itmp(:),Dist(:),Xdist(:),Ydist(:),Zdist(:)


!
! Test 0 : Try to initialize the PEs
!
      CALL ParInit( )
      Passed = .TRUE.
      Tolerance = Gsize*1.0E-15

!
! Create a virtual 2-D PE mesh.  Remember that this is not 
! inherently supported by PILGRIM which considers the PEs 
! as an agglommeration of Gsize processes
!
      npr_1 = 1
      npr_2 = 1
! 
! The following loop is guaranteed to terminate when npr_1 = Gsize
! and sooner if it finds a factorizaton of Gsize.  For best results,
! use Gsize = product of two primes
!
      DO WHILE ( npr_1 * npr_2 .LT. Gsize )
        npr_1 = npr_1 + 1
        npr_2 = Gsize / npr_1  
      ENDDO

      myid_2 = gid / npr_1
      myid_1 = gid - myid_2 * npr_1

#if !defined(USE_ARENAS)
!
! Test 1 : Test ParSplit, DecompRegular2D, DecompRegular3D, ParScatter,
!          and ParGather, as they will be used in the LLNL
!          2D decomposition FVCCM.  This test is supported in 
!          MPI PILGRIM but not in MLP (Jim Taft) since it requires
!          communicators and a group-wise barrier to be supported 
!          via shared memory.   This will come in due time.
!


!
! Split the communicators as LLNL needs
!
      call parsplit(commglobal, myid_2, gid, Comm_1, rank_1, size_1 )
      call parsplit(commglobal, myid_1, gid, Comm_2, rank_2, size_2 )

      IF ( myid_1 /= rank_1 .OR. myid_2 /= rank_2 .OR.                   &
     &     npr_1 /= size_1 .OR. npr_2 /= size_2 ) THEN
        print *, "ERROR in ParSplit: ranks or sizes are incorrect"
      ENDIF

      ALLOCATE( Dist( 1 ) )

!
! Create a latitude/level distribution which is intentionally unbalanced
! -- this is a tougher test of the software than a trivial case
!
      ALLOCATE( XDist( 1 ) )
      ALLOCATE( YDist( npr_1 ) )
      ALLOCATE( ZDist( npr_2 ) )

      Xdist(1) = Im
      BlockLen = Jm
      DO I = 1, npr_1-1
        YDist( I ) = BlockLen / 2
        BlockLen   = BlockLen - YDist( I ) 
      ENDDO
      YDist( npr_1 ) = BlockLen

      BlockLen = Km
      DO J = 1, npr_2-1
        ZDist( J ) = BlockLen / 2
        BlockLen   = BlockLen - ZDist( J ) 
      ENDDO
      ZDist( npr_2 ) = BlockLen

!
! Latitude/vertical decompositions 3D array
!
      ALLOCATE( Rlocal3D( im * ydist(myid_1+1) * zdist(myid_2+1) ) )
      call decompcreate( 1, npr_1, npr_2, xdist, ydist, zdist, YZ3D )

!
! Latitude strip decompositions 3D array
!
      dist(1) = km
      call decompcreate( 1, npr_1, 1, xdist, ydist, dist, Y3D )

!
! Now define a 3D decomposition local to the vertical column as 
! defined by LLNL.  This is slightly tricky, 
! since the decomposition is consistent only over
! all processors with the same myid_1
!

      ALLOCATE( Rsemiglobal3D( Im*ydist(myid_1+1)*Km ) )
      Dist(1) = ydist(myid_1+1)   ! DecompRegular3D requires arrays
      call decompcreate( 1,1,npr_2,xdist,dist,zdist, Z3D )

      DEALLOCATE( zdist )
      DEALLOCATE( ydist )
      DEALLOCATE( xdist )
      DEALLOCATE(  dist )

!
! Initialize the global arrays
!
      ALLOCATE( Bglobal3D( im*jm*km ) )
      ALLOCATE( Aglobal3D( im*jm*km ) )
      CALL RANDOM_NUMBER( HARVEST = Aglobal3D )  ! Only PE 0 is of interest

      CALL ParScatter( CommGlobal, 0, Aglobal3D, YZ3D, Rlocal3D )
      CALL ParGather(  Comm_2, 0, Rlocal3D, Z3D, Rsemiglobal3D )
!
! LLNL will want to do the following on only the myid_z == 0 PES
! This will cause trouble in the current version of MLP (Jim Taft)
! PILGRIM since all PEs meet at a barrier in all communication primitives 
! (since a group-wise barrier will take some time to implement)
!
      IF ( myid_2 == 0 ) THEN  
        CALL ParGather(  Comm_1, 0, Rsemiglobal3D, Y3D, Bglobal3D )
      ENDIF

      IF ( GID == 0 ) THEN
        IF ( SUM(Aglobal3D-Bglobal3D) /= 0.0 ) THEN
          PRINT *, "ParUtilitiesTest failed: Scatter/Gather ver. != Orig."
          Passed = .FALSE.
        END IF
      ENDIF

      DEALLOCATE( Bglobal3D )
      DEALLOCATE( Aglobal3D )
      DEALLOCATE( Rsemiglobal3D )
      DEALLOCATE( Rlocal3D )

      CALL DecompFree( Z3D )
      CALL DecompFree( Y3D )
      CALL DecompFree( YZ3D )

      CALL ParFree( Comm_1 )
      CALL ParFree( Comm_2 )
#endif

!
! Test 2: A simple XY column distribution for 2D and 3D arrays
!
      ALLOCATE( XDist( npr_1 ) )
      ALLOCATE( YDist( npr_2 ) )
      ALLOCATE( ZDist( 1 ) )

!
! Consider a fairly irregular decomposition
!
      BlockLen = Im
      DO I = 1, npr_1-1
        XDist( I ) = BlockLen / 2
        BlockLen   = BlockLen - XDist( I ) 
      ENDDO
      XDist( npr_1 ) = BlockLen

      BlockLen = Jm
      DO J = 1, npr_2-1
        YDist( J ) = BlockLen / 2
        BlockLen   = BlockLen - YDist( J ) 
      ENDDO
      YDist( npr_2 ) = BlockLen

      Zdist(1) = Km

!
! Classical column distribution which could be used in the physics
!
      ALLOCATE( Rlocal2D( xdist(myid_1+1)*ydist(myid_2+1) ) )
      call decompcreate( npr_1, npr_2, xdist, ydist, XY2D )
      ALLOCATE( Rlocal3D( xdist(myid_1+1)*ydist(myid_2+1)*km ) )
      call decompcreate( npr_1, npr_2, 1, xdist,ydist,zdist, XY3D )


      DEALLOCATE( ZDist )
      DEALLOCATE( YDist )
      DEALLOCATE( XDist )

      ALLOCATE( Aglobal2D( im*jm ) )
      ALLOCATE( Aglobal3D( im*jm*km ) )
      ALLOCATE( Bglobal2D( im*jm ) )
      ALLOCATE( Bglobal3D( im*jm*km ) )

      CALL RANDOM_NUMBER( HARVEST = Aglobal2D )
      CALL RANDOM_NUMBER( HARVEST = Aglobal3D )

!
!     Now scatter the arrays over all PEs
!
      CALL ParScatter( CommGlobal, 0, Aglobal2D, XY2D, Rlocal2D )
      CALL ParGather( CommGlobal, 0, Rlocal2D, XY2D, Bglobal2D )
      CALL ParScatter( CommGlobal, 0, Aglobal3D, XY3D, Rlocal3D )
      CALL ParGather( CommGlobal, 0, Rlocal3D, XY3D, Bglobal3D )
      IF ( GID == 0 ) THEN
        IF ( SUM( Aglobal2d - Bglobal2d ) /= 0.0 .OR.                     &
     &       SUM( Aglobal3d - Bglobal3d ) /= 0.0 )  THEN
          PRINT *, "ParUtilitiesTest failed: Gather/scatter != Orig."
          Passed = .FALSE.
        END IF
      END IF

      DEALLOCATE( Rlocal3D )
      DEALLOCATE( Rlocal2D )
      DEALLOCATE( Bglobal3D )
      DEALLOCATE( Aglobal3D )
      DEALLOCATE( Bglobal2D )
      DEALLOCATE( Aglobal2D )

      CALL DecompFree( XY3D )
      CALL DecompFree( XY2D )

!
! Test 3 : Test ParExchangeVector by exchanging a vector twice
!
      ALLOCATE( Xdist( Gsize ) )
      ALLOCATE( Ydist( Gsize ) )

!
! Initialize seed to a different value on every PE, thus ensuring
! different values in the subsequent vectors
!
      CALL RANDOM_SEED( SIZE = BlockLen )
      ALLOCATE( Itmp( BlockLen ) )
      DO I=1, BlockLen
        Itmp(BlockLen) = Gid*(BlockLen-I+1)*Gid
      ENDDO
      CALL RANDOM_SEED( PUT = Itmp )
      DEALLOCATE( Itmp )


!
! Loop several times for better testing
!
      DO J = 1, 10
        ALLOCATE( Rtmp(Gsize) )
        CALL RANDOM_NUMBER( HARVEST = Rtmp )
!
! Determine a random destination pattern
!
        Xdist = INT( 10.0 * Rtmp )
        DEALLOCATE( Rtmp )

        ALLOCATE( Rglobal( SUM(Xdist) ) )
        ALLOCATE( Rlocal( SUM(Xdist) ) )
        ALLOCATE( Rtmp( Gsize*SUM(Xdist) ) )   ! A maximum buffer size

        CALL RANDOM_NUMBER( HARVEST = Rglobal )
        CALL ParExchangeVector( CommGlobal,Xdist,Rglobal,Ydist,Rtmp )
        CALL ParExchangeVector( CommGlobal,Ydist,Rtmp,Xdist,Rlocal )
        IF ( SUM( Rglobal - Rlocal ) /= 0.0 ) THEN
          PRINT *, "ParUtilitiesTest failed: ParExchangeVector"
          PRINT *, "Loop index ", J
          Passed = .FALSE.
          stop
        ENDIF

        DEALLOCATE( Rtmp )
        DEALLOCATE( Rlocal )
        DEALLOCATE( Rglobal )

      ENDDO

      DEALLOCATE( Ydist )
      DEALLOCATE( Xdist )

!
! Test 4: Parallel sums, ParBeginTransfer/ParEndTransfer
!
      ALLOCATE( Xdist( Gsize ) )
      ALLOCATE( Ydist( Gsize ) )

! Scalar sum test
      ALLOCATE( Rlocal(1) )    ! ParExchangeVector expects arrays
      ALLOCATE( Rglobal( Gsize ) )
      CALL RANDOM_NUMBER( HARVEST = Q )
      Rlocal(1) = Q
      Xdist = 0
      Xdist(1) = 1
      CALL ParExchangeVector( CommGlobal,Xdist,Rlocal,Ydist,Rglobal )
      CALL ParCollective( CommGlobal, SUMOP, Q )
      IF ( GID == 0 ) THEN
        Scalar = 0.0
        DO pe=0,Gsize-1
          Scalar = Scalar + Rglobal( pe+1 )
        ENDDO
        IF ( ABS( Scalar - Q ) > Tolerance ) THEN
            print *, "Error in Scalar sum: ", Scalar-Q
        ENDIF
      ENDIF
      DEALLOCATE( Rlocal )
      DEALLOCATE( Rglobal )

! 1D Array sum test
      CALL RANDOM_NUMBER( HARVEST = Array1D )
      ALLOCATE( Rglobal( Im*Gsize ) )
      Xdist = 0
      Xdist(1) = Im
      CALL ParExchangeVector( CommGlobal,Xdist,Array1D,Ydist,Rglobal )
      CALL ParCollective( CommGlobal, SUMOP, Im, Array1D )
      IF ( GID == 0 ) THEN
        DO i=1, Im
          Scalar = 0.0
          DO pe=0,Gsize-1
            Scalar = Scalar + Rglobal( Im*pe+I )
          ENDDO
          IF ( ABS( Scalar - Array1D(I) ) > Tolerance ) THEN
            print *, "Error in 1D Sum: ", Scalar-Array1D(I), " pos ",I
          ENDIF
        ENDDO
      ENDIF
      DEALLOCATE( Rglobal )

! 2D Array sum test
      CALL RANDOM_NUMBER( HARVEST = Array2D )

      ALLOCATE( Rglobal( Im*Jm*Gsize ) )
      ALLOCATE( Rlocal( Im*Jm ) )
      Xdist = 0
      Xdist(1) = Im*Jm

      inc = 0
      DO J=1,Jm
        DO I=1,Im
          inc = inc+1
          Rlocal(inc) = Array2D(i,j)
        ENDDO
      ENDDO
      CALL ParExchangeVector( CommGlobal,Xdist,Rlocal,Ydist,Rglobal )
      CALL ParCollective( CommGlobal, SUMOP, Im, Jm, Array2D )
      IF ( GID == 0 ) THEN
        inc = 0
        DO j=1, Jm
          DO i=1, Im
            inc = inc + 1
            Scalar = 0.0
            DO pe=0,Gsize-1
              Scalar = Scalar + Rglobal( Jm*Im*pe+Inc )
            ENDDO
            IF ( ABS( Scalar - Array2D(I,J) ) > Tolerance ) THEN
              print *, "Error 2D Sum: ",Scalar-Array2D(I,J), "pos ",I,J
            ENDIF
          ENDDO
        ENDDO
      ENDIF
      DEALLOCATE( Rglobal )
      DEALLOCATE( Rlocal )

! 3D Array sum test
      CALL RANDOM_NUMBER( HARVEST = Array3D )

      ALLOCATE( Rglobal( Im*Jm*Km*Gsize ) )
      ALLOCATE( Rlocal( Im*Jm*Km ) )
      Xdist = 0
      Xdist(1) = Im*Jm*Km

      inc = 0
      DO K=1,Km
        DO J=1,Jm
          DO I=1,Im
            inc = inc+1
            Rlocal(inc) = Array3D(i,j,k)
          ENDDO
        ENDDO
      ENDDO
      CALL ParExchangeVector( CommGlobal,Xdist,Rlocal,Ydist,Rglobal )
      CALL ParCollective( CommGlobal, SUMOP, Im, Jm, Km, Array3D )
      IF ( GID == 0 ) THEN
        inc = 0
        DO k=1, Km
          DO j=1, Jm
            DO i=1, Im
              inc = inc + 1
              Scalar = 0.0
              DO pe=0,Gsize-1
                Scalar = Scalar + Rglobal( Km*Jm*Im*pe+inc )
              ENDDO
              IF ( ABS( Scalar - Array3D(I,J,K) ) > Tolerance ) THEN
              print *, "Error 3D Sum: ",Scalar-Array3D(I,J,K), I, J, K
              ENDIF
            ENDDO
          ENDDO
        ENDDO
      ENDIF


      DEALLOCATE( Rglobal )
      DEALLOCATE( Rlocal )

      DEALLOCATE( Ydist )
      DEALLOCATE( Xdist )

!
! That's all folks
!

      IF ( Gid == 0 ) THEN
        IF ( Passed ) THEN
          PRINT *, "Passed ParUtilitiesTest"
        ELSE
          PRINT *, "Failed ParUtilitiesTest"
        ENDIF
      END IF


      CALL ParExit( )

!EOC
!-------------------------------------------------------------------------
      END PROGRAM parutilitiestest