lapack/dlarf.c

/* dlarf.f -- translated by f2c (version 20061008).
   You must link the resulting object file with libf2c:
        on Microsoft Windows system, link with libf2c.lib;
        on Linux or Unix systems, link with .../path/to/libf2c.a -lm
        or, if you install libf2c.a in a standard place, with -lf2c -lm
        -- in that order, at the end of the command line, as in
                cc *.o -lf2c -lm
        Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,

                http://www.netlib.org/f2c/libf2c.zip
*/

#include "blaswrap.h"
#include "lapack_datatypes.h"

/* Table of constant values */

static doublereal c_b4 = 1.;
static doublereal c_b5 = 0.;
static integer c__1 = 1;

/* Subroutine */ void dlarf_(char *side, integer *m, integer *n, doublereal *v, integer *incv, doublereal *tau,
                             doublereal *c__, integer *ldc, doublereal *work) {
  /* System generated locals */
  integer c_dim1, c_offset;
  doublereal d__1;

  /* Local variables */
  integer i__;
  logical applyleft;
  extern /* Subroutine */ void dger_(integer *, integer *, doublereal *, doublereal *, integer *, doublereal *,
                                     integer *, doublereal *, integer *);
  extern logical lsame_(char *, char *);
  extern /* Subroutine */ void dgemv_(const char *, const integer *, const integer *, const doublereal *,
                                      const doublereal *, const integer *, const doublereal *, const integer *,
                                      const doublereal *, doublereal *, const integer *);
  integer lastc, lastv;
  extern integer iladlc_(integer *, integer *, doublereal *, integer *),
      iladlr_(integer *, integer *, doublereal *, integer *);

  /*  -- LAPACK auxiliary routine (version 3.2) -- */
  /*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
  /*     November 2006 */

  /*     .. Scalar Arguments .. */
  /*     .. */
  /*     .. Array Arguments .. */
  /*     .. */

  /*  Purpose */
  /*  ======= */

  /*  DLARF applies a real elementary reflector H to a real m by n matrix */
  /*  C, from either the left or the right. H is represented in the form */

  /*        H = I - tau * v * v' */

  /*  where tau is a real scalar and v is a real vector. */

  /*  If tau = 0, then H is taken to be the unit matrix. */

  /*  Arguments */
  /*  ========= */

  /*  SIDE    (input) CHARACTER*1 */
  /*          = 'L': form  H * C */
  /*          = 'R': form  C * H */

  /*  M       (input) INTEGER */
  /*          The number of rows of the matrix C. */

  /*  N       (input) INTEGER */
  /*          The number of columns of the matrix C. */

  /*  V       (input) DOUBLE PRECISION array, dimension */
  /*                     (1 + (M-1)*abs(INCV)) if SIDE = 'L' */
  /*                  or (1 + (N-1)*abs(INCV)) if SIDE = 'R' */
  /*          The vector v in the representation of H. V is not used if */
  /*          TAU = 0. */

  /*  INCV    (input) INTEGER */
  /*          The increment between elements of v. INCV <> 0. */

  /*  TAU     (input) DOUBLE PRECISION */
  /*          The value tau in the representation of H. */

  /*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N) */
  /*          On entry, the m by n matrix C. */
  /*          On exit, C is overwritten by the matrix H * C if SIDE = 'L', */
  /*          or C * H if SIDE = 'R'. */

  /*  LDC     (input) INTEGER */
  /*          The leading dimension of the array C. LDC >= max(1,M). */

  /*  WORK    (workspace) DOUBLE PRECISION array, dimension */
  /*                         (N) if SIDE = 'L' */
  /*                      or (M) if SIDE = 'R' */

  /*  ===================================================================== */

  /*     .. Parameters .. */
  /*     .. */
  /*     .. Local Scalars .. */
  /*     .. */
  /*     .. External Subroutines .. */
  /*     .. */
  /*     .. External Functions .. */
  /*     .. */
  /*     .. Executable Statements .. */

  /* Parameter adjustments */
  --v;
  c_dim1 = *ldc;
  c_offset = 1 + c_dim1;
  c__ -= c_offset;
  --work;

  /* Function Body */
  applyleft = lsame_(side, "L");
  lastv = 0;
  lastc = 0;
  if (*tau != 0.) {
    /*     Set up variables for scanning V.  LASTV begins pointing to the end */
    /*     of V. */
    if (applyleft) {
      lastv = *m;
    } else {
      lastv = *n;
    }
    if (*incv > 0) {
      i__ = (lastv - 1) * *incv + 1;
    } else {
      i__ = 1;
    }
    /*     Look for the last non-zero row in V. */
    while (lastv > 0 && v[i__] == 0.) {
      --lastv;
      i__ -= *incv;
    }
    if (applyleft) {
      /*     Scan for the last non-zero column in C(1:lastv,:). */
      lastc = iladlc_(&lastv, n, &c__[c_offset], ldc);
    } else {
      /*     Scan for the last non-zero row in C(:,1:lastv). */
      lastc = iladlr_(m, &lastv, &c__[c_offset], ldc);
    }
  }
  /*     Note that lastc.eq.0 renders the BLAS operations null; no special */
  /*     case is needed at this level. */
  if (applyleft) {
    /*        Form  H * C */

    if (lastv > 0) {
      /*           w(1:lastc,1) := C(1:lastv,1:lastc)' * v(1:lastv,1) */

      dgemv_("Transpose", &lastv, &lastc, &c_b4, &c__[c_offset], ldc, &v[1], incv, &c_b5, &work[1], &c__1);

      /*           C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)' */

      d__1 = -(*tau);
      dger_(&lastv, &lastc, &d__1, &v[1], incv, &work[1], &c__1, &c__[c_offset], ldc);
    }
  } else {
    /*        Form  C * H */

    if (lastv > 0) {
      /*           w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) */

      dgemv_("No transpose", &lastc, &lastv, &c_b4, &c__[c_offset], ldc, &v[1], incv, &c_b5, &work[1], &c__1);

      /*           C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)' */

      d__1 = -(*tau);
      dger_(&lastc, &lastv, &d__1, &work[1], &c__1, &v[1], incv, &c__[c_offset], ldc);
    }
  }

  /*     End of DLARF */

} /* dlarf_ */