188 SUBROUTINE dtbrfs( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B,
189 $ ldb,
x, ldx, ferr, berr, work, iwork, info )
197 CHARACTER diag, trans, uplo
198 INTEGER info, kd, ldab, ldb, ldx, n, nrhs
202 DOUBLE PRECISION ab( ldab, * ),
b( ldb, * ), berr( * ),
203 $ ferr( * ), work( * ),
x( ldx, * )
209 DOUBLE PRECISION zero
210 parameter( zero = 0.0d+0 )
212 parameter( one = 1.0d+0 )
215 LOGICAL notran, nounit, upper
217 INTEGER i,
j, k, kase, nz
218 DOUBLE PRECISION eps, lstres, s, safe1, safe2, safmin, xk
227 INTRINSIC abs, max, min
239 upper =
lsame( uplo,
'U' )
240 notran =
lsame( trans,
'N' )
241 nounit =
lsame( diag,
'N' )
243 IF( .NOT.upper .AND. .NOT.
lsame( uplo,
'L' ) )
THEN
245 ELSE IF( .NOT.notran .AND. .NOT.
lsame( trans,
'T' ) .AND. .NOT.
246 $
lsame( trans,
'C' ) )
THEN
248 ELSE IF( .NOT.nounit .AND. .NOT.
lsame( diag,
'U' ) )
THEN
250 ELSE IF( n.LT.0 )
THEN
252 ELSE IF( kd.LT.0 )
THEN
254 ELSE IF( nrhs.LT.0 )
THEN
256 ELSE IF( ldab.LT.kd+1 )
THEN
258 ELSE IF( ldb.LT.max( 1, n ) )
THEN
260 ELSE IF( ldx.LT.max( 1, n ) )
THEN
264 CALL
xerbla(
'DTBRFS', -info )
270 IF( n.EQ.0 .OR. nrhs.EQ.0 )
THEN
288 safmin =
dlamch(
'Safe minimum' )
299 CALL
dcopy( n,
x( 1,
j ), 1, work( n+1 ), 1 )
300 CALL
dtbmv( uplo, trans, diag, n, kd, ab, ldab, work( n+1 ),
302 CALL
daxpy( n, -one,
b( 1,
j ), 1, work( n+1 ), 1 )
314 work( i ) = abs(
b( i,
j ) )
324 xk = abs(
x( k,
j ) )
325 DO 30 i = max( 1, k-kd ), k
326 work( i ) = work( i ) +
327 $ abs( ab( kd+1+i-k, k ) )*xk
332 xk = abs(
x( k,
j ) )
333 DO 50 i = max( 1, k-kd ), k - 1
334 work( i ) = work( i ) +
335 $ abs( ab( kd+1+i-k, k ) )*xk
337 work( k ) = work( k ) + xk
343 xk = abs(
x( k,
j ) )
344 DO 70 i = k, min( n, k+kd )
345 work( i ) = work( i ) + abs( ab( 1+i-k, k ) )*xk
350 xk = abs(
x( k,
j ) )
351 DO 90 i = k + 1, min( n, k+kd )
352 work( i ) = work( i ) + abs( ab( 1+i-k, k ) )*xk
354 work( k ) = work( k ) + xk
366 DO 110 i = max( 1, k-kd ), k
367 s = s + abs( ab( kd+1+i-k, k ) )*
370 work( k ) = work( k ) + s
375 DO 130 i = max( 1, k-kd ), k - 1
376 s = s + abs( ab( kd+1+i-k, k ) )*
379 work( k ) = work( k ) + s
386 DO 150 i = k, min( n, k+kd )
387 s = s + abs( ab( 1+i-k, k ) )*abs(
x( i,
j ) )
389 work( k ) = work( k ) + s
394 DO 170 i = k + 1, min( n, k+kd )
395 s = s + abs( ab( 1+i-k, k ) )*abs(
x( i,
j ) )
397 work( k ) = work( k ) + s
404 IF( work( i ).GT.safe2 )
THEN
405 s = max( s, abs( work( n+i ) ) / work( i ) )
407 s = max( s, ( abs( work( n+i ) )+safe1 ) /
408 $ ( work( i )+safe1 ) )
436 IF( work( i ).GT.safe2 )
THEN
437 work( i ) = abs( work( n+i ) ) + nz*eps*work( i )
439 work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) + safe1
445 CALL
dlacn2( n, work( 2*n+1 ), work( n+1 ), iwork, ferr(
j ),
452 CALL
dtbsv( uplo, transt, diag, n, kd, ab, ldab,
455 work( n+i ) = work( i )*work( n+i )
462 work( n+i ) = work( i )*work( n+i )
464 CALL
dtbsv( uplo, trans, diag, n, kd, ab, ldab,
474 lstres = max( lstres, abs(
x( i,
j ) ) )
477 $ ferr(
j ) = ferr(
j ) / lstres
subroutine dtbsv(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX)
DTBSV
LOGICAL function lsame(CA, CB)
LSAME
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
subroutine xerbla(SRNAME, INFO)
XERBLA
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine dtbmv(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX)
DTBMV
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine daxpy(N, DA, DX, INCX, DY, INCY)
DAXPY
subroutine dlacn2(N, V, X, ISGN, EST, KASE, ISAVE)
DLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vec...
DOUBLE PRECISION function dlamch(CMACH)
DLAMCH
subroutine dtbrfs(UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO)
DTBRFS