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

   1 #include "clapack.h"
   2
   3 /* Subroutine */ int slasq4_(integer *i0, integer *n0, real *z__, integer *pp,
   4          integer *n0in, real *dmin__, real *dmin1, real *dmin2, real *dn,
   5         real *dn1, real *dn2, real *tau, integer *ttype)
   6 {
   7     /* Initialized data */
   8
   9     static real g = 0.f;
  10
  11     /* System generated locals */
  12     integer i__1;
  13     real r__1, r__2;
  14
  15     /* Builtin functions */
  16     double sqrt(doublereal);
  17
  18     /* Local variables */
  19     real s, a2, b1, b2;
  20     integer i4, nn, np;
  21     real gam, gap1, gap2;
  22
  23
  24 /*  -- LAPACK auxiliary routine (version 3.1) -- */
  25 /*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
  26 /*     November 2006 */
  27
  28 /*     .. Scalar Arguments .. */
  29 /*     .. */
  30 /*     .. Array Arguments .. */
  31 /*     .. */
  32
  33 /*  Purpose */
  34 /*  ======= */
  35
  36 /*  SLASQ4 computes an approximation TAU to the smallest eigenvalue */
  37 /*  using values of d from the previous transform. */
  38
  39 /*  I0    (input) INTEGER */
  40 /*        First index. */
  41
  42 /*  N0    (input) INTEGER */
  43 /*        Last index. */
  44
  45 /*  Z     (input) REAL array, dimension ( 4*N ) */
  46 /*        Z holds the qd array. */
  47
  48 /*  PP    (input) INTEGER */
  49 /*        PP=0 for ping, PP=1 for pong. */
  50
  51 /*  N0IN  (input) INTEGER */
  52 /*        The value of N0 at start of EIGTEST. */
  53
  54 /*  DMIN  (input) REAL */
  55 /*        Minimum value of d. */
  56
  57 /*  DMIN1 (input) REAL */
  58 /*        Minimum value of d, excluding D( N0 ). */
  59
  60 /*  DMIN2 (input) REAL */
  61 /*        Minimum value of d, excluding D( N0 ) and D( N0-1 ). */
  62
  63 /*  DN    (input) REAL */
  64 /*        d(N) */
  65
  66 /*  DN1   (input) REAL */
  67 /*        d(N-1) */
  68
  69 /*  DN2   (input) REAL */
  70 /*        d(N-2) */
  71
  72 /*  TAU   (output) REAL */
  73 /*        This is the shift. */
  74
  75 /*  TTYPE (output) INTEGER */
  76 /*        Shift type. */
  77
  78 /*  Further Details */
  79 /*  =============== */
  80 /*  CNST1 = 9/16 */
  81
  82 /*  ===================================================================== */
  83
  84 /*     .. Parameters .. */
  85 /*     .. */
  86 /*     .. Local Scalars .. */
  87 /*     .. */
  88 /*     .. Intrinsic Functions .. */
  89 /*     .. */
  90 /*     .. Save statement .. */
  91 /*     .. */
  92 /*     .. Data statement .. */
  93     /* Parameter adjustments */
  94     --z__;
  95
  96     /* Function Body */
  97 /*     .. */
  98 /*     .. Executable Statements .. */
  99
 100 /*     A negative DMIN forces the shift to take that absolute value */
 101 /*     TTYPE records the type of shift. */
 102
 103     if (*dmin__ <= 0.f) {
 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 * .25f;
 124                 if (gap2 > 0.f && gap2 > b2) {
 125                     gap1 = a2 - *dn - b2 / gap2 * b2;
 126                 } else {
 127                     gap1 = a2 - *dn - (b1 + b2);
 128                 }
 129                 if (gap1 > 0.f && gap1 > b1) {
 130 /* Computing MAX */
 131                     r__1 = *dn - b1 / gap1 * b1, r__2 = *dmin__ * .5f;
 132                     s = dmax(r__1,r__2);
 133                     *ttype = -2;
 134                 } else {
 135                     s = 0.f;
 136                     if (*dn > b1) {
 137                         s = *dn - b1;
 138                     }
 139                     if (a2 > b1 + b2) {
 140 /* Computing MIN */
 141                         r__1 = s, r__2 = a2 - (b1 + b2);
 142                         s = dmin(r__1,r__2);
 143                     }
 144 /* Computing MAX */
 145                     r__1 = s, r__2 = *dmin__ * .333f;
 146                     s = dmax(r__1,r__2);
 147                     *ttype = -3;
 148                 }
 149             } else {
 150
 151 /*              Case 4. */
 152
 153                 *ttype = -4;
 154                 s = *dmin__ * .25f;
 155                 if (*dmin__ == *dn) {
 156                     gam = *dn;
 157                     a2 = 0.f;
 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.f) {
 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 (dmax(b2,b1) * 100.f < a2 || .563f < a2) {
 193                         goto L20;
 194                     }
 195 /* L10: */
 196                 }
 197 L20:
 198                 a2 *= 1.05f;
 199
 200 /*              Rayleigh quotient residual bound. */
 201
 202                 if (a2 < .563f) {
 203                     s = gam * (1.f - sqrt(a2)) / (a2 + 1.f);
 204                 }
 205             }
 206         } else if (*dmin__ == *dn2) {
 207
 208 /*           Case 5. */
 209
 210             *ttype = -5;
 211             s = *dmin__ * .25f;
 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.f);
 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.f) {
 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 (dmax(b2,b1) * 100.f < a2 || .563f < a2) {
 241                         goto L40;
 242                     }
 243 /* L30: */
 244                 }
 245 L40:
 246                 a2 *= 1.05f;
 247             }
 248
 249             if (a2 < .563f) {
 250                 s = gam * (1.f - sqrt(a2)) / (a2 + 1.f);
 251             }
 252         } else {
 253
 254 /*           Case 6, no information to guide us. */
 255
 256             if (*ttype == -6) {
 257                 g += (1.f - g) * .333f;
 258             } else if (*ttype == -18) {
 259                 g = .083250000000000005f;
 260             } else {
 261                 g = .25f;
 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 * .333f;
 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.f) {
 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 (dmax(b1,a2) * 100.f < b2) {
 294                     goto L60;
 295                 }
 296 /* L50: */
 297             }
 298 L60:
 299             b2 = sqrt(b2 * 1.05f);
 300 /* Computing 2nd power */
 301             r__1 = b2;
 302             a2 = *dmin1 / (r__1 * r__1 + 1.f);
 303             gap2 = *dmin2 * .5f - a2;
 304             if (gap2 > 0.f && gap2 > b2 * a2) {
 305 /* Computing MAX */
 306                 r__1 = s, r__2 = a2 * (1.f - a2 * 1.01f * (b2 / gap2) * b2);
 307                 s = dmax(r__1,r__2);
 308             } else {
 309 /* Computing MAX */
 310                 r__1 = s, r__2 = a2 * (1.f - b2 * 1.01f);
 311                 s = dmax(r__1,r__2);
 312                 *ttype = -8;
 313             }
 314         } else {
 315
 316 /*           Case 9. */
 317
 318             s = *dmin1 * .25f;
 319             if (*dmin1 == *dn1) {
 320                 s = *dmin1 * .5f;
 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.f < z__[nn - 7]) {
 332             *ttype = -10;
 333             s = *dmin2 * .333f;
 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.f) {
 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.f < b2) {
 350                     goto L80;
 351                 }
 352 /* L70: */
 353             }
 354 L80:
 355             b2 = sqrt(b2 * 1.05f);
 356 /* Computing 2nd power */
 357             r__1 = b2;
 358             a2 = *dmin2 / (r__1 * r__1 + 1.f);
 359             gap2 = z__[nn - 7] + z__[nn - 9] - sqrt(z__[nn - 11]) * sqrt(z__[
 360                     nn - 9]) - a2;
 361             if (gap2 > 0.f && gap2 > b2 * a2) {
 362 /* Computing MAX */
 363                 r__1 = s, r__2 = a2 * (1.f - a2 * 1.01f * (b2 / gap2) * b2);
 364                 s = dmax(r__1,r__2);
 365             } else {
 366 /* Computing MAX */
 367                 r__1 = s, r__2 = a2 * (1.f - b2 * 1.01f);
 368                 s = dmax(r__1,r__2);
 369             }
 370         } else {
 371             s = *dmin2 * .25f;
 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.f;
 379         *ttype = -12;
 380     }
 381
 382     *tau = s;
 383     return 0;
 384
 385 /*     End of SLASQ4 */
 386
 387 } /* slasq4_ */