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 / zlassq.f < prev    next >
Text File  |  1996-09-28  |  3KB  |  103 lines
  1.       SUBROUTINE ZLASSQ( N, X, INCX, SCALE, SUMSQ )
  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. *     October 31, 1992
  7. *
  8. *     .. Scalar Arguments ..
  9.       INTEGER            INCX, N
  10.       DOUBLE PRECISION   SCALE, SUMSQ
  11. *     ..
  12. *     .. Array Arguments ..
  13.       COMPLEX*16         X( * )
  14. *     ..
  15. *
  16. *  Purpose
  17. *  =======
  18. *
  19. *  ZLASSQ returns the values scl and ssq such that
  20. *
  21. *     ( scl**2 )*ssq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,
  22. *
  23. *  where x( i ) = abs( X( 1 + ( i - 1 )*INCX ) ). The value of sumsq is
  24. *  assumed to be at least unity and the value of ssq will then satisfy
  25. *
  26. *     1.0 .le. ssq .le. ( sumsq + 2*n ).
  27. *
  28. *  scale is assumed to be non-negative and scl returns the value
  29. *
  30. *     scl = max( scale, abs( real( x( i ) ) ), abs( aimag( x( i ) ) ) ),
  31. *            i
  32. *
  33. *  scale and sumsq must be supplied in SCALE and SUMSQ respectively.
  34. *  SCALE and SUMSQ are overwritten by scl and ssq respectively.
  35. *
  36. *  The routine makes only one pass through the vector X.
  37. *
  38. *  Arguments
  39. *  =========
  40. *
  41. *  N       (input) INTEGER
  42. *          The number of elements to be used from the vector X.
  43. *
  44. *  X       (input) DOUBLE PRECISION
  45. *          The vector x as described above.
  46. *             x( i )  = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.
  47. *
  48. *  INCX    (input) INTEGER
  49. *          The increment between successive values of the vector X.
  50. *          INCX > 0.
  51. *
  52. *  SCALE   (input/output) DOUBLE PRECISION
  53. *          On entry, the value  scale  in the equation above.
  54. *          On exit, SCALE is overwritten with the value  scl .
  55. *
  56. *  SUMSQ   (input/output) DOUBLE PRECISION
  57. *          On entry, the value  sumsq  in the equation above.
  58. *          On exit, SUMSQ is overwritten with the value  ssq .
  59. *
  60. * =====================================================================
  61. *
  62. *     .. Parameters ..
  63.       DOUBLE PRECISION   ZERO
  64.       PARAMETER          ( ZERO = 0.0D+0 )
  65. *     ..
  66. *     .. Local Scalars ..
  67.       INTEGER            IX
  68.       DOUBLE PRECISION   TEMP1
  69. *     ..
  70. *     .. Intrinsic Functions ..
  71.       INTRINSIC          ABS, DBLE, DIMAG
  72. *     ..
  73. *     .. Executable Statements ..
  74. *
  75.       IF( N.GT.0 ) THEN
  76.          DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX
  77.             IF( DBLE( X( IX ) ).NE.ZERO ) THEN
  78.                TEMP1 = ABS( DBLE( X( IX ) ) )
  79.                IF( SCALE.LT.TEMP1 ) THEN
  80.                   SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2
  81.                   SCALE = TEMP1
  82.                ELSE
  83.                   SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2
  84.                END IF
  85.             END IF
  86.             IF( DIMAG( X( IX ) ).NE.ZERO ) THEN
  87.                TEMP1 = ABS( DIMAG( X( IX ) ) )
  88.                IF( SCALE.LT.TEMP1 ) THEN
  89.                   SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2
  90.                   SCALE = TEMP1
  91.                ELSE
  92.                   SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2
  93.                END IF
  94.             END IF
  95.    10    CONTINUE
  96.       END IF
  97. *
  98.       RETURN
  99. *
  100. *     End of ZLASSQ
  101. *
  102.       END
  103.