189 SUBROUTINE zpbrfs( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B,
190 $ ldb, x, ldx, ferr, berr, work, rwork, info )
199 INTEGER INFO, KD, LDAB, LDAFB, LDB, LDX, N, NRHS
202 DOUBLE PRECISION BERR( * ), FERR( * ), RWORK( * )
203 COMPLEX*16 AB( ldab, * ), AFB( ldafb, * ), B( ldb, * ),
204 $ work( * ), x( ldx, * )
211 parameter ( itmax = 5 )
212 DOUBLE PRECISION ZERO
213 parameter ( zero = 0.0d+0 )
215 parameter ( one = ( 1.0d+0, 0.0d+0 ) )
217 parameter ( two = 2.0d+0 )
218 DOUBLE PRECISION THREE
219 parameter ( three = 3.0d+0 )
223 INTEGER COUNT, I, J, K, KASE, L, NZ
224 DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
234 INTRINSIC abs, dble, dimag, max, min
238 DOUBLE PRECISION DLAMCH
239 EXTERNAL lsame, dlamch
242 DOUBLE PRECISION CABS1
245 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) )
252 upper = lsame( uplo,
'U' )
253 IF( .NOT.upper .AND. .NOT.lsame( uplo,
'L' ) )
THEN
255 ELSE IF( n.LT.0 )
THEN
257 ELSE IF( kd.LT.0 )
THEN
259 ELSE IF( nrhs.LT.0 )
THEN
261 ELSE IF( ldab.LT.kd+1 )
THEN
263 ELSE IF( ldafb.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(
'ZPBRFS', -info )
277 IF( n.EQ.0 .OR. nrhs.EQ.0 )
THEN
287 nz = min( n+1, 2*kd+2 )
288 eps = dlamch(
'Epsilon' )
289 safmin = dlamch(
'Safe minimum' )
305 CALL zcopy( n, b( 1, j ), 1, work, 1 )
306 CALL zhbmv( uplo, n, kd, -one, ab, ldab, x( 1, j ), 1, one,
319 rwork( i ) = cabs1( b( i, j ) )
327 xk = cabs1( x( k, j ) )
329 DO 40 i = max( 1, k-kd ), k - 1
330 rwork( i ) = rwork( i ) + cabs1( ab( l+i, k ) )*xk
331 s = s + cabs1( ab( l+i, k ) )*cabs1( x( i, j ) )
333 rwork( k ) = rwork( k ) + abs( dble( ab( kd+1, k ) ) )*
339 xk = cabs1( x( k, j ) )
340 rwork( k ) = rwork( k ) + abs( dble( ab( 1, k ) ) )*xk
342 DO 60 i = k + 1, min( n, k+kd )
343 rwork( i ) = rwork( i ) + cabs1( ab( l+i, k ) )*xk
344 s = s + cabs1( ab( l+i, k ) )*cabs1( x( i, j ) )
346 rwork( k ) = rwork( k ) + s
351 IF( rwork( i ).GT.safe2 )
THEN
352 s = max( s, cabs1( work( i ) ) / rwork( i ) )
354 s = max( s, ( cabs1( work( i ) )+safe1 ) /
355 $ ( rwork( i )+safe1 ) )
366 IF( berr( j ).GT.eps .AND. two*berr( j ).LE.lstres .AND.
367 $ count.LE.itmax )
THEN
371 CALL zpbtrs( uplo, n, kd, 1, afb, ldafb, work, n, info )
372 CALL zaxpy( n, one, work, 1, x( 1, j ), 1 )
401 IF( rwork( i ).GT.safe2 )
THEN
402 rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
404 rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +
411 CALL zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
417 CALL zpbtrs( uplo, n, kd, 1, afb, ldafb, work, n, info )
419 work( i ) = rwork( i )*work( i )
421 ELSE IF( kase.EQ.2 )
THEN
426 work( i ) = rwork( i )*work( i )
428 CALL zpbtrs( uplo, n, kd, 1, afb, ldafb, work, n, info )
437 lstres = max( lstres, cabs1( x( i, j ) ) )
440 $ ferr( j ) = ferr( j ) / lstres
subroutine zpbtrs(UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO)
ZPBTRS
subroutine zcopy(N, ZX, INCX, ZY, INCY)
ZCOPY
subroutine zpbrfs(UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO)
ZPBRFS
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 zhbmv(UPLO, N, K, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
ZHBMV
subroutine zaxpy(N, ZA, ZX, INCX, ZY, INCY)
ZAXPY