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