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