mirror of https://github.com/opencv/opencv.git
Open Source Computer Vision Library
https://opencv.org/
You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
192 lines
4.8 KiB
192 lines
4.8 KiB
/* dlarfp.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 dlarfp_(integer *n, doublereal *alpha, doublereal *x, |
|
integer *incx, doublereal *tau) |
|
{ |
|
/* System generated locals */ |
|
integer i__1; |
|
doublereal d__1; |
|
|
|
/* Builtin functions */ |
|
double d_sign(doublereal *, doublereal *); |
|
|
|
/* 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; |
|
|
|
|
|
/* -- LAPACK auxiliary routine (version 3.2) -- */ |
|
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ |
|
/* November 2006 */ |
|
|
|
/* .. Scalar Arguments .. */ |
|
/* .. */ |
|
/* .. Array Arguments .. */ |
|
/* .. */ |
|
|
|
/* Purpose */ |
|
/* ======= */ |
|
|
|
/* DLARFP 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) 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. */ |
|
|
|
/* INCX (input) INTEGER */ |
|
/* The increment between elements of X. INCX > 0. */ |
|
|
|
/* TAU (output) DOUBLE PRECISION */ |
|
/* The value tau. */ |
|
|
|
/* ===================================================================== */ |
|
|
|
/* .. Parameters .. */ |
|
/* .. */ |
|
/* .. Local Scalars .. */ |
|
/* .. */ |
|
/* .. External Functions .. */ |
|
/* .. */ |
|
/* .. Intrinsic Functions .. */ |
|
/* .. */ |
|
/* .. External Subroutines .. */ |
|
/* .. */ |
|
/* .. Executable Statements .. */ |
|
|
|
/* Parameter adjustments */ |
|
--x; |
|
|
|
/* Function Body */ |
|
if (*n <= 0) { |
|
*tau = 0.; |
|
return 0; |
|
} |
|
|
|
i__1 = *n - 1; |
|
xnorm = dnrm2_(&i__1, &x[1], incx); |
|
|
|
if (xnorm == 0.) { |
|
|
|
/* H = [+/-1, 0; I], sign chosen so ALPHA >= 0 */ |
|
|
|
if (*alpha >= 0.) { |
|
/* 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.; |
|
} else { |
|
/* However, the application routines rely on explicit */ |
|
/* zero checks when TAU.ne.ZERO, and we must clear X. */ |
|
*tau = 2.; |
|
i__1 = *n - 1; |
|
for (j = 1; j <= i__1; ++j) { |
|
x[(j - 1) * *incx + 1] = 0.; |
|
} |
|
*alpha = -(*alpha); |
|
} |
|
} 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); |
|
} |
|
*alpha += beta; |
|
if (beta < 0.) { |
|
beta = -beta; |
|
*tau = -(*alpha) / beta; |
|
} else { |
|
*alpha = xnorm * (xnorm / *alpha); |
|
*tau = *alpha / beta; |
|
*alpha = -(*alpha); |
|
} |
|
i__1 = *n - 1; |
|
d__1 = 1. / *alpha; |
|
dscal_(&i__1, &d__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 DLARFP */ |
|
|
|
} /* dlarfp_ */
|
|
|