LAPACK: BLAS/TESTING/sblat2.f Source File

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