180 SUBROUTINE zsprfs( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX,
181 $ ferr, berr, work, rwork, info )
190 INTEGER INFO, LDB, LDX, N, NRHS
194 DOUBLE PRECISION BERR( * ), FERR( * ), RWORK( * )
195 COMPLEX*16 AFP( * ), AP( * ), B( ldb, * ), WORK( * ),
203 parameter ( itmax = 5 )
204 DOUBLE PRECISION ZERO
205 parameter ( zero = 0.0d+0 )
207 parameter ( one = ( 1.0d+0, 0.0d+0 ) )
209 parameter ( two = 2.0d+0 )
210 DOUBLE PRECISION THREE
211 parameter ( three = 3.0d+0 )
215 INTEGER COUNT, I, IK, J, K, KASE, KK, NZ
216 DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
226 INTRINSIC abs, dble, dimag, max
230 DOUBLE PRECISION DLAMCH
231 EXTERNAL lsame, dlamch
234 DOUBLE PRECISION CABS1
237 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( 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(
'ZSPRFS', -info )
263 IF( n.EQ.0 .OR. nrhs.EQ.0 )
THEN
274 eps = dlamch(
'Epsilon' )
275 safmin = dlamch(
'Safe minimum' )
291 CALL zcopy( n, b( 1, j ), 1, work, 1 )
292 CALL zspmv( 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 zsptrs( uplo, n, 1, afp, ipiv, work, n, info )
361 CALL zaxpy( 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 zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
406 CALL zsptrs( 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 zsptrs( uplo, n, 1, afp, ipiv, work, n, info )
426 lstres = max( lstres, cabs1( x( i, j ) ) )
429 $ ferr( j ) = ferr( j ) / lstres
subroutine zsptrs(UPLO, N, NRHS, AP, IPIV, B, LDB, INFO)
ZSPTRS
subroutine zcopy(N, ZX, INCX, ZY, INCY)
ZCOPY
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 zspmv(UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY)
ZSPMV computes a matrix-vector product for complex vectors using a complex symmetric packed matrix ...
subroutine zaxpy(N, ZA, ZX, INCX, ZY, INCY)
ZAXPY
subroutine zsprfs(UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO)
ZSPRFS