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
CVSweb interface <joel.bertrand@systella.fr>