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