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