222 lines
7.7 KiB
Fortran
222 lines
7.7 KiB
Fortran
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 <stdio.h>
|
|
*#include <float.h>
|
|
*#include <math.h>
|
|
*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
|