143 lines
3.9 KiB
Fortran
143 lines
3.9 KiB
Fortran
SUBROUTINE DLARTG( F, G, CS, SN, R )
|
|
*
|
|
* -- LAPACK auxiliary routine (version 2.0) --
|
|
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
|
|
* Courant Institute, Argonne National Lab, and Rice University
|
|
* September 30, 1994
|
|
*
|
|
* .. Scalar Arguments ..
|
|
DOUBLE PRECISION CS, F, G, R, SN
|
|
* ..
|
|
*
|
|
* Purpose
|
|
* =======
|
|
*
|
|
* DLARTG generate 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 BLAS1 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 without doing any
|
|
* floating point operations (saves work in DBDSQR when
|
|
* there are zeros on the diagonal).
|
|
*
|
|
* If F exceeds G in magnitude, CS will be positive.
|
|
*
|
|
* Arguments
|
|
* =========
|
|
*
|
|
* F (input) DOUBLE PRECISION
|
|
* The first component of vector to be rotated.
|
|
*
|
|
* G (input) DOUBLE PRECISION
|
|
* The second component of vector to be rotated.
|
|
*
|
|
* CS (output) DOUBLE PRECISION
|
|
* The cosine of the rotation.
|
|
*
|
|
* SN (output) DOUBLE PRECISION
|
|
* The sine of the rotation.
|
|
*
|
|
* R (output) DOUBLE PRECISION
|
|
* The nonzero component of the rotated vector.
|
|
*
|
|
* =====================================================================
|
|
*
|
|
* .. Parameters ..
|
|
DOUBLE PRECISION ZERO
|
|
PARAMETER ( ZERO = 0.0D0 )
|
|
DOUBLE PRECISION ONE
|
|
PARAMETER ( ONE = 1.0D0 )
|
|
DOUBLE PRECISION TWO
|
|
PARAMETER ( TWO = 2.0D0 )
|
|
* ..
|
|
* .. Local Scalars ..
|
|
LOGICAL FIRST
|
|
INTEGER COUNT, I
|
|
DOUBLE PRECISION EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE
|
|
* ..
|
|
* .. External Functions ..
|
|
DOUBLE PRECISION DLAMCH
|
|
EXTERNAL DLAMCH
|
|
* ..
|
|
* .. Intrinsic Functions ..
|
|
INTRINSIC ABS, INT, LOG, MAX, SQRT
|
|
* ..
|
|
* .. Save statement ..
|
|
SAVE FIRST, SAFMX2, SAFMIN, SAFMN2
|
|
* ..
|
|
* .. Data statements ..
|
|
DATA FIRST / .TRUE. /
|
|
* ..
|
|
* .. Executable Statements ..
|
|
*
|
|
IF( FIRST ) THEN
|
|
FIRST = .FALSE.
|
|
SAFMIN = DLAMCH( 'S' )
|
|
EPS = DLAMCH( 'E' )
|
|
SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) /
|
|
$ LOG( DLAMCH( 'B' ) ) / TWO )
|
|
SAFMX2 = ONE / SAFMN2
|
|
END IF
|
|
IF( G.EQ.ZERO ) THEN
|
|
CS = ONE
|
|
SN = ZERO
|
|
R = F
|
|
ELSE IF( F.EQ.ZERO ) THEN
|
|
CS = ZERO
|
|
SN = ONE
|
|
R = G
|
|
ELSE
|
|
F1 = F
|
|
G1 = G
|
|
SCALE = MAX( ABS( F1 ), ABS( G1 ) )
|
|
IF( SCALE.GE.SAFMX2 ) THEN
|
|
COUNT = 0
|
|
10 CONTINUE
|
|
COUNT = COUNT + 1
|
|
F1 = F1*SAFMN2
|
|
G1 = G1*SAFMN2
|
|
SCALE = MAX( ABS( F1 ), ABS( G1 ) )
|
|
IF( SCALE.GE.SAFMX2 )
|
|
$ GO TO 10
|
|
R = SQRT( F1**2+G1**2 )
|
|
CS = F1 / R
|
|
SN = G1 / R
|
|
DO 20 I = 1, COUNT
|
|
R = R*SAFMX2
|
|
20 CONTINUE
|
|
ELSE IF( SCALE.LE.SAFMN2 ) THEN
|
|
COUNT = 0
|
|
30 CONTINUE
|
|
COUNT = COUNT + 1
|
|
F1 = F1*SAFMX2
|
|
G1 = G1*SAFMX2
|
|
SCALE = MAX( ABS( F1 ), ABS( G1 ) )
|
|
IF( SCALE.LE.SAFMN2 )
|
|
$ GO TO 30
|
|
R = SQRT( F1**2+G1**2 )
|
|
CS = F1 / R
|
|
SN = G1 / R
|
|
DO 40 I = 1, COUNT
|
|
R = R*SAFMN2
|
|
40 CONTINUE
|
|
ELSE
|
|
R = SQRT( F1**2+G1**2 )
|
|
CS = F1 / R
|
|
SN = G1 / R
|
|
END IF
|
|
IF( ABS( F ).GT.ABS( G ) .AND. CS.LT.ZERO ) THEN
|
|
CS = -CS
|
|
SN = -SN
|
|
R = -R
|
|
END IF
|
|
END IF
|
|
RETURN
|
|
*
|
|
* End of DLARTG
|
|
*
|
|
END
|