LAPACK 3.12.1
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ dlasq3()

subroutine dlasq3 ( integer i0,
integer n0,
double precision, dimension( * ) z,
integer pp,
double precision dmin,
double precision sigma,
double precision desig,
double precision qmax,
integer nfail,
integer iter,
integer ndiv,
logical ieee,
integer ttype,
double precision dmin1,
double precision dmin2,
double precision dn,
double precision dn1,
double precision dn2,
double precision g,
double precision tau )

DLASQ3 checks for deflation, computes a shift and calls dqds. Used by sbdsqr.

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

Purpose:
!>
!> DLASQ3 checks for deflation, computes a shift (TAU) and calls dqds.
!> In case of failure it changes shifts, and tries again until output
!> is positive.
!>
Parameters
[in]I0
!>          I0 is INTEGER
!>         First index.
!>
[in,out]N0
!>          N0 is INTEGER
!>         Last index.
!>
[in,out]Z
!>          Z is DOUBLE PRECISION array, dimension ( 4*N0 )
!>         Z holds the qd array.
!>
[in,out]PP
!>          PP is INTEGER
!>         PP=0 for ping, PP=1 for pong.
!>         PP=2 indicates that flipping was applied to the Z array
!>         and that the initial tests for deflation should not be
!>         performed.
!>
[out]DMIN
!>          DMIN is DOUBLE PRECISION
!>         Minimum value of d.
!>
[out]SIGMA
!>          SIGMA is DOUBLE PRECISION
!>         Sum of shifts used in current segment.
!>
[in,out]DESIG
!>          DESIG is DOUBLE PRECISION
!>         Lower order part of SIGMA
!>
[in]QMAX
!>          QMAX is DOUBLE PRECISION
!>         Maximum value of q.
!>
[in,out]NFAIL
!>          NFAIL is INTEGER
!>         Increment NFAIL by 1 each time the shift was too big.
!>
[in,out]ITER
!>          ITER is INTEGER
!>         Increment ITER by 1 for each iteration.
!>
[in,out]NDIV
!>          NDIV is INTEGER
!>         Increment NDIV by 1 for each division.
!>
[in]IEEE
!>          IEEE is LOGICAL
!>         Flag for IEEE or non IEEE arithmetic (passed to DLASQ5).
!>
[in,out]TTYPE
!>          TTYPE is INTEGER
!>         Shift type.
!>
[in,out]DMIN1
!>          DMIN1 is DOUBLE PRECISION
!>
[in,out]DMIN2
!>          DMIN2 is DOUBLE PRECISION
!>
[in,out]DN
!>          DN is DOUBLE PRECISION
!>
[in,out]DN1
!>          DN1 is DOUBLE PRECISION
!>
[in,out]DN2
!>          DN2 is DOUBLE PRECISION
!>
[in,out]G
!>          G is DOUBLE PRECISION
!>
[in,out]TAU
!>          TAU is DOUBLE PRECISION
!>
!>         These are passed as arguments in order to save their values
!>         between calls to DLASQ3.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 177 of file dlasq3.f.

181*
182* -- LAPACK computational routine --
183* -- LAPACK is a software package provided by Univ. of Tennessee, --
184* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
185*
186* .. Scalar Arguments ..
187 LOGICAL IEEE
188 INTEGER I0, ITER, N0, NDIV, NFAIL, PP
189 DOUBLE PRECISION DESIG, DMIN, DMIN1, DMIN2, DN, DN1, DN2, G,
190 $ QMAX, SIGMA, TAU
191* ..
192* .. Array Arguments ..
193 DOUBLE PRECISION Z( * )
194* ..
195*
196* =====================================================================
197*
198* .. Parameters ..
199 DOUBLE PRECISION CBIAS
200 parameter( cbias = 1.50d0 )
201 DOUBLE PRECISION ZERO, QURTR, HALF, ONE, TWO, HUNDRD
202 parameter( zero = 0.0d0, qurtr = 0.250d0, half = 0.5d0,
203 $ one = 1.0d0, two = 2.0d0, hundrd = 100.0d0 )
204* ..
205* .. Local Scalars ..
206 INTEGER IPN4, J4, N0IN, NN, TTYPE
207 DOUBLE PRECISION EPS, S, T, TEMP, TOL, TOL2
208* ..
209* .. External Subroutines ..
210 EXTERNAL dlasq4, dlasq5, dlasq6
211* ..
212* .. External Function ..
213 DOUBLE PRECISION DLAMCH
214 LOGICAL DISNAN
215 EXTERNAL disnan, dlamch
216* ..
217* .. Intrinsic Functions ..
218 INTRINSIC abs, max, min, sqrt
219* ..
220* .. Executable Statements ..
221*
222 n0in = n0
223 eps = dlamch( 'Precision' )
224 tol = eps*hundrd
225 tol2 = tol**2
226*
227* Check for deflation.
228*
229 10 CONTINUE
230*
231 IF( n0.LT.i0 )
232 $ RETURN
233 IF( n0.EQ.i0 )
234 $ GO TO 20
235 nn = 4*n0 + pp
236 IF( n0.EQ.( i0+1 ) )
237 $ GO TO 40
238*
239* Check whether E(N0-1) is negligible, 1 eigenvalue.
240*
241 IF( z( nn-5 ).GT.tol2*( sigma+z( nn-3 ) ) .AND.
242 $ z( nn-2*pp-4 ).GT.tol2*z( nn-7 ) )
243 $ GO TO 30
244*
245 20 CONTINUE
246*
247 z( 4*n0-3 ) = z( 4*n0+pp-3 ) + sigma
248 n0 = n0 - 1
249 GO TO 10
250*
251* Check whether E(N0-2) is negligible, 2 eigenvalues.
252*
253 30 CONTINUE
254*
255 IF( z( nn-9 ).GT.tol2*sigma .AND.
256 $ z( nn-2*pp-8 ).GT.tol2*z( nn-11 ) )
257 $ GO TO 50
258*
259 40 CONTINUE
260*
261 IF( z( nn-3 ).GT.z( nn-7 ) ) THEN
262 s = z( nn-3 )
263 z( nn-3 ) = z( nn-7 )
264 z( nn-7 ) = s
265 END IF
266 t = half*( ( z( nn-7 )-z( nn-3 ) )+z( nn-5 ) )
267 IF( z( nn-5 ).GT.z( nn-3 )*tol2.AND.t.NE.zero ) THEN
268 s = z( nn-3 )*( z( nn-5 ) / t )
269 IF( s.LE.t ) THEN
270 s = z( nn-3 )*( z( nn-5 ) /
271 $ ( t*( one+sqrt( one+s / t ) ) ) )
272 ELSE
273 s = z( nn-3 )*( z( nn-5 ) / ( t+sqrt( t )*sqrt( t+s ) ) )
274 END IF
275 t = z( nn-7 ) + ( s+z( nn-5 ) )
276 z( nn-3 ) = z( nn-3 )*( z( nn-7 ) / t )
277 z( nn-7 ) = t
278 END IF
279 z( 4*n0-7 ) = z( nn-7 ) + sigma
280 z( 4*n0-3 ) = z( nn-3 ) + sigma
281 n0 = n0 - 2
282 GO TO 10
283*
284 50 CONTINUE
285 IF( pp.EQ.2 )
286 $ pp = 0
287*
288* Reverse the qd-array, if warranted.
289*
290 IF( dmin.LE.zero .OR. n0.LT.n0in ) THEN
291 IF( cbias*z( 4*i0+pp-3 ).LT.z( 4*n0+pp-3 ) ) THEN
292 ipn4 = 4*( i0+n0 )
293 DO 60 j4 = 4*i0, 2*( i0+n0-1 ), 4
294 temp = z( j4-3 )
295 z( j4-3 ) = z( ipn4-j4-3 )
296 z( ipn4-j4-3 ) = temp
297 temp = z( j4-2 )
298 z( j4-2 ) = z( ipn4-j4-2 )
299 z( ipn4-j4-2 ) = temp
300 temp = z( j4-1 )
301 z( j4-1 ) = z( ipn4-j4-5 )
302 z( ipn4-j4-5 ) = temp
303 temp = z( j4 )
304 z( j4 ) = z( ipn4-j4-4 )
305 z( ipn4-j4-4 ) = temp
306 60 CONTINUE
307 IF( n0-i0.LE.4 ) THEN
308 z( 4*n0+pp-1 ) = z( 4*i0+pp-1 )
309 z( 4*n0-pp ) = z( 4*i0-pp )
310 END IF
311 dmin2 = min( dmin2, z( 4*n0+pp-1 ) )
312 z( 4*n0+pp-1 ) = min( z( 4*n0+pp-1 ), z( 4*i0+pp-1 ),
313 $ z( 4*i0+pp+3 ) )
314 z( 4*n0-pp ) = min( z( 4*n0-pp ), z( 4*i0-pp ),
315 $ z( 4*i0-pp+4 ) )
316 qmax = max( qmax, z( 4*i0+pp-3 ), z( 4*i0+pp+1 ) )
317 dmin = -zero
318 END IF
319 END IF
320*
321* Choose a shift.
322*
323 CALL dlasq4( i0, n0, z, pp, n0in, dmin, dmin1, dmin2, dn, dn1,
324 $ dn2, tau, ttype, g )
325*
326* Call dqds until DMIN > 0.
327*
328 70 CONTINUE
329*
330 CALL dlasq5( i0, n0, z, pp, tau, sigma, dmin, dmin1, dmin2, dn,
331 $ dn1, dn2, ieee, eps )
332*
333 ndiv = ndiv + ( n0-i0+2 )
334 iter = iter + 1
335*
336* Check status.
337*
338 IF( dmin.GE.zero .AND. dmin1.GE.zero ) THEN
339*
340* Success.
341*
342 GO TO 90
343*
344 ELSE IF( dmin.LT.zero .AND. dmin1.GT.zero .AND.
345 $ z( 4*( n0-1 )-pp ).LT.tol*( sigma+dn1 ) .AND.
346 $ abs( dn ).LT.tol*sigma ) THEN
347*
348* Convergence hidden by negative DN.
349*
350 z( 4*( n0-1 )-pp+2 ) = zero
351 dmin = zero
352 GO TO 90
353 ELSE IF( dmin.LT.zero ) THEN
354*
355* TAU too big. Select new TAU and try again.
356*
357 nfail = nfail + 1
358 IF( ttype.LT.-22 ) THEN
359*
360* Failed twice. Play it safe.
361*
362 tau = zero
363 ELSE IF( dmin1.GT.zero ) THEN
364*
365* Late failure. Gives excellent shift.
366*
367 tau = ( tau+dmin )*( one-two*eps )
368 ttype = ttype - 11
369 ELSE
370*
371* Early failure. Divide by 4.
372*
373 tau = qurtr*tau
374 ttype = ttype - 12
375 END IF
376 GO TO 70
377 ELSE IF( disnan( dmin ) ) THEN
378*
379* NaN.
380*
381 IF( tau.EQ.zero ) THEN
382 GO TO 80
383 ELSE
384 tau = zero
385 GO TO 70
386 END IF
387 ELSE
388*
389* Possible underflow. Play it safe.
390*
391 GO TO 80
392 END IF
393*
394* Risk of underflow.
395*
396 80 CONTINUE
397 CALL dlasq6( i0, n0, z, pp, dmin, dmin1, dmin2, dn, dn1, dn2 )
398 ndiv = ndiv + ( n0-i0+2 )
399 iter = iter + 1
400 tau = zero
401*
402 90 CONTINUE
403 IF( tau.LT.sigma ) THEN
404 desig = desig + tau
405 t = sigma + desig
406 desig = desig - ( t-sigma )
407 ELSE
408 t = sigma + tau
409 desig = sigma - ( t-tau ) + desig
410 END IF
411 sigma = t
412*
413 RETURN
414*
415* End of DLASQ3
416*
disnan
logical function disnan(din)
DISNAN tests input for NaN.
Definition disnan.f:57
dlamch
double precision function dlamch(cmach)
DLAMCH
Definition dlamch.f:69
dlasq4
subroutine dlasq4(i0, n0, z, pp, n0in, dmin, dmin1, dmin2, dn, dn1, dn2, tau, ttype, g)
DLASQ4 computes an approximation to the smallest eigenvalue using values of d from the previous trans...
Definition dlasq4.f:149
dlasq5
subroutine dlasq5(i0, n0, z, pp, tau, sigma, dmin, dmin1, dmin2, dn, dnm1, dnm2, ieee, eps)
DLASQ5 computes one dqds transform in ping-pong form. Used by sbdsqr and sstegr.
Definition dlasq5.f:143
dlasq6
subroutine dlasq6(i0, n0, z, pp, dmin, dmin1, dmin2, dn, dnm1, dnm2)
DLASQ6 computes one dqd transform in ping-pong form. Used by sbdsqr and sstegr.
Definition dlasq6.f:117
Here is the call graph for this function:
Here is the caller graph for this function: