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