KTH framework for Nek5000 toolboxes; testing version  0.0.1
dlartg.f
Go to the documentation of this file.
1  SUBROUTINE dlartg( F, G, CS, SN, R )
2 *
3 * -- LAPACK auxiliary routine (version 3.0) --
4 * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
5 * Courant Institute, Argonne National Lab, and Rice University
6 * September 30, 1994
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 * =====================================================================
49 *
50 * .. Parameters ..
51  DOUBLE PRECISION ZERO
52  parameter( zero = 0.0d0 )
53  DOUBLE PRECISION ONE
54  parameter( one = 1.0d0 )
55  DOUBLE PRECISION TWO
56  parameter( two = 2.0d0 )
57 * ..
58 * .. Local Scalars ..
59  LOGICAL FIRST
60  INTEGER COUNT, I
61  DOUBLE PRECISION EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE
62 * ..
63 * .. External Functions ..
64  DOUBLE PRECISION DLAMCH
65  EXTERNAL dlamch
66 * ..
67 * .. Intrinsic Functions ..
68  INTRINSIC abs, int, log, max, sqrt
69 * ..
70 * .. Save statement ..
71  SAVE first, safmx2, safmin, safmn2
72 * ..
73 * .. Data statements ..
74  DATA first / .true. /
75 * ..
76 * .. Executable Statements ..
77 *
78  IF( first ) THEN
79  first = .false.
80  safmin = dlamch( 'S' )
81  eps = dlamch( 'E' )
82  safmn2 = dlamch( 'B' )**int( log( safmin / eps ) /
83  $ log( dlamch( 'B' ) ) / two )
84  safmx2 = one / safmn2
85  END IF
86  IF( g.EQ.zero ) THEN
87  cs = one
88  sn = zero
89  r = f
90  ELSE IF( f.EQ.zero ) THEN
91  cs = zero
92  sn = one
93  r = g
94  ELSE
95  f1 = f
96  g1 = g
97  scale = max( abs( f1 ), abs( g1 ) )
98  IF( scale.GE.safmx2 ) THEN
99  count = 0
100  10 CONTINUE
101  count = count + 1
102  f1 = f1*safmn2
103  g1 = g1*safmn2
104  scale = max( abs( f1 ), abs( g1 ) )
105  IF( scale.GE.safmx2 )
106  $ GO TO 10
107  r = sqrt( f1**2+g1**2 )
108  cs = f1 / r
109  sn = g1 / r
110  DO 20 i = 1, count
111  r = r*safmx2
112  20 CONTINUE
113  ELSE IF( scale.LE.safmn2 ) THEN
114  count = 0
115  30 CONTINUE
116  count = count + 1
117  f1 = f1*safmx2
118  g1 = g1*safmx2
119  scale = max( abs( f1 ), abs( g1 ) )
120  IF( scale.LE.safmn2 )
121  $ GO TO 30
122  r = sqrt( f1**2+g1**2 )
123  cs = f1 / r
124  sn = g1 / r
125  DO 40 i = 1, count
126  r = r*safmn2
127  40 CONTINUE
128  ELSE
129  r = sqrt( f1**2+g1**2 )
130  cs = f1 / r
131  sn = g1 / r
132  END IF
133  IF( abs( f ).GT.abs( g ) .AND. cs.LT.zero ) THEN
134  cs = -cs
135  sn = -sn
136  r = -r
137  END IF
138  END IF
139  RETURN
140 *
141 * End of DLARTG
142 *
143  END
subroutine dlartg(F, G, CS, SN, R)
Definition: dlartg.f:2