212 SUBROUTINE dlaed2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W,
213 $ q2, indx, indxc, indxp, coltyp, info )
221 INTEGER INFO, K, LDQ, N, N1
225 INTEGER COLTYP( * ), INDX( * ), INDXC( * ), INDXP( * ),
227 DOUBLE PRECISION D( * ), DLAMDA( * ), Q( ldq, * ), Q2( * ),
234 DOUBLE PRECISION MONE, ZERO, ONE, TWO, EIGHT
235 parameter ( mone = -1.0d0, zero = 0.0d0, one = 1.0d0,
236 $ two = 2.0d0, eight = 8.0d0 )
239 INTEGER CTOT( 4 ), PSM( 4 )
242 INTEGER CT, I, IMAX, IQ1, IQ2, J, JMAX, JS, K2, N1P1,
244 DOUBLE PRECISION C, EPS, S, T, TAU, TOL
248 DOUBLE PRECISION DLAMCH, DLAPY2
249 EXTERNAL idamax, dlamch, dlapy2
255 INTRINSIC abs, max, min, sqrt
265 ELSE IF( ldq.LT.max( 1, n ) )
THEN
267 ELSE IF( min( 1, ( n / 2 ) ).GT.n1 .OR. ( n / 2 ).LT.n1 )
THEN
271 CALL xerbla(
'DLAED2', -info )
283 IF( rho.LT.zero )
THEN
284 CALL dscal( n2, mone, z( n1p1 ), 1 )
290 t = one / sqrt( two )
291 CALL dscal( n, t, z, 1 )
300 indxq( i ) = indxq( i ) + n1
306 dlamda( i ) = d( indxq( i ) )
308 CALL dlamrg( n1, n2, dlamda, 1, 1, indxc )
310 indx( i ) = indxq( indxc( i ) )
315 imax = idamax( n, z, 1 )
316 jmax = idamax( n, d, 1 )
317 eps = dlamch(
'Epsilon' )
318 tol = eight*eps*max( abs( d( jmax ) ), abs( z( imax ) ) )
324 IF( rho*abs( z( imax ) ).LE.tol )
THEN
329 CALL dcopy( n, q( 1, i ), 1, q2( iq2 ), 1 )
333 CALL dlacpy(
'A', n, n, q2, n, q, ldq )
334 CALL dcopy( n, dlamda, 1, d, 1 )
356 IF( rho*abs( z( nj ) ).LE.tol )
THEN
375 IF( rho*abs( z( nj ) ).LE.tol )
THEN
393 t = d( nj ) - d( pj )
396 IF( abs( t*c*s ).LE.tol )
THEN
402 IF( coltyp( nj ).NE.coltyp( pj ) )
405 CALL drot( n, q( 1, pj ), 1, q( 1, nj ), 1, c, s )
406 t = d( pj )*c**2 + d( nj )*s**2
407 d( nj ) = d( pj )*s**2 + d( nj )*c**2
413 IF( d( pj ).LT.d( indxp( k2+i ) ) )
THEN
414 indxp( k2+i-1 ) = indxp( k2+i )
427 dlamda( k ) = d( pj )
439 dlamda( k ) = d( pj )
453 ctot( ct ) = ctot( ct ) + 1
459 psm( 2 ) = 1 + ctot( 1 )
460 psm( 3 ) = psm( 2 ) + ctot( 2 )
461 psm( 4 ) = psm( 3 ) + ctot( 3 )
471 indx( psm( ct ) ) = js
472 indxc( psm( ct ) ) = j
473 psm( ct ) = psm( ct ) + 1
483 iq2 = 1 + ( ctot( 1 )+ctot( 2 ) )*n1
484 DO 140 j = 1, ctot( 1 )
486 CALL dcopy( n1, q( 1, js ), 1, q2( iq1 ), 1 )
492 DO 150 j = 1, ctot( 2 )
494 CALL dcopy( n1, q( 1, js ), 1, q2( iq1 ), 1 )
495 CALL dcopy( n2, q( n1+1, js ), 1, q2( iq2 ), 1 )
502 DO 160 j = 1, ctot( 3 )
504 CALL dcopy( n2, q( n1+1, js ), 1, q2( iq2 ), 1 )
511 DO 170 j = 1, ctot( 4 )
513 CALL dcopy( n, q( 1, js ), 1, q2( iq2 ), 1 )
523 CALL dlacpy(
'A', n, ctot( 4 ), q2( iq1 ), n,
525 CALL dcopy( n-k, z( k+1 ), 1, d( k+1 ), 1 )
531 coltyp( j ) = ctot( j )
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
subroutine drot(N, DX, INCX, DY, INCY, C, S)
DROT
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
subroutine dlaed2(K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W, Q2, INDX, INDXC, INDXP, COLTYP, INFO)
DLAED2 used by sstedc. Merges eigenvalues and deflates secular equation. Used when the original matri...