115 SUBROUTINE zhetri( UPLO, N, A, LDA, IPIV, WORK, INFO )
128 COMPLEX*16 A( lda, * ), WORK( * )
135 COMPLEX*16 CONE, ZERO
136 parameter( one = 1.0d+0, cone = ( 1.0d+0, 0.0d+0 ),
137 $ zero = ( 0.0d+0, 0.0d+0 ) )
141 INTEGER J, K, KP, KSTEP
142 DOUBLE PRECISION AK, AKP1, D, T
143 COMPLEX*16 AKKP1, TEMP
148 EXTERNAL lsame, zdotc
154 INTRINSIC abs, dble, dconjg, max
161 upper = lsame( uplo,
'U' )
162 IF( .NOT.upper .AND. .NOT.lsame( uplo,
'L' ) )
THEN
164 ELSE IF( n.LT.0 )
THEN
166 ELSE IF( lda.LT.max( 1, n ) )
THEN
170 CALL
xerbla(
'ZHETRI', -info )
185 DO 10 info = n, 1, -1
186 IF( ipiv( info ).GT.0 .AND. a( info, info ).EQ.zero )
194 IF( ipiv( info ).GT.0 .AND. a( info, info ).EQ.zero )
215 IF( ipiv( k ).GT.0 )
THEN
221 a( k, k ) = one / dble( a( k, k ) )
226 CALL
zcopy( k-1, a( 1, k ), 1, work, 1 )
227 CALL
zhemv( uplo, k-1, -cone, a, lda, work, 1, zero,
229 a( k, k ) = a( k, k ) - dble( zdotc( k-1, work, 1, a( 1,
239 t = abs( a( k, k+1 ) )
240 ak = dble( a( k, k ) ) / t
241 akp1 = dble( a( k+1, k+1 ) ) / t
242 akkp1 = a( k, k+1 ) / t
243 d = t*( ak*akp1-one )
245 a( k+1, k+1 ) = ak / d
246 a( k, k+1 ) = -akkp1 / d
251 CALL
zcopy( k-1, a( 1, k ), 1, work, 1 )
252 CALL
zhemv( uplo, k-1, -cone, a, lda, work, 1, zero,
254 a( k, k ) = a( k, k ) - dble( zdotc( k-1, work, 1, a( 1,
256 a( k, k+1 ) = a( k, k+1 ) -
257 $ zdotc( k-1, a( 1, k ), 1, a( 1, k+1 ), 1 )
258 CALL
zcopy( k-1, a( 1, k+1 ), 1, work, 1 )
259 CALL
zhemv( uplo, k-1, -cone, a, lda, work, 1, zero,
261 a( k+1, k+1 ) = a( k+1, k+1 ) -
262 $ dble( zdotc( k-1, work, 1, a( 1, k+1 ),
268 kp = abs( ipiv( k ) )
274 CALL zswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 )
275 DO 40 j = kp + 1, k - 1
276 temp = dconjg( a( j, k ) )
277 a( j, k ) = dconjg( a( kp, j ) )
280 a( kp, k ) = dconjg( a( kp, k ) )
282 a( k, k ) = a( kp, kp )
284 IF( kstep.EQ.2 )
THEN
286 a( k, k+1 ) = a( kp, k+1 )
310 IF( ipiv( k ).GT.0 )
THEN
316 a( k, k ) = one / dble( a( k, k ) )
321 CALL
zcopy( n-k, a( k+1, k ), 1, work, 1 )
322 CALL
zhemv( uplo, n-k, -cone, a( k+1, k+1 ), lda, work,
323 $ 1, zero, a( k+1, k ), 1 )
324 a( k, k ) = a( k, k ) - dble( zdotc( n-k, work, 1,
334 t = abs( a( k, k-1 ) )
335 ak = dble( a( k-1, k-1 ) ) / t
336 akp1 = dble( a( k, k ) ) / t
337 akkp1 = a( k, k-1 ) / t
338 d = t*( ak*akp1-one )
339 a( k-1, k-1 ) = akp1 / d
341 a( k, k-1 ) = -akkp1 / d
346 CALL
zcopy( n-k, a( k+1, k ), 1, work, 1 )
347 CALL
zhemv( uplo, n-k, -cone, a( k+1, k+1 ), lda, work,
348 $ 1, zero, a( k+1, k ), 1 )
349 a( k, k ) = a( k, k ) - dble( zdotc( n-k, work, 1,
351 a( k, k-1 ) = a( k, k-1 ) -
352 $ zdotc( n-k, a( k+1, k ), 1, a( k+1, k-1 ),
354 CALL
zcopy( n-k, a( k+1, k-1 ), 1, work, 1 )
355 CALL
zhemv( uplo, n-k, -cone, a( k+1, k+1 ), lda, work,
356 $ 1, zero, a( k+1, k-1 ), 1 )
357 a( k-1, k-1 ) = a( k-1, k-1 ) -
358 $ dble( zdotc( n-k, work, 1, a( k+1, k-1 ),
364 kp = abs( ipiv( k ) )
371 $ CALL zswap( n-kp, a( kp+1, k ), 1, a( kp+1, kp ), 1 )
372 DO 70 j = k + 1, kp - 1
373 temp = dconjg( a( j, k ) )
374 a( j, k ) = dconjg( a( kp, j ) )
377 a( kp, k ) = dconjg( a( kp, k ) )
379 a( k, k ) = a( kp, kp )
381 IF( kstep.EQ.2 )
THEN
383 a( k, k-1 ) = a( kp, k-1 )
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine zcopy(N, ZX, INCX, ZY, INCY)
ZCOPY
subroutine zhemv(UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
ZHEMV
subroutine zhetri(UPLO, N, A, LDA, IPIV, WORK, INFO)
ZHETRI