PLASMA  2.4.5
PLASMA - Parallel Linear Algebra for Scalable Multi-core Architectures
 All Data Structures Namespaces Files Functions Variables Typedefs Enumerations Enumerator Macros Groups
dlartg.f
Go to the documentation of this file.
1  SUBROUTINE dlartg( F, G, CS, SN, R )
2 *
3 * -- LAPACK auxiliary routine (version 3.2) --
4 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
5 * November 2006
6 *
7 * .. Scalar Arguments ..
8  DOUBLE PRECISION cs, f, g, r, sn
9 * ..
10 *
11 * Purpose
12 * =======
13 *
14 * DLARTG generate a plane rotation so that
15 *
16 * [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1.
17 * [ -SN CS ] [ G ] [ 0 ]
18 *
19 * This is a slower, more accurate version of the BLAS1 routine DROTG,
20 * with the following other differences:
21 * F and G are unchanged on return.
22 * If G=0, then CS=1 and SN=0.
23 * If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any
24 * floating point operations (saves work in DBDSQR when
25 * there are zeros on the diagonal).
26 *
27 * If F exceeds G in magnitude, CS will be positive.
28 *
29 * Arguments
30 * =========
31 *
32 * F (input) DOUBLE PRECISION
33 * The first component of vector to be rotated.
34 *
35 * G (input) DOUBLE PRECISION
36 * The second component of vector to be rotated.
37 *
38 * CS (output) DOUBLE PRECISION
39 * The cosine of the rotation.
40 *
41 * SN (output) DOUBLE PRECISION
42 * The sine of the rotation.
43 *
44 * R (output) DOUBLE PRECISION
45 * The nonzero component of the rotated vector.
46 *
47 * This version has a few statements commented out for thread safety
48 * (machine parameters are computed on each entry). 10 feb 03, SJH.
49 *
50 * =====================================================================
51 *
52 * .. Parameters ..
53  DOUBLE PRECISION zero
54  parameter( zero = 0.0d0 )
55  DOUBLE PRECISION one
56  parameter( one = 1.0d0 )
57  DOUBLE PRECISION two
58  parameter( two = 2.0d0 )
59 * ..
60 * .. Local Scalars ..
61 * LOGICAL FIRST
62  INTEGER count, i
63  DOUBLE PRECISION eps, f1, g1, safmin, safmn2, safmx2, scale
64 * ..
65 * .. External Functions ..
66  DOUBLE PRECISION dlamch
67  EXTERNAL dlamch
68 * ..
69 * .. Intrinsic Functions ..
70  INTRINSIC abs, int, log, max, sqrt
71 * ..
72 * .. Save statement ..
73 * SAVE FIRST, SAFMX2, SAFMIN, SAFMN2
74 * ..
75 * .. Data statements ..
76 * DATA FIRST / .TRUE. /
77 * ..
78 * .. Executable Statements ..
79 *
80 * IF( FIRST ) THEN
81  safmin = dlamch( 'S' )
82  eps = dlamch( 'E' )
83  safmn2 = dlamch( 'B' )**int( log( safmin / eps ) /
84  $ log( dlamch( 'B' ) ) / two )
85  safmx2 = one / safmn2
86 * FIRST = .FALSE.
87 * END IF
88  IF( g.EQ.zero ) THEN
89  cs = one
90  sn = zero
91  r = f
92  ELSE IF( f.EQ.zero ) THEN
93  cs = zero
94  sn = one
95  r = g
96  ELSE
97  f1 = f
98  g1 = g
99  scale = max( abs( f1 ), abs( g1 ) )
100  IF( scale.GE.safmx2 ) THEN
101  count = 0
102  10 continue
103  count = count + 1
104  f1 = f1*safmn2
105  g1 = g1*safmn2
106  scale = max( abs( f1 ), abs( g1 ) )
107  IF( scale.GE.safmx2 )
108  $ go to 10
109  r = sqrt( f1**2+g1**2 )
110  cs = f1 / r
111  sn = g1 / r
112  DO 20 i = 1, count
113  r = r*safmx2
114  20 continue
115  ELSE IF( scale.LE.safmn2 ) THEN
116  count = 0
117  30 continue
118  count = count + 1
119  f1 = f1*safmx2
120  g1 = g1*safmx2
121  scale = max( abs( f1 ), abs( g1 ) )
122  IF( scale.LE.safmn2 )
123  $ go to 30
124  r = sqrt( f1**2+g1**2 )
125  cs = f1 / r
126  sn = g1 / r
127  DO 40 i = 1, count
128  r = r*safmn2
129  40 continue
130  ELSE
131  r = sqrt( f1**2+g1**2 )
132  cs = f1 / r
133  sn = g1 / r
134  END IF
135  IF( abs( f ).GT.abs( g ) .AND. cs.LT.zero ) THEN
136  cs = -cs
137  sn = -sn
138  r = -r
139  END IF
140  END IF
141  return
142 *
143 * End of DLARTG
144 *
145  END