d1mach.f

Go to the documentation of this file. Or view the newest version in sPHENIX GitHub for file d1mach.f

      DOUBLE PRECISION FUNCTION d1mach(I)
      INTEGER i
C
C  DOUBLE-PRECISION MACHINE CONSTANTS
C  D1MACH( 1) = B**(EMIN-1), THE SMALLEST POSITIVE MAGNITUDE.
C  D1MACH( 2) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE.
C  D1MACH( 3) = B**(-T), THE SMALLEST RELATIVE SPACING.
C  D1MACH( 4) = B**(1-T), THE LARGEST RELATIVE SPACING.
C  D1MACH( 5) = LOG10(B)
C
      INTEGER small(2)
      INTEGER large(2)
      INTEGER right(2)
      INTEGER diver(2)
      INTEGER log10(2)
      INTEGER sc, cray1(38), j
      COMMON /d9mach/ cray1
      SAVE small, large, right, diver, log10, sc
      DOUBLE PRECISION dmach(5)
      equivalence(dmach(1),small(1))
      equivalence(dmach(2),large(1))
      equivalence(dmach(3),right(1))
      equivalence(dmach(4),diver(1))
      equivalence(dmach(5),log10(1))
C  THIS VERSION ADAPTS AUTOMATICALLY TO MOST CURRENT MACHINES.
C  R1MACH CAN HANDLE AUTO-DOUBLE COMPILING, BUT THIS VERSION OF
C  D1MACH DOES NOT, BECAUSE WE DO NOT HAVE QUAD CONSTANTS FOR
C  MANY MACHINES YET.
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 SMALL(1),SMALL(2) / O402400000000, O000000000000 /
C      DATA LARGE(1),LARGE(2) / O376777777777, O777777777777 /
C      DATA RIGHT(1),RIGHT(2) / O604400000000, O000000000000 /
C      DATA DIVER(1),DIVER(2) / O606400000000, O000000000000 /
C      DATA LOG10(1),LOG10(2) / O776464202324, O117571775714 /, SC/987/
C
C     MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING
C     32-BIT INTEGERS.
C      DATA SMALL(1),SMALL(2) /    8388608,           0 /
C      DATA LARGE(1),LARGE(2) / 2147483647,          -1 /
C      DATA RIGHT(1),RIGHT(2) /  612368384,           0 /
C      DATA DIVER(1),DIVER(2) /  620756992,           0 /
C      DATA LOG10(1),LOG10(2) / 1067065498, -2063872008 /, SC/987/
C
C     MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES.
C      DATA SMALL(1),SMALL(2) / O000040000000, O000000000000 /
C      DATA LARGE(1),LARGE(2) / O377777777777, O777777777777 /
C      DATA RIGHT(1),RIGHT(2) / O170540000000, O000000000000 /
C      DATA DIVER(1),DIVER(2) / O170640000000, O000000000000 /
C      DATA LOG10(1),LOG10(2) / O177746420232, O411757177572 /, SC/987/
C
C     ON FIRST CALL, IF NO DATA UNCOMMENTED, TEST MACHINE TYPES.
      IF (sc .NE. 987) THEN
         dmach(1) = 1.d13
         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 IF ( small(1) .EQ. 1120022684
     *       .AND. small(2) .EQ. -448790528) THEN
*           *** CONVEX C-1 ***
            small(1) = 1048576
            small(2) = 0
            large(1) = 2147483647
            large(2) = -1
            right(1) = 1019215872
            right(2) = 0
            diver(1) = 1020264448
            diver(2) = 0
            log10(1) = 1072907283
            log10(2) = 1352628735
         ELSE IF ( small(1) .EQ. 815547074
     *       .AND. small(2) .EQ. 58688) THEN
*           *** VAX G-FLOATING ***
            small(1) = 16
            small(2) = 0
            large(1) = -32769
            large(2) = -1
            right(1) = 15552
            right(2) = 0
            diver(1) = 15568
            diver(2) = 0
            log10(1) = 1142112243
            log10(2) = 2046775455
         ELSE
            dmach(2) = 1.d27 + 1
            dmach(3) = 1.d27
            large(2) = large(2) - right(2)
            IF (large(2) .EQ. 64 .AND. small(2) .EQ. 0) THEN
               cray1(1) = 67291416
               DO 10 j = 1, 20
                  cray1(j+1) = cray1(j) + cray1(j)
 10               CONTINUE
               cray1(22) = cray1(21) + 321322
               DO 20 j = 22, 37
                  cray1(j+1) = cray1(j) + cray1(j)
 20               CONTINUE
               IF (cray1(38) .EQ. small(1)) THEN
*                  *** CRAY ***
                  CALL i1mcry(small(1), j, 8285, 8388608, 0)
                  small(2) = 0
                  CALL i1mcry(large(1), j, 24574, 16777215, 16777215)
                  CALL i1mcry(large(2), j, 0, 16777215, 16777214)
                  CALL i1mcry(right(1), j, 16291, 8388608, 0)
                  right(2) = 0
                  CALL i1mcry(diver(1), j, 16292, 8388608, 0)
                  diver(2) = 0
                  CALL i1mcry(log10(1), j, 16383, 10100890, 8715215)
                  CALL i1mcry(log10(2), j, 0, 16226447, 9001388)
               ELSE
                  WRITE(*,9000)
                  stop 779
                  END IF
            ELSE
               WRITE(*,9000)
               stop 779
               END IF
            END IF
         sc = 987
         END IF
*    SANITY CHECK
      IF (dmach(4) .GE. 1.0d0) stop 778
      IF (i .LT. 1 .OR. i .GT. 5) THEN
         WRITE(*,*) 'D1MACH(I): I =',i,' is out of bounds.'
         stop
         END IF
      d1mach = dmach(i)
      RETURN
 9000 FORMAT(/' Adjust D1MACH by uncommenting data statements'/
     *' appropriate for your machine.')
* /* Standard C source for D1MACH -- remove the * in column 1 */
*#include <stdio.h>
*#include <float.h>
*#include <math.h>
*double d1mach_(long *i)
*{
* switch(*i){
*   case 1: return DBL_MIN;
*   case 2: return DBL_MAX;
*   case 3: return DBL_EPSILON/FLT_RADIX;
*   case 4: return DBL_EPSILON;
*   case 5: return log10((double)FLT_RADIX);
*   }
* fprintf(stderr, "invalid argument: d1mach(%ld)\n", *i);
* exit(1); return 0; /* some compilers demand return values */
*}
      END

      SUBROUTINE i1mcry(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