LAPACK  3.5.0
LAPACK: Linear Algebra PACKage
 All Classes Files Functions Variables Typedefs Macros
slartg.f
Go to the documentation of this file.
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