142 COMPLEX A( lda, * ), WORK( * )
150 parameter( one = 1.0e+0, cone = ( 1.0e+0, 0.0e+0 ),
151 $ czero = ( 0.0e+0, 0.0e+0 ) )
155 INTEGER J, K, KP, KSTEP
162 EXTERNAL lsame, cdotc
168 INTRINSIC abs, conjg, max, real
175 upper = lsame( uplo,
'U' )
176 IF( .NOT.upper .AND. .NOT.lsame( uplo,
'L' ) )
THEN
178 ELSE IF( n.LT.0 )
THEN
180 ELSE IF( lda.LT.max( 1, n ) )
THEN
184 CALL
xerbla(
'CHETRI_ROOK', -info )
199 DO 10 info = n, 1, -1
200 IF( ipiv( info ).GT.0 .AND. a( info, info ).EQ.czero )
208 IF( ipiv( info ).GT.0 .AND. a( info, info ).EQ.czero )
229 IF( ipiv( k ).GT.0 )
THEN
235 a( k, k ) = one /
REAL( A( K, K ) )
240 CALL
ccopy( k-1, a( 1, k ), 1, work, 1 )
241 CALL
chemv( uplo, k-1, -cone, a, lda, work, 1, czero,
243 a( k, k ) = a( k, k ) -
REAL( CDOTC( K-1, WORK, 1, A( 1,
$ K ), 1 ) )
252 t = abs( a( k, k+1 ) )
253 ak =
REAL( A( K, K ) ) / T
254 akp1 =
REAL( A( K+1, K+1 ) ) / T
255 akkp1 = a( k, k+1 ) / t
256 d = t*( ak*akp1-one )
258 a( k+1, k+1 ) = ak / d
259 a( k, k+1 ) = -akkp1 / d
264 CALL
ccopy( k-1, a( 1, k ), 1, work, 1 )
265 CALL
chemv( uplo, k-1, -cone, a, lda, work, 1, czero,
267 a( k, k ) = a( k, k ) -
REAL( CDOTC( K-1, WORK, 1, A( 1,
$ K ), 1 ) )
268 a( k, k+1 ) = a( k, k+1 ) -
269 $ cdotc( k-1, a( 1, k ), 1, a( 1, k+1 ), 1 )
270 CALL
ccopy( k-1, a( 1, k+1 ), 1, work, 1 )
271 CALL
chemv( uplo, k-1, -cone, a, lda, work, 1, czero,
273 a( k+1, k+1 ) = a( k+1, k+1 ) -
274 $
REAL( CDOTC( K-1, WORK, 1, A( 1, K+1 ),
$ 1 ) )
279 IF( kstep.EQ.1 )
THEN
288 $ CALL
cswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 )
290 DO 40 j = kp + 1, k - 1
291 temp = conjg( a( j, k ) )
292 a( j, k ) = conjg( a( kp, j ) )
296 a( kp, k ) = conjg( a( kp, k ) )
299 a( k, k ) = a( kp, kp )
313 $ CALL
cswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 )
315 DO 50 j = kp + 1, k - 1
316 temp = conjg( a( j, k ) )
317 a( j, k ) = conjg( a( kp, j ) )
321 a( kp, k ) = conjg( a( kp, k ) )
324 a( k, k ) = a( kp, kp )
328 a( k, k+1 ) = a( kp, k+1 )
339 $ CALL
cswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 )
341 DO 60 j = kp + 1, k - 1
342 temp = conjg( a( j, k ) )
343 a( j, k ) = conjg( a( kp, j ) )
347 a( kp, k ) = conjg( a( kp, k ) )
350 a( k, k ) = a( kp, kp )
374 IF( ipiv( k ).GT.0 )
THEN
380 a( k, k ) = one /
REAL( A( K, K ) )
385 CALL
ccopy( n-k, a( k+1, k ), 1, work, 1 )
386 CALL
chemv( uplo, n-k, -cone, a( k+1, k+1 ), lda, work,
387 $ 1, czero, a( k+1, k ), 1 )
388 a( k, k ) = a( k, k ) -
REAL( CDOTC( N-K, WORK, 1,
$ A( K+1, K ), 1 ) )
397 t = abs( a( k, k-1 ) )
398 ak =
REAL( A( K-1, K-1 ) ) / T
399 akp1 =
REAL( A( K, K ) ) / T
400 akkp1 = a( k, k-1 ) / t
401 d = t*( ak*akp1-one )
402 a( k-1, k-1 ) = akp1 / d
404 a( k, k-1 ) = -akkp1 / d
409 CALL
ccopy( n-k, a( k+1, k ), 1, work, 1 )
410 CALL
chemv( uplo, n-k, -cone, a( k+1, k+1 ), lda, work,
411 $ 1, czero, a( k+1, k ), 1 )
412 a( k, k ) = a( k, k ) -
REAL( CDOTC( N-K, WORK, 1,
$ A( K+1, K ), 1 ) )
413 a( k, k-1 ) = a( k, k-1 ) -
414 $ cdotc( n-k, a( k+1, k ), 1, a( k+1, k-1 ),
416 CALL
ccopy( n-k, a( k+1, k-1 ), 1, work, 1 )
417 CALL
chemv( uplo, n-k, -cone, a( k+1, k+1 ), lda, work,
418 $ 1, czero, a( k+1, k-1 ), 1 )
419 a( k-1, k-1 ) = a( k-1, k-1 ) -
420 $
REAL( CDOTC( N-K, WORK, 1, A( K+1, K-1 ),
$ 1 ) )
425 IF( kstep.EQ.1 )
THEN
434 $ CALL
cswap( n-kp, a( kp+1, k ), 1, a( kp+1, kp ), 1 )
436 DO 90 j = k + 1, kp - 1
437 temp = conjg( a( j, k ) )
438 a( j, k ) = conjg( a( kp, j ) )
442 a( kp, k ) = conjg( a( kp, k ) )
445 a( k, k ) = a( kp, kp )
459 $ CALL
cswap( n-kp, a( kp+1, k ), 1, a( kp+1, kp ), 1 )
461 DO 100 j = k + 1, kp - 1
462 temp = conjg( a( j, k ) )
463 a( j, k ) = conjg( a( kp, j ) )
467 a( kp, k ) = conjg( a( kp, k ) )
470 a( k, k ) = a( kp, kp )
474 a( k, k-1 ) = a( kp, k-1 )
485 $ CALL
cswap( n-kp, a( kp+1, k ), 1, a( kp+1, kp ), 1 )
487 DO 110 j = k + 1, kp - 1
488 temp = conjg( a( j, k ) )
489 a( j, k ) = conjg( a( kp, j ) )
493 a( kp, k ) = conjg( a( kp, k ) )
496 a( k, k ) = a( kp, kp )
511 subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine cswap(N, CX, INCX, CY, INCY)
CSWAP
subroutine chemv(UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
CHEMV
subroutine chetri_rook(UPLO, N, A, LDA, IPIV, WORK, INFO)
CHETRI_ROOK computes the inverse of HE matrix using the factorization obtained with the bounded Bunch...
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY