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 / zlartg.f < prev    next >
Text File  |  1996-09-28  |  3KB  |  118 lines
  1.       SUBROUTINE ZLARTG( 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
  10.       COMPLEX*16         F, G, R, SN
  11. *     ..
  12. *
  13. *  Purpose
  14. *  =======
  15. *
  16. *  ZLARTG generates a plane rotation so that
  17. *
  18. *     [  CS  SN  ]     [ F ]     [ R ]
  19. *     [  __      ]  .  [   ]  =  [   ]   where CS**2 + |SN|**2 = 1.
  20. *     [ -SN  CS  ]     [ G ]     [ 0 ]
  21. *
  22. *  This is a faster version of the BLAS1 routine ZROTG, except for
  23. *  the following differences:
  24. *     F and G are unchanged on return.
  25. *     If G=0, then CS=1 and SN=0.
  26. *     If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any
  27. *        floating point operations.
  28. *
  29. *  Arguments
  30. *  =========
  31. *
  32. *  F       (input) COMPLEX*16
  33. *          The first component of vector to be rotated.
  34. *
  35. *  G       (input) COMPLEX*16
  36. *          The second component of vector to be rotated.
  37. *
  38. *  CS      (output) DOUBLE PRECISION
  39. *          The cosine of the rotation.
  40. *
  41. *  SN      (output) COMPLEX*16
  42. *          The sine of the rotation.
  43. *
  44. *  R       (output) COMPLEX*16
  45. *          The nonzero component of the rotated vector.
  46. *
  47. *  =====================================================================
  48. *
  49. *     .. Parameters ..
  50.       DOUBLE PRECISION   ONE, ZERO
  51.       PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
  52.       COMPLEX*16         CZERO
  53.       PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ) )
  54. *     ..
  55. *     .. Local Scalars ..
  56.       DOUBLE PRECISION   D, DI, F1, F2, FA, G1, G2, GA
  57.       COMPLEX*16         FS, GS, SS, T
  58. *     ..
  59. *     .. Intrinsic Functions ..
  60.       INTRINSIC          ABS, DBLE, DCONJG, DIMAG, SQRT
  61. *     ..
  62. *     .. Statement Functions ..
  63.       DOUBLE PRECISION   ABS1, ABSSQ
  64. *     ..
  65. *     .. Statement Function definitions ..
  66.       ABS1( T ) = ABS( DBLE( T ) ) + ABS( DIMAG( T ) )
  67.       ABSSQ( T ) = DBLE( T )**2 + DIMAG( T )**2
  68. *     ..
  69. *     .. Executable Statements ..
  70. *
  71. *     [ 25 or 38 ops for main paths ]
  72. *
  73.       IF( G.EQ.CZERO ) THEN
  74.          CS = ONE
  75.          SN = ZERO
  76.          R = F
  77.       ELSE IF( F.EQ.CZERO ) THEN
  78.          CS = ZERO
  79. *
  80.          SN = DCONJG( G ) / ABS( G )
  81.          R = ABS( G )
  82. *
  83. *         SN = ONE
  84. *         R = G
  85. *
  86.       ELSE
  87.          F1 = ABS1( F )
  88.          G1 = ABS1( G )
  89.          IF( F1.GE.G1 ) THEN
  90.             GS = G / F1
  91.             G2 = ABSSQ( GS )
  92.             FS = F / F1
  93.             F2 = ABSSQ( FS )
  94.             D = SQRT( ONE+G2 / F2 )
  95.             CS = ONE / D
  96.             SN = DCONJG( GS )*FS*( CS / F2 )
  97.             R = F*D
  98.          ELSE
  99.             FS = F / G1
  100.             F2 = ABSSQ( FS )
  101.             FA = SQRT( F2 )
  102.             GS = G / G1
  103.             G2 = ABSSQ( GS )
  104.             GA = SQRT( G2 )
  105.             D = SQRT( ONE+F2 / G2 )
  106.             DI = ONE / D
  107.             CS = ( FA / GA )*DI
  108.             SS = ( DCONJG( GS )*FS ) / ( FA*GA )
  109.             SN = SS*DI
  110.             R = G*SS*D
  111.          END IF
  112.       END IF
  113.       RETURN
  114. *
  115. *     End of ZLARTG
  116. *
  117.       END
  118.