Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

source: pacpussensors/trunk/Vislab/lib3dv/eigen/blas/testing/sblat3.f@ 137

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

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

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

Download in other formats: