Remove int return values from LAPACK functions. PiperOrigin-RevId: 609443878 Change-Id: I4a23ce01977c42315de900c5d77254c33dffba92
diff --git a/blas/f2c/scabs1.c b/blas/f2c/scabs1.c index 61e4ac8..5b4e71d 100644 --- a/blas/f2c/scabs1.c +++ b/blas/f2c/scabs1.c
@@ -1,15 +1,12 @@ #include "datatypes.h" -doublereal scabs1_(complex *z__) -{ - /* System generated locals */ - real ret_val, r__1, r__2; - /* Builtin functions */ - double r_imag(complex *); -/* Purpose - ======= - SCABS1 computes absolute value of a complex number */ - ret_val = (r__1 = z__->r, dabs(r__1)) + (r__2 = r_imag(z__), dabs(r__2)); - return ret_val; -} /* scabs1_ */ +doublereal scabs1_(complex *z__) { + /* System generated locals */ + real ret_val, r__1, r__2; + /* Purpose + ======= + SCABS1 computes absolute value of a complex number */ + ret_val = (r__1 = z__->r, dabs(r__1)) + (r__2 = z__->i, dabs(r__2)); + return ret_val; +} /* scabs1_ */
diff --git a/lapack/clacgv.c b/lapack/clacgv.c index 31fa8ff..896d313 100644 --- a/lapack/clacgv.c +++ b/lapack/clacgv.c
@@ -1,95 +1,94 @@ /* clacgv.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., + 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 + http://www.netlib.org/f2c/libf2c.zip */ -#include "f2c.h" #include "blaswrap.h" +#include "lapack_datatypes.h" -/* Subroutine */ int clacgv_(integer *n, complex *x, integer *incx) -{ - /* System generated locals */ - integer i__1, i__2; - complex q__1; +static inline void r_cnjg(complex *r, complex *z) { + r->r = z->r; + r->i = -(z->i); +} - /* Builtin functions */ - void r_cnjg(complex *, complex *); +/* Subroutine */ void clacgv_(integer *n, complex *x, integer *incx) { + /* System generated locals */ + integer i__1, i__2; + complex q__1; - /* Local variables */ - integer i__, ioff; + /* Local variables */ + integer i__, ioff; + /* -- LAPACK auxiliary routine (version 3.2) -- */ + /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ + /* November 2006 */ -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ + /* .. Scalar Arguments .. */ + /* .. */ + /* .. Array Arguments .. */ + /* .. */ -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ + /* Purpose */ + /* ======= */ -/* Purpose */ -/* ======= */ + /* CLACGV conjugates a complex vector of length N. */ -/* CLACGV conjugates a complex vector of length N. */ + /* Arguments */ + /* ========= */ -/* Arguments */ -/* ========= */ + /* N (input) INTEGER */ + /* The length of the vector X. N >= 0. */ -/* N (input) INTEGER */ -/* The length of the vector X. N >= 0. */ + /* X (input/output) COMPLEX array, dimension */ + /* (1+(N-1)*abs(INCX)) */ + /* On entry, the vector of length N to be conjugated. */ + /* On exit, X is overwritten with conjg(X). */ -/* X (input/output) COMPLEX array, dimension */ -/* (1+(N-1)*abs(INCX)) */ -/* On entry, the vector of length N to be conjugated. */ -/* On exit, X is overwritten with conjg(X). */ + /* INCX (input) INTEGER */ + /* The spacing between successive elements of X. */ -/* INCX (input) INTEGER */ -/* The spacing between successive elements of X. */ + /* ===================================================================== */ -/* ===================================================================== */ + /* .. Local Scalars .. */ + /* .. */ + /* .. Intrinsic Functions .. */ + /* .. */ + /* .. Executable Statements .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ + /* Parameter adjustments */ + --x; - /* Parameter adjustments */ - --x; - - /* Function Body */ - if (*incx == 1) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = i__; - r_cnjg(&q__1, &x[i__]); - x[i__2].r = q__1.r, x[i__2].i = q__1.i; -/* L10: */ - } - } else { - ioff = 1; - if (*incx < 0) { - ioff = 1 - (*n - 1) * *incx; - } - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = ioff; - r_cnjg(&q__1, &x[ioff]); - x[i__2].r = q__1.r, x[i__2].i = q__1.i; - ioff += *incx; -/* L20: */ - } + /* Function Body */ + if (*incx == 1) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + r_cnjg(&q__1, &x[i__]); + x[i__2].r = q__1.r, x[i__2].i = q__1.i; + /* L10: */ } - return 0; + } else { + ioff = 1; + if (*incx < 0) { + ioff = 1 - (*n - 1) * *incx; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = ioff; + r_cnjg(&q__1, &x[ioff]); + x[i__2].r = q__1.r, x[i__2].i = q__1.i; + ioff += *incx; + /* L20: */ + } + } -/* End of CLACGV */ + /* End of CLACGV */ } /* clacgv_ */
diff --git a/lapack/cladiv.c b/lapack/cladiv.c index d10c959..e6a0b0d 100644 --- a/lapack/cladiv.c +++ b/lapack/cladiv.c
@@ -1,74 +1,66 @@ /* cladiv.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., + 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 + http://www.netlib.org/f2c/libf2c.zip */ -#include "f2c.h" #include "blaswrap.h" +#include "lapack_datatypes.h" -/* Complex */ VOID cladiv_(complex * ret_val, complex *x, complex *y) -{ - /* System generated locals */ - real r__1, r__2, r__3, r__4; - complex q__1; +/* Complex */ void cladiv_(complex *ret_val, complex *x, complex *y) { + /* System generated locals */ + real r__1, r__2, r__3, r__4; + complex q__1; - /* Builtin functions */ - double r_imag(complex *); + /* Local variables */ + real zi, zr; + extern /* Subroutine */ void sladiv_(real *, real *, real *, real *, real *, real *); - /* Local variables */ - real zi, zr; - extern /* Subroutine */ int sladiv_(real *, real *, real *, real *, real * -, real *); + /* -- LAPACK auxiliary routine (version 3.2) -- */ + /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ + /* November 2006 */ + /* .. Scalar Arguments .. */ + /* .. */ -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ + /* Purpose */ + /* ======= */ -/* .. Scalar Arguments .. */ -/* .. */ + /* CLADIV := X / Y, where X and Y are complex. The computation of X / Y */ + /* will not overflow on an intermediary step unless the results */ + /* overflows. */ -/* Purpose */ -/* ======= */ + /* Arguments */ + /* ========= */ -/* CLADIV := X / Y, where X and Y are complex. The computation of X / Y */ -/* will not overflow on an intermediary step unless the results */ -/* overflows. */ + /* X (input) COMPLEX */ + /* Y (input) COMPLEX */ + /* The complex scalars X and Y. */ -/* Arguments */ -/* ========= */ + /* ===================================================================== */ -/* X (input) COMPLEX */ -/* Y (input) COMPLEX */ -/* The complex scalars X and Y. */ + /* .. Local Scalars .. */ + /* .. */ + /* .. External Subroutines .. */ + /* .. */ + /* .. Intrinsic Functions .. */ + /* .. */ + /* .. Executable Statements .. */ -/* ===================================================================== */ + r__1 = x->r; + r__2 = x->i; + r__3 = y->r; + r__4 = y->i; + sladiv_(&r__1, &r__2, &r__3, &r__4, &zr, &zi); + q__1.r = zr, q__1.i = zi; + ret_val->r = q__1.r, ret_val->i = q__1.i; -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - r__1 = x->r; - r__2 = r_imag(x); - r__3 = y->r; - r__4 = r_imag(y); - sladiv_(&r__1, &r__2, &r__3, &r__4, &zr, &zi); - q__1.r = zr, q__1.i = zi; - ret_val->r = q__1.r, ret_val->i = q__1.i; - - return ; - -/* End of CLADIV */ + /* End of CLADIV */ } /* cladiv_ */
diff --git a/lapack/clarf.c b/lapack/clarf.c index 53da4d3..0be36cd 100644 --- a/lapack/clarf.c +++ b/lapack/clarf.c
@@ -1,198 +1,185 @@ /* 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., + 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 + http://www.netlib.org/f2c/libf2c.zip */ -#include "f2c.h" #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 complex c_b1 = {1.f, 0.f}; +static complex c_b2 = {0.f, 0.f}; static integer c__1 = 1; -/* Subroutine */ int 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; +/* 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 */ int cgerc_(integer *, integer *, complex *, - complex *, integer *, complex *, integer *, complex *, integer *), - cgemv_(char *, integer *, integer *, complex *, complex *, - integer *, complex *, integer *, complex *, complex *, integer *); - extern logical lsame_(char *, char *); - integer lastc, lastv; - extern integer ilaclc_(integer *, integer *, complex *, integer *), - ilaclr_(integer *, integer *, complex *, integer *); + /* 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 */ -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ + /* .. Scalar Arguments .. */ + /* .. */ + /* .. Array Arguments .. */ + /* .. */ -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ + /* Purpose */ + /* ======= */ -/* 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 */ -/* 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' */ -/* H = I - tau * v * v' */ + /* where tau is a complex scalar and v is a complex vector. */ -/* where tau is a complex scalar and v is a complex vector. */ + /* If tau = 0, then H is taken to be the unit matrix. */ -/* 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. */ -/* To apply H' (the conjugate transpose of H), supply conjg(tau) instead */ -/* tau. */ + /* Arguments */ + /* ========= */ -/* Arguments */ -/* ========= */ + /* SIDE (input) CHARACTER*1 */ + /* = 'L': form H * C */ + /* = 'R': form C * H */ -/* SIDE (input) CHARACTER*1 */ -/* = 'L': form H * C */ -/* = 'R': form C * H */ + /* M (input) INTEGER */ + /* The number of rows of the matrix C. */ -/* M (input) INTEGER */ -/* The number of rows of the matrix C. */ + /* N (input) INTEGER */ + /* The number of columns 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. */ -/* 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. */ -/* INCV (input) INTEGER */ -/* The increment between elements of v. INCV <> 0. */ + /* TAU (input) COMPLEX */ + /* The value tau in the representation of H. */ -/* 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'. */ -/* 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). */ -/* 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' */ -/* WORK (workspace) COMPLEX array, dimension */ -/* (N) if SIDE = 'L' */ -/* or (M) if SIDE = 'R' */ + /* ===================================================================== */ -/* ===================================================================== */ + /* .. Parameters .. */ + /* .. */ + /* .. Local Scalars .. */ + /* .. */ + /* .. External Subroutines .. */ + /* .. */ + /* .. External Functions .. */ + /* .. */ + /* .. Executable Statements .. */ -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ + /* Parameter adjustments */ + --v; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + --work; - /* 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. */ + /* 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) { - -/* 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); - } + lastv = *m; } 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); - } + lastv = *n; } - return 0; + 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 */ -/* End of CLARF */ + 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_ */
diff --git a/lapack/clarfb.c b/lapack/clarfb.c index 6b31aa1..72fd915 100644 --- a/lapack/clarfb.c +++ b/lapack/clarfb.c
@@ -1,837 +1,736 @@ /* clarfb.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., + 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 + http://www.netlib.org/f2c/libf2c.zip */ -#include "f2c.h" #include "blaswrap.h" +#include "lapack_datatypes.h" + +static inline void r_cnjg(complex *r, complex *z) { + r->r = z->r; + r->i = -(z->i); +} /* Table of constant values */ -static complex c_b1 = {1.f,0.f}; +static complex c_b1 = {1.f, 0.f}; static integer c__1 = 1; -/* Subroutine */ int clarfb_(char *side, char *trans, char *direct, char * - storev, integer *m, integer *n, integer *k, complex *v, integer *ldv, - complex *t, integer *ldt, complex *c__, integer *ldc, complex *work, - integer *ldwork) -{ - /* System generated locals */ - integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1, - work_offset, i__1, i__2, i__3, i__4, i__5; - complex q__1, q__2; +/* Subroutine */ void clarfb_(char *side, char *trans, char *direct, char *storev, integer *m, integer *n, integer *k, + complex *v, integer *ldv, complex *t, integer *ldt, complex *c__, integer *ldc, + complex *work, integer *ldwork) { + /* System generated locals */ + integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1, work_offset, i__1, i__2, i__3, i__4, i__5; + complex q__1, q__2; - /* Builtin functions */ - void r_cnjg(complex *, complex *); + /* Local variables */ + integer i__, j; + extern /* Subroutine */ void cgemm_(const char *, const char *, const integer *, 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; + extern /* Subroutine */ void ccopy_(integer *, complex *, integer *, complex *, integer *), + ctrmm_(const char *, const char *, const char *, const char *, const integer *, const integer *, const complex *, + const complex *, const integer *, complex *, const integer *); + integer lastv; + extern integer ilaclc_(integer *, integer *, complex *, integer *); + extern /* Subroutine */ void clacgv_(integer *, complex *, integer *); + extern integer ilaclr_(integer *, integer *, complex *, integer *); + char transt[1]; - /* Local variables */ - integer i__, j; - extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *, - integer *, complex *, complex *, integer *, complex *, integer *, - complex *, complex *, integer *); - extern logical lsame_(char *, char *); - integer lastc; - extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, - complex *, integer *), ctrmm_(char *, char *, char *, char *, - integer *, integer *, complex *, complex *, integer *, complex *, - integer *); - integer lastv; - extern integer ilaclc_(integer *, integer *, complex *, integer *); - extern /* Subroutine */ int clacgv_(integer *, complex *, integer *); - extern integer ilaclr_(integer *, integer *, complex *, integer *); - char transt[1]; + /* -- LAPACK auxiliary routine (version 3.2) -- */ + /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ + /* November 2006 */ + /* .. Scalar Arguments .. */ + /* .. */ + /* .. Array Arguments .. */ + /* .. */ -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ + /* Purpose */ + /* ======= */ -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ + /* CLARFB applies a complex block reflector H or its transpose H' to a */ + /* complex M-by-N matrix C, from either the left or the right. */ -/* Purpose */ -/* ======= */ + /* Arguments */ + /* ========= */ -/* CLARFB applies a complex block reflector H or its transpose H' to a */ -/* complex M-by-N matrix C, from either the left or the right. */ + /* SIDE (input) CHARACTER*1 */ + /* = 'L': apply H or H' from the Left */ + /* = 'R': apply H or H' from the Right */ -/* Arguments */ -/* ========= */ + /* TRANS (input) CHARACTER*1 */ + /* = 'N': apply H (No transpose) */ + /* = 'C': apply H' (Conjugate transpose) */ -/* SIDE (input) CHARACTER*1 */ -/* = 'L': apply H or H' from the Left */ -/* = 'R': apply H or H' from the Right */ + /* DIRECT (input) CHARACTER*1 */ + /* Indicates how H is formed from a product of elementary */ + /* reflectors */ + /* = 'F': H = H(1) H(2) . . . H(k) (Forward) */ + /* = 'B': H = H(k) . . . H(2) H(1) (Backward) */ -/* TRANS (input) CHARACTER*1 */ -/* = 'N': apply H (No transpose) */ -/* = 'C': apply H' (Conjugate transpose) */ + /* STOREV (input) CHARACTER*1 */ + /* Indicates how the vectors which define the elementary */ + /* reflectors are stored: */ + /* = 'C': Columnwise */ + /* = 'R': Rowwise */ -/* DIRECT (input) CHARACTER*1 */ -/* Indicates how H is formed from a product of elementary */ -/* reflectors */ -/* = 'F': H = H(1) H(2) . . . H(k) (Forward) */ -/* = 'B': H = H(k) . . . H(2) H(1) (Backward) */ + /* M (input) INTEGER */ + /* The number of rows of the matrix C. */ -/* STOREV (input) CHARACTER*1 */ -/* Indicates how the vectors which define the elementary */ -/* reflectors are stored: */ -/* = 'C': Columnwise */ -/* = 'R': Rowwise */ + /* N (input) INTEGER */ + /* The number of columns of the matrix C. */ -/* M (input) INTEGER */ -/* The number of rows of the matrix C. */ + /* K (input) INTEGER */ + /* The order of the matrix T (= the number of elementary */ + /* reflectors whose product defines the block reflector). */ -/* N (input) INTEGER */ -/* The number of columns of the matrix C. */ + /* V (input) COMPLEX array, dimension */ + /* (LDV,K) if STOREV = 'C' */ + /* (LDV,M) if STOREV = 'R' and SIDE = 'L' */ + /* (LDV,N) if STOREV = 'R' and SIDE = 'R' */ + /* The matrix V. See further details. */ -/* K (input) INTEGER */ -/* The order of the matrix T (= the number of elementary */ -/* reflectors whose product defines the block reflector). */ + /* LDV (input) INTEGER */ + /* The leading dimension of the array V. */ + /* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); */ + /* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); */ + /* if STOREV = 'R', LDV >= K. */ -/* V (input) COMPLEX array, dimension */ -/* (LDV,K) if STOREV = 'C' */ -/* (LDV,M) if STOREV = 'R' and SIDE = 'L' */ -/* (LDV,N) if STOREV = 'R' and SIDE = 'R' */ -/* The matrix V. See further details. */ + /* T (input) COMPLEX array, dimension (LDT,K) */ + /* The triangular K-by-K matrix T in the representation of the */ + /* block reflector. */ -/* LDV (input) INTEGER */ -/* The leading dimension of the array V. */ -/* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); */ -/* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); */ -/* if STOREV = 'R', LDV >= K. */ + /* LDT (input) INTEGER */ + /* The leading dimension of the array T. LDT >= K. */ -/* T (input) COMPLEX array, dimension (LDT,K) */ -/* The triangular K-by-K matrix T in the representation of the */ -/* block reflector. */ + /* C (input/output) COMPLEX array, dimension (LDC,N) */ + /* On entry, the M-by-N matrix C. */ + /* On exit, C is overwritten by H*C or H'*C or C*H or C*H'. */ -/* LDT (input) INTEGER */ -/* The leading dimension of the array T. LDT >= K. */ + /* LDC (input) INTEGER */ + /* The leading dimension of the array C. LDC >= max(1,M). */ -/* C (input/output) COMPLEX array, dimension (LDC,N) */ -/* On entry, the M-by-N matrix C. */ -/* On exit, C is overwritten by H*C or H'*C or C*H or C*H'. */ + /* WORK (workspace) COMPLEX array, dimension (LDWORK,K) */ -/* LDC (input) INTEGER */ -/* The leading dimension of the array C. LDC >= max(1,M). */ + /* LDWORK (input) INTEGER */ + /* The leading dimension of the array WORK. */ + /* If SIDE = 'L', LDWORK >= max(1,N); */ + /* if SIDE = 'R', LDWORK >= max(1,M). */ -/* WORK (workspace) COMPLEX array, dimension (LDWORK,K) */ + /* ===================================================================== */ -/* LDWORK (input) INTEGER */ -/* The leading dimension of the array WORK. */ -/* If SIDE = 'L', LDWORK >= max(1,N); */ -/* if SIDE = 'R', LDWORK >= max(1,M). */ + /* .. Parameters .. */ + /* .. */ + /* .. Local Scalars .. */ + /* .. */ + /* .. External Functions .. */ + /* .. */ + /* .. External Subroutines .. */ + /* .. */ + /* .. Intrinsic Functions .. */ + /* .. */ + /* .. Executable Statements .. */ -/* ===================================================================== */ + /* Quick return if possible */ -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ + /* Parameter adjustments */ + v_dim1 = *ldv; + v_offset = 1 + v_dim1; + v -= v_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1; + t -= t_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + work_dim1 = *ldwork; + work_offset = 1 + work_dim1; + work -= work_offset; -/* Quick return if possible */ + /* Function Body */ + if (*m <= 0 || *n <= 0) { + return; + } - /* Parameter adjustments */ - v_dim1 = *ldv; - v_offset = 1 + v_dim1; - v -= v_offset; - t_dim1 = *ldt; - t_offset = 1 + t_dim1; - t -= t_offset; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - work_dim1 = *ldwork; - work_offset = 1 + work_dim1; - work -= work_offset; + if (lsame_(trans, "N")) { + *(unsigned char *)transt = 'C'; + } else { + *(unsigned char *)transt = 'N'; + } - /* Function Body */ - if (*m <= 0 || *n <= 0) { - return 0; - } + if (lsame_(storev, "C")) { + if (lsame_(direct, "F")) { + /* Let V = ( V1 ) (first K rows) */ + /* ( V2 ) */ + /* where V1 is unit lower triangular. */ - if (lsame_(trans, "N")) { - *(unsigned char *)transt = 'C'; + if (lsame_(side, "L")) { + /* Form H * C or H' * C where C = ( C1 ) */ + /* ( C2 ) */ + + /* Computing MAX */ + i__1 = *k, i__2 = ilaclr_(m, k, &v[v_offset], ldv); + lastv = max(i__1, i__2); + lastc = ilaclc_(&lastv, n, &c__[c_offset], ldc); + + /* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) */ + + /* W := C1' */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + ccopy_(&lastc, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1], &c__1); + clacgv_(&lastc, &work[j * work_dim1 + 1], &c__1); + /* L10: */ + } + + /* W := W * V1 */ + + ctrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &c_b1, &v[v_offset], ldv, &work[work_offset], + ldwork); + if (lastv > *k) { + /* W := W + C2'*V2 */ + + i__1 = lastv - *k; + cgemm_("Conjugate transpose", "No transpose", &lastc, k, &i__1, &c_b1, &c__[*k + 1 + c_dim1], ldc, + &v[*k + 1 + v_dim1], ldv, &c_b1, &work[work_offset], ldwork); + } + + /* W := W * T' or W * T */ + + ctrmm_("Right", "Upper", transt, "Non-unit", &lastc, k, &c_b1, &t[t_offset], ldt, &work[work_offset], ldwork); + + /* C := C - V * W' */ + + if (*m > *k) { + /* C2 := C2 - V2 * W' */ + + i__1 = lastv - *k; + q__1.r = -1.f, q__1.i = -0.f; + cgemm_("No transpose", "Conjugate transpose", &i__1, &lastc, k, &q__1, &v[*k + 1 + v_dim1], ldv, + &work[work_offset], ldwork, &c_b1, &c__[*k + 1 + c_dim1], ldc); + } + + /* W := W * V1' */ + + ctrmm_("Right", "Lower", "Conjugate transpose", "Unit", &lastc, k, &c_b1, &v[v_offset], ldv, &work[work_offset], + ldwork); + + /* C1 := C1 - W' */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = lastc; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = j + i__ * c_dim1; + i__4 = j + i__ * c_dim1; + r_cnjg(&q__2, &work[i__ + j * work_dim1]); + q__1.r = c__[i__4].r - q__2.r, q__1.i = c__[i__4].i - q__2.i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + /* L20: */ + } + /* L30: */ + } + + } else if (lsame_(side, "R")) { + /* Form C * H or C * H' where C = ( C1 C2 ) */ + + /* Computing MAX */ + i__1 = *k, i__2 = ilaclr_(n, k, &v[v_offset], ldv); + lastv = max(i__1, i__2); + lastc = ilaclr_(m, &lastv, &c__[c_offset], ldc); + + /* W := C * V = (C1*V1 + C2*V2) (stored in WORK) */ + + /* W := C1 */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + ccopy_(&lastc, &c__[j * c_dim1 + 1], &c__1, &work[j * work_dim1 + 1], &c__1); + /* L40: */ + } + + /* W := W * V1 */ + + ctrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &c_b1, &v[v_offset], ldv, &work[work_offset], + ldwork); + if (lastv > *k) { + /* W := W + C2 * V2 */ + + i__1 = lastv - *k; + cgemm_("No transpose", "No transpose", &lastc, k, &i__1, &c_b1, &c__[(*k + 1) * c_dim1 + 1], ldc, + &v[*k + 1 + v_dim1], ldv, &c_b1, &work[work_offset], ldwork); + } + + /* W := W * T or W * T' */ + + ctrmm_("Right", "Upper", trans, "Non-unit", &lastc, k, &c_b1, &t[t_offset], ldt, &work[work_offset], ldwork); + + /* C := C - W * V' */ + + if (lastv > *k) { + /* C2 := C2 - W * V2' */ + + i__1 = lastv - *k; + q__1.r = -1.f, q__1.i = -0.f; + cgemm_("No transpose", "Conjugate transpose", &lastc, &i__1, k, &q__1, &work[work_offset], ldwork, + &v[*k + 1 + v_dim1], ldv, &c_b1, &c__[(*k + 1) * c_dim1 + 1], ldc); + } + + /* W := W * V1' */ + + ctrmm_("Right", "Lower", "Conjugate transpose", "Unit", &lastc, k, &c_b1, &v[v_offset], ldv, &work[work_offset], + ldwork); + + /* C1 := C1 - W */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = lastc; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * work_dim1; + q__1.r = c__[i__4].r - work[i__5].r, q__1.i = c__[i__4].i - work[i__5].i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + /* L50: */ + } + /* L60: */ + } + } + } else { - *(unsigned char *)transt = 'N'; + /* Let V = ( V1 ) */ + /* ( V2 ) (last K rows) */ + /* where V2 is unit upper triangular. */ + + if (lsame_(side, "L")) { + /* Form H * C or H' * C where C = ( C1 ) */ + /* ( C2 ) */ + + /* Computing MAX */ + i__1 = *k, i__2 = ilaclr_(m, k, &v[v_offset], ldv); + lastv = max(i__1, i__2); + lastc = ilaclc_(&lastv, n, &c__[c_offset], ldc); + + /* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) */ + + /* W := C2' */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + ccopy_(&lastc, &c__[lastv - *k + j + c_dim1], ldc, &work[j * work_dim1 + 1], &c__1); + clacgv_(&lastc, &work[j * work_dim1 + 1], &c__1); + /* L70: */ + } + + /* W := W * V2 */ + + ctrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &c_b1, &v[lastv - *k + 1 + v_dim1], ldv, + &work[work_offset], ldwork); + if (lastv > *k) { + /* W := W + C1'*V1 */ + + i__1 = lastv - *k; + cgemm_("Conjugate transpose", "No transpose", &lastc, k, &i__1, &c_b1, &c__[c_offset], ldc, &v[v_offset], ldv, + &c_b1, &work[work_offset], ldwork); + } + + /* W := W * T' or W * T */ + + ctrmm_("Right", "Lower", transt, "Non-unit", &lastc, k, &c_b1, &t[t_offset], ldt, &work[work_offset], ldwork); + + /* C := C - V * W' */ + + if (lastv > *k) { + /* C1 := C1 - V1 * W' */ + + i__1 = lastv - *k; + q__1.r = -1.f, q__1.i = -0.f; + cgemm_("No transpose", "Conjugate transpose", &i__1, &lastc, k, &q__1, &v[v_offset], ldv, &work[work_offset], + ldwork, &c_b1, &c__[c_offset], ldc); + } + + /* W := W * V2' */ + + ctrmm_("Right", "Upper", "Conjugate transpose", "Unit", &lastc, k, &c_b1, &v[lastv - *k + 1 + v_dim1], ldv, + &work[work_offset], ldwork); + + /* C2 := C2 - W' */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = lastc; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = lastv - *k + j + i__ * c_dim1; + i__4 = lastv - *k + j + i__ * c_dim1; + r_cnjg(&q__2, &work[i__ + j * work_dim1]); + q__1.r = c__[i__4].r - q__2.r, q__1.i = c__[i__4].i - q__2.i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + /* L80: */ + } + /* L90: */ + } + + } else if (lsame_(side, "R")) { + /* Form C * H or C * H' where C = ( C1 C2 ) */ + + /* Computing MAX */ + i__1 = *k, i__2 = ilaclr_(n, k, &v[v_offset], ldv); + lastv = max(i__1, i__2); + lastc = ilaclr_(m, &lastv, &c__[c_offset], ldc); + + /* W := C * V = (C1*V1 + C2*V2) (stored in WORK) */ + + /* W := C2 */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + ccopy_(&lastc, &c__[(lastv - *k + j) * c_dim1 + 1], &c__1, &work[j * work_dim1 + 1], &c__1); + /* L100: */ + } + + /* W := W * V2 */ + + ctrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &c_b1, &v[lastv - *k + 1 + v_dim1], ldv, + &work[work_offset], ldwork); + if (lastv > *k) { + /* W := W + C1 * V1 */ + + i__1 = lastv - *k; + cgemm_("No transpose", "No transpose", &lastc, k, &i__1, &c_b1, &c__[c_offset], ldc, &v[v_offset], ldv, &c_b1, + &work[work_offset], ldwork); + } + + /* W := W * T or W * T' */ + + ctrmm_("Right", "Lower", trans, "Non-unit", &lastc, k, &c_b1, &t[t_offset], ldt, &work[work_offset], ldwork); + + /* C := C - W * V' */ + + if (lastv > *k) { + /* C1 := C1 - W * V1' */ + + i__1 = lastv - *k; + q__1.r = -1.f, q__1.i = -0.f; + cgemm_("No transpose", "Conjugate transpose", &lastc, &i__1, k, &q__1, &work[work_offset], ldwork, + &v[v_offset], ldv, &c_b1, &c__[c_offset], ldc); + } + + /* W := W * V2' */ + + ctrmm_("Right", "Upper", "Conjugate transpose", "Unit", &lastc, k, &c_b1, &v[lastv - *k + 1 + v_dim1], ldv, + &work[work_offset], ldwork); + + /* C2 := C2 - W */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = lastc; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + (lastv - *k + j) * c_dim1; + i__4 = i__ + (lastv - *k + j) * c_dim1; + i__5 = i__ + j * work_dim1; + q__1.r = c__[i__4].r - work[i__5].r, q__1.i = c__[i__4].i - work[i__5].i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + /* L110: */ + } + /* L120: */ + } + } } - if (lsame_(storev, "C")) { + } else if (lsame_(storev, "R")) { + if (lsame_(direct, "F")) { + /* Let V = ( V1 V2 ) (V1: first K columns) */ + /* where V1 is unit upper triangular. */ - if (lsame_(direct, "F")) { + if (lsame_(side, "L")) { + /* Form H * C or H' * C where C = ( C1 ) */ + /* ( C2 ) */ -/* Let V = ( V1 ) (first K rows) */ -/* ( V2 ) */ -/* where V1 is unit lower triangular. */ + /* Computing MAX */ + i__1 = *k, i__2 = ilaclc_(k, m, &v[v_offset], ldv); + lastv = max(i__1, i__2); + lastc = ilaclc_(&lastv, n, &c__[c_offset], ldc); - if (lsame_(side, "L")) { + /* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) */ -/* Form H * C or H' * C where C = ( C1 ) */ -/* ( C2 ) */ + /* W := C1' */ -/* Computing MAX */ - i__1 = *k, i__2 = ilaclr_(m, k, &v[v_offset], ldv); - lastv = max(i__1,i__2); - lastc = ilaclc_(&lastv, n, &c__[c_offset], ldc); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + ccopy_(&lastc, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1], &c__1); + clacgv_(&lastc, &work[j * work_dim1 + 1], &c__1); + /* L130: */ + } -/* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) */ + /* W := W * V1' */ -/* W := C1' */ + ctrmm_("Right", "Upper", "Conjugate transpose", "Unit", &lastc, k, &c_b1, &v[v_offset], ldv, &work[work_offset], + ldwork); + if (lastv > *k) { + /* W := W + C2'*V2' */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - ccopy_(&lastc, &c__[j + c_dim1], ldc, &work[j * work_dim1 - + 1], &c__1); - clacgv_(&lastc, &work[j * work_dim1 + 1], &c__1); -/* L10: */ - } + i__1 = lastv - *k; + cgemm_("Conjugate transpose", "Conjugate transpose", &lastc, k, &i__1, &c_b1, &c__[*k + 1 + c_dim1], ldc, + &v[(*k + 1) * v_dim1 + 1], ldv, &c_b1, &work[work_offset], ldwork); + } -/* W := W * V1 */ + /* W := W * T' or W * T */ - ctrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, & - c_b1, &v[v_offset], ldv, &work[work_offset], ldwork); - if (lastv > *k) { + ctrmm_("Right", "Upper", transt, "Non-unit", &lastc, k, &c_b1, &t[t_offset], ldt, &work[work_offset], ldwork); -/* W := W + C2'*V2 */ + /* C := C - V' * W' */ - i__1 = lastv - *k; - cgemm_("Conjugate transpose", "No transpose", &lastc, k, & - i__1, &c_b1, &c__[*k + 1 + c_dim1], ldc, &v[*k + - 1 + v_dim1], ldv, &c_b1, &work[work_offset], - ldwork); - } + if (lastv > *k) { + /* C2 := C2 - V2' * W' */ -/* W := W * T' or W * T */ + i__1 = lastv - *k; + q__1.r = -1.f, q__1.i = -0.f; + cgemm_("Conjugate transpose", "Conjugate transpose", &i__1, &lastc, k, &q__1, &v[(*k + 1) * v_dim1 + 1], ldv, + &work[work_offset], ldwork, &c_b1, &c__[*k + 1 + c_dim1], ldc); + } - ctrmm_("Right", "Upper", transt, "Non-unit", &lastc, k, &c_b1, - &t[t_offset], ldt, &work[work_offset], ldwork); + /* W := W * V1 */ -/* C := C - V * W' */ + ctrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &c_b1, &v[v_offset], ldv, &work[work_offset], + ldwork); - if (*m > *k) { + /* C1 := C1 - W' */ -/* C2 := C2 - V2 * W' */ + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = lastc; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = j + i__ * c_dim1; + i__4 = j + i__ * c_dim1; + r_cnjg(&q__2, &work[i__ + j * work_dim1]); + q__1.r = c__[i__4].r - q__2.r, q__1.i = c__[i__4].i - q__2.i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + /* L140: */ + } + /* L150: */ + } - i__1 = lastv - *k; - q__1.r = -1.f, q__1.i = -0.f; - cgemm_("No transpose", "Conjugate transpose", &i__1, & - lastc, k, &q__1, &v[*k + 1 + v_dim1], ldv, &work[ - work_offset], ldwork, &c_b1, &c__[*k + 1 + c_dim1] -, ldc); - } + } else if (lsame_(side, "R")) { + /* Form C * H or C * H' where C = ( C1 C2 ) */ -/* W := W * V1' */ + /* Computing MAX */ + i__1 = *k, i__2 = ilaclc_(k, n, &v[v_offset], ldv); + lastv = max(i__1, i__2); + lastc = ilaclr_(m, &lastv, &c__[c_offset], ldc); - ctrmm_("Right", "Lower", "Conjugate transpose", "Unit", & - lastc, k, &c_b1, &v[v_offset], ldv, &work[work_offset] -, ldwork) - ; + /* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) */ -/* C1 := C1 - W' */ + /* W := C1 */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = lastc; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = j + i__ * c_dim1; - i__4 = j + i__ * c_dim1; - r_cnjg(&q__2, &work[i__ + j * work_dim1]); - q__1.r = c__[i__4].r - q__2.r, q__1.i = c__[i__4].i - - q__2.i; - c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; -/* L20: */ - } -/* L30: */ - } + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + ccopy_(&lastc, &c__[j * c_dim1 + 1], &c__1, &work[j * work_dim1 + 1], &c__1); + /* L160: */ + } - } else if (lsame_(side, "R")) { + /* W := W * V1' */ -/* Form C * H or C * H' where C = ( C1 C2 ) */ + ctrmm_("Right", "Upper", "Conjugate transpose", "Unit", &lastc, k, &c_b1, &v[v_offset], ldv, &work[work_offset], + ldwork); + if (lastv > *k) { + /* W := W + C2 * V2' */ -/* Computing MAX */ - i__1 = *k, i__2 = ilaclr_(n, k, &v[v_offset], ldv); - lastv = max(i__1,i__2); - lastc = ilaclr_(m, &lastv, &c__[c_offset], ldc); + i__1 = lastv - *k; + cgemm_("No transpose", "Conjugate transpose", &lastc, k, &i__1, &c_b1, &c__[(*k + 1) * c_dim1 + 1], ldc, + &v[(*k + 1) * v_dim1 + 1], ldv, &c_b1, &work[work_offset], ldwork); + } -/* W := C * V = (C1*V1 + C2*V2) (stored in WORK) */ + /* W := W * T or W * T' */ -/* W := C1 */ + ctrmm_("Right", "Upper", trans, "Non-unit", &lastc, k, &c_b1, &t[t_offset], ldt, &work[work_offset], ldwork); - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - ccopy_(&lastc, &c__[j * c_dim1 + 1], &c__1, &work[j * - work_dim1 + 1], &c__1); -/* L40: */ - } + /* C := C - W * V */ -/* W := W * V1 */ + if (lastv > *k) { + /* C2 := C2 - W * V2 */ - ctrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, & - c_b1, &v[v_offset], ldv, &work[work_offset], ldwork); - if (lastv > *k) { + i__1 = lastv - *k; + q__1.r = -1.f, q__1.i = -0.f; + cgemm_("No transpose", "No transpose", &lastc, &i__1, k, &q__1, &work[work_offset], ldwork, + &v[(*k + 1) * v_dim1 + 1], ldv, &c_b1, &c__[(*k + 1) * c_dim1 + 1], ldc); + } -/* W := W + C2 * V2 */ + /* W := W * V1 */ - i__1 = lastv - *k; - cgemm_("No transpose", "No transpose", &lastc, k, &i__1, & - c_b1, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[*k + 1 - + v_dim1], ldv, &c_b1, &work[work_offset], ldwork); - } + ctrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &c_b1, &v[v_offset], ldv, &work[work_offset], + ldwork); -/* W := W * T or W * T' */ + /* C1 := C1 - W */ - ctrmm_("Right", "Upper", trans, "Non-unit", &lastc, k, &c_b1, - &t[t_offset], ldt, &work[work_offset], ldwork); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = lastc; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * work_dim1; + q__1.r = c__[i__4].r - work[i__5].r, q__1.i = c__[i__4].i - work[i__5].i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + /* L170: */ + } + /* L180: */ + } + } -/* C := C - W * V' */ + } else { + /* Let V = ( V1 V2 ) (V2: last K columns) */ + /* where V2 is unit lower triangular. */ - if (lastv > *k) { + if (lsame_(side, "L")) { + /* Form H * C or H' * C where C = ( C1 ) */ + /* ( C2 ) */ -/* C2 := C2 - W * V2' */ + /* Computing MAX */ + i__1 = *k, i__2 = ilaclc_(k, m, &v[v_offset], ldv); + lastv = max(i__1, i__2); + lastc = ilaclc_(&lastv, n, &c__[c_offset], ldc); - i__1 = lastv - *k; - q__1.r = -1.f, q__1.i = -0.f; - cgemm_("No transpose", "Conjugate transpose", &lastc, & - i__1, k, &q__1, &work[work_offset], ldwork, &v[*k - + 1 + v_dim1], ldv, &c_b1, &c__[(*k + 1) * c_dim1 - + 1], ldc); - } + /* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) */ -/* W := W * V1' */ + /* W := C2' */ - ctrmm_("Right", "Lower", "Conjugate transpose", "Unit", & - lastc, k, &c_b1, &v[v_offset], ldv, &work[work_offset] -, ldwork) - ; + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + ccopy_(&lastc, &c__[lastv - *k + j + c_dim1], ldc, &work[j * work_dim1 + 1], &c__1); + clacgv_(&lastc, &work[j * work_dim1 + 1], &c__1); + /* L190: */ + } -/* C1 := C1 - W */ + /* W := W * V2' */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = lastc; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * c_dim1; - i__4 = i__ + j * c_dim1; - i__5 = i__ + j * work_dim1; - q__1.r = c__[i__4].r - work[i__5].r, q__1.i = c__[ - i__4].i - work[i__5].i; - c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; -/* L50: */ - } -/* L60: */ - } - } + ctrmm_("Right", "Lower", "Conjugate transpose", "Unit", &lastc, k, &c_b1, &v[(lastv - *k + 1) * v_dim1 + 1], + ldv, &work[work_offset], ldwork); + if (lastv > *k) { + /* W := W + C1'*V1' */ - } else { + i__1 = lastv - *k; + cgemm_("Conjugate transpose", "Conjugate transpose", &lastc, k, &i__1, &c_b1, &c__[c_offset], ldc, + &v[v_offset], ldv, &c_b1, &work[work_offset], ldwork); + } -/* Let V = ( V1 ) */ -/* ( V2 ) (last K rows) */ -/* where V2 is unit upper triangular. */ + /* W := W * T' or W * T */ - if (lsame_(side, "L")) { + ctrmm_("Right", "Lower", transt, "Non-unit", &lastc, k, &c_b1, &t[t_offset], ldt, &work[work_offset], ldwork); -/* Form H * C or H' * C where C = ( C1 ) */ -/* ( C2 ) */ + /* C := C - V' * W' */ -/* Computing MAX */ - i__1 = *k, i__2 = ilaclr_(m, k, &v[v_offset], ldv); - lastv = max(i__1,i__2); - lastc = ilaclc_(&lastv, n, &c__[c_offset], ldc); + if (lastv > *k) { + /* C1 := C1 - V1' * W' */ -/* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) */ + i__1 = lastv - *k; + q__1.r = -1.f, q__1.i = -0.f; + cgemm_("Conjugate transpose", "Conjugate transpose", &i__1, &lastc, k, &q__1, &v[v_offset], ldv, + &work[work_offset], ldwork, &c_b1, &c__[c_offset], ldc); + } -/* W := C2' */ + /* W := W * V2 */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - ccopy_(&lastc, &c__[lastv - *k + j + c_dim1], ldc, &work[ - j * work_dim1 + 1], &c__1); - clacgv_(&lastc, &work[j * work_dim1 + 1], &c__1); -/* L70: */ - } + ctrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &c_b1, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, + &work[work_offset], ldwork); -/* W := W * V2 */ + /* C2 := C2 - W' */ - ctrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, & - c_b1, &v[lastv - *k + 1 + v_dim1], ldv, &work[ - work_offset], ldwork); - if (lastv > *k) { + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = lastc; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = lastv - *k + j + i__ * c_dim1; + i__4 = lastv - *k + j + i__ * c_dim1; + r_cnjg(&q__2, &work[i__ + j * work_dim1]); + q__1.r = c__[i__4].r - q__2.r, q__1.i = c__[i__4].i - q__2.i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + /* L200: */ + } + /* L210: */ + } -/* W := W + C1'*V1 */ + } else if (lsame_(side, "R")) { + /* Form C * H or C * H' where C = ( C1 C2 ) */ - i__1 = lastv - *k; - cgemm_("Conjugate transpose", "No transpose", &lastc, k, & - i__1, &c_b1, &c__[c_offset], ldc, &v[v_offset], - ldv, &c_b1, &work[work_offset], ldwork); - } + /* Computing MAX */ + i__1 = *k, i__2 = ilaclc_(k, n, &v[v_offset], ldv); + lastv = max(i__1, i__2); + lastc = ilaclr_(m, &lastv, &c__[c_offset], ldc); -/* W := W * T' or W * T */ + /* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) */ - ctrmm_("Right", "Lower", transt, "Non-unit", &lastc, k, &c_b1, - &t[t_offset], ldt, &work[work_offset], ldwork); + /* W := C2 */ -/* C := C - V * W' */ + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + ccopy_(&lastc, &c__[(lastv - *k + j) * c_dim1 + 1], &c__1, &work[j * work_dim1 + 1], &c__1); + /* L220: */ + } - if (lastv > *k) { + /* W := W * V2' */ -/* C1 := C1 - V1 * W' */ + ctrmm_("Right", "Lower", "Conjugate transpose", "Unit", &lastc, k, &c_b1, &v[(lastv - *k + 1) * v_dim1 + 1], + ldv, &work[work_offset], ldwork); + if (lastv > *k) { + /* W := W + C1 * V1' */ - i__1 = lastv - *k; - q__1.r = -1.f, q__1.i = -0.f; - cgemm_("No transpose", "Conjugate transpose", &i__1, & - lastc, k, &q__1, &v[v_offset], ldv, &work[ - work_offset], ldwork, &c_b1, &c__[c_offset], ldc); - } + i__1 = lastv - *k; + cgemm_("No transpose", "Conjugate transpose", &lastc, k, &i__1, &c_b1, &c__[c_offset], ldc, &v[v_offset], ldv, + &c_b1, &work[work_offset], ldwork); + } -/* W := W * V2' */ + /* W := W * T or W * T' */ - ctrmm_("Right", "Upper", "Conjugate transpose", "Unit", & - lastc, k, &c_b1, &v[lastv - *k + 1 + v_dim1], ldv, & - work[work_offset], ldwork); + ctrmm_("Right", "Lower", trans, "Non-unit", &lastc, k, &c_b1, &t[t_offset], ldt, &work[work_offset], ldwork); -/* C2 := C2 - W' */ + /* C := C - W * V */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = lastc; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = lastv - *k + j + i__ * c_dim1; - i__4 = lastv - *k + j + i__ * c_dim1; - r_cnjg(&q__2, &work[i__ + j * work_dim1]); - q__1.r = c__[i__4].r - q__2.r, q__1.i = c__[i__4].i - - q__2.i; - c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; -/* L80: */ - } -/* L90: */ - } + if (lastv > *k) { + /* C1 := C1 - W * V1 */ - } else if (lsame_(side, "R")) { + i__1 = lastv - *k; + q__1.r = -1.f, q__1.i = -0.f; + cgemm_("No transpose", "No transpose", &lastc, &i__1, k, &q__1, &work[work_offset], ldwork, &v[v_offset], ldv, + &c_b1, &c__[c_offset], ldc); + } -/* Form C * H or C * H' where C = ( C1 C2 ) */ + /* W := W * V2 */ -/* Computing MAX */ - i__1 = *k, i__2 = ilaclr_(n, k, &v[v_offset], ldv); - lastv = max(i__1,i__2); - lastc = ilaclr_(m, &lastv, &c__[c_offset], ldc); + ctrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &c_b1, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, + &work[work_offset], ldwork); -/* W := C * V = (C1*V1 + C2*V2) (stored in WORK) */ + /* C1 := C1 - W */ -/* W := C2 */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - ccopy_(&lastc, &c__[(lastv - *k + j) * c_dim1 + 1], &c__1, - &work[j * work_dim1 + 1], &c__1); -/* L100: */ - } - -/* W := W * V2 */ - - ctrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, & - c_b1, &v[lastv - *k + 1 + v_dim1], ldv, &work[ - work_offset], ldwork); - if (lastv > *k) { - -/* W := W + C1 * V1 */ - - i__1 = lastv - *k; - cgemm_("No transpose", "No transpose", &lastc, k, &i__1, & - c_b1, &c__[c_offset], ldc, &v[v_offset], ldv, & - c_b1, &work[work_offset], ldwork); - } - -/* W := W * T or W * T' */ - - ctrmm_("Right", "Lower", trans, "Non-unit", &lastc, k, &c_b1, - &t[t_offset], ldt, &work[work_offset], ldwork); - -/* C := C - W * V' */ - - if (lastv > *k) { - -/* C1 := C1 - W * V1' */ - - i__1 = lastv - *k; - q__1.r = -1.f, q__1.i = -0.f; - cgemm_("No transpose", "Conjugate transpose", &lastc, & - i__1, k, &q__1, &work[work_offset], ldwork, &v[ - v_offset], ldv, &c_b1, &c__[c_offset], ldc); - } - -/* W := W * V2' */ - - ctrmm_("Right", "Upper", "Conjugate transpose", "Unit", & - lastc, k, &c_b1, &v[lastv - *k + 1 + v_dim1], ldv, & - work[work_offset], ldwork); - -/* C2 := C2 - W */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = lastc; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + (lastv - *k + j) * c_dim1; - i__4 = i__ + (lastv - *k + j) * c_dim1; - i__5 = i__ + j * work_dim1; - q__1.r = c__[i__4].r - work[i__5].r, q__1.i = c__[ - i__4].i - work[i__5].i; - c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; -/* L110: */ - } -/* L120: */ - } - } - } - - } else if (lsame_(storev, "R")) { - - if (lsame_(direct, "F")) { - -/* Let V = ( V1 V2 ) (V1: first K columns) */ -/* where V1 is unit upper triangular. */ - - if (lsame_(side, "L")) { - -/* Form H * C or H' * C where C = ( C1 ) */ -/* ( C2 ) */ - -/* Computing MAX */ - i__1 = *k, i__2 = ilaclc_(k, m, &v[v_offset], ldv); - lastv = max(i__1,i__2); - lastc = ilaclc_(&lastv, n, &c__[c_offset], ldc); - -/* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) */ - -/* W := C1' */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - ccopy_(&lastc, &c__[j + c_dim1], ldc, &work[j * work_dim1 - + 1], &c__1); - clacgv_(&lastc, &work[j * work_dim1 + 1], &c__1); -/* L130: */ - } - -/* W := W * V1' */ - - ctrmm_("Right", "Upper", "Conjugate transpose", "Unit", & - lastc, k, &c_b1, &v[v_offset], ldv, &work[work_offset] -, ldwork) - ; - if (lastv > *k) { - -/* W := W + C2'*V2' */ - - i__1 = lastv - *k; - cgemm_("Conjugate transpose", "Conjugate transpose", & - lastc, k, &i__1, &c_b1, &c__[*k + 1 + c_dim1], - ldc, &v[(*k + 1) * v_dim1 + 1], ldv, &c_b1, &work[ - work_offset], ldwork); - } - -/* W := W * T' or W * T */ - - ctrmm_("Right", "Upper", transt, "Non-unit", &lastc, k, &c_b1, - &t[t_offset], ldt, &work[work_offset], ldwork); - -/* C := C - V' * W' */ - - if (lastv > *k) { - -/* C2 := C2 - V2' * W' */ - - i__1 = lastv - *k; - q__1.r = -1.f, q__1.i = -0.f; - cgemm_("Conjugate transpose", "Conjugate transpose", & - i__1, &lastc, k, &q__1, &v[(*k + 1) * v_dim1 + 1], - ldv, &work[work_offset], ldwork, &c_b1, &c__[*k - + 1 + c_dim1], ldc); - } - -/* W := W * V1 */ - - ctrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, & - c_b1, &v[v_offset], ldv, &work[work_offset], ldwork); - -/* C1 := C1 - W' */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = lastc; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = j + i__ * c_dim1; - i__4 = j + i__ * c_dim1; - r_cnjg(&q__2, &work[i__ + j * work_dim1]); - q__1.r = c__[i__4].r - q__2.r, q__1.i = c__[i__4].i - - q__2.i; - c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; -/* L140: */ - } -/* L150: */ - } - - } else if (lsame_(side, "R")) { - -/* Form C * H or C * H' where C = ( C1 C2 ) */ - -/* Computing MAX */ - i__1 = *k, i__2 = ilaclc_(k, n, &v[v_offset], ldv); - lastv = max(i__1,i__2); - lastc = ilaclr_(m, &lastv, &c__[c_offset], ldc); - -/* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) */ - -/* W := C1 */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - ccopy_(&lastc, &c__[j * c_dim1 + 1], &c__1, &work[j * - work_dim1 + 1], &c__1); -/* L160: */ - } - -/* W := W * V1' */ - - ctrmm_("Right", "Upper", "Conjugate transpose", "Unit", & - lastc, k, &c_b1, &v[v_offset], ldv, &work[work_offset] -, ldwork) - ; - if (lastv > *k) { - -/* W := W + C2 * V2' */ - - i__1 = lastv - *k; - cgemm_("No transpose", "Conjugate transpose", &lastc, k, & - i__1, &c_b1, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[ - (*k + 1) * v_dim1 + 1], ldv, &c_b1, &work[ - work_offset], ldwork); - } - -/* W := W * T or W * T' */ - - ctrmm_("Right", "Upper", trans, "Non-unit", &lastc, k, &c_b1, - &t[t_offset], ldt, &work[work_offset], ldwork); - -/* C := C - W * V */ - - if (lastv > *k) { - -/* C2 := C2 - W * V2 */ - - i__1 = lastv - *k; - q__1.r = -1.f, q__1.i = -0.f; - cgemm_("No transpose", "No transpose", &lastc, &i__1, k, & - q__1, &work[work_offset], ldwork, &v[(*k + 1) * - v_dim1 + 1], ldv, &c_b1, &c__[(*k + 1) * c_dim1 + - 1], ldc); - } - -/* W := W * V1 */ - - ctrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, & - c_b1, &v[v_offset], ldv, &work[work_offset], ldwork); - -/* C1 := C1 - W */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = lastc; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * c_dim1; - i__4 = i__ + j * c_dim1; - i__5 = i__ + j * work_dim1; - q__1.r = c__[i__4].r - work[i__5].r, q__1.i = c__[ - i__4].i - work[i__5].i; - c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; -/* L170: */ - } -/* L180: */ - } - - } - - } else { - -/* Let V = ( V1 V2 ) (V2: last K columns) */ -/* where V2 is unit lower triangular. */ - - if (lsame_(side, "L")) { - -/* Form H * C or H' * C where C = ( C1 ) */ -/* ( C2 ) */ - -/* Computing MAX */ - i__1 = *k, i__2 = ilaclc_(k, m, &v[v_offset], ldv); - lastv = max(i__1,i__2); - lastc = ilaclc_(&lastv, n, &c__[c_offset], ldc); - -/* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) */ - -/* W := C2' */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - ccopy_(&lastc, &c__[lastv - *k + j + c_dim1], ldc, &work[ - j * work_dim1 + 1], &c__1); - clacgv_(&lastc, &work[j * work_dim1 + 1], &c__1); -/* L190: */ - } - -/* W := W * V2' */ - - ctrmm_("Right", "Lower", "Conjugate transpose", "Unit", & - lastc, k, &c_b1, &v[(lastv - *k + 1) * v_dim1 + 1], - ldv, &work[work_offset], ldwork); - if (lastv > *k) { - -/* W := W + C1'*V1' */ - - i__1 = lastv - *k; - cgemm_("Conjugate transpose", "Conjugate transpose", & - lastc, k, &i__1, &c_b1, &c__[c_offset], ldc, &v[ - v_offset], ldv, &c_b1, &work[work_offset], ldwork); - } - -/* W := W * T' or W * T */ - - ctrmm_("Right", "Lower", transt, "Non-unit", &lastc, k, &c_b1, - &t[t_offset], ldt, &work[work_offset], ldwork); - -/* C := C - V' * W' */ - - if (lastv > *k) { - -/* C1 := C1 - V1' * W' */ - - i__1 = lastv - *k; - q__1.r = -1.f, q__1.i = -0.f; - cgemm_("Conjugate transpose", "Conjugate transpose", & - i__1, &lastc, k, &q__1, &v[v_offset], ldv, &work[ - work_offset], ldwork, &c_b1, &c__[c_offset], ldc); - } - -/* W := W * V2 */ - - ctrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, & - c_b1, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[ - work_offset], ldwork); - -/* C2 := C2 - W' */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = lastc; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = lastv - *k + j + i__ * c_dim1; - i__4 = lastv - *k + j + i__ * c_dim1; - r_cnjg(&q__2, &work[i__ + j * work_dim1]); - q__1.r = c__[i__4].r - q__2.r, q__1.i = c__[i__4].i - - q__2.i; - c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; -/* L200: */ - } -/* L210: */ - } - - } else if (lsame_(side, "R")) { - -/* Form C * H or C * H' where C = ( C1 C2 ) */ - -/* Computing MAX */ - i__1 = *k, i__2 = ilaclc_(k, n, &v[v_offset], ldv); - lastv = max(i__1,i__2); - lastc = ilaclr_(m, &lastv, &c__[c_offset], ldc); - -/* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) */ - -/* W := C2 */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - ccopy_(&lastc, &c__[(lastv - *k + j) * c_dim1 + 1], &c__1, - &work[j * work_dim1 + 1], &c__1); -/* L220: */ - } - -/* W := W * V2' */ - - ctrmm_("Right", "Lower", "Conjugate transpose", "Unit", & - lastc, k, &c_b1, &v[(lastv - *k + 1) * v_dim1 + 1], - ldv, &work[work_offset], ldwork); - if (lastv > *k) { - -/* W := W + C1 * V1' */ - - i__1 = lastv - *k; - cgemm_("No transpose", "Conjugate transpose", &lastc, k, & - i__1, &c_b1, &c__[c_offset], ldc, &v[v_offset], - ldv, &c_b1, &work[work_offset], ldwork); - } - -/* W := W * T or W * T' */ - - ctrmm_("Right", "Lower", trans, "Non-unit", &lastc, k, &c_b1, - &t[t_offset], ldt, &work[work_offset], ldwork); - -/* C := C - W * V */ - - if (lastv > *k) { - -/* C1 := C1 - W * V1 */ - - i__1 = lastv - *k; - q__1.r = -1.f, q__1.i = -0.f; - cgemm_("No transpose", "No transpose", &lastc, &i__1, k, & - q__1, &work[work_offset], ldwork, &v[v_offset], - ldv, &c_b1, &c__[c_offset], ldc); - } - -/* W := W * V2 */ - - ctrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, & - c_b1, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[ - work_offset], ldwork); - -/* C1 := C1 - W */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = lastc; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + (lastv - *k + j) * c_dim1; - i__4 = i__ + (lastv - *k + j) * c_dim1; - i__5 = i__ + j * work_dim1; - q__1.r = c__[i__4].r - work[i__5].r, q__1.i = c__[ - i__4].i - work[i__5].i; - c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; -/* L230: */ - } -/* L240: */ - } - - } - - } + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = lastc; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + (lastv - *k + j) * c_dim1; + i__4 = i__ + (lastv - *k + j) * c_dim1; + i__5 = i__ + j * work_dim1; + q__1.r = c__[i__4].r - work[i__5].r, q__1.i = c__[i__4].i - work[i__5].i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + /* L230: */ + } + /* L240: */ + } + } } + } - return 0; - -/* End of CLARFB */ + /* End of CLARFB */ } /* clarfb_ */
diff --git a/lapack/clarfg.c b/lapack/clarfg.c index 2a2c3eb..69bfd94 100644 --- a/lapack/clarfg.c +++ b/lapack/clarfg.c
@@ -1,190 +1,182 @@ /* clarfg.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., + 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 + http://www.netlib.org/f2c/libf2c.zip */ -#include "f2c.h" #include "blaswrap.h" +#include "lapack_datatypes.h" + +static inline real r_sign(real *a, real *b) { + real x; + x = (*a >= 0 ? *a : -*a); + return (*b >= 0 ? x : -x); +} /* Table of constant values */ -static complex c_b5 = {1.f,0.f}; +static complex c_b5 = {1.f, 0.f}; -/* Subroutine */ int clarfg_(integer *n, complex *alpha, complex *x, integer * - incx, complex *tau) -{ - /* System generated locals */ - integer i__1; - real r__1, r__2; - complex q__1, q__2; +/* Subroutine */ void clarfg_(integer *n, complex *alpha, complex *x, integer *incx, complex *tau) { + /* System generated locals */ + integer i__1; + real r__1, r__2; + complex q__1, q__2; - /* Builtin functions */ - double r_imag(complex *), r_sign(real *, real *); + /* Local variables */ + integer j, knt; + real beta; + extern /* Subroutine */ void cscal_(integer *, complex *, complex *, integer *); + real alphi, alphr, xnorm; + extern real scnrm2_(integer *, complex *, integer *), slapy3_(real *, real *, real *); + extern /* Complex */ void cladiv_(complex *, complex *, complex *); + extern doublereal slamch_(char *); + extern /* Subroutine */ void csscal_(integer *, real *, complex *, integer *); + real safmin, rsafmn; - /* Local variables */ - integer j, knt; - real beta; - extern /* Subroutine */ int cscal_(integer *, complex *, complex *, - integer *); - real alphi, alphr, xnorm; - extern doublereal scnrm2_(integer *, complex *, integer *), slapy3_(real * -, real *, real *); - extern /* Complex */ VOID cladiv_(complex *, complex *, complex *); - extern doublereal slamch_(char *); - extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer - *); - real safmin, rsafmn; + /* -- LAPACK auxiliary routine (version 3.2) -- */ + /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ + /* November 2006 */ + /* .. Scalar Arguments .. */ + /* .. */ + /* .. Array Arguments .. */ + /* .. */ -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ + /* Purpose */ + /* ======= */ -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ + /* CLARFG generates a complex elementary reflector H of order n, such */ + /* that */ -/* Purpose */ -/* ======= */ + /* H' * ( alpha ) = ( beta ), H' * H = I. */ + /* ( x ) ( 0 ) */ -/* CLARFG generates a complex elementary reflector H of order n, such */ -/* that */ + /* where alpha and beta are scalars, with beta real, and x is an */ + /* (n-1)-element complex vector. H is represented in the form */ -/* H' * ( alpha ) = ( beta ), H' * H = I. */ -/* ( x ) ( 0 ) */ + /* H = I - tau * ( 1 ) * ( 1 v' ) , */ + /* ( v ) */ -/* where alpha and beta are scalars, with beta real, and x is an */ -/* (n-1)-element complex vector. H is represented in the form */ + /* where tau is a complex scalar and v is a complex (n-1)-element */ + /* vector. Note that H is not hermitian. */ -/* H = I - tau * ( 1 ) * ( 1 v' ) , */ -/* ( v ) */ + /* If the elements of x are all zero and alpha is real, then tau = 0 */ + /* and H is taken to be the unit matrix. */ -/* where tau is a complex scalar and v is a complex (n-1)-element */ -/* vector. Note that H is not hermitian. */ + /* Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 . */ -/* If the elements of x are all zero and alpha is real, then tau = 0 */ -/* and H is taken to be the unit matrix. */ + /* Arguments */ + /* ========= */ -/* Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 . */ + /* N (input) INTEGER */ + /* The order of the elementary reflector. */ -/* Arguments */ -/* ========= */ + /* ALPHA (input/output) COMPLEX */ + /* On entry, the value alpha. */ + /* On exit, it is overwritten with the value beta. */ -/* N (input) INTEGER */ -/* The order of the elementary reflector. */ + /* X (input/output) COMPLEX array, dimension */ + /* (1+(N-2)*abs(INCX)) */ + /* On entry, the vector x. */ + /* On exit, it is overwritten with the vector v. */ -/* ALPHA (input/output) COMPLEX */ -/* On entry, the value alpha. */ -/* On exit, it is overwritten with the value beta. */ + /* INCX (input) INTEGER */ + /* The increment between elements of X. INCX > 0. */ -/* X (input/output) COMPLEX array, dimension */ -/* (1+(N-2)*abs(INCX)) */ -/* On entry, the vector x. */ -/* On exit, it is overwritten with the vector v. */ + /* TAU (output) COMPLEX */ + /* The value tau. */ -/* INCX (input) INTEGER */ -/* The increment between elements of X. INCX > 0. */ + /* ===================================================================== */ -/* TAU (output) COMPLEX */ -/* The value tau. */ + /* .. Parameters .. */ + /* .. */ + /* .. Local Scalars .. */ + /* .. */ + /* .. External Functions .. */ + /* .. */ + /* .. Intrinsic Functions .. */ + /* .. */ + /* .. External Subroutines .. */ + /* .. */ + /* .. Executable Statements .. */ -/* ===================================================================== */ + /* Parameter adjustments */ + --x; -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Executable Statements .. */ + /* Function Body */ + if (*n <= 0) { + tau->r = 0.f, tau->i = 0.f; + return; + } - /* Parameter adjustments */ - --x; + i__1 = *n - 1; + xnorm = scnrm2_(&i__1, &x[1], incx); + alphr = alpha->r; + alphi = alpha->i; - /* Function Body */ - if (*n <= 0) { - tau->r = 0.f, tau->i = 0.f; - return 0; + if (xnorm == 0.f && alphi == 0.f) { + /* H = I */ + + tau->r = 0.f, tau->i = 0.f; + } else { + /* general case */ + + r__1 = slapy3_(&alphr, &alphi, &xnorm); + beta = -r_sign(&r__1, &alphr); + safmin = slamch_("S") / slamch_("E"); + rsafmn = 1.f / safmin; + + knt = 0; + if (dabs(beta) < safmin) { + /* XNORM, BETA may be inaccurate; scale X and recompute them */ + + L10: + ++knt; + i__1 = *n - 1; + csscal_(&i__1, &rsafmn, &x[1], incx); + beta *= rsafmn; + alphi *= rsafmn; + alphr *= rsafmn; + if (dabs(beta) < safmin) { + goto L10; + } + + /* New BETA is at most 1, at least SAFMIN */ + + i__1 = *n - 1; + xnorm = scnrm2_(&i__1, &x[1], incx); + q__1.r = alphr, q__1.i = alphi; + alpha->r = q__1.r, alpha->i = q__1.i; + r__1 = slapy3_(&alphr, &alphi, &xnorm); + beta = -r_sign(&r__1, &alphr); } - + r__1 = (beta - alphr) / beta; + r__2 = -alphi / beta; + q__1.r = r__1, q__1.i = r__2; + tau->r = q__1.r, tau->i = q__1.i; + q__2.r = alpha->r - beta, q__2.i = alpha->i; + cladiv_(&q__1, &c_b5, &q__2); + alpha->r = q__1.r, alpha->i = q__1.i; i__1 = *n - 1; - xnorm = scnrm2_(&i__1, &x[1], incx); - alphr = alpha->r; - alphi = r_imag(alpha); + cscal_(&i__1, alpha, &x[1], incx); - if (xnorm == 0.f && alphi == 0.f) { + /* If ALPHA is subnormal, it may lose relative accuracy */ -/* H = I */ - - tau->r = 0.f, tau->i = 0.f; - } else { - -/* general case */ - - r__1 = slapy3_(&alphr, &alphi, &xnorm); - beta = -r_sign(&r__1, &alphr); - safmin = slamch_("S") / slamch_("E"); - rsafmn = 1.f / safmin; - - knt = 0; - if (dabs(beta) < safmin) { - -/* XNORM, BETA may be inaccurate; scale X and recompute them */ - -L10: - ++knt; - i__1 = *n - 1; - csscal_(&i__1, &rsafmn, &x[1], incx); - beta *= rsafmn; - alphi *= rsafmn; - alphr *= rsafmn; - if (dabs(beta) < safmin) { - goto L10; - } - -/* New BETA is at most 1, at least SAFMIN */ - - i__1 = *n - 1; - xnorm = scnrm2_(&i__1, &x[1], incx); - q__1.r = alphr, q__1.i = alphi; - alpha->r = q__1.r, alpha->i = q__1.i; - r__1 = slapy3_(&alphr, &alphi, &xnorm); - beta = -r_sign(&r__1, &alphr); - } - r__1 = (beta - alphr) / beta; - r__2 = -alphi / beta; - q__1.r = r__1, q__1.i = r__2; - tau->r = q__1.r, tau->i = q__1.i; - q__2.r = alpha->r - beta, q__2.i = alpha->i; - cladiv_(&q__1, &c_b5, &q__2); - alpha->r = q__1.r, alpha->i = q__1.i; - i__1 = *n - 1; - cscal_(&i__1, alpha, &x[1], incx); - -/* If ALPHA is subnormal, it may lose relative accuracy */ - - i__1 = knt; - for (j = 1; j <= i__1; ++j) { - beta *= safmin; -/* L20: */ - } - alpha->r = beta, alpha->i = 0.f; + i__1 = knt; + for (j = 1; j <= i__1; ++j) { + beta *= safmin; + /* L20: */ } + alpha->r = beta, alpha->i = 0.f; + } - return 0; - -/* End of CLARFG */ + /* End of CLARFG */ } /* clarfg_ */
diff --git a/lapack/clarft.c b/lapack/clarft.c index ca573e4..3a5efd5 100644 --- a/lapack/clarft.c +++ b/lapack/clarft.c
@@ -1,361 +1,347 @@ /* clarft.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., + 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 + http://www.netlib.org/f2c/libf2c.zip */ -#include "f2c.h" #include "blaswrap.h" +#include "lapack_datatypes.h" /* Table of constant values */ -static complex c_b2 = {0.f,0.f}; +static complex c_b2 = {0.f, 0.f}; static integer c__1 = 1; -/* Subroutine */ int clarft_(char *direct, char *storev, integer *n, integer * - k, complex *v, integer *ldv, complex *tau, complex *t, integer *ldt) -{ - /* System generated locals */ - integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4; - complex q__1; +/* Subroutine */ void clarft_(char *direct, char *storev, integer *n, integer *k, complex *v, integer *ldv, + complex *tau, complex *t, integer *ldt) { + /* System generated locals */ + integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4; + complex q__1; - /* Local variables */ - integer i__, j, prevlastv; - complex vii; - extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex * -, complex *, integer *, complex *, integer *, complex *, complex * -, integer *); - extern logical lsame_(char *, char *); - integer lastv; - extern /* Subroutine */ int ctrmv_(char *, char *, char *, integer *, - complex *, integer *, complex *, integer *), clacgv_(integer *, complex *, integer *); + /* Local variables */ + integer i__, j, prevlastv; + complex vii; + extern /* Subroutine */ void 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 lastv; + extern /* Subroutine */ void ctrmv_(const char *, const char *, const char *, const integer *, const complex *, + const integer *, complex *, const integer *), + clacgv_(integer *, complex *, integer *); + /* -- LAPACK auxiliary routine (version 3.2) -- */ + /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ + /* November 2006 */ -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ + /* .. Scalar Arguments .. */ + /* .. */ + /* .. Array Arguments .. */ + /* .. */ -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ + /* Purpose */ + /* ======= */ -/* Purpose */ -/* ======= */ + /* CLARFT forms the triangular factor T of a complex block reflector H */ + /* of order n, which is defined as a product of k elementary reflectors. */ -/* CLARFT forms the triangular factor T of a complex block reflector H */ -/* of order n, which is defined as a product of k elementary reflectors. */ + /* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; */ -/* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; */ + /* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. */ -/* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. */ + /* If STOREV = 'C', the vector which defines the elementary reflector */ + /* H(i) is stored in the i-th column of the array V, and */ -/* If STOREV = 'C', the vector which defines the elementary reflector */ -/* H(i) is stored in the i-th column of the array V, and */ + /* H = I - V * T * V' */ -/* H = I - V * T * V' */ + /* If STOREV = 'R', the vector which defines the elementary reflector */ + /* H(i) is stored in the i-th row of the array V, and */ -/* If STOREV = 'R', the vector which defines the elementary reflector */ -/* H(i) is stored in the i-th row of the array V, and */ + /* H = I - V' * T * V */ -/* H = I - V' * T * V */ + /* Arguments */ + /* ========= */ -/* Arguments */ -/* ========= */ + /* DIRECT (input) CHARACTER*1 */ + /* Specifies the order in which the elementary reflectors are */ + /* multiplied to form the block reflector: */ + /* = 'F': H = H(1) H(2) . . . H(k) (Forward) */ + /* = 'B': H = H(k) . . . H(2) H(1) (Backward) */ -/* DIRECT (input) CHARACTER*1 */ -/* Specifies the order in which the elementary reflectors are */ -/* multiplied to form the block reflector: */ -/* = 'F': H = H(1) H(2) . . . H(k) (Forward) */ -/* = 'B': H = H(k) . . . H(2) H(1) (Backward) */ + /* STOREV (input) CHARACTER*1 */ + /* Specifies how the vectors which define the elementary */ + /* reflectors are stored (see also Further Details): */ + /* = 'C': columnwise */ + /* = 'R': rowwise */ -/* STOREV (input) CHARACTER*1 */ -/* Specifies how the vectors which define the elementary */ -/* reflectors are stored (see also Further Details): */ -/* = 'C': columnwise */ -/* = 'R': rowwise */ + /* N (input) INTEGER */ + /* The order of the block reflector H. N >= 0. */ -/* N (input) INTEGER */ -/* The order of the block reflector H. N >= 0. */ + /* K (input) INTEGER */ + /* The order of the triangular factor T (= the number of */ + /* elementary reflectors). K >= 1. */ -/* K (input) INTEGER */ -/* The order of the triangular factor T (= the number of */ -/* elementary reflectors). K >= 1. */ + /* V (input/output) COMPLEX array, dimension */ + /* (LDV,K) if STOREV = 'C' */ + /* (LDV,N) if STOREV = 'R' */ + /* The matrix V. See further details. */ -/* V (input/output) COMPLEX array, dimension */ -/* (LDV,K) if STOREV = 'C' */ -/* (LDV,N) if STOREV = 'R' */ -/* The matrix V. See further details. */ + /* LDV (input) INTEGER */ + /* The leading dimension of the array V. */ + /* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. */ -/* LDV (input) INTEGER */ -/* The leading dimension of the array V. */ -/* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. */ + /* TAU (input) COMPLEX array, dimension (K) */ + /* TAU(i) must contain the scalar factor of the elementary */ + /* reflector H(i). */ -/* TAU (input) COMPLEX array, dimension (K) */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i). */ + /* T (output) COMPLEX array, dimension (LDT,K) */ + /* The k by k triangular factor T of the block reflector. */ + /* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is */ + /* lower triangular. The rest of the array is not used. */ -/* T (output) COMPLEX array, dimension (LDT,K) */ -/* The k by k triangular factor T of the block reflector. */ -/* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is */ -/* lower triangular. The rest of the array is not used. */ + /* LDT (input) INTEGER */ + /* The leading dimension of the array T. LDT >= K. */ -/* LDT (input) INTEGER */ -/* The leading dimension of the array T. LDT >= K. */ + /* Further Details */ + /* =============== */ -/* Further Details */ -/* =============== */ + /* The shape of the matrix V and the storage of the vectors which define */ + /* the H(i) is best illustrated by the following example with n = 5 and */ + /* k = 3. The elements equal to 1 are not stored; the corresponding */ + /* array elements are modified but restored on exit. The rest of the */ + /* array is not used. */ -/* The shape of the matrix V and the storage of the vectors which define */ -/* the H(i) is best illustrated by the following example with n = 5 and */ -/* k = 3. The elements equal to 1 are not stored; the corresponding */ -/* array elements are modified but restored on exit. The rest of the */ -/* array is not used. */ + /* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': */ -/* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': */ + /* V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) */ + /* ( v1 1 ) ( 1 v2 v2 v2 ) */ + /* ( v1 v2 1 ) ( 1 v3 v3 ) */ + /* ( v1 v2 v3 ) */ + /* ( v1 v2 v3 ) */ -/* V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) */ -/* ( v1 1 ) ( 1 v2 v2 v2 ) */ -/* ( v1 v2 1 ) ( 1 v3 v3 ) */ -/* ( v1 v2 v3 ) */ -/* ( v1 v2 v3 ) */ + /* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': */ -/* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': */ + /* V = ( v1 v2 v3 ) V = ( v1 v1 1 ) */ + /* ( v1 v2 v3 ) ( v2 v2 v2 1 ) */ + /* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) */ + /* ( 1 v3 ) */ + /* ( 1 ) */ -/* V = ( v1 v2 v3 ) V = ( v1 v1 1 ) */ -/* ( v1 v2 v3 ) ( v2 v2 v2 1 ) */ -/* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) */ -/* ( 1 v3 ) */ -/* ( 1 ) */ + /* ===================================================================== */ -/* ===================================================================== */ + /* .. Parameters .. */ + /* .. */ + /* .. Local Scalars .. */ + /* .. */ + /* .. External Subroutines .. */ + /* .. */ + /* .. External Functions .. */ + /* .. */ + /* .. Executable Statements .. */ -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ + /* Quick return if possible */ -/* Quick return if possible */ + /* Parameter adjustments */ + v_dim1 = *ldv; + v_offset = 1 + v_dim1; + v -= v_offset; + --tau; + t_dim1 = *ldt; + t_offset = 1 + t_dim1; + t -= t_offset; - /* Parameter adjustments */ - v_dim1 = *ldv; - v_offset = 1 + v_dim1; - v -= v_offset; - --tau; - t_dim1 = *ldt; - t_offset = 1 + t_dim1; - t -= t_offset; + /* Function Body */ + if (*n == 0) { + return; + } - /* Function Body */ - if (*n == 0) { - return 0; + if (lsame_(direct, "F")) { + prevlastv = *n; + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + prevlastv = max(prevlastv, i__); + i__2 = i__; + if (tau[i__2].r == 0.f && tau[i__2].i == 0.f) { + /* H(i) = I */ + + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + i__3 = j + i__ * t_dim1; + t[i__3].r = 0.f, t[i__3].i = 0.f; + /* L10: */ + } + } else { + /* general case */ + + i__2 = i__ + i__ * v_dim1; + vii.r = v[i__2].r, vii.i = v[i__2].i; + i__2 = i__ + i__ * v_dim1; + v[i__2].r = 1.f, v[i__2].i = 0.f; + if (lsame_(storev, "C")) { + /* Skip any trailing zeros. */ + i__2 = i__ + 1; + for (lastv = *n; lastv >= i__2; --lastv) { + i__3 = lastv + i__ * v_dim1; + if (v[i__3].r != 0.f || v[i__3].i != 0.f) { + break; + } + } + j = min(lastv, prevlastv); + + /* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)' * V(i:j,i) */ + + i__2 = j - i__ + 1; + i__3 = i__ - 1; + i__4 = i__; + q__1.r = -tau[i__4].r, q__1.i = -tau[i__4].i; + cgemv_("Conjugate transpose", &i__2, &i__3, &q__1, &v[i__ + v_dim1], ldv, &v[i__ + i__ * v_dim1], &c__1, + &c_b2, &t[i__ * t_dim1 + 1], &c__1); + } else { + /* Skip any trailing zeros. */ + i__2 = i__ + 1; + for (lastv = *n; lastv >= i__2; --lastv) { + i__3 = i__ + lastv * v_dim1; + if (v[i__3].r != 0.f || v[i__3].i != 0.f) { + break; + } + } + j = min(lastv, prevlastv); + + /* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)' */ + + if (i__ < j) { + i__2 = j - i__; + clacgv_(&i__2, &v[i__ + (i__ + 1) * v_dim1], ldv); + } + i__2 = i__ - 1; + i__3 = j - i__ + 1; + i__4 = i__; + q__1.r = -tau[i__4].r, q__1.i = -tau[i__4].i; + cgemv_("No transpose", &i__2, &i__3, &q__1, &v[i__ * v_dim1 + 1], ldv, &v[i__ + i__ * v_dim1], ldv, &c_b2, + &t[i__ * t_dim1 + 1], &c__1); + if (i__ < j) { + i__2 = j - i__; + clacgv_(&i__2, &v[i__ + (i__ + 1) * v_dim1], ldv); + } + } + i__2 = i__ + i__ * v_dim1; + v[i__2].r = vii.r, v[i__2].i = vii.i; + + /* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) */ + + i__2 = i__ - 1; + ctrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[t_offset], ldt, &t[i__ * t_dim1 + 1], &c__1); + i__2 = i__ + i__ * t_dim1; + i__3 = i__; + t[i__2].r = tau[i__3].r, t[i__2].i = tau[i__3].i; + if (i__ > 1) { + prevlastv = max(prevlastv, lastv); + } else { + prevlastv = lastv; + } + } + /* L20: */ } + } else { + prevlastv = 1; + for (i__ = *k; i__ >= 1; --i__) { + i__1 = i__; + if (tau[i__1].r == 0.f && tau[i__1].i == 0.f) { + /* H(i) = I */ - if (lsame_(direct, "F")) { - prevlastv = *n; - i__1 = *k; - for (i__ = 1; i__ <= i__1; ++i__) { - prevlastv = max(prevlastv,i__); - i__2 = i__; - if (tau[i__2].r == 0.f && tau[i__2].i == 0.f) { + i__1 = *k; + for (j = i__; j <= i__1; ++j) { + i__2 = j + i__ * t_dim1; + t[i__2].r = 0.f, t[i__2].i = 0.f; + /* L30: */ + } + } else { + /* general case */ -/* H(i) = I */ + if (i__ < *k) { + if (lsame_(storev, "C")) { + i__1 = *n - *k + i__ + i__ * v_dim1; + vii.r = v[i__1].r, vii.i = v[i__1].i; + i__1 = *n - *k + i__ + i__ * v_dim1; + v[i__1].r = 1.f, v[i__1].i = 0.f; + /* Skip any leading zeros. */ + i__1 = i__ - 1; + for (lastv = 1; lastv <= i__1; ++lastv) { + i__2 = lastv + i__ * v_dim1; + if (v[i__2].r != 0.f || v[i__2].i != 0.f) { + break; + } + } + j = max(lastv, prevlastv); - i__2 = i__; - for (j = 1; j <= i__2; ++j) { - i__3 = j + i__ * t_dim1; - t[i__3].r = 0.f, t[i__3].i = 0.f; -/* L10: */ - } - } else { + /* T(i+1:k,i) := */ + /* - tau(i) * V(j:n-k+i,i+1:k)' * V(j:n-k+i,i) */ -/* general case */ + i__1 = *n - *k + i__ - j + 1; + i__2 = *k - i__; + i__3 = i__; + q__1.r = -tau[i__3].r, q__1.i = -tau[i__3].i; + cgemv_("Conjugate transpose", &i__1, &i__2, &q__1, &v[j + (i__ + 1) * v_dim1], ldv, &v[j + i__ * v_dim1], + &c__1, &c_b2, &t[i__ + 1 + i__ * t_dim1], &c__1); + i__1 = *n - *k + i__ + i__ * v_dim1; + v[i__1].r = vii.r, v[i__1].i = vii.i; + } else { + i__1 = i__ + (*n - *k + i__) * v_dim1; + vii.r = v[i__1].r, vii.i = v[i__1].i; + i__1 = i__ + (*n - *k + i__) * v_dim1; + v[i__1].r = 1.f, v[i__1].i = 0.f; + /* Skip any leading zeros. */ + i__1 = i__ - 1; + for (lastv = 1; lastv <= i__1; ++lastv) { + i__2 = i__ + lastv * v_dim1; + if (v[i__2].r != 0.f || v[i__2].i != 0.f) { + break; + } + } + j = max(lastv, prevlastv); - i__2 = i__ + i__ * v_dim1; - vii.r = v[i__2].r, vii.i = v[i__2].i; - i__2 = i__ + i__ * v_dim1; - v[i__2].r = 1.f, v[i__2].i = 0.f; - if (lsame_(storev, "C")) { -/* Skip any trailing zeros. */ - i__2 = i__ + 1; - for (lastv = *n; lastv >= i__2; --lastv) { - i__3 = lastv + i__ * v_dim1; - if (v[i__3].r != 0.f || v[i__3].i != 0.f) { - break; - } - } - j = min(lastv,prevlastv); + /* T(i+1:k,i) := */ + /* - tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)' */ -/* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)' * V(i:j,i) */ + i__1 = *n - *k + i__ - 1 - j + 1; + clacgv_(&i__1, &v[i__ + j * v_dim1], ldv); + i__1 = *k - i__; + i__2 = *n - *k + i__ - j + 1; + i__3 = i__; + q__1.r = -tau[i__3].r, q__1.i = -tau[i__3].i; + cgemv_("No transpose", &i__1, &i__2, &q__1, &v[i__ + 1 + j * v_dim1], ldv, &v[i__ + j * v_dim1], ldv, &c_b2, + &t[i__ + 1 + i__ * t_dim1], &c__1); + i__1 = *n - *k + i__ - 1 - j + 1; + clacgv_(&i__1, &v[i__ + j * v_dim1], ldv); + i__1 = i__ + (*n - *k + i__) * v_dim1; + v[i__1].r = vii.r, v[i__1].i = vii.i; + } - i__2 = j - i__ + 1; - i__3 = i__ - 1; - i__4 = i__; - q__1.r = -tau[i__4].r, q__1.i = -tau[i__4].i; - cgemv_("Conjugate transpose", &i__2, &i__3, &q__1, &v[i__ - + v_dim1], ldv, &v[i__ + i__ * v_dim1], &c__1, & - c_b2, &t[i__ * t_dim1 + 1], &c__1); - } else { -/* Skip any trailing zeros. */ - i__2 = i__ + 1; - for (lastv = *n; lastv >= i__2; --lastv) { - i__3 = i__ + lastv * v_dim1; - if (v[i__3].r != 0.f || v[i__3].i != 0.f) { - break; - } - } - j = min(lastv,prevlastv); + /* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) */ -/* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)' */ - - if (i__ < j) { - i__2 = j - i__; - clacgv_(&i__2, &v[i__ + (i__ + 1) * v_dim1], ldv); - } - i__2 = i__ - 1; - i__3 = j - i__ + 1; - i__4 = i__; - q__1.r = -tau[i__4].r, q__1.i = -tau[i__4].i; - cgemv_("No transpose", &i__2, &i__3, &q__1, &v[i__ * - v_dim1 + 1], ldv, &v[i__ + i__ * v_dim1], ldv, & - c_b2, &t[i__ * t_dim1 + 1], &c__1); - if (i__ < j) { - i__2 = j - i__; - clacgv_(&i__2, &v[i__ + (i__ + 1) * v_dim1], ldv); - } - } - i__2 = i__ + i__ * v_dim1; - v[i__2].r = vii.r, v[i__2].i = vii.i; - -/* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) */ - - i__2 = i__ - 1; - ctrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[ - t_offset], ldt, &t[i__ * t_dim1 + 1], &c__1); - i__2 = i__ + i__ * t_dim1; - i__3 = i__; - t[i__2].r = tau[i__3].r, t[i__2].i = tau[i__3].i; - if (i__ > 1) { - prevlastv = max(prevlastv,lastv); - } else { - prevlastv = lastv; - } - } -/* L20: */ - } - } else { - prevlastv = 1; - for (i__ = *k; i__ >= 1; --i__) { - i__1 = i__; - if (tau[i__1].r == 0.f && tau[i__1].i == 0.f) { - -/* H(i) = I */ - - i__1 = *k; - for (j = i__; j <= i__1; ++j) { - i__2 = j + i__ * t_dim1; - t[i__2].r = 0.f, t[i__2].i = 0.f; -/* L30: */ - } - } else { - -/* general case */ - - if (i__ < *k) { - if (lsame_(storev, "C")) { - i__1 = *n - *k + i__ + i__ * v_dim1; - vii.r = v[i__1].r, vii.i = v[i__1].i; - i__1 = *n - *k + i__ + i__ * v_dim1; - v[i__1].r = 1.f, v[i__1].i = 0.f; -/* Skip any leading zeros. */ - i__1 = i__ - 1; - for (lastv = 1; lastv <= i__1; ++lastv) { - i__2 = lastv + i__ * v_dim1; - if (v[i__2].r != 0.f || v[i__2].i != 0.f) { - break; - } - } - j = max(lastv,prevlastv); - -/* T(i+1:k,i) := */ -/* - tau(i) * V(j:n-k+i,i+1:k)' * V(j:n-k+i,i) */ - - i__1 = *n - *k + i__ - j + 1; - i__2 = *k - i__; - i__3 = i__; - q__1.r = -tau[i__3].r, q__1.i = -tau[i__3].i; - cgemv_("Conjugate transpose", &i__1, &i__2, &q__1, &v[ - j + (i__ + 1) * v_dim1], ldv, &v[j + i__ * - v_dim1], &c__1, &c_b2, &t[i__ + 1 + i__ * - t_dim1], &c__1); - i__1 = *n - *k + i__ + i__ * v_dim1; - v[i__1].r = vii.r, v[i__1].i = vii.i; - } else { - i__1 = i__ + (*n - *k + i__) * v_dim1; - vii.r = v[i__1].r, vii.i = v[i__1].i; - i__1 = i__ + (*n - *k + i__) * v_dim1; - v[i__1].r = 1.f, v[i__1].i = 0.f; -/* Skip any leading zeros. */ - i__1 = i__ - 1; - for (lastv = 1; lastv <= i__1; ++lastv) { - i__2 = i__ + lastv * v_dim1; - if (v[i__2].r != 0.f || v[i__2].i != 0.f) { - break; - } - } - j = max(lastv,prevlastv); - -/* T(i+1:k,i) := */ -/* - tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)' */ - - i__1 = *n - *k + i__ - 1 - j + 1; - clacgv_(&i__1, &v[i__ + j * v_dim1], ldv); - i__1 = *k - i__; - i__2 = *n - *k + i__ - j + 1; - i__3 = i__; - q__1.r = -tau[i__3].r, q__1.i = -tau[i__3].i; - cgemv_("No transpose", &i__1, &i__2, &q__1, &v[i__ + - 1 + j * v_dim1], ldv, &v[i__ + j * v_dim1], - ldv, &c_b2, &t[i__ + 1 + i__ * t_dim1], &c__1); - i__1 = *n - *k + i__ - 1 - j + 1; - clacgv_(&i__1, &v[i__ + j * v_dim1], ldv); - i__1 = i__ + (*n - *k + i__) * v_dim1; - v[i__1].r = vii.r, v[i__1].i = vii.i; - } - -/* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) */ - - i__1 = *k - i__; - ctrmv_("Lower", "No transpose", "Non-unit", &i__1, &t[i__ - + 1 + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ * - t_dim1], &c__1) - ; - if (i__ > 1) { - prevlastv = min(prevlastv,lastv); - } else { - prevlastv = lastv; - } - } - i__1 = i__ + i__ * t_dim1; - i__2 = i__; - t[i__1].r = tau[i__2].r, t[i__1].i = tau[i__2].i; - } -/* L40: */ - } + i__1 = *k - i__; + ctrmv_("Lower", "No transpose", "Non-unit", &i__1, &t[i__ + 1 + (i__ + 1) * t_dim1], ldt, + &t[i__ + 1 + i__ * t_dim1], &c__1); + if (i__ > 1) { + prevlastv = min(prevlastv, lastv); + } else { + prevlastv = lastv; + } + } + i__1 = i__ + i__ * t_dim1; + i__2 = i__; + t[i__1].r = tau[i__2].r, t[i__1].i = tau[i__2].i; + } + /* L40: */ } - return 0; + } -/* End of CLARFT */ + /* End of CLARFT */ } /* clarft_ */
diff --git a/lapack/dladiv.c b/lapack/dladiv.c index 20fbe6b..45c0183 100644 --- a/lapack/dladiv.c +++ b/lapack/dladiv.c
@@ -1,78 +1,74 @@ /* dladiv.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., + 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 + http://www.netlib.org/f2c/libf2c.zip */ -#include "f2c.h" #include "blaswrap.h" +#include "lapack_datatypes.h" -/* Subroutine */ int dladiv_(doublereal *a, doublereal *b, doublereal *c__, - doublereal *d__, doublereal *p, doublereal *q) -{ - doublereal e, f; +/* Subroutine */ void dladiv_(doublereal *a, doublereal *b, doublereal *c__, doublereal *d__, doublereal *p, + doublereal *q) { + doublereal e, f; + /* -- LAPACK auxiliary routine (version 3.2) -- */ + /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ + /* November 2006 */ -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ + /* .. Scalar Arguments .. */ + /* .. */ -/* .. Scalar Arguments .. */ -/* .. */ + /* Purpose */ + /* ======= */ -/* Purpose */ -/* ======= */ + /* DLADIV performs complex division in real arithmetic */ -/* DLADIV performs complex division in real arithmetic */ + /* a + i*b */ + /* p + i*q = --------- */ + /* c + i*d */ -/* a + i*b */ -/* p + i*q = --------- */ -/* c + i*d */ + /* The algorithm is due to Robert L. Smith and can be found */ + /* in D. Knuth, The art of Computer Programming, Vol.2, p.195 */ -/* The algorithm is due to Robert L. Smith and can be found */ -/* in D. Knuth, The art of Computer Programming, Vol.2, p.195 */ + /* Arguments */ + /* ========= */ -/* Arguments */ -/* ========= */ + /* A (input) DOUBLE PRECISION */ + /* B (input) DOUBLE PRECISION */ + /* C (input) DOUBLE PRECISION */ + /* D (input) DOUBLE PRECISION */ + /* The scalars a, b, c, and d in the above expression. */ -/* A (input) DOUBLE PRECISION */ -/* B (input) DOUBLE PRECISION */ -/* C (input) DOUBLE PRECISION */ -/* D (input) DOUBLE PRECISION */ -/* The scalars a, b, c, and d in the above expression. */ + /* P (output) DOUBLE PRECISION */ + /* Q (output) DOUBLE PRECISION */ + /* The scalars p and q in the above expression. */ -/* P (output) DOUBLE PRECISION */ -/* Q (output) DOUBLE PRECISION */ -/* The scalars p and q in the above expression. */ + /* ===================================================================== */ -/* ===================================================================== */ + /* .. Local Scalars .. */ + /* .. */ + /* .. Intrinsic Functions .. */ + /* .. */ + /* .. Executable Statements .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ + if (abs(*d__) < abs(*c__)) { + e = *d__ / *c__; + f = *c__ + *d__ * e; + *p = (*a + *b * e) / f; + *q = (*b - *a * e) / f; + } else { + e = *c__ / *d__; + f = *d__ + *c__ * e; + *p = (*b + *a * e) / f; + *q = (-(*a) + *b * e) / f; + } - if (abs(*d__) < abs(*c__)) { - e = *d__ / *c__; - f = *c__ + *d__ * e; - *p = (*a + *b * e) / f; - *q = (*b - *a * e) / f; - } else { - e = *c__ / *d__; - f = *d__ + *c__ * e; - *p = (*b + *a * e) / f; - *q = (-(*a) + *b * e) / f; - } - - return 0; - -/* End of DLADIV */ + /* End of DLADIV */ } /* dladiv_ */
diff --git a/lapack/dlamch.c b/lapack/dlamch.c index e224439..71c4166 100644 --- a/lapack/dlamch.c +++ b/lapack/dlamch.c
@@ -1,1001 +1,992 @@ /* dlamch.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., + 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 + http://www.netlib.org/f2c/libf2c.zip */ -#include "f2c.h" #include "blaswrap.h" +#include "lapack_datatypes.h" /* Table of constant values */ -static integer c__1 = 1; +/* static integer c__1 = 1; */ static doublereal c_b32 = 0.; -doublereal dlamch_(char *cmach) -{ - /* Initialized data */ +static inline doublereal pow_di(doublereal *ap, integer *bp) { + doublereal pow, x; + integer n; + unsigned long u; - static logical first = TRUE_; + pow = 1; + x = *ap; + n = *bp; - /* System generated locals */ - integer i__1; - doublereal ret_val; - - /* Builtin functions */ - double pow_di(doublereal *, integer *); - - /* Local variables */ - static doublereal t; - integer it; - static doublereal rnd, eps, base; - integer beta; - static doublereal emin, prec, emax; - integer imin, imax; - logical lrnd = 0; - static doublereal rmin, rmax; - doublereal rmach = 0; - extern logical lsame_(char *, char *); - doublereal small; - static doublereal sfmin; - extern /* Subroutine */ int dlamc2_(integer *, integer *, logical *, - doublereal *, integer *, doublereal *, integer *, doublereal *); - - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAMCH determines double precision machine parameters. */ - -/* Arguments */ -/* ========= */ - -/* CMACH (input) CHARACTER*1 */ -/* Specifies the value to be returned by DLAMCH: */ -/* = 'E' or 'e', DLAMCH := eps */ -/* = 'S' or 's , DLAMCH := sfmin */ -/* = 'B' or 'b', DLAMCH := base */ -/* = 'P' or 'p', DLAMCH := eps*base */ -/* = 'N' or 'n', DLAMCH := t */ -/* = 'R' or 'r', DLAMCH := rnd */ -/* = 'M' or 'm', DLAMCH := emin */ -/* = 'U' or 'u', DLAMCH := rmin */ -/* = 'L' or 'l', DLAMCH := emax */ -/* = 'O' or 'o', DLAMCH := rmax */ - -/* where */ - -/* eps = relative machine precision */ -/* sfmin = safe minimum, such that 1/sfmin does not overflow */ -/* base = base of the machine */ -/* prec = eps*base */ -/* t = number of (base) digits in the mantissa */ -/* rnd = 1.0 when rounding occurs in addition, 0.0 otherwise */ -/* emin = minimum exponent before (gradual) underflow */ -/* rmin = underflow threshold - base**(emin-1) */ -/* emax = largest exponent before overflow */ -/* rmax = overflow threshold - (base**emax)*(1-eps) */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Save statement .. */ -/* .. */ -/* .. Data statements .. */ -/* .. */ -/* .. Executable Statements .. */ - - if (first) { - dlamc2_(&beta, &it, &lrnd, &eps, &imin, &rmin, &imax, &rmax); - base = (doublereal) beta; - t = (doublereal) it; - if (lrnd) { - rnd = 1.; - i__1 = 1 - it; - eps = pow_di(&base, &i__1) / 2; - } else { - rnd = 0.; - i__1 = 1 - it; - eps = pow_di(&base, &i__1); - } - prec = eps * base; - emin = (doublereal) imin; - emax = (doublereal) imax; - sfmin = rmin; - small = 1. / rmax; - if (small >= sfmin) { - -/* Use SMALL plus a bit, to avoid the possibility of rounding */ -/* causing overflow when computing 1/sfmin. */ - - sfmin = small * (eps + 1.); - } + if (n != 0) { + if (n < 0) { + n = -n; + x = 1 / x; } - - if (lsame_(cmach, "E")) { - rmach = eps; - } else if (lsame_(cmach, "S")) { - rmach = sfmin; - } else if (lsame_(cmach, "B")) { - rmach = base; - } else if (lsame_(cmach, "P")) { - rmach = prec; - } else if (lsame_(cmach, "N")) { - rmach = t; - } else if (lsame_(cmach, "R")) { - rmach = rnd; - } else if (lsame_(cmach, "M")) { - rmach = emin; - } else if (lsame_(cmach, "U")) { - rmach = rmin; - } else if (lsame_(cmach, "L")) { - rmach = emax; - } else if (lsame_(cmach, "O")) { - rmach = rmax; + for (u = n;;) { + if (u & 01) pow *= x; + if (u >>= 1) + x *= x; + else + break; } + } + return (pow); +} - ret_val = rmach; - first = FALSE_; - return ret_val; +doublereal dlamch_(char *cmach) { + /* Initialized data */ -/* End of DLAMCH */ + static logical first = TRUE_; + + /* System generated locals */ + integer i__1; + doublereal ret_val; + + /* Local variables */ + static doublereal t; + integer it; + static doublereal rnd, eps, base; + integer beta; + static doublereal emin, prec, emax; + integer imin, imax; + logical lrnd = 0; + static doublereal rmin, rmax; + doublereal rmach = 0; + extern logical lsame_(char *, char *); + doublereal small; + static doublereal sfmin; + extern /* Subroutine */ void dlamc2_(integer *, integer *, logical *, doublereal *, integer *, doublereal *, + integer *, doublereal *); + + /* -- LAPACK auxiliary routine (version 3.2) -- */ + /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ + /* November 2006 */ + + /* .. Scalar Arguments .. */ + /* .. */ + + /* Purpose */ + /* ======= */ + + /* DLAMCH determines double precision machine parameters. */ + + /* Arguments */ + /* ========= */ + + /* CMACH (input) CHARACTER*1 */ + /* Specifies the value to be returned by DLAMCH: */ + /* = 'E' or 'e', DLAMCH := eps */ + /* = 'S' or 's , DLAMCH := sfmin */ + /* = 'B' or 'b', DLAMCH := base */ + /* = 'P' or 'p', DLAMCH := eps*base */ + /* = 'N' or 'n', DLAMCH := t */ + /* = 'R' or 'r', DLAMCH := rnd */ + /* = 'M' or 'm', DLAMCH := emin */ + /* = 'U' or 'u', DLAMCH := rmin */ + /* = 'L' or 'l', DLAMCH := emax */ + /* = 'O' or 'o', DLAMCH := rmax */ + + /* where */ + + /* eps = relative machine precision */ + /* sfmin = safe minimum, such that 1/sfmin does not overflow */ + /* base = base of the machine */ + /* prec = eps*base */ + /* t = number of (base) digits in the mantissa */ + /* rnd = 1.0 when rounding occurs in addition, 0.0 otherwise */ + /* emin = minimum exponent before (gradual) underflow */ + /* rmin = underflow threshold - base**(emin-1) */ + /* emax = largest exponent before overflow */ + /* rmax = overflow threshold - (base**emax)*(1-eps) */ + + /* ===================================================================== */ + + /* .. Parameters .. */ + /* .. */ + /* .. Local Scalars .. */ + /* .. */ + /* .. External Functions .. */ + /* .. */ + /* .. External Subroutines .. */ + /* .. */ + /* .. Save statement .. */ + /* .. */ + /* .. Data statements .. */ + /* .. */ + /* .. Executable Statements .. */ + + if (first) { + dlamc2_(&beta, &it, &lrnd, &eps, &imin, &rmin, &imax, &rmax); + base = (doublereal)beta; + t = (doublereal)it; + if (lrnd) { + rnd = 1.; + i__1 = 1 - it; + eps = pow_di(&base, &i__1) / 2; + } else { + rnd = 0.; + i__1 = 1 - it; + eps = pow_di(&base, &i__1); + } + prec = eps * base; + emin = (doublereal)imin; + emax = (doublereal)imax; + sfmin = rmin; + small = 1. / rmax; + if (small >= sfmin) { + /* Use SMALL plus a bit, to avoid the possibility of rounding */ + /* causing overflow when computing 1/sfmin. */ + + sfmin = small * (eps + 1.); + } + } + + if (lsame_(cmach, "E")) { + rmach = eps; + } else if (lsame_(cmach, "S")) { + rmach = sfmin; + } else if (lsame_(cmach, "B")) { + rmach = base; + } else if (lsame_(cmach, "P")) { + rmach = prec; + } else if (lsame_(cmach, "N")) { + rmach = t; + } else if (lsame_(cmach, "R")) { + rmach = rnd; + } else if (lsame_(cmach, "M")) { + rmach = emin; + } else if (lsame_(cmach, "U")) { + rmach = rmin; + } else if (lsame_(cmach, "L")) { + rmach = emax; + } else if (lsame_(cmach, "O")) { + rmach = rmax; + } + + ret_val = rmach; + first = FALSE_; + return ret_val; + + /* End of DLAMCH */ } /* dlamch_ */ - /* *********************************************************************** */ -/* Subroutine */ int dlamc1_(integer *beta, integer *t, logical *rnd, logical - *ieee1) -{ - /* Initialized data */ +/* Subroutine */ void dlamc1_(integer *beta, integer *t, logical *rnd, logical *ieee1) { + /* Initialized data */ - static logical first = TRUE_; + static logical first = TRUE_; - /* System generated locals */ - doublereal d__1, d__2; + /* System generated locals */ + doublereal d__1, d__2; - /* Local variables */ - doublereal a, b, c__, f, t1, t2; - static integer lt; - doublereal one, qtr; - static logical lrnd; - static integer lbeta; - doublereal savec; - extern doublereal dlamc3_(doublereal *, doublereal *); - static logical lieee1; + /* Local variables */ + doublereal a, b, c__, f, t1, t2; + static integer lt; + doublereal one, qtr; + static logical lrnd; + static integer lbeta; + doublereal savec; + extern doublereal dlamc3_(doublereal *, doublereal *); + static logical lieee1; + /* -- LAPACK auxiliary routine (version 3.2) -- */ + /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ + /* November 2006 */ -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ + /* .. Scalar Arguments .. */ + /* .. */ -/* .. Scalar Arguments .. */ -/* .. */ + /* Purpose */ + /* ======= */ -/* Purpose */ -/* ======= */ + /* DLAMC1 determines the machine parameters given by BETA, T, RND, and */ + /* IEEE1. */ -/* DLAMC1 determines the machine parameters given by BETA, T, RND, and */ -/* IEEE1. */ + /* Arguments */ + /* ========= */ -/* Arguments */ -/* ========= */ + /* BETA (output) INTEGER */ + /* The base of the machine. */ -/* BETA (output) INTEGER */ -/* The base of the machine. */ + /* T (output) INTEGER */ + /* The number of ( BETA ) digits in the mantissa. */ -/* T (output) INTEGER */ -/* The number of ( BETA ) digits in the mantissa. */ + /* RND (output) LOGICAL */ + /* Specifies whether proper rounding ( RND = .TRUE. ) or */ + /* chopping ( RND = .FALSE. ) occurs in addition. This may not */ + /* be a reliable guide to the way in which the machine performs */ + /* its arithmetic. */ -/* RND (output) LOGICAL */ -/* Specifies whether proper rounding ( RND = .TRUE. ) or */ -/* chopping ( RND = .FALSE. ) occurs in addition. This may not */ -/* be a reliable guide to the way in which the machine performs */ -/* its arithmetic. */ + /* IEEE1 (output) LOGICAL */ + /* Specifies whether rounding appears to be done in the IEEE */ + /* 'round to nearest' style. */ -/* IEEE1 (output) LOGICAL */ -/* Specifies whether rounding appears to be done in the IEEE */ -/* 'round to nearest' style. */ + /* Further Details */ + /* =============== */ -/* Further Details */ -/* =============== */ + /* The routine is based on the routine ENVRON by Malcolm and */ + /* incorporates suggestions by Gentleman and Marovich. See */ -/* The routine is based on the routine ENVRON by Malcolm and */ -/* incorporates suggestions by Gentleman and Marovich. See */ + /* Malcolm M. A. (1972) Algorithms to reveal properties of */ + /* floating-point arithmetic. Comms. of the ACM, 15, 949-951. */ -/* Malcolm M. A. (1972) Algorithms to reveal properties of */ -/* floating-point arithmetic. Comms. of the ACM, 15, 949-951. */ + /* Gentleman W. M. and Marovich S. B. (1974) More on algorithms */ + /* that reveal properties of floating point arithmetic units. */ + /* Comms. of the ACM, 17, 276-277. */ -/* Gentleman W. M. and Marovich S. B. (1974) More on algorithms */ -/* that reveal properties of floating point arithmetic units. */ -/* Comms. of the ACM, 17, 276-277. */ + /* ===================================================================== */ -/* ===================================================================== */ + /* .. Local Scalars .. */ + /* .. */ + /* .. External Functions .. */ + /* .. */ + /* .. Save statement .. */ + /* .. */ + /* .. Data statements .. */ + /* .. */ + /* .. Executable Statements .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Save statement .. */ -/* .. */ -/* .. Data statements .. */ -/* .. */ -/* .. Executable Statements .. */ + if (first) { + one = 1.; - if (first) { - one = 1.; + /* LBETA, LIEEE1, LT and LRND are the local values of BETA, */ + /* IEEE1, T and RND. */ -/* LBETA, LIEEE1, LT and LRND are the local values of BETA, */ -/* IEEE1, T and RND. */ + /* Throughout this routine we use the function DLAMC3 to ensure */ + /* that relevant values are stored and not held in registers, or */ + /* are not affected by optimizers. */ -/* Throughout this routine we use the function DLAMC3 to ensure */ -/* that relevant values are stored and not held in registers, or */ -/* are not affected by optimizers. */ + /* Compute a = 2.0**m with the smallest positive integer m such */ + /* that */ -/* Compute a = 2.0**m with the smallest positive integer m such */ -/* that */ + /* fl( a + 1.0 ) = a. */ -/* fl( a + 1.0 ) = a. */ + a = 1.; + c__ = 1.; - a = 1.; - c__ = 1.; + /* + WHILE( C.EQ.ONE )LOOP */ + L10: + if (c__ == one) { + a *= 2; + c__ = dlamc3_(&a, &one); + d__1 = -a; + c__ = dlamc3_(&c__, &d__1); + goto L10; + } + /* + END WHILE */ -/* + WHILE( C.EQ.ONE )LOOP */ -L10: - if (c__ == one) { - a *= 2; - c__ = dlamc3_(&a, &one); - d__1 = -a; - c__ = dlamc3_(&c__, &d__1); - goto L10; - } -/* + END WHILE */ + /* Now compute b = 2.0**m with the smallest positive integer m */ + /* such that */ -/* Now compute b = 2.0**m with the smallest positive integer m */ -/* such that */ + /* fl( a + b ) .gt. a. */ -/* fl( a + b ) .gt. a. */ + b = 1.; + c__ = dlamc3_(&a, &b); - b = 1.; - c__ = dlamc3_(&a, &b); + /* + WHILE( C.EQ.A )LOOP */ + L20: + if (c__ == a) { + b *= 2; + c__ = dlamc3_(&a, &b); + goto L20; + } + /* + END WHILE */ -/* + WHILE( C.EQ.A )LOOP */ -L20: - if (c__ == a) { - b *= 2; - c__ = dlamc3_(&a, &b); - goto L20; - } -/* + END WHILE */ + /* Now compute the base. a and c are neighbouring floating point */ + /* numbers in the interval ( beta**t, beta**( t + 1 ) ) and so */ + /* their difference is beta. Adding 0.25 to c is to ensure that it */ + /* is truncated to beta and not ( beta - 1 ). */ -/* Now compute the base. a and c are neighbouring floating point */ -/* numbers in the interval ( beta**t, beta**( t + 1 ) ) and so */ -/* their difference is beta. Adding 0.25 to c is to ensure that it */ -/* is truncated to beta and not ( beta - 1 ). */ + qtr = one / 4; + savec = c__; + d__1 = -a; + c__ = dlamc3_(&c__, &d__1); + lbeta = (integer)(c__ + qtr); - qtr = one / 4; - savec = c__; - d__1 = -a; - c__ = dlamc3_(&c__, &d__1); - lbeta = (integer) (c__ + qtr); + /* Now determine whether rounding or chopping occurs, by adding a */ + /* bit less than beta/2 and a bit more than beta/2 to a. */ -/* Now determine whether rounding or chopping occurs, by adding a */ -/* bit less than beta/2 and a bit more than beta/2 to a. */ - - b = (doublereal) lbeta; - d__1 = b / 2; - d__2 = -b / 100; - f = dlamc3_(&d__1, &d__2); - c__ = dlamc3_(&f, &a); - if (c__ == a) { - lrnd = TRUE_; - } else { - lrnd = FALSE_; - } - d__1 = b / 2; - d__2 = b / 100; - f = dlamc3_(&d__1, &d__2); - c__ = dlamc3_(&f, &a); - if (lrnd && c__ == a) { - lrnd = FALSE_; - } - -/* Try and decide whether rounding is done in the IEEE 'round to */ -/* nearest' style. B/2 is half a unit in the last place of the two */ -/* numbers A and SAVEC. Furthermore, A is even, i.e. has last bit */ -/* zero, and SAVEC is odd. Thus adding B/2 to A should not change */ -/* A, but adding B/2 to SAVEC should change SAVEC. */ - - d__1 = b / 2; - t1 = dlamc3_(&d__1, &a); - d__1 = b / 2; - t2 = dlamc3_(&d__1, &savec); - lieee1 = t1 == a && t2 > savec && lrnd; - -/* Now find the mantissa, t. It should be the integer part of */ -/* log to the base beta of a, however it is safer to determine t */ -/* by powering. So we find t as the smallest positive integer for */ -/* which */ - -/* fl( beta**t + 1.0 ) = 1.0. */ - - lt = 0; - a = 1.; - c__ = 1.; - -/* + WHILE( C.EQ.ONE )LOOP */ -L30: - if (c__ == one) { - ++lt; - a *= lbeta; - c__ = dlamc3_(&a, &one); - d__1 = -a; - c__ = dlamc3_(&c__, &d__1); - goto L30; - } -/* + END WHILE */ - + b = (doublereal)lbeta; + d__1 = b / 2; + d__2 = -b / 100; + f = dlamc3_(&d__1, &d__2); + c__ = dlamc3_(&f, &a); + if (c__ == a) { + lrnd = TRUE_; + } else { + lrnd = FALSE_; + } + d__1 = b / 2; + d__2 = b / 100; + f = dlamc3_(&d__1, &d__2); + c__ = dlamc3_(&f, &a); + if (lrnd && c__ == a) { + lrnd = FALSE_; } - *beta = lbeta; - *t = lt; - *rnd = lrnd; - *ieee1 = lieee1; - first = FALSE_; - return 0; + /* Try and decide whether rounding is done in the IEEE 'round to */ + /* nearest' style. B/2 is half a unit in the last place of the two */ + /* numbers A and SAVEC. Furthermore, A is even, i.e. has last bit */ + /* zero, and SAVEC is odd. Thus adding B/2 to A should not change */ + /* A, but adding B/2 to SAVEC should change SAVEC. */ -/* End of DLAMC1 */ + d__1 = b / 2; + t1 = dlamc3_(&d__1, &a); + d__1 = b / 2; + t2 = dlamc3_(&d__1, &savec); + lieee1 = t1 == a && t2 > savec && lrnd; + + /* Now find the mantissa, t. It should be the integer part of */ + /* log to the base beta of a, however it is safer to determine t */ + /* by powering. So we find t as the smallest positive integer for */ + /* which */ + + /* fl( beta**t + 1.0 ) = 1.0. */ + + lt = 0; + a = 1.; + c__ = 1.; + + /* + WHILE( C.EQ.ONE )LOOP */ + L30: + if (c__ == one) { + ++lt; + a *= lbeta; + c__ = dlamc3_(&a, &one); + d__1 = -a; + c__ = dlamc3_(&c__, &d__1); + goto L30; + } + /* + END WHILE */ + } + + *beta = lbeta; + *t = lt; + *rnd = lrnd; + *ieee1 = lieee1; + first = FALSE_; + + /* End of DLAMC1 */ } /* dlamc1_ */ - /* *********************************************************************** */ -/* Subroutine */ int dlamc2_(integer *beta, integer *t, logical *rnd, - doublereal *eps, integer *emin, doublereal *rmin, integer *emax, - doublereal *rmax) -{ - /* Initialized data */ +/* Subroutine */ void dlamc2_(integer *beta, integer *t, logical *rnd, doublereal *eps, integer *emin, doublereal *rmin, + integer *emax, doublereal *rmax) { + /* Initialized data */ - static logical first = TRUE_; - static logical iwarn = FALSE_; + static logical first = TRUE_; + static logical iwarn = FALSE_; - /* Format strings */ - static char fmt_9999[] = "(//\002 WARNING. The value EMIN may be incorre" - "ct:-\002,\002 EMIN = \002,i8,/\002 If, after inspection, the va" - "lue EMIN looks\002,\002 acceptable please comment out \002,/\002" - " the IF block as marked within the code of routine\002,\002 DLAM" - "C2,\002,/\002 otherwise supply EMIN explicitly.\002,/)"; + /* Format strings */ + /* + static char fmt_9999[] = + "(//\002 WARNING. The value EMIN may be incorre" + "ct:-\002,\002 EMIN = \002,i8,/\002 If, after inspection, the va" + "lue EMIN looks\002,\002 acceptable please comment out \002,/\002" + " the IF block as marked within the code of routine\002,\002 DLAM" + "C2,\002,/\002 otherwise supply EMIN explicitly.\002,/)"; + */ + /* System generated locals */ + integer i__1; + doublereal d__1, d__2, d__3, d__4, d__5; - /* System generated locals */ - integer i__1; - doublereal d__1, d__2, d__3, d__4, d__5; + /* Builtin functions */ + /* integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void); */ - /* Builtin functions */ - double pow_di(doublereal *, integer *); - integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void); + /* Local variables */ + doublereal a, b, c__; + integer i__; + static integer lt; + doublereal one, two; + logical ieee; + doublereal half; + logical lrnd = 0; + static doublereal leps; + doublereal zero; + static integer lbeta; + doublereal rbase; + static integer lemin, lemax; + integer gnmin; + doublereal small; + integer gpmin; + doublereal third; + static doublereal lrmin, lrmax; + doublereal sixth; + extern /* Subroutine */ void dlamc1_(integer *, integer *, logical *, logical *); + extern doublereal dlamc3_(doublereal *, doublereal *); + logical lieee1; + extern /* Subroutine */ void dlamc4_(integer *, doublereal *, integer *), + dlamc5_(integer *, integer *, integer *, logical *, integer *, doublereal *); + integer ngnmin, ngpmin; - /* Local variables */ - doublereal a, b, c__; - integer i__; - static integer lt; - doublereal one, two; - logical ieee; - doublereal half; - logical lrnd = 0; - static doublereal leps; - doublereal zero; - static integer lbeta; - doublereal rbase; - static integer lemin, lemax; - integer gnmin; - doublereal small; - integer gpmin; - doublereal third; - static doublereal lrmin, lrmax; - doublereal sixth; - extern /* Subroutine */ int dlamc1_(integer *, integer *, logical *, - logical *); - extern doublereal dlamc3_(doublereal *, doublereal *); - logical lieee1; - extern /* Subroutine */ int dlamc4_(integer *, doublereal *, integer *), - dlamc5_(integer *, integer *, integer *, logical *, integer *, - doublereal *); - integer ngnmin, ngpmin; + /* Fortran I/O blocks */ + /* static cilist io___58 = {0, 6, 0, fmt_9999, 0}; */ - /* Fortran I/O blocks */ - static cilist io___58 = { 0, 6, 0, fmt_9999, 0 }; + /* -- LAPACK auxiliary routine (version 3.2) -- */ + /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ + /* November 2006 */ + /* .. Scalar Arguments .. */ + /* .. */ + /* Purpose */ + /* ======= */ -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ + /* DLAMC2 determines the machine parameters specified in its argument */ + /* list. */ -/* .. Scalar Arguments .. */ -/* .. */ + /* Arguments */ + /* ========= */ -/* Purpose */ -/* ======= */ + /* BETA (output) INTEGER */ + /* The base of the machine. */ -/* DLAMC2 determines the machine parameters specified in its argument */ -/* list. */ + /* T (output) INTEGER */ + /* The number of ( BETA ) digits in the mantissa. */ -/* Arguments */ -/* ========= */ + /* RND (output) LOGICAL */ + /* Specifies whether proper rounding ( RND = .TRUE. ) or */ + /* chopping ( RND = .FALSE. ) occurs in addition. This may not */ + /* be a reliable guide to the way in which the machine performs */ + /* its arithmetic. */ -/* BETA (output) INTEGER */ -/* The base of the machine. */ + /* EPS (output) DOUBLE PRECISION */ + /* The smallest positive number such that */ -/* T (output) INTEGER */ -/* The number of ( BETA ) digits in the mantissa. */ + /* fl( 1.0 - EPS ) .LT. 1.0, */ -/* RND (output) LOGICAL */ -/* Specifies whether proper rounding ( RND = .TRUE. ) or */ -/* chopping ( RND = .FALSE. ) occurs in addition. This may not */ -/* be a reliable guide to the way in which the machine performs */ -/* its arithmetic. */ + /* where fl denotes the computed value. */ -/* EPS (output) DOUBLE PRECISION */ -/* The smallest positive number such that */ + /* EMIN (output) INTEGER */ + /* The minimum exponent before (gradual) underflow occurs. */ -/* fl( 1.0 - EPS ) .LT. 1.0, */ + /* RMIN (output) DOUBLE PRECISION */ + /* The smallest normalized number for the machine, given by */ + /* BASE**( EMIN - 1 ), where BASE is the floating point value */ + /* of BETA. */ -/* where fl denotes the computed value. */ + /* EMAX (output) INTEGER */ + /* The maximum exponent before overflow occurs. */ -/* EMIN (output) INTEGER */ -/* The minimum exponent before (gradual) underflow occurs. */ + /* RMAX (output) DOUBLE PRECISION */ + /* The largest positive number for the machine, given by */ + /* BASE**EMAX * ( 1 - EPS ), where BASE is the floating point */ + /* value of BETA. */ -/* RMIN (output) DOUBLE PRECISION */ -/* The smallest normalized number for the machine, given by */ -/* BASE**( EMIN - 1 ), where BASE is the floating point value */ -/* of BETA. */ + /* Further Details */ + /* =============== */ -/* EMAX (output) INTEGER */ -/* The maximum exponent before overflow occurs. */ + /* The computation of EPS is based on a routine PARANOIA by */ + /* W. Kahan of the University of California at Berkeley. */ -/* RMAX (output) DOUBLE PRECISION */ -/* The largest positive number for the machine, given by */ -/* BASE**EMAX * ( 1 - EPS ), where BASE is the floating point */ -/* value of BETA. */ + /* ===================================================================== */ -/* Further Details */ -/* =============== */ + /* .. Local Scalars .. */ + /* .. */ + /* .. External Functions .. */ + /* .. */ + /* .. External Subroutines .. */ + /* .. */ + /* .. Intrinsic Functions .. */ + /* .. */ + /* .. Save statement .. */ + /* .. */ + /* .. Data statements .. */ + /* .. */ + /* .. Executable Statements .. */ -/* The computation of EPS is based on a routine PARANOIA by */ -/* W. Kahan of the University of California at Berkeley. */ + if (first) { + zero = 0.; + one = 1.; + two = 2.; -/* ===================================================================== */ + /* LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values of */ + /* BETA, T, RND, EPS, EMIN and RMIN. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Save statement .. */ -/* .. */ -/* .. Data statements .. */ -/* .. */ -/* .. Executable Statements .. */ + /* Throughout this routine we use the function DLAMC3 to ensure */ + /* that relevant values are stored and not held in registers, or */ + /* are not affected by optimizers. */ - if (first) { - zero = 0.; - one = 1.; - two = 2.; + /* DLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1. */ -/* LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values of */ -/* BETA, T, RND, EPS, EMIN and RMIN. */ + dlamc1_(&lbeta, <, &lrnd, &lieee1); -/* Throughout this routine we use the function DLAMC3 to ensure */ -/* that relevant values are stored and not held in registers, or */ -/* are not affected by optimizers. */ + /* Start to find EPS. */ -/* DLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1. */ + b = (doublereal)lbeta; + i__1 = -lt; + a = pow_di(&b, &i__1); + leps = a; - dlamc1_(&lbeta, <, &lrnd, &lieee1); + /* Try some tricks to see whether or not this is the correct EPS. */ -/* Start to find EPS. */ - - b = (doublereal) lbeta; - i__1 = -lt; - a = pow_di(&b, &i__1); - leps = a; - -/* Try some tricks to see whether or not this is the correct EPS. */ - - b = two / 3; - half = one / 2; - d__1 = -half; - sixth = dlamc3_(&b, &d__1); - third = dlamc3_(&sixth, &sixth); - d__1 = -half; - b = dlamc3_(&third, &d__1); - b = dlamc3_(&b, &sixth); - b = abs(b); - if (b < leps) { - b = leps; - } - - leps = 1.; - -/* + WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP */ -L10: - if (leps > b && b > zero) { - leps = b; - d__1 = half * leps; -/* Computing 5th power */ - d__3 = two, d__4 = d__3, d__3 *= d__3; -/* Computing 2nd power */ - d__5 = leps; - d__2 = d__4 * (d__3 * d__3) * (d__5 * d__5); - c__ = dlamc3_(&d__1, &d__2); - d__1 = -c__; - c__ = dlamc3_(&half, &d__1); - b = dlamc3_(&half, &c__); - d__1 = -b; - c__ = dlamc3_(&half, &d__1); - b = dlamc3_(&half, &c__); - goto L10; - } -/* + END WHILE */ - - if (a < leps) { - leps = a; - } - -/* Computation of EPS complete. */ - -/* Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3)). */ -/* Keep dividing A by BETA until (gradual) underflow occurs. This */ -/* is detected when we cannot recover the previous A. */ - - rbase = one / lbeta; - small = one; - for (i__ = 1; i__ <= 3; ++i__) { - d__1 = small * rbase; - small = dlamc3_(&d__1, &zero); -/* L20: */ - } - a = dlamc3_(&one, &small); - dlamc4_(&ngpmin, &one, &lbeta); - d__1 = -one; - dlamc4_(&ngnmin, &d__1, &lbeta); - dlamc4_(&gpmin, &a, &lbeta); - d__1 = -a; - dlamc4_(&gnmin, &d__1, &lbeta); - ieee = FALSE_; - - if (ngpmin == ngnmin && gpmin == gnmin) { - if (ngpmin == gpmin) { - lemin = ngpmin; -/* ( Non twos-complement machines, no gradual underflow; */ -/* e.g., VAX ) */ - } else if (gpmin - ngpmin == 3) { - lemin = ngpmin - 1 + lt; - ieee = TRUE_; -/* ( Non twos-complement machines, with gradual underflow; */ -/* e.g., IEEE standard followers ) */ - } else { - lemin = min(ngpmin,gpmin); -/* ( A guess; no known machine ) */ - iwarn = TRUE_; - } - - } else if (ngpmin == gpmin && ngnmin == gnmin) { - if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1) { - lemin = max(ngpmin,ngnmin); -/* ( Twos-complement machines, no gradual underflow; */ -/* e.g., CYBER 205 ) */ - } else { - lemin = min(ngpmin,ngnmin); -/* ( A guess; no known machine ) */ - iwarn = TRUE_; - } - - } else if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1 && gpmin == gnmin) - { - if (gpmin - min(ngpmin,ngnmin) == 3) { - lemin = max(ngpmin,ngnmin) - 1 + lt; -/* ( Twos-complement machines with gradual underflow; */ -/* no known machine ) */ - } else { - lemin = min(ngpmin,ngnmin); -/* ( A guess; no known machine ) */ - iwarn = TRUE_; - } - - } else { -/* Computing MIN */ - i__1 = min(ngpmin,ngnmin), i__1 = min(i__1,gpmin); - lemin = min(i__1,gnmin); -/* ( A guess; no known machine ) */ - iwarn = TRUE_; - } - first = FALSE_; -/* ** */ -/* Comment out this if block if EMIN is ok */ - if (iwarn) { - first = TRUE_; - s_wsfe(&io___58); - do_fio(&c__1, (char *)&lemin, (ftnlen)sizeof(integer)); - e_wsfe(); - } -/* ** */ - -/* Assume IEEE arithmetic if we found denormalised numbers above, */ -/* or if arithmetic seems to round in the IEEE style, determined */ -/* in routine DLAMC1. A true IEEE machine should have both things */ -/* true; however, faulty machines may have one or the other. */ - - ieee = ieee || lieee1; - -/* Compute RMIN by successive division by BETA. We could compute */ -/* RMIN as BASE**( EMIN - 1 ), but some machines underflow during */ -/* this computation. */ - - lrmin = 1.; - i__1 = 1 - lemin; - for (i__ = 1; i__ <= i__1; ++i__) { - d__1 = lrmin * rbase; - lrmin = dlamc3_(&d__1, &zero); -/* L30: */ - } - -/* Finally, call DLAMC5 to compute EMAX and RMAX. */ - - dlamc5_(&lbeta, <, &lemin, &ieee, &lemax, &lrmax); + b = two / 3; + half = one / 2; + d__1 = -half; + sixth = dlamc3_(&b, &d__1); + third = dlamc3_(&sixth, &sixth); + d__1 = -half; + b = dlamc3_(&third, &d__1); + b = dlamc3_(&b, &sixth); + b = abs(b); + if (b < leps) { + b = leps; } - *beta = lbeta; - *t = lt; - *rnd = lrnd; - *eps = leps; - *emin = lemin; - *rmin = lrmin; - *emax = lemax; - *rmax = lrmax; + leps = 1.; - return 0; + /* + WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP */ + L10: + if (leps > b && b > zero) { + leps = b; + d__1 = half * leps; + /* Computing 5th power */ + d__3 = two, d__4 = d__3, d__3 *= d__3; + /* Computing 2nd power */ + d__5 = leps; + d__2 = d__4 * (d__3 * d__3) * (d__5 * d__5); + c__ = dlamc3_(&d__1, &d__2); + d__1 = -c__; + c__ = dlamc3_(&half, &d__1); + b = dlamc3_(&half, &c__); + d__1 = -b; + c__ = dlamc3_(&half, &d__1); + b = dlamc3_(&half, &c__); + goto L10; + } + /* + END WHILE */ + if (a < leps) { + leps = a; + } -/* End of DLAMC2 */ + /* Computation of EPS complete. */ + + /* Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3)). */ + /* Keep dividing A by BETA until (gradual) underflow occurs. This */ + /* is detected when we cannot recover the previous A. */ + + rbase = one / lbeta; + small = one; + for (i__ = 1; i__ <= 3; ++i__) { + d__1 = small * rbase; + small = dlamc3_(&d__1, &zero); + /* L20: */ + } + a = dlamc3_(&one, &small); + dlamc4_(&ngpmin, &one, &lbeta); + d__1 = -one; + dlamc4_(&ngnmin, &d__1, &lbeta); + dlamc4_(&gpmin, &a, &lbeta); + d__1 = -a; + dlamc4_(&gnmin, &d__1, &lbeta); + ieee = FALSE_; + + if (ngpmin == ngnmin && gpmin == gnmin) { + if (ngpmin == gpmin) { + lemin = ngpmin; + /* ( Non twos-complement machines, no gradual underflow; */ + /* e.g., VAX ) */ + } else if (gpmin - ngpmin == 3) { + lemin = ngpmin - 1 + lt; + ieee = TRUE_; + /* ( Non twos-complement machines, with gradual underflow; */ + /* e.g., IEEE standard followers ) */ + } else { + lemin = min(ngpmin, gpmin); + /* ( A guess; no known machine ) */ + iwarn = TRUE_; + } + + } else if (ngpmin == gpmin && ngnmin == gnmin) { + if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1) { + lemin = max(ngpmin, ngnmin); + /* ( Twos-complement machines, no gradual underflow; */ + /* e.g., CYBER 205 ) */ + } else { + lemin = min(ngpmin, ngnmin); + /* ( A guess; no known machine ) */ + iwarn = TRUE_; + } + + } else if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1 && gpmin == gnmin) { + if (gpmin - min(ngpmin, ngnmin) == 3) { + lemin = max(ngpmin, ngnmin) - 1 + lt; + /* ( Twos-complement machines with gradual underflow; */ + /* no known machine ) */ + } else { + lemin = min(ngpmin, ngnmin); + /* ( A guess; no known machine ) */ + iwarn = TRUE_; + } + + } else { + /* Computing MIN */ + i__1 = min(ngpmin, ngnmin), i__1 = min(i__1, gpmin); + lemin = min(i__1, gnmin); + /* ( A guess; no known machine ) */ + iwarn = TRUE_; + } + first = FALSE_; + /* ** */ + /* Comment out this if block if EMIN is ok */ + /* + if (iwarn) { + first = TRUE_; + s_wsfe(&io___58); + do_fio(&c__1, (char *)&lemin, (ftnlen)sizeof(integer)); + e_wsfe(); + } + */ + /* ** */ + + /* Assume IEEE arithmetic if we found denormalised numbers above, */ + /* or if arithmetic seems to round in the IEEE style, determined */ + /* in routine DLAMC1. A true IEEE machine should have both things */ + /* true; however, faulty machines may have one or the other. */ + + ieee = ieee || lieee1; + + /* Compute RMIN by successive division by BETA. We could compute */ + /* RMIN as BASE**( EMIN - 1 ), but some machines underflow during */ + /* this computation. */ + + lrmin = 1.; + i__1 = 1 - lemin; + for (i__ = 1; i__ <= i__1; ++i__) { + d__1 = lrmin * rbase; + lrmin = dlamc3_(&d__1, &zero); + /* L30: */ + } + + /* Finally, call DLAMC5 to compute EMAX and RMAX. */ + + dlamc5_(&lbeta, <, &lemin, &ieee, &lemax, &lrmax); + } + + *beta = lbeta; + *t = lt; + *rnd = lrnd; + *eps = leps; + *emin = lemin; + *rmin = lrmin; + *emax = lemax; + *rmax = lrmax; + + /* End of DLAMC2 */ } /* dlamc2_ */ - /* *********************************************************************** */ -doublereal dlamc3_(doublereal *a, doublereal *b) -{ - /* System generated locals */ - doublereal ret_val; +doublereal dlamc3_(doublereal *a, doublereal *b) { + /* System generated locals */ + doublereal ret_val; + /* -- LAPACK auxiliary routine (version 3.2) -- */ + /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ + /* November 2006 */ -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ + /* .. Scalar Arguments .. */ + /* .. */ -/* .. Scalar Arguments .. */ -/* .. */ + /* Purpose */ + /* ======= */ -/* Purpose */ -/* ======= */ + /* DLAMC3 is intended to force A and B to be stored prior to doing */ + /* the addition of A and B , for use in situations where optimizers */ + /* might hold one of these in a register. */ -/* DLAMC3 is intended to force A and B to be stored prior to doing */ -/* the addition of A and B , for use in situations where optimizers */ -/* might hold one of these in a register. */ + /* Arguments */ + /* ========= */ -/* Arguments */ -/* ========= */ + /* A (input) DOUBLE PRECISION */ + /* B (input) DOUBLE PRECISION */ + /* The values A and B. */ -/* A (input) DOUBLE PRECISION */ -/* B (input) DOUBLE PRECISION */ -/* The values A and B. */ + /* ===================================================================== */ -/* ===================================================================== */ + /* .. Executable Statements .. */ -/* .. Executable Statements .. */ + ret_val = *a + *b; - ret_val = *a + *b; + return ret_val; - return ret_val; - -/* End of DLAMC3 */ + /* End of DLAMC3 */ } /* dlamc3_ */ - /* *********************************************************************** */ -/* Subroutine */ int dlamc4_(integer *emin, doublereal *start, integer *base) -{ - /* System generated locals */ - integer i__1; - doublereal d__1; +/* Subroutine */ void dlamc4_(integer *emin, doublereal *start, integer *base) { + /* System generated locals */ + integer i__1; + doublereal d__1; - /* Local variables */ - doublereal a; - integer i__; - doublereal b1, b2, c1, c2, d1, d2, one, zero, rbase; - extern doublereal dlamc3_(doublereal *, doublereal *); + /* Local variables */ + doublereal a; + integer i__; + doublereal b1, b2, c1, c2, d1, d2, one, zero, rbase; + extern doublereal dlamc3_(doublereal *, doublereal *); + /* -- LAPACK auxiliary routine (version 3.2) -- */ + /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ + /* November 2006 */ -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ + /* .. Scalar Arguments .. */ + /* .. */ -/* .. Scalar Arguments .. */ -/* .. */ + /* Purpose */ + /* ======= */ -/* Purpose */ -/* ======= */ + /* DLAMC4 is a service routine for DLAMC2. */ -/* DLAMC4 is a service routine for DLAMC2. */ + /* Arguments */ + /* ========= */ -/* Arguments */ -/* ========= */ + /* EMIN (output) INTEGER */ + /* The minimum exponent before (gradual) underflow, computed by */ + /* setting A = START and dividing by BASE until the previous A */ + /* can not be recovered. */ -/* EMIN (output) INTEGER */ -/* The minimum exponent before (gradual) underflow, computed by */ -/* setting A = START and dividing by BASE until the previous A */ -/* can not be recovered. */ + /* START (input) DOUBLE PRECISION */ + /* The starting point for determining EMIN. */ -/* START (input) DOUBLE PRECISION */ -/* The starting point for determining EMIN. */ + /* BASE (input) INTEGER */ + /* The base of the machine. */ -/* BASE (input) INTEGER */ -/* The base of the machine. */ + /* ===================================================================== */ -/* ===================================================================== */ + /* .. Local Scalars .. */ + /* .. */ + /* .. External Functions .. */ + /* .. */ + /* .. Executable Statements .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - a = *start; - one = 1.; - rbase = one / *base; - zero = 0.; - *emin = 1; - d__1 = a * rbase; - b1 = dlamc3_(&d__1, &zero); - c1 = a; - c2 = a; - d1 = a; - d2 = a; + a = *start; + one = 1.; + rbase = one / *base; + zero = 0.; + *emin = 1; + d__1 = a * rbase; + b1 = dlamc3_(&d__1, &zero); + c1 = a; + c2 = a; + d1 = a; + d2 = a; /* + WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND. */ /* $ ( D1.EQ.A ).AND.( D2.EQ.A ) )LOOP */ L10: - if (c1 == a && c2 == a && d1 == a && d2 == a) { - --(*emin); - a = b1; - d__1 = a / *base; - b1 = dlamc3_(&d__1, &zero); - d__1 = b1 * *base; - c1 = dlamc3_(&d__1, &zero); - d1 = zero; - i__1 = *base; - for (i__ = 1; i__ <= i__1; ++i__) { - d1 += b1; -/* L20: */ - } - d__1 = a * rbase; - b2 = dlamc3_(&d__1, &zero); - d__1 = b2 / rbase; - c2 = dlamc3_(&d__1, &zero); - d2 = zero; - i__1 = *base; - for (i__ = 1; i__ <= i__1; ++i__) { - d2 += b2; -/* L30: */ - } - goto L10; + if (c1 == a && c2 == a && d1 == a && d2 == a) { + --(*emin); + a = b1; + d__1 = a / *base; + b1 = dlamc3_(&d__1, &zero); + d__1 = b1 * *base; + c1 = dlamc3_(&d__1, &zero); + d1 = zero; + i__1 = *base; + for (i__ = 1; i__ <= i__1; ++i__) { + d1 += b1; + /* L20: */ } -/* + END WHILE */ + d__1 = a * rbase; + b2 = dlamc3_(&d__1, &zero); + d__1 = b2 / rbase; + c2 = dlamc3_(&d__1, &zero); + d2 = zero; + i__1 = *base; + for (i__ = 1; i__ <= i__1; ++i__) { + d2 += b2; + /* L30: */ + } + goto L10; + } + /* + END WHILE */ - return 0; - -/* End of DLAMC4 */ + /* End of DLAMC4 */ } /* dlamc4_ */ - /* *********************************************************************** */ -/* Subroutine */ int dlamc5_(integer *beta, integer *p, integer *emin, - logical *ieee, integer *emax, doublereal *rmax) -{ - /* System generated locals */ - integer i__1; - doublereal d__1; +/* Subroutine */ void dlamc5_(integer *beta, integer *p, integer *emin, logical *ieee, integer *emax, + doublereal *rmax) { + /* System generated locals */ + integer i__1; + doublereal d__1; - /* Local variables */ - integer i__; - doublereal y, z__; - integer try__, lexp; - doublereal oldy; - integer uexp, nbits; - extern doublereal dlamc3_(doublereal *, doublereal *); - doublereal recbas; - integer exbits, expsum; + /* Local variables */ + integer i__; + doublereal y, z__; + integer try__, lexp; + doublereal oldy; + integer uexp, nbits; + extern doublereal dlamc3_(doublereal *, doublereal *); + doublereal recbas; + integer exbits, expsum; + /* -- LAPACK auxiliary routine (version 3.2) -- */ + /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ + /* November 2006 */ -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ + /* .. Scalar Arguments .. */ + /* .. */ -/* .. Scalar Arguments .. */ -/* .. */ + /* Purpose */ + /* ======= */ -/* Purpose */ -/* ======= */ + /* DLAMC5 attempts to compute RMAX, the largest machine floating-point */ + /* number, without overflow. It assumes that EMAX + abs(EMIN) sum */ + /* approximately to a power of 2. It will fail on machines where this */ + /* assumption does not hold, for example, the Cyber 205 (EMIN = -28625, */ + /* EMAX = 28718). It will also fail if the value supplied for EMIN is */ + /* too large (i.e. too close to zero), probably with overflow. */ -/* DLAMC5 attempts to compute RMAX, the largest machine floating-point */ -/* number, without overflow. It assumes that EMAX + abs(EMIN) sum */ -/* approximately to a power of 2. It will fail on machines where this */ -/* assumption does not hold, for example, the Cyber 205 (EMIN = -28625, */ -/* EMAX = 28718). It will also fail if the value supplied for EMIN is */ -/* too large (i.e. too close to zero), probably with overflow. */ + /* Arguments */ + /* ========= */ -/* Arguments */ -/* ========= */ + /* BETA (input) INTEGER */ + /* The base of floating-point arithmetic. */ -/* BETA (input) INTEGER */ -/* The base of floating-point arithmetic. */ + /* P (input) INTEGER */ + /* The number of base BETA digits in the mantissa of a */ + /* floating-point value. */ -/* P (input) INTEGER */ -/* The number of base BETA digits in the mantissa of a */ -/* floating-point value. */ + /* EMIN (input) INTEGER */ + /* The minimum exponent before (gradual) underflow. */ -/* EMIN (input) INTEGER */ -/* The minimum exponent before (gradual) underflow. */ + /* IEEE (input) LOGICAL */ + /* A logical flag specifying whether or not the arithmetic */ + /* system is thought to comply with the IEEE standard. */ -/* IEEE (input) LOGICAL */ -/* A logical flag specifying whether or not the arithmetic */ -/* system is thought to comply with the IEEE standard. */ + /* EMAX (output) INTEGER */ + /* The largest exponent before overflow */ -/* EMAX (output) INTEGER */ -/* The largest exponent before overflow */ + /* RMAX (output) DOUBLE PRECISION */ + /* The largest machine floating-point number. */ -/* RMAX (output) DOUBLE PRECISION */ -/* The largest machine floating-point number. */ + /* ===================================================================== */ -/* ===================================================================== */ + /* .. Parameters .. */ + /* .. */ + /* .. Local Scalars .. */ + /* .. */ + /* .. External Functions .. */ + /* .. */ + /* .. Intrinsic Functions .. */ + /* .. */ + /* .. Executable Statements .. */ -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ + /* First compute LEXP and UEXP, two powers of 2 that bound */ + /* abs(EMIN). We then assume that EMAX + abs(EMIN) will sum */ + /* approximately to the bound that is closest to abs(EMIN). */ + /* (EMAX is the exponent of the required number RMAX). */ -/* First compute LEXP and UEXP, two powers of 2 that bound */ -/* abs(EMIN). We then assume that EMAX + abs(EMIN) will sum */ -/* approximately to the bound that is closest to abs(EMIN). */ -/* (EMAX is the exponent of the required number RMAX). */ - - lexp = 1; - exbits = 1; + lexp = 1; + exbits = 1; L10: - try__ = lexp << 1; - if (try__ <= -(*emin)) { - lexp = try__; - ++exbits; - goto L10; + try__ = lexp << 1; + if (try__ <= -(*emin)) { + lexp = try__; + ++exbits; + goto L10; + } + if (lexp == -(*emin)) { + uexp = lexp; + } else { + uexp = try__; + ++exbits; + } + + /* Now -LEXP is less than or equal to EMIN, and -UEXP is greater */ + /* than or equal to EMIN. EXBITS is the number of bits needed to */ + /* store the exponent. */ + + if (uexp + *emin > -lexp - *emin) { + expsum = lexp << 1; + } else { + expsum = uexp << 1; + } + + /* EXPSUM is the exponent range, approximately equal to */ + /* EMAX - EMIN + 1 . */ + + *emax = expsum + *emin - 1; + nbits = exbits + 1 + *p; + + /* NBITS is the total number of bits needed to store a */ + /* floating-point number. */ + + if (nbits % 2 == 1 && *beta == 2) { + /* Either there are an odd number of bits used to store a */ + /* floating-point number, which is unlikely, or some bits are */ + /* not used in the representation of numbers, which is possible, */ + /* (e.g. Cray machines) or the mantissa has an implicit bit, */ + /* (e.g. IEEE machines, Dec Vax machines), which is perhaps the */ + /* most likely. We have to assume the last alternative. */ + /* If this is true, then we need to reduce EMAX by one because */ + /* there must be some way of representing zero in an implicit-bit */ + /* system. On machines like Cray, we are reducing EMAX by one */ + /* unnecessarily. */ + + --(*emax); + } + + if (*ieee) { + /* Assume we are on an IEEE machine which reserves one exponent */ + /* for infinity and NaN. */ + + --(*emax); + } + + /* Now create RMAX, the largest machine number, which should */ + /* be equal to (1.0 - BETA**(-P)) * BETA**EMAX . */ + + /* First compute 1.0 - BETA**(-P), being careful that the */ + /* result is less than 1.0 . */ + + recbas = 1. / *beta; + z__ = *beta - 1.; + y = 0.; + i__1 = *p; + for (i__ = 1; i__ <= i__1; ++i__) { + z__ *= recbas; + if (y < 1.) { + oldy = y; } - if (lexp == -(*emin)) { - uexp = lexp; - } else { - uexp = try__; - ++exbits; - } + y = dlamc3_(&y, &z__); + /* L20: */ + } + if (y >= 1.) { + y = oldy; + } -/* Now -LEXP is less than or equal to EMIN, and -UEXP is greater */ -/* than or equal to EMIN. EXBITS is the number of bits needed to */ -/* store the exponent. */ + /* Now multiply by BETA**EMAX to get RMAX. */ - if (uexp + *emin > -lexp - *emin) { - expsum = lexp << 1; - } else { - expsum = uexp << 1; - } + i__1 = *emax; + for (i__ = 1; i__ <= i__1; ++i__) { + d__1 = y * *beta; + y = dlamc3_(&d__1, &c_b32); + /* L30: */ + } -/* EXPSUM is the exponent range, approximately equal to */ -/* EMAX - EMIN + 1 . */ + *rmax = y; - *emax = expsum + *emin - 1; - nbits = exbits + 1 + *p; - -/* NBITS is the total number of bits needed to store a */ -/* floating-point number. */ - - if (nbits % 2 == 1 && *beta == 2) { - -/* Either there are an odd number of bits used to store a */ -/* floating-point number, which is unlikely, or some bits are */ -/* not used in the representation of numbers, which is possible, */ -/* (e.g. Cray machines) or the mantissa has an implicit bit, */ -/* (e.g. IEEE machines, Dec Vax machines), which is perhaps the */ -/* most likely. We have to assume the last alternative. */ -/* If this is true, then we need to reduce EMAX by one because */ -/* there must be some way of representing zero in an implicit-bit */ -/* system. On machines like Cray, we are reducing EMAX by one */ -/* unnecessarily. */ - - --(*emax); - } - - if (*ieee) { - -/* Assume we are on an IEEE machine which reserves one exponent */ -/* for infinity and NaN. */ - - --(*emax); - } - -/* Now create RMAX, the largest machine number, which should */ -/* be equal to (1.0 - BETA**(-P)) * BETA**EMAX . */ - -/* First compute 1.0 - BETA**(-P), being careful that the */ -/* result is less than 1.0 . */ - - recbas = 1. / *beta; - z__ = *beta - 1.; - y = 0.; - i__1 = *p; - for (i__ = 1; i__ <= i__1; ++i__) { - z__ *= recbas; - if (y < 1.) { - oldy = y; - } - y = dlamc3_(&y, &z__); -/* L20: */ - } - if (y >= 1.) { - y = oldy; - } - -/* Now multiply by BETA**EMAX to get RMAX. */ - - i__1 = *emax; - for (i__ = 1; i__ <= i__1; ++i__) { - d__1 = y * *beta; - y = dlamc3_(&d__1, &c_b32); -/* L30: */ - } - - *rmax = y; - return 0; - -/* End of DLAMC5 */ + /* End of DLAMC5 */ } /* dlamc5_ */
diff --git a/lapack/dlapy2.c b/lapack/dlapy2.c index 6e88cd1..ef4cf57 100644 --- a/lapack/dlapy2.c +++ b/lapack/dlapy2.c
@@ -10,8 +10,8 @@ http://www.netlib.org/f2c/libf2c.zip */ -#include "f2c.h" #include "blaswrap.h" +#include "lapack_datatypes.h" doublereal dlapy2_(doublereal *x, doublereal *y) {
diff --git a/lapack/dlapy3.c b/lapack/dlapy3.c index 6aec3d0..91d5220 100644 --- a/lapack/dlapy3.c +++ b/lapack/dlapy3.c
@@ -10,8 +10,8 @@ http://www.netlib.org/f2c/libf2c.zip */ -#include "f2c.h" #include "blaswrap.h" +#include "lapack_datatypes.h" doublereal dlapy3_(doublereal *x, doublereal *y, doublereal *z__) {
diff --git a/lapack/dlarf.c b/lapack/dlarf.c index aba8a59..07dda21 100644 --- a/lapack/dlarf.c +++ b/lapack/dlarf.c
@@ -1,17 +1,17 @@ /* 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., + 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 + http://www.netlib.org/f2c/libf2c.zip */ -#include "f2c.h" #include "blaswrap.h" +#include "lapack_datatypes.h" /* Table of constant values */ @@ -19,175 +19,162 @@ static doublereal c_b5 = 0.; static integer c__1 = 1; -/* Subroutine */ int 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; +/* 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 */ int dger_(integer *, integer *, doublereal *, - doublereal *, integer *, doublereal *, integer *, doublereal *, - integer *); - extern logical lsame_(char *, char *); - extern /* Subroutine */ int dgemv_(char *, integer *, integer *, - doublereal *, doublereal *, integer *, doublereal *, integer *, - doublereal *, doublereal *, integer *); - integer lastc, lastv; - extern integer iladlc_(integer *, integer *, doublereal *, integer *), - iladlr_(integer *, integer *, doublereal *, integer *); + /* 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 */ -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ + /* .. Scalar Arguments .. */ + /* .. */ + /* .. Array Arguments .. */ + /* .. */ -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ + /* Purpose */ + /* ======= */ -/* 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 */ -/* 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' */ -/* H = I - tau * v * v' */ + /* where tau is a real scalar and v is a real vector. */ -/* where tau is a real scalar and v is a real vector. */ + /* If tau = 0, then H is taken to be the unit matrix. */ -/* If tau = 0, then H is taken to be the unit matrix. */ + /* Arguments */ + /* ========= */ -/* Arguments */ -/* ========= */ + /* SIDE (input) CHARACTER*1 */ + /* = 'L': form H * C */ + /* = 'R': form C * H */ -/* SIDE (input) CHARACTER*1 */ -/* = 'L': form H * C */ -/* = 'R': form C * H */ + /* M (input) INTEGER */ + /* The number of rows of the matrix C. */ -/* M (input) INTEGER */ -/* The number of rows of the matrix C. */ + /* N (input) INTEGER */ + /* The number of columns 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. */ -/* 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. */ -/* INCV (input) INTEGER */ -/* The increment between elements of v. INCV <> 0. */ + /* TAU (input) DOUBLE PRECISION */ + /* The value tau in the representation of H. */ -/* 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'. */ -/* 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). */ -/* 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' */ -/* WORK (workspace) DOUBLE PRECISION array, dimension */ -/* (N) if SIDE = 'L' */ -/* or (M) if SIDE = 'R' */ + /* ===================================================================== */ -/* ===================================================================== */ + /* .. Parameters .. */ + /* .. */ + /* .. Local Scalars .. */ + /* .. */ + /* .. External Subroutines .. */ + /* .. */ + /* .. External Functions .. */ + /* .. */ + /* .. Executable Statements .. */ -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ + /* Parameter adjustments */ + --v; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + --work; - /* 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. */ + /* 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) { - -/* 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); - } + lastv = *m; } 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); - } + lastv = *n; } - return 0; + 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 */ -/* End of DLARF */ + 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_ */
diff --git a/lapack/dlarfb.c b/lapack/dlarfb.c index 9833b69..3bf4d23 100644 --- a/lapack/dlarfb.c +++ b/lapack/dlarfb.c
@@ -1,17 +1,17 @@ /* dlarfb.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., + 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 + http://www.netlib.org/f2c/libf2c.zip */ -#include "f2c.h" #include "blaswrap.h" +#include "lapack_datatypes.h" /* Table of constant values */ @@ -19,756 +19,662 @@ static doublereal c_b14 = 1.; static doublereal c_b25 = -1.; -/* Subroutine */ int dlarfb_(char *side, char *trans, char *direct, char * - storev, integer *m, integer *n, integer *k, doublereal *v, integer * - ldv, doublereal *t, integer *ldt, doublereal *c__, integer *ldc, - doublereal *work, integer *ldwork) -{ - /* System generated locals */ - integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1, - work_offset, i__1, i__2; +/* Subroutine */ void dlarfb_(char *side, char *trans, char *direct, char *storev, integer *m, integer *n, integer *k, + doublereal *v, integer *ldv, doublereal *t, integer *ldt, doublereal *c__, integer *ldc, + doublereal *work, integer *ldwork) { + /* System generated locals */ + integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1, work_offset, i__1, i__2; - /* Local variables */ - integer i__, j; - extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, - integer *, doublereal *, doublereal *, integer *, doublereal *, - integer *, doublereal *, doublereal *, integer *); - extern logical lsame_(char *, char *); - integer lastc; - extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, - doublereal *, integer *), dtrmm_(char *, char *, char *, char *, - integer *, integer *, doublereal *, doublereal *, integer *, - doublereal *, integer *); - integer lastv; - extern integer iladlc_(integer *, integer *, doublereal *, integer *), - iladlr_(integer *, integer *, doublereal *, integer *); - char transt[1]; + /* Local variables */ + integer i__, j; + extern /* Subroutine */ void dgemm_(const char *, const char *, const integer *, const integer *, const integer *, + const doublereal *, const doublereal *, const integer *, const doublereal *, + const integer *, const doublereal *, doublereal *, const integer *); + extern logical lsame_(char *, char *); + integer lastc; + extern /* Subroutine */ void dcopy_(integer *, doublereal *, integer *, doublereal *, integer *), + dtrmm_(const char *, const char *, const char *, const char *, const integer *, const integer *, + const doublereal *, const doublereal *, const integer *, doublereal *, const integer *); + integer lastv; + extern integer iladlc_(integer *, integer *, doublereal *, integer *), + iladlr_(integer *, integer *, doublereal *, integer *); + char transt[1]; + /* -- LAPACK auxiliary routine (version 3.2) -- */ + /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ + /* November 2006 */ -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ + /* .. Scalar Arguments .. */ + /* .. */ + /* .. Array Arguments .. */ + /* .. */ -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ + /* Purpose */ + /* ======= */ -/* Purpose */ -/* ======= */ + /* DLARFB applies a real block reflector H or its transpose H' to a */ + /* real m by n matrix C, from either the left or the right. */ -/* DLARFB applies a real block reflector H or its transpose H' to a */ -/* real m by n matrix C, from either the left or the right. */ + /* Arguments */ + /* ========= */ -/* Arguments */ -/* ========= */ + /* SIDE (input) CHARACTER*1 */ + /* = 'L': apply H or H' from the Left */ + /* = 'R': apply H or H' from the Right */ -/* SIDE (input) CHARACTER*1 */ -/* = 'L': apply H or H' from the Left */ -/* = 'R': apply H or H' from the Right */ + /* TRANS (input) CHARACTER*1 */ + /* = 'N': apply H (No transpose) */ + /* = 'T': apply H' (Transpose) */ -/* TRANS (input) CHARACTER*1 */ -/* = 'N': apply H (No transpose) */ -/* = 'T': apply H' (Transpose) */ + /* DIRECT (input) CHARACTER*1 */ + /* Indicates how H is formed from a product of elementary */ + /* reflectors */ + /* = 'F': H = H(1) H(2) . . . H(k) (Forward) */ + /* = 'B': H = H(k) . . . H(2) H(1) (Backward) */ -/* DIRECT (input) CHARACTER*1 */ -/* Indicates how H is formed from a product of elementary */ -/* reflectors */ -/* = 'F': H = H(1) H(2) . . . H(k) (Forward) */ -/* = 'B': H = H(k) . . . H(2) H(1) (Backward) */ + /* STOREV (input) CHARACTER*1 */ + /* Indicates how the vectors which define the elementary */ + /* reflectors are stored: */ + /* = 'C': Columnwise */ + /* = 'R': Rowwise */ -/* STOREV (input) CHARACTER*1 */ -/* Indicates how the vectors which define the elementary */ -/* reflectors are stored: */ -/* = 'C': Columnwise */ -/* = 'R': Rowwise */ + /* M (input) INTEGER */ + /* The number of rows of the matrix C. */ -/* M (input) INTEGER */ -/* The number of rows of the matrix C. */ + /* N (input) INTEGER */ + /* The number of columns of the matrix C. */ -/* N (input) INTEGER */ -/* The number of columns of the matrix C. */ + /* K (input) INTEGER */ + /* The order of the matrix T (= the number of elementary */ + /* reflectors whose product defines the block reflector). */ -/* K (input) INTEGER */ -/* The order of the matrix T (= the number of elementary */ -/* reflectors whose product defines the block reflector). */ + /* V (input) DOUBLE PRECISION array, dimension */ + /* (LDV,K) if STOREV = 'C' */ + /* (LDV,M) if STOREV = 'R' and SIDE = 'L' */ + /* (LDV,N) if STOREV = 'R' and SIDE = 'R' */ + /* The matrix V. See further details. */ -/* V (input) DOUBLE PRECISION array, dimension */ -/* (LDV,K) if STOREV = 'C' */ -/* (LDV,M) if STOREV = 'R' and SIDE = 'L' */ -/* (LDV,N) if STOREV = 'R' and SIDE = 'R' */ -/* The matrix V. See further details. */ + /* LDV (input) INTEGER */ + /* The leading dimension of the array V. */ + /* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); */ + /* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); */ + /* if STOREV = 'R', LDV >= K. */ -/* LDV (input) INTEGER */ -/* The leading dimension of the array V. */ -/* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); */ -/* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); */ -/* if STOREV = 'R', LDV >= K. */ + /* T (input) DOUBLE PRECISION array, dimension (LDT,K) */ + /* The triangular k by k matrix T in the representation of the */ + /* block reflector. */ -/* T (input) DOUBLE PRECISION array, dimension (LDT,K) */ -/* The triangular k by k matrix T in the representation of the */ -/* block reflector. */ + /* LDT (input) INTEGER */ + /* The leading dimension of the array T. LDT >= K. */ -/* LDT (input) INTEGER */ -/* The leading dimension of the array T. LDT >= K. */ + /* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */ + /* On entry, the m by n matrix C. */ + /* On exit, C is overwritten by H*C or H'*C or C*H or C*H'. */ -/* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */ -/* On entry, the m by n matrix C. */ -/* On exit, C is overwritten by H*C or H'*C or C*H or C*H'. */ + /* LDC (input) INTEGER */ + /* The leading dimension of the array C. LDA >= max(1,M). */ -/* LDC (input) INTEGER */ -/* The leading dimension of the array C. LDA >= max(1,M). */ + /* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,K) */ -/* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,K) */ + /* LDWORK (input) INTEGER */ + /* The leading dimension of the array WORK. */ + /* If SIDE = 'L', LDWORK >= max(1,N); */ + /* if SIDE = 'R', LDWORK >= max(1,M). */ -/* LDWORK (input) INTEGER */ -/* The leading dimension of the array WORK. */ -/* If SIDE = 'L', LDWORK >= max(1,N); */ -/* if SIDE = 'R', LDWORK >= max(1,M). */ + /* ===================================================================== */ -/* ===================================================================== */ + /* .. Parameters .. */ + /* .. */ + /* .. Local Scalars .. */ + /* .. */ + /* .. External Functions .. */ + /* .. */ + /* .. External Subroutines .. */ + /* .. */ + /* .. Executable Statements .. */ -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Executable Statements .. */ + /* Quick return if possible */ -/* Quick return if possible */ + /* Parameter adjustments */ + v_dim1 = *ldv; + v_offset = 1 + v_dim1; + v -= v_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1; + t -= t_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + work_dim1 = *ldwork; + work_offset = 1 + work_dim1; + work -= work_offset; - /* Parameter adjustments */ - v_dim1 = *ldv; - v_offset = 1 + v_dim1; - v -= v_offset; - t_dim1 = *ldt; - t_offset = 1 + t_dim1; - t -= t_offset; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - work_dim1 = *ldwork; - work_offset = 1 + work_dim1; - work -= work_offset; + /* Function Body */ + if (*m <= 0 || *n <= 0) { + return; + } - /* Function Body */ - if (*m <= 0 || *n <= 0) { - return 0; - } + if (lsame_(trans, "N")) { + *(unsigned char *)transt = 'T'; + } else { + *(unsigned char *)transt = 'N'; + } - if (lsame_(trans, "N")) { - *(unsigned char *)transt = 'T'; + if (lsame_(storev, "C")) { + if (lsame_(direct, "F")) { + /* Let V = ( V1 ) (first K rows) */ + /* ( V2 ) */ + /* where V1 is unit lower triangular. */ + + if (lsame_(side, "L")) { + /* Form H * C or H' * C where C = ( C1 ) */ + /* ( C2 ) */ + + /* Computing MAX */ + i__1 = *k, i__2 = iladlr_(m, k, &v[v_offset], ldv); + lastv = max(i__1, i__2); + lastc = iladlc_(&lastv, n, &c__[c_offset], ldc); + + /* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) */ + + /* W := C1' */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dcopy_(&lastc, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1], &c__1); + /* L10: */ + } + + /* W := W * V1 */ + + dtrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &c_b14, &v[v_offset], ldv, &work[work_offset], + ldwork); + if (lastv > *k) { + /* W := W + C2'*V2 */ + + i__1 = lastv - *k; + dgemm_("Transpose", "No transpose", &lastc, k, &i__1, &c_b14, &c__[*k + 1 + c_dim1], ldc, &v[*k + 1 + v_dim1], + ldv, &c_b14, &work[work_offset], ldwork); + } + + /* W := W * T' or W * T */ + + dtrmm_("Right", "Upper", transt, "Non-unit", &lastc, k, &c_b14, &t[t_offset], ldt, &work[work_offset], ldwork); + + /* C := C - V * W' */ + + if (lastv > *k) { + /* C2 := C2 - V2 * W' */ + + i__1 = lastv - *k; + dgemm_("No transpose", "Transpose", &i__1, &lastc, k, &c_b25, &v[*k + 1 + v_dim1], ldv, &work[work_offset], + ldwork, &c_b14, &c__[*k + 1 + c_dim1], ldc); + } + + /* W := W * V1' */ + + dtrmm_("Right", "Lower", "Transpose", "Unit", &lastc, k, &c_b14, &v[v_offset], ldv, &work[work_offset], ldwork); + + /* C1 := C1 - W' */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = lastc; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[j + i__ * c_dim1] -= work[i__ + j * work_dim1]; + /* L20: */ + } + /* L30: */ + } + + } else if (lsame_(side, "R")) { + /* Form C * H or C * H' where C = ( C1 C2 ) */ + + /* Computing MAX */ + i__1 = *k, i__2 = iladlr_(n, k, &v[v_offset], ldv); + lastv = max(i__1, i__2); + lastc = iladlr_(m, &lastv, &c__[c_offset], ldc); + + /* W := C * V = (C1*V1 + C2*V2) (stored in WORK) */ + + /* W := C1 */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dcopy_(&lastc, &c__[j * c_dim1 + 1], &c__1, &work[j * work_dim1 + 1], &c__1); + /* L40: */ + } + + /* W := W * V1 */ + + dtrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &c_b14, &v[v_offset], ldv, &work[work_offset], + ldwork); + if (lastv > *k) { + /* W := W + C2 * V2 */ + + i__1 = lastv - *k; + dgemm_("No transpose", "No transpose", &lastc, k, &i__1, &c_b14, &c__[(*k + 1) * c_dim1 + 1], ldc, + &v[*k + 1 + v_dim1], ldv, &c_b14, &work[work_offset], ldwork); + } + + /* W := W * T or W * T' */ + + dtrmm_("Right", "Upper", trans, "Non-unit", &lastc, k, &c_b14, &t[t_offset], ldt, &work[work_offset], ldwork); + + /* C := C - W * V' */ + + if (lastv > *k) { + /* C2 := C2 - W * V2' */ + + i__1 = lastv - *k; + dgemm_("No transpose", "Transpose", &lastc, &i__1, k, &c_b25, &work[work_offset], ldwork, &v[*k + 1 + v_dim1], + ldv, &c_b14, &c__[(*k + 1) * c_dim1 + 1], ldc); + } + + /* W := W * V1' */ + + dtrmm_("Right", "Lower", "Transpose", "Unit", &lastc, k, &c_b14, &v[v_offset], ldv, &work[work_offset], ldwork); + + /* C1 := C1 - W */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = lastc; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1]; + /* L50: */ + } + /* L60: */ + } + } + } else { - *(unsigned char *)transt = 'N'; + /* Let V = ( V1 ) */ + /* ( V2 ) (last K rows) */ + /* where V2 is unit upper triangular. */ + + if (lsame_(side, "L")) { + /* Form H * C or H' * C where C = ( C1 ) */ + /* ( C2 ) */ + + /* Computing MAX */ + i__1 = *k, i__2 = iladlr_(m, k, &v[v_offset], ldv); + lastv = max(i__1, i__2); + lastc = iladlc_(&lastv, n, &c__[c_offset], ldc); + + /* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) */ + + /* W := C2' */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dcopy_(&lastc, &c__[lastv - *k + j + c_dim1], ldc, &work[j * work_dim1 + 1], &c__1); + /* L70: */ + } + + /* W := W * V2 */ + + dtrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &c_b14, &v[lastv - *k + 1 + v_dim1], ldv, + &work[work_offset], ldwork); + if (lastv > *k) { + /* W := W + C1'*V1 */ + + i__1 = lastv - *k; + dgemm_("Transpose", "No transpose", &lastc, k, &i__1, &c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, + &work[work_offset], ldwork); + } + + /* W := W * T' or W * T */ + + dtrmm_("Right", "Lower", transt, "Non-unit", &lastc, k, &c_b14, &t[t_offset], ldt, &work[work_offset], ldwork); + + /* C := C - V * W' */ + + if (lastv > *k) { + /* C1 := C1 - V1 * W' */ + + i__1 = lastv - *k; + dgemm_("No transpose", "Transpose", &i__1, &lastc, k, &c_b25, &v[v_offset], ldv, &work[work_offset], ldwork, + &c_b14, &c__[c_offset], ldc); + } + + /* W := W * V2' */ + + dtrmm_("Right", "Upper", "Transpose", "Unit", &lastc, k, &c_b14, &v[lastv - *k + 1 + v_dim1], ldv, + &work[work_offset], ldwork); + + /* C2 := C2 - W' */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = lastc; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[lastv - *k + j + i__ * c_dim1] -= work[i__ + j * work_dim1]; + /* L80: */ + } + /* L90: */ + } + + } else if (lsame_(side, "R")) { + /* Form C * H or C * H' where C = ( C1 C2 ) */ + + /* Computing MAX */ + i__1 = *k, i__2 = iladlr_(n, k, &v[v_offset], ldv); + lastv = max(i__1, i__2); + lastc = iladlr_(m, &lastv, &c__[c_offset], ldc); + + /* W := C * V = (C1*V1 + C2*V2) (stored in WORK) */ + + /* W := C2 */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dcopy_(&lastc, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, &work[j * work_dim1 + 1], &c__1); + /* L100: */ + } + + /* W := W * V2 */ + + dtrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &c_b14, &v[lastv - *k + 1 + v_dim1], ldv, + &work[work_offset], ldwork); + if (lastv > *k) { + /* W := W + C1 * V1 */ + + i__1 = lastv - *k; + dgemm_("No transpose", "No transpose", &lastc, k, &i__1, &c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, + &c_b14, &work[work_offset], ldwork); + } + + /* W := W * T or W * T' */ + + dtrmm_("Right", "Lower", trans, "Non-unit", &lastc, k, &c_b14, &t[t_offset], ldt, &work[work_offset], ldwork); + + /* C := C - W * V' */ + + if (lastv > *k) { + /* C1 := C1 - W * V1' */ + + i__1 = lastv - *k; + dgemm_("No transpose", "Transpose", &lastc, &i__1, k, &c_b25, &work[work_offset], ldwork, &v[v_offset], ldv, + &c_b14, &c__[c_offset], ldc); + } + + /* W := W * V2' */ + + dtrmm_("Right", "Upper", "Transpose", "Unit", &lastc, k, &c_b14, &v[lastv - *k + 1 + v_dim1], ldv, + &work[work_offset], ldwork); + + /* C2 := C2 - W */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = lastc; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + (lastv - *k + j) * c_dim1] -= work[i__ + j * work_dim1]; + /* L110: */ + } + /* L120: */ + } + } } - if (lsame_(storev, "C")) { + } else if (lsame_(storev, "R")) { + if (lsame_(direct, "F")) { + /* Let V = ( V1 V2 ) (V1: first K columns) */ + /* where V1 is unit upper triangular. */ - if (lsame_(direct, "F")) { + if (lsame_(side, "L")) { + /* Form H * C or H' * C where C = ( C1 ) */ + /* ( C2 ) */ -/* Let V = ( V1 ) (first K rows) */ -/* ( V2 ) */ -/* where V1 is unit lower triangular. */ + /* Computing MAX */ + i__1 = *k, i__2 = iladlc_(k, m, &v[v_offset], ldv); + lastv = max(i__1, i__2); + lastc = iladlc_(&lastv, n, &c__[c_offset], ldc); - if (lsame_(side, "L")) { + /* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) */ -/* Form H * C or H' * C where C = ( C1 ) */ -/* ( C2 ) */ + /* W := C1' */ -/* Computing MAX */ - i__1 = *k, i__2 = iladlr_(m, k, &v[v_offset], ldv); - lastv = max(i__1,i__2); - lastc = iladlc_(&lastv, n, &c__[c_offset], ldc); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dcopy_(&lastc, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1], &c__1); + /* L130: */ + } -/* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) */ + /* W := W * V1' */ -/* W := C1' */ + dtrmm_("Right", "Upper", "Transpose", "Unit", &lastc, k, &c_b14, &v[v_offset], ldv, &work[work_offset], ldwork); + if (lastv > *k) { + /* W := W + C2'*V2' */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - dcopy_(&lastc, &c__[j + c_dim1], ldc, &work[j * work_dim1 - + 1], &c__1); -/* L10: */ - } + i__1 = lastv - *k; + dgemm_("Transpose", "Transpose", &lastc, k, &i__1, &c_b14, &c__[*k + 1 + c_dim1], ldc, + &v[(*k + 1) * v_dim1 + 1], ldv, &c_b14, &work[work_offset], ldwork); + } -/* W := W * V1 */ + /* W := W * T' or W * T */ - dtrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, & - c_b14, &v[v_offset], ldv, &work[work_offset], ldwork); - if (lastv > *k) { + dtrmm_("Right", "Upper", transt, "Non-unit", &lastc, k, &c_b14, &t[t_offset], ldt, &work[work_offset], ldwork); -/* W := W + C2'*V2 */ + /* C := C - V' * W' */ - i__1 = lastv - *k; - dgemm_("Transpose", "No transpose", &lastc, k, &i__1, & - c_b14, &c__[*k + 1 + c_dim1], ldc, &v[*k + 1 + - v_dim1], ldv, &c_b14, &work[work_offset], ldwork); - } + if (lastv > *k) { + /* C2 := C2 - V2' * W' */ -/* W := W * T' or W * T */ + i__1 = lastv - *k; + dgemm_("Transpose", "Transpose", &i__1, &lastc, k, &c_b25, &v[(*k + 1) * v_dim1 + 1], ldv, &work[work_offset], + ldwork, &c_b14, &c__[*k + 1 + c_dim1], ldc); + } - dtrmm_("Right", "Upper", transt, "Non-unit", &lastc, k, & - c_b14, &t[t_offset], ldt, &work[work_offset], ldwork); + /* W := W * V1 */ -/* C := C - V * W' */ + dtrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &c_b14, &v[v_offset], ldv, &work[work_offset], + ldwork); - if (lastv > *k) { + /* C1 := C1 - W' */ -/* C2 := C2 - V2 * W' */ + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = lastc; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[j + i__ * c_dim1] -= work[i__ + j * work_dim1]; + /* L140: */ + } + /* L150: */ + } - i__1 = lastv - *k; - dgemm_("No transpose", "Transpose", &i__1, &lastc, k, & - c_b25, &v[*k + 1 + v_dim1], ldv, &work[ - work_offset], ldwork, &c_b14, &c__[*k + 1 + - c_dim1], ldc); - } + } else if (lsame_(side, "R")) { + /* Form C * H or C * H' where C = ( C1 C2 ) */ -/* W := W * V1' */ + /* Computing MAX */ + i__1 = *k, i__2 = iladlc_(k, n, &v[v_offset], ldv); + lastv = max(i__1, i__2); + lastc = iladlr_(m, &lastv, &c__[c_offset], ldc); - dtrmm_("Right", "Lower", "Transpose", "Unit", &lastc, k, & - c_b14, &v[v_offset], ldv, &work[work_offset], ldwork); + /* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) */ -/* C1 := C1 - W' */ + /* W := C1 */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = lastc; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[j + i__ * c_dim1] -= work[i__ + j * work_dim1]; -/* L20: */ - } -/* L30: */ - } + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dcopy_(&lastc, &c__[j * c_dim1 + 1], &c__1, &work[j * work_dim1 + 1], &c__1); + /* L160: */ + } - } else if (lsame_(side, "R")) { + /* W := W * V1' */ -/* Form C * H or C * H' where C = ( C1 C2 ) */ + dtrmm_("Right", "Upper", "Transpose", "Unit", &lastc, k, &c_b14, &v[v_offset], ldv, &work[work_offset], ldwork); + if (lastv > *k) { + /* W := W + C2 * V2' */ -/* Computing MAX */ - i__1 = *k, i__2 = iladlr_(n, k, &v[v_offset], ldv); - lastv = max(i__1,i__2); - lastc = iladlr_(m, &lastv, &c__[c_offset], ldc); + i__1 = lastv - *k; + dgemm_("No transpose", "Transpose", &lastc, k, &i__1, &c_b14, &c__[(*k + 1) * c_dim1 + 1], ldc, + &v[(*k + 1) * v_dim1 + 1], ldv, &c_b14, &work[work_offset], ldwork); + } -/* W := C * V = (C1*V1 + C2*V2) (stored in WORK) */ + /* W := W * T or W * T' */ -/* W := C1 */ + dtrmm_("Right", "Upper", trans, "Non-unit", &lastc, k, &c_b14, &t[t_offset], ldt, &work[work_offset], ldwork); - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - dcopy_(&lastc, &c__[j * c_dim1 + 1], &c__1, &work[j * - work_dim1 + 1], &c__1); -/* L40: */ - } + /* C := C - W * V */ -/* W := W * V1 */ + if (lastv > *k) { + /* C2 := C2 - W * V2 */ - dtrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, & - c_b14, &v[v_offset], ldv, &work[work_offset], ldwork); - if (lastv > *k) { + i__1 = lastv - *k; + dgemm_("No transpose", "No transpose", &lastc, &i__1, k, &c_b25, &work[work_offset], ldwork, + &v[(*k + 1) * v_dim1 + 1], ldv, &c_b14, &c__[(*k + 1) * c_dim1 + 1], ldc); + } -/* W := W + C2 * V2 */ + /* W := W * V1 */ - i__1 = lastv - *k; - dgemm_("No transpose", "No transpose", &lastc, k, &i__1, & - c_b14, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[*k + - 1 + v_dim1], ldv, &c_b14, &work[work_offset], - ldwork); - } + dtrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &c_b14, &v[v_offset], ldv, &work[work_offset], + ldwork); -/* W := W * T or W * T' */ + /* C1 := C1 - W */ - dtrmm_("Right", "Upper", trans, "Non-unit", &lastc, k, &c_b14, - &t[t_offset], ldt, &work[work_offset], ldwork); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = lastc; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1]; + /* L170: */ + } + /* L180: */ + } + } -/* C := C - W * V' */ + } else { + /* Let V = ( V1 V2 ) (V2: last K columns) */ + /* where V2 is unit lower triangular. */ - if (lastv > *k) { + if (lsame_(side, "L")) { + /* Form H * C or H' * C where C = ( C1 ) */ + /* ( C2 ) */ -/* C2 := C2 - W * V2' */ + /* Computing MAX */ + i__1 = *k, i__2 = iladlc_(k, m, &v[v_offset], ldv); + lastv = max(i__1, i__2); + lastc = iladlc_(&lastv, n, &c__[c_offset], ldc); - i__1 = lastv - *k; - dgemm_("No transpose", "Transpose", &lastc, &i__1, k, & - c_b25, &work[work_offset], ldwork, &v[*k + 1 + - v_dim1], ldv, &c_b14, &c__[(*k + 1) * c_dim1 + 1], - ldc); - } + /* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) */ -/* W := W * V1' */ + /* W := C2' */ - dtrmm_("Right", "Lower", "Transpose", "Unit", &lastc, k, & - c_b14, &v[v_offset], ldv, &work[work_offset], ldwork); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dcopy_(&lastc, &c__[lastv - *k + j + c_dim1], ldc, &work[j * work_dim1 + 1], &c__1); + /* L190: */ + } -/* C1 := C1 - W */ + /* W := W * V2' */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = lastc; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1]; -/* L50: */ - } -/* L60: */ - } - } + dtrmm_("Right", "Lower", "Transpose", "Unit", &lastc, k, &c_b14, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, + &work[work_offset], ldwork); + if (lastv > *k) { + /* W := W + C1'*V1' */ - } else { + i__1 = lastv - *k; + dgemm_("Transpose", "Transpose", &lastc, k, &i__1, &c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, + &work[work_offset], ldwork); + } -/* Let V = ( V1 ) */ -/* ( V2 ) (last K rows) */ -/* where V2 is unit upper triangular. */ + /* W := W * T' or W * T */ - if (lsame_(side, "L")) { + dtrmm_("Right", "Lower", transt, "Non-unit", &lastc, k, &c_b14, &t[t_offset], ldt, &work[work_offset], ldwork); -/* Form H * C or H' * C where C = ( C1 ) */ -/* ( C2 ) */ + /* C := C - V' * W' */ -/* Computing MAX */ - i__1 = *k, i__2 = iladlr_(m, k, &v[v_offset], ldv); - lastv = max(i__1,i__2); - lastc = iladlc_(&lastv, n, &c__[c_offset], ldc); + if (lastv > *k) { + /* C1 := C1 - V1' * W' */ -/* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) */ + i__1 = lastv - *k; + dgemm_("Transpose", "Transpose", &i__1, &lastc, k, &c_b25, &v[v_offset], ldv, &work[work_offset], ldwork, + &c_b14, &c__[c_offset], ldc); + } -/* W := C2' */ + /* W := W * V2 */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - dcopy_(&lastc, &c__[lastv - *k + j + c_dim1], ldc, &work[ - j * work_dim1 + 1], &c__1); -/* L70: */ - } + dtrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &c_b14, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, + &work[work_offset], ldwork); -/* W := W * V2 */ + /* C2 := C2 - W' */ - dtrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, & - c_b14, &v[lastv - *k + 1 + v_dim1], ldv, &work[ - work_offset], ldwork); - if (lastv > *k) { + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = lastc; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[lastv - *k + j + i__ * c_dim1] -= work[i__ + j * work_dim1]; + /* L200: */ + } + /* L210: */ + } -/* W := W + C1'*V1 */ + } else if (lsame_(side, "R")) { + /* Form C * H or C * H' where C = ( C1 C2 ) */ - i__1 = lastv - *k; - dgemm_("Transpose", "No transpose", &lastc, k, &i__1, & - c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, & - c_b14, &work[work_offset], ldwork); - } + /* Computing MAX */ + i__1 = *k, i__2 = iladlc_(k, n, &v[v_offset], ldv); + lastv = max(i__1, i__2); + lastc = iladlr_(m, &lastv, &c__[c_offset], ldc); -/* W := W * T' or W * T */ + /* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) */ - dtrmm_("Right", "Lower", transt, "Non-unit", &lastc, k, & - c_b14, &t[t_offset], ldt, &work[work_offset], ldwork); + /* W := C2 */ -/* C := C - V * W' */ + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dcopy_(&lastc, &c__[(lastv - *k + j) * c_dim1 + 1], &c__1, &work[j * work_dim1 + 1], &c__1); + /* L220: */ + } - if (lastv > *k) { + /* W := W * V2' */ -/* C1 := C1 - V1 * W' */ + dtrmm_("Right", "Lower", "Transpose", "Unit", &lastc, k, &c_b14, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, + &work[work_offset], ldwork); + if (lastv > *k) { + /* W := W + C1 * V1' */ - i__1 = lastv - *k; - dgemm_("No transpose", "Transpose", &i__1, &lastc, k, & - c_b25, &v[v_offset], ldv, &work[work_offset], - ldwork, &c_b14, &c__[c_offset], ldc); - } + i__1 = lastv - *k; + dgemm_("No transpose", "Transpose", &lastc, k, &i__1, &c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, + &work[work_offset], ldwork); + } -/* W := W * V2' */ + /* W := W * T or W * T' */ - dtrmm_("Right", "Upper", "Transpose", "Unit", &lastc, k, & - c_b14, &v[lastv - *k + 1 + v_dim1], ldv, &work[ - work_offset], ldwork); + dtrmm_("Right", "Lower", trans, "Non-unit", &lastc, k, &c_b14, &t[t_offset], ldt, &work[work_offset], ldwork); -/* C2 := C2 - W' */ + /* C := C - W * V */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = lastc; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[lastv - *k + j + i__ * c_dim1] -= work[i__ + j * - work_dim1]; -/* L80: */ - } -/* L90: */ - } + if (lastv > *k) { + /* C1 := C1 - W * V1 */ - } else if (lsame_(side, "R")) { + i__1 = lastv - *k; + dgemm_("No transpose", "No transpose", &lastc, &i__1, k, &c_b25, &work[work_offset], ldwork, &v[v_offset], + ldv, &c_b14, &c__[c_offset], ldc); + } -/* Form C * H or C * H' where C = ( C1 C2 ) */ + /* W := W * V2 */ -/* Computing MAX */ - i__1 = *k, i__2 = iladlr_(n, k, &v[v_offset], ldv); - lastv = max(i__1,i__2); - lastc = iladlr_(m, &lastv, &c__[c_offset], ldc); + dtrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &c_b14, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, + &work[work_offset], ldwork); -/* W := C * V = (C1*V1 + C2*V2) (stored in WORK) */ + /* C1 := C1 - W */ -/* W := C2 */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - dcopy_(&lastc, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, & - work[j * work_dim1 + 1], &c__1); -/* L100: */ - } - -/* W := W * V2 */ - - dtrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, & - c_b14, &v[lastv - *k + 1 + v_dim1], ldv, &work[ - work_offset], ldwork); - if (lastv > *k) { - -/* W := W + C1 * V1 */ - - i__1 = lastv - *k; - dgemm_("No transpose", "No transpose", &lastc, k, &i__1, & - c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, & - c_b14, &work[work_offset], ldwork); - } - -/* W := W * T or W * T' */ - - dtrmm_("Right", "Lower", trans, "Non-unit", &lastc, k, &c_b14, - &t[t_offset], ldt, &work[work_offset], ldwork); - -/* C := C - W * V' */ - - if (lastv > *k) { - -/* C1 := C1 - W * V1' */ - - i__1 = lastv - *k; - dgemm_("No transpose", "Transpose", &lastc, &i__1, k, & - c_b25, &work[work_offset], ldwork, &v[v_offset], - ldv, &c_b14, &c__[c_offset], ldc); - } - -/* W := W * V2' */ - - dtrmm_("Right", "Upper", "Transpose", "Unit", &lastc, k, & - c_b14, &v[lastv - *k + 1 + v_dim1], ldv, &work[ - work_offset], ldwork); - -/* C2 := C2 - W */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = lastc; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + (lastv - *k + j) * c_dim1] -= work[i__ + j * - work_dim1]; -/* L110: */ - } -/* L120: */ - } - } - } - - } else if (lsame_(storev, "R")) { - - if (lsame_(direct, "F")) { - -/* Let V = ( V1 V2 ) (V1: first K columns) */ -/* where V1 is unit upper triangular. */ - - if (lsame_(side, "L")) { - -/* Form H * C or H' * C where C = ( C1 ) */ -/* ( C2 ) */ - -/* Computing MAX */ - i__1 = *k, i__2 = iladlc_(k, m, &v[v_offset], ldv); - lastv = max(i__1,i__2); - lastc = iladlc_(&lastv, n, &c__[c_offset], ldc); - -/* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) */ - -/* W := C1' */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - dcopy_(&lastc, &c__[j + c_dim1], ldc, &work[j * work_dim1 - + 1], &c__1); -/* L130: */ - } - -/* W := W * V1' */ - - dtrmm_("Right", "Upper", "Transpose", "Unit", &lastc, k, & - c_b14, &v[v_offset], ldv, &work[work_offset], ldwork); - if (lastv > *k) { - -/* W := W + C2'*V2' */ - - i__1 = lastv - *k; - dgemm_("Transpose", "Transpose", &lastc, k, &i__1, &c_b14, - &c__[*k + 1 + c_dim1], ldc, &v[(*k + 1) * v_dim1 - + 1], ldv, &c_b14, &work[work_offset], ldwork); - } - -/* W := W * T' or W * T */ - - dtrmm_("Right", "Upper", transt, "Non-unit", &lastc, k, & - c_b14, &t[t_offset], ldt, &work[work_offset], ldwork); - -/* C := C - V' * W' */ - - if (lastv > *k) { - -/* C2 := C2 - V2' * W' */ - - i__1 = lastv - *k; - dgemm_("Transpose", "Transpose", &i__1, &lastc, k, &c_b25, - &v[(*k + 1) * v_dim1 + 1], ldv, &work[ - work_offset], ldwork, &c_b14, &c__[*k + 1 + - c_dim1], ldc); - } - -/* W := W * V1 */ - - dtrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, & - c_b14, &v[v_offset], ldv, &work[work_offset], ldwork); - -/* C1 := C1 - W' */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = lastc; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[j + i__ * c_dim1] -= work[i__ + j * work_dim1]; -/* L140: */ - } -/* L150: */ - } - - } else if (lsame_(side, "R")) { - -/* Form C * H or C * H' where C = ( C1 C2 ) */ - -/* Computing MAX */ - i__1 = *k, i__2 = iladlc_(k, n, &v[v_offset], ldv); - lastv = max(i__1,i__2); - lastc = iladlr_(m, &lastv, &c__[c_offset], ldc); - -/* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) */ - -/* W := C1 */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - dcopy_(&lastc, &c__[j * c_dim1 + 1], &c__1, &work[j * - work_dim1 + 1], &c__1); -/* L160: */ - } - -/* W := W * V1' */ - - dtrmm_("Right", "Upper", "Transpose", "Unit", &lastc, k, & - c_b14, &v[v_offset], ldv, &work[work_offset], ldwork); - if (lastv > *k) { - -/* W := W + C2 * V2' */ - - i__1 = lastv - *k; - dgemm_("No transpose", "Transpose", &lastc, k, &i__1, & - c_b14, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[(*k + - 1) * v_dim1 + 1], ldv, &c_b14, &work[work_offset], - ldwork); - } - -/* W := W * T or W * T' */ - - dtrmm_("Right", "Upper", trans, "Non-unit", &lastc, k, &c_b14, - &t[t_offset], ldt, &work[work_offset], ldwork); - -/* C := C - W * V */ - - if (lastv > *k) { - -/* C2 := C2 - W * V2 */ - - i__1 = lastv - *k; - dgemm_("No transpose", "No transpose", &lastc, &i__1, k, & - c_b25, &work[work_offset], ldwork, &v[(*k + 1) * - v_dim1 + 1], ldv, &c_b14, &c__[(*k + 1) * c_dim1 - + 1], ldc); - } - -/* W := W * V1 */ - - dtrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, & - c_b14, &v[v_offset], ldv, &work[work_offset], ldwork); - -/* C1 := C1 - W */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = lastc; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1]; -/* L170: */ - } -/* L180: */ - } - - } - - } else { - -/* Let V = ( V1 V2 ) (V2: last K columns) */ -/* where V2 is unit lower triangular. */ - - if (lsame_(side, "L")) { - -/* Form H * C or H' * C where C = ( C1 ) */ -/* ( C2 ) */ - -/* Computing MAX */ - i__1 = *k, i__2 = iladlc_(k, m, &v[v_offset], ldv); - lastv = max(i__1,i__2); - lastc = iladlc_(&lastv, n, &c__[c_offset], ldc); - -/* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) */ - -/* W := C2' */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - dcopy_(&lastc, &c__[lastv - *k + j + c_dim1], ldc, &work[ - j * work_dim1 + 1], &c__1); -/* L190: */ - } - -/* W := W * V2' */ - - dtrmm_("Right", "Lower", "Transpose", "Unit", &lastc, k, & - c_b14, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[ - work_offset], ldwork); - if (lastv > *k) { - -/* W := W + C1'*V1' */ - - i__1 = lastv - *k; - dgemm_("Transpose", "Transpose", &lastc, k, &i__1, &c_b14, - &c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, & - work[work_offset], ldwork); - } - -/* W := W * T' or W * T */ - - dtrmm_("Right", "Lower", transt, "Non-unit", &lastc, k, & - c_b14, &t[t_offset], ldt, &work[work_offset], ldwork); - -/* C := C - V' * W' */ - - if (lastv > *k) { - -/* C1 := C1 - V1' * W' */ - - i__1 = lastv - *k; - dgemm_("Transpose", "Transpose", &i__1, &lastc, k, &c_b25, - &v[v_offset], ldv, &work[work_offset], ldwork, & - c_b14, &c__[c_offset], ldc); - } - -/* W := W * V2 */ - - dtrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, & - c_b14, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[ - work_offset], ldwork); - -/* C2 := C2 - W' */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = lastc; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[lastv - *k + j + i__ * c_dim1] -= work[i__ + j * - work_dim1]; -/* L200: */ - } -/* L210: */ - } - - } else if (lsame_(side, "R")) { - -/* Form C * H or C * H' where C = ( C1 C2 ) */ - -/* Computing MAX */ - i__1 = *k, i__2 = iladlc_(k, n, &v[v_offset], ldv); - lastv = max(i__1,i__2); - lastc = iladlr_(m, &lastv, &c__[c_offset], ldc); - -/* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) */ - -/* W := C2 */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - dcopy_(&lastc, &c__[(lastv - *k + j) * c_dim1 + 1], &c__1, - &work[j * work_dim1 + 1], &c__1); -/* L220: */ - } - -/* W := W * V2' */ - - dtrmm_("Right", "Lower", "Transpose", "Unit", &lastc, k, & - c_b14, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[ - work_offset], ldwork); - if (lastv > *k) { - -/* W := W + C1 * V1' */ - - i__1 = lastv - *k; - dgemm_("No transpose", "Transpose", &lastc, k, &i__1, & - c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, & - c_b14, &work[work_offset], ldwork); - } - -/* W := W * T or W * T' */ - - dtrmm_("Right", "Lower", trans, "Non-unit", &lastc, k, &c_b14, - &t[t_offset], ldt, &work[work_offset], ldwork); - -/* C := C - W * V */ - - if (lastv > *k) { - -/* C1 := C1 - W * V1 */ - - i__1 = lastv - *k; - dgemm_("No transpose", "No transpose", &lastc, &i__1, k, & - c_b25, &work[work_offset], ldwork, &v[v_offset], - ldv, &c_b14, &c__[c_offset], ldc); - } - -/* W := W * V2 */ - - dtrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, & - c_b14, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[ - work_offset], ldwork); - -/* C1 := C1 - W */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = lastc; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + (lastv - *k + j) * c_dim1] -= work[i__ + j * - work_dim1]; -/* L230: */ - } -/* L240: */ - } - - } - - } + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = lastc; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + (lastv - *k + j) * c_dim1] -= work[i__ + j * work_dim1]; + /* L230: */ + } + /* L240: */ + } + } } + } - return 0; - -/* End of DLARFB */ + /* End of DLARFB */ } /* dlarfb_ */
diff --git a/lapack/dlarfg.c b/lapack/dlarfg.c index 2a052ca..be321f9 100644 --- a/lapack/dlarfg.c +++ b/lapack/dlarfg.c
@@ -1,170 +1,164 @@ /* dlarfg.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., + 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 + http://www.netlib.org/f2c/libf2c.zip */ -#include "f2c.h" #include "blaswrap.h" +#include "lapack_datatypes.h" -/* Subroutine */ int dlarfg_(integer *n, doublereal *alpha, doublereal *x, - integer *incx, doublereal *tau) -{ - /* System generated locals */ - integer i__1; - doublereal d__1; +static inline doublereal d_sign(doublereal *a, doublereal *b) { + doublereal x; + x = (*a >= 0 ? *a : -*a); + return (*b >= 0 ? x : -x); +} - /* Builtin functions */ - double d_sign(doublereal *, doublereal *); +/* Subroutine */ void dlarfg_(integer *n, doublereal *alpha, doublereal *x, integer *incx, doublereal *tau) { + /* System generated locals */ + integer i__1; + doublereal d__1; - /* Local variables */ - integer j, knt; - doublereal beta; - extern doublereal dnrm2_(integer *, doublereal *, integer *); - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *); - doublereal xnorm; - extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *); - doublereal safmin, rsafmn; + /* Local variables */ + integer j, knt; + doublereal beta; + extern doublereal dnrm2_(integer *, doublereal *, integer *); + extern /* Subroutine */ void dscal_(integer *, doublereal *, doublereal *, integer *); + doublereal xnorm; + extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *); + doublereal safmin, rsafmn; + /* -- LAPACK auxiliary routine (version 3.2) -- */ + /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ + /* November 2006 */ -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ + /* .. Scalar Arguments .. */ + /* .. */ + /* .. Array Arguments .. */ + /* .. */ -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ + /* Purpose */ + /* ======= */ -/* Purpose */ -/* ======= */ + /* DLARFG generates a real elementary reflector H of order n, such */ + /* that */ -/* DLARFG generates a real elementary reflector H of order n, such */ -/* that */ + /* H * ( alpha ) = ( beta ), H' * H = I. */ + /* ( x ) ( 0 ) */ -/* H * ( alpha ) = ( beta ), H' * H = I. */ -/* ( x ) ( 0 ) */ + /* where alpha and beta are scalars, and x is an (n-1)-element real */ + /* vector. H is represented in the form */ -/* where alpha and beta are scalars, and x is an (n-1)-element real */ -/* vector. H is represented in the form */ + /* H = I - tau * ( 1 ) * ( 1 v' ) , */ + /* ( v ) */ -/* H = I - tau * ( 1 ) * ( 1 v' ) , */ -/* ( v ) */ + /* where tau is a real scalar and v is a real (n-1)-element */ + /* vector. */ -/* where tau is a real scalar and v is a real (n-1)-element */ -/* vector. */ + /* If the elements of x are all zero, then tau = 0 and H is taken to be */ + /* the unit matrix. */ -/* If the elements of x are all zero, then tau = 0 and H is taken to be */ -/* the unit matrix. */ + /* Otherwise 1 <= tau <= 2. */ -/* Otherwise 1 <= tau <= 2. */ + /* Arguments */ + /* ========= */ -/* Arguments */ -/* ========= */ + /* N (input) INTEGER */ + /* The order of the elementary reflector. */ -/* N (input) INTEGER */ -/* The order of the elementary reflector. */ + /* ALPHA (input/output) DOUBLE PRECISION */ + /* On entry, the value alpha. */ + /* On exit, it is overwritten with the value beta. */ -/* ALPHA (input/output) DOUBLE PRECISION */ -/* On entry, the value alpha. */ -/* On exit, it is overwritten with the value beta. */ + /* X (input/output) DOUBLE PRECISION array, dimension */ + /* (1+(N-2)*abs(INCX)) */ + /* On entry, the vector x. */ + /* On exit, it is overwritten with the vector v. */ -/* X (input/output) DOUBLE PRECISION array, dimension */ -/* (1+(N-2)*abs(INCX)) */ -/* On entry, the vector x. */ -/* On exit, it is overwritten with the vector v. */ + /* INCX (input) INTEGER */ + /* The increment between elements of X. INCX > 0. */ -/* INCX (input) INTEGER */ -/* The increment between elements of X. INCX > 0. */ + /* TAU (output) DOUBLE PRECISION */ + /* The value tau. */ -/* TAU (output) DOUBLE PRECISION */ -/* The value tau. */ + /* ===================================================================== */ -/* ===================================================================== */ + /* .. Parameters .. */ + /* .. */ + /* .. Local Scalars .. */ + /* .. */ + /* .. External Functions .. */ + /* .. */ + /* .. Intrinsic Functions .. */ + /* .. */ + /* .. External Subroutines .. */ + /* .. */ + /* .. Executable Statements .. */ -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Executable Statements .. */ + /* Parameter adjustments */ + --x; - /* Parameter adjustments */ - --x; + /* Function Body */ + if (*n <= 1) { + *tau = 0.; + return; + } - /* Function Body */ - if (*n <= 1) { - *tau = 0.; - return 0; + i__1 = *n - 1; + xnorm = dnrm2_(&i__1, &x[1], incx); + + if (xnorm == 0.) { + /* H = I */ + + *tau = 0.; + } else { + /* general case */ + + d__1 = dlapy2_(alpha, &xnorm); + beta = -d_sign(&d__1, alpha); + safmin = dlamch_("S") / dlamch_("E"); + knt = 0; + if (abs(beta) < safmin) { + /* XNORM, BETA may be inaccurate; scale X and recompute them */ + + rsafmn = 1. / safmin; + L10: + ++knt; + i__1 = *n - 1; + dscal_(&i__1, &rsafmn, &x[1], incx); + beta *= rsafmn; + *alpha *= rsafmn; + if (abs(beta) < safmin) { + goto L10; + } + + /* New BETA is at most 1, at least SAFMIN */ + + i__1 = *n - 1; + xnorm = dnrm2_(&i__1, &x[1], incx); + d__1 = dlapy2_(alpha, &xnorm); + beta = -d_sign(&d__1, alpha); } - + *tau = (beta - *alpha) / beta; i__1 = *n - 1; - xnorm = dnrm2_(&i__1, &x[1], incx); + d__1 = 1. / (*alpha - beta); + dscal_(&i__1, &d__1, &x[1], incx); - if (xnorm == 0.) { + /* If ALPHA is subnormal, it may lose relative accuracy */ -/* H = I */ - - *tau = 0.; - } else { - -/* general case */ - - d__1 = dlapy2_(alpha, &xnorm); - beta = -d_sign(&d__1, alpha); - safmin = dlamch_("S") / dlamch_("E"); - knt = 0; - if (abs(beta) < safmin) { - -/* XNORM, BETA may be inaccurate; scale X and recompute them */ - - rsafmn = 1. / safmin; -L10: - ++knt; - i__1 = *n - 1; - dscal_(&i__1, &rsafmn, &x[1], incx); - beta *= rsafmn; - *alpha *= rsafmn; - if (abs(beta) < safmin) { - goto L10; - } - -/* New BETA is at most 1, at least SAFMIN */ - - i__1 = *n - 1; - xnorm = dnrm2_(&i__1, &x[1], incx); - d__1 = dlapy2_(alpha, &xnorm); - beta = -d_sign(&d__1, alpha); - } - *tau = (beta - *alpha) / beta; - i__1 = *n - 1; - d__1 = 1. / (*alpha - beta); - dscal_(&i__1, &d__1, &x[1], incx); - -/* If ALPHA is subnormal, it may lose relative accuracy */ - - i__1 = knt; - for (j = 1; j <= i__1; ++j) { - beta *= safmin; -/* L20: */ - } - *alpha = beta; + i__1 = knt; + for (j = 1; j <= i__1; ++j) { + beta *= safmin; + /* L20: */ } + *alpha = beta; + } - return 0; - -/* End of DLARFG */ + /* End of DLARFG */ } /* dlarfg_ */
diff --git a/lapack/dlarft.c b/lapack/dlarft.c index 0d4951c..46f36f9 100644 --- a/lapack/dlarft.c +++ b/lapack/dlarft.c
@@ -1,325 +1,309 @@ /* dlarft.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., + 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 + http://www.netlib.org/f2c/libf2c.zip */ -#include "f2c.h" #include "blaswrap.h" +#include "lapack_datatypes.h" /* Table of constant values */ static integer c__1 = 1; static doublereal c_b8 = 0.; -/* Subroutine */ int dlarft_(char *direct, char *storev, integer *n, integer * - k, doublereal *v, integer *ldv, doublereal *tau, doublereal *t, - integer *ldt) -{ - /* System generated locals */ - integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3; - doublereal d__1; +/* Subroutine */ void dlarft_(char *direct, char *storev, integer *n, integer *k, doublereal *v, integer *ldv, + doublereal *tau, doublereal *t, integer *ldt) { + /* System generated locals */ + integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3; + doublereal d__1; - /* Local variables */ - integer i__, j, prevlastv; - doublereal vii; - extern logical lsame_(char *, char *); - extern /* Subroutine */ int dgemv_(char *, integer *, integer *, - doublereal *, doublereal *, integer *, doublereal *, integer *, - doublereal *, doublereal *, integer *); - integer lastv; - extern /* Subroutine */ int dtrmv_(char *, char *, char *, integer *, - doublereal *, integer *, doublereal *, integer *); + /* Local variables */ + integer i__, j, prevlastv; + doublereal vii; + 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 lastv; + extern /* Subroutine */ void dtrmv_(const char *, const char *, const char *, const integer *, const doublereal *, + const integer *, doublereal *, const integer *); + /* -- LAPACK auxiliary routine (version 3.2) -- */ + /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ + /* November 2006 */ -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ + /* .. Scalar Arguments .. */ + /* .. */ + /* .. Array Arguments .. */ + /* .. */ -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ + /* Purpose */ + /* ======= */ -/* Purpose */ -/* ======= */ + /* DLARFT forms the triangular factor T of a real block reflector H */ + /* of order n, which is defined as a product of k elementary reflectors. */ -/* DLARFT forms the triangular factor T of a real block reflector H */ -/* of order n, which is defined as a product of k elementary reflectors. */ + /* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; */ -/* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; */ + /* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. */ -/* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. */ + /* If STOREV = 'C', the vector which defines the elementary reflector */ + /* H(i) is stored in the i-th column of the array V, and */ -/* If STOREV = 'C', the vector which defines the elementary reflector */ -/* H(i) is stored in the i-th column of the array V, and */ + /* H = I - V * T * V' */ -/* H = I - V * T * V' */ + /* If STOREV = 'R', the vector which defines the elementary reflector */ + /* H(i) is stored in the i-th row of the array V, and */ -/* If STOREV = 'R', the vector which defines the elementary reflector */ -/* H(i) is stored in the i-th row of the array V, and */ + /* H = I - V' * T * V */ -/* H = I - V' * T * V */ + /* Arguments */ + /* ========= */ -/* Arguments */ -/* ========= */ + /* DIRECT (input) CHARACTER*1 */ + /* Specifies the order in which the elementary reflectors are */ + /* multiplied to form the block reflector: */ + /* = 'F': H = H(1) H(2) . . . H(k) (Forward) */ + /* = 'B': H = H(k) . . . H(2) H(1) (Backward) */ -/* DIRECT (input) CHARACTER*1 */ -/* Specifies the order in which the elementary reflectors are */ -/* multiplied to form the block reflector: */ -/* = 'F': H = H(1) H(2) . . . H(k) (Forward) */ -/* = 'B': H = H(k) . . . H(2) H(1) (Backward) */ + /* STOREV (input) CHARACTER*1 */ + /* Specifies how the vectors which define the elementary */ + /* reflectors are stored (see also Further Details): */ + /* = 'C': columnwise */ + /* = 'R': rowwise */ -/* STOREV (input) CHARACTER*1 */ -/* Specifies how the vectors which define the elementary */ -/* reflectors are stored (see also Further Details): */ -/* = 'C': columnwise */ -/* = 'R': rowwise */ + /* N (input) INTEGER */ + /* The order of the block reflector H. N >= 0. */ -/* N (input) INTEGER */ -/* The order of the block reflector H. N >= 0. */ + /* K (input) INTEGER */ + /* The order of the triangular factor T (= the number of */ + /* elementary reflectors). K >= 1. */ -/* K (input) INTEGER */ -/* The order of the triangular factor T (= the number of */ -/* elementary reflectors). K >= 1. */ + /* V (input/output) DOUBLE PRECISION array, dimension */ + /* (LDV,K) if STOREV = 'C' */ + /* (LDV,N) if STOREV = 'R' */ + /* The matrix V. See further details. */ -/* V (input/output) DOUBLE PRECISION array, dimension */ -/* (LDV,K) if STOREV = 'C' */ -/* (LDV,N) if STOREV = 'R' */ -/* The matrix V. See further details. */ + /* LDV (input) INTEGER */ + /* The leading dimension of the array V. */ + /* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. */ -/* LDV (input) INTEGER */ -/* The leading dimension of the array V. */ -/* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. */ + /* TAU (input) DOUBLE PRECISION array, dimension (K) */ + /* TAU(i) must contain the scalar factor of the elementary */ + /* reflector H(i). */ -/* TAU (input) DOUBLE PRECISION array, dimension (K) */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i). */ + /* T (output) DOUBLE PRECISION array, dimension (LDT,K) */ + /* The k by k triangular factor T of the block reflector. */ + /* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is */ + /* lower triangular. The rest of the array is not used. */ -/* T (output) DOUBLE PRECISION array, dimension (LDT,K) */ -/* The k by k triangular factor T of the block reflector. */ -/* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is */ -/* lower triangular. The rest of the array is not used. */ + /* LDT (input) INTEGER */ + /* The leading dimension of the array T. LDT >= K. */ -/* LDT (input) INTEGER */ -/* The leading dimension of the array T. LDT >= K. */ + /* Further Details */ + /* =============== */ -/* Further Details */ -/* =============== */ + /* The shape of the matrix V and the storage of the vectors which define */ + /* the H(i) is best illustrated by the following example with n = 5 and */ + /* k = 3. The elements equal to 1 are not stored; the corresponding */ + /* array elements are modified but restored on exit. The rest of the */ + /* array is not used. */ -/* The shape of the matrix V and the storage of the vectors which define */ -/* the H(i) is best illustrated by the following example with n = 5 and */ -/* k = 3. The elements equal to 1 are not stored; the corresponding */ -/* array elements are modified but restored on exit. The rest of the */ -/* array is not used. */ + /* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': */ -/* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': */ + /* V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) */ + /* ( v1 1 ) ( 1 v2 v2 v2 ) */ + /* ( v1 v2 1 ) ( 1 v3 v3 ) */ + /* ( v1 v2 v3 ) */ + /* ( v1 v2 v3 ) */ -/* V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) */ -/* ( v1 1 ) ( 1 v2 v2 v2 ) */ -/* ( v1 v2 1 ) ( 1 v3 v3 ) */ -/* ( v1 v2 v3 ) */ -/* ( v1 v2 v3 ) */ + /* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': */ -/* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': */ + /* V = ( v1 v2 v3 ) V = ( v1 v1 1 ) */ + /* ( v1 v2 v3 ) ( v2 v2 v2 1 ) */ + /* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) */ + /* ( 1 v3 ) */ + /* ( 1 ) */ -/* V = ( v1 v2 v3 ) V = ( v1 v1 1 ) */ -/* ( v1 v2 v3 ) ( v2 v2 v2 1 ) */ -/* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) */ -/* ( 1 v3 ) */ -/* ( 1 ) */ + /* ===================================================================== */ -/* ===================================================================== */ + /* .. Parameters .. */ + /* .. */ + /* .. Local Scalars .. */ + /* .. */ + /* .. External Subroutines .. */ + /* .. */ + /* .. External Functions .. */ + /* .. */ + /* .. Executable Statements .. */ -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ + /* Quick return if possible */ -/* Quick return if possible */ + /* Parameter adjustments */ + v_dim1 = *ldv; + v_offset = 1 + v_dim1; + v -= v_offset; + --tau; + t_dim1 = *ldt; + t_offset = 1 + t_dim1; + t -= t_offset; - /* Parameter adjustments */ - v_dim1 = *ldv; - v_offset = 1 + v_dim1; - v -= v_offset; - --tau; - t_dim1 = *ldt; - t_offset = 1 + t_dim1; - t -= t_offset; + /* Function Body */ + if (*n == 0) { + return; + } - /* Function Body */ - if (*n == 0) { - return 0; + if (lsame_(direct, "F")) { + prevlastv = *n; + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + prevlastv = max(i__, prevlastv); + if (tau[i__] == 0.) { + /* H(i) = I */ + + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + t[j + i__ * t_dim1] = 0.; + /* L10: */ + } + } else { + /* general case */ + + vii = v[i__ + i__ * v_dim1]; + v[i__ + i__ * v_dim1] = 1.; + if (lsame_(storev, "C")) { + /* Skip any trailing zeros. */ + i__2 = i__ + 1; + for (lastv = *n; lastv >= i__2; --lastv) { + if (v[lastv + i__ * v_dim1] != 0.) { + break; + } + } + j = min(lastv, prevlastv); + + /* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)' * V(i:j,i) */ + + i__2 = j - i__ + 1; + i__3 = i__ - 1; + d__1 = -tau[i__]; + dgemv_("Transpose", &i__2, &i__3, &d__1, &v[i__ + v_dim1], ldv, &v[i__ + i__ * v_dim1], &c__1, &c_b8, + &t[i__ * t_dim1 + 1], &c__1); + } else { + /* Skip any trailing zeros. */ + i__2 = i__ + 1; + for (lastv = *n; lastv >= i__2; --lastv) { + if (v[i__ + lastv * v_dim1] != 0.) { + break; + } + } + j = min(lastv, prevlastv); + + /* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)' */ + + i__2 = i__ - 1; + i__3 = j - i__ + 1; + d__1 = -tau[i__]; + dgemv_("No transpose", &i__2, &i__3, &d__1, &v[i__ * v_dim1 + 1], ldv, &v[i__ + i__ * v_dim1], ldv, &c_b8, + &t[i__ * t_dim1 + 1], &c__1); + } + v[i__ + i__ * v_dim1] = vii; + + /* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) */ + + i__2 = i__ - 1; + dtrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[t_offset], ldt, &t[i__ * t_dim1 + 1], &c__1); + t[i__ + i__ * t_dim1] = tau[i__]; + if (i__ > 1) { + prevlastv = max(prevlastv, lastv); + } else { + prevlastv = lastv; + } + } + /* L20: */ } + } else { + prevlastv = 1; + for (i__ = *k; i__ >= 1; --i__) { + if (tau[i__] == 0.) { + /* H(i) = I */ - if (lsame_(direct, "F")) { - prevlastv = *n; - i__1 = *k; - for (i__ = 1; i__ <= i__1; ++i__) { - prevlastv = max(i__,prevlastv); - if (tau[i__] == 0.) { + i__1 = *k; + for (j = i__; j <= i__1; ++j) { + t[j + i__ * t_dim1] = 0.; + /* L30: */ + } + } else { + /* general case */ -/* H(i) = I */ + if (i__ < *k) { + if (lsame_(storev, "C")) { + vii = v[*n - *k + i__ + i__ * v_dim1]; + v[*n - *k + i__ + i__ * v_dim1] = 1.; + /* Skip any leading zeros. */ + i__1 = i__ - 1; + for (lastv = 1; lastv <= i__1; ++lastv) { + if (v[lastv + i__ * v_dim1] != 0.) { + break; + } + } + j = max(lastv, prevlastv); - i__2 = i__; - for (j = 1; j <= i__2; ++j) { - t[j + i__ * t_dim1] = 0.; -/* L10: */ - } - } else { + /* T(i+1:k,i) := */ + /* - tau(i) * V(j:n-k+i,i+1:k)' * V(j:n-k+i,i) */ -/* general case */ + i__1 = *n - *k + i__ - j + 1; + i__2 = *k - i__; + d__1 = -tau[i__]; + dgemv_("Transpose", &i__1, &i__2, &d__1, &v[j + (i__ + 1) * v_dim1], ldv, &v[j + i__ * v_dim1], &c__1, + &c_b8, &t[i__ + 1 + i__ * t_dim1], &c__1); + v[*n - *k + i__ + i__ * v_dim1] = vii; + } else { + vii = v[i__ + (*n - *k + i__) * v_dim1]; + v[i__ + (*n - *k + i__) * v_dim1] = 1.; + /* Skip any leading zeros. */ + i__1 = i__ - 1; + for (lastv = 1; lastv <= i__1; ++lastv) { + if (v[i__ + lastv * v_dim1] != 0.) { + break; + } + } + j = max(lastv, prevlastv); - vii = v[i__ + i__ * v_dim1]; - v[i__ + i__ * v_dim1] = 1.; - if (lsame_(storev, "C")) { -/* Skip any trailing zeros. */ - i__2 = i__ + 1; - for (lastv = *n; lastv >= i__2; --lastv) { - if (v[lastv + i__ * v_dim1] != 0.) { - break; - } - } - j = min(lastv,prevlastv); + /* T(i+1:k,i) := */ + /* - tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)' */ -/* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)' * V(i:j,i) */ + i__1 = *k - i__; + i__2 = *n - *k + i__ - j + 1; + d__1 = -tau[i__]; + dgemv_("No transpose", &i__1, &i__2, &d__1, &v[i__ + 1 + j * v_dim1], ldv, &v[i__ + j * v_dim1], ldv, &c_b8, + &t[i__ + 1 + i__ * t_dim1], &c__1); + v[i__ + (*n - *k + i__) * v_dim1] = vii; + } - i__2 = j - i__ + 1; - i__3 = i__ - 1; - d__1 = -tau[i__]; - dgemv_("Transpose", &i__2, &i__3, &d__1, &v[i__ + v_dim1], - ldv, &v[i__ + i__ * v_dim1], &c__1, &c_b8, &t[ - i__ * t_dim1 + 1], &c__1); - } else { -/* Skip any trailing zeros. */ - i__2 = i__ + 1; - for (lastv = *n; lastv >= i__2; --lastv) { - if (v[i__ + lastv * v_dim1] != 0.) { - break; - } - } - j = min(lastv,prevlastv); + /* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) */ -/* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)' */ - - i__2 = i__ - 1; - i__3 = j - i__ + 1; - d__1 = -tau[i__]; - dgemv_("No transpose", &i__2, &i__3, &d__1, &v[i__ * - v_dim1 + 1], ldv, &v[i__ + i__ * v_dim1], ldv, & - c_b8, &t[i__ * t_dim1 + 1], &c__1); - } - v[i__ + i__ * v_dim1] = vii; - -/* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) */ - - i__2 = i__ - 1; - dtrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[ - t_offset], ldt, &t[i__ * t_dim1 + 1], &c__1); - t[i__ + i__ * t_dim1] = tau[i__]; - if (i__ > 1) { - prevlastv = max(prevlastv,lastv); - } else { - prevlastv = lastv; - } - } -/* L20: */ - } - } else { - prevlastv = 1; - for (i__ = *k; i__ >= 1; --i__) { - if (tau[i__] == 0.) { - -/* H(i) = I */ - - i__1 = *k; - for (j = i__; j <= i__1; ++j) { - t[j + i__ * t_dim1] = 0.; -/* L30: */ - } - } else { - -/* general case */ - - if (i__ < *k) { - if (lsame_(storev, "C")) { - vii = v[*n - *k + i__ + i__ * v_dim1]; - v[*n - *k + i__ + i__ * v_dim1] = 1.; -/* Skip any leading zeros. */ - i__1 = i__ - 1; - for (lastv = 1; lastv <= i__1; ++lastv) { - if (v[lastv + i__ * v_dim1] != 0.) { - break; - } - } - j = max(lastv,prevlastv); - -/* T(i+1:k,i) := */ -/* - tau(i) * V(j:n-k+i,i+1:k)' * V(j:n-k+i,i) */ - - i__1 = *n - *k + i__ - j + 1; - i__2 = *k - i__; - d__1 = -tau[i__]; - dgemv_("Transpose", &i__1, &i__2, &d__1, &v[j + (i__ - + 1) * v_dim1], ldv, &v[j + i__ * v_dim1], & - c__1, &c_b8, &t[i__ + 1 + i__ * t_dim1], & - c__1); - v[*n - *k + i__ + i__ * v_dim1] = vii; - } else { - vii = v[i__ + (*n - *k + i__) * v_dim1]; - v[i__ + (*n - *k + i__) * v_dim1] = 1.; -/* Skip any leading zeros. */ - i__1 = i__ - 1; - for (lastv = 1; lastv <= i__1; ++lastv) { - if (v[i__ + lastv * v_dim1] != 0.) { - break; - } - } - j = max(lastv,prevlastv); - -/* T(i+1:k,i) := */ -/* - tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)' */ - - i__1 = *k - i__; - i__2 = *n - *k + i__ - j + 1; - d__1 = -tau[i__]; - dgemv_("No transpose", &i__1, &i__2, &d__1, &v[i__ + - 1 + j * v_dim1], ldv, &v[i__ + j * v_dim1], - ldv, &c_b8, &t[i__ + 1 + i__ * t_dim1], &c__1); - v[i__ + (*n - *k + i__) * v_dim1] = vii; - } - -/* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) */ - - i__1 = *k - i__; - dtrmv_("Lower", "No transpose", "Non-unit", &i__1, &t[i__ - + 1 + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ * - t_dim1], &c__1) - ; - if (i__ > 1) { - prevlastv = min(prevlastv,lastv); - } else { - prevlastv = lastv; - } - } - t[i__ + i__ * t_dim1] = tau[i__]; - } -/* L40: */ - } + i__1 = *k - i__; + dtrmv_("Lower", "No transpose", "Non-unit", &i__1, &t[i__ + 1 + (i__ + 1) * t_dim1], ldt, + &t[i__ + 1 + i__ * t_dim1], &c__1); + if (i__ > 1) { + prevlastv = min(prevlastv, lastv); + } else { + prevlastv = lastv; + } + } + t[i__ + i__ * t_dim1] = tau[i__]; + } + /* L40: */ } - return 0; + } -/* End of DLARFT */ + /* End of DLARFT */ } /* dlarft_ */
diff --git a/lapack/ilaclc.c b/lapack/ilaclc.c index 98a0519..d5f4518 100644 --- a/lapack/ilaclc.c +++ b/lapack/ilaclc.c
@@ -10,8 +10,8 @@ http://www.netlib.org/f2c/libf2c.zip */ -#include "f2c.h" #include "blaswrap.h" +#include "lapack_datatypes.h" integer ilaclc_(integer *m, integer *n, complex *a, integer *lda) {
diff --git a/lapack/ilaclr.c b/lapack/ilaclr.c index b28e22e..fe768c0 100644 --- a/lapack/ilaclr.c +++ b/lapack/ilaclr.c
@@ -10,8 +10,8 @@ http://www.netlib.org/f2c/libf2c.zip */ -#include "f2c.h" #include "blaswrap.h" +#include "lapack_datatypes.h" integer ilaclr_(integer *m, integer *n, complex *a, integer *lda) {
diff --git a/lapack/iladlc.c b/lapack/iladlc.c index a18f02e..8af8292 100644 --- a/lapack/iladlc.c +++ b/lapack/iladlc.c
@@ -10,8 +10,8 @@ http://www.netlib.org/f2c/libf2c.zip */ -#include "f2c.h" #include "blaswrap.h" +#include "lapack_datatypes.h" integer iladlc_(integer *m, integer *n, doublereal *a, integer *lda) {
diff --git a/lapack/iladlr.c b/lapack/iladlr.c index f1626e4..9e074d8 100644 --- a/lapack/iladlr.c +++ b/lapack/iladlr.c
@@ -10,8 +10,8 @@ http://www.netlib.org/f2c/libf2c.zip */ -#include "f2c.h" #include "blaswrap.h" +#include "lapack_datatypes.h" integer iladlr_(integer *m, integer *n, doublereal *a, integer *lda) {
diff --git a/lapack/ilaslc.c b/lapack/ilaslc.c index c877084..cbcfe17 100644 --- a/lapack/ilaslc.c +++ b/lapack/ilaslc.c
@@ -10,8 +10,8 @@ http://www.netlib.org/f2c/libf2c.zip */ -#include "f2c.h" #include "blaswrap.h" +#include "lapack_datatypes.h" integer ilaslc_(integer *m, integer *n, real *a, integer *lda) {
diff --git a/lapack/ilaslr.c b/lapack/ilaslr.c index 0aaa4a0..4d9c7b6 100644 --- a/lapack/ilaslr.c +++ b/lapack/ilaslr.c
@@ -10,8 +10,8 @@ http://www.netlib.org/f2c/libf2c.zip */ -#include "f2c.h" #include "blaswrap.h" +#include "lapack_datatypes.h" integer ilaslr_(integer *m, integer *n, real *a, integer *lda) {
diff --git a/lapack/ilazlc.c b/lapack/ilazlc.c index 2b20f40..4691646 100644 --- a/lapack/ilazlc.c +++ b/lapack/ilazlc.c
@@ -10,8 +10,8 @@ http://www.netlib.org/f2c/libf2c.zip */ -#include "f2c.h" #include "blaswrap.h" +#include "lapack_datatypes.h" integer ilazlc_(integer *m, integer *n, doublecomplex *a, integer *lda) {
diff --git a/lapack/ilazlr.c b/lapack/ilazlr.c index 373d077..553b166 100644 --- a/lapack/ilazlr.c +++ b/lapack/ilazlr.c
@@ -10,8 +10,8 @@ http://www.netlib.org/f2c/libf2c.zip */ -#include "f2c.h" #include "blaswrap.h" +#include "lapack_datatypes.h" integer ilazlr_(integer *m, integer *n, doublecomplex *a, integer *lda) {
diff --git a/lapack/lapack_datatypes.h b/lapack/lapack_datatypes.h new file mode 100644 index 0000000..01818a5 --- /dev/null +++ b/lapack/lapack_datatypes.h
@@ -0,0 +1,9 @@ +#ifndef EIGEN_LAPACK_DATATYPES_H_ +#define EIGEN_LAPACK_DATATYPES_H_ + +#include "../blas/f2c/datatypes.h" + +#define TRUE_ (logical)1 +#define FALSE_ (logical)0 + +#endif // EIGEN_LAPACK_DATATYPES_H_ \ No newline at end of file
diff --git a/lapack/sladiv.c b/lapack/sladiv.c index af4e0c5..629992d 100644 --- a/lapack/sladiv.c +++ b/lapack/sladiv.c
@@ -1,78 +1,73 @@ /* sladiv.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., + 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 + http://www.netlib.org/f2c/libf2c.zip */ -#include "f2c.h" #include "blaswrap.h" +#include "lapack_datatypes.h" -/* Subroutine */ int sladiv_(real *a, real *b, real *c__, real *d__, real *p, - real *q) -{ - real e, f; +/* Subroutine */ void sladiv_(real *a, real *b, real *c__, real *d__, real *p, real *q) { + real e, f; + /* -- LAPACK auxiliary routine (version 3.2) -- */ + /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ + /* November 2006 */ -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ + /* .. Scalar Arguments .. */ + /* .. */ -/* .. Scalar Arguments .. */ -/* .. */ + /* Purpose */ + /* ======= */ -/* Purpose */ -/* ======= */ + /* SLADIV performs complex division in real arithmetic */ -/* SLADIV performs complex division in real arithmetic */ + /* a + i*b */ + /* p + i*q = --------- */ + /* c + i*d */ -/* a + i*b */ -/* p + i*q = --------- */ -/* c + i*d */ + /* The algorithm is due to Robert L. Smith and can be found */ + /* in D. Knuth, The art of Computer Programming, Vol.2, p.195 */ -/* The algorithm is due to Robert L. Smith and can be found */ -/* in D. Knuth, The art of Computer Programming, Vol.2, p.195 */ + /* Arguments */ + /* ========= */ -/* Arguments */ -/* ========= */ + /* A (input) REAL */ + /* B (input) REAL */ + /* C (input) REAL */ + /* D (input) REAL */ + /* The scalars a, b, c, and d in the above expression. */ -/* A (input) REAL */ -/* B (input) REAL */ -/* C (input) REAL */ -/* D (input) REAL */ -/* The scalars a, b, c, and d in the above expression. */ + /* P (output) REAL */ + /* Q (output) REAL */ + /* The scalars p and q in the above expression. */ -/* P (output) REAL */ -/* Q (output) REAL */ -/* The scalars p and q in the above expression. */ + /* ===================================================================== */ -/* ===================================================================== */ + /* .. Local Scalars .. */ + /* .. */ + /* .. Intrinsic Functions .. */ + /* .. */ + /* .. Executable Statements .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ + if (dabs(*d__) < dabs(*c__)) { + e = *d__ / *c__; + f = *c__ + *d__ * e; + *p = (*a + *b * e) / f; + *q = (*b - *a * e) / f; + } else { + e = *c__ / *d__; + f = *d__ + *c__ * e; + *p = (*b + *a * e) / f; + *q = (-(*a) + *b * e) / f; + } - if (dabs(*d__) < dabs(*c__)) { - e = *d__ / *c__; - f = *c__ + *d__ * e; - *p = (*a + *b * e) / f; - *q = (*b - *a * e) / f; - } else { - e = *c__ / *d__; - f = *d__ + *c__ * e; - *p = (*b + *a * e) / f; - *q = (-(*a) + *b * e) / f; - } - - return 0; - -/* End of SLADIV */ + /* End of SLADIV */ } /* sladiv_ */
diff --git a/lapack/slamch.c b/lapack/slamch.c index e57b5e5..7438dfe 100644 --- a/lapack/slamch.c +++ b/lapack/slamch.c
@@ -1,1000 +1,991 @@ /* slamch.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., + 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 + http://www.netlib.org/f2c/libf2c.zip */ -#include "f2c.h" #include "blaswrap.h" +#include "lapack_datatypes.h" /* Table of constant values */ -static integer c__1 = 1; +/* static integer c__1 = 1; */ static real c_b32 = 0.f; -doublereal slamch_(char *cmach) -{ - /* Initialized data */ +static inline real pow_ri(real *ap, integer *bp) { + real pow, x; + integer n; + unsigned long u; - static logical first = TRUE_; + pow = 1; + x = *ap; + n = *bp; - /* System generated locals */ - integer i__1; - real ret_val; - - /* Builtin functions */ - double pow_ri(real *, integer *); - - /* Local variables */ - static real t; - integer it; - static real rnd, eps, base; - integer beta; - static real emin, prec, emax; - integer imin, imax; - logical lrnd; - static real rmin, rmax; - real rmach = 0; - extern logical lsame_(char *, char *); - real small; - static real sfmin; - extern /* Subroutine */ int slamc2_(integer *, integer *, logical *, real - *, integer *, real *, integer *, real *); - - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SLAMCH determines single precision machine parameters. */ - -/* Arguments */ -/* ========= */ - -/* CMACH (input) CHARACTER*1 */ -/* Specifies the value to be returned by SLAMCH: */ -/* = 'E' or 'e', SLAMCH := eps */ -/* = 'S' or 's , SLAMCH := sfmin */ -/* = 'B' or 'b', SLAMCH := base */ -/* = 'P' or 'p', SLAMCH := eps*base */ -/* = 'N' or 'n', SLAMCH := t */ -/* = 'R' or 'r', SLAMCH := rnd */ -/* = 'M' or 'm', SLAMCH := emin */ -/* = 'U' or 'u', SLAMCH := rmin */ -/* = 'L' or 'l', SLAMCH := emax */ -/* = 'O' or 'o', SLAMCH := rmax */ - -/* where */ - -/* eps = relative machine precision */ -/* sfmin = safe minimum, such that 1/sfmin does not overflow */ -/* base = base of the machine */ -/* prec = eps*base */ -/* t = number of (base) digits in the mantissa */ -/* rnd = 1.0 when rounding occurs in addition, 0.0 otherwise */ -/* emin = minimum exponent before (gradual) underflow */ -/* rmin = underflow threshold - base**(emin-1) */ -/* emax = largest exponent before overflow */ -/* rmax = overflow threshold - (base**emax)*(1-eps) */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Save statement .. */ -/* .. */ -/* .. Data statements .. */ -/* .. */ -/* .. Executable Statements .. */ - - if (first) { - slamc2_(&beta, &it, &lrnd, &eps, &imin, &rmin, &imax, &rmax); - base = (real) beta; - t = (real) it; - if (lrnd) { - rnd = 1.f; - i__1 = 1 - it; - eps = pow_ri(&base, &i__1) / 2; - } else { - rnd = 0.f; - i__1 = 1 - it; - eps = pow_ri(&base, &i__1); - } - prec = eps * base; - emin = (real) imin; - emax = (real) imax; - sfmin = rmin; - small = 1.f / rmax; - if (small >= sfmin) { - -/* Use SMALL plus a bit, to avoid the possibility of rounding */ -/* causing overflow when computing 1/sfmin. */ - - sfmin = small * (eps + 1.f); - } + if (n != 0) { + if (n < 0) { + n = -n; + x = 1 / x; } - - if (lsame_(cmach, "E")) { - rmach = eps; - } else if (lsame_(cmach, "S")) { - rmach = sfmin; - } else if (lsame_(cmach, "B")) { - rmach = base; - } else if (lsame_(cmach, "P")) { - rmach = prec; - } else if (lsame_(cmach, "N")) { - rmach = t; - } else if (lsame_(cmach, "R")) { - rmach = rnd; - } else if (lsame_(cmach, "M")) { - rmach = emin; - } else if (lsame_(cmach, "U")) { - rmach = rmin; - } else if (lsame_(cmach, "L")) { - rmach = emax; - } else if (lsame_(cmach, "O")) { - rmach = rmax; + for (u = n;;) { + if (u & 01) pow *= x; + if (u >>= 1) + x *= x; + else + break; } + } + return (pow); +} - ret_val = rmach; - first = FALSE_; - return ret_val; +doublereal slamch_(char *cmach) { + /* Initialized data */ -/* End of SLAMCH */ + static logical first = TRUE_; + + /* System generated locals */ + integer i__1; + real ret_val; + + /* Local variables */ + static real t; + integer it; + static real rnd, eps, base; + integer beta; + static real emin, prec, emax; + integer imin, imax; + logical lrnd; + static real rmin, rmax; + real rmach = 0; + extern logical lsame_(char *, char *); + real small; + static real sfmin; + extern /* Subroutine */ void slamc2_(integer *, integer *, logical *, real *, integer *, real *, integer *, real *); + + /* -- LAPACK auxiliary routine (version 3.2) -- */ + /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ + /* November 2006 */ + + /* .. Scalar Arguments .. */ + /* .. */ + + /* Purpose */ + /* ======= */ + + /* SLAMCH determines single precision machine parameters. */ + + /* Arguments */ + /* ========= */ + + /* CMACH (input) CHARACTER*1 */ + /* Specifies the value to be returned by SLAMCH: */ + /* = 'E' or 'e', SLAMCH := eps */ + /* = 'S' or 's , SLAMCH := sfmin */ + /* = 'B' or 'b', SLAMCH := base */ + /* = 'P' or 'p', SLAMCH := eps*base */ + /* = 'N' or 'n', SLAMCH := t */ + /* = 'R' or 'r', SLAMCH := rnd */ + /* = 'M' or 'm', SLAMCH := emin */ + /* = 'U' or 'u', SLAMCH := rmin */ + /* = 'L' or 'l', SLAMCH := emax */ + /* = 'O' or 'o', SLAMCH := rmax */ + + /* where */ + + /* eps = relative machine precision */ + /* sfmin = safe minimum, such that 1/sfmin does not overflow */ + /* base = base of the machine */ + /* prec = eps*base */ + /* t = number of (base) digits in the mantissa */ + /* rnd = 1.0 when rounding occurs in addition, 0.0 otherwise */ + /* emin = minimum exponent before (gradual) underflow */ + /* rmin = underflow threshold - base**(emin-1) */ + /* emax = largest exponent before overflow */ + /* rmax = overflow threshold - (base**emax)*(1-eps) */ + + /* ===================================================================== */ + + /* .. Parameters .. */ + /* .. */ + /* .. Local Scalars .. */ + /* .. */ + /* .. External Functions .. */ + /* .. */ + /* .. External Subroutines .. */ + /* .. */ + /* .. Save statement .. */ + /* .. */ + /* .. Data statements .. */ + /* .. */ + /* .. Executable Statements .. */ + + if (first) { + slamc2_(&beta, &it, &lrnd, &eps, &imin, &rmin, &imax, &rmax); + base = (real)beta; + t = (real)it; + if (lrnd) { + rnd = 1.f; + i__1 = 1 - it; + eps = pow_ri(&base, &i__1) / 2; + } else { + rnd = 0.f; + i__1 = 1 - it; + eps = pow_ri(&base, &i__1); + } + prec = eps * base; + emin = (real)imin; + emax = (real)imax; + sfmin = rmin; + small = 1.f / rmax; + if (small >= sfmin) { + /* Use SMALL plus a bit, to avoid the possibility of rounding */ + /* causing overflow when computing 1/sfmin. */ + + sfmin = small * (eps + 1.f); + } + } + + if (lsame_(cmach, "E")) { + rmach = eps; + } else if (lsame_(cmach, "S")) { + rmach = sfmin; + } else if (lsame_(cmach, "B")) { + rmach = base; + } else if (lsame_(cmach, "P")) { + rmach = prec; + } else if (lsame_(cmach, "N")) { + rmach = t; + } else if (lsame_(cmach, "R")) { + rmach = rnd; + } else if (lsame_(cmach, "M")) { + rmach = emin; + } else if (lsame_(cmach, "U")) { + rmach = rmin; + } else if (lsame_(cmach, "L")) { + rmach = emax; + } else if (lsame_(cmach, "O")) { + rmach = rmax; + } + + ret_val = rmach; + first = FALSE_; + return ret_val; + + /* End of SLAMCH */ } /* slamch_ */ - /* *********************************************************************** */ -/* Subroutine */ int slamc1_(integer *beta, integer *t, logical *rnd, logical - *ieee1) -{ - /* Initialized data */ +/* Subroutine */ void slamc1_(integer *beta, integer *t, logical *rnd, logical *ieee1) { + /* Initialized data */ - static logical first = TRUE_; + static logical first = TRUE_; - /* System generated locals */ - real r__1, r__2; + /* System generated locals */ + real r__1, r__2; - /* Local variables */ - real a, b, c__, f, t1, t2; - static integer lt; - real one, qtr; - static logical lrnd; - static integer lbeta; - real savec; - static logical lieee1; - extern doublereal slamc3_(real *, real *); + /* Local variables */ + real a, b, c__, f, t1, t2; + static integer lt; + real one, qtr; + static logical lrnd; + static integer lbeta; + real savec; + static logical lieee1; + extern doublereal slamc3_(real *, real *); + /* -- LAPACK auxiliary routine (version 3.2) -- */ + /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ + /* November 2006 */ -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ + /* .. Scalar Arguments .. */ + /* .. */ -/* .. Scalar Arguments .. */ -/* .. */ + /* Purpose */ + /* ======= */ -/* Purpose */ -/* ======= */ + /* SLAMC1 determines the machine parameters given by BETA, T, RND, and */ + /* IEEE1. */ -/* SLAMC1 determines the machine parameters given by BETA, T, RND, and */ -/* IEEE1. */ + /* Arguments */ + /* ========= */ -/* Arguments */ -/* ========= */ + /* BETA (output) INTEGER */ + /* The base of the machine. */ -/* BETA (output) INTEGER */ -/* The base of the machine. */ + /* T (output) INTEGER */ + /* The number of ( BETA ) digits in the mantissa. */ -/* T (output) INTEGER */ -/* The number of ( BETA ) digits in the mantissa. */ + /* RND (output) LOGICAL */ + /* Specifies whether proper rounding ( RND = .TRUE. ) or */ + /* chopping ( RND = .FALSE. ) occurs in addition. This may not */ + /* be a reliable guide to the way in which the machine performs */ + /* its arithmetic. */ -/* RND (output) LOGICAL */ -/* Specifies whether proper rounding ( RND = .TRUE. ) or */ -/* chopping ( RND = .FALSE. ) occurs in addition. This may not */ -/* be a reliable guide to the way in which the machine performs */ -/* its arithmetic. */ + /* IEEE1 (output) LOGICAL */ + /* Specifies whether rounding appears to be done in the IEEE */ + /* 'round to nearest' style. */ -/* IEEE1 (output) LOGICAL */ -/* Specifies whether rounding appears to be done in the IEEE */ -/* 'round to nearest' style. */ + /* Further Details */ + /* =============== */ -/* Further Details */ -/* =============== */ + /* The routine is based on the routine ENVRON by Malcolm and */ + /* incorporates suggestions by Gentleman and Marovich. See */ -/* The routine is based on the routine ENVRON by Malcolm and */ -/* incorporates suggestions by Gentleman and Marovich. See */ + /* Malcolm M. A. (1972) Algorithms to reveal properties of */ + /* floating-point arithmetic. Comms. of the ACM, 15, 949-951. */ -/* Malcolm M. A. (1972) Algorithms to reveal properties of */ -/* floating-point arithmetic. Comms. of the ACM, 15, 949-951. */ + /* Gentleman W. M. and Marovich S. B. (1974) More on algorithms */ + /* that reveal properties of floating point arithmetic units. */ + /* Comms. of the ACM, 17, 276-277. */ -/* Gentleman W. M. and Marovich S. B. (1974) More on algorithms */ -/* that reveal properties of floating point arithmetic units. */ -/* Comms. of the ACM, 17, 276-277. */ + /* ===================================================================== */ -/* ===================================================================== */ + /* .. Local Scalars .. */ + /* .. */ + /* .. External Functions .. */ + /* .. */ + /* .. Save statement .. */ + /* .. */ + /* .. Data statements .. */ + /* .. */ + /* .. Executable Statements .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Save statement .. */ -/* .. */ -/* .. Data statements .. */ -/* .. */ -/* .. Executable Statements .. */ + if (first) { + one = 1.f; - if (first) { - one = 1.f; + /* LBETA, LIEEE1, LT and LRND are the local values of BETA, */ + /* IEEE1, T and RND. */ -/* LBETA, LIEEE1, LT and LRND are the local values of BETA, */ -/* IEEE1, T and RND. */ + /* Throughout this routine we use the function SLAMC3 to ensure */ + /* that relevant values are stored and not held in registers, or */ + /* are not affected by optimizers. */ -/* Throughout this routine we use the function SLAMC3 to ensure */ -/* that relevant values are stored and not held in registers, or */ -/* are not affected by optimizers. */ + /* Compute a = 2.0**m with the smallest positive integer m such */ + /* that */ -/* Compute a = 2.0**m with the smallest positive integer m such */ -/* that */ + /* fl( a + 1.0 ) = a. */ -/* fl( a + 1.0 ) = a. */ + a = 1.f; + c__ = 1.f; - a = 1.f; - c__ = 1.f; + /* + WHILE( C.EQ.ONE )LOOP */ + L10: + if (c__ == one) { + a *= 2; + c__ = slamc3_(&a, &one); + r__1 = -a; + c__ = slamc3_(&c__, &r__1); + goto L10; + } + /* + END WHILE */ -/* + WHILE( C.EQ.ONE )LOOP */ -L10: - if (c__ == one) { - a *= 2; - c__ = slamc3_(&a, &one); - r__1 = -a; - c__ = slamc3_(&c__, &r__1); - goto L10; - } -/* + END WHILE */ + /* Now compute b = 2.0**m with the smallest positive integer m */ + /* such that */ -/* Now compute b = 2.0**m with the smallest positive integer m */ -/* such that */ + /* fl( a + b ) .gt. a. */ -/* fl( a + b ) .gt. a. */ + b = 1.f; + c__ = slamc3_(&a, &b); - b = 1.f; - c__ = slamc3_(&a, &b); + /* + WHILE( C.EQ.A )LOOP */ + L20: + if (c__ == a) { + b *= 2; + c__ = slamc3_(&a, &b); + goto L20; + } + /* + END WHILE */ -/* + WHILE( C.EQ.A )LOOP */ -L20: - if (c__ == a) { - b *= 2; - c__ = slamc3_(&a, &b); - goto L20; - } -/* + END WHILE */ + /* Now compute the base. a and c are neighbouring floating point */ + /* numbers in the interval ( beta**t, beta**( t + 1 ) ) and so */ + /* their difference is beta. Adding 0.25 to c is to ensure that it */ + /* is truncated to beta and not ( beta - 1 ). */ -/* Now compute the base. a and c are neighbouring floating point */ -/* numbers in the interval ( beta**t, beta**( t + 1 ) ) and so */ -/* their difference is beta. Adding 0.25 to c is to ensure that it */ -/* is truncated to beta and not ( beta - 1 ). */ + qtr = one / 4; + savec = c__; + r__1 = -a; + c__ = slamc3_(&c__, &r__1); + lbeta = c__ + qtr; - qtr = one / 4; - savec = c__; - r__1 = -a; - c__ = slamc3_(&c__, &r__1); - lbeta = c__ + qtr; + /* Now determine whether rounding or chopping occurs, by adding a */ + /* bit less than beta/2 and a bit more than beta/2 to a. */ -/* Now determine whether rounding or chopping occurs, by adding a */ -/* bit less than beta/2 and a bit more than beta/2 to a. */ - - b = (real) lbeta; - r__1 = b / 2; - r__2 = -b / 100; - f = slamc3_(&r__1, &r__2); - c__ = slamc3_(&f, &a); - if (c__ == a) { - lrnd = TRUE_; - } else { - lrnd = FALSE_; - } - r__1 = b / 2; - r__2 = b / 100; - f = slamc3_(&r__1, &r__2); - c__ = slamc3_(&f, &a); - if (lrnd && c__ == a) { - lrnd = FALSE_; - } - -/* Try and decide whether rounding is done in the IEEE 'round to */ -/* nearest' style. B/2 is half a unit in the last place of the two */ -/* numbers A and SAVEC. Furthermore, A is even, i.e. has last bit */ -/* zero, and SAVEC is odd. Thus adding B/2 to A should not change */ -/* A, but adding B/2 to SAVEC should change SAVEC. */ - - r__1 = b / 2; - t1 = slamc3_(&r__1, &a); - r__1 = b / 2; - t2 = slamc3_(&r__1, &savec); - lieee1 = t1 == a && t2 > savec && lrnd; - -/* Now find the mantissa, t. It should be the integer part of */ -/* log to the base beta of a, however it is safer to determine t */ -/* by powering. So we find t as the smallest positive integer for */ -/* which */ - -/* fl( beta**t + 1.0 ) = 1.0. */ - - lt = 0; - a = 1.f; - c__ = 1.f; - -/* + WHILE( C.EQ.ONE )LOOP */ -L30: - if (c__ == one) { - ++lt; - a *= lbeta; - c__ = slamc3_(&a, &one); - r__1 = -a; - c__ = slamc3_(&c__, &r__1); - goto L30; - } -/* + END WHILE */ - + b = (real)lbeta; + r__1 = b / 2; + r__2 = -b / 100; + f = slamc3_(&r__1, &r__2); + c__ = slamc3_(&f, &a); + if (c__ == a) { + lrnd = TRUE_; + } else { + lrnd = FALSE_; + } + r__1 = b / 2; + r__2 = b / 100; + f = slamc3_(&r__1, &r__2); + c__ = slamc3_(&f, &a); + if (lrnd && c__ == a) { + lrnd = FALSE_; } - *beta = lbeta; - *t = lt; - *rnd = lrnd; - *ieee1 = lieee1; - first = FALSE_; - return 0; + /* Try and decide whether rounding is done in the IEEE 'round to */ + /* nearest' style. B/2 is half a unit in the last place of the two */ + /* numbers A and SAVEC. Furthermore, A is even, i.e. has last bit */ + /* zero, and SAVEC is odd. Thus adding B/2 to A should not change */ + /* A, but adding B/2 to SAVEC should change SAVEC. */ -/* End of SLAMC1 */ + r__1 = b / 2; + t1 = slamc3_(&r__1, &a); + r__1 = b / 2; + t2 = slamc3_(&r__1, &savec); + lieee1 = t1 == a && t2 > savec && lrnd; + + /* Now find the mantissa, t. It should be the integer part of */ + /* log to the base beta of a, however it is safer to determine t */ + /* by powering. So we find t as the smallest positive integer for */ + /* which */ + + /* fl( beta**t + 1.0 ) = 1.0. */ + + lt = 0; + a = 1.f; + c__ = 1.f; + + /* + WHILE( C.EQ.ONE )LOOP */ + L30: + if (c__ == one) { + ++lt; + a *= lbeta; + c__ = slamc3_(&a, &one); + r__1 = -a; + c__ = slamc3_(&c__, &r__1); + goto L30; + } + /* + END WHILE */ + } + + *beta = lbeta; + *t = lt; + *rnd = lrnd; + *ieee1 = lieee1; + first = FALSE_; + + /* End of SLAMC1 */ } /* slamc1_ */ - /* *********************************************************************** */ -/* Subroutine */ int slamc2_(integer *beta, integer *t, logical *rnd, real * - eps, integer *emin, real *rmin, integer *emax, real *rmax) -{ - /* Initialized data */ +/* Subroutine */ void slamc2_(integer *beta, integer *t, logical *rnd, real *eps, integer *emin, real *rmin, + integer *emax, real *rmax) { + /* Initialized data */ - static logical first = TRUE_; - static logical iwarn = FALSE_; + static logical first = TRUE_; + static logical iwarn = FALSE_; - /* Format strings */ - static char fmt_9999[] = "(//\002 WARNING. The value EMIN may be incorre" - "ct:-\002,\002 EMIN = \002,i8,/\002 If, after inspection, the va" - "lue EMIN looks\002,\002 acceptable please comment out \002,/\002" - " the IF block as marked within the code of routine\002,\002 SLAM" - "C2,\002,/\002 otherwise supply EMIN explicitly.\002,/)"; + /* Format strings */ + /* + static char fmt_9999[] = + "(//\002 WARNING. The value EMIN may be incorre" + "ct:-\002,\002 EMIN = \002,i8,/\002 If, after inspection, the va" + "lue EMIN looks\002,\002 acceptable please comment out \002,/\002" + " the IF block as marked within the code of routine\002,\002 SLAM" + "C2,\002,/\002 otherwise supply EMIN explicitly.\002,/)"; + */ + /* System generated locals */ + integer i__1; + real r__1, r__2, r__3, r__4, r__5; - /* System generated locals */ - integer i__1; - real r__1, r__2, r__3, r__4, r__5; + /* Builtin functions */ + /* double pow_ri(real *, integer *); */ + /* integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void); */ - /* Builtin functions */ - double pow_ri(real *, integer *); - integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void); + /* Local variables */ + real a, b, c__; + integer i__; + static integer lt; + real one, two; + logical ieee; + real half; + logical lrnd = 0; + static real leps; + real zero; + static integer lbeta; + real rbase; + static integer lemin, lemax; + integer gnmin; + real small; + integer gpmin; + real third; + static real lrmin, lrmax; + real sixth; + logical lieee1; + extern /* Subroutine */ void slamc1_(integer *, integer *, logical *, logical *); + extern doublereal slamc3_(real *, real *); + extern /* Subroutine */ void slamc4_(integer *, real *, integer *), + slamc5_(integer *, integer *, integer *, logical *, integer *, real *); + integer ngnmin, ngpmin; - /* Local variables */ - real a, b, c__; - integer i__; - static integer lt; - real one, two; - logical ieee; - real half; - logical lrnd = 0; - static real leps; - real zero; - static integer lbeta; - real rbase; - static integer lemin, lemax; - integer gnmin; - real small; - integer gpmin; - real third; - static real lrmin, lrmax; - real sixth; - logical lieee1; - extern /* Subroutine */ int slamc1_(integer *, integer *, logical *, - logical *); - extern doublereal slamc3_(real *, real *); - extern /* Subroutine */ int slamc4_(integer *, real *, integer *), - slamc5_(integer *, integer *, integer *, logical *, integer *, - real *); - integer ngnmin, ngpmin; + /* Fortran I/O blocks */ + /* static cilist io___58 = {0, 6, 0, fmt_9999, 0}; */ - /* Fortran I/O blocks */ - static cilist io___58 = { 0, 6, 0, fmt_9999, 0 }; + /* -- LAPACK auxiliary routine (version 3.2) -- */ + /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ + /* November 2006 */ + /* .. Scalar Arguments .. */ + /* .. */ + /* Purpose */ + /* ======= */ -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ + /* SLAMC2 determines the machine parameters specified in its argument */ + /* list. */ -/* .. Scalar Arguments .. */ -/* .. */ + /* Arguments */ + /* ========= */ -/* Purpose */ -/* ======= */ + /* BETA (output) INTEGER */ + /* The base of the machine. */ -/* SLAMC2 determines the machine parameters specified in its argument */ -/* list. */ + /* T (output) INTEGER */ + /* The number of ( BETA ) digits in the mantissa. */ -/* Arguments */ -/* ========= */ + /* RND (output) LOGICAL */ + /* Specifies whether proper rounding ( RND = .TRUE. ) or */ + /* chopping ( RND = .FALSE. ) occurs in addition. This may not */ + /* be a reliable guide to the way in which the machine performs */ + /* its arithmetic. */ -/* BETA (output) INTEGER */ -/* The base of the machine. */ + /* EPS (output) REAL */ + /* The smallest positive number such that */ -/* T (output) INTEGER */ -/* The number of ( BETA ) digits in the mantissa. */ + /* fl( 1.0 - EPS ) .LT. 1.0, */ -/* RND (output) LOGICAL */ -/* Specifies whether proper rounding ( RND = .TRUE. ) or */ -/* chopping ( RND = .FALSE. ) occurs in addition. This may not */ -/* be a reliable guide to the way in which the machine performs */ -/* its arithmetic. */ + /* where fl denotes the computed value. */ -/* EPS (output) REAL */ -/* The smallest positive number such that */ + /* EMIN (output) INTEGER */ + /* The minimum exponent before (gradual) underflow occurs. */ -/* fl( 1.0 - EPS ) .LT. 1.0, */ + /* RMIN (output) REAL */ + /* The smallest normalized number for the machine, given by */ + /* BASE**( EMIN - 1 ), where BASE is the floating point value */ + /* of BETA. */ -/* where fl denotes the computed value. */ + /* EMAX (output) INTEGER */ + /* The maximum exponent before overflow occurs. */ -/* EMIN (output) INTEGER */ -/* The minimum exponent before (gradual) underflow occurs. */ + /* RMAX (output) REAL */ + /* The largest positive number for the machine, given by */ + /* BASE**EMAX * ( 1 - EPS ), where BASE is the floating point */ + /* value of BETA. */ -/* RMIN (output) REAL */ -/* The smallest normalized number for the machine, given by */ -/* BASE**( EMIN - 1 ), where BASE is the floating point value */ -/* of BETA. */ + /* Further Details */ + /* =============== */ -/* EMAX (output) INTEGER */ -/* The maximum exponent before overflow occurs. */ + /* The computation of EPS is based on a routine PARANOIA by */ + /* W. Kahan of the University of California at Berkeley. */ -/* RMAX (output) REAL */ -/* The largest positive number for the machine, given by */ -/* BASE**EMAX * ( 1 - EPS ), where BASE is the floating point */ -/* value of BETA. */ + /* ===================================================================== */ -/* Further Details */ -/* =============== */ + /* .. Local Scalars .. */ + /* .. */ + /* .. External Functions .. */ + /* .. */ + /* .. External Subroutines .. */ + /* .. */ + /* .. Intrinsic Functions .. */ + /* .. */ + /* .. Save statement .. */ + /* .. */ + /* .. Data statements .. */ + /* .. */ + /* .. Executable Statements .. */ -/* The computation of EPS is based on a routine PARANOIA by */ -/* W. Kahan of the University of California at Berkeley. */ + if (first) { + zero = 0.f; + one = 1.f; + two = 2.f; -/* ===================================================================== */ + /* LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values of */ + /* BETA, T, RND, EPS, EMIN and RMIN. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Save statement .. */ -/* .. */ -/* .. Data statements .. */ -/* .. */ -/* .. Executable Statements .. */ + /* Throughout this routine we use the function SLAMC3 to ensure */ + /* that relevant values are stored and not held in registers, or */ + /* are not affected by optimizers. */ - if (first) { - zero = 0.f; - one = 1.f; - two = 2.f; + /* SLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1. */ -/* LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values of */ -/* BETA, T, RND, EPS, EMIN and RMIN. */ + slamc1_(&lbeta, <, &lrnd, &lieee1); -/* Throughout this routine we use the function SLAMC3 to ensure */ -/* that relevant values are stored and not held in registers, or */ -/* are not affected by optimizers. */ + /* Start to find EPS. */ -/* SLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1. */ + b = (real)lbeta; + i__1 = -lt; + a = pow_ri(&b, &i__1); + leps = a; - slamc1_(&lbeta, <, &lrnd, &lieee1); + /* Try some tricks to see whether or not this is the correct EPS. */ -/* Start to find EPS. */ - - b = (real) lbeta; - i__1 = -lt; - a = pow_ri(&b, &i__1); - leps = a; - -/* Try some tricks to see whether or not this is the correct EPS. */ - - b = two / 3; - half = one / 2; - r__1 = -half; - sixth = slamc3_(&b, &r__1); - third = slamc3_(&sixth, &sixth); - r__1 = -half; - b = slamc3_(&third, &r__1); - b = slamc3_(&b, &sixth); - b = dabs(b); - if (b < leps) { - b = leps; - } - - leps = 1.f; - -/* + WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP */ -L10: - if (leps > b && b > zero) { - leps = b; - r__1 = half * leps; -/* Computing 5th power */ - r__3 = two, r__4 = r__3, r__3 *= r__3; -/* Computing 2nd power */ - r__5 = leps; - r__2 = r__4 * (r__3 * r__3) * (r__5 * r__5); - c__ = slamc3_(&r__1, &r__2); - r__1 = -c__; - c__ = slamc3_(&half, &r__1); - b = slamc3_(&half, &c__); - r__1 = -b; - c__ = slamc3_(&half, &r__1); - b = slamc3_(&half, &c__); - goto L10; - } -/* + END WHILE */ - - if (a < leps) { - leps = a; - } - -/* Computation of EPS complete. */ - -/* Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3)). */ -/* Keep dividing A by BETA until (gradual) underflow occurs. This */ -/* is detected when we cannot recover the previous A. */ - - rbase = one / lbeta; - small = one; - for (i__ = 1; i__ <= 3; ++i__) { - r__1 = small * rbase; - small = slamc3_(&r__1, &zero); -/* L20: */ - } - a = slamc3_(&one, &small); - slamc4_(&ngpmin, &one, &lbeta); - r__1 = -one; - slamc4_(&ngnmin, &r__1, &lbeta); - slamc4_(&gpmin, &a, &lbeta); - r__1 = -a; - slamc4_(&gnmin, &r__1, &lbeta); - ieee = FALSE_; - - if (ngpmin == ngnmin && gpmin == gnmin) { - if (ngpmin == gpmin) { - lemin = ngpmin; -/* ( Non twos-complement machines, no gradual underflow; */ -/* e.g., VAX ) */ - } else if (gpmin - ngpmin == 3) { - lemin = ngpmin - 1 + lt; - ieee = TRUE_; -/* ( Non twos-complement machines, with gradual underflow; */ -/* e.g., IEEE standard followers ) */ - } else { - lemin = min(ngpmin,gpmin); -/* ( A guess; no known machine ) */ - iwarn = TRUE_; - } - - } else if (ngpmin == gpmin && ngnmin == gnmin) { - if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1) { - lemin = max(ngpmin,ngnmin); -/* ( Twos-complement machines, no gradual underflow; */ -/* e.g., CYBER 205 ) */ - } else { - lemin = min(ngpmin,ngnmin); -/* ( A guess; no known machine ) */ - iwarn = TRUE_; - } - - } else if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1 && gpmin == gnmin) - { - if (gpmin - min(ngpmin,ngnmin) == 3) { - lemin = max(ngpmin,ngnmin) - 1 + lt; -/* ( Twos-complement machines with gradual underflow; */ -/* no known machine ) */ - } else { - lemin = min(ngpmin,ngnmin); -/* ( A guess; no known machine ) */ - iwarn = TRUE_; - } - - } else { -/* Computing MIN */ - i__1 = min(ngpmin,ngnmin), i__1 = min(i__1,gpmin); - lemin = min(i__1,gnmin); -/* ( A guess; no known machine ) */ - iwarn = TRUE_; - } - first = FALSE_; -/* ** */ -/* Comment out this if block if EMIN is ok */ - if (iwarn) { - first = TRUE_; - s_wsfe(&io___58); - do_fio(&c__1, (char *)&lemin, (ftnlen)sizeof(integer)); - e_wsfe(); - } -/* ** */ - -/* Assume IEEE arithmetic if we found denormalised numbers above, */ -/* or if arithmetic seems to round in the IEEE style, determined */ -/* in routine SLAMC1. A true IEEE machine should have both things */ -/* true; however, faulty machines may have one or the other. */ - - ieee = ieee || lieee1; - -/* Compute RMIN by successive division by BETA. We could compute */ -/* RMIN as BASE**( EMIN - 1 ), but some machines underflow during */ -/* this computation. */ - - lrmin = 1.f; - i__1 = 1 - lemin; - for (i__ = 1; i__ <= i__1; ++i__) { - r__1 = lrmin * rbase; - lrmin = slamc3_(&r__1, &zero); -/* L30: */ - } - -/* Finally, call SLAMC5 to compute EMAX and RMAX. */ - - slamc5_(&lbeta, <, &lemin, &ieee, &lemax, &lrmax); + b = two / 3; + half = one / 2; + r__1 = -half; + sixth = slamc3_(&b, &r__1); + third = slamc3_(&sixth, &sixth); + r__1 = -half; + b = slamc3_(&third, &r__1); + b = slamc3_(&b, &sixth); + b = dabs(b); + if (b < leps) { + b = leps; } - *beta = lbeta; - *t = lt; - *rnd = lrnd; - *eps = leps; - *emin = lemin; - *rmin = lrmin; - *emax = lemax; - *rmax = lrmax; + leps = 1.f; - return 0; + /* + WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP */ + L10: + if (leps > b && b > zero) { + leps = b; + r__1 = half * leps; + /* Computing 5th power */ + r__3 = two, r__4 = r__3, r__3 *= r__3; + /* Computing 2nd power */ + r__5 = leps; + r__2 = r__4 * (r__3 * r__3) * (r__5 * r__5); + c__ = slamc3_(&r__1, &r__2); + r__1 = -c__; + c__ = slamc3_(&half, &r__1); + b = slamc3_(&half, &c__); + r__1 = -b; + c__ = slamc3_(&half, &r__1); + b = slamc3_(&half, &c__); + goto L10; + } + /* + END WHILE */ + if (a < leps) { + leps = a; + } -/* End of SLAMC2 */ + /* Computation of EPS complete. */ + + /* Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3)). */ + /* Keep dividing A by BETA until (gradual) underflow occurs. This */ + /* is detected when we cannot recover the previous A. */ + + rbase = one / lbeta; + small = one; + for (i__ = 1; i__ <= 3; ++i__) { + r__1 = small * rbase; + small = slamc3_(&r__1, &zero); + /* L20: */ + } + a = slamc3_(&one, &small); + slamc4_(&ngpmin, &one, &lbeta); + r__1 = -one; + slamc4_(&ngnmin, &r__1, &lbeta); + slamc4_(&gpmin, &a, &lbeta); + r__1 = -a; + slamc4_(&gnmin, &r__1, &lbeta); + ieee = FALSE_; + + if (ngpmin == ngnmin && gpmin == gnmin) { + if (ngpmin == gpmin) { + lemin = ngpmin; + /* ( Non twos-complement machines, no gradual underflow; */ + /* e.g., VAX ) */ + } else if (gpmin - ngpmin == 3) { + lemin = ngpmin - 1 + lt; + ieee = TRUE_; + /* ( Non twos-complement machines, with gradual underflow; */ + /* e.g., IEEE standard followers ) */ + } else { + lemin = min(ngpmin, gpmin); + /* ( A guess; no known machine ) */ + iwarn = TRUE_; + } + + } else if (ngpmin == gpmin && ngnmin == gnmin) { + if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1) { + lemin = max(ngpmin, ngnmin); + /* ( Twos-complement machines, no gradual underflow; */ + /* e.g., CYBER 205 ) */ + } else { + lemin = min(ngpmin, ngnmin); + /* ( A guess; no known machine ) */ + iwarn = TRUE_; + } + + } else if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1 && gpmin == gnmin) { + if (gpmin - min(ngpmin, ngnmin) == 3) { + lemin = max(ngpmin, ngnmin) - 1 + lt; + /* ( Twos-complement machines with gradual underflow; */ + /* no known machine ) */ + } else { + lemin = min(ngpmin, ngnmin); + /* ( A guess; no known machine ) */ + iwarn = TRUE_; + } + + } else { + /* Computing MIN */ + i__1 = min(ngpmin, ngnmin), i__1 = min(i__1, gpmin); + lemin = min(i__1, gnmin); + /* ( A guess; no known machine ) */ + iwarn = TRUE_; + } + first = FALSE_; + /* ** */ + /* Comment out this if block if EMIN is ok */ + /* + if (iwarn) { + first = TRUE_; + s_wsfe(&io___58); + do_fio(&c__1, (char *)&lemin, (ftnlen)sizeof(integer)); + e_wsfe(); + } + */ + /* ** */ + + /* Assume IEEE arithmetic if we found denormalised numbers above, */ + /* or if arithmetic seems to round in the IEEE style, determined */ + /* in routine SLAMC1. A true IEEE machine should have both things */ + /* true; however, faulty machines may have one or the other. */ + + ieee = ieee || lieee1; + + /* Compute RMIN by successive division by BETA. We could compute */ + /* RMIN as BASE**( EMIN - 1 ), but some machines underflow during */ + /* this computation. */ + + lrmin = 1.f; + i__1 = 1 - lemin; + for (i__ = 1; i__ <= i__1; ++i__) { + r__1 = lrmin * rbase; + lrmin = slamc3_(&r__1, &zero); + /* L30: */ + } + + /* Finally, call SLAMC5 to compute EMAX and RMAX. */ + + slamc5_(&lbeta, <, &lemin, &ieee, &lemax, &lrmax); + } + + *beta = lbeta; + *t = lt; + *rnd = lrnd; + *eps = leps; + *emin = lemin; + *rmin = lrmin; + *emax = lemax; + *rmax = lrmax; + + /* End of SLAMC2 */ } /* slamc2_ */ - /* *********************************************************************** */ -doublereal slamc3_(real *a, real *b) -{ - /* System generated locals */ - real ret_val; +doublereal slamc3_(real *a, real *b) { + /* System generated locals */ + real ret_val; + /* -- LAPACK auxiliary routine (version 3.2) -- */ + /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ + /* November 2006 */ -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ + /* .. Scalar Arguments .. */ + /* .. */ -/* .. Scalar Arguments .. */ -/* .. */ + /* Purpose */ + /* ======= */ -/* Purpose */ -/* ======= */ + /* SLAMC3 is intended to force A and B to be stored prior to doing */ + /* the addition of A and B , for use in situations where optimizers */ + /* might hold one of these in a register. */ -/* SLAMC3 is intended to force A and B to be stored prior to doing */ -/* the addition of A and B , for use in situations where optimizers */ -/* might hold one of these in a register. */ + /* Arguments */ + /* ========= */ -/* Arguments */ -/* ========= */ + /* A (input) REAL */ + /* B (input) REAL */ + /* The values A and B. */ -/* A (input) REAL */ -/* B (input) REAL */ -/* The values A and B. */ + /* ===================================================================== */ -/* ===================================================================== */ + /* .. Executable Statements .. */ -/* .. Executable Statements .. */ + ret_val = *a + *b; - ret_val = *a + *b; + return ret_val; - return ret_val; - -/* End of SLAMC3 */ + /* End of SLAMC3 */ } /* slamc3_ */ - /* *********************************************************************** */ -/* Subroutine */ int slamc4_(integer *emin, real *start, integer *base) -{ - /* System generated locals */ - integer i__1; - real r__1; +/* Subroutine */ void slamc4_(integer *emin, real *start, integer *base) { + /* System generated locals */ + integer i__1; + real r__1; - /* Local variables */ - real a; - integer i__; - real b1, b2, c1, c2, d1, d2, one, zero, rbase; - extern doublereal slamc3_(real *, real *); + /* Local variables */ + real a; + integer i__; + real b1, b2, c1, c2, d1, d2, one, zero, rbase; + extern doublereal slamc3_(real *, real *); + /* -- LAPACK auxiliary routine (version 3.2) -- */ + /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ + /* November 2006 */ -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ + /* .. Scalar Arguments .. */ + /* .. */ -/* .. Scalar Arguments .. */ -/* .. */ + /* Purpose */ + /* ======= */ -/* Purpose */ -/* ======= */ + /* SLAMC4 is a service routine for SLAMC2. */ -/* SLAMC4 is a service routine for SLAMC2. */ + /* Arguments */ + /* ========= */ -/* Arguments */ -/* ========= */ + /* EMIN (output) INTEGER */ + /* The minimum exponent before (gradual) underflow, computed by */ + /* setting A = START and dividing by BASE until the previous A */ + /* can not be recovered. */ -/* EMIN (output) INTEGER */ -/* The minimum exponent before (gradual) underflow, computed by */ -/* setting A = START and dividing by BASE until the previous A */ -/* can not be recovered. */ + /* START (input) REAL */ + /* The starting point for determining EMIN. */ -/* START (input) REAL */ -/* The starting point for determining EMIN. */ + /* BASE (input) INTEGER */ + /* The base of the machine. */ -/* BASE (input) INTEGER */ -/* The base of the machine. */ + /* ===================================================================== */ -/* ===================================================================== */ + /* .. Local Scalars .. */ + /* .. */ + /* .. External Functions .. */ + /* .. */ + /* .. Executable Statements .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - a = *start; - one = 1.f; - rbase = one / *base; - zero = 0.f; - *emin = 1; - r__1 = a * rbase; - b1 = slamc3_(&r__1, &zero); - c1 = a; - c2 = a; - d1 = a; - d2 = a; + a = *start; + one = 1.f; + rbase = one / *base; + zero = 0.f; + *emin = 1; + r__1 = a * rbase; + b1 = slamc3_(&r__1, &zero); + c1 = a; + c2 = a; + d1 = a; + d2 = a; /* + WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND. */ /* $ ( D1.EQ.A ).AND.( D2.EQ.A ) )LOOP */ L10: - if (c1 == a && c2 == a && d1 == a && d2 == a) { - --(*emin); - a = b1; - r__1 = a / *base; - b1 = slamc3_(&r__1, &zero); - r__1 = b1 * *base; - c1 = slamc3_(&r__1, &zero); - d1 = zero; - i__1 = *base; - for (i__ = 1; i__ <= i__1; ++i__) { - d1 += b1; -/* L20: */ - } - r__1 = a * rbase; - b2 = slamc3_(&r__1, &zero); - r__1 = b2 / rbase; - c2 = slamc3_(&r__1, &zero); - d2 = zero; - i__1 = *base; - for (i__ = 1; i__ <= i__1; ++i__) { - d2 += b2; -/* L30: */ - } - goto L10; + if (c1 == a && c2 == a && d1 == a && d2 == a) { + --(*emin); + a = b1; + r__1 = a / *base; + b1 = slamc3_(&r__1, &zero); + r__1 = b1 * *base; + c1 = slamc3_(&r__1, &zero); + d1 = zero; + i__1 = *base; + for (i__ = 1; i__ <= i__1; ++i__) { + d1 += b1; + /* L20: */ } -/* + END WHILE */ + r__1 = a * rbase; + b2 = slamc3_(&r__1, &zero); + r__1 = b2 / rbase; + c2 = slamc3_(&r__1, &zero); + d2 = zero; + i__1 = *base; + for (i__ = 1; i__ <= i__1; ++i__) { + d2 += b2; + /* L30: */ + } + goto L10; + } + /* + END WHILE */ - return 0; - -/* End of SLAMC4 */ + /* End of SLAMC4 */ } /* slamc4_ */ - /* *********************************************************************** */ -/* Subroutine */ int slamc5_(integer *beta, integer *p, integer *emin, - logical *ieee, integer *emax, real *rmax) -{ - /* System generated locals */ - integer i__1; - real r__1; +/* Subroutine */ void slamc5_(integer *beta, integer *p, integer *emin, logical *ieee, integer *emax, real *rmax) { + /* System generated locals */ + integer i__1; + real r__1; - /* Local variables */ - integer i__; - real y, z__; - integer try__, lexp; - real oldy; - integer uexp, nbits; - extern doublereal slamc3_(real *, real *); - real recbas; - integer exbits, expsum; + /* Local variables */ + integer i__; + real y, z__; + integer try__, lexp; + real oldy; + integer uexp, nbits; + extern doublereal slamc3_(real *, real *); + real recbas; + integer exbits, expsum; + /* -- LAPACK auxiliary routine (version 3.2) -- */ + /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ + /* November 2006 */ -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ + /* .. Scalar Arguments .. */ + /* .. */ -/* .. Scalar Arguments .. */ -/* .. */ + /* Purpose */ + /* ======= */ -/* Purpose */ -/* ======= */ + /* SLAMC5 attempts to compute RMAX, the largest machine floating-point */ + /* number, without overflow. It assumes that EMAX + abs(EMIN) sum */ + /* approximately to a power of 2. It will fail on machines where this */ + /* assumption does not hold, for example, the Cyber 205 (EMIN = -28625, */ + /* EMAX = 28718). It will also fail if the value supplied for EMIN is */ + /* too large (i.e. too close to zero), probably with overflow. */ -/* SLAMC5 attempts to compute RMAX, the largest machine floating-point */ -/* number, without overflow. It assumes that EMAX + abs(EMIN) sum */ -/* approximately to a power of 2. It will fail on machines where this */ -/* assumption does not hold, for example, the Cyber 205 (EMIN = -28625, */ -/* EMAX = 28718). It will also fail if the value supplied for EMIN is */ -/* too large (i.e. too close to zero), probably with overflow. */ + /* Arguments */ + /* ========= */ -/* Arguments */ -/* ========= */ + /* BETA (input) INTEGER */ + /* The base of floating-point arithmetic. */ -/* BETA (input) INTEGER */ -/* The base of floating-point arithmetic. */ + /* P (input) INTEGER */ + /* The number of base BETA digits in the mantissa of a */ + /* floating-point value. */ -/* P (input) INTEGER */ -/* The number of base BETA digits in the mantissa of a */ -/* floating-point value. */ + /* EMIN (input) INTEGER */ + /* The minimum exponent before (gradual) underflow. */ -/* EMIN (input) INTEGER */ -/* The minimum exponent before (gradual) underflow. */ + /* IEEE (input) LOGICAL */ + /* A logical flag specifying whether or not the arithmetic */ + /* system is thought to comply with the IEEE standard. */ -/* IEEE (input) LOGICAL */ -/* A logical flag specifying whether or not the arithmetic */ -/* system is thought to comply with the IEEE standard. */ + /* EMAX (output) INTEGER */ + /* The largest exponent before overflow */ -/* EMAX (output) INTEGER */ -/* The largest exponent before overflow */ + /* RMAX (output) REAL */ + /* The largest machine floating-point number. */ -/* RMAX (output) REAL */ -/* The largest machine floating-point number. */ + /* ===================================================================== */ -/* ===================================================================== */ + /* .. Parameters .. */ + /* .. */ + /* .. Local Scalars .. */ + /* .. */ + /* .. External Functions .. */ + /* .. */ + /* .. Intrinsic Functions .. */ + /* .. */ + /* .. Executable Statements .. */ -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ + /* First compute LEXP and UEXP, two powers of 2 that bound */ + /* abs(EMIN). We then assume that EMAX + abs(EMIN) will sum */ + /* approximately to the bound that is closest to abs(EMIN). */ + /* (EMAX is the exponent of the required number RMAX). */ -/* First compute LEXP and UEXP, two powers of 2 that bound */ -/* abs(EMIN). We then assume that EMAX + abs(EMIN) will sum */ -/* approximately to the bound that is closest to abs(EMIN). */ -/* (EMAX is the exponent of the required number RMAX). */ - - lexp = 1; - exbits = 1; + lexp = 1; + exbits = 1; L10: - try__ = lexp << 1; - if (try__ <= -(*emin)) { - lexp = try__; - ++exbits; - goto L10; + try__ = lexp << 1; + if (try__ <= -(*emin)) { + lexp = try__; + ++exbits; + goto L10; + } + if (lexp == -(*emin)) { + uexp = lexp; + } else { + uexp = try__; + ++exbits; + } + + /* Now -LEXP is less than or equal to EMIN, and -UEXP is greater */ + /* than or equal to EMIN. EXBITS is the number of bits needed to */ + /* store the exponent. */ + + if (uexp + *emin > -lexp - *emin) { + expsum = lexp << 1; + } else { + expsum = uexp << 1; + } + + /* EXPSUM is the exponent range, approximately equal to */ + /* EMAX - EMIN + 1 . */ + + *emax = expsum + *emin - 1; + nbits = exbits + 1 + *p; + + /* NBITS is the total number of bits needed to store a */ + /* floating-point number. */ + + if (nbits % 2 == 1 && *beta == 2) { + /* Either there are an odd number of bits used to store a */ + /* floating-point number, which is unlikely, or some bits are */ + /* not used in the representation of numbers, which is possible, */ + /* (e.g. Cray machines) or the mantissa has an implicit bit, */ + /* (e.g. IEEE machines, Dec Vax machines), which is perhaps the */ + /* most likely. We have to assume the last alternative. */ + /* If this is true, then we need to reduce EMAX by one because */ + /* there must be some way of representing zero in an implicit-bit */ + /* system. On machines like Cray, we are reducing EMAX by one */ + /* unnecessarily. */ + + --(*emax); + } + + if (*ieee) { + /* Assume we are on an IEEE machine which reserves one exponent */ + /* for infinity and NaN. */ + + --(*emax); + } + + /* Now create RMAX, the largest machine number, which should */ + /* be equal to (1.0 - BETA**(-P)) * BETA**EMAX . */ + + /* First compute 1.0 - BETA**(-P), being careful that the */ + /* result is less than 1.0 . */ + + recbas = 1.f / *beta; + z__ = *beta - 1.f; + y = 0.f; + i__1 = *p; + for (i__ = 1; i__ <= i__1; ++i__) { + z__ *= recbas; + if (y < 1.f) { + oldy = y; } - if (lexp == -(*emin)) { - uexp = lexp; - } else { - uexp = try__; - ++exbits; - } + y = slamc3_(&y, &z__); + /* L20: */ + } + if (y >= 1.f) { + y = oldy; + } -/* Now -LEXP is less than or equal to EMIN, and -UEXP is greater */ -/* than or equal to EMIN. EXBITS is the number of bits needed to */ -/* store the exponent. */ + /* Now multiply by BETA**EMAX to get RMAX. */ - if (uexp + *emin > -lexp - *emin) { - expsum = lexp << 1; - } else { - expsum = uexp << 1; - } + i__1 = *emax; + for (i__ = 1; i__ <= i__1; ++i__) { + r__1 = y * *beta; + y = slamc3_(&r__1, &c_b32); + /* L30: */ + } -/* EXPSUM is the exponent range, approximately equal to */ -/* EMAX - EMIN + 1 . */ + *rmax = y; - *emax = expsum + *emin - 1; - nbits = exbits + 1 + *p; - -/* NBITS is the total number of bits needed to store a */ -/* floating-point number. */ - - if (nbits % 2 == 1 && *beta == 2) { - -/* Either there are an odd number of bits used to store a */ -/* floating-point number, which is unlikely, or some bits are */ -/* not used in the representation of numbers, which is possible, */ -/* (e.g. Cray machines) or the mantissa has an implicit bit, */ -/* (e.g. IEEE machines, Dec Vax machines), which is perhaps the */ -/* most likely. We have to assume the last alternative. */ -/* If this is true, then we need to reduce EMAX by one because */ -/* there must be some way of representing zero in an implicit-bit */ -/* system. On machines like Cray, we are reducing EMAX by one */ -/* unnecessarily. */ - - --(*emax); - } - - if (*ieee) { - -/* Assume we are on an IEEE machine which reserves one exponent */ -/* for infinity and NaN. */ - - --(*emax); - } - -/* Now create RMAX, the largest machine number, which should */ -/* be equal to (1.0 - BETA**(-P)) * BETA**EMAX . */ - -/* First compute 1.0 - BETA**(-P), being careful that the */ -/* result is less than 1.0 . */ - - recbas = 1.f / *beta; - z__ = *beta - 1.f; - y = 0.f; - i__1 = *p; - for (i__ = 1; i__ <= i__1; ++i__) { - z__ *= recbas; - if (y < 1.f) { - oldy = y; - } - y = slamc3_(&y, &z__); -/* L20: */ - } - if (y >= 1.f) { - y = oldy; - } - -/* Now multiply by BETA**EMAX to get RMAX. */ - - i__1 = *emax; - for (i__ = 1; i__ <= i__1; ++i__) { - r__1 = y * *beta; - y = slamc3_(&r__1, &c_b32); -/* L30: */ - } - - *rmax = y; - return 0; - -/* End of SLAMC5 */ + /* End of SLAMC5 */ } /* slamc5_ */
diff --git a/lapack/slapy2.c b/lapack/slapy2.c index e048cac..63293cd 100644 --- a/lapack/slapy2.c +++ b/lapack/slapy2.c
@@ -10,8 +10,8 @@ http://www.netlib.org/f2c/libf2c.zip */ -#include "f2c.h" #include "blaswrap.h" +#include "lapack_datatypes.h" doublereal slapy2_(real *x, real *y) {
diff --git a/lapack/slapy3.c b/lapack/slapy3.c index 921a2c4..3e352a4 100644 --- a/lapack/slapy3.c +++ b/lapack/slapy3.c
@@ -10,8 +10,8 @@ http://www.netlib.org/f2c/libf2c.zip */ -#include "f2c.h" #include "blaswrap.h" +#include "lapack_datatypes.h" doublereal slapy3_(real *x, real *y, real *z__) {
diff --git a/lapack/slarf.c b/lapack/slarf.c index dbef082..66133ba 100644 --- a/lapack/slarf.c +++ b/lapack/slarf.c
@@ -1,17 +1,17 @@ /* slarf.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., + 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 + http://www.netlib.org/f2c/libf2c.zip */ -#include "f2c.h" #include "blaswrap.h" +#include "lapack_datatypes.h" /* Table of constant values */ @@ -19,173 +19,162 @@ static real c_b5 = 0.f; static integer c__1 = 1; -/* Subroutine */ int slarf_(char *side, integer *m, integer *n, real *v, - integer *incv, real *tau, real *c__, integer *ldc, real *work) -{ - /* System generated locals */ - integer c_dim1, c_offset; - real r__1; +/* Subroutine */ void slarf_(char *side, integer *m, integer *n, real *v, integer *incv, real *tau, real *c__, + integer *ldc, real *work) { + /* System generated locals */ + integer c_dim1, c_offset; + real r__1; - /* Local variables */ - integer i__; - logical applyleft; - extern /* Subroutine */ int sger_(integer *, integer *, real *, real *, - integer *, real *, integer *, real *, integer *); - extern logical lsame_(char *, char *); - integer lastc; - extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *, - real *, integer *, real *, integer *, real *, real *, integer *); - integer lastv; - extern integer ilaslc_(integer *, integer *, real *, integer *), ilaslr_( - integer *, integer *, real *, integer *); + /* Local variables */ + integer i__; + logical applyleft; + extern /* Subroutine */ void sger_(integer *, integer *, real *, real *, integer *, real *, integer *, real *, + integer *); + extern logical lsame_(char *, char *); + integer lastc; + extern /* Subroutine */ void sgemv_(const char *, const integer *, const integer *, const real *, const real *, + const integer *, const real *, const integer *, const real *, real *, + const integer *); + integer lastv; + extern integer ilaslc_(integer *, integer *, real *, integer *), ilaslr_(integer *, integer *, real *, integer *); + /* -- LAPACK auxiliary routine (version 3.2) -- */ + /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ + /* November 2006 */ -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ + /* .. Scalar Arguments .. */ + /* .. */ + /* .. Array Arguments .. */ + /* .. */ -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ + /* Purpose */ + /* ======= */ -/* Purpose */ -/* ======= */ + /* SLARF 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 */ -/* SLARF 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' */ -/* H = I - tau * v * v' */ + /* where tau is a real scalar and v is a real vector. */ -/* where tau is a real scalar and v is a real vector. */ + /* If tau = 0, then H is taken to be the unit matrix. */ -/* If tau = 0, then H is taken to be the unit matrix. */ + /* Arguments */ + /* ========= */ -/* Arguments */ -/* ========= */ + /* SIDE (input) CHARACTER*1 */ + /* = 'L': form H * C */ + /* = 'R': form C * H */ -/* SIDE (input) CHARACTER*1 */ -/* = 'L': form H * C */ -/* = 'R': form C * H */ + /* M (input) INTEGER */ + /* The number of rows of the matrix C. */ -/* M (input) INTEGER */ -/* The number of rows of the matrix C. */ + /* N (input) INTEGER */ + /* The number of columns of the matrix C. */ -/* N (input) INTEGER */ -/* The number of columns of the matrix C. */ + /* V (input) REAL 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. */ -/* V (input) REAL 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. */ -/* INCV (input) INTEGER */ -/* The increment between elements of v. INCV <> 0. */ + /* TAU (input) REAL */ + /* The value tau in the representation of H. */ -/* TAU (input) REAL */ -/* The value tau in the representation of H. */ + /* C (input/output) REAL 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'. */ -/* C (input/output) REAL 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). */ -/* LDC (input) INTEGER */ -/* The leading dimension of the array C. LDC >= max(1,M). */ + /* WORK (workspace) REAL array, dimension */ + /* (N) if SIDE = 'L' */ + /* or (M) if SIDE = 'R' */ -/* WORK (workspace) REAL array, dimension */ -/* (N) if SIDE = 'L' */ -/* or (M) if SIDE = 'R' */ + /* ===================================================================== */ -/* ===================================================================== */ + /* .. Parameters .. */ + /* .. */ + /* .. Local Scalars .. */ + /* .. */ + /* .. External Subroutines .. */ + /* .. */ + /* .. External Functions .. */ + /* .. */ + /* .. Executable Statements .. */ -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ + /* Parameter adjustments */ + --v; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + --work; - /* 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.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. */ - while(lastv > 0 && v[i__] == 0.f) { - --lastv; - i__ -= *incv; - } - if (applyleft) { -/* Scan for the last non-zero column in C(1:lastv,:). */ - lastc = ilaslc_(&lastv, n, &c__[c_offset], ldc); - } else { -/* Scan for the last non-zero row in C(:,1:lastv). */ - lastc = ilaslr_(m, &lastv, &c__[c_offset], ldc); - } - } -/* Note that lastc.eq.0 renders the BLAS operations null; no special */ -/* case is needed at this level. */ + /* Function Body */ + applyleft = lsame_(side, "L"); + lastv = 0; + lastc = 0; + if (*tau != 0.f) { + /* Set up variables for scanning V. LASTV begins pointing to the end */ + /* of V. */ if (applyleft) { - -/* Form H * C */ - - if (lastv > 0) { - -/* w(1:lastc,1) := C(1:lastv,1:lastc)' * v(1:lastv,1) */ - - sgemv_("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)' */ - - r__1 = -(*tau); - sger_(&lastv, &lastc, &r__1, &v[1], incv, &work[1], &c__1, &c__[ - c_offset], ldc); - } + lastv = *m; } else { - -/* Form C * H */ - - if (lastv > 0) { - -/* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) */ - - sgemv_("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)' */ - - r__1 = -(*tau); - sger_(&lastc, &lastv, &r__1, &work[1], &c__1, &v[1], incv, &c__[ - c_offset], ldc); - } + lastv = *n; } - return 0; + 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.f) { + --lastv; + i__ -= *incv; + } + if (applyleft) { + /* Scan for the last non-zero column in C(1:lastv,:). */ + lastc = ilaslc_(&lastv, n, &c__[c_offset], ldc); + } else { + /* Scan for the last non-zero row in C(:,1:lastv). */ + lastc = ilaslr_(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 */ -/* End of SLARF */ + if (lastv > 0) { + /* w(1:lastc,1) := C(1:lastv,1:lastc)' * v(1:lastv,1) */ + + sgemv_("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)' */ + + r__1 = -(*tau); + sger_(&lastv, &lastc, &r__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) */ + + sgemv_("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)' */ + + r__1 = -(*tau); + sger_(&lastc, &lastv, &r__1, &work[1], &c__1, &v[1], incv, &c__[c_offset], ldc); + } + } + + /* End of SLARF */ } /* slarf_ */
diff --git a/lapack/slarfb.c b/lapack/slarfb.c index 3c8030a..95364b2 100644 --- a/lapack/slarfb.c +++ b/lapack/slarfb.c
@@ -1,17 +1,17 @@ /* slarfb.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., + 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 + http://www.netlib.org/f2c/libf2c.zip */ -#include "f2c.h" #include "blaswrap.h" +#include "lapack_datatypes.h" /* Table of constant values */ @@ -19,755 +19,661 @@ static real c_b14 = 1.f; static real c_b25 = -1.f; -/* Subroutine */ int slarfb_(char *side, char *trans, char *direct, char * - storev, integer *m, integer *n, integer *k, real *v, integer *ldv, - real *t, integer *ldt, real *c__, integer *ldc, real *work, integer * - ldwork) -{ - /* System generated locals */ - integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1, - work_offset, i__1, i__2; +/* Subroutine */ void slarfb_(char *side, char *trans, char *direct, char *storev, integer *m, integer *n, integer *k, + real *v, integer *ldv, real *t, integer *ldt, real *c__, integer *ldc, real *work, + integer *ldwork) { + /* System generated locals */ + integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1, work_offset, i__1, i__2; - /* Local variables */ - integer i__, j; - extern logical lsame_(char *, char *); - integer lastc; - extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *, - integer *, real *, real *, integer *, real *, integer *, real *, - real *, integer *); - integer lastv; - extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, - integer *), strmm_(char *, char *, char *, char *, integer *, - integer *, real *, real *, integer *, real *, integer *); - extern integer ilaslc_(integer *, integer *, real *, integer *), ilaslr_( - integer *, integer *, real *, integer *); - char transt[1]; + /* Local variables */ + integer i__, j; + extern logical lsame_(char *, char *); + integer lastc; + extern /* Subroutine */ void sgemm_(const char *, const char *, const integer *, const integer *, const integer *, + const real *, const real *, const integer *, const real *, const integer *, + const real *, real *, const integer *); + integer lastv; + extern /* Subroutine */ void scopy_(integer *, real *, integer *, real *, integer *), + strmm_(const char *, const char *, const char *, const char *, const integer *, const integer *, const real *, + const real *, const integer *, real *, const integer *); + extern integer ilaslc_(integer *, integer *, real *, integer *), ilaslr_(integer *, integer *, real *, integer *); + char transt[1]; + /* -- LAPACK auxiliary routine (version 3.2) -- */ + /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ + /* November 2006 */ -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ + /* .. Scalar Arguments .. */ + /* .. */ + /* .. Array Arguments .. */ + /* .. */ -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ + /* Purpose */ + /* ======= */ -/* Purpose */ -/* ======= */ + /* SLARFB applies a real block reflector H or its transpose H' to a */ + /* real m by n matrix C, from either the left or the right. */ -/* SLARFB applies a real block reflector H or its transpose H' to a */ -/* real m by n matrix C, from either the left or the right. */ + /* Arguments */ + /* ========= */ -/* Arguments */ -/* ========= */ + /* SIDE (input) CHARACTER*1 */ + /* = 'L': apply H or H' from the Left */ + /* = 'R': apply H or H' from the Right */ -/* SIDE (input) CHARACTER*1 */ -/* = 'L': apply H or H' from the Left */ -/* = 'R': apply H or H' from the Right */ + /* TRANS (input) CHARACTER*1 */ + /* = 'N': apply H (No transpose) */ + /* = 'T': apply H' (Transpose) */ -/* TRANS (input) CHARACTER*1 */ -/* = 'N': apply H (No transpose) */ -/* = 'T': apply H' (Transpose) */ + /* DIRECT (input) CHARACTER*1 */ + /* Indicates how H is formed from a product of elementary */ + /* reflectors */ + /* = 'F': H = H(1) H(2) . . . H(k) (Forward) */ + /* = 'B': H = H(k) . . . H(2) H(1) (Backward) */ -/* DIRECT (input) CHARACTER*1 */ -/* Indicates how H is formed from a product of elementary */ -/* reflectors */ -/* = 'F': H = H(1) H(2) . . . H(k) (Forward) */ -/* = 'B': H = H(k) . . . H(2) H(1) (Backward) */ + /* STOREV (input) CHARACTER*1 */ + /* Indicates how the vectors which define the elementary */ + /* reflectors are stored: */ + /* = 'C': Columnwise */ + /* = 'R': Rowwise */ -/* STOREV (input) CHARACTER*1 */ -/* Indicates how the vectors which define the elementary */ -/* reflectors are stored: */ -/* = 'C': Columnwise */ -/* = 'R': Rowwise */ + /* M (input) INTEGER */ + /* The number of rows of the matrix C. */ -/* M (input) INTEGER */ -/* The number of rows of the matrix C. */ + /* N (input) INTEGER */ + /* The number of columns of the matrix C. */ -/* N (input) INTEGER */ -/* The number of columns of the matrix C. */ + /* K (input) INTEGER */ + /* The order of the matrix T (= the number of elementary */ + /* reflectors whose product defines the block reflector). */ -/* K (input) INTEGER */ -/* The order of the matrix T (= the number of elementary */ -/* reflectors whose product defines the block reflector). */ + /* V (input) REAL array, dimension */ + /* (LDV,K) if STOREV = 'C' */ + /* (LDV,M) if STOREV = 'R' and SIDE = 'L' */ + /* (LDV,N) if STOREV = 'R' and SIDE = 'R' */ + /* The matrix V. See further details. */ -/* V (input) REAL array, dimension */ -/* (LDV,K) if STOREV = 'C' */ -/* (LDV,M) if STOREV = 'R' and SIDE = 'L' */ -/* (LDV,N) if STOREV = 'R' and SIDE = 'R' */ -/* The matrix V. See further details. */ + /* LDV (input) INTEGER */ + /* The leading dimension of the array V. */ + /* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); */ + /* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); */ + /* if STOREV = 'R', LDV >= K. */ -/* LDV (input) INTEGER */ -/* The leading dimension of the array V. */ -/* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); */ -/* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); */ -/* if STOREV = 'R', LDV >= K. */ + /* T (input) REAL array, dimension (LDT,K) */ + /* The triangular k by k matrix T in the representation of the */ + /* block reflector. */ -/* T (input) REAL array, dimension (LDT,K) */ -/* The triangular k by k matrix T in the representation of the */ -/* block reflector. */ + /* LDT (input) INTEGER */ + /* The leading dimension of the array T. LDT >= K. */ -/* LDT (input) INTEGER */ -/* The leading dimension of the array T. LDT >= K. */ + /* C (input/output) REAL array, dimension (LDC,N) */ + /* On entry, the m by n matrix C. */ + /* On exit, C is overwritten by H*C or H'*C or C*H or C*H'. */ -/* C (input/output) REAL array, dimension (LDC,N) */ -/* On entry, the m by n matrix C. */ -/* On exit, C is overwritten by H*C or H'*C or C*H or C*H'. */ + /* LDC (input) INTEGER */ + /* The leading dimension of the array C. LDA >= max(1,M). */ -/* LDC (input) INTEGER */ -/* The leading dimension of the array C. LDA >= max(1,M). */ + /* WORK (workspace) REAL array, dimension (LDWORK,K) */ -/* WORK (workspace) REAL array, dimension (LDWORK,K) */ + /* LDWORK (input) INTEGER */ + /* The leading dimension of the array WORK. */ + /* If SIDE = 'L', LDWORK >= max(1,N); */ + /* if SIDE = 'R', LDWORK >= max(1,M). */ -/* LDWORK (input) INTEGER */ -/* The leading dimension of the array WORK. */ -/* If SIDE = 'L', LDWORK >= max(1,N); */ -/* if SIDE = 'R', LDWORK >= max(1,M). */ + /* ===================================================================== */ -/* ===================================================================== */ + /* .. Parameters .. */ + /* .. */ + /* .. Local Scalars .. */ + /* .. */ + /* .. External Functions .. */ + /* .. */ + /* .. External Subroutines .. */ + /* .. */ + /* .. Executable Statements .. */ -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Executable Statements .. */ + /* Quick return if possible */ -/* Quick return if possible */ + /* Parameter adjustments */ + v_dim1 = *ldv; + v_offset = 1 + v_dim1; + v -= v_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1; + t -= t_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + work_dim1 = *ldwork; + work_offset = 1 + work_dim1; + work -= work_offset; - /* Parameter adjustments */ - v_dim1 = *ldv; - v_offset = 1 + v_dim1; - v -= v_offset; - t_dim1 = *ldt; - t_offset = 1 + t_dim1; - t -= t_offset; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - work_dim1 = *ldwork; - work_offset = 1 + work_dim1; - work -= work_offset; + /* Function Body */ + if (*m <= 0 || *n <= 0) { + return; + } - /* Function Body */ - if (*m <= 0 || *n <= 0) { - return 0; - } + if (lsame_(trans, "N")) { + *(unsigned char *)transt = 'T'; + } else { + *(unsigned char *)transt = 'N'; + } - if (lsame_(trans, "N")) { - *(unsigned char *)transt = 'T'; + if (lsame_(storev, "C")) { + if (lsame_(direct, "F")) { + /* Let V = ( V1 ) (first K rows) */ + /* ( V2 ) */ + /* where V1 is unit lower triangular. */ + + if (lsame_(side, "L")) { + /* Form H * C or H' * C where C = ( C1 ) */ + /* ( C2 ) */ + + /* Computing MAX */ + i__1 = *k, i__2 = ilaslr_(m, k, &v[v_offset], ldv); + lastv = max(i__1, i__2); + lastc = ilaslc_(&lastv, n, &c__[c_offset], ldc); + + /* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) */ + + /* W := C1' */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + scopy_(&lastc, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1], &c__1); + /* L10: */ + } + + /* W := W * V1 */ + + strmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &c_b14, &v[v_offset], ldv, &work[work_offset], + ldwork); + if (lastv > *k) { + /* W := W + C2'*V2 */ + + i__1 = lastv - *k; + sgemm_("Transpose", "No transpose", &lastc, k, &i__1, &c_b14, &c__[*k + 1 + c_dim1], ldc, &v[*k + 1 + v_dim1], + ldv, &c_b14, &work[work_offset], ldwork); + } + + /* W := W * T' or W * T */ + + strmm_("Right", "Upper", transt, "Non-unit", &lastc, k, &c_b14, &t[t_offset], ldt, &work[work_offset], ldwork); + + /* C := C - V * W' */ + + if (lastv > *k) { + /* C2 := C2 - V2 * W' */ + + i__1 = lastv - *k; + sgemm_("No transpose", "Transpose", &i__1, &lastc, k, &c_b25, &v[*k + 1 + v_dim1], ldv, &work[work_offset], + ldwork, &c_b14, &c__[*k + 1 + c_dim1], ldc); + } + + /* W := W * V1' */ + + strmm_("Right", "Lower", "Transpose", "Unit", &lastc, k, &c_b14, &v[v_offset], ldv, &work[work_offset], ldwork); + + /* C1 := C1 - W' */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = lastc; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[j + i__ * c_dim1] -= work[i__ + j * work_dim1]; + /* L20: */ + } + /* L30: */ + } + + } else if (lsame_(side, "R")) { + /* Form C * H or C * H' where C = ( C1 C2 ) */ + + /* Computing MAX */ + i__1 = *k, i__2 = ilaslr_(n, k, &v[v_offset], ldv); + lastv = max(i__1, i__2); + lastc = ilaslr_(m, &lastv, &c__[c_offset], ldc); + + /* W := C * V = (C1*V1 + C2*V2) (stored in WORK) */ + + /* W := C1 */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + scopy_(&lastc, &c__[j * c_dim1 + 1], &c__1, &work[j * work_dim1 + 1], &c__1); + /* L40: */ + } + + /* W := W * V1 */ + + strmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &c_b14, &v[v_offset], ldv, &work[work_offset], + ldwork); + if (lastv > *k) { + /* W := W + C2 * V2 */ + + i__1 = lastv - *k; + sgemm_("No transpose", "No transpose", &lastc, k, &i__1, &c_b14, &c__[(*k + 1) * c_dim1 + 1], ldc, + &v[*k + 1 + v_dim1], ldv, &c_b14, &work[work_offset], ldwork); + } + + /* W := W * T or W * T' */ + + strmm_("Right", "Upper", trans, "Non-unit", &lastc, k, &c_b14, &t[t_offset], ldt, &work[work_offset], ldwork); + + /* C := C - W * V' */ + + if (lastv > *k) { + /* C2 := C2 - W * V2' */ + + i__1 = lastv - *k; + sgemm_("No transpose", "Transpose", &lastc, &i__1, k, &c_b25, &work[work_offset], ldwork, &v[*k + 1 + v_dim1], + ldv, &c_b14, &c__[(*k + 1) * c_dim1 + 1], ldc); + } + + /* W := W * V1' */ + + strmm_("Right", "Lower", "Transpose", "Unit", &lastc, k, &c_b14, &v[v_offset], ldv, &work[work_offset], ldwork); + + /* C1 := C1 - W */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = lastc; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1]; + /* L50: */ + } + /* L60: */ + } + } + } else { - *(unsigned char *)transt = 'N'; + /* Let V = ( V1 ) */ + /* ( V2 ) (last K rows) */ + /* where V2 is unit upper triangular. */ + + if (lsame_(side, "L")) { + /* Form H * C or H' * C where C = ( C1 ) */ + /* ( C2 ) */ + + /* Computing MAX */ + i__1 = *k, i__2 = ilaslr_(m, k, &v[v_offset], ldv); + lastv = max(i__1, i__2); + lastc = ilaslc_(&lastv, n, &c__[c_offset], ldc); + + /* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) */ + + /* W := C2' */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + scopy_(&lastc, &c__[lastv - *k + j + c_dim1], ldc, &work[j * work_dim1 + 1], &c__1); + /* L70: */ + } + + /* W := W * V2 */ + + strmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &c_b14, &v[lastv - *k + 1 + v_dim1], ldv, + &work[work_offset], ldwork); + if (lastv > *k) { + /* W := W + C1'*V1 */ + + i__1 = lastv - *k; + sgemm_("Transpose", "No transpose", &lastc, k, &i__1, &c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, + &work[work_offset], ldwork); + } + + /* W := W * T' or W * T */ + + strmm_("Right", "Lower", transt, "Non-unit", &lastc, k, &c_b14, &t[t_offset], ldt, &work[work_offset], ldwork); + + /* C := C - V * W' */ + + if (lastv > *k) { + /* C1 := C1 - V1 * W' */ + + i__1 = lastv - *k; + sgemm_("No transpose", "Transpose", &i__1, &lastc, k, &c_b25, &v[v_offset], ldv, &work[work_offset], ldwork, + &c_b14, &c__[c_offset], ldc); + } + + /* W := W * V2' */ + + strmm_("Right", "Upper", "Transpose", "Unit", &lastc, k, &c_b14, &v[lastv - *k + 1 + v_dim1], ldv, + &work[work_offset], ldwork); + + /* C2 := C2 - W' */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = lastc; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[lastv - *k + j + i__ * c_dim1] -= work[i__ + j * work_dim1]; + /* L80: */ + } + /* L90: */ + } + + } else if (lsame_(side, "R")) { + /* Form C * H or C * H' where C = ( C1 C2 ) */ + + /* Computing MAX */ + i__1 = *k, i__2 = ilaslr_(n, k, &v[v_offset], ldv); + lastv = max(i__1, i__2); + lastc = ilaslr_(m, &lastv, &c__[c_offset], ldc); + + /* W := C * V = (C1*V1 + C2*V2) (stored in WORK) */ + + /* W := C2 */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + scopy_(&lastc, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, &work[j * work_dim1 + 1], &c__1); + /* L100: */ + } + + /* W := W * V2 */ + + strmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &c_b14, &v[lastv - *k + 1 + v_dim1], ldv, + &work[work_offset], ldwork); + if (lastv > *k) { + /* W := W + C1 * V1 */ + + i__1 = lastv - *k; + sgemm_("No transpose", "No transpose", &lastc, k, &i__1, &c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, + &c_b14, &work[work_offset], ldwork); + } + + /* W := W * T or W * T' */ + + strmm_("Right", "Lower", trans, "Non-unit", &lastc, k, &c_b14, &t[t_offset], ldt, &work[work_offset], ldwork); + + /* C := C - W * V' */ + + if (lastv > *k) { + /* C1 := C1 - W * V1' */ + + i__1 = lastv - *k; + sgemm_("No transpose", "Transpose", &lastc, &i__1, k, &c_b25, &work[work_offset], ldwork, &v[v_offset], ldv, + &c_b14, &c__[c_offset], ldc); + } + + /* W := W * V2' */ + + strmm_("Right", "Upper", "Transpose", "Unit", &lastc, k, &c_b14, &v[lastv - *k + 1 + v_dim1], ldv, + &work[work_offset], ldwork); + + /* C2 := C2 - W */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = lastc; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + (lastv - *k + j) * c_dim1] -= work[i__ + j * work_dim1]; + /* L110: */ + } + /* L120: */ + } + } } - if (lsame_(storev, "C")) { + } else if (lsame_(storev, "R")) { + if (lsame_(direct, "F")) { + /* Let V = ( V1 V2 ) (V1: first K columns) */ + /* where V1 is unit upper triangular. */ - if (lsame_(direct, "F")) { + if (lsame_(side, "L")) { + /* Form H * C or H' * C where C = ( C1 ) */ + /* ( C2 ) */ -/* Let V = ( V1 ) (first K rows) */ -/* ( V2 ) */ -/* where V1 is unit lower triangular. */ + /* Computing MAX */ + i__1 = *k, i__2 = ilaslc_(k, m, &v[v_offset], ldv); + lastv = max(i__1, i__2); + lastc = ilaslc_(&lastv, n, &c__[c_offset], ldc); - if (lsame_(side, "L")) { + /* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) */ -/* Form H * C or H' * C where C = ( C1 ) */ -/* ( C2 ) */ + /* W := C1' */ -/* Computing MAX */ - i__1 = *k, i__2 = ilaslr_(m, k, &v[v_offset], ldv); - lastv = max(i__1,i__2); - lastc = ilaslc_(&lastv, n, &c__[c_offset], ldc); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + scopy_(&lastc, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1], &c__1); + /* L130: */ + } -/* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) */ + /* W := W * V1' */ -/* W := C1' */ + strmm_("Right", "Upper", "Transpose", "Unit", &lastc, k, &c_b14, &v[v_offset], ldv, &work[work_offset], ldwork); + if (lastv > *k) { + /* W := W + C2'*V2' */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - scopy_(&lastc, &c__[j + c_dim1], ldc, &work[j * work_dim1 - + 1], &c__1); -/* L10: */ - } + i__1 = lastv - *k; + sgemm_("Transpose", "Transpose", &lastc, k, &i__1, &c_b14, &c__[*k + 1 + c_dim1], ldc, + &v[(*k + 1) * v_dim1 + 1], ldv, &c_b14, &work[work_offset], ldwork); + } -/* W := W * V1 */ + /* W := W * T' or W * T */ - strmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, & - c_b14, &v[v_offset], ldv, &work[work_offset], ldwork); - if (lastv > *k) { + strmm_("Right", "Upper", transt, "Non-unit", &lastc, k, &c_b14, &t[t_offset], ldt, &work[work_offset], ldwork); -/* W := W + C2'*V2 */ + /* C := C - V' * W' */ - i__1 = lastv - *k; - sgemm_("Transpose", "No transpose", &lastc, k, &i__1, & - c_b14, &c__[*k + 1 + c_dim1], ldc, &v[*k + 1 + - v_dim1], ldv, &c_b14, &work[work_offset], ldwork); - } + if (lastv > *k) { + /* C2 := C2 - V2' * W' */ -/* W := W * T' or W * T */ + i__1 = lastv - *k; + sgemm_("Transpose", "Transpose", &i__1, &lastc, k, &c_b25, &v[(*k + 1) * v_dim1 + 1], ldv, &work[work_offset], + ldwork, &c_b14, &c__[*k + 1 + c_dim1], ldc); + } - strmm_("Right", "Upper", transt, "Non-unit", &lastc, k, & - c_b14, &t[t_offset], ldt, &work[work_offset], ldwork); + /* W := W * V1 */ -/* C := C - V * W' */ + strmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &c_b14, &v[v_offset], ldv, &work[work_offset], + ldwork); - if (lastv > *k) { + /* C1 := C1 - W' */ -/* C2 := C2 - V2 * W' */ + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = lastc; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[j + i__ * c_dim1] -= work[i__ + j * work_dim1]; + /* L140: */ + } + /* L150: */ + } - i__1 = lastv - *k; - sgemm_("No transpose", "Transpose", &i__1, &lastc, k, & - c_b25, &v[*k + 1 + v_dim1], ldv, &work[ - work_offset], ldwork, &c_b14, &c__[*k + 1 + - c_dim1], ldc); - } + } else if (lsame_(side, "R")) { + /* Form C * H or C * H' where C = ( C1 C2 ) */ -/* W := W * V1' */ + /* Computing MAX */ + i__1 = *k, i__2 = ilaslc_(k, n, &v[v_offset], ldv); + lastv = max(i__1, i__2); + lastc = ilaslr_(m, &lastv, &c__[c_offset], ldc); - strmm_("Right", "Lower", "Transpose", "Unit", &lastc, k, & - c_b14, &v[v_offset], ldv, &work[work_offset], ldwork); + /* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) */ -/* C1 := C1 - W' */ + /* W := C1 */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = lastc; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[j + i__ * c_dim1] -= work[i__ + j * work_dim1]; -/* L20: */ - } -/* L30: */ - } + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + scopy_(&lastc, &c__[j * c_dim1 + 1], &c__1, &work[j * work_dim1 + 1], &c__1); + /* L160: */ + } - } else if (lsame_(side, "R")) { + /* W := W * V1' */ -/* Form C * H or C * H' where C = ( C1 C2 ) */ + strmm_("Right", "Upper", "Transpose", "Unit", &lastc, k, &c_b14, &v[v_offset], ldv, &work[work_offset], ldwork); + if (lastv > *k) { + /* W := W + C2 * V2' */ -/* Computing MAX */ - i__1 = *k, i__2 = ilaslr_(n, k, &v[v_offset], ldv); - lastv = max(i__1,i__2); - lastc = ilaslr_(m, &lastv, &c__[c_offset], ldc); + i__1 = lastv - *k; + sgemm_("No transpose", "Transpose", &lastc, k, &i__1, &c_b14, &c__[(*k + 1) * c_dim1 + 1], ldc, + &v[(*k + 1) * v_dim1 + 1], ldv, &c_b14, &work[work_offset], ldwork); + } -/* W := C * V = (C1*V1 + C2*V2) (stored in WORK) */ + /* W := W * T or W * T' */ -/* W := C1 */ + strmm_("Right", "Upper", trans, "Non-unit", &lastc, k, &c_b14, &t[t_offset], ldt, &work[work_offset], ldwork); - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - scopy_(&lastc, &c__[j * c_dim1 + 1], &c__1, &work[j * - work_dim1 + 1], &c__1); -/* L40: */ - } + /* C := C - W * V */ -/* W := W * V1 */ + if (lastv > *k) { + /* C2 := C2 - W * V2 */ - strmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, & - c_b14, &v[v_offset], ldv, &work[work_offset], ldwork); - if (lastv > *k) { + i__1 = lastv - *k; + sgemm_("No transpose", "No transpose", &lastc, &i__1, k, &c_b25, &work[work_offset], ldwork, + &v[(*k + 1) * v_dim1 + 1], ldv, &c_b14, &c__[(*k + 1) * c_dim1 + 1], ldc); + } -/* W := W + C2 * V2 */ + /* W := W * V1 */ - i__1 = lastv - *k; - sgemm_("No transpose", "No transpose", &lastc, k, &i__1, & - c_b14, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[*k + - 1 + v_dim1], ldv, &c_b14, &work[work_offset], - ldwork); - } + strmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &c_b14, &v[v_offset], ldv, &work[work_offset], + ldwork); -/* W := W * T or W * T' */ + /* C1 := C1 - W */ - strmm_("Right", "Upper", trans, "Non-unit", &lastc, k, &c_b14, - &t[t_offset], ldt, &work[work_offset], ldwork); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = lastc; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1]; + /* L170: */ + } + /* L180: */ + } + } -/* C := C - W * V' */ + } else { + /* Let V = ( V1 V2 ) (V2: last K columns) */ + /* where V2 is unit lower triangular. */ - if (lastv > *k) { + if (lsame_(side, "L")) { + /* Form H * C or H' * C where C = ( C1 ) */ + /* ( C2 ) */ -/* C2 := C2 - W * V2' */ + /* Computing MAX */ + i__1 = *k, i__2 = ilaslc_(k, m, &v[v_offset], ldv); + lastv = max(i__1, i__2); + lastc = ilaslc_(&lastv, n, &c__[c_offset], ldc); - i__1 = lastv - *k; - sgemm_("No transpose", "Transpose", &lastc, &i__1, k, & - c_b25, &work[work_offset], ldwork, &v[*k + 1 + - v_dim1], ldv, &c_b14, &c__[(*k + 1) * c_dim1 + 1], - ldc); - } + /* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) */ -/* W := W * V1' */ + /* W := C2' */ - strmm_("Right", "Lower", "Transpose", "Unit", &lastc, k, & - c_b14, &v[v_offset], ldv, &work[work_offset], ldwork); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + scopy_(&lastc, &c__[lastv - *k + j + c_dim1], ldc, &work[j * work_dim1 + 1], &c__1); + /* L190: */ + } -/* C1 := C1 - W */ + /* W := W * V2' */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = lastc; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1]; -/* L50: */ - } -/* L60: */ - } - } + strmm_("Right", "Lower", "Transpose", "Unit", &lastc, k, &c_b14, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, + &work[work_offset], ldwork); + if (lastv > *k) { + /* W := W + C1'*V1' */ - } else { + i__1 = lastv - *k; + sgemm_("Transpose", "Transpose", &lastc, k, &i__1, &c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, + &work[work_offset], ldwork); + } -/* Let V = ( V1 ) */ -/* ( V2 ) (last K rows) */ -/* where V2 is unit upper triangular. */ + /* W := W * T' or W * T */ - if (lsame_(side, "L")) { + strmm_("Right", "Lower", transt, "Non-unit", &lastc, k, &c_b14, &t[t_offset], ldt, &work[work_offset], ldwork); -/* Form H * C or H' * C where C = ( C1 ) */ -/* ( C2 ) */ + /* C := C - V' * W' */ -/* Computing MAX */ - i__1 = *k, i__2 = ilaslr_(m, k, &v[v_offset], ldv); - lastv = max(i__1,i__2); - lastc = ilaslc_(&lastv, n, &c__[c_offset], ldc); + if (lastv > *k) { + /* C1 := C1 - V1' * W' */ -/* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) */ + i__1 = lastv - *k; + sgemm_("Transpose", "Transpose", &i__1, &lastc, k, &c_b25, &v[v_offset], ldv, &work[work_offset], ldwork, + &c_b14, &c__[c_offset], ldc); + } -/* W := C2' */ + /* W := W * V2 */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - scopy_(&lastc, &c__[lastv - *k + j + c_dim1], ldc, &work[ - j * work_dim1 + 1], &c__1); -/* L70: */ - } + strmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &c_b14, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, + &work[work_offset], ldwork); -/* W := W * V2 */ + /* C2 := C2 - W' */ - strmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, & - c_b14, &v[lastv - *k + 1 + v_dim1], ldv, &work[ - work_offset], ldwork); - if (lastv > *k) { + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = lastc; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[lastv - *k + j + i__ * c_dim1] -= work[i__ + j * work_dim1]; + /* L200: */ + } + /* L210: */ + } -/* W := W + C1'*V1 */ + } else if (lsame_(side, "R")) { + /* Form C * H or C * H' where C = ( C1 C2 ) */ - i__1 = lastv - *k; - sgemm_("Transpose", "No transpose", &lastc, k, &i__1, & - c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, & - c_b14, &work[work_offset], ldwork); - } + /* Computing MAX */ + i__1 = *k, i__2 = ilaslc_(k, n, &v[v_offset], ldv); + lastv = max(i__1, i__2); + lastc = ilaslr_(m, &lastv, &c__[c_offset], ldc); -/* W := W * T' or W * T */ + /* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) */ - strmm_("Right", "Lower", transt, "Non-unit", &lastc, k, & - c_b14, &t[t_offset], ldt, &work[work_offset], ldwork); + /* W := C2 */ -/* C := C - V * W' */ + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + scopy_(&lastc, &c__[(lastv - *k + j) * c_dim1 + 1], &c__1, &work[j * work_dim1 + 1], &c__1); + /* L220: */ + } - if (lastv > *k) { + /* W := W * V2' */ -/* C1 := C1 - V1 * W' */ + strmm_("Right", "Lower", "Transpose", "Unit", &lastc, k, &c_b14, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, + &work[work_offset], ldwork); + if (lastv > *k) { + /* W := W + C1 * V1' */ - i__1 = lastv - *k; - sgemm_("No transpose", "Transpose", &i__1, &lastc, k, & - c_b25, &v[v_offset], ldv, &work[work_offset], - ldwork, &c_b14, &c__[c_offset], ldc); - } + i__1 = lastv - *k; + sgemm_("No transpose", "Transpose", &lastc, k, &i__1, &c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, + &work[work_offset], ldwork); + } -/* W := W * V2' */ + /* W := W * T or W * T' */ - strmm_("Right", "Upper", "Transpose", "Unit", &lastc, k, & - c_b14, &v[lastv - *k + 1 + v_dim1], ldv, &work[ - work_offset], ldwork); + strmm_("Right", "Lower", trans, "Non-unit", &lastc, k, &c_b14, &t[t_offset], ldt, &work[work_offset], ldwork); -/* C2 := C2 - W' */ + /* C := C - W * V */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = lastc; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[lastv - *k + j + i__ * c_dim1] -= work[i__ + j * - work_dim1]; -/* L80: */ - } -/* L90: */ - } + if (lastv > *k) { + /* C1 := C1 - W * V1 */ - } else if (lsame_(side, "R")) { + i__1 = lastv - *k; + sgemm_("No transpose", "No transpose", &lastc, &i__1, k, &c_b25, &work[work_offset], ldwork, &v[v_offset], + ldv, &c_b14, &c__[c_offset], ldc); + } -/* Form C * H or C * H' where C = ( C1 C2 ) */ + /* W := W * V2 */ -/* Computing MAX */ - i__1 = *k, i__2 = ilaslr_(n, k, &v[v_offset], ldv); - lastv = max(i__1,i__2); - lastc = ilaslr_(m, &lastv, &c__[c_offset], ldc); + strmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &c_b14, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, + &work[work_offset], ldwork); -/* W := C * V = (C1*V1 + C2*V2) (stored in WORK) */ + /* C1 := C1 - W */ -/* W := C2 */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - scopy_(&lastc, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, & - work[j * work_dim1 + 1], &c__1); -/* L100: */ - } - -/* W := W * V2 */ - - strmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, & - c_b14, &v[lastv - *k + 1 + v_dim1], ldv, &work[ - work_offset], ldwork); - if (lastv > *k) { - -/* W := W + C1 * V1 */ - - i__1 = lastv - *k; - sgemm_("No transpose", "No transpose", &lastc, k, &i__1, & - c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, & - c_b14, &work[work_offset], ldwork); - } - -/* W := W * T or W * T' */ - - strmm_("Right", "Lower", trans, "Non-unit", &lastc, k, &c_b14, - &t[t_offset], ldt, &work[work_offset], ldwork); - -/* C := C - W * V' */ - - if (lastv > *k) { - -/* C1 := C1 - W * V1' */ - - i__1 = lastv - *k; - sgemm_("No transpose", "Transpose", &lastc, &i__1, k, & - c_b25, &work[work_offset], ldwork, &v[v_offset], - ldv, &c_b14, &c__[c_offset], ldc); - } - -/* W := W * V2' */ - - strmm_("Right", "Upper", "Transpose", "Unit", &lastc, k, & - c_b14, &v[lastv - *k + 1 + v_dim1], ldv, &work[ - work_offset], ldwork); - -/* C2 := C2 - W */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = lastc; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + (lastv - *k + j) * c_dim1] -= work[i__ + j * - work_dim1]; -/* L110: */ - } -/* L120: */ - } - } - } - - } else if (lsame_(storev, "R")) { - - if (lsame_(direct, "F")) { - -/* Let V = ( V1 V2 ) (V1: first K columns) */ -/* where V1 is unit upper triangular. */ - - if (lsame_(side, "L")) { - -/* Form H * C or H' * C where C = ( C1 ) */ -/* ( C2 ) */ - -/* Computing MAX */ - i__1 = *k, i__2 = ilaslc_(k, m, &v[v_offset], ldv); - lastv = max(i__1,i__2); - lastc = ilaslc_(&lastv, n, &c__[c_offset], ldc); - -/* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) */ - -/* W := C1' */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - scopy_(&lastc, &c__[j + c_dim1], ldc, &work[j * work_dim1 - + 1], &c__1); -/* L130: */ - } - -/* W := W * V1' */ - - strmm_("Right", "Upper", "Transpose", "Unit", &lastc, k, & - c_b14, &v[v_offset], ldv, &work[work_offset], ldwork); - if (lastv > *k) { - -/* W := W + C2'*V2' */ - - i__1 = lastv - *k; - sgemm_("Transpose", "Transpose", &lastc, k, &i__1, &c_b14, - &c__[*k + 1 + c_dim1], ldc, &v[(*k + 1) * v_dim1 - + 1], ldv, &c_b14, &work[work_offset], ldwork); - } - -/* W := W * T' or W * T */ - - strmm_("Right", "Upper", transt, "Non-unit", &lastc, k, & - c_b14, &t[t_offset], ldt, &work[work_offset], ldwork); - -/* C := C - V' * W' */ - - if (lastv > *k) { - -/* C2 := C2 - V2' * W' */ - - i__1 = lastv - *k; - sgemm_("Transpose", "Transpose", &i__1, &lastc, k, &c_b25, - &v[(*k + 1) * v_dim1 + 1], ldv, &work[ - work_offset], ldwork, &c_b14, &c__[*k + 1 + - c_dim1], ldc); - } - -/* W := W * V1 */ - - strmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, & - c_b14, &v[v_offset], ldv, &work[work_offset], ldwork); - -/* C1 := C1 - W' */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = lastc; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[j + i__ * c_dim1] -= work[i__ + j * work_dim1]; -/* L140: */ - } -/* L150: */ - } - - } else if (lsame_(side, "R")) { - -/* Form C * H or C * H' where C = ( C1 C2 ) */ - -/* Computing MAX */ - i__1 = *k, i__2 = ilaslc_(k, n, &v[v_offset], ldv); - lastv = max(i__1,i__2); - lastc = ilaslr_(m, &lastv, &c__[c_offset], ldc); - -/* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) */ - -/* W := C1 */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - scopy_(&lastc, &c__[j * c_dim1 + 1], &c__1, &work[j * - work_dim1 + 1], &c__1); -/* L160: */ - } - -/* W := W * V1' */ - - strmm_("Right", "Upper", "Transpose", "Unit", &lastc, k, & - c_b14, &v[v_offset], ldv, &work[work_offset], ldwork); - if (lastv > *k) { - -/* W := W + C2 * V2' */ - - i__1 = lastv - *k; - sgemm_("No transpose", "Transpose", &lastc, k, &i__1, & - c_b14, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[(*k + - 1) * v_dim1 + 1], ldv, &c_b14, &work[work_offset], - ldwork); - } - -/* W := W * T or W * T' */ - - strmm_("Right", "Upper", trans, "Non-unit", &lastc, k, &c_b14, - &t[t_offset], ldt, &work[work_offset], ldwork); - -/* C := C - W * V */ - - if (lastv > *k) { - -/* C2 := C2 - W * V2 */ - - i__1 = lastv - *k; - sgemm_("No transpose", "No transpose", &lastc, &i__1, k, & - c_b25, &work[work_offset], ldwork, &v[(*k + 1) * - v_dim1 + 1], ldv, &c_b14, &c__[(*k + 1) * c_dim1 - + 1], ldc); - } - -/* W := W * V1 */ - - strmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, & - c_b14, &v[v_offset], ldv, &work[work_offset], ldwork); - -/* C1 := C1 - W */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = lastc; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1]; -/* L170: */ - } -/* L180: */ - } - - } - - } else { - -/* Let V = ( V1 V2 ) (V2: last K columns) */ -/* where V2 is unit lower triangular. */ - - if (lsame_(side, "L")) { - -/* Form H * C or H' * C where C = ( C1 ) */ -/* ( C2 ) */ - -/* Computing MAX */ - i__1 = *k, i__2 = ilaslc_(k, m, &v[v_offset], ldv); - lastv = max(i__1,i__2); - lastc = ilaslc_(&lastv, n, &c__[c_offset], ldc); - -/* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) */ - -/* W := C2' */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - scopy_(&lastc, &c__[lastv - *k + j + c_dim1], ldc, &work[ - j * work_dim1 + 1], &c__1); -/* L190: */ - } - -/* W := W * V2' */ - - strmm_("Right", "Lower", "Transpose", "Unit", &lastc, k, & - c_b14, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[ - work_offset], ldwork); - if (lastv > *k) { - -/* W := W + C1'*V1' */ - - i__1 = lastv - *k; - sgemm_("Transpose", "Transpose", &lastc, k, &i__1, &c_b14, - &c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, & - work[work_offset], ldwork); - } - -/* W := W * T' or W * T */ - - strmm_("Right", "Lower", transt, "Non-unit", &lastc, k, & - c_b14, &t[t_offset], ldt, &work[work_offset], ldwork); - -/* C := C - V' * W' */ - - if (lastv > *k) { - -/* C1 := C1 - V1' * W' */ - - i__1 = lastv - *k; - sgemm_("Transpose", "Transpose", &i__1, &lastc, k, &c_b25, - &v[v_offset], ldv, &work[work_offset], ldwork, & - c_b14, &c__[c_offset], ldc); - } - -/* W := W * V2 */ - - strmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, & - c_b14, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[ - work_offset], ldwork); - -/* C2 := C2 - W' */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = lastc; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[lastv - *k + j + i__ * c_dim1] -= work[i__ + j * - work_dim1]; -/* L200: */ - } -/* L210: */ - } - - } else if (lsame_(side, "R")) { - -/* Form C * H or C * H' where C = ( C1 C2 ) */ - -/* Computing MAX */ - i__1 = *k, i__2 = ilaslc_(k, n, &v[v_offset], ldv); - lastv = max(i__1,i__2); - lastc = ilaslr_(m, &lastv, &c__[c_offset], ldc); - -/* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) */ - -/* W := C2 */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - scopy_(&lastc, &c__[(lastv - *k + j) * c_dim1 + 1], &c__1, - &work[j * work_dim1 + 1], &c__1); -/* L220: */ - } - -/* W := W * V2' */ - - strmm_("Right", "Lower", "Transpose", "Unit", &lastc, k, & - c_b14, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[ - work_offset], ldwork); - if (lastv > *k) { - -/* W := W + C1 * V1' */ - - i__1 = lastv - *k; - sgemm_("No transpose", "Transpose", &lastc, k, &i__1, & - c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, & - c_b14, &work[work_offset], ldwork); - } - -/* W := W * T or W * T' */ - - strmm_("Right", "Lower", trans, "Non-unit", &lastc, k, &c_b14, - &t[t_offset], ldt, &work[work_offset], ldwork); - -/* C := C - W * V */ - - if (lastv > *k) { - -/* C1 := C1 - W * V1 */ - - i__1 = lastv - *k; - sgemm_("No transpose", "No transpose", &lastc, &i__1, k, & - c_b25, &work[work_offset], ldwork, &v[v_offset], - ldv, &c_b14, &c__[c_offset], ldc); - } - -/* W := W * V2 */ - - strmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, & - c_b14, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[ - work_offset], ldwork); - -/* C1 := C1 - W */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = lastc; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + (lastv - *k + j) * c_dim1] -= work[i__ + j * - work_dim1]; -/* L230: */ - } -/* L240: */ - } - - } - - } + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = lastc; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + (lastv - *k + j) * c_dim1] -= work[i__ + j * work_dim1]; + /* L230: */ + } + /* L240: */ + } + } } + } - return 0; - -/* End of SLARFB */ + /* End of SLARFB */ } /* slarfb_ */
diff --git a/lapack/slarfg.c b/lapack/slarfg.c index 0d31251..beccdc3 100644 --- a/lapack/slarfg.c +++ b/lapack/slarfg.c
@@ -1,169 +1,164 @@ /* slarfg.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., + 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 + http://www.netlib.org/f2c/libf2c.zip */ -#include "f2c.h" #include "blaswrap.h" +#include "lapack_datatypes.h" -/* Subroutine */ int slarfg_(integer *n, real *alpha, real *x, integer *incx, - real *tau) -{ - /* System generated locals */ - integer i__1; - real r__1; +static inline real r_sign(real *a, real *b) { + real x; + x = (*a >= 0 ? *a : -*a); + return (*b >= 0 ? x : -x); +} - /* Builtin functions */ - double r_sign(real *, real *); +/* Subroutine */ void slarfg_(integer *n, real *alpha, real *x, integer *incx, real *tau) { + /* System generated locals */ + integer i__1; + real r__1; - /* Local variables */ - integer j, knt; - real beta; - extern doublereal snrm2_(integer *, real *, integer *); - extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); - real xnorm; - extern doublereal slapy2_(real *, real *), slamch_(char *); - real safmin, rsafmn; + /* Local variables */ + integer j, knt; + real beta; + extern real snrm2_(integer *, real *, integer *); + extern /* Subroutine */ void sscal_(integer *, real *, real *, integer *); + real xnorm; + extern doublereal slapy2_(real *, real *), slamch_(char *); + real safmin, rsafmn; + /* -- LAPACK auxiliary routine (version 3.2) -- */ + /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ + /* November 2006 */ -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ + /* .. Scalar Arguments .. */ + /* .. */ + /* .. Array Arguments .. */ + /* .. */ -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ + /* Purpose */ + /* ======= */ -/* Purpose */ -/* ======= */ + /* SLARFG generates a real elementary reflector H of order n, such */ + /* that */ -/* SLARFG generates a real elementary reflector H of order n, such */ -/* that */ + /* H * ( alpha ) = ( beta ), H' * H = I. */ + /* ( x ) ( 0 ) */ -/* H * ( alpha ) = ( beta ), H' * H = I. */ -/* ( x ) ( 0 ) */ + /* where alpha and beta are scalars, and x is an (n-1)-element real */ + /* vector. H is represented in the form */ -/* where alpha and beta are scalars, and x is an (n-1)-element real */ -/* vector. H is represented in the form */ + /* H = I - tau * ( 1 ) * ( 1 v' ) , */ + /* ( v ) */ -/* H = I - tau * ( 1 ) * ( 1 v' ) , */ -/* ( v ) */ + /* where tau is a real scalar and v is a real (n-1)-element */ + /* vector. */ -/* where tau is a real scalar and v is a real (n-1)-element */ -/* vector. */ + /* If the elements of x are all zero, then tau = 0 and H is taken to be */ + /* the unit matrix. */ -/* If the elements of x are all zero, then tau = 0 and H is taken to be */ -/* the unit matrix. */ + /* Otherwise 1 <= tau <= 2. */ -/* Otherwise 1 <= tau <= 2. */ + /* Arguments */ + /* ========= */ -/* Arguments */ -/* ========= */ + /* N (input) INTEGER */ + /* The order of the elementary reflector. */ -/* N (input) INTEGER */ -/* The order of the elementary reflector. */ + /* ALPHA (input/output) REAL */ + /* On entry, the value alpha. */ + /* On exit, it is overwritten with the value beta. */ -/* ALPHA (input/output) REAL */ -/* On entry, the value alpha. */ -/* On exit, it is overwritten with the value beta. */ + /* X (input/output) REAL array, dimension */ + /* (1+(N-2)*abs(INCX)) */ + /* On entry, the vector x. */ + /* On exit, it is overwritten with the vector v. */ -/* X (input/output) REAL array, dimension */ -/* (1+(N-2)*abs(INCX)) */ -/* On entry, the vector x. */ -/* On exit, it is overwritten with the vector v. */ + /* INCX (input) INTEGER */ + /* The increment between elements of X. INCX > 0. */ -/* INCX (input) INTEGER */ -/* The increment between elements of X. INCX > 0. */ + /* TAU (output) REAL */ + /* The value tau. */ -/* TAU (output) REAL */ -/* The value tau. */ + /* ===================================================================== */ -/* ===================================================================== */ + /* .. Parameters .. */ + /* .. */ + /* .. Local Scalars .. */ + /* .. */ + /* .. External Functions .. */ + /* .. */ + /* .. Intrinsic Functions .. */ + /* .. */ + /* .. External Subroutines .. */ + /* .. */ + /* .. Executable Statements .. */ -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Executable Statements .. */ + /* Parameter adjustments */ + --x; - /* Parameter adjustments */ - --x; + /* Function Body */ + if (*n <= 1) { + *tau = 0.f; + return; + } - /* Function Body */ - if (*n <= 1) { - *tau = 0.f; - return 0; + i__1 = *n - 1; + xnorm = snrm2_(&i__1, &x[1], incx); + + if (xnorm == 0.f) { + /* H = I */ + + *tau = 0.f; + } else { + /* general case */ + + r__1 = slapy2_(alpha, &xnorm); + beta = -r_sign(&r__1, alpha); + safmin = slamch_("S") / slamch_("E"); + knt = 0; + if (dabs(beta) < safmin) { + /* XNORM, BETA may be inaccurate; scale X and recompute them */ + + rsafmn = 1.f / safmin; + L10: + ++knt; + i__1 = *n - 1; + sscal_(&i__1, &rsafmn, &x[1], incx); + beta *= rsafmn; + *alpha *= rsafmn; + if (dabs(beta) < safmin) { + goto L10; + } + + /* New BETA is at most 1, at least SAFMIN */ + + i__1 = *n - 1; + xnorm = snrm2_(&i__1, &x[1], incx); + r__1 = slapy2_(alpha, &xnorm); + beta = -r_sign(&r__1, alpha); } - + *tau = (beta - *alpha) / beta; i__1 = *n - 1; - xnorm = snrm2_(&i__1, &x[1], incx); + r__1 = 1.f / (*alpha - beta); + sscal_(&i__1, &r__1, &x[1], incx); - if (xnorm == 0.f) { + /* If ALPHA is subnormal, it may lose relative accuracy */ -/* H = I */ - - *tau = 0.f; - } else { - -/* general case */ - - r__1 = slapy2_(alpha, &xnorm); - beta = -r_sign(&r__1, alpha); - safmin = slamch_("S") / slamch_("E"); - knt = 0; - if (dabs(beta) < safmin) { - -/* XNORM, BETA may be inaccurate; scale X and recompute them */ - - rsafmn = 1.f / safmin; -L10: - ++knt; - i__1 = *n - 1; - sscal_(&i__1, &rsafmn, &x[1], incx); - beta *= rsafmn; - *alpha *= rsafmn; - if (dabs(beta) < safmin) { - goto L10; - } - -/* New BETA is at most 1, at least SAFMIN */ - - i__1 = *n - 1; - xnorm = snrm2_(&i__1, &x[1], incx); - r__1 = slapy2_(alpha, &xnorm); - beta = -r_sign(&r__1, alpha); - } - *tau = (beta - *alpha) / beta; - i__1 = *n - 1; - r__1 = 1.f / (*alpha - beta); - sscal_(&i__1, &r__1, &x[1], incx); - -/* If ALPHA is subnormal, it may lose relative accuracy */ - - i__1 = knt; - for (j = 1; j <= i__1; ++j) { - beta *= safmin; -/* L20: */ - } - *alpha = beta; + i__1 = knt; + for (j = 1; j <= i__1; ++j) { + beta *= safmin; + /* L20: */ } + *alpha = beta; + } - return 0; - -/* End of SLARFG */ + /* End of SLARFG */ } /* slarfg_ */
diff --git a/lapack/slarft.c b/lapack/slarft.c index 4143ce4..97bfa41 100644 --- a/lapack/slarft.c +++ b/lapack/slarft.c
@@ -1,323 +1,309 @@ /* slarft.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., + 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 + http://www.netlib.org/f2c/libf2c.zip */ -#include "f2c.h" #include "blaswrap.h" +#include "lapack_datatypes.h" /* Table of constant values */ static integer c__1 = 1; static real c_b8 = 0.f; -/* Subroutine */ int slarft_(char *direct, char *storev, integer *n, integer * - k, real *v, integer *ldv, real *tau, real *t, integer *ldt) -{ - /* System generated locals */ - integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3; - real r__1; +/* Subroutine */ void slarft_(char *direct, char *storev, integer *n, integer *k, real *v, integer *ldv, real *tau, + real *t, integer *ldt) { + /* System generated locals */ + integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3; + real r__1; - /* Local variables */ - integer i__, j, prevlastv; - real vii; - extern logical lsame_(char *, char *); - extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *, - real *, integer *, real *, integer *, real *, real *, integer *); - integer lastv; - extern /* Subroutine */ int strmv_(char *, char *, char *, integer *, - real *, integer *, real *, integer *); + /* Local variables */ + integer i__, j, prevlastv; + real vii; + extern logical lsame_(char *, char *); + extern /* Subroutine */ void sgemv_(const char *, const integer *, const integer *, const real *, const real *, + const integer *, const real *, const integer *, const real *, real *, + const integer *); + integer lastv; + extern /* Subroutine */ void strmv_(const char *, const char *, const char *, const integer *, const real *, + const integer *, real *, const integer *); + /* -- LAPACK auxiliary routine (version 3.2) -- */ + /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ + /* November 2006 */ -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ + /* .. Scalar Arguments .. */ + /* .. */ + /* .. Array Arguments .. */ + /* .. */ -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ + /* Purpose */ + /* ======= */ -/* Purpose */ -/* ======= */ + /* SLARFT forms the triangular factor T of a real block reflector H */ + /* of order n, which is defined as a product of k elementary reflectors. */ -/* SLARFT forms the triangular factor T of a real block reflector H */ -/* of order n, which is defined as a product of k elementary reflectors. */ + /* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; */ -/* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; */ + /* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. */ -/* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. */ + /* If STOREV = 'C', the vector which defines the elementary reflector */ + /* H(i) is stored in the i-th column of the array V, and */ -/* If STOREV = 'C', the vector which defines the elementary reflector */ -/* H(i) is stored in the i-th column of the array V, and */ + /* H = I - V * T * V' */ -/* H = I - V * T * V' */ + /* If STOREV = 'R', the vector which defines the elementary reflector */ + /* H(i) is stored in the i-th row of the array V, and */ -/* If STOREV = 'R', the vector which defines the elementary reflector */ -/* H(i) is stored in the i-th row of the array V, and */ + /* H = I - V' * T * V */ -/* H = I - V' * T * V */ + /* Arguments */ + /* ========= */ -/* Arguments */ -/* ========= */ + /* DIRECT (input) CHARACTER*1 */ + /* Specifies the order in which the elementary reflectors are */ + /* multiplied to form the block reflector: */ + /* = 'F': H = H(1) H(2) . . . H(k) (Forward) */ + /* = 'B': H = H(k) . . . H(2) H(1) (Backward) */ -/* DIRECT (input) CHARACTER*1 */ -/* Specifies the order in which the elementary reflectors are */ -/* multiplied to form the block reflector: */ -/* = 'F': H = H(1) H(2) . . . H(k) (Forward) */ -/* = 'B': H = H(k) . . . H(2) H(1) (Backward) */ + /* STOREV (input) CHARACTER*1 */ + /* Specifies how the vectors which define the elementary */ + /* reflectors are stored (see also Further Details): */ + /* = 'C': columnwise */ + /* = 'R': rowwise */ -/* STOREV (input) CHARACTER*1 */ -/* Specifies how the vectors which define the elementary */ -/* reflectors are stored (see also Further Details): */ -/* = 'C': columnwise */ -/* = 'R': rowwise */ + /* N (input) INTEGER */ + /* The order of the block reflector H. N >= 0. */ -/* N (input) INTEGER */ -/* The order of the block reflector H. N >= 0. */ + /* K (input) INTEGER */ + /* The order of the triangular factor T (= the number of */ + /* elementary reflectors). K >= 1. */ -/* K (input) INTEGER */ -/* The order of the triangular factor T (= the number of */ -/* elementary reflectors). K >= 1. */ + /* V (input/output) REAL array, dimension */ + /* (LDV,K) if STOREV = 'C' */ + /* (LDV,N) if STOREV = 'R' */ + /* The matrix V. See further details. */ -/* V (input/output) REAL array, dimension */ -/* (LDV,K) if STOREV = 'C' */ -/* (LDV,N) if STOREV = 'R' */ -/* The matrix V. See further details. */ + /* LDV (input) INTEGER */ + /* The leading dimension of the array V. */ + /* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. */ -/* LDV (input) INTEGER */ -/* The leading dimension of the array V. */ -/* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. */ + /* TAU (input) REAL array, dimension (K) */ + /* TAU(i) must contain the scalar factor of the elementary */ + /* reflector H(i). */ -/* TAU (input) REAL array, dimension (K) */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i). */ + /* T (output) REAL array, dimension (LDT,K) */ + /* The k by k triangular factor T of the block reflector. */ + /* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is */ + /* lower triangular. The rest of the array is not used. */ -/* T (output) REAL array, dimension (LDT,K) */ -/* The k by k triangular factor T of the block reflector. */ -/* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is */ -/* lower triangular. The rest of the array is not used. */ + /* LDT (input) INTEGER */ + /* The leading dimension of the array T. LDT >= K. */ -/* LDT (input) INTEGER */ -/* The leading dimension of the array T. LDT >= K. */ + /* Further Details */ + /* =============== */ -/* Further Details */ -/* =============== */ + /* The shape of the matrix V and the storage of the vectors which define */ + /* the H(i) is best illustrated by the following example with n = 5 and */ + /* k = 3. The elements equal to 1 are not stored; the corresponding */ + /* array elements are modified but restored on exit. The rest of the */ + /* array is not used. */ -/* The shape of the matrix V and the storage of the vectors which define */ -/* the H(i) is best illustrated by the following example with n = 5 and */ -/* k = 3. The elements equal to 1 are not stored; the corresponding */ -/* array elements are modified but restored on exit. The rest of the */ -/* array is not used. */ + /* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': */ -/* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': */ + /* V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) */ + /* ( v1 1 ) ( 1 v2 v2 v2 ) */ + /* ( v1 v2 1 ) ( 1 v3 v3 ) */ + /* ( v1 v2 v3 ) */ + /* ( v1 v2 v3 ) */ -/* V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) */ -/* ( v1 1 ) ( 1 v2 v2 v2 ) */ -/* ( v1 v2 1 ) ( 1 v3 v3 ) */ -/* ( v1 v2 v3 ) */ -/* ( v1 v2 v3 ) */ + /* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': */ -/* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': */ + /* V = ( v1 v2 v3 ) V = ( v1 v1 1 ) */ + /* ( v1 v2 v3 ) ( v2 v2 v2 1 ) */ + /* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) */ + /* ( 1 v3 ) */ + /* ( 1 ) */ -/* V = ( v1 v2 v3 ) V = ( v1 v1 1 ) */ -/* ( v1 v2 v3 ) ( v2 v2 v2 1 ) */ -/* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) */ -/* ( 1 v3 ) */ -/* ( 1 ) */ + /* ===================================================================== */ -/* ===================================================================== */ + /* .. Parameters .. */ + /* .. */ + /* .. Local Scalars .. */ + /* .. */ + /* .. External Subroutines .. */ + /* .. */ + /* .. External Functions .. */ + /* .. */ + /* .. Executable Statements .. */ -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ + /* Quick return if possible */ -/* Quick return if possible */ + /* Parameter adjustments */ + v_dim1 = *ldv; + v_offset = 1 + v_dim1; + v -= v_offset; + --tau; + t_dim1 = *ldt; + t_offset = 1 + t_dim1; + t -= t_offset; - /* Parameter adjustments */ - v_dim1 = *ldv; - v_offset = 1 + v_dim1; - v -= v_offset; - --tau; - t_dim1 = *ldt; - t_offset = 1 + t_dim1; - t -= t_offset; + /* Function Body */ + if (*n == 0) { + return; + } - /* Function Body */ - if (*n == 0) { - return 0; + if (lsame_(direct, "F")) { + prevlastv = *n; + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + prevlastv = max(i__, prevlastv); + if (tau[i__] == 0.f) { + /* H(i) = I */ + + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + t[j + i__ * t_dim1] = 0.f; + /* L10: */ + } + } else { + /* general case */ + + vii = v[i__ + i__ * v_dim1]; + v[i__ + i__ * v_dim1] = 1.f; + if (lsame_(storev, "C")) { + /* Skip any trailing zeros. */ + i__2 = i__ + 1; + for (lastv = *n; lastv >= i__2; --lastv) { + if (v[lastv + i__ * v_dim1] != 0.f) { + break; + } + } + j = min(lastv, prevlastv); + + /* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)' * V(i:j,i) */ + + i__2 = j - i__ + 1; + i__3 = i__ - 1; + r__1 = -tau[i__]; + sgemv_("Transpose", &i__2, &i__3, &r__1, &v[i__ + v_dim1], ldv, &v[i__ + i__ * v_dim1], &c__1, &c_b8, + &t[i__ * t_dim1 + 1], &c__1); + } else { + /* Skip any trailing zeros. */ + i__2 = i__ + 1; + for (lastv = *n; lastv >= i__2; --lastv) { + if (v[i__ + lastv * v_dim1] != 0.f) { + break; + } + } + j = min(lastv, prevlastv); + + /* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)' */ + + i__2 = i__ - 1; + i__3 = j - i__ + 1; + r__1 = -tau[i__]; + sgemv_("No transpose", &i__2, &i__3, &r__1, &v[i__ * v_dim1 + 1], ldv, &v[i__ + i__ * v_dim1], ldv, &c_b8, + &t[i__ * t_dim1 + 1], &c__1); + } + v[i__ + i__ * v_dim1] = vii; + + /* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) */ + + i__2 = i__ - 1; + strmv_("Upper", "No transpose", "Non-unit", &i__2, &t[t_offset], ldt, &t[i__ * t_dim1 + 1], &c__1); + t[i__ + i__ * t_dim1] = tau[i__]; + if (i__ > 1) { + prevlastv = max(prevlastv, lastv); + } else { + prevlastv = lastv; + } + } + /* L20: */ } + } else { + prevlastv = 1; + for (i__ = *k; i__ >= 1; --i__) { + if (tau[i__] == 0.f) { + /* H(i) = I */ - if (lsame_(direct, "F")) { - prevlastv = *n; - i__1 = *k; - for (i__ = 1; i__ <= i__1; ++i__) { - prevlastv = max(i__,prevlastv); - if (tau[i__] == 0.f) { + i__1 = *k; + for (j = i__; j <= i__1; ++j) { + t[j + i__ * t_dim1] = 0.f; + /* L30: */ + } + } else { + /* general case */ -/* H(i) = I */ + if (i__ < *k) { + if (lsame_(storev, "C")) { + vii = v[*n - *k + i__ + i__ * v_dim1]; + v[*n - *k + i__ + i__ * v_dim1] = 1.f; + /* Skip any leading zeros. */ + i__1 = i__ - 1; + for (lastv = 1; lastv <= i__1; ++lastv) { + if (v[lastv + i__ * v_dim1] != 0.f) { + break; + } + } + j = max(lastv, prevlastv); - i__2 = i__; - for (j = 1; j <= i__2; ++j) { - t[j + i__ * t_dim1] = 0.f; -/* L10: */ - } - } else { + /* T(i+1:k,i) := */ + /* - tau(i) * V(j:n-k+i,i+1:k)' * V(j:n-k+i,i) */ -/* general case */ + i__1 = *n - *k + i__ - j + 1; + i__2 = *k - i__; + r__1 = -tau[i__]; + sgemv_("Transpose", &i__1, &i__2, &r__1, &v[j + (i__ + 1) * v_dim1], ldv, &v[j + i__ * v_dim1], &c__1, + &c_b8, &t[i__ + 1 + i__ * t_dim1], &c__1); + v[*n - *k + i__ + i__ * v_dim1] = vii; + } else { + vii = v[i__ + (*n - *k + i__) * v_dim1]; + v[i__ + (*n - *k + i__) * v_dim1] = 1.f; + /* Skip any leading zeros. */ + i__1 = i__ - 1; + for (lastv = 1; lastv <= i__1; ++lastv) { + if (v[i__ + lastv * v_dim1] != 0.f) { + break; + } + } + j = max(lastv, prevlastv); - vii = v[i__ + i__ * v_dim1]; - v[i__ + i__ * v_dim1] = 1.f; - if (lsame_(storev, "C")) { -/* Skip any trailing zeros. */ - i__2 = i__ + 1; - for (lastv = *n; lastv >= i__2; --lastv) { - if (v[lastv + i__ * v_dim1] != 0.f) { - break; - } - } - j = min(lastv,prevlastv); + /* T(i+1:k,i) := */ + /* - tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)' */ -/* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)' * V(i:j,i) */ + i__1 = *k - i__; + i__2 = *n - *k + i__ - j + 1; + r__1 = -tau[i__]; + sgemv_("No transpose", &i__1, &i__2, &r__1, &v[i__ + 1 + j * v_dim1], ldv, &v[i__ + j * v_dim1], ldv, &c_b8, + &t[i__ + 1 + i__ * t_dim1], &c__1); + v[i__ + (*n - *k + i__) * v_dim1] = vii; + } - i__2 = j - i__ + 1; - i__3 = i__ - 1; - r__1 = -tau[i__]; - sgemv_("Transpose", &i__2, &i__3, &r__1, &v[i__ + v_dim1], - ldv, &v[i__ + i__ * v_dim1], &c__1, &c_b8, &t[ - i__ * t_dim1 + 1], &c__1); - } else { -/* Skip any trailing zeros. */ - i__2 = i__ + 1; - for (lastv = *n; lastv >= i__2; --lastv) { - if (v[i__ + lastv * v_dim1] != 0.f) { - break; - } - } - j = min(lastv,prevlastv); + /* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) */ -/* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)' */ - - i__2 = i__ - 1; - i__3 = j - i__ + 1; - r__1 = -tau[i__]; - sgemv_("No transpose", &i__2, &i__3, &r__1, &v[i__ * - v_dim1 + 1], ldv, &v[i__ + i__ * v_dim1], ldv, & - c_b8, &t[i__ * t_dim1 + 1], &c__1); - } - v[i__ + i__ * v_dim1] = vii; - -/* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) */ - - i__2 = i__ - 1; - strmv_("Upper", "No transpose", "Non-unit", &i__2, &t[ - t_offset], ldt, &t[i__ * t_dim1 + 1], &c__1); - t[i__ + i__ * t_dim1] = tau[i__]; - if (i__ > 1) { - prevlastv = max(prevlastv,lastv); - } else { - prevlastv = lastv; - } - } -/* L20: */ - } - } else { - prevlastv = 1; - for (i__ = *k; i__ >= 1; --i__) { - if (tau[i__] == 0.f) { - -/* H(i) = I */ - - i__1 = *k; - for (j = i__; j <= i__1; ++j) { - t[j + i__ * t_dim1] = 0.f; -/* L30: */ - } - } else { - -/* general case */ - - if (i__ < *k) { - if (lsame_(storev, "C")) { - vii = v[*n - *k + i__ + i__ * v_dim1]; - v[*n - *k + i__ + i__ * v_dim1] = 1.f; -/* Skip any leading zeros. */ - i__1 = i__ - 1; - for (lastv = 1; lastv <= i__1; ++lastv) { - if (v[lastv + i__ * v_dim1] != 0.f) { - break; - } - } - j = max(lastv,prevlastv); - -/* T(i+1:k,i) := */ -/* - tau(i) * V(j:n-k+i,i+1:k)' * V(j:n-k+i,i) */ - - i__1 = *n - *k + i__ - j + 1; - i__2 = *k - i__; - r__1 = -tau[i__]; - sgemv_("Transpose", &i__1, &i__2, &r__1, &v[j + (i__ - + 1) * v_dim1], ldv, &v[j + i__ * v_dim1], & - c__1, &c_b8, &t[i__ + 1 + i__ * t_dim1], & - c__1); - v[*n - *k + i__ + i__ * v_dim1] = vii; - } else { - vii = v[i__ + (*n - *k + i__) * v_dim1]; - v[i__ + (*n - *k + i__) * v_dim1] = 1.f; -/* Skip any leading zeros. */ - i__1 = i__ - 1; - for (lastv = 1; lastv <= i__1; ++lastv) { - if (v[i__ + lastv * v_dim1] != 0.f) { - break; - } - } - j = max(lastv,prevlastv); - -/* T(i+1:k,i) := */ -/* - tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)' */ - - i__1 = *k - i__; - i__2 = *n - *k + i__ - j + 1; - r__1 = -tau[i__]; - sgemv_("No transpose", &i__1, &i__2, &r__1, &v[i__ + - 1 + j * v_dim1], ldv, &v[i__ + j * v_dim1], - ldv, &c_b8, &t[i__ + 1 + i__ * t_dim1], &c__1); - v[i__ + (*n - *k + i__) * v_dim1] = vii; - } - -/* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) */ - - i__1 = *k - i__; - strmv_("Lower", "No transpose", "Non-unit", &i__1, &t[i__ - + 1 + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ * - t_dim1], &c__1) - ; - if (i__ > 1) { - prevlastv = min(prevlastv,lastv); - } else { - prevlastv = lastv; - } - } - t[i__ + i__ * t_dim1] = tau[i__]; - } -/* L40: */ - } + i__1 = *k - i__; + strmv_("Lower", "No transpose", "Non-unit", &i__1, &t[i__ + 1 + (i__ + 1) * t_dim1], ldt, + &t[i__ + 1 + i__ * t_dim1], &c__1); + if (i__ > 1) { + prevlastv = min(prevlastv, lastv); + } else { + prevlastv = lastv; + } + } + t[i__ + i__ * t_dim1] = tau[i__]; + } + /* L40: */ } - return 0; + } -/* End of SLARFT */ + /* End of SLARFT */ } /* slarft_ */
diff --git a/lapack/zlacgv.c b/lapack/zlacgv.c index e455696..672fb3e 100644 --- a/lapack/zlacgv.c +++ b/lapack/zlacgv.c
@@ -1,95 +1,94 @@ /* zlacgv.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., + 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 + http://www.netlib.org/f2c/libf2c.zip */ -#include "f2c.h" #include "blaswrap.h" +#include "lapack_datatypes.h" -/* Subroutine */ int zlacgv_(integer *n, doublecomplex *x, integer *incx) -{ - /* System generated locals */ - integer i__1, i__2; - doublecomplex z__1; +static inline void d_cnjg(doublecomplex *r, doublecomplex *z) { + r->r = z->r; + r->i = -(z->i); +} - /* Builtin functions */ - void d_cnjg(doublecomplex *, doublecomplex *); +/* Subroutine */ void zlacgv_(integer *n, doublecomplex *x, integer *incx) { + /* System generated locals */ + integer i__1, i__2; + doublecomplex z__1; - /* Local variables */ - integer i__, ioff; + /* Local variables */ + integer i__, ioff; + /* -- LAPACK auxiliary routine (version 3.2) -- */ + /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ + /* November 2006 */ -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ + /* .. Scalar Arguments .. */ + /* .. */ + /* .. Array Arguments .. */ + /* .. */ -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ + /* Purpose */ + /* ======= */ -/* Purpose */ -/* ======= */ + /* ZLACGV conjugates a complex vector of length N. */ -/* ZLACGV conjugates a complex vector of length N. */ + /* Arguments */ + /* ========= */ -/* Arguments */ -/* ========= */ + /* N (input) INTEGER */ + /* The length of the vector X. N >= 0. */ -/* N (input) INTEGER */ -/* The length of the vector X. N >= 0. */ + /* X (input/output) COMPLEX*16 array, dimension */ + /* (1+(N-1)*abs(INCX)) */ + /* On entry, the vector of length N to be conjugated. */ + /* On exit, X is overwritten with conjg(X). */ -/* X (input/output) COMPLEX*16 array, dimension */ -/* (1+(N-1)*abs(INCX)) */ -/* On entry, the vector of length N to be conjugated. */ -/* On exit, X is overwritten with conjg(X). */ + /* INCX (input) INTEGER */ + /* The spacing between successive elements of X. */ -/* INCX (input) INTEGER */ -/* The spacing between successive elements of X. */ + /* ===================================================================== */ -/* ===================================================================== */ + /* .. Local Scalars .. */ + /* .. */ + /* .. Intrinsic Functions .. */ + /* .. */ + /* .. Executable Statements .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ + /* Parameter adjustments */ + --x; - /* Parameter adjustments */ - --x; - - /* Function Body */ - if (*incx == 1) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = i__; - d_cnjg(&z__1, &x[i__]); - x[i__2].r = z__1.r, x[i__2].i = z__1.i; -/* L10: */ - } - } else { - ioff = 1; - if (*incx < 0) { - ioff = 1 - (*n - 1) * *incx; - } - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = ioff; - d_cnjg(&z__1, &x[ioff]); - x[i__2].r = z__1.r, x[i__2].i = z__1.i; - ioff += *incx; -/* L20: */ - } + /* Function Body */ + if (*incx == 1) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + d_cnjg(&z__1, &x[i__]); + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + /* L10: */ } - return 0; + } else { + ioff = 1; + if (*incx < 0) { + ioff = 1 - (*n - 1) * *incx; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = ioff; + d_cnjg(&z__1, &x[ioff]); + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + ioff += *incx; + /* L20: */ + } + } -/* End of ZLACGV */ + /* End of ZLACGV */ } /* zlacgv_ */
diff --git a/lapack/zladiv.c b/lapack/zladiv.c index d92be5a..37aa923 100644 --- a/lapack/zladiv.c +++ b/lapack/zladiv.c
@@ -1,75 +1,67 @@ /* zladiv.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., + 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 + http://www.netlib.org/f2c/libf2c.zip */ -#include "f2c.h" #include "blaswrap.h" +#include "lapack_datatypes.h" -/* Double Complex */ VOID zladiv_(doublecomplex * ret_val, doublecomplex *x, - doublecomplex *y) -{ - /* System generated locals */ - doublereal d__1, d__2, d__3, d__4; - doublecomplex z__1; +/* Double Complex */ void zladiv_(doublecomplex *ret_val, doublecomplex *x, doublecomplex *y) { + /* System generated locals */ + doublereal d__1, d__2, d__3, d__4; + doublecomplex z__1; - /* Builtin functions */ - double d_imag(doublecomplex *); + /* Local variables */ + doublereal zi, zr; + extern /* Subroutine */ void dladiv_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *); - /* Local variables */ - doublereal zi, zr; - extern /* Subroutine */ int dladiv_(doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *); + /* -- LAPACK auxiliary routine (version 3.2) -- */ + /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ + /* November 2006 */ + /* .. Scalar Arguments .. */ + /* .. */ -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ + /* Purpose */ + /* ======= */ -/* .. Scalar Arguments .. */ -/* .. */ + /* ZLADIV := X / Y, where X and Y are complex. The computation of X / Y */ + /* will not overflow on an intermediary step unless the results */ + /* overflows. */ -/* Purpose */ -/* ======= */ + /* Arguments */ + /* ========= */ -/* ZLADIV := X / Y, where X and Y are complex. The computation of X / Y */ -/* will not overflow on an intermediary step unless the results */ -/* overflows. */ + /* X (input) COMPLEX*16 */ + /* Y (input) COMPLEX*16 */ + /* The complex scalars X and Y. */ -/* Arguments */ -/* ========= */ + /* ===================================================================== */ -/* X (input) COMPLEX*16 */ -/* Y (input) COMPLEX*16 */ -/* The complex scalars X and Y. */ + /* .. Local Scalars .. */ + /* .. */ + /* .. External Subroutines .. */ + /* .. */ + /* .. Intrinsic Functions .. */ + /* .. */ + /* .. Executable Statements .. */ -/* ===================================================================== */ + d__1 = x->r; + d__2 = x->i; + d__3 = y->r; + d__4 = y->i; + dladiv_(&d__1, &d__2, &d__3, &d__4, &zr, &zi); + z__1.r = zr, z__1.i = zi; + ret_val->r = z__1.r, ret_val->i = z__1.i; -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - d__1 = x->r; - d__2 = d_imag(x); - d__3 = y->r; - d__4 = d_imag(y); - dladiv_(&d__1, &d__2, &d__3, &d__4, &zr, &zi); - z__1.r = zr, z__1.i = zi; - ret_val->r = z__1.r, ret_val->i = z__1.i; - - return ; - -/* End of ZLADIV */ + /* End of ZLADIV */ } /* zladiv_ */
diff --git a/lapack/zlarf.c b/lapack/zlarf.c index 0b8ad02..032cb31 100644 --- a/lapack/zlarf.c +++ b/lapack/zlarf.c
@@ -1,200 +1,187 @@ /* 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., + 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 + http://www.netlib.org/f2c/libf2c.zip */ -#include "f2c.h" #include "blaswrap.h" +#include "lapack_datatypes.h" /* Table of constant values */ -static doublecomplex c_b1 = {1.,0.}; -static doublecomplex c_b2 = {0.,0.}; +static doublecomplex c_b1 = {1., 0.}; +static doublecomplex c_b2 = {0., 0.}; static integer c__1 = 1; -/* Subroutine */ int 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; +/* 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 */ int zgerc_(integer *, integer *, doublecomplex *, - doublecomplex *, integer *, doublecomplex *, integer *, - doublecomplex *, integer *), zgemv_(char *, integer *, integer *, - doublecomplex *, doublecomplex *, integer *, doublecomplex *, - integer *, doublecomplex *, doublecomplex *, integer *); - integer lastv; - extern integer ilazlc_(integer *, integer *, doublecomplex *, integer *), - ilazlr_(integer *, integer *, doublecomplex *, integer *); + /* 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 */ -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ + /* .. Scalar Arguments .. */ + /* .. */ + /* .. Array Arguments .. */ + /* .. */ -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ + /* Purpose */ + /* ======= */ -/* 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 */ -/* 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' */ -/* H = I - tau * v * v' */ + /* where tau is a complex scalar and v is a complex vector. */ -/* where tau is a complex scalar and v is a complex vector. */ + /* If tau = 0, then H is taken to be the unit matrix. */ -/* 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. */ -/* To apply H' (the conjugate transpose of H), supply conjg(tau) instead */ -/* tau. */ + /* Arguments */ + /* ========= */ -/* Arguments */ -/* ========= */ + /* SIDE (input) CHARACTER*1 */ + /* = 'L': form H * C */ + /* = 'R': form C * H */ -/* SIDE (input) CHARACTER*1 */ -/* = 'L': form H * C */ -/* = 'R': form C * H */ + /* M (input) INTEGER */ + /* The number of rows of the matrix C. */ -/* M (input) INTEGER */ -/* The number of rows of the matrix C. */ + /* N (input) INTEGER */ + /* The number of columns 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. */ -/* 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. */ -/* INCV (input) INTEGER */ -/* The increment between elements of v. INCV <> 0. */ + /* TAU (input) COMPLEX*16 */ + /* The value tau in the representation of H. */ -/* 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'. */ -/* 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). */ -/* 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' */ -/* WORK (workspace) COMPLEX*16 array, dimension */ -/* (N) if SIDE = 'L' */ -/* or (M) if SIDE = 'R' */ + /* ===================================================================== */ -/* ===================================================================== */ + /* .. Parameters .. */ + /* .. */ + /* .. Local Scalars .. */ + /* .. */ + /* .. External Subroutines .. */ + /* .. */ + /* .. External Functions .. */ + /* .. */ + /* .. Executable Statements .. */ -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ + /* Parameter adjustments */ + --v; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + --work; - /* 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. */ + /* 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) { - -/* 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); - } + lastv = *m; } 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); - } + lastv = *n; } - return 0; + 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 */ -/* End of ZLARF */ + 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_ */
diff --git a/lapack/zlarfb.c b/lapack/zlarfb.c index cdd584e..d98370c 100644 --- a/lapack/zlarfb.c +++ b/lapack/zlarfb.c
@@ -1,839 +1,737 @@ /* zlarfb.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., + 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 + http://www.netlib.org/f2c/libf2c.zip */ -#include "f2c.h" #include "blaswrap.h" +#include "lapack_datatypes.h" + +static inline void d_cnjg(doublecomplex *r, doublecomplex *z) { + r->r = z->r; + r->i = -(z->i); +} /* Table of constant values */ -static doublecomplex c_b1 = {1.,0.}; +static doublecomplex c_b1 = {1., 0.}; static integer c__1 = 1; -/* Subroutine */ int zlarfb_(char *side, char *trans, char *direct, char * - storev, integer *m, integer *n, integer *k, doublecomplex *v, integer - *ldv, doublecomplex *t, integer *ldt, doublecomplex *c__, integer * - ldc, doublecomplex *work, integer *ldwork) -{ - /* System generated locals */ - integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1, - work_offset, i__1, i__2, i__3, i__4, i__5; - doublecomplex z__1, z__2; +/* Subroutine */ void zlarfb_(char *side, char *trans, char *direct, char *storev, integer *m, integer *n, integer *k, + doublecomplex *v, integer *ldv, doublecomplex *t, integer *ldt, doublecomplex *c__, + integer *ldc, doublecomplex *work, integer *ldwork) { + /* System generated locals */ + integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1, work_offset, i__1, i__2, i__3, i__4, i__5; + doublecomplex z__1, z__2; - /* Builtin functions */ - void d_cnjg(doublecomplex *, doublecomplex *); + /* Local variables */ + integer i__, j; + extern logical lsame_(char *, char *); + integer lastc; + extern /* Subroutine */ void zgemm_(const char *, const char *, const integer *, const integer *, const integer *, + const doublecomplex *, const doublecomplex *, const integer *, + const doublecomplex *, const integer *, const doublecomplex *, doublecomplex *, + const integer *); + integer lastv; + extern /* Subroutine */ void zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, integer *), + ztrmm_(const char *, const char *, const char *, const char *, const integer *, const integer *, + const doublecomplex *, const doublecomplex *, const integer *, doublecomplex *, const integer *); + extern integer ilazlc_(integer *, integer *, doublecomplex *, integer *); + extern /* Subroutine */ void zlacgv_(integer *, doublecomplex *, integer *); + extern integer ilazlr_(integer *, integer *, doublecomplex *, integer *); + char transt[1]; - /* Local variables */ - integer i__, j; - extern logical lsame_(char *, char *); - integer lastc; - extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, - integer *, doublecomplex *, doublecomplex *, integer *, - doublecomplex *, integer *, doublecomplex *, doublecomplex *, - integer *); - integer lastv; - extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, - doublecomplex *, integer *), ztrmm_(char *, char *, char *, char * -, integer *, integer *, doublecomplex *, doublecomplex *, integer - *, doublecomplex *, integer *); - extern integer ilazlc_(integer *, integer *, doublecomplex *, integer *); - extern /* Subroutine */ int zlacgv_(integer *, doublecomplex *, integer *) - ; - extern integer ilazlr_(integer *, integer *, doublecomplex *, integer *); - char transt[1]; + /* -- LAPACK auxiliary routine (version 3.2) -- */ + /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ + /* November 2006 */ + /* .. Scalar Arguments .. */ + /* .. */ + /* .. Array Arguments .. */ + /* .. */ -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ + /* Purpose */ + /* ======= */ -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ + /* ZLARFB applies a complex block reflector H or its transpose H' to a */ + /* complex M-by-N matrix C, from either the left or the right. */ -/* Purpose */ -/* ======= */ + /* Arguments */ + /* ========= */ -/* ZLARFB applies a complex block reflector H or its transpose H' to a */ -/* complex M-by-N matrix C, from either the left or the right. */ + /* SIDE (input) CHARACTER*1 */ + /* = 'L': apply H or H' from the Left */ + /* = 'R': apply H or H' from the Right */ -/* Arguments */ -/* ========= */ + /* TRANS (input) CHARACTER*1 */ + /* = 'N': apply H (No transpose) */ + /* = 'C': apply H' (Conjugate transpose) */ -/* SIDE (input) CHARACTER*1 */ -/* = 'L': apply H or H' from the Left */ -/* = 'R': apply H or H' from the Right */ + /* DIRECT (input) CHARACTER*1 */ + /* Indicates how H is formed from a product of elementary */ + /* reflectors */ + /* = 'F': H = H(1) H(2) . . . H(k) (Forward) */ + /* = 'B': H = H(k) . . . H(2) H(1) (Backward) */ -/* TRANS (input) CHARACTER*1 */ -/* = 'N': apply H (No transpose) */ -/* = 'C': apply H' (Conjugate transpose) */ + /* STOREV (input) CHARACTER*1 */ + /* Indicates how the vectors which define the elementary */ + /* reflectors are stored: */ + /* = 'C': Columnwise */ + /* = 'R': Rowwise */ -/* DIRECT (input) CHARACTER*1 */ -/* Indicates how H is formed from a product of elementary */ -/* reflectors */ -/* = 'F': H = H(1) H(2) . . . H(k) (Forward) */ -/* = 'B': H = H(k) . . . H(2) H(1) (Backward) */ + /* M (input) INTEGER */ + /* The number of rows of the matrix C. */ -/* STOREV (input) CHARACTER*1 */ -/* Indicates how the vectors which define the elementary */ -/* reflectors are stored: */ -/* = 'C': Columnwise */ -/* = 'R': Rowwise */ + /* N (input) INTEGER */ + /* The number of columns of the matrix C. */ -/* M (input) INTEGER */ -/* The number of rows of the matrix C. */ + /* K (input) INTEGER */ + /* The order of the matrix T (= the number of elementary */ + /* reflectors whose product defines the block reflector). */ -/* N (input) INTEGER */ -/* The number of columns of the matrix C. */ + /* V (input) COMPLEX*16 array, dimension */ + /* (LDV,K) if STOREV = 'C' */ + /* (LDV,M) if STOREV = 'R' and SIDE = 'L' */ + /* (LDV,N) if STOREV = 'R' and SIDE = 'R' */ + /* The matrix V. See further details. */ -/* K (input) INTEGER */ -/* The order of the matrix T (= the number of elementary */ -/* reflectors whose product defines the block reflector). */ + /* LDV (input) INTEGER */ + /* The leading dimension of the array V. */ + /* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); */ + /* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); */ + /* if STOREV = 'R', LDV >= K. */ -/* V (input) COMPLEX*16 array, dimension */ -/* (LDV,K) if STOREV = 'C' */ -/* (LDV,M) if STOREV = 'R' and SIDE = 'L' */ -/* (LDV,N) if STOREV = 'R' and SIDE = 'R' */ -/* The matrix V. See further details. */ + /* T (input) COMPLEX*16 array, dimension (LDT,K) */ + /* The triangular K-by-K matrix T in the representation of the */ + /* block reflector. */ -/* LDV (input) INTEGER */ -/* The leading dimension of the array V. */ -/* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); */ -/* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); */ -/* if STOREV = 'R', LDV >= K. */ + /* LDT (input) INTEGER */ + /* The leading dimension of the array T. LDT >= K. */ -/* T (input) COMPLEX*16 array, dimension (LDT,K) */ -/* The triangular K-by-K matrix T in the representation of the */ -/* block reflector. */ + /* C (input/output) COMPLEX*16 array, dimension (LDC,N) */ + /* On entry, the M-by-N matrix C. */ + /* On exit, C is overwritten by H*C or H'*C or C*H or C*H'. */ -/* LDT (input) INTEGER */ -/* The leading dimension of the array T. LDT >= K. */ + /* LDC (input) INTEGER */ + /* The leading dimension of the array C. LDC >= max(1,M). */ -/* C (input/output) COMPLEX*16 array, dimension (LDC,N) */ -/* On entry, the M-by-N matrix C. */ -/* On exit, C is overwritten by H*C or H'*C or C*H or C*H'. */ + /* WORK (workspace) COMPLEX*16 array, dimension (LDWORK,K) */ -/* LDC (input) INTEGER */ -/* The leading dimension of the array C. LDC >= max(1,M). */ + /* LDWORK (input) INTEGER */ + /* The leading dimension of the array WORK. */ + /* If SIDE = 'L', LDWORK >= max(1,N); */ + /* if SIDE = 'R', LDWORK >= max(1,M). */ -/* WORK (workspace) COMPLEX*16 array, dimension (LDWORK,K) */ + /* ===================================================================== */ -/* LDWORK (input) INTEGER */ -/* The leading dimension of the array WORK. */ -/* If SIDE = 'L', LDWORK >= max(1,N); */ -/* if SIDE = 'R', LDWORK >= max(1,M). */ + /* .. Parameters .. */ + /* .. */ + /* .. Local Scalars .. */ + /* .. */ + /* .. External Functions .. */ + /* .. */ + /* .. External Subroutines .. */ + /* .. */ + /* .. Intrinsic Functions .. */ + /* .. */ + /* .. Executable Statements .. */ -/* ===================================================================== */ + /* Quick return if possible */ -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ + /* Parameter adjustments */ + v_dim1 = *ldv; + v_offset = 1 + v_dim1; + v -= v_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1; + t -= t_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + work_dim1 = *ldwork; + work_offset = 1 + work_dim1; + work -= work_offset; -/* Quick return if possible */ + /* Function Body */ + if (*m <= 0 || *n <= 0) { + return; + } - /* Parameter adjustments */ - v_dim1 = *ldv; - v_offset = 1 + v_dim1; - v -= v_offset; - t_dim1 = *ldt; - t_offset = 1 + t_dim1; - t -= t_offset; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - work_dim1 = *ldwork; - work_offset = 1 + work_dim1; - work -= work_offset; + if (lsame_(trans, "N")) { + *(unsigned char *)transt = 'C'; + } else { + *(unsigned char *)transt = 'N'; + } - /* Function Body */ - if (*m <= 0 || *n <= 0) { - return 0; - } + if (lsame_(storev, "C")) { + if (lsame_(direct, "F")) { + /* Let V = ( V1 ) (first K rows) */ + /* ( V2 ) */ + /* where V1 is unit lower triangular. */ - if (lsame_(trans, "N")) { - *(unsigned char *)transt = 'C'; + if (lsame_(side, "L")) { + /* Form H * C or H' * C where C = ( C1 ) */ + /* ( C2 ) */ + + /* Computing MAX */ + i__1 = *k, i__2 = ilazlr_(m, k, &v[v_offset], ldv); + lastv = max(i__1, i__2); + lastc = ilazlc_(&lastv, n, &c__[c_offset], ldc); + + /* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) */ + + /* W := C1' */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + zcopy_(&lastc, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1], &c__1); + zlacgv_(&lastc, &work[j * work_dim1 + 1], &c__1); + /* L10: */ + } + + /* W := W * V1 */ + + ztrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &c_b1, &v[v_offset], ldv, &work[work_offset], + ldwork); + if (lastv > *k) { + /* W := W + C2'*V2 */ + + i__1 = lastv - *k; + zgemm_("Conjugate transpose", "No transpose", &lastc, k, &i__1, &c_b1, &c__[*k + 1 + c_dim1], ldc, + &v[*k + 1 + v_dim1], ldv, &c_b1, &work[work_offset], ldwork); + } + + /* W := W * T' or W * T */ + + ztrmm_("Right", "Upper", transt, "Non-unit", &lastc, k, &c_b1, &t[t_offset], ldt, &work[work_offset], ldwork); + + /* C := C - V * W' */ + + if (*m > *k) { + /* C2 := C2 - V2 * W' */ + + i__1 = lastv - *k; + z__1.r = -1., z__1.i = -0.; + zgemm_("No transpose", "Conjugate transpose", &i__1, &lastc, k, &z__1, &v[*k + 1 + v_dim1], ldv, + &work[work_offset], ldwork, &c_b1, &c__[*k + 1 + c_dim1], ldc); + } + + /* W := W * V1' */ + + ztrmm_("Right", "Lower", "Conjugate transpose", "Unit", &lastc, k, &c_b1, &v[v_offset], ldv, &work[work_offset], + ldwork); + + /* C1 := C1 - W' */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = lastc; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = j + i__ * c_dim1; + i__4 = j + i__ * c_dim1; + d_cnjg(&z__2, &work[i__ + j * work_dim1]); + z__1.r = c__[i__4].r - z__2.r, z__1.i = c__[i__4].i - z__2.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + /* L20: */ + } + /* L30: */ + } + + } else if (lsame_(side, "R")) { + /* Form C * H or C * H' where C = ( C1 C2 ) */ + + /* Computing MAX */ + i__1 = *k, i__2 = ilazlr_(n, k, &v[v_offset], ldv); + lastv = max(i__1, i__2); + lastc = ilazlr_(m, &lastv, &c__[c_offset], ldc); + + /* W := C * V = (C1*V1 + C2*V2) (stored in WORK) */ + + /* W := C1 */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + zcopy_(&lastc, &c__[j * c_dim1 + 1], &c__1, &work[j * work_dim1 + 1], &c__1); + /* L40: */ + } + + /* W := W * V1 */ + + ztrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &c_b1, &v[v_offset], ldv, &work[work_offset], + ldwork); + if (lastv > *k) { + /* W := W + C2 * V2 */ + + i__1 = lastv - *k; + zgemm_("No transpose", "No transpose", &lastc, k, &i__1, &c_b1, &c__[(*k + 1) * c_dim1 + 1], ldc, + &v[*k + 1 + v_dim1], ldv, &c_b1, &work[work_offset], ldwork); + } + + /* W := W * T or W * T' */ + + ztrmm_("Right", "Upper", trans, "Non-unit", &lastc, k, &c_b1, &t[t_offset], ldt, &work[work_offset], ldwork); + + /* C := C - W * V' */ + + if (lastv > *k) { + /* C2 := C2 - W * V2' */ + + i__1 = lastv - *k; + z__1.r = -1., z__1.i = -0.; + zgemm_("No transpose", "Conjugate transpose", &lastc, &i__1, k, &z__1, &work[work_offset], ldwork, + &v[*k + 1 + v_dim1], ldv, &c_b1, &c__[(*k + 1) * c_dim1 + 1], ldc); + } + + /* W := W * V1' */ + + ztrmm_("Right", "Lower", "Conjugate transpose", "Unit", &lastc, k, &c_b1, &v[v_offset], ldv, &work[work_offset], + ldwork); + + /* C1 := C1 - W */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = lastc; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * work_dim1; + z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[i__4].i - work[i__5].i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + /* L50: */ + } + /* L60: */ + } + } + } else { - *(unsigned char *)transt = 'N'; + /* Let V = ( V1 ) */ + /* ( V2 ) (last K rows) */ + /* where V2 is unit upper triangular. */ + + if (lsame_(side, "L")) { + /* Form H * C or H' * C where C = ( C1 ) */ + /* ( C2 ) */ + + /* Computing MAX */ + i__1 = *k, i__2 = ilazlr_(m, k, &v[v_offset], ldv); + lastv = max(i__1, i__2); + lastc = ilazlc_(&lastv, n, &c__[c_offset], ldc); + + /* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) */ + + /* W := C2' */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + zcopy_(&lastc, &c__[lastv - *k + j + c_dim1], ldc, &work[j * work_dim1 + 1], &c__1); + zlacgv_(&lastc, &work[j * work_dim1 + 1], &c__1); + /* L70: */ + } + + /* W := W * V2 */ + + ztrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &c_b1, &v[lastv - *k + 1 + v_dim1], ldv, + &work[work_offset], ldwork); + if (lastv > *k) { + /* W := W + C1'*V1 */ + + i__1 = lastv - *k; + zgemm_("Conjugate transpose", "No transpose", &lastc, k, &i__1, &c_b1, &c__[c_offset], ldc, &v[v_offset], ldv, + &c_b1, &work[work_offset], ldwork); + } + + /* W := W * T' or W * T */ + + ztrmm_("Right", "Lower", transt, "Non-unit", &lastc, k, &c_b1, &t[t_offset], ldt, &work[work_offset], ldwork); + + /* C := C - V * W' */ + + if (lastv > *k) { + /* C1 := C1 - V1 * W' */ + + i__1 = lastv - *k; + z__1.r = -1., z__1.i = -0.; + zgemm_("No transpose", "Conjugate transpose", &i__1, &lastc, k, &z__1, &v[v_offset], ldv, &work[work_offset], + ldwork, &c_b1, &c__[c_offset], ldc); + } + + /* W := W * V2' */ + + ztrmm_("Right", "Upper", "Conjugate transpose", "Unit", &lastc, k, &c_b1, &v[lastv - *k + 1 + v_dim1], ldv, + &work[work_offset], ldwork); + + /* C2 := C2 - W' */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = lastc; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = lastv - *k + j + i__ * c_dim1; + i__4 = lastv - *k + j + i__ * c_dim1; + d_cnjg(&z__2, &work[i__ + j * work_dim1]); + z__1.r = c__[i__4].r - z__2.r, z__1.i = c__[i__4].i - z__2.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + /* L80: */ + } + /* L90: */ + } + + } else if (lsame_(side, "R")) { + /* Form C * H or C * H' where C = ( C1 C2 ) */ + + /* Computing MAX */ + i__1 = *k, i__2 = ilazlr_(n, k, &v[v_offset], ldv); + lastv = max(i__1, i__2); + lastc = ilazlr_(m, &lastv, &c__[c_offset], ldc); + + /* W := C * V = (C1*V1 + C2*V2) (stored in WORK) */ + + /* W := C2 */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + zcopy_(&lastc, &c__[(lastv - *k + j) * c_dim1 + 1], &c__1, &work[j * work_dim1 + 1], &c__1); + /* L100: */ + } + + /* W := W * V2 */ + + ztrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &c_b1, &v[lastv - *k + 1 + v_dim1], ldv, + &work[work_offset], ldwork); + if (lastv > *k) { + /* W := W + C1 * V1 */ + + i__1 = lastv - *k; + zgemm_("No transpose", "No transpose", &lastc, k, &i__1, &c_b1, &c__[c_offset], ldc, &v[v_offset], ldv, &c_b1, + &work[work_offset], ldwork); + } + + /* W := W * T or W * T' */ + + ztrmm_("Right", "Lower", trans, "Non-unit", &lastc, k, &c_b1, &t[t_offset], ldt, &work[work_offset], ldwork); + + /* C := C - W * V' */ + + if (lastv > *k) { + /* C1 := C1 - W * V1' */ + + i__1 = lastv - *k; + z__1.r = -1., z__1.i = -0.; + zgemm_("No transpose", "Conjugate transpose", &lastc, &i__1, k, &z__1, &work[work_offset], ldwork, + &v[v_offset], ldv, &c_b1, &c__[c_offset], ldc); + } + + /* W := W * V2' */ + + ztrmm_("Right", "Upper", "Conjugate transpose", "Unit", &lastc, k, &c_b1, &v[lastv - *k + 1 + v_dim1], ldv, + &work[work_offset], ldwork); + + /* C2 := C2 - W */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = lastc; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + (lastv - *k + j) * c_dim1; + i__4 = i__ + (lastv - *k + j) * c_dim1; + i__5 = i__ + j * work_dim1; + z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[i__4].i - work[i__5].i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + /* L110: */ + } + /* L120: */ + } + } } - if (lsame_(storev, "C")) { + } else if (lsame_(storev, "R")) { + if (lsame_(direct, "F")) { + /* Let V = ( V1 V2 ) (V1: first K columns) */ + /* where V1 is unit upper triangular. */ - if (lsame_(direct, "F")) { + if (lsame_(side, "L")) { + /* Form H * C or H' * C where C = ( C1 ) */ + /* ( C2 ) */ -/* Let V = ( V1 ) (first K rows) */ -/* ( V2 ) */ -/* where V1 is unit lower triangular. */ + /* Computing MAX */ + i__1 = *k, i__2 = ilazlc_(k, m, &v[v_offset], ldv); + lastv = max(i__1, i__2); + lastc = ilazlc_(&lastv, n, &c__[c_offset], ldc); - if (lsame_(side, "L")) { + /* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) */ -/* Form H * C or H' * C where C = ( C1 ) */ -/* ( C2 ) */ + /* W := C1' */ -/* Computing MAX */ - i__1 = *k, i__2 = ilazlr_(m, k, &v[v_offset], ldv); - lastv = max(i__1,i__2); - lastc = ilazlc_(&lastv, n, &c__[c_offset], ldc); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + zcopy_(&lastc, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1], &c__1); + zlacgv_(&lastc, &work[j * work_dim1 + 1], &c__1); + /* L130: */ + } -/* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) */ + /* W := W * V1' */ -/* W := C1' */ + ztrmm_("Right", "Upper", "Conjugate transpose", "Unit", &lastc, k, &c_b1, &v[v_offset], ldv, &work[work_offset], + ldwork); + if (lastv > *k) { + /* W := W + C2'*V2' */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - zcopy_(&lastc, &c__[j + c_dim1], ldc, &work[j * work_dim1 - + 1], &c__1); - zlacgv_(&lastc, &work[j * work_dim1 + 1], &c__1); -/* L10: */ - } + i__1 = lastv - *k; + zgemm_("Conjugate transpose", "Conjugate transpose", &lastc, k, &i__1, &c_b1, &c__[*k + 1 + c_dim1], ldc, + &v[(*k + 1) * v_dim1 + 1], ldv, &c_b1, &work[work_offset], ldwork); + } -/* W := W * V1 */ + /* W := W * T' or W * T */ - ztrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, & - c_b1, &v[v_offset], ldv, &work[work_offset], ldwork); - if (lastv > *k) { + ztrmm_("Right", "Upper", transt, "Non-unit", &lastc, k, &c_b1, &t[t_offset], ldt, &work[work_offset], ldwork); -/* W := W + C2'*V2 */ + /* C := C - V' * W' */ - i__1 = lastv - *k; - zgemm_("Conjugate transpose", "No transpose", &lastc, k, & - i__1, &c_b1, &c__[*k + 1 + c_dim1], ldc, &v[*k + - 1 + v_dim1], ldv, &c_b1, &work[work_offset], - ldwork); - } + if (lastv > *k) { + /* C2 := C2 - V2' * W' */ -/* W := W * T' or W * T */ + i__1 = lastv - *k; + z__1.r = -1., z__1.i = -0.; + zgemm_("Conjugate transpose", "Conjugate transpose", &i__1, &lastc, k, &z__1, &v[(*k + 1) * v_dim1 + 1], ldv, + &work[work_offset], ldwork, &c_b1, &c__[*k + 1 + c_dim1], ldc); + } - ztrmm_("Right", "Upper", transt, "Non-unit", &lastc, k, &c_b1, - &t[t_offset], ldt, &work[work_offset], ldwork); + /* W := W * V1 */ -/* C := C - V * W' */ + ztrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &c_b1, &v[v_offset], ldv, &work[work_offset], + ldwork); - if (*m > *k) { + /* C1 := C1 - W' */ -/* C2 := C2 - V2 * W' */ + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = lastc; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = j + i__ * c_dim1; + i__4 = j + i__ * c_dim1; + d_cnjg(&z__2, &work[i__ + j * work_dim1]); + z__1.r = c__[i__4].r - z__2.r, z__1.i = c__[i__4].i - z__2.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + /* L140: */ + } + /* L150: */ + } - i__1 = lastv - *k; - z__1.r = -1., z__1.i = -0.; - zgemm_("No transpose", "Conjugate transpose", &i__1, & - lastc, k, &z__1, &v[*k + 1 + v_dim1], ldv, &work[ - work_offset], ldwork, &c_b1, &c__[*k + 1 + c_dim1] -, ldc); - } + } else if (lsame_(side, "R")) { + /* Form C * H or C * H' where C = ( C1 C2 ) */ -/* W := W * V1' */ + /* Computing MAX */ + i__1 = *k, i__2 = ilazlc_(k, n, &v[v_offset], ldv); + lastv = max(i__1, i__2); + lastc = ilazlr_(m, &lastv, &c__[c_offset], ldc); - ztrmm_("Right", "Lower", "Conjugate transpose", "Unit", & - lastc, k, &c_b1, &v[v_offset], ldv, &work[work_offset] -, ldwork) - ; + /* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) */ -/* C1 := C1 - W' */ + /* W := C1 */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = lastc; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = j + i__ * c_dim1; - i__4 = j + i__ * c_dim1; - d_cnjg(&z__2, &work[i__ + j * work_dim1]); - z__1.r = c__[i__4].r - z__2.r, z__1.i = c__[i__4].i - - z__2.i; - c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; -/* L20: */ - } -/* L30: */ - } + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + zcopy_(&lastc, &c__[j * c_dim1 + 1], &c__1, &work[j * work_dim1 + 1], &c__1); + /* L160: */ + } - } else if (lsame_(side, "R")) { + /* W := W * V1' */ -/* Form C * H or C * H' where C = ( C1 C2 ) */ + ztrmm_("Right", "Upper", "Conjugate transpose", "Unit", &lastc, k, &c_b1, &v[v_offset], ldv, &work[work_offset], + ldwork); + if (lastv > *k) { + /* W := W + C2 * V2' */ -/* Computing MAX */ - i__1 = *k, i__2 = ilazlr_(n, k, &v[v_offset], ldv); - lastv = max(i__1,i__2); - lastc = ilazlr_(m, &lastv, &c__[c_offset], ldc); + i__1 = lastv - *k; + zgemm_("No transpose", "Conjugate transpose", &lastc, k, &i__1, &c_b1, &c__[(*k + 1) * c_dim1 + 1], ldc, + &v[(*k + 1) * v_dim1 + 1], ldv, &c_b1, &work[work_offset], ldwork); + } -/* W := C * V = (C1*V1 + C2*V2) (stored in WORK) */ + /* W := W * T or W * T' */ -/* W := C1 */ + ztrmm_("Right", "Upper", trans, "Non-unit", &lastc, k, &c_b1, &t[t_offset], ldt, &work[work_offset], ldwork); - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - zcopy_(&lastc, &c__[j * c_dim1 + 1], &c__1, &work[j * - work_dim1 + 1], &c__1); -/* L40: */ - } + /* C := C - W * V */ -/* W := W * V1 */ + if (lastv > *k) { + /* C2 := C2 - W * V2 */ - ztrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, & - c_b1, &v[v_offset], ldv, &work[work_offset], ldwork); - if (lastv > *k) { + i__1 = lastv - *k; + z__1.r = -1., z__1.i = -0.; + zgemm_("No transpose", "No transpose", &lastc, &i__1, k, &z__1, &work[work_offset], ldwork, + &v[(*k + 1) * v_dim1 + 1], ldv, &c_b1, &c__[(*k + 1) * c_dim1 + 1], ldc); + } -/* W := W + C2 * V2 */ + /* W := W * V1 */ - i__1 = lastv - *k; - zgemm_("No transpose", "No transpose", &lastc, k, &i__1, & - c_b1, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[*k + 1 - + v_dim1], ldv, &c_b1, &work[work_offset], ldwork); - } + ztrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &c_b1, &v[v_offset], ldv, &work[work_offset], + ldwork); -/* W := W * T or W * T' */ + /* C1 := C1 - W */ - ztrmm_("Right", "Upper", trans, "Non-unit", &lastc, k, &c_b1, - &t[t_offset], ldt, &work[work_offset], ldwork); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = lastc; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * work_dim1; + z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[i__4].i - work[i__5].i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + /* L170: */ + } + /* L180: */ + } + } -/* C := C - W * V' */ + } else { + /* Let V = ( V1 V2 ) (V2: last K columns) */ + /* where V2 is unit lower triangular. */ - if (lastv > *k) { + if (lsame_(side, "L")) { + /* Form H * C or H' * C where C = ( C1 ) */ + /* ( C2 ) */ -/* C2 := C2 - W * V2' */ + /* Computing MAX */ + i__1 = *k, i__2 = ilazlc_(k, m, &v[v_offset], ldv); + lastv = max(i__1, i__2); + lastc = ilazlc_(&lastv, n, &c__[c_offset], ldc); - i__1 = lastv - *k; - z__1.r = -1., z__1.i = -0.; - zgemm_("No transpose", "Conjugate transpose", &lastc, & - i__1, k, &z__1, &work[work_offset], ldwork, &v[*k - + 1 + v_dim1], ldv, &c_b1, &c__[(*k + 1) * c_dim1 - + 1], ldc); - } + /* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) */ -/* W := W * V1' */ + /* W := C2' */ - ztrmm_("Right", "Lower", "Conjugate transpose", "Unit", & - lastc, k, &c_b1, &v[v_offset], ldv, &work[work_offset] -, ldwork) - ; + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + zcopy_(&lastc, &c__[lastv - *k + j + c_dim1], ldc, &work[j * work_dim1 + 1], &c__1); + zlacgv_(&lastc, &work[j * work_dim1 + 1], &c__1); + /* L190: */ + } -/* C1 := C1 - W */ + /* W := W * V2' */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = lastc; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * c_dim1; - i__4 = i__ + j * c_dim1; - i__5 = i__ + j * work_dim1; - z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[ - i__4].i - work[i__5].i; - c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; -/* L50: */ - } -/* L60: */ - } - } + ztrmm_("Right", "Lower", "Conjugate transpose", "Unit", &lastc, k, &c_b1, &v[(lastv - *k + 1) * v_dim1 + 1], + ldv, &work[work_offset], ldwork); + if (lastv > *k) { + /* W := W + C1'*V1' */ - } else { + i__1 = lastv - *k; + zgemm_("Conjugate transpose", "Conjugate transpose", &lastc, k, &i__1, &c_b1, &c__[c_offset], ldc, + &v[v_offset], ldv, &c_b1, &work[work_offset], ldwork); + } -/* Let V = ( V1 ) */ -/* ( V2 ) (last K rows) */ -/* where V2 is unit upper triangular. */ + /* W := W * T' or W * T */ - if (lsame_(side, "L")) { + ztrmm_("Right", "Lower", transt, "Non-unit", &lastc, k, &c_b1, &t[t_offset], ldt, &work[work_offset], ldwork); -/* Form H * C or H' * C where C = ( C1 ) */ -/* ( C2 ) */ + /* C := C - V' * W' */ -/* Computing MAX */ - i__1 = *k, i__2 = ilazlr_(m, k, &v[v_offset], ldv); - lastv = max(i__1,i__2); - lastc = ilazlc_(&lastv, n, &c__[c_offset], ldc); + if (lastv > *k) { + /* C1 := C1 - V1' * W' */ -/* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) */ + i__1 = lastv - *k; + z__1.r = -1., z__1.i = -0.; + zgemm_("Conjugate transpose", "Conjugate transpose", &i__1, &lastc, k, &z__1, &v[v_offset], ldv, + &work[work_offset], ldwork, &c_b1, &c__[c_offset], ldc); + } -/* W := C2' */ + /* W := W * V2 */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - zcopy_(&lastc, &c__[lastv - *k + j + c_dim1], ldc, &work[ - j * work_dim1 + 1], &c__1); - zlacgv_(&lastc, &work[j * work_dim1 + 1], &c__1); -/* L70: */ - } + ztrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &c_b1, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, + &work[work_offset], ldwork); -/* W := W * V2 */ + /* C2 := C2 - W' */ - ztrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, & - c_b1, &v[lastv - *k + 1 + v_dim1], ldv, &work[ - work_offset], ldwork); - if (lastv > *k) { + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = lastc; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = lastv - *k + j + i__ * c_dim1; + i__4 = lastv - *k + j + i__ * c_dim1; + d_cnjg(&z__2, &work[i__ + j * work_dim1]); + z__1.r = c__[i__4].r - z__2.r, z__1.i = c__[i__4].i - z__2.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + /* L200: */ + } + /* L210: */ + } -/* W := W + C1'*V1 */ + } else if (lsame_(side, "R")) { + /* Form C * H or C * H' where C = ( C1 C2 ) */ - i__1 = lastv - *k; - zgemm_("Conjugate transpose", "No transpose", &lastc, k, & - i__1, &c_b1, &c__[c_offset], ldc, &v[v_offset], - ldv, &c_b1, &work[work_offset], ldwork); - } + /* Computing MAX */ + i__1 = *k, i__2 = ilazlc_(k, n, &v[v_offset], ldv); + lastv = max(i__1, i__2); + lastc = ilazlr_(m, &lastv, &c__[c_offset], ldc); -/* W := W * T' or W * T */ + /* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) */ - ztrmm_("Right", "Lower", transt, "Non-unit", &lastc, k, &c_b1, - &t[t_offset], ldt, &work[work_offset], ldwork); + /* W := C2 */ -/* C := C - V * W' */ + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + zcopy_(&lastc, &c__[(lastv - *k + j) * c_dim1 + 1], &c__1, &work[j * work_dim1 + 1], &c__1); + /* L220: */ + } - if (lastv > *k) { + /* W := W * V2' */ -/* C1 := C1 - V1 * W' */ + ztrmm_("Right", "Lower", "Conjugate transpose", "Unit", &lastc, k, &c_b1, &v[(lastv - *k + 1) * v_dim1 + 1], + ldv, &work[work_offset], ldwork); + if (lastv > *k) { + /* W := W + C1 * V1' */ - i__1 = lastv - *k; - z__1.r = -1., z__1.i = -0.; - zgemm_("No transpose", "Conjugate transpose", &i__1, & - lastc, k, &z__1, &v[v_offset], ldv, &work[ - work_offset], ldwork, &c_b1, &c__[c_offset], ldc); - } + i__1 = lastv - *k; + zgemm_("No transpose", "Conjugate transpose", &lastc, k, &i__1, &c_b1, &c__[c_offset], ldc, &v[v_offset], ldv, + &c_b1, &work[work_offset], ldwork); + } -/* W := W * V2' */ + /* W := W * T or W * T' */ - ztrmm_("Right", "Upper", "Conjugate transpose", "Unit", & - lastc, k, &c_b1, &v[lastv - *k + 1 + v_dim1], ldv, & - work[work_offset], ldwork); + ztrmm_("Right", "Lower", trans, "Non-unit", &lastc, k, &c_b1, &t[t_offset], ldt, &work[work_offset], ldwork); -/* C2 := C2 - W' */ + /* C := C - W * V */ - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = lastc; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = lastv - *k + j + i__ * c_dim1; - i__4 = lastv - *k + j + i__ * c_dim1; - d_cnjg(&z__2, &work[i__ + j * work_dim1]); - z__1.r = c__[i__4].r - z__2.r, z__1.i = c__[i__4].i - - z__2.i; - c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; -/* L80: */ - } -/* L90: */ - } + if (lastv > *k) { + /* C1 := C1 - W * V1 */ - } else if (lsame_(side, "R")) { + i__1 = lastv - *k; + z__1.r = -1., z__1.i = -0.; + zgemm_("No transpose", "No transpose", &lastc, &i__1, k, &z__1, &work[work_offset], ldwork, &v[v_offset], ldv, + &c_b1, &c__[c_offset], ldc); + } -/* Form C * H or C * H' where C = ( C1 C2 ) */ + /* W := W * V2 */ -/* Computing MAX */ - i__1 = *k, i__2 = ilazlr_(n, k, &v[v_offset], ldv); - lastv = max(i__1,i__2); - lastc = ilazlr_(m, &lastv, &c__[c_offset], ldc); + ztrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &c_b1, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, + &work[work_offset], ldwork); -/* W := C * V = (C1*V1 + C2*V2) (stored in WORK) */ + /* C1 := C1 - W */ -/* W := C2 */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - zcopy_(&lastc, &c__[(lastv - *k + j) * c_dim1 + 1], &c__1, - &work[j * work_dim1 + 1], &c__1); -/* L100: */ - } - -/* W := W * V2 */ - - ztrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, & - c_b1, &v[lastv - *k + 1 + v_dim1], ldv, &work[ - work_offset], ldwork); - if (lastv > *k) { - -/* W := W + C1 * V1 */ - - i__1 = lastv - *k; - zgemm_("No transpose", "No transpose", &lastc, k, &i__1, & - c_b1, &c__[c_offset], ldc, &v[v_offset], ldv, & - c_b1, &work[work_offset], ldwork); - } - -/* W := W * T or W * T' */ - - ztrmm_("Right", "Lower", trans, "Non-unit", &lastc, k, &c_b1, - &t[t_offset], ldt, &work[work_offset], ldwork); - -/* C := C - W * V' */ - - if (lastv > *k) { - -/* C1 := C1 - W * V1' */ - - i__1 = lastv - *k; - z__1.r = -1., z__1.i = -0.; - zgemm_("No transpose", "Conjugate transpose", &lastc, & - i__1, k, &z__1, &work[work_offset], ldwork, &v[ - v_offset], ldv, &c_b1, &c__[c_offset], ldc); - } - -/* W := W * V2' */ - - ztrmm_("Right", "Upper", "Conjugate transpose", "Unit", & - lastc, k, &c_b1, &v[lastv - *k + 1 + v_dim1], ldv, & - work[work_offset], ldwork); - -/* C2 := C2 - W */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = lastc; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + (lastv - *k + j) * c_dim1; - i__4 = i__ + (lastv - *k + j) * c_dim1; - i__5 = i__ + j * work_dim1; - z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[ - i__4].i - work[i__5].i; - c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; -/* L110: */ - } -/* L120: */ - } - } - } - - } else if (lsame_(storev, "R")) { - - if (lsame_(direct, "F")) { - -/* Let V = ( V1 V2 ) (V1: first K columns) */ -/* where V1 is unit upper triangular. */ - - if (lsame_(side, "L")) { - -/* Form H * C or H' * C where C = ( C1 ) */ -/* ( C2 ) */ - -/* Computing MAX */ - i__1 = *k, i__2 = ilazlc_(k, m, &v[v_offset], ldv); - lastv = max(i__1,i__2); - lastc = ilazlc_(&lastv, n, &c__[c_offset], ldc); - -/* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) */ - -/* W := C1' */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - zcopy_(&lastc, &c__[j + c_dim1], ldc, &work[j * work_dim1 - + 1], &c__1); - zlacgv_(&lastc, &work[j * work_dim1 + 1], &c__1); -/* L130: */ - } - -/* W := W * V1' */ - - ztrmm_("Right", "Upper", "Conjugate transpose", "Unit", & - lastc, k, &c_b1, &v[v_offset], ldv, &work[work_offset] -, ldwork) - ; - if (lastv > *k) { - -/* W := W + C2'*V2' */ - - i__1 = lastv - *k; - zgemm_("Conjugate transpose", "Conjugate transpose", & - lastc, k, &i__1, &c_b1, &c__[*k + 1 + c_dim1], - ldc, &v[(*k + 1) * v_dim1 + 1], ldv, &c_b1, &work[ - work_offset], ldwork); - } - -/* W := W * T' or W * T */ - - ztrmm_("Right", "Upper", transt, "Non-unit", &lastc, k, &c_b1, - &t[t_offset], ldt, &work[work_offset], ldwork); - -/* C := C - V' * W' */ - - if (lastv > *k) { - -/* C2 := C2 - V2' * W' */ - - i__1 = lastv - *k; - z__1.r = -1., z__1.i = -0.; - zgemm_("Conjugate transpose", "Conjugate transpose", & - i__1, &lastc, k, &z__1, &v[(*k + 1) * v_dim1 + 1], - ldv, &work[work_offset], ldwork, &c_b1, &c__[*k - + 1 + c_dim1], ldc); - } - -/* W := W * V1 */ - - ztrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, & - c_b1, &v[v_offset], ldv, &work[work_offset], ldwork); - -/* C1 := C1 - W' */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = lastc; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = j + i__ * c_dim1; - i__4 = j + i__ * c_dim1; - d_cnjg(&z__2, &work[i__ + j * work_dim1]); - z__1.r = c__[i__4].r - z__2.r, z__1.i = c__[i__4].i - - z__2.i; - c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; -/* L140: */ - } -/* L150: */ - } - - } else if (lsame_(side, "R")) { - -/* Form C * H or C * H' where C = ( C1 C2 ) */ - -/* Computing MAX */ - i__1 = *k, i__2 = ilazlc_(k, n, &v[v_offset], ldv); - lastv = max(i__1,i__2); - lastc = ilazlr_(m, &lastv, &c__[c_offset], ldc); - -/* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) */ - -/* W := C1 */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - zcopy_(&lastc, &c__[j * c_dim1 + 1], &c__1, &work[j * - work_dim1 + 1], &c__1); -/* L160: */ - } - -/* W := W * V1' */ - - ztrmm_("Right", "Upper", "Conjugate transpose", "Unit", & - lastc, k, &c_b1, &v[v_offset], ldv, &work[work_offset] -, ldwork) - ; - if (lastv > *k) { - -/* W := W + C2 * V2' */ - - i__1 = lastv - *k; - zgemm_("No transpose", "Conjugate transpose", &lastc, k, & - i__1, &c_b1, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[ - (*k + 1) * v_dim1 + 1], ldv, &c_b1, &work[ - work_offset], ldwork); - } - -/* W := W * T or W * T' */ - - ztrmm_("Right", "Upper", trans, "Non-unit", &lastc, k, &c_b1, - &t[t_offset], ldt, &work[work_offset], ldwork); - -/* C := C - W * V */ - - if (lastv > *k) { - -/* C2 := C2 - W * V2 */ - - i__1 = lastv - *k; - z__1.r = -1., z__1.i = -0.; - zgemm_("No transpose", "No transpose", &lastc, &i__1, k, & - z__1, &work[work_offset], ldwork, &v[(*k + 1) * - v_dim1 + 1], ldv, &c_b1, &c__[(*k + 1) * c_dim1 + - 1], ldc); - } - -/* W := W * V1 */ - - ztrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, & - c_b1, &v[v_offset], ldv, &work[work_offset], ldwork); - -/* C1 := C1 - W */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = lastc; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + j * c_dim1; - i__4 = i__ + j * c_dim1; - i__5 = i__ + j * work_dim1; - z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[ - i__4].i - work[i__5].i; - c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; -/* L170: */ - } -/* L180: */ - } - - } - - } else { - -/* Let V = ( V1 V2 ) (V2: last K columns) */ -/* where V2 is unit lower triangular. */ - - if (lsame_(side, "L")) { - -/* Form H * C or H' * C where C = ( C1 ) */ -/* ( C2 ) */ - -/* Computing MAX */ - i__1 = *k, i__2 = ilazlc_(k, m, &v[v_offset], ldv); - lastv = max(i__1,i__2); - lastc = ilazlc_(&lastv, n, &c__[c_offset], ldc); - -/* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) */ - -/* W := C2' */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - zcopy_(&lastc, &c__[lastv - *k + j + c_dim1], ldc, &work[ - j * work_dim1 + 1], &c__1); - zlacgv_(&lastc, &work[j * work_dim1 + 1], &c__1); -/* L190: */ - } - -/* W := W * V2' */ - - ztrmm_("Right", "Lower", "Conjugate transpose", "Unit", & - lastc, k, &c_b1, &v[(lastv - *k + 1) * v_dim1 + 1], - ldv, &work[work_offset], ldwork); - if (lastv > *k) { - -/* W := W + C1'*V1' */ - - i__1 = lastv - *k; - zgemm_("Conjugate transpose", "Conjugate transpose", & - lastc, k, &i__1, &c_b1, &c__[c_offset], ldc, &v[ - v_offset], ldv, &c_b1, &work[work_offset], ldwork); - } - -/* W := W * T' or W * T */ - - ztrmm_("Right", "Lower", transt, "Non-unit", &lastc, k, &c_b1, - &t[t_offset], ldt, &work[work_offset], ldwork); - -/* C := C - V' * W' */ - - if (lastv > *k) { - -/* C1 := C1 - V1' * W' */ - - i__1 = lastv - *k; - z__1.r = -1., z__1.i = -0.; - zgemm_("Conjugate transpose", "Conjugate transpose", & - i__1, &lastc, k, &z__1, &v[v_offset], ldv, &work[ - work_offset], ldwork, &c_b1, &c__[c_offset], ldc); - } - -/* W := W * V2 */ - - ztrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, & - c_b1, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[ - work_offset], ldwork); - -/* C2 := C2 - W' */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = lastc; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = lastv - *k + j + i__ * c_dim1; - i__4 = lastv - *k + j + i__ * c_dim1; - d_cnjg(&z__2, &work[i__ + j * work_dim1]); - z__1.r = c__[i__4].r - z__2.r, z__1.i = c__[i__4].i - - z__2.i; - c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; -/* L200: */ - } -/* L210: */ - } - - } else if (lsame_(side, "R")) { - -/* Form C * H or C * H' where C = ( C1 C2 ) */ - -/* Computing MAX */ - i__1 = *k, i__2 = ilazlc_(k, n, &v[v_offset], ldv); - lastv = max(i__1,i__2); - lastc = ilazlr_(m, &lastv, &c__[c_offset], ldc); - -/* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) */ - -/* W := C2 */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - zcopy_(&lastc, &c__[(lastv - *k + j) * c_dim1 + 1], &c__1, - &work[j * work_dim1 + 1], &c__1); -/* L220: */ - } - -/* W := W * V2' */ - - ztrmm_("Right", "Lower", "Conjugate transpose", "Unit", & - lastc, k, &c_b1, &v[(lastv - *k + 1) * v_dim1 + 1], - ldv, &work[work_offset], ldwork); - if (lastv > *k) { - -/* W := W + C1 * V1' */ - - i__1 = lastv - *k; - zgemm_("No transpose", "Conjugate transpose", &lastc, k, & - i__1, &c_b1, &c__[c_offset], ldc, &v[v_offset], - ldv, &c_b1, &work[work_offset], ldwork); - } - -/* W := W * T or W * T' */ - - ztrmm_("Right", "Lower", trans, "Non-unit", &lastc, k, &c_b1, - &t[t_offset], ldt, &work[work_offset], ldwork); - -/* C := C - W * V */ - - if (lastv > *k) { - -/* C1 := C1 - W * V1 */ - - i__1 = lastv - *k; - z__1.r = -1., z__1.i = -0.; - zgemm_("No transpose", "No transpose", &lastc, &i__1, k, & - z__1, &work[work_offset], ldwork, &v[v_offset], - ldv, &c_b1, &c__[c_offset], ldc); - } - -/* W := W * V2 */ - - ztrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, & - c_b1, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[ - work_offset], ldwork); - -/* C1 := C1 - W */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = lastc; - for (i__ = 1; i__ <= i__2; ++i__) { - i__3 = i__ + (lastv - *k + j) * c_dim1; - i__4 = i__ + (lastv - *k + j) * c_dim1; - i__5 = i__ + j * work_dim1; - z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[ - i__4].i - work[i__5].i; - c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; -/* L230: */ - } -/* L240: */ - } - - } - - } + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = lastc; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + (lastv - *k + j) * c_dim1; + i__4 = i__ + (lastv - *k + j) * c_dim1; + i__5 = i__ + j * work_dim1; + z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[i__4].i - work[i__5].i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + /* L230: */ + } + /* L240: */ + } + } } + } - return 0; - -/* End of ZLARFB */ + /* End of ZLARFB */ } /* zlarfb_ */
diff --git a/lapack/zlarfg.c b/lapack/zlarfg.c index d18efe5..ba5a1f9 100644 --- a/lapack/zlarfg.c +++ b/lapack/zlarfg.c
@@ -1,191 +1,183 @@ /* zlarfg.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., + 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 + http://www.netlib.org/f2c/libf2c.zip */ -#include "f2c.h" #include "blaswrap.h" +#include "lapack_datatypes.h" + +static inline doublereal d_sign(doublereal *a, doublereal *b) { + doublereal x; + x = (*a >= 0 ? *a : -*a); + return (*b >= 0 ? x : -x); +} /* Table of constant values */ -static doublecomplex c_b5 = {1.,0.}; +static doublecomplex c_b5 = {1., 0.}; -/* Subroutine */ int zlarfg_(integer *n, doublecomplex *alpha, doublecomplex * - x, integer *incx, doublecomplex *tau) -{ - /* System generated locals */ - integer i__1; - doublereal d__1, d__2; - doublecomplex z__1, z__2; +/* Subroutine */ void zlarfg_(integer *n, doublecomplex *alpha, doublecomplex *x, integer *incx, doublecomplex *tau) { + /* System generated locals */ + integer i__1; + doublereal d__1, d__2; + doublecomplex z__1, z__2; - /* Builtin functions */ - double d_imag(doublecomplex *), d_sign(doublereal *, doublereal *); + /* Local variables */ + integer j, knt; + doublereal beta, alphi, alphr; + extern /* Subroutine */ void zscal_(integer *, doublecomplex *, doublecomplex *, integer *); + doublereal xnorm; + extern doublereal dlapy3_(doublereal *, doublereal *, doublereal *), dznrm2_(integer *, doublecomplex *, integer *), + dlamch_(char *); + doublereal safmin; + extern /* Subroutine */ void zdscal_(integer *, doublereal *, doublecomplex *, integer *); + doublereal rsafmn; + extern /* Double Complex */ void zladiv_(doublecomplex *, doublecomplex *, doublecomplex *); - /* Local variables */ - integer j, knt; - doublereal beta, alphi, alphr; - extern /* Subroutine */ int zscal_(integer *, doublecomplex *, - doublecomplex *, integer *); - doublereal xnorm; - extern doublereal dlapy3_(doublereal *, doublereal *, doublereal *), - dznrm2_(integer *, doublecomplex *, integer *), dlamch_(char *); - doublereal safmin; - extern /* Subroutine */ int zdscal_(integer *, doublereal *, - doublecomplex *, integer *); - doublereal rsafmn; - extern /* Double Complex */ VOID zladiv_(doublecomplex *, doublecomplex *, - doublecomplex *); + /* -- LAPACK auxiliary routine (version 3.2) -- */ + /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ + /* November 2006 */ + /* .. Scalar Arguments .. */ + /* .. */ + /* .. Array Arguments .. */ + /* .. */ -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ + /* Purpose */ + /* ======= */ -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ + /* ZLARFG generates a complex elementary reflector H of order n, such */ + /* that */ -/* Purpose */ -/* ======= */ + /* H' * ( alpha ) = ( beta ), H' * H = I. */ + /* ( x ) ( 0 ) */ -/* ZLARFG generates a complex elementary reflector H of order n, such */ -/* that */ + /* where alpha and beta are scalars, with beta real, and x is an */ + /* (n-1)-element complex vector. H is represented in the form */ -/* H' * ( alpha ) = ( beta ), H' * H = I. */ -/* ( x ) ( 0 ) */ + /* H = I - tau * ( 1 ) * ( 1 v' ) , */ + /* ( v ) */ -/* where alpha and beta are scalars, with beta real, and x is an */ -/* (n-1)-element complex vector. H is represented in the form */ + /* where tau is a complex scalar and v is a complex (n-1)-element */ + /* vector. Note that H is not hermitian. */ -/* H = I - tau * ( 1 ) * ( 1 v' ) , */ -/* ( v ) */ + /* If the elements of x are all zero and alpha is real, then tau = 0 */ + /* and H is taken to be the unit matrix. */ -/* where tau is a complex scalar and v is a complex (n-1)-element */ -/* vector. Note that H is not hermitian. */ + /* Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 . */ -/* If the elements of x are all zero and alpha is real, then tau = 0 */ -/* and H is taken to be the unit matrix. */ + /* Arguments */ + /* ========= */ -/* Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 . */ + /* N (input) INTEGER */ + /* The order of the elementary reflector. */ -/* Arguments */ -/* ========= */ + /* ALPHA (input/output) COMPLEX*16 */ + /* On entry, the value alpha. */ + /* On exit, it is overwritten with the value beta. */ -/* N (input) INTEGER */ -/* The order of the elementary reflector. */ + /* X (input/output) COMPLEX*16 array, dimension */ + /* (1+(N-2)*abs(INCX)) */ + /* On entry, the vector x. */ + /* On exit, it is overwritten with the vector v. */ -/* ALPHA (input/output) COMPLEX*16 */ -/* On entry, the value alpha. */ -/* On exit, it is overwritten with the value beta. */ + /* INCX (input) INTEGER */ + /* The increment between elements of X. INCX > 0. */ -/* X (input/output) COMPLEX*16 array, dimension */ -/* (1+(N-2)*abs(INCX)) */ -/* On entry, the vector x. */ -/* On exit, it is overwritten with the vector v. */ + /* TAU (output) COMPLEX*16 */ + /* The value tau. */ -/* INCX (input) INTEGER */ -/* The increment between elements of X. INCX > 0. */ + /* ===================================================================== */ -/* TAU (output) COMPLEX*16 */ -/* The value tau. */ + /* .. Parameters .. */ + /* .. */ + /* .. Local Scalars .. */ + /* .. */ + /* .. External Functions .. */ + /* .. */ + /* .. Intrinsic Functions .. */ + /* .. */ + /* .. External Subroutines .. */ + /* .. */ + /* .. Executable Statements .. */ -/* ===================================================================== */ + /* Parameter adjustments */ + --x; -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Executable Statements .. */ + /* Function Body */ + if (*n <= 0) { + tau->r = 0., tau->i = 0.; + return; + } - /* Parameter adjustments */ - --x; + i__1 = *n - 1; + xnorm = dznrm2_(&i__1, &x[1], incx); + alphr = alpha->r; + alphi = alpha->i; - /* Function Body */ - if (*n <= 0) { - tau->r = 0., tau->i = 0.; - return 0; + if (xnorm == 0. && alphi == 0.) { + /* H = I */ + + tau->r = 0., tau->i = 0.; + } else { + /* general case */ + + d__1 = dlapy3_(&alphr, &alphi, &xnorm); + beta = -d_sign(&d__1, &alphr); + safmin = dlamch_("S") / dlamch_("E"); + rsafmn = 1. / safmin; + + knt = 0; + if (abs(beta) < safmin) { + /* XNORM, BETA may be inaccurate; scale X and recompute them */ + + L10: + ++knt; + i__1 = *n - 1; + zdscal_(&i__1, &rsafmn, &x[1], incx); + beta *= rsafmn; + alphi *= rsafmn; + alphr *= rsafmn; + if (abs(beta) < safmin) { + goto L10; + } + + /* New BETA is at most 1, at least SAFMIN */ + + i__1 = *n - 1; + xnorm = dznrm2_(&i__1, &x[1], incx); + z__1.r = alphr, z__1.i = alphi; + alpha->r = z__1.r, alpha->i = z__1.i; + d__1 = dlapy3_(&alphr, &alphi, &xnorm); + beta = -d_sign(&d__1, &alphr); } - + d__1 = (beta - alphr) / beta; + d__2 = -alphi / beta; + z__1.r = d__1, z__1.i = d__2; + tau->r = z__1.r, tau->i = z__1.i; + z__2.r = alpha->r - beta, z__2.i = alpha->i; + zladiv_(&z__1, &c_b5, &z__2); + alpha->r = z__1.r, alpha->i = z__1.i; i__1 = *n - 1; - xnorm = dznrm2_(&i__1, &x[1], incx); - alphr = alpha->r; - alphi = d_imag(alpha); + zscal_(&i__1, alpha, &x[1], incx); - if (xnorm == 0. && alphi == 0.) { + /* If ALPHA is subnormal, it may lose relative accuracy */ -/* H = I */ - - tau->r = 0., tau->i = 0.; - } else { - -/* general case */ - - d__1 = dlapy3_(&alphr, &alphi, &xnorm); - beta = -d_sign(&d__1, &alphr); - safmin = dlamch_("S") / dlamch_("E"); - rsafmn = 1. / safmin; - - knt = 0; - if (abs(beta) < safmin) { - -/* XNORM, BETA may be inaccurate; scale X and recompute them */ - -L10: - ++knt; - i__1 = *n - 1; - zdscal_(&i__1, &rsafmn, &x[1], incx); - beta *= rsafmn; - alphi *= rsafmn; - alphr *= rsafmn; - if (abs(beta) < safmin) { - goto L10; - } - -/* New BETA is at most 1, at least SAFMIN */ - - i__1 = *n - 1; - xnorm = dznrm2_(&i__1, &x[1], incx); - z__1.r = alphr, z__1.i = alphi; - alpha->r = z__1.r, alpha->i = z__1.i; - d__1 = dlapy3_(&alphr, &alphi, &xnorm); - beta = -d_sign(&d__1, &alphr); - } - d__1 = (beta - alphr) / beta; - d__2 = -alphi / beta; - z__1.r = d__1, z__1.i = d__2; - tau->r = z__1.r, tau->i = z__1.i; - z__2.r = alpha->r - beta, z__2.i = alpha->i; - zladiv_(&z__1, &c_b5, &z__2); - alpha->r = z__1.r, alpha->i = z__1.i; - i__1 = *n - 1; - zscal_(&i__1, alpha, &x[1], incx); - -/* If ALPHA is subnormal, it may lose relative accuracy */ - - i__1 = knt; - for (j = 1; j <= i__1; ++j) { - beta *= safmin; -/* L20: */ - } - alpha->r = beta, alpha->i = 0.; + i__1 = knt; + for (j = 1; j <= i__1; ++j) { + beta *= safmin; + /* L20: */ } + alpha->r = beta, alpha->i = 0.; + } - return 0; - -/* End of ZLARFG */ + /* End of ZLARFG */ } /* zlarfg_ */
diff --git a/lapack/zlarft.c b/lapack/zlarft.c index b55adc2..3b40c28 100644 --- a/lapack/zlarft.c +++ b/lapack/zlarft.c
@@ -1,362 +1,347 @@ /* zlarft.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., + 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 + http://www.netlib.org/f2c/libf2c.zip */ -#include "f2c.h" #include "blaswrap.h" +#include "lapack_datatypes.h" /* Table of constant values */ -static doublecomplex c_b2 = {0.,0.}; +static doublecomplex c_b2 = {0., 0.}; static integer c__1 = 1; -/* Subroutine */ int zlarft_(char *direct, char *storev, integer *n, integer * - k, doublecomplex *v, integer *ldv, doublecomplex *tau, doublecomplex * - t, integer *ldt) -{ - /* System generated locals */ - integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4; - doublecomplex z__1; +/* Subroutine */ void zlarft_(char *direct, char *storev, integer *n, integer *k, doublecomplex *v, integer *ldv, + doublecomplex *tau, doublecomplex *t, integer *ldt) { + /* System generated locals */ + integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4; + doublecomplex z__1; - /* Local variables */ - integer i__, j, prevlastv; - doublecomplex vii; - extern logical lsame_(char *, char *); - extern /* Subroutine */ int zgemv_(char *, integer *, integer *, - doublecomplex *, doublecomplex *, integer *, doublecomplex *, - integer *, doublecomplex *, doublecomplex *, integer *); - integer lastv; - extern /* Subroutine */ int ztrmv_(char *, char *, char *, integer *, - doublecomplex *, integer *, doublecomplex *, integer *), zlacgv_(integer *, doublecomplex *, integer *); + /* Local variables */ + integer i__, j, prevlastv; + doublecomplex vii; + extern logical lsame_(char *, char *); + extern /* Subroutine */ void 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 /* Subroutine */ void ztrmv_(const char *, const char *, const char *, const integer *, const doublecomplex *, + const integer *, doublecomplex *, const integer *), + zlacgv_(integer *, doublecomplex *, integer *); + /* -- LAPACK auxiliary routine (version 3.2) -- */ + /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ + /* November 2006 */ -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ + /* .. Scalar Arguments .. */ + /* .. */ + /* .. Array Arguments .. */ + /* .. */ -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ + /* Purpose */ + /* ======= */ -/* Purpose */ -/* ======= */ + /* ZLARFT forms the triangular factor T of a complex block reflector H */ + /* of order n, which is defined as a product of k elementary reflectors. */ -/* ZLARFT forms the triangular factor T of a complex block reflector H */ -/* of order n, which is defined as a product of k elementary reflectors. */ + /* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; */ -/* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; */ + /* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. */ -/* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. */ + /* If STOREV = 'C', the vector which defines the elementary reflector */ + /* H(i) is stored in the i-th column of the array V, and */ -/* If STOREV = 'C', the vector which defines the elementary reflector */ -/* H(i) is stored in the i-th column of the array V, and */ + /* H = I - V * T * V' */ -/* H = I - V * T * V' */ + /* If STOREV = 'R', the vector which defines the elementary reflector */ + /* H(i) is stored in the i-th row of the array V, and */ -/* If STOREV = 'R', the vector which defines the elementary reflector */ -/* H(i) is stored in the i-th row of the array V, and */ + /* H = I - V' * T * V */ -/* H = I - V' * T * V */ + /* Arguments */ + /* ========= */ -/* Arguments */ -/* ========= */ + /* DIRECT (input) CHARACTER*1 */ + /* Specifies the order in which the elementary reflectors are */ + /* multiplied to form the block reflector: */ + /* = 'F': H = H(1) H(2) . . . H(k) (Forward) */ + /* = 'B': H = H(k) . . . H(2) H(1) (Backward) */ -/* DIRECT (input) CHARACTER*1 */ -/* Specifies the order in which the elementary reflectors are */ -/* multiplied to form the block reflector: */ -/* = 'F': H = H(1) H(2) . . . H(k) (Forward) */ -/* = 'B': H = H(k) . . . H(2) H(1) (Backward) */ + /* STOREV (input) CHARACTER*1 */ + /* Specifies how the vectors which define the elementary */ + /* reflectors are stored (see also Further Details): */ + /* = 'C': columnwise */ + /* = 'R': rowwise */ -/* STOREV (input) CHARACTER*1 */ -/* Specifies how the vectors which define the elementary */ -/* reflectors are stored (see also Further Details): */ -/* = 'C': columnwise */ -/* = 'R': rowwise */ + /* N (input) INTEGER */ + /* The order of the block reflector H. N >= 0. */ -/* N (input) INTEGER */ -/* The order of the block reflector H. N >= 0. */ + /* K (input) INTEGER */ + /* The order of the triangular factor T (= the number of */ + /* elementary reflectors). K >= 1. */ -/* K (input) INTEGER */ -/* The order of the triangular factor T (= the number of */ -/* elementary reflectors). K >= 1. */ + /* V (input/output) COMPLEX*16 array, dimension */ + /* (LDV,K) if STOREV = 'C' */ + /* (LDV,N) if STOREV = 'R' */ + /* The matrix V. See further details. */ -/* V (input/output) COMPLEX*16 array, dimension */ -/* (LDV,K) if STOREV = 'C' */ -/* (LDV,N) if STOREV = 'R' */ -/* The matrix V. See further details. */ + /* LDV (input) INTEGER */ + /* The leading dimension of the array V. */ + /* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. */ -/* LDV (input) INTEGER */ -/* The leading dimension of the array V. */ -/* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. */ + /* TAU (input) COMPLEX*16 array, dimension (K) */ + /* TAU(i) must contain the scalar factor of the elementary */ + /* reflector H(i). */ -/* TAU (input) COMPLEX*16 array, dimension (K) */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i). */ + /* T (output) COMPLEX*16 array, dimension (LDT,K) */ + /* The k by k triangular factor T of the block reflector. */ + /* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is */ + /* lower triangular. The rest of the array is not used. */ -/* T (output) COMPLEX*16 array, dimension (LDT,K) */ -/* The k by k triangular factor T of the block reflector. */ -/* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is */ -/* lower triangular. The rest of the array is not used. */ + /* LDT (input) INTEGER */ + /* The leading dimension of the array T. LDT >= K. */ -/* LDT (input) INTEGER */ -/* The leading dimension of the array T. LDT >= K. */ + /* Further Details */ + /* =============== */ -/* Further Details */ -/* =============== */ + /* The shape of the matrix V and the storage of the vectors which define */ + /* the H(i) is best illustrated by the following example with n = 5 and */ + /* k = 3. The elements equal to 1 are not stored; the corresponding */ + /* array elements are modified but restored on exit. The rest of the */ + /* array is not used. */ -/* The shape of the matrix V and the storage of the vectors which define */ -/* the H(i) is best illustrated by the following example with n = 5 and */ -/* k = 3. The elements equal to 1 are not stored; the corresponding */ -/* array elements are modified but restored on exit. The rest of the */ -/* array is not used. */ + /* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': */ -/* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': */ + /* V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) */ + /* ( v1 1 ) ( 1 v2 v2 v2 ) */ + /* ( v1 v2 1 ) ( 1 v3 v3 ) */ + /* ( v1 v2 v3 ) */ + /* ( v1 v2 v3 ) */ -/* V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) */ -/* ( v1 1 ) ( 1 v2 v2 v2 ) */ -/* ( v1 v2 1 ) ( 1 v3 v3 ) */ -/* ( v1 v2 v3 ) */ -/* ( v1 v2 v3 ) */ + /* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': */ -/* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': */ + /* V = ( v1 v2 v3 ) V = ( v1 v1 1 ) */ + /* ( v1 v2 v3 ) ( v2 v2 v2 1 ) */ + /* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) */ + /* ( 1 v3 ) */ + /* ( 1 ) */ -/* V = ( v1 v2 v3 ) V = ( v1 v1 1 ) */ -/* ( v1 v2 v3 ) ( v2 v2 v2 1 ) */ -/* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) */ -/* ( 1 v3 ) */ -/* ( 1 ) */ + /* ===================================================================== */ -/* ===================================================================== */ + /* .. Parameters .. */ + /* .. */ + /* .. Local Scalars .. */ + /* .. */ + /* .. External Subroutines .. */ + /* .. */ + /* .. External Functions .. */ + /* .. */ + /* .. Executable Statements .. */ -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ + /* Quick return if possible */ -/* Quick return if possible */ + /* Parameter adjustments */ + v_dim1 = *ldv; + v_offset = 1 + v_dim1; + v -= v_offset; + --tau; + t_dim1 = *ldt; + t_offset = 1 + t_dim1; + t -= t_offset; - /* Parameter adjustments */ - v_dim1 = *ldv; - v_offset = 1 + v_dim1; - v -= v_offset; - --tau; - t_dim1 = *ldt; - t_offset = 1 + t_dim1; - t -= t_offset; + /* Function Body */ + if (*n == 0) { + return; + } - /* Function Body */ - if (*n == 0) { - return 0; + if (lsame_(direct, "F")) { + prevlastv = *n; + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + prevlastv = max(prevlastv, i__); + i__2 = i__; + if (tau[i__2].r == 0. && tau[i__2].i == 0.) { + /* H(i) = I */ + + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + i__3 = j + i__ * t_dim1; + t[i__3].r = 0., t[i__3].i = 0.; + /* L10: */ + } + } else { + /* general case */ + + i__2 = i__ + i__ * v_dim1; + vii.r = v[i__2].r, vii.i = v[i__2].i; + i__2 = i__ + i__ * v_dim1; + v[i__2].r = 1., v[i__2].i = 0.; + if (lsame_(storev, "C")) { + /* Skip any trailing zeros. */ + i__2 = i__ + 1; + for (lastv = *n; lastv >= i__2; --lastv) { + i__3 = lastv + i__ * v_dim1; + if (v[i__3].r != 0. || v[i__3].i != 0.) { + break; + } + } + j = min(lastv, prevlastv); + + /* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)' * V(i:j,i) */ + + i__2 = j - i__ + 1; + i__3 = i__ - 1; + i__4 = i__; + z__1.r = -tau[i__4].r, z__1.i = -tau[i__4].i; + zgemv_("Conjugate transpose", &i__2, &i__3, &z__1, &v[i__ + v_dim1], ldv, &v[i__ + i__ * v_dim1], &c__1, + &c_b2, &t[i__ * t_dim1 + 1], &c__1); + } else { + /* Skip any trailing zeros. */ + i__2 = i__ + 1; + for (lastv = *n; lastv >= i__2; --lastv) { + i__3 = i__ + lastv * v_dim1; + if (v[i__3].r != 0. || v[i__3].i != 0.) { + break; + } + } + j = min(lastv, prevlastv); + + /* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)' */ + + if (i__ < j) { + i__2 = j - i__; + zlacgv_(&i__2, &v[i__ + (i__ + 1) * v_dim1], ldv); + } + i__2 = i__ - 1; + i__3 = j - i__ + 1; + i__4 = i__; + z__1.r = -tau[i__4].r, z__1.i = -tau[i__4].i; + zgemv_("No transpose", &i__2, &i__3, &z__1, &v[i__ * v_dim1 + 1], ldv, &v[i__ + i__ * v_dim1], ldv, &c_b2, + &t[i__ * t_dim1 + 1], &c__1); + if (i__ < j) { + i__2 = j - i__; + zlacgv_(&i__2, &v[i__ + (i__ + 1) * v_dim1], ldv); + } + } + i__2 = i__ + i__ * v_dim1; + v[i__2].r = vii.r, v[i__2].i = vii.i; + + /* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) */ + + i__2 = i__ - 1; + ztrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[t_offset], ldt, &t[i__ * t_dim1 + 1], &c__1); + i__2 = i__ + i__ * t_dim1; + i__3 = i__; + t[i__2].r = tau[i__3].r, t[i__2].i = tau[i__3].i; + if (i__ > 1) { + prevlastv = max(prevlastv, lastv); + } else { + prevlastv = lastv; + } + } + /* L20: */ } + } else { + prevlastv = 1; + for (i__ = *k; i__ >= 1; --i__) { + i__1 = i__; + if (tau[i__1].r == 0. && tau[i__1].i == 0.) { + /* H(i) = I */ - if (lsame_(direct, "F")) { - prevlastv = *n; - i__1 = *k; - for (i__ = 1; i__ <= i__1; ++i__) { - prevlastv = max(prevlastv,i__); - i__2 = i__; - if (tau[i__2].r == 0. && tau[i__2].i == 0.) { + i__1 = *k; + for (j = i__; j <= i__1; ++j) { + i__2 = j + i__ * t_dim1; + t[i__2].r = 0., t[i__2].i = 0.; + /* L30: */ + } + } else { + /* general case */ -/* H(i) = I */ + if (i__ < *k) { + if (lsame_(storev, "C")) { + i__1 = *n - *k + i__ + i__ * v_dim1; + vii.r = v[i__1].r, vii.i = v[i__1].i; + i__1 = *n - *k + i__ + i__ * v_dim1; + v[i__1].r = 1., v[i__1].i = 0.; + /* Skip any leading zeros. */ + i__1 = i__ - 1; + for (lastv = 1; lastv <= i__1; ++lastv) { + i__2 = lastv + i__ * v_dim1; + if (v[i__2].r != 0. || v[i__2].i != 0.) { + break; + } + } + j = max(lastv, prevlastv); - i__2 = i__; - for (j = 1; j <= i__2; ++j) { - i__3 = j + i__ * t_dim1; - t[i__3].r = 0., t[i__3].i = 0.; -/* L10: */ - } - } else { + /* T(i+1:k,i) := */ + /* - tau(i) * V(j:n-k+i,i+1:k)' * V(j:n-k+i,i) */ -/* general case */ + i__1 = *n - *k + i__ - j + 1; + i__2 = *k - i__; + i__3 = i__; + z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i; + zgemv_("Conjugate transpose", &i__1, &i__2, &z__1, &v[j + (i__ + 1) * v_dim1], ldv, &v[j + i__ * v_dim1], + &c__1, &c_b2, &t[i__ + 1 + i__ * t_dim1], &c__1); + i__1 = *n - *k + i__ + i__ * v_dim1; + v[i__1].r = vii.r, v[i__1].i = vii.i; + } else { + i__1 = i__ + (*n - *k + i__) * v_dim1; + vii.r = v[i__1].r, vii.i = v[i__1].i; + i__1 = i__ + (*n - *k + i__) * v_dim1; + v[i__1].r = 1., v[i__1].i = 0.; + /* Skip any leading zeros. */ + i__1 = i__ - 1; + for (lastv = 1; lastv <= i__1; ++lastv) { + i__2 = i__ + lastv * v_dim1; + if (v[i__2].r != 0. || v[i__2].i != 0.) { + break; + } + } + j = max(lastv, prevlastv); - i__2 = i__ + i__ * v_dim1; - vii.r = v[i__2].r, vii.i = v[i__2].i; - i__2 = i__ + i__ * v_dim1; - v[i__2].r = 1., v[i__2].i = 0.; - if (lsame_(storev, "C")) { -/* Skip any trailing zeros. */ - i__2 = i__ + 1; - for (lastv = *n; lastv >= i__2; --lastv) { - i__3 = lastv + i__ * v_dim1; - if (v[i__3].r != 0. || v[i__3].i != 0.) { - break; - } - } - j = min(lastv,prevlastv); + /* T(i+1:k,i) := */ + /* - tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)' */ -/* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)' * V(i:j,i) */ + i__1 = *n - *k + i__ - 1 - j + 1; + zlacgv_(&i__1, &v[i__ + j * v_dim1], ldv); + i__1 = *k - i__; + i__2 = *n - *k + i__ - j + 1; + i__3 = i__; + z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i; + zgemv_("No transpose", &i__1, &i__2, &z__1, &v[i__ + 1 + j * v_dim1], ldv, &v[i__ + j * v_dim1], ldv, &c_b2, + &t[i__ + 1 + i__ * t_dim1], &c__1); + i__1 = *n - *k + i__ - 1 - j + 1; + zlacgv_(&i__1, &v[i__ + j * v_dim1], ldv); + i__1 = i__ + (*n - *k + i__) * v_dim1; + v[i__1].r = vii.r, v[i__1].i = vii.i; + } - i__2 = j - i__ + 1; - i__3 = i__ - 1; - i__4 = i__; - z__1.r = -tau[i__4].r, z__1.i = -tau[i__4].i; - zgemv_("Conjugate transpose", &i__2, &i__3, &z__1, &v[i__ - + v_dim1], ldv, &v[i__ + i__ * v_dim1], &c__1, & - c_b2, &t[i__ * t_dim1 + 1], &c__1); - } else { -/* Skip any trailing zeros. */ - i__2 = i__ + 1; - for (lastv = *n; lastv >= i__2; --lastv) { - i__3 = i__ + lastv * v_dim1; - if (v[i__3].r != 0. || v[i__3].i != 0.) { - break; - } - } - j = min(lastv,prevlastv); + /* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) */ -/* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)' */ - - if (i__ < j) { - i__2 = j - i__; - zlacgv_(&i__2, &v[i__ + (i__ + 1) * v_dim1], ldv); - } - i__2 = i__ - 1; - i__3 = j - i__ + 1; - i__4 = i__; - z__1.r = -tau[i__4].r, z__1.i = -tau[i__4].i; - zgemv_("No transpose", &i__2, &i__3, &z__1, &v[i__ * - v_dim1 + 1], ldv, &v[i__ + i__ * v_dim1], ldv, & - c_b2, &t[i__ * t_dim1 + 1], &c__1); - if (i__ < j) { - i__2 = j - i__; - zlacgv_(&i__2, &v[i__ + (i__ + 1) * v_dim1], ldv); - } - } - i__2 = i__ + i__ * v_dim1; - v[i__2].r = vii.r, v[i__2].i = vii.i; - -/* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) */ - - i__2 = i__ - 1; - ztrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[ - t_offset], ldt, &t[i__ * t_dim1 + 1], &c__1); - i__2 = i__ + i__ * t_dim1; - i__3 = i__; - t[i__2].r = tau[i__3].r, t[i__2].i = tau[i__3].i; - if (i__ > 1) { - prevlastv = max(prevlastv,lastv); - } else { - prevlastv = lastv; - } - } -/* L20: */ - } - } else { - prevlastv = 1; - for (i__ = *k; i__ >= 1; --i__) { - i__1 = i__; - if (tau[i__1].r == 0. && tau[i__1].i == 0.) { - -/* H(i) = I */ - - i__1 = *k; - for (j = i__; j <= i__1; ++j) { - i__2 = j + i__ * t_dim1; - t[i__2].r = 0., t[i__2].i = 0.; -/* L30: */ - } - } else { - -/* general case */ - - if (i__ < *k) { - if (lsame_(storev, "C")) { - i__1 = *n - *k + i__ + i__ * v_dim1; - vii.r = v[i__1].r, vii.i = v[i__1].i; - i__1 = *n - *k + i__ + i__ * v_dim1; - v[i__1].r = 1., v[i__1].i = 0.; -/* Skip any leading zeros. */ - i__1 = i__ - 1; - for (lastv = 1; lastv <= i__1; ++lastv) { - i__2 = lastv + i__ * v_dim1; - if (v[i__2].r != 0. || v[i__2].i != 0.) { - break; - } - } - j = max(lastv,prevlastv); - -/* T(i+1:k,i) := */ -/* - tau(i) * V(j:n-k+i,i+1:k)' * V(j:n-k+i,i) */ - - i__1 = *n - *k + i__ - j + 1; - i__2 = *k - i__; - i__3 = i__; - z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i; - zgemv_("Conjugate transpose", &i__1, &i__2, &z__1, &v[ - j + (i__ + 1) * v_dim1], ldv, &v[j + i__ * - v_dim1], &c__1, &c_b2, &t[i__ + 1 + i__ * - t_dim1], &c__1); - i__1 = *n - *k + i__ + i__ * v_dim1; - v[i__1].r = vii.r, v[i__1].i = vii.i; - } else { - i__1 = i__ + (*n - *k + i__) * v_dim1; - vii.r = v[i__1].r, vii.i = v[i__1].i; - i__1 = i__ + (*n - *k + i__) * v_dim1; - v[i__1].r = 1., v[i__1].i = 0.; -/* Skip any leading zeros. */ - i__1 = i__ - 1; - for (lastv = 1; lastv <= i__1; ++lastv) { - i__2 = i__ + lastv * v_dim1; - if (v[i__2].r != 0. || v[i__2].i != 0.) { - break; - } - } - j = max(lastv,prevlastv); - -/* T(i+1:k,i) := */ -/* - tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)' */ - - i__1 = *n - *k + i__ - 1 - j + 1; - zlacgv_(&i__1, &v[i__ + j * v_dim1], ldv); - i__1 = *k - i__; - i__2 = *n - *k + i__ - j + 1; - i__3 = i__; - z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i; - zgemv_("No transpose", &i__1, &i__2, &z__1, &v[i__ + - 1 + j * v_dim1], ldv, &v[i__ + j * v_dim1], - ldv, &c_b2, &t[i__ + 1 + i__ * t_dim1], &c__1); - i__1 = *n - *k + i__ - 1 - j + 1; - zlacgv_(&i__1, &v[i__ + j * v_dim1], ldv); - i__1 = i__ + (*n - *k + i__) * v_dim1; - v[i__1].r = vii.r, v[i__1].i = vii.i; - } - -/* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) */ - - i__1 = *k - i__; - ztrmv_("Lower", "No transpose", "Non-unit", &i__1, &t[i__ - + 1 + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ * - t_dim1], &c__1) - ; - if (i__ > 1) { - prevlastv = min(prevlastv,lastv); - } else { - prevlastv = lastv; - } - } - i__1 = i__ + i__ * t_dim1; - i__2 = i__; - t[i__1].r = tau[i__2].r, t[i__1].i = tau[i__2].i; - } -/* L40: */ - } + i__1 = *k - i__; + ztrmv_("Lower", "No transpose", "Non-unit", &i__1, &t[i__ + 1 + (i__ + 1) * t_dim1], ldt, + &t[i__ + 1 + i__ * t_dim1], &c__1); + if (i__ > 1) { + prevlastv = min(prevlastv, lastv); + } else { + prevlastv = lastv; + } + } + i__1 = i__ + i__ * t_dim1; + i__2 = i__; + t[i__1].r = tau[i__2].r, t[i__1].i = tau[i__2].i; + } + /* L40: */ } - return 0; + } -/* End of ZLARFT */ + /* End of ZLARFT */ } /* zlarft_ */