PROGRAM PSBLA1TST
*
*  -- PBLAS testing driver (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*  Purpose
*  =======
*
*  PSBLA1TST is the main testing program for the PBLAS Level 1 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 44 lines:
*  'Level 1 PBLAS, Testing input file'
*  'Intel iPSC/860 hypercube, gamma model.'
*  'PSBLAS1TST.SUMM'            output file name (if any)
*  6       device out
*  F       logical flag, T to stop on failures
*  F       logical flag, T to test error exits
*  0       verbosity, 0 for pass/fail, 1-3 for matrix dump on errors
*  10      the leading dimension gap
*  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
*  2                    number of tests problems
*  3  4                 values of N
*  6 10                 values of M_X
*  6 10                 values of N_X
*  2  5                 values of IMB_X
*  2  5                 values of INB_X
*  2  5                 values of MB_X
*  2  5                 values of NB_X
*  0  1                 values of RSRC_X
*  0  0                 values of CSRC_X
*  1  1                 values of IX
*  1  1                 values of JX
*  1  1                 values of INCX
*  6 10                 values of M_Y
*  6 10                 values of N_Y
*  2  5                 values of IMB_Y
*  2  5                 values of INB_Y
*  2  5                 values of MB_Y
*  2  5                 values of NB_Y
*  0  1                 values of RSRC_Y
*  0  0                 values of CSRC_Y
*  1  1                 values of IY
*  1  1                 values of JY
*  6  1                 values of INCY
*  PSSWAP  T            put F for no test in the same column
*  PSSCAL  T            put F for no test in the same column
*  PSCOPY  T            put F for no test in the same column
*  PSAXPY  T            put F for no test in the same column
*  PSDOT   T            put F for no test in the same column
*  PSNRM2  T            put F for no test in the same column
*  PSASUM  T            put F for no test in the same column
*  PSAMAX  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.
*
*  REALSZ  INTEGER
*          REALSZ  indicates  the  length in bytes on the given platform
*          for  a  single  precision  real. By default, REALSZ is set to
*          four.
*
*  MEM     REAL array
*          MEM is an array of dimension TOTMEM / REALSZ.
*          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, GAPMUL, REALSZ, TOTMEM,
     $                   MEMSIZ, NSUBS
      REAL               PADVAL, ZERO
      PARAMETER          ( MAXTESTS = 20, MAXGRIDS = 20, GAPMUL = 10,
     $                   REALSZ = 4, TOTMEM = 2000000,
     $                   MEMSIZ = TOTMEM / REALSZ, ZERO = 0.0E+0,
     $                   PADVAL = -9923.0E+0, NSUBS = 8 )
      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 ..
      LOGICAL            ERRFLG, SOF, TEE
      INTEGER            CSRCX, CSRCY, I, IAM, ICTXT, IGAP, IMBX, IMBY,
     $                   IMIDX, IMIDY, INBX, INBY, INCX, INCY, IPMATX,
     $                   IPMATY, IPOSTX, IPOSTY, IPREX, IPREY, IPW, IPX,
     $                   IPY, IVERB, IX, IXSEED, IY, IYSEED, J, JX, JY,
     $                   K, LDX, LDY, MBX, MBY, MEMREQD, MPX, MPY, MX,
     $                   MY, MYCOL, MYROW, N, NBX, NBY, NGRIDS, NOUT,
     $                   NPCOL, NPROCS, NPROW, NQX, NQY, NTESTS, NX, NY,
     $                   PISCLR, RSRCX, RSRCY, TSKIP, TSTCNT
      REAL               ALPHA, PSCLR, PUSCLR
*     ..
*     .. Local Arrays ..
      CHARACTER*80       OUTFILE
      LOGICAL            LTEST( NSUBS ), YCHECK( NSUBS )
      INTEGER            CSCXVAL( MAXTESTS ), CSCYVAL( MAXTESTS ),
     $                   DESCX( DLEN_ ), DESCXR( DLEN_ ),
     $                   DESCY( DLEN_ ), DESCYR( DLEN_ ), IERR( 4 ),
     $                   IMBXVAL( MAXTESTS ), IMBYVAL( MAXTESTS ),
     $                   INBXVAL( MAXTESTS ), INBYVAL( MAXTESTS ),
     $                   INCXVAL( MAXTESTS ), INCYVAL( MAXTESTS ),
     $                   IXVAL( MAXTESTS ), IYVAL( MAXTESTS ),
     $                   JXVAL( MAXTESTS ), JYVAL( MAXTESTS ),
     $                   KFAIL( NSUBS ), KPASS( NSUBS ), KSKIP( NSUBS ),
     $                   KTESTS( NSUBS ), MBXVAL( MAXTESTS ),
     $                   MBYVAL( MAXTESTS ), MXVAL( MAXTESTS ),
     $                   MYVAL( MAXTESTS ), NBXVAL( MAXTESTS ),
     $                   NBYVAL( MAXTESTS ), NVAL( MAXTESTS ),
     $                   NXVAL( MAXTESTS ), NYVAL( MAXTESTS ),
     $                   PVAL( MAXTESTS ), QVAL( MAXTESTS ),
     $                   RSCXVAL( MAXTESTS ), RSCYVAL( MAXTESTS )
      REAL               MEM( MEMSIZ )
*     ..
*     .. External Subroutines ..
      EXTERNAL           BLACS_EXIT, BLACS_GET, BLACS_GRIDEXIT,
     $                   BLACS_GRIDINFO, BLACS_GRIDINIT, BLACS_PINFO,
     $                   IGSUM2D, PB_DESCSET2, PB_PSLAPRNT, PB_SCHEKPAD,
     $                   PB_SFILLPAD, PSAMAX, PSASUM, PSAXPY,
     $                   PSBLA1TSTINFO, PSBLAS1TSTCHK, PSBLAS1TSTCHKE,
     $                   PSCHKARG1, PSCHKVOUT, PSCOPY, PSDOT, PSLAGEN,
     $                   PSMPRNT, PSNRM2, PSSCAL, PSSWAP, PSVPRNT,
     $                   PVDESCCHK, PVDIMCHK
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MOD
*     ..
*     .. 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               SNAMES/'PSSWAP ', 'PSSCAL ', 'PSCOPY ',
     $                   'PSAXPY ', 'PSDOT  ', 'PSNRM2 ',
     $                   'PSASUM ', 'PSAMAX '/
      DATA               YCHECK/.TRUE., .FALSE., .TRUE., .TRUE., .TRUE.,
     $                   .FALSE., .FALSE., .FALSE./
*     ..
*     .. Executable Statements ..
*
*     Initialization
*
*     Set flag so that the PBLAS error handler will abort on errors.
*
      ABRTFLG = .FALSE.
*
*     So far no error, will become true as soon as one error is found.
*
      ERRFLG = .FALSE.
*
*     Test counters
*
      TSKIP  = 0
      TSTCNT = 0
*
*     Seeds for random matrix generations.
*
      IXSEED = 100
      IYSEED = 200
*
*     So far no tests have been performed.
*
      DO 10 I = 1, NSUBS
         KPASS( I )  = 0
         KSKIP( I )  = 0
         KFAIL( I )  = 0
         KTESTS( I ) = 0
   10 CONTINUE
*
*     Get starting information
*
      CALL BLACS_PINFO( IAM, NPROCS )
      CALL PSBLA1TSTINFO( OUTFILE, NOUT, NTESTS, NVAL, MXVAL, NXVAL,
     $                    IMBXVAL, MBXVAL, INBXVAL, NBXVAL, RSCXVAL,
     $                    CSCXVAL, IXVAL, JXVAL, INCXVAL, MYVAL,
     $                    NYVAL, IMBYVAL, MBYVAL, INBYVAL, NBYVAL,
     $                    RSCYVAL, CSCYVAL, IYVAL, JYVAL, INCYVAL,
     $                    MAXTESTS, NGRIDS, PVAL, MAXGRIDS, QVAL,
     $                    MAXGRIDS, LTEST, SOF, TEE, IAM, IGAP, IVERB,
     $                    NPROCS, ALPHA, MEM )
*
      IF( IAM.EQ.0 ) THEN
         WRITE( NOUT, FMT = 9979 )
         WRITE( NOUT, FMT = * )
      END IF
*
*     If TEE is set then Test Error Exits of routines.
*
      IF( TEE )
     $   CALL PSBLAS1TSTCHKE( LTEST, NOUT, NPROCS )
*
*     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'
            TSKIP = TSKIP + 1
            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
*
            N     = NVAL( J )
            MX    = MXVAL( J )
            NX    = NXVAL( J )
            IMBX  = IMBXVAL( J )
            MBX   = MBXVAL( J )
            INBX  = INBXVAL( J )
            NBX   = NBXVAL( J )
            RSRCX = RSCXVAL( J )
            CSRCX = CSCXVAL( J )
            IX    = IXVAL( J )
            JX    = JXVAL( J )
            INCX  = INCXVAL( J )
            MY    = MYVAL( J )
            NY    = NYVAL( J )
            IMBY  = IMBYVAL( J )
            MBY   = MBYVAL( J )
            INBY  = INBYVAL( J )
            NBY   = NBYVAL( J )
            RSRCY = RSCYVAL( J )
            CSRCY = CSCYVAL( J )
            IY    = IYVAL( J )
            JY    = JYVAL( J )
            INCY  = INCYVAL( J )
*
            IF( IAM.EQ.0 ) THEN
               TSTCNT = TSTCNT + 1
               WRITE( NOUT, FMT = * )
               WRITE( NOUT, FMT = 9996 ) TSTCNT, NPROW, NPCOL
               WRITE( NOUT, FMT = * )
*
               WRITE( NOUT, FMT = 9995 )
               WRITE( NOUT, FMT = 9994 )
               WRITE( NOUT, FMT = 9995 )
               WRITE( NOUT, FMT = 9993 ) N, IX, JX, MX, NX, IMBX, INBX,
     $                                   MBX, NBX, RSRCX, CSRCX, INCX
*
               WRITE( NOUT, FMT = 9995 )
               WRITE( NOUT, FMT = 9992 )
               WRITE( NOUT, FMT = 9995 )
               WRITE( NOUT, FMT = 9993 ) N, IY, JY, MY, NY, IMBY, INBY,
     $                                   MBY, NBY, RSRCY, CSRCY, INCY
               WRITE( NOUT, FMT = 9995 )
            END IF
*
*           Check the validity of the input and initialize DESC_
*
            CALL PVDESCCHK( ICTXT, NOUT, 'X', DESCX,
     $                      BLOCK_CYCLIC_2D_INB, MX, NX, IMBX, INBX,
     $                      MBX, NBX, RSRCX, CSRCX, INCX, MPX, NQX,
     $                      IPREX, IMIDX, IPOSTX, IGAP, GAPMUL,
     $                      IERR( 1 ) )
            CALL PVDESCCHK( ICTXT, NOUT, 'Y', DESCY,
     $                      BLOCK_CYCLIC_2D_INB, MY, NY, IMBY, INBY,
     $                      MBY, NBY, RSRCY, CSRCY, INCY, MPY, NQY,
     $                      IPREY, IMIDY, IPOSTY, IGAP, GAPMUL,
     $                      IERR( 2 ) )
*
            IF( IERR( 1 ).GT.0 .OR. IERR( 2 ).GT.0 ) THEN
               TSKIP = TSKIP + 1
               GO TO 40
            END IF
*
            LDX = MAX( 1, MX )
            LDY = MAX( 1, MY )
*
*           Assign pointers into MEM for matrices corresponding to
*           vectors X and Y. Ex: IPX starts at position MEM( IPREX+1 ).
*
            IPX    = IPREX + 1
            IPY    = IPX + DESCX( LLD_ ) * NQX + IPOSTX + IPREY
            IPMATX = IPY + DESCY( LLD_ ) * NQY + IPOSTY
            IPMATY = IPMATX + MX * NX
            IPW    = IPMATY + MY * NY
*
*           Check if sufficient memory.
*           Requirement = mem for local part of parallel matrices +
*                         mem for whole matrices for comp. check +
*                         mem for recving comp. check error vals.
*
            MEMREQD = IPW - 1 +
     $                MAX( MAX( IMBX, MBX ), MAX( IMBY, MBY ) )
            IERR( 1 ) = 0
            IF( MEMREQD.GT.MEMSIZ ) THEN
               IF( IAM.EQ.0 )
     $            WRITE( NOUT, FMT = 9990 ) 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 = 9991 )
               TSKIP = TSKIP + 1
               GO TO 40
            END IF
*
*           Loop over all PBLAS 1 routines
*
            DO 30 K = 1, NSUBS
*
*              Continue only if this sub has to be tested.
*
               IF( .NOT.LTEST( K ) )
     $            GO TO 30
*
               IF( IAM.EQ.0 ) THEN
                  WRITE( NOUT, FMT = * )
                  WRITE( NOUT, FMT = 9989 ) SNAMES( K )
               END IF
*
*              Check the validity of the operand sizes
*
               CALL PVDIMCHK( ICTXT, NOUT, N, 'X', IX, JX, DESCX, INCX,
     $                        IERR( 1 ) )
               CALL PVDIMCHK( ICTXT, NOUT, N, 'Y', IY, JY, DESCY, INCY,
     $                        IERR( 2 ) )
*
               IF( IERR( 1 ).NE.0 .OR. IERR( 2 ).NE.0 ) THEN
                  KSKIP( K ) = KSKIP( K ) + 1
                  GO TO 30
               END IF
*
*              Generate distributed matrices X and Y
*
               CALL PSLAGEN( .FALSE., 'None', 'No diag', 0, MX, NX, 1,
     $                       1, DESCX, IXSEED, MEM( IPX ),
     $                       DESCX( LLD_ ) )
               IF( YCHECK( K ) )
     $            CALL PSLAGEN( .FALSE., 'None', 'No diag', 0, MY, NY,
     $                          1, 1, DESCY, IYSEED, MEM( IPY ),
     $                          DESCY( LLD_ ) )
*
*              Generate entire matrices on each process.
*
               CALL PB_DESCSET2( DESCXR, MX, NX, IMBX, INBX, MBX, NBX,
     $                           -1, -1, ICTXT, MAX( 1, MX ) )
               CALL PSLAGEN( .FALSE., 'None', 'No diag', 0, MX, NX, 1,
     $                       1, DESCXR, IXSEED, MEM( IPMATX ),
     $                       DESCXR( LLD_ ) )
               IF( YCHECK( K ) ) THEN
                  CALL PB_DESCSET2( DESCYR, MY, NY, IMBY, INBY, MBY,
     $                              NBY, -1, -1, ICTXT, MAX( 1, MY ) )
                  CALL PSLAGEN( .FALSE., 'None', 'No diag', 0, MY, NY,
     $                          1, 1, DESCYR, IYSEED, MEM( IPMATY ),
     $                          DESCYR( LLD_ ) )
               END IF
*
*              Pad the guard zones of X, and Y
*
               CALL PB_SFILLPAD( ICTXT, MPX, NQX, MEM( IPX-IPREX ),
     $                           DESCX( LLD_ ), IPREX, IPOSTX, PADVAL )
*
               IF( YCHECK( K ) ) THEN
                  CALL PB_SFILLPAD( ICTXT, MPY, NQY, MEM( IPY-IPREY ),
     $                              DESCY( LLD_ ), IPREY, IPOSTY,
     $                              PADVAL )
               END IF
*
*              Initialize the check for INPUT only args.
*
               INFO = 0
               CALL PSCHKARG1( ICTXT, NOUT, SNAMES( K ), N, ALPHA, IX,
     $                         JX, DESCX, INCX, IY, JY, DESCY, INCY,
     $                         INFO )
*
               INFO = 0
               PSCLR  = ZERO
               PUSCLR = ZERO
               PISCLR = 0
*
*              Print initial parallel data if IVERB >= 2.
*
               IF( IVERB.EQ.2 ) THEN
                  IF( INCX.EQ.DESCX( M_ ) ) THEN
                     CALL PB_PSLAPRNT( 1, N, MEM( IPX ), IX, JX, DESCX,
     $                                 0, 0, 'PARALLEL_INITIAL_X', NOUT,
     $                                 MEM( IPW ) )
                  ELSE
                     CALL PB_PSLAPRNT( N, 1, MEM( IPX ), IX, JX, DESCX,
     $                                 0, 0, 'PARALLEL_INITIAL_X', NOUT,
     $                                 MEM( IPW ) )
                  END IF
                  IF( YCHECK( K ) ) THEN
                     IF( INCY.EQ.DESCY( M_ ) ) THEN
                        CALL PB_PSLAPRNT( 1, N, MEM( IPY ), IY, JY,
     $                                    DESCY, 0, 0,
     $                                    'PARALLEL_INITIAL_Y', NOUT,
     $                                    MEM( IPW ) )
                     ELSE
                        CALL PB_PSLAPRNT( N, 1, MEM( IPY ), IY, JY,
     $                                    DESCY, 0, 0,
     $                                    'PARALLEL_INITIAL_Y', NOUT,
     $                                    MEM( IPW ) )
                     END IF
                  END IF
               ELSE IF( IVERB.GE.3 ) THEN
                  CALL PB_PSLAPRNT( MX, NX, MEM( IPX ), 1, 1, DESCX, 0,
     $                              0, 'PARALLEL_INITIAL_X', NOUT,
     $                              MEM( IPW ) )
                  IF( YCHECK( K ) )
     $               CALL PB_PSLAPRNT( MY, NY, MEM( IPY ), 1, 1, DESCY,
     $                                 0, 0, 'PARALLEL_INITIAL_Y', NOUT,
     $                                 MEM( IPW ) )
               END IF
*
*              Call the PBLAS routine
*
               IF( K.EQ.1 ) THEN
*
*                 Test PSSWAP
*
                  CALL PSSWAP( N, MEM( IPX ), IX, JX, DESCX, INCX,
     $                         MEM( IPY ), IY, JY, DESCY, INCY )
*
               ELSE IF( K.EQ.2 ) THEN
*
*                 Test PSSCAL
*
                  PSCLR = ALPHA
                  CALL PSSCAL( N, ALPHA, MEM( IPX ), IX, JX, DESCX,
     $                         INCX )
*
               ELSE IF( K.EQ.3 ) THEN
*
*                 Test PSCOPY
*
                  CALL PSCOPY( N, MEM( IPX ), IX, JX, DESCX, INCX,
     $                         MEM( IPY ), IY, JY, DESCY, INCY )
*
               ELSE IF( K.EQ.4 ) THEN
*
*                 Test PSAXPY
*
                  PSCLR = ALPHA
                  CALL PSAXPY( N, ALPHA, MEM( IPX ), IX, JX, DESCX,
     $                         INCX, MEM( IPY ), IY, JY, DESCY, INCY )
*
               ELSE IF( K.EQ.5 ) THEN
*
*                 Test PSDOT
*
                  CALL PSDOT( N, PSCLR, MEM( IPX ), IX, JX, DESCX, INCX,
     $                        MEM( IPY ), IY, JY, DESCY, INCY )
*
               ELSE IF( K.EQ.6 ) THEN
*
*                 Test PSNRM2
*
                  CALL PSNRM2( N, PUSCLR, MEM( IPX ), IX, JX, DESCX,
     $                         INCX )
*
               ELSE IF( K.EQ.7 ) THEN
*
*                 Test PSASUM
*
                  CALL PSASUM( N, PUSCLR, MEM( IPX ), IX, JX, DESCX,
     $                         INCX )
*
               ELSE IF( K.EQ.8 ) THEN
*
                  CALL PSAMAX( N, PSCLR, PISCLR, MEM( IPX ), IX, JX,
     $                         DESCX, INCX )
*
               END IF
*
*              Check if the operation has been performed.
*
               IF( INFO.NE.0 ) THEN
                  KSKIP( K ) = KSKIP( K ) + 1
                  IF( IAM.EQ.0 )
     $               WRITE( NOUT, FMT = 9978 ) INFO
                  GO TO 30
               END IF
*
*              Check the computations
*
               CALL PSBLAS1TSTCHK( ICTXT, NOUT, K, N, PSCLR, PUSCLR,
     $                             PISCLR, MEM( IPMATX ), MEM( IPX ),
     $                             IX, JX, DESCX, INCX, MEM( IPMATY ),
     $                             MEM( IPY ), IY, JY, DESCY, INCY,
     $                             INFO )
               IF( MOD( INFO, 2 ).EQ.1 ) THEN
                  IERR( 1 ) = 1
               ELSE IF( MOD( INFO / 2, 2 ).EQ.1 ) THEN
                  IERR( 2 ) = 1
               ELSE IF( INFO.NE.0 ) THEN
                  IERR( 1 ) = 1
                  IERR( 2 ) = 1
               END IF
*
*              Check padding
*
               CALL PB_SCHEKPAD( ICTXT, SNAMES( K ), MPX, NQX,
     $                           MEM( IPX-IPREX ), DESCX( LLD_ ),
     $                           IPREX, IPOSTX, PADVAL )
               IF( YCHECK( K ) ) THEN
                  CALL PB_SCHEKPAD( ICTXT, SNAMES( K ), MPY, NQY,
     $                              MEM( IPY-IPREY ), DESCY( LLD_ ),
     $                              IPREY, IPOSTY, PADVAL )
               END IF
*
*              Check input-only scalar arguments
*
               INFO = 1
               CALL PSCHKARG1( ICTXT, NOUT, SNAMES( K ), N, ALPHA, IX,
     $                         JX, DESCX, INCX, IY, JY, DESCY, INCY,
     $                         INFO )
*
*              Check input-only array arguments
*
               CALL PSCHKVOUT( N, MEM( IPMATX ), MEM( IPX ), IX, JX,
     $                         DESCX, INCX, IERR( 3 ) )
*
               IF( IERR( 3 ).NE.0 ) THEN
                  IF( IAM.EQ.0 )
     $               WRITE( NOUT, FMT = 9986 ) 'PARALLEL_X', SNAMES( K )
               END IF
*
               IF( YCHECK( K ) ) THEN
                  CALL PSCHKVOUT( N, MEM( IPMATY ), MEM( IPY ), IY, JY,
     $                            DESCY, INCY, IERR( 4 ) )
                  IF( IERR( 4 ).NE.0 ) THEN
                     IF( IAM.EQ.0 )
     $                  WRITE( NOUT, FMT = 9986 ) 'PARALLEL_Y',
     $                                       SNAMES( K )
                  END IF
               END IF
*
*              Only node 0 prints computational test result
*
               IF( INFO.NE.0 .OR. IERR( 1 ).NE.0 .OR.
     $             IERR( 2 ).NE.0 .OR. IERR( 3 ).NE.0 .OR.
     $             IERR( 4 ).NE. 0 ) THEN
                  IF( IAM.EQ.0 )
     $               WRITE( NOUT, FMT = 9988 ) SNAMES( K )
                  KFAIL( K ) = KFAIL( K ) + 1
                  ERRFLG = .TRUE.
               ELSE
                  IF( IAM.EQ.0 )
     $               WRITE( NOUT, FMT = 9987 ) SNAMES( K )
                  KPASS( K ) = KPASS( K ) + 1
               END IF
*
*              Dump matrix if IVERB >= 1 and error.
*
               IF( IVERB.GE.1 .AND. ERRFLG ) THEN
                  IF( IERR( 3 ).NE.0 .OR. IVERB.GE.3 ) THEN
                     CALL PSMPRNT( ICTXT, NOUT, MX, NX, MEM( IPMATX ),
     $                             LDX, 0, 0, 'SERIAL_X' )
                     CALL PB_PSLAPRNT( MX, NX, MEM( IPX ), 1, 1, DESCX,
     $                                 0, 0, 'PARALLEL_X', NOUT,
     $                                 MEM( IPMATX ) )
                  ELSE IF( IERR( 1 ).NE.0 ) THEN
                     IF( N.GT.0 )
     $                  CALL PSVPRNT( ICTXT, NOUT, N,
     $                                MEM( IPMATX+IX-1+(JX-1)*LDX ),
     $                                INCX, 0, 0, 'SERIAL_X' )
                     IF( INCX.EQ.DESCX( M_ ) ) THEN
                        CALL PB_PSLAPRNT( 1, N, MEM( IPX ), IX, JX,
     $                                    DESCX, 0, 0, 'PARALLEL_X',
     $                                    NOUT, MEM( IPMATX ) )
                     ELSE
                        CALL PB_PSLAPRNT( N, 1, MEM( IPX ), IX, JX,
     $                                    DESCX, 0, 0, 'PARALLEL_X',
     $                                    NOUT, MEM( IPMATX ) )
                     END IF
                  END IF
                  IF( YCHECK( K ) ) THEN
                     IF( IERR( 4 ).NE.0 .OR. IVERB.GE.3 ) THEN
                        CALL PSMPRNT( ICTXT, NOUT, MY, NY,
     $                                MEM( IPMATY ), LDY, 0, 0,
     $                                'SERIAL_Y' )
                        CALL PB_PSLAPRNT( MY, NY, MEM( IPY ), 1, 1,
     $                                    DESCY, 0, 0, 'PARALLEL_Y',
     $                                    NOUT, MEM( IPMATX ) )
                     ELSE IF( IERR( 2 ).NE.0 ) THEN
                        IF( N.GT.0 )
     $                     CALL PSVPRNT( ICTXT, NOUT, N,
     $                                   MEM( IPMATY+IY-1+(JY-1)*LDY ),
     $                                   INCY, 0, 0, 'SERIAL_Y' )
                        IF( INCY.EQ.DESCY( M_ ) ) THEN
                           CALL PB_PSLAPRNT( 1, N, MEM( IPY ), IY, JY,
     $                                       DESCY, 0, 0, 'PARALLEL_Y',
     $                                       NOUT, MEM( IPMATX ) )
                        ELSE
                           CALL PB_PSLAPRNT( N, 1, MEM( IPY ), IY, JY,
     $                                       DESCY, 0, 0, 'PARALLEL_Y',
     $                                       NOUT, MEM( IPMATX ) )
                        END IF
                     END IF
                  END IF
               END IF
*
*              Leave if error and "Stop On Failure"
*
               IF( SOF.AND.ERRFLG )
     $            GO TO 70
*
   30       CONTINUE
*
   40       IF( IAM.EQ.0 ) THEN
               WRITE( NOUT, FMT = * )
               WRITE( NOUT, FMT = 9985 ) J
            END IF
*
   50   CONTINUE
*
        CALL BLACS_GRIDEXIT( ICTXT )
*
   60 CONTINUE
*
*     Come here, if error and "Stop On Failure"
*
   70 CONTINUE
*
*     Before printing out final stats, add TSKIP to all skips
*
      DO 80 I = 1, NSUBS
         IF( LTEST( I ) ) THEN
            KSKIP( I ) = KSKIP( I ) + TSKIP
            KTESTS( I ) = KSKIP( I ) + KFAIL( I ) + KPASS( I )
         END IF
   80 CONTINUE
*
*     Print results
*
      IF( IAM.EQ.0 ) THEN
         WRITE( NOUT, FMT = * )
         WRITE( NOUT, FMT = 9981 )
         WRITE( NOUT, FMT = * )
         WRITE( NOUT, FMT = 9983 )
         WRITE( NOUT, FMT = 9982 )
*
         DO 90 I = 1, NSUBS
            WRITE( NOUT, FMT = 9984 ) '|', SNAMES( I ), KTESTS( I ),
     $                                KPASS( I ), KFAIL( I ), KSKIP( I )
   90    CONTINUE
         WRITE( NOUT, FMT = * )
         WRITE( NOUT, FMT = 9980 )
         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 ', I4 , ' started on a ', I6, ' x ',
     $        I6, ' process grid.' )
 9995 FORMAT( 2X, '---------------------------------------------------',
     $        '--------------------------' )
 9994 FORMAT( 2X, '     N     IX     JX     MX     NX  IMBX  INBX',
     $        '   MBX   NBX RSRCX CSRCX   INCX' )
 9993 FORMAT( 2X,I6,1X,I6,1X,I6,1X,I6,1X,I6,1X,I5,1X,I5,1X,I5,1X,I5,1X,
     $        I5,1X,I5,1X,I6 )
 9992 FORMAT( 2X, '     N     IY     JY     MY     NY  IMBY  INBY',
     $        '   MBY   NBY RSRCY CSRCY   INCY' )
 9991 FORMAT( 'Not enough memory for this test: going on to',
     $        ' next test case.' )
 9990 FORMAT( 'Not enough memory. Need: ', I12 )
 9989 FORMAT( 2X, '   Tested Subroutine: ', A )
 9988 FORMAT( 2X, '   ***** Computational check: ', A, '       ',
     $        ' FAILED ',' *****' )
 9987 FORMAT( 2X, '   ***** Computational check: ', A, '       ',
     $        ' PASSED ',' *****' )
 9986 FORMAT( 2X, '   ***** ERROR ***** Matrix operand ', A,
     $        ' modified by ', A, ' *****' )
 9985 FORMAT( 2X, 'Test number ', I4, ' completed.' )
 9984 FORMAT( 2X,A1,2X,A7,8X,I4,6X,I4,5X,I4,4X,I4 )
 9983 FORMAT( 2X, '   SUBROUTINE  TOTAL TESTS  PASSED   FAILED  ',
     $        'SKIPPED' )
 9982 FORMAT( 2X, '   ----------  -----------  ------   ------  ',
     $        '-------' )
 9981 FORMAT( 2X, 'Testing Summary')
 9980 FORMAT( 2X, 'End of Tests.' )
 9979 FORMAT( 2X, 'Tests started.' )
 9978 FORMAT( 2X, '   ***** Operation not supported, error code: ',
     $        I5, ' *****' )
*
      STOP
*
*     End of PSBLA1TST
*
      END
      SUBROUTINE PSBLA1TSTINFO( SUMMRY, NOUT, NMAT, NVAL, MXVAL,
     $                          NXVAL, IMBXVAL, MBXVAL, INBXVAL,
     $                          NBXVAL, RSCXVAL, CSCXVAL, IXVAL,
     $                          JXVAL, INCXVAL, MYVAL, NYVAL, IMBYVAL,
     $                          MBYVAL, INBYVAL, NBYVAL, RSCYVAL,
     $                          CSCYVAL, IYVAL, JYVAL, INCYVAL,
     $                          LDVAL, NGRIDS, PVAL, LDPVAL, QVAL,
     $                          LDQVAL, LTEST, SOF, TEE, IAM, IGAP,
     $                          IVERB, NPROCS, ALPHA, 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 ..
      LOGICAL            SOF, TEE
      INTEGER            IAM, IGAP, IVERB, LDPVAL, LDQVAL, LDVAL,
     $                   NGRIDS, NMAT, NOUT, NPROCS
      REAL               ALPHA
*     ..
*     .. Array Arguments ..
      CHARACTER*( * )    SUMMRY
      LOGICAL            LTEST( * )
      INTEGER            CSCXVAL( LDVAL ), CSCYVAL( LDVAL ),
     $                   IMBXVAL( LDVAL ), IMBYVAL( LDVAL ),
     $                   INBXVAL( LDVAL ), INBYVAL( LDVAL ),
     $                   INCXVAL( LDVAL ), INCYVAL( LDVAL ),
     $                   IXVAL( LDVAL ), IYVAL( LDVAL ), JXVAL( LDVAL ),
     $                   JYVAL( LDVAL ), MBXVAL( LDVAL ),
     $                   MBYVAL( LDVAL ), MXVAL( LDVAL ),
     $                   MYVAL( LDVAL ), NBXVAL( LDVAL ),
     $                   NBYVAL( LDVAL ), NVAL( LDVAL ), NXVAL( LDVAL ),
     $                   NYVAL( LDVAL ), PVAL( LDPVAL ), QVAL( LDQVAL ),
     $                   RSCXVAL( LDVAL ), RSCYVAL( LDVAL ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  PSBLA1TSTINFO  get the needed startup information for testing various
*  Level 1 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.
*
*  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.
*
*  MXVAL   (global output) INTEGER array
*          On entry, MXVAL is an array of dimension LDVAL. On exit, this
*          array  contains  the values  of  DESCX( M_ )  to run the code
*          with.
*
*  NXVAL   (global output) INTEGER array
*          On entry, NXVAL is an array of dimension LDVAL. On exit, this
*          array  contains  the values  of  DESCX( N_ )  to run the code
*          with.
*
*  IMBXVAL (global output) INTEGER array
*          On entry,  IMBXVAL  is an array of  dimension LDVAL. On exit,
*          this  array  contains  the values of DESCX( IMB_ ) to run the
*          code with.
*
*  MBXVAL  (global output) INTEGER array
*          On entry,  MBXVAL  is an array of  dimension  LDVAL. On exit,
*          this  array  contains  the values of DESCX( MB_ ) to  run the
*          code with.
*
*  INBXVAL (global output) INTEGER array
*          On entry,  INBXVAL  is an array of  dimension LDVAL. On exit,
*          this  array  contains  the values of DESCX( INB_ ) to run the
*          code with.
*
*  NBXVAL  (global output) INTEGER array
*          On entry,  NBXVAL  is an array of  dimension  LDVAL. On exit,
*          this  array  contains  the values of DESCX( NB_ ) to  run the
*          code with.
*
*  RSCXVAL (global output) INTEGER array
*          On entry, RSCXVAL  is an array of  dimension  LDVAL. On exit,
*          this  array  contains the values of DESCX( RSRC_ ) to run the
*          code with.
*
*  CSCXVAL (global output) INTEGER array
*          On entry, CSCXVAL  is an array of  dimension  LDVAL. On exit,
*          this  array  contains the values of DESCX( CSRC_ ) to run the
*          code with.
*
*  IXVAL   (global output) INTEGER array
*          On entry, IXVAL is an array of dimension LDVAL. On exit, this
*          array  contains the values of IX to run the code with.
*
*  JXVAL   (global output) INTEGER array
*          On entry, JXVAL is an array of dimension LDVAL. On exit, this
*          array  contains the values of JX to run the code with.
*
*  INCXVAL (global output) INTEGER array
*          On entry,  INCXVAL  is  an array of dimension LDVAL. On exit,
*          this array  contains the values of INCX to run the code with.
*
*  MYVAL   (global output) INTEGER array
*          On entry, MYVAL is an array of dimension LDVAL. On exit, this
*          array  contains  the values  of  DESCY( M_ )  to run the code
*          with.
*
*  NYVAL   (global output) INTEGER array
*          On entry, NYVAL is an array of dimension LDVAL. On exit, this
*          array  contains  the values  of  DESCY( N_ )  to run the code
*          with.
*
*  IMBYVAL (global output) INTEGER array
*          On entry,  IMBYVAL  is an array of  dimension LDVAL. On exit,
*          this  array  contains  the values of DESCY( IMB_ ) to run the
*          code with.
*
*  MBYVAL  (global output) INTEGER array
*          On entry,  MBYVAL  is an array of  dimension  LDVAL. On exit,
*          this  array  contains  the values of DESCY( MB_ ) to  run the
*          code with.
*
*  INBYVAL (global output) INTEGER array
*          On entry,  INBYVAL  is an array of  dimension LDVAL. On exit,
*          this  array  contains  the values of DESCY( INB_ ) to run the
*          code with.
*
*  NBYVAL  (global output) INTEGER array
*          On entry,  NBYVAL  is an array of  dimension  LDVAL. On exit,
*          this  array  contains  the values of DESCY( NB_ ) to  run the
*          code with.
*
*  RSCYVAL (global output) INTEGER array
*          On entry, RSCYVAL  is an array of  dimension  LDVAL. On exit,
*          this  array  contains the values of DESCY( RSRC_ ) to run the
*          code with.
*
*  CSCYVAL (global output) INTEGER array
*          On entry, CSCYVAL  is an array of  dimension  LDVAL. On exit,
*          this  array  contains the values of DESCY( CSRC_ ) to run the
*          code with.
*
*  IYVAL   (global output) INTEGER array
*          On entry, IYVAL is an array of dimension LDVAL. On exit, this
*          array  contains the values of IY to run the code with.
*
*  JYVAL   (global output) INTEGER array
*          On entry, JYVAL is an array of dimension LDVAL. On exit, this
*          array  contains the values of JY to run the code with.
*
*  INCYVAL (global output) INTEGER array
*          On entry,  INCYVAL  is  an array of dimension LDVAL. On exit,
*          this array  contains the values of INCY 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  DESCX(:),  IX, JX, INCX, DESCY(:),
*          IY,  JY  and  INCY.  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.
*
*  LTEST   (global output) LOGICAL array
*          On entry,  LTEST  is an array of dimension at least eight. On
*          exit, if LTEST( i ) is .TRUE., the i-th Level 1 PBLAS routine
*          will be tested.  See  the  input file for the ordering of the
*          routines.
*
*  SOF     (global output) LOGICAL
*          On exit, if SOF is .TRUE., the tester will  stop on the first
*          detected failure. Otherwise, it won't.
*
*  TEE     (global output) LOGICAL
*          On exit, if TEE is .TRUE., the tester will  perform the error
*          exit tests. These tests won't be performed otherwise.
*
*  IAM     (local input) INTEGER
*          On entry,  IAM  specifies the number of the process executing
*          this routine.
*
*  IGAP    (global output) INTEGER
*          On exit, IGAP  specifies the user-specified gap used for pad-
*          ding. IGAP must be at least zero.
*
*  IVERB   (global output) INTEGER
*          On exit,  IVERB  specifies  the output verbosity level: 0 for
*          pass/fail, 1, 2 or 3 for matrix dump on errors.
*
*  NPROCS  (global input) INTEGER
*          On entry, NPROCS specifies the total number of processes.
*
*  ALPHA   (global output) REAL
*          On exit, ALPHA specifies the value of alpha to be used in all
*          the test cases.
*
*  WORK    (local workspace) INTEGER array
*          On   entry,   WORK   is   an  array  of  dimension  at  least
*          MAX( 2, 2*NGRIDS+23*NMAT+NSUBS+4 )  with  NSUBS  equal  to 8.
*          This array is used to pack all output arrays in order to send
*          the information 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 = 8 )
*     ..
*     .. Local Scalars ..
      LOGICAL            LTESTT
      INTEGER            I, ICTXT, J
      REAL               EPS
*     ..
*     .. 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
*     ..
*     .. External Functions ..
      REAL               PSLAMCH
      EXTERNAL           PSLAMCH
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          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='PSBLAS1TST.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.
*
*        Read the flag that indicates if Stop on Failure
*
         READ( NIN, FMT = * ) SOF
*
*        Read the flag that indicates if Test Error Exits
*
         READ( NIN, FMT = * ) TEE
*
*        Read the verbosity level
*
         READ( NIN, FMT = * ) IVERB
         IF( IVERB.LT.0 .OR. IVERB.GT.3 )
     $      IVERB = 0
*
*        Read the leading dimension gap
*
         READ( NIN, FMT = * ) IGAP
         IF( IGAP.LT.0 )
     $      IGAP = 0
*
*        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 100
         ELSE IF( NGRIDS.GT.LDQVAL ) THEN
            WRITE( NOUT, FMT = 9998 ) 'Grids', LDQVAL
            GO TO 100
         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
*
         READ( NIN, FMT = * ) ALPHA
*
*        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 100
         END IF
*
*        Read in input data into arrays.
*
         READ( NIN, FMT = * ) ( NVAL( I ),     I = 1, NMAT )
         READ( NIN, FMT = * ) ( MXVAL( I ),    I = 1, NMAT )
         READ( NIN, FMT = * ) ( NXVAL( I ),    I = 1, NMAT )
         READ( NIN, FMT = * ) ( IMBXVAL( I ),  I = 1, NMAT )
         READ( NIN, FMT = * ) ( INBXVAL( I ),  I = 1, NMAT )
         READ( NIN, FMT = * ) ( MBXVAL( I ),   I = 1, NMAT )
         READ( NIN, FMT = * ) ( NBXVAL( I ),   I = 1, NMAT )
         READ( NIN, FMT = * ) ( RSCXVAL( I ),  I = 1, NMAT )
         READ( NIN, FMT = * ) ( CSCXVAL( I ),  I = 1, NMAT )
         READ( NIN, FMT = * ) ( IXVAL( I ),    I = 1, NMAT )
         READ( NIN, FMT = * ) ( JXVAL( I ),    I = 1, NMAT )
         READ( NIN, FMT = * ) ( INCXVAL( I ),  I = 1, NMAT )
         READ( NIN, FMT = * ) ( MYVAL( I ),    I = 1, NMAT )
         READ( NIN, FMT = * ) ( NYVAL( I ),    I = 1, NMAT )
         READ( NIN, FMT = * ) ( IMBYVAL( I ),  I = 1, NMAT )
         READ( NIN, FMT = * ) ( INBYVAL( I ),  I = 1, NMAT )
         READ( NIN, FMT = * ) ( MBYVAL( I ),   I = 1, NMAT )
         READ( NIN, FMT = * ) ( NBYVAL( I ),   I = 1, NMAT )
         READ( NIN, FMT = * ) ( RSCYVAL( I ),  I = 1, NMAT )
         READ( NIN, FMT = * ) ( CSCYVAL( I ),  I = 1, NMAT )
         READ( NIN, FMT = * ) ( IYVAL( I ),    I = 1, NMAT )
         READ( NIN, FMT = * ) ( JYVAL( I ),    I = 1, NMAT )
         READ( NIN, FMT = * ) ( INCYVAL( 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 100
*
   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 )
*
*        Compute machine epsilon
*
         EPS = PSLAMCH( ICTXT, 'eps' )
*
*        Pack information arrays and broadcast
*
         CALL SGEBS2D( ICTXT, 'All', ' ', 1, 1, ALPHA, 1 )
*
         WORK( 1 ) = NGRIDS
         WORK( 2 ) = NMAT
         CALL IGEBS2D( ICTXT, 'All', ' ', 2, 1, WORK, 2 )
*
         I = 1
         IF( SOF ) THEN
            WORK( I ) = 1
         ELSE
            WORK( I ) = 0
         END IF
         I = I + 1
         IF( TEE ) THEN
            WORK( I ) = 1
         ELSE
            WORK( I ) = 0
         END IF
         I = I + 1
         WORK( I ) = IVERB
         I = I + 1
         WORK( I ) = IGAP
         I = I + 1
         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,   NVAL,     1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   MXVAL,    1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   NXVAL,    1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   IMBXVAL,  1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   INBXVAL,  1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   MBXVAL,   1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   NBXVAL,   1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   RSCXVAL,  1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   CSCXVAL,  1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   IXVAL,    1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   JXVAL,    1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   INCXVAL,  1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   MYVAL,    1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   NYVAL,    1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   IMBYVAL,  1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   INBYVAL,  1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   MBYVAL,   1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   NBYVAL,   1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   RSCYVAL,  1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   CSCYVAL,  1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   IYVAL,    1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   JYVAL,    1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   INCYVAL,  1, WORK( I ), 1 )
         I = I + NMAT
*
         DO 70 J = 1, NSUBS
            IF( LTEST( J ) ) THEN
               WORK( I ) = 1
            ELSE
               WORK( I ) = 0
            END IF
            I = I + 1
   70    CONTINUE
         I = I - 1
         CALL IGEBS2D( ICTXT, 'All', ' ', I, 1, WORK, I )
*
*        regurgitate input
*
         WRITE( NOUT, FMT = 9999 ) 'Level 1 PBLAS testing program.'
         WRITE( NOUT, FMT = 9999 ) USRINFO
         WRITE( NOUT, FMT = * )
         WRITE( NOUT, FMT = 9999 )
     $               'Tests of the real single precision '//
     $               'Level 1 PBLAS'
         WRITE( NOUT, FMT = * )
         WRITE( NOUT, FMT = 9999 )
     $               'The following parameter values will be used:'
         WRITE( NOUT, FMT = * )
         WRITE( NOUT, FMT = 9993 ) NMAT
         WRITE( NOUT, FMT = 9992 ) NGRIDS
         WRITE( NOUT, FMT = 9990 )
     $               'P', ( PVAL(I), I = 1, MIN(NGRIDS, 5) )
         IF( NGRIDS.GT.5 )
     $      WRITE( NOUT, FMT = 9991 ) ( PVAL(I), I = 6,
     $                                  MIN( 10, NGRIDS ) )
         IF( NGRIDS.GT.10 )
     $      WRITE( NOUT, FMT = 9991 ) ( PVAL(I), I = 11,
     $                                  MIN( 15, NGRIDS ) )
         IF( NGRIDS.GT.15 )
     $      WRITE( NOUT, FMT = 9991 ) ( PVAL(I), I = 16, NGRIDS )
         WRITE( NOUT, FMT = 9990 )
     $               'Q', ( QVAL(I), I = 1, MIN(NGRIDS, 5) )
         IF( NGRIDS.GT.5 )
     $      WRITE( NOUT, FMT = 9991 ) ( QVAL(I), I = 6,
     $                                  MIN( 10, NGRIDS ) )
         IF( NGRIDS.GT.10 )
     $      WRITE( NOUT, FMT = 9991 ) ( QVAL(I), I = 11,
     $                                  MIN( 15, NGRIDS ) )
         IF( NGRIDS.GT.15 )
     $      WRITE( NOUT, FMT = 9991 ) ( QVAL(I), I = 16, NGRIDS )
         WRITE( NOUT, FMT = 9988 ) SOF
         WRITE( NOUT, FMT = 9987 ) TEE
         WRITE( NOUT, FMT = 9983 ) IGAP
         WRITE( NOUT, FMT = 9986 ) IVERB
         WRITE( NOUT, FMT = 9982 ) ALPHA
         IF( LTEST( 1 ) ) THEN
            WRITE( NOUT, FMT = 9985 ) SNAMES( 1 ), ' ... Yes'
         ELSE
            WRITE( NOUT, FMT = 9985 ) SNAMES( 1 ), ' ... No '
         END IF
         DO 80 I = 2, NSUBS
            IF( LTEST( I ) ) THEN
               WRITE( NOUT, FMT = 9984 ) SNAMES( I ), ' ... Yes'
            ELSE
               WRITE( NOUT, FMT = 9984 ) SNAMES( I ), ' ... No '
            END IF
   80    CONTINUE
         WRITE( NOUT, FMT = 9994 ) EPS
         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 )
*
*        Compute machine epsilon
*
         EPS = PSLAMCH( ICTXT, 'eps' )
*
         CALL SGEBR2D( ICTXT, 'All', ' ', 1, 1, ALPHA, 1, 0, 0 )
*
         CALL IGEBR2D( ICTXT, 'All', ' ', 2, 1, WORK, 2, 0, 0 )
         NGRIDS = WORK( 1 )
         NMAT   = WORK( 2 )
*
         I = 2*NGRIDS + 23*NMAT + NSUBS + 4
         CALL IGEBR2D( ICTXT, 'All', ' ', I, 1, WORK, I, 0, 0 )
*
         I = 1
         IF( WORK( I ).EQ.1 ) THEN
            SOF = .TRUE.
         ELSE
            SOF = .FALSE.
         END IF
         I = I + 1
         IF( WORK( I ).EQ.1 ) THEN
            TEE = .TRUE.
         ELSE
            TEE = .FALSE.
         END IF
         I = I + 1
         IVERB = WORK( I )
         I = I + 1
         IGAP = WORK( I )
         I = I + 1
         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, NVAL,     1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   WORK( I ), 1, MXVAL,    1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   WORK( I ), 1, NXVAL,    1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   WORK( I ), 1, IMBXVAL,  1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   WORK( I ), 1, INBXVAL,  1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   WORK( I ), 1, MBXVAL,   1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   WORK( I ), 1, NBXVAL,   1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   WORK( I ), 1, RSCXVAL,  1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   WORK( I ), 1, CSCXVAL,  1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   WORK( I ), 1, IXVAL,    1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   WORK( I ), 1, JXVAL,    1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   WORK( I ), 1, INCXVAL,  1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   WORK( I ), 1, MYVAL,    1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   WORK( I ), 1, NYVAL,    1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   WORK( I ), 1, IMBYVAL,  1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   WORK( I ), 1, INBYVAL,  1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   WORK( I ), 1, MBYVAL,   1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   WORK( I ), 1, NBYVAL,   1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   WORK( I ), 1, RSCYVAL,  1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   WORK( I ), 1, CSCYVAL,  1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   WORK( I ), 1, IYVAL,    1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   WORK( I ), 1, JYVAL,    1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   WORK( I ), 1, INCYVAL,  1 )
         I = I + NMAT
*
         DO 90 J = 1, NSUBS
            IF( WORK( I ).EQ.1 ) THEN
               LTEST( J ) = .TRUE.
            ELSE
               LTEST( J ) = .FALSE.
            END IF
            I = I + 1
   90    CONTINUE
*
      END IF
*
      CALL BLACS_GRIDEXIT( ICTXT )
*
      RETURN
*
  100 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, 'Relative machine precision (eps) is taken to be ',
     $        E18.6 )
 9993 FORMAT( 2X, 'Number of Tests           : ', I6 )
 9992 FORMAT( 2X, 'Number of process grids   : ', I6 )
 9991 FORMAT( 2X, '                          : ', 5I6 )
 9990 FORMAT( 2X, A1, '                         : ', 5I6 )
 9988 FORMAT( 2X, 'Stop on failure flag      : ', L6 )
 9987 FORMAT( 2X, 'Test for error exits flag : ', L6 )
 9986 FORMAT( 2X, 'Verbosity level           : ', I6 )
 9985 FORMAT( 2X, 'Routines to be tested     :      ', A, A8 )
 9984 FORMAT( 2X, '                                 ', A, A8 )
 9983 FORMAT( 2X, 'Leading dimension gap     : ', I6 )
 9982 FORMAT( 2X, 'Alpha                     : ', G16.6 )
*
*     End of PSBLA1TSTINFO
*
      END
      SUBROUTINE PSBLAS1TSTCHKE( LTEST, INOUT, NPROCS )
*
*  -- 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            INOUT, NPROCS
*     ..
*     .. Array Arguments ..
      LOGICAL            LTEST( * )
*     ..
*
*  Purpose
*  =======
*
*  PSBLAS1TSTCHKE tests the error exits of the Level 1 PBLAS.
*
*  Notes
*  =====
*
*  A description  vector  is associated with each 2D block-cyclicly dis-
*  tributed matrix.  This  vector  stores  the  information  required to
*  establish the  mapping  between a  matrix entry and its corresponding
*  process and memory location.
*
*  In  the  following  comments,   the character _  should  be  read  as
*  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
*  block cyclicly distributed matrix.  Its description vector is DESCA:
*
*  NOTATION         STORED IN       EXPLANATION
*  ---------------- --------------- ------------------------------------
*  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
*  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
*                                   the NPROW x NPCOL BLACS process grid
*                                   A  is distributed over.  The context
*                                   itself  is  global,  but  the handle
*                                   (the integer value) may vary.
*  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
*                                   ted matrix A, M_A >= 0.
*  N_A     (global) DESCA( N_     ) The number of columns in the distri-
*                                   buted matrix A, N_A >= 0.
*  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
*                                   block of the matrix A, IMB_A > 0.
*  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
*                                   left   block   of   the   matrix  A,
*                                   INB_A > 0.
*  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
*                                   bute the last  M_A-IMB_A rows of  A,
*                                   MB_A > 0.
*  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
*                                   bute the last  N_A-INB_A  columns of
*                                   A, NB_A > 0.
*  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
*                                   row of the matrix  A is distributed,
*                                   NPROW > RSRC_A >= 0.
*  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
*                                   first  column of  A  is distributed.
*                                   NPCOL > CSRC_A >= 0.
*  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
*                                   array  storing  the  local blocks of
*                                   the distributed matrix A,
*                                   IF( Lc( 1, N_A ) > 0 )
*                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
*                                   ELSE
*                                      LLD_A >= 1.
*
*  Let K be the number of  rows of a matrix A starting at the global in-
*  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
*  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
*  receive if these K rows were distributed over NPROW processes.  If  K
*  is the number of columns of a matrix  A  starting at the global index
*  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
*  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
*  these K columns were distributed over NPCOL processes.
*
*  The values of Lr() and Lc() may be determined via a call to the func-
*  tion PB_NUMROC:
*  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
*  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
*
*  Arguments
*  =========
*
*  LTEST   (global input) LOGICAL array
*          On entry, LTEST is an array of dimension at least 8 (NSUBS).
*             If LTEST( 1 ) is .TRUE., PSSWAP will be tested;
*             If LTEST( 2 ) is .TRUE., PSSCAL will be tested;
*             If LTEST( 3 ) is .TRUE., PSCOPY will be tested;
*             If LTEST( 4 ) is .TRUE., PSAXPY will be tested;
*             If LTEST( 5 ) is .TRUE., PSDOT  will be tested;
*             If LTEST( 6 ) is .TRUE., PSNRM2 will be tested;
*             If LTEST( 7 ) is .TRUE., PSASUM will be tested;
*             If LTEST( 8 ) is .TRUE., PSAMAX will be tested.
*
*  INOUT   (global input) INTEGER
*          On entry,  INOUT  specifies  the unit number for output file.
*          When INOUT is 6, output to screen,  when INOUT = 0, output to
*          stderr. INOUT is only defined in process 0.
*
*  NPROCS  (global input) INTEGER
*          On entry, NPROCS specifies the total number of processes cal-
*          ling this routine.
*
*  Calling sequence encodings
*  ==========================
*
*  code Formal argument list                                Examples
*
*  11   (n,      v1,v2)                                     _SWAP, _COPY
*  12   (n,s1,   v1   )                                     _SCAL, _SCAL
*  13   (n,s1,   v1,v2)                                     _AXPY, _DOT_
*  14   (n,s1,i1,v1   )                                     _AMAX
*  15   (n,u1,   v1   )                                     _ASUM, _NRM2
*
*  21   (     trans,     m,n,s1,m1,v1,s2,v2)                _GEMV
*  22   (uplo,             n,s1,m1,v1,s2,v2)                _SYMV, _HEMV
*  23   (uplo,trans,diag,  n,   m1,v1      )                _TRMV, _TRSV
*  24   (                m,n,s1,v1,v2,m1)                   _GER_
*  25   (uplo,             n,s1,v1,   m1)                   _SYR
*  26   (uplo,             n,u1,v1,   m1)                   _HER
*  27   (uplo,             n,s1,v1,v2,m1)                   _SYR2, _HER2
*
*  31   (          transa,transb,     m,n,k,s1,m1,m2,s2,m3) _GEMM
*  32   (side,uplo,                   m,n,  s1,m1,m2,s2,m3) _SYMM, _HEMM
*  33   (     uplo,trans,               n,k,s1,m1,   s2,m3) _SYRK
*  34   (     uplo,trans,               n,k,u1,m1,   u2,m3) _HERK
*  35   (     uplo,trans,               n,k,s1,m1,m2,s2,m3) _SYR2K
*  36   (     uplo,trans,               n,k,s1,m1,m2,u2,m3) _HER2K
*  37   (                             m,n,  s1,m1,   s2,m3) _TRAN_
*  38   (side,uplo,transa,       diag,m,n,  s1,m1,m2      ) _TRMM, _TRSM
*  39   (          trans,             m,n,  s1,m1,   s2,m3) _GEADD
*  40   (     uplo,trans,             m,n,  s1,m1,   s2,m3) _TRADD
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            NSUBS
      PARAMETER          ( NSUBS = 8 )
*     ..
*     .. Local Scalars ..
      LOGICAL            ABRTSAV
      INTEGER            I, ICTXT, MYCOL, MYROW, NPCOL, NPROW
*     ..
*     .. Local Arrays ..
      INTEGER            SCODE( NSUBS )
*     ..
*     .. External Subroutines ..
      EXTERNAL           BLACS_GET, BLACS_GRIDEXIT, BLACS_GRIDINFO,
     $                   BLACS_GRIDINIT, PSAMAX, PSASUM, PSAXPY, PSCOPY,
     $                   PSDIMEE, PSDOT, PSNRM2, PSSCAL, PSSWAP,
     $                   PSVECEE
*     ..
*     .. Common Blocks ..
      LOGICAL            ABRTFLG
      INTEGER            NOUT
      CHARACTER*7        SNAMES( NSUBS )
      COMMON             /SNAMEC/SNAMES
      COMMON             /PBERRORC/NOUT, ABRTFLG
*     ..
*     .. Data Statements ..
      DATA               SCODE/11, 12, 11, 13, 13, 15, 15, 14/
*     ..
*     .. Executable Statements ..
*
*     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 BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
*
*     Set ABRTFLG to FALSE so that the PBLAS error handler won't abort
*     on errors during these tests and set the output device unit for
*     it.
*
      ABRTSAV = ABRTFLG
      ABRTFLG = .FALSE.
      NOUT    = INOUT
*
*     Test PSSWAP
*
      I = 1
      IF( LTEST( I ) ) THEN
         CALL PSDIMEE( ICTXT, NOUT, PSSWAP, SCODE( I ), SNAMES( I ) )
         CALL PSVECEE( ICTXT, NOUT, PSSWAP, SCODE( I ), SNAMES( I ) )
      END IF
*
*     Test PSSCAL
*
      I = I + 1
      IF( LTEST( I ) ) THEN
         CALL PSDIMEE( ICTXT, NOUT, PSSCAL, SCODE( I ), SNAMES( I ) )
         CALL PSVECEE( ICTXT, NOUT, PSSCAL, SCODE( I ), SNAMES( I ) )
      END IF
*
*     Test PSCOPY
*
      I = I + 1
      IF( LTEST( I ) ) THEN
         CALL PSDIMEE( ICTXT, NOUT, PSCOPY, SCODE( I ), SNAMES( I ) )
         CALL PSVECEE( ICTXT, NOUT, PSCOPY, SCODE( I ), SNAMES( I ) )
      END IF
*
*     Test PSAXPY
*
      I = I + 1
      IF( LTEST( I ) ) THEN
         CALL PSDIMEE( ICTXT, NOUT, PSAXPY, SCODE( I ), SNAMES( I ) )
         CALL PSVECEE( ICTXT, NOUT, PSAXPY, SCODE( I ), SNAMES( I ) )
      END IF
*
*     Test PSDOT
*
      I = I + 1
      IF( LTEST( I ) ) THEN
         CALL PSDIMEE( ICTXT, NOUT, PSDOT, SCODE( I ), SNAMES( I ) )
         CALL PSVECEE( ICTXT, NOUT, PSDOT, SCODE( I ), SNAMES( I ) )
      END IF
*
*     Test PSNRM2
*
      I = I + 1
      IF( LTEST( I ) ) THEN
         CALL PSDIMEE( ICTXT, NOUT, PSNRM2, SCODE( I ), SNAMES( I ) )
         CALL PSVECEE( ICTXT, NOUT, PSNRM2, SCODE( I ), SNAMES( I ) )
      END IF
*
*     Test PSASUM
*
      I = I + 1
      IF( LTEST( I ) ) THEN
         CALL PSDIMEE( ICTXT, NOUT, PSASUM, SCODE( I ), SNAMES( I ) )
         CALL PSVECEE( ICTXT, NOUT, PSASUM, SCODE( I ), SNAMES( I ) )
      END IF
*
*     Test PSAMAX
*
      I = I + 1
      IF( LTEST( I ) ) THEN
         CALL PSDIMEE( ICTXT, NOUT, PSAMAX, SCODE( I ), SNAMES( I ) )
         CALL PSVECEE( ICTXT, NOUT, PSAMAX, SCODE( I ), SNAMES( I ) )
      END IF
*
      IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 )
     $   WRITE( NOUT, FMT = 9999 )
*
      CALL BLACS_GRIDEXIT( ICTXT )
*
*     Reset ABRTFLG to the value it had before calling this routine
*
      ABRTFLG = ABRTSAV
*
 9999 FORMAT( 2X, 'Error-exit tests completed.' )
*
      RETURN
*
*     End of PSBLAS1TSTCHKE
*
      END
      SUBROUTINE PSCHKARG1( ICTXT, NOUT, SNAME, N, ALPHA, IX, JX,
     $                      DESCX, INCX, IY, JY, DESCY, INCY, INFO )
*
*  -- 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            ICTXT, INCX, INCY, INFO, IX, IY, JX, JY, N,
     $                   NOUT
      REAL               ALPHA
*     ..
*     .. Array Arguments ..
      CHARACTER*(*)      SNAME
      INTEGER            DESCX( * ), DESCY( * )
*     ..
*
*  Purpose
*  =======
*
*  PSCHKARG1 checks the input-only arguments of the Level 1 PBLAS.  When
*  INFO = 0, this routine makes a copy of its arguments (which are INPUT
*  only arguments to PBLAS routines). Otherwise, it verifies the  values
*  of these arguments against the saved copies.
*
*  Notes
*  =====
*
*  A description  vector  is associated with each 2D block-cyclicly dis-
*  tributed matrix.  This  vector  stores  the  information  required to
*  establish the  mapping  between a  matrix entry and its corresponding
*  process and memory location.
*
*  In  the  following  comments,   the character _  should  be  read  as
*  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
*  block cyclicly distributed matrix.  Its description vector is DESCA:
*
*  NOTATION         STORED IN       EXPLANATION
*  ---------------- --------------- ------------------------------------
*  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
*  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
*                                   the NPROW x NPCOL BLACS process grid
*                                   A  is distributed over.  The context
*                                   itself  is  global,  but  the handle
*                                   (the integer value) may vary.
*  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
*                                   ted matrix A, M_A >= 0.
*  N_A     (global) DESCA( N_     ) The number of columns in the distri-
*                                   buted matrix A, N_A >= 0.
*  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
*                                   block of the matrix A, IMB_A > 0.
*  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
*                                   left   block   of   the   matrix  A,
*                                   INB_A > 0.
*  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
*                                   bute the last  M_A-IMB_A rows of  A,
*                                   MB_A > 0.
*  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
*                                   bute the last  N_A-INB_A  columns of
*                                   A, NB_A > 0.
*  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
*                                   row of the matrix  A is distributed,
*                                   NPROW > RSRC_A >= 0.
*  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
*                                   first  column of  A  is distributed.
*                                   NPCOL > CSRC_A >= 0.
*  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
*                                   array  storing  the  local blocks of
*                                   the distributed matrix A,
*                                   IF( Lc( 1, N_A ) > 0 )
*                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
*                                   ELSE
*                                      LLD_A >= 1.
*
*  Let K be the number of  rows of a matrix A starting at the global in-
*  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
*  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
*  receive if these K rows were distributed over NPROW processes.  If  K
*  is the number of columns of a matrix  A  starting at the global index
*  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
*  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
*  these K columns were distributed over NPCOL processes.
*
*  The values of Lr() and Lc() may be determined via a call to the func-
*  tion PB_NUMROC:
*  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
*  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
*
*  Arguments
*  =========
*
*  ICTXT   (local input) INTEGER
*          On entry,  ICTXT  specifies the BLACS context handle, indica-
*          ting the global  context of the operation. The context itself
*          is global, but the value of ICTXT is local.
*
*  NOUT    (global input) INTEGER
*          On entry, 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.
*
*  SNAME   (global input) CHARACTER*(*)
*          On entry, SNAME specifies the subroutine  name  calling  this
*          subprogram.
*
*  N       (global input) INTEGER
*          On entry, N specifies the length of the subvector operands.
*
*  ALPHA   (global input) REAL
*          On entry, ALPHA specifies the scalar alpha.
*
*  IX      (global input) INTEGER
*          On entry, IX  specifies X's global row index, which points to
*          the beginning of the submatrix sub( X ).
*
*  JX      (global input) INTEGER
*          On entry, JX  specifies X's global column index, which points
*          to the beginning of the submatrix sub( X ).
*
*  DESCX   (global and local input) INTEGER array
*          On entry, DESCX  is an integer array of dimension DLEN_. This
*          is the array descriptor for the matrix X.
*
*  INCX    (global input) INTEGER
*          On entry,  INCX   specifies  the  global  increment  for  the
*          elements of  X.  Only two values of  INCX   are  supported in
*          this version, namely 1 and M_X. INCX  must not be zero.
*
*  IY      (global input) INTEGER
*          On entry, IY  specifies Y's global row index, which points to
*          the beginning of the submatrix sub( Y ).
*
*  JY      (global input) INTEGER
*          On entry, JY  specifies Y's global column index, which points
*          to the beginning of the submatrix sub( Y ).
*
*  DESCY   (global and local input) INTEGER array
*          On entry, DESCY  is an integer array of dimension DLEN_. This
*          is the array descriptor for the matrix Y.
*
*  INCY    (global input) INTEGER
*          On entry,  INCY   specifies  the  global  increment  for  the
*          elements of  Y.  Only two values of  INCY   are  supported in
*          this version, namely 1 and M_Y. INCY  must not be zero.
*
*  INFO    (global input/global output) INTEGER
*          When INFO = 0 on entry, the values of the arguments which are
*          INPUT only arguments to a PBLAS routine are copied into  sta-
*          tic variables and INFO is unchanged on exit.  Otherwise,  the
*          values  of  the  arguments are compared against the saved co-
*          pies. In case no error has been found INFO is zero on return,
*          otherwise it is non zero.
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Parameters ..
      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 ..
      INTEGER            I, INCXREF, INCYREF, IXREF, IYREF, JXREF,
     $                   JYREF, MYCOL, MYROW, NPCOL, NPROW, NREF
      REAL               ALPHAREF
*     ..
*     .. Local Arrays ..
      CHARACTER*15       ARGNAME
      INTEGER            DESCXREF( DLEN_ ), DESCYREF( DLEN_ )
*     ..
*     .. External Subroutines ..
      EXTERNAL           BLACS_GRIDINFO, IGSUM2D
*     ..
*     .. Save Statements ..
      SAVE
*     ..
*     .. Executable Statements ..
*
*     Get grid parameters
*
      CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
*
*     Check if first call. If yes, then save.
*
      IF( INFO.EQ.0 ) THEN
*
         NREF = N
         IXREF = IX
         JXREF = JX
         DO 10 I = 1, DLEN_
            DESCXREF( I ) = DESCX( I )
   10    CONTINUE
         INCXREF = INCX
         IYREF = IY
         JYREF = JY
         DO 20 I = 1, DLEN_
            DESCYREF( I ) = DESCY( I )
   20    CONTINUE
         INCYREF = INCY
         ALPHAREF = ALPHA
*
      ELSE
*
*        Test saved args. Return with first mismatch.
*
         ARGNAME = ' '
         IF( N.NE.NREF ) THEN
            WRITE( ARGNAME, FMT = '(A)' ) 'N'
         ELSE IF( IX.NE.IXREF ) THEN
            WRITE( ARGNAME, FMT = '(A)' ) 'IX'
         ELSE IF( JX.NE.JXREF ) THEN
            WRITE( ARGNAME, FMT = '(A)' ) 'JX'
         ELSE IF( DESCX( DTYPE_ ).NE.DESCXREF( DTYPE_ ) ) THEN
            WRITE( ARGNAME, FMT = '(A)' ) 'DESCX( DTYPE_ )'
         ELSE IF( DESCX( M_ ).NE.DESCXREF( M_ ) ) THEN
            WRITE( ARGNAME, FMT = '(A)' ) 'DESCX( M_ )'
         ELSE IF( DESCX( N_ ).NE.DESCXREF( N_ ) ) THEN
            WRITE( ARGNAME, FMT = '(A)' ) 'DESCX( N_ )'
         ELSE IF( DESCX( IMB_ ).NE.DESCXREF( IMB_ ) ) THEN
            WRITE( ARGNAME, FMT = '(A)' ) 'DESCX( IMB_ )'
         ELSE IF( DESCX( INB_ ).NE.DESCXREF( INB_ ) ) THEN
            WRITE( ARGNAME, FMT = '(A)' ) 'DESCX( INB_ )'
         ELSE IF( DESCX( MB_ ).NE.DESCXREF( MB_ ) ) THEN
            WRITE( ARGNAME, FMT = '(A)' ) 'DESCX( MB_ )'
         ELSE IF( DESCX( NB_ ).NE.DESCXREF( NB_ ) ) THEN
            WRITE( ARGNAME, FMT = '(A)' ) 'DESCX( NB_ )'
         ELSE IF( DESCX( RSRC_ ).NE.DESCXREF( RSRC_ ) ) THEN
            WRITE( ARGNAME, FMT = '(A)' ) 'DESCX( RSRC_ )'
         ELSE IF( DESCX( CSRC_ ).NE.DESCXREF( CSRC_ ) ) THEN
            WRITE( ARGNAME, FMT = '(A)' ) 'DESCX( CSRC_ )'
         ELSE IF( DESCX( CTXT_ ).NE.DESCXREF( CTXT_ ) ) THEN
            WRITE( ARGNAME, FMT = '(A)' ) 'DESCX( CTXT_ )'
         ELSE IF( DESCX( LLD_ ).NE.DESCXREF( LLD_ ) ) THEN
            WRITE( ARGNAME, FMT = '(A)' ) 'DESCX( LLD_ )'
         ELSE IF( INCX.NE.INCXREF ) THEN
            WRITE( ARGNAME, FMT = '(A)' ) 'INCX'
         ELSE IF( IY.NE.IYREF ) THEN
            WRITE( ARGNAME, FMT = '(A)' ) 'IY'
         ELSE IF( JY.NE.JYREF ) THEN
            WRITE( ARGNAME, FMT = '(A)' ) 'JY'
         ELSE IF( DESCY( DTYPE_ ).NE.DESCYREF( DTYPE_ ) ) THEN
            WRITE( ARGNAME, FMT = '(A)' ) 'DESCY( DTYPE_ )'
         ELSE IF( DESCY( M_ ).NE.DESCYREF( M_ ) ) THEN
            WRITE( ARGNAME, FMT = '(A)' ) 'DESCY( M_ )'
         ELSE IF( DESCY( N_ ).NE.DESCYREF( N_ ) ) THEN
            WRITE( ARGNAME, FMT = '(A)' ) 'DESCY( N_ )'
         ELSE IF( DESCY( IMB_ ).NE.DESCYREF( IMB_ ) ) THEN
            WRITE( ARGNAME, FMT = '(A)' ) 'DESCY( IMB_ )'
         ELSE IF( DESCY( INB_ ).NE.DESCYREF( INB_ ) ) THEN
            WRITE( ARGNAME, FMT = '(A)' ) 'DESCY( INB_ )'
         ELSE IF( DESCY( MB_ ).NE.DESCYREF( MB_ ) ) THEN
            WRITE( ARGNAME, FMT = '(A)' ) 'DESCY( MB_ )'
         ELSE IF( DESCY( NB_ ).NE.DESCYREF( NB_ ) ) THEN
            WRITE( ARGNAME, FMT = '(A)' ) 'DESCY( NB_ )'
         ELSE IF( DESCY( RSRC_ ).NE.DESCYREF( RSRC_ ) ) THEN
            WRITE( ARGNAME, FMT = '(A)' ) 'DESCY( RSRC_ )'
         ELSE IF( DESCY( CSRC_ ).NE.DESCYREF( CSRC_ ) ) THEN
            WRITE( ARGNAME, FMT = '(A)' ) 'DESCY( CSRC_ )'
         ELSE IF( DESCY( CTXT_ ).NE.DESCYREF( CTXT_ ) ) THEN
            WRITE( ARGNAME, FMT = '(A)' ) 'DESCY( CTXT_ )'
         ELSE IF( DESCY( LLD_ ).NE.DESCYREF( LLD_ ) ) THEN
            WRITE( ARGNAME, FMT = '(A)' ) 'DESCY( LLD_ )'
         ELSE IF( INCY.NE.INCYREF ) THEN
            WRITE( ARGNAME, FMT = '(A)' ) 'INCY'
         ELSE IF( ALPHA.NE.ALPHAREF ) THEN
            WRITE( ARGNAME, FMT = '(A)' ) 'ALPHA'
         ELSE
            INFO = 0
         END IF
*
         CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, INFO, 1, -1, 0 )
*
         IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN
*
            IF( INFO.GT.0 ) THEN
               WRITE( NOUT, FMT = 9999 ) ARGNAME, SNAME
            ELSE
               WRITE( NOUT, FMT = 9998 ) SNAME
            END IF
*
         END IF
*
      END IF
*
 9999 FORMAT( 2X, '   ***** Input-only parameter check: ', A,
     $        ' FAILED  changed ', A, ' *****' )
 9998 FORMAT( 2X, '   ***** Input-only parameter check: ', A,
     $        ' PASSED  *****' )
*
      RETURN
*
*     End of PSCHKARG1
*
      END
      LOGICAL FUNCTION PISINSCOPE( ICTXT, N, IX, JX, DESCX, INCX )
*
*  -- 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            ICTXT, INCX, IX, JX, N
*     ..
*     .. Array Arguments ..
      INTEGER            DESCX( * )
*     ..
*
*  Purpose
*  =======
*
*  PISINSCOPE returns  .TRUE.  if the calling process is in the scope of
*  sub( X ) = X( IX+(JX-1)*DESCX(M_)+(i-1)*INCX ) and  .FALSE.  if it is
*  not.  This  routine is used to determine which processes should check
*  the answer returned by some Level 1 PBLAS routines.
*
*  Notes
*  =====
*
*  A description  vector  is associated with each 2D block-cyclicly dis-
*  tributed matrix.  This  vector  stores  the  information  required to
*  establish the  mapping  between a  matrix entry and its corresponding
*  process and memory location.
*
*  In  the  following  comments,   the character _  should  be  read  as
*  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
*  block cyclicly distributed matrix.  Its description vector is DESCA:
*
*  NOTATION         STORED IN       EXPLANATION
*  ---------------- --------------- ------------------------------------
*  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
*  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
*                                   the NPROW x NPCOL BLACS process grid
*                                   A  is distributed over.  The context
*                                   itself  is  global,  but  the handle
*                                   (the integer value) may vary.
*  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
*                                   ted matrix A, M_A >= 0.
*  N_A     (global) DESCA( N_     ) The number of columns in the distri-
*                                   buted matrix A, N_A >= 0.
*  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
*                                   block of the matrix A, IMB_A > 0.
*  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
*                                   left   block   of   the   matrix  A,
*                                   INB_A > 0.
*  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
*                                   bute the last  M_A-IMB_A rows of  A,
*                                   MB_A > 0.
*  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
*                                   bute the last  N_A-INB_A  columns of
*                                   A, NB_A > 0.
*  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
*                                   row of the matrix  A is distributed,
*                                   NPROW > RSRC_A >= 0.
*  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
*                                   first  column of  A  is distributed.
*                                   NPCOL > CSRC_A >= 0.
*  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
*                                   array  storing  the  local blocks of
*                                   the distributed matrix A,
*                                   IF( Lc( 1, N_A ) > 0 )
*                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
*                                   ELSE
*                                      LLD_A >= 1.
*
*  Let K be the number of  rows of a matrix A starting at the global in-
*  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
*  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
*  receive if these K rows were distributed over NPROW processes.  If  K
*  is the number of columns of a matrix  A  starting at the global index
*  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
*  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
*  these K columns were distributed over NPCOL processes.
*
*  The values of Lr() and Lc() may be determined via a call to the func-
*  tion PB_NUMROC:
*  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
*  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
*
*  Arguments
*  =========
*
*  ICTXT   (local input) INTEGER
*          On entry,  ICTXT  specifies the BLACS context handle, indica-
*          ting the global  context of the operation. The context itself
*          is global, but the value of ICTXT is local.
*
*  N       (global input) INTEGER
*          The length of the subvector sub( X ).
*
*  IX      (global input) INTEGER
*          On entry, IX  specifies X's global row index, which points to
*          the beginning of the submatrix sub( X ).
*
*  JX      (global input) INTEGER
*          On entry, JX  specifies X's global column index, which points
*          to the beginning of the submatrix sub( X ).
*
*  DESCX   (global and local input) INTEGER array
*          On entry, DESCX  is an integer array of dimension DLEN_. This
*          is the array descriptor for the matrix X.
*
*  INCX    (global input) INTEGER
*          On entry,  INCX   specifies  the  global  increment  for  the
*          elements of  X.  Only two values of  INCX   are  supported in
*          this version, namely 1 and M_X. INCX  must not be zero.
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Parameters ..
      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 ..
      LOGICAL            COLREP, ROWREP
      INTEGER            IIX, IXCOL, IXROW, JJX, MYCOL, MYROW, NPCOL,
     $                   NPROW
*     ..
*     .. External Subroutines ..
      EXTERNAL           BLACS_GRIDINFO, PB_INFOG2L
*     ..
*     .. Executable Statements ..
*
      CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
*
      CALL PB_INFOG2L( IX, JX, DESCX, NPROW, NPCOL, MYROW, MYCOL,
     $                 IIX, JJX, IXROW, IXCOL )
      ROWREP = ( IXROW.EQ.-1 )
      COLREP = ( IXCOL.EQ.-1 )
*
      IF( DESCX( M_ ).EQ.1 .AND. N.EQ.1 ) THEN
*
*        This is the special case, find process owner of IX, JX, and
*        only this process is the scope.
*
         PISINSCOPE = ( ( IXROW.EQ.MYROW .OR. ROWREP ) .AND.
     $                   ( IXCOL.EQ.MYCOL .OR. COLREP ) )
*
      ELSE
*
         IF( INCX.EQ.DESCX( M_ ) ) THEN
*
*           row vector
*
            PISINSCOPE = ( MYROW.EQ.IXROW .OR. ROWREP )
*
         ELSE
*
*           column vector
*
            PISINSCOPE = ( MYCOL.EQ.IXCOL .OR. COLREP )
*
         END IF
*
      END IF
*
      RETURN
*
*     End of PISINSCOPE
*
      END
      SUBROUTINE PSBLAS1TSTCHK( ICTXT, NOUT, NROUT, N, PSCLR, PUSCLR,
     $                          PISCLR, X, PX, IX, JX, DESCX, INCX, Y,
     $                          PY, IY, JY, DESCY, INCY, INFO )
*
*  -- 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            ICTXT, INCX, INCY, INFO, IX, IY, JX, JY, N,
     $                   NOUT, NROUT, PISCLR
      REAL               PSCLR, PUSCLR
*     ..
*     .. Array Arguments ..
      INTEGER            DESCX( * ), DESCY( * )
      REAL               PX( * ), PY( * ), X( * ), Y( * )
*     ..
*
*  Purpose
*  =======
*
*  PSBLAS1TSTCHK performs the computational tests of the Level 1 PBLAS.
*
*  Notes
*  =====
*
*  A description  vector  is associated with each 2D block-cyclicly dis-
*  tributed matrix.  This  vector  stores  the  information  required to
*  establish the  mapping  between a  matrix entry and its corresponding
*  process and memory location.
*
*  In  the  following  comments,   the character _  should  be  read  as
*  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
*  block cyclicly distributed matrix.  Its description vector is DESCA:
*
*  NOTATION         STORED IN       EXPLANATION
*  ---------------- --------------- ------------------------------------
*  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
*  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
*                                   the NPROW x NPCOL BLACS process grid
*                                   A  is distributed over.  The context
*                                   itself  is  global,  but  the handle
*                                   (the integer value) may vary.
*  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
*                                   ted matrix A, M_A >= 0.
*  N_A     (global) DESCA( N_     ) The number of columns in the distri-
*                                   buted matrix A, N_A >= 0.
*  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
*                                   block of the matrix A, IMB_A > 0.
*  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
*                                   left   block   of   the   matrix  A,
*                                   INB_A > 0.
*  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
*                                   bute the last  M_A-IMB_A rows of  A,
*                                   MB_A > 0.
*  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
*                                   bute the last  N_A-INB_A  columns of
*                                   A, NB_A > 0.
*  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
*                                   row of the matrix  A is distributed,
*                                   NPROW > RSRC_A >= 0.
*  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
*                                   first  column of  A  is distributed.
*                                   NPCOL > CSRC_A >= 0.
*  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
*                                   array  storing  the  local blocks of
*                                   the distributed matrix A,
*                                   IF( Lc( 1, N_A ) > 0 )
*                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
*                                   ELSE
*                                      LLD_A >= 1.
*
*  Let K be the number of  rows of a matrix A starting at the global in-
*  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
*  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
*  receive if these K rows were distributed over NPROW processes.  If  K
*  is the number of columns of a matrix  A  starting at the global index
*  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
*  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
*  these K columns were distributed over NPCOL processes.
*
*  The values of Lr() and Lc() may be determined via a call to the func-
*  tion PB_NUMROC:
*  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
*  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
*
*  Arguments
*  =========
*
*  ICTXT   (local input) INTEGER
*          On entry,  ICTXT  specifies the BLACS context handle, indica-
*          ting the global  context of the operation. The context itself
*          is global, but the value of ICTXT is local.
*
*  NOUT    (global input) INTEGER
*          On entry, 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.
*
*  NROUT   (global input) INTEGER
*          On entry,  NROUT  specifies  which  routine will be tested as
*          follows:
*             If NROUT = 1,      PSSWAP will be tested;
*             else if NROUT = 2, PSSCAL will be tested;
*             else if NROUT = 3, PSCOPY will be tested;
*             else if NROUT = 4, PSAXPY will be tested;
*             else if NROUT = 5, PSDOT  will be tested;
*             else if NROUT = 6, PSNRM2 will be tested;
*             else if NROUT = 7, PSASUM will be tested;
*             else if NROUT = 8, PSAMAX will be tested.
*
*  N       (global input) INTEGER
*          On entry, N specifies the length of the subvector operands.
*
*  PSCLR   (global input) REAL
*          On entry, depending on the value of  NROUT,  PSCLR  specifies
*          the scalar ALPHA, or the output scalar returned by the PBLAS,
*          i.e., the dot product, the 2-norm,  the  absolute sum  or the
*          value of AMAX.
*
*  PUSCLR  (global input) REAL
*          On entry, PUSCLR specifies the real part of the  scalar ALPHA
*          used  by  the  real  scaling, the 2-norm, or the absolute sum
*          routines.  PUSCLR  is  not  used in the real versions of this
*          routine.
*
*  PISCLR  (global input) REAL
*          On entry, PISCLR  specifies the value of the global index re-
*          turned by PSAMAX, otherwise PISCLR is not used.
*
*  X       (local input/local output) REAL array
*          On entry, X is an array of  dimension  (DESCX( M_ ),*).  This
*          array contains a local copy of the initial entire matrix PX.
*
*  PX      (local input) REAL array
*          On entry, PX is an array of dimension (DESCX( LLD_ ),*). This
*          array contains the local entries of the matrix PX.
*
*  IX      (global input) INTEGER
*          On entry, IX  specifies X's global row index, which points to
*          the beginning of the submatrix sub( X ).
*
*  JX      (global input) INTEGER
*          On entry, JX  specifies X's global column index, which points
*          to the beginning of the submatrix sub( X ).
*
*  DESCX   (global and local input) INTEGER array
*          On entry, DESCX  is an integer array of dimension DLEN_. This
*          is the array descriptor for the matrix X.
*
*  INCX    (global input) INTEGER
*          On entry,  INCX   specifies  the  global  increment  for  the
*          elements of  X.  Only two values of  INCX   are  supported in
*          this version, namely 1 and M_X. INCX  must not be zero.
*
*  Y       (local input/local output) REAL array
*          On entry, Y is an array of  dimension  (DESCY( M_ ),*).  This
*          array contains a local copy of the initial entire matrix PY.
*
*  PY      (local input) REAL array
*          On entry, PY is an array of dimension (DESCY( LLD_ ),*). This
*          array contains the local entries of the matrix PY.
*
*  IY      (global input) INTEGER
*          On entry, IY  specifies Y's global row index, which points to
*          the beginning of the submatrix sub( Y ).
*
*  JY      (global input) INTEGER
*          On entry, JY  specifies Y's global column index, which points
*          to the beginning of the submatrix sub( Y ).
*
*  DESCY   (global and local input) INTEGER array
*          On entry, DESCY  is an integer array of dimension DLEN_. This
*          is the array descriptor for the matrix Y.
*
*  INCY    (global input) INTEGER
*          On entry,  INCY   specifies  the  global  increment  for  the
*          elements of  Y.  Only two values of  INCY   are  supported in
*          this version, namely 1 and M_Y. INCY  must not be zero.
*
*  INFO    (global output) INTEGER
*          On exit, if INFO = 0,  no  error  has  been  found, otherwise
*          if( MOD( INFO,   2 ) = 1 ) then an error on X has been found,
*          if( MOD( INFO/2, 2 ) = 1 ) then an error on Y has been found.
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO
      PARAMETER          ( ZERO = 0.0E+0 )
      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 ..
      LOGICAL            COLREP, INXSCOPE, INYSCOPE, ROWREP
      INTEGER            I, IB, ICURCOL, ICURROW, IDUMM, IIX, IIY, IN,
     $                   IOFFX, IOFFY, ISCLR, IXCOL, IXROW, IYCOL,
     $                   IYROW, J, JB, JJX, JJY, JN, KK, LDX, LDY,
     $                   MYCOL, MYROW, NPCOL, NPROW
      REAL               ERR, ERRMAX, PREC, SCLR, USCLR
*     ..
*     .. Local Arrays ..
      INTEGER            IERR( 6 )
      CHARACTER*5        ARGIN1, ARGIN2, ARGOUT1, ARGOUT2
*     ..
*     .. External Subroutines ..
      EXTERNAL           BLACS_GRIDINFO, IGAMX2D, PB_INFOG2L, PSCHKVIN,
     $                   PSERRASUM, PSERRAXPY, PSERRDOT, PSERRNRM2,
     $                   PSERRSCAL, SCOPY, SSWAP
*     ..
*     .. External Functions ..
      LOGICAL            PISINSCOPE
      INTEGER            ISAMAX
      REAL               PSLAMCH
      EXTERNAL           ISAMAX, PISINSCOPE, PSLAMCH
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MIN
*     ..
*     .. Executable Statements ..
*
      INFO    = 0
*
*     Quick return if possible
*
      IF( N.LE.0 )
     $   RETURN
*
      CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
*
      ARGIN1  = '     '
      ARGIN2  = '     '
      ARGOUT1 = '     '
      ARGOUT2 = '     '
      DO 10 I = 1, 6
         IERR( I ) = 0
   10 CONTINUE
*
      PREC = PSLAMCH( ICTXT, 'precision' )
*
      IF( NROUT.EQ.1 ) THEN
*
*        Test PSSWAP
*
         IOFFX = IX + ( JX - 1 ) * DESCX( M_ )
         IOFFY = IY + ( JY - 1 ) * DESCY( M_ )
         CALL SSWAP( N, X( IOFFX ), INCX, Y( IOFFY ), INCY )
         CALL PSCHKVIN( ERRMAX, N, X, PX, IX, JX, DESCX, INCX,
     $                    IERR( 1 ) )
         CALL PSCHKVIN( ERRMAX, N, Y, PY, IY, JY, DESCY, INCY,
     $                    IERR( 2 ) )
*
      ELSE IF( NROUT.EQ.2 ) THEN
*
*        Test PSSCAL
*
         LDX   = DESCX( LLD_ )
         IOFFX = IX + ( JX - 1 ) * DESCX( M_ )
         CALL PB_INFOG2L( IX, JX, DESCX, NPROW, NPCOL, MYROW, MYCOL,
     $                    IIX, JJX, IXROW, IXCOL )
         ICURROW = IXROW
         ICURCOL = IXCOL
         ROWREP = ( IXROW.EQ.-1 )
         COLREP = ( IXCOL.EQ.-1 )
*
         IF( INCX.EQ.DESCX( M_ ) ) THEN
*
*           sub( X ) is a row vector
*
            JB = DESCX( INB_ ) - JX + 1
            IF( JB.LE.0 )
     $         JB = ( (-JB ) / DESCX( NB_ ) + 1 ) * DESCX( NB_ ) + JB
            JB = MIN( JB, N )
            JN = JX + JB - 1
*
            DO 20 J = JX, JN
*
               CALL PSERRSCAL( ERR, PSCLR, X( IOFFX ), PREC )
*
               IF( ( MYROW.EQ.ICURROW .OR. ROWREP ) .AND.
     $             ( MYCOL.EQ.ICURCOL .OR. COLREP ) ) THEN
                  IF( ABS( PX( IIX+(JJX-1)*LDX ) - X( IOFFX ) ).GT.
     $                ERR )
     $             IERR( 1 ) = 1
                  JJX = JJX + 1
               END IF
*
               IOFFX = IOFFX + INCX
*
   20       CONTINUE
*
            ICURCOL = MOD( ICURCOL+1, NPCOL )
*
            DO 40 J = JN+1, JX+N-1, DESCX( NB_ )
               JB = MIN( JX+N-J, DESCX( NB_ ) )
*
               DO 30 KK = 0, JB-1
*
                  CALL PSERRSCAL( ERR, PSCLR, X( IOFFX ), PREC )
*
                  IF( ( MYROW.EQ.ICURROW .OR. ROWREP ) .AND.
     $                ( MYCOL.EQ.ICURCOL .OR. COLREP ) ) THEN
                     IF( ABS( PX( IIX+(JJX-1)*LDX ) - X( IOFFX ) ).GT.
     $                   ERR )
     $                  IERR( 1 ) = 1
                     JJX = JJX + 1
                  END IF
*
                  IOFFX = IOFFX + INCX
*
   30          CONTINUE
*
               ICURCOL = MOD( ICURCOL+1, NPCOL )
*
   40       CONTINUE
*
         ELSE
*
*           sub( X ) is a column vector
*
            IB = DESCX( IMB_ ) - IX + 1
            IF( IB.LE.0 )
     $         IB = ( (-IB ) / DESCX( MB_ ) + 1 ) * DESCX( MB_ ) + IB
            IB = MIN( IB, N )
            IN = IX + IB - 1
*
            DO 50 I = IX, IN
*
               CALL PSERRSCAL( ERR, PSCLR, X( IOFFX ), PREC )
*
               IF( ( MYROW.EQ.ICURROW .OR. ROWREP ) .AND.
     $             ( MYCOL.EQ.ICURCOL .OR. COLREP ) ) THEN
                  IF( ABS( PX( IIX+(JJX-1)*LDX ) - X( IOFFX ) ).GT.
     $                ERR )
     $               IERR( 1 ) = 1
                  IIX = IIX + 1
               END IF
*
               IOFFX = IOFFX + INCX
*
   50       CONTINUE
*
            ICURROW = MOD( ICURROW+1, NPROW )
*
            DO 70 I = IN+1, IX+N-1, DESCX( MB_ )
               IB = MIN( IX+N-I, DESCX( MB_ ) )
*
               DO 60 KK = 0, IB-1
*
                  CALL PSERRSCAL( ERR, PSCLR, X( IOFFX ), PREC )
*
                  IF( ( MYROW.EQ.ICURROW .OR. ROWREP ) .AND.
     $                ( MYCOL.EQ.ICURCOL .OR. COLREP ) ) THEN
                     IF( ABS( PX( IIX+(JJX-1)*LDX ) - X( IOFFX ) ).GT.
     $                   ERR )
     $                  IERR( 1 ) = 1
                     IIX = IIX + 1
                  END IF
*
                  IOFFX = IOFFX + INCX
   60          CONTINUE
*
               ICURROW = MOD( ICURROW+1, NPROW )
*
   70       CONTINUE
*
         END IF
*
      ELSE IF( NROUT.EQ.3 ) THEN
*
*        Test PSCOPY
*
         IOFFX = IX + ( JX - 1 ) * DESCX( M_ )
         IOFFY = IY + ( JY - 1 ) * DESCY( M_ )
         CALL SCOPY( N, X( IOFFX ), INCX, Y( IOFFY ), INCY )
         CALL PSCHKVIN( ERRMAX, N, X, PX, IX, JX, DESCX, INCX,
     $                  IERR( 1 ) )
         CALL PSCHKVIN( ERRMAX, N, Y, PY, IY, JY, DESCY, INCY,
     $                  IERR( 2 ) )
*
      ELSE IF( NROUT.EQ.4 ) THEN
*
*        Test PSAXPY
*
         CALL PSCHKVIN( ERRMAX, N, X, PX, IX, JX, DESCX, INCX,
     $                  IERR( 1 ) )
         LDY = DESCY( LLD_ )
         IOFFX = IX + ( JX - 1 ) * DESCX( M_ )
         IOFFY = IY + ( JY - 1 ) * DESCY( M_ )
         CALL PB_INFOG2L( IY, JY, DESCY, NPROW, NPCOL, MYROW, MYCOL,
     $                    IIY, JJY, IYROW, IYCOL )
         ICURROW = IYROW
         ICURCOL = IYCOL
         ROWREP  = ( IYROW.EQ.-1 )
         COLREP  = ( IYCOL.EQ.-1 )
*
         IF( INCY.EQ.DESCY( M_ ) ) THEN
*
*           sub( Y ) is a row vector
*
            JB = DESCY( INB_ ) - JY + 1
            IF( JB.LE.0 )
     $         JB = ( (-JB ) / DESCY( NB_ ) + 1 ) * DESCY( NB_ ) + JB
            JB = MIN( JB, N )
            JN = JY + JB - 1
*
            DO 140 J = JY, JN
*
               CALL PSERRAXPY( ERR, PSCLR, X( IOFFX ), Y( IOFFY ),
     $                         PREC )
*
               IF( ( MYROW.EQ.ICURROW .OR. ROWREP ) .AND.
     $             ( MYCOL.EQ.ICURCOL .OR. COLREP ) ) THEN
                  IF( ABS( PY( IIY+(JJY-1)*LDY ) - Y( IOFFY ) ).GT.
     $                ERR ) THEN
                     IERR( 2 ) = 1
                  END IF
                  JJY = JJY + 1
               END IF
*
               IOFFX = IOFFX + INCX
               IOFFY = IOFFY + INCY
*
  140       CONTINUE
*
            ICURCOL = MOD( ICURCOL+1, NPCOL )
*
            DO 160 J = JN+1, JY+N-1, DESCY( NB_ )
               JB = MIN( JY+N-J, DESCY( NB_ ) )
*
               DO 150 KK = 0, JB-1
*
                  CALL PSERRAXPY( ERR, PSCLR, X( IOFFX ), Y( IOFFY ),
     $                            PREC )
*
                  IF( ( MYROW.EQ.ICURROW .OR. ROWREP ) .AND.
     $                ( MYCOL.EQ.ICURCOL .OR. COLREP ) ) THEN
                     IF( ABS( PY( IIY+(JJY-1)*LDY ) - Y( IOFFY ) ).GT.
     $                   ERR ) THEN
                        IERR( 2 ) = 1
                     END IF
                     JJY = JJY + 1
                  END IF
*
                  IOFFX = IOFFX + INCX
                  IOFFY = IOFFY + INCY
*
  150          CONTINUE
*
               ICURCOL = MOD( ICURCOL+1, NPCOL )
*
  160       CONTINUE
*
         ELSE
*
*           sub( Y ) is a column vector
*
            IB = DESCY( IMB_ ) - IY + 1
            IF( IB.LE.0 )
     $         IB = ( (-IB ) / DESCY( MB_ ) + 1 ) * DESCY( MB_ ) + IB
            IB = MIN( IB, N )
            IN = IY + IB - 1
*
            DO 170 I = IY, IN
*
               CALL PSERRAXPY( ERR, PSCLR, X( IOFFX ), Y( IOFFY ),
     $                         PREC )
*
               IF( ( MYROW.EQ.ICURROW .OR. ROWREP ) .AND.
     $             ( MYCOL.EQ.ICURCOL .OR. COLREP ) ) THEN
                  IF( ABS( PY( IIY+(JJY-1)*LDY ) - Y( IOFFY ) ).GT.
     $                ERR ) THEN
                     IERR( 2 ) = 1
                  END IF
                  IIY = IIY + 1
               END IF
*
               IOFFX = IOFFX + INCX
               IOFFY = IOFFY + INCY
*
  170       CONTINUE
*
            ICURROW = MOD( ICURROW+1, NPROW )
*
            DO 190 I = IN+1, IY+N-1, DESCY( MB_ )
               IB = MIN( IY+N-I, DESCY( MB_ ) )
*
               DO 180 KK = 0, IB-1
*
                  CALL PSERRAXPY( ERR, PSCLR, X( IOFFX ), Y( IOFFY ),
     $                            PREC )
*
                  IF( ( MYROW.EQ.ICURROW .OR. ROWREP ) .AND.
     $                ( MYCOL.EQ.ICURCOL .OR. COLREP ) ) THEN
                     IF( ABS( PY( IIY+(JJY-1)*LDY ) - Y( IOFFY ) ).GT.
     $                   ERR ) THEN
                        IERR( 2 ) = 1
                     END IF
                     IIY = IIY + 1
                  END IF
*
                  IOFFX = IOFFX + INCX
                  IOFFY = IOFFY + INCY
*
  180          CONTINUE
*
               ICURROW = MOD( ICURROW+1, NPROW )
*
  190       CONTINUE
*
         END IF
*
      ELSE IF( NROUT.EQ.5 ) THEN
*
*        Test PSDOT
*
         CALL PSCHKVIN( ERRMAX, N, X, PX, IX, JX, DESCX, INCX,
     $                  IERR( 1 ) )
         CALL PSCHKVIN( ERRMAX, N, Y, PY, IY, JY, DESCY, INCY,
     $                  IERR( 2 ) )
         IOFFX = IX + ( JX - 1 ) * DESCX( M_ )
         IOFFY = IY + ( JY - 1 ) * DESCY( M_ )
         CALL PSERRDOT( ERR, N, SCLR, X( IOFFX ), INCX, Y( IOFFY ),
     $                  INCY, PREC )
         INXSCOPE = PISINSCOPE( ICTXT, N, IX, JX, DESCX, INCX )
         INYSCOPE = PISINSCOPE( ICTXT, N, IY, JY, DESCY, INCY )
         IF( INXSCOPE.OR.INYSCOPE ) THEN
            IF( ABS( PSCLR - SCLR ).GT.ERR ) THEN
               IERR( 3 ) = 1
               WRITE( ARGIN1, FMT = '(A)' ) 'DOT'
               IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN
                  WRITE( NOUT, FMT = 9998 ) ARGIN1
                  WRITE( NOUT, FMT = 9996 ) SCLR, PSCLR
               END IF
            END IF
         ELSE
            SCLR = ZERO
            IF( PSCLR.NE.SCLR ) THEN
               IERR( 4 ) = 1
               WRITE( ARGOUT1, FMT = '(A)' ) 'DOT'
               IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN
                  WRITE( NOUT, FMT = 9997 ) ARGOUT1
                  WRITE( NOUT, FMT = 9996 ) SCLR, PSCLR
               END IF
            END IF
         END IF
*
      ELSE IF( NROUT.EQ.6 ) THEN
*
*        Test PSNRM2
*
         CALL PSCHKVIN( ERRMAX, N, X, PX, IX, JX, DESCX, INCX,
     $                  IERR( 1 ) )
         IOFFX = IX + ( JX - 1 ) * DESCX( M_ )
         CALL PSERRNRM2( ERR, N, USCLR, X( IOFFX ), INCX, PREC )
         IF( PISINSCOPE( ICTXT, N, IX, JX, DESCX, INCX ) ) THEN
            IF( ABS( PUSCLR - USCLR ).GT.ERR ) THEN
               IERR( 3 ) = 1
               WRITE( ARGIN1, FMT = '(A)' ) 'NRM2'
               IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN
                  WRITE( NOUT, FMT = 9998 ) ARGIN1
                  WRITE( NOUT, FMT = 9996 ) USCLR, PUSCLR
               END IF
            END IF
         ELSE
            USCLR = ZERO
            IF( PUSCLR.NE.USCLR ) THEN
               IERR( 4 ) = 1
               WRITE( ARGOUT1, FMT = '(A)' ) 'NRM2'
               IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN
                  WRITE( NOUT, FMT = 9997 ) ARGOUT1
                  WRITE( NOUT, FMT = 9996 ) USCLR, PUSCLR
               END IF
            END IF
         END IF
*
      ELSE IF( NROUT.EQ.7 ) THEN
*
*        Test PSASUM
*
         CALL PSCHKVIN( ERRMAX, N, X, PX, IX, JX, DESCX, INCX,
     $                  IERR( 1 ) )
         IOFFX = IX + ( JX - 1 ) * DESCX( M_ )
         CALL PSERRASUM( ERR, N, USCLR, X( IOFFX ), INCX, PREC )
         IF( PISINSCOPE( ICTXT, N, IX, JX, DESCX, INCX ) ) THEN
            IF( ABS( PUSCLR - USCLR ) .GT. ERR ) THEN
               IERR( 3 ) = 1
               WRITE( ARGIN1, FMT = '(A)' ) 'ASUM'
               IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN
                  WRITE( NOUT, FMT = 9998 ) ARGIN1
                  WRITE( NOUT, FMT = 9996 ) USCLR, PUSCLR
               END IF
            END IF
         ELSE
            USCLR = ZERO
            IF( PUSCLR.NE.USCLR ) THEN
               IERR( 4 ) = 1
               WRITE( ARGOUT1, FMT = '(A)' ) 'ASUM'
               IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN
                  WRITE( NOUT, FMT = 9997 ) ARGOUT1
                  WRITE( NOUT, FMT = 9996 ) USCLR, PUSCLR
               END IF
            END IF
         END IF
*
      ELSE IF( NROUT.EQ.8 ) THEN
*
*        Test PSAMAX
*
         CALL PSCHKVIN( ERRMAX, N, X, PX, IX, JX, DESCX, INCX,
     $                  IERR( 1 ) )
         IOFFX = IX + ( JX - 1 ) * DESCX( M_ )
         IF( PISINSCOPE( ICTXT, N, IX, JX, DESCX, INCX ) ) THEN
            ISCLR = ISAMAX( N, X( IOFFX ), INCX )
            IF( N.LT.1 ) THEN
               SCLR = ZERO
            ELSE IF( ( INCX.EQ.1 ).AND.( DESCX( M_ ).EQ.1 ).AND.
     $               ( N.EQ.1 ) ) THEN
               ISCLR = JX
               SCLR = X( IOFFX )
            ELSE IF( INCX.EQ.DESCX( M_ ) ) THEN
               ISCLR = JX + ISCLR - 1
               SCLR = X( IX + ( ISCLR - 1 ) * DESCX( M_ ) )
            ELSE
               ISCLR = IX + ISCLR - 1
               SCLR = X( ISCLR + ( JX - 1 ) * DESCX( M_ ) )
            END IF
*
            IF( PSCLR.NE.SCLR ) THEN
               IERR( 3 ) = 1
               WRITE( ARGIN1, FMT = '(A)' ) 'AMAX'
               IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN
                  WRITE( NOUT, FMT = 9998 ) ARGIN1
                  WRITE( NOUT, FMT = 9996 ) SCLR, PSCLR
               END IF
            END IF
*
            IF( PISCLR.NE.ISCLR ) THEN
               IERR( 5 ) = 1
               WRITE( ARGIN2, FMT = '(A)' ) 'INDX'
               IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN
                  WRITE( NOUT, FMT = 9998 ) ARGIN2
                  WRITE( NOUT, FMT = 9995 ) ISCLR, PISCLR
               END IF
            END IF
         ELSE
            ISCLR = 0
            SCLR  = ZERO
            IF( PSCLR.NE.SCLR ) THEN
               IERR( 4 ) = 1
               WRITE( ARGOUT1, FMT = '(A)' ) 'AMAX'
               IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN
                  WRITE( NOUT, FMT = 9997 ) ARGOUT1
                  WRITE( NOUT, FMT = 9996 ) SCLR, PSCLR
               END IF
            END IF
            IF( PISCLR.NE.ISCLR ) THEN
               IERR( 6 ) = 1
               WRITE( ARGOUT2, FMT = '(A)' ) 'INDX'
               IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN
                  WRITE( NOUT, FMT = 9997 ) ARGOUT2
                  WRITE( NOUT, FMT = 9995 ) ISCLR, PISCLR
               END IF
            END IF
         END IF
*
      END IF
*
*     Find IERR across all processes
*
      CALL IGAMX2D( ICTXT, 'All', ' ', 6, 1, IERR, 6, IDUMM, IDUMM, -1,
     $              -1, 0 )
*
*     Encode the errors found in INFO
*
      IF( IERR( 1 ).NE.0 ) THEN
         INFO = INFO + 1
         IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 )
     $      WRITE( NOUT, FMT = 9999 ) 'X'
      END IF
*
      IF( IERR( 2 ).NE.0 ) THEN
         INFO = INFO + 2
         IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 )
     $      WRITE( NOUT, FMT = 9999 ) 'Y'
      END IF
*
      IF( IERR( 3 ).NE.0 )
     $   INFO = INFO + 4
*
      IF( IERR( 4 ).NE.0 )
     $   INFO = INFO + 8
*
      IF( IERR( 5 ).NE.0 )
     $   INFO = INFO + 16
*
      IF( IERR( 6 ).NE.0 )
     $   INFO = INFO + 32
*
 9999 FORMAT( 2X, '   ***** ERROR: Vector operand ', A,
     $        ' is incorrect.' )
 9998 FORMAT( 2X, '   ***** ERROR: Output scalar result ', A,
     $        ' in scope is incorrect.' )
 9997 FORMAT( 2X, '   ***** ERROR: Output scalar result ', A,
     $        ' out of scope is incorrect.' )
 9996 FORMAT( 2X, '   ***** Expected value is: ', E16.8, /2X,
     $        '         Obtained value is: ', E16.8 )
 9995 FORMAT( 2X, '   ***** Expected value is: ', I6, /2X,
     $        '         Obtained value is: ', I6 )
*
      RETURN
*
*     End of PSBLAS1TSTCHK
*
      END
      SUBROUTINE PSERRDOT( ERRBND, N, SCLR, X, INCX, Y, INCY, PREC )
*
*  -- 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            INCX, INCY, N
      REAL               ERRBND, PREC, SCLR
*     ..
*     .. Array Arguments ..
      REAL               X( * ), Y( * )
*     ..
*
*  Purpose
*  =======
*
*  PSERRDOT  serially  computes  the  dot product X**T * Y and returns a
*  scaled relative acceptable error bound on the result.
*
*  Notes
*  =====
*
*  If dot1 = SCLR and  dot2 are two different computed results, and dot1
*  is being assumed to be correct, we require
*
*     abs( dot1 - dot2 ) <= ERRBND = ERRFACT * abs( dot1 ),
*
*  where ERRFACT is computed as the maximum of the positive and negative
*  partial  sums  multiplied  by  a constant proportional to the machine
*  precision.
*
*  Arguments
*  =========
*
*  ERRBND  (global output) REAL
*          On exit, ERRBND  specifies the scaled relative acceptable er-
*          ror bound.
*
*  N       (global input) INTEGER
*          On entry, N specifies the length of the vector operands.
*
*  SCLR    (global output) REAL
*          On exit,  SCLR  specifies  the dot product of the two vectors
*          X and Y.
*
*  X       (global input) REAL array
*          On   entry,   X   is   an   array   of   dimension  at  least
*          ( 1 + ( n - 1 )*abs( INCX ) ).  Before  entry,  the incremen-
*          ted array X must contain the vector x.
*
*  INCX    (global input) INTEGER.
*          On entry, INCX specifies the increment for the elements of X.
*          INCX must not be zero.
*
*  Y       (global input) REAL array
*          On   entry,   Y   is   an   array   of   dimension  at  least
*          ( 1 + ( n - 1 )*abs( INCY ) ).  Before  entry,  the incremen-
*          ted array Y must contain the vector y.
*
*  INCY    (global input) INTEGER.
*          On entry, INCY specifies the increment for the elements of Y.
*          INCY must not be zero.
*
*  PREC    (global input) REAL
*          On entry, PREC specifies the machine precision.
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ONE, TWO, ZERO
      PARAMETER          ( ONE = 1.0E+0, TWO = 2.0E+0,
     $                   ZERO = 0.0E+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, IX, IY
      REAL               ADDBND, FACT, SUMNEG, SUMPOS, TMP
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
*     ..
*     .. Executable Statements ..
*
      IX = 1
      IY = 1
      SCLR = ZERO
      SUMPOS = ZERO
      SUMNEG = ZERO
      FACT = TWO * ( ONE + PREC )
      ADDBND = TWO * TWO * TWO * PREC
*
      DO 10 I = 1, N
         TMP = X( IX ) * Y( IY )
         SCLR = SCLR + TMP
         IF( TMP.GE.ZERO ) THEN
            SUMPOS = SUMPOS + TMP * FACT
         ELSE
            SUMNEG = SUMNEG - TMP * FACT
         END IF
         IX = IX + INCX
         IY = IY + INCY
   10 CONTINUE
*
      ERRBND = ADDBND * MAX( SUMPOS, SUMNEG )
*
      RETURN
*
*     End of PSERRDOT
*
      END
      SUBROUTINE PSERRNRM2( ERRBND, N, USCLR, X, INCX, PREC )
*
*  -- 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            INCX, N
      REAL               ERRBND, PREC, USCLR
*     ..
*     .. Array Arguments ..
      REAL               X( * )
*     ..
*
*  Purpose
*  =======
*
*  PSERRNRM2  serially  computes  the  2-norm the vector X and returns a
*  scaled relative acceptable error bound on the result.
*
*  Notes
*  =====
*
*  If  norm1 = SCLR  and  norm2  are two different computed results, and
*  norm1 being assumed to be correct, we require
*
*     abs( norm1 - norm2 ) <= ERRBND = ERRFACT * abs( norm1 ),
*
*  where ERRFACT is computed as the maximum of the positive and negative
*  partial  sums  multiplied  by  a constant proportional to the machine
*  precision.
*
*  Arguments
*  =========
*
*  ERRBND  (global output) REAL
*          On exit, ERRBND  specifies the scaled relative acceptable er-
*          ror bound.
*
*  N       (global input) INTEGER
*          On entry, N specifies the length of the vector operand.
*
*  USCLR   (global output) REAL
*          On exit, USCLR specifies the 2-norm of the vector X.
*
*  X       (global input) REAL array
*          On   entry,   X   is   an   array   of   dimension  at  least
*          ( 1 + ( n - 1 )*abs( INCX ) ).  Before  entry,  the incremen-
*          ted array X must contain the vector x.
*
*  INCX    (global input) INTEGER.
*          On entry, INCX specifies the increment for the elements of X.
*          INCX must not be zero.
*
*  PREC    (global input) REAL
*          On entry, PREC specifies the machine precision.
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ONE, TWO, ZERO
      PARAMETER          ( ONE = 1.0E+0, TWO = 2.0E+0,
     $                   ZERO = 0.0E+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            IX
      REAL               ABSXI, ADDBND, FACT, SCALE, SSQ, SUMSCA, SUMSSQ
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS
*     ..
*     .. Executable Statements ..
*
      USCLR = ZERO
      SUMSSQ = ONE
      SUMSCA = ZERO
      ADDBND = TWO * TWO * TWO * PREC
      FACT = ONE + TWO * ( ( ONE + PREC )**3 - ONE )
*
      SCALE = ZERO
      SSQ = ONE
      DO 10 IX = 1, 1 + ( N - 1 )*INCX, INCX
         IF( X( IX ).NE.ZERO ) THEN
            ABSXI = ABS( X( IX ) )
            IF( SCALE.LT.ABSXI )THEN
               SUMSSQ = ONE + ( SSQ*( SCALE/ABSXI )**2 ) * FACT
               ERRBND = ADDBND * SUMSSQ
               SUMSSQ = SUMSSQ + ERRBND
               SSQ    = ONE + SSQ*( SCALE/ABSXI )**2
               SUMSCA = ABSXI
               SCALE  = ABSXI
            ELSE
               SUMSSQ = SSQ + ( ( ABSXI/SCALE )**2 ) * FACT
               ERRBND = ADDBND * SUMSSQ
               SUMSSQ = SUMSSQ + ERRBND
               SSQ    = SSQ + ( ABSXI/SCALE )**2
            END IF
         END IF
   10 CONTINUE
*
      USCLR = SCALE * SQRT( SSQ )
*
*     Error on square root
*
      ERRBND = SQRT( SUMSSQ ) * ( ONE + TWO * ( 1.00001E+0 * PREC ) )
*
      ERRBND = ( SUMSCA * ERRBND ) - USCLR
*
      RETURN
*
*     End of PSERRNRM2
*
      END
      SUBROUTINE PSERRASUM( ERRBND, N, USCLR, X, INCX, PREC )
*
*  -- 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            INCX, N
      REAL               ERRBND, PREC, USCLR
*     ..
*     .. Array Arguments ..
      REAL               X( * )
*     ..
*
*  Purpose
*  =======
*
*  PSERRASUM  serially computes the sum of absolute values of the vector
*  X and returns a scaled relative acceptable error bound on the result.
*
*  Arguments
*  =========
*
*  ERRBND  (global output) REAL
*          On exit, ERRBND  specifies a scaled relative acceptable error
*          bound. In this case the error bound is just the absolute  sum
*          multiplied  by  a constant proportional to the machine preci-
*          sion.
*
*  N       (global input) INTEGER
*          On entry, N specifies the length of the vector operand.
*
*  USCLR   (global output) REAL
*          On exit, USCLR  specifies  the  sum of absolute values of the
*          vector X.
*
*  X       (global input) REAL array
*          On   entry,   X   is   an   array   of   dimension  at  least
*          ( 1 + ( n - 1 )*abs( INCX ) ).  Before  entry,  the incremen-
*          ted array X must contain the vector x.
*
*  INCX    (global input) INTEGER.
*          On entry, INCX specifies the increment for the elements of X.
*          INCX must not be zero.
*
*  PREC    (global input) REAL
*          On entry, PREC specifies the machine precision.
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               TWO, ZERO
      PARAMETER          ( TWO = 2.0E+0, ZERO = 0.0E+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            IX
      REAL               ADDBND
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS
*     ..
*     .. Executable Statements ..
*
      IX = 1
      USCLR = ZERO
      ADDBND = TWO * TWO * TWO * PREC
*
      DO 10 IX = 1, 1 + ( N - 1 )*INCX, INCX
         USCLR = USCLR + ABS( X( IX ) )
   10 CONTINUE
*
      ERRBND = ADDBND * USCLR
*
      RETURN
*
*     End of PSERRASUM
*
      END
      SUBROUTINE PSERRSCAL( ERRBND, PSCLR, X, PREC )
*
*  -- PBLAS test routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      REAL               ERRBND, PREC, PSCLR, X
*     ..
*
*  Purpose
*  =======
*
*  PSERRSCAL serially computes the product PSCLR * X and returns a sca-
*  led relative acceptable error bound on the result.
*
*  Notes
*  =====
*
*  If s1 = PSCLR*X and  s2 are two different computed results, and s1 is
*  being assumed to be correct, we require
*
*        abs( s1 - s2 ) <= ERRBND = ERRFACT * abs( s1 ),
*
*  where ERRFACT is computed as two times the machine precision.
*
*  Arguments
*  =========
*
*  ERRBND  (global output) REAL
*          On exit, ERRBND  specifies the scaled relative acceptable er-
*          ror bound.
*
*  PSCLR   (global input) REAL
*          On entry, PSCLR specifies the scale factor.
*
*  X       (global input/global output) REAL
*          On entry, X  specifies the scalar to be scaled. On exit, X is
*          the scaled entry.
*
*  PREC    (global input) REAL
*          On entry, PREC specifies the machine precision.
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               TWO
      PARAMETER          ( TWO = 2.0E+0 )
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS
*     ..
*     .. Executable Statements ..
*
      X = PSCLR * X
*
      ERRBND = ( TWO * PREC ) * ABS( X )
*
      RETURN
*
*     End of PSERRSCAL
*
      END
      SUBROUTINE PSERRAXPY( ERRBND, PSCLR, X, Y, PREC )
*
*  -- PBLAS test routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      REAL               ERRBND, PREC, PSCLR, X, Y
*     ..
*
*  Purpose
*  =======
*
*  PSERRAXPY  serially computes Y := Y + PSCLR * X and returns a scaled
*  relative acceptable error bound on the result.
*
*  Arguments
*  =========
*
*  ERRBND  (global output) REAL
*          On exit, ERRBND  specifies the scaled relative acceptable er-
*          ror bound.
*
*  PSCLR   (global input) REAL
*          On entry, PSCLR specifies the scale factor.
*
*  X       (global input) REAL
*          On entry, X  specifies the scalar to be scaled.
*
*  Y       (global input/global output) REAL
*          On entry, Y specifies the scalar to be added. On exit, Y con-
*          tains the resulting scalar.
*
*  PREC    (global input) REAL
*          On entry, PREC specifies the machine precision.
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ONE, TWO, ZERO
      PARAMETER          ( ONE = 1.0E+0, TWO = 2.0E+0,
     $                   ZERO = 0.0E+0 )
*     ..
*     .. Local Scalars ..
      REAL               ADDBND, FACT, SUMPOS, SUMNEG, TMP
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
      SUMPOS = ZERO
      SUMNEG = ZERO
      FACT = ONE + TWO * PREC
      ADDBND = TWO * TWO * TWO * PREC
*
      TMP = PSCLR * X
      IF( TMP.GE.ZERO ) THEN
         SUMPOS = SUMPOS + TMP * FACT
      ELSE
         SUMNEG = SUMNEG - TMP * FACT
      END IF
*
      TMP = Y
      IF( TMP.GE.ZERO ) THEN
         SUMPOS = SUMPOS + TMP
      ELSE
         SUMNEG = SUMNEG - TMP
      END IF
*
      Y = Y + ( PSCLR * X )
*
      ERRBND = ADDBND * MAX( SUMPOS, SUMNEG )
*
      RETURN
*
*     End of PSERRAXPY
*
      END