added lapack 3.7.0 with latest patches from git
This commit is contained in:
Werner Saar
202
lapack-netlib/SRC/dlartgp.f
Normal file
202
lapack-netlib/SRC/dlartgp.f
Normal file
@@ -0,0 +1,202 @@
|
||||
*> \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 December 2016
|
||||
*
|
||||
*> \ingroup OTHERauxiliary
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE DLARTGP( F, G, CS, SN, R )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.7.0) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* December 2016
|
||||
*
|
||||
* .. 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
|
||||
Reference in New Issue
Block a user