LAPACK  3.10.0
LAPACK: Linear Algebra PACKage

◆ slasq4()

subroutine slasq4 ( integer  I0,
integer  N0,
real, dimension( * )  Z,
integer  PP,
integer  N0IN,
real  DMIN,
real  DMIN1,
real  DMIN2,
real  DN,
real  DN1,
real  DN2,
real  TAU,
integer  TTYPE,
real  G 
)

SLASQ4 computes an approximation to the smallest eigenvalue using values of d from the previous transform. Used by sbdsqr.

Download SLASQ4 + dependencies [TGZ] [ZIP] [TXT]

Purpose:
 SLASQ4 computes an approximation TAU to the smallest eigenvalue
 using values of d from the previous transform.
Parameters
[in]I0
          I0 is INTEGER
        First index.
[in]N0
          N0 is INTEGER
        Last index.
[in]Z
          Z is REAL array, dimension ( 4*N0 )
        Z holds the qd array.
[in]PP
          PP is INTEGER
        PP=0 for ping, PP=1 for pong.
[in]N0IN
          N0IN is INTEGER
        The value of N0 at start of EIGTEST.
[in]DMIN
          DMIN is REAL
        Minimum value of d.
[in]DMIN1
          DMIN1 is REAL
        Minimum value of d, excluding D( N0 ).
[in]DMIN2
          DMIN2 is REAL
        Minimum value of d, excluding D( N0 ) and D( N0-1 ).
[in]DN
          DN is REAL
        d(N)
[in]DN1
          DN1 is REAL
        d(N-1)
[in]DN2
          DN2 is REAL
        d(N-2)
[out]TAU
          TAU is REAL
        This is the shift.
[out]TTYPE
          TTYPE is INTEGER
        Shift type.
[in,out]G
          G is REAL
        G is passed as an argument in order to save its value between
        calls to SLASQ4.
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
  CNST1 = 9/16

Definition at line 149 of file slasq4.f.

151 *
152 * -- LAPACK computational routine --
153 * -- LAPACK is a software package provided by Univ. of Tennessee, --
154 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
155 *
156 * .. Scalar Arguments ..
157  INTEGER I0, N0, N0IN, PP, TTYPE
158  REAL DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, TAU
159 * ..
160 * .. Array Arguments ..
161  REAL Z( * )
162 * ..
163 *
164 * =====================================================================
165 *
166 * .. Parameters ..
167  REAL CNST1, CNST2, CNST3
168  parameter( cnst1 = 0.5630e0, cnst2 = 1.010e0,
169  $ cnst3 = 1.050e0 )
170  REAL QURTR, THIRD, HALF, ZERO, ONE, TWO, HUNDRD
171  parameter( qurtr = 0.250e0, third = 0.3330e0,
172  $ half = 0.50e0, zero = 0.0e0, one = 1.0e0,
173  $ two = 2.0e0, hundrd = 100.0e0 )
174 * ..
175 * .. Local Scalars ..
176  INTEGER I4, NN, NP
177  REAL A2, B1, B2, GAM, GAP1, GAP2, S
178 * ..
179 * .. Intrinsic Functions ..
180  INTRINSIC max, min, sqrt
181 * ..
182 * .. Executable Statements ..
183 *
184 * A negative DMIN forces the shift to take that absolute value
185 * TTYPE records the type of shift.
186 *
187  IF( dmin.LE.zero ) THEN
188  tau = -dmin
189  ttype = -1
190  RETURN
191  END IF
192 *
193  nn = 4*n0 + pp
194  IF( n0in.EQ.n0 ) THEN
195 *
196 * No eigenvalues deflated.
197 *
198  IF( dmin.EQ.dn .OR. dmin.EQ.dn1 ) THEN
199 *
200  b1 = sqrt( z( nn-3 ) )*sqrt( z( nn-5 ) )
201  b2 = sqrt( z( nn-7 ) )*sqrt( z( nn-9 ) )
202  a2 = z( nn-7 ) + z( nn-5 )
203 *
204 * Cases 2 and 3.
205 *
206  IF( dmin.EQ.dn .AND. dmin1.EQ.dn1 ) THEN
207  gap2 = dmin2 - a2 - dmin2*qurtr
208  IF( gap2.GT.zero .AND. gap2.GT.b2 ) THEN
209  gap1 = a2 - dn - ( b2 / gap2 )*b2
210  ELSE
211  gap1 = a2 - dn - ( b1+b2 )
212  END IF
213  IF( gap1.GT.zero .AND. gap1.GT.b1 ) THEN
214  s = max( dn-( b1 / gap1 )*b1, half*dmin )
215  ttype = -2
216  ELSE
217  s = zero
218  IF( dn.GT.b1 )
219  $ s = dn - b1
220  IF( a2.GT.( b1+b2 ) )
221  $ s = min( s, a2-( b1+b2 ) )
222  s = max( s, third*dmin )
223  ttype = -3
224  END IF
225  ELSE
226 *
227 * Case 4.
228 *
229  ttype = -4
230  s = qurtr*dmin
231  IF( dmin.EQ.dn ) THEN
232  gam = dn
233  a2 = zero
234  IF( z( nn-5 ) .GT. z( nn-7 ) )
235  $ RETURN
236  b2 = z( nn-5 ) / z( nn-7 )
237  np = nn - 9
238  ELSE
239  np = nn - 2*pp
240  gam = dn1
241  IF( z( np-4 ) .GT. z( np-2 ) )
242  $ RETURN
243  a2 = z( np-4 ) / z( np-2 )
244  IF( z( nn-9 ) .GT. z( nn-11 ) )
245  $ RETURN
246  b2 = z( nn-9 ) / z( nn-11 )
247  np = nn - 13
248  END IF
249 *
250 * Approximate contribution to norm squared from I < NN-1.
251 *
252  a2 = a2 + b2
253  DO 10 i4 = np, 4*i0 - 1 + pp, -4
254  IF( b2.EQ.zero )
255  $ GO TO 20
256  b1 = b2
257  IF( z( i4 ) .GT. z( i4-2 ) )
258  $ RETURN
259  b2 = b2*( z( i4 ) / z( i4-2 ) )
260  a2 = a2 + b2
261  IF( hundrd*max( b2, b1 ).LT.a2 .OR. cnst1.LT.a2 )
262  $ GO TO 20
263  10 CONTINUE
264  20 CONTINUE
265  a2 = cnst3*a2
266 *
267 * Rayleigh quotient residual bound.
268 *
269  IF( a2.LT.cnst1 )
270  $ s = gam*( one-sqrt( a2 ) ) / ( one+a2 )
271  END IF
272  ELSE IF( dmin.EQ.dn2 ) THEN
273 *
274 * Case 5.
275 *
276  ttype = -5
277  s = qurtr*dmin
278 *
279 * Compute contribution to norm squared from I > NN-2.
280 *
281  np = nn - 2*pp
282  b1 = z( np-2 )
283  b2 = z( np-6 )
284  gam = dn2
285  IF( z( np-8 ).GT.b2 .OR. z( np-4 ).GT.b1 )
286  $ RETURN
287  a2 = ( z( np-8 ) / b2 )*( one+z( np-4 ) / b1 )
288 *
289 * Approximate contribution to norm squared from I < NN-2.
290 *
291  IF( n0-i0.GT.2 ) THEN
292  b2 = z( nn-13 ) / z( nn-15 )
293  a2 = a2 + b2
294  DO 30 i4 = nn - 17, 4*i0 - 1 + pp, -4
295  IF( b2.EQ.zero )
296  $ GO TO 40
297  b1 = b2
298  IF( z( i4 ) .GT. z( i4-2 ) )
299  $ RETURN
300  b2 = b2*( z( i4 ) / z( i4-2 ) )
301  a2 = a2 + b2
302  IF( hundrd*max( b2, b1 ).LT.a2 .OR. cnst1.LT.a2 )
303  $ GO TO 40
304  30 CONTINUE
305  40 CONTINUE
306  a2 = cnst3*a2
307  END IF
308 *
309  IF( a2.LT.cnst1 )
310  $ s = gam*( one-sqrt( a2 ) ) / ( one+a2 )
311  ELSE
312 *
313 * Case 6, no information to guide us.
314 *
315  IF( ttype.EQ.-6 ) THEN
316  g = g + third*( one-g )
317  ELSE IF( ttype.EQ.-18 ) THEN
318  g = qurtr*third
319  ELSE
320  g = qurtr
321  END IF
322  s = g*dmin
323  ttype = -6
324  END IF
325 *
326  ELSE IF( n0in.EQ.( n0+1 ) ) THEN
327 *
328 * One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN.
329 *
330  IF( dmin1.EQ.dn1 .AND. dmin2.EQ.dn2 ) THEN
331 *
332 * Cases 7 and 8.
333 *
334  ttype = -7
335  s = third*dmin1
336  IF( z( nn-5 ).GT.z( nn-7 ) )
337  $ RETURN
338  b1 = z( nn-5 ) / z( nn-7 )
339  b2 = b1
340  IF( b2.EQ.zero )
341  $ GO TO 60
342  DO 50 i4 = 4*n0 - 9 + pp, 4*i0 - 1 + pp, -4
343  a2 = b1
344  IF( z( i4 ).GT.z( i4-2 ) )
345  $ RETURN
346  b1 = b1*( z( i4 ) / z( i4-2 ) )
347  b2 = b2 + b1
348  IF( hundrd*max( b1, a2 ).LT.b2 )
349  $ GO TO 60
350  50 CONTINUE
351  60 CONTINUE
352  b2 = sqrt( cnst3*b2 )
353  a2 = dmin1 / ( one+b2**2 )
354  gap2 = half*dmin2 - a2
355  IF( gap2.GT.zero .AND. gap2.GT.b2*a2 ) THEN
356  s = max( s, a2*( one-cnst2*a2*( b2 / gap2 )*b2 ) )
357  ELSE
358  s = max( s, a2*( one-cnst2*b2 ) )
359  ttype = -8
360  END IF
361  ELSE
362 *
363 * Case 9.
364 *
365  s = qurtr*dmin1
366  IF( dmin1.EQ.dn1 )
367  $ s = half*dmin1
368  ttype = -9
369  END IF
370 *
371  ELSE IF( n0in.EQ.( n0+2 ) ) THEN
372 *
373 * Two eigenvalues deflated. Use DMIN2, DN2 for DMIN and DN.
374 *
375 * Cases 10 and 11.
376 *
377  IF( dmin2.EQ.dn2 .AND. two*z( nn-5 ).LT.z( nn-7 ) ) THEN
378  ttype = -10
379  s = third*dmin2
380  IF( z( nn-5 ).GT.z( nn-7 ) )
381  $ RETURN
382  b1 = z( nn-5 ) / z( nn-7 )
383  b2 = b1
384  IF( b2.EQ.zero )
385  $ GO TO 80
386  DO 70 i4 = 4*n0 - 9 + pp, 4*i0 - 1 + pp, -4
387  IF( z( i4 ).GT.z( i4-2 ) )
388  $ RETURN
389  b1 = b1*( z( i4 ) / z( i4-2 ) )
390  b2 = b2 + b1
391  IF( hundrd*b1.LT.b2 )
392  $ GO TO 80
393  70 CONTINUE
394  80 CONTINUE
395  b2 = sqrt( cnst3*b2 )
396  a2 = dmin2 / ( one+b2**2 )
397  gap2 = z( nn-7 ) + z( nn-9 ) -
398  $ sqrt( z( nn-11 ) )*sqrt( z( nn-9 ) ) - a2
399  IF( gap2.GT.zero .AND. gap2.GT.b2*a2 ) THEN
400  s = max( s, a2*( one-cnst2*a2*( b2 / gap2 )*b2 ) )
401  ELSE
402  s = max( s, a2*( one-cnst2*b2 ) )
403  END IF
404  ELSE
405  s = qurtr*dmin2
406  ttype = -11
407  END IF
408  ELSE IF( n0in.GT.( n0+2 ) ) THEN
409 *
410 * Case 12, more than two eigenvalues deflated. No information.
411 *
412  s = zero
413  ttype = -12
414  END IF
415 *
416  tau = s
417  RETURN
418 *
419 * End of SLASQ4
420 *
Here is the caller graph for this function: