Annotation of rpl/lapack/lapack/dlartg.f, revision 1.8
1.8 ! bertrand 1: *> \brief \b DLARTG
! 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 November 2011
! 94: *
! 95: *> \ingroup auxOTHERauxiliary
! 96: *
! 97: * =====================================================================
1.1 bertrand 98: SUBROUTINE DLARTG( F, G, CS, SN, R )
99: *
1.8 ! bertrand 100: * -- LAPACK auxiliary routine (version 3.4.0) --
1.1 bertrand 101: * -- LAPACK is a software package provided by Univ. of Tennessee, --
102: * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
1.8 ! bertrand 103: * November 2011
1.1 bertrand 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>