1      DOUBLE PRECISION FUNCTION D1MACH(I)
2      INTEGER I
3C
4C  DOUBLE-PRECISION MACHINE CONSTANTS
5C  D1MACH( 1) = B**(EMIN-1), THE SMALLEST POSITIVE MAGNITUDE.
6C  D1MACH( 2) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE.
7C  D1MACH( 3) = B**(-T), THE SMALLEST RELATIVE SPACING.
8C  D1MACH( 4) = B**(1-T), THE LARGEST RELATIVE SPACING.
9C  D1MACH( 5) = LOG10(B)
10C
11      INTEGER SMALL(2)
12      INTEGER LARGE(2)
13      INTEGER RIGHT(2)
14      INTEGER DIVER(2)
15      INTEGER LOG10(2)
16      INTEGER SC, CRAY1(38), J
17      COMMON /D9MACH/ CRAY1
18      SAVE SMALL, LARGE, RIGHT, DIVER, LOG10, SC
19      DOUBLE PRECISION DMACH(5)
20      EQUIVALENCE (DMACH(1),SMALL(1))
21      EQUIVALENCE (DMACH(2),LARGE(1))
22      EQUIVALENCE (DMACH(3),RIGHT(1))
23      EQUIVALENCE (DMACH(4),DIVER(1))
24      EQUIVALENCE (DMACH(5),LOG10(1))
25C  THIS VERSION ADAPTS AUTOMATICALLY TO MOST CURRENT MACHINES.
26C  R1MACH CAN HANDLE AUTO-DOUBLE COMPILING, BUT THIS VERSION OF
27C  D1MACH DOES NOT, BECAUSE WE DO NOT HAVE QUAD CONSTANTS FOR
28C  MANY MACHINES YET.
29C  TO COMPILE ON OLDER MACHINES, ADD A C IN COLUMN 1
30C  ON THE NEXT LINE
31      DATA SC/0/
32C  AND REMOVE THE C FROM COLUMN 1 IN ONE OF THE SECTIONS BELOW.
33C  CONSTANTS FOR EVEN OLDER MACHINES CAN BE OBTAINED BY
34C          mail netlib@research.bell-labs.com
35C          send old1mach from blas
36C  PLEASE SEND CORRECTIONS TO dmg OR ehg@bell-labs.com.
37C
38C     MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES.
39C      DATA SMALL(1),SMALL(2) / O402400000000, O000000000000 /
40C      DATA LARGE(1),LARGE(2) / O376777777777, O777777777777 /
41C      DATA RIGHT(1),RIGHT(2) / O604400000000, O000000000000 /
42C      DATA DIVER(1),DIVER(2) / O606400000000, O000000000000 /
43C      DATA LOG10(1),LOG10(2) / O776464202324, O117571775714 /, SC/987/
44C
45C     MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING
46C     32-BIT INTEGERS.
47C      DATA SMALL(1),SMALL(2) /    8388608,           0 /
48C      DATA LARGE(1),LARGE(2) / 2147483647,          -1 /
49C      DATA RIGHT(1),RIGHT(2) /  612368384,           0 /
50C      DATA DIVER(1),DIVER(2) /  620756992,           0 /
51C      DATA LOG10(1),LOG10(2) / 1067065498, -2063872008 /, SC/987/
52C
53C     MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES.
54C      DATA SMALL(1),SMALL(2) / O000040000000, O000000000000 /
55C      DATA LARGE(1),LARGE(2) / O377777777777, O777777777777 /
56C      DATA RIGHT(1),RIGHT(2) / O170540000000, O000000000000 /
57C      DATA DIVER(1),DIVER(2) / O170640000000, O000000000000 /
58C      DATA LOG10(1),LOG10(2) / O177746420232, O411757177572 /, SC/987/
59C
60C     ON FIRST CALL, IF NO DATA UNCOMMENTED, TEST MACHINE TYPES.
61      IF (SC .NE. 987) THEN
62         DMACH(1) = 1.D13
63         IF (      SMALL(1) .EQ. 1117925532
64     *       .AND. SMALL(2) .EQ. -448790528) THEN
65*           *** IEEE BIG ENDIAN ***
66            SMALL(1) = 1048576
67            SMALL(2) = 0
68            LARGE(1) = 2146435071
69            LARGE(2) = -1
70            RIGHT(1) = 1017118720
71            RIGHT(2) = 0
72            DIVER(1) = 1018167296
73            DIVER(2) = 0
74            LOG10(1) = 1070810131
75            LOG10(2) = 1352628735
76         ELSE IF ( SMALL(2) .EQ. 1117925532
77     *       .AND. SMALL(1) .EQ. -448790528) THEN
78*           *** IEEE LITTLE ENDIAN ***
79            SMALL(2) = 1048576
80            SMALL(1) = 0
81            LARGE(2) = 2146435071
82            LARGE(1) = -1
83            RIGHT(2) = 1017118720
84            RIGHT(1) = 0
85            DIVER(2) = 1018167296
86            DIVER(1) = 0
87            LOG10(2) = 1070810131
88            LOG10(1) = 1352628735
89         ELSE IF ( SMALL(1) .EQ. -2065213935
90     *       .AND. SMALL(2) .EQ. 10752) THEN
91*               *** VAX WITH D_FLOATING ***
92            SMALL(1) = 128
93            SMALL(2) = 0
94            LARGE(1) = -32769
95            LARGE(2) = -1
96            RIGHT(1) = 9344
97            RIGHT(2) = 0
98            DIVER(1) = 9472
99            DIVER(2) = 0
100            LOG10(1) = 546979738
101            LOG10(2) = -805796613
102         ELSE IF ( SMALL(1) .EQ. 1267827943
103     *       .AND. SMALL(2) .EQ. 704643072) THEN
104*               *** IBM MAINFRAME ***
105            SMALL(1) = 1048576
106            SMALL(2) = 0
107            LARGE(1) = 2147483647
108            LARGE(2) = -1
109            RIGHT(1) = 856686592
110            RIGHT(2) = 0
111            DIVER(1) = 873463808
112            DIVER(2) = 0
113            LOG10(1) = 1091781651
114            LOG10(2) = 1352628735
115         ELSE IF ( SMALL(1) .EQ. 1120022684
116     *       .AND. SMALL(2) .EQ. -448790528) THEN
117*           *** CONVEX C-1 ***
118            SMALL(1) = 1048576
119            SMALL(2) = 0
120            LARGE(1) = 2147483647
121            LARGE(2) = -1
122            RIGHT(1) = 1019215872
123            RIGHT(2) = 0
124            DIVER(1) = 1020264448
125            DIVER(2) = 0
126            LOG10(1) = 1072907283
127            LOG10(2) = 1352628735
128         ELSE IF ( SMALL(1) .EQ. 815547074
129     *       .AND. SMALL(2) .EQ. 58688) THEN
130*           *** VAX G-FLOATING ***
131            SMALL(1) = 16
132            SMALL(2) = 0
133            LARGE(1) = -32769
134            LARGE(2) = -1
135            RIGHT(1) = 15552
136            RIGHT(2) = 0
137            DIVER(1) = 15568
138            DIVER(2) = 0
139            LOG10(1) = 1142112243
140            LOG10(2) = 2046775455
141         ELSE
142            DMACH(2) = 1.D27 + 1
143            DMACH(3) = 1.D27
144            LARGE(2) = LARGE(2) - RIGHT(2)
145            IF (LARGE(2) .EQ. 64 .AND. SMALL(2) .EQ. 0) THEN
146               CRAY1(1) = 67291416
147               DO 10 J = 1, 20
148                  CRAY1(J+1) = CRAY1(J) + CRAY1(J)
149 10               CONTINUE
150               CRAY1(22) = CRAY1(21) + 321322
151               DO 20 J = 22, 37
152                  CRAY1(J+1) = CRAY1(J) + CRAY1(J)
153 20               CONTINUE
154               IF (CRAY1(38) .EQ. SMALL(1)) THEN
155*                  *** CRAY ***
156                  CALL I1MCRY(SMALL(1), J, 8285, 8388608, 0)
157                  SMALL(2) = 0
158                  CALL I1MCRY(LARGE(1), J, 24574, 16777215, 16777215)
159                  CALL I1MCRY(LARGE(2), J, 0, 16777215, 16777214)
160                  CALL I1MCRY(RIGHT(1), J, 16291, 8388608, 0)
161                  RIGHT(2) = 0
162                  CALL I1MCRY(DIVER(1), J, 16292, 8388608, 0)
163                  DIVER(2) = 0
164                  CALL I1MCRY(LOG10(1), J, 16383, 10100890, 8715215)
165                  CALL I1MCRY(LOG10(2), J, 0, 16226447, 9001388)
166               ELSE
167                  WRITE(*,9000)
168                  STOP 779
169                  END IF
170            ELSE
171               WRITE(*,9000)
172               STOP 779
173               END IF
174            END IF
175         SC = 987
176         END IF
177*    SANITY CHECK
178      IF (DMACH(4) .GE. 1.0D0) STOP 778
179      IF (I .LT. 1 .OR. I .GT. 5) THEN
180         WRITE(*,*) 'D1MACH(I): I =',I,' is out of bounds.'
181         STOP
182         END IF
183      D1MACH = DMACH(I)
184      RETURN
185 9000 FORMAT(/' Adjust D1MACH by uncommenting data statements'/
186     *' appropriate for your machine.')
187* /* Standard C source for D1MACH -- remove the * in column 1 */
188*#include <stdio.h>
189*#include <float.h>
190*#include <math.h>
191*double d1mach_(long *i)
192*{
193*	switch(*i){
194*	  case 1: return DBL_MIN;
195*	  case 2: return DBL_MAX;
196*	  case 3: return DBL_EPSILON/FLT_RADIX;
197*	  case 4: return DBL_EPSILON;
198*	  case 5: return log10((double)FLT_RADIX);
199*	  }
200*	fprintf(stderr, "invalid argument: d1mach(%ld)\n", *i);
201*	exit(1); return 0; /* some compilers demand return values */
202*}
203      END
204      SUBROUTINE I1MCRY(A, A1, B, C, D)
205**** SPECIAL COMPUTATION FOR OLD CRAY MACHINES ****
206      INTEGER A, A1, B, C, D
207      A1 = 16777216*B + C
208      A = 16777216*A1 + D
209      END
210