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

   1 #include "clapack.h"
   2
   3 /* Table of constant values */
   4
   5 static integer c__1 = 1;
   6 static integer c__0 = 0;
   7 static real c_b8 = 1.f;
   8
   9 /* Subroutine */ int slasd8_(integer *icompq, integer *k, real *d__, real *
  10         z__, real *vf, real *vl, real *difl, real *difr, integer *lddifr,
  11         real *dsigma, real *work, integer *info)
  12 {
  13     /* System generated locals */
  14     integer difr_dim1, difr_offset, i__1, i__2;
  15     real r__1, r__2;
  16
  17     /* Builtin functions */
  18     double sqrt(doublereal), r_sign(real *, real *);
  19
  20     /* Local variables */
  21     integer i__, j;
  22     real dj, rho;
  23     integer iwk1, iwk2, iwk3;
  24     real temp;
  25     extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
  26     integer iwk2i, iwk3i;
  27     extern doublereal snrm2_(integer *, real *, integer *);
  28     real diflj, difrj, dsigj;
  29     extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
  30             integer *);
  31     extern doublereal slamc3_(real *, real *);
  32     extern /* Subroutine */ int slasd4_(integer *, integer *, real *, real *,
  33             real *, real *, real *, real *, integer *), xerbla_(char *,
  34             integer *);
  35     real dsigjp;
  36     extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
  37             real *, integer *, integer *, real *, integer *, integer *), slaset_(char *, integer *, integer *, real *, real *,
  38             real *, integer *);
  39
  40
  41 /*  -- LAPACK auxiliary routine (version 3.1) -- */
  42 /*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
  43 /*     November 2006 */
  44
  45 /*     .. Scalar Arguments .. */
  46 /*     .. */
  47 /*     .. Array Arguments .. */
  48 /*     .. */
  49
  50 /*  Purpose */
  51 /*  ======= */
  52
  53 /*  SLASD8 finds the square roots of the roots of the secular equation, */
  54 /*  as defined by the values in DSIGMA and Z. It makes the appropriate */
  55 /*  calls to SLASD4, and stores, for each  element in D, the distance */
  56 /*  to its two nearest poles (elements in DSIGMA). It also updates */
  57 /*  the arrays VF and VL, the first and last components of all the */
  58 /*  right singular vectors of the original bidiagonal matrix. */
  59
  60 /*  SLASD8 is called from SLASD6. */
  61
  62 /*  Arguments */
  63 /*  ========= */
  64
  65 /*  ICOMPQ  (input) INTEGER */
  66 /*          Specifies whether singular vectors are to be computed in */
  67 /*          factored form in the calling routine: */
  68 /*          = 0: Compute singular values only. */
  69 /*          = 1: Compute singular vectors in factored form as well. */
  70
  71 /*  K       (input) INTEGER */
  72 /*          The number of terms in the rational function to be solved */
  73 /*          by SLASD4.  K >= 1. */
  74
  75 /*  D       (output) REAL array, dimension ( K ) */
  76 /*          On output, D contains the updated singular values. */
  77
  78 /*  Z       (input) REAL array, dimension ( K ) */
  79 /*          The first K elements of this array contain the components */
  80 /*          of the deflation-adjusted updating row vector. */
  81
  82 /*  VF      (input/output) REAL array, dimension ( K ) */
  83 /*          On entry, VF contains  information passed through DBEDE8. */
  84 /*          On exit, VF contains the first K components of the first */
  85 /*          components of all right singular vectors of the bidiagonal */
  86 /*          matrix. */
  87
  88 /*  VL      (input/output) REAL array, dimension ( K ) */
  89 /*          On entry, VL contains  information passed through DBEDE8. */
  90 /*          On exit, VL contains the first K components of the last */
  91 /*          components of all right singular vectors of the bidiagonal */
  92 /*          matrix. */
  93
  94 /*  DIFL    (output) REAL array, dimension ( K ) */
  95 /*          On exit, DIFL(I) = D(I) - DSIGMA(I). */
  96
  97 /*  DIFR    (output) REAL array, */
  98 /*                   dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and */
  99 /*                   dimension ( K ) if ICOMPQ = 0. */
 100 /*          On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not */
 101 /*          defined and will not be referenced. */
 102
 103 /*          If ICOMPQ = 1, DIFR(1:K,2) is an array containing the */
 104 /*          normalizing factors for the right singular vector matrix. */
 105
 106 /*  LDDIFR  (input) INTEGER */
 107 /*          The leading dimension of DIFR, must be at least K. */
 108
 109 /*  DSIGMA  (input) REAL array, dimension ( K ) */
 110 /*          The first K elements of this array contain the old roots */
 111 /*          of the deflated updating problem.  These are the poles */
 112 /*          of the secular equation. */
 113
 114 /*  WORK    (workspace) REAL array, dimension at least 3 * K */
 115
 116 /*  INFO    (output) INTEGER */
 117 /*          = 0:  successful exit. */
 118 /*          < 0:  if INFO = -i, the i-th argument had an illegal value. */
 119 /*          > 0:  if INFO = 1, an singular value did not converge */
 120
 121 /*  Further Details */
 122 /*  =============== */
 123
 124 /*  Based on contributions by */
 125 /*     Ming Gu and Huan Ren, Computer Science Division, University of */
 126 /*     California at Berkeley, USA */
 127
 128 /*  ===================================================================== */
 129
 130 /*     .. Parameters .. */
 131 /*     .. */
 132 /*     .. Local Scalars .. */
 133 /*     .. */
 134 /*     .. External Subroutines .. */
 135 /*     .. */
 136 /*     .. External Functions .. */
 137 /*     .. */
 138 /*     .. Intrinsic Functions .. */
 139 /*     .. */
 140 /*     .. Executable Statements .. */
 141
 142 /*     Test the input parameters. */
 143
 144     /* Parameter adjustments */
 145     --d__;
 146     --z__;
 147     --vf;
 148     --vl;
 149     --difl;
 150     difr_dim1 = *lddifr;
 151     difr_offset = 1 + difr_dim1;
 152     difr -= difr_offset;
 153     --dsigma;
 154     --work;
 155
 156     /* Function Body */
 157     *info = 0;
 158
 159     if (*icompq < 0 || *icompq > 1) {
 160         *info = -1;
 161     } else if (*k < 1) {
 162         *info = -2;
 163     } else if (*lddifr < *k) {
 164         *info = -9;
 165     }
 166     if (*info != 0) {
 167         i__1 = -(*info);
 168         xerbla_("SLASD8", &i__1);
 169         return 0;
 170     }
 171
 172 /*     Quick return if possible */
 173
 174     if (*k == 1) {
 175         d__[1] = dabs(z__[1]);
 176         difl[1] = d__[1];
 177         if (*icompq == 1) {
 178             difl[2] = 1.f;
 179             difr[(difr_dim1 << 1) + 1] = 1.f;
 180         }
 181         return 0;
 182     }
 183
 184 /*     Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can */
 185 /*     be computed with high relative accuracy (barring over/underflow). */
 186 /*     This is a problem on machines without a guard digit in */
 187 /*     add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). */
 188 /*     The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I), */
 189 /*     which on any of these machines zeros out the bottommost */
 190 /*     bit of DSIGMA(I) if it is 1; this makes the subsequent */
 191 /*     subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation */
 192 /*     occurs. On binary machines with a guard digit (almost all */
 193 /*     machines) it does not change DSIGMA(I) at all. On hexadecimal */
 194 /*     and decimal machines with a guard digit, it slightly */
 195 /*     changes the bottommost bits of DSIGMA(I). It does not account */
 196 /*     for hexadecimal or decimal machines without guard digits */
 197 /*     (we know of none). We use a subroutine call to compute */
 198 /*     2*DSIGMA(I) to prevent optimizing compilers from eliminating */
 199 /*     this code. */
 200
 201     i__1 = *k;
 202     for (i__ = 1; i__ <= i__1; ++i__) {
 203         dsigma[i__] = slamc3_(&dsigma[i__], &dsigma[i__]) - dsigma[i__];
 204 /* L10: */
 205     }
 206
 207 /*     Book keeping. */
 208
 209     iwk1 = 1;
 210     iwk2 = iwk1 + *k;
 211     iwk3 = iwk2 + *k;
 212     iwk2i = iwk2 - 1;
 213     iwk3i = iwk3 - 1;
 214
 215 /*     Normalize Z. */
 216
 217     rho = snrm2_(k, &z__[1], &c__1);
 218     slascl_("G", &c__0, &c__0, &rho, &c_b8, k, &c__1, &z__[1], k, info);
 219     rho *= rho;
 220
 221 /*     Initialize WORK(IWK3). */
 222
 223     slaset_("A", k, &c__1, &c_b8, &c_b8, &work[iwk3], k);
 224
 225 /*     Compute the updated singular values, the arrays DIFL, DIFR, */
 226 /*     and the updated Z. */
 227
 228     i__1 = *k;
 229     for (j = 1; j <= i__1; ++j) {
 230         slasd4_(k, &j, &dsigma[1], &z__[1], &work[iwk1], &rho, &d__[j], &work[
 231                 iwk2], info);
 232
 233 /*        If the root finder fails, the computation is terminated. */
 234
 235         if (*info != 0) {
 236             return 0;
 237         }
 238         work[iwk3i + j] = work[iwk3i + j] * work[j] * work[iwk2i + j];
 239         difl[j] = -work[j];
 240         difr[j + difr_dim1] = -work[j + 1];
 241         i__2 = j - 1;
 242         for (i__ = 1; i__ <= i__2; ++i__) {
 243             work[iwk3i + i__] = work[iwk3i + i__] * work[i__] * work[iwk2i +
 244                     i__] / (dsigma[i__] - dsigma[j]) / (dsigma[i__] + dsigma[
 245                     j]);
 246 /* L20: */
 247         }
 248         i__2 = *k;
 249         for (i__ = j + 1; i__ <= i__2; ++i__) {
 250             work[iwk3i + i__] = work[iwk3i + i__] * work[i__] * work[iwk2i +
 251                     i__] / (dsigma[i__] - dsigma[j]) / (dsigma[i__] + dsigma[
 252                     j]);
 253 /* L30: */
 254         }
 255 /* L40: */
 256     }
 257
 258 /*     Compute updated Z. */
 259
 260     i__1 = *k;
 261     for (i__ = 1; i__ <= i__1; ++i__) {
 262         r__2 = sqrt((r__1 = work[iwk3i + i__], dabs(r__1)));
 263         z__[i__] = r_sign(&r__2, &z__[i__]);
 264 /* L50: */
 265     }
 266
 267 /*     Update VF and VL. */
 268
 269     i__1 = *k;
 270     for (j = 1; j <= i__1; ++j) {
 271         diflj = difl[j];
 272         dj = d__[j];
 273         dsigj = -dsigma[j];
 274         if (j < *k) {
 275             difrj = -difr[j + difr_dim1];
 276             dsigjp = -dsigma[j + 1];
 277         }
 278         work[j] = -z__[j] / diflj / (dsigma[j] + dj);
 279         i__2 = j - 1;
 280         for (i__ = 1; i__ <= i__2; ++i__) {
 281             work[i__] = z__[i__] / (slamc3_(&dsigma[i__], &dsigj) - diflj) / (
 282                     dsigma[i__] + dj);
 283 /* L60: */
 284         }
 285         i__2 = *k;
 286         for (i__ = j + 1; i__ <= i__2; ++i__) {
 287             work[i__] = z__[i__] / (slamc3_(&dsigma[i__], &dsigjp) + difrj) /
 288                     (dsigma[i__] + dj);
 289 /* L70: */
 290         }
 291         temp = snrm2_(k, &work[1], &c__1);
 292         work[iwk2i + j] = sdot_(k, &work[1], &c__1, &vf[1], &c__1) / temp;
 293         work[iwk3i + j] = sdot_(k, &work[1], &c__1, &vl[1], &c__1) / temp;
 294         if (*icompq == 1) {
 295             difr[j + (difr_dim1 << 1)] = temp;
 296         }
 297 /* L80: */
 298     }
 299
 300     scopy_(k, &work[iwk2], &c__1, &vf[1], &c__1);
 301     scopy_(k, &work[iwk3], &c__1, &vl[1], &c__1);
 302
 303     return 0;
 304
 305 /*     End of SLASD8 */
 306
 307 } /* slasd8_ */