mirror of
https://git.planet-casio.com/Lephenixnoir/OpenLibm.git
synced 2025-01-01 06:23:39 +01:00
116 lines
2.8 KiB
Fortran
116 lines
2.8 KiB
Fortran
*DECK MPADD3
|
|
SUBROUTINE MPADD3 (X, Y, S, MED, RE)
|
|
C***BEGIN PROLOGUE MPADD3
|
|
C***SUBSIDIARY
|
|
C***PURPOSE Subsidiary to DQDOTA and DQDOTI
|
|
C***LIBRARY SLATEC
|
|
C***TYPE ALL (MPADD3-A)
|
|
C***AUTHOR (UNKNOWN)
|
|
C***DESCRIPTION
|
|
C
|
|
C Called by MPADD2; does inner loops of addition
|
|
C
|
|
C The arguments X(*) and Y(*) and the variable R in COMMON are all
|
|
C INTEGER arrays of size 30. See the comments in the routine MPBLAS
|
|
C for the reason for this choice.
|
|
C
|
|
C***SEE ALSO DQDOTA, DQDOTI, MPBLAS
|
|
C***ROUTINES CALLED (NONE)
|
|
C***COMMON BLOCKS MPCOM
|
|
C***REVISION HISTORY (YYMMDD)
|
|
C 791001 DATE WRITTEN
|
|
C ?????? Modified for use with BLAS. Blank COMMON changed to named
|
|
C COMMON. R given dimension 12.
|
|
C 890831 Modified array declarations. (WRB)
|
|
C 891214 Prologue converted to Version 4.0 format. (BAB)
|
|
C 900402 Added TYPE section. (WRB)
|
|
C 930124 Increased Array size in MPCON for SUN -r8. (RWC)
|
|
C***END PROLOGUE MPADD3
|
|
COMMON /MPCOM/ B, T, M, LUN, MXR, R(30)
|
|
INTEGER B, T, R, X(*), Y(*), S, RE, C, TED
|
|
C***FIRST EXECUTABLE STATEMENT MPADD3
|
|
TED = T + MED
|
|
I2 = T + 4
|
|
I = I2
|
|
C = 0
|
|
C CLEAR GUARD DIGITS TO RIGHT OF X DIGITS
|
|
10 IF (I.LE.TED) GO TO 20
|
|
R(I) = 0
|
|
I = I - 1
|
|
GO TO 10
|
|
20 IF (S.LT.0) GO TO 130
|
|
C HERE DO ADDITION, EXPONENT(Y) .GE. EXPONENT(X)
|
|
IF (I.LT.T) GO TO 40
|
|
30 J = I - MED
|
|
R(I) = X(J+2)
|
|
I = I - 1
|
|
IF (I.GT.T) GO TO 30
|
|
40 IF (I.LE.MED) GO TO 60
|
|
J = I - MED
|
|
C = Y(I+2) + X(J+2) + C
|
|
IF (C.LT.B) GO TO 50
|
|
C CARRY GENERATED HERE
|
|
R(I) = C - B
|
|
C = 1
|
|
I = I - 1
|
|
GO TO 40
|
|
C NO CARRY GENERATED HERE
|
|
50 R(I) = C
|
|
C = 0
|
|
I = I - 1
|
|
GO TO 40
|
|
60 IF (I.LE.0) GO TO 90
|
|
C = Y(I+2) + C
|
|
IF (C.LT.B) GO TO 70
|
|
R(I) = 0
|
|
C = 1
|
|
I = I - 1
|
|
GO TO 60
|
|
70 R(I) = C
|
|
I = I - 1
|
|
C NO CARRY POSSIBLE HERE
|
|
80 IF (I.LE.0) RETURN
|
|
R(I) = Y(I+2)
|
|
I = I - 1
|
|
GO TO 80
|
|
90 IF (C.EQ.0) RETURN
|
|
C MUST SHIFT RIGHT HERE AS CARRY OFF END
|
|
I2P = I2 + 1
|
|
DO 100 J = 2, I2
|
|
I = I2P - J
|
|
100 R(I+1) = R(I)
|
|
R(1) = 1
|
|
RE = RE + 1
|
|
RETURN
|
|
C HERE DO SUBTRACTION, ABS(Y) .GT. ABS(X)
|
|
110 J = I - MED
|
|
R(I) = C - X(J+2)
|
|
C = 0
|
|
IF (R(I).GE.0) GO TO 120
|
|
C BORROW GENERATED HERE
|
|
C = -1
|
|
R(I) = R(I) + B
|
|
120 I = I - 1
|
|
130 IF (I.GT.T) GO TO 110
|
|
140 IF (I.LE.MED) GO TO 160
|
|
J = I - MED
|
|
C = Y(I+2) + C - X(J+2)
|
|
IF (C.GE.0) GO TO 150
|
|
C BORROW GENERATED HERE
|
|
R(I) = C + B
|
|
C = -1
|
|
I = I - 1
|
|
GO TO 140
|
|
C NO BORROW GENERATED HERE
|
|
150 R(I) = C
|
|
C = 0
|
|
I = I - 1
|
|
GO TO 140
|
|
160 IF (I.LE.0) RETURN
|
|
C = Y(I+2) + C
|
|
IF (C.GE.0) GO TO 70
|
|
R(I) = C + B
|
|
C = -1
|
|
I = I - 1
|
|
GO TO 160
|
|
END
|