/* zlarf.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 doublecomplex c_b1 = {1., 0.};
static doublecomplex c_b2 = {0., 0.};
static integer c__1 = 1;

/* Subroutine */ void zlarf_(char *side, integer *m, integer *n, doublecomplex *v, integer *incv, doublecomplex *tau,
                             doublecomplex *c__, integer *ldc, doublecomplex *work) {
  /* System generated locals */
  integer c_dim1, c_offset, i__1;
  doublecomplex z__1;

  /* Local variables */
  integer i__;
  logical applyleft;
  extern logical lsame_(char *, char *);
  integer lastc;
  extern /* Subroutine */ void zgerc_(integer *, integer *, doublecomplex *, doublecomplex *, integer *,
                                      doublecomplex *, integer *, doublecomplex *, integer *),
      zgemv_(const char *, const integer *, const integer *, const doublecomplex *, const doublecomplex *,
             const integer *, const doublecomplex *, const integer *, const doublecomplex *, doublecomplex *,
             const integer *);
  integer lastv;
  extern integer ilazlc_(integer *, integer *, doublecomplex *, integer *),
      ilazlr_(integer *, integer *, doublecomplex *, integer *);

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

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

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

  /*  ZLARF applies a complex elementary reflector H to a complex 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 complex scalar and v is a complex vector. */

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

  /*  To apply H' (the conjugate transpose of H), supply conjg(tau) instead */
  /*  tau. */

  /*  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) COMPLEX*16 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) COMPLEX*16 */
  /*          The value tau in the representation of H. */

  /*  C       (input/output) COMPLEX*16 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) COMPLEX*16 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->r != 0. || tau->i != 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. */
    for (;;) { /* while(complicated condition) */
      i__1 = i__;
      if (!(lastv > 0 && (v[i__1].r == 0. && v[i__1].i == 0.))) break;
      --lastv;
      i__ -= *incv;
    }
    if (applyleft) {
      /*     Scan for the last non-zero column in C(1:lastv,:). */
      lastc = ilazlc_(&lastv, n, &c__[c_offset], ldc);
    } else {
      /*     Scan for the last non-zero row in C(:,1:lastv). */
      lastc = ilazlr_(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) */

      zgemv_("Conjugate transpose", &lastv, &lastc, &c_b1, &c__[c_offset], ldc, &v[1], incv, &c_b2, &work[1], &c__1);

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

      z__1.r = -tau->r, z__1.i = -tau->i;
      zgerc_(&lastv, &lastc, &z__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) */

      zgemv_("No transpose", &lastc, &lastv, &c_b1, &c__[c_offset], ldc, &v[1], incv, &c_b2, &work[1], &c__1);

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

      z__1.r = -tau->r, z__1.i = -tau->i;
      zgerc_(&lastc, &lastv, &z__1, &work[1], &c__1, &v[1], incv, &c__[c_offset], ldc);
    }
  }

  /*     End of ZLARF */

} /* zlarf_ */