Annotation of rpl/lapack/lapack/dlartgp.f, revision 1.4
1.4 ! bertrand 1: *> \brief \b DLARTGP
! 2: *
! 3: * =========== DOCUMENTATION ===========
! 4: *
! 5: * Online html documentation available at
! 6: * http://www.netlib.org/lapack/explore-html/
! 7: *
! 8: *> \htmlonly
! 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">
! 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: *> \date November 2011
! 92: *
! 93: *> \ingroup auxOTHERauxiliary
! 94: *
! 95: * =====================================================================
1.1 bertrand 96: SUBROUTINE DLARTGP( F, G, CS, SN, R )
97: *
1.4 ! bertrand 98: * -- LAPACK auxiliary routine (version 3.4.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.4 ! bertrand 101: * November 2011
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