LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
clarfg.f
Go to the documentation of this file.
1 *> \brief \b CLARFG generates an elementary reflector (Householder matrix).
2 *
3 * =========== DOCUMENTATION ===========
4 *
5 * Online html documentation available at
6 * http://www.netlib.org/lapack/explore-html/
7 *
8 *> \htmlonly
9 *> Download CLARFG + dependencies
10 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/clarfg.f">
11 *> [TGZ]</a>
12 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/clarfg.f">
13 *> [ZIP]</a>
14 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/clarfg.f">
15 *> [TXT]</a>
16 *> \endhtmlonly
17 *
18 * Definition:
19 * ===========
20 *
21 * SUBROUTINE CLARFG( N, ALPHA, X, INCX, TAU )
22 *
23 * .. Scalar Arguments ..
24 * INTEGER INCX, N
25 * COMPLEX ALPHA, TAU
26 * ..
27 * .. Array Arguments ..
28 * COMPLEX X( * )
29 * ..
30 *
31 *
32 *> \par Purpose:
33 * =============
34 *>
35 *> \verbatim
36 *>
37 *> CLARFG generates a complex elementary reflector H of order n, such
38 *> that
39 *>
40 *> H**H * ( alpha ) = ( beta ), H**H * H = I.
41 *> ( x ) ( 0 )
42 *>
43 *> where alpha and beta are scalars, with beta real, and x is an
44 *> (n-1)-element complex vector. H is represented in the form
45 *>
46 *> H = I - tau * ( 1 ) * ( 1 v**H ) ,
47 *> ( v )
48 *>
49 *> where tau is a complex scalar and v is a complex (n-1)-element
50 *> vector. Note that H is not hermitian.
51 *>
52 *> If the elements of x are all zero and alpha is real, then tau = 0
53 *> and H is taken to be the unit matrix.
54 *>
55 *> Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 .
56 *> \endverbatim
57 *
58 * Arguments:
59 * ==========
60 *
61 *> \param[in] N
62 *> \verbatim
63 *> N is INTEGER
64 *> The order of the elementary reflector.
65 *> \endverbatim
66 *>
67 *> \param[in,out] ALPHA
68 *> \verbatim
69 *> ALPHA is COMPLEX
70 *> On entry, the value alpha.
71 *> On exit, it is overwritten with the value beta.
72 *> \endverbatim
73 *>
74 *> \param[in,out] X
75 *> \verbatim
76 *> X is COMPLEX array, dimension
77 *> (1+(N-2)*abs(INCX))
78 *> On entry, the vector x.
79 *> On exit, it is overwritten with the vector v.
80 *> \endverbatim
81 *>
82 *> \param[in] INCX
83 *> \verbatim
84 *> INCX is INTEGER
85 *> The increment between elements of X. INCX > 0.
86 *> \endverbatim
87 *>
88 *> \param[out] TAU
89 *> \verbatim
90 *> TAU is COMPLEX
91 *> The value tau.
92 *> \endverbatim
93 *
94 * Authors:
95 * ========
96 *
97 *> \author Univ. of Tennessee
98 *> \author Univ. of California Berkeley
99 *> \author Univ. of Colorado Denver
100 *> \author NAG Ltd.
101 *
102 *> \date September 2012
103 *
104 *> \ingroup complexOTHERauxiliary
105 *
106 * =====================================================================
107  SUBROUTINE clarfg( N, ALPHA, X, INCX, TAU )
108 *
109 * -- LAPACK auxiliary routine (version 3.4.2) --
110 * -- LAPACK is a software package provided by Univ. of Tennessee, --
111 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
112 * September 2012
113 *
114 * .. Scalar Arguments ..
115  INTEGER incx, n
116  COMPLEX alpha, tau
117 * ..
118 * .. Array Arguments ..
119  COMPLEX x( * )
120 * ..
121 *
122 * =====================================================================
123 *
124 * .. Parameters ..
125  REAL one, zero
126  parameter( one = 1.0e+0, zero = 0.0e+0 )
127 * ..
128 * .. Local Scalars ..
129  INTEGER j, knt
130  REAL alphi, alphr, beta, rsafmn, safmin, xnorm
131 * ..
132 * .. External Functions ..
133  REAL scnrm2, slamch, slapy3
134  COMPLEX cladiv
135  EXTERNAL scnrm2, slamch, slapy3, cladiv
136 * ..
137 * .. Intrinsic Functions ..
138  INTRINSIC abs, aimag, cmplx, REAL, sign
139 * ..
140 * .. External Subroutines ..
141  EXTERNAL cscal, csscal
142 * ..
143 * .. Executable Statements ..
144 *
145  IF( n.LE.0 ) THEN
146  tau = zero
147  return
148  END IF
149 *
150  xnorm = scnrm2( n-1, x, incx )
151  alphr = REAL( alpha )
152  alphi = aimag( alpha )
153 *
154  IF( xnorm.EQ.zero .AND. alphi.EQ.zero ) THEN
155 *
156 * H = I
157 *
158  tau = zero
159  ELSE
160 *
161 * general case
162 *
163  beta = -sign( slapy3( alphr, alphi, xnorm ), alphr )
164  safmin = slamch( 'S' ) / slamch( 'E' )
165  rsafmn = one / safmin
166 *
167  knt = 0
168  IF( abs( beta ).LT.safmin ) THEN
169 *
170 * XNORM, BETA may be inaccurate; scale X and recompute them
171 *
172  10 continue
173  knt = knt + 1
174  CALL csscal( n-1, rsafmn, x, incx )
175  beta = beta*rsafmn
176  alphi = alphi*rsafmn
177  alphr = alphr*rsafmn
178  IF( abs( beta ).LT.safmin )
179  $ go to 10
180 *
181 * New BETA is at most 1, at least SAFMIN
182 *
183  xnorm = scnrm2( n-1, x, incx )
184  alpha = cmplx( alphr, alphi )
185  beta = -sign( slapy3( alphr, alphi, xnorm ), alphr )
186  END IF
187  tau = cmplx( ( beta-alphr ) / beta, -alphi / beta )
188  alpha = cladiv( cmplx( one ), alpha-beta )
189  CALL cscal( n-1, alpha, x, incx )
190 *
191 * If ALPHA is subnormal, it may lose relative accuracy
192 *
193  DO 20 j = 1, knt
194  beta = beta*safmin
195  20 continue
196  alpha = beta
197  END IF
198 *
199  return
200 *
201 * End of CLARFG
202 *
203  END