pzblas3tim.f

Go to the documentation of this file.

      BLOCK DATA
      INTEGER NSUBS
      parameter(nsubs = 11)
      CHARACTER*7        SNAMES( NSUBS )
      COMMON             /snamec/snames
      DATA               snames/'PZGEMM ', 'PZSYMM ', 'PZHEMM ',
     $                   'PZSYRK ', 'PZHERK ', 'PZSYR2K',
     $                   'PZHER2K', 'PZTRMM ', 'PZTRSM ',
     $                   'PZGEADD', 'PZTRADD'/
      END BLOCK DATA
      
      PROGRAM pzbla3tim
*
*  -- PBLAS timing driver (version 2.0.2) --
*     Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
*     May 1 2012
*
*  Purpose
*  =======
*
*  PZBLA3TIM  is the main timing program for the Level 3 PBLAS routines.
*
*  The program must be driven by a short data file.  An  annotated exam-
*  ple of a data file can be obtained by deleting the first 3 characters
*  from the following 59 lines:
*  'Level 3 PBLAS, Timing input file'
*  'Intel iPSC/860 hypercube, gamma model.'
*  'PZBLAS3TIM.SUMM'     output file name (if any)
*  6     device out
*  10              value of the logical computational blocksize NB
*  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.0D0, 0.0D0)  value of ALPHA
*  (1.0D0, 0.0D0)  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 IMB_A
*  2  5            values of INB_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 IMB_B
*  2  5            values of INB_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 IMB_C
*  2  5            values of INB_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
*  PZGEMM  T  put F for no test in the same column
*  PZSYMM  T  put F for no test in the same column
*  PZHEMM  T  put F for no test in the same column
*  PZSYRK  T  put F for no test in the same column
*  PZHERK  T  put F for no test in the same column
*  PZSYR2K T  put F for no test in the same column
*  PZHER2K T  put F for no test in the same column
*  PZTRMM  T  put F for no test in the same column
*  PZTRSM  T  put F for no test in the same column
*  PZGEADD T  put F for no test in the same column
*  PZTRADD T  put F for no test in the same column
*
*  Internal Parameters
*  ===================
*
*  TOTMEM  INTEGER
*          TOTMEM  is  a machine-specific parameter indicating the maxi-
*          mum  amount  of  available  memory per  process 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. By default, TOTMEM is 2000000.
*
*  DBLESZ  INTEGER
*  ZPLXSZ  INTEGER
*          DBLESZ  and  ZPLXSZ indicate the length in bytes on the given
*          platform  for a double  precision real and a double precision
*          complex. By default, DBLESZ is set to eight and ZPLXSZ is set
*          to sixteen.
*
*  MEM     COMPLEX*16 array
*          MEM is an array of dimension TOTMEM / ZPLXSZ.
*          All arrays used by SCALAPACK routines are allocated from this
*          array MEM and referenced by pointers. The  integer  IPA,  for
*          example, is a pointer to the starting element of MEM for  the
*          matrix A.
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            maxtests, maxgrids, zplxsz, totmem, memsiz,
     $                   nsubs
      COMPLEX*16         one
      parameter( maxtests = 20, maxgrids = 20, zplxsz = 16,
     $                   one = ( 1.0d+0, 0.0d+0 ), totmem = 2000000,
     $                   nsubs = 11, memsiz = totmem / zplxsz )
      INTEGER            block_cyclic_2d_inb, csrc_, ctxt_, dlen_,
     $                   dtype_, imb_, inb_, lld_, mb_, m_, nb_, n_,
     $                   rsrc_
      parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
     $                   dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
     $                   imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
     $                   rsrc_ = 9, csrc_ = 10, lld_ = 11 )
*     ..
*     .. Local Scalars ..
      CHARACTER*1        adiagdo, aform, cform, diag, side, transa,
     $                   transb, uplo
      INTEGER            csrca, csrcb, csrcc, i, ia, iam, iaseed, ib,
     $                   ibseed, ic, icseed, ictxt, imba, imbb, imbc,
     $                   imida, imidb, imidc, inba, inbb, inbc, ipa,
     $                   ipb, ipc, iposta, ipostb, ipostc, iprea, ipreb,
     $                   iprec, j, ja, jb, jc, k, l, m, ma, mb, mba,
     $                   mbb, mbc, mc, 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, offda, offdc, rsrca, rsrcb, rsrcc
      DOUBLE PRECISION   cflops, nops, WFLOPS
      COMPLEX*16         alpha, beta, scale
*     ..
*     .. Local Arrays ..
      LOGICAL            ltest( nsubs ), bcheck( nsubs ),
     $                   ccheck( nsubs )
      CHARACTER*1        diagval( maxtests ), sideval( maxtests ),
     $                   trnaval( maxtests ), trnbval( maxtests ),
     $                   uploval( maxtests )
      CHARACTER*80       outfile
      INTEGER            cscaval( maxtests ), cscbval( maxtests ),
     $                   csccval( maxtests ), desca( dlen_ ),
     $                   descb( dlen_ ), descc( dlen_ ),
     $                   iaval( maxtests ), ibval( maxtests ),
     $                   icval( maxtests ), ierr( 3 ),
     $                   imbaval( maxtests ), imbbval( maxtests ),
     $                   imbcval( maxtests ), inbaval( maxtests ),
     $                   inbbval( maxtests ), inbcval( maxtests ),
     $                   javal( maxtests ), jbval( maxtests ),
     $                   jcval( maxtests ), kval( maxtests ),
     $                   maval( maxtests ), mbaval( maxtests ),
     $                   mbbval( maxtests ), mbcval( maxtests ),
     $                   mbval( maxtests ), mcval( maxtests ),
     $                   mval( maxtests ), naval( maxtests ),
     $                   nbaval( maxtests ), nbbval( maxtests ),
     $                   nbcval( maxtests ), nbval( maxtests ),
     $                   ncval( maxtests ), nval( maxtests ),
     $                   pval( maxtests ), qval( maxtests ),
     $                   rscaval( maxtests ), rscbval( maxtests ),
     $                   rsccval( maxtests )
      DOUBLE PRECISION   ctime( 1 ), wtime( 1 )
      COMPLEX*16         mem( memsiz )
*     ..
*     .. External Subroutines ..
      EXTERNAL           blacs_barrier, blacs_exit, blacs_get,
     $                   blacs_gridexit, blacs_gridinfo, blacs_gridinit,
     $                   blacs_pinfo, igsum2d, pb_boot, pb_combine,
     $                   pb_timer, pmdescchk, pmdimchk, pzbla3timinfo,
     $                   pzgeadd, pzgemm, pzhemm, pzher2k, pzherk,
     $                   pzlagen, pzlascal, pzsymm, pzsyr2k, pzsyrk,
     $                   pztradd, pztrmm, pztrsm
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   pdopbl3
      EXTERNAL           lsame, pdopbl3
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          dble, dcmplx, max
*     ..
*     .. Common Blocks ..
      CHARACTER*7        snames( nsubs )
      LOGICAL            abrtflg
      INTEGER            INFO, nblog
      COMMON             /snamec/snames
      COMMON             /infoc/info, nblog
      COMMON             /pberrorc/nout, abrtflg
*     ..
*     .. Data Statements ..
      DATA               bcheck/.true., .true., .true., .false.,
     $                   .false., .true., .true., .true., .true.,
     $                   .false., .false./
      DATA               ccheck/.true., .true., .true., .true., .true.,
     $                   .true., .true., .false., .false., .true.,
     $                   .true./
*     ..
*     .. Executable Statements ..
*
*     Initialization
*
*     Set flag so that the PBLAS error handler 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 pzbla3timinfo( outfile, nout, ntests, diagval, sideval,
     $                    trnaval, trnbval, uploval, mval, nval,
     $                    kval, maval, naval, imbaval, mbaval,
     $                    inbaval, nbaval, rscaval, cscaval, iaval,
     $                    javal, mbval, nbval, imbbval, mbbval,
     $                    inbbval, nbbval, rscbval, cscbval, ibval,
     $                    jbval, mcval, ncval, imbcval, mbcval,
     $                    inbcval, nbcval, rsccval, csccval, icval,
     $                    jcval, maxtests, ngrids, pval, maxgrids,
     $                    qval, maxgrids, nblog, 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 = trnaval( j )
            transb = trnbval( j )
            uplo   = uploval( j )
*
            m      = mval( j )
            n      = nval( j )
            k      = kval( j )
*
            ma    = maval( j )
            na    = naval( j )
            imba  = imbaval( j )
            mba   = mbaval( j )
            inba  = inbaval( j )
            nba   = nbaval( j )
            rsrca = rscaval( j )
            csrca = cscaval( j )
            ia    = iaval( j )
            ja    = javal( j )
*
            mb    = mbval( j )
            nb    = nbval( j )
            imbb  = imbbval( j )
            mbb   = mbbval( j )
            inbb  = inbbval( j )
            nbb   = nbbval( j )
            rsrcb = rscbval( j )
            csrcb = cscbval( j )
            ib    = ibval( j )
            jb    = jbval( j )
*
            mc    = mcval( j )
            nc    = ncval( j )
            imbc  = imbcval( j )
            mbc   = mbcval( j )
            inbc  = inbcval( j )
            nbc   = nbcval( j )
            rsrcc = rsccval( j )
            csrcc = csccval( 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, imba, inba,
     $                                   mba, nba, rsrca, csrca
*
               WRITE( nout, fmt = 9995 )
               WRITE( nout, fmt = 9990 )
               WRITE( nout, fmt = 9995 )
               WRITE( nout, fmt = 9991 ) ib, jb, mb, nb, imbb, inbb,
     $                                   mbb, nbb, rsrcb, csrcb
*
               WRITE( nout, fmt = 9995 )
               WRITE( nout, fmt = 9989 )
               WRITE( nout, fmt = 9995 )
               WRITE( nout, fmt = 9991 ) ic, jc, mc, nc, imbc, inbc,
     $                                   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 pmdescchk( ictxt, nout, 'A', desca,
     $                      block_cyclic_2d_inb, ma, na, imba, inba,
     $                      mba, nba, rsrca, csrca, mpa, nqa, iprea,
     $                      imida, iposta, 0, 0, ierr( 1 ) )
*
            CALL pmdescchk( ictxt, nout, 'B', descb,
     $                      block_cyclic_2d_inb, mb, nb, imbb, inbb,
     $                      mbb, nbb, rsrcb, csrcb, mpb, nqb, ipreb,
     $                      imidb, ipostb, 0, 0, ierr( 2 ) )
*
            CALL pmdescchk( ictxt, nout, 'c', DESCC,
     $                      BLOCK_CYCLIC_2D_INB, MC, NC, IMBC, INBC,
     $                      MBC, NBC, RSRCC, CSRCC, MPC, NQC, IPREC,
     $                      IMIDC, IPOSTC, 0, 0, IERR( 3 ) )
*
.GT..OR..GT..OR.            IF( IERR( 1 )0  IERR( 2 )0 
.GT.     $          IERR( 3 )0 ) THEN
               GO TO 40
            END IF
*
*           Assign pointers into MEM for matrices corresponding to
*           the distributed matrices A, X and Y.
*
            IPA = IPREA + 1
            IPB = IPA + DESCA( LLD_ )*NQA
            IPC = IPB + DESCB( LLD_ )*NQB
*
*           Check if sufficient memory.
*
            MEMREQD = IPC + DESCC( LLD_ )*NQC - 1
            IERR( 1 ) = 0
.GT.            IF( MEMREQDMEMSIZ ) THEN
.EQ.               IF( IAM0 )
     $            WRITE( NOUT, FMT = 9987 ) MEMREQD*ZPLXSZ
               IERR( 1 ) = 1
            END IF
*
*           Check all processes for an error
*
            CALL IGSUM2D( ICTXT, 'all', ' ', 1, 1, IERR, 1, -1, 0 )
*
.GT.            IF( IERR( 1 )0 ) THEN
.EQ.               IF( IAM0 )
     $            WRITE( NOUT, FMT = 9988 )
               GO TO 40
            END IF
*
*           Loop over all PBLAS 3 routines
*
            DO 30 L = 1, NSUBS
*
*              Continue only if this subroutine has to be tested.
*
.NOT.               IF( LTEST( L ) )
     $            GO TO 30
*
*              Define the size of the operands
*
.EQ.               IF( L1 ) THEN
*
*                 PZGEMM
*
                  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
.EQ..OR..EQ.               ELSE IF( L2  L3 ) THEN
*
*                 PZSYMM, PZHEMM
*
                  NROWC = M
                  NCOLC = N
                  NROWB = M
                  NCOLB = N
                  IF( LSAME( SIDE, 'l' ) ) THEN
                     NROWA = M
                     NCOLA = M
                  ELSE
                     NROWA = N
                     NCOLA = N
                  END IF
.EQ..OR..EQ.               ELSE IF( L4  L5 ) THEN
*
*                 PZSYRK, PZHERK
*
                  NROWC = N
                  NCOLC = N
                  IF( LSAME( TRANSA, 'n' ) ) THEN
                     NROWA = N
                     NCOLA = K
                  ELSE
                     NROWA = K
                     NCOLA = N
                  END IF
                  NROWB = 0
                  NCOLB = 0
.EQ..OR..EQ.               ELSE IF( L6  L7 ) THEN
*
*                 PZSYR2K, PZHER2K
*
                  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
.EQ..OR..EQ.               ELSE IF( L8  L9 ) THEN
*
*                 PZTRMM, PZTRSM
*
                  NROWB = M
                  NCOLB = N
                  IF( LSAME( SIDE, 'l' ) ) THEN
                     NROWA = M
                     NCOLA = M
                  ELSE
                     NROWA = N
                     NCOLA = N
                  END IF
                  NROWC = 0
                  NCOLC = 0
.EQ..OR..EQ.               ELSE IF( L10  L11 ) THEN
*
*                 PZGEADD, PZTRADD
*
                  IF( LSAME( TRANSA, 'n' ) ) THEN
                     NROWA = M
                     NCOLA = N
                  ELSE
                     NROWA = N
                     NCOLA = M
                  END IF
                  NROWC = M
                  NCOLC = N
                  NROWB = 0
                  NCOLB = 0
*
               END IF
*
*              Check the validity of the operand sizes
*
               CALL PMDIMCHK( ICTXT, NOUT, NROWA, NCOLA, 'a', IA, JA,
     $                        DESCA, IERR( 1 ) )
               CALL PMDIMCHK( ICTXT, NOUT, NROWB, NCOLB, 'b', IB, JB,
     $                        DESCB, IERR( 2 ) )
               CALL PMDIMCHK( ICTXT, NOUT, NROWC, NCOLC, 'c', IC, JC,
     $                        DESCC, IERR( 3 ) )
*
.NE..OR..NE..OR.               IF( IERR( 1 )0  IERR( 2 )0 
.NE.     $             IERR( 3 )0 ) THEN
                  GO TO 30
               END IF
*
*              Check special values of TRANSA for symmetric and
*              hermitian rank-k and rank-2k updates.
*
.EQ..OR..EQ.               IF( L4  L6 ) THEN
.NOT.                  IF( LSAME( TRANSA, 'n.AND.' )
.NOT.     $                LSAME( TRANSA, 't' ) ) THEN
.EQ.                     IF( IAM0 )
     $                  WRITE( NOUT, FMT = 9983 ) SNAMES( L ), 'transa'
                     GO TO 30
                  END IF
.EQ..OR..EQ.               ELSE IF( L5  L7 ) THEN
.NOT.                  IF( LSAME( TRANSA, 'n.AND.' )
.NOT.     $                LSAME( TRANSA, 'c' ) ) THEN
.EQ.                     IF( IAM0 )
     $                  WRITE( NOUT, FMT = 9983 ) SNAMES( L ), 'transa'
                     GO TO 30
                  END IF
               END IF
*
*              Generate distributed matrices A, B and C
*
.EQ.               IF( L2 ) THEN
*
*                 PZSYMM
*
                  AFORM   = 's'
                  ADIAGDO = 'n'
                  OFFDA   = IA - JA
                  CFORM   = 'n'
                  OFFDC   = 0
*
.EQ.               ELSE IF( L3 ) THEN
*
*                 PZHEMM
*
                  AFORM   = 'h'
                  ADIAGDO = 'n'
                  OFFDA   = IA - JA
                  CFORM   = 'n'
                  OFFDC   = 0
*
.EQ..OR..EQ.               ELSE IF( L4  L6 ) THEN
*
*                 PZSYRK, PZSYR2K
*
                  AFORM   = 'n'
                  ADIAGDO = 'n'
                  OFFDA   = 0
                  CFORM   = 's'
                  OFFDC   = IC - JC
*
.EQ..OR..EQ.               ELSE IF( L5  L7 ) THEN
*
*                 PZHERK, PZHER2K
*
                  AFORM = 'n'
                  ADIAGDO = 'n'
                  OFFDA = 0
                  CFORM = 'h'
                  OFFDC = IC - JC
*
.EQ..AND.               ELSE IF( ( L9 )( LSAME( DIAG, 'n' ) ) ) THEN
*
*                 PZTRSM
*
                  AFORM   = 'n'
                  ADIAGDO = 'd'
                  OFFDA   = IA - JA
                  CFORM   = 'n'
                  OFFDC   = 0
*
               ELSE
*
*                 Default values
*
                  AFORM   = 'n'
                  ADIAGDO = 'n'
                  OFFDA   = 0
                  CFORM   = 'n'
                  OFFDC   = 0
*
               END IF
*
               CALL PZLAGEN( .FALSE., AFORM, ADIAGDO, OFFDA, MA, NA,
     $                       1, 1, DESCA, IASEED, MEM( IPA ),
     $                       DESCA( LLD_ ) )
.EQ..AND..NOT.               IF( ( L9 )( ( LSAME( DIAG, 'n.AND.' ) ) )
.GT.     $             ( MAX( NROWA, NCOLA )1 ) ) THEN
                  SCALE = ONE / DCMPLX( DBLE( MAX( NROWA, NCOLA ) ) )
                  IF( LSAME( UPLO, 'l' ) ) THEN
                     CALL PZLASCAL( 'lower', NROWA-1, NCOLA-1, SCALE,
     $                              MEM( IPA ), IA+1, JA, DESCA )
                  ELSE
                     CALL PZLASCAL( 'upper', NROWA-1, NCOLA-1, SCALE,
     $                              MEM( IPA ), IA, JA+1, DESCA )
                  END IF
*
               END IF
*
               IF( BCHECK( L ) )
     $            CALL PZLAGEN( .FALSE., 'none', 'no diag', 0, MB, NB,
     $                          1, 1, DESCB, IBSEED, MEM( IPB ),
     $                          DESCB( LLD_ ) )
*
               IF( CCHECK( L ) )
     $            CALL PZLAGEN( .FALSE., CFORM, 'no diag', OFFDC, MC,
     $                          NC, 1, 1, DESCC, ICSEED, MEM( IPC ),
     $                          DESCC( LLD_ ) )
*
               INFO = 0
               CALL PB_BOOT()
               CALL BLACS_BARRIER( ICTXT, 'all' )
*
*              Call the Level 3 PBLAS routine
*
.EQ.               IF( L1 ) THEN
*
*                 Test PZGEMM
*
                  NOPS = PDOPBL3( SNAMES( L ), M, N, K )
*
                  CALL PB_TIMER( 1 )
                  CALL PZGEMM( TRANSA, TRANSB, M, N, K, ALPHA,
     $                         MEM( IPA ), IA, JA, DESCA, MEM( IPB ),
     $                         IB, JB, DESCB, BETA, MEM( IPC ), IC, JC,
     $                         DESCC )
                  CALL PB_TIMER( 1 )
*
.EQ.               ELSE IF( L2 ) THEN
*
*                 Test PZSYMM
*
                  IF( LSAME( SIDE, 'l' ) ) THEN
                     NOPS = PDOPBL3( SNAMES( L ), M, N, 0 )
                  ELSE
                     NOPS = PDOPBL3( SNAMES( L ), M, N, 1 )
                  END IF
*
                  CALL PB_TIMER( 1 )
                  CALL PZSYMM( SIDE, UPLO, M, N, ALPHA, MEM( IPA ), IA,
     $                         JA, DESCA, MEM( IPB ), IB, JB, DESCB,
     $                         BETA, MEM( IPC ), IC, JC, DESCC )
                  CALL PB_TIMER( 1 )
*
.EQ.               ELSE IF( L3 ) THEN
*
*                 Test PZHEMM
*
                  IF( LSAME( SIDE, 'l' ) ) THEN
                     NOPS = PDOPBL3( SNAMES( L ), M, N, 0 )
                  ELSE
                     NOPS = PDOPBL3( SNAMES( L ), M, N, 1 )
                  END IF
*
                  CALL PB_TIMER( 1 )
                  CALL PZHEMM( SIDE, UPLO, M, N, ALPHA, MEM( IPA ), IA,
     $                         JA, DESCA, MEM( IPB ), IB, JB, DESCB,
     $                         BETA, MEM( IPC ), IC, JC, DESCC )
                  CALL PB_TIMER( 1 )
*
.EQ.               ELSE IF( L4 ) THEN
*
*                 Test PZSYRK
*
                  NOPS = PDOPBL3( SNAMES( L ), N, N, K )
*
                  CALL PB_TIMER( 1 )
                  CALL PZSYRK( UPLO, TRANSA, N, K, ALPHA, MEM( IPA ),
     $                         IA, JA, DESCA, BETA, MEM( IPC ), IC, JC,
     $                         DESCC )
                  CALL PB_TIMER( 1 )
*
.EQ.               ELSE IF( L5 ) THEN
*
*                 Test PZHERK
*
                  NOPS = PDOPBL3( SNAMES( L ), N, N, K )
*
                  CALL PB_TIMER( 1 )
                  CALL PZHERK( UPLO, TRANSA, N, K, DBLE( ALPHA ),
     $                         MEM( IPA ), IA, JA, DESCA, DBLE( BETA ),
     $                         MEM( IPC ), IC, JC, DESCC )
                  CALL PB_TIMER( 1 )
*
.EQ.               ELSE IF( L6 ) THEN
*
*                 Test PZSYR2K
*
                  NOPS = PDOPBL3( SNAMES( L ), N, N, K )
*
                  CALL PB_TIMER( 1 )
                  CALL PZSYR2K( UPLO, TRANSA, N, K, ALPHA, MEM( IPA ),
     $                          IA, JA, DESCA, MEM( IPB ), IB, JB,
     $                          DESCB, BETA, MEM( IPC ), IC, JC,
     $                          DESCC )
                  CALL PB_TIMER( 1 )
*
.EQ.               ELSE IF( L7 ) THEN
*
*                 Test PZHER2K
*
                  NOPS = PDOPBL3( SNAMES( L ), N, N, K )
*
                  CALL PB_TIMER( 1 )
                  CALL PZHER2K( UPLO, TRANSA, N, K, ALPHA, MEM( IPA ),
     $                          IA, JA, DESCA, MEM( IPB ), IB, JB,
     $                          DESCB, DBLE( BETA ), MEM( IPC ), IC, JC,
     $                          DESCC )
                  CALL PB_TIMER( 1 )
*
.EQ.               ELSE IF( L8 ) THEN
*
*                 Test PZTRMM
*
                  IF( LSAME( SIDE, 'l' ) ) THEN
                     NOPS = PDOPBL3( SNAMES( L ), M, N, 0 )
                  ELSE
                     NOPS = PDOPBL3( SNAMES( L ), M, N, 1 )
                  END IF
*
                  CALL PB_TIMER( 1 )
                  CALL PZTRMM( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA,
     $                         MEM( IPA ), IA, JA, DESCA, MEM( IPB ),
     $                         IB, JB, DESCB )
                  CALL PB_TIMER( 1 )
*
.EQ.               ELSE IF( L9 ) THEN
*
*                 Test PZTRSM
*
                  IF( LSAME( SIDE, 'l' ) ) THEN
                     NOPS = PDOPBL3( SNAMES( L ), M, N, 0 )
                  ELSE
                     NOPS = PDOPBL3( SNAMES( L ), M, N, 1 )
                  END IF
*
                  CALL PB_TIMER( 1 )
                  CALL PZTRSM( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA,
     $                         MEM( IPA ), IA, JA, DESCA, MEM( IPB ),
     $                         IB, JB, DESCB )
                  CALL PB_TIMER( 1 )
*
.EQ.               ELSE IF( L10 ) THEN
*
*                 Test PZGEADD
*
                  NOPS = PDOPBL3( SNAMES( L ), M, N, M )
*
                  CALL PB_TIMER( 1 )
                  CALL PZGEADD( TRANSA, M, N, ALPHA, MEM( IPA ), IA, JA,
     $                          DESCA, BETA, MEM( IPC ), IC, JC, DESCC )
                  CALL PB_TIMER( 1 )
*
.EQ.               ELSE IF( L11 ) THEN
*
*                 Test PZTRADD
*
                  IF( LSAME( UPLO, 'u' ) ) THEN
                     NOPS = PDOPBL3( SNAMES( L ), M, N, 0 )
                  ELSE
                     NOPS = PDOPBL3( SNAMES( L ), M, N, 1 )
                  END IF
*
                  CALL PB_TIMER( 1 )
                  CALL PZTRADD( UPLO, TRANSA, M, N, ALPHA, MEM( IPA ),
     $                          IA, JA, DESCA, BETA, MEM( IPC ), IC, JC,
     $                          DESCC )
                  CALL PB_TIMER( 1 )
*
               END IF
*
*              Check if the operation has been performed.
*
.NE.               IF( INFO0 ) THEN
.EQ.                  IF( IAM0 )
     $               WRITE( NOUT, FMT = 9982 ) INFO
                  GO TO 30
               END IF
*
               CALL PB_COMBINE( ICTXT, 'all', '>', 'w', 1, 1, WTIME )
               CALL PB_COMBINE( ICTXT, 'all', '>', 'c', 1, 1, CTIME )
*
*              Only node 0 prints timing test result
*
.EQ.               IF( IAM0 ) THEN
*
*                 Print WALL time if machine supports it
*
.GT.                  IF( WTIME( 1 )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
*
.GT.                  IF( CTIME( 1 )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
*
.EQ.   40       IF( IAM0 ) THEN
               WRITE( NOUT, FMT = 9995 )
               WRITE( NOUT, FMT = * )
               WRITE( NOUT, FMT = 9986 ) J
            END IF
*
   50   CONTINUE
*
        CALL BLACS_GRIDEXIT( ICTXT )
*
   60 CONTINUE
*
.EQ.      IF( IAM0 ) 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,7x,a1,7x,a1,5x,a1 )
 9992 FORMAT( 2x, '       IA     JA     MA     NA   IMBA   INBA',
     $        '    MBA    NBA RSRCA CSRCA' )
 9991 FORMAT( 5x,i6,1x,i6,1x,i6,1x,i6,1x,i6,1x,i6,1x,i6,1x,i6,
     $        1x,i5,1x,i5 )
 9990 FORMAT( 2x, '       IB     JB     MB     NB   IMBB   INBB',
     $        '    MBB    NBB RSRCB CSRCB' )
 9989 FORMAT( 2x, '       IC     JC     MC     NC   IMBC   INBC',
     $        '    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' )
*
      stop
*
*     End of PZBLA3TIM
*
      END
      SUBROUTINE pzbla3timinfo( SUMMRY, NOUT, NMAT, DIAGVAL, SIDEVAL,
     $                          TRNAVAL, TRNBVAL, UPLOVAL, MVAL,
     $                          NVAL, KVAL, MAVAL, NAVAL, IMBAVAL,
     $                          MBAVAL, INBAVAL, NBAVAL, RSCAVAL,
     $                          CSCAVAL, IAVAL, JAVAL, MBVAL, NBVAL,
     $                          IMBBVAL, MBBVAL, INBBVAL, NBBVAL,
     $                          RSCBVAL, CSCBVAL, IBVAL, JBVAL,
     $                          MCVAL, NCVAL, IMBCVAL, MBCVAL,
     $                          INBCVAL, NBCVAL, RSCCVAL, CSCCVAL,
     $                          ICVAL, JCVAL, LDVAL, NGRIDS, PVAL,
     $                          LDPVAL, QVAL, LDQVAL, NBLOG, LTEST,
     $                          IAM, NPROCS, ALPHA, BETA, WORK )
*
*  -- PBLAS test routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      INTEGER            IAM, LDPVAL, LDQVAL, LDVAL, NBLOG, NGRIDS,
     $                   NMAT, NOUT, NPROCS
      COMPLEX*16         ALPHA, BETA
*     ..
*     .. Array Arguments ..
      CHARACTER*( * )    SUMMRY
      CHARACTER*1        DIAGVAL( LDVAL ), SIDEVAL( LDVAL ),
     $                   TRNAVAL( LDVAL ), TRNBVAL( LDVAL ),
     $                   UPLOVAL( LDVAL )
      LOGICAL            LTEST( * )
      INTEGER            CSCAVAL( LDVAL ), CSCBVAL( LDVAL ),
     $                   csccval( ldval ), iaval( ldval ),
     $                   ibval( ldval ), icval( ldval ),
     $                   imbaval( ldval ), imbbval( ldval ),
     $                   imbcval( ldval ), inbaval( ldval ),
     $                   inbbval( ldval ), inbcval( ldval ),
     $                   javal( ldval ), jbval( ldval ), jcval( ldval ),
     $                   kval( ldval ), maval( ldval ), mbaval( ldval ),
     $                   mbbval( ldval ), mbcval( ldval ),
     $                   mbval( ldval ), mcval( ldval ), mval( ldval ),
     $                   naval( ldval ), nbaval( ldval ),
     $                   nbbval( ldval ), nbcval( ldval ),
     $                   nbval( ldval ), ncval( ldval ), nval( ldval ),
     $                   pval( ldpval ), qval( ldqval ),
     $                   rscaval( ldval ), rscbval( ldval ),
     $                   rsccval( ldval ), work( * )
*     ..
*
*  Purpose
*  =======
*
*  PZBLA3TIMINFO  get  the needed startup information for timing various
*  Level 3 PBLAS routines, and transmits it to all processes.
*
*  Notes
*  =====
*
*  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.
*
*  Arguments
*  =========
*
*  SUMMRY  (global output) CHARACTER*(*)
*          On  exit,  SUMMRY  is  the  name of output (summary) file (if
*          any). SUMMRY is only defined for process 0.
*
*  NOUT    (global output) INTEGER
*          On exit, NOUT  specifies the unit number for the output file.
*          When NOUT is 6, output to screen,  when  NOUT is 0, output to
*          stderr. NOUT is only defined for process 0.
*
*  NMAT    (global output) INTEGER
*          On exit,  NMAT  specifies the number of different test cases.
*
*  DIAGVAL (global output) CHARACTER array
*          On entry,  DIAGVAL  is  an array of dimension LDVAL. On exit,
*          this array contains the values of DIAG to run the code with.
*
*  SIDEVAL (global output) CHARACTER array
*          On entry,  SIDEVAL  is  an array of dimension LDVAL. On exit,
*          this array contains the values of SIDE to run the code with.
*
*  TRNAVAL (global output) CHARACTER array
*          On entry, TRNAVAL  is an array of dimension LDVAL.  On  exit,
*          this array contains  the  values  of  TRANSA  to run the code
*          with.
*
*  TRNBVAL (global output) CHARACTER array
*          On entry, TRNBVAL  is an array of dimension LDVAL.  On  exit,
*          this array contains  the  values  of  TRANSB  to run the code
*          with.
*
*  UPLOVAL (global output) CHARACTER array
*          On entry, UPLOVAL  is an array of dimension LDVAL.  On  exit,
*          this array contains the values of UPLO to run the code with.
*
*  MVAL    (global output) INTEGER array
*          On entry, MVAL is an array of dimension LDVAL.  On exit, this
*          array contains the values of M to run the code with.
*
*  NVAL    (global output) INTEGER array
*          On entry, NVAL is an array of dimension LDVAL.  On exit, this
*          array contains the values of N to run the code with.
*
*  KVAL    (global output) INTEGER array
*          On entry, KVAL is an array of dimension LDVAL.  On exit, this
*          array contains the values of K to run the code with.
*
*  MAVAL   (global output) INTEGER array
*          On entry, MAVAL is an array of dimension LDVAL. On exit, this
*          array  contains  the values  of  DESCA( M_ )  to run the code
*          with.
*
*  NAVAL   (global output) INTEGER array
*          On entry, NAVAL is an array of dimension LDVAL. On exit, this
*          array  contains  the values  of  DESCA( N_ )  to run the code
*          with.
*
*  IMBAVAL (global output) INTEGER array
*          On entry,  IMBAVAL  is an array of  dimension LDVAL. On exit,
*          this  array  contains  the values of DESCA( IMB_ ) to run the
*          code with.
*
*  MBAVAL  (global output) INTEGER array
*          On entry,  MBAVAL  is an array of  dimension  LDVAL. On exit,
*          this  array  contains  the values of DESCA( MB_ ) to  run the
*          code with.
*
*  INBAVAL (global output) INTEGER array
*          On entry,  INBAVAL  is an array of  dimension LDVAL. On exit,
*          this  array  contains  the values of DESCA( INB_ ) to run the
*          code with.
*
*  NBAVAL  (global output) INTEGER array
*          On entry,  NBAVAL  is an array of  dimension  LDVAL. On exit,
*          this  array  contains  the values of DESCA( NB_ ) to  run the
*          code with.
*
*  RSCAVAL (global output) INTEGER array
*          On entry, RSCAVAL  is an array of  dimension  LDVAL. On exit,
*          this  array  contains the values of DESCA( RSRC_ ) to run the
*          code with.
*
*  CSCAVAL (global output) INTEGER array
*          On entry, CSCAVAL  is an array of  dimension  LDVAL. On exit,
*          this  array  contains the values of DESCA( CSRC_ ) to run the
*          code with.
*
*  IAVAL   (global output) INTEGER array
*          On entry, IAVAL is an array of dimension LDVAL. On exit, this
*          array  contains the values of IA to run the code with.
*
*  JAVAL   (global output) INTEGER array
*          On entry, JAVAL is an array of dimension LDVAL. On exit, this
*          array  contains the values of JA to run the code with.
*
*  MBVAL   (global output) INTEGER array
*          On entry, MBVAL is an array of dimension LDVAL. On exit, this
*          array  contains  the values  of  DESCB( M_ )  to run the code
*          with.
*
*  NBVAL   (global output) INTEGER array
*          On entry, NBVAL is an array of dimension LDVAL. On exit, this
*          array  contains  the values  of  DESCB( N_ )  to run the code
*          with.
*
*  IMBBVAL (global output) INTEGER array
*          On entry,  IMBBVAL  is an array of  dimension LDVAL. On exit,
*          this  array  contains  the values of DESCB( IMB_ ) to run the
*          code with.
*
*  MBBVAL  (global output) INTEGER array
*          On entry,  MBBVAL  is an array of  dimension  LDVAL. On exit,
*          this  array  contains  the values of DESCB( MB_ ) to  run the
*          code with.
*
*  INBBVAL (global output) INTEGER array
*          On entry,  INBBVAL  is an array of  dimension LDVAL. On exit,
*          this  array  contains  the values of DESCB( INB_ ) to run the
*          code with.
*
*  NBBVAL  (global output) INTEGER array
*          On entry,  NBBVAL  is an array of  dimension  LDVAL. On exit,
*          this  array  contains  the values of DESCB( NB_ ) to  run the
*          code with.
*
*  RSCBVAL (global output) INTEGER array
*          On entry, RSCBVAL  is an array of  dimension  LDVAL. On exit,
*          this  array  contains the values of DESCB( RSRC_ ) to run the
*          code with.
*
*  CSCBVAL (global output) INTEGER array
*          On entry, CSCBVAL  is an array of  dimension  LDVAL. On exit,
*          this  array  contains the values of DESCB( CSRC_ ) to run the
*          code with.
*
*  IBVAL   (global output) INTEGER array
*          On entry, IBVAL is an array of dimension LDVAL. On exit, this
*          array  contains the values of IB to run the code with.
*
*  JBVAL   (global output) INTEGER array
*          On entry, JBVAL is an array of dimension LDVAL. On exit, this
*          array  contains the values of JB to run the code with.
*
*  MCVAL   (global output) INTEGER array
*          On entry, MCVAL is an array of dimension LDVAL. On exit, this
*          array  contains  the values  of  DESCC( M_ )  to run the code
*          with.
*
*  NCVAL   (global output) INTEGER array
*          On entry, NCVAL is an array of dimension LDVAL. On exit, this
*          array  contains  the values  of  DESCC( N_ )  to run the code
*          with.
*
*  IMBCVAL (global output) INTEGER array
*          On entry,  IMBCVAL  is an array of  dimension LDVAL. On exit,
*          this  array  contains  the values of DESCC( IMB_ ) to run the
*          code with.
*
*  MBCVAL  (global output) INTEGER array
*          On entry,  MBCVAL  is an array of  dimension  LDVAL. On exit,
*          this  array  contains  the values of DESCC( MB_ ) to  run the
*          code with.
*
*  INBCVAL (global output) INTEGER array
*          On entry,  INBCVAL  is an array of  dimension LDVAL. On exit,
*          this  array  contains  the values of DESCC( INB_ ) to run the
*          code with.
*
*  NBCVAL  (global output) INTEGER array
*          On entry,  NBCVAL  is an array of  dimension  LDVAL. On exit,
*          this  array  contains  the values of DESCC( NB_ ) to  run the
*          code with.
*
*  RSCCVAL (global output) INTEGER array
*          On entry, RSCCVAL  is an array of  dimension  LDVAL. On exit,
*          this  array  contains the values of DESCC( RSRC_ ) to run the
*          code with.
*
*  CSCCVAL (global output) INTEGER array
*          On entry, CSCCVAL  is an array of  dimension  LDVAL. On exit,
*          this  array  contains the values of DESCC( CSRC_ ) to run the
*          code with.
*
*  ICVAL   (global output) INTEGER array
*          On entry, ICVAL is an array of dimension LDVAL. On exit, this
*          array  contains the values of IC to run the code with.
*
*  JCVAL   (global output) INTEGER array
*          On entry, JCVAL is an array of dimension LDVAL. On exit, this
*          array  contains the values of JC to run the code with.
*
*  LDVAL   (global input) INTEGER
*          On entry, LDVAL specifies the maximum number of different va-
*          lues  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
*          On exit, NGRIDS specifies the number of different values that
*          can be used for P and Q.
*
*  PVAL    (global output) INTEGER array
*          On entry, PVAL is an array of dimension LDPVAL. On exit, this
*          array contains the values of P to run the code with.
*
*  LDPVAL  (global input) INTEGER
*          On entry,  LDPVAL  specifies  the maximum number of different
*          values that can be used for P.
*
*  QVAL    (global output) INTEGER array
*          On entry, QVAL is an array of dimension LDQVAL. On exit, this
*          array contains the values of Q to run the code with.
*
*  LDQVAL  (global input) INTEGER
*          On entry,  LDQVAL  specifies  the maximum number of different
*          values that can be used for Q.
*
*  NBLOG   (global output) INTEGER
*          On exit, NBLOG specifies the logical computational block size
*          to run the tests with. NBLOG must be at least one.
*
*  LTEST   (global output) LOGICAL array
*          On entry, LTEST  is an array of dimension at least eleven. On
*          exit, if LTEST( i ) is .TRUE., the i-th Level 3 PBLAS routine
*          will be tested.  See  the  input file for the ordering of the
*          routines.
*
*  IAM     (local input) INTEGER
*          On entry,  IAM  specifies the number of the process executing
*          this routine.
*
*  NPROCS  (global input) INTEGER
*          On entry, NPROCS specifies the total number of processes.
*
*  ALPHA   (global output) COMPLEX*16
*          On exit, ALPHA specifies the value of alpha to be used in all
*          the test cases.
*
*  BETA    (global output) COMPLEX*16
*          On exit, BETA  specifies the value of beta  to be used in all
*          the test cases.
*
*  WORK    (local workspace) INTEGER array
*          On   entry,   WORK   is   an  array  of  dimension  at  least
*          MAX( 3, 2*NGRIDS+38*NMAT+NSUBS ) with NSUBS = 11. This  array
*          is  used  to  pack all output arrays in order to send info in
*          one message.
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            NIN, NSUBS
      PARAMETER          ( NIN = 11, nsubs = 11 )
*     ..
*     .. Local Scalars ..
      LOGICAL            LTESTT
      INTEGER            I, ICTXT, J
*     ..
*     .. Local Arrays ..
      CHARACTER*7        SNAMET
      CHARACTER*79       USRINFO
*     ..
*     .. External Subroutines ..
      EXTERNAL           blacs_abort, blacs_get, blacs_gridexit,
     $                   blacs_gridinit, blacs_setup, icopy, igebr2d,
     $                   igebs2d, sgebr2d, sgebs2d, zgebr2d, zgebs2d
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          char, ichar, max, min
*     ..
*     .. Common Blocks ..
      CHARACTER*7        SNAMES( NSUBS )
      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='PZBLAS3TIM.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 logical computational block size
*
         READ( nin, fmt = * ) nblog
         IF( nblog.LT.1 )
     $      nblog = 32
*
*        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 = * ) ( trnaval( i ), i = 1, nmat )
         READ( nin, fmt = * ) ( trnbval( 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 = * ) ( imbaval( i ), i = 1, nmat )
         READ( nin, fmt = * ) ( inbaval( i ), i = 1, nmat )
         READ( nin, fmt = * ) ( mbaval( i ), i = 1, nmat )
         READ( nin, fmt = * ) ( nbaval( i ), i = 1, nmat )
         READ( nin, fmt = * ) ( rscaval( i ), i = 1, nmat )
         READ( nin, fmt = * ) ( cscaval( 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 = * ) ( imbbval( i ), i = 1, nmat )
         READ( nin, fmt = * ) ( inbbval( i ), i = 1, nmat )
         READ( nin, fmt = * ) ( mbbval( i ), i = 1, nmat )
         READ( nin, fmt = * ) ( nbbval( i ), i = 1, nmat )
         READ( nin, fmt = * ) ( rscbval( i ), i = 1, nmat )
         READ( nin, fmt = * ) ( cscbval( 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 = * ) ( imbcval( i ), i = 1, nmat )
         READ( nin, fmt = * ) ( inbcval( i ), i = 1, nmat )
         READ( nin, fmt = * ) ( mbcval( i ), i = 1, nmat )
         READ( nin, fmt = * ) ( nbcval( i ), i = 1, nmat )
         READ( nin, fmt = * ) ( rsccval( i ), i = 1, nmat )
         READ( nin, fmt = * ) ( csccval( 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 zgebs2d( ictxt, 'All', ' ', 1, 1, alpha, 1 )
         CALL zgebs2d( ictxt, 'All', ' ', 1, 1, beta,  1 )
*
         work( 1 ) = ngrids
         work( 2 ) = nmat
         work( 3 ) = nblog
         CALL igebs2d( ictxt, 'All', ' ', 3, 1, work, 3 )
*
         i = 1
         DO 70 j = 1, nmat
            work( i   ) = ichar( diagval( j ) )
            work( i+1 ) = ichar( sideval( j ) )
            work( i+2 ) = ichar( trnaval( j ) )
            work( i+3 ) = ichar( trnbval( 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,   imbaval,  1, work( i ), 1 )
         i = i + nmat
         CALL icopy( nmat,   inbaval,  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,   rscaval,  1, work( i ), 1 )
         i = i + nmat
         CALL icopy( nmat,   cscaval,  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,   imbbval,  1, work( i ), 1 )
         i = i + nmat
         CALL icopy( nmat,   inbbval,  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,   rscbval,  1, work( i ), 1 )
         i = i + nmat
         CALL icopy( nmat,   cscbval,  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,   imbcval,  1, work( i ), 1 )
         i = i + nmat
         CALL icopy( nmat,   inbcval,  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,   rsccval,  1, work( i ), 1 )
         i = i + nmat
         CALL icopy( nmat,   csccval,  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 )
     $               'Level 3 PBLAS timing program.'
         WRITE( nout, fmt = 9999 ) usrinfo
         WRITE( nout, fmt = * )
         WRITE( nout, fmt = 9999 )
     $               'Tests of the complex double precision '//
     $               'Level 3 PBLAS'
         WRITE( nout, fmt = * )
         WRITE( nout, fmt = 9992 ) nmat
         WRITE( nout, fmt = 9986 ) nblog
         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,
     $                                  min( 10, ngrids ) )
         IF( ngrids.GT.10 )
     $      WRITE( nout, fmt = 9990 ) ( pval(i), i = 11,
     $                                  min( 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,
     $                                  min( 10, ngrids ) )
         IF( ngrids.GT.10 )
     $      WRITE( nout, fmt = 9990 ) ( qval(i), i = 11,
     $                                  min( 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 zgebr2d( ictxt, 'All', ' ', 1, 1, alpha, 1, 0, 0 )
         CALL zgebr2d( ictxt, 'All', ' ', 1, 1, beta,  1, 0, 0 )
*
         CALL igebr2d( ictxt, 'All', ' ', 3, 1, work, 3, 0, 0 )
         ngrids = work( 1 )
         nmat   = work( 2 )
         nblog  = work( 3 )
*
         i = 2*ngrids + 38*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 ) )
            trnaval( j ) = char( work( i+2 ) )
            trnbval( 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, imbaval,  1 )
         i = i + nmat
         CALL icopy( nmat,   work( i ), 1, inbaval,  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, rscaval,  1 )
         i = i + nmat
         CALL icopy( nmat,   work( i ), 1, cscaval,  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, imbbval,  1 )
         i = i + nmat
         CALL icopy( nmat,   work( i ), 1, inbbval,  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, rscbval,  1 )
         i = i + nmat
         CALL icopy( nmat,   work( i ), 1, cscbval,  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, imbcval,  1 )
         i = i + nmat
         CALL icopy( nmat,   work( i ), 1, inbcval,  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, rsccval,  1 )
         i = i + nmat
         CALL icopy( nmat,   work( i ), 1, csccval,  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,
     $        ',', g16.6, ')' )
 9993 FORMAT( 2x, 'Beta                      :      (', g16.6,
     $        ',', 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 )
 9986 FORMAT( 2x, 'Logical block size        : ', I6 )
*
*     End of PZBLA3TIMINFO
*
      END