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