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