Return to dlartg.f CVS log

Up to [local] / rpl / lapack / lapack

Initial revision

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