src/LAPACK/dlamch.f

   1       FUNCTION DLAMCH ( CMACH ) RESULT(RMACH)
   2 !
   3 !  -- LAPACK auxiliary routine Replacement for DLAMCH.f
   4 !     use Fortran 90 Machine Parameter built-in functions.
   5 !
   6       character(len=1) :: CMACH
   7       real(kind(1.d0)) :: xdbl, ydbl, RMACH
   8 !
   9 !  Purpose
  10 !  =======
  11 !
  12 !
  13 !  DLAMCH determines double precision 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 !
  34 ! =====================================================================
  35       xdbl=1.d0
  36       IF( CMACH == 'E' .or. CMACH == 'e' ) THEN
  37 !          eps   = relative machine precision
  38          RMACH = Epsilon(xdbl)
  39       ELSE IF( CMACH == 'S' .or. CMACH == 's' ) THEN
  40 !          sfmin = safe minimum, such that 1/sfmin does not overflow
  41          RMACH = Tiny(xdbl)
  42       ELSE IF( CMACH == 'B' .or. CMACH == 'b' ) THEN
  43 !          base  = base of the machine
  44          RMACH = Radix(xdbl)
  45       ELSE IF( CMACH == 'P' .or. CMACH == 'p' ) THEN
  46 !          prec  = eps*base
  47          RMACH = Radix(xdbl)*Epsilon(xdbl)
  48       ELSE IF( CMACH == 'N' .or. CMACH == 'n' ) THEN
  49 !          t     = number of (base) digits in the mantissa
  50          RMACH = Digits(xdbl)
  51       ELSE IF( CMACH == 'R' .or. CMACH == 'r' ) THEN
  52 !          rnd   = 1.0 when rounding occurs in addition, 0.0 otherwise
  53 !          Assume rounding (IEEE).
  54          RMACH = 1.0
  55       ELSE IF( CMACH == 'M' .or. CMACH == 'm' ) THEN
  56 !          emin  = minimum exponent before (gradual) underflow
  57          RMACH = Minexponent(xdbl)
  58       ELSE IF( CMACH == 'U' .or. CMACH == 'u' ) THEN
  59 !          rmin  = underflow threshold - base**(emin-1)
  60          RMACH = Tiny(xdbl)
  61       ELSE IF( CMACH == 'L' .or. CMACH == 'l' ) THEN
  62 !          emax  = largest exponent before overflow
  63          RMACH = Maxexponent(xdbl)
  64       ELSE IF( CMACH == 'O' .or. CMACH == 'o' ) THEN
  65 !          rmax  = overflow threshold  - (base**emax)*(1-eps)
  66          RMACH = Huge(xdbl)
  67       END IF
  68 !
  69       END
  70
  71 *
  72 ************************************************************************
  73 *
  74       DOUBLE PRECISION FUNCTION DLAMC3( A, B )
  75 *
  76 *  -- LAPACK auxiliary routine (version 3.1) --
  77 *     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
  78 *     November 2006
  79 *
  80 *     .. Scalar Arguments ..
  81       DOUBLE PRECISION   A, B
  82 *
  83 *     .. Local variables ..
  84       INTEGER I
  85       DOUBLE PRECISION X(10),Y(10)
  86 *     ..
  87 *
  88 *  Purpose
  89 *  =======
  90 *
  91 *  DLAMC3  is intended to force  A  and  B  to be stored prior to doing
  92 *  the addition of  A  and  B ,  for use in situations where optimizers
  93 *  might hold one of these in a register.
  94 *
  95 *  Arguments
  96 *  =========
  97 *
  98 *  A       (input) DOUBLE PRECISION
  99 *  B       (input) DOUBLE PRECISION
 100 *          The values A and B.
 101 *
 102 * =====================================================================
 103 *
 104 *     .. Executable Statements ..
 105 *
 106 *      DLAMC3 = A + B
 107
 108 *     Modification by JKD to ensure variables are flushed to memory
 109       DO I=1,10
 110         X(I)=A
 111       END DO
 112       DO I=1,10
 113         Y(I)=X(I)+B
 114       END DO
 115       DLAMC3=Y(10)
 116 *
 117       RETURN
 118 *
 119 *     End of DLAMC3
 120 *
 121       END
 122