242 SUBROUTINE dsytf2_rk( UPLO, N, A, LDA, E, IPIV, INFO )
255 DOUBLE PRECISION A( lda, * ), E( * )
261 DOUBLE PRECISION ZERO, ONE
262 parameter ( zero = 0.0d+0, one = 1.0d+0 )
263 DOUBLE PRECISION EIGHT, SEVTEN
264 parameter ( eight = 8.0d+0, sevten = 17.0d+0 )
268 INTEGER I, IMAX, J, JMAX, ITEMP, K, KK, KP, KSTEP,
270 DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22,
271 $ rowmax, dtemp, t, wk, wkm1, wkp1, sfmin
276 DOUBLE PRECISION DLAMCH
277 EXTERNAL lsame, idamax, dlamch
283 INTRINSIC abs, max, sqrt
290 upper = lsame( uplo,
'U' )
291 IF( .NOT.upper .AND. .NOT.lsame( uplo,
'L' ) )
THEN
293 ELSE IF( n.LT.0 )
THEN
295 ELSE IF( lda.LT.max( 1, n ) )
THEN
299 CALL xerbla(
'DSYTF2_RK', -info )
305 alpha = ( one+sqrt( sevten ) ) / eight
309 sfmin = dlamch(
'S' )
336 absakk = abs( a( k, k ) )
343 imax = idamax( k-1, a( 1, k ), 1 )
344 colmax = abs( a( imax, k ) )
349 IF( (max( absakk, colmax ).EQ.zero) )
THEN
369 IF( .NOT.( absakk.LT.alpha*colmax ) )
THEN
390 jmax = imax + idamax( k-imax, a( imax, imax+1 ),
392 rowmax = abs( a( imax, jmax ) )
398 itemp = idamax( imax-1, a( 1, imax ), 1 )
399 dtemp = abs( a( itemp, imax ) )
400 IF( dtemp.GT.rowmax )
THEN
409 IF( .NOT.( abs( a( imax, imax ) ).LT.alpha*rowmax ) )
421 ELSE IF( ( p.EQ.jmax ).OR.( rowmax.LE.colmax ) )
THEN
440 IF( .NOT. done )
GOTO 12
448 IF( ( kstep.EQ.2 ) .AND. ( p.NE.k ) )
THEN
454 $
CALL dswap( p-1, a( 1, k ), 1, a( 1, p ), 1 )
456 $
CALL dswap( k-p-1, a( p+1, k ), 1, a( p, p+1 ),
459 a( k, k ) = a( p, p )
466 $
CALL dswap( n-k, a( k, k+1 ), lda, a( p, k+1 ), lda )
479 $
CALL dswap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 )
480 IF( ( kk.GT.1 ) .AND. ( kp.LT.(kk-1) ) )
481 $
CALL dswap( kk-kp-1, a( kp+1, kk ), 1, a( kp, kp+1 ),
484 a( kk, kk ) = a( kp, kp )
486 IF( kstep.EQ.2 )
THEN
488 a( k-1, k ) = a( kp, k )
496 $
CALL dswap( n-k, a( kk, k+1 ), lda, a( kp, k+1 ),
503 IF( kstep.EQ.1 )
THEN
516 IF( abs( a( k, k ) ).GE.sfmin )
THEN
522 d11 = one / a( k, k )
523 CALL dsyr( uplo, k-1, -d11, a( 1, k ), 1, a, lda )
527 CALL dscal( k-1, d11, a( 1, k ), 1 )
534 a( ii, k ) = a( ii, k ) / d11
542 CALL dsyr( uplo, k-1, -d11, a( 1, k ), 1, a, lda )
570 d22 = a( k-1, k-1 ) / d12
571 d11 = a( k, k ) / d12
572 t = one / ( d11*d22-one )
574 DO 30 j = k - 2, 1, -1
576 wkm1 = t*( d11*a( j, k-1 )-a( j, k ) )
577 wk = t*( d22*a( j, k )-a( j, k-1 ) )
580 a( i, j ) = a( i, j ) - (a( i, k ) / d12 )*wk -
581 $ ( a( i, k-1 ) / d12 )*wkm1
587 a( j, k-1 ) = wkm1 / d12
608 IF( kstep.EQ.1 )
THEN
646 absakk = abs( a( k, k ) )
653 imax = k + idamax( n-k, a( k+1, k ), 1 )
654 colmax = abs( a( imax, k ) )
659 IF( ( max( absakk, colmax ).EQ.zero ) )
THEN
679 IF( .NOT.( absakk.LT.alpha*colmax ) )
THEN
700 jmax = k - 1 + idamax( imax-k, a( imax, k ), lda )
701 rowmax = abs( a( imax, jmax ) )
707 itemp = imax + idamax( n-imax, a( imax+1, imax ),
709 dtemp = abs( a( itemp, imax ) )
710 IF( dtemp.GT.rowmax )
THEN
719 IF( .NOT.( abs( a( imax, imax ) ).LT.alpha*rowmax ) )
731 ELSE IF( ( p.EQ.jmax ).OR.( rowmax.LE.colmax ) )
THEN
750 IF( .NOT. done )
GOTO 42
758 IF( ( kstep.EQ.2 ) .AND. ( p.NE.k ) )
THEN
764 $
CALL dswap( n-p, a( p+1, k ), 1, a( p+1, p ), 1 )
766 $
CALL dswap( p-k-1, a( k+1, k ), 1, a( p, k+1 ), lda )
768 a( k, k ) = a( p, p )
775 $
CALL dswap( k-1, a( k, 1 ), lda, a( p, 1 ), lda )
788 $
CALL dswap( n-kp, a( kp+1, kk ), 1, a( kp+1, kp ), 1 )
789 IF( ( kk.LT.n ) .AND. ( kp.GT.(kk+1) ) )
790 $
CALL dswap( kp-kk-1, a( kk+1, kk ), 1, a( kp, kk+1 ),
793 a( kk, kk ) = a( kp, kp )
795 IF( kstep.EQ.2 )
THEN
797 a( k+1, k ) = a( kp, k )
805 $
CALL dswap( k-1, a( kk, 1 ), lda, a( kp, 1 ), lda )
811 IF( kstep.EQ.1 )
THEN
824 IF( abs( a( k, k ) ).GE.sfmin )
THEN
830 d11 = one / a( k, k )
831 CALL dsyr( uplo, n-k, -d11, a( k+1, k ), 1,
832 $ a( k+1, k+1 ), lda )
836 CALL dscal( n-k, d11, a( k+1, k ), 1 )
843 a( ii, k ) = a( ii, k ) / d11
851 CALL dsyr( uplo, n-k, -d11, a( k+1, k ), 1,
852 $ a( k+1, k+1 ), lda )
881 d11 = a( k+1, k+1 ) / d21
882 d22 = a( k, k ) / d21
883 t = one / ( d11*d22-one )
889 wk = t*( d11*a( j, k )-a( j, k+1 ) )
890 wkp1 = t*( d22*a( j, k+1 )-a( j, k ) )
895 a( i, j ) = a( i, j ) - ( a( i, k ) / d21 )*wk -
896 $ ( a( i, k+1 ) / d21 )*wkp1
902 a( j, k+1 ) = wkp1 / d21
923 IF( kstep.EQ.1 )
THEN
subroutine dsyr(UPLO, N, ALPHA, X, INCX, A, LDA)
DSYR
subroutine dsytf2_rk(UPLO, N, A, LDA, E, IPIV, INFO)
DSYTF2_RK computes the factorization of a real symmetric indefinite matrix using the bounded Bunch-Ka...
subroutine dswap(N, DX, INCX, DY, INCY)
DSWAP
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine dscal(N, DA, DX, INCX)
DSCAL