      PROGRAM PSBLA3TIM
*
*  -- PBLAS testing driver (version 1.5) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     May 1, 1997
*
*  Purpose
*  ========
*
*  PSBLA3TIM is the main timing program for the REAL
*  PBLAS Level 3 routines.
*
*  The program must be driven by a short data file.  An annotated
*  example of a data file can be obtained by deleting the first 3
*  characters from the following 48 lines:
*  'ScaLAPACK, Version 2.0, Level 3 PBLAS timing input file'
*  'Intel iPSC/860 hypercube, gamma model.'
*  'PSBLAT3.SUMM'     output file name (if any)
*  6     device out
*  1               number of process grids (ordered pairs of P & Q)
*  2 2 1 4 2 3 8   values of P
*  2 2 4 1 3 2 1   values of Q
*  1.0E0           value of ALPHA
*  1.0E0           value of BETA
*  2               number of tests problems
*  'N' 'U'         values of DIAG
*  'L' 'R'         values of SIDE
*  'N' 'T'         values of TRANSA
*  'N' 'T'         values of TRANSB
*  'U' 'L'         values of UPLO
*  3  4            values of M
*  3  4            values of N
*  3  4            values of K
*  6 10            values of M_A
*  6 10            values of N_A
*  2  5            values of MB_A
*  2  5            values of NB_A
*  0  1            values of RSRC_A
*  0  0            values of CSRC_A
*  1  1            values of IA
*  1  1            values of JA
*  6 10            values of M_B
*  6 10            values of N_B
*  2  5            values of MB_B
*  2  5            values of NB_B
*  0  1            values of RSRC_B
*  0  0            values of CSRC_B
*  1  1            values of IB
*  1  1            values of JB
*  6 10            values of M_C
*  6 10            values of N_C
*  2  5            values of MB_C
*  2  5            values of NB_C
*  0  1            values of RSRC_C
*  0  0            values of CSRC_C
*  1  1            values of IC
*  1  1            values of JC
*  PSGEMM  T  put F for no test in the same column
*  PSSYMM  T  put F for no test in the same column
*  PSSYRK  T  put F for no test in the same column
*  PSSYR2K T  put F for no test in the same column
*  PSTRAN  T  put F for no test in the same column
*  PSTRMM  T  put F for no test in the same column
*  PSTRSM  T  put F for no test in the same column
*
*  Internal Parameters
*  ===================
*
*  TOTMEM   INTEGER, default = 2000000
*           TOTMEM is a machine-specific parameter indicating the
*           maximum amount of available memory in bytes.
*           The user should customize TOTMEM to his platform.  Remember
*           to leave room in memory for the operating system, the BLACS
*           buffer, etc.  For example, on a system with 8 MB of memory
*           per process (e.g., one processor on an Intel iPSC/860), the
*           parameters we use are TOTMEM=6200000 (leaving 1.8 MB for OS,
*           code, BLACS buffer, etc).  However, for PVM, we usually set
*           TOTMEM = 2000000.  Some experimenting with the maximum value
*           of TOTMEM may be required.
*
*  INTGSZ   INTEGER, default = 4 bytes.
*  REALSZ   INTEGER, default = 4 bytes.
*           INTGSZ and REALSZ indicate the length in bytes on the
*           given platform for an integer and a single precision real.
*  MEM      REAL array, dimension ( TOTMEM / REALSZ )
*
*           All arrays used by SCALAPACK routines are allocated from
*           this array and referenced by pointers.  The integer IPA,
*           for example, is a pointer to the starting element of MEM for
*           the matrix A.
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            MAXTESTS, MAXGRIDS, REALSZ, TOTMEM, MEMSIZ,
     $                   NSUBS
      PARAMETER          ( MAXTESTS = 20, MAXGRIDS = 20, REALSZ = 4,
     $                     TOTMEM = 64000000, NSUBS = 7,
     $                     MEMSIZ = TOTMEM / REALSZ )
      INTEGER            BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
     $                   LLD_, MB_, M_, NB_, N_, RSRC_
      PARAMETER          ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
     $                     CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
     $                     RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
*     ..
*     .. Local Scalars ..
      CHARACTER*1        AFORM, CFORM, DIAG, SIDE, TRANSA, TRANSB, UPLO
      INTEGER            CSRCA, CSRCB, CSRCC, I, IAM, ICTXT, IMIDPADA,
     $                   IMIDPADB, IMIDPADC, IPREPADA, IPREPADB,
     $                   IPREPADC, IPOSTPADA, IPOSTPADB, IPOSTPADC, IPA,
     $                   IPB, IPC, IA, IASEED, IB, IBSEED, IC, ICSEED,
     $                   J, JA, JB, JC, K, KK, L, M, MA, MB, MBA, MBB,
     $                   MC, MBC, MEMREQD, MPA, MPB, MPC, MYCOL, MYROW,
     $                   N, NA, NB, NBA, NBB, NBC, NC, NCOLA, NCOLB,
     $                   NCOLC, NGRIDS, NOUT, NPCOL, NPROCS, NPROW, NQA,
     $                   NQB, NQC, NROWA, NROWB, NROWC, NTESTS, RSRCA,
     $                   RSRCB, RSRCC
      REAL               ALPHA, BETA
      DOUBLE PRECISION   CFLOPS, NOPS, WFLOPS
*     ..
*     .. Local Arrays ..
      LOGICAL            LTEST( NSUBS ), BCHECK( NSUBS ),
     $                   CCHECK( NSUBS )
      CHARACTER*1        DIAGVAL( MAXTESTS ), SIDEVAL( MAXTESTS ),
     $                   TRANSAVAL( MAXTESTS ), TRANSBVAL( MAXTESTS ),
     $                   UPLOVAL( MAXTESTS )
      CHARACTER*80       OUTFILE
      INTEGER            CSRCAVAL( MAXTESTS ), CSRCBVAL( MAXTESTS ),
     $                   CSRCCVAL( MAXTESTS ), DESCA( DLEN_ ),
     $                   DESCB( DLEN_ ), DESCC( DLEN_ ), IERR( 3 ),
     $                   IAVAL( MAXTESTS ), IBVAL( MAXTESTS ),
     $                   ICVAL( MAXTESTS ), JAVAL( MAXTESTS ),
     $                   JBVAL( MAXTESTS ), JCVAL( MAXTESTS ),
     $                   KVAL( MAXTESTS ), MVAL( MAXTESTS ),
     $                   MAVAL( MAXTESTS ), MBVAL( MAXTESTS ),
     $                   MCVAL( MAXTESTS ), MBAVAL( MAXTESTS ),
     $                   MBBVAL( MAXTESTS ), MBCVAL( MAXTESTS ),
     $                   NVAL( MAXTESTS ), NAVAL( MAXTESTS ),
     $                   NBAVAL( MAXTESTS ), NBBVAL( MAXTESTS ),
     $                   NBCVAL( MAXTESTS ), NBVAL( MAXTESTS ),
     $                   NCVAL( MAXTESTS ), PVAL( MAXTESTS ),
     $                   QVAL( MAXTESTS ), RSRCAVAL( MAXTESTS ),
     $                   RSRCBVAL( MAXTESTS ), RSRCCVAL( MAXTESTS )
      REAL               MEM( MEMSIZ )
      DOUBLE PRECISION   CTIME( 1 ), WTIME( 1 )
*     ..
*     .. External Subroutines ..
      EXTERNAL           BLACS_EXIT, BLACS_GET, BLACS_GRIDEXIT,
     $                   BLACS_GRIDINFO, BLACS_GRIDINIT, BLACS_PINFO,
     $                   BLACS_BARRIER, IGSUM2D, PBSMATGEN,
     $                   PSBLA3TIMINFO, MDESCCHK, MDIMCHK,
     $                   SLBOOT, SLCOMBINE, SLTIMER,
     $                   PSGEMM, PSSYMM, PSSYRK, PSSYR2K,
     $                   PSTRAN, PSTRMM, PSTRSM
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   PDOPBL3
      EXTERNAL           LSAME, PDOPBL3
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          DBLE
*     ..
*     .. Scalars in Common ..
      CHARACTER*7        SNAMES( NSUBS )
      LOGICAL            ABRTFLG
      INTEGER            INFO
*     ..
*     .. Common blocks ..
      COMMON             /SNAMEC/SNAMES
      COMMON             /INFOC/INFO
      COMMON             /PBERRORC/NOUT, ABRTFLG
*     ..
*     .. Data Statements ..
      DATA               SNAMES/'PSGEMM', 'PSSYMM', 'PSSYRK',
     $                   'PSSYR2K', 'PSTRAN', 'PSTRMM',
     $                   'PSTRSM'/
      DATA               BCHECK/.TRUE., .TRUE., .FALSE., .TRUE.,
     $                   .FALSE., .TRUE., .TRUE./
      DATA               CCHECK/.TRUE., .TRUE., .TRUE., .TRUE., .TRUE.,
     $                   .FALSE., .FALSE./
*     ..
*     .. Executable Statements ..
*
*     Initialization
*
*     Set flag so that PBERROR won't abort on errors, so that the tester
*     will detect unsupported operations.
*
      ABRTFLG = .FALSE.
*
*     Seeds for random matrix generations.
*
      IASEED = 100
      IBSEED = 200
      ICSEED = 300
*
*     Get starting information
*
      CALL BLACS_PINFO( IAM, NPROCS )
      CALL PSBLA3TIMINFO( OUTFILE, NOUT, NTESTS, DIAGVAL, SIDEVAL,
     $                    TRANSAVAL, TRANSBVAL, UPLOVAL, MVAL, NVAL,
     $                    KVAL, MAVAL, NAVAL, MBAVAL, NBAVAL, RSRCAVAL,
     $                    CSRCAVAL, IAVAL, JAVAL, MBVAL, NBVAL, MBBVAL,
     $                    NBBVAL, RSRCBVAL, CSRCBVAL, IBVAL, JBVAL,
     $                    MCVAL, NCVAL, MBCVAL, NBCVAL, RSRCCVAL,
     $                    CSRCCVAL, ICVAL, JCVAL, MAXTESTS, NGRIDS,
     $                    PVAL, MAXGRIDS, QVAL, MAXGRIDS, LTEST, IAM,
     $                    NPROCS, ALPHA, BETA, MEM )
*
      IF( IAM.EQ.0 )
     $   WRITE( NOUT, FMT = 9984 )
*
*     Loop over different process grids
*
      DO 60 I = 1, NGRIDS
*
         NPROW = PVAL( I )
         NPCOL = QVAL( I )
*
*        Make sure grid information is correct
*
         IERR( 1 ) = 0
         IF( NPROW.LT.1 ) THEN
            IF( IAM.EQ.0 )
     $         WRITE( NOUT, FMT = 9999 ) 'GRID SIZE', 'NPROW', NPROW
            IERR( 1 ) = 1
         ELSE IF( NPCOL.LT.1 ) THEN
            IF( IAM.EQ.0 )
     $         WRITE( NOUT, FMT = 9999 ) 'GRID SIZE', 'NPCOL', NPCOL
            IERR( 1 ) = 1
         ELSE IF( NPROW*NPCOL.GT.NPROCS ) THEN
            IF( IAM.EQ.0 )
     $         WRITE( NOUT, FMT = 9998 ) NPROW*NPCOL, NPROCS
            IERR( 1 ) = 1
         END IF
*
         IF( IERR( 1 ).GT.0 ) THEN
            IF( IAM.EQ.0 )
     $         WRITE( NOUT, FMT = 9997 ) 'GRID'
            GO TO 60
         END IF
*
*        Define process grid
*
         CALL BLACS_GET( -1, 0, ICTXT )
         CALL BLACS_GRIDINIT( ICTXT, 'Row-major', NPROW, NPCOL )
         CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
*
*        Go to bottom of process grid loop if this case doesn't use my
*        process
*
         IF( MYROW.GE.NPROW .OR. MYCOL.GE.NPCOL )
     $      GO TO 60
*
*        Loop over number of tests
*
         DO 50 J = 1, NTESTS
*
*           Get the test parameters
*
            DIAG   = DIAGVAL( J )
            SIDE   = SIDEVAL( J )
            TRANSA = TRANSAVAL( J )
            TRANSB = TRANSBVAL( J )
            UPLO   = UPLOVAL( J )
*
            M      = MVAL( J )
            N      = NVAL( J )
            K      = KVAL( J )
*
            MA    = MAVAL( J )
            NA    = NAVAL( J )
            MBA   = MBAVAL( J )
            NBA   = NBAVAL( J )
            RSRCA = RSRCAVAL( J )
            CSRCA = CSRCAVAL( J )
            IA    = IAVAL( J )
            JA    = JAVAL( J )
*
            MB    = MBVAL( J )
            NB    = NBVAL( J )
            MBB   = MBBVAL( J )
            NBB   = NBBVAL( J )
            RSRCB = RSRCBVAL( J )
            CSRCB = CSRCBVAL( J )
            IB    = IBVAL( J )
            JB    = JBVAL( J )
*
            MC    = MCVAL( J )
            NC    = NCVAL( J )
            MBC   = MBCVAL( J )
            NBC   = NBCVAL( J )
            RSRCC = RSRCCVAL( J )
            CSRCC = CSRCCVAL( J )
            IC    = ICVAL( J )
            JC    = JCVAL( J )
*
            IF( IAM.EQ.0 ) THEN
*
               WRITE( NOUT, FMT = * )
               WRITE( NOUT, FMT = 9996 ) J, NPROW, NPCOL
               WRITE( NOUT, FMT = * )
*
               WRITE( NOUT, FMT = 9995 )
               WRITE( NOUT, FMT = 9994 )
               WRITE( NOUT, FMT = 9995 )
               WRITE( NOUT, FMT = 9993 ) M, N, K, SIDE, UPLO, TRANSA,
     $                                   TRANSB, DIAG
*
               WRITE( NOUT, FMT = 9995 )
               WRITE( NOUT, FMT = 9992 )
               WRITE( NOUT, FMT = 9995 )
               WRITE( NOUT, FMT = 9991 ) IA, JA, MA, NA, MBA, NBA,
     $                                   RSRCA, CSRCA
*
               WRITE( NOUT, FMT = 9995 )
               WRITE( NOUT, FMT = 9990 )
               WRITE( NOUT, FMT = 9995 )
               WRITE( NOUT, FMT = 9991 ) IB, JB, MB, NB, MBB, NBB,
     $                                   RSRCB, CSRCB
*
               WRITE( NOUT, FMT = 9995 )
               WRITE( NOUT, FMT = 9989 )
               WRITE( NOUT, FMT = 9995 )
               WRITE( NOUT, FMT = 9991 ) IC, JC, MC, NC, MBC, NBC,
     $                                   RSRCC, CSRCC
*
               WRITE( NOUT, FMT = 9995 )
               WRITE( NOUT, FMT = 9980 )
*
            END IF
*
*           Check the validity of the input test parameters
*
            IF( .NOT.LSAME( SIDE, 'L' ).AND.
     $          .NOT.LSAME( SIDE, 'R' ) ) THEN
               IF( IAM.EQ.0 )
     $            WRITE( NOUT, FMT = 9997 ) 'SIDE'
               GO TO 40
            END IF
*
            IF( .NOT.LSAME( UPLO, 'U' ).AND.
     $          .NOT.LSAME( UPLO, 'L' ) ) THEN
               IF( IAM.EQ.0 )
     $            WRITE( NOUT, FMT = 9997 ) 'UPLO'
               GO TO 40
            END IF
*
            IF( .NOT.LSAME( TRANSA, 'N' ).AND.
     $          .NOT.LSAME( TRANSA, 'T' ).AND.
     $          .NOT.LSAME( TRANSA, 'C' ) ) THEN
               IF( IAM.EQ.0 )
     $            WRITE( NOUT, FMT = 9997 ) 'TRANSA'
               GO TO 40
            END IF
*
            IF( .NOT.LSAME( TRANSB, 'N' ).AND.
     $          .NOT.LSAME( TRANSB, 'T' ).AND.
     $          .NOT.LSAME( TRANSB, 'C' ) ) THEN
               IF( IAM.EQ.0 )
     $            WRITE( NOUT, FMT = 9997 ) 'TRANSB'
               GO TO 40
            END IF
*
            IF( .NOT.LSAME( DIAG , 'U' ).AND.
     $          .NOT.LSAME( DIAG , 'N' ) )THEN
               IF( IAM.EQ.0 )
     $            WRITE( NOUT, FMT = 9997 ) 'DIAG'
               GO TO 40
            END IF
*
*           Check and initialize the matrix descriptors
*
            CALL MDESCCHK( ICTXT, NOUT, 'A', DESCA, MA, NA, MBA, NBA,
     $                     RSRCA, CSRCA, MPA, NQA, IPREPADA, IMIDPADA,
     $                     IPOSTPADA, 0, 0, IERR( 1 ) )
*
            CALL MDESCCHK( ICTXT, NOUT, 'B', DESCB, MB, NB, MBB, NBB,
     $                     RSRCB, CSRCB, MPB, NQB, IPREPADB, IMIDPADB,
     $                     IPOSTPADB, 0, 0, IERR( 2 ) )
*
            CALL MDESCCHK( ICTXT, NOUT, 'A', DESCC, MC, NC, MBC, NBC,
     $                     RSRCC, CSRCC, MPC, NQC, IPREPADC, IMIDPADC,
     $                     IPOSTPADC, 0, 0, IERR( 3 ) )
*
            IF( IERR( 1 ).GT.0 .OR. IERR( 2 ).GT.0 .OR.
     $          IERR( 3 ).GT.0 ) THEN
               GO TO 40
            END IF
*
*           Assign pointers into MEM for matrices corresponding to
*           the distributed matrices A, X and Y.
*
            IPA = IPREPADA + 1
            IPB = IPA + DESCA( LLD_ )*NQA
            IPC = IPB + DESCB( LLD_ )*NQB
*
*           Check if sufficient memory.
*
            MEMREQD = IPC + DESCC( LLD_ )*NQC - 1
            IERR( 1 ) = 0
            IF( MEMREQD.GT.MEMSIZ ) THEN
               IF( IAM.EQ.0 )
     $            WRITE( NOUT, FMT = 9987 ) MEMREQD*REALSZ
               IERR( 1 ) = 1
            END IF
*
*           Check all processes for an error
*
            CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, 0 )
*
            IF( IERR( 1 ).GT.0 ) THEN
               IF( IAM.EQ.0 )
     $            WRITE( NOUT, FMT = 9988 )
               GO TO 40
            END IF
*
            IF( LSAME( SIDE, 'L' ) ) THEN
               KK = 0
            ELSE
               KK = 1
            END IF
*
*           Loop over all PBLAS 3 routines
*
            DO 30 L = 1, NSUBS
*
*              Continue only if this subroutine has to be tested.
*
               IF( .NOT.LTEST( L ) )
     $            GO TO 30
*
*              Define the size of the operands
*
               IF( L.EQ.1 ) THEN
                  NROWC = M
                  NCOLC = N
                  IF( LSAME( TRANSA, 'N' ) ) THEN
                     NROWA = M
                     NCOLA = K
                  ELSE
                     NROWA = K
                     NCOLA = M
                  END IF
                  IF( LSAME( TRANSB, 'N' ) ) THEN
                     NROWB = K
                     NCOLB = N
                  ELSE
                     NROWB = N
                     NCOLB = K
                  END IF
               ELSE IF( L.EQ.2 ) THEN
                  NROWC = M
                  NCOLC = N
                  NROWB = M
                  NCOLB = N
                  IF( LSAME( SIDE, 'L' ) ) THEN
                     NROWA = M
                     NCOLA = M
                  ELSE
                     NROWA = N
                     NCOLA = N
                  END IF
               ELSE IF( L.EQ.3 ) THEN
                  NROWC = N
                  NCOLC = N
                  IF( LSAME( TRANSA, 'N' ) ) THEN
                     NROWA = N
                     NCOLA = K
                  ELSE
                     NROWA = K
                     NCOLA = N
                  END IF
                  NROWB = 0
                  NCOLB = 0
               ELSE IF( L.EQ.4 ) THEN
                  NROWC = N
                  NCOLC = N
                  IF( LSAME( TRANSA, 'N' ) ) THEN
                     NROWA = N
                     NCOLA = K
                     NROWB = N
                     NCOLB = K
                  ELSE
                     NROWA = K
                     NCOLA = N
                     NROWB = K
                     NCOLB = N
                  END IF
               ELSE IF( L.EQ.5 ) THEN
                  NROWA = N
                  NCOLA = M
                  NROWC = M
                  NCOLC = N
                  NROWB = 0
                  NCOLB = 0
               ELSE IF( L.EQ.6 .OR. L.EQ.7 ) THEN
                  NROWB = M
                  NCOLB = N
                  IF( LSAME( SIDE, 'L' ) ) THEN
                     NROWA = M
                     NCOLA = M
                  ELSE
                     NROWA = N
                     NCOLA = N
                  END IF
                  NROWC = 0
                  NCOLC = 0
               END IF
*
*              Check the validity of the operand sizes
*
               CALL MDIMCHK( ICTXT, NOUT, NROWA, NCOLA, 'A', IA, JA,
     $                       DESCA, IERR( 1 ) )
               CALL MDIMCHK( ICTXT, NOUT, NROWB, NCOLB, 'B', IB, JB,
     $                       DESCB, IERR( 2 ) )
               CALL MDIMCHK( ICTXT, NOUT, NROWC, NCOLC, 'C', IC, JC,
     $                       DESCC, IERR( 3 ) )
*
               IF( IERR( 1 ).NE.0 .OR. IERR( 2 ).NE.0 .OR.
     $             IERR( 3 ).NE.0 ) THEN
                  GO TO 30
               END IF
*
*              Generate distributed matrices A, B and C
*
               IF( L.EQ.2 ) THEN
                  AFORM = 'S'
                  CFORM = 'N'
               ELSE IF( L.EQ.3 .OR. L.EQ.4 ) THEN
                  AFORM = 'N'
                  CFORM = 'S'
               ELSE
                  AFORM = 'N'
                  CFORM = 'N'
               END IF
*
*              Avoid weakness of Matrix generator
*
               IF( LSAME( AFORM, 'S' ) .OR. LSAME( AFORM, 'H' ) ) THEN
                  IF( DESCA( M_ ).NE.DESCA( N_ ) .OR. IA.NE.JA ) THEN
                     IF( IAM.EQ.0 )
     $                  WRITE( NOUT, FMT = 9979 )
                     GO TO 30
                  END IF
               END IF
               IF( LSAME( CFORM, 'S' ) .OR. LSAME( CFORM, 'H' ) ) THEN
                  IF( DESCC( M_ ).NE.DESCC( N_ ) .OR. IC.NE.JC ) THEN
                     IF( IAM.EQ.0 )
     $                  WRITE( NOUT, FMT = 9979 )
                     GO TO 30
                  END IF
               END IF
*
               CALL PBSMATGEN( ICTXT, AFORM, 'No diag', DESCA( M_ ),
     $                         DESCA( N_ ), DESCA( MB_ ), DESCA( NB_ ),
     $                         MEM( IPA ), DESCA( LLD_ ),
     $                         DESCA( RSRC_ ), DESCA( CSRC_ ), IASEED,
     $                         0, MPA, 0, NQA, MYROW, MYCOL, NPROW,
     $                         NPCOL )
*
               IF( BCHECK( L ) ) THEN
                  CALL PBSMATGEN( ICTXT, 'None', 'No diag', DESCB( M_ ),
     $                            DESCB( N_ ), DESCB( MB_ ),
     $                            DESCB( NB_ ), MEM( IPB ),
     $                            DESCB( LLD_ ), DESCB( RSRC_ ),
     $                            DESCB( CSRC_ ), IBSEED, 0, MPB, 0,
     $                            NQB, MYROW, MYCOL, NPROW, NPCOL )
               END IF
*
               IF( CCHECK( L ) ) THEN
                  CALL PBSMATGEN( ICTXT, CFORM, 'No diag', DESCC( M_ ),
     $                            DESCC( N_ ), DESCC( MB_ ),
     $                            DESCC( NB_ ), MEM( IPC ),
     $                            DESCC( LLD_ ), DESCC( RSRC_ ),
     $                            DESCC( CSRC_ ), ICSEED, 0, MPC, 0,
     $                            NQC, MYROW, MYCOL, NPROW, NPCOL )
               END IF
*
               INFO = 0
               CALL SLBOOT()
               CALL BLACS_BARRIER( ICTXT, 'All' )
*
*              Call the Level 3 PBLAS routine
*
               IF( L.EQ.1 ) THEN
*
*                 Test PSGEMM
*
                  NOPS = PDOPBL3( SNAMES( L ), M, N, K )
                  CALL SLTIMER( 1 )
                  CALL PSGEMM( TRANSA, TRANSB, M, N, K, ALPHA,
     $                         MEM( IPA ), IA, JA, DESCA, MEM( IPB ),
     $                         IB, JB, DESCB, BETA, MEM( IPC ), IC, JC,
     $                         DESCC )
                  CALL SLTIMER( 1 )
*
               ELSE IF( L.EQ.2 ) THEN
*
*                 Test PSSYMM
*
                  NOPS = PDOPBL3( SNAMES( L ), M, N, KK )
                  CALL SLTIMER( 1 )
                  CALL PSSYMM( SIDE, UPLO, M, N, ALPHA, MEM( IPA ), IA,
     $                         JA, DESCA, MEM( IPB ), IB, JB, DESCB,
     $                         BETA, MEM( IPC ), IC, JC, DESCC )
                  CALL SLTIMER( 1 )
*
               ELSE IF( L.EQ.3 ) THEN
*
*                 Test PSSYRK
*
                  NOPS = PDOPBL3( SNAMES( L ), N, N, K )
                  CALL SLTIMER( 1 )
                  CALL PSSYRK( UPLO, TRANSA, N, K, ALPHA, MEM( IPA ),
     $                         IA, JA, DESCA, BETA, MEM( IPC ), IC, JC,
     $                         DESCC )
                  CALL SLTIMER( 1 )
*
               ELSE IF( L.EQ.4 ) THEN
*
*                 Test PSSYR2K
*
                  NOPS = PDOPBL3( SNAMES( L ), N, N, K )
                  CALL SLTIMER( 1 )
                  CALL PSSYR2K( UPLO, TRANSA, N, K, ALPHA, MEM( IPA ),
     $                          IA, JA, DESCA, MEM( IPB ), IB, JB,
     $                          DESCB, BETA, MEM( IPC ), IC, JC,
     $                          DESCC )
                  CALL SLTIMER( 1 )
*
               ELSE IF( L.EQ.5 ) THEN
*
*                 Test PSTRAN
*
                  NOPS = 0.0D+0
                  CALL SLTIMER( 1 )
                  CALL PSTRAN( M, N, ALPHA, MEM( IPA ), IA, JA, DESCA,
     $                         BETA, MEM( IPC ), IC, JC, DESCC )
                  CALL SLTIMER( 1 )
*
               ELSE IF( L.EQ.6 ) THEN
*
*                 Test PSTRMM
*
                  NOPS = PDOPBL3( SNAMES( L ), M, N, KK )
                  CALL SLTIMER( 1 )
                  CALL PSTRMM( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA,
     $                         MEM( IPA ), IA, JA, DESCA, MEM( IPB ),
     $                         IB, JB, DESCB )
                  CALL SLTIMER( 1 )
*
               ELSE IF( L.EQ.7 ) THEN
*
*                 Test PSTRSM
*
                  NOPS = PDOPBL3( SNAMES( L ), M, N, KK )
                  CALL SLTIMER( 1 )
                  CALL PSTRSM( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA,
     $                         MEM( IPA ), IA, JA, DESCA, MEM( IPB ),
     $                         IB, JB, DESCB )
                  CALL SLTIMER( 1 )
*
               END IF
*
*              Check if the operation has been performed.
*
               IF( INFO.NE.0 ) THEN
                  IF( IAM.EQ.0 )
     $               WRITE( NOUT, FMT = 9982 ) INFO
                  GO TO 30
               END IF
*
               CALL SLCOMBINE( ICTXT, 'All', '>', 'W', 1, 1, WTIME )
               CALL SLCOMBINE( ICTXT, 'All', '>', 'C', 1, 1, CTIME )
*
*              Only node 0 prints timing test result
*
               IF( IAM.EQ.0 ) THEN
*
*                 Print WALL time if machine supports it
*
                  IF( WTIME( 1 ).GT.0.0D+0 ) THEN
                     WFLOPS = NOPS / ( WTIME( 1 ) * 1.0D+6 )
                  ELSE
                     WFLOPS = 0.0D+0
                  END IF
*
*                 Print CPU time if machine supports it
*
                  IF( CTIME( 1 ).GT.0.0D+0 ) THEN
                     CFLOPS = NOPS / ( CTIME( 1 ) * 1.0D+6 )
                  ELSE
                     CFLOPS = 0.0D+0
                  END IF
*
                  WRITE( NOUT, FMT = 9981 ) SNAMES( L ), WTIME( 1 ),
     $                                      WFLOPS, CTIME( 1 ), CFLOPS
*
               END IF
*
   30       CONTINUE
*
   40       IF( IAM.EQ.0 ) THEN
               WRITE( NOUT, FMT = 9995 )
               WRITE( NOUT, FMT = * )
               WRITE( NOUT, FMT = 9986 ) J
            END IF
*
   50   CONTINUE
*
        CALL BLACS_GRIDEXIT( ICTXT )
*
   60 CONTINUE
*
      IF( IAM.EQ.0 ) THEN
         WRITE( NOUT, FMT = * )
         WRITE( NOUT, FMT = 9985 )
         WRITE( NOUT, FMT = * )
      END IF
*
      CALL BLACS_EXIT( 0 )
*
 9999 FORMAT( 'ILLEGAL ', A, ': ', A, ' = ', I10,
     $        ' should be at least 1' )
 9998 FORMAT( 'ILLEGAL GRID: NPROW*NPCOL = ', I4,
     $        '. It can be at most', I4 )
 9997 FORMAT( 'Bad ', A, ' parameters: going on to next test case.' )
 9996 FORMAT( 2X, 'Test number ', I2 , ' started on a ', I4, ' x ',
     $        I4, ' process grid.' )
 9995 FORMAT( 2X, '   ------------------------------------------------',
     $        '-------------------' )
 9994 FORMAT( 2X, '        M      N      K    SIDE  UPLO  TRANSA  ',
     $        'TRANSB  DIAG' )
 9993 FORMAT( 5X,I6,1X,I6,1X,I6,6X,A1,5X,A1,6X,A1,7X,A1,6X,A1 )
 9992 FORMAT( 2X, '       IA     JA     MA     NA    MBA    NBA',
     $        ' RSRCA CSRCA' )
 9991 FORMAT( 5X,I6,1X,I6,1X,I6,1X,I6,1X,I6,1X,I6,1X,I5,1X,I5 )
 9990 FORMAT( 2X, '       IB     JB     MB     NB    MBB    NBB',
     $        ' RSRCB CSRCB' )
 9989 FORMAT( 2X, '       IC     JC     MC     NC    MBC    NBC',
     $        ' RSRCC CSRCC' )
 9988 FORMAT( 'Not enough memory for this test: going on to',
     $        ' next test case.' )
 9987 FORMAT( 'Not enough memory. Need: ', I12 )
 9986 FORMAT( 2X, 'Test number ', I2, ' completed.' )
 9985 FORMAT( 2X, 'End of Tests.' )
 9984 FORMAT( 2X, 'Tests started.' )
 9983 FORMAT( 5X, A, '     ***** ', A, ' has an incorrect value:     ',
     $            ' BYPASS  *****' )
 9982 FORMAT( 2X, '   ***** Operation not supported, error code: ',
     $        I5, ' *****' )
 9981 FORMAT( 2X, '   ', A, 2X, F13.3, 2X, F13.3, 2X, F13.3, 2X, F13.3 )
 9980 FORMAT( 2X, '            WALL time (s)    WALL Mflops ',
     $        '  CPU time (s)     CPU Mflops' )
 9979 FORMAT( 2X, '   ***** Test not supported yet: SKIPPED *****' )
*
      STOP
*
*     End of PSBLA3TIM
*
      END
      SUBROUTINE PSBLA3TIMINFO( SUMMRY, NOUT, NMAT, DIAGVAL, SIDEVAL,
     $                          TRANSAVAL, TRANSBVAL, UPLOVAL, MVAL,
     $                          NVAL, KVAL, MAVAL, NAVAL, MBAVAL,
     $                          NBAVAL, RSRCAVAL, CSRCAVAL, IAVAL,
     $                          JAVAL, MBVAL, NBVAL, MBBVAL, NBBVAL,
     $                          RSRCBVAL, CSRCBVAL, IBVAL, JBVAL, MCVAL,
     $                          NCVAL, MBCVAL, NBCVAL, RSRCCVAL,
     $                          CSRCCVAL, ICVAL, JCVAL, LDVAL, NGRIDS,
     $                          PVAL, LDPVAL, QVAL, LDQVAL, LTEST, IAM,
     $                          NPROCS, ALPHA, BETA, WORK )
*
*  -- PBLAS test routine (version 1.5) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     May 1, 1997
*
*     .. Scalar Arguments ..
      CHARACTER*( * )    SUMMRY
      INTEGER            IAM, LDPVAL, LDQVAL, LDVAL, NGRIDS, NMAT, NOUT,
     $                   NPROCS
      REAL               ALPHA, BETA
*     ..
*     .. Array Arguments ..
      CHARACTER          DIAGVAL( LDVAL ), SIDEVAL( LDVAL ),
     $                   TRANSAVAL( LDVAL ), TRANSBVAL( LDVAL ),
     $                   UPLOVAL( LDVAL )
      LOGICAL            LTEST( * )
      INTEGER            CSRCAVAL( LDVAL ), CSRCBVAL( LDVAL ),
     $                   CSRCCVAL( LDVAL ), IAVAL( LDVAL ),
     $                   IBVAL( LDVAL ), ICVAL( LDVAL ), JAVAL( LDVAL ),
     $                   JBVAL( LDVAL ), JCVAL( LDVAL ), KVAL( LDVAL ),
     $                   MVAL( LDVAL ), MAVAL( LDVAL ), MBAVAL( LDVAL ),
     $                   MBBVAL( LDVAL ), MBCVAL( LDVAL ),
     $                   MBVAL( LDVAL ), MCVAL( LDVAL ), NAVAL( LDVAL ),
     $                   NBAVAL( LDVAL ), NBBVAL( LDVAL ),
     $                   NBCVAL( LDVAL ), NBVAL( LDVAL ),
     $                   NCVAL( LDVAL ), NVAL( LDVAL ), PVAL( LDPVAL ),
     $                   QVAL( LDQVAL ), RSRCAVAL( LDVAL ),
     $                   RSRCBVAL( LDVAL ), RSRCCVAL( LDVAL ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  PSBLA3TIMINFO gets needed startup information for timing various
*  PBLAS 3 routines, and transmits it to all processes.
*
*  Arguments
*  =========
*
*  SUMMRY    (global output) CHARACTER*(*)
*            Name of output (summary) file (if any). Only defined for
*            process 0.
*
*  NOUT      (global output) INTEGER
*            The unit number for output file. NOUT = 6, ouput to screen,
*            NOUT = 0, output to stderr.  Only defined for process 0.
*
*  NMAT      (global output) INTEGER
*            The number of different test cases.
*
*  DIAGVAL   (global output) CHARACTER array, dimension (LDVAL)
*            The values of DIAG to run the code with.
*
*  SIDEVAL   (global output) CHARACTER array, dimension (LDVAL)
*            The values of SIDE to run the code with.
*
*  TRANSAVAL (global output) CHARACTER array, dimension (LDVAL)
*            The values of TRANSA to run the code with.
*
*  TRANSBVAL (global output) CHARACTER array, dimension (LDVAL)
*            The values of TRANSA to run the code with.
*
*  UPLOVAL   (global output) CHARACTER array, dimension (LDVAL)
*            The values of UPLO to run the code with.
*
*  MVAL      (global output) INTEGER array, dimension (LDVAL)
*            The values of M to run the code with.
*
*  NVAL      (global output) INTEGER array, dimension (LDVAL)
*            The values of N to run the code with.
*
*  KVAL      (global output) INTEGER array, dimension (LDVAL)
*            The values of K to run the code with.
*
*  MAVAL     (global output) INTEGER array, dimension (LDVAL)
*            The values of DESCA( M_ ) (number of rows in the
*            distributed matrix A) to run the code with.
*
*  NAVAL     (global output) INTEGER array, dimension (LDVAL)
*            The values of DESCA( N_ ) (number of columns in the
*            distributed matrix A) to run the code with.
*
*  MBAVAL    (global output) INTEGER array, dimension (LDVAL)
*            The values of DESCA( MB_ ) (row block sizes of the
*            distributed matrix A) to run the code with.
*
*  NBAVAL    (global output) INTEGER array, dimension (LDVAL)
*            The values of DESCA( NB_ ) (column block sizes of
*            the distributed matrix A) to run the code with.
*
*  RSRCAVAL  (global output) INTEGER array, dimension (LDVAL)
*            The values of DESCA( RSRC_ ) (row process source of
*            the distributed matrix A) to run the code with.
*
*  CSRCAVAL  (global output) INTEGER array, dimension (LDVAL)
*            The values of DESCA( CSRC_ ) (column process source
*            of the distributed matrix A) to run the code with.
*
*  IAVAL     (global output) INTEGER array, dimension (LDVAL)
*            The values of IA (global row source index of the
*            matrix operand A) to run the code with.
*
*  JAVAL     (global output) INTEGER array, dimension (LDVAL)
*            The values of JA (global column source index of
*            the matrix operand A) to run the code with.
*
*  MBVAL     (global output) INTEGER array, dimension (LDVAL)
*            The values of DESCB( M_ ) (number of rows in the
*            distributed matrix B) to run the code with.
*
*  NBVAL     (global output) INTEGER array, dimension (LDVAL)
*            The values of DESCB( N_ ) (number of columns in the
*            distributed matrix B) to run the code with.
*
*  MBBVAL    (global output) INTEGER array, dimension (LDVAL)
*            The values of DESCB( MB_ ) (row block sizes of the
*            distributed matrix B) to run the code with.
*
*  NBBVAL    (global output) INTEGER array, dimension (LDVAL)
*            The values of DESCB( NB_ ) (column block sizes of
*            the distributed matrix B) to run the code with.
*
*  RSRCBVAL  (global output) INTEGER array, dimension (LDVAL)
*            The values of DESCB( RSRC_ ) (row process source of
*            the distributed matrix B) to run the code with.
*
*  CSRCBVAL  (global output) INTEGER array, dimension (LDVAL)
*            The values of DESCB( CSRC_ ) (column process source
*            of the distributed matrix B) to run the code with.
*
*  IBVAL     (global output) INTEGER array, dimension (LDVAL)
*            The values of IB (global row source index of the
*            matrix operand B) to run the code with.
*
*  JBVAL     (global output) INTEGER array, dimension (LDVAL)
*            The values of JB (global column source index of
*            the matrix operand B) to run the code with.
*
*  MCVAL     (global output) INTEGER array, dimension (LDVAL)
*            The values of DESCC( M_ ) (number of rows in the
*            distributed matrix C) to run the code with.
*
*  NCVAL     (global output) INTEGER array, dimension (LDVAL)
*            The values of DESCC( N_ ) (number of columns in
*            the distributed matrix C) to run the code with.
*
*  MBCVAL    (global output) INTEGER array, dimension (LDVAL)
*            The values of DESCC( MB_ ) (row block sizes of the
*            distributed matrix C) to run the code with.
*
*  NBCVAL    (global output) INTEGER array, dimension (LDVAL)
*            The values of DESCC( NB_ ) (column block sizes of
*            the distributed matrix C) to run the code with.
*
*  RSRCCVAL  (global output) INTEGER array, dimension (LDVAL)
*            The values of DESCC( RSRC_ ) (row process source of
*            the distributed matrix C) to run the code with.
*
*  CSRCCVAL  (global output) INTEGER array, dimension (LDVAL)
*            The values of DESCC( CSRC_ ) (column process source
*            of the distributed matrix C) to run the code with.
*
*  ICVAL     (global output) INTEGER array, dimension (LDVAL)
*            The values of IC (global row source index of the
*            matrix operand C) to run the code with.
*
*  JCVAL     (global output) INTEGER array, dimension (LDVAL)
*            The values of JC (global column source index of
*            the matrix operand C) to run the code with.
*
*  LDVAL     (global output) INTEGER array, dimension (LDVAL)
*            The maximum number of different values that can be used for
*            DIAG, SIDE, TRANSA, TRANSB, UPLO, M, N, K, DESCA, IA, JA,
*            DESCB, IB, JB, DESCC, IC, JC. This is also the maximum
*            number of test cases.
*
*  NGRIDS    (global output) INTEGER
*            The number of different values that can be used for P & Q.
*
*  PVAL      (global output) INTEGER array, dimension (LDPVAL)
*            The values of P (number of process rows) to run the code
*            with.
*
*  LDPVAL    (global input) INTEGER
*            The maximum number of different values that can be used for
*            P, LDPVAL >= NGRIDS.
*
*  QVAL      (global output) INTEGER array, dimension (LDQVAL)
*            The values of Q (number of process columns) to run the code
*            with.
*
*  LDQVAL    (global input) INTEGER
*            The maximum number of different values that can be used for
*            Q, LDQVAL >= NGRIDS.
*
*  LTEST     (Global output) LOGICAL array, dimension (>= 7)
*            If LTEST( i ) is .TRUE. on exit, the i-th PBLAS-3 routine
*            will be tested. See the input file for the ordering of the
*            routines.
*
*  IAM       (local input) INTEGER
*            My process number.
*
*  NPROCS    (global input) INTEGER
*            The total number of processes.
*
*  ALPHA     (global output) REAL
*            The value of ALPHA to be used in all the test cases.
*
*  BETA      (global output) REAL
*            The value of BETA to be used in all the test cases.
*
*  WORK      (local workspace) INTEGER array of dimension >=
*            MAX( 2, 2*NGRIDS+32*NMAT+NSUBS ) with NSUBS = 7. Used to
*            pack all input arrays in order to send info in one message.
*
* ======================================================================
*
* Note: For packing the information we assumed that the length in bytes
* ===== of an integer is equal to the length in bytes of a real single
*       precision.
*
* ======================================================================
*
*     .. Parameters ..
      INTEGER            NIN, NSUBS
      PARAMETER          ( NIN = 11, NSUBS = 7 )
*     ..
*     .. Local Scalars ..
      CHARACTER*7        SNAMET
      CHARACTER*79       USRINFO
      LOGICAL            LTESTT
      INTEGER            I, ICTXT, J
*     ..
*     .. External Subroutines ..
      EXTERNAL           BLACS_ABORT, BLACS_GET, BLACS_GRIDEXIT,
     $                   BLACS_GRIDINIT, BLACS_SETUP, ICOPY, IGEBR2D,
     $                   IGEBS2D, SGEBR2D, SGEBS2D
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          CHAR, ICHAR, MAX, MIN
*     ..
*     .. Scalars in Common ..
      CHARACTER*7        SNAMES( NSUBS )
*     ..
*     .. Common blocks ..
      COMMON             /SNAMEC/SNAMES
*     ..
*     .. Executable Statements ..
*
*     Process 0 reads the input data, broadcasts to other processes and
*     writes needed information to NOUT
*
      IF( IAM.EQ.0 ) THEN
*
*        Open file and skip data file header
*
         OPEN( NIN, FILE='PSBLA3TIM.dat', STATUS='OLD' )
         READ( NIN, FMT = * ) SUMMRY
         SUMMRY = ' '
*
*        Read in user-supplied info about machine type, compiler, etc.
*
         READ( NIN, FMT = 9999 ) USRINFO
*
*        Read name and unit number for summary output file
*
         READ( NIN, FMT = * ) SUMMRY
         READ( NIN, FMT = * ) NOUT
         IF( NOUT.NE.0 .AND. NOUT.NE.6 )
     $      OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' )
*
*        Read and check the parameter values for the tests.
*
*        Get number of grids
*
         READ( NIN, FMT = * ) NGRIDS
         IF( NGRIDS.LT.1 .OR. NGRIDS.GT.LDPVAL ) THEN
            WRITE( NOUT, FMT = 9998 ) 'Grids', LDPVAL
            GO TO 120
         ELSE IF( NGRIDS.GT.LDQVAL ) THEN
            WRITE( NOUT, FMT = 9998 ) 'Grids', LDQVAL
            GO TO 120
         END IF
*
*        Get values of P and Q
*
         READ( NIN, FMT = * ) ( PVAL( I ), I = 1, NGRIDS )
         READ( NIN, FMT = * ) ( QVAL( I ), I = 1, NGRIDS )
*
*        Read ALPHA, BETA
*
         READ( NIN, FMT = * ) ALPHA
         READ( NIN, FMT = * ) BETA
*
*        Read number of tests.
*
         READ( NIN, FMT = * ) NMAT
         IF( NMAT.LT.1 .OR. NMAT.GT.LDVAL ) THEN
            WRITE( NOUT, FMT = 9998 ) 'Tests', LDVAL
            GO TO 120
         ENDIF
*
*        Read in input data into arrays.
*
         READ( NIN, FMT = * ) ( DIAGVAL( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( SIDEVAL( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( TRANSAVAL( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( TRANSBVAL( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( UPLOVAL( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( MVAL( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( NVAL( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( KVAL( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( MAVAL( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( NAVAL( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( MBAVAL( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( NBAVAL( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( RSRCAVAL( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( CSRCAVAL( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( IAVAL( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( JAVAL( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( MBVAL( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( NBVAL( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( MBBVAL( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( NBBVAL( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( RSRCBVAL( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( CSRCBVAL( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( IBVAL( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( JBVAL( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( MCVAL( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( NCVAL( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( MBCVAL( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( NBCVAL( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( RSRCCVAL( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( CSRCCVAL( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( ICVAL( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( JCVAL( I ), I = 1, NMAT )
*
*        Read names of subroutines and flags which indicate
*        whether they are to be tested.
*
         DO 10 I = 1, NSUBS
            LTEST( I ) = .FALSE.
   10    CONTINUE
   20    CONTINUE
         READ( NIN, FMT = 9996, END = 50 ) SNAMET, LTESTT
         DO 30 I = 1, NSUBS
            IF( SNAMET.EQ.SNAMES( I ) )
     $         GO TO 40
   30    CONTINUE
*
         WRITE( NOUT, FMT = 9995 )SNAMET
         GO TO 120
*
   40    CONTINUE
         LTEST( I ) = LTESTT
         GO TO 20
*
   50    CONTINUE
*
*        Close input file
*
         CLOSE ( NIN )
*
*        For pvm only: if virtual machine not set up, allocate it and
*        spawn the correct number of processes.
*
         IF( NPROCS.LT.1 ) THEN
            NPROCS = 0
            DO 60 I = 1, NGRIDS
               NPROCS = MAX( NPROCS, PVAL( I )*QVAL( I ) )
   60       CONTINUE
            CALL BLACS_SETUP( IAM, NPROCS )
         END IF
*
*        Temporarily define blacs grid to include all processes so
*        information can be broadcast to all processes
*
         CALL BLACS_GET( -1, 0, ICTXT )
         CALL BLACS_GRIDINIT( ICTXT, 'Row-major', 1, NPROCS )
*
*        Pack information arrays and broadcast
*
         CALL SGEBS2D( ICTXT, 'All', ' ', 1, 1, ALPHA, 1 )
         CALL SGEBS2D( ICTXT, 'All', ' ', 1, 1, BETA, 1 )
*
         WORK( 1 ) = NGRIDS
         WORK( 2 ) = NMAT
         CALL IGEBS2D( ICTXT, 'All', ' ', 2, 1, WORK, 2 )
*
         I = 1
         DO 70 J = 1, NMAT
            WORK( I ) = ICHAR( DIAGVAL( J ) )
            WORK( I+1 ) = ICHAR( SIDEVAL( J ) )
            WORK( I+2 ) = ICHAR( TRANSAVAL( J ) )
            WORK( I+3 ) = ICHAR( TRANSBVAL( J ) )
            WORK( I+4 ) = ICHAR( UPLOVAL( J ) )
            I = I + 5
   70    CONTINUE
         CALL ICOPY( NGRIDS, PVAL, 1, WORK( I ), 1 )
         I = I + NGRIDS
         CALL ICOPY( NGRIDS, QVAL, 1, WORK( I ), 1 )
         I = I + NGRIDS
         CALL ICOPY( NMAT, MVAL, 1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, NVAL, 1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, KVAL, 1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, MAVAL, 1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, NAVAL, 1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, MBAVAL, 1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, NBAVAL, 1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, RSRCAVAL, 1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, CSRCAVAL, 1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, IAVAL, 1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, JAVAL, 1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, MBVAL, 1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, NBVAL, 1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, MBBVAL, 1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, NBBVAL, 1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, RSRCBVAL, 1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, CSRCBVAL, 1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, IBVAL, 1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, JBVAL, 1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, MCVAL, 1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, NCVAL, 1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, MBCVAL, 1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, NBCVAL, 1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, RSRCCVAL, 1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, CSRCCVAL, 1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, ICVAL, 1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, JCVAL, 1, WORK( I ), 1 )
         I = I + NMAT
*
         DO 80 J = 1, NSUBS
            IF( LTEST( J ) ) THEN
               WORK( I ) = 1
            ELSE
               WORK( I ) = 0
            END IF
            I = I + 1
   80    CONTINUE
         I = I - 1
         CALL IGEBS2D( ICTXT, 'All', ' ', I, 1, WORK, I )
*
*        regurgitate input
*
         WRITE( NOUT, FMT = 9999 )
     $               'ScaLAPACK Level-3 PBLAS timing program.'
         WRITE( NOUT, FMT = 9999 ) USRINFO
         WRITE( NOUT, FMT = * )
         WRITE( NOUT, FMT = 9999 )
     $               'Tests of the real single precision '//
     $               'Level-3 PBLAS'
         WRITE( NOUT, FMT = * )
         WRITE( NOUT, FMT = 9992 ) NMAT
         WRITE( NOUT, FMT = 9991 ) NGRIDS
         WRITE( NOUT, FMT = 9989 )
     $               'P', ( PVAL(I), I = 1, MIN(NGRIDS, 5) )
         IF( NGRIDS.GT.5 )
     $      WRITE( NOUT, FMT = 9990 ) ( PVAL(I), I = 6,
     $                                  MAX( 10, NGRIDS ) )
         IF( NGRIDS.GT.10 )
     $      WRITE( NOUT, FMT = 9990 ) ( PVAL(I), I = 11,
     $                                  MAX( 15, NGRIDS ) )
         IF( NGRIDS.GT.15 )
     $      WRITE( NOUT, FMT = 9990 ) ( PVAL(I), I = 16, NGRIDS )
         WRITE( NOUT, FMT = 9989 )
     $               'Q', ( QVAL(I), I = 1, MIN(NGRIDS, 5) )
         IF( NGRIDS.GT.5 )
     $      WRITE( NOUT, FMT = 9990 ) ( QVAL(I), I = 6,
     $                                  MAX( 10, NGRIDS ) )
         IF( NGRIDS.GT.10 )
     $      WRITE( NOUT, FMT = 9990 ) ( QVAL(I), I = 11,
     $                                  MAX( 15, NGRIDS ) )
         IF( NGRIDS.GT.15 )
     $      WRITE( NOUT, FMT = 9990 ) ( QVAL(I), I = 16, NGRIDS )
         WRITE( NOUT, FMT = 9994 ) ALPHA
         WRITE( NOUT, FMT = 9993 ) BETA
         IF( LTEST( 1 ) ) THEN
            WRITE( NOUT, FMT = 9988 ) SNAMES( 1 ), ' ... Yes'
         ELSE
            WRITE( NOUT, FMT = 9988 ) SNAMES( 1 ), ' ... No '
         END IF
         DO 90 I = 2, NSUBS
            IF( LTEST( I ) ) THEN
               WRITE( NOUT, FMT = 9987 ) SNAMES( I ), ' ... Yes'
            ELSE
               WRITE( NOUT, FMT = 9987 ) SNAMES( I ), ' ... No '
            END IF
   90    CONTINUE
         WRITE( NOUT, FMT = * )
*
      ELSE
*
*        If in pvm, must participate setting up virtual machine
*
         IF( NPROCS.LT.1 )
     $      CALL BLACS_SETUP( IAM, NPROCS )
*
*        Temporarily define blacs grid to include all processes so
*        information can be broadcast to all processes
*
         CALL BLACS_GET( -1, 0, ICTXT )
         CALL BLACS_GRIDINIT( ICTXT, 'Row-major', 1, NPROCS )
*
         CALL SGEBR2D( ICTXT, 'All', ' ', 1, 1, ALPHA, 1, 0, 0 )
         CALL SGEBR2D( ICTXT, 'All', ' ', 1, 1, BETA, 1, 0, 0 )
*
         CALL IGEBR2D( ICTXT, 'All', ' ', 2, 1, WORK, 2, 0, 0 )
         NGRIDS = WORK( 1 )
         NMAT   = WORK( 2 )
*
         I = 2*NGRIDS + 32*NMAT + NSUBS
         CALL IGEBR2D( ICTXT, 'All', ' ', I, 1, WORK, I, 0, 0 )
*
         I = 1
         DO 100 J = 1, NMAT
            DIAGVAL( J ) = CHAR( WORK( I ) )
            SIDEVAL( J ) = CHAR( WORK( I+1 ) )
            TRANSAVAL( J ) = CHAR( WORK( I+2 ) )
            TRANSBVAL( J ) = CHAR( WORK( I+3 ) )
            UPLOVAL( J ) = CHAR( WORK( I+4 ) )
            I = I + 5
  100    CONTINUE
         CALL ICOPY( NGRIDS, WORK( I ), 1, PVAL, 1 )
         I = I + NGRIDS
         CALL ICOPY( NGRIDS, WORK( I ), 1, QVAL, 1 )
         I = I + NGRIDS
         CALL ICOPY( NMAT, WORK( I ), 1, MVAL, 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, WORK( I ), 1, NVAL, 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, WORK( I ), 1, KVAL, 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, WORK( I ), 1, MAVAL, 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, WORK( I ), 1, NAVAL, 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, WORK( I ), 1, MBAVAL, 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, WORK( I ), 1, NBAVAL, 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, WORK( I ), 1, RSRCAVAL, 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, WORK( I ), 1, CSRCAVAL, 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, WORK( I ), 1, IAVAL, 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, WORK( I ), 1, JAVAL, 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, WORK( I ), 1, MBVAL, 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, WORK( I ), 1, NBVAL, 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, WORK( I ), 1, MBBVAL, 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, WORK( I ), 1, NBBVAL, 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, WORK( I ), 1, RSRCBVAL, 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, WORK( I ), 1, CSRCBVAL, 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, WORK( I ), 1, IBVAL, 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, WORK( I ), 1, JBVAL, 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, WORK( I ), 1, MCVAL, 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, WORK( I ), 1, NCVAL, 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, WORK( I ), 1, MBCVAL, 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, WORK( I ), 1, NBCVAL, 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, WORK( I ), 1, RSRCCVAL, 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, WORK( I ), 1, CSRCCVAL, 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, WORK( I ), 1, ICVAL, 1 )
         I = I + NMAT
         CALL ICOPY( NMAT, WORK( I ), 1, JCVAL, 1 )
         I = I + NMAT
*
         DO 110 J = 1, NSUBS
            IF( WORK( I ).EQ.1 ) THEN
               LTEST( J ) = .TRUE.
            ELSE
               LTEST( J ) = .FALSE.
            END IF
            I = I + 1
  110    CONTINUE
*
      END IF
*
      CALL BLACS_GRIDEXIT( ICTXT )
*
      RETURN
*
  120 WRITE( NOUT, FMT = 9997 )
      CLOSE( NIN )
      IF( NOUT.NE.6 .AND. NOUT.NE.0 )
     $   CLOSE( NOUT )
      CALL BLACS_ABORT( ICTXT, 1 )
*
      STOP
*
 9999 FORMAT( A )
 9998 FORMAT( ' Number of values of ',5A, ' is less than 1 or greater ',
     $        'than ', I2 )
 9997 FORMAT( ' Illegal input in file ',40A,'.  Aborting run.' )
 9996 FORMAT( A7, L2 )
 9995 FORMAT( '  Subprogram name ', A7, ' not recognized',
     $        /' ******* TESTS ABANDONED *******' )
 9994 FORMAT( 2X, 'Alpha                     : ', G16.6 )
 9993 FORMAT( 2X, 'Beta                      : ', G16.6 )
 9992 FORMAT( 2X, 'Number of Tests           : ', I6 )
 9991 FORMAT( 2X, 'Number of process grids   : ', I6 )
 9990 FORMAT( 2X, '                          : ', 5I6 )
 9989 FORMAT( 2X, A1, '                         : ', 5I6 )
 9988 FORMAT( 2X, 'Routines to be tested     :      ', A, A8 )
 9987 FORMAT( 2X, '                                 ', A, A8 )
*
*     End of PSBLA3TIMINFO
*
      END
