git.maemo.org Git - opencv/blob - 3rdparty/lapack/dlazq4.c

   1 #include "clapack.h"
   2
   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)
   7 {
   8     /* System generated locals */
   9     integer i__1;
  10     doublereal d__1, d__2;
  11
  12     /* Builtin functions */
  13     double sqrt(doublereal);
  14
  15     /* Local variables */
  16     doublereal s, a2, b1, b2;
  17     integer i4, nn, np;
  18     doublereal gam, gap1, gap2;
  19
  20
  21 /*  -- LAPACK auxiliary routine (version 3.1) -- */
  22 /*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
  23 /*     November 2006 */
  24
  25 /*     .. Scalar Arguments .. */
  26 /*     .. */
  27 /*     .. Array Arguments .. */
  28 /*     .. */
  29
  30 /*  Purpose */
  31 /*  ======= */
  32
  33 /*  DLAZQ4 computes an approximation TAU to the smallest eigenvalue */
  34 /*  using values of d from the previous transform. */
  35
  36 /*  I0    (input) INTEGER */
  37 /*        First index. */
  38
  39 /*  N0    (input) INTEGER */
  40 /*        Last index. */
  41
  42 /*  Z     (input) DOUBLE PRECISION array, dimension ( 4*N ) */
  43 /*        Z holds the qd array. */
  44
  45 /*  PP    (input) INTEGER */
  46 /*        PP=0 for ping, PP=1 for pong. */
  47
  48 /*  N0IN  (input) INTEGER */
  49 /*        The value of N0 at start of EIGTEST. */
  50
  51 /*  DMIN  (input) DOUBLE PRECISION */
  52 /*        Minimum value of d. */
  53
  54 /*  DMIN1 (input) DOUBLE PRECISION */
  55 /*        Minimum value of d, excluding D( N0 ). */
  56
  57 /*  DMIN2 (input) DOUBLE PRECISION */
  58 /*        Minimum value of d, excluding D( N0 ) and D( N0-1 ). */
  59
  60 /*  DN    (input) DOUBLE PRECISION */
  61 /*        d(N) */
  62
  63 /*  DN1   (input) DOUBLE PRECISION */
  64 /*        d(N-1) */
  65
  66 /*  DN2   (input) DOUBLE PRECISION */
  67 /*        d(N-2) */
  68
  69 /*  TAU   (output) DOUBLE PRECISION */
  70 /*        This is the shift. */
  71
  72 /*  TTYPE (output) INTEGER */
  73 /*        Shift type. */
  74
  75 /*  G     (input/output) DOUBLE PRECISION */
  76 /*        G is passed as an argument in order to save its value between */
  77 /*        calls to DLAZQ4 */
  78
  79 /*  Further Details */
  80 /*  =============== */
  81 /*  CNST1 = 9/16 */
  82
  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. */
  85
  86 /*  ===================================================================== */
  87
  88 /*     .. Parameters .. */
  89 /*     .. */
  90 /*     .. Local Scalars .. */
  91 /*     .. */
  92 /*     .. Intrinsic Functions .. */
  93 /*     .. */
  94 /*     .. Executable Statements .. */
  95
  96 /*     A negative DMIN forces the shift to take that absolute value */
  97 /*     TTYPE records the type of shift. */
  98
  99     /* Parameter adjustments */
 100     --z__;
 101
 102     /* Function Body */
 103     if (*dmin__ <= 0.) {
 104         *tau = -(*dmin__);
 105         *ttype = -1;
 106         return 0;
 107     }
 108
 109     nn = (*n0 << 2) + *pp;
 110     if (*n0in == *n0) {
 111
 112 /*        No eigenvalues deflated. */
 113
 114         if (*dmin__ == *dn || *dmin__ == *dn1) {
 115
 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];
 119
 120 /*           Cases 2 and 3. */
 121
 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;
 126                 } else {
 127                     gap1 = a2 - *dn - (b1 + b2);
 128                 }
 129                 if (gap1 > 0. && gap1 > b1) {
 130 /* Computing MAX */
 131                     d__1 = *dn - b1 / gap1 * b1, d__2 = *dmin__ * .5;
 132                     s = max(d__1,d__2);
 133                     *ttype = -2;
 134                 } else {
 135                     s = 0.;
 136                     if (*dn > b1) {
 137                         s = *dn - b1;
 138                     }
 139                     if (a2 > b1 + b2) {
 140 /* Computing MIN */
 141                         d__1 = s, d__2 = a2 - (b1 + b2);
 142                         s = min(d__1,d__2);
 143                     }
 144 /* Computing MAX */
 145                     d__1 = s, d__2 = *dmin__ * .333;
 146                     s = max(d__1,d__2);
 147                     *ttype = -3;
 148                 }
 149             } else {
 150
 151 /*              Case 4. */
 152
 153                 *ttype = -4;
 154                 s = *dmin__ * .25;
 155                 if (*dmin__ == *dn) {
 156                     gam = *dn;
 157                     a2 = 0.;
 158                     if (z__[nn - 5] > z__[nn - 7]) {
 159                         return 0;
 160                     }
 161                     b2 = z__[nn - 5] / z__[nn - 7];
 162                     np = nn - 9;
 163                 } else {
 164                     np = nn - (*pp << 1);
 165                     b2 = z__[np - 2];
 166                     gam = *dn1;
 167                     if (z__[np - 4] > z__[np - 2]) {
 168                         return 0;
 169                     }
 170                     a2 = z__[np - 4] / z__[np - 2];
 171                     if (z__[nn - 9] > z__[nn - 11]) {
 172                         return 0;
 173                     }
 174                     b2 = z__[nn - 9] / z__[nn - 11];
 175                     np = nn - 13;
 176                 }
 177
 178 /*              Approximate contribution to norm squared from I < NN-1. */
 179
 180                 a2 += b2;
 181                 i__1 = (*i0 << 2) - 1 + *pp;
 182                 for (i4 = np; i4 >= i__1; i4 += -4) {
 183                     if (b2 == 0.) {
 184                         goto L20;
 185                     }
 186                     b1 = b2;
 187                     if (z__[i4] > z__[i4 - 2]) {
 188                         return 0;
 189                     }
 190                     b2 *= z__[i4] / z__[i4 - 2];
 191                     a2 += b2;
 192                     if (max(b2,b1) * 100. < a2 || .563 < a2) {
 193                         goto L20;
 194                     }
 195 /* L10: */
 196                 }
 197 L20:
 198                 a2 *= 1.05;
 199
 200 /*              Rayleigh quotient residual bound. */
 201
 202                 if (a2 < .563) {
 203                     s = gam * (1. - sqrt(a2)) / (a2 + 1.);
 204                 }
 205             }
 206         } else if (*dmin__ == *dn2) {
 207
 208 /*           Case 5. */
 209
 210             *ttype = -5;
 211             s = *dmin__ * .25;
 212
 213 /*           Compute contribution to norm squared from I > NN-2. */
 214
 215             np = nn - (*pp << 1);
 216             b1 = z__[np - 2];
 217             b2 = z__[np - 6];
 218             gam = *dn2;
 219             if (z__[np - 8] > b2 || z__[np - 4] > b1) {
 220                 return 0;
 221             }
 222             a2 = z__[np - 8] / b2 * (z__[np - 4] / b1 + 1.);
 223
 224 /*           Approximate contribution to norm squared from I < NN-2. */
 225
 226             if (*n0 - *i0 > 2) {
 227                 b2 = z__[nn - 13] / z__[nn - 15];
 228                 a2 += b2;
 229                 i__1 = (*i0 << 2) - 1 + *pp;
 230                 for (i4 = nn - 17; i4 >= i__1; i4 += -4) {
 231                     if (b2 == 0.) {
 232                         goto L40;
 233                     }
 234                     b1 = b2;
 235                     if (z__[i4] > z__[i4 - 2]) {
 236                         return 0;
 237                     }
 238                     b2 *= z__[i4] / z__[i4 - 2];
 239                     a2 += b2;
 240                     if (max(b2,b1) * 100. < a2 || .563 < a2) {
 241                         goto L40;
 242                     }
 243 /* L30: */
 244                 }
 245 L40:
 246                 a2 *= 1.05;
 247             }
 248
 249             if (a2 < .563) {
 250                 s = gam * (1. - sqrt(a2)) / (a2 + 1.);
 251             }
 252         } else {
 253
 254 /*           Case 6, no information to guide us. */
 255
 256             if (*ttype == -6) {
 257                 *g += (1. - *g) * .333;
 258             } else if (*ttype == -18) {
 259                 *g = .083250000000000005;
 260             } else {
 261                 *g = .25;
 262             }
 263             s = *g * *dmin__;
 264             *ttype = -6;
 265         }
 266
 267     } else if (*n0in == *n0 + 1) {
 268
 269 /*        One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN. */
 270
 271         if (*dmin1 == *dn1 && *dmin2 == *dn2) {
 272
 273 /*           Cases 7 and 8. */
 274
 275             *ttype = -7;
 276             s = *dmin1 * .333;
 277             if (z__[nn - 5] > z__[nn - 7]) {
 278                 return 0;
 279             }
 280             b1 = z__[nn - 5] / z__[nn - 7];
 281             b2 = b1;
 282             if (b2 == 0.) {
 283                 goto L60;
 284             }
 285             i__1 = (*i0 << 2) - 1 + *pp;
 286             for (i4 = (*n0 << 2) - 9 + *pp; i4 >= i__1; i4 += -4) {
 287                 a2 = b1;
 288                 if (z__[i4] > z__[i4 - 2]) {
 289                     return 0;
 290                 }
 291                 b1 *= z__[i4] / z__[i4 - 2];
 292                 b2 += b1;
 293                 if (max(b1,a2) * 100. < b2) {
 294                     goto L60;
 295                 }
 296 /* L50: */
 297             }
 298 L60:
 299             b2 = sqrt(b2 * 1.05);
 300 /* Computing 2nd power */
 301             d__1 = b2;
 302             a2 = *dmin1 / (d__1 * d__1 + 1.);
 303             gap2 = *dmin2 * .5 - a2;
 304             if (gap2 > 0. && gap2 > b2 * a2) {
 305 /* Computing MAX */
 306                 d__1 = s, d__2 = a2 * (1. - a2 * 1.01 * (b2 / gap2) * b2);
 307                 s = max(d__1,d__2);
 308             } else {
 309 /* Computing MAX */
 310                 d__1 = s, d__2 = a2 * (1. - b2 * 1.01);
 311                 s = max(d__1,d__2);
 312                 *ttype = -8;
 313             }
 314         } else {
 315
 316 /*           Case 9. */
 317
 318             s = *dmin1 * .25;
 319             if (*dmin1 == *dn1) {
 320                 s = *dmin1 * .5;
 321             }
 322             *ttype = -9;
 323         }
 324
 325     } else if (*n0in == *n0 + 2) {
 326
 327 /*        Two eigenvalues deflated. Use DMIN2, DN2 for DMIN and DN. */
 328
 329 /*        Cases 10 and 11. */
 330
 331         if (*dmin2 == *dn2 && z__[nn - 5] * 2. < z__[nn - 7]) {
 332             *ttype = -10;
 333             s = *dmin2 * .333;
 334             if (z__[nn - 5] > z__[nn - 7]) {
 335                 return 0;
 336             }
 337             b1 = z__[nn - 5] / z__[nn - 7];
 338             b2 = b1;
 339             if (b2 == 0.) {
 340                 goto L80;
 341             }
 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]) {
 345                     return 0;
 346                 }
 347                 b1 *= z__[i4] / z__[i4 - 2];
 348                 b2 += b1;
 349                 if (b1 * 100. < b2) {
 350                     goto L80;
 351                 }
 352 /* L70: */
 353             }
 354 L80:
 355             b2 = sqrt(b2 * 1.05);
 356 /* Computing 2nd power */
 357             d__1 = b2;
 358             a2 = *dmin2 / (d__1 * d__1 + 1.);
 359             gap2 = z__[nn - 7] + z__[nn - 9] - sqrt(z__[nn - 11]) * sqrt(z__[
 360                     nn - 9]) - a2;
 361             if (gap2 > 0. && gap2 > b2 * a2) {
 362 /* Computing MAX */
 363                 d__1 = s, d__2 = a2 * (1. - a2 * 1.01 * (b2 / gap2) * b2);
 364                 s = max(d__1,d__2);
 365             } else {
 366 /* Computing MAX */
 367                 d__1 = s, d__2 = a2 * (1. - b2 * 1.01);
 368                 s = max(d__1,d__2);
 369             }
 370         } else {
 371             s = *dmin2 * .25;
 372             *ttype = -11;
 373         }
 374     } else if (*n0in > *n0 + 2) {
 375
 376 /*        Case 12, more than two eigenvalues deflated. No information. */
 377
 378         s = 0.;
 379         *ttype = -12;
 380     }
 381
 382     *tau = s;
 383     return 0;
 384
 385 /*     End of DLAZQ4 */
 386
 387 } /* dlazq4_ */