191 SUBROUTINE slarrf( N, D, L, LD, CLSTRT, CLEND,
193 $ spdiam, clgapl, clgapr, pivmin, sigma,
194 $ dplus, lplus, work, info )
202 INTEGER CLSTRT, CLEND, INFO, N
203 REAL CLGAPL, CLGAPR, PIVMIN, SIGMA, SPDIAM
206 REAL D( * ), DPLUS( * ), L( * ), LD( * ),
207 $ lplus( * ), w( * ), wgap( * ), werr( * ), work( * )
213 REAL MAXGROWTH1, MAXGROWTH2, ONE, QUART, TWO
214 parameter ( one = 1.0e0, two = 2.0e0,
217 $ maxgrowth2 = 8.e0 )
220 LOGICAL DORRR1, FORCER, NOFAIL, SAWNAN1, SAWNAN2, TRYRRR1
221 INTEGER I, INDX, KTRY, KTRYMAX, SLEFT, SRIGHT, SHIFT
222 parameter ( ktrymax = 1, sleft = 1, sright = 2 )
223 REAL AVGAP, BESTSHIFT, CLWDTH, EPS, FACT, FAIL,
224 $ fail2, growthbound, ldelta, ldmax, lsigma,
225 $ max1, max2, mingap, oldp, prod, rdelta, rdmax,
226 $ rrr1, rrr2, rsigma, s, smlgrowth, tmp, znm2
231 EXTERNAL sisnan, slamch
242 fact =
REAL(2**ktrymax)
243 eps = slamch(
'Precision' )
265 clwdth = abs(w(clend)-w(clstrt)) + werr(clend) + werr(clstrt)
266 avgap = clwdth /
REAL(clend-clstrt)
267 mingap = min(clgapl, clgapr)
269 lsigma = min(w( clstrt ),w( clend )) - werr( clstrt )
270 rsigma = max(w( clstrt ),w( clend )) + werr( clend )
273 lsigma = lsigma - abs(lsigma)* two * eps
274 rsigma = rsigma + abs(rsigma)* two * eps
277 ldmax = quart * mingap + two * pivmin
278 rdmax = quart * mingap + two * pivmin
280 ldelta = max(avgap,wgap( clstrt ))/fact
281 rdelta = max(avgap,wgap( clend-1 ))/fact
287 fail =
REAL(n-1)*MINGAP/(spdiam*eps)
288 fail2 =
REAL(n-1)*MINGAP/(spdiam*sqrt(eps))
293 growthbound = maxgrowth1*spdiam
299 ldelta = min(ldmax,ldelta)
300 rdelta = min(rdmax,rdelta)
307 dplus( 1 ) = d( 1 ) + s
308 IF(abs(dplus(1)).LT.pivmin)
THEN
314 max1 = abs( dplus( 1 ) )
316 lplus( i ) = ld( i ) / dplus( i )
317 s = s*lplus( i )*l( i ) - lsigma
318 dplus( i+1 ) = d( i+1 ) + s
319 IF(abs(dplus(i+1)).LT.pivmin)
THEN
325 max1 = max( max1,abs(dplus(i+1)) )
327 sawnan1 = sawnan1 .OR. sisnan( max1 )
330 $ (max1.LE.growthbound .AND. .NOT.sawnan1 ) )
THEN
338 work( 1 ) = d( 1 ) + s
339 IF(abs(work(1)).LT.pivmin)
THEN
345 max2 = abs( work( 1 ) )
347 work( n+i ) = ld( i ) / work( i )
348 s = s*work( n+i )*l( i ) - rsigma
349 work( i+1 ) = d( i+1 ) + s
350 IF(abs(work(i+1)).LT.pivmin)
THEN
356 max2 = max( max2,abs(work(i+1)) )
358 sawnan2 = sawnan2 .OR. sisnan( max2 )
361 $ (max2.LE.growthbound .AND. .NOT.sawnan2 ) )
THEN
369 IF(sawnan1.AND.sawnan2)
THEN
373 IF( .NOT.sawnan1 )
THEN
375 IF(max1.LE.smlgrowth)
THEN
380 IF( .NOT.sawnan2 )
THEN
381 IF(sawnan1 .OR. max2.LE.max1) indx = 2
382 IF(max2.LE.smlgrowth)
THEN
394 IF((clwdth.LT.mingap/
REAL(128)) .AND.
395 $ (min(max1,max2).LT.fail2)
396 $ .AND.(.NOT.sawnan1).AND.(.NOT.sawnan2))
THEN
402 IF( tryrrr1 .AND. dorrr1 )
THEN
404 tmp = abs( dplus( n ) )
409 IF( prod .LE. eps )
THEN
411 $ ((dplus(i+1)*work(n+i+1))/(dplus(i)*work(n+i)))*oldp
413 prod = prod*abs(work(n+i))
416 znm2 = znm2 + prod**2
417 tmp = max( tmp, abs( dplus( i ) * prod ))
419 rrr1 = tmp/( spdiam * sqrt( znm2 ) )
420 IF (rrr1.LE.maxgrowth2)
THEN
425 ELSE IF(indx.EQ.2)
THEN
426 tmp = abs( work( n ) )
431 IF( prod .LE. eps )
THEN
432 prod = ((work(i+1)*lplus(i+1))/(work(i)*lplus(i)))*oldp
434 prod = prod*abs(lplus(i))
437 znm2 = znm2 + prod**2
438 tmp = max( tmp, abs( work( i ) * prod ))
440 rrr2 = tmp/( spdiam * sqrt( znm2 ) )
441 IF (rrr2.LE.maxgrowth2)
THEN
451 IF (ktry.LT.ktrymax)
THEN
454 lsigma = max( lsigma - ldelta,
456 rsigma = min( rsigma + rdelta,
458 ldelta = two * ldelta
459 rdelta = two * rdelta
465 IF((smlgrowth.LT.fail).OR.nofail)
THEN
477 IF (shift.EQ.sleft)
THEN
478 ELSEIF (shift.EQ.sright)
THEN
480 CALL scopy( n, work, 1, dplus, 1 )
481 CALL scopy( n-1, work(n+1), 1, lplus, 1 )
subroutine slarrf(N, D, L, LD, CLSTRT, CLEND, W, WGAP, WERR, SPDIAM, CLGAPL, CLGAPR, PIVMIN, SIGMA, DPLUS, LPLUS, WORK, INFO)
SLARRF finds a new relatively robust representation such that at least one of the eigenvalues is rela...
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY