1 /* ../netlib/slarfg.f -- translated by f2c (version 20100827). You must link the resulting object file with libf2c: on Microsoft Windows system, link with libf2c.lib;
2 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 */
3 #include "FLA_f2c.h" /* > \brief \b SLARFG generates an elementary reflector (Householder matrix). */
4 /* =========== DOCUMENTATION =========== */
5 /* Online html documentation available at */
6 /* http://www.netlib.org/lapack/explore-html/ */
7 /* > \htmlonly */
8 /* > Download SLARFG + dependencies */
9 /* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slarfg. f"> */
10 /* > [TGZ]</a> */
11 /* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slarfg. f"> */
12 /* > [ZIP]</a> */
13 /* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slarfg. f"> */
14 /* > [TXT]</a> */
15 /* > \endhtmlonly */
16 /* Definition: */
17 /* =========== */
18 /* SUBROUTINE SLARFG( N, ALPHA, X, INCX, TAU ) */
19 /* .. Scalar Arguments .. */
20 /* INTEGER INCX, N */
21 /* REAL ALPHA, TAU */
22 /* .. */
23 /* .. Array Arguments .. */
24 /* REAL X( * ) */
25 /* .. */
26 /* > \par Purpose: */
27 /* ============= */
28 /* > */
29 /* > \verbatim */
30 /* > */
31 /* > SLARFG generates a real elementary reflector H of order n, such */
32 /* > that */
33 /* > */
34 /* > H * ( alpha ) = ( beta ), H**T * H = I. */
35 /* > ( x ) ( 0 ) */
36 /* > */
37 /* > where alpha and beta are scalars, and x is an (n-1)-element real */
38 /* > vector. H is represented in the form */
39 /* > */
40 /* > H = I - tau * ( 1 ) * ( 1 v**T ) , */
41 /* > ( v ) */
42 /* > */
43 /* > where tau is a real scalar and v is a real (n-1)-element */
44 /* > vector. */
45 /* > */
46 /* > If the elements of x are all zero, then tau = 0 and H is taken to be */
47 /* > the unit matrix. */
48 /* > */
49 /* > Otherwise 1 <= tau <= 2. */
50 /* > \endverbatim */
51 /* Arguments: */
52 /* ========== */
53 /* > \param[in] N */
54 /* > \verbatim */
55 /* > N is INTEGER */
56 /* > The order of the elementary reflector. */
57 /* > \endverbatim */
58 /* > */
59 /* > \param[in,out] ALPHA */
60 /* > \verbatim */
61 /* > ALPHA is REAL */
62 /* > On entry, the value alpha. */
63 /* > On exit, it is overwritten with the value beta. */
64 /* > \endverbatim */
65 /* > */
66 /* > \param[in,out] X */
67 /* > \verbatim */
68 /* > X is REAL array, dimension */
69 /* > (1+(N-2)*f2c_abs(INCX)) */
70 /* > On entry, the vector x. */
71 /* > On exit, it is overwritten with the vector v. */
72 /* > \endverbatim */
73 /* > */
74 /* > \param[in] INCX */
75 /* > \verbatim */
76 /* > INCX is INTEGER */
77 /* > The increment between elements of X. INCX > 0. */
78 /* > \endverbatim */
79 /* > */
80 /* > \param[out] TAU */
81 /* > \verbatim */
82 /* > TAU is REAL */
83 /* > The value tau. */
84 /* > \endverbatim */
85 /* Authors: */
86 /* ======== */
87 /* > \author Univ. of Tennessee */
88 /* > \author Univ. of California Berkeley */
89 /* > \author Univ. of Colorado Denver */
90 /* > \author NAG Ltd. */
91 /* > \date September 2012 */
92 /* > \ingroup realOTHERauxiliary */
93 /* ===================================================================== */
94 /* Subroutine */
slarfg_(integer * n,real * alpha,real * x,integer * incx,real * tau)95 int slarfg_(integer *n, real *alpha, real *x, integer *incx, real *tau)
96 {
97 /* System generated locals */
98 integer i__1;
99 real r__1;
100 /* Builtin functions */
101 double r_sign(real *, real *);
102 /* Local variables */
103 integer j, knt;
104 real beta;
105 extern real snrm2_(integer *, real *, integer *);
106 extern /* Subroutine */
107 int sscal_(integer *, real *, real *, integer *);
108 real xnorm;
109 extern real slapy2_(real *, real *), slamch_(char *);
110 real safmin, rsafmn;
111 /* -- LAPACK auxiliary routine (version 3.4.2) -- */
112 /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
113 /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
114 /* September 2012 */
115 /* .. Scalar Arguments .. */
116 /* .. */
117 /* .. Array Arguments .. */
118 /* .. */
119 /* ===================================================================== */
120 /* .. Parameters .. */
121 /* .. */
122 /* .. Local Scalars .. */
123 /* .. */
124 /* .. External Functions .. */
125 /* .. */
126 /* .. Intrinsic Functions .. */
127 /* .. */
128 /* .. External Subroutines .. */
129 /* .. */
130 /* .. Executable Statements .. */
131 /* Parameter adjustments */
132 --x;
133 /* Function Body */
134 if (*n <= 1)
135 {
136 *tau = 0.f;
137 return 0;
138 }
139 i__1 = *n - 1;
140 xnorm = snrm2_(&i__1, &x[1], incx);
141 if (xnorm == 0.f)
142 {
143 /* H = I */
144 *tau = 0.f;
145 }
146 else
147 {
148 /* general case */
149 r__1 = slapy2_(alpha, &xnorm);
150 beta = -r_sign(&r__1, alpha);
151 safmin = slamch_("S") / slamch_("E");
152 knt = 0;
153 if (f2c_abs(beta) < safmin)
154 {
155 /* XNORM, BETA may be inaccurate;
156 scale X and recompute them */
157 rsafmn = 1.f / safmin;
158 L10:
159 ++knt;
160 i__1 = *n - 1;
161 sscal_(&i__1, &rsafmn, &x[1], incx);
162 beta *= rsafmn;
163 *alpha *= rsafmn;
164 if (f2c_abs(beta) < safmin)
165 {
166 goto L10;
167 }
168 /* New BETA is at most 1, at least SAFMIN */
169 i__1 = *n - 1;
170 xnorm = snrm2_(&i__1, &x[1], incx);
171 r__1 = slapy2_(alpha, &xnorm);
172 beta = -r_sign(&r__1, alpha);
173 }
174 *tau = (beta - *alpha) / beta;
175 i__1 = *n - 1;
176 r__1 = 1.f / (*alpha - beta);
177 sscal_(&i__1, &r__1, &x[1], incx);
178 /* If ALPHA is subnormal, it may lose relative accuracy */
179 i__1 = knt;
180 for (j = 1;
181 j <= i__1;
182 ++j)
183 {
184 beta *= safmin;
185 /* L20: */
186 }
187 *alpha = beta;
188 }
189 return 0;
190 /* End of SLARFG */
191 }
192 /* slarfg_ */
193