176 SUBROUTINE chprfs( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X,
178 $ FERR, BERR, WORK, RWORK, INFO )
186 INTEGER INFO, LDB, LDX, N, NRHS
190 REAL BERR( * ), FERR( * ), RWORK( * )
191 COMPLEX AFP( * ), AP( * ), B( LDB, * ), WORK( * ),
199 PARAMETER ( ITMAX = 5 )
201 parameter( zero = 0.0e+0 )
203 parameter( one = ( 1.0e+0, 0.0e+0 ) )
205 parameter( two = 2.0e+0 )
207 parameter( three = 3.0e+0 )
211 INTEGER COUNT, I, IK, J, K, KASE, KK, NZ
212 REAL EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
223 INTRINSIC abs, aimag, max, real
228 EXTERNAL lsame, slamch
234 cabs1( zdum ) = abs( real( zdum ) ) + abs( aimag( zdum ) )
241 upper = lsame( uplo,
'U' )
242 IF( .NOT.upper .AND. .NOT.lsame( uplo,
'L' ) )
THEN
244 ELSE IF( n.LT.0 )
THEN
246 ELSE IF( nrhs.LT.0 )
THEN
248 ELSE IF( ldb.LT.max( 1, n ) )
THEN
250 ELSE IF( ldx.LT.max( 1, n ) )
THEN
254 CALL xerbla(
'CHPRFS', -info )
260 IF( n.EQ.0 .OR. nrhs.EQ.0 )
THEN
271 eps = slamch(
'Epsilon' )
272 safmin = slamch(
'Safe minimum' )
273 safe1 = real( nz )*safmin
288 CALL ccopy( n, b( 1, j ), 1, work, 1 )
289 CALL chpmv( uplo, n, -one, ap, x( 1, j ), 1, one, work, 1 )
301 rwork( i ) = cabs1( b( i, j ) )
310 xk = cabs1( x( k, j ) )
313 rwork( i ) = rwork( i ) + cabs1( ap( ik ) )*xk
314 s = s + cabs1( ap( ik ) )*cabs1( x( i, j ) )
317 rwork( k ) = rwork( k ) + abs( real( ap( kk+k-1 ) ) )*
324 xk = cabs1( x( k, j ) )
325 rwork( k ) = rwork( k ) + abs( real( ap( kk ) ) )*xk
328 rwork( i ) = rwork( i ) + cabs1( ap( ik ) )*xk
329 s = s + cabs1( ap( ik ) )*cabs1( x( i, j ) )
332 rwork( k ) = rwork( k ) + s
338 IF( rwork( i ).GT.safe2 )
THEN
339 s = max( s, cabs1( work( i ) ) / rwork( i ) )
341 s = max( s, ( cabs1( work( i ) )+safe1 ) /
342 $ ( rwork( i )+safe1 ) )
353 IF( berr( j ).GT.eps .AND. two*berr( j ).LE.lstres .AND.
354 $ count.LE.itmax )
THEN
358 CALL chptrs( uplo, n, 1, afp, ipiv, work, n, info )
359 CALL caxpy( n, one, work, 1, x( 1, j ), 1 )
388 IF( rwork( i ).GT.safe2 )
THEN
389 rwork( i ) = cabs1( work( i ) ) + real( nz )*
392 rwork( i ) = cabs1( work( i ) ) + real( nz )*
393 $ eps*rwork( i ) + safe1
399 CALL clacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
405 CALL chptrs( uplo, n, 1, afp, ipiv, work, n, info )
407 work( i ) = rwork( i )*work( i )
409 ELSE IF( kase.EQ.2 )
THEN
414 work( i ) = rwork( i )*work( i )
416 CALL chptrs( uplo, n, 1, afp, ipiv, work, n, info )
425 lstres = max( lstres, cabs1( x( i, j ) ) )
428 $ ferr( j ) = ferr( j ) / lstres
subroutine chprfs(uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, ferr, berr, work, rwork, info)
CHPRFS