![[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|
Return to dlartgp.f CVS log | Up to [local] / rpl / lapack / lapack |
1.1 bertrand 1: SUBROUTINE DLARTGP( F, G, CS, SN, R )
2: *
3: * Originally DLARTG
4: * -- LAPACK auxiliary routine (version 3.2) --
5: * -- LAPACK is a software package provided by Univ. of Tennessee, --
6: * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
7: * November 2006
8: *
9: * Adapted to DLARTGP
10: * July 2010
11: *
12: * .. Scalar Arguments ..
13: DOUBLE PRECISION CS, F, G, R, SN
14: * ..
15: *
16: * Purpose
17: * =======
18: *
19: * DLARTGP generates a plane rotation so that
20: *
21: * [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1.
22: * [ -SN CS ] [ G ] [ 0 ]
23: *
24: * This is a slower, more accurate version of the Level 1 BLAS routine DROTG,
25: * with the following other differences:
26: * F and G are unchanged on return.
27: * If G=0, then CS=(+/-)1 and SN=0.
28: * If F=0 and (G .ne. 0), then CS=0 and SN=(+/-)1.
29: *
30: * The sign is chosen so that R >= 0.
31: *
32: * Arguments
33: * =========
34: *
35: * F (input) DOUBLE PRECISION
36: * The first component of vector to be rotated.
37: *
38: * G (input) DOUBLE PRECISION
39: * The second component of vector to be rotated.
40: *
41: * CS (output) DOUBLE PRECISION
42: * The cosine of the rotation.
43: *
44: * SN (output) DOUBLE PRECISION
45: * The sine of the rotation.
46: *
47: * R (output) DOUBLE PRECISION
48: * The nonzero component of the rotated vector.
49: *
50: * This version has a few statements commented out for thread safety
51: * (machine parameters are computed on each entry). 10 feb 03, SJH.
52: *
53: * =====================================================================
54: *
55: * .. Parameters ..
56: DOUBLE PRECISION ZERO
57: PARAMETER ( ZERO = 0.0D0 )
58: DOUBLE PRECISION ONE
59: PARAMETER ( ONE = 1.0D0 )
60: DOUBLE PRECISION TWO
61: PARAMETER ( TWO = 2.0D0 )
62: * ..
63: * .. Local Scalars ..
64: * LOGICAL FIRST
65: INTEGER COUNT, I
66: DOUBLE PRECISION EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE
67: * ..
68: * .. External Functions ..
69: DOUBLE PRECISION DLAMCH
70: EXTERNAL DLAMCH
71: * ..
72: * .. Intrinsic Functions ..
73: INTRINSIC ABS, INT, LOG, MAX, SIGN, SQRT
74: * ..
75: * .. Save statement ..
76: * SAVE FIRST, SAFMX2, SAFMIN, SAFMN2
77: * ..
78: * .. Data statements ..
79: * DATA FIRST / .TRUE. /
80: * ..
81: * .. Executable Statements ..
82: *
83: * IF( FIRST ) THEN
84: SAFMIN = DLAMCH( 'S' )
85: EPS = DLAMCH( 'E' )
86: SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) /
87: $ LOG( DLAMCH( 'B' ) ) / TWO )
88: SAFMX2 = ONE / SAFMN2
89: * FIRST = .FALSE.
90: * END IF
91: IF( G.EQ.ZERO ) THEN
92: CS = SIGN( ONE, F )
93: SN = ZERO
94: R = ABS( F )
95: ELSE IF( F.EQ.ZERO ) THEN
96: CS = ZERO
97: SN = SIGN( ONE, G )
98: R = ABS( G )
99: ELSE
100: F1 = F
101: G1 = G
102: SCALE = MAX( ABS( F1 ), ABS( G1 ) )
103: IF( SCALE.GE.SAFMX2 ) THEN
104: COUNT = 0
105: 10 CONTINUE
106: COUNT = COUNT + 1
107: F1 = F1*SAFMN2
108: G1 = G1*SAFMN2
109: SCALE = MAX( ABS( F1 ), ABS( G1 ) )
110: IF( SCALE.GE.SAFMX2 )
111: $ GO TO 10
112: R = SQRT( F1**2+G1**2 )
113: CS = F1 / R
114: SN = G1 / R
115: DO 20 I = 1, COUNT
116: R = R*SAFMX2
117: 20 CONTINUE
118: ELSE IF( SCALE.LE.SAFMN2 ) THEN
119: COUNT = 0
120: 30 CONTINUE
121: COUNT = COUNT + 1
122: F1 = F1*SAFMX2
123: G1 = G1*SAFMX2
124: SCALE = MAX( ABS( F1 ), ABS( G1 ) )
125: IF( SCALE.LE.SAFMN2 )
126: $ GO TO 30
127: R = SQRT( F1**2+G1**2 )
128: CS = F1 / R
129: SN = G1 / R
130: DO 40 I = 1, COUNT
131: R = R*SAFMN2
132: 40 CONTINUE
133: ELSE
134: R = SQRT( F1**2+G1**2 )
135: CS = F1 / R
136: SN = G1 / R
137: END IF
138: IF( R.LT.ZERO ) THEN
139: CS = -CS
140: SN = -SN
141: R = -R
142: END IF
143: END IF
144: RETURN
145: *
146: * End of DLARTGP
147: *
148: END