Annotation of rpl/lapack/lapack/dlartgp.f, revision 1.14
1.7 bertrand 1: *> \brief \b DLARTGP generates a plane rotation so that the diagonal is nonnegative.
1.4 bertrand 2: *
3: * =========== DOCUMENTATION ===========
4: *
1.11 bertrand 5: * Online html documentation available at
6: * http://www.netlib.org/lapack/explore-html/
1.4 bertrand 7: *
8: *> \htmlonly
1.11 bertrand 9: *> Download DLARTGP + dependencies
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">
1.4 bertrand 15: *> [TXT]</a>
1.11 bertrand 16: *> \endhtmlonly
1.4 bertrand 17: *
18: * Definition:
19: * ===========
20: *
21: * SUBROUTINE DLARTGP( F, G, CS, SN, R )
1.11 bertrand 22: *
1.4 bertrand 23: * .. Scalar Arguments ..
24: * DOUBLE PRECISION CS, F, G, R, SN
25: * ..
1.11 bertrand 26: *
1.4 bertrand 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: *
1.11 bertrand 86: *> \author Univ. of Tennessee
87: *> \author Univ. of California Berkeley
88: *> \author Univ. of Colorado Denver
89: *> \author NAG Ltd.
1.4 bertrand 90: *
1.11 bertrand 91: *> \ingroup OTHERauxiliary
1.4 bertrand 92: *
93: * =====================================================================
1.1 bertrand 94: SUBROUTINE DLARTGP( F, G, CS, SN, R )
95: *
1.14 ! bertrand 96: * -- LAPACK auxiliary routine --
1.1 bertrand 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 ) )
1.14 ! bertrand 161: IF( SCALE.GE.SAFMX2 .AND. COUNT .LT. 20 )
1.1 bertrand 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
CVSweb interface <joel.bertrand@systella.fr>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to dlartgp.f CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [local] / rpl / lapack / lapack