LAPACK 3.11.0 LAPACK: Linear Algebra PACKage
Searching...
No Matches

## ◆ 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.

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.```
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: