| /* clarf.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 complex c_b1 = {1.f, 0.f}; |
| static complex c_b2 = {0.f, 0.f}; |
| static integer c__1 = 1; |
| |
| /* Subroutine */ void clarf_(char *side, integer *m, integer *n, complex *v, integer *incv, complex *tau, complex *c__, |
| integer *ldc, complex *work) { |
| /* System generated locals */ |
| integer c_dim1, c_offset, i__1; |
| complex q__1; |
| |
| /* Local variables */ |
| integer i__; |
| logical applyleft; |
| extern /* Subroutine */ void cgerc_(integer *, integer *, complex *, complex *, integer *, complex *, integer *, |
| complex *, integer *), |
| cgemv_(const char *, const integer *, const integer *, const complex *, const complex *, const integer *, |
| const complex *, const integer *, const complex *, complex *, const integer *); |
| extern logical lsame_(char *, char *); |
| integer lastc, lastv; |
| extern integer ilaclc_(integer *, integer *, complex *, integer *), |
| ilaclr_(integer *, integer *, complex *, integer *); |
| |
| /* -- LAPACK auxiliary routine (version 3.2) -- */ |
| /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ |
| /* November 2006 */ |
| |
| /* .. Scalar Arguments .. */ |
| /* .. */ |
| /* .. Array Arguments .. */ |
| /* .. */ |
| |
| /* Purpose */ |
| /* ======= */ |
| |
| /* CLARF 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 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 */ |
| /* The value tau in the representation of H. */ |
| |
| /* C (input/output) COMPLEX 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 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.f || tau->i != 0.f) { |
| /* 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.f && v[i__1].i == 0.f))) break; |
| --lastv; |
| i__ -= *incv; |
| } |
| if (applyleft) { |
| /* Scan for the last non-zero column in C(1:lastv,:). */ |
| lastc = ilaclc_(&lastv, n, &c__[c_offset], ldc); |
| } else { |
| /* Scan for the last non-zero row in C(:,1:lastv). */ |
| lastc = ilaclr_(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) */ |
| |
| cgemv_("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)' */ |
| |
| q__1.r = -tau->r, q__1.i = -tau->i; |
| cgerc_(&lastv, &lastc, &q__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) */ |
| |
| cgemv_("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)' */ |
| |
| q__1.r = -tau->r, q__1.i = -tau->i; |
| cgerc_(&lastc, &lastv, &q__1, &work[1], &c__1, &v[1], incv, &c__[c_offset], ldc); |
| } |
| } |
| |
| /* End of CLARF */ |
| |
| } /* clarf_ */ |
