188 SUBROUTINE ztbrfs( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B,
189 $ ldb, x, ldx, ferr, berr, work, rwork, info )
197 CHARACTER DIAG, TRANS, UPLO
198 INTEGER INFO, KD, LDAB, LDB, LDX, N, NRHS
201 DOUBLE PRECISION BERR( * ), FERR( * ), RWORK( * )
202 COMPLEX*16 AB( ldab, * ), B( ldb, * ), WORK( * ),
209 DOUBLE PRECISION ZERO
210 parameter ( zero = 0.0d+0 )
212 parameter ( one = ( 1.0d+0, 0.0d+0 ) )
215 LOGICAL NOTRAN, NOUNIT, UPPER
216 CHARACTER TRANSN, TRANST
217 INTEGER I, J, K, KASE, NZ
218 DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
228 INTRINSIC abs, dble, dimag, max, min
232 DOUBLE PRECISION DLAMCH
233 EXTERNAL lsame, dlamch
236 DOUBLE PRECISION CABS1
239 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) )
246 upper = lsame( uplo,
'U' )
247 notran = lsame( trans,
'N' )
248 nounit = lsame( diag,
'N' )
250 IF( .NOT.upper .AND. .NOT.lsame( uplo,
'L' ) )
THEN
252 ELSE IF( .NOT.notran .AND. .NOT.lsame( trans,
'T' ) .AND. .NOT.
253 $ lsame( trans,
'C' ) )
THEN
255 ELSE IF( .NOT.nounit .AND. .NOT.lsame( diag,
'U' ) )
THEN
257 ELSE IF( n.LT.0 )
THEN
259 ELSE IF( kd.LT.0 )
THEN
261 ELSE IF( nrhs.LT.0 )
THEN
263 ELSE IF( ldab.LT.kd+1 )
THEN
265 ELSE IF( ldb.LT.max( 1, n ) )
THEN
267 ELSE IF( ldx.LT.max( 1, n ) )
THEN
271 CALL xerbla(
'ZTBRFS', -info )
277 IF( n.EQ.0 .OR. nrhs.EQ.0 )
THEN
296 eps = dlamch(
'Epsilon' )
297 safmin = dlamch(
'Safe minimum' )
308 CALL zcopy( n, x( 1, j ), 1, work, 1 )
309 CALL ztbmv( uplo, trans, diag, n, kd, ab, ldab, work, 1 )
310 CALL zaxpy( n, -one, b( 1, j ), 1, work, 1 )
322 rwork( i ) = cabs1( b( i, j ) )
332 xk = cabs1( x( k, j ) )
333 DO 30 i = max( 1, k-kd ), k
334 rwork( i ) = rwork( i ) +
335 $ cabs1( ab( kd+1+i-k, k ) )*xk
340 xk = cabs1( x( k, j ) )
341 DO 50 i = max( 1, k-kd ), k - 1
342 rwork( i ) = rwork( i ) +
343 $ cabs1( ab( kd+1+i-k, k ) )*xk
345 rwork( k ) = rwork( k ) + xk
351 xk = cabs1( x( k, j ) )
352 DO 70 i = k, min( n, k+kd )
353 rwork( i ) = rwork( i ) +
354 $ cabs1( ab( 1+i-k, k ) )*xk
359 xk = cabs1( x( k, j ) )
360 DO 90 i = k + 1, min( n, k+kd )
361 rwork( i ) = rwork( i ) +
362 $ cabs1( ab( 1+i-k, k ) )*xk
364 rwork( k ) = rwork( k ) + xk
376 DO 110 i = max( 1, k-kd ), k
377 s = s + cabs1( ab( kd+1+i-k, k ) )*
380 rwork( k ) = rwork( k ) + s
384 s = cabs1( x( k, j ) )
385 DO 130 i = max( 1, k-kd ), k - 1
386 s = s + cabs1( ab( kd+1+i-k, k ) )*
389 rwork( k ) = rwork( k ) + s
396 DO 150 i = k, min( n, k+kd )
397 s = s + cabs1( ab( 1+i-k, k ) )*
400 rwork( k ) = rwork( k ) + s
404 s = cabs1( x( k, j ) )
405 DO 170 i = k + 1, min( n, k+kd )
406 s = s + cabs1( ab( 1+i-k, k ) )*
409 rwork( k ) = rwork( k ) + s
416 IF( rwork( i ).GT.safe2 )
THEN
417 s = max( s, cabs1( work( i ) ) / rwork( i ) )
419 s = max( s, ( cabs1( work( i ) )+safe1 ) /
420 $ ( rwork( i )+safe1 ) )
448 IF( rwork( i ).GT.safe2 )
THEN
449 rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
451 rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +
458 CALL zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
464 CALL ztbsv( uplo, transt, diag, n, kd, ab, ldab, work,
467 work( i ) = rwork( i )*work( i )
474 work( i ) = rwork( i )*work( i )
476 CALL ztbsv( uplo, transn, diag, n, kd, ab, ldab, work,
486 lstres = max( lstres, cabs1( x( i, j ) ) )
489 $ ferr( j ) = ferr( j ) / lstres
subroutine zcopy(N, ZX, INCX, ZY, INCY)
ZCOPY
subroutine ztbmv(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX)
ZTBMV
subroutine zlacn2(N, V, X, EST, KASE, ISAVE)
ZLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vec...
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine ztbsv(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX)
ZTBSV
subroutine ztbrfs(UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO)
ZTBRFS
subroutine zaxpy(N, ZA, ZX, INCX, ZY, INCY)
ZAXPY