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

   1 #include "clapack.h"
   2
   3 /* Table of constant values */
   4
   5 static real c_b4 = 1.f;
   6 static real c_b5 = 0.f;
   7 static integer c__1 = 1;
   8
   9 /* Subroutine */ int slarf_(char *side, integer *m, integer *n, real *v,
  10         integer *incv, real *tau, real *c__, integer *ldc, real *work)
  11 {
  12     /* System generated locals */
  13     integer c_dim1, c_offset;
  14     real r__1;
  15
  16     /* Local variables */
  17     extern /* Subroutine */ int sger_(integer *, integer *, real *, real *,
  18             integer *, real *, integer *, real *, integer *);
  19     extern logical lsame_(char *, char *);
  20     extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
  21             real *, integer *, real *, integer *, real *, real *, integer *);
  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 /*  SLARF applies a real elementary reflector H to a real m by n matrix */
  37 /*  C, from either the left or the right. H is represented in the form */
  38
  39 /*        H = I - tau * v * v' */
  40
  41 /*  where tau is a real scalar and v is a real vector. */
  42
  43 /*  If tau = 0, then H is taken to be the unit matrix. */
  44
  45 /*  Arguments */
  46 /*  ========= */
  47
  48 /*  SIDE    (input) CHARACTER*1 */
  49 /*          = 'L': form  H * C */
  50 /*          = 'R': form  C * H */
  51
  52 /*  M       (input) INTEGER */
  53 /*          The number of rows of the matrix C. */
  54
  55 /*  N       (input) INTEGER */
  56 /*          The number of columns of the matrix C. */
  57
  58 /*  V       (input) REAL array, dimension */
  59 /*                     (1 + (M-1)*abs(INCV)) if SIDE = 'L' */
  60 /*                  or (1 + (N-1)*abs(INCV)) if SIDE = 'R' */
  61 /*          The vector v in the representation of H. V is not used if */
  62 /*          TAU = 0. */
  63
  64 /*  INCV    (input) INTEGER */
  65 /*          The increment between elements of v. INCV <> 0. */
  66
  67 /*  TAU     (input) REAL */
  68 /*          The value tau in the representation of H. */
  69
  70 /*  C       (input/output) REAL array, dimension (LDC,N) */
  71 /*          On entry, the m by n matrix C. */
  72 /*          On exit, C is overwritten by the matrix H * C if SIDE = 'L', */
  73 /*          or C * H if SIDE = 'R'. */
  74
  75 /*  LDC     (input) INTEGER */
  76 /*          The leading dimension of the array C. LDC >= max(1,M). */
  77
  78 /*  WORK    (workspace) REAL array, dimension */
  79 /*                         (N) if SIDE = 'L' */
  80 /*                      or (M) if SIDE = 'R' */
  81
  82 /*  ===================================================================== */
  83
  84 /*     .. Parameters .. */
  85 /*     .. */
  86 /*     .. External Subroutines .. */
  87 /*     .. */
  88 /*     .. External Functions .. */
  89 /*     .. */
  90 /*     .. Executable Statements .. */
  91
  92     /* Parameter adjustments */
  93     --v;
  94     c_dim1 = *ldc;
  95     c_offset = 1 + c_dim1;
  96     c__ -= c_offset;
  97     --work;
  98
  99     /* Function Body */
 100     if (lsame_(side, "L")) {
 101
 102 /*        Form  H * C */
 103
 104         if (*tau != 0.f) {
 105
 106 /*           w := C' * v */
 107
 108             sgemv_("Transpose", m, n, &c_b4, &c__[c_offset], ldc, &v[1], incv,
 109                      &c_b5, &work[1], &c__1);
 110
 111 /*           C := C - v * w' */
 112
 113             r__1 = -(*tau);
 114             sger_(m, n, &r__1, &v[1], incv, &work[1], &c__1, &c__[c_offset],
 115                     ldc);
 116         }
 117     } else {
 118
 119 /*        Form  C * H */
 120
 121         if (*tau != 0.f) {
 122
 123 /*           w := C * v */
 124
 125             sgemv_("No transpose", m, n, &c_b4, &c__[c_offset], ldc, &v[1],
 126                     incv, &c_b5, &work[1], &c__1);
 127
 128 /*           C := C - w * v' */
 129
 130             r__1 = -(*tau);
 131             sger_(m, n, &r__1, &work[1], &c__1, &v[1], incv, &c__[c_offset],
 132                     ldc);
 133         }
 134     }
 135     return 0;
 136
 137 /*     End of SLARF */
 138
 139 } /* slarf_ */