96 parameter( nsubs = 6 )
98 parameter( zero = 0.0, one = 1.0 )
100 parameter( nmax = 65 )
101 INTEGER NIDMAX, NALMAX, NBEMAX
102 parameter( nidmax = 9, nalmax = 7, nbemax = 7 )
104 REAL EPS, ERR, THRESH
105 INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NOUT, NTRA
106 LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE,
108 CHARACTER*1 TRANSA, TRANSB
110 CHARACTER*32 SNAPS, SUMMRY
112 REAL AA( nmax*nmax ), AB( nmax, 2*nmax ),
113 $ alf( nalmax ), as( nmax*nmax ),
114 $ bb( nmax*nmax ), bet( nbemax ),
115 $ bs( nmax*nmax ), c( nmax, nmax ),
116 $ cc( nmax*nmax ), cs( nmax*nmax ), ct( nmax ),
117 $ g( nmax ), w( 2*nmax )
118 INTEGER IDIM( nidmax )
119 LOGICAL LTEST( nsubs )
120 CHARACTER*6 SNAMES( nsubs )
134 COMMON /infoc/infot, noutc, ok, lerr
135 COMMON /srnamc/srnamt
137 DATA snames/
'SGEMM ',
'SSYMM ',
'STRMM ',
'STRSM ',
138 $
'SSYRK ',
'SSYR2K'/
143 READ( nin, fmt = * )summry
144 READ( nin, fmt = * )nout
145 OPEN( nout, file = summry )
150 READ( nin, fmt = * )snaps
151 READ( nin, fmt = * )ntra
154 OPEN( ntra, file = snaps )
157 READ( nin, fmt = * )rewi
158 rewi = rewi.AND.trace
160 READ( nin, fmt = * )sfatal
162 READ( nin, fmt = * )tsterr
164 READ( nin, fmt = * )thresh
169 READ( nin, fmt = * )nidim
170 IF( nidim.LT.1.OR.nidim.GT.nidmax )
THEN
171 WRITE( nout, fmt = 9997 )
'N', nidmax
174 READ( nin, fmt = * )( idim( i ), i = 1, nidim )
176 IF( idim( i ).LT.0.OR.idim( i ).GT.nmax )
THEN
177 WRITE( nout, fmt = 9996 )nmax
182 READ( nin, fmt = * )nalf
183 IF( nalf.LT.1.OR.nalf.GT.nalmax )
THEN
184 WRITE( nout, fmt = 9997 )
'ALPHA', nalmax
187 READ( nin, fmt = * )( alf( i ), i = 1, nalf )
189 READ( nin, fmt = * )nbet
190 IF( nbet.LT.1.OR.nbet.GT.nbemax )
THEN
191 WRITE( nout, fmt = 9997 )
'BETA', nbemax
194 READ( nin, fmt = * )( bet( i ), i = 1, nbet )
198 WRITE( nout, fmt = 9995 )
199 WRITE( nout, fmt = 9994 )( idim( i ), i = 1, nidim )
200 WRITE( nout, fmt = 9993 )( alf( i ), i = 1, nalf )
201 WRITE( nout, fmt = 9992 )( bet( i ), i = 1, nbet )
202 IF( .NOT.tsterr )
THEN
203 WRITE( nout, fmt = * )
204 WRITE( nout, fmt = 9984 )
206 WRITE( nout, fmt = * )
207 WRITE( nout, fmt = 9999 )thresh
208 WRITE( nout, fmt = * )
216 30
READ( nin, fmt = 9988,
END = 60 )snamet, ltestt
218 IF( snamet.EQ.snames( i ) )
221 WRITE( nout, fmt = 9990 )snamet
223 50 ltest( i ) = ltestt
232 WRITE( nout, fmt = 9998 )eps
239 ab( i, j ) = max( i - j + 1, 0 )
241 ab( j, nmax + 1 ) = j
242 ab( 1, nmax + j ) = j
246 cc( j ) = j*( ( j + 1 )*j )/2 - ( ( j + 1 )*j*( j - 1 ) )/3
252 CALL
smmch( transa, transb, n, 1, n, one, ab, nmax,
253 $ ab( 1, nmax + 1 ), nmax, zero, c, nmax, ct, g, cc,
254 $ nmax, eps, err, fatal, nout, .true. )
255 same = lse( cc, ct, n )
256 IF( .NOT.same.OR.err.NE.zero )
THEN
257 WRITE( nout, fmt = 9989 )transa, transb, same, err
261 CALL
smmch( transa, transb, n, 1, n, one, ab, nmax,
262 $ ab( 1, nmax + 1 ), nmax, zero, c, nmax, ct, g, cc,
263 $ nmax, eps, err, fatal, nout, .true. )
264 same = lse( cc, ct, n )
265 IF( .NOT.same.OR.err.NE.zero )
THEN
266 WRITE( nout, fmt = 9989 )transa, transb, same, err
270 ab( j, nmax + 1 ) = n - j + 1
271 ab( 1, nmax + j ) = n - j + 1
274 cc( n - j + 1 ) = j*( ( j + 1 )*j )/2 -
275 $ ( ( j + 1 )*j*( j - 1 ) )/3
279 CALL
smmch( transa, transb, n, 1, n, one, ab, nmax,
280 $ ab( 1, nmax + 1 ), nmax, zero, c, nmax, ct, g, cc,
281 $ nmax, eps, err, fatal, nout, .true. )
282 same = lse( cc, ct, n )
283 IF( .NOT.same.OR.err.NE.zero )
THEN
284 WRITE( nout, fmt = 9989 )transa, transb, same, err
288 CALL
smmch( transa, transb, n, 1, n, one, ab, nmax,
289 $ ab( 1, nmax + 1 ), nmax, zero, c, nmax, ct, g, cc,
290 $ nmax, eps, err, fatal, nout, .true. )
291 same = lse( cc, ct, n )
292 IF( .NOT.same.OR.err.NE.zero )
THEN
293 WRITE( nout, fmt = 9989 )transa, transb, same, err
299 DO 200 isnum = 1, nsubs
300 WRITE( nout, fmt = * )
301 IF( .NOT.ltest( isnum ) )
THEN
303 WRITE( nout, fmt = 9987 )snames( isnum )
305 srnamt = snames( isnum )
308 CALL
schke( isnum, snames( isnum ), nout )
309 WRITE( nout, fmt = * )
315 go to( 140, 150, 160, 160, 170, 180 )isnum
317 140 CALL
schk1( snames( isnum ), eps, thresh, nout, ntra, trace,
318 $ rewi, fatal, nidim, idim, nalf, alf, nbet, bet,
319 $ nmax, ab, aa, as, ab( 1, nmax + 1 ), bb, bs, c,
323 150 CALL
schk2( snames( isnum ), eps, thresh, nout, ntra, trace,
324 $ rewi, fatal, nidim, idim, nalf, alf, nbet, bet,
325 $ nmax, ab, aa, as, ab( 1, nmax + 1 ), bb, bs, c,
329 160 CALL
schk3( snames( isnum ), eps, thresh, nout, ntra, trace,
330 $ rewi, fatal, nidim, idim, nalf, alf, nmax, ab,
331 $ aa, as, ab( 1, nmax + 1 ), bb, bs, ct, g, c )
334 170 CALL
schk4( snames( isnum ), eps, thresh, nout, ntra, trace,
335 $ rewi, fatal, nidim, idim, nalf, alf, nbet, bet,
336 $ nmax, ab, aa, as, ab( 1, nmax + 1 ), bb, bs, c,
340 180 CALL
schk5( snames( isnum ), eps, thresh, nout, ntra, trace,
341 $ rewi, fatal, nidim, idim, nalf, alf, nbet, bet,
342 $ nmax, ab, aa, as, bb, bs, c, cc, cs, ct, g, w )
345 190
IF( fatal.AND.sfatal )
349 WRITE( nout, fmt = 9986 )
353 WRITE( nout, fmt = 9985 )
357 WRITE( nout, fmt = 9991 )
365 9999
FORMAT(
' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES',
367 9998
FORMAT(
' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1p, e9.1 )
368 9997
FORMAT(
' NUMBER OF VALUES OF ', a,
' IS LESS THAN 1 OR GREATER ',
370 9996
FORMAT(
' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', i2 )
371 9995
FORMAT(
' TESTS OF THE REAL LEVEL 3 BLAS', //
' THE F',
372 $
'OLLOWING PARAMETER VALUES WILL BE USED:' )
373 9994
FORMAT(
' FOR N ', 9i6 )
374 9993
FORMAT(
' FOR ALPHA ', 7f6.1 )
375 9992
FORMAT(
' FOR BETA ', 7f6.1 )
376 9991
FORMAT(
' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM',
377 $ /
' ******* TESTS ABANDONED *******' )
378 9990
FORMAT(
' SUBPROGRAM NAME ', a6,
' NOT RECOGNIZED', /
' ******* T',
379 $
'ESTS ABANDONED *******' )
380 9989
FORMAT(
' ERROR IN SMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALU',
381 $
'ATED WRONGLY.', /
' SMMCH WAS CALLED WITH TRANSA = ', a1,
382 $
' AND TRANSB = ', a1, /
' AND RETURNED SAME = ', l1,
' AND ',
383 $
'ERR = ', f12.3,
'.', /
' THIS MAY BE DUE TO FAULTS IN THE ',
384 $
'ARITHMETIC OR THE COMPILER.', /
' ******* TESTS ABANDONED ',
386 9988
FORMAT( a6, l2 )
387 9987
FORMAT( 1x, a6,
' WAS NOT TESTED' )
388 9986
FORMAT( /
' END OF TESTS' )
389 9985
FORMAT( /
' ******* FATAL ERROR - TESTS ABANDONED *******' )
390 9984
FORMAT(
' ERROR-EXITS WILL NOT BE TESTED' )
395 SUBROUTINE schk1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
396 $ fatal, nidim, idim, nalf, alf, nbet, bet, nmax,
397 $ a, aa, as, b, bb, bs, c, cc, cs, ct, g )
411 parameter( zero = 0.0 )
414 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
415 LOGICAL FATAL, REWI, TRACE
418 REAL A( nmax, nmax ), AA( nmax*nmax ), ALF( nalf ),
419 $ as( nmax*nmax ), b( nmax, nmax ),
420 $ bb( nmax*nmax ), bet( nbet ), bs( nmax*nmax ),
421 $ c( nmax, nmax ), cc( nmax*nmax ),
422 $ cs( nmax*nmax ), ct( nmax ), g( nmax )
423 INTEGER IDIM( nidim )
425 REAL ALPHA, ALS, BETA, BLS, ERR, ERRMAX
426 INTEGER I, IA, IB, ICA, ICB, IK, IM, IN, K, KS, LAA,
427 $ lbb, lcc, lda, ldas, ldb, ldbs, ldc, ldcs, m,
428 $ ma, mb, ms, n, na, nargs, nb, nc, ns
429 LOGICAL NULL, RESET, SAME, TRANA, TRANB
430 CHARACTER*1 TRANAS, TRANBS, TRANSA, TRANSB
445 COMMON /infoc/infot, noutc, ok, lerr
468 null = n.LE.0.OR.m.LE.0
474 transa = ich( ica: ica )
475 trana = transa.EQ.
'T'.OR.transa.EQ.
'C'
495 CALL
smake(
'GE',
' ',
' ', ma, na, a, nmax, aa, lda,
499 transb = ich( icb: icb )
500 tranb = transb.EQ.
'T'.OR.transb.EQ.
'C'
520 CALL
smake(
'GE',
' ',
' ', mb, nb, b, nmax, bb,
531 CALL
smake(
'GE',
' ',
' ', m, n, c, nmax,
532 $ cc, ldc, reset, zero )
562 $
WRITE( ntra, fmt = 9995 )nc, sname,
563 $ transa, transb, m, n, k, alpha, lda, ldb,
567 CALL
sgemm( transa, transb, m, n, k, alpha,
568 $ aa, lda, bb, ldb, beta, cc, ldc )
573 WRITE( nout, fmt = 9994 )
580 isame( 1 ) = transa.EQ.tranas
581 isame( 2 ) = transb.EQ.tranbs
585 isame( 6 ) = als.EQ.alpha
586 isame( 7 ) = lse( as, aa, laa )
587 isame( 8 ) = ldas.EQ.lda
588 isame( 9 ) = lse( bs, bb, lbb )
589 isame( 10 ) = ldbs.EQ.ldb
590 isame( 11 ) = bls.EQ.beta
592 isame( 12 ) = lse( cs, cc, lcc )
594 isame( 12 ) = lseres(
'GE',
' ', m, n, cs,
597 isame( 13 ) = ldcs.EQ.ldc
604 same = same.AND.isame( i )
605 IF( .NOT.isame( i ) )
606 $
WRITE( nout, fmt = 9998 )i
617 CALL
smmch( transa, transb, m, n, k,
618 $ alpha, a, nmax, b, nmax, beta,
619 $ c, nmax, ct, g, cc, ldc, eps,
620 $ err, fatal, nout, .true. )
621 errmax = max( errmax, err )
644 IF( errmax.LT.thresh )
THEN
645 WRITE( nout, fmt = 9999 )sname, nc
647 WRITE( nout, fmt = 9997 )sname, nc, errmax
652 WRITE( nout, fmt = 9996 )sname
653 WRITE( nout, fmt = 9995 )nc, sname, transa, transb, m, n, k,
654 $ alpha, lda, ldb, beta, ldc
659 9999
FORMAT(
' ', a6,
' PASSED THE COMPUTATIONAL TESTS (', i6,
' CALL',
661 9998
FORMAT(
' ******* FATAL ERROR - PARAMETER NUMBER ', i2,
' WAS CH',
662 $
'ANGED INCORRECTLY *******' )
663 9997
FORMAT(
' ', a6,
' COMPLETED THE COMPUTATIONAL TESTS (', i6,
' C',
664 $
'ALLS)', /
' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
665 $
' - SUSPECT *******' )
666 9996
FORMAT(
' ******* ', a6,
' FAILED ON CALL NUMBER:' )
667 9995
FORMAT( 1x, i6,
': ', a6,
'(''', a1,
''',''', a1,
''',',
668 $ 3( i3,
',' ), f4.1,
', A,', i3,
', B,', i3,
',', f4.1,
', ',
670 9994
FORMAT(
' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
676 SUBROUTINE schk2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
677 $ fatal, nidim, idim, nalf, alf, nbet, bet, nmax,
678 $ a, aa, as, b, bb, bs, c, cc, cs, ct, g )
692 parameter( zero = 0.0 )
695 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
696 LOGICAL FATAL, REWI, TRACE
699 REAL A( nmax, nmax ), AA( nmax*nmax ), ALF( nalf ),
700 $ as( nmax*nmax ), b( nmax, nmax ),
701 $ bb( nmax*nmax ), bet( nbet ), bs( nmax*nmax ),
702 $ c( nmax, nmax ), cc( nmax*nmax ),
703 $ cs( nmax*nmax ), ct( nmax ), g( nmax )
704 INTEGER IDIM( nidim )
706 REAL ALPHA, ALS, BETA, BLS, ERR, ERRMAX
707 INTEGER I, IA, IB, ICS, ICU, IM, IN, LAA, LBB, LCC,
708 $ lda, ldas, ldb, ldbs, ldc, ldcs, m, ms, n, na,
710 LOGICAL LEFT, NULL, RESET, SAME
711 CHARACTER*1 SIDE, SIDES, UPLO, UPLOS
712 CHARACTER*2 ICHS, ICHU
726 COMMON /infoc/infot, noutc, ok, lerr
728 DATA ichs/
'LR'/, ichu/
'UL'/
749 null = n.LE.0.OR.m.LE.0
762 CALL
smake(
'GE',
' ',
' ', m, n, b, nmax, bb, ldb, reset,
766 side = ichs( ics: ics )
784 uplo = ichu( icu: icu )
788 CALL
smake(
'SY', uplo,
' ', na, na, a, nmax, aa, lda,
799 CALL
smake(
'GE',
' ',
' ', m, n, c, nmax, cc,
829 $
WRITE( ntra, fmt = 9995 )nc, sname, side,
830 $ uplo, m, n, alpha, lda, ldb, beta, ldc
833 CALL
ssymm( side, uplo, m, n, alpha, aa, lda,
834 $ bb, ldb, beta, cc, ldc )
839 WRITE( nout, fmt = 9994 )
846 isame( 1 ) = sides.EQ.side
847 isame( 2 ) = uplos.EQ.uplo
850 isame( 5 ) = als.EQ.alpha
851 isame( 6 ) = lse( as, aa, laa )
852 isame( 7 ) = ldas.EQ.lda
853 isame( 8 ) = lse( bs, bb, lbb )
854 isame( 9 ) = ldbs.EQ.ldb
855 isame( 10 ) = bls.EQ.beta
857 isame( 11 ) = lse( cs, cc, lcc )
859 isame( 11 ) = lseres(
'GE',
' ', m, n, cs,
862 isame( 12 ) = ldcs.EQ.ldc
869 same = same.AND.isame( i )
870 IF( .NOT.isame( i ) )
871 $
WRITE( nout, fmt = 9998 )i
883 CALL
smmch(
'N',
'N', m, n, m, alpha, a,
884 $ nmax, b, nmax, beta, c, nmax,
885 $ ct, g, cc, ldc, eps, err,
886 $ fatal, nout, .true. )
888 CALL
smmch(
'N',
'N', m, n, n, alpha, b,
889 $ nmax, a, nmax, beta, c, nmax,
890 $ ct, g, cc, ldc, eps, err,
891 $ fatal, nout, .true. )
893 errmax = max( errmax, err )
914 IF( errmax.LT.thresh )
THEN
915 WRITE( nout, fmt = 9999 )sname, nc
917 WRITE( nout, fmt = 9997 )sname, nc, errmax
922 WRITE( nout, fmt = 9996 )sname
923 WRITE( nout, fmt = 9995 )nc, sname, side, uplo, m, n, alpha, lda,
929 9999
FORMAT(
' ', a6,
' PASSED THE COMPUTATIONAL TESTS (', i6,
' CALL',
931 9998
FORMAT(
' ******* FATAL ERROR - PARAMETER NUMBER ', i2,
' WAS CH',
932 $
'ANGED INCORRECTLY *******' )
933 9997
FORMAT(
' ', a6,
' COMPLETED THE COMPUTATIONAL TESTS (', i6,
' C',
934 $
'ALLS)', /
' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
935 $
' - SUSPECT *******' )
936 9996
FORMAT(
' ******* ', a6,
' FAILED ON CALL NUMBER:' )
937 9995
FORMAT( 1x, i6,
': ', a6,
'(', 2(
'''', a1,
''',' ), 2( i3,
',' ),
938 $ f4.1,
', A,', i3,
', B,', i3,
',', f4.1,
', C,', i3,
') ',
940 9994
FORMAT(
' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
946 SUBROUTINE schk3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
947 $ fatal, nidim, idim, nalf, alf, nmax, a, aa, as,
948 $ b, bb, bs, ct, g, c )
962 parameter( zero = 0.0, one = 1.0 )
965 INTEGER NALF, NIDIM, NMAX, NOUT, NTRA
966 LOGICAL FATAL, REWI, TRACE
969 REAL A( nmax, nmax ), AA( nmax*nmax ), ALF( nalf ),
970 $ as( nmax*nmax ), b( nmax, nmax ),
971 $ bb( nmax*nmax ), bs( nmax*nmax ),
972 $ c( nmax, nmax ), ct( nmax ), g( nmax )
973 INTEGER IDIM( nidim )
975 REAL ALPHA, ALS, ERR, ERRMAX
976 INTEGER I, IA, ICD, ICS, ICT, ICU, IM, IN, J, LAA, LBB,
977 $ lda, ldas, ldb, ldbs, m, ms, n, na, nargs, nc,
979 LOGICAL LEFT, NULL, RESET, SAME
980 CHARACTER*1 DIAG, DIAGS, SIDE, SIDES, TRANAS, TRANSA, UPLO,
982 CHARACTER*2 ICHD, ICHS, ICHU
997 COMMON /infoc/infot, noutc, ok, lerr
999 DATA ichu/
'UL'/, icht/
'NTC'/, ichd/
'UN'/, ichs/
'LR'/
1013 DO 140 im = 1, nidim
1016 DO 130 in = 1, nidim
1026 null = m.LE.0.OR.n.LE.0
1029 side = ichs( ics: ics )
1046 uplo = ichu( icu: icu )
1049 transa = icht( ict: ict )
1052 diag = ichd( icd: icd )
1059 CALL
smake(
'TR', uplo, diag, na, na, a,
1060 $ nmax, aa, lda, reset, zero )
1064 CALL
smake(
'GE',
' ',
' ', m, n, b, nmax,
1065 $ bb, ldb, reset, zero )
1090 IF( sname( 4: 5 ).EQ.
'MM' )
THEN
1092 $
WRITE( ntra, fmt = 9995 )nc, sname,
1093 $ side, uplo, transa, diag, m, n, alpha,
1097 CALL
strmm( side, uplo, transa, diag, m,
1098 $ n, alpha, aa, lda, bb, ldb )
1099 ELSE IF( sname( 4: 5 ).EQ.
'SM' )
THEN
1101 $
WRITE( ntra, fmt = 9995 )nc, sname,
1102 $ side, uplo, transa, diag, m, n, alpha,
1106 CALL
strsm( side, uplo, transa, diag, m,
1107 $ n, alpha, aa, lda, bb, ldb )
1113 WRITE( nout, fmt = 9994 )
1120 isame( 1 ) = sides.EQ.side
1121 isame( 2 ) = uplos.EQ.uplo
1122 isame( 3 ) = tranas.EQ.transa
1123 isame( 4 ) = diags.EQ.diag
1124 isame( 5 ) = ms.EQ.m
1125 isame( 6 ) = ns.EQ.n
1126 isame( 7 ) = als.EQ.alpha
1127 isame( 8 ) = lse( as, aa, laa )
1128 isame( 9 ) = ldas.EQ.lda
1130 isame( 10 ) = lse( bs, bb, lbb )
1132 isame( 10 ) = lseres(
'GE',
' ', m, n, bs,
1135 isame( 11 ) = ldbs.EQ.ldb
1142 same = same.AND.isame( i )
1143 IF( .NOT.isame( i ) )
1144 $
WRITE( nout, fmt = 9998 )i
1152 IF( sname( 4: 5 ).EQ.
'MM' )
THEN
1157 CALL
smmch( transa,
'N', m, n, m,
1158 $ alpha, a, nmax, b, nmax,
1159 $ zero, c, nmax, ct, g,
1160 $ bb, ldb, eps, err,
1161 $ fatal, nout, .true. )
1163 CALL
smmch(
'N', transa, m, n, n,
1164 $ alpha, b, nmax, a, nmax,
1165 $ zero, c, nmax, ct, g,
1166 $ bb, ldb, eps, err,
1167 $ fatal, nout, .true. )
1169 ELSE IF( sname( 4: 5 ).EQ.
'SM' )
THEN
1176 c( i, j ) = bb( i + ( j - 1 )*
1178 bb( i + ( j - 1 )*ldb ) = alpha*
1184 CALL
smmch( transa,
'N', m, n, m,
1185 $ one, a, nmax, c, nmax,
1186 $ zero, b, nmax, ct, g,
1187 $ bb, ldb, eps, err,
1188 $ fatal, nout, .false. )
1190 CALL
smmch(
'N', transa, m, n, n,
1191 $ one, c, nmax, a, nmax,
1192 $ zero, b, nmax, ct, g,
1193 $ bb, ldb, eps, err,
1194 $ fatal, nout, .false. )
1197 errmax = max( errmax, err )
1220 IF( errmax.LT.thresh )
THEN
1221 WRITE( nout, fmt = 9999 )sname, nc
1223 WRITE( nout, fmt = 9997 )sname, nc, errmax
1228 WRITE( nout, fmt = 9996 )sname
1229 WRITE( nout, fmt = 9995 )nc, sname, side, uplo, transa, diag, m,
1230 $ n, alpha, lda, ldb
1235 9999
FORMAT(
' ', a6,
' PASSED THE COMPUTATIONAL TESTS (', i6,
' CALL',
1237 9998
FORMAT(
' ******* FATAL ERROR - PARAMETER NUMBER ', i2,
' WAS CH',
1238 $
'ANGED INCORRECTLY *******' )
1239 9997
FORMAT(
' ', a6,
' COMPLETED THE COMPUTATIONAL TESTS (', i6,
' C',
1240 $
'ALLS)', /
' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
1241 $
' - SUSPECT *******' )
1242 9996
FORMAT(
' ******* ', a6,
' FAILED ON CALL NUMBER:' )
1243 9995
FORMAT( 1x, i6,
': ', a6,
'(', 4(
'''', a1,
''',' ), 2( i3,
',' ),
1244 $ f4.1,
', A,', i3,
', B,', i3,
') .' )
1245 9994
FORMAT(
' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1251 SUBROUTINE schk4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1252 $ fatal, nidim, idim, nalf, alf, nbet, bet, nmax,
1253 $ a, aa, as, b, bb, bs, c, cc, cs, ct, g )
1267 parameter( zero = 0.0 )
1270 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
1271 LOGICAL FATAL, REWI, TRACE
1274 REAL A( nmax, nmax ), AA( nmax*nmax ), ALF( nalf ),
1275 $ as( nmax*nmax ), b( nmax, nmax ),
1276 $ bb( nmax*nmax ), bet( nbet ), bs( nmax*nmax ),
1277 $ c( nmax, nmax ), cc( nmax*nmax ),
1278 $ cs( nmax*nmax ), ct( nmax ), g( nmax )
1279 INTEGER IDIM( nidim )
1281 REAL ALPHA, ALS, BETA, BETS, ERR, ERRMAX
1282 INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, K, KS,
1283 $ laa, lcc, lda, ldas, ldc, ldcs, lj, ma, n, na,
1285 LOGICAL NULL, RESET, SAME, TRAN, UPPER
1286 CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS
1293 EXTERNAL lse, lseres
1299 INTEGER INFOT, NOUTC
1302 COMMON /infoc/infot, noutc, ok, lerr
1304 DATA icht/
'NTC'/, ichu/
'UL'/
1312 DO 100 in = 1, nidim
1328 trans = icht( ict: ict )
1329 tran = trans.EQ.
'T'.OR.trans.EQ.
'C'
1348 CALL
smake(
'GE',
' ',
' ', ma, na, a, nmax, aa, lda,
1352 uplo = ichu( icu: icu )
1363 CALL
smake(
'SY', uplo,
' ', n, n, c, nmax, cc,
1364 $ ldc, reset, zero )
1388 $
WRITE( ntra, fmt = 9994 )nc, sname, uplo,
1389 $ trans, n, k, alpha, lda, beta, ldc
1392 CALL
ssyrk( uplo, trans, n, k, alpha, aa, lda,
1398 WRITE( nout, fmt = 9993 )
1405 isame( 1 ) = uplos.EQ.uplo
1406 isame( 2 ) = transs.EQ.trans
1407 isame( 3 ) = ns.EQ.n
1408 isame( 4 ) = ks.EQ.k
1409 isame( 5 ) = als.EQ.alpha
1410 isame( 6 ) = lse( as, aa, laa )
1411 isame( 7 ) = ldas.EQ.lda
1412 isame( 8 ) = bets.EQ.beta
1414 isame( 9 ) = lse( cs, cc, lcc )
1416 isame( 9 ) = lseres(
'SY', uplo, n, n, cs,
1419 isame( 10 ) = ldcs.EQ.ldc
1426 same = same.AND.isame( i )
1427 IF( .NOT.isame( i ) )
1428 $
WRITE( nout, fmt = 9998 )i
1449 CALL
smmch(
'T',
'N', lj, 1, k, alpha,
1451 $ a( 1, j ), nmax, beta,
1452 $ c( jj, j ), nmax, ct, g,
1453 $ cc( jc ), ldc, eps, err,
1454 $ fatal, nout, .true. )
1456 CALL
smmch(
'N',
'T', lj, 1, k, alpha,
1458 $ a( j, 1 ), nmax, beta,
1459 $ c( jj, j ), nmax, ct, g,
1460 $ cc( jc ), ldc, eps, err,
1461 $ fatal, nout, .true. )
1468 errmax = max( errmax, err )
1490 IF( errmax.LT.thresh )
THEN
1491 WRITE( nout, fmt = 9999 )sname, nc
1493 WRITE( nout, fmt = 9997 )sname, nc, errmax
1499 $
WRITE( nout, fmt = 9995 )j
1502 WRITE( nout, fmt = 9996 )sname
1503 WRITE( nout, fmt = 9994 )nc, sname, uplo, trans, n, k, alpha,
1509 9999
FORMAT(
' ', a6,
' PASSED THE COMPUTATIONAL TESTS (', i6,
' CALL',
1511 9998
FORMAT(
' ******* FATAL ERROR - PARAMETER NUMBER ', i2,
' WAS CH',
1512 $
'ANGED INCORRECTLY *******' )
1513 9997
FORMAT(
' ', a6,
' COMPLETED THE COMPUTATIONAL TESTS (', i6,
' C',
1514 $
'ALLS)', /
' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
1515 $
' - SUSPECT *******' )
1516 9996
FORMAT(
' ******* ', a6,
' FAILED ON CALL NUMBER:' )
1517 9995
FORMAT(
' THESE ARE THE RESULTS FOR COLUMN ', i3 )
1518 9994
FORMAT( 1x, i6,
': ', a6,
'(', 2(
'''', a1,
''',' ), 2( i3,
',' ),
1519 $ f4.1,
', A,', i3,
',', f4.1,
', C,', i3,
') .' )
1520 9993
FORMAT(
' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1526 SUBROUTINE schk5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1527 $ fatal, nidim, idim, nalf, alf, nbet, bet, nmax,
1528 $ ab, aa, as, bb, bs, c, cc, cs, ct, g, w )
1542 parameter( zero = 0.0 )
1545 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
1546 LOGICAL FATAL, REWI, TRACE
1549 REAL AA( nmax*nmax ), AB( 2*nmax*nmax ),
1550 $ alf( nalf ), as( nmax*nmax ), bb( nmax*nmax ),
1551 $ bet( nbet ), bs( nmax*nmax ), c( nmax, nmax ),
1552 $ cc( nmax*nmax ), cs( nmax*nmax ), ct( nmax ),
1553 $ g( nmax ), w( 2*nmax )
1554 INTEGER IDIM( nidim )
1556 REAL ALPHA, ALS, BETA, BETS, ERR, ERRMAX
1557 INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, JJAB,
1558 $ k, ks, laa, lbb, lcc, lda, ldas, ldb, ldbs,
1559 $ ldc, ldcs, lj, ma, n, na, nargs, nc, ns
1560 LOGICAL NULL, RESET, SAME, TRAN, UPPER
1561 CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS
1568 EXTERNAL lse, lseres
1574 INTEGER INFOT, NOUTC
1577 COMMON /infoc/infot, noutc, ok, lerr
1579 DATA icht/
'NTC'/, ichu/
'UL'/
1587 DO 130 in = 1, nidim
1599 DO 120 ik = 1, nidim
1603 trans = icht( ict: ict )
1604 tran = trans.EQ.
'T'.OR.trans.EQ.
'C'
1624 CALL
smake(
'GE',
' ',
' ', ma, na, ab, 2*nmax, aa,
1625 $ lda, reset, zero )
1627 CALL
smake(
'GE',
' ',
' ', ma, na, ab, nmax, aa, lda,
1636 CALL
smake(
'GE',
' ',
' ', ma, na, ab( k + 1 ),
1637 $ 2*nmax, bb, ldb, reset, zero )
1639 CALL
smake(
'GE',
' ',
' ', ma, na, ab( k*nmax + 1 ),
1640 $ nmax, bb, ldb, reset, zero )
1644 uplo = ichu( icu: icu )
1655 CALL
smake(
'SY', uplo,
' ', n, n, c, nmax, cc,
1656 $ ldc, reset, zero )
1684 $
WRITE( ntra, fmt = 9994 )nc, sname, uplo,
1685 $ trans, n, k, alpha, lda, ldb, beta, ldc
1688 CALL
ssyr2k( uplo, trans, n, k, alpha, aa, lda,
1689 $ bb, ldb, beta, cc, ldc )
1694 WRITE( nout, fmt = 9993 )
1701 isame( 1 ) = uplos.EQ.uplo
1702 isame( 2 ) = transs.EQ.trans
1703 isame( 3 ) = ns.EQ.n
1704 isame( 4 ) = ks.EQ.k
1705 isame( 5 ) = als.EQ.alpha
1706 isame( 6 ) = lse( as, aa, laa )
1707 isame( 7 ) = ldas.EQ.lda
1708 isame( 8 ) = lse( bs, bb, lbb )
1709 isame( 9 ) = ldbs.EQ.ldb
1710 isame( 10 ) = bets.EQ.beta
1712 isame( 11 ) = lse( cs, cc, lcc )
1714 isame( 11 ) = lseres(
'SY', uplo, n, n, cs,
1717 isame( 12 ) = ldcs.EQ.ldc
1724 same = same.AND.isame( i )
1725 IF( .NOT.isame( i ) )
1726 $
WRITE( nout, fmt = 9998 )i
1749 w( i ) = ab( ( j - 1 )*2*nmax + k +
1751 w( k + i ) = ab( ( j - 1 )*2*nmax +
1754 CALL
smmch(
'T',
'N', lj, 1, 2*k,
1755 $ alpha, ab( jjab ), 2*nmax,
1757 $ c( jj, j ), nmax, ct, g,
1758 $ cc( jc ), ldc, eps, err,
1759 $ fatal, nout, .true. )
1762 w( i ) = ab( ( k + i - 1 )*nmax +
1764 w( k + i ) = ab( ( i - 1 )*nmax +
1767 CALL
smmch(
'N',
'N', lj, 1, 2*k,
1768 $ alpha, ab( jj ), nmax, w,
1769 $ 2*nmax, beta, c( jj, j ),
1770 $ nmax, ct, g, cc( jc ), ldc,
1771 $ eps, err, fatal, nout,
1779 $ jjab = jjab + 2*nmax
1781 errmax = max( errmax, err )
1803 IF( errmax.LT.thresh )
THEN
1804 WRITE( nout, fmt = 9999 )sname, nc
1806 WRITE( nout, fmt = 9997 )sname, nc, errmax
1812 $
WRITE( nout, fmt = 9995 )j
1815 WRITE( nout, fmt = 9996 )sname
1816 WRITE( nout, fmt = 9994 )nc, sname, uplo, trans, n, k, alpha,
1817 $ lda, ldb, beta, ldc
1822 9999
FORMAT(
' ', a6,
' PASSED THE COMPUTATIONAL TESTS (', i6,
' CALL',
1824 9998
FORMAT(
' ******* FATAL ERROR - PARAMETER NUMBER ', i2,
' WAS CH',
1825 $
'ANGED INCORRECTLY *******' )
1826 9997
FORMAT(
' ', a6,
' COMPLETED THE COMPUTATIONAL TESTS (', i6,
' C',
1827 $
'ALLS)', /
' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
1828 $
' - SUSPECT *******' )
1829 9996
FORMAT(
' ******* ', a6,
' FAILED ON CALL NUMBER:' )
1830 9995
FORMAT(
' THESE ARE THE RESULTS FOR COLUMN ', i3 )
1831 9994
FORMAT( 1x, i6,
': ', a6,
'(', 2(
'''', a1,
''',' ), 2( i3,
',' ),
1832 $ f4.1,
', A,', i3,
', B,', i3,
',', f4.1,
', C,', i3,
') ',
1834 9993
FORMAT(
' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1861 INTEGER INFOT, NOUTC
1865 parameter( one = 1.0e0, two = 2.0e0 )
1869 REAL A( 2, 1 ), B( 2, 1 ), C( 2, 1 )
1874 COMMON /infoc/infot, noutc, ok, lerr
1888 go to( 10, 20, 30, 40, 50, 60 )isnum
1890 CALL
sgemm(
'/',
'N', 0, 0, 0, alpha, a, 1, b, 1, beta, c, 1 )
1891 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1893 CALL
sgemm(
'/',
'T', 0, 0, 0, alpha, a, 1, b, 1, beta, c, 1 )
1894 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1896 CALL
sgemm(
'N',
'/', 0, 0, 0, alpha, a, 1, b, 1, beta, c, 1 )
1897 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1899 CALL
sgemm(
'T',
'/', 0, 0, 0, alpha, a, 1, b, 1, beta, c, 1 )
1900 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1902 CALL
sgemm(
'N',
'N', -1, 0, 0, alpha, a, 1, b, 1, beta, c, 1 )
1903 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1905 CALL
sgemm(
'N',
'T', -1, 0, 0, alpha, a, 1, b, 1, beta, c, 1 )
1906 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1908 CALL
sgemm(
'T',
'N', -1, 0, 0, alpha, a, 1, b, 1, beta, c, 1 )
1909 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1911 CALL
sgemm(
'T',
'T', -1, 0, 0, alpha, a, 1, b, 1, beta, c, 1 )
1912 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1914 CALL
sgemm(
'N',
'N', 0, -1, 0, alpha, a, 1, b, 1, beta, c, 1 )
1915 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1917 CALL
sgemm(
'N',
'T', 0, -1, 0, alpha, a, 1, b, 1, beta, c, 1 )
1918 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1920 CALL
sgemm(
'T',
'N', 0, -1, 0, alpha, a, 1, b, 1, beta, c, 1 )
1921 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1923 CALL
sgemm(
'T',
'T', 0, -1, 0, alpha, a, 1, b, 1, beta, c, 1 )
1924 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1926 CALL
sgemm(
'N',
'N', 0, 0, -1, alpha, a, 1, b, 1, beta, c, 1 )
1927 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1929 CALL
sgemm(
'N',
'T', 0, 0, -1, alpha, a, 1, b, 1, beta, c, 1 )
1930 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1932 CALL
sgemm(
'T',
'N', 0, 0, -1, alpha, a, 1, b, 1, beta, c, 1 )
1933 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1935 CALL
sgemm(
'T',
'T', 0, 0, -1, alpha, a, 1, b, 1, beta, c, 1 )
1936 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1938 CALL
sgemm(
'N',
'N', 2, 0, 0, alpha, a, 1, b, 1, beta, c, 2 )
1939 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1941 CALL
sgemm(
'N',
'T', 2, 0, 0, alpha, a, 1, b, 1, beta, c, 2 )
1942 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1944 CALL
sgemm(
'T',
'N', 0, 0, 2, alpha, a, 1, b, 2, beta, c, 1 )
1945 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1947 CALL
sgemm(
'T',
'T', 0, 0, 2, alpha, a, 1, b, 1, beta, c, 1 )
1948 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1950 CALL
sgemm(
'N',
'N', 0, 0, 2, alpha, a, 1, b, 1, beta, c, 1 )
1951 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1953 CALL
sgemm(
'T',
'N', 0, 0, 2, alpha, a, 2, b, 1, beta, c, 1 )
1954 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1956 CALL
sgemm(
'N',
'T', 0, 2, 0, alpha, a, 1, b, 1, beta, c, 1 )
1957 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1959 CALL
sgemm(
'T',
'T', 0, 2, 0, alpha, a, 1, b, 1, beta, c, 1 )
1960 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1962 CALL
sgemm(
'N',
'N', 2, 0, 0, alpha, a, 2, b, 1, beta, c, 1 )
1963 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1965 CALL
sgemm(
'N',
'T', 2, 0, 0, alpha, a, 2, b, 1, beta, c, 1 )
1966 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1968 CALL
sgemm(
'T',
'N', 2, 0, 0, alpha, a, 1, b, 1, beta, c, 1 )
1969 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1971 CALL
sgemm(
'T',
'T', 2, 0, 0, alpha, a, 1, b, 1, beta, c, 1 )
1972 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1975 CALL
ssymm(
'/',
'U', 0, 0, alpha, a, 1, b, 1, beta, c, 1 )
1976 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1978 CALL
ssymm(
'L',
'/', 0, 0, alpha, a, 1, b, 1, beta, c, 1 )
1979 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1981 CALL
ssymm(
'L',
'U', -1, 0, alpha, a, 1, b, 1, beta, c, 1 )
1982 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1984 CALL
ssymm(
'R',
'U', -1, 0, alpha, a, 1, b, 1, beta, c, 1 )
1985 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1987 CALL
ssymm(
'L',
'L', -1, 0, alpha, a, 1, b, 1, beta, c, 1 )
1988 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1990 CALL
ssymm(
'R',
'L', -1, 0, alpha, a, 1, b, 1, beta, c, 1 )
1991 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1993 CALL
ssymm(
'L',
'U', 0, -1, alpha, a, 1, b, 1, beta, c, 1 )
1994 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1996 CALL
ssymm(
'R',
'U', 0, -1, alpha, a, 1, b, 1, beta, c, 1 )
1997 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1999 CALL
ssymm(
'L',
'L', 0, -1, alpha, a, 1, b, 1, beta, c, 1 )
2000 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2002 CALL
ssymm(
'R',
'L', 0, -1, alpha, a, 1, b, 1, beta, c, 1 )
2003 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2005 CALL
ssymm(
'L',
'U', 2, 0, alpha, a, 1, b, 2, beta, c, 2 )
2006 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2008 CALL
ssymm(
'R',
'U', 0, 2, alpha, a, 1, b, 1, beta, c, 1 )
2009 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2011 CALL
ssymm(
'L',
'L', 2, 0, alpha, a, 1, b, 2, beta, c, 2 )
2012 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2014 CALL
ssymm(
'R',
'L', 0, 2, alpha, a, 1, b, 1, beta, c, 1 )
2015 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2017 CALL
ssymm(
'L',
'U', 2, 0, alpha, a, 2, b, 1, beta, c, 2 )
2018 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2020 CALL
ssymm(
'R',
'U', 2, 0, alpha, a, 1, b, 1, beta, c, 2 )
2021 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2023 CALL
ssymm(
'L',
'L', 2, 0, alpha, a, 2, b, 1, beta, c, 2 )
2024 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2026 CALL
ssymm(
'R',
'L', 2, 0, alpha, a, 1, b, 1, beta, c, 2 )
2027 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2029 CALL
ssymm(
'L',
'U', 2, 0, alpha, a, 2, b, 2, beta, c, 1 )
2030 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2032 CALL
ssymm(
'R',
'U', 2, 0, alpha, a, 1, b, 2, beta, c, 1 )
2033 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2035 CALL
ssymm(
'L',
'L', 2, 0, alpha, a, 2, b, 2, beta, c, 1 )
2036 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2038 CALL
ssymm(
'R',
'L', 2, 0, alpha, a, 1, b, 2, beta, c, 1 )
2039 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2042 CALL
strmm(
'/',
'U',
'N',
'N', 0, 0, alpha, a, 1, b, 1 )
2043 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2045 CALL
strmm(
'L',
'/',
'N',
'N', 0, 0, alpha, a, 1, b, 1 )
2046 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2048 CALL
strmm(
'L',
'U',
'/',
'N', 0, 0, alpha, a, 1, b, 1 )
2049 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2051 CALL
strmm(
'L',
'U',
'N',
'/', 0, 0, alpha, a, 1, b, 1 )
2052 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2054 CALL
strmm(
'L',
'U',
'N',
'N', -1, 0, alpha, a, 1, b, 1 )
2055 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2057 CALL
strmm(
'L',
'U',
'T',
'N', -1, 0, alpha, a, 1, b, 1 )
2058 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2060 CALL
strmm(
'R',
'U',
'N',
'N', -1, 0, alpha, a, 1, b, 1 )
2061 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2063 CALL
strmm(
'R',
'U',
'T',
'N', -1, 0, alpha, a, 1, b, 1 )
2064 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2066 CALL
strmm(
'L',
'L',
'N',
'N', -1, 0, alpha, a, 1, b, 1 )
2067 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2069 CALL
strmm(
'L',
'L',
'T',
'N', -1, 0, alpha, a, 1, b, 1 )
2070 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2072 CALL
strmm(
'R',
'L',
'N',
'N', -1, 0, alpha, a, 1, b, 1 )
2073 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2075 CALL
strmm(
'R',
'L',
'T',
'N', -1, 0, alpha, a, 1, b, 1 )
2076 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2078 CALL
strmm(
'L',
'U',
'N',
'N', 0, -1, alpha, a, 1, b, 1 )
2079 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2081 CALL
strmm(
'L',
'U',
'T',
'N', 0, -1, alpha, a, 1, b, 1 )
2082 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2084 CALL
strmm(
'R',
'U',
'N',
'N', 0, -1, alpha, a, 1, b, 1 )
2085 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2087 CALL
strmm(
'R',
'U',
'T',
'N', 0, -1, alpha, a, 1, b, 1 )
2088 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2090 CALL
strmm(
'L',
'L',
'N',
'N', 0, -1, alpha, a, 1, b, 1 )
2091 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2093 CALL
strmm(
'L',
'L',
'T',
'N', 0, -1, alpha, a, 1, b, 1 )
2094 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2096 CALL
strmm(
'R',
'L',
'N',
'N', 0, -1, alpha, a, 1, b, 1 )
2097 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2099 CALL
strmm(
'R',
'L',
'T',
'N', 0, -1, alpha, a, 1, b, 1 )
2100 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2102 CALL
strmm(
'L',
'U',
'N',
'N', 2, 0, alpha, a, 1, b, 2 )
2103 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2105 CALL
strmm(
'L',
'U',
'T',
'N', 2, 0, alpha, a, 1, b, 2 )
2106 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2108 CALL
strmm(
'R',
'U',
'N',
'N', 0, 2, alpha, a, 1, b, 1 )
2109 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2111 CALL
strmm(
'R',
'U',
'T',
'N', 0, 2, alpha, a, 1, b, 1 )
2112 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2114 CALL
strmm(
'L',
'L',
'N',
'N', 2, 0, alpha, a, 1, b, 2 )
2115 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2117 CALL
strmm(
'L',
'L',
'T',
'N', 2, 0, alpha, a, 1, b, 2 )
2118 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2120 CALL
strmm(
'R',
'L',
'N',
'N', 0, 2, alpha, a, 1, b, 1 )
2121 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2123 CALL
strmm(
'R',
'L',
'T',
'N', 0, 2, alpha, a, 1, b, 1 )
2124 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2126 CALL
strmm(
'L',
'U',
'N',
'N', 2, 0, alpha, a, 2, b, 1 )
2127 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2129 CALL
strmm(
'L',
'U',
'T',
'N', 2, 0, alpha, a, 2, b, 1 )
2130 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2132 CALL
strmm(
'R',
'U',
'N',
'N', 2, 0, alpha, a, 1, b, 1 )
2133 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2135 CALL
strmm(
'R',
'U',
'T',
'N', 2, 0, alpha, a, 1, b, 1 )
2136 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2138 CALL
strmm(
'L',
'L',
'N',
'N', 2, 0, alpha, a, 2, b, 1 )
2139 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2141 CALL
strmm(
'L',
'L',
'T',
'N', 2, 0, alpha, a, 2, b, 1 )
2142 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2144 CALL
strmm(
'R',
'L',
'N',
'N', 2, 0, alpha, a, 1, b, 1 )
2145 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2147 CALL
strmm(
'R',
'L',
'T',
'N', 2, 0, alpha, a, 1, b, 1 )
2148 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2151 CALL
strsm(
'/',
'U',
'N',
'N', 0, 0, alpha, a, 1, b, 1 )
2152 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2154 CALL
strsm(
'L',
'/',
'N',
'N', 0, 0, alpha, a, 1, b, 1 )
2155 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2157 CALL
strsm(
'L',
'U',
'/',
'N', 0, 0, alpha, a, 1, b, 1 )
2158 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2160 CALL
strsm(
'L',
'U',
'N',
'/', 0, 0, alpha, a, 1, b, 1 )
2161 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2163 CALL
strsm(
'L',
'U',
'N',
'N', -1, 0, alpha, a, 1, b, 1 )
2164 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2166 CALL
strsm(
'L',
'U',
'T',
'N', -1, 0, alpha, a, 1, b, 1 )
2167 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2169 CALL
strsm(
'R',
'U',
'N',
'N', -1, 0, alpha, a, 1, b, 1 )
2170 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2172 CALL
strsm(
'R',
'U',
'T',
'N', -1, 0, alpha, a, 1, b, 1 )
2173 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2175 CALL
strsm(
'L',
'L',
'N',
'N', -1, 0, alpha, a, 1, b, 1 )
2176 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2178 CALL
strsm(
'L',
'L',
'T',
'N', -1, 0, alpha, a, 1, b, 1 )
2179 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2181 CALL
strsm(
'R',
'L',
'N',
'N', -1, 0, alpha, a, 1, b, 1 )
2182 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2184 CALL
strsm(
'R',
'L',
'T',
'N', -1, 0, alpha, a, 1, b, 1 )
2185 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2187 CALL
strsm(
'L',
'U',
'N',
'N', 0, -1, alpha, a, 1, b, 1 )
2188 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2190 CALL
strsm(
'L',
'U',
'T',
'N', 0, -1, alpha, a, 1, b, 1 )
2191 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2193 CALL
strsm(
'R',
'U',
'N',
'N', 0, -1, alpha, a, 1, b, 1 )
2194 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2196 CALL
strsm(
'R',
'U',
'T',
'N', 0, -1, alpha, a, 1, b, 1 )
2197 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2199 CALL
strsm(
'L',
'L',
'N',
'N', 0, -1, alpha, a, 1, b, 1 )
2200 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2202 CALL
strsm(
'L',
'L',
'T',
'N', 0, -1, alpha, a, 1, b, 1 )
2203 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2205 CALL
strsm(
'R',
'L',
'N',
'N', 0, -1, alpha, a, 1, b, 1 )
2206 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2208 CALL
strsm(
'R',
'L',
'T',
'N', 0, -1, alpha, a, 1, b, 1 )
2209 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2211 CALL
strsm(
'L',
'U',
'N',
'N', 2, 0, alpha, a, 1, b, 2 )
2212 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2214 CALL
strsm(
'L',
'U',
'T',
'N', 2, 0, alpha, a, 1, b, 2 )
2215 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2217 CALL
strsm(
'R',
'U',
'N',
'N', 0, 2, alpha, a, 1, b, 1 )
2218 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2220 CALL
strsm(
'R',
'U',
'T',
'N', 0, 2, alpha, a, 1, b, 1 )
2221 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2223 CALL
strsm(
'L',
'L',
'N',
'N', 2, 0, alpha, a, 1, b, 2 )
2224 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2226 CALL
strsm(
'L',
'L',
'T',
'N', 2, 0, alpha, a, 1, b, 2 )
2227 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2229 CALL
strsm(
'R',
'L',
'N',
'N', 0, 2, alpha, a, 1, b, 1 )
2230 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2232 CALL
strsm(
'R',
'L',
'T',
'N', 0, 2, alpha, a, 1, b, 1 )
2233 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2235 CALL
strsm(
'L',
'U',
'N',
'N', 2, 0, alpha, a, 2, b, 1 )
2236 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2238 CALL
strsm(
'L',
'U',
'T',
'N', 2, 0, alpha, a, 2, b, 1 )
2239 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2241 CALL
strsm(
'R',
'U',
'N',
'N', 2, 0, alpha, a, 1, b, 1 )
2242 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2244 CALL
strsm(
'R',
'U',
'T',
'N', 2, 0, alpha, a, 1, b, 1 )
2245 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2247 CALL
strsm(
'L',
'L',
'N',
'N', 2, 0, alpha, a, 2, b, 1 )
2248 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2250 CALL
strsm(
'L',
'L',
'T',
'N', 2, 0, alpha, a, 2, b, 1 )
2251 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2253 CALL
strsm(
'R',
'L',
'N',
'N', 2, 0, alpha, a, 1, b, 1 )
2254 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2256 CALL
strsm(
'R',
'L',
'T',
'N', 2, 0, alpha, a, 1, b, 1 )
2257 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2260 CALL
ssyrk(
'/',
'N', 0, 0, alpha, a, 1, beta, c, 1 )
2261 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2263 CALL
ssyrk(
'U',
'/', 0, 0, alpha, a, 1, beta, c, 1 )
2264 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2266 CALL
ssyrk(
'U',
'N', -1, 0, alpha, a, 1, beta, c, 1 )
2267 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2269 CALL
ssyrk(
'U',
'T', -1, 0, alpha, a, 1, beta, c, 1 )
2270 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2272 CALL
ssyrk(
'L',
'N', -1, 0, alpha, a, 1, beta, c, 1 )
2273 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2275 CALL
ssyrk(
'L',
'T', -1, 0, alpha, a, 1, beta, c, 1 )
2276 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2278 CALL
ssyrk(
'U',
'N', 0, -1, alpha, a, 1, beta, c, 1 )
2279 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2281 CALL
ssyrk(
'U',
'T', 0, -1, alpha, a, 1, beta, c, 1 )
2282 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2284 CALL
ssyrk(
'L',
'N', 0, -1, alpha, a, 1, beta, c, 1 )
2285 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2287 CALL
ssyrk(
'L',
'T', 0, -1, alpha, a, 1, beta, c, 1 )
2288 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2290 CALL
ssyrk(
'U',
'N', 2, 0, alpha, a, 1, beta, c, 2 )
2291 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2293 CALL
ssyrk(
'U',
'T', 0, 2, alpha, a, 1, beta, c, 1 )
2294 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2296 CALL
ssyrk(
'L',
'N', 2, 0, alpha, a, 1, beta, c, 2 )
2297 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2299 CALL
ssyrk(
'L',
'T', 0, 2, alpha, a, 1, beta, c, 1 )
2300 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2302 CALL
ssyrk(
'U',
'N', 2, 0, alpha, a, 2, beta, c, 1 )
2303 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2305 CALL
ssyrk(
'U',
'T', 2, 0, alpha, a, 1, beta, c, 1 )
2306 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2308 CALL
ssyrk(
'L',
'N', 2, 0, alpha, a, 2, beta, c, 1 )
2309 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2311 CALL
ssyrk(
'L',
'T', 2, 0, alpha, a, 1, beta, c, 1 )
2312 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2315 CALL
ssyr2k(
'/',
'N', 0, 0, alpha, a, 1, b, 1, beta, c, 1 )
2316 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2318 CALL
ssyr2k(
'U',
'/', 0, 0, alpha, a, 1, b, 1, beta, c, 1 )
2319 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2321 CALL
ssyr2k(
'U',
'N', -1, 0, alpha, a, 1, b, 1, beta, c, 1 )
2322 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2324 CALL
ssyr2k(
'U',
'T', -1, 0, alpha, a, 1, b, 1, beta, c, 1 )
2325 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2327 CALL
ssyr2k(
'L',
'N', -1, 0, alpha, a, 1, b, 1, beta, c, 1 )
2328 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2330 CALL
ssyr2k(
'L',
'T', -1, 0, alpha, a, 1, b, 1, beta, c, 1 )
2331 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2333 CALL
ssyr2k(
'U',
'N', 0, -1, alpha, a, 1, b, 1, beta, c, 1 )
2334 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2336 CALL
ssyr2k(
'U',
'T', 0, -1, alpha, a, 1, b, 1, beta, c, 1 )
2337 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2339 CALL
ssyr2k(
'L',
'N', 0, -1, alpha, a, 1, b, 1, beta, c, 1 )
2340 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2342 CALL
ssyr2k(
'L',
'T', 0, -1, alpha, a, 1, b, 1, beta, c, 1 )
2343 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2345 CALL
ssyr2k(
'U',
'N', 2, 0, alpha, a, 1, b, 1, beta, c, 2 )
2346 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2348 CALL
ssyr2k(
'U',
'T', 0, 2, alpha, a, 1, b, 1, beta, c, 1 )
2349 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2351 CALL
ssyr2k(
'L',
'N', 2, 0, alpha, a, 1, b, 1, beta, c, 2 )
2352 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2354 CALL
ssyr2k(
'L',
'T', 0, 2, alpha, a, 1, b, 1, beta, c, 1 )
2355 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2357 CALL
ssyr2k(
'U',
'N', 2, 0, alpha, a, 2, b, 1, beta, c, 2 )
2358 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2360 CALL
ssyr2k(
'U',
'T', 0, 2, alpha, a, 2, b, 1, beta, c, 1 )
2361 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2363 CALL
ssyr2k(
'L',
'N', 2, 0, alpha, a, 2, b, 1, beta, c, 2 )
2364 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2366 CALL
ssyr2k(
'L',
'T', 0, 2, alpha, a, 2, b, 1, beta, c, 1 )
2367 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2369 CALL
ssyr2k(
'U',
'N', 2, 0, alpha, a, 2, b, 2, beta, c, 1 )
2370 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2372 CALL
ssyr2k(
'U',
'T', 2, 0, alpha, a, 1, b, 1, beta, c, 1 )
2373 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2375 CALL
ssyr2k(
'L',
'N', 2, 0, alpha, a, 2, b, 2, beta, c, 1 )
2376 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2378 CALL
ssyr2k(
'L',
'T', 2, 0, alpha, a, 1, b, 1, beta, c, 1 )
2379 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2382 WRITE( nout, fmt = 9999 )srnamt
2384 WRITE( nout, fmt = 9998 )srnamt
2388 9999
FORMAT(
' ', a6,
' PASSED THE TESTS OF ERROR-EXITS' )
2389 9998
FORMAT(
' ******* ', a6,
' FAILED THE TESTS OF ERROR-EXITS *****',
2395 SUBROUTINE smake( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, RESET,
2414 parameter( zero = 0.0, one = 1.0 )
2416 parameter( rogue = -1.0e10 )
2419 INTEGER LDA, M, N, NMAX
2421 CHARACTER*1 DIAG, UPLO
2424 REAL A( nmax, * ), AA( * )
2426 INTEGER I, IBEG, IEND, J
2427 LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER
2435 upper = ( sym.OR.tri ).AND.uplo.EQ.
'U'
2436 lower = ( sym.OR.tri ).AND.uplo.EQ.
'L'
2437 unit = tri.AND.diag.EQ.
'U'
2443 IF( gen.OR.( upper.AND.i.LE.j ).OR.( lower.AND.i.GE.j ) )
2445 a( i, j ) = sbeg( reset ) + transl
2448 IF( n.GT.3.AND.j.EQ.n/2 )
2451 a( j, i ) = a( i, j )
2459 $ a( j, j ) = a( j, j ) + one
2466 IF( type.EQ.
'GE' )
THEN
2469 aa( i + ( j - 1 )*lda ) = a( i, j )
2471 DO 40 i = m + 1, lda
2472 aa( i + ( j - 1 )*lda ) = rogue
2475 ELSE IF( type.EQ.
'SY'.OR.type.EQ.
'TR' )
THEN
2492 DO 60 i = 1, ibeg - 1
2493 aa( i + ( j - 1 )*lda ) = rogue
2495 DO 70 i = ibeg, iend
2496 aa( i + ( j - 1 )*lda ) = a( i, j )
2498 DO 80 i = iend + 1, lda
2499 aa( i + ( j - 1 )*lda ) = rogue
2508 SUBROUTINE smmch( TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB,
2509 $ beta, c, ldc, ct, g, cc, ldcc, eps, err, fatal,
2524 parameter( zero = 0.0, one = 1.0 )
2526 REAL ALPHA, BETA, EPS, ERR
2527 INTEGER KK, LDA, LDB, LDC, LDCC, M, N, NOUT
2529 CHARACTER*1 TRANSA, TRANSB
2531 REAL A( lda, * ), B( ldb, * ), C( ldc, * ),
2532 $ cc( ldcc, * ), ct( * ), g( * )
2536 LOGICAL TRANA, TRANB
2538 INTRINSIC abs, max, sqrt
2540 trana = transa.EQ.
'T'.OR.transa.EQ.
'C'
2541 tranb = transb.EQ.
'T'.OR.transb.EQ.
'C'
2553 IF( .NOT.trana.AND..NOT.tranb )
THEN
2556 ct( i ) = ct( i ) + a( i, k )*b( k, j )
2557 g( i ) = g( i ) + abs( a( i, k ) )*abs( b( k, j ) )
2560 ELSE IF( trana.AND..NOT.tranb )
THEN
2563 ct( i ) = ct( i ) + a( k, i )*b( k, j )
2564 g( i ) = g( i ) + abs( a( k, i ) )*abs( b( k, j ) )
2567 ELSE IF( .NOT.trana.AND.tranb )
THEN
2570 ct( i ) = ct( i ) + a( i, k )*b( j, k )
2571 g( i ) = g( i ) + abs( a( i, k ) )*abs( b( j, k ) )
2574 ELSE IF( trana.AND.tranb )
THEN
2577 ct( i ) = ct( i ) + a( k, i )*b( j, k )
2578 g( i ) = g( i ) + abs( a( k, i ) )*abs( b( j, k ) )
2583 ct( i ) = alpha*ct( i ) + beta*c( i, j )
2584 g( i ) = abs( alpha )*g( i ) + abs( beta )*abs( c( i, j ) )
2591 erri = abs( ct( i ) - cc( i, j ) )/eps
2592 IF( g( i ).NE.zero )
2593 $ erri = erri/g( i )
2594 err = max( err, erri )
2595 IF( err*sqrt( eps ).GE.one )
2607 WRITE( nout, fmt = 9999 )
2610 WRITE( nout, fmt = 9998 )i, ct( i ), cc( i, j )
2612 WRITE( nout, fmt = 9998 )i, cc( i, j ), ct( i )
2616 $
WRITE( nout, fmt = 9997 )j
2621 9999
FORMAT(
' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
2622 $
'F ACCURATE *******', /
' EXPECTED RESULT COMPU',
2624 9998
FORMAT( 1x, i7, 2g18.6 )
2625 9997
FORMAT(
' THESE ARE THE RESULTS FOR COLUMN ', i3 )
2630 LOGICAL FUNCTION lse( RI, RJ, LR )
2645 REAL RI( * ), RJ( * )
2650 IF( ri( i ).NE.rj( i ) )
2662 LOGICAL FUNCTION lseres( TYPE, UPLO, M, N, AA, AS, LDA )
2681 REAL AA( lda, * ), AS( lda, * )
2683 INTEGER I, IBEG, IEND, J
2687 IF( type.EQ.
'GE' )
THEN
2689 DO 10 i = m + 1, lda
2690 IF( aa( i, j ).NE.as( i, j ) )
2694 ELSE IF( type.EQ.
'SY' )
THEN
2703 DO 30 i = 1, ibeg - 1
2704 IF( aa( i, j ).NE.as( i, j ) )
2707 DO 40 i = iend + 1, lda
2708 IF( aa( i, j ).NE.as( i, j ) )
2723 REAL FUNCTION sbeg( RESET )
2758 i = i - 1000*( i/1000 )
2763 sbeg = ( i - 500 )/1001.0
2769 REAL FUNCTION sdiff( X, Y )
2788 SUBROUTINE chkxer( SRNAMT, INFOT, NOUT, LERR, OK )
2806 WRITE( nout, fmt = 9999 )infot, srnamt
2812 9999
FORMAT(
' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', i2,
' NOT D',
2813 $
'ETECTED BY ', a6,
' *****' )
2845 COMMON /infoc/infot, nout, ok, lerr
2846 COMMON /srnamc/srnamt
2849 IF( info.NE.infot )
THEN
2850 IF( infot.NE.0 )
THEN
2851 WRITE( nout, fmt = 9999 )info, infot
2853 WRITE( nout, fmt = 9997 )info
2857 IF( srname.NE.srnamt )
THEN
2858 WRITE( nout, fmt = 9998 )srname, srnamt
2863 9999
FORMAT(
' ******* XERBLA WAS CALLED WITH INFO = ', i6,
' INSTEAD',
2864 $
' OF ', i2,
' *******' )
2865 9998
FORMAT(
' ******* XERBLA WAS CALLED WITH SRNAME = ', a6,
' INSTE',
2866 $
'AD OF ', a6,
' *******' )
2867 9997
FORMAT(
' ******* XERBLA WAS CALLED WITH INFO = ', i6,
subroutine smmch(TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB, BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL, NOUT, MV)
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)
subroutine ssymm(SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
SSYMM
subroutine ssyr2k(UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
SSYR2K
subroutine schke(ISNUM, SRNAMT, NOUT)
subroutine ssyrk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
SSYRK
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine chkxer(SRNAMT, INFOT, NOUT, LERR, OK)
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)
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)
subroutine strmm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
STRMM
subroutine sgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
SGEMM
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)
subroutine smake(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, KU, RESET, TRANSL)
subroutine strsm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
STRSM
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)