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
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
complex function cdotc(N, CX, INCX, CY, INCY)
CDOTC
subroutine cswap(N, CX, INCX, CY, INCY)
CSWAP
logical function lsame(CA, CB)
LSAME
subroutine chemv(UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
CHEMV
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
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