[] add metering mode to CLI

1 files changed, 191 insertions, 0 deletions

diff --git a/contrib/libs/clapack/slarfp.c b/contrib/libs/clapack/slarfp.c
new file mode 100644
index 0000000000..5db647ab0a
--- /dev/null
+++ b/contrib/libs/clapack/slarfp.c
@@ -0,0 +1,191 @@
+/* slarfp.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slarfp_(integer *n, real *alpha, real *x, integer *incx, 
+	real *tau)
+{
+    /* System generated locals */
+    integer i__1;
+    real r__1;
+
+    /* Builtin functions */
+    double r_sign(real *, real *);
+
+    /* 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;
+
+
+/*  -- LAPACK auxiliary routine (version 3.2) -- */
+/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/*     November 2006 */
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  SLARFP generates a real elementary reflector H of order n, such */
+/*  that */
+
+/*        H * ( alpha ) = ( beta ),   H' * H = I. */
+/*            (   x   )   (   0  ) */
+
+/*  where alpha and beta are scalars, beta is non-negative, and x is */
+/*  an (n-1)-element real vector.  H is represented in the form */
+
+/*        H = I - tau * ( 1 ) * ( 1 v' ) , */
+/*                      ( v ) */
+
+/*  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. */
+
+/*  Otherwise  1 <= tau <= 2. */
+
+/*  Arguments */
+/*  ========= */
+
+/*  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. */
+
+/*  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. */
+
+/*  TAU     (output) REAL */
+/*          The value tau. */
+
+/*  ===================================================================== */
+
+/*     .. Parameters .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. External Functions .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+/*     .. External Subroutines .. */
+/*     .. */
+/*     .. Executable Statements .. */
+
+    /* Parameter adjustments */
+    --x;
+
+    /* Function Body */
+    if (*n <= 0) {
+	*tau = 0.f;
+	return 0;
+    }
+
+    i__1 = *n - 1;
+    xnorm = snrm2_(&i__1, &x[1], incx);
+
+    if (xnorm == 0.f) {
+
+/*        H  =  [+/-1, 0; I], sign chosen so ALPHA >= 0. */
+
+	if (*alpha >= 0.f) {
+/*           When TAU.eq.ZERO, the vector is special-cased to be */
+/*           all zeros in the application routines.  We do not need */
+/*           to clear it. */
+	    *tau = 0.f;
+	} else {
+/*           However, the application routines rely on explicit */
+/*           zero checks when TAU.ne.ZERO, and we must clear X. */
+	    *tau = 2.f;
+	    i__1 = *n - 1;
+	    for (j = 1; j <= i__1; ++j) {
+		x[(j - 1) * *incx + 1] = 0.f;
+	    }
+	    *alpha = -(*alpha);
+	}
+    } 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);
+	}
+	*alpha += beta;
+	if (beta < 0.f) {
+	    beta = -beta;
+	    *tau = -(*alpha) / beta;
+	} else {
+	    *alpha = xnorm * (xnorm / *alpha);
+	    *tau = *alpha / beta;
+	    *alpha = -(*alpha);
+	}
+	i__1 = *n - 1;
+	r__1 = 1.f / *alpha;
+	sscal_(&i__1, &r__1, &x[1], incx);
+
+/*        If BETA is subnormal, it may lose relative accuracy */
+
+	i__1 = knt;
+	for (j = 1; j <= i__1; ++j) {
+	    beta *= safmin;
+/* L20: */
+	}
+	*alpha = beta;
+    }
+
+    return 0;
+
+/*     End of SLARFP */
+
+} /* slarfp_ */