165 INTEGER nmax, nn, nns, nout
166 DOUBLE PRECISION thresh
170 INTEGER iwork( * ), nsval( * ), nval( * )
171 DOUBLE PRECISION ab( * ), ainv( * ), b( * ), rwork( * ),
172 $ work( * ), x( * ), xact( * )
178 INTEGER ntype1, ntypes
179 parameter ( ntype1 = 9, ntypes = 17 )
181 parameter ( ntests = 8 )
183 parameter ( ntran = 3 )
184 DOUBLE PRECISION one, zero
185 parameter ( one = 1.0d+0, zero = 0.0d+0 )
188 CHARACTER diag, norm, trans, uplo, xtype
190 INTEGER i, idiag, ik, imat, in, info, irhs, itran,
191 $ iuplo, j, k, kd, lda, ldab, n, nerrs, nfail,
192 $ nimat, nimat2, nk, nrhs, nrun
193 DOUBLE PRECISION ainvnm, anorm, rcond, rcondc, rcondi, rcondo,
197 CHARACTER transs( ntran ), uplos( 2 )
198 INTEGER iseed( 4 ), iseedy( 4 )
199 DOUBLE PRECISION result( ntests )
215 INTEGER infot, iounit
218 COMMON / infoc / infot, iounit, ok, lerr
219 COMMON / srnamc / srnamt
225 DATA iseedy / 1988, 1989, 1990, 1991 /
226 DATA uplos /
'U',
'L' / , transs /
'N',
'T',
'C' /
232 path( 1: 1 ) =
'Double precision'
238 iseed( i ) = iseedy( i )
244 $
CALL derrtr( path, nout )
269 ELSE IF( ik.EQ.2 )
THEN
271 ELSE IF( ik.EQ.3 )
THEN
273 ELSE IF( ik.EQ.4 )
THEN
278 DO 90 imat = 1, nimat
282 IF( .NOT.dotype( imat ) )
289 uplo = uplos( iuplo )
294 CALL dlattb( imat, uplo,
'No transpose', diag, iseed,
295 $ n, kd, ab, ldab, x, work, info )
299 IF(
lsame( diag,
'N' ) )
THEN
308 CALL dlaset(
'Full', n, n, zero, one, ainv, lda )
309 IF(
lsame( uplo,
'U' ) )
THEN
311 CALL dtbsv( uplo,
'No transpose', diag, j, kd,
312 $ ab, ldab, ainv( ( j-1 )*lda+1 ), 1 )
316 CALL dtbsv( uplo,
'No transpose', diag, n-j+1,
317 $ kd, ab( ( j-1 )*ldab+1 ), ldab,
318 $ ainv( ( j-1 )*lda+j ), 1 )
324 anorm =
dlantb(
'1', uplo, diag, n, kd, ab, ldab,
326 ainvnm =
dlantr(
'1', uplo, diag, n, n, ainv, lda,
328 IF( anorm.LE.zero .OR. ainvnm.LE.zero )
THEN
331 rcondo = ( one / anorm ) / ainvnm
336 anorm =
dlantb(
'I', uplo, diag, n, kd, ab, ldab,
338 ainvnm =
dlantr(
'I', uplo, diag, n, n, ainv, lda,
340 IF( anorm.LE.zero .OR. ainvnm.LE.zero )
THEN
343 rcondi = ( one / anorm ) / ainvnm
350 DO 50 itran = 1, ntran
354 trans = transs( itran )
355 IF( itran.EQ.1 )
THEN
367 CALL dlarhs( path, xtype, uplo, trans, n, n, kd,
368 $ idiag, nrhs, ab, ldab, xact, lda,
369 $ b, lda, iseed, info )
371 CALL dlacpy(
'Full', n, nrhs, b, lda, x, lda )
374 CALL dtbtrs( uplo, trans, diag, n, kd, nrhs, ab,
375 $ ldab, x, lda, info )
380 $
CALL alaerh( path,
'DTBTRS', info, 0,
381 $ uplo // trans // diag, n, n, kd,
382 $ kd, nrhs, imat, nfail, nerrs,
385 CALL dtbt02( uplo, trans, diag, n, kd, nrhs, ab,
386 $ ldab, x, lda, b, lda, work,
392 CALL dget04( n, nrhs, x, lda, xact, lda, rcondc,
400 CALL dtbrfs( uplo, trans, diag, n, kd, nrhs, ab,
401 $ ldab, b, lda, x, lda, rwork,
402 $ rwork( nrhs+1 ), work, iwork,
408 $
CALL alaerh( path,
'DTBRFS', info, 0,
409 $ uplo // trans // diag, n, n, kd,
410 $ kd, nrhs, imat, nfail, nerrs,
413 CALL dget04( n, nrhs, x, lda, xact, lda, rcondc,
415 CALL dtbt05( uplo, trans, diag, n, kd, nrhs, ab,
416 $ ldab, b, lda, x, lda, xact, lda,
417 $ rwork, rwork( nrhs+1 ),
424 IF( result( k ).GE.thresh )
THEN
425 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
426 $
CALL alahd( nout, path )
427 WRITE( nout, fmt = 9999 )uplo, trans,
428 $ diag, n, kd, nrhs, imat, k, result( k )
440 IF( itran.EQ.1 )
THEN
448 CALL dtbcon( norm, uplo, diag, n, kd, ab, ldab,
449 $ rcond, work, iwork, info )
454 $
CALL alaerh( path,
'DTBCON', info, 0,
455 $ norm // uplo // diag, n, n, kd, kd,
456 $ -1, imat, nfail, nerrs, nout )
458 CALL dtbt06( rcond, rcondc, uplo, diag, n, kd, ab,
459 $ ldab, rwork, result( 6 ) )
464 IF( result( 6 ).GE.thresh )
THEN
465 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
466 $
CALL alahd( nout, path )
467 WRITE( nout, fmt = 9998 )
'DTBCON', norm, uplo,
468 $ diag, n, kd, imat, 6, result( 6 )
478 DO 120 imat = ntype1 + 1, nimat2
482 IF( .NOT.dotype( imat ) )
489 uplo = uplos( iuplo )
490 DO 100 itran = 1, ntran
494 trans = transs( itran )
499 CALL dlattb( imat, uplo, trans, diag, iseed, n, kd,
500 $ ab, ldab, x, work, info )
506 CALL dcopy( n, x, 1, b, 1 )
507 CALL dlatbs( uplo, trans, diag,
'N', n, kd, ab,
508 $ ldab, b, scale, rwork, info )
513 $
CALL alaerh( path,
'DLATBS', info, 0,
514 $ uplo // trans // diag //
'N', n, n,
515 $ kd, kd, -1, imat, nfail, nerrs,
518 CALL dtbt03( uplo, trans, diag, n, kd, 1, ab, ldab,
519 $ scale, rwork, one, b, lda, x, lda,
520 $ work, result( 7 ) )
525 CALL dcopy( n, x, 1, b, 1 )
526 CALL dlatbs( uplo, trans, diag,
'Y', n, kd, ab,
527 $ ldab, b, scale, rwork, info )
532 $
CALL alaerh( path,
'DLATBS', info, 0,
533 $ uplo // trans // diag //
'Y', n, n,
534 $ kd, kd, -1, imat, nfail, nerrs,
537 CALL dtbt03( uplo, trans, diag, n, kd, 1, ab, ldab,
538 $ scale, rwork, one, b, lda, x, lda,
539 $ work, result( 8 ) )
544 IF( result( 7 ).GE.thresh )
THEN
545 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
546 $
CALL alahd( nout, path )
547 WRITE( nout, fmt = 9997 )
'DLATBS', uplo, trans,
548 $ diag,
'N', n, kd, imat, 7, result( 7 )
551 IF( result( 8 ).GE.thresh )
THEN
552 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
553 $
CALL alahd( nout, path )
554 WRITE( nout, fmt = 9997 )
'DLATBS', uplo, trans,
555 $ diag,
'Y', n, kd, imat, 8, result( 8 )
567 CALL alasum( path, nout, nfail, nrun, nerrs )
569 9999
FORMAT(
' UPLO=''', a1,
''', TRANS=''', a1,
''',
570 $ DIAG=''', a1,
''', N=', i5,
', KD=', i5,
', NRHS=', i5,
571 $
', type ', i2,
', test(', i2,
')=', g12.5 )
572 9998
FORMAT( 1x, a,
'( ''', a1,
''', ''', a1,
''', ''', a1,
''',',
573 $ i5,
',', i5,
', ... ), type ', i2,
', test(', i2,
')=',
575 9997
FORMAT( 1x, a,
'( ''', a1,
''', ''', a1,
''', ''', a1,
''', ''',
576 $ a1,
''',', i5,
',', i5,
', ... ), type ', i2,
', test(',
subroutine dlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine alahd(IOUNIT, PATH)
ALAHD
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine dlarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
DLARHS
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
subroutine dtbsv(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX)
DTBSV
subroutine dtbcon(NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, IWORK, INFO)
DTBCON
subroutine dtbtrs(UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, INFO)
DTBTRS
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
subroutine dtbt05(UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
DTBT05
subroutine dtbt03(UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, SCALE, CNORM, TSCAL, X, LDX, B, LDB, WORK, RESID)
DTBT03
subroutine dtbt02(UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, X, LDX, B, LDB, WORK, RESID)
DTBT02
subroutine dlattb(IMAT, UPLO, TRANS, DIAG, ISEED, N, KD, AB, LDAB, B, WORK, INFO)
DLATTB
subroutine dtbt06(RCOND, RCONDC, UPLO, DIAG, N, KD, AB, LDAB, WORK, RAT)
DTBT06
subroutine dget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
DGET04
subroutine derrtr(PATH, NUNIT)
DERRTR
double precision function dlantr(NORM, UPLO, DIAG, M, N, A, LDA, WORK)
DLANTR returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a trapezoidal or triangular matrix.
subroutine dtbrfs(UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO)
DTBRFS
subroutine dlatbs(UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, SCALE, CNORM, INFO)
DLATBS solves a triangular banded system of equations.
double precision function dlantb(NORM, UPLO, DIAG, N, K, AB, LDAB, WORK)
DLANTB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a triangular band matrix.
logical function lsame(CA, CB)
LSAME
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM