212 SUBROUTINE slaed2( 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 REAL D( * ), DLAMDA( * ), Q( ldq, * ), Q2( * ),
234 REAL MONE, ZERO, ONE, TWO, EIGHT
235 parameter( mone = -1.0e0, zero = 0.0e0, one = 1.0e0,
236 $ two = 2.0e0, eight = 8.0e0 )
239 INTEGER CTOT( 4 ), PSM( 4 )
242 INTEGER CT, I, IMAX, IQ1, IQ2, J, JMAX, JS, K2, N1P1,
244 REAL C, EPS, S, T, TAU, TOL
249 EXTERNAL isamax, slamch, slapy2
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(
'SLAED2', -info )
283 IF( rho.LT.zero )
THEN
284 CALL
sscal( n2, mone, z( n1p1 ), 1 )
290 t = one / sqrt( two )
291 CALL
sscal( n, t, z, 1 )
300 indxq( i ) = indxq( i ) + n1
306 dlamda( i ) = d( indxq( i ) )
308 CALL
slamrg( n1, n2, dlamda, 1, 1, indxc )
310 indx( i ) = indxq( indxc( i ) )
315 imax = isamax( n, z, 1 )
316 jmax = isamax( n, d, 1 )
317 eps = slamch(
'Epsilon' )
318 tol = eight*eps*max( abs( d( jmax ) ), abs( z( imax ) ) )
324 IF( rho*abs( z( imax ) ).LE.tol )
THEN
329 CALL
scopy( n, q( 1, i ), 1, q2( iq2 ), 1 )
333 CALL
slacpy(
'A', n, n, q2, n, q, ldq )
334 CALL
scopy( 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
srot( 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
scopy( n1, q( 1, js ), 1, q2( iq1 ), 1 )
492 DO 150 j = 1, ctot( 2 )
494 CALL
scopy( n1, q( 1, js ), 1, q2( iq1 ), 1 )
495 CALL
scopy( n2, q( n1+1, js ), 1, q2( iq2 ), 1 )
502 DO 160 j = 1, ctot( 3 )
504 CALL
scopy( n2, q( n1+1, js ), 1, q2( iq2 ), 1 )
511 DO 170 j = 1, ctot( 4 )
513 CALL
scopy( n, q( 1, js ), 1, q2( iq2 ), 1 )
523 CALL
slacpy(
'A', n, ctot( 4 ), q2( iq1 ), n,
525 CALL
scopy( n-k, z( k+1 ), 1, d( k+1 ), 1 )
531 coltyp( j ) = ctot( j )
subroutine slaed2(K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W, Q2, INDX, INDXC, INDXP, COLTYP, INFO)
SLAED2 used by sstedc. Merges eigenvalues and deflates secular equation. Used when the original matri...
subroutine slamrg(N1, N2, A, STRD1, STRD2, INDEX)
SLAMRG creates a permutation list to merge the entries of two independently sorted sets into a single...
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 sscal(N, SA, SX, INCX)
SSCAL
subroutine srot(N, SX, INCX, SY, INCY, C, S)
SROT