test/sblat2.f

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