Return to dlartgp.f CVS log

Up to [local] / rpl / lapack / lapack

Cohérence.

    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