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 srot(N, SX, INCX, SY, INCY, C, S)
SROT
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 sscal(N, SA, SX, INCX)
SSCAL
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY