180 SUBROUTINE chprfs( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX,
181 $ ferr, berr, work, rwork, info )
190 INTEGER info, ldb, ldx, n, nrhs
194 REAL berr( * ), ferr( * ), rwork( * )
195 COMPLEX afp( * ), ap( * ),
b( ldb, * ), work( * ),
203 parameter( itmax = 5 )
205 parameter( zero = 0.0e+0 )
207 parameter( one = ( 1.0e+0, 0.0e+0 ) )
209 parameter( two = 2.0e+0 )
211 parameter( three = 3.0e+0 )
215 INTEGER count, i, ik,
j, k, kase, kk, nz
216 REAL eps, lstres, s, safe1, safe2, safmin, xk
226 INTRINSIC abs, aimag, max, real
237 cabs1( zdum ) = abs(
REAL( ZDUM ) ) + abs( aimag( zdum ) )
244 upper =
lsame( uplo,
'U' )
245 IF( .NOT.upper .AND. .NOT.
lsame( uplo,
'L' ) )
THEN
247 ELSE IF( n.LT.0 )
THEN
249 ELSE IF( nrhs.LT.0 )
THEN
251 ELSE IF( ldb.LT.max( 1, n ) )
THEN
253 ELSE IF( ldx.LT.max( 1, n ) )
THEN
257 CALL
xerbla(
'CHPRFS', -info )
263 IF( n.EQ.0 .OR. nrhs.EQ.0 )
THEN
275 safmin =
slamch(
'Safe minimum' )
291 CALL
ccopy( n,
b( 1,
j ), 1, work, 1 )
292 CALL
chpmv( uplo, n, -one, ap, x( 1,
j ), 1, one, work, 1 )
304 rwork( i ) = cabs1(
b( i,
j ) )
313 xk = cabs1( x( k,
j ) )
316 rwork( i ) = rwork( i ) + cabs1( ap( ik ) )*xk
317 s = s + cabs1( ap( ik ) )*cabs1( x( i,
j ) )
320 rwork( k ) = rwork( k ) + abs(
REAL( AP( KK+K-1 ) ) )*
327 xk = cabs1( x( k,
j ) )
328 rwork( k ) = rwork( k ) + abs(
REAL( AP( KK ) ) )*xk
331 rwork( i ) = rwork( i ) + cabs1( ap( ik ) )*xk
332 s = s + cabs1( ap( ik ) )*cabs1( x( i,
j ) )
335 rwork( k ) = rwork( k ) + s
341 IF( rwork( i ).GT.safe2 )
THEN
342 s = max( s, cabs1( work( i ) ) / rwork( i ) )
344 s = max( s, ( cabs1( work( i ) )+safe1 ) /
345 $ ( rwork( i )+safe1 ) )
356 IF( berr(
j ).GT.eps .AND. two*berr(
j ).LE.lstres .AND.
357 $ count.LE.itmax )
THEN
361 CALL
chptrs( uplo, n, 1, afp, ipiv, work, n, info )
362 CALL
caxpy( n, one, work, 1, x( 1,
j ), 1 )
391 IF( rwork( i ).GT.safe2 )
THEN
392 rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
394 rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +
401 CALL
clacn2( n, work( n+1 ), work, ferr(
j ), kase, isave )
407 CALL
chptrs( uplo, n, 1, afp, ipiv, work, n, info )
409 work( i ) = rwork( i )*work( i )
411 ELSE IF( kase.EQ.2 )
THEN
416 work( i ) = rwork( i )*work( i )
418 CALL
chptrs( uplo, n, 1, afp, ipiv, work, n, info )
427 lstres = max( lstres, cabs1( x( i,
j ) ) )
430 $ ferr(
j ) = ferr(
j ) / lstres
subroutine caxpy(N, CA, CX, INCX, CY, INCY)
CAXPY
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine chprfs(UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO)
CHPRFS
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
logical function lsame(CA, CB)
LSAME
subroutine chpmv(UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY)
CHPMV
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 chptrs(UPLO, N, NRHS, AP, IPIV, B, LDB, INFO)
CHPTRS
subroutine clacn2(N, V, X, EST, KASE, ISAVE)
CLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vec...