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 )
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 alahd(IOUNIT, PATH)
ALAHD
subroutine stbt06(RCOND, RCONDC, UPLO, DIAG, N, KD, AB, LDAB, WORK, RAT)
STBT06
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 stbt03(UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, SCALE, CNORM, TSCAL, X, LDX, B, LDB, WORK, RESID)
STBT03
real function slantb(NORM, UPLO, DIAG, N, K, AB, LDAB, WORK)
SLANTB 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.
subroutine stbcon(NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, IWORK, INFO)
STBCON
subroutine stbt05(UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
STBT05
subroutine slatbs(UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, SCALE, CNORM, INFO)
SLATBS solves a triangular banded system of equations.
subroutine serrtr(PATH, NUNIT)
SERRTR
subroutine sget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
SGET04
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 stbrfs(UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO)
STBRFS
logical function lsame(CA, CB)
LSAME
subroutine slattb(IMAT, UPLO, TRANS, DIAG, ISEED, N, KD, AB, LDAB, B, WORK, INFO)
SLATTB
subroutine stbt02(UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, X, LDX, B, LDB, WORK, RESID)
STBT02
subroutine stbsv(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX)
STBSV
real function slantr(NORM, UPLO, DIAG, M, N, A, LDA, WORK)
SLANTR 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 stbtrs(UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, INFO)
STBTRS
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM