192 SUBROUTINE zherfs( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB,
193 $ x, ldx, ferr, berr, work, rwork, info )
202 INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS
206 DOUBLE PRECISION BERR( * ), FERR( * ), RWORK( * )
207 COMPLEX*16 A( lda, * ), AF( ldaf, * ), B( ldb, * ),
208 $ work( * ), x( ldx, * )
215 parameter ( itmax = 5 )
216 DOUBLE PRECISION ZERO
217 parameter ( zero = 0.0d+0 )
219 parameter ( one = ( 1.0d+0, 0.0d+0 ) )
221 parameter ( two = 2.0d+0 )
222 DOUBLE PRECISION THREE
223 parameter ( three = 3.0d+0 )
227 INTEGER COUNT, I, J, K, KASE, NZ
228 DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
238 INTRINSIC abs, dble, dimag, max
242 DOUBLE PRECISION DLAMCH
243 EXTERNAL lsame, dlamch
246 DOUBLE PRECISION CABS1
249 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) )
256 upper = lsame( uplo,
'U' )
257 IF( .NOT.upper .AND. .NOT.lsame( uplo,
'L' ) )
THEN
259 ELSE IF( n.LT.0 )
THEN
261 ELSE IF( nrhs.LT.0 )
THEN
263 ELSE IF( lda.LT.max( 1, n ) )
THEN
265 ELSE IF( ldaf.LT.max( 1, n ) )
THEN
267 ELSE IF( ldb.LT.max( 1, n ) )
THEN
269 ELSE IF( ldx.LT.max( 1, n ) )
THEN
273 CALL xerbla(
'ZHERFS', -info )
279 IF( n.EQ.0 .OR. nrhs.EQ.0 )
THEN
290 eps = dlamch(
'Epsilon' )
291 safmin = dlamch(
'Safe minimum' )
307 CALL zcopy( n, b( 1, j ), 1, work, 1 )
308 CALL zhemv( uplo, n, -one, a, lda, x( 1, j ), 1, one, work, 1 )
320 rwork( i ) = cabs1( b( i, j ) )
328 xk = cabs1( x( k, j ) )
330 rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk
331 s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) )
333 rwork( k ) = rwork( k ) + abs( dble( a( k, k ) ) )*xk + s
338 xk = cabs1( x( k, j ) )
339 rwork( k ) = rwork( k ) + abs( dble( a( k, k ) ) )*xk
341 rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk
342 s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) )
344 rwork( k ) = rwork( k ) + s
349 IF( rwork( i ).GT.safe2 )
THEN
350 s = max( s, cabs1( work( i ) ) / rwork( i ) )
352 s = max( s, ( cabs1( work( i ) )+safe1 ) /
353 $ ( rwork( i )+safe1 ) )
364 IF( berr( j ).GT.eps .AND. two*berr( j ).LE.lstres .AND.
365 $ count.LE.itmax )
THEN
369 CALL zhetrs( uplo, n, 1, af, ldaf, ipiv, work, n, info )
370 CALL zaxpy( n, one, work, 1, x( 1, j ), 1 )
399 IF( rwork( i ).GT.safe2 )
THEN
400 rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
402 rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +
409 CALL zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
415 CALL zhetrs( uplo, n, 1, af, ldaf, ipiv, work, n, info )
417 work( i ) = rwork( i )*work( i )
419 ELSE IF( kase.EQ.2 )
THEN
424 work( i ) = rwork( i )*work( i )
426 CALL zhetrs( uplo, n, 1, af, ldaf, ipiv, work, n, info )
435 lstres = max( lstres, cabs1( x( i, j ) ) )
438 $ ferr( j ) = ferr( j ) / lstres
subroutine zhemv(UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
ZHEMV
subroutine zherfs(UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO)
ZHERFS
subroutine zcopy(N, ZX, INCX, ZY, INCY)
ZCOPY
subroutine xerbla(SRNAME, INFO)
XERBLA
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 zhetrs(UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO)
ZHETRS
subroutine zaxpy(N, ZA, ZX, INCX, ZY, INCY)
ZAXPY