180 SUBROUTINE csprfs( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX,
181 $ ferr, berr, work, rwork, info )
190 INTEGER INFO, LDB, LDX, N, NRHS
194 REAL BERR( * ), FERR( * ), RWORK( * )
195 COMPLEX AFP( * ), AP( * ), B( ldb, * ), WORK( * ),
203 parameter ( itmax = 5 )
205 parameter ( zero = 0.0e+0 )
207 parameter ( one = ( 1.0e+0, 0.0e+0 ) )
209 parameter ( two = 2.0e+0 )
211 parameter ( three = 3.0e+0 )
215 INTEGER COUNT, I, IK, J, K, KASE, KK, NZ
216 REAL EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
226 INTRINSIC abs, aimag, max, real
231 EXTERNAL lsame, slamch
237 cabs1( zdum ) = abs(
REAL( ZDUM ) ) + abs( AIMAG( zdum ) )
244 upper = lsame( uplo,
'U' )
245 IF( .NOT.upper .AND. .NOT.lsame( uplo,
'L' ) )
THEN
247 ELSE IF( n.LT.0 )
THEN
249 ELSE IF( nrhs.LT.0 )
THEN
251 ELSE IF( ldb.LT.max( 1, n ) )
THEN
253 ELSE IF( ldx.LT.max( 1, n ) )
THEN
257 CALL xerbla(
'CSPRFS', -info )
263 IF( n.EQ.0 .OR. nrhs.EQ.0 )
THEN
274 eps = slamch(
'Epsilon' )
275 safmin = slamch(
'Safe minimum' )
291 CALL ccopy( n, b( 1, j ), 1, work, 1 )
292 CALL cspmv( uplo, n, -one, ap, x( 1, j ), 1, one, work, 1 )
304 rwork( i ) = cabs1( b( i, j ) )
313 xk = cabs1( x( k, j ) )
316 rwork( i ) = rwork( i ) + cabs1( ap( ik ) )*xk
317 s = s + cabs1( ap( ik ) )*cabs1( x( i, j ) )
320 rwork( k ) = rwork( k ) + cabs1( ap( kk+k-1 ) )*xk + s
326 xk = cabs1( x( k, j ) )
327 rwork( k ) = rwork( k ) + cabs1( ap( kk ) )*xk
330 rwork( i ) = rwork( i ) + cabs1( ap( ik ) )*xk
331 s = s + cabs1( ap( ik ) )*cabs1( x( i, j ) )
334 rwork( k ) = rwork( k ) + s
340 IF( rwork( i ).GT.safe2 )
THEN
341 s = max( s, cabs1( work( i ) ) / rwork( i ) )
343 s = max( s, ( cabs1( work( i ) )+safe1 ) /
344 $ ( rwork( i )+safe1 ) )
355 IF( berr( j ).GT.eps .AND. two*berr( j ).LE.lstres .AND.
356 $ count.LE.itmax )
THEN
360 CALL csptrs( uplo, n, 1, afp, ipiv, work, n, info )
361 CALL caxpy( n, one, work, 1, x( 1, j ), 1 )
390 IF( rwork( i ).GT.safe2 )
THEN
391 rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
393 rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +
400 CALL clacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
406 CALL csptrs( uplo, n, 1, afp, ipiv, work, n, info )
408 work( i ) = rwork( i )*work( i )
410 ELSE IF( kase.EQ.2 )
THEN
415 work( i ) = rwork( i )*work( i )
417 CALL csptrs( uplo, n, 1, afp, ipiv, work, n, info )
426 lstres = max( lstres, cabs1( x( i, j ) ) )
429 $ ferr( j ) = ferr( j ) / lstres
subroutine cspmv(UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY)
CSPMV computes a matrix-vector product for complex vectors using a complex symmetric packed matrix ...
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine csptrs(UPLO, N, NRHS, AP, IPIV, B, LDB, INFO)
CSPTRS
subroutine csprfs(UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO)
CSPRFS
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY
subroutine caxpy(N, CA, CX, INCX, CY, INCY)
CAXPY
subroutine clacn2(N, V, X, EST, KASE, ISAVE)
CLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vec...