171 SUBROUTINE dpprfs( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR,
172 $ berr, work, iwork, info )
181 INTEGER INFO, LDB, LDX, N, NRHS
185 DOUBLE PRECISION AFP( * ), AP( * ), B( ldb, * ), BERR( * ),
186 $ ferr( * ), work( * ), x( ldx, * )
193 parameter( itmax = 5 )
194 DOUBLE PRECISION ZERO
195 parameter( zero = 0.0d+0 )
197 parameter( one = 1.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
219 DOUBLE PRECISION DLAMCH
220 EXTERNAL lsame, dlamch
227 upper = lsame( uplo,
'U' )
228 IF( .NOT.upper .AND. .NOT.lsame( uplo,
'L' ) )
THEN
230 ELSE IF( n.LT.0 )
THEN
232 ELSE IF( nrhs.LT.0 )
THEN
234 ELSE IF( ldb.LT.max( 1, n ) )
THEN
236 ELSE IF( ldx.LT.max( 1, n ) )
THEN
240 CALL
xerbla(
'DPPRFS', -info )
246 IF( n.EQ.0 .OR. nrhs.EQ.0 )
THEN
257 eps = dlamch(
'Epsilon' )
258 safmin = dlamch(
'Safe minimum' )
274 CALL
dcopy( n, b( 1, j ), 1, work( n+1 ), 1 )
275 CALL
dspmv( uplo, n, -one, ap, x( 1, j ), 1, one, work( n+1 ),
288 work( i ) = abs( b( i, j ) )
297 xk = abs( x( k, j ) )
300 work( i ) = work( i ) + abs( ap( ik ) )*xk
301 s = s + abs( ap( ik ) )*abs( x( i, j ) )
304 work( k ) = work( k ) + abs( ap( kk+k-1 ) )*xk + s
310 xk = abs( x( k, j ) )
311 work( k ) = work( k ) + abs( ap( kk ) )*xk
314 work( i ) = work( i ) + abs( ap( ik ) )*xk
315 s = s + abs( ap( ik ) )*abs( x( i, j ) )
318 work( k ) = work( k ) + s
324 IF( work( i ).GT.safe2 )
THEN
325 s = max( s, abs( work( n+i ) ) / work( i ) )
327 s = max( s, ( abs( work( n+i ) )+safe1 ) /
328 $ ( work( i )+safe1 ) )
339 IF( berr( j ).GT.eps .AND. two*berr( j ).LE.lstres .AND.
340 $ count.LE.itmax )
THEN
344 CALL
dpptrs( uplo, n, 1, afp, work( n+1 ), n, info )
345 CALL
daxpy( n, one, work( n+1 ), 1, x( 1, j ), 1 )
374 IF( work( i ).GT.safe2 )
THEN
375 work( i ) = abs( work( n+i ) ) + nz*eps*work( i )
377 work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) + safe1
383 CALL
dlacn2( n, work( 2*n+1 ), work( n+1 ), iwork, ferr( j ),
390 CALL
dpptrs( uplo, n, 1, afp, work( n+1 ), n, info )
392 work( n+i ) = work( i )*work( n+i )
394 ELSE IF( kase.EQ.2 )
THEN
399 work( n+i ) = work( i )*work( n+i )
401 CALL
dpptrs( uplo, n, 1, afp, work( n+1 ), n, info )
410 lstres = max( lstres, abs( x( i, j ) ) )
413 $ ferr( j ) = ferr( j ) / lstres
subroutine dspmv(UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY)
DSPMV
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine dpptrs(UPLO, N, NRHS, AP, B, LDB, INFO)
DPPTRS
subroutine daxpy(N, DA, DX, INCX, DY, INCY)
DAXPY
subroutine dlacn2(N, V, X, ISGN, EST, KASE, ISAVE)
DLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vec...
subroutine dpprfs(UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO)
DPPRFS