242 SUBROUTINE dlaed8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO,
243 $ cutpnt, z, dlamda, q2, ldq2, w, perm, givptr,
244 $ givcol, givnum, indxp, indx, info )
252 INTEGER cutpnt, givptr, icompq, info, k, ldq, ldq2, n,
257 INTEGER givcol( 2, * ), indx( * ), indxp( * ),
258 $ indxq( * ), perm( * )
259 DOUBLE PRECISION d( * ), dlamda( * ), givnum( 2, * ),
260 $ q( ldq, * ), q2( ldq2, * ), w( * ), z( * )
266 DOUBLE PRECISION mone, zero, one, two, eight
267 parameter( mone = -1.0d0, zero = 0.0d0, one = 1.0d0,
268 $ two = 2.0d0, eight = 8.0d0 )
272 INTEGER i, imax,
j, jlam, jmax, jp, k2, n1, n1p1, n2
273 DOUBLE PRECISION c, eps, s, t, tau, tol
284 INTRINSIC abs, max, min, sqrt
292 IF( icompq.LT.0 .OR. icompq.GT.1 )
THEN
294 ELSE IF( n.LT.0 )
THEN
296 ELSE IF( icompq.EQ.1 .AND. qsiz.LT.n )
THEN
298 ELSE IF( ldq.LT.max( 1, n ) )
THEN
300 ELSE IF( cutpnt.LT.min( 1, n ) .OR. cutpnt.GT.n )
THEN
302 ELSE IF( ldq2.LT.max( 1, n ) )
THEN
306 CALL
xerbla(
'DLAED8', -info )
326 IF( rho.LT.zero )
THEN
327 CALL
dscal( n2, mone, z( n1p1 ), 1 )
332 t = one / sqrt( two )
336 CALL
dscal( n, t, z, 1 )
341 DO 20 i = cutpnt + 1, n
342 indxq( i ) = indxq( i ) + cutpnt
345 dlamda( i ) = d( indxq( i ) )
346 w( i ) = z( indxq( i ) )
350 CALL
dlamrg( n1, n2, dlamda, 1, 1, indx )
352 d( i ) = dlamda( indx( i ) )
353 z( i ) = w( indx( i ) )
361 tol = eight*eps*abs( d( jmax ) )
367 IF( rho*abs( z( imax ) ).LE.tol )
THEN
369 IF( icompq.EQ.0 )
THEN
371 perm(
j ) = indxq( indx(
j ) )
375 perm(
j ) = indxq( indx(
j ) )
376 CALL
dcopy( qsiz, q( 1, perm(
j ) ), 1, q2( 1,
j ), 1 )
378 CALL
dlacpy(
'A', qsiz, n, q2( 1, 1 ), ldq2, q( 1, 1 ),
393 IF( rho*abs( z(
j ) ).LE.tol )
THEN
410 IF( rho*abs( z(
j ) ).LE.tol )
THEN
427 t = d(
j ) - d( jlam )
430 IF( abs( t*c*s ).LE.tol )
THEN
440 givcol( 1, givptr ) = indxq( indx( jlam ) )
441 givcol( 2, givptr ) = indxq( indx(
j ) )
442 givnum( 1, givptr ) = c
443 givnum( 2, givptr ) = s
444 IF( icompq.EQ.1 )
THEN
445 CALL
drot( qsiz, q( 1, indxq( indx( jlam ) ) ), 1,
446 $ q( 1, indxq( indx(
j ) ) ), 1, c, s )
448 t = d( jlam )*c*c + d(
j )*s*s
449 d(
j ) = d( jlam )*s*s + d(
j )*c*c
455 IF( d( jlam ).LT.d( indxp( k2+i ) ) )
THEN
456 indxp( k2+i-1 ) = indxp( k2+i )
461 indxp( k2+i-1 ) = jlam
464 indxp( k2+i-1 ) = jlam
470 dlamda( k ) = d( jlam )
482 dlamda( k ) = d( jlam )
492 IF( icompq.EQ.0 )
THEN
495 dlamda(
j ) = d( jp )
496 perm(
j ) = indxq( indx( jp ) )
501 dlamda(
j ) = d( jp )
502 perm(
j ) = indxq( indx( jp ) )
503 CALL
dcopy( qsiz, q( 1, perm(
j ) ), 1, q2( 1,
j ), 1 )
511 IF( icompq.EQ.0 )
THEN
512 CALL
dcopy( n-k, dlamda( k+1 ), 1, d( k+1 ), 1 )
514 CALL
dcopy( n-k, dlamda( k+1 ), 1, d( k+1 ), 1 )
515 CALL
dlacpy(
'A', qsiz, n-k, q2( 1, k+1 ), ldq2,
subroutine dlaed8(ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, CUTPNT, Z, DLAMDA, Q2, LDQ2, W, PERM, GIVPTR, GIVCOL, GIVNUM, INDXP, INDX, INFO)
DLAED8 used by sstedc. Merges eigenvalues and deflates secular equation. Used when the original matri...
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
subroutine dlamrg(N1, N2, A, DTRD1, DTRD2, INDEX)
DLAMRG creates a permutation list to merge the entries of two independently sorted sets into a single...
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine dscal(N, DA, DX, INCX)
DSCAL
double precision function dlapy2(X, Y)
DLAPY2 returns sqrt(x2+y2).
double precision function dlamch(CMACH)
DLAMCH
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine drot(N, DX, INCX, DY, INCY, C, S)
DROT
integer function idamax(N, DX, INCX)
IDAMAX
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.