QPMS
/
qpms
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
qpms/amos/i1mach.f

292 lines
9.5 KiB
Fortran
Raw Permalink Blame History

INTEGER FUNCTION I1MACH(I)
INTEGER I
C
C I1MACH( 1) = THE STANDARD INPUT UNIT.
C I1MACH( 2) = THE STANDARD OUTPUT UNIT.
C I1MACH( 3) = THE STANDARD PUNCH UNIT.
C I1MACH( 4) = THE STANDARD ERROR MESSAGE UNIT.
C I1MACH( 5) = THE NUMBER OF BITS PER INTEGER STORAGE UNIT.
C I1MACH( 6) = THE NUMBER OF CHARACTERS PER CHARACTER STORAGE UNIT.
C INTEGERS HAVE FORM SIGN ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) )
C I1MACH( 7) = A, THE BASE.
C I1MACH( 8) = S, THE NUMBER OF BASE-A DIGITS.
C I1MACH( 9) = A**S - 1, THE LARGEST MAGNITUDE.
C FLOATS HAVE FORM SIGN (B**E)*( (X(1)/B) + ... + (X(T)/B**T) )
C WHERE EMIN .LE. E .LE. EMAX.
C I1MACH(10) = B, THE BASE.
C SINGLE-PRECISION
C I1MACH(11) = T, THE NUMBER OF BASE-B DIGITS.
C I1MACH(12) = EMIN, THE SMALLEST EXPONENT E.
C I1MACH(13) = EMAX, THE LARGEST EXPONENT E.
C DOUBLE-PRECISION
C I1MACH(14) = T, THE NUMBER OF BASE-B DIGITS.
C I1MACH(15) = EMIN, THE SMALLEST EXPONENT E.
C I1MACH(16) = EMAX, THE LARGEST EXPONENT E.
C
INTEGER IMACH(16), OUTPUT, SC, SMALL(2)
SAVE IMACH, SC
REAL RMACH
EQUIVALENCE (IMACH(4),OUTPUT), (RMACH,SMALL(1))
INTEGER I3, J, K, 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
C DATA IMACH( 1) / 5 /
C DATA IMACH( 2) / 6 /
C DATA IMACH( 3) / 43 /
C DATA IMACH( 4) / 6 /
C DATA IMACH( 5) / 36 /
C DATA IMACH( 6) / 4 /
C DATA IMACH( 7) / 2 /
C DATA IMACH( 8) / 35 /
C DATA IMACH( 9) / O377777777777 /
C DATA IMACH(10) / 2 /
C DATA IMACH(11) / 27 /
C DATA IMACH(12) / -127 /
C DATA IMACH(13) / 127 /
C DATA IMACH(14) / 63 /
C DATA IMACH(15) / -127 /
C DATA IMACH(16) / 127 /, SC/987/
C
C MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING
C 32-BIT INTEGER ARITHMETIC.
C
C DATA IMACH( 1) / 5 /
C DATA IMACH( 2) / 6 /
C DATA IMACH( 3) / 7 /
C DATA IMACH( 4) / 6 /
C DATA IMACH( 5) / 32 /
C DATA IMACH( 6) / 4 /
C DATA IMACH( 7) / 2 /
C DATA IMACH( 8) / 31 /
C DATA IMACH( 9) / 2147483647 /
C DATA IMACH(10) / 2 /
C DATA IMACH(11) / 24 /
C DATA IMACH(12) / -127 /
C DATA IMACH(13) / 127 /
C DATA IMACH(14) / 56 /
C DATA IMACH(15) / -127 /
C DATA IMACH(16) / 127 /, SC/987/
C
C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES.
C
C NOTE THAT THE PUNCH UNIT, I1MACH(3), HAS BEEN SET TO 7
C WHICH IS APPROPRIATE FOR THE UNIVAC-FOR SYSTEM.
C IF YOU HAVE THE UNIVAC-FTN SYSTEM, SET IT TO 1.
C
C DATA IMACH( 1) / 5 /
C DATA IMACH( 2) / 6 /
C DATA IMACH( 3) / 7 /
C DATA IMACH( 4) / 6 /
C DATA IMACH( 5) / 36 /
C DATA IMACH( 6) / 6 /
C DATA IMACH( 7) / 2 /
C DATA IMACH( 8) / 35 /
C DATA IMACH( 9) / O377777777777 /
C DATA IMACH(10) / 2 /
C DATA IMACH(11) / 27 /
C DATA IMACH(12) / -128 /
C DATA IMACH(13) / 127 /
C DATA IMACH(14) / 60 /
C DATA IMACH(15) /-1024 /
C DATA IMACH(16) / 1023 /, SC/987/
C
IF (SC .NE. 987) THEN
* *** CHECK FOR AUTODOUBLE ***
SMALL(2) = 0
RMACH = 1E13
IF (SMALL(2) .NE. 0) THEN
* *** AUTODOUBLED ***
IF ( (SMALL(1) .EQ. 1117925532
* .AND. SMALL(2) .EQ. -448790528)
* .OR. (SMALL(2) .EQ. 1117925532
* .AND. SMALL(1) .EQ. -448790528)) THEN
* *** IEEE ***
IMACH(10) = 2
IMACH(14) = 53
IMACH(15) = -1021
IMACH(16) = 1024
ELSE IF ( SMALL(1) .EQ. -2065213935
* .AND. SMALL(2) .EQ. 10752) THEN
* *** VAX WITH D_FLOATING ***
IMACH(10) = 2
IMACH(14) = 56
IMACH(15) = -127
IMACH(16) = 127
ELSE IF ( SMALL(1) .EQ. 1267827943
* .AND. SMALL(2) .EQ. 704643072) THEN
* *** IBM MAINFRAME ***
IMACH(10) = 16
IMACH(14) = 14
IMACH(15) = -64
IMACH(16) = 63
ELSE
WRITE(*,9010)
STOP 777
END IF
IMACH(11) = IMACH(14)
IMACH(12) = IMACH(15)
IMACH(13) = IMACH(16)
ELSE
RMACH = 1234567.
IF (SMALL(1) .EQ. 1234613304) THEN
* *** IEEE ***
IMACH(10) = 2
IMACH(11) = 24
IMACH(12) = -125
IMACH(13) = 128
IMACH(14) = 53
IMACH(15) = -1021
IMACH(16) = 1024
SC = 987
ELSE IF (SMALL(1) .EQ. -1271379306) THEN
* *** VAX ***
IMACH(10) = 2
IMACH(11) = 24
IMACH(12) = -127
IMACH(13) = 127
IMACH(14) = 56
IMACH(15) = -127
IMACH(16) = 127
SC = 987
ELSE IF (SMALL(1) .EQ. 1175639687) THEN
* *** IBM MAINFRAME ***
IMACH(10) = 16
IMACH(11) = 6
IMACH(12) = -64
IMACH(13) = 63
IMACH(14) = 14
IMACH(15) = -64
IMACH(16) = 63
SC = 987
ELSE IF (SMALL(1) .EQ. 1251390520) THEN
* *** CONVEX C-1 ***
IMACH(10) = 2
IMACH(11) = 24
IMACH(12) = -128
IMACH(13) = 127
IMACH(14) = 53
IMACH(15) = -1024
IMACH(16) = 1023
ELSE
DO 10 I3 = 1, 3
J = SMALL(1) / 10000000
K = SMALL(1) - 10000000*J
IF (K .NE. T3E(I3)) GO TO 20
SMALL(1) = J
10 CONTINUE
* *** CRAY T3E ***
IMACH( 1) = 5
IMACH( 2) = 6
IMACH( 3) = 0
IMACH( 4) = 0
IMACH( 5) = 64
IMACH( 6) = 8
IMACH( 7) = 2
IMACH( 8) = 63
CALL I1MCR1(IMACH(9), K, 32767, 16777215, 16777215)
IMACH(10) = 2
IMACH(11) = 53
IMACH(12) = -1021
IMACH(13) = 1024
IMACH(14) = 53
IMACH(15) = -1021
IMACH(16) = 1024
GO TO 35
20 CALL I1MCR1(J, K, 16405, 9876536, 0)
IF (SMALL(1) .NE. J) THEN
WRITE(*,9020)
STOP 777
END IF
* *** CRAY 1, XMP, 2, AND 3 ***
IMACH(1) = 5
IMACH(2) = 6
IMACH(3) = 102
IMACH(4) = 6
IMACH(5) = 46
IMACH(6) = 8
IMACH(7) = 2
IMACH(8) = 45
CALL I1MCR1(IMACH(9), K, 0, 4194303, 16777215)
IMACH(10) = 2
IMACH(11) = 47
IMACH(12) = -8188
IMACH(13) = 8189
IMACH(14) = 94
IMACH(15) = -8141
IMACH(16) = 8189
GO TO 35
END IF
END IF
IMACH( 1) = 5
IMACH( 2) = 6
IMACH( 3) = 7
IMACH( 4) = 6
IMACH( 5) = 32
IMACH( 6) = 4
IMACH( 7) = 2
IMACH( 8) = 31
IMACH( 9) = 2147483647
35 SC = 987
END IF
9010 FORMAT(/' Adjust autodoubled I1MACH by uncommenting data'/
* ' statements appropriate for your machine and setting'/
* ' IMACH(I) = IMACH(I+3) for I = 11, 12, and 13.')
9020 FORMAT(/' Adjust I1MACH by uncommenting data statements'/
* ' appropriate for your machine.')
IF (I .LT. 1 .OR. I .GT. 16) GO TO 40
I1MACH = IMACH(I)
RETURN
40 WRITE(*,*) 'I1MACH(I): I =',I,' is out of bounds.'
STOP
* /* C source for I1MACH -- remove the * in column 1 */
* /* Note that some values may need changing. */
*#include <stdio.h>
*#include <float.h>
*#include <limits.h>
*#include <math.h>
*
*long i1mach_(long *i)
*{
* switch(*i){
* case 1: return 5; /* standard input */
* case 2: return 6; /* standard output */
* case 3: return 7; /* standard punch */
* case 4: return 0; /* standard error */
* case 5: return 32; /* bits per integer */
* case 6: return sizeof(int);
* case 7: return 2; /* base for integers */
* case 8: return 31; /* digits of integer base */
* case 9: return LONG_MAX;
* case 10: return FLT_RADIX;
* case 11: return FLT_MANT_DIG;
* case 12: return FLT_MIN_EXP;
* case 13: return FLT_MAX_EXP;
* case 14: return DBL_MANT_DIG;
* case 15: return DBL_MIN_EXP;
* case 16: return DBL_MAX_EXP;
* }
* fprintf(stderr, "invalid argument: i1mach(%ld)\n", *i);
* exit(1);return 0; /* some compilers demand return values */
*}
END
SUBROUTINE I1MCR1(A, A1, B, C, D)
**** SPECIAL COMPUTATION FOR OLD CRAY MACHINES ****
INTEGER A, A1, B, C, D
A1 = 16777216*B + C
A = 16777216*A1 + D
END
Reference in New Issue View Git Blame Copy Permalink