slarfg.f revision 7faaa9f3f0df9d23790277834d426c3d992ac3ba 
1*> \brief \b SLARFG
2*
3*  =========== DOCUMENTATION ===========
4*
5* Online html documentation available at
6*            http://www.netlib.org/lapack/explore-html/
7*
8*> \htmlonly
9*> Download SLARFG + dependencies
10*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slarfg.f">
11*> [TGZ]</a>
12*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slarfg.f">
13*> [ZIP]</a>
14*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slarfg.f">
15*> [TXT]</a>
16*> \endhtmlonly
17*
18*  Definition:
19*  ===========
20*
21*       SUBROUTINE SLARFG( N, ALPHA, X, INCX, TAU )
22*
23*       .. Scalar Arguments ..
24*       INTEGER            INCX, N
25*       REAL               ALPHA, TAU
26*       ..
27*       .. Array Arguments ..
28*       REAL               X( * )
29*       ..
30*
31*
32*> \par Purpose:
33*  =============
34*>
35*> \verbatim
36*>
37*> SLARFG generates a real elementary reflector H of order n, such
38*> that
39*>
40*>       H * ( alpha ) = ( beta ),   H**T * H = I.
41*>           (   x   )   (   0  )
42*>
43*> where alpha and beta are scalars, and x is an (n-1)-element real
44*> vector. H is represented in the form
45*>
46*>       H = I - tau * ( 1 ) * ( 1 v**T ) ,
47*>                     ( v )
48*>
49*> where tau is a real scalar and v is a real (n-1)-element
50*> vector.
51*>
52*> If the elements of x are all zero, then tau = 0 and H is taken to be
53*> the unit matrix.
54*>
55*> Otherwise  1 <= tau <= 2.
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 REAL
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 REAL 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 REAL
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 realOTHERauxiliary
105*
106*  =====================================================================
107      SUBROUTINE SLARFG( 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      REAL               ALPHA, TAU
117*     ..
118*     .. Array Arguments ..
119      REAL               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               BETA, RSAFMN, SAFMIN, XNORM
131*     ..
132*     .. External Functions ..
133      REAL               SLAMCH, SLAPY2, SNRM2
134      EXTERNAL           SLAMCH, SLAPY2, SNRM2
135*     ..
136*     .. Intrinsic Functions ..
137      INTRINSIC          ABS, SIGN
138*     ..
139*     .. External Subroutines ..
140      EXTERNAL           SSCAL
141*     ..
142*     .. Executable Statements ..
143*
144      IF( N.LE.1 ) THEN
145         TAU = ZERO
146         RETURN
147      END IF
148*
149      XNORM = SNRM2( N-1, X, INCX )
150*
151      IF( XNORM.EQ.ZERO ) THEN
152*
153*        H  =  I
154*
155         TAU = ZERO
156      ELSE
157*
158*        general case
159*
160         BETA = -SIGN( SLAPY2( ALPHA, XNORM ), ALPHA )
161         SAFMIN = SLAMCH( 'S' ) / SLAMCH( 'E' )
162         KNT = 0
163         IF( ABS( BETA ).LT.SAFMIN ) THEN
164*
165*           XNORM, BETA may be inaccurate; scale X and recompute them
166*
167            RSAFMN = ONE / SAFMIN
168   10       CONTINUE
169            KNT = KNT + 1
170            CALL SSCAL( N-1, RSAFMN, X, INCX )
171            BETA = BETA*RSAFMN
172            ALPHA = ALPHA*RSAFMN
173            IF( ABS( BETA ).LT.SAFMIN )
174     $         GO TO 10
175*
176*           New BETA is at most 1, at least SAFMIN
177*
178            XNORM = SNRM2( N-1, X, INCX )
179            BETA = -SIGN( SLAPY2( ALPHA, XNORM ), ALPHA )
180         END IF
181         TAU = ( BETA-ALPHA ) / BETA
182         CALL SSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX )
183*
184*        If ALPHA is subnormal, it may lose relative accuracy
185*
186         DO 20 J = 1, KNT
187            BETA = BETA*SAFMIN
188 20      CONTINUE
189         ALPHA = BETA
190      END IF
191*
192      RETURN
193*
194*     End of SLARFG
195*
196      END
197