184 SUBROUTINE ztbrfs( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B,
185 $ LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )
192 CHARACTER DIAG, TRANS, UPLO
193 INTEGER INFO, KD, LDAB, LDB, LDX, N, NRHS
196 DOUBLE PRECISION BERR( * ), FERR( * ), RWORK( * )
197 COMPLEX*16 AB( LDAB, * ), B( LDB, * ), WORK( * ),
204 DOUBLE PRECISION ZERO
205 parameter( zero = 0.0d+0 )
207 parameter( one = ( 1.0d+0, 0.0d+0 ) )
210 LOGICAL NOTRAN, NOUNIT, UPPER
211 CHARACTER TRANSN, TRANST
212 INTEGER I, J, K, KASE, NZ
213 DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
224 INTRINSIC abs, dble, dimag, max, min
228 DOUBLE PRECISION DLAMCH
229 EXTERNAL lsame, dlamch
232 DOUBLE PRECISION CABS1
235 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) )
242 upper = lsame( uplo,
'U' )
243 notran = lsame( trans,
'N' )
244 nounit = lsame( diag,
'N' )
246 IF( .NOT.upper .AND. .NOT.lsame( uplo,
'L' ) )
THEN
248 ELSE IF( .NOT.notran .AND. .NOT.lsame( trans,
'T' ) .AND. .NOT.
249 $ lsame( trans,
'C' ) )
THEN
251 ELSE IF( .NOT.nounit .AND. .NOT.lsame( diag,
'U' ) )
THEN
253 ELSE IF( n.LT.0 )
THEN
255 ELSE IF( kd.LT.0 )
THEN
257 ELSE IF( nrhs.LT.0 )
THEN
259 ELSE IF( ldab.LT.kd+1 )
THEN
261 ELSE IF( ldb.LT.max( 1, n ) )
THEN
263 ELSE IF( ldx.LT.max( 1, n ) )
THEN
267 CALL xerbla(
'ZTBRFS', -info )
273 IF( n.EQ.0 .OR. nrhs.EQ.0 )
THEN
292 eps = dlamch(
'Epsilon' )
293 safmin = dlamch(
'Safe minimum' )
304 CALL zcopy( n, x( 1, j ), 1, work, 1 )
305 CALL ztbmv( uplo, trans, diag, n, kd, ab, ldab, work, 1 )
306 CALL zaxpy( n, -one, b( 1, j ), 1, work, 1 )
318 rwork( i ) = cabs1( b( i, j ) )
328 xk = cabs1( x( k, j ) )
329 DO 30 i = max( 1, k-kd ), k
330 rwork( i ) = rwork( i ) +
331 $ cabs1( ab( kd+1+i-k, k ) )*xk
336 xk = cabs1( x( k, j ) )
337 DO 50 i = max( 1, k-kd ), k - 1
338 rwork( i ) = rwork( i ) +
339 $ cabs1( ab( kd+1+i-k, k ) )*xk
341 rwork( k ) = rwork( k ) + xk
347 xk = cabs1( x( k, j ) )
348 DO 70 i = k, min( n, k+kd )
349 rwork( i ) = rwork( i ) +
350 $ cabs1( ab( 1+i-k, k ) )*xk
355 xk = cabs1( x( k, j ) )
356 DO 90 i = k + 1, min( n, k+kd )
357 rwork( i ) = rwork( i ) +
358 $ cabs1( ab( 1+i-k, k ) )*xk
360 rwork( k ) = rwork( k ) + xk
372 DO 110 i = max( 1, k-kd ), k
373 s = s + cabs1( ab( kd+1+i-k, k ) )*
376 rwork( k ) = rwork( k ) + s
380 s = cabs1( x( k, j ) )
381 DO 130 i = max( 1, k-kd ), k - 1
382 s = s + cabs1( ab( kd+1+i-k, k ) )*
385 rwork( k ) = rwork( k ) + s
392 DO 150 i = k, min( n, k+kd )
393 s = s + cabs1( ab( 1+i-k, k ) )*
396 rwork( k ) = rwork( k ) + s
400 s = cabs1( x( k, j ) )
401 DO 170 i = k + 1, min( n, k+kd )
402 s = s + cabs1( ab( 1+i-k, k ) )*
405 rwork( k ) = rwork( k ) + s
412 IF( rwork( i ).GT.safe2 )
THEN
413 s = max( s, cabs1( work( i ) ) / rwork( i ) )
415 s = max( s, ( cabs1( work( i ) )+safe1 ) /
416 $ ( rwork( i )+safe1 ) )
444 IF( rwork( i ).GT.safe2 )
THEN
445 rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
447 rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +
454 CALL zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
460 CALL ztbsv( uplo, transt, diag, n, kd, ab, ldab, work,
463 work( i ) = rwork( i )*work( i )
470 work( i ) = rwork( i )*work( i )
472 CALL ztbsv( uplo, transn, diag, n, kd, ab, ldab, work,
482 lstres = max( lstres, cabs1( x( i, j ) ) )
485 $ ferr( j ) = ferr( j ) / lstres