1*> \brief \b ZLARFG
2*
3*  =========== DOCUMENTATION ===========
4*
5* Online html documentation available at
6*            http://www.netlib.org/lapack/explore-html/
7*
8*> \htmlonly
9*> Download ZLARFG + dependencies
10*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlarfg.f">
11*> [TGZ]</a>
12*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlarfg.f">
13*> [ZIP]</a>
14*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlarfg.f">
15*> [TXT]</a>
16*> \endhtmlonly
17*
18*  Definition:
19*  ===========
20*
21*       SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU )
22*
23*       .. Scalar Arguments ..
24*       INTEGER            INCX, N
25*       COMPLEX*16         ALPHA, TAU
26*       ..
27*       .. Array Arguments ..
28*       COMPLEX*16         X( * )
29*       ..
30*
31*
32*> \par Purpose:
33*  =============
34*>
35*> \verbatim
36*>
37*> ZLARFG 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*16
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*16 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*16
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 November 2011
103*
104*> \ingroup complex16OTHERauxiliary
105*
106*  =====================================================================
107      SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU )
108*
109*  -- LAPACK auxiliary routine (version 3.4.0) --
110*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
111*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
112*     November 2011
113*
114*     .. Scalar Arguments ..
115      INTEGER            INCX, N
116      COMPLEX*16         ALPHA, TAU
117*     ..
118*     .. Array Arguments ..
119      COMPLEX*16         X( * )
120*     ..
121*
122*  =====================================================================
123*
124*     .. Parameters ..
125      DOUBLE PRECISION   ONE, ZERO
126      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
127*     ..
128*     .. Local Scalars ..
129      INTEGER            J, KNT
130      DOUBLE PRECISION   ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM
131*     ..
132*     .. External Functions ..
133      DOUBLE PRECISION   DLAMCH, DLAPY3, DZNRM2
134      COMPLEX*16         ZLADIV
135      EXTERNAL           DLAMCH, DLAPY3, DZNRM2, ZLADIV
136*     ..
137*     .. Intrinsic Functions ..
138      INTRINSIC          ABS, DBLE, DCMPLX, DIMAG, SIGN
139*     ..
140*     .. External Subroutines ..
141      EXTERNAL           ZDSCAL, ZSCAL
142*     ..
143*     .. Executable Statements ..
144*
145      IF( N.LE.0 ) THEN
146         TAU = ZERO
147         RETURN
148      END IF
149*
150      XNORM = DZNRM2( N-1, X, INCX )
151      ALPHR = DBLE( ALPHA )
152      ALPHI = DIMAG( 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( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
164         SAFMIN = DLAMCH( 'S' ) / DLAMCH( '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 ZDSCAL( 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 = DZNRM2( N-1, X, INCX )
184            ALPHA = DCMPLX( ALPHR, ALPHI )
185            BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
186         END IF
187         TAU = DCMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA )
188         ALPHA = ZLADIV( DCMPLX( ONE ), ALPHA-BETA )
189         CALL ZSCAL( 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 ZLARFG
202*
203      END
204