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 dcopy(N, DX, INCX, DY, INCY)
DCOPY
subroutine zcopy(N, ZX, INCX, ZY, INCY)
ZCOPY
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 xerbla(SRNAME, INFO)
XERBLA
subroutine dscal(N, DA, DX, INCX)
DSCAL
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 dlamrg(N1, N2, A, DTRD1, DTRD2, INDEX)
DLAMRG creates a permutation list to merge the entries of two independently sorted sets into a single...