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