/* Subroutine */ int clarfp_(integer *n, complex *alpha, complex *x, integer *
incx, complex *tau)
{
/* System generated locals */
integer i__1, i__2;
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 */ int cscal_(integer *, complex *, complex *,
integer *);
real alphi, alphr, xnorm;
extern doublereal scnrm2_(integer *, complex *, integer *), slapy2_(real *
, real *), 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 .. */
/* .. */
/* Purpose */
/* ======= */
/* CLARFP generates a complex elementary reflector H of order n, such */
/* that */
/* H' * ( alpha ) = ( beta ), H' * H = I. */
/* ( x ) ( 0 ) */
/* where alpha and beta are scalars, beta is real and non-negative, and */
/* x is an (n-1)-element complex vector. H is represented in the form */
/* H = I - tau * ( 1 ) * ( 1 v' ) , */
/* ( v ) */
/* where tau is a complex scalar and v is a complex (n-1)-element */
/* vector. Note that H is not hermitian. */
/* If the elements of x are all zero and alpha is real, then tau = 0 */
/* and H is taken to be the unit matrix. */
/* Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 . */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the elementary reflector. */
/* ALPHA (input/output) COMPLEX */
/* On entry, the value alpha. */
/* On exit, it is overwritten with the value beta. */
/* 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. */
/* 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;
/* Function Body */
if (*n <= 0) {
tau->r = 0.f, tau->i = 0.f;
return 0;
}
i__1 = *n - 1;
xnorm = scnrm2_(&i__1, &x[1], incx);
alphr = alpha->r;
alphi = r_imag(alpha);
if (xnorm == 0.f && alphi == 0.f) {
/* H = [1-alpha/abs(alpha) 0; 0 I], sign chosen so ALPHA >= 0. */
if (alphi == 0.f) {
if (alphr >= 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->r = 0.f, tau->i = 0.f;
} else {
/* However, the application routines rely on explicit */
/* zero checks when TAU.ne.ZERO, and we must clear X. */
tau->r = 2.f, tau->i = 0.f;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.f, x[i__2].i = 0.f;
}
q__1.r = -alpha->r, q__1.i = -alpha->i;
alpha->r = q__1.r, alpha->i = q__1.i;
}
} else {
/* Only "reflecting" the diagonal entry to be real and non-negative. */
xnorm = slapy2_(&alphr, &alphi);
r__1 = 1.f - alphr / xnorm;
r__2 = -alphi / xnorm;
q__1.r = r__1, q__1.i = r__2;
tau->r = q__1.r, tau->i = q__1.i;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.f, x[i__2].i = 0.f;
}
alpha->r = xnorm, alpha->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);
}
q__1.r = alpha->r + beta, q__1.i = alpha->i;
alpha->r = q__1.r, alpha->i = q__1.i;
if (beta < 0.f) {
beta = -beta;
q__2.r = -alpha->r, q__2.i = -alpha->i;
q__1.r = q__2.r / beta, q__1.i = q__2.i / beta;
tau->r = q__1.r, tau->i = q__1.i;
} else {
alphr = alphi * (alphi / alpha->r);
alphr += xnorm * (xnorm / alpha->r);
r__1 = 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;
r__1 = -alphr;
q__1.r = r__1, q__1.i = alphi;
alpha->r = q__1.r, alpha->i = q__1.i;
}
cladiv_(&q__1, &c_b5, alpha);
alpha->r = q__1.r, alpha->i = q__1.i;
i__1 = *n - 1;
cscal_(&i__1, alpha, &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->r = beta, alpha->i = 0.f;
}
return 0;
/* End of CLARFP */
} /* clarfp_ */
/* Subroutine */
int clarfgp_(integer *n, complex *alpha, complex *x, integer *incx, complex *tau)
{
/* System generated locals */
integer i__1, i__2;
real r__1, r__2;
complex q__1, q__2;
/* Builtin functions */
double r_imag(complex *), r_sign(real *, real *), c_abs(complex *);
/* Local variables */
integer j;
complex savealpha;
integer knt;
real beta;
extern /* Subroutine */
int cscal_(integer *, complex *, complex *, integer *);
real alphi, alphr, xnorm;
extern real scnrm2_(integer *, complex *, integer *), slapy2_(real *, real *), slapy3_(real *, real *, real *);
extern /* Complex */
VOID cladiv_(complex *, complex *, complex *);
extern real slamch_(char *);
extern /* Subroutine */
int csscal_(integer *, real *, complex *, integer *);
real bignum, smlnum;
/* -- LAPACK auxiliary routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--x;
/* Function Body */
if (*n <= 0)
{
tau->r = 0.f, tau->i = 0.f;
return 0;
}
i__1 = *n - 1;
xnorm = scnrm2_(&i__1, &x[1], incx);
alphr = alpha->r;
alphi = r_imag(alpha);
if (xnorm == 0.f)
{
/* H = [1-alpha/f2c_abs(alpha) 0;
0 I], sign chosen so ALPHA >= 0. */
if (alphi == 0.f)
{
if (alphr >= 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->r = 0.f, tau->i = 0.f;
}
else
{
/* However, the application routines rely on explicit */
/* zero checks when TAU.ne.ZERO, and we must clear X. */
tau->r = 2.f, tau->i = 0.f;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.f;
x[i__2].i = 0.f; // , expr subst
}
q__1.r = -alpha->r;
q__1.i = -alpha->i; // , expr subst
alpha->r = q__1.r, alpha->i = q__1.i;
}
}
else
{
/* Only "reflecting" the diagonal entry to be real and non-negative. */
xnorm = slapy2_(&alphr, &alphi);
r__1 = 1.f - alphr / xnorm;
r__2 = -alphi / xnorm;
q__1.r = r__1;
q__1.i = r__2; // , expr subst
tau->r = q__1.r, tau->i = q__1.i;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.f;
x[i__2].i = 0.f; // , expr subst
}
alpha->r = xnorm, alpha->i = 0.f;
}
}
else
{
/* general case */
r__1 = slapy3_(&alphr, &alphi, &xnorm);
beta = r_sign(&r__1, &alphr);
smlnum = slamch_("S") / slamch_("E");
bignum = 1.f / smlnum;
knt = 0;
if (f2c_abs(beta) < smlnum)
{
/* XNORM, BETA may be inaccurate;
scale X and recompute them */
L10:
++knt;
i__1 = *n - 1;
csscal_(&i__1, &bignum, &x[1], incx);
beta *= bignum;
alphi *= bignum;
alphr *= bignum;
if (f2c_abs(beta) < smlnum)
{
goto L10;
}
/* New BETA is at most 1, at least SMLNUM */
i__1 = *n - 1;
xnorm = scnrm2_(&i__1, &x[1], incx);
q__1.r = alphr;
q__1.i = alphi; // , expr subst
alpha->r = q__1.r, alpha->i = q__1.i;
r__1 = slapy3_(&alphr, &alphi, &xnorm);
beta = r_sign(&r__1, &alphr);
}
savealpha.r = alpha->r;
savealpha.i = alpha->i; // , expr subst
q__1.r = alpha->r + beta;
q__1.i = alpha->i; // , expr subst
alpha->r = q__1.r, alpha->i = q__1.i;
if (beta < 0.f)
{
beta = -beta;
q__2.r = -alpha->r;
q__2.i = -alpha->i; // , expr subst
q__1.r = q__2.r / beta;
q__1.i = q__2.i / beta; // , expr subst
tau->r = q__1.r, tau->i = q__1.i;
}
else
{
alphr = alphi * (alphi / alpha->r);
alphr += xnorm * (xnorm / alpha->r);
r__1 = alphr / beta;
r__2 = -alphi / beta;
q__1.r = r__1;
q__1.i = r__2; // , expr subst
tau->r = q__1.r, tau->i = q__1.i;
r__1 = -alphr;
q__1.r = r__1;
q__1.i = alphi; // , expr subst
alpha->r = q__1.r, alpha->i = q__1.i;
}
cladiv_(&q__1, &c_b5, alpha);
alpha->r = q__1.r, alpha->i = q__1.i;
if (c_abs(tau) <= smlnum)
{
/* In the case where the computed TAU ends up being a denormalized number, */
/* it loses relative accuracy. This is a BIG problem. Solution: flush TAU */
/* to ZERO (or TWO or whatever makes a nonnegative real number for BETA). */
/* (Bug report provided by Pat Quillen from MathWorks on Jul 29, 2009.) */
/* (Thanks Pat. Thanks MathWorks.) */
alphr = savealpha.r;
alphi = r_imag(&savealpha);
if (alphi == 0.f)
{
if (alphr >= 0.f)
{
tau->r = 0.f, tau->i = 0.f;
}
else
{
tau->r = 2.f, tau->i = 0.f;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.f;
x[i__2].i = 0.f; // , expr subst
}
q__1.r = -savealpha.r;
q__1.i = -savealpha.i; // , expr subst
beta = q__1.r;
}
}
else
{
xnorm = slapy2_(&alphr, &alphi);
r__1 = 1.f - alphr / xnorm;
r__2 = -alphi / xnorm;
q__1.r = r__1;
q__1.i = r__2; // , expr subst
tau->r = q__1.r, tau->i = q__1.i;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.f;
x[i__2].i = 0.f; // , expr subst
}
beta = xnorm;
}
}
else
{
/* This is the general case. */
i__1 = *n - 1;
cscal_(&i__1, alpha, &x[1], incx);
}
/* If BETA is subnormal, it may lose relative accuracy */
i__1 = knt;
for (j = 1;
j <= i__1;
++j)
{
beta *= smlnum;
/* L20: */
}
alpha->r = beta, alpha->i = 0.f;
}
return 0;
/* End of CLARFGP */
}
/* Subroutine */ int clarfg_(integer *n, complex *alpha, complex *x, integer *
incx, complex *tau)
{
/* -- LAPACK auxiliary routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CLARFG generates a complex elementary reflector H of order n, such
that
H' * ( alpha ) = ( beta ), H' * H = I.
( x ) ( 0 )
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 = I - tau * ( 1 ) * ( 1 v' ) ,
( v )
where tau is a complex scalar and v is a complex (n-1)-element
vector. Note that H is not hermitian.
If the elements of x are all zero and alpha is real, then tau = 0
and H is taken to be the unit matrix.
Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 .
Arguments
=========
N (input) INTEGER
The order of the elementary reflector.
ALPHA (input/output) COMPLEX
On entry, the value alpha.
On exit, it is overwritten with the value beta.
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.
INCX (input) INTEGER
The increment between elements of X. INCX > 0.
TAU (output) COMPLEX
The value tau.
=====================================================================
Parameter adjustments
Function Body */
/* Table of constant values */
static complex c_b5 = {1.f,0.f};
/* System generated locals */
integer i__1;
real r__1;
doublereal d__1, d__2;
complex q__1, q__2;
/* Builtin functions */
double r_imag(complex *), r_sign(real *, real *);
/* Local variables */
static real beta;
static integer j;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *);
static 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
*);
static real safmin, rsafmn;
static integer knt;
#define X(I) x[(I)-1]
if (*n <= 0) {
tau->r = 0.f, tau->i = 0.f;
return 0;
}
i__1 = *n - 1;
xnorm = scnrm2_(&i__1, &X(1), incx);
alphr = alpha->r;
alphi = r_imag(alpha);
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 = -(doublereal)r_sign(&r__1, &alphr);
safmin = slamch_("S") / slamch_("E");
rsafmn = 1.f / safmin;
if (dabs(beta) < safmin) {
/* XNORM, BETA may be inaccurate; scale X and recompute
them */
knt = 0;
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 = -(doublereal)r_sign(&r__1, &alphr);
d__1 = (beta - alphr) / beta;
d__2 = -(doublereal)alphi / beta;
q__1.r = d__1, q__1.i = d__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
*/
alpha->r = beta, alpha->i = 0.f;
i__1 = knt;
for (j = 1; j <= knt; ++j) {
q__1.r = safmin * alpha->r, q__1.i = safmin * alpha->i;
alpha->r = q__1.r, alpha->i = q__1.i;
/* L20: */
}
} else {
d__1 = (beta - alphr) / beta;
d__2 = -(doublereal)alphi / beta;
q__1.r = d__1, q__1.i = d__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);
alpha->r = beta, alpha->i = 0.f;
}
}
return 0;
/* End of CLARFG */
} /* clarfg_ */
