LAPACK: BLAS/TESTING/cblat2.f Source File

Go to the documentation of this file.
00001       PROGRAM CBLAT2
00002 *
00003 *  Test program for the COMPLEX          Level 2 Blas.
00004 *
00005 *  The program must be driven by a short data file. The first 18 records
00006 *  of the file are read using list-directed input, the last 17 records
00007 *  are read using the format ( A6, L2 ). An annotated example of a data
00008 *  file can be obtained by deleting the first 3 characters from the
00009 *  following 35 lines:
00010 *  'cblat2.out'      NAME OF SUMMARY OUTPUT FILE
00011 *  6                 UNIT NUMBER OF SUMMARY FILE
00012 *  'CBLA2T.SNAP'     NAME OF SNAPSHOT OUTPUT FILE
00013 *  -1                UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
00014 *  F        LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
00015 *  F        LOGICAL FLAG, T TO STOP ON FAILURES.
00016 *  T        LOGICAL FLAG, T TO TEST ERROR EXITS.
00017 *  16.0     THRESHOLD VALUE OF TEST RATIO
00018 *  6                 NUMBER OF VALUES OF N
00019 *  0 1 2 3 5 9       VALUES OF N
00020 *  4                 NUMBER OF VALUES OF K
00021 *  0 1 2 4           VALUES OF K
00022 *  4                 NUMBER OF VALUES OF INCX AND INCY
00023 *  1 2 -1 -2         VALUES OF INCX AND INCY
00024 *  3                 NUMBER OF VALUES OF ALPHA
00025 *  (0.0,0.0) (1.0,0.0) (0.7,-0.9)       VALUES OF ALPHA
00026 *  3                 NUMBER OF VALUES OF BETA
00027 *  (0.0,0.0) (1.0,0.0) (1.3,-1.1)       VALUES OF BETA
00028 *  CGEMV  T PUT F FOR NO TEST. SAME COLUMNS.
00029 *  CGBMV  T PUT F FOR NO TEST. SAME COLUMNS.
00030 *  CHEMV  T PUT F FOR NO TEST. SAME COLUMNS.
00031 *  CHBMV  T PUT F FOR NO TEST. SAME COLUMNS.
00032 *  CHPMV  T PUT F FOR NO TEST. SAME COLUMNS.
00033 *  CTRMV  T PUT F FOR NO TEST. SAME COLUMNS.
00034 *  CTBMV  T PUT F FOR NO TEST. SAME COLUMNS.
00035 *  CTPMV  T PUT F FOR NO TEST. SAME COLUMNS.
00036 *  CTRSV  T PUT F FOR NO TEST. SAME COLUMNS.
00037 *  CTBSV  T PUT F FOR NO TEST. SAME COLUMNS.
00038 *  CTPSV  T PUT F FOR NO TEST. SAME COLUMNS.
00039 *  CGERC  T PUT F FOR NO TEST. SAME COLUMNS.
00040 *  CGERU  T PUT F FOR NO TEST. SAME COLUMNS.
00041 *  CHER   T PUT F FOR NO TEST. SAME COLUMNS.
00042 *  CHPR   T PUT F FOR NO TEST. SAME COLUMNS.
00043 *  CHER2  T PUT F FOR NO TEST. SAME COLUMNS.
00044 *  CHPR2  T PUT F FOR NO TEST. SAME COLUMNS.
00045 *
00046 *     See:
00047 *
00048 *        Dongarra J. J., Du Croz J. J., Hammarling S.  and Hanson R. J..
00049 *        An  extended  set of Fortran  Basic Linear Algebra Subprograms.
00050 *
00051 *        Technical  Memoranda  Nos. 41 (revision 3) and 81,  Mathematics
00052 *        and  Computer Science  Division,  Argonne  National Laboratory,
00053 *        9700 South Cass Avenue, Argonne, Illinois 60439, US.
00054 *
00055 *        Or
00056 *
00057 *        NAG  Technical Reports TR3/87 and TR4/87,  Numerical Algorithms
00058 *        Group  Ltd.,  NAG  Central  Office,  256  Banbury  Road, Oxford
00059 *        OX2 7DE, UK,  and  Numerical Algorithms Group Inc.,  1101  31st
00060 *        Street,  Suite 100,  Downers Grove,  Illinois 60515-1263,  USA.
00061 *
00062 *
00063 *  -- Written on 10-August-1987.
00064 *     Richard Hanson, Sandia National Labs.
00065 *     Jeremy Du Croz, NAG Central Office.
00066 *
00067 *     10-9-00:  Change STATUS='NEW' to 'UNKNOWN' so that the testers
00068 *               can be run multiple times without deleting generated
00069 *               output files (susan)
00070 *
00071 *     .. Parameters ..
00072       INTEGER            NIN
00073       PARAMETER          ( NIN = 5 )
00074       INTEGER            NSUBS
00075       PARAMETER          ( NSUBS = 17 )
00076       COMPLEX            ZERO, ONE
00077       PARAMETER          ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) )
00078       REAL               RZERO, RHALF, RONE
00079       PARAMETER          ( RZERO = 0.0, RHALF = 0.5, RONE = 1.0 )
00080       INTEGER            NMAX, INCMAX
00081       PARAMETER          ( NMAX = 65, INCMAX = 2 )
00082       INTEGER            NINMAX, NIDMAX, NKBMAX, NALMAX, NBEMAX
00083       PARAMETER          ( NINMAX = 7, NIDMAX = 9, NKBMAX = 7,
00084      $                   NALMAX = 7, NBEMAX = 7 )
00085 *     .. Local Scalars ..
00086       REAL               EPS, ERR, THRESH
00087       INTEGER            I, ISNUM, J, N, NALF, NBET, NIDIM, NINC, NKB,
00088      $                   NOUT, NTRA
00089       LOGICAL            FATAL, LTESTT, REWI, SAME, SFATAL, TRACE,
00090      $                   TSTERR
00091       CHARACTER*1        TRANS
00092       CHARACTER*6        SNAMET
00093       CHARACTER*32       SNAPS, SUMMRY
00094 *     .. Local Arrays ..
00095       COMPLEX            A( NMAX, NMAX ), AA( NMAX*NMAX ),
00096      $                   ALF( NALMAX ), AS( NMAX*NMAX ), BET( NBEMAX ),
00097      $                   X( NMAX ), XS( NMAX*INCMAX ),
00098      $                   XX( NMAX*INCMAX ), Y( NMAX ),
00099      $                   YS( NMAX*INCMAX ), YT( NMAX ),
00100      $                   YY( NMAX*INCMAX ), Z( 2*NMAX )
00101       REAL               G( NMAX )
00102       INTEGER            IDIM( NIDMAX ), INC( NINMAX ), KB( NKBMAX )
00103       LOGICAL            LTEST( NSUBS )
00104       CHARACTER*6        SNAMES( NSUBS )
00105 *     .. External Functions ..
00106       REAL               SDIFF
00107       LOGICAL            LCE
00108       EXTERNAL           SDIFF, LCE
00109 *     .. External Subroutines ..
00110       EXTERNAL           CCHK1, CCHK2, CCHK3, CCHK4, CCHK5, CCHK6,
00111      $                   CCHKE, CMVCH
00112 *     .. Intrinsic Functions ..
00113       INTRINSIC          ABS, MAX, MIN
00114 *     .. Scalars in Common ..
00115       INTEGER            INFOT, NOUTC
00116       LOGICAL            LERR, OK
00117       CHARACTER*6        SRNAMT
00118 *     .. Common blocks ..
00119       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
00120       COMMON             /SRNAMC/SRNAMT
00121 *     .. Data statements ..
00122       DATA               SNAMES/'CGEMV ', 'CGBMV ', 'CHEMV ', 'CHBMV ',
00123      $                   'CHPMV ', 'CTRMV ', 'CTBMV ', 'CTPMV ',
00124      $                   'CTRSV ', 'CTBSV ', 'CTPSV ', 'CGERC ',
00125      $                   'CGERU ', 'CHER  ', 'CHPR  ', 'CHER2 ',
00126      $                   'CHPR2 '/
00127 *     .. Executable Statements ..
00128 *
00129 *     Read name and unit number for summary output file and open file.
00130 *
00131       READ( NIN, FMT = * )SUMMRY
00132       READ( NIN, FMT = * )NOUT
00133       OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' )
00134       NOUTC = NOUT
00135 *
00136 *     Read name and unit number for snapshot output file and open file.
00137 *
00138       READ( NIN, FMT = * )SNAPS
00139       READ( NIN, FMT = * )NTRA
00140       TRACE = NTRA.GE.0
00141       IF( TRACE )THEN
00142          OPEN( NTRA, FILE = SNAPS, STATUS = 'UNKNOWN' )
00143       END IF
00144 *     Read the flag that directs rewinding of the snapshot file.
00145       READ( NIN, FMT = * )REWI
00146       REWI = REWI.AND.TRACE
00147 *     Read the flag that directs stopping on any failure.
00148       READ( NIN, FMT = * )SFATAL
00149 *     Read the flag that indicates whether error exits are to be tested.
00150       READ( NIN, FMT = * )TSTERR
00151 *     Read the threshold value of the test ratio
00152       READ( NIN, FMT = * )THRESH
00153 *
00154 *     Read and check the parameter values for the tests.
00155 *
00156 *     Values of N
00157       READ( NIN, FMT = * )NIDIM
00158       IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN
00159          WRITE( NOUT, FMT = 9997 )'N', NIDMAX
00160          GO TO 230
00161       END IF
00162       READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM )
00163       DO 10 I = 1, NIDIM
00164          IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN
00165             WRITE( NOUT, FMT = 9996 )NMAX
00166             GO TO 230
00167          END IF
00168    10 CONTINUE
00169 *     Values of K
00170       READ( NIN, FMT = * )NKB
00171       IF( NKB.LT.1.OR.NKB.GT.NKBMAX )THEN
00172          WRITE( NOUT, FMT = 9997 )'K', NKBMAX
00173          GO TO 230
00174       END IF
00175       READ( NIN, FMT = * )( KB( I ), I = 1, NKB )
00176       DO 20 I = 1, NKB
00177          IF( KB( I ).LT.0 )THEN
00178             WRITE( NOUT, FMT = 9995 )
00179             GO TO 230
00180          END IF
00181    20 CONTINUE
00182 *     Values of INCX and INCY
00183       READ( NIN, FMT = * )NINC
00184       IF( NINC.LT.1.OR.NINC.GT.NINMAX )THEN
00185          WRITE( NOUT, FMT = 9997 )'INCX AND INCY', NINMAX
00186          GO TO 230
00187       END IF
00188       READ( NIN, FMT = * )( INC( I ), I = 1, NINC )
00189       DO 30 I = 1, NINC
00190          IF( INC( I ).EQ.0.OR.ABS( INC( I ) ).GT.INCMAX )THEN
00191             WRITE( NOUT, FMT = 9994 )INCMAX
00192             GO TO 230
00193          END IF
00194    30 CONTINUE
00195 *     Values of ALPHA
00196       READ( NIN, FMT = * )NALF
00197       IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN
00198          WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX
00199          GO TO 230
00200       END IF
00201       READ( NIN, FMT = * )( ALF( I ), I = 1, NALF )
00202 *     Values of BETA
00203       READ( NIN, FMT = * )NBET
00204       IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN
00205          WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX
00206          GO TO 230
00207       END IF
00208       READ( NIN, FMT = * )( BET( I ), I = 1, NBET )
00209 *
00210 *     Report values of parameters.
00211 *
00212       WRITE( NOUT, FMT = 9993 )
00213       WRITE( NOUT, FMT = 9992 )( IDIM( I ), I = 1, NIDIM )
00214       WRITE( NOUT, FMT = 9991 )( KB( I ), I = 1, NKB )
00215       WRITE( NOUT, FMT = 9990 )( INC( I ), I = 1, NINC )
00216       WRITE( NOUT, FMT = 9989 )( ALF( I ), I = 1, NALF )
00217       WRITE( NOUT, FMT = 9988 )( BET( I ), I = 1, NBET )
00218       IF( .NOT.TSTERR )THEN
00219          WRITE( NOUT, FMT = * )
00220          WRITE( NOUT, FMT = 9980 )
00221       END IF
00222       WRITE( NOUT, FMT = * )
00223       WRITE( NOUT, FMT = 9999 )THRESH
00224       WRITE( NOUT, FMT = * )
00225 *
00226 *     Read names of subroutines and flags which indicate
00227 *     whether they are to be tested.
00228 *
00229       DO 40 I = 1, NSUBS
00230          LTEST( I ) = .FALSE.
00231    40 CONTINUE
00232    50 READ( NIN, FMT = 9984, END = 80 )SNAMET, LTESTT
00233       DO 60 I = 1, NSUBS
00234          IF( SNAMET.EQ.SNAMES( I ) )
00235      $      GO TO 70
00236    60 CONTINUE
00237       WRITE( NOUT, FMT = 9986 )SNAMET
00238       STOP
00239    70 LTEST( I ) = LTESTT
00240       GO TO 50
00241 *
00242    80 CONTINUE
00243       CLOSE ( NIN )
00244 *
00245 *     Compute EPS (the machine precision).
00246 *
00247       EPS = RONE
00248    90 CONTINUE
00249       IF( SDIFF( RONE + EPS, RONE ).EQ.RZERO )
00250      $   GO TO 100
00251       EPS = RHALF*EPS
00252       GO TO 90
00253   100 CONTINUE
00254       EPS = EPS + EPS
00255       WRITE( NOUT, FMT = 9998 )EPS
00256 *
00257 *     Check the reliability of CMVCH using exact data.
00258 *
00259       N = MIN( 32, NMAX )
00260       DO 120 J = 1, N
00261          DO 110 I = 1, N
00262             A( I, J ) = MAX( I - J + 1, 0 )
00263   110    CONTINUE
00264          X( J ) = J
00265          Y( J ) = ZERO
00266   120 CONTINUE
00267       DO 130 J = 1, N
00268          YY( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3
00269   130 CONTINUE
00270 *     YY holds the exact result. On exit from CMVCH YT holds
00271 *     the result computed by CMVCH.
00272       TRANS = 'N'
00273       CALL CMVCH( TRANS, N, N, ONE, A, NMAX, X, 1, ZERO, Y, 1, YT, G,
00274      $            YY, EPS, ERR, FATAL, NOUT, .TRUE. )
00275       SAME = LCE( YY, YT, N )
00276       IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN
00277          WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR
00278          STOP
00279       END IF
00280       TRANS = 'T'
00281       CALL CMVCH( TRANS, N, N, ONE, A, NMAX, X, -1, ZERO, Y, -1, YT, G,
00282      $            YY, EPS, ERR, FATAL, NOUT, .TRUE. )
00283       SAME = LCE( YY, YT, N )
00284       IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN
00285          WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR
00286          STOP
00287       END IF
00288 *
00289 *     Test each subroutine in turn.
00290 *
00291       DO 210 ISNUM = 1, NSUBS
00292          WRITE( NOUT, FMT = * )
00293          IF( .NOT.LTEST( ISNUM ) )THEN
00294 *           Subprogram is not to be tested.
00295             WRITE( NOUT, FMT = 9983 )SNAMES( ISNUM )
00296          ELSE
00297             SRNAMT = SNAMES( ISNUM )
00298 *           Test error exits.
00299             IF( TSTERR )THEN
00300                CALL CCHKE( ISNUM, SNAMES( ISNUM ), NOUT )
00301                WRITE( NOUT, FMT = * )
00302             END IF
00303 *           Test computations.
00304             INFOT = 0
00305             OK = .TRUE.
00306             FATAL = .FALSE.
00307             GO TO ( 140, 140, 150, 150, 150, 160, 160,
00308      $              160, 160, 160, 160, 170, 170, 180,
00309      $              180, 190, 190 )ISNUM
00310 *           Test CGEMV, 01, and CGBMV, 02.
00311   140       CALL CCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
00312      $                  REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF,
00313      $                  NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS,
00314      $                  X, XX, XS, Y, YY, YS, YT, G )
00315             GO TO 200
00316 *           Test CHEMV, 03, CHBMV, 04, and CHPMV, 05.
00317   150       CALL CCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
00318      $                  REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF,
00319      $                  NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS,
00320      $                  X, XX, XS, Y, YY, YS, YT, G )
00321             GO TO 200
00322 *           Test CTRMV, 06, CTBMV, 07, CTPMV, 08,
00323 *           CTRSV, 09, CTBSV, 10, and CTPSV, 11.
00324   160       CALL CCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
00325      $                  REWI, FATAL, NIDIM, IDIM, NKB, KB, NINC, INC,
00326      $                  NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z )
00327             GO TO 200
00328 *           Test CGERC, 12, CGERU, 13.
00329   170       CALL CCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
00330      $                  REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC,
00331      $                  NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS,
00332      $                  YT, G, Z )
00333             GO TO 200
00334 *           Test CHER, 14, and CHPR, 15.
00335   180       CALL CCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
00336      $                  REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC,
00337      $                  NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS,
00338      $                  YT, G, Z )
00339             GO TO 200
00340 *           Test CHER2, 16, and CHPR2, 17.
00341   190       CALL CCHK6( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
00342      $                  REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC,
00343      $                  NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS,
00344      $                  YT, G, Z )
00345 *
00346   200       IF( FATAL.AND.SFATAL )
00347      $         GO TO 220
00348          END IF
00349   210 CONTINUE
00350       WRITE( NOUT, FMT = 9982 )
00351       GO TO 240
00352 *
00353   220 CONTINUE
00354       WRITE( NOUT, FMT = 9981 )
00355       GO TO 240
00356 *
00357   230 CONTINUE
00358       WRITE( NOUT, FMT = 9987 )
00359 *
00360   240 CONTINUE
00361       IF( TRACE )
00362      $   CLOSE ( NTRA )
00363       CLOSE ( NOUT )
00364       STOP
00365 *
00366  9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES',
00367      $      'S THAN', F8.2 )
00368  9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, E9.1 )
00369  9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ',
00370      $      'THAN ', I2 )
00371  9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 )
00372  9995 FORMAT( ' VALUE OF K IS LESS THAN 0' )
00373  9994 FORMAT( ' ABSOLUTE VALUE OF INCX OR INCY IS 0 OR GREATER THAN ',
00374      $      I2 )
00375  9993 FORMAT( ' TESTS OF THE COMPLEX          LEVEL 2 BLAS', //' THE F',
00376      $      'OLLOWING PARAMETER VALUES WILL BE USED:' )
00377  9992 FORMAT( '   FOR N              ', 9I6 )
00378  9991 FORMAT( '   FOR K              ', 7I6 )
00379  9990 FORMAT( '   FOR INCX AND INCY  ', 7I6 )
00380  9989 FORMAT( '   FOR ALPHA          ',
00381      $      7( '(', F4.1, ',', F4.1, ')  ', : ) )
00382  9988 FORMAT( '   FOR BETA           ',
00383      $      7( '(', F4.1, ',', F4.1, ')  ', : ) )
00384  9987 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM',
00385      $      /' ******* TESTS ABANDONED *******' )
00386  9986 FORMAT( ' SUBPROGRAM NAME ', A6, ' NOT RECOGNIZED', /' ******* T',
00387      $      'ESTS ABANDONED *******' )
00388  9985 FORMAT( ' ERROR IN CMVCH -  IN-LINE DOT PRODUCTS ARE BEING EVALU',
00389      $      'ATED WRONGLY.', /' CMVCH WAS CALLED WITH TRANS = ', A1,
00390      $      ' AND RETURNED SAME = ', L1, ' AND ERR = ', F12.3, '.', /
00391      $   ' THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.'
00392      $      , /' ******* TESTS ABANDONED *******' )
00393  9984 FORMAT( A6, L2 )
00394  9983 FORMAT( 1X, A6, ' WAS NOT TESTED' )
00395  9982 FORMAT( /' END OF TESTS' )
00396  9981 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' )
00397  9980 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' )
00398 *
00399 *     End of CBLAT2.
00400 *
00401       END
00402       SUBROUTINE CCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
00403      $                  FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET,
00404      $                  BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX,
00405      $                  XS, Y, YY, YS, YT, G )
00406 *
00407 *  Tests CGEMV and CGBMV.
00408 *
00409 *  Auxiliary routine for test program for Level 2 Blas.
00410 *
00411 *  -- Written on 10-August-1987.
00412 *     Richard Hanson, Sandia National Labs.
00413 *     Jeremy Du Croz, NAG Central Office.
00414 *
00415 *     .. Parameters ..
00416       COMPLEX            ZERO, HALF
00417       PARAMETER          ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ) )
00418       REAL               RZERO
00419       PARAMETER          ( RZERO = 0.0 )
00420 *     .. Scalar Arguments ..
00421       REAL               EPS, THRESH
00422       INTEGER            INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX,
00423      $                   NOUT, NTRA
00424       LOGICAL            FATAL, REWI, TRACE
00425       CHARACTER*6        SNAME
00426 *     .. Array Arguments ..
00427       COMPLEX            A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
00428      $                   AS( NMAX*NMAX ), BET( NBET ), X( NMAX ),
00429      $                   XS( NMAX*INCMAX ), XX( NMAX*INCMAX ),
00430      $                   Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ),
00431      $                   YY( NMAX*INCMAX )
00432       REAL               G( NMAX )
00433       INTEGER            IDIM( NIDIM ), INC( NINC ), KB( NKB )
00434 *     .. Local Scalars ..
00435       COMPLEX            ALPHA, ALS, BETA, BLS, TRANSL
00436       REAL               ERR, ERRMAX
00437       INTEGER            I, IA, IB, IC, IKU, IM, IN, INCX, INCXS, INCY,
00438      $                   INCYS, IX, IY, KL, KLS, KU, KUS, LAA, LDA,
00439      $                   LDAS, LX, LY, M, ML, MS, N, NARGS, NC, ND, NK,
00440      $                   NL, NS
00441       LOGICAL            BANDED, FULL, NULL, RESET, SAME, TRAN
00442       CHARACTER*1        TRANS, TRANSS
00443       CHARACTER*3        ICH
00444 *     .. Local Arrays ..
00445       LOGICAL            ISAME( 13 )
00446 *     .. External Functions ..
00447       LOGICAL            LCE, LCERES
00448       EXTERNAL           LCE, LCERES
00449 *     .. External Subroutines ..
00450       EXTERNAL           CGBMV, CGEMV, CMAKE, CMVCH
00451 *     .. Intrinsic Functions ..
00452       INTRINSIC          ABS, MAX, MIN
00453 *     .. Scalars in Common ..
00454       INTEGER            INFOT, NOUTC
00455       LOGICAL            LERR, OK
00456 *     .. Common blocks ..
00457       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
00458 *     .. Data statements ..
00459       DATA               ICH/'NTC'/
00460 *     .. Executable Statements ..
00461       FULL = SNAME( 3: 3 ).EQ.'E'
00462       BANDED = SNAME( 3: 3 ).EQ.'B'
00463 *     Define the number of arguments.
00464       IF( FULL )THEN
00465          NARGS = 11
00466       ELSE IF( BANDED )THEN
00467          NARGS = 13
00468       END IF
00469 *
00470       NC = 0
00471       RESET = .TRUE.
00472       ERRMAX = RZERO
00473 *
00474       DO 120 IN = 1, NIDIM
00475          N = IDIM( IN )
00476          ND = N/2 + 1
00477 *
00478          DO 110 IM = 1, 2
00479             IF( IM.EQ.1 )
00480      $         M = MAX( N - ND, 0 )
00481             IF( IM.EQ.2 )
00482      $         M = MIN( N + ND, NMAX )
00483 *
00484             IF( BANDED )THEN
00485                NK = NKB
00486             ELSE
00487                NK = 1
00488             END IF
00489             DO 100 IKU = 1, NK
00490                IF( BANDED )THEN
00491                   KU = KB( IKU )
00492                   KL = MAX( KU - 1, 0 )
00493                ELSE
00494                   KU = N - 1
00495                   KL = M - 1
00496                END IF
00497 *              Set LDA to 1 more than minimum value if room.
00498                IF( BANDED )THEN
00499                   LDA = KL + KU + 1
00500                ELSE
00501                   LDA = M
00502                END IF
00503                IF( LDA.LT.NMAX )
00504      $            LDA = LDA + 1
00505 *              Skip tests if not enough room.
00506                IF( LDA.GT.NMAX )
00507      $            GO TO 100
00508                LAA = LDA*N
00509                NULL = N.LE.0.OR.M.LE.0
00510 *
00511 *              Generate the matrix A.
00512 *
00513                TRANSL = ZERO
00514                CALL CMAKE( SNAME( 2: 3 ), ' ', ' ', M, N, A, NMAX, AA,
00515      $                     LDA, KL, KU, RESET, TRANSL )
00516 *
00517                DO 90 IC = 1, 3
00518                   TRANS = ICH( IC: IC )
00519                   TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C'
00520 *
00521                   IF( TRAN )THEN
00522                      ML = N
00523                      NL = M
00524                   ELSE
00525                      ML = M
00526                      NL = N
00527                   END IF
00528 *
00529                   DO 80 IX = 1, NINC
00530                      INCX = INC( IX )
00531                      LX = ABS( INCX )*NL
00532 *
00533 *                    Generate the vector X.
00534 *
00535                      TRANSL = HALF
00536                      CALL CMAKE( 'GE', ' ', ' ', 1, NL, X, 1, XX,
00537      $                           ABS( INCX ), 0, NL - 1, RESET, TRANSL )
00538                      IF( NL.GT.1 )THEN
00539                         X( NL/2 ) = ZERO
00540                         XX( 1 + ABS( INCX )*( NL/2 - 1 ) ) = ZERO
00541                      END IF
00542 *
00543                      DO 70 IY = 1, NINC
00544                         INCY = INC( IY )
00545                         LY = ABS( INCY )*ML
00546 *
00547                         DO 60 IA = 1, NALF
00548                            ALPHA = ALF( IA )
00549 *
00550                            DO 50 IB = 1, NBET
00551                               BETA = BET( IB )
00552 *
00553 *                             Generate the vector Y.
00554 *
00555                               TRANSL = ZERO
00556                               CALL CMAKE( 'GE', ' ', ' ', 1, ML, Y, 1,
00557      $                                    YY, ABS( INCY ), 0, ML - 1,
00558      $                                    RESET, TRANSL )
00559 *
00560                               NC = NC + 1
00561 *
00562 *                             Save every datum before calling the
00563 *                             subroutine.
00564 *
00565                               TRANSS = TRANS
00566                               MS = M
00567                               NS = N
00568                               KLS = KL
00569                               KUS = KU
00570                               ALS = ALPHA
00571                               DO 10 I = 1, LAA
00572                                  AS( I ) = AA( I )
00573    10                         CONTINUE
00574                               LDAS = LDA
00575                               DO 20 I = 1, LX
00576                                  XS( I ) = XX( I )
00577    20                         CONTINUE
00578                               INCXS = INCX
00579                               BLS = BETA
00580                               DO 30 I = 1, LY
00581                                  YS( I ) = YY( I )
00582    30                         CONTINUE
00583                               INCYS = INCY
00584 *
00585 *                             Call the subroutine.
00586 *
00587                               IF( FULL )THEN
00588                                  IF( TRACE )
00589      $                              WRITE( NTRA, FMT = 9994 )NC, SNAME,
00590      $                              TRANS, M, N, ALPHA, LDA, INCX, BETA,
00591      $                              INCY
00592                                  IF( REWI )
00593      $                              REWIND NTRA
00594                                  CALL CGEMV( TRANS, M, N, ALPHA, AA,
00595      $                                       LDA, XX, INCX, BETA, YY,
00596      $                                       INCY )
00597                               ELSE IF( BANDED )THEN
00598                                  IF( TRACE )
00599      $                              WRITE( NTRA, FMT = 9995 )NC, SNAME,
00600      $                              TRANS, M, N, KL, KU, ALPHA, LDA,
00601      $                              INCX, BETA, INCY
00602                                  IF( REWI )
00603      $                              REWIND NTRA
00604                                  CALL CGBMV( TRANS, M, N, KL, KU, ALPHA,
00605      $                                       AA, LDA, XX, INCX, BETA,
00606      $                                       YY, INCY )
00607                               END IF
00608 *
00609 *                             Check if error-exit was taken incorrectly.
00610 *
00611                               IF( .NOT.OK )THEN
00612                                  WRITE( NOUT, FMT = 9993 )
00613                                  FATAL = .TRUE.
00614                                  GO TO 130
00615                               END IF
00616 *
00617 *                             See what data changed inside subroutines.
00618 *
00619                               ISAME( 1 ) = TRANS.EQ.TRANSS
00620                               ISAME( 2 ) = MS.EQ.M
00621                               ISAME( 3 ) = NS.EQ.N
00622                               IF( FULL )THEN
00623                                  ISAME( 4 ) = ALS.EQ.ALPHA
00624                                  ISAME( 5 ) = LCE( AS, AA, LAA )
00625                                  ISAME( 6 ) = LDAS.EQ.LDA
00626                                  ISAME( 7 ) = LCE( XS, XX, LX )
00627                                  ISAME( 8 ) = INCXS.EQ.INCX
00628                                  ISAME( 9 ) = BLS.EQ.BETA
00629                                  IF( NULL )THEN
00630                                     ISAME( 10 ) = LCE( YS, YY, LY )
00631                                  ELSE
00632                                     ISAME( 10 ) = LCERES( 'GE', ' ', 1,
00633      $                                            ML, YS, YY,
00634      $                                            ABS( INCY ) )
00635                                  END IF
00636                                  ISAME( 11 ) = INCYS.EQ.INCY
00637                               ELSE IF( BANDED )THEN
00638                                  ISAME( 4 ) = KLS.EQ.KL
00639                                  ISAME( 5 ) = KUS.EQ.KU
00640                                  ISAME( 6 ) = ALS.EQ.ALPHA
00641                                  ISAME( 7 ) = LCE( AS, AA, LAA )
00642                                  ISAME( 8 ) = LDAS.EQ.LDA
00643                                  ISAME( 9 ) = LCE( XS, XX, LX )
00644                                  ISAME( 10 ) = INCXS.EQ.INCX
00645                                  ISAME( 11 ) = BLS.EQ.BETA
00646                                  IF( NULL )THEN
00647                                     ISAME( 12 ) = LCE( YS, YY, LY )
00648                                  ELSE
00649                                     ISAME( 12 ) = LCERES( 'GE', ' ', 1,
00650      $                                            ML, YS, YY,
00651      $                                            ABS( INCY ) )
00652                                  END IF
00653                                  ISAME( 13 ) = INCYS.EQ.INCY
00654                               END IF
00655 *
00656 *                             If data was incorrectly changed, report
00657 *                             and return.
00658 *
00659                               SAME = .TRUE.
00660                               DO 40 I = 1, NARGS
00661                                  SAME = SAME.AND.ISAME( I )
00662                                  IF( .NOT.ISAME( I ) )
00663      $                              WRITE( NOUT, FMT = 9998 )I
00664    40                         CONTINUE
00665                               IF( .NOT.SAME )THEN
00666                                  FATAL = .TRUE.
00667                                  GO TO 130
00668                               END IF
00669 *
00670                               IF( .NOT.NULL )THEN
00671 *
00672 *                                Check the result.
00673 *
00674                                  CALL CMVCH( TRANS, M, N, ALPHA, A,
00675      $                                       NMAX, X, INCX, BETA, Y,
00676      $                                       INCY, YT, G, YY, EPS, ERR,
00677      $                                       FATAL, NOUT, .TRUE. )
00678                                  ERRMAX = MAX( ERRMAX, ERR )
00679 *                                If got really bad answer, report and
00680 *                                return.
00681                                  IF( FATAL )
00682      $                              GO TO 130
00683                               ELSE
00684 *                                Avoid repeating tests with M.le.0 or
00685 *                                N.le.0.
00686                                  GO TO 110
00687                               END IF
00688 *
00689    50                      CONTINUE
00690 *
00691    60                   CONTINUE
00692 *
00693    70                CONTINUE
00694 *
00695    80             CONTINUE
00696 *
00697    90          CONTINUE
00698 *
00699   100       CONTINUE
00700 *
00701   110    CONTINUE
00702 *
00703   120 CONTINUE
00704 *
00705 *     Report result.
00706 *
00707       IF( ERRMAX.LT.THRESH )THEN
00708          WRITE( NOUT, FMT = 9999 )SNAME, NC
00709       ELSE
00710          WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
00711       END IF
00712       GO TO 140
00713 *
00714   130 CONTINUE
00715       WRITE( NOUT, FMT = 9996 )SNAME
00716       IF( FULL )THEN
00717          WRITE( NOUT, FMT = 9994 )NC, SNAME, TRANS, M, N, ALPHA, LDA,
00718      $      INCX, BETA, INCY
00719       ELSE IF( BANDED )THEN
00720          WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANS, M, N, KL, KU,
00721      $      ALPHA, LDA, INCX, BETA, INCY
00722       END IF
00723 *
00724   140 CONTINUE
00725       RETURN
00726 *
00727  9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
00728      $      'S)' )
00729  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
00730      $      'ANGED INCORRECTLY *******' )
00731  9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
00732      $      'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
00733      $      ' - SUSPECT *******' )
00734  9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
00735  9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 4( I3, ',' ), '(',
00736      $      F4.1, ',', F4.1, '), A,', I3, ', X,', I2, ',(', F4.1, ',',
00737      $      F4.1, '), Y,', I2, ') .' )
00738  9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), '(',
00739      $      F4.1, ',', F4.1, '), A,', I3, ', X,', I2, ',(', F4.1, ',',
00740      $      F4.1, '), Y,', I2, ')         .' )
00741  9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
00742      $      '******' )
00743 *
00744 *     End of CCHK1.
00745 *
00746       END
00747       SUBROUTINE CCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
00748      $                  FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET,
00749      $                  BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX,
00750      $                  XS, Y, YY, YS, YT, G )
00751 *
00752 *  Tests CHEMV, CHBMV and CHPMV.
00753 *
00754 *  Auxiliary routine for test program for Level 2 Blas.
00755 *
00756 *  -- Written on 10-August-1987.
00757 *     Richard Hanson, Sandia National Labs.
00758 *     Jeremy Du Croz, NAG Central Office.
00759 *
00760 *     .. Parameters ..
00761       COMPLEX            ZERO, HALF
00762       PARAMETER          ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ) )
00763       REAL               RZERO
00764       PARAMETER          ( RZERO = 0.0 )
00765 *     .. Scalar Arguments ..
00766       REAL               EPS, THRESH
00767       INTEGER            INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX,
00768      $                   NOUT, NTRA
00769       LOGICAL            FATAL, REWI, TRACE
00770       CHARACTER*6        SNAME
00771 *     .. Array Arguments ..
00772       COMPLEX            A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
00773      $                   AS( NMAX*NMAX ), BET( NBET ), X( NMAX ),
00774      $                   XS( NMAX*INCMAX ), XX( NMAX*INCMAX ),
00775      $                   Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ),
00776      $                   YY( NMAX*INCMAX )
00777       REAL               G( NMAX )
00778       INTEGER            IDIM( NIDIM ), INC( NINC ), KB( NKB )
00779 *     .. Local Scalars ..
00780       COMPLEX            ALPHA, ALS, BETA, BLS, TRANSL
00781       REAL               ERR, ERRMAX
00782       INTEGER            I, IA, IB, IC, IK, IN, INCX, INCXS, INCY,
00783      $                   INCYS, IX, IY, K, KS, LAA, LDA, LDAS, LX, LY,
00784      $                   N, NARGS, NC, NK, NS
00785       LOGICAL            BANDED, FULL, NULL, PACKED, RESET, SAME
00786       CHARACTER*1        UPLO, UPLOS
00787       CHARACTER*2        ICH
00788 *     .. Local Arrays ..
00789       LOGICAL            ISAME( 13 )
00790 *     .. External Functions ..
00791       LOGICAL            LCE, LCERES
00792       EXTERNAL           LCE, LCERES
00793 *     .. External Subroutines ..
00794       EXTERNAL           CHBMV, CHEMV, CHPMV, CMAKE, CMVCH
00795 *     .. Intrinsic Functions ..
00796       INTRINSIC          ABS, MAX
00797 *     .. Scalars in Common ..
00798       INTEGER            INFOT, NOUTC
00799       LOGICAL            LERR, OK
00800 *     .. Common blocks ..
00801       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
00802 *     .. Data statements ..
00803       DATA               ICH/'UL'/
00804 *     .. Executable Statements ..
00805       FULL = SNAME( 3: 3 ).EQ.'E'
00806       BANDED = SNAME( 3: 3 ).EQ.'B'
00807       PACKED = SNAME( 3: 3 ).EQ.'P'
00808 *     Define the number of arguments.
00809       IF( FULL )THEN
00810          NARGS = 10
00811       ELSE IF( BANDED )THEN
00812          NARGS = 11
00813       ELSE IF( PACKED )THEN
00814          NARGS = 9
00815       END IF
00816 *
00817       NC = 0
00818       RESET = .TRUE.
00819       ERRMAX = RZERO
00820 *
00821       DO 110 IN = 1, NIDIM
00822          N = IDIM( IN )
00823 *
00824          IF( BANDED )THEN
00825             NK = NKB
00826          ELSE
00827             NK = 1
00828          END IF
00829          DO 100 IK = 1, NK
00830             IF( BANDED )THEN
00831                K = KB( IK )
00832             ELSE
00833                K = N - 1
00834             END IF
00835 *           Set LDA to 1 more than minimum value if room.
00836             IF( BANDED )THEN
00837                LDA = K + 1
00838             ELSE
00839                LDA = N
00840             END IF
00841             IF( LDA.LT.NMAX )
00842      $         LDA = LDA + 1
00843 *           Skip tests if not enough room.
00844             IF( LDA.GT.NMAX )
00845      $         GO TO 100
00846             IF( PACKED )THEN
00847                LAA = ( N*( N + 1 ) )/2
00848             ELSE
00849                LAA = LDA*N
00850             END IF
00851             NULL = N.LE.0
00852 *
00853             DO 90 IC = 1, 2
00854                UPLO = ICH( IC: IC )
00855 *
00856 *              Generate the matrix A.
00857 *
00858                TRANSL = ZERO
00859                CALL CMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, NMAX, AA,
00860      $                     LDA, K, K, RESET, TRANSL )
00861 *
00862                DO 80 IX = 1, NINC
00863                   INCX = INC( IX )
00864                   LX = ABS( INCX )*N
00865 *
00866 *                 Generate the vector X.
00867 *
00868                   TRANSL = HALF
00869                   CALL CMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX,
00870      $                        ABS( INCX ), 0, N - 1, RESET, TRANSL )
00871                   IF( N.GT.1 )THEN
00872                      X( N/2 ) = ZERO
00873                      XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
00874                   END IF
00875 *
00876                   DO 70 IY = 1, NINC
00877                      INCY = INC( IY )
00878                      LY = ABS( INCY )*N
00879 *
00880                      DO 60 IA = 1, NALF
00881                         ALPHA = ALF( IA )
00882 *
00883                         DO 50 IB = 1, NBET
00884                            BETA = BET( IB )
00885 *
00886 *                          Generate the vector Y.
00887 *
00888                            TRANSL = ZERO
00889                            CALL CMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY,
00890      $                                 ABS( INCY ), 0, N - 1, RESET,
00891      $                                 TRANSL )
00892 *
00893                            NC = NC + 1
00894 *
00895 *                          Save every datum before calling the
00896 *                          subroutine.
00897 *
00898                            UPLOS = UPLO
00899                            NS = N
00900                            KS = K
00901                            ALS = ALPHA
00902                            DO 10 I = 1, LAA
00903                               AS( I ) = AA( I )
00904    10                      CONTINUE
00905                            LDAS = LDA
00906                            DO 20 I = 1, LX
00907                               XS( I ) = XX( I )
00908    20                      CONTINUE
00909                            INCXS = INCX
00910                            BLS = BETA
00911                            DO 30 I = 1, LY
00912                               YS( I ) = YY( I )
00913    30                      CONTINUE
00914                            INCYS = INCY
00915 *
00916 *                          Call the subroutine.
00917 *
00918                            IF( FULL )THEN
00919                               IF( TRACE )
00920      $                           WRITE( NTRA, FMT = 9993 )NC, SNAME,
00921      $                           UPLO, N, ALPHA, LDA, INCX, BETA, INCY
00922                               IF( REWI )
00923      $                           REWIND NTRA
00924                               CALL CHEMV( UPLO, N, ALPHA, AA, LDA, XX,
00925      $                                    INCX, BETA, YY, INCY )
00926                            ELSE IF( BANDED )THEN
00927                               IF( TRACE )
00928      $                           WRITE( NTRA, FMT = 9994 )NC, SNAME,
00929      $                           UPLO, N, K, ALPHA, LDA, INCX, BETA,
00930      $                           INCY
00931                               IF( REWI )
00932      $                           REWIND NTRA
00933                               CALL CHBMV( UPLO, N, K, ALPHA, AA, LDA,
00934      $                                    XX, INCX, BETA, YY, INCY )
00935                            ELSE IF( PACKED )THEN
00936                               IF( TRACE )
00937      $                           WRITE( NTRA, FMT = 9995 )NC, SNAME,
00938      $                           UPLO, N, ALPHA, INCX, BETA, INCY
00939                               IF( REWI )
00940      $                           REWIND NTRA
00941                               CALL CHPMV( UPLO, N, ALPHA, AA, XX, INCX,
00942      $                                    BETA, YY, INCY )
00943                            END IF
00944 *
00945 *                          Check if error-exit was taken incorrectly.
00946 *
00947                            IF( .NOT.OK )THEN
00948                               WRITE( NOUT, FMT = 9992 )
00949                               FATAL = .TRUE.
00950                               GO TO 120
00951                            END IF
00952 *
00953 *                          See what data changed inside subroutines.
00954 *
00955                            ISAME( 1 ) = UPLO.EQ.UPLOS
00956                            ISAME( 2 ) = NS.EQ.N
00957                            IF( FULL )THEN
00958                               ISAME( 3 ) = ALS.EQ.ALPHA
00959                               ISAME( 4 ) = LCE( AS, AA, LAA )
00960                               ISAME( 5 ) = LDAS.EQ.LDA
00961                               ISAME( 6 ) = LCE( XS, XX, LX )
00962                               ISAME( 7 ) = INCXS.EQ.INCX
00963                               ISAME( 8 ) = BLS.EQ.BETA
00964                               IF( NULL )THEN
00965                                  ISAME( 9 ) = LCE( YS, YY, LY )
00966                               ELSE
00967                                  ISAME( 9 ) = LCERES( 'GE', ' ', 1, N,
00968      $                                        YS, YY, ABS( INCY ) )
00969                               END IF
00970                               ISAME( 10 ) = INCYS.EQ.INCY
00971                            ELSE IF( BANDED )THEN
00972                               ISAME( 3 ) = KS.EQ.K
00973                               ISAME( 4 ) = ALS.EQ.ALPHA
00974                               ISAME( 5 ) = LCE( AS, AA, LAA )
00975                               ISAME( 6 ) = LDAS.EQ.LDA
00976                               ISAME( 7 ) = LCE( XS, XX, LX )
00977                               ISAME( 8 ) = INCXS.EQ.INCX
00978                               ISAME( 9 ) = BLS.EQ.BETA
00979                               IF( NULL )THEN
00980                                  ISAME( 10 ) = LCE( YS, YY, LY )
00981                               ELSE
00982                                  ISAME( 10 ) = LCERES( 'GE', ' ', 1, N,
00983      $                                         YS, YY, ABS( INCY ) )
00984                               END IF
00985                               ISAME( 11 ) = INCYS.EQ.INCY
00986                            ELSE IF( PACKED )THEN
00987                               ISAME( 3 ) = ALS.EQ.ALPHA
00988                               ISAME( 4 ) = LCE( AS, AA, LAA )
00989                               ISAME( 5 ) = LCE( XS, XX, LX )
00990                               ISAME( 6 ) = INCXS.EQ.INCX
00991                               ISAME( 7 ) = BLS.EQ.BETA
00992                               IF( NULL )THEN
00993                                  ISAME( 8 ) = LCE( YS, YY, LY )
00994                               ELSE
00995                                  ISAME( 8 ) = LCERES( 'GE', ' ', 1, N,
00996      $                                        YS, YY, ABS( INCY ) )
00997                               END IF
00998                               ISAME( 9 ) = INCYS.EQ.INCY
00999                            END IF
01000 *
01001 *                          If data was incorrectly changed, report and
01002 *                          return.
01003 *
01004                            SAME = .TRUE.
01005                            DO 40 I = 1, NARGS
01006                               SAME = SAME.AND.ISAME( I )
01007                               IF( .NOT.ISAME( I ) )
01008      $                           WRITE( NOUT, FMT = 9998 )I
01009    40                      CONTINUE
01010                            IF( .NOT.SAME )THEN
01011                               FATAL = .TRUE.
01012                               GO TO 120
01013                            END IF
01014 *
01015                            IF( .NOT.NULL )THEN
01016 *
01017 *                             Check the result.
01018 *
01019                               CALL CMVCH( 'N', N, N, ALPHA, A, NMAX, X,
01020      $                                    INCX, BETA, Y, INCY, YT, G,
01021      $                                    YY, EPS, ERR, FATAL, NOUT,
01022      $                                    .TRUE. )
01023                               ERRMAX = MAX( ERRMAX, ERR )
01024 *                             If got really bad answer, report and
01025 *                             return.
01026                               IF( FATAL )
01027      $                           GO TO 120
01028                            ELSE
01029 *                             Avoid repeating tests with N.le.0
01030                               GO TO 110
01031                            END IF
01032 *
01033    50                   CONTINUE
01034 *
01035    60                CONTINUE
01036 *
01037    70             CONTINUE
01038 *
01039    80          CONTINUE
01040 *
01041    90       CONTINUE
01042 *
01043   100    CONTINUE
01044 *
01045   110 CONTINUE
01046 *
01047 *     Report result.
01048 *
01049       IF( ERRMAX.LT.THRESH )THEN
01050          WRITE( NOUT, FMT = 9999 )SNAME, NC
01051       ELSE
01052          WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
01053       END IF
01054       GO TO 130
01055 *
01056   120 CONTINUE
01057       WRITE( NOUT, FMT = 9996 )SNAME
01058       IF( FULL )THEN
01059          WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, LDA, INCX,
01060      $      BETA, INCY
01061       ELSE IF( BANDED )THEN
01062          WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, K, ALPHA, LDA,
01063      $      INCX, BETA, INCY
01064       ELSE IF( PACKED )THEN
01065          WRITE( NOUT, FMT = 9995 )NC, SNAME, UPLO, N, ALPHA, INCX,
01066      $      BETA, INCY
01067       END IF
01068 *
01069   130 CONTINUE
01070       RETURN
01071 *
01072  9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
01073      $      'S)' )
01074  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
01075      $      'ANGED INCORRECTLY *******' )
01076  9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
01077      $      'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
01078      $      ' - SUSPECT *******' )
01079  9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
01080  9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',(', F4.1, ',',
01081      $      F4.1, '), AP, X,', I2, ',(', F4.1, ',', F4.1, '), Y,', I2,
01082      $      ')                .' )
01083  9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), '(',
01084      $      F4.1, ',', F4.1, '), A,', I3, ', X,', I2, ',(', F4.1, ',',
01085      $      F4.1, '), Y,', I2, ')         .' )
01086  9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',(', F4.1, ',',
01087      $      F4.1, '), A,', I3, ', X,', I2, ',(', F4.1, ',', F4.1, '), ',
01088      $      'Y,', I2, ')             .' )
01089  9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
01090      $      '******' )
01091 *
01092 *     End of CCHK2.
01093 *
01094       END
01095       SUBROUTINE CCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
01096      $                  FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, NMAX,
01097      $                  INCMAX, A, AA, AS, X, XX, XS, XT, G, Z )
01098 *
01099 *  Tests CTRMV, CTBMV, CTPMV, CTRSV, CTBSV and CTPSV.
01100 *
01101 *  Auxiliary routine for test program for Level 2 Blas.
01102 *
01103 *  -- Written on 10-August-1987.
01104 *     Richard Hanson, Sandia National Labs.
01105 *     Jeremy Du Croz, NAG Central Office.
01106 *
01107 *     .. Parameters ..
01108       COMPLEX            ZERO, HALF, ONE
01109       PARAMETER          ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ),
01110      $                   ONE = ( 1.0, 0.0 ) )
01111       REAL               RZERO
01112       PARAMETER          ( RZERO = 0.0 )
01113 *     .. Scalar Arguments ..
01114       REAL               EPS, THRESH
01115       INTEGER            INCMAX, NIDIM, NINC, NKB, NMAX, NOUT, NTRA
01116       LOGICAL            FATAL, REWI, TRACE
01117       CHARACTER*6        SNAME
01118 *     .. Array Arguments ..
01119       COMPLEX            A( NMAX, NMAX ), AA( NMAX*NMAX ),
01120      $                   AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ),
01121      $                   XT( NMAX ), XX( NMAX*INCMAX ), Z( NMAX )
01122       REAL               G( NMAX )
01123       INTEGER            IDIM( NIDIM ), INC( NINC ), KB( NKB )
01124 *     .. Local Scalars ..
01125       COMPLEX            TRANSL
01126       REAL               ERR, ERRMAX
01127       INTEGER            I, ICD, ICT, ICU, IK, IN, INCX, INCXS, IX, K,
01128      $                   KS, LAA, LDA, LDAS, LX, N, NARGS, NC, NK, NS
01129       LOGICAL            BANDED, FULL, NULL, PACKED, RESET, SAME
01130       CHARACTER*1        DIAG, DIAGS, TRANS, TRANSS, UPLO, UPLOS
01131       CHARACTER*2        ICHD, ICHU
01132       CHARACTER*3        ICHT
01133 *     .. Local Arrays ..
01134       LOGICAL            ISAME( 13 )
01135 *     .. External Functions ..
01136       LOGICAL            LCE, LCERES
01137       EXTERNAL           LCE, LCERES
01138 *     .. External Subroutines ..
01139       EXTERNAL           CMAKE, CMVCH, CTBMV, CTBSV, CTPMV, CTPSV,
01140      $                   CTRMV, CTRSV
01141 *     .. Intrinsic Functions ..
01142       INTRINSIC          ABS, MAX
01143 *     .. Scalars in Common ..
01144       INTEGER            INFOT, NOUTC
01145       LOGICAL            LERR, OK
01146 *     .. Common blocks ..
01147       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
01148 *     .. Data statements ..
01149       DATA               ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/
01150 *     .. Executable Statements ..
01151       FULL = SNAME( 3: 3 ).EQ.'R'
01152       BANDED = SNAME( 3: 3 ).EQ.'B'
01153       PACKED = SNAME( 3: 3 ).EQ.'P'
01154 *     Define the number of arguments.
01155       IF( FULL )THEN
01156          NARGS = 8
01157       ELSE IF( BANDED )THEN
01158          NARGS = 9
01159       ELSE IF( PACKED )THEN
01160          NARGS = 7
01161       END IF
01162 *
01163       NC = 0
01164       RESET = .TRUE.
01165       ERRMAX = RZERO
01166 *     Set up zero vector for CMVCH.
01167       DO 10 I = 1, NMAX
01168          Z( I ) = ZERO
01169    10 CONTINUE
01170 *
01171       DO 110 IN = 1, NIDIM
01172          N = IDIM( IN )
01173 *
01174          IF( BANDED )THEN
01175             NK = NKB
01176          ELSE
01177             NK = 1
01178          END IF
01179          DO 100 IK = 1, NK
01180             IF( BANDED )THEN
01181                K = KB( IK )
01182             ELSE
01183                K = N - 1
01184             END IF
01185 *           Set LDA to 1 more than minimum value if room.
01186             IF( BANDED )THEN
01187                LDA = K + 1
01188             ELSE
01189                LDA = N
01190             END IF
01191             IF( LDA.LT.NMAX )
01192      $         LDA = LDA + 1
01193 *           Skip tests if not enough room.
01194             IF( LDA.GT.NMAX )
01195      $         GO TO 100
01196             IF( PACKED )THEN
01197                LAA = ( N*( N + 1 ) )/2
01198             ELSE
01199                LAA = LDA*N
01200             END IF
01201             NULL = N.LE.0
01202 *
01203             DO 90 ICU = 1, 2
01204                UPLO = ICHU( ICU: ICU )
01205 *
01206                DO 80 ICT = 1, 3
01207                   TRANS = ICHT( ICT: ICT )
01208 *
01209                   DO 70 ICD = 1, 2
01210                      DIAG = ICHD( ICD: ICD )
01211 *
01212 *                    Generate the matrix A.
01213 *
01214                      TRANSL = ZERO
01215                      CALL CMAKE( SNAME( 2: 3 ), UPLO, DIAG, N, N, A,
01216      $                           NMAX, AA, LDA, K, K, RESET, TRANSL )
01217 *
01218                      DO 60 IX = 1, NINC
01219                         INCX = INC( IX )
01220                         LX = ABS( INCX )*N
01221 *
01222 *                       Generate the vector X.
01223 *
01224                         TRANSL = HALF
01225                         CALL CMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX,
01226      $                              ABS( INCX ), 0, N - 1, RESET,
01227      $                              TRANSL )
01228                         IF( N.GT.1 )THEN
01229                            X( N/2 ) = ZERO
01230                            XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
01231                         END IF
01232 *
01233                         NC = NC + 1
01234 *
01235 *                       Save every datum before calling the subroutine.
01236 *
01237                         UPLOS = UPLO
01238                         TRANSS = TRANS
01239                         DIAGS = DIAG
01240                         NS = N
01241                         KS = K
01242                         DO 20 I = 1, LAA
01243                            AS( I ) = AA( I )
01244    20                   CONTINUE
01245                         LDAS = LDA
01246                         DO 30 I = 1, LX
01247                            XS( I ) = XX( I )
01248    30                   CONTINUE
01249                         INCXS = INCX
01250 *
01251 *                       Call the subroutine.
01252 *
01253                         IF( SNAME( 4: 5 ).EQ.'MV' )THEN
01254                            IF( FULL )THEN
01255                               IF( TRACE )
01256      $                           WRITE( NTRA, FMT = 9993 )NC, SNAME,
01257      $                           UPLO, TRANS, DIAG, N, LDA, INCX
01258                               IF( REWI )
01259      $                           REWIND NTRA
01260                               CALL CTRMV( UPLO, TRANS, DIAG, N, AA, LDA,
01261      $                                    XX, INCX )
01262                            ELSE IF( BANDED )THEN
01263                               IF( TRACE )
01264      $                           WRITE( NTRA, FMT = 9994 )NC, SNAME,
01265      $                           UPLO, TRANS, DIAG, N, K, LDA, INCX
01266                               IF( REWI )
01267      $                           REWIND NTRA
01268                               CALL CTBMV( UPLO, TRANS, DIAG, N, K, AA,
01269      $                                    LDA, XX, INCX )
01270                            ELSE IF( PACKED )THEN
01271                               IF( TRACE )
01272      $                           WRITE( NTRA, FMT = 9995 )NC, SNAME,
01273      $                           UPLO, TRANS, DIAG, N, INCX
01274                               IF( REWI )
01275      $                           REWIND NTRA
01276                               CALL CTPMV( UPLO, TRANS, DIAG, N, AA, XX,
01277      $                                    INCX )
01278                            END IF
01279                         ELSE IF( SNAME( 4: 5 ).EQ.'SV' )THEN
01280                            IF( FULL )THEN
01281                               IF( TRACE )
01282      $                           WRITE( NTRA, FMT = 9993 )NC, SNAME,
01283      $                           UPLO, TRANS, DIAG, N, LDA, INCX
01284                               IF( REWI )
01285      $                           REWIND NTRA
01286                               CALL CTRSV( UPLO, TRANS, DIAG, N, AA, LDA,
01287      $                                    XX, INCX )
01288                            ELSE IF( BANDED )THEN
01289                               IF( TRACE )
01290      $                           WRITE( NTRA, FMT = 9994 )NC, SNAME,
01291      $                           UPLO, TRANS, DIAG, N, K, LDA, INCX
01292                               IF( REWI )
01293      $                           REWIND NTRA
01294                               CALL CTBSV( UPLO, TRANS, DIAG, N, K, AA,
01295      $                                    LDA, XX, INCX )
01296                            ELSE IF( PACKED )THEN
01297                               IF( TRACE )
01298      $                           WRITE( NTRA, FMT = 9995 )NC, SNAME,
01299      $                           UPLO, TRANS, DIAG, N, INCX
01300                               IF( REWI )
01301      $                           REWIND NTRA
01302                               CALL CTPSV( UPLO, TRANS, DIAG, N, AA, XX,
01303      $                                    INCX )
01304                            END IF
01305                         END IF
01306 *
01307 *                       Check if error-exit was taken incorrectly.
01308 *
01309                         IF( .NOT.OK )THEN
01310                            WRITE( NOUT, FMT = 9992 )
01311                            FATAL = .TRUE.
01312                            GO TO 120
01313                         END IF
01314 *
01315 *                       See what data changed inside subroutines.
01316 *
01317                         ISAME( 1 ) = UPLO.EQ.UPLOS
01318                         ISAME( 2 ) = TRANS.EQ.TRANSS
01319                         ISAME( 3 ) = DIAG.EQ.DIAGS
01320                         ISAME( 4 ) = NS.EQ.N
01321                         IF( FULL )THEN
01322                            ISAME( 5 ) = LCE( AS, AA, LAA )
01323                            ISAME( 6 ) = LDAS.EQ.LDA
01324                            IF( NULL )THEN
01325                               ISAME( 7 ) = LCE( XS, XX, LX )
01326                            ELSE
01327                               ISAME( 7 ) = LCERES( 'GE', ' ', 1, N, XS,
01328      $                                     XX, ABS( INCX ) )
01329                            END IF
01330                            ISAME( 8 ) = INCXS.EQ.INCX
01331                         ELSE IF( BANDED )THEN
01332                            ISAME( 5 ) = KS.EQ.K
01333                            ISAME( 6 ) = LCE( AS, AA, LAA )
01334                            ISAME( 7 ) = LDAS.EQ.LDA
01335                            IF( NULL )THEN
01336                               ISAME( 8 ) = LCE( XS, XX, LX )
01337                            ELSE
01338                               ISAME( 8 ) = LCERES( 'GE', ' ', 1, N, XS,
01339      $                                     XX, ABS( INCX ) )
01340                            END IF
01341                            ISAME( 9 ) = INCXS.EQ.INCX
01342                         ELSE IF( PACKED )THEN
01343                            ISAME( 5 ) = LCE( AS, AA, LAA )
01344                            IF( NULL )THEN
01345                               ISAME( 6 ) = LCE( XS, XX, LX )
01346                            ELSE
01347                               ISAME( 6 ) = LCERES( 'GE', ' ', 1, N, XS,
01348      $                                     XX, ABS( INCX ) )
01349                            END IF
01350                            ISAME( 7 ) = INCXS.EQ.INCX
01351                         END IF
01352 *
01353 *                       If data was incorrectly changed, report and
01354 *                       return.
01355 *
01356                         SAME = .TRUE.
01357                         DO 40 I = 1, NARGS
01358                            SAME = SAME.AND.ISAME( I )
01359                            IF( .NOT.ISAME( I ) )
01360      $                        WRITE( NOUT, FMT = 9998 )I
01361    40                   CONTINUE
01362                         IF( .NOT.SAME )THEN
01363                            FATAL = .TRUE.
01364                            GO TO 120
01365                         END IF
01366 *
01367                         IF( .NOT.NULL )THEN
01368                            IF( SNAME( 4: 5 ).EQ.'MV' )THEN
01369 *
01370 *                             Check the result.
01371 *
01372                               CALL CMVCH( TRANS, N, N, ONE, A, NMAX, X,
01373      $                                    INCX, ZERO, Z, INCX, XT, G,
01374      $                                    XX, EPS, ERR, FATAL, NOUT,
01375      $                                    .TRUE. )
01376                            ELSE IF( SNAME( 4: 5 ).EQ.'SV' )THEN
01377 *
01378 *                             Compute approximation to original vector.
01379 *
01380                               DO 50 I = 1, N
01381                                  Z( I ) = XX( 1 + ( I - 1 )*
01382      $                                    ABS( INCX ) )
01383                                  XX( 1 + ( I - 1 )*ABS( INCX ) )
01384      $                              = X( I )
01385    50                         CONTINUE
01386                               CALL CMVCH( TRANS, N, N, ONE, A, NMAX, Z,
01387      $                                    INCX, ZERO, X, INCX, XT, G,
01388      $                                    XX, EPS, ERR, FATAL, NOUT,
01389      $                                    .FALSE. )
01390                            END IF
01391                            ERRMAX = MAX( ERRMAX, ERR )
01392 *                          If got really bad answer, report and return.
01393                            IF( FATAL )
01394      $                        GO TO 120
01395                         ELSE
01396 *                          Avoid repeating tests with N.le.0.
01397                            GO TO 110
01398                         END IF
01399 *
01400    60                CONTINUE
01401 *
01402    70             CONTINUE
01403 *
01404    80          CONTINUE
01405 *
01406    90       CONTINUE
01407 *
01408   100    CONTINUE
01409 *
01410   110 CONTINUE
01411 *
01412 *     Report result.
01413 *
01414       IF( ERRMAX.LT.THRESH )THEN
01415          WRITE( NOUT, FMT = 9999 )SNAME, NC
01416       ELSE
01417          WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
01418       END IF
01419       GO TO 130
01420 *
01421   120 CONTINUE
01422       WRITE( NOUT, FMT = 9996 )SNAME
01423       IF( FULL )THEN
01424          WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, TRANS, DIAG, N, LDA,
01425      $      INCX
01426       ELSE IF( BANDED )THEN
01427          WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, DIAG, N, K,
01428      $      LDA, INCX
01429       ELSE IF( PACKED )THEN
01430          WRITE( NOUT, FMT = 9995 )NC, SNAME, UPLO, TRANS, DIAG, N, INCX
01431       END IF
01432 *
01433   130 CONTINUE
01434       RETURN
01435 *
01436  9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
01437      $      'S)' )
01438  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
01439      $      'ANGED INCORRECTLY *******' )
01440  9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
01441      $      'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
01442      $      ' - SUSPECT *******' )
01443  9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
01444  9995 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), I3, ', AP, ',
01445      $      'X,', I2, ')                                      .' )
01446  9994 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), 2( I3, ',' ),
01447      $      ' A,', I3, ', X,', I2, ')                               .' )
01448  9993 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), I3, ', A,',
01449      $      I3, ', X,', I2, ')                                   .' )
01450  9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
01451      $      '******' )
01452 *
01453 *     End of CCHK3.
01454 *
01455       END
01456       SUBROUTINE CCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
01457      $                  FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX,
01458      $                  INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G,
01459      $                  Z )
01460 *
01461 *  Tests CGERC and CGERU.
01462 *
01463 *  Auxiliary routine for test program for Level 2 Blas.
01464 *
01465 *  -- Written on 10-August-1987.
01466 *     Richard Hanson, Sandia National Labs.
01467 *     Jeremy Du Croz, NAG Central Office.
01468 *
01469 *     .. Parameters ..
01470       COMPLEX            ZERO, HALF, ONE
01471       PARAMETER          ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ),
01472      $                   ONE = ( 1.0, 0.0 ) )
01473       REAL               RZERO
01474       PARAMETER          ( RZERO = 0.0 )
01475 *     .. Scalar Arguments ..
01476       REAL               EPS, THRESH
01477       INTEGER            INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA
01478       LOGICAL            FATAL, REWI, TRACE
01479       CHARACTER*6        SNAME
01480 *     .. Array Arguments ..
01481       COMPLEX            A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
01482      $                   AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ),
01483      $                   XX( NMAX*INCMAX ), Y( NMAX ),
01484      $                   YS( NMAX*INCMAX ), YT( NMAX ),
01485      $                   YY( NMAX*INCMAX ), Z( NMAX )
01486       REAL               G( NMAX )
01487       INTEGER            IDIM( NIDIM ), INC( NINC )
01488 *     .. Local Scalars ..
01489       COMPLEX            ALPHA, ALS, TRANSL
01490       REAL               ERR, ERRMAX
01491       INTEGER            I, IA, IM, IN, INCX, INCXS, INCY, INCYS, IX,
01492      $                   IY, J, LAA, LDA, LDAS, LX, LY, M, MS, N, NARGS,
01493      $                   NC, ND, NS
01494       LOGICAL            CONJ, NULL, RESET, SAME
01495 *     .. Local Arrays ..
01496       COMPLEX            W( 1 )
01497       LOGICAL            ISAME( 13 )
01498 *     .. External Functions ..
01499       LOGICAL            LCE, LCERES
01500       EXTERNAL           LCE, LCERES
01501 *     .. External Subroutines ..
01502       EXTERNAL           CGERC, CGERU, CMAKE, CMVCH
01503 *     .. Intrinsic Functions ..
01504       INTRINSIC          ABS, CONJG, MAX, MIN
01505 *     .. Scalars in Common ..
01506       INTEGER            INFOT, NOUTC
01507       LOGICAL            LERR, OK
01508 *     .. Common blocks ..
01509       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
01510 *     .. Executable Statements ..
01511       CONJ = SNAME( 5: 5 ).EQ.'C'
01512 *     Define the number of arguments.
01513       NARGS = 9
01514 *
01515       NC = 0
01516       RESET = .TRUE.
01517       ERRMAX = RZERO
01518 *
01519       DO 120 IN = 1, NIDIM
01520          N = IDIM( IN )
01521          ND = N/2 + 1
01522 *
01523          DO 110 IM = 1, 2
01524             IF( IM.EQ.1 )
01525      $         M = MAX( N - ND, 0 )
01526             IF( IM.EQ.2 )
01527      $         M = MIN( N + ND, NMAX )
01528 *
01529 *           Set LDA to 1 more than minimum value if room.
01530             LDA = M
01531             IF( LDA.LT.NMAX )
01532      $         LDA = LDA + 1
01533 *           Skip tests if not enough room.
01534             IF( LDA.GT.NMAX )
01535      $         GO TO 110
01536             LAA = LDA*N
01537             NULL = N.LE.0.OR.M.LE.0
01538 *
01539             DO 100 IX = 1, NINC
01540                INCX = INC( IX )
01541                LX = ABS( INCX )*M
01542 *
01543 *              Generate the vector X.
01544 *
01545                TRANSL = HALF
01546                CALL CMAKE( 'GE', ' ', ' ', 1, M, X, 1, XX, ABS( INCX ),
01547      $                     0, M - 1, RESET, TRANSL )
01548                IF( M.GT.1 )THEN
01549                   X( M/2 ) = ZERO
01550                   XX( 1 + ABS( INCX )*( M/2 - 1 ) ) = ZERO
01551                END IF
01552 *
01553                DO 90 IY = 1, NINC
01554                   INCY = INC( IY )
01555                   LY = ABS( INCY )*N
01556 *
01557 *                 Generate the vector Y.
01558 *
01559                   TRANSL = ZERO
01560                   CALL CMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY,
01561      $                        ABS( INCY ), 0, N - 1, RESET, TRANSL )
01562                   IF( N.GT.1 )THEN
01563                      Y( N/2 ) = ZERO
01564                      YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO
01565                   END IF
01566 *
01567                   DO 80 IA = 1, NALF
01568                      ALPHA = ALF( IA )
01569 *
01570 *                    Generate the matrix A.
01571 *
01572                      TRANSL = ZERO
01573                      CALL CMAKE( SNAME( 2: 3 ), ' ', ' ', M, N, A, NMAX,
01574      $                           AA, LDA, M - 1, N - 1, RESET, TRANSL )
01575 *
01576                      NC = NC + 1
01577 *
01578 *                    Save every datum before calling the subroutine.
01579 *
01580                      MS = M
01581                      NS = N
01582                      ALS = ALPHA
01583                      DO 10 I = 1, LAA
01584                         AS( I ) = AA( I )
01585    10                CONTINUE
01586                      LDAS = LDA
01587                      DO 20 I = 1, LX
01588                         XS( I ) = XX( I )
01589    20                CONTINUE
01590                      INCXS = INCX
01591                      DO 30 I = 1, LY
01592                         YS( I ) = YY( I )
01593    30                CONTINUE
01594                      INCYS = INCY
01595 *
01596 *                    Call the subroutine.
01597 *
01598                      IF( TRACE )
01599      $                  WRITE( NTRA, FMT = 9994 )NC, SNAME, M, N,
01600      $                  ALPHA, INCX, INCY, LDA
01601                      IF( CONJ )THEN
01602                         IF( REWI )
01603      $                     REWIND NTRA
01604                         CALL CGERC( M, N, ALPHA, XX, INCX, YY, INCY, AA,
01605      $                              LDA )
01606                      ELSE
01607                         IF( REWI )
01608      $                     REWIND NTRA
01609                         CALL CGERU( M, N, ALPHA, XX, INCX, YY, INCY, AA,
01610      $                              LDA )
01611                      END IF
01612 *
01613 *                    Check if error-exit was taken incorrectly.
01614 *
01615                      IF( .NOT.OK )THEN
01616                         WRITE( NOUT, FMT = 9993 )
01617                         FATAL = .TRUE.
01618                         GO TO 140
01619                      END IF
01620 *
01621 *                    See what data changed inside subroutine.
01622 *
01623                      ISAME( 1 ) = MS.EQ.M
01624                      ISAME( 2 ) = NS.EQ.N
01625                      ISAME( 3 ) = ALS.EQ.ALPHA
01626                      ISAME( 4 ) = LCE( XS, XX, LX )
01627                      ISAME( 5 ) = INCXS.EQ.INCX
01628                      ISAME( 6 ) = LCE( YS, YY, LY )
01629                      ISAME( 7 ) = INCYS.EQ.INCY
01630                      IF( NULL )THEN
01631                         ISAME( 8 ) = LCE( AS, AA, LAA )
01632                      ELSE
01633                         ISAME( 8 ) = LCERES( 'GE', ' ', M, N, AS, AA,
01634      $                               LDA )
01635                      END IF
01636                      ISAME( 9 ) = LDAS.EQ.LDA
01637 *
01638 *                    If data was incorrectly changed, report and return.
01639 *
01640                      SAME = .TRUE.
01641                      DO 40 I = 1, NARGS
01642                         SAME = SAME.AND.ISAME( I )
01643                         IF( .NOT.ISAME( I ) )
01644      $                     WRITE( NOUT, FMT = 9998 )I
01645    40                CONTINUE
01646                      IF( .NOT.SAME )THEN
01647                         FATAL = .TRUE.
01648                         GO TO 140
01649                      END IF
01650 *
01651                      IF( .NOT.NULL )THEN
01652 *
01653 *                       Check the result column by column.
01654 *
01655                         IF( INCX.GT.0 )THEN
01656                            DO 50 I = 1, M
01657                               Z( I ) = X( I )
01658    50                      CONTINUE
01659                         ELSE
01660                            DO 60 I = 1, M
01661                               Z( I ) = X( M - I + 1 )
01662    60                      CONTINUE
01663                         END IF
01664                         DO 70 J = 1, N
01665                            IF( INCY.GT.0 )THEN
01666                               W( 1 ) = Y( J )
01667                            ELSE
01668                               W( 1 ) = Y( N - J + 1 )
01669                            END IF
01670                            IF( CONJ )
01671      $                        W( 1 ) = CONJG( W( 1 ) )
01672                            CALL CMVCH( 'N', M, 1, ALPHA, Z, NMAX, W, 1,
01673      $                                 ONE, A( 1, J ), 1, YT, G,
01674      $                                 AA( 1 + ( J - 1 )*LDA ), EPS,
01675      $                                 ERR, FATAL, NOUT, .TRUE. )
01676                            ERRMAX = MAX( ERRMAX, ERR )
01677 *                          If got really bad answer, report and return.
01678                            IF( FATAL )
01679      $                        GO TO 130
01680    70                   CONTINUE
01681                      ELSE
01682 *                       Avoid repeating tests with M.le.0 or N.le.0.
01683                         GO TO 110
01684                      END IF
01685 *
01686    80             CONTINUE
01687 *
01688    90          CONTINUE
01689 *
01690   100       CONTINUE
01691 *
01692   110    CONTINUE
01693 *
01694   120 CONTINUE
01695 *
01696 *     Report result.
01697 *
01698       IF( ERRMAX.LT.THRESH )THEN
01699          WRITE( NOUT, FMT = 9999 )SNAME, NC
01700       ELSE
01701          WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
01702       END IF
01703       GO TO 150
01704 *
01705   130 CONTINUE
01706       WRITE( NOUT, FMT = 9995 )J
01707 *
01708   140 CONTINUE
01709       WRITE( NOUT, FMT = 9996 )SNAME
01710       WRITE( NOUT, FMT = 9994 )NC, SNAME, M, N, ALPHA, INCX, INCY, LDA
01711 *
01712   150 CONTINUE
01713       RETURN
01714 *
01715  9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
01716      $      'S)' )
01717  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
01718      $      'ANGED INCORRECTLY *******' )
01719  9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
01720      $      'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
01721      $      ' - SUSPECT *******' )
01722  9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
01723  9995 FORMAT( '      THESE ARE THE RESULTS FOR COLUMN ', I3 )
01724  9994 FORMAT( 1X, I6, ': ', A6, '(', 2( I3, ',' ), '(', F4.1, ',', F4.1,
01725      $      '), X,', I2, ', Y,', I2, ', A,', I3, ')                   ',
01726      $      '      .' )
01727  9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
01728      $      '******' )
01729 *
01730 *     End of CCHK4.
01731 *
01732       END
01733       SUBROUTINE CCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
01734      $                  FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX,
01735      $                  INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G,
01736      $                  Z )
01737 *
01738 *  Tests CHER and CHPR.
01739 *
01740 *  Auxiliary routine for test program for Level 2 Blas.
01741 *
01742 *  -- Written on 10-August-1987.
01743 *     Richard Hanson, Sandia National Labs.
01744 *     Jeremy Du Croz, NAG Central Office.
01745 *
01746 *     .. Parameters ..
01747       COMPLEX            ZERO, HALF, ONE
01748       PARAMETER          ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ),
01749      $                   ONE = ( 1.0, 0.0 ) )
01750       REAL               RZERO
01751       PARAMETER          ( RZERO = 0.0 )
01752 *     .. Scalar Arguments ..
01753       REAL               EPS, THRESH
01754       INTEGER            INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA
01755       LOGICAL            FATAL, REWI, TRACE
01756       CHARACTER*6        SNAME
01757 *     .. Array Arguments ..
01758       COMPLEX            A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
01759      $                   AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ),
01760      $                   XX( NMAX*INCMAX ), Y( NMAX ),
01761      $                   YS( NMAX*INCMAX ), YT( NMAX ),
01762      $                   YY( NMAX*INCMAX ), Z( NMAX )
01763       REAL               G( NMAX )
01764       INTEGER            IDIM( NIDIM ), INC( NINC )
01765 *     .. Local Scalars ..
01766       COMPLEX            ALPHA, TRANSL
01767       REAL               ERR, ERRMAX, RALPHA, RALS
01768       INTEGER            I, IA, IC, IN, INCX, INCXS, IX, J, JA, JJ, LAA,
01769      $                   LDA, LDAS, LJ, LX, N, NARGS, NC, NS
01770       LOGICAL            FULL, NULL, PACKED, RESET, SAME, UPPER
01771       CHARACTER*1        UPLO, UPLOS
01772       CHARACTER*2        ICH
01773 *     .. Local Arrays ..
01774       COMPLEX            W( 1 )
01775       LOGICAL            ISAME( 13 )
01776 *     .. External Functions ..
01777       LOGICAL            LCE, LCERES
01778       EXTERNAL           LCE, LCERES
01779 *     .. External Subroutines ..
01780       EXTERNAL           CHER, CHPR, CMAKE, CMVCH
01781 *     .. Intrinsic Functions ..
01782       INTRINSIC          ABS, CMPLX, CONJG, MAX, REAL
01783 *     .. Scalars in Common ..
01784       INTEGER            INFOT, NOUTC
01785       LOGICAL            LERR, OK
01786 *     .. Common blocks ..
01787       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
01788 *     .. Data statements ..
01789       DATA               ICH/'UL'/
01790 *     .. Executable Statements ..
01791       FULL = SNAME( 3: 3 ).EQ.'E'
01792       PACKED = SNAME( 3: 3 ).EQ.'P'
01793 *     Define the number of arguments.
01794       IF( FULL )THEN
01795          NARGS = 7
01796       ELSE IF( PACKED )THEN
01797          NARGS = 6
01798       END IF
01799 *
01800       NC = 0
01801       RESET = .TRUE.
01802       ERRMAX = RZERO
01803 *
01804       DO 100 IN = 1, NIDIM
01805          N = IDIM( IN )
01806 *        Set LDA to 1 more than minimum value if room.
01807          LDA = N
01808          IF( LDA.LT.NMAX )
01809      $      LDA = LDA + 1
01810 *        Skip tests if not enough room.
01811          IF( LDA.GT.NMAX )
01812      $      GO TO 100
01813          IF( PACKED )THEN
01814             LAA = ( N*( N + 1 ) )/2
01815          ELSE
01816             LAA = LDA*N
01817          END IF
01818 *
01819          DO 90 IC = 1, 2
01820             UPLO = ICH( IC: IC )
01821             UPPER = UPLO.EQ.'U'
01822 *
01823             DO 80 IX = 1, NINC
01824                INCX = INC( IX )
01825                LX = ABS( INCX )*N
01826 *
01827 *              Generate the vector X.
01828 *
01829                TRANSL = HALF
01830                CALL CMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ),
01831      $                     0, N - 1, RESET, TRANSL )
01832                IF( N.GT.1 )THEN
01833                   X( N/2 ) = ZERO
01834                   XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
01835                END IF
01836 *
01837                DO 70 IA = 1, NALF
01838                   RALPHA = REAL( ALF( IA ) )
01839                   ALPHA = CMPLX( RALPHA, RZERO )
01840                   NULL = N.LE.0.OR.RALPHA.EQ.RZERO
01841 *
01842 *                 Generate the matrix A.
01843 *
01844                   TRANSL = ZERO
01845                   CALL CMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, NMAX,
01846      $                        AA, LDA, N - 1, N - 1, RESET, TRANSL )
01847 *
01848                   NC = NC + 1
01849 *
01850 *                 Save every datum before calling the subroutine.
01851 *
01852                   UPLOS = UPLO
01853                   NS = N
01854                   RALS = RALPHA
01855                   DO 10 I = 1, LAA
01856                      AS( I ) = AA( I )
01857    10             CONTINUE
01858                   LDAS = LDA
01859                   DO 20 I = 1, LX
01860                      XS( I ) = XX( I )
01861    20             CONTINUE
01862                   INCXS = INCX
01863 *
01864 *                 Call the subroutine.
01865 *
01866                   IF( FULL )THEN
01867                      IF( TRACE )
01868      $                  WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, N,
01869      $                  RALPHA, INCX, LDA
01870                      IF( REWI )
01871      $                  REWIND NTRA
01872                      CALL CHER( UPLO, N, RALPHA, XX, INCX, AA, LDA )
01873                   ELSE IF( PACKED )THEN
01874                      IF( TRACE )
01875      $                  WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, N,
01876      $                  RALPHA, INCX
01877                      IF( REWI )
01878      $                  REWIND NTRA
01879                      CALL CHPR( UPLO, N, RALPHA, XX, INCX, AA )
01880                   END IF
01881 *
01882 *                 Check if error-exit was taken incorrectly.
01883 *
01884                   IF( .NOT.OK )THEN
01885                      WRITE( NOUT, FMT = 9992 )
01886                      FATAL = .TRUE.
01887                      GO TO 120
01888                   END IF
01889 *
01890 *                 See what data changed inside subroutines.
01891 *
01892                   ISAME( 1 ) = UPLO.EQ.UPLOS
01893                   ISAME( 2 ) = NS.EQ.N
01894                   ISAME( 3 ) = RALS.EQ.RALPHA
01895                   ISAME( 4 ) = LCE( XS, XX, LX )
01896                   ISAME( 5 ) = INCXS.EQ.INCX
01897                   IF( NULL )THEN
01898                      ISAME( 6 ) = LCE( AS, AA, LAA )
01899                   ELSE
01900                      ISAME( 6 ) = LCERES( SNAME( 2: 3 ), UPLO, N, N, AS,
01901      $                            AA, LDA )
01902                   END IF
01903                   IF( .NOT.PACKED )THEN
01904                      ISAME( 7 ) = LDAS.EQ.LDA
01905                   END IF
01906 *
01907 *                 If data was incorrectly changed, report and return.
01908 *
01909                   SAME = .TRUE.
01910                   DO 30 I = 1, NARGS
01911                      SAME = SAME.AND.ISAME( I )
01912                      IF( .NOT.ISAME( I ) )
01913      $                  WRITE( NOUT, FMT = 9998 )I
01914    30             CONTINUE
01915                   IF( .NOT.SAME )THEN
01916                      FATAL = .TRUE.
01917                      GO TO 120
01918                   END IF
01919 *
01920                   IF( .NOT.NULL )THEN
01921 *
01922 *                    Check the result column by column.
01923 *
01924                      IF( INCX.GT.0 )THEN
01925                         DO 40 I = 1, N
01926                            Z( I ) = X( I )
01927    40                   CONTINUE
01928                      ELSE
01929                         DO 50 I = 1, N
01930                            Z( I ) = X( N - I + 1 )
01931    50                   CONTINUE
01932                      END IF
01933                      JA = 1
01934                      DO 60 J = 1, N
01935                         W( 1 ) = CONJG( Z( J ) )
01936                         IF( UPPER )THEN
01937                            JJ = 1
01938                            LJ = J
01939                         ELSE
01940                            JJ = J
01941                            LJ = N - J + 1
01942                         END IF
01943                         CALL CMVCH( 'N', LJ, 1, ALPHA, Z( JJ ), LJ, W,
01944      $                              1, ONE, A( JJ, J ), 1, YT, G,
01945      $                              AA( JA ), EPS, ERR, FATAL, NOUT,
01946      $                              .TRUE. )
01947                         IF( FULL )THEN
01948                            IF( UPPER )THEN
01949                               JA = JA + LDA
01950                            ELSE
01951                               JA = JA + LDA + 1
01952                            END IF
01953                         ELSE
01954                            JA = JA + LJ
01955                         END IF
01956                         ERRMAX = MAX( ERRMAX, ERR )
01957 *                       If got really bad answer, report and return.
01958                         IF( FATAL )
01959      $                     GO TO 110
01960    60                CONTINUE
01961                   ELSE
01962 *                    Avoid repeating tests if N.le.0.
01963                      IF( N.LE.0 )
01964      $                  GO TO 100
01965                   END IF
01966 *
01967    70          CONTINUE
01968 *
01969    80       CONTINUE
01970 *
01971    90    CONTINUE
01972 *
01973   100 CONTINUE
01974 *
01975 *     Report result.
01976 *
01977       IF( ERRMAX.LT.THRESH )THEN
01978          WRITE( NOUT, FMT = 9999 )SNAME, NC
01979       ELSE
01980          WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
01981       END IF
01982       GO TO 130
01983 *
01984   110 CONTINUE
01985       WRITE( NOUT, FMT = 9995 )J
01986 *
01987   120 CONTINUE
01988       WRITE( NOUT, FMT = 9996 )SNAME
01989       IF( FULL )THEN
01990          WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, RALPHA, INCX, LDA
01991       ELSE IF( PACKED )THEN
01992          WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, RALPHA, INCX
01993       END IF
01994 *
01995   130 CONTINUE
01996       RETURN
01997 *
01998  9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
01999      $      'S)' )
02000  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
02001      $      'ANGED INCORRECTLY *******' )
02002  9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
02003      $      'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
02004      $      ' - SUSPECT *******' )
02005  9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
02006  9995 FORMAT( '      THESE ARE THE RESULTS FOR COLUMN ', I3 )
02007  9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,',
02008      $      I2, ', AP)                                         .' )
02009  9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,',
02010      $      I2, ', A,', I3, ')                                      .' )
02011  9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
02012      $      '******' )
02013 *
02014 *     End of CCHK5.
02015 *
02016       END
02017       SUBROUTINE CCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
02018      $                  FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX,
02019      $                  INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G,
02020      $                  Z )
02021 *
02022 *  Tests CHER2 and CHPR2.
02023 *
02024 *  Auxiliary routine for test program for Level 2 Blas.
02025 *
02026 *  -- Written on 10-August-1987.
02027 *     Richard Hanson, Sandia National Labs.
02028 *     Jeremy Du Croz, NAG Central Office.
02029 *
02030 *     .. Parameters ..
02031       COMPLEX            ZERO, HALF, ONE
02032       PARAMETER          ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ),
02033      $                   ONE = ( 1.0, 0.0 ) )
02034       REAL               RZERO
02035       PARAMETER          ( RZERO = 0.0 )
02036 *     .. Scalar Arguments ..
02037       REAL               EPS, THRESH
02038       INTEGER            INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA
02039       LOGICAL            FATAL, REWI, TRACE
02040       CHARACTER*6        SNAME
02041 *     .. Array Arguments ..
02042       COMPLEX            A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
02043      $                   AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ),
02044      $                   XX( NMAX*INCMAX ), Y( NMAX ),
02045      $                   YS( NMAX*INCMAX ), YT( NMAX ),
02046      $                   YY( NMAX*INCMAX ), Z( NMAX, 2 )
02047       REAL               G( NMAX )
02048       INTEGER            IDIM( NIDIM ), INC( NINC )
02049 *     .. Local Scalars ..
02050       COMPLEX            ALPHA, ALS, TRANSL
02051       REAL               ERR, ERRMAX
02052       INTEGER            I, IA, IC, IN, INCX, INCXS, INCY, INCYS, IX,
02053      $                   IY, J, JA, JJ, LAA, LDA, LDAS, LJ, LX, LY, N,
02054      $                   NARGS, NC, NS
02055       LOGICAL            FULL, NULL, PACKED, RESET, SAME, UPPER
02056       CHARACTER*1        UPLO, UPLOS
02057       CHARACTER*2        ICH
02058 *     .. Local Arrays ..
02059       COMPLEX            W( 2 )
02060       LOGICAL            ISAME( 13 )
02061 *     .. External Functions ..
02062       LOGICAL            LCE, LCERES
02063       EXTERNAL           LCE, LCERES
02064 *     .. External Subroutines ..
02065       EXTERNAL           CHER2, CHPR2, CMAKE, CMVCH
02066 *     .. Intrinsic Functions ..
02067       INTRINSIC          ABS, CONJG, MAX
02068 *     .. Scalars in Common ..
02069       INTEGER            INFOT, NOUTC
02070       LOGICAL            LERR, OK
02071 *     .. Common blocks ..
02072       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
02073 *     .. Data statements ..
02074       DATA               ICH/'UL'/
02075 *     .. Executable Statements ..
02076       FULL = SNAME( 3: 3 ).EQ.'E'
02077       PACKED = SNAME( 3: 3 ).EQ.'P'
02078 *     Define the number of arguments.
02079       IF( FULL )THEN
02080          NARGS = 9
02081       ELSE IF( PACKED )THEN
02082          NARGS = 8
02083       END IF
02084 *
02085       NC = 0
02086       RESET = .TRUE.
02087       ERRMAX = RZERO
02088 *
02089       DO 140 IN = 1, NIDIM
02090          N = IDIM( IN )
02091 *        Set LDA to 1 more than minimum value if room.
02092          LDA = N
02093          IF( LDA.LT.NMAX )
02094      $      LDA = LDA + 1
02095 *        Skip tests if not enough room.
02096          IF( LDA.GT.NMAX )
02097      $      GO TO 140
02098          IF( PACKED )THEN
02099             LAA = ( N*( N + 1 ) )/2
02100          ELSE
02101             LAA = LDA*N
02102          END IF
02103 *
02104          DO 130 IC = 1, 2
02105             UPLO = ICH( IC: IC )
02106             UPPER = UPLO.EQ.'U'
02107 *
02108             DO 120 IX = 1, NINC
02109                INCX = INC( IX )
02110                LX = ABS( INCX )*N
02111 *
02112 *              Generate the vector X.
02113 *
02114                TRANSL = HALF
02115                CALL CMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ),
02116      $                     0, N - 1, RESET, TRANSL )
02117                IF( N.GT.1 )THEN
02118                   X( N/2 ) = ZERO
02119                   XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
02120                END IF
02121 *
02122                DO 110 IY = 1, NINC
02123                   INCY = INC( IY )
02124                   LY = ABS( INCY )*N
02125 *
02126 *                 Generate the vector Y.
02127 *
02128                   TRANSL = ZERO
02129                   CALL CMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY,
02130      $                        ABS( INCY ), 0, N - 1, RESET, TRANSL )
02131                   IF( N.GT.1 )THEN
02132                      Y( N/2 ) = ZERO
02133                      YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO
02134                   END IF
02135 *
02136                   DO 100 IA = 1, NALF
02137                      ALPHA = ALF( IA )
02138                      NULL = N.LE.0.OR.ALPHA.EQ.ZERO
02139 *
02140 *                    Generate the matrix A.
02141 *
02142                      TRANSL = ZERO
02143                      CALL CMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A,
02144      $                           NMAX, AA, LDA, N - 1, N - 1, RESET,
02145      $                           TRANSL )
02146 *
02147                      NC = NC + 1
02148 *
02149 *                    Save every datum before calling the subroutine.
02150 *
02151                      UPLOS = UPLO
02152                      NS = N
02153                      ALS = ALPHA
02154                      DO 10 I = 1, LAA
02155                         AS( I ) = AA( I )
02156    10                CONTINUE
02157                      LDAS = LDA
02158                      DO 20 I = 1, LX
02159                         XS( I ) = XX( I )
02160    20                CONTINUE
02161                      INCXS = INCX
02162                      DO 30 I = 1, LY
02163                         YS( I ) = YY( I )
02164    30                CONTINUE
02165                      INCYS = INCY
02166 *
02167 *                    Call the subroutine.
02168 *
02169                      IF( FULL )THEN
02170                         IF( TRACE )
02171      $                     WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, N,
02172      $                     ALPHA, INCX, INCY, LDA
02173                         IF( REWI )
02174      $                     REWIND NTRA
02175                         CALL CHER2( UPLO, N, ALPHA, XX, INCX, YY, INCY,
02176      $                              AA, LDA )
02177                      ELSE IF( PACKED )THEN
02178                         IF( TRACE )
02179      $                     WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, N,
02180      $                     ALPHA, INCX, INCY
02181                         IF( REWI )
02182      $                     REWIND NTRA
02183                         CALL CHPR2( UPLO, N, ALPHA, XX, INCX, YY, INCY,
02184      $                              AA )
02185                      END IF
02186 *
02187 *                    Check if error-exit was taken incorrectly.
02188 *
02189                      IF( .NOT.OK )THEN
02190                         WRITE( NOUT, FMT = 9992 )
02191                         FATAL = .TRUE.
02192                         GO TO 160
02193                      END IF
02194 *
02195 *                    See what data changed inside subroutines.
02196 *
02197                      ISAME( 1 ) = UPLO.EQ.UPLOS
02198                      ISAME( 2 ) = NS.EQ.N
02199                      ISAME( 3 ) = ALS.EQ.ALPHA
02200                      ISAME( 4 ) = LCE( XS, XX, LX )
02201                      ISAME( 5 ) = INCXS.EQ.INCX
02202                      ISAME( 6 ) = LCE( YS, YY, LY )
02203                      ISAME( 7 ) = INCYS.EQ.INCY
02204                      IF( NULL )THEN
02205                         ISAME( 8 ) = LCE( AS, AA, LAA )
02206                      ELSE
02207                         ISAME( 8 ) = LCERES( SNAME( 2: 3 ), UPLO, N, N,
02208      $                               AS, AA, LDA )
02209                      END IF
02210                      IF( .NOT.PACKED )THEN
02211                         ISAME( 9 ) = LDAS.EQ.LDA
02212                      END IF
02213 *
02214 *                    If data was incorrectly changed, report and return.
02215 *
02216                      SAME = .TRUE.
02217                      DO 40 I = 1, NARGS
02218                         SAME = SAME.AND.ISAME( I )
02219                         IF( .NOT.ISAME( I ) )
02220      $                     WRITE( NOUT, FMT = 9998 )I
02221    40                CONTINUE
02222                      IF( .NOT.SAME )THEN
02223                         FATAL = .TRUE.
02224                         GO TO 160
02225                      END IF
02226 *
02227                      IF( .NOT.NULL )THEN
02228 *
02229 *                       Check the result column by column.
02230 *
02231                         IF( INCX.GT.0 )THEN
02232                            DO 50 I = 1, N
02233                               Z( I, 1 ) = X( I )
02234    50                      CONTINUE
02235                         ELSE
02236                            DO 60 I = 1, N
02237                               Z( I, 1 ) = X( N - I + 1 )
02238    60                      CONTINUE
02239                         END IF
02240                         IF( INCY.GT.0 )THEN
02241                            DO 70 I = 1, N
02242                               Z( I, 2 ) = Y( I )
02243    70                      CONTINUE
02244                         ELSE
02245                            DO 80 I = 1, N
02246                               Z( I, 2 ) = Y( N - I + 1 )
02247    80                      CONTINUE
02248                         END IF
02249                         JA = 1
02250                         DO 90 J = 1, N
02251                            W( 1 ) = ALPHA*CONJG( Z( J, 2 ) )
02252                            W( 2 ) = CONJG( ALPHA )*CONJG( Z( J, 1 ) )
02253                            IF( UPPER )THEN
02254                               JJ = 1
02255                               LJ = J
02256                            ELSE
02257                               JJ = J
02258                               LJ = N - J + 1
02259                            END IF
02260                            CALL CMVCH( 'N', LJ, 2, ONE, Z( JJ, 1 ),
02261      $                                 NMAX, W, 1, ONE, A( JJ, J ), 1,
02262      $                                 YT, G, AA( JA ), EPS, ERR, FATAL,
02263      $                                 NOUT, .TRUE. )
02264                            IF( FULL )THEN
02265                               IF( UPPER )THEN
02266                                  JA = JA + LDA
02267                               ELSE
02268                                  JA = JA + LDA + 1
02269                               END IF
02270                            ELSE
02271                               JA = JA + LJ
02272                            END IF
02273                            ERRMAX = MAX( ERRMAX, ERR )
02274 *                          If got really bad answer, report and return.
02275                            IF( FATAL )
02276      $                        GO TO 150
02277    90                   CONTINUE
02278                      ELSE
02279 *                       Avoid repeating tests with N.le.0.
02280                         IF( N.LE.0 )
02281      $                     GO TO 140
02282                      END IF
02283 *
02284   100             CONTINUE
02285 *
02286   110          CONTINUE
02287 *
02288   120       CONTINUE
02289 *
02290   130    CONTINUE
02291 *
02292   140 CONTINUE
02293 *
02294 *     Report result.
02295 *
02296       IF( ERRMAX.LT.THRESH )THEN
02297          WRITE( NOUT, FMT = 9999 )SNAME, NC
02298       ELSE
02299          WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
02300       END IF
02301       GO TO 170
02302 *
02303   150 CONTINUE
02304       WRITE( NOUT, FMT = 9995 )J
02305 *
02306   160 CONTINUE
02307       WRITE( NOUT, FMT = 9996 )SNAME
02308       IF( FULL )THEN
02309          WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, INCX,
02310      $      INCY, LDA
02311       ELSE IF( PACKED )THEN
02312          WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, ALPHA, INCX, INCY
02313       END IF
02314 *
02315   170 CONTINUE
02316       RETURN
02317 *
02318  9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
02319      $      'S)' )
02320  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
02321      $      'ANGED INCORRECTLY *******' )
02322  9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
02323      $      'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
02324      $      ' - SUSPECT *******' )
02325  9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
02326  9995 FORMAT( '      THESE ARE THE RESULTS FOR COLUMN ', I3 )
02327  9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',(', F4.1, ',',
02328      $      F4.1, '), X,', I2, ', Y,', I2, ', AP)                     ',
02329      $      '       .' )
02330  9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',(', F4.1, ',',
02331      $      F4.1, '), X,', I2, ', Y,', I2, ', A,', I3, ')             ',
02332      $      '            .' )
02333  9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
02334      $      '******' )
02335 *
02336 *     End of CCHK6.
02337 *
02338       END
02339       SUBROUTINE CCHKE( ISNUM, SRNAMT, NOUT )
02340 *
02341 *  Tests the error exits from the Level 2 Blas.
02342 *  Requires a special version of the error-handling routine XERBLA.
02343 *  ALPHA, RALPHA, BETA, A, X and Y should not need to be defined.
02344 *
02345 *  Auxiliary routine for test program for Level 2 Blas.
02346 *
02347 *  -- Written on 10-August-1987.
02348 *     Richard Hanson, Sandia National Labs.
02349 *     Jeremy Du Croz, NAG Central Office.
02350 *
02351 *     .. Scalar Arguments ..
02352       INTEGER            ISNUM, NOUT
02353       CHARACTER*6        SRNAMT
02354 *     .. Scalars in Common ..
02355       INTEGER            INFOT, NOUTC
02356       LOGICAL            LERR, OK
02357 *     .. Local Scalars ..
02358       COMPLEX            ALPHA, BETA
02359       REAL               RALPHA
02360 *     .. Local Arrays ..
02361       COMPLEX            A( 1, 1 ), X( 1 ), Y( 1 )
02362 *     .. External Subroutines ..
02363       EXTERNAL           CGBMV, CGEMV, CGERC, CGERU, CHBMV, CHEMV, CHER,
02364      $                   CHER2, CHKXER, CHPMV, CHPR, CHPR2, CTBMV,
02365      $                   CTBSV, CTPMV, CTPSV, CTRMV, CTRSV
02366 *     .. Common blocks ..
02367       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
02368 *     .. Executable Statements ..
02369 *     OK is set to .FALSE. by the special version of XERBLA or by CHKXER
02370 *     if anything is wrong.
02371       OK = .TRUE.
02372 *     LERR is set to .TRUE. by the special version of XERBLA each time
02373 *     it is called, and is then tested and re-set by CHKXER.
02374       LERR = .FALSE.
02375       GO TO ( 10, 20, 30, 40, 50, 60, 70, 80,
02376      $        90, 100, 110, 120, 130, 140, 150, 160,
02377      $        170 )ISNUM
02378    10 INFOT = 1
02379       CALL CGEMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
02380       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02381       INFOT = 2
02382       CALL CGEMV( 'N', -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
02383       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02384       INFOT = 3
02385       CALL CGEMV( 'N', 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 )
02386       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02387       INFOT = 6
02388       CALL CGEMV( 'N', 2, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
02389       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02390       INFOT = 8
02391       CALL CGEMV( 'N', 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 )
02392       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02393       INFOT = 11
02394       CALL CGEMV( 'N', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 )
02395       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02396       GO TO 180
02397    20 INFOT = 1
02398       CALL CGBMV( '/', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
02399       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02400       INFOT = 2
02401       CALL CGBMV( 'N', -1, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
02402       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02403       INFOT = 3
02404       CALL CGBMV( 'N', 0, -1, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
02405       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02406       INFOT = 4
02407       CALL CGBMV( 'N', 0, 0, -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
02408       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02409       INFOT = 5
02410       CALL CGBMV( 'N', 2, 0, 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 )
02411       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02412       INFOT = 8
02413       CALL CGBMV( 'N', 0, 0, 1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
02414       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02415       INFOT = 10
02416       CALL CGBMV( 'N', 0, 0, 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 )
02417       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02418       INFOT = 13
02419       CALL CGBMV( 'N', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 )
02420       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02421       GO TO 180
02422    30 INFOT = 1
02423       CALL CHEMV( '/', 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
02424       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02425       INFOT = 2
02426       CALL CHEMV( 'U', -1, ALPHA, A, 1, X, 1, BETA, Y, 1 )
02427       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02428       INFOT = 5
02429       CALL CHEMV( 'U', 2, ALPHA, A, 1, X, 1, BETA, Y, 1 )
02430       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02431       INFOT = 7
02432       CALL CHEMV( 'U', 0, ALPHA, A, 1, X, 0, BETA, Y, 1 )
02433       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02434       INFOT = 10
02435       CALL CHEMV( 'U', 0, ALPHA, A, 1, X, 1, BETA, Y, 0 )
02436       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02437       GO TO 180
02438    40 INFOT = 1
02439       CALL CHBMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
02440       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02441       INFOT = 2
02442       CALL CHBMV( 'U', -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
02443       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02444       INFOT = 3
02445       CALL CHBMV( 'U', 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 )
02446       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02447       INFOT = 6
02448       CALL CHBMV( 'U', 0, 1, ALPHA, A, 1, X, 1, BETA, Y, 1 )
02449       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02450       INFOT = 8
02451       CALL CHBMV( 'U', 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 )
02452       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02453       INFOT = 11
02454       CALL CHBMV( 'U', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 )
02455       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02456       GO TO 180
02457    50 INFOT = 1
02458       CALL CHPMV( '/', 0, ALPHA, A, X, 1, BETA, Y, 1 )
02459       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02460       INFOT = 2
02461       CALL CHPMV( 'U', -1, ALPHA, A, X, 1, BETA, Y, 1 )
02462       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02463       INFOT = 6
02464       CALL CHPMV( 'U', 0, ALPHA, A, X, 0, BETA, Y, 1 )
02465       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02466       INFOT = 9
02467       CALL CHPMV( 'U', 0, ALPHA, A, X, 1, BETA, Y, 0 )
02468       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02469       GO TO 180
02470    60 INFOT = 1
02471       CALL CTRMV( '/', 'N', 'N', 0, A, 1, X, 1 )
02472       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02473       INFOT = 2
02474       CALL CTRMV( 'U', '/', 'N', 0, A, 1, X, 1 )
02475       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02476       INFOT = 3
02477       CALL CTRMV( 'U', 'N', '/', 0, A, 1, X, 1 )
02478       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02479       INFOT = 4
02480       CALL CTRMV( 'U', 'N', 'N', -1, A, 1, X, 1 )
02481       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02482       INFOT = 6
02483       CALL CTRMV( 'U', 'N', 'N', 2, A, 1, X, 1 )
02484       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02485       INFOT = 8
02486       CALL CTRMV( 'U', 'N', 'N', 0, A, 1, X, 0 )
02487       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02488       GO TO 180
02489    70 INFOT = 1
02490       CALL CTBMV( '/', 'N', 'N', 0, 0, A, 1, X, 1 )
02491       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02492       INFOT = 2
02493       CALL CTBMV( 'U', '/', 'N', 0, 0, A, 1, X, 1 )
02494       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02495       INFOT = 3
02496       CALL CTBMV( 'U', 'N', '/', 0, 0, A, 1, X, 1 )
02497       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02498       INFOT = 4
02499       CALL CTBMV( 'U', 'N', 'N', -1, 0, A, 1, X, 1 )
02500       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02501       INFOT = 5
02502       CALL CTBMV( 'U', 'N', 'N', 0, -1, A, 1, X, 1 )
02503       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02504       INFOT = 7
02505       CALL CTBMV( 'U', 'N', 'N', 0, 1, A, 1, X, 1 )
02506       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02507       INFOT = 9
02508       CALL CTBMV( 'U', 'N', 'N', 0, 0, A, 1, X, 0 )
02509       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02510       GO TO 180
02511    80 INFOT = 1
02512       CALL CTPMV( '/', 'N', 'N', 0, A, X, 1 )
02513       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02514       INFOT = 2
02515       CALL CTPMV( 'U', '/', 'N', 0, A, X, 1 )
02516       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02517       INFOT = 3
02518       CALL CTPMV( 'U', 'N', '/', 0, A, X, 1 )
02519       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02520       INFOT = 4
02521       CALL CTPMV( 'U', 'N', 'N', -1, A, X, 1 )
02522       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02523       INFOT = 7
02524       CALL CTPMV( 'U', 'N', 'N', 0, A, X, 0 )
02525       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02526       GO TO 180
02527    90 INFOT = 1
02528       CALL CTRSV( '/', 'N', 'N', 0, A, 1, X, 1 )
02529       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02530       INFOT = 2
02531       CALL CTRSV( 'U', '/', 'N', 0, A, 1, X, 1 )
02532       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02533       INFOT = 3
02534       CALL CTRSV( 'U', 'N', '/', 0, A, 1, X, 1 )
02535       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02536       INFOT = 4
02537       CALL CTRSV( 'U', 'N', 'N', -1, A, 1, X, 1 )
02538       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02539       INFOT = 6
02540       CALL CTRSV( 'U', 'N', 'N', 2, A, 1, X, 1 )
02541       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02542       INFOT = 8
02543       CALL CTRSV( 'U', 'N', 'N', 0, A, 1, X, 0 )
02544       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02545       GO TO 180
02546   100 INFOT = 1
02547       CALL CTBSV( '/', 'N', 'N', 0, 0, A, 1, X, 1 )
02548       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02549       INFOT = 2
02550       CALL CTBSV( 'U', '/', 'N', 0, 0, A, 1, X, 1 )
02551       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02552       INFOT = 3
02553       CALL CTBSV( 'U', 'N', '/', 0, 0, A, 1, X, 1 )
02554       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02555       INFOT = 4
02556       CALL CTBSV( 'U', 'N', 'N', -1, 0, A, 1, X, 1 )
02557       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02558       INFOT = 5
02559       CALL CTBSV( 'U', 'N', 'N', 0, -1, A, 1, X, 1 )
02560       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02561       INFOT = 7
02562       CALL CTBSV( 'U', 'N', 'N', 0, 1, A, 1, X, 1 )
02563       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02564       INFOT = 9
02565       CALL CTBSV( 'U', 'N', 'N', 0, 0, A, 1, X, 0 )
02566       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02567       GO TO 180
02568   110 INFOT = 1
02569       CALL CTPSV( '/', 'N', 'N', 0, A, X, 1 )
02570       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02571       INFOT = 2
02572       CALL CTPSV( 'U', '/', 'N', 0, A, X, 1 )
02573       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02574       INFOT = 3
02575       CALL CTPSV( 'U', 'N', '/', 0, A, X, 1 )
02576       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02577       INFOT = 4
02578       CALL CTPSV( 'U', 'N', 'N', -1, A, X, 1 )
02579       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02580       INFOT = 7
02581       CALL CTPSV( 'U', 'N', 'N', 0, A, X, 0 )
02582       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02583       GO TO 180
02584   120 INFOT = 1
02585       CALL CGERC( -1, 0, ALPHA, X, 1, Y, 1, A, 1 )
02586       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02587       INFOT = 2
02588       CALL CGERC( 0, -1, ALPHA, X, 1, Y, 1, A, 1 )
02589       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02590       INFOT = 5
02591       CALL CGERC( 0, 0, ALPHA, X, 0, Y, 1, A, 1 )
02592       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02593       INFOT = 7
02594       CALL CGERC( 0, 0, ALPHA, X, 1, Y, 0, A, 1 )
02595       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02596       INFOT = 9
02597       CALL CGERC( 2, 0, ALPHA, X, 1, Y, 1, A, 1 )
02598       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02599       GO TO 180
02600   130 INFOT = 1
02601       CALL CGERU( -1, 0, ALPHA, X, 1, Y, 1, A, 1 )
02602       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02603       INFOT = 2
02604       CALL CGERU( 0, -1, ALPHA, X, 1, Y, 1, A, 1 )
02605       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02606       INFOT = 5
02607       CALL CGERU( 0, 0, ALPHA, X, 0, Y, 1, A, 1 )
02608       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02609       INFOT = 7
02610       CALL CGERU( 0, 0, ALPHA, X, 1, Y, 0, A, 1 )
02611       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02612       INFOT = 9
02613       CALL CGERU( 2, 0, ALPHA, X, 1, Y, 1, A, 1 )
02614       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02615       GO TO 180
02616   140 INFOT = 1
02617       CALL CHER( '/', 0, RALPHA, X, 1, A, 1 )
02618       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02619       INFOT = 2
02620       CALL CHER( 'U', -1, RALPHA, X, 1, A, 1 )
02621       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02622       INFOT = 5
02623       CALL CHER( 'U', 0, RALPHA, X, 0, A, 1 )
02624       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02625       INFOT = 7
02626       CALL CHER( 'U', 2, RALPHA, X, 1, A, 1 )
02627       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02628       GO TO 180
02629   150 INFOT = 1
02630       CALL CHPR( '/', 0, RALPHA, X, 1, A )
02631       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02632       INFOT = 2
02633       CALL CHPR( 'U', -1, RALPHA, X, 1, A )
02634       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02635       INFOT = 5
02636       CALL CHPR( 'U', 0, RALPHA, X, 0, A )
02637       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02638       GO TO 180
02639   160 INFOT = 1
02640       CALL CHER2( '/', 0, ALPHA, X, 1, Y, 1, A, 1 )
02641       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02642       INFOT = 2
02643       CALL CHER2( 'U', -1, ALPHA, X, 1, Y, 1, A, 1 )
02644       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02645       INFOT = 5
02646       CALL CHER2( 'U', 0, ALPHA, X, 0, Y, 1, A, 1 )
02647       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02648       INFOT = 7
02649       CALL CHER2( 'U', 0, ALPHA, X, 1, Y, 0, A, 1 )
02650       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02651       INFOT = 9
02652       CALL CHER2( 'U', 2, ALPHA, X, 1, Y, 1, A, 1 )
02653       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02654       GO TO 180
02655   170 INFOT = 1
02656       CALL CHPR2( '/', 0, ALPHA, X, 1, Y, 1, A )
02657       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02658       INFOT = 2
02659       CALL CHPR2( 'U', -1, ALPHA, X, 1, Y, 1, A )
02660       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02661       INFOT = 5
02662       CALL CHPR2( 'U', 0, ALPHA, X, 0, Y, 1, A )
02663       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02664       INFOT = 7
02665       CALL CHPR2( 'U', 0, ALPHA, X, 1, Y, 0, A )
02666       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02667 *
02668   180 IF( OK )THEN
02669          WRITE( NOUT, FMT = 9999 )SRNAMT
02670       ELSE
02671          WRITE( NOUT, FMT = 9998 )SRNAMT
02672       END IF
02673       RETURN
02674 *
02675  9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' )
02676  9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****',
02677      $      '**' )
02678 *
02679 *     End of CCHKE.
02680 *
02681       END
02682       SUBROUTINE CMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL,
02683      $                  KU, RESET, TRANSL )
02684 *
02685 *  Generates values for an M by N matrix A within the bandwidth
02686 *  defined by KL and KU.
02687 *  Stores the values in the array AA in the data structure required
02688 *  by the routine, with unwanted elements set to rogue value.
02689 *
02690 *  TYPE is 'GE', 'GB', 'HE', 'HB', 'HP', 'TR', 'TB' OR 'TP'.
02691 *
02692 *  Auxiliary routine for test program for Level 2 Blas.
02693 *
02694 *  -- Written on 10-August-1987.
02695 *     Richard Hanson, Sandia National Labs.
02696 *     Jeremy Du Croz, NAG Central Office.
02697 *
02698 *     .. Parameters ..
02699       COMPLEX            ZERO, ONE
02700       PARAMETER          ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) )
02701       COMPLEX            ROGUE
02702       PARAMETER          ( ROGUE = ( -1.0E10, 1.0E10 ) )
02703       REAL               RZERO
02704       PARAMETER          ( RZERO = 0.0 )
02705       REAL               RROGUE
02706       PARAMETER          ( RROGUE = -1.0E10 )
02707 *     .. Scalar Arguments ..
02708       COMPLEX            TRANSL
02709       INTEGER            KL, KU, LDA, M, N, NMAX
02710       LOGICAL            RESET
02711       CHARACTER*1        DIAG, UPLO
02712       CHARACTER*2        TYPE
02713 *     .. Array Arguments ..
02714       COMPLEX            A( NMAX, * ), AA( * )
02715 *     .. Local Scalars ..
02716       INTEGER            I, I1, I2, I3, IBEG, IEND, IOFF, J, JJ, KK
02717       LOGICAL            GEN, LOWER, SYM, TRI, UNIT, UPPER
02718 *     .. External Functions ..
02719       COMPLEX            CBEG
02720       EXTERNAL           CBEG
02721 *     .. Intrinsic Functions ..
02722       INTRINSIC          CMPLX, CONJG, MAX, MIN, REAL
02723 *     .. Executable Statements ..
02724       GEN = TYPE( 1: 1 ).EQ.'G'
02725       SYM = TYPE( 1: 1 ).EQ.'H'
02726       TRI = TYPE( 1: 1 ).EQ.'T'
02727       UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U'
02728       LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L'
02729       UNIT = TRI.AND.DIAG.EQ.'U'
02730 *
02731 *     Generate data in array A.
02732 *
02733       DO 20 J = 1, N
02734          DO 10 I = 1, M
02735             IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) )
02736      $          THEN
02737                IF( ( I.LE.J.AND.J - I.LE.KU ).OR.
02738      $             ( I.GE.J.AND.I - J.LE.KL ) )THEN
02739                   A( I, J ) = CBEG( RESET ) + TRANSL
02740                ELSE
02741                   A( I, J ) = ZERO
02742                END IF
02743                IF( I.NE.J )THEN
02744                   IF( SYM )THEN
02745                      A( J, I ) = CONJG( A( I, J ) )
02746                   ELSE IF( TRI )THEN
02747                      A( J, I ) = ZERO
02748                   END IF
02749                END IF
02750             END IF
02751    10    CONTINUE
02752          IF( SYM )
02753      $      A( J, J ) = CMPLX( REAL( A( J, J ) ), RZERO )
02754          IF( TRI )
02755      $      A( J, J ) = A( J, J ) + ONE
02756          IF( UNIT )
02757      $      A( J, J ) = ONE
02758    20 CONTINUE
02759 *
02760 *     Store elements in array AS in data structure required by routine.
02761 *
02762       IF( TYPE.EQ.'GE' )THEN
02763          DO 50 J = 1, N
02764             DO 30 I = 1, M
02765                AA( I + ( J - 1 )*LDA ) = A( I, J )
02766    30       CONTINUE
02767             DO 40 I = M + 1, LDA
02768                AA( I + ( J - 1 )*LDA ) = ROGUE
02769    40       CONTINUE
02770    50    CONTINUE
02771       ELSE IF( TYPE.EQ.'GB' )THEN
02772          DO 90 J = 1, N
02773             DO 60 I1 = 1, KU + 1 - J
02774                AA( I1 + ( J - 1 )*LDA ) = ROGUE
02775    60       CONTINUE
02776             DO 70 I2 = I1, MIN( KL + KU + 1, KU + 1 + M - J )
02777                AA( I2 + ( J - 1 )*LDA ) = A( I2 + J - KU - 1, J )
02778    70       CONTINUE
02779             DO 80 I3 = I2, LDA
02780                AA( I3 + ( J - 1 )*LDA ) = ROGUE
02781    80       CONTINUE
02782    90    CONTINUE
02783       ELSE IF( TYPE.EQ.'HE'.OR.TYPE.EQ.'TR' )THEN
02784          DO 130 J = 1, N
02785             IF( UPPER )THEN
02786                IBEG = 1
02787                IF( UNIT )THEN
02788                   IEND = J - 1
02789                ELSE
02790                   IEND = J
02791                END IF
02792             ELSE
02793                IF( UNIT )THEN
02794                   IBEG = J + 1
02795                ELSE
02796                   IBEG = J
02797                END IF
02798                IEND = N
02799             END IF
02800             DO 100 I = 1, IBEG - 1
02801                AA( I + ( J - 1 )*LDA ) = ROGUE
02802   100       CONTINUE
02803             DO 110 I = IBEG, IEND
02804                AA( I + ( J - 1 )*LDA ) = A( I, J )
02805   110       CONTINUE
02806             DO 120 I = IEND + 1, LDA
02807                AA( I + ( J - 1 )*LDA ) = ROGUE
02808   120       CONTINUE
02809             IF( SYM )THEN
02810                JJ = J + ( J - 1 )*LDA
02811                AA( JJ ) = CMPLX( REAL( AA( JJ ) ), RROGUE )
02812             END IF
02813   130    CONTINUE
02814       ELSE IF( TYPE.EQ.'HB'.OR.TYPE.EQ.'TB' )THEN
02815          DO 170 J = 1, N
02816             IF( UPPER )THEN
02817                KK = KL + 1
02818                IBEG = MAX( 1, KL + 2 - J )
02819                IF( UNIT )THEN
02820                   IEND = KL
02821                ELSE
02822                   IEND = KL + 1
02823                END IF
02824             ELSE
02825                KK = 1
02826                IF( UNIT )THEN
02827                   IBEG = 2
02828                ELSE
02829                   IBEG = 1
02830                END IF
02831                IEND = MIN( KL + 1, 1 + M - J )
02832             END IF
02833             DO 140 I = 1, IBEG - 1
02834                AA( I + ( J - 1 )*LDA ) = ROGUE
02835   140       CONTINUE
02836             DO 150 I = IBEG, IEND
02837                AA( I + ( J - 1 )*LDA ) = A( I + J - KK, J )
02838   150       CONTINUE
02839             DO 160 I = IEND + 1, LDA
02840                AA( I + ( J - 1 )*LDA ) = ROGUE
02841   160       CONTINUE
02842             IF( SYM )THEN
02843                JJ = KK + ( J - 1 )*LDA
02844                AA( JJ ) = CMPLX( REAL( AA( JJ ) ), RROGUE )
02845             END IF
02846   170    CONTINUE
02847       ELSE IF( TYPE.EQ.'HP'.OR.TYPE.EQ.'TP' )THEN
02848          IOFF = 0
02849          DO 190 J = 1, N
02850             IF( UPPER )THEN
02851                IBEG = 1
02852                IEND = J
02853             ELSE
02854                IBEG = J
02855                IEND = N
02856             END IF
02857             DO 180 I = IBEG, IEND
02858                IOFF = IOFF + 1
02859                AA( IOFF ) = A( I, J )
02860                IF( I.EQ.J )THEN
02861                   IF( UNIT )
02862      $               AA( IOFF ) = ROGUE
02863                   IF( SYM )
02864      $               AA( IOFF ) = CMPLX( REAL( AA( IOFF ) ), RROGUE )
02865                END IF
02866   180       CONTINUE
02867   190    CONTINUE
02868       END IF
02869       RETURN
02870 *
02871 *     End of CMAKE.
02872 *
02873       END
02874       SUBROUTINE CMVCH( TRANS, M, N, ALPHA, A, NMAX, X, INCX, BETA, Y,
02875      $                  INCY, YT, G, YY, EPS, ERR, FATAL, NOUT, MV )
02876 *
02877 *  Checks the results of the computational tests.
02878 *
02879 *  Auxiliary routine for test program for Level 2 Blas.
02880 *
02881 *  -- Written on 10-August-1987.
02882 *     Richard Hanson, Sandia National Labs.
02883 *     Jeremy Du Croz, NAG Central Office.
02884 *
02885 *     .. Parameters ..
02886       COMPLEX            ZERO
02887       PARAMETER          ( ZERO = ( 0.0, 0.0 ) )
02888       REAL               RZERO, RONE
02889       PARAMETER          ( RZERO = 0.0, RONE = 1.0 )
02890 *     .. Scalar Arguments ..
02891       COMPLEX            ALPHA, BETA
02892       REAL               EPS, ERR
02893       INTEGER            INCX, INCY, M, N, NMAX, NOUT
02894       LOGICAL            FATAL, MV
02895       CHARACTER*1        TRANS
02896 *     .. Array Arguments ..
02897       COMPLEX            A( NMAX, * ), X( * ), Y( * ), YT( * ), YY( * )
02898       REAL               G( * )
02899 *     .. Local Scalars ..
02900       COMPLEX            C
02901       REAL               ERRI
02902       INTEGER            I, INCXL, INCYL, IY, J, JX, KX, KY, ML, NL
02903       LOGICAL            CTRAN, TRAN
02904 *     .. Intrinsic Functions ..
02905       INTRINSIC          ABS, AIMAG, CONJG, MAX, REAL, SQRT
02906 *     .. Statement Functions ..
02907       REAL               ABS1
02908 *     .. Statement Function definitions ..
02909       ABS1( C ) = ABS( REAL( C ) ) + ABS( AIMAG( C ) )
02910 *     .. Executable Statements ..
02911       TRAN = TRANS.EQ.'T'
02912       CTRAN = TRANS.EQ.'C'
02913       IF( TRAN.OR.CTRAN )THEN
02914          ML = N
02915          NL = M
02916       ELSE
02917          ML = M
02918          NL = N
02919       END IF
02920       IF( INCX.LT.0 )THEN
02921          KX = NL
02922          INCXL = -1
02923       ELSE
02924          KX = 1
02925          INCXL = 1
02926       END IF
02927       IF( INCY.LT.0 )THEN
02928          KY = ML
02929          INCYL = -1
02930       ELSE
02931          KY = 1
02932          INCYL = 1
02933       END IF
02934 *
02935 *     Compute expected result in YT using data in A, X and Y.
02936 *     Compute gauges in G.
02937 *
02938       IY = KY
02939       DO 40 I = 1, ML
02940          YT( IY ) = ZERO
02941          G( IY ) = RZERO
02942          JX = KX
02943          IF( TRAN )THEN
02944             DO 10 J = 1, NL
02945                YT( IY ) = YT( IY ) + A( J, I )*X( JX )
02946                G( IY ) = G( IY ) + ABS1( A( J, I ) )*ABS1( X( JX ) )
02947                JX = JX + INCXL
02948    10       CONTINUE
02949          ELSE IF( CTRAN )THEN
02950             DO 20 J = 1, NL
02951                YT( IY ) = YT( IY ) + CONJG( A( J, I ) )*X( JX )
02952                G( IY ) = G( IY ) + ABS1( A( J, I ) )*ABS1( X( JX ) )
02953                JX = JX + INCXL
02954    20       CONTINUE
02955          ELSE
02956             DO 30 J = 1, NL
02957                YT( IY ) = YT( IY ) + A( I, J )*X( JX )
02958                G( IY ) = G( IY ) + ABS1( A( I, J ) )*ABS1( X( JX ) )
02959                JX = JX + INCXL
02960    30       CONTINUE
02961          END IF
02962          YT( IY ) = ALPHA*YT( IY ) + BETA*Y( IY )
02963          G( IY ) = ABS1( ALPHA )*G( IY ) + ABS1( BETA )*ABS1( Y( IY ) )
02964          IY = IY + INCYL
02965    40 CONTINUE
02966 *
02967 *     Compute the error ratio for this result.
02968 *
02969       ERR = ZERO
02970       DO 50 I = 1, ML
02971          ERRI = ABS( YT( I ) - YY( 1 + ( I - 1 )*ABS( INCY ) ) )/EPS
02972          IF( G( I ).NE.RZERO )
02973      $      ERRI = ERRI/G( I )
02974          ERR = MAX( ERR, ERRI )
02975          IF( ERR*SQRT( EPS ).GE.RONE )
02976      $      GO TO 60
02977    50 CONTINUE
02978 *     If the loop completes, all results are at least half accurate.
02979       GO TO 80
02980 *
02981 *     Report fatal error.
02982 *
02983    60 FATAL = .TRUE.
02984       WRITE( NOUT, FMT = 9999 )
02985       DO 70 I = 1, ML
02986          IF( MV )THEN
02987             WRITE( NOUT, FMT = 9998 )I, YT( I ),
02988      $         YY( 1 + ( I - 1 )*ABS( INCY ) )
02989          ELSE
02990             WRITE( NOUT, FMT = 9998 )I,
02991      $         YY( 1 + ( I - 1 )*ABS( INCY ) ), YT( I )
02992          END IF
02993    70 CONTINUE
02994 *
02995    80 CONTINUE
02996       RETURN
02997 *
02998  9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
02999      $      'F ACCURATE *******', /'                       EXPECTED RE',
03000      $      'SULT                    COMPUTED RESULT' )
03001  9998 FORMAT( 1X, I7, 2( '  (', G15.6, ',', G15.6, ')' ) )
03002 *
03003 *     End of CMVCH.
03004 *
03005       END
03006       LOGICAL FUNCTION LCE( RI, RJ, LR )
03007 *
03008 *  Tests if two arrays are identical.
03009 *
03010 *  Auxiliary routine for test program for Level 2 Blas.
03011 *
03012 *  -- Written on 10-August-1987.
03013 *     Richard Hanson, Sandia National Labs.
03014 *     Jeremy Du Croz, NAG Central Office.
03015 *
03016 *     .. Scalar Arguments ..
03017       INTEGER            LR
03018 *     .. Array Arguments ..
03019       COMPLEX            RI( * ), RJ( * )
03020 *     .. Local Scalars ..
03021       INTEGER            I
03022 *     .. Executable Statements ..
03023       DO 10 I = 1, LR
03024          IF( RI( I ).NE.RJ( I ) )
03025      $      GO TO 20
03026    10 CONTINUE
03027       LCE = .TRUE.
03028       GO TO 30
03029    20 CONTINUE
03030       LCE = .FALSE.
03031    30 RETURN
03032 *
03033 *     End of LCE.
03034 *
03035       END
03036       LOGICAL FUNCTION LCERES( TYPE, UPLO, M, N, AA, AS, LDA )
03037 *
03038 *  Tests if selected elements in two arrays are equal.
03039 *
03040 *  TYPE is 'GE', 'HE' or 'HP'.
03041 *
03042 *  Auxiliary routine for test program for Level 2 Blas.
03043 *
03044 *  -- Written on 10-August-1987.
03045 *     Richard Hanson, Sandia National Labs.
03046 *     Jeremy Du Croz, NAG Central Office.
03047 *
03048 *     .. Scalar Arguments ..
03049       INTEGER            LDA, M, N
03050       CHARACTER*1        UPLO
03051       CHARACTER*2        TYPE
03052 *     .. Array Arguments ..
03053       COMPLEX            AA( LDA, * ), AS( LDA, * )
03054 *     .. Local Scalars ..
03055       INTEGER            I, IBEG, IEND, J
03056       LOGICAL            UPPER
03057 *     .. Executable Statements ..
03058       UPPER = UPLO.EQ.'U'
03059       IF( TYPE.EQ.'GE' )THEN
03060          DO 20 J = 1, N
03061             DO 10 I = M + 1, LDA
03062                IF( AA( I, J ).NE.AS( I, J ) )
03063      $            GO TO 70
03064    10       CONTINUE
03065    20    CONTINUE
03066       ELSE IF( TYPE.EQ.'HE' )THEN
03067          DO 50 J = 1, N
03068             IF( UPPER )THEN
03069                IBEG = 1
03070                IEND = J
03071             ELSE
03072                IBEG = J
03073                IEND = N
03074             END IF
03075             DO 30 I = 1, IBEG - 1
03076                IF( AA( I, J ).NE.AS( I, J ) )
03077      $            GO TO 70
03078    30       CONTINUE
03079             DO 40 I = IEND + 1, LDA
03080                IF( AA( I, J ).NE.AS( I, J ) )
03081      $            GO TO 70
03082    40       CONTINUE
03083    50    CONTINUE
03084       END IF
03085 *
03086    60 CONTINUE
03087       LCERES = .TRUE.
03088       GO TO 80
03089    70 CONTINUE
03090       LCERES = .FALSE.
03091    80 RETURN
03092 *
03093 *     End of LCERES.
03094 *
03095       END
03096       COMPLEX FUNCTION CBEG( RESET )
03097 *
03098 *  Generates complex numbers as pairs of random numbers uniformly
03099 *  distributed between -0.5 and 0.5.
03100 *
03101 *  Auxiliary routine for test program for Level 2 Blas.
03102 *
03103 *  -- Written on 10-August-1987.
03104 *     Richard Hanson, Sandia National Labs.
03105 *     Jeremy Du Croz, NAG Central Office.
03106 *
03107 *     .. Scalar Arguments ..
03108       LOGICAL            RESET
03109 *     .. Local Scalars ..
03110       INTEGER            I, IC, J, MI, MJ
03111 *     .. Save statement ..
03112       SAVE               I, IC, J, MI, MJ
03113 *     .. Intrinsic Functions ..
03114       INTRINSIC          CMPLX
03115 *     .. Executable Statements ..
03116       IF( RESET )THEN
03117 *        Initialize local variables.
03118          MI = 891
03119          MJ = 457
03120          I = 7
03121          J = 7
03122          IC = 0
03123          RESET = .FALSE.
03124       END IF
03125 *
03126 *     The sequence of values of I or J is bounded between 1 and 999.
03127 *     If initial I or J = 1,2,3,6,7 or 9, the period will be 50.
03128 *     If initial I or J = 4 or 8, the period will be 25.
03129 *     If initial I or J = 5, the period will be 10.
03130 *     IC is used to break up the period by skipping 1 value of I or J
03131 *     in 6.
03132 *
03133       IC = IC + 1
03134    10 I = I*MI
03135       J = J*MJ
03136       I = I - 1000*( I/1000 )
03137       J = J - 1000*( J/1000 )
03138       IF( IC.GE.5 )THEN
03139          IC = 0
03140          GO TO 10
03141       END IF
03142       CBEG = CMPLX( ( I - 500 )/1001.0, ( J - 500 )/1001.0 )
03143       RETURN
03144 *
03145 *     End of CBEG.
03146 *
03147       END
03148       REAL FUNCTION SDIFF( X, Y )
03149 *
03150 *  Auxiliary routine for test program for Level 2 Blas.
03151 *
03152 *  -- Written on 10-August-1987.
03153 *     Richard Hanson, Sandia National Labs.
03154 *
03155 *     .. Scalar Arguments ..
03156       REAL               X, Y
03157 *     .. Executable Statements ..
03158       SDIFF = X - Y
03159       RETURN
03160 *
03161 *     End of SDIFF.
03162 *
03163       END
03164       SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
03165 *
03166 *  Tests whether XERBLA has detected an error when it should.
03167 *
03168 *  Auxiliary routine for test program for Level 2 Blas.
03169 *
03170 *  -- Written on 10-August-1987.
03171 *     Richard Hanson, Sandia National Labs.
03172 *     Jeremy Du Croz, NAG Central Office.
03173 *
03174 *     .. Scalar Arguments ..
03175       INTEGER            INFOT, NOUT
03176       LOGICAL            LERR, OK
03177       CHARACTER*6        SRNAMT
03178 *     .. Executable Statements ..
03179       IF( .NOT.LERR )THEN
03180          WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT
03181          OK = .FALSE.
03182       END IF
03183       LERR = .FALSE.
03184       RETURN
03185 *
03186  9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D',
03187      $      'ETECTED BY ', A6, ' *****' )
03188 *
03189 *     End of CHKXER.
03190 *
03191       END
03192       SUBROUTINE XERBLA( SRNAME, INFO )
03193 *
03194 *  This is a special version of XERBLA to be used only as part of
03195 *  the test program for testing error exits from the Level 2 BLAS
03196 *  routines.
03197 *
03198 *  XERBLA  is an error handler for the Level 2 BLAS routines.
03199 *
03200 *  It is called by the Level 2 BLAS routines if an input parameter is
03201 *  invalid.
03202 *
03203 *  Auxiliary routine for test program for Level 2 Blas.
03204 *
03205 *  -- Written on 10-August-1987.
03206 *     Richard Hanson, Sandia National Labs.
03207 *     Jeremy Du Croz, NAG Central Office.
03208 *
03209 *     .. Scalar Arguments ..
03210       INTEGER            INFO
03211       CHARACTER*6        SRNAME
03212 *     .. Scalars in Common ..
03213       INTEGER            INFOT, NOUT
03214       LOGICAL            LERR, OK
03215       CHARACTER*6        SRNAMT
03216 *     .. Common blocks ..
03217       COMMON             /INFOC/INFOT, NOUT, OK, LERR
03218       COMMON             /SRNAMC/SRNAMT
03219 *     .. Executable Statements ..
03220       LERR = .TRUE.
03221       IF( INFO.NE.INFOT )THEN
03222          IF( INFOT.NE.0 )THEN
03223             WRITE( NOUT, FMT = 9999 )INFO, INFOT
03224          ELSE
03225             WRITE( NOUT, FMT = 9997 )INFO
03226          END IF
03227          OK = .FALSE.
03228       END IF
03229       IF( SRNAME.NE.SRNAMT )THEN
03230          WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT
03231          OK = .FALSE.
03232       END IF
03233       RETURN
03234 *
03235  9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, ' INSTEAD',
03236      $      ' OF ', I2, ' *******' )
03237  9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A6, ' INSTE',
03238      $      'AD OF ', A6, ' *******' )
03239  9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6,
03240      $      ' *******' )
03241 *
03242 *     End of XERBLA
03243 *
03244       END
03245