You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
199 lines
5.2 KiB
199 lines
5.2 KiB
*> \brief \b SLARTGP 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 SLARTGP + dependencies
|
|
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slartgp.f">
|
|
*> [TGZ]</a>
|
|
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slartgp.f">
|
|
*> [ZIP]</a>
|
|
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slartgp.f">
|
|
*> [TXT]</a>
|
|
*> \endhtmlonly
|
|
*
|
|
* Definition:
|
|
* ===========
|
|
*
|
|
* SUBROUTINE SLARTGP( F, G, CS, SN, R )
|
|
*
|
|
* .. Scalar Arguments ..
|
|
* REAL CS, F, G, R, SN
|
|
* ..
|
|
*
|
|
*
|
|
*> \par Purpose:
|
|
* =============
|
|
*>
|
|
*> \verbatim
|
|
*>
|
|
*> SLARTGP 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 SROTG,
|
|
*> 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 REAL
|
|
*> The first component of vector to be rotated.
|
|
*> \endverbatim
|
|
*>
|
|
*> \param[in] G
|
|
*> \verbatim
|
|
*> G is REAL
|
|
*> The second component of vector to be rotated.
|
|
*> \endverbatim
|
|
*>
|
|
*> \param[out] CS
|
|
*> \verbatim
|
|
*> CS is REAL
|
|
*> The cosine of the rotation.
|
|
*> \endverbatim
|
|
*>
|
|
*> \param[out] SN
|
|
*> \verbatim
|
|
*> SN is REAL
|
|
*> The sine of the rotation.
|
|
*> \endverbatim
|
|
*>
|
|
*> \param[out] R
|
|
*> \verbatim
|
|
*> R is REAL
|
|
*> 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.
|
|
*
|
|
*> \ingroup OTHERauxiliary
|
|
*
|
|
* =====================================================================
|
|
SUBROUTINE SLARTGP( F, G, CS, SN, R )
|
|
*
|
|
* -- LAPACK auxiliary routine --
|
|
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
|
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
|
*
|
|
* .. Scalar Arguments ..
|
|
REAL CS, F, G, R, SN
|
|
* ..
|
|
*
|
|
* =====================================================================
|
|
*
|
|
* .. Parameters ..
|
|
REAL ZERO
|
|
PARAMETER ( ZERO = 0.0E0 )
|
|
REAL ONE
|
|
PARAMETER ( ONE = 1.0E0 )
|
|
REAL TWO
|
|
PARAMETER ( TWO = 2.0E0 )
|
|
* ..
|
|
* .. Local Scalars ..
|
|
* LOGICAL FIRST
|
|
INTEGER COUNT, I
|
|
REAL EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE
|
|
* ..
|
|
* .. External Functions ..
|
|
REAL SLAMCH
|
|
EXTERNAL SLAMCH
|
|
* ..
|
|
* .. 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 = SLAMCH( 'S' )
|
|
EPS = SLAMCH( 'E' )
|
|
SAFMN2 = SLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) /
|
|
$ LOG( SLAMCH( '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 .AND. COUNT .LT. 20)
|
|
$ 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 SLARTGP
|
|
*
|
|
END
|
|
|