← Back to branch summary

~ubuntu-branches/ubuntu/wily/julia/wily

« back to all changes in this revision

Viewing changes to deps/openlibm/slatec/xadd.f

  • Committer: Package Import Robot
  • Author(s): Sébastien Villemot
  • Date: 2013-01-16 12:29:42 UTC
  • mfrom: (1.1.2)
  • Revision ID: package-import@ubuntu.com-20130116122942-x86e42akjq31repw
Tags: 0.0.0+20130107.gitd9656f41-1
* New upstream snashot
* No longer try to rebuild helpdb.jl.
   + debian/rules: remove helpdb.jl from build-arch rule
   + debian/control: move back python-sphinx to Build-Depends-Indep
* debian/copyright: reflect upstream changes
* Add Build-Conflicts on libatlas3-base (makes linalg tests fail)
* debian/rules: replace obsolete USE_DEBIAN makeflag by a list of
  USE_SYSTEM_* flags
* debian/rules: on non-x86 systems, use libm instead of openlibm
* dpkg-buildflags.patch: remove patch, applied upstream
* Refreshed other patches

Show diffs side-by-side

added added

removed removed

Lines of Context:
deps/openlibm/slatec/xadd.f
 
1
*DECK XADD
 
2
      SUBROUTINE XADD (X, IX, Y, IY, Z, IZ, IERROR)
 
3
C***BEGIN PROLOGUE  XADD
 
4
C***PURPOSE  To provide single-precision floating-point arithmetic
 
5
C            with an extended exponent range.
 
6
C***LIBRARY   SLATEC
 
7
C***CATEGORY  A3D
 
8
C***TYPE      SINGLE PRECISION (XADD-S, DXADD-D)
 
9
C***KEYWORDS  EXTENDED-RANGE SINGLE-PRECISION ARITHMETIC
 
10
C***AUTHOR  Lozier, Daniel W., (National Bureau of Standards)
 
11
C           Smith, John M., (NBS and George Mason University)
 
12
C***DESCRIPTION
 
13
C     REAL X, Y, Z
 
14
C     INTEGER IX, IY, IZ
 
15
C
 
16
C                  FORMS THE EXTENDED-RANGE SUM  (Z,IZ) =
 
17
C                  (X,IX) + (Y,IY).  (Z,IZ) IS ADJUSTED
 
18
C                  BEFORE RETURNING. THE INPUT OPERANDS
 
19
C                  NEED NOT BE IN ADJUSTED FORM, BUT THEIR
 
20
C                  PRINCIPAL PARTS MUST SATISFY
 
21
C                  RADIX**(-2L).LE.ABS(X).LE.RADIX**(2L),
 
22
C                  RADIX**(-2L).LE.ABS(Y).LE.RADIX**(2L).
 
23
C
 
24
C***SEE ALSO  XSET
 
25
C***REFERENCES  (NONE)
 
26
C***ROUTINES CALLED  XADJ
 
27
C***COMMON BLOCKS    XBLK2
 
28
C***REVISION HISTORY  (YYMMDD)
 
29
C   820712  DATE WRITTEN
 
30
C   881020  Revised to meet SLATEC CML recommendations.  (DWL and JMS)
 
31
C   901019  Revisions to prologue.  (DWL and WRB)
 
32
C   901106  Changed all specific intrinsics to generic.  (WRB)
 
33
C           Corrected order of sections in prologue and added TYPE
 
34
C           section.  (WRB)
 
35
C   920127  Revised PURPOSE section of prologue.  (DWL)
 
36
C***END PROLOGUE  XADD
 
37
      REAL X, Y, Z
 
38
      INTEGER IX, IY, IZ
 
39
      REAL RADIX, RADIXL, RAD2L, DLG10R
 
40
      INTEGER L, L2, KMAX
 
41
      COMMON /XBLK2/ RADIX, RADIXL, RAD2L, DLG10R, L, L2, KMAX
 
42
      SAVE /XBLK2/
 
43
C
 
44
C
 
45
C   THE CONDITIONS IMPOSED ON L AND KMAX BY THIS SUBROUTINE
 
46
C ARE
 
47
C     (1) 1 .LT. L .LE. 0.5*LOGR(0.5*DZERO)
 
48
C
 
49
C     (2) NRADPL .LT. L .LE. KMAX/6
 
50
C
 
51
C     (3) KMAX .LE. (2**NBITS - 4*L - 1)/2
 
52
C
 
53
C THESE CONDITIONS MUST BE MET BY APPROPRIATE CODING
 
54
C IN SUBROUTINE XSET.
 
55
C
 
56
C***FIRST EXECUTABLE STATEMENT  XADD
 
57
      IERROR=0
 
58
      IF (X.NE.0.0) GO TO 10
 
59
      Z = Y
 
60
      IZ = IY
 
61
      GO TO 220
 
62
   10 IF (Y.NE.0.0) GO TO 20
 
63
      Z = X
 
64
      IZ = IX
 
65
      GO TO 220
 
66
   20 CONTINUE
 
67
      IF (IX.GE.0 .AND. IY.GE.0) GO TO 40
 
68
      IF (IX.LT.0 .AND. IY.LT.0) GO TO 40
 
69
      IF (ABS(IX).LE.6*L .AND. ABS(IY).LE.6*L) GO TO 40
 
70
      IF (IX.GE.0) GO TO 30
 
71
      Z = Y
 
72
      IZ = IY
 
73
      GO TO 220
 
74
   30 CONTINUE
 
75
      Z = X
 
76
      IZ = IX
 
77
      GO TO 220
 
78
   40 I = IX - IY
 
79
      IF (I) 80, 50, 90
 
80
   50 IF (ABS(X).GT.1.0 .AND. ABS(Y).GT.1.0) GO TO 60
 
81
      IF (ABS(X).LT.1.0 .AND. ABS(Y).LT.1.0) GO TO 70
 
82
      Z = X + Y
 
83
      IZ = IX
 
84
      GO TO 220
 
85
   60 S = X/RADIXL
 
86
      T = Y/RADIXL
 
87
      Z = S + T
 
88
      IZ = IX + L
 
89
      GO TO 220
 
90
   70 S = X*RADIXL
 
91
      T = Y*RADIXL
 
92
      Z = S + T
 
93
      IZ = IX - L
 
94
      GO TO 220
 
95
   80 S = Y
 
96
      IS = IY
 
97
      T = X
 
98
      GO TO 100
 
99
   90 S = X
 
100
      IS = IX
 
101
      T = Y
 
102
  100 CONTINUE
 
103
C
 
104
C  AT THIS POINT, THE ONE OF (X,IX) OR (Y,IY) THAT HAS THE
 
105
C LARGER AUXILIARY INDEX IS STORED IN (S,IS). THE PRINCIPAL
 
106
C PART OF THE OTHER INPUT IS STORED IN T.
 
107
C
 
108
      I1 = ABS(I)/L
 
109
      I2 = MOD(ABS(I),L)
 
110
      IF (ABS(T).GE.RADIXL) GO TO 130
 
111
      IF (ABS(T).GE.1.0) GO TO 120
 
112
      IF (RADIXL*ABS(T).GE.1.0) GO TO 110
 
113
      J = I1 + 1
 
114
      T = T*RADIX**(L-I2)
 
115
      GO TO 140
 
116
  110 J = I1
 
117
      T = T*RADIX**(-I2)
 
118
      GO TO 140
 
119
  120 J = I1 - 1
 
120
      IF (J.LT.0) GO TO 110
 
121
      T = T*RADIX**(-I2)/RADIXL
 
122
      GO TO 140
 
123
  130 J = I1 - 2
 
124
      IF (J.LT.0) GO TO 120
 
125
      T = T*RADIX**(-I2)/RAD2L
 
126
  140 CONTINUE
 
127
C
 
128
C  AT THIS POINT, SOME OR ALL OF THE DIFFERENCE IN THE
 
129
C AUXILIARY INDICES HAS BEEN USED TO EFFECT A LEFT SHIFT
 
130
C OF T.  THE SHIFTED VALUE OF T SATISFIES
 
131
C
 
132
C       RADIX**(-2*L) .LE. ABS(T) .LE. 1.0
 
133
C
 
134
C AND, IF J=0, NO FURTHER SHIFTING REMAINS TO BE DONE.
 
135
C
 
136
      IF (J.EQ.0) GO TO 190
 
137
      IF (ABS(S).GE.RADIXL .OR. J.GT.3) GO TO 150
 
138
      IF (ABS(S).GE.1.0) GO TO (180, 150, 150), J
 
139
      IF (RADIXL*ABS(S).GE.1.0) GO TO (180, 170, 150), J
 
140
      GO TO (180, 170, 160), J
 
141
  150 Z = S
 
142
      IZ = IS
 
143
      GO TO 220
 
144
  160 S = S*RADIXL
 
145
  170 S = S*RADIXL
 
146
  180 S = S*RADIXL
 
147
  190 CONTINUE
 
148
C
 
149
C   AT THIS POINT, THE REMAINING DIFFERENCE IN THE
 
150
C AUXILIARY INDICES HAS BEEN USED TO EFFECT A RIGHT SHIFT
 
151
C OF S.  IF THE SHIFTED VALUE OF S WOULD HAVE EXCEEDED
 
152
C RADIX**L, THEN (S,IS) IS RETURNED AS THE VALUE OF THE
 
153
C SUM.
 
154
C
 
155
      IF (ABS(S).GT.1.0 .AND. ABS(T).GT.1.0) GO TO 200
 
156
      IF (ABS(S).LT.1.0 .AND. ABS(T).LT.1.0) GO TO 210
 
157
      Z = S + T
 
158
      IZ = IS - J*L
 
159
      GO TO 220
 
160
  200 S = S/RADIXL
 
161
      T = T/RADIXL
 
162
      Z = S + T
 
163
      IZ = IS - J*L + L
 
164
      GO TO 220
 
165
  210 S = S*RADIXL
 
166
      T = T*RADIXL
 
167
      Z = S + T
 
168
      IZ = IS - J*L - L
 
169
  220 CALL XADJ(Z, IZ,IERROR)
 
170
      RETURN
 
171
      END