Return to dlartgp.f CVS log

Up to [local] / rpl / lapack / lapack

Annotation of rpl/lapack/lapack/dlartgp.f, revision 1.1

1.1     ! bertrand    1:       SUBROUTINE DLARTGP( F, G, CS, SN, R )
        !             2: *
        !             3: *     Originally DLARTG
        !             4: *  -- LAPACK auxiliary routine (version 3.2) --
        !             5: *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
        !             6: *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
        !             7: *     November 2006
        !             8: *
        !             9: *     Adapted to DLARTGP
        !            10: *     July 2010
        !            11: *
        !            12: *     .. Scalar Arguments ..
        !            13:       DOUBLE PRECISION   CS, F, G, R, SN
        !            14: *     ..
        !            15: *
        !            16: *  Purpose
        !            17: *  =======
        !            18: *
        !            19: *  DLARTGP generates a plane rotation so that
        !            20: *
        !            21: *     [  CS  SN  ]  .  [ F ]  =  [ R ]   where CS**2 + SN**2 = 1.
        !            22: *     [ -SN  CS  ]     [ G ]     [ 0 ]
        !            23: *
        !            24: *  This is a slower, more accurate version of the Level 1 BLAS routine DROTG,
        !            25: *  with the following other differences:
        !            26: *     F and G are unchanged on return.
        !            27: *     If G=0, then CS=(+/-)1 and SN=0.
        !            28: *     If F=0 and (G .ne. 0), then CS=0 and SN=(+/-)1.
        !            29: *
        !            30: *  The sign is chosen so that R >= 0.
        !            31: *
        !            32: *  Arguments
        !            33: *  =========
        !            34: *
        !            35: *  F       (input) DOUBLE PRECISION
        !            36: *          The first component of vector to be rotated.
        !            37: *
        !            38: *  G       (input) DOUBLE PRECISION
        !            39: *          The second component of vector to be rotated.
        !            40: *
        !            41: *  CS      (output) DOUBLE PRECISION
        !            42: *          The cosine of the rotation.
        !            43: *
        !            44: *  SN      (output) DOUBLE PRECISION
        !            45: *          The sine of the rotation.
        !            46: *
        !            47: *  R       (output) DOUBLE PRECISION
        !            48: *          The nonzero component of the rotated vector.
        !            49: *
        !            50: *  This version has a few statements commented out for thread safety
        !            51: *  (machine parameters are computed on each entry). 10 feb 03, SJH.
        !            52: *
        !            53: *  =====================================================================
        !            54: *
        !            55: *     .. Parameters ..
        !            56:       DOUBLE PRECISION   ZERO
        !            57:       PARAMETER          ( ZERO = 0.0D0 )
        !            58:       DOUBLE PRECISION   ONE
        !            59:       PARAMETER          ( ONE = 1.0D0 )
        !            60:       DOUBLE PRECISION   TWO
        !            61:       PARAMETER          ( TWO = 2.0D0 )
        !            62: *     ..
        !            63: *     .. Local Scalars ..
        !            64: *     LOGICAL            FIRST
        !            65:       INTEGER            COUNT, I
        !            66:       DOUBLE PRECISION   EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE
        !            67: *     ..
        !            68: *     .. External Functions ..
        !            69:       DOUBLE PRECISION   DLAMCH
        !            70:       EXTERNAL           DLAMCH
        !            71: *     ..
        !            72: *     .. Intrinsic Functions ..
        !            73:       INTRINSIC          ABS, INT, LOG, MAX, SIGN, SQRT
        !            74: *     ..
        !            75: *     .. Save statement ..
        !            76: *     SAVE               FIRST, SAFMX2, SAFMIN, SAFMN2
        !            77: *     ..
        !            78: *     .. Data statements ..
        !            79: *     DATA               FIRST / .TRUE. /
        !            80: *     ..
        !            81: *     .. Executable Statements ..
        !            82: *
        !            83: *     IF( FIRST ) THEN
        !            84:          SAFMIN = DLAMCH( 'S' )
        !            85:          EPS = DLAMCH( 'E' )
        !            86:          SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) /
        !            87:      $            LOG( DLAMCH( 'B' ) ) / TWO )
        !            88:          SAFMX2 = ONE / SAFMN2
        !            89: *        FIRST = .FALSE.
        !            90: *     END IF
        !            91:       IF( G.EQ.ZERO ) THEN
        !            92:          CS = SIGN( ONE, F )
        !            93:          SN = ZERO
        !            94:          R = ABS( F )
        !            95:       ELSE IF( F.EQ.ZERO ) THEN
        !            96:          CS = ZERO
        !            97:          SN = SIGN( ONE, G )
        !            98:          R = ABS( G )
        !            99:       ELSE
        !           100:          F1 = F
        !           101:          G1 = G
        !           102:          SCALE = MAX( ABS( F1 ), ABS( G1 ) )
        !           103:          IF( SCALE.GE.SAFMX2 ) THEN
        !           104:             COUNT = 0
        !           105:    10       CONTINUE
        !           106:             COUNT = COUNT + 1
        !           107:             F1 = F1*SAFMN2
        !           108:             G1 = G1*SAFMN2
        !           109:             SCALE = MAX( ABS( F1 ), ABS( G1 ) )
        !           110:             IF( SCALE.GE.SAFMX2 )
        !           111:      $         GO TO 10
        !           112:             R = SQRT( F1**2+G1**2 )
        !           113:             CS = F1 / R
        !           114:             SN = G1 / R
        !           115:             DO 20 I = 1, COUNT
        !           116:                R = R*SAFMX2
        !           117:    20       CONTINUE
        !           118:          ELSE IF( SCALE.LE.SAFMN2 ) THEN
        !           119:             COUNT = 0
        !           120:    30       CONTINUE
        !           121:             COUNT = COUNT + 1
        !           122:             F1 = F1*SAFMX2
        !           123:             G1 = G1*SAFMX2
        !           124:             SCALE = MAX( ABS( F1 ), ABS( G1 ) )
        !           125:             IF( SCALE.LE.SAFMN2 )
        !           126:      $         GO TO 30
        !           127:             R = SQRT( F1**2+G1**2 )
        !           128:             CS = F1 / R
        !           129:             SN = G1 / R
        !           130:             DO 40 I = 1, COUNT
        !           131:                R = R*SAFMN2
        !           132:    40       CONTINUE
        !           133:          ELSE
        !           134:             R = SQRT( F1**2+G1**2 )
        !           135:             CS = F1 / R
        !           136:             SN = G1 / R
        !           137:          END IF
        !           138:          IF( R.LT.ZERO ) THEN
        !           139:             CS = -CS
        !           140:             SN = -SN
        !           141:             R = -R
        !           142:          END IF
        !           143:       END IF
        !           144:       RETURN
        !           145: *
        !           146: *     End of DLARTGP
        !           147: *
        !           148:       END