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