171 SUBROUTINE cpprfs( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR,
172 $ berr, work, rwork, info )
181 INTEGER INFO, LDB, LDX, N, NRHS
184 REAL BERR( * ), FERR( * ), RWORK( * )
185 COMPLEX AFP( * ), AP( * ), B( ldb, * ), WORK( * ),
193 parameter ( itmax = 5 )
195 parameter ( zero = 0.0e+0 )
197 parameter ( cone = ( 1.0e+0, 0.0e+0 ) )
199 parameter ( two = 2.0e+0 )
201 parameter ( three = 3.0e+0 )
205 INTEGER COUNT, I, IK, J, K, KASE, KK, NZ
206 REAL EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
216 INTRINSIC abs, aimag, max, real
221 EXTERNAL lsame, slamch
227 cabs1( zdum ) = abs(
REAL( ZDUM ) ) + abs( AIMAG( zdum ) )
234 upper = lsame( uplo,
'U' )
235 IF( .NOT.upper .AND. .NOT.lsame( uplo,
'L' ) )
THEN
237 ELSE IF( n.LT.0 )
THEN
239 ELSE IF( nrhs.LT.0 )
THEN
241 ELSE IF( ldb.LT.max( 1, n ) )
THEN
243 ELSE IF( ldx.LT.max( 1, n ) )
THEN
247 CALL xerbla(
'CPPRFS', -info )
253 IF( n.EQ.0 .OR. nrhs.EQ.0 )
THEN
264 eps = slamch(
'Epsilon' )
265 safmin = slamch(
'Safe minimum' )
281 CALL ccopy( n, b( 1, j ), 1, work, 1 )
282 CALL chpmv( uplo, n, -cone, ap, x( 1, j ), 1, cone, work, 1 )
294 rwork( i ) = cabs1( b( i, j ) )
303 xk = cabs1( x( k, j ) )
306 rwork( i ) = rwork( i ) + cabs1( ap( ik ) )*xk
307 s = s + cabs1( ap( ik ) )*cabs1( x( i, j ) )
310 rwork( k ) = rwork( k ) + abs(
REAL( AP( KK+K-1 ) ) )*
317 xk = cabs1( x( k, j ) )
318 rwork( k ) = rwork( k ) + abs(
REAL( AP( KK ) ) )*xk
321 rwork( i ) = rwork( i ) + cabs1( ap( ik ) )*xk
322 s = s + cabs1( ap( ik ) )*cabs1( x( i, j ) )
325 rwork( k ) = rwork( k ) + s
331 IF( rwork( i ).GT.safe2 )
THEN
332 s = max( s, cabs1( work( i ) ) / rwork( i ) )
334 s = max( s, ( cabs1( work( i ) )+safe1 ) /
335 $ ( rwork( i )+safe1 ) )
346 IF( berr( j ).GT.eps .AND. two*berr( j ).LE.lstres .AND.
347 $ count.LE.itmax )
THEN
351 CALL cpptrs( uplo, n, 1, afp, work, n, info )
352 CALL caxpy( n, cone, work, 1, x( 1, j ), 1 )
381 IF( rwork( i ).GT.safe2 )
THEN
382 rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
384 rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +
391 CALL clacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
397 CALL cpptrs( uplo, n, 1, afp, work, n, info )
399 work( i ) = rwork( i )*work( i )
401 ELSE IF( kase.EQ.2 )
THEN
406 work( i ) = rwork( i )*work( i )
408 CALL cpptrs( uplo, n, 1, afp, work, n, info )
417 lstres = max( lstres, cabs1( x( i, j ) ) )
420 $ ferr( j ) = ferr( j ) / lstres
subroutine cpprfs(UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO)
CPPRFS
subroutine chpmv(UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY)
CHPMV
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine clacn2(N, V, X, EST, KASE, ISAVE)
CLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vec...
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY
subroutine caxpy(N, CA, CX, INCX, CY, INCY)
CAXPY
subroutine cpptrs(UPLO, N, NRHS, AP, B, LDB, INFO)
CPPTRS