Gitiles
Code Review Sign In
realtimeroboticsgroup.org / RealtimeRoboticsGroup / test / 72890c2da170577883e6431bd92d612716a31b85 / . / blas / testing / sblat3.f
blob: 325a9eb927b9bb7ccbc70957408d7e2714d2390c [file] [log] [blame]
Brian Silverman72890c22015-09-19 14:37:37 -0400[diff] [blame^]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( NMAX*NMAX ), AB( NMAX, 2*NMAX ),
67 $ ALF( NALMAX ), AS( NMAX*NMAX ),
68 $ BB( NMAX*NMAX ), BET( NBEMAX ),
69 $ BS( NMAX*NMAX ), C( NMAX, NMAX ),
70 $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), 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( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
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( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
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( NMAX*NMAX ), BS( NMAX*NMAX ),
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( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
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( NMAX*NMAX ), AB( 2*NMAX*NMAX ),
1511 $ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ),
1512 $ BET( NBET ), BS( NMAX*NMAX ), C( NMAX, NMAX ),
1513 $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), 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 )*2*NMAX + K +
1711 $ I )
1712 W( K + I ) = AB( ( J - 1 )*2*NMAX +
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 ) = ALPHA*CT( I ) + BETA*C( 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