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 dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
subroutine dsteqr(COMPZ, N, D, E, Z, LDZ, WORK, INFO)
DSTEQR
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
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 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 dgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
DGEMM
subroutine xerbla(SRNAME, INFO)
XERBLA
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...