189 SUBROUTINE cpbrfs( 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 REAL berr( * ), ferr( * ), rwork( * )
203 COMPLEX ab( ldab, * ), afb( ldafb, * ),
b( ldb, * ),
204 $ work( * ), x( ldx, * )
211 parameter( itmax = 5 )
213 parameter( zero = 0.0e+0 )
215 parameter( one = ( 1.0e+0, 0.0e+0 ) )
217 parameter( two = 2.0e+0 )
219 parameter( three = 3.0e+0 )
223 INTEGER count, i,
j, k, kase, l, nz
224 REAL eps, lstres, s, safe1, safe2, safmin, xk
234 INTRINSIC abs, aimag, max, min, real
245 cabs1( zdum ) = abs(
REAL( ZDUM ) ) + abs( aimag( 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(
'CPBRFS', -info )
277 IF( n.EQ.0 .OR. nrhs.EQ.0 )
THEN
287 nz = min( n+1, 2*kd+2 )
289 safmin =
slamch(
'Safe minimum' )
305 CALL
ccopy( n,
b( 1,
j ), 1, work, 1 )
306 CALL
chbmv( 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(
REAL( AB( KD+1, K ) ) )*
339 xk = cabs1( x( k,
j ) )
340 rwork( k ) = rwork( k ) + abs(
REAL( 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
cpbtrs( uplo, n, kd, 1, afb, ldafb, work, n, info )
372 CALL
caxpy( 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
clacn2( n, work( n+1 ), work, ferr(
j ), kase, isave )
417 CALL
cpbtrs( 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
cpbtrs( uplo, n, kd, 1, afb, ldafb, work, n, info )
437 lstres = max( lstres, cabs1( x( i,
j ) ) )
440 $ ferr(
j ) = ferr(
j ) / lstres
subroutine caxpy(N, CA, CX, INCX, CY, INCY)
CAXPY
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine cpbrfs(UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO)
CPBRFS
subroutine cpbtrs(UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO)
CPBTRS
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
logical function lsame(CA, CB)
LSAME
subroutine chbmv(UPLO, N, K, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
CHBMV
real function slamch(CMACH)
SLAMCH
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY
subroutine clacn2(N, V, X, EST, KASE, ISAVE)
CLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vec...