updated 3rd party libs: CLapack 3.1.1.1 => 3.2.1, zlib 1.2.3 => 1.2.5, libpng 1.2.x => 1.4.3, libtiff 3.7.x => 3.9.4. fixed many 64-bit related VS2010 warnings
This commit is contained in:
Vadim Pisarevsky
191
3rdparty/lapack/slarfp.c
vendored
Normal file
191
3rdparty/lapack/slarfp.c
vendored
Normal file
@@ -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 "clapack.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_ */
|
||||
Reference in New Issue
Block a user