Annotation of rpl/lapack/lapack/dlartgp.f, revision 1.11
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: *> \date December 2016
1.4 bertrand 92: *
1.11 ! bertrand 93: *> \ingroup OTHERauxiliary
1.4 bertrand 94: *
95: * =====================================================================
1.1 bertrand 96: SUBROUTINE DLARTGP( F, G, CS, SN, R )
97: *
1.11 ! bertrand 98: * -- LAPACK auxiliary routine (version 3.7.0) --
1.1 bertrand 99: * -- LAPACK is a software package provided by Univ. of Tennessee, --
100: * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
1.11 ! bertrand 101: * December 2016
1.1 bertrand 102: *
103: * .. Scalar Arguments ..
104: DOUBLE PRECISION CS, F, G, R, SN
105: * ..
106: *
107: * =====================================================================
108: *
109: * .. Parameters ..
110: DOUBLE PRECISION ZERO
111: PARAMETER ( ZERO = 0.0D0 )
112: DOUBLE PRECISION ONE
113: PARAMETER ( ONE = 1.0D0 )
114: DOUBLE PRECISION TWO
115: PARAMETER ( TWO = 2.0D0 )
116: * ..
117: * .. Local Scalars ..
118: * LOGICAL FIRST
119: INTEGER COUNT, I
120: DOUBLE PRECISION EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE
121: * ..
122: * .. External Functions ..
123: DOUBLE PRECISION DLAMCH
124: EXTERNAL DLAMCH
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 = DLAMCH( 'S' )
139: EPS = DLAMCH( 'E' )
140: SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) /
141: $ LOG( DLAMCH( '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 DLARTGP
201: *
202: 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