172 SUBROUTINE dlaed0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS,
173 $ work, iwork, info )
181 INTEGER icompq, info, ldq, ldqs, n, qsiz
185 DOUBLE PRECISION d( * ), e( * ), q( ldq, * ), qstore( ldqs, * ),
192 DOUBLE PRECISION zero, one, two
193 parameter( zero = 0.d0, one = 1.d0, two = 2.d0 )
196 INTEGER curlvl, curprb, curr, i, igivcl, igivnm,
197 $ igivpt, indxq, iperm, iprmpt, iq, iqptr, iwrem,
198 $
j, k, lgn, matsiz, msd2, smlsiz, smm1, spm1,
199 $ spm2, submat, subpbs, tlvls
200 DOUBLE PRECISION temp
211 INTRINSIC abs, dble, int, log, max
219 IF( icompq.LT.0 .OR. icompq.GT.2 )
THEN
221 ELSE IF( ( icompq.EQ.1 ) .AND. ( qsiz.LT.max( 0, n ) ) )
THEN
223 ELSE IF( n.LT.0 )
THEN
225 ELSE IF( ldq.LT.max( 1, n ) )
THEN
227 ELSE IF( ldqs.LT.max( 1, n ) )
THEN
231 CALL
xerbla(
'DLAED0', -info )
240 smlsiz =
ilaenv( 9,
'DLAED0',
' ', 0, 0, 0, 0 )
249 IF( iwork( subpbs ).GT.smlsiz )
THEN
250 DO 20
j = subpbs, 1, -1
251 iwork( 2*
j ) = ( iwork(
j )+1 ) / 2
252 iwork( 2*
j-1 ) = iwork(
j ) / 2
259 iwork(
j ) = iwork(
j ) + iwork(
j-1 )
267 submat = iwork( i ) + 1
269 d( smm1 ) = d( smm1 ) - abs( e( smm1 ) )
270 d( submat ) = d( submat ) - abs( e( smm1 ) )
274 IF( icompq.NE.2 )
THEN
279 temp = log( dble( n ) ) / log( two )
285 iprmpt = indxq + n + 1
286 iperm = iprmpt + n*lgn
287 iqptr = iperm + n*lgn
288 igivpt = iqptr + n + 2
289 igivcl = igivpt + n*lgn
292 iq = igivnm + 2*n*lgn
293 iwrem = iq + n**2 + 1
298 iwork( iprmpt+i ) = 1
299 iwork( igivpt+i ) = 1
313 submat = iwork( i ) + 1
314 matsiz = iwork( i+1 ) - iwork( i )
316 IF( icompq.EQ.2 )
THEN
317 CALL
dsteqr(
'I', matsiz, d( submat ), e( submat ),
318 $ q( submat, submat ), ldq, work, info )
322 CALL
dsteqr(
'I', matsiz, d( submat ), e( submat ),
323 $ work( iq-1+iwork( iqptr+curr ) ), matsiz, work,
327 IF( icompq.EQ.1 )
THEN
328 CALL
dgemm(
'N',
'N', qsiz, matsiz, matsiz, one,
329 $ q( 1, submat ), ldq, work( iq-1+iwork( iqptr+
330 $ curr ) ), matsiz, zero, qstore( 1, submat ),
333 iwork( iqptr+curr+1 ) = iwork( iqptr+curr ) + matsiz**2
337 DO 60
j = submat, iwork( i+1 )
350 IF( subpbs.GT.1 )
THEN
359 submat = iwork( i ) + 1
360 matsiz = iwork( i+2 ) - iwork( i )
373 IF( icompq.EQ.2 )
THEN
374 CALL
dlaed1( matsiz, d( submat ), q( submat, submat ),
375 $ ldq, iwork( indxq+submat ),
376 $ e( submat+msd2-1 ), msd2, work,
377 $ iwork( subpbs+1 ), info )
379 CALL
dlaed7( icompq, matsiz, qsiz, tlvls, curlvl, curprb,
380 $ d( submat ), qstore( 1, submat ), ldqs,
381 $ iwork( indxq+submat ), e( submat+msd2-1 ),
382 $ msd2, work( iq ), iwork( iqptr ),
383 $ iwork( iprmpt ), iwork( iperm ),
384 $ iwork( igivpt ), iwork( igivcl ),
385 $ work( igivnm ), work( iwrem ),
386 $ iwork( subpbs+1 ), info )
390 iwork( i / 2+1 ) = iwork( i+2 )
402 IF( icompq.EQ.1 )
THEN
406 CALL
dcopy( qsiz, qstore( 1,
j ), 1, q( 1, i ), 1 )
408 CALL
dcopy( n, work, 1, d, 1 )
409 ELSE IF( icompq.EQ.2 )
THEN
413 CALL
dcopy( n, q( 1,
j ), 1, work( n*i+1 ), 1 )
415 CALL
dcopy( n, work, 1, d, 1 )
416 CALL
dlacpy(
'A', n, n, work( n+1 ), n, q, ldq )
422 CALL
dcopy( n, work, 1, d, 1 )
427 info = submat*( n+1 ) + submat + matsiz - 1
subroutine dsteqr(COMPZ, N, D, E, Z, LDZ, WORK, INFO)
DSTEQR
subroutine dlaed0(ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, WORK, IWORK, INFO)
DLAED0 used by sstedc. Computes all eigenvalues and corresponding eigenvectors of an unreduced symmet...
subroutine dgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
DGEMM
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
subroutine dlaed7(ICOMPQ, N, QSIZ, TLVLS, CURLVL, CURPBM, D, Q, LDQ, INDXQ, RHO, CUTPNT, QSTORE, QPTR, PRMPTR, PERM, GIVPTR, GIVCOL, GIVNUM, WORK, IWORK, INFO)
DLAED7 used by sstedc. Computes the updated eigensystem of a diagonal matrix after modification by a ...
subroutine xerbla(SRNAME, INFO)
XERBLA
INTEGER function ilaenv(ISPEC, NAME, OPTS, N1, N2, N3, N4)
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine dlaed1(N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK, INFO)
DLAED1 used by sstedc. Computes the updated eigensystem of a diagonal matrix after modification by a ...
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.