133 SUBROUTINE csteqr( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
145 REAL D( * ), E( * ), WORK( * )
152 REAL ZERO, ONE, TWO, THREE
153 parameter( zero = 0.0e0, one = 1.0e0, two = 2.0e0,
156 parameter( czero = ( 0.0e0, 0.0e0 ),
157 $ cone = ( 1.0e0, 0.0e0 ) )
159 parameter( maxit = 30 )
162 INTEGER I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND,
163 $ lendm1, lendp1, lendsv, lm1, lsv, m, mm, mm1,
165 REAL ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2,
166 $ s, safmax, safmin, ssfmax, ssfmin, tst
170 REAL SLAMCH, SLANST, SLAPY2
171 EXTERNAL lsame, slamch, slanst, slapy2
178 INTRINSIC abs, max, sign, sqrt
186 IF( lsame( compz,
'N' ) )
THEN
188 ELSE IF( lsame( compz,
'V' ) )
THEN
190 ELSE IF( lsame( compz,
'I' ) )
THEN
195 IF( icompz.LT.0 )
THEN
197 ELSE IF( n.LT.0 )
THEN
199 ELSE IF( ( ldz.LT.1 ) .OR. ( icompz.GT.0 .AND. ldz.LT.max( 1,
204 CALL
xerbla(
'CSTEQR', -info )
223 safmin = slamch(
'S' )
224 safmax = one / safmin
225 ssfmax = sqrt( safmax ) / three
226 ssfmin = sqrt( safmin ) / eps2
232 $ CALL
claset(
'Full', n, n, czero, cone, z, ldz )
254 IF( tst.LE.( sqrt( abs( d( m ) ) )*sqrt( abs( d( m+
255 $ 1 ) ) ) )*eps )
THEN
274 anorm = slanst(
'I', lend-l+1, d( l ), e( l ) )
278 IF( anorm.GT.ssfmax )
THEN
280 CALL
slascl(
'G', 0, 0, anorm, ssfmax, lend-l+1, 1, d( l ), n,
282 CALL
slascl(
'G', 0, 0, anorm, ssfmax, lend-l, 1, e( l ), n,
284 ELSE IF( anorm.LT.ssfmin )
THEN
286 CALL
slascl(
'G', 0, 0, anorm, ssfmin, lend-l+1, 1, d( l ), n,
288 CALL
slascl(
'G', 0, 0, anorm, ssfmin, lend-l, 1, e( l ), n,
294 IF( abs( d( lend ) ).LT.abs( d( l ) ) )
THEN
309 tst = abs( e( m ) )**2
310 IF( tst.LE.( eps2*abs( d( m ) ) )*abs( d( m+1 ) )+
328 IF( icompz.GT.0 )
THEN
329 CALL
slaev2( d( l ), e( l ), d( l+1 ), rt1, rt2, c, s )
332 CALL
clasr(
'R',
'V',
'B', n, 2, work( l ),
333 $ work( n-1+l ), z( 1, l ), ldz )
335 CALL
slae2( d( l ), e( l ), d( l+1 ), rt1, rt2 )
352 g = ( d( l+1 )-p ) / ( two*e( l ) )
354 g = d( m ) - p + ( e( l ) / ( g+sign( r, g ) ) )
366 CALL
slartg( g, f, c, s, r )
370 r = ( d( i )-g )*s + two*c*b
377 IF( icompz.GT.0 )
THEN
386 IF( icompz.GT.0 )
THEN
388 CALL
clasr(
'R',
'V',
'B', n, mm, work( l ), work( n-1+l ),
415 DO 100 m = l, lendp1, -1
416 tst = abs( e( m-1 ) )**2
417 IF( tst.LE.( eps2*abs( d( m ) ) )*abs( d( m-1 ) )+
435 IF( icompz.GT.0 )
THEN
436 CALL
slaev2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2, c, s )
439 CALL
clasr(
'R',
'V',
'F', n, 2, work( m ),
440 $ work( n-1+m ), z( 1, l-1 ), ldz )
442 CALL
slae2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2 )
459 g = ( d( l-1 )-p ) / ( two*e( l-1 ) )
461 g = d( m ) - p + ( e( l-1 ) / ( g+sign( r, g ) ) )
473 CALL
slartg( g, f, c, s, r )
477 r = ( d( i+1 )-g )*s + two*c*b
484 IF( icompz.GT.0 )
THEN
493 IF( icompz.GT.0 )
THEN
495 CALL
clasr(
'R',
'V',
'F', n, mm, work( m ), work( n-1+m ),
518 IF( iscale.EQ.1 )
THEN
519 CALL
slascl(
'G', 0, 0, ssfmax, anorm, lendsv-lsv+1, 1,
520 $ d( lsv ), n, info )
521 CALL
slascl(
'G', 0, 0, ssfmax, anorm, lendsv-lsv, 1, e( lsv ),
523 ELSE IF( iscale.EQ.2 )
THEN
524 CALL
slascl(
'G', 0, 0, ssfmin, anorm, lendsv-lsv+1, 1,
525 $ d( lsv ), n, info )
526 CALL
slascl(
'G', 0, 0, ssfmin, anorm, lendsv-lsv, 1, e( lsv ),
533 IF( jtot.EQ.nmaxit )
THEN
545 IF( icompz.EQ.0 )
THEN
549 CALL
slasrt(
'I', n, d, info )
560 IF( d( j ).LT.p )
THEN
568 CALL
cswap( n, z( 1, i ), 1, z( 1, k ), 1 )
subroutine claset(UPLO, M, N, ALPHA, BETA, A, LDA)
CLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine slae2(A, B, C, RT1, RT2)
SLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix.
subroutine slaev2(A, B, C, RT1, RT2, CS1, SN1)
SLAEV2 computes the eigenvalues and eigenvectors of a 2-by-2 symmetric/Hermitian matrix.
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine clasr(SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA)
CLASR applies a sequence of plane rotations to a general rectangular matrix.
subroutine cswap(N, CX, INCX, CY, INCY)
CSWAP
subroutine slascl(TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO)
SLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
subroutine csteqr(COMPZ, N, D, E, Z, LDZ, WORK, INFO)
CSTEQR
subroutine slasrt(ID, N, D, INFO)
SLASRT sorts numbers in increasing or decreasing order.
subroutine slartg(F, G, CS, SN, R)
SLARTG generates a plane rotation with real cosine and real sine.