210 SUBROUTINE slaed2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMBDA, W,
211 $ Q2, INDX, INDXC, INDXP, COLTYP, INFO )
218 INTEGER INFO, K, LDQ, N, N1
222 INTEGER COLTYP( * ), INDX( * ), INDXC( * ), INDXP( * ),
224 REAL D( * ), DLAMBDA( * ), Q( LDQ, * ), Q2( * ),
231 REAL MONE, ZERO, ONE, TWO, EIGHT
232 parameter( mone = -1.0e0, zero = 0.0e0, one = 1.0e0,
233 $ two = 2.0e0, eight = 8.0e0 )
236 INTEGER CTOT( 4 ), PSM( 4 )
239 INTEGER CT, I, IMAX, IQ1, IQ2, J, JMAX, JS, K2, N1P1,
241 REAL C, EPS, S, T, TAU, TOL
246 EXTERNAL isamax, slamch, slapy2
252 INTRINSIC abs, max, min, sqrt
262 ELSE IF( ldq.LT.max( 1, n ) )
THEN
264 ELSE IF( min( 1, ( n / 2 ) ).GT.n1 .OR. ( n / 2 ).LT.n1 )
THEN
268 CALL xerbla(
'SLAED2', -info )
280 IF( rho.LT.zero )
THEN
281 CALL sscal( n2, mone, z( n1p1 ), 1 )
287 t = one / sqrt( two )
288 CALL sscal( n, t, z, 1 )
297 indxq( i ) = indxq( i ) + n1
303 dlambda( i ) = d( indxq( i ) )
305 CALL slamrg( n1, n2, dlambda, 1, 1, indxc )
307 indx( i ) = indxq( indxc( i ) )
312 imax = isamax( n, z, 1 )
313 jmax = isamax( n, d, 1 )
314 eps = slamch(
'Epsilon' )
315 tol = eight*eps*max( abs( d( jmax ) ), abs( z( imax ) ) )
321 IF( rho*abs( z( imax ) ).LE.tol )
THEN
326 CALL scopy( n, q( 1, i ), 1, q2( iq2 ), 1 )
327 dlambda( j ) = d( i )
330 CALL slacpy(
'A', n, n, q2, n, q, ldq )
331 CALL scopy( n, dlambda, 1, d, 1 )
353 IF( rho*abs( z( nj ) ).LE.tol )
THEN
372 IF( rho*abs( z( nj ) ).LE.tol )
THEN
390 t = d( nj ) - d( pj )
393 IF( abs( t*c*s ).LE.tol )
THEN
399 IF( coltyp( nj ).NE.coltyp( pj ) )
402 CALL srot( n, q( 1, pj ), 1, q( 1, nj ), 1, c, s )
403 t = d( pj )*c**2 + d( nj )*s**2
404 d( nj ) = d( pj )*s**2 + d( nj )*c**2
410 IF( d( pj ).LT.d( indxp( k2+i ) ) )
THEN
411 indxp( k2+i-1 ) = indxp( k2+i )
424 dlambda( k ) = d( pj )
436 dlambda( k ) = d( pj )
450 ctot( ct ) = ctot( ct ) + 1
456 psm( 2 ) = 1 + ctot( 1 )
457 psm( 3 ) = psm( 2 ) + ctot( 2 )
458 psm( 4 ) = psm( 3 ) + ctot( 3 )
468 indx( psm( ct ) ) = js
469 indxc( psm( ct ) ) = j
470 psm( ct ) = psm( ct ) + 1
480 iq2 = 1 + ( ctot( 1 )+ctot( 2 ) )*n1
481 DO 140 j = 1, ctot( 1 )
483 CALL scopy( n1, q( 1, js ), 1, q2( iq1 ), 1 )
489 DO 150 j = 1, ctot( 2 )
491 CALL scopy( n1, q( 1, js ), 1, q2( iq1 ), 1 )
492 CALL scopy( n2, q( n1+1, js ), 1, q2( iq2 ), 1 )
499 DO 160 j = 1, ctot( 3 )
501 CALL scopy( n2, q( n1+1, js ), 1, q2( iq2 ), 1 )
508 DO 170 j = 1, ctot( 4 )
510 CALL scopy( n, q( 1, js ), 1, q2( iq2 ), 1 )
520 CALL slacpy(
'A', n, ctot( 4 ), q2( iq1 ), n,
522 CALL scopy( n-k, z( k+1 ), 1, d( k+1 ), 1 )
528 coltyp( j ) = ctot( j )
subroutine xerbla(srname, info)
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 slaed2(k, n, n1, d, q, ldq, indxq, rho, z, dlambda, 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 srot(n, sx, incx, sy, incy, c, s)
SROT
subroutine sscal(n, sa, sx, incx)
SSCAL