3 /* Subroutine */ int dlazq4_(integer *i0, integer *n0, doublereal *z__,
4 integer *pp, integer *n0in, doublereal *dmin__, doublereal *dmin1,
5 doublereal *dmin2, doublereal *dn, doublereal *dn1, doublereal *dn2,
6 doublereal *tau, integer *ttype, doublereal *g)
8 /* System generated locals */
10 doublereal d__1, d__2;
12 /* Builtin functions */
13 double sqrt(doublereal);
16 doublereal s, a2, b1, b2;
18 doublereal gam, gap1, gap2;
21 /* -- LAPACK auxiliary routine (version 3.1) -- */
22 /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
25 /* .. Scalar Arguments .. */
27 /* .. Array Arguments .. */
33 /* DLAZQ4 computes an approximation TAU to the smallest eigenvalue */
34 /* using values of d from the previous transform. */
36 /* I0 (input) INTEGER */
39 /* N0 (input) INTEGER */
42 /* Z (input) DOUBLE PRECISION array, dimension ( 4*N ) */
43 /* Z holds the qd array. */
45 /* PP (input) INTEGER */
46 /* PP=0 for ping, PP=1 for pong. */
48 /* N0IN (input) INTEGER */
49 /* The value of N0 at start of EIGTEST. */
51 /* DMIN (input) DOUBLE PRECISION */
52 /* Minimum value of d. */
54 /* DMIN1 (input) DOUBLE PRECISION */
55 /* Minimum value of d, excluding D( N0 ). */
57 /* DMIN2 (input) DOUBLE PRECISION */
58 /* Minimum value of d, excluding D( N0 ) and D( N0-1 ). */
60 /* DN (input) DOUBLE PRECISION */
63 /* DN1 (input) DOUBLE PRECISION */
66 /* DN2 (input) DOUBLE PRECISION */
69 /* TAU (output) DOUBLE PRECISION */
70 /* This is the shift. */
72 /* TTYPE (output) INTEGER */
75 /* G (input/output) DOUBLE PRECISION */
76 /* G is passed as an argument in order to save its value between */
83 /* This is a thread safe version of DLASQ4, which passes G through the */
84 /* argument list in place of declaring G in a SAVE statment. */
86 /* ===================================================================== */
88 /* .. Parameters .. */
90 /* .. Local Scalars .. */
92 /* .. Intrinsic Functions .. */
94 /* .. Executable Statements .. */
96 /* A negative DMIN forces the shift to take that absolute value */
97 /* TTYPE records the type of shift. */
99 /* Parameter adjustments */
109 nn = (*n0 << 2) + *pp;
112 /* No eigenvalues deflated. */
114 if (*dmin__ == *dn || *dmin__ == *dn1) {
116 b1 = sqrt(z__[nn - 3]) * sqrt(z__[nn - 5]);
117 b2 = sqrt(z__[nn - 7]) * sqrt(z__[nn - 9]);
118 a2 = z__[nn - 7] + z__[nn - 5];
122 if (*dmin__ == *dn && *dmin1 == *dn1) {
123 gap2 = *dmin2 - a2 - *dmin2 * .25;
124 if (gap2 > 0. && gap2 > b2) {
125 gap1 = a2 - *dn - b2 / gap2 * b2;
127 gap1 = a2 - *dn - (b1 + b2);
129 if (gap1 > 0. && gap1 > b1) {
131 d__1 = *dn - b1 / gap1 * b1, d__2 = *dmin__ * .5;
141 d__1 = s, d__2 = a2 - (b1 + b2);
145 d__1 = s, d__2 = *dmin__ * .333;
155 if (*dmin__ == *dn) {
158 if (z__[nn - 5] > z__[nn - 7]) {
161 b2 = z__[nn - 5] / z__[nn - 7];
164 np = nn - (*pp << 1);
167 if (z__[np - 4] > z__[np - 2]) {
170 a2 = z__[np - 4] / z__[np - 2];
171 if (z__[nn - 9] > z__[nn - 11]) {
174 b2 = z__[nn - 9] / z__[nn - 11];
178 /* Approximate contribution to norm squared from I < NN-1. */
181 i__1 = (*i0 << 2) - 1 + *pp;
182 for (i4 = np; i4 >= i__1; i4 += -4) {
187 if (z__[i4] > z__[i4 - 2]) {
190 b2 *= z__[i4] / z__[i4 - 2];
192 if (max(b2,b1) * 100. < a2 || .563 < a2) {
200 /* Rayleigh quotient residual bound. */
203 s = gam * (1. - sqrt(a2)) / (a2 + 1.);
206 } else if (*dmin__ == *dn2) {
213 /* Compute contribution to norm squared from I > NN-2. */
215 np = nn - (*pp << 1);
219 if (z__[np - 8] > b2 || z__[np - 4] > b1) {
222 a2 = z__[np - 8] / b2 * (z__[np - 4] / b1 + 1.);
224 /* Approximate contribution to norm squared from I < NN-2. */
227 b2 = z__[nn - 13] / z__[nn - 15];
229 i__1 = (*i0 << 2) - 1 + *pp;
230 for (i4 = nn - 17; i4 >= i__1; i4 += -4) {
235 if (z__[i4] > z__[i4 - 2]) {
238 b2 *= z__[i4] / z__[i4 - 2];
240 if (max(b2,b1) * 100. < a2 || .563 < a2) {
250 s = gam * (1. - sqrt(a2)) / (a2 + 1.);
254 /* Case 6, no information to guide us. */
257 *g += (1. - *g) * .333;
258 } else if (*ttype == -18) {
259 *g = .083250000000000005;
267 } else if (*n0in == *n0 + 1) {
269 /* One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN. */
271 if (*dmin1 == *dn1 && *dmin2 == *dn2) {
277 if (z__[nn - 5] > z__[nn - 7]) {
280 b1 = z__[nn - 5] / z__[nn - 7];
285 i__1 = (*i0 << 2) - 1 + *pp;
286 for (i4 = (*n0 << 2) - 9 + *pp; i4 >= i__1; i4 += -4) {
288 if (z__[i4] > z__[i4 - 2]) {
291 b1 *= z__[i4] / z__[i4 - 2];
293 if (max(b1,a2) * 100. < b2) {
299 b2 = sqrt(b2 * 1.05);
300 /* Computing 2nd power */
302 a2 = *dmin1 / (d__1 * d__1 + 1.);
303 gap2 = *dmin2 * .5 - a2;
304 if (gap2 > 0. && gap2 > b2 * a2) {
306 d__1 = s, d__2 = a2 * (1. - a2 * 1.01 * (b2 / gap2) * b2);
310 d__1 = s, d__2 = a2 * (1. - b2 * 1.01);
319 if (*dmin1 == *dn1) {
325 } else if (*n0in == *n0 + 2) {
327 /* Two eigenvalues deflated. Use DMIN2, DN2 for DMIN and DN. */
329 /* Cases 10 and 11. */
331 if (*dmin2 == *dn2 && z__[nn - 5] * 2. < z__[nn - 7]) {
334 if (z__[nn - 5] > z__[nn - 7]) {
337 b1 = z__[nn - 5] / z__[nn - 7];
342 i__1 = (*i0 << 2) - 1 + *pp;
343 for (i4 = (*n0 << 2) - 9 + *pp; i4 >= i__1; i4 += -4) {
344 if (z__[i4] > z__[i4 - 2]) {
347 b1 *= z__[i4] / z__[i4 - 2];
349 if (b1 * 100. < b2) {
355 b2 = sqrt(b2 * 1.05);
356 /* Computing 2nd power */
358 a2 = *dmin2 / (d__1 * d__1 + 1.);
359 gap2 = z__[nn - 7] + z__[nn - 9] - sqrt(z__[nn - 11]) * sqrt(z__[
361 if (gap2 > 0. && gap2 > b2 * a2) {
363 d__1 = s, d__2 = a2 * (1. - a2 * 1.01 * (b2 / gap2) * b2);
367 d__1 = s, d__2 = a2 * (1. - b2 * 1.01);
374 } else if (*n0in > *n0 + 2) {
376 /* Case 12, more than two eigenvalues deflated. No information. */