Mercurial > octave-nkf
annotate liboctave/cruft/slatec-fn/datanh.f @ 20654:b65888ec820e draft default tip gccjit
dmalcom gcc jit import
author | Stefan Mahr <dac922@gmx.de> |
---|---|
date | Fri, 27 Feb 2015 16:59:36 +0100 |
parents | 446c46af4b42 |
children |
rev | line source |
---|---|
2329 | 1 *DECK DATANH |
2 DOUBLE PRECISION FUNCTION DATANH (X) | |
3 C***BEGIN PROLOGUE DATANH | |
4 C***PURPOSE Compute the arc hyperbolic tangent. | |
5 C***LIBRARY SLATEC (FNLIB) | |
6 C***CATEGORY C4C | |
7 C***TYPE DOUBLE PRECISION (ATANH-S, DATANH-D, CATANH-C) | |
8 C***KEYWORDS ARC HYPERBOLIC TANGENT, ATANH, ELEMENTARY FUNCTIONS, | |
9 C FNLIB, INVERSE HYPERBOLIC TANGENT | |
10 C***AUTHOR Fullerton, W., (LANL) | |
11 C***DESCRIPTION | |
12 C | |
13 C DATANH(X) calculates the double precision arc hyperbolic | |
14 C tangent for double precision argument X. | |
15 C | |
16 C Series for ATNH on the interval 0. to 2.50000E-01 | |
17 C with weighted error 6.86E-32 | |
18 C log weighted error 31.16 | |
19 C significant figures required 30.00 | |
20 C decimal places required 31.88 | |
21 C | |
22 C***REFERENCES (NONE) | |
23 C***ROUTINES CALLED D1MACH, DCSEVL, INITDS, XERMSG | |
24 C***REVISION HISTORY (YYMMDD) | |
25 C 770601 DATE WRITTEN | |
26 C 890531 Changed all specific intrinsics to generic. (WRB) | |
27 C 890531 REVISION DATE from Version 3.2 | |
28 C 891214 Prologue converted to Version 4.0 format. (BAB) | |
29 C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) | |
30 C***END PROLOGUE DATANH | |
31 DOUBLE PRECISION X, ATNHCS(27), DXREL, SQEPS, Y, DCSEVL, D1MACH | |
32 LOGICAL FIRST | |
33 SAVE ATNHCS, NTERMS, DXREL, SQEPS, FIRST | |
34 DATA ATNHCS( 1) / +.9439510239 3195492308 4289221863 3 D-1 / | |
35 DATA ATNHCS( 2) / +.4919843705 5786159472 0003457666 8 D-1 / | |
36 DATA ATNHCS( 3) / +.2102593522 4554327634 7932733175 2 D-2 / | |
37 DATA ATNHCS( 4) / +.1073554449 7761165846 4073104527 6 D-3 / | |
38 DATA ATNHCS( 5) / +.5978267249 2930314786 4278751787 2 D-5 / | |
39 DATA ATNHCS( 6) / +.3505062030 8891348459 6683488620 0 D-6 / | |
40 DATA ATNHCS( 7) / +.2126374343 7653403508 9621931443 1 D-7 / | |
41 DATA ATNHCS( 8) / +.1321694535 7155271921 2980172305 5 D-8 / | |
42 DATA ATNHCS( 9) / +.8365875501 1780703646 2360405295 9 D-10 / | |
43 DATA ATNHCS( 10) / +.5370503749 3110021638 8143458777 2 D-11 / | |
44 DATA ATNHCS( 11) / +.3486659470 1571079229 7124578429 0 D-12 / | |
45 DATA ATNHCS( 12) / +.2284549509 6034330155 2402411972 2 D-13 / | |
46 DATA ATNHCS( 13) / +.1508407105 9447930448 7422906755 8 D-14 / | |
47 DATA ATNHCS( 14) / +.1002418816 8041091261 3699572283 7 D-15 / | |
48 DATA ATNHCS( 15) / +.6698674738 1650695397 1552688298 6 D-17 / | |
49 DATA ATNHCS( 16) / +.4497954546 4949310830 8332762453 3 D-18 / | |
50 DATA ATNHCS( 17) / +.3032954474 2794535416 8236714666 6 D-19 / | |
51 DATA ATNHCS( 18) / +.2052702064 1909368264 6386141866 6 D-20 / | |
52 DATA ATNHCS( 19) / +.1393848977 0538377131 9301461333 3 D-21 / | |
53 DATA ATNHCS( 20) / +.9492580637 2245769719 5895466666 6 D-23 / | |
54 DATA ATNHCS( 21) / +.6481915448 2423076049 8244266666 6 D-24 / | |
55 DATA ATNHCS( 22) / +.4436730205 7236152726 3232000000 0 D-25 / | |
56 DATA ATNHCS( 23) / +.3043465618 5431616389 1200000000 0 D-26 / | |
57 DATA ATNHCS( 24) / +.2091881298 7923934740 4799999999 9 D-27 / | |
58 DATA ATNHCS( 25) / +.1440445411 2340505613 6533333333 3 D-28 / | |
59 DATA ATNHCS( 26) / +.9935374683 1416404650 6666666666 6 D-30 / | |
60 DATA ATNHCS( 27) / +.6863462444 3582600533 3333333333 3 D-31 / | |
61 DATA FIRST /.TRUE./ | |
62 C***FIRST EXECUTABLE STATEMENT DATANH | |
63 IF (FIRST) THEN | |
64 NTERMS = INITDS (ATNHCS, 27, 0.1*REAL(D1MACH(3)) ) | |
65 DXREL = SQRT(D1MACH(4)) | |
66 SQEPS = SQRT(3.0D0*D1MACH(3)) | |
67 ENDIF | |
68 FIRST = .FALSE. | |
69 C | |
70 Y = ABS(X) | |
14392
d17237256856
Make SLATEC-FN atanh/erfc functions more tolerant about edge cases like
Michael Goffioul <michael.goffioul@gmail.com>
parents:
2329
diff
changeset
|
71 IF (Y .GE. 1.D0) THEN |
19627
446c46af4b42
strip trailing whitespace from most source files
John W. Eaton <jwe@octave.org>
parents:
15271
diff
changeset
|
72 IF (Y .GT. 1.D0) THEN |
14392
d17237256856
Make SLATEC-FN atanh/erfc functions more tolerant about edge cases like
Michael Goffioul <michael.goffioul@gmail.com>
parents:
2329
diff
changeset
|
73 DATANH = (X - X) / (X - X) |
d17237256856
Make SLATEC-FN atanh/erfc functions more tolerant about edge cases like
Michael Goffioul <michael.goffioul@gmail.com>
parents:
2329
diff
changeset
|
74 ELSE |
d17237256856
Make SLATEC-FN atanh/erfc functions more tolerant about edge cases like
Michael Goffioul <michael.goffioul@gmail.com>
parents:
2329
diff
changeset
|
75 DATANH = X / 0.D0 |
d17237256856
Make SLATEC-FN atanh/erfc functions more tolerant about edge cases like
Michael Goffioul <michael.goffioul@gmail.com>
parents:
2329
diff
changeset
|
76 ENDIF |
d17237256856
Make SLATEC-FN atanh/erfc functions more tolerant about edge cases like
Michael Goffioul <michael.goffioul@gmail.com>
parents:
2329
diff
changeset
|
77 RETURN |
d17237256856
Make SLATEC-FN atanh/erfc functions more tolerant about edge cases like
Michael Goffioul <michael.goffioul@gmail.com>
parents:
2329
diff
changeset
|
78 ENDIF |
2329 | 79 C |
80 IF (1.D0-Y .LT. DXREL) CALL XERMSG ('SLATEC', 'DATANH', | |
81 + 'ANSWER LT HALF PRECISION BECAUSE ABS(X) TOO NEAR 1', 1, 1) | |
82 C | |
83 DATANH = X | |
84 IF (Y.GT.SQEPS .AND. Y.LE.0.5D0) DATANH = X*(1.0D0 + | |
85 1 DCSEVL (8.D0*X*X-1.D0, ATNHCS, NTERMS) ) | |
86 IF (Y.GT.0.5D0) DATANH = 0.5D0*LOG ((1.0D0+X)/(1.0D0-X)) | |
87 C | |
88 RETURN | |
89 END |