1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
|
! { dg-do compile { target i?86-*-* x86_64-*-* } }
! { dg-options "-O2 -w" }
C fconc64.F, from CERNLIB (simplified)
FUNCTION DFCONC(X,TAU,M)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMPLEX*16 WGAMMA,WLOGAM
COMPLEX*16 CGM,CLG,CRG,I,A,B,C,TI,R,RR,U(0:3),V(0:3),W(19)
LOGICAL LM0,LM1,LTA
CHARACTER NAME*(*)
CHARACTER*80 ERRTXT
PARAMETER (NAME = 'RFCONC/DFCONC')
DIMENSION T(7),H(9),S(5),P(11),D(-1:6)
PARAMETER (PI = 3.14159 26535 89793 24D+0)
PARAMETER (RPI = 1.77245 38509 05516 03D+0)
PARAMETER (I = (0,1))
PARAMETER (Z1 = 1, HF = Z1/2, TH = 1+HF, C1 = Z1/10, C2 = Z1/5)
PARAMETER (RPH = 2/PI, RPW = 2/RPI, TW = 20, NMAX = 200)
DATA EPS /1D-14/
ASSIGN 1 TO JP
GO TO 20
1 ASSIGN 2 TO JP
GO TO 20
2 IF(LM1) FC=2*FC/SQRT(1-X1)
GO TO 99
12 ASSIGN 3 TO JP
GO TO 20
3 IF(LM1) FC=SIGN(HF,1-X)*(TAU**2+HF**2)*SQRT(ABS(X**2-1))*FC
GO TO 99
13 ASSIGN 4 TO JP
GO TO 20
4 R1=EXP((TI-HF)*LOG(X+X)+CLG(1+TI)-CLG((TH-FM)+TI))*
1 R*((HF-FM)+TI)/TI
FC=RPW*R1
IF(LM1) FC=FC/SQRT(1-X1)
GO TO 99
20 IF(LTA) THEN
IF(ABS(R-RR) .LT. EPS) GO TO JP, (1,2,3,4)
ELSE
W(1)=X1*A*B/C
R=1+W(1)
DO 23 N = 1,NMAX
RR=R
W(1)=W(1)*X1*(A+FN)*(B+FN)/((C+FN)*(FN+1))
IF(ABS(R-RR) .LT. EPS) GO TO JP, (1,2,3,4)
23 CONTINUE
END IF
99 DFCONC=FC
RETURN
101 FORMAT('ILLEGAL ARGUMENT(S) X = ',D15.8,' TAU = ',D15.8,
1 ' M = ',I3)
102 FORMAT('CONVERGENCE PROBLEM FOR HYPERGEOMETRIC FUNCTION, X = ',
1 D15.8)
END
|
