172 SUBROUTINE slaed0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS,
173 $ work, iwork, info )
181 INTEGER ICOMPQ, INFO, LDQ, LDQS, N, QSIZ
185 REAL D( * ), E( * ), Q( ldq, * ), QSTORE( ldqs, * ),
193 parameter ( zero = 0.e0, one = 1.e0, two = 2.e0 )
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
211 INTRINSIC abs, int, log, max, real
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(
'SLAED0', -info )
240 smlsiz = ilaenv( 9,
'SLAED0',
' ', 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(
REAL( 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 ssteqr(
'I', matsiz, d( submat ), e( submat ),
318 $ q( submat, submat ), ldq, work, info )
322 CALL ssteqr(
'I', matsiz, d( submat ), e( submat ),
323 $ work( iq-1+iwork( iqptr+curr ) ), matsiz, work,
327 IF( icompq.EQ.1 )
THEN
328 CALL sgemm(
'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 slaed1( 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 slaed7( 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 scopy( qsiz, qstore( 1, j ), 1, q( 1, i ), 1 )
408 CALL scopy( n, work, 1, d, 1 )
409 ELSE IF( icompq.EQ.2 )
THEN
413 CALL scopy( n, q( 1, j ), 1, work( n*i+1 ), 1 )
415 CALL scopy( n, work, 1, d, 1 )
416 CALL slacpy(
'A', n, n, work( n+1 ), n, q, ldq )
422 CALL scopy( n, work, 1, d, 1 )
427 info = submat*( n+1 ) + submat + matsiz - 1
subroutine sgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
SGEMM
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
subroutine slaed1(N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK, INFO)
SLAED1 used by sstedc. Computes the updated eigensystem of a diagonal matrix after modification by a ...
subroutine ssteqr(COMPZ, N, D, E, Z, LDZ, WORK, INFO)
SSTEQR
subroutine slaed0(ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, WORK, IWORK, INFO)
SLAED0 used by sstedc. Computes all eigenvalues and corresponding eigenvectors of an unreduced symmet...
subroutine slaed7(ICOMPQ, N, QSIZ, TLVLS, CURLVL, CURPBM, D, Q, LDQ, INDXQ, RHO, CUTPNT, QSTORE, QPTR, PRMPTR, PERM, GIVPTR, GIVCOL, GIVNUM, WORK, IWORK, INFO)
SLAED7 used by sstedc. Computes the updated eigensystem of a diagonal matrix after modification by a ...
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY