mirror of
https://git.planet-casio.com/Lephenixnoir/OpenLibm.git
synced 2025-01-01 06:23:39 +01:00
95 lines
3.3 KiB
Fortran
95 lines
3.3 KiB
Fortran
*DECK MPADD2
|
|
SUBROUTINE MPADD2 (X, Y, Z, Y1, TRUNC)
|
|
C***BEGIN PROLOGUE MPADD2
|
|
C***SUBSIDIARY
|
|
C***PURPOSE Subsidiary to DQDOTA and DQDOTI
|
|
C***LIBRARY SLATEC
|
|
C***TYPE ALL (MPADD2-A)
|
|
C***AUTHOR (UNKNOWN)
|
|
C***DESCRIPTION
|
|
C
|
|
C Called by MPADD, MPSUB etc.
|
|
C X, Y and Z are MP numbers, Y1 and TRUNC are integers.
|
|
C To force call by reference rather than value/result, Y1 is
|
|
C declared as an array, but only Y1(1) is ever used.
|
|
C Sets Z = X + Y1(1)*ABS(Y), where Y1(1) = +- Y(1).
|
|
C If TRUNC .EQ. 0, R*-rounding is used; otherwise, truncation.
|
|
C R*-rounding is defined in the Kuki and Cody reference.
|
|
C
|
|
C The arguments X(*), Y(*), and Z(*) are all INTEGER arrays of size
|
|
C 30. See the comments in the routine MPBLAS for the reason for this
|
|
C choice.
|
|
C
|
|
C***SEE ALSO DQDOTA, DQDOTI, MPBLAS
|
|
C***REFERENCES H. Kuki and W. J. Cody, A statistical study of floating
|
|
C point number systems, Communications of the ACM 16, 4
|
|
C (April 1973), pp. 223-230.
|
|
C R. P. Brent, On the precision attainable with various
|
|
C floating-point number systems, IEEE Transactions on
|
|
C Computers C-22, 6 (June 1973), pp. 601-607.
|
|
C R. P. Brent, A Fortran multiple-precision arithmetic
|
|
C package, ACM Transactions on Mathematical Software 4,
|
|
C 1 (March 1978), pp. 57-70.
|
|
C R. P. Brent, MP, a Fortran multiple-precision arithmetic
|
|
C package, Algorithm 524, ACM Transactions on Mathema-
|
|
C tical Software 4, 1 (March 1978), pp. 71-81.
|
|
C***ROUTINES CALLED MPADD3, MPCHK, MPERR, MPNZR, MPSTR
|
|
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 890531 Changed all specific intrinsics to generic. (WRB)
|
|
C 891214 Prologue converted to Version 4.0 format. (BAB)
|
|
C 900402 Added TYPE section. (WRB)
|
|
C 920528 Added a REFERENCES section revised. (WRB)
|
|
C 930124 Increased Array size in MPCON for SUN -r8. (RWC)
|
|
C***END PROLOGUE MPADD2
|
|
COMMON /MPCOM/ B, T, M, LUN, MXR, R(30)
|
|
INTEGER B, T, R, X(*), Y(*), Z(*), Y1(*), TRUNC
|
|
INTEGER S, ED, RS, RE
|
|
C***FIRST EXECUTABLE STATEMENT MPADD2
|
|
IF (X(1).NE.0) GO TO 20
|
|
10 CALL MPSTR(Y, Z)
|
|
Z(1) = Y1(1)
|
|
RETURN
|
|
20 IF (Y1(1).NE.0) GO TO 40
|
|
30 CALL MPSTR (X, Z)
|
|
RETURN
|
|
C COMPARE SIGNS
|
|
40 S = X(1)*Y1(1)
|
|
IF (ABS(S).LE.1) GO TO 60
|
|
CALL MPCHK (1, 4)
|
|
WRITE (LUN, 50)
|
|
50 FORMAT (' *** SIGN NOT 0, +1 OR -1 IN CALL TO MPADD2,',
|
|
1 ' POSSIBLE OVERWRITING PROBLEM ***')
|
|
CALL MPERR
|
|
Z(1) = 0
|
|
RETURN
|
|
C COMPARE EXPONENTS
|
|
60 ED = X(2) - Y(2)
|
|
MED = ABS(ED)
|
|
IF (ED) 90, 70, 120
|
|
C EXPONENTS EQUAL SO COMPARE SIGNS, THEN FRACTIONS IF NEC.
|
|
70 IF (S.GT.0) GO TO 100
|
|
DO 80 J = 1, T
|
|
IF (X(J+2) - Y(J+2)) 100, 80, 130
|
|
80 CONTINUE
|
|
C RESULT IS ZERO
|
|
Z(1) = 0
|
|
RETURN
|
|
C HERE EXPONENT(Y) .GE. EXPONENT(X)
|
|
90 IF (MED.GT.T) GO TO 10
|
|
100 RS = Y1(1)
|
|
RE = Y(2)
|
|
CALL MPADD3 (X, Y, S, MED, RE)
|
|
C NORMALIZE, ROUND OR TRUNCATE, AND RETURN
|
|
110 CALL MPNZR (RS, RE, Z, TRUNC)
|
|
RETURN
|
|
C ABS(X) .GT. ABS(Y)
|
|
120 IF (MED.GT.T) GO TO 30
|
|
130 RS = X(1)
|
|
RE = X(2)
|
|
CALL MPADD3 (Y, X, S, MED, RE)
|
|
GO TO 110
|
|
END
|