LAPACK  3.10.1 LAPACK: Linear Algebra PACKage
dlartgp.f
Go to the documentation of this file.
1 *> \brief \b DLARTGP 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
10 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlartgp.f">
11 *> [TGZ]</a>
12 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlartgp.f">
13 *> [ZIP]</a>
14 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlartgp.f">
15 *> [TXT]</a>
16 *> \endhtmlonly
17 *
18 * Definition:
19 * ===========
20 *
21 * SUBROUTINE DLARTGP( F, G, CS, SN, R )
22 *
23 * .. Scalar Arguments ..
24 * DOUBLE PRECISION CS, F, G, R, SN
25 * ..
26 *
27 *
28 *> \par Purpose:
29 * =============
30 *>
31 *> \verbatim
32 *>
33 *> DLARTGP 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 DROTG,
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 DOUBLE PRECISION
53 *> The first component of vector to be rotated.
54 *> \endverbatim
55 *>
56 *> \param[in] G
57 *> \verbatim
58 *> G is DOUBLE PRECISION
59 *> The second component of vector to be rotated.
60 *> \endverbatim
61 *>
62 *> \param[out] CS
63 *> \verbatim
64 *> CS is DOUBLE PRECISION
65 *> The cosine of the rotation.
66 *> \endverbatim
67 *>
68 *> \param[out] SN
69 *> \verbatim
70 *> SN is DOUBLE PRECISION
71 *> The sine of the rotation.
72 *> \endverbatim
73 *>
74 *> \param[out] R
75 *> \verbatim
76 *> R is DOUBLE PRECISION
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 *> \ingroup OTHERauxiliary
92 *
93 * =====================================================================
94  SUBROUTINE dlartgp( F, G, CS, SN, R )
95 *
96 * -- LAPACK auxiliary routine --
97 * -- LAPACK is a software package provided by Univ. of Tennessee, --
98 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
99 *
100 * .. Scalar Arguments ..
101  DOUBLE PRECISION CS, F, G, R, SN
102 * ..
103 *
104 * =====================================================================
105 *
106 * .. Parameters ..
107  DOUBLE PRECISION ZERO
108  parameter( zero = 0.0d0 )
109  DOUBLE PRECISION ONE
110  parameter( one = 1.0d0 )
111  DOUBLE PRECISION TWO
112  parameter( two = 2.0d0 )
113 * ..
114 * .. Local Scalars ..
115 * LOGICAL FIRST
116  INTEGER COUNT, I
117  DOUBLE PRECISION EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE
118 * ..
119 * .. External Functions ..
120  DOUBLE PRECISION DLAMCH
121  EXTERNAL dlamch
122 * ..
123 * .. Intrinsic Functions ..
124  INTRINSIC abs, int, log, max, sign, sqrt
125 * ..
126 * .. Save statement ..
127 * SAVE FIRST, SAFMX2, SAFMIN, SAFMN2
128 * ..
129 * .. Data statements ..
130 * DATA FIRST / .TRUE. /
131 * ..
132 * .. Executable Statements ..
133 *
134 * IF( FIRST ) THEN
135  safmin = dlamch( 'S' )
136  eps = dlamch( 'E' )
137  safmn2 = dlamch( 'B' )**int( log( safmin / eps ) /
138  \$ log( dlamch( 'B' ) ) / two )
139  safmx2 = one / safmn2
140 * FIRST = .FALSE.
141 * END IF
142  IF( g.EQ.zero ) THEN
143  cs = sign( one, f )
144  sn = zero
145  r = abs( f )
146  ELSE IF( f.EQ.zero ) THEN
147  cs = zero
148  sn = sign( one, g )
149  r = abs( g )
150  ELSE
151  f1 = f
152  g1 = g
153  scale = max( abs( f1 ), abs( g1 ) )
154  IF( scale.GE.safmx2 ) THEN
155  count = 0
156  10 CONTINUE
157  count = count + 1
158  f1 = f1*safmn2
159  g1 = g1*safmn2
160  scale = max( abs( f1 ), abs( g1 ) )
161  IF( scale.GE.safmx2 .AND. count .LT. 20 )
162  \$ GO TO 10
163  r = sqrt( f1**2+g1**2 )
164  cs = f1 / r
165  sn = g1 / r
166  DO 20 i = 1, count
167  r = r*safmx2
168  20 CONTINUE
169  ELSE IF( scale.LE.safmn2 ) THEN
170  count = 0
171  30 CONTINUE
172  count = count + 1
173  f1 = f1*safmx2
174  g1 = g1*safmx2
175  scale = max( abs( f1 ), abs( g1 ) )
176  IF( scale.LE.safmn2 )
177  \$ GO TO 30
178  r = sqrt( f1**2+g1**2 )
179  cs = f1 / r
180  sn = g1 / r
181  DO 40 i = 1, count
182  r = r*safmn2
183  40 CONTINUE
184  ELSE
185  r = sqrt( f1**2+g1**2 )
186  cs = f1 / r
187  sn = g1 / r
188  END IF
189  IF( r.LT.zero ) THEN
190  cs = -cs
191  sn = -sn
192  r = -r
193  END IF
194  END IF
195  RETURN
196 *
197 * End of DLARTGP
198 *
199  END
subroutine dlartgp(F, G, CS, SN, R)
DLARTGP generates a plane rotation so that the diagonal is nonnegative.
Definition: dlartgp.f:95