171 SUBROUTINE zpprfs( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR,
172 $ berr, work, rwork, info )
181 INTEGER INFO, LDB, LDX, N, NRHS
184 DOUBLE PRECISION BERR( * ), FERR( * ), RWORK( * )
185 COMPLEX*16 AFP( * ), AP( * ), B( ldb, * ), WORK( * ),
193 parameter ( itmax = 5 )
194 DOUBLE PRECISION ZERO
195 parameter ( zero = 0.0d+0 )
197 parameter ( cone = ( 1.0d+0, 0.0d+0 ) )
199 parameter ( two = 2.0d+0 )
200 DOUBLE PRECISION THREE
201 parameter ( three = 3.0d+0 )
205 INTEGER COUNT, I, IK, J, K, KASE, KK, NZ
206 DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
216 INTRINSIC abs, dble, dimag, max
220 DOUBLE PRECISION DLAMCH
221 EXTERNAL lsame, dlamch
224 DOUBLE PRECISION CABS1
227 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( 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(
'ZPPRFS', -info )
253 IF( n.EQ.0 .OR. nrhs.EQ.0 )
THEN
264 eps = dlamch(
'Epsilon' )
265 safmin = dlamch(
'Safe minimum' )
281 CALL zcopy( n, b( 1, j ), 1, work, 1 )
282 CALL zhpmv( 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( dble( ap( kk+k-1 ) ) )*
317 xk = cabs1( x( k, j ) )
318 rwork( k ) = rwork( k ) + abs( dble( 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 zpptrs( uplo, n, 1, afp, work, n, info )
352 CALL zaxpy( 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 zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
397 CALL zpptrs( 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 zpptrs( uplo, n, 1, afp, work, n, info )
417 lstres = max( lstres, cabs1( x( i, j ) ) )
420 $ ferr( j ) = ferr( j ) / lstres
subroutine zpptrs(UPLO, N, NRHS, AP, B, LDB, INFO)
ZPPTRS
subroutine zcopy(N, ZX, INCX, ZY, INCY)
ZCOPY
subroutine zpprfs(UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO)
ZPPRFS
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 zhpmv(UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY)
ZHPMV
subroutine zaxpy(N, ZA, ZX, INCX, ZY, INCY)
ZAXPY