dd/d81/psblas2tst_8f_source.html

00001       BLOCK DATA
00002       INTEGER NSUBS
00003       PARAMETER (NSUBS = 7)
00004       CHARACTER*7        SNAMES( NSUBS )
00005       COMMON             /SNAMEC/SNAMES
00006       DATA               SNAMES/'PSGEMV ', 'PSSYMV ', 'PSTRMV ',
00007      $                   'PSTRSV ', 'PSGER  ', 'PSSYR  ',
00008      $                   'PSSYR2 '/
00009       END BLOCK DATA
00010
00011       PROGRAM PSBLA2TST
00012 *
00013 *  -- PBLAS testing driver (version 2.0.2) --
00014 *     Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
00015 *     May 1 2012
00016 *
00017 *  Purpose
00018 *  =======
00019 *
00020 *  PSBLA2TST is the main testing program for the PBLAS Level 2 routines.
00021 *
00022 *  The program must be driven by a short data file.  An  annotated exam-
00023 *  ple of a data file can be obtained by deleting the first 3 characters
00024 *  from the following 60 lines:
00025 *  'Level 2 PBLAS, Testing input file'
00026 *  'Intel iPSC/860 hypercube, gamma model.'
00027 *  'PSBLAS2TST.SUMM'     output file name (if any)
00028 *  6       device out
00029 *  F       logical flag, T to stop on failures
00030 *  F       logical flag, T to test error exits
00031 *  0       verbosity, 0 for pass/fail, 1-3 for matrix dump on errors
00032 *  10      the leading dimension gap
00033 *  16.0    threshold value of test ratio
00034 *  10              value of the logical computational blocksize NB
00035 *  1               number of process grids (ordered pairs of P & Q)
00036 *  2 2 1 4 2 3 8   values of P
00037 *  2 2 4 1 3 2 1   values of Q
00038 *  1.0E0           value of ALPHA
00039 *  1.0E0           value of BETA
00040 *  2               number of tests problems
00041 *  'U' 'L'         values of UPLO
00042 *  'N' 'T'         values of TRANS
00043 *  'N' 'U'         values of DIAG
00044 *  3  4            values of M
00045 *  3  4            values of N
00046 *  6 10            values of M_A
00047 *  6 10            values of N_A
00048 *  2  5            values of IMB_A
00049 *  2  5            values of INB_A
00050 *  2  5            values of MB_A
00051 *  2  5            values of NB_A
00052 *  0  1            values of RSRC_A
00053 *  0  0            values of CSRC_A
00054 *  1  1            values of IA
00055 *  1  1            values of JA
00056 *  6 10            values of M_X
00057 *  6 10            values of N_X
00058 *  2  5            values of IMB_X
00059 *  2  5            values of INB_X
00060 *  2  5            values of MB_X
00061 *  2  5            values of NB_X
00062 *  0  1            values of RSRC_X
00063 *  0  0            values of CSRC_X
00064 *  1  1            values of IX
00065 *  1  1            values of JX
00066 *  1  1            values of INCX
00067 *  6 10            values of M_Y
00068 *  6 10            values of N_Y
00069 *  2  5            values of IMB_Y
00070 *  2  5            values of INB_Y
00071 *  2  5            values of MB_Y
00072 *  2  5            values of NB_Y
00073 *  0  1            values of RSRC_Y
00074 *  0  0            values of CSRC_Y
00075 *  1  1            values of IY
00076 *  1  1            values of JY
00077 *  6  1            values of INCY
00078 *  PSGEMV  T  put F for no test in the same column
00079 *  PSSYMV  T  put F for no test in the same column
00080 *  PSTRMV  T  put F for no test in the same column
00081 *  PSTRSV  T  put F for no test in the same column
00082 *  PSGER   T  put F for no test in the same column
00083 *  PSSYR   T  put F for no test in the same column
00084 *  PSSYR2  T  put F for no test in the same column
00085 *
00086 *  Internal Parameters
00087 *  ===================
00088 *
00089 *  TOTMEM  INTEGER
00090 *          TOTMEM  is  a machine-specific parameter indicating the maxi-
00091 *          mum  amount  of  available  memory per  process in bytes. The
00092 *          user  should  customize TOTMEM to his  platform.  Remember to
00093 *          leave  room  in  memory  for the  operating system, the BLACS
00094 *          buffer, etc.  For  example,  on  a system with 8 MB of memory
00095 *          per process (e.g., one processor  on an Intel iPSC/860),  the
00096 *          parameters we use are TOTMEM=6200000  (leaving 1.8 MB for OS,
00097 *          code, BLACS buffer, etc).  However,  for PVM,  we usually set
00098 *          TOTMEM = 2000000.  Some experimenting  with the maximum value
00099 *          of TOTMEM may be required. By default, TOTMEM is 2000000.
00100 *
00101 *  REALSZ  INTEGER
00102 *          REALSZ  indicates  the  length in bytes on the given platform
00103 *          for  a  single  precision  real. By default, REALSZ is set to
00104 *          four.
00105 *
00106 *  MEM     REAL array
00107 *          MEM is an array of dimension TOTMEM / REALSZ.
00108 *          All arrays used by SCALAPACK routines are allocated from this
00109 *          array MEM and referenced by pointers. The  integer  IPA,  for
00110 *          example, is a pointer to the starting element of MEM for  the
00111 *          matrix A.
00112 *
00113 *  -- Written on April 1, 1998 by
00114 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
00115 *
00116 *  =====================================================================
00117 *
00118 *     .. Parameters ..
00119       INTEGER            MAXTESTS, MAXGRIDS, GAPMUL, REALSZ, TOTMEM,
00120      $                   MEMSIZ, NSUBS
00121       REAL               ONE, PADVAL, ZERO, ROGUE
00122       PARAMETER          ( MAXTESTS = 20, MAXGRIDS = 20, GAPMUL = 10,
00123      $                   REALSZ = 4, TOTMEM = 2000000,
00124      $                   MEMSIZ = TOTMEM / REALSZ, ZERO = 0.0E+0,
00125      $                   ONE = 1.0E+0, PADVAL = -9923.0E+0,
00126      $                   NSUBS = 7, ROGUE = -1.0E+10 )
00127       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
00128      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
00129      $                   RSRC_
00130       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
00131      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
00132      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
00133      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
00134 *     ..
00135 *     .. Local Scalars ..
00136       LOGICAL            ERRFLG, SOF, TEE
00137       CHARACTER*1        AFORM, DIAG, DIAGDO, TRANS, UPLO
00138       INTEGER            CSRCA, CSRCX, CSRCY, I, IA, IAM, IASEED, ICTXT,
00139      $                   IGAP, IMBA, IMBX, IMBY, IMIDA, IMIDX, IMIDY,
00140      $                   INBA, INBX, INBY, INCX, INCY, IPA, IPG, IPMATA,
00141      $                   IPMATX, IPMATY, IPOSTA, IPOSTX, IPOSTY, IPREA,
00142      $                   IPREX, IPREY, IPX, IPY, IVERB, IX, IXSEED, IY,
00143      $                   IYSEED, J, JA, JX, JY, K, LDA, LDX, LDY, M, MA,
00144      $                   MBA, MBX, MBY, MEMREQD, MPA, MPX, MPY, MX, MY,
00145      $                   MYCOL, MYROW, N, NA, NBA, NBX, NBY, NCOLA,
00146      $                   NGRIDS, NLX, NLY, NOUT, NPCOL, NPROCS, NPROW,
00147      $                   NQA, NQX, NQY, NROWA, NTESTS, NX, NY, OFFD,
00148      $                   RSRCA, RSRCX, RSRCY, TSKIP, TSTCNT
00149       REAL               ALPHA, BETA, SCALE, THRESH
00150 *     ..
00151 *     .. Local Arrays ..
00152       LOGICAL            LTEST( NSUBS ), YCHECK( NSUBS )
00153       CHARACTER*1        DIAGVAL( MAXTESTS ), TRANVAL( MAXTESTS ),
00154      $                   UPLOVAL( MAXTESTS )
00155       CHARACTER*80       OUTFILE
00156       INTEGER            CSCAVAL( MAXTESTS ), CSCXVAL( MAXTESTS ),
00157      $                   CSCYVAL( MAXTESTS ), DESCA( DLEN_ ),
00158      $                   DESCAR( DLEN_ ), DESCX( DLEN_ ),
00159      $                   DESCXR( DLEN_ ), DESCY( DLEN_ ),
00160      $                   DESCYR( DLEN_ ), IAVAL( MAXTESTS ), IERR( 6 ),
00161      $                   IMBAVAL( MAXTESTS ), IMBXVAL( MAXTESTS ),
00162      $                   IMBYVAL( MAXTESTS ), INBAVAL( MAXTESTS ),
00163      $                   INBXVAL( MAXTESTS ), INBYVAL( MAXTESTS ),
00164      $                   INCXVAL( MAXTESTS ), INCYVAL( MAXTESTS ),
00165      $                   IXVAL( MAXTESTS ), IYVAL( MAXTESTS ),
00166      $                   JAVAL( MAXTESTS ), JXVAL( MAXTESTS ),
00167      $                   JYVAL( MAXTESTS )
00168       INTEGER            KFAIL( NSUBS ), KPASS( NSUBS ), KSKIP( NSUBS ),
00169      $                   KTESTS( NSUBS ), MAVAL( MAXTESTS ),
00170      $                   MBAVAL( MAXTESTS ), MBXVAL( MAXTESTS ),
00171      $                   MBYVAL( MAXTESTS ), MVAL( MAXTESTS ),
00172      $                   MXVAL( MAXTESTS ), MYVAL( MAXTESTS ),
00173      $                   NAVAL( MAXTESTS ), NBAVAL( MAXTESTS ),
00174      $                   NBXVAL( MAXTESTS ), NBYVAL( MAXTESTS ),
00175      $                   NVAL( MAXTESTS ), NXVAL( MAXTESTS ),
00176      $                   NYVAL( MAXTESTS ), PVAL( MAXTESTS ),
00177      $                   QVAL( MAXTESTS ), RSCAVAL( MAXTESTS ),
00178      $                   RSCXVAL( MAXTESTS ), RSCYVAL( MAXTESTS )
00179       REAL               MEM( MEMSIZ )
00180 *     ..
00181 *     .. External Subroutines ..
00182       EXTERNAL           BLACS_EXIT, BLACS_GET, BLACS_GRIDEXIT,
00183      $                   BLACS_GRIDINFO, BLACS_GRIDINIT, BLACS_PINFO,
00184      $                   IGSUM2D, PB_DESCSET2, PB_PSLAPRNT, PB_SCHEKPAD,
00185      $                   PB_SFILLPAD, PB_SLASCAL, PB_SLASET, PMDESCCHK,
00186      $                   PMDIMCHK, PSBLA2TSTINFO, PSBLAS2TSTCHK,
00187      $                   PSBLAS2TSTCHKE, PSCHKARG2, PSCHKVOUT, PSGEMV,
00188      $                   PSGER, PSLAGEN, PSLASCAL, PSLASET, PSMPRNT,
00189      $                   PSSYMV, PSSYR, PSSYR2, PSTRMV, PSTRSV, PSVPRNT,
00190      $                   PVDESCCHK, PVDIMCHK
00191 *     ..
00192 *     .. External Functions ..
00193       LOGICAL            LSAME
00194       EXTERNAL           LSAME
00195 *     ..
00196 *     .. Intrinsic Functions ..
00197       INTRINSIC          ABS, MAX, MOD, REAL
00198 *     ..
00199 *     .. Common Blocks ..
00200       CHARACTER*7        SNAMES( NSUBS )
00201       LOGICAL            ABRTFLG
00202       INTEGER            INFO, NBLOG
00203       COMMON             /SNAMEC/SNAMES
00204       COMMON             /INFOC/INFO, NBLOG
00205       COMMON             /PBERRORC/NOUT, ABRTFLG
00206 *     ..
00207 *     .. Data Statements ..
00208       DATA               YCHECK/.TRUE., .TRUE., .FALSE., .FALSE.,
00209      $                   .TRUE., .FALSE., .TRUE./
00210 *     ..
00211 *     .. Executable Statements ..
00212 *
00213 *     Initialization
00214 *
00215 *     Set flag so that the PBLAS error handler won't abort on errors, so
00216 *     that the tester will detect unsupported operations.
00217 *
00218       ABRTFLG = .FALSE.
00219 *
00220 *     So far no error, will become true as soon as one error is found.
00221 *
00222       ERRFLG = .FALSE.
00223 *
00224 *     Test counters
00225 *
00226       TSKIP  = 0
00227       TSTCNT = 0
00228 *
00229 *     Seeds for random matrix generations.
00230 *
00231       IASEED = 100
00232       IXSEED = 200
00233       IYSEED = 300
00234 *
00235 *     So far no tests have been performed.
00236 *
00237       DO 10 I = 1, NSUBS
00238          KPASS( I )  = 0
00239          KSKIP( I )  = 0
00240          KFAIL( I )  = 0
00241          KTESTS( I ) = 0
00242    10 CONTINUE
00243 *
00244 *     Get starting information
00245 *
00246       CALL BLACS_PINFO( IAM, NPROCS )
00247       CALL PSBLA2TSTINFO( OUTFILE, NOUT, NTESTS, DIAGVAL, TRANVAL,
00248      $                    UPLOVAL, MVAL, NVAL, MAVAL, NAVAL, IMBAVAL,
00249      $                    MBAVAL, INBAVAL, NBAVAL, RSCAVAL, CSCAVAL,
00250      $                    IAVAL, JAVAL, MXVAL, NXVAL, IMBXVAL, MBXVAL,
00251      $                    INBXVAL, NBXVAL, RSCXVAL, CSCXVAL, IXVAL,
00252      $                    JXVAL, INCXVAL, MYVAL, NYVAL, IMBYVAL,
00253      $                    MBYVAL, INBYVAL, NBYVAL, RSCYVAL, CSCYVAL,
00254      $                    IYVAL, JYVAL, INCYVAL, MAXTESTS, NGRIDS,
00255      $                    PVAL, MAXGRIDS, QVAL, MAXGRIDS, NBLOG, LTEST,
00256      $                    SOF, TEE, IAM, IGAP, IVERB, NPROCS, THRESH,
00257      $                    ALPHA, BETA, MEM )
00258 *
00259       IF( IAM.EQ.0 ) THEN
00260          WRITE( NOUT, FMT = 9975 )
00261          WRITE( NOUT, FMT = * )
00262       END IF
00263 *
00264 *     If TEE is set then Test Error Exits of routines.
00265 *
00266       IF( TEE )
00267      $   CALL PSBLAS2TSTCHKE( LTEST, NOUT, NPROCS )
00268 *
00269 *     Loop over different process grids
00270 *
00271       DO 60 I = 1, NGRIDS
00272 *
00273          NPROW = PVAL( I )
00274          NPCOL = QVAL( I )
00275 *
00276 *        Make sure grid information is correct
00277 *
00278          IERR( 1 ) = 0
00279          IF( NPROW.LT.1 ) THEN
00280             IF( IAM.EQ.0 )
00281      $         WRITE( NOUT, FMT = 9999 ) 'GRID SIZE', 'NPROW', NPROW
00282             IERR( 1 ) = 1
00283          ELSE IF( NPCOL.LT.1 ) THEN
00284             IF( IAM.EQ.0 )
00285      $         WRITE( NOUT, FMT = 9999 ) 'GRID SIZE', 'NPCOL', NPCOL
00286             IERR( 1 ) = 1
00287          ELSE IF( NPROW*NPCOL.GT.NPROCS ) THEN
00288             IF( IAM.EQ.0 )
00289      $         WRITE( NOUT, FMT = 9998 ) NPROW*NPCOL, NPROCS
00290             IERR( 1 ) = 1
00291          END IF
00292 *
00293          IF( IERR( 1 ).GT.0 ) THEN
00294             IF( IAM.EQ.0 )
00295      $         WRITE( NOUT, FMT = 9997 ) 'GRID'
00296             TSKIP = TSKIP + 1
00297             GO TO 60
00298          END IF
00299 *
00300 *        Define process grid
00301 *
00302          CALL BLACS_GET( -1, 0, ICTXT )
00303          CALL BLACS_GRIDINIT( ICTXT, 'Row-major', NPROW, NPCOL )
00304          CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
00305 *
00306 *        Go to bottom of process grid loop if this case doesn't use my
00307 *        process
00308 *
00309          IF( MYROW.GE.NPROW .OR. MYCOL.GE.NPCOL )
00310      $      GO TO 60
00311 *
00312 *        Loop over number of tests
00313 *
00314          DO 50 J = 1, NTESTS
00315 *
00316 *           Get the test parameters
00317 *
00318             DIAG  = DIAGVAL( J )
00319             TRANS = TRANVAL( J )
00320             UPLO  = UPLOVAL( J )
00321 *
00322             M     = MVAL( J )
00323             N     = NVAL( J )
00324 *
00325             MA    = MAVAL( J )
00326             NA    = NAVAL( J )
00327             IMBA  = IMBAVAL( J )
00328             INBA  = INBAVAL( J )
00329             MBA   = MBAVAL( J )
00330             NBA   = NBAVAL( J )
00331             RSRCA = RSCAVAL( J )
00332             CSRCA = CSCAVAL( J )
00333             IA    = IAVAL( J )
00334             JA    = JAVAL( J )
00335 *
00336             MX    = MXVAL( J )
00337             NX    = NXVAL( J )
00338             IMBX  = IMBXVAL( J )
00339             INBX  = INBXVAL( J )
00340             MBX   = MBXVAL( J )
00341             NBX   = NBXVAL( J )
00342             RSRCX = RSCXVAL( J )
00343             CSRCX = CSCXVAL( J )
00344             IX    = IXVAL( J )
00345             JX    = JXVAL( J )
00346             INCX  = INCXVAL( J )
00347 *
00348             MY    = MYVAL( J )
00349             NY    = NYVAL( J )
00350             IMBY  = IMBYVAL( J )
00351             INBY  = INBYVAL( J )
00352             MBY   = MBYVAL( J )
00353             NBY   = NBYVAL( J )
00354             RSRCY = RSCYVAL( J )
00355             CSRCY = CSCYVAL( J )
00356             IY    = IYVAL( J )
00357             JY    = JYVAL( J )
00358             INCY  = INCYVAL( J )
00359 *
00360             IF( IAM.EQ.0 ) THEN
00361                TSTCNT = TSTCNT + 1
00362                WRITE( NOUT, FMT = * )
00363                WRITE( NOUT, FMT = 9996 ) TSTCNT, NPROW, NPCOL
00364                WRITE( NOUT, FMT = * )
00365 *
00366                WRITE( NOUT, FMT = 9995 )
00367                WRITE( NOUT, FMT = 9994 )
00368                WRITE( NOUT, FMT = 9995 )
00369                WRITE( NOUT, FMT = 9993 ) M, N, UPLO, TRANS, DIAG
00370 *
00371                WRITE( NOUT, FMT = 9995 )
00372                WRITE( NOUT, FMT = 9992 )
00373                WRITE( NOUT, FMT = 9995 )
00374                WRITE( NOUT, FMT = 9991 ) IA, JA, MA, NA, IMBA, INBA,
00375      $                                   MBA, NBA, RSRCA, CSRCA
00376 *
00377                WRITE( NOUT, FMT = 9995 )
00378                WRITE( NOUT, FMT = 9990 )
00379                WRITE( NOUT, FMT = 9995 )
00380                WRITE( NOUT, FMT = 9989 ) IX, JX, MX, NX, IMBX, INBX,
00381      $                                   MBX, NBX, RSRCX, CSRCX, INCX
00382 *
00383                WRITE( NOUT, FMT = 9995 )
00384                WRITE( NOUT, FMT = 9988 )
00385                WRITE( NOUT, FMT = 9995 )
00386                WRITE( NOUT, FMT = 9989 ) IY, JY, MY, NY, IMBY, INBY,
00387      $                                   MBY, NBY, RSRCY, CSRCY, INCY
00388 *
00389                WRITE( NOUT, FMT = 9995 )
00390 *
00391             END IF
00392 *
00393 *           Check the validity of the input test parameters
00394 *
00395             IF( .NOT.LSAME( UPLO, 'U' ).AND.
00396      $          .NOT.LSAME( UPLO, 'L' ) ) THEN
00397                IF( IAM.EQ.0 )
00398      $            WRITE( NOUT, FMT = 9997 ) 'UPLO'
00399                TSKIP = TSKIP + 1
00400                GO TO 40
00401             END IF
00402 *
00403             IF( .NOT.LSAME( TRANS, 'N' ).AND.
00404      $          .NOT.LSAME( TRANS, 'T' ).AND.
00405      $          .NOT.LSAME( TRANS, 'C' ) ) THEN
00406                IF( IAM.EQ.0 )
00407      $            WRITE( NOUT, FMT = 9997 ) 'TRANS'
00408                TSKIP = TSKIP + 1
00409                GO TO 40
00410             END IF
00411 *
00412             IF( .NOT.LSAME( DIAG , 'U' ).AND.
00413      $         .NOT.LSAME( DIAG , 'N' ) )THEN
00414                IF( IAM.EQ.0 )
00415      $            WRITE( NOUT, FMT = 9997 ) TRANS
00416                WRITE( NOUT, FMT = 9997 ) 'DIAG'
00417                TSKIP = TSKIP + 1
00418                GO TO 40
00419             END IF
00420 *
00421 *           Check and initialize the matrix descriptors
00422 *
00423             CALL PMDESCCHK( ICTXT, NOUT, 'A', DESCA,
00424      $                      BLOCK_CYCLIC_2D_INB, MA, NA, IMBA, INBA,
00425      $                      MBA, NBA, RSRCA, CSRCA, MPA, NQA, IPREA,
00426      $                      IMIDA, IPOSTA, IGAP, GAPMUL, IERR( 1 ) )
00427             CALL PVDESCCHK( ICTXT, NOUT, 'X', DESCX,
00428      $                      BLOCK_CYCLIC_2D_INB, MX, NX, IMBX, INBX,
00429      $                      MBX, NBX, RSRCX, CSRCX, INCX, MPX, NQX,
00430      $                      IPREX, IMIDX, IPOSTX, IGAP, GAPMUL,
00431      $                      IERR( 2 ) )
00432             CALL PVDESCCHK( ICTXT, NOUT, 'Y', DESCY,
00433      $                      BLOCK_CYCLIC_2D_INB, MY, NY, IMBY, INBY,
00434      $                      MBY, NBY, RSRCY, CSRCY, INCY, MPY, NQY,
00435      $                      IPREY, IMIDY, IPOSTY, IGAP, GAPMUL,
00436      $                      IERR( 3 ) )
00437 *
00438             IF( IERR( 1 ).GT.0 .OR. IERR( 2 ).GT.0 .OR.
00439      $          IERR( 3 ).GT.0 ) THEN
00440                TSKIP = TSKIP + 1
00441                GO TO 40
00442             END IF
00443 *
00444             LDA = MAX( 1, MA )
00445             LDX = MAX( 1, MX )
00446             LDY = MAX( 1, MY )
00447 *
00448 *           Assign pointers into MEM for matrices corresponding to
00449 *           the distributed matrices A, X and Y.
00450 *
00451             IPA = IPREA + 1
00452             IPX = IPA + DESCA( LLD_ )*NQA + IPOSTA + IPREX
00453             IPY = IPX + DESCX( LLD_ )*NQX + IPOSTX + IPREY
00454             IPMATA = IPY + DESCY( LLD_ )*NQY + IPOSTY
00455             IPMATX = IPMATA + MA*NA
00456             IPMATY = IPMATX + MX*NX
00457             IPG = IPMATY + MAX( MX*NX, MY*NY )
00458 *
00459 *           Check if sufficient memory.
00460 *           Requirement = mem for local part of parallel matrices +
00461 *                         mem for whole matrices for comp. check +
00462 *                         mem for recving comp. check error vals.
00463 *
00464             MEMREQD = IPG + MAX( M, N ) - 1 +
00465      $                MAX( MAX( IMBA, MBA ),
00466      $                     MAX( MAX( IMBX, MBX ),
00467      $                          MAX( IMBY, MBY ) ) )
00468             IERR( 1 ) = 0
00469             IF( MEMREQD.GT.MEMSIZ ) THEN
00470                IF( IAM.EQ.0 )
00471      $            WRITE( NOUT, FMT = 9986 ) MEMREQD*REALSZ
00472                IERR( 1 ) = 1
00473             END IF
00474 *
00475 *           Check all processes for an error
00476 *
00477             CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, 0 )
00478 *
00479             IF( IERR( 1 ).GT.0 ) THEN
00480                IF( IAM.EQ.0 )
00481      $            WRITE( NOUT, FMT = 9987 )
00482                TSKIP = TSKIP + 1
00483                GO TO 40
00484             END IF
00485 *
00486 *           Loop over all PBLAS 2 routines
00487 *
00488             DO 30 K = 1, NSUBS
00489 *
00490 *              Continue only if this subroutine has to be tested.
00491 *
00492                IF( .NOT.LTEST( K ) )
00493      $            GO TO 30
00494 *
00495                IF( IAM.EQ.0 ) THEN
00496                   WRITE( NOUT, FMT = * )
00497                   WRITE( NOUT, FMT = 9985 ) SNAMES( K )
00498                END IF
00499 *
00500 *              Define the size of the operands
00501 *
00502                IF( K.EQ.1 ) THEN
00503                   NROWA = M
00504                   NCOLA = N
00505                   IF( LSAME( TRANS, 'N' ) ) THEN
00506                      NLX = N
00507                      NLY = M
00508                   ELSE
00509                      NLX = M
00510                      NLY = N
00511                   END IF
00512                ELSE IF( K.EQ.5 ) THEN
00513                   NROWA = M
00514                   NCOLA = N
00515                   NLX = M
00516                   NLY = N
00517                ELSE
00518                   NROWA = N
00519                   NCOLA = N
00520                   NLX = N
00521                   NLY = N
00522                END IF
00523 *
00524 *              Check the validity of the operand sizes
00525 *
00526                CALL PMDIMCHK( ICTXT, NOUT, NROWA, NCOLA, 'A', IA, JA,
00527      $                        DESCA, IERR( 1 ) )
00528                CALL PVDIMCHK( ICTXT, NOUT, NLX, 'X', IX, JX, DESCX,
00529      $                        INCX, IERR( 2 ) )
00530                CALL PVDIMCHK( ICTXT, NOUT, NLY, 'Y', IY, JY, DESCY,
00531      $                        INCY, IERR( 3 ) )
00532 *
00533                IF( IERR( 1 ).NE.0 .OR. IERR( 2 ).NE.0 .OR.
00534      $             IERR( 3 ).NE.0 ) THEN
00535                   KSKIP( K ) = KSKIP( K ) + 1
00536                   GO TO 30
00537                END IF
00538 *
00539 *              Generate distributed matrices A, X and Y
00540 *
00541                IF( K.EQ.2 .OR. K.EQ.6 .OR. K.EQ.7 ) THEN
00542                   AFORM  = 'S'
00543                   DIAGDO = 'N'
00544                   OFFD   = IA - JA
00545                ELSE IF( ( K.EQ.4 ).AND.( LSAME( DIAG, 'N' ) ) ) THEN
00546                   AFORM  = 'N'
00547                   DIAGDO = 'D'
00548                   OFFD   = IA - JA
00549                ELSE
00550                   AFORM  = 'N'
00551                   DIAGDO = 'N'
00552                   OFFD   = 0
00553                END IF
00554 *
00555                CALL PSLAGEN( .FALSE., AFORM, DIAGDO, OFFD, MA, NA,
00556      $                       1, 1, DESCA, IASEED, MEM( IPA ),
00557      $                       DESCA( LLD_ ) )
00558                CALL PSLAGEN( .FALSE., 'None', 'No diag', 0, MX, NX, 1,
00559      $                       1, DESCX, IXSEED, MEM( IPX ),
00560      $                       DESCX( LLD_ ) )
00561                IF( YCHECK( K ) )
00562      $            CALL PSLAGEN( .FALSE., 'None', 'No diag', 0, MY, NY,
00563      $                          1, 1, DESCY, IYSEED, MEM( IPY ),
00564      $                          DESCY( LLD_ ) )
00565 *
00566 *              Generate entire matrices on each process.
00567 *
00568                CALL PB_DESCSET2( DESCAR, MA, NA, IMBA, INBA, MBA, NBA,
00569      $                           -1, -1, ICTXT, MAX( 1, MA ) )
00570                CALL PSLAGEN( .FALSE., AFORM, DIAGDO, OFFD, MA, NA,
00571      $                       1, 1, DESCAR, IASEED, MEM( IPMATA ),
00572      $                       DESCAR( LLD_ ) )
00573                CALL PB_DESCSET2( DESCXR, MX, NX, IMBX, INBX, MBX, NBX,
00574      $                           -1, -1, ICTXT, MAX( 1, MX ) )
00575                CALL PSLAGEN( .FALSE., 'None', 'No diag', 0, MX, NX, 1,
00576      $                       1, DESCXR, IXSEED, MEM( IPMATX ),
00577      $                       DESCXR( LLD_ ) )
00578                IF( YCHECK( K ) ) THEN
00579 *
00580                   CALL PB_DESCSET2( DESCYR, MY, NY, IMBY, INBY, MBY,
00581      $                              NBY, -1, -1, ICTXT, MAX( 1, MY ) )
00582                   CALL PSLAGEN( .FALSE., 'None', 'No diag', 0, MY, NY,
00583      $                          1, 1, DESCYR, IYSEED, MEM( IPMATY ),
00584      $                          DESCYR( LLD_ ) )
00585 *
00586                ELSE
00587 *
00588 *                 If Y is not needed, generate a copy of X instead
00589 *
00590                   CALL PB_DESCSET2( DESCYR, MX, NX, IMBX, INBX, MBX,
00591      $                              NBX, -1, -1, ICTXT, MAX( 1, MX ) )
00592                   CALL PSLAGEN( .FALSE., 'None', 'No diag', 0, MX, NX,
00593      $                          1, 1, DESCYR, IXSEED, MEM( IPMATY ),
00594      $                          DESCYR( LLD_ ) )
00595 *
00596                END IF
00597 *
00598 *              Zero non referenced part of the matrices A
00599 *
00600                IF( ( K.EQ.2 .OR. K.EQ.6 .OR. K.EQ.7 ).AND.
00601      $             ( MAX( NROWA, NCOLA ).GT.1 ) ) THEN
00602 *
00603 *                 The distributed matrix A is symmetric
00604 *
00605                   IF( LSAME( UPLO, 'L' ) ) THEN
00606 *
00607 *                    Zeros the strict upper triangular part of A.
00608 *
00609                      CALL PSLASET( 'Upper', NROWA-1, NCOLA-1, ROGUE,
00610      $                             ROGUE, MEM( IPA ), IA, JA+1, DESCA )
00611                      IF( K.NE.2 ) THEN
00612                         CALL PB_SLASET( 'Upper', NROWA-1, NCOLA-1, 0,
00613      $                                  ROGUE, ROGUE,
00614      $                                  MEM( IPMATA+IA-1+JA*LDA ), LDA )
00615                      END IF
00616 *
00617                   ELSE IF( LSAME( UPLO, 'U' ) ) THEN
00618 *
00619 *                    Zeros the strict lower triangular part of A.
00620 *
00621                      CALL PSLASET( 'Lower', NROWA-1, NCOLA-1, ROGUE,
00622      $                             ROGUE, MEM( IPA ), IA+1, JA, DESCA )
00623                      IF( K.NE.2 ) THEN
00624                         CALL PB_SLASET( 'Lower', NROWA-1, NCOLA-1, 0,
00625      $                                  ROGUE, ROGUE,
00626      $                                  MEM( IPMATA+IA+(JA-1)*LDA ),
00627      $                                  LDA )
00628                      END IF
00629 *
00630                   END IF
00631 *
00632                ELSE IF( K.EQ.3 .OR. K.EQ.4 ) THEN
00633 *
00634                   IF( LSAME( UPLO, 'L' ) ) THEN
00635 *
00636 *                    The distributed matrix A is lower triangular
00637 *
00638                      IF( LSAME( DIAG, 'N' ) ) THEN
00639 *
00640                         IF( MAX( NROWA, NCOLA ).GT.1 ) THEN
00641                            CALL PSLASET( 'Upper', NROWA-1, NCOLA-1,
00642      $                                   ROGUE, ROGUE, MEM( IPA ), IA,
00643      $                                   JA+1, DESCA )
00644                            CALL PB_SLASET( 'Upper', NROWA-1, NCOLA-1, 0,
00645      $                                     ZERO, ZERO,
00646      $                                     MEM( IPMATA+IA-1+JA*LDA ),
00647      $                                     LDA )
00648                         END IF
00649 *
00650                      ELSE
00651 *
00652                         CALL PSLASET( 'Upper', NROWA, NCOLA, ROGUE, ONE,
00653      $                                MEM( IPA ), IA, JA, DESCA )
00654                         CALL PB_SLASET( 'Upper', NROWA, NCOLA, 0, ZERO,
00655      $                                  ONE,
00656      $                                  MEM( IPMATA+IA-1+(JA-1)*LDA ),
00657      $                                  LDA )
00658                         IF( ( K.EQ.4 ).AND.
00659      $                      ( MAX( NROWA, NCOLA ).GT.1 ) ) THEN
00660                            SCALE = ONE / REAL( MAX( NROWA, NCOLA ) )
00661                            CALL PSLASCAL( 'Lower', NROWA-1, NCOLA-1,
00662      $                                    SCALE, MEM( IPA ), IA+1, JA,
00663      $                                    DESCA )
00664                            CALL PB_SLASCAL( 'Lower', NROWA-1, NCOLA-1,
00665      $                                  0, SCALE,
00666      $                                  MEM( IPMATA+IA+(JA-1)*LDA ),
00667      $                                  LDA )
00668                         END IF
00669 *
00670                      END IF
00671 *
00672                   ELSE IF( LSAME( UPLO, 'U' ) ) THEN
00673 *
00674 *                    The distributed matrix A is upper triangular
00675 *
00676                      IF( LSAME( DIAG, 'N' ) ) THEN
00677 *
00678                         IF( MAX( NROWA, NCOLA ).GT.1 ) THEN
00679                            CALL PSLASET( 'Lower', NROWA-1, NCOLA-1,
00680      $                                   ROGUE, ROGUE, MEM( IPA ), IA+1,
00681      $                                   JA, DESCA )
00682                            CALL PB_SLASET( 'Lower', NROWA-1, NCOLA-1, 0,
00683      $                                     ZERO, ZERO,
00684      $                                     MEM( IPMATA+IA+(JA-1)*LDA ),
00685      $                                     LDA )
00686                         END IF
00687 *
00688                      ELSE
00689 *
00690                         CALL PSLASET( 'Lower', NROWA, NCOLA, ROGUE, ONE,
00691      $                                MEM( IPA ), IA, JA, DESCA )
00692                         CALL PB_SLASET( 'Lower', NROWA, NCOLA, 0, ZERO,
00693      $                                  ONE,
00694      $                                  MEM( IPMATA+IA-1+(JA-1)*LDA ),
00695      $                                  LDA )
00696                         IF( ( K.EQ.4 ).AND.
00697      $                      ( MAX( NROWA, NCOLA ).GT.1 ) ) THEN
00698                            SCALE = ONE / REAL( MAX( NROWA, NCOLA ) )
00699                            CALL PSLASCAL( 'Upper', NROWA-1, NCOLA-1,
00700      $                                    SCALE, MEM( IPA ), IA, JA+1,
00701      $                                    DESCA )
00702                            CALL PB_SLASCAL( 'Upper', NROWA-1, NCOLA-1,
00703      $                                  0, SCALE,
00704      $                                  MEM( IPMATA+IA-1+JA*LDA ), LDA )
00705                         END IF
00706 *
00707                      END IF
00708 *
00709                   END IF
00710 *
00711                END IF
00712 *
00713 *              Pad the guard zones of A, X and Y
00714 *
00715                CALL PB_SFILLPAD( ICTXT, MPA, NQA, MEM( IPA-IPREA ),
00716      $                           DESCA( LLD_ ), IPREA, IPOSTA, PADVAL )
00717 *
00718                CALL PB_SFILLPAD( ICTXT, MPX, NQX, MEM( IPX-IPREX ),
00719      $                           DESCX( LLD_ ), IPREX, IPOSTX, PADVAL )
00720 *
00721                IF( YCHECK( K ) ) THEN
00722                   CALL PB_SFILLPAD( ICTXT, MPY, NQY, MEM( IPY-IPREY ),
00723      $                              DESCY( LLD_ ), IPREY, IPOSTY,
00724      $                              PADVAL )
00725                END IF
00726 *
00727 *              Initialize the check for INPUT-only arguments.
00728 *
00729                INFO = 0
00730                CALL PSCHKARG2( ICTXT, NOUT, SNAMES( K ), UPLO, TRANS,
00731      $                         DIAG, M, N, ALPHA, IA, JA, DESCA, IX,
00732      $                         JX, DESCX, INCX, BETA, IY, JY, DESCY,
00733      $                         INCY, INFO )
00734 *
00735 *              Print initial parallel data if IVERB >= 2.
00736 *
00737                IF( IVERB.EQ.2 ) THEN
00738                   CALL PB_PSLAPRNT( NROWA, NCOLA, MEM( IPA ), IA, JA,
00739      $                              DESCA, 0, 0, 'PARALLEL_INITIAL_A',
00740      $                              NOUT, MEM( IPG ) )
00741                ELSE IF( IVERB.GE.3 ) THEN
00742                   CALL PB_PSLAPRNT( MA, NA, MEM( IPA ), 1, 1, DESCA, 0,
00743      $                              0, 'PARALLEL_INITIAL_A', NOUT,
00744      $                              MEM( IPG ) )
00745                END IF
00746 *
00747                IF( IVERB.EQ.2 ) THEN
00748                   IF( INCX.EQ.DESCX( M_ ) ) THEN
00749                      CALL PB_PSLAPRNT( 1, NLX, MEM( IPX ), IX, JX,
00750      $                                 DESCX, 0, 0,
00751      $                                 'PARALLEL_INITIAL_X', NOUT,
00752      $                                 MEM( IPG ) )
00753                   ELSE
00754                      CALL PB_PSLAPRNT( NLX, 1, MEM( IPX ), IX, JX,
00755      $                                 DESCX, 0, 0,
00756      $                                 'PARALLEL_INITIAL_X', NOUT,
00757      $                                 MEM( IPG ) )
00758                   END IF
00759                ELSE IF( IVERB.GE.3 ) THEN
00760                   CALL PB_PSLAPRNT( MX, NX, MEM( IPX ), 1, 1, DESCX, 0,
00761      $                              0, 'PARALLEL_INITIAL_X', NOUT,
00762      $                              MEM( IPG ) )
00763                END IF
00764 *
00765                IF( YCHECK( K ) ) THEN
00766                   IF( IVERB.EQ.2 ) THEN
00767                      IF( INCY.EQ.DESCY( M_ ) ) THEN
00768                         CALL PB_PSLAPRNT( 1, NLY, MEM( IPY ), IY, JY,
00769      $                                    DESCY, 0, 0,
00770      $                                    'PARALLEL_INITIAL_Y', NOUT,
00771      $                                    MEM( IPG ) )
00772                      ELSE
00773                         CALL PB_PSLAPRNT( NLY, 1, MEM( IPY ), IY, JY,
00774      $                                    DESCY, 0, 0,
00775      $                                    'PARALLEL_INITIAL_Y', NOUT,
00776      $                                    MEM( IPG ) )
00777                      END IF
00778                   ELSE IF( IVERB.GE.3 ) THEN
00779                      CALL PB_PSLAPRNT( MY, NY, MEM( IPY ), 1, 1, DESCY,
00780      $                                 0, 0, 'PARALLEL_INITIAL_Y', NOUT,
00781      $                                 MEM( IPG ) )
00782                   END IF
00783                END IF
00784 *
00785 *              Call the Level 2 PBLAS routine
00786 *
00787                INFO = 0
00788                IF( K.EQ.1 ) THEN
00789 *
00790 *                 Test PSGEMV
00791 *
00792                   CALL PSGEMV( TRANS, M, N, ALPHA, MEM( IPA ), IA, JA,
00793      $                         DESCA, MEM( IPX ), IX, JX, DESCX, INCX,
00794      $                         BETA, MEM( IPY ), IY, JY, DESCY, INCY )
00795 *
00796                ELSE IF( K.EQ.2 ) THEN
00797 *
00798 *                 Test PSSYMV
00799 *
00800                   CALL PSSYMV( UPLO, N, ALPHA, MEM( IPA ), IA, JA,
00801      $                         DESCA, MEM( IPX ), IX, JX, DESCX, INCX,
00802      $                         BETA, MEM( IPY ), IY, JY, DESCY, INCY )
00803 *
00804                ELSE IF( K.EQ.3 ) THEN
00805 *
00806 *                 Test PSTRMV
00807 *
00808                   CALL PSTRMV( UPLO, TRANS, DIAG, N, MEM( IPA ), IA, JA,
00809      $                         DESCA, MEM( IPX ), IX, JX, DESCX, INCX )
00810 *
00811                ELSE IF( K.EQ.4 ) THEN
00812 *
00813 *                 Test PSTRSV
00814 *
00815                   CALL PSTRSV( UPLO, TRANS, DIAG, N, MEM( IPA ), IA, JA,
00816      $                         DESCA, MEM( IPX ), IX, JX, DESCX, INCX )
00817 *
00818                ELSE IF( K.EQ.5 ) THEN
00819 *
00820 *                 Test PSGER
00821 *
00822                   CALL PSGER( M, N, ALPHA, MEM( IPX ), IX, JX, DESCX,
00823      $                        INCX, MEM( IPY ), IY, JY, DESCY, INCY,
00824      $                        MEM( IPA ), IA, JA, DESCA )
00825 *
00826                ELSE IF( K.EQ.6 ) THEN
00827 *
00828 *                 Test PSSYR
00829 *
00830                   CALL PSSYR( UPLO, N, ALPHA, MEM( IPX ), IX, JX, DESCX,
00831      $                         INCX, MEM( IPA ), IA, JA, DESCA )
00832 *
00833                ELSE IF( K.EQ.7 ) THEN
00834 *
00835 *                 Test PSSYR2
00836 *
00837                   CALL PSSYR2( UPLO, N, ALPHA, MEM( IPX ), IX, JX,
00838      $                         DESCX, INCX, MEM( IPY ), IY, JY, DESCY,
00839      $                         INCY, MEM( IPA ), IA, JA, DESCA )
00840 *
00841                END IF
00842 *
00843 *              Check if the operation has been performed.
00844 *
00845                IF( INFO.NE.0 ) THEN
00846                   KSKIP( K ) = KSKIP( K ) + 1
00847                   IF( IAM.EQ.0 )
00848      $               WRITE( NOUT, FMT = 9974 ) INFO
00849                   GO TO 30
00850                END IF
00851 *
00852 *              Check padding
00853 *
00854                CALL PB_SCHEKPAD( ICTXT, SNAMES( K ), MPA, NQA,
00855      $                           MEM( IPA-IPREA ), DESCA( LLD_ ), IPREA,
00856      $                           IPOSTA, PADVAL )
00857 *
00858                CALL PB_SCHEKPAD( ICTXT, SNAMES( K ), MPX, NQX,
00859      $                           MEM( IPX-IPREX ), DESCX( LLD_ ), IPREX,
00860      $                           IPOSTX, PADVAL )
00861 *
00862                IF( YCHECK( K ) ) THEN
00863                   CALL PB_SCHEKPAD( ICTXT, SNAMES( K ), MPY, NQY,
00864      $                              MEM( IPY-IPREY ), DESCY( LLD_ ),
00865      $                              IPREY, IPOSTY, PADVAL )
00866                END IF
00867 *
00868 *              Check the computations
00869 *
00870                CALL PSBLAS2TSTCHK( ICTXT, NOUT, K, UPLO, TRANS, DIAG, M,
00871      $                             N, ALPHA, MEM( IPMATA ), MEM( IPA ),
00872      $                             IA, JA, DESCA, MEM( IPMATX ),
00873      $                             MEM( IPX ), IX, JX, DESCX, INCX,
00874      $                             BETA, MEM( IPMATY ), MEM( IPY ), IY,
00875      $                             JY, DESCY, INCY, THRESH, ROGUE,
00876      $                             MEM( IPG ), INFO )
00877                IF( MOD( INFO, 2 ).EQ.1 ) THEN
00878                   IERR( 1 ) = 1
00879                ELSE IF( MOD( INFO / 2, 2 ).EQ.1 ) THEN
00880                   IERR( 2 ) = 1
00881                ELSE IF( MOD( INFO / 4, 2 ).EQ.1 ) THEN
00882                   IERR( 3 ) = 1
00883                ELSE IF( INFO.NE.0 ) THEN
00884                   IERR( 1 ) = 1
00885                   IERR( 2 ) = 1
00886                   IERR( 3 ) = 1
00887                END IF
00888 *
00889 *              Check input-only scalar arguments
00890 *
00891                INFO = 1
00892                CALL PSCHKARG2( ICTXT, NOUT, SNAMES( K ), UPLO, TRANS,
00893      $                         DIAG, M, N, ALPHA, IA, JA, DESCA, IX,
00894      $                         JX, DESCX, INCX, BETA, IY, JY, DESCY,
00895      $                         INCY, INFO )
00896 *
00897 *              Check input-only array arguments
00898 *
00899                CALL PSCHKMOUT( NROWA, NCOLA, MEM( IPMATA ), MEM( IPA ),
00900      $                         IA, JA, DESCA, IERR( 4 ) )
00901                CALL PSCHKVOUT( NLX, MEM( IPMATX ), MEM( IPX ), IX, JX,
00902      $                         DESCX, INCX, IERR( 5 ) )
00903 *
00904                IF( IERR( 4 ).NE.0 ) THEN
00905                   IF( IAM.EQ.0 )
00906      $               WRITE( NOUT, FMT = 9982 ) 'PARALLEL_A',
00907      $                                         SNAMES( K )
00908                END IF
00909 *
00910                IF( IERR( 5 ).NE.0 ) THEN
00911                   IF( IAM.EQ.0 )
00912      $               WRITE( NOUT, FMT = 9982 ) 'PARALLEL_X',
00913      $                                         SNAMES( K )
00914                END IF
00915 *
00916                IF( YCHECK( K ) ) THEN
00917                   CALL PSCHKVOUT( NLY, MEM( IPMATY ), MEM( IPY ), IY,
00918      $                            JY, DESCY, INCY, IERR( 6 ) )
00919                   IF( IERR( 6 ).NE.0 ) THEN
00920                      IF( IAM.EQ.0 )
00921      $                  WRITE( NOUT, FMT = 9982 ) 'PARALLEL_Y',
00922      $                                            SNAMES( K )
00923                   END IF
00924                END IF
00925 *
00926 *              Only node 0 prints computational test result
00927 *
00928                IF( INFO.NE.0 .OR. IERR( 1 ).NE.0 .OR.
00929      $             IERR( 2 ).NE.0 .OR. IERR( 3 ).NE.0 .OR.
00930      $             IERR( 4 ).NE.0 .OR. IERR( 5 ).NE.0 .OR.
00931      $             IERR( 6 ).NE.0 ) THEN
00932                   IF( IAM.EQ.0 )
00933      $               WRITE( NOUT, FMT = 9984 ) SNAMES( K )
00934                   KFAIL( K ) = KFAIL( K ) + 1
00935                   ERRFLG = .TRUE.
00936                ELSE
00937                   IF( IAM.EQ.0 )
00938      $               WRITE( NOUT, FMT = 9983 ) SNAMES( K )
00939                   KPASS( K ) = KPASS( K ) + 1
00940                END IF
00941 *
00942 *              Dump matrix if IVERB >= 1 and error.
00943 *
00944                IF( IVERB.GE.1 .AND. ERRFLG ) THEN
00945                   IF( IERR( 4 ).NE.0 .OR. IVERB.GE.3 ) THEN
00946                      CALL PSMPRNT( ICTXT, NOUT, MA, NA, MEM( IPMATA ),
00947      $                             LDA, 0, 0, 'SERIAL_A' )
00948                      CALL PB_PSLAPRNT( MA, NA, MEM( IPA ), 1, 1, DESCA,
00949      $                                 0, 0, 'PARALLEL_A', NOUT,
00950      $                                MEM( IPMATA ) )
00951                   ELSE IF( IERR( 1 ).NE.0 ) THEN
00952                      IF( ( NROWA.GT.0 ).AND.( NCOLA.GT.0 ) )
00953      $                  CALL PSMPRNT( ICTXT, NOUT, NROWA, NCOLA,
00954      $                                MEM( IPMATA+IA-1+(JA-1)*LDA ),
00955      $                                LDA, 0, 0, 'SERIAL_A' )
00956                      CALL PB_PSLAPRNT( NROWA, NCOLA, MEM( IPA ), IA, JA,
00957      $                                 DESCA, 0, 0, 'PARALLEL_A',
00958      $                                 NOUT, MEM( IPMATA ) )
00959                   END IF
00960                   IF( IERR( 5 ).NE.0 .OR. IVERB.GE.3 ) THEN
00961                      CALL PSMPRNT( ICTXT, NOUT, MX, NX, MEM( IPMATX ),
00962      $                             LDX, 0, 0, 'SERIAL_X' )
00963                      CALL PB_PSLAPRNT( MX, NX, MEM( IPX ), 1, 1, DESCX,
00964      $                                 0, 0, 'PARALLEL_X', NOUT,
00965      $                                 MEM( IPMATX ) )
00966                   ELSE IF( IERR( 2 ).NE.0 ) THEN
00967                      IF( NLX.GT.0 )
00968      $                  CALL PSVPRNT( ICTXT, NOUT, NLX,
00969      $                                MEM( IPMATX+IX-1+(JX-1)*LDX ),
00970      $                                INCX, 0, 0, 'SERIAL_X' )
00971                      IF( INCX.EQ.DESCX( M_ ) ) THEN
00972                         CALL PB_PSLAPRNT( 1, NLX, MEM( IPX ), IX, JX,
00973      $                                    DESCX, 0, 0, 'PARALLEL_X',
00974      $                                    NOUT, MEM( IPMATX ) )
00975                      ELSE
00976                         CALL PB_PSLAPRNT( NLX, 1, MEM( IPX ), IX, JX,
00977      $                                    DESCX, 0, 0, 'PARALLEL_X',
00978      $                                    NOUT, MEM( IPMATX ) )
00979                      END IF
00980                   END IF
00981                   IF( YCHECK( K ) ) THEN
00982                      IF( IERR( 6 ).NE.0 .OR. IVERB.GE.3 ) THEN
00983                         CALL PSMPRNT( ICTXT, NOUT, MY, NY,
00984      $                                MEM( IPMATY ), LDY, 0, 0,
00985      $                                'SERIAL_Y' )
00986                         CALL PB_PSLAPRNT( MY, NY, MEM( IPY ), 1, 1,
00987      $                                    DESCY, 0, 0, 'PARALLEL_Y',
00988      $                                    NOUT, MEM( IPMATX ) )
00989                      ELSE IF( IERR( 3 ).NE.0 ) THEN
00990                         IF( NLY.GT.0 )
00991      $                     CALL PSVPRNT( ICTXT, NOUT, NLY,
00992      $                                   MEM( IPMATY+IY-1+(JY-1)*LDY ),
00993      $                                   INCY, 0, 0, 'SERIAL_Y' )
00994                         IF( INCY.EQ.DESCY( M_ ) ) THEN
00995                            CALL PB_PSLAPRNT( 1, NLY, MEM( IPY ), IY, JY,
00996      $                                       DESCY, 0, 0, 'PARALLEL_Y',
00997      $                                       NOUT, MEM( IPMATX ) )
00998                         ELSE
00999                            CALL PB_PSLAPRNT( NLY, 1, MEM( IPY ), IY, JY,
01000      $                                       DESCY, 0, 0, 'PARALLEL_Y',
01001      $                                       NOUT, MEM( IPMATX ) )
01002                         END IF
01003                      END IF
01004                   END IF
01005                END IF
01006 *
01007 *              Leave if error and "Stop On Failure"
01008 *
01009                IF( SOF.AND.ERRFLG )
01010      $            GO TO 70
01011 *
01012    30       CONTINUE
01013 *
01014    40       IF( IAM.EQ.0 ) THEN
01015                WRITE( NOUT, FMT = * )
01016                WRITE( NOUT, FMT = 9981 ) J
01017             END IF
01018 *
01019    50   CONTINUE
01020 *
01021         CALL BLACS_GRIDEXIT( ICTXT )
01022 *
01023    60 CONTINUE
01024 *
01025 *     Come here, if error and "Stop On Failure"
01026 *
01027    70 CONTINUE
01028 *
01029 *     Before printing out final stats, add TSKIP to all skips
01030 *
01031       DO 80 I = 1, NSUBS
01032          IF( LTEST( I ) ) THEN
01033             KSKIP( I ) = KSKIP( I ) + TSKIP
01034             KTESTS( I ) = KSKIP( I ) + KFAIL( I ) + KPASS( I )
01035          END IF
01036    80 CONTINUE
01037 *
01038 *     Print results
01039 *
01040       IF( IAM.EQ.0 ) THEN
01041          WRITE( NOUT, FMT = * )
01042          WRITE( NOUT, FMT = 9977 )
01043          WRITE( NOUT, FMT = * )
01044          WRITE( NOUT, FMT = 9979 )
01045          WRITE( NOUT, FMT = 9978 )
01046 *
01047          DO 90 I = 1, NSUBS
01048             WRITE( NOUT, FMT = 9980 ) '|', SNAMES( I ), KTESTS( I ),
01049      $                                KPASS( I ), KFAIL( I ), KSKIP( I )
01050    90    CONTINUE
01051          WRITE( NOUT, FMT = * )
01052          WRITE( NOUT, FMT = 9976 )
01053          WRITE( NOUT, FMT = * )
01054 *
01055       END IF
01056 *
01057       CALL BLACS_EXIT( 0 )
01058 *
01059  9999 FORMAT( 'ILLEGAL ', A, ': ', A, ' = ', I10,
01060      $        ' should be at least 1' )
01061  9998 FORMAT( 'ILLEGAL GRID: NPROW*NPCOL = ', I4,
01062      $        '. It can be at most', I4 )
01063  9997 FORMAT( 'Bad ', A, ' parameters: going on to next test case.' )
01064  9996 FORMAT( 2X, 'Test number ', I4 , ' started on a ', I6, ' x ',
01065      $        I6, ' process grid.' )
01066  9995 FORMAT( 2X, '   ------------------------------------------------',
01067      $        '--------------------------' )
01068  9994 FORMAT( 2X, '        M      N       UPLO       TRANS       DIAG' )
01069  9993 FORMAT( 5X,I6,1X,I6,9X,A1,11X,A1,10X,A1 )
01070  9992 FORMAT( 2X, '       IA     JA     MA     NA   IMBA   INBA',
01071      $        '    MBA    NBA RSRCA CSRCA' )
01072  9991 FORMAT( 5X,I6,1X,I6,1X,I6,1X,I6,1X,I6,1X,I6,1X,I6,1X,I6,
01073      $        1X,I5,1X,I5 )
01074  9990 FORMAT( 2X, '       IX     JX     MX     NX   IMBX   INBX',
01075      $        '    MBX    NBX RSRCX CSRCX   INCX' )
01076  9989 FORMAT( 5X,I6,1X,I6,1X,I6,1X,I6,1X,I6,1X,I6,1X,I6,1X,I6,
01077      $        1X,I5,1X,I5,1X,I6 )
01078  9988 FORMAT( 2X, '       IY     JY     MY     NY   IMBY   INBY',
01079      $        '    MBY    NBY RSRCY CSRCY   INCY' )
01080  9987 FORMAT( 'Not enough memory for this test: going on to',
01081      $        ' next test case.' )
01082  9986 FORMAT( 'Not enough memory. Need: ', I12 )
01083  9985 FORMAT( 2X, '   Tested Subroutine: ', A )
01084  9984 FORMAT( 2X, '   ***** Computational check: ', A, '       ',
01085      $        ' FAILED ',' *****' )
01086  9983 FORMAT( 2X, '   ***** Computational check: ', A, '       ',
01087      $        ' PASSED ',' *****' )
01088  9982 FORMAT( 2X, '   ***** ERROR ***** Matrix operand ', A,
01089      $        ' modified by ', A, ' *****' )
01090  9981 FORMAT( 2X, 'Test number ', I4, ' completed.' )
01091  9980 FORMAT( 2X,A1,2X,A7,8X,I4,6X,I4,5X,I4,4X,I4 )
01092  9979 FORMAT( 2X, '   SUBROUTINE  TOTAL TESTS  PASSED   FAILED  ',
01093      $        'SKIPPED' )
01094  9978 FORMAT( 2X, '   ----------  -----------  ------   ------  ',
01095      $        '-------' )
01096  9977 FORMAT( 2X, 'Testing Summary')
01097  9976 FORMAT( 2X, 'End of Tests.' )
01098  9975 FORMAT( 2X, 'Tests started.' )
01099  9974 FORMAT( 2X, '   ***** Operation not supported, error code: ',
01100      $        I5, ' *****' )
01101 *
01102       STOP
01103 *
01104 *     End of PSBLA2TST
01105 *
01106       END
01107       SUBROUTINE PSBLA2TSTINFO( SUMMRY, NOUT, NMAT, DIAGVAL, TRANVAL,
01108      $                          UPLOVAL, MVAL, NVAL, MAVAL, NAVAL,
01109      $                          IMBAVAL, MBAVAL, INBAVAL, NBAVAL,
01110      $                          RSCAVAL, CSCAVAL, IAVAL, JAVAL,
01111      $                          MXVAL, NXVAL, IMBXVAL, MBXVAL,
01112      $                          INBXVAL, NBXVAL, RSCXVAL, CSCXVAL,
01113      $                          IXVAL, JXVAL, INCXVAL, MYVAL, NYVAL,
01114      $                          IMBYVAL, MBYVAL, INBYVAL, NBYVAL,
01115      $                          RSCYVAL, CSCYVAL, IYVAL, JYVAL,
01116      $                          INCYVAL, LDVAL, NGRIDS, PVAL, LDPVAL,
01117      $                          QVAL, LDQVAL, NBLOG, LTEST, SOF, TEE,
01118      $                          IAM, IGAP, IVERB, NPROCS, THRESH, ALPHA,
01119      $                          BETA, WORK )
01120 *
01121 *  -- PBLAS test routine (version 2.0) --
01122 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
01123 *     and University of California, Berkeley.
01124 *     April 1, 1998
01125 *
01126 *     .. Scalar Arguments ..
01127       LOGICAL            SOF, TEE
01128       INTEGER            IAM, IGAP, IVERB, LDPVAL, LDQVAL, LDVAL, NBLOG,
01129      $                   NGRIDS, NMAT, NOUT, NPROCS
01130       REAL               ALPHA, BETA, THRESH
01131 *     ..
01132 *     .. Array Arguments ..
01133       CHARACTER*( * )    SUMMRY
01134       CHARACTER*1        DIAGVAL( LDVAL ), TRANVAL( LDVAL ),
01135      $                   UPLOVAL( LDVAL )
01136       LOGICAL            LTEST( * )
01137       INTEGER            CSCAVAL( LDVAL ), CSCXVAL( LDVAL ),
01138      $                   CSCYVAL( LDVAL ), IAVAL( LDVAL ),
01139      $                   IMBAVAL( LDVAL ), IMBXVAL( LDVAL ),
01140      $                   IMBYVAL( LDVAL ), INBAVAL( LDVAL ),
01141      $                   INBXVAL( LDVAL ), INBYVAL( LDVAL ),
01142      $                   INCXVAL( LDVAL ), INCYVAL( LDVAL ),
01143      $                   IXVAL( LDVAL ), IYVAL( LDVAL ), JAVAL( LDVAL ),
01144      $                   JXVAL( LDVAL ), JYVAL( LDVAL ), MAVAL( LDVAL ),
01145      $                   MBAVAL( LDVAL ), MBXVAL( LDVAL ),
01146      $                   MBYVAL( LDVAL ), MVAL( LDVAL ), MXVAL( LDVAL ),
01147      $                   MYVAL( LDVAL ), NAVAL( LDVAL ),
01148      $                   NBAVAL( LDVAL ), NBXVAL( LDVAL ),
01149      $                   NBYVAL( LDVAL ), NVAL( LDVAL ), NXVAL( LDVAL ),
01150      $                   NYVAL( LDVAL ), PVAL( LDPVAL ), QVAL( LDQVAL ),
01151      $                   RSCAVAL( LDVAL ), RSCXVAL( LDVAL ),
01152      $                   RSCYVAL( LDVAL ), WORK( * )
01153 *     ..
01154 *
01155 *  Purpose
01156 *  =======
01157 *
01158 *  PSBLA2TSTINFO  get the needed startup information for testing various
01159 *  Level 2 PBLAS routines, and transmits it to all processes.
01160 *
01161 *  Notes
01162 *  =====
01163 *
01164 *  For packing the information we assumed that the length in bytes of an
01165 *  integer is equal to the length in bytes of a real single precision.
01166 *
01167 *  Arguments
01168 *  =========
01169 *
01170 *  SUMMRY  (global output) CHARACTER*(*)
01171 *          On  exit,  SUMMRY  is  the  name of output (summary) file (if
01172 *          any). SUMMRY is only defined for process 0.
01173 *
01174 *  NOUT    (global output) INTEGER
01175 *          On exit, NOUT  specifies the unit number for the output file.
01176 *          When NOUT is 6, output to screen,  when  NOUT is 0, output to
01177 *          stderr. NOUT is only defined for process 0.
01178 *
01179 *  NMAT    (global output) INTEGER
01180 *          On exit,  NMAT  specifies the number of different test cases.
01181 *
01182 *  DIAGVAL (global output) CHARACTER array
01183 *          On entry,  DIAGVAL  is  an array of dimension LDVAL. On exit,
01184 *          this array contains the values of DIAG to run the code with.
01185 *
01186 *  TRANVAL (global output) CHARACTER array
01187 *          On entry, TRANVAL  is an array of dimension LDVAL.  On  exit,
01188 *          this array contains  the  values  of  TRANS  to  run the code
01189 *          with.
01190 *
01191 *  UPLOVAL (global output) CHARACTER array
01192 *          On entry, UPLOVAL  is an array of dimension LDVAL.  On  exit,
01193 *          this array contains the values of UPLO to run the code with.
01194 *
01195 *  MVAL    (global output) INTEGER array
01196 *          On entry, MVAL is an array of dimension LDVAL.  On exit, this
01197 *          array contains the values of M to run the code with.
01198 *
01199 *  NVAL    (global output) INTEGER array
01200 *          On entry, NVAL is an array of dimension LDVAL.  On exit, this
01201 *          array contains the values of N to run the code with.
01202 *
01203 *  MAVAL   (global output) INTEGER array
01204 *          On entry, MAVAL is an array of dimension LDVAL. On exit, this
01205 *          array  contains  the values  of  DESCA( M_ )  to run the code
01206 *          with.
01207 *
01208 *  NAVAL   (global output) INTEGER array
01209 *          On entry, NAVAL is an array of dimension LDVAL. On exit, this
01210 *          array  contains  the values  of  DESCA( N_ )  to run the code
01211 *          with.
01212 *
01213 *  IMBAVAL (global output) INTEGER array
01214 *          On entry,  IMBAVAL  is an array of  dimension LDVAL. On exit,
01215 *          this  array  contains  the values of DESCA( IMB_ ) to run the
01216 *          code with.
01217 *
01218 *  MBAVAL  (global output) INTEGER array
01219 *          On entry,  MBAVAL  is an array of  dimension  LDVAL. On exit,
01220 *          this  array  contains  the values of DESCA( MB_ ) to  run the
01221 *          code with.
01222 *
01223 *  INBAVAL (global output) INTEGER array
01224 *          On entry,  INBAVAL  is an array of  dimension LDVAL. On exit,
01225 *          this  array  contains  the values of DESCA( INB_ ) to run the
01226 *          code with.
01227 *
01228 *  NBAVAL  (global output) INTEGER array
01229 *          On entry,  NBAVAL  is an array of  dimension  LDVAL. On exit,
01230 *          this  array  contains  the values of DESCA( NB_ ) to  run the
01231 *          code with.
01232 *
01233 *  RSCAVAL (global output) INTEGER array
01234 *          On entry, RSCAVAL  is an array of  dimension  LDVAL. On exit,
01235 *          this  array  contains the values of DESCA( RSRC_ ) to run the
01236 *          code with.
01237 *
01238 *  CSCAVAL (global output) INTEGER array
01239 *          On entry, CSCAVAL  is an array of  dimension  LDVAL. On exit,
01240 *          this  array  contains the values of DESCA( CSRC_ ) to run the
01241 *          code with.
01242 *
01243 *  IAVAL   (global output) INTEGER array
01244 *          On entry, IAVAL is an array of dimension LDVAL. On exit, this
01245 *          array  contains the values of IA to run the code with.
01246 *
01247 *  JAVAL   (global output) INTEGER array
01248 *          On entry, JAVAL is an array of dimension LDVAL. On exit, this
01249 *          array  contains the values of JA to run the code with.
01250 *
01251 *  MXVAL   (global output) INTEGER array
01252 *          On entry, MXVAL is an array of dimension LDVAL. On exit, this
01253 *          array  contains  the values  of  DESCX( M_ )  to run the code
01254 *          with.
01255 *
01256 *  NXVAL   (global output) INTEGER array
01257 *          On entry, NXVAL is an array of dimension LDVAL. On exit, this
01258 *          array  contains  the values  of  DESCX( N_ )  to run the code
01259 *          with.
01260 *
01261 *  IMBXVAL (global output) INTEGER array
01262 *          On entry,  IMBXVAL  is an array of  dimension LDVAL. On exit,
01263 *          this  array  contains  the values of DESCX( IMB_ ) to run the
01264 *          code with.
01265 *
01266 *  MBXVAL  (global output) INTEGER array
01267 *          On entry,  MBXVAL  is an array of  dimension  LDVAL. On exit,
01268 *          this  array  contains  the values of DESCX( MB_ ) to  run the
01269 *          code with.
01270 *
01271 *  INBXVAL (global output) INTEGER array
01272 *          On entry,  INBXVAL  is an array of  dimension LDVAL. On exit,
01273 *          this  array  contains  the values of DESCX( INB_ ) to run the
01274 *          code with.
01275 *
01276 *  NBXVAL  (global output) INTEGER array
01277 *          On entry,  NBXVAL  is an array of  dimension  LDVAL. On exit,
01278 *          this  array  contains  the values of DESCX( NB_ ) to  run the
01279 *          code with.
01280 *
01281 *  RSCXVAL (global output) INTEGER array
01282 *          On entry, RSCXVAL  is an array of  dimension  LDVAL. On exit,
01283 *          this  array  contains the values of DESCX( RSRC_ ) to run the
01284 *          code with.
01285 *
01286 *  CSCXVAL (global output) INTEGER array
01287 *          On entry, CSCXVAL  is an array of  dimension  LDVAL. On exit,
01288 *          this  array  contains the values of DESCX( CSRC_ ) to run the
01289 *          code with.
01290 *
01291 *  IXVAL   (global output) INTEGER array
01292 *          On entry, IXVAL is an array of dimension LDVAL. On exit, this
01293 *          array  contains the values of IX to run the code with.
01294 *
01295 *  JXVAL   (global output) INTEGER array
01296 *          On entry, JXVAL is an array of dimension LDVAL. On exit, this
01297 *          array  contains the values of JX to run the code with.
01298 *
01299 *  INCXVAL (global output) INTEGER array
01300 *          On entry,  INCXVAL  is  an array of dimension LDVAL. On exit,
01301 *          this array  contains the values of INCX to run the code with.
01302 *
01303 *  MYVAL   (global output) INTEGER array
01304 *          On entry, MYVAL is an array of dimension LDVAL. On exit, this
01305 *          array  contains  the values  of  DESCY( M_ )  to run the code
01306 *          with.
01307 *
01308 *  NYVAL   (global output) INTEGER array
01309 *          On entry, NYVAL is an array of dimension LDVAL. On exit, this
01310 *          array  contains  the values  of  DESCY( N_ )  to run the code
01311 *          with.
01312 *
01313 *  IMBYVAL (global output) INTEGER array
01314 *          On entry,  IMBYVAL  is an array of  dimension LDVAL. On exit,
01315 *          this  array  contains  the values of DESCY( IMB_ ) to run the
01316 *          code with.
01317 *
01318 *  MBYVAL  (global output) INTEGER array
01319 *          On entry,  MBYVAL  is an array of  dimension  LDVAL. On exit,
01320 *          this  array  contains  the values of DESCY( MB_ ) to  run the
01321 *          code with.
01322 *
01323 *  INBYVAL (global output) INTEGER array
01324 *          On entry,  INBYVAL  is an array of  dimension LDVAL. On exit,
01325 *          this  array  contains  the values of DESCY( INB_ ) to run the
01326 *          code with.
01327 *
01328 *  NBYVAL  (global output) INTEGER array
01329 *          On entry,  NBYVAL  is an array of  dimension  LDVAL. On exit,
01330 *          this  array  contains  the values of DESCY( NB_ ) to  run the
01331 *          code with.
01332 *
01333 *  RSCYVAL (global output) INTEGER array
01334 *          On entry, RSCYVAL  is an array of  dimension  LDVAL. On exit,
01335 *          this  array  contains the values of DESCY( RSRC_ ) to run the
01336 *          code with.
01337 *
01338 *  CSCYVAL (global output) INTEGER array
01339 *          On entry, CSCYVAL  is an array of  dimension  LDVAL. On exit,
01340 *          this  array  contains the values of DESCY( CSRC_ ) to run the
01341 *          code with.
01342 *
01343 *  IYVAL   (global output) INTEGER array
01344 *          On entry, IYVAL is an array of dimension LDVAL. On exit, this
01345 *          array  contains the values of IY to run the code with.
01346 *
01347 *  JYVAL   (global output) INTEGER array
01348 *          On entry, JYVAL is an array of dimension LDVAL. On exit, this
01349 *          array  contains the values of JY to run the code with.
01350 *
01351 *  INCYVAL (global output) INTEGER array
01352 *          On entry,  INCYVAL  is  an array of dimension LDVAL. On exit,
01353 *          this array  contains the values of INCY to run the code with.
01354 *
01355 *  LDVAL   (global input) INTEGER
01356 *          On entry, LDVAL specifies the maximum number of different va-
01357 *          lues that can be used for DIAG, TRANS, UPLO, M, N,  DESCA(:),
01358 *          IA,  JA,  DESCX(:),  IX, JX, INCX, DESCY(:), IY, JY and INCY.
01359 *          This is also the maximum number of test cases.
01360 *
01361 *  NGRIDS  (global output) INTEGER
01362 *          On exit, NGRIDS specifies the number of different values that
01363 *          can be used for P and Q.
01364 *
01365 *  PVAL    (global output) INTEGER array
01366 *          On entry, PVAL is an array of dimension LDPVAL. On exit, this
01367 *          array contains the values of P to run the code with.
01368 *
01369 *  LDPVAL  (global input) INTEGER
01370 *          On entry,  LDPVAL  specifies  the maximum number of different
01371 *          values that can be used for P.
01372 *
01373 *  QVAL    (global output) INTEGER array
01374 *          On entry, QVAL is an array of dimension LDQVAL. On exit, this
01375 *          array contains the values of Q to run the code with.
01376 *
01377 *  LDQVAL  (global input) INTEGER
01378 *          On entry,  LDQVAL  specifies  the maximum number of different
01379 *          values that can be used for Q.
01380 *
01381 *  NBLOG   (global output) INTEGER
01382 *          On exit, NBLOG specifies the logical computational block size
01383 *          to run the tests with. NBLOG must be at least one.
01384 *
01385 *  LTEST   (global output) LOGICAL array
01386 *          On entry,  LTEST  is an array of dimension at least seven. On
01387 *          exit, if LTEST( i ) is .TRUE., the i-th Level 2 PBLAS routine
01388 *          will be tested.  See  the  input file for the ordering of the
01389 *          routines.
01390 *
01391 *  SOF     (global output) LOGICAL
01392 *          On exit, if SOF is .TRUE., the tester will  stop on the first
01393 *          detected failure. Otherwise, it won't.
01394 *
01395 *  TEE     (global output) LOGICAL
01396 *          On exit, if TEE is .TRUE., the tester will  perform the error
01397 *          exit tests. These tests won't be performed otherwise.
01398 *
01399 *  IAM     (local input) INTEGER
01400 *          On entry,  IAM  specifies the number of the process executing
01401 *          this routine.
01402 *
01403 *  IGAP    (global output) INTEGER
01404 *          On exit, IGAP  specifies the user-specified gap used for pad-
01405 *          ding. IGAP must be at least zero.
01406 *
01407 *  IVERB   (global output) INTEGER
01408 *          On exit,  IVERB  specifies  the output verbosity level: 0 for
01409 *          pass/fail, 1, 2 or 3 for matrix dump on errors.
01410 *
01411 *  NPROCS  (global input) INTEGER
01412 *          On entry, NPROCS specifies the total number of processes.
01413 *
01414 *  THRESH  (global output) REAL
01415 *          On exit,  THRESH  specifies the threshhold value for the test
01416 *          ratio.
01417 *
01418 *  ALPHA   (global output) REAL
01419 *          On exit, ALPHA specifies the value of alpha to be used in all
01420 *          the test cases.
01421 *
01422 *  BETA    (global output) REAL
01423 *          On exit, BETA  specifies the value of beta  to be used in all
01424 *          the test cases.
01425 *
01426 *  WORK    (local workspace) INTEGER array
01427 *          On   entry,   WORK   is   an  array  of  dimension  at  least
01428 *          MAX( 3, 2*NGRIDS+37*NMAT+NSUBS+4 )  with  NSUBS  equal  to 7.
01429 *          This array is used to pack all output arrays in order to send
01430 *          the information in one message.
01431 *
01432 *  -- Written on April 1, 1998 by
01433 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
01434 *
01435 *  =====================================================================
01436 *
01437 *     .. Parameters ..
01438       INTEGER            NIN, NSUBS
01439       PARAMETER          ( NIN = 11, NSUBS = 7 )
01440 *     ..
01441 *     .. Local Scalars ..
01442       LOGICAL            LTESTT
01443       INTEGER            I, ICTXT, J
01444       REAL               EPS
01445 *     ..
01446 *     .. Local Arrays ..
01447       CHARACTER*7        SNAMET
01448       CHARACTER*79       USRINFO
01449 *     ..
01450 *     .. External Subroutines ..
01451       EXTERNAL           BLACS_ABORT, BLACS_GET, BLACS_GRIDEXIT,
01452      $                   BLACS_GRIDINIT, BLACS_SETUP, ICOPY, IGEBR2D,
01453      $                   IGEBS2D, SGEBR2D, SGEBS2D
01454 *ype real dble cplx zplx
01455 *     ..
01456 *     .. External Functions ..
01457       REAL               PSLAMCH
01458       EXTERNAL           PSLAMCH
01459 *     ..
01460 *     .. Intrinsic Functions ..
01461       INTRINSIC          CHAR, ICHAR, MAX, MIN
01462 *     ..
01463 *     .. Common Blocks ..
01464       CHARACTER*7        SNAMES( NSUBS )
01465       COMMON             /SNAMEC/SNAMES
01466 *     ..
01467 *     .. Executable Statements ..
01468 *
01469 *     Process 0 reads the input data, broadcasts to other processes and
01470 *     writes needed information to NOUT
01471 *
01472       IF( IAM.EQ.0 ) THEN
01473 *
01474 *        Open file and skip data file header
01475 *
01476          OPEN( NIN, FILE='PSBLAS2TST.dat', STATUS='OLD' )
01477          READ( NIN, FMT = * ) SUMMRY
01478          SUMMRY = ' '
01479 *
01480 *        Read in user-supplied info about machine type, compiler, etc.
01481 *
01482          READ( NIN, FMT = 9999 ) USRINFO
01483 *
01484 *        Read name and unit number for summary output file
01485 *
01486          READ( NIN, FMT = * ) SUMMRY
01487          READ( NIN, FMT = * ) NOUT
01488          IF( NOUT.NE.0 .AND. NOUT.NE.6 )
01489      $      OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' )
01490 *
01491 *        Read and check the parameter values for the tests.
01492 *
01493 *        Read the flag that indicates if Stop on Failure
01494 *
01495          READ( NIN, FMT = * ) SOF
01496 *
01497 *        Read the flag that indicates if Test Error Exits
01498 *
01499          READ( NIN, FMT = * ) TEE
01500 *
01501 *        Read the verbosity level
01502 *
01503          READ( NIN, FMT = * ) IVERB
01504          IF( IVERB.LT.0 .OR. IVERB.GT.3 )
01505      $      IVERB = 0
01506 *
01507 *        Read the leading dimension gap
01508 *
01509          READ( NIN, FMT = * ) IGAP
01510          IF( IGAP.LT.0 )
01511      $      IGAP = 0
01512 *
01513 *        Read the threshold value for test ratio
01514 *
01515          READ( NIN, FMT = * ) THRESH
01516          IF( THRESH.LT.0.0 )
01517      $      THRESH = 16.0
01518 *
01519 *        Get logical computational block size
01520 *
01521          READ( NIN, FMT = * ) NBLOG
01522          IF( NBLOG.LT.1 )
01523      $      NBLOG = 32
01524 *
01525 *        Get number of grids
01526 *
01527          READ( NIN, FMT = * ) NGRIDS
01528          IF( NGRIDS.LT.1 .OR. NGRIDS.GT.LDPVAL ) THEN
01529             WRITE( NOUT, FMT = 9998 ) 'Grids', LDPVAL
01530             GO TO 120
01531          ELSE IF( NGRIDS.GT.LDQVAL ) THEN
01532             WRITE( NOUT, FMT = 9998 ) 'Grids', LDQVAL
01533             GO TO 120
01534          END IF
01535 *
01536 *        Get values of P and Q
01537 *
01538          READ( NIN, FMT = * ) ( PVAL( I ), I = 1, NGRIDS )
01539          READ( NIN, FMT = * ) ( QVAL( I ), I = 1, NGRIDS )
01540 *
01541 *        Read ALPHA, BETA
01542 *
01543          READ( NIN, FMT = * ) ALPHA
01544          READ( NIN, FMT = * ) BETA
01545 *
01546 *        Read number of tests.
01547 *
01548          READ( NIN, FMT = * ) NMAT
01549          IF( NMAT.LT.1 .OR. NMAT.GT.LDVAL ) THEN
01550             WRITE( NOUT, FMT = 9998 ) 'Tests', LDVAL
01551             GO TO 120
01552          ENDIF
01553 *
01554 *        Read in input data into arrays.
01555 *
01556          READ( NIN, FMT = * ) ( UPLOVAL( I ),  I = 1, NMAT )
01557          READ( NIN, FMT = * ) ( TRANVAL( I ),  I = 1, NMAT )
01558          READ( NIN, FMT = * ) ( DIAGVAL( I ),  I = 1, NMAT )
01559          READ( NIN, FMT = * ) ( MVAL( I ),     I = 1, NMAT )
01560          READ( NIN, FMT = * ) ( NVAL( I ),     I = 1, NMAT )
01561          READ( NIN, FMT = * ) ( MAVAL( I ),    I = 1, NMAT )
01562          READ( NIN, FMT = * ) ( NAVAL( I ),    I = 1, NMAT )
01563          READ( NIN, FMT = * ) ( IMBAVAL( I ),  I = 1, NMAT )
01564          READ( NIN, FMT = * ) ( INBAVAL( I ),  I = 1, NMAT )
01565          READ( NIN, FMT = * ) ( MBAVAL( I ),   I = 1, NMAT )
01566          READ( NIN, FMT = * ) ( NBAVAL( I ),   I = 1, NMAT )
01567          READ( NIN, FMT = * ) ( RSCAVAL( I ),  I = 1, NMAT )
01568          READ( NIN, FMT = * ) ( CSCAVAL( I ),  I = 1, NMAT )
01569          READ( NIN, FMT = * ) ( IAVAL( I ),    I = 1, NMAT )
01570          READ( NIN, FMT = * ) ( JAVAL( I ),    I = 1, NMAT )
01571          READ( NIN, FMT = * ) ( MXVAL( I ),    I = 1, NMAT )
01572          READ( NIN, FMT = * ) ( NXVAL( I ),    I = 1, NMAT )
01573          READ( NIN, FMT = * ) ( IMBXVAL( I ),  I = 1, NMAT )
01574          READ( NIN, FMT = * ) ( INBXVAL( I ),  I = 1, NMAT )
01575          READ( NIN, FMT = * ) ( MBXVAL( I ),   I = 1, NMAT )
01576          READ( NIN, FMT = * ) ( NBXVAL( I ),   I = 1, NMAT )
01577          READ( NIN, FMT = * ) ( RSCXVAL( I ),  I = 1, NMAT )
01578          READ( NIN, FMT = * ) ( CSCXVAL( I ),  I = 1, NMAT )
01579          READ( NIN, FMT = * ) ( IXVAL( I ),    I = 1, NMAT )
01580          READ( NIN, FMT = * ) ( JXVAL( I ),    I = 1, NMAT )
01581          READ( NIN, FMT = * ) ( INCXVAL( I ),  I = 1, NMAT )
01582          READ( NIN, FMT = * ) ( MYVAL( I ),    I = 1, NMAT )
01583          READ( NIN, FMT = * ) ( NYVAL( I ),    I = 1, NMAT )
01584          READ( NIN, FMT = * ) ( IMBYVAL( I ),  I = 1, NMAT )
01585          READ( NIN, FMT = * ) ( INBYVAL( I ),  I = 1, NMAT )
01586          READ( NIN, FMT = * ) ( MBYVAL( I ),   I = 1, NMAT )
01587          READ( NIN, FMT = * ) ( NBYVAL( I ),   I = 1, NMAT )
01588          READ( NIN, FMT = * ) ( RSCYVAL( I ),  I = 1, NMAT )
01589          READ( NIN, FMT = * ) ( CSCYVAL( I ),  I = 1, NMAT )
01590          READ( NIN, FMT = * ) ( IYVAL( I ),    I = 1, NMAT )
01591          READ( NIN, FMT = * ) ( JYVAL( I ),    I = 1, NMAT )
01592          READ( NIN, FMT = * ) ( INCYVAL( I ),  I = 1, NMAT )
01593 *
01594 *        Read names of subroutines and flags which indicate
01595 *        whether they are to be tested.
01596 *
01597          DO 10 I = 1, NSUBS
01598             LTEST( I ) = .FALSE.
01599    10    CONTINUE
01600    20    CONTINUE
01601          READ( NIN, FMT = 9996, END = 50 ) SNAMET, LTESTT
01602          DO 30 I = 1, NSUBS
01603             IF( SNAMET.EQ.SNAMES( I ) )
01604      $         GO TO 40
01605    30    CONTINUE
01606 *
01607          WRITE( NOUT, FMT = 9995 )SNAMET
01608          GO TO 120
01609 *
01610    40    CONTINUE
01611          LTEST( I ) = LTESTT
01612          GO TO 20
01613 *
01614    50    CONTINUE
01615 *
01616 *        Close input file
01617 *
01618          CLOSE ( NIN )
01619 *
01620 *        For pvm only: if virtual machine not set up, allocate it and
01621 *        spawn the correct number of processes.
01622 *
01623          IF( NPROCS.LT.1 ) THEN
01624             NPROCS = 0
01625             DO 60 I = 1, NGRIDS
01626                NPROCS = MAX( NPROCS, PVAL( I )*QVAL( I ) )
01627    60       CONTINUE
01628             CALL BLACS_SETUP( IAM, NPROCS )
01629          END IF
01630 *
01631 *        Temporarily define blacs grid to include all processes so
01632 *        information can be broadcast to all processes
01633 *
01634          CALL BLACS_GET( -1, 0, ICTXT )
01635          CALL BLACS_GRIDINIT( ICTXT, 'Row-major', 1, NPROCS )
01636 *
01637 *        Compute machine epsilon
01638 *
01639          EPS = PSLAMCH( ICTXT, 'eps' )
01640 *
01641 *        Pack information arrays and broadcast
01642 *
01643          CALL SGEBS2D( ICTXT, 'All', ' ', 1, 1, THRESH, 1 )
01644          CALL SGEBS2D( ICTXT, 'All', ' ', 1, 1, ALPHA, 1 )
01645          CALL SGEBS2D( ICTXT, 'All', ' ', 1, 1, BETA, 1 )
01646 *
01647          WORK( 1 ) = NGRIDS
01648          WORK( 2 ) = NMAT
01649          WORK( 3 ) = NBLOG
01650          CALL IGEBS2D( ICTXT, 'All', ' ', 3, 1, WORK, 3 )
01651 *
01652          I = 1
01653          IF( SOF ) THEN
01654             WORK( I ) = 1
01655          ELSE
01656             WORK( I ) = 0
01657          END IF
01658          I = I + 1
01659          IF( TEE ) THEN
01660             WORK( I ) = 1
01661          ELSE
01662             WORK( I ) = 0
01663          END IF
01664          I = I + 1
01665          WORK( I ) = IVERB
01666          I = I + 1
01667          WORK( I ) = IGAP
01668          I = I + 1
01669          DO 70 J = 1, NMAT
01670             WORK( I )   = ICHAR( DIAGVAL( J ) )
01671             WORK( I+1 ) = ICHAR( TRANVAL( J ) )
01672             WORK( I+2 ) = ICHAR( UPLOVAL( J ) )
01673             I = I + 3
01674    70    CONTINUE
01675          CALL ICOPY( NGRIDS, PVAL,     1, WORK( I ), 1 )
01676          I = I + NGRIDS
01677          CALL ICOPY( NGRIDS, QVAL,     1, WORK( I ), 1 )
01678          I = I + NGRIDS
01679          CALL ICOPY( NMAT,   MVAL,     1, WORK( I ), 1 )
01680          I = I + NMAT
01681          CALL ICOPY( NMAT,   NVAL,     1, WORK( I ), 1 )
01682          I = I + NMAT
01683          CALL ICOPY( NMAT,   MAVAL,    1, WORK( I ), 1 )
01684          I = I + NMAT
01685          CALL ICOPY( NMAT,   NAVAL,    1, WORK( I ), 1 )
01686          I = I + NMAT
01687          CALL ICOPY( NMAT,   IMBAVAL,  1, WORK( I ), 1 )
01688          I = I + NMAT
01689          CALL ICOPY( NMAT,   INBAVAL,  1, WORK( I ), 1 )
01690          I = I + NMAT
01691          CALL ICOPY( NMAT,   MBAVAL,   1, WORK( I ), 1 )
01692          I = I + NMAT
01693          CALL ICOPY( NMAT,   NBAVAL,   1, WORK( I ), 1 )
01694          I = I + NMAT
01695          CALL ICOPY( NMAT,   RSCAVAL,  1, WORK( I ), 1 )
01696          I = I + NMAT
01697          CALL ICOPY( NMAT,   CSCAVAL,  1, WORK( I ), 1 )
01698          I = I + NMAT
01699          CALL ICOPY( NMAT,   IAVAL,    1, WORK( I ), 1 )
01700          I = I + NMAT
01701          CALL ICOPY( NMAT,   JAVAL,    1, WORK( I ), 1 )
01702          I = I + NMAT
01703          CALL ICOPY( NMAT,   MXVAL,    1, WORK( I ), 1 )
01704          I = I + NMAT
01705          CALL ICOPY( NMAT,   NXVAL,    1, WORK( I ), 1 )
01706          I = I + NMAT
01707          CALL ICOPY( NMAT,   IMBXVAL,  1, WORK( I ), 1 )
01708          I = I + NMAT
01709          CALL ICOPY( NMAT,   INBXVAL,  1, WORK( I ), 1 )
01710          I = I + NMAT
01711          CALL ICOPY( NMAT,   MBXVAL,   1, WORK( I ), 1 )
01712          I = I + NMAT
01713          CALL ICOPY( NMAT,   NBXVAL,   1, WORK( I ), 1 )
01714          I = I + NMAT
01715          CALL ICOPY( NMAT,   RSCXVAL,  1, WORK( I ), 1 )
01716          I = I + NMAT
01717          CALL ICOPY( NMAT,   CSCXVAL,  1, WORK( I ), 1 )
01718          I = I + NMAT
01719          CALL ICOPY( NMAT,   IXVAL,    1, WORK( I ), 1 )
01720          I = I + NMAT
01721          CALL ICOPY( NMAT,   JXVAL,    1, WORK( I ), 1 )
01722          I = I + NMAT
01723          CALL ICOPY( NMAT,   INCXVAL,  1, WORK( I ), 1 )
01724          I = I + NMAT
01725          CALL ICOPY( NMAT,   MYVAL,    1, WORK( I ), 1 )
01726          I = I + NMAT
01727          CALL ICOPY( NMAT,   NYVAL,    1, WORK( I ), 1 )
01728          I = I + NMAT
01729          CALL ICOPY( NMAT,   IMBYVAL,  1, WORK( I ), 1 )
01730          I = I + NMAT
01731          CALL ICOPY( NMAT,   INBYVAL,  1, WORK( I ), 1 )
01732          I = I + NMAT
01733          CALL ICOPY( NMAT,   MBYVAL,   1, WORK( I ), 1 )
01734          I = I + NMAT
01735          CALL ICOPY( NMAT,   NBYVAL,   1, WORK( I ), 1 )
01736          I = I + NMAT
01737          CALL ICOPY( NMAT,   RSCYVAL,  1, WORK( I ), 1 )
01738          I = I + NMAT
01739          CALL ICOPY( NMAT,   CSCYVAL,  1, WORK( I ), 1 )
01740          I = I + NMAT
01741          CALL ICOPY( NMAT,   IYVAL,    1, WORK( I ), 1 )
01742          I = I + NMAT
01743          CALL ICOPY( NMAT,   JYVAL,    1, WORK( I ), 1 )
01744          I = I + NMAT
01745          CALL ICOPY( NMAT,   INCYVAL,  1, WORK( I ), 1 )
01746          I = I + NMAT
01747 *
01748          DO 80 J = 1, NSUBS
01749             IF( LTEST( J ) ) THEN
01750                WORK( I ) = 1
01751             ELSE
01752                WORK( I ) = 0
01753             END IF
01754             I = I + 1
01755    80    CONTINUE
01756          I = I - 1
01757          CALL IGEBS2D( ICTXT, 'All', ' ', I, 1, WORK, I )
01758 *
01759 *        regurgitate input
01760 *
01761          WRITE( NOUT, FMT = 9999 ) 'Level 2 PBLAS testing program.'
01762          WRITE( NOUT, FMT = 9999 ) USRINFO
01763          WRITE( NOUT, FMT = * )
01764          WRITE( NOUT, FMT = 9999 )
01765      $               'Tests of the real single precision '//
01766      $               'Level 2 PBLAS'
01767          WRITE( NOUT, FMT = * )
01768          WRITE( NOUT, FMT = 9993 ) NMAT
01769          WRITE( NOUT, FMT = 9979 ) NBLOG
01770          WRITE( NOUT, FMT = 9992 ) NGRIDS
01771          WRITE( NOUT, FMT = 9990 )
01772      $               'P', ( PVAL(I), I = 1, MIN(NGRIDS, 5) )
01773          IF( NGRIDS.GT.5 )
01774      $      WRITE( NOUT, FMT = 9991 ) ( PVAL(I), I = 6,
01775      $                                  MIN( 10, NGRIDS ) )
01776          IF( NGRIDS.GT.10 )
01777      $      WRITE( NOUT, FMT = 9991 ) ( PVAL(I), I = 11,
01778      $                                  MIN( 15, NGRIDS ) )
01779          IF( NGRIDS.GT.15 )
01780      $      WRITE( NOUT, FMT = 9991 ) ( PVAL(I), I = 16, NGRIDS )
01781          WRITE( NOUT, FMT = 9990 )
01782      $               'Q', ( QVAL(I), I = 1, MIN(NGRIDS, 5) )
01783          IF( NGRIDS.GT.5 )
01784      $      WRITE( NOUT, FMT = 9991 ) ( QVAL(I), I = 6,
01785      $                                  MIN( 10, NGRIDS ) )
01786          IF( NGRIDS.GT.10 )
01787      $      WRITE( NOUT, FMT = 9991 ) ( QVAL(I), I = 11,
01788      $                                  MIN( 15, NGRIDS ) )
01789          IF( NGRIDS.GT.15 )
01790      $      WRITE( NOUT, FMT = 9991 ) ( QVAL(I), I = 16, NGRIDS )
01791          WRITE( NOUT, FMT = 9988 ) SOF
01792          WRITE( NOUT, FMT = 9987 ) TEE
01793          WRITE( NOUT, FMT = 9983 ) IGAP
01794          WRITE( NOUT, FMT = 9986 ) IVERB
01795          WRITE( NOUT, FMT = 9980 ) THRESH
01796          WRITE( NOUT, FMT = 9982 ) ALPHA
01797          WRITE( NOUT, FMT = 9981 ) BETA
01798          IF( LTEST( 1 ) ) THEN
01799             WRITE( NOUT, FMT = 9985 ) SNAMES( 1 ), ' ... Yes'
01800          ELSE
01801             WRITE( NOUT, FMT = 9985 ) SNAMES( 1 ), ' ... No '
01802          END IF
01803          DO 90 I = 2, NSUBS
01804             IF( LTEST( I ) ) THEN
01805                WRITE( NOUT, FMT = 9984 ) SNAMES( I ), ' ... Yes'
01806             ELSE
01807                WRITE( NOUT, FMT = 9984 ) SNAMES( I ), ' ... No '
01808             END IF
01809    90    CONTINUE
01810          WRITE( NOUT, FMT = 9994 ) EPS
01811          WRITE( NOUT, FMT = * )
01812 *
01813       ELSE
01814 *
01815 *        If in pvm, must participate setting up virtual machine
01816 *
01817          IF( NPROCS.LT.1 )
01818      $      CALL BLACS_SETUP( IAM, NPROCS )
01819 *
01820 *        Temporarily define blacs grid to include all processes so
01821 *        information can be broadcast to all processes
01822 *
01823          CALL BLACS_GET( -1, 0, ICTXT )
01824          CALL BLACS_GRIDINIT( ICTXT, 'Row-major', 1, NPROCS )
01825 *
01826 *        Compute machine epsilon
01827 *
01828          EPS = PSLAMCH( ICTXT, 'eps' )
01829 *
01830          CALL SGEBR2D( ICTXT, 'All', ' ', 1, 1, THRESH, 1, 0, 0 )
01831          CALL SGEBR2D( ICTXT, 'All', ' ', 1, 1, ALPHA, 1, 0, 0 )
01832          CALL SGEBR2D( ICTXT, 'All', ' ', 1, 1, BETA, 1, 0, 0 )
01833 *
01834          CALL IGEBR2D( ICTXT, 'All', ' ', 3, 1, WORK, 3, 0, 0 )
01835          NGRIDS = WORK( 1 )
01836          NMAT   = WORK( 2 )
01837          NBLOG  = WORK( 3 )
01838 *
01839          I = 2*NGRIDS + 37*NMAT + NSUBS + 4
01840          CALL IGEBR2D( ICTXT, 'All', ' ', I, 1, WORK, I, 0, 0 )
01841 *
01842          I = 1
01843          IF( WORK( I ).EQ.1 ) THEN
01844             SOF = .TRUE.
01845          ELSE
01846             SOF = .FALSE.
01847          END IF
01848          I = I + 1
01849          IF( WORK( I ).EQ.1 ) THEN
01850             TEE = .TRUE.
01851          ELSE
01852             TEE = .FALSE.
01853          END IF
01854          I = I + 1
01855          IVERB = WORK( I )
01856          I = I + 1
01857          IGAP = WORK( I )
01858          I = I + 1
01859          DO 100 J = 1, NMAT
01860             DIAGVAL( J )  = CHAR( WORK( I ) )
01861             TRANVAL( J )  = CHAR( WORK( I+1 ) )
01862             UPLOVAL( J )  = CHAR( WORK( I+2 ) )
01863             I = I + 3
01864   100    CONTINUE
01865          CALL ICOPY( NGRIDS, WORK( I ), 1, PVAL,     1 )
01866          I = I + NGRIDS
01867          CALL ICOPY( NGRIDS, WORK( I ), 1, QVAL,     1 )
01868          I = I + NGRIDS
01869          CALL ICOPY( NMAT,   WORK( I ), 1, MVAL,     1 )
01870          I = I + NMAT
01871          CALL ICOPY( NMAT,   WORK( I ), 1, NVAL,     1 )
01872          I = I + NMAT
01873          CALL ICOPY( NMAT,   WORK( I ), 1, MAVAL,    1 )
01874          I = I + NMAT
01875          CALL ICOPY( NMAT,   WORK( I ), 1, NAVAL,    1 )
01876          I = I + NMAT
01877          CALL ICOPY( NMAT,   WORK( I ), 1, IMBAVAL,  1 )
01878          I = I + NMAT
01879          CALL ICOPY( NMAT,   WORK( I ), 1, INBAVAL,  1 )
01880          I = I + NMAT
01881          CALL ICOPY( NMAT,   WORK( I ), 1, MBAVAL,   1 )
01882          I = I + NMAT
01883          CALL ICOPY( NMAT,   WORK( I ), 1, NBAVAL,   1 )
01884          I = I + NMAT
01885          CALL ICOPY( NMAT,   WORK( I ), 1, RSCAVAL,  1 )
01886          I = I + NMAT
01887          CALL ICOPY( NMAT,   WORK( I ), 1, CSCAVAL,  1 )
01888          I = I + NMAT
01889          CALL ICOPY( NMAT,   WORK( I ), 1, IAVAL,    1 )
01890          I = I + NMAT
01891          CALL ICOPY( NMAT,   WORK( I ), 1, JAVAL,    1 )
01892          I = I + NMAT
01893          CALL ICOPY( NMAT,   WORK( I ), 1, MXVAL,    1 )
01894          I = I + NMAT
01895          CALL ICOPY( NMAT,   WORK( I ), 1, NXVAL,    1 )
01896          I = I + NMAT
01897          CALL ICOPY( NMAT,   WORK( I ), 1, IMBXVAL,  1 )
01898          I = I + NMAT
01899          CALL ICOPY( NMAT,   WORK( I ), 1, INBXVAL,  1 )
01900          I = I + NMAT
01901          CALL ICOPY( NMAT,   WORK( I ), 1, MBXVAL,   1 )
01902          I = I + NMAT
01903          CALL ICOPY( NMAT,   WORK( I ), 1, NBXVAL,   1 )
01904          I = I + NMAT
01905          CALL ICOPY( NMAT,   WORK( I ), 1, RSCXVAL,  1 )
01906          I = I + NMAT
01907          CALL ICOPY( NMAT,   WORK( I ), 1, CSCXVAL,  1 )
01908          I = I + NMAT
01909          CALL ICOPY( NMAT,   WORK( I ), 1, IXVAL,    1 )
01910          I = I + NMAT
01911          CALL ICOPY( NMAT,   WORK( I ), 1, JXVAL,    1 )
01912          I = I + NMAT
01913          CALL ICOPY( NMAT,   WORK( I ), 1, INCXVAL,  1 )
01914          I = I + NMAT
01915          CALL ICOPY( NMAT,   WORK( I ), 1, MYVAL,    1 )
01916          I = I + NMAT
01917          CALL ICOPY( NMAT,   WORK( I ), 1, NYVAL,    1 )
01918          I = I + NMAT
01919          CALL ICOPY( NMAT,   WORK( I ), 1, IMBYVAL,  1 )
01920          I = I + NMAT
01921          CALL ICOPY( NMAT,   WORK( I ), 1, INBYVAL,  1 )
01922          I = I + NMAT
01923          CALL ICOPY( NMAT,   WORK( I ), 1, MBYVAL,   1 )
01924          I = I + NMAT
01925          CALL ICOPY( NMAT,   WORK( I ), 1, NBYVAL,   1 )
01926          I = I + NMAT
01927          CALL ICOPY( NMAT,   WORK( I ), 1, RSCYVAL,  1 )
01928          I = I + NMAT
01929          CALL ICOPY( NMAT,   WORK( I ), 1, CSCYVAL,  1 )
01930          I = I + NMAT
01931          CALL ICOPY( NMAT,   WORK( I ), 1, IYVAL,    1 )
01932          I = I + NMAT
01933          CALL ICOPY( NMAT,   WORK( I ), 1, JYVAL,    1 )
01934          I = I + NMAT
01935          CALL ICOPY( NMAT,   WORK( I ), 1, INCYVAL,  1 )
01936          I = I + NMAT
01937 *
01938          DO 110 J = 1, NSUBS
01939             IF( WORK( I ).EQ.1 ) THEN
01940                LTEST( J ) = .TRUE.
01941             ELSE
01942                LTEST( J ) = .FALSE.
01943             END IF
01944             I = I + 1
01945   110    CONTINUE
01946 *
01947       END IF
01948 *
01949       CALL BLACS_GRIDEXIT( ICTXT )
01950 *
01951       RETURN
01952 *
01953   120 WRITE( NOUT, FMT = 9997 )
01954       CLOSE( NIN )
01955       IF( NOUT.NE.6 .AND. NOUT.NE.0 )
01956      $   CLOSE( NOUT )
01957       CALL BLACS_ABORT( ICTXT, 1 )
01958 *
01959       STOP
01960 *
01961  9999 FORMAT( A )
01962  9998 FORMAT( ' Number of values of ',5A, ' is less than 1 or greater ',
01963      $        'than ', I2 )
01964  9997 FORMAT( ' Illegal input in file ',40A,'.  Aborting run.' )
01965  9996 FORMAT( A7, L2 )
01966  9995 FORMAT( '  Subprogram name ', A7, ' not recognized',
01967      $        /' ******* TESTS ABANDONED *******' )
01968  9994 FORMAT( 2X, 'Relative machine precision (eps) is taken to be ',
01969      $        E18.6 )
01970  9993 FORMAT( 2X, 'Number of Tests           : ', I6 )
01971  9992 FORMAT( 2X, 'Number of process grids   : ', I6 )
01972  9991 FORMAT( 2X, '                          : ', 5I6 )
01973  9990 FORMAT( 2X, A1, '                         : ', 5I6 )
01974  9988 FORMAT( 2X, 'Stop on failure flag      : ', L6 )
01975  9987 FORMAT( 2X, 'Test for error exits flag : ', L6 )
01976  9986 FORMAT( 2X, 'Verbosity level           : ', I6 )
01977  9985 FORMAT( 2X, 'Routines to be tested     :      ', A, A8 )
01978  9984 FORMAT( 2X, '                                 ', A, A8 )
01979  9983 FORMAT( 2X, 'Leading dimension gap     : ', I6 )
01980  9982 FORMAT( 2X, 'Alpha                     : ', G16.6 )
01981  9981 FORMAT( 2X, 'Beta                      : ', G16.6 )
01982  9980 FORMAT( 2X, 'Threshold value           : ', G16.6 )
01983  9979 FORMAT( 2X, 'Logical block size        : ', I6 )
01984 *
01985 *     End of PSBLA2TSTINFO
01986 *
01987       END
01988       SUBROUTINE PSBLAS2TSTCHKE( LTEST, INOUT, NPROCS )
01989 *
01990 *  -- PBLAS test routine (version 2.0) --
01991 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
01992 *     and University of California, Berkeley.
01993 *     April 1, 1998
01994 *
01995 *     .. Scalar Arguments ..
01996       INTEGER            INOUT, NPROCS
01997 *     ..
01998 *     .. Array Arguments ..
01999       LOGICAL            LTEST( * )
02000 *     ..
02001 *
02002 *  Purpose
02003 *  =======
02004 *
02005 *  PSBLAS2TSTCHKE tests the error exits of the Level 2 PBLAS.
02006 *
02007 *  Arguments
02008 *  =========
02009 *
02010 *  LTEST   (global input) LOGICAL array
02011 *          On entry, LTEST is an array of dimension at least 7 (NSUBS).
02012 *             If LTEST( 1 ) is .TRUE., PSGEMV will be tested;
02013 *             If LTEST( 2 ) is .TRUE., PSSYMV will be tested;
02014 *             If LTEST( 3 ) is .TRUE., PSTRMV will be tested;
02015 *             If LTEST( 4 ) is .TRUE., PSTRSV will be tested;
02016 *             If LTEST( 5 ) is .TRUE., PSGER  will be tested;
02017 *             If LTEST( 6 ) is .TRUE., PSSYR  will be tested;
02018 *             If LTEST( 7 ) is .TRUE., PSSYR2 will be tested;
02019 *
02020 *  INOUT   (global input) INTEGER
02021 *          On entry,  INOUT  specifies  the unit number for output file.
02022 *          When INOUT is 6, output to screen,  when INOUT = 0, output to
02023 *          stderr. INOUT is only defined in process 0.
02024 *
02025 *  NPROCS  (global input) INTEGER
02026 *          On entry, NPROCS specifies the total number of processes cal-
02027 *          ling this routine.
02028 *
02029 *  Calling sequence encodings
02030 *  ==========================
02031 *
02032 *  code Formal argument list                                Examples
02033 *
02034 *  11   (n,      v1,v2)                                     _SWAP, _COPY
02035 *  12   (n,s1,   v1   )                                     _SCAL, _SCAL
02036 *  13   (n,s1,   v1,v2)                                     _AXPY, _DOT_
02037 *  14   (n,s1,i1,v1   )                                     _AMAX
02038 *  15   (n,u1,   v1   )                                     _ASUM, _NRM2
02039 *
02040 *  21   (     trans,     m,n,s1,m1,v1,s2,v2)                _GEMV
02041 *  22   (uplo,             n,s1,m1,v1,s2,v2)                _SYMV, _HEMV
02042 *  23   (uplo,trans,diag,  n,   m1,v1      )                _TRMV, _TRSV
02043 *  24   (                m,n,s1,v1,v2,m1)                   _GER_
02044 *  25   (uplo,             n,s1,v1,   m1)                   _SYR
02045 *  26   (uplo,             n,u1,v1,   m1)                   _HER
02046 *  27   (uplo,             n,s1,v1,v2,m1)                   _SYR2, _HER2
02047 *
02048 *  31   (          transa,transb,     m,n,k,s1,m1,m2,s2,m3) _GEMM
02049 *  32   (side,uplo,                   m,n,  s1,m1,m2,s2,m3) _SYMM, _HEMM
02050 *  33   (     uplo,trans,               n,k,s1,m1,   s2,m3) _SYRK
02051 *  34   (     uplo,trans,               n,k,u1,m1,   u2,m3) _HERK
02052 *  35   (     uplo,trans,               n,k,s1,m1,m2,s2,m3) _SYR2K
02053 *  36   (     uplo,trans,               n,k,s1,m1,m2,u2,m3) _HER2K
02054 *  37   (                             m,n,  s1,m1,   s2,m3) _TRAN_
02055 *  38   (side,uplo,transa,       diag,m,n,  s1,m1,m2      ) _TRMM, _TRSM
02056 *  39   (          trans,             m,n,  s1,m1,   s2,m3) _GEADD
02057 *  40   (     uplo,trans,             m,n,  s1,m1,   s2,m3) _TRADD
02058 *
02059 *  -- Written on April 1, 1998 by
02060 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
02061 *
02062 *  =====================================================================
02063 *
02064 *     .. Parameters ..
02065       INTEGER            NSUBS
02066       PARAMETER          ( NSUBS = 7 )
02067 *     ..
02068 *     .. Local Scalars ..
02069       LOGICAL            ABRTSAV
02070       INTEGER            I, ICTXT, MYCOL, MYROW, NPCOL, NPROW
02071 *     ..
02072 *     .. Local Arrays ..
02073       INTEGER            SCODE( NSUBS )
02074 *     ..
02075 *     .. External Subroutines ..
02076       EXTERNAL           BLACS_GET, BLACS_GRIDEXIT, BLACS_GRIDINFO,
02077      $                   BLACS_GRIDINIT, PSDIMEE, PSGEMV, PSGER,
02078      $                   PSMATEE, PSOPTEE, PSSYMV, PSSYR, PSSYR2,
02079      $                   PSTRMV, PSTRSV, PSVECEE
02080 *     ..
02081 *     .. Common Blocks ..
02082       LOGICAL            ABRTFLG
02083       INTEGER            NOUT
02084       CHARACTER*7        SNAMES( NSUBS )
02085       COMMON             /SNAMEC/SNAMES
02086       COMMON             /PBERRORC/NOUT, ABRTFLG
02087 *     ..
02088 *     .. Data Statements ..
02089       DATA               SCODE/21, 22, 23, 23, 24, 25, 27/
02090 *     ..
02091 *     .. Executable Statements ..
02092 *
02093 *     Temporarily define blacs grid to include all processes so
02094 *     information can be broadcast to all processes.
02095 *
02096       CALL BLACS_GET( -1, 0, ICTXT )
02097       CALL BLACS_GRIDINIT( ICTXT, 'Row-major', 1, NPROCS )
02098       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
02099 *
02100 *     Set ABRTFLG to FALSE so that the PBLAS error handler won't abort
02101 *     on errors during these tests and set the output device unit for
02102 *     it.
02103 *
02104       ABRTSAV = ABRTFLG
02105       ABRTFLG = .FALSE.
02106       NOUT    = INOUT
02107 *
02108 *     Test PSGEMV
02109 *
02110       I = 1
02111       IF( LTEST( I ) ) THEN
02112          CALL PSOPTEE( ICTXT, NOUT, PSGEMV, SCODE( I ), SNAMES( I ) )
02113          CALL PSDIMEE( ICTXT, NOUT, PSGEMV, SCODE( I ), SNAMES( I ) )
02114          CALL PSMATEE( ICTXT, NOUT, PSGEMV, SCODE( I ), SNAMES( I ) )
02115          CALL PSVECEE( ICTXT, NOUT, PSGEMV, SCODE( I ), SNAMES( I ) )
02116       END IF
02117 *
02118 *     Test PSSYMV
02119 *
02120       I = I + 1
02121       IF( LTEST( I ) ) THEN
02122          CALL PSOPTEE( ICTXT, NOUT, PSSYMV, SCODE( I ), SNAMES( I ) )
02123          CALL PSDIMEE( ICTXT, NOUT, PSSYMV, SCODE( I ), SNAMES( I ) )
02124          CALL PSMATEE( ICTXT, NOUT, PSSYMV, SCODE( I ), SNAMES( I ) )
02125          CALL PSVECEE( ICTXT, NOUT, PSSYMV, SCODE( I ), SNAMES( I ) )
02126       END IF
02127 *
02128 *     Test PSTRMV
02129 *
02130       I = I + 1
02131       IF( LTEST( I ) ) THEN
02132          CALL PSOPTEE( ICTXT, NOUT, PSTRMV, SCODE( I ), SNAMES( I ) )
02133          CALL PSDIMEE( ICTXT, NOUT, PSTRMV, SCODE( I ), SNAMES( I ) )
02134          CALL PSMATEE( ICTXT, NOUT, PSTRMV, SCODE( I ), SNAMES( I ) )
02135          CALL PSVECEE( ICTXT, NOUT, PSTRMV, SCODE( I ), SNAMES( I ) )
02136       END IF
02137 *
02138 *     Test PSTRSV
02139 *
02140       I = I + 1
02141       IF( LTEST( I ) ) THEN
02142          CALL PSOPTEE( ICTXT, NOUT, PSTRSV, SCODE( I ), SNAMES( I ) )
02143          CALL PSDIMEE( ICTXT, NOUT, PSTRSV, SCODE( I ), SNAMES( I ) )
02144          CALL PSMATEE( ICTXT, NOUT, PSTRSV, SCODE( I ), SNAMES( I ) )
02145          CALL PSVECEE( ICTXT, NOUT, PSTRSV, SCODE( I ), SNAMES( I ) )
02146       END IF
02147 *
02148 *     Test PSGER
02149 *
02150       I = I + 1
02151       IF( LTEST( I ) ) THEN
02152          CALL PSDIMEE( ICTXT, NOUT, PSGER, SCODE( I ), SNAMES( I ) )
02153          CALL PSVECEE( ICTXT, NOUT, PSGER, SCODE( I ), SNAMES( I ) )
02154          CALL PSMATEE( ICTXT, NOUT, PSGER, SCODE( I ), SNAMES( I ) )
02155       END IF
02156 *
02157 *     Test PSSYR
02158 *
02159       I = I + 1
02160       IF( LTEST( I ) ) THEN
02161          CALL PSOPTEE( ICTXT, NOUT, PSSYR, SCODE( I ), SNAMES( I ) )
02162          CALL PSDIMEE( ICTXT, NOUT, PSSYR, SCODE( I ), SNAMES( I ) )
02163          CALL PSVECEE( ICTXT, NOUT, PSSYR, SCODE( I ), SNAMES( I ) )
02164          CALL PSMATEE( ICTXT, NOUT, PSSYR, SCODE( I ), SNAMES( I ) )
02165       END IF
02166 *
02167 *     Test PSSYR2
02168 *
02169       I = I + 1
02170       IF( LTEST( I ) ) THEN
02171          CALL PSOPTEE( ICTXT, NOUT, PSSYR2, SCODE( I ), SNAMES( I ) )
02172          CALL PSDIMEE( ICTXT, NOUT, PSSYR2, SCODE( I ), SNAMES( I ) )
02173          CALL PSVECEE( ICTXT, NOUT, PSSYR2, SCODE( I ), SNAMES( I ) )
02174          CALL PSMATEE( ICTXT, NOUT, PSSYR2, SCODE( I ), SNAMES( I ) )
02175       END IF
02176 *
02177       IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 )
02178      $   WRITE( NOUT, FMT = 9999 )
02179 *
02180       CALL BLACS_GRIDEXIT( ICTXT )
02181 *
02182 *     Reset ABRTFLG to the value it had before calling this routine
02183 *
02184       ABRTFLG = ABRTSAV
02185 *
02186  9999 FORMAT( 2X, 'Error-exit tests completed.' )
02187 *
02188       RETURN
02189 *
02190 *     End of PSBLAS2TSTCHKE
02191 *
02192       END
02193       SUBROUTINE PSCHKARG2( ICTXT, NOUT, SNAME, UPLO, TRANS, DIAG, M,
02194      $                      N, ALPHA, IA, JA, DESCA, IX, JX, DESCX,
02195      $                      INCX, BETA, IY, JY, DESCY, INCY, INFO )
02196 *
02197 *  -- PBLAS test routine (version 2.0) --
02198 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
02199 *     and University of California, Berkeley.
02200 *     April 1, 1998
02201 *
02202 *     .. Scalar Arguments ..
02203       CHARACTER*1        DIAG, TRANS, UPLO
02204       INTEGER            IA, ICTXT, INCX, INCY, INFO, IX, IY, JA, JX,
02205      $                   JY, M, N, NOUT
02206       REAL               ALPHA, BETA
02207 *     ..
02208 *     .. Array Arguments ..
02209       CHARACTER*(*)      SNAME
02210       INTEGER            DESCA( * ), DESCX( * ), DESCY( * )
02211 *     ..
02212 *
02213 *  Purpose
02214 *  =======
02215 *
02216 *  PSCHKARG2 checks the input-only arguments of the Level 2 PBLAS.  When
02217 *  INFO = 0, this routine makes a copy of its arguments (which are INPUT
02218 *  only arguments to PBLAS routines). Otherwise, it verifies the  values
02219 *  of these arguments against the saved copies.
02220 *
02221 *  Arguments
02222 *  =========
02223 *
02224 *  ICTXT   (local input) INTEGER
02225 *          On entry,  ICTXT  specifies the BLACS context handle, indica-
02226 *          ting the global  context of the operation. The context itself
02227 *          is global, but the value of ICTXT is local.
02228 *
02229 *  NOUT    (global input) INTEGER
02230 *          On entry, NOUT specifies the unit number for the output file.
02231 *          When NOUT is 6, output to screen,  when  NOUT is 0, output to
02232 *          stderr. NOUT is only defined for process 0.
02233 *
02234 *  SNAME   (global input) CHARACTER*(*)
02235 *          On entry, SNAME specifies the subroutine  name  calling  this
02236 *          subprogram.
02237 *
02238 *  UPLO    (global input) CHARACTER*1
02239 *          On entry, UPLO specifies the UPLO option in the Level 2 PBLAS
02240 *          operation.
02241 *
02242 *  TRANS   (global input) CHARACTER*1
02243 *          On entry,  TRANS  specifies  the TRANS  option in the Level 2
02244 *          PBLAS operation.
02245 *
02246 *  DIAG    (global input) CHARACTER*1
02247 *          On entry, DIAG specifies the DIAG option in the Level 2 PBLAS
02248 *          operation.
02249 *
02250 *  M       (global input) INTEGER
02251 *          On entry,  M  specifies  the  dimension of the submatrix ope-
02252 *          rands.
02253 *
02254 *  N       (global input) INTEGER
02255 *          On entry,  N  specifies  the  dimension of the submatrix ope-
02256 *          rands.
02257 *
02258 *  ALPHA   (global input) REAL
02259 *          On entry, ALPHA specifies the scalar alpha.
02260 *
02261 *  IA      (global input) INTEGER
02262 *          On entry, IA  specifies A's global row index, which points to
02263 *          the beginning of the submatrix sub( A ).
02264 *
02265 *  JA      (global input) INTEGER
02266 *          On entry, JA  specifies A's global column index, which points
02267 *          to the beginning of the submatrix sub( A ).
02268 *
02269 *  DESCA   (global and local input) INTEGER array
02270 *          On entry, DESCA  is an integer array of dimension DLEN_. This
02271 *          is the array descriptor for the matrix A.
02272 *
02273 *  IX      (global input) INTEGER
02274 *          On entry, IX  specifies X's global row index, which points to
02275 *          the beginning of the submatrix sub( X ).
02276 *
02277 *  JX      (global input) INTEGER
02278 *          On entry, JX  specifies X's global column index, which points
02279 *          to the beginning of the submatrix sub( X ).
02280 *
02281 *  DESCX   (global and local input) INTEGER array
02282 *          On entry, DESCX  is an integer array of dimension DLEN_. This
02283 *          is the array descriptor for the matrix X.
02284 *
02285 *  INCX    (global input) INTEGER
02286 *          On entry,  INCX   specifies  the  global  increment  for  the
02287 *          elements of  X.  Only two values of  INCX   are  supported in
02288 *          this version, namely 1 and M_X. INCX  must not be zero.
02289 *
02290 *  BETA    (global input) REAL
02291 *          On entry, BETA specifies the scalar beta.
02292 *
02293 *  IY      (global input) INTEGER
02294 *          On entry, IY  specifies Y's global row index, which points to
02295 *          the beginning of the submatrix sub( Y ).
02296 *
02297 *  JY      (global input) INTEGER
02298 *          On entry, JY  specifies Y's global column index, which points
02299 *          to the beginning of the submatrix sub( Y ).
02300 *
02301 *  DESCY   (global and local input) INTEGER array
02302 *          On entry, DESCY  is an integer array of dimension DLEN_. This
02303 *          is the array descriptor for the matrix Y.
02304 *
02305 *  INCY    (global input) INTEGER
02306 *          On entry,  INCY   specifies  the  global  increment  for  the
02307 *          elements of  Y.  Only two values of  INCY   are  supported in
02308 *          this version, namely 1 and M_Y. INCY  must not be zero.
02309 *
02310 *  INFO    (global input/global output) INTEGER
02311 *          When INFO = 0 on entry, the values of the arguments which are
02312 *          INPUT only arguments to a PBLAS routine are copied into  sta-
02313 *          tic variables and INFO is unchanged on exit.  Otherwise,  the
02314 *          values  of  the  arguments are compared against the saved co-
02315 *          pies. In case no error has been found INFO is zero on return,
02316 *          otherwise it is non zero.
02317 *
02318 *  -- Written on April 1, 1998 by
02319 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
02320 *
02321 *  =====================================================================
02322 *
02323 *     .. Parameters ..
02324       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
02325      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
02326      $                   RSRC_
02327       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
02328      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
02329      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
02330      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
02331 *     ..
02332 *     .. Local Scalars ..
02333       CHARACTER*1        DIAGREF, TRANSREF, UPLOREF
02334       INTEGER            I, IAREF, INCXREF, INCYREF, IXREF, IYREF,
02335      $                   JAREF, JXREF, JYREF, MREF, MYCOL, MYROW, NPCOL,
02336      $                   NPROW, NREF
02337       REAL               ALPHAREF, BETAREF
02338 *     ..
02339 *     .. Local Arrays ..
02340       CHARACTER*15       ARGNAME
02341       INTEGER            DESCAREF( DLEN_ ), DESCXREF( DLEN_ ),
02342      $                   DESCYREF( DLEN_ )
02343 *     ..
02344 *     .. External Subroutines ..
02345       EXTERNAL           BLACS_GRIDINFO, IGSUM2D
02346 *     ..
02347 *     .. External Functions ..
02348       LOGICAL            LSAME
02349       EXTERNAL           LSAME
02350 *     ..
02351 *     .. Save Statements ..
02352       SAVE
02353 *     ..
02354 *     .. Executable Statements ..
02355 *
02356 *     Get grid parameters
02357 *
02358       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
02359 *
02360 *     Check if first call. If yes, then save.
02361 *
02362       IF( INFO.EQ.0 ) THEN
02363 *
02364          DIAGREF = DIAG
02365          TRANSREF = TRANS
02366          UPLOREF = UPLO
02367          MREF = M
02368          NREF = N
02369          ALPHAREF = ALPHA
02370          IAREF = IA
02371          JAREF = JA
02372          DO 10 I = 1, DLEN_
02373             DESCAREF( I ) = DESCA( I )
02374    10    CONTINUE
02375          IXREF = IX
02376          JXREF = JX
02377          DO 20 I = 1, DLEN_
02378             DESCXREF( I ) = DESCX( I )
02379    20    CONTINUE
02380          INCXREF = INCX
02381          BETAREF = BETA
02382          IYREF = IY
02383          JYREF = JY
02384          DO 30 I = 1, DLEN_
02385             DESCYREF( I ) = DESCY( I )
02386    30    CONTINUE
02387          INCYREF = INCY
02388 *
02389       ELSE
02390 *
02391 *        Test saved args. Return with first mismatch.
02392 *
02393          ARGNAME = ' '
02394          IF( .NOT. LSAME( DIAG, DIAGREF ) ) THEN
02395             WRITE( ARGNAME, FMT = '(A)' ) 'DIAG'
02396          ELSE IF( .NOT. LSAME( TRANS, TRANSREF ) ) THEN
02397             WRITE( ARGNAME, FMT = '(A)' ) 'TRANS'
02398          ELSE IF( .NOT. LSAME( UPLO, UPLOREF ) ) THEN
02399             WRITE( ARGNAME, FMT = '(A)' ) 'UPLO'
02400          ELSE IF( M.NE.MREF ) THEN
02401             WRITE( ARGNAME, FMT = '(A)' ) 'M'
02402          ELSE IF( N.NE.NREF ) THEN
02403             WRITE( ARGNAME, FMT = '(A)' ) 'N'
02404          ELSE IF( ALPHA.NE.ALPHAREF ) THEN
02405             WRITE( ARGNAME, FMT = '(A)' ) 'ALPHA'
02406          ELSE IF( IA.NE.IAREF ) THEN
02407             WRITE( ARGNAME, FMT = '(A)' ) 'IA'
02408          ELSE IF( JA.NE.JAREF ) THEN
02409             WRITE( ARGNAME, FMT = '(A)' ) 'JA'
02410          ELSE IF( DESCA( DTYPE_ ).NE.DESCAREF( DTYPE_ ) ) THEN
02411             WRITE( ARGNAME, FMT = '(A)' ) 'DESCA( DTYPE_ )'
02412          ELSE IF( DESCA( M_ ).NE.DESCAREF( M_ ) ) THEN
02413             WRITE( ARGNAME, FMT = '(A)' ) 'DESCA( M_ )'
02414          ELSE IF( DESCA( N_ ).NE.DESCAREF( N_ ) ) THEN
02415             WRITE( ARGNAME, FMT = '(A)' ) 'DESCA( N_ )'
02416          ELSE IF( DESCA( IMB_ ).NE.DESCAREF( IMB_ ) ) THEN
02417             WRITE( ARGNAME, FMT = '(A)' ) 'DESCA( IMB_ )'
02418          ELSE IF( DESCA( INB_ ).NE.DESCAREF( INB_ ) ) THEN
02419             WRITE( ARGNAME, FMT = '(A)' ) 'DESCA( INB_ )'
02420          ELSE IF( DESCA( MB_ ).NE.DESCAREF( MB_ ) ) THEN
02421             WRITE( ARGNAME, FMT = '(A)' ) 'DESCA( MB_ )'
02422          ELSE IF( DESCA( NB_ ).NE.DESCAREF( NB_ ) ) THEN
02423             WRITE( ARGNAME, FMT = '(A)' ) 'DESCA( NB_ )'
02424          ELSE IF( DESCA( RSRC_ ).NE.DESCAREF( RSRC_ ) ) THEN
02425             WRITE( ARGNAME, FMT = '(A)' ) 'DESCA( RSRC_ )'
02426          ELSE IF( DESCA( CSRC_ ).NE.DESCAREF( CSRC_ ) ) THEN
02427             WRITE( ARGNAME, FMT = '(A)' ) 'DESCA( CSRC_ )'
02428          ELSE IF( DESCA( CTXT_ ).NE.DESCAREF( CTXT_ ) ) THEN
02429             WRITE( ARGNAME, FMT = '(A)' ) 'DESCA( CTXT_ )'
02430          ELSE IF( DESCA( LLD_ ).NE.DESCAREF( LLD_ ) ) THEN
02431             WRITE( ARGNAME, FMT = '(A)' ) 'DESCA( LLD_ )'
02432          ELSE IF( IX.NE.IXREF ) THEN
02433             WRITE( ARGNAME, FMT = '(A)' ) 'IX'
02434          ELSE IF( JX.NE.JXREF ) THEN
02435             WRITE( ARGNAME, FMT = '(A)' ) 'JX'
02436          ELSE IF( DESCX( DTYPE_ ).NE.DESCXREF( DTYPE_ ) ) THEN
02437             WRITE( ARGNAME, FMT = '(A)' ) 'DESCX( DTYPE_ )'
02438          ELSE IF( DESCX( M_ ).NE.DESCXREF( M_ ) ) THEN
02439             WRITE( ARGNAME, FMT = '(A)' ) 'DESCX( M_ )'
02440          ELSE IF( DESCX( N_ ).NE.DESCXREF( N_ ) ) THEN
02441             WRITE( ARGNAME, FMT = '(A)' ) 'DESCX( N_ )'
02442          ELSE IF( DESCX( IMB_ ).NE.DESCXREF( IMB_ ) ) THEN
02443             WRITE( ARGNAME, FMT = '(A)' ) 'DESCX( IMB_ )'
02444          ELSE IF( DESCX( INB_ ).NE.DESCXREF( INB_ ) ) THEN
02445             WRITE( ARGNAME, FMT = '(A)' ) 'DESCX( INB_ )'
02446          ELSE IF( DESCX( MB_ ).NE.DESCXREF( MB_ ) ) THEN
02447             WRITE( ARGNAME, FMT = '(A)' ) 'DESCX( MB_ )'
02448          ELSE IF( DESCX( NB_ ).NE.DESCXREF( NB_ ) ) THEN
02449             WRITE( ARGNAME, FMT = '(A)' ) 'DESCX( NB_ )'
02450          ELSE IF( DESCX( RSRC_ ).NE.DESCXREF( RSRC_ ) ) THEN
02451             WRITE( ARGNAME, FMT = '(A)' ) 'DESCX( RSRC_ )'
02452          ELSE IF( DESCX( CSRC_ ).NE.DESCXREF( CSRC_ ) ) THEN
02453             WRITE( ARGNAME, FMT = '(A)' ) 'DESCX( CSRC_ )'
02454          ELSE IF( DESCX( CTXT_ ).NE.DESCXREF( CTXT_ ) ) THEN
02455             WRITE( ARGNAME, FMT = '(A)' ) 'DESCX( CTXT_ )'
02456          ELSE IF( DESCX( LLD_ ).NE.DESCXREF( LLD_ ) ) THEN
02457             WRITE( ARGNAME, FMT = '(A)' ) 'DESCX( LLD_ )'
02458          ELSE IF( INCX.NE.INCXREF ) THEN
02459             WRITE( ARGNAME, FMT = '(A)' ) 'INCX'
02460          ELSE IF( BETA.NE.BETAREF ) THEN
02461             WRITE( ARGNAME, FMT = '(A)' ) 'BETA'
02462          ELSE IF( IY.NE.IYREF ) THEN
02463             WRITE( ARGNAME, FMT = '(A)' ) 'IY'
02464          ELSE IF( JY.NE.JYREF ) THEN
02465             WRITE( ARGNAME, FMT = '(A)' ) 'JY'
02466          ELSE IF( DESCY( DTYPE_ ).NE.DESCYREF( DTYPE_ ) ) THEN
02467             WRITE( ARGNAME, FMT = '(A)' ) 'DESCY( DTYPE_ )'
02468          ELSE IF( DESCY( M_ ).NE.DESCYREF( M_ ) ) THEN
02469             WRITE( ARGNAME, FMT = '(A)' ) 'DESCY( M_ )'
02470          ELSE IF( DESCY( N_ ).NE.DESCYREF( N_ ) ) THEN
02471             WRITE( ARGNAME, FMT = '(A)' ) 'DESCY( N_ )'
02472          ELSE IF( DESCY( IMB_ ).NE.DESCYREF( IMB_ ) ) THEN
02473             WRITE( ARGNAME, FMT = '(A)' ) 'DESCY( IMB_ )'
02474          ELSE IF( DESCY( INB_ ).NE.DESCYREF( INB_ ) ) THEN
02475             WRITE( ARGNAME, FMT = '(A)' ) 'DESCY( INB_ )'
02476          ELSE IF( DESCY( MB_ ).NE.DESCYREF( MB_ ) ) THEN
02477             WRITE( ARGNAME, FMT = '(A)' ) 'DESCY( MB_ )'
02478          ELSE IF( DESCY( NB_ ).NE.DESCYREF( NB_ ) ) THEN
02479             WRITE( ARGNAME, FMT = '(A)' ) 'DESCY( NB_ )'
02480          ELSE IF( DESCY( RSRC_ ).NE.DESCYREF( RSRC_ ) ) THEN
02481             WRITE( ARGNAME, FMT = '(A)' ) 'DESCY( RSRC_ )'
02482          ELSE IF( DESCY( CSRC_ ).NE.DESCYREF( CSRC_ ) ) THEN
02483             WRITE( ARGNAME, FMT = '(A)' ) 'DESCY( CSRC_ )'
02484          ELSE IF( DESCY( CTXT_ ).NE.DESCYREF( CTXT_ ) ) THEN
02485             WRITE( ARGNAME, FMT = '(A)' ) 'DESCY( CTXT_ )'
02486          ELSE IF( DESCY( LLD_ ).NE.DESCYREF( LLD_ ) ) THEN
02487             WRITE( ARGNAME, FMT = '(A)' ) 'DESCY( LLD_ )'
02488          ELSE IF( INCY.NE.INCYREF ) THEN
02489             WRITE( ARGNAME, FMT = '(A)' ) 'INCY'
02490          ELSE
02491             INFO = 0
02492          END IF
02493 *
02494          CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, INFO, 1, -1, 0 )
02495 *
02496          IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN
02497 *
02498             IF( INFO.NE.0 ) THEN
02499                WRITE( NOUT, FMT = 9999 ) ARGNAME, SNAME
02500             ELSE
02501                WRITE( NOUT, FMT = 9998 ) SNAME
02502             END IF
02503 *
02504          END IF
02505 *
02506       END IF
02507 *
02508  9999 FORMAT( 2X, '   ***** Input-only parameter check: ', A,
02509      $        ' FAILED  changed ', A, ' *****' )
02510  9998 FORMAT( 2X, '   ***** Input-only parameter check: ', A,
02511      $        ' PASSED  *****' )
02512 *
02513       RETURN
02514 *
02515 *     End of PSCHKARG2
02516 *
02517       END
02518       SUBROUTINE PSBLAS2TSTCHK( ICTXT, NOUT, NROUT, UPLO, TRANS, DIAG,
02519      $                          M, N, ALPHA, A, PA, IA, JA, DESCA, X,
02520      $                          PX, IX, JX, DESCX, INCX, BETA, Y, PY,
02521      $                          IY, JY, DESCY, INCY, THRESH, ROGUE,
02522      $                          WORK, INFO )
02523 *
02524 *  -- PBLAS test routine (version 2.0) --
02525 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
02526 *     and University of California, Berkeley.
02527 *     April 1, 1998
02528 *
02529 *     .. Scalar Arguments ..
02530       CHARACTER*1        DIAG, TRANS, UPLO
02531       INTEGER            IA, ICTXT, INCX, INCY, INFO, IX, IY, JA, JX,
02532      $                   JY, M, N, NOUT, NROUT
02533       REAL               ALPHA, BETA, ROGUE, THRESH
02534 *     ..
02535 *     .. Array Arguments ..
02536       INTEGER            DESCA( * ), DESCX( * ), DESCY( * )
02537       REAL               A( * ), PA( * ), PX( * ), PY( * ), WORK( * ),
02538      $                   X( * ), Y( * )
02539 *     ..
02540 *
02541 *  Purpose
02542 *  =======
02543 *
02544 *  PSBLAS2TSTCHK performs the computational tests of the Level 2 PBLAS.
02545 *
02546 *  Notes
02547 *  =====
02548 *
02549 *  A description  vector  is associated with each 2D block-cyclicly dis-
02550 *  tributed matrix.  This  vector  stores  the  information  required to
02551 *  establish the  mapping  between a  matrix entry and its corresponding
02552 *  process and memory location.
02553 *
02554 *  In  the  following  comments,   the character _  should  be  read  as
02555 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
02556 *  block cyclicly distributed matrix.  Its description vector is DESCA:
02557 *
02558 *  NOTATION         STORED IN       EXPLANATION
02559 *  ---------------- --------------- ------------------------------------
02560 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
02561 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
02562 *                                   the NPROW x NPCOL BLACS process grid
02563 *                                   A  is distributed over.  The context
02564 *                                   itself  is  global,  but  the handle
02565 *                                   (the integer value) may vary.
02566 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
02567 *                                   ted matrix A, M_A >= 0.
02568 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
02569 *                                   buted matrix A, N_A >= 0.
02570 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
02571 *                                   block of the matrix A, IMB_A > 0.
02572 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
02573 *                                   left   block   of   the   matrix  A,
02574 *                                   INB_A > 0.
02575 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
02576 *                                   bute the last  M_A-IMB_A rows of  A,
02577 *                                   MB_A > 0.
02578 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
02579 *                                   bute the last  N_A-INB_A  columns of
02580 *                                   A, NB_A > 0.
02581 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
02582 *                                   row of the matrix  A is distributed,
02583 *                                   NPROW > RSRC_A >= 0.
02584 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
02585 *                                   first  column of  A  is distributed.
02586 *                                   NPCOL > CSRC_A >= 0.
02587 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
02588 *                                   array  storing  the  local blocks of
02589 *                                   the distributed matrix A,
02590 *                                   IF( Lc( 1, N_A ) > 0 )
02591 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
02592 *                                   ELSE
02593 *                                      LLD_A >= 1.
02594 *
02595 *  Let K be the number of  rows of a matrix A starting at the global in-
02596 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
02597 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
02598 *  receive if these K rows were distributed over NPROW processes.  If  K
02599 *  is the number of columns of a matrix  A  starting at the global index
02600 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
02601 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
02602 *  these K columns were distributed over NPCOL processes.
02603 *
02604 *  The values of Lr() and Lc() may be determined via a call to the func-
02605 *  tion PB_NUMROC:
02606 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
02607 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
02608 *
02609 *  Arguments
02610 *  =========
02611 *
02612 *  ICTXT   (local input) INTEGER
02613 *          On entry,  ICTXT  specifies the BLACS context handle, indica-
02614 *          ting the global  context of the operation. The context itself
02615 *          is global, but the value of ICTXT is local.
02616 *
02617 *  NOUT    (global input) INTEGER
02618 *          On entry, NOUT specifies the unit number for the output file.
02619 *          When NOUT is 6, output to screen,  when  NOUT is 0, output to
02620 *          stderr. NOUT is only defined for process 0.
02621 *
02622 *  NROUT   (global input) INTEGER
02623 *          On entry,  NROUT  specifies  which  routine will be tested as
02624 *          follows:
02625 *             If NROUT = 1,      PSGEMV will be tested;
02626 *             else if NROUT = 2, PSSYMV will be tested;
02627 *             else if NROUT = 3, PSTRMV will be tested;
02628 *             else if NROUT = 4, PSTRSV will be tested;
02629 *             else if NROUT = 5, PSGER  will be tested;
02630 *             else if NROUT = 6, PSSYR  will be tested;
02631 *             else if NROUT = 7, PSSYR2 will be tested;
02632 *
02633 *  UPLO    (global input) CHARACTER*1
02634 *          On entry,  UPLO  specifies  if the upper or lower part of the
02635 *          matrix operand is to be referenced.
02636 *
02637 *  TRANS   (global input) CHARACTER*1
02638 *          On entry, TRANS  specifies if the matrix  operand  A is to be
02639 *          transposed.
02640 *
02641 *  DIAG    (global input) CHARACTER*1
02642 *          On entry, DIAG specifies if the  triangular matrix operand is
02643 *          unit or non-unit.
02644 *
02645 *  M       (global input) INTEGER
02646 *          On entry, M specifies the number of rows of A.
02647 *
02648 *  N       (global input) INTEGER
02649 *          On entry, N specifies the number of columns of A.
02650 *
02651 *  ALPHA   (global input) REAL
02652 *          On entry, ALPHA specifies the scalar alpha.
02653 *
02654 *  A       (local input/local output) REAL array
02655 *          On entry, A is an array of  dimension  (DESCA( M_ ),*).  This
02656 *          array contains a local copy of the initial entire matrix PA.
02657 *
02658 *  PA      (local input) REAL array
02659 *          On entry, PA is an array of dimension (DESCA( LLD_ ),*). This
02660 *          array contains the local entries of the matrix PA.
02661 *
02662 *  IA      (global input) INTEGER
02663 *          On entry, IA  specifies A's global row index, which points to
02664 *          the beginning of the submatrix sub( A ).
02665 *
02666 *  JA      (global input) INTEGER
02667 *          On entry, JA  specifies A's global column index, which points
02668 *          to the beginning of the submatrix sub( A ).
02669 *
02670 *  DESCA   (global and local input) INTEGER array
02671 *          On entry, DESCA  is an integer array of dimension DLEN_. This
02672 *          is the array descriptor for the matrix A.
02673 *
02674 *  X       (local input/local output) REAL array
02675 *          On entry, X is an array of  dimension  (DESCX( M_ ),*).  This
02676 *          array contains a local copy of the initial entire matrix PX.
02677 *
02678 *  PX      (local input) REAL array
02679 *          On entry, PX is an array of dimension (DESCX( LLD_ ),*). This
02680 *          array contains the local entries of the matrix PX.
02681 *
02682 *  IX      (global input) INTEGER
02683 *          On entry, IX  specifies X's global row index, which points to
02684 *          the beginning of the submatrix sub( X ).
02685 *
02686 *  JX      (global input) INTEGER
02687 *          On entry, JX  specifies X's global column index, which points
02688 *          to the beginning of the submatrix sub( X ).
02689 *
02690 *  DESCX   (global and local input) INTEGER array
02691 *          On entry, DESCX  is an integer array of dimension DLEN_. This
02692 *          is the array descriptor for the matrix X.
02693 *
02694 *  INCX    (global input) INTEGER
02695 *          On entry,  INCX   specifies  the  global  increment  for  the
02696 *          elements of  X.  Only two values of  INCX   are  supported in
02697 *          this version, namely 1 and M_X. INCX  must not be zero.
02698 *
02699 *  BETA    (global input) REAL
02700 *          On entry, BETA specifies the scalar beta.
02701 *
02702 *  Y       (local input/local output) REAL array
02703 *          On entry, Y is an array of  dimension  (DESCY( M_ ),*).  This
02704 *          array contains a local copy of the initial entire matrix PY.
02705 *
02706 *  PY      (local input) REAL array
02707 *          On entry, PY is an array of dimension (DESCY( LLD_ ),*). This
02708 *          array contains the local entries of the matrix PY.
02709 *
02710 *  IY      (global input) INTEGER
02711 *          On entry, IY  specifies Y's global row index, which points to
02712 *          the beginning of the submatrix sub( Y ).
02713 *
02714 *  JY      (global input) INTEGER
02715 *          On entry, JY  specifies Y's global column index, which points
02716 *          to the beginning of the submatrix sub( Y ).
02717 *
02718 *  DESCY   (global and local input) INTEGER array
02719 *          On entry, DESCY  is an integer array of dimension DLEN_. This
02720 *          is the array descriptor for the matrix Y.
02721 *
02722 *  INCY    (global input) INTEGER
02723 *          On entry,  INCY   specifies  the  global  increment  for  the
02724 *          elements of  Y.  Only two values of  INCY   are  supported in
02725 *          this version, namely 1 and M_Y. INCY  must not be zero.
02726 *
02727 *  THRESH  (global input) REAL
02728 *          On entry, THRESH is the threshold value for the test ratio.
02729 *
02730 *  ROGUE   (global input) REAL
02731 *          On entry,  ROGUE  specifies  the  constant  used  to  pad the
02732 *          non-referenced part of triangular or symmetric matrices.
02733 *
02734 *  WORK    (workspace) REAL array
02735 *          On entry, WORK  is an array of dimension LWORK where LWORK is
02736 *          at least  MAX( M, N ). This array is used to store the compu-
02737 *          ted gauges (see PSMVCH).
02738 *
02739 *  INFO    (global output) INTEGER
02740 *          On exit, if INFO = 0,  no  error  has  been  found, otherwise
02741 *          if( MOD( INFO,   2 ) = 1 ) then an error on A has been found,
02742 *          if( MOD( INFO/2, 2 ) = 1 ) then an error on X has been found,
02743 *          if( MOD( INFO/4, 2 ) = 1 ) then an error on Y has been found.
02744 *
02745 *  -- Written on April 1, 1998 by
02746 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
02747 *
02748 *  =====================================================================
02749 *
02750 *     .. Parameters ..
02751       REAL               ONE, ZERO
02752       PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
02753       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
02754      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
02755      $                   RSRC_
02756       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
02757      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
02758      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
02759      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
02760 *     ..
02761 *     .. Local Scalars ..
02762       INTEGER            I, MYCOL, MYROW, NPCOL, NPROW
02763       REAL               ERR
02764 *     ..
02765 *     .. Local Arrays ..
02766       INTEGER            IERR( 3 )
02767 *     ..
02768 *     .. External Subroutines ..
02769       EXTERNAL           BLACS_GRIDINFO, PB_SLASET, PSCHKMIN, PSCHKVIN,
02770      $                   PSMVCH, PSTRMV, PSVMCH, PSVMCH2, STRSV
02771 *     ..
02772 *     .. External Functions ..
02773       LOGICAL            LSAME
02774       EXTERNAL           LSAME
02775 *     ..
02776 *     .. Executable Statements ..
02777 *
02778       INFO = 0
02779 *
02780 *     Quick return if possible
02781 *
02782       IF( ( M.LE.0 ).OR.( N.LE.0 ) )
02783      $   RETURN
02784 *
02785 *     Start the operations
02786 *
02787       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
02788 *
02789       DO 10 I = 1, 3
02790          IERR( I ) = 0
02791    10 CONTINUE
02792 *
02793       IF( NROUT.EQ.1 ) THEN
02794 *
02795 *        Test PSGEMV
02796 *
02797 *        Check the resulting vector Y
02798 *
02799          CALL PSMVCH( ICTXT, TRANS, M, N, ALPHA, A, IA, JA, DESCA, X,
02800      $                IX, JX, DESCX, INCX, BETA, Y, PY, IY, JY, DESCY,
02801      $                INCY, WORK, ERR, IERR( 3 ) )
02802 *
02803          IF( IERR( 3 ).NE.0 ) THEN
02804             IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 )
02805      $         WRITE( NOUT, FMT = 9997 )
02806          ELSE IF( ERR.GT.THRESH ) THEN
02807             IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 )
02808      $         WRITE( NOUT, FMT = 9996 ) ERR
02809          END IF
02810 *
02811 *        Check the input-only arguments
02812 *
02813          CALL PSCHKMIN( ERR, M, N, A, PA, IA, JA, DESCA, IERR( 1 ) )
02814          IF( LSAME( TRANS, 'N' ) ) THEN
02815             CALL PSCHKVIN( ERR, N, X, PX, IX, JX, DESCX, INCX,
02816      $                     IERR( 2 ) )
02817          ELSE
02818             CALL PSCHKVIN( ERR, M, X, PX, IX, JX, DESCX, INCX,
02819      $                     IERR( 2 ) )
02820          END IF
02821 *
02822       ELSE IF( NROUT.EQ.2 ) THEN
02823 *
02824 *        Test PSSYMV
02825 *
02826 *        Check the resulting vector Y
02827 *
02828          CALL PSMVCH( ICTXT, 'No transpose', N, N, ALPHA, A, IA, JA,
02829      $                DESCA, X, IX, JX, DESCX, INCX, BETA, Y, PY, IY,
02830      $                JY, DESCY, INCY, WORK, ERR, IERR( 3 ) )
02831 *
02832          IF( IERR( 3 ).NE.0 ) THEN
02833             IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 )
02834      $         WRITE( NOUT, FMT = 9997 )
02835          ELSE IF( ERR.GT.THRESH ) THEN
02836             IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 )
02837      $         WRITE( NOUT, FMT = 9996 ) ERR
02838          END IF
02839 *
02840 *        Check the input-only arguments
02841 *
02842          IF( LSAME( UPLO, 'L' ) ) THEN
02843             CALL PB_SLASET( 'Upper', N-1, N-1, 0, ROGUE, ROGUE,
02844      $                      A( IA+JA*DESCA( M_ ) ), DESCA( M_ ) )
02845          ELSE
02846             CALL PB_SLASET( 'Lower', N-1, N-1, 0, ROGUE, ROGUE,
02847      $                      A( IA+1+(JA-1)*DESCA( M_ ) ), DESCA( M_ ) )
02848          END IF
02849          CALL PSCHKMIN( ERR, N, N, A, PA, IA, JA, DESCA, IERR( 1 ) )
02850          CALL PSCHKVIN( ERR, N, X, PX, IX, JX, DESCX, INCX, IERR( 2 ) )
02851 *
02852       ELSE IF( NROUT.EQ.3 ) THEN
02853 *
02854 *        Test PSTRMV
02855 *
02856 *        Check the resulting vector X
02857 *
02858          CALL PSMVCH( ICTXT, TRANS, N, N, ONE, A, IA, JA, DESCA, Y, IX,
02859      $                JX, DESCX, INCX, ZERO, X, PX, IX, JX, DESCX, INCX,
02860      $                WORK, ERR, IERR( 2 ) )
02861 *
02862          IF( IERR( 2 ).NE.0 ) THEN
02863             IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 )
02864      $         WRITE( NOUT, FMT = 9997 )
02865          ELSE IF( ERR.GT.THRESH ) THEN
02866             IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 )
02867      $         WRITE( NOUT, FMT = 9996 ) ERR
02868          END IF
02869 *
02870 *        Check the input-only arguments
02871 *
02872          IF( LSAME( UPLO, 'L' ) ) THEN
02873             IF( LSAME( DIAG, 'N' ) ) THEN
02874                CALL PB_SLASET( 'Upper', N-1, N-1, 0, ROGUE, ROGUE,
02875      $                         A( IA+JA*DESCA( M_ ) ), DESCA( M_ ) )
02876             ELSE
02877                CALL PB_SLASET( 'Upper', N, N, 0, ROGUE, ONE,
02878      $                         A( IA+(JA-1)*DESCA( M_ ) ), DESCA( M_ ) )
02879             END IF
02880          ELSE
02881             IF( LSAME( DIAG, 'N' ) ) THEN
02882                CALL PB_SLASET( 'Lower', N-1, N-1, 0, ROGUE, ROGUE,
02883      $                         A( IA+1+(JA-1)*DESCA( M_ ) ),
02884      $                         DESCA( M_ ) )
02885             ELSE
02886                CALL PB_SLASET( 'Lower', N, N, 0, ROGUE, ONE,
02887      $                         A( IA+(JA-1)*DESCA( M_ ) ), DESCA( M_ ) )
02888             END IF
02889          END IF
02890          CALL PSCHKMIN( ERR, N, N, A, PA, IA, JA, DESCA, IERR( 1 ) )
02891 *
02892       ELSE IF( NROUT.EQ.4 ) THEN
02893 *
02894 *        Test PSTRSV
02895 *
02896 *        Check the resulting vector X
02897 *
02898          CALL STRSV( UPLO, TRANS, DIAG, N, A( IA+(JA-1)*DESCA( M_ ) ),
02899      $               DESCA( M_ ), X( IX+(JX-1)*DESCX( M_ ) ), INCX )
02900          CALL PSTRMV( UPLO, TRANS, DIAG, N, PA, IA, JA, DESCA, PX, IX,
02901      $                JX, DESCX, INCX )
02902          CALL PSMVCH( ICTXT, TRANS, N, N, ONE, A, IA, JA, DESCA, X, IX,
02903      $                JX, DESCX, INCX, ZERO, Y, PX, IX, JX, DESCX, INCX,
02904      $                WORK, ERR, IERR( 2 ) )
02905 *
02906          IF( IERR( 2 ).NE.0 ) THEN
02907             IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 )
02908      $         WRITE( NOUT, FMT = 9997 )
02909          ELSE IF( ERR.GT.THRESH ) THEN
02910             IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 )
02911      $         WRITE( NOUT, FMT = 9996 ) ERR
02912          END IF
02913 *
02914 *        Check the input-only arguments
02915 *
02916          IF( LSAME( UPLO, 'L' ) ) THEN
02917             IF( LSAME( DIAG, 'N' ) ) THEN
02918                CALL PB_SLASET( 'Upper', N-1, N-1, 0, ROGUE, ROGUE,
02919      $                         A( IA+JA*DESCA( M_ ) ), DESCA( M_ ) )
02920             ELSE
02921                CALL PB_SLASET( 'Upper', N, N, 0, ROGUE, ONE,
02922      $                         A( IA+(JA-1)*DESCA( M_ ) ), DESCA( M_ ) )
02923             END IF
02924          ELSE
02925             IF( LSAME( DIAG, 'N' ) ) THEN
02926                CALL PB_SLASET( 'Lower', N-1, N-1, 0, ROGUE, ROGUE,
02927      $                         A( IA+1+(JA-1)*DESCA( M_ ) ),
02928      $                         DESCA( M_ ) )
02929             ELSE
02930                CALL PB_SLASET( 'Lower', N, N, 0, ROGUE, ONE,
02931      $                         A( IA+(JA-1)*DESCA( M_ ) ), DESCA( M_ ) )
02932             END IF
02933          END IF
02934          CALL PSCHKMIN( ERR, N, N, A, PA, IA, JA, DESCA, IERR( 1 ) )
02935 *
02936       ELSE IF( NROUT.EQ.5 ) THEN
02937 *
02938 *        Test PSGER
02939 *
02940 *        Check the resulting matrix A
02941 *
02942          CALL PSVMCH( ICTXT, 'Ge', M, N, ALPHA, X, IX, JX, DESCX,
02943      $                INCX, Y, IY, JY, DESCY, INCY, A, PA, IA, JA,
02944      $                DESCA, WORK, ERR, IERR( 1 ) )
02945          IF( IERR( 1 ).NE.0 ) THEN
02946             IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 )
02947      $         WRITE( NOUT, FMT = 9997 )
02948          ELSE IF( ERR.GT.THRESH ) THEN
02949             IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 )
02950      $         WRITE( NOUT, FMT = 9996 ) ERR
02951          END IF
02952 *
02953 *        Check the input-only arguments
02954 *
02955          CALL PSCHKVIN( ERR, M, X, PX, IX, JX, DESCX, INCX, IERR( 2 ) )
02956          CALL PSCHKVIN( ERR, N, Y, PY, IY, JY, DESCY, INCY, IERR( 3 ) )
02957 *
02958       ELSE IF( NROUT.EQ.6 ) THEN
02959 *
02960 *        Test PSSYR
02961 *
02962 *        Check the resulting matrix A
02963 *
02964          CALL PSVMCH( ICTXT, UPLO, N, N, ALPHA, X, IX, JX, DESCX,
02965      $                INCX, X, IX, JX, DESCX, INCX, A, PA, IA, JA,
02966      $                DESCA, WORK, ERR, IERR( 1 ) )
02967          IF( IERR( 1 ).NE.0 ) THEN
02968             IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 )
02969      $         WRITE( NOUT, FMT = 9997 )
02970          ELSE IF( ERR.GT.THRESH ) THEN
02971             IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 )
02972      $         WRITE( NOUT, FMT = 9996 ) ERR
02973          END IF
02974 *
02975 *        Check the input-only arguments
02976 *
02977          CALL PSCHKVIN( ERR, N, X, PX, IX, JX, DESCX, INCX, IERR( 2 ) )
02978 *
02979       ELSE IF( NROUT.EQ.7 ) THEN
02980 *
02981 *        Test PSSYR2
02982 *
02983 *        Check the resulting matrix A
02984 *
02985          CALL PSVMCH2( ICTXT, UPLO, N, N, ALPHA, X, IX, JX, DESCX, INCX,
02986      $                 Y, IY, JY, DESCY, INCY, A, PA, IA, JA, DESCA,
02987      $                 WORK, ERR, IERR( 1 ) )
02988          IF( IERR( 1 ).NE.0 ) THEN
02989             IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 )
02990      $         WRITE( NOUT, FMT = 9997 )
02991          ELSE IF( ERR.GT.THRESH ) THEN
02992             IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 )
02993      $         WRITE( NOUT, FMT = 9996 ) ERR
02994          END IF
02995 *
02996 *        Check the input-only arguments
02997 *
02998          CALL PSCHKVIN( ERR, N, X, PX, IX, JX, DESCX, INCX, IERR( 2 ) )
02999          CALL PSCHKVIN( ERR, N, Y, PY, IY, JY, DESCY, INCY, IERR( 3 ) )
03000 *
03001       END IF
03002 *
03003       IF( IERR( 1 ).NE.0 ) THEN
03004          INFO = INFO + 1
03005          IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 )
03006      $      WRITE( NOUT, FMT = 9999 ) 'A'
03007       END IF
03008 *
03009       IF( IERR( 2 ).NE.0 ) THEN
03010          INFO = INFO + 2
03011          IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 )
03012      $      WRITE( NOUT, FMT = 9998 ) 'X'
03013       END IF
03014 *
03015       IF( IERR( 3 ).NE.0 ) THEN
03016          INFO = INFO + 4
03017          IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 )
03018      $      WRITE( NOUT, FMT = 9998 ) 'Y'
03019       END IF
03020 *
03021  9999 FORMAT( 2X, '   ***** ERROR: Matrix operand ', A,
03022      $        ' is incorrect.' )
03023  9998 FORMAT( 2X, '   ***** ERROR: Vector operand ', A,
03024      $        ' is incorrect.' )
03025  9997 FORMAT( 2X, '   ***** FATAL ERROR - Computed result is less ',
03026      $        'than half accurate *****' )
03027  9996 FORMAT( 2X, '   ***** Test completed with maximum test ratio: ',
03028      $        F11.5, ' SUSPECT *****' )
03029 *
03030       RETURN
03031 *
03032 *     End of PSBLAS2TSTCHK
03033 *
03034       END