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