187 SUBROUTINE chetf2( UPLO, N, A, LDA, IPIV, INFO )
207 parameter( zero = 0.0e+0, one = 1.0e+0 )
209 parameter( eight = 8.0e+0, sevten = 17.0e+0 )
213 INTEGER i, imax,
j, jmax, k, kk, kp, kstep
214 REAL absakk, alpha, colmax, d, d11, d22, r1, rowmax,
216 COMPLEX d12, d21, t, wk, wkm1, wkp1, zdum
228 INTRINSIC abs, aimag, cmplx, conjg, max,
REAL, sqrt
234 cabs1( zdum ) = abs(
REAL( ZDUM ) ) + abs( aimag( zdum ) )
241 upper =
lsame( uplo,
'U' )
242 IF( .NOT.upper .AND. .NOT.
lsame( uplo,
'L' ) )
THEN
244 ELSE IF( n.LT.0 )
THEN
246 ELSE IF( lda.LT.max( 1, n ) )
THEN
250 CALL
xerbla(
'CHETF2', -info )
256 alpha = ( one+sqrt( sevten ) ) / eight
277 absakk = abs(
REAL( A( K, K ) ) )
284 imax =
icamax( k-1, a( 1, k ), 1 )
285 colmax = cabs1( a( imax, k ) )
290 IF( (max( absakk, colmax ).EQ.zero) .OR.
sisnan(absakk) )
THEN
298 a( k, k ) =
REAL( A( K, K ) )
300 IF( absakk.GE.alpha*colmax )
THEN
310 jmax = imax +
icamax( k-imax, a( imax, imax+1 ), lda )
311 rowmax = cabs1( a( imax, jmax ) )
313 jmax =
icamax( imax-1, a( 1, imax ), 1 )
314 rowmax = max( rowmax, cabs1( a( jmax, imax ) ) )
317 IF( absakk.GE.alpha*colmax*( colmax / rowmax ) )
THEN
322 ELSE IF( abs(
REAL( A( IMAX, IMAX ) ) ).GE.alpha*rowmax )
345 CALL
cswap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 )
346 DO 20
j = kp + 1, kk - 1
347 t = conjg( a(
j, kk ) )
348 a(
j, kk ) = conjg( a( kp,
j ) )
351 a( kp, kk ) = conjg( a( kp, kk ) )
352 r1 =
REAL( A( KK, KK ) )
353 a( kk, kk ) =
REAL( A( KP, KP ) )
355 IF( kstep.EQ.2 )
THEN
356 a( k, k ) =
REAL( A( K, K ) )
358 a( k-1, k ) = a( kp, k )
362 a( k, k ) =
REAL( A( K, K ) )
364 $ a( k-1, k-1 ) =
REAL( A( K-1, K-1 ) )
369 IF( kstep.EQ.1 )
THEN
381 r1 = one /
REAL( A( K, K ) )
382 CALL
cher( uplo, k-1, -r1, a( 1, k ), 1, a, lda )
386 CALL
csscal( k-1, r1, a( 1, k ), 1 )
403 d =
slapy2(
REAL( A( K-1, K ) ),
404 $ aimag( a( k-1, k ) ) )
405 d22 =
REAL( A( K-1, K-1 ) ) / d
406 d11 =
REAL( A( K, K ) ) / d
407 tt = one / ( d11*d22-one )
408 d12 = a( k-1, k ) / d
411 DO 40
j = k - 2, 1, -1
412 wkm1 = d*( d11*a(
j, k-1 )-conjg( d12 )*a(
j, k ) )
413 wk = d*( d22*a(
j, k )-d12*a(
j, k-1 ) )
415 a( i,
j ) = a( i,
j ) - a( i, k )*conjg( wk ) -
416 $ a( i, k-1 )*conjg( wkm1 )
420 a(
j,
j ) = cmplx(
REAL( A( J, J ) ), 0.0e+0 )
430 IF( kstep.EQ.1 )
THEN
461 absakk = abs(
REAL( A( K, K ) ) )
468 imax = k +
icamax( n-k, a( k+1, k ), 1 )
469 colmax = cabs1( a( imax, k ) )
474 IF( (max( absakk, colmax ).EQ.zero) .OR.
sisnan(absakk) )
THEN
482 a( k, k ) =
REAL( A( K, K ) )
484 IF( absakk.GE.alpha*colmax )
THEN
494 jmax = k - 1 +
icamax( imax-k, a( imax, k ), lda )
495 rowmax = cabs1( a( imax, jmax ) )
497 jmax = imax +
icamax( n-imax, a( imax+1, imax ), 1 )
498 rowmax = max( rowmax, cabs1( a( jmax, imax ) ) )
501 IF( absakk.GE.alpha*colmax*( colmax / rowmax ) )
THEN
506 ELSE IF( abs(
REAL( A( IMAX, IMAX ) ) ).GE.alpha*rowmax )
530 $ CALL
cswap( n-kp, a( kp+1, kk ), 1, a( kp+1, kp ), 1 )
531 DO 60
j = kk + 1, kp - 1
532 t = conjg( a(
j, kk ) )
533 a(
j, kk ) = conjg( a( kp,
j ) )
536 a( kp, kk ) = conjg( a( kp, kk ) )
537 r1 =
REAL( A( KK, KK ) )
538 a( kk, kk ) =
REAL( A( KP, KP ) )
540 IF( kstep.EQ.2 )
THEN
541 a( k, k ) =
REAL( A( K, K ) )
543 a( k+1, k ) = a( kp, k )
547 a( k, k ) =
REAL( A( K, K ) )
549 $ a( k+1, k+1 ) =
REAL( A( K+1, K+1 ) )
554 IF( kstep.EQ.1 )
THEN
568 r1 = one /
REAL( A( K, K ) )
569 CALL
cher( uplo, n-k, -r1, a( k+1, k ), 1,
570 $ a( k+1, k+1 ), lda )
574 CALL
csscal( n-k, r1, a( k+1, k ), 1 )
590 d =
slapy2(
REAL( A( K+1, K ) ),
591 $ aimag( a( k+1, k ) ) )
592 d11 =
REAL( A( K+1, K+1 ) ) / d
593 d22 =
REAL( A( K, K ) ) / d
594 tt = one / ( d11*d22-one )
595 d21 = a( k+1, k ) / d
599 wk = d*( d11*a(
j, k )-d21*a(
j, k+1 ) )
600 wkp1 = d*( d22*a(
j, k+1 )-conjg( d21 )*a(
j, k ) )
602 a( i,
j ) = a( i,
j ) - a( i, k )*conjg( wk ) -
603 $ a( i, k+1 )*conjg( wkp1 )
607 a(
j,
j ) = cmplx(
REAL( A( J, J ) ), 0.0e+0 )
615 IF( kstep.EQ.1 )
THEN
subroutine xerbla(SRNAME, INFO)
XERBLA
integer function icamax(N, CX, INCX)
ICAMAX
subroutine cher(UPLO, N, ALPHA, X, INCX, A, LDA)
CHER
subroutine cswap(N, CX, INCX, CY, INCY)
CSWAP
logical function lsame(CA, CB)
LSAME
subroutine chetf2(UPLO, N, A, LDA, IPIV, INFO)
CHETF2 computes the factorization of a complex Hermitian matrix, using the diagonal pivoting method (...
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine csscal(N, SA, CX, INCX)
CSSCAL
logical function sisnan(SIN)
SISNAN tests input for NaN.
real function slapy2(X, Y)
SLAPY2 returns sqrt(x2+y2).