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);</