1*> \brief \b SLARTG generates a plane rotation with real cosine and real sine.
2*
3*  =========== DOCUMENTATION ===========
4*
5* Online html documentation available at
6*            http://www.netlib.org/lapack/explore-html/
7*
8*> \htmlonly
9*> Download SLARTG + dependencies
10*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slartg.f">
11*> [TGZ]</a>
12*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slartg.f">
13*> [ZIP]</a>
14*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slartg.f">
15*> [TXT]</a>
16*> \endhtmlonly
17*
18*  Definition:
19*  ===========
20*
21*       SUBROUTINE SLARTG( F, G, CS, SN, R )
22*
23*       .. Scalar Arguments ..
24*       REAL               CS, F, G, R, SN
25*       ..
26*
27*
28*> \par Purpose:
29*  =============
30*>
31*> \verbatim
32*>
33*> SLARTG generate a plane rotation so that
34*>
35*>    [  CS  SN  ]  .  [ F ]  =  [ R ]   where CS**2 + SN**2 = 1.
36*>    [ -SN  CS  ]     [ G ]     [ 0 ]
37*>
38*> This is a slower, more accurate version of the BLAS1 routine SROTG,
39*> with the following other differences:
40*>    F and G are unchanged on return.
41*>    If G=0, then CS=1 and SN=0.
42*>    If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any
43*>       floating point operations (saves work in SBDSQR when
44*>       there are zeros on the diagonal).
45*>
46*> If F exceeds G in magnitude, CS will be positive.
47*> \endverbatim
48*
49*  Arguments:
50*  ==========
51*
52*> \param[in] F
53*> \verbatim
54*>          F is REAL
55*>          The first component of vector to be rotated.
56*> \endverbatim
57*>
58*> \param[in] G
59*> \verbatim
60*>          G is REAL
61*>          The second component of vector to be rotated.
62*> \endverbatim
63*>
64*> \param[out] CS
65*> \verbatim
66*>          CS is REAL
67*>          The cosine of the rotation.
68*> \endverbatim
69*>
70*> \param[out] SN
71*> \verbatim
72*>          SN is REAL
73*>          The sine of the rotation.
74*> \endverbatim
75*>
76*> \param[out] R
77*> \verbatim
78*>          R is REAL
79*>          The nonzero component of the rotated vector.
80*>
81*>  This version has a few statements commented out for thread safety
82*>  (machine parameters are computed on each entry). 10 feb 03, SJH.
83*> \endverbatim
84*
85*  Authors:
86*  ========
87*
88*> \author Univ. of Tennessee
89*> \author Univ. of California Berkeley
90*> \author Univ. of Colorado Denver
91*> \author NAG Ltd.
92*
93*> \date September 2012
94*
95*> \ingroup auxOTHERauxiliary
96*
97*  =====================================================================
98      SUBROUTINE SLARTG( F, G, CS, SN, R )
99*
100*  -- LAPACK auxiliary routine (version 3.4.2) --
101*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
102*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
103*     September 2012
104*
105*     .. Scalar Arguments ..
106      REAL               CS, F, G, R, SN
107*     ..
108*
109*  =====================================================================
110*
111*     .. Parameters ..
112      REAL               ZERO
113      PARAMETER          ( ZERO = 0.0E0 )
114      REAL               ONE
115      PARAMETER          ( ONE = 1.0E0 )
116      REAL               TWO
117      PARAMETER          ( TWO = 2.0E0 )
118*     ..
119*     .. Local Scalars ..
120*     LOGICAL            FIRST
121      INTEGER            COUNT, I
122      REAL               EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE
123*     ..
124*     .. External Functions ..
125      REAL               SLAMCH
126      EXTERNAL           SLAMCH
127*     ..
128*     .. Intrinsic Functions ..
129      INTRINSIC          ABS, INT, LOG, MAX, SQRT
130*     ..
131*     .. Save statement ..
132*     SAVE               FIRST, SAFMX2, SAFMIN, SAFMN2
133*     ..
134*     .. Data statements ..
135*     DATA               FIRST / .TRUE. /
136*     ..
137*     .. Executable Statements ..
138*
139*     IF( FIRST ) THEN
140         SAFMIN = SLAMCH( 'S' )
141         EPS = SLAMCH( 'E' )
142         SAFMN2 = SLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) /
143     $            LOG( SLAMCH( 'B' ) ) / TWO )
144         SAFMX2 = ONE / SAFMN2
145*        FIRST = .FALSE.
146*     END IF
147      IF( G.EQ.ZERO ) THEN
148         CS = ONE
149         SN = ZERO
150         R = F
151      ELSE IF( F.EQ.ZERO ) THEN
152         CS = ZERO
153         SN = ONE
154         R = G
155      ELSE
156         F1 = F
157         G1 = G
158         SCALE = MAX( ABS( F1 ), ABS( G1 ) )
159         IF( SCALE.GE.SAFMX2 ) THEN
160            COUNT = 0
161   10       CONTINUE
162            COUNT = COUNT + 1
163            F1 = F1*SAFMN2
164            G1 = G1*SAFMN2
165            SCALE = MAX( ABS( F1 ), ABS( G1 ) )
166            IF( SCALE.GE.SAFMX2 )
167     $         GO TO 10
168            R = SQRT( F1**2+G1**2 )
169            CS = F1 / R
170            SN = G1 / R
171            DO 20 I = 1, COUNT
172               R = R*SAFMX2
173   20       CONTINUE
174         ELSE IF( SCALE.LE.SAFMN2 ) THEN
175            COUNT = 0
176   30       CONTINUE
177            COUNT = COUNT + 1
178            F1 = F1*SAFMX2
179            G1 = G1*SAFMX2
180            SCALE = MAX( ABS( F1 ), ABS( G1 ) )
181            IF( SCALE.LE.SAFMN2 )
182     $         GO TO 30
183            R = SQRT( F1**2+G1**2 )
184            CS = F1 / R
185            SN = G1 / R
186            DO 40 I = 1, COUNT
187               R = R*SAFMN2
188   40       CONTINUE
189         ELSE
190            R = SQRT( F1**2+G1**2 )
191            CS = F1 / R
192            SN = G1 / R
193         END IF
194         IF( ABS( F ).GT.ABS( G ) .AND. CS.LT.ZERO ) THEN
195            CS = -CS
196            SN = -SN
197            R = -R
198         END IF
199      END IF
200      RETURN
201*
202*     End of SLARTG
203*
204      END
205