Télécharger dlamch.eso

Retour à la liste

Numérotation des lignes :

  1. C DLAMCH SOURCE BP208322 20/09/18 21:15:57 10718
  2. FUNCTION DLAMCH( CMACH )
  3. *
  4. * -- LAPACK auxiliary routine (version 2.0) --
  5. * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
  6. * Courant Institute, Argonne National Lab, and Rice University
  7. * October 31, 1992
  8. *
  9. *
  10. * Purpose
  11. * =======
  12. *
  13. * DLAMCH determines REAL*8 machine parameters.
  14. *
  15. * Arguments
  16. * =========
  17. *
  18. * CMACH (input) CHARACTER*1
  19. * Specifies the value to be returned by DLAMCH:
  20. * = 'E' or 'e', DLAMCH := eps
  21. * = 'S' or 's , DLAMCH := sfmin
  22. * = 'B' or 'b', DLAMCH := base
  23. * = 'P' or 'p', DLAMCH := eps*base
  24. * = 'N' or 'n', DLAMCH := t
  25. * = 'R' or 'r', DLAMCH := rnd
  26. * = 'M' or 'm', DLAMCH := emin
  27. * = 'U' or 'u', DLAMCH := rmin
  28. * = 'L' or 'l', DLAMCH := emax
  29. * = 'O' or 'o', DLAMCH := rmax
  30. *
  31. * where
  32. *
  33. * eps = relative machine precision
  34. * sfmin = safe minimum, such that 1/sfmin does not overflow
  35. * base = base of the machine
  36. * prec = eps*base
  37. * t = number of (base) digits in the mantissa
  38. * rnd = 1.0 when rounding occurs in addition, 0.0 otherwise
  39. * emin = minimum exponent before (gradual) underflow
  40. * rmin = underflow threshold - base**(emin-1)
  41. * emax = largest exponent before overflow
  42. * rmax = overflow threshold - (base**emax)*(1-eps)
  43. *
  44. * =====================================================================
  45.  
  46. ************************************************************************
  47. *Note: la fonction a ete entierement revue pour etre compatible avec le
  48. *script compil.sh (utilisation de fonctions intrinsèques au fortran 95)
  49. ************************************************************************
  50.  
  51. IMPLICIT INTEGER(I-N)
  52. IMPLICIT REAL*8(A-H,O-Z)
  53.  
  54. -INC CCREEL
  55. -INC PPARAM
  56. -INC CCOPTIO
  57.  
  58. CHARACTER CMACH
  59. REAL*8 LAMCH,DLAMCH
  60. REAL*8 SMALL
  61. REAL*8 EPS,RND,SFMIN
  62. REAL*8 SFMIN1,SFMIN2,SFMIN4,SFMIN10
  63.  
  64. REAL*8 ONE
  65. PARAMETER (ONE = 1.D0)
  66.  
  67. RND=ONE
  68.  
  69. IF (ONE .EQ. RND) THEN
  70.  
  71. c EPS=EPSILON(XZERO)*0.5D0
  72. EPS=XZPREC*0.5D0
  73. ELSE
  74.  
  75. c EPS=EPSILON(XZERO)
  76. EPS=XZPREC
  77. ENDIF
  78.  
  79.  
  80. IF (CMACH .EQ. 'E' .OR. CMACH .EQ. 'e') THEN
  81.  
  82. LAMCH=EPS
  83.  
  84. ELSEIF (CMACH .EQ. 'S'.OR. CMACH .EQ. 's') THEN
  85.  
  86. c SFMIN=TINY(XZERO)
  87. SFMIN=XPETIT
  88.  
  89. c SMALL = ONE / HUGE(XZERO)
  90. SMALL=ONE / XGRAND
  91.  
  92. IF (SMALL .GE. SFMIN) THEN
  93.  
  94. SFMIN=SMALL*( ONE + EPS )
  95. c SFMIN=SMALL*( ONE + XZPREC )
  96.  
  97. ENDIF
  98. LAMCH=SFMIN
  99.  
  100. ELSEIF (CMACH .EQ. 'B'.OR. CMACH .EQ. 'b') THEN
  101.  
  102. c LAMCH=RADIX(XZERO)
  103. LAMCH=2.D0
  104.  
  105. ELSEIF (CMACH .EQ. 'P'.OR. CMACH .EQ. 'p') THEN
  106.  
  107. c LAMCH=EPSILON(XZERO)*RADIX(XZERO)
  108. LAMCH=XZPREC*2.D0
  109.  
  110.  
  111. ************************************************************************
  112. *Les options qui suivent sont mises en commentaire car impliquent du
  113. *fortran 95
  114. ************************************************************************
  115.  
  116. c ELSEIF (CMACH .EQ. 'N'.OR. CMACH .EQ. 'n') THEN
  117. c
  118. c LAMCH=DIGITS(XZERO)
  119. c
  120. c ELSEIF (CMACH .EQ. 'R'.OR. CMACH .EQ. 'r') THEN
  121. c
  122. c LAMCH=MINEXPONENT(XZERO)
  123. c
  124. c ELSEIF (CMACH .EQ. 'M'.OR. CMACH .EQ. 'm') THEN
  125. c
  126. c LAMCH=TINY(XZERO)
  127. c
  128. c ELSEIF (CMACH .EQ. 'U'.OR. CMACH .EQ. 'u') THEN
  129. c
  130. c LAMCH=MINEXPONENT(XZERO)
  131. c
  132. c ELSEIF (CMACH .EQ. 'L'.OR. CMACH .EQ. 'l') THEN
  133. c
  134. c LAMCH=MAXEXPONENT(XZERO)
  135.  
  136. ELSEIF (CMACH .EQ. 'O'.OR. CMACH .EQ. 'o') THEN
  137.  
  138. c LAMCH=HUGE(XZERO)
  139. LAMCH=XGRAND
  140.  
  141. ELSE
  142.  
  143. LAMCH=XZERO
  144. write(*,*) 'DLAMCH(',CMACH,')= non prévu !'
  145. CALL ERREUR(5)
  146.  
  147. ENDIF
  148.  
  149. DLAMCH=LAMCH
  150.  
  151. RETURN
  152.  
  153. END
  154.  
  155.  
  156.  
  157.  
  158.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales