mirror of
https://git.planet-casio.com/Lephenixnoir/OpenLibm.git
synced 2025-01-01 06:23:39 +01:00
97 lines
3 KiB
Fortran
97 lines
3 KiB
Fortran
*DECK D9CHU
|
|
DOUBLE PRECISION FUNCTION D9CHU (A, B, Z)
|
|
C***BEGIN PROLOGUE D9CHU
|
|
C***SUBSIDIARY
|
|
C***PURPOSE Evaluate for large Z Z**A * U(A,B,Z) where U is the
|
|
C logarithmic confluent hypergeometric function.
|
|
C***LIBRARY SLATEC (FNLIB)
|
|
C***CATEGORY C11
|
|
C***TYPE DOUBLE PRECISION (R9CHU-S, D9CHU-D)
|
|
C***KEYWORDS FNLIB, LOGARITHMIC CONFLUENT HYPERGEOMETRIC FUNCTION,
|
|
C SPECIAL FUNCTIONS
|
|
C***AUTHOR Fullerton, W., (LANL)
|
|
C***DESCRIPTION
|
|
C
|
|
C Evaluate for large Z Z**A * U(A,B,Z) where U is the logarithmic
|
|
C confluent hypergeometric function. A rational approximation due to Y.
|
|
C L. Luke is used. When U is not in the asymptotic region, i.e., when A
|
|
C or B is large compared with Z, considerable significance loss occurs.
|
|
C A warning is provided when the computed result is less than half
|
|
C precision.
|
|
C
|
|
C***REFERENCES (NONE)
|
|
C***ROUTINES CALLED D1MACH, XERMSG
|
|
C***REVISION HISTORY (YYMMDD)
|
|
C 770801 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 900720 Routine changed from user-callable to subsidiary. (WRB)
|
|
C***END PROLOGUE D9CHU
|
|
DOUBLE PRECISION A, B, Z, AA(4), BB(4), AB, ANBN, BP, CT1, CT2,
|
|
1 CT3, C2, D1Z, EPS, G1, G2, G3, SAB, SQEPS, X2I1, D1MACH
|
|
LOGICAL FIRST
|
|
SAVE EPS, SQEPS, FIRST
|
|
DATA FIRST /.TRUE./
|
|
C***FIRST EXECUTABLE STATEMENT D9CHU
|
|
IF (FIRST) THEN
|
|
EPS = 4.0D0*D1MACH(4)
|
|
SQEPS = SQRT(D1MACH(4))
|
|
ENDIF
|
|
FIRST = .FALSE.
|
|
C
|
|
BP = 1.0D0 + A - B
|
|
AB = A*BP
|
|
CT2 = 2.0D0 * (Z - AB)
|
|
SAB = A + BP
|
|
C
|
|
BB(1) = 1.0D0
|
|
AA(1) = 1.0D0
|
|
C
|
|
CT3 = SAB + 1.0D0 + AB
|
|
BB(2) = 1.0D0 + 2.0D0*Z/CT3
|
|
AA(2) = 1.0D0 + CT2/CT3
|
|
C
|
|
ANBN = CT3 + SAB + 3.0D0
|
|
CT1 = 1.0D0 + 2.0D0*Z/ANBN
|
|
BB(3) = 1.0D0 + 6.0D0*CT1*Z/CT3
|
|
AA(3) = 1.0D0 + 6.0D0*AB/ANBN + 3.0D0*CT1*CT2/CT3
|
|
C
|
|
DO 30 I=4,300
|
|
X2I1 = 2*I - 3
|
|
CT1 = X2I1/(X2I1-2.0D0)
|
|
ANBN = ANBN + X2I1 + SAB
|
|
CT2 = (X2I1 - 1.0D0)/ANBN
|
|
C2 = X2I1*CT2 - 1.0D0
|
|
D1Z = X2I1*2.0D0*Z/ANBN
|
|
C
|
|
CT3 = SAB*CT2
|
|
G1 = D1Z + CT1*(C2+CT3)
|
|
G2 = D1Z - C2
|
|
G3 = CT1*(1.0D0 - CT3 - 2.0D0*CT2)
|
|
C
|
|
BB(4) = G1*BB(3) + G2*BB(2) + G3*BB(1)
|
|
AA(4) = G1*AA(3) + G2*AA(2) + G3*AA(1)
|
|
IF (ABS(AA(4)*BB(1)-AA(1)*BB(4)).LT.EPS*ABS(BB(4)*BB(1)))
|
|
1 GO TO 40
|
|
C
|
|
C IF OVERFLOWS OR UNDERFLOWS PROVE TO BE A PROBLEM, THE STATEMENTS
|
|
C BELOW COULD BE ALTERED TO INCORPORATE A DYNAMICALLY ADJUSTED SCALE
|
|
C FACTOR.
|
|
C
|
|
DO 20 J=1,3
|
|
AA(J) = AA(J+1)
|
|
BB(J) = BB(J+1)
|
|
20 CONTINUE
|
|
30 CONTINUE
|
|
CALL XERMSG ('SLATEC', 'D9CHU', 'NO CONVERGENCE IN 300 TERMS', 2,
|
|
+ 2)
|
|
C
|
|
40 D9CHU = AA(4)/BB(4)
|
|
C
|
|
IF (D9CHU .LT. SQEPS .OR. D9CHU .GT. 1.0D0/SQEPS) CALL XERMSG
|
|
+ ('SLATEC', 'D9CHU', 'ANSWER LT HALF PRECISION', 2, 1)
|
|
C
|
|
RETURN
|
|
END
|