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