         TITLE    'LIB-B00,08/22/73,DWG702985'
         PAGE
*
*
*  E X T E R N A L    C O M M U N I C A T I O N
*
*
*  DEFINITIONS
*
         DEF      CIRCULAR          'CIRCULAR' FUNCTION EVAL
         DEF      FEXP              FLOT EXPONENTIAL EVAL
         DEF      FFLOG             FLOT DYADIC LOGARITHM
         DEF      FFPOWER           FLOT BASE TO FLOT POWER EVAL
         DEF      FIPOWER           FLOT BASE TO INTG POWER EVAL
         DEF      FLOG              FLOT MONADIC LOGARITHM
         DEF      FSQRT             FLOT SQUARE ROOT
         DEF      IIPOWER           INTG BASE TO INTG POWER EVAL
         DEF      LIB@             START OF PROCEDURE
*
*  REFERENCES
*
         REF      ERDOMAIN          DOMAIN ERROR
         REF      F2I               CONVERT FLOATING TO INTEGER
         REF      INTGOVFL          INTEGER OVERFLOW (DOMAIN CHANGE)
         REF      LIBTEMPS          TEMPS ARE IN WINDOW IN APLUTSI      U07-0004
         PAGE
*
*
*  A S S E M B L Y    P A R A M E T E R S
*
*
         SYSTEM   SIG5F
PROGSECT CSECT    1
*
*  REGISTERS
*
N        EQU      3                 INDEX REG
LX       EQU      5                 INDEX LINK REG
AI       EQU      7                 LEFT ARG     INTG
BI       EQU      9                 RIGHT ARG    INTG
CI       EQU      13                EXTRA        INTG
AF       EQU      6                 LEFT ARG     FLOT
AF1      EQU      7                     *
BF       EQU      8                 RIGHT ARG    FLOT
BF1      EQU      9                     *
CF       EQU      12                EXTRA        FLOT
CF1      EQU      13                    *
FL       EQU      14                FLAG REG
         PAGE
*
*
*  P R O C S
*
*
TLOC     SET      0                                                     U07-0006
*
TEMP     CNAME    1
DTEMP    CNAME    2
         PROC
         DO1      NAME=2
TLOC     SET      TLOC+(TLOC&1)                                         U07-0009
         DISP     TLOC                                                  U07-0010
LF       EQU      LIBTEMPS+TLOC                                         U07-0011
TLOC     SET      TLOC+NAME                                             U07-0012
         PEND
*
*
EVEN     CNAME    0
ODD      CNAME    1
         PROC
LF       EQU      %
         ERROR,1,(CF(2)+NAME)&1   'REGISTER HAS WRONG PARITY'
         PEND
*
*
EQUAL    CNAME
         PROC
LF       EQU      %
         ERROR,1,1-(CF(2)=CF(3))  'REGISTERS MUST BE EQUAL'
         PEND
         PAGE
*
*
*  F U N C T I O N    E V A L U A T O R S
*
*
*              THE FUNCTION EVALUATION SUBROUTINES MUST NOT CLOBBER
*              REGISTERS 1, 2, 4, 10, 11 (KNOWN BY XSEG-GENERATING
*              MODULES AS N, K, N1, N2, AND N3).
*
*
         USECT    PROGSECT
LIB@     RES      0                START OF PROCEDURE
*
*
*  CIRCULAR FUNCTION JUMP TABLE
*
*              CALLED BY 'BAL,LX  CIRCULAR,X'  WITH LEFT ARG (INTEGER
*              BETWEEN -7 AND +7) IN X AND RIGHT ARG IN AF/AF1.
*              RESULT RETURNED IN AF/AF1.
*
CIRCULAR EQU      %+7
         B        FARCTANH          -7
         B        FARCCOSH          -6
         B        FARCSINH          -5
         B        FCIRCM4           -4
         B        FARCTAN           -3
         B        FARCCOS           -2
         B        FARCSIN           -1
         B        FCIRC0             0
         B        FSIN              +1
         B        FCOS              +2
         B        FTAN              +3
         B        FCIRC4            +4
         B        FSINH             +5
         B        FCOSH             +6
         B        FTANH             +7
         PAGE
*
*
*  DOUBLE PRECISION SINE                                        FSIN
*  DOUBLE PRECISION COSINE                                      FCOS
*
*  CONSTANTS
*
         BOUND    8
C0MC0    DATA     X'3A27311C',-X'3A27311C' +-RT(6/16**14)=0.9125056E-8
S5       DATA     X'C3C39FF1',X'C5110D64' -0.359864337061349258D-5
S4       DATA     X'3DA83C17',X'ED1FC206' 0.160441150747149909D-3
S3       DATA     X'C0ECD2D3',X'31D1A201' -0.468175413234161887D-2
S2       DATA     X'401466BC',X'677587FA' 0.796926262460430410D-1
S1       DATA     X'BF5AA218',X'CED20DF6' -0.645964097506244317
S0       DATA     X'411921FB',X'54442D18' 1.57079632679489662
C5       DATA     X'C2E59363',X'E0BB8C31' -0.252001354549174792D-4
C4       DATA     X'3E3C3E9F',X'6C141B84' 0.919259950095279119D-3
C3       DATA     X'C0AA8B0E',X'09009BCE' -0.208634807349535199D-1
C2       DATA     X'4040F07C',X'206C1E1C' 0.253669507899865139
C1       DATA     X'BEEC42C3',X'3641BA75' -1.23370055013615135
C0       DATA     X'40FFFFFF',X'FFFFFFFD' 0.999999999999999953
MASK     DATA     X'3FFFFFF'
MC6      DATA     X'C4830908'       -C6
C6       DATA     X'3B7CF6F8'       0.465529873E-6
S6       DATA     X'3AF1F9C8'       0.563393613E-7
         SPACE    3
FSIN     RES      0                 SINE ENTRY
         CLM,AF   C0MC0             CHECK FOR VERY SMALL X
         BCS,2    2A3               BRANCH IF LARGE POSITIVE
         BCS,4    2A1               BRANCH IF LARGE NEGATIVE
         B        0,LX              RETURN X FOR SIN(SMALL X)
         SPACE    3
FCOS     RES      0                 COSINE ENTRY
         LI,FL    X'100'            INDICATE COSINE - ROTATE 1 QUADRANT
         CLM,AF   C0MC0             CHECK FOR VERY SMALL X
         BCS,2    2A4               BRANCH IF LARGE POSITIVE
         BCS,4    2A2               BRANCH IF LARGE NEGATIVE
         LD,AF    ONE               RETURN 1.0D0
         B        0,LX                FOR COS(SMALL X)
2A1      LW,FL    ONE               INDICATE SIN(NEGATIVE)
2A2      FML,AF   M2OPI             CONVERT TO QUADRANTS, CHANGE SIGN
         B        3A1               PROCEED
2A3      LI,FL    0                 INDICATE SIN(POSITIVE)
2A4      FML,AF   2OPI              CONVERT TO QUADRANTS
3A1      LB,N     AF                BIASED EXPONENT
         AI,N     -X'4E'            CHECK FOR SIGNIFICANCE
         BLZ      3A3               BRANCH IF OK
         B        ERDOMAIN          ERROR
3A3      AI,N     X'E'              UNBIASED EXPONENT
         BLZ      3A7               BRANCH IF < 1/16 QUADRANT
         SLS,N    2                 MULTIPLY BY 4
         SLD,AF   0,N               SCALE B7
         AND,AF   MASK              MOD 4 NUMBER OF QUADRANTS
         AH,FL    AF                NUMBER OF QUADRANTS WITH COS MOD
         CI,FL    X'200'            CHECK UPPER/LOWER SEMICIRCLE
         BAZ      %+2               SKIP IF UPPER
         EOR,FL   ONE               INVERT SIGN CHANGE FLAG
         CI,FL    X'80'             FRACTION : 0.5
         BAZ      3A6               BRANCH IF < 0.5
         LI,N     X'BF'             INSERT
         STB,N    AF                  EXPONENT
         CI,FL    X'4100'           CHECK SIGN CHANGE AND EVEN/ODD QUAD.
         BL       3A4               BRANCH IF NO SIGN CHANGE
         BANZ     4A6               BRANCH IF ODD QUADRANT
4A1      FML,AF   AF                H=F*F
4A3      STD,AF   TEMP0             COPY H
4A4      FMS,AF   MC6               NEGATIVE
         FSL,AF   C5                  COSINE
         FML,AF   TEMP0             *H,-C(I)
         FSL,AF   C4
         FML,AF   TEMP0
         FSL,AF   C3
         FML,AF   TEMP0
         FSL,AF   C2
         FML,AF   TEMP0
         FSL,AF   C1
         FML,AF   TEMP0
         FSL,AF   C0
         B        0,LX              RETURN
3A4      BAZ      4A11              BRANCH IF EVEN QUADRANT
3A5      LCD,AF   AF                NEGATIVE FOR SINE EXPANSION
4A6      RES      0                 PLACE
4A8      STD,AF   TEMP0             COPY F
         FML,AF   TEMP0             H=F*F
         STD,AF   TEMP2             COPY H
4A9      FMS,AF   S6                SINE
         FAL,AF   S5                  POLYNOMIAL
         FML,AF   TEMP2             *H,+S(I)
         FAL,AF   S4
         FML,AF   TEMP2
         FAL,AF   S3
         FML,AF   TEMP2
         FAL,AF   S2
         FML,AF   TEMP2
         FAL,AF   S1
         FML,AF   TEMP2
         FAL,AF   S0
         FML,AF   TEMP0             *F
         B        0,LX              RETURN
3A6      LI,N     X'40'             INSERT
         STB,N    AF                  EXPONENT
3A7      CI,FL    X'4100'           CHECK SIGN CHANGE AND ODD/EVEN QUAD.
         BL       3A8               BRANCH IF NO SIGN CHANGE
         BANZ     4A1               BRANCH IF ODD QUADRANT
         OR,AF1   =1                FORCE NON-ZERO MANTISSA
         B        3A5               NEGATIVE RESULT, USE SIN EXPANSION
3A8      BAZ      4A6               BRANCH IF EVEN QUADRANT
4A11     FML,AF   AF                H=F*F
4A13     STD,AF   TEMP0             COPY H
4A14     FMS,AF   C6                POSITIVE
         FAL,AF   C5                  COSINE
         FML,AF   TEMP0             *H,+C(I)
         FAL,AF   C4
         FML,AF   TEMP0
         FAL,AF   C3
         FML,AF   TEMP0
         FAL,AF   C2
         FML,AF   TEMP0
         FAL,AF   C1
         FML,AF   TEMP0
         FAL,AF   C0
         B        0,LX              RETURN
         PAGE
*
*  DOUBLE PRECISION TANGENT                                     FTAN
*
*  CONSTANTS
*
         OPEN     C0MC0
         BOUND    8
X4140    DATA     X'41000000',FS'0.25' 1,.25
A9       DATA,8   FL'1.75402692800053906'
A8       DATA,8   FL'1.20545135789649175'
A7       DATA,8   FL'1.27837471033592976'
A6       DATA,8   FL'1.27300750870003719'
A5       DATA,8   FL'1.27324841140728890'
A4       DATA,8   FL'1.27326113329539502'
A3       DATA,8   FL'1.27343712586329919'
A2       DATA,8   FL'1.27508201993348727'
A1       DATA,8   FL'1.29192819501250237'
A0       DATA,8   FL'1.57079632679489662'
C0MC0    DATA     X'3A1BB67B',-X'3A1BB67B' +-RT(3)/16**7=0.64523921E-8
2OPI     DATA     X'40A2F983',X'6E4E4415' 2/PI=.636619772367581343
M2OPI    DATA     X'BF5D067C',X'91B1BBEB' -2/PI
         SPACE    3
FTAN     RES      0                 ENTRY
         CLM,AF   C0MC0             CHECK FOR VERY SMALL X
         BCS,2    2B1               BRANCH IF LARGE POSITIVE
         BCS,4    1B1               BRANCH IF LARGE NEGATIVE
         B        0,LX              TAN(SMALL X)=X
1B1      LI,FL    1                 INDICATE NEGATIVE X
         FML,AF   M2OPI             CONVERT TO QUADRANTS, CHANGE SIGN
         B        3B1               PROCEED
2B1      LI,FL    0                 INDICATE POSITIVE X
         FML,AF   2OPI              CONVERT TO QUADRANTS
3B1      LB,N     AF                EXPONENT TO INDEX
         CLM,AF   X4140             X : 1.0,0.25
         BCS,4    6B1               BRANCH IF X<0.25
         BCR,2    5B1               BRANCH IF X<1.0
         CI,N     X'4E'             CHECK MAGNITUDE
         BL       4B1               BRANCH IF OK
         B        ERDOMAIN          ERROR
4B1      SLS,N    2                 MULTIPLY BY 4
         SLD,AF   0,N               SCALE B7
         CW,AF    =X'01000000'      CHECK ODD/EVEN QUADRANT
         BAZ      %+2               SKIP IF EVEN
         AI,FL    9                 ODD QUAD - INVERT SIGN CHANGE
5B1      CW,AF    =X'00800000'      : 0.5
         BAZ      %+3               SKIP IF < 0.5
         LCD,AF   AF                1-FRACTION
         EOR,FL   =8                INVERT QUADRANT INDICATOR
         LI,N     X'40'             INSERT
         STB,N    AF                  EXPONENT
6B1      RES      0                 PLACE
6B3      CW,AF    X4140+1           :0.25
         BLE      %+3               BRANCH IF OK
         LI,N     -1                INDICATE > 0.25
         FSL,AF   HALF              F-0.5
         STD,AF   TEMP0             COPY X
         FML,AF   TEMP0             Z=X*X
         STD,AF   TEMP2             COPY Z
         FML,AF   A9                POLY-
         FAL,AF   A8                 NOMIAL
         FML,AF   TEMP2             OF ODD POWERS
         FAL,AF   A7
         FML,AF   TEMP2
         FAL,AF   A6
         FML,AF   TEMP2
         FAL,AF   A5
         FML,AF   TEMP2
         FAL,AF   A4
         FML,AF   TEMP2
         FAL,AF   A3
         FML,AF   TEMP2
         FAL,AF   A2
         FML,AF   TEMP2
         FAL,AF   A1
         FML,AF   TEMP2
         FAL,AF   A0
         FML,AF   TEMP0                   X
         AI,N     0                 CHECK FOR 0.5
         BGEZ     6B5               BRANCH IF NOT
         LCD,BF   AF                -V (POSITIVE)
         FAL,BF   ONE               1-V
         FAL,AF   HALF              ADD
         FAL,AF   HALF               1.0D0
         FDL,AF   BF                (1-V)/(1+V)
6B5      RES      0                 PLACE
6B7      CI,FL    5                 IFLAG : 5
         BL       8B1               BRANCH IF ABS(RESULT)<1
         BAZ      7B1               BRANCH IF NON-NEGATIVE RESULT
         LCD,BF   AF                -P
         B        7B2               PROCEED
7B1      LD,BF    AF                P
7B2      LD,AF    ONE
         FDL,AF   BF                RESULT
         B        0,LX              RETURN
8B1      BAZ      0,LX              RETURN IF POSITIVE
         LCD,AF   AF                CHANGE SIGN
         B        0,LX              RETURN
         PAGE
*
*  DOUBLE PRECISION ARCSINE                                     FARCSIN
*  DOUBLE PRECISION ARCCOSINE                                   FARCCOS
*
*  CONSTANTS
*
         BOUND    8
X40      DATA     X'40000000'       BIAS BIT
X208     DATA     FX'32.5B7'        TO CORRECT BIAS AND ADD 1/2
ONEM     DATA     X'40FFFFFF',-1    1-2**(-56)
         SPACE    3
FARCCOS  RES      0                 ARCCOSINE ENTRY
         OR,LX    X40               INDICATE ARCCOSINE
         SPACE    3
FARCSIN  RES      0                 ARCSINE ENTRY
1C2      STD,AF   TEMP6             COPY X
         LCD,BF   TEMP6             -X
1C3      BLEZ     1C5               BRANCH IF X>=0.0D0
         CD,BF    ONE               ABS(X) : 1.0D0
         BL       5C1               BRANCH IF LESS
         BE       3C1               BRANCH IF EQUAL
         B        ERDOMAIN          ERROR
1C5      CD,AF    ONE               X : 1.0D0
         BL       6C1               BRANCH IF LESS
         BG       ERDOMAIN          ERROR IF GREATER
         CW,LX    X40               CHECK FN. IND.
         BAZ      2C1               BRANCH IF ASIN
         LI,AF    0                 ACOS(1)=0, LSH ALREADY 0
         B        0,LX              RETURN
2C1      LD,AF    PI2               ASIN(1)=PI/2
         B        0,LX              RETURN
3C1      CW,LX    X40               CHECK FN. IND.
         BAZ      4C1               BRANCH IF ASIN
         LD,AF    PI                ACOS(-1)=PI
         B        0,LX              RETURN
4C1      LCD,AF   PI2               ASIN(-1)=-PI/2
         B        0,LX              RETURN
5C1      CW,BF    X40               ABS(X) : 1/16
         BAZ      7C1               BRANCH IF LESS
         SLD,BF   -1                OBTAIN
         AW,BF    X208                (1+ABS(X))/2
         LI,N     X'40'               AND
         STB,N    AF                  1-ABS(X)
         B        8C2               PROCEED
6C1      CW,AF    X40               X : 1/16
         BANZ     8C1               BRANCH IF NOT LESS
7C1      EQU      %
         FML,AF   BF                -X*X
         FAL,AF   ONEM              1-X*X
         B        9C1               PROCEED
8C1      SLD,AF   -1                OBTAIN
         AW,AF    X208                (1+X)/2
         LI,N     X'40'               AND
         STB,N    BF                  1-X
8C2      FML,AF   BF                (1-X*X)/2
         FAL,AF   AF                1-X*X
9C1      RES      0                 PLACE
9C3      STW,LX   TEMP5             SAVE LINK
9C4      BAL,LX   FSQRT             Y=RT(1-X*X)
10A2     LW,LX    TEMP5             RESTORE LINK
         CW,LX    X40               CHECK FUNCTION INDICATOR
         BANZ     10C3              BRANCH IF ACOS
         LD,BF    AF                2ND ARG= Y
         LD,AF    TEMP6             1ST ARG = X
10C5     B        FARCTAN2          OBTAIN RESULT FOR ASIN
10C3     LD,BF    TEMP6             2ND ARG =X
10C4     B        FARCTAN2          OBTAIN RESULT FOR ACOS
         PAGE
*
*  DOUBLE PRECISION ARCTANGENT-1 ARGUMENT, 2 QUADRANT RESOLUTN. FARCTAN
*  DOUBLE PRECISION ARCTANGENT-2 ARGUMENTS, 4 QUADRNT RESOLUTN. FARCTAN2
*
*  CONSTANTS - DO NOT REORDER CONSTANTS
*
         OPEN     MASK,A4,A3,A2,A1,A0
         BOUND    8
TABLE    DATA,8   0                 0.0D0 ATAN(0)
ONE      DATA,8   FL'1.0'           1.0D0
         DATA     X'401FD5BA',X'9AAC2F6E' .124354994546761435=ATAN(1/8)
PI2      DATA     X'411921FB',X'54442D18' 1.57079632679489656=PI/2
         DATA     X'403EB6EB',X'F25901BB' .244978663126864154=ATAN(1/4)
PI       DATA     X'413243F6',X'A8885A30' 3.14159265358979312
         DATA     X'405BD865',X'07937BC2' .358770670270572220=ATAN(3/8)
A4       DATA     X'401C37E9',X'6B3C1CDF' .110228146248221286
         DATA     X'4076B19C',X'1586ED3E' .463647609000806116=ATAN(1/2)
A3       DATA     X'BFDB6DE9',X'65E1CA41' -.142854130388704964
         DATA     X'408F005D',X'5EF7F5A0' .558599315343562436=ATAN(5/8)
A2       DATA     X'40333333',X'212A84EB' .199999995801153276
         DATA     X'40A4BC7D',X'1934F709' .643501108793284387=ATAN(3/4)
A1       DATA     X'BFAAAAAA',X'AAACEB70' -.333333333331284232
         DATA     X'40B8053E',X'2BC2319E' .718829999621624505=ATAN(7/8)
A0       DATA     X'40FFFFFF',X'FFFFFFF5' .999999999999999840
         DATA     X'40C90FDA',X'A22168C2' .785398163397448310=ATAN(1)
MASK     DATA     X'FFFE0000'       MODULO 1/8
         SPACE    3
FARCTAN  RES      0                 1 ARGUMENT ENTRY
         LD,BF    ONE               X=1.0D0
         SPACE    3
FARCTAN2 RES      0                 2 ARGUMENT ENTRY - USED BY
*                                     FARCSIN, FARCCOS
1D1      AI,AF    0                 Y : 0.0
         BG       10D1              BRANCH IF Y>0
         BL       6D1               BRANCH IF Y<0
2D1      AI,BF    0                 X : 0.0
4D1      BG       0,LX              Y=0, X>0, ATAN(Y/X)=0.0D0
         BL       12D1              BRANCH IF X<0
         B        ERDOMAIN          ERROR
6D1      AI,BF    0                 X:0
         BGEZ     9D1               BRANCH IF X>=0
         LI,FL    3                 INDICATE 3RD QUADRANT
         CW,AF    BF                MSH(Y) : MSH(X)
         B        13D2              PROCEED
9D1      LCD,AF   AF                ABS(Y)
         LI,FL    1                 INDICATE 4TH QUADRANT
         B        13D1              PROCEED
10D1     LI,FL    0                 ASSUME 1ST QUADRANT
         AI,BF    0                 X : 0.0
         BGEZ     13D1              BRANCH IF X>=0
12D1     LI,FL    2                 INDICATE 2ND QUADRANT
         LCD,BF   BF                ABS(X)
13D1     CW,BF    AF                MSH(X) : MSH(Y)
13D2     BGE      14D2              BRANCH IF FORMER >= LATTER
13D22    AI,FL    8                 INDICATE NORTH/SOUTH OCTANT
         FDL,BF   AF                U=X/Y
         STD,BF   TEMP0             COPY U
         LW,AF    TEMP0             COPY MSH(U)
         B        15D1              PROCEED
14D2     FDL,AF   BF                U=Y/X
         STD,AF   TEMP0             COPY U
15D1     FAS,AF   ONE               SCALE U
         AI,AF    X'10000'          ROUND TO
         AND,AF   MASK                NEAREST EIGHTH
         LH,N     AF                INDEX TO TABLE
         FSS,AF   ONE               V
         LI,AF1   0                 CLEAR LSH
         LCD,BF   AF                -V
         FML,BF   TEMP0             -V*U
         FSL,AF   TEMP0             V-U
         FSL,BF   ONE               DENOMINATOR
         FDL,AF   BF                (U-V)/(U*V+1.0D0)=Z
         STD,AF   TEMP0             COPY Z
         FML,AF   TEMP0             U=Z*Z
         STD,AF   TEMP2             COPY U
13D23    FML,AF   A4                POLYNOMIAL
         FAL,AF   A3                  EXPANSION
         FML,AF   TEMP2              *U+A(I)
         FAL,AF   A2
         FML,AF   TEMP2
         FAL,AF   A1
         FML,AF   TEMP2
         FAL,AF   A0
         FML,AF   TEMP0             *Z
16D1     FAL,AF   TABLE-X'4110'-X'4110',N  DATAN=TABLE(J)+DATAN(Z)
*  ABOVE HEX CORRECTIONS COMPENSATE FOR 1.0 ADDED TO INDEX ABOVE
16D12    CI,FL    6                 CHECK OCTANT AND SIGN OF X
         BL       16D3              BRANCH IF EAST/WEST OCTANT
         BAZ      16D2              BRANCH IF X POSITIVE
         FAL,AF   PI2               +PI/2
16D14    AI,FL    -10
         BGZ      16D5              BRANCH IF Y NEGATIVE
16D15    B        0,LX              RETURN
16D2     FSL,AF   PI2               -PI/2
16D22    AI,FL    -8
         BEZ      16D5              BRANCH IF Y POSITIVE
16D23    B        0,LX              RETURN
16D3     BAZ      16D4              BRANCH IF X POSITIVE
         FSL,AF   PI                -PI
16D32    AI,FL    -2
         BEZ      16D5              BRANCH IF Y POSITIVE
16D33    B        0,LX              RETURN
16D4     RES      0                 PLACE
16D42    AI,FL    0
         BEZ      0,LX              RETURN IF Y POSITIVE
16D5     LCD,AF   AF                CHANGE SIGN
         B        0,LX              RETURN
         PAGE
*
*  DOUBLE PRECISION HYPERBOLIC SINE                             FSINH
*  DOUBLE PRECISION HYPERBOLIC COSINE                           FCOSH
*
*  CONSTANTS
*
         OPEN     A4,A3,A2,A1,A0
         BOUND    8
C1MC1    DATA     X'42AF5DC3',-X'42AF5DC3' +-175.36628-
MCC      DATA     -X'404285FC',X'404285FC' -+ 0.26
A4       DATA     X'3C2E4DF9',X'BDA9EEDB' .275996875723123788D-5
A3       DATA     X'3DD00CEF',X'963E69E9' .198412447744192579D-3
A2       DATA     X'3F222222',X'228C9C82' .833333333938590834D-2
A1       DATA     X'402AAAAA',X'AAAA9C45' .166666666666615519
A0       DATA,8   FL'1.0'           1.0D0
TWENTY8  DATA     FS'28.0'          28.0
         SPACE    3
FSINH    RES      0                 HYPERBOLIC SINE ENTRY
         CLM,AF   C1MC1             ABS(X) : 175.36628-
         BCR,6    2E1               BRANCH IF OK
         B        ERDOMAIN          ERROR
2E1      CLM,AF   MCC               ABS(X) : 0.26
2E3      BCS,8    7E1               BRANCH IF X > 0.26
         BCS,1    4E1               BRANCH IF X < -0.26
         STD,AF   TEMP4             COPY X
         FML,AF   TEMP4             Z=X*X
         STD,AF   TEMP6             COPY Z
2E4      FML,AF   A4                POLYNOMIAL
         FAL,AF   A3                 OF
         FML,AF   TEMP6             ODD POWERS OF X
         FAL,AF   A2
         FML,AF   TEMP6
         FAL,AF   A1
         FML,AF   TEMP6
         FAL,AF   A0
         FML,AF   TEMP4             FINAL FACTOR
         B        0,LX              RETURN
4E1      FML,AF   MLN2INV           X=X/LN(2)
         STW,LX   TEMP4             SAVE LINK
4E2      CW,AF    TWENTY8           X : 28.0
         BL       6E1               BRANCH IF RECIPROCAL IS SIGNIFICANT
         FSL,AF   ONE               TO DIVIDE RESULT BY 2.0D0
5E1      BAL,LX   FEXP1             OBTAIN ABS(RESULT)
         LCD,AF   AF                SET NEGATIVE SIGN
5E3      B       *TEMP4             RETURN
6E1      BAL,LX   FEXP1             OBTAIN 2**X
         LCD,BF   ONE               -1.0
         FDL,BF   AF                -1.0/2**X
         FAL,AF   BF                2**X-1.0/2**X
         FML,AF   MHALF             RESULT
6E3      B       *TEMP4             RETURN
7E1      FML,AF   LN2INV            X=X/LN(2)
7E2      CW,AF    TWENTY8           X : 28.0
         BL       8E1               BRANCH IF RECIPROCAL IS SIGNIFICANT
7E3      FSL,AF   ONE               TO DIVIDE RESULT BY 2.0D0
7E4      B        FEXP1             OBTAIN RESULT
8E1      RES      0                 PLACE
8E3      STW,LX   TEMP4             SAVE LINK
8E4      BAL,LX   FEXP1             OBTAIN 2**X
         LCD,BF   ONE               -1.0
9E7      FDL,BF   AF                -1.0/2**X
         FAL,AF   BF                2**X-1.0/2**X
         FML,AF   HALF              RESULT
8E6      B       *TEMP4             RETURN
         SPACE    3
FCOSH    RES      0                 HYPERBOLIC COSINE ENTRY
         LAD,AF   AF                ABS(X)
         CW,AF    C1MC1             X : 175.36628-
         BG       ERDOMAIN          BRANCH IF RESULT OVERFLOWS
         FML,AF   LN2INV            X=X/LN(2)
9E2      CW,AF    TWENTY8           X : 28.0
         BGE      7E3               BRANCH IF X >= 28.0
9E5      STW,LX   TEMP4             SAVE LINK
9E6      BAL,LX   FEXP1             OBTAIN 2**X
         LD,BF    ONE               1.0
         B        9E7               PROCEED
         PAGE
*
*  DOUBLE PRECISION HYPERBOLIC TANGENT                          FTANH
*
*  CONSTANTS
*
         OPEN     AA,BB,CC,DD,EE
         BOUND    8
KMK      DATA     X'4213687B',-X'4213687B' +-28LN(2)=19.408121
CMC      DATA     X'4058B90C',-X'4058B90C' +-LN(2)/2=0.34657359
2OLN2    DATA     X'412E2A8E',X'CA5705FC' 2/LN(2)=2.88539008177792682
M2OLN2   DATA     X'BED1D571',X'35A8FA04'  -2/LN(2)
AA       DATA,8   FL'3465.0'        3465.0D0
BB       DATA,8   FL'189.0'         189.0D0
CC       DATA,8   FL'10395.0'       10395.0D0
DD       DATA,8   FL'1260.0'        1260.0D0
EE       DATA,8   FL'21.0'          21.0D0
         SPACE    3
FTANH    RES      0                 ENTRY
         CLM,AF   KMK               ABS(X) : 28LN(2)
         BCR,6    2F1               BRANCH IF LESS
         BCS,2    1F1               BRANCH IF X IS POSITIVE
         LCD,AF   ONE               X<-28LN(2), RESULT=-1.0D0
         B        0,LX              RETURN
1F1      LD,AF    ONE               X>28LN(2), RESULT=1.0D0
         B        0,LX              RETURN
2F1      CLM,AF   CMC               ABS(X) : LN(2)/2
         BCS,2    4F1               BRANCH IF X>LN(2)/2
         BCS,4    5F1               BRANCH IF X<-LN(2)/2
3F2      STD,AF   TEMP4             COPY X
         FML,AF   TEMP4             Y=X*X
         STD,AF   TEMP6             COPY Y
         FML,AF   EE
         FAL,AF   DD
         FML,AF   TEMP6
         FAL,AF   CC                 Q = C+Y*(D+Y*E)
         LD,BF    TEMP6
         FAL,BF   BB
         FML,BF   TEMP6
         FAL,BF   AA
         FML,BF   TEMP6             P=Y*(A+Y*(B+Y))
         FAL,BF   AF                P+Q
         FML,AF   TEMP4             X*Q
         FDL,AF   BF                RESULT
3F4      B        0,LX              RETURN
4F1      FML,AF   2OLN2             Y=2*X/LN(2)
4F3      STW,LX   TEMP4             SAVE LINK
4F4      BAL,LX   FEXP1             OBTAIN 2**Y = EXP(2*X)
         FAL,AF   ONE               Y=EXP(2*X)+1.0D0
         LCD,BF   ONE
         FDL,BF   AF                -1.0D0/Y
         LD,AF    HALF
         FAL,AF   BF                0.5D0-1.0D0/Y
         FAL,AF   AF                RESULT
4F6      B       *TEMP4             RETURN
5F1      FML,AF   M2OLN2            Y=2*X/LN(2)
5F3      STW,LX   TEMP4             SAVE LINK
5F4      BAL,LX   FEXP1             OBRAIN 2**Y = EXP(-2*X)
         FAL,AF   ONE               Y=EXP(-2*X)+1.0D0
         LD,BF    ONE
         FDL,BF   AF                1.0D0/Y
         LCD,AF   HALF
         FAL,AF   BF                1.0D0/Y-0.5D0
         FAL,AF   AF                RESULT
5F6      B       *TEMP4             RETURN
         PAGE
*
*  DOUBLE PRECISION INVERSE HYPERBOLIC SIN                      FARCSINH
*  DOUBLE PRECISION INVERSE HYPERBOLIC COSINE                   FARCCOSH
*  DOUBLE PRECISION INVERSE HYPERBOLIC TANGENT                  FARCTANH
*
*
FARCSINH EQU      %                 INVERSE SINH ENTRY
         STW,LX   LINKTEMP          SAVE LINK
         STD,AF   TEMP6             SAVE X
         BAL,LX   FCIRC4            SQRT(X**2+1)
         FAL,AF   TEMP6             X+SQRT(X**2+1) >=0
         BGZ      1Z1               IF X+SQRT(X**2+1) IS NEAR 0,
         LCD,AF   TEMP6               (AS IT WOULD BE FOR X<<0),
         FSL,AF   TEMP6               THEN ARCSINH(X)=-LOG(-2*X).
         BAL,LX   FLOG
         LCD,AF   AF
         B       *LINKTEMP
1Z1      BAL,LX   FLOG              ARCSINH(X)
         B       *LINKTEMP          RETURN
*
FARCCOSH EQU      %                 INVERSE COSH ENTRY
         STW,LX   LINKTEMP          SAVE LINK
         STD,AF   TEMP6             SAVE X
         BAL,LX   FCIRCM4           SQRT(X**2-1), ABS(X)>=1
         FAL,AF   TEMP6             X+SQRT(X**2-1)  >=1 OR <=-1
         BAL,LX   FLOG              ARCCOSH(X) >=0 (OR DOMAIN ERR)
         B       *LINKTEMP
*
FARCTANH EQU      %                 INVERSE TANH ENTRY
         STW,LX   LINKTEMP          SAVE LINK
         FSL,AF   ONE               X-1
         STD,AF   TEMP6
         FAL,AF   TWO               X+1
         FDL,AF   TEMP6             (X+1)/(X-1)   (NEGATIVE)
         LCD,AF   AF                (1+X)/(1-X)
         BAL,LX   FLOG              2*ARCTANH(X)
         FML,AF   HALF              ARCTANH(X)
         B       *LINKTEMP          RETURN
         PAGE
*
*  SPECIAL CIRCULAR FUNCTIONS:
*
*  SQRT(X**2 -1)                                                FCIRCM4
*  SQRT(X**2 +1)                                                FCIRC4
*  SQRT(1- X**2)                                                FCIRC0
*
FCIRCM4  EQU      %                 SQRT(X**2-1) ENTRY
         CLM,AF   HIGHSQ
         BCR,9    2Z1               IF ABS(X) LARGE ENOUGH,
         LAD,AF   AF                  USE F(X)=ABS(X).
         B        0,LX
2Z1      FML,AF   AF                X**2
         FSL,AF   ONE               X**2-1
         B        FSQRT             COMPUTE SQRT AND RETURN
*
FCIRC4   EQU      %                 SQRT(X**2+1) ENTRY
         CLM,AF   HIGHSQ
         BCR,9    2Z2               IF ABS(X) LARGE ENOUGH,
         LAD,AF   AF                  USE F(X)=ABS(X).
         B        0,LX
2Z2      FML,AF   AF                X**2
         FAL,AF   ONE               X**2+1
         B        FSQRT             COMPUTE SQRT AND RETURN
*
FCIRC0   EQU      %                 SQRT(1-X**2) ENTRY
         FML,AF   AF                X**2
         LCD,AF   AF                -X**2
         FAL,AF   ONE               1-X**2
         B        FSQRT             COMPUTE SQRT AND RETURN
*
         BOUND    8
HIGHSQ   DATA     -X'47100000',+X'47100000'
         PAGE
*
*  DOUBLE PRECISION EXPONENTIAL                                 FEXP
*  DOUBLE PRECISION NEGATIVE POWER OF TWO                       FEXP2
*  DOUBLE PRECISION POSITIVE POWER OF TWO                       FEXP1
*
*  CONSTANTS
*
         OPEN     TABLE
         BOUND    8
TABLE    DATA,8   FL'2',FL'4',FL'8',FL'16'
         DATA,8   FL'-2',FL'-1',FL'-.5',FL'-.25'
BIG      DATA     X'46100000',X'80000000'  TO SCALE INTEGER & ROUND
C1MC2    DATA     X'42AEAC4F',X'BD4C20D9' 174.67308,-179.87169
LN2INV   DATA     X'41171547',X'652B82FE' 1.44269504088896341=1/LN(2)
MLN2INV  DATA     X'BEE8EAB8',X'9AD47D02' -1/LN(2)
P00      DATA,8   FL'1513.9067990543389159'
P01      DATA,8   FL'20.202065651286927228'
P02      DATA,8   FL'-0.023093347753750233624'
Q00      DATA,8   FL'4368.2116627275584985'
Q01      DATA,8   FL'233.18421142748162379'
MHALF    DATA,8   FL'-.5'
HALF     DATA,8   FL'0.5'
         SPACE    3
FEXP     RES      0                 MAIN ENTRY
         CLM,AF   C1MC2             CHECK RANGE
         BCR,6    2G1               BRANCH IF OK
         BCS,4    1G1               UNDERFLOW
         B        ERDOMAIN          ERROR
1G1      SD,AF    AF                SET UNDERFLOW RESULT TO 0.0D0
         B        0,LX              RETURN
2G1      RES      0                 PLACE
2G3      AI,AF    0                 X : 0.0
         BGEZ     4G1               BRANCH IF X NON-NEGATIVE
         FML,AF   MLN2INV           X=-X/LN(2)
         SPACE    3
FEXP2    RES      0                 NEGATIVE POWER OF 2.0 ENTRY
*                                   USED BY FFPOWER
3G1      LI,N     1                 INDICATE NEGATIVE X
         B        6G1               PROCEED
4G1      FML,AF   LN2INV            X=X/LN(2.)
         SPACE    3
FEXP1    RES      0                 POSITIVE POWER OF 2.0 ENTRY
*                                   USED BY FSINH,  FFPOWER
5G1      LI,N     0                 INDICATE POSITIVE X
6G1      STD,AF   TEMP0             COPY X
         FAL,AF   BIG               SCALE INTEGER
         LI,AF1   0                 CLEAR FRACTION
         LD,CF    AF                COPY J
         FSS,AF   BIG               NORMALIZE J
         FSL,AF   TEMP0             -U, POST SHIFTS
         STD,AF   TEMP0             COPY -U
7G1      FML,AF   TEMP0             V=U*U
         STD,AF   TEMP2             COPY V
         LD,BF    TEMP2             COPY V
         FAL,BF   Q01               RATIONAL
         FML,BF   TEMP2
         FAL,BF   Q00
         FML,AF   P02
         FSL,AF   P01               APPROXIMATION
         FML,AF   TEMP2
         FSL,AF   P00
         FML,AF   TEMP0
8G1      EXU      OPN,N             -+ U
         FDL,AF   BF                +- (2.0 ** (+-U) )/2.0 -+ 0.5
         FSL,AF   HALF-2,N          +- (2.0 ** (+-U) )/2.0
         SLD,CF   -2                J/4
         SLS,CF   24                POSITION J/4 TO EXPONENT
         AW,AF    CF                16**( +- J/4)
         OR,N     CF1
         SCS,N    2                 MOD(J/4)
9G1      FML,AF   TABLE,N           FINAL FACTOR
9G3      B        0,LX              RETURN
OPN      FSL,BF   AF
         FAL,BF   AF
         PAGE
*
*  DOUBLE PRECISION NATURAL LOGARITHM                           FLOG
*  DOUBLE PRECISION BASE 2 LOGARITHM                            FLOG2
*
*  CONSTANTS
*
         OPEN     C6,C5,C4,C3,C2,C1,C0,D4,D3,D2,D1,MASK
         BOUND    8
FOURRT2  DATA     X'415A8279',X'99FCEF32' 5.65685424949238019=4RT(2)
C6       DATA     X'437C60DA',X'FF254B2A' 1990.05346598213023
C5       DATA     X'432176F9',X'A61B2FED' 535.435949426841753
C4       DATA     X'42A427D5',X'CF33479E' 164.155606222171279
C3       DATA     X'4234C2EA',X'CF2396D6' 52.7613954030883501
C2       DATA     X'4212776C',X'516A782D' 18.4664965519843255
C1       DATA     X'417B1C27',X'70E727E0' 7.69437355139461230
C0       DATA     X'415C551D',X'94AE0BFD' 5.77078016355585460
D4       DATA     X'403920FC',X'72219AEB' .223159578193740481
D3       DATA     X'40492475',X'F6A71ECB' .285712597578022078
D2       DATA     X'40666666',X'6BBA27A8' .400000001240327858
D1       DATA     X'40AAAAAA',X'AAAA50E8' .666666666666347771
TWO      DATA,8   FL'2.0'
LN2      DATA     X'40B17217',X'F7D1CF7A' .693147180559945309=LN(2)
C0C1     DATA     X'411185F1',X'40E9CA3B' 1.095,1/1.095=0.913242
MASK     DATA     X'80FFFFFF'       MANTISSA
X44      DATA     X'44000000'       EXPONENT
QTR      DATA     X'400000'         0.25B7
         SPACE    3
FLOG2    RES      0                 LOG BASE 2.0 ENTRY
*                                   USED BY FFPOWER
         AI,LX    X'80000'          INDICATE LOG BASE 2
FLOG     RES      0
1H3      LFI      0                 SET FF=0, POST SHIFTS POSSIBLE
         CLM,AF   C0C1              X:1.095,1/1.095
         BCS,6    3H1               BRANCH IF OUTSIDE INTERVAL
         FSL,AF   HALF              X-1.0D0
         FSL,AF   HALF                RETAINING SIGNIFICANCE
         LD,BF    AF                COPY X-1
         FAL,BF   TWO               X+1
         FDL,AF   BF                Z=(X-1)/(X+1)
         STD,AF   TEMP0             COPY Z
2H1      FML,AF   TEMP0             Y=Z*Z
         STD,AF   TEMP2             COPY Y
         FML,AF   D4                P
         FAL,AF   D3                 O
         FML,AF   TEMP2               LY-
         FAL,AF   D2                  NOMIAL
         FML,AF   TEMP2                 OF
         FAL,AF   D1                      ODD
         FML,AF   TEMP2                     POWERS
         FAL,AF   TWO                         OF
         FML,AF   TEMP0                         Z
2H3      BDR,LX   0,LX              RETURN IF NATURAL LOGARITHM
         FML,AF   LN2INV            CONVERT TO BASE 2.0
         B        1,LX              RETURN, BDR HAS REDUCED LX BY 1
3H1      LB,CF    AF                EN=EXPONENT
         SLS,CF   10                SCALE B21
         AND,AF   MASK              EM=MANTISSA
3H2      BGZ      3H3
         B        ERDOMAIN          ERROR
3H3      RES      0                 PLACE
         CW,AF    HALF              EM:0.5
         BANZ     6H1               BRANCH IF 0.5<=EM<1
         AI,CF    -X'10180'         REMOVE BIAS, SUBTRACT 1.5
         CW,AF    QTR               EM:0.25
         BANZ     7H1               BRANCH IF 0.25<=EM<0.5
         CW,AF    TWO               EM:0.125
         BANZ     4H1               BRANCH IF 0.125<=EM<0.25
         SLD,AF   2                 EM=EM*4.0D0
         AI,CF    X'10180'-X'10380' SUBTRACT 3.5
         B        7H1               PROCEED
4H1      SLD,AF   1                 EM=EM*2.0D0
         AI,CF    X'10180'-X'10280' SUBTRACT 2.5
         B        7H1               PROCEED
6H1      SLD,AF   -1                EM=EM*0.5D0
         AI,CF    -X'10080'         REMOVE BIAS, SUBTRACT 0.5
7H1      EOR,CF   X44               INSERT EXPONENT
         SFS,CF   5                 NORMALIZE
         LI,CF1   0                 CLEAR LSH OF EN
         AD,AF    FOURRT2           EM+4*SQRT(2.)
         LCD,BF   FOURRT2           -4*SQRT(2.)
         FDL,BF   AF                Y-0.5D0
         FAL,BF   HALF              Y
         STD,BF   TEMP0             COPY Y
         FML,BF   TEMP0             Z=Y*Y
         STD,BF   TEMP2             COPY Z
         LD,AF    C6                POLYNOMIAL
         FML,AF   TEMP2
         FAL,AF   C5
         FML,AF   TEMP2
         FAL,AF   C4
         FML,AF   TEMP2
         FAL,AF   C3
         FML,AF   TEMP2
         FAL,AF   C2
         FML,AF   TEMP2
         FAL,AF   C1
         FML,AF   TEMP2
         FAL,AF   C0
         FML,AF   TEMP0
         FAL,AF   CF                DLOG2(X)
7H3      BIR,LX   0,LX              RETURN IF LOG BASE 2
         FML,AF   LN2               CONVERT TO NATURAL LOGARITHM
         B        -1,LX             RETURN, BIR HAS INCREASED R6 BY 1
         PAGE
*
*
*  DYADIC LOGARITHM                                             FFLOG
*
*              CALLED WITH LEFT ARG IN AF/AF1 AND RIGHT ARG IN BF/BF1.
*              RESULT IS RETURNED IN AF/AF1.  LINK IS LX.
*
FFLOG    EQU      %                 DYADIC LOG ENTRY
         STD,BF   TEMP6             SAVE B
         STW,LX   LINKTEMP
         BAL,LX   FLOG              LOG(A)
         XW,AF    TEMP6             SAVE IT, RESTORE B
         XW,AF1   TEMP7
         BAL,LX   FLOG              LOG(B)
         FDL,AF   TEMP6             LOG(B)/LOG(A) = LOG BASE A OF B
         B       *LINKTEMP          RETURN
         PAGE
*
*  DOUBLE PRECISION SQUARE ROOT                                 FSQRT
*
*  CONSTANTS
*
         OPEN     AA,BB,CC,DD
X80F     DATA     X'80FFFFFF'
AA       DATA     X'1BE10000'       .108902
BB       DATA     X'907C0'          .03527451
CC       DATA     X'12E20000'       .07376
DD       DATA     X'D5A80'          .05216
         SPACE    3
FSQRT    RES      0                 ENTRY, USED BY FARCSIN, FARCCOS
         LI,N     2                 RESET FLAG
         LB,BF    AF                COPY EXPONENT
         AND,AF   X80F              EXTRACT MANTISSA
         BGZ      2K7               BRANCH IF OK
         BEZ      0,LX              RETURN 0 FOR DSQRT(0)
         B        ERDOMAIN          ERROR
2K7      CW,AF    =X'00C00000'      BRANCH IF
         BANZ     2K5                HI SCALE
         STD,AF   TEMP2             LO SCALE
         SLD,AF   2                 *4
         STD,AF   TEMP0             HI SCALE
         LW,AF    TEMP2             RESTORE LO
         BDR,N    2K6               SET FLAG AND JOIN
2K5      STD,AF   TEMP0             HI SCALE
         SLD,AF   -2                /4
         STD,AF   TEMP2             LO SCALE
2K6      LH,AF1   TEMP0             HI SCALE MSQTR
         CI,AF1   X'80'             BRANCH IF
         BANZ     2K3                HIEST SCALE
         MH,AF1   AA                LINEAR
         AW,AF1   BB                 APPROXIMATION
         B        2K4               JOIN
2K3      MH,AF1   CC                LINEAR
         AW,AF1   DD                 APPROXIMATION
2K4      STW,AF1  TEMP4             SQRT/8
         FDS,AF   TEMP4             FIRST
         AW,AF    TEMP4              NEWTON
         XW,AF    TEMP0             SQRT
         LW,AF1   TEMP1              /4
         FDL,AF   TEMP0             SECOND
         AD,AF    TEMP0              NEWTON
         XW,AF    TEMP2             SQRT
         XW,AF1   TEMP3             /2
         OR,AF    =X'10000000'      FOR EXPONENT GARBAGE
         FDL,AF   TEMP2             THIRD
         AD,AF    TEMP2              NEWTON
         SCS,BF   -1                HALVE EXPONENT,REMAINDER TO BIT 0
         AI,BF    X'20'             FIX BIAS, CHECK REMAINDER
         BGEZ     2K1               BRANCH IF NO REMAINDER
         SLD,AF   -4,N              MULTIPLY BY
         BIR,BF   2K2               2 OR 4 AND JOIN
2K1      SLD,AF   -2,N              NOP OR DIVIDE BY 2
2K2      STB,BF   AF                INSERT EXPONENT
         B        0,LX              RETURN
         PAGE
*
*  DOUBLE PRECISION RAISED TO A DOUBLE PRECISION POWER          FFPOWER
*
*  CONSTANTS
*
MEXPOV   DATA     X'43103800'       259.5
EXPOV    DATA     X'42FC0000'       252.0
         SPACE    3
FFPOWER  RES      0                 ENTRY
         STW,LX   LINKTEMP          SAVE LINK
         STD,BF   TEMP6             COPY Y
         AI,AF    0                 X : 0.0
         BGZ      4L1               BRANCH IF X > 0.0
         BLZ      2L1               BRANCH IF X < 0.0
1L1      AI,BF    0                 Y : 0.0
         BGZ      0,LX              RETURN 0.0D0 FOR 0**POSITIVE
         BEZ      2M1               X=Y=0, X**Y=1
         B        ERDOMAIN          ERROR
2L1      STD,AF   TEMP4             SAVE X
         LD,AF    BF                Y HAD BETTER BE AN INTEGER
         BAL,LX   F2I
         B        ERDOMAIN            (ERROR IF NOT)
         CI,AI    1                 CHECK Y FOR ODD/EVEN = FNEG
         STCF     LINKTEMP          SAVE FNEG
         LCD,AF   TEMP4             ABS(X)
4L1      RES      0                 PLACE
4L5      BAL,LX   FLOG2             OBTAIN LOG BASE 2 OF X
         LI,LX    WA(7L2)           FORCE RETURNS BELOW
4L6      FML,AF   TEMP6             Y*LOG2(X)
         BGEZ     6L1               BRANCH IF RESULT >= 1.0D0
         LCD,AF   AF                ABS(Y*LOG2(X))
         CW,AF    MEXPOV            CHECK FOR UNDER FLOW
5L1      BL       FEXP2             BRANCH IF OK
         SD,AF    AF                UNDERFLOW RESULT = 0.0D0
5L2      B       *LINKTEMP          RETURN
6L1      CW,AF    EXPOV             CHECK FOR OVERFLOW
7L1      BL       FEXP1             BRANCH IF OK
         B        ERDOMAIN          ERROR
7L2      RES      0                 PLACE
7L4      LC       LINKTEMP          FNEG
         BAZ     *LINKTEMP          RETURN IF RESULT IS POSITIVE
         LCD,AF   AF                SET RESULT NEGATIVE
         B       *LINKTEMP          RETURN
         PAGE
*
*  DOUBLE PRECISION RAISED TO AN INTEGER POWER                  FIPOWER
*
FIPOWER  RES      0                 ENTRY
         AI,AF    0                 X : 0
         BNEZ     1M1               BRANCH IF X NE 0
         AI,BI    0                 J : 0
         BGZ      0,LX              RETURN 0 IF J<0
         BEZ      2M1               X=J=0, X**J=1
         B        ERDOMAIN          ERROR
1M1      AI,BI    0                 J : 0
         BGZ      5M1               BRANCH IF J>0
         BLZ      3M1               BRANCH IF J<0
2M1      LD,AF    ONE               RESULT = 1.0D0
         B        0,LX              RETURN
3M1      STD,AF   TEMP0
         LD,AF    ONE               X=
         FDL,AF   TEMP0               1.0
         LCW,BI   BI                J=-J
         B        5M1               ENTER LOOP
4M1      SLS,BI   -1                J=J/2
         FML,AF   AF                X=X*X
5M1      CI,BI    1                 CHECK J FOR ODD/EVEN
         BAZ      4M1               LOOP IF EVEN
         BE       0,LX              RETURN IF J=1
         LD,CF    AF                COPY X
         B        7M1               ENTER LOOP
6M1      FML,AF   CF                CURRENT POWER IS A FACTOR
7M1      SLS,BI   -1                J=J/2
         FML,CF   CF                X=X*X
         CI,BI    1                 CHECK J FOR ODD/EVEN
         BAZ      7M1               LOOP IF EVEN - NO FACTOR THIS TIME
         BNE      6M1               LOOP IF J>1
         FML,AF   CF                FINAL FACTOR
         B        0,LX              RETURN
         PAGE
*
*  INTEGER RAISED TO AN INTEGER POWER                           IIPOWER
*
*  CONSTANTS
*
         BOUND    8
ONEM1    DATA     1,-1              +- 1
         SPACE    3
IIPOWER  RES      0                 ENTRY
         CLM,AI   ONEM1             ABS(I) : 1
         BCS,6    3N1               BRANCH IF GREATER
         BCR,3    0,LX              RETURN 1 IF I=1
         BCS,8    2N1               BRANCH IF I=0
         CI,BI    1                 CHECK POWER FOR ODD/EVEN
         BANZ     0,LX              RETURN -1 IF ODD
1N1      LI,AI    1                 RESULT = 1
         B        0,LX              RETURN
2N1      AI,BI    0                 J : 0
         BGZ      0,LX              RETURN 0 FOR 0**POSITIVE
         BEZ      1N1               I=J=0, I**J=1
         B        ERDOMAIN          ERROR
3N1      AI,BI    0                 J : 0
         BGZ      6N1               BRANCH IF J>0
         BEZ      1N1               BRANCH IF J=0
         B        INTGOVFL          WONT FIT AS INTEGER
5N1      SLS,BI   -1                J=J/2
         MW,AI    AI                I=I*I
         BOV      INTGOVFL          CHECK FOR OVERFLOW
6N1      CI,BI    1                 CHECK J FOR ODD/EVEN
         BAZ      5N1               LOOP IF EVEN
         BE       0,LX              RETURN IF J=1
         LW,N     BI                MOVE J
         LW,BI    AI                COPY I
         B        8N1               ENTER LOOP
7N1      MW,AI    BI                CURRENT POWER IS A FACTOR
         BOV      INTGOVFL          CHECK FOR OVERFLOW
8N1      SLS,N    -1                J=J/2
         MW,BI    BI                I=I*I
         BOV      INTGOVFL          CHECK FOR OVERFLOW
         CI,N     1                 CHECK J FOR ODD/EVEN
         BAZ      8N1               LOOP IF EVEN - NO FACTOR THIS TIME
         BNE      7N1               LOOP IF J>1
         MW,AI    BI                FINAL FACTOR
         BOV      INTGOVFL          CHECK FOR OVERFLOW
         B        0,LX              RETURN
         PAGE
*
*
*  TEMPS
*
TEMP0    TEMP
TEMP1    TEMP
TEMP2    TEMP
TEMP3    TEMP
TEMP4    TEMP
TEMP5    TEMP
TEMP6    TEMP
TEMP7    TEMP
LINKTEMP TEMP                       LINK TEMP
*
*
                  ERROR,X'F',TLOC>9  'TOO MANY TEMPS'                   U07-0014
NTEMPS   SET      TLOC                                                  U07-0015
2Z       END

