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 dpprfs(UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO)
DPPRFS
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
subroutine dspmv(UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY)
DSPMV
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 xerbla(SRNAME, INFO)
XERBLA
subroutine dpptrs(UPLO, N, NRHS, AP, B, LDB, INFO)
DPPTRS