mirror of
https://github.com/opencv/opencv.git
synced 2024-12-18 11:28:02 +08:00
164 lines
3.8 KiB
C
164 lines
3.8 KiB
C
#include "clapack.h"
|
|
|
|
/* Subroutine */ int dlarfg_(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.1) -- */
|
|
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
|
|
/* November 2006 */
|
|
|
|
/* .. Scalar Arguments .. */
|
|
/* .. */
|
|
/* .. Array Arguments .. */
|
|
/* .. */
|
|
|
|
/* Purpose */
|
|
/* ======= */
|
|
|
|
/* DLARFG 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, 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 <= 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");
|
|
if (abs(beta) < safmin) {
|
|
|
|
/* XNORM, BETA may be inaccurate; scale X and recompute them */
|
|
|
|
rsafmn = 1. / safmin;
|
|
knt = 0;
|
|
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 */
|
|
|
|
*alpha = beta;
|
|
i__1 = knt;
|
|
for (j = 1; j <= i__1; ++j) {
|
|
*alpha *= safmin;
|
|
/* L20: */
|
|
}
|
|
} else {
|
|
*tau = (beta - *alpha) / beta;
|
|
i__1 = *n - 1;
|
|
d__1 = 1. / (*alpha - beta);
|
|
dscal_(&i__1, &d__1, &x[1], incx);
|
|
*alpha = beta;
|
|
}
|
|
}
|
|
|
|
return 0;
|
|
|
|
/* End of DLARFG */
|
|
|
|
} /* dlarfg_ */
|