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