2
    3
    4
    5
    6
    7
    8
    9      CHARACTER          CMACH
   10
   11
   12
   13
   14
   15
   16
   17
   18
   19
   20
   21
   22
   23
   24
   25
   26
   27
   28
   29
   30
   31
   32
   33
   34
   35
   36
   37
   38
   39
   40
   41
   42
   43
   44
   45
   46
   47
   48
   49      DOUBLE PRECISION   ONE, ZERO
   50      parameter( one = 1.0d+0, zero = 0.0d+0 )
   51
   52
   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
   59      LOGICAL            LSAME
   61
   62
   64
   65
   66      SAVE               first, eps, sfmin, base, t, rnd, emin, rmin,
   67     $                   emax, rmax, prec
   68
   69
   70      DATA               first / .true. /
   71
   72
   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
   94
   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
  123      RETURN
  124
  125
  126