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 *#include *#include *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