GNU Octave: libcruft/slatec-fn/atanh.f Source File

Go to the documentation of this file.
00001 *DECK ATANH
00002       FUNCTION ATANH (X)
00003 C***BEGIN PROLOGUE  ATANH
00004 C***PURPOSE  Compute the arc hyperbolic tangent.
00005 C***LIBRARY   SLATEC (FNLIB)
00006 C***CATEGORY  C4C
00007 C***TYPE      SINGLE PRECISION (ATANH-S, DATANH-D, CATANH-C)
00008 C***KEYWORDS  ARC HYPERBOLIC TANGENT, ATANH, ELEMENTARY FUNCTIONS,
00009 C             FNLIB, INVERSE HYPERBOLIC TANGENT
00010 C***AUTHOR  Fullerton, W., (LANL)
00011 C***DESCRIPTION
00012 C
00013 C ATANH(X) computes the arc hyperbolic tangent of X.
00014 C
00015 C Series for ATNH       on the interval  0.          to  2.50000D-01
00016 C                                        with weighted error   6.70E-18
00017 C                                         log weighted error  17.17
00018 C                               significant figures required  16.01
00019 C                                    decimal places required  17.76
00020 C
00021 C***REFERENCES  (NONE)
00022 C***ROUTINES CALLED  CSEVL, INITS, R1MACH, XERMSG
00023 C***REVISION HISTORY  (YYMMDD)
00024 C   770401  DATE WRITTEN
00025 C   890531  Changed all specific intrinsics to generic.  (WRB)
00026 C   890531  REVISION DATE from Version 3.2
00027 C   891214  Prologue converted to Version 4.0 format.  (BAB)
00028 C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
00029 C   900326  Removed duplicate information from DESCRIPTION section.
00030 C           (WRB)
00031 C***END PROLOGUE  ATANH
00032       DIMENSION ATNHCS(15)
00033       LOGICAL FIRST
00034       SAVE ATNHCS, NTERMS, DXREL, SQEPS, FIRST
00035       DATA ATNHCS( 1) /    .0943951023 93195492E0 /
00036       DATA ATNHCS( 2) /    .0491984370 55786159E0 /
00037       DATA ATNHCS( 3) /    .0021025935 22455432E0 /
00038       DATA ATNHCS( 4) /    .0001073554 44977611E0 /
00039       DATA ATNHCS( 5) /    .0000059782 67249293E0 /
00040       DATA ATNHCS( 6) /    .0000003505 06203088E0 /
00041       DATA ATNHCS( 7) /    .0000000212 63743437E0 /
00042       DATA ATNHCS( 8) /    .0000000013 21694535E0 /
00043       DATA ATNHCS( 9) /    .0000000000 83658755E0 /
00044       DATA ATNHCS(10) /    .0000000000 05370503E0 /
00045       DATA ATNHCS(11) /    .0000000000 00348665E0 /
00046       DATA ATNHCS(12) /    .0000000000 00022845E0 /
00047       DATA ATNHCS(13) /    .0000000000 00001508E0 /
00048       DATA ATNHCS(14) /    .0000000000 00000100E0 /
00049       DATA ATNHCS(15) /    .0000000000 00000006E0 /
00050       DATA FIRST /.TRUE./
00051 C***FIRST EXECUTABLE STATEMENT  ATANH
00052       IF (FIRST) THEN
00053          NTERMS = INITS (ATNHCS, 15, 0.1*R1MACH(3))
00054          DXREL = SQRT (R1MACH(4))
00055          SQEPS = SQRT (3.0*R1MACH(3))
00056       ENDIF
00057       FIRST = .FALSE.
00058 C
00059       Y = ABS(X)
00060       IF (Y .GE. 1.0) CALL XERMSG ('SLATEC', 'ATANH', 'ABS(X) GE 1', 2,
00061      +   2)
00062 C
00063       IF (1.0-Y .LT. DXREL) CALL XERMSG ('SLATEC', 'ATANH',
00064      +   'ANSWER LT HALF PRECISION BECAUSE ABS(X) TOO NEAR 1', 1, 1)
00065 C
00066       ATANH = X
00067       IF (Y.GT.SQEPS .AND. Y.LE.0.5) ATANH = X*(1.0 + CSEVL (8.*X*X-1.,
00068      1  ATNHCS, NTERMS))
00069       IF (Y.GT.0.5) ATANH = 0.5*LOG((1.0+X)/(1.0-X))
00070 C
00071       RETURN
00072       END