183 SUBROUTINE zporfs( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X,
184 $ ldx, ferr, berr, work, rwork, info )
193 INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS
196 DOUBLE PRECISION BERR( * ), FERR( * ), RWORK( * )
197 COMPLEX*16 A( lda, * ), AF( ldaf, * ), B( ldb, * ),
198 $ work( * ), x( ldx, * )
205 parameter ( itmax = 5 )
206 DOUBLE PRECISION ZERO
207 parameter ( zero = 0.0d+0 )
209 parameter ( one = ( 1.0d+0, 0.0d+0 ) )
211 parameter ( two = 2.0d+0 )
212 DOUBLE PRECISION THREE
213 parameter ( three = 3.0d+0 )
217 INTEGER COUNT, I, J, K, KASE, NZ
218 DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
228 INTRINSIC abs, dble, dimag, max
232 DOUBLE PRECISION DLAMCH
233 EXTERNAL lsame, dlamch
236 DOUBLE PRECISION CABS1
239 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) )
246 upper = lsame( uplo,
'U' )
247 IF( .NOT.upper .AND. .NOT.lsame( uplo,
'L' ) )
THEN
249 ELSE IF( n.LT.0 )
THEN
251 ELSE IF( nrhs.LT.0 )
THEN
253 ELSE IF( lda.LT.max( 1, n ) )
THEN
255 ELSE IF( ldaf.LT.max( 1, n ) )
THEN
257 ELSE IF( ldb.LT.max( 1, n ) )
THEN
259 ELSE IF( ldx.LT.max( 1, n ) )
THEN
263 CALL xerbla(
'ZPORFS', -info )
269 IF( n.EQ.0 .OR. nrhs.EQ.0 )
THEN
280 eps = dlamch(
'Epsilon' )
281 safmin = dlamch(
'Safe minimum' )
297 CALL zcopy( n, b( 1, j ), 1, work, 1 )
298 CALL zhemv( uplo, n, -one, a, lda, x( 1, j ), 1, one, work, 1 )
310 rwork( i ) = cabs1( b( i, j ) )
318 xk = cabs1( x( k, j ) )
320 rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk
321 s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) )
323 rwork( k ) = rwork( k ) + abs( dble( a( k, k ) ) )*xk + s
328 xk = cabs1( x( k, j ) )
329 rwork( k ) = rwork( k ) + abs( dble( a( k, k ) ) )*xk
331 rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk
332 s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) )
334 rwork( k ) = rwork( k ) + s
339 IF( rwork( i ).GT.safe2 )
THEN
340 s = max( s, cabs1( work( i ) ) / rwork( i ) )
342 s = max( s, ( cabs1( work( i ) )+safe1 ) /
343 $ ( rwork( i )+safe1 ) )
354 IF( berr( j ).GT.eps .AND. two*berr( j ).LE.lstres .AND.
355 $ count.LE.itmax )
THEN
359 CALL zpotrs( uplo, n, 1, af, ldaf, work, n, info )
360 CALL zaxpy( n, one, work, 1, x( 1, j ), 1 )
389 IF( rwork( i ).GT.safe2 )
THEN
390 rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
392 rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +
399 CALL zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
405 CALL zpotrs( uplo, n, 1, af, ldaf, 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 zpotrs( uplo, n, 1, af, ldaf, work, n, info )
425 lstres = max( lstres, cabs1( x( i, j ) ) )
428 $ ferr( j ) = ferr( j ) / lstres
subroutine zhemv(UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
ZHEMV
subroutine zcopy(N, ZX, INCX, ZY, INCY)
ZCOPY
subroutine zporfs(UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO)
ZPORFS
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 zaxpy(N, ZA, ZX, INCX, ZY, INCY)
ZAXPY
subroutine zpotrs(UPLO, N, NRHS, A, LDA, B, LDB, INFO)
ZPOTRS