mirror of
https://git.planet-casio.com/Lephenixnoir/OpenLibm.git
synced 2025-01-01 06:23:39 +01:00
67 lines
1.9 KiB
Fortran
67 lines
1.9 KiB
Fortran
*DECK R9PAK
|
|
FUNCTION R9PAK (Y, N)
|
|
C***BEGIN PROLOGUE R9PAK
|
|
C***PURPOSE Pack a base 2 exponent into a floating point number.
|
|
C***LIBRARY SLATEC (FNLIB)
|
|
C***CATEGORY A6B
|
|
C***TYPE SINGLE PRECISION (R9PAK-S, D9PAK-D)
|
|
C***KEYWORDS FNLIB, PACK
|
|
C***AUTHOR Fullerton, W., (LANL)
|
|
C***DESCRIPTION
|
|
C
|
|
C Pack a base 2 exponent into floating point number Y. This
|
|
C routine is almost the inverse of R9UPAK. It is not exactly
|
|
C the inverse, because ABS(X) need not be between 0.5 and
|
|
C 1.0. If both R9PAK and 2.0**N were known to be in range, we
|
|
C could compute
|
|
C R9PAK = Y * 2.0**N .
|
|
C
|
|
C***REFERENCES (NONE)
|
|
C***ROUTINES CALLED I1MACH, R1MACH, R9UPAK, XERMSG
|
|
C***REVISION HISTORY (YYMMDD)
|
|
C 790801 DATE WRITTEN
|
|
C 890531 Changed all specific intrinsics to generic. (WRB)
|
|
C 890531 REVISION DATE from Version 3.2
|
|
C 891214 Prologue converted to Version 4.0 format. (BAB)
|
|
C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ)
|
|
C 901009 Routine used I1MACH(7) where it should use I1MACH(10),
|
|
C Corrected (RWC)
|
|
C***END PROLOGUE R9PAK
|
|
LOGICAL FIRST
|
|
SAVE NMIN, NMAX, A1N210, FIRST
|
|
DATA A1N210 / 3.321928094 887362 E0/
|
|
DATA FIRST /.TRUE./
|
|
C***FIRST EXECUTABLE STATEMENT R9PAK
|
|
IF (FIRST) THEN
|
|
A1N2B = 1.0
|
|
IF (I1MACH(10).NE.2) A1N2B = R1MACH(5)*A1N210
|
|
NMIN = A1N2B*I1MACH(12)
|
|
NMAX = A1N2B*I1MACH(13)
|
|
ENDIF
|
|
FIRST = .FALSE.
|
|
C
|
|
CALL R9UPAK(Y,R9PAK,NY)
|
|
C
|
|
NSUM = N + NY
|
|
IF (NSUM.LT.NMIN) GO TO 40
|
|
IF (NSUM .GT. NMAX) CALL XERMSG ('SLATEC', 'R9PAK',
|
|
+ 'PACKED NUMBER OVERFLOWS', 2, 2)
|
|
C
|
|
IF (NSUM.EQ.0) RETURN
|
|
IF (NSUM.GT.0) GO TO 30
|
|
C
|
|
20 R9PAK = 0.5*R9PAK
|
|
NSUM = NSUM + 1
|
|
IF(NSUM.NE.0) GO TO 20
|
|
RETURN
|
|
C
|
|
30 R9PAK = 2.0*R9PAK
|
|
NSUM = NSUM - 1
|
|
IF(NSUM.NE.0) GO TO 30
|
|
RETURN
|
|
C
|
|
40 CALL XERMSG ('SLATEC', 'R9PAK', 'PACKED NUMBER UNDERFLOWS', 1, 1)
|
|
R9PAK = 0.0
|
|
RETURN
|
|
C
|
|
END
|