Statistiques
| Révision :

root / src / lapack / double / dlartg.f @ 10

Historique | Voir | Annoter | Télécharger (4,02 ko)

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