96 parameter( nsubs = 6 )
97 DOUBLE PRECISION zero, one
98 parameter( zero = 0.0d0, one = 1.0d0 )
100 parameter( nmax = 65 )
101 INTEGER nidmax, nalmax, nbemax
102 parameter( nidmax = 9, nalmax = 7, nbemax = 7 )
104 DOUBLE PRECISION 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 DOUBLE PRECISION 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 )
122 DOUBLE PRECISION ddiff
134 COMMON /infoc/infot, noutc, ok, lerr
135 COMMON /srnamc/srnamt
137 DATA snames/
'DGEMM ',
'DSYMM ',
'DTRMM ',
'DTRSM ',
138 $
'DSYRK ',
'DSYR2K'/
143 READ( nin, fmt = * )summry
144 READ( nin, fmt = * )nout
145 OPEN( nout, file = summry, status =
'UNKNOWN' )
150 READ( nin, fmt = * )snaps
151 READ( nin, fmt = * )ntra
154 OPEN( ntra, file = snaps, status =
'UNKNOWN' )
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
dmmch( 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 =
lde( cc, ct, n )
256 IF( .NOT.same.OR.err.NE.zero )
THEN
257 WRITE( nout, fmt = 9989 )transa, transb, same, err
261 CALL
dmmch( 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 =
lde( 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
dmmch( 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 =
lde( cc, ct, n )
283 IF( .NOT.same.OR.err.NE.zero )
THEN
284 WRITE( nout, fmt = 9989 )transa, transb, same, err
288 CALL
dmmch( 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 =
lde( 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
dchke( isnum, snames( isnum ), nout )
309 WRITE( nout, fmt = * )
315 go to( 140, 150, 160, 160, 170, 180 )isnum
317 140 CALL
dchk1( 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
dchk2( 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
dchk3( 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
dchk4( 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
dchk5( 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, d9.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 DOUBLE PRECISION 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 DMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALU',
381 $
'ATED WRONGLY.', /
' DMMCH 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( 1
x, 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 dchk1( 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 )
410 DOUBLE PRECISION zero
411 parameter( zero = 0.0d0 )
413 DOUBLE PRECISION eps, thresh
414 INTEGER nalf, nbet, nidim, nmax, nout, ntra
415 LOGICAL fatal, rewi, trace
418 DOUBLE PRECISION 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 DOUBLE PRECISION 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
dmake(
'GE',
' ',
' ', ma, na, a, nmax, aa, lda,
499 transb = ich( icb: icb )
500 tranb = transb.EQ.
'T'.OR.transb.EQ.
'C'
520 CALL
dmake(
'GE',
' ',
' ', mb, nb,
b, nmax, bb,
531 CALL
dmake(
'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
dgemm( 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 ) =
lde( as, aa, laa )
587 isame( 8 ) = ldas.EQ.lda
588 isame( 9 ) =
lde( bs, bb, lbb )
589 isame( 10 ) = ldbs.EQ.ldb
590 isame( 11 ) = bls.EQ.beta
592 isame( 12 ) =
lde( cs, cc, lcc )
594 isame( 12 ) =
lderes(
'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
dmmch( 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( 1
x, 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 dchk2( 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 )
691 DOUBLE PRECISION zero
692 parameter( zero = 0.0d0 )
694 DOUBLE PRECISION eps, thresh
695 INTEGER nalf, nbet, nidim, nmax, nout, ntra
696 LOGICAL fatal, rewi, trace
699 DOUBLE PRECISION 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 DOUBLE PRECISION 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
dmake(
'GE',
' ',
' ', m, n,
b, nmax, bb, ldb, reset,
766 side = ichs( ics: ics )
784 uplo = ichu( icu: icu )
788 CALL
dmake(
'SY', uplo,
' ', na, na, a, nmax, aa, lda,
799 CALL
dmake(
'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
dsymm( 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 ) =
lde( as, aa, laa )
852 isame( 7 ) = ldas.EQ.lda
853 isame( 8 ) =
lde( bs, bb, lbb )
854 isame( 9 ) = ldbs.EQ.ldb
855 isame( 10 ) = bls.EQ.beta
857 isame( 11 ) =
lde( cs, cc, lcc )
859 isame( 11 ) =
lderes(
'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
dmmch(
'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
dmmch(
'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( 1
x, 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 dchk3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
947 $ fatal, nidim, idim, nalf, alf, nmax, a, aa, as,
948 $
b, bb, bs, ct, g, c )
961 DOUBLE PRECISION zero, one
962 parameter( zero = 0.0d0, one = 1.0d0 )
964 DOUBLE PRECISION eps, thresh
965 INTEGER nalf, nidim, nmax, nout, ntra
966 LOGICAL fatal, rewi, trace
969 DOUBLE PRECISION 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 DOUBLE PRECISION 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
dmake(
'TR', uplo, diag, na, na, a,
1060 $ nmax, aa, lda, reset, zero )
1064 CALL
dmake(
'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
dtrmm( 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
dtrsm( 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 ) =
lde( as, aa, laa )
1128 isame( 9 ) = ldas.EQ.lda
1130 isame( 10 ) =
lde( bs, bb, lbb )
1132 isame( 10 ) =
lderes(
'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
dmmch( 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
dmmch(
'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
dmmch( 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
dmmch(
'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( 1
x, 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 dchk4( 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 )
1266 DOUBLE PRECISION zero
1267 parameter( zero = 0.0d0 )
1269 DOUBLE PRECISION eps, thresh
1270 INTEGER nalf, nbet, nidim, nmax, nout, ntra
1271 LOGICAL fatal, rewi, trace
1274 DOUBLE PRECISION 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 DOUBLE PRECISION 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
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
dmake(
'GE',
' ',
' ', ma, na, a, nmax, aa, lda,
1352 uplo = ichu( icu: icu )
1363 CALL
dmake(
'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
dsyrk( 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 ) =
lde( as, aa, laa )
1411 isame( 7 ) = ldas.EQ.lda
1412 isame( 8 ) = bets.EQ.beta
1414 isame( 9 ) =
lde( cs, cc, lcc )
1416 isame( 9 ) =
lderes(
'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
dmmch(
'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
dmmch(
'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( 1
x, 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 dchk5( 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 )
1541 DOUBLE PRECISION zero
1542 parameter( zero = 0.0d0 )
1544 DOUBLE PRECISION eps, thresh
1545 INTEGER nalf, nbet, nidim, nmax, nout, ntra
1546 LOGICAL fatal, rewi, trace
1549 DOUBLE PRECISION 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 DOUBLE PRECISION 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
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
dmake(
'GE',
' ',
' ', ma, na, ab, 2*nmax, aa,
1625 $ lda, reset, zero )
1627 CALL
dmake(
'GE',
' ',
' ', ma, na, ab, nmax, aa, lda,
1636 CALL
dmake(
'GE',
' ',
' ', ma, na, ab( k + 1 ),
1637 $ 2*nmax, bb, ldb, reset, zero )
1639 CALL
dmake(
'GE',
' ',
' ', ma, na, ab( k*nmax + 1 ),
1640 $ nmax, bb, ldb, reset, zero )
1644 uplo = ichu( icu: icu )
1655 CALL
dmake(
'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
dsyr2k( 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 ) =
lde( as, aa, laa )
1707 isame( 7 ) = ldas.EQ.lda
1708 isame( 8 ) =
lde( bs, bb, lbb )
1709 isame( 9 ) = ldbs.EQ.ldb
1710 isame( 10 ) = bets.EQ.beta
1712 isame( 11 ) =
lde( cs, cc, lcc )
1714 isame( 11 ) =
lderes(
'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
dmmch(
'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
dmmch(
'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( 1
x, 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
1864 DOUBLE PRECISION one, two
1865 parameter( one = 1.0d0, two = 2.0d0 )
1867 DOUBLE PRECISION alpha, beta
1869 DOUBLE PRECISION 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
dgemm(
'/',
'N', 0, 0, 0, alpha, a, 1,
b, 1, beta, c, 1 )
1891 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1893 CALL
dgemm(
'/',
'T', 0, 0, 0, alpha, a, 1,
b, 1, beta, c, 1 )
1894 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1896 CALL
dgemm(
'N',
'/', 0, 0, 0, alpha, a, 1,
b, 1, beta, c, 1 )
1897 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1899 CALL
dgemm(
'T',
'/', 0, 0, 0, alpha, a, 1,
b, 1, beta, c, 1 )
1900 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1902 CALL
dgemm(
'N',
'N', -1, 0, 0, alpha, a, 1,
b, 1, beta, c, 1 )
1903 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1905 CALL
dgemm(
'N',
'T', -1, 0, 0, alpha, a, 1,
b, 1, beta, c, 1 )
1906 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1908 CALL
dgemm(
'T',
'N', -1, 0, 0, alpha, a, 1,
b, 1, beta, c, 1 )
1909 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1911 CALL
dgemm(
'T',
'T', -1, 0, 0, alpha, a, 1,
b, 1, beta, c, 1 )
1912 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1914 CALL
dgemm(
'N',
'N', 0, -1, 0, alpha, a, 1,
b, 1, beta, c, 1 )
1915 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1917 CALL
dgemm(
'N',
'T', 0, -1, 0, alpha, a, 1,
b, 1, beta, c, 1 )
1918 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1920 CALL
dgemm(
'T',
'N', 0, -1, 0, alpha, a, 1,
b, 1, beta, c, 1 )
1921 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1923 CALL
dgemm(
'T',
'T', 0, -1, 0, alpha, a, 1,
b, 1, beta, c, 1 )
1924 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1926 CALL
dgemm(
'N',
'N', 0, 0, -1, alpha, a, 1,
b, 1, beta, c, 1 )
1927 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1929 CALL
dgemm(
'N',
'T', 0, 0, -1, alpha, a, 1,
b, 1, beta, c, 1 )
1930 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1932 CALL
dgemm(
'T',
'N', 0, 0, -1, alpha, a, 1,
b, 1, beta, c, 1 )
1933 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1935 CALL
dgemm(
'T',
'T', 0, 0, -1, alpha, a, 1,
b, 1, beta, c, 1 )
1936 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1938 CALL
dgemm(
'N',
'N', 2, 0, 0, alpha, a, 1,
b, 1, beta, c, 2 )
1939 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1941 CALL
dgemm(
'N',
'T', 2, 0, 0, alpha, a, 1,
b, 1, beta, c, 2 )
1942 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1944 CALL
dgemm(
'T',
'N', 0, 0, 2, alpha, a, 1,
b, 2, beta, c, 1 )
1945 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1947 CALL
dgemm(
'T',
'T', 0, 0, 2, alpha, a, 1,
b, 1, beta, c, 1 )
1948 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1950 CALL
dgemm(
'N',
'N', 0, 0, 2, alpha, a, 1,
b, 1, beta, c, 1 )
1951 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1953 CALL
dgemm(
'T',
'N', 0, 0, 2, alpha, a, 2,
b, 1, beta, c, 1 )
1954 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1956 CALL
dgemm(
'N',
'T', 0, 2, 0, alpha, a, 1,
b, 1, beta, c, 1 )
1957 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1959 CALL
dgemm(
'T',
'T', 0, 2, 0, alpha, a, 1,
b, 1, beta, c, 1 )
1960 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1962 CALL
dgemm(
'N',
'N', 2, 0, 0, alpha, a, 2,
b, 1, beta, c, 1 )
1963 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1965 CALL
dgemm(
'N',
'T', 2, 0, 0, alpha, a, 2,
b, 1, beta, c, 1 )
1966 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1968 CALL
dgemm(
'T',
'N', 2, 0, 0, alpha, a, 1,
b, 1, beta, c, 1 )
1969 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1971 CALL
dgemm(
'T',
'T', 2, 0, 0, alpha, a, 1,
b, 1, beta, c, 1 )
1972 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1975 CALL
dsymm(
'/',
'U', 0, 0, alpha, a, 1,
b, 1, beta, c, 1 )
1976 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1978 CALL
dsymm(
'L',
'/', 0, 0, alpha, a, 1,
b, 1, beta, c, 1 )
1979 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1981 CALL
dsymm(
'L',
'U', -1, 0, alpha, a, 1,
b, 1, beta, c, 1 )
1982 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1984 CALL
dsymm(
'R',
'U', -1, 0, alpha, a, 1,
b, 1, beta, c, 1 )
1985 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1987 CALL
dsymm(
'L',
'L', -1, 0, alpha, a, 1,
b, 1, beta, c, 1 )
1988 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1990 CALL
dsymm(
'R',
'L', -1, 0, alpha, a, 1,
b, 1, beta, c, 1 )
1991 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1993 CALL
dsymm(
'L',
'U', 0, -1, alpha, a, 1,
b, 1, beta, c, 1 )
1994 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1996 CALL
dsymm(
'R',
'U', 0, -1, alpha, a, 1,
b, 1, beta, c, 1 )
1997 CALL
chkxer( srnamt, infot, nout, lerr, ok )
1999 CALL
dsymm(
'L',
'L', 0, -1, alpha, a, 1,
b, 1, beta, c, 1 )
2000 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2002 CALL
dsymm(
'R',
'L', 0, -1, alpha, a, 1,
b, 1, beta, c, 1 )
2003 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2005 CALL
dsymm(
'L',
'U', 2, 0, alpha, a, 1,
b, 2, beta, c, 2 )
2006 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2008 CALL
dsymm(
'R',
'U', 0, 2, alpha, a, 1,
b, 1, beta, c, 1 )
2009 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2011 CALL
dsymm(
'L',
'L', 2, 0, alpha, a, 1,
b, 2, beta, c, 2 )
2012 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2014 CALL
dsymm(
'R',
'L', 0, 2, alpha, a, 1,
b, 1, beta, c, 1 )
2015 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2017 CALL
dsymm(
'L',
'U', 2, 0, alpha, a, 2,
b, 1, beta, c, 2 )
2018 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2020 CALL
dsymm(
'R',
'U', 2, 0, alpha, a, 1,
b, 1, beta, c, 2 )
2021 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2023 CALL
dsymm(
'L',
'L', 2, 0, alpha, a, 2,
b, 1, beta, c, 2 )
2024 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2026 CALL
dsymm(
'R',
'L', 2, 0, alpha, a, 1,
b, 1, beta, c, 2 )
2027 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2029 CALL
dsymm(
'L',
'U', 2, 0, alpha, a, 2,
b, 2, beta, c, 1 )
2030 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2032 CALL
dsymm(
'R',
'U', 2, 0, alpha, a, 1,
b, 2, beta, c, 1 )
2033 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2035 CALL
dsymm(
'L',
'L', 2, 0, alpha, a, 2,
b, 2, beta, c, 1 )
2036 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2038 CALL
dsymm(
'R',
'L', 2, 0, alpha, a, 1,
b, 2, beta, c, 1 )
2039 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2042 CALL
dtrmm(
'/',
'U',
'N',
'N', 0, 0, alpha, a, 1,
b, 1 )
2043 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2045 CALL
dtrmm(
'L',
'/',
'N',
'N', 0, 0, alpha, a, 1,
b, 1 )
2046 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2048 CALL
dtrmm(
'L',
'U',
'/',
'N', 0, 0, alpha, a, 1,
b, 1 )
2049 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2051 CALL
dtrmm(
'L',
'U',
'N',
'/', 0, 0, alpha, a, 1,
b, 1 )
2052 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2054 CALL
dtrmm(
'L',
'U',
'N',
'N', -1, 0, alpha, a, 1,
b, 1 )
2055 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2057 CALL
dtrmm(
'L',
'U',
'T',
'N', -1, 0, alpha, a, 1,
b, 1 )
2058 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2060 CALL
dtrmm(
'R',
'U',
'N',
'N', -1, 0, alpha, a, 1,
b, 1 )
2061 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2063 CALL
dtrmm(
'R',
'U',
'T',
'N', -1, 0, alpha, a, 1,
b, 1 )
2064 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2066 CALL
dtrmm(
'L',
'L',
'N',
'N', -1, 0, alpha, a, 1,
b, 1 )
2067 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2069 CALL
dtrmm(
'L',
'L',
'T',
'N', -1, 0, alpha, a, 1,
b, 1 )
2070 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2072 CALL
dtrmm(
'R',
'L',
'N',
'N', -1, 0, alpha, a, 1,
b, 1 )
2073 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2075 CALL
dtrmm(
'R',
'L',
'T',
'N', -1, 0, alpha, a, 1,
b, 1 )
2076 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2078 CALL
dtrmm(
'L',
'U',
'N',
'N', 0, -1, alpha, a, 1,
b, 1 )
2079 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2081 CALL
dtrmm(
'L',
'U',
'T',
'N', 0, -1, alpha, a, 1,
b, 1 )
2082 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2084 CALL
dtrmm(
'R',
'U',
'N',
'N', 0, -1, alpha, a, 1,
b, 1 )
2085 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2087 CALL
dtrmm(
'R',
'U',
'T',
'N', 0, -1, alpha, a, 1,
b, 1 )
2088 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2090 CALL
dtrmm(
'L',
'L',
'N',
'N', 0, -1, alpha, a, 1,
b, 1 )
2091 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2093 CALL
dtrmm(
'L',
'L',
'T',
'N', 0, -1, alpha, a, 1,
b, 1 )
2094 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2096 CALL
dtrmm(
'R',
'L',
'N',
'N', 0, -1, alpha, a, 1,
b, 1 )
2097 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2099 CALL
dtrmm(
'R',
'L',
'T',
'N', 0, -1, alpha, a, 1,
b, 1 )
2100 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2102 CALL
dtrmm(
'L',
'U',
'N',
'N', 2, 0, alpha, a, 1,
b, 2 )
2103 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2105 CALL
dtrmm(
'L',
'U',
'T',
'N', 2, 0, alpha, a, 1,
b, 2 )
2106 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2108 CALL
dtrmm(
'R',
'U',
'N',
'N', 0, 2, alpha, a, 1,
b, 1 )
2109 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2111 CALL
dtrmm(
'R',
'U',
'T',
'N', 0, 2, alpha, a, 1,
b, 1 )
2112 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2114 CALL
dtrmm(
'L',
'L',
'N',
'N', 2, 0, alpha, a, 1,
b, 2 )
2115 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2117 CALL
dtrmm(
'L',
'L',
'T',
'N', 2, 0, alpha, a, 1,
b, 2 )
2118 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2120 CALL
dtrmm(
'R',
'L',
'N',
'N', 0, 2, alpha, a, 1,
b, 1 )
2121 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2123 CALL
dtrmm(
'R',
'L',
'T',
'N', 0, 2, alpha, a, 1,
b, 1 )
2124 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2126 CALL
dtrmm(
'L',
'U',
'N',
'N', 2, 0, alpha, a, 2,
b, 1 )
2127 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2129 CALL
dtrmm(
'L',
'U',
'T',
'N', 2, 0, alpha, a, 2,
b, 1 )
2130 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2132 CALL
dtrmm(
'R',
'U',
'N',
'N', 2, 0, alpha, a, 1,
b, 1 )
2133 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2135 CALL
dtrmm(
'R',
'U',
'T',
'N', 2, 0, alpha, a, 1,
b, 1 )
2136 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2138 CALL
dtrmm(
'L',
'L',
'N',
'N', 2, 0, alpha, a, 2,
b, 1 )
2139 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2141 CALL
dtrmm(
'L',
'L',
'T',
'N', 2, 0, alpha, a, 2,
b, 1 )
2142 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2144 CALL
dtrmm(
'R',
'L',
'N',
'N', 2, 0, alpha, a, 1,
b, 1 )
2145 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2147 CALL
dtrmm(
'R',
'L',
'T',
'N', 2, 0, alpha, a, 1,
b, 1 )
2148 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2151 CALL
dtrsm(
'/',
'U',
'N',
'N', 0, 0, alpha, a, 1,
b, 1 )
2152 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2154 CALL
dtrsm(
'L',
'/',
'N',
'N', 0, 0, alpha, a, 1,
b, 1 )
2155 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2157 CALL
dtrsm(
'L',
'U',
'/',
'N', 0, 0, alpha, a, 1,
b, 1 )
2158 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2160 CALL
dtrsm(
'L',
'U',
'N',
'/', 0, 0, alpha, a, 1,
b, 1 )
2161 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2163 CALL
dtrsm(
'L',
'U',
'N',
'N', -1, 0, alpha, a, 1,
b, 1 )
2164 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2166 CALL
dtrsm(
'L',
'U',
'T',
'N', -1, 0, alpha, a, 1,
b, 1 )
2167 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2169 CALL
dtrsm(
'R',
'U',
'N',
'N', -1, 0, alpha, a, 1,
b, 1 )
2170 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2172 CALL
dtrsm(
'R',
'U',
'T',
'N', -1, 0, alpha, a, 1,
b, 1 )
2173 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2175 CALL
dtrsm(
'L',
'L',
'N',
'N', -1, 0, alpha, a, 1,
b, 1 )
2176 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2178 CALL
dtrsm(
'L',
'L',
'T',
'N', -1, 0, alpha, a, 1,
b, 1 )
2179 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2181 CALL
dtrsm(
'R',
'L',
'N',
'N', -1, 0, alpha, a, 1,
b, 1 )
2182 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2184 CALL
dtrsm(
'R',
'L',
'T',
'N', -1, 0, alpha, a, 1,
b, 1 )
2185 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2187 CALL
dtrsm(
'L',
'U',
'N',
'N', 0, -1, alpha, a, 1,
b, 1 )
2188 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2190 CALL
dtrsm(
'L',
'U',
'T',
'N', 0, -1, alpha, a, 1,
b, 1 )
2191 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2193 CALL
dtrsm(
'R',
'U',
'N',
'N', 0, -1, alpha, a, 1,
b, 1 )
2194 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2196 CALL
dtrsm(
'R',
'U',
'T',
'N', 0, -1, alpha, a, 1,
b, 1 )
2197 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2199 CALL
dtrsm(
'L',
'L',
'N',
'N', 0, -1, alpha, a, 1,
b, 1 )
2200 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2202 CALL
dtrsm(
'L',
'L',
'T',
'N', 0, -1, alpha, a, 1,
b, 1 )
2203 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2205 CALL
dtrsm(
'R',
'L',
'N',
'N', 0, -1, alpha, a, 1,
b, 1 )
2206 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2208 CALL
dtrsm(
'R',
'L',
'T',
'N', 0, -1, alpha, a, 1,
b, 1 )
2209 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2211 CALL
dtrsm(
'L',
'U',
'N',
'N', 2, 0, alpha, a, 1,
b, 2 )
2212 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2214 CALL
dtrsm(
'L',
'U',
'T',
'N', 2, 0, alpha, a, 1,
b, 2 )
2215 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2217 CALL
dtrsm(
'R',
'U',
'N',
'N', 0, 2, alpha, a, 1,
b, 1 )
2218 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2220 CALL
dtrsm(
'R',
'U',
'T',
'N', 0, 2, alpha, a, 1,
b, 1 )
2221 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2223 CALL
dtrsm(
'L',
'L',
'N',
'N', 2, 0, alpha, a, 1,
b, 2 )
2224 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2226 CALL
dtrsm(
'L',
'L',
'T',
'N', 2, 0, alpha, a, 1,
b, 2 )
2227 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2229 CALL
dtrsm(
'R',
'L',
'N',
'N', 0, 2, alpha, a, 1,
b, 1 )
2230 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2232 CALL
dtrsm(
'R',
'L',
'T',
'N', 0, 2, alpha, a, 1,
b, 1 )
2233 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2235 CALL
dtrsm(
'L',
'U',
'N',
'N', 2, 0, alpha, a, 2,
b, 1 )
2236 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2238 CALL
dtrsm(
'L',
'U',
'T',
'N', 2, 0, alpha, a, 2,
b, 1 )
2239 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2241 CALL
dtrsm(
'R',
'U',
'N',
'N', 2, 0, alpha, a, 1,
b, 1 )
2242 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2244 CALL
dtrsm(
'R',
'U',
'T',
'N', 2, 0, alpha, a, 1,
b, 1 )
2245 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2247 CALL
dtrsm(
'L',
'L',
'N',
'N', 2, 0, alpha, a, 2,
b, 1 )
2248 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2250 CALL
dtrsm(
'L',
'L',
'T',
'N', 2, 0, alpha, a, 2,
b, 1 )
2251 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2253 CALL
dtrsm(
'R',
'L',
'N',
'N', 2, 0, alpha, a, 1,
b, 1 )
2254 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2256 CALL
dtrsm(
'R',
'L',
'T',
'N', 2, 0, alpha, a, 1,
b, 1 )
2257 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2260 CALL
dsyrk(
'/',
'N', 0, 0, alpha, a, 1, beta, c, 1 )
2261 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2263 CALL
dsyrk(
'U',
'/', 0, 0, alpha, a, 1, beta, c, 1 )
2264 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2266 CALL
dsyrk(
'U',
'N', -1, 0, alpha, a, 1, beta, c, 1 )
2267 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2269 CALL
dsyrk(
'U',
'T', -1, 0, alpha, a, 1, beta, c, 1 )
2270 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2272 CALL
dsyrk(
'L',
'N', -1, 0, alpha, a, 1, beta, c, 1 )
2273 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2275 CALL
dsyrk(
'L',
'T', -1, 0, alpha, a, 1, beta, c, 1 )
2276 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2278 CALL
dsyrk(
'U',
'N', 0, -1, alpha, a, 1, beta, c, 1 )
2279 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2281 CALL
dsyrk(
'U',
'T', 0, -1, alpha, a, 1, beta, c, 1 )
2282 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2284 CALL
dsyrk(
'L',
'N', 0, -1, alpha, a, 1, beta, c, 1 )
2285 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2287 CALL
dsyrk(
'L',
'T', 0, -1, alpha, a, 1, beta, c, 1 )
2288 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2290 CALL
dsyrk(
'U',
'N', 2, 0, alpha, a, 1, beta, c, 2 )
2291 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2293 CALL
dsyrk(
'U',
'T', 0, 2, alpha, a, 1, beta, c, 1 )
2294 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2296 CALL
dsyrk(
'L',
'N', 2, 0, alpha, a, 1, beta, c, 2 )
2297 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2299 CALL
dsyrk(
'L',
'T', 0, 2, alpha, a, 1, beta, c, 1 )
2300 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2302 CALL
dsyrk(
'U',
'N', 2, 0, alpha, a, 2, beta, c, 1 )
2303 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2305 CALL
dsyrk(
'U',
'T', 2, 0, alpha, a, 1, beta, c, 1 )
2306 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2308 CALL
dsyrk(
'L',
'N', 2, 0, alpha, a, 2, beta, c, 1 )
2309 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2311 CALL
dsyrk(
'L',
'T', 2, 0, alpha, a, 1, beta, c, 1 )
2312 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2315 CALL
dsyr2k(
'/',
'N', 0, 0, alpha, a, 1,
b, 1, beta, c, 1 )
2316 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2318 CALL
dsyr2k(
'U',
'/', 0, 0, alpha, a, 1,
b, 1, beta, c, 1 )
2319 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2321 CALL
dsyr2k(
'U',
'N', -1, 0, alpha, a, 1,
b, 1, beta, c, 1 )
2322 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2324 CALL
dsyr2k(
'U',
'T', -1, 0, alpha, a, 1,
b, 1, beta, c, 1 )
2325 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2327 CALL
dsyr2k(
'L',
'N', -1, 0, alpha, a, 1,
b, 1, beta, c, 1 )
2328 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2330 CALL
dsyr2k(
'L',
'T', -1, 0, alpha, a, 1,
b, 1, beta, c, 1 )
2331 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2333 CALL
dsyr2k(
'U',
'N', 0, -1, alpha, a, 1,
b, 1, beta, c, 1 )
2334 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2336 CALL
dsyr2k(
'U',
'T', 0, -1, alpha, a, 1,
b, 1, beta, c, 1 )
2337 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2339 CALL
dsyr2k(
'L',
'N', 0, -1, alpha, a, 1,
b, 1, beta, c, 1 )
2340 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2342 CALL
dsyr2k(
'L',
'T', 0, -1, alpha, a, 1,
b, 1, beta, c, 1 )
2343 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2345 CALL
dsyr2k(
'U',
'N', 2, 0, alpha, a, 1,
b, 1, beta, c, 2 )
2346 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2348 CALL
dsyr2k(
'U',
'T', 0, 2, alpha, a, 1,
b, 1, beta, c, 1 )
2349 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2351 CALL
dsyr2k(
'L',
'N', 2, 0, alpha, a, 1,
b, 1, beta, c, 2 )
2352 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2354 CALL
dsyr2k(
'L',
'T', 0, 2, alpha, a, 1,
b, 1, beta, c, 1 )
2355 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2357 CALL
dsyr2k(
'U',
'N', 2, 0, alpha, a, 2,
b, 1, beta, c, 2 )
2358 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2360 CALL
dsyr2k(
'U',
'T', 0, 2, alpha, a, 2,
b, 1, beta, c, 1 )
2361 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2363 CALL
dsyr2k(
'L',
'N', 2, 0, alpha, a, 2,
b, 1, beta, c, 2 )
2364 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2366 CALL
dsyr2k(
'L',
'T', 0, 2, alpha, a, 2,
b, 1, beta, c, 1 )
2367 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2369 CALL
dsyr2k(
'U',
'N', 2, 0, alpha, a, 2,
b, 2, beta, c, 1 )
2370 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2372 CALL
dsyr2k(
'U',
'T', 2, 0, alpha, a, 1,
b, 1, beta, c, 1 )
2373 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2375 CALL
dsyr2k(
'L',
'N', 2, 0, alpha, a, 2,
b, 2, beta, c, 1 )
2376 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2378 CALL
dsyr2k(
'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 dmake( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, RESET,
2413 DOUBLE PRECISION zero, one
2414 parameter( zero = 0.0d0, one = 1.0d0 )
2415 DOUBLE PRECISION rogue
2416 parameter( rogue = -1.0d10 )
2418 DOUBLE PRECISION transl
2419 INTEGER lda, m, n, nmax
2421 CHARACTER*1 diag, uplo
2424 DOUBLE PRECISION a( nmax, * ), aa( * )
2426 INTEGER i, ibeg, iend,
j
2427 LOGICAL gen, lower, sym, tri, unit, upper
2429 DOUBLE PRECISION dbeg
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 ) =
dbeg( 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 dmmch( TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB,
2509 $ beta, c, ldc, ct, g, cc, ldcc, eps, err, fatal,
2523 DOUBLE PRECISION zero, one
2524 parameter( zero = 0.0d0, one = 1.0d0 )
2526 DOUBLE PRECISION alpha, beta, eps, err
2527 INTEGER kk, lda, ldb, ldc, ldcc, m, n, nout
2529 CHARACTER*1 transa, transb
2531 DOUBLE PRECISION a( lda, * ),
b( ldb, * ), c( ldc, * ),
2532 $ cc( ldcc, * ), ct( * ), g( * )
2534 DOUBLE PRECISION erri
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( 1
x, i7, 2g18.6 )
2625 9997
FORMAT(
' THESE ARE THE RESULTS FOR COLUMN ', i3 )
2630 LOGICAL FUNCTION lde( RI, RJ, LR )
2645 DOUBLE PRECISION ri( * ), rj( * )
2650 IF( ri( i ).NE.rj( i ) )
2662 LOGICAL FUNCTION lderes( TYPE, UPLO, M, N, AA, AS, LDA )
2681 DOUBLE PRECISION 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 DOUBLE PRECISION FUNCTION dbeg( RESET )
2758 i = i - 1000*( i/1000 )
2763 dbeg = ( i - 500 )/1001.0d0
2780 DOUBLE PRECISION 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 dmake(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, KU, RESET, TRANSL)
DOUBLE PRECISION function ddiff(X, Y)
subroutine dgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
DGEMM
LOGICAL function lde(RI, RJ, LR)
subroutine dsymm(SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
DSYMM
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine chkxer(SRNAMT, INFOT, NOUT, LERR, OK)
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine dtrsm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
DTRSM
subroutine dsyrk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
DSYRK
subroutine dchke(ISNUM, SRNAMT, NOUT)
subroutine dchk4(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)
DOUBLE PRECISION function dbeg(RESET)
subroutine dchk3(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 dchk5(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)
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine dchk1(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 dmmch(TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB, BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL, NOUT, MV)
subroutine dsyr2k(UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
DSYR2K
subroutine dtrmm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
DTRMM
subroutine dchk2(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)
LOGICAL function lderes(TYPE, UPLO, M, N, AA, AS, LDA)