147 SUBROUTINE slasq4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN,
148 $ DN1, DN2, TAU, TTYPE, G )
155 INTEGER I0, N0, N0IN, PP, TTYPE
156 REAL DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, TAU
165 REAL CNST1, CNST2, CNST3
166 parameter( cnst1 = 0.5630e0, cnst2 = 1.010e0,
168 REAL QURTR, THIRD, HALF, ZERO, ONE, TWO, HUNDRD
169 parameter( qurtr = 0.250e0, third = 0.3330e0,
170 $ half = 0.50e0, zero = 0.0e0, one = 1.0e0,
171 $ two = 2.0e0, hundrd = 100.0e0 )
175 REAL A2, B1, B2, GAM, GAP1, GAP2, S
178 INTRINSIC max, min, sqrt
185 IF( dmin.LE.zero )
THEN
192 IF( n0in.EQ.n0 )
THEN
196 IF( dmin.EQ.dn .OR. dmin.EQ.dn1 )
THEN
198 b1 = sqrt( z( nn-3 ) )*sqrt( z( nn-5 ) )
199 b2 = sqrt( z( nn-7 ) )*sqrt( z( nn-9 ) )
200 a2 = z( nn-7 ) + z( nn-5 )
204 IF( dmin.EQ.dn .AND. dmin1.EQ.dn1 )
THEN
205 gap2 = dmin2 - a2 - dmin2*qurtr
206 IF( gap2.GT.zero .AND. gap2.GT.b2 )
THEN
207 gap1 = a2 - dn - ( b2 / gap2 )*b2
209 gap1 = a2 - dn - ( b1+b2 )
211 IF( gap1.GT.zero .AND. gap1.GT.b1 )
THEN
212 s = max( dn-( b1 / gap1 )*b1, half*dmin )
218 IF( a2.GT.( b1+b2 ) )
219 $ s = min( s, a2-( b1+b2 ) )
220 s = max( s, third*dmin )
229 IF( dmin.EQ.dn )
THEN
232 IF( z( nn-5 ) .GT. z( nn-7 ) )
234 b2 = z( nn-5 ) / z( nn-7 )
239 IF( z( np-4 ) .GT. z( np-2 ) )
241 a2 = z( np-4 ) / z( np-2 )
242 IF( z( nn-9 ) .GT. z( nn-11 ) )
244 b2 = z( nn-9 ) / z( nn-11 )
251 DO 10 i4 = np, 4*i0 - 1 + pp, -4
255 IF( z( i4 ) .GT. z( i4-2 ) )
257 b2 = b2*( z( i4 ) / z( i4-2 ) )
259 IF( hundrd*max( b2, b1 ).LT.a2 .OR. cnst1.LT.a2 )
268 $ s = gam*( one-sqrt( a2 ) ) / ( one+a2 )
270 ELSE IF( dmin.EQ.dn2 )
THEN
283 IF( z( np-8 ).GT.b2 .OR. z( np-4 ).GT.b1 )
285 a2 = ( z( np-8 ) / b2 )*( one+z( np-4 ) / b1 )
289 IF( n0-i0.GT.2 )
THEN
290 b2 = z( nn-13 ) / z( nn-15 )
292 DO 30 i4 = nn - 17, 4*i0 - 1 + pp, -4
296 IF( z( i4 ) .GT. z( i4-2 ) )
298 b2 = b2*( z( i4 ) / z( i4-2 ) )
300 IF( hundrd*max( b2, b1 ).LT.a2 .OR. cnst1.LT.a2 )
308 $ s = gam*( one-sqrt( a2 ) ) / ( one+a2 )
313 IF( ttype.EQ.-6 )
THEN
314 g = g + third*( one-g )
315 ELSE IF( ttype.EQ.-18 )
THEN
324 ELSE IF( n0in.EQ.( n0+1 ) )
THEN
328 IF( dmin1.EQ.dn1 .AND. dmin2.EQ.dn2 )
THEN
334 IF( z( nn-5 ).GT.z( nn-7 ) )
336 b1 = z( nn-5 ) / z( nn-7 )
340 DO 50 i4 = 4*n0 - 9 + pp, 4*i0 - 1 + pp, -4
342 IF( z( i4 ).GT.z( i4-2 ) )
344 b1 = b1*( z( i4 ) / z( i4-2 ) )
346 IF( hundrd*max( b1, a2 ).LT.b2 )
350 b2 = sqrt( cnst3*b2 )
351 a2 = dmin1 / ( one+b2**2 )
352 gap2 = half*dmin2 - a2
353 IF( gap2.GT.zero .AND. gap2.GT.b2*a2 )
THEN
354 s = max( s, a2*( one-cnst2*a2*( b2 / gap2 )*b2 ) )
356 s = max( s, a2*( one-cnst2*b2 ) )
369 ELSE IF( n0in.EQ.( n0+2 ) )
THEN
375 IF( dmin2.EQ.dn2 .AND. two*z( nn-5 ).LT.z( nn-7 ) )
THEN
378 IF( z( nn-5 ).GT.z( nn-7 ) )
380 b1 = z( nn-5 ) / z( nn-7 )
384 DO 70 i4 = 4*n0 - 9 + pp, 4*i0 - 1 + pp, -4
385 IF( z( i4 ).GT.z( i4-2 ) )
387 b1 = b1*( z( i4 ) / z( i4-2 ) )
389 IF( hundrd*b1.LT.b2 )
393 b2 = sqrt( cnst3*b2 )
394 a2 = dmin2 / ( one+b2**2 )
395 gap2 = z( nn-7 ) + z( nn-9 ) -
396 $ sqrt( z( nn-11 ) )*sqrt( z( nn-9 ) ) - a2
397 IF( gap2.GT.zero .AND. gap2.GT.b2*a2 )
THEN
398 s = max( s, a2*( one-cnst2*a2*( b2 / gap2 )*b2 ) )
400 s = max( s, a2*( one-cnst2*b2 ) )
406 ELSE IF( n0in.GT.( n0+2 ) )
THEN
subroutine slasq4(i0, n0, z, pp, n0in, dmin, dmin1, dmin2, dn, dn1, dn2, tau, ttype, g)
SLASQ4 computes an approximation to the smallest eigenvalue using values of d from the previous trans...