115 SUBROUTINE chetri( UPLO, N, A, LDA, IPIV, WORK, INFO )
128 COMPLEX A( lda, * ), WORK( * )
136 parameter( one = 1.0e+0, cone = ( 1.0e+0, 0.0e+0 ),
137 $ zero = ( 0.0e+0, 0.0e+0 ) )
141 INTEGER J, K, KP, KSTEP
148 EXTERNAL lsame, cdotc
154 INTRINSIC abs, conjg, max, real
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(
'CHETRI', -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 /
REAL( A( K, K ) )
226 CALL
ccopy( k-1, a( 1, k ), 1, work, 1 )
227 CALL
chemv( uplo, k-1, -cone, a, lda, work, 1, zero,
229 a( k, k ) = a( k, k ) -
REAL( CDOTC( K-1, WORK, 1, A( 1,
$ K ), 1 ) )
238 t = abs( a( k, k+1 ) )
239 ak =
REAL( A( K, K ) ) / T
240 akp1 =
REAL( A( K+1, K+1 ) ) / T
241 akkp1 = a( k, k+1 ) / t
242 d = t*( ak*akp1-one )
244 a( k+1, k+1 ) = ak / d
245 a( k, k+1 ) = -akkp1 / d
250 CALL
ccopy( k-1, a( 1, k ), 1, work, 1 )
251 CALL
chemv( uplo, k-1, -cone, a, lda, work, 1, zero,
253 a( k, k ) = a( k, k ) -
REAL( CDOTC( K-1, WORK, 1, A( 1,
$ K ), 1 ) )
254 a( k, k+1 ) = a( k, k+1 ) -
255 $ cdotc( k-1, a( 1, k ), 1, a( 1, k+1 ), 1 )
256 CALL
ccopy( k-1, a( 1, k+1 ), 1, work, 1 )
257 CALL
chemv( uplo, k-1, -cone, a, lda, work, 1, zero,
259 a( k+1, k+1 ) = a( k+1, k+1 ) -
260 $
REAL( CDOTC( K-1, WORK, 1, A( 1, K+1 ),
$ 1 ) )
265 kp = abs( ipiv( k ) )
271 CALL
cswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 )
272 DO 40 j = kp + 1, k - 1
273 temp = conjg( a( j, k ) )
274 a( j, k ) = conjg( a( kp, j ) )
277 a( kp, k ) = conjg( a( kp, k ) )
279 a( k, k ) = a( kp, kp )
281 IF( kstep.EQ.2 )
THEN
283 a( k, k+1 ) = a( kp, k+1 )
307 IF( ipiv( k ).GT.0 )
THEN
313 a( k, k ) = one /
REAL( A( K, K ) )
318 CALL
ccopy( n-k, a( k+1, k ), 1, work, 1 )
319 CALL
chemv( uplo, n-k, -cone, a( k+1, k+1 ), lda, work,
320 $ 1, zero, a( k+1, k ), 1 )
321 a( k, k ) = a( k, k ) -
REAL( CDOTC( N-K, WORK, 1,
$ A( K+1, K ), 1 ) )
330 t = abs( a( k, k-1 ) )
331 ak =
REAL( A( K-1, K-1 ) ) / T
332 akp1 =
REAL( A( K, K ) ) / T
333 akkp1 = a( k, k-1 ) / t
334 d = t*( ak*akp1-one )
335 a( k-1, k-1 ) = akp1 / d
337 a( k, k-1 ) = -akkp1 / d
342 CALL
ccopy( n-k, a( k+1, k ), 1, work, 1 )
343 CALL
chemv( uplo, n-k, -cone, a( k+1, k+1 ), lda, work,
344 $ 1, zero, a( k+1, k ), 1 )
345 a( k, k ) = a( k, k ) -
REAL( CDOTC( N-K, WORK, 1,
$ A( K+1, K ), 1 ) )
346 a( k, k-1 ) = a( k, k-1 ) -
347 $ cdotc( n-k, a( k+1, k ), 1, a( k+1, k-1 ),
349 CALL
ccopy( n-k, a( k+1, k-1 ), 1, work, 1 )
350 CALL
chemv( uplo, n-k, -cone, a( k+1, k+1 ), lda, work,
351 $ 1, zero, a( k+1, k-1 ), 1 )
352 a( k-1, k-1 ) = a( k-1, k-1 ) -
353 $
REAL( CDOTC( N-K, WORK, 1, A( K+1, K-1 ),
$ 1 ) )
358 kp = abs( ipiv( k ) )
365 $ CALL
cswap( n-kp, a( kp+1, k ), 1, a( kp+1, kp ), 1 )
366 DO 70 j = k + 1, kp - 1
367 temp = conjg( a( j, k ) )
368 a( j, k ) = conjg( a( kp, j ) )
371 a( kp, k ) = conjg( a( kp, k ) )
373 a( k, k ) = a( kp, kp )
375 IF( kstep.EQ.2 )
THEN
377 a( k, k-1 ) = a( kp, k-1 )
392 subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine chetri(UPLO, N, A, LDA, IPIV, WORK, INFO)
CHETRI
subroutine cswap(N, CX, INCX, CY, INCY)
CSWAP
subroutine chemv(UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
CHEMV
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY