home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / octave-1.1.1p1-src.tgz / tar.out / fsf / octave / libcruft / lapack / dlartg.f < prev    next >
Text File  |  1996-09-28  |  4KB  |  144 lines
  1.       SUBROUTINE DLARTG( F, G, CS, SN, R )
  2. *
  3. *  -- LAPACK auxiliary routine (version 2.0) --
  4. *     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
  5. *     Courant Institute, Argonne National Lab, and Rice University
  6. *     September 30, 1994
  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. *  =====================================================================
  49. *
  50. *     .. Parameters ..
  51.       DOUBLE PRECISION   ZERO
  52.       PARAMETER          ( ZERO = 0.0D0 )
  53.       DOUBLE PRECISION   ONE
  54.       PARAMETER          ( ONE = 1.0D0 )
  55.       DOUBLE PRECISION   TWO
  56.       PARAMETER          ( TWO = 2.0D0 )
  57. *     ..
  58. *     .. Local Scalars ..
  59.       LOGICAL            FIRST
  60.       INTEGER            COUNT, I
  61.       DOUBLE PRECISION   EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE
  62. *     ..
  63. *     .. External Functions ..
  64.       DOUBLE PRECISION   DLAMCH
  65.       EXTERNAL           DLAMCH
  66. *     ..
  67. *     .. Intrinsic Functions ..
  68.       INTRINSIC          ABS, INT, LOG, MAX, SQRT
  69. *     ..
  70. *     .. Save statement ..
  71.       SAVE               FIRST, SAFMX2, SAFMIN, SAFMN2
  72. *     ..
  73. *     .. Data statements ..
  74.       DATA               FIRST / .TRUE. /
  75. *     ..
  76. *     .. Executable Statements ..
  77. *
  78.       IF( FIRST ) THEN
  79.          FIRST = .FALSE.
  80.          SAFMIN = DLAMCH( 'S' )
  81.          EPS = DLAMCH( 'E' )
  82.          SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) /
  83.      $            LOG( DLAMCH( 'B' ) ) / TWO )
  84.          SAFMX2 = ONE / SAFMN2
  85.       END IF
  86.       IF( G.EQ.ZERO ) THEN
  87.          CS = ONE
  88.          SN = ZERO
  89.          R = F
  90.       ELSE IF( F.EQ.ZERO ) THEN
  91.          CS = ZERO
  92.          SN = ONE
  93.          R = G
  94.       ELSE
  95.          F1 = F
  96.          G1 = G
  97.          SCALE = MAX( ABS( F1 ), ABS( G1 ) )
  98.          IF( SCALE.GE.SAFMX2 ) THEN
  99.             COUNT = 0
  100.    10       CONTINUE
  101.             COUNT = COUNT + 1
  102.             F1 = F1*SAFMN2
  103.             G1 = G1*SAFMN2
  104.             SCALE = MAX( ABS( F1 ), ABS( G1 ) )
  105.             IF( SCALE.GE.SAFMX2 )
  106.      $         GO TO 10
  107.             R = SQRT( F1**2+G1**2 )
  108.             CS = F1 / R
  109.             SN = G1 / R
  110.             DO 20 I = 1, COUNT
  111.                R = R*SAFMX2
  112.    20       CONTINUE
  113.          ELSE IF( SCALE.LE.SAFMN2 ) THEN
  114.             COUNT = 0
  115.    30       CONTINUE
  116.             COUNT = COUNT + 1
  117.             F1 = F1*SAFMX2
  118.             G1 = G1*SAFMX2
  119.             SCALE = MAX( ABS( F1 ), ABS( G1 ) )
  120.             IF( SCALE.LE.SAFMN2 )
  121.      $         GO TO 30
  122.             R = SQRT( F1**2+G1**2 )
  123.             CS = F1 / R
  124.             SN = G1 / R
  125.             DO 40 I = 1, COUNT
  126.                R = R*SAFMN2
  127.    40       CONTINUE
  128.          ELSE
  129.             R = SQRT( F1**2+G1**2 )
  130.             CS = F1 / R
  131.             SN = G1 / R
  132.          END IF
  133.          IF( ABS( F ).GT.ABS( G ) .AND. CS.LT.ZERO ) THEN
  134.             CS = -CS
  135.             SN = -SN
  136.             R = -R
  137.          END IF
  138.       END IF
  139.       RETURN
  140. *
  141. *     End of DLARTG
  142. *
  143.       END
  144.