test/dblat2.f

   1       PROGRAM DBLAT2
   2 *
   3 *  Test program for the DOUBLE PRECISION Level 2 Blas.
   4 *
   5 *  The program must be driven by a short data file. The first 18 records
   6 *  of the file are read using list-directed input, the last 16 records
   7 *  are read using the format ( A6, L2 ). An annotated example of a data
   8 *  file can be obtained by deleting the first 3 characters from the
   9 *  following 34 lines:
  10 *  'DBLAT2.SUMM'     NAME OF SUMMARY OUTPUT FILE
  11 *  6                 UNIT NUMBER OF SUMMARY FILE
  12 *  'DBLAT2.SNAP'     NAME OF SNAPSHOT OUTPUT FILE
  13 *  -1                UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
  14 *  F        LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
  15 *  F        LOGICAL FLAG, T TO STOP ON FAILURES.
  16 *  T        LOGICAL FLAG, T TO TEST ERROR EXITS.
  17 *  16.0     THRESHOLD VALUE OF TEST RATIO
  18 *  6                 NUMBER OF VALUES OF N
  19 *  0 1 2 3 5 9       VALUES OF N
  20 *  4                 NUMBER OF VALUES OF K
  21 *  0 1 2 4           VALUES OF K
  22 *  4                 NUMBER OF VALUES OF INCX AND INCY
  23 *  1 2 -1 -2         VALUES OF INCX AND INCY
  24 *  3                 NUMBER OF VALUES OF ALPHA
  25 *  0.0 1.0 0.7       VALUES OF ALPHA
  26 *  3                 NUMBER OF VALUES OF BETA
  27 *  0.0 1.0 0.9       VALUES OF BETA
  28 *  DGEMV  T PUT F FOR NO TEST. SAME COLUMNS.
  29 *  DGBMV  T PUT F FOR NO TEST. SAME COLUMNS.
  30 *  DSYMV  T PUT F FOR NO TEST. SAME COLUMNS.
  31 *  DSBMV  T PUT F FOR NO TEST. SAME COLUMNS.
  32 *  DSPMV  T PUT F FOR NO TEST. SAME COLUMNS.
  33 *  DTRMV  T PUT F FOR NO TEST. SAME COLUMNS.
  34 *  DTBMV  T PUT F FOR NO TEST. SAME COLUMNS.
  35 *  DTPMV  T PUT F FOR NO TEST. SAME COLUMNS.
  36 *  DTRSV  T PUT F FOR NO TEST. SAME COLUMNS.
  37 *  DTBSV  T PUT F FOR NO TEST. SAME COLUMNS.
  38 *  DTPSV  T PUT F FOR NO TEST. SAME COLUMNS.
  39 *  DGER   T PUT F FOR NO TEST. SAME COLUMNS.
  40 *  DSYR   T PUT F FOR NO TEST. SAME COLUMNS.
  41 *  DSPR   T PUT F FOR NO TEST. SAME COLUMNS.
  42 *  DSYR2  T PUT F FOR NO TEST. SAME COLUMNS.
  43 *  DSPR2  T PUT F FOR NO TEST. SAME COLUMNS.
  44 *
  45 *     See:
  46 *
  47 *        Dongarra J. J., Du Croz J. J., Hammarling S.  and Hanson R. J..
  48 *        An  extended  set of Fortran  Basic Linear Algebra Subprograms.
  49 *
  50 *        Technical  Memoranda  Nos. 41 (revision 3) and 81,  Mathematics
  51 *        and  Computer Science  Division,  Argonne  National Laboratory,
  52 *        9700 South Cass Avenue, Argonne, Illinois 60439, US.
  53 *
  54 *        Or
  55 *
  56 *        NAG  Technical Reports TR3/87 and TR4/87,  Numerical Algorithms
  57 *        Group  Ltd.,  NAG  Central  Office,  256  Banbury  Road, Oxford
  58 *        OX2 7DE, UK,  and  Numerical Algorithms Group Inc.,  1101  31st
  59 *        Street,  Suite 100,  Downers Grove,  Illinois 60515-1263,  USA.
  60 *
  61 *
  62 *  -- Written on 10-August-1987.
  63 *     Richard Hanson, Sandia National Labs.
  64 *     Jeremy Du Croz, NAG Central Office.
  65 *
  66 *     .. Parameters ..
  67       INTEGER            NIN
  68       PARAMETER          ( NIN = 5 )
  69       INTEGER            NSUBS
  70       PARAMETER          ( NSUBS = 16 )
  71       DOUBLE PRECISION   ZERO, HALF, ONE
  72       PARAMETER          ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )
  73       INTEGER            NMAX, INCMAX
  74       PARAMETER          ( NMAX = 65, INCMAX = 2 )
  75       INTEGER            NINMAX, NIDMAX, NKBMAX, NALMAX, NBEMAX
  76       PARAMETER          ( NINMAX = 7, NIDMAX = 9, NKBMAX = 7,
  77      $                   NALMAX = 7, NBEMAX = 7 )
  78 *     .. Local Scalars ..
  79       DOUBLE PRECISION   EPS, ERR, THRESH
  80       INTEGER            I, ISNUM, J, N, NALF, NBET, NIDIM, NINC, NKB,
  81      $                   NOUT, NTRA
  82       LOGICAL            FATAL, LTESTT, REWI, SAME, SFATAL, TRACE,
  83      $                   TSTERR
  84       CHARACTER*1        TRANS
  85       CHARACTER*6        SNAMET
  86       CHARACTER*32       SNAPS, SUMMRY
  87 *     .. Local Arrays ..
  88       DOUBLE PRECISION   A( NMAX, NMAX ), AA( NMAX*NMAX ),
  89      $                   ALF( NALMAX ), AS( NMAX*NMAX ), BET( NBEMAX ),
  90      $                   G( NMAX ), X( NMAX ), XS( NMAX*INCMAX ),
  91      $                   XX( NMAX*INCMAX ), Y( NMAX ),
  92      $                   YS( NMAX*INCMAX ), YT( NMAX ),
  93      $                   YY( NMAX*INCMAX ), Z( 2*NMAX )
  94       INTEGER            IDIM( NIDMAX ), INC( NINMAX ), KB( NKBMAX )
  95       LOGICAL            LTEST( NSUBS )
  96       CHARACTER*6        SNAMES( NSUBS )
  97 *     .. External Functions ..
  98       DOUBLE PRECISION   DDIFF
  99       LOGICAL            LDE
 100       EXTERNAL           DDIFF, LDE
 101 *     .. External Subroutines ..
 102       EXTERNAL           DCHK1, DCHK2, DCHK3, DCHK4, DCHK5, DCHK6,
 103      $                   DCHKE, DMVCH
 104 *     .. Intrinsic Functions ..
 105       INTRINSIC          ABS, MAX, MIN
 106 *     .. Scalars in Common ..
 107       INTEGER            INFOT, NOUTC
 108       LOGICAL            LERR, OK
 109       CHARACTER*6        SRNAMT
 110 *     .. Common blocks ..
 111       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
 112       COMMON             /SRNAMC/SRNAMT
 113 *     .. Data statements ..
 114       DATA               SNAMES/'DGEMV ', 'DGBMV ', 'DSYMV ', 'DSBMV ',
 115      $                   'DSPMV ', 'DTRMV ', 'DTBMV ', 'DTPMV ',
 116      $                   'DTRSV ', 'DTBSV ', 'DTPSV ', 'DGER  ',
 117      $                   'DSYR  ', 'DSPR  ', 'DSYR2 ', 'DSPR2 '/
 118 *     .. Executable Statements ..
 119 *
 120 *     Read name and unit number for summary output file and open file.
 121 *
 122       READ( NIN, FMT = * )SUMMRY
 123       READ( NIN, FMT = * )NOUT
 124       OPEN( NOUT, FILE = SUMMRY, STATUS = 'NEW' )
 125       NOUTC = NOUT
 126 *
 127 *     Read name and unit number for snapshot output file and open file.
 128 *
 129       READ( NIN, FMT = * )SNAPS
 130       READ( NIN, FMT = * )NTRA
 131       TRACE = NTRA.GE.0
 132       IF( TRACE )THEN
 133          OPEN( NTRA, FILE = SNAPS, STATUS = 'NEW' )
 134       END IF
 135 *     Read the flag that directs rewinding of the snapshot file.
 136       READ( NIN, FMT = * )REWI
 137       REWI = REWI.AND.TRACE
 138 *     Read the flag that directs stopping on any failure.
 139       READ( NIN, FMT = * )SFATAL
 140 *     Read the flag that indicates whether error exits are to be tested.
 141       READ( NIN, FMT = * )TSTERR
 142 *     Read the threshold value of the test ratio
 143       READ( NIN, FMT = * )THRESH
 144 *
 145 *     Read and check the parameter values for the tests.
 146 *
 147 *     Values of N
 148       READ( NIN, FMT = * )NIDIM
 149       IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN
 150          WRITE( NOUT, FMT = 9997 )'N', NIDMAX
 151          GO TO 230
 152       END IF
 153       READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM )
 154       DO 10 I = 1, NIDIM
 155          IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN
 156             WRITE( NOUT, FMT = 9996 )NMAX
 157             GO TO 230
 158          END IF
 159    10 CONTINUE
 160 *     Values of K
 161       READ( NIN, FMT = * )NKB
 162       IF( NKB.LT.1.OR.NKB.GT.NKBMAX )THEN
 163          WRITE( NOUT, FMT = 9997 )'K', NKBMAX
 164          GO TO 230
 165       END IF
 166       READ( NIN, FMT = * )( KB( I ), I = 1, NKB )
 167       DO 20 I = 1, NKB
 168          IF( KB( I ).LT.0 )THEN
 169             WRITE( NOUT, FMT = 9995 )
 170             GO TO 230
 171          END IF
 172    20 CONTINUE
 173 *     Values of INCX and INCY
 174       READ( NIN, FMT = * )NINC
 175       IF( NINC.LT.1.OR.NINC.GT.NINMAX )THEN
 176          WRITE( NOUT, FMT = 9997 )'INCX AND INCY', NINMAX
 177          GO TO 230
 178       END IF
 179       READ( NIN, FMT = * )( INC( I ), I = 1, NINC )
 180       DO 30 I = 1, NINC
 181          IF( INC( I ).EQ.0.OR.ABS( INC( I ) ).GT.INCMAX )THEN
 182             WRITE( NOUT, FMT = 9994 )INCMAX
 183             GO TO 230
 184          END IF
 185    30 CONTINUE
 186 *     Values of ALPHA
 187       READ( NIN, FMT = * )NALF
 188       IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN
 189          WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX
 190          GO TO 230
 191       END IF
 192       READ( NIN, FMT = * )( ALF( I ), I = 1, NALF )
 193 *     Values of BETA
 194       READ( NIN, FMT = * )NBET
 195       IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN
 196          WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX
 197          GO TO 230
 198       END IF
 199       READ( NIN, FMT = * )( BET( I ), I = 1, NBET )
 200 *
 201 *     Report values of parameters.
 202 *
 203       WRITE( NOUT, FMT = 9993 )
 204       WRITE( NOUT, FMT = 9992 )( IDIM( I ), I = 1, NIDIM )
 205       WRITE( NOUT, FMT = 9991 )( KB( I ), I = 1, NKB )
 206       WRITE( NOUT, FMT = 9990 )( INC( I ), I = 1, NINC )
 207       WRITE( NOUT, FMT = 9989 )( ALF( I ), I = 1, NALF )
 208       WRITE( NOUT, FMT = 9988 )( BET( I ), I = 1, NBET )
 209       IF( .NOT.TSTERR )THEN
 210          WRITE( NOUT, FMT = * )
 211          WRITE( NOUT, FMT = 9980 )
 212       END IF
 213       WRITE( NOUT, FMT = * )
 214       WRITE( NOUT, FMT = 9999 )THRESH
 215       WRITE( NOUT, FMT = * )
 216 *
 217 *     Read names of subroutines and flags which indicate
 218 *     whether they are to be tested.
 219 *
 220       DO 40 I = 1, NSUBS
 221          LTEST( I ) = .FALSE.
 222    40 CONTINUE
 223    50 READ( NIN, FMT = 9984, END = 80 )SNAMET, LTESTT
 224       DO 60 I = 1, NSUBS
 225          IF( SNAMET.EQ.SNAMES( I ) )
 226      $      GO TO 70
 227    60 CONTINUE
 228       WRITE( NOUT, FMT = 9986 )SNAMET
 229       STOP
 230    70 LTEST( I ) = LTESTT
 231       GO TO 50
 232 *
 233    80 CONTINUE
 234       CLOSE ( NIN )
 235 *
 236 *     Compute EPS (the machine precision).
 237 *
 238       EPS = ONE
 239    90 CONTINUE
 240       IF( DDIFF( ONE + EPS, ONE ).EQ.ZERO )
 241      $   GO TO 100
 242       EPS = HALF*EPS
 243       GO TO 90
 244   100 CONTINUE
 245       EPS = EPS + EPS
 246       WRITE( NOUT, FMT = 9998 )EPS
 247 *
 248 *     Check the reliability of DMVCH using exact data.
 249 *
 250       N = MIN( 32, NMAX )
 251       DO 120 J = 1, N
 252          DO 110 I = 1, N
 253             A( I, J ) = MAX( I - J + 1, 0 )
 254   110    CONTINUE
 255          X( J ) = J
 256          Y( J ) = ZERO
 257   120 CONTINUE
 258       DO 130 J = 1, N
 259          YY( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3
 260   130 CONTINUE
 261 *     YY holds the exact result. On exit from DMVCH YT holds
 262 *     the result computed by DMVCH.
 263       TRANS = 'N'
 264       CALL DMVCH( TRANS, N, N, ONE, A, NMAX, X, 1, ZERO, Y, 1, YT, G,
 265      $            YY, EPS, ERR, FATAL, NOUT, .TRUE. )
 266       SAME = LDE( YY, YT, N )
 267       IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
 268          WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR
 269          STOP
 270       END IF
 271       TRANS = 'T'
 272       CALL DMVCH( TRANS, N, N, ONE, A, NMAX, X, -1, ZERO, Y, -1, YT, G,
 273      $            YY, EPS, ERR, FATAL, NOUT, .TRUE. )
 274       SAME = LDE( YY, YT, N )
 275       IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
 276          WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR
 277          STOP
 278       END IF
 279 *
 280 *     Test each subroutine in turn.
 281 *
 282       DO 210 ISNUM = 1, NSUBS
 283          WRITE( NOUT, FMT = * )
 284          IF( .NOT.LTEST( ISNUM ) )THEN
 285 *           Subprogram is not to be tested.
 286             WRITE( NOUT, FMT = 9983 )SNAMES( ISNUM )
 287          ELSE
 288             SRNAMT = SNAMES( ISNUM )
 289 *           Test error exits.
 290             IF( TSTERR )THEN
 291                CALL DCHKE( ISNUM, SNAMES( ISNUM ), NOUT )
 292                WRITE( NOUT, FMT = * )
 293             END IF
 294 *           Test computations.
 295             INFOT = 0
 296             OK = .TRUE.
 297             FATAL = .FALSE.
 298             GO TO ( 140, 140, 150, 150, 150, 160, 160,
 299      $              160, 160, 160, 160, 170, 180, 180,
 300      $              190, 190 )ISNUM
 301 *           Test DGEMV, 01, and DGBMV, 02.
 302   140       CALL DCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
 303      $                  REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF,
 304      $                  NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS,
 305      $                  X, XX, XS, Y, YY, YS, YT, G )
 306             GO TO 200
 307 *           Test DSYMV, 03, DSBMV, 04, and DSPMV, 05.
 308   150       CALL DCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
 309      $                  REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF,
 310      $                  NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS,
 311      $                  X, XX, XS, Y, YY, YS, YT, G )
 312             GO TO 200
 313 *           Test DTRMV, 06, DTBMV, 07, DTPMV, 08,
 314 *           DTRSV, 09, DTBSV, 10, and DTPSV, 11.
 315   160       CALL DCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
 316      $                  REWI, FATAL, NIDIM, IDIM, NKB, KB, NINC, INC,
 317      $                  NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z )
 318             GO TO 200
 319 *           Test DGER, 12.
 320   170       CALL DCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
 321      $                  REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC,
 322      $                  NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS,
 323      $                  YT, G, Z )
 324             GO TO 200
 325 *           Test DSYR, 13, and DSPR, 14.
 326   180       CALL DCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
 327      $                  REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC,
 328      $                  NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS,
 329      $                  YT, G, Z )
 330             GO TO 200
 331 *           Test DSYR2, 15, and DSPR2, 16.
 332   190       CALL DCHK6( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
 333      $                  REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC,
 334      $                  NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS,
 335      $                  YT, G, Z )
 336 *
 337   200       IF( FATAL.AND.SFATAL )
 338      $         GO TO 220
 339          END IF
 340   210 CONTINUE
 341       WRITE( NOUT, FMT = 9982 )
 342       GO TO 240
 343 *
 344   220 CONTINUE
 345       WRITE( NOUT, FMT = 9981 )
 346       GO TO 240
 347 *
 348   230 CONTINUE
 349       WRITE( NOUT, FMT = 9987 )
 350 *
 351   240 CONTINUE
 352       IF( TRACE )
 353      $   CLOSE ( NTRA )
 354       CLOSE ( NOUT )
 355       STOP
 356 *
 357  9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES',
 358      $      'S THAN', F8.2 )
 359  9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, D9.1 )
 360  9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ',
 361      $      'THAN ', I2 )
 362  9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 )
 363  9995 FORMAT( ' VALUE OF K IS LESS THAN 0' )
 364  9994 FORMAT( ' ABSOLUTE VALUE OF INCX OR INCY IS 0 OR GREATER THAN ',
 365      $      I2 )
 366  9993 FORMAT( ' TESTS OF THE DOUBLE PRECISION LEVEL 2 BLAS', //' THE F',
 367      $      'OLLOWING PARAMETER VALUES WILL BE USED:' )
 368  9992 FORMAT( '   FOR N              ', 9I6 )
 369  9991 FORMAT( '   FOR K              ', 7I6 )
 370  9990 FORMAT( '   FOR INCX AND INCY  ', 7I6 )
 371  9989 FORMAT( '   FOR ALPHA          ', 7F6.1 )
 372  9988 FORMAT( '   FOR BETA           ', 7F6.1 )
 373  9987 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM',
 374      $      /' ******* TESTS ABANDONED *******' )
 375  9986 FORMAT( ' SUBPROGRAM NAME ', A6, ' NOT RECOGNIZED', /' ******* T',
 376      $      'ESTS ABANDONED *******' )
 377  9985 FORMAT( ' ERROR IN DMVCH -  IN-LINE DOT PRODUCTS ARE BEING EVALU',
 378      $      'ATED WRONGLY.', /' DMVCH WAS CALLED WITH TRANS = ', A1,
 379      $      ' AND RETURNED SAME = ', L1, ' AND ERR = ', F12.3, '.', /
 380      $   ' THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.'
 381      $      , /' ******* TESTS ABANDONED *******' )
 382  9984 FORMAT( A6, L2 )
 383  9983 FORMAT( 1X, A6, ' WAS NOT TESTED' )
 384  9982 FORMAT( /' END OF TESTS' )
 385  9981 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' )
 386  9980 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' )
 387 *
 388 *     End of DBLAT2.
 389 *
 390       END
 391       SUBROUTINE DCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
 392      $                  FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET,
 393      $                  BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX,
 394      $                  XS, Y, YY, YS, YT, G )
 395 *
 396 *  Tests DGEMV and DGBMV.
 397 *
 398 *  Auxiliary routine for test program for Level 2 Blas.
 399 *
 400 *  -- Written on 10-August-1987.
 401 *     Richard Hanson, Sandia National Labs.
 402 *     Jeremy Du Croz, NAG Central Office.
 403 *
 404 *     .. Parameters ..
 405       DOUBLE PRECISION   ZERO, HALF
 406       PARAMETER          ( ZERO = 0.0D0, HALF = 0.5D0 )
 407 *     .. Scalar Arguments ..
 408       DOUBLE PRECISION   EPS, THRESH
 409       INTEGER            INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX,
 410      $                   NOUT, NTRA
 411       LOGICAL            FATAL, REWI, TRACE
 412       CHARACTER*6        SNAME
 413 *     .. Array Arguments ..
 414       DOUBLE PRECISION   A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
 415      $                   AS( NMAX*NMAX ), BET( NBET ), G( NMAX ),
 416      $                   X( NMAX ), XS( NMAX*INCMAX ),
 417      $                   XX( NMAX*INCMAX ), Y( NMAX ),
 418      $                   YS( NMAX*INCMAX ), YT( NMAX ),
 419      $                   YY( NMAX*INCMAX )
 420       INTEGER            IDIM( NIDIM ), INC( NINC ), KB( NKB )
 421 *     .. Local Scalars ..
 422       DOUBLE PRECISION   ALPHA, ALS, BETA, BLS, ERR, ERRMAX, TRANSL
 423       INTEGER            I, IA, IB, IC, IKU, IM, IN, INCX, INCXS, INCY,
 424      $                   INCYS, IX, IY, KL, KLS, KU, KUS, LAA, LDA,
 425      $                   LDAS, LX, LY, M, ML, MS, N, NARGS, NC, ND, NK,
 426      $                   NL, NS
 427       LOGICAL            BANDED, FULL, NULL, RESET, SAME, TRAN
 428       CHARACTER*1        TRANS, TRANSS
 429       CHARACTER*3        ICH
 430 *     .. Local Arrays ..
 431       LOGICAL            ISAME( 13 )
 432 *     .. External Functions ..
 433       LOGICAL            LDE, LDERES
 434       EXTERNAL           LDE, LDERES
 435 *     .. External Subroutines ..
 436       EXTERNAL           DGBMV, DGEMV, DMAKE, DMVCH
 437 *     .. Intrinsic Functions ..
 438       INTRINSIC          ABS, MAX, MIN
 439 *     .. Scalars in Common ..
 440       INTEGER            INFOT, NOUTC
 441       LOGICAL            LERR, OK
 442 *     .. Common blocks ..
 443       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
 444 *     .. Data statements ..
 445       DATA               ICH/'NTC'/
 446 *     .. Executable Statements ..
 447       FULL = SNAME( 3: 3 ).EQ.'E'
 448       BANDED = SNAME( 3: 3 ).EQ.'B'
 449 *     Define the number of arguments.
 450       IF( FULL )THEN
 451          NARGS = 11
 452       ELSE IF( BANDED )THEN
 453          NARGS = 13
 454       END IF
 455 *
 456       NC = 0
 457       RESET = .TRUE.
 458       ERRMAX = ZERO
 459 *
 460       DO 120 IN = 1, NIDIM
 461          N = IDIM( IN )
 462          ND = N/2 + 1
 463 *
 464          DO 110 IM = 1, 2
 465             IF( IM.EQ.1 )
 466      $         M = MAX( N - ND, 0 )
 467             IF( IM.EQ.2 )
 468      $         M = MIN( N + ND, NMAX )
 469 *
 470             IF( BANDED )THEN
 471                NK = NKB
 472             ELSE
 473                NK = 1
 474             END IF
 475             DO 100 IKU = 1, NK
 476                IF( BANDED )THEN
 477                   KU = KB( IKU )
 478                   KL = MAX( KU - 1, 0 )
 479                ELSE
 480                   KU = N - 1
 481                   KL = M - 1
 482                END IF
 483 *              Set LDA to 1 more than minimum value if room.
 484                IF( BANDED )THEN
 485                   LDA = KL + KU + 1
 486                ELSE
 487                   LDA = M
 488                END IF
 489                IF( LDA.LT.NMAX )
 490      $            LDA = LDA + 1
 491 *              Skip tests if not enough room.
 492                IF( LDA.GT.NMAX )
 493      $            GO TO 100
 494                LAA = LDA*N
 495                NULL = N.LE.0.OR.M.LE.0
 496 *
 497 *              Generate the matrix A.
 498 *
 499                TRANSL = ZERO
 500                CALL DMAKE( SNAME( 2: 3 ), ' ', ' ', M, N, A, NMAX, AA,
 501      $                     LDA, KL, KU, RESET, TRANSL )
 502 *
 503                DO 90 IC = 1, 3
 504                   TRANS = ICH( IC: IC )
 505                   TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C'
 506 *
 507                   IF( TRAN )THEN
 508                      ML = N
 509                      NL = M
 510                   ELSE
 511                      ML = M
 512                      NL = N
 513                   END IF
 514 *
 515                   DO 80 IX = 1, NINC
 516                      INCX = INC( IX )
 517                      LX = ABS( INCX )*NL
 518 *
 519 *                    Generate the vector X.
 520 *
 521                      TRANSL = HALF
 522                      CALL DMAKE( 'GE', ' ', ' ', 1, NL, X, 1, XX,
 523      $                           ABS( INCX ), 0, NL - 1, RESET, TRANSL )
 524                      IF( NL.GT.1 )THEN
 525                         X( NL/2 ) = ZERO
 526                         XX( 1 + ABS( INCX )*( NL/2 - 1 ) ) = ZERO
 527                      END IF
 528 *
 529                      DO 70 IY = 1, NINC
 530                         INCY = INC( IY )
 531                         LY = ABS( INCY )*ML
 532 *
 533                         DO 60 IA = 1, NALF
 534                            ALPHA = ALF( IA )
 535 *
 536                            DO 50 IB = 1, NBET
 537                               BETA = BET( IB )
 538 *
 539 *                             Generate the vector Y.
 540 *
 541                               TRANSL = ZERO
 542                               CALL DMAKE( 'GE', ' ', ' ', 1, ML, Y, 1,
 543      $                                    YY, ABS( INCY ), 0, ML - 1,
 544      $                                    RESET, TRANSL )
 545 *
 546                               NC = NC + 1
 547 *
 548 *                             Save every datum before calling the
 549 *                             subroutine.
 550 *
 551                               TRANSS = TRANS
 552                               MS = M
 553                               NS = N
 554                               KLS = KL
 555                               KUS = KU
 556                               ALS = ALPHA
 557                               DO 10 I = 1, LAA
 558                                  AS( I ) = AA( I )
 559    10                         CONTINUE
 560                               LDAS = LDA
 561                               DO 20 I = 1, LX
 562                                  XS( I ) = XX( I )
 563    20                         CONTINUE
 564                               INCXS = INCX
 565                               BLS = BETA
 566                               DO 30 I = 1, LY
 567                                  YS( I ) = YY( I )
 568    30                         CONTINUE
 569                               INCYS = INCY
 570 *
 571 *                             Call the subroutine.
 572 *
 573                               IF( FULL )THEN
 574                                  IF( TRACE )
 575      $                              WRITE( NTRA, FMT = 9994 )NC, SNAME,
 576      $                              TRANS, M, N, ALPHA, LDA, INCX, BETA,
 577      $                              INCY
 578                                  IF( REWI )
 579      $                              REWIND NTRA
 580                                  CALL DGEMV( TRANS, M, N, ALPHA, AA,
 581      $                                       LDA, XX, INCX, BETA, YY,
 582      $                                       INCY )
 583                               ELSE IF( BANDED )THEN
 584                                  IF( TRACE )
 585      $                              WRITE( NTRA, FMT = 9995 )NC, SNAME,
 586      $                              TRANS, M, N, KL, KU, ALPHA, LDA,
 587      $                              INCX, BETA, INCY
 588                                  IF( REWI )
 589      $                              REWIND NTRA
 590                                  CALL DGBMV( TRANS, M, N, KL, KU, ALPHA,
 591      $                                       AA, LDA, XX, INCX, BETA,
 592      $                                       YY, INCY )
 593                               END IF
 594 *
 595 *                             Check if error-exit was taken incorrectly.
 596 *
 597                               IF( .NOT.OK )THEN
 598                                  WRITE( NOUT, FMT = 9993 )
 599                                  FATAL = .TRUE.
 600                                  GO TO 130
 601                               END IF
 602 *
 603 *                             See what data changed inside subroutines.
 604 *
 605                               ISAME( 1 ) = TRANS.EQ.TRANSS
 606                               ISAME( 2 ) = MS.EQ.M
 607                               ISAME( 3 ) = NS.EQ.N
 608                               IF( FULL )THEN
 609                                  ISAME( 4 ) = ALS.EQ.ALPHA
 610                                  ISAME( 5 ) = LDE( AS, AA, LAA )
 611                                  ISAME( 6 ) = LDAS.EQ.LDA
 612                                  ISAME( 7 ) = LDE( XS, XX, LX )
 613                                  ISAME( 8 ) = INCXS.EQ.INCX
 614                                  ISAME( 9 ) = BLS.EQ.BETA
 615                                  IF( NULL )THEN
 616                                     ISAME( 10 ) = LDE( YS, YY, LY )
 617                                  ELSE
 618                                     ISAME( 10 ) = LDERES( 'GE', ' ', 1,
 619      $                                            ML, YS, YY,
 620      $                                            ABS( INCY ) )
 621                                  END IF
 622                                  ISAME( 11 ) = INCYS.EQ.INCY
 623                               ELSE IF( BANDED )THEN
 624                                  ISAME( 4 ) = KLS.EQ.KL
 625                                  ISAME( 5 ) = KUS.EQ.KU
 626                                  ISAME( 6 ) = ALS.EQ.ALPHA
 627                                  ISAME( 7 ) = LDE( AS, AA, LAA )
 628                                  ISAME( 8 ) = LDAS.EQ.LDA
 629                                  ISAME( 9 ) = LDE( XS, XX, LX )
 630                                  ISAME( 10 ) = INCXS.EQ.INCX
 631                                  ISAME( 11 ) = BLS.EQ.BETA
 632                                  IF( NULL )THEN
 633                                     ISAME( 12 ) = LDE( YS, YY, LY )
 634                                  ELSE
 635                                     ISAME( 12 ) = LDERES( 'GE', ' ', 1,
 636      $                                            ML, YS, YY,
 637      $                                            ABS( INCY ) )
 638                                  END IF
 639                                  ISAME( 13 ) = INCYS.EQ.INCY
 640                               END IF
 641 *
 642 *                             If data was incorrectly changed, report
 643 *                             and return.
 644 *
 645                               SAME = .TRUE.
 646                               DO 40 I = 1, NARGS
 647                                  SAME = SAME.AND.ISAME( I )
 648                                  IF( .NOT.ISAME( I ) )
 649      $                              WRITE( NOUT, FMT = 9998 )I
 650    40                         CONTINUE
 651                               IF( .NOT.SAME )THEN
 652                                  FATAL = .TRUE.
 653                                  GO TO 130
 654                               END IF
 655 *
 656                               IF( .NOT.NULL )THEN
 657 *
 658 *                                Check the result.
 659 *
 660                                  CALL DMVCH( TRANS, M, N, ALPHA, A,
 661      $                                       NMAX, X, INCX, BETA, Y,
 662      $                                       INCY, YT, G, YY, EPS, ERR,
 663      $                                       FATAL, NOUT, .TRUE. )
 664                                  ERRMAX = MAX( ERRMAX, ERR )
 665 *                                If got really bad answer, report and
 666 *                                return.
 667                                  IF( FATAL )
 668      $                              GO TO 130
 669                               ELSE
 670 *                                Avoid repeating tests with M.le.0 or
 671 *                                N.le.0.
 672                                  GO TO 110
 673                               END IF
 674 *
 675    50                      CONTINUE
 676 *
 677    60                   CONTINUE
 678 *
 679    70                CONTINUE
 680 *
 681    80             CONTINUE
 682 *
 683    90          CONTINUE
 684 *
 685   100       CONTINUE
 686 *
 687   110    CONTINUE
 688 *
 689   120 CONTINUE
 690 *
 691 *     Report result.
 692 *
 693       IF( ERRMAX.LT.THRESH )THEN
 694          WRITE( NOUT, FMT = 9999 )SNAME, NC
 695       ELSE
 696          WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
 697       END IF
 698       GO TO 140
 699 *
 700   130 CONTINUE
 701       WRITE( NOUT, FMT = 9996 )SNAME
 702       IF( FULL )THEN
 703          WRITE( NOUT, FMT = 9994 )NC, SNAME, TRANS, M, N, ALPHA, LDA,
 704      $      INCX, BETA, INCY
 705       ELSE IF( BANDED )THEN
 706          WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANS, M, N, KL, KU,
 707      $      ALPHA, LDA, INCX, BETA, INCY
 708       END IF
 709 *
 710   140 CONTINUE
 711       RETURN
 712 *
 713  9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
 714      $      'S)' )
 715  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
 716      $      'ANGED INCORRECTLY *******' )
 717  9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
 718      $      'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
 719      $      ' - SUSPECT *******' )
 720  9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
 721  9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 4( I3, ',' ), F4.1,
 722      $      ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2, ') .' )
 723  9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), F4.1,
 724      $      ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2,
 725      $      ')         .' )
 726  9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
 727      $      '******' )
 728 *
 729 *     End of DCHK1.
 730 *
 731       END
 732       SUBROUTINE DCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
 733      $                  FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET,
 734      $                  BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX,
 735      $                  XS, Y, YY, YS, YT, G )
 736 *
 737 *  Tests DSYMV, DSBMV and DSPMV.
 738 *
 739 *  Auxiliary routine for test program for Level 2 Blas.
 740 *
 741 *  -- Written on 10-August-1987.
 742 *     Richard Hanson, Sandia National Labs.
 743 *     Jeremy Du Croz, NAG Central Office.
 744 *
 745 *     .. Parameters ..
 746       DOUBLE PRECISION   ZERO, HALF
 747       PARAMETER          ( ZERO = 0.0D0, HALF = 0.5D0 )
 748 *     .. Scalar Arguments ..
 749       DOUBLE PRECISION   EPS, THRESH
 750       INTEGER            INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX,
 751      $                   NOUT, NTRA
 752       LOGICAL            FATAL, REWI, TRACE
 753       CHARACTER*6        SNAME
 754 *     .. Array Arguments ..
 755       DOUBLE PRECISION   A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
 756      $                   AS( NMAX*NMAX ), BET( NBET ), G( NMAX ),
 757      $                   X( NMAX ), XS( NMAX*INCMAX ),
 758      $                   XX( NMAX*INCMAX ), Y( NMAX ),
 759      $                   YS( NMAX*INCMAX ), YT( NMAX ),
 760      $                   YY( NMAX*INCMAX )
 761       INTEGER            IDIM( NIDIM ), INC( NINC ), KB( NKB )
 762 *     .. Local Scalars ..
 763       DOUBLE PRECISION   ALPHA, ALS, BETA, BLS, ERR, ERRMAX, TRANSL
 764       INTEGER            I, IA, IB, IC, IK, IN, INCX, INCXS, INCY,
 765      $                   INCYS, IX, IY, K, KS, LAA, LDA, LDAS, LX, LY,
 766      $                   N, NARGS, NC, NK, NS
 767       LOGICAL            BANDED, FULL, NULL, PACKED, RESET, SAME
 768       CHARACTER*1        UPLO, UPLOS
 769       CHARACTER*2        ICH
 770 *     .. Local Arrays ..
 771       LOGICAL            ISAME( 13 )
 772 *     .. External Functions ..
 773       LOGICAL            LDE, LDERES
 774       EXTERNAL           LDE, LDERES
 775 *     .. External Subroutines ..
 776       EXTERNAL           DMAKE, DMVCH, DSBMV, DSPMV, DSYMV
 777 *     .. Intrinsic Functions ..
 778       INTRINSIC          ABS, MAX
 779 *     .. Scalars in Common ..
 780       INTEGER            INFOT, NOUTC
 781       LOGICAL            LERR, OK
 782 *     .. Common blocks ..
 783       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
 784 *     .. Data statements ..
 785       DATA               ICH/'UL'/
 786 *     .. Executable Statements ..
 787       FULL = SNAME( 3: 3 ).EQ.'Y'
 788       BANDED = SNAME( 3: 3 ).EQ.'B'
 789       PACKED = SNAME( 3: 3 ).EQ.'P'
 790 *     Define the number of arguments.
 791       IF( FULL )THEN
 792          NARGS = 10
 793       ELSE IF( BANDED )THEN
 794          NARGS = 11
 795       ELSE IF( PACKED )THEN
 796          NARGS = 9
 797       END IF
 798 *
 799       NC = 0
 800       RESET = .TRUE.
 801       ERRMAX = ZERO
 802 *
 803       DO 110 IN = 1, NIDIM
 804          N = IDIM( IN )
 805 *
 806          IF( BANDED )THEN
 807             NK = NKB
 808          ELSE
 809             NK = 1
 810          END IF
 811          DO 100 IK = 1, NK
 812             IF( BANDED )THEN
 813                K = KB( IK )
 814             ELSE
 815                K = N - 1
 816             END IF
 817 *           Set LDA to 1 more than minimum value if room.
 818             IF( BANDED )THEN
 819                LDA = K + 1
 820             ELSE
 821                LDA = N
 822             END IF
 823             IF( LDA.LT.NMAX )
 824      $         LDA = LDA + 1
 825 *           Skip tests if not enough room.
 826             IF( LDA.GT.NMAX )
 827      $         GO TO 100
 828             IF( PACKED )THEN
 829                LAA = ( N*( N + 1 ) )/2
 830             ELSE
 831                LAA = LDA*N
 832             END IF
 833             NULL = N.LE.0
 834 *
 835             DO 90 IC = 1, 2
 836                UPLO = ICH( IC: IC )
 837 *
 838 *              Generate the matrix A.
 839 *
 840                TRANSL = ZERO
 841                CALL DMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, NMAX, AA,
 842      $                     LDA, K, K, RESET, TRANSL )
 843 *
 844                DO 80 IX = 1, NINC
 845                   INCX = INC( IX )
 846                   LX = ABS( INCX )*N
 847 *
 848 *                 Generate the vector X.
 849 *
 850                   TRANSL = HALF
 851                   CALL DMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX,
 852      $                        ABS( INCX ), 0, N - 1, RESET, TRANSL )
 853                   IF( N.GT.1 )THEN
 854                      X( N/2 ) = ZERO
 855                      XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
 856                   END IF
 857 *
 858                   DO 70 IY = 1, NINC
 859                      INCY = INC( IY )
 860                      LY = ABS( INCY )*N
 861 *
 862                      DO 60 IA = 1, NALF
 863                         ALPHA = ALF( IA )
 864 *
 865                         DO 50 IB = 1, NBET
 866                            BETA = BET( IB )
 867 *
 868 *                          Generate the vector Y.
 869 *
 870                            TRANSL = ZERO
 871                            CALL DMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY,
 872      $                                 ABS( INCY ), 0, N - 1, RESET,
 873      $                                 TRANSL )
 874 *
 875                            NC = NC + 1
 876 *
 877 *                          Save every datum before calling the
 878 *                          subroutine.
 879 *
 880                            UPLOS = UPLO
 881                            NS = N
 882                            KS = K
 883                            ALS = ALPHA
 884                            DO 10 I = 1, LAA
 885                               AS( I ) = AA( I )
 886    10                      CONTINUE
 887                            LDAS = LDA
 888                            DO 20 I = 1, LX
 889                               XS( I ) = XX( I )
 890    20                      CONTINUE
 891                            INCXS = INCX
 892                            BLS = BETA
 893                            DO 30 I = 1, LY
 894                               YS( I ) = YY( I )
 895    30                      CONTINUE
 896                            INCYS = INCY
 897 *
 898 *                          Call the subroutine.
 899 *
 900                            IF( FULL )THEN
 901                               IF( TRACE )
 902      $                           WRITE( NTRA, FMT = 9993 )NC, SNAME,
 903      $                           UPLO, N, ALPHA, LDA, INCX, BETA, INCY
 904                               IF( REWI )
 905      $                           REWIND NTRA
 906                               CALL DSYMV( UPLO, N, ALPHA, AA, LDA, XX,
 907      $                                    INCX, BETA, YY, INCY )
 908                            ELSE IF( BANDED )THEN
 909                               IF( TRACE )
 910      $                           WRITE( NTRA, FMT = 9994 )NC, SNAME,
 911      $                           UPLO, N, K, ALPHA, LDA, INCX, BETA,
 912      $                           INCY
 913                               IF( REWI )
 914      $                           REWIND NTRA
 915                               CALL DSBMV( UPLO, N, K, ALPHA, AA, LDA,
 916      $                                    XX, INCX, BETA, YY, INCY )
 917                            ELSE IF( PACKED )THEN
 918                               IF( TRACE )
 919      $                           WRITE( NTRA, FMT = 9995 )NC, SNAME,
 920      $                           UPLO, N, ALPHA, INCX, BETA, INCY
 921                               IF( REWI )
 922      $                           REWIND NTRA
 923                               CALL DSPMV( UPLO, N, ALPHA, AA, XX, INCX,
 924      $                                    BETA, YY, INCY )
 925                            END IF
 926 *
 927 *                          Check if error-exit was taken incorrectly.
 928 *
 929                            IF( .NOT.OK )THEN
 930                               WRITE( NOUT, FMT = 9992 )
 931                               FATAL = .TRUE.
 932                               GO TO 120
 933                            END IF
 934 *
 935 *                          See what data changed inside subroutines.
 936 *
 937                            ISAME( 1 ) = UPLO.EQ.UPLOS
 938                            ISAME( 2 ) = NS.EQ.N
 939                            IF( FULL )THEN
 940                               ISAME( 3 ) = ALS.EQ.ALPHA
 941                               ISAME( 4 ) = LDE( AS, AA, LAA )
 942                               ISAME( 5 ) = LDAS.EQ.LDA
 943                               ISAME( 6 ) = LDE( XS, XX, LX )
 944                               ISAME( 7 ) = INCXS.EQ.INCX
 945                               ISAME( 8 ) = BLS.EQ.BETA
 946                               IF( NULL )THEN
 947                                  ISAME( 9 ) = LDE( YS, YY, LY )
 948                               ELSE
 949                                  ISAME( 9 ) = LDERES( 'GE', ' ', 1, N,
 950      $                                        YS, YY, ABS( INCY ) )
 951                               END IF
 952                               ISAME( 10 ) = INCYS.EQ.INCY
 953                            ELSE IF( BANDED )THEN
 954                               ISAME( 3 ) = KS.EQ.K
 955                               ISAME( 4 ) = ALS.EQ.ALPHA
 956                               ISAME( 5 ) = LDE( AS, AA, LAA )
 957                               ISAME( 6 ) = LDAS.EQ.LDA
 958                               ISAME( 7 ) = LDE( XS, XX, LX )
 959                               ISAME( 8 ) = INCXS.EQ.INCX
 960                               ISAME( 9 ) = BLS.EQ.BETA
 961                               IF( NULL )THEN
 962                                  ISAME( 10 ) = LDE( YS, YY, LY )
 963                               ELSE
 964                                  ISAME( 10 ) = LDERES( 'GE', ' ', 1, N,
 965      $                                         YS, YY, ABS( INCY ) )
 966                               END IF
 967                               ISAME( 11 ) = INCYS.EQ.INCY
 968                            ELSE IF( PACKED )THEN
 969                               ISAME( 3 ) = ALS.EQ.ALPHA
 970                               ISAME( 4 ) = LDE( AS, AA, LAA )
 971                               ISAME( 5 ) = LDE( XS, XX, LX )
 972                               ISAME( 6 ) = INCXS.EQ.INCX
 973                               ISAME( 7 ) = BLS.EQ.BETA
 974                               IF( NULL )THEN
 975                                  ISAME( 8 ) = LDE( YS, YY, LY )
 976                               ELSE
 977                                  ISAME( 8 ) = LDERES( 'GE', ' ', 1, N,
 978      $                                        YS, YY, ABS( INCY ) )
 979                               END IF
 980                               ISAME( 9 ) = INCYS.EQ.INCY
 981                            END IF
 982 *
 983 *                          If data was incorrectly changed, report and
 984 *                          return.
 985 *
 986                            SAME = .TRUE.
 987                            DO 40 I = 1, NARGS
 988                               SAME = SAME.AND.ISAME( I )
 989                               IF( .NOT.ISAME( I ) )
 990      $                           WRITE( NOUT, FMT = 9998 )I
 991    40                      CONTINUE
 992                            IF( .NOT.SAME )THEN
 993                               FATAL = .TRUE.
 994                               GO TO 120
 995                            END IF
 996 *
 997                            IF( .NOT.NULL )THEN
 998 *
 999 *                             Check the result.
1000 *
1001                               CALL DMVCH( 'N', N, N, ALPHA, A, NMAX, X,
1002      $                                    INCX, BETA, Y, INCY, YT, G,
1003      $                                    YY, EPS, ERR, FATAL, NOUT,
1004      $                                    .TRUE. )
1005                               ERRMAX = MAX( ERRMAX, ERR )
1006 *                             If got really bad answer, report and
1007 *                             return.
1008                               IF( FATAL )
1009      $                           GO TO 120
1010                            ELSE
1011 *                             Avoid repeating tests with N.le.0
1012                               GO TO 110
1013                            END IF
1014 *
1015    50                   CONTINUE
1016 *
1017    60                CONTINUE
1018 *
1019    70             CONTINUE
1020 *
1021    80          CONTINUE
1022 *
1023    90       CONTINUE
1024 *
1025   100    CONTINUE
1026 *
1027   110 CONTINUE
1028 *
1029 *     Report result.
1030 *
1031       IF( ERRMAX.LT.THRESH )THEN
1032          WRITE( NOUT, FMT = 9999 )SNAME, NC
1033       ELSE
1034          WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
1035       END IF
1036       GO TO 130
1037 *
1038   120 CONTINUE
1039       WRITE( NOUT, FMT = 9996 )SNAME
1040       IF( FULL )THEN
1041          WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, LDA, INCX,
1042      $      BETA, INCY
1043       ELSE IF( BANDED )THEN
1044          WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, K, ALPHA, LDA,
1045      $      INCX, BETA, INCY
1046       ELSE IF( PACKED )THEN
1047          WRITE( NOUT, FMT = 9995 )NC, SNAME, UPLO, N, ALPHA, INCX,
1048      $      BETA, INCY
1049       END IF
1050 *
1051   130 CONTINUE
1052       RETURN
1053 *
1054  9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
1055      $      'S)' )
1056  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
1057      $      'ANGED INCORRECTLY *******' )
1058  9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
1059      $      'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
1060      $      ' - SUSPECT *******' )
1061  9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
1062  9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', AP',
1063      $      ', X,', I2, ',', F4.1, ', Y,', I2, ')                .' )
1064  9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), F4.1,
1065      $      ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2,
1066      $      ')         .' )
1067  9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', A,',
1068      $      I3, ', X,', I2, ',', F4.1, ', Y,', I2, ')             .' )
1069  9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1070      $      '******' )
1071 *
1072 *     End of DCHK2.
1073 *
1074       END
1075       SUBROUTINE DCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1076      $                  FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, NMAX,
1077      $                  INCMAX, A, AA, AS, X, XX, XS, XT, G, Z )
1078 *
1079 *  Tests DTRMV, DTBMV, DTPMV, DTRSV, DTBSV and DTPSV.
1080 *
1081 *  Auxiliary routine for test program for Level 2 Blas.
1082 *
1083 *  -- Written on 10-August-1987.
1084 *     Richard Hanson, Sandia National Labs.
1085 *     Jeremy Du Croz, NAG Central Office.
1086 *
1087 *     .. Parameters ..
1088       DOUBLE PRECISION   ZERO, HALF, ONE
1089       PARAMETER          ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )
1090 *     .. Scalar Arguments ..
1091       DOUBLE PRECISION   EPS, THRESH
1092       INTEGER            INCMAX, NIDIM, NINC, NKB, NMAX, NOUT, NTRA
1093       LOGICAL            FATAL, REWI, TRACE
1094       CHARACTER*6        SNAME
1095 *     .. Array Arguments ..
1096       DOUBLE PRECISION   A( NMAX, NMAX ), AA( NMAX*NMAX ),
1097      $                   AS( NMAX*NMAX ), G( NMAX ), X( NMAX ),
1098      $                   XS( NMAX*INCMAX ), XT( NMAX ),
1099      $                   XX( NMAX*INCMAX ), Z( NMAX )
1100       INTEGER            IDIM( NIDIM ), INC( NINC ), KB( NKB )
1101 *     .. Local Scalars ..
1102       DOUBLE PRECISION   ERR, ERRMAX, TRANSL
1103       INTEGER            I, ICD, ICT, ICU, IK, IN, INCX, INCXS, IX, K,
1104      $                   KS, LAA, LDA, LDAS, LX, N, NARGS, NC, NK, NS
1105       LOGICAL            BANDED, FULL, NULL, PACKED, RESET, SAME
1106       CHARACTER*1        DIAG, DIAGS, TRANS, TRANSS, UPLO, UPLOS
1107       CHARACTER*2        ICHD, ICHU
1108       CHARACTER*3        ICHT
1109 *     .. Local Arrays ..
1110       LOGICAL            ISAME( 13 )
1111 *     .. External Functions ..
1112       LOGICAL            LDE, LDERES
1113       EXTERNAL           LDE, LDERES
1114 *     .. External Subroutines ..
1115       EXTERNAL           DMAKE, DMVCH, DTBMV, DTBSV, DTPMV, DTPSV,
1116      $                   DTRMV, DTRSV
1117 *     .. Intrinsic Functions ..
1118       INTRINSIC          ABS, MAX
1119 *     .. Scalars in Common ..
1120       INTEGER            INFOT, NOUTC
1121       LOGICAL            LERR, OK
1122 *     .. Common blocks ..
1123       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
1124 *     .. Data statements ..
1125       DATA               ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/
1126 *     .. Executable Statements ..
1127       FULL = SNAME( 3: 3 ).EQ.'R'
1128       BANDED = SNAME( 3: 3 ).EQ.'B'
1129       PACKED = SNAME( 3: 3 ).EQ.'P'
1130 *     Define the number of arguments.
1131       IF( FULL )THEN
1132          NARGS = 8
1133       ELSE IF( BANDED )THEN
1134          NARGS = 9
1135       ELSE IF( PACKED )THEN
1136          NARGS = 7
1137       END IF
1138 *
1139       NC = 0
1140       RESET = .TRUE.
1141       ERRMAX = ZERO
1142 *     Set up zero vector for DMVCH.
1143       DO 10 I = 1, NMAX
1144          Z( I ) = ZERO
1145    10 CONTINUE
1146 *
1147       DO 110 IN = 1, NIDIM
1148          N = IDIM( IN )
1149 *
1150          IF( BANDED )THEN
1151             NK = NKB
1152          ELSE
1153             NK = 1
1154          END IF
1155          DO 100 IK = 1, NK
1156             IF( BANDED )THEN
1157                K = KB( IK )
1158             ELSE
1159                K = N - 1
1160             END IF
1161 *           Set LDA to 1 more than minimum value if room.
1162             IF( BANDED )THEN
1163                LDA = K + 1
1164             ELSE
1165                LDA = N
1166             END IF
1167             IF( LDA.LT.NMAX )
1168      $         LDA = LDA + 1
1169 *           Skip tests if not enough room.
1170             IF( LDA.GT.NMAX )
1171      $         GO TO 100
1172             IF( PACKED )THEN
1173                LAA = ( N*( N + 1 ) )/2
1174             ELSE
1175                LAA = LDA*N
1176             END IF
1177             NULL = N.LE.0
1178 *
1179             DO 90 ICU = 1, 2
1180                UPLO = ICHU( ICU: ICU )
1181 *
1182                DO 80 ICT = 1, 3
1183                   TRANS = ICHT( ICT: ICT )
1184 *
1185                   DO 70 ICD = 1, 2
1186                      DIAG = ICHD( ICD: ICD )
1187 *
1188 *                    Generate the matrix A.
1189 *
1190                      TRANSL = ZERO
1191                      CALL DMAKE( SNAME( 2: 3 ), UPLO, DIAG, N, N, A,
1192      $                           NMAX, AA, LDA, K, K, RESET, TRANSL )
1193 *
1194                      DO 60 IX = 1, NINC
1195                         INCX = INC( IX )
1196                         LX = ABS( INCX )*N
1197 *
1198 *                       Generate the vector X.
1199 *
1200                         TRANSL = HALF
1201                         CALL DMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX,
1202      $                              ABS( INCX ), 0, N - 1, RESET,
1203      $                              TRANSL )
1204                         IF( N.GT.1 )THEN
1205                            X( N/2 ) = ZERO
1206                            XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
1207                         END IF
1208 *
1209                         NC = NC + 1
1210 *
1211 *                       Save every datum before calling the subroutine.
1212 *
1213                         UPLOS = UPLO
1214                         TRANSS = TRANS
1215                         DIAGS = DIAG
1216                         NS = N
1217                         KS = K
1218                         DO 20 I = 1, LAA
1219                            AS( I ) = AA( I )
1220    20                   CONTINUE
1221                         LDAS = LDA
1222                         DO 30 I = 1, LX
1223                            XS( I ) = XX( I )
1224    30                   CONTINUE
1225                         INCXS = INCX
1226 *
1227 *                       Call the subroutine.
1228 *
1229                         IF( SNAME( 4: 5 ).EQ.'MV' )THEN
1230                            IF( FULL )THEN
1231                               IF( TRACE )
1232      $                           WRITE( NTRA, FMT = 9993 )NC, SNAME,
1233      $                           UPLO, TRANS, DIAG, N, LDA, INCX
1234                               IF( REWI )
1235      $                           REWIND NTRA
1236                               CALL DTRMV( UPLO, TRANS, DIAG, N, AA, LDA,
1237      $                                    XX, INCX )
1238                            ELSE IF( BANDED )THEN
1239                               IF( TRACE )
1240      $                           WRITE( NTRA, FMT = 9994 )NC, SNAME,
1241      $                           UPLO, TRANS, DIAG, N, K, LDA, INCX
1242                               IF( REWI )
1243      $                           REWIND NTRA
1244                               CALL DTBMV( UPLO, TRANS, DIAG, N, K, AA,
1245      $                                    LDA, XX, INCX )
1246                            ELSE IF( PACKED )THEN
1247                               IF( TRACE )
1248      $                           WRITE( NTRA, FMT = 9995 )NC, SNAME,
1249      $                           UPLO, TRANS, DIAG, N, INCX
1250                               IF( REWI )
1251      $                           REWIND NTRA
1252                               CALL DTPMV( UPLO, TRANS, DIAG, N, AA, XX,
1253      $                                    INCX )
1254                            END IF
1255                         ELSE IF( SNAME( 4: 5 ).EQ.'SV' )THEN
1256                            IF( FULL )THEN
1257                               IF( TRACE )
1258      $                           WRITE( NTRA, FMT = 9993 )NC, SNAME,
1259      $                           UPLO, TRANS, DIAG, N, LDA, INCX
1260                               IF( REWI )
1261      $                           REWIND NTRA
1262                               CALL DTRSV( UPLO, TRANS, DIAG, N, AA, LDA,
1263      $                                    XX, INCX )
1264                            ELSE IF( BANDED )THEN
1265                               IF( TRACE )
1266      $                           WRITE( NTRA, FMT = 9994 )NC, SNAME,
1267      $                           UPLO, TRANS, DIAG, N, K, LDA, INCX
1268                               IF( REWI )
1269      $                           REWIND NTRA
1270                               CALL DTBSV( UPLO, TRANS, DIAG, N, K, AA,
1271      $                                    LDA, XX, INCX )
1272                            ELSE IF( PACKED )THEN
1273                               IF( TRACE )
1274      $                           WRITE( NTRA, FMT = 9995 )NC, SNAME,
1275      $                           UPLO, TRANS, DIAG, N, INCX
1276                               IF( REWI )
1277      $                           REWIND NTRA
1278                               CALL DTPSV( UPLO, TRANS, DIAG, N, AA, XX,
1279      $                                    INCX )
1280                            END IF
1281                         END IF
1282 *
1283 *                       Check if error-exit was taken incorrectly.
1284 *
1285                         IF( .NOT.OK )THEN
1286                            WRITE( NOUT, FMT = 9992 )
1287                            FATAL = .TRUE.
1288                            GO TO 120
1289                         END IF
1290 *
1291 *                       See what data changed inside subroutines.
1292 *
1293                         ISAME( 1 ) = UPLO.EQ.UPLOS
1294                         ISAME( 2 ) = TRANS.EQ.TRANSS
1295                         ISAME( 3 ) = DIAG.EQ.DIAGS
1296                         ISAME( 4 ) = NS.EQ.N
1297                         IF( FULL )THEN
1298                            ISAME( 5 ) = LDE( AS, AA, LAA )
1299                            ISAME( 6 ) = LDAS.EQ.LDA
1300                            IF( NULL )THEN
1301                               ISAME( 7 ) = LDE( XS, XX, LX )
1302                            ELSE
1303                               ISAME( 7 ) = LDERES( 'GE', ' ', 1, N, XS,
1304      $                                     XX, ABS( INCX ) )
1305                            END IF
1306                            ISAME( 8 ) = INCXS.EQ.INCX
1307                         ELSE IF( BANDED )THEN
1308                            ISAME( 5 ) = KS.EQ.K
1309                            ISAME( 6 ) = LDE( AS, AA, LAA )
1310                            ISAME( 7 ) = LDAS.EQ.LDA
1311                            IF( NULL )THEN
1312                               ISAME( 8 ) = LDE( XS, XX, LX )
1313                            ELSE
1314                               ISAME( 8 ) = LDERES( 'GE', ' ', 1, N, XS,
1315      $                                     XX, ABS( INCX ) )
1316                            END IF
1317                            ISAME( 9 ) = INCXS.EQ.INCX
1318                         ELSE IF( PACKED )THEN
1319                            ISAME( 5 ) = LDE( AS, AA, LAA )
1320                            IF( NULL )THEN
1321                               ISAME( 6 ) = LDE( XS, XX, LX )
1322                            ELSE
1323                               ISAME( 6 ) = LDERES( 'GE', ' ', 1, N, XS,
1324      $                                     XX, ABS( INCX ) )
1325                            END IF
1326                            ISAME( 7 ) = INCXS.EQ.INCX
1327                         END IF
1328 *
1329 *                       If data was incorrectly changed, report and
1330 *                       return.
1331 *
1332                         SAME = .TRUE.
1333                         DO 40 I = 1, NARGS
1334                            SAME = SAME.AND.ISAME( I )
1335                            IF( .NOT.ISAME( I ) )
1336      $                        WRITE( NOUT, FMT = 9998 )I
1337    40                   CONTINUE
1338                         IF( .NOT.SAME )THEN
1339                            FATAL = .TRUE.
1340                            GO TO 120
1341                         END IF
1342 *
1343                         IF( .NOT.NULL )THEN
1344                            IF( SNAME( 4: 5 ).EQ.'MV' )THEN
1345 *
1346 *                             Check the result.
1347 *
1348                               CALL DMVCH( TRANS, N, N, ONE, A, NMAX, X,
1349      $                                    INCX, ZERO, Z, INCX, XT, G,
1350      $                                    XX, EPS, ERR, FATAL, NOUT,
1351      $                                    .TRUE. )
1352                            ELSE IF( SNAME( 4: 5 ).EQ.'SV' )THEN
1353 *
1354 *                             Compute approximation to original vector.
1355 *
1356                               DO 50 I = 1, N
1357                                  Z( I ) = XX( 1 + ( I - 1 )*
1358      $                                    ABS( INCX ) )
1359                                  XX( 1 + ( I - 1 )*ABS( INCX ) )
1360      $                              = X( I )
1361    50                         CONTINUE
1362                               CALL DMVCH( TRANS, N, N, ONE, A, NMAX, Z,
1363      $                                    INCX, ZERO, X, INCX, XT, G,
1364      $                                    XX, EPS, ERR, FATAL, NOUT,
1365      $                                    .FALSE. )
1366                            END IF
1367                            ERRMAX = MAX( ERRMAX, ERR )
1368 *                          If got really bad answer, report and return.
1369                            IF( FATAL )
1370      $                        GO TO 120
1371                         ELSE
1372 *                          Avoid repeating tests with N.le.0.
1373                            GO TO 110
1374                         END IF
1375 *
1376    60                CONTINUE
1377 *
1378    70             CONTINUE
1379 *
1380    80          CONTINUE
1381 *
1382    90       CONTINUE
1383 *
1384   100    CONTINUE
1385 *
1386   110 CONTINUE
1387 *
1388 *     Report result.
1389 *
1390       IF( ERRMAX.LT.THRESH )THEN
1391          WRITE( NOUT, FMT = 9999 )SNAME, NC
1392       ELSE
1393          WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
1394       END IF
1395       GO TO 130
1396 *
1397   120 CONTINUE
1398       WRITE( NOUT, FMT = 9996 )SNAME
1399       IF( FULL )THEN
1400          WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, TRANS, DIAG, N, LDA,
1401      $      INCX
1402       ELSE IF( BANDED )THEN
1403          WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, DIAG, N, K,
1404      $      LDA, INCX
1405       ELSE IF( PACKED )THEN
1406          WRITE( NOUT, FMT = 9995 )NC, SNAME, UPLO, TRANS, DIAG, N, INCX
1407       END IF
1408 *
1409   130 CONTINUE
1410       RETURN
1411 *
1412  9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
1413      $      'S)' )
1414  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
1415      $      'ANGED INCORRECTLY *******' )
1416  9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
1417      $      'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
1418      $      ' - SUSPECT *******' )
1419  9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
1420  9995 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), I3, ', AP, ',
1421      $      'X,', I2, ')                        .' )
1422  9994 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), 2( I3, ',' ),
1423      $      ' A,', I3, ', X,', I2, ')                 .' )
1424  9993 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), I3, ', A,',
1425      $      I3, ', X,', I2, ')                     .' )
1426  9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1427      $      '******' )
1428 *
1429 *     End of DCHK3.
1430 *
1431       END
1432       SUBROUTINE DCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1433      $                  FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX,
1434      $                  INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G,
1435      $                  Z )
1436 *
1437 *  Tests DGER.
1438 *
1439 *  Auxiliary routine for test program for Level 2 Blas.
1440 *
1441 *  -- Written on 10-August-1987.
1442 *     Richard Hanson, Sandia National Labs.
1443 *     Jeremy Du Croz, NAG Central Office.
1444 *
1445 *     .. Parameters ..
1446       DOUBLE PRECISION   ZERO, HALF, ONE
1447       PARAMETER          ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )
1448 *     .. Scalar Arguments ..
1449       DOUBLE PRECISION   EPS, THRESH
1450       INTEGER            INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA
1451       LOGICAL            FATAL, REWI, TRACE
1452       CHARACTER*6        SNAME
1453 *     .. Array Arguments ..
1454       DOUBLE PRECISION   A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
1455      $                   AS( NMAX*NMAX ), G( NMAX ), X( NMAX ),
1456      $                   XS( NMAX*INCMAX ), XX( NMAX*INCMAX ),
1457      $                   Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ),
1458      $                   YY( NMAX*INCMAX ), Z( NMAX )
1459       INTEGER            IDIM( NIDIM ), INC( NINC )
1460 *     .. Local Scalars ..
1461       DOUBLE PRECISION   ALPHA, ALS, ERR, ERRMAX, TRANSL
1462       INTEGER            I, IA, IM, IN, INCX, INCXS, INCY, INCYS, IX,
1463      $                   IY, J, LAA, LDA, LDAS, LX, LY, M, MS, N, NARGS,
1464      $                   NC, ND, NS
1465       LOGICAL            NULL, RESET, SAME
1466 *     .. Local Arrays ..
1467       DOUBLE PRECISION   W( 1 )
1468       LOGICAL            ISAME( 13 )
1469 *     .. External Functions ..
1470       LOGICAL            LDE, LDERES
1471       EXTERNAL           LDE, LDERES
1472 *     .. External Subroutines ..
1473       EXTERNAL           DGER, DMAKE, DMVCH
1474 *     .. Intrinsic Functions ..
1475       INTRINSIC          ABS, MAX, MIN
1476 *     .. Scalars in Common ..
1477       INTEGER            INFOT, NOUTC
1478       LOGICAL            LERR, OK
1479 *     .. Common blocks ..
1480       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
1481 *     .. Executable Statements ..
1482 *     Define the number of arguments.
1483       NARGS = 9
1484 *
1485       NC = 0
1486       RESET = .TRUE.
1487       ERRMAX = ZERO
1488 *
1489       DO 120 IN = 1, NIDIM
1490          N = IDIM( IN )
1491          ND = N/2 + 1
1492 *
1493          DO 110 IM = 1, 2
1494             IF( IM.EQ.1 )
1495      $         M = MAX( N - ND, 0 )
1496             IF( IM.EQ.2 )
1497      $         M = MIN( N + ND, NMAX )
1498 *
1499 *           Set LDA to 1 more than minimum value if room.
1500             LDA = M
1501             IF( LDA.LT.NMAX )
1502      $         LDA = LDA + 1
1503 *           Skip tests if not enough room.
1504             IF( LDA.GT.NMAX )
1505      $         GO TO 110
1506             LAA = LDA*N
1507             NULL = N.LE.0.OR.M.LE.0
1508 *
1509             DO 100 IX = 1, NINC
1510                INCX = INC( IX )
1511                LX = ABS( INCX )*M
1512 *
1513 *              Generate the vector X.
1514 *
1515                TRANSL = HALF
1516                CALL DMAKE( 'GE', ' ', ' ', 1, M, X, 1, XX, ABS( INCX ),
1517      $                     0, M - 1, RESET, TRANSL )
1518                IF( M.GT.1 )THEN
1519                   X( M/2 ) = ZERO
1520                   XX( 1 + ABS( INCX )*( M/2 - 1 ) ) = ZERO
1521                END IF
1522 *
1523                DO 90 IY = 1, NINC
1524                   INCY = INC( IY )
1525                   LY = ABS( INCY )*N
1526 *
1527 *                 Generate the vector Y.
1528 *
1529                   TRANSL = ZERO
1530                   CALL DMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY,
1531      $                        ABS( INCY ), 0, N - 1, RESET, TRANSL )
1532                   IF( N.GT.1 )THEN
1533                      Y( N/2 ) = ZERO
1534                      YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO
1535                   END IF
1536 *
1537                   DO 80 IA = 1, NALF
1538                      ALPHA = ALF( IA )
1539 *
1540 *                    Generate the matrix A.
1541 *
1542                      TRANSL = ZERO
1543                      CALL DMAKE( SNAME( 2: 3 ), ' ', ' ', M, N, A, NMAX,
1544      $                           AA, LDA, M - 1, N - 1, RESET, TRANSL )
1545 *
1546                      NC = NC + 1
1547 *
1548 *                    Save every datum before calling the subroutine.
1549 *
1550                      MS = M
1551                      NS = N
1552                      ALS = ALPHA
1553                      DO 10 I = 1, LAA
1554                         AS( I ) = AA( I )
1555    10                CONTINUE
1556                      LDAS = LDA
1557                      DO 20 I = 1, LX
1558                         XS( I ) = XX( I )
1559    20                CONTINUE
1560                      INCXS = INCX
1561                      DO 30 I = 1, LY
1562                         YS( I ) = YY( I )
1563    30                CONTINUE
1564                      INCYS = INCY
1565 *
1566 *                    Call the subroutine.
1567 *
1568                      IF( TRACE )
1569      $                  WRITE( NTRA, FMT = 9994 )NC, SNAME, M, N,
1570      $                  ALPHA, INCX, INCY, LDA
1571                      IF( REWI )
1572      $                  REWIND NTRA
1573                      CALL DGER( M, N, ALPHA, XX, INCX, YY, INCY, AA,
1574      $                          LDA )
1575 *
1576 *                    Check if error-exit was taken incorrectly.
1577 *
1578                      IF( .NOT.OK )THEN
1579                         WRITE( NOUT, FMT = 9993 )
1580                         FATAL = .TRUE.
1581                         GO TO 140
1582                      END IF
1583 *
1584 *                    See what data changed inside subroutine.
1585 *
1586                      ISAME( 1 ) = MS.EQ.M
1587                      ISAME( 2 ) = NS.EQ.N
1588                      ISAME( 3 ) = ALS.EQ.ALPHA
1589                      ISAME( 4 ) = LDE( XS, XX, LX )
1590                      ISAME( 5 ) = INCXS.EQ.INCX
1591                      ISAME( 6 ) = LDE( YS, YY, LY )
1592                      ISAME( 7 ) = INCYS.EQ.INCY
1593                      IF( NULL )THEN
1594                         ISAME( 8 ) = LDE( AS, AA, LAA )
1595                      ELSE
1596                         ISAME( 8 ) = LDERES( 'GE', ' ', M, N, AS, AA,
1597      $                               LDA )
1598                      END IF
1599                      ISAME( 9 ) = LDAS.EQ.LDA
1600 *
1601 *                    If data was incorrectly changed, report and return.
1602 *
1603                      SAME = .TRUE.
1604                      DO 40 I = 1, NARGS
1605                         SAME = SAME.AND.ISAME( I )
1606                         IF( .NOT.ISAME( I ) )
1607      $                     WRITE( NOUT, FMT = 9998 )I
1608    40                CONTINUE
1609                      IF( .NOT.SAME )THEN
1610                         FATAL = .TRUE.
1611                         GO TO 140
1612                      END IF
1613 *
1614                      IF( .NOT.NULL )THEN
1615 *
1616 *                       Check the result column by column.
1617 *
1618                         IF( INCX.GT.0 )THEN
1619                            DO 50 I = 1, M
1620                               Z( I ) = X( I )
1621    50                      CONTINUE
1622                         ELSE
1623                            DO 60 I = 1, M
1624                               Z( I ) = X( M - I + 1 )
1625    60                      CONTINUE
1626                         END IF
1627                         DO 70 J = 1, N
1628                            IF( INCY.GT.0 )THEN
1629                               W( 1 ) = Y( J )
1630                            ELSE
1631                               W( 1 ) = Y( N - J + 1 )
1632                            END IF
1633                            CALL DMVCH( 'N', M, 1, ALPHA, Z, NMAX, W, 1,
1634      $                                 ONE, A( 1, J ), 1, YT, G,
1635      $                                 AA( 1 + ( J - 1 )*LDA ), EPS,
1636      $                                 ERR, FATAL, NOUT, .TRUE. )
1637                            ERRMAX = MAX( ERRMAX, ERR )
1638 *                          If got really bad answer, report and return.
1639                            IF( FATAL )
1640      $                        GO TO 130
1641    70                   CONTINUE
1642                      ELSE
1643 *                       Avoid repeating tests with M.le.0 or N.le.0.
1644                         GO TO 110
1645                      END IF
1646 *
1647    80             CONTINUE
1648 *
1649    90          CONTINUE
1650 *
1651   100       CONTINUE
1652 *
1653   110    CONTINUE
1654 *
1655   120 CONTINUE
1656 *
1657 *     Report result.
1658 *
1659       IF( ERRMAX.LT.THRESH )THEN
1660          WRITE( NOUT, FMT = 9999 )SNAME, NC
1661       ELSE
1662          WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
1663       END IF
1664       GO TO 150
1665 *
1666   130 CONTINUE
1667       WRITE( NOUT, FMT = 9995 )J
1668 *
1669   140 CONTINUE
1670       WRITE( NOUT, FMT = 9996 )SNAME
1671       WRITE( NOUT, FMT = 9994 )NC, SNAME, M, N, ALPHA, INCX, INCY, LDA
1672 *
1673   150 CONTINUE
1674       RETURN
1675 *
1676  9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
1677      $      'S)' )
1678  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
1679      $      'ANGED INCORRECTLY *******' )
1680  9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
1681      $      'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
1682      $      ' - SUSPECT *******' )
1683  9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
1684  9995 FORMAT( '      THESE ARE THE RESULTS FOR COLUMN ', I3 )
1685  9994 FORMAT( 1X, I6, ': ', A6, '(', 2( I3, ',' ), F4.1, ', X,', I2,
1686      $      ', Y,', I2, ', A,', I3, ')                  .' )
1687  9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1688      $      '******' )
1689 *
1690 *     End of DCHK4.
1691 *
1692       END
1693       SUBROUTINE DCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1694      $                  FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX,
1695      $                  INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G,
1696      $                  Z )
1697 *
1698 *  Tests DSYR and DSPR.
1699 *
1700 *  Auxiliary routine for test program for Level 2 Blas.
1701 *
1702 *  -- Written on 10-August-1987.
1703 *     Richard Hanson, Sandia National Labs.
1704 *     Jeremy Du Croz, NAG Central Office.
1705 *
1706 *     .. Parameters ..
1707       DOUBLE PRECISION   ZERO, HALF, ONE
1708       PARAMETER          ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )
1709 *     .. Scalar Arguments ..
1710       DOUBLE PRECISION   EPS, THRESH
1711       INTEGER            INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA
1712       LOGICAL            FATAL, REWI, TRACE
1713       CHARACTER*6        SNAME
1714 *     .. Array Arguments ..
1715       DOUBLE PRECISION   A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
1716      $                   AS( NMAX*NMAX ), G( NMAX ), X( NMAX ),
1717      $                   XS( NMAX*INCMAX ), XX( NMAX*INCMAX ),
1718      $                   Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ),
1719      $                   YY( NMAX*INCMAX ), Z( NMAX )
1720       INTEGER            IDIM( NIDIM ), INC( NINC )
1721 *     .. Local Scalars ..
1722       DOUBLE PRECISION   ALPHA, ALS, ERR, ERRMAX, TRANSL
1723       INTEGER            I, IA, IC, IN, INCX, INCXS, IX, J, JA, JJ, LAA,
1724      $                   LDA, LDAS, LJ, LX, N, NARGS, NC, NS
1725       LOGICAL            FULL, NULL, PACKED, RESET, SAME, UPPER
1726       CHARACTER*1        UPLO, UPLOS
1727       CHARACTER*2        ICH
1728 *     .. Local Arrays ..
1729       DOUBLE PRECISION   W( 1 )
1730       LOGICAL            ISAME( 13 )
1731 *     .. External Functions ..
1732       LOGICAL            LDE, LDERES
1733       EXTERNAL           LDE, LDERES
1734 *     .. External Subroutines ..
1735       EXTERNAL           DMAKE, DMVCH, DSPR, DSYR
1736 *     .. Intrinsic Functions ..
1737       INTRINSIC          ABS, MAX
1738 *     .. Scalars in Common ..
1739       INTEGER            INFOT, NOUTC
1740       LOGICAL            LERR, OK
1741 *     .. Common blocks ..
1742       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
1743 *     .. Data statements ..
1744       DATA               ICH/'UL'/
1745 *     .. Executable Statements ..
1746       FULL = SNAME( 3: 3 ).EQ.'Y'
1747       PACKED = SNAME( 3: 3 ).EQ.'P'
1748 *     Define the number of arguments.
1749       IF( FULL )THEN
1750          NARGS = 7
1751       ELSE IF( PACKED )THEN
1752          NARGS = 6
1753       END IF
1754 *
1755       NC = 0
1756       RESET = .TRUE.
1757       ERRMAX = ZERO
1758 *
1759       DO 100 IN = 1, NIDIM
1760          N = IDIM( IN )
1761 *        Set LDA to 1 more than minimum value if room.
1762          LDA = N
1763          IF( LDA.LT.NMAX )
1764      $      LDA = LDA + 1
1765 *        Skip tests if not enough room.
1766          IF( LDA.GT.NMAX )
1767      $      GO TO 100
1768          IF( PACKED )THEN
1769             LAA = ( N*( N + 1 ) )/2
1770          ELSE
1771             LAA = LDA*N
1772          END IF
1773 *
1774          DO 90 IC = 1, 2
1775             UPLO = ICH( IC: IC )
1776             UPPER = UPLO.EQ.'U'
1777 *
1778             DO 80 IX = 1, NINC
1779                INCX = INC( IX )
1780                LX = ABS( INCX )*N
1781 *
1782 *              Generate the vector X.
1783 *
1784                TRANSL = HALF
1785                CALL DMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ),
1786      $                     0, N - 1, RESET, TRANSL )
1787                IF( N.GT.1 )THEN
1788                   X( N/2 ) = ZERO
1789                   XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
1790                END IF
1791 *
1792                DO 70 IA = 1, NALF
1793                   ALPHA = ALF( IA )
1794                   NULL = N.LE.0.OR.ALPHA.EQ.ZERO
1795 *
1796 *                 Generate the matrix A.
1797 *
1798                   TRANSL = ZERO
1799                   CALL DMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, NMAX,
1800      $                        AA, LDA, N - 1, N - 1, RESET, TRANSL )
1801 *
1802                   NC = NC + 1
1803 *
1804 *                 Save every datum before calling the subroutine.
1805 *
1806                   UPLOS = UPLO
1807                   NS = N
1808                   ALS = ALPHA
1809                   DO 10 I = 1, LAA
1810                      AS( I ) = AA( I )
1811    10             CONTINUE
1812                   LDAS = LDA
1813                   DO 20 I = 1, LX
1814                      XS( I ) = XX( I )
1815    20             CONTINUE
1816                   INCXS = INCX
1817 *
1818 *                 Call the subroutine.
1819 *
1820                   IF( FULL )THEN
1821                      IF( TRACE )
1822      $                  WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, N,
1823      $                  ALPHA, INCX, LDA
1824                      IF( REWI )
1825      $                  REWIND NTRA
1826                      CALL DSYR( UPLO, N, ALPHA, XX, INCX, AA, LDA )
1827                   ELSE IF( PACKED )THEN
1828                      IF( TRACE )
1829      $                  WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, N,
1830      $                  ALPHA, INCX
1831                      IF( REWI )
1832      $                  REWIND NTRA
1833                      CALL DSPR( UPLO, N, ALPHA, XX, INCX, AA )
1834                   END IF
1835 *
1836 *                 Check if error-exit was taken incorrectly.
1837 *
1838                   IF( .NOT.OK )THEN
1839                      WRITE( NOUT, FMT = 9992 )
1840                      FATAL = .TRUE.
1841                      GO TO 120
1842                   END IF
1843 *
1844 *                 See what data changed inside subroutines.
1845 *
1846                   ISAME( 1 ) = UPLO.EQ.UPLOS
1847                   ISAME( 2 ) = NS.EQ.N
1848                   ISAME( 3 ) = ALS.EQ.ALPHA
1849                   ISAME( 4 ) = LDE( XS, XX, LX )
1850                   ISAME( 5 ) = INCXS.EQ.INCX
1851                   IF( NULL )THEN
1852                      ISAME( 6 ) = LDE( AS, AA, LAA )
1853                   ELSE
1854                      ISAME( 6 ) = LDERES( SNAME( 2: 3 ), UPLO, N, N, AS,
1855      $                            AA, LDA )
1856                   END IF
1857                   IF( .NOT.PACKED )THEN
1858                      ISAME( 7 ) = LDAS.EQ.LDA
1859                   END IF
1860 *
1861 *                 If data was incorrectly changed, report and return.
1862 *
1863                   SAME = .TRUE.
1864                   DO 30 I = 1, NARGS
1865                      SAME = SAME.AND.ISAME( I )
1866                      IF( .NOT.ISAME( I ) )
1867      $                  WRITE( NOUT, FMT = 9998 )I
1868    30             CONTINUE
1869                   IF( .NOT.SAME )THEN
1870                      FATAL = .TRUE.
1871                      GO TO 120
1872                   END IF
1873 *
1874                   IF( .NOT.NULL )THEN
1875 *
1876 *                    Check the result column by column.
1877 *
1878                      IF( INCX.GT.0 )THEN
1879                         DO 40 I = 1, N
1880                            Z( I ) = X( I )
1881    40                   CONTINUE
1882                      ELSE
1883                         DO 50 I = 1, N
1884                            Z( I ) = X( N - I + 1 )
1885    50                   CONTINUE
1886                      END IF
1887                      JA = 1
1888                      DO 60 J = 1, N
1889                         W( 1 ) = Z( J )
1890                         IF( UPPER )THEN
1891                            JJ = 1
1892                            LJ = J
1893                         ELSE
1894                            JJ = J
1895                            LJ = N - J + 1
1896                         END IF
1897                         CALL DMVCH( 'N', LJ, 1, ALPHA, Z( JJ ), LJ, W,
1898      $                              1, ONE, A( JJ, J ), 1, YT, G,
1899      $                              AA( JA ), EPS, ERR, FATAL, NOUT,
1900      $                              .TRUE. )
1901                         IF( FULL )THEN
1902                            IF( UPPER )THEN
1903                               JA = JA + LDA
1904                            ELSE
1905                               JA = JA + LDA + 1
1906                            END IF
1907                         ELSE
1908                            JA = JA + LJ
1909                         END IF
1910                         ERRMAX = MAX( ERRMAX, ERR )
1911 *                       If got really bad answer, report and return.
1912                         IF( FATAL )
1913      $                     GO TO 110
1914    60                CONTINUE
1915                   ELSE
1916 *                    Avoid repeating tests if N.le.0.
1917                      IF( N.LE.0 )
1918      $                  GO TO 100
1919                   END IF
1920 *
1921    70          CONTINUE
1922 *
1923    80       CONTINUE
1924 *
1925    90    CONTINUE
1926 *
1927   100 CONTINUE
1928 *
1929 *     Report result.
1930 *
1931       IF( ERRMAX.LT.THRESH )THEN
1932          WRITE( NOUT, FMT = 9999 )SNAME, NC
1933       ELSE
1934          WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
1935       END IF
1936       GO TO 130
1937 *
1938   110 CONTINUE
1939       WRITE( NOUT, FMT = 9995 )J
1940 *
1941   120 CONTINUE
1942       WRITE( NOUT, FMT = 9996 )SNAME
1943       IF( FULL )THEN
1944          WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, INCX, LDA
1945       ELSE IF( PACKED )THEN
1946          WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, ALPHA, INCX
1947       END IF
1948 *
1949   130 CONTINUE
1950       RETURN
1951 *
1952  9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
1953      $      'S)' )
1954  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
1955      $      'ANGED INCORRECTLY *******' )
1956  9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
1957      $      'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
1958      $      ' - SUSPECT *******' )
1959  9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
1960  9995 FORMAT( '      THESE ARE THE RESULTS FOR COLUMN ', I3 )
1961  9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,',
1962      $      I2, ', AP)                           .' )
1963  9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,',
1964      $      I2, ', A,', I3, ')                        .' )
1965  9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1966      $      '******' )
1967 *
1968 *     End of DCHK5.
1969 *
1970       END
1971       SUBROUTINE DCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1972      $                  FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX,
1973      $                  INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G,
1974      $                  Z )
1975 *
1976 *  Tests DSYR2 and DSPR2.
1977 *
1978 *  Auxiliary routine for test program for Level 2 Blas.
1979 *
1980 *  -- Written on 10-August-1987.
1981 *     Richard Hanson, Sandia National Labs.
1982 *     Jeremy Du Croz, NAG Central Office.
1983 *
1984 *     .. Parameters ..
1985       DOUBLE PRECISION   ZERO, HALF, ONE
1986       PARAMETER          ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )
1987 *     .. Scalar Arguments ..
1988       DOUBLE PRECISION   EPS, THRESH
1989       INTEGER            INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA
1990       LOGICAL            FATAL, REWI, TRACE
1991       CHARACTER*6        SNAME
1992 *     .. Array Arguments ..
1993       DOUBLE PRECISION   A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
1994      $                   AS( NMAX*NMAX ), G( NMAX ), X( NMAX ),
1995      $                   XS( NMAX*INCMAX ), XX( NMAX*INCMAX ),
1996      $                   Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ),
1997      $                   YY( NMAX*INCMAX ), Z( NMAX, 2 )
1998       INTEGER            IDIM( NIDIM ), INC( NINC )
1999 *     .. Local Scalars ..
2000       DOUBLE PRECISION   ALPHA, ALS, ERR, ERRMAX, TRANSL
2001       INTEGER            I, IA, IC, IN, INCX, INCXS, INCY, INCYS, IX,
2002      $                   IY, J, JA, JJ, LAA, LDA, LDAS, LJ, LX, LY, N,
2003      $                   NARGS, NC, NS
2004       LOGICAL            FULL, NULL, PACKED, RESET, SAME, UPPER
2005       CHARACTER*1        UPLO, UPLOS
2006       CHARACTER*2        ICH
2007 *     .. Local Arrays ..
2008       DOUBLE PRECISION   W( 2 )
2009       LOGICAL            ISAME( 13 )
2010 *     .. External Functions ..
2011       LOGICAL            LDE, LDERES
2012       EXTERNAL           LDE, LDERES
2013 *     .. External Subroutines ..
2014       EXTERNAL           DMAKE, DMVCH, DSPR2, DSYR2
2015 *     .. Intrinsic Functions ..
2016       INTRINSIC          ABS, MAX
2017 *     .. Scalars in Common ..
2018       INTEGER            INFOT, NOUTC
2019       LOGICAL            LERR, OK
2020 *     .. Common blocks ..
2021       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
2022 *     .. Data statements ..
2023       DATA               ICH/'UL'/
2024 *     .. Executable Statements ..
2025       FULL = SNAME( 3: 3 ).EQ.'Y'
2026       PACKED = SNAME( 3: 3 ).EQ.'P'
2027 *     Define the number of arguments.
2028       IF( FULL )THEN
2029          NARGS = 9
2030       ELSE IF( PACKED )THEN
2031          NARGS = 8
2032       END IF
2033 *
2034       NC = 0
2035       RESET = .TRUE.
2036       ERRMAX = ZERO
2037 *
2038       DO 140 IN = 1, NIDIM
2039          N = IDIM( IN )
2040 *        Set LDA to 1 more than minimum value if room.
2041          LDA = N
2042          IF( LDA.LT.NMAX )
2043      $      LDA = LDA + 1
2044 *        Skip tests if not enough room.
2045          IF( LDA.GT.NMAX )
2046      $      GO TO 140
2047          IF( PACKED )THEN
2048             LAA = ( N*( N + 1 ) )/2
2049          ELSE
2050             LAA = LDA*N
2051          END IF
2052 *
2053          DO 130 IC = 1, 2
2054             UPLO = ICH( IC: IC )
2055             UPPER = UPLO.EQ.'U'
2056 *
2057             DO 120 IX = 1, NINC
2058                INCX = INC( IX )
2059                LX = ABS( INCX )*N
2060 *
2061 *              Generate the vector X.
2062 *
2063                TRANSL = HALF
2064                CALL DMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ),
2065      $                     0, N - 1, RESET, TRANSL )
2066                IF( N.GT.1 )THEN
2067                   X( N/2 ) = ZERO
2068                   XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
2069                END IF
2070 *
2071                DO 110 IY = 1, NINC
2072                   INCY = INC( IY )
2073                   LY = ABS( INCY )*N
2074 *
2075 *                 Generate the vector Y.
2076 *
2077                   TRANSL = ZERO
2078                   CALL DMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY,
2079      $                        ABS( INCY ), 0, N - 1, RESET, TRANSL )
2080                   IF( N.GT.1 )THEN
2081                      Y( N/2 ) = ZERO
2082                      YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO
2083                   END IF
2084 *
2085                   DO 100 IA = 1, NALF
2086                      ALPHA = ALF( IA )
2087                      NULL = N.LE.0.OR.ALPHA.EQ.ZERO
2088 *
2089 *                    Generate the matrix A.
2090 *
2091                      TRANSL = ZERO
2092                      CALL DMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A,
2093      $                           NMAX, AA, LDA, N - 1, N - 1, RESET,
2094      $                           TRANSL )
2095 *
2096                      NC = NC + 1
2097 *
2098 *                    Save every datum before calling the subroutine.
2099 *
2100                      UPLOS = UPLO
2101                      NS = N
2102                      ALS = ALPHA
2103                      DO 10 I = 1, LAA
2104                         AS( I ) = AA( I )
2105    10                CONTINUE
2106                      LDAS = LDA
2107                      DO 20 I = 1, LX
2108                         XS( I ) = XX( I )
2109    20                CONTINUE
2110                      INCXS = INCX
2111                      DO 30 I = 1, LY
2112                         YS( I ) = YY( I )
2113    30                CONTINUE
2114                      INCYS = INCY
2115 *
2116 *                    Call the subroutine.
2117 *
2118                      IF( FULL )THEN
2119                         IF( TRACE )
2120      $                     WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, N,
2121      $                     ALPHA, INCX, INCY, LDA
2122                         IF( REWI )
2123      $                     REWIND NTRA
2124                         CALL DSYR2( UPLO, N, ALPHA, XX, INCX, YY, INCY,
2125      $                              AA, LDA )
2126                      ELSE IF( PACKED )THEN
2127                         IF( TRACE )
2128      $                     WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, N,
2129      $                     ALPHA, INCX, INCY
2130                         IF( REWI )
2131      $                     REWIND NTRA
2132                         CALL DSPR2( UPLO, N, ALPHA, XX, INCX, YY, INCY,
2133      $                              AA )
2134                      END IF
2135 *
2136 *                    Check if error-exit was taken incorrectly.
2137 *
2138                      IF( .NOT.OK )THEN
2139                         WRITE( NOUT, FMT = 9992 )
2140                         FATAL = .TRUE.
2141                         GO TO 160
2142                      END IF
2143 *
2144 *                    See what data changed inside subroutines.
2145 *
2146                      ISAME( 1 ) = UPLO.EQ.UPLOS
2147                      ISAME( 2 ) = NS.EQ.N
2148                      ISAME( 3 ) = ALS.EQ.ALPHA
2149                      ISAME( 4 ) = LDE( XS, XX, LX )
2150                      ISAME( 5 ) = INCXS.EQ.INCX
2151                      ISAME( 6 ) = LDE( YS, YY, LY )
2152                      ISAME( 7 ) = INCYS.EQ.INCY
2153                      IF( NULL )THEN
2154                         ISAME( 8 ) = LDE( AS, AA, LAA )
2155                      ELSE
2156                         ISAME( 8 ) = LDERES( SNAME( 2: 3 ), UPLO, N, N,
2157      $                               AS, AA, LDA )
2158                      END IF
2159                      IF( .NOT.PACKED )THEN
2160                         ISAME( 9 ) = LDAS.EQ.LDA
2161                      END IF
2162 *
2163 *                    If data was incorrectly changed, report and return.
2164 *
2165                      SAME = .TRUE.
2166                      DO 40 I = 1, NARGS
2167                         SAME = SAME.AND.ISAME( I )
2168                         IF( .NOT.ISAME( I ) )
2169      $                     WRITE( NOUT, FMT = 9998 )I
2170    40                CONTINUE
2171                      IF( .NOT.SAME )THEN
2172                         FATAL = .TRUE.
2173                         GO TO 160
2174                      END IF
2175 *
2176                      IF( .NOT.NULL )THEN
2177 *
2178 *                       Check the result column by column.
2179 *
2180                         IF( INCX.GT.0 )THEN
2181                            DO 50 I = 1, N
2182                               Z( I, 1 ) = X( I )
2183    50                      CONTINUE
2184                         ELSE
2185                            DO 60 I = 1, N
2186                               Z( I, 1 ) = X( N - I + 1 )
2187    60                      CONTINUE
2188                         END IF
2189                         IF( INCY.GT.0 )THEN
2190                            DO 70 I = 1, N
2191                               Z( I, 2 ) = Y( I )
2192    70                      CONTINUE
2193                         ELSE
2194                            DO 80 I = 1, N
2195                               Z( I, 2 ) = Y( N - I + 1 )
2196    80                      CONTINUE
2197                         END IF
2198                         JA = 1
2199                         DO 90 J = 1, N
2200                            W( 1 ) = Z( J, 2 )
2201                            W( 2 ) = Z( J, 1 )
2202                            IF( UPPER )THEN
2203                               JJ = 1
2204                               LJ = J
2205                            ELSE
2206                               JJ = J
2207                               LJ = N - J + 1
2208                            END IF
2209                            CALL DMVCH( 'N', LJ, 2, ALPHA, Z( JJ, 1 ),
2210      $                                 NMAX, W, 1, ONE, A( JJ, J ), 1,
2211      $                                 YT, G, AA( JA ), EPS, ERR, FATAL,
2212      $                                 NOUT, .TRUE. )
2213                            IF( FULL )THEN
2214                               IF( UPPER )THEN
2215                                  JA = JA + LDA
2216                               ELSE
2217                                  JA = JA + LDA + 1
2218                               END IF
2219                            ELSE
2220                               JA = JA + LJ
2221                            END IF
2222                            ERRMAX = MAX( ERRMAX, ERR )
2223 *                          If got really bad answer, report and return.
2224                            IF( FATAL )
2225      $                        GO TO 150
2226    90                   CONTINUE
2227                      ELSE
2228 *                       Avoid repeating tests with N.le.0.
2229                         IF( N.LE.0 )
2230      $                     GO TO 140
2231                      END IF
2232 *
2233   100             CONTINUE
2234 *
2235   110          CONTINUE
2236 *
2237   120       CONTINUE
2238 *
2239   130    CONTINUE
2240 *
2241   140 CONTINUE
2242 *
2243 *     Report result.
2244 *
2245       IF( ERRMAX.LT.THRESH )THEN
2246          WRITE( NOUT, FMT = 9999 )SNAME, NC
2247       ELSE
2248          WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
2249       END IF
2250       GO TO 170
2251 *
2252   150 CONTINUE
2253       WRITE( NOUT, FMT = 9995 )J
2254 *
2255   160 CONTINUE
2256       WRITE( NOUT, FMT = 9996 )SNAME
2257       IF( FULL )THEN
2258          WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, INCX,
2259      $      INCY, LDA
2260       ELSE IF( PACKED )THEN
2261          WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, ALPHA, INCX, INCY
2262       END IF
2263 *
2264   170 CONTINUE
2265       RETURN
2266 *
2267  9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
2268      $      'S)' )
2269  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
2270      $      'ANGED INCORRECTLY *******' )
2271  9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
2272      $      'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
2273      $      ' - SUSPECT *******' )
2274  9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
2275  9995 FORMAT( '      THESE ARE THE RESULTS FOR COLUMN ', I3 )
2276  9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,',
2277      $      I2, ', Y,', I2, ', AP)                     .' )
2278  9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,',
2279      $      I2, ', Y,', I2, ', A,', I3, ')                  .' )
2280  9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
2281      $      '******' )
2282 *
2283 *     End of DCHK6.
2284 *
2285       END
2286       SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT )
2287 *
2288 *  Tests the error exits from the Level 2 Blas.
2289 *  Requires a special version of the error-handling routine XERBLA.
2290 *  ALPHA, BETA, A, X and Y should not need to be defined.
2291 *
2292 *  Auxiliary routine for test program for Level 2 Blas.
2293 *
2294 *  -- Written on 10-August-1987.
2295 *     Richard Hanson, Sandia National Labs.
2296 *     Jeremy Du Croz, NAG Central Office.
2297 *
2298 *     .. Scalar Arguments ..
2299       INTEGER            ISNUM, NOUT
2300       CHARACTER*6        SRNAMT
2301 *     .. Scalars in Common ..
2302       INTEGER            INFOT, NOUTC
2303       LOGICAL            LERR, OK
2304 *     .. Local Scalars ..
2305       DOUBLE PRECISION   ALPHA, BETA
2306 *     .. Local Arrays ..
2307       DOUBLE PRECISION   A( 1, 1 ), X( 1 ), Y( 1 )
2308 *     .. External Subroutines ..
2309       EXTERNAL           CHKXER, DGBMV, DGEMV, DGER, DSBMV, DSPMV, DSPR,
2310      $                   DSPR2, DSYMV, DSYR, DSYR2, DTBMV, DTBSV, DTPMV,
2311      $                   DTPSV, DTRMV, DTRSV
2312 *     .. Common blocks ..
2313       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
2314 *     .. Executable Statements ..
2315 *     OK is set to .FALSE. by the special version of XERBLA or by CHKXER
2316 *     if anything is wrong.
2317       OK = .TRUE.
2318 *     LERR is set to .TRUE. by the special version of XERBLA each time
2319 *     it is called, and is then tested and re-set by CHKXER.
2320       LERR = .FALSE.
2321       GO TO ( 10, 20, 30, 40, 50, 60, 70, 80,
2322      $        90, 100, 110, 120, 130, 140, 150,
2323      $        160 )ISNUM
2324    10 INFOT = 1
2325       CALL DGEMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2326       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2327       INFOT = 2
2328       CALL DGEMV( 'N', -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2329       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2330       INFOT = 3
2331       CALL DGEMV( 'N', 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2332       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2333       INFOT = 6
2334       CALL DGEMV( 'N', 2, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2335       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2336       INFOT = 8
2337       CALL DGEMV( 'N', 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 )
2338       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2339       INFOT = 11
2340       CALL DGEMV( 'N', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 )
2341       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2342       GO TO 170
2343    20 INFOT = 1
2344       CALL DGBMV( '/', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2345       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2346       INFOT = 2
2347       CALL DGBMV( 'N', -1, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2348       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2349       INFOT = 3
2350       CALL DGBMV( 'N', 0, -1, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2351       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2352       INFOT = 4
2353       CALL DGBMV( 'N', 0, 0, -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2354       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2355       INFOT = 5
2356       CALL DGBMV( 'N', 2, 0, 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2357       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2358       INFOT = 8
2359       CALL DGBMV( 'N', 0, 0, 1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2360       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2361       INFOT = 10
2362       CALL DGBMV( 'N', 0, 0, 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 )
2363       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2364       INFOT = 13
2365       CALL DGBMV( 'N', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 )
2366       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2367       GO TO 170
2368    30 INFOT = 1
2369       CALL DSYMV( '/', 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2370       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2371       INFOT = 2
2372       CALL DSYMV( 'U', -1, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2373       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2374       INFOT = 5
2375       CALL DSYMV( 'U', 2, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2376       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2377       INFOT = 7
2378       CALL DSYMV( 'U', 0, ALPHA, A, 1, X, 0, BETA, Y, 1 )
2379       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2380       INFOT = 10
2381       CALL DSYMV( 'U', 0, ALPHA, A, 1, X, 1, BETA, Y, 0 )
2382       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2383       GO TO 170
2384    40 INFOT = 1
2385       CALL DSBMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2386       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2387       INFOT = 2
2388       CALL DSBMV( 'U', -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2389       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2390       INFOT = 3
2391       CALL DSBMV( 'U', 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2392       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2393       INFOT = 6
2394       CALL DSBMV( 'U', 0, 1, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2395       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2396       INFOT = 8
2397       CALL DSBMV( 'U', 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 )
2398       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2399       INFOT = 11
2400       CALL DSBMV( 'U', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 )
2401       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2402       GO TO 170
2403    50 INFOT = 1
2404       CALL DSPMV( '/', 0, ALPHA, A, X, 1, BETA, Y, 1 )
2405       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2406       INFOT = 2
2407       CALL DSPMV( 'U', -1, ALPHA, A, X, 1, BETA, Y, 1 )
2408       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2409       INFOT = 6
2410       CALL DSPMV( 'U', 0, ALPHA, A, X, 0, BETA, Y, 1 )
2411       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2412       INFOT = 9
2413       CALL DSPMV( 'U', 0, ALPHA, A, X, 1, BETA, Y, 0 )
2414       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2415       GO TO 170
2416    60 INFOT = 1
2417       CALL DTRMV( '/', 'N', 'N', 0, A, 1, X, 1 )
2418       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2419       INFOT = 2
2420       CALL DTRMV( 'U', '/', 'N', 0, A, 1, X, 1 )
2421       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2422       INFOT = 3
2423       CALL DTRMV( 'U', 'N', '/', 0, A, 1, X, 1 )
2424       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2425       INFOT = 4
2426       CALL DTRMV( 'U', 'N', 'N', -1, A, 1, X, 1 )
2427       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2428       INFOT = 6
2429       CALL DTRMV( 'U', 'N', 'N', 2, A, 1, X, 1 )
2430       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2431       INFOT = 8
2432       CALL DTRMV( 'U', 'N', 'N', 0, A, 1, X, 0 )
2433       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2434       GO TO 170
2435    70 INFOT = 1
2436       CALL DTBMV( '/', 'N', 'N', 0, 0, A, 1, X, 1 )
2437       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2438       INFOT = 2
2439       CALL DTBMV( 'U', '/', 'N', 0, 0, A, 1, X, 1 )
2440       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2441       INFOT = 3
2442       CALL DTBMV( 'U', 'N', '/', 0, 0, A, 1, X, 1 )
2443       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2444       INFOT = 4
2445       CALL DTBMV( 'U', 'N', 'N', -1, 0, A, 1, X, 1 )
2446       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2447       INFOT = 5
2448       CALL DTBMV( 'U', 'N', 'N', 0, -1, A, 1, X, 1 )
2449       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2450       INFOT = 7
2451       CALL DTBMV( 'U', 'N', 'N', 0, 1, A, 1, X, 1 )
2452       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2453       INFOT = 9
2454       CALL DTBMV( 'U', 'N', 'N', 0, 0, A, 1, X, 0 )
2455       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2456       GO TO 170
2457    80 INFOT = 1
2458       CALL DTPMV( '/', 'N', 'N', 0, A, X, 1 )
2459       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2460       INFOT = 2
2461       CALL DTPMV( 'U', '/', 'N', 0, A, X, 1 )
2462       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2463       INFOT = 3
2464       CALL DTPMV( 'U', 'N', '/', 0, A, X, 1 )
2465       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2466       INFOT = 4
2467       CALL DTPMV( 'U', 'N', 'N', -1, A, X, 1 )
2468       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2469       INFOT = 7
2470       CALL DTPMV( 'U', 'N', 'N', 0, A, X, 0 )
2471       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2472       GO TO 170
2473    90 INFOT = 1
2474       CALL DTRSV( '/', 'N', 'N', 0, A, 1, X, 1 )
2475       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2476       INFOT = 2
2477       CALL DTRSV( 'U', '/', 'N', 0, A, 1, X, 1 )
2478       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2479       INFOT = 3
2480       CALL DTRSV( 'U', 'N', '/', 0, A, 1, X, 1 )
2481       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2482       INFOT = 4
2483       CALL DTRSV( 'U', 'N', 'N', -1, A, 1, X, 1 )
2484       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2485       INFOT = 6
2486       CALL DTRSV( 'U', 'N', 'N', 2, A, 1, X, 1 )
2487       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2488       INFOT = 8
2489       CALL DTRSV( 'U', 'N', 'N', 0, A, 1, X, 0 )
2490       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2491       GO TO 170
2492   100 INFOT = 1
2493       CALL DTBSV( '/', 'N', 'N', 0, 0, A, 1, X, 1 )
2494       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2495       INFOT = 2
2496       CALL DTBSV( 'U', '/', 'N', 0, 0, A, 1, X, 1 )
2497       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2498       INFOT = 3
2499       CALL DTBSV( 'U', 'N', '/', 0, 0, A, 1, X, 1 )
2500       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2501       INFOT = 4
2502       CALL DTBSV( 'U', 'N', 'N', -1, 0, A, 1, X, 1 )
2503       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2504       INFOT = 5
2505       CALL DTBSV( 'U', 'N', 'N', 0, -1, A, 1, X, 1 )
2506       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2507       INFOT = 7
2508       CALL DTBSV( 'U', 'N', 'N', 0, 1, A, 1, X, 1 )
2509       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2510       INFOT = 9
2511       CALL DTBSV( 'U', 'N', 'N', 0, 0, A, 1, X, 0 )
2512       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2513       GO TO 170
2514   110 INFOT = 1
2515       CALL DTPSV( '/', 'N', 'N', 0, A, X, 1 )
2516       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2517       INFOT = 2
2518       CALL DTPSV( 'U', '/', 'N', 0, A, X, 1 )
2519       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2520       INFOT = 3
2521       CALL DTPSV( 'U', 'N', '/', 0, A, X, 1 )
2522       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2523       INFOT = 4
2524       CALL DTPSV( 'U', 'N', 'N', -1, A, X, 1 )
2525       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2526       INFOT = 7
2527       CALL DTPSV( 'U', 'N', 'N', 0, A, X, 0 )
2528       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2529       GO TO 170
2530   120 INFOT = 1
2531       CALL DGER( -1, 0, ALPHA, X, 1, Y, 1, A, 1 )
2532       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2533       INFOT = 2
2534       CALL DGER( 0, -1, ALPHA, X, 1, Y, 1, A, 1 )
2535       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2536       INFOT = 5
2537       CALL DGER( 0, 0, ALPHA, X, 0, Y, 1, A, 1 )
2538       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2539       INFOT = 7
2540       CALL DGER( 0, 0, ALPHA, X, 1, Y, 0, A, 1 )
2541       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2542       INFOT = 9
2543       CALL DGER( 2, 0, ALPHA, X, 1, Y, 1, A, 1 )
2544       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2545       GO TO 170
2546   130 INFOT = 1
2547       CALL DSYR( '/', 0, ALPHA, X, 1, A, 1 )
2548       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2549       INFOT = 2
2550       CALL DSYR( 'U', -1, ALPHA, X, 1, A, 1 )
2551       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2552       INFOT = 5
2553       CALL DSYR( 'U', 0, ALPHA, X, 0, A, 1 )
2554       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2555       INFOT = 7
2556       CALL DSYR( 'U', 2, ALPHA, X, 1, A, 1 )
2557       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2558       GO TO 170
2559   140 INFOT = 1
2560       CALL DSPR( '/', 0, ALPHA, X, 1, A )
2561       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2562       INFOT = 2
2563       CALL DSPR( 'U', -1, ALPHA, X, 1, A )
2564       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2565       INFOT = 5
2566       CALL DSPR( 'U', 0, ALPHA, X, 0, A )
2567       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2568       GO TO 170
2569   150 INFOT = 1
2570       CALL DSYR2( '/', 0, ALPHA, X, 1, Y, 1, A, 1 )
2571       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2572       INFOT = 2
2573       CALL DSYR2( 'U', -1, ALPHA, X, 1, Y, 1, A, 1 )
2574       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2575       INFOT = 5
2576       CALL DSYR2( 'U', 0, ALPHA, X, 0, Y, 1, A, 1 )
2577       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2578       INFOT = 7
2579       CALL DSYR2( 'U', 0, ALPHA, X, 1, Y, 0, A, 1 )
2580       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2581       INFOT = 9
2582       CALL DSYR2( 'U', 2, ALPHA, X, 1, Y, 1, A, 1 )
2583       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2584       GO TO 170
2585   160 INFOT = 1
2586       CALL DSPR2( '/', 0, ALPHA, X, 1, Y, 1, A )
2587       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2588       INFOT = 2
2589       CALL DSPR2( 'U', -1, ALPHA, X, 1, Y, 1, A )
2590       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2591       INFOT = 5
2592       CALL DSPR2( 'U', 0, ALPHA, X, 0, Y, 1, A )
2593       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2594       INFOT = 7
2595       CALL DSPR2( 'U', 0, ALPHA, X, 1, Y, 0, A )
2596       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2597 *
2598   170 IF( OK )THEN
2599          WRITE( NOUT, FMT = 9999 )SRNAMT
2600       ELSE
2601          WRITE( NOUT, FMT = 9998 )SRNAMT
2602       END IF
2603       RETURN
2604 *
2605  9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' )
2606  9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****',
2607      $      '**' )
2608 *
2609 *     End of DCHKE.
2610 *
2611       END
2612       SUBROUTINE DMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL,
2613      $                  KU, RESET, TRANSL )
2614 *
2615 *  Generates values for an M by N matrix A within the bandwidth
2616 *  defined by KL and KU.
2617 *  Stores the values in the array AA in the data structure required
2618 *  by the routine, with unwanted elements set to rogue value.
2619 *
2620 *  TYPE is 'GE', 'GB', 'SY', 'SB', 'SP', 'TR', 'TB' OR 'TP'.
2621 *
2622 *  Auxiliary routine for test program for Level 2 Blas.
2623 *
2624 *  -- Written on 10-August-1987.
2625 *     Richard Hanson, Sandia National Labs.
2626 *     Jeremy Du Croz, NAG Central Office.
2627 *
2628 *     .. Parameters ..
2629       DOUBLE PRECISION   ZERO, ONE
2630       PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
2631       DOUBLE PRECISION   ROGUE
2632       PARAMETER          ( ROGUE = -1.0D10 )
2633 *     .. Scalar Arguments ..
2634       DOUBLE PRECISION   TRANSL
2635       INTEGER            KL, KU, LDA, M, N, NMAX
2636       LOGICAL            RESET
2637       CHARACTER*1        DIAG, UPLO
2638       CHARACTER*2        TYPE
2639 *     .. Array Arguments ..
2640       DOUBLE PRECISION   A( NMAX, * ), AA( * )
2641 *     .. Local Scalars ..
2642       INTEGER            I, I1, I2, I3, IBEG, IEND, IOFF, J, KK
2643       LOGICAL            GEN, LOWER, SYM, TRI, UNIT, UPPER
2644 *     .. External Functions ..
2645       DOUBLE PRECISION   DBEG
2646       EXTERNAL           DBEG
2647 *     .. Intrinsic Functions ..
2648       INTRINSIC          MAX, MIN
2649 *     .. Executable Statements ..
2650       GEN = TYPE( 1: 1 ).EQ.'G'
2651       SYM = TYPE( 1: 1 ).EQ.'S'
2652       TRI = TYPE( 1: 1 ).EQ.'T'
2653       UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U'
2654       LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L'
2655       UNIT = TRI.AND.DIAG.EQ.'U'
2656 *
2657 *     Generate data in array A.
2658 *
2659       DO 20 J = 1, N
2660          DO 10 I = 1, M
2661             IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) )
2662      $          THEN
2663                IF( ( I.LE.J.AND.J - I.LE.KU ).OR.
2664      $             ( I.GE.J.AND.I - J.LE.KL ) )THEN
2665                   A( I, J ) = DBEG( RESET ) + TRANSL
2666                ELSE
2667                   A( I, J ) = ZERO
2668                END IF
2669                IF( I.NE.J )THEN
2670                   IF( SYM )THEN
2671                      A( J, I ) = A( I, J )
2672                   ELSE IF( TRI )THEN
2673                      A( J, I ) = ZERO
2674                   END IF
2675                END IF
2676             END IF
2677    10    CONTINUE
2678          IF( TRI )
2679      $      A( J, J ) = A( J, J ) + ONE
2680          IF( UNIT )
2681      $      A( J, J ) = ONE
2682    20 CONTINUE
2683 *
2684 *     Store elements in array AS in data structure required by routine.
2685 *
2686       IF( TYPE.EQ.'GE' )THEN
2687          DO 50 J = 1, N
2688             DO 30 I = 1, M
2689                AA( I + ( J - 1 )*LDA ) = A( I, J )
2690    30       CONTINUE
2691             DO 40 I = M + 1, LDA
2692                AA( I + ( J - 1 )*LDA ) = ROGUE
2693    40       CONTINUE
2694    50    CONTINUE
2695       ELSE IF( TYPE.EQ.'GB' )THEN
2696          DO 90 J = 1, N
2697             DO 60 I1 = 1, KU + 1 - J
2698                AA( I1 + ( J - 1 )*LDA ) = ROGUE
2699    60       CONTINUE
2700             DO 70 I2 = I1, MIN( KL + KU + 1, KU + 1 + M - J )
2701                AA( I2 + ( J - 1 )*LDA ) = A( I2 + J - KU - 1, J )
2702    70       CONTINUE
2703             DO 80 I3 = I2, LDA
2704                AA( I3 + ( J - 1 )*LDA ) = ROGUE
2705    80       CONTINUE
2706    90    CONTINUE
2707       ELSE IF( TYPE.EQ.'SY'.OR.TYPE.EQ.'TR' )THEN
2708          DO 130 J = 1, N
2709             IF( UPPER )THEN
2710                IBEG = 1
2711                IF( UNIT )THEN
2712                   IEND = J - 1
2713                ELSE
2714                   IEND = J
2715                END IF
2716             ELSE
2717                IF( UNIT )THEN
2718                   IBEG = J + 1
2719                ELSE
2720                   IBEG = J
2721                END IF
2722                IEND = N
2723             END IF
2724             DO 100 I = 1, IBEG - 1
2725                AA( I + ( J - 1 )*LDA ) = ROGUE
2726   100       CONTINUE
2727             DO 110 I = IBEG, IEND
2728                AA( I + ( J - 1 )*LDA ) = A( I, J )
2729   110       CONTINUE
2730             DO 120 I = IEND + 1, LDA
2731                AA( I + ( J - 1 )*LDA ) = ROGUE
2732   120       CONTINUE
2733   130    CONTINUE
2734       ELSE IF( TYPE.EQ.'SB'.OR.TYPE.EQ.'TB' )THEN
2735          DO 170 J = 1, N
2736             IF( UPPER )THEN
2737                KK = KL + 1
2738                IBEG = MAX( 1, KL + 2 - J )
2739                IF( UNIT )THEN
2740                   IEND = KL
2741                ELSE
2742                   IEND = KL + 1
2743                END IF
2744             ELSE
2745                KK = 1
2746                IF( UNIT )THEN
2747                   IBEG = 2
2748                ELSE
2749                   IBEG = 1
2750                END IF
2751                IEND = MIN( KL + 1, 1 + M - J )
2752             END IF
2753             DO 140 I = 1, IBEG - 1
2754                AA( I + ( J - 1 )*LDA ) = ROGUE
2755   140       CONTINUE
2756             DO 150 I = IBEG, IEND
2757                AA( I + ( J - 1 )*LDA ) = A( I + J - KK, J )
2758   150       CONTINUE
2759             DO 160 I = IEND + 1, LDA
2760                AA( I + ( J - 1 )*LDA ) = ROGUE
2761   160       CONTINUE
2762   170    CONTINUE
2763       ELSE IF( TYPE.EQ.'SP'.OR.TYPE.EQ.'TP' )THEN
2764          IOFF = 0
2765          DO 190 J = 1, N
2766             IF( UPPER )THEN
2767                IBEG = 1
2768                IEND = J
2769             ELSE
2770                IBEG = J
2771                IEND = N
2772             END IF
2773             DO 180 I = IBEG, IEND
2774                IOFF = IOFF + 1
2775                AA( IOFF ) = A( I, J )
2776                IF( I.EQ.J )THEN
2777                   IF( UNIT )
2778      $               AA( IOFF ) = ROGUE
2779                END IF
2780   180       CONTINUE
2781   190    CONTINUE
2782       END IF
2783       RETURN
2784 *
2785 *     End of DMAKE.
2786 *
2787       END
2788       SUBROUTINE DMVCH( TRANS, M, N, ALPHA, A, NMAX, X, INCX, BETA, Y,
2789      $                  INCY, YT, G, YY, EPS, ERR, FATAL, NOUT, MV )
2790 *
2791 *  Checks the results of the computational tests.
2792 *
2793 *  Auxiliary routine for test program for Level 2 Blas.
2794 *
2795 *  -- Written on 10-August-1987.
2796 *     Richard Hanson, Sandia National Labs.
2797 *     Jeremy Du Croz, NAG Central Office.
2798 *
2799 *     .. Parameters ..
2800       DOUBLE PRECISION   ZERO, ONE
2801       PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
2802 *     .. Scalar Arguments ..
2803       DOUBLE PRECISION   ALPHA, BETA, EPS, ERR
2804       INTEGER            INCX, INCY, M, N, NMAX, NOUT
2805       LOGICAL            FATAL, MV
2806       CHARACTER*1        TRANS
2807 *     .. Array Arguments ..
2808       DOUBLE PRECISION   A( NMAX, * ), G( * ), X( * ), Y( * ), YT( * ),
2809      $                   YY( * )
2810 *     .. Local Scalars ..
2811       DOUBLE PRECISION   ERRI
2812       INTEGER            I, INCXL, INCYL, IY, J, JX, KX, KY, ML, NL
2813       LOGICAL            TRAN
2814 *     .. Intrinsic Functions ..
2815       INTRINSIC          ABS, MAX, SQRT
2816 *     .. Executable Statements ..
2817       TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C'
2818       IF( TRAN )THEN
2819          ML = N
2820          NL = M
2821       ELSE
2822          ML = M
2823          NL = N
2824       END IF
2825       IF( INCX.LT.0 )THEN
2826          KX = NL
2827          INCXL = -1
2828       ELSE
2829          KX = 1
2830          INCXL = 1
2831       END IF
2832       IF( INCY.LT.0 )THEN
2833          KY = ML
2834          INCYL = -1
2835       ELSE
2836          KY = 1
2837          INCYL = 1
2838       END IF
2839 *
2840 *     Compute expected result in YT using data in A, X and Y.
2841 *     Compute gauges in G.
2842 *
2843       IY = KY
2844       DO 30 I = 1, ML
2845          YT( IY ) = ZERO
2846          G( IY ) = ZERO
2847          JX = KX
2848          IF( TRAN )THEN
2849             DO 10 J = 1, NL
2850                YT( IY ) = YT( IY ) + A( J, I )*X( JX )
2851                G( IY ) = G( IY ) + ABS( A( J, I )*X( JX ) )
2852                JX = JX + INCXL
2853    10       CONTINUE
2854          ELSE
2855             DO 20 J = 1, NL
2856                YT( IY ) = YT( IY ) + A( I, J )*X( JX )
2857                G( IY ) = G( IY ) + ABS( A( I, J )*X( JX ) )
2858                JX = JX + INCXL
2859    20       CONTINUE
2860          END IF
2861          YT( IY ) = ALPHA*YT( IY ) + BETA*Y( IY )
2862          G( IY ) = ABS( ALPHA )*G( IY ) + ABS( BETA*Y( IY ) )
2863          IY = IY + INCYL
2864    30 CONTINUE
2865 *
2866 *     Compute the error ratio for this result.
2867 *
2868       ERR = ZERO
2869       DO 40 I = 1, ML
2870          ERRI = ABS( YT( I ) - YY( 1 + ( I - 1 )*ABS( INCY ) ) )/EPS
2871          IF( G( I ).NE.ZERO )
2872      $      ERRI = ERRI/G( I )
2873          ERR = MAX( ERR, ERRI )
2874          IF( ERR*SQRT( EPS ).GE.ONE )
2875      $      GO TO 50
2876    40 CONTINUE
2877 *     If the loop completes, all results are at least half accurate.
2878       GO TO 70
2879 *
2880 *     Report fatal error.
2881 *
2882    50 FATAL = .TRUE.
2883       WRITE( NOUT, FMT = 9999 )
2884       DO 60 I = 1, ML
2885          IF( MV )THEN
2886             WRITE( NOUT, FMT = 9998 )I, YT( I ),
2887      $         YY( 1 + ( I - 1 )*ABS( INCY ) )
2888          ELSE
2889             WRITE( NOUT, FMT = 9998 )I,
2890      $         YY( 1 + ( I - 1 )*ABS( INCY ) ), YT( I )
2891          END IF
2892    60 CONTINUE
2893 *
2894    70 CONTINUE
2895       RETURN
2896 *
2897  9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
2898      $      'F ACCURATE *******', /'           EXPECTED RESULT   COMPU',
2899      $      'TED RESULT' )
2900  9998 FORMAT( 1X, I7, 2G18.6 )
2901 *
2902 *     End of DMVCH.
2903 *
2904       END
2905       LOGICAL FUNCTION LDE( RI, RJ, LR )
2906 *
2907 *  Tests if two arrays are identical.
2908 *
2909 *  Auxiliary routine for test program for Level 2 Blas.
2910 *
2911 *  -- Written on 10-August-1987.
2912 *     Richard Hanson, Sandia National Labs.
2913 *     Jeremy Du Croz, NAG Central Office.
2914 *
2915 *     .. Scalar Arguments ..
2916       INTEGER            LR
2917 *     .. Array Arguments ..
2918       DOUBLE PRECISION   RI( * ), RJ( * )
2919 *     .. Local Scalars ..
2920       INTEGER            I
2921 *     .. Executable Statements ..
2922       DO 10 I = 1, LR
2923          IF( RI( I ).NE.RJ( I ) )
2924      $      GO TO 20
2925    10 CONTINUE
2926       LDE = .TRUE.
2927       GO TO 30
2928    20 CONTINUE
2929       LDE = .FALSE.
2930    30 RETURN
2931 *
2932 *     End of LDE.
2933 *
2934       END
2935       LOGICAL FUNCTION LDERES( TYPE, UPLO, M, N, AA, AS, LDA )
2936 *
2937 *  Tests if selected elements in two arrays are equal.
2938 *
2939 *  TYPE is 'GE', 'SY' or 'SP'.
2940 *
2941 *  Auxiliary routine for test program for Level 2 Blas.
2942 *
2943 *  -- Written on 10-August-1987.
2944 *     Richard Hanson, Sandia National Labs.
2945 *     Jeremy Du Croz, NAG Central Office.
2946 *
2947 *     .. Scalar Arguments ..
2948       INTEGER            LDA, M, N
2949       CHARACTER*1        UPLO
2950       CHARACTER*2        TYPE
2951 *     .. Array Arguments ..
2952       DOUBLE PRECISION   AA( LDA, * ), AS( LDA, * )
2953 *     .. Local Scalars ..
2954       INTEGER            I, IBEG, IEND, J
2955       LOGICAL            UPPER
2956 *     .. Executable Statements ..
2957       UPPER = UPLO.EQ.'U'
2958       IF( TYPE.EQ.'GE' )THEN
2959          DO 20 J = 1, N
2960             DO 10 I = M + 1, LDA
2961                IF( AA( I, J ).NE.AS( I, J ) )
2962      $            GO TO 70
2963    10       CONTINUE
2964    20    CONTINUE
2965       ELSE IF( TYPE.EQ.'SY' )THEN
2966          DO 50 J = 1, N
2967             IF( UPPER )THEN
2968                IBEG = 1
2969                IEND = J
2970             ELSE
2971                IBEG = J
2972                IEND = N
2973             END IF
2974             DO 30 I = 1, IBEG - 1
2975                IF( AA( I, J ).NE.AS( I, J ) )
2976      $            GO TO 70
2977    30       CONTINUE
2978             DO 40 I = IEND + 1, LDA
2979                IF( AA( I, J ).NE.AS( I, J ) )
2980      $            GO TO 70
2981    40       CONTINUE
2982    50    CONTINUE
2983       END IF
2984 *
2985    60 CONTINUE
2986       LDERES = .TRUE.
2987       GO TO 80
2988    70 CONTINUE
2989       LDERES = .FALSE.
2990    80 RETURN
2991 *
2992 *     End of LDERES.
2993 *
2994       END
2995       DOUBLE PRECISION FUNCTION DBEG( RESET )
2996 *
2997 *  Generates random numbers uniformly distributed between -0.5 and 0.5.
2998 *
2999 *  Auxiliary routine for test program for Level 2 Blas.
3000 *
3001 *  -- Written on 10-August-1987.
3002 *     Richard Hanson, Sandia National Labs.
3003 *     Jeremy Du Croz, NAG Central Office.
3004 *
3005 *     .. Scalar Arguments ..
3006       LOGICAL            RESET
3007 *     .. Local Scalars ..
3008       INTEGER            I, IC, MI
3009 *     .. Save statement ..
3010       SAVE               I, IC, MI
3011 *     .. Intrinsic Functions ..
3012       INTRINSIC          DBLE
3013 *     .. Executable Statements ..
3014       IF( RESET )THEN
3015 *        Initialize local variables.
3016          MI = 891
3017          I = 7
3018          IC = 0
3019          RESET = .FALSE.
3020       END IF
3021 *
3022 *     The sequence of values of I is bounded between 1 and 999.
3023 *     If initial I = 1,2,3,6,7 or 9, the period will be 50.
3024 *     If initial I = 4 or 8, the period will be 25.
3025 *     If initial I = 5, the period will be 10.
3026 *     IC is used to break up the period by skipping 1 value of I in 6.
3027 *
3028       IC = IC + 1
3029    10 I = I*MI
3030       I = I - 1000*( I/1000 )
3031       IF( IC.GE.5 )THEN
3032          IC = 0
3033          GO TO 10
3034       END IF
3035       DBEG = DBLE( I - 500 )/1001.0D0
3036       RETURN
3037 *
3038 *     End of DBEG.
3039 *
3040       END
3041       DOUBLE PRECISION FUNCTION DDIFF( X, Y )
3042 *
3043 *  Auxiliary routine for test program for Level 2 Blas.
3044 *
3045 *  -- Written on 10-August-1987.
3046 *     Richard Hanson, Sandia National Labs.
3047 *
3048 *     .. Scalar Arguments ..
3049       DOUBLE PRECISION   X, Y
3050 *     .. Executable Statements ..
3051       DDIFF = X - Y
3052       RETURN
3053 *
3054 *     End of DDIFF.
3055 *
3056       END
3057       SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
3058 *
3059 *  Tests whether XERBLA has detected an error when it should.
3060 *
3061 *  Auxiliary routine for test program for Level 2 Blas.
3062 *
3063 *  -- Written on 10-August-1987.
3064 *     Richard Hanson, Sandia National Labs.
3065 *     Jeremy Du Croz, NAG Central Office.
3066 *
3067 *     .. Scalar Arguments ..
3068       INTEGER            INFOT, NOUT
3069       LOGICAL            LERR, OK
3070       CHARACTER*6        SRNAMT
3071 *     .. Executable Statements ..
3072       IF( .NOT.LERR )THEN
3073          WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT
3074          OK = .FALSE.
3075       END IF
3076       LERR = .FALSE.
3077       RETURN
3078 *
3079  9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D',
3080      $      'ETECTED BY ', A6, ' *****' )
3081 *
3082 *     End of CHKXER.
3083 *
3084       END
3085       SUBROUTINE XERBLA( SRNAME, INFO )
3086 *
3087 *  This is a special version of XERBLA to be used only as part of
3088 *  the test program for testing error exits from the Level 2 BLAS
3089 *  routines.
3090 *
3091 *  XERBLA  is an error handler for the Level 2 BLAS routines.
3092 *
3093 *  It is called by the Level 2 BLAS routines if an input parameter is
3094 *  invalid.
3095 *
3096 *  Auxiliary routine for test program for Level 2 Blas.
3097 *
3098 *  -- Written on 10-August-1987.
3099 *     Richard Hanson, Sandia National Labs.
3100 *     Jeremy Du Croz, NAG Central Office.
3101 *
3102 *     .. Scalar Arguments ..
3103       INTEGER            INFO
3104       CHARACTER*6        SRNAME
3105 *     .. Scalars in Common ..
3106       INTEGER            INFOT, NOUT
3107       LOGICAL            LERR, OK
3108       CHARACTER*6        SRNAMT
3109 *     .. Common blocks ..
3110       COMMON             /INFOC/INFOT, NOUT, OK, LERR
3111       COMMON             /SRNAMC/SRNAMT
3112 *     .. Executable Statements ..
3113       LERR = .TRUE.
3114       IF( INFO.NE.INFOT )THEN
3115          IF( INFOT.NE.0 )THEN
3116             WRITE( NOUT, FMT = 9999 )INFO, INFOT
3117          ELSE
3118             WRITE( NOUT, FMT = 9997 )INFO
3119          END IF
3120          OK = .FALSE.
3121       END IF
3122       IF( SRNAME.NE.SRNAMT )THEN
3123          WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT
3124          OK = .FALSE.
3125       END IF
3126       RETURN
3127 *
3128  9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, ' INSTEAD',
3129      $      ' OF ', I2, ' *******' )
3130  9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A6, ' INSTE',
3131      $      'AD OF ', A6, ' *******' )
3132  9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6,
3133      $      ' *******' )
3134 *
3135 *     End of XERBLA
3136 *
3137       END
3138