ASMB,L,F,R,C
* 
*  **************************************************************** 
*  * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979.  ALL RIGHTS      * 
*  * RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED,       * 
*  * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT * 
*  * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.        * 
*  **************************************************************** 
* 
*   NAME: PART OF MATH LIBRARY
*   SOURCE:  24998-18XXX  SEE NAM FOR LAST THREE DIGITS 
*   RELOC: PART OF 24998-12001
*   PGMR: BG & JTS
* 
      HED "DTANH" - DOUBLE PRECISION HYPERBOLIC TANGENT.
      NAM DTANH,7 24998-1X097 REV.2001 780320 
* 
      ENT DTANH 
      EXT .ENTR,.DFER,.XFER,.FLUN,.PWR2 
      EXT DEXP,.XADD,.XMPY,.XDIV
* 
*     DTANH TAKES THE DOUBLE-PRECISION HYPERBOLIC TANGENT OF A
*     DOUBLE-PRECISION NUMBER.
* 
*     CALLING SEQUENCE: 
* 
*                   JSB DTANH 
*                   DEF *+3 
*                   DEF <RESULT>
*                   DEF <ARG> 
*                   <RETURN>
* 
*     METHOD:  OUTSIDE THE RANGE [-32,+32) THE RESULT IS 1.0 TIMES THE
*     SIGN OF THE ARGUMENT.  WITHIN THE ABOVE RANGE BUT OUTSIDE THE 
*     RANGE [-0.25,+0.25) THE DEFINITION IS USED: 
* 
*                              EXP(2*X) - 1 
*                   TANH(X) = --------------
*                              EXP(2*X) + 1 
* 
*     WITHIN [-0.25,+0.25) THE FOLLOWING APPROXIMATION IS USED: 
* 
*                                      C1 
*                   TANH(X) = X * ( -------- + C3 + C4*XSQ )
*                                    C2+XSQ 
*     WHERE:
*                   C1 = .201101929221D+01
*                   C2 = .247073386009D+01
*                   C3 = .186063976899D+00
*                   C4 = .390245451777D-02
      SPC 4 
*                   COPY ARG, GET ITS EXPONENT. 
* 
RESLT DEF *-* 
ARG   DEF *-* 
DTANH NOP 
      JSB .ENTR     COPY ADDRESSES
      DEF RESLT 
      JSB .DFER     COPY ARG
      DEF X 
      DEF ARG,I 
      LDB X+2       LAST WORD 
      JSB .FLUN     A = EXPONENT
      SKP 
*                   DETERMINE WHICH RANGE.
* 
      INA           EXPONENT+1
      SSA           EXPONENT < -1 ?  (IN [-.25,.25) ) 
      JMP DTNH1     YES, USE APPROXIMATION. 
      STA TEMP      SAVE EXPONENT+1 TO FORM 2*X 
      ADA =D-7      EXPONENT >= 6 ?  (OUTSIDE [-32,32) )
      SSA,RSS 
      JMP DTNH2     YES, JUST SIGN(1,X) 
      LDA X         X=0 ? 
      SZA 
      JMP DTNH3     NO, MIDDLE RANGE, USE DEFINITION.OX.
* 
*                   USE APPROXIMATION IN [-.25,+.25) .
* 
DTNH1 JSB .XMPY     X**2
      DEF XSQ 
      DEF X 
      DEF X 
      JSB .XADD     C2+XSQ
      DEF TEMP
      DEF C2
      DEF XSQ 
      JSB .XDIV     C1/(C2+XSQ) 
      DEF TEMP
      DEF C1
      DEF TEMP
      JSB .XADD     +C3 
      DEF TEMP
      DEF TEMP
      DEF C3
      JSB .XMPY     C4*XSQ
      DEF XSQ 
      DEF C4
      DEF XSQ 
      JSB .XADD     C1/(C2+XSQ) + C3 + C4*XSQ 
      DEF TEMP
      DEF TEMP
      DEF XSQ 
      JSB .XMPY     TANH
      DEF RESLT,I 
      DEF X 
      DEF TEMP
      JMP DTANH,I   EXIT
* 
*                   OUTSIDE [-32,+32), RESULT IS SIGN(1.0,X) .
* 
DTNH2 LDB X         PICK -1 OR +1 
      LDA ONEP
      SSB 
      LDA MONEP 
      LDB RESLT     COPY TO RESULT
      JSB .XFER 
      JMP DTANH,I   EXIT. 
* 
*                   IN [-32,-.25) OR [.25,32), USE DEFINITION.
* 
DTNH3 JSB .PWR2     FORM 2*X
      DEF TEMP
      STB X+2 
      JSB DEXP      EXP(2*X)
      DEF *+3 
      DEF X 
      DEF X 
      NOP 
      JSB .XADD     EXP(2*X)-1
      DEF XSQ 
      DEF X 
MONEP DEF MONE
      JSB .XADD     EXP(2*X)+1
      DEF X 
      DEF X 
ONEP  DEF ONE 
      JSB .XDIV     RESULT. 
      DEF RESLT,I 
      DEF XSQ 
      DEF X 
      JMP DTANH,I   EXIT. 
* 
*                   LOCALS & CONSTANTS. 
* 
X     BSS 3         ARG 
XSQ   BSS 3         X**2
TEMP  BSS 3         TEMP
ONE   DEX 1.0 
MONE  DEX -1.0
C1    OCT 040132,042441,073004
C2    OCT 047420,040164,143404
C3    OCT 057503,143417,077375
C4    OCT 100037,153274,065761
      END 
                                                                                                              