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 / dlamch.f < prev    next >
Text File  |  1996-09-28  |  4KB  |  128 lines
  1.       DOUBLE PRECISION FUNCTION DLAMCH( CMACH )
  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.       CHARACTER          CMACH
  10. *     ..
  11. *
  12. *  Purpose
  13. *  =======
  14. *
  15. *  DLAMCH determines double precision machine parameters.
  16. *
  17. *  Arguments
  18. *  =========
  19. *
  20. *  CMACH   (input) CHARACTER*1
  21. *          Specifies the value to be returned by DLAMCH:
  22. *          = 'E' or 'e',   DLAMCH := eps
  23. *          = 'S' or 's ,   DLAMCH := sfmin
  24. *          = 'B' or 'b',   DLAMCH := base
  25. *          = 'P' or 'p',   DLAMCH := eps*base
  26. *          = 'N' or 'n',   DLAMCH := t
  27. *          = 'R' or 'r',   DLAMCH := rnd
  28. *          = 'M' or 'm',   DLAMCH := emin
  29. *          = 'U' or 'u',   DLAMCH := rmin
  30. *          = 'L' or 'l',   DLAMCH := emax
  31. *          = 'O' or 'o',   DLAMCH := rmax
  32. *
  33. *          where
  34. *
  35. *          eps   = relative machine precision
  36. *          sfmin = safe minimum, such that 1/sfmin does not overflow
  37. *          base  = base of the machine
  38. *          prec  = eps*base
  39. *          t     = number of (base) digits in the mantissa
  40. *          rnd   = 1.0 when rounding occurs in addition, 0.0 otherwise
  41. *          emin  = minimum exponent before (gradual) underflow
  42. *          rmin  = underflow threshold - base**(emin-1)
  43. *          emax  = largest exponent before overflow
  44. *          rmax  = overflow threshold  - (base**emax)*(1-eps)
  45. *
  46. * =====================================================================
  47. *
  48. *     .. Parameters ..
  49.       DOUBLE PRECISION   ONE, ZERO
  50.       PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
  51. *     ..
  52. *     .. Local Scalars ..
  53.       LOGICAL            FIRST, LRND
  54.       INTEGER            BETA, IMAX, IMIN, IT
  55.       DOUBLE PRECISION   BASE, EMAX, EMIN, EPS, PREC, RMACH, RMAX, RMIN,
  56.      $                   RND, SFMIN, SMALL, T
  57. *     ..
  58. *     .. External Functions ..
  59.       LOGICAL            LSAME
  60.       EXTERNAL           LSAME
  61. *     ..
  62. *     .. External Subroutines ..
  63.       EXTERNAL           DLAMC2
  64. *     ..
  65. *     .. Save statement ..
  66.       SAVE               FIRST, EPS, SFMIN, BASE, T, RND, EMIN, RMIN,
  67.      $                   EMAX, RMAX, PREC
  68. *     ..
  69. *     .. Data statements ..
  70.       DATA               FIRST / .TRUE. /
  71. *     ..
  72. *     .. Executable Statements ..
  73. *
  74.       IF( FIRST ) THEN
  75.          FIRST = .FALSE.
  76.          CALL DLAMC2( BETA, IT, LRND, EPS, IMIN, RMIN, IMAX, RMAX )
  77.          BASE = BETA
  78.          T = IT
  79.          IF( LRND ) THEN
  80.             RND = ONE
  81.             EPS = ( BASE**( 1-IT ) ) / 2
  82.          ELSE
  83.             RND = ZERO
  84.             EPS = BASE**( 1-IT )
  85.          END IF
  86.          PREC = EPS*BASE
  87.          EMIN = IMIN
  88.          EMAX = IMAX
  89.          SFMIN = RMIN
  90.          SMALL = ONE / RMAX
  91.          IF( SMALL.GE.SFMIN ) THEN
  92. *
  93. *           Use SMALL plus a bit, to avoid the possibility of rounding
  94. *           causing overflow when computing  1/sfmin.
  95. *
  96.             SFMIN = SMALL*( ONE+EPS )
  97.          END IF
  98.       END IF
  99. *
  100.       IF( LSAME( CMACH, 'E' ) ) THEN
  101.          RMACH = EPS
  102.       ELSE IF( LSAME( CMACH, 'S' ) ) THEN
  103.          RMACH = SFMIN
  104.       ELSE IF( LSAME( CMACH, 'B' ) ) THEN
  105.          RMACH = BASE
  106.       ELSE IF( LSAME( CMACH, 'P' ) ) THEN
  107.          RMACH = PREC
  108.       ELSE IF( LSAME( CMACH, 'N' ) ) THEN
  109.          RMACH = T
  110.       ELSE IF( LSAME( CMACH, 'R' ) ) THEN
  111.          RMACH = RND
  112.       ELSE IF( LSAME( CMACH, 'M' ) ) THEN
  113.          RMACH = EMIN
  114.       ELSE IF( LSAME( CMACH, 'U' ) ) THEN
  115.          RMACH = RMIN
  116.       ELSE IF( LSAME( CMACH, 'L' ) ) THEN
  117.          RMACH = EMAX
  118.       ELSE IF( LSAME( CMACH, 'O' ) ) THEN
  119.          RMACH = RMAX
  120.       END IF
  121. *
  122.       DLAMCH = RMACH
  123.       RETURN
  124. *
  125. *     End of DLAMCH
  126. *
  127.       END
  128.