##// END OF EJS Templates
schain
RSS
add Ffiles
add Ffiles
rflores - - Load All Authors

File last commit:

r1601:3b2826fe0d97
r1601:3b2826fe0d97
Show More
r1mach.f
222 lines | 7.7 KiB | text/x-fortran | FortranFixedLexer
/ schainf / fit_acf / r1mach.f
History | Source | Raw |Copy content |Copy permalink
rflores
add Ffiles
 r1601 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