 LAPACK  3.6.1 LAPACK: Linear Algebra PACKage
 subroutine dlartgp ( double precision F, double precision G, double precision CS, double precision SN, double precision R )

DLARTGP generates a plane rotation so that the diagonal is nonnegative.

Purpose:
DLARTGP generates a plane rotation so that

[  CS  SN  ]  .  [ F ]  =  [ R ]   where CS**2 + SN**2 = 1.
[ -SN  CS  ]     [ G ]     [ 0 ]

This is a slower, more accurate version of the Level 1 BLAS routine DROTG,
with the following other differences:
F and G are unchanged on return.
If G=0, then CS=(+/-)1 and SN=0.
If F=0 and (G .ne. 0), then CS=0 and SN=(+/-)1.

The sign is chosen so that R >= 0.
Parameters
 [in] F F is DOUBLE PRECISION The first component of vector to be rotated. [in] G G is DOUBLE PRECISION The second component of vector to be rotated. [out] CS CS is DOUBLE PRECISION The cosine of the rotation. [out] SN SN is DOUBLE PRECISION The sine of the rotation. [out] R R is DOUBLE PRECISION The nonzero component of the rotated vector. This version has a few statements commented out for thread safety (machine parameters are computed on each entry). 10 feb 03, SJH.
Date
September 2012

Definition at line 97 of file dlartgp.f.

97 *
98 * -- LAPACK auxiliary routine (version 3.4.2) --
99 * -- LAPACK is a software package provided by Univ. of Tennessee, --
100 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
101 * September 2012
102 *
103 * .. Scalar Arguments ..
104  DOUBLE PRECISION cs, f, g, r, sn
105 * ..
106 *
107 * =====================================================================
108 *
109 * .. Parameters ..
110  DOUBLE PRECISION zero
111  parameter ( zero = 0.0d0 )
112  DOUBLE PRECISION one
113  parameter ( one = 1.0d0 )
114  DOUBLE PRECISION two
115  parameter ( two = 2.0d0 )
116 * ..
117 * .. Local Scalars ..
118 * LOGICAL FIRST
119  INTEGER count, i
120  DOUBLE PRECISION eps, f1, g1, safmin, safmn2, safmx2, scale
121 * ..
122 * .. External Functions ..
123  DOUBLE PRECISION dlamch
124  EXTERNAL dlamch
125 * ..
126 * .. Intrinsic Functions ..
127  INTRINSIC abs, int, log, max, sign, sqrt
128 * ..
129 * .. Save statement ..
130 * SAVE FIRST, SAFMX2, SAFMIN, SAFMN2
131 * ..
132 * .. Data statements ..
133 * DATA FIRST / .TRUE. /
134 * ..
135 * .. Executable Statements ..
136 *
137 * IF( FIRST ) THEN
138  safmin = dlamch( 'S' )
139  eps = dlamch( 'E' )
140  safmn2 = dlamch( 'B' )**int( log( safmin / eps ) /
141  \$ log( dlamch( 'B' ) ) / two )
142  safmx2 = one / safmn2
143 * FIRST = .FALSE.
144 * END IF
145  IF( g.EQ.zero ) THEN
146  cs = sign( one, f )
147  sn = zero
148  r = abs( f )
149  ELSE IF( f.EQ.zero ) THEN
150  cs = zero
151  sn = sign( one, g )
152  r = abs( g )
153  ELSE
154  f1 = f
155  g1 = g
156  scale = max( abs( f1 ), abs( g1 ) )
157  IF( scale.GE.safmx2 ) THEN
158  count = 0
159  10 CONTINUE
160  count = count + 1
161  f1 = f1*safmn2
162  g1 = g1*safmn2
163  scale = max( abs( f1 ), abs( g1 ) )
164  IF( scale.GE.safmx2 )
165  \$ GO TO 10
166  r = sqrt( f1**2+g1**2 )
167  cs = f1 / r
168  sn = g1 / r
169  DO 20 i = 1, count
170  r = r*safmx2
171  20 CONTINUE
172  ELSE IF( scale.LE.safmn2 ) THEN
173  count = 0
174  30 CONTINUE
175  count = count + 1
176  f1 = f1*safmx2
177  g1 = g1*safmx2
178  scale = max( abs( f1 ), abs( g1 ) )
179  IF( scale.LE.safmn2 )
180  \$ GO TO 30
181  r = sqrt( f1**2+g1**2 )
182  cs = f1 / r
183  sn = g1 / r
184  DO 40 i = 1, count
185  r = r*safmn2
186  40 CONTINUE
187  ELSE
188  r = sqrt( f1**2+g1**2 )
189  cs = f1 / r
190  sn = g1 / r
191  END IF
192  IF( r.LT.zero ) THEN
193  cs = -cs
194  sn = -sn
195  r = -r
196  END IF
197  END IF
198  RETURN
199 *
200 * End of DLARTGP
201 *
double precision function dlamch(CMACH)
DLAMCH
Definition: dlamch.f:65

Here is the caller graph for this function: