203 lines
5.3 KiB
Fortran
203 lines
5.3 KiB
Fortran
*> \brief \b DLARTGP generates a plane rotation so that the diagonal is nonnegative.
|
|
*
|
|
* =========== DOCUMENTATION ===========
|
|
*
|
|
* Online html documentation available at
|
|
* http://www.netlib.org/lapack/explore-html/
|
|
*
|
|
*> \htmlonly
|
|
*> Download DLARTGP + dependencies
|
|
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlartgp.f">
|
|
*> [TGZ]</a>
|
|
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlartgp.f">
|
|
*> [ZIP]</a>
|
|
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlartgp.f">
|
|
*> [TXT]</a>
|
|
*> \endhtmlonly
|
|
*
|
|
* Definition:
|
|
* ===========
|
|
*
|
|
* SUBROUTINE DLARTGP( F, G, CS, SN, R )
|
|
*
|
|
* .. Scalar Arguments ..
|
|
* DOUBLE PRECISION CS, F, G, R, SN
|
|
* ..
|
|
*
|
|
*
|
|
*> \par Purpose:
|
|
* =============
|
|
*>
|
|
*> \verbatim
|
|
*>
|
|
*> 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.
|
|
*> \endverbatim
|
|
*
|
|
* Arguments:
|
|
* ==========
|
|
*
|
|
*> \param[in] F
|
|
*> \verbatim
|
|
*> F is DOUBLE PRECISION
|
|
*> The first component of vector to be rotated.
|
|
*> \endverbatim
|
|
*>
|
|
*> \param[in] G
|
|
*> \verbatim
|
|
*> G is DOUBLE PRECISION
|
|
*> The second component of vector to be rotated.
|
|
*> \endverbatim
|
|
*>
|
|
*> \param[out] CS
|
|
*> \verbatim
|
|
*> CS is DOUBLE PRECISION
|
|
*> The cosine of the rotation.
|
|
*> \endverbatim
|
|
*>
|
|
*> \param[out] SN
|
|
*> \verbatim
|
|
*> SN is DOUBLE PRECISION
|
|
*> The sine of the rotation.
|
|
*> \endverbatim
|
|
*>
|
|
*> \param[out] R
|
|
*> \verbatim
|
|
*> 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.
|
|
*> \endverbatim
|
|
*
|
|
* Authors:
|
|
* ========
|
|
*
|
|
*> \author Univ. of Tennessee
|
|
*> \author Univ. of California Berkeley
|
|
*> \author Univ. of Colorado Denver
|
|
*> \author NAG Ltd.
|
|
*
|
|
*> \date September 2012
|
|
*
|
|
*> \ingroup auxOTHERauxiliary
|
|
*
|
|
* =====================================================================
|
|
SUBROUTINE DLARTGP( F, G, CS, SN, R )
|
|
*
|
|
* -- LAPACK auxiliary routine (version 3.4.2) --
|
|
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
|
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
|
* September 2012
|
|
*
|
|
* .. Scalar Arguments ..
|
|
DOUBLE PRECISION CS, F, G, R, SN
|
|
* ..
|
|
*
|
|
* =====================================================================
|
|
*
|
|
* .. 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, SIGN, SQRT
|
|
* ..
|
|
* .. Save statement ..
|
|
* SAVE FIRST, SAFMX2, SAFMIN, SAFMN2
|
|
* ..
|
|
* .. Data statements ..
|
|
* DATA FIRST / .TRUE. /
|
|
* ..
|
|
* .. Executable Statements ..
|
|
*
|
|
* IF( FIRST ) THEN
|
|
SAFMIN = DLAMCH( 'S' )
|
|
EPS = DLAMCH( 'E' )
|
|
SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) /
|
|
$ LOG( DLAMCH( 'B' ) ) / TWO )
|
|
SAFMX2 = ONE / SAFMN2
|
|
* FIRST = .FALSE.
|
|
* END IF
|
|
IF( G.EQ.ZERO ) THEN
|
|
CS = SIGN( ONE, F )
|
|
SN = ZERO
|
|
R = ABS( F )
|
|
ELSE IF( F.EQ.ZERO ) THEN
|
|
CS = ZERO
|
|
SN = SIGN( ONE, G )
|
|
R = ABS( 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( R.LT.ZERO ) THEN
|
|
CS = -CS
|
|
SN = -SN
|
|
R = -R
|
|
END IF
|
|
END IF
|
|
RETURN
|
|
*
|
|
* End of DLARTGP
|
|
*
|
|
END
|