1
2
3
4
5
6
7
8
9
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
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
|
REAL FUNCTION R1MACH(I)
INTEGER I
C
C SINGLE-PRECISION MACHINE CONSTANTS
C R1MACH(1) = B**(EMIN-1), THE SMALLEST POSITIVE MAGNITUDE.
C R1MACH(2) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE.
C R1MACH(3) = B**(-T), THE SMALLEST RELATIVE SPACING.
C R1MACH(4) = B**(1-T), THE LARGEST RELATIVE SPACING.
C R1MACH(5) = LOG10(B)
C
INTEGER SMALL(2)
INTEGER LARGE(2)
INTEGER RIGHT(2)
INTEGER DIVER(2)
INTEGER LOG10(2)
C needs to be (2) for AUTODOUBLE, HARRIS SLASH 6, ...
INTEGER SC
SAVE SMALL, LARGE, RIGHT, DIVER, LOG10, SC
REAL RMACH(5)
EQUIVALENCE (RMACH(1),SMALL(1))
EQUIVALENCE (RMACH(2),LARGE(1))
EQUIVALENCE (RMACH(3),RIGHT(1))
EQUIVALENCE (RMACH(4),DIVER(1))
EQUIVALENCE (RMACH(5),LOG10(1))
INTEGER J, K, L, T3E(3)
DATA T3E(1) / 9777664 /
DATA T3E(2) / 5323660 /
DATA T3E(3) / 46980 /
C THIS VERSION ADAPTS AUTOMATICALLY TO MOST CURRENT MACHINES,
C INCLUDING AUTO-DOUBLE COMPILERS.
C TO COMPILE ON OLDER MACHINES, ADD A C IN COLUMN 1
C ON THE NEXT LINE
DATA SC/0/
C AND REMOVE THE C FROM COLUMN 1 IN ONE OF THE SECTIONS BELOW.
C CONSTANTS FOR EVEN OLDER MACHINES CAN BE OBTAINED BY
C mail netlib@research.bell-labs.com
C send old1mach from blas
C PLEASE SEND CORRECTIONS TO dmg OR ehg@bell-labs.com.
C
C MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES.
C DATA RMACH(1) / O402400000000 /
C DATA RMACH(2) / O376777777777 /
C DATA RMACH(3) / O714400000000 /
C DATA RMACH(4) / O716400000000 /
C DATA RMACH(5) / O776464202324 /, SC/987/
C
C MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING
C 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL).
C DATA SMALL(1) / 8388608 /
C DATA LARGE(1) / 2147483647 /
C DATA RIGHT(1) / 880803840 /
C DATA DIVER(1) / 889192448 /
C DATA LOG10(1) / 1067065499 /, SC/987/
C DATA RMACH(1) / O00040000000 /
C DATA RMACH(2) / O17777777777 /
C DATA RMACH(3) / O06440000000 /
C DATA RMACH(4) / O06500000000 /
C DATA RMACH(5) / O07746420233 /, SC/987/
C
C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES.
C DATA RMACH(1) / O000400000000 /
C DATA RMACH(2) / O377777777777 /
C DATA RMACH(3) / O146400000000 /
C DATA RMACH(4) / O147400000000 /
C DATA RMACH(5) / O177464202324 /, SC/987/
C
IF (SC .NE. 987) THEN
* *** CHECK FOR AUTODOUBLE ***
SMALL(2) = 0
RMACH(1) = 1E13
IF (SMALL(2) .NE. 0) THEN
* *** AUTODOUBLED ***
IF ( SMALL(1) .EQ. 1117925532
* .AND. SMALL(2) .EQ. -448790528) THEN
* *** IEEE BIG ENDIAN ***
SMALL(1) = 1048576
SMALL(2) = 0
LARGE(1) = 2146435071
LARGE(2) = -1
RIGHT(1) = 1017118720
RIGHT(2) = 0
DIVER(1) = 1018167296
DIVER(2) = 0
LOG10(1) = 1070810131
LOG10(2) = 1352628735
ELSE IF ( SMALL(2) .EQ. 1117925532
* .AND. SMALL(1) .EQ. -448790528) THEN
* *** IEEE LITTLE ENDIAN ***
SMALL(2) = 1048576
SMALL(1) = 0
LARGE(2) = 2146435071
LARGE(1) = -1
RIGHT(2) = 1017118720
RIGHT(1) = 0
DIVER(2) = 1018167296
DIVER(1) = 0
LOG10(2) = 1070810131
LOG10(1) = 1352628735
ELSE IF ( SMALL(1) .EQ. -2065213935
* .AND. SMALL(2) .EQ. 10752) THEN
* *** VAX WITH D_FLOATING ***
SMALL(1) = 128
SMALL(2) = 0
LARGE(1) = -32769
LARGE(2) = -1
RIGHT(1) = 9344
RIGHT(2) = 0
DIVER(1) = 9472
DIVER(2) = 0
LOG10(1) = 546979738
LOG10(2) = -805796613
ELSE IF ( SMALL(1) .EQ. 1267827943
* .AND. SMALL(2) .EQ. 704643072) THEN
* *** IBM MAINFRAME ***
SMALL(1) = 1048576
SMALL(2) = 0
LARGE(1) = 2147483647
LARGE(2) = -1
RIGHT(1) = 856686592
RIGHT(2) = 0
DIVER(1) = 873463808
DIVER(2) = 0
LOG10(1) = 1091781651
LOG10(2) = 1352628735
ELSE
WRITE(*,9010)
STOP 777
END IF
ELSE
RMACH(1) = 1234567.
IF (SMALL(1) .EQ. 1234613304) THEN
* *** IEEE ***
SMALL(1) = 8388608
LARGE(1) = 2139095039
RIGHT(1) = 864026624
DIVER(1) = 872415232
LOG10(1) = 1050288283
ELSE IF (SMALL(1) .EQ. -1271379306) THEN
* *** VAX ***
SMALL(1) = 128
LARGE(1) = -32769
RIGHT(1) = 13440
DIVER(1) = 13568
LOG10(1) = 547045274
ELSE IF (SMALL(1) .EQ. 1175639687) THEN
* *** IBM MAINFRAME ***
SMALL(1) = 1048576
LARGE(1) = 2147483647
RIGHT(1) = 990904320
DIVER(1) = 1007681536
LOG10(1) = 1091781651
ELSE IF (SMALL(1) .EQ. 1251390520) THEN
* *** CONVEX C-1 ***
SMALL(1) = 8388608
LARGE(1) = 2147483647
RIGHT(1) = 880803840
DIVER(1) = 889192448
LOG10(1) = 1067065499
ELSE
DO 10 L = 1, 3
J = SMALL(1) / 10000000
K = SMALL(1) - 10000000*J
IF (K .NE. T3E(L)) GO TO 20
SMALL(1) = J
10 CONTINUE
* *** CRAY T3E ***
CALL I1MCRA(SMALL, K, 16, 0, 0)
CALL I1MCRA(LARGE, K, 32751, 16777215, 16777215)
CALL I1MCRA(RIGHT, K, 15520, 0, 0)
CALL I1MCRA(DIVER, K, 15536, 0, 0)
CALL I1MCRA(LOG10, K, 16339, 4461392, 10451455)
GO TO 30
20 CALL I1MCRA(J, K, 16405, 9876536, 0)
IF (SMALL(1) .NE. J) THEN
WRITE(*,9020)
STOP 777
END IF
* *** CRAY 1, XMP, 2, AND 3 ***
CALL I1MCRA(SMALL(1), K, 8195, 8388608, 1)
CALL I1MCRA(LARGE(1), K, 24574, 16777215, 16777214)
CALL I1MCRA(RIGHT(1), K, 16338, 8388608, 0)
CALL I1MCRA(DIVER(1), K, 16339, 8388608, 0)
CALL I1MCRA(LOG10(1), K, 16383, 10100890, 8715216)
END IF
END IF
30 SC = 987
END IF
* SANITY CHECK
IF (RMACH(4) .GE. 1.0) STOP 776
IF (I .LT. 1 .OR. I .GT. 5) THEN
WRITE(*,*) 'R1MACH(I): I =',I,' is out of bounds.'
STOP
END IF
R1MACH = RMACH(I)
RETURN
9010 FORMAT(/' Adjust autodoubled R1MACH by getting data'/
*' appropriate for your machine from D1MACH.')
9020 FORMAT(/' Adjust R1MACH by uncommenting data statements'/
*' appropriate for your machine.')
* /* C source for R1MACH -- remove the * in column 1 */
*#include <stdio.h>
*#include <float.h>
*#include <math.h>
*float r1mach_(long *i)
*{
* switch(*i){
* case 1: return FLT_MIN;
* case 2: return FLT_MAX;
* case 3: return FLT_EPSILON/FLT_RADIX;
* case 4: return FLT_EPSILON;
* case 5: return log10((double)FLT_RADIX);
* }
* fprintf(stderr, "invalid argument: r1mach(%ld)\n", *i);
* exit(1); return 0; /* else complaint of missing return value */
*}
END
SUBROUTINE I1MCRA(A, A1, B, C, D)
**** SPECIAL COMPUTATION FOR CRAY MACHINES ****
INTEGER A, A1, B, C, D
A1 = 16777216*B + C
A = 16777216*A1 + D
END
|
