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