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 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 xerbla(SRNAME, INFO)
XERBLA
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
subroutine sgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
SGEMM
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 ...
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
integer function ilaenv(ISPEC, NAME, OPTS, N1, N2, N3, N4)
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