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( 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 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( 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 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( 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 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( 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 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
1293 EXTERNAL lde, lderes
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( 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 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
1568 EXTERNAL lde, lderes
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( 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 *',
1840 SUBROUTINE dchke( ISNUM, SRNAMT, NOUT )
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( 1x, 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
2769 DOUBLE PRECISION FUNCTION ddiff( X, Y )
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,
' *****' )
2818 SUBROUTINE xerbla( SRNAME, INFO )
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 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)
subroutine dtrsm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
DTRSM
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 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 dsymm(SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
DSYMM
subroutine dtrmm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
DTRMM
subroutine dmake(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, KU, RESET, TRANSL)
subroutine dmmch(TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB, BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL, NOUT, MV)
logical function lde(RI, RJ, LR)
double precision function ddiff(X, Y)
subroutine dsyr2k(UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
DSYR2K
subroutine dgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
DGEMM
subroutine dsyrk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
DSYRK
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)
subroutine chkxer(SRNAMT, INFOT, NOUT, LERR, OK)
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)
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine dchke(ISNUM, SRNAMT, NOUT)
double precision function dbeg(RESET)
logical function lderes(TYPE, UPLO, M, N, AA, AS, LDA)