*DECK C$DEXP
          IDENT  C$DEXP 
          TITLE  C$DEXP - FORTRAN 5 DOUBLE PREC. EXPONENTIAL
          COMMENT         FORTRAN 5 DOUBLE PREC. EXPONENTIAL
*         COPYRIGHT CONTROL DATA CORP 1978,1979,1980,1981,1982
* 
*         CONTROL DATA PROPRIETARY PRODUCT
  
 XM       SET    1           UPPER PART OF ARGUMENT 
 XZ       SET    2           LOWER PART OF ARGUMENT 
  
  
  
*                PASS EULER 
*                MM = +- PACK(0,0)
*                AMZ = ARGUMENT 
          ENTRY  C$DEXP 
 C$DEXP   DATA   0           ENTRY/EXIT WORD
* M       A-M 3-40--------5 GENERATED BELOW SET'S VIA FCLTEXT:  
 MA       SET 3 
 MC       SET   4 
 MD       SET    0
 MM       SET             5 
  
 AM       SET    7
 AZ       SET    6
          SX.MC  366335B
          BX.AM  X.XM 
          AX.XM  59 
          SB1    1
          BX.AZ  X.XZ 
          PX.MM  X.XM 
          SA.AM  SAVX 
          BX.MA  X.XM-X.AM   ABS(X) 
          LX.MC  -19         1070*LN(2) 
          SA.AZ  A.AM+B1
          IX.MD  X.MC-X.MA   CATCH IND, INF AND MOST LARGE ARGUMENTS
          SB4    RET         SET RETURN ADDRESS FOR DEULER
          PL     X.MD,DEULER
          EQ     ERR
  
*                DEULER RETURNS HERE
 RET      BSS    0
*                TMZ = (1 + CMZ+SMZ) * 2**N 
 SZ       SET    7
 CZ       SET    1
* T       A-M 0736041-----6 GENERATED BELOW SET'S VIA FCLTEXT:  
 TA       SET 0 
 TB       SET  7
 TC       SET   3 
 TD       SET    6
 TE       SET     0 
 TF       SET      4
 TG       SET       1 
 TM       SET             6 
  
 TL       SET    4
  
* T       N-Z 3-152350---27 GENERATED BELOW SET'S VIA FCLTEXT:  
 TN       SET 3 
 TP       SET   1 
 TQ       SET    5
 TR       SET     2 
 TS       SET      3
 TT       SET       5 
 TU       SET        0
 TY       SET            2
 TZ       SET             7 
  
 TO       SET    5
          RX.TN  X.SZ+X.CZ
          RX.TY  X.TN+X.TO
          SX.TB  17204B 
          FX.TA  X.TL+X.TY
          DX.TP  X.TL+X.TY
          LX.TB  45          1.0
          FX.TC  X.TB+X.TA
          DX.TQ  X.TB+X.TA
          NX.TD  X.TC 
          DX.TR  X.TD+X.TQ
          FX.TE  X.TD+X.TQ
          RX.TS  X.TP+X.TR
          NO
          DX.TT  X.TE+X.TS
          FX.TF  X.TE+X.TS
          UX.TU  X.TT,B4
          UX.TG  X.TF,B2
          SB4    B4+B3
          SB2    B2+B3
          PX.TZ  X.TU,B4
          SB3    -1777B 
          PX.TM  X.TG,B2
          LT     B4,B3,UND   IF BOTTOM DID UNDERFLOW
          SB4    B2+B3
          LT     B4,C$DEXP
          EQ     ERR         IF OVERFLOW
  
 UND      SX7    0           LOWER UNDERFLOW
          GT     B2,B3,C$DEXP IF TOP DID NOT UNDERFLOW
 ERR      SA1    SAVX 
*         VISA   ERRBAD,LRG-RJS 
          SA2    A1+1 
          PL     X.XM,RJS 
          ID     X.XM,RJS 
*         VISA   ERR118,TINY-RJS
  
 RJS      BSS    0
*         RJT    SYS1ST.
          ID     X1,C$DEXP
          MX2    11 
          AX1    60 
          LX2    -1          +INF FOR LARGE +X
          BX6    -X1*X2      0 FOR LARGE -X 
          BX7    X6 
          EQ     C$DEXP 
 SAVX     BSS    2
*LRG      DATA   C/TOO LARGE /
*TINY     DATA   C*TOO SMALL, RESULT UNDERFLOW* 
          TITLE  DEULER - ROUTINE FOR DEXP
*         COPYRIGHT CONTROL DATA CORP 1978,1979,1980,1981,1982
* 
*         CONTROL DATA PROPRIETARY PRODUCT
          SST 
          LIST   F,X
          NOREF  I,R
  
*         DEULER DOES ARGUMENT REDUCTION
*                A = N * LN(2) + Z ,
*         EVALUATION OF 
*                S = SINH(Z) ,
*         COMPUTATION OF
*                C = COSH(Z) - 1 = SQRT(1 + S**2) - 1 , 
*         AND PART OF 
*                T = C + S .
*         INPUT..      AMZ, MM
*         OUTPUT..     SMZ, CMZ, TLO, B3=N
  
 LOG2E    DATA   1.4426950408889634 
          DATA   17165427102775740000B
          DATA   16544347571527440000B
          DATA   16107435471400374573B
          DATA   17304200705116007646B    272.11063290371021
          DATA   16677463056525203471B    .56622828495781118E-07
          DATA   61221361541035054565B  -.0000000000474970880178988087
          DATA   16666563105317725074B   .0000000250521083854439304505
 TEMPZZ   BSS    1
          DATA   17155252525252525252B   .1666666666666666666666666667
          DATA   16355252525252525270B
          DATA   17114210421042104210B   .0083333333333333333333333123
          DATA   16314210421041564350B
          DATA   17036400640064006400B   .0001984126984126984127004664
          DATA   16236400645042266044B
 D9       BSS 
          DATA   16755616743512533071B   .0000027557319223985889740833
          DATA   16154654216400045006B
  
 DEULER   BSS 
 AM       SET    7
 AZ       SET    6
  
* N       A-M 421---------0 GENERATED BELOW SET'S VIA FCLTEXT:  
 NA       SET 4 
 NB       SET  2
 NC       SET   1 
 NM       SET             0 
  
 MM       SET    5
* Z       A-M 321115------4 GENERATED BELOW SET'S VIA FCLTEXT:  
 ZA       SET 3 
 ZB       SET  2
 ZC       SET   1 
 ZD       SET    1
 ZE       SET     1 
 ZF       SET      5
 ZM       SET             4 
  
* Z       N-Z 45346703----7 GENERATED BELOW SET'S VIA FCLTEXT:  
 ZN       SET 4 
 ZO       SET  5
 ZP       SET   3 
 ZQ       SET    4
 ZR       SET     6 
 ZS       SET      7
 ZT       SET       0 
 ZU       SET        3
 ZZ       SET             7 
  
*                N = A * LOG2(E)
          SA.NA  LOG2E
          SA.ZA  A.NA+B1
          FX.NB  X.NA*X.AM
          SA.ZN  A.ZA+B1
          RX.NC  X.MM+X.NB
          NX.NM  X.NC        FLOATING N FOR USE BELOW 
          SB3    X.NC        INTEGER N FOR OUTPUT 
*                ZMZ = AMZ - N * LN(2)
          SA.ZO  A.ZN+B1
          FX.ZB  X.ZA*X.NM
          FX.ZP  X.ZN*X.NM
          FX.ZC  X.AM-X.ZB
          FX.ZD  X.ZC-X.ZB
          FX.ZQ  X.AZ-X.ZP
          NX.ZE  X.ZD 
          DX.ZR  X.AZ-X.ZP
          FX.ZT  X.ZO*X.NM
          FX.ZF  X.ZE+X.ZQ
          DX.ZS  X.ZE+X.ZQ
* P       A-M 12362125717-2 GENERATED BELOW SET'S VIA FCLTEXT:  
 PA       SET 1 
 PB       SET  2
 PC       SET   3 
 PD       SET    6
 PE       SET     2 
 PF       SET      1
 PG       SET       2 
 PH       SET        5
 PI       SET         7 
 PJ       SET          1
 PK       SET           7 
 PM       SET             2 
  
* P       N-Z 2135522522626 GENERATED BELOW SET'S VIA FCLTEXT:  
 PN       SET 2 
 PO       SET  1
 PP       SET   3 
 PQ       SET    5
 PR       SET     5 
 PS       SET      2
 PT       SET       2 
 PU       SET        5
 PV       SET         2 
 PW       SET          2
 PX       SET           6 
 PY       SET            2
 PZ       SET             6 
  
          SA.PB  A.ZO+B1
          NX.ZM  X.ZF 
          RX.ZU  X.ZR-X.ZT
          SA.PA  A.PB+1 
*                Q = Z**2  (USE UPPER, COMPENSATE LATER)
 QM       SET    0
 QZ       SET    6
*                PG= Q * (PA/(PB-Q) + PC)    (IN SINGLE PRECISION)
          FX.QM  X.ZM*X.ZM
          RX.ZZ  X.ZS+X.ZU
          SA.PC  A.PA+B1
          FX.PD  X.PB-X.QM
          FX.PE  X.PA/X.PD
          SA.PH  A.PC+B1
          DX.QZ  X.ZM*X.ZM
          SA.ZZ  A.PH+B1     TEMPZZ 
          FX.PF  X.PE+X.PC
          FX.PG  X.QM*X.PF
          SA.PJ  D9 
          SA.PP  A.PJ+1 
*                PIN=PH + PG    (SINGLE QUANTITIES ADDED IN D.P.) 
          FX.PI  X.PH+X.PG
          DX.PN  X.PH+X.PG
*                PMZ = Q *(D3 + Q *(D5 + ... (D9 + Q *PIN)...)) 
          FX.PU  X.PI*X.QZ
          FX.PT  X.QM*X.PN
          SB2    4
  
 POLY     FX.PW  X.PT+X.PU
          DX.PQ  X.QM*X.PI
          SB2    B2-B1
          FX.PK  X.QM*X.PI
          FX.PV  X.PW+X.PP
          SA.PP  A.PJ-B1
          FX.PS  X.PV+X.PQ
          DX.PR  X.PJ+X.PK
          FX.PI  X.PJ+X.PK
          SA.PJ  A.PP-B1
          FX.PY  X.PS+X.PR
          FX.PU  X.PI*X.QZ
          FX.PT  X.QM*X.PY
          GT,B2  POLY 
 ZZ       SET    PP 
  
          DX.PO  X.QM*X.PI
          FX.PX  X.PT+X.PU
          FX.PM  X.QM*X.PI
          FX.PZ  X.PO+X.PX
  
*                SLY = ZM + ZM * PMZ
* S       A-M 1----------76 GENERATED BELOW SET'S VIA FCLTEXT:  
 SA       SET 1 
 SL       SET            7
 SM       SET             6 
  
* S       N-Z 5645--6--3447 GENERATED BELOW SET'S VIA FCLTEXT:  
 SN       SET 5 
 SO       SET  6
 SP       SET   4 
 SQ       SET    5
 ST       SET       6 
 SW       SET          3
 SX       SET           4 
 SY       SET            4
 SZ       SET             7 
  
          FX.SA  X.ZM*X.PM
          DX.SN  X.ZM*X.PM
          FX.SL  X.ZM+X.SA
          RX.SO  X.ZM*X.PZ
          DX.SP  X.ZM+X.SA
  
*                HI =(3*Z**2 + S**2)/16  (AS CHEAPLY AS POSSIBLE) 
*                HJ = HI+HI 
*                HK = 2*(1+HJ)
*                HL = (S**2 - HJ) / HK - HI 
*                HM = HJ + (HK-HL)*(HL/HK)
*                   BECAUSE 
*                COSH = 1 + Z**2/2 + Z**4/24 + Z**6/720 + 
*                S    =   Z + Z**3/6 + Z**5/120 + 
*                HI   =     Z**2/4 + Z**4/48 + Z**6/360 + 
*                HI IS ABOUT (COSH-1)/2.
*                HJ THRU HM IS TWO HERON  ITERATIONS TO SOLVE 
*                   COSH = SQRT(1+SINH**2)
  
* H       A-M 6106062505650 GENERATED BELOW SET'S VIA FCLTEXT:  
 HA       SET 6 
 HB       SET  1
 HC       SET   0 
 HD       SET    6
 HE       SET     0 
 HF       SET      6
 HG       SET       2 
 HH       SET        5
 HI       SET         0 
 HJ       SET          5
 HK       SET           6 
 HL       SET            5
 HM       SET             0 
  
* H       N-Z 2-62-020      GENERATED BELOW SET'S VIA FCLTEXT:  
 HN       SET 2 
 HP       SET   6 
 HQ       SET    2
 HS       SET      0
 HT       SET       2 
 HU       SET        0
  
          MX.HT  11          *4 
          FX.HB  X.SL*X.SL
          RX.SQ  X.SN+X.SO
          FX.HA  X.QM-X.HB
          IX.HC  X.QM-X.HT   HC = 4*QM
          FX.HD  X.HC-X.HA   FIRST GUESS *8 
          UX.HE  X.HD,B2
          AX.HE  4
          PX.HS  X.HE,B2
          RX.SY  X.SP+X.SQ
          SX.HF  17214B 
          NX.HI  X.HS        FIRST GUESS /2 
          FX.HJ  X.HI+X.HI   HJ = 2*HI
          LX.HF  45          2.0
          IX.HG  X.HI-X.HT
          FX.HH  X.HB-X.HJ
          FX.HK  X.HF+X.HG
          FX.HN  X.HH/X.HK
          FX.HL  X.HN-X.HI
          FX.HP  X.HL/X.HK
          FX.HU  X.HI+X.HN
          FX.HQ  X.HL*X.HP
          RX.HM  X.HU-X.HQ
  
*                SZ = SY +(ZZ + HM*ZZ)
*                THIS CORRECTS THE LOWER PART OF S FOR
*                    LEAVING OUT ZZ.
*                SMZ IS NOW THE SINH(ZMZ).
  
* C       A-M 65115-----15- GENERATED BELOW SET'S VIA FCLTEXT:  
 CA       SET 6 
 CB       SET  5
 CC       SET   1 
 CD       SET    1
 CE       SET     5 
 CK       SET           1 
 CL       SET            5
  
 CM       SET HM
  
* C       N-Z 2223353233521 GENERATED BELOW SET'S VIA FCLTEXT:  
 CN       SET 2 
 CO       SET  2
 CP       SET   2 
 CQ       SET    3
 CR       SET     3 
 CS       SET      5
 CT       SET       3 
 CU       SET        2
 CV       SET         3 
 CW       SET          3
 CX       SET           5 
 CY       SET            2
 CZ       SET             1 
  
          DX.CO  X.SL*X.SL
          FX.ST  X.HM*X.ZZ
          DX.CS  X.HM*X.HM   [HM**2]LOWER 
          RX.SW  X.ZZ+X.ST
          FX.CA  X.HM+X.HM
          RX.SX  X.SY+X.SW
  
*                CKX = [S**2]UPPER - 2*HM 
*                CLY = CK  - [HM**2]UPPER 
*                CZ =(CL + CX + [S**2]LOWER + CY - [HM**2]LOWER)/(2+2HM)
*                IN OTHER WORDS 
*                COSH-1 = GUESS + (SINH**2 -2*GUESS-GUESS**2)/2(1+GUESS)
          FX.CQ  X.CO-X.CS
          FX.CN  X.SL*X.SX
          DX.CX  X.HB-X.CA
          FX.CC  X.HB-X.CA
          FX.CR  X.CX+X.CQ
          FX.CB  X.HM*X.HM
          NX.CK  X.CC 
          FX.CP  X.CN+X.CN
          FX.CT  X.CP+X.CR
          DX.CY  X.CK-X.CB
          FX.CL  X.CK-X.CB
          SX.CD  17214B 
          FX.CV  X.CT+X.CY
          LX.CD  45          X.CD = 2.0 
          NX.CU  X.CL 
          RX.CE  X.CD+X.CA
          RX.CW  X.CU+X.CV
          FX.SM  X.SL+X.SX   CLEAN UP SINH
          DX.SZ  X.SL+X.SX
          FX.CZ  X.CW/X.CE
  
*                TMZ = SMZ + CMZ   (SINH + COSH-1)
 TL       SET    4
 TO       SET    5
          DX.TO  X.SM+X.CM
          FX.TL  X.SM+X.CM
          JP     B4 
  
          END 
