← Back to branch summary

~daniele-bigoni/pyorthpol/pyorthpol-python3

« back to all changes in this revision

Viewing changes to PyORTHPOL/ORTHPOLxx/src/r1mach.f

  • Committer: Daniele Bigoni
  • Date: 2014-12-16 10:43:03 UTC
  • Revision ID: dabi@dtu.dk-20141216104303-ba4utrt7ln5g39lq
started with launchpad

Show diffs side-by-side

added added

removed removed

Lines of Context:
PyORTHPOL/ORTHPOLxx/src/r1mach.f
 
1
      REAL FUNCTION R1MACH(I)
 
2
      INTEGER I
 
3
C
 
4
C  SINGLE-PRECISION MACHINE CONSTANTS
 
5
C  R1MACH(1) = B**(EMIN-1), THE SMALLEST POSITIVE MAGNITUDE.
 
6
C  R1MACH(2) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE.
 
7
C  R1MACH(3) = B**(-T), THE SMALLEST RELATIVE SPACING.
 
8
C  R1MACH(4) = B**(1-T), THE LARGEST RELATIVE SPACING.
 
9
C  R1MACH(5) = LOG10(B)
 
10
C
 
11
      INTEGER SMALL(2)
 
12
      INTEGER LARGE(2)
 
13
      INTEGER RIGHT(2)
 
14
      INTEGER DIVER(2)
 
15
      INTEGER LOG10(2)
 
16
C     needs to be (2) for AUTODOUBLE, HARRIS SLASH 6, ...
 
17
      INTEGER SC
 
18
      SAVE SMALL, LARGE, RIGHT, DIVER, LOG10, SC
 
19
      REAL RMACH(5)
 
20
      EQUIVALENCE (RMACH(1),SMALL(1))
 
21
      EQUIVALENCE (RMACH(2),LARGE(1))
 
22
      EQUIVALENCE (RMACH(3),RIGHT(1))
 
23
      EQUIVALENCE (RMACH(4),DIVER(1))
 
24
      EQUIVALENCE (RMACH(5),LOG10(1))
 
25
      INTEGER J, K, L, T3E(3)
 
26
      DATA T3E(1) / 9777664 /
 
27
      DATA T3E(2) / 5323660 /
 
28
      DATA T3E(3) / 46980 /
 
29
C  THIS VERSION ADAPTS AUTOMATICALLY TO MOST CURRENT MACHINES,
 
30
C  INCLUDING AUTO-DOUBLE COMPILERS.
 
31
C  TO COMPILE ON OLDER MACHINES, ADD A C IN COLUMN 1
 
32
C  ON THE NEXT LINE
 
33
      DATA SC/0/
 
34
C  AND REMOVE THE C FROM COLUMN 1 IN ONE OF THE SECTIONS BELOW.
 
35
C  CONSTANTS FOR EVEN OLDER MACHINES CAN BE OBTAINED BY
 
36
C          mail netlib@research.bell-labs.com
 
37
C          send old1mach from blas
 
38
C  PLEASE SEND CORRECTIONS TO dmg OR ehg@bell-labs.com.
 
39
C
 
40
C     MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES.
 
41
C      DATA RMACH(1) / O402400000000 /
 
42
C      DATA RMACH(2) / O376777777777 /
 
43
C      DATA RMACH(3) / O714400000000 /
 
44
C      DATA RMACH(4) / O716400000000 /
 
45
C      DATA RMACH(5) / O776464202324 /, SC/987/
 
46
C
 
47
C     MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING
 
48
C     32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL).
 
49
C      DATA SMALL(1) /    8388608 /
 
50
C      DATA LARGE(1) / 2147483647 /
 
51
C      DATA RIGHT(1) /  880803840 /
 
52
C      DATA DIVER(1) /  889192448 /
 
53
C      DATA LOG10(1) / 1067065499 /, SC/987/
 
54
C      DATA RMACH(1) / O00040000000 /
 
55
C      DATA RMACH(2) / O17777777777 /
 
56
C      DATA RMACH(3) / O06440000000 /
 
57
C      DATA RMACH(4) / O06500000000 /
 
58
C      DATA RMACH(5) / O07746420233 /, SC/987/
 
59
C
 
60
C     MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES.
 
61
C      DATA RMACH(1) / O000400000000 /
 
62
C      DATA RMACH(2) / O377777777777 /
 
63
C      DATA RMACH(3) / O146400000000 /
 
64
C      DATA RMACH(4) / O147400000000 /
 
65
C      DATA RMACH(5) / O177464202324 /, SC/987/
 
66
C
 
67
      IF (SC .NE. 987) THEN
 
68
*        *** CHECK FOR AUTODOUBLE ***
 
69
         SMALL(2) = 0
 
70
         RMACH(1) = 1E13
 
71
         IF (SMALL(2) .NE. 0) THEN
 
72
*           *** AUTODOUBLED ***
 
73
            IF (      SMALL(1) .EQ. 1117925532
 
74
     *          .AND. SMALL(2) .EQ. -448790528) THEN
 
75
*              *** IEEE BIG ENDIAN ***
 
76
               SMALL(1) = 1048576
 
77
               SMALL(2) = 0
 
78
               LARGE(1) = 2146435071
 
79
               LARGE(2) = -1
 
80
               RIGHT(1) = 1017118720
 
81
               RIGHT(2) = 0
 
82
               DIVER(1) = 1018167296
 
83
               DIVER(2) = 0
 
84
               LOG10(1) = 1070810131
 
85
               LOG10(2) = 1352628735
 
86
            ELSE IF ( SMALL(2) .EQ. 1117925532
 
87
     *          .AND. SMALL(1) .EQ. -448790528) THEN
 
88
*              *** IEEE LITTLE ENDIAN ***
 
89
               SMALL(2) = 1048576
 
90
               SMALL(1) = 0
 
91
               LARGE(2) = 2146435071
 
92
               LARGE(1) = -1
 
93
               RIGHT(2) = 1017118720
 
94
               RIGHT(1) = 0
 
95
               DIVER(2) = 1018167296
 
96
               DIVER(1) = 0
 
97
               LOG10(2) = 1070810131
 
98
               LOG10(1) = 1352628735
 
99
            ELSE IF ( SMALL(1) .EQ. -2065213935
 
100
     *          .AND. SMALL(2) .EQ. 10752) THEN
 
101
*              *** VAX WITH D_FLOATING ***
 
102
               SMALL(1) = 128
 
103
               SMALL(2) = 0
 
104
               LARGE(1) = -32769
 
105
               LARGE(2) = -1
 
106
               RIGHT(1) = 9344
 
107
               RIGHT(2) = 0
 
108
               DIVER(1) = 9472
 
109
               DIVER(2) = 0
 
110
               LOG10(1) = 546979738
 
111
               LOG10(2) = -805796613
 
112
            ELSE IF ( SMALL(1) .EQ. 1267827943
 
113
     *          .AND. SMALL(2) .EQ. 704643072) THEN
 
114
*              *** IBM MAINFRAME ***
 
115
               SMALL(1) = 1048576
 
116
               SMALL(2) = 0
 
117
               LARGE(1) = 2147483647
 
118
               LARGE(2) = -1
 
119
               RIGHT(1) = 856686592
 
120
               RIGHT(2) = 0
 
121
               DIVER(1) = 873463808
 
122
               DIVER(2) = 0
 
123
               LOG10(1) = 1091781651
 
124
               LOG10(2) = 1352628735
 
125
            ELSE
 
126
               WRITE(*,9010)
 
127
               STOP 777
 
128
               END IF
 
129
         ELSE
 
130
            RMACH(1) = 1234567.
 
131
            IF (SMALL(1) .EQ. 1234613304) THEN
 
132
*              *** IEEE ***
 
133
               SMALL(1) = 8388608
 
134
               LARGE(1) = 2139095039
 
135
               RIGHT(1) = 864026624
 
136
               DIVER(1) = 872415232
 
137
               LOG10(1) = 1050288283
 
138
            ELSE IF (SMALL(1) .EQ. -1271379306) THEN
 
139
*              *** VAX ***
 
140
               SMALL(1) = 128
 
141
               LARGE(1) = -32769
 
142
               RIGHT(1) = 13440
 
143
               DIVER(1) = 13568
 
144
               LOG10(1) = 547045274
 
145
            ELSE IF (SMALL(1) .EQ. 1175639687) THEN
 
146
*              *** IBM MAINFRAME ***
 
147
               SMALL(1) = 1048576
 
148
               LARGE(1) = 2147483647
 
149
               RIGHT(1) = 990904320
 
150
               DIVER(1) = 1007681536
 
151
               LOG10(1) = 1091781651
 
152
            ELSE IF (SMALL(1) .EQ. 1251390520) THEN
 
153
*              *** CONVEX C-1 ***
 
154
               SMALL(1) = 8388608
 
155
               LARGE(1) = 2147483647
 
156
               RIGHT(1) = 880803840
 
157
               DIVER(1) = 889192448
 
158
               LOG10(1) = 1067065499
 
159
            ELSE
 
160
               DO 10 L = 1, 3
 
161
                  J = SMALL(1) / 10000000
 
162
                  K = SMALL(1) - 10000000*J
 
163
                  IF (K .NE. T3E(L)) GO TO 20
 
164
                  SMALL(1) = J
 
165
 10               CONTINUE
 
166
*              *** CRAY T3E ***
 
167
               CALL I1MCRA(SMALL, K, 16, 0, 0)
 
168
               CALL I1MCRA(LARGE, K, 32751, 16777215, 16777215)
 
169
               CALL I1MCRA(RIGHT, K, 15520, 0, 0)
 
170
               CALL I1MCRA(DIVER, K, 15536, 0, 0)
 
171
               CALL I1MCRA(LOG10, K, 16339, 4461392, 10451455)
 
172
               GO TO 30
 
173
 20            CALL I1MCRA(J, K, 16405, 9876536, 0)
 
174
               IF (SMALL(1) .NE. J) THEN
 
175
                  WRITE(*,9020)
 
176
                  STOP 777
 
177
                  END IF
 
178
*              *** CRAY 1, XMP, 2, AND 3 ***
 
179
               CALL I1MCRA(SMALL(1), K, 8195, 8388608, 1)
 
180
               CALL I1MCRA(LARGE(1), K, 24574, 16777215, 16777214)
 
181
               CALL I1MCRA(RIGHT(1), K, 16338, 8388608, 0)
 
182
               CALL I1MCRA(DIVER(1), K, 16339, 8388608, 0)
 
183
               CALL I1MCRA(LOG10(1), K, 16383, 10100890, 8715216)
 
184
               END IF
 
185
            END IF
 
186
 30      SC = 987
 
187
         END IF
 
188
*     SANITY CHECK
 
189
      IF (RMACH(4) .GE. 1.0) STOP 776
 
190
      IF (I .LT. 1 .OR. I .GT. 5) THEN
 
191
         WRITE(*,*) 'R1MACH(I): I =',I,' is out of bounds.'
 
192
         STOP
 
193
         END IF
 
194
      R1MACH = RMACH(I)
 
195
      RETURN
 
196
 9010 FORMAT(/' Adjust autodoubled R1MACH by getting data'/
 
197
     *' appropriate for your machine from D1MACH.')
 
198
 9020 FORMAT(/' Adjust R1MACH by uncommenting data statements'/
 
199
     *' appropriate for your machine.')
 
200
* /* C source for R1MACH -- remove the * in column 1 */
 
201
*#include <stdio.h>
 
202
*#include <float.h>
 
203
*#include <math.h>
 
204
*float r1mach_(long *i)
 
205
*{
 
206
*       switch(*i){
 
207
*         case 1: return FLT_MIN;
 
208
*         case 2: return FLT_MAX;
 
209
*         case 3: return FLT_EPSILON/FLT_RADIX;
 
210
*         case 4: return FLT_EPSILON;
 
211
*         case 5: return log10((double)FLT_RADIX);
 
212
*         }
 
213
*       fprintf(stderr, "invalid argument: r1mach(%ld)\n", *i);
 
214
*       exit(1); return 0; /* else complaint of missing return value */
 
215
*}
 
216
      END
 
217
      SUBROUTINE I1MCRA(A, A1, B, C, D)
 
218
**** SPECIAL COMPUTATION FOR CRAY MACHINES ****
 
219
      INTEGER A, A1, B, C, D
 
220
      A1 = 16777216*B + C
 
221
      A = 16777216*A1 + D
 
222
      END