!-------------------------------------------------------------------------!         NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS!-------------------------------------------------------------------------!BOP! !ROUTINE: ParPatternTest --- Unit tester for the parutilities patterns!! !INTERFACE:      PROGRAM parpatterntest! !USES:      USE  decompmodule, ONLY: DecompType, DecompFree, DecompPermute,      &     &     DecompCreate      USE  parutilitiesmodule, ONLY: Gsize, GID, CommGlobal,               &     &     ParPatternType, ParInit, ParExit, ParScatter, ParGather,        &     &     ParPatternCreate, ParPatternFree,                               &     &     ParBeginTransfer, ParEndTransfer#include "debug.h"#include "misc.h"      IMPLICIT NONE#include "gpt.inc"! !DESCRIPTION:!!    This main program tests the functionality of the decompmodule !    and parutilitiesmodule which relates to communication patterns.!!      Test 1: DecompRegular1D, ParPatternCreate, ParBegin/EndTransfer!!    Validation check:!!         mpirun -np 7 parpatterntest!!    Should yield a single message (if -DDEBUG_ON is *not* defined):!!         Passed all tests!! !REVISION HISTORY:!   01.06.03   Sawyer     Creation from RedistributeTest!!EOP!-------------------------------------------------------------------------!BOC! !LOCAL VARIABLES:      INTEGER GlobalPEs, GlobalRank, I, J, Ierror      TYPE (DecompType)  :: DecompA, DecompB, ObsDecomp      TYPE (ParPatternType) :: InterAB, InterBA      INTEGER BlockLen, Remainder, Ipe      REAL time1, time2, time3      LOGICAL Passed! For the Observation decomposition      INTEGER   Nactual, Xdim, Ydim, Zdim      PARAMETER ( Nactual = 331 )      PARAMETER ( Xdim = 144 )      PARAMETER ( Ydim =  91 )      PARAMETER ( Zdim =  30 )      REAL, ALLOCATABLE :: Rglobal(:), Rtmp(:), RlocalA(:), RlocalB(:)      REAL, ALLOCATABLE :: R2dlocalA(:), R2dlocalB(:)      REAL, ALLOCATABLE :: R2dGlobal(:), R2dtmp(:)!! 3D Arrays are smashed down to 1D!      REAL, ALLOCATABLE :: R3dlocalA(:), R3dlocalB(:)      REAL, ALLOCATABLE :: R3dGlobal(:), R3dTmp(:)      INTEGER, ALLOCATABLE :: itmp(:), DistA(:), DistB(:)      INTEGER, ALLOCATABLE :: Xdist(:), Ydist(:), Zdist(:), Perm(:)      CALL ParInit( )      Passed = .TRUE.!! Initialize timing library.  2nd arg 0 means disable, 1 means enable!#if defined(TIMING)      call t_setoptionf (usrsys, 1)      call t_initializef ()#endif!! Test 1 : Test DecompRegular1D, DecompPermute, ParScatter1D, ParGather1D !          and Redistribution using a block-wise distribution.!#if defined(TIMING)      call t_startf('1D Redist Total')#endif!!     Set the global vector to random values!      ALLOCATE( Rtmp(Nactual) )      rtmp = 1.0!! Decomposition for Observations:  Block distribution with remainder! on last PE.  Should be OK if #obs >> #PEs!!      ALLOCATE( DistA( Gsize ) )      ALLOCATE( DistB( Gsize ) )      ALLOCATE( Perm( Gsize ) )      BlockLen = Nactual      DO I = 1, Gsize-1        DistA( I ) = BlockLen / 2        BlockLen  = BlockLen - DistA(I)      ENDDO      DistA( Gsize ) = BlockLen      IF ( SUM( DistA ) .ne. Nactual ) THEN        print *, " Error: DistA contains ", SUM(DistA), " != ",Nactual      ENDIF      DO I = 1, Gsize        DistB( I ) = DistA( Gsize-I+1 )      ENDDO      CALL DecompCreate ( Gsize, DistA, DecompA )      CALL DecompCreate ( Gsize, DistB, DecompB )      DO I=1, Gsize-1        Perm( I+1 ) = I      ENDDO      Perm( 1 ) = Gsize      CALL DecompPermute( Perm, DecompB )      ALLOCATE( RlocalA( DecompA%NumEntries(GID+1) ) )      ALLOCATE( RlocalB( DecompB%NumEntries(GID+1) ) )      ALLOCATE( Rglobal( Nactual ) )      IF ( GID .EQ. 0 ) THEN        CALL RANDOM_NUMBER( HARVEST = Rglobal )      ENDIF!! Now scatter the arrays over all PEs!      CALL ParScatter( CommGlobal, 0, Rglobal, DecompA, RlocalA )!! Now redistribute the local arrays from one decomposition to another!#if defined(TIMING)      call t_startf('1D Redist Create')#endif      CALL ParPatternCreate( CommGlobal, DecompA, DecompB, InterAB )      CALL ParPatternCreate( CommGlobal, DecompB, DecompA, InterBA )#if defined(TIMING)      call t_stopf('1D Redist Create')#endif#if defined(TIMING)      call t_startf('1D Redist Forward')#endif      CALL ParBeginTransfer( InterAB, RlocalA, RlocalB )      CALL ParEndTransfer( InterAB, RlocalA, RlocalB )#if defined(TIMING)      call t_stopf('1D Redist Forward')#endif      RlocalA = 0.0#if defined(TIMING)      call t_startf('1D Redist Back')#endif      CALL ParBeginTransfer( InterBA, RlocalB, RlocalA )      CALL ParEndTransfer( InterBA, RlocalB, RlocalA )#if defined(TIMING)      call t_stopf('1D Redist Back')#endif      CALL ParPatternFree( CommGlobal, InterBA )      CALL ParPatternFree( CommGlobal, InterAB )      CALL ParGather( CommGlobal, 0, RlocalA, DecompA, Rtmp )      IF ( GID .eq. 0 ) THEN        Rtmp = Rtmp - Rglobal        IF ( SUM(Rtmp) .ne. 0.0 ) THEN          PRINT *, "Redistribution failed: 1D Gathered ver. != Orig."          Passed = .FALSE.        ENDIF      ENDIF      CALL DecompFree( DecompB )      CALL DecompFree( DecompA )      DEALLOCATE( DistB )      DEALLOCATE( DistA )      DEALLOCATE( RlocalB )      DEALLOCATE( RlocalA )      DEALLOCATE( Rtmp )      DEALLOCATE( Rglobal )#if defined(TIMING)      call t_stopf('1D Redist Total')#endif!! Test 2 : Test DecompRegular2D, ParScatter2D and ParGather2D !          and Redistribute using a 2-D block-wise distribution.!#if defined(TIMING)      call t_startf('2D Redist Total')#endif!! Set the target vector to non-random values!!! Make sure that the array is not square!        ALLOCATE( R2dtmp( XDim*YDim ) )! Set the global vector to random values! Make sure that the array is not square!      ALLOCATE( R2dGlobal( XDim*YDim ) )      IF ( GID .EQ. 0 ) THEN        CALL RANDOM_NUMBER( HARVEST = R2dglobal )      ENDIF!     Decomposition for Observations:  Block distribution with remainder!       on last PE.  Should be OK if #obs >> #PEs!      ALLOCATE( DistA( Gsize ) )      ALLOCATE( DistB( Gsize ) )      ALLOCATE( XDist( 1 ) )      ALLOCATE( YDist( 1 ) )      BlockLen   = Xdim      DO I = 1, Gsize-1        DistA( I ) = BlockLen / 2        BlockLen   = BlockLen - DistA( I )       ENDDO      DistA( Gsize ) = BlockLen      YDist( 1 ) = Ydim            XDist( 1 ) = Xdim      BlockLen   = Ydim      DO J = 1, Gsize-1        DistB( J ) = BlockLen / 2        BlockLen   = BlockLen - DistB( J )       ENDDO      DistB( Gsize ) = BlockLen!! Row-major ordering!      ALLOCATE( R2dlocalA( DistA(GID+1)*YDist(1) ) )      ALLOCATE( R2dlocalB( XDist(1)*DistB(GID+1) ) )      CALL DecompCreate( Gsize, 1, DistA, YDist, DecompA )      CALL DecompCreate( 1, Gsize, Xdist, DistB, DecompB )!!     Now scatter the arrays over all PEs!      CALL ParScatter( CommGlobal, 0, R2dglobal, DecompA, R2dlocalA )#if defined(TIMING)      call t_startf('2D Redist Create')#endif      CALL ParPatternCreate( CommGlobal, DecompA, DecompB, InterAB )      CALL ParPatternCreate( CommGlobal, DecompB, DecompA, InterBA )#if defined(TIMING)      call t_stopf('2D Redist Create')#endif#if defined(TIMING)      call t_startf('2D Redist Forward')#endif      CALL ParBeginTransfer( InterAB, R2dlocalA, R2dlocalB )      CALL ParEndTransfer( InterAB, R2dlocalA, R2dlocalB )#if defined(TIMING)      call t_stopf('2D Redist Forward')#endif      R2dlocalA = 0.0#if defined(TIMING)      call t_startf('2D Redist Back')#endif      CALL ParBeginTransfer( InterBA, R2dlocalB, R2dlocalA )      CALL ParEndTransfer( InterBA, R2dlocalB, R2dlocalA )#if defined(TIMING)      call t_stopf('2D Redist Back')#endif      CALL ParPatternFree( CommGlobal, InterAB )      CALL ParPatternFree( CommGlobal, InterBA )      CALL ParGather( CommGlobal, 0, R2dlocalA, DecompA, R2dtmp )      IF ( GID .eq. 0 ) THEN        R2dtmp = R2dtmp - R2dglobal        IF ( SUM(R2dtmp) .ne. 0.0 ) THEN          PRINT *,"RedistributeTest Failed: 2D Gathered ver. != Orig."          Passed = .FALSE.        ENDIF      ENDIF      CALL DecompFree( DecompB )      CALL DecompFree( DecompA )      DEALLOCATE( R2dlocalB )      DEALLOCATE( R2dlocalA )      DEALLOCATE( YDist )      DEALLOCATE( XDist )      DEALLOCATE( DistB )      DEALLOCATE( DistA )      DEALLOCATE( R2dtmp )      DEALLOCATE( R2dglobal )#if defined(TIMING)      call t_stopf('2D Redist Total')#endif!! Test 3 : Test 3-D redistribution!#if defined(TIMING)      call t_startf('3D Redist Total')#endif!! Set the target vector to non-random values!!! Make sure that the array is not square!        ALLOCATE( R3dTmp( Xdim*Ydim*ZDim ) )! Set the global vector to random values! Make sure that the array is not square!      ALLOCATE( R3dGlobal( XDim*YDim*ZDim  ) )      IF ( GID .eq. 0 ) THEN        CALL RANDOM_NUMBER( HARVEST = R3dglobal )      ENDIF      r3dtmp = 1.0!! Now define the distribution!      ALLOCATE( DistA( Gsize ) )      ALLOCATE( DistB( Gsize ) )      ALLOCATE( XDist( 1 ) )      ALLOCATE( YDist( 1 ) )      ALLOCATE( ZDist( 1 ) )      XDist( 1 ) = Xdim      YDist( 1 ) = Ydim      ZDist( 1 ) = Zdim!! Optimal distribution in Z!      BlockLen   = Zdim / Gsize      Remainder  = MOD( Zdim, Gsize )        IF ( Remainder .gt. 0 ) DistA( 1:Remainder ) = BlockLen+1      DistA( Remainder+1 : Gsize ) = BlockLen      CALL DecompCreate( 1,1,Gsize,XDist,YDist,DistA,DecompA )!! Optimal distribution in Y!      BlockLen   = Ydim / Gsize      Remainder  = MOD( Ydim, Gsize )       IF ( Remainder .gt. 0 ) DistB( 1:Remainder ) = BlockLen+1      DistB( Remainder+1 : Gsize ) = BlockLen      CALL DecompCreate( 1,Gsize,1,XDist,DistB,ZDist,DecompB )      ALLOCATE( R3dlocalA( XDist(1)*YDist(1)*DistA(GID+1) ) )      ALLOCATE( R3dlocalB( XDist(1)*DistB(GID+1)*ZDist(1) ) )!! Do all the stuff here!      CALL ParScatter( CommGlobal, 0, R3dglobal, DecompA, R3dlocalA )#if defined( TIMING )      call t_startf('3D Redist Create')#endif      CALL ParPatternCreate( CommGlobal, DecompA, DecompB, InterAB )      CALL ParPatternCreate( CommGlobal, DecompB, DecompA, InterBA )#if defined(TIMING)      call t_stopf('3D Redist Create')#endif#if defined(TIMING)      call t_startf('3D Redist Forward')#endif      CALL ParBeginTransfer( InterAB, R3dlocalA, R3dlocalB )      CALL ParEndTransfer( InterAB, R3dlocalA, R3dlocalB )#if defined(TIMING)      call t_stopf('3D Redist Forward')#endif      R3dlocalA = 0.0#if defined(TIMING)      call t_startf('3D Redist Back')#endif      CALL ParBeginTransfer( InterBA, R3dlocalB, R3dlocalA )      CALL ParEndTransfer( InterBA, R3dlocalB, R3dlocalA )#if defined(TIMING)      call t_stopf('3D Redist Back')#endif      CALL ParPatternFree( CommGlobal, InterAB )      CALL ParPatternFree( CommGlobal, InterBA )      CALL ParGather( CommGlobal, 0, R3dlocalA, DecompA, R3dtmp )      IF ( GID .eq. 0 ) THEN        R3dtmp = R3dtmp - R3dglobal        IF ( SUM(R3dtmp) .ne. 0.0 ) THEN          PRINT *, "RedistributeTest failed: 3d Gathered ver. != Orig."          Passed = .FALSE.        ENDIF      ENDIF      CALL DecompFree( DecompB )      CALL DecompFree( DecompA )      DEALLOCATE( R3dlocalB )      DEALLOCATE( R3dlocalA )      DEALLOCATE( ZDist )      DEALLOCATE( YDist )      DEALLOCATE( XDist )      DEALLOCATE( DistB )      DEALLOCATE( DistA )      DEALLOCATE( R3dtmp )      DEALLOCATE( R3dglobal )#if defined(TIMING)      call t_stopf('3D Redist Total')#endif!! That's all folks!#if defined(TIMING)      call t_prf(GID)#endif      IF ( Passed ) THEN        PRINT *, "Passed ParPatternTest"      ELSE        PRINT *, "Failed ParPatternTest"       ENDIF      CALL ParExit( )!EOC!-------------------------------------------------------------------------      END PROGRAM parpatterntest