Back to home page

sPhenix code displayed by LXR
 
 

    

File indexing completed on 2025-08-05 08:15:40 

0001 
0002 
0003       DOUBLE PRECISION FUNCTION D1MACH(I)
0004       INTEGER I
0005 C
0006 C  DOUBLE-PRECISION MACHINE CONSTANTS
0007 C  D1MACH( 1) = B**(EMIN-1), THE SMALLEST POSITIVE MAGNITUDE.
0008 C  D1MACH( 2) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE.
0009 C  D1MACH( 3) = B**(-T), THE SMALLEST RELATIVE SPACING.
0010 C  D1MACH( 4) = B**(1-T), THE LARGEST RELATIVE SPACING.
0011 C  D1MACH( 5) = LOG10(B)
0012 C
0013       INTEGER SMALL(2)
0014       INTEGER LARGE(2)
0015       INTEGER RIGHT(2)
0016       INTEGER DIVER(2)
0017       INTEGER LOG10(2)
0018       INTEGER SC, CRAY1(38), J
0019       COMMON /D9MACH/ CRAY1
0020       SAVE SMALL, LARGE, RIGHT, DIVER, LOG10, SC
0021       DOUBLE PRECISION DMACH(5)
0022       EQUIVALENCE (DMACH(1),SMALL(1))
0023       EQUIVALENCE (DMACH(2),LARGE(1))
0024       EQUIVALENCE (DMACH(3),RIGHT(1))
0025       EQUIVALENCE (DMACH(4),DIVER(1))
0026       EQUIVALENCE (DMACH(5),LOG10(1))
0027 C  THIS VERSION ADAPTS AUTOMATICALLY TO MOST CURRENT MACHINES.
0028 C  R1MACH CAN HANDLE AUTO-DOUBLE COMPILING, BUT THIS VERSION OF
0029 C  D1MACH DOES NOT, BECAUSE WE DO NOT HAVE QUAD CONSTANTS FOR
0030 C  MANY MACHINES YET.
0031 C  TO COMPILE ON OLDER MACHINES, ADD A C IN COLUMN 1
0032 C  ON THE NEXT LINE
0033       DATA SC/0/
0034 C  AND REMOVE THE C FROM COLUMN 1 IN ONE OF THE SECTIONS BELOW.
0035 C  CONSTANTS FOR EVEN OLDER MACHINES CAN BE OBTAINED BY
0036 C          mail netlib@research.bell-labs.com
0037 C          send old1mach from blas
0038 C  PLEASE SEND CORRECTIONS TO dmg OR ehg@bell-labs.com.
0039 C
0040 C     MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES.
0041 C      DATA SMALL(1),SMALL(2) / O402400000000, O000000000000 /
0042 C      DATA LARGE(1),LARGE(2) / O376777777777, O777777777777 /
0043 C      DATA RIGHT(1),RIGHT(2) / O604400000000, O000000000000 /
0044 C      DATA DIVER(1),DIVER(2) / O606400000000, O000000000000 /
0045 C      DATA LOG10(1),LOG10(2) / O776464202324, O117571775714 /, SC/987/
0046 C
0047 C     MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING
0048 C     32-BIT INTEGERS.
0049 C      DATA SMALL(1),SMALL(2) /    8388608,           0 /
0050 C      DATA LARGE(1),LARGE(2) / 2147483647,          -1 /
0051 C      DATA RIGHT(1),RIGHT(2) /  612368384,           0 /
0052 C      DATA DIVER(1),DIVER(2) /  620756992,           0 /
0053 C      DATA LOG10(1),LOG10(2) / 1067065498, -2063872008 /, SC/987/
0054 C
0055 C     MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES.
0056 C      DATA SMALL(1),SMALL(2) / O000040000000, O000000000000 /
0057 C      DATA LARGE(1),LARGE(2) / O377777777777, O777777777777 /
0058 C      DATA RIGHT(1),RIGHT(2) / O170540000000, O000000000000 /
0059 C      DATA DIVER(1),DIVER(2) / O170640000000, O000000000000 /
0060 C      DATA LOG10(1),LOG10(2) / O177746420232, O411757177572 /, SC/987/
0061 C
0062 C     ON FIRST CALL, IF NO DATA UNCOMMENTED, TEST MACHINE TYPES.
0063       IF (SC .NE. 987) THEN
0064          DMACH(1) = 1.D13
0065          IF (      SMALL(1) .EQ. 1117925532
0066      *       .AND. SMALL(2) .EQ. -448790528) THEN
0067 *           *** IEEE BIG ENDIAN ***
0068             SMALL(1) = 1048576
0069             SMALL(2) = 0
0070             LARGE(1) = 2146435071
0071             LARGE(2) = -1
0072             RIGHT(1) = 1017118720
0073             RIGHT(2) = 0
0074             DIVER(1) = 1018167296
0075             DIVER(2) = 0
0076             LOG10(1) = 1070810131
0077             LOG10(2) = 1352628735
0078          ELSE IF ( SMALL(2) .EQ. 1117925532
0079      *       .AND. SMALL(1) .EQ. -448790528) THEN
0080 *           *** IEEE LITTLE ENDIAN ***
0081             SMALL(2) = 1048576
0082             SMALL(1) = 0
0083             LARGE(2) = 2146435071
0084             LARGE(1) = -1
0085             RIGHT(2) = 1017118720
0086             RIGHT(1) = 0
0087             DIVER(2) = 1018167296
0088             DIVER(1) = 0
0089             LOG10(2) = 1070810131
0090             LOG10(1) = 1352628735
0091          ELSE IF ( SMALL(1) .EQ. -2065213935
0092      *       .AND. SMALL(2) .EQ. 10752) THEN
0093 *               *** VAX WITH D_FLOATING ***
0094             SMALL(1) = 128
0095             SMALL(2) = 0
0096             LARGE(1) = -32769
0097             LARGE(2) = -1
0098             RIGHT(1) = 9344
0099             RIGHT(2) = 0
0100             DIVER(1) = 9472
0101             DIVER(2) = 0
0102             LOG10(1) = 546979738
0103             LOG10(2) = -805796613
0104          ELSE IF ( SMALL(1) .EQ. 1267827943
0105      *       .AND. SMALL(2) .EQ. 704643072) THEN
0106 *               *** IBM MAINFRAME ***
0107             SMALL(1) = 1048576
0108             SMALL(2) = 0
0109             LARGE(1) = 2147483647
0110             LARGE(2) = -1
0111             RIGHT(1) = 856686592
0112             RIGHT(2) = 0
0113             DIVER(1) = 873463808
0114             DIVER(2) = 0
0115             LOG10(1) = 1091781651
0116             LOG10(2) = 1352628735
0117          ELSE IF ( SMALL(1) .EQ. 1120022684
0118      *       .AND. SMALL(2) .EQ. -448790528) THEN
0119 *           *** CONVEX C-1 ***
0120             SMALL(1) = 1048576
0121             SMALL(2) = 0
0122             LARGE(1) = 2147483647
0123             LARGE(2) = -1
0124             RIGHT(1) = 1019215872
0125             RIGHT(2) = 0
0126             DIVER(1) = 1020264448
0127             DIVER(2) = 0
0128             LOG10(1) = 1072907283
0129             LOG10(2) = 1352628735
0130          ELSE IF ( SMALL(1) .EQ. 815547074
0131      *       .AND. SMALL(2) .EQ. 58688) THEN
0132 *           *** VAX G-FLOATING ***
0133             SMALL(1) = 16
0134             SMALL(2) = 0
0135             LARGE(1) = -32769
0136             LARGE(2) = -1
0137             RIGHT(1) = 15552
0138             RIGHT(2) = 0
0139             DIVER(1) = 15568
0140             DIVER(2) = 0
0141             LOG10(1) = 1142112243
0142             LOG10(2) = 2046775455
0143          ELSE
0144             DMACH(2) = 1.D27 + 1
0145             DMACH(3) = 1.D27
0146             LARGE(2) = LARGE(2) - RIGHT(2)
0147             IF (LARGE(2) .EQ. 64 .AND. SMALL(2) .EQ. 0) THEN
0148                CRAY1(1) = 67291416
0149                DO 10 J = 1, 20
0150                   CRAY1(J+1) = CRAY1(J) + CRAY1(J)
0151  10               CONTINUE
0152                CRAY1(22) = CRAY1(21) + 321322
0153                DO 20 J = 22, 37
0154                   CRAY1(J+1) = CRAY1(J) + CRAY1(J)
0155  20               CONTINUE
0156                IF (CRAY1(38) .EQ. SMALL(1)) THEN
0157 *                  *** CRAY ***
0158                   CALL I1MCRY(SMALL(1), J, 8285, 8388608, 0)
0159                   SMALL(2) = 0
0160                   CALL I1MCRY(LARGE(1), J, 24574, 16777215, 16777215)
0161                   CALL I1MCRY(LARGE(2), J, 0, 16777215, 16777214)
0162                   CALL I1MCRY(RIGHT(1), J, 16291, 8388608, 0)
0163                   RIGHT(2) = 0
0164                   CALL I1MCRY(DIVER(1), J, 16292, 8388608, 0)
0165                   DIVER(2) = 0
0166                   CALL I1MCRY(LOG10(1), J, 16383, 10100890, 8715215)
0167                   CALL I1MCRY(LOG10(2), J, 0, 16226447, 9001388)
0168                ELSE
0169                   WRITE(*,9000)
0170                   STOP 779
0171                   END IF
0172             ELSE
0173                WRITE(*,9000)
0174                STOP 779
0175                END IF
0176             END IF
0177          SC = 987
0178          END IF
0179 *    SANITY CHECK
0180       IF (DMACH(4) .GE. 1.0D0) STOP 778
0181       IF (I .LT. 1 .OR. I .GT. 5) THEN
0182          WRITE(*,*) 'D1MACH(I): I =',I,' is out of bounds.'
0183          STOP
0184          END IF
0185       D1MACH = DMACH(I)
0186       RETURN
0187  9000 FORMAT(/' Adjust D1MACH by uncommenting data statements'/
0188      *' appropriate for your machine.')
0189 * /* Standard C source for D1MACH -- remove the * in column 1 */
0190 *#include <stdio.h>
0191 *#include <float.h>
0192 *#include <math.h>
0193 *double d1mach_(long *i)
0194 *{
0195 *       switch(*i){
0196 *         case 1: return DBL_MIN;
0197 *         case 2: return DBL_MAX;
0198 *         case 3: return DBL_EPSILON/FLT_RADIX;
0199 *         case 4: return DBL_EPSILON;
0200 *         case 5: return log10((double)FLT_RADIX);
0201 *         }
0202 *       fprintf(stderr, "invalid argument: d1mach(%ld)\n", *i);
0203 *       exit(1); return 0; /* some compilers demand return values */
0204 *}
0205       END
0206 
0207       SUBROUTINE I1MCRY(A, A1, B, C, D)
0208 **** SPECIAL COMPUTATION FOR OLD CRAY MACHINES ****
0209       INTEGER A, A1, B, C, D
0210       A1 = 16777216*B + C
0211       A = 16777216*A1 + D
0212       END
[ Source navigation ] [ Diff markup ] [ Identifier search ] [ general search ]

This page was automatically generated by the 2.3.7 LXR engine.

The LXR team
Valid CSS 2.1! Valid HTML 4.01!