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

   1 #include "clapack.h"
   2
   3 /* Table of constant values */
   4
   5 static integer c__1 = 1;
   6
   7 /* Subroutine */ int sorg2r_(integer *m, integer *n, integer *k, real *a,
   8         integer *lda, real *tau, real *work, integer *info)
   9 {
  10     /* System generated locals */
  11     integer a_dim1, a_offset, i__1, i__2;
  12     real r__1;
  13
  14     /* Local variables */
  15     integer i__, j, l;
  16     extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
  17             slarf_(char *, integer *, integer *, real *, integer *, real *,
  18             real *, integer *, real *), xerbla_(char *, integer *);
  19
  20
  21 /*  -- LAPACK 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 /*  SORG2R generates an m by n real matrix Q with orthonormal columns, */
  34 /*  which is defined as the first n columns of a product of k elementary */
  35 /*  reflectors of order m */
  36
  37 /*        Q  =  H(1) H(2) . . . H(k) */
  38
  39 /*  as returned by SGEQRF. */
  40
  41 /*  Arguments */
  42 /*  ========= */
  43
  44 /*  M       (input) INTEGER */
  45 /*          The number of rows of the matrix Q. M >= 0. */
  46
  47 /*  N       (input) INTEGER */
  48 /*          The number of columns of the matrix Q. M >= N >= 0. */
  49
  50 /*  K       (input) INTEGER */
  51 /*          The number of elementary reflectors whose product defines the */
  52 /*          matrix Q. N >= K >= 0. */
  53
  54 /*  A       (input/output) REAL array, dimension (LDA,N) */
  55 /*          On entry, the i-th column must contain the vector which */
  56 /*          defines the elementary reflector H(i), for i = 1,2,...,k, as */
  57 /*          returned by SGEQRF in the first k columns of its array */
  58 /*          argument A. */
  59 /*          On exit, the m-by-n matrix Q. */
  60
  61 /*  LDA     (input) INTEGER */
  62 /*          The first dimension of the array A. LDA >= max(1,M). */
  63
  64 /*  TAU     (input) REAL array, dimension (K) */
  65 /*          TAU(i) must contain the scalar factor of the elementary */
  66 /*          reflector H(i), as returned by SGEQRF. */
  67
  68 /*  WORK    (workspace) REAL array, dimension (N) */
  69
  70 /*  INFO    (output) INTEGER */
  71 /*          = 0: successful exit */
  72 /*          < 0: if INFO = -i, the i-th argument has an illegal value */
  73
  74 /*  ===================================================================== */
  75
  76 /*     .. Parameters .. */
  77 /*     .. */
  78 /*     .. Local Scalars .. */
  79 /*     .. */
  80 /*     .. External Subroutines .. */
  81 /*     .. */
  82 /*     .. Intrinsic Functions .. */
  83 /*     .. */
  84 /*     .. Executable Statements .. */
  85
  86 /*     Test the input arguments */
  87
  88     /* Parameter adjustments */
  89     a_dim1 = *lda;
  90     a_offset = 1 + a_dim1;
  91     a -= a_offset;
  92     --tau;
  93     --work;
  94
  95     /* Function Body */
  96     *info = 0;
  97     if (*m < 0) {
  98         *info = -1;
  99     } else if (*n < 0 || *n > *m) {
 100         *info = -2;
 101     } else if (*k < 0 || *k > *n) {
 102         *info = -3;
 103     } else if (*lda < max(1,*m)) {
 104         *info = -5;
 105     }
 106     if (*info != 0) {
 107         i__1 = -(*info);
 108         xerbla_("SORG2R", &i__1);
 109         return 0;
 110     }
 111
 112 /*     Quick return if possible */
 113
 114     if (*n <= 0) {
 115         return 0;
 116     }
 117
 118 /*     Initialise columns k+1:n to columns of the unit matrix */
 119
 120     i__1 = *n;
 121     for (j = *k + 1; j <= i__1; ++j) {
 122         i__2 = *m;
 123         for (l = 1; l <= i__2; ++l) {
 124             a[l + j * a_dim1] = 0.f;
 125 /* L10: */
 126         }
 127         a[j + j * a_dim1] = 1.f;
 128 /* L20: */
 129     }
 130
 131     for (i__ = *k; i__ >= 1; --i__) {
 132
 133 /*        Apply H(i) to A(i:m,i:n) from the left */
 134
 135         if (i__ < *n) {
 136             a[i__ + i__ * a_dim1] = 1.f;
 137             i__1 = *m - i__ + 1;
 138             i__2 = *n - i__;
 139             slarf_("Left", &i__1, &i__2, &a[i__ + i__ * a_dim1], &c__1, &tau[
 140                     i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]);
 141         }
 142         if (i__ < *m) {
 143             i__1 = *m - i__;
 144             r__1 = -tau[i__];
 145             sscal_(&i__1, &r__1, &a[i__ + 1 + i__ * a_dim1], &c__1);
 146         }
 147         a[i__ + i__ * a_dim1] = 1.f - tau[i__];
 148
 149 /*        Set A(1:i-1,i) to zero */
 150
 151         i__1 = i__ - 1;
 152         for (l = 1; l <= i__1; ++l) {
 153             a[l + i__ * a_dim1] = 0.f;
 154 /* L30: */
 155         }
 156 /* L40: */
 157     }
 158     return 0;
 159
 160 /*     End of SORG2R */
 161
 162 } /* sorg2r_ */