227 SUBROUTINE zlaed8( K, N, QSIZ, Q, LDQ, D, RHO, CUTPNT, Z, DLAMDA,
228 $ q2, ldq2, w, indxp, indx, indxq, perm, givptr,
229 $ givcol, givnum, info )
237 INTEGER CUTPNT, GIVPTR, INFO, K, LDQ, LDQ2, N, QSIZ
241 INTEGER GIVCOL( 2, * ), INDX( * ), INDXP( * ),
242 $ indxq( * ), perm( * )
243 DOUBLE PRECISION D( * ), DLAMDA( * ), GIVNUM( 2, * ), W( * ),
245 COMPLEX*16 Q( ldq, * ), Q2( ldq2, * )
251 DOUBLE PRECISION MONE, ZERO, ONE, TWO, EIGHT
252 parameter( mone = -1.0d0, zero = 0.0d0, one = 1.0d0,
253 $ two = 2.0d0, eight = 8.0d0 )
256 INTEGER I, IMAX, J, JLAM, JMAX, JP, K2, N1, N1P1, N2
257 DOUBLE PRECISION C, EPS, S, T, TAU, TOL
261 DOUBLE PRECISION DLAMCH, DLAPY2
262 EXTERNAL idamax, dlamch, dlapy2
269 INTRINSIC abs, max, min, sqrt
279 ELSE IF( qsiz.LT.n )
THEN
281 ELSE IF( ldq.LT.max( 1, n ) )
THEN
283 ELSE IF( cutpnt.LT.min( 1, n ) .OR. cutpnt.GT.n )
THEN
285 ELSE IF( ldq2.LT.max( 1, n ) )
THEN
289 CALL
xerbla(
'ZLAED8', -info )
309 IF( rho.LT.zero )
THEN
310 CALL
dscal( n2, mone, z( n1p1 ), 1 )
315 t = one / sqrt( two )
319 CALL
dscal( n, t, z, 1 )
324 DO 20 i = cutpnt + 1, n
325 indxq( i ) = indxq( i ) + cutpnt
328 dlamda( i ) = d( indxq( i ) )
329 w( i ) = z( indxq( i ) )
333 CALL
dlamrg( n1, n2, dlamda, 1, 1, indx )
335 d( i ) = dlamda( indx( i ) )
336 z( i ) = w( indx( i ) )
341 imax = idamax( n, z, 1 )
342 jmax = idamax( n, d, 1 )
343 eps = dlamch(
'Epsilon' )
344 tol = eight*eps*abs( d( jmax ) )
350 IF( rho*abs( z( imax ) ).LE.tol )
THEN
353 perm( j ) = indxq( indx( j ) )
354 CALL
zcopy( qsiz, q( 1, perm( j ) ), 1, q2( 1, j ), 1 )
356 CALL
zlacpy(
'A', qsiz, n, q2( 1, 1 ), ldq2, q( 1, 1 ), ldq )
369 IF( rho*abs( z( j ) ).LE.tol )
THEN
386 IF( rho*abs( z( j ) ).LE.tol )
THEN
403 t = d( j ) - d( jlam )
406 IF( abs( t*c*s ).LE.tol )
THEN
416 givcol( 1, givptr ) = indxq( indx( jlam ) )
417 givcol( 2, givptr ) = indxq( indx( j ) )
418 givnum( 1, givptr ) = c
419 givnum( 2, givptr ) = s
420 CALL
zdrot( qsiz, q( 1, indxq( indx( jlam ) ) ), 1,
421 $ q( 1, indxq( indx( j ) ) ), 1, c, s )
422 t = d( jlam )*c*c + d( j )*s*s
423 d( j ) = d( jlam )*s*s + d( j )*c*c
429 IF( d( jlam ).LT.d( indxp( k2+i ) ) )
THEN
430 indxp( k2+i-1 ) = indxp( k2+i )
435 indxp( k2+i-1 ) = jlam
438 indxp( k2+i-1 ) = jlam
444 dlamda( k ) = d( jlam )
456 dlamda( k ) = d( jlam )
468 dlamda( j ) = d( jp )
469 perm( j ) = indxq( indx( jp ) )
470 CALL
zcopy( qsiz, q( 1, perm( j ) ), 1, q2( 1, j ), 1 )
477 CALL
dcopy( n-k, dlamda( k+1 ), 1, d( k+1 ), 1 )
478 CALL
zlacpy(
'A', qsiz, n-k, q2( 1, k+1 ), ldq2, q( 1, k+1 ),
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
subroutine zdrot(N, CX, INCX, CY, INCY, C, S)
ZDROT
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 zlaed8(K, N, QSIZ, Q, LDQ, D, RHO, CUTPNT, Z, DLAMDA, Q2, LDQ2, W, INDXP, INDX, INDXQ, PERM, GIVPTR, GIVCOL, GIVNUM, INFO)
ZLAED8 used by sstedc. Merges eigenvalues and deflates secular equation. Used when the original matri...
subroutine zcopy(N, ZX, INCX, ZY, INCY)
ZCOPY
subroutine dscal(N, DA, DX, INCX)
DSCAL