ScaLAPACK  2.0.2
ScaLAPACK: Scalable Linear Algebra PACKage
blacstest.f
Go to the documentation of this file.
00001       PROGRAM BLACSTEST
00002 *
00003 *  -- BLACS tester (version 1.0) --
00004 *  University of Tennessee
00005 *  December 15, 1994
00006 *
00007 *  Purpose
00008 *  =======
00009 *  This is the driver for the BLACS test suite.
00010 *
00011 *  Arguments
00012 *  =========
00013 *  None.  Input is done via the data files indicated below.
00014 *
00015 *  Input Files
00016 *  ===========
00017 *  The following input files must reside in the current working
00018 *  directory:
00019 *
00020 *  bt.dat   -- input parameters for the test run as a whole
00021 *  sdrv.dat -- input parameters for point-to-point testing
00022 *  bsbr.dat -- input parameters for broadcast testing
00023 *  comb.dat -- input parameters for combine testing
00024 *
00025 *  Output Files
00026 *  ============
00027 *  Test results are generated and sent to output file as
00028 *  specified by the user in bt.dat.
00029 *
00030 *  ===================================================================
00031 *
00032 *     .. Parameters ..
00033       INTEGER CMEMSIZ, MEMELTS
00034       PARAMETER( MEMELTS = 250000 )
00035       PARAMETER( CMEMSIZ = 10000 )
00036 *     ..
00037 *     .. External Functions ..
00038       LOGICAL ALLPASS
00039       INTEGER IBTMSGID, IBTSIZEOF
00040       REAL SBTEPS
00041       DOUBLE PRECISION DBTEPS
00042       EXTERNAL ALLPASS, IBTMSGID, SBTEPS, DBTEPS, IBTSIZEOF
00043 *     ..
00044 *     .. External Subroutines ..
00045       EXTERNAL BLACS_PINFO, BTSETUP, RDBTIN
00046 *     ..
00047 *     .. Local Scalars ..
00048       INTEGER I, IAM, NNODES, VERB, OUTNUM, MEMLEN, NPREC, ISIZE, DSIZE
00049       LOGICAL TESTSDRV, TESTBSBR, TESTCOMB, TESTAUX
00050 *     ..
00051 *     .. Local Arrays ..
00052       CHARACTER*1 CMEM(CMEMSIZ), PREC(9)
00053       INTEGER IPREC(9), ITMP(2)
00054       DOUBLE PRECISION MEM(MEMELTS)
00055 *     ..
00056 *     .. Executable Statements ..
00057 *
00058       ISIZE = IBTSIZEOF('I')
00059       DSIZE = IBTSIZEOF('D')
00060 *
00061 *     Get initial process information, and initialize message IDs
00062 *
00063       CALL BLACS_PINFO( IAM, NNODES )
00064       ITMP(1) = IBTMSGID()
00065 *
00066 *     Call BLACS_GRIDINIT so BLACS set up some system stuff:  should
00067 *     make it possible for the user to print, read input files, etc.
00068 *
00069       IF( NNODES .GT. 0 ) THEN
00070          CALL BLACS_GET( 0, 0, ITMP )
00071          CALL BLACS_GRIDINIT(ITMP, 'c', 1, NNODES)
00072          CALL BLACS_GRIDEXIT(ITMP)
00073       END IF
00074 *
00075 *     Read in what tests to do
00076 *
00077       IF( IAM .EQ. 0 )
00078      $   CALL RDBTIN( TESTSDRV, TESTBSBR, TESTCOMB, TESTAUX, NPREC,
00079      $               PREC, VERB, OUTNUM )
00080 *
00081       MEMLEN = (MEMELTS * DSIZE) / ISIZE
00082 *
00083 *     Get process info for communication, and create virtual machine
00084 *     if necessary
00085 *
00086       CALL BTSETUP( MEM, MEMLEN, CMEM, CMEMSIZ, OUTNUM, TESTSDRV,
00087      $              TESTBSBR, TESTCOMB, TESTAUX, IAM, NNODES )
00088 *
00089 *     Send out RDBTIN information
00090 *
00091       IF( IAM .EQ. 0 ) THEN
00092 *
00093 *        Store test info in back of precision array
00094 *
00095          ITMP(1) = NPREC
00096          ITMP(2) = VERB
00097          CALL BTSEND( 3, 2, ITMP, -1, IBTMSGID() )
00098          DO 10 I = 1, 9
00099             IPREC(I) = 0
00100    10    CONTINUE
00101          DO 20 I = 1, NPREC
00102             IF( PREC(I) .EQ. 'I' ) THEN
00103                IPREC(I) = 1
00104             ELSE IF( PREC(I) .EQ. 'S' ) THEN
00105                IPREC(I) = 2
00106             ELSE IF( PREC(I) .EQ. 'D' ) THEN
00107                IPREC(I) = 3
00108             ELSE IF( PREC(I) .EQ. 'C' ) THEN
00109                IPREC(I) = 4
00110             ELSE IF( PREC(I) .EQ. 'Z' ) THEN
00111                IPREC(I) = 5
00112             END IF
00113    20    CONTINUE
00114          IF( TESTSDRV ) IPREC(6) = 1
00115          IF( TESTBSBR ) IPREC(7) = 1
00116          IF( TESTCOMB ) IPREC(8) = 1
00117          IF( TESTAUX )  IPREC(9) = 1
00118          CALL BTSEND( 3, 9, IPREC, -1, IBTMSGID()+1 )
00119       ELSE
00120          CALL BTRECV( 3, 2, ITMP, 0, IBTMSGID() )
00121          NPREC = ITMP(1)
00122          VERB = ITMP(2)
00123          CALL BTRECV( 3, 9, IPREC, 0, IBTMSGID()+1 )
00124          DO 30 I = 1, NPREC
00125             IF( IPREC(I) .EQ. 1 ) THEN
00126                PREC(I) = 'I'
00127             ELSE IF( IPREC(I) .EQ. 2 ) THEN
00128                PREC(I) = 'S'
00129             ELSE IF( IPREC(I) .EQ. 3 ) THEN
00130                PREC(I) = 'D'
00131             ELSE IF( IPREC(I) .EQ. 4 ) THEN
00132                PREC(I) = 'C'
00133             ELSE IF( IPREC(I) .EQ. 5 ) THEN
00134                PREC(I) = 'Z'
00135             END IF
00136    30    CONTINUE
00137          TESTSDRV = ( IPREC(6) .EQ. 1 )
00138          TESTBSBR = ( IPREC(7) .EQ. 1 )
00139          TESTCOMB = ( IPREC(8) .EQ. 1 )
00140          TESTAUX  = ( IPREC(9) .EQ. 1 )
00141       ENDIF
00142 *
00143       IF( TESTSDRV .OR. TESTBSBR .OR. TESTCOMB .OR. TESTAUX ) THEN
00144 *
00145 *        Find maximal machine epsilon for single and double precision
00146 *
00147          ITMP(1) = INT( SBTEPS() )
00148          ITMP(1) = INT( DBTEPS() )
00149 *
00150          CALL RUNTESTS( MEM, MEMLEN, CMEM, CMEMSIZ, PREC, NPREC, OUTNUM,
00151      $                  VERB, TESTSDRV, TESTBSBR, TESTCOMB, TESTAUX )
00152 *
00153       END IF
00154 *
00155       IF( IAM .EQ. 0 ) THEN
00156          WRITE(OUTNUM,*) ' '
00157          WRITE(OUTNUM,1000)
00158          WRITE(OUTNUM,1000)
00159          IF( ALLPASS(.TRUE.) ) THEN
00160             WRITE(OUTNUM,2000) 'NO'
00161          ELSE
00162             WRITE(OUTNUM,2000) '  '
00163          END IF
00164          WRITE(OUTNUM,1000)
00165          WRITE(OUTNUM,1000)
00166          IF( OUTNUM.NE.0 .AND. OUTNUM.NE.6 ) CLOSE(OUTNUM)
00167       ENDIF
00168 *
00169       CALL BLACS_EXIT(0)
00170  1000 FORMAT('=======================================')
00171  2000 FORMAT('THERE WERE ',A2,' FAILURES IN THIS TEST RUN')
00172       STOP
00173 *
00174 *     End BLACSTESTER
00175 *
00176       END
00177 *
00178       SUBROUTINE RUNTESTS( MEM, MEMLEN, CMEM, CMEMLEN, PREC, NPREC,
00179      $                     OUTNUM, VERB, TESTSDRV, TESTBSBR, TESTCOMB,
00180      $                     TESTAUX )
00181 *
00182 *     .. Scalar Arguments ..
00183       INTEGER MEMLEN, CMEMLEN, NPREC, OUTNUM, VERB, IAM, NNODES
00184       LOGICAL TESTSDRV, TESTBSBR, TESTCOMB, TESTAUX
00185 *     ..
00186 *     .. Array Arguments ..
00187       CHARACTER*1 CMEM(CMEMLEN), PREC(NPREC)
00188       INTEGER MEM(MEMLEN)
00189 *     ..
00190 *     .. External Functions ..
00191       INTEGER  IBTNPROCS, IBTMYPROC, IBTMSGID, IBTSIZEOF, SAFEINDEX
00192       EXTERNAL IBTNPROCS, IBTMYPROC, IBTMSGID, IBTSIZEOF, SAFEINDEX
00193 *     ..
00194 *     .. External Subroutines ..
00195       EXTERNAL CSDRVTEST, DSDRVTEST, ISDRVTEST, SSDRVTEST, ZSDRVTEST
00196       EXTERNAL CBSBRTEST, DBSBRTEST, IBSBRTEST, SBSBRTEST, ZBSBRTEST
00197       EXTERNAL ISUMTEST, SSUMTEST, DSUMTEST, CSUMTEST, ZSUMTEST
00198       EXTERNAL IAMXTEST, SAMXTEST, DAMXTEST, CAMXTEST, ZAMXTEST
00199       EXTERNAL IAMNTEST, SAMNTEST, DAMNTEST, CAMNTEST, ZAMNTEST
00200       EXTERNAL AUXTEST, BTSEND, BTRECV, BTINFO
00201 *     ..
00202 *     .. Local Scalars ..
00203       INTEGER NSCOPE, NOP, NTOP, NSHAPE, NMAT, NSRC, NDEST, NGRID
00204       INTEGER TREP, TCOH, OPPTR, SCOPEPTR, TOPPTR, UPLOPTR, DIAGPTR
00205       INTEGER MPTR, NPTR, LDSPTR, LDDPTR, LDIPTR
00206       INTEGER RSRCPTR, CSRCPTR, RDESTPTR, CDESTPTR, PPTR, QPTR
00207       INTEGER ISEEDPTR, RAPTR, CAPTR, CTXTPTR, WORKPTR, WORKLEN
00208       INTEGER MEMUSED, CMEMUSED, I, J, K
00209       INTEGER ISIZE, SSIZE, DSIZE, CSIZE, ZSIZE
00210 *     ..
00211 *     .. Local Arrays ..
00212       INTEGER ITMP(4)
00213 *     ..
00214 *     .. Executable Statements ..
00215 *
00216       IAM = IBTMYPROC()
00217       NNODES = IBTNPROCS()
00218       ISIZE = IBTSIZEOF('I')
00219       SSIZE = IBTSIZEOF('S')
00220       DSIZE = IBTSIZEOF('D')
00221       CSIZE = IBTSIZEOF('C')
00222       ZSIZE = IBTSIZEOF('Z')
00223 *
00224       IF( IAM.EQ.0 ) THEN
00225          CALL BLACS_GET( 0, 2, I )
00226          WRITE(OUTNUM,3000)
00227          WRITE(OUTNUM,3000)
00228          WRITE(OUTNUM,2000) I
00229          WRITE(OUTNUM,3000)
00230          WRITE(OUTNUM,3000)
00231       END IF
00232 *
00233       IF( TESTAUX ) THEN
00234 *
00235 *        Each process will make sure that BLACS_PINFO returns
00236 *        the same value as BLACS_SETUP, and send a packet
00237 *        to node 0 saying whether it was.
00238 *
00239          CALL BLACS_PINFO( ITMP(1), ITMP(3) )
00240          CALL BLACS_SETUP( ITMP(2), ITMP(4) )
00241          IF( IAM .EQ. 0 ) THEN
00242             DO 35 I = 0, NNODES-1
00243                IF( I .NE. 0 )
00244      $            CALL BTRECV( 3, 4, ITMP, I, IBTMSGID()+2 )
00245                IF( ITMP(1) .NE. ITMP(2) )
00246      $              WRITE( OUTNUM, 1000 ) ITMP(1), ITMP(2)
00247                IF( (ITMP(3).NE.ITMP(4)) .OR. (ITMP(3).NE.NNODES) )
00248      $              WRITE( OUTNUM, 1000 ) ITMP(3), ITMP(4), NNODES
00249    35       CONTINUE
00250          ELSE
00251             CALL BTSEND( 3, 4, ITMP, 0, IBTMSGID()+2 )
00252          ENDIF
00253       ENDIF
00254 *
00255 *     Run point-to-point tests as appropriate
00256 *
00257       IF( TESTSDRV ) THEN
00258 *
00259 *        Get test info
00260 *
00261          CALL BTINFO( 'SDRV', MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM,
00262      $                CMEMLEN, OUTNUM, NOP, NSCOPE, TREP, TCOH, NTOP,
00263      $                NSHAPE, NMAT, NSRC, NGRID, OPPTR, SCOPEPTR,
00264      $                TOPPTR, UPLOPTR, DIAGPTR, MPTR, NPTR, LDSPTR,
00265      $                LDDPTR, LDIPTR, RSRCPTR, CSRCPTR, RDESTPTR,
00266      $                CDESTPTR, PPTR, QPTR )
00267 *
00268 *        iseedptr used as tests passed/failed array, so it must
00269 *        be of size NTESTS -- It's not used unless VERB < 2
00270 *
00271          CTXTPTR = MEMUSED + 1
00272          ISEEDPTR = CTXTPTR + NGRID
00273          MEMUSED = ISEEDPTR - 1
00274          IF( VERB .LT. 2 )
00275      $      MEMUSED = MEMUSED + NSHAPE * NMAT * NSRC * NGRID
00276 *
00277          CALL MAKEGRIDS( MEM(CTXTPTR), OUTNUM, NGRID, MEM(PPTR),
00278      $                   MEM(QPTR) )
00279 *
00280 *        Call individual tests as appropriate.
00281 *
00282          DO 10 I = 1, NPREC
00283             IF( PREC(I) .EQ. 'I' ) THEN
00284 *
00285                WORKPTR = SAFEINDEX(MEMUSED + 1, ISIZE, ISIZE)
00286                WORKLEN = ( DSIZE * (MEMLEN - WORKPTR + 1) ) / ISIZE
00287                CALL ISDRVTEST(OUTNUM, VERB, NSHAPE, CMEM(UPLOPTR),
00288      $                        CMEM(DIAGPTR), NMAT, MEM(MPTR),
00289      $                        MEM(NPTR), MEM(LDSPTR), MEM(LDDPTR),
00290      $                        NSRC, MEM(RSRCPTR), MEM(CSRCPTR),
00291      $                        MEM(RDESTPTR), MEM(CDESTPTR),
00292      $                        NGRID, MEM(CTXTPTR), MEM(PPTR), MEM(QPTR),
00293      $                        MEM(ISEEDPTR), MEM(WORKPTR), WORKLEN)
00294 *
00295             ELSE IF( PREC(I) .EQ. 'S' ) THEN
00296 *
00297                WORKPTR = SAFEINDEX(MEMUSED + 1, ISIZE, SSIZE)
00298                WORKLEN = ( DSIZE * (MEMLEN - WORKPTR + 1) ) / SSIZE
00299                CALL SSDRVTEST(OUTNUM, VERB, NSHAPE, CMEM(UPLOPTR),
00300      $                        CMEM(DIAGPTR), NMAT, MEM(MPTR),
00301      $                        MEM(NPTR), MEM(LDSPTR), MEM(LDDPTR),
00302      $                        NSRC, MEM(RSRCPTR), MEM(CSRCPTR),
00303      $                        MEM(RDESTPTR), MEM(CDESTPTR),
00304      $                        NGRID, MEM(CTXTPTR), MEM(PPTR), MEM(QPTR),
00305      $                        MEM(ISEEDPTR), MEM(WORKPTR), WORKLEN)
00306 *
00307             ELSE IF( PREC(I) .EQ. 'D' ) THEN
00308 *
00309                WORKPTR = SAFEINDEX(MEMUSED + 1, ISIZE, DSIZE)
00310                WORKLEN = ( DSIZE * (MEMLEN - WORKPTR + 1) ) / DSIZE
00311                CALL DSDRVTEST(OUTNUM, VERB, NSHAPE, CMEM(UPLOPTR),
00312      $                        CMEM(DIAGPTR), NMAT, MEM(MPTR),
00313      $                        MEM(NPTR), MEM(LDSPTR), MEM(LDDPTR),
00314      $                        NSRC, MEM(RSRCPTR), MEM(CSRCPTR),
00315      $                        MEM(RDESTPTR), MEM(CDESTPTR),
00316      $                        NGRID, MEM(CTXTPTR), MEM(PPTR), MEM(QPTR),
00317      $                        MEM(ISEEDPTR), MEM(WORKPTR), WORKLEN)
00318 *
00319             ELSE IF( PREC(I) .EQ. 'C' ) THEN
00320 *
00321                WORKPTR = SAFEINDEX(MEMUSED + 1, ISIZE, CSIZE)
00322                WORKLEN = ( DSIZE * (MEMLEN - WORKPTR + 1) ) / CSIZE
00323                CALL CSDRVTEST(OUTNUM, VERB, NSHAPE, CMEM(UPLOPTR),
00324      $                        CMEM(DIAGPTR), NMAT, MEM(MPTR),
00325      $                        MEM(NPTR), MEM(LDSPTR), MEM(LDDPTR),
00326      $                        NSRC, MEM(RSRCPTR), MEM(CSRCPTR),
00327      $                        MEM(RDESTPTR), MEM(CDESTPTR),
00328      $                        NGRID, MEM(CTXTPTR), MEM(PPTR), MEM(QPTR),
00329      $                        MEM(ISEEDPTR), MEM(WORKPTR), WORKLEN)
00330 *
00331             ELSE IF( PREC(I) .EQ. 'Z' ) THEN
00332 *
00333                WORKPTR = SAFEINDEX(MEMUSED + 1, ISIZE, ZSIZE)
00334                WORKLEN = ( DSIZE * (MEMLEN - WORKPTR + 1) ) / ZSIZE
00335                CALL ZSDRVTEST(OUTNUM, VERB, NSHAPE, CMEM(UPLOPTR),
00336      $                        CMEM(DIAGPTR), NMAT, MEM(MPTR),
00337      $                        MEM(NPTR), MEM(LDSPTR), MEM(LDDPTR),
00338      $                        NSRC, MEM(RSRCPTR), MEM(CSRCPTR),
00339      $                        MEM(RDESTPTR), MEM(CDESTPTR),
00340      $                        NGRID, MEM(CTXTPTR), MEM(PPTR), MEM(QPTR),
00341      $                        MEM(ISEEDPTR), MEM(WORKPTR), WORKLEN)
00342             END IF
00343    10    CONTINUE
00344          CALL FREEGRIDS( NGRID, MEM(CTXTPTR) )
00345       END IF
00346 *
00347       IF( TESTBSBR ) THEN
00348 *
00349 *        Get test info
00350 *
00351          CALL BTINFO( 'BSBR', MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM,
00352      $                CMEMLEN, OUTNUM, NOP, NSCOPE, TREP, TCOH, NTOP,
00353      $                NSHAPE, NMAT, NSRC, NGRID, OPPTR, SCOPEPTR,
00354      $                TOPPTR, UPLOPTR, DIAGPTR, MPTR, NPTR, LDSPTR,
00355      $                LDDPTR, LDIPTR, RSRCPTR, CSRCPTR, RDESTPTR,
00356      $                CDESTPTR, PPTR, QPTR )
00357 *
00358 *        iseedptr used as tests passed/failed array, so it must
00359 *        be of size NTESTS -- It's not used unless VERB < 2
00360 *
00361          CTXTPTR = MEMUSED + 1
00362          ISEEDPTR = CTXTPTR + NGRID
00363          MEMUSED = ISEEDPTR - 1
00364          IF( VERB .LT. 2 )
00365      $      MEMUSED = MEMUSED + NSCOPE*NTOP*NSHAPE*NMAT*NSRC*NGRID
00366 *
00367          CALL MAKEGRIDS( MEM(CTXTPTR), OUTNUM, NGRID, MEM(PPTR),
00368      $                   MEM(QPTR) )
00369 *
00370 *        Call individual tests as appropriate.
00371 *
00372          DO 20 I = 1, NPREC
00373             IF( PREC(I) .EQ. 'I' ) THEN
00374 *
00375                WORKPTR = SAFEINDEX(MEMUSED + 1, ISIZE, ISIZE)
00376                WORKLEN = ( DSIZE * (MEMLEN - WORKPTR + 1) ) / ISIZE
00377                CALL IBSBRTEST(OUTNUM, VERB, NSCOPE, CMEM(SCOPEPTR),
00378      $                        NTOP, CMEM(TOPPTR), NSHAPE, CMEM(UPLOPTR),
00379      $                        CMEM(DIAGPTR), NMAT, MEM(MPTR),
00380      $                        MEM(NPTR), MEM(LDSPTR), MEM(LDDPTR),
00381      $                        NSRC, MEM(RSRCPTR), MEM(CSRCPTR),
00382      $                        NGRID, MEM(CTXTPTR), MEM(PPTR), MEM(QPTR),
00383      $                        MEM(ISEEDPTR), MEM(WORKPTR), WORKLEN)
00384 *
00385             ELSE IF( PREC(I) .EQ. 'S' ) THEN
00386 *
00387                WORKPTR = SAFEINDEX(MEMUSED + 1, ISIZE, SSIZE)
00388                WORKLEN = ( DSIZE * (MEMLEN - WORKPTR + 1) ) / SSIZE
00389                CALL SBSBRTEST(OUTNUM, VERB, NSCOPE, CMEM(SCOPEPTR),
00390      $                        NTOP, CMEM(TOPPTR), NSHAPE, CMEM(UPLOPTR),
00391      $                        CMEM(DIAGPTR), NMAT, MEM(MPTR),
00392      $                        MEM(NPTR), MEM(LDSPTR), MEM(LDDPTR),
00393      $                        NSRC, MEM(RSRCPTR), MEM(CSRCPTR),
00394      $                        NGRID, MEM(CTXTPTR), MEM(PPTR), MEM(QPTR),
00395      $                        MEM(ISEEDPTR), MEM(WORKPTR), WORKLEN)
00396 *
00397             ELSE IF( PREC(I) .EQ. 'D' ) THEN
00398 *
00399                WORKPTR = SAFEINDEX(MEMUSED + 1, ISIZE, DSIZE)
00400                WORKLEN = ( DSIZE * (MEMLEN - WORKPTR + 1) ) / DSIZE
00401                CALL DBSBRTEST(OUTNUM, VERB, NSCOPE, CMEM(SCOPEPTR),
00402      $                        NTOP, CMEM(TOPPTR), NSHAPE, CMEM(UPLOPTR),
00403      $                        CMEM(DIAGPTR), NMAT, MEM(MPTR),
00404      $                        MEM(NPTR), MEM(LDSPTR), MEM(LDDPTR),
00405      $                        NSRC, MEM(RSRCPTR), MEM(CSRCPTR),
00406      $                        NGRID, MEM(CTXTPTR), MEM(PPTR), MEM(QPTR),
00407      $                        MEM(ISEEDPTR), MEM(WORKPTR), WORKLEN)
00408 *
00409             ELSE IF( PREC(I) .EQ. 'C' ) THEN
00410 *
00411                WORKPTR = SAFEINDEX(MEMUSED + 1, ISIZE, CSIZE)
00412                WORKLEN = ( DSIZE * (MEMLEN - WORKPTR + 1) ) / CSIZE
00413                CALL CBSBRTEST(OUTNUM, VERB, NSCOPE, CMEM(SCOPEPTR),
00414      $                        NTOP, CMEM(TOPPTR), NSHAPE, CMEM(UPLOPTR),
00415      $                        CMEM(DIAGPTR), NMAT, MEM(MPTR),
00416      $                        MEM(NPTR), MEM(LDSPTR), MEM(LDDPTR),
00417      $                        NSRC, MEM(RSRCPTR), MEM(CSRCPTR),
00418      $                        NGRID, MEM(CTXTPTR), MEM(PPTR), MEM(QPTR),
00419      $                        MEM(ISEEDPTR), MEM(WORKPTR), WORKLEN)
00420 *
00421             ELSE IF( PREC(I) .EQ. 'Z' ) THEN
00422 *
00423                WORKPTR = SAFEINDEX(MEMUSED + 1, ISIZE, ZSIZE)
00424                WORKLEN = ( DSIZE * (MEMLEN - WORKPTR + 1) ) / ZSIZE
00425                CALL ZBSBRTEST(OUTNUM, VERB, NSCOPE, CMEM(SCOPEPTR),
00426      $                        NTOP, CMEM(TOPPTR), NSHAPE, CMEM(UPLOPTR),
00427      $                        CMEM(DIAGPTR), NMAT, MEM(MPTR),
00428      $                        MEM(NPTR), MEM(LDSPTR), MEM(LDDPTR),
00429      $                        NSRC, MEM(RSRCPTR), MEM(CSRCPTR),
00430      $                        NGRID, MEM(CTXTPTR), MEM(PPTR), MEM(QPTR),
00431      $                        MEM(ISEEDPTR), MEM(WORKPTR), WORKLEN)
00432 *
00433             END IF
00434 *
00435    20    CONTINUE
00436          CALL FREEGRIDS( NGRID, MEM(CTXTPTR) )
00437       END IF
00438       IF( TESTCOMB ) THEN
00439 *
00440 *        Get test info
00441 *
00442          CALL BTINFO( 'COMB', MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM,
00443      $                CMEMLEN, OUTNUM, NOP, NSCOPE, TREP, TCOH, NTOP,
00444      $                NSHAPE, NMAT, NDEST, NGRID, OPPTR, SCOPEPTR,
00445      $                TOPPTR, UPLOPTR, DIAGPTR, MPTR, NPTR, LDSPTR,
00446      $                LDDPTR, LDIPTR, RSRCPTR, CSRCPTR, RDESTPTR,
00447      $                CDESTPTR, PPTR, QPTR )
00448          CTXTPTR = MEMUSED + 1
00449          MEMUSED  = CTXTPTR + NGRID - 1
00450 *
00451 *        Find space required by RA and CA arrays
00452 *
00453          K = 0
00454          DO 40 J = 0, NOP-1
00455             IF( CMEM(OPPTR+J).EQ.'>' .OR. CMEM(OPPTR+J).EQ.'<' ) THEN
00456                DO 30 I = 0, NMAT
00457 *
00458 *                 NOTE: here we assume ipre+ipost = 4*M
00459 *
00460                   K = MAX0( K, 4*MEM(MPTR+I) )
00461                   IF ( MEM(LDIPTR+I) .NE. -1 )
00462      $               K = MAX0( K, MEM(NPTR+I)*MEM(LDIPTR+I) +
00463      $                            4*MEM(MPTR+I) )
00464    30          CONTINUE
00465             END IF
00466    40    CONTINUE
00467          RAPTR = MEMUSED + 1
00468          CAPTR = RAPTR + K
00469 *
00470 *        iseed array also used as tests passed/failed array, so it must
00471 *        be of size MAX( 4*NNODES, NTESTS )
00472 *
00473          ISEEDPTR = CAPTR + K
00474          I = 0
00475          IF( VERB.LT.2 ) I = NSCOPE * NTOP * NMAT * NDEST * NGRID
00476          MEMUSED = ISEEDPTR + MAX( 4*NNODES, I )
00477 *
00478          CALL MAKEGRIDS( MEM(CTXTPTR), OUTNUM, NGRID, MEM(PPTR),
00479      $                   MEM(QPTR) )
00480 *
00481 *        Call individual tests as appropriate.
00482 *
00483          DO 60 I = 1, NPREC
00484             DO 50 J = 0, NOP-1
00485                IF( PREC(I) .EQ. 'I' ) THEN
00486                   WORKPTR = SAFEINDEX(MEMUSED, ISIZE, ISIZE)
00487                   WORKLEN = ( DSIZE * (MEMLEN - WORKPTR + 1) ) / ISIZE
00488                   IF( CMEM(OPPTR+J) .EQ. '+' ) THEN
00489                      CALL ISUMTEST(OUTNUM, VERB, TREP, TCOH, NSCOPE,
00490      $                             CMEM(SCOPEPTR), NTOP, CMEM(TOPPTR),
00491      $                             NMAT, MEM(MPTR), MEM(NPTR),
00492      $                             MEM(LDSPTR), MEM(LDDPTR), NDEST,
00493      $                             MEM(RDESTPTR), MEM(CDESTPTR), NGRID,
00494      $                             MEM(CTXTPTR), MEM(PPTR), MEM(QPTR),
00495      $                             MEM(ISEEDPTR), MEM(WORKPTR),
00496      $                             WORKLEN)
00497                   ELSE IF( CMEM(OPPTR+J) .EQ. '>' ) THEN
00498                      CALL IAMXTEST(OUTNUM, VERB, TREP, TCOH, NSCOPE,
00499      $                             CMEM(SCOPEPTR), NTOP, CMEM(TOPPTR),
00500      $                             NMAT, MEM(MPTR), MEM(NPTR),
00501      $                             MEM(LDSPTR), MEM(LDDPTR),
00502      $                             MEM(LDIPTR), NDEST, MEM(RDESTPTR),
00503      $                             MEM(CDESTPTR), NGRID, MEM(CTXTPTR),
00504      $                             MEM(PPTR), MEM(QPTR), MEM(ISEEDPTR),
00505      $                             MEM(RAPTR), MEM(CAPTR), K,
00506      $                             MEM(WORKPTR), WORKLEN)
00507                   ELSE IF( CMEM(OPPTR+J) .EQ. '<' ) THEN
00508                      CALL IAMNTEST(OUTNUM, VERB, TREP, TCOH, NSCOPE,
00509      $                             CMEM(SCOPEPTR), NTOP, CMEM(TOPPTR),
00510      $                             NMAT, MEM(MPTR), MEM(NPTR),
00511      $                             MEM(LDSPTR), MEM(LDDPTR),
00512      $                             MEM(LDIPTR), NDEST, MEM(RDESTPTR),
00513      $                             MEM(CDESTPTR), NGRID, MEM(CTXTPTR),
00514      $                             MEM(PPTR), MEM(QPTR), MEM(ISEEDPTR),
00515      $                             MEM(RAPTR), MEM(CAPTR), K,
00516      $                             MEM(WORKPTR), WORKLEN)
00517                   END IF
00518                ELSE IF( PREC(I) .EQ. 'S' ) THEN
00519                   WORKPTR = SAFEINDEX(MEMUSED, ISIZE, SSIZE)
00520                   WORKLEN = ( DSIZE * (MEMLEN - WORKPTR + 1) ) / SSIZE
00521                   IF( CMEM(OPPTR+J) .EQ. '+' ) THEN
00522                      CALL SSUMTEST(OUTNUM, VERB, TREP, TCOH, NSCOPE,
00523      $                             CMEM(SCOPEPTR), NTOP, CMEM(TOPPTR),
00524      $                             NMAT, MEM(MPTR), MEM(NPTR),
00525      $                             MEM(LDSPTR), MEM(LDDPTR), NDEST,
00526      $                             MEM(RDESTPTR), MEM(CDESTPTR), NGRID,
00527      $                             MEM(CTXTPTR), MEM(PPTR), MEM(QPTR),
00528      $                             MEM(ISEEDPTR), MEM(WORKPTR),
00529      $                             WORKLEN)
00530                   ELSE IF( CMEM(OPPTR+J) .EQ. '>' ) THEN
00531                      CALL SAMXTEST(OUTNUM, VERB, TREP, TCOH, NSCOPE,
00532      $                             CMEM(SCOPEPTR), NTOP, CMEM(TOPPTR),
00533      $                             NMAT, MEM(MPTR), MEM(NPTR),
00534      $                             MEM(LDSPTR), MEM(LDDPTR),
00535      $                             MEM(LDIPTR), NDEST, MEM(RDESTPTR),
00536      $                             MEM(CDESTPTR), NGRID, MEM(CTXTPTR),
00537      $                             MEM(PPTR), MEM(QPTR), MEM(ISEEDPTR),
00538      $                             MEM(RAPTR), MEM(CAPTR), K,
00539      $                             MEM(WORKPTR), WORKLEN)
00540                   ELSE IF( CMEM(OPPTR+J) .EQ. '<' ) THEN
00541                      CALL SAMNTEST(OUTNUM, VERB, TREP, TCOH, NSCOPE,
00542      $                             CMEM(SCOPEPTR), NTOP, CMEM(TOPPTR),
00543      $                             NMAT, MEM(MPTR), MEM(NPTR),
00544      $                             MEM(LDSPTR), MEM(LDDPTR),
00545      $                             MEM(LDIPTR), NDEST, MEM(RDESTPTR),
00546      $                             MEM(CDESTPTR), NGRID, MEM(CTXTPTR),
00547      $                             MEM(PPTR), MEM(QPTR), MEM(ISEEDPTR),
00548      $                             MEM(RAPTR), MEM(CAPTR), K,
00549      $                             MEM(WORKPTR), WORKLEN)
00550                   END IF
00551                ELSE IF( PREC(I) .EQ. 'C' ) THEN
00552                   WORKPTR = SAFEINDEX(MEMUSED, ISIZE, CSIZE)
00553                   WORKLEN = ( DSIZE * (MEMLEN - WORKPTR + 1) ) / CSIZE
00554                   IF( CMEM(OPPTR+J) .EQ. '+' ) THEN
00555                      CALL CSUMTEST(OUTNUM, VERB, TREP, TCOH, NSCOPE,
00556      $                             CMEM(SCOPEPTR), NTOP, CMEM(TOPPTR),
00557      $                             NMAT, MEM(MPTR), MEM(NPTR),
00558      $                             MEM(LDSPTR), MEM(LDDPTR), NDEST,
00559      $                             MEM(RDESTPTR), MEM(CDESTPTR), NGRID,
00560      $                             MEM(CTXTPTR), MEM(PPTR), MEM(QPTR),
00561      $                             MEM(ISEEDPTR), MEM(WORKPTR),
00562      $                             WORKLEN)
00563                   ELSE IF( CMEM(OPPTR+J) .EQ. '>' ) THEN
00564                      CALL CAMXTEST(OUTNUM, VERB, TREP, TCOH, NSCOPE,
00565      $                             CMEM(SCOPEPTR), NTOP, CMEM(TOPPTR),
00566      $                             NMAT, MEM(MPTR), MEM(NPTR),
00567      $                             MEM(LDSPTR), MEM(LDDPTR),
00568      $                             MEM(LDIPTR), NDEST, MEM(RDESTPTR),
00569      $                             MEM(CDESTPTR), NGRID, MEM(CTXTPTR),
00570      $                             MEM(PPTR), MEM(QPTR), MEM(ISEEDPTR),
00571      $                             MEM(RAPTR), MEM(CAPTR), K,
00572      $                             MEM(WORKPTR), WORKLEN)
00573                   ELSE IF( CMEM(OPPTR+J) .EQ. '<' ) THEN
00574                      CALL CAMNTEST(OUTNUM, VERB, TREP, TCOH, NSCOPE,
00575      $                             CMEM(SCOPEPTR), NTOP, CMEM(TOPPTR),
00576      $                             NMAT, MEM(MPTR), MEM(NPTR),
00577      $                             MEM(LDSPTR), MEM(LDDPTR),
00578      $                             MEM(LDIPTR), NDEST, MEM(RDESTPTR),
00579      $                             MEM(CDESTPTR), NGRID, MEM(CTXTPTR),
00580      $                             MEM(PPTR), MEM(QPTR), MEM(ISEEDPTR),
00581      $                             MEM(RAPTR), MEM(CAPTR), K,
00582      $                             MEM(WORKPTR), WORKLEN)
00583                   END IF
00584                ELSE IF( PREC(I) .EQ. 'Z' ) THEN
00585                   WORKPTR = SAFEINDEX(MEMUSED, ISIZE, ZSIZE)
00586                   WORKLEN = ( DSIZE * (MEMLEN - WORKPTR + 1) ) / ZSIZE
00587                   IF( CMEM(OPPTR+J) .EQ. '+' ) THEN
00588                      CALL ZSUMTEST(OUTNUM, VERB, TREP, TCOH, NSCOPE,
00589      $                             CMEM(SCOPEPTR), NTOP, CMEM(TOPPTR),
00590      $                             NMAT, MEM(MPTR), MEM(NPTR),
00591      $                             MEM(LDSPTR), MEM(LDDPTR), NDEST,
00592      $                             MEM(RDESTPTR), MEM(CDESTPTR), NGRID,
00593      $                             MEM(CTXTPTR), MEM(PPTR), MEM(QPTR),
00594      $                             MEM(ISEEDPTR), MEM(WORKPTR),
00595      $                             WORKLEN)
00596                   ELSE IF( CMEM(OPPTR+J) .EQ. '>' ) THEN
00597                      CALL ZAMXTEST(OUTNUM, VERB, TREP, TCOH, NSCOPE,
00598      $                             CMEM(SCOPEPTR), NTOP, CMEM(TOPPTR),
00599      $                             NMAT, MEM(MPTR), MEM(NPTR),
00600      $                             MEM(LDSPTR), MEM(LDDPTR),
00601      $                             MEM(LDIPTR), NDEST, MEM(RDESTPTR),
00602      $                             MEM(CDESTPTR), NGRID, MEM(CTXTPTR),
00603      $                             MEM(PPTR), MEM(QPTR), MEM(ISEEDPTR),
00604      $                             MEM(RAPTR), MEM(CAPTR), K,
00605      $                             MEM(WORKPTR), WORKLEN)
00606                   ELSE IF( CMEM(OPPTR+J) .EQ. '<' ) THEN
00607                      CALL ZAMNTEST(OUTNUM, VERB, TREP, TCOH, NSCOPE,
00608      $                             CMEM(SCOPEPTR), NTOP, CMEM(TOPPTR),
00609      $                             NMAT, MEM(MPTR), MEM(NPTR),
00610      $                             MEM(LDSPTR), MEM(LDDPTR),
00611      $                             MEM(LDIPTR), NDEST, MEM(RDESTPTR),
00612      $                             MEM(CDESTPTR), NGRID, MEM(CTXTPTR),
00613      $                             MEM(PPTR), MEM(QPTR), MEM(ISEEDPTR),
00614      $                             MEM(RAPTR), MEM(CAPTR), K,
00615      $                             MEM(WORKPTR), WORKLEN)
00616                   END IF
00617                END IF
00618    50       CONTINUE
00619    60    CONTINUE
00620          CALL FREEGRIDS( NGRID, MEM(CTXTPTR) )
00621       END IF
00622 *
00623       IF( TESTAUX ) THEN
00624          CALL AUXTEST( OUTNUM, MEM, MEMLEN )
00625       END IF
00626 *
00627  1000 FORMAT('AUXILIARY ERROR - IAM MISMATCH: BLACS_PINFO RETURNED',I4,
00628      $       /,' BLACS_SETUP RETURNED',I4,'.')
00629  1500 FORMAT('AUXILIARY ERROR - NPROC MISMATCH: BLACS_PINFO RETURNED',
00630      $       I4,/,' BLACS_SETUP RETURNED',I4,', TESTER THINKS',I4,'.')
00631  2000 FORMAT('BEGINNING BLACS TESTING, BLACS DEBUG LEVEL =',I2)
00632  3000 FORMAT('==============================================')
00633       RETURN
00634 *
00635 *     End of RUNTESTS
00636 *
00637       END
00638 *
00639       SUBROUTINE MAKEGRIDS( CONTEXTS, OUTNUM, NGRIDS, P, Q )
00640       INTEGER NGRIDS, OUTNUM
00641       INTEGER CONTEXTS(NGRIDS), P(NGRIDS), Q(NGRIDS)
00642       INTEGER  IBTMYPROC
00643       EXTERNAL IBTMYPROC
00644       INTEGER NPROW, NPCOL, MYROW, MYCOL, I
00645 *
00646       DO 10 I = 1, NGRIDS
00647          CALL BLACS_GET( 0, 0, CONTEXTS(I) )
00648          CALL BLACS_GRIDINIT( CONTEXTS(I), 'r', P(I), Q(I) )
00649    10 CONTINUE
00650 *
00651       DO 20 I = 1, NGRIDS
00652          CALL BLACS_GRIDINFO( CONTEXTS(I), NPROW, NPCOL, MYROW, MYCOL )
00653          IF( NPROW .GT. 0 ) THEN
00654             IF( NPROW.NE.P(I) .OR. NPCOL.NE.Q(I) ) THEN
00655                IF( IBTMYPROC() .NE. 0 ) OUTNUM = 6
00656                WRITE(OUTNUM,1000) I
00657                IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
00658                CALL BLACS_ABORT( CONTEXTS(I), -1 )
00659             END IF
00660          END IF
00661    20 CONTINUE
00662 *
00663  1000 FORMAT('Grid creation error trying to create grid #',I3)
00664       RETURN
00665       END
00666 *
00667       SUBROUTINE FREEGRIDS( NGRIDS, CONTEXTS )
00668       INTEGER NGRIDS
00669       INTEGER CONTEXTS(NGRIDS)
00670       INTEGER I, NPROW, NPCOL, MYROW, MYCOL
00671 *
00672       DO 10 I = 1, NGRIDS
00673          CALL BLACS_GRIDINFO( CONTEXTS(I), NPROW, NPCOL, MYROW, MYCOL )
00674          IF( MYROW.LT.NPROW .AND. MYCOL.LT.NPCOL )
00675      $      CALL BLACS_GRIDEXIT( CONTEXTS(I) )
00676    10 CONTINUE
00677       RETURN
00678       END
00679 *
00680       SUBROUTINE AUXTEST( OUTNUM, MEM, MEMLEN )
00681 *
00682 *     .. Scalar Arguments ..
00683       INTEGER OUTNUM, MEMLEN
00684 *     ..
00685 *     .. Array Arguments ..
00686       INTEGER MEM(MEMLEN)
00687 *     ..
00688 *     .. External Functions ..
00689       LOGICAL  ALLPASS
00690       INTEGER  IBTMYPROC, IBTMSGID, BLACS_PNUM
00691       DOUBLE PRECISION DWALLTIME00
00692       EXTERNAL ALLPASS, IBTMYPROC, IBTMSGID, BLACS_PNUM
00693       EXTERNAL DWALLTIME00
00694 *     ..
00695 *     .. External Subroutines ..
00696       EXTERNAL BLACS_PINFO, BLACS_GRIDINIT, BLACS_GRIDMAP
00697       EXTERNAL BLACS_FREEBUFF, BLACS_GRIDEXIT, BLACS_ABORT
00698       EXTERNAL BLACS_GRIDINFO, BLACS_PCOORD, BLACS_BARRIER
00699       EXTERNAL BLACS_SET
00700 *     ..
00701 *     .. Local Scalars ..
00702       LOGICAL AUXPASSED, PASSED, IPRINT
00703       INTEGER NPROCS, NPROW, NPCOL, MYROW, MYCOL, CTXT, CTXT2, LDA
00704       INTEGER I, J, K
00705       DOUBLE PRECISION DTIME, DEPS
00706 *     ..
00707 *     .. Local Arrays ..
00708       DOUBLE PRECISION START(2), STST(2), KEEP(2)
00709 *     ..
00710 *     .. Executable Statements ..
00711 *
00712       IPRINT = ( IBTMYPROC() .EQ. 0 )
00713       IF( IPRINT ) THEN
00714          WRITE(OUTNUM,*) '  '
00715          WRITE(OUTNUM,1000)
00716          WRITE(OUTNUM,*) '  '
00717       END IF
00718       CALL BLACS_PINFO( I, NPROCS )
00719       IF( NPROCS .LT. 2 ) THEN
00720          IF( IPRINT )
00721      $      WRITE(OUTNUM,*) 'NOT ENOUGH PROCESSES TO PERFORM AUXTESTS'
00722          RETURN
00723       END IF
00724 *
00725 *     Make sure BLACS_PNUM and BLACS_PCOORD are inverses of each other
00726 *
00727       IF( IPRINT ) THEN
00728          WRITE(OUTNUM,*) ' '
00729          WRITE(OUTNUM,*) 'RUNNING BLACS_PNUM/BLACS_PCOORD TEST'
00730       END IF
00731       PASSED = .TRUE.
00732       NPROCS = NPROCS - MOD(NPROCS,2)
00733       CALL BLACS_GET( 0, 0, CTXT )
00734       CALL BLACS_GRIDINIT( CTXT, 'r', 1, NPROCS )
00735       CALL BLACS_GRIDINFO( CTXT, NPROW, NPCOL, MYROW, MYCOL )
00736       IF( MYROW.GE.NPROW .OR. MYCOL.GE.NPCOL ) GOTO 100
00737       DO 10 I = 1, NPROCS
00738          K = BLACS_PNUM( CTXT, 0, I-1 )
00739          CALL BLACS_PCOORD( CTXT,  BLACS_PNUM( CTXT, 0, I-1 ), J, K )
00740          IF( PASSED ) PASSED = ( J.EQ.0 .AND. K.EQ.I-1 )
00741    10 CONTINUE
00742       K = 1
00743       IF( PASSED ) K = 0
00744       CALL IGSUM2D( CTXT, 'a', ' ', 1, 1, K, 1, -1, 0 )
00745       PASSED = ( K .EQ. 0 )
00746       AUXPASSED = PASSED
00747       IF( IPRINT ) THEN
00748          IF( PASSED ) THEN
00749             WRITE(OUTNUM,*) 'PASSED  BLACS_PNUM/BLACS_PCOORD TEST'
00750          ELSE
00751             WRITE(OUTNUM,*) 'FAILED  BLACS_PNUM/BLACS_PCOORD TEST'
00752          END IF
00753          WRITE(OUTNUM,*) '  '
00754       END IF
00755 *
00756 *     Test to see if DGSUM2D is repeatable when repeatability flag is set
00757 *     Skip test if DGSUM2D is repeatable when repeatability flag is not set
00758 *     NOTE: do not change the EPS calculation loop; it is figured in this
00759 *           strange way so that it ports across platforms
00760 *
00761       IF( IPRINT ) WRITE(OUTNUM,*) 'RUNNING REPEATABLE SUM TEST'
00762       J = 0
00763    12 CONTINUE
00764       PASSED = .TRUE.
00765       START(1) = 1.0D0
00766    15 CONTINUE
00767          DEPS = START(1)
00768          START(1) = START(1) / 2.0D0
00769          STST(1) = 1.0D0 + START(1)
00770       IF (STST(1) .NE. 1.0D0) GOTO 15
00771 *
00772       START(1) = DEPS / DBLE(NPCOL-1)
00773       IF (MYCOL .EQ. 3) START(1) = 1.0D0
00774       START(2) = 7.00005D0 * NPCOL
00775       STST(1) = START(1)
00776       STST(2) = START(2)
00777       CALL BLACS_SET(CTXT, 15, J)
00778       CALL DGSUM2D(CTXT, 'a', 'f', 2, 1, STST, 2, -1, 0)
00779       KEEP(1) = STST(1)
00780       KEEP(2) = STST(2)
00781       DO 30 I = 1, 3
00782 *
00783 *        Have a different guy waste time so he enters combine last
00784 *
00785          IF (MYCOL .EQ. I) THEN
00786              DTIME = DWALLTIME00()
00787    20        CONTINUE
00788              IF (DWALLTIME00() - DTIME .LT. 2.0D0) GOTO 20
00789          END IF
00790          STST(1) = START(1)
00791          STST(2) = START(2)
00792          CALL DGSUM2D(CTXT, 'a', 'f', 2, 1, STST, 2, -1, 0)
00793          IF ( (KEEP(1).NE.STST(1)) .OR. (KEEP(2).NE.STST(2)) )
00794      $      PASSED = .FALSE.
00795    30 CONTINUE
00796       K = 1
00797       IF (PASSED) K = 0
00798       CALL IGSUM2D( CTXT, 'a', ' ', 1, 1, K, 1, -1, 0 )
00799       PASSED = (K .EQ. 0)
00800       IF (J .EQ. 0) THEN
00801          IF (.NOT.PASSED) THEN
00802             J = 1
00803             GOTO 12
00804          ELSE IF( IPRINT ) THEN
00805             WRITE(OUTNUM,*) 'SKIPPED REPEATABLE SUM TEST'
00806             WRITE(OUTNUM,*) ' '
00807          END IF
00808       END IF
00809 *
00810       IF (J .EQ. 1) THEN
00811          AUXPASSED = AUXPASSED .AND. PASSED
00812          IF( IPRINT ) THEN
00813             IF( PASSED ) THEN
00814                WRITE(OUTNUM,*) 'PASSED  REPEATABLE SUM TEST'
00815             ELSE
00816                WRITE(OUTNUM,*) 'FAILED  REPEATABLE SUM TEST'
00817             END IF
00818             WRITE(OUTNUM,*) ' '
00819          END IF
00820       END IF
00821 *
00822 *     Test BLACS_GRIDMAP: force a column major ordering, starting at an
00823 *     arbitrary processor
00824 *
00825       PASSED = .TRUE.
00826       IF( IPRINT ) WRITE(OUTNUM,*) 'RUNNING BLACS_GRIDMAP TEST'
00827       NPROW = 2
00828       NPCOL = NPROCS / NPROW
00829       DO 40 I = 0, NPROCS-1
00830          MEM(I+1) = BLACS_PNUM( CTXT, 0, MOD(I+NPCOL, NPROCS) )
00831    40 CONTINUE
00832       CALL BLACS_GET( CTXT, 10, CTXT2 )
00833       CALL BLACS_GRIDMAP( CTXT2, MEM, NPROW, NPROW, NPCOL )
00834       CALL BLACS_GRIDINFO( CTXT2, NPROW, NPCOL, MYROW, MYCOL )
00835       PASSED = ( NPROW.EQ.2 .AND. NPCOL.EQ.NPROCS/2 )
00836 *
00837 *     Fan in pids for final check: Note we assume SD/RV working
00838 *
00839       IF( PASSED ) THEN
00840          K = BLACS_PNUM( CTXT2, MYROW, MYCOL )
00841          IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN
00842             DO 60 J = 0, NPCOL-1
00843                DO 50 I = 0, NPROW-1
00844                   IF( I.NE.0 .OR. J.NE.0 )
00845      $               CALL IGERV2D( CTXT2, 1, 1, K, 1, I, J )
00846                   IF ( PASSED )
00847      $               PASSED = ( K .EQ. BLACS_PNUM(CTXT2, I, J) )
00848    50          CONTINUE
00849    60       CONTINUE
00850          ELSE
00851             CALL IGESD2D( CTXT2, 1, 1, K, 1, 0, 0 )
00852          END IF
00853       END IF
00854       K = 1
00855       IF ( PASSED ) K = 0
00856       CALL IGSUM2D( CTXT, 'a', ' ', 1, 1, K, 1, -1, 0 )
00857       PASSED = ( K .EQ. 0 )
00858       AUXPASSED = AUXPASSED .AND. PASSED
00859       IF( IPRINT ) THEN
00860          IF( PASSED ) THEN
00861             WRITE(OUTNUM,*) 'PASSED  BLACS_GRIDMAP TEST'
00862          ELSE
00863             WRITE(OUTNUM,*) 'FAILED  BLACS_GRIDMAP TEST'
00864          END IF
00865          WRITE(OUTNUM,*) ' '
00866       END IF
00867 *
00868       IF( IPRINT ) WRITE(OUTNUM,*) 'CALL BLACS_FREEBUFF'
00869       CALL BLACS_FREEBUFF( CTXT, 0 )
00870       CALL BLACS_FREEBUFF( CTXT, 1 )
00871       J = 0
00872       CALL IGSUM2D( CTXT2, 'All', ' ', 1, 1, J, 1, -1, MYCOL )
00873       IF( IPRINT ) THEN
00874          WRITE(OUTNUM,*) 'DONE BLACS_FREEBUFF'
00875          WRITE(OUTNUM,*) ' '
00876       END IF
00877 *
00878 *     Make sure barriers don't interfere with each other
00879 *
00880       IF( IPRINT ) WRITE(OUTNUM,*) 'CALL BARRIER'
00881       CALL BLACS_BARRIER(CTXT2, 'A')
00882       CALL BLACS_BARRIER(CTXT2, 'R')
00883       CALL BLACS_BARRIER(CTXT2, 'C')
00884       CALL BLACS_BARRIER(CTXT2, 'R')
00885       CALL BLACS_BARRIER(CTXT2, 'A')
00886       CALL BLACS_BARRIER(CTXT2, 'C')
00887       CALL BLACS_BARRIER(CTXT2, 'C')
00888       CALL BLACS_BARRIER(CTXT2, 'R')
00889       CALL BLACS_BARRIER(CTXT2, 'A')
00890       J = 0
00891       CALL IGSUM2D( CTXT2, 'All', ' ', 1, 1, J, 1, -1, MYCOL )
00892       IF( IPRINT ) THEN
00893          WRITE(OUTNUM,*) 'DONE BARRIER'
00894          WRITE(OUTNUM,*) ' '
00895       END IF
00896 *
00897 *     Ensure contiguous sends are locally-blocking
00898 *
00899       IF( IPRINT ) THEN
00900          WRITE(OUTNUM,*) 'The following tests will hang if your BLACS'//
00901      $                   ' are not locally blocking:'
00902          WRITE(OUTNUM,*) 'RUNNING LOCALLY-BLOCKING CONTIGUOUS SEND TEST'
00903       END IF
00904       K = MIN( MEMLEN, 50000 )
00905 *
00906 *     Initialize send buffer
00907 *
00908       DO 70 J = 1, K
00909          MEM(J) = 1
00910    70 CONTINUE
00911 *
00912       IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN
00913          CALL IGESD2D( CTXT2, K, 1, MEM, K, NPROW-1, NPCOL-1 )
00914          CALL IGESD2D( CTXT2, K, 1, MEM, K, NPROW-1, NPCOL-1 )
00915          CALL IGESD2D( CTXT2, K, 1, MEM, K, NPROW-1, NPCOL-1 )
00916          CALL IGERV2D( CTXT2, K, 1, MEM, K, NPROW-1, NPCOL-1 )
00917          CALL IGERV2D( CTXT2, K, 1, MEM, K, NPROW-1, NPCOL-1 )
00918          CALL IGERV2D( CTXT2, K, 1, MEM, K, NPROW-1, NPCOL-1 )
00919       ELSE IF( MYROW.EQ.NPROW-1 .AND. MYCOL.EQ.NPCOL-1 ) THEN
00920          CALL IGESD2D( CTXT2, K, 1, MEM, K, 0, 0 )
00921          CALL IGESD2D( CTXT2, K, 1, MEM, K, 0, 0 )
00922          CALL IGESD2D( CTXT2, K, 1, MEM, K, 0, 0 )
00923          CALL IGERV2D( CTXT2, K, 1, MEM, K, 0, 0 )
00924          CALL IGERV2D( CTXT2, K, 1, MEM, K, 0, 0 )
00925          CALL IGERV2D( CTXT2, K, 1, MEM, K, 0, 0 )
00926       END IF
00927       J = 0
00928       CALL IGSUM2D( CTXT2, 'All', ' ', 1, 1, J, 1, -1, MYCOL )
00929       IF( IPRINT )
00930      $   WRITE(OUTNUM,*) 'PASSED  LOCALLY-BLOCKING CONTIGUOUS SEND TEST'
00931 *
00932 *     Ensure non-contiguous sends are locally-blocking
00933 *
00934       J = 4
00935       LDA = K / J
00936       I = MAX( 2, LDA / 4 )
00937       IF( IPRINT )
00938      $   WRITE(OUTNUM,*) 'RUNNING LOCALLY-BLOCKING NON-CONTIGUOUS '//
00939      $                   'SEND TEST'
00940       IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN
00941          CALL IGESD2D( CTXT2, I, J, MEM, LDA, NPROW-1, NPCOL-1 )
00942          CALL IGESD2D( CTXT2, I, J, MEM, LDA, NPROW-1, NPCOL-1 )
00943          CALL IGESD2D( CTXT2, I, J, MEM, LDA, NPROW-1, NPCOL-1 )
00944          CALL IGERV2D( CTXT2, I, J, MEM, LDA, NPROW-1, NPCOL-1 )
00945          CALL IGERV2D( CTXT2, I, J, MEM, LDA, NPROW-1, NPCOL-1 )
00946          CALL IGERV2D( CTXT2, I, J, MEM, LDA, NPROW-1, NPCOL-1 )
00947       ELSE IF( MYROW.EQ.NPROW-1 .AND. MYCOL.EQ.NPCOL-1 ) THEN
00948          CALL IGESD2D( CTXT2, I, J, MEM, LDA, 0, 0 )
00949          CALL IGESD2D( CTXT2, I, J, MEM, LDA, 0, 0 )
00950          CALL IGESD2D( CTXT2, I, J, MEM, LDA, 0, 0 )
00951          CALL IGERV2D( CTXT2, I, J, MEM, LDA, 0, 0 )
00952          CALL IGERV2D( CTXT2, I, J, MEM, LDA, 0, 0 )
00953          CALL IGERV2D( CTXT2, I, J, MEM, LDA, 0, 0 )
00954       END IF
00955       CALL IGSUM2D( CTXT2, 'All', ' ', 1, 1, J, 1, -1, MYCOL )
00956       IF( IPRINT ) THEN
00957          WRITE(OUTNUM,*)'PASSED  LOCALLY-BLOCKING NON-CONTIGUOUS '//
00958      $                  'SEND TEST'
00959          WRITE(OUTNUM,*) '  '
00960       END IF
00961 *
00962 *     Note that we already tested the message ID setting/getting in
00963 *     first call to IBTMSGID()
00964 *
00965       IF( IPRINT ) WRITE(OUTNUM,*) 'RUNNING BLACS_SET/BLACS_GET TESTS'
00966       J = 0
00967       CALL BLACS_SET( CTXT2, 11, 3 )
00968       CALL BLACS_SET( CTXT2, 12, 2 )
00969       CALL BLACS_GET( CTXT2, 12, I )
00970       CALL BLACS_GET( CTXT2, 11, K )
00971       IF( K.NE.3 ) J = J + 1
00972       IF( I.NE.2 ) J = J + 1
00973       CALL BLACS_SET( CTXT2, 13, 3 )
00974       CALL BLACS_SET( CTXT2, 14, 2 )
00975       CALL BLACS_GET( CTXT2, 14, I )
00976       CALL BLACS_GET( CTXT2, 13, K )
00977       IF( K.NE.3 ) J = J + 1
00978       IF( I.NE.2 ) J = J + 1
00979 *
00980 *     See if anyone had error, and print result
00981 *
00982       CALL IGSUM2D( CTXT2, 'All', ' ', 1, 1, J, 1, -1, MYCOL )
00983       PASSED = (J .EQ. 0)
00984       AUXPASSED = AUXPASSED .AND. PASSED
00985       IF( IPRINT ) THEN
00986          IF( PASSED ) THEN
00987             WRITE(OUTNUM,*) 'PASSED  BLACS_SET/BLACS_GET TESTS'
00988          ELSE
00989             WRITE(OUTNUM,*) 'FAILED  BLACS_SET/BLACS_GET TESTS'
00990          END IF
00991          WRITE(OUTNUM,*) ' '
00992       END IF
00993 *
00994       IF( IPRINT ) WRITE(OUTNUM,*) 'CALL BLACS_GRIDEXIT'
00995       CALL BLACS_GRIDEXIT(CTXT)
00996       CALL BLACS_GRIDEXIT(CTXT2)
00997       IF( IPRINT ) THEN
00998          WRITE(OUTNUM,*) 'DONE BLACS_GRIDEXIT'
00999          WRITE(OUTNUM,*) '  '
01000       END IF
01001 *
01002   100 CONTINUE
01003 *
01004       PASSED = ALLPASS(AUXPASSED)
01005       IF( IPRINT ) THEN
01006          WRITE(OUTNUM,*) 'The final auxiliary test is for BLACS_ABORT.'
01007          WRITE(OUTNUM,*) 'Immediately after this message, all '//
01008      $                   'processes should be killed.'
01009          WRITE(OUTNUM,*) 'If processes survive the call, your BLACS_'//
01010      $                   'ABORT is incorrect.'
01011       END IF
01012       CALL BLACS_PINFO( I, NPROCS )
01013       CALL BLACS_GET( 0, 0, CTXT )
01014       CALL BLACS_GRIDINIT( CTXT, 'r', 1, NPROCS )
01015       CALL BLACS_BARRIER(CTXT, 'A')
01016       CALL BLACS_GRIDINFO( CTXT, NPROW, NPCOL, MYROW, MYCOL )
01017 *
01018 *     Test BLACS_ABORT
01019 *
01020       IF( MYROW.EQ.NPROW/2 .AND. MYCOL.EQ.NPCOL/2 ) THEN
01021          CALL BLACS_ABORT( CTXT, -1 )
01022 *
01023 *     Other procs try to cause a hang: should be killed by BLACS_ABORT
01024 *
01025       ELSE
01026          I = 1
01027 110      CONTINUE
01028             I = I + 3
01029             I = I - 2
01030             I = I - 1
01031          IF( I.EQ.1 ) GOTO 110
01032       end if
01033 *
01034  1000 FORMAT('AUXILIARY TESTS: BEGIN.')
01035       RETURN
01036       END
01037 *
01038       SUBROUTINE BTTRANSCHAR(TRANSTO, N, CMEM, IMEM)
01039       CHARACTER TRANSTO
01040       INTEGER N
01041       CHARACTER*1 CMEM(N)
01042       INTEGER IMEM(N)
01043       INTEGER I
01044 *
01045       IF( TRANSTO .EQ. 'I' ) THEN
01046          DO 10 I = 1, N
01047             IMEM(I) = ICHAR( CMEM(I) )
01048    10    CONTINUE
01049       ELSE
01050          DO 20 I = 1, N
01051             CMEM(I) = CHAR( IMEM(I) )
01052    20    CONTINUE
01053       END IF
01054       RETURN
01055       END
01056 *
01057       SUBROUTINE BTINFO( TEST, MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM,
01058      $                   CMEMLEN, OUTNUM, NOP, NSCOPE, TREP, TCOH, NTOP,
01059      $                   NSHAPE, NMAT, NSRC, NGRID, OPPTR, SCOPEPTR,
01060      $                   TOPPTR, UPLOPTR, DIAGPTR, MPTR, NPTR, LDSPTR,
01061      $                   LDDPTR, LDIPTR, RSRCPTR, CSRCPTR, RDESTPTR,
01062      $                   CDESTPTR, PPTR, QPTR )
01063 *
01064 *     .. Scalar Arguments ..
01065       CHARACTER*1 TEST
01066       INTEGER CDESTPTR, CMEMLEN, CMEMUSED, CSRCPTR, DIAGPTR, LDDPTR,
01067      $        LDIPTR, LDSPTR, MEMLEN, MEMUSED, MPTR, NGRID, NMAT, NOP,
01068      $        NPTR, NSCOPE, NSHAPE, NSRC, NTOP, OPPTR, OUTNUM, PPTR,
01069      $        QPTR, RDESTPTR, RSRCPTR, SCOPEPTR, TCOH, TOPPTR, TREP,
01070      $        UPLOPTR
01071 *     ..
01072 *     .. Array Arguments ..
01073       CHARACTER*1 CMEM(CMEMLEN)
01074       INTEGER MEM(MEMLEN)
01075 *     ..
01076 *     .. External Functions ..
01077       INTEGER  IBTMYPROC, IBTMSGID, IBTSIZEOF
01078       EXTERNAL IBTMYPROC, IBTMSGID, IBTSIZEOF
01079 *     ..
01080 *     .. Local Scalars ..
01081       INTEGER IAM, ISIZE, DSIZE
01082 *     ..
01083 *     .. Local Arrays ..
01084       INTEGER ITMP(2)
01085 *     ..
01086 *     .. Executable Statements ..
01087 *
01088       IAM = IBTMYPROC()
01089       IF( IAM .EQ. 0 ) THEN
01090          IF( TEST .EQ. 'S' ) THEN
01091             CALL RDSDRV( MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM, CMEMLEN,
01092      $                   OUTNUM )
01093          ELSE IF( TEST .EQ. 'B' ) THEN
01094             CALL RDBSBR( MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM, CMEMLEN,
01095      $                   OUTNUM )
01096          ELSE
01097             CALL RDCOMB( MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM, CMEMLEN,
01098      $                   OUTNUM )
01099          END IF
01100          ITMP(1) = MEMUSED
01101          ITMP(2) = CMEMUSED
01102          CALL BTSEND( 3, 2, ITMP, -1, IBTMSGID()+3 )
01103          IF( MEMLEN .GE. MEMUSED + CMEMUSED ) THEN
01104             CALL BTTRANSCHAR( 'I', CMEMUSED, CMEM, MEM(MEMUSED+1) )
01105          ELSE
01106             ISIZE = IBTSIZEOF('I')
01107             DSIZE = IBTSIZEOF('D')
01108             WRITE(OUTNUM,1000) ( (MEMUSED+CMEMUSED)*ISIZE + DSIZE-1 )
01109      $                         / DSIZE
01110             CALL BLACS_ABORT(-1, -1)
01111          END IF
01112          CALL BTSEND( 3, MEMUSED+CMEMUSED, MEM, -1, IBTMSGID()+4 )
01113       ELSE
01114          CALL BTRECV( 3, 2, ITMP, 0, IBTMSGID()+3 )
01115          MEMUSED = ITMP(1)
01116          CMEMUSED = ITMP(2)
01117          IF( MEMLEN .GE. MEMUSED + CMEMUSED ) THEN
01118             CALL BTRECV( 3, MEMUSED+CMEMUSED, MEM, 0, IBTMSGID()+4 )
01119             CALL BTTRANSCHAR( 'C', CMEMUSED, CMEM, MEM(MEMUSED+1) )
01120          ELSE
01121             ISIZE = IBTSIZEOF('I')
01122             DSIZE = IBTSIZEOF('D')
01123             WRITE(OUTNUM,1000) ( (MEMUSED+CMEMUSED)*ISIZE + DSIZE-1 )
01124      $                         / DSIZE
01125             CALL BLACS_ABORT(-1, -1)
01126          END IF
01127       END IF
01128       CALL BTUNPACK( TEST, MEM, MEMUSED, NOP, NSCOPE, TREP, TCOH, NTOP,
01129      $               NSHAPE, NMAT, NSRC, NGRID, OPPTR, SCOPEPTR, TOPPTR,
01130      $               UPLOPTR, DIAGPTR, MPTR, NPTR, LDSPTR, LDDPTR,
01131      $               LDIPTR, RSRCPTR, CSRCPTR, RDESTPTR, CDESTPTR, PPTR,
01132      $               QPTR)
01133 *
01134  1000 FORMAT('MEM array too short to pack CMEM; increase to at least',
01135      $       I7)
01136 *
01137       RETURN
01138 *
01139 *     End BTINFO
01140 *
01141       END
01142 *
01143       SUBROUTINE RDBTIN( TESTSDRV, TESTBSBR, TESTCOMB, TESTAUX, NPREC,
01144      $                   PREC, VERB, OUTNUM )
01145 *
01146 *  -- BLACS tester (version 1.0) --
01147 *  University of Tennessee
01148 *  December 15, 1994
01149 *
01150 *
01151 *     .. Scalar Arguments ..
01152       LOGICAL TESTSDRV, TESTBSBR, TESTCOMB, TESTAUX
01153       INTEGER NPREC, OUTNUM, VERB
01154 *     ..
01155 *     .. Array Arguments ..
01156       CHARACTER*1 PREC(*)
01157 *     ..
01158 *
01159 *  Purpose
01160 *  =======
01161 *  RDBTIN:  Read and process the top-level input file BT.dat.
01162 *
01163 *  Arguments
01164 *  =========
01165 *  TESTSDRV (output) LOGICAL
01166 *           Run any point-to-point tests?
01167 *
01168 *  TESTBSBR (output) LOGICAL
01169 *           Run any broadcast tests?
01170 *
01171 *  TESTCOMB (output) LOGICAL
01172 *           Run any combine-operation tests (e.g. MAX)
01173 *
01174 *  TESTAUX  (output) LOGICAL
01175 *           Run any auxiliary tests?
01176 *
01177 *  NPREC    (output) INTEGER
01178 *           Number of different precisions to test. (up to 5, as determined
01179 *           by the parameter PRECMAX down in the code.)
01180 *
01181 *  PREC     (output) CHARACTER*1 array, dimension 5
01182 *           Prefix letter of each precision to test, from the set
01183 *           {'C', 'D', 'I', 'S', 'Z'}
01184 *
01185 *  VERB     (output) INTEGER
01186 *           Output verbosity for this test run.
01187 *            0 = Print only "BEGIN [SDRV/BSBR/COMB]", followed by PASSED
01188 *                or FAILED message
01189 *            1 = Same as 0, but also prints out header explaining all tests
01190 *                to be run.
01191 *            2 = Prints out info before and after every individual test.
01192 *
01193 *  OUTNUM   (output) INTEGER
01194 *           Unit number for output file.
01195 *  ======================================================================
01196 *
01197 *
01198 *     .. Parameters ..
01199       INTEGER PRECMAX, VERBMAX, IN
01200       PARAMETER ( PRECMAX = 5, VERBMAX = 2, IN = 11 )
01201 *     ..
01202 *     .. Local Scalars ..
01203       INTEGER I
01204       CHARACTER*1 CH
01205       LOGICAL READERROR
01206 *     ..
01207 *     .. Local Arrays ..
01208       CHARACTER*80 HEADER, OUTNAME
01209 *     ..
01210 *     .. External Functions ..
01211       LOGICAL LSAME
01212       EXTERNAL LSAME
01213 *     ..
01214 *     .. Executable Statements
01215 *
01216 *     Open and read the file blacstest.dat.  Expected format is
01217 *     -----
01218 *     'One line of free text intended as a comment for each test run'
01219 *     integer             Unit number of output file
01220 *     string              Name of output file (ignored if unit = 6)
01221 *     {'T'|'F'}           Run any point to point tests?
01222 *     {'T'|'F'}           Run any broadcast tests?
01223 *     {'T'|'F'}           Run any combine-operator tests?
01224 *     {'T'|'F'}           Run the auxiliary tests?
01225 *     integer             Number of precisions to test - up to 99
01226 *     array of CHAR*1's   Specific precisions to test
01227 *     integer             Output verb (1-n, n=most verbose)
01228 *     integer             Number of nodes required by largest test case
01229 *     -----
01230 *     Note that the comments to the right of each line are present
01231 *     in the sample blacstest.dat file included with this
01232 *     distribution, but they are not required.
01233 *
01234 *     The array of CHAR*1's is expected to have length equal to the
01235 *     integer in the previous line - if it is shorter, problems may
01236 *     occur later; if it is longer, the trailing elements will just
01237 *     be ignored.  The verb is expected to be an integer
01238 *     between 1 and n inclusive and will be set to 1 if outside
01239 *     this range.
01240 *
01241 *     Only process 0 should be calling this routine
01242 *
01243       READERROR = .FALSE.
01244       OPEN( UNIT = IN, FILE = 'bt.dat', STATUS = 'OLD' )
01245       READ(IN, *) HEADER
01246       READ(IN, *) OUTNUM
01247       READ(IN, *) OUTNAME
01248 *
01249 *     Open and prepare output file
01250 *
01251       IF( OUTNUM.NE.6 .AND. OUTNUM.NE.0 )
01252      $  OPEN( UNIT = OUTNUM, FILE = OUTNAME, STATUS = 'UNKNOWN' )
01253       WRITE(OUTNUM, *) HEADER
01254 *
01255 *     Determine which tests to run
01256 *
01257       READ(IN, *) CH
01258       IF( LSAME(CH, 'T') ) THEN
01259          TESTSDRV = .TRUE.
01260       ELSE IF( LSAME(CH, 'F') ) THEN
01261          TESTSDRV = .FALSE.
01262       ELSE
01263          WRITE(OUTNUM, 1000) 'SDRV', CH
01264          READERROR = .TRUE.
01265       END IF
01266 *
01267       READ(IN, *) CH
01268       IF( LSAME(CH, 'T') ) THEN
01269          TESTBSBR = .TRUE.
01270       ELSE IF(LSAME( CH, 'F') ) THEN
01271          TESTBSBR = .FALSE.
01272       ELSE
01273          WRITE(OUTNUM, 1000) 'BSBR', CH
01274          READERROR = .TRUE.
01275       END IF
01276 *
01277       READ(IN, *) CH
01278       IF( LSAME(CH, 'T') ) THEN
01279          TESTCOMB = .TRUE.
01280       ELSE IF( LSAME(CH, 'F') ) THEN
01281          TESTCOMB = .FALSE.
01282       ELSE
01283          WRITE(OUTNUM, 1000) 'COMB', CH
01284          READERROR = .TRUE.
01285       END IF
01286 *
01287       READ(IN, *) CH
01288       IF( LSAME(CH, 'T') ) THEN
01289          TESTAUX = .TRUE.
01290       ELSE IF( LSAME(CH, 'F') ) THEN
01291          TESTAUX = .FALSE.
01292       ELSE
01293          WRITE(OUTNUM, 1000) 'AUX ', CH
01294          READERROR = .TRUE.
01295       END IF
01296 *
01297 *     Get # of precisions, and precisions to test
01298 *
01299       READ(IN, *) NPREC
01300       IF( NPREC .LT. 0 ) THEN
01301          NPREC = 0
01302       ELSE IF( NPREC. GT. PRECMAX ) THEN
01303          WRITE(OUTNUM, 2000) NPREC, PRECMAX, PRECMAX
01304          NPREC = PRECMAX
01305       END IF
01306 *
01307       READ(IN, *) ( PREC(I), I = 1, NPREC )
01308       DO 100 I = 1, NPREC
01309          IF( LSAME(PREC(I), 'C') ) THEN
01310             PREC(I) = 'C'
01311          ELSE IF( LSAME(PREC(I), 'D') ) THEN
01312             PREC(I) = 'D'
01313          ELSE IF( LSAME(PREC(I), 'I') ) THEN
01314             PREC(I) = 'I'
01315          ELSE IF( LSAME(PREC(I), 'S') ) THEN
01316             PREC(I) = 'S'
01317          ELSE IF( LSAME(PREC(I), 'Z') ) THEN
01318             PREC(I) = 'Z'
01319          ELSE
01320             WRITE(OUTNUM, 3000) PREC(I)
01321             READERROR = .TRUE.
01322          END IF
01323   100 CONTINUE
01324 *
01325       READ(IN, *) VERB
01326 *
01327       IF( VERB .GT. VERBMAX ) THEN
01328          WRITE(OUTNUM, 4000) VERB, VERBMAX, VERBMAX
01329          VERB = VERBMAX
01330       ELSE IF( VERB .LT. 0 ) THEN
01331          WRITE(OUTNUM, 5000) VERB
01332          VERB = 0
01333       END IF
01334 *
01335 *     Abort if there was a fatal error
01336 *
01337       IF( READERROR ) THEN
01338          WRITE(OUTNUM, 6000)
01339          IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE( OUTNUM )
01340          STOP
01341       END IF
01342 *
01343  1000 FORMAT( 'INVALID CHARACTER FOR ',A4,' TESTS ''', A1,
01344      $        ''' (EXPECTED T/F)' )
01345  2000 FORMAT( 'NUMBER OF PRECISIONS ', I6, ' GREATER THAN ', I6,
01346      $        ' - SETTING TO ', I6, '.')
01347  3000 FORMAT( 'UNRECOGNIZABLE PRECISION ENTRY ''', A1,
01348      $        ''' - EXPECTED ''C'', ''D'', ''I'', ''S'', OR ''Z''.')
01349  4000 FORMAT( 'VERBOSITY ', I4, ' GREATER THAN ',I4,
01350      $        ' - SETTING TO ',I4,'.')
01351  5000 FORMAT( 'VERBOSITY ', I4, ' LESS THAN 0 - SETTING TO 0' )
01352  6000 FORMAT( 'FATAL INPUT FILE ERROR - ABORTING RUN.' )
01353 *
01354       RETURN
01355 *
01356 *     End of RDBTIN
01357 *
01358       END
01359 *
01360       INTEGER FUNCTION IBTMSGID()
01361 *
01362 *  -- BLACS tester (version 1.0) --
01363 *  University of Tennessee
01364 *  December 15, 1994
01365 *
01366 *
01367 *     PURPOSE
01368 *     =======
01369 *     IBTMSGID : returns a ID for tester communication.
01370 *
01371       INTEGER MINID
01372       INTEGER ITMP(2)
01373       SAVE MINID
01374       DATA MINID /-1/
01375 *
01376 *     On first call, reserve 1st 1000 IDs for tester use
01377 *
01378       IF (MINID .EQ. -1) THEN
01379          CALL BLACS_GET( -1, 1, ITMP )
01380          MINID = ITMP(1)
01381          ITMP(1) = ITMP(1) + 1000
01382          CALL BLACS_SET( -1, 1, ITMP )
01383       END IF
01384 *
01385 *     return the minimum allowable ID
01386 *
01387       IBTMSGID = MINID
01388 *
01389       RETURN
01390       END
01391 *
01392       SUBROUTINE BTUNPACK(TEST, MEM, MEMLEN, NOP, NSCOPE, TREP, TCOH,
01393      $                    NTOP, NSHAPE, NMAT, NSRC, NGRID, OPPTR,
01394      $                    SCOPEPTR, TOPPTR, UPLOPTR, DIAGPTR, MPTR,
01395      $                    NPTR, LDSPTR, LDDPTR, LDIPTR, RSRCPTR,
01396      $                    CSRCPTR, RDESTPTR, CDESTPTR, PPTR, QPTR)
01397 *
01398 *  -- BLACS tester (version 1.0) --
01399 *  University of Tennessee
01400 *  December 15, 1994
01401 *
01402 *
01403 *     .. Scalar Arguments ..
01404       CHARACTER*1 TEST
01405       INTEGER CDESTPTR, CSRCPTR, DIAGPTR, LDDPTR, LDIPTR, LDSPTR,
01406      $        MEMLEN, MPTR, NGRID, NMAT, NOP, NPTR, NSCOPE, NSHAPE,
01407      $        NSRC, NTOP, OPPTR, PPTR, QPTR, RDESTPTR, RSRCPTR,
01408      $        SCOPEPTR, TCOH, TOPPTR, TREP, UPLOPTR
01409 *     ..
01410 *     .. Array Arguments ..
01411       INTEGER MEM(MEMLEN)
01412 *     ..
01413 *
01414 *  Purpose
01415 *  =======
01416 *  BTUNPACK: Figure pointers into MEM where the various input values
01417 *  are stored.
01418 *
01419 *  Arguments
01420 *  =========
01421 *  TEST     (input) CHARACTER*1
01422 *           The test we're unpacking for:
01423 *            = 'S' : SDRV test
01424 *            = 'B' : BSBR test
01425 *            = 'C' : Combine test
01426 *
01427 *  MEM      (input) INTEGER array of dimension MEMLEN
01428 *           Memory containing values and number of items.
01429 *
01430 *  MEMLEN   (input/output) INTEGER
01431 *           The number of elements that are used in MEM.
01432 *
01433 *  .
01434 *  .
01435 *  .
01436 *
01437 *  =====================================================================
01438 *
01439 *     .. Local Scalars ..
01440       INTEGER NDEST, NLDI
01441 *     ..
01442 *     .. Executable Statements ..
01443 *
01444 *     Test is SDRV
01445 *
01446       IF( TEST .EQ. 'S' ) THEN
01447          NOP    = 0
01448          NSHAPE = MEM(MEMLEN-3)
01449          NSCOPE = 0
01450          TREP   = 0
01451          TCOH   = 0
01452          NTOP   = 0
01453          NMAT   = MEM(MEMLEN-2)
01454          NLDI   = 0
01455          NSRC   = MEM(MEMLEN-1)
01456          NDEST  = NSRC
01457          NGRID  = MEM(MEMLEN)
01458          MEMLEN = MEMLEN - 3
01459 *
01460 *     Test is BSBR
01461 *
01462       ELSE IF ( TEST .EQ. 'B' ) THEN
01463          NOP    = 0
01464          NSCOPE = MEM(MEMLEN-5)
01465          TREP   = 0
01466          TCOH   = 0
01467          NTOP   = MEM(MEMLEN-4)
01468          NSHAPE = MEM(MEMLEN-3)
01469          NMAT   = MEM(MEMLEN-2)
01470          NLDI   = 0
01471          NSRC   = MEM(MEMLEN-1)
01472          NDEST  = 0
01473          NGRID  = MEM(MEMLEN)
01474          MEMLEN = MEMLEN - 5
01475 *
01476 *     Test is COMB
01477 *
01478       ELSE
01479          NOP    = MEM(MEMLEN-7)
01480          NSCOPE = MEM(MEMLEN-6)
01481          TREP   = MEM(MEMLEN-5)
01482          TCOH   = MEM(MEMLEN-4)
01483          NTOP   = MEM(MEMLEN-3)
01484          NSHAPE = 0
01485          NMAT   = MEM(MEMLEN-2)
01486          NLDI   = NMAT
01487          NSRC   = 0
01488          NDEST  = MEM(MEMLEN-1)
01489          NGRID  = MEM(MEMLEN)
01490          MEMLEN = MEMLEN - 6
01491       END IF
01492       OPPTR = 1
01493       SCOPEPTR = OPPTR + NOP
01494       TOPPTR = SCOPEPTR + NSCOPE
01495       UPLOPTR = TOPPTR + NTOP
01496       DIAGPTR = UPLOPTR + NSHAPE
01497       MPTR = 1
01498       NPTR = MPTR + NMAT
01499       LDSPTR = NPTR + NMAT
01500       LDDPTR = LDSPTR + NMAT
01501       LDIPTR = LDDPTR + NMAT
01502       RSRCPTR = LDIPTR + NLDI
01503       CSRCPTR = RSRCPTR + NSRC
01504       RDESTPTR = CSRCPTR + NSRC
01505       CDESTPTR = RDESTPTR + NDEST
01506       PPTR = CDESTPTR + NDEST
01507       QPTR = PPTR + NGRID
01508       IF( NSRC .EQ. 0 ) NSRC = NDEST
01509 *
01510       RETURN
01511 *
01512 *     End of BTUNPACK
01513 *
01514       END
01515 *
01516       INTEGER FUNCTION SAFEINDEX(INDX, SIZE1, SIZE2)
01517 *
01518 *     .. Scalar Arguments ..
01519       INTEGER INDX, SIZE1, SIZE2
01520 *     ..
01521 *
01522 *  If you have an array with elements of SIZE1 bytes, of which you
01523 *  have used INDX-1 elements, returns the index necessary to keep it
01524 *  on a SIZE2 boundary (assuming it was SIZE2 aligned in the first place).
01525 *
01526 *     .. Local scalars ..
01527       INTEGER I
01528 *     ..
01529 *     .. Executable Statements ..
01530 *
01531 *     Take into account that Fortran starts arrays at 1, not 0
01532 *
01533       I = INDX - 1
01534    10 CONTINUE
01535       IF( MOD(I*SIZE1, SIZE2) .EQ. 0 ) GOTO 20
01536          I = I + 1
01537       GOTO 10
01538    20 CONTINUE
01539 *
01540       SAFEINDEX = I + 1
01541 *
01542       RETURN
01543       END
01544 *
01545 *
01546       SUBROUTINE RDSDRV( MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM, CMEMLEN,
01547      $                   OUTNUM )
01548 *
01549 *  -- BLACS tester (version 1.0) --
01550 *  University of Tennessee
01551 *  December 15, 1994
01552 *
01553 *
01554 *     .. Scalar Arguments ..
01555       INTEGER MEMUSED, MEMLEN, CMEMUSED, CMEMLEN, OUTNUM
01556 *     ..
01557 *     .. Array Arguments ..
01558       CHARACTER*1 CMEM(CMEMLEN)
01559       INTEGER MEM(MEMLEN)
01560 *     ..
01561 *
01562 *     Purpose
01563 *     =======
01564 *     RDSDRV:  Read and process the input file SDRV.dat.
01565 *
01566 *     Arguments
01567 *     =========
01568 *     MEMUSED  (output) INTEGER
01569 *              Number of elements in MEM that this subroutine ends up using.
01570 *
01571 *     MEM      (output) INTEGER array of dimension memlen
01572 *              On output, holds information read in from sdrv.dat.
01573 *
01574 *     MEMLEN   (input) INTEGER
01575 *              Number of elements of MEM that this subroutine
01576 *              may safely write into.
01577 *
01578 *     CMEMUSED (output) INTEGER
01579 *              Number of elements in CMEM that this subroutine ends up using.
01580 *
01581 *     CMEM     (output) CHARACTER*1 array of dimension cmemlen
01582 *              On output, holds the values for UPLO and DIAG.
01583 *
01584 *     CMEMLEN  (input) INTEGER
01585 *              Number of elements of CMEM that this subroutine
01586 *              may safely write into.
01587 *
01588 *     OUTNUM   (input) INTEGER
01589 *              Unit number of the output file.
01590 *
01591 *     =================================================================
01592 *
01593 *     .. Parameters ..
01594       INTEGER SDIN
01595       PARAMETER( SDIN = 12 )
01596 *     ..
01597 *     .. External Functions ..
01598       LOGICAL  LSAME
01599       EXTERNAL LSAME
01600 *     ..
01601 *     .. Local Scalars ..
01602       INTEGER NSHAPE, NMAT, NSRC, NGRID, I, J
01603       INTEGER UPLOPTR, DIAGPTR, MPTR, NPTR, LDSPTR, LDDPTR, RSRCPTR
01604       INTEGER CSRCPTR, RDESTPTR, CDESTPTR, PPTR, QPTR
01605 *     ..
01606 *     .. Executable Statements
01607 *
01608 *     Open and read the file sdrv.dat.  The expected format is
01609 *     below.
01610 *
01611 *------
01612 *integer                         number of shapes of the matrix
01613 *array of CHAR*1's               UPLO
01614 *array of CHAR*1's               DIAG: unit diagonal or not?
01615 *integer                         number of nmat
01616 *array of integers               M: number of rows in matrix
01617 *array of integers               N: number of columns in matrix
01618 *integer                         LDA: leading dimension on source proc
01619 *integer                         LDA: leading dimension on dest proc
01620 *integer                         number of source/dest pairs
01621 *array of integers               RSRC: process row of message source
01622 *array of integers               CSRC: process column of msg. src.
01623 *array of integers               RDEST: process row of msg. dest.
01624 *array of integers               CDEST: process column of msg. dest.
01625 *integer                         Number of grids
01626 *array of integers               NPROW: number of rows in process grid
01627 *array of integers               NPCOL: number of col's in proc. grid
01628 *------
01629 *  note: UPLO stands for 'upper or lower trapezoidal or general
01630 *        rectangular.'
01631 *  note: the text descriptions as shown above are present in
01632 *             the sample sdrv.dat included with this distribution,
01633 *             but are not required.
01634 *
01635 *     Read input file
01636 *
01637       MEMUSED = 1
01638       CMEMUSED = 1
01639       OPEN(UNIT = SDIN, FILE = 'sdrv.dat', STATUS = 'OLD')
01640 *
01641 *     Read in number of shapes, and values of UPLO and DIAG
01642 *
01643       READ(SDIN, *) NSHAPE
01644       UPLOPTR = CMEMUSED
01645       DIAGPTR = UPLOPTR + NSHAPE
01646       CMEMUSED = DIAGPTR + NSHAPE
01647       IF ( CMEMUSED .GT. CMEMLEN ) THEN
01648          WRITE(OUTNUM, 1000) CMEMLEN, NSHAPE, 'MATRIX SHAPES.'
01649          IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
01650          STOP
01651       ELSE IF( NSHAPE .LT. 1 ) THEN
01652          WRITE(OUTNUM, 2000) 'MATRIX SHAPE.'
01653          IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
01654          STOP
01655       END IF
01656 *
01657 *     Read in, upcase, and fatal error if UPLO/DIAG not recognized
01658 *
01659       READ(SDIN, *) ( CMEM(UPLOPTR+I), I = 0, NSHAPE-1 )
01660       DO 30 I = 0, NSHAPE-1
01661          IF( LSAME(CMEM(UPLOPTR+I), 'G') ) THEN
01662             CMEM(UPLOPTR+I) = 'G'
01663          ELSE IF( LSAME(CMEM(UPLOPTR+I), 'U') ) THEN
01664             CMEM(UPLOPTR+I) = 'U'
01665          ELSE IF( LSAME(CMEM(UPLOPTR+I), 'L') ) THEN
01666             CMEM(UPLOPTR+I) = 'L'
01667          ELSE
01668             WRITE(OUTNUM, 3000) 'UPLO ', CMEM(UPLOPTR+I)
01669             IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
01670             STOP
01671          END IF
01672    30 CONTINUE
01673 *
01674       READ(SDIN, *) ( CMEM(DIAGPTR+I), I = 0, NSHAPE-1 )
01675       DO 40 I = 0, NSHAPE-1
01676          IF( CMEM(UPLOPTR+I) .NE. 'G' ) THEN
01677             IF( LSAME(CMEM(DIAGPTR+I), 'U') ) THEN
01678                CMEM( DIAGPTR+I ) = 'U'
01679             ELSE IF( LSAME(CMEM(DIAGPTR+I), 'N') ) THEN
01680                CMEM(DIAGPTR+I) = 'N'
01681             ELSE
01682                WRITE(OUTNUM, 3000) 'DIAG ', CMEM(DIAGPTR+I)
01683                IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
01684                STOP
01685             END IF
01686          END IF
01687    40 CONTINUE
01688 *
01689 *     Read in number of matrices, and values for M, N, LDASRC, and LDADEST
01690 *
01691       READ(SDIN, *) NMAT
01692       MPTR = MEMUSED
01693       NPTR = MPTR + NMAT
01694       LDSPTR = NPTR + NMAT
01695       LDDPTR = LDSPTR + NMAT
01696       MEMUSED = LDDPTR + NMAT
01697       IF( MEMUSED .GT. MEMLEN ) THEN
01698          WRITE(OUTNUM, 1000) MEMLEN, NMAT, 'MATRICES.'
01699          IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
01700          STOP
01701       ELSE IF( NMAT .LT. 1 ) THEN
01702          WRITE(OUTNUM, 2000) 'MATRIX.'
01703          IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
01704          STOP
01705       END IF
01706       READ(SDIN, *) ( MEM( MPTR+I ), I = 0, NMAT-1 )
01707       READ(SDIN, *) ( MEM( NPTR+I ), I = 0, NMAT-1 )
01708       READ(SDIN, *) ( MEM( LDSPTR+I ), I = 0, NMAT-1 )
01709       READ(SDIN, *) ( MEM( LDDPTR+I ), I = 0, NMAT-1 )
01710 *
01711 *     Make sure matrix values are legal
01712 *
01713       CALL CHKMATDAT( OUTNUM, 'SDRV.dat', .FALSE., NMAT, MEM(MPTR),
01714      $                MEM(NPTR), MEM(LDSPTR), MEM(LDDPTR), MEM(LDDPTR) )
01715 *
01716 *     Read in number of src/dest pairs, and values of src/dest
01717 *
01718       READ(SDIN, *) NSRC
01719       RSRCPTR  = MEMUSED
01720       CSRCPTR  = RSRCPTR  + NSRC
01721       RDESTPTR = CSRCPTR  + NSRC
01722       CDESTPTR = RDESTPTR + NSRC
01723       MEMUSED  = CDESTPTR + NSRC
01724       IF( MEMUSED .GT. MEMLEN ) THEN
01725          WRITE(OUTNUM, 1000) MEMLEN, NMAT, 'SRC/DEST.'
01726          IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
01727          STOP
01728       ELSE IF( NSRC .LT. 1 ) THEN
01729          WRITE(OUTNUM, 2000) 'SRC/DEST.'
01730          IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
01731          STOP
01732       END IF
01733       READ(SDIN, *) ( MEM(RSRCPTR+I), I = 0, NSRC-1 )
01734       READ(SDIN, *) ( MEM(CSRCPTR+I), I = 0, NSRC-1 )
01735       READ(SDIN, *) ( MEM(RDESTPTR+I), I = 0, NSRC-1 )
01736       READ(SDIN, *) ( MEM(CDESTPTR+I), I = 0, NSRC-1 )
01737 *
01738 *     Read in number of grids pairs, and values of P (process rows) and
01739 *     Q (process columns)
01740 *
01741       READ(SDIN, *) NGRID
01742       PPTR = MEMUSED
01743       QPTR = PPTR + NGRID
01744       MEMUSED = QPTR + NGRID
01745       IF( MEMUSED .GT. MEMLEN ) THEN
01746          WRITE(OUTNUM, 1000) MEMLEN, NGRID, 'PROCESS GRIDS.'
01747          IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
01748          STOP
01749       ELSE IF( NGRID .LT. 1 ) THEN
01750          WRITE(OUTNUM, 2000) 'PROCESS GRID'
01751          IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE( OUTNUM )
01752          STOP
01753       END IF
01754 *
01755       READ(SDIN, *) ( MEM(PPTR+I), I = 0, NGRID-1 )
01756       READ(SDIN, *) ( MEM(QPTR+I), I = 0, NGRID-1 )
01757       IF( SDIN .NE. 6 .AND. SDIN .NE. 0 ) CLOSE( SDIN )
01758 *
01759 *     Fatal error if we've got an illegal grid
01760 *
01761       DO 70 J = 0, NGRID-1
01762          IF( MEM(PPTR+J).LT.1 .OR. MEM(QPTR+J).LT.1 ) THEN
01763             WRITE(OUTNUM, 4000) MEM(PPTR+J), MEM(QPTR+J)
01764             IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
01765             STOP
01766          END IF
01767    70 CONTINUE
01768 *
01769 *     Prepare output variables
01770 *
01771       MEM(MEMUSED)   = NSHAPE
01772       MEM(MEMUSED+1) = NMAT
01773       MEM(MEMUSED+2) = NSRC
01774       MEM(MEMUSED+3) = NGRID
01775       MEMUSED = MEMUSED + 3
01776       CMEMUSED = CMEMUSED - 1
01777 *
01778  1000 FORMAT('Mem too short (',I4,') to handle',I4,' ',A20)
01779  2000 FORMAT('Must have at least one ',A20)
01780  3000 FORMAT('UNRECOGNIZABLE ',A5,' ''', A1, '''.')
01781  4000 FORMAT('Illegal process grid: {',I3,',',I3,'}.')
01782 *
01783       RETURN
01784 *
01785 *     End of RDSDRV.
01786 *
01787       END
01788 *
01789       SUBROUTINE CHKMATDAT( NOUT, INFILE, TSTFLAG, NMAT, M0, N0,
01790      $                      LDAS0, LDAD0, LDI0 )
01791 *
01792 *  -- BLACS tester (version 1.0) --
01793 *  University of Tennessee
01794 *  December 15, 1994
01795 *
01796 *
01797 *     .. Scalar Arguments ..
01798       LOGICAL TSTFLAG
01799       INTEGER NOUT, NMAT
01800 *     ..
01801 *     .. Array Arguments ..
01802       CHARACTER*8 INFILE
01803       INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT)
01804 *     ..
01805 *   Purpose
01806 *  =======
01807 *  CHKMATDAT: Checks that matrix data is correct.
01808 *
01809 *  Arguments
01810 *  =========
01811 *  NOUT    (input) INTEGER
01812 *          The device number to write output to.
01813 *
01814 *  INFILE  (input) CHARACTER*8
01815 *          The name of the input file where matrix values came from.
01816 *
01817 *  TSTFLAG (input) LOGICAL
01818 *          Whether to test RCFLAG (LDI) values or not.
01819 *
01820 *  NMAT    (input) INTEGER
01821 *          The number of matrices to be tested.
01822 *
01823 *  M0      (input) INTEGER array of dimension (NMAT)
01824 *          Values of M to be tested.
01825 *
01826 *  M0      (input) INTEGER array of dimension (NMAT)
01827 *          Values of M to be tested.
01828 *
01829 *  N0      (input) INTEGER array of dimension (NMAT)
01830 *          Values of N to be tested.
01831 *
01832 *  LDAS0   (input) INTEGER array of dimension (NMAT)
01833 *          Values of LDAS (leading dimension of A on source process)
01834 *          to be tested.
01835 *
01836 *  LDAD0   (input) INTEGER array of dimension (NMAT)
01837 *          Values of LDAD (leading dimension of A on destination
01838 *          process) to be tested.
01839 *
01840 *  ====================================================================
01841 *
01842 *     .. Local Scalars ..
01843       LOGICAL MATOK
01844       INTEGER I
01845 *     ..
01846 *     .. Executable Statements ..
01847       MATOK = .TRUE.
01848       DO 10 I = 1, NMAT
01849          IF( M0(I) .LT. 0 ) THEN
01850             WRITE(NOUT,1000) INFILE, 'M', M0(I)
01851             MATOK = .FALSE.
01852          ELSE IF( N0(I) .LT. 0 ) THEN
01853             WRITE(NOUT,1000) INFILE, 'N', N0(I)
01854             MATOK = .FALSE.
01855          ELSE IF( LDAS0(I) .LT. M0(I) ) THEN
01856             WRITE(NOUT,2000) INFILE, 'LDASRC', LDAS0(I), M0(I)
01857             MATOK = .FALSE.
01858          ELSE IF( LDAD0(I) .LT. M0(I) ) THEN
01859             WRITE(NOUT,2000) INFILE, 'LDADST', LDAD0(I), M0(I)
01860             MATOK = .FALSE.
01861          ELSE IF( TSTFLAG ) THEN
01862             IF( (LDI0(I).LT.M0(I)) .AND. (LDI0(I).NE.-1) ) THEN
01863                WRITE(NOUT,2000) INFILE, 'RCFLAG', LDI0(I), M0(I)
01864                MATOK = .FALSE.
01865             END IF
01866          END IF
01867    10 CONTINUE
01868 *
01869       IF( .NOT.MATOK ) THEN
01870          IF( NOUT .NE. 6 .AND. NOUT .NE. 0 ) CLOSE(NOUT)
01871          CALL BLACS_ABORT(-1, 1)
01872       END IF
01873 *
01874  1000 FORMAT(A8,' INPUT ERROR: Illegal ',A1,'; value=',I6,'.')
01875  2000 FORMAT(A8,' INPUT ERROR: Illegal ',A6,'; value=',I6,', but M=',I6)
01876 *
01877       RETURN
01878       END
01879 *
01880       LOGICAL FUNCTION ALLPASS( THISTEST )
01881 *
01882 *  -- BLACS tester (version 1.0) --
01883 *  University of Tennessee
01884 *  December 15, 1994
01885 *
01886 *
01887 *     .. Scalar Arguments ..
01888       LOGICAL THISTEST
01889 *     ..
01890 *  Purpose
01891 *  =======
01892 *  ALLPASS: Returns whether all tests have passed so far.
01893 *
01894 *  =====================================================================
01895 *
01896 *     .. Local Scalars ..
01897       LOGICAL PASSHIST
01898 *     ..
01899 *     .. Save Statement ..
01900       SAVE PASSHIST
01901 *     ..
01902 *     .. Data Statements ..
01903       DATA PASSHIST /.TRUE./
01904 *     ..
01905 *     .. Executable Statements ..
01906       PASSHIST = (PASSHIST .AND. THISTEST)
01907       ALLPASS = PASSHIST
01908 *
01909       RETURN
01910       END
01911 *
01912       SUBROUTINE RDBSBR( MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM, CMEMLEN,
01913      $                   OUTNUM )
01914 *
01915 *  -- BLACS tester (version 1.0) --
01916 *  University of Tennessee
01917 *  December 15, 1994
01918 *
01919 *
01920 *     .. Scalar Arguments ..
01921       INTEGER MEMUSED, MEMLEN, CMEMUSED, CMEMLEN, OUTNUM
01922 *     ..
01923 *     .. Array Arguments ..
01924       CHARACTER*1 CMEM(CMEMLEN)
01925       INTEGER MEM(MEMLEN)
01926 *     ..
01927 *
01928 *     Purpose
01929 *     =======
01930 *     RDBSBR:  Read and process the input file BSBR.dat.
01931 *
01932 *     Arguments
01933 *     =========
01934 *     MEMUSED  (output) INTEGER
01935 *              Number of elements in MEM that this subroutine ends up using.
01936 *
01937 *     MEM      (output) INTEGER array of dimension memlen
01938 *              On output, holds information read in from sdrv.dat.
01939 *
01940 *     MEMLEN   (input) INTEGER
01941 *              Number of elements of MEM that this subroutine
01942 *              may safely write into.
01943 *
01944 *     CMEMUSED (output) INTEGER
01945 *              Number of elements in CMEM that this subroutine ends up using.
01946 *
01947 *     CMEM     (output) CHARACTER*1 array of dimension cmemlen
01948 *              On output, holds the values for UPLO and DIAG.
01949 *
01950 *     CMEMLEN  (input) INTEGER
01951 *              Number of elements of CMEM that this subroutine
01952 *              may safely write into.
01953 *
01954 *     OUTNUM   (input) INTEGER
01955 *              Unit number of the output file.
01956 *
01957 *     =================================================================
01958 *
01959 *     .. Parameters ..
01960       INTEGER SDIN
01961       PARAMETER( SDIN = 12 )
01962 *     ..
01963 *     .. External Functions ..
01964       LOGICAL  LSAME
01965       EXTERNAL LSAME
01966 *     ..
01967 *     .. Local Scalars ..
01968       INTEGER NSCOPE, NTOP, NSHAPE, NMAT, NSRC, NGRID, I, J
01969       INTEGER SCOPEPTR, TOPPTR, UPLOPTR, DIAGPTR, MPTR, NPTR
01970       INTEGER LDSPTR, LDDPTR, RSRCPTR, CSRCPTR, PPTR, QPTR
01971 *     ..
01972 *     .. Executable Statements
01973 *
01974 *     Open and read the file bsbr.dat.  The expected format is
01975 *     below.
01976 *
01977 *------
01978 *integer                         Number of scopes
01979 *array of CHAR*1's               Values for Scopes
01980 *integer                         Number of topologies
01981 *array of CHAR*1's               Values for TOP
01982 *integer                         number of shapes of the matrix
01983 *array of CHAR*1's               UPLO
01984 *array of CHAR*1's               DIAG: unit diagonal or not?
01985 *integer                         number of nmat
01986 *array of integers               M: number of rows in matrix
01987 *array of integers               N: number of columns in matrix
01988 *integer                         LDA: leading dimension on source proc
01989 *integer                         LDA: leading dimension on dest proc
01990 *integer                         number of source/dest pairs
01991 *array of integers               RSRC: process row of message source
01992 *array of integers               CSRC: process column of msg. src.
01993 *integer                         Number of grids
01994 *array of integers               NPROW: number of rows in process grid
01995 *array of integers               NPCOL: number of col's in proc. grid
01996 *------
01997 *  note: UPLO stands for 'upper or lower trapezoidal or general
01998 *        rectangular.'
01999 *  note: the text descriptions as shown above are present in
02000 *             the sample bsbr.dat included with this distribution,
02001 *             but are not required.
02002 *
02003 *     Read input file
02004 *
02005       MEMUSED = 1
02006       CMEMUSED = 1
02007       OPEN(UNIT = SDIN, FILE = 'bsbr.dat', STATUS = 'OLD')
02008 *
02009 *     Read in scopes and topologies
02010 *
02011       READ(SDIN, *) NSCOPE
02012       SCOPEPTR = CMEMUSED
02013       CMEMUSED = SCOPEPTR + NSCOPE
02014       IF ( CMEMUSED .GT. CMEMLEN ) THEN
02015          WRITE(OUTNUM, 1000) CMEMLEN, NSCOPE, 'SCOPES.'
02016          IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
02017          STOP
02018       ELSE IF( NSCOPE .LT. 1 ) THEN
02019          WRITE(OUTNUM, 2000) 'SCOPE.'
02020          IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
02021          STOP
02022       END IF
02023 *
02024       READ(SDIN, *) ( CMEM(SCOPEPTR+I), I = 0, NSCOPE-1 )
02025       DO 20 I = 0, NSCOPE-1
02026          IF( LSAME(CMEM(SCOPEPTR+I), 'R') ) THEN
02027             CMEM(SCOPEPTR+I) = 'R'
02028          ELSE IF( LSAME(CMEM(SCOPEPTR+I), 'C') ) THEN
02029             CMEM(SCOPEPTR+I) = 'C'
02030          ELSE IF( LSAME(CMEM(SCOPEPTR+I), 'A') ) THEN
02031             CMEM(SCOPEPTR+I) = 'A'
02032          ELSE
02033             WRITE(OUTNUM, 3000) 'SCOPE', CMEM(SCOPEPTR+I)
02034             IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
02035             STOP
02036          END IF
02037    20 CONTINUE
02038 *
02039       READ(SDIN, *) NTOP
02040       TOPPTR = CMEMUSED
02041       CMEMUSED = TOPPTR + NTOP
02042       IF ( CMEMUSED .GT. CMEMLEN ) THEN
02043          WRITE(OUTNUM, 1000) CMEMLEN, NTOP, 'TOPOLOGIES.'
02044          IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
02045          STOP
02046       ELSE IF( NTOP .LT. 1 ) THEN
02047          WRITE(OUTNUM, 2000) 'TOPOLOGY.'
02048          IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
02049          STOP
02050       END IF
02051       READ(SDIN, *) ( CMEM(TOPPTR+I), I = 0, NTOP-1 )
02052 *
02053 *
02054 *     Read in number of shapes, and values of UPLO and DIAG
02055 *
02056       READ(SDIN, *) NSHAPE
02057       UPLOPTR = CMEMUSED
02058       DIAGPTR = UPLOPTR + NSHAPE
02059       CMEMUSED = DIAGPTR + NSHAPE
02060       IF ( CMEMUSED .GT. CMEMLEN ) THEN
02061          WRITE(OUTNUM, 1000) CMEMLEN, NSHAPE, 'MATRIX SHAPES.'
02062          IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
02063          STOP
02064       ELSE IF( NSHAPE .LT. 1 ) THEN
02065          WRITE(OUTNUM, 2000) 'MATRIX SHAPE.'
02066          IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
02067          STOP
02068       END IF
02069 *
02070 *     Read in, upcase, and fatal error if UPLO/DIAG not recognized
02071 *
02072       READ(SDIN, *) ( CMEM(UPLOPTR+I), I = 0, NSHAPE-1 )
02073       DO 30 I = 0, NSHAPE-1
02074          IF( LSAME(CMEM(UPLOPTR+I), 'G') ) THEN
02075             CMEM(UPLOPTR+I) = 'G'
02076          ELSE IF( LSAME(CMEM(UPLOPTR+I), 'U') ) THEN
02077             CMEM(UPLOPTR+I) = 'U'
02078          ELSE IF( LSAME(CMEM(UPLOPTR+I), 'L') ) THEN
02079             CMEM(UPLOPTR+I) = 'L'
02080          ELSE
02081             WRITE(OUTNUM, 3000) 'UPLO ', CMEM(UPLOPTR+I)
02082             IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
02083             STOP
02084          END IF
02085    30 CONTINUE
02086 *
02087       READ(SDIN, *) ( CMEM(DIAGPTR+I), I = 0, NSHAPE-1 )
02088       DO 40 I = 0, NSHAPE-1
02089          IF( CMEM(UPLOPTR+I) .NE. 'G' ) THEN
02090             IF( LSAME(CMEM(DIAGPTR+I), 'U') ) THEN
02091                CMEM( DIAGPTR+I ) = 'U'
02092             ELSE IF( LSAME(CMEM(DIAGPTR+I), 'N') ) THEN
02093                CMEM(DIAGPTR+I) = 'N'
02094             ELSE
02095                WRITE(OUTNUM, 3000) 'DIAG ', CMEM(DIAGPTR+I)
02096                IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
02097                STOP
02098             END IF
02099          END IF
02100    40 CONTINUE
02101 *
02102 *     Read in number of matrices, and values for M, N, LDASRC, and LDADEST
02103 *
02104       READ(SDIN, *) NMAT
02105       MPTR = MEMUSED
02106       NPTR = MPTR + NMAT
02107       LDSPTR = NPTR + NMAT
02108       LDDPTR = LDSPTR + NMAT
02109       MEMUSED = LDDPTR + NMAT
02110       IF( MEMUSED .GT. MEMLEN ) THEN
02111          WRITE(OUTNUM, 1000) MEMLEN, NMAT, 'MATRICES.'
02112          IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
02113          STOP
02114       ELSE IF( NMAT .LT. 1 ) THEN
02115          WRITE(OUTNUM, 2000) 'MATRIX.'
02116          IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
02117          STOP
02118       END IF
02119       READ(SDIN, *) ( MEM( MPTR+I ), I = 0, NMAT-1 )
02120       READ(SDIN, *) ( MEM( NPTR+I ), I = 0, NMAT-1 )
02121       READ(SDIN, *) ( MEM( LDSPTR+I ), I = 0, NMAT-1 )
02122       READ(SDIN, *) ( MEM( LDDPTR+I ), I = 0, NMAT-1 )
02123 *
02124 *     Make sure matrix values are legal
02125 *
02126       CALL CHKMATDAT( OUTNUM, 'BSBR.dat', .FALSE., NMAT, MEM(MPTR),
02127      $                MEM(NPTR), MEM(LDSPTR), MEM(LDDPTR), MEM(LDDPTR) )
02128 *
02129 *     Read in number of src pairs, and values of src
02130 *
02131       READ(SDIN, *) NSRC
02132       RSRCPTR  = MEMUSED
02133       CSRCPTR  = RSRCPTR  + NSRC
02134       MEMUSED  = CSRCPTR + NSRC
02135       IF( MEMUSED .GT. MEMLEN ) THEN
02136          WRITE(OUTNUM, 1000) MEMLEN, NMAT, 'SRC.'
02137          IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
02138          STOP
02139       ELSE IF( NSRC .LT. 1 ) THEN
02140          WRITE(OUTNUM, 2000) 'SRC.'
02141          IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
02142          STOP
02143       END IF
02144       READ(SDIN, *) ( MEM(RSRCPTR+I), I = 0, NSRC-1 )
02145       READ(SDIN, *) ( MEM(CSRCPTR+I), I = 0, NSRC-1 )
02146 *
02147 *     Read in number of grids pairs, and values of P (process rows) and
02148 *     Q (process columns)
02149 *
02150       READ(SDIN, *) NGRID
02151       PPTR = MEMUSED
02152       QPTR = PPTR + NGRID
02153       MEMUSED = QPTR + NGRID
02154       IF( MEMUSED .GT. MEMLEN ) THEN
02155          WRITE(OUTNUM, 1000) MEMLEN, NGRID, 'PROCESS GRIDS.'
02156          IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
02157          STOP
02158       ELSE IF( NGRID .LT. 1 ) THEN
02159          WRITE(OUTNUM, 2000) 'PROCESS GRID'
02160          IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE( OUTNUM )
02161          STOP
02162       END IF
02163 *
02164       READ(SDIN, *) ( MEM(PPTR+I), I = 0, NGRID-1 )
02165       READ(SDIN, *) ( MEM(QPTR+I), I = 0, NGRID-1 )
02166       IF( SDIN .NE. 6 .AND. SDIN .NE. 0 ) CLOSE( SDIN )
02167 *
02168 *     Fatal error if we've got an illegal grid
02169 *
02170       DO 70 J = 0, NGRID-1
02171          IF( MEM(PPTR+J).LT.1 .OR. MEM(QPTR+J).LT.1 ) THEN
02172             WRITE(OUTNUM, 4000) MEM(PPTR+J), MEM(QPTR+J)
02173             IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
02174             STOP
02175          END IF
02176    70 CONTINUE
02177 *
02178 *     Prepare output variables
02179 *
02180       MEM(MEMUSED)   = NSCOPE
02181       MEM(MEMUSED+1) = NTOP
02182       MEM(MEMUSED+2) = NSHAPE
02183       MEM(MEMUSED+3) = NMAT
02184       MEM(MEMUSED+4) = NSRC
02185       MEM(MEMUSED+5) = NGRID
02186       MEMUSED = MEMUSED + 5
02187       CMEMUSED = CMEMUSED - 1
02188 *
02189  1000 FORMAT('Mem too short (',I4,') to handle',I4,' ',A20)
02190  2000 FORMAT('Must have at least one ',A20)
02191  3000 FORMAT('UNRECOGNIZABLE ',A5,' ''', A1, '''.')
02192  4000 FORMAT('Illegal process grid: {',I3,',',I3,'}.')
02193 *
02194       RETURN
02195 *
02196 *     End of RDBSBR.
02197 *
02198       END
02199 *
02200 *
02201       SUBROUTINE ISDRVTEST( OUTNUM, VERB, NSHAPE, UPLO0, DIAG0,
02202      $                      NMAT, M0, N0, LDAS0, LDAD0, NSRC, RSRC0,
02203      $                      CSRC0, RDEST0, CDEST0, NGRID, CONTEXT0,
02204      $                      P0, Q0, TFAIL, MEM, MEMLEN )
02205 *
02206 *  -- BLACS tester (version 1.0) --
02207 *  University of Tennessee
02208 *  December 15, 1994
02209 *
02210 *
02211 *     .. Scalar Arguments ..
02212       INTEGER OUTNUM, VERB, NSHAPE, NMAT, NSRC, NGRID, MEMLEN
02213 *     ..
02214 *     .. Array Arguments ..
02215       CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
02216       INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
02217       INTEGER RSRC0(NSRC), CSRC0(NSRC), RDEST0(NSRC), CDEST0(NSRC)
02218       INTEGER CONTEXT0(NGRID), P0(NGRID), Q0(NGRID), TFAIL(*)
02219       INTEGER MEM(MEMLEN)
02220 *     ..
02221 *
02222 *  Purpose
02223 *  =======
02224 *  ITESTSDRV:  Test integer send/recv
02225 *
02226 *  Arguments
02227 *  =========
02228 *  OUTNUM   (input) INTEGER
02229 *           The device number to write output to.
02230 *
02231 *  VERB     (input) INTEGER
02232 *           The level of verbosity (how much printing to do).
02233 *
02234 *  NSHAPE   (input) INTEGER
02235 *           The number of matrix shapes to be tested.
02236 *
02237 *  UPLO0    (input) CHARACTER*1 array of dimension (NSHAPE)
02238 *           Values of UPLO to be tested.
02239 *
02240 *  DIAG0    (input) CHARACTER*1 array of dimension (NSHAPE)
02241 *           Values of DIAG to be tested.
02242 *
02243 *  NMAT     (input) INTEGER
02244 *           The number of matrices to be tested.
02245 *
02246 *  M0       (input) INTEGER array of dimension (NMAT)
02247 *           Values of M to be tested.
02248 *
02249 *  M0       (input) INTEGER array of dimension (NMAT)
02250 *           Values of M to be tested.
02251 *
02252 *  N0       (input) INTEGER array of dimension (NMAT)
02253 *           Values of N to be tested.
02254 *
02255 *  LDAS0    (input) INTEGER array of dimension (NMAT)
02256 *           Values of LDAS (leading dimension of A on source process)
02257 *           to be tested.
02258 *
02259 *  LDAD0    (input) INTEGER array of dimension (NMAT)
02260 *           Values of LDAD (leading dimension of A on destination
02261 *           process) to be tested.
02262 *  NSRC     (input) INTEGER
02263 *           The number of sources to be tested.
02264 *
02265 *  RSRC0    (input) INTEGER array of dimension (NDEST)
02266 *           Values of RSRC (row coordinate of source) to be tested.
02267 *
02268 *  CSRC0    (input) INTEGER array of dimension (NDEST)
02269 *           Values of CSRC (column coordinate of source) to be tested.
02270 *
02271 *  RDEST0   (input) INTEGER array of dimension (NNSRC)
02272 *           Values of RDEST (row coordinate of destination) to be
02273 *           tested.
02274 *
02275 *  CDEST0   (input) INTEGER array of dimension (NNSRC)
02276 *           Values of CDEST (column coordinate of destination) to be
02277 *           tested.
02278 *
02279 *  NGRID    (input) INTEGER
02280 *           The number of process grids to be tested.
02281 *
02282 *  CONTEXT0 (input) INTEGER array of dimension (NGRID)
02283 *           The BLACS context handles corresponding to the grids.
02284 *
02285 *  P0       (input) INTEGER array of dimension (NGRID)
02286 *           Values of P (number of process rows, NPROW).
02287 *
02288 *  Q0       (input) INTEGER array of dimension (NGRID)
02289 *           Values of Q (number of process columns, NPCOL).
02290 *
02291 *  TFAIL    (workspace) INTEGER array of dimension (NTESTS)
02292 *           If VERB < 2, serves to indicate which tests fail.  This
02293 *           requires workspace of NTESTS (number of tests performed).
02294 *
02295 *  MEM      (workspace) INTEGER array of dimension (MEMLEN)
02296 *           Used for all other workspaces, including the matrix A,
02297 *           and its pre and post padding.
02298 *
02299 *  MEMLEN   (input) INTEGER
02300 *           The length, in elements, of MEM.
02301 *
02302 * =====================================================================
02303 *
02304 *     .. External Functions ..
02305       LOGICAL ALLPASS
02306       INTEGER  IBTMYPROC, IBTSIZEOF
02307       EXTERNAL ALLPASS, IBTMYPROC, IBTSIZEOF
02308 *     ..
02309 *     .. External Subroutines ..
02310       EXTERNAL BLACS_GRIDINFO
02311       EXTERNAL ITRSD2D, IGESD2D, ITRRV2D, IGERV2D
02312       EXTERNAL IINITMAT, ICHKMAT, ICHKPAD, IBTCHECKIN
02313 *     ..
02314 *     .. Local Scalars ..
02315       CHARACTER*1 UPLO, DIAG
02316       LOGICAL TESTOK
02317       INTEGER IAM, I, K, IGR, ISH, IMA, ISO, MYROW, MYCOL, IPRE, IPOST
02318       INTEGER M, N, NPROW, NPCOL, RSRC, CSRC, RDEST, CDEST
02319       INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
02320       INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE
02321       INTEGER SCHECKVAL, RCHECKVAL
02322 *     ..
02323 *     .. Executable Statements ..
02324 *
02325       SCHECKVAL = -1
02326       RCHECKVAL = -2
02327 *
02328       IAM = IBTMYPROC()
02329       ISIZE = IBTSIZEOF('I')
02330       ISIZE = IBTSIZEOF('I')
02331 *
02332 *     Verify file parameters
02333 *
02334       IF( IAM .EQ. 0 ) THEN
02335          WRITE(OUTNUM, *) '  '
02336          WRITE(OUTNUM, *) '  '
02337          WRITE(OUTNUM, 1000 )
02338          IF( VERB .GT. 0 ) THEN
02339             WRITE(OUTNUM,*) '  '
02340             WRITE(OUTNUM, 2000) 'NSHAPE:', NSHAPE
02341             WRITE(OUTNUM, 3000) ' UPLO :', ( UPLO0(I), I = 1, NSHAPE )
02342             WRITE(OUTNUM, 3000) ' DIAG :', ( DIAG0(I), I = 1, NSHAPE )
02343             WRITE(OUTNUM, 2000) 'NMAT  :', NMAT
02344             WRITE(OUTNUM, 2000) ' M    :', ( M0(I), I = 1, NMAT )
02345             WRITE(OUTNUM, 2000) ' N    :', ( N0(I), I = 1, NMAT )
02346             WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT )
02347             WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT )
02348             WRITE(OUTNUM, 2000) 'NSRC  :', NSRC
02349             WRITE(OUTNUM, 2000) ' RSRC :',( RSRC0(I), I = 1, NSRC )
02350             WRITE(OUTNUM, 2000) ' CSRC :',( CSRC0(I), I = 1, NSRC )
02351             WRITE(OUTNUM, 2000) ' RDEST:',( RDEST0(I), I = 1, NSRC )
02352             WRITE(OUTNUM, 2000) ' CDEST:',( CDEST0(I), I = 1, NSRC )
02353             WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID
02354             WRITE(OUTNUM, 2000) ' P    :', ( P0(I), I = 1, NGRID )
02355             WRITE(OUTNUM, 2000) ' Q    :', ( Q0(I), I = 1, NGRID )
02356             WRITE(OUTNUM, 2000) 'VERB  :', VERB
02357             WRITE(OUTNUM,*) '  '
02358          END IF
02359          IF( VERB .GT. 1 ) THEN
02360             WRITE(OUTNUM,5000)
02361             WRITE(OUTNUM,6000)
02362          END IF
02363       END IF
02364 *
02365 *     Find biggest matrix, so we know where to stick error info
02366 *
02367       I = 0
02368       DO 10 IMA = 1, NMAT
02369          K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + 4 * M0(IMA)
02370          IF( K .GT. I ) I = K
02371    10 CONTINUE
02372       MAXERR = ( ISIZE * (MEMLEN-I) ) / ( ISIZE*2 + ISIZE*6 )
02373       IF( MAXERR .LT. 1 ) THEN
02374          WRITE(OUTNUM,*) 'ERROR: Not enough memory to run SDRV tests.'
02375          CALL BLACS_ABORT(-1, 1)
02376       END IF
02377       ERRDPTR = I + 1
02378       ERRIPTR = ERRDPTR + MAXERR
02379       NERR = 0
02380       TESTNUM = 0
02381       NFAIL = 0
02382       NSKIP = 0
02383 *
02384 *     Loop over grids of matrix
02385 *
02386       DO 110 IGR = 1, NGRID
02387 *
02388          CONTEXT = CONTEXT0(IGR)
02389          CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL )
02390 *
02391          DO 80 ISH = 1, NSHAPE
02392             UPLO = UPLO0(ISH)
02393             DIAG = DIAG0(ISH)
02394 *
02395             DO 70 IMA = 1, NMAT
02396                M = M0(IMA)
02397                N = N0(IMA)
02398                LDASRC = LDAS0(IMA)
02399                LDADST = LDAD0(IMA)
02400 *
02401                DO 60 ISO = 1, NSRC
02402                   TESTNUM = TESTNUM + 1
02403                   RSRC = RSRC0(ISO)
02404                   CSRC = CSRC0(ISO)
02405                   IF( RSRC.GE.P0(IGR) .OR. CSRC.GE.Q0(IGR) ) THEN
02406                      NSKIP = NSKIP + 1
02407                      GOTO 60
02408                   END IF
02409                   RDEST = RDEST0(ISO)
02410                   CDEST = CDEST0(ISO)
02411                   IF( RDEST.GE.P0(IGR) .OR. CDEST.GE.Q0(IGR) ) THEN
02412                      NSKIP = NSKIP + 1
02413                      GOTO 60
02414                   END IF
02415 *
02416                   IF( VERB .GT. 1 ) THEN
02417                      IF( IAM .EQ. 0 ) THEN
02418                         WRITE(OUTNUM, 7000) TESTNUM, 'RUNNING',
02419      $                                      UPLO, DIAG, M, N,
02420      $                                      LDASRC, LDADST, RSRC, CSRC,
02421      $                                      RDEST, CDEST, NPROW, NPCOL
02422                      END IF
02423                   END IF
02424 *
02425                   TESTOK = .TRUE.
02426                   IPRE  = 2 * M
02427                   IPOST = IPRE
02428                   APTR = IPRE + 1
02429 *
02430 *                 source process generates matrix and sends it
02431 *
02432                   IF( MYROW .EQ. RSRC .AND. MYCOL .EQ. CSRC ) THEN
02433                      CALL IINITMAT( UPLO, DIAG, M, N, MEM, LDASRC,
02434      $                              IPRE, IPOST, SCHECKVAL, TESTNUM,
02435      $                              MYROW, MYCOL )
02436 *
02437                      IF( UPLO .EQ. 'U' .OR. UPLO .EQ. 'L' ) THEN
02438                          CALL ITRSD2D( CONTEXT, UPLO, DIAG, M, N,
02439      $                                 MEM(APTR), LDASRC, RDEST, CDEST )
02440                      ELSE
02441                          CALL IGESD2D( CONTEXT, M, N, MEM(APTR),
02442      $                                 LDASRC, RDEST, CDEST )
02443                      END IF
02444                   END IF
02445 *
02446                   IF( MYROW .EQ. RDEST .AND. MYCOL .EQ. CDEST ) THEN
02447 *
02448 *                    Pad entire matrix area
02449 *
02450                      DO 50 K = 1, IPRE+IPOST+LDADST*N
02451                         MEM(K) = RCHECKVAL
02452    50                CONTINUE
02453 *
02454 *                    Receive matrix
02455 *
02456                      IF( UPLO .EQ. 'U' .OR. UPLO .EQ. 'L' ) THEN
02457                         CALL ITRRV2D( CONTEXT, UPLO, DIAG, M, N,
02458      $                                MEM(APTR), LDADST, RSRC, CSRC )
02459                      ELSE
02460                         CALL IGERV2D( CONTEXT, M, N, MEM(APTR),
02461      $                                LDADST, RSRC, CSRC )
02462                      END IF
02463 *
02464 *                    Check for errors in matrix or padding
02465 *
02466                      I = NERR
02467                      CALL ICHKMAT( UPLO, DIAG, M, N, MEM(APTR), LDADST,
02468      $                        RSRC, CSRC, MYROW, MYCOL, TESTNUM, MAXERR,
02469      $                        NERR, MEM(ERRIPTR), MEM(ERRDPTR) )
02470 *
02471                      CALL ICHKPAD( UPLO, DIAG, M, N, MEM, LDADST,
02472      $                        RSRC, CSRC, MYROW, MYCOL, IPRE, IPOST,
02473      $                        RCHECKVAL, TESTNUM, MAXERR, NERR,
02474      $                        MEM(ERRIPTR), MEM(ERRDPTR) )
02475                      TESTOK = I .EQ. NERR
02476                   END IF
02477 *
02478                   IF( VERB .GT. 1 ) THEN
02479                      I = NERR
02480                      CALL IBTCHECKIN( 0, OUTNUM, MAXERR, NERR,
02481      $                                MEM(ERRIPTR), MEM(ERRDPTR),
02482      $                                TFAIL )
02483                      IF( IAM .EQ. 0 ) THEN
02484                         IF( TESTOK .AND. I.EQ.NERR ) THEN
02485                            WRITE(OUTNUM, 7000) TESTNUM, 'PASSED ',
02486      $                           UPLO, DIAG, M, N, LDASRC, LDADST,
02487      $                           RSRC, CSRC, RDEST, CDEST, NPROW, NPCOL
02488                         ELSE
02489                            NFAIL = NFAIL + 1
02490                            WRITE(OUTNUM, 7000) TESTNUM, 'FAILED ',
02491      $                          UPLO, DIAG, M, N, LDASRC, LDADST,
02492      $                          RSRC, CSRC, RDEST, CDEST, NPROW, NPCOL
02493                         ENDIF
02494                      END IF
02495 *
02496 *                    Once we've printed out errors, can re-use buf space
02497 *
02498                      NERR = 0
02499                   END IF
02500    60          CONTINUE
02501    70       CONTINUE
02502    80    CONTINUE
02503   110 CONTINUE
02504 *
02505       IF( VERB .LT. 2 ) THEN
02506          NFAIL = TESTNUM
02507          CALL IBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR),
02508      $                    MEM(ERRDPTR), TFAIL )
02509       END IF
02510       IF( IAM .EQ. 0 ) THEN
02511          IF( VERB .GT. 1 ) WRITE(OUTNUM,*) '   '
02512          IF( NFAIL+NSKIP .EQ. 0 ) THEN
02513             WRITE(OUTNUM, 8000 ) TESTNUM
02514          ELSE
02515             WRITE(OUTNUM, 9000 ) TESTNUM, TESTNUM-NSKIP-NFAIL,
02516      $                           NSKIP, NFAIL
02517          END IF
02518       END IF
02519 *
02520 *     Log whether their were any failures
02521 *
02522       TESTOK = ALLPASS( (NFAIL.EQ.0) )
02523 *
02524  1000 FORMAT('INTEGER SDRV TESTS: BEGIN.' )
02525  2000 FORMAT(1X,A7,3X,10I6)
02526  3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,
02527      $       5X,A1,5X,A1)
02528  5000 FORMAT(' TEST#  STATUS UPLO DIA     M     N  LDAS  LDAD RSRC ',
02529      $       'CSRC RDEST CDEST    P    Q')
02530  6000 FORMAT(' ----- ------- ---- --- ----- ----- ----- ----- ---- ',
02531      $       '---- ----- ----- ---- ----')
02532  7000 FORMAT(I6,1X,A7,4X,A1,3X,A1,4I6,2I5,2I6,2I5)
02533  8000 FORMAT('INTEGER SDRV TESTS: PASSED ALL',
02534      $       I5, ' TESTS.')
02535  9000 FORMAT('INTEGER SDRV TESTS:',I5,' TESTS;',I5,' PASSED,',
02536      $       I5,' SKIPPED,',I5,' FAILED.')
02537 *
02538       RETURN
02539 *
02540 *     End of ISDRVTEST.
02541 *
02542       END
02543 *
02544 *
02545       SUBROUTINE SSDRVTEST( OUTNUM, VERB, NSHAPE, UPLO0, DIAG0,
02546      $                      NMAT, M0, N0, LDAS0, LDAD0, NSRC, RSRC0,
02547      $                      CSRC0, RDEST0, CDEST0, NGRID, CONTEXT0,
02548      $                      P0, Q0, TFAIL, MEM, MEMLEN )
02549 *
02550 *  -- BLACS tester (version 1.0) --
02551 *  University of Tennessee
02552 *  December 15, 1994
02553 *
02554 *
02555 *     .. Scalar Arguments ..
02556       INTEGER OUTNUM, VERB, NSHAPE, NMAT, NSRC, NGRID, MEMLEN
02557 *     ..
02558 *     .. Array Arguments ..
02559       CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
02560       INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
02561       INTEGER RSRC0(NSRC), CSRC0(NSRC), RDEST0(NSRC), CDEST0(NSRC)
02562       INTEGER CONTEXT0(NGRID), P0(NGRID), Q0(NGRID), TFAIL(*)
02563       REAL MEM(MEMLEN)
02564 *     ..
02565 *
02566 *  Purpose
02567 *  =======
02568 *  STESTSDRV:  Test real send/recv
02569 *
02570 *  Arguments
02571 *  =========
02572 *  OUTNUM   (input) INTEGER
02573 *           The device number to write output to.
02574 *
02575 *  VERB     (input) INTEGER
02576 *           The level of verbosity (how much printing to do).
02577 *
02578 *  NSHAPE   (input) INTEGER
02579 *           The number of matrix shapes to be tested.
02580 *
02581 *  UPLO0    (input) CHARACTER*1 array of dimension (NSHAPE)
02582 *           Values of UPLO to be tested.
02583 *
02584 *  DIAG0    (input) CHARACTER*1 array of dimension (NSHAPE)
02585 *           Values of DIAG to be tested.
02586 *
02587 *  NMAT     (input) INTEGER
02588 *           The number of matrices to be tested.
02589 *
02590 *  M0       (input) INTEGER array of dimension (NMAT)
02591 *           Values of M to be tested.
02592 *
02593 *  M0       (input) INTEGER array of dimension (NMAT)
02594 *           Values of M to be tested.
02595 *
02596 *  N0       (input) INTEGER array of dimension (NMAT)
02597 *           Values of N to be tested.
02598 *
02599 *  LDAS0    (input) INTEGER array of dimension (NMAT)
02600 *           Values of LDAS (leading dimension of A on source process)
02601 *           to be tested.
02602 *
02603 *  LDAD0    (input) INTEGER array of dimension (NMAT)
02604 *           Values of LDAD (leading dimension of A on destination
02605 *           process) to be tested.
02606 *  NSRC     (input) INTEGER
02607 *           The number of sources to be tested.
02608 *
02609 *  RSRC0    (input) INTEGER array of dimension (NDEST)
02610 *           Values of RSRC (row coordinate of source) to be tested.
02611 *
02612 *  CSRC0    (input) INTEGER array of dimension (NDEST)
02613 *           Values of CSRC (column coordinate of source) to be tested.
02614 *
02615 *  RDEST0   (input) INTEGER array of dimension (NNSRC)
02616 *           Values of RDEST (row coordinate of destination) to be
02617 *           tested.
02618 *
02619 *  CDEST0   (input) INTEGER array of dimension (NNSRC)
02620 *           Values of CDEST (column coordinate of destination) to be
02621 *           tested.
02622 *
02623 *  NGRID    (input) INTEGER
02624 *           The number of process grids to be tested.
02625 *
02626 *  CONTEXT0 (input) INTEGER array of dimension (NGRID)
02627 *           The BLACS context handles corresponding to the grids.
02628 *
02629 *  P0       (input) INTEGER array of dimension (NGRID)
02630 *           Values of P (number of process rows, NPROW).
02631 *
02632 *  Q0       (input) INTEGER array of dimension (NGRID)
02633 *           Values of Q (number of process columns, NPCOL).
02634 *
02635 *  TFAIL    (workspace) INTEGER array of dimension (NTESTS)
02636 *           If VERB < 2, serves to indicate which tests fail.  This
02637 *           requires workspace of NTESTS (number of tests performed).
02638 *
02639 *  MEM      (workspace) REAL array of dimension (MEMLEN)
02640 *           Used for all other workspaces, including the matrix A,
02641 *           and its pre and post padding.
02642 *
02643 *  MEMLEN   (input) INTEGER
02644 *           The length, in elements, of MEM.
02645 *
02646 * =====================================================================
02647 *
02648 *     .. External Functions ..
02649       LOGICAL ALLPASS
02650       INTEGER  IBTMYPROC, IBTSIZEOF
02651       EXTERNAL ALLPASS, IBTMYPROC, IBTSIZEOF
02652 *     ..
02653 *     .. External Subroutines ..
02654       EXTERNAL BLACS_GRIDINFO
02655       EXTERNAL STRSD2D, SGESD2D, STRRV2D, SGERV2D
02656       EXTERNAL SINITMAT, SCHKMAT, SCHKPAD, SBTCHECKIN
02657 *     ..
02658 *     .. Local Scalars ..
02659       CHARACTER*1 UPLO, DIAG
02660       LOGICAL TESTOK
02661       INTEGER IAM, I, K, IGR, ISH, IMA, ISO, MYROW, MYCOL, IPRE, IPOST
02662       INTEGER M, N, NPROW, NPCOL, RSRC, CSRC, RDEST, CDEST
02663       INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
02664       INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE, SSIZE
02665       REAL SCHECKVAL, RCHECKVAL
02666 *     ..
02667 *     .. Executable Statements ..
02668 *
02669       SCHECKVAL = -0.01E0
02670       RCHECKVAL = -0.02E0
02671 *
02672       IAM = IBTMYPROC()
02673       ISIZE = IBTSIZEOF('I')
02674       SSIZE = IBTSIZEOF('S')
02675 *
02676 *     Verify file parameters
02677 *
02678       IF( IAM .EQ. 0 ) THEN
02679          WRITE(OUTNUM, *) '  '
02680          WRITE(OUTNUM, *) '  '
02681          WRITE(OUTNUM, 1000 )
02682          IF( VERB .GT. 0 ) THEN
02683             WRITE(OUTNUM,*) '  '
02684             WRITE(OUTNUM, 2000) 'NSHAPE:', NSHAPE
02685             WRITE(OUTNUM, 3000) ' UPLO :', ( UPLO0(I), I = 1, NSHAPE )
02686             WRITE(OUTNUM, 3000) ' DIAG :', ( DIAG0(I), I = 1, NSHAPE )
02687             WRITE(OUTNUM, 2000) 'NMAT  :', NMAT
02688             WRITE(OUTNUM, 2000) ' M    :', ( M0(I), I = 1, NMAT )
02689             WRITE(OUTNUM, 2000) ' N    :', ( N0(I), I = 1, NMAT )
02690             WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT )
02691             WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT )
02692             WRITE(OUTNUM, 2000) 'NSRC  :', NSRC
02693             WRITE(OUTNUM, 2000) ' RSRC :',( RSRC0(I), I = 1, NSRC )
02694             WRITE(OUTNUM, 2000) ' CSRC :',( CSRC0(I), I = 1, NSRC )
02695             WRITE(OUTNUM, 2000) ' RDEST:',( RDEST0(I), I = 1, NSRC )
02696             WRITE(OUTNUM, 2000) ' CDEST:',( CDEST0(I), I = 1, NSRC )
02697             WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID
02698             WRITE(OUTNUM, 2000) ' P    :', ( P0(I), I = 1, NGRID )
02699             WRITE(OUTNUM, 2000) ' Q    :', ( Q0(I), I = 1, NGRID )
02700             WRITE(OUTNUM, 2000) 'VERB  :', VERB
02701             WRITE(OUTNUM,*) '  '
02702          END IF
02703          IF( VERB .GT. 1 ) THEN
02704             WRITE(OUTNUM,5000)
02705             WRITE(OUTNUM,6000)
02706          END IF
02707       END IF
02708 *
02709 *     Find biggest matrix, so we know where to stick error info
02710 *
02711       I = 0
02712       DO 10 IMA = 1, NMAT
02713          K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + 4 * M0(IMA)
02714          IF( K .GT. I ) I = K
02715    10 CONTINUE
02716       MAXERR = ( SSIZE * (MEMLEN-I) ) / ( SSIZE*2 + ISIZE*6 )
02717       IF( MAXERR .LT. 1 ) THEN
02718          WRITE(OUTNUM,*) 'ERROR: Not enough memory to run SDRV tests.'
02719          CALL BLACS_ABORT(-1, 1)
02720       END IF
02721       ERRDPTR = I + 1
02722       ERRIPTR = ERRDPTR + MAXERR
02723       NERR = 0
02724       TESTNUM = 0
02725       NFAIL = 0
02726       NSKIP = 0
02727 *
02728 *     Loop over grids of matrix
02729 *
02730       DO 110 IGR = 1, NGRID
02731 *
02732          CONTEXT = CONTEXT0(IGR)
02733          CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL )
02734 *
02735          DO 80 ISH = 1, NSHAPE
02736             UPLO = UPLO0(ISH)
02737             DIAG = DIAG0(ISH)
02738 *
02739             DO 70 IMA = 1, NMAT
02740                M = M0(IMA)
02741                N = N0(IMA)
02742                LDASRC = LDAS0(IMA)
02743                LDADST = LDAD0(IMA)
02744 *
02745                DO 60 ISO = 1, NSRC
02746                   TESTNUM = TESTNUM + 1
02747                   RSRC = RSRC0(ISO)
02748                   CSRC = CSRC0(ISO)
02749                   IF( RSRC.GE.P0(IGR) .OR. CSRC.GE.Q0(IGR) ) THEN
02750                      NSKIP = NSKIP + 1
02751                      GOTO 60
02752                   END IF
02753                   RDEST = RDEST0(ISO)
02754                   CDEST = CDEST0(ISO)
02755                   IF( RDEST.GE.P0(IGR) .OR. CDEST.GE.Q0(IGR) ) THEN
02756                      NSKIP = NSKIP + 1
02757                      GOTO 60
02758                   END IF
02759 *
02760                   IF( VERB .GT. 1 ) THEN
02761                      IF( IAM .EQ. 0 ) THEN
02762                         WRITE(OUTNUM, 7000) TESTNUM, 'RUNNING',
02763      $                                      UPLO, DIAG, M, N,
02764      $                                      LDASRC, LDADST, RSRC, CSRC,
02765      $                                      RDEST, CDEST, NPROW, NPCOL
02766                      END IF
02767                   END IF
02768 *
02769                   TESTOK = .TRUE.
02770                   IPRE  = 2 * M
02771                   IPOST = IPRE
02772                   APTR = IPRE + 1
02773 *
02774 *                 source process generates matrix and sends it
02775 *
02776                   IF( MYROW .EQ. RSRC .AND. MYCOL .EQ. CSRC ) THEN
02777                      CALL SINITMAT( UPLO, DIAG, M, N, MEM, LDASRC,
02778      $                              IPRE, IPOST, SCHECKVAL, TESTNUM,
02779      $                              MYROW, MYCOL )
02780 *
02781                      IF( UPLO .EQ. 'U' .OR. UPLO .EQ. 'L' ) THEN
02782                          CALL STRSD2D( CONTEXT, UPLO, DIAG, M, N,
02783      $                                 MEM(APTR), LDASRC, RDEST, CDEST )
02784                      ELSE
02785                          CALL SGESD2D( CONTEXT, M, N, MEM(APTR),
02786      $                                 LDASRC, RDEST, CDEST )
02787                      END IF
02788                   END IF
02789 *
02790                   IF( MYROW .EQ. RDEST .AND. MYCOL .EQ. CDEST ) THEN
02791 *
02792 *                    Pad entire matrix area
02793 *
02794                      DO 50 K = 1, IPRE+IPOST+LDADST*N
02795                         MEM(K) = RCHECKVAL
02796    50                CONTINUE
02797 *
02798 *                    Receive matrix
02799 *
02800                      IF( UPLO .EQ. 'U' .OR. UPLO .EQ. 'L' ) THEN
02801                         CALL STRRV2D( CONTEXT, UPLO, DIAG, M, N,
02802      $                                MEM(APTR), LDADST, RSRC, CSRC )
02803                      ELSE
02804                         CALL SGERV2D( CONTEXT, M, N, MEM(APTR),
02805      $                                LDADST, RSRC, CSRC )
02806                      END IF
02807 *
02808 *                    Check for errors in matrix or padding
02809 *
02810                      I = NERR
02811                      CALL SCHKMAT( UPLO, DIAG, M, N, MEM(APTR), LDADST,
02812      $                        RSRC, CSRC, MYROW, MYCOL, TESTNUM, MAXERR,
02813      $                        NERR, MEM(ERRIPTR), MEM(ERRDPTR) )
02814 *
02815                      CALL SCHKPAD( UPLO, DIAG, M, N, MEM, LDADST,
02816      $                        RSRC, CSRC, MYROW, MYCOL, IPRE, IPOST,
02817      $                        RCHECKVAL, TESTNUM, MAXERR, NERR,
02818      $                        MEM(ERRIPTR), MEM(ERRDPTR) )
02819                      TESTOK = I .EQ. NERR
02820                   END IF
02821 *
02822                   IF( VERB .GT. 1 ) THEN
02823                      I = NERR
02824                      CALL SBTCHECKIN( 0, OUTNUM, MAXERR, NERR,
02825      $                                MEM(ERRIPTR), MEM(ERRDPTR),
02826      $                                TFAIL )
02827                      IF( IAM .EQ. 0 ) THEN
02828                         IF( TESTOK .AND. I.EQ.NERR ) THEN
02829                            WRITE(OUTNUM, 7000) TESTNUM, 'PASSED ',
02830      $                           UPLO, DIAG, M, N, LDASRC, LDADST,
02831      $                           RSRC, CSRC, RDEST, CDEST, NPROW, NPCOL
02832                         ELSE
02833                            NFAIL = NFAIL + 1
02834                            WRITE(OUTNUM, 7000) TESTNUM, 'FAILED ',
02835      $                          UPLO, DIAG, M, N, LDASRC, LDADST,
02836      $                          RSRC, CSRC, RDEST, CDEST, NPROW, NPCOL
02837                         ENDIF
02838                      END IF
02839 *
02840 *                    Once we've printed out errors, can re-use buf space
02841 *
02842                      NERR = 0
02843                   END IF
02844    60          CONTINUE
02845    70       CONTINUE
02846    80    CONTINUE
02847   110 CONTINUE
02848 *
02849       IF( VERB .LT. 2 ) THEN
02850          NFAIL = TESTNUM
02851          CALL SBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR),
02852      $                    MEM(ERRDPTR), TFAIL )
02853       END IF
02854       IF( IAM .EQ. 0 ) THEN
02855          IF( VERB .GT. 1 ) WRITE(OUTNUM,*) '   '
02856          IF( NFAIL+NSKIP .EQ. 0 ) THEN
02857             WRITE(OUTNUM, 8000 ) TESTNUM
02858          ELSE
02859             WRITE(OUTNUM, 9000 ) TESTNUM, TESTNUM-NSKIP-NFAIL,
02860      $                           NSKIP, NFAIL
02861          END IF
02862       END IF
02863 *
02864 *     Log whether their were any failures
02865 *
02866       TESTOK = ALLPASS( (NFAIL.EQ.0) )
02867 *
02868  1000 FORMAT('REAL SDRV TESTS: BEGIN.' )
02869  2000 FORMAT(1X,A7,3X,10I6)
02870  3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,
02871      $       5X,A1,5X,A1)
02872  5000 FORMAT(' TEST#  STATUS UPLO DIA     M     N  LDAS  LDAD RSRC ',
02873      $       'CSRC RDEST CDEST    P    Q')
02874  6000 FORMAT(' ----- ------- ---- --- ----- ----- ----- ----- ---- ',
02875      $       '---- ----- ----- ---- ----')
02876  7000 FORMAT(I6,1X,A7,4X,A1,3X,A1,4I6,2I5,2I6,2I5)
02877  8000 FORMAT('REAL SDRV TESTS: PASSED ALL',
02878      $       I5, ' TESTS.')
02879  9000 FORMAT('REAL SDRV TESTS:',I5,' TESTS;',I5,' PASSED,',
02880      $       I5,' SKIPPED,',I5,' FAILED.')
02881 *
02882       RETURN
02883 *
02884 *     End of SSDRVTEST.
02885 *
02886       END
02887 *
02888 *
02889       SUBROUTINE DSDRVTEST( OUTNUM, VERB, NSHAPE, UPLO0, DIAG0,
02890      $                      NMAT, M0, N0, LDAS0, LDAD0, NSRC, RSRC0,
02891      $                      CSRC0, RDEST0, CDEST0, NGRID, CONTEXT0,
02892      $                      P0, Q0, TFAIL, MEM, MEMLEN )
02893 *
02894 *  -- BLACS tester (version 1.0) --
02895 *  University of Tennessee
02896 *  December 15, 1994
02897 *
02898 *
02899 *     .. Scalar Arguments ..
02900       INTEGER OUTNUM, VERB, NSHAPE, NMAT, NSRC, NGRID, MEMLEN
02901 *     ..
02902 *     .. Array Arguments ..
02903       CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
02904       INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
02905       INTEGER RSRC0(NSRC), CSRC0(NSRC), RDEST0(NSRC), CDEST0(NSRC)
02906       INTEGER CONTEXT0(NGRID), P0(NGRID), Q0(NGRID), TFAIL(*)
02907       DOUBLE PRECISION MEM(MEMLEN)
02908 *     ..
02909 *
02910 *  Purpose
02911 *  =======
02912 *  DTESTSDRV:  Test double precision send/recv
02913 *
02914 *  Arguments
02915 *  =========
02916 *  OUTNUM   (input) INTEGER
02917 *           The device number to write output to.
02918 *
02919 *  VERB     (input) INTEGER
02920 *           The level of verbosity (how much printing to do).
02921 *
02922 *  NSHAPE   (input) INTEGER
02923 *           The number of matrix shapes to be tested.
02924 *
02925 *  UPLO0    (input) CHARACTER*1 array of dimension (NSHAPE)
02926 *           Values of UPLO to be tested.
02927 *
02928 *  DIAG0    (input) CHARACTER*1 array of dimension (NSHAPE)
02929 *           Values of DIAG to be tested.
02930 *
02931 *  NMAT     (input) INTEGER
02932 *           The number of matrices to be tested.
02933 *
02934 *  M0       (input) INTEGER array of dimension (NMAT)
02935 *           Values of M to be tested.
02936 *
02937 *  M0       (input) INTEGER array of dimension (NMAT)
02938 *           Values of M to be tested.
02939 *
02940 *  N0       (input) INTEGER array of dimension (NMAT)
02941 *           Values of N to be tested.
02942 *
02943 *  LDAS0    (input) INTEGER array of dimension (NMAT)
02944 *           Values of LDAS (leading dimension of A on source process)
02945 *           to be tested.
02946 *
02947 *  LDAD0    (input) INTEGER array of dimension (NMAT)
02948 *           Values of LDAD (leading dimension of A on destination
02949 *           process) to be tested.
02950 *  NSRC     (input) INTEGER
02951 *           The number of sources to be tested.
02952 *
02953 *  RSRC0    (input) INTEGER array of dimension (NDEST)
02954 *           Values of RSRC (row coordinate of source) to be tested.
02955 *
02956 *  CSRC0    (input) INTEGER array of dimension (NDEST)
02957 *           Values of CSRC (column coordinate of source) to be tested.
02958 *
02959 *  RDEST0   (input) INTEGER array of dimension (NNSRC)
02960 *           Values of RDEST (row coordinate of destination) to be
02961 *           tested.
02962 *
02963 *  CDEST0   (input) INTEGER array of dimension (NNSRC)
02964 *           Values of CDEST (column coordinate of destination) to be
02965 *           tested.
02966 *
02967 *  NGRID    (input) INTEGER
02968 *           The number of process grids to be tested.
02969 *
02970 *  CONTEXT0 (input) INTEGER array of dimension (NGRID)
02971 *           The BLACS context handles corresponding to the grids.
02972 *
02973 *  P0       (input) INTEGER array of dimension (NGRID)
02974 *           Values of P (number of process rows, NPROW).
02975 *
02976 *  Q0       (input) INTEGER array of dimension (NGRID)
02977 *           Values of Q (number of process columns, NPCOL).
02978 *
02979 *  TFAIL    (workspace) INTEGER array of dimension (NTESTS)
02980 *           If VERB < 2, serves to indicate which tests fail.  This
02981 *           requires workspace of NTESTS (number of tests performed).
02982 *
02983 *  MEM      (workspace) DOUBLE PRECISION array of dimension (MEMLEN)
02984 *           Used for all other workspaces, including the matrix A,
02985 *           and its pre and post padding.
02986 *
02987 *  MEMLEN   (input) INTEGER
02988 *           The length, in elements, of MEM.
02989 *
02990 * =====================================================================
02991 *
02992 *     .. External Functions ..
02993       LOGICAL ALLPASS
02994       INTEGER  IBTMYPROC, IBTSIZEOF
02995       EXTERNAL ALLPASS, IBTMYPROC, IBTSIZEOF
02996 *     ..
02997 *     .. External Subroutines ..
02998       EXTERNAL BLACS_GRIDINFO
02999       EXTERNAL DTRSD2D, DGESD2D, DTRRV2D, DGERV2D
03000       EXTERNAL DINITMAT, DCHKMAT, DCHKPAD, DBTCHECKIN
03001 *     ..
03002 *     .. Local Scalars ..
03003       CHARACTER*1 UPLO, DIAG
03004       LOGICAL TESTOK
03005       INTEGER IAM, I, K, IGR, ISH, IMA, ISO, MYROW, MYCOL, IPRE, IPOST
03006       INTEGER M, N, NPROW, NPCOL, RSRC, CSRC, RDEST, CDEST
03007       INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
03008       INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE, DSIZE
03009       DOUBLE PRECISION SCHECKVAL, RCHECKVAL
03010 *     ..
03011 *     .. Executable Statements ..
03012 *
03013       SCHECKVAL = -0.01D0
03014       RCHECKVAL = -0.02D0
03015 *
03016       IAM = IBTMYPROC()
03017       ISIZE = IBTSIZEOF('I')
03018       DSIZE = IBTSIZEOF('D')
03019 *
03020 *     Verify file parameters
03021 *
03022       IF( IAM .EQ. 0 ) THEN
03023          WRITE(OUTNUM, *) '  '
03024          WRITE(OUTNUM, *) '  '
03025          WRITE(OUTNUM, 1000 )
03026          IF( VERB .GT. 0 ) THEN
03027             WRITE(OUTNUM,*) '  '
03028             WRITE(OUTNUM, 2000) 'NSHAPE:', NSHAPE
03029             WRITE(OUTNUM, 3000) ' UPLO :', ( UPLO0(I), I = 1, NSHAPE )
03030             WRITE(OUTNUM, 3000) ' DIAG :', ( DIAG0(I), I = 1, NSHAPE )
03031             WRITE(OUTNUM, 2000) 'NMAT  :', NMAT
03032             WRITE(OUTNUM, 2000) ' M    :', ( M0(I), I = 1, NMAT )
03033             WRITE(OUTNUM, 2000) ' N    :', ( N0(I), I = 1, NMAT )
03034             WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT )
03035             WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT )
03036             WRITE(OUTNUM, 2000) 'NSRC  :', NSRC
03037             WRITE(OUTNUM, 2000) ' RSRC :',( RSRC0(I), I = 1, NSRC )
03038             WRITE(OUTNUM, 2000) ' CSRC :',( CSRC0(I), I = 1, NSRC )
03039             WRITE(OUTNUM, 2000) ' RDEST:',( RDEST0(I), I = 1, NSRC )
03040             WRITE(OUTNUM, 2000) ' CDEST:',( CDEST0(I), I = 1, NSRC )
03041             WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID
03042             WRITE(OUTNUM, 2000) ' P    :', ( P0(I), I = 1, NGRID )
03043             WRITE(OUTNUM, 2000) ' Q    :', ( Q0(I), I = 1, NGRID )
03044             WRITE(OUTNUM, 2000) 'VERB  :', VERB
03045             WRITE(OUTNUM,*) '  '
03046          END IF
03047          IF( VERB .GT. 1 ) THEN
03048             WRITE(OUTNUM,5000)
03049             WRITE(OUTNUM,6000)
03050          END IF
03051       END IF
03052 *
03053 *     Find biggest matrix, so we know where to stick error info
03054 *
03055       I = 0
03056       DO 10 IMA = 1, NMAT
03057          K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + 4 * M0(IMA)
03058          IF( K .GT. I ) I = K
03059    10 CONTINUE
03060       MAXERR = ( DSIZE * (MEMLEN-I) ) / ( DSIZE*2 + ISIZE*6 )
03061       IF( MAXERR .LT. 1 ) THEN
03062          WRITE(OUTNUM,*) 'ERROR: Not enough memory to run SDRV tests.'
03063          CALL BLACS_ABORT(-1, 1)
03064       END IF
03065       ERRDPTR = I + 1
03066       ERRIPTR = ERRDPTR + MAXERR
03067       NERR = 0
03068       TESTNUM = 0
03069       NFAIL = 0
03070       NSKIP = 0
03071 *
03072 *     Loop over grids of matrix
03073 *
03074       DO 110 IGR = 1, NGRID
03075 *
03076          CONTEXT = CONTEXT0(IGR)
03077          CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL )
03078 *
03079          DO 80 ISH = 1, NSHAPE
03080             UPLO = UPLO0(ISH)
03081             DIAG = DIAG0(ISH)
03082 *
03083             DO 70 IMA = 1, NMAT
03084                M = M0(IMA)
03085                N = N0(IMA)
03086                LDASRC = LDAS0(IMA)
03087                LDADST = LDAD0(IMA)
03088 *
03089                DO 60 ISO = 1, NSRC
03090                   TESTNUM = TESTNUM + 1
03091                   RSRC = RSRC0(ISO)
03092                   CSRC = CSRC0(ISO)
03093                   IF( RSRC.GE.P0(IGR) .OR. CSRC.GE.Q0(IGR) ) THEN
03094                      NSKIP = NSKIP + 1
03095                      GOTO 60
03096                   END IF
03097                   RDEST = RDEST0(ISO)
03098                   CDEST = CDEST0(ISO)
03099                   IF( RDEST.GE.P0(IGR) .OR. CDEST.GE.Q0(IGR) ) THEN
03100                      NSKIP = NSKIP + 1
03101                      GOTO 60
03102                   END IF
03103 *
03104                   IF( VERB .GT. 1 ) THEN
03105                      IF( IAM .EQ. 0 ) THEN
03106                         WRITE(OUTNUM, 7000) TESTNUM, 'RUNNING',
03107      $                                      UPLO, DIAG, M, N,
03108      $                                      LDASRC, LDADST, RSRC, CSRC,
03109      $                                      RDEST, CDEST, NPROW, NPCOL
03110                      END IF
03111                   END IF
03112 *
03113                   TESTOK = .TRUE.
03114                   IPRE  = 2 * M
03115                   IPOST = IPRE
03116                   APTR = IPRE + 1
03117 *
03118 *                 source process generates matrix and sends it
03119 *
03120                   IF( MYROW .EQ. RSRC .AND. MYCOL .EQ. CSRC ) THEN
03121                      CALL DINITMAT( UPLO, DIAG, M, N, MEM, LDASRC,
03122      $                              IPRE, IPOST, SCHECKVAL, TESTNUM,
03123      $                              MYROW, MYCOL )
03124 *
03125                      IF( UPLO .EQ. 'U' .OR. UPLO .EQ. 'L' ) THEN
03126                          CALL DTRSD2D( CONTEXT, UPLO, DIAG, M, N,
03127      $                                 MEM(APTR), LDASRC, RDEST, CDEST )
03128                      ELSE
03129                          CALL DGESD2D( CONTEXT, M, N, MEM(APTR),
03130      $                                 LDASRC, RDEST, CDEST )
03131                      END IF
03132                   END IF
03133 *
03134                   IF( MYROW .EQ. RDEST .AND. MYCOL .EQ. CDEST ) THEN
03135 *
03136 *                    Pad entire matrix area
03137 *
03138                      DO 50 K = 1, IPRE+IPOST+LDADST*N
03139                         MEM(K) = RCHECKVAL
03140    50                CONTINUE
03141 *
03142 *                    Receive matrix
03143 *
03144                      IF( UPLO .EQ. 'U' .OR. UPLO .EQ. 'L' ) THEN
03145                         CALL DTRRV2D( CONTEXT, UPLO, DIAG, M, N,
03146      $                                MEM(APTR), LDADST, RSRC, CSRC )
03147                      ELSE
03148                         CALL DGERV2D( CONTEXT, M, N, MEM(APTR),
03149      $                                LDADST, RSRC, CSRC )
03150                      END IF
03151 *
03152 *                    Check for errors in matrix or padding
03153 *
03154                      I = NERR
03155                      CALL DCHKMAT( UPLO, DIAG, M, N, MEM(APTR), LDADST,
03156      $                        RSRC, CSRC, MYROW, MYCOL, TESTNUM, MAXERR,
03157      $                        NERR, MEM(ERRIPTR), MEM(ERRDPTR) )
03158 *
03159                      CALL DCHKPAD( UPLO, DIAG, M, N, MEM, LDADST,
03160      $                        RSRC, CSRC, MYROW, MYCOL, IPRE, IPOST,
03161      $                        RCHECKVAL, TESTNUM, MAXERR, NERR,
03162      $                        MEM(ERRIPTR), MEM(ERRDPTR) )
03163                      TESTOK = I .EQ. NERR
03164                   END IF
03165 *
03166                   IF( VERB .GT. 1 ) THEN
03167                      I = NERR
03168                      CALL DBTCHECKIN( 0, OUTNUM, MAXERR, NERR,
03169      $                                MEM(ERRIPTR), MEM(ERRDPTR),
03170      $                                TFAIL )
03171                      IF( IAM .EQ. 0 ) THEN
03172                         IF( TESTOK .AND. I.EQ.NERR ) THEN
03173                            WRITE(OUTNUM, 7000) TESTNUM, 'PASSED ',
03174      $                           UPLO, DIAG, M, N, LDASRC, LDADST,
03175      $                           RSRC, CSRC, RDEST, CDEST, NPROW, NPCOL
03176                         ELSE
03177                            NFAIL = NFAIL + 1
03178                            WRITE(OUTNUM, 7000) TESTNUM, 'FAILED ',
03179      $                          UPLO, DIAG, M, N, LDASRC, LDADST,
03180      $                          RSRC, CSRC, RDEST, CDEST, NPROW, NPCOL
03181                         ENDIF
03182                      END IF
03183 *
03184 *                    Once we've printed out errors, can re-use buf space
03185 *
03186                      NERR = 0
03187                   END IF
03188    60          CONTINUE
03189    70       CONTINUE
03190    80    CONTINUE
03191   110 CONTINUE
03192 *
03193       IF( VERB .LT. 2 ) THEN
03194          NFAIL = TESTNUM
03195          CALL DBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR),
03196      $                    MEM(ERRDPTR), TFAIL )
03197       END IF
03198       IF( IAM .EQ. 0 ) THEN
03199          IF( VERB .GT. 1 ) WRITE(OUTNUM,*) '   '
03200          IF( NFAIL+NSKIP .EQ. 0 ) THEN
03201             WRITE(OUTNUM, 8000 ) TESTNUM
03202          ELSE
03203             WRITE(OUTNUM, 9000 ) TESTNUM, TESTNUM-NSKIP-NFAIL,
03204      $                           NSKIP, NFAIL
03205          END IF
03206       END IF
03207 *
03208 *     Log whether their were any failures
03209 *
03210       TESTOK = ALLPASS( (NFAIL.EQ.0) )
03211 *
03212  1000 FORMAT('DOUBLE PRECISION SDRV TESTS: BEGIN.' )
03213  2000 FORMAT(1X,A7,3X,10I6)
03214  3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,
03215      $       5X,A1,5X,A1)
03216  5000 FORMAT(' TEST#  STATUS UPLO DIA     M     N  LDAS  LDAD RSRC ',
03217      $       'CSRC RDEST CDEST    P    Q')
03218  6000 FORMAT(' ----- ------- ---- --- ----- ----- ----- ----- ---- ',
03219      $       '---- ----- ----- ---- ----')
03220  7000 FORMAT(I6,1X,A7,4X,A1,3X,A1,4I6,2I5,2I6,2I5)
03221  8000 FORMAT('DOUBLE PRECISION SDRV TESTS: PASSED ALL',
03222      $       I5, ' TESTS.')
03223  9000 FORMAT('DOUBLE PRECISION SDRV TESTS:',I5,' TESTS;',I5,' PASSED,',
03224      $       I5,' SKIPPED,',I5,' FAILED.')
03225 *
03226       RETURN
03227 *
03228 *     End of DSDRVTEST.
03229 *
03230       END
03231 *
03232 *
03233       SUBROUTINE CSDRVTEST( OUTNUM, VERB, NSHAPE, UPLO0, DIAG0,
03234      $                      NMAT, M0, N0, LDAS0, LDAD0, NSRC, RSRC0,
03235      $                      CSRC0, RDEST0, CDEST0, NGRID, CONTEXT0,
03236      $                      P0, Q0, TFAIL, MEM, MEMLEN )
03237 *
03238 *  -- BLACS tester (version 1.0) --
03239 *  University of Tennessee
03240 *  December 15, 1994
03241 *
03242 *
03243 *     .. Scalar Arguments ..
03244       INTEGER OUTNUM, VERB, NSHAPE, NMAT, NSRC, NGRID, MEMLEN
03245 *     ..
03246 *     .. Array Arguments ..
03247       CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
03248       INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
03249       INTEGER RSRC0(NSRC), CSRC0(NSRC), RDEST0(NSRC), CDEST0(NSRC)
03250       INTEGER CONTEXT0(NGRID), P0(NGRID), Q0(NGRID), TFAIL(*)
03251       COMPLEX MEM(MEMLEN)
03252 *     ..
03253 *
03254 *  Purpose
03255 *  =======
03256 *  CTESTSDRV:  Test complex send/recv
03257 *
03258 *  Arguments
03259 *  =========
03260 *  OUTNUM   (input) INTEGER
03261 *           The device number to write output to.
03262 *
03263 *  VERB     (input) INTEGER
03264 *           The level of verbosity (how much printing to do).
03265 *
03266 *  NSHAPE   (input) INTEGER
03267 *           The number of matrix shapes to be tested.
03268 *
03269 *  UPLO0    (input) CHARACTER*1 array of dimension (NSHAPE)
03270 *           Values of UPLO to be tested.
03271 *
03272 *  DIAG0    (input) CHARACTER*1 array of dimension (NSHAPE)
03273 *           Values of DIAG to be tested.
03274 *
03275 *  NMAT     (input) INTEGER
03276 *           The number of matrices to be tested.
03277 *
03278 *  M0       (input) INTEGER array of dimension (NMAT)
03279 *           Values of M to be tested.
03280 *
03281 *  M0       (input) INTEGER array of dimension (NMAT)
03282 *           Values of M to be tested.
03283 *
03284 *  N0       (input) INTEGER array of dimension (NMAT)
03285 *           Values of N to be tested.
03286 *
03287 *  LDAS0    (input) INTEGER array of dimension (NMAT)
03288 *           Values of LDAS (leading dimension of A on source process)
03289 *           to be tested.
03290 *
03291 *  LDAD0    (input) INTEGER array of dimension (NMAT)
03292 *           Values of LDAD (leading dimension of A on destination
03293 *           process) to be tested.
03294 *  NSRC     (input) INTEGER
03295 *           The number of sources to be tested.
03296 *
03297 *  RSRC0    (input) INTEGER array of dimension (NDEST)
03298 *           Values of RSRC (row coordinate of source) to be tested.
03299 *
03300 *  CSRC0    (input) INTEGER array of dimension (NDEST)
03301 *           Values of CSRC (column coordinate of source) to be tested.
03302 *
03303 *  RDEST0   (input) INTEGER array of dimension (NNSRC)
03304 *           Values of RDEST (row coordinate of destination) to be
03305 *           tested.
03306 *
03307 *  CDEST0   (input) INTEGER array of dimension (NNSRC)
03308 *           Values of CDEST (column coordinate of destination) to be
03309 *           tested.
03310 *
03311 *  NGRID    (input) INTEGER
03312 *           The number of process grids to be tested.
03313 *
03314 *  CONTEXT0 (input) INTEGER array of dimension (NGRID)
03315 *           The BLACS context handles corresponding to the grids.
03316 *
03317 *  P0       (input) INTEGER array of dimension (NGRID)
03318 *           Values of P (number of process rows, NPROW).
03319 *
03320 *  Q0       (input) INTEGER array of dimension (NGRID)
03321 *           Values of Q (number of process columns, NPCOL).
03322 *
03323 *  TFAIL    (workspace) INTEGER array of dimension (NTESTS)
03324 *           If VERB < 2, serves to indicate which tests fail.  This
03325 *           requires workspace of NTESTS (number of tests performed).
03326 *
03327 *  MEM      (workspace) COMPLEX array of dimension (MEMLEN)
03328 *           Used for all other workspaces, including the matrix A,
03329 *           and its pre and post padding.
03330 *
03331 *  MEMLEN   (input) INTEGER
03332 *           The length, in elements, of MEM.
03333 *
03334 * =====================================================================
03335 *
03336 *     .. External Functions ..
03337       LOGICAL ALLPASS
03338       INTEGER  IBTMYPROC, IBTSIZEOF
03339       EXTERNAL ALLPASS, IBTMYPROC, IBTSIZEOF
03340 *     ..
03341 *     .. External Subroutines ..
03342       EXTERNAL BLACS_GRIDINFO
03343       EXTERNAL CTRSD2D, CGESD2D, CTRRV2D, CGERV2D
03344       EXTERNAL CINITMAT, CCHKMAT, CCHKPAD, CBTCHECKIN
03345 *     ..
03346 *     .. Local Scalars ..
03347       CHARACTER*1 UPLO, DIAG
03348       LOGICAL TESTOK
03349       INTEGER IAM, I, K, IGR, ISH, IMA, ISO, MYROW, MYCOL, IPRE, IPOST
03350       INTEGER M, N, NPROW, NPCOL, RSRC, CSRC, RDEST, CDEST
03351       INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
03352       INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE, CSIZE
03353       COMPLEX SCHECKVAL, RCHECKVAL
03354 *     ..
03355 *     .. Executable Statements ..
03356 *
03357       SCHECKVAL = CMPLX( -0.01, -0.01 )
03358       RCHECKVAL = CMPLX( -0.02, -0.02 )
03359 *
03360       IAM = IBTMYPROC()
03361       ISIZE = IBTSIZEOF('I')
03362       CSIZE = IBTSIZEOF('C')
03363 *
03364 *     Verify file parameters
03365 *
03366       IF( IAM .EQ. 0 ) THEN
03367          WRITE(OUTNUM, *) '  '
03368          WRITE(OUTNUM, *) '  '
03369          WRITE(OUTNUM, 1000 )
03370          IF( VERB .GT. 0 ) THEN
03371             WRITE(OUTNUM,*) '  '
03372             WRITE(OUTNUM, 2000) 'NSHAPE:', NSHAPE
03373             WRITE(OUTNUM, 3000) ' UPLO :', ( UPLO0(I), I = 1, NSHAPE )
03374             WRITE(OUTNUM, 3000) ' DIAG :', ( DIAG0(I), I = 1, NSHAPE )
03375             WRITE(OUTNUM, 2000) 'NMAT  :', NMAT
03376             WRITE(OUTNUM, 2000) ' M    :', ( M0(I), I = 1, NMAT )
03377             WRITE(OUTNUM, 2000) ' N    :', ( N0(I), I = 1, NMAT )
03378             WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT )
03379             WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT )
03380             WRITE(OUTNUM, 2000) 'NSRC  :', NSRC
03381             WRITE(OUTNUM, 2000) ' RSRC :',( RSRC0(I), I = 1, NSRC )
03382             WRITE(OUTNUM, 2000) ' CSRC :',( CSRC0(I), I = 1, NSRC )
03383             WRITE(OUTNUM, 2000) ' RDEST:',( RDEST0(I), I = 1, NSRC )
03384             WRITE(OUTNUM, 2000) ' CDEST:',( CDEST0(I), I = 1, NSRC )
03385             WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID
03386             WRITE(OUTNUM, 2000) ' P    :', ( P0(I), I = 1, NGRID )
03387             WRITE(OUTNUM, 2000) ' Q    :', ( Q0(I), I = 1, NGRID )
03388             WRITE(OUTNUM, 2000) 'VERB  :', VERB
03389             WRITE(OUTNUM,*) '  '
03390          END IF
03391          IF( VERB .GT. 1 ) THEN
03392             WRITE(OUTNUM,5000)
03393             WRITE(OUTNUM,6000)
03394          END IF
03395       END IF
03396 *
03397 *     Find biggest matrix, so we know where to stick error info
03398 *
03399       I = 0
03400       DO 10 IMA = 1, NMAT
03401          K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + 4 * M0(IMA)
03402          IF( K .GT. I ) I = K
03403    10 CONTINUE
03404       MAXERR = ( CSIZE * (MEMLEN-I) ) / ( CSIZE*2 + ISIZE*6 )
03405       IF( MAXERR .LT. 1 ) THEN
03406          WRITE(OUTNUM,*) 'ERROR: Not enough memory to run SDRV tests.'
03407          CALL BLACS_ABORT(-1, 1)
03408       END IF
03409       ERRDPTR = I + 1
03410       ERRIPTR = ERRDPTR + MAXERR
03411       NERR = 0
03412       TESTNUM = 0
03413       NFAIL = 0
03414       NSKIP = 0
03415 *
03416 *     Loop over grids of matrix
03417 *
03418       DO 110 IGR = 1, NGRID
03419 *
03420          CONTEXT = CONTEXT0(IGR)
03421          CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL )
03422 *
03423          DO 80 ISH = 1, NSHAPE
03424             UPLO = UPLO0(ISH)
03425             DIAG = DIAG0(ISH)
03426 *
03427             DO 70 IMA = 1, NMAT
03428                M = M0(IMA)
03429                N = N0(IMA)
03430                LDASRC = LDAS0(IMA)
03431                LDADST = LDAD0(IMA)
03432 *
03433                DO 60 ISO = 1, NSRC
03434                   TESTNUM = TESTNUM + 1
03435                   RSRC = RSRC0(ISO)
03436                   CSRC = CSRC0(ISO)
03437                   IF( RSRC.GE.P0(IGR) .OR. CSRC.GE.Q0(IGR) ) THEN
03438                      NSKIP = NSKIP + 1
03439                      GOTO 60
03440                   END IF
03441                   RDEST = RDEST0(ISO)
03442                   CDEST = CDEST0(ISO)
03443                   IF( RDEST.GE.P0(IGR) .OR. CDEST.GE.Q0(IGR) ) THEN
03444                      NSKIP = NSKIP + 1
03445                      GOTO 60
03446                   END IF
03447 *
03448                   IF( VERB .GT. 1 ) THEN
03449                      IF( IAM .EQ. 0 ) THEN
03450                         WRITE(OUTNUM, 7000) TESTNUM, 'RUNNING',
03451      $                                      UPLO, DIAG, M, N,
03452      $                                      LDASRC, LDADST, RSRC, CSRC,
03453      $                                      RDEST, CDEST, NPROW, NPCOL
03454                      END IF
03455                   END IF
03456 *
03457                   TESTOK = .TRUE.
03458                   IPRE  = 2 * M
03459                   IPOST = IPRE
03460                   APTR = IPRE + 1
03461 *
03462 *                 source process generates matrix and sends it
03463 *
03464                   IF( MYROW .EQ. RSRC .AND. MYCOL .EQ. CSRC ) THEN
03465                      CALL CINITMAT( UPLO, DIAG, M, N, MEM, LDASRC,
03466      $                              IPRE, IPOST, SCHECKVAL, TESTNUM,
03467      $                              MYROW, MYCOL )
03468 *
03469                      IF( UPLO .EQ. 'U' .OR. UPLO .EQ. 'L' ) THEN
03470                          CALL CTRSD2D( CONTEXT, UPLO, DIAG, M, N,
03471      $                                 MEM(APTR), LDASRC, RDEST, CDEST )
03472                      ELSE
03473                          CALL CGESD2D( CONTEXT, M, N, MEM(APTR),
03474      $                                 LDASRC, RDEST, CDEST )
03475                      END IF
03476                   END IF
03477 *
03478                   IF( MYROW .EQ. RDEST .AND. MYCOL .EQ. CDEST ) THEN
03479 *
03480 *                    Pad entire matrix area
03481 *
03482                      DO 50 K = 1, IPRE+IPOST+LDADST*N
03483                         MEM(K) = RCHECKVAL
03484    50                CONTINUE
03485 *
03486 *                    Receive matrix
03487 *
03488                      IF( UPLO .EQ. 'U' .OR. UPLO .EQ. 'L' ) THEN
03489                         CALL CTRRV2D( CONTEXT, UPLO, DIAG, M, N,
03490      $                                MEM(APTR), LDADST, RSRC, CSRC )
03491                      ELSE
03492                         CALL CGERV2D( CONTEXT, M, N, MEM(APTR),
03493      $                                LDADST, RSRC, CSRC )
03494                      END IF
03495 *
03496 *                    Check for errors in matrix or padding
03497 *
03498                      I = NERR
03499                      CALL CCHKMAT( UPLO, DIAG, M, N, MEM(APTR), LDADST,
03500      $                        RSRC, CSRC, MYROW, MYCOL, TESTNUM, MAXERR,
03501      $                        NERR, MEM(ERRIPTR), MEM(ERRDPTR) )
03502 *
03503                      CALL CCHKPAD( UPLO, DIAG, M, N, MEM, LDADST,
03504      $                        RSRC, CSRC, MYROW, MYCOL, IPRE, IPOST,
03505      $                        RCHECKVAL, TESTNUM, MAXERR, NERR,
03506      $                        MEM(ERRIPTR), MEM(ERRDPTR) )
03507                      TESTOK = I .EQ. NERR
03508                   END IF
03509 *
03510                   IF( VERB .GT. 1 ) THEN
03511                      I = NERR
03512                      CALL CBTCHECKIN( 0, OUTNUM, MAXERR, NERR,
03513      $                                MEM(ERRIPTR), MEM(ERRDPTR),
03514      $                                TFAIL )
03515                      IF( IAM .EQ. 0 ) THEN
03516                         IF( TESTOK .AND. I.EQ.NERR ) THEN
03517                            WRITE(OUTNUM, 7000) TESTNUM, 'PASSED ',
03518      $                           UPLO, DIAG, M, N, LDASRC, LDADST,
03519      $                           RSRC, CSRC, RDEST, CDEST, NPROW, NPCOL
03520                         ELSE
03521                            NFAIL = NFAIL + 1
03522                            WRITE(OUTNUM, 7000) TESTNUM, 'FAILED ',
03523      $                          UPLO, DIAG, M, N, LDASRC, LDADST,
03524      $                          RSRC, CSRC, RDEST, CDEST, NPROW, NPCOL
03525                         ENDIF
03526                      END IF
03527 *
03528 *                    Once we've printed out errors, can re-use buf space
03529 *
03530                      NERR = 0
03531                   END IF
03532    60          CONTINUE
03533    70       CONTINUE
03534    80    CONTINUE
03535   110 CONTINUE
03536 *
03537       IF( VERB .LT. 2 ) THEN
03538          NFAIL = TESTNUM
03539          CALL CBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR),
03540      $                    MEM(ERRDPTR), TFAIL )
03541       END IF
03542       IF( IAM .EQ. 0 ) THEN
03543          IF( VERB .GT. 1 ) WRITE(OUTNUM,*) '   '
03544          IF( NFAIL+NSKIP .EQ. 0 ) THEN
03545             WRITE(OUTNUM, 8000 ) TESTNUM
03546          ELSE
03547             WRITE(OUTNUM, 9000 ) TESTNUM, TESTNUM-NSKIP-NFAIL,
03548      $                           NSKIP, NFAIL
03549          END IF
03550       END IF
03551 *
03552 *     Log whether their were any failures
03553 *
03554       TESTOK = ALLPASS( (NFAIL.EQ.0) )
03555 *
03556  1000 FORMAT('COMPLEX SDRV TESTS: BEGIN.' )
03557  2000 FORMAT(1X,A7,3X,10I6)
03558  3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,
03559      $       5X,A1,5X,A1)
03560  5000 FORMAT(' TEST#  STATUS UPLO DIA     M     N  LDAS  LDAD RSRC ',
03561      $       'CSRC RDEST CDEST    P    Q')
03562  6000 FORMAT(' ----- ------- ---- --- ----- ----- ----- ----- ---- ',
03563      $       '---- ----- ----- ---- ----')
03564  7000 FORMAT(I6,1X,A7,4X,A1,3X,A1,4I6,2I5,2I6,2I5)
03565  8000 FORMAT('COMPLEX SDRV TESTS: PASSED ALL',
03566      $       I5, ' TESTS.')
03567  9000 FORMAT('COMPLEX SDRV TESTS:',I5,' TESTS;',I5,' PASSED,',
03568      $       I5,' SKIPPED,',I5,' FAILED.')
03569 *
03570       RETURN
03571 *
03572 *     End of CSDRVTEST.
03573 *
03574       END
03575 *
03576 *
03577       SUBROUTINE ZSDRVTEST( OUTNUM, VERB, NSHAPE, UPLO0, DIAG0,
03578      $                      NMAT, M0, N0, LDAS0, LDAD0, NSRC, RSRC0,
03579      $                      CSRC0, RDEST0, CDEST0, NGRID, CONTEXT0,
03580      $                      P0, Q0, TFAIL, MEM, MEMLEN )
03581 *
03582 *  -- BLACS tester (version 1.0) --
03583 *  University of Tennessee
03584 *  December 15, 1994
03585 *
03586 *
03587 *     .. Scalar Arguments ..
03588       INTEGER OUTNUM, VERB, NSHAPE, NMAT, NSRC, NGRID, MEMLEN
03589 *     ..
03590 *     .. Array Arguments ..
03591       CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
03592       INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
03593       INTEGER RSRC0(NSRC), CSRC0(NSRC), RDEST0(NSRC), CDEST0(NSRC)
03594       INTEGER CONTEXT0(NGRID), P0(NGRID), Q0(NGRID), TFAIL(*)
03595       DOUBLE COMPLEX MEM(MEMLEN)
03596 *     ..
03597 *
03598 *  Purpose
03599 *  =======
03600 *  ZTESTSDRV:  Test double complex send/recv
03601 *
03602 *  Arguments
03603 *  =========
03604 *  OUTNUM   (input) INTEGER
03605 *           The device number to write output to.
03606 *
03607 *  VERB     (input) INTEGER
03608 *           The level of verbosity (how much printing to do).
03609 *
03610 *  NSHAPE   (input) INTEGER
03611 *           The number of matrix shapes to be tested.
03612 *
03613 *  UPLO0    (input) CHARACTER*1 array of dimension (NSHAPE)
03614 *           Values of UPLO to be tested.
03615 *
03616 *  DIAG0    (input) CHARACTER*1 array of dimension (NSHAPE)
03617 *           Values of DIAG to be tested.
03618 *
03619 *  NMAT     (input) INTEGER
03620 *           The number of matrices to be tested.
03621 *
03622 *  M0       (input) INTEGER array of dimension (NMAT)
03623 *           Values of M to be tested.
03624 *
03625 *  M0       (input) INTEGER array of dimension (NMAT)
03626 *           Values of M to be tested.
03627 *
03628 *  N0       (input) INTEGER array of dimension (NMAT)
03629 *           Values of N to be tested.
03630 *
03631 *  LDAS0    (input) INTEGER array of dimension (NMAT)
03632 *           Values of LDAS (leading dimension of A on source process)
03633 *           to be tested.
03634 *
03635 *  LDAD0    (input) INTEGER array of dimension (NMAT)
03636 *           Values of LDAD (leading dimension of A on destination
03637 *           process) to be tested.
03638 *  NSRC     (input) INTEGER
03639 *           The number of sources to be tested.
03640 *
03641 *  RSRC0    (input) INTEGER array of dimension (NDEST)
03642 *           Values of RSRC (row coordinate of source) to be tested.
03643 *
03644 *  CSRC0    (input) INTEGER array of dimension (NDEST)
03645 *           Values of CSRC (column coordinate of source) to be tested.
03646 *
03647 *  RDEST0   (input) INTEGER array of dimension (NNSRC)
03648 *           Values of RDEST (row coordinate of destination) to be
03649 *           tested.
03650 *
03651 *  CDEST0   (input) INTEGER array of dimension (NNSRC)
03652 *           Values of CDEST (column coordinate of destination) to be
03653 *           tested.
03654 *
03655 *  NGRID    (input) INTEGER
03656 *           The number of process grids to be tested.
03657 *
03658 *  CONTEXT0 (input) INTEGER array of dimension (NGRID)
03659 *           The BLACS context handles corresponding to the grids.
03660 *
03661 *  P0       (input) INTEGER array of dimension (NGRID)
03662 *           Values of P (number of process rows, NPROW).
03663 *
03664 *  Q0       (input) INTEGER array of dimension (NGRID)
03665 *           Values of Q (number of process columns, NPCOL).
03666 *
03667 *  TFAIL    (workspace) INTEGER array of dimension (NTESTS)
03668 *           If VERB < 2, serves to indicate which tests fail.  This
03669 *           requires workspace of NTESTS (number of tests performed).
03670 *
03671 *  MEM      (workspace) DOUBLE COMPLEX array of dimension (MEMLEN)
03672 *           Used for all other workspaces, including the matrix A,
03673 *           and its pre and post padding.
03674 *
03675 *  MEMLEN   (input) INTEGER
03676 *           The length, in elements, of MEM.
03677 *
03678 * =====================================================================
03679 *
03680 *     .. External Functions ..
03681       LOGICAL ALLPASS
03682       INTEGER  IBTMYPROC, IBTSIZEOF
03683       EXTERNAL ALLPASS, IBTMYPROC, IBTSIZEOF
03684 *     ..
03685 *     .. External Subroutines ..
03686       EXTERNAL BLACS_GRIDINFO
03687       EXTERNAL ZTRSD2D, ZGESD2D, ZTRRV2D, ZGERV2D
03688       EXTERNAL ZINITMAT, ZCHKMAT, ZCHKPAD, ZBTCHECKIN
03689 *     ..
03690 *     .. Local Scalars ..
03691       CHARACTER*1 UPLO, DIAG
03692       LOGICAL TESTOK
03693       INTEGER IAM, I, K, IGR, ISH, IMA, ISO, MYROW, MYCOL, IPRE, IPOST
03694       INTEGER M, N, NPROW, NPCOL, RSRC, CSRC, RDEST, CDEST
03695       INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
03696       INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE, ZSIZE
03697       DOUBLE COMPLEX SCHECKVAL, RCHECKVAL
03698 *     ..
03699 *     .. Executable Statements ..
03700 *
03701       SCHECKVAL = DCMPLX( -0.01D0, -0.01D0 )
03702       RCHECKVAL = DCMPLX( -0.02D0, -0.02D0 )
03703 *
03704       IAM = IBTMYPROC()
03705       ISIZE = IBTSIZEOF('I')
03706       ZSIZE = IBTSIZEOF('Z')
03707 *
03708 *     Verify file parameters
03709 *
03710       IF( IAM .EQ. 0 ) THEN
03711          WRITE(OUTNUM, *) '  '
03712          WRITE(OUTNUM, *) '  '
03713          WRITE(OUTNUM, 1000 )
03714          IF( VERB .GT. 0 ) THEN
03715             WRITE(OUTNUM,*) '  '
03716             WRITE(OUTNUM, 2000) 'NSHAPE:', NSHAPE
03717             WRITE(OUTNUM, 3000) ' UPLO :', ( UPLO0(I), I = 1, NSHAPE )
03718             WRITE(OUTNUM, 3000) ' DIAG :', ( DIAG0(I), I = 1, NSHAPE )
03719             WRITE(OUTNUM, 2000) 'NMAT  :', NMAT
03720             WRITE(OUTNUM, 2000) ' M    :', ( M0(I), I = 1, NMAT )
03721             WRITE(OUTNUM, 2000) ' N    :', ( N0(I), I = 1, NMAT )
03722             WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT )
03723             WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT )
03724             WRITE(OUTNUM, 2000) 'NSRC  :', NSRC
03725             WRITE(OUTNUM, 2000) ' RSRC :',( RSRC0(I), I = 1, NSRC )
03726             WRITE(OUTNUM, 2000) ' CSRC :',( CSRC0(I), I = 1, NSRC )
03727             WRITE(OUTNUM, 2000) ' RDEST:',( RDEST0(I), I = 1, NSRC )
03728             WRITE(OUTNUM, 2000) ' CDEST:',( CDEST0(I), I = 1, NSRC )
03729             WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID
03730             WRITE(OUTNUM, 2000) ' P    :', ( P0(I), I = 1, NGRID )
03731             WRITE(OUTNUM, 2000) ' Q    :', ( Q0(I), I = 1, NGRID )
03732             WRITE(OUTNUM, 2000) 'VERB  :', VERB
03733             WRITE(OUTNUM,*) '  '
03734          END IF
03735          IF( VERB .GT. 1 ) THEN
03736             WRITE(OUTNUM,5000)
03737             WRITE(OUTNUM,6000)
03738          END IF
03739       END IF
03740 *
03741 *     Find biggest matrix, so we know where to stick error info
03742 *
03743       I = 0
03744       DO 10 IMA = 1, NMAT
03745          K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + 4 * M0(IMA)
03746          IF( K .GT. I ) I = K
03747    10 CONTINUE
03748       MAXERR = ( ZSIZE * (MEMLEN-I) ) / ( ZSIZE*2 + ISIZE*6 )
03749       IF( MAXERR .LT. 1 ) THEN
03750          WRITE(OUTNUM,*) 'ERROR: Not enough memory to run SDRV tests.'
03751          CALL BLACS_ABORT(-1, 1)
03752       END IF
03753       ERRDPTR = I + 1
03754       ERRIPTR = ERRDPTR + MAXERR
03755       NERR = 0
03756       TESTNUM = 0
03757       NFAIL = 0
03758       NSKIP = 0
03759 *
03760 *     Loop over grids of matrix
03761 *
03762       DO 110 IGR = 1, NGRID
03763 *
03764          CONTEXT = CONTEXT0(IGR)
03765          CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL )
03766 *
03767          DO 80 ISH = 1, NSHAPE
03768             UPLO = UPLO0(ISH)
03769             DIAG = DIAG0(ISH)
03770 *
03771             DO 70 IMA = 1, NMAT
03772                M = M0(IMA)
03773                N = N0(IMA)
03774                LDASRC = LDAS0(IMA)
03775                LDADST = LDAD0(IMA)
03776 *
03777                DO 60 ISO = 1, NSRC
03778                   TESTNUM = TESTNUM + 1
03779                   RSRC = RSRC0(ISO)
03780                   CSRC = CSRC0(ISO)
03781                   IF( RSRC.GE.P0(IGR) .OR. CSRC.GE.Q0(IGR) ) THEN
03782                      NSKIP = NSKIP + 1
03783                      GOTO 60
03784                   END IF
03785                   RDEST = RDEST0(ISO)
03786                   CDEST = CDEST0(ISO)
03787                   IF( RDEST.GE.P0(IGR) .OR. CDEST.GE.Q0(IGR) ) THEN
03788                      NSKIP = NSKIP + 1
03789                      GOTO 60
03790                   END IF
03791 *
03792                   IF( VERB .GT. 1 ) THEN
03793                      IF( IAM .EQ. 0 ) THEN
03794                         WRITE(OUTNUM, 7000) TESTNUM, 'RUNNING',
03795      $                                      UPLO, DIAG, M, N,
03796      $                                      LDASRC, LDADST, RSRC, CSRC,
03797      $                                      RDEST, CDEST, NPROW, NPCOL
03798                      END IF
03799                   END IF
03800 *
03801                   TESTOK = .TRUE.
03802                   IPRE  = 2 * M
03803                   IPOST = IPRE
03804                   APTR = IPRE + 1
03805 *
03806 *                 source process generates matrix and sends it
03807 *
03808                   IF( MYROW .EQ. RSRC .AND. MYCOL .EQ. CSRC ) THEN
03809                      CALL ZINITMAT( UPLO, DIAG, M, N, MEM, LDASRC,
03810      $                              IPRE, IPOST, SCHECKVAL, TESTNUM,
03811      $                              MYROW, MYCOL )
03812 *
03813                      IF( UPLO .EQ. 'U' .OR. UPLO .EQ. 'L' ) THEN
03814                          CALL ZTRSD2D( CONTEXT, UPLO, DIAG, M, N,
03815      $                                 MEM(APTR), LDASRC, RDEST, CDEST )
03816                      ELSE
03817                          CALL ZGESD2D( CONTEXT, M, N, MEM(APTR),
03818      $                                 LDASRC, RDEST, CDEST )
03819                      END IF
03820                   END IF
03821 *
03822                   IF( MYROW .EQ. RDEST .AND. MYCOL .EQ. CDEST ) THEN
03823 *
03824 *                    Pad entire matrix area
03825 *
03826                      DO 50 K = 1, IPRE+IPOST+LDADST*N
03827                         MEM(K) = RCHECKVAL
03828    50                CONTINUE
03829 *
03830 *                    Receive matrix
03831 *
03832                      IF( UPLO .EQ. 'U' .OR. UPLO .EQ. 'L' ) THEN
03833                         CALL ZTRRV2D( CONTEXT, UPLO, DIAG, M, N,
03834      $                                MEM(APTR), LDADST, RSRC, CSRC )
03835                      ELSE
03836                         CALL ZGERV2D( CONTEXT, M, N, MEM(APTR),
03837      $                                LDADST, RSRC, CSRC )
03838                      END IF
03839 *
03840 *                    Check for errors in matrix or padding
03841 *
03842                      I = NERR
03843                      CALL ZCHKMAT( UPLO, DIAG, M, N, MEM(APTR), LDADST,
03844      $                        RSRC, CSRC, MYROW, MYCOL, TESTNUM, MAXERR,
03845      $                        NERR, MEM(ERRIPTR), MEM(ERRDPTR) )
03846 *
03847                      CALL ZCHKPAD( UPLO, DIAG, M, N, MEM, LDADST,
03848      $                        RSRC, CSRC, MYROW, MYCOL, IPRE, IPOST,
03849      $                        RCHECKVAL, TESTNUM, MAXERR, NERR,
03850      $                        MEM(ERRIPTR), MEM(ERRDPTR) )
03851                      TESTOK = I .EQ. NERR
03852                   END IF
03853 *
03854                   IF( VERB .GT. 1 ) THEN
03855                      I = NERR
03856                      CALL ZBTCHECKIN( 0, OUTNUM, MAXERR, NERR,
03857      $                                MEM(ERRIPTR), MEM(ERRDPTR),
03858      $                                TFAIL )
03859                      IF( IAM .EQ. 0 ) THEN
03860                         IF( TESTOK .AND. I.EQ.NERR ) THEN
03861                            WRITE(OUTNUM, 7000) TESTNUM, 'PASSED ',
03862      $                           UPLO, DIAG, M, N, LDASRC, LDADST,
03863      $                           RSRC, CSRC, RDEST, CDEST, NPROW, NPCOL
03864                         ELSE
03865                            NFAIL = NFAIL + 1
03866                            WRITE(OUTNUM, 7000) TESTNUM, 'FAILED ',
03867      $                          UPLO, DIAG, M, N, LDASRC, LDADST,
03868      $                          RSRC, CSRC, RDEST, CDEST, NPROW, NPCOL
03869                         ENDIF
03870                      END IF
03871 *
03872 *                    Once we've printed out errors, can re-use buf space
03873 *
03874                      NERR = 0
03875                   END IF
03876    60          CONTINUE
03877    70       CONTINUE
03878    80    CONTINUE
03879   110 CONTINUE
03880 *
03881       IF( VERB .LT. 2 ) THEN
03882          NFAIL = TESTNUM
03883          CALL ZBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR),
03884      $                    MEM(ERRDPTR), TFAIL )
03885       END IF
03886       IF( IAM .EQ. 0 ) THEN
03887          IF( VERB .GT. 1 ) WRITE(OUTNUM,*) '   '
03888          IF( NFAIL+NSKIP .EQ. 0 ) THEN
03889             WRITE(OUTNUM, 8000 ) TESTNUM
03890          ELSE
03891             WRITE(OUTNUM, 9000 ) TESTNUM, TESTNUM-NSKIP-NFAIL,
03892      $                           NSKIP, NFAIL
03893          END IF
03894       END IF
03895 *
03896 *     Log whether their were any failures
03897 *
03898       TESTOK = ALLPASS( (NFAIL.EQ.0) )
03899 *
03900  1000 FORMAT('DOUBLE COMPLEX SDRV TESTS: BEGIN.' )
03901  2000 FORMAT(1X,A7,3X,10I6)
03902  3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,
03903      $       5X,A1,5X,A1)
03904  5000 FORMAT(' TEST#  STATUS UPLO DIA     M     N  LDAS  LDAD RSRC ',
03905      $       'CSRC RDEST CDEST    P    Q')
03906  6000 FORMAT(' ----- ------- ---- --- ----- ----- ----- ----- ---- ',
03907      $       '---- ----- ----- ---- ----')
03908  7000 FORMAT(I6,1X,A7,4X,A1,3X,A1,4I6,2I5,2I6,2I5)
03909  8000 FORMAT('DOUBLE COMPLEX SDRV TESTS: PASSED ALL',
03910      $       I5, ' TESTS.')
03911  9000 FORMAT('DOUBLE COMPLEX SDRV TESTS:',I5,' TESTS;',I5,' PASSED,',
03912      $       I5,' SKIPPED,',I5,' FAILED.')
03913 *
03914       RETURN
03915 *
03916 *     End of ZSDRVTEST.
03917 *
03918       END
03919 *
03920 *
03921       SUBROUTINE IBSBRTEST( OUTNUM, VERB, NSCOPE, SCOPE0, NTOP, TOP0,
03922      $                      NSHAPE, UPLO0, DIAG0, NMAT, M0, N0, LDAS0,
03923      $                      LDAD0, NSRC, RSRC0, CSRC0, NGRID, CONTEXT0,
03924      $                      P0, Q0, TFAIL, MEM, MEMLEN )
03925 *
03926 *  -- BLACS tester (version 1.0) --
03927 *  University of Tennessee
03928 *  December 15, 1994
03929 *
03930 *
03931 *     .. Scalar Arguments ..
03932       INTEGER OUTNUM, VERB, NSCOPE, NTOP, NSHAPE, NMAT, NSRC, NGRID
03933       INTEGER MEMLEN
03934 *     ..
03935 *     .. Array Arguments ..
03936       CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
03937       CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
03938       INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
03939       INTEGER RSRC0(NSRC), CSRC0(NSRC), CONTEXT0(NGRID)
03940       INTEGER P0(NGRID), Q0(NGRID), TFAIL(*)
03941       INTEGER MEM(MEMLEN)
03942 *     ..
03943 *
03944 *  Purpose
03945 *  =======
03946 *  ITESTBSBR:  Test integer broadcast
03947 *
03948 *  Arguments
03949 *  =========
03950 *  OUTNUM   (input) INTEGER
03951 *           The device number to write output to.
03952 *
03953 *  VERB     (input) INTEGER
03954 *           The level of verbosity (how much printing to do).
03955 *
03956 *  NSCOPE   (input) INTEGER
03957 *           The number of scopes to be tested.
03958 *
03959 *  SCOPE0   (input) CHARACTER*1 array of dimension (NSCOPE)
03960 *           Values of the scopes to be tested.
03961 *
03962 *  NTOP     (input) INTEGER
03963 *           The number of topologies to be tested.
03964 *
03965 *  TOP0     (input) CHARACTER*1 array of dimension (NTOP)
03966 *           Values of the topologies to be tested.
03967 *
03968 *  NSHAPE   (input) INTEGER
03969 *           The number of matrix shapes to be tested.
03970 *
03971 *  UPLO0    (input) CHARACTER*1 array of dimension (NSHAPE)
03972 *           Values of UPLO to be tested.
03973 *
03974 *  DIAG0    (input) CHARACTER*1 array of dimension (NSHAPE)
03975 *           Values of DIAG to be tested.
03976 *
03977 *  NMAT     (input) INTEGER
03978 *           The number of matrices to be tested.
03979 *
03980 *  M0       (input) INTEGER array of dimension (NMAT)
03981 *           Values of M to be tested.
03982 *
03983 *  M0       (input) INTEGER array of dimension (NMAT)
03984 *           Values of M to be tested.
03985 *
03986 *  N0       (input) INTEGER array of dimension (NMAT)
03987 *           Values of N to be tested.
03988 *
03989 *  LDAS0    (input) INTEGER array of dimension (NMAT)
03990 *           Values of LDAS (leading dimension of A on source process)
03991 *           to be tested.
03992 *
03993 *  LDAD0    (input) INTEGER array of dimension (NMAT)
03994 *           Values of LDAD (leading dimension of A on destination
03995 *           process) to be tested.
03996 *  NSRC     (input) INTEGER
03997 *           The number of sources to be tested.
03998 *
03999 *  RSRC0    (input) INTEGER array of dimension (NDEST)
04000 *           Values of RSRC (row coordinate of source) to be tested.
04001 *
04002 *  CSRC0    (input) INTEGER array of dimension (NDEST)
04003 *           Values of CSRC (column coordinate of source) to be tested.
04004 *
04005 *  NGRID    (input) INTEGER
04006 *           The number of process grids to be tested.
04007 *
04008 *  CONTEXT0 (input) INTEGER array of dimension (NGRID)
04009 *           The BLACS context handles corresponding to the grids.
04010 *
04011 *  P0       (input) INTEGER array of dimension (NGRID)
04012 *           Values of P (number of process rows, NPROW).
04013 *
04014 *  Q0       (input) INTEGER array of dimension (NGRID)
04015 *           Values of Q (number of process columns, NPCOL).
04016 *
04017 *  TFAIL    (workspace) INTEGER array of dimension (NTESTS)
04018 *           If VERB < 2, serves to indicate which tests fail.  This
04019 *           requires workspace of NTESTS (number of tests performed).
04020 *
04021 *  MEM      (workspace) INTEGER array of dimension (MEMLEN)
04022 *           Used for all other workspaces, including the matrix A,
04023 *           and its pre and post padding.
04024 *
04025 *  MEMLEN   (input) INTEGER
04026 *           The length, in elements, of MEM.
04027 *
04028 * =====================================================================
04029 *
04030 *     .. External Functions ..
04031       LOGICAL  ALLPASS, LSAME
04032       INTEGER  IBTMYPROC, IBTSIZEOF
04033       EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTSIZEOF
04034 *     ..
04035 *     .. External Subroutines ..
04036       EXTERNAL BLACS_GRIDINFO
04037       EXTERNAL ITRBS2D, IGEBS2D, ITRBR2D, IGEBR2D
04038       EXTERNAL IINITMAT, ICHKMAT, ICHKPAD, IBTCHECKIN
04039 *     ..
04040 *     .. Local Scalars ..
04041       CHARACTER*1 SCOPE, TOP, UPLO, DIAG
04042       LOGICAL TESTOK, INGRID
04043       INTEGER IAM, I, K, J, IGR, ISH, IMA, ISO, ISC, ITO
04044       INTEGER M, N, NPROW, NPCOL, MYROW, MYCOL, RSRC, CSRC
04045       INTEGER ISTART, ISTOP, IPRE, IPOST, SETWHAT
04046       INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
04047       INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE
04048       INTEGER SCHECKVAL, RCHECKVAL
04049 *     ..
04050 *     .. Executable Statements ..
04051 *
04052       SCHECKVAL = -1
04053       RCHECKVAL = -2
04054 *
04055       IAM = IBTMYPROC()
04056       ISIZE = IBTSIZEOF('I')
04057       ISIZE = IBTSIZEOF('I')
04058 *
04059 *     Verify file parameters
04060 *
04061       IF( IAM .EQ. 0 ) THEN
04062          WRITE(OUTNUM, *) '  '
04063          WRITE(OUTNUM, *) '  '
04064          WRITE(OUTNUM, 1000 )
04065          IF( VERB .GT. 0 ) THEN
04066             WRITE(OUTNUM,*) '  '
04067             WRITE(OUTNUM, 2000) 'NSCOPE:', NSCOPE
04068             WRITE(OUTNUM, 3000) ' SCOPE:', ( SCOPE0(I), I = 1, NSCOPE )
04069             WRITE(OUTNUM, 2000) 'NTOP  :', NTOP
04070             WRITE(OUTNUM, 3000) ' TOP  :', ( TOP0(I), I = 1, NTOP )
04071             WRITE(OUTNUM, 2000) 'NSHAPE:', NSHAPE
04072             WRITE(OUTNUM, 3000) ' UPLO :', ( UPLO0(I), I = 1, NSHAPE )
04073             WRITE(OUTNUM, 3000) ' DIAG :', ( DIAG0(I), I = 1, NSHAPE )
04074             WRITE(OUTNUM, 2000) 'NMAT  :', NMAT
04075             WRITE(OUTNUM, 2000) ' M    :', ( M0(I), I = 1, NMAT )
04076             WRITE(OUTNUM, 2000) ' N    :', ( N0(I), I = 1, NMAT )
04077             WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT )
04078             WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT )
04079             WRITE(OUTNUM, 2000) 'NSRC  :', NSRC
04080             WRITE(OUTNUM, 2000) ' RSRC :',( RSRC0(I), I = 1, NSRC )
04081             WRITE(OUTNUM, 2000) ' CSRC :',( CSRC0(I), I = 1, NSRC )
04082             WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID
04083             WRITE(OUTNUM, 2000) ' P    :', ( P0(I), I = 1, NGRID )
04084             WRITE(OUTNUM, 2000) ' Q    :', ( Q0(I), I = 1, NGRID )
04085             WRITE(OUTNUM, 2000) 'VERB  :', VERB
04086             WRITE(OUTNUM,*) '  '
04087          END IF
04088          IF( VERB .GT. 1 ) THEN
04089             WRITE(OUTNUM,5000)
04090             WRITE(OUTNUM,6000)
04091          END IF
04092       END IF
04093 *
04094 *     Find biggest matrix, so we know where to stick error info
04095 *
04096       I = 0
04097       DO 10 IMA = 1, NMAT
04098          K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + 4 * M0(IMA)
04099          IF( K .GT. I ) I = K
04100    10 CONTINUE
04101       MAXERR = ( ISIZE * (MEMLEN-I) ) / ( ISIZE*2 + ISIZE*6 )
04102       IF( MAXERR .LT. 1 ) THEN
04103          WRITE(OUTNUM,*) 'ERROR: Not enough memory to run BSBR tests.'
04104          CALL BLACS_ABORT(-1, 1)
04105       END IF
04106       ERRDPTR = I + 1
04107       ERRIPTR = ERRDPTR + MAXERR
04108       NERR = 0
04109       TESTNUM = 0
04110       NFAIL = 0
04111       NSKIP = 0
04112 *
04113 *     Loop over grids of matrix
04114 *
04115       DO 110 IGR = 1, NGRID
04116 *
04117          CONTEXT = CONTEXT0(IGR)
04118          CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL )
04119 *
04120          INGRID = ( NPROW .GT. 0 )
04121 *
04122          DO 100 ISC = 1, NSCOPE
04123             SCOPE = SCOPE0(ISC)
04124             DO 90 ITO = 1, NTOP
04125                TOP = TOP0(ITO)
04126 *
04127 *              If testing multipath ('M') or general tree ('T'),
04128 *              need to loop over calls to BLACS_SET
04129 *
04130                IF( LSAME(TOP, 'M') ) THEN
04131                   SETWHAT = 11
04132                   IF( SCOPE .EQ. 'R' ) THEN
04133                      ISTART = -(NPCOL - 1)
04134                      ISTOP = -ISTART
04135                   ELSE IF (SCOPE .EQ. 'C') THEN
04136                      ISTART = -(NPROW - 1)
04137                      ISTOP = -ISTART
04138                   ELSE
04139                      ISTART = -(NPROW*NPCOL - 1)
04140                      ISTOP = -ISTART
04141                   ENDIF
04142                ELSE IF( LSAME(TOP, 'T') ) THEN
04143                   SETWHAT = 12
04144                   ISTART = 1
04145                   IF( SCOPE .EQ. 'R' ) THEN
04146                      ISTOP = NPCOL - 1
04147                   ELSE IF (SCOPE .EQ. 'C') THEN
04148                      ISTOP = NPROW - 1
04149                   ELSE
04150                      ISTOP = NPROW*NPCOL - 1
04151                   ENDIF
04152                ELSE
04153                   SETWHAT = 0
04154                   ISTART = 1
04155                   ISTOP = 1
04156                ENDIF
04157                DO 80 ISH = 1, NSHAPE
04158                   UPLO = UPLO0(ISH)
04159                   DIAG = DIAG0(ISH)
04160 *
04161                   DO 70 IMA = 1, NMAT
04162                      M = M0(IMA)
04163                      N = N0(IMA)
04164                      LDASRC = LDAS0(IMA)
04165                      LDADST = LDAD0(IMA)
04166 *
04167                      DO 60 ISO = 1, NSRC
04168                         TESTNUM = TESTNUM + 1
04169                         RSRC = RSRC0(ISO)
04170                         CSRC = CSRC0(ISO)
04171                         IF( RSRC.GE.P0(IGR) .OR. CSRC.GE.Q0(IGR) ) THEN
04172                            NSKIP = NSKIP + 1
04173                            GOTO 60
04174                         END IF
04175                         IF( VERB .GT. 1 ) THEN
04176                            IF( IAM .EQ. 0 ) THEN
04177                               WRITE(OUTNUM, 7000)
04178      $                        TESTNUM, 'RUNNING',SCOPE, TOP, UPLO, DIAG,
04179      $                        M, N, LDASRC, LDADST, RSRC, CSRC,
04180      $                        NPROW, NPCOL
04181                            END IF
04182                         END IF
04183 *
04184                         TESTOK = .TRUE.
04185                         IPRE  = 2 * M
04186                         IPOST = IPRE
04187                         APTR = IPRE + 1
04188 *
04189 *                       If I am in scope
04190 *
04191                         IF( (MYROW.EQ.RSRC .AND. SCOPE.EQ.'R') .OR.
04192      $                       (MYCOL.EQ.CSRC .AND. SCOPE.EQ.'C') .OR.
04193      $                       (SCOPE .EQ. 'A') ) THEN
04194 *
04195 *                          source process generates matrix and sends it
04196 *
04197                            IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC ) THEN
04198                               CALL IINITMAT(UPLO, DIAG, M, N, MEM,
04199      $                                      LDASRC, IPRE, IPOST,
04200      $                                      SCHECKVAL, TESTNUM,
04201      $                                      MYROW, MYCOL )
04202 *
04203                               DO 20 J = ISTART, ISTOP
04204                                  IF( J.EQ.0 ) GOTO 20
04205                                  IF( SETWHAT.NE.0 )
04206      $                              CALL BLACS_SET(CONTEXT, SETWHAT, J)
04207                                  IF( UPLO.EQ.'U' .OR. UPLO.EQ.'L' ) THEN
04208                                      CALL ITRBS2D(CONTEXT, SCOPE, TOP,
04209      $                                            UPLO, DIAG, M, N,
04210      $                                            MEM(APTR), LDASRC )
04211                                  ELSE
04212                                      CALL IGEBS2D(CONTEXT, SCOPE, TOP,
04213      $                                            M, N, MEM(APTR),
04214      $                                            LDASRC )
04215                                  END IF
04216    20                         CONTINUE
04217 *
04218 *                          Destination processes
04219 *
04220                            ELSE IF( INGRID ) THEN
04221                               DO 40 J = ISTART, ISTOP
04222                                  IF( J.EQ.0 ) GOTO 40
04223                                  IF( SETWHAT.NE.0 )
04224      $                              CALL BLACS_SET(CONTEXT, SETWHAT, J)
04225 *
04226 *                                Pad entire matrix area
04227 *
04228                                  DO 30 K = 1, IPRE+IPOST+LDADST*N
04229                                     MEM(K) = RCHECKVAL
04230    30                            CONTINUE
04231 *
04232 *                                Receive matrix
04233 *
04234                                  IF( UPLO.EQ.'U' .OR. UPLO.EQ.'L' ) THEN
04235                                     CALL ITRBR2D(CONTEXT, SCOPE, TOP,
04236      $                                           UPLO, DIAG, M, N,
04237      $                                           MEM(APTR), LDADST,
04238      $                                           RSRC, CSRC)
04239                                  ELSE
04240                                     CALL IGEBR2D(CONTEXT, SCOPE, TOP,
04241      $                                           M, N, MEM(APTR),
04242      $                                           LDADST, RSRC, CSRC)
04243                                  END IF
04244 *
04245 *                                Check for errors in matrix or padding
04246 *
04247                                  I = NERR
04248                                  CALL ICHKMAT(UPLO, DIAG, M, N,
04249      $                                   MEM(APTR), LDADST, RSRC, CSRC,
04250      $                                   MYROW, MYCOL, TESTNUM, MAXERR,
04251      $                                   NERR, MEM(ERRIPTR),
04252      $                                   MEM(ERRDPTR))
04253 *
04254                                  CALL ICHKPAD(UPLO, DIAG, M, N, MEM,
04255      $                                   LDADST, RSRC, CSRC, MYROW,
04256      $                                   MYCOL, IPRE, IPOST, RCHECKVAL,
04257      $                                   TESTNUM, MAXERR, NERR,
04258      $                                   MEM(ERRIPTR), MEM(ERRDPTR))
04259    40                         CONTINUE
04260                               TESTOK = ( I .EQ. NERR )
04261                            END IF
04262                         END IF
04263 *
04264                         IF( VERB .GT. 1 ) THEN
04265                            I = NERR
04266                            CALL IBTCHECKIN(0, OUTNUM, MAXERR, NERR,
04267      $                                     MEM(ERRIPTR), MEM(ERRDPTR),
04268      $                                     TFAIL)
04269                            IF( IAM .EQ. 0 ) THEN
04270                               TESTOK = ( TESTOK .AND. (I.EQ.NERR) )
04271                               IF( TESTOK ) THEN
04272                                  WRITE(OUTNUM,7000)TESTNUM,'PASSED ',
04273      $                                 SCOPE, TOP, UPLO, DIAG, M, N,
04274      $                                 LDASRC, LDADST, RSRC, CSRC,
04275      $                                 NPROW, NPCOL
04276                               ELSE
04277                                  NFAIL = NFAIL + 1
04278                                  WRITE(OUTNUM,7000)TESTNUM,'FAILED ',
04279      $                                SCOPE, TOP, UPLO, DIAG, M, N,
04280      $                                LDASRC, LDADST, RSRC, CSRC,
04281      $                                NPROW, NPCOL
04282                               END IF
04283                            END IF
04284 *
04285 *                          Once we've printed out errors, can re-use buf space
04286 *
04287                            NERR = 0
04288                         END IF
04289    60                CONTINUE
04290    70             CONTINUE
04291    80          CONTINUE
04292    90       CONTINUE
04293   100    CONTINUE
04294   110 CONTINUE
04295 *
04296       IF( VERB .LT. 2 ) THEN
04297          NFAIL = TESTNUM
04298          CALL IBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR),
04299      $                    MEM(ERRDPTR), TFAIL )
04300       END IF
04301       IF( IAM .EQ. 0 ) THEN
04302          IF( VERB .GT. 1 ) WRITE(OUTNUM,*) '   '
04303          IF( NFAIL+NSKIP .EQ. 0 ) THEN
04304             WRITE(OUTNUM, 8000 ) TESTNUM
04305          ELSE
04306             WRITE(OUTNUM, 9000 ) TESTNUM, TESTNUM-NSKIP-NFAIL,
04307      $                           NSKIP, NFAIL
04308          END IF
04309       END IF
04310 *
04311 *     Log whether their were any failures
04312 *
04313       TESTOK = ALLPASS( (NFAIL.EQ.0) )
04314 *
04315  1000 FORMAT('INTEGER BSBR TESTS: BEGIN.' )
04316  2000 FORMAT(1X,A7,3X,10I6)
04317  3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,
04318      $       5X,A1,5X,A1)
04319  5000 FORMAT(' TEST#  STATUS SCOPE TOP UPLO DIAG     M     N  LDAS ',
04320      $       ' LDAD RSRC CSRC    P    Q')
04321  6000 FORMAT(' ----- ------- ----- --- ---- ---- ----- ----- ----- ',
04322      $       '----- ---- ---- ---- ----')
04323  7000 FORMAT(I6,1X,A7,5X,A1,3X,A1,2(4X,A1), 4I6, 4I5)
04324  8000 FORMAT('INTEGER BSBR TESTS: PASSED ALL',
04325      $       I5, ' TESTS.')
04326  9000 FORMAT('INTEGER BSBR TESTS:',I5,' TESTS;',I5,' PASSED,',
04327      $       I5,' SKIPPED,',I5,' FAILED.')
04328 *
04329       RETURN
04330 *
04331 *     End of IBSBRTEST.
04332 *
04333       END
04334 *
04335 *
04336       SUBROUTINE SBSBRTEST( OUTNUM, VERB, NSCOPE, SCOPE0, NTOP, TOP0,
04337      $                      NSHAPE, UPLO0, DIAG0, NMAT, M0, N0, LDAS0,
04338      $                      LDAD0, NSRC, RSRC0, CSRC0, NGRID, CONTEXT0,
04339      $                      P0, Q0, TFAIL, MEM, MEMLEN )
04340 *
04341 *  -- BLACS tester (version 1.0) --
04342 *  University of Tennessee
04343 *  December 15, 1994
04344 *
04345 *
04346 *     .. Scalar Arguments ..
04347       INTEGER OUTNUM, VERB, NSCOPE, NTOP, NSHAPE, NMAT, NSRC, NGRID
04348       INTEGER MEMLEN
04349 *     ..
04350 *     .. Array Arguments ..
04351       CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
04352       CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
04353       INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
04354       INTEGER RSRC0(NSRC), CSRC0(NSRC), CONTEXT0(NGRID)
04355       INTEGER P0(NGRID), Q0(NGRID), TFAIL(*)
04356       REAL MEM(MEMLEN)
04357 *     ..
04358 *
04359 *  Purpose
04360 *  =======
04361 *  STESTBSBR:  Test real broadcast
04362 *
04363 *  Arguments
04364 *  =========
04365 *  OUTNUM   (input) INTEGER
04366 *           The device number to write output to.
04367 *
04368 *  VERB     (input) INTEGER
04369 *           The level of verbosity (how much printing to do).
04370 *
04371 *  NSCOPE   (input) INTEGER
04372 *           The number of scopes to be tested.
04373 *
04374 *  SCOPE0   (input) CHARACTER*1 array of dimension (NSCOPE)
04375 *           Values of the scopes to be tested.
04376 *
04377 *  NTOP     (input) INTEGER
04378 *           The number of topologies to be tested.
04379 *
04380 *  TOP0     (input) CHARACTER*1 array of dimension (NTOP)
04381 *           Values of the topologies to be tested.
04382 *
04383 *  NSHAPE   (input) INTEGER
04384 *           The number of matrix shapes to be tested.
04385 *
04386 *  UPLO0    (input) CHARACTER*1 array of dimension (NSHAPE)
04387 *           Values of UPLO to be tested.
04388 *
04389 *  DIAG0    (input) CHARACTER*1 array of dimension (NSHAPE)
04390 *           Values of DIAG to be tested.
04391 *
04392 *  NMAT     (input) INTEGER
04393 *           The number of matrices to be tested.
04394 *
04395 *  M0       (input) INTEGER array of dimension (NMAT)
04396 *           Values of M to be tested.
04397 *
04398 *  M0       (input) INTEGER array of dimension (NMAT)
04399 *           Values of M to be tested.
04400 *
04401 *  N0       (input) INTEGER array of dimension (NMAT)
04402 *           Values of N to be tested.
04403 *
04404 *  LDAS0    (input) INTEGER array of dimension (NMAT)
04405 *           Values of LDAS (leading dimension of A on source process)
04406 *           to be tested.
04407 *
04408 *  LDAD0    (input) INTEGER array of dimension (NMAT)
04409 *           Values of LDAD (leading dimension of A on destination
04410 *           process) to be tested.
04411 *  NSRC     (input) INTEGER
04412 *           The number of sources to be tested.
04413 *
04414 *  RSRC0    (input) INTEGER array of dimension (NDEST)
04415 *           Values of RSRC (row coordinate of source) to be tested.
04416 *
04417 *  CSRC0    (input) INTEGER array of dimension (NDEST)
04418 *           Values of CSRC (column coordinate of source) to be tested.
04419 *
04420 *  NGRID    (input) INTEGER
04421 *           The number of process grids to be tested.
04422 *
04423 *  CONTEXT0 (input) INTEGER array of dimension (NGRID)
04424 *           The BLACS context handles corresponding to the grids.
04425 *
04426 *  P0       (input) INTEGER array of dimension (NGRID)
04427 *           Values of P (number of process rows, NPROW).
04428 *
04429 *  Q0       (input) INTEGER array of dimension (NGRID)
04430 *           Values of Q (number of process columns, NPCOL).
04431 *
04432 *  TFAIL    (workspace) INTEGER array of dimension (NTESTS)
04433 *           If VERB < 2, serves to indicate which tests fail.  This
04434 *           requires workspace of NTESTS (number of tests performed).
04435 *
04436 *  MEM      (workspace) REAL array of dimension (MEMLEN)
04437 *           Used for all other workspaces, including the matrix A,
04438 *           and its pre and post padding.
04439 *
04440 *  MEMLEN   (input) INTEGER
04441 *           The length, in elements, of MEM.
04442 *
04443 * =====================================================================
04444 *
04445 *     .. External Functions ..
04446       LOGICAL  ALLPASS, LSAME
04447       INTEGER  IBTMYPROC, IBTSIZEOF
04448       EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTSIZEOF
04449 *     ..
04450 *     .. External Subroutines ..
04451       EXTERNAL BLACS_GRIDINFO
04452       EXTERNAL STRBS2D, SGEBS2D, STRBR2D, SGEBR2D
04453       EXTERNAL SINITMAT, SCHKMAT, SCHKPAD, SBTCHECKIN
04454 *     ..
04455 *     .. Local Scalars ..
04456       CHARACTER*1 SCOPE, TOP, UPLO, DIAG
04457       LOGICAL TESTOK, INGRID
04458       INTEGER IAM, I, K, J, IGR, ISH, IMA, ISO, ISC, ITO
04459       INTEGER M, N, NPROW, NPCOL, MYROW, MYCOL, RSRC, CSRC
04460       INTEGER ISTART, ISTOP, IPRE, IPOST, SETWHAT
04461       INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
04462       INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE, SSIZE
04463       REAL SCHECKVAL, RCHECKVAL
04464 *     ..
04465 *     .. Executable Statements ..
04466 *
04467       SCHECKVAL = -0.01E0
04468       RCHECKVAL = -0.02E0
04469 *
04470       IAM = IBTMYPROC()
04471       ISIZE = IBTSIZEOF('I')
04472       SSIZE = IBTSIZEOF('S')
04473 *
04474 *     Verify file parameters
04475 *
04476       IF( IAM .EQ. 0 ) THEN
04477          WRITE(OUTNUM, *) '  '
04478          WRITE(OUTNUM, *) '  '
04479          WRITE(OUTNUM, 1000 )
04480          IF( VERB .GT. 0 ) THEN
04481             WRITE(OUTNUM,*) '  '
04482             WRITE(OUTNUM, 2000) 'NSCOPE:', NSCOPE
04483             WRITE(OUTNUM, 3000) ' SCOPE:', ( SCOPE0(I), I = 1, NSCOPE )
04484             WRITE(OUTNUM, 2000) 'NTOP  :', NTOP
04485             WRITE(OUTNUM, 3000) ' TOP  :', ( TOP0(I), I = 1, NTOP )
04486             WRITE(OUTNUM, 2000) 'NSHAPE:', NSHAPE
04487             WRITE(OUTNUM, 3000) ' UPLO :', ( UPLO0(I), I = 1, NSHAPE )
04488             WRITE(OUTNUM, 3000) ' DIAG :', ( DIAG0(I), I = 1, NSHAPE )
04489             WRITE(OUTNUM, 2000) 'NMAT  :', NMAT
04490             WRITE(OUTNUM, 2000) ' M    :', ( M0(I), I = 1, NMAT )
04491             WRITE(OUTNUM, 2000) ' N    :', ( N0(I), I = 1, NMAT )
04492             WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT )
04493             WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT )
04494             WRITE(OUTNUM, 2000) 'NSRC  :', NSRC
04495             WRITE(OUTNUM, 2000) ' RSRC :',( RSRC0(I), I = 1, NSRC )
04496             WRITE(OUTNUM, 2000) ' CSRC :',( CSRC0(I), I = 1, NSRC )
04497             WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID
04498             WRITE(OUTNUM, 2000) ' P    :', ( P0(I), I = 1, NGRID )
04499             WRITE(OUTNUM, 2000) ' Q    :', ( Q0(I), I = 1, NGRID )
04500             WRITE(OUTNUM, 2000) 'VERB  :', VERB
04501             WRITE(OUTNUM,*) '  '
04502          END IF
04503          IF( VERB .GT. 1 ) THEN
04504             WRITE(OUTNUM,5000)
04505             WRITE(OUTNUM,6000)
04506          END IF
04507       END IF
04508 *
04509 *     Find biggest matrix, so we know where to stick error info
04510 *
04511       I = 0
04512       DO 10 IMA = 1, NMAT
04513          K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + 4 * M0(IMA)
04514          IF( K .GT. I ) I = K
04515    10 CONTINUE
04516       MAXERR = ( SSIZE * (MEMLEN-I) ) / ( SSIZE*2 + ISIZE*6 )
04517       IF( MAXERR .LT. 1 ) THEN
04518          WRITE(OUTNUM,*) 'ERROR: Not enough memory to run BSBR tests.'
04519          CALL BLACS_ABORT(-1, 1)
04520       END IF
04521       ERRDPTR = I + 1
04522       ERRIPTR = ERRDPTR + MAXERR
04523       NERR = 0
04524       TESTNUM = 0
04525       NFAIL = 0
04526       NSKIP = 0
04527 *
04528 *     Loop over grids of matrix
04529 *
04530       DO 110 IGR = 1, NGRID
04531 *
04532          CONTEXT = CONTEXT0(IGR)
04533          CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL )
04534 *
04535          INGRID = ( NPROW .GT. 0 )
04536 *
04537          DO 100 ISC = 1, NSCOPE
04538             SCOPE = SCOPE0(ISC)
04539             DO 90 ITO = 1, NTOP
04540                TOP = TOP0(ITO)
04541 *
04542 *              If testing multipath ('M') or general tree ('T'),
04543 *              need to loop over calls to BLACS_SET
04544 *
04545                IF( LSAME(TOP, 'M') ) THEN
04546                   SETWHAT = 11
04547                   IF( SCOPE .EQ. 'R' ) THEN
04548                      ISTART = -(NPCOL - 1)
04549                      ISTOP = -ISTART
04550                   ELSE IF (SCOPE .EQ. 'C') THEN
04551                      ISTART = -(NPROW - 1)
04552                      ISTOP = -ISTART
04553                   ELSE
04554                      ISTART = -(NPROW*NPCOL - 1)
04555                      ISTOP = -ISTART
04556                   ENDIF
04557                ELSE IF( LSAME(TOP, 'T') ) THEN
04558                   SETWHAT = 12
04559                   ISTART = 1
04560                   IF( SCOPE .EQ. 'R' ) THEN
04561                      ISTOP = NPCOL - 1
04562                   ELSE IF (SCOPE .EQ. 'C') THEN
04563                      ISTOP = NPROW - 1
04564                   ELSE
04565                      ISTOP = NPROW*NPCOL - 1
04566                   ENDIF
04567                ELSE
04568                   SETWHAT = 0
04569                   ISTART = 1
04570                   ISTOP = 1
04571                ENDIF
04572                DO 80 ISH = 1, NSHAPE
04573                   UPLO = UPLO0(ISH)
04574                   DIAG = DIAG0(ISH)
04575 *
04576                   DO 70 IMA = 1, NMAT
04577                      M = M0(IMA)
04578                      N = N0(IMA)
04579                      LDASRC = LDAS0(IMA)
04580                      LDADST = LDAD0(IMA)
04581 *
04582                      DO 60 ISO = 1, NSRC
04583                         TESTNUM = TESTNUM + 1
04584                         RSRC = RSRC0(ISO)
04585                         CSRC = CSRC0(ISO)
04586                         IF( RSRC.GE.P0(IGR) .OR. CSRC.GE.Q0(IGR) ) THEN
04587                            NSKIP = NSKIP + 1
04588                            GOTO 60
04589                         END IF
04590                         IF( VERB .GT. 1 ) THEN
04591                            IF( IAM .EQ. 0 ) THEN
04592                               WRITE(OUTNUM, 7000)
04593      $                        TESTNUM, 'RUNNING',SCOPE, TOP, UPLO, DIAG,
04594      $                        M, N, LDASRC, LDADST, RSRC, CSRC,
04595      $                        NPROW, NPCOL
04596                            END IF
04597                         END IF
04598 *
04599                         TESTOK = .TRUE.
04600                         IPRE  = 2 * M
04601                         IPOST = IPRE
04602                         APTR = IPRE + 1
04603 *
04604 *                       If I am in scope
04605 *
04606                         IF( (MYROW.EQ.RSRC .AND. SCOPE.EQ.'R') .OR.
04607      $                       (MYCOL.EQ.CSRC .AND. SCOPE.EQ.'C') .OR.
04608      $                       (SCOPE .EQ. 'A') ) THEN
04609 *
04610 *                          source process generates matrix and sends it
04611 *
04612                            IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC ) THEN
04613                               CALL SINITMAT(UPLO, DIAG, M, N, MEM,
04614      $                                      LDASRC, IPRE, IPOST,
04615      $                                      SCHECKVAL, TESTNUM,
04616      $                                      MYROW, MYCOL )
04617 *
04618                               DO 20 J = ISTART, ISTOP
04619                                  IF( J.EQ.0 ) GOTO 20
04620                                  IF( SETWHAT.NE.0 )
04621      $                              CALL BLACS_SET(CONTEXT, SETWHAT, J)
04622                                  IF( UPLO.EQ.'U' .OR. UPLO.EQ.'L' ) THEN
04623                                      CALL STRBS2D(CONTEXT, SCOPE, TOP,
04624      $                                            UPLO, DIAG, M, N,
04625      $                                            MEM(APTR), LDASRC )
04626                                  ELSE
04627                                      CALL SGEBS2D(CONTEXT, SCOPE, TOP,
04628      $                                            M, N, MEM(APTR),
04629      $                                            LDASRC )
04630                                  END IF
04631    20                         CONTINUE
04632 *
04633 *                          Destination processes
04634 *
04635                            ELSE IF( INGRID ) THEN
04636                               DO 40 J = ISTART, ISTOP
04637                                  IF( J.EQ.0 ) GOTO 40
04638                                  IF( SETWHAT.NE.0 )
04639      $                              CALL BLACS_SET(CONTEXT, SETWHAT, J)
04640 *
04641 *                                Pad entire matrix area
04642 *
04643                                  DO 30 K = 1, IPRE+IPOST+LDADST*N
04644                                     MEM(K) = RCHECKVAL
04645    30                            CONTINUE
04646 *
04647 *                                Receive matrix
04648 *
04649                                  IF( UPLO.EQ.'U' .OR. UPLO.EQ.'L' ) THEN
04650                                     CALL STRBR2D(CONTEXT, SCOPE, TOP,
04651      $                                           UPLO, DIAG, M, N,
04652      $                                           MEM(APTR), LDADST,
04653      $                                           RSRC, CSRC)
04654                                  ELSE
04655                                     CALL SGEBR2D(CONTEXT, SCOPE, TOP,
04656      $                                           M, N, MEM(APTR),
04657      $                                           LDADST, RSRC, CSRC)
04658                                  END IF
04659 *
04660 *                                Check for errors in matrix or padding
04661 *
04662                                  I = NERR
04663                                  CALL SCHKMAT(UPLO, DIAG, M, N,
04664      $                                   MEM(APTR), LDADST, RSRC, CSRC,
04665      $                                   MYROW, MYCOL, TESTNUM, MAXERR,
04666      $                                   NERR, MEM(ERRIPTR),
04667      $                                   MEM(ERRDPTR))
04668 *
04669                                  CALL SCHKPAD(UPLO, DIAG, M, N, MEM,
04670      $                                   LDADST, RSRC, CSRC, MYROW,
04671      $                                   MYCOL, IPRE, IPOST, RCHECKVAL,
04672      $                                   TESTNUM, MAXERR, NERR,
04673      $                                   MEM(ERRIPTR), MEM(ERRDPTR))
04674    40                         CONTINUE
04675                               TESTOK = ( I .EQ. NERR )
04676                            END IF
04677                         END IF
04678 *
04679                         IF( VERB .GT. 1 ) THEN
04680                            I = NERR
04681                            CALL SBTCHECKIN(0, OUTNUM, MAXERR, NERR,
04682      $                                     MEM(ERRIPTR), MEM(ERRDPTR),
04683      $                                     TFAIL)
04684                            IF( IAM .EQ. 0 ) THEN
04685                               TESTOK = ( TESTOK .AND. (I.EQ.NERR) )
04686                               IF( TESTOK ) THEN
04687                                  WRITE(OUTNUM,7000)TESTNUM,'PASSED ',
04688      $                                 SCOPE, TOP, UPLO, DIAG, M, N,
04689      $                                 LDASRC, LDADST, RSRC, CSRC,
04690      $                                 NPROW, NPCOL
04691                               ELSE
04692                                  NFAIL = NFAIL + 1
04693                                  WRITE(OUTNUM,7000)TESTNUM,'FAILED ',
04694      $                                SCOPE, TOP, UPLO, DIAG, M, N,
04695      $                                LDASRC, LDADST, RSRC, CSRC,
04696      $                                NPROW, NPCOL
04697                               END IF
04698                            END IF
04699 *
04700 *                          Once we've printed out errors, can re-use buf space
04701 *
04702                            NERR = 0
04703                         END IF
04704    60                CONTINUE
04705    70             CONTINUE
04706    80          CONTINUE
04707    90       CONTINUE
04708   100    CONTINUE
04709   110 CONTINUE
04710 *
04711       IF( VERB .LT. 2 ) THEN
04712          NFAIL = TESTNUM
04713          CALL SBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR),
04714      $                    MEM(ERRDPTR), TFAIL )
04715       END IF
04716       IF( IAM .EQ. 0 ) THEN
04717          IF( VERB .GT. 1 ) WRITE(OUTNUM,*) '   '
04718          IF( NFAIL+NSKIP .EQ. 0 ) THEN
04719             WRITE(OUTNUM, 8000 ) TESTNUM
04720          ELSE
04721             WRITE(OUTNUM, 9000 ) TESTNUM, TESTNUM-NSKIP-NFAIL,
04722      $                           NSKIP, NFAIL
04723          END IF
04724       END IF
04725 *
04726 *     Log whether their were any failures
04727 *
04728       TESTOK = ALLPASS( (NFAIL.EQ.0) )
04729 *
04730  1000 FORMAT('REAL BSBR TESTS: BEGIN.' )
04731  2000 FORMAT(1X,A7,3X,10I6)
04732  3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,
04733      $       5X,A1,5X,A1)
04734  5000 FORMAT(' TEST#  STATUS SCOPE TOP UPLO DIAG     M     N  LDAS ',
04735      $       ' LDAD RSRC CSRC    P    Q')
04736  6000 FORMAT(' ----- ------- ----- --- ---- ---- ----- ----- ----- ',
04737      $       '----- ---- ---- ---- ----')
04738  7000 FORMAT(I6,1X,A7,5X,A1,3X,A1,2(4X,A1), 4I6, 4I5)
04739  8000 FORMAT('REAL BSBR TESTS: PASSED ALL',
04740      $       I5, ' TESTS.')
04741  9000 FORMAT('REAL BSBR TESTS:',I5,' TESTS;',I5,' PASSED,',
04742      $       I5,' SKIPPED,',I5,' FAILED.')
04743 *
04744       RETURN
04745 *
04746 *     End of SBSBRTEST.
04747 *
04748       END
04749 *
04750 *
04751       SUBROUTINE DBSBRTEST( OUTNUM, VERB, NSCOPE, SCOPE0, NTOP, TOP0,
04752      $                      NSHAPE, UPLO0, DIAG0, NMAT, M0, N0, LDAS0,
04753      $                      LDAD0, NSRC, RSRC0, CSRC0, NGRID, CONTEXT0,
04754      $                      P0, Q0, TFAIL, MEM, MEMLEN )
04755 *
04756 *  -- BLACS tester (version 1.0) --
04757 *  University of Tennessee
04758 *  December 15, 1994
04759 *
04760 *
04761 *     .. Scalar Arguments ..
04762       INTEGER OUTNUM, VERB, NSCOPE, NTOP, NSHAPE, NMAT, NSRC, NGRID
04763       INTEGER MEMLEN
04764 *     ..
04765 *     .. Array Arguments ..
04766       CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
04767       CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
04768       INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
04769       INTEGER RSRC0(NSRC), CSRC0(NSRC), CONTEXT0(NGRID)
04770       INTEGER P0(NGRID), Q0(NGRID), TFAIL(*)
04771       DOUBLE PRECISION MEM(MEMLEN)
04772 *     ..
04773 *
04774 *  Purpose
04775 *  =======
04776 *  DTESTBSBR:  Test double precision broadcast
04777 *
04778 *  Arguments
04779 *  =========
04780 *  OUTNUM   (input) INTEGER
04781 *           The device number to write output to.
04782 *
04783 *  VERB     (input) INTEGER
04784 *           The level of verbosity (how much printing to do).
04785 *
04786 *  NSCOPE   (input) INTEGER
04787 *           The number of scopes to be tested.
04788 *
04789 *  SCOPE0   (input) CHARACTER*1 array of dimension (NSCOPE)
04790 *           Values of the scopes to be tested.
04791 *
04792 *  NTOP     (input) INTEGER
04793 *           The number of topologies to be tested.
04794 *
04795 *  TOP0     (input) CHARACTER*1 array of dimension (NTOP)
04796 *           Values of the topologies to be tested.
04797 *
04798 *  NSHAPE   (input) INTEGER
04799 *           The number of matrix shapes to be tested.
04800 *
04801 *  UPLO0    (input) CHARACTER*1 array of dimension (NSHAPE)
04802 *           Values of UPLO to be tested.
04803 *
04804 *  DIAG0    (input) CHARACTER*1 array of dimension (NSHAPE)
04805 *           Values of DIAG to be tested.
04806 *
04807 *  NMAT     (input) INTEGER
04808 *           The number of matrices to be tested.
04809 *
04810 *  M0       (input) INTEGER array of dimension (NMAT)
04811 *           Values of M to be tested.
04812 *
04813 *  M0       (input) INTEGER array of dimension (NMAT)
04814 *           Values of M to be tested.
04815 *
04816 *  N0       (input) INTEGER array of dimension (NMAT)
04817 *           Values of N to be tested.
04818 *
04819 *  LDAS0    (input) INTEGER array of dimension (NMAT)
04820 *           Values of LDAS (leading dimension of A on source process)
04821 *           to be tested.
04822 *
04823 *  LDAD0    (input) INTEGER array of dimension (NMAT)
04824 *           Values of LDAD (leading dimension of A on destination
04825 *           process) to be tested.
04826 *  NSRC     (input) INTEGER
04827 *           The number of sources to be tested.
04828 *
04829 *  RSRC0    (input) INTEGER array of dimension (NDEST)
04830 *           Values of RSRC (row coordinate of source) to be tested.
04831 *
04832 *  CSRC0    (input) INTEGER array of dimension (NDEST)
04833 *           Values of CSRC (column coordinate of source) to be tested.
04834 *
04835 *  NGRID    (input) INTEGER
04836 *           The number of process grids to be tested.
04837 *
04838 *  CONTEXT0 (input) INTEGER array of dimension (NGRID)
04839 *           The BLACS context handles corresponding to the grids.
04840 *
04841 *  P0       (input) INTEGER array of dimension (NGRID)
04842 *           Values of P (number of process rows, NPROW).
04843 *
04844 *  Q0       (input) INTEGER array of dimension (NGRID)
04845 *           Values of Q (number of process columns, NPCOL).
04846 *
04847 *  TFAIL    (workspace) INTEGER array of dimension (NTESTS)
04848 *           If VERB < 2, serves to indicate which tests fail.  This
04849 *           requires workspace of NTESTS (number of tests performed).
04850 *
04851 *  MEM      (workspace) DOUBLE PRECISION array of dimension (MEMLEN)
04852 *           Used for all other workspaces, including the matrix A,
04853 *           and its pre and post padding.
04854 *
04855 *  MEMLEN   (input) INTEGER
04856 *           The length, in elements, of MEM.
04857 *
04858 * =====================================================================
04859 *
04860 *     .. External Functions ..
04861       LOGICAL  ALLPASS, LSAME
04862       INTEGER  IBTMYPROC, IBTSIZEOF
04863       EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTSIZEOF
04864 *     ..
04865 *     .. External Subroutines ..
04866       EXTERNAL BLACS_GRIDINFO
04867       EXTERNAL DTRBS2D, DGEBS2D, DTRBR2D, DGEBR2D
04868       EXTERNAL DINITMAT, DCHKMAT, DCHKPAD, DBTCHECKIN
04869 *     ..
04870 *     .. Local Scalars ..
04871       CHARACTER*1 SCOPE, TOP, UPLO, DIAG
04872       LOGICAL TESTOK, INGRID
04873       INTEGER IAM, I, K, J, IGR, ISH, IMA, ISO, ISC, ITO
04874       INTEGER M, N, NPROW, NPCOL, MYROW, MYCOL, RSRC, CSRC
04875       INTEGER ISTART, ISTOP, IPRE, IPOST, SETWHAT
04876       INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
04877       INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE, DSIZE
04878       DOUBLE PRECISION SCHECKVAL, RCHECKVAL
04879 *     ..
04880 *     .. Executable Statements ..
04881 *
04882       SCHECKVAL = -0.01D0
04883       RCHECKVAL = -0.02D0
04884 *
04885       IAM = IBTMYPROC()
04886       ISIZE = IBTSIZEOF('I')
04887       DSIZE = IBTSIZEOF('D')
04888 *
04889 *     Verify file parameters
04890 *
04891       IF( IAM .EQ. 0 ) THEN
04892          WRITE(OUTNUM, *) '  '
04893          WRITE(OUTNUM, *) '  '
04894          WRITE(OUTNUM, 1000 )
04895          IF( VERB .GT. 0 ) THEN
04896             WRITE(OUTNUM,*) '  '
04897             WRITE(OUTNUM, 2000) 'NSCOPE:', NSCOPE
04898             WRITE(OUTNUM, 3000) ' SCOPE:', ( SCOPE0(I), I = 1, NSCOPE )
04899             WRITE(OUTNUM, 2000) 'NTOP  :', NTOP
04900             WRITE(OUTNUM, 3000) ' TOP  :', ( TOP0(I), I = 1, NTOP )
04901             WRITE(OUTNUM, 2000) 'NSHAPE:', NSHAPE
04902             WRITE(OUTNUM, 3000) ' UPLO :', ( UPLO0(I), I = 1, NSHAPE )
04903             WRITE(OUTNUM, 3000) ' DIAG :', ( DIAG0(I), I = 1, NSHAPE )
04904             WRITE(OUTNUM, 2000) 'NMAT  :', NMAT
04905             WRITE(OUTNUM, 2000) ' M    :', ( M0(I), I = 1, NMAT )
04906             WRITE(OUTNUM, 2000) ' N    :', ( N0(I), I = 1, NMAT )
04907             WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT )
04908             WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT )
04909             WRITE(OUTNUM, 2000) 'NSRC  :', NSRC
04910             WRITE(OUTNUM, 2000) ' RSRC :',( RSRC0(I), I = 1, NSRC )
04911             WRITE(OUTNUM, 2000) ' CSRC :',( CSRC0(I), I = 1, NSRC )
04912             WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID
04913             WRITE(OUTNUM, 2000) ' P    :', ( P0(I), I = 1, NGRID )
04914             WRITE(OUTNUM, 2000) ' Q    :', ( Q0(I), I = 1, NGRID )
04915             WRITE(OUTNUM, 2000) 'VERB  :', VERB
04916             WRITE(OUTNUM,*) '  '
04917          END IF
04918          IF( VERB .GT. 1 ) THEN
04919             WRITE(OUTNUM,5000)
04920             WRITE(OUTNUM,6000)
04921          END IF
04922       END IF
04923 *
04924 *     Find biggest matrix, so we know where to stick error info
04925 *
04926       I = 0
04927       DO 10 IMA = 1, NMAT
04928          K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + 4 * M0(IMA)
04929          IF( K .GT. I ) I = K
04930    10 CONTINUE
04931       MAXERR = ( DSIZE * (MEMLEN-I) ) / ( DSIZE*2 + ISIZE*6 )
04932       IF( MAXERR .LT. 1 ) THEN
04933          WRITE(OUTNUM,*) 'ERROR: Not enough memory to run BSBR tests.'
04934          CALL BLACS_ABORT(-1, 1)
04935       END IF
04936       ERRDPTR = I + 1
04937       ERRIPTR = ERRDPTR + MAXERR
04938       NERR = 0
04939       TESTNUM = 0
04940       NFAIL = 0
04941       NSKIP = 0
04942 *
04943 *     Loop over grids of matrix
04944 *
04945       DO 110 IGR = 1, NGRID
04946 *
04947          CONTEXT = CONTEXT0(IGR)
04948          CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL )
04949 *
04950          INGRID = ( NPROW .GT. 0 )
04951 *
04952          DO 100 ISC = 1, NSCOPE
04953             SCOPE = SCOPE0(ISC)
04954             DO 90 ITO = 1, NTOP
04955                TOP = TOP0(ITO)
04956 *
04957 *              If testing multipath ('M') or general tree ('T'),
04958 *              need to loop over calls to BLACS_SET
04959 *
04960                IF( LSAME(TOP, 'M') ) THEN
04961                   SETWHAT = 11
04962                   IF( SCOPE .EQ. 'R' ) THEN
04963                      ISTART = -(NPCOL - 1)
04964                      ISTOP = -ISTART
04965                   ELSE IF (SCOPE .EQ. 'C') THEN
04966                      ISTART = -(NPROW - 1)
04967                      ISTOP = -ISTART
04968                   ELSE
04969                      ISTART = -(NPROW*NPCOL - 1)
04970                      ISTOP = -ISTART
04971                   ENDIF
04972                ELSE IF( LSAME(TOP, 'T') ) THEN
04973                   SETWHAT = 12
04974                   ISTART = 1
04975                   IF( SCOPE .EQ. 'R' ) THEN
04976                      ISTOP = NPCOL - 1
04977                   ELSE IF (SCOPE .EQ. 'C') THEN
04978                      ISTOP = NPROW - 1
04979                   ELSE
04980                      ISTOP = NPROW*NPCOL - 1
04981                   ENDIF
04982                ELSE
04983                   SETWHAT = 0
04984                   ISTART = 1
04985                   ISTOP = 1
04986                ENDIF
04987                DO 80 ISH = 1, NSHAPE
04988                   UPLO = UPLO0(ISH)
04989                   DIAG = DIAG0(ISH)
04990 *
04991                   DO 70 IMA = 1, NMAT
04992                      M = M0(IMA)
04993                      N = N0(IMA)
04994                      LDASRC = LDAS0(IMA)
04995                      LDADST = LDAD0(IMA)
04996 *
04997                      DO 60 ISO = 1, NSRC
04998                         TESTNUM = TESTNUM + 1
04999                         RSRC = RSRC0(ISO)
05000                         CSRC = CSRC0(ISO)
05001                         IF( RSRC.GE.P0(IGR) .OR. CSRC.GE.Q0(IGR) ) THEN
05002                            NSKIP = NSKIP + 1
05003                            GOTO 60
05004                         END IF
05005                         IF( VERB .GT. 1 ) THEN
05006                            IF( IAM .EQ. 0 ) THEN
05007                               WRITE(OUTNUM, 7000)
05008      $                        TESTNUM, 'RUNNING',SCOPE, TOP, UPLO, DIAG,
05009      $                        M, N, LDASRC, LDADST, RSRC, CSRC,
05010      $                        NPROW, NPCOL
05011                            END IF
05012                         END IF
05013 *
05014                         TESTOK = .TRUE.
05015                         IPRE  = 2 * M
05016                         IPOST = IPRE
05017                         APTR = IPRE + 1
05018 *
05019 *                       If I am in scope
05020 *
05021                         IF( (MYROW.EQ.RSRC .AND. SCOPE.EQ.'R') .OR.
05022      $                       (MYCOL.EQ.CSRC .AND. SCOPE.EQ.'C') .OR.
05023      $                       (SCOPE .EQ. 'A') ) THEN
05024 *
05025 *                          source process generates matrix and sends it
05026 *
05027                            IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC ) THEN
05028                               CALL DINITMAT(UPLO, DIAG, M, N, MEM,
05029      $                                      LDASRC, IPRE, IPOST,
05030      $                                      SCHECKVAL, TESTNUM,
05031      $                                      MYROW, MYCOL )
05032 *
05033                               DO 20 J = ISTART, ISTOP
05034                                  IF( J.EQ.0 ) GOTO 20
05035                                  IF( SETWHAT.NE.0 )
05036      $                              CALL BLACS_SET(CONTEXT, SETWHAT, J)
05037                                  IF( UPLO.EQ.'U' .OR. UPLO.EQ.'L' ) THEN
05038                                      CALL DTRBS2D(CONTEXT, SCOPE, TOP,
05039      $                                            UPLO, DIAG, M, N,
05040      $                                            MEM(APTR), LDASRC )
05041                                  ELSE
05042                                      CALL DGEBS2D(CONTEXT, SCOPE, TOP,
05043      $                                            M, N, MEM(APTR),
05044      $                                            LDASRC )
05045                                  END IF
05046    20                         CONTINUE
05047 *
05048 *                          Destination processes
05049 *
05050                            ELSE IF( INGRID ) THEN
05051                               DO 40 J = ISTART, ISTOP
05052                                  IF( J.EQ.0 ) GOTO 40
05053                                  IF( SETWHAT.NE.0 )
05054      $                              CALL BLACS_SET(CONTEXT, SETWHAT, J)
05055 *
05056 *                                Pad entire matrix area
05057 *
05058                                  DO 30 K = 1, IPRE+IPOST+LDADST*N
05059                                     MEM(K) = RCHECKVAL
05060    30                            CONTINUE
05061 *
05062 *                                Receive matrix
05063 *
05064                                  IF( UPLO.EQ.'U' .OR. UPLO.EQ.'L' ) THEN
05065                                     CALL DTRBR2D(CONTEXT, SCOPE, TOP,
05066      $                                           UPLO, DIAG, M, N,
05067      $                                           MEM(APTR), LDADST,
05068      $                                           RSRC, CSRC)
05069                                  ELSE
05070                                     CALL DGEBR2D(CONTEXT, SCOPE, TOP,
05071      $                                           M, N, MEM(APTR),
05072      $                                           LDADST, RSRC, CSRC)
05073                                  END IF
05074 *
05075 *                                Check for errors in matrix or padding
05076 *
05077                                  I = NERR
05078                                  CALL DCHKMAT(UPLO, DIAG, M, N,
05079      $                                   MEM(APTR), LDADST, RSRC, CSRC,
05080      $                                   MYROW, MYCOL, TESTNUM, MAXERR,
05081      $                                   NERR, MEM(ERRIPTR),
05082      $                                   MEM(ERRDPTR))
05083 *
05084                                  CALL DCHKPAD(UPLO, DIAG, M, N, MEM,
05085      $                                   LDADST, RSRC, CSRC, MYROW,
05086      $                                   MYCOL, IPRE, IPOST, RCHECKVAL,
05087      $                                   TESTNUM, MAXERR, NERR,
05088      $                                   MEM(ERRIPTR), MEM(ERRDPTR))
05089    40                         CONTINUE
05090                               TESTOK = ( I .EQ. NERR )
05091                            END IF
05092                         END IF
05093 *
05094                         IF( VERB .GT. 1 ) THEN
05095                            I = NERR
05096                            CALL DBTCHECKIN(0, OUTNUM, MAXERR, NERR,
05097      $                                     MEM(ERRIPTR), MEM(ERRDPTR),
05098      $                                     TFAIL)
05099                            IF( IAM .EQ. 0 ) THEN
05100                               TESTOK = ( TESTOK .AND. (I.EQ.NERR) )
05101                               IF( TESTOK ) THEN
05102                                  WRITE(OUTNUM,7000)TESTNUM,'PASSED ',
05103      $                                 SCOPE, TOP, UPLO, DIAG, M, N,
05104      $                                 LDASRC, LDADST, RSRC, CSRC,
05105      $                                 NPROW, NPCOL
05106                               ELSE
05107                                  NFAIL = NFAIL + 1
05108                                  WRITE(OUTNUM,7000)TESTNUM,'FAILED ',
05109      $                                SCOPE, TOP, UPLO, DIAG, M, N,
05110      $                                LDASRC, LDADST, RSRC, CSRC,
05111      $                                NPROW, NPCOL
05112                               END IF
05113                            END IF
05114 *
05115 *                          Once we've printed out errors, can re-use buf space
05116 *
05117                            NERR = 0
05118                         END IF
05119    60                CONTINUE
05120    70             CONTINUE
05121    80          CONTINUE
05122    90       CONTINUE
05123   100    CONTINUE
05124   110 CONTINUE
05125 *
05126       IF( VERB .LT. 2 ) THEN
05127          NFAIL = TESTNUM
05128          CALL DBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR),
05129      $                    MEM(ERRDPTR), TFAIL )
05130       END IF
05131       IF( IAM .EQ. 0 ) THEN
05132          IF( VERB .GT. 1 ) WRITE(OUTNUM,*) '   '
05133          IF( NFAIL+NSKIP .EQ. 0 ) THEN
05134             WRITE(OUTNUM, 8000 ) TESTNUM
05135          ELSE
05136             WRITE(OUTNUM, 9000 ) TESTNUM, TESTNUM-NSKIP-NFAIL,
05137      $                           NSKIP, NFAIL
05138          END IF
05139       END IF
05140 *
05141 *     Log whether their were any failures
05142 *
05143       TESTOK = ALLPASS( (NFAIL.EQ.0) )
05144 *
05145  1000 FORMAT('DOUBLE PRECISION BSBR TESTS: BEGIN.' )
05146  2000 FORMAT(1X,A7,3X,10I6)
05147  3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,
05148      $       5X,A1,5X,A1)
05149  5000 FORMAT(' TEST#  STATUS SCOPE TOP UPLO DIAG     M     N  LDAS ',
05150      $       ' LDAD RSRC CSRC    P    Q')
05151  6000 FORMAT(' ----- ------- ----- --- ---- ---- ----- ----- ----- ',
05152      $       '----- ---- ---- ---- ----')
05153  7000 FORMAT(I6,1X,A7,5X,A1,3X,A1,2(4X,A1), 4I6, 4I5)
05154  8000 FORMAT('DOUBLE PRECISION BSBR TESTS: PASSED ALL',
05155      $       I5, ' TESTS.')
05156  9000 FORMAT('DOUBLE PRECISION BSBR TESTS:',I5,' TESTS;',I5,' PASSED,',
05157      $       I5,' SKIPPED,',I5,' FAILED.')
05158 *
05159       RETURN
05160 *
05161 *     End of DBSBRTEST.
05162 *
05163       END
05164 *
05165 *
05166       SUBROUTINE CBSBRTEST( OUTNUM, VERB, NSCOPE, SCOPE0, NTOP, TOP0,
05167      $                      NSHAPE, UPLO0, DIAG0, NMAT, M0, N0, LDAS0,
05168      $                      LDAD0, NSRC, RSRC0, CSRC0, NGRID, CONTEXT0,
05169      $                      P0, Q0, TFAIL, MEM, MEMLEN )
05170 *
05171 *  -- BLACS tester (version 1.0) --
05172 *  University of Tennessee
05173 *  December 15, 1994
05174 *
05175 *
05176 *     .. Scalar Arguments ..
05177       INTEGER OUTNUM, VERB, NSCOPE, NTOP, NSHAPE, NMAT, NSRC, NGRID
05178       INTEGER MEMLEN
05179 *     ..
05180 *     .. Array Arguments ..
05181       CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
05182       CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
05183       INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
05184       INTEGER RSRC0(NSRC), CSRC0(NSRC), CONTEXT0(NGRID)
05185       INTEGER P0(NGRID), Q0(NGRID), TFAIL(*)
05186       COMPLEX MEM(MEMLEN)
05187 *     ..
05188 *
05189 *  Purpose
05190 *  =======
05191 *  CTESTBSBR:  Test complex broadcast
05192 *
05193 *  Arguments
05194 *  =========
05195 *  OUTNUM   (input) INTEGER
05196 *           The device number to write output to.
05197 *
05198 *  VERB     (input) INTEGER
05199 *           The level of verbosity (how much printing to do).
05200 *
05201 *  NSCOPE   (input) INTEGER
05202 *           The number of scopes to be tested.
05203 *
05204 *  SCOPE0   (input) CHARACTER*1 array of dimension (NSCOPE)
05205 *           Values of the scopes to be tested.
05206 *
05207 *  NTOP     (input) INTEGER
05208 *           The number of topologies to be tested.
05209 *
05210 *  TOP0     (input) CHARACTER*1 array of dimension (NTOP)
05211 *           Values of the topologies to be tested.
05212 *
05213 *  NSHAPE   (input) INTEGER
05214 *           The number of matrix shapes to be tested.
05215 *
05216 *  UPLO0    (input) CHARACTER*1 array of dimension (NSHAPE)
05217 *           Values of UPLO to be tested.
05218 *
05219 *  DIAG0    (input) CHARACTER*1 array of dimension (NSHAPE)
05220 *           Values of DIAG to be tested.
05221 *
05222 *  NMAT     (input) INTEGER
05223 *           The number of matrices to be tested.
05224 *
05225 *  M0       (input) INTEGER array of dimension (NMAT)
05226 *           Values of M to be tested.
05227 *
05228 *  M0       (input) INTEGER array of dimension (NMAT)
05229 *           Values of M to be tested.
05230 *
05231 *  N0       (input) INTEGER array of dimension (NMAT)
05232 *           Values of N to be tested.
05233 *
05234 *  LDAS0    (input) INTEGER array of dimension (NMAT)
05235 *           Values of LDAS (leading dimension of A on source process)
05236 *           to be tested.
05237 *
05238 *  LDAD0    (input) INTEGER array of dimension (NMAT)
05239 *           Values of LDAD (leading dimension of A on destination
05240 *           process) to be tested.
05241 *  NSRC     (input) INTEGER
05242 *           The number of sources to be tested.
05243 *
05244 *  RSRC0    (input) INTEGER array of dimension (NDEST)
05245 *           Values of RSRC (row coordinate of source) to be tested.
05246 *
05247 *  CSRC0    (input) INTEGER array of dimension (NDEST)
05248 *           Values of CSRC (column coordinate of source) to be tested.
05249 *
05250 *  NGRID    (input) INTEGER
05251 *           The number of process grids to be tested.
05252 *
05253 *  CONTEXT0 (input) INTEGER array of dimension (NGRID)
05254 *           The BLACS context handles corresponding to the grids.
05255 *
05256 *  P0       (input) INTEGER array of dimension (NGRID)
05257 *           Values of P (number of process rows, NPROW).
05258 *
05259 *  Q0       (input) INTEGER array of dimension (NGRID)
05260 *           Values of Q (number of process columns, NPCOL).
05261 *
05262 *  TFAIL    (workspace) INTEGER array of dimension (NTESTS)
05263 *           If VERB < 2, serves to indicate which tests fail.  This
05264 *           requires workspace of NTESTS (number of tests performed).
05265 *
05266 *  MEM      (workspace) COMPLEX array of dimension (MEMLEN)
05267 *           Used for all other workspaces, including the matrix A,
05268 *           and its pre and post padding.
05269 *
05270 *  MEMLEN   (input) INTEGER
05271 *           The length, in elements, of MEM.
05272 *
05273 * =====================================================================
05274 *
05275 *     .. External Functions ..
05276       LOGICAL  ALLPASS, LSAME
05277       INTEGER  IBTMYPROC, IBTSIZEOF
05278       EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTSIZEOF
05279 *     ..
05280 *     .. External Subroutines ..
05281       EXTERNAL BLACS_GRIDINFO
05282       EXTERNAL CTRBS2D, CGEBS2D, CTRBR2D, CGEBR2D
05283       EXTERNAL CINITMAT, CCHKMAT, CCHKPAD, CBTCHECKIN
05284 *     ..
05285 *     .. Local Scalars ..
05286       CHARACTER*1 SCOPE, TOP, UPLO, DIAG
05287       LOGICAL TESTOK, INGRID
05288       INTEGER IAM, I, K, J, IGR, ISH, IMA, ISO, ISC, ITO
05289       INTEGER M, N, NPROW, NPCOL, MYROW, MYCOL, RSRC, CSRC
05290       INTEGER ISTART, ISTOP, IPRE, IPOST, SETWHAT
05291       INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
05292       INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE, CSIZE
05293       COMPLEX SCHECKVAL, RCHECKVAL
05294 *     ..
05295 *     .. Executable Statements ..
05296 *
05297       SCHECKVAL = CMPLX( -0.01, -0.01 )
05298       RCHECKVAL = CMPLX( -0.02, -0.02 )
05299 *
05300       IAM = IBTMYPROC()
05301       ISIZE = IBTSIZEOF('I')
05302       CSIZE = IBTSIZEOF('C')
05303 *
05304 *     Verify file parameters
05305 *
05306       IF( IAM .EQ. 0 ) THEN
05307          WRITE(OUTNUM, *) '  '
05308          WRITE(OUTNUM, *) '  '
05309          WRITE(OUTNUM, 1000 )
05310          IF( VERB .GT. 0 ) THEN
05311             WRITE(OUTNUM,*) '  '
05312             WRITE(OUTNUM, 2000) 'NSCOPE:', NSCOPE
05313             WRITE(OUTNUM, 3000) ' SCOPE:', ( SCOPE0(I), I = 1, NSCOPE )
05314             WRITE(OUTNUM, 2000) 'NTOP  :', NTOP
05315             WRITE(OUTNUM, 3000) ' TOP  :', ( TOP0(I), I = 1, NTOP )
05316             WRITE(OUTNUM, 2000) 'NSHAPE:', NSHAPE
05317             WRITE(OUTNUM, 3000) ' UPLO :', ( UPLO0(I), I = 1, NSHAPE )
05318             WRITE(OUTNUM, 3000) ' DIAG :', ( DIAG0(I), I = 1, NSHAPE )
05319             WRITE(OUTNUM, 2000) 'NMAT  :', NMAT
05320             WRITE(OUTNUM, 2000) ' M    :', ( M0(I), I = 1, NMAT )
05321             WRITE(OUTNUM, 2000) ' N    :', ( N0(I), I = 1, NMAT )
05322             WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT )
05323             WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT )
05324             WRITE(OUTNUM, 2000) 'NSRC  :', NSRC
05325             WRITE(OUTNUM, 2000) ' RSRC :',( RSRC0(I), I = 1, NSRC )
05326             WRITE(OUTNUM, 2000) ' CSRC :',( CSRC0(I), I = 1, NSRC )
05327             WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID
05328             WRITE(OUTNUM, 2000) ' P    :', ( P0(I), I = 1, NGRID )
05329             WRITE(OUTNUM, 2000) ' Q    :', ( Q0(I), I = 1, NGRID )
05330             WRITE(OUTNUM, 2000) 'VERB  :', VERB
05331             WRITE(OUTNUM,*) '  '
05332          END IF
05333          IF( VERB .GT. 1 ) THEN
05334             WRITE(OUTNUM,5000)
05335             WRITE(OUTNUM,6000)
05336          END IF
05337       END IF
05338 *
05339 *     Find biggest matrix, so we know where to stick error info
05340 *
05341       I = 0
05342       DO 10 IMA = 1, NMAT
05343          K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + 4 * M0(IMA)
05344          IF( K .GT. I ) I = K
05345    10 CONTINUE
05346       MAXERR = ( CSIZE * (MEMLEN-I) ) / ( CSIZE*2 + ISIZE*6 )
05347       IF( MAXERR .LT. 1 ) THEN
05348          WRITE(OUTNUM,*) 'ERROR: Not enough memory to run BSBR tests.'
05349          CALL BLACS_ABORT(-1, 1)
05350       END IF
05351       ERRDPTR = I + 1
05352       ERRIPTR = ERRDPTR + MAXERR
05353       NERR = 0
05354       TESTNUM = 0
05355       NFAIL = 0
05356       NSKIP = 0
05357 *
05358 *     Loop over grids of matrix
05359 *
05360       DO 110 IGR = 1, NGRID
05361 *
05362          CONTEXT = CONTEXT0(IGR)
05363          CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL )
05364 *
05365          INGRID = ( NPROW .GT. 0 )
05366 *
05367          DO 100 ISC = 1, NSCOPE
05368             SCOPE = SCOPE0(ISC)
05369             DO 90 ITO = 1, NTOP
05370                TOP = TOP0(ITO)
05371 *
05372 *              If testing multipath ('M') or general tree ('T'),
05373 *              need to loop over calls to BLACS_SET
05374 *
05375                IF( LSAME(TOP, 'M') ) THEN
05376                   SETWHAT = 11
05377                   IF( SCOPE .EQ. 'R' ) THEN
05378                      ISTART = -(NPCOL - 1)
05379                      ISTOP = -ISTART
05380                   ELSE IF (SCOPE .EQ. 'C') THEN
05381                      ISTART = -(NPROW - 1)
05382                      ISTOP = -ISTART
05383                   ELSE
05384                      ISTART = -(NPROW*NPCOL - 1)
05385                      ISTOP = -ISTART
05386                   ENDIF
05387                ELSE IF( LSAME(TOP, 'T') ) THEN
05388                   SETWHAT = 12
05389                   ISTART = 1
05390                   IF( SCOPE .EQ. 'R' ) THEN
05391                      ISTOP = NPCOL - 1
05392                   ELSE IF (SCOPE .EQ. 'C') THEN
05393                      ISTOP = NPROW - 1
05394                   ELSE
05395                      ISTOP = NPROW*NPCOL - 1
05396                   ENDIF
05397                ELSE
05398                   SETWHAT = 0
05399                   ISTART = 1
05400                   ISTOP = 1
05401                ENDIF
05402                DO 80 ISH = 1, NSHAPE
05403                   UPLO = UPLO0(ISH)
05404                   DIAG = DIAG0(ISH)
05405 *
05406                   DO 70 IMA = 1, NMAT
05407                      M = M0(IMA)
05408                      N = N0(IMA)
05409                      LDASRC = LDAS0(IMA)
05410                      LDADST = LDAD0(IMA)
05411 *
05412                      DO 60 ISO = 1, NSRC
05413                         TESTNUM = TESTNUM + 1
05414                         RSRC = RSRC0(ISO)
05415                         CSRC = CSRC0(ISO)
05416                         IF( RSRC.GE.P0(IGR) .OR. CSRC.GE.Q0(IGR) ) THEN
05417                            NSKIP = NSKIP + 1
05418                            GOTO 60
05419                         END IF
05420                         IF( VERB .GT. 1 ) THEN
05421                            IF( IAM .EQ. 0 ) THEN
05422                               WRITE(OUTNUM, 7000)
05423      $                        TESTNUM, 'RUNNING',SCOPE, TOP, UPLO, DIAG,
05424      $                        M, N, LDASRC, LDADST, RSRC, CSRC,
05425      $                        NPROW, NPCOL
05426                            END IF
05427                         END IF
05428 *
05429                         TESTOK = .TRUE.
05430                         IPRE  = 2 * M
05431                         IPOST = IPRE
05432                         APTR = IPRE + 1
05433 *
05434 *                       If I am in scope
05435 *
05436                         IF( (MYROW.EQ.RSRC .AND. SCOPE.EQ.'R') .OR.
05437      $                       (MYCOL.EQ.CSRC .AND. SCOPE.EQ.'C') .OR.
05438      $                       (SCOPE .EQ. 'A') ) THEN
05439 *
05440 *                          source process generates matrix and sends it
05441 *
05442                            IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC ) THEN
05443                               CALL CINITMAT(UPLO, DIAG, M, N, MEM,
05444      $                                      LDASRC, IPRE, IPOST,
05445      $                                      SCHECKVAL, TESTNUM,
05446      $                                      MYROW, MYCOL )
05447 *
05448                               DO 20 J = ISTART, ISTOP
05449                                  IF( J.EQ.0 ) GOTO 20
05450                                  IF( SETWHAT.NE.0 )
05451      $                              CALL BLACS_SET(CONTEXT, SETWHAT, J)
05452                                  IF( UPLO.EQ.'U' .OR. UPLO.EQ.'L' ) THEN
05453                                      CALL CTRBS2D(CONTEXT, SCOPE, TOP,
05454      $                                            UPLO, DIAG, M, N,
05455      $                                            MEM(APTR), LDASRC )
05456                                  ELSE
05457                                      CALL CGEBS2D(CONTEXT, SCOPE, TOP,
05458      $                                            M, N, MEM(APTR),
05459      $                                            LDASRC )
05460                                  END IF
05461    20                         CONTINUE
05462 *
05463 *                          Destination processes
05464 *
05465                            ELSE IF( INGRID ) THEN
05466                               DO 40 J = ISTART, ISTOP
05467                                  IF( J.EQ.0 ) GOTO 40
05468                                  IF( SETWHAT.NE.0 )
05469      $                              CALL BLACS_SET(CONTEXT, SETWHAT, J)
05470 *
05471 *                                Pad entire matrix area
05472 *
05473                                  DO 30 K = 1, IPRE+IPOST+LDADST*N
05474                                     MEM(K) = RCHECKVAL
05475    30                            CONTINUE
05476 *
05477 *                                Receive matrix
05478 *
05479                                  IF( UPLO.EQ.'U' .OR. UPLO.EQ.'L' ) THEN
05480                                     CALL CTRBR2D(CONTEXT, SCOPE, TOP,
05481      $                                           UPLO, DIAG, M, N,
05482      $                                           MEM(APTR), LDADST,
05483      $                                           RSRC, CSRC)
05484                                  ELSE
05485                                     CALL CGEBR2D(CONTEXT, SCOPE, TOP,
05486      $                                           M, N, MEM(APTR),
05487      $                                           LDADST, RSRC, CSRC)
05488                                  END IF
05489 *
05490 *                                Check for errors in matrix or padding
05491 *
05492                                  I = NERR
05493                                  CALL CCHKMAT(UPLO, DIAG, M, N,
05494      $                                   MEM(APTR), LDADST, RSRC, CSRC,
05495      $                                   MYROW, MYCOL, TESTNUM, MAXERR,
05496      $                                   NERR, MEM(ERRIPTR),
05497      $                                   MEM(ERRDPTR))
05498 *
05499                                  CALL CCHKPAD(UPLO, DIAG, M, N, MEM,
05500      $                                   LDADST, RSRC, CSRC, MYROW,
05501      $                                   MYCOL, IPRE, IPOST, RCHECKVAL,
05502      $                                   TESTNUM, MAXERR, NERR,
05503      $                                   MEM(ERRIPTR), MEM(ERRDPTR))
05504    40                         CONTINUE
05505                               TESTOK = ( I .EQ. NERR )
05506                            END IF
05507                         END IF
05508 *
05509                         IF( VERB .GT. 1 ) THEN
05510                            I = NERR
05511                            CALL CBTCHECKIN(0, OUTNUM, MAXERR, NERR,
05512      $                                     MEM(ERRIPTR), MEM(ERRDPTR),
05513      $                                     TFAIL)
05514                            IF( IAM .EQ. 0 ) THEN
05515                               TESTOK = ( TESTOK .AND. (I.EQ.NERR) )
05516                               IF( TESTOK ) THEN
05517                                  WRITE(OUTNUM,7000)TESTNUM,'PASSED ',
05518      $                                 SCOPE, TOP, UPLO, DIAG, M, N,
05519      $                                 LDASRC, LDADST, RSRC, CSRC,
05520      $                                 NPROW, NPCOL
05521                               ELSE
05522                                  NFAIL = NFAIL + 1
05523                                  WRITE(OUTNUM,7000)TESTNUM,'FAILED ',
05524      $                                SCOPE, TOP, UPLO, DIAG, M, N,
05525      $                                LDASRC, LDADST, RSRC, CSRC,
05526      $                                NPROW, NPCOL
05527                               END IF
05528                            END IF
05529 *
05530 *                          Once we've printed out errors, can re-use buf space
05531 *
05532                            NERR = 0
05533                         END IF
05534    60                CONTINUE
05535    70             CONTINUE
05536    80          CONTINUE
05537    90       CONTINUE
05538   100    CONTINUE
05539   110 CONTINUE
05540 *
05541       IF( VERB .LT. 2 ) THEN
05542          NFAIL = TESTNUM
05543          CALL CBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR),
05544      $                    MEM(ERRDPTR), TFAIL )
05545       END IF
05546       IF( IAM .EQ. 0 ) THEN
05547          IF( VERB .GT. 1 ) WRITE(OUTNUM,*) '   '
05548          IF( NFAIL+NSKIP .EQ. 0 ) THEN
05549             WRITE(OUTNUM, 8000 ) TESTNUM
05550          ELSE
05551             WRITE(OUTNUM, 9000 ) TESTNUM, TESTNUM-NSKIP-NFAIL,
05552      $                           NSKIP, NFAIL
05553          END IF
05554       END IF
05555 *
05556 *     Log whether their were any failures
05557 *
05558       TESTOK = ALLPASS( (NFAIL.EQ.0) )
05559 *
05560  1000 FORMAT('COMPLEX BSBR TESTS: BEGIN.' )
05561  2000 FORMAT(1X,A7,3X,10I6)
05562  3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,
05563      $       5X,A1,5X,A1)
05564  5000 FORMAT(' TEST#  STATUS SCOPE TOP UPLO DIAG     M     N  LDAS ',
05565      $       ' LDAD RSRC CSRC    P    Q')
05566  6000 FORMAT(' ----- ------- ----- --- ---- ---- ----- ----- ----- ',
05567      $       '----- ---- ---- ---- ----')
05568  7000 FORMAT(I6,1X,A7,5X,A1,3X,A1,2(4X,A1), 4I6, 4I5)
05569  8000 FORMAT('COMPLEX BSBR TESTS: PASSED ALL',
05570      $       I5, ' TESTS.')
05571  9000 FORMAT('COMPLEX BSBR TESTS:',I5,' TESTS;',I5,' PASSED,',
05572      $       I5,' SKIPPED,',I5,' FAILED.')
05573 *
05574       RETURN
05575 *
05576 *     End of CBSBRTEST.
05577 *
05578       END
05579 *
05580 *
05581       SUBROUTINE ZBSBRTEST( OUTNUM, VERB, NSCOPE, SCOPE0, NTOP, TOP0,
05582      $                      NSHAPE, UPLO0, DIAG0, NMAT, M0, N0, LDAS0,
05583      $                      LDAD0, NSRC, RSRC0, CSRC0, NGRID, CONTEXT0,
05584      $                      P0, Q0, TFAIL, MEM, MEMLEN )
05585 *
05586 *  -- BLACS tester (version 1.0) --
05587 *  University of Tennessee
05588 *  December 15, 1994
05589 *
05590 *
05591 *     .. Scalar Arguments ..
05592       INTEGER OUTNUM, VERB, NSCOPE, NTOP, NSHAPE, NMAT, NSRC, NGRID
05593       INTEGER MEMLEN
05594 *     ..
05595 *     .. Array Arguments ..
05596       CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
05597       CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
05598       INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
05599       INTEGER RSRC0(NSRC), CSRC0(NSRC), CONTEXT0(NGRID)
05600       INTEGER P0(NGRID), Q0(NGRID), TFAIL(*)
05601       DOUBLE COMPLEX MEM(MEMLEN)
05602 *     ..
05603 *
05604 *  Purpose
05605 *  =======
05606 *  ZTESTBSBR:  Test double complex broadcast
05607 *
05608 *  Arguments
05609 *  =========
05610 *  OUTNUM   (input) INTEGER
05611 *           The device number to write output to.
05612 *
05613 *  VERB     (input) INTEGER
05614 *           The level of verbosity (how much printing to do).
05615 *
05616 *  NSCOPE   (input) INTEGER
05617 *           The number of scopes to be tested.
05618 *
05619 *  SCOPE0   (input) CHARACTER*1 array of dimension (NSCOPE)
05620 *           Values of the scopes to be tested.
05621 *
05622 *  NTOP     (input) INTEGER
05623 *           The number of topologies to be tested.
05624 *
05625 *  TOP0     (input) CHARACTER*1 array of dimension (NTOP)
05626 *           Values of the topologies to be tested.
05627 *
05628 *  NSHAPE   (input) INTEGER
05629 *           The number of matrix shapes to be tested.
05630 *
05631 *  UPLO0    (input) CHARACTER*1 array of dimension (NSHAPE)
05632 *           Values of UPLO to be tested.
05633 *
05634 *  DIAG0    (input) CHARACTER*1 array of dimension (NSHAPE)
05635 *           Values of DIAG to be tested.
05636 *
05637 *  NMAT     (input) INTEGER
05638 *           The number of matrices to be tested.
05639 *
05640 *  M0       (input) INTEGER array of dimension (NMAT)
05641 *           Values of M to be tested.
05642 *
05643 *  M0       (input) INTEGER array of dimension (NMAT)
05644 *           Values of M to be tested.
05645 *
05646 *  N0       (input) INTEGER array of dimension (NMAT)
05647 *           Values of N to be tested.
05648 *
05649 *  LDAS0    (input) INTEGER array of dimension (NMAT)
05650 *           Values of LDAS (leading dimension of A on source process)
05651 *           to be tested.
05652 *
05653 *  LDAD0    (input) INTEGER array of dimension (NMAT)
05654 *           Values of LDAD (leading dimension of A on destination
05655 *           process) to be tested.
05656 *  NSRC     (input) INTEGER
05657 *           The number of sources to be tested.
05658 *
05659 *  RSRC0    (input) INTEGER array of dimension (NDEST)
05660 *           Values of RSRC (row coordinate of source) to be tested.
05661 *
05662 *  CSRC0    (input) INTEGER array of dimension (NDEST)
05663 *           Values of CSRC (column coordinate of source) to be tested.
05664 *
05665 *  NGRID    (input) INTEGER
05666 *           The number of process grids to be tested.
05667 *
05668 *  CONTEXT0 (input) INTEGER array of dimension (NGRID)
05669 *           The BLACS context handles corresponding to the grids.
05670 *
05671 *  P0       (input) INTEGER array of dimension (NGRID)
05672 *           Values of P (number of process rows, NPROW).
05673 *
05674 *  Q0       (input) INTEGER array of dimension (NGRID)
05675 *           Values of Q (number of process columns, NPCOL).
05676 *
05677 *  TFAIL    (workspace) INTEGER array of dimension (NTESTS)
05678 *           If VERB < 2, serves to indicate which tests fail.  This
05679 *           requires workspace of NTESTS (number of tests performed).
05680 *
05681 *  MEM      (workspace) DOUBLE COMPLEX array of dimension (MEMLEN)
05682 *           Used for all other workspaces, including the matrix A,
05683 *           and its pre and post padding.
05684 *
05685 *  MEMLEN   (input) INTEGER
05686 *           The length, in elements, of MEM.
05687 *
05688 * =====================================================================
05689 *
05690 *     .. External Functions ..
05691       LOGICAL  ALLPASS, LSAME
05692       INTEGER  IBTMYPROC, IBTSIZEOF
05693       EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTSIZEOF
05694 *     ..
05695 *     .. External Subroutines ..
05696       EXTERNAL BLACS_GRIDINFO
05697       EXTERNAL ZTRBS2D, ZGEBS2D, ZTRBR2D, ZGEBR2D
05698       EXTERNAL ZINITMAT, ZCHKMAT, ZCHKPAD, ZBTCHECKIN
05699 *     ..
05700 *     .. Local Scalars ..
05701       CHARACTER*1 SCOPE, TOP, UPLO, DIAG
05702       LOGICAL TESTOK, INGRID
05703       INTEGER IAM, I, K, J, IGR, ISH, IMA, ISO, ISC, ITO
05704       INTEGER M, N, NPROW, NPCOL, MYROW, MYCOL, RSRC, CSRC
05705       INTEGER ISTART, ISTOP, IPRE, IPOST, SETWHAT
05706       INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
05707       INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE, ZSIZE
05708       DOUBLE COMPLEX SCHECKVAL, RCHECKVAL
05709 *     ..
05710 *     .. Executable Statements ..
05711 *
05712       SCHECKVAL = DCMPLX( -0.01D0, -0.01D0 )
05713       RCHECKVAL = DCMPLX( -0.02D0, -0.02D0 )
05714 *
05715       IAM = IBTMYPROC()
05716       ISIZE = IBTSIZEOF('I')
05717       ZSIZE = IBTSIZEOF('Z')
05718 *
05719 *     Verify file parameters
05720 *
05721       IF( IAM .EQ. 0 ) THEN
05722          WRITE(OUTNUM, *) '  '
05723          WRITE(OUTNUM, *) '  '
05724          WRITE(OUTNUM, 1000 )
05725          IF( VERB .GT. 0 ) THEN
05726             WRITE(OUTNUM,*) '  '
05727             WRITE(OUTNUM, 2000) 'NSCOPE:', NSCOPE
05728             WRITE(OUTNUM, 3000) ' SCOPE:', ( SCOPE0(I), I = 1, NSCOPE )
05729             WRITE(OUTNUM, 2000) 'NTOP  :', NTOP
05730             WRITE(OUTNUM, 3000) ' TOP  :', ( TOP0(I), I = 1, NTOP )
05731             WRITE(OUTNUM, 2000) 'NSHAPE:', NSHAPE
05732             WRITE(OUTNUM, 3000) ' UPLO :', ( UPLO0(I), I = 1, NSHAPE )
05733             WRITE(OUTNUM, 3000) ' DIAG :', ( DIAG0(I), I = 1, NSHAPE )
05734             WRITE(OUTNUM, 2000) 'NMAT  :', NMAT
05735             WRITE(OUTNUM, 2000) ' M    :', ( M0(I), I = 1, NMAT )
05736             WRITE(OUTNUM, 2000) ' N    :', ( N0(I), I = 1, NMAT )
05737             WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT )
05738             WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT )
05739             WRITE(OUTNUM, 2000) 'NSRC  :', NSRC
05740             WRITE(OUTNUM, 2000) ' RSRC :',( RSRC0(I), I = 1, NSRC )
05741             WRITE(OUTNUM, 2000) ' CSRC :',( CSRC0(I), I = 1, NSRC )
05742             WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID
05743             WRITE(OUTNUM, 2000) ' P    :', ( P0(I), I = 1, NGRID )
05744             WRITE(OUTNUM, 2000) ' Q    :', ( Q0(I), I = 1, NGRID )
05745             WRITE(OUTNUM, 2000) 'VERB  :', VERB
05746             WRITE(OUTNUM,*) '  '
05747          END IF
05748          IF( VERB .GT. 1 ) THEN
05749             WRITE(OUTNUM,5000)
05750             WRITE(OUTNUM,6000)
05751          END IF
05752       END IF
05753 *
05754 *     Find biggest matrix, so we know where to stick error info
05755 *
05756       I = 0
05757       DO 10 IMA = 1, NMAT
05758          K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + 4 * M0(IMA)
05759          IF( K .GT. I ) I = K
05760    10 CONTINUE
05761       MAXERR = ( ZSIZE * (MEMLEN-I) ) / ( ZSIZE*2 + ISIZE*6 )
05762       IF( MAXERR .LT. 1 ) THEN
05763          WRITE(OUTNUM,*) 'ERROR: Not enough memory to run BSBR tests.'
05764          CALL BLACS_ABORT(-1, 1)
05765       END IF
05766       ERRDPTR = I + 1
05767       ERRIPTR = ERRDPTR + MAXERR
05768       NERR = 0
05769       TESTNUM = 0
05770       NFAIL = 0
05771       NSKIP = 0
05772 *
05773 *     Loop over grids of matrix
05774 *
05775       DO 110 IGR = 1, NGRID
05776 *
05777          CONTEXT = CONTEXT0(IGR)
05778          CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL )
05779 *
05780          INGRID = ( NPROW .GT. 0 )
05781 *
05782          DO 100 ISC = 1, NSCOPE
05783             SCOPE = SCOPE0(ISC)
05784             DO 90 ITO = 1, NTOP
05785                TOP = TOP0(ITO)
05786 *
05787 *              If testing multipath ('M') or general tree ('T'),
05788 *              need to loop over calls to BLACS_SET
05789 *
05790                IF( LSAME(TOP, 'M') ) THEN
05791                   SETWHAT = 11
05792                   IF( SCOPE .EQ. 'R' ) THEN
05793                      ISTART = -(NPCOL - 1)
05794                      ISTOP = -ISTART
05795                   ELSE IF (SCOPE .EQ. 'C') THEN
05796                      ISTART = -(NPROW - 1)
05797                      ISTOP = -ISTART
05798                   ELSE
05799                      ISTART = -(NPROW*NPCOL - 1)
05800                      ISTOP = -ISTART
05801                   ENDIF
05802                ELSE IF( LSAME(TOP, 'T') ) THEN
05803                   SETWHAT = 12
05804                   ISTART = 1
05805                   IF( SCOPE .EQ. 'R' ) THEN
05806                      ISTOP = NPCOL - 1
05807                   ELSE IF (SCOPE .EQ. 'C') THEN
05808                      ISTOP = NPROW - 1
05809                   ELSE
05810                      ISTOP = NPROW*NPCOL - 1
05811                   ENDIF
05812                ELSE
05813                   SETWHAT = 0
05814                   ISTART = 1
05815                   ISTOP = 1
05816                ENDIF
05817                DO 80 ISH = 1, NSHAPE
05818                   UPLO = UPLO0(ISH)
05819                   DIAG = DIAG0(ISH)
05820 *
05821                   DO 70 IMA = 1, NMAT
05822                      M = M0(IMA)
05823                      N = N0(IMA)
05824                      LDASRC = LDAS0(IMA)
05825                      LDADST = LDAD0(IMA)
05826 *
05827                      DO 60 ISO = 1, NSRC
05828                         TESTNUM = TESTNUM + 1
05829                         RSRC = RSRC0(ISO)
05830                         CSRC = CSRC0(ISO)
05831                         IF( RSRC.GE.P0(IGR) .OR. CSRC.GE.Q0(IGR) ) THEN
05832                            NSKIP = NSKIP + 1
05833                            GOTO 60
05834                         END IF
05835                         IF( VERB .GT. 1 ) THEN
05836                            IF( IAM .EQ. 0 ) THEN
05837                               WRITE(OUTNUM, 7000)
05838      $                        TESTNUM, 'RUNNING',SCOPE, TOP, UPLO, DIAG,
05839      $                        M, N, LDASRC, LDADST, RSRC, CSRC,
05840      $                        NPROW, NPCOL
05841                            END IF
05842                         END IF
05843 *
05844                         TESTOK = .TRUE.
05845                         IPRE  = 2 * M
05846                         IPOST = IPRE
05847                         APTR = IPRE + 1
05848 *
05849 *                       If I am in scope
05850 *
05851                         IF( (MYROW.EQ.RSRC .AND. SCOPE.EQ.'R') .OR.
05852      $                       (MYCOL.EQ.CSRC .AND. SCOPE.EQ.'C') .OR.
05853      $                       (SCOPE .EQ. 'A') ) THEN
05854 *
05855 *                          source process generates matrix and sends it
05856 *
05857                            IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC ) THEN
05858                               CALL ZINITMAT(UPLO, DIAG, M, N, MEM,
05859      $                                      LDASRC, IPRE, IPOST,
05860      $                                      SCHECKVAL, TESTNUM,
05861      $                                      MYROW, MYCOL )
05862 *
05863                               DO 20 J = ISTART, ISTOP
05864                                  IF( J.EQ.0 ) GOTO 20
05865                                  IF( SETWHAT.NE.0 )
05866      $                              CALL BLACS_SET(CONTEXT, SETWHAT, J)
05867                                  IF( UPLO.EQ.'U' .OR. UPLO.EQ.'L' ) THEN
05868                                      CALL ZTRBS2D(CONTEXT, SCOPE, TOP,
05869      $                                            UPLO, DIAG, M, N,
05870      $                                            MEM(APTR), LDASRC )
05871                                  ELSE
05872                                      CALL ZGEBS2D(CONTEXT, SCOPE, TOP,
05873      $                                            M, N, MEM(APTR),
05874      $                                            LDASRC )
05875                                  END IF
05876    20                         CONTINUE
05877 *
05878 *                          Destination processes
05879 *
05880                            ELSE IF( INGRID ) THEN
05881                               DO 40 J = ISTART, ISTOP
05882                                  IF( J.EQ.0 ) GOTO 40
05883                                  IF( SETWHAT.NE.0 )
05884      $                              CALL BLACS_SET(CONTEXT, SETWHAT, J)
05885 *
05886 *                                Pad entire matrix area
05887 *
05888                                  DO 30 K = 1, IPRE+IPOST+LDADST*N
05889                                     MEM(K) = RCHECKVAL
05890    30                            CONTINUE
05891 *
05892 *                                Receive matrix
05893 *
05894                                  IF( UPLO.EQ.'U' .OR. UPLO.EQ.'L' ) THEN
05895                                     CALL ZTRBR2D(CONTEXT, SCOPE, TOP,
05896      $                                           UPLO, DIAG, M, N,
05897      $                                           MEM(APTR), LDADST,
05898      $                                           RSRC, CSRC)
05899                                  ELSE
05900                                     CALL ZGEBR2D(CONTEXT, SCOPE, TOP,
05901      $                                           M, N, MEM(APTR),
05902      $                                           LDADST, RSRC, CSRC)
05903                                  END IF
05904 *
05905 *                                Check for errors in matrix or padding
05906 *
05907                                  I = NERR
05908                                  CALL ZCHKMAT(UPLO, DIAG, M, N,
05909      $                                   MEM(APTR), LDADST, RSRC, CSRC,
05910      $                                   MYROW, MYCOL, TESTNUM, MAXERR,
05911      $                                   NERR, MEM(ERRIPTR),
05912      $                                   MEM(ERRDPTR))
05913 *
05914                                  CALL ZCHKPAD(UPLO, DIAG, M, N, MEM,
05915      $                                   LDADST, RSRC, CSRC, MYROW,
05916      $                                   MYCOL, IPRE, IPOST, RCHECKVAL,
05917      $                                   TESTNUM, MAXERR, NERR,
05918      $                                   MEM(ERRIPTR), MEM(ERRDPTR))
05919    40                         CONTINUE
05920                               TESTOK = ( I .EQ. NERR )
05921                            END IF
05922                         END IF
05923 *
05924                         IF( VERB .GT. 1 ) THEN
05925                            I = NERR
05926                            CALL ZBTCHECKIN(0, OUTNUM, MAXERR, NERR,
05927      $                                     MEM(ERRIPTR), MEM(ERRDPTR),
05928      $                                     TFAIL)
05929                            IF( IAM .EQ. 0 ) THEN
05930                               TESTOK = ( TESTOK .AND. (I.EQ.NERR) )
05931                               IF( TESTOK ) THEN
05932                                  WRITE(OUTNUM,7000)TESTNUM,'PASSED ',
05933      $                                 SCOPE, TOP, UPLO, DIAG, M, N,
05934      $                                 LDASRC, LDADST, RSRC, CSRC,
05935      $                                 NPROW, NPCOL
05936                               ELSE
05937                                  NFAIL = NFAIL + 1
05938                                  WRITE(OUTNUM,7000)TESTNUM,'FAILED ',
05939      $                                SCOPE, TOP, UPLO, DIAG, M, N,
05940      $                                LDASRC, LDADST, RSRC, CSRC,
05941      $                                NPROW, NPCOL
05942                               END IF
05943                            END IF
05944 *
05945 *                          Once we've printed out errors, can re-use buf space
05946 *
05947                            NERR = 0
05948                         END IF
05949    60                CONTINUE
05950    70             CONTINUE
05951    80          CONTINUE
05952    90       CONTINUE
05953   100    CONTINUE
05954   110 CONTINUE
05955 *
05956       IF( VERB .LT. 2 ) THEN
05957          NFAIL = TESTNUM
05958          CALL ZBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR),
05959      $                    MEM(ERRDPTR), TFAIL )
05960       END IF
05961       IF( IAM .EQ. 0 ) THEN
05962          IF( VERB .GT. 1 ) WRITE(OUTNUM,*) '   '
05963          IF( NFAIL+NSKIP .EQ. 0 ) THEN
05964             WRITE(OUTNUM, 8000 ) TESTNUM
05965          ELSE
05966             WRITE(OUTNUM, 9000 ) TESTNUM, TESTNUM-NSKIP-NFAIL,
05967      $                           NSKIP, NFAIL
05968          END IF
05969       END IF
05970 *
05971 *     Log whether their were any failures
05972 *
05973       TESTOK = ALLPASS( (NFAIL.EQ.0) )
05974 *
05975  1000 FORMAT('DOUBLE COMPLEX BSBR TESTS: BEGIN.' )
05976  2000 FORMAT(1X,A7,3X,10I6)
05977  3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,
05978      $       5X,A1,5X,A1)
05979  5000 FORMAT(' TEST#  STATUS SCOPE TOP UPLO DIAG     M     N  LDAS ',
05980      $       ' LDAD RSRC CSRC    P    Q')
05981  6000 FORMAT(' ----- ------- ----- --- ---- ---- ----- ----- ----- ',
05982      $       '----- ---- ---- ---- ----')
05983  7000 FORMAT(I6,1X,A7,5X,A1,3X,A1,2(4X,A1), 4I6, 4I5)
05984  8000 FORMAT('DOUBLE COMPLEX BSBR TESTS: PASSED ALL',
05985      $       I5, ' TESTS.')
05986  9000 FORMAT('DOUBLE COMPLEX BSBR TESTS:',I5,' TESTS;',I5,' PASSED,',
05987      $       I5,' SKIPPED,',I5,' FAILED.')
05988 *
05989       RETURN
05990 *
05991 *     End of ZBSBRTEST.
05992 *
05993       END
05994 *
05995 *
05996       SUBROUTINE RDCOMB( MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM, CMEMLEN,
05997      $                   OUTNUM )
05998 *
05999 *  -- BLACS tester (version 1.0) --
06000 *  University of Tennessee
06001 *  December 15, 1994
06002 *
06003 *
06004 *     .. Scalar Arguments ..
06005       INTEGER MEMUSED, MEMLEN, CMEMUSED, CMEMLEN, OUTNUM
06006 *     ..
06007 *     .. Array Arguments ..
06008       CHARACTER*1 CMEM(CMEMLEN)
06009       INTEGER MEM(MEMLEN)
06010 *     ..
06011 *
06012 *     Purpose
06013 *     =======
06014 *     RDCOMB:  Read and process the input file COMB.dat.
06015 *
06016 *     Arguments
06017 *     =========
06018 *     MEMUSED  (output) INTEGER
06019 *              Number of elements in MEM that this subroutine ends up using.
06020 *
06021 *     MEM      (output) INTEGER array of dimension memlen
06022 *              On output, holds information read in from sdrv.dat.
06023 *
06024 *     MEMLEN   (input) INTEGER
06025 *              Number of elements of MEM that this subroutine
06026 *              may safely write into.
06027 *
06028 *     CMEMUSED (output) INTEGER
06029 *              Number of elements in CMEM that this subroutine ends up using.
06030 *
06031 *     CMEM     (output) CHARACTER*1 array of dimension cmemlen
06032 *              On output, holds the values for UPLO and DIAG.
06033 *
06034 *     CMEMLEN  (input) INTEGER
06035 *              Number of elements of CMEM that this subroutine
06036 *              may safely write into.
06037 *
06038 *     OUTNUM   (input) INTEGER
06039 *              Unit number of the output file.
06040 *
06041 *     =================================================================
06042 *
06043 *     .. Parameters ..
06044       INTEGER SDIN
06045       PARAMETER( SDIN = 12 )
06046 *     ..
06047 *     .. External Functions ..
06048       LOGICAL  LSAME
06049       EXTERNAL LSAME
06050 *     ..
06051 *     .. Local Scalars ..
06052       INTEGER TOPSREPEAT, TOPSCOHRNT, NOPS, NSCOPE, NTOP, NMAT, NDEST
06053       INTEGER NGRID, I, J, OPPTR, SCOPEPTR, TOPPTR, MPTR, NPTR
06054       INTEGER LDSPTR, LDDPTR, LDIPTR, RDESTPTR, CDESTPTR, PPTR, QPTR
06055 *     ..
06056 *     .. Executable Statements
06057 *
06058 *     Open and read the file comb.dat.  The expected format is
06059 *     below.
06060 *
06061 *------
06062 *integer                         Number of operations
06063 *array of CHAR*1's               OPs: '+', '>', '<'
06064 *integer                         Number of scopes
06065 *array of CHAR*1's               Values for Scopes
06066 *HAR*1                           Repeatability flag ('R', 'N', 'B')
06067 *HAR*1                           Coherency flag ('C', 'N', 'B')
06068 *integer                         Number of topologies
06069 *array of CHAR*1's               Values for TOP
06070 *integer                         number of nmat
06071 *array of integers               M: number of rows in matrix
06072 *array of integers               N: number of columns in matrix
06073 *integer                         LDA: leading dimension on source proc
06074 *integer                         LDA: leading dimension on dest proc
06075 *integer                         number of source/dest pairs
06076 *array of integers               RDEST: process row of msg. dest.
06077 *array of integers               CDEST: process column of msg. dest.
06078 *integer                         Number of grids
06079 *array of integers               NPROW: number of rows in process grid
06080 *array of integers               NPCOL: number of col's in proc. grid
06081 *------
06082 *  note: the text descriptions as shown above are present in
06083 *             the sample comb.dat included with this distribution,
06084 *             but are not required.
06085 *
06086 *     Read input file
06087 *
06088       MEMUSED = 1
06089       CMEMUSED = 1
06090       OPEN(UNIT = SDIN, FILE = 'comb.dat', STATUS = 'OLD')
06091 *
06092 *     Get what operations to test (+, >, <)
06093 *
06094       READ(SDIN, *) NOPS
06095       OPPTR = CMEMUSED
06096       CMEMUSED = OPPTR + NOPS
06097       IF ( CMEMUSED .GT. CMEMLEN ) THEN
06098          WRITE(OUTNUM, 1000) CMEMLEN, NOPS, 'OPERATIONS.'
06099          IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
06100          STOP
06101       ELSE IF( NOPS .LT. 1 ) THEN
06102          WRITE(OUTNUM, 2000) 'OPERATIONS.'
06103          IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
06104          STOP
06105       END IF
06106 *
06107       READ(SDIN, *) ( CMEM(OPPTR+I), I = 0, NOPS-1 )
06108       DO 10 I = 0, NOPS-1
06109          IF( (CMEM(OPPTR+I).NE.'+') .AND. (CMEM(OPPTR+I).NE.'>') .AND.
06110      $       (CMEM(OPPTR+I).NE.'<') ) THEN
06111             WRITE(OUTNUM,5000) CMEM(OPPTR+I)
06112             IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
06113             STOP
06114          END IF
06115    10 CONTINUE
06116 *
06117 *     Read in scopes and topologies
06118 *
06119       READ(SDIN, *) NSCOPE
06120       SCOPEPTR = CMEMUSED
06121       CMEMUSED = SCOPEPTR + NSCOPE
06122       IF ( CMEMUSED .GT. CMEMLEN ) THEN
06123          WRITE(OUTNUM, 1000) CMEMLEN, NSCOPE, 'SCOPES.'
06124          IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
06125          STOP
06126       ELSE IF( NSCOPE .LT. 1 ) THEN
06127          WRITE(OUTNUM, 2000) 'SCOPE.'
06128          IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
06129          STOP
06130       END IF
06131 *
06132       READ(SDIN, *) ( CMEM(SCOPEPTR+I), I = 0, NSCOPE-1 )
06133       DO 20 I = 0, NSCOPE-1
06134          IF( LSAME(CMEM(SCOPEPTR+I), 'R') ) THEN
06135             CMEM(SCOPEPTR+I) = 'R'
06136          ELSE IF( LSAME(CMEM(SCOPEPTR+I), 'C') ) THEN
06137             CMEM(SCOPEPTR+I) = 'C'
06138          ELSE IF( LSAME(CMEM(SCOPEPTR+I), 'A') ) THEN
06139             CMEM(SCOPEPTR+I) = 'A'
06140          ELSE
06141             WRITE(OUTNUM, 3000) 'SCOPE', CMEM(SCOPEPTR+I)
06142             IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
06143             STOP
06144          END IF
06145    20 CONTINUE
06146 *
06147       READ(SDIN, *) TOPSREPEAT
06148       READ(SDIN, *) TOPSCOHRNT
06149 *
06150       READ(SDIN, *) NTOP
06151       TOPPTR = CMEMUSED
06152       CMEMUSED = TOPPTR + NTOP
06153       IF ( CMEMUSED .GT. CMEMLEN ) THEN
06154          WRITE(OUTNUM, 1000) CMEMLEN, NTOP, 'TOPOLOGIES.'
06155          IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
06156          STOP
06157       ELSE IF( NTOP .LT. 1 ) THEN
06158          WRITE(OUTNUM, 2000) 'TOPOLOGY.'
06159          IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
06160          STOP
06161       END IF
06162       READ(SDIN, *) ( CMEM(TOPPTR+I), I = 0, NTOP-1 )
06163 *
06164 *
06165 *     Read in number of matrices, and values for M, N, LDASRC, and LDADEST
06166 *
06167       READ(SDIN, *) NMAT
06168       MPTR = MEMUSED
06169       NPTR = MPTR + NMAT
06170       LDSPTR = NPTR + NMAT
06171       LDDPTR = LDSPTR + NMAT
06172       LDIPTR = LDDPTR + NMAT
06173       MEMUSED = LDIPTR + NMAT
06174       IF( MEMUSED .GT. MEMLEN ) THEN
06175          WRITE(OUTNUM, 1000) MEMLEN, NMAT, 'MATRICES.'
06176          IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
06177          STOP
06178       ELSE IF( NMAT .LT. 1 ) THEN
06179          WRITE(OUTNUM, 2000) 'MATRIX.'
06180          IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
06181          STOP
06182       END IF
06183       READ(SDIN, *) ( MEM( MPTR+I ), I = 0, NMAT-1 )
06184       READ(SDIN, *) ( MEM( NPTR+I ), I = 0, NMAT-1 )
06185       READ(SDIN, *) ( MEM( LDSPTR+I ), I = 0, NMAT-1 )
06186       READ(SDIN, *) ( MEM( LDDPTR+I ), I = 0, NMAT-1 )
06187       READ(SDIN, *) ( MEM( LDIPTR+I ), I = 0, NMAT-1 )
06188 *
06189 *     Make sure matrix values are legal
06190 *
06191       CALL CHKMATDAT( OUTNUM, 'COMB.dat', .TRUE., NMAT, MEM(MPTR),
06192      $                MEM(NPTR), MEM(LDSPTR), MEM(LDDPTR), MEM(LDIPTR) )
06193 *
06194 *     Read in number of dest pairs, and values of dest
06195 *
06196       READ(SDIN, *) NDEST
06197       RDESTPTR  = MEMUSED
06198       CDESTPTR  = RDESTPTR  + NDEST
06199       MEMUSED  = CDESTPTR + NDEST
06200       IF( MEMUSED .GT. MEMLEN ) THEN
06201          WRITE(OUTNUM, 1000) MEMLEN, NMAT, 'DEST.'
06202          IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
06203          STOP
06204       ELSE IF( NDEST .LT. 1 ) THEN
06205          WRITE(OUTNUM, 2000) 'DEST.'
06206          IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
06207          STOP
06208       END IF
06209       READ(SDIN, *) ( MEM(RDESTPTR+I), I = 0, NDEST-1 )
06210       READ(SDIN, *) ( MEM(CDESTPTR+I), I = 0, NDEST-1 )
06211 *
06212 *     Read in number of grids pairs, and values of P (process rows) and
06213 *     Q (process columns)
06214 *
06215       READ(SDIN, *) NGRID
06216       PPTR = MEMUSED
06217       QPTR = PPTR + NGRID
06218       MEMUSED = QPTR + NGRID
06219       IF( MEMUSED .GT. MEMLEN ) THEN
06220          WRITE(OUTNUM, 1000) MEMLEN, NGRID, 'PROCESS GRIDS.'
06221          IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
06222          STOP
06223       ELSE IF( NGRID .LT. 1 ) THEN
06224          WRITE(OUTNUM, 2000) 'PROCESS GRID'
06225          IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE( OUTNUM )
06226          STOP
06227       END IF
06228 *
06229       READ(SDIN, *) ( MEM(PPTR+I), I = 0, NGRID-1 )
06230       READ(SDIN, *) ( MEM(QPTR+I), I = 0, NGRID-1 )
06231       IF( SDIN .NE. 6 .AND. SDIN .NE. 0 ) CLOSE( SDIN )
06232 *
06233 *     Fatal error if we've got an illegal grid
06234 *
06235       DO 70 J = 0, NGRID-1
06236          IF( MEM(PPTR+J).LT.1 .OR. MEM(QPTR+J).LT.1 ) THEN
06237             WRITE(OUTNUM, 4000) MEM(PPTR+J), MEM(QPTR+J)
06238             IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
06239             STOP
06240          END IF
06241    70 CONTINUE
06242 *
06243 *     Prepare output variables
06244 *
06245       MEM(MEMUSED)   = NOPS
06246       MEM(MEMUSED+1) = NSCOPE
06247       MEM(MEMUSED+2) = TOPSREPEAT
06248       MEM(MEMUSED+3) = TOPSCOHRNT
06249       MEM(MEMUSED+4) = NTOP
06250       MEM(MEMUSED+5) = NMAT
06251       MEM(MEMUSED+6) = NDEST
06252       MEM(MEMUSED+7) = NGRID
06253       MEMUSED = MEMUSED + 7
06254       CMEMUSED = CMEMUSED - 1
06255 *
06256  1000 FORMAT('Mem too short (',I4,') to handle',I4,' ',A20)
06257  2000 FORMAT('Must have at least one ',A20)
06258  3000 FORMAT('UNRECOGNIZABLE ',A5,' ''', A1, '''.')
06259  4000 FORMAT('Illegal process grid: {',I3,',',I3,'}.')
06260  5000 FORMAT('Illegal OP value ''',A1,''':, expected ''+'' (SUM),',
06261      $       ' ''>'' (MAX), or ''<'' (MIN).')
06262 *
06263       RETURN
06264 *
06265 *     End of RDCOMB.
06266 *
06267       END
06268 *
06269 *
06270       SUBROUTINE IBTCHECKIN( NFTESTS, OUTNUM, MAXERR, NERR, IERR,
06271      $                       IVAL, TFAILED )
06272       INTEGER NFTESTS, OUTNUM, MAXERR, NERR
06273       INTEGER IERR(*), TFAILED(*)
06274       INTEGER IVAL(*)
06275 *
06276 *  Purpose
06277 *  =======
06278 *  IBTCHECKIN: Process 0 receives error report from all processes.
06279 *
06280 *  Arguments
06281 *  =========
06282 *  NFTESTS  (input/output) INTEGER
06283 *           if NFTESTS is <= 0 upon entry, NFTESTS is not written to.
06284 *           Otherwise, on entry it specifies the total number of tests
06285 *           run, and on exit it is the number of tests which failed.
06286 *
06287 *  OUTNUM   (input) INTEGER
06288 *           Device number for output.
06289 *
06290 *  MAXERR   (input) INTEGER
06291 *           Max number of errors that can be stored in ERRIBUFF or
06292 *           ERRIBUFF
06293 *
06294 *  NERR     (output) INTEGER
06295 *           The number of errors that have been found.
06296 *
06297 *  ERRIBUF  (output) INTEGER array, dimension (6,MAXERRS)
06298 *           Buffer in which to store integer error information.  It will
06299 *           be built up in the following format for the call to TSEND.
06300 *           All integer information is recorded in the following 6-tuple
06301 *           {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
06302 *             SRC = RSRC * NPROCS + CSRC
06303 *             DEST = RDEST * NPROCS + CDEST
06304 *             WHAT
06305 *              = 1 : Error in pre-padding
06306 *              = 2 : Error in post-padding
06307 *              = 3 : Error in LDA-M gap
06308 *              = 4 : Error in complementory triangle
06309 *              ELSE: Error in matrix
06310 *           If there are more errors than can fit in the error buffer,
06311 *           the error number will indicate the actual number of errors
06312 *           found, but the buffer will be truncated to the maximum
06313 *           number of errors which can fit.
06314 *
06315 *  ERRDBUF  (output) @(doctype) array, dimension (2, MAXERRS)
06316 *           Buffer in which to store error data information.
06317 *           {Incorrect, Predicted}
06318 *
06319 *  TFAILED (workspace) INTEGER array, dimension NFTESTS
06320 *          Workspace used to keep track of which tests failed.
06321 *          If input of NFTESTS < 1, this array not accessed.
06322 *
06323 *  ===================================================================
06324 *
06325 *     .. External Functions ..
06326       INTEGER  IBTMYPROC, IBTNPROCS, IBTMSGID
06327       EXTERNAL IBTMYPROC, IBTNPROCS, IBTMSGID
06328 *     ..
06329 *     .. Local Scalars ..
06330       LOGICAL COUNTING
06331       INTEGER K, NERR2, IAM, NPROCS, NTESTS
06332 *
06333 *     Proc 0 collects error info from everyone
06334 *
06335       IAM = IBTMYPROC()
06336       NPROCS = IBTNPROCS()
06337 *
06338       IF( IAM .EQ. 0 ) THEN
06339 *
06340 *        If we are finding out how many failed tests there are, initialize
06341 *        the total number of tests (NTESTS), and zero the test failed array
06342 *
06343          COUNTING = NFTESTS .GT. 0
06344          IF( COUNTING ) THEN
06345             NTESTS = NFTESTS
06346             DO 10 K = 1, NTESTS
06347                TFAILED(K) = 0
06348    10       CONTINUE
06349          END IF
06350 *
06351          CALL IPRINTERRS(OUTNUM, MAXERR, NERR, IERR, IVAL, COUNTING,
06352      $                   TFAILED)
06353 *
06354          DO 20 K = 1, NPROCS-1
06355             CALL BTSEND(3, 0, K, K, IBTMSGID()+50)
06356             CALL BTRECV(3, 1, NERR2, K, IBTMSGID()+50)
06357             IF( NERR2 .GT. 0 ) THEN
06358                NERR = NERR + NERR2
06359                CALL BTRECV(3, NERR2*6, IERR, K, IBTMSGID()+51)
06360                CALL BTRECV(3, NERR2*2, IVAL, K, IBTMSGID()+51)
06361                CALL IPRINTERRS(OUTNUM, MAXERR, NERR2, IERR, IVAL,
06362      $                         COUNTING, TFAILED)
06363             END IF
06364    20    CONTINUE
06365 *
06366 *        Count up number of tests that failed
06367 *
06368          IF( COUNTING ) THEN
06369             NFTESTS = 0
06370             DO 30 K = 1, NTESTS
06371                NFTESTS = NFTESTS + TFAILED(K)
06372    30       CONTINUE
06373          END IF
06374 *
06375 *     Send my error info to proc 0
06376 *
06377       ELSE
06378          CALL BTRECV(3, 0, K, 0, IBTMSGID()+50)
06379          CALL BTSEND(3, 1, NERR, 0, IBTMSGID()+50)
06380          IF( NERR .GT. 0 ) THEN
06381             CALL BTSEND(3, NERR*6, IERR, 0, IBTMSGID()+51)
06382             CALL BTSEND(3, NERR*2, IVAL, 0, IBTMSGID()+51)
06383          END IF
06384       ENDIF
06385 *
06386       RETURN
06387 *
06388 *     End of IBTCHECKIN
06389 *
06390       END
06391 *
06392       SUBROUTINE IINITMAT(UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST,
06393      $                    CHECKVAL, TESTNUM, MYROW, MYCOL)
06394       CHARACTER*1 UPLO, DIAG
06395       INTEGER M, N, LDA, IPRE, IPOST, TESTNUM, MYROW, MYCOL
06396       INTEGER CHECKVAL
06397       INTEGER MEM(*)
06398 *
06399 *     .. External Subroutines ..
06400       EXTERNAL IGENMAT, IPADMAT
06401 *     ..
06402 *     .. Executable Statements ..
06403 *
06404       CALL IGENMAT( M, N, MEM(IPRE+1), LDA, TESTNUM, MYROW, MYCOL )
06405       CALL IPADMAT( UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST, CHECKVAL )
06406 *
06407       RETURN
06408       END
06409 *
06410       SUBROUTINE IGENMAT( M, N, A, LDA, TESTNUM, MYROW, MYCOL )
06411 *
06412 *  -- BLACS tester (version 1.0) --
06413 *  University of Tennessee
06414 *  December 15, 1994
06415 *
06416 *
06417 *     .. Scalar Arguments ..
06418       INTEGER M, N, LDA, TESTNUM, MYROW, MYCOL
06419 *     ..
06420 *     .. Array Arguments ..
06421       INTEGER A(LDA,N)
06422 *     ..
06423 *
06424 *  Purpose
06425 *  =======
06426 *  IGENMAT: Generates an M-by-N matrix filled with random elements.
06427 *
06428 *  Arguments
06429 *  =========
06430 *   M       (input) INTEGER
06431 *           The number of rows of the matrix A.  M >= 0.
06432 *
06433 *   N       (input) INTEGER
06434 *           The number of columns of the matrix A.  N >= 0.
06435 *
06436 *   A       (output) @up@(doctype) array, dimension (LDA,N)
06437 *           The m by n matrix A.  Fortran77 (column-major) storage
06438 *           assumed.
06439 *
06440 *   LDA     (input) INTEGER
06441 *           The leading dimension of the array A.  LDA >= max(1, M).
06442 *
06443 *  TESTNUM  (input) INTEGER
06444 *           Unique number for this test case, used as a basis for
06445 *           the random seeds.
06446 *
06447 *  ====================================================================
06448 *
06449 *     .. External Functions ..
06450       INTEGER IBTNPROCS
06451       INTEGER IBTRAN
06452       EXTERNAL IBTRAN, IBTNPROCS
06453 *     ..
06454 *     .. Local Scalars ..
06455       INTEGER I, J, NPROCS, SRC
06456 *     ..
06457 *     .. Local Arrays ..
06458       INTEGER ISEED(4)
06459 *     ..
06460 *     .. Executable Statements ..
06461 *
06462 *     ISEED's four values must be positive integers less than 4096,
06463 *     fourth one has to be odd. (see _LARND).  Use some goofy
06464 *     functions to come up with seed values which together should
06465 *     be unique.
06466 *
06467       NPROCS = IBTNPROCS()
06468       SRC = MYROW * NPROCS + MYCOL
06469       ISEED(1) = MOD( 1002 + TESTNUM*5 + SRC*3, 4096 )
06470       ISEED(2) = MOD( 2027 + TESTNUM*7 + SRC, 4096 )
06471       ISEED(3) = MOD( 1234 + TESTNUM + SRC*3, 4096 )
06472       ISEED(4) = MOD( 4311 + TESTNUM*10 + SRC*2, 4096 )
06473 *
06474       DO 10 J = 1, N
06475          DO 10 I = 1, M
06476             A(I, J) = IBTRAN( ISEED )
06477    10 CONTINUE
06478 *
06479       RETURN
06480 *
06481 *     End of IGENMAT.
06482 *
06483       END
06484 *
06485       INTEGER FUNCTION IBTRAN(ISEED)
06486       INTEGER ISEED(*)
06487 *
06488 *     .. External Functions ..
06489       DOUBLE PRECISION DLARND
06490       EXTERNAL DLARND
06491 *     ..
06492 *     .. Local Scalars ..
06493       DOUBLE PRECISION DVAL
06494 *     ..
06495 *     .. Executable Statements ..
06496 *
06497       DVAL = 1.0D6 * DLARND(2, ISEED)
06498       IBTRAN = INT(DVAL)
06499 *
06500       RETURN
06501 *
06502 *     End of Ibtran
06503 *
06504       END
06505 *
06506       SUBROUTINE IPADMAT( UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST,
06507      $                    CHECKVAL )
06508 *
06509 *  -- BLACS tester (version 1.0) --
06510 *  University of Tennessee
06511 *  December 15, 1994
06512 *
06513 *     .. Scalar Arguments ..
06514       CHARACTER*1 UPLO, DIAG
06515       INTEGER M, N, LDA, IPRE, IPOST
06516       INTEGER CHECKVAL
06517 *     ..
06518 *     .. Array Arguments ..
06519       INTEGER MEM( * )
06520 *     ..
06521 *
06522 *  Purpose
06523 *  =======
06524 *
06525 *  IPADMAT: Pad Matrix.
06526 *  This routines surrounds a matrix with a guardzone initialized to the
06527 *  value CHECKVAL.  There are three distinct guardzones:
06528 *  - A contiguous zone of size IPRE immediately before the start
06529 *    of the matrix.
06530 *  - A contiguous zone of size IPOST immedately after the end of the
06531 *    matrix.
06532 *  - Interstitial zones within each column of the matrix, in the
06533 *    elements A( M+1:LDA, J ).
06534 *
06535 *  Arguments
06536 *  =========
06537 *  UPLO     (input) CHARACTER*1
06538 *           Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
06539 *           rectangular?
06540 *
06541 *  DIAG     (input) CHARACTER*1
06542 *           For trapezoidal matrices, is the main diagonal included
06543 *           ('N') or not ('U')?
06544 *
06545 *   M       (input) INTEGER
06546 *           The number of rows of the matrix A.  M >= 0.
06547 *
06548 *   N       (input) INTEGER
06549 *           The number of columns of the matrix A.  N >= 0.
06550 *
06551 *  MEM      (output) integer array, dimension (IPRE+IPOST+LDA*N)
06552 *           The address IPRE elements ahead of the matrix A you want to
06553 *           pad, which is then of dimension (LDA,N).
06554 *
06555 *  IPRE     (input) INTEGER
06556 *           The size of the guard zone ahead of the matrix A.
06557 *
06558 *  IPOST    (input) INTEGER
06559 *           The size of the guard zone behind the matrix A.
06560 *
06561 *  CHECKVAL (input) integer
06562 *           The value to insert into the guard zones.
06563 *
06564 *  ====================================================================
06565 *
06566 *     .. Local Scalars ..
06567       INTEGER I, J, K
06568 *     ..
06569 *     .. Executable Statements ..
06570 *
06571 *     Put check buffer in front of A
06572 *
06573       IF( IPRE .GT. 0 ) THEN
06574          DO 10 I = 1, IPRE
06575             MEM( I ) = CHECKVAL
06576    10    CONTINUE
06577       END IF
06578 *
06579 *     Put check buffer in back of A
06580 *
06581       IF( IPOST .GT. 0 ) THEN
06582          J = IPRE + LDA*N + 1
06583          DO 20 I = J, J+IPOST-1
06584             MEM( I ) = CHECKVAL
06585    20    CONTINUE
06586       END IF
06587 *
06588 *     Put check buffer in all (LDA-M) gaps
06589 *
06590       IF( LDA .GT. M ) THEN
06591          K = IPRE + M + 1
06592          DO 40 J = 1, N
06593             DO 30 I = K, K+LDA-M-1
06594                MEM( I ) = CHECKVAL
06595    30       CONTINUE
06596             K = K + LDA
06597    40    CONTINUE
06598       END IF
06599 *
06600 *     If the matrix is upper or lower trapezoidal, calculate the
06601 *     additional triangular area which needs to be padded,  Each
06602 *     element referred to is in the Ith row and the Jth column.
06603 *
06604       IF( UPLO .EQ. 'U' ) THEN
06605          IF( M .LE. N ) THEN
06606             IF( DIAG .EQ. 'U' ) THEN
06607                DO 41 I = 1, M
06608                   DO 42 J = 1, I
06609                      K = IPRE + I + (J-1)*LDA
06610                      MEM( K ) = CHECKVAL
06611    42             CONTINUE
06612    41          CONTINUE
06613             ELSE
06614                DO 43 I = 2, M
06615                   DO 44 J = 1, I-1
06616                      K = IPRE + I + (J-1)*LDA
06617                      MEM( K ) = CHECKVAL
06618    44             CONTINUE
06619    43          CONTINUE
06620             END IF
06621          ELSE
06622             IF( DIAG .EQ. 'U' ) THEN
06623                DO 45 I = M-N+1, M
06624                   DO 46 J = 1, I-(M-N)
06625                      K = IPRE + I + (J-1)*LDA
06626                      MEM( K ) = CHECKVAL
06627    46             CONTINUE
06628    45          CONTINUE
06629             ELSE
06630                DO 47 I = M-N+2, M
06631                   DO 48 J = 1, I-(M-N)-1
06632                      K = IPRE + I + (J-1)*LDA
06633                      MEM( K ) = CHECKVAL
06634    48             CONTINUE
06635    47          CONTINUE
06636             END IF
06637          END IF
06638       ELSE IF( UPLO .EQ. 'L' ) THEN
06639          IF( M .LE. N ) THEN
06640             IF( DIAG .EQ. 'U' ) THEN
06641                DO 49 I = 1, M
06642                   DO 50 J = N-M+I, N
06643                      K = IPRE + I + (J-1)*LDA
06644                      MEM( K ) = CHECKVAL
06645    50             CONTINUE
06646    49          CONTINUE
06647             ELSE
06648                DO 51 I = 1, M-1
06649                   DO 52 J = N-M+I+1, N
06650                      K = IPRE + I + (J-1)*LDA
06651                      MEM( K ) = CHECKVAL
06652    52             CONTINUE
06653    51          CONTINUE
06654             END IF
06655          ELSE
06656             IF( UPLO .EQ. 'U' ) THEN
06657                DO 53 I = 1, N
06658                   DO 54 J = I, N
06659                      K = IPRE + I + (J-1)*LDA
06660                      MEM( K ) = CHECKVAL
06661    54             CONTINUE
06662    53          CONTINUE
06663             ELSE
06664                DO 55 I = 1, N-1
06665                   DO 56 J = I+1, N
06666                      K = IPRE + I + (J-1)*LDA
06667                      MEM( K ) = CHECKVAL
06668    56             CONTINUE
06669    55          CONTINUE
06670             END IF
06671          END IF
06672       END IF
06673 *
06674 *     End of IPADMAT.
06675 *
06676       RETURN
06677       END
06678 *
06679       SUBROUTINE ICHKPAD( UPLO, DIAG, M, N, MEM, LDA, RSRC, CSRC,
06680      $                    MYROW, MYCOL, IPRE, IPOST, CHECKVAL,
06681      $                    TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF )
06682 *
06683 *  -- BLACS tester (version 1.0) --
06684 *  University of Tennessee
06685 *  December 15, 1994
06686 *
06687 *
06688 *     .. Scalar Arguments ..
06689       CHARACTER*1 UPLO, DIAG
06690       INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, IPRE, IPOST
06691       INTEGER TESTNUM, MAXERR, NERR
06692       INTEGER CHECKVAL
06693 *     ..
06694 *     .. Array Arguments ..
06695       INTEGER ERRIBUF(6, MAXERR)
06696       INTEGER MEM(*), ERRDBUF(2, MAXERR)
06697 *     ..
06698 *
06699 *  Purpose
06700 *  =======
06701 *  ICHKPAD: Check padding put in by PADMAT.
06702 *  Checks that padding around target matrix has not been overwritten
06703 *  by the previous point-to-point or broadcast send.
06704 *
06705 *  Arguments
06706 *  =========
06707 *  UPLO     (input) CHARACTER*1
06708 *           Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
06709 *           rectangular?
06710 *
06711 *  DIAG     (input) CHARACTER*1
06712 *           For trapezoidal matrices, is the main diagonal included
06713 *           ('N') or not ('U')?
06714 *
06715 *   M       (input) INTEGER
06716 *           The number of rows of the matrix A.  M >= 0.
06717 *
06718 *   N       (input) INTEGER
06719 *           The number of columns of the matrix A.  N >= 0.
06720 *
06721 *  MEM       (input) integer array, dimension(IPRE+IPOST+LDA*N).
06722 *            Memory location IPRE elements in front of the matrix A.
06723 *
06724 *   LDA     (input) INTEGER
06725 *           The leading dimension of the array A.  LDA >= max(1, M).
06726 *
06727 *  RSRC     (input) INTEGER
06728 *           The process row of the source of the matrix.
06729 *
06730 *  CSRC     (input) INTEGER
06731 *           The process column of the source of the matrix.
06732 *
06733 *  MYROW    (input) INTEGER
06734 *           Row of this process in the process grid.
06735 *
06736 *  MYCOL    (input) INTEGER
06737 *           Column of this process in the process grid.
06738 *
06739 *  IPRE     (input) INTEGER
06740 *           The size of the guard zone before the start of A.
06741 *
06742 *  IPOST    (input) INTEGER
06743 *           The size of guard zone after A.
06744 *
06745 *  CHECKVAL (input) integer
06746 *           The value to pad matrix with.
06747 *
06748 *  TESTNUM  (input) INTEGER
06749 *           The number of the test being checked.
06750 *
06751 *  MAXERR   (input) INTEGER
06752 *           Max number of errors that can be stored in ERRIBUFF or
06753 *           ERRIBUFF
06754 *
06755 *  NERR     (output) INTEGER
06756 *           The number of errors that have been found.
06757 *
06758 *  ERRIBUF  (output) INTEGER array, dimension (6,MAXERRS)
06759 *           Buffer in which to store integer error information.  It will
06760 *           be built up in the following format for the call to TSEND.
06761 *           All integer information is recorded in the following 6-tuple
06762 *           {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
06763 *             SRC = RSRC * NPROCS + CSRC
06764 *             DEST = RDEST * NPROCS + CDEST
06765 *             WHAT
06766 *              = 1 : Error in pre-padding
06767 *              = 2 : Error in post-padding
06768 *              = 3 : Error in LDA-M gap
06769 *              = 4 : Error in complementory triangle
06770 *              ELSE: Error in matrix
06771 *           If there are more errors than can fit in the error buffer,
06772 *           the error number will indicate the actual number of errors
06773 *           found, but the buffer will be truncated to the maximum
06774 *           number of errors which can fit.
06775 *
06776 *  ERRDBUF  (output) @(doctype) array, dimension (2, MAXERRS)
06777 *           Buffer in which to store error data information.
06778 *           {Incorrect, Predicted}
06779 *
06780 *  ===================================================================
06781 *
06782 *     .. Parameters ..
06783       INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
06784       PARAMETER( ERR_PRE = 1, ERR_POST = 2, ERR_GAP = 3, ERR_TRI = 4 )
06785       PARAMETER( ERR_MAT = 5 )
06786 *     ..
06787 *     .. External Functions ..
06788       INTEGER IBTNPROCS
06789       EXTERNAL IBTNPROCS
06790 *     ..
06791 *     .. Local Scalars ..
06792       LOGICAL ISTRAP
06793       INTEGER I, J, K, IRST, IRND, ICST, ICND, SRC, DEST
06794       INTEGER NPROCS
06795 *     ..
06796 *     .. Executable Statements ..
06797 *
06798       NPROCS = IBTNPROCS()
06799       SRC = RSRC * NPROCS + CSRC
06800       DEST = MYROW * NPROCS + MYCOL
06801 *
06802 *     Check buffer in front of A
06803 *
06804       IF( IPRE .GT. 0 ) THEN
06805          DO 10 I = 1, IPRE
06806             IF( MEM(I) .NE. CHECKVAL ) THEN
06807                NERR = NERR + 1
06808                IF( NERR .LE. MAXERR ) THEN
06809                   ERRIBUF(1, NERR) = TESTNUM
06810                   ERRIBUF(2, NERR) = SRC
06811                   ERRIBUF(3, NERR) = DEST
06812                   ERRIBUF(4, NERR) = I
06813                   ERRIBUF(5, NERR) = IPRE - I + 1
06814                   ERRIBUF(6, NERR) = ERR_PRE
06815                   ERRDBUF(1, NERR) = MEM(I)
06816                   ERRDBUF(2, NERR) = CHECKVAL
06817                END IF
06818             END IF
06819    10    CONTINUE
06820       END IF
06821 *
06822 *     Check buffer behind A
06823 *
06824       IF( IPOST .GT. 0 ) THEN
06825          J = IPRE + LDA*N + 1
06826          DO 20 I = J, J+IPOST-1
06827             IF( MEM(I) .NE. CHECKVAL ) THEN
06828                NERR = NERR + 1
06829                IF( NERR .LE. MAXERR ) THEN
06830                   ERRIBUF(1, NERR) = TESTNUM
06831                   ERRIBUF(2, NERR) = SRC
06832                   ERRIBUF(3, NERR) = DEST
06833                   ERRIBUF(4, NERR) = I - J + 1
06834                   ERRIBUF(5, NERR) = J
06835                   ERRIBUF(6, NERR) = ERR_POST
06836                   ERRDBUF(1, NERR) = MEM(I)
06837                   ERRDBUF(2, NERR) = CHECKVAL
06838                END IF
06839             END IF
06840    20    CONTINUE
06841       END IF
06842 *
06843 *     Check all (LDA-M) gaps
06844 *
06845       IF( LDA .GT. M ) THEN
06846          DO 40 J = 1, N
06847             DO 30 I = M+1, LDA
06848                K = IPRE + (J-1)*LDA + I
06849                IF( MEM(K) .NE. CHECKVAL) THEN
06850                   NERR = NERR + 1
06851                   IF( NERR .LE. MAXERR ) THEN
06852                      ERRIBUF(1, NERR) = TESTNUM
06853                      ERRIBUF(2, NERR) = SRC
06854                      ERRIBUF(3, NERR) = DEST
06855                      ERRIBUF(4, NERR) = I
06856                      ERRIBUF(5, NERR) = J
06857                      ERRIBUF(6, NERR) = ERR_GAP
06858                      ERRDBUF(1, NERR) = MEM(K)
06859                      ERRDBUF(2, NERR) = CHECKVAL
06860                   END IF
06861                END IF
06862    30       CONTINUE
06863    40    CONTINUE
06864       END IF
06865 *
06866 *     Determine limits of trapezoidal matrix
06867 *
06868       ISTRAP = .FALSE.
06869       IF( UPLO .EQ. 'U' ) THEN
06870          ISTRAP = .TRUE.
06871          IF( M .LE. N ) THEN
06872             IRST = 2
06873             IRND = M
06874             ICST = 1
06875             ICND = M - 1
06876          ELSEIF( M .GT. N ) THEN
06877             IRST = ( M-N ) + 2
06878             IRND = M
06879             ICST = 1
06880             ICND = N - 1
06881          ENDIF
06882          IF( DIAG .EQ. 'U' ) THEN
06883             IRST = IRST - 1
06884             ICND = ICND + 1
06885          ENDIF
06886       ELSE IF( UPLO .EQ. 'L' ) THEN
06887          ISTRAP = .TRUE.
06888          IF( M .LE. N ) THEN
06889             IRST = 1
06890             IRND = 1
06891             ICST = ( N-M ) + 2
06892             ICND = N
06893          ELSEIF( M .GT. N ) THEN
06894             IRST = 1
06895             IRND = 1
06896             ICST = 2
06897             ICND = N
06898          ENDIF
06899          IF( DIAG .EQ. 'U' ) THEN
06900             ICST = ICST - 1
06901          ENDIF
06902       ENDIF
06903 *
06904 *     Check elements and report any errors
06905 *
06906       IF( ISTRAP ) THEN
06907          DO 100 J = ICST, ICND
06908             DO 105 I = IRST, IRND
06909                IF( MEM( IPRE + (J-1)*LDA + I ) .NE. CHECKVAL ) THEN
06910                   NERR = NERR + 1
06911                   IF( NERR .LE. MAXERR ) THEN
06912                      ERRIBUF(1, NERR) = TESTNUM
06913                      ERRIBUF(2, NERR) = SRC
06914                      ERRIBUF(3, NERR) = DEST
06915                      ERRIBUF(4, NERR) = I
06916                      ERRIBUF(5, NERR) = J
06917                      ERRIBUF(6, NERR) = ERR_TRI
06918                      ERRDBUF(1, NERR) = MEM( IPRE + (J-1)*LDA + I )
06919                      ERRDBUF(2, NERR) = CHECKVAL
06920                   END IF
06921                END IF
06922   105       CONTINUE
06923 *
06924 *           Update the limits to allow filling in padding
06925 *
06926             IF( UPLO .EQ. 'U' ) THEN
06927                IRST = IRST + 1
06928             ELSE
06929                IRND = IRND + 1
06930             ENDIF
06931   100    CONTINUE
06932       END IF
06933 *
06934       RETURN
06935 *
06936 *     End of ICHKPAD.
06937 *
06938       END
06939 *
06940       SUBROUTINE ICHKMAT( UPLO, DIAG, M, N, A, LDA, RSRC, CSRC,
06941      $                    MYROW, MYCOL, TESTNUM, MAXERR, NERR,
06942      $                    ERRIBUF, ERRDBUF )
06943 *
06944 *  -- BLACS tester (version 1.0) --
06945 *  University of Tennessee
06946 *  December 15, 1994
06947 *
06948 *
06949 *     .. Scalar Arguments ..
06950       CHARACTER*1 UPLO, DIAG
06951       INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, TESTNUM
06952       INTEGER MAXERR, NERR
06953 *     ..
06954 *     .. Array Arguments ..
06955       INTEGER ERRIBUF(6, MAXERR)
06956       INTEGER A(LDA,N), ERRDBUF(2, MAXERR)
06957 *     ..
06958 *
06959 *  Purpose
06960 *  =======
06961 *  iCHKMAT:  Check matrix to see whether there were any transmission
06962 *            errors.
06963 *
06964 *  Arguments
06965 *  =========
06966 *  UPLO     (input) CHARACTER*1
06967 *           Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
06968 *           rectangular?
06969 *
06970 *  DIAG     (input) CHARACTER*1
06971 *           For trapezoidal matrices, is the main diagonal included
06972 *           ('N') or not ('U')?
06973 *
06974 *   M       (input) INTEGER
06975 *           The number of rows of the matrix A.  M >= 0.
06976 *
06977 *   N       (input) INTEGER
06978 *           The number of columns of the matrix A.  N >= 0.
06979 *
06980 *   A       (input) @up@(doctype) array, dimension (LDA,N)
06981 *           The m by n matrix A.  Fortran77 (column-major) storage
06982 *           assumed.
06983 *
06984 *   LDA     (input) INTEGER
06985 *           The leading dimension of the array A.  LDA >= max(1, M).
06986 *
06987 *  RSRC     (input) INTEGER
06988 *           The process row of the source of the matrix.
06989 *
06990 *  CSRC     (input) INTEGER
06991 *           The process column of the source of the matrix.
06992 *
06993 *  MYROW    (input) INTEGER
06994 *           Row of this process in the process grid.
06995 *
06996 *  MYCOL    (input) INTEGER
06997 *           Column of this process in the process grid.
06998 *
06999 *
07000 *  TESTNUM  (input) INTEGER
07001 *           The number of the test being checked.
07002 *
07003 *  MAXERR   (input) INTEGER
07004 *           Max number of errors that can be stored in ERRIBUFF or
07005 *           ERRIBUFF
07006 *
07007 *  NERR     (output) INTEGER
07008 *           The number of errors that have been found.
07009 *
07010 *  ERRIBUF  (output) INTEGER array, dimension (6,MAXERRS)
07011 *           Buffer in which to store integer error information.  It will
07012 *           be built up in the following format for the call to TSEND.
07013 *           All integer information is recorded in the following 6-tuple
07014 *           {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
07015 *             SRC = RSRC * NPROCS + CSRC
07016 *             DEST = RDEST * NPROCS + CDEST
07017 *             WHAT
07018 *              = 1 : Error in pre-padding
07019 *              = 2 : Error in post-padding
07020 *              = 3 : Error in LDA-M gap
07021 *              = 4 : Error in complementory triangle
07022 *              ELSE: Error in matrix
07023 *           If there are more errors than can fit in the error buffer,
07024 *           the error number will indicate the actual number of errors
07025 *           found, but the buffer will be truncated to the maximum
07026 *           number of errors which can fit.
07027 *
07028 *  ERRDBUF  (output) @(doctype) array, dimension (2, MAXERRS)
07029 *           Buffer in which to store error data information.
07030 *           {Incorrect, Predicted}
07031 *
07032 *  ===================================================================
07033 *
07034 *     .. Local Scalars ..
07035       INTEGER I, J, NPROCS, SRC, DEST
07036       LOGICAL USEIT
07037       INTEGER COMPVAL
07038 *     ..
07039 *     .. Local Arrays ..
07040       INTEGER ISEED(4)
07041 *     ..
07042 *     .. External Functions ..
07043       INTEGER IBTNPROCS
07044       INTEGER IBTRAN
07045       EXTERNAL IBTRAN, IBTNPROCS
07046 *     ..
07047 *     .. Executable Statements ..
07048 *
07049       NPROCS = IBTNPROCS()
07050       SRC = RSRC * NPROCS + CSRC
07051       DEST = MYROW * NPROCS + MYCOL
07052 *
07053 *     Initialize ISEED with the same values as used in IGENMAT.
07054 *
07055       ISEED(1) = MOD( 1002 + TESTNUM*5 + SRC*3, 4096 )
07056       ISEED(2) = MOD( 2027 + TESTNUM*7 + SRC, 4096 )
07057       ISEED(3) = MOD( 1234 + TESTNUM + SRC*3, 4096 )
07058       ISEED(4) = MOD( 4311 + TESTNUM*10 + SRC*2, 4096 )
07059 *
07060 *     Generate the elements randomly with the same method used in GENMAT.
07061 *     Note that for trapezoidal matrices, we generate all elements in the
07062 *     enclosing rectangle and then ignore the complementary triangle.
07063 *
07064       DO 100 J = 1, N
07065          DO 105 I = 1, M
07066             COMPVAL = IBTRAN( ISEED )
07067 *
07068 *           Now determine whether we actually need this value.  The
07069 *           strategy is to chop out the proper triangle based on what
07070 *           particular kind of trapezoidal matrix we're dealing with.
07071 *
07072             USEIT = .TRUE.
07073             IF( UPLO .EQ. 'U' ) THEN
07074                IF( M .LE. N ) THEN
07075                   IF( DIAG .EQ. 'U' ) THEN
07076                      IF( I .GE. J ) THEN
07077                         USEIT = .FALSE.
07078                      END IF
07079                   ELSE
07080                      IF( I .GT. J ) THEN
07081                         USEIT = .FALSE.
07082                      END IF
07083                   END IF
07084                ELSE
07085                   IF( DIAG .EQ. 'U' ) THEN
07086                      IF( I .GE. M-N+J ) THEN
07087                         USEIT = .FALSE.
07088                      END IF
07089                   ELSE
07090                      IF( I .GT. M-N+J ) THEN
07091                         USEIT = .FALSE.
07092                      END IF
07093                   END IF
07094                END IF
07095             ELSE IF( UPLO .EQ. 'L' ) THEN
07096                IF( M .LE. N ) THEN
07097                   IF( DIAG .EQ. 'U' ) THEN
07098                      IF( J. GE. I+(N-M) ) THEN
07099                         USEIT = .FALSE.
07100                      END IF
07101                   ELSE
07102                      IF( J .GT. I+(N-M) ) THEN
07103                         USEIT = .FALSE.
07104                      END IF
07105                   END IF
07106                ELSE
07107                   IF( DIAG .EQ. 'U' ) THEN
07108                      IF( J .GE. I ) THEN
07109                         USEIT = .FALSE.
07110                      END IF
07111                   ELSE
07112                      IF( J .GT. I ) THEN
07113                         USEIT = .FALSE.
07114                      END IF
07115                   END IF
07116                END IF
07117             END IF
07118 *
07119 *           Compare the generated value to the one that's in the
07120 *           received matrix.  If they don't match, tack another
07121 *           error record onto what's already there.
07122 *
07123             IF( USEIT ) THEN
07124                IF( A(I,J) .NE. COMPVAL ) THEN
07125                   NERR = NERR + 1
07126                   IF( NERR .LE. MAXERR ) THEN
07127                      ERRIBUF(1, NERR) = TESTNUM
07128                      ERRIBUF(2, NERR) = SRC
07129                      ERRIBUF(3, NERR) = DEST
07130                      ERRIBUF(4, NERR) = I
07131                      ERRIBUF(5, NERR) = J
07132                      ERRIBUF(6, NERR) = 5
07133                      ERRDBUF(1, NERR) = A(I, J)
07134                      ERRDBUF(2, NERR) = COMPVAL
07135                   END IF
07136                END IF
07137             END IF
07138   105    CONTINUE
07139   100 CONTINUE
07140       RETURN
07141 *
07142 *     End of ICHKMAT.
07143 *
07144       END
07145 *
07146       SUBROUTINE IPRINTERRS( OUTNUM, MAXERR, NERR,
07147      $                       ERRIBUF, ERRDBUF, COUNTING, TFAILED )
07148 *
07149 *  -- BLACS tester (version 1.0) --
07150 *  University of Tennessee
07151 *  December 15, 1994
07152 *
07153 *
07154 *     .. Scalar Arguments ..
07155       LOGICAL COUNTING
07156       INTEGER OUTNUM, MAXERR, NERR
07157 *     ..
07158 *     .. Array Arguments ..
07159       INTEGER ERRIBUF(6, MAXERR), TFAILED(*)
07160       INTEGER ERRDBUF(2, MAXERR)
07161 *     ..
07162 *
07163 *  Purpose
07164 *  =======
07165 *  IPRINTERRS: Print errors that have been recorded
07166 *
07167 *  Arguments
07168 *  =========
07169 *  OUTNUM   (input) INTEGER
07170 *           Device number for output.
07171 *
07172 *  MAXERR   (input) INTEGER
07173 *           Max number of errors that can be stored in ERRIBUFF or
07174 *           ERRIBUFF
07175 *
07176 *  NERR     (output) INTEGER
07177 *           The number of errors that have been found.
07178 *
07179 *  ERRIBUF  (output) INTEGER array, dimension (6,MAXERRS)
07180 *           Buffer in which to store integer error information.  It will
07181 *           be built up in the following format for the call to TSEND.
07182 *           All integer information is recorded in the following 6-tuple
07183 *           {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
07184 *             SRC = RSRC * NPROCS + CSRC
07185 *             DEST = RDEST * NPROCS + CDEST
07186 *             WHAT
07187 *              = 1 : Error in pre-padding
07188 *              = 2 : Error in post-padding
07189 *              = 3 : Error in LDA-M gap
07190 *              = 4 : Error in complementory triangle
07191 *              ELSE: Error in matrix
07192 *           If there are more errors than can fit in the error buffer,
07193 *           the error number will indicate the actual number of errors
07194 *           found, but the buffer will be truncated to the maximum
07195 *           number of errors which can fit.
07196 *
07197 *  ERRDBUF  (output) @(doctype) array, dimension (2, MAXERRS)
07198 *           Buffer in which to store error data information.
07199 *           {Incorrect, Predicted}
07200 *
07201 *  TFAILED (input/ourput) INTEGER array, dimension NTESTS
07202 *          Workspace used to keep track of which tests failed.
07203 *          This array not accessed unless COUNTING is true.
07204 *
07205 *  ===================================================================
07206 *
07207 *     .. Parameters ..
07208       INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
07209       PARAMETER( ERR_PRE = 1, ERR_POST = 2, ERR_GAP = 3, ERR_TRI = 4 )
07210       PARAMETER( ERR_MAT = 5 )
07211 *     ..
07212 *     .. External Functions ..
07213       INTEGER IBTMYPROC, IBTNPROCS
07214       EXTERNAL IBTMYPROC, IBTNPROCS
07215 *     ..
07216 *     .. Local Scalars ..
07217       CHARACTER*1 MAT
07218       LOGICAL MATISINT
07219       INTEGER OLDTEST, NPROCS, PROW, PCOL, I, ERRTYPE
07220 *     ..
07221 *     .. Executable Statements ..
07222 *
07223       IF( (IBTMYPROC().NE.0) .OR. (NERR.LE.0) ) RETURN
07224       OLDTEST = -1
07225       NPROCS = IBTNPROCS()
07226       PROW = ERRIBUF(3,1) / NPROCS
07227       PCOL = MOD( ERRIBUF(3,1), NPROCS )
07228       IF( NERR .GT. MAXERR ) WRITE(OUTNUM,13000)
07229 *
07230       DO 20 I = 1, MIN( NERR, MAXERR )
07231          IF( ERRIBUF(1,I) .NE. OLDTEST ) THEN
07232             IF( OLDTEST .NE. -1 )
07233      $         WRITE(OUTNUM,12000) PROW, PCOL, OLDTEST
07234             WRITE(OUTNUM,*) '  '
07235             WRITE(OUTNUM,1000) PROW, PCOL, ERRIBUF(1,I)
07236             IF( COUNTING ) TFAILED( ERRIBUF(1,I) ) = 1
07237             OLDTEST = ERRIBUF(1, I)
07238          END IF
07239 *
07240 *        Print out error message depending on type of error
07241 *
07242          ERRTYPE = ERRIBUF(6, I)
07243          IF( ERRTYPE .LT. -10 ) THEN
07244             ERRTYPE = -ERRTYPE - 10
07245             MAT = 'C'
07246             MATISINT = .TRUE.
07247          ELSE IF( ERRTYPE .LT. 0 ) THEN
07248             ERRTYPE = -ERRTYPE
07249             MAT = 'R'
07250             MATISINT = .TRUE.
07251          ELSE
07252             MATISINT = .FALSE.
07253          END IF
07254 *
07255 *        RA/CA arrays from MAX/MIN have different printing protocol
07256 *
07257          IF( MATISINT ) THEN
07258             IF( ERRIBUF(2, I) .EQ. -1 ) THEN
07259                WRITE(OUTNUM,11000) ERRIBUF(4,I), ERRIBUF(5,I), MAT,
07260      $            INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) )
07261             ELSE IF( ERRTYPE .EQ. ERR_PRE ) THEN
07262                WRITE(OUTNUM,7000) ERRIBUF(5,I), MAT,
07263      $            INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) )
07264             ELSE IF( ERRTYPE .EQ. ERR_POST ) THEN
07265                WRITE(OUTNUM,8000) ERRIBUF(4,I), MAT,
07266      $            INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) )
07267             ELSE IF( ERRTYPE .EQ. ERR_GAP ) THEN
07268                WRITE(OUTNUM,9000) MAT, ERRIBUF(4,I), ERRIBUF(5,I),
07269      $            INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) )
07270             ELSE
07271                WRITE(OUTNUM,10000) MAT, ERRIBUF(4,I), ERRIBUF(5,I),
07272      $                             INT( ERRDBUF(2,I) ),
07273      $                             INT( ERRDBUF(1,I) )
07274             END IF
07275 *
07276 *        Have memory overwrites in matrix A
07277 *
07278          ELSE
07279             IF( ERRTYPE .EQ. ERR_PRE ) THEN
07280                WRITE(OUTNUM,2000) ERRIBUF(5,I), ERRDBUF(2,I),
07281      $                            ERRDBUF(1,I)
07282             ELSE IF( ERRTYPE .EQ. ERR_POST ) THEN
07283                WRITE(OUTNUM,3000) ERRIBUF(4,I), ERRDBUF(2,I),
07284      $                            ERRDBUF(1,I)
07285             ELSE IF( ERRTYPE .EQ. ERR_GAP ) THEN
07286                WRITE(OUTNUM,4000) ERRIBUF(4,I), ERRIBUF(5,I),
07287      $                            ERRDBUF(2,I), ERRDBUF(1,I)
07288             ELSE IF( ERRTYPE .EQ. ERR_TRI ) THEN
07289                WRITE(OUTNUM,5000) ERRIBUF(4,I), ERRIBUF(5,I),
07290      $                            ERRDBUF(2,I), ERRDBUF(1,I)
07291             ELSE
07292                WRITE(OUTNUM,6000) ERRIBUF(4,I), ERRIBUF(5,I),
07293      $                            ERRDBUF(2,I), ERRDBUF(1,I)
07294             END IF
07295          END IF
07296    20 CONTINUE
07297       WRITE(OUTNUM,12000) PROW, PCOL, OLDTEST
07298 *
07299  1000 FORMAT('PROCESS {',I4,',',I4,'} REPORTS ERRORS IN TEST#',I6,':')
07300  2000 FORMAT('   Buffer overwrite ',I4,
07301      $       ' elements before the start of A:',/,
07302      $       '   Expected=',I12,
07303      $       '; Received=',I12)
07304  3000 FORMAT('   Buffer overwrite ',I4,' elements after the end of A:',
07305      $       /,'   Expected=',I12,
07306      $       '; Received=',I12)
07307  4000 FORMAT('   LDA-M gap overwrite at postion (',I4,',',I4,'):',/,
07308      $       '   Expected=',I12,
07309      $       '; Received=',I12)
07310  5000 FORMAT('   Complementory triangle overwrite at A(',I4,',',I4,
07311      $       '):',/,'   Expected=',I12,
07312      $       '; Received=',I12)
07313  6000 FORMAT('   Invalid element at A(',I4,',',I4,'):',/,
07314      $       '   Expected=',I12,
07315      $       '; Received=',I12)
07316  7000 FORMAT('   Buffer overwrite ',I4,' elements before the start of ',
07317      $       A1,'A:',/,'   Expected=',I12,'; Received=',I12)
07318  8000 FORMAT('   Buffer overwrite ',I4,' elements after the end of ',
07319      $       A1,'A:',/,'   Expected=',I12,'; Received=',I12)
07320 *
07321  9000 FORMAT('   LD',A1,'A-M gap overwrite at postion (',I4,',',I4,'):'
07322      $       ,/,'   Expected=',I12,'; Received=',I12)
07323 *
07324 10000 FORMAT('   Invalid element at ',A1,'A(',I4,',',I4,'):',/,
07325      $       '   Expected=',I12,'; Received=',I12)
07326 11000 FORMAT('   Overwrite at position (',I4,',',I4,') of non-existent '
07327      $       ,A1,'A array.',/,'   Expected=',I12,'; Received=',I12)
07328 12000 FORMAT('PROCESS {',I4,',',I4,'} DONE ERROR REPORT FOR TEST#',
07329      $       I6,'.')
07330 13000 FORMAT('WARNING: There were more errors than could be recorded.',
07331      $       /,'Increase MEMELTS to get complete listing.')
07332       RETURN
07333 *
07334 *     End IPRINTERRS
07335 *
07336       END
07337 *
07338 *
07339       SUBROUTINE SBTCHECKIN( NFTESTS, OUTNUM, MAXERR, NERR, IERR,
07340      $                       SVAL, TFAILED )
07341       INTEGER NFTESTS, OUTNUM, MAXERR, NERR
07342       INTEGER IERR(*), TFAILED(*)
07343       REAL SVAL(*)
07344 *
07345 *  Purpose
07346 *  =======
07347 *  SBTCHECKIN: Process 0 receives error report from all processes.
07348 *
07349 *  Arguments
07350 *  =========
07351 *  NFTESTS  (input/output) INTEGER
07352 *           if NFTESTS is <= 0 upon entry, NFTESTS is not written to.
07353 *           Otherwise, on entry it specifies the total number of tests
07354 *           run, and on exit it is the number of tests which failed.
07355 *
07356 *  OUTNUM   (input) INTEGER
07357 *           Device number for output.
07358 *
07359 *  MAXERR   (input) INTEGER
07360 *           Max number of errors that can be stored in ERRIBUFF or
07361 *           ERRSBUFF
07362 *
07363 *  NERR     (output) INTEGER
07364 *           The number of errors that have been found.
07365 *
07366 *  ERRIBUF  (output) INTEGER array, dimension (6,MAXERRS)
07367 *           Buffer in which to store integer error information.  It will
07368 *           be built up in the following format for the call to TSEND.
07369 *           All integer information is recorded in the following 6-tuple
07370 *           {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
07371 *             SRC = RSRC * NPROCS + CSRC
07372 *             DEST = RDEST * NPROCS + CDEST
07373 *             WHAT
07374 *              = 1 : Error in pre-padding
07375 *              = 2 : Error in post-padding
07376 *              = 3 : Error in LDA-M gap
07377 *              = 4 : Error in complementory triangle
07378 *              ELSE: Error in matrix
07379 *           If there are more errors than can fit in the error buffer,
07380 *           the error number will indicate the actual number of errors
07381 *           found, but the buffer will be truncated to the maximum
07382 *           number of errors which can fit.
07383 *
07384 *  ERRDBUF  (output) @(doctype) array, dimension (2, MAXERRS)
07385 *           Buffer in which to store error data information.
07386 *           {Incorrect, Predicted}
07387 *
07388 *  TFAILED (workspace) INTEGER array, dimension NFTESTS
07389 *          Workspace used to keep track of which tests failed.
07390 *          If input of NFTESTS < 1, this array not accessed.
07391 *
07392 *  ===================================================================
07393 *
07394 *     .. External Functions ..
07395       INTEGER  IBTMYPROC, IBTNPROCS, IBTMSGID
07396       EXTERNAL IBTMYPROC, IBTNPROCS, IBTMSGID
07397 *     ..
07398 *     .. Local Scalars ..
07399       LOGICAL COUNTING
07400       INTEGER K, NERR2, IAM, NPROCS, NTESTS
07401 *
07402 *     Proc 0 collects error info from everyone
07403 *
07404       IAM = IBTMYPROC()
07405       NPROCS = IBTNPROCS()
07406 *
07407       IF( IAM .EQ. 0 ) THEN
07408 *
07409 *        If we are finding out how many failed tests there are, initialize
07410 *        the total number of tests (NTESTS), and zero the test failed array
07411 *
07412          COUNTING = NFTESTS .GT. 0
07413          IF( COUNTING ) THEN
07414             NTESTS = NFTESTS
07415             DO 10 K = 1, NTESTS
07416                TFAILED(K) = 0
07417    10       CONTINUE
07418          END IF
07419 *
07420          CALL SPRINTERRS(OUTNUM, MAXERR, NERR, IERR, SVAL, COUNTING,
07421      $                   TFAILED)
07422 *
07423          DO 20 K = 1, NPROCS-1
07424             CALL BTSEND(3, 0, K, K, IBTMSGID()+50)
07425             CALL BTRECV(3, 1, NERR2, K, IBTMSGID()+50)
07426             IF( NERR2 .GT. 0 ) THEN
07427                NERR = NERR + NERR2
07428                CALL BTRECV(3, NERR2*6, IERR, K, IBTMSGID()+51)
07429                CALL BTRECV(4, NERR2*2, SVAL, K, IBTMSGID()+51)
07430                CALL SPRINTERRS(OUTNUM, MAXERR, NERR2, IERR, SVAL,
07431      $                         COUNTING, TFAILED)
07432             END IF
07433    20    CONTINUE
07434 *
07435 *        Count up number of tests that failed
07436 *
07437          IF( COUNTING ) THEN
07438             NFTESTS = 0
07439             DO 30 K = 1, NTESTS
07440                NFTESTS = NFTESTS + TFAILED(K)
07441    30       CONTINUE
07442          END IF
07443 *
07444 *     Send my error info to proc 0
07445 *
07446       ELSE
07447          CALL BTRECV(3, 0, K, 0, IBTMSGID()+50)
07448          CALL BTSEND(3, 1, NERR, 0, IBTMSGID()+50)
07449          IF( NERR .GT. 0 ) THEN
07450             CALL BTSEND(3, NERR*6, IERR, 0, IBTMSGID()+51)
07451             CALL BTSEND(4, NERR*2, SVAL, 0, IBTMSGID()+51)
07452          END IF
07453       ENDIF
07454 *
07455       RETURN
07456 *
07457 *     End of SBTCHECKIN
07458 *
07459       END
07460 *
07461       SUBROUTINE SINITMAT(UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST,
07462      $                    CHECKVAL, TESTNUM, MYROW, MYCOL)
07463       CHARACTER*1 UPLO, DIAG
07464       INTEGER M, N, LDA, IPRE, IPOST, TESTNUM, MYROW, MYCOL
07465       REAL CHECKVAL
07466       REAL MEM(*)
07467 *
07468 *     .. External Subroutines ..
07469       EXTERNAL SGENMAT, SPADMAT
07470 *     ..
07471 *     .. Executable Statements ..
07472 *
07473       CALL SGENMAT( M, N, MEM(IPRE+1), LDA, TESTNUM, MYROW, MYCOL )
07474       CALL SPADMAT( UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST, CHECKVAL )
07475 *
07476       RETURN
07477       END
07478 *
07479       SUBROUTINE SGENMAT( M, N, A, LDA, TESTNUM, MYROW, MYCOL )
07480 *
07481 *  -- BLACS tester (version 1.0) --
07482 *  University of Tennessee
07483 *  December 15, 1994
07484 *
07485 *
07486 *     .. Scalar Arguments ..
07487       INTEGER M, N, LDA, TESTNUM, MYROW, MYCOL
07488 *     ..
07489 *     .. Array Arguments ..
07490       REAL A(LDA,N)
07491 *     ..
07492 *
07493 *  Purpose
07494 *  =======
07495 *  SGENMAT: Generates an M-by-N matrix filled with random elements.
07496 *
07497 *  Arguments
07498 *  =========
07499 *   M       (input) INTEGER
07500 *           The number of rows of the matrix A.  M >= 0.
07501 *
07502 *   N       (input) INTEGER
07503 *           The number of columns of the matrix A.  N >= 0.
07504 *
07505 *   A       (output) @up@(doctype) array, dimension (LDA,N)
07506 *           The m by n matrix A.  Fortran77 (column-major) storage
07507 *           assumed.
07508 *
07509 *   LDA     (input) INTEGER
07510 *           The leading dimension of the array A.  LDA >= max(1, M).
07511 *
07512 *  TESTNUM  (input) INTEGER
07513 *           Unique number for this test case, used as a basis for
07514 *           the random seeds.
07515 *
07516 *  ====================================================================
07517 *
07518 *     .. External Functions ..
07519       INTEGER IBTNPROCS
07520       REAL SBTRAN
07521       EXTERNAL SBTRAN, IBTNPROCS
07522 *     ..
07523 *     .. Local Scalars ..
07524       INTEGER I, J, NPROCS, SRC
07525 *     ..
07526 *     .. Local Arrays ..
07527       INTEGER ISEED(4)
07528 *     ..
07529 *     .. Executable Statements ..
07530 *
07531 *     ISEED's four values must be positive integers less than 4096,
07532 *     fourth one has to be odd. (see _LARND).  Use some goofy
07533 *     functions to come up with seed values which together should
07534 *     be unique.
07535 *
07536       NPROCS = IBTNPROCS()
07537       SRC = MYROW * NPROCS + MYCOL
07538       ISEED(1) = MOD( 1002 + TESTNUM*5 + SRC*3, 4096 )
07539       ISEED(2) = MOD( 2027 + TESTNUM*7 + SRC, 4096 )
07540       ISEED(3) = MOD( 1234 + TESTNUM + SRC*3, 4096 )
07541       ISEED(4) = MOD( 4311 + TESTNUM*10 + SRC*2, 4096 )
07542 *
07543       DO 10 J = 1, N
07544          DO 10 I = 1, M
07545             A(I, J) = SBTRAN( ISEED )
07546    10 CONTINUE
07547 *
07548       RETURN
07549 *
07550 *     End of SGENMAT.
07551 *
07552       END
07553 *
07554       REAL FUNCTION SBTRAN(ISEED)
07555       INTEGER ISEED(*)
07556 *
07557 *     .. External Functions ..
07558       DOUBLE PRECISION DLARND
07559       EXTERNAL DLARND
07560 *     .. Executable Statements ..
07561 *
07562       SBTRAN = REAL( DLARND(2, ISEED) )
07563 *
07564       RETURN
07565 *
07566 *     End of Sbtran
07567 *
07568       END
07569 *
07570       SUBROUTINE SPADMAT( UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST,
07571      $                    CHECKVAL )
07572 *
07573 *  -- BLACS tester (version 1.0) --
07574 *  University of Tennessee
07575 *  December 15, 1994
07576 *
07577 *     .. Scalar Arguments ..
07578       CHARACTER*1 UPLO, DIAG
07579       INTEGER M, N, LDA, IPRE, IPOST
07580       REAL CHECKVAL
07581 *     ..
07582 *     .. Array Arguments ..
07583       REAL MEM( * )
07584 *     ..
07585 *
07586 *  Purpose
07587 *  =======
07588 *
07589 *  SPADMAT: Pad Matrix.
07590 *  This routines surrounds a matrix with a guardzone initialized to the
07591 *  value CHECKVAL.  There are three distinct guardzones:
07592 *  - A contiguous zone of size IPRE immediately before the start
07593 *    of the matrix.
07594 *  - A contiguous zone of size IPOST immedately after the end of the
07595 *    matrix.
07596 *  - Interstitial zones within each column of the matrix, in the
07597 *    elements A( M+1:LDA, J ).
07598 *
07599 *  Arguments
07600 *  =========
07601 *  UPLO     (input) CHARACTER*1
07602 *           Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
07603 *           rectangular?
07604 *
07605 *  DIAG     (input) CHARACTER*1
07606 *           For trapezoidal matrices, is the main diagonal included
07607 *           ('N') or not ('U')?
07608 *
07609 *   M       (input) INTEGER
07610 *           The number of rows of the matrix A.  M >= 0.
07611 *
07612 *   N       (input) INTEGER
07613 *           The number of columns of the matrix A.  N >= 0.
07614 *
07615 *  MEM      (output) real array, dimension (IPRE+IPOST+LDA*N)
07616 *           The address IPRE elements ahead of the matrix A you want to
07617 *           pad, which is then of dimension (LDA,N).
07618 *
07619 *  IPRE     (input) INTEGER
07620 *           The size of the guard zone ahead of the matrix A.
07621 *
07622 *  IPOST    (input) INTEGER
07623 *           The size of the guard zone behind the matrix A.
07624 *
07625 *  CHECKVAL (input) real
07626 *           The value to insert into the guard zones.
07627 *
07628 *  ====================================================================
07629 *
07630 *     .. Local Scalars ..
07631       INTEGER I, J, K
07632 *     ..
07633 *     .. Executable Statements ..
07634 *
07635 *     Put check buffer in front of A
07636 *
07637       IF( IPRE .GT. 0 ) THEN
07638          DO 10 I = 1, IPRE
07639             MEM( I ) = CHECKVAL
07640    10    CONTINUE
07641       END IF
07642 *
07643 *     Put check buffer in back of A
07644 *
07645       IF( IPOST .GT. 0 ) THEN
07646          J = IPRE + LDA*N + 1
07647          DO 20 I = J, J+IPOST-1
07648             MEM( I ) = CHECKVAL
07649    20    CONTINUE
07650       END IF
07651 *
07652 *     Put check buffer in all (LDA-M) gaps
07653 *
07654       IF( LDA .GT. M ) THEN
07655          K = IPRE + M + 1
07656          DO 40 J = 1, N
07657             DO 30 I = K, K+LDA-M-1
07658                MEM( I ) = CHECKVAL
07659    30       CONTINUE
07660             K = K + LDA
07661    40    CONTINUE
07662       END IF
07663 *
07664 *     If the matrix is upper or lower trapezoidal, calculate the
07665 *     additional triangular area which needs to be padded,  Each
07666 *     element referred to is in the Ith row and the Jth column.
07667 *
07668       IF( UPLO .EQ. 'U' ) THEN
07669          IF( M .LE. N ) THEN
07670             IF( DIAG .EQ. 'U' ) THEN
07671                DO 41 I = 1, M
07672                   DO 42 J = 1, I
07673                      K = IPRE + I + (J-1)*LDA
07674                      MEM( K ) = CHECKVAL
07675    42             CONTINUE
07676    41          CONTINUE
07677             ELSE
07678                DO 43 I = 2, M
07679                   DO 44 J = 1, I-1
07680                      K = IPRE + I + (J-1)*LDA
07681                      MEM( K ) = CHECKVAL
07682    44             CONTINUE
07683    43          CONTINUE
07684             END IF
07685          ELSE
07686             IF( DIAG .EQ. 'U' ) THEN
07687                DO 45 I = M-N+1, M
07688                   DO 46 J = 1, I-(M-N)
07689                      K = IPRE + I + (J-1)*LDA
07690                      MEM( K ) = CHECKVAL
07691    46             CONTINUE
07692    45          CONTINUE
07693             ELSE
07694                DO 47 I = M-N+2, M
07695                   DO 48 J = 1, I-(M-N)-1
07696                      K = IPRE + I + (J-1)*LDA
07697                      MEM( K ) = CHECKVAL
07698    48             CONTINUE
07699    47          CONTINUE
07700             END IF
07701          END IF
07702       ELSE IF( UPLO .EQ. 'L' ) THEN
07703          IF( M .LE. N ) THEN
07704             IF( DIAG .EQ. 'U' ) THEN
07705                DO 49 I = 1, M
07706                   DO 50 J = N-M+I, N
07707                      K = IPRE + I + (J-1)*LDA
07708                      MEM( K ) = CHECKVAL
07709    50             CONTINUE
07710    49          CONTINUE
07711             ELSE
07712                DO 51 I = 1, M-1
07713                   DO 52 J = N-M+I+1, N
07714                      K = IPRE + I + (J-1)*LDA
07715                      MEM( K ) = CHECKVAL
07716    52             CONTINUE
07717    51          CONTINUE
07718             END IF
07719          ELSE
07720             IF( UPLO .EQ. 'U' ) THEN
07721                DO 53 I = 1, N
07722                   DO 54 J = I, N
07723                      K = IPRE + I + (J-1)*LDA
07724                      MEM( K ) = CHECKVAL
07725    54             CONTINUE
07726    53          CONTINUE
07727             ELSE
07728                DO 55 I = 1, N-1
07729                   DO 56 J = I+1, N
07730                      K = IPRE + I + (J-1)*LDA
07731                      MEM( K ) = CHECKVAL
07732    56             CONTINUE
07733    55          CONTINUE
07734             END IF
07735          END IF
07736       END IF
07737 *
07738 *     End of SPADMAT.
07739 *
07740       RETURN
07741       END
07742 *
07743       SUBROUTINE SCHKPAD( UPLO, DIAG, M, N, MEM, LDA, RSRC, CSRC,
07744      $                    MYROW, MYCOL, IPRE, IPOST, CHECKVAL,
07745      $                    TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF )
07746 *
07747 *  -- BLACS tester (version 1.0) --
07748 *  University of Tennessee
07749 *  December 15, 1994
07750 *
07751 *
07752 *     .. Scalar Arguments ..
07753       CHARACTER*1 UPLO, DIAG
07754       INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, IPRE, IPOST
07755       INTEGER TESTNUM, MAXERR, NERR
07756       REAL CHECKVAL
07757 *     ..
07758 *     .. Array Arguments ..
07759       INTEGER ERRIBUF(6, MAXERR)
07760       REAL MEM(*), ERRDBUF(2, MAXERR)
07761 *     ..
07762 *
07763 *  Purpose
07764 *  =======
07765 *  SCHKPAD: Check padding put in by PADMAT.
07766 *  Checks that padding around target matrix has not been overwritten
07767 *  by the previous point-to-point or broadcast send.
07768 *
07769 *  Arguments
07770 *  =========
07771 *  UPLO     (input) CHARACTER*1
07772 *           Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
07773 *           rectangular?
07774 *
07775 *  DIAG     (input) CHARACTER*1
07776 *           For trapezoidal matrices, is the main diagonal included
07777 *           ('N') or not ('U')?
07778 *
07779 *   M       (input) INTEGER
07780 *           The number of rows of the matrix A.  M >= 0.
07781 *
07782 *   N       (input) INTEGER
07783 *           The number of columns of the matrix A.  N >= 0.
07784 *
07785 *  MEM       (input) real array, dimension(IPRE+IPOST+LDA*N).
07786 *            Memory location IPRE elements in front of the matrix A.
07787 *
07788 *   LDA     (input) INTEGER
07789 *           The leading dimension of the array A.  LDA >= max(1, M).
07790 *
07791 *  RSRC     (input) INTEGER
07792 *           The process row of the source of the matrix.
07793 *
07794 *  CSRC     (input) INTEGER
07795 *           The process column of the source of the matrix.
07796 *
07797 *  MYROW    (input) INTEGER
07798 *           Row of this process in the process grid.
07799 *
07800 *  MYCOL    (input) INTEGER
07801 *           Column of this process in the process grid.
07802 *
07803 *  IPRE     (input) INTEGER
07804 *           The size of the guard zone before the start of A.
07805 *
07806 *  IPOST    (input) INTEGER
07807 *           The size of guard zone after A.
07808 *
07809 *  CHECKVAL (input) real
07810 *           The value to pad matrix with.
07811 *
07812 *  TESTNUM  (input) INTEGER
07813 *           The number of the test being checked.
07814 *
07815 *  MAXERR   (input) INTEGER
07816 *           Max number of errors that can be stored in ERRIBUFF or
07817 *           ERRSBUFF
07818 *
07819 *  NERR     (output) INTEGER
07820 *           The number of errors that have been found.
07821 *
07822 *  ERRIBUF  (output) INTEGER array, dimension (6,MAXERRS)
07823 *           Buffer in which to store integer error information.  It will
07824 *           be built up in the following format for the call to TSEND.
07825 *           All integer information is recorded in the following 6-tuple
07826 *           {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
07827 *             SRC = RSRC * NPROCS + CSRC
07828 *             DEST = RDEST * NPROCS + CDEST
07829 *             WHAT
07830 *              = 1 : Error in pre-padding
07831 *              = 2 : Error in post-padding
07832 *              = 3 : Error in LDA-M gap
07833 *              = 4 : Error in complementory triangle
07834 *              ELSE: Error in matrix
07835 *           If there are more errors than can fit in the error buffer,
07836 *           the error number will indicate the actual number of errors
07837 *           found, but the buffer will be truncated to the maximum
07838 *           number of errors which can fit.
07839 *
07840 *  ERRDBUF  (output) @(doctype) array, dimension (2, MAXERRS)
07841 *           Buffer in which to store error data information.
07842 *           {Incorrect, Predicted}
07843 *
07844 *  ===================================================================
07845 *
07846 *     .. Parameters ..
07847       INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
07848       PARAMETER( ERR_PRE = 1, ERR_POST = 2, ERR_GAP = 3, ERR_TRI = 4 )
07849       PARAMETER( ERR_MAT = 5 )
07850 *     ..
07851 *     .. External Functions ..
07852       INTEGER IBTNPROCS
07853       EXTERNAL IBTNPROCS
07854 *     ..
07855 *     .. Local Scalars ..
07856       LOGICAL ISTRAP
07857       INTEGER I, J, K, IRST, IRND, ICST, ICND, SRC, DEST
07858       INTEGER NPROCS
07859 *     ..
07860 *     .. Executable Statements ..
07861 *
07862       NPROCS = IBTNPROCS()
07863       SRC = RSRC * NPROCS + CSRC
07864       DEST = MYROW * NPROCS + MYCOL
07865 *
07866 *     Check buffer in front of A
07867 *
07868       IF( IPRE .GT. 0 ) THEN
07869          DO 10 I = 1, IPRE
07870             IF( MEM(I) .NE. CHECKVAL ) THEN
07871                NERR = NERR + 1
07872                IF( NERR .LE. MAXERR ) THEN
07873                   ERRIBUF(1, NERR) = TESTNUM
07874                   ERRIBUF(2, NERR) = SRC
07875                   ERRIBUF(3, NERR) = DEST
07876                   ERRIBUF(4, NERR) = I
07877                   ERRIBUF(5, NERR) = IPRE - I + 1
07878                   ERRIBUF(6, NERR) = ERR_PRE
07879                   ERRDBUF(1, NERR) = MEM(I)
07880                   ERRDBUF(2, NERR) = CHECKVAL
07881                END IF
07882             END IF
07883    10    CONTINUE
07884       END IF
07885 *
07886 *     Check buffer behind A
07887 *
07888       IF( IPOST .GT. 0 ) THEN
07889          J = IPRE + LDA*N + 1
07890          DO 20 I = J, J+IPOST-1
07891             IF( MEM(I) .NE. CHECKVAL ) THEN
07892                NERR = NERR + 1
07893                IF( NERR .LE. MAXERR ) THEN
07894                   ERRIBUF(1, NERR) = TESTNUM
07895                   ERRIBUF(2, NERR) = SRC
07896                   ERRIBUF(3, NERR) = DEST
07897                   ERRIBUF(4, NERR) = I - J + 1
07898                   ERRIBUF(5, NERR) = J
07899                   ERRIBUF(6, NERR) = ERR_POST
07900                   ERRDBUF(1, NERR) = MEM(I)
07901                   ERRDBUF(2, NERR) = CHECKVAL
07902                END IF
07903             END IF
07904    20    CONTINUE
07905       END IF
07906 *
07907 *     Check all (LDA-M) gaps
07908 *
07909       IF( LDA .GT. M ) THEN
07910          DO 40 J = 1, N
07911             DO 30 I = M+1, LDA
07912                K = IPRE + (J-1)*LDA + I
07913                IF( MEM(K) .NE. CHECKVAL) THEN
07914                   NERR = NERR + 1
07915                   IF( NERR .LE. MAXERR ) THEN
07916                      ERRIBUF(1, NERR) = TESTNUM
07917                      ERRIBUF(2, NERR) = SRC
07918                      ERRIBUF(3, NERR) = DEST
07919                      ERRIBUF(4, NERR) = I
07920                      ERRIBUF(5, NERR) = J
07921                      ERRIBUF(6, NERR) = ERR_GAP
07922                      ERRDBUF(1, NERR) = MEM(K)
07923                      ERRDBUF(2, NERR) = CHECKVAL
07924                   END IF
07925                END IF
07926    30       CONTINUE
07927    40    CONTINUE
07928       END IF
07929 *
07930 *     Determine limits of trapezoidal matrix
07931 *
07932       ISTRAP = .FALSE.
07933       IF( UPLO .EQ. 'U' ) THEN
07934          ISTRAP = .TRUE.
07935          IF( M .LE. N ) THEN
07936             IRST = 2
07937             IRND = M
07938             ICST = 1
07939             ICND = M - 1
07940          ELSEIF( M .GT. N ) THEN
07941             IRST = ( M-N ) + 2
07942             IRND = M
07943             ICST = 1
07944             ICND = N - 1
07945          ENDIF
07946          IF( DIAG .EQ. 'U' ) THEN
07947             IRST = IRST - 1
07948             ICND = ICND + 1
07949          ENDIF
07950       ELSE IF( UPLO .EQ. 'L' ) THEN
07951          ISTRAP = .TRUE.
07952          IF( M .LE. N ) THEN
07953             IRST = 1
07954             IRND = 1
07955             ICST = ( N-M ) + 2
07956             ICND = N
07957          ELSEIF( M .GT. N ) THEN
07958             IRST = 1
07959             IRND = 1
07960             ICST = 2
07961             ICND = N
07962          ENDIF
07963          IF( DIAG .EQ. 'U' ) THEN
07964             ICST = ICST - 1
07965          ENDIF
07966       ENDIF
07967 *
07968 *     Check elements and report any errors
07969 *
07970       IF( ISTRAP ) THEN
07971          DO 100 J = ICST, ICND
07972             DO 105 I = IRST, IRND
07973                IF( MEM( IPRE + (J-1)*LDA + I ) .NE. CHECKVAL ) THEN
07974                   NERR = NERR + 1
07975                   IF( NERR .LE. MAXERR ) THEN
07976                      ERRIBUF(1, NERR) = TESTNUM
07977                      ERRIBUF(2, NERR) = SRC
07978                      ERRIBUF(3, NERR) = DEST
07979                      ERRIBUF(4, NERR) = I
07980                      ERRIBUF(5, NERR) = J
07981                      ERRIBUF(6, NERR) = ERR_TRI
07982                      ERRDBUF(1, NERR) = MEM( IPRE + (J-1)*LDA + I )
07983                      ERRDBUF(2, NERR) = CHECKVAL
07984                   END IF
07985                END IF
07986   105       CONTINUE
07987 *
07988 *           Update the limits to allow filling in padding
07989 *
07990             IF( UPLO .EQ. 'U' ) THEN
07991                IRST = IRST + 1
07992             ELSE
07993                IRND = IRND + 1
07994             ENDIF
07995   100    CONTINUE
07996       END IF
07997 *
07998       RETURN
07999 *
08000 *     End of SCHKPAD.
08001 *
08002       END
08003 *
08004       SUBROUTINE SCHKMAT( UPLO, DIAG, M, N, A, LDA, RSRC, CSRC,
08005      $                    MYROW, MYCOL, TESTNUM, MAXERR, NERR,
08006      $                    ERRIBUF, ERRDBUF )
08007 *
08008 *  -- BLACS tester (version 1.0) --
08009 *  University of Tennessee
08010 *  December 15, 1994
08011 *
08012 *
08013 *     .. Scalar Arguments ..
08014       CHARACTER*1 UPLO, DIAG
08015       INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, TESTNUM
08016       INTEGER MAXERR, NERR
08017 *     ..
08018 *     .. Array Arguments ..
08019       INTEGER ERRIBUF(6, MAXERR)
08020       REAL A(LDA,N), ERRDBUF(2, MAXERR)
08021 *     ..
08022 *
08023 *  Purpose
08024 *  =======
08025 *  sCHKMAT:  Check matrix to see whether there were any transmission
08026 *            errors.
08027 *
08028 *  Arguments
08029 *  =========
08030 *  UPLO     (input) CHARACTER*1
08031 *           Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
08032 *           rectangular?
08033 *
08034 *  DIAG     (input) CHARACTER*1
08035 *           For trapezoidal matrices, is the main diagonal included
08036 *           ('N') or not ('U')?
08037 *
08038 *   M       (input) INTEGER
08039 *           The number of rows of the matrix A.  M >= 0.
08040 *
08041 *   N       (input) INTEGER
08042 *           The number of columns of the matrix A.  N >= 0.
08043 *
08044 *   A       (input) @up@(doctype) array, dimension (LDA,N)
08045 *           The m by n matrix A.  Fortran77 (column-major) storage
08046 *           assumed.
08047 *
08048 *   LDA     (input) INTEGER
08049 *           The leading dimension of the array A.  LDA >= max(1, M).
08050 *
08051 *  RSRC     (input) INTEGER
08052 *           The process row of the source of the matrix.
08053 *
08054 *  CSRC     (input) INTEGER
08055 *           The process column of the source of the matrix.
08056 *
08057 *  MYROW    (input) INTEGER
08058 *           Row of this process in the process grid.
08059 *
08060 *  MYCOL    (input) INTEGER
08061 *           Column of this process in the process grid.
08062 *
08063 *
08064 *  TESTNUM  (input) INTEGER
08065 *           The number of the test being checked.
08066 *
08067 *  MAXERR   (input) INTEGER
08068 *           Max number of errors that can be stored in ERRIBUFF or
08069 *           ERRSBUFF
08070 *
08071 *  NERR     (output) INTEGER
08072 *           The number of errors that have been found.
08073 *
08074 *  ERRIBUF  (output) INTEGER array, dimension (6,MAXERRS)
08075 *           Buffer in which to store integer error information.  It will
08076 *           be built up in the following format for the call to TSEND.
08077 *           All integer information is recorded in the following 6-tuple
08078 *           {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
08079 *             SRC = RSRC * NPROCS + CSRC
08080 *             DEST = RDEST * NPROCS + CDEST
08081 *             WHAT
08082 *              = 1 : Error in pre-padding
08083 *              = 2 : Error in post-padding
08084 *              = 3 : Error in LDA-M gap
08085 *              = 4 : Error in complementory triangle
08086 *              ELSE: Error in matrix
08087 *           If there are more errors than can fit in the error buffer,
08088 *           the error number will indicate the actual number of errors
08089 *           found, but the buffer will be truncated to the maximum
08090 *           number of errors which can fit.
08091 *
08092 *  ERRDBUF  (output) @(doctype) array, dimension (2, MAXERRS)
08093 *           Buffer in which to store error data information.
08094 *           {Incorrect, Predicted}
08095 *
08096 *  ===================================================================
08097 *
08098 *     .. Local Scalars ..
08099       INTEGER I, J, NPROCS, SRC, DEST
08100       LOGICAL USEIT
08101       REAL COMPVAL
08102 *     ..
08103 *     .. Local Arrays ..
08104       INTEGER ISEED(4)
08105 *     ..
08106 *     .. External Functions ..
08107       INTEGER IBTNPROCS
08108       REAL SBTRAN
08109       EXTERNAL SBTRAN, IBTNPROCS
08110 *     ..
08111 *     .. Executable Statements ..
08112 *
08113       NPROCS = IBTNPROCS()
08114       SRC = RSRC * NPROCS + CSRC
08115       DEST = MYROW * NPROCS + MYCOL
08116 *
08117 *     Initialize ISEED with the same values as used in SGENMAT.
08118 *
08119       ISEED(1) = MOD( 1002 + TESTNUM*5 + SRC*3, 4096 )
08120       ISEED(2) = MOD( 2027 + TESTNUM*7 + SRC, 4096 )
08121       ISEED(3) = MOD( 1234 + TESTNUM + SRC*3, 4096 )
08122       ISEED(4) = MOD( 4311 + TESTNUM*10 + SRC*2, 4096 )
08123 *
08124 *     Generate the elements randomly with the same method used in GENMAT.
08125 *     Note that for trapezoidal matrices, we generate all elements in the
08126 *     enclosing rectangle and then ignore the complementary triangle.
08127 *
08128       DO 100 J = 1, N
08129          DO 105 I = 1, M
08130             COMPVAL = SBTRAN( ISEED )
08131 *
08132 *           Now determine whether we actually need this value.  The
08133 *           strategy is to chop out the proper triangle based on what
08134 *           particular kind of trapezoidal matrix we're dealing with.
08135 *
08136             USEIT = .TRUE.
08137             IF( UPLO .EQ. 'U' ) THEN
08138                IF( M .LE. N ) THEN
08139                   IF( DIAG .EQ. 'U' ) THEN
08140                      IF( I .GE. J ) THEN
08141                         USEIT = .FALSE.
08142                      END IF
08143                   ELSE
08144                      IF( I .GT. J ) THEN
08145                         USEIT = .FALSE.
08146                      END IF
08147                   END IF
08148                ELSE
08149                   IF( DIAG .EQ. 'U' ) THEN
08150                      IF( I .GE. M-N+J ) THEN
08151                         USEIT = .FALSE.
08152                      END IF
08153                   ELSE
08154                      IF( I .GT. M-N+J ) THEN
08155                         USEIT = .FALSE.
08156                      END IF
08157                   END IF
08158                END IF
08159             ELSE IF( UPLO .EQ. 'L' ) THEN
08160                IF( M .LE. N ) THEN
08161                   IF( DIAG .EQ. 'U' ) THEN
08162                      IF( J. GE. I+(N-M) ) THEN
08163                         USEIT = .FALSE.
08164                      END IF
08165                   ELSE
08166                      IF( J .GT. I+(N-M) ) THEN
08167                         USEIT = .FALSE.
08168                      END IF
08169                   END IF
08170                ELSE
08171                   IF( DIAG .EQ. 'U' ) THEN
08172                      IF( J .GE. I ) THEN
08173                         USEIT = .FALSE.
08174                      END IF
08175                   ELSE
08176                      IF( J .GT. I ) THEN
08177                         USEIT = .FALSE.
08178                      END IF
08179                   END IF
08180                END IF
08181             END IF
08182 *
08183 *           Compare the generated value to the one that's in the
08184 *           received matrix.  If they don't match, tack another
08185 *           error record onto what's already there.
08186 *
08187             IF( USEIT ) THEN
08188                IF( A(I,J) .NE. COMPVAL ) THEN
08189                   NERR = NERR + 1
08190                   IF( NERR .LE. MAXERR ) THEN
08191                      ERRIBUF(1, NERR) = TESTNUM
08192                      ERRIBUF(2, NERR) = SRC
08193                      ERRIBUF(3, NERR) = DEST
08194                      ERRIBUF(4, NERR) = I
08195                      ERRIBUF(5, NERR) = J
08196                      ERRIBUF(6, NERR) = 5
08197                      ERRDBUF(1, NERR) = A(I, J)
08198                      ERRDBUF(2, NERR) = COMPVAL
08199                   END IF
08200                END IF
08201             END IF
08202   105    CONTINUE
08203   100 CONTINUE
08204       RETURN
08205 *
08206 *     End of SCHKMAT.
08207 *
08208       END
08209 *
08210       SUBROUTINE SPRINTERRS( OUTNUM, MAXERR, NERR,
08211      $                       ERRIBUF, ERRDBUF, COUNTING, TFAILED )
08212 *
08213 *  -- BLACS tester (version 1.0) --
08214 *  University of Tennessee
08215 *  December 15, 1994
08216 *
08217 *
08218 *     .. Scalar Arguments ..
08219       LOGICAL COUNTING
08220       INTEGER OUTNUM, MAXERR, NERR
08221 *     ..
08222 *     .. Array Arguments ..
08223       INTEGER ERRIBUF(6, MAXERR), TFAILED(*)
08224       REAL ERRDBUF(2, MAXERR)
08225 *     ..
08226 *
08227 *  Purpose
08228 *  =======
08229 *  SPRINTERRS: Print errors that have been recorded
08230 *
08231 *  Arguments
08232 *  =========
08233 *  OUTNUM   (input) INTEGER
08234 *           Device number for output.
08235 *
08236 *  MAXERR   (input) INTEGER
08237 *           Max number of errors that can be stored in ERRIBUFF or
08238 *           ERRSBUFF
08239 *
08240 *  NERR     (output) INTEGER
08241 *           The number of errors that have been found.
08242 *
08243 *  ERRIBUF  (output) INTEGER array, dimension (6,MAXERRS)
08244 *           Buffer in which to store integer error information.  It will
08245 *           be built up in the following format for the call to TSEND.
08246 *           All integer information is recorded in the following 6-tuple
08247 *           {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
08248 *             SRC = RSRC * NPROCS + CSRC
08249 *             DEST = RDEST * NPROCS + CDEST
08250 *             WHAT
08251 *              = 1 : Error in pre-padding
08252 *              = 2 : Error in post-padding
08253 *              = 3 : Error in LDA-M gap
08254 *              = 4 : Error in complementory triangle
08255 *              ELSE: Error in matrix
08256 *           If there are more errors than can fit in the error buffer,
08257 *           the error number will indicate the actual number of errors
08258 *           found, but the buffer will be truncated to the maximum
08259 *           number of errors which can fit.
08260 *
08261 *  ERRDBUF  (output) @(doctype) array, dimension (2, MAXERRS)
08262 *           Buffer in which to store error data information.
08263 *           {Incorrect, Predicted}
08264 *
08265 *  TFAILED (input/ourput) INTEGER array, dimension NTESTS
08266 *          Workspace used to keep track of which tests failed.
08267 *          This array not accessed unless COUNTING is true.
08268 *
08269 *  ===================================================================
08270 *
08271 *     .. Parameters ..
08272       INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
08273       PARAMETER( ERR_PRE = 1, ERR_POST = 2, ERR_GAP = 3, ERR_TRI = 4 )
08274       PARAMETER( ERR_MAT = 5 )
08275 *     ..
08276 *     .. External Functions ..
08277       INTEGER IBTMYPROC, IBTNPROCS
08278       EXTERNAL IBTMYPROC, IBTNPROCS
08279 *     ..
08280 *     .. Local Scalars ..
08281       CHARACTER*1 MAT
08282       LOGICAL MATISINT
08283       INTEGER OLDTEST, NPROCS, PROW, PCOL, I, ERRTYPE
08284 *     ..
08285 *     .. Executable Statements ..
08286 *
08287       IF( (IBTMYPROC().NE.0) .OR. (NERR.LE.0) ) RETURN
08288       OLDTEST = -1
08289       NPROCS = IBTNPROCS()
08290       PROW = ERRIBUF(3,1) / NPROCS
08291       PCOL = MOD( ERRIBUF(3,1), NPROCS )
08292       IF( NERR .GT. MAXERR ) WRITE(OUTNUM,13000)
08293 *
08294       DO 20 I = 1, MIN( NERR, MAXERR )
08295          IF( ERRIBUF(1,I) .NE. OLDTEST ) THEN
08296             IF( OLDTEST .NE. -1 )
08297      $         WRITE(OUTNUM,12000) PROW, PCOL, OLDTEST
08298             WRITE(OUTNUM,*) '  '
08299             WRITE(OUTNUM,1000) PROW, PCOL, ERRIBUF(1,I)
08300             IF( COUNTING ) TFAILED( ERRIBUF(1,I) ) = 1
08301             OLDTEST = ERRIBUF(1, I)
08302          END IF
08303 *
08304 *        Print out error message depending on type of error
08305 *
08306          ERRTYPE = ERRIBUF(6, I)
08307          IF( ERRTYPE .LT. -10 ) THEN
08308             ERRTYPE = -ERRTYPE - 10
08309             MAT = 'C'
08310             MATISINT = .TRUE.
08311          ELSE IF( ERRTYPE .LT. 0 ) THEN
08312             ERRTYPE = -ERRTYPE
08313             MAT = 'R'
08314             MATISINT = .TRUE.
08315          ELSE
08316             MATISINT = .FALSE.
08317          END IF
08318 *
08319 *        RA/CA arrays from MAX/MIN have different printing protocol
08320 *
08321          IF( MATISINT ) THEN
08322             IF( ERRIBUF(2, I) .EQ. -1 ) THEN
08323                WRITE(OUTNUM,11000) ERRIBUF(4,I), ERRIBUF(5,I), MAT,
08324      $            INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) )
08325             ELSE IF( ERRTYPE .EQ. ERR_PRE ) THEN
08326                WRITE(OUTNUM,7000) ERRIBUF(5,I), MAT,
08327      $            INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) )
08328             ELSE IF( ERRTYPE .EQ. ERR_POST ) THEN
08329                WRITE(OUTNUM,8000) ERRIBUF(4,I), MAT,
08330      $            INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) )
08331             ELSE IF( ERRTYPE .EQ. ERR_GAP ) THEN
08332                WRITE(OUTNUM,9000) MAT, ERRIBUF(4,I), ERRIBUF(5,I),
08333      $            INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) )
08334             ELSE
08335                WRITE(OUTNUM,10000) MAT, ERRIBUF(4,I), ERRIBUF(5,I),
08336      $                             INT( ERRDBUF(2,I) ),
08337      $                             INT( ERRDBUF(1,I) )
08338             END IF
08339 *
08340 *        Have memory overwrites in matrix A
08341 *
08342          ELSE
08343             IF( ERRTYPE .EQ. ERR_PRE ) THEN
08344                WRITE(OUTNUM,2000) ERRIBUF(5,I), ERRDBUF(2,I),
08345      $                            ERRDBUF(1,I)
08346             ELSE IF( ERRTYPE .EQ. ERR_POST ) THEN
08347                WRITE(OUTNUM,3000) ERRIBUF(4,I), ERRDBUF(2,I),
08348      $                            ERRDBUF(1,I)
08349             ELSE IF( ERRTYPE .EQ. ERR_GAP ) THEN
08350                WRITE(OUTNUM,4000) ERRIBUF(4,I), ERRIBUF(5,I),
08351      $                            ERRDBUF(2,I), ERRDBUF(1,I)
08352             ELSE IF( ERRTYPE .EQ. ERR_TRI ) THEN
08353                WRITE(OUTNUM,5000) ERRIBUF(4,I), ERRIBUF(5,I),
08354      $                            ERRDBUF(2,I), ERRDBUF(1,I)
08355             ELSE
08356                WRITE(OUTNUM,6000) ERRIBUF(4,I), ERRIBUF(5,I),
08357      $                            ERRDBUF(2,I), ERRDBUF(1,I)
08358             END IF
08359          END IF
08360    20 CONTINUE
08361       WRITE(OUTNUM,12000) PROW, PCOL, OLDTEST
08362 *
08363  1000 FORMAT('PROCESS {',I4,',',I4,'} REPORTS ERRORS IN TEST#',I6,':')
08364  2000 FORMAT('   Buffer overwrite ',I4,
08365      $       ' elements before the start of A:',/,
08366      $       '   Expected=',G15.8,
08367      $       '; Received=',G15.8)
08368  3000 FORMAT('   Buffer overwrite ',I4,' elements after the end of A:',
08369      $       /,'   Expected=',G15.8,
08370      $       '; Received=',G15.8)
08371  4000 FORMAT('   LDA-M gap overwrite at postion (',I4,',',I4,'):',/,
08372      $       '   Expected=',G15.8,
08373      $       '; Received=',G15.8)
08374  5000 FORMAT('   Complementory triangle overwrite at A(',I4,',',I4,
08375      $       '):',/,'   Expected=',G15.8,
08376      $       '; Received=',G15.8)
08377  6000 FORMAT('   Invalid element at A(',I4,',',I4,'):',/,
08378      $       '   Expected=',G15.8,
08379      $       '; Received=',G15.8)
08380  7000 FORMAT('   Buffer overwrite ',I4,' elements before the start of ',
08381      $       A1,'A:',/,'   Expected=',I12,'; Received=',I12)
08382  8000 FORMAT('   Buffer overwrite ',I4,' elements after the end of ',
08383      $       A1,'A:',/,'   Expected=',I12,'; Received=',I12)
08384 *
08385  9000 FORMAT('   LD',A1,'A-M gap overwrite at postion (',I4,',',I4,'):'
08386      $       ,/,'   Expected=',I12,'; Received=',I12)
08387 *
08388 10000 FORMAT('   Invalid element at ',A1,'A(',I4,',',I4,'):',/,
08389      $       '   Expected=',I12,'; Received=',I12)
08390 11000 FORMAT('   Overwrite at position (',I4,',',I4,') of non-existent '
08391      $       ,A1,'A array.',/,'   Expected=',I12,'; Received=',I12)
08392 12000 FORMAT('PROCESS {',I4,',',I4,'} DONE ERROR REPORT FOR TEST#',
08393      $       I6,'.')
08394 13000 FORMAT('WARNING: There were more errors than could be recorded.',
08395      $       /,'Increase MEMELTS to get complete listing.')
08396       RETURN
08397 *
08398 *     End SPRINTERRS
08399 *
08400       END
08401 *
08402 *
08403       SUBROUTINE DBTCHECKIN( NFTESTS, OUTNUM, MAXERR, NERR, IERR,
08404      $                       DVAL, TFAILED )
08405       INTEGER NFTESTS, OUTNUM, MAXERR, NERR
08406       INTEGER IERR(*), TFAILED(*)
08407       DOUBLE PRECISION DVAL(*)
08408 *
08409 *  Purpose
08410 *  =======
08411 *  DBTCHECKIN: Process 0 receives error report from all processes.
08412 *
08413 *  Arguments
08414 *  =========
08415 *  NFTESTS  (input/output) INTEGER
08416 *           if NFTESTS is <= 0 upon entry, NFTESTS is not written to.
08417 *           Otherwise, on entry it specifies the total number of tests
08418 *           run, and on exit it is the number of tests which failed.
08419 *
08420 *  OUTNUM   (input) INTEGER
08421 *           Device number for output.
08422 *
08423 *  MAXERR   (input) INTEGER
08424 *           Max number of errors that can be stored in ERRIBUFF or
08425 *           ERRDBUFF
08426 *
08427 *  NERR     (output) INTEGER
08428 *           The number of errors that have been found.
08429 *
08430 *  ERRIBUF  (output) INTEGER array, dimension (6,MAXERRS)
08431 *           Buffer in which to store integer error information.  It will
08432 *           be built up in the following format for the call to TSEND.
08433 *           All integer information is recorded in the following 6-tuple
08434 *           {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
08435 *             SRC = RSRC * NPROCS + CSRC
08436 *             DEST = RDEST * NPROCS + CDEST
08437 *             WHAT
08438 *              = 1 : Error in pre-padding
08439 *              = 2 : Error in post-padding
08440 *              = 3 : Error in LDA-M gap
08441 *              = 4 : Error in complementory triangle
08442 *              ELSE: Error in matrix
08443 *           If there are more errors than can fit in the error buffer,
08444 *           the error number will indicate the actual number of errors
08445 *           found, but the buffer will be truncated to the maximum
08446 *           number of errors which can fit.
08447 *
08448 *  ERRDBUF  (output) @(doctype) array, dimension (2, MAXERRS)
08449 *           Buffer in which to store error data information.
08450 *           {Incorrect, Predicted}
08451 *
08452 *  TFAILED (workspace) INTEGER array, dimension NFTESTS
08453 *          Workspace used to keep track of which tests failed.
08454 *          If input of NFTESTS < 1, this array not accessed.
08455 *
08456 *  ===================================================================
08457 *
08458 *     .. External Functions ..
08459       INTEGER  IBTMYPROC, IBTNPROCS, IBTMSGID
08460       EXTERNAL IBTMYPROC, IBTNPROCS, IBTMSGID
08461 *     ..
08462 *     .. Local Scalars ..
08463       LOGICAL COUNTING
08464       INTEGER K, NERR2, IAM, NPROCS, NTESTS
08465 *
08466 *     Proc 0 collects error info from everyone
08467 *
08468       IAM = IBTMYPROC()
08469       NPROCS = IBTNPROCS()
08470 *
08471       IF( IAM .EQ. 0 ) THEN
08472 *
08473 *        If we are finding out how many failed tests there are, initialize
08474 *        the total number of tests (NTESTS), and zero the test failed array
08475 *
08476          COUNTING = NFTESTS .GT. 0
08477          IF( COUNTING ) THEN
08478             NTESTS = NFTESTS
08479             DO 10 K = 1, NTESTS
08480                TFAILED(K) = 0
08481    10       CONTINUE
08482          END IF
08483 *
08484          CALL DPRINTERRS(OUTNUM, MAXERR, NERR, IERR, DVAL, COUNTING,
08485      $                   TFAILED)
08486 *
08487          DO 20 K = 1, NPROCS-1
08488             CALL BTSEND(3, 0, K, K, IBTMSGID()+50)
08489             CALL BTRECV(3, 1, NERR2, K, IBTMSGID()+50)
08490             IF( NERR2 .GT. 0 ) THEN
08491                NERR = NERR + NERR2
08492                CALL BTRECV(3, NERR2*6, IERR, K, IBTMSGID()+51)
08493                CALL BTRECV(6, NERR2*2, DVAL, K, IBTMSGID()+51)
08494                CALL DPRINTERRS(OUTNUM, MAXERR, NERR2, IERR, DVAL,
08495      $                         COUNTING, TFAILED)
08496             END IF
08497    20    CONTINUE
08498 *
08499 *        Count up number of tests that failed
08500 *
08501          IF( COUNTING ) THEN
08502             NFTESTS = 0
08503             DO 30 K = 1, NTESTS
08504                NFTESTS = NFTESTS + TFAILED(K)
08505    30       CONTINUE
08506          END IF
08507 *
08508 *     Send my error info to proc 0
08509 *
08510       ELSE
08511          CALL BTRECV(3, 0, K, 0, IBTMSGID()+50)
08512          CALL BTSEND(3, 1, NERR, 0, IBTMSGID()+50)
08513          IF( NERR .GT. 0 ) THEN
08514             CALL BTSEND(3, NERR*6, IERR, 0, IBTMSGID()+51)
08515             CALL BTSEND(6, NERR*2, DVAL, 0, IBTMSGID()+51)
08516          END IF
08517       ENDIF
08518 *
08519       RETURN
08520 *
08521 *     End of DBTCHECKIN
08522 *
08523       END
08524 *
08525       SUBROUTINE DINITMAT(UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST,
08526      $                    CHECKVAL, TESTNUM, MYROW, MYCOL)
08527       CHARACTER*1 UPLO, DIAG
08528       INTEGER M, N, LDA, IPRE, IPOST, TESTNUM, MYROW, MYCOL
08529       DOUBLE PRECISION CHECKVAL
08530       DOUBLE PRECISION MEM(*)
08531 *
08532 *     .. External Subroutines ..
08533       EXTERNAL DGENMAT, DPADMAT
08534 *     ..
08535 *     .. Executable Statements ..
08536 *
08537       CALL DGENMAT( M, N, MEM(IPRE+1), LDA, TESTNUM, MYROW, MYCOL )
08538       CALL DPADMAT( UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST, CHECKVAL )
08539 *
08540       RETURN
08541       END
08542 *
08543       SUBROUTINE DGENMAT( M, N, A, LDA, TESTNUM, MYROW, MYCOL )
08544 *
08545 *  -- BLACS tester (version 1.0) --
08546 *  University of Tennessee
08547 *  December 15, 1994
08548 *
08549 *
08550 *     .. Scalar Arguments ..
08551       INTEGER M, N, LDA, TESTNUM, MYROW, MYCOL
08552 *     ..
08553 *     .. Array Arguments ..
08554       DOUBLE PRECISION A(LDA,N)
08555 *     ..
08556 *
08557 *  Purpose
08558 *  =======
08559 *  DGENMAT: Generates an M-by-N matrix filled with random elements.
08560 *
08561 *  Arguments
08562 *  =========
08563 *   M       (input) INTEGER
08564 *           The number of rows of the matrix A.  M >= 0.
08565 *
08566 *   N       (input) INTEGER
08567 *           The number of columns of the matrix A.  N >= 0.
08568 *
08569 *   A       (output) @up@(doctype) array, dimension (LDA,N)
08570 *           The m by n matrix A.  Fortran77 (column-major) storage
08571 *           assumed.
08572 *
08573 *   LDA     (input) INTEGER
08574 *           The leading dimension of the array A.  LDA >= max(1, M).
08575 *
08576 *  TESTNUM  (input) INTEGER
08577 *           Unique number for this test case, used as a basis for
08578 *           the random seeds.
08579 *
08580 *  ====================================================================
08581 *
08582 *     .. External Functions ..
08583       INTEGER IBTNPROCS
08584       DOUBLE PRECISION DBTRAN
08585       EXTERNAL DBTRAN, IBTNPROCS
08586 *     ..
08587 *     .. Local Scalars ..
08588       INTEGER I, J, NPROCS, SRC
08589 *     ..
08590 *     .. Local Arrays ..
08591       INTEGER ISEED(4)
08592 *     ..
08593 *     .. Executable Statements ..
08594 *
08595 *     ISEED's four values must be positive integers less than 4096,
08596 *     fourth one has to be odd. (see _LARND).  Use some goofy
08597 *     functions to come up with seed values which together should
08598 *     be unique.
08599 *
08600       NPROCS = IBTNPROCS()
08601       SRC = MYROW * NPROCS + MYCOL
08602       ISEED(1) = MOD( 1002 + TESTNUM*5 + SRC*3, 4096 )
08603       ISEED(2) = MOD( 2027 + TESTNUM*7 + SRC, 4096 )
08604       ISEED(3) = MOD( 1234 + TESTNUM + SRC*3, 4096 )
08605       ISEED(4) = MOD( 4311 + TESTNUM*10 + SRC*2, 4096 )
08606 *
08607       DO 10 J = 1, N
08608          DO 10 I = 1, M
08609             A(I, J) = DBTRAN( ISEED )
08610    10 CONTINUE
08611 *
08612       RETURN
08613 *
08614 *     End of DGENMAT.
08615 *
08616       END
08617 *
08618       DOUBLE PRECISION FUNCTION DBTRAN(ISEED)
08619       INTEGER ISEED(*)
08620 *
08621 *     .. External Functions ..
08622       DOUBLE PRECISION DLARND
08623       EXTERNAL DLARND
08624 *     .. Executable Statements ..
08625 *
08626       DBTRAN = DLARND(2, ISEED)
08627 *
08628       RETURN
08629 *
08630 *     End of Dbtran
08631 *
08632       END
08633 *
08634       SUBROUTINE DPADMAT( UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST,
08635      $                    CHECKVAL )
08636 *
08637 *  -- BLACS tester (version 1.0) --
08638 *  University of Tennessee
08639 *  December 15, 1994
08640 *
08641 *     .. Scalar Arguments ..
08642       CHARACTER*1 UPLO, DIAG
08643       INTEGER M, N, LDA, IPRE, IPOST
08644       DOUBLE PRECISION CHECKVAL
08645 *     ..
08646 *     .. Array Arguments ..
08647       DOUBLE PRECISION MEM( * )
08648 *     ..
08649 *
08650 *  Purpose
08651 *  =======
08652 *
08653 *  DPADMAT: Pad Matrix.
08654 *  This routines surrounds a matrix with a guardzone initialized to the
08655 *  value CHECKVAL.  There are three distinct guardzones:
08656 *  - A contiguous zone of size IPRE immediately before the start
08657 *    of the matrix.
08658 *  - A contiguous zone of size IPOST immedately after the end of the
08659 *    matrix.
08660 *  - Interstitial zones within each column of the matrix, in the
08661 *    elements A( M+1:LDA, J ).
08662 *
08663 *  Arguments
08664 *  =========
08665 *  UPLO     (input) CHARACTER*1
08666 *           Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
08667 *           rectangular?
08668 *
08669 *  DIAG     (input) CHARACTER*1
08670 *           For trapezoidal matrices, is the main diagonal included
08671 *           ('N') or not ('U')?
08672 *
08673 *   M       (input) INTEGER
08674 *           The number of rows of the matrix A.  M >= 0.
08675 *
08676 *   N       (input) INTEGER
08677 *           The number of columns of the matrix A.  N >= 0.
08678 *
08679 *  MEM      (output) double precision array, dimension (IPRE+IPOST+LDA*N)
08680 *           The address IPRE elements ahead of the matrix A you want to
08681 *           pad, which is then of dimension (LDA,N).
08682 *
08683 *  IPRE     (input) INTEGER
08684 *           The size of the guard zone ahead of the matrix A.
08685 *
08686 *  IPOST    (input) INTEGER
08687 *           The size of the guard zone behind the matrix A.
08688 *
08689 *  CHECKVAL (input) double precision
08690 *           The value to insert into the guard zones.
08691 *
08692 *  ====================================================================
08693 *
08694 *     .. Local Scalars ..
08695       INTEGER I, J, K
08696 *     ..
08697 *     .. Executable Statements ..
08698 *
08699 *     Put check buffer in front of A
08700 *
08701       IF( IPRE .GT. 0 ) THEN
08702          DO 10 I = 1, IPRE
08703             MEM( I ) = CHECKVAL
08704    10    CONTINUE
08705       END IF
08706 *
08707 *     Put check buffer in back of A
08708 *
08709       IF( IPOST .GT. 0 ) THEN
08710          J = IPRE + LDA*N + 1
08711          DO 20 I = J, J+IPOST-1
08712             MEM( I ) = CHECKVAL
08713    20    CONTINUE
08714       END IF
08715 *
08716 *     Put check buffer in all (LDA-M) gaps
08717 *
08718       IF( LDA .GT. M ) THEN
08719          K = IPRE + M + 1
08720          DO 40 J = 1, N
08721             DO 30 I = K, K+LDA-M-1
08722                MEM( I ) = CHECKVAL
08723    30       CONTINUE
08724             K = K + LDA
08725    40    CONTINUE
08726       END IF
08727 *
08728 *     If the matrix is upper or lower trapezoidal, calculate the
08729 *     additional triangular area which needs to be padded,  Each
08730 *     element referred to is in the Ith row and the Jth column.
08731 *
08732       IF( UPLO .EQ. 'U' ) THEN
08733          IF( M .LE. N ) THEN
08734             IF( DIAG .EQ. 'U' ) THEN
08735                DO 41 I = 1, M
08736                   DO 42 J = 1, I
08737                      K = IPRE + I + (J-1)*LDA
08738                      MEM( K ) = CHECKVAL
08739    42             CONTINUE
08740    41          CONTINUE
08741             ELSE
08742                DO 43 I = 2, M
08743                   DO 44 J = 1, I-1
08744                      K = IPRE + I + (J-1)*LDA
08745                      MEM( K ) = CHECKVAL
08746    44             CONTINUE
08747    43          CONTINUE
08748             END IF
08749          ELSE
08750             IF( DIAG .EQ. 'U' ) THEN
08751                DO 45 I = M-N+1, M
08752                   DO 46 J = 1, I-(M-N)
08753                      K = IPRE + I + (J-1)*LDA
08754                      MEM( K ) = CHECKVAL
08755    46             CONTINUE
08756    45          CONTINUE
08757             ELSE
08758                DO 47 I = M-N+2, M
08759                   DO 48 J = 1, I-(M-N)-1
08760                      K = IPRE + I + (J-1)*LDA
08761                      MEM( K ) = CHECKVAL
08762    48             CONTINUE
08763    47          CONTINUE
08764             END IF
08765          END IF
08766       ELSE IF( UPLO .EQ. 'L' ) THEN
08767          IF( M .LE. N ) THEN
08768             IF( DIAG .EQ. 'U' ) THEN
08769                DO 49 I = 1, M
08770                   DO 50 J = N-M+I, N
08771                      K = IPRE + I + (J-1)*LDA
08772                      MEM( K ) = CHECKVAL
08773    50             CONTINUE
08774    49          CONTINUE
08775             ELSE
08776                DO 51 I = 1, M-1
08777                   DO 52 J = N-M+I+1, N
08778                      K = IPRE + I + (J-1)*LDA
08779                      MEM( K ) = CHECKVAL
08780    52             CONTINUE
08781    51          CONTINUE
08782             END IF
08783          ELSE
08784             IF( UPLO .EQ. 'U' ) THEN
08785                DO 53 I = 1, N
08786                   DO 54 J = I, N
08787                      K = IPRE + I + (J-1)*LDA
08788                      MEM( K ) = CHECKVAL
08789    54             CONTINUE
08790    53          CONTINUE
08791             ELSE
08792                DO 55 I = 1, N-1
08793                   DO 56 J = I+1, N
08794                      K = IPRE + I + (J-1)*LDA
08795                      MEM( K ) = CHECKVAL
08796    56             CONTINUE
08797    55          CONTINUE
08798             END IF
08799          END IF
08800       END IF
08801 *
08802 *     End of DPADMAT.
08803 *
08804       RETURN
08805       END
08806 *
08807       SUBROUTINE DCHKPAD( UPLO, DIAG, M, N, MEM, LDA, RSRC, CSRC,
08808      $                    MYROW, MYCOL, IPRE, IPOST, CHECKVAL,
08809      $                    TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF )
08810 *
08811 *  -- BLACS tester (version 1.0) --
08812 *  University of Tennessee
08813 *  December 15, 1994
08814 *
08815 *
08816 *     .. Scalar Arguments ..
08817       CHARACTER*1 UPLO, DIAG
08818       INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, IPRE, IPOST
08819       INTEGER TESTNUM, MAXERR, NERR
08820       DOUBLE PRECISION CHECKVAL
08821 *     ..
08822 *     .. Array Arguments ..
08823       INTEGER ERRIBUF(6, MAXERR)
08824       DOUBLE PRECISION MEM(*), ERRDBUF(2, MAXERR)
08825 *     ..
08826 *
08827 *  Purpose
08828 *  =======
08829 *  DCHKPAD: Check padding put in by PADMAT.
08830 *  Checks that padding around target matrix has not been overwritten
08831 *  by the previous point-to-point or broadcast send.
08832 *
08833 *  Arguments
08834 *  =========
08835 *  UPLO     (input) CHARACTER*1
08836 *           Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
08837 *           rectangular?
08838 *
08839 *  DIAG     (input) CHARACTER*1
08840 *           For trapezoidal matrices, is the main diagonal included
08841 *           ('N') or not ('U')?
08842 *
08843 *   M       (input) INTEGER
08844 *           The number of rows of the matrix A.  M >= 0.
08845 *
08846 *   N       (input) INTEGER
08847 *           The number of columns of the matrix A.  N >= 0.
08848 *
08849 *  MEM       (input) double precision array, dimension(IPRE+IPOST+LDA*N).
08850 *            Memory location IPRE elements in front of the matrix A.
08851 *
08852 *   LDA     (input) INTEGER
08853 *           The leading dimension of the array A.  LDA >= max(1, M).
08854 *
08855 *  RSRC     (input) INTEGER
08856 *           The process row of the source of the matrix.
08857 *
08858 *  CSRC     (input) INTEGER
08859 *           The process column of the source of the matrix.
08860 *
08861 *  MYROW    (input) INTEGER
08862 *           Row of this process in the process grid.
08863 *
08864 *  MYCOL    (input) INTEGER
08865 *           Column of this process in the process grid.
08866 *
08867 *  IPRE     (input) INTEGER
08868 *           The size of the guard zone before the start of A.
08869 *
08870 *  IPOST    (input) INTEGER
08871 *           The size of guard zone after A.
08872 *
08873 *  CHECKVAL (input) double precision
08874 *           The value to pad matrix with.
08875 *
08876 *  TESTNUM  (input) INTEGER
08877 *           The number of the test being checked.
08878 *
08879 *  MAXERR   (input) INTEGER
08880 *           Max number of errors that can be stored in ERRIBUFF or
08881 *           ERRDBUFF
08882 *
08883 *  NERR     (output) INTEGER
08884 *           The number of errors that have been found.
08885 *
08886 *  ERRIBUF  (output) INTEGER array, dimension (6,MAXERRS)
08887 *           Buffer in which to store integer error information.  It will
08888 *           be built up in the following format for the call to TSEND.
08889 *           All integer information is recorded in the following 6-tuple
08890 *           {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
08891 *             SRC = RSRC * NPROCS + CSRC
08892 *             DEST = RDEST * NPROCS + CDEST
08893 *             WHAT
08894 *              = 1 : Error in pre-padding
08895 *              = 2 : Error in post-padding
08896 *              = 3 : Error in LDA-M gap
08897 *              = 4 : Error in complementory triangle
08898 *              ELSE: Error in matrix
08899 *           If there are more errors than can fit in the error buffer,
08900 *           the error number will indicate the actual number of errors
08901 *           found, but the buffer will be truncated to the maximum
08902 *           number of errors which can fit.
08903 *
08904 *  ERRDBUF  (output) @(doctype) array, dimension (2, MAXERRS)
08905 *           Buffer in which to store error data information.
08906 *           {Incorrect, Predicted}
08907 *
08908 *  ===================================================================
08909 *
08910 *     .. Parameters ..
08911       INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
08912       PARAMETER( ERR_PRE = 1, ERR_POST = 2, ERR_GAP = 3, ERR_TRI = 4 )
08913       PARAMETER( ERR_MAT = 5 )
08914 *     ..
08915 *     .. External Functions ..
08916       INTEGER IBTNPROCS
08917       EXTERNAL IBTNPROCS
08918 *     ..
08919 *     .. Local Scalars ..
08920       LOGICAL ISTRAP
08921       INTEGER I, J, K, IRST, IRND, ICST, ICND, SRC, DEST
08922       INTEGER NPROCS
08923 *     ..
08924 *     .. Executable Statements ..
08925 *
08926       NPROCS = IBTNPROCS()
08927       SRC = RSRC * NPROCS + CSRC
08928       DEST = MYROW * NPROCS + MYCOL
08929 *
08930 *     Check buffer in front of A
08931 *
08932       IF( IPRE .GT. 0 ) THEN
08933          DO 10 I = 1, IPRE
08934             IF( MEM(I) .NE. CHECKVAL ) THEN
08935                NERR = NERR + 1
08936                IF( NERR .LE. MAXERR ) THEN
08937                   ERRIBUF(1, NERR) = TESTNUM
08938                   ERRIBUF(2, NERR) = SRC
08939                   ERRIBUF(3, NERR) = DEST
08940                   ERRIBUF(4, NERR) = I
08941                   ERRIBUF(5, NERR) = IPRE - I + 1
08942                   ERRIBUF(6, NERR) = ERR_PRE
08943                   ERRDBUF(1, NERR) = MEM(I)
08944                   ERRDBUF(2, NERR) = CHECKVAL
08945                END IF
08946             END IF
08947    10    CONTINUE
08948       END IF
08949 *
08950 *     Check buffer behind A
08951 *
08952       IF( IPOST .GT. 0 ) THEN
08953          J = IPRE + LDA*N + 1
08954          DO 20 I = J, J+IPOST-1
08955             IF( MEM(I) .NE. CHECKVAL ) THEN
08956                NERR = NERR + 1
08957                IF( NERR .LE. MAXERR ) THEN
08958                   ERRIBUF(1, NERR) = TESTNUM
08959                   ERRIBUF(2, NERR) = SRC
08960                   ERRIBUF(3, NERR) = DEST
08961                   ERRIBUF(4, NERR) = I - J + 1
08962                   ERRIBUF(5, NERR) = J
08963                   ERRIBUF(6, NERR) = ERR_POST
08964                   ERRDBUF(1, NERR) = MEM(I)
08965                   ERRDBUF(2, NERR) = CHECKVAL
08966                END IF
08967             END IF
08968    20    CONTINUE
08969       END IF
08970 *
08971 *     Check all (LDA-M) gaps
08972 *
08973       IF( LDA .GT. M ) THEN
08974          DO 40 J = 1, N
08975             DO 30 I = M+1, LDA
08976                K = IPRE + (J-1)*LDA + I
08977                IF( MEM(K) .NE. CHECKVAL) THEN
08978                   NERR = NERR + 1
08979                   IF( NERR .LE. MAXERR ) THEN
08980                      ERRIBUF(1, NERR) = TESTNUM
08981                      ERRIBUF(2, NERR) = SRC
08982                      ERRIBUF(3, NERR) = DEST
08983                      ERRIBUF(4, NERR) = I
08984                      ERRIBUF(5, NERR) = J
08985                      ERRIBUF(6, NERR) = ERR_GAP
08986                      ERRDBUF(1, NERR) = MEM(K)
08987                      ERRDBUF(2, NERR) = CHECKVAL
08988                   END IF
08989                END IF
08990    30       CONTINUE
08991    40    CONTINUE
08992       END IF
08993 *
08994 *     Determine limits of trapezoidal matrix
08995 *
08996       ISTRAP = .FALSE.
08997       IF( UPLO .EQ. 'U' ) THEN
08998          ISTRAP = .TRUE.
08999          IF( M .LE. N ) THEN
09000             IRST = 2
09001             IRND = M
09002             ICST = 1
09003             ICND = M - 1
09004          ELSEIF( M .GT. N ) THEN
09005             IRST = ( M-N ) + 2
09006             IRND = M
09007             ICST = 1
09008             ICND = N - 1
09009          ENDIF
09010          IF( DIAG .EQ. 'U' ) THEN
09011             IRST = IRST - 1
09012             ICND = ICND + 1
09013          ENDIF
09014       ELSE IF( UPLO .EQ. 'L' ) THEN
09015          ISTRAP = .TRUE.
09016          IF( M .LE. N ) THEN
09017             IRST = 1
09018             IRND = 1
09019             ICST = ( N-M ) + 2
09020             ICND = N
09021          ELSEIF( M .GT. N ) THEN
09022             IRST = 1
09023             IRND = 1
09024             ICST = 2
09025             ICND = N
09026          ENDIF
09027          IF( DIAG .EQ. 'U' ) THEN
09028             ICST = ICST - 1
09029          ENDIF
09030       ENDIF
09031 *
09032 *     Check elements and report any errors
09033 *
09034       IF( ISTRAP ) THEN
09035          DO 100 J = ICST, ICND
09036             DO 105 I = IRST, IRND
09037                IF( MEM( IPRE + (J-1)*LDA + I ) .NE. CHECKVAL ) THEN
09038                   NERR = NERR + 1
09039                   IF( NERR .LE. MAXERR ) THEN
09040                      ERRIBUF(1, NERR) = TESTNUM
09041                      ERRIBUF(2, NERR) = SRC
09042                      ERRIBUF(3, NERR) = DEST
09043                      ERRIBUF(4, NERR) = I
09044                      ERRIBUF(5, NERR) = J
09045                      ERRIBUF(6, NERR) = ERR_TRI
09046                      ERRDBUF(1, NERR) = MEM( IPRE + (J-1)*LDA + I )
09047                      ERRDBUF(2, NERR) = CHECKVAL
09048                   END IF
09049                END IF
09050   105       CONTINUE
09051 *
09052 *           Update the limits to allow filling in padding
09053 *
09054             IF( UPLO .EQ. 'U' ) THEN
09055                IRST = IRST + 1
09056             ELSE
09057                IRND = IRND + 1
09058             ENDIF
09059   100    CONTINUE
09060       END IF
09061 *
09062       RETURN
09063 *
09064 *     End of DCHKPAD.
09065 *
09066       END
09067 *
09068       SUBROUTINE DCHKMAT( UPLO, DIAG, M, N, A, LDA, RSRC, CSRC,
09069      $                    MYROW, MYCOL, TESTNUM, MAXERR, NERR,
09070      $                    ERRIBUF, ERRDBUF )
09071 *
09072 *  -- BLACS tester (version 1.0) --
09073 *  University of Tennessee
09074 *  December 15, 1994
09075 *
09076 *
09077 *     .. Scalar Arguments ..
09078       CHARACTER*1 UPLO, DIAG
09079       INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, TESTNUM
09080       INTEGER MAXERR, NERR
09081 *     ..
09082 *     .. Array Arguments ..
09083       INTEGER ERRIBUF(6, MAXERR)
09084       DOUBLE PRECISION A(LDA,N), ERRDBUF(2, MAXERR)
09085 *     ..
09086 *
09087 *  Purpose
09088 *  =======
09089 *  dCHKMAT:  Check matrix to see whether there were any transmission
09090 *            errors.
09091 *
09092 *  Arguments
09093 *  =========
09094 *  UPLO     (input) CHARACTER*1
09095 *           Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
09096 *           rectangular?
09097 *
09098 *  DIAG     (input) CHARACTER*1
09099 *           For trapezoidal matrices, is the main diagonal included
09100 *           ('N') or not ('U')?
09101 *
09102 *   M       (input) INTEGER
09103 *           The number of rows of the matrix A.  M >= 0.
09104 *
09105 *   N       (input) INTEGER
09106 *           The number of columns of the matrix A.  N >= 0.
09107 *
09108 *   A       (input) @up@(doctype) array, dimension (LDA,N)
09109 *           The m by n matrix A.  Fortran77 (column-major) storage
09110 *           assumed.
09111 *
09112 *   LDA     (input) INTEGER
09113 *           The leading dimension of the array A.  LDA >= max(1, M).
09114 *
09115 *  RSRC     (input) INTEGER
09116 *           The process row of the source of the matrix.
09117 *
09118 *  CSRC     (input) INTEGER
09119 *           The process column of the source of the matrix.
09120 *
09121 *  MYROW    (input) INTEGER
09122 *           Row of this process in the process grid.
09123 *
09124 *  MYCOL    (input) INTEGER
09125 *           Column of this process in the process grid.
09126 *
09127 *
09128 *  TESTNUM  (input) INTEGER
09129 *           The number of the test being checked.
09130 *
09131 *  MAXERR   (input) INTEGER
09132 *           Max number of errors that can be stored in ERRIBUFF or
09133 *           ERRDBUFF
09134 *
09135 *  NERR     (output) INTEGER
09136 *           The number of errors that have been found.
09137 *
09138 *  ERRIBUF  (output) INTEGER array, dimension (6,MAXERRS)
09139 *           Buffer in which to store integer error information.  It will
09140 *           be built up in the following format for the call to TSEND.
09141 *           All integer information is recorded in the following 6-tuple
09142 *           {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
09143 *             SRC = RSRC * NPROCS + CSRC
09144 *             DEST = RDEST * NPROCS + CDEST
09145 *             WHAT
09146 *              = 1 : Error in pre-padding
09147 *              = 2 : Error in post-padding
09148 *              = 3 : Error in LDA-M gap
09149 *              = 4 : Error in complementory triangle
09150 *              ELSE: Error in matrix
09151 *           If there are more errors than can fit in the error buffer,
09152 *           the error number will indicate the actual number of errors
09153 *           found, but the buffer will be truncated to the maximum
09154 *           number of errors which can fit.
09155 *
09156 *  ERRDBUF  (output) @(doctype) array, dimension (2, MAXERRS)
09157 *           Buffer in which to store error data information.
09158 *           {Incorrect, Predicted}
09159 *
09160 *  ===================================================================
09161 *
09162 *     .. Local Scalars ..
09163       INTEGER I, J, NPROCS, SRC, DEST
09164       LOGICAL USEIT
09165       DOUBLE PRECISION COMPVAL
09166 *     ..
09167 *     .. Local Arrays ..
09168       INTEGER ISEED(4)
09169 *     ..
09170 *     .. External Functions ..
09171       INTEGER IBTNPROCS
09172       DOUBLE PRECISION DBTRAN
09173       EXTERNAL DBTRAN, IBTNPROCS
09174 *     ..
09175 *     .. Executable Statements ..
09176 *
09177       NPROCS = IBTNPROCS()
09178       SRC = RSRC * NPROCS + CSRC
09179       DEST = MYROW * NPROCS + MYCOL
09180 *
09181 *     Initialize ISEED with the same values as used in DGENMAT.
09182 *
09183       ISEED(1) = MOD( 1002 + TESTNUM*5 + SRC*3, 4096 )
09184       ISEED(2) = MOD( 2027 + TESTNUM*7 + SRC, 4096 )
09185       ISEED(3) = MOD( 1234 + TESTNUM + SRC*3, 4096 )
09186       ISEED(4) = MOD( 4311 + TESTNUM*10 + SRC*2, 4096 )
09187 *
09188 *     Generate the elements randomly with the same method used in GENMAT.
09189 *     Note that for trapezoidal matrices, we generate all elements in the
09190 *     enclosing rectangle and then ignore the complementary triangle.
09191 *
09192       DO 100 J = 1, N
09193          DO 105 I = 1, M
09194             COMPVAL = DBTRAN( ISEED )
09195 *
09196 *           Now determine whether we actually need this value.  The
09197 *           strategy is to chop out the proper triangle based on what
09198 *           particular kind of trapezoidal matrix we're dealing with.
09199 *
09200             USEIT = .TRUE.
09201             IF( UPLO .EQ. 'U' ) THEN
09202                IF( M .LE. N ) THEN
09203                   IF( DIAG .EQ. 'U' ) THEN
09204                      IF( I .GE. J ) THEN
09205                         USEIT = .FALSE.
09206                      END IF
09207                   ELSE
09208                      IF( I .GT. J ) THEN
09209                         USEIT = .FALSE.
09210                      END IF
09211                   END IF
09212                ELSE
09213                   IF( DIAG .EQ. 'U' ) THEN
09214                      IF( I .GE. M-N+J ) THEN
09215                         USEIT = .FALSE.
09216                      END IF
09217                   ELSE
09218                      IF( I .GT. M-N+J ) THEN
09219                         USEIT = .FALSE.
09220                      END IF
09221                   END IF
09222                END IF
09223             ELSE IF( UPLO .EQ. 'L' ) THEN
09224                IF( M .LE. N ) THEN
09225                   IF( DIAG .EQ. 'U' ) THEN
09226                      IF( J. GE. I+(N-M) ) THEN
09227                         USEIT = .FALSE.
09228                      END IF
09229                   ELSE
09230                      IF( J .GT. I+(N-M) ) THEN
09231                         USEIT = .FALSE.
09232                      END IF
09233                   END IF
09234                ELSE
09235                   IF( DIAG .EQ. 'U' ) THEN
09236                      IF( J .GE. I ) THEN
09237                         USEIT = .FALSE.
09238                      END IF
09239                   ELSE
09240                      IF( J .GT. I ) THEN
09241                         USEIT = .FALSE.
09242                      END IF
09243                   END IF
09244                END IF
09245             END IF
09246 *
09247 *           Compare the generated value to the one that's in the
09248 *           received matrix.  If they don't match, tack another
09249 *           error record onto what's already there.
09250 *
09251             IF( USEIT ) THEN
09252                IF( A(I,J) .NE. COMPVAL ) THEN
09253                   NERR = NERR + 1
09254                   IF( NERR .LE. MAXERR ) THEN
09255                      ERRIBUF(1, NERR) = TESTNUM
09256                      ERRIBUF(2, NERR) = SRC
09257                      ERRIBUF(3, NERR) = DEST
09258                      ERRIBUF(4, NERR) = I
09259                      ERRIBUF(5, NERR) = J
09260                      ERRIBUF(6, NERR) = 5
09261                      ERRDBUF(1, NERR) = A(I, J)
09262                      ERRDBUF(2, NERR) = COMPVAL
09263                   END IF
09264                END IF
09265             END IF
09266   105    CONTINUE
09267   100 CONTINUE
09268       RETURN
09269 *
09270 *     End of DCHKMAT.
09271 *
09272       END
09273 *
09274       SUBROUTINE DPRINTERRS( OUTNUM, MAXERR, NERR,
09275      $                       ERRIBUF, ERRDBUF, COUNTING, TFAILED )
09276 *
09277 *  -- BLACS tester (version 1.0) --
09278 *  University of Tennessee
09279 *  December 15, 1994
09280 *
09281 *
09282 *     .. Scalar Arguments ..
09283       LOGICAL COUNTING
09284       INTEGER OUTNUM, MAXERR, NERR
09285 *     ..
09286 *     .. Array Arguments ..
09287       INTEGER ERRIBUF(6, MAXERR), TFAILED(*)
09288       DOUBLE PRECISION ERRDBUF(2, MAXERR)
09289 *     ..
09290 *
09291 *  Purpose
09292 *  =======
09293 *  DPRINTERRS: Print errors that have been recorded
09294 *
09295 *  Arguments
09296 *  =========
09297 *  OUTNUM   (input) INTEGER
09298 *           Device number for output.
09299 *
09300 *  MAXERR   (input) INTEGER
09301 *           Max number of errors that can be stored in ERRIBUFF or
09302 *           ERRDBUFF
09303 *
09304 *  NERR     (output) INTEGER
09305 *           The number of errors that have been found.
09306 *
09307 *  ERRIBUF  (output) INTEGER array, dimension (6,MAXERRS)
09308 *           Buffer in which to store integer error information.  It will
09309 *           be built up in the following format for the call to TSEND.
09310 *           All integer information is recorded in the following 6-tuple
09311 *           {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
09312 *             SRC = RSRC * NPROCS + CSRC
09313 *             DEST = RDEST * NPROCS + CDEST
09314 *             WHAT
09315 *              = 1 : Error in pre-padding
09316 *              = 2 : Error in post-padding
09317 *              = 3 : Error in LDA-M gap
09318 *              = 4 : Error in complementory triangle
09319 *              ELSE: Error in matrix
09320 *           If there are more errors than can fit in the error buffer,
09321 *           the error number will indicate the actual number of errors
09322 *           found, but the buffer will be truncated to the maximum
09323 *           number of errors which can fit.
09324 *
09325 *  ERRDBUF  (output) @(doctype) array, dimension (2, MAXERRS)
09326 *           Buffer in which to store error data information.
09327 *           {Incorrect, Predicted}
09328 *
09329 *  TFAILED (input/ourput) INTEGER array, dimension NTESTS
09330 *          Workspace used to keep track of which tests failed.
09331 *          This array not accessed unless COUNTING is true.
09332 *
09333 *  ===================================================================
09334 *
09335 *     .. Parameters ..
09336       INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
09337       PARAMETER( ERR_PRE = 1, ERR_POST = 2, ERR_GAP = 3, ERR_TRI = 4 )
09338       PARAMETER( ERR_MAT = 5 )
09339 *     ..
09340 *     .. External Functions ..
09341       INTEGER IBTMYPROC, IBTNPROCS
09342       EXTERNAL IBTMYPROC, IBTNPROCS
09343 *     ..
09344 *     .. Local Scalars ..
09345       CHARACTER*1 MAT
09346       LOGICAL MATISINT
09347       INTEGER OLDTEST, NPROCS, PROW, PCOL, I, ERRTYPE
09348 *     ..
09349 *     .. Executable Statements ..
09350 *
09351       IF( (IBTMYPROC().NE.0) .OR. (NERR.LE.0) ) RETURN
09352       OLDTEST = -1
09353       NPROCS = IBTNPROCS()
09354       PROW = ERRIBUF(3,1) / NPROCS
09355       PCOL = MOD( ERRIBUF(3,1), NPROCS )
09356       IF( NERR .GT. MAXERR ) WRITE(OUTNUM,13000)
09357 *
09358       DO 20 I = 1, MIN( NERR, MAXERR )
09359          IF( ERRIBUF(1,I) .NE. OLDTEST ) THEN
09360             IF( OLDTEST .NE. -1 )
09361      $         WRITE(OUTNUM,12000) PROW, PCOL, OLDTEST
09362             WRITE(OUTNUM,*) '  '
09363             WRITE(OUTNUM,1000) PROW, PCOL, ERRIBUF(1,I)
09364             IF( COUNTING ) TFAILED( ERRIBUF(1,I) ) = 1
09365             OLDTEST = ERRIBUF(1, I)
09366          END IF
09367 *
09368 *        Print out error message depending on type of error
09369 *
09370          ERRTYPE = ERRIBUF(6, I)
09371          IF( ERRTYPE .LT. -10 ) THEN
09372             ERRTYPE = -ERRTYPE - 10
09373             MAT = 'C'
09374             MATISINT = .TRUE.
09375          ELSE IF( ERRTYPE .LT. 0 ) THEN
09376             ERRTYPE = -ERRTYPE
09377             MAT = 'R'
09378             MATISINT = .TRUE.
09379          ELSE
09380             MATISINT = .FALSE.
09381          END IF
09382 *
09383 *        RA/CA arrays from MAX/MIN have different printing protocol
09384 *
09385          IF( MATISINT ) THEN
09386             IF( ERRIBUF(2, I) .EQ. -1 ) THEN
09387                WRITE(OUTNUM,11000) ERRIBUF(4,I), ERRIBUF(5,I), MAT,
09388      $            INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) )
09389             ELSE IF( ERRTYPE .EQ. ERR_PRE ) THEN
09390                WRITE(OUTNUM,7000) ERRIBUF(5,I), MAT,
09391      $            INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) )
09392             ELSE IF( ERRTYPE .EQ. ERR_POST ) THEN
09393                WRITE(OUTNUM,8000) ERRIBUF(4,I), MAT,
09394      $            INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) )
09395             ELSE IF( ERRTYPE .EQ. ERR_GAP ) THEN
09396                WRITE(OUTNUM,9000) MAT, ERRIBUF(4,I), ERRIBUF(5,I),
09397      $            INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) )
09398             ELSE
09399                WRITE(OUTNUM,10000) MAT, ERRIBUF(4,I), ERRIBUF(5,I),
09400      $                             INT( ERRDBUF(2,I) ),
09401      $                             INT( ERRDBUF(1,I) )
09402             END IF
09403 *
09404 *        Have memory overwrites in matrix A
09405 *
09406          ELSE
09407             IF( ERRTYPE .EQ. ERR_PRE ) THEN
09408                WRITE(OUTNUM,2000) ERRIBUF(5,I), ERRDBUF(2,I),
09409      $                            ERRDBUF(1,I)
09410             ELSE IF( ERRTYPE .EQ. ERR_POST ) THEN
09411                WRITE(OUTNUM,3000) ERRIBUF(4,I), ERRDBUF(2,I),
09412      $                            ERRDBUF(1,I)
09413             ELSE IF( ERRTYPE .EQ. ERR_GAP ) THEN
09414                WRITE(OUTNUM,4000) ERRIBUF(4,I), ERRIBUF(5,I),
09415      $                            ERRDBUF(2,I), ERRDBUF(1,I)
09416             ELSE IF( ERRTYPE .EQ. ERR_TRI ) THEN
09417                WRITE(OUTNUM,5000) ERRIBUF(4,I), ERRIBUF(5,I),
09418      $                            ERRDBUF(2,I), ERRDBUF(1,I)
09419             ELSE
09420                WRITE(OUTNUM,6000) ERRIBUF(4,I), ERRIBUF(5,I),
09421      $                            ERRDBUF(2,I), ERRDBUF(1,I)
09422             END IF
09423          END IF
09424    20 CONTINUE
09425       WRITE(OUTNUM,12000) PROW, PCOL, OLDTEST
09426 *
09427  1000 FORMAT('PROCESS {',I4,',',I4,'} REPORTS ERRORS IN TEST#',I6,':')
09428  2000 FORMAT('   Buffer overwrite ',I4,
09429      $       ' elements before the start of A:',/,
09430      $       '   Expected=',G22.15,
09431      $       '; Received=',G22.15)
09432  3000 FORMAT('   Buffer overwrite ',I4,' elements after the end of A:',
09433      $       /,'   Expected=',G22.15,
09434      $       '; Received=',G22.15)
09435  4000 FORMAT('   LDA-M gap overwrite at postion (',I4,',',I4,'):',/,
09436      $       '   Expected=',G22.15,
09437      $       '; Received=',G22.15)
09438  5000 FORMAT('   Complementory triangle overwrite at A(',I4,',',I4,
09439      $       '):',/,'   Expected=',G22.15,
09440      $       '; Received=',G22.15)
09441  6000 FORMAT('   Invalid element at A(',I4,',',I4,'):',/,
09442      $       '   Expected=',G22.15,
09443      $       '; Received=',G22.15)
09444  7000 FORMAT('   Buffer overwrite ',I4,' elements before the start of ',
09445      $       A1,'A:',/,'   Expected=',I12,'; Received=',I12)
09446  8000 FORMAT('   Buffer overwrite ',I4,' elements after the end of ',
09447      $       A1,'A:',/,'   Expected=',I12,'; Received=',I12)
09448 *
09449  9000 FORMAT('   LD',A1,'A-M gap overwrite at postion (',I4,',',I4,'):'
09450      $       ,/,'   Expected=',I12,'; Received=',I12)
09451 *
09452 10000 FORMAT('   Invalid element at ',A1,'A(',I4,',',I4,'):',/,
09453      $       '   Expected=',I12,'; Received=',I12)
09454 11000 FORMAT('   Overwrite at position (',I4,',',I4,') of non-existent '
09455      $       ,A1,'A array.',/,'   Expected=',I12,'; Received=',I12)
09456 12000 FORMAT('PROCESS {',I4,',',I4,'} DONE ERROR REPORT FOR TEST#',
09457      $       I6,'.')
09458 13000 FORMAT('WARNING: There were more errors than could be recorded.',
09459      $       /,'Increase MEMELTS to get complete listing.')
09460       RETURN
09461 *
09462 *     End DPRINTERRS
09463 *
09464       END
09465 *
09466 *
09467       SUBROUTINE CBTCHECKIN( NFTESTS, OUTNUM, MAXERR, NERR, IERR,
09468      $                       CVAL, TFAILED )
09469       INTEGER NFTESTS, OUTNUM, MAXERR, NERR
09470       INTEGER IERR(*), TFAILED(*)
09471       COMPLEX CVAL(*)
09472 *
09473 *  Purpose
09474 *  =======
09475 *  CBTCHECKIN: Process 0 receives error report from all processes.
09476 *
09477 *  Arguments
09478 *  =========
09479 *  NFTESTS  (input/output) INTEGER
09480 *           if NFTESTS is <= 0 upon entry, NFTESTS is not written to.
09481 *           Otherwise, on entry it specifies the total number of tests
09482 *           run, and on exit it is the number of tests which failed.
09483 *
09484 *  OUTNUM   (input) INTEGER
09485 *           Device number for output.
09486 *
09487 *  MAXERR   (input) INTEGER
09488 *           Max number of errors that can be stored in ERRIBUFF or
09489 *           ERRCBUFF
09490 *
09491 *  NERR     (output) INTEGER
09492 *           The number of errors that have been found.
09493 *
09494 *  ERRIBUF  (output) INTEGER array, dimension (6,MAXERRS)
09495 *           Buffer in which to store integer error information.  It will
09496 *           be built up in the following format for the call to TSEND.
09497 *           All integer information is recorded in the following 6-tuple
09498 *           {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
09499 *             SRC = RSRC * NPROCS + CSRC
09500 *             DEST = RDEST * NPROCS + CDEST
09501 *             WHAT
09502 *              = 1 : Error in pre-padding
09503 *              = 2 : Error in post-padding
09504 *              = 3 : Error in LDA-M gap
09505 *              = 4 : Error in complementory triangle
09506 *              ELSE: Error in matrix
09507 *           If there are more errors than can fit in the error buffer,
09508 *           the error number will indicate the actual number of errors
09509 *           found, but the buffer will be truncated to the maximum
09510 *           number of errors which can fit.
09511 *
09512 *  ERRDBUF  (output) @(doctype) array, dimension (2, MAXERRS)
09513 *           Buffer in which to store error data information.
09514 *           {Incorrect, Predicted}
09515 *
09516 *  TFAILED (workspace) INTEGER array, dimension NFTESTS
09517 *          Workspace used to keep track of which tests failed.
09518 *          If input of NFTESTS < 1, this array not accessed.
09519 *
09520 *  ===================================================================
09521 *
09522 *     .. External Functions ..
09523       INTEGER  IBTMYPROC, IBTNPROCS, IBTMSGID
09524       EXTERNAL IBTMYPROC, IBTNPROCS, IBTMSGID
09525 *     ..
09526 *     .. Local Scalars ..
09527       LOGICAL COUNTING
09528       INTEGER K, NERR2, IAM, NPROCS, NTESTS
09529 *
09530 *     Proc 0 collects error info from everyone
09531 *
09532       IAM = IBTMYPROC()
09533       NPROCS = IBTNPROCS()
09534 *
09535       IF( IAM .EQ. 0 ) THEN
09536 *
09537 *        If we are finding out how many failed tests there are, initialize
09538 *        the total number of tests (NTESTS), and zero the test failed array
09539 *
09540          COUNTING = NFTESTS .GT. 0
09541          IF( COUNTING ) THEN
09542             NTESTS = NFTESTS
09543             DO 10 K = 1, NTESTS
09544                TFAILED(K) = 0
09545    10       CONTINUE
09546          END IF
09547 *
09548          CALL CPRINTERRS(OUTNUM, MAXERR, NERR, IERR, CVAL, COUNTING,
09549      $                   TFAILED)
09550 *
09551          DO 20 K = 1, NPROCS-1
09552             CALL BTSEND(3, 0, K, K, IBTMSGID()+50)
09553             CALL BTRECV(3, 1, NERR2, K, IBTMSGID()+50)
09554             IF( NERR2 .GT. 0 ) THEN
09555                NERR = NERR + NERR2
09556                CALL BTRECV(3, NERR2*6, IERR, K, IBTMSGID()+51)
09557                CALL BTRECV(5, NERR2*2, CVAL, K, IBTMSGID()+51)
09558                CALL CPRINTERRS(OUTNUM, MAXERR, NERR2, IERR, CVAL,
09559      $                         COUNTING, TFAILED)
09560             END IF
09561    20    CONTINUE
09562 *
09563 *        Count up number of tests that failed
09564 *
09565          IF( COUNTING ) THEN
09566             NFTESTS = 0
09567             DO 30 K = 1, NTESTS
09568                NFTESTS = NFTESTS + TFAILED(K)
09569    30       CONTINUE
09570          END IF
09571 *
09572 *     Send my error info to proc 0
09573 *
09574       ELSE
09575          CALL BTRECV(3, 0, K, 0, IBTMSGID()+50)
09576          CALL BTSEND(3, 1, NERR, 0, IBTMSGID()+50)
09577          IF( NERR .GT. 0 ) THEN
09578             CALL BTSEND(3, NERR*6, IERR, 0, IBTMSGID()+51)
09579             CALL BTSEND(5, NERR*2, CVAL, 0, IBTMSGID()+51)
09580          END IF
09581       ENDIF
09582 *
09583       RETURN
09584 *
09585 *     End of CBTCHECKIN
09586 *
09587       END
09588 *
09589       SUBROUTINE CINITMAT(UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST,
09590      $                    CHECKVAL, TESTNUM, MYROW, MYCOL)
09591       CHARACTER*1 UPLO, DIAG
09592       INTEGER M, N, LDA, IPRE, IPOST, TESTNUM, MYROW, MYCOL
09593       COMPLEX CHECKVAL
09594       COMPLEX MEM(*)
09595 *
09596 *     .. External Subroutines ..
09597       EXTERNAL CGENMAT, CPADMAT
09598 *     ..
09599 *     .. Executable Statements ..
09600 *
09601       CALL CGENMAT( M, N, MEM(IPRE+1), LDA, TESTNUM, MYROW, MYCOL )
09602       CALL CPADMAT( UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST, CHECKVAL )
09603 *
09604       RETURN
09605       END
09606 *
09607       SUBROUTINE CGENMAT( M, N, A, LDA, TESTNUM, MYROW, MYCOL )
09608 *
09609 *  -- BLACS tester (version 1.0) --
09610 *  University of Tennessee
09611 *  December 15, 1994
09612 *
09613 *
09614 *     .. Scalar Arguments ..
09615       INTEGER M, N, LDA, TESTNUM, MYROW, MYCOL
09616 *     ..
09617 *     .. Array Arguments ..
09618       COMPLEX A(LDA,N)
09619 *     ..
09620 *
09621 *  Purpose
09622 *  =======
09623 *  CGENMAT: Generates an M-by-N matrix filled with random elements.
09624 *
09625 *  Arguments
09626 *  =========
09627 *   M       (input) INTEGER
09628 *           The number of rows of the matrix A.  M >= 0.
09629 *
09630 *   N       (input) INTEGER
09631 *           The number of columns of the matrix A.  N >= 0.
09632 *
09633 *   A       (output) @up@(doctype) array, dimension (LDA,N)
09634 *           The m by n matrix A.  Fortran77 (column-major) storage
09635 *           assumed.
09636 *
09637 *   LDA     (input) INTEGER
09638 *           The leading dimension of the array A.  LDA >= max(1, M).
09639 *
09640 *  TESTNUM  (input) INTEGER
09641 *           Unique number for this test case, used as a basis for
09642 *           the random seeds.
09643 *
09644 *  ====================================================================
09645 *
09646 *     .. External Functions ..
09647       INTEGER IBTNPROCS
09648       COMPLEX CBTRAN
09649       EXTERNAL CBTRAN, IBTNPROCS
09650 *     ..
09651 *     .. Local Scalars ..
09652       INTEGER I, J, NPROCS, SRC
09653 *     ..
09654 *     .. Local Arrays ..
09655       INTEGER ISEED(4)
09656 *     ..
09657 *     .. Executable Statements ..
09658 *
09659 *     ISEED's four values must be positive integers less than 4096,
09660 *     fourth one has to be odd. (see _LARND).  Use some goofy
09661 *     functions to come up with seed values which together should
09662 *     be unique.
09663 *
09664       NPROCS = IBTNPROCS()
09665       SRC = MYROW * NPROCS + MYCOL
09666       ISEED(1) = MOD( 1002 + TESTNUM*5 + SRC*3, 4096 )
09667       ISEED(2) = MOD( 2027 + TESTNUM*7 + SRC, 4096 )
09668       ISEED(3) = MOD( 1234 + TESTNUM + SRC*3, 4096 )
09669       ISEED(4) = MOD( 4311 + TESTNUM*10 + SRC*2, 4096 )
09670 *
09671       DO 10 J = 1, N
09672          DO 10 I = 1, M
09673             A(I, J) = CBTRAN( ISEED )
09674    10 CONTINUE
09675 *
09676       RETURN
09677 *
09678 *     End of CGENMAT.
09679 *
09680       END
09681 *
09682       COMPLEX FUNCTION CBTRAN(ISEED)
09683       INTEGER ISEED(*)
09684 *
09685 *     .. External Functions ..
09686       DOUBLE COMPLEX ZLARND
09687       EXTERNAL ZLARND
09688       CBTRAN = CMPLX( ZLARND(2, ISEED) )
09689 *
09690       RETURN
09691 *
09692 *     End of Cbtran
09693 *
09694       END
09695 *
09696       SUBROUTINE CPADMAT( UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST,
09697      $                    CHECKVAL )
09698 *
09699 *  -- BLACS tester (version 1.0) --
09700 *  University of Tennessee
09701 *  December 15, 1994
09702 *
09703 *     .. Scalar Arguments ..
09704       CHARACTER*1 UPLO, DIAG
09705       INTEGER M, N, LDA, IPRE, IPOST
09706       COMPLEX CHECKVAL
09707 *     ..
09708 *     .. Array Arguments ..
09709       COMPLEX MEM( * )
09710 *     ..
09711 *
09712 *  Purpose
09713 *  =======
09714 *
09715 *  CPADMAT: Pad Matrix.
09716 *  This routines surrounds a matrix with a guardzone initialized to the
09717 *  value CHECKVAL.  There are three distinct guardzones:
09718 *  - A contiguous zone of size IPRE immediately before the start
09719 *    of the matrix.
09720 *  - A contiguous zone of size IPOST immedately after the end of the
09721 *    matrix.
09722 *  - Interstitial zones within each column of the matrix, in the
09723 *    elements A( M+1:LDA, J ).
09724 *
09725 *  Arguments
09726 *  =========
09727 *  UPLO     (input) CHARACTER*1
09728 *           Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
09729 *           rectangular?
09730 *
09731 *  DIAG     (input) CHARACTER*1
09732 *           For trapezoidal matrices, is the main diagonal included
09733 *           ('N') or not ('U')?
09734 *
09735 *   M       (input) INTEGER
09736 *           The number of rows of the matrix A.  M >= 0.
09737 *
09738 *   N       (input) INTEGER
09739 *           The number of columns of the matrix A.  N >= 0.
09740 *
09741 *  MEM      (output) complex array, dimension (IPRE+IPOST+LDA*N)
09742 *           The address IPRE elements ahead of the matrix A you want to
09743 *           pad, which is then of dimension (LDA,N).
09744 *
09745 *  IPRE     (input) INTEGER
09746 *           The size of the guard zone ahead of the matrix A.
09747 *
09748 *  IPOST    (input) INTEGER
09749 *           The size of the guard zone behind the matrix A.
09750 *
09751 *  CHECKVAL (input) complex
09752 *           The value to insert into the guard zones.
09753 *
09754 *  ====================================================================
09755 *
09756 *     .. Local Scalars ..
09757       INTEGER I, J, K
09758 *     ..
09759 *     .. Executable Statements ..
09760 *
09761 *     Put check buffer in front of A
09762 *
09763       IF( IPRE .GT. 0 ) THEN
09764          DO 10 I = 1, IPRE
09765             MEM( I ) = CHECKVAL
09766    10    CONTINUE
09767       END IF
09768 *
09769 *     Put check buffer in back of A
09770 *
09771       IF( IPOST .GT. 0 ) THEN
09772          J = IPRE + LDA*N + 1
09773          DO 20 I = J, J+IPOST-1
09774             MEM( I ) = CHECKVAL
09775    20    CONTINUE
09776       END IF
09777 *
09778 *     Put check buffer in all (LDA-M) gaps
09779 *
09780       IF( LDA .GT. M ) THEN
09781          K = IPRE + M + 1
09782          DO 40 J = 1, N
09783             DO 30 I = K, K+LDA-M-1
09784                MEM( I ) = CHECKVAL
09785    30       CONTINUE
09786             K = K + LDA
09787    40    CONTINUE
09788       END IF
09789 *
09790 *     If the matrix is upper or lower trapezoidal, calculate the
09791 *     additional triangular area which needs to be padded,  Each
09792 *     element referred to is in the Ith row and the Jth column.
09793 *
09794       IF( UPLO .EQ. 'U' ) THEN
09795          IF( M .LE. N ) THEN
09796             IF( DIAG .EQ. 'U' ) THEN
09797                DO 41 I = 1, M
09798                   DO 42 J = 1, I
09799                      K = IPRE + I + (J-1)*LDA
09800                      MEM( K ) = CHECKVAL
09801    42             CONTINUE
09802    41          CONTINUE
09803             ELSE
09804                DO 43 I = 2, M
09805                   DO 44 J = 1, I-1
09806                      K = IPRE + I + (J-1)*LDA
09807                      MEM( K ) = CHECKVAL
09808    44             CONTINUE
09809    43          CONTINUE
09810             END IF
09811          ELSE
09812             IF( DIAG .EQ. 'U' ) THEN
09813                DO 45 I = M-N+1, M
09814                   DO 46 J = 1, I-(M-N)
09815                      K = IPRE + I + (J-1)*LDA
09816                      MEM( K ) = CHECKVAL
09817    46             CONTINUE
09818    45          CONTINUE
09819             ELSE
09820                DO 47 I = M-N+2, M
09821                   DO 48 J = 1, I-(M-N)-1
09822                      K = IPRE + I + (J-1)*LDA
09823                      MEM( K ) = CHECKVAL
09824    48             CONTINUE
09825    47          CONTINUE
09826             END IF
09827          END IF
09828       ELSE IF( UPLO .EQ. 'L' ) THEN
09829          IF( M .LE. N ) THEN
09830             IF( DIAG .EQ. 'U' ) THEN
09831                DO 49 I = 1, M
09832                   DO 50 J = N-M+I, N
09833                      K = IPRE + I + (J-1)*LDA
09834                      MEM( K ) = CHECKVAL
09835    50             CONTINUE
09836    49          CONTINUE
09837             ELSE
09838                DO 51 I = 1, M-1
09839                   DO 52 J = N-M+I+1, N
09840                      K = IPRE + I + (J-1)*LDA
09841                      MEM( K ) = CHECKVAL
09842    52             CONTINUE
09843    51          CONTINUE
09844             END IF
09845          ELSE
09846             IF( UPLO .EQ. 'U' ) THEN
09847                DO 53 I = 1, N
09848                   DO 54 J = I, N
09849                      K = IPRE + I + (J-1)*LDA
09850                      MEM( K ) = CHECKVAL
09851    54             CONTINUE
09852    53          CONTINUE
09853             ELSE
09854                DO 55 I = 1, N-1
09855                   DO 56 J = I+1, N
09856                      K = IPRE + I + (J-1)*LDA
09857                      MEM( K ) = CHECKVAL
09858    56             CONTINUE
09859    55          CONTINUE
09860             END IF
09861          END IF
09862       END IF
09863 *
09864 *     End of CPADMAT.
09865 *
09866       RETURN
09867       END
09868 *
09869       SUBROUTINE CCHKPAD( UPLO, DIAG, M, N, MEM, LDA, RSRC, CSRC,
09870      $                    MYROW, MYCOL, IPRE, IPOST, CHECKVAL,
09871      $                    TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF )
09872 *
09873 *  -- BLACS tester (version 1.0) --
09874 *  University of Tennessee
09875 *  December 15, 1994
09876 *
09877 *
09878 *     .. Scalar Arguments ..
09879       CHARACTER*1 UPLO, DIAG
09880       INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, IPRE, IPOST
09881       INTEGER TESTNUM, MAXERR, NERR
09882       COMPLEX CHECKVAL
09883 *     ..
09884 *     .. Array Arguments ..
09885       INTEGER ERRIBUF(6, MAXERR)
09886       COMPLEX MEM(*), ERRDBUF(2, MAXERR)
09887 *     ..
09888 *
09889 *  Purpose
09890 *  =======
09891 *  CCHKPAD: Check padding put in by PADMAT.
09892 *  Checks that padding around target matrix has not been overwritten
09893 *  by the previous point-to-point or broadcast send.
09894 *
09895 *  Arguments
09896 *  =========
09897 *  UPLO     (input) CHARACTER*1
09898 *           Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
09899 *           rectangular?
09900 *
09901 *  DIAG     (input) CHARACTER*1
09902 *           For trapezoidal matrices, is the main diagonal included
09903 *           ('N') or not ('U')?
09904 *
09905 *   M       (input) INTEGER
09906 *           The number of rows of the matrix A.  M >= 0.
09907 *
09908 *   N       (input) INTEGER
09909 *           The number of columns of the matrix A.  N >= 0.
09910 *
09911 *  MEM       (input) complex array, dimension(IPRE+IPOST+LDA*N).
09912 *            Memory location IPRE elements in front of the matrix A.
09913 *
09914 *   LDA     (input) INTEGER
09915 *           The leading dimension of the array A.  LDA >= max(1, M).
09916 *
09917 *  RSRC     (input) INTEGER
09918 *           The process row of the source of the matrix.
09919 *
09920 *  CSRC     (input) INTEGER
09921 *           The process column of the source of the matrix.
09922 *
09923 *  MYROW    (input) INTEGER
09924 *           Row of this process in the process grid.
09925 *
09926 *  MYCOL    (input) INTEGER
09927 *           Column of this process in the process grid.
09928 *
09929 *  IPRE     (input) INTEGER
09930 *           The size of the guard zone before the start of A.
09931 *
09932 *  IPOST    (input) INTEGER
09933 *           The size of guard zone after A.
09934 *
09935 *  CHECKVAL (input) complex
09936 *           The value to pad matrix with.
09937 *
09938 *  TESTNUM  (input) INTEGER
09939 *           The number of the test being checked.
09940 *
09941 *  MAXERR   (input) INTEGER
09942 *           Max number of errors that can be stored in ERRIBUFF or
09943 *           ERRCBUFF
09944 *
09945 *  NERR     (output) INTEGER
09946 *           The number of errors that have been found.
09947 *
09948 *  ERRIBUF  (output) INTEGER array, dimension (6,MAXERRS)
09949 *           Buffer in which to store integer error information.  It will
09950 *           be built up in the following format for the call to TSEND.
09951 *           All integer information is recorded in the following 6-tuple
09952 *           {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
09953 *             SRC = RSRC * NPROCS + CSRC
09954 *             DEST = RDEST * NPROCS + CDEST
09955 *             WHAT
09956 *              = 1 : Error in pre-padding
09957 *              = 2 : Error in post-padding
09958 *              = 3 : Error in LDA-M gap
09959 *              = 4 : Error in complementory triangle
09960 *              ELSE: Error in matrix
09961 *           If there are more errors than can fit in the error buffer,
09962 *           the error number will indicate the actual number of errors
09963 *           found, but the buffer will be truncated to the maximum
09964 *           number of errors which can fit.
09965 *
09966 *  ERRDBUF  (output) @(doctype) array, dimension (2, MAXERRS)
09967 *           Buffer in which to store error data information.
09968 *           {Incorrect, Predicted}
09969 *
09970 *  ===================================================================
09971 *
09972 *     .. Parameters ..
09973       INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
09974       PARAMETER( ERR_PRE = 1, ERR_POST = 2, ERR_GAP = 3, ERR_TRI = 4 )
09975       PARAMETER( ERR_MAT = 5 )
09976 *     ..
09977 *     .. External Functions ..
09978       INTEGER IBTNPROCS
09979       EXTERNAL IBTNPROCS
09980 *     ..
09981 *     .. Local Scalars ..
09982       LOGICAL ISTRAP
09983       INTEGER I, J, K, IRST, IRND, ICST, ICND, SRC, DEST
09984       INTEGER NPROCS
09985 *     ..
09986 *     .. Executable Statements ..
09987 *
09988       NPROCS = IBTNPROCS()
09989       SRC = RSRC * NPROCS + CSRC
09990       DEST = MYROW * NPROCS + MYCOL
09991 *
09992 *     Check buffer in front of A
09993 *
09994       IF( IPRE .GT. 0 ) THEN
09995          DO 10 I = 1, IPRE
09996             IF( MEM(I) .NE. CHECKVAL ) THEN
09997                NERR = NERR + 1
09998                IF( NERR .LE. MAXERR ) THEN
09999                   ERRIBUF(1, NERR) = TESTNUM
10000                   ERRIBUF(2, NERR) = SRC
10001                   ERRIBUF(3, NERR) = DEST
10002                   ERRIBUF(4, NERR) = I
10003                   ERRIBUF(5, NERR) = IPRE - I + 1
10004                   ERRIBUF(6, NERR) = ERR_PRE
10005                   ERRDBUF(1, NERR) = MEM(I)
10006                   ERRDBUF(2, NERR) = CHECKVAL
10007                END IF
10008             END IF
10009    10    CONTINUE
10010       END IF
10011 *
10012 *     Check buffer behind A
10013 *
10014       IF( IPOST .GT. 0 ) THEN
10015          J = IPRE + LDA*N + 1
10016          DO 20 I = J, J+IPOST-1
10017             IF( MEM(I) .NE. CHECKVAL ) THEN
10018                NERR = NERR + 1
10019                IF( NERR .LE. MAXERR ) THEN
10020                   ERRIBUF(1, NERR) = TESTNUM
10021                   ERRIBUF(2, NERR) = SRC
10022                   ERRIBUF(3, NERR) = DEST
10023                   ERRIBUF(4, NERR) = I - J + 1
10024                   ERRIBUF(5, NERR) = J
10025                   ERRIBUF(6, NERR) = ERR_POST
10026                   ERRDBUF(1, NERR) = MEM(I)
10027                   ERRDBUF(2, NERR) = CHECKVAL
10028                END IF
10029             END IF
10030    20    CONTINUE
10031       END IF
10032 *
10033 *     Check all (LDA-M) gaps
10034 *
10035       IF( LDA .GT. M ) THEN
10036          DO 40 J = 1, N
10037             DO 30 I = M+1, LDA
10038                K = IPRE + (J-1)*LDA + I
10039                IF( MEM(K) .NE. CHECKVAL) THEN
10040                   NERR = NERR + 1
10041                   IF( NERR .LE. MAXERR ) THEN
10042                      ERRIBUF(1, NERR) = TESTNUM
10043                      ERRIBUF(2, NERR) = SRC
10044                      ERRIBUF(3, NERR) = DEST
10045                      ERRIBUF(4, NERR) = I
10046                      ERRIBUF(5, NERR) = J
10047                      ERRIBUF(6, NERR) = ERR_GAP
10048                      ERRDBUF(1, NERR) = MEM(K)
10049                      ERRDBUF(2, NERR) = CHECKVAL
10050                   END IF
10051                END IF
10052    30       CONTINUE
10053    40    CONTINUE
10054       END IF
10055 *
10056 *     Determine limits of trapezoidal matrix
10057 *
10058       ISTRAP = .FALSE.
10059       IF( UPLO .EQ. 'U' ) THEN
10060          ISTRAP = .TRUE.
10061          IF( M .LE. N ) THEN
10062             IRST = 2
10063             IRND = M
10064             ICST = 1
10065             ICND = M - 1
10066          ELSEIF( M .GT. N ) THEN
10067             IRST = ( M-N ) + 2
10068             IRND = M
10069             ICST = 1
10070             ICND = N - 1
10071          ENDIF
10072          IF( DIAG .EQ. 'U' ) THEN
10073             IRST = IRST - 1
10074             ICND = ICND + 1
10075          ENDIF
10076       ELSE IF( UPLO .EQ. 'L' ) THEN
10077          ISTRAP = .TRUE.
10078          IF( M .LE. N ) THEN
10079             IRST = 1
10080             IRND = 1
10081             ICST = ( N-M ) + 2
10082             ICND = N
10083          ELSEIF( M .GT. N ) THEN
10084             IRST = 1
10085             IRND = 1
10086             ICST = 2
10087             ICND = N
10088          ENDIF
10089          IF( DIAG .EQ. 'U' ) THEN
10090             ICST = ICST - 1
10091          ENDIF
10092       ENDIF
10093 *
10094 *     Check elements and report any errors
10095 *
10096       IF( ISTRAP ) THEN
10097          DO 100 J = ICST, ICND
10098             DO 105 I = IRST, IRND
10099                IF( MEM( IPRE + (J-1)*LDA + I ) .NE. CHECKVAL ) THEN
10100                   NERR = NERR + 1
10101                   IF( NERR .LE. MAXERR ) THEN
10102                      ERRIBUF(1, NERR) = TESTNUM
10103                      ERRIBUF(2, NERR) = SRC
10104                      ERRIBUF(3, NERR) = DEST
10105                      ERRIBUF(4, NERR) = I
10106                      ERRIBUF(5, NERR) = J
10107                      ERRIBUF(6, NERR) = ERR_TRI
10108                      ERRDBUF(1, NERR) = MEM( IPRE + (J-1)*LDA + I )
10109                      ERRDBUF(2, NERR) = CHECKVAL
10110                   END IF
10111                END IF
10112   105       CONTINUE
10113 *
10114 *           Update the limits to allow filling in padding
10115 *
10116             IF( UPLO .EQ. 'U' ) THEN
10117                IRST = IRST + 1
10118             ELSE
10119                IRND = IRND + 1
10120             ENDIF
10121   100    CONTINUE
10122       END IF
10123 *
10124       RETURN
10125 *
10126 *     End of CCHKPAD.
10127 *
10128       END
10129 *
10130       SUBROUTINE CCHKMAT( UPLO, DIAG, M, N, A, LDA, RSRC, CSRC,
10131      $                    MYROW, MYCOL, TESTNUM, MAXERR, NERR,
10132      $                    ERRIBUF, ERRDBUF )
10133 *
10134 *  -- BLACS tester (version 1.0) --
10135 *  University of Tennessee
10136 *  December 15, 1994
10137 *
10138 *
10139 *     .. Scalar Arguments ..
10140       CHARACTER*1 UPLO, DIAG
10141       INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, TESTNUM
10142       INTEGER MAXERR, NERR
10143 *     ..
10144 *     .. Array Arguments ..
10145       INTEGER ERRIBUF(6, MAXERR)
10146       COMPLEX A(LDA,N), ERRDBUF(2, MAXERR)
10147 *     ..
10148 *
10149 *  Purpose
10150 *  =======
10151 *  cCHKMAT:  Check matrix to see whether there were any transmission
10152 *            errors.
10153 *
10154 *  Arguments
10155 *  =========
10156 *  UPLO     (input) CHARACTER*1
10157 *           Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
10158 *           rectangular?
10159 *
10160 *  DIAG     (input) CHARACTER*1
10161 *           For trapezoidal matrices, is the main diagonal included
10162 *           ('N') or not ('U')?
10163 *
10164 *   M       (input) INTEGER
10165 *           The number of rows of the matrix A.  M >= 0.
10166 *
10167 *   N       (input) INTEGER
10168 *           The number of columns of the matrix A.  N >= 0.
10169 *
10170 *   A       (input) @up@(doctype) array, dimension (LDA,N)
10171 *           The m by n matrix A.  Fortran77 (column-major) storage
10172 *           assumed.
10173 *
10174 *   LDA     (input) INTEGER
10175 *           The leading dimension of the array A.  LDA >= max(1, M).
10176 *
10177 *  RSRC     (input) INTEGER
10178 *           The process row of the source of the matrix.
10179 *
10180 *  CSRC     (input) INTEGER
10181 *           The process column of the source of the matrix.
10182 *
10183 *  MYROW    (input) INTEGER
10184 *           Row of this process in the process grid.
10185 *
10186 *  MYCOL    (input) INTEGER
10187 *           Column of this process in the process grid.
10188 *
10189 *
10190 *  TESTNUM  (input) INTEGER
10191 *           The number of the test being checked.
10192 *
10193 *  MAXERR   (input) INTEGER
10194 *           Max number of errors that can be stored in ERRIBUFF or
10195 *           ERRCBUFF
10196 *
10197 *  NERR     (output) INTEGER
10198 *           The number of errors that have been found.
10199 *
10200 *  ERRIBUF  (output) INTEGER array, dimension (6,MAXERRS)
10201 *           Buffer in which to store integer error information.  It will
10202 *           be built up in the following format for the call to TSEND.
10203 *           All integer information is recorded in the following 6-tuple
10204 *           {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
10205 *             SRC = RSRC * NPROCS + CSRC
10206 *             DEST = RDEST * NPROCS + CDEST
10207 *             WHAT
10208 *              = 1 : Error in pre-padding
10209 *              = 2 : Error in post-padding
10210 *              = 3 : Error in LDA-M gap
10211 *              = 4 : Error in complementory triangle
10212 *              ELSE: Error in matrix
10213 *           If there are more errors than can fit in the error buffer,
10214 *           the error number will indicate the actual number of errors
10215 *           found, but the buffer will be truncated to the maximum
10216 *           number of errors which can fit.
10217 *
10218 *  ERRDBUF  (output) @(doctype) array, dimension (2, MAXERRS)
10219 *           Buffer in which to store error data information.
10220 *           {Incorrect, Predicted}
10221 *
10222 *  ===================================================================
10223 *
10224 *     .. Local Scalars ..
10225       INTEGER I, J, NPROCS, SRC, DEST
10226       LOGICAL USEIT
10227       COMPLEX COMPVAL
10228 *     ..
10229 *     .. Local Arrays ..
10230       INTEGER ISEED(4)
10231 *     ..
10232 *     .. External Functions ..
10233       INTEGER IBTNPROCS
10234       COMPLEX CBTRAN
10235       EXTERNAL CBTRAN, IBTNPROCS
10236 *     ..
10237 *     .. Executable Statements ..
10238 *
10239       NPROCS = IBTNPROCS()
10240       SRC = RSRC * NPROCS + CSRC
10241       DEST = MYROW * NPROCS + MYCOL
10242 *
10243 *     Initialize ISEED with the same values as used in CGENMAT.
10244 *
10245       ISEED(1) = MOD( 1002 + TESTNUM*5 + SRC*3, 4096 )
10246       ISEED(2) = MOD( 2027 + TESTNUM*7 + SRC, 4096 )
10247       ISEED(3) = MOD( 1234 + TESTNUM + SRC*3, 4096 )
10248       ISEED(4) = MOD( 4311 + TESTNUM*10 + SRC*2, 4096 )
10249 *
10250 *     Generate the elements randomly with the same method used in GENMAT.
10251 *     Note that for trapezoidal matrices, we generate all elements in the
10252 *     enclosing rectangle and then ignore the complementary triangle.
10253 *
10254       DO 100 J = 1, N
10255          DO 105 I = 1, M
10256             COMPVAL = CBTRAN( ISEED )
10257 *
10258 *           Now determine whether we actually need this value.  The
10259 *           strategy is to chop out the proper triangle based on what
10260 *           particular kind of trapezoidal matrix we're dealing with.
10261 *
10262             USEIT = .TRUE.
10263             IF( UPLO .EQ. 'U' ) THEN
10264                IF( M .LE. N ) THEN
10265                   IF( DIAG .EQ. 'U' ) THEN
10266                      IF( I .GE. J ) THEN
10267                         USEIT = .FALSE.
10268                      END IF
10269                   ELSE
10270                      IF( I .GT. J ) THEN
10271                         USEIT = .FALSE.
10272                      END IF
10273                   END IF
10274                ELSE
10275                   IF( DIAG .EQ. 'U' ) THEN
10276                      IF( I .GE. M-N+J ) THEN
10277                         USEIT = .FALSE.
10278                      END IF
10279                   ELSE
10280                      IF( I .GT. M-N+J ) THEN
10281                         USEIT = .FALSE.
10282                      END IF
10283                   END IF
10284                END IF
10285             ELSE IF( UPLO .EQ. 'L' ) THEN
10286                IF( M .LE. N ) THEN
10287                   IF( DIAG .EQ. 'U' ) THEN
10288                      IF( J. GE. I+(N-M) ) THEN
10289                         USEIT = .FALSE.
10290                      END IF
10291                   ELSE
10292                      IF( J .GT. I+(N-M) ) THEN
10293                         USEIT = .FALSE.
10294                      END IF
10295                   END IF
10296                ELSE
10297                   IF( DIAG .EQ. 'U' ) THEN
10298                      IF( J .GE. I ) THEN
10299                         USEIT = .FALSE.
10300                      END IF
10301                   ELSE
10302                      IF( J .GT. I ) THEN
10303                         USEIT = .FALSE.
10304                      END IF
10305                   END IF
10306                END IF
10307             END IF
10308 *
10309 *           Compare the generated value to the one that's in the
10310 *           received matrix.  If they don't match, tack another
10311 *           error record onto what's already there.
10312 *
10313             IF( USEIT ) THEN
10314                IF( A(I,J) .NE. COMPVAL ) THEN
10315                   NERR = NERR + 1
10316                   IF( NERR .LE. MAXERR ) THEN
10317                      ERRIBUF(1, NERR) = TESTNUM
10318                      ERRIBUF(2, NERR) = SRC
10319                      ERRIBUF(3, NERR) = DEST
10320                      ERRIBUF(4, NERR) = I
10321                      ERRIBUF(5, NERR) = J
10322                      ERRIBUF(6, NERR) = 5
10323                      ERRDBUF(1, NERR) = A(I, J)
10324                      ERRDBUF(2, NERR) = COMPVAL
10325                   END IF
10326                END IF
10327             END IF
10328   105    CONTINUE
10329   100 CONTINUE
10330       RETURN
10331 *
10332 *     End of CCHKMAT.
10333 *
10334       END
10335 *
10336       SUBROUTINE CPRINTERRS( OUTNUM, MAXERR, NERR,
10337      $                       ERRIBUF, ERRDBUF, COUNTING, TFAILED )
10338 *
10339 *  -- BLACS tester (version 1.0) --
10340 *  University of Tennessee
10341 *  December 15, 1994
10342 *
10343 *
10344 *     .. Scalar Arguments ..
10345       LOGICAL COUNTING
10346       INTEGER OUTNUM, MAXERR, NERR
10347 *     ..
10348 *     .. Array Arguments ..
10349       INTEGER ERRIBUF(6, MAXERR), TFAILED(*)
10350       COMPLEX ERRDBUF(2, MAXERR)
10351 *     ..
10352 *
10353 *  Purpose
10354 *  =======
10355 *  CPRINTERRS: Print errors that have been recorded
10356 *
10357 *  Arguments
10358 *  =========
10359 *  OUTNUM   (input) INTEGER
10360 *           Device number for output.
10361 *
10362 *  MAXERR   (input) INTEGER
10363 *           Max number of errors that can be stored in ERRIBUFF or
10364 *           ERRCBUFF
10365 *
10366 *  NERR     (output) INTEGER
10367 *           The number of errors that have been found.
10368 *
10369 *  ERRIBUF  (output) INTEGER array, dimension (6,MAXERRS)
10370 *           Buffer in which to store integer error information.  It will
10371 *           be built up in the following format for the call to TSEND.
10372 *           All integer information is recorded in the following 6-tuple
10373 *           {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
10374 *             SRC = RSRC * NPROCS + CSRC
10375 *             DEST = RDEST * NPROCS + CDEST
10376 *             WHAT
10377 *              = 1 : Error in pre-padding
10378 *              = 2 : Error in post-padding
10379 *              = 3 : Error in LDA-M gap
10380 *              = 4 : Error in complementory triangle
10381 *              ELSE: Error in matrix
10382 *           If there are more errors than can fit in the error buffer,
10383 *           the error number will indicate the actual number of errors
10384 *           found, but the buffer will be truncated to the maximum
10385 *           number of errors which can fit.
10386 *
10387 *  ERRDBUF  (output) @(doctype) array, dimension (2, MAXERRS)
10388 *           Buffer in which to store error data information.
10389 *           {Incorrect, Predicted}
10390 *
10391 *  TFAILED (input/ourput) INTEGER array, dimension NTESTS
10392 *          Workspace used to keep track of which tests failed.
10393 *          This array not accessed unless COUNTING is true.
10394 *
10395 *  ===================================================================
10396 *
10397 *     .. Parameters ..
10398       INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
10399       PARAMETER( ERR_PRE = 1, ERR_POST = 2, ERR_GAP = 3, ERR_TRI = 4 )
10400       PARAMETER( ERR_MAT = 5 )
10401 *     ..
10402 *     .. External Functions ..
10403       INTEGER IBTMYPROC, IBTNPROCS
10404       EXTERNAL IBTMYPROC, IBTNPROCS
10405 *     ..
10406 *     .. Local Scalars ..
10407       CHARACTER*1 MAT
10408       LOGICAL MATISINT
10409       INTEGER OLDTEST, NPROCS, PROW, PCOL, I, ERRTYPE
10410 *     ..
10411 *     .. Executable Statements ..
10412 *
10413       IF( (IBTMYPROC().NE.0) .OR. (NERR.LE.0) ) RETURN
10414       OLDTEST = -1
10415       NPROCS = IBTNPROCS()
10416       PROW = ERRIBUF(3,1) / NPROCS
10417       PCOL = MOD( ERRIBUF(3,1), NPROCS )
10418       IF( NERR .GT. MAXERR ) WRITE(OUTNUM,13000)
10419 *
10420       DO 20 I = 1, MIN( NERR, MAXERR )
10421          IF( ERRIBUF(1,I) .NE. OLDTEST ) THEN
10422             IF( OLDTEST .NE. -1 )
10423      $         WRITE(OUTNUM,12000) PROW, PCOL, OLDTEST
10424             WRITE(OUTNUM,*) '  '
10425             WRITE(OUTNUM,1000) PROW, PCOL, ERRIBUF(1,I)
10426             IF( COUNTING ) TFAILED( ERRIBUF(1,I) ) = 1
10427             OLDTEST = ERRIBUF(1, I)
10428          END IF
10429 *
10430 *        Print out error message depending on type of error
10431 *
10432          ERRTYPE = ERRIBUF(6, I)
10433          IF( ERRTYPE .LT. -10 ) THEN
10434             ERRTYPE = -ERRTYPE - 10
10435             MAT = 'C'
10436             MATISINT = .TRUE.
10437          ELSE IF( ERRTYPE .LT. 0 ) THEN
10438             ERRTYPE = -ERRTYPE
10439             MAT = 'R'
10440             MATISINT = .TRUE.
10441          ELSE
10442             MATISINT = .FALSE.
10443          END IF
10444 *
10445 *        RA/CA arrays from MAX/MIN have different printing protocol
10446 *
10447          IF( MATISINT ) THEN
10448             IF( ERRIBUF(2, I) .EQ. -1 ) THEN
10449                WRITE(OUTNUM,11000) ERRIBUF(4,I), ERRIBUF(5,I), MAT,
10450      $            INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) )
10451             ELSE IF( ERRTYPE .EQ. ERR_PRE ) THEN
10452                WRITE(OUTNUM,7000) ERRIBUF(5,I), MAT,
10453      $            INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) )
10454             ELSE IF( ERRTYPE .EQ. ERR_POST ) THEN
10455                WRITE(OUTNUM,8000) ERRIBUF(4,I), MAT,
10456      $            INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) )
10457             ELSE IF( ERRTYPE .EQ. ERR_GAP ) THEN
10458                WRITE(OUTNUM,9000) MAT, ERRIBUF(4,I), ERRIBUF(5,I),
10459      $            INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) )
10460             ELSE
10461                WRITE(OUTNUM,10000) MAT, ERRIBUF(4,I), ERRIBUF(5,I),
10462      $                             INT( ERRDBUF(2,I) ),
10463      $                             INT( ERRDBUF(1,I) )
10464             END IF
10465 *
10466 *        Have memory overwrites in matrix A
10467 *
10468          ELSE
10469             IF( ERRTYPE .EQ. ERR_PRE ) THEN
10470                WRITE(OUTNUM,2000) ERRIBUF(5,I),
10471      $         REAL( ERRDBUF(2,I) ), AIMAG( ERRDBUF(2,I) ),
10472      $         REAL( ERRDBUF(1,I) ), AIMAG( ERRDBUF(1,I) )
10473             ELSE IF( ERRTYPE .EQ. ERR_POST ) THEN
10474                WRITE(OUTNUM,3000) ERRIBUF(4,I),
10475      $         REAL( ERRDBUF(2,I) ), AIMAG( ERRDBUF(2,I) ),
10476      $         REAL( ERRDBUF(1,I) ), AIMAG( ERRDBUF(1,I) )
10477             ELSE IF( ERRTYPE .EQ. ERR_GAP ) THEN
10478                WRITE(OUTNUM,4000)
10479      $         ERRIBUF(4,I), ERRIBUF(5,I),
10480      $         REAL( ERRDBUF(2,I) ), AIMAG( ERRDBUF(2,I) ),
10481      $         REAL( ERRDBUF(1,I) ), AIMAG( ERRDBUF(1,I) )
10482             ELSE IF( ERRTYPE .EQ. ERR_TRI ) THEN
10483                WRITE(OUTNUM,5000) ERRIBUF(4,I), ERRIBUF(5,I),
10484      $         REAL( ERRDBUF(2,I) ), AIMAG( ERRDBUF(2,I) ),
10485      $         REAL( ERRDBUF(1,I) ), AIMAG( ERRDBUF(1,I) )
10486             ELSE
10487                WRITE(OUTNUM,6000) ERRIBUF(4,I), ERRIBUF(5,I),
10488      $         REAL( ERRDBUF(2,I) ), AIMAG( ERRDBUF(2,I) ),
10489      $         REAL( ERRDBUF(1,I) ), AIMAG( ERRDBUF(1,I) )
10490             END IF
10491          END IF
10492    20 CONTINUE
10493       WRITE(OUTNUM,12000) PROW, PCOL, OLDTEST
10494 *
10495  1000 FORMAT('PROCESS {',I4,',',I4,'} REPORTS ERRORS IN TEST#',I6,':')
10496  2000 FORMAT('   Buffer overwrite ',I4,
10497      $       ' elements before the start of A:',/,
10498      $       '   Expected=','[',G15.8,',',G15.8,']',
10499      $       '; Received=','[',G15.8,',',G15.8,']')
10500  3000 FORMAT('   Buffer overwrite ',I4,' elements after the end of A:',
10501      $       /,'   Expected=','[',G15.8,',',G15.8,']',
10502      $       '; Received=','[',G15.8,',',G15.8,']')
10503  4000 FORMAT('   LDA-M gap overwrite at postion (',I4,',',I4,'):',/,
10504      $       '   Expected=','[',G15.8,',',G15.8,']',
10505      $       '; Received=','[',G15.8,',',G15.8,']')
10506  5000 FORMAT('   Complementory triangle overwrite at A(',I4,',',I4,
10507      $       '):',/,'   Expected=','[',G15.8,',',G15.8,']',
10508      $       '; Received=','[',G15.8,',',G15.8,']')
10509  6000 FORMAT('   Invalid element at A(',I4,',',I4,'):',/,
10510      $       '   Expected=','[',G15.8,',',G15.8,']',
10511      $       '; Received=','[',G15.8,',',G15.8,']')
10512  7000 FORMAT('   Buffer overwrite ',I4,' elements before the start of ',
10513      $       A1,'A:',/,'   Expected=',I12,'; Received=',I12)
10514  8000 FORMAT('   Buffer overwrite ',I4,' elements after the end of ',
10515      $       A1,'A:',/,'   Expected=',I12,'; Received=',I12)
10516 *
10517  9000 FORMAT('   LD',A1,'A-M gap overwrite at postion (',I4,',',I4,'):'
10518      $       ,/,'   Expected=',I12,'; Received=',I12)
10519 *
10520 10000 FORMAT('   Invalid element at ',A1,'A(',I4,',',I4,'):',/,
10521      $       '   Expected=',I12,'; Received=',I12)
10522 11000 FORMAT('   Overwrite at position (',I4,',',I4,') of non-existent '
10523      $       ,A1,'A array.',/,'   Expected=',I12,'; Received=',I12)
10524 12000 FORMAT('PROCESS {',I4,',',I4,'} DONE ERROR REPORT FOR TEST#',
10525      $       I6,'.')
10526 13000 FORMAT('WARNING: There were more errors than could be recorded.',
10527      $       /,'Increase MEMELTS to get complete listing.')
10528       RETURN
10529 *
10530 *     End CPRINTERRS
10531 *
10532       END
10533 *
10534 *
10535       SUBROUTINE ZBTCHECKIN( NFTESTS, OUTNUM, MAXERR, NERR, IERR,
10536      $                       ZVAL, TFAILED )
10537       INTEGER NFTESTS, OUTNUM, MAXERR, NERR
10538       INTEGER IERR(*), TFAILED(*)
10539       DOUBLE COMPLEX ZVAL(*)
10540 *
10541 *  Purpose
10542 *  =======
10543 *  ZBTCHECKIN: Process 0 receives error report from all processes.
10544 *
10545 *  Arguments
10546 *  =========
10547 *  NFTESTS  (input/output) INTEGER
10548 *           if NFTESTS is <= 0 upon entry, NFTESTS is not written to.
10549 *           Otherwise, on entry it specifies the total number of tests
10550 *           run, and on exit it is the number of tests which failed.
10551 *
10552 *  OUTNUM   (input) INTEGER
10553 *           Device number for output.
10554 *
10555 *  MAXERR   (input) INTEGER
10556 *           Max number of errors that can be stored in ERRIBUFF or
10557 *           ERRZBUFF
10558 *
10559 *  NERR     (output) INTEGER
10560 *           The number of errors that have been found.
10561 *
10562 *  ERRIBUF  (output) INTEGER array, dimension (6,MAXERRS)
10563 *           Buffer in which to store integer error information.  It will
10564 *           be built up in the following format for the call to TSEND.
10565 *           All integer information is recorded in the following 6-tuple
10566 *           {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
10567 *             SRC = RSRC * NPROCS + CSRC
10568 *             DEST = RDEST * NPROCS + CDEST
10569 *             WHAT
10570 *              = 1 : Error in pre-padding
10571 *              = 2 : Error in post-padding
10572 *              = 3 : Error in LDA-M gap
10573 *              = 4 : Error in complementory triangle
10574 *              ELSE: Error in matrix
10575 *           If there are more errors than can fit in the error buffer,
10576 *           the error number will indicate the actual number of errors
10577 *           found, but the buffer will be truncated to the maximum
10578 *           number of errors which can fit.
10579 *
10580 *  ERRDBUF  (output) @(doctype) array, dimension (2, MAXERRS)
10581 *           Buffer in which to store error data information.
10582 *           {Incorrect, Predicted}
10583 *
10584 *  TFAILED (workspace) INTEGER array, dimension NFTESTS
10585 *          Workspace used to keep track of which tests failed.
10586 *          If input of NFTESTS < 1, this array not accessed.
10587 *
10588 *  ===================================================================
10589 *
10590 *     .. External Functions ..
10591       INTEGER  IBTMYPROC, IBTNPROCS, IBTMSGID
10592       EXTERNAL IBTMYPROC, IBTNPROCS, IBTMSGID
10593 *     ..
10594 *     .. Local Scalars ..
10595       LOGICAL COUNTING
10596       INTEGER K, NERR2, IAM, NPROCS, NTESTS
10597 *
10598 *     Proc 0 collects error info from everyone
10599 *
10600       IAM = IBTMYPROC()
10601       NPROCS = IBTNPROCS()
10602 *
10603       IF( IAM .EQ. 0 ) THEN
10604 *
10605 *        If we are finding out how many failed tests there are, initialize
10606 *        the total number of tests (NTESTS), and zero the test failed array
10607 *
10608          COUNTING = NFTESTS .GT. 0
10609          IF( COUNTING ) THEN
10610             NTESTS = NFTESTS
10611             DO 10 K = 1, NTESTS
10612                TFAILED(K) = 0
10613    10       CONTINUE
10614          END IF
10615 *
10616          CALL ZPRINTERRS(OUTNUM, MAXERR, NERR, IERR, ZVAL, COUNTING,
10617      $                   TFAILED)
10618 *
10619          DO 20 K = 1, NPROCS-1
10620             CALL BTSEND(3, 0, K, K, IBTMSGID()+50)
10621             CALL BTRECV(3, 1, NERR2, K, IBTMSGID()+50)
10622             IF( NERR2 .GT. 0 ) THEN
10623                NERR = NERR + NERR2
10624                CALL BTRECV(3, NERR2*6, IERR, K, IBTMSGID()+51)
10625                CALL BTRECV(7, NERR2*2, ZVAL, K, IBTMSGID()+51)
10626                CALL ZPRINTERRS(OUTNUM, MAXERR, NERR2, IERR, ZVAL,
10627      $                         COUNTING, TFAILED)
10628             END IF
10629    20    CONTINUE
10630 *
10631 *        Count up number of tests that failed
10632 *
10633          IF( COUNTING ) THEN
10634             NFTESTS = 0
10635             DO 30 K = 1, NTESTS
10636                NFTESTS = NFTESTS + TFAILED(K)
10637    30       CONTINUE
10638          END IF
10639 *
10640 *     Send my error info to proc 0
10641 *
10642       ELSE
10643          CALL BTRECV(3, 0, K, 0, IBTMSGID()+50)
10644          CALL BTSEND(3, 1, NERR, 0, IBTMSGID()+50)
10645          IF( NERR .GT. 0 ) THEN
10646             CALL BTSEND(3, NERR*6, IERR, 0, IBTMSGID()+51)
10647             CALL BTSEND(7, NERR*2, ZVAL, 0, IBTMSGID()+51)
10648          END IF
10649       ENDIF
10650 *
10651       RETURN
10652 *
10653 *     End of ZBTCHECKIN
10654 *
10655       END
10656 *
10657       SUBROUTINE ZINITMAT(UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST,
10658      $                    CHECKVAL, TESTNUM, MYROW, MYCOL)
10659       CHARACTER*1 UPLO, DIAG
10660       INTEGER M, N, LDA, IPRE, IPOST, TESTNUM, MYROW, MYCOL
10661       DOUBLE COMPLEX CHECKVAL
10662       DOUBLE COMPLEX MEM(*)
10663 *
10664 *     .. External Subroutines ..
10665       EXTERNAL ZGENMAT, ZPADMAT
10666 *     ..
10667 *     .. Executable Statements ..
10668 *
10669       CALL ZGENMAT( M, N, MEM(IPRE+1), LDA, TESTNUM, MYROW, MYCOL )
10670       CALL ZPADMAT( UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST, CHECKVAL )
10671 *
10672       RETURN
10673       END
10674 *
10675       SUBROUTINE ZGENMAT( M, N, A, LDA, TESTNUM, MYROW, MYCOL )
10676 *
10677 *  -- BLACS tester (version 1.0) --
10678 *  University of Tennessee
10679 *  December 15, 1994
10680 *
10681 *
10682 *     .. Scalar Arguments ..
10683       INTEGER M, N, LDA, TESTNUM, MYROW, MYCOL
10684 *     ..
10685 *     .. Array Arguments ..
10686       DOUBLE COMPLEX A(LDA,N)
10687 *     ..
10688 *
10689 *  Purpose
10690 *  =======
10691 *  ZGENMAT: Generates an M-by-N matrix filled with random elements.
10692 *
10693 *  Arguments
10694 *  =========
10695 *   M       (input) INTEGER
10696 *           The number of rows of the matrix A.  M >= 0.
10697 *
10698 *   N       (input) INTEGER
10699 *           The number of columns of the matrix A.  N >= 0.
10700 *
10701 *   A       (output) @up@(doctype) array, dimension (LDA,N)
10702 *           The m by n matrix A.  Fortran77 (column-major) storage
10703 *           assumed.
10704 *
10705 *   LDA     (input) INTEGER
10706 *           The leading dimension of the array A.  LDA >= max(1, M).
10707 *
10708 *  TESTNUM  (input) INTEGER
10709 *           Unique number for this test case, used as a basis for
10710 *           the random seeds.
10711 *
10712 *  ====================================================================
10713 *
10714 *     .. External Functions ..
10715       INTEGER IBTNPROCS
10716       DOUBLE COMPLEX ZBTRAN
10717       EXTERNAL ZBTRAN, IBTNPROCS
10718 *     ..
10719 *     .. Local Scalars ..
10720       INTEGER I, J, NPROCS, SRC
10721 *     ..
10722 *     .. Local Arrays ..
10723       INTEGER ISEED(4)
10724 *     ..
10725 *     .. Executable Statements ..
10726 *
10727 *     ISEED's four values must be positive integers less than 4096,
10728 *     fourth one has to be odd. (see _LARND).  Use some goofy
10729 *     functions to come up with seed values which together should
10730 *     be unique.
10731 *
10732       NPROCS = IBTNPROCS()
10733       SRC = MYROW * NPROCS + MYCOL
10734       ISEED(1) = MOD( 1002 + TESTNUM*5 + SRC*3, 4096 )
10735       ISEED(2) = MOD( 2027 + TESTNUM*7 + SRC, 4096 )
10736       ISEED(3) = MOD( 1234 + TESTNUM + SRC*3, 4096 )
10737       ISEED(4) = MOD( 4311 + TESTNUM*10 + SRC*2, 4096 )
10738 *
10739       DO 10 J = 1, N
10740          DO 10 I = 1, M
10741             A(I, J) = ZBTRAN( ISEED )
10742    10 CONTINUE
10743 *
10744       RETURN
10745 *
10746 *     End of ZGENMAT.
10747 *
10748       END
10749 *
10750       DOUBLE COMPLEX FUNCTION ZBTRAN(ISEED)
10751       INTEGER ISEED(*)
10752 *
10753 *     .. External Functions ..
10754       DOUBLE COMPLEX ZLARND
10755       EXTERNAL ZLARND
10756       ZBTRAN = ZLARND(2, ISEED)
10757 *
10758       RETURN
10759 *
10760 *     End of Zbtran
10761 *
10762       END
10763 *
10764       SUBROUTINE ZPADMAT( UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST,
10765      $                    CHECKVAL )
10766 *
10767 *  -- BLACS tester (version 1.0) --
10768 *  University of Tennessee
10769 *  December 15, 1994
10770 *
10771 *     .. Scalar Arguments ..
10772       CHARACTER*1 UPLO, DIAG
10773       INTEGER M, N, LDA, IPRE, IPOST
10774       DOUBLE COMPLEX CHECKVAL
10775 *     ..
10776 *     .. Array Arguments ..
10777       DOUBLE COMPLEX MEM( * )
10778 *     ..
10779 *
10780 *  Purpose
10781 *  =======
10782 *
10783 *  ZPADMAT: Pad Matrix.
10784 *  This routines surrounds a matrix with a guardzone initialized to the
10785 *  value CHECKVAL.  There are three distinct guardzones:
10786 *  - A contiguous zone of size IPRE immediately before the start
10787 *    of the matrix.
10788 *  - A contiguous zone of size IPOST immedately after the end of the
10789 *    matrix.
10790 *  - Interstitial zones within each column of the matrix, in the
10791 *    elements A( M+1:LDA, J ).
10792 *
10793 *  Arguments
10794 *  =========
10795 *  UPLO     (input) CHARACTER*1
10796 *           Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
10797 *           rectangular?
10798 *
10799 *  DIAG     (input) CHARACTER*1
10800 *           For trapezoidal matrices, is the main diagonal included
10801 *           ('N') or not ('U')?
10802 *
10803 *   M       (input) INTEGER
10804 *           The number of rows of the matrix A.  M >= 0.
10805 *
10806 *   N       (input) INTEGER
10807 *           The number of columns of the matrix A.  N >= 0.
10808 *
10809 *  MEM      (output) double complex array, dimension (IPRE+IPOST+LDA*N)
10810 *           The address IPRE elements ahead of the matrix A you want to
10811 *           pad, which is then of dimension (LDA,N).
10812 *
10813 *  IPRE     (input) INTEGER
10814 *           The size of the guard zone ahead of the matrix A.
10815 *
10816 *  IPOST    (input) INTEGER
10817 *           The size of the guard zone behind the matrix A.
10818 *
10819 *  CHECKVAL (input) double complex
10820 *           The value to insert into the guard zones.
10821 *
10822 *  ====================================================================
10823 *
10824 *     .. Local Scalars ..
10825       INTEGER I, J, K
10826 *     ..
10827 *     .. Executable Statements ..
10828 *
10829 *     Put check buffer in front of A
10830 *
10831       IF( IPRE .GT. 0 ) THEN
10832          DO 10 I = 1, IPRE
10833             MEM( I ) = CHECKVAL
10834    10    CONTINUE
10835       END IF
10836 *
10837 *     Put check buffer in back of A
10838 *
10839       IF( IPOST .GT. 0 ) THEN
10840          J = IPRE + LDA*N + 1
10841          DO 20 I = J, J+IPOST-1
10842             MEM( I ) = CHECKVAL
10843    20    CONTINUE
10844       END IF
10845 *
10846 *     Put check buffer in all (LDA-M) gaps
10847 *
10848       IF( LDA .GT. M ) THEN
10849          K = IPRE + M + 1
10850          DO 40 J = 1, N
10851             DO 30 I = K, K+LDA-M-1
10852                MEM( I ) = CHECKVAL
10853    30       CONTINUE
10854             K = K + LDA
10855    40    CONTINUE
10856       END IF
10857 *
10858 *     If the matrix is upper or lower trapezoidal, calculate the
10859 *     additional triangular area which needs to be padded,  Each
10860 *     element referred to is in the Ith row and the Jth column.
10861 *
10862       IF( UPLO .EQ. 'U' ) THEN
10863          IF( M .LE. N ) THEN
10864             IF( DIAG .EQ. 'U' ) THEN
10865                DO 41 I = 1, M
10866                   DO 42 J = 1, I
10867                      K = IPRE + I + (J-1)*LDA
10868                      MEM( K ) = CHECKVAL
10869    42             CONTINUE
10870    41          CONTINUE
10871             ELSE
10872                DO 43 I = 2, M
10873                   DO 44 J = 1, I-1
10874                      K = IPRE + I + (J-1)*LDA
10875                      MEM( K ) = CHECKVAL
10876    44             CONTINUE
10877    43          CONTINUE
10878             END IF
10879          ELSE
10880             IF( DIAG .EQ. 'U' ) THEN
10881                DO 45 I = M-N+1, M
10882                   DO 46 J = 1, I-(M-N)
10883                      K = IPRE + I + (J-1)*LDA
10884                      MEM( K ) = CHECKVAL
10885    46             CONTINUE
10886    45          CONTINUE
10887             ELSE
10888                DO 47 I = M-N+2, M
10889                   DO 48 J = 1, I-(M-N)-1
10890                      K = IPRE + I + (J-1)*LDA
10891                      MEM( K ) = CHECKVAL
10892    48             CONTINUE
10893    47          CONTINUE
10894             END IF
10895          END IF
10896       ELSE IF( UPLO .EQ. 'L' ) THEN
10897          IF( M .LE. N ) THEN
10898             IF( DIAG .EQ. 'U' ) THEN
10899                DO 49 I = 1, M
10900                   DO 50 J = N-M+I, N
10901                      K = IPRE + I + (J-1)*LDA
10902                      MEM( K ) = CHECKVAL
10903    50             CONTINUE
10904    49          CONTINUE
10905             ELSE
10906                DO 51 I = 1, M-1
10907                   DO 52 J = N-M+I+1, N
10908                      K = IPRE + I + (J-1)*LDA
10909                      MEM( K ) = CHECKVAL
10910    52             CONTINUE
10911    51          CONTINUE
10912             END IF
10913          ELSE
10914             IF( UPLO .EQ. 'U' ) THEN
10915                DO 53 I = 1, N
10916                   DO 54 J = I, N
10917                      K = IPRE + I + (J-1)*LDA
10918                      MEM( K ) = CHECKVAL
10919    54             CONTINUE
10920    53          CONTINUE
10921             ELSE
10922                DO 55 I = 1, N-1
10923                   DO 56 J = I+1, N
10924                      K = IPRE + I + (J-1)*LDA
10925                      MEM( K ) = CHECKVAL
10926    56             CONTINUE
10927    55          CONTINUE
10928             END IF
10929          END IF
10930       END IF
10931 *
10932 *     End of ZPADMAT.
10933 *
10934       RETURN
10935       END
10936 *
10937       SUBROUTINE ZCHKPAD( UPLO, DIAG, M, N, MEM, LDA, RSRC, CSRC,
10938      $                    MYROW, MYCOL, IPRE, IPOST, CHECKVAL,
10939      $                    TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF )
10940 *
10941 *  -- BLACS tester (version 1.0) --
10942 *  University of Tennessee
10943 *  December 15, 1994
10944 *
10945 *
10946 *     .. Scalar Arguments ..
10947       CHARACTER*1 UPLO, DIAG
10948       INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, IPRE, IPOST
10949       INTEGER TESTNUM, MAXERR, NERR
10950       DOUBLE COMPLEX CHECKVAL
10951 *     ..
10952 *     .. Array Arguments ..
10953       INTEGER ERRIBUF(6, MAXERR)
10954       DOUBLE COMPLEX MEM(*), ERRDBUF(2, MAXERR)
10955 *     ..
10956 *
10957 *  Purpose
10958 *  =======
10959 *  ZCHKPAD: Check padding put in by PADMAT.
10960 *  Checks that padding around target matrix has not been overwritten
10961 *  by the previous point-to-point or broadcast send.
10962 *
10963 *  Arguments
10964 *  =========
10965 *  UPLO     (input) CHARACTER*1
10966 *           Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
10967 *           rectangular?
10968 *
10969 *  DIAG     (input) CHARACTER*1
10970 *           For trapezoidal matrices, is the main diagonal included
10971 *           ('N') or not ('U')?
10972 *
10973 *   M       (input) INTEGER
10974 *           The number of rows of the matrix A.  M >= 0.
10975 *
10976 *   N       (input) INTEGER
10977 *           The number of columns of the matrix A.  N >= 0.
10978 *
10979 *  MEM       (input) double complex array, dimension(IPRE+IPOST+LDA*N).
10980 *            Memory location IPRE elements in front of the matrix A.
10981 *
10982 *   LDA     (input) INTEGER
10983 *           The leading dimension of the array A.  LDA >= max(1, M).
10984 *
10985 *  RSRC     (input) INTEGER
10986 *           The process row of the source of the matrix.
10987 *
10988 *  CSRC     (input) INTEGER
10989 *           The process column of the source of the matrix.
10990 *
10991 *  MYROW    (input) INTEGER
10992 *           Row of this process in the process grid.
10993 *
10994 *  MYCOL    (input) INTEGER
10995 *           Column of this process in the process grid.
10996 *
10997 *  IPRE     (input) INTEGER
10998 *           The size of the guard zone before the start of A.
10999 *
11000 *  IPOST    (input) INTEGER
11001 *           The size of guard zone after A.
11002 *
11003 *  CHECKVAL (input) double complex
11004 *           The value to pad matrix with.
11005 *
11006 *  TESTNUM  (input) INTEGER
11007 *           The number of the test being checked.
11008 *
11009 *  MAXERR   (input) INTEGER
11010 *           Max number of errors that can be stored in ERRIBUFF or
11011 *           ERRZBUFF
11012 *
11013 *  NERR     (output) INTEGER
11014 *           The number of errors that have been found.
11015 *
11016 *  ERRIBUF  (output) INTEGER array, dimension (6,MAXERRS)
11017 *           Buffer in which to store integer error information.  It will
11018 *           be built up in the following format for the call to TSEND.
11019 *           All integer information is recorded in the following 6-tuple
11020 *           {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
11021 *             SRC = RSRC * NPROCS + CSRC
11022 *             DEST = RDEST * NPROCS + CDEST
11023 *             WHAT
11024 *              = 1 : Error in pre-padding
11025 *              = 2 : Error in post-padding
11026 *              = 3 : Error in LDA-M gap
11027 *              = 4 : Error in complementory triangle
11028 *              ELSE: Error in matrix
11029 *           If there are more errors than can fit in the error buffer,
11030 *           the error number will indicate the actual number of errors
11031 *           found, but the buffer will be truncated to the maximum
11032 *           number of errors which can fit.
11033 *
11034 *  ERRDBUF  (output) @(doctype) array, dimension (2, MAXERRS)
11035 *           Buffer in which to store error data information.
11036 *           {Incorrect, Predicted}
11037 *
11038 *  ===================================================================
11039 *
11040 *     .. Parameters ..
11041       INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
11042       PARAMETER( ERR_PRE = 1, ERR_POST = 2, ERR_GAP = 3, ERR_TRI = 4 )
11043       PARAMETER( ERR_MAT = 5 )
11044 *     ..
11045 *     .. External Functions ..
11046       INTEGER IBTNPROCS
11047       EXTERNAL IBTNPROCS
11048 *     ..
11049 *     .. Local Scalars ..
11050       LOGICAL ISTRAP
11051       INTEGER I, J, K, IRST, IRND, ICST, ICND, SRC, DEST
11052       INTEGER NPROCS
11053 *     ..
11054 *     .. Executable Statements ..
11055 *
11056       NPROCS = IBTNPROCS()
11057       SRC = RSRC * NPROCS + CSRC
11058       DEST = MYROW * NPROCS + MYCOL
11059 *
11060 *     Check buffer in front of A
11061 *
11062       IF( IPRE .GT. 0 ) THEN
11063          DO 10 I = 1, IPRE
11064             IF( MEM(I) .NE. CHECKVAL ) THEN
11065                NERR = NERR + 1
11066                IF( NERR .LE. MAXERR ) THEN
11067                   ERRIBUF(1, NERR) = TESTNUM
11068                   ERRIBUF(2, NERR) = SRC
11069                   ERRIBUF(3, NERR) = DEST
11070                   ERRIBUF(4, NERR) = I
11071                   ERRIBUF(5, NERR) = IPRE - I + 1
11072                   ERRIBUF(6, NERR) = ERR_PRE
11073                   ERRDBUF(1, NERR) = MEM(I)
11074                   ERRDBUF(2, NERR) = CHECKVAL
11075                END IF
11076             END IF
11077    10    CONTINUE
11078       END IF
11079 *
11080 *     Check buffer behind A
11081 *
11082       IF( IPOST .GT. 0 ) THEN
11083          J = IPRE + LDA*N + 1
11084          DO 20 I = J, J+IPOST-1
11085             IF( MEM(I) .NE. CHECKVAL ) THEN
11086                NERR = NERR + 1
11087                IF( NERR .LE. MAXERR ) THEN
11088                   ERRIBUF(1, NERR) = TESTNUM
11089                   ERRIBUF(2, NERR) = SRC
11090                   ERRIBUF(3, NERR) = DEST
11091                   ERRIBUF(4, NERR) = I - J + 1
11092                   ERRIBUF(5, NERR) = J
11093                   ERRIBUF(6, NERR) = ERR_POST
11094                   ERRDBUF(1, NERR) = MEM(I)
11095                   ERRDBUF(2, NERR) = CHECKVAL
11096                END IF
11097             END IF
11098    20    CONTINUE
11099       END IF
11100 *
11101 *     Check all (LDA-M) gaps
11102 *
11103       IF( LDA .GT. M ) THEN
11104          DO 40 J = 1, N
11105             DO 30 I = M+1, LDA
11106                K = IPRE + (J-1)*LDA + I
11107                IF( MEM(K) .NE. CHECKVAL) THEN
11108                   NERR = NERR + 1
11109                   IF( NERR .LE. MAXERR ) THEN
11110                      ERRIBUF(1, NERR) = TESTNUM
11111                      ERRIBUF(2, NERR) = SRC
11112                      ERRIBUF(3, NERR) = DEST
11113                      ERRIBUF(4, NERR) = I
11114                      ERRIBUF(5, NERR) = J
11115                      ERRIBUF(6, NERR) = ERR_GAP
11116                      ERRDBUF(1, NERR) = MEM(K)
11117                      ERRDBUF(2, NERR) = CHECKVAL
11118                   END IF
11119                END IF
11120    30       CONTINUE
11121    40    CONTINUE
11122       END IF
11123 *
11124 *     Determine limits of trapezoidal matrix
11125 *
11126       ISTRAP = .FALSE.
11127       IF( UPLO .EQ. 'U' ) THEN
11128          ISTRAP = .TRUE.
11129          IF( M .LE. N ) THEN
11130             IRST = 2
11131             IRND = M
11132             ICST = 1
11133             ICND = M - 1
11134          ELSEIF( M .GT. N ) THEN
11135             IRST = ( M-N ) + 2
11136             IRND = M
11137             ICST = 1
11138             ICND = N - 1
11139          ENDIF
11140          IF( DIAG .EQ. 'U' ) THEN
11141             IRST = IRST - 1
11142             ICND = ICND + 1
11143          ENDIF
11144       ELSE IF( UPLO .EQ. 'L' ) THEN
11145          ISTRAP = .TRUE.
11146          IF( M .LE. N ) THEN
11147             IRST = 1
11148             IRND = 1
11149             ICST = ( N-M ) + 2
11150             ICND = N
11151          ELSEIF( M .GT. N ) THEN
11152             IRST = 1
11153             IRND = 1
11154             ICST = 2
11155             ICND = N
11156          ENDIF
11157          IF( DIAG .EQ. 'U' ) THEN
11158             ICST = ICST - 1
11159          ENDIF
11160       ENDIF
11161 *
11162 *     Check elements and report any errors
11163 *
11164       IF( ISTRAP ) THEN
11165          DO 100 J = ICST, ICND
11166             DO 105 I = IRST, IRND
11167                IF( MEM( IPRE + (J-1)*LDA + I ) .NE. CHECKVAL ) THEN
11168                   NERR = NERR + 1
11169                   IF( NERR .LE. MAXERR ) THEN
11170                      ERRIBUF(1, NERR) = TESTNUM
11171                      ERRIBUF(2, NERR) = SRC
11172                      ERRIBUF(3, NERR) = DEST
11173                      ERRIBUF(4, NERR) = I
11174                      ERRIBUF(5, NERR) = J
11175                      ERRIBUF(6, NERR) = ERR_TRI
11176                      ERRDBUF(1, NERR) = MEM( IPRE + (J-1)*LDA + I )
11177                      ERRDBUF(2, NERR) = CHECKVAL
11178                   END IF
11179                END IF
11180   105       CONTINUE
11181 *
11182 *           Update the limits to allow filling in padding
11183 *
11184             IF( UPLO .EQ. 'U' ) THEN
11185                IRST = IRST + 1
11186             ELSE
11187                IRND = IRND + 1
11188             ENDIF
11189   100    CONTINUE
11190       END IF
11191 *
11192       RETURN
11193 *
11194 *     End of ZCHKPAD.
11195 *
11196       END
11197 *
11198       SUBROUTINE ZCHKMAT( UPLO, DIAG, M, N, A, LDA, RSRC, CSRC,
11199      $                    MYROW, MYCOL, TESTNUM, MAXERR, NERR,
11200      $                    ERRIBUF, ERRDBUF )
11201 *
11202 *  -- BLACS tester (version 1.0) --
11203 *  University of Tennessee
11204 *  December 15, 1994
11205 *
11206 *
11207 *     .. Scalar Arguments ..
11208       CHARACTER*1 UPLO, DIAG
11209       INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, TESTNUM
11210       INTEGER MAXERR, NERR
11211 *     ..
11212 *     .. Array Arguments ..
11213       INTEGER ERRIBUF(6, MAXERR)
11214       DOUBLE COMPLEX A(LDA,N), ERRDBUF(2, MAXERR)
11215 *     ..
11216 *
11217 *  Purpose
11218 *  =======
11219 *  zCHKMAT:  Check matrix to see whether there were any transmission
11220 *            errors.
11221 *
11222 *  Arguments
11223 *  =========
11224 *  UPLO     (input) CHARACTER*1
11225 *           Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
11226 *           rectangular?
11227 *
11228 *  DIAG     (input) CHARACTER*1
11229 *           For trapezoidal matrices, is the main diagonal included
11230 *           ('N') or not ('U')?
11231 *
11232 *   M       (input) INTEGER
11233 *           The number of rows of the matrix A.  M >= 0.
11234 *
11235 *   N       (input) INTEGER
11236 *           The number of columns of the matrix A.  N >= 0.
11237 *
11238 *   A       (input) @up@(doctype) array, dimension (LDA,N)
11239 *           The m by n matrix A.  Fortran77 (column-major) storage
11240 *           assumed.
11241 *
11242 *   LDA     (input) INTEGER
11243 *           The leading dimension of the array A.  LDA >= max(1, M).
11244 *
11245 *  RSRC     (input) INTEGER
11246 *           The process row of the source of the matrix.
11247 *
11248 *  CSRC     (input) INTEGER
11249 *           The process column of the source of the matrix.
11250 *
11251 *  MYROW    (input) INTEGER
11252 *           Row of this process in the process grid.
11253 *
11254 *  MYCOL    (input) INTEGER
11255 *           Column of this process in the process grid.
11256 *
11257 *
11258 *  TESTNUM  (input) INTEGER
11259 *           The number of the test being checked.
11260 *
11261 *  MAXERR   (input) INTEGER
11262 *           Max number of errors that can be stored in ERRIBUFF or
11263 *           ERRZBUFF
11264 *
11265 *  NERR     (output) INTEGER
11266 *           The number of errors that have been found.
11267 *
11268 *  ERRIBUF  (output) INTEGER array, dimension (6,MAXERRS)
11269 *           Buffer in which to store integer error information.  It will
11270 *           be built up in the following format for the call to TSEND.
11271 *           All integer information is recorded in the following 6-tuple
11272 *           {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
11273 *             SRC = RSRC * NPROCS + CSRC
11274 *             DEST = RDEST * NPROCS + CDEST
11275 *             WHAT
11276 *              = 1 : Error in pre-padding
11277 *              = 2 : Error in post-padding
11278 *              = 3 : Error in LDA-M gap
11279 *              = 4 : Error in complementory triangle
11280 *              ELSE: Error in matrix
11281 *           If there are more errors than can fit in the error buffer,
11282 *           the error number will indicate the actual number of errors
11283 *           found, but the buffer will be truncated to the maximum
11284 *           number of errors which can fit.
11285 *
11286 *  ERRDBUF  (output) @(doctype) array, dimension (2, MAXERRS)
11287 *           Buffer in which to store error data information.
11288 *           {Incorrect, Predicted}
11289 *
11290 *  ===================================================================
11291 *
11292 *     .. Local Scalars ..
11293       INTEGER I, J, NPROCS, SRC, DEST
11294       LOGICAL USEIT
11295       DOUBLE COMPLEX COMPVAL
11296 *     ..
11297 *     .. Local Arrays ..
11298       INTEGER ISEED(4)
11299 *     ..
11300 *     .. External Functions ..
11301       INTEGER IBTNPROCS
11302       DOUBLE COMPLEX ZBTRAN
11303       EXTERNAL ZBTRAN, IBTNPROCS
11304 *     ..
11305 *     .. Executable Statements ..
11306 *
11307       NPROCS = IBTNPROCS()
11308       SRC = RSRC * NPROCS + CSRC
11309       DEST = MYROW * NPROCS + MYCOL
11310 *
11311 *     Initialize ISEED with the same values as used in ZGENMAT.
11312 *
11313       ISEED(1) = MOD( 1002 + TESTNUM*5 + SRC*3, 4096 )
11314       ISEED(2) = MOD( 2027 + TESTNUM*7 + SRC, 4096 )
11315       ISEED(3) = MOD( 1234 + TESTNUM + SRC*3, 4096 )
11316       ISEED(4) = MOD( 4311 + TESTNUM*10 + SRC*2, 4096 )
11317 *
11318 *     Generate the elements randomly with the same method used in GENMAT.
11319 *     Note that for trapezoidal matrices, we generate all elements in the
11320 *     enclosing rectangle and then ignore the complementary triangle.
11321 *
11322       DO 100 J = 1, N
11323          DO 105 I = 1, M
11324             COMPVAL = ZBTRAN( ISEED )
11325 *
11326 *           Now determine whether we actually need this value.  The
11327 *           strategy is to chop out the proper triangle based on what
1