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
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