Context Navigation

sblat2.f

Last change on this file was 136, checked in by ldecherf, 8 years ago
Doc
File size: 108.7 KB

Line
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( NMAXINCMAX ), Z( 2NMAX )
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( NMAXINCMAX ), XX( NMAXINCMAX ),
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( NMAXINCMAX ), XX( NMAXINCMAX ),
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( NMAXINCMAX ), XX( NMAXINCMAX ),
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 ) = ALPHAYT( IY ) + BETAY( IY )
2862	G( IY ) = ABS( ALPHA )G( IY ) + ABS( BETAY( 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

Note: See TracBrowser for help on using the repository browser.

Context Navigation

source: pacpussensors/trunk/Vislab/lib3dv-1.2.0/lib3dv/eigen/blas/testing/sblat2.f

Download in other formats: