212 SUBROUTINE cstedc( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, RWORK,
213 $ lrwork, iwork, liwork, info )
222 INTEGER INFO, LDZ, LIWORK, LRWORK, LWORK, N
226 REAL D( * ), E( * ), RWORK( * )
227 COMPLEX WORK( * ), Z( ldz, * )
234 parameter( zero = 0.0e0, one = 1.0e0, two = 2.0e0 )
238 INTEGER FINISH, I, ICOMPZ, II, J, K, LGN, LIWMIN, LL,
239 $ lrwmin, lwmin, m, smlsiz, start
240 REAL EPS, ORGNRM, P, TINY
246 EXTERNAL ilaenv, lsame, slamch, slanst
253 INTRINSIC abs, int, log, max, mod,
REAL, SQRT
260 lquery = ( lwork.EQ.-1 .OR. lrwork.EQ.-1 .OR. liwork.EQ.-1 )
262 IF( lsame( compz,
'N' ) )
THEN
264 ELSE IF( lsame( compz,
'V' ) )
THEN
266 ELSE IF( lsame( compz,
'I' ) )
THEN
271 IF( icompz.LT.0 )
THEN
273 ELSE IF( n.LT.0 )
THEN
275 ELSE IF( ( ldz.LT.1 ) .OR.
276 $ ( icompz.GT.0 .AND. ldz.LT.max( 1, n ) ) )
THEN
284 smlsiz = ilaenv( 9,
'CSTEDC',
' ', 0, 0, 0, 0 )
285 IF( n.LE.1 .OR. icompz.EQ.0 )
THEN
289 ELSE IF( n.LE.smlsiz )
THEN
293 ELSE IF( icompz.EQ.1 )
THEN
294 lgn = int( log(
REAL( N ) ) / log( TWO ) )
300 lrwmin = 1 + 3*n + 2*n*lgn + 4*n**2
301 liwmin = 6 + 6*n + 5*n*lgn
302 ELSE IF( icompz.EQ.2 )
THEN
304 lrwmin = 1 + 4*n + 2*n**2
311 IF( lwork.LT.lwmin .AND. .NOT.lquery )
THEN
313 ELSE IF( lrwork.LT.lrwmin .AND. .NOT.lquery )
THEN
315 ELSE IF( liwork.LT.liwmin .AND. .NOT.lquery )
THEN
321 CALL
xerbla(
'CSTEDC', -info )
323 ELSE IF( lquery )
THEN
348 IF( icompz.EQ.0 )
THEN
349 CALL
ssterf( n, d, e, info )
356 IF( n.LE.smlsiz )
THEN
358 CALL
csteqr( compz, n, d, e, z, ldz, rwork, info )
364 IF( icompz.EQ.2 )
THEN
365 CALL
slaset(
'Full', n, n, zero, one, rwork, n )
367 CALL
sstedc(
'I', n, d, e, rwork, n,
368 $ rwork( ll ), lrwork-ll+1, iwork, liwork, info )
371 z( i, j ) = rwork( ( j-1 )*n+i )
382 orgnrm = slanst(
'M', n, d, e )
386 eps = slamch(
'Epsilon' )
393 IF( start.LE.n )
THEN
403 IF( finish.LT.n )
THEN
404 tiny = eps*sqrt( abs( d( finish ) ) )*
405 $ sqrt( abs( d( finish+1 ) ) )
406 IF( abs( e( finish ) ).GT.tiny )
THEN
414 m = finish - start + 1
415 IF( m.GT.smlsiz )
THEN
419 orgnrm = slanst(
'M', m, d( start ), e( start ) )
420 CALL
slascl(
'G', 0, 0, orgnrm, one, m, 1, d( start ), m,
422 CALL
slascl(
'G', 0, 0, orgnrm, one, m-1, 1, e( start ),
425 CALL
claed0( n, m, d( start ), e( start ), z( 1, start ),
426 $ ldz, work, n, rwork, iwork, info )
428 info = ( info / ( m+1 )+start-1 )*( n+1 ) +
429 $ mod( info, ( m+1 ) ) + start - 1
435 CALL
slascl(
'G', 0, 0, one, orgnrm, m, 1, d( start ), m,
439 CALL
ssteqr(
'I', m, d( start ), e( start ), rwork, m,
440 $ rwork( m*m+1 ), info )
441 CALL
clacrm( n, m, z( 1, start ), ldz, rwork, m, work, n,
443 CALL
clacpy(
'A', n, m, work, n, z( 1, start ), ldz )
445 info = start*( n+1 ) + finish
469 IF( d( j ).LT.p )
THEN
477 CALL
cswap( n, z( 1, i ), 1, z( 1, k ), 1 )
subroutine slaset(UPLO, M, N, ALPHA, BETA, A, LDA)
SLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine cstedc(COMPZ, N, D, E, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO)
CSTEDC
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine cswap(N, CX, INCX, CY, INCY)
CSWAP
subroutine claed0(QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, RWORK, IWORK, INFO)
CLAED0 used by sstedc. Computes all eigenvalues and corresponding eigenvectors of an unreduced symmet...
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 clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
subroutine csteqr(COMPZ, N, D, E, Z, LDZ, WORK, INFO)
CSTEQR
subroutine sstedc(COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO)
SSTEBZ
subroutine clacrm(M, N, A, LDA, B, LDB, C, LDC, RWORK)
CLACRM multiplies a complex matrix by a square real matrix.
subroutine ssterf(N, D, E, INFO)
SSTERF
subroutine ssteqr(COMPZ, N, D, E, Z, LDZ, WORK, INFO)
SSTEQR