Mercurial > octave-nkf
diff libcruft/slatec-fn/atanh.f @ 7789:82be108cc558
First attempt at single precision tyeps
* * *
corrections to qrupdate single precision routines
* * *
prefer demotion to single over promotion to double
* * *
Add single precision support to log2 function
* * *
Trivial PROJECT file update
* * *
Cache optimized hermitian/transpose methods
* * *
Add tests for tranpose/hermitian and ChangeLog entry for new transpose code
author | David Bateman <dbateman@free.fr> |
---|---|
date | Sun, 27 Apr 2008 22:34:17 +0200 |
parents | |
children | d17237256856 |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/libcruft/slatec-fn/atanh.f Sun Apr 27 22:34:17 2008 +0200 @@ -0,0 +1,72 @@ +*DECK ATANH + FUNCTION ATANH (X) +C***BEGIN PROLOGUE ATANH +C***PURPOSE Compute the arc hyperbolic tangent. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C4C +C***TYPE SINGLE PRECISION (ATANH-S, DATANH-D, CATANH-C) +C***KEYWORDS ARC HYPERBOLIC TANGENT, ATANH, ELEMENTARY FUNCTIONS, +C FNLIB, INVERSE HYPERBOLIC TANGENT +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C ATANH(X) computes the arc hyperbolic tangent of X. +C +C Series for ATNH on the interval 0. to 2.50000D-01 +C with weighted error 6.70E-18 +C log weighted error 17.17 +C significant figures required 16.01 +C decimal places required 17.76 +C +C***REFERENCES (NONE) +C***ROUTINES CALLED CSEVL, INITS, R1MACH, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770401 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 900326 Removed duplicate information from DESCRIPTION section. +C (WRB) +C***END PROLOGUE ATANH + DIMENSION ATNHCS(15) + LOGICAL FIRST + SAVE ATNHCS, NTERMS, DXREL, SQEPS, FIRST + DATA ATNHCS( 1) / .0943951023 93195492E0 / + DATA ATNHCS( 2) / .0491984370 55786159E0 / + DATA ATNHCS( 3) / .0021025935 22455432E0 / + DATA ATNHCS( 4) / .0001073554 44977611E0 / + DATA ATNHCS( 5) / .0000059782 67249293E0 / + DATA ATNHCS( 6) / .0000003505 06203088E0 / + DATA ATNHCS( 7) / .0000000212 63743437E0 / + DATA ATNHCS( 8) / .0000000013 21694535E0 / + DATA ATNHCS( 9) / .0000000000 83658755E0 / + DATA ATNHCS(10) / .0000000000 05370503E0 / + DATA ATNHCS(11) / .0000000000 00348665E0 / + DATA ATNHCS(12) / .0000000000 00022845E0 / + DATA ATNHCS(13) / .0000000000 00001508E0 / + DATA ATNHCS(14) / .0000000000 00000100E0 / + DATA ATNHCS(15) / .0000000000 00000006E0 / + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT ATANH + IF (FIRST) THEN + NTERMS = INITS (ATNHCS, 15, 0.1*R1MACH(3)) + DXREL = SQRT (R1MACH(4)) + SQEPS = SQRT (3.0*R1MACH(3)) + ENDIF + FIRST = .FALSE. +C + Y = ABS(X) + IF (Y .GE. 1.0) CALL XERMSG ('SLATEC', 'ATANH', 'ABS(X) GE 1', 2, + + 2) +C + IF (1.0-Y .LT. DXREL) CALL XERMSG ('SLATEC', 'ATANH', + + 'ANSWER LT HALF PRECISION BECAUSE ABS(X) TOO NEAR 1', 1, 1) +C + ATANH = X + IF (Y.GT.SQEPS .AND. Y.LE.0.5) ATANH = X*(1.0 + CSEVL (8.*X*X-1., + 1 ATNHCS, NTERMS)) + IF (Y.GT.0.5) ATANH = 0.5*LOG((1.0+X)/(1.0-X)) +C + RETURN + END