154 SUBROUTINE schktb( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
155 $ nmax, ab, ainv, b, x, xact, work, rwork, iwork,
165 INTEGER NMAX, NN, NNS, NOUT
170 INTEGER IWORK( * ), NSVAL( * ), NVAL( * )
171 REAL 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 )
185 parameter( one = 1.0e+0, zero = 0.0e+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 REAL AINVNM, ANORM, RCOND, RCONDC, RCONDI, RCONDO,
197 CHARACTER TRANSS( ntran ), UPLOS( 2 )
198 INTEGER ISEED( 4 ), ISEEDY( 4 )
199 REAL RESULT( ntests )
204 EXTERNAL lsame, slantb, slantr
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 ) =
'Single precision'
238 iseed( i ) = iseedy( i )
244 $ CALL
serrtr( 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
slattb( imat, uplo,
'No transpose', diag, iseed,
295 $ n, kd, ab, ldab, x, work, info )
299 IF( lsame( diag,
'N' ) )
THEN
308 CALL
slaset(
'Full', n, n, zero, one, ainv, lda )
309 IF( lsame( uplo,
'U' ) )
THEN
311 CALL
stbsv( uplo,
'No transpose', diag, j, kd,
312 $ ab, ldab, ainv( ( j-1 )*lda+1 ), 1 )
316 CALL
stbsv( uplo,
'No transpose', diag, n-j+1,
317 $ kd, ab( ( j-1 )*ldab+1 ), ldab,
318 $ ainv( ( j-1 )*lda+j ), 1 )
324 anorm = slantb(
'1', uplo, diag, n, kd, ab, ldab,
326 ainvnm = slantr(
'1', uplo, diag, n, n, ainv, lda,
328 IF( anorm.LE.zero .OR. ainvnm.LE.zero )
THEN
331 rcondo = ( one / anorm ) / ainvnm
336 anorm = slantb(
'I', uplo, diag, n, kd, ab, ldab,
338 ainvnm = slantr(
'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
slarhs( path, xtype, uplo, trans, n, n, kd,
368 $ idiag, nrhs, ab, ldab, xact, lda,
369 $ b, lda, iseed, info )
371 CALL
slacpy(
'Full', n, nrhs, b, lda, x, lda )
374 CALL
stbtrs( uplo, trans, diag, n, kd, nrhs, ab,
375 $ ldab, x, lda, info )
380 $ CALL
alaerh( path,
'STBTRS', info, 0,
381 $ uplo // trans // diag, n, n, kd,
382 $ kd, nrhs, imat, nfail, nerrs,
385 CALL
stbt02( uplo, trans, diag, n, kd, nrhs, ab,
386 $ ldab, x, lda, b, lda, work,
392 CALL
sget04( n, nrhs, x, lda, xact, lda, rcondc,
400 CALL
stbrfs( uplo, trans, diag, n, kd, nrhs, ab,
401 $ ldab, b, lda, x, lda, rwork,
402 $ rwork( nrhs+1 ), work, iwork,
408 $ CALL
alaerh( path,
'STBRFS', info, 0,
409 $ uplo // trans // diag, n, n, kd,
410 $ kd, nrhs, imat, nfail, nerrs,
413 CALL
sget04( n, nrhs, x, lda, xact, lda, rcondc,
415 CALL
stbt05( 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
stbcon( norm, uplo, diag, n, kd, ab, ldab,
449 $ rcond, work, iwork, info )
454 $ CALL
alaerh( path,
'STBCON', info, 0,
455 $ norm // uplo // diag, n, n, kd, kd,
456 $ -1, imat, nfail, nerrs, nout )
458 CALL
stbt06( 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 )
'STBCON', 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
slattb( imat, uplo, trans, diag, iseed, n, kd,
500 $ ab, ldab, x, work, info )
506 CALL
scopy( n, x, 1, b, 1 )
507 CALL
slatbs( uplo, trans, diag,
'N', n, kd, ab,
508 $ ldab, b, scale, rwork, info )
513 $ CALL
alaerh( path,
'SLATBS', info, 0,
514 $ uplo // trans // diag //
'N', n, n,
515 $ kd, kd, -1, imat, nfail, nerrs,
518 CALL
stbt03( uplo, trans, diag, n, kd, 1, ab, ldab,
519 $ scale, rwork, one, b, lda, x, lda,
520 $ work, result( 7 ) )
525 CALL
scopy( n, x, 1, b, 1 )
526 CALL
slatbs( uplo, trans, diag,
'Y', n, kd, ab,
527 $ ldab, b, scale, rwork, info )
532 $ CALL
alaerh( path,
'SLATBS', info, 0,
533 $ uplo // trans // diag //
'Y', n, n,
534 $ kd, kd, -1, imat, nfail, nerrs,
537 CALL
stbt03( 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 )
'SLATBS', 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 )
'SLATBS', 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 slaset(UPLO, M, N, ALPHA, BETA, A, LDA)
SLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine stbcon(NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, IWORK, INFO)
STBCON
subroutine stbt02(UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, X, LDX, B, LDB, WORK, RESID)
STBT02
subroutine alahd(IOUNIT, PATH)
ALAHD
subroutine sget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
SGET04
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine slarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
SLARHS
subroutine schktb(DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, NMAX, AB, AINV, B, X, XACT, WORK, RWORK, IWORK, NOUT)
SCHKTB
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
subroutine stbrfs(UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO)
STBRFS
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
subroutine stbt06(RCOND, RCONDC, UPLO, DIAG, N, KD, AB, LDAB, WORK, RAT)
STBT06
subroutine stbsv(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX)
STBSV
subroutine slattb(IMAT, UPLO, TRANS, DIAG, ISEED, N, KD, AB, LDAB, B, WORK, INFO)
SLATTB
subroutine slatbs(UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, SCALE, CNORM, INFO)
SLATBS solves a triangular banded system of equations.
subroutine stbt05(UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
STBT05
subroutine serrtr(PATH, NUNIT)
SERRTR
subroutine stbt03(UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, SCALE, CNORM, TSCAL, X, LDX, B, LDB, WORK, RESID)
STBT03
subroutine stbtrs(UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, INFO)
STBTRS