141 SUBROUTINE slaed6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO )
161 parameter( maxit = 40 )
162 REAL zero, one, two, three, four, eight
163 parameter( zero = 0.0e0, one = 1.0e0, two = 2.0e0,
164 $ three = 3.0e0, four = 4.0e0, eight = 8.0e0 )
171 REAL dscale( 3 ), zscale( 3 )
175 INTEGER i, iter, niter
176 REAL a,
b, base, c, ddf, df, eps, erretm, eta, f,
177 $ fc, sclfac, sclinv, small1, small2, sminv1,
178 $ sminv2, temp, temp1, temp2, temp3, temp4,
182 INTRINSIC abs, int, log, max, min, sqrt
195 IF( finit .LT. zero )
THEN
203 IF( kniter.EQ.2 )
THEN
205 temp = ( d( 3 )-d( 2 ) ) / two
206 c = rho + z( 1 ) / ( ( d( 1 )-d( 2 ) )-temp )
207 a = c*( d( 2 )+d( 3 ) ) + z( 2 ) + z( 3 )
208 b = c*d( 2 )*d( 3 ) + z( 2 )*d( 3 ) + z( 3 )*d( 2 )
210 temp = ( d( 1 )-d( 2 ) ) / two
211 c = rho + z( 3 ) / ( ( d( 3 )-d( 2 ) )-temp )
212 a = c*( d( 1 )+d( 2 ) ) + z( 1 ) + z( 2 )
213 b = c*d( 1 )*d( 2 ) + z( 1 )*d( 2 ) + z( 2 )*d( 1 )
215 temp = max( abs( a ), abs(
b ), abs( c ) )
221 ELSE IF( a.LE.zero )
THEN
222 tau = ( a-sqrt( abs( a*a-four*
b*c ) ) ) / ( two*c )
224 tau = two*
b / ( a+sqrt( abs( a*a-four*
b*c ) ) )
226 IF( tau .LT. lbd .OR. tau .GT. ubd )
227 $ tau = ( lbd+ubd )/two
228 IF( d(1).EQ.tau .OR. d(2).EQ.tau .OR. d(3).EQ.tau )
THEN
231 temp = finit + tau*z(1)/( d(1)*( d( 1 )-tau ) ) +
232 $ tau*z(2)/( d(2)*( d( 2 )-tau ) ) +
233 $ tau*z(3)/( d(3)*( d( 3 )-tau ) )
234 IF( temp .LE. zero )
THEN
239 IF( abs( finit ).LE.abs( temp ) )
252 small1 = base**( int( log(
slamch(
'SafMin' ) ) / log( base ) /
254 sminv1 = one / small1
255 small2 = small1*small1
256 sminv2 = sminv1*sminv1
262 temp = min( abs( d( 2 )-tau ), abs( d( 3 )-tau ) )
264 temp = min( abs( d( 1 )-tau ), abs( d( 2 )-tau ) )
267 IF( temp.LE.small1 )
THEN
269 IF( temp.LE.small2 )
THEN
286 dscale( i ) = d( i )*sclfac
287 zscale( i ) = z( i )*sclfac
306 temp = one / ( dscale( i )-tau )
307 temp1 = zscale( i )*temp
310 fc = fc + temp1 / dscale( i )
316 IF( abs( f ).LE.zero )
318 IF( f .LE. zero )
THEN
337 DO 50 niter = iter, maxit
340 temp1 = dscale( 2 ) - tau
341 temp2 = dscale( 3 ) - tau
343 temp1 = dscale( 1 ) - tau
344 temp2 = dscale( 2 ) - tau
346 a = ( temp1+temp2 )*f - temp1*temp2*df
348 c = f - ( temp1+temp2 )*df + temp1*temp2*ddf
349 temp = max( abs( a ), abs(
b ), abs( c ) )
355 ELSE IF( a.LE.zero )
THEN
356 eta = ( a-sqrt( abs( a*a-four*
b*c ) ) ) / ( two*c )
358 eta = two*
b / ( a+sqrt( abs( a*a-four*
b*c ) ) )
360 IF( f*eta.GE.zero )
THEN
365 IF( tau .LT. lbd .OR. tau .GT. ubd )
366 $ tau = ( lbd + ubd )/two
373 IF ( ( dscale( i )-tau ).NE.zero )
THEN
374 temp = one / ( dscale( i )-tau )
375 temp1 = zscale( i )*temp
378 temp4 = temp1 / dscale( i )
380 erretm = erretm + abs( temp4 )
388 erretm = eight*( abs( finit )+abs( tau )*erretm ) +
390 IF( abs( f ).LE.eps*erretm )
392 IF( f .LE. zero )
THEN
subroutine slaed6(KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO)
SLAED6 used by sstedc. Computes one Newton step in solution of the secular equation.
REAL function slamch(CMACH)
SLAMCH
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i