File:
[local] /
rpl /
lapack /
lapack /
dlartg.f
Revision
1.17:
download - view:
text,
annotated -
select for diffs -
revision graph
Tue May 29 07:17:59 2018 UTC (5 years, 11 months ago) by
bertrand
Branches:
MAIN
CVS tags:
rpl-4_1_35,
rpl-4_1_34,
rpl-4_1_33,
rpl-4_1_32,
rpl-4_1_31,
rpl-4_1_30,
rpl-4_1_29,
rpl-4_1_28,
HEAD
Mise à jour de Lapack.
1: *> \brief \b DLARTG 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 DLARTG + dependencies
10: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlartg.f">
11: *> [TGZ]</a>
12: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlartg.f">
13: *> [ZIP]</a>
14: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlartg.f">
15: *> [TXT]</a>
16: *> \endhtmlonly
17: *
18: * Definition:
19: * ===========
20: *
21: * SUBROUTINE DLARTG( 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: *> DLARTG 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 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 without doing any
43: *> floating point operations (saves work in DBDSQR 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 DOUBLE PRECISION
55: *> The first component of vector to be rotated.
56: *> \endverbatim
57: *>
58: *> \param[in] G
59: *> \verbatim
60: *> G is DOUBLE PRECISION
61: *> The second component of vector to be rotated.
62: *> \endverbatim
63: *>
64: *> \param[out] CS
65: *> \verbatim
66: *> CS is DOUBLE PRECISION
67: *> The cosine of the rotation.
68: *> \endverbatim
69: *>
70: *> \param[out] SN
71: *> \verbatim
72: *> SN is DOUBLE PRECISION
73: *> The sine of the rotation.
74: *> \endverbatim
75: *>
76: *> \param[out] R
77: *> \verbatim
78: *> R is DOUBLE PRECISION
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 December 2016
94: *
95: *> \ingroup OTHERauxiliary
96: *
97: * =====================================================================
98: SUBROUTINE DLARTG( F, G, CS, SN, R )
99: *
100: * -- LAPACK auxiliary routine (version 3.7.0) --
101: * -- LAPACK is a software package provided by Univ. of Tennessee, --
102: * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
103: * December 2016
104: *
105: * .. Scalar Arguments ..
106: DOUBLE PRECISION CS, F, G, R, SN
107: * ..
108: *
109: * =====================================================================
110: *
111: * .. Parameters ..
112: DOUBLE PRECISION ZERO
113: PARAMETER ( ZERO = 0.0D0 )
114: DOUBLE PRECISION ONE
115: PARAMETER ( ONE = 1.0D0 )
116: DOUBLE PRECISION TWO
117: PARAMETER ( TWO = 2.0D0 )
118: * ..
119: * .. Local Scalars ..
120: * LOGICAL FIRST
121: INTEGER COUNT, I
122: DOUBLE PRECISION EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE
123: * ..
124: * .. External Functions ..
125: DOUBLE PRECISION DLAMCH
126: EXTERNAL DLAMCH
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 = DLAMCH( 'S' )
141: EPS = DLAMCH( 'E' )
142: SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) /
143: $ LOG( DLAMCH( '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 DLARTG
203: *
204: END
CVSweb interface <joel.bertrand@systella.fr>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to dlartg.f CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [local] / rpl / lapack / lapack