LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
slartgp.f
Go to the documentation of this file.
1 *> \brief \b SLARTGP generates a plane rotation so that the diagonal is nonnegative.
2 *
3 * =========== DOCUMENTATION ===========
4 *
5 * Online html documentation available at
6 * http://www.netlib.org/lapack/explore-html/
7 *
8 *> \htmlonly
9 *> Download SLARTGP + dependencies
10 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slartgp.f">
11 *> [TGZ]</a>
12 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slartgp.f">
13 *> [ZIP]</a>
14 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slartgp.f">
15 *> [TXT]</a>
16 *> \endhtmlonly
17 *
18 * Definition:
19 * ===========
20 *
21 * SUBROUTINE SLARTGP( 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 *> SLARTGP generates 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 Level 1 BLAS 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.
43 *>
44 *> The sign is chosen so that R >= 0.
45 *> \endverbatim
46 *
47 * Arguments:
48 * ==========
49 *
50 *> \param[in] F
51 *> \verbatim
52 *> F is REAL
53 *> The first component of vector to be rotated.
54 *> \endverbatim
55 *>
56 *> \param[in] G
57 *> \verbatim
58 *> G is REAL
59 *> The second component of vector to be rotated.
60 *> \endverbatim
61 *>
62 *> \param[out] CS
63 *> \verbatim
64 *> CS is REAL
65 *> The cosine of the rotation.
66 *> \endverbatim
67 *>
68 *> \param[out] SN
69 *> \verbatim
70 *> SN is REAL
71 *> The sine of the rotation.
72 *> \endverbatim
73 *>
74 *> \param[out] R
75 *> \verbatim
76 *> R is REAL
77 *> The nonzero component of the rotated vector.
78 *>
79 *> This version has a few statements commented out for thread safety
80 *> (machine parameters are computed on each entry). 10 feb 03, SJH.
81 *> \endverbatim
82 *
83 * Authors:
84 * ========
85 *
86 *> \author Univ. of Tennessee
87 *> \author Univ. of California Berkeley
88 *> \author Univ. of Colorado Denver
89 *> \author NAG Ltd.
90 *
91 *> \date September 2012
92 *
93 *> \ingroup auxOTHERauxiliary
94 *
95 * =====================================================================
96  SUBROUTINE slartgp( F, G, CS, SN, R )
97 *
98 * -- LAPACK auxiliary routine (version 3.4.2) --
99 * -- LAPACK is a software package provided by Univ. of Tennessee, --
100 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
101 * September 2012
102 *
103 * .. Scalar Arguments ..
104  REAL cs, f, g, r, sn
105 * ..
106 *
107 * =====================================================================
108 *
109 * .. Parameters ..
110  REAL zero
111  parameter( zero = 0.0e0 )
112  REAL one
113  parameter( one = 1.0e0 )
114  REAL two
115  parameter( two = 2.0e0 )
116 * ..
117 * .. Local Scalars ..
118 * LOGICAL FIRST
119  INTEGER count, i
120  REAL eps, f1, g1, safmin, safmn2, safmx2, scale
121 * ..
122 * .. External Functions ..
123  REAL slamch
124  EXTERNAL slamch
125 * ..
126 * .. Intrinsic Functions ..
127  INTRINSIC abs, int, log, max, sign, sqrt
128 * ..
129 * .. Save statement ..
130 * SAVE FIRST, SAFMX2, SAFMIN, SAFMN2
131 * ..
132 * .. Data statements ..
133 * DATA FIRST / .TRUE. /
134 * ..
135 * .. Executable Statements ..
136 *
137 * IF( FIRST ) THEN
138  safmin = slamch( 'S' )
139  eps = slamch( 'E' )
140  safmn2 = slamch( 'B' )**int( log( safmin / eps ) /
141  $ log( slamch( 'B' ) ) / two )
142  safmx2 = one / safmn2
143 * FIRST = .FALSE.
144 * END IF
145  IF( g.EQ.zero ) THEN
146  cs = sign( one, f )
147  sn = zero
148  r = abs( f )
149  ELSE IF( f.EQ.zero ) THEN
150  cs = zero
151  sn = sign( one, g )
152  r = abs( g )
153  ELSE
154  f1 = f
155  g1 = g
156  scale = max( abs( f1 ), abs( g1 ) )
157  IF( scale.GE.safmx2 ) THEN
158  count = 0
159  10 continue
160  count = count + 1
161  f1 = f1*safmn2
162  g1 = g1*safmn2
163  scale = max( abs( f1 ), abs( g1 ) )
164  IF( scale.GE.safmx2 )
165  $ go to 10
166  r = sqrt( f1**2+g1**2 )
167  cs = f1 / r
168  sn = g1 / r
169  DO 20 i = 1, count
170  r = r*safmx2
171  20 continue
172  ELSE IF( scale.LE.safmn2 ) THEN
173  count = 0
174  30 continue
175  count = count + 1
176  f1 = f1*safmx2
177  g1 = g1*safmx2
178  scale = max( abs( f1 ), abs( g1 ) )
179  IF( scale.LE.safmn2 )
180  $ go to 30
181  r = sqrt( f1**2+g1**2 )
182  cs = f1 / r
183  sn = g1 / r
184  DO 40 i = 1, count
185  r = r*safmn2
186  40 continue
187  ELSE
188  r = sqrt( f1**2+g1**2 )
189  cs = f1 / r
190  sn = g1 / r
191  END IF
192  IF( r.LT.zero ) THEN
193  cs = -cs
194  sn = -sn
195  r = -r
196  END IF
197  END IF
198  return
199 *
200 * End of SLARTG
201 *
202  END