C COMPUTATION OF SPECIAL FUNCTIONS C C Shanjie Zhang and Jianming Jin C C Copyrighted but permission granted to use code in programs. C Buy their book "Computation of Special Functions", 1996, John Wiley & Sons, Inc. C C Scipy changes: C - Compiled into a single source file and changed REAL To DBLE throughout. C - Changed according to ERRATA. C - Changed GAMMA to GAMMA2 and PSI to PSI_SPEC to avoid potential conflicts. C - Made functions return sf_error codes in ISFER variables instead C of printing warnings. The codes are C - SF_ERROR_OK = 0: no error C - SF_ERROR_SINGULAR = 1: singularity encountered C - SF_ERROR_UNDERFLOW = 2: floating point underflow C - SF_ERROR_OVERFLOW = 3: floating point overflow C - SF_ERROR_SLOW = 4: too many iterations required C - SF_ERROR_LOSS = 5: loss of precision C - SF_ERROR_NO_RESULT = 6: no result obtained C - SF_ERROR_DOMAIN = 7: out of domain C - SF_ERROR_ARG = 8: invalid input parameter C - SF_ERROR_OTHER = 9: unclassified error C FUNCTION DNAN() DOUBLE PRECISION DNAN DNAN = 0.0D0 DNAN = 0.0D0/DNAN END FUNCTION DINF() DOUBLE PRECISION DINF DINF = 1.0D300 DINF = DINF*DINF END SUBROUTINE CPDSA(N,Z,CDN) C C =========================================================== C Purpose: Compute complex parabolic cylinder function Dn(z) C for small argument C Input: z --- complex argument of D(z) C n --- Order of D(z) (n = 0,-1,-2,...) C Output: CDN --- Dn(z) C Routine called: GAIH for computing Г(x), x=n/2 (n=1,2,...) C =========================================================== C IMPLICIT DOUBLE PRECISION (A-B,D-H,O-Y) IMPLICIT COMPLEX*16 (C,Z) EPS=1.0D-15 PI=3.141592653589793D0 SQ2=DSQRT(2.0D0) CA0=EXP(-.25D0*Z*Z) VA0=0.5D0*(1.0D0-N) IF (N.EQ.0.0) THEN CDN=CA0 ELSE IF (ABS(Z).EQ.0.0) THEN IF (VA0.LE.0.0.AND.VA0.EQ.INT(VA0)) THEN CDN=0.0D0 ELSE CALL GAIH(VA0,GA0) PD=DSQRT(PI)/(2.0D0**(-.5D0*N)*GA0) CDN = DCMPLX(PD, 0.0D0) ENDIF ELSE XN=-N CALL GAIH(XN,G1) CB0=2.0D0**(-0.5D0*N-1.0D0)*CA0/G1 VT=-.5D0*N CALL GAIH(VT,G0) CDN = DCMPLX(G0, 0.0D0) CR=(1.0D0,0.0D0) DO 10 M=1,250 VM=.5D0*(M-N) CALL GAIH(VM,GM) CR=-CR*SQ2*Z/M CDW=GM*CR CDN=CDN+CDW IF (ABS(CDW).LT.ABS(CDN)*EPS) GO TO 20 10 CONTINUE 20 CDN=CB0*CDN ENDIF ENDIF RETURN END C ********************************** SUBROUTINE CFS(Z,ZF,ZD) C C ========================================================= C Purpose: Compute complex Fresnel Integral S(z) and S'(z) C Input : z --- Argument of S(z) C Output: ZF --- S(z) C ZD --- S'(z) C ========================================================= C IMPLICIT DOUBLE PRECISION (E,P,W) IMPLICIT COMPLEX *16 (C,S,Z,D) EPS=1.0D-14 PI=3.141592653589793D0 W0=ABS(Z) ZP=0.5D0*PI*Z*Z ZP2=ZP*ZP Z0=(0.0D0,0.0D0) IF (Z.EQ.Z0) THEN S=Z0 ELSE IF (W0.LE.2.5) THEN S=Z*ZP/3.0D0 CR=S WB0=0.0D0 DO 10 K=1,80 CR=-.5D0*CR*(4.0D0*K-1.0D0)/K/(2.0D0*K+1.0D0) & /(4.0D0*K+3.0D0)*ZP2 S=S+CR WB=ABS(S) IF (DABS(WB-WB0).LT.EPS.AND.K.GT.10) GO TO 30 10 WB0=WB ELSE IF (W0.GT.2.5.AND.W0.LT.4.5) THEN M=85 S=Z0 CF1=Z0 CF0=(1.0D-100,0.0D0) DO 15 K=M,0,-1 CF=(2.0D0*K+3.0D0)*CF0/ZP-CF1 IF (K.NE.INT(K/2)*2) S=S+CF CF1=CF0 15 CF0=CF S=2.0D0/(PI*Z)*SIN(ZP)/CF*S ELSE C Auxiliary functions f(z) and g(z) can be computed using an C asymptotic expansion in the right quadrant |arg(z)| <= pi/4, not pi/2 C as sometimes suggested. Use the symmetry S(z) = -iS(-iz). C Interestingly, most of the expansion code is the same across C the quadrants. (The forth power in Z is the equalizer here.) C Only one constant has to be adapted. IF (DIMAG(Z).GT.-DBLE(Z).AND.DIMAG(Z).LE.DBLE(Z)) THEN C right quadrant D=DCMPLX(.5D0,0.0D0) ELSE IF (DIMAG(Z).GT.DBLE(Z).AND.DIMAG(Z).GE.-DBLE(Z)) THEN C upper quadrant D=DCMPLX(0.0D0,-.5D0) ELSE IF (DIMAG(Z).LT.-DBLE(Z).AND.DIMAG(Z).GE.DBLE(Z)) THEN C left quadrant D=DCMPLX(-.5D0,0.0D0) ELSE C lower quadrant D=DCMPLX(0.0D0,.5D0) ENDIF CR=(1.0D0,0.0D0) CF=(1.0D0,0.0D0) DO 20 K=1,20 CR=-.25D0*CR*(4.0D0*K-1.0D0)*(4.0D0*K-3.0D0)/ZP2 20 CF=CF+CR CR=(1.0D0,0.0D0) CG=(1.0D0,0.0D0) DO 25 K=1,12 CR=-.25D0*CR*(4.0D0*K+1.0D0)*(4.0D0*K-1.0D0)/ZP2 25 CG=CG+CR CG=CG/(PI*Z*Z) S=D-(CF*COS(ZP)+CG*SIN(ZP))/(PI*Z) ENDIF 30 ZF=S ZD=SIN(0.5*PI*Z*Z) RETURN END C ********************************** SUBROUTINE LQMN(MM,M,N,X,QM,QD) C C ========================================================== C Purpose: Compute the associated Legendre functions of the C second kind, Qmn(x) and Qmn'(x) C Input : x --- Argument of Qmn(x) C m --- Order of Qmn(x) ( m = 0,1,2,… ) C n --- Degree of Qmn(x) ( n = 0,1,2,… ) C mm --- Physical dimension of QM and QD C Output: QM(m,n) --- Qmn(x) C QD(m,n) --- Qmn'(x) C ========================================================== C IMPLICIT DOUBLE PRECISION (Q,X) DIMENSION QM(0:MM,0:N),QD(0:MM,0:N) IF (DABS(X).EQ.1.0D0) THEN DO 10 I=0,M DO 10 J=0,N QM(I,J)=1.0D+300 QD(I,J)=1.0D+300 10 CONTINUE RETURN ENDIF LS=1 IF (DABS(X).GT.1.0D0) LS=-1 XS=LS*(1.0D0-X*X) XQ=DSQRT(XS) Q0=0.5D0*DLOG(DABS((X+1.0D0)/(X-1.0D0))) IF (DABS(X).LT.1.0001D0) THEN QM(0,0)=Q0 QM(0,1)=X*Q0-1.0D0 QM(1,0)=-1.0D0/XQ QM(1,1)=-LS*XQ*(Q0+X/(1.0D0-X*X)) DO 15 I=0,1 DO 15 J=2,N QM(I,J)=((2.0D0*J-1.0D0)*X*QM(I,J-1) & -(J+I-1.0D0)*QM(I,J-2))/(J-I) 15 CONTINUE DO 20 J=0,N DO 20 I=2,M QM(I,J)=-2.0D0*(I-1.0D0)*X/XQ*QM(I-1,J)-LS* & (J+I-1.0D0)*(J-I+2.0D0)*QM(I-2,J) 20 CONTINUE ELSE IF (DABS(X).GT.1.1D0) THEN KM=40+M+N ELSE KM=(40+M+N)*INT(-1.0-1.8*LOG(X-1.0)) ENDIF QF2=0.0D0 QF1=1.0D0 QF0=0.0D0 DO 25 K=KM,0,-1 QF0=((2*K+3.0D0)*X*QF1-(K+2.0D0)*QF2)/(K+1.0D0) IF (K.LE.N) QM(0,K)=QF0 QF2=QF1 25 QF1=QF0 DO 30 K=0,N 30 QM(0,K)=Q0*QM(0,K)/QF0 QF2=0.0D0 QF1=1.0D0 DO 35 K=KM,0,-1 QF0=((2*K+3.0D0)*X*QF1-(K+1.0D0)*QF2)/(K+2.0D0) IF (K.LE.N) QM(1,K)=QF0 QF2=QF1 35 QF1=QF0 Q10=-1.0D0/XQ DO 40 K=0,N 40 QM(1,K)=Q10*QM(1,K)/QF0 DO 45 J=0,N Q0=QM(0,J) Q1=QM(1,J) DO 45 I=0,M-2 QF=-2.0D0*(I+1)*X/XQ*Q1+(J-I)*(J+I+1.0D0)*Q0 QM(I+2,J)=QF Q0=Q1 Q1=QF 45 CONTINUE ENDIF QD(0,0)=LS/XS DO 50 J=1,N 50 QD(0,J)=LS*J*(QM(0,J-1)-X*QM(0,J))/XS DO 55 J=0,N DO 55 I=1,M QD(I,J)=LS*I*X/XS*QM(I,J)+(I+J)*(J-I+1.0D0)/XQ*QM(I-1,J) 55 CONTINUE RETURN END C ********************************** SUBROUTINE CLPMN(MM,M,N,X,Y,NTYPE,CPM,CPD) C C ========================================================= C Purpose: Compute the associated Legendre functions Pmn(z) C and their derivatives Pmn'(z) for a complex C argument C Input : x --- Real part of z C y --- Imaginary part of z C m --- Order of Pmn(z), m = 0,1,2,...,n C n --- Degree of Pmn(z), n = 0,1,2,...,N C mm --- Physical dimension of CPM and CPD C ntype --- type of cut, either 2 or 3 C Output: CPM(m,n) --- Pmn(z) C CPD(m,n) --- Pmn'(z) C ========================================================= C IMPLICIT DOUBLE PRECISION (D,X,Y) IMPLICIT COMPLEX*16 (C,Z) DIMENSION CPM(0:MM,0:N),CPD(0:MM,0:N) Z = DCMPLX(X, Y) DO 10 I=0,N DO 10 J=0,M CPM(J,I)=(0.0D0,0.0D0) 10 CPD(J,I)=(0.0D0,0.0D0) CPM(0,0)=(1.0D0,0.0D0) IF (N.EQ.0) RETURN IF (DABS(X).EQ.1.0D0.AND.Y.EQ.0.0D0) THEN DO 15 I=1,N CPM(0,I)=X**I 15 CPD(0,I)=0.5D0*I*(I+1)*X**(I+1) DO 20 J=1,N DO 20 I=1,M IF (I.EQ.1) THEN CPD(I,J)=DINF() ELSE IF (I.EQ.2) THEN CPD(I,J)=-0.25D0*(J+2)*(J+1)*J*(J-1)*X**(J+1) ENDIF 20 CONTINUE RETURN ENDIF if (NTYPE.EQ.2) THEN C sqrt(1 - z^2) with branch cut on |x|>1 ZS=(1.0D0-Z*Z) ZQ=-SQRT(ZS) LS=-1 ELSE C sqrt(z^2 - 1) with branch cut between [-1, 1] ZS=(Z*Z-1.0D0) ZQ=SQRT(ZS) IF (X.LT.0D0) THEN ZQ=-ZQ END IF LS=1 END IF DO 25 I=1,M C DLMF 14.7.15 25 CPM(I,I)=(2.0D0*I-1.0D0)*ZQ*CPM(I-1,I-1) DO 30 I=0,MIN(M,N-1) C DLMF 14.10.7 30 CPM(I,I+1)=(2.0D0*I+1.0D0)*Z*CPM(I,I) DO 35 I=0,M DO 35 J=I+2,N C DLMF 14.10.3 CPM(I,J)=((2.0D0*J-1.0D0)*Z*CPM(I,J-1)-(I+J- & 1.0D0)*CPM(I,J-2))/(J-I) 35 CONTINUE CPD(0,0)=(0.0D0,0.0D0) DO 40 J=1,N C DLMF 14.10.5 40 CPD(0,J)=LS*J*(Z*CPM(0,J)-CPM(0,J-1))/ZS DO 45 I=1,M DO 45 J=I,N C derivative of DLMF 14.7.11 & DLMF 14.10.6 for type 3 C derivative of DLMF 14.7.8 & DLMF 14.10.1 for type 2 CPD(I,J)=LS*(-I*Z*CPM(I,J)/ZS+(J+I)*(J-I+1.0D0) & /ZQ*CPM(I-1,J)) 45 CONTINUE RETURN END C ********************************** SUBROUTINE VVSA(VA,X,PV) C C =================================================== C Purpose: Compute parabolic cylinder function Vv(x) C for small argument C Input: x --- Argument C va --- Order C Output: PV --- Vv(x) C Routine called : GAMMA2 for computing Г(x) C =================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) EPS=1.0D-15 PI=3.141592653589793D0 EP=EXP(-.25D0*X*X) VA0=1.0D0+0.5D0*VA IF (X.EQ.0.0) THEN IF (VA0.LE.0.0.AND.VA0.EQ.INT(VA0).OR.VA.EQ.0.0) THEN PV=0.0D0 ELSE VB0=-0.5D0*VA SV0=DSIN(VA0*PI) CALL GAMMA2(VA0,GA0) PV=2.0D0**VB0*SV0/GA0 ENDIF ELSE SQ2=DSQRT(2.0D0) A0=2.0D0**(-.5D0*VA)*EP/(2.0D0*PI) SV=DSIN(-(VA+.5D0)*PI) V1=-.5D0*VA CALL GAMMA2(V1,G1) PV=(SV+1.0D0)*G1 R=1.0D0 FAC=1.0D0 DO 10 M=1,250 VM=.5D0*(M-VA) CALL GAMMA2(VM,GM) R=R*SQ2*X/M FAC=-FAC GW=FAC*SV+1.0D0 R1=GW*R*GM PV=PV+R1 IF (DABS(R1/PV).LT.EPS.AND.GW.NE.0.0) GO TO 15 10 CONTINUE 15 PV=A0*PV ENDIF RETURN END C ********************************** C SciPy: Changed P from a character array to an integer array. SUBROUTINE JDZO(NT,N,M,P,ZO) C C =========================================================== C Purpose: Compute the zeros of Bessel functions Jn(x) and C Jn'(x), and arrange them in the order of their C magnitudes C Input : NT --- Number of total zeros ( NT ≤ 1200 ) C Output: ZO(L) --- Value of the L-th zero of Jn(x) C and Jn'(x) C N(L) --- n, order of Jn(x) or Jn'(x) associated C with the L-th zero C M(L) --- m, serial number of the zeros of Jn(x) C or Jn'(x) associated with the L-th zero C ( L is the serial number of all the C zeros of Jn(x) and Jn'(x) ) C P(L) --- 0 (TM) or 1 (TE), a code for designating the C zeros of Jn(x) or Jn'(x). C In the waveguide applications, the zeros C of Jn(x) correspond to TM modes and C those of Jn'(x) correspond to TE modes C Routine called: BJNDD for computing Jn(x), Jn'(x) and C Jn''(x) C ============================================================= C IMPLICIT DOUBLE PRECISION (A-H,O-Z) INTEGER P(1400), P1(70) DIMENSION N(1400),M(1400),ZO(0:1400),N1(70),M1(70), & ZOC(0:70),BJ(101),DJ(101),FJ(101) X = 0 ZOC(0) = 0 IF (NT.LT.600) THEN XM=-1.0+2.248485*NT**0.5-.0159382*NT+3.208775E-4 & *NT**1.5 NM=INT(14.5+.05875*NT) MM=INT(.02*NT)+6 ELSE XM=5.0+1.445389*NT**.5+.01889876*NT-2.147763E-4 & *NT**1.5 NM=INT(27.8+.0327*NT) MM=INT(.01088*NT)+10 ENDIF L0=0 DO 45 I=1,NM X1=.407658+.4795504*(I-1)**.5+.983618*(I-1) X2=1.99535+.8333883*(I-1)**.5+.984584*(I-1) L1=0 DO 30 J=1,MM IF (I.EQ.1.AND.J.EQ.1) GO TO 15 X=X1 10 CALL BJNDD(I,X,BJ,DJ,FJ) X0=X X=X-DJ(I)/FJ(I) IF (X1.GT.XM) GO TO 20 IF (DABS(X-X0).GT.1.0D-10) GO TO 10 15 L1=L1+1 N1(L1)=I-1 M1(L1)=J IF (I.EQ.1) M1(L1)=J-1 P1(L1)=1 ZOC(L1)=X IF (I.LE.15) THEN X1=X+3.057+.0122*(I-1)+(1.555+.41575*(I-1))/(J+1)**2 ELSE X1=X+2.918+.01924*(I-1)+(6.26+.13205*(I-1))/(J+1)**2 ENDIF 20 X=X2 25 CALL BJNDD(I,X,BJ,DJ,FJ) X0=X X=X-BJ(I)/DJ(I) IF (X.GT.XM) GO TO 30 IF (DABS(X-X0).GT.1.0D-10) GO TO 25 L1=L1+1 N1(L1)=I-1 M1(L1)=J P1(L1)=0 ZOC(L1)=X IF (I.LE.15) THEN X2=X+3.11+.0138*(I-1)+(.04832+.2804*(I-1))/(J+1)**2 ELSE X2=X+3.001+.0105*(I-1)+(11.52+.48525*(I-1))/(J+3)**2 ENDIF 30 CONTINUE L=L0+L1 L2=L 35 IF (L0.EQ.0) THEN DO 40 K=1,L ZO(K)=ZOC(K) N(K)=N1(K) M(K)=M1(K) 40 P(K)=P1(K) L1=0 ELSE IF (L0.NE.0) THEN IF (ZO(L0).GE.ZOC(L1)) THEN ZO(L0+L1)=ZO(L0) N(L0+L1)=N(L0) M(L0+L1)=M(L0) P(L0+L1)=P(L0) L0=L0-1 ELSE ZO(L0+L1)=ZOC(L1) N(L0+L1)=N1(L1) M(L0+L1)=M1(L1) P(L0+L1)=P1(L1) L1=L1-1 ENDIF ENDIF IF (L1.NE.0) GO TO 35 45 L0=L2 RETURN END C ********************************** SUBROUTINE CBK(M,N,C,CV,QT,CK,BK) C C ===================================================== C Purpose: Compute coefficient Bk's for oblate radial C functions with a small argument C ===================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION BK(200),CK(200),U(200),V(200),W(200) EPS=1.0D-14 IP=1 IF (N-M.EQ.2*INT((N-M)/2)) IP=0 NM=25+INT(0.5*(N-M)+C) U(1)=0.0D0 N2=NM-2 DO 10 J=2,N2 10 U(J)=C*C DO 15 J=1,N2 15 V(J)=(2.0*J-1.0-IP)*(2.0*(J-M)-IP)+M*(M-1.0)-CV DO 20 J=1,NM-1 20 W(J)=(2.0*J-IP)*(2.0*J+1.0-IP) IF (IP.EQ.0) THEN SW=0.0D0 DO 40 K=0,N2-1 S1=0.0D0 I1=K-M+1 DO 30 I=I1,NM IF (I.LT.0) GO TO 30 R1=1.0D0 DO 25 J=1,K 25 R1=R1*(I+M-J)/J S1=S1+CK(I+1)*(2.0*I+M)*R1 IF (DABS(S1-SW).LT.DABS(S1)*EPS) GO TO 35 SW=S1 30 CONTINUE 35 BK(K+1)=QT*S1 40 CONTINUE ELSE IF (IP.EQ.1) THEN SW=0.0D0 DO 60 K=0,N2-1 S1=0.0D0 I1=K-M+1 DO 50 I=I1,NM IF (I.LT.0) GO TO 50 R1=1.0D0 DO 45 J=1,K 45 R1=R1*(I+M-J)/J IF (I.GT.0) S1=S1+CK(I)*(2.0*I+M-1)*R1 S1=S1-CK(I+1)*(2.0*I+M)*R1 IF (DABS(S1-SW).LT.DABS(S1)*EPS) GO TO 55 SW=S1 50 CONTINUE 55 BK(K+1)=QT*S1 60 CONTINUE ENDIF W(1)=W(1)/V(1) BK(1)=BK(1)/V(1) DO 65 K=2,N2 T=V(K)-W(K-1)*U(K) W(K)=W(K)/T 65 BK(K)=(BK(K)-BK(K-1)*U(K))/T DO 70 K=N2-1,1,-1 70 BK(K)=BK(K)-W(K)*BK(K+1) RETURN END C ********************************** SUBROUTINE RMN2SP(M,N,C,X,CV,DF,KD,R2F,R2D) C C ====================================================== C Purpose: Compute prolate spheroidal radial function C of the second kind with a small argument C Routines called: C (1) LPMNS for computing the associated Legendre C functions of the first kind C (2) LQMNS for computing the associated Legendre C functions of the second kind C (3) KMN for computing expansion coefficients C and joining factors C ====================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION PM(0:251),PD(0:251),QM(0:251),QD(0:251), & DN(200),DF(200) IF (DABS(DF(1)).LT.1.0D-280) THEN R2F=1.0D+300 R2D=1.0D+300 RETURN ENDIF EPS=1.0D-14 IP=1 NM1=INT((N-M)/2) IF (N-M.EQ.2*NM1) IP=0 NM=25+NM1+INT(C) NM2=2*NM+M CALL KMN(M,N,C,CV,KD,DF,DN,CK1,CK2) CALL LPMNS(M,NM2,X,PM,PD) CALL LQMNS(M,NM2,X,QM,QD) SU0=0.0D0 SW=0.0D0 DO 10 K=1,NM J=2*K-2+M+IP SU0=SU0+DF(K)*QM(J) IF (K.GT.NM1.AND.DABS(SU0-SW).LT.DABS(SU0)*EPS) GO TO 15 10 SW=SU0 15 SD0=0.0D0 DO 20 K=1,NM J=2*K-2+M+IP SD0=SD0+DF(K)*QD(J) IF (K.GT.NM1.AND.DABS(SD0-SW).LT.DABS(SD0)*EPS) GO TO 25 20 SW=SD0 25 SU1=0.0D0 SD1=0.0D0 DO 30 K=1,M J=M-2*K+IP IF (J.LT.0) J=-J-1 SU1=SU1+DN(K)*QM(J) 30 SD1=SD1+DN(K)*QD(J) GA=((X-1.0D0)/(X+1.0D0))**(0.5D0*M) DO 55 K=1,M J=M-2*K+IP IF (J.GE.0) GO TO 55 IF (J.LT.0) J=-J-1 R1=1.0D0 DO 35 J1=1,J 35 R1=(M+J1)*R1 R2=1.0D0 DO 40 J2=1,M-J-2 40 R2=J2*R2 R3=1.0D0 SF=1.0D0 DO 45 L1=1,J R3=0.5D0*R3*(-J+L1-1.0)*(J+L1)/((M+L1)*L1)*(1.0-X) 45 SF=SF+R3 IF (M-J.GE.2) GB=(M-J-1.0D0)*R2 IF (M-J.LE.1) GB=1.0D0 SPL=R1*GA*GB*SF SU1=SU1+(-1)**(J+M)*DN(K)*SPL SPD1=M/(X*X-1.0D0)*SPL GC=0.5D0*J*(J+1.0)/(M+1.0) SD=1.0D0 R4=1.0D0 DO 50 L1=1,J-1 R4=0.5D0*R4*(-J+L1)*(J+L1+1.0)/((M+L1+1.0)*L1) & *(1.0-X) 50 SD=SD+R4 SPD2=R1*GA*GB*GC*SD SD1=SD1+(-1)**(J+M)*DN(K)*(SPD1+SPD2) 55 CONTINUE SU2=0.0D0 KI=(2*M+1+IP)/2 NM3=NM+KI DO 60 K=KI,NM3 J=2*K-1-M-IP SU2=SU2+DN(K)*PM(J) IF (J.GT.M.AND.DABS(SU2-SW).LT.DABS(SU2)*EPS) GO TO 65 60 SW=SU2 65 SD2=0.0D0 DO 70 K=KI,NM3 J=2*K-1-M-IP SD2=SD2+DN(K)*PD(J) IF (J.GT.M.AND.DABS(SD2-SW).LT.DABS(SD2)*EPS) GO TO 75 70 SW=SD2 75 SUM=SU0+SU1+SU2 SDM=SD0+SD1+SD2 R2F=SUM/CK2 R2D=SDM/CK2 RETURN END C ********************************** SUBROUTINE BERNOB(N,BN) C C ====================================== C Purpose: Compute Bernoulli number Bn C Input : n --- Serial number C Output: BN(n) --- Bn C ====================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION BN(0:N) TPI=6.283185307179586D0 BN(0)=1.0D0 BN(1)=-0.5D0 BN(2)=1.0D0/6.0D0 R1=(2.0D0/TPI)**2 DO 20 M=4,N,2 R1=-R1*(M-1)*M/(TPI*TPI) R2=1.0D0 DO 10 K=2,10000 S=(1.0D0/K)**M R2=R2+S IF (S.LT.1.0D-15) GOTO 20 10 CONTINUE 20 BN(M)=R1*R2 RETURN END C ********************************** SUBROUTINE BERNOA(N,BN) C C ====================================== C Purpose: Compute Bernoulli number Bn C Input : n --- Serial number C Output: BN(n) --- Bn C ====================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION BN(0:N) BN(0)=1.0D0 BN(1)=-0.5D0 DO 30 M=2,N S=-(1.0D0/(M+1.0D0)-0.5D0) DO 20 K=2,M-1 R=1.0D0 DO 10 J=2,K 10 R=R*(J+M-K)/J 20 S=S-R*BN(K) 30 BN(M)=S DO 40 M=3,N,2 40 BN(M)=0.0D0 RETURN END C ********************************** SUBROUTINE QSTAR(M,N,C,CK,CK1,QS,QT) C C ========================================================= C Purpose: Compute Q*mn(-ic) for oblate radial functions C with a small argument C ========================================================= C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION AP(200),CK(200) IP=1 IF (N-M.EQ.2*INT((N-M)/2)) IP=0 R=1.0D0/CK(1)**2 AP(1)=R DO 20 I=1,M S=0.0D0 DO 15 L=1,I SK=0.0D0 DO 10 K=0,L 10 SK=SK+CK(K+1)*CK(L-K+1) 15 S=S+SK*AP(I-L+1) 20 AP(I+1)=-R*S QS0=AP(M+1) DO 30 L=1,M R=1.0D0 DO 25 K=1,L 25 R=R*(2.0D0*K+IP)*(2.0D0*K-1.0D0+IP)/(2.0D0*K)**2 30 QS0=QS0+AP(M-L+1)*R QS=(-1)**IP*CK1*(CK1*QS0)/C QT=-2.0D0/CK1*QS RETURN END C ********************************** SUBROUTINE CV0(KD,M,Q,A0) C C ===================================================== C Purpose: Compute the initial characteristic value of C Mathieu functions for m ≤ 12 or q ≤ 300 or C q ≥ m*m C Input : m --- Order of Mathieu functions C q --- Parameter of Mathieu functions C Output: A0 --- Characteristic value C Routines called: C (1) CVQM for computing initial characteristic C value for q ≤ 3*m C (2) CVQL for computing initial characteristic C value for q ≥ m*m C ==================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) Q2=Q*Q IF (M.EQ.0) THEN IF (Q.LE.1.0) THEN A0=(((.0036392*Q2-.0125868)*Q2+.0546875)*Q2-.5)*Q2 ELSE IF (Q.LE.10.0) THEN A0=((3.999267D-3*Q-9.638957D-2)*Q-.88297)*Q & +.5542818 ELSE CALL CVQL(KD,M,Q,A0) ENDIF ELSE IF (M.EQ.1) THEN IF (Q.LE.1.0.AND.KD.EQ.2) THEN A0=(((-6.51E-4*Q-.015625)*Q-.125)*Q+1.0)*Q+1.0 ELSE IF (Q.LE.1.0.AND.KD.EQ.3) THEN A0=(((-6.51E-4*Q+.015625)*Q-.125)*Q-1.0)*Q+1.0 ELSE IF (Q.LE.10.0.AND. KD.EQ.2) THEN A0=(((-4.94603D-4*Q+1.92917D-2)*Q-.3089229) & *Q+1.33372)*Q+.811752 ELSE IF (Q.LE.10.0.AND.KD.EQ.3) THEN A0=((1.971096D-3*Q-5.482465D-2)*Q-1.152218) & *Q+1.10427 ELSE CALL CVQL(KD,M,Q,A0) ENDIF ELSE IF (M.EQ.2) THEN IF (Q.LE.1.0.AND.KD.EQ.1) THEN A0=(((-.0036391*Q2+.0125888)*Q2-.0551939)*Q2 & +.416667)*Q2+4.0 ELSE IF (Q.LE.1.0.AND.KD.EQ.4) THEN A0=(.0003617*Q2-.0833333)*Q2+4.0 ELSE IF (Q.LE.15.AND.KD.EQ.1) THEN A0=(((3.200972D-4*Q-8.667445D-3)*Q & -1.829032D-4)*Q+.9919999)*Q+3.3290504 ELSE IF (Q.LE.10.0.AND.KD.EQ.4) THEN A0=((2.38446D-3*Q-.08725329)*Q-4.732542D-3) & *Q+4.00909 ELSE CALL CVQL(KD,M,Q,A0) ENDIF ELSE IF (M.EQ.3) THEN IF (Q.LE.1.0.AND.KD.EQ.2) THEN A0=((6.348E-4*Q+.015625)*Q+.0625)*Q2+9.0 ELSE IF (Q.LE.1.0.AND.KD.EQ.3) THEN A0=((6.348E-4*Q-.015625)*Q+.0625)*Q2+9.0 ELSE IF (Q.LE.20.0.AND.KD.EQ.2) THEN A0=(((3.035731D-4*Q-1.453021D-2)*Q & +.19069602)*Q-.1039356)*Q+8.9449274 ELSE IF (Q.LE.15.0.AND.KD.EQ.3) THEN A0=((9.369364D-5*Q-.03569325)*Q+.2689874)*Q & +8.771735 ELSE CALL CVQL(KD,M,Q,A0) ENDIF ELSE IF (M.EQ.4) THEN IF (Q.LE.1.0.AND.KD.EQ.1) THEN A0=((-2.1E-6*Q2+5.012E-4)*Q2+.0333333)*Q2+16.0 ELSE IF (Q.LE.1.0.AND.KD.EQ.4) THEN A0=((3.7E-6*Q2-3.669E-4)*Q2+.0333333)*Q2+16.0 ELSE IF (Q.LE.25.0.AND.KD.EQ.1) THEN A0=(((1.076676D-4*Q-7.9684875D-3)*Q & +.17344854)*Q-.5924058)*Q+16.620847 ELSE IF (Q.LE.20.0.AND.KD.EQ.4) THEN A0=((-7.08719D-4*Q+3.8216144D-3)*Q & +.1907493)*Q+15.744 ELSE CALL CVQL(KD,M,Q,A0) ENDIF ELSE IF (M.EQ.5) THEN IF (Q.LE.1.0.AND.KD.EQ.2) THEN A0=((6.8E-6*Q+1.42E-5)*Q2+.0208333)*Q2+25.0 ELSE IF (Q.LE.1.0.AND.KD.EQ.3) THEN A0=((-6.8E-6*Q+1.42E-5)*Q2+.0208333)*Q2+25.0 ELSE IF (Q.LE.35.0.AND.KD.EQ.2) THEN A0=(((2.238231D-5*Q-2.983416D-3)*Q & +.10706975)*Q-.600205)*Q+25.93515 ELSE IF (Q.LE.25.0.AND.KD.EQ.3) THEN A0=((-7.425364D-4*Q+2.18225D-2)*Q & +4.16399D-2)*Q+24.897 ELSE CALL CVQL(KD,M,Q,A0) ENDIF ELSE IF (M.EQ.6) THEN IF (Q.LE.1.0) THEN A0=(.4D-6*Q2+.0142857)*Q2+36.0 ELSE IF (Q.LE.40.0.AND.KD.EQ.1) THEN A0=(((-1.66846D-5*Q+4.80263D-4)*Q & +2.53998D-2)*Q-.181233)*Q+36.423 ELSE IF (Q.LE.35.0.AND.KD.EQ.4) THEN A0=((-4.57146D-4*Q+2.16609D-2)*Q-2.349616D-2)*Q & +35.99251 ELSE CALL CVQL(KD,M,Q,A0) ENDIF ELSE IF (M.EQ.7) THEN IF (Q.LE.10.0) THEN CALL CVQM(M,Q,A0) ELSE IF (Q.LE.50.0.AND.KD.EQ.2) THEN A0=(((-1.411114D-5*Q+9.730514D-4)*Q & -3.097887D-3)*Q+3.533597D-2)*Q+49.0547 ELSE IF (Q.LE.40.0.AND.KD.EQ.3) THEN A0=((-3.043872D-4*Q+2.05511D-2)*Q & -9.16292D-2)*Q+49.19035 ELSE CALL CVQL(KD,M,Q,A0) ENDIF ELSE IF (M.GE.8) THEN IF (Q.LE.3.*M) THEN CALL CVQM(M,Q,A0) ELSE IF (Q.GT.M*M) THEN CALL CVQL(KD,M,Q,A0) ELSE IF (M.EQ.8.AND.KD.EQ.1) THEN A0=(((8.634308D-6*Q-2.100289D-3)*Q+.169072)*Q & -4.64336)*Q+109.4211 ELSE IF (M.EQ.8.AND.KD.EQ.4) THEN A0=((-6.7842D-5*Q+2.2057D-3)*Q+.48296)*Q+56.59 ELSE IF (M.EQ.9.AND.KD.EQ.2) THEN A0=(((2.906435D-6*Q-1.019893D-3)*Q+.1101965)*Q & -3.821851)*Q+127.6098 ELSE IF (M.EQ.9.AND.KD.EQ.3) THEN A0=((-9.577289D-5*Q+.01043839)*Q+.06588934)*Q & +78.0198 ELSE IF (M.EQ.10.AND.KD.EQ.1) THEN A0=(((5.44927D-7*Q-3.926119D-4)*Q+.0612099)*Q & -2.600805)*Q+138.1923 ELSE IF (M.EQ.10.AND.KD.EQ.4) THEN A0=((-7.660143D-5*Q+.01132506)*Q-.09746023)*Q & +99.29494 ELSE IF (M.EQ.11.AND.KD.EQ.2) THEN A0=(((-5.67615D-7*Q+7.152722D-6)*Q+.01920291)*Q & -1.081583)*Q+140.88 ELSE IF (M.EQ.11.AND.KD.EQ.3) THEN A0=((-6.310551D-5*Q+.0119247)*Q-.2681195)*Q & +123.667 ELSE IF (M.EQ.12.AND.KD.EQ.1) THEN A0=(((-2.38351D-7*Q-2.90139D-5)*Q+.02023088)*Q & -1.289)*Q+171.2723 ELSE IF (M.EQ.12.AND.KD.EQ.4) THEN A0=(((3.08902D-7*Q-1.577869D-4)*Q+.0247911)*Q & -1.05454)*Q+161.471 ENDIF ENDIF ENDIF RETURN END C ********************************** SUBROUTINE CVQM(M,Q,A0) C C ===================================================== C Purpose: Compute the characteristic value of Mathieu C functions for q ≤ m*m C Input : m --- Order of Mathieu functions C q --- Parameter of Mathieu functions C Output: A0 --- Initial characteristic value C ===================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) HM1=.5*Q/(M*M-1.0) HM3=.25*HM1**3/(M*M-4.0) HM5=HM1*HM3*Q/((M*M-1.0)*(M*M-9.0)) A0=M*M+Q*(HM1+(5.0*M*M+7.0)*HM3 & +(9.0*M**4+58.0*M*M+29.0)*HM5) RETURN END C ********************************** SUBROUTINE CVQL(KD,M,Q,A0) C C ======================================================== C Purpose: Compute the characteristic value of Mathieu C functions for q ≥ 3m C Input : m --- Order of Mathieu functions C q --- Parameter of Mathieu functions C Output: A0 --- Initial characteristic value C ======================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) W=0.0D0 IF (KD.EQ.1.OR.KD.EQ.2) W=2.0D0*M+1.0D0 IF (KD.EQ.3.OR.KD.EQ.4) W=2.0D0*M-1.0D0 W2=W*W W3=W*W2 W4=W2*W2 W6=W2*W4 D1=5.0+34.0/W2+9.0/W4 D2=(33.0+410.0/W2+405.0/W4)/W D3=(63.0+1260.0/W2+2943.0/W4+486.0/W6)/W2 D4=(527.0+15617.0/W2+69001.0/W4+41607.0/W6)/W3 C1=128.0 P2=Q/W4 P1=DSQRT(P2) CV1=-2.0*Q+2.0*W*DSQRT(Q)-(W2+1.0)/8.0 CV2=(W+3.0/W)+D1/(32.0*P1)+D2/(8.0*C1*P2) CV2=CV2+D3/(64.0*C1*P1*P2)+D4/(16.0*C1*C1*P2*P2) A0=CV1-CV2/(C1*P1) RETURN END INTEGER FUNCTION MSTA1(X,MP) C C =================================================== C Purpose: Determine the starting point for backward C recurrence such that the magnitude of C Jn(x) at that point is about 10^(-MP) C Input : x --- Argument of Jn(x) C MP --- Value of magnitude C Output: MSTA1 --- Starting point C =================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) A0=DABS(X) N0=INT(1.1D0*A0)+1 F0=ENVJ(N0,A0)-MP N1=N0+5 F1=ENVJ(N1,A0)-MP DO 10 IT=1,20 NN=N1-(N1-N0)/(1.0D0-F0/F1) F=ENVJ(NN,A0)-MP IF(ABS(NN-N1).LT.1) GO TO 20 N0=N1 F0=F1 N1=NN 10 F1=F 20 MSTA1=NN RETURN END INTEGER FUNCTION MSTA2(X,N,MP) C C =================================================== C Purpose: Determine the starting point for backward C recurrence such that all Jn(x) has MP C significant digits C Input : x --- Argument of Jn(x) C n --- Order of Jn(x) C MP --- Significant digit C Output: MSTA2 --- Starting point C =================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) A0=DABS(X) HMP=0.5D0*MP EJN=ENVJ(N,A0) IF (EJN.LE.HMP) THEN OBJ=MP N0=INT(1.1*A0)+1 ELSE OBJ=HMP+EJN N0=N ENDIF F0=ENVJ(N0,A0)-OBJ N1=N0+5 F1=ENVJ(N1,A0)-OBJ DO 10 IT=1,20 NN=N1-(N1-N0)/(1.0D0-F0/F1) F=ENVJ(NN,A0)-OBJ IF (ABS(NN-N1).LT.1) GO TO 20 N0=N1 F0=F1 N1=NN 10 F1=F 20 MSTA2=NN+10 RETURN END REAL*8 FUNCTION ENVJ(N,X) DOUBLE PRECISION X ENVJ=0.5D0*DLOG10(6.28D0*N)-N*DLOG10(1.36D0*X/N) RETURN END C ********************************** SUBROUTINE ITTJYB(X,TTJ,TTY) C C ========================================================== C Purpose: Integrate [1-J0(t)]/t with respect to t from 0 C to x, and Y0(t)/t with respect to t from x to ∞ C Input : x --- Variable in the limits ( x ≥ 0 ) C Output: TTJ --- Integration of [1-J0(t)]/t from 0 to x C TTY --- Integration of Y0(t)/t from x to ∞ C ========================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) PI=3.141592653589793D0 EL=.5772156649015329D0 IF (X.EQ.0.0D0) THEN TTJ=0.0D0 TTY=-1.0D+300 ELSE IF (X.LE.4.0D0) THEN X1=X/4.0D0 T=X1*X1 TTJ=((((((.35817D-4*T-.639765D-3)*T+.7092535D-2)*T & -.055544803D0)*T+.296292677D0)*T-.999999326D0) & *T+1.999999936D0)*T TTY=(((((((-.3546D-5*T+.76217D-4)*T-.1059499D-2)*T & +.010787555D0)*T-.07810271D0)*T+.377255736D0) & *T-1.114084491D0)*T+1.909859297D0)*T E0=EL+DLOG(X/2.0D0) TTY=PI/6.0D0+E0/PI*(2.0D0*TTJ-E0)-TTY ELSE IF (X.LE.8.0D0) THEN XT=X+.25D0*PI T1=4.0D0/X T=T1*T1 F0=(((((.0145369D0*T-.0666297D0)*T+.1341551D0)*T & -.1647797D0)*T+.1608874D0)*T-.2021547D0)*T & +.7977506D0 G0=((((((.0160672D0*T-.0759339D0)*T+.1576116D0)*T & -.1960154D0)*T+.1797457D0)*T-.1702778D0)*T & +.3235819D0)*T1 TTJ=(F0*DCOS(XT)+G0*DSIN(XT))/(DSQRT(X)*X) TTJ=TTJ+EL+DLOG(X/2.0D0) TTY=(F0*DSIN(XT)-G0*DCOS(XT))/(DSQRT(X)*X) ELSE T=8.0D0/X XT=X+.25D0*PI F0=(((((.18118D-2*T-.91909D-2)*T+.017033D0)*T & -.9394D-3)*T-.051445D0)*T-.11D-5)*T+.7978846D0 G0=(((((-.23731D-2*T+.59842D-2)*T+.24437D-2)*T & -.0233178D0)*T+.595D-4)*T+.1620695D0)*T TTJ=(F0*DCOS(XT)+G0*DSIN(XT))/(DSQRT(X)*X) & +EL+DLOG(X/2.0D0) TTY=(F0*DSIN(XT)-G0*DCOS(XT))/(DSQRT(X)*X) ENDIF RETURN END C ********************************** SUBROUTINE ITTJYA(X,TTJ,TTY) C C ========================================================= C Purpose: Integrate [1-J0(t)]/t with respect to t from 0 C to x, and Y0(t)/t with respect to t from x to ∞ C Input : x --- Variable in the limits ( x ≥ 0 ) C Output: TTJ --- Integration of [1-J0(t)]/t from 0 to x C TTY --- Integration of Y0(t)/t from x to ∞ C ========================================================= C IMPLICIT DOUBLE PRECISION (A-H,O-Z) PI=3.141592653589793D0 EL=.5772156649015329D0 IF (X.EQ.0.0D0) THEN TTJ=0.0D0 TTY=-1.0D+300 ELSE IF (X.LE.20.0D0) THEN TTJ=1.0D0 R=1.0D0 DO 10 K=2,100 R=-.25D0*R*(K-1.0D0)/(K*K*K)*X*X TTJ=TTJ+R IF (DABS(R).LT.DABS(TTJ)*1.0D-12) GO TO 15 10 CONTINUE 15 TTJ=TTJ*.125D0*X*X E0=.5D0*(PI*PI/6.0D0-EL*EL)-(.5D0*DLOG(X/2.0D0)+EL) & *DLOG(X/2.0D0) B1=EL+DLOG(X/2.0D0)-1.5D0 RS=1.0D0 R=-1.0D0 DO 20 K=2,100 R=-.25D0*R*(K-1.0D0)/(K*K*K)*X*X RS=RS+1.0D0/K R2=R*(RS+1.0D0/(2.0D0*K)-(EL+DLOG(X/2.0D0))) B1=B1+R2 IF (DABS(R2).LT.DABS(B1)*1.0D-12) GO TO 25 20 CONTINUE 25 TTY=2.0D0/PI*(E0+.125D0*X*X*B1) ELSE A0=DSQRT(2.0D0/(PI*X)) BJ0=0.0D0 BY0=0.0D0 BJ1=0.0D0 DO 50 L=0,1 VT=4.0D0*L*L PX=1.0D0 R=1.0D0 DO 30 K=1,14 R=-.0078125D0*R*(VT-(4.0D0*K-3.0D0)**2) & /(X*K)*(VT-(4.0D0*K-1.0D0)**2) & /((2.0D0*K-1.0D0)*X) PX=PX+R IF (DABS(R).LT.DABS(PX)*1.0D-12) GO TO 35 30 CONTINUE 35 QX=1.0D0 R=1.0D0 DO 40 K=1,14 R=-.0078125D0*R*(VT-(4.0D0*K-1.0D0)**2) & /(X*K)*(VT-(4.0D0*K+1.0D0)**2) & /(2.0D0*K+1.0D0)/X QX=QX+R IF (DABS(R).LT.DABS(QX)*1.0D-12) GO TO 45 40 CONTINUE 45 QX=.125D0*(VT-1.0D0)/X*QX XK=X-(.25D0+.5D0*L)*PI BJ1=A0*(PX*DCOS(XK)-QX*DSIN(XK)) BY1=A0*(PX*DSIN(XK)+QX*DCOS(XK)) IF (L.EQ.0) THEN BJ0=BJ1 BY0=BY1 ENDIF 50 CONTINUE T=2.0D0/X G0=1.0D0 R0=1.0D0 DO 55 K=1,10 R0=-K*K*T*T*R0 55 G0=G0+R0 G1=1.0D0 R1=1.0D0 DO 60 K=1,10 R1=-K*(K+1.0D0)*T*T*R1 60 G1=G1+R1 TTJ=2.0D0*G1*BJ0/(X*X)-G0*BJ1/X+EL+DLOG(X/2.0D0) TTY=2.0D0*G1*BY0/(X*X)-G0*BY1/X ENDIF RETURN END C ********************************** SUBROUTINE CJYLV(V,Z,CBJV,CDJV,CBYV,CDYV) C C =================================================== C Purpose: Compute Bessel functions Jv(z) and Yv(z) C and their derivatives with a complex C argument and a large order C Input: v --- Order of Jv(z) and Yv(z) C z --- Complex argument C Output: CBJV --- Jv(z) C CDJV --- Jv'(z) C CBYV --- Yv(z) C CDYV --- Yv'(z) C Routine called: C CJK to compute the expansion coefficients C =================================================== C IMPLICIT DOUBLE PRECISION (A,B,D-H,O-Y) IMPLICIT COMPLEX*16 (C,Z) DIMENSION CF(12),A(91) KM=12 CALL CJK(KM,A) PI=3.141592653589793D0 DO 30 L=1,0,-1 V0=V-L CWS=SQRT(1.0D0-(Z/V0)*(Z/V0)) CETA=CWS+LOG(Z/V0/(1.0D0+CWS)) CT=1.0D0/CWS CT2=CT*CT DO 15 K=1,KM L0=K*(K+1)/2+1 LF=L0+K CF(K)=A(LF) DO 10 I=LF-1,L0,-1 10 CF(K)=CF(K)*CT2+A(I) 15 CF(K)=CF(K)*CT**K VR=1.0D0/V0 CSJ=(1.0D0,0.0D0) DO 20 K=1,KM 20 CSJ=CSJ+CF(K)*VR**K CBJV=SQRT(CT/(2.0D0*PI*V0))*EXP(V0*CETA)*CSJ IF (L.EQ.1) CFJ=CBJV CSY=(1.0D0,0.0D0) DO 25 K=1,KM 25 CSY=CSY+(-1)**K*CF(K)*VR**K CBYV=-SQRT(2.0D0*CT/(PI*V0))*EXP(-V0*CETA)*CSY IF (L.EQ.1) CFY=CBYV 30 CONTINUE CDJV=-V/Z*CBJV+CFJ CDYV=-V/Z*CBYV+CFY RETURN END C ********************************** SUBROUTINE RMN2L(M,N,C,X,DF,KD,R2F,R2D,ID) C C ======================================================== C Purpose: Compute prolate and oblate spheroidal radial C functions of the second kind for given m, n, C c and a large cx C Routine called: C SPHY for computing the spherical Bessel C functions of the second kind C ======================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION DF(200),SY(0:251),DY(0:251) EPS=1.0D-14 IP=1 NM1=INT((N-M)/2) IF (N-M.EQ.2*NM1) IP=0 NM=25+NM1+INT(C) REG=1.0D0 IF (M+NM.GT.80) REG=1.0D-200 NM2=2*NM+M CX=C*X CALL SPHY(NM2,CX,NM2,SY,DY) R0=REG DO 10 J=1,2*M+IP 10 R0=R0*J R=R0 SUC=R*DF(1) SW=0.0D0 DO 15 K=2,NM R=R*(M+K-1.0)*(M+K+IP-1.5D0)/(K-1.0D0)/(K+IP-1.5D0) SUC=SUC+R*DF(K) IF (K.GT.NM1.AND.DABS(SUC-SW).LT.DABS(SUC)*EPS) GO TO 20 15 SW=SUC 20 A0=(1.0D0-KD/(X*X))**(0.5D0*M)/SUC R2F=0.0D0 EPS1=0.0D0 NP=0 DO 50 K=1,NM L=2*K+M-N-2+IP LG=1 IF (L.NE.4*INT(L/4)) LG=-1 IF (K.EQ.1) THEN R=R0 ELSE R=R*(M+K-1.0)*(M+K+IP-1.5D0)/(K-1.0D0)/(K+IP-1.5D0) ENDIF NP=M+2*K-2+IP R2F=R2F+LG*R*(DF(K)*SY(NP)) EPS1=DABS(R2F-SW) IF (K.GT.NM1.AND.EPS1.LT.DABS(R2F)*EPS) GO TO 55 50 SW=R2F 55 ID1=INT(LOG10(EPS1/DABS(R2F)+EPS)) R2F=R2F*A0 IF (NP.GE.NM2) THEN ID=10 RETURN ENDIF B0=KD*M/X**3.0D0/(1.0-KD/(X*X))*R2F SUD=0.0D0 EPS2=0.0D0 DO 60 K=1,NM L=2*K+M-N-2+IP LG=1 IF (L.NE.4*INT(L/4)) LG=-1 IF (K.EQ.1) THEN R=R0 ELSE R=R*(M+K-1.0)*(M+K+IP-1.5D0)/(K-1.0D0)/(K+IP-1.5D0) ENDIF NP=M+2*K-2+IP SUD=SUD+LG*R*(DF(K)*DY(NP)) EPS2=DABS(SUD-SW) IF (K.GT.NM1.AND.EPS2.LT.DABS(SUD)*EPS) GO TO 65 60 SW=SUD 65 R2D=B0+A0*C*SUD ID2=INT(LOG10(EPS2/DABS(SUD)+EPS)) ID=MAX(ID1,ID2) RETURN END C ********************************** SUBROUTINE PSI_SPEC(X,PS) C C ====================================== C Purpose: Compute Psi function C Input : x --- Argument of psi(x) C Output: PS --- psi(x) C ====================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) XA=DABS(X) PI=3.141592653589793D0 EL=.5772156649015329D0 S=0.0D0 IF (X.EQ.INT(X).AND.X.LE.0.0) THEN PS=1.0D+300 RETURN ELSE IF (XA.EQ.INT(XA)) THEN N=XA DO 10 K=1 ,N-1 10 S=S+1.0D0/K PS=-EL+S ELSE IF (XA+.5.EQ.INT(XA+.5)) THEN N=XA-.5 DO 20 K=1,N 20 S=S+1.0/(2.0D0*K-1.0D0) PS=-EL+2.0D0*S-1.386294361119891D0 ELSE IF (XA.LT.10.0) THEN N=10-INT(XA) DO 30 K=0,N-1 30 S=S+1.0D0/(XA+K) XA=XA+N ENDIF X2=1.0D0/(XA*XA) A1=-.8333333333333D-01 A2=.83333333333333333D-02 A3=-.39682539682539683D-02 A4=.41666666666666667D-02 A5=-.75757575757575758D-02 A6=.21092796092796093D-01 A7=-.83333333333333333D-01 A8=.4432598039215686D0 PS=DLOG(XA)-.5D0/XA+X2*(((((((A8*X2+A7)*X2+ & A6)*X2+A5)*X2+A4)*X2+A3)*X2+A2)*X2+A1) PS=PS-S ENDIF IF (X.LT.0.0) PS=PS-PI*DCOS(PI*X)/DSIN(PI*X)-1.0D0/X RETURN END C ********************************** SUBROUTINE CVA2(KD,M,Q,A) C C ====================================================== C Purpose: Calculate a specific characteristic value of C Mathieu functions C Input : m --- Order of Mathieu functions C q --- Parameter of Mathieu functions C KD --- Case code C KD=1 for cem(x,q) ( m = 0,2,4,...) C KD=2 for cem(x,q) ( m = 1,3,5,...) C KD=3 for sem(x,q) ( m = 1,3,5,...) C KD=4 for sem(x,q) ( m = 2,4,6,...) C Output: A --- Characteristic value C Routines called: C (1) REFINE for finding accurate characteristic C value using an iteration method C (2) CV0 for finding initial characteristic C values using polynomial approximation C (3) CVQM for computing initial characteristic C values for q ≤ 3*m C (3) CVQL for computing initial characteristic C values for q ≥ m*m C ====================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) IF (M.LE.12.OR.Q.LE.3.0*M.OR.Q.GT.M*M) THEN CALL CV0(KD,M,Q,A) IF (Q.NE.0.0D0.AND.M.NE.2) CALL REFINE(KD,M,Q,A) IF (Q.GT.2.0D-3.AND.M.EQ.2) CALL REFINE(KD,M,Q,A) ELSE NDIV=10 DELTA=(M-3.0)*M/NDIV IF ((Q-3.0*M).LE.(M*M-Q)) THEN 5 NN=INT((Q-3.0*M)/DELTA)+1 DELTA=(Q-3.0*M)/NN Q1=2.0*M CALL CVQM(M,Q1,A1) Q2=3.0*M CALL CVQM(M,Q2,A2) QQ=3.0*M DO 10 I=1,NN QQ=QQ+DELTA A=(A1*Q2-A2*Q1+(A2-A1)*QQ)/(Q2-Q1) IFLAG=1 IF (I.EQ.NN) IFLAG=-1 CALL REFINE(KD,M,QQ,A) Q1=Q2 Q2=QQ A1=A2 A2=A 10 CONTINUE IF (IFLAG.EQ.-10) THEN NDIV=NDIV*2 DELTA=(M-3.0)*M/NDIV GO TO 5 ENDIF ELSE 15 NN=INT((M*M-Q)/DELTA)+1 DELTA=(M*M-Q)/NN Q1=M*(M-1.0) CALL CVQL(KD,M,Q1,A1) Q2=M*M CALL CVQL(KD,M,Q2,A2) QQ=M*M DO 20 I=1,NN QQ=QQ-DELTA A=(A1*Q2-A2*Q1+(A2-A1)*QQ)/(Q2-Q1) IFLAG=1 IF (I.EQ.NN) IFLAG=-1 CALL REFINE(KD,M,QQ,A) Q1=Q2 Q2=QQ A1=A2 A2=A 20 CONTINUE IF (IFLAG.EQ.-10) THEN NDIV=NDIV*2 DELTA=(M-3.0)*M/NDIV GO TO 15 ENDIF ENDIF ENDIF RETURN END C ********************************** SUBROUTINE LPMNS(M,N,X,PM,PD) C C ======================================================== C Purpose: Compute associated Legendre functions Pmn(x) C and Pmn'(x) for a given order C Input : x --- Argument of Pmn(x) C m --- Order of Pmn(x), m = 0,1,2,...,n C n --- Degree of Pmn(x), n = 0,1,2,...,N C Output: PM(n) --- Pmn(x) C PD(n) --- Pmn'(x) C ======================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION PM(0:N),PD(0:N) DO 10 K=0,N PM(K)=0.0D0 10 PD(K)=0.0D0 IF (DABS(X).EQ.1.0D0) THEN DO 15 K=0,N IF (M.EQ.0) THEN PM(K)=1.0D0 PD(K)=0.5D0*K*(K+1.0) IF (X.LT.0.0) THEN PM(K)=(-1)**K*PM(K) PD(K)=(-1)**(K+1)*PD(K) ENDIF ELSE IF (M.EQ.1) THEN PD(K)=1.0D+300 ELSE IF (M.EQ.2) THEN PD(K)=-0.25D0*(K+2.0)*(K+1.0)*K*(K-1.0) IF (X.LT.0.0) PD(K)=(-1)**(K+1)*PD(K) ENDIF 15 CONTINUE RETURN ENDIF X0=DABS(1.0D0-X*X) PM0=1.0D0 PMK=PM0 DO 20 K=1,M PMK=(2.0D0*K-1.0D0)*DSQRT(X0)*PM0 20 PM0=PMK PM1=(2.0D0*M+1.0D0)*X*PM0 PM(M)=PMK PM(M+1)=PM1 DO 25 K=M+2,N PM2=((2.0D0*K-1.0D0)*X*PM1-(K+M-1.0D0)*PMK)/(K-M) PM(K)=PM2 PMK=PM1 25 PM1=PM2 PD(0)=((1.0D0-M)*PM(1)-X*PM(0))/(X*X-1.0) DO 30 K=1,N 30 PD(K)=(K*X*PM(K)-(K+M)*PM(K-1))/(X*X-1.0D0) DO 35 K=1,N PM(K)=(-1)**M*PM(K) 35 PD(K)=(-1)**M*PD(K) RETURN END C ********************************** SUBROUTINE CERF(Z,CER,CDER) C C ========================================================== C Purpose: Compute complex Error function erf(z) & erf'(z) C Input: z --- Complex argument of erf(z) C x --- Real part of z C y --- Imaginary part of z C Output: CER --- erf(z) C CDER --- erf'(z) C ========================================================== IMPLICIT DOUBLE PRECISION (A-H,O-Z) COMPLEX *16 Z,CER,CDER EPS=1.0D-12 PI=3.141592653589793D0 X=DBLE(Z) Y=DIMAG(Z) X2=X*X IF (X.LE.3.5D0) THEN ER=1.0D0 R=1.0D0 W=0.0D0 DO 10 K=1,100 R=R*X2/(K+0.5D0) ER=ER+R IF (DABS(ER-W).LE.EPS*DABS(ER)) GO TO 15 10 W=ER 15 C0=2.0D0/DSQRT(PI)*X*EXP(-X2) ER0=C0*ER ELSE ER=1.0D0 R=1.0D0 DO 20 K=1,12 R=-R*(K-0.5D0)/X2 20 ER=ER+R C0=EXP(-X2)/(X*DSQRT(PI)) ER0=1.0D0-C0*ER ENDIF IF (Y.EQ.0.0D0) THEN ERR=ER0 ERI=0.0D0 ELSE CS=DCOS(2.0D0*X*Y) SS=DSIN(2.0D0*X*Y) ER1=EXP(-X2)*(1.0D0-CS)/(2.0D0*PI*X) EI1=EXP(-X2)*SS/(2.0D0*PI*X) ER2=0.0D0 W1=0.0D0 DO 25 N=1,100 ER2=ER2+EXP(-.25D0*N*N)/(N*N+4.0D0*X2)*(2.0D0*X & -2.0D0*X*DCOSH(N*Y)*CS+N*DSINH(N*Y)*SS) IF (DABS((ER2-W1)/ER2).LT.EPS) GO TO 30 25 W1=ER2 30 C0=2.0D0*EXP(-X2)/PI ERR=ER0+ER1+C0*ER2 EI2=0.0D0 W2=0.0D0 DO 35 N=1,100 EI2=EI2+EXP(-.25D0*N*N)/(N*N+4.0D0*X2)*(2.0D0*X & *DCOSH(N*Y)*SS+N*DSINH(N*Y)*CS) IF (DABS((EI2-W2)/EI2).LT.EPS) GO TO 40 35 W2=EI2 40 ERI=EI1+C0*EI2 ENDIF CER = DCMPLX(ERR, ERI) CDER=2.0D0/DSQRT(PI)*EXP(-Z*Z) RETURN END C ********************************** SUBROUTINE RSWFP(M,N,C,X,CV,KF,R1F,R1D,R2F,R2D) C C ============================================================== C Purpose: Compute prolate spheriodal radial functions of the C first and second kinds, and their derivatives C Input : m --- Mode parameter, m = 0,1,2,... C n --- Mode parameter, n = m,m+1,m+2,... C c --- Spheroidal parameter C x --- Argument of radial function ( x > 1.0 ) C cv --- Characteristic value C KF --- Function code C KF=1 for the first kind C KF=2 for the second kind C KF=3 for both the first and second kinds C Output: R1F --- Radial function of the first kind C R1D --- Derivative of the radial function of C the first kind C R2F --- Radial function of the second kind C R2D --- Derivative of the radial function of C the second kind C Routines called: C (1) SDMN for computing expansion coefficients dk C (2) RMN1 for computing prolate and oblate radial C functions of the first kind C (3) RMN2L for computing prolate and oblate radial C functions of the second kind for a large argument C (4) RMN2SP for computing the prolate radial function C of the second kind for a small argument C ============================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION DF(200) KD=1 CALL SDMN(M,N,C,CV,KD,DF) IF (KF.NE.2) THEN CALL RMN1(M,N,C,X,DF,KD,R1F,R1D) ENDIF IF (KF.GT.1) THEN CALL RMN2L(M,N,C,X,DF,KD,R2F,R2D,ID) IF (ID.GT.-8) THEN CALL RMN2SP(M,N,C,X,CV,DF,KD,R2F,R2D) ENDIF ENDIF RETURN END C ********************************** SUBROUTINE JYNDD(N,X,BJN,DJN,FJN,BYN,DYN,FYN) C C =========================================================== C Purpose: Compute Bessel functions Jn(x) and Yn(x), and C their first and second derivatives C Input: x --- Argument of Jn(x) and Yn(x) ( x > 0 ) C n --- Order of Jn(x) and Yn(x) C Output: BJN --- Jn(x) C DJN --- Jn'(x) C FJN --- Jn"(x) C BYN --- Yn(x) C DYN --- Yn'(x) C FYN --- Yn"(x) C Routines called: C JYNBH to compute Jn and Yn C =========================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION BJ(2),BY(2) CALL JYNBH(N+1,N,X,NM,BJ,BY) C Compute derivatives by differentiation formulas BJN=BJ(1) BYN=BY(1) DJN=-BJ(2)+N*BJ(1)/X DYN=-BY(2)+N*BY(1)/X FJN=(N*N/(X*X)-1.0D0)*BJN-DJN/X FYN=(N*N/(X*X)-1.0D0)*BYN-DYN/X RETURN END C ********************************** SUBROUTINE GAM0 (X,GA) C C ================================================ C Purpose: Compute gamma function Г(x) C Input : x --- Argument of Г(x) ( |x| ≤ 1 ) C Output: GA --- Г(x) C ================================================ C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION G(25) DATA G/1.0D0,0.5772156649015329D0, & -0.6558780715202538D0, -0.420026350340952D-1, & 0.1665386113822915D0, -.421977345555443D-1, & -.96219715278770D-2, .72189432466630D-2, & -.11651675918591D-2, -.2152416741149D-3, & .1280502823882D-3, -.201348547807D-4, & -.12504934821D-5, .11330272320D-5, & -.2056338417D-6, .61160950D-8, & .50020075D-8, -.11812746D-8, & .1043427D-9, .77823D-11, & -.36968D-11, .51D-12, & -.206D-13, -.54D-14, .14D-14/ GR=(25) DO 20 K=24,1,-1 20 GR=GR*X+G(K) GA=1.0D0/(GR*X) RETURN END C ********************************** SUBROUTINE CISIB(X,CI,SI) C C ============================================= C Purpose: Compute cosine and sine integrals C Si(x) and Ci(x) ( x ≥ 0 ) C Input : x --- Argument of Ci(x) and Si(x) C Output: CI --- Ci(x) C SI --- Si(x) C ============================================= C IMPLICIT DOUBLE PRECISION (A-H,O-Z) X2=X*X IF (X.EQ.0.0) THEN CI=-1.0D+300 SI=0.0D0 ELSE IF (X.LE.1.0D0) THEN CI=((((-3.0D-8*X2+3.10D-6)*X2-2.3148D-4) & *X2+1.041667D-2)*X2-0.25)*X2+0.577215665D0+LOG(X) SI=((((3.1D-7*X2-2.834D-5)*X2+1.66667D-003) & *X2-5.555556D-002)*X2+1.0)*X ELSE FX=((((X2+38.027264D0)*X2+265.187033D0)*X2 & +335.67732D0)*X2+38.102495D0)/((((X2 & +40.021433D0)*X2+322.624911D0)*X2 & +570.23628D0)*X2+157.105423D0) GX=((((X2+42.242855D0)*X2+302.757865D0)*X2 & +352.018498D0)*X2+21.821899D0)/((((X2 & +48.196927D0)*X2+482.485984D0)*X2 & +1114.978885D0)*X2+449.690326D0)/X CI=FX*SIN(X)/X-GX*COS(X)/X SI=1.570796327D0-FX*COS(X)/X-GX*SIN(X)/X ENDIF RETURN END C ********************************** SUBROUTINE EULERA(N,EN) C C ====================================== C Purpose: Compute Euler number En C Input : n --- Serial number C Output: EN(n) --- En C ====================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION EN(0:N) EN(0)=1.0D0 DO 30 M=1,N/2 S=1.0D0 DO 20 K=1,M-1 R=1.0D0 DO 10 J=1,2*K 10 R=R*(2.0D0*M-2.0D0*K+J)/J 20 S=S+R*EN(2*K) 30 EN(2*M)=-S RETURN END C ********************************** SUBROUTINE REFINE(KD,M,Q,A) C C ===================================================== C Purpose: calculate the accurate characteristic value C by the secant method C Input : m --- Order of Mathieu functions C q --- Parameter of Mathieu functions C A --- Initial characteristic value C Output: A --- Refineed characteristic value C Routine called: CVF for computing the value of F for C characteristic equation C ======================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) EPS=1.0D-14 MJ=10+M CA=A DELTA=0.0D0 X0=A CALL CVF(KD,M,Q,X0,MJ,F0) X1=1.002*A CALL CVF(KD,M,Q,X1,MJ,F1) DO 10 IT=1,100 MJ=MJ+1 X=X1-(X1-X0)/(1.0D0-F0/F1) CALL CVF(KD,M,Q,X,MJ,F) IF (ABS(1.0-X1/X).LT.EPS.OR.F.EQ.0.0) GO TO 15 X0=X1 F0=F1 X1=X 10 F1=F 15 A=X RETURN END C ********************************** SUBROUTINE CISIA(X,CI,SI) C C ============================================= C Purpose: Compute cosine and sine integrals C Si(x) and Ci(x) ( x ≥ 0 ) C Input : x --- Argument of Ci(x) and Si(x) C Output: CI --- Ci(x) C SI --- Si(x) C ============================================= C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION BJ(101) P2=1.570796326794897D0 EL=.5772156649015329D0 EPS=1.0D-15 X2=X*X IF (X.EQ.0.0D0) THEN CI=-1.0D+300 SI=0.0D0 ELSE IF (X.LE.16.0D0) THEN XR=-.25D0*X2 CI=EL+DLOG(X)+XR DO 10 K=2,40 XR=-.5D0*XR*(K-1)/(K*K*(2*K-1))*X2 CI=CI+XR IF (DABS(XR).LT.DABS(CI)*EPS) GO TO 15 10 CONTINUE 15 XR=X SI=X DO 20 K=1,40 XR=-.5D0*XR*(2*K-1)/K/(4*K*K+4*K+1)*X2 SI=SI+XR IF (DABS(XR).LT.DABS(SI)*EPS) RETURN 20 CONTINUE ELSE IF (X.LE.32.0D0) THEN M=INT(47.2+.82*X) XA1=0.0D0 XA0=1.0D-100 DO 25 K=M,1,-1 XA=4.0D0*K*XA0/X-XA1 BJ(K)=XA XA1=XA0 25 XA0=XA XS=BJ(1) DO 30 K=3,M,2 30 XS=XS+2.0D0*BJ(K) BJ(1)=BJ(1)/XS DO 35 K=2,M 35 BJ(K)=BJ(K)/XS XR=1.0D0 XG1=BJ(1) DO 40 K=2,M XR=.25D0*XR*(2.0*K-3.0)**2/((K-1.0)*(2.0*K-1.0)**2)*X 40 XG1=XG1+BJ(K)*XR XR=1.0D0 XG2=BJ(1) DO 45 K=2,M XR=.25D0*XR*(2.0*K-5.0)**2/((K-1.0)*(2.0*K-3.0)**2)*X 45 XG2=XG2+BJ(K)*XR XCS=DCOS(X/2.0D0) XSS=DSIN(X/2.0D0) CI=EL+DLOG(X)-X*XSS*XG1+2*XCS*XG2-2*XCS*XCS SI=X*XCS*XG1+2*XSS*XG2-DSIN(X) ELSE XR=1.0D0 XF=1.0D0 DO 50 K=1,9 XR=-2.0D0*XR*K*(2*K-1)/X2 50 XF=XF+XR XR=1.0D0/X XG=XR DO 55 K=1,8 XR=-2.0D0*XR*(2*K+1)*K/X2 55 XG=XG+XR CI=XF*DSIN(X)/X-XG*DCOS(X)/X SI=P2-XF*DCOS(X)/X-XG*DSIN(X)/X ENDIF RETURN END C ********************************** SUBROUTINE ITSL0(X,TL0) C C =========================================================== C Purpose: Evaluate the integral of modified Struve function C L0(t) with respect to t from 0 to x C Input : x --- Upper limit ( x ≥ 0 ) C Output: TL0 --- Integration of L0(t) from 0 to x C =========================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION A(18) PI=3.141592653589793D0 R=1.0D0 IF (X.LE.20.0) THEN S=0.5D0 DO 10 K=1,100 RD=1.0D0 IF (K.EQ.1) RD=0.5D0 R=R*RD*K/(K+1.0D0)*(X/(2.0D0*K+1.0D0))**2 S=S+R IF (DABS(R/S).LT.1.0D-12) GO TO 15 10 CONTINUE 15 TL0=2.0D0/PI*X*X*S ELSE S=1.0D0 DO 20 K=1,10 R=R*K/(K+1.0D0)*((2.0D0*K+1.0D0)/X)**2 S=S+R IF (DABS(R/S).LT.1.0D-12) GO TO 25 20 CONTINUE 25 EL=.57721566490153D0 S0=-S/(PI*X*X)+2.0D0/PI*(DLOG(2.0D0*X)+EL) A0=1.0D0 A1=5.0D0/8.0D0 A(1)=A1 DO 30 K=1,10 AF=((1.5D0*(K+.50D0)*(K+5.0D0/6.0D0)*A1-.5D0* & (K+.5D0)**2*(K-.5D0)*A0))/(K+1.0D0) A(K+1)=AF A0=A1 30 A1=AF TI=1.0D0 R=1.0D0 DO 35 K=1,11 R=R/X 35 TI=TI+A(K)*R TL0=TI/DSQRT(2*PI*X)*EXP(X)+S0 ENDIF RETURN END C ********************************** SUBROUTINE CLQN(N,X,Y,CQN,CQD) C C ================================================== C Purpose: Compute the Legendre functions Qn(z) and C their derivatives Qn'(z) for a complex C argument C Input : x --- Real part of z C y --- Imaginary part of z C n --- Degree of Qn(z), n = 0,1,2,... C Output: CQN(n) --- Qn(z) C CQD(n) --- Qn'(z) C ================================================== C IMPLICIT DOUBLE PRECISION (X,Y) IMPLICIT COMPLEX*16 (C,Z) DIMENSION CQN(0:N),CQD(0:N) Z = DCMPLX(X, Y) IF (Z.EQ.1.0D0) THEN DO 10 K=0,N CQN(K)=(1.0D+300,0.0D0) 10 CQD(K)=(1.0D+300,0.0D0) RETURN ENDIF LS=1 IF (ABS(Z).GT.1.0D0) LS=-1 CQ0=0.5D0*LOG(LS*(1.0D0+Z)/(1.0D0-Z)) CQ1=Z*CQ0-1.0D0 CQN(0)=CQ0 CQN(1)=CQ1 IF (ABS(Z).LT.1.0001D0) THEN CQF0=CQ0 CQF1=CQ1 DO 15 K=2,N CQF2=((2.0D0*K-1.0D0)*Z*CQF1-(K-1.0D0)*CQF0)/K CQN(K)=CQF2 CQF0=CQF1 15 CQF1=CQF2 ELSE IF (ABS(Z).GT.1.1D0) THEN KM=40+N ELSE KM=(40+N)*INT(-1.0-1.8*LOG(ABS(Z-1.0))) ENDIF CQF2=0.0D0 CQF1=1.0D0 DO 20 K=KM,0,-1 CQF0=((2*K+3.0D0)*Z*CQF1-(K+2.0D0)*CQF2)/(K+1.0D0) IF (K.LE.N) CQN(K)=CQF0 CQF2=CQF1 20 CQF1=CQF0 DO 25 K=0,N 25 CQN(K)=CQN(K)*CQ0/CQF0 ENDIF CQD(0)=(CQN(1)-Z*CQN(0))/(Z*Z-1.0D0) DO 30 K=1,N 30 CQD(K)=(K*Z*CQN(K)-K*CQN(K-1))/(Z*Z-1.0D0) RETURN END C ********************************** SUBROUTINE AIRYZO(NT,KF,XA,XB,XC,XD) C C ======================================================== C Purpose: Compute the first NT zeros of Airy functions C Ai(x) and Ai'(x), a and a', and the associated C values of Ai(a') and Ai'(a); and the first NT C zeros of Airy functions Bi(x) and Bi'(x), b and C b', and the associated values of Bi(b') and C Bi'(b) C Input : NT --- Total number of zeros C KF --- Function code C KF=1 for Ai(x) and Ai'(x) C KF=2 for Bi(x) and Bi'(x) C Output: XA(m) --- a, the m-th zero of Ai(x) or C b, the m-th zero of Bi(x) C XB(m) --- a', the m-th zero of Ai'(x) or C b', the m-th zero of Bi'(x) C XC(m) --- Ai(a') or Bi(b') C XD(m) --- Ai'(a) or Bi'(b) C ( m --- Serial number of zeros ) C Routine called: AIRYB for computing Airy functions and C their derivatives C ======================================================= C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION XA(NT),XB(NT),XC(NT),XD(NT) PI=3.141592653589793D0 RT=0.0D0 DO 15 I=1,NT RT0=0D0 IF (KF.EQ.1) THEN U=3.0D0*PI*(4.0D0*I-1)/8.0D0 U1=1/(U*U) ELSE IF (KF.EQ.2) THEN IF (I.EQ.1) THEN RT0=-1.17371D0 ELSE U=3.0D0*PI*(4.0D0*I-3.0D0)/8.0D0 U1=1/(U*U) ENDIF ENDIF IF (RT0.EQ.0) THEN C DLMF 9.9.18 RT0=-(U*U)**(1.0D0/3.0D0)*( & + 1D0 & + U1*(5D0/48D0 & + U1*(-5D0/36D0 & + U1*(77125D0/82944D0 & + U1*(-108056875D0/6967296D0))))) ENDIF 10 X=RT0 CALL AIRYB(X,AI,BI,AD,BD) IF (KF.EQ.1) RT=RT0-AI/AD IF (KF.EQ.2) RT=RT0-BI/BD ERR=DABS((RT-RT0)/RT) IF (ERR.GT.1.D-12) THEN RT0=RT GOTO 10 ELSE XA(I)=RT IF (ERR.GT.1D-14) CALL AIRYB(RT,AI,BI,AD,BD) IF (KF.EQ.1) XD(I)=AD IF (KF.EQ.2) XD(I)=BD ENDIF 15 CONTINUE DO 25 I=1,NT RT0=0D0 IF (KF.EQ.1) THEN IF (I.EQ.1) THEN RT0=-1.01879D0 ELSE U=3.0D0*PI*(4.0D0*I-3.0D0)/8.0D0 U1=1/(U*U) ENDIF ELSE IF (KF.EQ.2) THEN IF (I.EQ.1) THEN RT0=-2.29444D0 ELSE U=3.0D0*PI*(4.0D0*I-1.0D0)/8.0D0 U1=1/(U*U) ENDIF ENDIF IF (RT0.EQ.0) THEN C DLMF 9.9.19 RT0=-(U*U)**(1.0D0/3.0D0)*( & + 1D0 & + U1*(-7D0/48D0 & + U1*(+35D0/288D0 & + U1*(-181223D0/207360D0 & + U1*(18683371D0/1244160D0))))) END IF 20 X=RT0 CALL AIRYB(X,AI,BI,AD,BD) IF (KF.EQ.1) RT=RT0-AD/(AI*X) IF (KF.EQ.2) RT=RT0-BD/(BI*X) ERR=DABS((RT-RT0)/RT) IF (ERR.GT.1.0D-12) THEN RT0=RT GOTO 20 ELSE XB(I)=RT IF (ERR.GT.1D-14) CALL AIRYB(RT,AI,BI,AD,BD) IF (KF.EQ.1) XC(I)=AI IF (KF.EQ.2) XC(I)=BI ENDIF 25 CONTINUE RETURN END C ********************************** SUBROUTINE ERROR(X,ERR) C C ========================================= C Purpose: Compute error function erf(x) C Input: x --- Argument of erf(x) C Output: ERR --- erf(x) C ========================================= C IMPLICIT DOUBLE PRECISION (A-H,O-Z) EPS=1.0D-15 PI=3.141592653589793D0 X2=X*X IF (DABS(X).LT.3.5D0) THEN ER=1.0D0 R=1.0D0 DO 10 K=1,50 R=R*X2/(K+0.5D0) ER=ER+R IF (DABS(R).LE.DABS(ER)*EPS) GO TO 15 10 CONTINUE 15 C0=2.0D0/DSQRT(PI)*X*EXP(-X2) ERR=C0*ER ELSE ER=1.0D0 R=1.0D0 DO 20 K=1,12 R=-R*(K-0.5D0)/X2 20 ER=ER+R C0=EXP(-X2)/(DABS(X)*DSQRT(PI)) ERR=1.0D0-C0*ER IF (X.LT.0.0) ERR=-ERR ENDIF RETURN END C ********************************** SUBROUTINE CERROR(Z,CER) C C ==================================================== C Purpose: Compute error function erf(z) for a complex C argument (z=x+iy) C Input : z --- Complex argument C Output: CER --- erf(z) C ==================================================== C IMPLICIT COMPLEX *16 (C,Z) DOUBLE PRECISION A0,PI A0=ABS(Z) C0=EXP(-Z*Z) PI=3.141592653589793D0 Z1=Z IF (DBLE(Z).LT.0.0) THEN Z1=-Z ENDIF C C Cutoff radius R = 4.36; determined by balancing rounding error C and asymptotic expansion error, see below. C C The resulting maximum global accuracy expected is around 1e-8 C IF (A0.LE.4.36D0) THEN C C Rounding error in the Taylor expansion is roughly C C ~ R*R * EPSILON * R**(2 R**2) / (2 R**2 Gamma(R**2 + 1/2)) C CS=Z1 CR=Z1 DO 10 K=1,120 CR=CR*Z1*Z1/(K+0.5D0) CS=CS+CR IF (ABS(CR/CS).LT.1.0D-15) GO TO 15 10 CONTINUE 15 CER=2.0D0*C0*CS/DSQRT(PI) ELSE CL=1.0D0/Z1 CR=CL C C Asymptotic series; maximum K must be at most ~ R^2. C C The maximum accuracy obtainable from this expansion is roughly C C ~ Gamma(2R**2 + 2) / ( C (2 R**2)**(R**2 + 1/2) Gamma(R**2 + 3/2) 2**(R**2 + 1/2)) C DO 20 K=1,20 CR=-CR*(K-0.5D0)/(Z1*Z1) CL=CL+CR IF (ABS(CR/CL).LT.1.0D-15) GO TO 25 20 CONTINUE 25 CER=1.0D0-C0*CL/DSQRT(PI) ENDIF IF (DBLE(Z).LT.0.0) THEN CER=-CER ENDIF RETURN END C ********************************** SUBROUTINE EULERB(N,EN) C C ====================================== C Purpose: Compute Euler number En C Input : n --- Serial number C Output: EN(n) --- En C ====================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION EN(0:N) HPI=2.0D0/3.141592653589793D0 EN(0)=1.0D0 EN(2)=-1.0D0 R1=-4.0D0*HPI**3 DO 20 M=4,N,2 R1=-R1*(M-1)*M*HPI*HPI R2=1.0D0 ISGN=1.0D0 DO 10 K=3,1000,2 ISGN=-ISGN S=(1.0D0/K)**(M+1) R2=R2+ISGN*S IF (S.LT.1.0D-15) GOTO 20 10 CONTINUE 20 EN(M)=R1*R2 RETURN END C ********************************** SUBROUTINE CVA1(KD,M,Q,CV) C C ============================================================ C Purpose: Compute a sequence of characteristic values of C Mathieu functions C Input : M --- Maximum order of Mathieu functions C q --- Parameter of Mathieu functions C KD --- Case code C KD=1 for cem(x,q) ( m = 0,2,4,… ) C KD=2 for cem(x,q) ( m = 1,3,5,… ) C KD=3 for sem(x,q) ( m = 1,3,5,… ) C KD=4 for sem(x,q) ( m = 2,4,6,… ) C Output: CV(I) --- Characteristic values; I = 1,2,3,... C For KD=1, CV(1), CV(2), CV(3),..., correspond to C the characteristic values of cem for m = 0,2,4,... C For KD=2, CV(1), CV(2), CV(3),..., correspond to C the characteristic values of cem for m = 1,3,5,... C For KD=3, CV(1), CV(2), CV(3),..., correspond to C the characteristic values of sem for m = 1,3,5,... C For KD=4, CV(1), CV(2), CV(3),..., correspond to C the characteristic values of sem for m = 0,2,4,... C ============================================================ C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION G(200),H(200),D(500),E(500),F(500),CV(200) EPS=1.0D-14 ICM=INT(M/2)+1 IF (KD.EQ.4) ICM=M/2 IF (Q.EQ.0.0D0) THEN IF (KD.EQ.1) THEN DO 10 IC=1,ICM 10 CV(IC)=4.0D0*(IC-1.0D0)**2 ELSE IF (KD.NE.4) THEN DO 15 IC=1,ICM 15 CV(IC)=(2.0D0*IC-1.0D0)**2 ELSE DO 20 IC=1,ICM 20 CV(IC)=4.0D0*IC*IC ENDIF ELSE NM=INT(10+1.5*M+0.5*Q) E(1)=0.0D0 F(1)=0.0D0 IF (KD.EQ.1) THEN D(1)=0.0D0 DO 25 I=2,NM D(I)=4.0D0*(I-1.0D0)**2 E(I)=Q 25 F(I)=Q*Q E(2)=DSQRT(2.0D0)*Q F(2)=2.0D0*Q*Q ELSE IF (KD.NE.4) THEN D(1)=1.0D0+(-1)**KD*Q DO 30 I=2,NM D(I)=(2.0D0*I-1.0D0)**2 E(I)=Q 30 F(I)=Q*Q ELSE D(1)=4.0D0 DO 35 I=2,NM D(I)=4.0D0*I*I E(I)=Q 35 F(I)=Q*Q ENDIF XA=D(NM)+DABS(E(NM)) XB=D(NM)-DABS(E(NM)) NM1=NM-1 DO 40 I=1,NM1 T=DABS(E(I))+DABS(E(I+1)) T1=D(I)+T IF (XA.LT.T1) XA=T1 T1=D(I)-T IF (T1.LT.XB) XB=T1 40 CONTINUE DO 45 I=1,ICM G(I)=XA 45 H(I)=XB DO 75 K=1,ICM DO 50 K1=K,ICM IF (G(K1).LT.G(K)) THEN G(K)=G(K1) GO TO 55 ENDIF 50 CONTINUE 55 IF (K.NE.1.AND.H(K).LT.H(K-1)) H(K)=H(K-1) 60 X1=(G(K)+H(K))/2.0D0 CV(K)=X1 IF (DABS((G(K)-H(K))/X1).LT.EPS) GO TO 70 J=0 S=1.0D0 DO 65 I=1,NM IF (S.EQ.0.0D0) S=S+1.0D-30 T=F(I)/S S=D(I)-T-X1 IF (S.LT.0.0) J=J+1 65 CONTINUE IF (J.LT.K) THEN H(K)=X1 ELSE G(K)=X1 IF (J.GE.ICM) THEN G(ICM)=X1 ELSE IF (H(J+1).LT.X1) H(J+1)=X1 IF (X1.LT.G(J)) G(J)=X1 ENDIF ENDIF GO TO 60 70 CV(K)=X1 75 CONTINUE ENDIF RETURN END C ********************************** SUBROUTINE ITTIKB(X,TTI,TTK) C C ========================================================= C Purpose: Integrate [I0(t)-1]/t with respect to t from 0 C to x, and K0(t)/t with respect to t from x to ∞ C Input : x --- Variable in the limits ( x ≥ 0 ) C Output: TTI --- Integration of [I0(t)-1]/t from 0 to x C TTK --- Integration of K0(t)/t from x to ∞ C ========================================================= C IMPLICIT DOUBLE PRECISION (A-H,O-Z) PI=3.141592653589793D0 EL=.5772156649015329D0 IF (X.EQ.0.0D0) THEN TTI=0.0D0 ELSE IF (X.LE.5.0D0) THEN X1=X/5.0D0 T=X1*X1 TTI=(((((((.1263D-3*T+.96442D-3)*T+.968217D-2)*T & +.06615507D0)*T+.33116853D0)*T+1.13027241D0) & *T+2.44140746D0)*T+3.12499991D0)*T ELSE T=5.0D0/X TTI=(((((((((2.1945464D0*T-3.5195009D0)*T & -11.9094395D0)*T+40.394734D0)*T-48.0524115D0) & *T+28.1221478D0)*T-8.6556013D0)*T+1.4780044D0) & *T-.0493843D0)*T+.1332055D0)*T+.3989314D0 TTI=TTI*EXP(X)/(DSQRT(X)*X) ENDIF IF (X.EQ.0.0D0) THEN TTK=1.0D+300 ELSE IF (X.LE.2.0D0) THEN T1=X/2.0D0 T=T1*T1 TTK=(((((.77D-6*T+.1544D-4)*T+.48077D-3)*T & +.925821D-2)*T+.10937537D0)*T+.74999993D0)*T E0=EL+DLOG(X/2.0D0) TTK=PI*PI/24.0D0+E0*(.5D0*E0+TTI)-TTK ELSE IF (X.LE.4.0D0) THEN T=2.0D0/X TTK=(((.06084D0*T-.280367D0)*T+.590944D0)*T & -.850013D0)*T+1.234684D0 TTK=TTK*EXP(-X)/(DSQRT(X)*X) ELSE T=4.0D0/X TTK=(((((.02724D0*T-.1110396D0)*T+.2060126D0)*T & -.2621446D0)*T+.3219184D0)*T-.5091339D0)*T & +1.2533141D0 TTK=TTK*EXP(-X)/(DSQRT(X)*X) ENDIF RETURN END C ********************************** SUBROUTINE LQNB(N,X,QN,QD) C C ==================================================== C Purpose: Compute Legendre functions Qn(x) & Qn'(x) C Input : x --- Argument of Qn(x) C n --- Degree of Qn(x) ( n = 0,1,2,…) C Output: QN(n) --- Qn(x) C QD(n) --- Qn'(x) C ==================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION QN(0:N),QD(0:N) EPS=1.0D-14 IF (DABS(X).EQ.1.0D0) THEN DO 10 K=0,N QN(K)=1.0D+300 10 QD(K)=1.0D+300 RETURN ENDIF IF (X.LE.1.021D0) THEN X2=DABS((1.0D0+X)/(1.0D0-X)) Q0=0.5D0*DLOG(X2) Q1=X*Q0-1.0D0 QN(0)=Q0 QN(1)=Q1 QD(0)=1.0D0/(1.0D0-X*X) QD(1)=QN(0)+X*QD(0) DO 15 K=2,N QF=((2.0D0*K-1.0D0)*X*Q1-(K-1.0D0)*Q0)/K QN(K)=QF QD(K)=(QN(K-1)-X*QF)*K/(1.0D0-X*X) Q0=Q1 15 Q1=QF ELSE QC1=0.0D0 QC2=1.0D0/X DO 20 J=1,N QC2=QC2*J/((2.0*J+1.0D0)*X) IF (J.EQ.N-1) QC1=QC2 20 CONTINUE DO 35 L=0,1 NL=N+L QF=1.0D0 QR=1.0D0 DO 25 K=1,500 QR=QR*(0.5D0*NL+K-1.0D0)*(0.5D0*(NL-1)+K) & /((NL+K-0.5D0)*K*X*X) QF=QF+QR IF (DABS(QR/QF).LT.EPS) GO TO 30 25 CONTINUE 30 IF (L.EQ.0) THEN QN(N-1)=QF*QC1 ELSE QN(N)=QF*QC2 ENDIF 35 CONTINUE QF2=QN(N) QF1=QN(N-1) DO 40 K=N,2,-1 QF0=((2*K-1.0D0)*X*QF1-K*QF2)/(K-1.0D0) QN(K-2)=QF0 QF2=QF1 40 QF1=QF0 QD(0)=1.0D0/(1.0D0-X*X) DO 45 K=1,N 45 QD(K)=K*(QN(K-1)-X*QN(K))/(1.0D0-X*X) ENDIF RETURN END C ********************************** SUBROUTINE CJK(KM,A) C C ======================================================== C Purpose: Compute the expansion coefficients for the C asymptotic expansion of Bessel functions C with large orders C Input : Km --- Maximum k C Output: A(L) --- Cj(k) where j and k are related to L C by L=j+1+[k*(k+1)]/2; j,k=0,1,...,Km C ======================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION A(*) A(1)=1.0D0 F0=1.0D0 G0=1.0D0 DO 10 K=0,KM-1 L1=(K+1)*(K+2)/2+1 L2=(K+1)*(K+2)/2+K+2 F=(0.5D0*K+0.125D0/(K+1))*F0 G=-(1.5D0*K+0.625D0/(3.0*(K+1.0D0)))*G0 A(L1)=F A(L2)=G F0=F 10 G0=G DO 15 K=1,KM-1 DO 15 J=1,K L3=K*(K+1)/2+J+1 L4=(K+1)*(K+2)/2+J+1 A(L4)=(J+0.5D0*K+0.125D0/(2.0*J+K+1.0))*A(L3) & -(J+0.5D0*K-1.0+0.625D0/(2.0*J+K+1.0))*A(L3-1) 15 CONTINUE RETURN END C ********************************** SUBROUTINE ITTIKA(X,TTI,TTK) C C ========================================================= C Purpose: Integrate [I0(t)-1]/t with respect to t from 0 C to x, and K0(t)/t with respect to t from x to ∞ C Input : x --- Variable in the limits ( x ≥ 0 ) C Output: TTI --- Integration of [I0(t)-1]/t from 0 to x C TTK --- Integration of K0(t)/t from x to ∞ C ========================================================= C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION C(8) PI=3.141592653589793D0 EL=.5772156649015329D0 DATA C/1.625D0,4.1328125D0, & 1.45380859375D+1,6.553353881835D+1, & 3.6066157150269D+2,2.3448727161884D+3, & 1.7588273098916D+4,1.4950639538279D+5/ IF (X.EQ.0.0D0) THEN TTI=0.0D0 TTK=1.0D+300 RETURN ENDIF IF (X.LT.40.0D0) THEN TTI=1.0D0 R=1.0D0 DO 10 K=2,50 R=.25D0*R*(K-1.0D0)/(K*K*K)*X*X TTI=TTI+R IF (DABS(R/TTI).LT.1.0D-12) GO TO 15 10 CONTINUE 15 TTI=TTI*.125D0*X*X ELSE TTI=1.0D0 R=1.0D0 DO 20 K=1,8 R=R/X 20 TTI=TTI+C(K)*R RC=X*DSQRT(2.0D0*PI*X) TTI=TTI*EXP(X)/RC ENDIF IF (X.LE.12.0D0) THEN E0=(.5D0*DLOG(X/2.0D0)+EL)*DLOG(X/2.0D0) & +PI*PI/24.0D0+.5D0*EL*EL B1=1.5D0-(EL+DLOG(X/2.0D0)) RS=1.0D0 R=1.0D0 DO 25 K=2,50 R=.25D0*R*(K-1.0D0)/(K*K*K)*X*X RS=RS+1.0D0/K R2=R*(RS+1.0D0/(2.0D0*K)-(EL+DLOG(X/2.0D0))) B1=B1+R2 IF (DABS(R2/B1).LT.1.0D-12) GO TO 30 25 CONTINUE 30 TTK=E0-.125D0*X*X*B1 ELSE TTK=1.0D0 R=1.0D0 DO 35 K=1,8 R=-R/X 35 TTK=TTK+C(K)*R RC=X*DSQRT(2.0D0/PI*X) TTK=TTK*EXP(-X)/RC ENDIF RETURN END C ********************************** SUBROUTINE LAMV(V,X,VM,VL,DL) C C ========================================================= C Purpose: Compute lambda function with arbitrary order v, C and their derivative C Input : x --- Argument of lambda function C v --- Order of lambda function C Output: VL(n) --- Lambda function of order n+v0 C DL(n) --- Derivative of lambda function C VM --- Highest order computed C Routines called: C (1) MSTA1 and MSTA2 for computing the starting C point for backward recurrence C (2) GAM0 for computing gamma function (|x| ≤ 1) C ========================================================= C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION VL(0:*),DL(0:*) PI=3.141592653589793D0 RP2=0.63661977236758D0 X=DABS(X) X2=X*X N=INT(V) V0=V-N VM=V IF (X.LE.12.0D0) THEN DO 25 K=0,N VK=V0+K BK=1.0D0 R=1.0D0 DO 10 I=1,50 R=-0.25D0*R*X2/(I*(I+VK)) BK=BK+R IF (DABS(R).LT.DABS(BK)*1.0D-15) GO TO 15 10 CONTINUE 15 VL(K)=BK UK=1.0D0 R=1.0D0 DO 20 I=1,50 R=-0.25D0*R*X2/(I*(I+VK+1.0D0)) UK=UK+R IF (DABS(R).LT.DABS(UK)*1.0D-15) GO TO 25 20 CONTINUE 25 DL(K)=-0.5D0*X/(VK+1.0D0)*UK RETURN ENDIF K0=11 IF (X.GE.35.0D0) K0=10 IF (X.GE.50.0D0) K0=8 BJV0=0.0D0 BJV1=0.0D0 DO 40 J=0,1 VV=4.0D0*(J+V0)*(J+V0) PX=1.0D0 RP=1.0D0 DO 30 K=1,K0 RP=-0.78125D-2*RP*(VV-(4.0*K-3.0)**2.0)*(VV- & (4.0*K-1.0)**2.0)/(K*(2.0*K-1.0)*X2) 30 PX=PX+RP QX=1.0D0 RQ=1.0D0 DO 35 K=1,K0 RQ=-0.78125D-2*RQ*(VV-(4.0*K-1.0)**2.0)*(VV- & (4.0*K+1.0)**2.0)/(K*(2.0*K+1.0)*X2) 35 QX=QX+RQ QX=0.125D0*(VV-1.0D0)*QX/X XK=X-(0.5D0*(J+V0)+0.25D0)*PI A0=DSQRT(RP2/X) CK=DCOS(XK) SK=DSIN(XK) IF (J.EQ.0) BJV0=A0*(PX*CK-QX*SK) IF (J.EQ.1) BJV1=A0*(PX*CK-QX*SK) 40 CONTINUE IF (V0.EQ.0.0D0) THEN GA=1.0D0 ELSE CALL GAM0(V0,GA) GA=V0*GA ENDIF FAC=(2.0D0/X)**V0*GA VL(0)=BJV0 DL(0)=-BJV1+V0/X*BJV0 VL(1)=BJV1 DL(1)=BJV0-(1.0D0+V0)/X*BJV1 R0=2.0D0*(1.0D0+V0)/X IF (N.LE.1) THEN VL(0)=FAC*VL(0) DL(0)=FAC*DL(0)-V0/X*VL(0) VL(1)=FAC*R0*VL(1) DL(1)=FAC*R0*DL(1)-(1.0D0+V0)/X*VL(1) RETURN ENDIF IF (N.GE.2.AND.N.LE.INT(0.9*X)) THEN F0=BJV0 F1=BJV1 DO 45 K=2,N F=2.0D0*(K+V0-1.0D0)/X*F1-F0 F0=F1 F1=F 45 VL(K)=F ELSE IF (N.GE.2) THEN M=MSTA1(X,200) IF (M.LT.N) THEN N=M ELSE M=MSTA2(X,N,15) ENDIF F=0.0D0 F2=0.0D0 F1=1.0D-100 DO 50 K=M,0,-1 F=2.0D0*(V0+K+1.0D0)/X*F1-F2 IF (K.LE.N) VL(K)=F F2=F1 50 F1=F CS=0.0D0 IF (DABS(BJV0).GT.DABS(BJV1)) THEN CS=BJV0/F ELSE CS=BJV1/F2 ENDIF DO 55 K=0,N 55 VL(K)=CS*VL(K) ENDIF VL(0)=FAC*VL(0) DO 65 J=1,N RC=FAC*R0 VL(J)=RC*VL(J) DL(J-1)=-0.5D0*X/(J+V0)*VL(J) 65 R0=2.0D0*(J+V0+1)/X*R0 DL(N)=2.0D0*(V0+N)*(VL(N-1)-VL(N))/X VM=N+V0 RETURN END C ********************************** SUBROUTINE CHGUIT(A,B,X,HU,ID) C C ====================================================== C Purpose: Compute hypergeometric function U(a,b,x) by C using Gaussian-Legendre integration (n=60) C Input : a --- Parameter ( a > 0 ) C b --- Parameter C x --- Argument ( x > 0 ) C Output: HU --- U(a,b,z) C ID --- Estimated number of significant digits C Routine called: GAMMA2 for computing Г(x) C ====================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION T(30),W(30) DATA T/ .259597723012478D-01, .778093339495366D-01, & .129449135396945D+00, .180739964873425D+00, & .231543551376029D+00, .281722937423262D+00, & .331142848268448D+00, .379670056576798D+00, & .427173741583078D+00, .473525841761707D+00, & .518601400058570D+00, .562278900753945D+00, & .604440597048510D+00, .644972828489477D+00, & .683766327381356D+00, .720716513355730D+00, & .755723775306586D+00, .788693739932264D+00, & .819537526162146D+00, .848171984785930D+00, & .874519922646898D+00, .898510310810046D+00, & .920078476177628D+00, .939166276116423D+00, & .955722255839996D+00, .969701788765053D+00, & .981067201752598D+00, .989787895222222D+00, & .995840525118838D+00, .999210123227436D+00/ DATA W/ .519078776312206D-01, .517679431749102D-01, & .514884515009810D-01, .510701560698557D-01, & .505141845325094D-01, .498220356905502D-01, & .489955754557568D-01, .480370318199712D-01, & .469489888489122D-01, .457343797161145D-01, & .443964787957872D-01, .429388928359356D-01, & .413655512355848D-01, .396806954523808D-01, & .378888675692434D-01, .359948980510845D-01, & .340038927249464D-01, .319212190192963D-01, & .297524915007890D-01, .275035567499248D-01, & .251804776215213D-01, .227895169439978D-01, & .203371207294572D-01, .178299010142074D-01, & .152746185967848D-01, .126781664768159D-01, & .100475571822880D-01, .738993116334531D-02, & .471272992695363D-02, .202681196887362D-02/ ID=9 C DLMF 13.4.4, integration up to C=12/X A1=A-1.0D0 B1=B-A-1.0D0 C=12.0D0/X HU0=0.0D0 DO 20 M=10,100,5 HU1=0.0D0 G=0.5D0*C/M D=G DO 15 J=1,M S=0.0D0 DO 10 K=1,30 T1=D+G*T(K) T2=D-G*T(K) F1=EXP(-X*T1)*T1**A1*(1.0D0+T1)**B1 F2=EXP(-X*T2)*T2**A1*(1.0D0+T2)**B1 S=S+W(K)*(F1+F2) 10 CONTINUE HU1=HU1+S*G D=D+2.0D0*G 15 CONTINUE IF (DABS(1.0D0-HU0/HU1).LT.1.0D-9) GO TO 25 HU0=HU1 20 CONTINUE 25 CALL GAMMA2(A,GA) HU1=HU1/GA C DLMF 13.4.4 with substitution t=C/(1-u) C integration u from 0 to 1, i.e. t from C=12/X to infinity DO 40 M=2,10,2 HU2=0.0D0 G=0.5D0/M D=G DO 35 J=1,M S=0.0D0 DO 30 K=1,30 T1=D+G*T(K) T2=D-G*T(K) T3=C/(1.0D0-T1) T4=C/(1.0D0-T2) F1=T3*T3/C*EXP(-X*T3)*T3**A1*(1.0D0+T3)**B1 F2=T4*T4/C*EXP(-X*T4)*T4**A1*(1.0D0+T4)**B1 S=S+W(K)*(F1+F2) 30 CONTINUE HU2=HU2+S*G D=D+2.0D0*G 35 CONTINUE IF (DABS(1.0D0-HU0/HU2).LT.1.0D-9) GO TO 45 HU0=HU2 40 CONTINUE 45 CALL GAMMA2(A,GA) HU2=HU2/GA HU=HU1+HU2 RETURN END C ********************************** SUBROUTINE KMN(M,N,C,CV,KD,DF,DN,CK1,CK2) C C =================================================== C Purpose: Compute the expansion coefficients of the C prolate and oblate spheroidal functions C and joining factors C =================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION U(200),V(200),W(200),DF(200),DN(200), & TP(200),RK(200) NM=25+INT(0.5*(N-M)+C) NN=NM+M CS=C*C*KD IP=1 IF (N-M.EQ.2*INT((N-M)/2)) IP=0 K=0 DO 10 I=1,NN+3 IF (IP.EQ.0) K=-2*(I-1) IF (IP.EQ.1) K=-(2*I-3) GK0=2.0D0*M+K GK1=(M+K)*(M+K+1.0D0) GK2=2.0D0*(M+K)-1.0D0 GK3=2.0D0*(M+K)+3.0D0 U(I)=GK0*(GK0-1.0D0)*CS/(GK2*(GK2+2.0D0)) V(I)=GK1-CV+(2.0D0*(GK1-M*M)-1.0D0)*CS/(GK2*GK3) 10 W(I)=(K+1.0D0)*(K+2.0D0)*CS/((GK2+2.0D0)*GK3) DO 20 K=1,M T=V(M+1) DO 15 L=0,M-K-1 15 T=V(M-L)-W(M-L+1)*U(M-L)/T 20 RK(K)=-U(K)/T R=1.0D0 DO 25 K=1,M R=R*RK(K) 25 DN(K)=DF(1)*R TP(NN)=V(NN+1) DO 30 K=NN-1,M+1,-1 TP(K)=V(K+1)-W(K+2)*U(K+1)/TP(K+1) IF (K.GT.M+1) RK(K)=-U(K)/TP(K) 30 CONTINUE IF (M.EQ.0) DNP=DF(1) IF (M.NE.0) DNP=DN(M) DN(M+1)=(-1)**IP*DNP*CS/((2.0*M-1.0)*(2.0*M+1.0-4.0*IP) & *TP(M+1)) DO 35 K=M+2,NN 35 DN(K)=RK(K)*DN(K-1) R1=1.0D0 DO 40 J=1,(N+M+IP)/2 40 R1=R1*(J+0.5D0*(N+M+IP)) NM1=(N-M)/2 R=1.0D0 DO 45 J=1,2*M+IP 45 R=R*J SU0=R*DF(1) SW=0.0D0 DO 50 K=2,NM R=R*(M+K-1.0)*(M+K+IP-1.5D0)/(K-1.0D0)/(K+IP-1.5D0) SU0=SU0+R*DF(K) IF (K.GT.NM1.AND.DABS((SU0-SW)/SU0).LT.1.0D-14) GO TO 55 50 SW=SU0 55 IF (KD.EQ.1) GOTO 70 R2=1.0D0 DO 60 J=1,M 60 R2=2.0D0*C*R2*J R3=1.0D0 DO 65 J=1,(N-M-IP)/2 65 R3=R3*J SA0=(2.0*(M+IP)+1.0)*R1/(2.0**N*C**IP*R2*R3*DF(1)) CK1=SA0*SU0 IF (KD.EQ.-1) RETURN 70 R4=1.0D0 DO 75 J=1,(N-M-IP)/2 75 R4=4.0D0*R4*J R5=1.0D0 DO 80 J=1,M 80 R5=R5*(J+M)/C G0=DN(M) IF (M.EQ.0) G0=DF(1) SB0=(IP+1.0)*C**(IP+1)/(2.0*IP*(M-2.0)+1.0)/(2.0*M-1.0) CK2=(-1)**IP*SB0*R4*R5*G0/R1*SU0 RETURN END C ********************************** SUBROUTINE LAGZO(N,X,W) C C ========================================================= C Purpose : Compute the zeros of Laguerre polynomial Ln(x) C in the interval [0,∞], and the corresponding C weighting coefficients for Gauss-Laguerre C integration C Input : n --- Order of the Laguerre polynomial C X(n) --- Zeros of the Laguerre polynomial C W(n) --- Corresponding weighting coefficients C ========================================================= C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION X(N),W(N) HN=1.0D0/N PF=0.0D0 PD=0.0D0 DO 35 NR=1,N Z=HN IF (NR.GT.1) Z=X(NR-1)+HN*NR**1.27 IT=0 10 IT=IT+1 Z0=Z P=1.0D0 DO 15 I=1,NR-1 15 P=P*(Z-X(I)) F0=1.0D0 F1=1.0D0-Z DO 20 K=2,N PF=((2.0D0*K-1.0D0-Z)*F1-(K-1.0D0)*F0)/K PD=K/Z*(PF-F1) F0=F1 20 F1=PF FD=PF/P Q=0.0D0 DO 30 I=1,NR-1 WP=1.0D0 DO 25 J=1,NR-1 IF (J.EQ.I) GO TO 25 WP=WP*(Z-X(J)) 25 CONTINUE Q=Q+WP 30 CONTINUE GD=(PD-Q*FD)/P Z=Z-FD/GD IF (IT.LE.40.AND.DABS((Z-Z0)/Z).GT.1.0D-15) GO TO 10 X(NR)=Z W(NR)=1.0D0/(Z*PD*PD) 35 CONTINUE RETURN END C ********************************** SUBROUTINE VVLA(VA,X,PV) C C =================================================== C Purpose: Compute parabolic cylinder function Vv(x) C for large argument C Input: x --- Argument C va --- Order C Output: PV --- Vv(x) C Routines called: C (1) DVLA for computing Dv(x) for large |x| C (2) GAMMA2 for computing Г(x) C =================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) PI=3.141592653589793D0 EPS=1.0D-12 QE=EXP(0.25*X*X) A0=DABS(X)**(-VA-1.0D0)*DSQRT(2.0D0/PI)*QE R=1.0D0 PV=1.0D0 DO 10 K=1,18 R=0.5D0*R*(2.0*K+VA-1.0)*(2.0*K+VA)/(K*X*X) PV=PV+R IF (DABS(R/PV).LT.EPS) GO TO 15 10 CONTINUE 15 PV=A0*PV IF (X.LT.0.0D0) THEN X1=-X CALL DVLA(VA,X1,PDL) CALL GAMMA2(-VA,GL) DSL=DSIN(PI*VA)*DSIN(PI*VA) PV=DSL*GL/PI*PDL-DCOS(PI*VA)*PV ENDIF RETURN END C ********************************** SUBROUTINE CJYVA(V,Z,VM,CBJ,CDJ,CBY,CDY) C C =========================================================== C Purpose: Compute Bessel functions Jv(z), Yv(z) and their C derivatives for a complex argument C Input : z --- Complex argument C v --- Order of Jv(z) and Yv(z) C ( v = n+v0, n = 0,1,2,..., 0 ≤ v0 < 1 ) C Output: CBJ(n) --- Jn+v0(z) C CDJ(n) --- Jn+v0'(z) C CBY(n) --- Yn+v0(z) C CDY(n) --- Yn+v0'(z) C VM --- Highest order computed C Routines called: C (1) GAMMA2 for computing the gamma function C (2) MSTA1 and MSTA2 for computing the starting C point for backward recurrence C =========================================================== C IMPLICIT DOUBLE PRECISION (A,B,G,O-Y) IMPLICIT COMPLEX*16 (C,Z) DIMENSION CBJ(0:*),CDJ(0:*),CBY(0:*),CDY(0:*) PI=3.141592653589793D0 RP2=.63661977236758D0 CI=(0.0D0,1.0D0) A0=ABS(Z) Z1=Z Z2=Z*Z N=INT(V) V0=V-N PV0=PI*V0 PV1=PI*(1.0D0+V0) IF (A0.LT.1.0D-100) THEN DO 10 K=0,N CBJ(K)=(0.0D0,0.0D0) CDJ(K)=(0.0D0,0.0D0) CBY(K)=-(1.0D+300,0.0D0) 10 CDY(K)=(1.0D+300,0.0D0) IF (V0.EQ.0.0) THEN CBJ(0)=(1.0D0,0.0D0) CDJ(1)=(0.5D0,0.0D0) ELSE CDJ(0)=(1.0D+300,0.0D0) ENDIF VM=V RETURN ENDIF LB0=0.0D0 IF (DBLE(Z).LT.0.0) Z1=-Z IF (A0.LE.12.0) THEN DO 25 L=0,1 VL=V0+L CJVL=(1.0D0,0.0D0) CR=(1.0D0,0.0D0) DO 15 K=1,40 CR=-0.25D0*CR*Z2/(K*(K+VL)) CJVL=CJVL+CR IF (ABS(CR).LT.ABS(CJVL)*1.0D-15) GO TO 20 15 CONTINUE 20 VG=1.0D0+VL CALL GAMMA2(VG,GA) CA=(0.5D0*Z1)**VL/GA IF (L.EQ.0) CJV0=CJVL*CA IF (L.EQ.1) CJV1=CJVL*CA 25 CONTINUE ELSE K0=11 IF (A0.GE.35.0) K0=10 IF (A0.GE.50.0) K0=8 DO 40 J=0,1 VV=4.0D0*(J+V0)*(J+V0) CPZ=(1.0D0,0.0D0) CRP=(1.0D0,0.0D0) DO 30 K=1,K0 CRP=-0.78125D-2*CRP*(VV-(4.0*K-3.0)**2.0)*(VV- & (4.0*K-1.0)**2.0)/(K*(2.0*K-1.0)*Z2) 30 CPZ=CPZ+CRP CQZ=(1.0D0,0.0D0) CRQ=(1.0D0,0.0D0) DO 35 K=1,K0 CRQ=-0.78125D-2*CRQ*(VV-(4.0*K-1.0)**2.0)*(VV- & (4.0*K+1.0)**2.0)/(K*(2.0*K+1.0)*Z2) 35 CQZ=CQZ+CRQ CQZ=0.125D0*(VV-1.0)*CQZ/Z1 ZK=Z1-(0.5D0*(J+V0)+0.25D0)*PI CA0=SQRT(RP2/Z1) CCK=COS(ZK) CSK=SIN(ZK) IF (J.EQ.0) THEN CJV0=CA0*(CPZ*CCK-CQZ*CSK) CYV0=CA0*(CPZ*CSK+CQZ*CCK) ELSE IF (J.EQ.1) THEN CJV1=CA0*(CPZ*CCK-CQZ*CSK) CYV1=CA0*(CPZ*CSK+CQZ*CCK) ENDIF 40 CONTINUE ENDIF IF (A0.LE.12.0) THEN IF (V0.NE.0.0) THEN DO 55 L=0,1 VL=V0+L CJVL=(1.0D0,0.0D0) CR=(1.0D0,0.0D0) DO 45 K=1,40 CR=-0.25D0*CR*Z2/(K*(K-VL)) CJVL=CJVL+CR IF (ABS(CR).LT.ABS(CJVL)*1.0D-15) GO TO 50 45 CONTINUE 50 VG=1.0D0-VL CALL GAMMA2(VG,GB) CB=(2.0D0/Z1)**VL/GB IF (L.EQ.0) CJU0=CJVL*CB IF (L.EQ.1) CJU1=CJVL*CB 55 CONTINUE CYV0=(CJV0*DCOS(PV0)-CJU0)/DSIN(PV0) CYV1=(CJV1*DCOS(PV1)-CJU1)/DSIN(PV1) ELSE CEC=LOG(Z1/2.0D0)+.5772156649015329D0 CS0=(0.0D0,0.0D0) W0=0.0D0 CR0=(1.0D0,0.0D0) DO 60 K=1,30 W0=W0+1.0D0/K CR0=-0.25D0*CR0/(K*K)*Z2 60 CS0=CS0+CR0*W0 CYV0=RP2*(CEC*CJV0-CS0) CS1=(1.0D0,0.0D0) W1=0.0D0 CR1=(1.0D0,0.0D0) DO 65 K=1,30 W1=W1+1.0D0/K CR1=-0.25D0*CR1/(K*(K+1))*Z2 65 CS1=CS1+CR1*(2.0D0*W1+1.0D0/(K+1.0D0)) CYV1=RP2*(CEC*CJV1-1.0D0/Z1-0.25D0*Z1*CS1) ENDIF ENDIF IF (DBLE(Z).LT.0.0D0) THEN CFAC0=EXP(PV0*CI) CFAC1=EXP(PV1*CI) IF (DIMAG(Z).LT.0.0D0) THEN CYV0=CFAC0*CYV0-2.0D0*CI*DCOS(PV0)*CJV0 CYV1=CFAC1*CYV1-2.0D0*CI*DCOS(PV1)*CJV1 CJV0=CJV0/CFAC0 CJV1=CJV1/CFAC1 ELSE IF (DIMAG(Z).GT.0.0D0) THEN CYV0=CYV0/CFAC0+2.0D0*CI*DCOS(PV0)*CJV0 CYV1=CYV1/CFAC1+2.0D0*CI*DCOS(PV1)*CJV1 CJV0=CFAC0*CJV0 CJV1=CFAC1*CJV1 ENDIF ENDIF CBJ(0)=CJV0 CBJ(1)=CJV1 IF (N.GE.2.AND.N.LE.INT(0.25*A0)) THEN CF0=CJV0 CF1=CJV1 DO 70 K=2,N CF=2.0D0*(K+V0-1.0D0)/Z*CF1-CF0 CBJ(K)=CF CF0=CF1 70 CF1=CF ELSE IF (N.GE.2) THEN M=MSTA1(A0,200) IF (M.LT.N) THEN N=M ELSE M=MSTA2(A0,N,15) ENDIF CF2=(0.0D0,0.0D0) CF1=(1.0D-100,0.0D0) DO 75 K=M,0,-1 CF=2.0D0*(V0+K+1.0D0)/Z*CF1-CF2 IF (K.LE.N) CBJ(K)=CF CF2=CF1 75 CF1=CF IF (ABS(CJV0).GT.ABS(CJV1)) CS=CJV0/CF IF (ABS(CJV0).LE.ABS(CJV1)) CS=CJV1/CF2 DO 80 K=0,N 80 CBJ(K)=CS*CBJ(K) ENDIF CDJ(0)=V0/Z*CBJ(0)-CBJ(1) DO 85 K=1,N 85 CDJ(K)=-(K+V0)/Z*CBJ(K)+CBJ(K-1) CBY(0)=CYV0 CBY(1)=CYV1 YA0=ABS(CYV0) LB=0 CG0=CYV0 CG1=CYV1 DO 90 K=2,N CYK=2.0D0*(V0+K-1.0D0)/Z*CG1-CG0 IF (ABS(CYK).GT.1.0D+290) GO TO 90 YAK=ABS(CYK) YA1=ABS(CG0) IF (YAK.LT.YA0.AND.YAK.LT.YA1) LB=K CBY(K)=CYK CG0=CG1 CG1=CYK 90 CONTINUE IF (LB.LE.4.OR.DIMAG(Z).EQ.0.0D0) GO TO 125 95 IF (LB.EQ.LB0) GO TO 125 CH2=(1.0D0,0.0D0) CH1=(0.0D0,0.0D0) LB0=LB DO 100 K=LB,1,-1 CH0=2.0D0*(K+V0)/Z*CH1-CH2 CH2=CH1 100 CH1=CH0 CP12=CH0 CP22=CH2 CH2=(0.0D0,0.0D0) CH1=(1.0D0,0.0D0) DO 105 K=LB,1,-1 CH0=2.0D0*(K+V0)/Z*CH1-CH2 CH2=CH1 105 CH1=CH0 CP11=CH0 CP21=CH2 IF (LB.EQ.N) CBJ(LB+1)=2.0D0*(LB+V0)/Z*CBJ(LB)-CBJ(LB-1) IF (ABS(CBJ(0)).GT.ABS(CBJ(1))) THEN CBY(LB+1)=(CBJ(LB+1)*CYV0-2.0D0*CP11/(PI*Z))/CBJ(0) CBY(LB)=(CBJ(LB)*CYV0+2.0D0*CP12/(PI*Z))/CBJ(0) ELSE CBY(LB+1)=(CBJ(LB+1)*CYV1-2.0D0*CP21/(PI*Z))/CBJ(1) CBY(LB)=(CBJ(LB)*CYV1+2.0D0*CP22/(PI*Z))/CBJ(1) ENDIF CYL2=CBY(LB+1) CYL1=CBY(LB) DO 110 K=LB-1,0,-1 CYLK=2.0D0*(K+V0+1.0D0)/Z*CYL1-CYL2 CBY(K)=CYLK CYL2=CYL1 110 CYL1=CYLK CYL1=CBY(LB) CYL2=CBY(LB+1) DO 115 K=LB+1,N-1 CYLK=2.0D0*(K+V0)/Z*CYL2-CYL1 CBY(K+1)=CYLK CYL1=CYL2 115 CYL2=CYLK DO 120 K=2,N WA=ABS(CBY(K)) IF (WA.LT.ABS(CBY(K-1))) LB=K 120 CONTINUE GO TO 95 125 CDY(0)=V0/Z*CBY(0)-CBY(1) DO 130 K=1,N 130 CDY(K)=CBY(K-1)-(K+V0)/Z*CBY(K) VM=N+V0 RETURN END C ********************************** SUBROUTINE CJYVB(V,Z,VM,CBJ,CDJ,CBY,CDY) C C =========================================================== C Purpose: Compute Bessel functions Jv(z), Yv(z) and their C derivatives for a complex argument C Input : z --- Complex argument C v --- Order of Jv(z) and Yv(z) C ( v = n+v0, n = 0,1,2,..., 0 ≤ v0 < 1 ) C Output: CBJ(n) --- Jn+v0(z) C CDJ(n) --- Jn+v0'(z) C CBY(n) --- Yn+v0(z) C CDY(n) --- Yn+v0'(z) C VM --- Highest order computed C Routines called: C (1) GAMMA2 for computing the gamma function C (2) MSTA1 and MSTA2 for computing the starting C point for backward recurrence C =========================================================== C IMPLICIT DOUBLE PRECISION (A,B,G,O-Y) IMPLICIT COMPLEX*16 (C,Z) DIMENSION CBJ(0:*),CDJ(0:*),CBY(0:*),CDY(0:*) PI=3.141592653589793D0 RP2=.63661977236758D0 CI=(0.0D0,1.0D0) A0=ABS(Z) Z1=Z Z2=Z*Z N=INT(V) V0=V-N PV0=PI*V0 IF (A0.LT.1.0D-100) THEN DO 10 K=0,N CBJ(K)=(0.0D0,0.0D0) CDJ(K)=(0.0D0,0.0D0) CBY(K)=-(1.0D+300,0.0D0) 10 CDY(K)=(1.0D+300,0.0D0) IF (V0.EQ.0.0) THEN CBJ(0)=(1.0D0,0.0D0) CDJ(1)=(0.5D0,0.0D0) ELSE CDJ(0)=(1.0D+300,0.0D0) ENDIF VM=V RETURN ENDIF IF (DBLE(Z).LT.0.0D0) Z1=-Z IF (A0.LE.12.0) THEN CJV0=(1.0D0,0.0D0) CR=(1.0D0,0.0D0) DO 15 K=1,40 CR=-0.25D0*CR*Z2/(K*(K+V0)) CJV0=CJV0+CR IF (ABS(CR).LT.ABS(CJV0)*1.0D-15) GO TO 20 15 CONTINUE 20 VG=1.0D0+V0 CALL GAMMA2(VG,GA) CA=(0.5D0*Z1)**V0/GA CJV0=CJV0*CA ELSE K0=11 IF (A0.GE.35.0) K0=10 IF (A0.GE.50.0) K0=8 VV=4.0D0*V0*V0 CPZ=(1.0D0,0.0D0) CRP=(1.0D0,0.0D0) DO 25 K=1,K0 CRP=-0.78125D-2*CRP*(VV-(4.0*K-3.0)**2.0)*(VV- & (4.0*K-1.0)**2.0)/(K*(2.0*K-1.0)*Z2) 25 CPZ=CPZ+CRP CQZ=(1.0D0,0.0D0) CRQ=(1.0D0,0.0D0) DO 30 K=1,K0 CRQ=-0.78125D-2*CRQ*(VV-(4.0*K-1.0)**2.0)*(VV- & (4.0*K+1.0)**2.0)/(K*(2.0*K+1.0)*Z2) 30 CQZ=CQZ+CRQ CQZ=0.125D0*(VV-1.0)*CQZ/Z1 ZK=Z1-(0.5D0*V0+0.25D0)*PI CA0=SQRT(RP2/Z1) CCK=COS(ZK) CSK=SIN(ZK) CJV0=CA0*(CPZ*CCK-CQZ*CSK) CYV0=CA0*(CPZ*CSK+CQZ*CCK) ENDIF IF (A0.LE.12.0) THEN IF (V0.NE.0.0) THEN CJVN=(1.0D0,0.0D0) CR=(1.0D0,0.0D0) DO 35 K=1,40 CR=-0.25D0*CR*Z2/(K*(K-V0)) CJVN=CJVN+CR IF (ABS(CR).LT.ABS(CJVN)*1.0D-15) GO TO 40 35 CONTINUE 40 VG=1.0D0-V0 CALL GAMMA2(VG,GB) CB=(2.0D0/Z1)**V0/GB CJU0=CJVN*CB CYV0=(CJV0*DCOS(PV0)-CJU0)/DSIN(PV0) ELSE CEC=LOG(Z1/2.0D0)+.5772156649015329D0 CS0=(0.0D0,0.0D0) W0=0.0D0 CR0=(1.0D0,0.0D0) DO 45 K=1,30 W0=W0+1.0D0/K CR0=-0.25D0*CR0/(K*K)*Z2 45 CS0=CS0+CR0*W0 CYV0=RP2*(CEC*CJV0-CS0) ENDIF ENDIF IF (N.EQ.0) N=1 M=MSTA1(A0,200) IF (M.LT.N) THEN N=M ELSE M=MSTA2(A0,N,15) ENDIF CF2=(0.0D0,0.0D0) CF1=(1.0D-100,0.0D0) DO 50 K=M,0,-1 CF=2.0D0*(V0+K+1.0D0)/Z1*CF1-CF2 IF (K.LE.N) CBJ(K)=CF CF2=CF1 50 CF1=CF CS=CJV0/CF DO 55 K=0,N 55 CBJ(K)=CS*CBJ(K) IF (DBLE(Z).LT.0.0D0) THEN CFAC0=EXP(PV0*CI) IF (DIMAG(Z).LT.0.0D0) THEN CYV0=CFAC0*CYV0-2.0D0*CI*DCOS(PV0)*CJV0 ELSE IF (DIMAG(Z).GT.0.0D0) THEN CYV0=CYV0/CFAC0+2.0D0*CI*DCOS(PV0)*CJV0 ENDIF DO 60 K=0,N IF (DIMAG(Z).LT.0.0D0) THEN CBJ(K)=EXP(-PI*(K+V0)*CI)*CBJ(K) ELSE IF (DIMAG(Z).GT.0.0D0) THEN CBJ(K)=EXP(PI*(K+V0)*CI)*CBJ(K) ENDIF 60 CONTINUE Z1=Z1 ENDIF CBY(0)=CYV0 DO 65 K=1,N CYY=(CBJ(K)*CBY(K-1)-2.0D0/(PI*Z))/CBJ(K-1) CBY(K)=CYY 65 CONTINUE CDJ(0)=V0/Z*CBJ(0)-CBJ(1) DO 70 K=1,N 70 CDJ(K)=-(K+V0)/Z*CBJ(K)+CBJ(K-1) CDY(0)=V0/Z*CBY(0)-CBY(1) DO 75 K=1,N 75 CDY(K)=CBY(K-1)-(K+V0)/Z*CBY(K) VM=N+V0 RETURN END C ********************************** SUBROUTINE JY01A(X,BJ0,DJ0,BJ1,DJ1,BY0,DY0,BY1,DY1) C C ======================================================= C Purpose: Compute Bessel functions J0(x), J1(x), Y0(x), C Y1(x), and their derivatives C Input : x --- Argument of Jn(x) & Yn(x) ( x ≥ 0 ) C Output: BJ0 --- J0(x) C DJ0 --- J0'(x) C BJ1 --- J1(x) C DJ1 --- J1'(x) C BY0 --- Y0(x) C DY0 --- Y0'(x) C BY1 --- Y1(x) C DY1 --- Y1'(x) C ======================================================= C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION A(12),B(12),A1(12),B1(12) PI=3.141592653589793D0 RP2=0.63661977236758D0 X2=X*X IF (X.EQ.0.0D0) THEN BJ0=1.0D0 BJ1=0.0D0 DJ0=0.0D0 DJ1=0.5D0 BY0=-1.0D+300 BY1=-1.0D+300 DY0=1.0D+300 DY1=1.0D+300 RETURN ENDIF IF (X.LE.12.0D0) THEN BJ0=1.0D0 R=1.0D0 DO 5 K=1,30 R=-0.25D0*R*X2/(K*K) BJ0=BJ0+R IF (DABS(R).LT.DABS(BJ0)*1.0D-15) GO TO 10 5 CONTINUE 10 BJ1=1.0D0 R=1.0D0 DO 15 K=1,30 R=-0.25D0*R*X2/(K*(K+1.0D0)) BJ1=BJ1+R IF (DABS(R).LT.DABS(BJ1)*1.0D-15) GO TO 20 15 CONTINUE 20 BJ1=0.5D0*X*BJ1 EC=DLOG(X/2.0D0)+0.5772156649015329D0 CS0=0.0D0 W0=0.0D0 R0=1.0D0 DO 25 K=1,30 W0=W0+1.0D0/K R0=-0.25D0*R0/(K*K)*X2 R=R0*W0 CS0=CS0+R IF (DABS(R).LT.DABS(CS0)*1.0D-15) GO TO 30 25 CONTINUE 30 BY0=RP2*(EC*BJ0-CS0) CS1=1.0D0 W1=0.0D0 R1=1.0D0 DO 35 K=1,30 W1=W1+1.0D0/K R1=-0.25D0*R1/(K*(K+1))*X2 R=R1*(2.0D0*W1+1.0D0/(K+1.0D0)) CS1=CS1+R IF (DABS(R).LT.DABS(CS1)*1.0D-15) GO TO 40 35 CONTINUE 40 BY1=RP2*(EC*BJ1-1.0D0/X-0.25D0*X*CS1) ELSE DATA A/-.7031250000000000D-01,.1121520996093750D+00, & -.5725014209747314D+00,.6074042001273483D+01, & -.1100171402692467D+03,.3038090510922384D+04, & -.1188384262567832D+06,.6252951493434797D+07, & -.4259392165047669D+09,.3646840080706556D+11, & -.3833534661393944D+13,.4854014686852901D+15/ DATA B/ .7324218750000000D-01,-.2271080017089844D+00, & .1727727502584457D+01,-.2438052969955606D+02, & .5513358961220206D+03,-.1825775547429318D+05, & .8328593040162893D+06,-.5006958953198893D+08, & .3836255180230433D+10,-.3649010818849833D+12, & .4218971570284096D+14,-.5827244631566907D+16/ DATA A1/.1171875000000000D+00,-.1441955566406250D+00, & .6765925884246826D+00,-.6883914268109947D+01, & .1215978918765359D+03,-.3302272294480852D+04, & .1276412726461746D+06,-.6656367718817688D+07, & .4502786003050393D+09,-.3833857520742790D+11, & .4011838599133198D+13,-.5060568503314727D+15/ DATA B1/-.1025390625000000D+00,.2775764465332031D+00, & -.1993531733751297D+01,.2724882731126854D+02, & -.6038440767050702D+03,.1971837591223663D+05, & -.8902978767070678D+06,.5310411010968522D+08, & -.4043620325107754D+10,.3827011346598605D+12, & -.4406481417852278D+14,.6065091351222699D+16/ K0=12 IF (X.GE.35.0) K0=10 IF (X.GE.50.0) K0=8 T1=X-0.25D0*PI P0=1.0D0 Q0=-0.125D0/X DO 45 K=1,K0 P0=P0+A(K)*X**(-2*K) 45 Q0=Q0+B(K)*X**(-2*K-1) CU=DSQRT(RP2/X) BJ0=CU*(P0*DCOS(T1)-Q0*DSIN(T1)) BY0=CU*(P0*DSIN(T1)+Q0*DCOS(T1)) T2=X-0.75D0*PI P1=1.0D0 Q1=0.375D0/X DO 50 K=1,K0 P1=P1+A1(K)*X**(-2*K) 50 Q1=Q1+B1(K)*X**(-2*K-1) CU=DSQRT(RP2/X) BJ1=CU*(P1*DCOS(T2)-Q1*DSIN(T2)) BY1=CU*(P1*DSIN(T2)+Q1*DCOS(T2)) ENDIF DJ0=-BJ1 DJ1=BJ0-BJ1/X DY0=-BY1 DY1=BY0-BY1/X RETURN END C ********************************** SUBROUTINE INCOG(A,X,GIN,GIM,GIP,ISFER) C C =================================================== C Purpose: Compute the incomplete gamma function C r(a,x), Г(a,x) and P(a,x) C Input : a --- Parameter ( a ≤ 170 ) C x --- Argument C Output: GIN --- r(a,x) C GIM --- Г(a,x) C GIP --- P(a,x) C ISFER --- Error flag C Routine called: GAMMA2 for computing Г(x) C =================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) ISFER=0 XAM=-X+A*DLOG(X) IF (XAM.GT.700.0.OR.A.GT.170.0) THEN ISFER=6 RETURN ENDIF IF (X.EQ.0.0) THEN GIN=0.0 CALL GAMMA2(A,GA) GIM=GA GIP=0.0 ELSE IF (X.LE.1.0+A) THEN S=1.0D0/A R=S DO 10 K=1,60 R=R*X/(A+K) S=S+R IF (DABS(R/S).LT.1.0D-15) GO TO 15 10 CONTINUE 15 GIN=EXP(XAM)*S CALL GAMMA2(A,GA) GIP=GIN/GA GIM=GA-GIN ELSE IF (X.GT.1.0+A) THEN T0=0.0D0 DO 20 K=60,1,-1 T0=(K-A)/(1.0D0+K/(X+T0)) 20 CONTINUE GIM=EXP(XAM)/(X+T0) CALL GAMMA2(A,GA) GIN=GA-GIM GIP=1.0D0-GIM/GA ENDIF END C ********************************** SUBROUTINE ITIKB(X,TI,TK) C C ======================================================= C Purpose: Integrate Bessel functions I0(t) and K0(t) C with respect to t from 0 to x C Input : x --- Upper limit of the integral ( x ≥ 0 ) C Output: TI --- Integration of I0(t) from 0 to x C TK --- Integration of K0(t) from 0 to x C ======================================================= C IMPLICIT DOUBLE PRECISION (A-H,O-Z) PI=3.141592653589793D0 IF (X.EQ.0.0D0) THEN TI=0.0D0 ELSE IF (X.LT.5.0D0) THEN T1=X/5.0D0 T=T1*T1 TI=((((((((.59434D-3*T+.4500642D-2)*T & +.044686921D0)*T+.300704878D0)*T+1.471860153D0) & *T+4.844024624D0)*T+9.765629849D0)*T & +10.416666367D0)*T+5.0D0)*T1 ELSE IF (X.GE.5.0.AND.X.LE.8.0D0) THEN T=5.0D0/X TI=(((-.015166D0*T-.0202292D0)*T+.1294122D0)*T & -.0302912D0)*T+.4161224D0 TI=TI*EXP(X)/DSQRT(X) ELSE T=8.0D0/X TI=(((((-.0073995D0*T+.017744D0)*T-.0114858D0)*T & +.55956D-2)*T+.59191D-2)*T+.0311734D0)*T & +.3989423D0 TI=TI*EXP(X)/DSQRT(X) ENDIF IF (X.EQ.0.0D0) THEN TK=0.0D0 ELSE IF (X.LE.2.0D0) THEN T1=X/2.0D0 T=T1*T1 TK=((((((.116D-5*T+.2069D-4)*T+.62664D-3)*T & +.01110118D0)*T+.11227902D0)*T+.50407836D0)*T & +.84556868D0)*T1 TK=TK-DLOG(X/2.0D0)*TI ELSE IF (X.GT.2.0.AND.X.LE.4.0D0) THEN T=2.0D0/X TK=(((.0160395D0*T-.0781715D0)*T+.185984D0)*T & -.3584641D0)*T+1.2494934D0 TK=PI/2.0D0-TK*EXP(-X)/DSQRT(X) ELSE IF (X.GT.4.0.AND.X.LE.7.0D0) THEN T=4.0D0/X TK=(((((.37128D-2*T-.0158449D0)*T+.0320504D0)*T & -.0481455D0)*T+.0787284D0)*T-.1958273D0)*T & +1.2533141D0 TK=PI/2.0D0-TK*EXP(-X)/DSQRT(X) ELSE T=7.0D0/X TK=(((((.33934D-3*T-.163271D-2)*T+.417454D-2)*T & -.933944D-2)*T+.02576646D0)*T-.11190289D0)*T & +1.25331414D0 TK=PI/2.0D0-TK*EXP(-X)/DSQRT(X) ENDIF RETURN END C ********************************** SUBROUTINE ITIKA(X,TI,TK) C C ======================================================= C Purpose: Integrate modified Bessel functions I0(t) and C K0(t) with respect to t from 0 to x C Input : x --- Upper limit of the integral ( x ≥ 0 ) C Output: TI --- Integration of I0(t) from 0 to x C TK --- Integration of K0(t) from 0 to x C ======================================================= C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION A(10) PI=3.141592653589793D0 EL=.5772156649015329D0 DATA A/.625D0,1.0078125D0, & 2.5927734375D0,9.1868591308594D0, & 4.1567974090576D+1,2.2919635891914D+2, & 1.491504060477D+3,1.1192354495579D+4, & 9.515939374212D+4,9.0412425769041D+5/ IF (X.EQ.0.0D0) THEN TI=0.0D0 TK=0.0D0 RETURN ELSE IF (X.LT.20.0D0) THEN X2=X*X TI=1.0D0 R=1.0D0 DO 10 K=1,50 R=.25D0*R*(2*K-1.0D0)/(2*K+1.0D0)/(K*K)*X2 TI=TI+R IF (DABS(R/TI).LT.1.0D-12) GO TO 15 10 CONTINUE 15 TI=TI*X ELSE X2=0.0D0 TI=1.0D0 R=1.0D0 DO 20 K=1,10 R=R/X 20 TI=TI+A(K)*R RC1=1.0D0/DSQRT(2.0D0*PI*X) TI=RC1*EXP(X)*TI ENDIF IF (X.LT.12.0D0) THEN E0=EL+DLOG(X/2.0D0) B1=1.0D0-E0 B2=0.0D0 RS=0.0D0 R=1.0D0 TW=0.0D0 DO 25 K=1,50 R=.25D0*R*(2*K-1.0D0)/(2*K+1.0D0)/(K*K)*X2 B1=B1+R*(1.0D0/(2*K+1)-E0) RS=RS+1.0D0/K B2=B2+R*RS TK=B1+B2 IF (DABS((TK-TW)/TK).LT.1.0D-12) GO TO 30 25 TW=TK 30 TK=TK*X ELSE TK=1.0D0 R=1.0D0 DO 35 K=1,10 R=-R/X 35 TK=TK+A(K)*R RC2=DSQRT(PI/(2.0D0*X)) TK=PI/2.0D0-RC2*TK*EXP(-X) ENDIF RETURN END C ********************************** SUBROUTINE JYV(V,X,VM,BJ,DJ,BY,DY) C C ======================================================= C Purpose: Compute Bessel functions Jv(x) and Yv(x) C and their derivatives C Input : x --- Argument of Jv(x) and Yv(x) C v --- Order of Jv(x) and Yv(x) C ( v = n+v0, 0 ≤ v0 < 1, n = 0,1,2,... ) C Output: BJ(n) --- Jn+v0(x) C DJ(n) --- Jn+v0'(x) C BY(n) --- Yn+v0(x) C DY(n) --- Yn+v0'(x) C VM --- Highest order computed C Routines called: C (1) GAMMA2 for computing gamma function C (2) MSTA1 and MSTA2 for computing the starting C point for backward recurrence C ======================================================= C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION BJ(0:*),DJ(0:*),BY(0:*),DY(0:*) EL=.5772156649015329D0 PI=3.141592653589793D0 RP2=.63661977236758D0 X2=X*X N=INT(V) V0=V-N IF (X.LT.1.0D-100) THEN DO 10 K=0,N BJ(K)=0.0D0 DJ(K)=0.0D0 BY(K)=-1.0D+300 10 DY(K)=1.0D+300 IF (V0.EQ.0.0) THEN BJ(0)=1.0D0 DJ(1)=0.5D0 ELSE DJ(0)=1.0D+300 ENDIF VM=V RETURN ENDIF BJV0=0.0D0 BJV1=0.0D0 BYV0=0.0D0 BYV1=0.0D0 IF (X.LE.12.0) THEN DO 25 L=0,1 VL=V0+L BJVL=1.0D0 R=1.0D0 DO 15 K=1,40 R=-0.25D0*R*X2/(K*(K+VL)) BJVL=BJVL+R IF (DABS(R).LT.DABS(BJVL)*1.0D-15) GO TO 20 15 CONTINUE 20 VG=1.0D0+VL CALL GAMMA2(VG,GA) A=(0.5D0*X)**VL/GA IF (L.EQ.0) BJV0=BJVL*A IF (L.EQ.1) BJV1=BJVL*A 25 CONTINUE ELSE K0=11 IF (X.GE.35.0) K0=10 IF (X.GE.50.0) K0=8 DO 40 J=0,1 VV=4.0D0*(J+V0)*(J+V0) PX=1.0D0 RP=1.0D0 DO 30 K=1,K0 RP=-0.78125D-2*RP*(VV-(4.0*K-3.0)**2.0)*(VV- & (4.0*K-1.0)**2.0)/(K*(2.0*K-1.0)*X2) 30 PX=PX+RP QX=1.0D0 RQ=1.0D0 DO 35 K=1,K0 RQ=-0.78125D-2*RQ*(VV-(4.0*K-1.0)**2.0)*(VV- & (4.0*K+1.0)**2.0)/(K*(2.0*K+1.0)*X2) 35 QX=QX+RQ QX=0.125D0*(VV-1.0)*QX/X XK=X-(0.5D0*(J+V0)+0.25D0)*PI A0=DSQRT(RP2/X) CK=DCOS(XK) SK=DSIN(XK) IF (J.EQ.0) THEN BJV0=A0*(PX*CK-QX*SK) BYV0=A0*(PX*SK+QX*CK) ELSE IF (J.EQ.1) THEN BJV1=A0*(PX*CK-QX*SK) BYV1=A0*(PX*SK+QX*CK) ENDIF 40 CONTINUE ENDIF BJ(0)=BJV0 BJ(1)=BJV1 DJ(0)=V0/X*BJ(0)-BJ(1) DJ(1)=-(1.0D0+V0)/X*BJ(1)+BJ(0) IF (N.GE.2.AND.N.LE.INT(0.9*X)) THEN F0=BJV0 F1=BJV1 DO 45 K=2,N F=2.0D0*(K+V0-1.0D0)/X*F1-F0 BJ(K)=F F0=F1 45 F1=F ELSE IF (N.GE.2) THEN M=MSTA1(X,200) IF (M.LT.N) THEN N=M ELSE M=MSTA2(X,N,15) ENDIF F=0.0D0 F2=0.0D0 F1=1.0D-100 DO 50 K=M,0,-1 F=2.0D0*(V0+K+1.0D0)/X*F1-F2 IF (K.LE.N) BJ(K)=F F2=F1 50 F1=F IF (DABS(BJV0).GT.DABS(BJV1)) THEN CS=BJV0/F ELSE CS=BJV1/F2 ENDIF DO 55 K=0,N 55 BJ(K)=CS*BJ(K) ENDIF DO 60 K=2,N 60 DJ(K)=-(K+V0)/X*BJ(K)+BJ(K-1) IF (X.LE.12.0D0) THEN IF (V0.NE.0.0) THEN BJU0=0.0D0 BJU1=0.0D0 DO 75 L=0,1 VL=V0+L BJVL=1.0D0 R=1.0D0 DO 65 K=1,40 R=-0.25D0*R*X2/(K*(K-VL)) BJVL=BJVL+R IF (DABS(R).LT.DABS(BJVL)*1.0D-15) GO TO 70 65 CONTINUE 70 VG=1.0D0-VL CALL GAMMA2(VG,GB) B=(2.0D0/X)**VL/GB IF (L.EQ.0) BJU0=BJVL*B IF (L.EQ.1) BJU1=BJVL*B 75 CONTINUE PV0=PI*V0 PV1=PI*(1.0D0+V0) BYV0=(BJV0*DCOS(PV0)-BJU0)/DSIN(PV0) BYV1=(BJV1*DCOS(PV1)-BJU1)/DSIN(PV1) ELSE EC=DLOG(X/2.0D0)+EL CS0=0.0D0 W0=0.0D0 R0=1.0D0 DO 80 K=1,30 W0=W0+1.0D0/K R0=-0.25D0*R0/(K*K)*X2 80 CS0=CS0+R0*W0 BYV0=RP2*(EC*BJV0-CS0) CS1=1.0D0 W1=0.0D0 R1=1.0D0 DO 85 K=1,30 W1=W1+1.0D0/K R1=-0.25D0*R1/(K*(K+1))*X2 85 CS1=CS1+R1*(2.0D0*W1+1.0D0/(K+1.0D0)) BYV1=RP2*(EC*BJV1-1.0D0/X-0.25D0*X*CS1) ENDIF ENDIF BY(0)=BYV0 BY(1)=BYV1 DO 90 K=2,N BYVK=2.0D0*(V0+K-1.0D0)/X*BYV1-BYV0 BY(K)=BYVK BYV0=BYV1 90 BYV1=BYVK DY(0)=V0/X*BY(0)-BY(1) DO 95 K=1,N 95 DY(K)=-(K+V0)/X*BY(K)+BY(K-1) VM=N+V0 RETURN END C ********************************** SUBROUTINE JYNB(N,X,NM,BJ,DJ,BY,DY) C C ===================================================== C Purpose: Compute Bessel functions Jn(x), Yn(x) and C their derivatives C Input : x --- Argument of Jn(x) and Yn(x) ( x ≥ 0 ) C n --- Order of Jn(x) and Yn(x) C Output: BJ(n) --- Jn(x) C DJ(n) --- Jn'(x) C BY(n) --- Yn(x) C DY(n) --- Yn'(x) C NM --- Highest order computed C Routines called: C JYNBH to calculate the Jn and Yn C ===================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION BJ(0:N),DJ(0:N),BY(0:N),DY(0:N) CALL JYNBH(N,0,X,NM,BJ,BY) C Compute derivatives by differentiation formulas IF (X.LT.1.0D-100) THEN DO 10 K=0,N DJ(K) = 0.0D0 10 DY(K) = 1.0D+300 DJ(1)=0.5D0 ELSE DJ(0)=-BJ(1) DO 40 K=1,NM 40 DJ(K)=BJ(K-1)-K/X*BJ(K) DY(0)=-BY(1) DO 50 K=1,NM 50 DY(K)=BY(K-1)-K*BY(K)/X END IF RETURN END C ********************************** SUBROUTINE JYNBH(N,NMIN,X,NM,BJ,BY) C C ===================================================== C Purpose: Compute Bessel functions Jn(x), Yn(x) C Input : x --- Argument of Jn(x) and Yn(x) ( x ≥ 0 ) C n --- Highest order of Jn(x) and Yn(x) computed ( n ≥ 0 ) C nmin -- Lowest order computed ( nmin ≥ 0 ) C Output: BJ(n-NMIN) --- Jn(x) ; if indexing starts at 0 C BY(n-NMIN) --- Yn(x) ; if indexing starts at 0 C NM --- Highest order computed C Routines called: C MSTA1 and MSTA2 to calculate the starting C point for backward recurrence C ===================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION BJ(0:N-NMIN),BY(0:N-NMIN),A(4),B(4),A1(4),B1(4) PI=3.141592653589793D0 R2P=.63661977236758D0 NM=N IF (X.LT.1.0D-100) THEN DO 10 K=NMIN,N BJ(K-NMIN)=0.0D0 10 BY(K-NMIN)=-1.0D+300 IF (NMIN.EQ.0) BJ(0)=1.0D0 RETURN ENDIF IF (X.LE.300.0.OR.N.GT.INT(0.9*X)) THEN C Backward recurrence for Jn IF (N.EQ.0) NM=1 M=MSTA1(X,200) IF (M.LT.NM) THEN NM=M ELSE M=MSTA2(X,NM,15) ENDIF BS=0.0D0 SU=0.0D0 SV=0.0D0 F2=0.0D0 F1=1.0D-100 F=0.0D0 DO 15 K=M,0,-1 F=2.0D0*(K+1.0D0)/X*F1-F2 IF (K.LE.NM .AND. K.GE.NMIN) BJ(K-NMIN)=F IF (K.EQ.2*INT(K/2).AND.K.NE.0) THEN BS=BS+2.0D0*F SU=SU+(-1)**(K/2)*F/K ELSE IF (K.GT.1) THEN SV=SV+(-1)**(K/2)*K/(K*K-1.0D0)*F ENDIF F2=F1 15 F1=F S0=BS+F DO 20 K=NMIN,NM 20 BJ(K-NMIN)=BJ(K-NMIN)/S0 C Estimates for Yn at start of recurrence BJ0 = F1 / S0 BJ1 = F2 / S0 EC=DLOG(X/2.0D0)+0.5772156649015329D0 BY0=R2P*(EC*BJ0-4.0D0*SU/S0) BY1=R2P*((EC-1.0D0)*BJ1-BJ0/X-4.0D0*SV/S0) IF (0.GE.NMIN) BY(0-NMIN)=BY0 IF (1.GE.NMIN) BY(1-NMIN)=BY1 KY=2 ELSE C Hankel expansion DATA A/-.7031250000000000D-01,.1121520996093750D+00, & -.5725014209747314D+00,.6074042001273483D+01/ DATA B/ .7324218750000000D-01,-.2271080017089844D+00, & .1727727502584457D+01,-.2438052969955606D+02/ DATA A1/.1171875000000000D+00,-.1441955566406250D+00, & .6765925884246826D+00,-.6883914268109947D+01/ DATA B1/-.1025390625000000D+00,.2775764465332031D+00, & -.1993531733751297D+01,.2724882731126854D+02/ T1=X-0.25D0*PI P0=1.0D0 Q0=-0.125D0/X DO 25 K=1,4 P0=P0+A(K)*X**(-2*K) 25 Q0=Q0+B(K)*X**(-2*K-1) CU=DSQRT(R2P/X) BJ0=CU*(P0*DCOS(T1)-Q0*DSIN(T1)) BY0=CU*(P0*DSIN(T1)+Q0*DCOS(T1)) IF (0.GE.NMIN) BJ(0-NMIN)=BJ0 IF (0.GE.NMIN) BY(0-NMIN)=BY0 T2=X-0.75D0*PI P1=1.0D0 Q1=0.375D0/X DO 30 K=1,4 P1=P1+A1(K)*X**(-2*K) 30 Q1=Q1+B1(K)*X**(-2*K-1) BJ1=CU*(P1*DCOS(T2)-Q1*DSIN(T2)) BY1=CU*(P1*DSIN(T2)+Q1*DCOS(T2)) IF (1.GE.NMIN) BJ(1-NMIN)=BJ1 IF (1.GE.NMIN) BY(1-NMIN)=BY1 DO 35 K=2,NM BJK=2.0D0*(K-1.0D0)/X*BJ1-BJ0 IF (K.GE.NMIN) BJ(K-NMIN)=BJK BJ0=BJ1 35 BJ1=BJK KY=2 ENDIF C Forward recurrence for Yn DO 45 K=KY,NM BYK=2.0D0*(K-1.0D0)*BY1/X-BY0 IF (K.GE.NMIN) BY(K-NMIN)=BYK BY0=BY1 45 BY1=BYK RETURN END C ********************************** SUBROUTINE LEGZO(N,X,W) C C ========================================================= C Purpose : Compute the zeros of Legendre polynomial Pn(x) C in the interval [-1,1], and the corresponding C weighting coefficients for Gauss-Legendre C integration C Input : n --- Order of the Legendre polynomial C Output: X(n) --- Zeros of the Legendre polynomial C W(n) --- Corresponding weighting coefficients C ========================================================= C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION X(N),W(N) N0=(N+1)/2 PF=0.0D0 PD=0.0D0 DO 45 NR=1,N0 Z=DCOS(3.1415926D0*(NR-0.25D0)/N) 10 Z0=Z P=1.0D0 DO 15 I=1,NR-1 15 P=P*(Z-X(I)) F0=1.0D0 IF (NR.EQ.N0.AND.N.NE.2*INT(N/2)) Z=0.0D0 F1=Z DO 20 K=2,N PF=(2.0D0-1.0D0/K)*Z*F1-(1.0D0-1.0D0/K)*F0 PD=K*(F1-Z*PF)/(1.0D0-Z*Z) F0=F1 20 F1=PF IF (Z.EQ.0.0) GO TO 40 FD=PF/P Q=0.0D0 DO 35 I=1,NR WP=1.0D0 DO 30 J=1,NR IF (J.NE.I) WP=WP*(Z-X(J)) 30 CONTINUE 35 Q=Q+WP GD=(PD-Q*FD)/P Z=Z-FD/GD IF (DABS(Z-Z0).GT.DABS(Z)*1.0D-15) GO TO 10 40 X(NR)=Z X(N+1-NR)=-Z W(NR)=2.0D0/((1.0D0-Z*Z)*PD*PD) 45 W(N+1-NR)=W(NR) RETURN END C ********************************** SUBROUTINE ASWFA(M,N,C,X,KD,CV,S1F,S1D) C C =========================================================== C Purpose: Compute the prolate and oblate spheroidal angular C functions of the first kind and their derivatives C Input : m --- Mode parameter, m = 0,1,2,... C n --- Mode parameter, n = m,m+1,... C c --- Spheroidal parameter C x --- Argument of angular function, |x| < 1.0 C KD --- Function code C KD=1 for prolate; KD=-1 for oblate C cv --- Characteristic value C Output: S1F --- Angular function of the first kind C S1D --- Derivative of the angular function of C the first kind C Routine called: C SCKB for computing expansion coefficients ck C =========================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION CK(200),DF(200) EPS=1.0D-14 X0=X X=DABS(X) IP=1 IF (N-M.EQ.2*INT((N-M)/2)) IP=0 NM=40+INT((N-M)/2+C) NM2=NM/2-2 CALL SDMN(M,N,C,CV,KD,DF) CALL SCKB(M,N,C,DF,CK) X1=1.0D0-X*X IF (M.EQ.0.AND.X1.EQ.0.0D0) THEN A0=1.0D0 ELSE A0=X1**(0.5D0*M) ENDIF SU1=CK(1) DO 10 K=1,NM2 R=CK(K+1)*X1**K SU1=SU1+R IF (K.GE.10.AND.DABS(R/SU1).LT.EPS) GO TO 15 10 CONTINUE 15 S1F=A0*X**IP*SU1 IF (X.EQ.1.0D0) THEN IF (M.EQ.0) S1D=IP*CK(1)-2.0D0*CK(2) IF (M.EQ.1) S1D=-1.0D+100 IF (M.EQ.2) S1D=-2.0D0*CK(1) IF (M.GE.3) S1D=0.0D0 ELSE D0=IP-M/X1*X**(IP+1.0D0) D1=-2.0D0*A0*X**(IP+1.0D0) SU2=CK(2) DO 20 K=2,NM2 R=K*CK(K+1)*X1**(K-1.0D0) SU2=SU2+R IF (K.GE.10.AND.DABS(R/SU2).LT.EPS) GO TO 25 20 CONTINUE 25 S1D=D0*A0*SU1+D1*SU2 ENDIF IF (X0.LT.0.0D0.AND.IP.EQ.0) S1D=-S1D IF (X0.LT.0.0D0.AND.IP.EQ.1) S1F=-S1F X=X0 RETURN END C ********************************** SUBROUTINE JYNA(N,X,NM,BJ,DJ,BY,DY) C C ========================================================== C Purpose: Compute Bessel functions Jn(x) & Yn(x) and C their derivatives C Input : x --- Argument of Jn(x) & Yn(x) ( x ≥ 0 ) C n --- Order of Jn(x) & Yn(x) C Output: BJ(n) --- Jn(x) C DJ(n) --- Jn'(x) C BY(n) --- Yn(x) C DY(n) --- Yn'(x) C NM --- Highest order computed C Routines called: C (1) JY01B to calculate J0(x), J1(x), Y0(x) & Y1(x) C (2) MSTA1 and MSTA2 to calculate the starting C point for backward recurrence C ========================================================= C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION BJ(0:N),BY(0:N),DJ(0:N),DY(0:N) NM=N IF (X.LT.1.0D-100) THEN DO 10 K=0,N BJ(K)=0.0D0 DJ(K)=0.0D0 BY(K)=-1.0D+300 10 DY(K)=1.0D+300 BJ(0)=1.0D0 DJ(1)=0.5D0 RETURN ENDIF CALL JY01B(X,BJ0,DJ0,BJ1,DJ1,BY0,DY0,BY1,DY1) BJ(0)=BJ0 BJ(1)=BJ1 BY(0)=BY0 BY(1)=BY1 DJ(0)=DJ0 DJ(1)=DJ1 DY(0)=DY0 DY(1)=DY1 IF (N.LE.1) RETURN IF (N.LT.INT(0.9*X)) THEN DO 20 K=2,N BJK=2.0D0*(K-1.0D0)/X*BJ1-BJ0 BJ(K)=BJK BJ0=BJ1 20 BJ1=BJK ELSE M=MSTA1(X,200) IF (M.LT.N) THEN NM=M ELSE M=MSTA2(X,N,15) ENDIF F2=0.0D0 F1=1.0D-100 F=0.0D0 DO 30 K=M,0,-1 F=2.0D0*(K+1.0D0)/X*F1-F2 IF (K.LE.NM) BJ(K)=F F2=F1 30 F1=F IF (DABS(BJ0).GT.DABS(BJ1)) THEN CS=BJ0/F ELSE CS=BJ1/F2 ENDIF DO 40 K=0,NM 40 BJ(K)=CS*BJ(K) ENDIF DO 50 K=2,NM 50 DJ(K)=BJ(K-1)-K/X*BJ(K) F0=BY(0) F1=BY(1) DO 60 K=2,NM F=2.0D0*(K-1.0D0)/X*F1-F0 BY(K)=F F0=F1 60 F1=F DO 70 K=2,NM 70 DY(K)=BY(K-1)-K*BY(K)/X RETURN END C ********************************** SUBROUTINE PBDV(V,X,DV,DP,PDF,PDD) C C ==================================================== C Purpose: Compute parabolic cylinder functions Dv(x) C and their derivatives C Input: x --- Argument of Dv(x) C v --- Order of Dv(x) C Output: DV(na) --- Dn+v0(x) C DP(na) --- Dn+v0'(x) C ( na = |n|, v0 = v-n, |v0| < 1, C n = 0,±1,±2,… ) C PDF --- Dv(x) C PDD --- Dv'(x) C Routines called: C (1) DVSA for computing Dv(x) for small |x| C (2) DVLA for computing Dv(x) for large |x| C ==================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION DV(0:*),DP(0:*) XA=DABS(X) VH=V V=V+DSIGN(1.0D0,V) NV=INT(V) V0=V-NV NA=ABS(NV) EP=EXP(-.25D0*X*X) JA=0 IF (NA.GE.1) JA=1 IF (V.GE.0.0) THEN IF (V0.EQ.0.0) THEN PD0=EP PD1=X*EP ELSE DO 10 L=0,JA V1=V0+L IF (XA.LE.5.8) CALL DVSA(V1,X,PD1) IF (XA.GT.5.8) CALL DVLA(V1,X,PD1) IF (L.EQ.0) PD0=PD1 10 CONTINUE ENDIF DV(0)=PD0 DV(1)=PD1 DO 15 K=2,NA PDF=X*PD1-(K+V0-1.0D0)*PD0 DV(K)=PDF PD0=PD1 15 PD1=PDF ELSE IF (X.LE.0.0) THEN IF (XA.LE.5.8D0) THEN CALL DVSA(V0,X,PD0) V1=V0-1.0D0 CALL DVSA(V1,X,PD1) ELSE CALL DVLA(V0,X,PD0) V1=V0-1.0D0 CALL DVLA(V1,X,PD1) ENDIF DV(0)=PD0 DV(1)=PD1 DO 20 K=2,NA PD=(-X*PD1+PD0)/(K-1.0D0-V0) DV(K)=PD PD0=PD1 20 PD1=PD ELSE IF (X.LE.2.0) THEN V2=NV+V0 IF (NV.EQ.0) V2=V2-1.0D0 NK=INT(-V2) CALL DVSA(V2,X,F1) V1=V2+1.0D0 CALL DVSA(V1,X,F0) DV(NK)=F1 DV(NK-1)=F0 DO 25 K=NK-2,0,-1 F=X*F0+(K-V0+1.0D0)*F1 DV(K)=F F1=F0 25 F0=F ELSE IF (XA.LE.5.8) CALL DVSA(V0,X,PD0) IF (XA.GT.5.8) CALL DVLA(V0,X,PD0) DV(0)=PD0 M=100+NA F1=0.0D0 F0=1.0D-30 F=0.0D0 DO 30 K=M,0,-1 F=X*F0+(K-V0+1.0D0)*F1 IF (K.LE.NA) DV(K)=F F1=F0 30 F0=F S0=PD0/F DO 35 K=0,NA 35 DV(K)=S0*DV(K) ENDIF ENDIF DO 40 K=0,NA-1 V1=ABS(V0)+K IF (V.GE.0.0D0) THEN DP(K)=0.5D0*X*DV(K)-DV(K+1) ELSE DP(K)=-0.5D0*X*DV(K)-V1*DV(K+1) ENDIF 40 CONTINUE PDF=DV(NA-1) PDD=DP(NA-1) V=VH RETURN END C ********************************** SUBROUTINE ITSH0(X,TH0) C C =================================================== C Purpose: Evaluate the integral of Struve function C H0(t) with respect to t from 0 and x C Input : x --- Upper limit ( x ≥ 0 ) C Output: TH0 --- Integration of H0(t) from 0 and x C =================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION A(25) PI=3.141592653589793D0 R=1.0D0 IF (X.LE.30.0) THEN S=0.5D0 DO 10 K=1,100 RD=1.0D0 IF (K.EQ.1) RD=0.5D0 R=-R*RD*K/(K+1.0D0)*(X/(2.0D0*K+1.0D0))**2 S=S+R IF (DABS(R).LT.DABS(S)*1.0D-12) GO TO 15 10 CONTINUE 15 TH0=2.0D0/PI*X*X*S ELSE S=1.0D0 DO 20 K=1,12 R=-R*K/(K+1.0D0)*((2.0D0*K+1.0D0)/X)**2 S=S+R IF (DABS(R).LT.DABS(S)*1.0D-12) GO TO 25 20 CONTINUE 25 EL=.57721566490153D0 S0=S/(PI*X*X)+2.0D0/PI*(DLOG(2.0D0*X)+EL) A0=1.0D0 A1=5.0D0/8.0D0 A(1)=A1 DO 30 K=1,20 AF=((1.5D0*(K+.5D0)*(K+5.0D0/6.0D0)*A1-.5D0 & *(K+.5D0)*(K+.5D0)*(K-.5D0)*A0))/(K+1.0D0) A(K+1)=AF A0=A1 30 A1=AF BF=1.0D0 R=1.0D0 DO 35 K=1,10 R=-R/(X*X) 35 BF=BF+A(2*K)*R BG=A(1)/X R=1.0D0/X DO 40 K=1,10 R=-R/(X*X) 40 BG=BG+A(2*K+1)*R XP=X+.25D0*PI TY=DSQRT(2.0D0/(PI*X))*(BG*DCOS(XP)-BF*DSIN(XP)) TH0=TY+S0 ENDIF RETURN END C ********************************** SUBROUTINE CERZO(NT,ZO) C C =============================================================== C Purpose : Evaluate the complex zeros of error function erf(z) C using the modified Newton's iteration method C Input : NT --- Total number of zeros C Output: ZO(L) --- L-th zero of erf(z), L=1,2,...,NT C Routine called: CERF for computing erf(z) and erf'(z) C =============================================================== C IMPLICIT DOUBLE PRECISION (E,P,W) IMPLICIT COMPLEX *16 (C,Z) DIMENSION ZO(NT) PI=3.141592653589793D0 W=0.0D0 DO 35 NR=1,NT PU=DSQRT(PI*(4.0D0*NR-0.5D0)) PV=PI*DSQRT(2.0D0*NR-0.25D0) PX=0.5*PU-0.5*DLOG(PV)/PU PY=0.5*PU+0.5*DLOG(PV)/PU Z = DCMPLX(PX, PY) IT=0 15 IT=IT+1 CALL CERF(Z,ZF,ZD) ZP=(1.0D0,0.0D0) DO 20 I=1,NR-1 20 ZP=ZP*(Z-ZO(I)) ZFD=ZF/ZP ZQ=(0.0D0,0.0D0) DO 30 I=1,NR-1 ZW=(1.0D0,0.0D0) DO 25 J=1,NR-1 IF (J.EQ.I) GO TO 25 ZW=ZW*(Z-ZO(J)) 25 CONTINUE 30 ZQ=ZQ+ZW ZGD=(ZD-ZQ*ZFD)/ZP Z=Z-ZFD/ZGD W0=W W=ABS(Z) IF (IT.LE.50.AND.DABS((W-W0)/W).GT.1.0D-11) GO TO 15 35 ZO(NR)=Z RETURN END C ********************************** SUBROUTINE GAMMA2(X,GA) C C ================================================== C Purpose: Compute gamma function Г(x) C Input : x --- Argument of Г(x) C ( x is not equal to 0,-1,-2,…) C Output: GA --- Г(x) C ================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION G(26) PI=3.141592653589793D0 IF (X.EQ.INT(X)) THEN IF (X.GT.0.0D0) THEN GA=1.0D0 M1=X-1 DO 10 K=2,M1 10 GA=GA*K ELSE GA=1.0D+300 ENDIF ELSE R=1.0D0 IF (DABS(X).GT.1.0D0) THEN Z=DABS(X) M=INT(Z) DO 15 K=1,M 15 R=R*(Z-K) Z=Z-M ELSE Z=X ENDIF DATA G/1.0D0,0.5772156649015329D0, & -0.6558780715202538D0, -0.420026350340952D-1, & 0.1665386113822915D0,-.421977345555443D-1, & -.96219715278770D-2, .72189432466630D-2, & -.11651675918591D-2, -.2152416741149D-3, & .1280502823882D-3, -.201348547807D-4, & -.12504934821D-5, .11330272320D-5, & -.2056338417D-6, .61160950D-8, & .50020075D-8, -.11812746D-8, & .1043427D-9, .77823D-11, & -.36968D-11, .51D-12, & -.206D-13, -.54D-14, .14D-14, .1D-15/ GR=G(26) DO 20 K=25,1,-1 20 GR=GR*Z+G(K) GA=1.0D0/(GR*Z) IF (DABS(X).GT.1.0D0) THEN GA=GA*R IF (X.LT.0.0D0) GA=-PI/(X*GA*DSIN(PI*X)) ENDIF ENDIF RETURN END C ********************************** SUBROUTINE CHGU(A,B,X,HU,MD,ISFER) C C ======================================================= C Purpose: Compute the confluent hypergeometric function C U(a,b,x) C Input : a --- Parameter C b --- Parameter C x --- Argument ( x > 0 ) C Output: HU --- U(a,b,x) C MD --- Method code C ISFER --- Error flag C Routines called: C (1) CHGUS for small x ( MD=1 ) C (2) CHGUL for large x ( MD=2 ) C (3) CHGUBI for integer b ( MD=3 ) C (4) CHGUIT for numerical integration ( MD=4 ) C ======================================================= C IMPLICIT DOUBLE PRECISION (A-H,O-Z) LOGICAL IL1,IL2,IL3,BL1,BL2,BL3,BN AA=A-B+1.0D0 ISFER=0 IL1=A.EQ.INT(A).AND.A.LE.0.0 IL2=AA.EQ.INT(AA).AND.AA.LE.0.0 IL3=ABS(A*(A-B+1.0))/X.LE.2.0 BL1=X.LE.5.0.OR.(X.LE.10.0.AND.A.LE.2.0) BL2=(X.GT.5.0.AND.X.LE.12.5).AND.(A.GE.1.0.AND.B.GE.A+4.0) BL3=X.GT.12.5.AND.A.GE.5.0.AND.B.GE.A+5.0 BN=B.EQ.INT(B).AND.B.NE.0.0 ID1=-100 HU1=0.0D0 IF (B.NE.INT(B)) THEN CALL CHGUS(A,B,X,HU,ID1) MD=1 IF (ID1.GE.9) RETURN HU1=HU ENDIF IF (IL1.OR.IL2.OR.IL3) THEN CALL CHGUL(A,B,X,HU,ID) MD=2 IF (ID.GE.9) RETURN IF (ID1.GT.ID) THEN MD=1 ID=ID1 HU=HU1 ENDIF ENDIF IF (A.GE.1.0) THEN IF (BN.AND.(BL1.OR.BL2.OR.BL3)) THEN CALL CHGUBI(A,B,X,HU,ID) MD=3 ELSE CALL CHGUIT(A,B,X,HU,ID) MD=4 ENDIF ELSE IF (B.LE.A) THEN A00=A B00=B A=A-B+1.0D0 B=2.0D0-B CALL CHGUIT(A,B,X,HU,ID) HU=X**(1.0D0-B00)*HU A=A00 B=B00 MD=4 ELSE IF (BN.AND.(.NOT.IL1)) THEN CALL CHGUBI(A,B,X,HU,ID) MD=3 ENDIF ENDIF IF (ID.LT.6) ISFER=6 RETURN END C ********************************** SUBROUTINE LAMN(N,X,NM,BL,DL) C C ========================================================= C Purpose: Compute lambda functions and their derivatives C Input: x --- Argument of lambda function C n --- Order of lambda function C Output: BL(n) --- Lambda function of order n C DL(n) --- Derivative of lambda function C NM --- Highest order computed C Routines called: C MSTA1 and MSTA2 for computing the start C point for backward recurrence C ========================================================= C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION BL(0:N),DL(0:N) NM=N IF (DABS(X).LT.1.0D-100) THEN DO 10 K=0,N BL(K)=0.0D0 10 DL(K)=0.0D0 BL(0)=1.0D0 DL(1)=0.5D0 RETURN ENDIF IF (X.LE.12.0D0) THEN X2=X*X DO 25 K=0,N BK=1.0D0 R=1.0D0 DO 15 I=1,50 R=-0.25D0*R*X2/(I*(I+K)) BK=BK+R IF (DABS(R).LT.DABS(BK)*1.0D-15) GO TO 20 15 CONTINUE 20 BL(K)=BK 25 IF (K.GE.1) DL(K-1)=-0.5D0*X/K*BK UK=1.0D0 R=1.0D0 DO 30 I=1,50 R=-0.25D0*R*X2/(I*(I+N+1.0D0)) UK=UK+R IF (DABS(R).LT.DABS(UK)*1.0D-15) GO TO 35 30 CONTINUE 35 DL(N)=-0.5D0*X/(N+1.0D0)*UK RETURN ENDIF IF (N.EQ.0) NM=1 M=MSTA1(X,200) IF (M.LT.NM) THEN NM=M ELSE M=MSTA2(X,NM,15) ENDIF BS=0.0D0 F=0.0D0 F0=0.0D0 F1=1.0D-100 DO 40 K=M,0,-1 F=2.0D0*(K+1.0D0)*F1/X-F0 IF (K.LE.NM) BL(K)=F IF (K.EQ.2*INT(K/2)) BS=BS+2.0D0*F F0=F1 40 F1=F BG=BS-F DO 45 K=0,NM 45 BL(K)=BL(K)/BG R0=1.0D0 DO 50 K=1,NM R0=2.0D0*R0*K/X 50 BL(K)=R0*BL(K) DL(0)=-0.5D0*X*BL(1) DO 55 K=1,NM 55 DL(K)=2.0D0*K/X*(BL(K-1)-BL(K)) RETURN END C ********************************** SUBROUTINE COMELP(HK,CK,CE) C C ================================================== C Purpose: Compute complete elliptic integrals K(k) C and E(k) C Input : K --- Modulus k ( 0 ≤ k ≤ 1 ) C Output : CK --- K(k) C CE --- E(k) C ================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) PK=1.0D0-HK*HK IF (HK.EQ.1.0) THEN CK=1.0D+300 CE=1.0D0 ELSE AK=(((.01451196212D0*PK+.03742563713D0)*PK & +.03590092383D0)*PK+.09666344259D0)*PK+ & 1.38629436112D0 BK=(((.00441787012D0*PK+.03328355346D0)*PK+ & .06880248576D0)*PK+.12498593597D0)*PK+.5D0 CK=AK-BK*DLOG(PK) AE=(((.01736506451D0*PK+.04757383546D0)*PK+ & .0626060122D0)*PK+.44325141463D0)*PK+1.0D0 BE=(((.00526449639D0*PK+.04069697526D0)*PK+ & .09200180037D0)*PK+.2499836831D0)*PK CE=AE-BE*DLOG(PK) ENDIF RETURN END C ********************************** SUBROUTINE INCOB(A,B,X,BIX) C C ======================================================== C Purpose: Compute the incomplete beta function Ix(a,b) C Input : a --- Parameter C b --- Parameter C x --- Argument ( 0 ≤ x ≤ 1 ) C Output: BIX --- Ix(a,b) C Routine called: BETA for computing beta function B(p,q) C ======================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION DK(51),FK(51) S0=(A+1.0D0)/(A+B+2.0D0) CALL BETA(A,B,BT) IF (X.LE.S0) THEN DO 10 K=1,20 10 DK(2*K)=K*(B-K)*X/(A+2.0D0*K-1.0D0)/(A+2.0D0*K) DO 15 K=0,20 15 DK(2*K+1)=-(A+K)*(A+B+K)*X/(A+2.D0*K)/(A+2.0*K+1.0) T1=0.0D0 DO 20 K=20,1,-1 20 T1=DK(K)/(1.0D0+T1) TA=1.0D0/(1.0D0+T1) BIX=X**A*(1.0D0-X)**B/(A*BT)*TA ELSE DO 25 K=1,20 25 FK(2*K)=K*(A-K)*(1.0D0-X)/(B+2.*K-1.0)/(B+2.0*K) DO 30 K=0,20 30 FK(2*K+1)=-(B+K)*(A+B+K)*(1.D0-X)/ & (B+2.D0*K)/(B+2.D0*K+1.D0) T2=0.0D0 DO 35 K=20,1,-1 35 T2=FK(K)/(1.0D0+T2) TB=1.0D0/(1.0D0+T2) BIX=1.0D0-X**A*(1.0D0-X)**B/(B*BT)*TB ENDIF RETURN END C ********************************** SUBROUTINE CVF(KD,M,Q,A,MJ,F) C C ====================================================== C Purpose: Compute the value of F for characteristic C equation of Mathieu functions C Input : m --- Order of Mathieu functions C q --- Parameter of Mathieu functions C A --- Characteristic value C Output: F --- Value of F for characteristic equation C ====================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) B=A IC=INT(M/2) L=0 L0=0 J0=2 JF=IC IF (KD.EQ.1) L0=2 IF (KD.EQ.1) J0=3 IF (KD.EQ.2.OR.KD.EQ.3) L=1 IF (KD.EQ.4) JF=IC-1 T1=0.0D0 DO 10 J=MJ,IC+1,-1 10 T1=-Q*Q/((2.0D0*J+L)**2-B+T1) IF (M.LE.2) THEN T2=0.0D0 IF (KD.EQ.1.AND.M.EQ.0) T1=T1+T1 IF (KD.EQ.1.AND.M.EQ.2) T1=-2.0D0*Q*Q/(4.0D0-B+T1)-4.0D0 IF (KD.EQ.2.AND.M.EQ.1) T1=T1+Q IF (KD.EQ.3.AND.M.EQ.1) T1=T1-Q ELSE T0=0.0D0 IF (KD.EQ.1) T0=4.0D0-B+2.0D0*Q*Q/B IF (KD.EQ.2) T0=1.0D0-B+Q IF (KD.EQ.3) T0=1.0D0-B-Q IF (KD.EQ.4) T0=4.0D0-B T2=-Q*Q/T0 DO 15 J=J0,JF 15 T2=-Q*Q/((2.0D0*J-L-L0)**2-B+T2) ENDIF F=(2.0D0*IC+L)**2+T1+T2-B RETURN END C ********************************** SUBROUTINE CLPN(N,X,Y,CPN,CPD) C C ================================================== C Purpose: Compute Legendre polynomials Pn(z) and C their derivatives Pn'(z) for a complex C argument C Input : x --- Real part of z C y --- Imaginary part of z C n --- Degree of Pn(z), n = 0,1,2,... C Output: CPN(n) --- Pn(z) C CPD(n) --- Pn'(z) C ================================================== C IMPLICIT DOUBLE PRECISION (X,Y) IMPLICIT COMPLEX *16 (C,Z) DIMENSION CPN(0:N),CPD(0:N) Z = DCMPLX(X, Y) CPN(0)=(1.0D0,0.0D0) CPN(1)=Z CPD(0)=(0.0D0,0.0D0) CPD(1)=(1.0D0,0.0D0) CP0=(1.0D0,0.0D0) CP1=Z DO 10 K=2,N CPF=(2.0D0*K-1.0D0)/K*Z*CP1-(K-1.0D0)/K*CP0 CPN(K)=CPF IF (DABS(X).EQ.1.0D0.AND.Y.EQ.0.0D0) THEN CPD(K)=0.5D0*X**(K+1)*K*(K+1.0D0) ELSE CPD(K)=K*(CP1-Z*CPF)/(1.0D0-Z*Z) ENDIF CP0=CP1 10 CP1=CPF RETURN END C ********************************** SUBROUTINE LQMNS(M,N,X,QM,QD) C C ======================================================== C Purpose: Compute associated Legendre functions Qmn(x) C and Qmn'(x) for a given order C Input : x --- Argument of Qmn(x) C m --- Order of Qmn(x), m = 0,1,2,... C n --- Degree of Qmn(x), n = 0,1,2,... C Output: QM(n) --- Qmn(x) C QD(n) --- Qmn'(x) C ======================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION QM(0:N),QD(0:N) DO 10 K=0,N QM(K)=0.0D0 10 QD(K)=0.0D0 IF (DABS(X).EQ.1.0D0) THEN DO 15 K=0,N QM(K)=1.0D+300 15 QD(K)=1.0D+300 RETURN ENDIF LS=1 IF (DABS(X).GT.1.0D0) LS=-1 XQ=DSQRT(LS*(1.0D0-X*X)) Q0=0.5D0*DLOG(DABS((X+1.0)/(X-1.0))) Q00=Q0 Q10=-1.0D0/XQ Q01=X*Q0-1.0D0 Q11=-LS*XQ*(Q0+X/(1.0D0-X*X)) QF0=Q00 QF1=Q10 QM0=0.0D0 QM1=0.0D0 DO 20 K=2,M QM0=-2.0D0*(K-1.0)/XQ*X*QF1-LS*(K-1.0)*(2.0-K)*QF0 QF0=QF1 20 QF1=QM0 IF (M.EQ.0) QM0=Q00 IF (M.EQ.1) QM0=Q10 QM(0)=QM0 IF (DABS(X).LT.1.0001D0) THEN IF (M.EQ.0.AND.N.GT.0) THEN QF0=Q00 QF1=Q01 DO 25 K=2,N QF2=((2.0*K-1.0D0)*X*QF1-(K-1.0)*QF0)/K QM(K)=QF2 QF0=QF1 25 QF1=QF2 ENDIF QG0=Q01 QG1=Q11 DO 30 K=2,M QM1=-2.0D0*(K-1.0)/XQ*X*QG1-LS*K*(3.0-K)*QG0 QG0=QG1 30 QG1=QM1 IF (M.EQ.0) QM1=Q01 IF (M.EQ.1) QM1=Q11 QM(1)=QM1 IF (M.EQ.1.AND.N.GT.1) THEN QH0=Q10 QH1=Q11 DO 35 K=2,N QH2=((2.0*K-1.0D0)*X*QH1-K*QH0)/(K-1.0) QM(K)=QH2 QH0=QH1 35 QH1=QH2 ELSE IF (M.GE.2) THEN QG0=Q00 QG1=Q01 QH0=Q10 QH1=Q11 QMK=0.0D0 DO 45 L=2,N Q0L=((2.0D0*L-1.0D0)*X*QG1-(L-1.0D0)*QG0)/L Q1L=((2.0*L-1.0D0)*X*QH1-L*QH0)/(L-1.0D0) QF0=Q0L QF1=Q1L DO 40 K=2,M QMK=-2.0D0*(K-1.0)/XQ*X*QF1-LS*(K+L-1.0)* & (L+2.0-K)*QF0 QF0=QF1 40 QF1=QMK QM(L)=QMK QG0=QG1 QG1=Q0L QH0=QH1 45 QH1=Q1L ENDIF ELSE IF (DABS(X).GT.1.1) THEN KM=40+M+N ELSE KM=(40+M+N)*INT(-1.0-1.8*LOG(X-1.0)) ENDIF QF2=0.0D0 QF1=1.0D0 DO 50 K=KM,0,-1 QF0=((2.0*K+3.0D0)*X*QF1-(K+2.0-M)*QF2)/(K+M+1.0) IF (K.LE.N) QM(K)=QF0 QF2=QF1 50 QF1=QF0 DO 55 K=0,N 55 QM(K)=QM(K)*QM0/QF0 ENDIF IF (DABS(X).LT.1.0D0) THEN DO 60 K=0,N 60 QM(K)=(-1)**M*QM(K) ENDIF QD(0)=((1.0D0-M)*QM(1)-X*QM(0))/(X*X-1.0) DO 65 K=1,N 65 QD(K)=(K*X*QM(K)-(K+M)*QM(K-1))/(X*X-1.0) RETURN END C ********************************** SUBROUTINE CIKLV(V,Z,CBIV,CDIV,CBKV,CDKV) C C ===================================================== C Purpose: Compute modified Bessel functions Iv(z) and C Kv(z) and their derivatives with a complex C argument and a large order C Input: v --- Order of Iv(z) and Kv(z) C z --- Complex argument C Output: CBIV --- Iv(z) C CDIV --- Iv'(z) C CBKV --- Kv(z) C CDKV --- Kv'(z) C Routine called: C CJK to compute the expansion coefficients C ==================================================== C IMPLICIT DOUBLE PRECISION (A,B,D-H,O-Y) IMPLICIT COMPLEX*16 (C,Z) DIMENSION CF(12),A(91) PI=3.141592653589793D0 KM=12 CALL CJK(KM,A) DO 30 L=1,0,-1 V0=V-L CWS=SQRT(1.0D0+(Z/V0)*(Z/V0)) CETA=CWS+LOG(Z/V0/(1.0D0+CWS)) CT=1.0D0/CWS CT2=CT*CT DO 15 K=1,KM L0=K*(K+1)/2+1 LF=L0+K CF(K)=A(LF) DO 10 I=LF-1,L0,-1 10 CF(K)=CF(K)*CT2+A(I) 15 CF(K)=CF(K)*CT**K VR=1.0D0/V0 CSI=(1.0D0,0.0D0) DO 20 K=1,KM 20 CSI=CSI+CF(K)*VR**K CBIV=SQRT(CT/(2.0D0*PI*V0))*EXP(V0*CETA)*CSI IF (L.EQ.1) CFI=CBIV CSK=(1.0D0,0.0D0) DO 25 K=1,KM 25 CSK=CSK+(-1)**K*CF(K)*VR**K CBKV=SQRT(PI*CT/(2.0D0*V0))*EXP(-V0*CETA)*CSK IF (L.EQ.1) CFK=CBKV 30 CONTINUE CDIV=CFI-V/Z*CBIV CDKV=-CFK-V/Z*CBKV RETURN END C ********************************** SUBROUTINE ELIT(HK,PHI,FE,EE) C C ================================================== C Purpose: Compute complete and incomplete elliptic C integrals F(k,phi) and E(k,phi) C Input : HK --- Modulus k ( 0 ≤ k ≤ 1 ) C Phi --- Argument ( in degrees ) C Output : FE --- F(k,phi) C EE --- E(k,phi) C ================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) G=0.0D0 PI=3.14159265358979D0 A0=1.0D0 B0=DSQRT(1.0D0-HK*HK) D0=(PI/180.0D0)*PHI R=HK*HK IF (HK.EQ.1.0D0.AND.PHI.EQ.90.0D0) THEN FE=1.0D+300 EE=1.0D0 ELSE IF (HK.EQ.1.0D0) THEN FE=DLOG((1.0D0+DSIN(D0))/DCOS(D0)) EE=DSIN(D0) ELSE FAC=1.0D0 D=0.0D0 DO 10 N=1,40 A=(A0+B0)/2.0D0 B=DSQRT(A0*B0) C=(A0-B0)/2.0D0 FAC=2.0D0*FAC R=R+FAC*C*C IF (PHI.NE.90.0D0) THEN D=D0+DATAN((B0/A0)*DTAN(D0)) G=G+C*DSIN(D) D0=D+PI*INT(D/PI+.5D0) ENDIF A0=A B0=B IF (C.LT.1.0D-7) GO TO 15 10 CONTINUE 15 CK=PI/(2.0D0*A) CE=PI*(2.0D0-R)/(4.0D0*A) IF (PHI.EQ.90.0D0) THEN FE=CK EE=CE ELSE FE=D/(FAC*A) EE=FE*CE/CK+G ENDIF ENDIF RETURN END C ********************************** SUBROUTINE ELIT3(PHI,HK,C,EL3) C C ========================================================= C Purpose: Compute the elliptic integral of the third kind C using Gauss-Legendre quadrature C Input : Phi --- Argument ( in degrees ) C k --- Modulus ( 0 ≤ k ≤ 1.0 ) C c --- Parameter ( 0 ≤ c ≤ 1.0 ) C Output: EL3 --- Value of the elliptic integral of the C third kind C ========================================================= C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION T(10),W(10) LOGICAL LB1,LB2 DATA T/.9931285991850949D0,.9639719272779138D0, & .9122344282513259D0,.8391169718222188D0, & .7463319064601508D0,.6360536807265150D0, & .5108670019508271D0,.3737060887154195D0, & .2277858511416451D0,.7652652113349734D-1/ DATA W/.1761400713915212D-1,.4060142980038694D-1, & .6267204833410907D-1,.8327674157670475D-1, & .1019301198172404D0,.1181945319615184D0, & .1316886384491766D0,.1420961093183820D0, & .1491729864726037D0,.1527533871307258D0/ LB1=HK.EQ.1.0D0.AND.DABS(PHI-90.0).LE.1.0D-8 LB2=C.EQ.1.0D0.AND.DABS(PHI-90.0).LE.1.0D-8 IF (LB1.OR.LB2) THEN EL3=1.0D+300 RETURN ENDIF C1=0.87266462599716D-2*PHI C2=C1 EL3=0.0D0 DO 10 I=1,10 C0=C2*T(I) T1=C1+C0 T2=C1-C0 F1=1.0D0/((1.0D0-C*DSIN(T1)*DSIN(T1))* & DSQRT(1.0D0-HK*HK*DSIN(T1)*DSIN(T1))) F2=1.0D0/((1.0D0-C*DSIN(T2)*DSIN(T2))* & DSQRT(1.0D0-HK*HK*DSIN(T2)*DSIN(T2))) 10 EL3=EL3+W(I)*(F1+F2) EL3=C1*EL3 RETURN END C ********************************** SUBROUTINE EIX(X,EI) C C ============================================ C Purpose: Compute exponential integral Ei(x) C Input : x --- Argument of Ei(x) C Output: EI --- Ei(x) C ============================================ C IMPLICIT DOUBLE PRECISION (A-H,O-Z) IF (X.EQ.0.0) THEN EI=-1.0D+300 ELSE IF (X .LT. 0) THEN CALL E1XB(-X, EI) EI = -EI ELSE IF (DABS(X).LE.40.0) THEN C Power series around x=0 EI=1.0D0 R=1.0D0 DO 15 K=1,100 R=R*K*X/(K+1.0D0)**2 EI=EI+R IF (DABS(R/EI).LE.1.0D-15) GO TO 20 15 CONTINUE 20 GA=0.5772156649015328D0 EI=GA+DLOG(X)+X*EI ELSE C Asymptotic expansion (the series is not convergent) EI=1.0D0 R=1.0D0 DO 25 K=1,20 R=R*K/X 25 EI=EI+R EI=EXP(X)/X*EI ENDIF RETURN END C ********************************** SUBROUTINE EIXZ(Z,CEI) C C ============================================ C Purpose: Compute exponential integral Ei(x) C Input : x --- Complex argument of Ei(x) C Output: EI --- Ei(x) C ============================================ C IMPLICIT NONE DOUBLE COMPLEX Z, CEI DOUBLE PRECISION PI PI=3.141592653589793D0 CALL E1Z(-Z, CEI) CEI = -CEI IF (DIMAG(Z).GT.0) THEN CEI = CEI + (0d0,1d0)*PI ELSE IF (DIMAG(Z).LT.0) THEN CEI = CEI - (0d0,1d0)*PI ELSE IF (DIMAG(Z).EQ.0) THEN IF (DBLE(Z).GT.0) THEN CEI = CEI + (0d0,1d0)*DSIGN(PI,DIMAG(Z)) ENDIF ENDIF RETURN END C ********************************** SUBROUTINE E1XB(X,E1) C C ============================================ C Purpose: Compute exponential integral E1(x) C Input : x --- Argument of E1(x) C Output: E1 --- E1(x) ( x > 0 ) C ============================================ C IMPLICIT DOUBLE PRECISION (A-H,O-Z) IF (X.EQ.0.0) THEN E1=1.0D+300 ELSE IF (X.LE.1.0) THEN E1=1.0D0 R=1.0D0 DO 10 K=1,25 R=-R*K*X/(K+1.0D0)**2 E1=E1+R IF (DABS(R).LE.DABS(E1)*1.0D-15) GO TO 15 10 CONTINUE 15 GA=0.5772156649015328D0 E1=-GA-DLOG(X)+X*E1 ELSE M=20+INT(80.0/X) T0=0.0D0 DO 20 K=M,1,-1 T0=K/(1.0D0+K/(X+T0)) 20 CONTINUE T=1.0D0/(X+T0) E1=EXP(-X)*T ENDIF RETURN END C ********************************** SUBROUTINE CHGM(A,B,X,HG) C C =================================================== C Purpose: Compute confluent hypergeometric function C M(a,b,x) C Input : a --- Parameter C b --- Parameter ( b <> 0,-1,-2,... ) C x --- Argument C Output: HG --- M(a,b,x) C Routine called: CGAMA for computing complex ln[Г(x)] C =================================================== C IMPLICIT DOUBLE PRECISION (A-B,D-H,O-Z) IMPLICIT COMPLEX*16 (C) PI=3.141592653589793D0 A0=A A1=A X0=X HG=0.0D0 C DLMF 13.2.39 IF (X.LT.0.0D0) THEN A=B-A A0=A X=DABS(X) ENDIF NL=0 LA=0 IF (A.GE.2.0D0) THEN C preparing terms for DLMF 13.3.1 NL=1 LA=INT(A) A=A-LA-1.0D0 ENDIF Y0=0.0D0 Y1=0.0D0 DO 30 N=0,NL IF (A0.GE.2.0D0) A=A+1.0D0 IF (X.LE.30.0D0+DABS(B).OR.A.LT.0.0D0) THEN HG=1.0D0 RG=1.0D0 DO 15 J=1,500 RG=RG*(A+J-1.0D0)/(J*(B+J-1.0D0))*X HG=HG+RG IF (HG.NE.0D0.AND.DABS(RG/HG).LT.1.0D-15) THEN C DLMF 13.2.39 (cf. above) IF (X0.LT.0.0D0) HG=HG*EXP(X0) GO TO 25 ENDIF 15 CONTINUE ELSE C DLMF 13.7.2 & 13.2.4, SUM2 corresponds to first sum Y=0.0D0 CALL CGAMA(A,Y,0,TAR,TAI) CTA = DCMPLX(TAR, TAI) Y=0.0D0 CALL CGAMA(B,Y,0,TBR,TBI) CTB = DCMPLX(TBR, TBI) XG=B-A Y=0.0D0 CALL CGAMA(XG,Y,0,TBAR,TBAI) CTBA = DCMPLX(TBAR, TBAI) SUM1=1.0D0 SUM2=1.0D0 R1=1.0D0 R2=1.0D0 DO 20 I=1,8 R1=-R1*(A+I-1.0D0)*(A-B+I)/(X*I) R2=-R2*(B-A+I-1.0D0)*(A-I)/(X*I) SUM1=SUM1+R1 20 SUM2=SUM2+R2 IF (X0.GE.0.0D0) THEN HG1=DBLE(EXP(CTB-CTBA))*X**(-A)*DCOS(PI*A)*SUM1 HG2=DBLE(EXP(CTB-CTA+X))*X**(A-B)*SUM2 ELSE C DLMF 13.2.39 (cf. above) HG1=DBLE(EXP(CTB-CTBA+X0))*X**(-A)*DCOS(PI*A)*SUM1 HG2=DBLE(EXP(CTB-CTA))*X**(A-B)*SUM2 ENDIF HG=HG1+HG2 ENDIF 25 IF (N.EQ.0) Y0=HG IF (N.EQ.1) Y1=HG 30 CONTINUE IF (A0.GE.2.0D0) THEN C DLMF 13.3.1 DO 35 I=1,LA-1 HG=((2.0D0*A-B+X)*Y1+(B-A)*Y0)/A Y0=Y1 Y1=HG 35 A=A+1.0D0 ENDIF A=A1 X=X0 RETURN END C ********************************** SUBROUTINE HYGFX(A,B,C,X,HF,ISFER) C C ==================================================== C Purpose: Compute hypergeometric function F(a,b,c,x) C Input : a --- Parameter C b --- Parameter C c --- Parameter, c <> 0,-1,-2,... C x --- Argument ( x < 1 ) C Output: HF --- F(a,b,c,x) C ISFER --- Error flag C Routines called: C (1) GAMMA2 for computing gamma function C (2) PSI_SPEC for computing psi function C ==================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) LOGICAL L0,L1,L2,L3,L4,L5 PI=3.141592653589793D0 EL=.5772156649015329D0 ISFER=0 L0=C.EQ.INT(C).AND.C.LT.0.0 L1=1.0D0-X.LT.1.0D-15.AND.C-A-B.LE.0.0 L2=A.EQ.INT(A).AND.A.LT.0.0 L3=B.EQ.INT(B).AND.B.LT.0.0 L4=C-A.EQ.INT(C-A).AND.C-A.LE.0.0 L5=C-B.EQ.INT(C-B).AND.C-B.LE.0.0 IF (L0.OR.L1) THEN ISFER=3 RETURN ENDIF EPS=1.0D-15 IF (X.GT.0.95) EPS=1.0D-8 IF (X.EQ.0.0.OR.A.EQ.0.0.OR.B.EQ.0.0) THEN HF=1.0D0 RETURN ELSE IF (1.0D0-X.EQ.EPS.AND.C-A-B.GT.0.0) THEN CALL GAMMA2(C,GC) CALL GAMMA2(C-A-B,GCAB) CALL GAMMA2(C-A,GCA) CALL GAMMA2(C-B,GCB) HF=GC*GCAB/(GCA*GCB) RETURN ELSE IF (1.0D0+X.LE.EPS.AND.DABS(C-A+B-1.0).LE.EPS) THEN G0=DSQRT(PI)*2.0D0**(-A) CALL GAMMA2(C,G1) CALL GAMMA2(1.0D0+A/2.0-B,G2) CALL GAMMA2(0.5D0+0.5*A,G3) HF=G0*G1/(G2*G3) RETURN ELSE IF (L2.OR.L3) THEN IF (L2) NM=INT(ABS(A)) IF (L3) NM=INT(ABS(B)) HF=1.0D0 R=1.0D0 DO 10 K=1,NM R=R*(A+K-1.0D0)*(B+K-1.0D0)/(K*(C+K-1.0D0))*X 10 HF=HF+R RETURN ELSE IF (L4.OR.L5) THEN IF (L4) NM=INT(ABS(C-A)) IF (L5) NM=INT(ABS(C-B)) HF=1.0D0 R=1.0D0 DO 15 K=1,NM R=R*(C-A+K-1.0D0)*(C-B+K-1.0D0)/(K*(C+K-1.0D0))*X 15 HF=HF+R HF=(1.0D0-X)**(C-A-B)*HF RETURN ENDIF AA=A BB=B X1=X IF (X.LT.0.0D0) THEN X=X/(X-1.0D0) IF (C.GT.A.AND.B.LT.A.AND.B.GT.0.0) THEN A=BB B=AA ENDIF B=C-B ENDIF HW=0.0D0 IF (X.GE.0.75D0) THEN GM=0.0D0 IF (DABS(C-A-B-INT(C-A-B)).LT.1.0D-15) THEN M=INT(C-A-B) CALL GAMMA2(A,GA) CALL GAMMA2(B,GB) CALL GAMMA2(C,GC) CALL GAMMA2(A+M,GAM) CALL GAMMA2(B+M,GBM) CALL PSI_SPEC(A,PA) CALL PSI_SPEC(B,PB) IF (M.NE.0) GM=1.0D0 DO 30 J=1,ABS(M)-1 30 GM=GM*J RM=1.0D0 DO 35 J=1,ABS(M) 35 RM=RM*J F0=1.0D0 R0=1.0D0 R1=1.0D0 SP0=0.D0 SP=0.0D0 IF (M.GE.0) THEN C0=GM*GC/(GAM*GBM) C1=-GC*(X-1.0D0)**M/(GA*GB*RM) DO 40 K=1,M-1 R0=R0*(A+K-1.0D0)*(B+K-1.0)/(K*(K-M))*(1.0-X) 40 F0=F0+R0 DO 45 K=1,M 45 SP0=SP0+1.0D0/(A+K-1.0)+1.0/(B+K-1.0)-1.0/K F1=PA+PB+SP0+2.0D0*EL+DLOG(1.0D0-X) DO 55 K=1,250 SP=SP+(1.0D0-A)/(K*(A+K-1.0))+(1.0-B)/(K*(B+K-1.0)) SM=0.0D0 DO 50 J=1,M 50 SM=SM+(1.0D0-A)/((J+K)*(A+J+K-1.0))+1.0/ & (B+J+K-1.0) RP=PA+PB+2.0D0*EL+SP+SM+DLOG(1.0D0-X) R1=R1*(A+M+K-1.0D0)*(B+M+K-1.0)/(K*(M+K))*(1.0-X) F1=F1+R1*RP IF (DABS(F1-HW).LT.DABS(F1)*EPS) GO TO 60 55 HW=F1 60 HF=F0*C0+F1*C1 ELSE IF (M.LT.0) THEN M=-M C0=GM*GC/(GA*GB*(1.0D0-X)**M) C1=-(-1)**M*GC/(GAM*GBM*RM) DO 65 K=1,M-1 R0=R0*(A-M+K-1.0D0)*(B-M+K-1.0)/(K*(K-M))*(1.0-X) 65 F0=F0+R0 DO 70 K=1,M 70 SP0=SP0+1.0D0/K F1=PA+PB-SP0+2.0D0*EL+DLOG(1.0D0-X) DO 80 K=1,250 SP=SP+(1.0D0-A)/(K*(A+K-1.0))+(1.0-B)/(K*(B+K-1.0)) SM=0.0D0 DO 75 J=1,M 75 SM=SM+1.0D0/(J+K) RP=PA+PB+2.0D0*EL+SP-SM+DLOG(1.0D0-X) R1=R1*(A+K-1.0D0)*(B+K-1.0)/(K*(M+K))*(1.0-X) F1=F1+R1*RP IF (DABS(F1-HW).LT.DABS(F1)*EPS) GO TO 85 80 HW=F1 85 HF=F0*C0+F1*C1 ENDIF ELSE CALL GAMMA2(A,GA) CALL GAMMA2(B,GB) CALL GAMMA2(C,GC) CALL GAMMA2(C-A,GCA) CALL GAMMA2(C-B,GCB) CALL GAMMA2(C-A-B,GCAB) CALL GAMMA2(A+B-C,GABC) C0=GC*GCAB/(GCA*GCB) C1=GC*GABC/(GA*GB)*(1.0D0-X)**(C-A-B) HF=0.0D0 R0=C0 R1=C1 DO 90 K=1,250 R0=R0*(A+K-1.0D0)*(B+K-1.0)/(K*(A+B-C+K))*(1.0-X) R1=R1*(C-A+K-1.0D0)*(C-B+K-1.0)/(K*(C-A-B+K)) & *(1.0-X) HF=HF+R0+R1 IF (DABS(HF-HW).LT.DABS(HF)*EPS) GO TO 95 90 HW=HF 95 HF=HF+C0+C1 ENDIF ELSE A0=1.0D0 IF (C.GT.A.AND.C.LT.2.0D0*A.AND. & C.GT.B.AND.C.LT.2.0D0*B) THEN A0=(1.0D0-X)**(C-A-B) A=C-A B=C-B ENDIF HF=1.0D0 R=1.0D0 DO 100 K=1,250 R=R*(A+K-1.0D0)*(B+K-1.0D0)/(K*(C+K-1.0D0))*X HF=HF+R IF (DABS(HF-HW).LE.DABS(HF)*EPS) GO TO 105 100 HW=HF 105 HF=A0*HF ENDIF IF (X1.LT.0.0D0) THEN X=X1 C0=1.0D0/(1.0D0-X)**AA HF=C0*HF ENDIF A=AA B=BB IF (K.GT.120) ISFER=5 RETURN END C ********************************** SUBROUTINE CCHG(A,B,Z,CHG) C C =================================================== C Purpose: Compute confluent hypergeometric function C M(a,b,z) with real parameters a, b and a C complex argument z C Input : a --- Parameter C b --- Parameter C z --- Complex argument C Output: CHG --- M(a,b,z) C Routine called: CGAMA for computing complex ln[Г(x)] C =================================================== C IMPLICIT DOUBLE PRECISION (A,B,D-H,O-Y) IMPLICIT COMPLEX *16 (C,Z) PI=3.141592653589793D0 CI=(0.0D0,1.0D0) A0=A A1=A Z0=Z IF (B.EQ.0.0.OR.B.EQ.-INT(ABS(B))) THEN CHG=(1.0D+300,0.0D0) ELSE IF (A.EQ.0.0D0.OR.Z.EQ.0.0D0) THEN CHG=(1.0D0,0.0D0) ELSE IF (A.EQ.-1.0D0) THEN CHG=1.0D0-Z/B ELSE IF (A.EQ.B) THEN CHG=EXP(Z) ELSE IF (A-B.EQ.1.0D0) THEN CHG=(1.0D0+Z/B)*EXP(Z) ELSE IF (A.EQ.1.0D0.AND.B.EQ.2.0D0) THEN CHG=(EXP(Z)-1.0D0)/Z ELSE IF (A.EQ.INT(A).AND.A.LT.0.0D0) THEN M=INT(-A) CR=(1.0D0,0.0D0) CHG=(1.0D0,0.0D0) DO 10 K=1,M CR=CR*(A+K-1.0D0)/K/(B+K-1.0D0)*Z 10 CHG=CHG+CR ELSE X0=DBLE(Z) IF (X0.LT.0.0D0) THEN A=B-A A0=A Z=-Z ENDIF NL=0 LA=0 IF (A.GE.2.0D0) THEN NL=1 LA=INT(A) A=A-LA-1.0D0 ENDIF NS=0 DO 30 N=0,NL IF (A0.GE.2.0D0) A=A+1.0D0 IF (ABS(Z).LT.20.0D0+ABS(B).OR.A.LT.0.0D0) THEN CHG=(1.0D0,0.0D0) CRG=(1.0D0,0.0D0) DO 15 J=1,500 CRG=CRG*(A+J-1.0D0)/(J*(B+J-1.0D0))*Z CHG=CHG+CRG IF (ABS((CHG-CHW)/CHG).LT.1.D-15) GO TO 25 CHW=CHG 15 CONTINUE ELSE Y=0.0D0 CALL CGAMA(A,Y,0,G1R,G1I) CG1 = DCMPLX(G1R, G1I) Y=0.0D0 CALL CGAMA(B,Y,0,G2R,G2I) CG2 = DCMPLX(G2R,G2I) BA=B-A Y=0.0D0 CALL CGAMA(BA,Y,0,G3R,G3I) CG3 = DCMPLX(G3R, G3I) CS1=(1.0D0,0.0D0) CS2=(1.0D0,0.0D0) CR1=(1.0D0,0.0D0) CR2=(1.0D0,0.0D0) DO 20 I=1,8 CR1=-CR1*(A+I-1.0D0)*(A-B+I)/(Z*I) CR2=CR2*(B-A+I-1.0D0)*(I-A)/(Z*I) CS1=CS1+CR1 20 CS2=CS2+CR2 X=DBLE(Z) Y=DIMAG(Z) IF (X.EQ.0.0.AND.Y.GE.0.0) THEN PHI=0.5D0*PI ELSE IF (X.EQ.0.0.AND.Y.LE.0.0) THEN PHI=-0.5D0*PI ELSE PHI=DATAN(Y/X) ENDIF IF (PHI.GT.-0.5*PI.AND.PHI.LT.1.5*PI) NS=1 IF (PHI.GT.-1.5*PI.AND.PHI.LE.-0.5*PI) NS=-1 CFAC=EXP(NS*CI*PI*A) IF (Y.EQ.0.0D0) CFAC=DCOS(PI*A) CHG1=EXP(CG2-CG3)*Z**(-A)*CFAC*CS1 CHG2=EXP(CG2-CG1+Z)*Z**(A-B)*CS2 CHG=CHG1+CHG2 ENDIF 25 IF (N.EQ.0) CY0=CHG IF (N.EQ.1) CY1=CHG 30 CONTINUE IF (A0.GE.2.0D0) THEN DO 35 I=1,LA-1 CHG=((2.0D0*A-B+Z)*CY1+(B-A)*CY0)/A CY0=CY1 CY1=CHG 35 A=A+1.0D0 ENDIF IF (X0.LT.0.0D0) CHG=CHG*EXP(-Z) ENDIF A=A1 Z=Z0 RETURN END C ********************************** SUBROUTINE HYGFZ(A,B,C,Z,ZHF,ISFER) C C ====================================================== C Purpose: Compute the hypergeometric function for a C complex argument, F(a,b,c,z) C Input : a --- Parameter C b --- Parameter C c --- Parameter, c <> 0,-1,-2,... C z --- Complex argument C Output: ZHF --- F(a,b,c,z) C ISFER --- Error flag C Routines called: C (1) GAMMA2 for computing gamma function C (2) PSI_SPEC for computing psi function C ====================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Y) IMPLICIT COMPLEX *16 (Z) LOGICAL L0,L1,L2,L3,L4,L5,L6 X=DBLE(Z) Y=DIMAG(Z) EPS=1.0D-15 ISFER=0 L0=C.EQ.INT(C).AND.C.LT.0.0D0 L1=DABS(1.0D0-X).LT.EPS.AND.Y.EQ.0.0D0.AND.C-A-B.LE.0.0D0 L2=ABS(Z+1.0D0).LT.EPS.AND.DABS(C-A+B-1.0D0).LT.EPS L3=A.EQ.INT(A).AND.A.LT.0.0D0 L4=B.EQ.INT(B).AND.B.LT.0.0D0 L5=C-A.EQ.INT(C-A).AND.C-A.LE.0.0D0 L6=C-B.EQ.INT(C-B).AND.C-B.LE.0.0D0 AA=A BB=B A0=ABS(Z) IF (A0.GT.0.95D0) EPS=1.0D-8 PI=3.141592653589793D0 EL=.5772156649015329D0 IF (L0.OR.L1) THEN ISFER=3 RETURN ENDIF NM=0 IF (A0.EQ.0.0D0.OR.A.EQ.0.0D0.OR.B.EQ.0.0D0) THEN ZHF=(1.0D0,0.0D0) ELSE IF (Z.EQ.1.0D0.AND.C-A-B.GT.0.0D0) THEN CALL GAMMA2(C,GC) CALL GAMMA2(C-A-B,GCAB) CALL GAMMA2(C-A,GCA) CALL GAMMA2(C-B,GCB) ZHF=GC*GCAB/(GCA*GCB) ELSE IF (L2) THEN G0=DSQRT(PI)*2.0D0**(-A) CALL GAMMA2(C,G1) CALL GAMMA2(1.0D0+A/2.0D0-B,G2) CALL GAMMA2(0.5D0+0.5D0*A,G3) ZHF=G0*G1/(G2*G3) ELSE IF (L3.OR.L4) THEN IF (L3) NM=INT(ABS(A)) IF (L4) NM=INT(ABS(B)) ZHF=(1.0D0,0.0D0) ZR=(1.0D0,0.0D0) DO 10 K=1,NM ZR=ZR*(A+K-1.0D0)*(B+K-1.0D0)/(K*(C+K-1.0D0))*Z 10 ZHF=ZHF+ZR ELSE IF (L5.OR.L6) THEN IF (L5) NM=INT(ABS(C-A)) IF (L6) NM=INT(ABS(C-B)) ZHF=(1.0D0,0.0D0) ZR=(1.0D0,0.0D0) DO 15 K=1,NM ZR=ZR*(C-A+K-1.0D0)*(C-B+K-1.0D0)/(K*(C+K-1.0D0))*Z 15 ZHF=ZHF+ZR ZHF=(1.0D0-Z)**(C-A-B)*ZHF ELSE IF (A0.LE.1.0D0) THEN IF (X.LT.0.0D0) THEN Z1=Z/(Z-1.0D0) IF (C.GT.A.AND.B.LT.A.AND.B.GT.0.0) THEN A=BB B=AA ENDIF ZC0=1.0D0/((1.0D0-Z)**A) ZHF=(1.0D0,0.0D0) ZR0=(1.0D0,0.0D0) DO 20 K=1,500 ZR0=ZR0*(A+K-1.0D0)*(C-B+K-1.0D0)/(K*(C+K-1.0D0))*Z1 ZHF=ZHF+ZR0 IF (ABS(ZHF-ZW).LT.ABS(ZHF)*EPS) GO TO 25 20 ZW=ZHF 25 ZHF=ZC0*ZHF ELSE IF (A0.GE.0.90D0) THEN GM=0.0D0 MCAB=INT(C-A-B+EPS*DSIGN(1.0D0,C-A-B)) IF (DABS(C-A-B-MCAB).LT.EPS) THEN M=INT(C-A-B) CALL GAMMA2(A,GA) CALL GAMMA2(B,GB) CALL GAMMA2(C,GC) CALL GAMMA2(A+M,GAM) CALL GAMMA2(B+M,GBM) CALL PSI_SPEC(A,PA) CALL PSI_SPEC(B,PB) IF (M.NE.0) GM=1.0D0 DO 30 J=1,ABS(M)-1 30 GM=GM*J RM=1.0D0 DO 35 J=1,ABS(M) 35 RM=RM*J ZF0=(1.0D0,0.0D0) ZR0=(1.0D0,0.0D0) ZR1=(1.0D0,0.0D0) SP0=0.D0 SP=0.0D0 IF (M.GE.0) THEN ZC0=GM*GC/(GAM*GBM) ZC1=-GC*(Z-1.0D0)**M/(GA*GB*RM) DO 40 K=1,M-1 ZR0=ZR0*(A+K-1.D0)*(B+K-1.D0)/(K*(K-M))*(1.D0-Z) 40 ZF0=ZF0+ZR0 DO 45 K=1,M 45 SP0=SP0+1.0D0/(A+K-1.0D0)+1.0/(B+K-1.0D0)-1.D0/K ZF1=PA+PB+SP0+2.0D0*EL+LOG(1.0D0-Z) DO 55 K=1,500 SP=SP+(1.0D0-A)/(K*(A+K-1.0D0))+(1.0D0-B)/ & (K*(B+K-1.0D0)) SM=0.0D0 DO 50 J=1,M SM=SM+(1.0D0-A)/((J+K)*(A+J+K-1.0D0)) & +1.0D0/(B+J+K-1.0D0) 50 CONTINUE ZP=PA+PB+2.0D0*EL+SP+SM+LOG(1.0D0-Z) ZR1=ZR1*(A+M+K-1.0D0)*(B+M+K-1.0D0)/(K*(M+K)) & *(1.0D0-Z) ZF1=ZF1+ZR1*ZP IF (ABS(ZF1-ZW).LT.ABS(ZF1)*EPS) GO TO 60 55 ZW=ZF1 60 ZHF=ZF0*ZC0+ZF1*ZC1 ELSE IF (M.LT.0) THEN M=-M ZC0=GM*GC/(GA*GB*(1.0D0-Z)**M) ZC1=-(-1)**M*GC/(GAM*GBM*RM) DO 65 K=1,M-1 ZR0=ZR0*(A-M+K-1.0D0)*(B-M+K-1.0D0)/(K*(K-M)) & *(1.0D0-Z) 65 ZF0=ZF0+ZR0 DO 70 K=1,M 70 SP0=SP0+1.0D0/K ZF1=PA+PB-SP0+2.0D0*EL+LOG(1.0D0-Z) DO 80 K=1,500 SP=SP+(1.0D0-A)/(K*(A+K-1.0D0))+(1.0D0-B)/(K* & (B+K-1.0D0)) SM=0.0D0 DO 75 J=1,M 75 SM=SM+1.0D0/(J+K) ZP=PA+PB+2.0D0*EL+SP-SM+LOG(1.0D0-Z) ZR1=ZR1*(A+K-1.D0)*(B+K-1.D0)/(K*(M+K))*(1.D0-Z) ZF1=ZF1+ZR1*ZP IF (ABS(ZF1-ZW).LT.ABS(ZF1)*EPS) GO TO 85 80 ZW=ZF1 85 ZHF=ZF0*ZC0+ZF1*ZC1 ENDIF ELSE CALL GAMMA2(A,GA) CALL GAMMA2(B,GB) CALL GAMMA2(C,GC) CALL GAMMA2(C-A,GCA) CALL GAMMA2(C-B,GCB) CALL GAMMA2(C-A-B,GCAB) CALL GAMMA2(A+B-C,GABC) ZC0=GC*GCAB/(GCA*GCB) ZC1=GC*GABC/(GA*GB)*(1.0D0-Z)**(C-A-B) ZHF=(0.0D0,0.0D0) ZR0=ZC0 ZR1=ZC1 DO 90 K=1,500 ZR0=ZR0*(A+K-1.D0)*(B+K-1.D0)/(K*(A+B-C+K))*(1.D0-Z) ZR1=ZR1*(C-A+K-1.0D0)*(C-B+K-1.0D0)/(K*(C-A-B+K)) & *(1.0D0-Z) ZHF=ZHF+ZR0+ZR1 IF (ABS(ZHF-ZW).LT.ABS(ZHF)*EPS) GO TO 95 90 ZW=ZHF 95 ZHF=ZHF+ZC0+ZC1 ENDIF ELSE Z00=(1.0D0,0.0D0) IF (C-A.LT.A.AND.C-B.LT.B) THEN Z00=(1.0D0-Z)**(C-A-B) A=C-A B=C-B ENDIF ZHF=(1.0D0,0.D0) ZR=(1.0D0,0.0D0) DO 100 K=1,1500 ZR=ZR*(A+K-1.0D0)*(B+K-1.0D0)/(K*(C+K-1.0D0))*Z ZHF=ZHF+ZR IF (ABS(ZHF-ZW).LE.ABS(ZHF)*EPS) GO TO 105 100 ZW=ZHF 105 ZHF=Z00*ZHF ENDIF ELSE IF (A0.GT.1.0D0) THEN MAB=INT(A-B+EPS*DSIGN(1.0D0,A-B)) IF (DABS(A-B-MAB).LT.EPS.AND.A0.LE.1.1D0) B=B+EPS IF (DABS(A-B-MAB).GT.EPS) THEN CALL GAMMA2(A,GA) CALL GAMMA2(B,GB) CALL GAMMA2(C,GC) CALL GAMMA2(A-B,GAB) CALL GAMMA2(B-A,GBA) CALL GAMMA2(C-A,GCA) CALL GAMMA2(C-B,GCB) ZC0=GC*GBA/(GCA*GB*(-Z)**A) ZC1=GC*GAB/(GCB*GA*(-Z)**B) ZR0=ZC0 ZR1=ZC1 ZHF=(0.0D0,0.0D0) DO 110 K=1,500 ZR0=ZR0*(A+K-1.0D0)*(A-C+K)/((A-B+K)*K*Z) ZR1=ZR1*(B+K-1.0D0)*(B-C+K)/((B-A+K)*K*Z) ZHF=ZHF+ZR0+ZR1 IF (ABS((ZHF-ZW)/ZHF).LE.EPS) GO TO 115 110 ZW=ZHF 115 ZHF=ZHF+ZC0+ZC1 ELSE IF (A-B.LT.0.0D0) THEN A=BB B=AA ENDIF CA=C-A CB=C-B NCA=INT(CA+EPS*DSIGN(1.0D0,CA)) NCB=INT(CB+EPS*DSIGN(1.0D0,CB)) IF (DABS(CA-NCA).LT.EPS.OR.DABS(CB-NCB).LT.EPS) C=C+EPS CALL GAMMA2(A,GA) CALL GAMMA2(C,GC) CALL GAMMA2(C-B,GCB) CALL PSI_SPEC(A,PA) CALL PSI_SPEC(C-A,PCA) CALL PSI_SPEC(A-C,PAC) MAB=INT(A-B+EPS) ZC0=GC/(GA*(-Z)**B) CALL GAMMA2(A-B,GM) ZF0=GM/GCB*ZC0 ZR=ZC0 DO 120 K=1,MAB-1 ZR=ZR*(B+K-1.0D0)/(K*Z) T0=A-B-K CALL GAMMA2(T0,G0) CALL GAMMA2(C-B-K,GCBK) 120 ZF0=ZF0+ZR*G0/GCBK IF (MAB.EQ.0) ZF0=(0.0D0,0.0D0) ZC1=GC/(GA*GCB*(-Z)**A) SP=-2.0D0*EL-PA-PCA DO 125 J=1,MAB 125 SP=SP+1.0D0/J ZP0=SP+LOG(-Z) SQ=1.0D0 DO 130 J=1,MAB 130 SQ=SQ*(B+J-1.0D0)*(B-C+J)/J ZF1=(SQ*ZP0)*ZC1 ZR=ZC1 RK1=1.0D0 SJ1=0.0D0 W0=0.0D0 DO 145 K=1,10000 ZR=ZR/Z RK1=RK1*(B+K-1.0D0)*(B-C+K)/(K*K) RK2=RK1 DO 135 J=K+1,K+MAB 135 RK2=RK2*(B+J-1.0D0)*(B-C+J)/J SJ1=SJ1+(A-1.0D0)/(K*(A+K-1.0D0))+(A-C-1.0D0)/ & (K*(A-C+K-1.0D0)) SJ2=SJ1 DO 140 J=K+1,K+MAB 140 SJ2=SJ2+1.0D0/J ZP=-2.0D0*EL-PA-PAC+SJ2-1.0D0/(K+A-C) & -PI/DTAN(PI*(K+A-C))+LOG(-Z) ZF1=ZF1+RK2*ZR*ZP WS=ABS(ZF1) IF (DABS((WS-W0)/WS).LT.EPS) GO TO 150 145 W0=WS 150 ZHF=ZF0+ZF1 ENDIF ENDIF A=AA B=BB IF (K.GT.150) ISFER=5 RETURN END C ********************************** SUBROUTINE ITAIRY(X,APT,BPT,ANT,BNT) C C ====================================================== C Purpose: Compute the integrals of Airy fnctions with C respect to t from 0 and x ( x ≥ 0 ) C Input : x --- Upper limit of the integral C Output : APT --- Integration of Ai(t) from 0 and x C BPT --- Integration of Bi(t) from 0 and x C ANT --- Integration of Ai(-t) from 0 and x C BNT --- Integration of Bi(-t) from 0 and x C ====================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION A(16) EPS=1.0D-15 PI=3.141592653589793D0 C1=.355028053887817D0 C2=.258819403792807D0 SR3=1.732050807568877D0 IF (X.EQ.0.0D0) THEN APT=0.0D0 BPT=0.0D0 ANT=0.0D0 BNT=0.0D0 ELSE IF (DABS(X).LE.9.25D0) THEN DO 30 L=0,1 X=(-1)**L*X FX=X R=X DO 10 K=1,40 R=R*(3.0*K-2.0D0)/(3.0*K+1.0D0)*X/(3.0*K) & *X/(3.0*K-1.0D0)*X FX=FX+R IF (DABS(R).LT.DABS(FX)*EPS) GO TO 15 10 CONTINUE 15 GX=.5D0*X*X R=GX DO 20 K=1,40 R=R*(3.0*K-1.0D0)/(3.0*K+2.0D0)*X/(3.0*K) & *X/(3.0*K+1.0D0)*X GX=GX+R IF (DABS(R).LT.DABS(GX)*EPS) GO TO 25 20 CONTINUE 25 ANT=C1*FX-C2*GX BNT=SR3*(C1*FX+C2*GX) IF (L.EQ.0) THEN APT=ANT BPT=BNT ELSE ANT=-ANT BNT=-BNT X=-X ENDIF 30 CONTINUE ELSE DATA A/.569444444444444D0,.891300154320988D0, & .226624344493027D+01,.798950124766861D+01, & .360688546785343D+02,.198670292131169D+03, & .129223456582211D+04,.969483869669600D+04, & .824184704952483D+05,.783031092490225D+06, & .822210493622814D+07,.945557399360556D+08, & .118195595640730D+10,.159564653040121D+11, & .231369166433050D+12,.358622522796969D+13/ Q2=1.414213562373095D0 Q0=.3333333333333333D0 Q1=.6666666666666667D0 XE=X*DSQRT(X)/1.5D0 XP6=1.0D0/DSQRT(6.0D0*PI*XE) SU1=1.0D0 R=1.0D0 XR1=1.0D0/XE DO 35 K=1,16 R=-R*XR1 35 SU1=SU1+A(K)*R SU2=1.0D0 R=1.0D0 DO 40 K=1,16 R=R*XR1 40 SU2=SU2+A(K)*R APT=Q0-EXP(-XE)*XP6*SU1 BPT=2.0D0*EXP(XE)*XP6*SU2 SU3=1.0D0 R=1.0D0 XR2=1.0D0/(XE*XE) DO 45 K=1,8 R=-R*XR2 45 SU3=SU3+A(2*K)*R SU4=A(1)*XR1 R=XR1 DO 50 K=1,7 R=-R*XR2 50 SU4=SU4+A(2*K+1)*R SU5=SU3+SU4 SU6=SU3-SU4 ANT=Q1-Q2*XP6*(SU5*DCOS(XE)-SU6*DSIN(XE)) BNT=Q2*XP6*(SU5*DSIN(XE)+SU6*DCOS(XE)) ENDIF ENDIF RETURN END C ********************************** SUBROUTINE IKNA(N,X,NM,BI,DI,BK,DK) C C ======================================================== C Purpose: Compute modified Bessel functions In(x) and C Kn(x), and their derivatives C Input: x --- Argument of In(x) and Kn(x) ( x ≥ 0 ) C n --- Order of In(x) and Kn(x) C Output: BI(n) --- In(x) C DI(n) --- In'(x) C BK(n) --- Kn(x) C DK(n) --- Kn'(x) C NM --- Highest order computed C Routines called: C (1) IK01A for computing I0(x),I1(x),K0(x) & K1(x) C (2) MSTA1 and MSTA2 for computing the starting C point for backward recurrence C ======================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION BI(0:N),DI(0:N),BK(0:N),DK(0:N) NM=N IF (X.LE.1.0D-100) THEN DO 10 K=0,N BI(K)=0.0D0 DI(K)=0.0D0 BK(K)=1.0D+300 10 DK(K)=-1.0D+300 BI(0)=1.0D0 DI(1)=0.5D0 RETURN ENDIF CALL IK01A(X,BI0,DI0,BI1,DI1,BK0,DK0,BK1,DK1) BI(0)=BI0 BI(1)=BI1 BK(0)=BK0 BK(1)=BK1 DI(0)=DI0 DI(1)=DI1 DK(0)=DK0 DK(1)=DK1 IF (N.LE.1) RETURN IF (X.GT.40.0.AND.N.LT.INT(0.25*X)) THEN H0=BI0 H1=BI1 DO 15 K=2,N H=-2.0D0*(K-1.0D0)/X*H1+H0 BI(K)=H H0=H1 15 H1=H ELSE M=MSTA1(X,200) IF (M.LT.N) THEN NM=M ELSE M=MSTA2(X,N,15) ENDIF F0=0.0D0 F1=1.0D-100 F=0.0D0 DO 20 K=M,0,-1 F=2.0D0*(K+1.0D0)*F1/X+F0 IF (K.LE.NM) BI(K)=F F0=F1 20 F1=F S0=BI0/F DO 25 K=0,NM 25 BI(K)=S0*BI(K) ENDIF G0=BK0 G1=BK1 DO 30 K=2,NM G=2.0D0*(K-1.0D0)/X*G1+G0 BK(K)=G G0=G1 30 G1=G DO 40 K=2,NM DI(K)=BI(K-1)-K/X*BI(K) 40 DK(K)=-BK(K-1)-K/X*BK(K) RETURN END C ********************************** SUBROUTINE CJYNB(N,Z,NM,CBJ,CDJ,CBY,CDY) C C ======================================================= C Purpose: Compute Bessel functions Jn(z), Yn(z) and C their derivatives for a complex argument C Input : z --- Complex argument of Jn(z) and Yn(z) C n --- Order of Jn(z) and Yn(z) C Output: CBJ(n) --- Jn(z) C CDJ(n) --- Jn'(z) C CBY(n) --- Yn(z) C CDY(n) --- Yn'(z) C NM --- Highest order computed C Routines called: C MSTA1 and MSTA2 to calculate the starting C point for backward recurrence C ======================================================= C IMPLICIT DOUBLE PRECISION (A,B,D-H,O-Y) IMPLICIT COMPLEX*16 (C,Z) DIMENSION CBJ(0:N),CDJ(0:N),CBY(0:N),CDY(0:N), & A(4),B(4),A1(4),B1(4) EL=0.5772156649015329D0 PI=3.141592653589793D0 R2P=.63661977236758D0 Y0=DABS(DIMAG(Z)) A0=ABS(Z) NM=N IF (A0.LT.1.0D-100) THEN DO 10 K=0,N CBJ(K)=(0.0D0,0.0D0) CDJ(K)=(0.0D0,0.0D0) CBY(K)=-(1.0D+300,0.0D0) 10 CDY(K)=(1.0D+300,0.0D0) CBJ(0)=(1.0D0,0.0D0) CDJ(1)=(0.5D0,0.0D0) RETURN ENDIF IF (A0.LE.300.D0.OR.N.GT.80) THEN IF (N.EQ.0) NM=1 M=MSTA1(A0,200) IF (M.LT.NM) THEN NM=M ELSE M=MSTA2(A0,NM,15) ENDIF CBS=(0.0D0,0.0D0) CSU=(0.0D0,0.0D0) CSV=(0.0D0,0.0D0) CF2=(0.0D0,0.0D0) CF1=(1.0D-100,0.0D0) DO 15 K=M,0,-1 CF=2.0D0*(K+1.0D0)/Z*CF1-CF2 IF (K.LE.NM) CBJ(K)=CF IF (K.EQ.2*INT(K/2).AND.K.NE.0) THEN IF (Y0.LE.1.0D0) THEN CBS=CBS+2.0D0*CF ELSE CBS=CBS+(-1)**(K/2)*2.0D0*CF ENDIF CSU=CSU+(-1)**(K/2)*CF/K ELSE IF (K.GT.1) THEN CSV=CSV+(-1)**(K/2)*K/(K*K-1.0D0)*CF ENDIF CF2=CF1 15 CF1=CF IF (Y0.LE.1.0D0) THEN CS0=CBS+CF ELSE CS0=(CBS+CF)/COS(Z) ENDIF DO 20 K=0,NM 20 CBJ(K)=CBJ(K)/CS0 CE=LOG(Z/2.0D0)+EL CBY(0)=R2P*(CE*CBJ(0)-4.0D0*CSU/CS0) CBY(1)=R2P*(-CBJ(0)/Z+(CE-1.0D0)*CBJ(1)-4.0D0*CSV/CS0) ELSE DATA A/-.7031250000000000D-01,.1121520996093750D+00, & -.5725014209747314D+00,.6074042001273483D+01/ DATA B/ .7324218750000000D-01,-.2271080017089844D+00, & .1727727502584457D+01,-.2438052969955606D+02/ DATA A1/.1171875000000000D+00,-.1441955566406250D+00, & .6765925884246826D+00,-.6883914268109947D+01/ DATA B1/-.1025390625000000D+00,.2775764465332031D+00, & -.1993531733751297D+01,.2724882731126854D+02/ CT1=Z-0.25D0*PI CP0=(1.0D0,0.0D0) DO 25 K=1,4 25 CP0=CP0+A(K)*Z**(-2*K) CQ0=-0.125D0/Z DO 30 K=1,4 30 CQ0=CQ0+B(K)*Z**(-2*K-1) CU=SQRT(R2P/Z) CBJ0=CU*(CP0*COS(CT1)-CQ0*SIN(CT1)) CBY0=CU*(CP0*SIN(CT1)+CQ0*COS(CT1)) CBJ(0)=CBJ0 CBY(0)=CBY0 CT2=Z-0.75D0*PI CP1=(1.0D0,0.0D0) DO 35 K=1,4 35 CP1=CP1+A1(K)*Z**(-2*K) CQ1=0.375D0/Z DO 40 K=1,4 40 CQ1=CQ1+B1(K)*Z**(-2*K-1) CBJ1=CU*(CP1*COS(CT2)-CQ1*SIN(CT2)) CBY1=CU*(CP1*SIN(CT2)+CQ1*COS(CT2)) CBJ(1)=CBJ1 CBY(1)=CBY1 DO 45 K=2,NM CBJK=2.0D0*(K-1.0D0)/Z*CBJ1-CBJ0 CBJ(K)=CBJK CBJ0=CBJ1 45 CBJ1=CBJK ENDIF CDJ(0)=-CBJ(1) DO 50 K=1,NM 50 CDJ(K)=CBJ(K-1)-K/Z*CBJ(K) IF (ABS(CBJ(0)).GT.1.0D0) THEN CBY(1)=(CBJ(1)*CBY(0)-2.0D0/(PI*Z))/CBJ(0) ENDIF DO 55 K=2,NM IF (ABS(CBJ(K-1)).GE.ABS(CBJ(K-2))) THEN CYY=(CBJ(K)*CBY(K-1)-2.0D0/(PI*Z))/CBJ(K-1) ELSE CYY=(CBJ(K)*CBY(K-2)-4.0D0*(K-1.0D0)/(PI*Z*Z))/CBJ(K-2) ENDIF CBY(K)=CYY 55 CONTINUE CDY(0)=-CBY(1) DO 60 K=1,NM 60 CDY(K)=CBY(K-1)-K/Z*CBY(K) RETURN END C ********************************** SUBROUTINE IKNB(N,X,NM,BI,DI,BK,DK) C C ============================================================ C Purpose: Compute modified Bessel functions In(x) and Kn(x), C and their derivatives C Input: x --- Argument of In(x) and Kn(x) ( 0 ≤ x ≤ 700 ) C n --- Order of In(x) and Kn(x) C Output: BI(n) --- In(x) C DI(n) --- In'(x) C BK(n) --- Kn(x) C DK(n) --- Kn'(x) C NM --- Highest order computed C Routines called: C MSTA1 and MSTA2 for computing the starting point C for backward recurrence C =========================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION BI(0:N),DI(0:N),BK(0:N),DK(0:N) PI=3.141592653589793D0 EL=0.5772156649015329D0 NM=N IF (X.LE.1.0D-100) THEN DO 10 K=0,N BI(K)=0.0D0 DI(K)=0.0D0 BK(K)=1.0D+300 10 DK(K)=-1.0D+300 BI(0)=1.0D0 DI(1)=0.5D0 RETURN ENDIF IF (N.EQ.0) NM=1 M=MSTA1(X,200) IF (M.LT.NM) THEN NM=M ELSE M=MSTA2(X,NM,15) ENDIF BS=0.0D0 SK0=0.0D0 F=0.0D0 F0=0.0D0 F1=1.0D-100 DO 15 K=M,0,-1 F=2.0D0*(K+1.0D0)/X*F1+F0 IF (K.LE.NM) BI(K)=F IF (K.NE.0.AND.K.EQ.2*INT(K/2)) SK0=SK0+4.0D0*F/K BS=BS+2.0D0*F F0=F1 15 F1=F S0=EXP(X)/(BS-F) DO 20 K=0,NM 20 BI(K)=S0*BI(K) IF (X.LE.8.0D0) THEN BK(0)=-(DLOG(0.5D0*X)+EL)*BI(0)+S0*SK0 BK(1)=(1.0D0/X-BI(1)*BK(0))/BI(0) ELSE A0=DSQRT(PI/(2.0D0*X))*EXP(-X) K0=16 IF (X.GE.25.0) K0=10 IF (X.GE.80.0) K0=8 IF (X.GE.200.0) K0=6 DO 30 L=0,1 BKL=1.0D0 VT=4.0D0*L R=1.0D0 DO 25 K=1,K0 R=0.125D0*R*(VT-(2.0*K-1.0)**2)/(K*X) 25 BKL=BKL+R BK(L)=A0*BKL 30 CONTINUE ENDIF G0=BK(0) G1=BK(1) DO 35 K=2,NM G=2.0D0*(K-1.0D0)/X*G1+G0 BK(K)=G G0=G1 35 G1=G DI(0)=BI(1) DK(0)=-BK(1) DO 40 K=1,NM DI(K)=BI(K-1)-K/X*BI(K) 40 DK(K)=-BK(K-1)-K/X*BK(K) RETURN END C ********************************** SUBROUTINE LPMN(MM,M,N,X,PM,PD) C C ===================================================== C Purpose: Compute the associated Legendre functions C Pmn(x) and their derivatives Pmn'(x) for C real argument C Input : x --- Argument of Pmn(x) C m --- Order of Pmn(x), m = 0,1,2,...,n C n --- Degree of Pmn(x), n = 0,1,2,...,N C mm --- Physical dimension of PM and PD C Output: PM(m,n) --- Pmn(x) C PD(m,n) --- Pmn'(x) C ===================================================== C IMPLICIT DOUBLE PRECISION (D,P,X) DIMENSION PM(0:MM,0:N),PD(0:MM,0:N) INTRINSIC MIN DO 10 I=0,N DO 10 J=0,M PM(J,I)=0.0D0 10 PD(J,I)=0.0D0 PM(0,0)=1.0D0 IF (N.EQ.0) RETURN IF (DABS(X).EQ.1.0D0) THEN DO 15 I=1,N PM(0,I)=X**I 15 PD(0,I)=0.5D0*I*(I+1.0D0)*X**(I+1) DO 20 J=1,N DO 20 I=1,M IF (I.EQ.1) THEN PD(I,J)=DINF() ELSE IF (I.EQ.2) THEN PD(I,J)=-0.25D0*(J+2)*(J+1)*J*(J-1)*X**(J+1) ENDIF 20 CONTINUE RETURN ENDIF LS=1 IF (DABS(X).GT.1.0D0) LS=-1 XQ=DSQRT(LS*(1.0D0-X*X)) C Ensure connection to the complex-valued function for |x| > 1 IF (X.LT.-1D0) XQ=-XQ XS=LS*(1.0D0-X*X) DO 30 I=1,M 30 PM(I,I)=-LS*(2.0D0*I-1.0D0)*XQ*PM(I-1,I-1) DO 35 I=0,MIN(M,N-1) 35 PM(I,I+1)=(2.0D0*I+1.0D0)*X*PM(I,I) DO 40 I=0,M DO 40 J=I+2,N PM(I,J)=((2.0D0*J-1.0D0)*X*PM(I,J-1)- & (I+J-1.0D0)*PM(I,J-2))/(J-I) 40 CONTINUE PD(0,0)=0.0D0 DO 45 J=1,N 45 PD(0,J)=LS*J*(PM(0,J-1)-X*PM(0,J))/XS DO 50 I=1,M DO 50 J=I,N PD(I,J)=LS*I*X*PM(I,J)/XS+(J+I) & *(J-I+1.0D0)/XQ*PM(I-1,J) 50 CONTINUE RETURN END C ********************************** SUBROUTINE MTU0(KF,M,Q,X,CSF,CSD) C C =============================================================== C Purpose: Compute Mathieu functions cem(x,q) and sem(x,q) C and their derivatives ( q ≥ 0 ) C Input : KF --- Function code C KF=1 for computing cem(x,q) and cem'(x,q) C KF=2 for computing sem(x,q) and sem'(x,q) C m --- Order of Mathieu functions C q --- Parameter of Mathieu functions C x --- Argument of Mathieu functions (in degrees) C Output: CSF --- cem(x,q) or sem(x,q) C CSD --- cem'x,q) or sem'x,q) C Routines called: C (1) CVA2 for computing the characteristic values C (2) FCOEF for computing the expansion coefficients C =============================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION FG(251) EPS=1.0D-14 IF (KF.EQ.1.AND.M.EQ.2*INT(M/2)) KD=1 IF (KF.EQ.1.AND.M.NE.2*INT(M/2)) KD=2 IF (KF.EQ.2.AND.M.NE.2*INT(M/2)) KD=3 IF (KF.EQ.2.AND.M.EQ.2*INT(M/2)) KD=4 CALL CVA2(KD,M,Q,A) IF (Q.LE.1.0D0) THEN QM=7.5+56.1*SQRT(Q)-134.7*Q+90.7*SQRT(Q)*Q ELSE QM=17.0+3.1*SQRT(Q)-.126*Q+.0037*SQRT(Q)*Q ENDIF KM=INT(QM+0.5*M) IF(KM.GT.251) THEN CSF=DNAN() CSD=DNAN() RETURN END IF CALL FCOEF(KD,M,Q,A,FG) IC=INT(M/2)+1 RD=1.74532925199433D-2 XR=X*RD CSF=0.0D0 DO 10 K=1,KM IF (KD.EQ.1) THEN CSF=CSF+FG(K)*DCOS((2*K-2)*XR) ELSE IF (KD.EQ.2) THEN CSF=CSF+FG(K)*DCOS((2*K-1)*XR) ELSE IF (KD.EQ.3) THEN CSF=CSF+FG(K)*DSIN((2*K-1)*XR) ELSE IF (KD.EQ.4) THEN CSF=CSF+FG(K)*DSIN(2*K*XR) ENDIF IF (K.GE.IC.AND.DABS(FG(K)).LT.DABS(CSF)*EPS) GO TO 15 10 CONTINUE 15 CSD=0.0D0 DO 20 K=1,KM IF (KD.EQ.1) THEN CSD=CSD-(2*K-2)*FG(K)*DSIN((2*K-2)*XR) ELSE IF (KD.EQ.2) THEN CSD=CSD-(2*K-1)*FG(K)*DSIN((2*K-1)*XR) ELSE IF (KD.EQ.3) THEN CSD=CSD+(2*K-1)*FG(K)*DCOS((2*K-1)*XR) ELSE IF (KD.EQ.4) THEN CSD=CSD+2.0D0*K*FG(K)*DCOS(2*K*XR) ENDIF IF (K.GE.IC.AND.DABS(FG(K)).LT.DABS(CSD)*EPS) GO TO 25 20 CONTINUE 25 RETURN END C ********************************** SUBROUTINE CY01(KF,Z,ZF,ZD) C C =========================================================== C Purpose: Compute complex Bessel functions Y0(z), Y1(z) C and their derivatives C Input : z --- Complex argument of Yn(z) ( n=0,1 ) C KF --- Function choice code C KF=0 for ZF=Y0(z) and ZD=Y0'(z) C KF=1 for ZF=Y1(z) and ZD=Y1'(z) C KF=2 for ZF=Y1'(z) and ZD=Y1''(z) C Output: ZF --- Y0(z) or Y1(z) or Y1'(z) C ZD --- Y0'(z) or Y1'(z) or Y1''(z) C =========================================================== C IMPLICIT DOUBLE PRECISION (A,B,E,P,R,W) IMPLICIT COMPLEX*16 (C,Z) DIMENSION A(12),B(12),A1(12),B1(12) PI=3.141592653589793D0 EL=0.5772156649015329D0 RP2=2.0D0/PI CI=(0.0D0,1.0D0) A0=ABS(Z) Z2=Z*Z Z1=Z IF (A0.EQ.0.0D0) THEN CBJ0=(1.0D0,0.0D0) CBJ1=(0.0D0,0.0D0) CBY0=-(1.0D300,0.0D0) CBY1=-(1.0D300,0.0D0) CDY0=(1.0D300,0.0D0) CDY1=(1.0D300,0.0D0) GO TO 70 ENDIF IF (DBLE(Z).LT.0.0) Z1=-Z IF (A0.LE.12.0) THEN CBJ0=(1.0D0,0.0D0) CR=(1.0D0,0.0D0) DO 10 K=1,40 CR=-0.25D0*CR*Z2/(K*K) CBJ0=CBJ0+CR IF (ABS(CR).LT.ABS(CBJ0)*1.0D-15) GO TO 15 10 CONTINUE 15 CBJ1=(1.0D0,0.0D0) CR=(1.0D0,0.0D0) DO 20 K=1,40 CR=-0.25D0*CR*Z2/(K*(K+1.0D0)) CBJ1=CBJ1+CR IF (ABS(CR).LT.ABS(CBJ1)*1.0D-15) GO TO 25 20 CONTINUE 25 CBJ1=0.5D0*Z1*CBJ1 W0=0.0D0 CR=(1.0D0,0.0D0) CS=(0.0D0,0.0D0) DO 30 K=1,40 W0=W0+1.0D0/K CR=-0.25D0*CR/(K*K)*Z2 CP=CR*W0 CS=CS+CP IF (ABS(CP).LT.ABS(CS)*1.0D-15) GO TO 35 30 CONTINUE 35 CBY0=RP2*(LOG(Z1/2.0D0)+EL)*CBJ0-RP2*CS W1=0.0D0 CR=(1.0D0,0.0D0) CS=(1.0D0,0.0D0) DO 40 K=1,40 W1=W1+1.0D0/K CR=-0.25D0*CR/(K*(K+1))*Z2 CP=CR*(2.0D0*W1+1.0D0/(K+1.0D0)) CS=CS+CP IF (ABS(CP).LT.ABS(CS)*1.0D-15) GO TO 45 40 CONTINUE 45 CBY1=RP2*((LOG(Z1/2.0D0)+EL)*CBJ1-1.0D0/Z1-.25D0*Z1*CS) ELSE DATA A/-.703125D-01,.112152099609375D+00, & -.5725014209747314D+00,.6074042001273483D+01, & -.1100171402692467D+03,.3038090510922384D+04, & -.1188384262567832D+06,.6252951493434797D+07, & -.4259392165047669D+09,.3646840080706556D+11, & -.3833534661393944D+13,.4854014686852901D+15/ DATA B/ .732421875D-01,-.2271080017089844D+00, & .1727727502584457D+01,-.2438052969955606D+02, & .5513358961220206D+03,-.1825775547429318D+05, & .8328593040162893D+06,-.5006958953198893D+08, & .3836255180230433D+10,-.3649010818849833D+12, & .4218971570284096D+14,-.5827244631566907D+16/ DATA A1/.1171875D+00,-.144195556640625D+00, & .6765925884246826D+00,-.6883914268109947D+01, & .1215978918765359D+03,-.3302272294480852D+04, & .1276412726461746D+06,-.6656367718817688D+07, & .4502786003050393D+09,-.3833857520742790D+11, & .4011838599133198D+13,-.5060568503314727D+15/ DATA B1/-.1025390625D+00,.2775764465332031D+00, & -.1993531733751297D+01,.2724882731126854D+02, & -.6038440767050702D+03,.1971837591223663D+05, & -.8902978767070678D+06,.5310411010968522D+08, & -.4043620325107754D+10,.3827011346598605D+12, & -.4406481417852278D+14,.6065091351222699D+16/ K0=12 IF (A0.GE.35.0) K0=10 IF (A0.GE.50.0) K0=8 CT1=Z1-.25D0*PI CP0=(1.0D0,0.0D0) DO 50 K=1,K0 50 CP0=CP0+A(K)*Z1**(-2*K) CQ0=-0.125D0/Z1 DO 55 K=1,K0 55 CQ0=CQ0+B(K)*Z1**(-2*K-1) CU=SQRT(RP2/Z1) CBJ0=CU*(CP0*COS(CT1)-CQ0*SIN(CT1)) CBY0=CU*(CP0*SIN(CT1)+CQ0*COS(CT1)) CT2=Z1-.75D0*PI CP1=(1.0D0,0.0D0) DO 60 K=1,K0 60 CP1=CP1+A1(K)*Z1**(-2*K) CQ1=0.375D0/Z1 DO 65 K=1,K0 65 CQ1=CQ1+B1(K)*Z1**(-2*K-1) CBJ1=CU*(CP1*COS(CT2)-CQ1*SIN(CT2)) CBY1=CU*(CP1*SIN(CT2)+CQ1*COS(CT2)) ENDIF IF (DBLE(Z).LT.0.0) THEN IF (DIMAG(Z).LT.0.0) CBY0=CBY0-2.0D0*CI*CBJ0 IF (DIMAG(Z).GT.0.0) CBY0=CBY0+2.0D0*CI*CBJ0 IF (DIMAG(Z).LT.0.0) CBY1=-(CBY1-2.0D0*CI*CBJ1) IF (DIMAG(Z).GT.0.0) CBY1=-(CBY1+2.0D0*CI*CBJ1) CBJ1=-CBJ1 ENDIF CDY0=-CBY1 CDY1=CBY0-1.0D0/Z*CBY1 70 IF (KF.EQ.0) THEN ZF=CBY0 ZD=CDY0 ELSE IF (KF.EQ.1) THEN ZF=CBY1 ZD=CDY1 ELSE IF (KF.EQ.2) THEN ZF=CDY1 ZD=-CDY1/Z-(1.0D0-1.0D0/(Z*Z))*CBY1 ENDIF RETURN END C ********************************** SUBROUTINE FFK(KS,X,FR,FI,FM,FA,GR,GI,GM,GA) C C ======================================================= C Purpose: Compute modified Fresnel integrals F±(x) C and K±(x) C Input : x --- Argument of F±(x) and K±(x) C KS --- Sign code C KS=0 for calculating F+(x) and K+(x) C KS=1 for calculating F_(x) and K_(x) C Output: FR --- Re[F±(x)] C FI --- Im[F±(x)] C FM --- |F±(x)| C FA --- Arg[F±(x)] (Degs.) C GR --- Re[K±(x)] C GI --- Im[K±(x)] C GM --- |K±(x)| C GA --- Arg[K±(x)] (Degs.) C ====================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) SRD= 57.29577951308233D0 EPS=1.0D-15 PI=3.141592653589793D0 PP2=1.2533141373155D0 P2P=.7978845608028654D0 XA=DABS(X) X2=X*X X4=X2*X2 IF (X.EQ.0.0D0) THEN FR=.5D0*DSQRT(0.5D0*PI) FI=(-1)**KS*FR FM=DSQRT(0.25D0*PI) FA=(-1)**KS*45.0D0 GR=.5D0 GI=0.0D0 GM=.5D0 GA=0.0D0 ELSE IF (XA.LE.2.5D0) THEN XR=P2P*XA C1=XR DO 10 K=1,50 XR=-.5D0*XR*(4.0D0*K-3.0D0)/K/(2.0D0*K-1.0D0) & /(4.0D0*K+1.0D0)*X4 C1=C1+XR IF (DABS(XR/C1).LT.EPS) GO TO 15 10 CONTINUE 15 S1=P2P*XA*XA*XA/3.0D0 XR=S1 DO 20 K=1,50 XR=-.5D0*XR*(4.0D0*K-1.0D0)/K/(2.0D0*K+1.0D0) & /(4.0D0*K+3.0D0)*X4 S1=S1+XR IF (DABS(XR/S1).LT.EPS) GO TO 40 20 CONTINUE ELSE IF (XA.LT.5.5D0) THEN M=INT(42+1.75*X2) XSU=0.0D0 XC=0.0D0 XS=0.0D0 XF1=0.0D0 XF0=1D-100 DO 25 K=M,0,-1 XF=(2.0D0*K+3.0D0)*XF0/X2-XF1 IF (K.EQ.2*INT(K/2)) THEN XC=XC+XF ELSE XS=XS+XF ENDIF XSU=XSU+(2.0D0*K+1.0D0)*XF*XF XF1=XF0 25 XF0=XF XQ=DSQRT(XSU) XW=P2P*XA/XQ C1=XC*XW S1=XS*XW ELSE XR=1.0D0 XF=1.0D0 DO 30 K=1,12 XR=-.25D0*XR*(4.0D0*K-1.0D0)*(4.0D0*K-3.0D0)/X4 30 XF=XF+XR XR=1.0D0/(2.0D0*XA*XA) XG=XR DO 35 K=1,12 XR=-.25D0*XR*(4.0D0*K+1.0D0)*(4.0D0*K-1.0D0)/X4 35 XG=XG+XR C1=.5D0+(XF*DSIN(X2)-XG*DCOS(X2))/DSQRT(2.0D0*PI)/XA S1=.5D0-(XF*DCOS(X2)+XG*DSIN(X2))/DSQRT(2.0D0*PI)/XA ENDIF 40 FR=PP2*(.5D0-C1) FI0=PP2*(.5D0-S1) FI=(-1)**KS*FI0 FM=DSQRT(FR*FR+FI*FI) IF (FR.GE.0.0) THEN FA=SRD*DATAN(FI/FR) ELSE IF (FI.GT.0.0) THEN FA=SRD*(DATAN(FI/FR)+PI) ELSE IF (FI.LT.0.0) THEN FA=SRD*(DATAN(FI/FR)-PI) ENDIF XP=X*X+PI/4.0D0 CS=DCOS(XP) SS=DSIN(XP) XQ2=1.0D0/DSQRT(PI) GR=XQ2*(FR*CS+FI0*SS) GI=(-1)**KS*XQ2*(FI0*CS-FR*SS) GM=DSQRT(GR*GR+GI*GI) IF (GR.GE.0.0) THEN GA=SRD*DATAN(GI/GR) ELSE IF (GI.GT.0.0) THEN GA=SRD*(DATAN(GI/GR)+PI) ELSE IF (GI.LT.0.0) THEN GA=SRD*(DATAN(GI/GR)-PI) ENDIF IF (X.LT.0.0D0) THEN FR=PP2-FR FI=(-1)**KS*PP2-FI FM=DSQRT(FR*FR+FI*FI) FA=SRD*DATAN(FI/FR) GR=DCOS(X*X)-GR GI=-(-1)**KS*DSIN(X*X)-GI GM=DSQRT(GR*GR+GI*GI) GA=SRD*DATAN(GI/GR) ENDIF ENDIF RETURN END C ********************************** SUBROUTINE AIRYA(X,AI,BI,AD,BD) C C ====================================================== C Purpose: Compute Airy functions and their derivatives C Input: x --- Argument of Airy function C Output: AI --- Ai(x) C BI --- Bi(x) C AD --- Ai'(x) C BD --- Bi'(x) C Routine called: C AJYIK for computing Jv(x), Yv(x), Iv(x) and C Kv(x) with v=1/3 and 2/3 C ====================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) XA=DABS(X) PIR=0.318309886183891D0 C1=0.355028053887817D0 C2=0.258819403792807D0 SR3=1.732050807568877D0 Z=XA**1.5/1.5D0 XQ=DSQRT(XA) CALL AJYIK(Z,VJ1,VJ2,VY1,VY2,VI1,VI2,VK1,VK2) IF (X.EQ.0.0D0) THEN AI=C1 BI=SR3*C1 AD=-C2 BD=SR3*C2 ELSE IF (X.GT.0.0D0) THEN AI=PIR*XQ/SR3*VK1 BI=XQ*(PIR*VK1+2.0D0/SR3*VI1) AD=-XA/SR3*PIR*VK2 BD=XA*(PIR*VK2+2.0D0/SR3*VI2) ELSE AI=0.5D0*XQ*(VJ1-VY1/SR3) BI=-0.5D0*XQ*(VJ1/SR3+VY1) AD=0.5D0*XA*(VJ2+VY2/SR3) BD=0.5D0*XA*(VJ2/SR3-VY2) ENDIF RETURN END C ********************************** SUBROUTINE AIRYB(X,AI,BI,AD,BD) C C ======================================================= C Purpose: Compute Airy functions and their derivatives C Input: x --- Argument of Airy function C Output: AI --- Ai(x) C BI --- Bi(x) C AD --- Ai'(x) C BD --- Bi'(x) C ======================================================= C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION CK(51),DK(51) EPS=1.0D-15 PI=3.141592653589793D0 C1=0.355028053887817D0 C2=0.258819403792807D0 SR3=1.732050807568877D0 XA=DABS(X) XQ=DSQRT(XA) XM=8.0D0 IF (X.GT.0.0D0) XM=5.0D0 IF (X.EQ.0.0D0) THEN AI=C1 BI=SR3*C1 AD=-C2 BD=SR3*C2 RETURN ENDIF IF (XA.LE.XM) THEN FX=1.0D0 R=1.0D0 DO 10 K=1,40 R=R*X/(3.0D0*K)*X/(3.0D0*K-1.0D0)*X FX=FX+R IF (DABS(R).LT.DABS(FX)*EPS) GO TO 15 10 CONTINUE 15 GX=X R=X DO 20 K=1,40 R=R*X/(3.0D0*K)*X/(3.0D0*K+1.0D0)*X GX=GX+R IF (DABS(R).LT.DABS(GX)*EPS) GO TO 25 20 CONTINUE 25 AI=C1*FX-C2*GX BI=SR3*(C1*FX+C2*GX) DF=0.5D0*X*X R=DF DO 30 K=1,40 R=R*X/(3.0D0*K)*X/(3.0D0*K+2.0D0)*X DF=DF+R IF (DABS(R).LT.DABS(DF)*EPS) GO TO 35 30 CONTINUE 35 DG=1.0D0 R=1.0D0 DO 40 K=1,40 R=R*X/(3.0D0*K)*X/(3.0D0*K-2.0D0)*X DG=DG+R IF (DABS(R).LT.DABS(DG)*EPS) GO TO 45 40 CONTINUE 45 AD=C1*DF-C2*DG BD=SR3*(C1*DF+C2*DG) ELSE KM=INT(24.5-XA) IF (XA.LT.6.0) KM=14 IF (XA.GT.15.0) KM=10 IF (X.GT.0.0D0) THEN KMAX=KM ELSE C Choose cutoffs so that the remainder term in asymptotic C expansion is epsilon size. The X<0 branch needs to be fast C in order to make AIRYZO efficient IF (XA.GT.70.0) KM=3 IF (XA.GT.500.0) KM=2 IF (XA.GT.1000.0) KM=1 KM2=KM IF (XA.GT.150.0) KM2=1 IF (XA.GT.3000.0) KM2=0 KMAX=2*KM+1 ENDIF XE=XA*XQ/1.5D0 XR1=1.0D0/XE XAR=1.0D0/XQ XF=DSQRT(XAR) RP=0.5641895835477563D0 R=1.0D0 DO 50 K=1,KMAX R=R*(6.0D0*K-1.0D0)/216.0D0*(6.0D0*K-3.0D0) & /K*(6.0D0*K-5.0D0)/(2.0D0*K-1.0D0) CK(K)=R 50 DK(K)=-(6.0D0*K+1.0D0)/(6.0D0*K-1.0D0)*CK(K) IF (X.GT.0.0D0) THEN SAI=1.0D0 SAD=1.0D0 R=1.0D0 DO 55 K=1,KM R=-R*XR1 SAI=SAI+CK(K)*R 55 SAD=SAD+DK(K)*R SBI=1.0D0 SBD=1.0D0 R=1.0D0 DO 60 K=1,KM R=R*XR1 SBI=SBI+CK(K)*R 60 SBD=SBD+DK(K)*R XP1=EXP(-XE) AI=0.5D0*RP*XF*XP1*SAI BI=RP*XF/XP1*SBI AD=-.5D0*RP/XF*XP1*SAD BD=RP/XF/XP1*SBD ELSE XCS=DCOS(XE+PI/4.0D0) XSS=DSIN(XE+PI/4.0D0) SSA=1.0D0 SDA=1.0D0 R=1.0D0 XR2=1.0D0/(XE*XE) DO 65 K=1,KM R=-R*XR2 SSA=SSA+CK(2*K)*R 65 SDA=SDA+DK(2*K)*R SSB=CK(1)*XR1 SDB=DK(1)*XR1 R=XR1 DO 70 K=1,KM2 R=-R*XR2 SSB=SSB+CK(2*K+1)*R 70 SDB=SDB+DK(2*K+1)*R AI=RP*XF*(XSS*SSA-XCS*SSB) BI=RP*XF*(XCS*SSA+XSS*SSB) AD=-RP/XF*(XCS*SDA+XSS*SDB) BD=RP/XF*(XSS*SDA-XCS*SDB) ENDIF ENDIF RETURN END C ********************************** SUBROUTINE SCKA(M,N,C,CV,KD,CK) C C ====================================================== C Purpose: Compute the expansion coefficients of the C prolate and oblate spheroidal functions, c2k C Input : m --- Mode parameter C n --- Mode parameter C c --- Spheroidal parameter C cv --- Characteristic value C KD --- Function code C KD=1 for prolate; KD=-1 for oblate C Output: CK(k) --- Expansion coefficients ck; C CK(1), CK(2),... correspond to C c0, c2,... C ====================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION CK(200) IF (C.LE.1.0D-10) C=1.0D-10 NM=25+INT((N-M)/2+C) CS=C*C*KD IP=1 IF (N-M.EQ.2*INT((N-M)/2)) IP=0 FS=1.0D0 F1=0.0D0 F0=1.0D-100 KB=0 CK(NM+1)=0.0D0 FL=0.0D0 DO 15 K=NM,1,-1 F=(((2.0D0*K+M+IP)*(2.0D0*K+M+1.0D0+IP)-CV+CS)*F0 & -4.0D0*(K+1.0D0)*(K+M+1.0D0)*F1)/CS IF (DABS(F).GT.DABS(CK(K+1))) THEN CK(K)=F F1=F0 F0=F IF (DABS(F).GT.1.0D+100) THEN DO 5 K1=NM,K,-1 5 CK(K1)=CK(K1)*1.0D-100 F1=F1*1.0D-100 F0=F0*1.0D-100 ENDIF ELSE KB=K FL=CK(K+1) F1=1.0D0 F2=0.25D0*((M+IP)*(M+IP+1.0)-CV+CS)/(M+1.0)*F1 CK(1)=F1 IF (KB.EQ.1) THEN FS=F2 ELSE IF (KB.EQ.2) THEN CK(2)=F2 FS=0.125D0*(((M+IP+2.0)*(M+IP+3.0)-CV+CS)*F2 & -CS*F1)/(M+2.0) ELSE CK(2)=F2 DO 10 J=3,KB+1 F=0.25D0*(((2.0*J+M+IP-4.0)*(2.0*J+M+IP- & 3.0)-CV+CS)*F2-CS*F1)/((J-1.0)*(J+M-1.0)) IF (J.LE.KB) CK(J)=F F1=F2 10 F2=F FS=F ENDIF GO TO 20 ENDIF 15 CONTINUE 20 SU1=0.0D0 DO 25 K=1,KB 25 SU1=SU1+CK(K) SU2=0.0D0 DO 30 K=KB+1,NM 30 SU2=SU2+CK(K) R1=1.0D0 DO 35 J=1,(N+M+IP)/2 35 R1=R1*(J+0.5D0*(N+M+IP)) R2=1.0D0 DO 40 J=1,(N-M-IP)/2 40 R2=-R2*J IF (KB.EQ.0) THEN S0=R1/(2.0D0**N*R2*SU2) ELSE S0=R1/(2.0D0**N*R2*(FL/FS*SU1+SU2)) ENDIF DO 45 K=1,KB 45 CK(K)=FL/FS*S0*CK(K) DO 50 K=KB+1,NM 50 CK(K)=S0*CK(K) RETURN END C ********************************** SUBROUTINE SCKB(M,N,C,DF,CK) C C ====================================================== C Purpose: Compute the expansion coefficients of the C prolate and oblate spheroidal functions C Input : m --- Mode parameter C n --- Mode parameter C c --- Spheroidal parameter C DF(k) --- Expansion coefficients dk C Output: CK(k) --- Expansion coefficients ck; C CK(1), CK(2), ... correspond to C c0, c2, ... C ====================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION DF(200),CK(200) IF (C.LE.1.0D-10) C=1.0D-10 NM=25+INT(0.5*(N-M)+C) IP=1 IF (N-M.EQ.2*INT((N-M)/2)) IP=0 REG=1.0D0 IF (M+NM.GT.80) REG=1.0D-200 FAC=-0.5D0**M SW=0.0D0 DO 35 K=0,NM-1 FAC=-FAC I1=2*K+IP+1 R=REG DO 10 I=I1,I1+2*M-1 10 R=R*I I2=K+M+IP DO 15 I=I2,I2+K-1 15 R=R*(I+0.5D0) SUM=R*DF(K+1) DO 20 I=K+1,NM D1=2.0D0*I+IP D2=2.0D0*M+D1 D3=I+M+IP-0.5D0 R=R*D2*(D2-1.0D0)*I*(D3+K)/(D1*(D1-1.0D0)*(I-K)*D3) SUM=SUM+R*DF(I+1) IF (DABS(SW-SUM).LT.DABS(SUM)*1.0D-14) GOTO 25 20 SW=SUM 25 R1=REG DO 30 I=2,M+K 30 R1=R1*I 35 CK(K+1)=FAC*SUM/R1 RETURN END C ********************************** SUBROUTINE CPDLA(N,Z,CDN) C C =========================================================== C Purpose: Compute complex parabolic cylinder function Dn(z) C for large argument C Input: z --- Complex argument of Dn(z) C n --- Order of Dn(z) (n = 0,±1,±2,…) C Output: CDN --- Dn(z) C =========================================================== C IMPLICIT DOUBLE PRECISION (A-B,D-H,O-Y) IMPLICIT COMPLEX*16 (C,Z) CB0=Z**N*EXP(-.25D0*Z*Z) CR=(1.0D0,0.0D0) CDN=(1.0D0,0.0D0) DO 10 K=1,16 CR=-0.5D0*CR*(2.0*K-N-1.0)*(2.0*K-N-2.0)/(K*Z*Z) CDN=CDN+CR IF (ABS(CR).LT.ABS(CDN)*1.0D-12) GO TO 15 10 CONTINUE 15 CDN=CB0*CDN RETURN END C ********************************** SUBROUTINE FCSZO(KF,NT,ZO) C C =============================================================== C Purpose: Compute the complex zeros of Fresnel integral C(z) C or S(z) using modified Newton's iteration method C Input : KF --- Function code C KF=1 for C(z) or KF=2 for S(z) C NT --- Total number of zeros C Output: ZO(L) --- L-th zero of C(z) or S(z) C Routines called: C (1) CFC for computing Fresnel integral C(z) C (2) CFS for computing Fresnel integral S(z) C ============================================================== C IMPLICIT DOUBLE PRECISION (E,P,W) IMPLICIT COMPLEX *16 (C,Z) DIMENSION ZO(NT) PI=3.141592653589793D0 PSQ=0.0D0 W=0.0D0 DO 35 NR=1,NT IF (KF.EQ.1) PSQ=DSQRT(4.0D0*NR-1.0D0) IF (KF.EQ.2) PSQ=2.0D0*NR**(0.5) PX=PSQ-DLOG(PI*PSQ)/(PI*PI*PSQ**3.0) PY=DLOG(PI*PSQ)/(PI*PSQ) Z = DCMPLX(PX, PY) IF (KF.EQ.2) THEN IF (NR.EQ.2) Z=(2.8334,0.2443) IF (NR.EQ.3) Z=(3.4674,0.2185) IF (NR.EQ.4) Z=(4.0025,0.2008) ENDIF IT=0 15 IT=IT+1 IF (KF.EQ.1) CALL CFC(Z,ZF,ZD) IF (KF.EQ.2) CALL CFS(Z,ZF,ZD) ZP=(1.0D0,0.0D0) DO 20 I=1,NR-1 20 ZP=ZP*(Z-ZO(I)) ZFD=ZF/ZP ZQ=(0.0D0,0.0D0) DO 30 I=1,NR-1 ZW=(1.0D0,0.0D0) DO 25 J=1,NR-1 IF (J.EQ.I) GO TO 25 ZW=ZW*(Z-ZO(J)) 25 CONTINUE 30 ZQ=ZQ+ZW ZGD=(ZD-ZQ*ZFD)/ZP Z=Z-ZFD/ZGD W0=W W=ABS(Z) IF (IT.LE.50.AND.DABS((W-W0)/W).GT.1.0D-12) GO TO 15 35 ZO(NR)=Z RETURN END C ********************************** SUBROUTINE E1XA(X,E1) C C ============================================ C Purpose: Compute exponential integral E1(x) C Input : x --- Argument of E1(x) C Output: E1 --- E1(x) ( x > 0 ) C ============================================ C IMPLICIT DOUBLE PRECISION (A-H,O-Z) IF (X.EQ.0.0) THEN E1=1.0D+300 ELSE IF (X.LE.1.0) THEN E1=-DLOG(X)+((((1.07857D-3*X-9.76004D-3)*X+5.519968D-2)*X & -0.24991055D0)*X+0.99999193D0)*X-0.57721566D0 ELSE ES1=(((X+8.5733287401D0)*X+18.059016973D0)*X & +8.6347608925D0)*X+0.2677737343D0 ES2=(((X+9.5733223454D0)*X+25.6329561486D0)*X & +21.0996530827D0)*X+3.9584969228D0 E1=EXP(-X)/X*ES1/ES2 ENDIF RETURN END C ********************************** SUBROUTINE LPMV0(V,M,X,PMV) C C ======================================================= C Purpose: Compute the associated Legendre function C Pmv(x) with an integer order and an arbitrary C nonnegative degree v C Input : x --- Argument of Pm(x) ( -1 ≤ x ≤ 1 ) C m --- Order of Pmv(x) C v --- Degree of Pmv(x) C Output: PMV --- Pmv(x) C Routine called: PSI_SPEC for computing Psi function C ======================================================= C IMPLICIT DOUBLE PRECISION (A-H,O-Z) PI=3.141592653589793D0 EL=.5772156649015329D0 EPS=1.0D-14 NV=INT(V) V0=V-NV IF (X.EQ.-1.0D0.AND.V.NE.NV) THEN IF (M.EQ.0) PMV=-1.0D+300 IF (M.NE.0) PMV=1.0D+300 RETURN ENDIF C0=1.0D0 IF (M.NE.0) THEN RG=V*(V+M) DO 10 J=1,M-1 10 RG=RG*(V*V-J*J) XQ=DSQRT(1.0D0-X*X) R0=1.0D0 DO 15 J=1,M 15 R0=.5D0*R0*XQ/J C0=R0*RG ENDIF IF (V0.EQ.0.0D0) THEN C DLMF 14.3.4, 14.7.17, 15.2.4 PMV=1.0D0 R=1.0D0 DO 20 K=1,NV-M R=0.5D0*R*(-NV+M+K-1.0D0)*(NV+M+K)/(K*(K+M)) & *(1.0D0+X) 20 PMV=PMV+R PMV=(-1)**NV*C0*PMV ELSE IF (X.GE.-0.35D0) THEN C DLMF 14.3.4, 15.2.1 PMV=1.0D0 R=1.0D0 DO 25 K=1,100 R=0.5D0*R*(-V+M+K-1.0D0)*(V+M+K)/(K*(M+K))*(1.0D0-X) PMV=PMV+R IF (K.GT.12.AND.DABS(R/PMV).LT.EPS) GO TO 30 25 CONTINUE 30 PMV=(-1)**M*C0*PMV ELSE C DLMF 14.3.5, 15.8.10 VS=DSIN(V*PI)/PI PV0=0.0D0 IF (M.NE.0) THEN QR=DSQRT((1.0D0-X)/(1.0D0+X)) R2=1.0D0 DO 35 J=1,M 35 R2=R2*QR*J S0=1.0D0 R1=1.0D0 DO 40 K=1,M-1 R1=0.5D0*R1*(-V+K-1)*(V+K)/(K*(K-M))*(1.0D0+X) 40 S0=S0+R1 PV0=-VS*R2/M*S0 ENDIF CALL PSI_SPEC(V,PSV) PA=2.0D0*(PSV+EL)+PI/DTAN(PI*V)+1.0D0/V S1=0.0D0 DO 45 J=1,M 45 S1=S1+(J*J+V*V)/(J*(J*J-V*V)) PMV=PA+S1-1.0D0/(M-V)+DLOG(0.5D0*(1.0D0+X)) R=1.0D0 DO 60 K=1,100 R=0.5D0*R*(-V+M+K-1.0D0)*(V+M+K)/(K*(K+M))*(1.0D0+X) S=0.0D0 DO 50 J=1,M 50 S=S+((K+J)**2+V*V)/((K+J)*((K+J)**2-V*V)) S2=0.0D0 DO 55 J=1,K 55 S2=S2+1.0D0/(J*(J*J-V*V)) PSS=PA+S+2.0D0*V*V*S2-1.0D0/(M+K-V) & +DLOG(0.5D0*(1.0D0+X)) R2=PSS*R PMV=PMV+R2 IF (DABS(R2/PMV).LT.EPS) GO TO 65 60 CONTINUE 65 PMV=PV0+PMV*VS*C0 ENDIF ENDIF RETURN END C ********************************** SUBROUTINE LPMV(V,M,X,PMV) C C ======================================================= C Purpose: Compute the associated Legendre function C Pmv(x) with an integer order and an arbitrary C degree v, using recursion for large degrees C Input : x --- Argument of Pm(x) ( -1 ≤ x ≤ 1 ) C m --- Order of Pmv(x) C v --- Degree of Pmv(x) C Output: PMV --- Pmv(x) C Routine called: LPMV0 C ======================================================= C IMPLICIT DOUBLE PRECISION (A-H,O-Z) IF (X.EQ.-1.0D0.AND.V.NE.INT(V)) THEN IF (M.EQ.0) PMV=-DINF() IF (M.NE.0) PMV=DINF() RETURN ENDIF VX=V MX=M C DLMF 14.9.5 IF (V.LT.0) THEN VX=-VX-1 ENDIF NEG_M=0 IF (M.LT.0) THEN IF ((VX+M+1).GT.0D0.OR.VX.NE.INT(VX)) THEN NEG_M=1 MX=-M ELSE C We don't handle cases where DLMF 14.9.3 doesn't help PMV=DNAN() RETURN END IF ENDIF NV=INT(VX) V0=VX-NV IF (NV.GT.2.AND.NV.GT.MX) THEN C Up-recursion on degree, AMS 8.5.3 / DLMF 14.10.3 CALL LPMV0(V0+MX, MX, X, P0) CALL LPMV0(V0+MX+1, MX, X, P1) PMV = P1 DO 10 J=MX+2,NV PMV = ((2*(V0+J)-1)*X*P1 - (V0+J-1+MX)*P0) / (V0+J-MX) P0 = P1 P1 = PMV 10 CONTINUE ELSE CALL LPMV0(VX, MX, X, PMV) ENDIF IF (NEG_M.NE.0.AND.ABS(PMV).LT.1.0D+300) THEN C DLMF 14.9.3 CALL GAMMA2(VX-MX+1, G1) CALL GAMMA2(VX+MX+1, G2) PMV = PMV*G1/G2 * (-1)**MX ENDIF END C ********************************** SUBROUTINE CGAMA(X,Y,KF,GR,GI) C C ========================================================= C Purpose: Compute the gamma function Г(z) or ln[Г(z)] C for a complex argument C Input : x --- Real part of z C y --- Imaginary part of z C KF --- Function code C KF=0 for ln[Г(z)] C KF=1 for Г(z) C Output: GR --- Real part of ln[Г(z)] or Г(z) C GI --- Imaginary part of ln[Г(z)] or Г(z) C ======================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION A(10) PI=3.141592653589793D0 DATA A/8.333333333333333D-02,-2.777777777777778D-03, & 7.936507936507937D-04,-5.952380952380952D-04, & 8.417508417508418D-04,-1.917526917526918D-03, & 6.410256410256410D-03,-2.955065359477124D-02, & 1.796443723688307D-01,-1.39243221690590D+00/ IF (Y.EQ.0.0D0.AND.X.EQ.INT(X).AND.X.LE.0.0D0) THEN GR=1.0D+300 GI=0.0D0 RETURN ELSE IF (X.LT.0.0D0) THEN X1=X Y1=Y X=-X Y=-Y ELSE Y1=0.0D0 X1=X ENDIF X0=X NA=0 IF (X.LE.7.0) THEN NA=INT(7-X) X0=X+NA ENDIF Z1=DSQRT(X0*X0+Y*Y) TH=DATAN(Y/X0) GR=(X0-.5D0)*DLOG(Z1)-TH*Y-X0+0.5D0*DLOG(2.0D0*PI) GI=TH*(X0-0.5D0)+Y*DLOG(Z1)-Y DO 10 K=1,10 T=Z1**(1-2*K) GR=GR+A(K)*T*DCOS((2.0D0*K-1.0D0)*TH) 10 GI=GI-A(K)*T*DSIN((2.0D0*K-1.0D0)*TH) IF (X.LE.7.0) THEN GR1=0.0D0 GI1=0.0D0 DO 15 J=0,NA-1 GR1=GR1+.5D0*DLOG((X+J)**2+Y*Y) 15 GI1=GI1+DATAN(Y/(X+J)) GR=GR-GR1 GI=GI-GI1 ENDIF IF (X1.LT.0.0D0) THEN Z1=DSQRT(X*X+Y*Y) TH1=DATAN(Y/X) SR=-DSIN(PI*X)*DCOSH(PI*Y) SI=-DCOS(PI*X)*DSINH(PI*Y) Z2=DSQRT(SR*SR+SI*SI) TH2=DATAN(SI/SR) IF (SR.LT.0.0D0) TH2=PI+TH2 GR=DLOG(PI/(Z1*Z2))-GR GI=-TH1-TH2-GI X=X1 Y=Y1 ENDIF IF (KF.EQ.1) THEN G0=EXP(GR) GR=G0*DCOS(GI) GI=G0*DSIN(GI) ENDIF RETURN END C ********************************** SUBROUTINE ASWFB(M,N,C,X,KD,CV,S1F,S1D) C C =========================================================== C Purpose: Compute the prolate and oblate spheroidal angular C functions of the first kind and their derivatives C Input : m --- Mode parameter, m = 0,1,2,... C n --- Mode parameter, n = m,m+1,... C c --- Spheroidal parameter C x --- Argument of angular function, |x| < 1.0 C KD --- Function code C KD=1 for prolate; KD=-1 for oblate C cv --- Characteristic value C Output: S1F --- Angular function of the first kind C S1D --- Derivative of the angular function of C the first kind C Routines called: C (1) SDMN for computing expansion coefficients dk C (2) LPMNS for computing associated Legendre function C of the first kind Pmn(x) C =========================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION DF(200),PM(0:251),PD(0:251) EPS=1.0D-14 IP=1 IF (N-M.EQ.2*INT((N-M)/2)) IP=0 NM=25+INT((N-M)/2+C) NM2=2*NM+M CALL SDMN(M,N,C,CV,KD,DF) CALL LPMNS(M,NM2,X,PM,PD) SW=0.0D0 SU1=0.0D0 DO 10 K=1,NM MK=M+2*(K-1)+IP SU1=SU1+DF(K)*PM(MK) IF (DABS(SW-SU1).LT.DABS(SU1)*EPS) GOTO 15 10 SW=SU1 15 S1F=(-1)**M*SU1 SU1=0.0D0 DO 20 K=1,NM MK=M+2*(K-1)+IP SU1=SU1+DF(K)*PD(MK) IF (DABS(SW-SU1).LT.DABS(SU1)*EPS) GOTO 25 20 SW=SU1 25 S1D=(-1)**M*SU1 RETURN END C ********************************** SUBROUTINE CHGUS(A,B,X,HU,ID) C C ====================================================== C Purpose: Compute confluent hypergeometric function C U(a,b,x) for small argument x C Input : a --- Parameter C b --- Parameter ( b <> 0,-1,-2,...) C x --- Argument C Output: HU --- U(a,b,x) C ID --- Estimated number of significant digits C Routine called: GAMMA2 for computing gamma function C ====================================================== C C DLMF 13.2.42 with prefactors rewritten according to C DLMF 5.5.3, M(a, b, x) with DLMF 13.2.2 C IMPLICIT DOUBLE PRECISION (A-H,O-Z) ID=-100 PI=3.141592653589793D0 CALL GAMMA2(A,GA) CALL GAMMA2(B,GB) XG1=1.0D0+A-B CALL GAMMA2(XG1,GAB) XG2=2.0D0-B CALL GAMMA2(XG2,GB2) HU0=PI/DSIN(PI*B) R1=HU0/(GAB*GB) R2=HU0*X**(1.0D0-B)/(GA*GB2) HU=R1-R2 HMAX=0.0D0 HMIN=1.0D+300 H0=0.0D0 DO 10 J=1,150 R1=R1*(A+J-1.0D0)/(J*(B+J-1.0D0))*X R2=R2*(A-B+J)/(J*(1.0D0-B+J))*X HU=HU+R1-R2 HUA=DABS(HU) IF (HUA.GT.HMAX) HMAX=HUA IF (HUA.LT.HMIN) HMIN=HUA IF (DABS(HU-H0).LT.DABS(HU)*1.0D-15) GO TO 15 10 H0=HU 15 D1=LOG10(HMAX) D2=0.0D0 IF (HMIN.NE.0.0) D2=LOG10(HMIN) ID=15-ABS(D1-D2) RETURN END C ********************************** SUBROUTINE ITTH0(X,TTH) C C =========================================================== C Purpose: Evaluate the integral H0(t)/t with respect to t C from x to infinity C Input : x --- Lower limit ( x ≥ 0 ) C Output: TTH --- Integration of H0(t)/t from x to infinity C =========================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) PI=3.141592653589793D0 S=1.0D0 R=1.0D0 IF (X.LT.24.5D0) THEN DO 10 K=1,60 R=-R*X*X*(2.0*K-1.0D0)/(2.0*K+1.0D0)**3 S=S+R IF (DABS(R).LT.DABS(S)*1.0D-12) GO TO 15 10 CONTINUE 15 TTH=PI/2.0D0-2.0D0/PI*X*S ELSE DO 20 K=1,10 R=-R*(2.0*K-1.0D0)**3/((2.0*K+1.0D0)*X*X) S=S+R IF (DABS(R).LT.DABS(S)*1.0D-12) GO TO 25 20 CONTINUE 25 TTH=2.0D0/(PI*X)*S T=8.0D0/X XT=X+.25D0*PI F0=(((((.18118D-2*T-.91909D-2)*T+.017033D0)*T & -.9394D-3)*T-.051445D0)*T-.11D-5)*T+.7978846D0 G0=(((((-.23731D-2*T+.59842D-2)*T+.24437D-2)*T & -.0233178D0)*T+.595D-4)*T+.1620695D0)*T TTY=(F0*DSIN(XT)-G0*DCOS(XT))/(DSQRT(X)*X) TTH=TTH+TTY ENDIF RETURN END C ********************************** SUBROUTINE LGAMA(KF,X,GL) C C ================================================== C Purpose: Compute gamma function Г(x) or ln[Г(x)] C Input: x --- Argument of Г(x) ( x > 0 ) C KF --- Function code C KF=1 for Г(x); KF=0 for ln[Г(x)] C Output: GL --- Г(x) or ln[Г(x)] C ================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION A(10) DATA A/8.333333333333333D-02,-2.777777777777778D-03, & 7.936507936507937D-04,-5.952380952380952D-04, & 8.417508417508418D-04,-1.917526917526918D-03, & 6.410256410256410D-03,-2.955065359477124D-02, & 1.796443723688307D-01,-1.39243221690590D+00/ X0=X N=0 IF (X.EQ.1.0.OR.X.EQ.2.0) THEN GL=0.0D0 GO TO 20 ELSE IF (X.LE.7.0) THEN N=INT(7-X) X0=X+N ENDIF X2=1.0D0/(X0*X0) XP=6.283185307179586477D0 GL0=A(10) DO 10 K=9,1,-1 10 GL0=GL0*X2+A(K) GL=GL0/X0+0.5D0*DLOG(XP)+(X0-.5D0)*DLOG(X0)-X0 IF (X.LE.7.0) THEN DO 15 K=1,N GL=GL-DLOG(X0-1.0D0) 15 X0=X0-1.0D0 ENDIF 20 IF (KF.EQ.1) GL=EXP(GL) RETURN END C ********************************** SUBROUTINE LQNA(N,X,QN,QD) C C ===================================================== C Purpose: Compute Legendre functions Qn(x) and Qn'(x) C Input : x --- Argument of Qn(x) ( -1 ≤ x ≤ 1 ) C n --- Degree of Qn(x) ( n = 0,1,2,… ) C Output: QN(n) --- Qn(x) C QD(n) --- Qn'(x) C ( 1.0D+300 stands for infinity ) C ===================================================== C IMPLICIT DOUBLE PRECISION (Q,X) DIMENSION QN(0:N),QD(0:N) IF (DABS(X).EQ.1.0D0) THEN DO 10 K=0,N QN(K)=1.0D+300 QD(K)=-1.0D+300 10 CONTINUE ELSE IF (DABS(X).LT.1.0D0) THEN Q0=0.5D0*DLOG((1.0D0+X)/(1.0D0-X)) Q1=X*Q0-1.0D0 QN(0)=Q0 QN(1)=Q1 QD(0)=1.0D0/(1.0D0-X*X) QD(1)=QN(0)+X*QD(0) DO 15 K=2,N QF=((2*K-1)*X*Q1-(K-1)*Q0)/K QN(K)=QF QD(K)=(QN(K-1)-X*QF)*K/(1.0D0-X*X) Q0=Q1 15 Q1=QF ENDIF RETURN END C ********************************** SUBROUTINE DVLA(VA,X,PD) C C ==================================================== C Purpose: Compute parabolic cylinder functions Dv(x) C for large argument C Input: x --- Argument C va --- Order C Output: PD --- Dv(x) C Routines called: C (1) VVLA for computing Vv(x) for large |x| C (2) GAMMA2 for computing Г(x) C ==================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) PI=3.141592653589793D0 EPS=1.0D-12 EP=EXP(-.25*X*X) A0=DABS(X)**VA*EP R=1.0D0 PD=1.0D0 DO 10 K=1,16 R=-0.5D0*R*(2.0*K-VA-1.0)*(2.0*K-VA-2.0)/(K*X*X) PD=PD+R IF (DABS(R/PD).LT.EPS) GO TO 15 10 CONTINUE 15 PD=A0*PD IF (X.LT.0.0D0) THEN X1=-X CALL VVLA(VA,X1,VL) CALL GAMMA2(-VA,GL) PD=PI*VL/GL+DCOS(PI*VA)*PD ENDIF RETURN END C ********************************** SUBROUTINE IK01A(X,BI0,DI0,BI1,DI1,BK0,DK0,BK1,DK1) C C ========================================================= C Purpose: Compute modified Bessel functions I0(x), I1(1), C K0(x) and K1(x), and their derivatives C Input : x --- Argument ( x ≥ 0 ) C Output: BI0 --- I0(x) C DI0 --- I0'(x) C BI1 --- I1(x) C DI1 --- I1'(x) C BK0 --- K0(x) C DK0 --- K0'(x) C BK1 --- K1(x) C DK1 --- K1'(x) C ========================================================= C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION A(12),B(12),A1(8) PI=3.141592653589793D0 EL=0.5772156649015329D0 X2=X*X IF (X.EQ.0.0D0) THEN BI0=1.0D0 BI1=0.0D0 BK0=1.0D+300 BK1=1.0D+300 DI0=0.0D0 DI1=0.5D0 DK0=-1.0D+300 DK1=-1.0D+300 RETURN ELSE IF (X.LE.18.0D0) THEN BI0=1.0D0 R=1.0D0 DO 15 K=1,50 R=0.25D0*R*X2/(K*K) BI0=BI0+R IF (DABS(R/BI0).LT.1.0D-15) GO TO 20 15 CONTINUE 20 BI1=1.0D0 R=1.0D0 DO 25 K=1,50 R=0.25D0*R*X2/(K*(K+1)) BI1=BI1+R IF (DABS(R/BI1).LT.1.0D-15) GO TO 30 25 CONTINUE 30 BI1=0.5D0*X*BI1 ELSE DATA A/0.125D0,7.03125D-2, & 7.32421875D-2,1.1215209960938D-1, & 2.2710800170898D-1,5.7250142097473D-1, & 1.7277275025845D0,6.0740420012735D0, & 2.4380529699556D01,1.1001714026925D02, & 5.5133589612202D02,3.0380905109224D03/ DATA B/-0.375D0,-1.171875D-1, & -1.025390625D-1,-1.4419555664063D-1, & -2.7757644653320D-1,-6.7659258842468D-1, & -1.9935317337513D0,-6.8839142681099D0, & -2.7248827311269D01,-1.2159789187654D02, & -6.0384407670507D02,-3.3022722944809D03/ K0=12 IF (X.GE.35.0) K0=9 IF (X.GE.50.0) K0=7 CA=EXP(X)/DSQRT(2.0D0*PI*X) BI0=1.0D0 XR=1.0D0/X DO 35 K=1,K0 35 BI0=BI0+A(K)*XR**K BI0=CA*BI0 BI1=1.0D0 DO 40 K=1,K0 40 BI1=BI1+B(K)*XR**K BI1=CA*BI1 ENDIF WW=0.0D0 IF (X.LE.9.0D0) THEN CT=-(DLOG(X/2.0D0)+EL) BK0=0.0D0 W0=0.0D0 R=1.0D0 DO 65 K=1,50 W0=W0+1.0D0/K R=0.25D0*R/(K*K)*X2 BK0=BK0+R*(W0+CT) IF (DABS((BK0-WW)/BK0).LT.1.0D-15) GO TO 70 65 WW=BK0 70 BK0=BK0+CT ELSE DATA A1/0.125D0,0.2109375D0, & 1.0986328125D0,1.1775970458984D01, & 2.1461706161499D02,5.9511522710323D03, & 2.3347645606175D05,1.2312234987631D07/ CB=0.5D0/X XR2=1.0D0/X2 BK0=1.0D0 DO 75 K=1,8 75 BK0=BK0+A1(K)*XR2**K BK0=CB*BK0/BI0 ENDIF BK1=(1.0D0/X-BI1*BK0)/BI0 DI0=BI1 DI1=BI0-BI1/X DK0=-BK1 DK1=-BK0-BK1/X RETURN END C ********************************** SUBROUTINE CPBDN(N,Z,CPB,CPD) C C ================================================== C Purpose: Compute the parabolic cylinder functions C Dn(z) and Dn'(z) for a complex argument C Input: z --- Complex argument of Dn(z) C n --- Order of Dn(z) ( n=0,±1,±2,… ) C Output: CPB(|n|) --- Dn(z) C CPD(|n|) --- Dn'(z) C Routines called: C (1) CPDSA for computing Dn(z) for a small |z| C (2) CPDLA for computing Dn(z) for a large |z| C ================================================== C IMPLICIT DOUBLE PRECISION (A-B,D-H,O-Y) IMPLICIT COMPLEX*16 (C,Z) DIMENSION CPB(0:*),CPD(0:*) PI=3.141592653589793D0 X=DBLE(Z) A0=ABS(Z) C0=(0.0D0,0.0D0) CA0=EXP(-0.25D0*Z*Z) N0=0 IF (N.GE.0) THEN CF0=CA0 CF1=Z*CA0 CPB(0)=CF0 CPB(1)=CF1 DO 10 K=2,N CF=Z*CF1-(K-1.0D0)*CF0 CPB(K)=CF CF0=CF1 10 CF1=CF ELSE N0=-N IF (X.LE.0.0.OR.ABS(Z).EQ.0.0) THEN CF0=CA0 CPB(0)=CF0 Z1=-Z IF (A0.LE.7.0) THEN CALL CPDSA(-1,Z1,CF1) ELSE CALL CPDLA(-1,Z1,CF1) ENDIF CF1=DSQRT(2.0D0*PI)/CA0-CF1 CPB(1)=CF1 DO 15 K=2,N0 CF=(-Z*CF1+CF0)/(K-1.0D0) CPB(K)=CF CF0=CF1 15 CF1=CF ELSE IF (A0.LE.3.0) THEN CALL CPDSA(-N0,Z,CFA) CPB(N0)=CFA N1=N0+1 CALL CPDSA(-N1,Z,CFB) CPB(N1)=CFB NM1=N0-1 DO 20 K=NM1,0,-1 CF=Z*CFA+(K+1.0D0)*CFB CPB(K)=CF CFB=CFA 20 CFA=CF ELSE M=100+ABS(N) CFA=C0 CFB=(1.0D-30,0.0D0) DO 25 K=M,0,-1 CF=Z*CFB+(K+1.0D0)*CFA IF (K.LE.N0) CPB(K)=CF CFA=CFB 25 CFB=CF CS0=CA0/CF DO 30 K=0,N0 30 CPB(K)=CS0*CPB(K) ENDIF ENDIF ENDIF CPD(0)=-0.5D0*Z*CPB(0) IF (N.GE.0) THEN DO 35 K=1,N 35 CPD(K)=-0.5D0*Z*CPB(K)+K*CPB(K-1) ELSE DO 40 K=1,N0 40 CPD(K)=0.5D0*Z*CPB(K)-CPB(K-1) ENDIF RETURN END C ********************************** SUBROUTINE IK01B(X,BI0,DI0,BI1,DI1,BK0,DK0,BK1,DK1) C C ========================================================= C Purpose: Compute modified Bessel functions I0(x), I1(1), C K0(x) and K1(x), and their derivatives C Input : x --- Argument ( x ≥ 0 ) C Output: BI0 --- I0(x) C DI0 --- I0'(x) C BI1 --- I1(x) C DI1 --- I1'(x) C BK0 --- K0(x) C DK0 --- K0'(x) C BK1 --- K1(x) C DK1 --- K1'(x) C ========================================================= C IMPLICIT DOUBLE PRECISION (A-H,O-Z) IF (X.EQ.0.0D0) THEN BI0=1.0D0 BI1=0.0D0 BK0=1.0D+300 BK1=1.0D+300 DI0=0.0D0 DI1=0.5D0 DK0=-1.0D+300 DK1=-1.0D+300 RETURN ELSE IF (X.LE.3.75D0) THEN T=X/3.75D0 T2=T*T BI0=(((((.0045813D0*T2+.0360768D0)*T2+.2659732D0) & *T2+1.2067492D0)*T2+3.0899424D0)*T2 & +3.5156229D0)*T2+1.0D0 BI1=X*((((((.00032411D0*T2+.00301532D0)*T2 & +.02658733D0)*T2+.15084934D0)*T2+.51498869D0) & *T2+.87890594D0)*T2+.5D0) ELSE T=3.75D0/X BI0=((((((((.00392377D0*T-.01647633D0)*T & +.02635537D0)*T-.02057706D0)*T+.916281D-2)*T & -.157565D-2)*T+.225319D-2)*T+.01328592D0)*T & +.39894228D0)*EXP(X)/DSQRT(X) BI1=((((((((-.420059D-2*T+.01787654D0)*T & -.02895312D0)*T+.02282967D0)*T-.01031555D0)*T & +.163801D-2)*T-.00362018D0)*T-.03988024D0)*T & +.39894228D0)*EXP(X)/DSQRT(X) ENDIF IF (X.LE.2.0D0) THEN T=X/2.0D0 T2=T*T BK0=(((((.0000074D0*T2+.0001075D0)*T2+.00262698D0) & *T2+.0348859D0)*T2+.23069756D0)*T2+.4227842D0) & *T2-.57721566D0-BI0*DLOG(T) BK1=((((((-.00004686D0*T2-.00110404D0)*T2 & -.01919402D0)*T2-.18156897D0)*T2-.67278579D0) & *T2+.15443144D0)*T2+1.0D0)/X+BI1*DLOG(T) ELSE T=2.0D0/X T2=T*T BK0=((((((.00053208D0*T-.0025154D0)*T+.00587872D0) & *T-.01062446D0)*T+.02189568D0)*T-.07832358D0) & *T+1.25331414D0)*EXP(-X)/DSQRT(X) BK1=((((((-.00068245D0*T+.00325614D0)*T & -.00780353D0)*T+.01504268D0)*T-.0365562D0)*T+ & .23498619D0)*T+1.25331414D0)*EXP(-X)/DSQRT(X) ENDIF DI0=BI1 DI1=BI0-BI1/X DK0=-BK1 DK1=-BK0-BK1/X RETURN END C ********************************** SUBROUTINE BETA(P,Q,BT) C C ========================================== C Purpose: Compute the beta function B(p,q) C Input : p --- Parameter ( p > 0 ) C q --- Parameter ( q > 0 ) C Output: BT --- B(p,q) C Routine called: GAMMA2 for computing Г(x) C ========================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) CALL GAMMA2(P,GP) CALL GAMMA2(Q,GQ) PPQ=P+Q CALL GAMMA2(PPQ,GPQ) BT=GP*GQ/GPQ RETURN END C ********************************** SUBROUTINE LPN(N,X,PN,PD) C C =============================================== C Purpose: Compute Legendre polynomials Pn(x) C and their derivatives Pn'(x) C Input : x --- Argument of Pn(x) C n --- Degree of Pn(x) ( n = 0,1,...) C Output: PN(n) --- Pn(x) C PD(n) --- Pn'(x) C =============================================== C IMPLICIT DOUBLE PRECISION (P,X) DIMENSION PN(0:N),PD(0:N) PN(0)=1.0D0 PN(1)=X PD(0)=0.0D0 PD(1)=1.0D0 P0=1.0D0 P1=X DO 10 K=2,N PF=(2.0D0*K-1.0D0)/K*X*P1-(K-1.0D0)/K*P0 PN(K)=PF IF (DABS(X).EQ.1.0D0) THEN PD(K)=0.5D0*X**(K+1)*K*(K+1.0D0) ELSE PD(K)=K*(P1-X*PF)/(1.0D0-X*X) ENDIF P0=P1 10 P1=PF RETURN END C ********************************** SUBROUTINE FCOEF(KD,M,Q,A,FC) C C ===================================================== C Purpose: Compute expansion coefficients for Mathieu C functions and modified Mathieu functions C Input : m --- Order of Mathieu functions C q --- Parameter of Mathieu functions C KD --- Case code C KD=1 for cem(x,q) ( m = 0,2,4,...) C KD=2 for cem(x,q) ( m = 1,3,5,...) C KD=3 for sem(x,q) ( m = 1,3,5,...) C KD=4 for sem(x,q) ( m = 2,4,6,...) C A --- Characteristic value of Mathieu C functions for given m and q C Output: FC(k) --- Expansion coefficients of Mathieu C functions ( k= 1,2,...,KM ) C FC(1),FC(2),FC(3),... correspond to C A0,A2,A4,... for KD=1 case, A1,A3, C A5,... for KD=2 case, B1,B3,B5,... C for KD=3 case and B2,B4,B6,... for C KD=4 case C ===================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION FC(251) DO 5 I=1,251 5 FC(I)=0.0D0 IF (DABS(Q).LE.1.0D-7) THEN C Expansion up to order Q^1 (Abramowitz & Stegun 20.2.27-28) IF (KD.EQ.1) THEN JM=M/2 + 1 ELSE IF (KD.EQ.2.OR.KD.EQ.3) THEN JM=(M-1)/2+1 ELSE IF (KD.EQ.4) THEN JM=M/2 END IF C Check for overflow IF (JM+1.GT.251) THEN FNAN=DNAN() DO 7666 I=1,251 7666 FC(I)=FNAN RETURN ENDIF C Proceed using the simplest expansion IF (KD.EQ.1.OR.KD.EQ.2) THEN IF (M.EQ.0) THEN FC(1) = 1/SQRT(2.0D0) FC(2) = -Q/2.0D0/SQRT(2.0D0) ELSE IF (M.EQ.1) THEN FC(1) = 1.0D0 FC(2) = -Q/8.0D0 ELSE IF (M.EQ.2) THEN FC(1) = Q/4.0D0 FC(2) = 1.0D0 FC(3) = -Q/12.0D0 ELSE FC(JM) = 1.0D0 FC(JM+1) = -Q/(4.0D0 * (M + 1)) FC(JM-1) = Q/(4.0D0 * (M - 1)) END IF ELSE IF (KD.EQ.3.OR.KD.EQ.4) THEN IF (M.EQ.1) THEN FC(1) = 1.0D0 FC(2) = -Q/8.0D0 ELSE IF (M.EQ.2) THEN FC(1) = 1.0D0 FC(2) = -Q/12.0D0 ELSE FC(JM) = 1.0D0 FC(JM+1) = -Q/(4.0D0 * (M + 1)) FC(JM-1) = Q/(4.0D0 * (M - 1)) END IF ENDIF RETURN ELSE IF (Q.LE.1.0D0) THEN QM=7.5+56.1*SQRT(Q)-134.7*Q+90.7*SQRT(Q)*Q ELSE QM=17.0+3.1*SQRT(Q)-.126*Q+.0037*SQRT(Q)*Q ENDIF KM=INT(QM+0.5*M) IF (KM.GT.251) THEN C Overflow, generate NaNs FNAN=DNAN() DO 7 I=1,251 7 FC(I)=FNAN RETURN ENDIF KB=0 S=0.0D0 F=1.0D-100 U=0.0D0 FC(KM)=0.0D0 F2=0.0D0 IF (KD.EQ.1) THEN DO 25 K=KM,3,-1 V=U U=F F=(A-4.0D0*K*K)*U/Q-V IF (DABS(F).LT.DABS(FC(K+1))) THEN KB=K FC(1)=1.0D-100 SP=0.0D0 F3=FC(K+1) FC(2)=A/Q*FC(1) FC(3)=(A-4.0D0)*FC(2)/Q-2.0D0*FC(1) U=FC(2) F1=FC(3) DO 15 I=3,KB V=U U=F1 F1=(A-4.0D0*(I-1.0D0)**2)*U/Q-V FC(I+1)=F1 IF (I.EQ.KB) F2=F1 IF (I.NE.KB) SP=SP+F1*F1 15 CONTINUE SP=SP+2.0D0*FC(1)**2+FC(2)**2+FC(3)**2 SS=S+SP*(F3/F2)**2 S0=DSQRT(1.0D0/SS) DO 20 J=1,KM IF (J.LE.KB+1) THEN FC(J)=S0*FC(J)*F3/F2 ELSE FC(J)=S0*FC(J) ENDIF 20 CONTINUE GO TO 85 ELSE FC(K)=F S=S+F*F ENDIF 25 CONTINUE FC(2)=Q*FC(3)/(A-4.0D0-2.0D0*Q*Q/A) FC(1)=Q/A*FC(2) S=S+2.0D0*FC(1)**2+FC(2)**2 S0=DSQRT(1.0D0/S) DO 30 K=1,KM 30 FC(K)=S0*FC(K) ELSE IF (KD.EQ.2.OR.KD.EQ.3) THEN DO 35 K=KM,3,-1 V=U U=F F=(A-(2.0D0*K-1)**2)*U/Q-V IF (DABS(F).GE.DABS(FC(K))) THEN FC(K-1)=F S=S+F*F ELSE KB=K F3=FC(K) GO TO 45 ENDIF 35 CONTINUE FC(1)=Q/(A-1.0D0-(-1)**KD*Q)*FC(2) S=S+FC(1)*FC(1) S0=DSQRT(1.0D0/S) DO 40 K=1,KM 40 FC(K)=S0*FC(K) GO TO 85 45 FC(1)=1.0D-100 FC(2)=(A-1.0D0-(-1)**KD*Q)/Q*FC(1) SP=0.0D0 U=FC(1) F1=FC(2) DO 50 I=2,KB-1 V=U U=F1 F1=(A-(2.0D0*I-1.0D0)**2)*U/Q-V IF (I.NE.KB-1) THEN FC(I+1)=F1 SP=SP+F1*F1 ELSE F2=F1 ENDIF 50 CONTINUE SP=SP+FC(1)**2+FC(2)**2 SS=S+SP*(F3/F2)**2 S0=1.0D0/DSQRT(SS) DO 55 J=1,KM IF (J.LT.KB) FC(J)=S0*FC(J)*F3/F2 IF (J.GE.KB) FC(J)=S0*FC(J) 55 CONTINUE ELSE IF (KD.EQ.4) THEN DO 60 K=KM,3,-1 V=U U=F F=(A-4.0D0*K*K)*U/Q-V IF (DABS(F).GE.DABS(FC(K))) THEN FC(K-1)=F S=S+F*F ELSE KB=K F3=FC(K) GO TO 70 ENDIF 60 CONTINUE FC(1)=Q/(A-4.0D0)*FC(2) S=S+FC(1)*FC(1) S0=DSQRT(1.0D0/S) DO 65 K=1,KM 65 FC(K)=S0*FC(K) GO TO 85 70 FC(1)=1.0D-100 FC(2)=(A-4.0D0)/Q*FC(1) SP=0.0D0 U=FC(1) F1=FC(2) DO 75 I=2,KB-1 V=U U=F1 F1=(A-4.0D0*I*I)*U/Q-V IF (I.NE.KB-1) THEN FC(I+1)=F1 SP=SP+F1*F1 ELSE F2=F1 ENDIF 75 CONTINUE SP=SP+FC(1)**2+FC(2)**2 SS=S+SP*(F3/F2)**2 S0=1.0D0/DSQRT(SS) DO 80 J=1,KM IF (J.LT.KB) FC(J)=S0*FC(J)*F3/F2 IF (J.GE.KB) FC(J)=S0*FC(J) 80 CONTINUE ENDIF 85 IF (FC(1).LT.0.0D0) THEN DO 90 J=1,KM 90 FC(J)=-FC(J) ENDIF RETURN END C ********************************** SUBROUTINE SPHI(N,X,NM,SI,DI) C C ======================================================== C Purpose: Compute modified spherical Bessel functions C of the first kind, in(x) and in'(x) C Input : x --- Argument of in(x) C n --- Order of in(x) ( n = 0,1,2,... ) C Output: SI(n) --- in(x) C DI(n) --- in'(x) C NM --- Highest order computed C Routines called: C MSTA1 and MSTA2 for computing the starting C point for backward recurrence C ======================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION SI(0:N),DI(0:N) NM=N IF (DABS(X).LT.1.0D-100) THEN DO 10 K=0,N SI(K)=0.0D0 10 DI(K)=0.0D0 SI(0)=1.0D0 DI(1)=0.333333333333333D0 RETURN ENDIF SI(0)=DSINH(X)/X SI(1)=-(DSINH(X)/X-DCOSH(X))/X SI0=SI(0) IF (N.GE.2) THEN M=MSTA1(X,200) IF (M.LT.N) THEN NM=M ELSE M=MSTA2(X,N,15) ENDIF F=0.0D0 F0=0.0D0 F1=1.0D0-100 DO 15 K=M,0,-1 F=(2.0D0*K+3.0D0)*F1/X+F0 IF (K.LE.NM) SI(K)=F F0=F1 15 F1=F CS=SI0/F DO 20 K=0,NM 20 SI(K)=CS*SI(K) ENDIF DI(0)=SI(1) DO 25 K=1,NM 25 DI(K)=SI(K-1)-(K+1.0D0)/X*SI(K) RETURN END C ********************************** SUBROUTINE PBWA(A,X,W1F,W1D,W2F,W2D) C C ====================================================== C Purpose: Compute parabolic cylinder functions W(a,±x) C and their derivatives C Input : a --- Parameter ( 0 ≤ |a| ≤ 5 ) C x --- Argument of W(a,±x) ( 0 ≤ |x| ≤ 5 ) C Output : W1F --- W(a,x) C W1D --- W'(a,x) C W2F --- W(a,-x) C W2D --- W'(a,-x) C Routine called: C CGAMA for computing complex gamma function C ====================================================== C IMPLICIT DOUBLE PRECISION (A,B,D-H,O-Y) IMPLICIT COMPLEX *16 (C,Z) DIMENSION H(100),D(80) EPS=1.0D-15 P0=0.59460355750136D0 IF (A.EQ.0.0D0) THEN G1=3.625609908222D0 G2=1.225416702465D0 ELSE X1=0.25D0 Y1=0.5D0*A CALL CGAMA(X1,Y1,1,UGR,UGI) G1=DSQRT(UGR*UGR+UGI*UGI) X2=0.75D0 CALL CGAMA(X2,Y1,1,VGR,VGI) G2=DSQRT(VGR*VGR+VGI*VGI) ENDIF F1=DSQRT(G1/G2) F2=DSQRT(2.0D0*G2/G1) H0=1.0D0 H1=A H(1)=A DO 10 L1=4,200,2 M=L1/2 HL=A*H1-0.25D0*(L1-2.0D0)*(L1-3.0D0)*H0 H(M)=HL H0=H1 10 H1=HL Y1F=1.0D0 R=1.0D0 DO 15 K=1,100 R=0.5D0*R*X*X/(K*(2.0D0*K-1.0D0)) R1=H(K)*R Y1F=Y1F+R1 IF (DABS(R1).LE.EPS*DABS(Y1F).AND.K.GT.30) GO TO 20 15 CONTINUE 20 Y1D=A R=1.0D0 DO 25 K=1,99 R=0.5D0*R*X*X/(K*(2.0D0*K+1.0D0)) R1=H(K+1)*R Y1D=Y1D+R1 IF (DABS(R1).LE.EPS*DABS(Y1D).AND.K.GT.30) GO TO 30 25 CONTINUE 30 Y1D=X*Y1D D1=1.0D0 D2=A D(1)=1.0D0 D(2)=A DO 40 L2=5,160,2 M=(L2+1)/2 DL=A*D2-0.25D0*(L2-2.0D0)*(L2-3.0D0)*D1 D(M)=DL D1=D2 40 D2=DL Y2F=1.0D0 R=1.0D0 DO 45 K=1,79 R=0.5D0*R*X*X/(K*(2.0D0*K+1.0D0)) R1=D(K+1)*R Y2F=Y2F+R1 IF (DABS(R1).LE.EPS*DABS(Y2F).AND.K.GT.30) GO TO 50 45 CONTINUE 50 Y2F=X*Y2F Y2D=1.0D0 R=1.0D0 DO 55 K=1,79 R=0.5D0*R*X*X/(K*(2.0D0*K-1.0D0)) R1=D(K+1)*R Y2D=Y2D+R1 IF (DABS(R1).LE.EPS*DABS(Y2F).AND.K.GT.30) GO TO 60 55 CONTINUE 60 W1F=P0*(F1*Y1F-F2*Y2F) W2F=P0*(F1*Y1F+F2*Y2F) W1D=P0*(F1*Y1D-F2*Y2D) W2D=P0*(F1*Y1D+F2*Y2D) RETURN END C ********************************** SUBROUTINE RMN1(M,N,C,X,DF,KD,R1F,R1D) C C ======================================================= C Purpose: Compute prolate and oblate spheroidal radial C functions of the first kind for given m, n, C c and x C Routines called: C (1) SCKB for computing expansion coefficients c2k C (2) SPHJ for computing the spherical Bessel C functions of the first kind C ======================================================= C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION CK(200),DF(200),SJ(0:251),DJ(0:251) EPS=1.0D-14 IP=1 NM1=INT((N-M)/2) IF (N-M.EQ.2*NM1) IP=0 NM=25+NM1+INT(C) REG=1.0D0 IF (M+NM.GT.80) REG=1.0D-200 R0=REG DO 10 J=1,2*M+IP 10 R0=R0*J R=R0 SUC=R*DF(1) SW=0.0D0 DO 15 K=2,NM R=R*(M+K-1.0)*(M+K+IP-1.5D0)/(K-1.0D0)/(K+IP-1.5D0) SUC=SUC+R*DF(K) IF (K.GT.NM1.AND.DABS(SUC-SW).LT.DABS(SUC)*EPS) GO TO 20 15 SW=SUC 20 CONTINUE IF (X.EQ.0.0) THEN CALL SCKB(M,N,C,DF,CK) SUM=0.0D0 SW1=0.0D0 DO 25 J=1,NM SUM=SUM+CK(J) IF (DABS(SUM-SW1).LT.DABS(SUM)*EPS) GO TO 30 25 SW1=SUM 30 R1=1.0D0 DO 35 J=1,(N+M+IP)/2 35 R1=R1*(J+0.5D0*(N+M+IP)) R2=1.0D0 DO 40 J=1,M 40 R2=2.0D0*C*R2*J R3=1.0D0 DO 45 J=1,(N-M-IP)/2 45 R3=R3*J SA0=(2.0*(M+IP)+1.0)*R1/(2.0**N*C**IP*R2*R3) IF (IP.EQ.0) THEN R1F=SUM/(SA0*SUC)*DF(1)*REG R1D=0.0D0 ELSE IF (IP.EQ.1) THEN R1F=0.0D0 R1D=SUM/(SA0*SUC)*DF(1)*REG ENDIF RETURN ENDIF CX=C*X NM2=2*NM+M CALL SPHJ(NM2,CX,NM2,SJ,DJ) A0=(1.0D0-KD/(X*X))**(0.5D0*M)/SUC R1F=0.0D0 SW=0.0D0 LG=0 DO 50 K=1,NM L=2*K+M-N-2+IP IF (L.EQ.4*INT(L/4)) LG=1 IF (L.NE.4*INT(L/4)) LG=-1 IF (K.EQ.1) THEN R=R0 ELSE R=R*(M+K-1.0)*(M+K+IP-1.5D0)/(K-1.0D0)/(K+IP-1.5D0) ENDIF NP=M+2*K-2+IP R1F=R1F+LG*R*DF(K)*SJ(NP) IF (K.GT.NM1.AND.DABS(R1F-SW).LT.DABS(R1F)*EPS) GO TO 55 50 SW=R1F 55 R1F=R1F*A0 B0=KD*M/X**3.0D0/(1.0-KD/(X*X))*R1F SUD=0.0D0 SW=0.0D0 DO 60 K=1,NM L=2*K+M-N-2+IP IF (L.EQ.4*INT(L/4)) LG=1 IF (L.NE.4*INT(L/4)) LG=-1 IF (K.EQ.1) THEN R=R0 ELSE R=R*(M+K-1.0)*(M+K+IP-1.5D0)/(K-1.0D0)/(K+IP-1.5D0) ENDIF NP=M+2*K-2+IP SUD=SUD+LG*R*DF(K)*DJ(NP) IF (K.GT.NM1.AND.DABS(SUD-SW).LT.DABS(SUD)*EPS) GO TO 65 60 SW=SUD 65 R1D=B0+A0*C*SUD RETURN END C ********************************** SUBROUTINE DVSA(VA,X,PD) C C =================================================== C Purpose: Compute parabolic cylinder function Dv(x) C for small argument C Input: x --- Argument C va --- Order C Output: PD --- Dv(x) C Routine called: GAMMA2 for computing Г(x) C =================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) EPS=1.0D-15 PI=3.141592653589793D0 SQ2=DSQRT(2.0D0) EP=EXP(-.25D0*X*X) VA0=0.5D0*(1.0D0-VA) IF (VA.EQ.0.0) THEN PD=EP ELSE IF (X.EQ.0.0) THEN IF (VA0.LE.0.0.AND.VA0.EQ.INT(VA0)) THEN PD=0.0D0 ELSE CALL GAMMA2(VA0,GA0) PD=DSQRT(PI)/(2.0D0**(-.5D0*VA)*GA0) ENDIF ELSE CALL GAMMA2(-VA,G1) A0=2.0D0**(-0.5D0*VA-1.0D0)*EP/G1 VT=-.5D0*VA CALL GAMMA2(VT,G0) PD=G0 R=1.0D0 DO 10 M=1,250 VM=.5D0*(M-VA) CALL GAMMA2(VM,GM) R=-R*SQ2*X/M R1=GM*R PD=PD+R1 IF (DABS(R1).LT.DABS(PD)*EPS) GO TO 15 10 CONTINUE 15 PD=A0*PD ENDIF ENDIF RETURN END C ********************************** SUBROUTINE E1Z(Z,CE1) C C ==================================================== C Purpose: Compute complex exponential integral E1(z) C Input : z --- Argument of E1(z) C Output: CE1 --- E1(z) C ==================================================== C IMPLICIT COMPLEX*16 (C,Z) IMPLICIT DOUBLE PRECISION (A,D-H,O-Y) PI=3.141592653589793D0 EL=0.5772156649015328D0 X=DBLE(Z) A0=ABS(Z) C Continued fraction converges slowly near negative real axis, C so use power series in a wedge around it until radius 40.0 XT=-2*DABS(DIMAG(Z)) IF (A0.EQ.0.0D0) THEN CE1=(1.0D+300,0.0D0) ELSE IF (A0.LE.5.0.OR.X.LT.XT.AND.A0.LT.40.0) THEN C Power series CE1=(1.0D0,0.0D0) CR=(1.0D0,0.0D0) DO 10 K=1,500 CR=-CR*K*Z/(K+1.0D0)**2 CE1=CE1+CR IF (ABS(CR).LE.ABS(CE1)*1.0D-15) GO TO 15 10 CONTINUE 15 CONTINUE IF (X.LE.0.0.AND.DIMAG(Z).EQ.0.0) THEN C Careful on the branch cut -- use the sign of the imaginary part C to get the right sign on the factor if pi. CE1=-EL-LOG(-Z)+Z*CE1-DSIGN(PI,DIMAG(Z))*(0.0D0,1.0D0) ELSE CE1=-EL-LOG(Z)+Z*CE1 ENDIF ELSE C Continued fraction https://dlmf.nist.gov/6.9 C C 1 1 1 2 2 3 3 C E1 = exp(-z) * ----- ----- ----- ----- ----- ----- ----- ... C Z + 1 + Z + 1 + Z + 1 + Z + ZC=0D0 ZD=1/Z ZDC=1*ZD ZC=ZC + ZDC DO 20 K=1,500 ZD=1/(ZD*K + 1) ZDC=(1*ZD - 1)*ZDC ZC=ZC + ZDC ZD=1/(ZD*K + Z) ZDC=(Z*ZD - 1)*ZDC ZC=ZC + ZDC IF (ABS(ZDC).LE.ABS(ZC)*1.0D-15.AND.K.GT.20) GO TO 25 20 CONTINUE 25 CE1=EXP(-Z)*ZC IF (X.LE.0.0.AND.DIMAG(Z).EQ.0.0) CE1=CE1-PI*(0.0D0,1.0D0) ENDIF RETURN END C ********************************** SUBROUTINE ITJYB(X,TJ,TY) C C ======================================================= C Purpose: Integrate Bessel functions J0(t) and Y0(t) C with respect to t from 0 to x ( x ≥ 0 ) C Input : x --- Upper limit of the integral C Output: TJ --- Integration of J0(t) from 0 to x C TY --- Integration of Y0(t) from 0 to x C ======================================================= C IMPLICIT DOUBLE PRECISION (A-H,O-Z) PI=3.141592653589793D0 IF (X.EQ.0.0D0) THEN TJ=0.0D0 TY=0.0D0 ELSE IF (X.LE.4.0D0) THEN X1=X/4.0D0 T=X1*X1 TJ=(((((((-.133718D-3*T+.2362211D-2)*T & -.025791036D0)*T+.197492634D0)*T-1.015860606D0) & *T+3.199997842D0)*T-5.333333161D0)*T+4.0D0)*X1 TY=((((((((.13351D-4*T-.235002D-3)*T+.3034322D-2)* & T-.029600855D0)*T+.203380298D0)*T-.904755062D0) & *T+2.287317974D0)*T-2.567250468D0)*T & +1.076611469D0)*X1 TY=2.0D0/PI*DLOG(X/2.0D0)*TJ-TY ELSE IF (X.LE.8.0D0) THEN XT=X-.25D0*PI T=16.0D0/(X*X) F0=((((((.1496119D-2*T-.739083D-2)*T+.016236617D0) & *T-.022007499D0)*T+.023644978D0) & *T-.031280848D0)*T+.124611058D0)*4.0D0/X G0=(((((.1076103D-2*T-.5434851D-2)*T+.01242264D0) & *T-.018255209)*T+.023664841D0)*T-.049635633D0) & *T+.79784879D0 TJ=1.0D0-(F0*DCOS(XT)-G0*DSIN(XT))/DSQRT(X) TY=-(F0*DSIN(XT)+G0*DCOS(XT))/DSQRT(X) ELSE T=64.0D0/(X*X) XT=X-.25D0*PI F0=(((((((-.268482D-4*T+.1270039D-3)*T & -.2755037D-3)*T+.3992825D-3)*T-.5366169D-3)*T & +.10089872D-2)*T-.40403539D-2)*T+.0623347304D0) & *8.0D0/X G0=((((((-.226238D-4*T+.1107299D-3)*T-.2543955D-3) & *T+.4100676D-3)*T-.6740148D-3)*T+.17870944D-2) & *T-.01256424405D0)*T+.79788456D0 TJ=1.0D0-(F0*DCOS(XT)-G0*DSIN(XT))/DSQRT(X) TY=-(F0*DSIN(XT)+G0*DCOS(XT))/DSQRT(X) ENDIF RETURN END C ********************************** SUBROUTINE CHGUL(A,B,X,HU,ID) C C ======================================================= C Purpose: Compute the confluent hypergeometric function C U(a,b,x) for large argument x C Input : a --- Parameter C b --- Parameter C x --- Argument C Output: HU --- U(a,b,x) C ID --- Estimated number of significant digits C ======================================================= C IMPLICIT DOUBLE PRECISION (A-H,O-Z) LOGICAL IL1,IL2 ID=-100 AA=A-B+1.0D0 IL1=A.EQ.INT(A).AND.A.LE.0.0 IL2=AA.EQ.INT(AA).AND.AA.LE.0.0 NM=0 IF (IL1) NM=ABS(A) IF (IL2) NM=ABS(AA) C IL1: DLMF 13.2.7 with k=-s-a C IL2: DLMF 13.2.8 IF (IL1.OR.IL2) THEN HU=1.0D0 R=1.0D0 DO 10 K=1,NM R=-R*(A+K-1.0D0)*(A-B+K)/(K*X) HU=HU+R 10 CONTINUE HU=X**(-A)*HU ID=10 ELSE C DLMF 13.7.3 HU=1.0D0 R=1.0D0 DO 15 K=1,25 R=-R*(A+K-1.0D0)*(A-B+K)/(K*X) RA=DABS(R) IF (K.GT.5.AND.RA.GE.R0.OR.RA.LT.1.0D-15) GO TO 20 R0=RA 15 HU=HU+R 20 ID=ABS(LOG10(RA)) HU=X**(-A)*HU ENDIF RETURN END C ********************************** SUBROUTINE GMN(M,N,C,X,BK,GF,GD) C C =========================================================== C Purpose: Compute gmn(-ic,ix) and its derivative for oblate C radial functions with a small argument C =========================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION BK(200) EPS=1.0D-14 IP=1 IF (N-M.EQ.2*INT((N-M)/2)) IP=0 NM=25+INT(0.5*(N-M)+C) XM=(1.0D0+X*X)**(-0.5D0*M) GF0=0.0D0 GW=0.0D0 DO 10 K=1,NM GF0=GF0+BK(K)*X**(2.0*K-2.0) IF (DABS((GF0-GW)/GF0).LT.EPS.AND.K.GE.10) GO TO 15 10 GW=GF0 15 GF=XM*GF0*X**(1-IP) GD1=-M*X/(1.0D0+X*X)*GF GD0=0.0D0 DO 20 K=1,NM IF (IP.EQ.0) THEN GD0=GD0+(2.0D0*K-1.0)*BK(K)*X**(2.0*K-2.0) ELSE GD0=GD0+2.0D0*K*BK(K+1)*X**(2.0*K-1.0) ENDIF IF (DABS((GD0-GW)/GD0).LT.EPS.AND.K.GE.10) GO TO 25 20 GW=GD0 25 GD=GD1+XM*GD0 RETURN END C ********************************** SUBROUTINE ITJYA(X,TJ,TY) C C ========================================================== C Purpose: Integrate Bessel functions J0(t) & Y0(t) with C respect to t from 0 to x C Input : x --- Upper limit of the integral ( x >= 0 ) C Output: TJ --- Integration of J0(t) from 0 to x C TY --- Integration of Y0(t) from 0 to x C ======================================================= C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION A(18) PI=3.141592653589793D0 EL=.5772156649015329D0 EPS=1.0D-12 IF (X.EQ.0.0D0) THEN TJ=0.0D0 TY=0.0D0 ELSE IF (X.LE.20.0D0) THEN X2=X*X TJ=X R=X DO 10 K=1,60 R=-.25D0*R*(2*K-1.0D0)/(2*K+1.0D0)/(K*K)*X2 TJ=TJ+R IF (DABS(R).LT.DABS(TJ)*EPS) GO TO 15 10 CONTINUE 15 TY1=(EL+DLOG(X/2.0D0))*TJ RS=0.0D0 TY2=1.0D0 R=1.0D0 DO 20 K=1,60 R=-.25D0*R*(2*K-1.0D0)/(2*K+1.0D0)/(K*K)*X2 RS=RS+1.0D0/K R2=R*(RS+1.0D0/(2.0D0*K+1.0D0)) TY2=TY2+R2 IF (DABS(R2).LT.DABS(TY2)*EPS) GO TO 25 20 CONTINUE 25 TY=(TY1-X*TY2)*2.0D0/PI ELSE A0=1.0D0 A1=5.0D0/8.0D0 A(1)=A1 DO 30 K=1,16 AF=((1.5D0*(K+.5D0)*(K+5.0D0/6.0D0)*A1-.5D0 & *(K+.5D0)*(K+.5D0)*(K-.5D0)*A0))/(K+1.0D0) A(K+1)=AF A0=A1 30 A1=AF BF=1.0D0 R=1.0D0 DO 35 K=1,8 R=-R/(X*X) 35 BF=BF+A(2*K)*R BG=A(1)/X R=1.0D0/X DO 40 K=1,8 R=-R/(X*X) 40 BG=BG+A(2*K+1)*R XP=X+.25D0*PI RC=DSQRT(2.0D0/(PI*X)) TJ=1.0D0-RC*(BF*DCOS(XP)+BG*DSIN(XP)) TY=RC*(BG*DCOS(XP)-BF*DSIN(XP)) ENDIF RETURN END C ********************************** SUBROUTINE RCTY(N,X,NM,RY,DY) C C ======================================================== C Purpose: Compute Riccati-Bessel functions of the second C kind and their derivatives C Input: x --- Argument of Riccati-Bessel function C n --- Order of yn(x) C Output: RY(n) --- x·yn(x) C DY(n) --- [x·yn(x)]' C NM --- Highest order computed C ======================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION RY(0:N),DY(0:N) NM=N IF (X.LT.1.0D-60) THEN DO 10 K=0,N RY(K)=-1.0D+300 10 DY(K)=1.0D+300 RY(0)=-1.0D0 DY(0)=0.0D0 RETURN ENDIF RY(0)=-DCOS(X) RY(1)=RY(0)/X-DSIN(X) RF0=RY(0) RF1=RY(1) DO 15 K=2,N RF2=(2.0D0*K-1.0D0)*RF1/X-RF0 IF (DABS(RF2).GT.1.0D+300) GO TO 20 RY(K)=RF2 RF0=RF1 15 RF1=RF2 20 NM=K-1 DY(0)=DSIN(X) DO 25 K=1,NM 25 DY(K)=-K*RY(K)/X+RY(K-1) RETURN END C ********************************** SUBROUTINE LPNI(N,X,PN,PD,PL) C C ===================================================== C Purpose: Compute Legendre polynomials Pn(x), Pn'(x) C and the integral of Pn(t) from 0 to x C Input : x --- Argument of Pn(x) C n --- Degree of Pn(x) ( n = 0,1,... ) C Output: PN(n) --- Pn(x) C PD(n) --- Pn'(x) C PL(n) --- Integral of Pn(t) from 0 to x C ===================================================== C IMPLICIT DOUBLE PRECISION (P,R,X) DIMENSION PN(0:N),PD(0:N),PL(0:N) PN(0)=1.0D0 PN(1)=X PD(0)=0.0D0 PD(1)=1.0D0 PL(0)=X PL(1)=0.5D0*X*X P0=1.0D0 P1=X DO 15 K=2,N PF=(2.0D0*K-1.0D0)/K*X*P1-(K-1.0D0)/K*P0 PN(K)=PF IF (DABS(X).EQ.1.0D0) THEN PD(K)=0.5D0*X**(K+1)*K*(K+1.0D0) ELSE PD(K)=K*(P1-X*PF)/(1.0D0-X*X) ENDIF PL(K)=(X*PN(K)-PN(K-1))/(K+1.0D0) P0=P1 P1=PF IF (K.EQ.2*INT(K/2)) GO TO 15 R=1.0D0/(K+1.0D0) N1=(K-1)/2 DO 10 J=1,N1 10 R=(0.5D0/J-1.0D0)*R PL(K)=PL(K)+R 15 CONTINUE RETURN END C ********************************** SUBROUTINE KLVNA(X,BER,BEI,GER,GEI,DER,DEI,HER,HEI) C C ====================================================== C Purpose: Compute Kelvin functions ber x, bei x, ker x C and kei x, and their derivatives ( x > 0 ) C Input : x --- Argument of Kelvin functions C Output: BER --- ber x C BEI --- bei x C GER --- ker x C GEI --- kei x C DER --- ber'x C DEI --- bei'x C HER --- ker'x C HEI --- kei'x C ================================================ C IMPLICIT DOUBLE PRECISION (A-H,O-Z) PI=3.141592653589793D0 EL=.5772156649015329D0 EPS=1.0D-15 IF (X.EQ.0.0D0) THEN BER=1.0D0 BEI=0.0D0 GER=1.0D+300 GEI=-0.25D0*PI DER=0.0D0 DEI=0.0D0 HER=-1.0D+300 HEI=0.0D0 RETURN ENDIF X2=0.25D0*X*X X4=X2*X2 IF (DABS(X).LT.10.0D0) THEN BER=1.0D0 R=1.0D0 DO 10 M=1,60 R=-0.25D0*R/(M*M)/(2.0D0*M-1.0D0)**2*X4 BER=BER+R IF (DABS(R).LT.DABS(BER)*EPS) GO TO 15 10 CONTINUE 15 BEI=X2 R=X2 DO 20 M=1,60 R=-0.25D0*R/(M*M)/(2.0D0*M+1.0D0)**2*X4 BEI=BEI+R IF (DABS(R).LT.DABS(BEI)*EPS) GO TO 25 20 CONTINUE 25 GER=-(DLOG(X/2.0D0)+EL)*BER+0.25D0*PI*BEI R=1.0D0 GS=0.0D0 DO 30 M=1,60 R=-0.25D0*R/(M*M)/(2.0D0*M-1.0D0)**2*X4 GS=GS+1.0D0/(2.0D0*M-1.0D0)+1.0D0/(2.0D0*M) GER=GER+R*GS IF (DABS(R*GS).LT.DABS(GER)*EPS) GO TO 35 30 CONTINUE 35 GEI=X2-(DLOG(X/2.0D0)+EL)*BEI-0.25D0*PI*BER R=X2 GS=1.0D0 DO 40 M=1,60 R=-0.25D0*R/(M*M)/(2.0D0*M+1.0D0)**2*X4 GS=GS+1.0D0/(2.0D0*M)+1.0D0/(2.0D0*M+1.0D0) GEI=GEI+R*GS IF (DABS(R*GS).LT.DABS(GEI)*EPS) GO TO 45 40 CONTINUE 45 DER=-0.25D0*X*X2 R=DER DO 50 M=1,60 R=-0.25D0*R/M/(M+1.0D0)/(2.0D0*M+1.0D0)**2*X4 DER=DER+R IF (DABS(R).LT.DABS(DER)*EPS) GO TO 55 50 CONTINUE 55 DEI=0.5D0*X R=DEI DO 60 M=1,60 R=-0.25D0*R/(M*M)/(2.D0*M-1.D0)/(2.D0*M+1.D0)*X4 DEI=DEI+R IF (DABS(R).LT.DABS(DEI)*EPS) GO TO 65 60 CONTINUE 65 R=-0.25D0*X*X2 GS=1.5D0 HER=1.5D0*R-BER/X-(DLOG(X/2.D0)+EL)*DER+0.25*PI*DEI DO 70 M=1,60 R=-0.25D0*R/M/(M+1.0D0)/(2.0D0*M+1.0D0)**2*X4 GS=GS+1.0D0/(2*M+1.0D0)+1.0D0/(2*M+2.0D0) HER=HER+R*GS IF (DABS(R*GS).LT.DABS(HER)*EPS) GO TO 75 70 CONTINUE 75 R=0.5D0*X GS=1.0D0 HEI=0.5D0*X-BEI/X-(DLOG(X/2.D0)+EL)*DEI-0.25*PI*DER DO 80 M=1,60 R=-0.25D0*R/(M*M)/(2*M-1.0D0)/(2*M+1.0D0)*X4 GS=GS+1.0D0/(2.0D0*M)+1.0D0/(2*M+1.0D0) HEI=HEI+R*GS IF (DABS(R*GS).LT.DABS(HEI)*EPS) RETURN 80 CONTINUE ELSE PP0=1.0D0 PN0=1.0D0 QP0=0.0D0 QN0=0.0D0 R0=1.0D0 KM=18 IF (DABS(X).GE.40.0) KM=10 FAC=1.0D0 DO 85 K=1,KM FAC=-FAC XT=0.25D0*K*PI-INT(0.125D0*K)*2.0D0*PI CS=COS(XT) SS=SIN(XT) R0=0.125D0*R0*(2.0D0*K-1.0D0)**2/K/X RC=R0*CS RS=R0*SS PP0=PP0+RC PN0=PN0+FAC*RC QP0=QP0+RS 85 QN0=QN0+FAC*RS XD=X/DSQRT(2.0D0) XE1=EXP(XD) XE2=EXP(-XD) XC1=1.D0/DSQRT(2.0D0*PI*X) XC2=DSQRT(.5D0*PI/X) CP0=DCOS(XD+0.125D0*PI) CN0=DCOS(XD-0.125D0*PI) SP0=DSIN(XD+0.125D0*PI) SN0=DSIN(XD-0.125D0*PI) GER=XC2*XE2*(PN0*CP0-QN0*SP0) GEI=XC2*XE2*(-PN0*SP0-QN0*CP0) BER=XC1*XE1*(PP0*CN0+QP0*SN0)-GEI/PI BEI=XC1*XE1*(PP0*SN0-QP0*CN0)+GER/PI PP1=1.0D0 PN1=1.0D0 QP1=0.0D0 QN1=0.0D0 R1=1.0D0 FAC=1.0D0 DO 90 K=1,KM FAC=-FAC XT=0.25D0*K*PI-INT(0.125D0*K)*2.0D0*PI CS=DCOS(XT) SS=DSIN(XT) R1=0.125D0*R1*(4.D0-(2.0D0*K-1.0D0)**2)/K/X RC=R1*CS RS=R1*SS PP1=PP1+FAC*RC PN1=PN1+RC QP1=QP1+FAC*RS QN1=QN1+RS 90 CONTINUE HER=XC2*XE2*(-PN1*CN0+QN1*SN0) HEI=XC2*XE2*(PN1*SN0+QN1*CN0) DER=XC1*XE1*(PP1*CP0+QP1*SP0)-HEI/PI DEI=XC1*XE1*(PP1*SP0-QP1*CP0)+HER/PI ENDIF RETURN END C ********************************** SUBROUTINE CHGUBI(A,B,X,HU,ID) C C ====================================================== C Purpose: Compute confluent hypergeometric function C U(a,b,x) with integer b ( b = ±1,±2,... ) C Input : a --- Parameter C b --- Parameter C x --- Argument C Output: HU --- U(a,b,x) C ID --- Estimated number of significant digits C Routines called: C (1) GAMMA2 for computing gamma function Г(x) C (2) PSI_SPEC for computing psi function C ====================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) ID=-100 EL=0.5772156649015329D0 N=ABS(B-1) RN1=1.0D0 RN=1.0D0 DO 10 J=1,N RN=RN*J IF (J.EQ.N-1) RN1=RN 10 CONTINUE CALL PSI_SPEC(A,PS) CALL GAMMA2(A,GA) IF (B.GT.0.0) THEN A0=A A1=A-N A2=A1 CALL GAMMA2(A1,GA1) UA=(-1)**(N-1)/(RN*GA1) UB=RN1/GA*X**(-N) ELSE A0=A+N A1=A0 A2=A CALL GAMMA2(A1,GA1) UA=(-1)**(N-1)/(RN*GA)*X**N UB=RN1/GA1 ENDIF HM1=1.0D0 R=1.0D0 HMAX=0.0D0 HMIN=1.0D+300 H0=0D0 DO 15 K=1,150 R=R*(A0+K-1.0D0)*X/((N+K)*K) HM1=HM1+R HU1=DABS(HM1) IF (HU1.GT.HMAX) HMAX=HU1 IF (HU1.LT.HMIN) HMIN=HU1 IF (DABS(HM1-H0).LT.DABS(HM1)*1.0D-15) GO TO 20 15 H0=HM1 20 DA1=LOG10(HMAX) DA2=0.0D0 IF (HMIN.NE.0.0) DA2=LOG10(HMIN) ID=15-ABS(DA1-DA2) HM1=HM1*DLOG(X) S0=0.0D0 DO 25 M=1,N IF (B.GE.0.0) S0=S0-1.0D0/M 25 IF (B.LT.0.0) S0=S0+(1.0D0-A)/(M*(A+M-1.0D0)) HM2=PS+2.0D0*EL+S0 R=1.0D0 HMAX=0.0D0 HMIN=1.0D+300 DO 50 K=1,150 S1=0.0D0 S2=0.0D0 IF (B.GT.0.0) THEN DO 30 M=1,K 30 S1=S1-(M+2.0D0*A-2.0D0)/(M*(M+A-1.0D0)) DO 35 M=1,N 35 S2=S2+1.0D0/(K+M) ELSE DO 40 M=1,K+N 40 S1=S1+(1.0D0-A)/(M*(M+A-1.0D0)) DO 45 M=1,K 45 S2=S2+1.0D0/M ENDIF HW=2.0D0*EL+PS+S1-S2 R=R*(A0+K-1.0D0)*X/((N+K)*K) HM2=HM2+R*HW HU2=DABS(HM2) IF (HU2.GT.HMAX) HMAX=HU2 IF (HU2.LT.HMIN) HMIN=HU2 IF (DABS((HM2-H0)/HM2).LT.1.0D-15) GO TO 55 50 H0=HM2 55 DB1=LOG10(HMAX) DB2=0.0D0 IF (HMIN.NE.0.0) DB2=LOG10(HMIN) ID1=15-ABS(DB1-DB2) IF (ID1.LT.ID) ID=ID1 HM3=1.0D0 IF (N.EQ.0) HM3=0.0D0 R=1.0D0 DO 60 K=1,N-1 R=R*(A2+K-1.0D0)/((K-N)*K)*X 60 HM3=HM3+R SA=UA*(HM1+HM2) SB=UB*HM3 HU=SA+SB ID2=0.0D0 IF (SA.NE.0.0) ID1=INT(LOG10(ABS(SA))) IF (HU.NE.0.0) ID2=INT(LOG10(ABS(HU))) IF (SA*SB.LT.0.0) ID=ID-ABS(ID1-ID2) RETURN END C ********************************** SUBROUTINE CYZO(NT,KF,KC,ZO,ZV) C C =========================================================== C Purpose : Compute the complex zeros of Y0(z), Y1(z) and C Y1'(z), and their associated values at the zeros C using the modified Newton's iteration method C Input: NT --- Total number of zeros/roots C KF --- Function choice code C KF=0 for Y0(z) & Y1(z0) C KF=1 for Y1(z) & Y0(z1) C KF=2 for Y1'(z) & Y1(z1') C KC --- Choice code C KC=0 for complex roots C KC=1 for real roots C Output: ZO(L) --- L-th zero of Y0(z) or Y1(z) or Y1'(z) C ZV(L) --- Value of Y0'(z) or Y1'(z) or Y1(z) C at the L-th zero C Routine called: CY01 for computing Y0(z) and Y1(z), and C their derivatives C =========================================================== IMPLICIT DOUBLE PRECISION (H,O-Y) IMPLICIT COMPLEX*16 (C,Z) DIMENSION ZO(NT),ZV(NT) X=0.0D0 Y=0.0D0 H=0.0D0 IF (KC.EQ.0) THEN X=-2.4D0 Y=0.54D0 H=3.14D0 ELSE IF (KC.EQ.1) THEN X=0.89 Y=0.0 H=-3.14 ENDIF IF (KF.EQ.1) X=-0.503 IF (KF.EQ.2) X=0.577 ZERO = DCMPLX(X, Y) Z=ZERO W=0.0D0 DO 35 NR=1,NT IF (NR.NE.1) Z=ZO(NR-1)-H IT=0 15 IT=IT+1 CALL CY01(KF,Z,ZF,ZD) ZP=(1.0D0,0.0D0) DO 20 I=1,NR-1 20 ZP=ZP*(Z-ZO(I)) ZFD=ZF/ZP ZQ=(0.0D0,0.0D0) DO 30 I=1,NR-1 ZW=(1.0D0,0.0D0) DO 25 J=1,NR-1 IF (J.EQ.I) GO TO 25 ZW=ZW*(Z-ZO(J)) 25 CONTINUE ZQ=ZQ+ZW 30 CONTINUE ZGD=(ZD-ZQ*ZFD)/ZP Z=Z-ZFD/ZGD W0=W W=ABS(Z) IF (IT.LE.50.AND.DABS((W-W0)/W).GT.1.0D-12) GO TO 15 ZO(NR)=Z 35 CONTINUE DO 40 I=1,NT Z=ZO(I) IF (KF.EQ.0.OR.KF.EQ.2) THEN CALL CY01(1,Z,ZF,ZD) ZV(I)=ZF ELSE IF (KF.EQ.1) THEN CALL CY01(0,Z,ZF,ZD) ZV(I)=ZF ENDIF 40 CONTINUE RETURN END C ********************************** SUBROUTINE KLVNB(X,BER,BEI,GER,GEI,DER,DEI,HER,HEI) C C ====================================================== C Purpose: Compute Kelvin functions ber x, bei x, ker x C and kei x, and their derivatives ( x > 0 ) C Input : x --- Argument of Kelvin functions C Output: BER --- ber x C BEI --- bei x C GER --- ker x C GEI --- kei x C DER --- ber'x C DEI --- bei'x C HER --- ker'x C HEI --- kei'x C ================================================ C IMPLICIT DOUBLE PRECISION (A-H,O-Z) PI=3.141592653589793D0 IF (X.EQ.0.0D0) THEN BER=1.0D0 BEI=0.0D0 GER=1.0D+300 GEI=-.25D0*PI DER=0.0D0 DEI=0.0D0 HER=-1.0D+300 HEI=0.0D0 ELSE IF (X.LT.8.0D0) THEN T=X/8.0D0 T2=T*T U=T2*T2 BER=((((((-.901D-5*U+.122552D-2)*U-.08349609D0)*U & +2.64191397D0)*U-32.36345652D0)*U & +113.77777774D0)*U-64.0D0)*U+1.0D0 BEI=T*T*((((((.11346D-3*U-.01103667D0)*U & +.52185615D0)*U-10.56765779D0)*U & +72.81777742D0)*U-113.77777774D0)*U+16.0D0) GER=((((((-.2458D-4*U+.309699D-2)*U-.19636347D0) & *U+5.65539121D0)*U-60.60977451D0)*U+ & 171.36272133D0)*U-59.05819744D0)*U-.57721566D0 GER=GER-DLOG(.5D0*X)*BER+.25D0*PI*BEI GEI=T2*((((((.29532D-3*U-.02695875D0)*U & +1.17509064D0)*U-21.30060904D0)*U & +124.2356965D0)*U-142.91827687D0)*U & +6.76454936D0) GEI=GEI-DLOG(.5D0*X)*BEI-.25D0*PI*BER DER=X*T2*((((((-.394D-5*U+.45957D-3)*U & -.02609253D0)*U+.66047849D0)*U-6.0681481D0)*U & +14.22222222D0)*U-4.0D0) DEI=X*((((((.4609D-4*U-.379386D-2)*U+.14677204D0) & *U-2.31167514D0)*U+11.37777772D0)*U & -10.66666666D0)*U+.5D0) HER=X*T2*((((((-.1075D-4*U+.116137D-2)*U & -.06136358D0)*U+1.4138478D0)*U-11.36433272D0) & *U+21.42034017D0)*U-3.69113734D0) HER=HER-DLOG(.5D0*X)*DER-BER/X+.25D0*PI*DEI HEI=X*((((((.11997D-3*U-.926707D-2)*U & +.33049424D0)*U-4.65950823D0)*U+19.41182758D0) & *U-13.39858846D0)*U+.21139217D0) HEI=HEI-DLOG(.5D0*X)*DEI-BEI/X-.25D0*PI*DER ELSE T=8.0D0/X TNR=0.0D0 TNI=0.0D0 DO 10 L=1,2 V=(-1)**L*T TPR=((((.6D-6*V-.34D-5)*V-.252D-4)*V-.906D-4) & *V*V+.0110486D0)*V TPI=((((.19D-5*V+.51D-5)*V*V-.901D-4)*V & -.9765D-3)*V-.0110485D0)*V-.3926991D0 IF (L.EQ.1) THEN TNR=TPR TNI=TPI ENDIF 10 CONTINUE YD=X/DSQRT(2.0D0) YE1=EXP(YD+TPR) YE2=EXP(-YD+TNR) YC1=1.0D0/DSQRT(2.0D0*PI*X) YC2=DSQRT(PI/(2.0D0*X)) CSP=DCOS(YD+TPI) SSP=DSIN(YD+TPI) CSN=DCOS(-YD+TNI) SSN=DSIN(-YD+TNI) GER=YC2*YE2*CSN GEI=YC2*YE2*SSN FXR=YC1*YE1*CSP FXI=YC1*YE1*SSP BER=FXR-GEI/PI BEI=FXI+GER/PI PNR=0.0D0 PNI=0.0D0 DO 15 L=1,2 V=(-1)**L*T PPR=(((((.16D-5*V+.117D-4)*V+.346D-4)*V+.5D-6) & *V-.13813D-2)*V-.0625001D0)*V+.7071068D0 PPI=(((((-.32D-5*V-.24D-5)*V+.338D-4)*V+ & .2452D-3)*V+.13811D-2)*V-.1D-6)*V+.7071068D0 IF (L.EQ.1) THEN PNR=PPR PNI=PPI ENDIF 15 CONTINUE HER=GEI*PNI-GER*PNR HEI=-(GEI*PNR+GER*PNI) DER=FXR*PPR-FXI*PPI-HEI/PI DEI=FXI*PPR+FXR*PPI+HER/PI ENDIF RETURN END C ********************************** SUBROUTINE RMN2SO(M,N,C,X,CV,DF,KD,R2F,R2D) C C ============================================================= C Purpose: Compute oblate radial functions of the second kind C with a small argument, Rmn(-ic,ix) & Rmn'(-ic,ix) C Routines called: C (1) SCKB for computing the expansion coefficients c2k C (2) KMN for computing the joining factors C (3) QSTAR for computing the factor defined in (15.7.3) C (4) CBK for computing the the expansion coefficient C defined in (15.7.6) C (5) GMN for computing the function defined in (15.7.4) C (6) RMN1 for computing the radial function of the first C kind C ============================================================= C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION BK(200),CK(200),DF(200),DN(200) IF (DABS(DF(1)).LE.1.0D-280) THEN R2F=1.0D+300 R2D=1.0D+300 RETURN ENDIF EPS=1.0D-14 PI=3.141592653589793D0 NM=25+INT((N-M)/2+C) IP=1 IF (N-M.EQ.2*INT((N-M)/2)) IP=0 CALL SCKB(M,N,C,DF,CK) CALL KMN(M,N,C,CV,KD,DF,DN,CK1,CK2) CALL QSTAR(M,N,C,CK,CK1,QS,QT) CALL CBK(M,N,C,CV,QT,CK,BK) IF (X.EQ.0.0D0) THEN SUM=0.0D0 SW=0.0D0 DO 10 J=1,NM SUM=SUM+CK(J) IF (DABS(SUM-SW).LT.DABS(SUM)*EPS) GO TO 15 10 SW=SUM 15 IF (IP.EQ.0) THEN R1F=SUM/CK1 R2F=-0.5D0*PI*QS*R1F R2D=QS*R1F+BK(1) ELSE IF (IP.EQ.1) THEN R1D=SUM/CK1 R2F=BK(1) R2D=-0.5D0*PI*QS*R1D ENDIF RETURN ELSE CALL GMN(M,N,C,X,BK,GF,GD) CALL RMN1(M,N,C,X,DF,KD,R1F,R1D) H0=DATAN(X)-0.5D0*PI R2F=QS*R1F*H0+GF R2D=QS*(R1D*H0+R1F/(1.0D0+X*X))+GD ENDIF RETURN END C ********************************** SUBROUTINE BJNDD(N,X,BJ,DJ,FJ) C C ===================================================== C Purpose: Compute Bessel functions Jn(x) and their C first and second derivatives ( n= 0,1,… ) C Input: x --- Argument of Jn(x) ( x ≥ 0 ) C n --- Order of Jn(x) C Output: BJ(n+1) --- Jn(x) C DJ(n+1) --- Jn'(x) C FJ(n+1) --- Jn"(x) C ===================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION BJ(101),DJ(101),FJ(101) DO 10 NT=1,900 MT=INT(0.5*LOG10(6.28*NT)-NT*LOG10(1.36*DABS(X)/NT)) IF (MT.GT.20) GO TO 15 10 CONTINUE 15 M=NT BS=0.0D0 F=0.0D0 F0=0.0D0 F1=1.0D-35 DO 20 K=M,0,-1 F=2.0D0*(K+1.0D0)*F1/X-F0 IF (K.LE.N) BJ(K+1)=F IF (K.EQ.2*INT(K/2)) BS=BS+2.0D0*F F0=F1 20 F1=F DO 25 K=0,N 25 BJ(K+1)=BJ(K+1)/(BS-F) DJ(1)=-BJ(2) FJ(1)=-1.0D0*BJ(1)-DJ(1)/X DO 30 K=1,N DJ(K+1)=BJ(K)-K*BJ(K+1)/X 30 FJ(K+1)=(K*K/(X*X)-1.0D0)*BJ(K+1)-DJ(K+1)/X RETURN END C ********************************** SUBROUTINE SPHJ(N,X,NM,SJ,DJ) C MODIFIED to ALLOW N=0 CASE (ALSO IN SPHY) C C ======================================================= C Purpose: Compute spherical Bessel functions jn(x) and C their derivatives C Input : x --- Argument of jn(x) C n --- Order of jn(x) ( n = 0,1,… ) C Output: SJ(n) --- jn(x) C DJ(n) --- jn'(x) C NM --- Highest order computed C Routines called: C MSTA1 and MSTA2 for computing the starting C point for backward recurrence C ======================================================= C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION SJ(0:N),DJ(0:N) NM=N IF (DABS(X).LT.1.0D-100) THEN DO 10 K=0,N SJ(K)=0.0D0 10 DJ(K)=0.0D0 SJ(0)=1.0D0 IF (N.GT.0) THEN DJ(1)=.3333333333333333D0 ENDIF RETURN ENDIF SJ(0)=DSIN(X)/X DJ(0)=(DCOS(X)-DSIN(X)/X)/X IF (N.LT.1) THEN RETURN ENDIF SJ(1)=(SJ(0)-DCOS(X))/X IF (N.GE.2) THEN SA=SJ(0) SB=SJ(1) M=MSTA1(X,200) IF (M.LT.N) THEN NM=M ELSE M=MSTA2(X,N,15) ENDIF F=0.0D0 F0=0.0D0 F1=1.0D0-100 DO 15 K=M,0,-1 F=(2.0D0*K+3.0D0)*F1/X-F0 IF (K.LE.NM) SJ(K)=F F0=F1 15 F1=F CS=0.0D0 IF (DABS(SA).GT.DABS(SB)) CS=SA/F IF (DABS(SA).LE.DABS(SB)) CS=SB/F0 DO 20 K=0,NM 20 SJ(K)=CS*SJ(K) ENDIF DO 25 K=1,NM 25 DJ(K)=SJ(K-1)-(K+1.0D0)*SJ(K)/X RETURN END C ********************************** SUBROUTINE OTHPL(KF,N,X,PL,DPL) C C ========================================================== C Purpose: Compute orthogonal polynomials: Tn(x) or Un(x), C or Ln(x) or Hn(x), and their derivatives C Input : KF --- Function code C KF=1 for Chebyshev polynomial Tn(x) C KF=2 for Chebyshev polynomial Un(x) C KF=3 for Laguerre polynomial Ln(x) C KF=4 for Hermite polynomial Hn(x) C n --- Order of orthogonal polynomials C x --- Argument of orthogonal polynomials C Output: PL(n) --- Tn(x) or Un(x) or Ln(x) or Hn(x) C DPL(n)--- Tn'(x) or Un'(x) or Ln'(x) or Hn'(x) C ========================================================= C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION PL(0:N),DPL(0:N) A=2.0D0 B=0.0D0 C=1.0D0 Y0=1.0D0 Y1=2.0D0*X DY0=0.0D0 DY1=2.0D0 PL(0)=1.0D0 PL(1)=2.0D0*X DPL(0)=0.0D0 DPL(1)=2.0D0 IF (KF.EQ.1) THEN Y1=X DY1=1.0D0 PL(1)=X DPL(1)=1.0D0 ELSE IF (KF.EQ.3) THEN Y1=1.0D0-X DY1=-1.0D0 PL(1)=1.0D0-X DPL(1)=-1.0D0 ENDIF DO 10 K=2,N IF (KF.EQ.3) THEN A=-1.0D0/K B=2.0D0+A C=1.0D0+A ELSE IF (KF.EQ.4) THEN C=2.0D0*(K-1.0D0) ENDIF YN=(A*X+B)*Y1-C*Y0 DYN=A*Y1+(A*X+B)*DY1-C*DY0 PL(K)=YN DPL(K)=DYN Y0=Y1 Y1=YN DY0=DY1 10 DY1=DYN RETURN END C ********************************** SUBROUTINE KLVNZO(NT,KD,ZO) C C ==================================================== C Purpose: Compute the zeros of Kelvin functions C Input : NT --- Total number of zeros C KD --- Function code C KD=1 to 8 for ber x, bei x, ker x, kei x, C ber'x, bei'x, ker'x and kei'x, C respectively. C Output: ZO(M) --- the M-th zero of Kelvin function C for code KD C Routine called: C KLVNA for computing Kelvin functions and C their derivatives C ==================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION ZO(NT),RT0(8) RT0(1)=2.84891 RT0(2)=5.02622 RT0(3)=1.71854 RT0(4)=3.91467 RT0(5)=6.03871 RT0(6)=3.77268 RT0(7)=2.66584 RT0(8)=4.93181 RT=RT0(KD) DO 15 M=1,NT 10 CALL KLVNA(RT,BER,BEI,GER,GEI,DER,DEI,HER,HEI) IF (KD.EQ.1) THEN RT=RT-BER/DER ELSE IF (KD.EQ.2) THEN RT=RT-BEI/DEI ELSE IF (KD.EQ.3) THEN RT=RT-GER/HER ELSE IF (KD.EQ.4) THEN RT=RT-GEI/HEI ELSE IF (KD.EQ.5) THEN DDR=-BEI-DER/RT RT=RT-DER/DDR ELSE IF (KD.EQ.6) THEN DDI=BER-DEI/RT RT=RT-DEI/DDI ELSE IF (KD.EQ.7) THEN GDR=-GEI-HER/RT RT=RT-HER/GDR ELSE GDI=GER-HEI/RT RT=RT-HEI/GDI ENDIF IF (DABS(RT-RT0(KD)).GT.5.0D-10) THEN RT0(KD)=RT GO TO 10 ENDIF ZO(M)=RT 15 RT=RT+4.44D0 RETURN END C ********************************** SUBROUTINE RSWFO(M,N,C,X,CV,KF,R1F,R1D,R2F,R2D) C C ========================================================== C Purpose: Compute oblate radial functions of the first C and second kinds, and their derivatives C Input : m --- Mode parameter, m = 0,1,2,... C n --- Mode parameter, n = m,m+1,m+2,... C c --- Spheroidal parameter C x --- Argument (x ≥ 0) C cv --- Characteristic value C KF --- Function code C KF=1 for the first kind C KF=2 for the second kind C KF=3 for both the first and second kinds C Output: R1F --- Radial function of the first kind C R1D --- Derivative of the radial function of C the first kind C R2F --- Radial function of the second kind C R2D --- Derivative of the radial function of C the second kind C Routines called: C (1) SDMN for computing expansion coefficients dk C (2) RMN1 for computing prolate or oblate radial C function of the first kind C (3) RMN2L for computing prolate or oblate radial C function of the second kind for a large argument C (4) RMN2SO for computing oblate radial functions of C the second kind for a small argument C ========================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION DF(200) KD=-1 CALL SDMN(M,N,C,CV,KD,DF) IF (KF.NE.2) THEN CALL RMN1(M,N,C,X,DF,KD,R1F,R1D) ENDIF IF (KF.GT.1) THEN ID=10 IF (X.GT.1.0D-8) THEN CALL RMN2L(M,N,C,X,DF,KD,R2F,R2D,ID) ENDIF IF (ID.GT.-1) THEN CALL RMN2SO(M,N,C,X,CV,DF,KD,R2F,R2D) ENDIF ENDIF RETURN END C ********************************** SUBROUTINE CH12N(N,Z,NM,CHF1,CHD1,CHF2,CHD2) C C ==================================================== C Purpose: Compute Hankel functions of the first and C second kinds and their derivatives for a C complex argument C Input : z --- Complex argument C n --- Order of Hn(1)(z) and Hn(2)(z) C Output: CHF1(n) --- Hn(1)(z) C CHD1(n) --- Hn(1)'(z) C CHF2(n) --- Hn(2)(z) C CHD2(n) --- Hn(2)'(z) C NM --- Highest order computed C Routines called: C (1) CJYNB for computing Jn(z) and Yn(z) C (2) CIKNB for computing In(z) and Kn(z) C ==================================================== C IMPLICIT DOUBLE PRECISION (A,B,D-H,O-Y) IMPLICIT COMPLEX*16 (C,Z) DIMENSION CBJ(0:250),CDJ(0:250),CBY(0:250),CDY(0:250), & CBI(0:250),CDI(0:250),CBK(0:250),CDK(0:250) DIMENSION CHF1(0:N),CHD1(0:N),CHF2(0:N),CHD2(0:N) CI=(0.0D0,1.0D0) PI=3.141592653589793D0 IF (DIMAG(Z).LT.0.0D0) THEN CALL CJYNB(N,Z,NM,CBJ,CDJ,CBY,CDY) DO 10 K=0,NM CHF1(K)=CBJ(K)+CI*CBY(K) 10 CHD1(K)=CDJ(K)+CI*CDY(K) ZI=CI*Z CALL CIKNB(N,ZI,NM,CBI,CDI,CBK,CDK) CFAC=-2.0D0/(PI*CI) DO 15 K=0,NM CHF2(K)=CFAC*CBK(K) CHD2(K)=CFAC*CI*CDK(K) 15 CFAC=CFAC*CI ELSE IF (DIMAG(Z).GT.0.0D0) THEN ZI=-CI*Z CALL CIKNB(N,ZI,NM,CBI,CDI,CBK,CDK) CF1=-CI CFAC=2.0D0/(PI*CI) DO 20 K=0,NM CHF1(K)=CFAC*CBK(K) CHD1(K)=-CFAC*CI*CDK(K) 20 CFAC=CFAC*CF1 CALL CJYNB(N,Z,NM,CBJ,CDJ,CBY,CDY) DO 25 K=0,NM CHF2(K)=CBJ(K)-CI*CBY(K) 25 CHD2(K)=CDJ(K)-CI*CDY(K) ELSE CALL CJYNB(N,Z,NM,CBJ,CDJ,CBY,CDY) DO 30 K=0,NM CHF1(K)=CBJ(K)+CI*CBY(K) CHD1(K)=CDJ(K)+CI*CDY(K) CHF2(K)=CBJ(K)-CI*CBY(K) 30 CHD2(K)=CDJ(K)-CI*CDY(K) ENDIF RETURN END C ********************************** SUBROUTINE JYZO(N,NT,RJ0,RJ1,RY0,RY1) C C ====================================================== C Purpose: Compute the zeros of Bessel functions Jn(x), C Yn(x), and their derivatives C Input : n --- Order of Bessel functions (n >= 0) C NT --- Number of zeros (roots) C Output: RJ0(L) --- L-th zero of Jn(x), L=1,2,...,NT C RJ1(L) --- L-th zero of Jn'(x), L=1,2,...,NT C RY0(L) --- L-th zero of Yn(x), L=1,2,...,NT C RY1(L) --- L-th zero of Yn'(x), L=1,2,...,NT C Routine called: JYNDD for computing Jn(x), Yn(x), and C their first and second derivatives C ====================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION RJ0(NT),RJ1(NT),RY0(NT),RY1(NT) PI=3.141592653589793D0 C -- Newton method for j_{N,L} C 1) initial guess for j_{N,1} IF (N.LE.20) THEN X=2.82141+1.15859*N ELSE C Abr & Stg (9.5.14) X=N+1.85576*N**0.33333+1.03315/N**0.33333 ENDIF L=0 C 2) iterate XGUESS=X 10 X0=X CALL JYNDD(N,X,BJN,DJN,FJN,BYN,DYN,FYN) X=X-BJN/DJN IF (X-X0.LT.-1) X=X0-1 IF (X-X0.GT.1) X=X0+1 IF (DABS(X-X0).GT.1.0D-11) GO TO 10 C 3) initial guess for j_{N,L+1} IF (L.GE.1)THEN IF (X.LE.RJ0(L)+0.5) THEN X=XGUESS+PI XGUESS=X GO TO 10 ENDIF END IF L=L+1 RJ0(L)=X C XXX: should have a better initial guess for large N ~> 100 here X=X+PI+MAX((0.0972d0+0.0679*N-0.000354*N**2)/L, 0d0) IF (L.LT.NT) GO TO 10 C -- Newton method for j_{N,L}' IF (N.LE.20) THEN X=0.961587+1.07703*N ELSE X=N+0.80861*N**0.33333+0.07249/N**0.33333 ENDIF IF (N.EQ.0) X=3.8317 L=0 XGUESS=X 15 X0=X CALL JYNDD(N,X,BJN,DJN,FJN,BYN,DYN,FYN) X=X-DJN/FJN IF (X-X0.LT.-1) X=X0-1 IF (X-X0.GT.1) X=X0+1 IF (DABS(X-X0).GT.1.0D-11) GO TO 15 IF (L.GE.1)THEN IF (X.LE.RJ1(L)+0.5) THEN X=XGUESS+PI XGUESS=X GO TO 15 ENDIF END IF L=L+1 RJ1(L)=X C XXX: should have a better initial guess for large N ~> 100 here X=X+PI+MAX((0.4955d0+0.0915*N-0.000435*N**2)/L, 0d0) IF (L.LT.NT) GO TO 15 C -- Newton method for y_{N,L} IF (N.LE.20) THEN X=1.19477+1.08933*N ELSE X=N+0.93158*N**0.33333+0.26035/N**0.33333 ENDIF L=0 XGUESS=X 20 X0=X CALL JYNDD(N,X,BJN,DJN,FJN,BYN,DYN,FYN) X=X-BYN/DYN IF (X-X0.LT.-1) X=X0-1 IF (X-X0.GT.1) X=X0+1 IF (DABS(X-X0).GT.1.0D-11) GO TO 20 IF (L.GE.1)THEN IF (X.LE.RY0(L)+0.5) THEN X=XGUESS+PI XGUESS=X GO TO 20 END IF END IF L=L+1 RY0(L)=X C XXX: should have a better initial guess for large N ~> 100 here X=X+PI+MAX((0.312d0+0.0852*N-0.000403*N**2)/L,0d0) IF (L.LT.NT) GO TO 20 C -- Newton method for y_{N,L}' IF (N.LE.20) THEN X=2.67257+1.16099*N ELSE X=N+1.8211*N**0.33333+0.94001/N**0.33333 ENDIF L=0 XGUESS=X 25 X0=X CALL JYNDD(N,X,BJN,DJN,FJN,BYN,DYN,FYN) X=X-DYN/FYN IF (DABS(X-X0).GT.1.0D-11) GO TO 25 IF (L.GE.1) THEN IF (X.LE.RY1(L)+0.5) THEN X=XGUESS+PI XGUESS=X GO TO 25 END IF END IF L=L+1 RY1(L)=X C XXX: should have a better initial guess for large N ~> 100 here X=X+PI+MAX((0.197d0+0.0643*N-0.000286*N**2)/L,0d0) IF (L.LT.NT) GO TO 25 RETURN END C ********************************** SUBROUTINE IKV(V,X,VM,BI,DI,BK,DK) C C ======================================================= C Purpose: Compute modified Bessel functions Iv(x) and C Kv(x), and their derivatives C Input : x --- Argument ( x ≥ 0 ) C v --- Order of Iv(x) and Kv(x) C ( v = n+v0, n = 0,1,2,..., 0 ≤ v0 < 1 ) C Output: BI(n) --- In+v0(x) C DI(n) --- In+v0'(x) C BK(n) --- Kn+v0(x) C DK(n) --- Kn+v0'(x) C VM --- Highest order computed C Routines called: C (1) GAMMA2 for computing the gamma function C (2) MSTA1 and MSTA2 to compute the starting C point for backward recurrence C ======================================================= C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION BI(0:*),DI(0:*),BK(0:*),DK(0:*) PI=3.141592653589793D0 X2=X*X N=INT(V) V0=V-N IF (N.EQ.0) N=1 IF (X.LT.1.0D-100) THEN DO 10 K=0,N BI(K)=0.0D0 DI(K)=0.0D0 BK(K)=-1.0D+300 10 DK(K)=1.0D+300 IF (V.EQ.0.0) THEN BI(0)=1.0D0 DI(1)=0.5D0 ENDIF VM=V RETURN ENDIF PIV=PI*V0 VT=4.0D0*V0*V0 IF (V0.EQ.0.0D0) THEN A1=1.0D0 ELSE V0P=1.0D0+V0 CALL GAMMA2(V0P,GAP) A1=(0.5D0*X)**V0/GAP ENDIF K0=14 IF (X.GE.35.0) K0=10 IF (X.GE.50.0) K0=8 IF (X.LE.18.0) THEN BI0=1.0D0 R=1.0D0 DO 15 K=1,30 R=0.25D0*R*X2/(K*(K+V0)) BI0=BI0+R IF (DABS(R/BI0).LT.1.0D-15) GO TO 20 15 CONTINUE 20 BI0=BI0*A1 ELSE CA=EXP(X)/DSQRT(2.0D0*PI*X) SUM=1.0D0 R=1.0D0 DO 25 K=1,K0 R=-0.125D0*R*(VT-(2.0D0*K-1.0D0)**2.0)/(K*X) 25 SUM=SUM+R BI0=CA*SUM ENDIF M=MSTA1(X,200) IF (M.LT.N) THEN N=M ELSE M=MSTA2(X,N,15) ENDIF F=0.0D0 F2=0.0D0 F1=1.0D-100 WW=0.0D0 DO 30 K=M,0,-1 F=2.0D0*(V0+K+1.0D0)/X*F1+F2 IF (K.LE.N) BI(K)=F F2=F1 30 F1=F CS=BI0/F DO 35 K=0,N 35 BI(K)=CS*BI(K) DI(0)=V0/X*BI(0)+BI(1) DO 40 K=1,N 40 DI(K)=-(K+V0)/X*BI(K)+BI(K-1) IF (X.LE.9.0D0) THEN IF (V0.EQ.0.0D0) THEN CT=-DLOG(0.5D0*X)-0.5772156649015329D0 CS=0.0D0 W0=0.0D0 R=1.0D0 DO 45 K=1,50 W0=W0+1.0D0/K R=0.25D0*R/(K*K)*X2 CS=CS+R*(W0+CT) WA=DABS(CS) IF (DABS((WA-WW)/WA).LT.1.0D-15) GO TO 50 45 WW=WA 50 BK0=CT+CS ELSE V0N=1.0D0-V0 CALL GAMMA2(V0N,GAN) A2=1.0D0/(GAN*(0.5D0*X)**V0) A1=(0.5D0*X)**V0/GAP SUM=A2-A1 R1=1.0D0 R2=1.0D0 DO 55 K=1,120 R1=0.25D0*R1*X2/(K*(K-V0)) R2=0.25D0*R2*X2/(K*(K+V0)) SUM=SUM+A2*R1-A1*R2 WA=DABS(SUM) IF (DABS((WA-WW)/WA).LT.1.0D-15) GO TO 60 55 WW=WA 60 BK0=0.5D0*PI*SUM/DSIN(PIV) ENDIF ELSE CB=EXP(-X)*DSQRT(0.5D0*PI/X) SUM=1.0D0 R=1.0D0 DO 65 K=1,K0 R=0.125D0*R*(VT-(2.0*K-1.0)**2.0)/(K*X) 65 SUM=SUM+R BK0=CB*SUM ENDIF BK1=(1.0D0/X-BI(1)*BK0)/BI(0) BK(0)=BK0 BK(1)=BK1 DO 70 K=2,N BK2=2.0D0*(V0+K-1.0D0)/X*BK1+BK0 BK(K)=BK2 BK0=BK1 70 BK1=BK2 DK(0)=V0/X*BK(0)-BK(1) DO 80 K=1,N 80 DK(K)=-(K+V0)/X*BK(K)-BK(K-1) VM=N+V0 RETURN END C ********************************** SUBROUTINE SDMN(M,N,C,CV,KD,DF) C C ===================================================== C Purpose: Compute the expansion coefficients of the C prolate and oblate spheroidal functions, dk C Input : m --- Mode parameter C n --- Mode parameter C c --- Spheroidal parameter C cv --- Characteristic value C KD --- Function code C KD=1 for prolate; KD=-1 for oblate C Output: DF(k) --- Expansion coefficients dk; C DF(1), DF(2), ... correspond to C d0, d2, ... for even n-m and d1, C d3, ... for odd n-m C ===================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION A(200),D(200),G(200),DF(200) NM=25+INT(0.5*(N-M)+C) IF (C.LT.1.0D-10) THEN DO 5 I=1,NM 5 DF(I)=0D0 DF((N-M)/2+1)=1.0D0 RETURN ENDIF CS=C*C*KD IP=1 K=0 IF (N-M.EQ.2*INT((N-M)/2)) IP=0 DO 10 I=1,NM+2 IF (IP.EQ.0) K=2*(I-1) IF (IP.EQ.1) K=2*I-1 DK0=M+K DK1=M+K+1 DK2=2*(M+K) D2K=2*M+K A(I)=(D2K+2.0)*(D2K+1.0)/((DK2+3.0)*(DK2+5.0))*CS D(I)=DK0*DK1+(2.0*DK0*DK1-2.0*M*M-1.0)/((DK2-1.0) & *(DK2+3.0))*CS G(I)=K*(K-1.0)/((DK2-3.0)*(DK2-1.0))*CS 10 CONTINUE FS=1.0D0 F1=0.0D0 F0=1.0D-100 KB=0 DF(NM+1)=0.0D0 FL=0.0D0 DO 30 K=NM,1,-1 F=-((D(K+1)-CV)*F0+A(K+1)*F1)/G(K+1) IF (DABS(F).GT.DABS(DF(K+1))) THEN DF(K)=F F1=F0 F0=F IF (DABS(F).GT.1.0D+100) THEN DO 12 K1=K,NM 12 DF(K1)=DF(K1)*1.0D-100 F1=F1*1.0D-100 F0=F0*1.0D-100 ENDIF ELSE KB=K FL=DF(K+1) F1=1.0D-100 F2=-(D(1)-CV)/A(1)*F1 DF(1)=F1 IF (KB.EQ.1) THEN FS=F2 ELSE IF (KB.EQ.2) THEN DF(2)=F2 FS=-((D(2)-CV)*F2+G(2)*F1)/A(2) ELSE DF(2)=F2 DO 20 J=3,KB+1 F=-((D(J-1)-CV)*F2+G(J-1)*F1)/A(J-1) IF (J.LE.KB) DF(J)=F IF (DABS(F).GT.1.0D+100) THEN DO 15 K1=1,J 15 DF(K1)=DF(K1)*1.0D-100 F=F*1.0D-100 F2=F2*1.0D-100 ENDIF F1=F2 20 F2=F FS=F ENDIF GO TO 35 ENDIF 30 CONTINUE 35 SU1=0.0D0 R1=1.0D0 DO 40 J=M+IP+1,2*(M+IP) 40 R1=R1*J SU1=DF(1)*R1 DO 45 K=2,KB R1=-R1*(K+M+IP-1.5D0)/(K-1.0D0) 45 SU1=SU1+R1*DF(K) SU2=0.0D0 SW=0.0D0 DO 50 K=KB+1,NM IF (K.NE.1) R1=-R1*(K+M+IP-1.5D0)/(K-1.0D0) SU2=SU2+R1*DF(K) IF (DABS(SW-SU2).LT.DABS(SU2)*1.0D-14) GOTO 55 50 SW=SU2 55 R3=1.0D0 DO 60 J=1,(M+N+IP)/2 60 R3=R3*(J+0.5D0*(N+M+IP)) R4=1.0D0 DO 65 J=1,(N-M-IP)/2 65 R4=-4.0D0*R4*J S0=R3/(FL*(SU1/FS)+SU2)/R4 DO 70 K=1,KB 70 DF(K)=FL/FS*S0*DF(K) DO 75 K=KB+1,NM 75 DF(K)=S0*DF(K) RETURN END C ********************************** SUBROUTINE AJYIK(X,VJ1,VJ2,VY1,VY2,VI1,VI2,VK1,VK2) C C ======================================================= C Purpose: Compute Bessel functions Jv(x) and Yv(x), C and modified Bessel functions Iv(x) and C Kv(x), and their derivatives with v=1/3,2/3 C Input : x --- Argument of Jv(x),Yv(x),Iv(x) and C Kv(x) ( x ≥ 0 ) C Output: VJ1 --- J1/3(x) C VJ2 --- J2/3(x) C VY1 --- Y1/3(x) C VY2 --- Y2/3(x) C VI1 --- I1/3(x) C VI2 --- I2/3(x) C VK1 --- K1/3(x) C VK2 --- K2/3(x) C ======================================================= C IMPLICIT DOUBLE PRECISION (A-H,O-Z) IF (X.EQ.0.0D0) THEN VJ1=0.0D0 VJ2=0.0D0 VY1=-1.0D+300 VY2=1.0D+300 VI1=0.0D0 VI2=0.0D0 VK1=-1.0D+300 VK2=-1.0D+300 RETURN ENDIF PI=3.141592653589793D0 RP2=.63661977236758D0 GP1=.892979511569249D0 GP2=.902745292950934D0 GN1=1.3541179394264D0 GN2=2.678938534707747D0 VV0=0.444444444444444D0 UU0=1.1547005383793D0 X2=X*X K0=12 IF (X.GE.35.0) K0=10 IF (X.GE.50.0) K0=8 IF (X.LE.12.0) THEN DO 25 L=1,2 VL=L/3.0D0 VJL=1.0D0 R=1.0D0 DO 15 K=1,40 R=-0.25D0*R*X2/(K*(K+VL)) VJL=VJL+R IF (DABS(R).LT.1.0D-15) GO TO 20 15 CONTINUE 20 A0=(0.5D0*X)**VL IF (L.EQ.1) VJ1=A0/GP1*VJL IF (L.EQ.2) VJ2=A0/GP2*VJL 25 CONTINUE ELSE DO 40 L=1,2 VV=VV0*L*L PX=1.0D0 RP=1.0D0 DO 30 K=1,K0 RP=-0.78125D-2*RP*(VV-(4.0*K-3.0)**2.0)*(VV- & (4.0*K-1.0)**2.0)/(K*(2.0*K-1.0)*X2) 30 PX=PX+RP QX=1.0D0 RQ=1.0D0 DO 35 K=1,K0 RQ=-0.78125D-2*RQ*(VV-(4.0*K-1.0)**2.0)*(VV- & (4.0*K+1.0)**2.0)/(K*(2.0*K+1.0)*X2) 35 QX=QX+RQ QX=0.125D0*(VV-1.0)*QX/X XK=X-(0.5D0*L/3.0D0+0.25D0)*PI A0=DSQRT(RP2/X) CK=DCOS(XK) SK=DSIN(XK) IF (L.EQ.1) THEN VJ1=A0*(PX*CK-QX*SK) VY1=A0*(PX*SK+QX*CK) ELSE IF (L.EQ.2) THEN VJ2=A0*(PX*CK-QX*SK) VY2=A0*(PX*SK+QX*CK) ENDIF 40 CONTINUE ENDIF IF (X.LE.12.0D0) THEN UJ1=0.0D0 UJ2=0.0D0 DO 55 L=1,2 VL=L/3.0D0 VJL=1.0D0 R=1.0D0 DO 45 K=1,40 R=-0.25D0*R*X2/(K*(K-VL)) VJL=VJL+R IF (DABS(R).LT.1.0D-15) GO TO 50 45 CONTINUE 50 B0=(2.0D0/X)**VL IF (L.EQ.1) UJ1=B0*VJL/GN1 IF (L.EQ.2) UJ2=B0*VJL/GN2 55 CONTINUE PV1=PI/3.0D0 PV2=PI/1.5D0 VY1=UU0*(VJ1*DCOS(PV1)-UJ1) VY2=UU0*(VJ2*DCOS(PV2)-UJ2) ENDIF IF (X.LE.18.0) THEN DO 70 L=1,2 VL=L/3.0D0 VIL=1.0D0 R=1.0D0 DO 60 K=1,40 R=0.25D0*R*X2/(K*(K+VL)) VIL=VIL+R IF (DABS(R).LT.1.0D-15) GO TO 65 60 CONTINUE 65 A0=(0.5D0*X)**VL IF (L.EQ.1) VI1=A0/GP1*VIL IF (L.EQ.2) VI2=A0/GP2*VIL 70 CONTINUE ELSE C0=EXP(X)/DSQRT(2.0D0*PI*X) DO 80 L=1,2 VV=VV0*L*L VSL=1.0D0 R=1.0D0 DO 75 K=1,K0 R=-0.125D0*R*(VV-(2.0D0*K-1.0D0)**2.0)/(K*X) 75 VSL=VSL+R IF (L.EQ.1) VI1=C0*VSL IF (L.EQ.2) VI2=C0*VSL 80 CONTINUE ENDIF IF (X.LE.9.0D0) THEN GN=0.0D0 DO 95 L=1,2 VL=L/3.0D0 IF (L.EQ.1) GN=GN1 IF (L.EQ.2) GN=GN2 A0=(2.0D0/X)**VL/GN SUM=1.0D0 R=1.0D0 DO 85 K=1,60 R=0.25D0*R*X2/(K*(K-VL)) SUM=SUM+R IF (DABS(R).LT.1.0D-15) GO TO 90 85 CONTINUE 90 IF (L.EQ.1) VK1=0.5D0*UU0*PI*(SUM*A0-VI1) IF (L.EQ.2) VK2=0.5D0*UU0*PI*(SUM*A0-VI2) 95 CONTINUE ELSE C0=EXP(-X)*DSQRT(0.5D0*PI/X) DO 105 L=1,2 VV=VV0*L*L SUM=1.0D0 R=1.0D0 DO 100 K=1,K0 R=0.125D0*R*(VV-(2.0*K-1.0)**2.0)/(K*X) 100 SUM=SUM+R IF (L.EQ.1) VK1=C0*SUM IF (L.EQ.2) VK2=C0*SUM 105 CONTINUE ENDIF RETURN END C ********************************** SUBROUTINE CIKVB(V,Z,VM,CBI,CDI,CBK,CDK) C C =========================================================== C Purpose: Compute the modified Bessel functions Iv(z), Kv(z) C and their derivatives for an arbitrary order and C complex argument C Input : z --- Complex argument z C v --- Real order of Iv(z) and Kv(z) C ( v =n+v0, n = 0,1,2,..., 0 ≤ v0 < 1 ) C Output: CBI(n) --- In+v0(z) C CDI(n) --- In+v0'(z) C CBK(n) --- Kn+v0(z) C CDK(n) --- Kn+v0'(z) C VM --- Highest order computed C Routines called: C (1) GAMMA2 for computing the gamma function C (2) MSTA1 and MSTA2 for computing the starting C point for backward recurrence C =========================================================== C IMPLICIT DOUBLE PRECISION (A,D-H,O-Y) IMPLICIT COMPLEX*16 (C,Z) DIMENSION CBI(0:*),CDI(0:*),CBK(0:*),CDK(0:*) Z1=Z Z2=Z*Z A0=ABS(Z) PI=3.141592653589793D0 CI=(0.0D0,1.0D0) N=INT(V) V0=V-N PIV=PI*V0 VT=4.0D0*V0*V0 IF (N.EQ.0) N=1 IF (A0.LT.1.0D-100) THEN DO 10 K=0,N CBI(K)=0.0D0 CDI(K)=0.0D0 CBK(K)=-1.0D+300 10 CDK(K)=1.0D+300 IF (V0.EQ.0.0) THEN CBI(0)=(1.0D0,0.0D0) CDI(1)=(0.5D0,0.0D0) ENDIF VM=V RETURN ENDIF K0=14 IF (A0.GE.35.0) K0=10 IF (A0.GE.50.0) K0=8 IF (DBLE(Z).LT.0.0) Z1=-Z IF (A0.LT.18.0) THEN IF (V0.EQ.0.0) THEN CA1=(1.0D0,0.0D0) ELSE V0P=1.0D0+V0 CALL GAMMA2(V0P,GAP) CA1=(0.5D0*Z1)**V0/GAP ENDIF CI0=(1.0D0,0.0D0) CR=(1.0D0,0.0D0) DO 15 K=1,50 CR=0.25D0*CR*Z2/(K*(K+V0)) CI0=CI0+CR IF (ABS(CR/CI0).LT.1.0D-15) GO TO 20 15 CONTINUE 20 CBI0=CI0*CA1 ELSE CA=EXP(Z1)/SQRT(2.0D0*PI*Z1) CS=(1.0D0,0.0D0) CR=(1.0D0,0.0D0) DO 25 K=1,K0 CR=-0.125D0*CR*(VT-(2.0D0*K-1.0D0)**2.0)/(K*Z1) 25 CS=CS+CR CBI0=CA*CS ENDIF M=MSTA1(A0,200) IF (M.LT.N) THEN N=M ELSE M=MSTA2(A0,N,15) ENDIF CF2=(0.0D0,0.0D0) CF1=(1.0D-100,0.0D0) DO 30 K=M,0,-1 CF=2.0D0*(V0+K+1.0D0)/Z1*CF1+CF2 IF (K.LE.N) CBI(K)=CF CF2=CF1 30 CF1=CF CS=CBI0/CF DO 35 K=0,N 35 CBI(K)=CS*CBI(K) IF (A0.LE.9.0) THEN IF (V0.EQ.0.0) THEN CT=-LOG(0.5D0*Z1)-0.5772156649015329D0 CS=(0.0D0,0.0D0) W0=0.0D0 CR=(1.0D0,0.0D0) DO 40 K=1,50 W0=W0+1.0D0/K CR=0.25D0*CR/(K*K)*Z2 CP=CR*(W0+CT) CS=CS+CP IF (K.GE.10.AND.ABS(CP/CS).LT.1.0D-15) GO TO 45 40 CONTINUE 45 CBK0=CT+CS ELSE V0N=1.0D0-V0 CALL GAMMA2(V0N,GAN) CA2=1.0D0/(GAN*(0.5D0*Z1)**V0) CA1=(0.5D0*Z1)**V0/GAP CSU=CA2-CA1 CR1=(1.0D0,0.0D0) CR2=(1.0D0,0.0D0) DO 50 K=1,50 CR1=0.25D0*CR1*Z2/(K*(K-V0)) CR2=0.25D0*CR2*Z2/(K*(K+V0)) CP=CA2*CR1-CA1*CR2 CSU=CSU+CP IF (K.GE.10.AND.ABS(CP/CSU).LT.1.0D-15) GO TO 55 50 CONTINUE 55 CBK0=0.5D0*PI*CSU/DSIN(PIV) ENDIF ELSE CB=EXP(-Z1)*SQRT(0.5D0*PI/Z1) CS=(1.0D0,0.0D0) CR=(1.0D0,0.0D0) DO 60 K=1,K0 CR=0.125D0*CR*(VT-(2.0D0*K-1.0D0)**2.0)/(K*Z1) 60 CS=CS+CR CBK0=CB*CS ENDIF CBK(0)=CBK0 IF (DBLE(Z).LT.0.0) THEN DO 65 K=0,N CVK=EXP((K+V0)*PI*CI) IF (DIMAG(Z).LT.0.0D0) THEN CBK(K)=CVK*CBK(K)+PI*CI*CBI(K) CBI(K)=CBI(K)/CVK ELSE IF (DIMAG(Z).GT.0.0) THEN CBK(K)=CBK(K)/CVK-PI*CI*CBI(K) CBI(K)=CVK*CBI(K) ENDIF 65 CONTINUE ENDIF DO 70 K=1,N CKK=(1.0D0/Z-CBI(K)*CBK(K-1))/CBI(K-1) CBK(K)=CKK 70 CONTINUE CDI(0)=V0/Z*CBI(0)+CBI(1) CDK(0)=V0/Z*CBK(0)-CBK(1) DO 80 K=1,N CDI(K)=-(K+V0)/Z*CBI(K)+CBI(K-1) 80 CDK(K)=-(K+V0)/Z*CBK(K)-CBK(K-1) VM=N+V0 RETURN END C ********************************** SUBROUTINE CIKVA(V,Z,VM,CBI,CDI,CBK,CDK) C C ============================================================ C Purpose: Compute the modified Bessel functions Iv(z), Kv(z) C and their derivatives for an arbitrary order and C complex argument C Input : z --- Complex argument C v --- Real order of Iv(z) and Kv(z) C ( v = n+v0, n = 0,1,2,…, 0 ≤ v0 < 1 ) C Output: CBI(n) --- In+v0(z) C CDI(n) --- In+v0'(z) C CBK(n) --- Kn+v0(z) C CDK(n) --- Kn+v0'(z) C VM --- Highest order computed C Routines called: C (1) GAMMA2 for computing the gamma function C (2) MSTA1 and MSTA2 for computing the starting C point for backward recurrence C ============================================================ C IMPLICIT DOUBLE PRECISION (A,G,P,R,V,W) IMPLICIT COMPLEX*16 (C,Z) DIMENSION CBI(0:*),CDI(0:*),CBK(0:*),CDK(0:*) PI=3.141592653589793D0 CI=(0.0D0,1.0D0) A0=ABS(Z) Z1=Z Z2=Z*Z N=INT(V) V0=V-N PIV=PI*V0 VT=4.0D0*V0*V0 IF (N.EQ.0) N=1 IF (A0.LT.1.0D-100) THEN DO 10 K=0,N CBI(K)=0.0D0 CDI(K)=0.0D0 CBK(K)=-1.0D+300 10 CDK(K)=1.0D+300 IF (V0.EQ.0.0) THEN CBI(0)=(1.0D0,0.0D0) CDI(1)=(0.5D0,0.0D0) ENDIF VM=V RETURN ENDIF K0=14 IF (A0.GE.35.0) K0=10 IF (A0.GE.50.0) K0=8 IF (DBLE(Z).LT.0.0) Z1=-Z IF (A0.LT.18.0) THEN IF (V0.EQ.0.0) THEN CA1=(1.0D0,0.0D0) ELSE V0P=1.0D0+V0 CALL GAMMA2(V0P,GAP) CA1=(0.5D0*Z1)**V0/GAP ENDIF CI0=(1.0D0,0.0D0) CR=(1.0D0,0.0D0) DO 15 K=1,50 CR=0.25D0*CR*Z2/(K*(K+V0)) CI0=CI0+CR IF (ABS(CR).LT.ABS(CI0)*1.0D-15) GO TO 20 15 CONTINUE 20 CBI0=CI0*CA1 ELSE CA=EXP(Z1)/SQRT(2.0D0*PI*Z1) CS=(1.0D0,0.0D0) CR=(1.0D0,0.0D0) DO 25 K=1,K0 CR=-0.125D0*CR*(VT-(2.0D0*K-1.0D0)**2.0)/(K*Z1) 25 CS=CS+CR CBI0=CA*CS ENDIF M=MSTA1(A0,200) IF (M.LT.N) THEN N=M ELSE M=MSTA2(A0,N,15) ENDIF CF2=(0.0D0,0.0D0) CF1=(1.0D-100,0.0D0) DO 30 K=M,0,-1 CF=2.0D0*(V0+K+1.0D0)/Z1*CF1+CF2 IF (K.LE.N) CBI(K)=CF CF2=CF1 30 CF1=CF CS=CBI0/CF DO 35 K=0,N 35 CBI(K)=CS*CBI(K) IF (A0.LE.9.0) THEN IF (V0.EQ.0.0) THEN CT=-LOG(0.5D0*Z1)-0.5772156649015329D0 CS=(0.0D0,0.0D0) W0=0.0D0 CR=(1.0D0,0.0D0) DO 40 K=1,50 W0=W0+1.0D0/K CR=0.25D0*CR/(K*K)*Z2 CP=CR*(W0+CT) CS=CS+CP IF (K.GE.10.AND.ABS(CP/CS).LT.1.0D-15) GO TO 45 40 CONTINUE 45 CBK0=CT+CS ELSE V0N=1.0D0-V0 CALL GAMMA2(V0N,GAN) CA2=1.0D0/(GAN*(0.5D0*Z1)**V0) CA1=(0.5D0*Z1)**V0/GAP CSU=CA2-CA1 CR1=(1.0D0,0.0D0) CR2=(1.0D0,0.0D0) WS0=0.0D0 DO 50 K=1,50 CR1=0.25D0*CR1*Z2/(K*(K-V0)) CR2=0.25D0*CR2*Z2/(K*(K+V0)) CSU=CSU+CA2*CR1-CA1*CR2 WS=ABS(CSU) IF (K.GE.10.AND.DABS(WS-WS0)/WS.LT.1.0D-15) GO TO 55 WS0=WS 50 CONTINUE 55 CBK0=0.5D0*PI*CSU/DSIN(PIV) ENDIF ELSE CB=EXP(-Z1)*SQRT(0.5D0*PI/Z1) CS=(1.0D0,0.0D0) CR=(1.0D0,0.0D0) DO 60 K=1,K0 CR=0.125D0*CR*(VT-(2.0D0*K-1.0D0)**2.0)/(K*Z1) 60 CS=CS+CR CBK0=CB*CS ENDIF CBK1=(1.0D0/Z1-CBI(1)*CBK0)/CBI(0) CBK(0)=CBK0 CBK(1)=CBK1 CG0=CBK0 CG1=CBK1 DO 65 K=2,N CGK=2.0D0*(V0+K-1.0D0)/Z1*CG1+CG0 CBK(K)=CGK CG0=CG1 65 CG1=CGK IF (DBLE(Z).LT.0.0) THEN DO 70 K=0,N CVK=EXP((K+V0)*PI*CI) IF (DIMAG(Z).LT.0.0D0) THEN CBK(K)=CVK*CBK(K)+PI*CI*CBI(K) CBI(K)=CBI(K)/CVK ELSE IF (DIMAG(Z).GT.0.0) THEN CBK(K)=CBK(K)/CVK-PI*CI*CBI(K) CBI(K)=CVK*CBI(K) ENDIF 70 CONTINUE ENDIF CDI(0)=V0/Z*CBI(0)+CBI(1) CDK(0)=V0/Z*CBK(0)-CBK(1) DO 75 K=1,N CDI(K)=-(K+V0)/Z*CBI(K)+CBI(K-1) 75 CDK(K)=-(K+V0)/Z*CBK(K)-CBK(K-1) VM=N+V0 RETURN END C ********************************** SUBROUTINE CFC(Z,ZF,ZD) C C ========================================================= C Purpose: Compute complex Fresnel integral C(z) and C'(z) C Input : z --- Argument of C(z) C Output: ZF --- C(z) C ZD --- C'(z) C ========================================================= C IMPLICIT DOUBLE PRECISION (E,P,W) IMPLICIT COMPLEX *16 (C,S,Z,D) EPS=1.0D-14 PI=3.141592653589793D0 W0=ABS(Z) ZP=0.5D0*PI*Z*Z ZP2=ZP*ZP Z0=(0.0D0,0.0D0) IF (Z.EQ.Z0) THEN C=Z0 ELSE IF (W0.LE.2.5) THEN CR=Z C=CR WA0=0.0D0 DO 10 K=1,80 CR=-.5D0*CR*(4.0D0*K-3.0D0)/K/(2.0D0*K-1.0D0) & /(4.0D0*K+1.0D0)*ZP2 C=C+CR WA=ABS(C) IF (DABS((WA-WA0)/WA).LT.EPS.AND.K.GT.10) GO TO 30 10 WA0=WA ELSE IF (W0.GT.2.5.AND.W0.LT.4.5) THEN M=85 C=Z0 CF1=Z0 CF0=(1.0D-100,0.0D0) DO 15 K=M,0,-1 CF=(2.0D0*K+3.0D0)*CF0/ZP-CF1 IF (K.EQ.INT(K/2)*2) C=C+CF CF1=CF0 15 CF0=CF C=2.0D0/(PI*Z)*SIN(ZP)/CF*C ELSE C See comment at CFS(), use C(z) = iC(-iz) IF (DIMAG(Z).GT.-DBLE(Z).AND.DIMAG(Z).LE.DBLE(Z)) THEN C right quadrant D=DCMPLX(.5D0,0.0D0) ELSE IF (DIMAG(Z).GT.DBLE(Z).AND.DIMAG(Z).GE.-DBLE(Z)) THEN C upper quadrant D=DCMPLX(0.0D0,.5D0) ELSE IF (DIMAG(Z).LT.-DBLE(Z).AND.DIMAG(Z).GE.DBLE(Z)) THEN C left quadrant D=DCMPLX(-.5D0,0.0D0) ELSE C lower quadrant D=DCMPLX(0.0D0,-.5D0) ENDIF CR=(1.0D0,0.0D0) CF=(1.0D0,0.0D0) DO 20 K=1,20 CR=-.25D0*CR*(4.0D0*K-1.0D0)*(4.0D0*K-3.0D0)/ZP2 20 CF=CF+CR CR=1.0D0/(PI*Z*Z) CG=CR DO 25 K=1,12 CR=-.25D0*CR*(4.0D0*K+1.0D0)*(4.0D0*K-1.0D0)/ZP2 25 CG=CG+CR C=D+(CF*SIN(ZP)-CG*COS(ZP))/(PI*Z) ENDIF 30 ZF=C ZD=COS(0.5*PI*Z*Z) RETURN END C ********************************** SUBROUTINE FCS(X,C,S) C C ================================================= C Purpose: Compute Fresnel integrals C(x) and S(x) C Input : x --- Argument of C(x) and S(x) C Output: C --- C(x) C S --- S(x) C ================================================= C IMPLICIT DOUBLE PRECISION (A-H,O-Z) EPS=1.0D-15 PI=3.141592653589793D0 XA=DABS(X) PX=PI*XA T=.5D0*PX*XA T2=T*T IF (XA.EQ.0.0) THEN C=0.0D0 S=0.0D0 ELSE IF (XA.LT.2.5D0) THEN R=XA C=R DO 10 K=1,50 R=-.5D0*R*(4.0D0*K-3.0D0)/K/(2.0D0*K-1.0D0) & /(4.0D0*K+1.0D0)*T2 C=C+R IF (DABS(R).LT.DABS(C)*EPS) GO TO 15 10 CONTINUE 15 S=XA*T/3.0D0 R=S DO 20 K=1,50 R=-.5D0*R*(4.0D0*K-1.0D0)/K/(2.0D0*K+1.0D0) & /(4.0D0*K+3.0D0)*T2 S=S+R IF (DABS(R).LT.DABS(S)*EPS) GO TO 40 20 CONTINUE ELSE IF (XA.LT.4.5D0) THEN M=INT(42.0+1.75*T) SU=0.0D0 C=0.0D0 S=0.0D0 F1=0.0D0 F0=1.0D-100 DO 25 K=M,0,-1 F=(2.0D0*K+3.0D0)*F0/T-F1 IF (K.EQ.INT(K/2)*2) THEN C=C+F ELSE S=S+F ENDIF SU=SU+(2.0D0*K+1.0D0)*F*F F1=F0 25 F0=F Q=DSQRT(SU) C=C*XA/Q S=S*XA/Q ELSE R=1.0D0 F=1.0D0 DO 30 K=1,20 R=-.25D0*R*(4.0D0*K-1.0D0)*(4.0D0*K-3.0D0)/T2 30 F=F+R R=1.0D0/(PX*XA) G=R DO 35 K=1,12 R=-.25D0*R*(4.0D0*K+1.0D0)*(4.0D0*K-1.0D0)/T2 35 G=G+R T0=T-INT(T/(2.0D0*PI))*2.0D0*PI C=.5D0+(F*DSIN(T0)-G*DCOS(T0))/PX S=.5D0-(F*DCOS(T0)+G*DSIN(T0))/PX ENDIF 40 IF (X.LT.0.0D0) THEN C=-C S=-S ENDIF RETURN END C ********************************** SUBROUTINE RCTJ(N,X,NM,RJ,DJ) C C ======================================================== C Purpose: Compute Riccati-Bessel functions of the first C kind and their derivatives C Input: x --- Argument of Riccati-Bessel function C n --- Order of jn(x) ( n = 0,1,2,... ) C Output: RJ(n) --- x·jn(x) C DJ(n) --- [x·jn(x)]' C NM --- Highest order computed C Routines called: C MSTA1 and MSTA2 for computing the starting C point for backward recurrence C ======================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION RJ(0:N),DJ(0:N) NM=N IF (DABS(X).LT.1.0D-100) THEN DO 10 K=0,N RJ(K)=0.0D0 10 DJ(K)=0.0D0 DJ(0)=1.0D0 RETURN ENDIF RJ(0)=DSIN(X) RJ(1)=RJ(0)/X-DCOS(X) RJ0=RJ(0) RJ1=RJ(1) CS=0.0D0 F=0.0D0 IF (N.GE.2) THEN M=MSTA1(X,200) IF (M.LT.N) THEN NM=M ELSE M=MSTA2(X,N,15) ENDIF F0=0.0D0 F1=1.0D-100 DO 15 K=M,0,-1 F=(2.0D0*K+3.0D0)*F1/X-F0 IF (K.LE.NM) RJ(K)=F F0=F1 15 F1=F IF (DABS(RJ0).GT.DABS(RJ1)) CS=RJ0/F IF (DABS(RJ0).LE.DABS(RJ1)) CS=RJ1/F0 DO 20 K=0,NM 20 RJ(K)=CS*RJ(K) ENDIF DJ(0)=DCOS(X) DO 25 K=1,NM 25 DJ(K)=-K*RJ(K)/X+RJ(K-1) RETURN END C ********************************** SUBROUTINE HERZO(N,X,W) C C ======================================================== C Purpose : Compute the zeros of Hermite polynomial Ln(x) C in the interval [-∞,∞], and the corresponding C weighting coefficients for Gauss-Hermite C integration C Input : n --- Order of the Hermite polynomial C X(n) --- Zeros of the Hermite polynomial C W(n) --- Corresponding weighting coefficients C ======================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION X(N),W(N) HN=1.0D0/N ZL=-1.1611D0+1.46D0*N**0.5 Z=0.0D0 HF=0.0D0 HD=0.0D0 DO 40 NR=1,N/2 IF (NR.EQ.1) Z=ZL IF (NR.NE.1) Z=Z-HN*(N/2+1-NR) IT=0 10 IT=IT+1 Z0=Z F0=1.0D0 F1=2.0D0*Z DO 15 K=2,N HF=2.0D0*Z*F1-2.0D0*(K-1.0D0)*F0 HD=2.0D0*K*F1 F0=F1 15 F1=HF P=1.0D0 DO 20 I=1,NR-1 20 P=P*(Z-X(I)) FD=HF/P Q=0.0D0 DO 30 I=1,NR-1 WP=1.0D0 DO 25 J=1,NR-1 IF (J.EQ.I) GO TO 25 WP=WP*(Z-X(J)) 25 CONTINUE 30 Q=Q+WP GD=(HD-Q*FD)/P Z=Z-FD/GD IF (IT.LE.40.AND.DABS((Z-Z0)/Z).GT.1.0D-15) GO TO 10 X(NR)=Z X(N+1-NR)=-Z R=1.0D0 DO 35 K=1,N 35 R=2.0D0*R*K W(NR)=3.544907701811D0*R/(HD*HD) 40 W(N+1-NR)=W(NR) IF (N.NE.2*INT(N/2)) THEN R1=1.0D0 R2=1.0D0 DO 45 J=1,N R1=2.0D0*R1*J IF (J.GE.(N+1)/2) R2=R2*J 45 CONTINUE W(N/2+1)=0.88622692545276D0*R1/(R2*R2) X(N/2+1)=0.0D0 ENDIF RETURN END C ********************************** SUBROUTINE JY01B(X,BJ0,DJ0,BJ1,DJ1,BY0,DY0,BY1,DY1) C C ======================================================= C Purpose: Compute Bessel functions J0(x), J1(x), Y0(x), C Y1(x), and their derivatives C Input : x --- Argument of Jn(x) & Yn(x) ( x ≥ 0 ) C Output: BJ0 --- J0(x) C DJ0 --- J0'(x) C BJ1 --- J1(x) C DJ1 --- J1'(x) C BY0 --- Y0(x) C DY0 --- Y0'(x) C BY1 --- Y1(x) C DY1 --- Y1'(x) C ======================================================= C IMPLICIT DOUBLE PRECISION (A-H,O-Z) PI=3.141592653589793D0 IF (X.EQ.0.0D0) THEN BJ0=1.0D0 BJ1=0.0D0 DJ0=0.0D0 DJ1=0.5D0 BY0=-1.0D+300 BY1=-1.0D+300 DY0=1.0D+300 DY1=1.0D+300 RETURN ELSE IF (X.LE.4.0D0) THEN T=X/4.0D0 T2=T*T BJ0=((((((-.5014415D-3*T2+.76771853D-2)*T2 & -.0709253492D0)*T2+.4443584263D0)*T2 & -1.7777560599D0)*T2+3.9999973021D0) & *T2-3.9999998721D0)*T2+1.0D0 BJ1=T*(((((((-.1289769D-3*T2+.22069155D-2) & *T2-.0236616773D0)*T2+.1777582922D0)*T2 & -.8888839649D0)*T2+2.6666660544D0)*T2 & -3.9999999710D0)*T2+1.9999999998D0) BY0=(((((((-.567433D-4*T2+.859977D-3)*T2 & -.94855882D-2)*T2+.0772975809D0)*T2 & -.4261737419D0)*T2+1.4216421221D0)*T2 & -2.3498519931D0)*T2+1.0766115157D0)*T2 & +.3674669052D0 BY0=2.0D0/PI*DLOG(X/2.0D0)*BJ0+BY0 BY1=((((((((.6535773D-3*T2-.0108175626D0)*T2 & +.107657606D0)*T2-.7268945577D0)*T2 & +3.1261399273D0)*T2-7.3980241381D0)*T2 & +6.8529236342D0)*T2+.3932562018D0)*T2 & -.6366197726D0)/X BY1=2.0D0/PI*DLOG(X/2.0D0)*BJ1+BY1 ELSE T=4.0D0/X T2=T*T A0=DSQRT(2.0D0/(PI*X)) P0=((((-.9285D-5*T2+.43506D-4)*T2-.122226D-3)*T2 & +.434725D-3)*T2-.4394275D-2)*T2+.999999997D0 Q0=T*(((((.8099D-5*T2-.35614D-4)*T2+.85844D-4)*T2 & -.218024D-3)*T2+.1144106D-2)*T2-.031249995D0) TA0=X-.25D0*PI BJ0=A0*(P0*DCOS(TA0)-Q0*DSIN(TA0)) BY0=A0*(P0*DSIN(TA0)+Q0*DCOS(TA0)) P1=((((.10632D-4*T2-.50363D-4)*T2+.145575D-3)*T2 & -.559487D-3)*T2+.7323931D-2)*T2+1.000000004D0 Q1=T*(((((-.9173D-5*T2+.40658D-4)*T2-.99941D-4)*T2 & +.266891D-3)*T2-.1601836D-2)*T2+.093749994D0) TA1=X-.75D0*PI BJ1=A0*(P1*DCOS(TA1)-Q1*DSIN(TA1)) BY1=A0*(P1*DSIN(TA1)+Q1*DCOS(TA1)) ENDIF DJ0=-BJ1 DJ1=BJ0-BJ1/X DY0=-BY1 DY1=BY0-BY1/X RETURN END C ********************************** SUBROUTINE ENXB(N,X,EN) C C =============================================== C Purpose: Compute exponential integral En(x) C Input : x --- Argument of En(x) C n --- Order of En(x) (n = 0,1,2,...) C Output: EN(n) --- En(x) C =============================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION EN(0:N) IF (X.EQ.0.0) THEN EN(0)=1.0D+300 EN(1)=1.0D+300 DO 10 K=2,N 10 EN(K)=1.0D0/(K-1.0) RETURN ELSE IF (X.LE.1.0) THEN EN(0)=EXP(-X)/X S0=0.0D0 DO 40 L=1,N RP=1.0D0 DO 15 J=1,L-1 15 RP=-RP*X/J PS=-0.5772156649015328D0 DO 20 M=1,L-1 20 PS=PS+1.0D0/M ENS=RP*(-DLOG(X)+PS) S=0.0D0 DO 30 M=0,20 IF (M.EQ.L-1) GO TO 30 R=1.0D0 DO 25 J=1,M 25 R=-R*X/J S=S+R/(M-L+1.0D0) IF (DABS(S-S0).LT.DABS(S)*1.0D-15) GO TO 35 S0=S 30 CONTINUE 35 EN(L)=ENS-S 40 CONTINUE ELSE EN(0)=EXP(-X)/X M=15+INT(100.0/X) DO 50 L=1,N T0=0.0D0 DO 45 K=M,1,-1 45 T0=(L+K-1.0D0)/(1.0D0+K/(X+T0)) T=1.0D0/(X+T0) 50 EN(L)=EXP(-X)*T ENDIF END C ********************************** SUBROUTINE SPHK(N,X,NM,SK,DK) C C ===================================================== C Purpose: Compute modified spherical Bessel functions C of the second kind, kn(x) and kn'(x) C Input : x --- Argument of kn(x) ( x ≥ 0 ) C n --- Order of kn(x) ( n = 0,1,2,... ) C Output: SK(n) --- kn(x) C DK(n) --- kn'(x) C NM --- Highest order computed C ===================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION SK(0:N),DK(0:N) PI=3.141592653589793D0 NM=N IF (X.LT.1.0D-60) THEN DO 10 K=0,N SK(K)=1.0D+300 10 DK(K)=-1.0D+300 RETURN ENDIF SK(0)=0.5D0*PI/X*EXP(-X) SK(1)=SK(0)*(1.0D0+1.0D0/X) F0=SK(0) F1=SK(1) DO 15 K=2,N F=(2.0D0*K-1.0D0)*F1/X+F0 SK(K)=F IF (DABS(F).GT.1.0D+300) GO TO 20 F0=F1 15 F1=F 20 NM=K-1 DK(0)=-SK(1) DO 25 K=1,NM 25 DK(K)=-SK(K-1)-(K+1.0D0)/X*SK(K) RETURN END C ********************************** SUBROUTINE ENXA(N,X,EN) C C ============================================ C Purpose: Compute exponential integral En(x) C Input : x --- Argument of En(x) ( x ≤ 20 ) C n --- Order of En(x) C Output: EN(n) --- En(x) C Routine called: E1XB for computing E1(x) C ============================================ C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION EN(0:N) EN(0)=EXP(-X)/X CALL E1XB(X,E1) EN(1)=E1 DO 10 K=2,N EK=(EXP(-X)-X*E1)/(K-1.0D0) EN(K)=EK 10 E1=EK RETURN END C ********************************** SUBROUTINE GAIH(X,GA) C C ===================================================== C Purpose: Compute gamma function Г(x) C Input : x --- Argument of Г(x), x = n/2, n=1,2,… C Output: GA --- Г(x) C ===================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) PI=3.141592653589793D0 IF (X.EQ.INT(X).AND.X.GT.0.0) THEN GA=1.0D0 M1=INT(X-1.0) DO 10 K=2,M1 10 GA=GA*K ELSE IF (X+.5D0.EQ.INT(X+.5D0).AND.X.GT.0.0) THEN M=INT(X) GA=DSQRT(PI) DO 15 K=1,M 15 GA=0.5D0*GA*(2.0D0*K-1.0D0) ENDIF RETURN END C ********************************** SUBROUTINE PBVV(V,X,VV,VP,PVF,PVD) C C =================================================== C Purpose: Compute parabolic cylinder functions Vv(x) C and their derivatives C Input: x --- Argument of Vv(x) C v --- Order of Vv(x) C Output: VV(na) --- Vv(x) C VP(na) --- Vv'(x) C ( na = |n|, v = n+v0, |v0| < 1 C n = 0,±1,±2,… ) C PVF --- Vv(x) C PVD --- Vv'(x) C Routines called: C (1) VVSA for computing Vv(x) for small |x| C (2) VVLA for computing Vv(x) for large |x| C =================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION VV(0:*),VP(0:*) PI=3.141592653589793D0 XA=DABS(X) VH=V V=V+DSIGN(1.0D0,V) NV=INT(V) V0=V-NV NA=ABS(NV) QE=EXP(0.25D0*X*X) Q2P=DSQRT(2.0D0/PI) JA=0 IF (NA.GE.1) JA=1 F=0.0D0 IF (V.LE.0.0) THEN IF (V0.EQ.0.0) THEN IF (XA.LE.7.5) CALL VVSA(V0,X,PV0) IF (XA.GT.7.5) CALL VVLA(V0,X,PV0) F0=Q2P*QE F1=X*F0 VV(0)=PV0 VV(1)=F0 VV(2)=F1 ELSE DO 10 L=0,JA V1=V0-L IF (XA.LE.7.5) CALL VVSA(V1,X,F1) IF (XA.GT.7.5) CALL VVLA(V1,X,F1) IF (L.EQ.0) F0=F1 10 CONTINUE VV(0)=F0 VV(1)=F1 ENDIF KV=2 IF (V0.EQ.0.0) KV=3 DO 15 K=KV,NA F=X*F1+(K-V0-2.0D0)*F0 VV(K)=F F0=F1 15 F1=F ELSE IF (X.GE.0.0.AND.X.LE.7.5D0) THEN V2=V IF (V2.LT.1.0) V2=V2+1.0D0 CALL VVSA(V2,X,F1) V1=V2-1.0D0 KV=INT(V2) CALL VVSA(V1,X,F0) VV(KV)=F1 VV(KV-1)=F0 DO 20 K=KV-2,0,-1 F=X*F0-(K+V0+2.0D0)*F1 IF (K.LE.NA) VV(K)=F F1=F0 20 F0=F ELSE IF (X.GT.7.5D0) THEN CALL VVLA(V0,X,PV0) M=100+ABS(NA) VV(1)=PV0 F1=0.0D0 F0=1.0D-40 DO 25 K=M,0,-1 F=X*F0-(K+V0+2.0D0)*F1 IF (K.LE.NA) VV(K)=F F1=F0 25 F0=F S0=PV0/F DO 30 K=0,NA 30 VV(K)=S0*VV(K) ELSE IF (XA.LE.7.5D0) THEN CALL VVSA(V0,X,F0) V1=V0+1.0 CALL VVSA(V1,X,F1) ELSE CALL VVLA(V0,X,F0) V1=V0+1.0D0 CALL VVLA(V1,X,F1) ENDIF VV(0)=F0 VV(1)=F1 DO 35 K=2,NA F=(X*F1-F0)/(K+V0) VV(K)=F F0=F1 35 F1=F ENDIF ENDIF DO 40 K=0,NA-1 V1=V0+K IF (V.GE.0.0D0) THEN VP(K)=0.5D0*X*VV(K)-(V1+1.0D0)*VV(K+1) ELSE VP(K)=-0.5D0*X*VV(K)+VV(K+1) ENDIF 40 CONTINUE PVF=VV(NA-1) PVD=VP(NA-1) V=VH RETURN END C ********************************** SUBROUTINE CLQMN(MM,M,N,X,Y,CQM,CQD) C C ======================================================= C Purpose: Compute the associated Legendre functions of C the second kind, Qmn(z) and Qmn'(z), for a C complex argument C Input : x --- Real part of z C y --- Imaginary part of z C m --- Order of Qmn(z) ( m = 0,1,2,… ) C n --- Degree of Qmn(z) ( n = 0,1,2,… ) C mm --- Physical dimension of CQM and CQD C Output: CQM(m,n) --- Qmn(z) C CQD(m,n) --- Qmn'(z) C ======================================================= C IMPLICIT DOUBLE PRECISION (X,Y) IMPLICIT COMPLEX*16 (C,Z) DIMENSION CQM(0:MM,0:N),CQD(0:MM,0:N) Z = DCMPLX(X, Y) IF (DABS(X).EQ.1.0D0.AND.Y.EQ.0.0D0) THEN DO 10 I=0,M DO 10 J=0,N CQM(I,J)=(1.0D+300,0.0D0) CQD(I,J)=(1.0D+300,0.0D0) 10 CONTINUE RETURN ENDIF XC=ABS(Z) LS=0 IF (DIMAG(Z).EQ.0.0D0.OR.XC.LT.1.0D0) LS=1 IF (XC.GT.1.0D0) LS=-1 ZQ=SQRT(LS*(1.0D0-Z*Z)) ZS=LS*(1.0D0-Z*Z) CQ0=0.5D0*LOG(LS*(1.0D0+Z)/(1.0D0-Z)) IF (XC.LT.1.0001D0) THEN CQM(0,0)=CQ0 CQM(0,1)=Z*CQ0-1.0D0 CQM(1,0)=-1.0D0/ZQ CQM(1,1)=-ZQ*(CQ0+Z/(1.0D0-Z*Z)) DO 15 I=0,1 DO 15 J=2,N CQM(I,J)=((2.0D0*J-1.0D0)*Z*CQM(I,J-1) & -(J+I-1.0D0)*CQM(I,J-2))/(J-I) 15 CONTINUE DO 20 J=0,N DO 20 I=2,M CQM(I,J)=-2.0D0*(I-1.0D0)*Z/ZQ*CQM(I-1,J)-LS* & (J+I-1.0D0)*(J-I+2.0D0)*CQM(I-2,J) 20 CONTINUE ELSE IF (XC.GT.1.1) THEN KM=40+M+N ELSE KM=(40+M+N)*INT(-1.0-1.8*LOG(XC-1.0)) ENDIF CQF2=(0.0D0,0.0D0) CQF1=(1.0D0,0.0D0) DO 25 K=KM,0,-1 CQF0=((2*K+3.0D0)*Z*CQF1-(K+2.0D0)*CQF2)/(K+1.0D0) IF (K.LE.N) CQM(0,K)=CQF0 CQF2=CQF1 25 CQF1=CQF0 DO 30 K=0,N 30 CQM(0,K)=CQ0*CQM(0,K)/CQF0 CQF2=0.0D0 CQF1=1.0D0 DO 35 K=KM,0,-1 CQF0=((2*K+3.0D0)*Z*CQF1-(K+1.0D0)*CQF2)/(K+2.0D0) IF (K.LE.N) CQM(1,K)=CQF0 CQF2=CQF1 35 CQF1=CQF0 CQ10=-1.0D0/ZQ DO 40 K=0,N 40 CQM(1,K)=CQ10*CQM(1,K)/CQF0 DO 45 J=0,N CQ0=CQM(0,J) CQ1=CQM(1,J) DO 45 I=0,M-2 CQF=-2.0D0*(I+1)*Z/ZQ*CQ1+(J-I)*(J+I+1.0D0)*CQ0 CQM(I+2,J)=CQF CQ0=CQ1 CQ1=CQF 45 CONTINUE ENDIF CQD(0,0)=LS/ZS DO 50 J=1,N 50 CQD(0,J)=LS*J*(CQM(0,J-1)-Z*CQM(0,J))/ZS DO 55 J=0,N DO 55 I=1,M CQD(I,J)=LS*I*Z/ZS*CQM(I,J)+(I+J)*(J-I+1.0D0) & /ZQ*CQM(I-1,J) 55 CONTINUE RETURN END C ********************************** SUBROUTINE SEGV(M,N,C,KD,CV,EG) C C ========================================================= C Purpose: Compute the characteristic values of spheroidal C wave functions C Input : m --- Mode parameter C n --- Mode parameter C c --- Spheroidal parameter C KD --- Function code C KD=1 for Prolate; KD=-1 for Oblate C Output: CV --- Characteristic value for given m, n and c C EG(L) --- Characteristic value for mode m and n' C ( L = n' - m + 1 ) C ========================================================= C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION B(100),H(100),D(300),E(300),F(300),CV0(100), & A(300),G(300),EG(200) IF (C.LT.1.0D-10) THEN DO 5 I=1,N-M+1 5 EG(I)=(I+M)*(I+M-1.0D0) GO TO 70 ENDIF ICM=(N-M+2)/2 NM=10+INT(0.5*(N-M)+C) CS=C*C*KD K=0 DO 60 L=0,1 DO 10 I=1,NM IF (L.EQ.0) K=2*(I-1) IF (L.EQ.1) K=2*I-1 DK0=M+K DK1=M+K+1 DK2=2*(M+K) D2K=2*M+K A(I)=(D2K+2.0)*(D2K+1.0)/((DK2+3.0)*(DK2+5.0))*CS D(I)=DK0*DK1+(2.0*DK0*DK1-2.0*M*M-1.0)/((DK2-1.0) & *(DK2+3.0))*CS 10 G(I)=K*(K-1.0)/((DK2-3.0)*(DK2-1.0))*CS DO 15 K=2,NM E(K)=DSQRT(A(K-1)*G(K)) 15 F(K)=E(K)*E(K) F(1)=0.0D0 E(1)=0.0D0 XA=D(NM)+DABS(E(NM)) XB=D(NM)-DABS(E(NM)) NM1=NM-1 DO 20 I=1,NM1 T=DABS(E(I))+DABS(E(I+1)) T1=D(I)+T IF (XA.LT.T1) XA=T1 T1=D(I)-T IF (T1.LT.XB) XB=T1 20 CONTINUE DO 25 I=1,ICM B(I)=XA 25 H(I)=XB DO 55 K=1,ICM DO 30 K1=K,ICM IF (B(K1).LT.B(K)) THEN B(K)=B(K1) GO TO 35 ENDIF 30 CONTINUE 35 IF (K.NE.1) THEN IF(H(K).LT.H(K-1)) H(K)=H(K-1) ENDIF 40 X1=(B(K)+H(K))/2.0D0 CV0(K)=X1 IF (DABS((B(K)-H(K))/X1).LT.1.0D-14) GO TO 50 J=0 S=1.0D0 DO 45 I=1,NM IF (S.EQ.0.0D0) S=S+1.0D-30 T=F(I)/S S=D(I)-T-X1 IF (S.LT.0.0D0) J=J+1 45 CONTINUE IF (J.LT.K) THEN H(K)=X1 ELSE B(K)=X1 IF (J.GE.ICM) THEN B(ICM)=X1 ELSE IF (H(J+1).LT.X1) H(J+1)=X1 IF (X1.LT.B(J)) B(J)=X1 ENDIF ENDIF GO TO 40 50 CV0(K)=X1 IF (L.EQ.0) EG(2*K-1)=CV0(K) IF (L.EQ.1) EG(2*K)=CV0(K) 55 CONTINUE 60 CONTINUE 70 CV=EG(N-M+1) RETURN END C ********************************** SUBROUTINE CIKNB(N,Z,NM,CBI,CDI,CBK,CDK) C C ============================================================ C Purpose: Compute modified Bessel functions In(z) and Kn(z), C and their derivatives for a complex argument C Input: z --- Complex argument C n --- Order of In(z) and Kn(z) C Output: CBI(n) --- In(z) C CDI(n) --- In'(z) C CBK(n) --- Kn(z) C CDK(n) --- Kn'(z) C NM --- Highest order computed C Routones called: C MSTA1 and MSTA2 to compute the starting point for C backward recurrence C =========================================================== C IMPLICIT DOUBLE PRECISION (A,B,D-H,O-Y) IMPLICIT COMPLEX*16 (C,Z) DIMENSION CBI(0:N),CDI(0:N),CBK(0:N),CDK(0:N) PI=3.141592653589793D0 EL=0.57721566490153D0 A0=ABS(Z) NM=N IF (A0.LT.1.0D-100) THEN DO 10 K=0,N CBI(K)=(0.0D0,0.0D0) CBK(K)=(1.0D+300,0.0D0) CDI(K)=(0.0D0,0.0D0) 10 CDK(K)=-(1.0D+300,0.0D0) CBI(0)=(1.0D0,0.0D0) CDI(1)=(0.5D0,0.0D0) RETURN ENDIF Z1=Z CI=(0.0D0,1.0D0) IF (DBLE(Z).LT.0.0) Z1=-Z IF (N.EQ.0) NM=1 M=MSTA1(A0,200) IF (M.LT.NM) THEN NM=M ELSE M=MSTA2(A0,NM,15) ENDIF CBS=0.0D0 CSK0=0.0D0 CF0=0.0D0 CF1=1.0D-100 DO 15 K=M,0,-1 CF=2.0D0*(K+1.0D0)*CF1/Z1+CF0 IF (K.LE.NM) CBI(K)=CF IF (K.NE.0.AND.K.EQ.2*INT(K/2)) CSK0=CSK0+4.0D0*CF/K CBS=CBS+2.0D0*CF CF0=CF1 15 CF1=CF CS0=EXP(Z1)/(CBS-CF) DO 20 K=0,NM 20 CBI(K)=CS0*CBI(K) IF (A0.LE.9.0) THEN CBK(0)=-(LOG(0.5D0*Z1)+EL)*CBI(0)+CS0*CSK0 CBK(1)=(1.0D0/Z1-CBI(1)*CBK(0))/CBI(0) ELSE CA0=SQRT(PI/(2.0D0*Z1))*EXP(-Z1) K0=16 IF (A0.GE.25.0) K0=10 IF (A0.GE.80.0) K0=8 IF (A0.GE.200.0) K0=6 DO 30 L=0,1 CBKL=1.0D0 VT=4.0D0*L CR=(1.0D0,0.0D0) DO 25 K=1,K0 CR=0.125D0*CR*(VT-(2.0*K-1.0)**2)/(K*Z1) 25 CBKL=CBKL+CR CBK(L)=CA0*CBKL 30 CONTINUE ENDIF CG0=CBK(0) CG1=CBK(1) DO 35 K=2,NM CG=2.0D0*(K-1.0D0)/Z1*CG1+CG0 CBK(K)=CG CG0=CG1 35 CG1=CG IF (DBLE(Z).LT.0.0) THEN FAC=1.0D0 DO 45 K=0,NM IF (DIMAG(Z).LT.0.0) THEN CBK(K)=FAC*CBK(K)+CI*PI*CBI(K) ELSE CBK(K)=FAC*CBK(K)-CI*PI*CBI(K) ENDIF CBI(K)=FAC*CBI(K) FAC=-FAC 45 CONTINUE ENDIF CDI(0)=CBI(1) CDK(0)=-CBK(1) DO 50 K=1,NM CDI(K)=CBI(K-1)-K/Z*CBI(K) 50 CDK(K)=-CBK(K-1)-K/Z*CBK(K) RETURN END C ********************************** SUBROUTINE CIKNA(N,Z,NM,CBI,CDI,CBK,CDK) C C ======================================================== C Purpose: Compute modified Bessel functions In(z), Kn(x) C and their derivatives for a complex argument C Input : z --- Complex argument of In(z) and Kn(z) C n --- Order of In(z) and Kn(z) C Output: CBI(n) --- In(z) C CDI(n) --- In'(z) C CBK(n) --- Kn(z) C CDK(n) --- Kn'(z) C NM --- Highest order computed C Routines called: C (1) CIK01 to compute I0(z), I1(z) K0(z) & K1(z) C (2) MSTA1 and MSTA2 to compute the starting C point for backward recurrence C ======================================================== C IMPLICIT DOUBLE PRECISION (A,B,P,W,X,Y) IMPLICIT COMPLEX*16 (C,Z) DIMENSION CBI(0:N),CDI(0:N),CBK(0:N),CDK(0:N) A0=ABS(Z) NM=N IF (A0.LT.1.0D-100) THEN DO 10 K=0,N CBI(K)=(0.0D0,0.0D0) CDI(K)=(0.0D0,0.0D0) CBK(K)=-(1.0D+300,0.0D0) 10 CDK(K)=(1.0D+300,0.0D0) CBI(0)=(1.0D0,0.0D0) CDI(1)=(0.5D0,0.0D0) RETURN ENDIF CALL CIK01(Z,CBI0,CDI0,CBI1,CDI1,CBK0,CDK0,CBK1,CDK1) CBI(0)=CBI0 CBI(1)=CBI1 CBK(0)=CBK0 CBK(1)=CBK1 CDI(0)=CDI0 CDI(1)=CDI1 CDK(0)=CDK0 CDK(1)=CDK1 IF (N.LE.1) RETURN M=MSTA1(A0,200) IF (M.LT.N) THEN NM=M ELSE M=MSTA2(A0,N,15) ENDIF CF2=(0.0D0,0.0D0) CF1=(1.0D-100,0.0D0) DO 45 K=M,0,-1 CF=2.0D0*(K+1.0D0)/Z*CF1+CF2 IF (K.LE.NM) CBI(K)=CF CF2=CF1 45 CF1=CF CS=CBI0/CF DO 50 K=0,NM 50 CBI(K)=CS*CBI(K) DO 60 K=2,NM IF (ABS(CBI(K-1)).GT.ABS(CBI(K-2))) THEN CKK=(1.0D0/Z-CBI(K)*CBK(K-1))/CBI(K-1) ELSE CKK=(CBI(K)*CBK(K-2)+2.0D0*(K-1.0D0)/(Z*Z))/CBI(K-2) ENDIF 60 CBK(K)=CKK DO 70 K=2,NM CDI(K)=CBI(K-1)-K/Z*CBI(K) 70 CDK(K)=-CBK(K-1)-K/Z*CBK(K) RETURN END C ********************************** SUBROUTINE MTU12(KF,KC,M,Q,X,F1R,D1R,F2R,D2R) C C ============================================================== C Purpose: Compute modified Mathieu functions of the first and C second kinds, Mcm(1)(2)(x,q) and Msm(1)(2)(x,q), C and their derivatives C Input: KF --- Function code C KF=1 for computing Mcm(x,q) C KF=2 for computing Msm(x,q) C KC --- Function Code C KC=1 for computing the first kind C KC=2 for computing the second kind C or Msm(2)(x,q) and Msm(2)'(x,q) C KC=3 for computing both the first C and second kinds C m --- Order of Mathieu functions C q --- Parameter of Mathieu functions ( q ≥ 0 ) C x --- Argument of Mathieu functions C Output: F1R --- Mcm(1)(x,q) or Msm(1)(x,q) C D1R --- Derivative of Mcm(1)(x,q) or Msm(1)(x,q) C F2R --- Mcm(2)(x,q) or Msm(2)(x,q) C D2R --- Derivative of Mcm(2)(x,q) or Msm(2)(x,q) C Routines called: C (1) CVA2 for computing the characteristic values C (2) FCOEF for computing expansion coefficients C (3) JYNB for computing Jn(x), Yn(x) and their C derivatives C ============================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION FG(251),BJ1(0:251),DJ1(0:251),BJ2(0:251),DJ2(0:251), & BY1(0:251),DY1(0:251),BY2(0:251),DY2(0:251) EPS=1.0D-14 IF (KF.EQ.1.AND.M.EQ.2*INT(M/2)) KD=1 IF (KF.EQ.1.AND.M.NE.2*INT(M/2)) KD=2 IF (KF.EQ.2.AND.M.NE.2*INT(M/2)) KD=3 IF (KF.EQ.2.AND.M.EQ.2*INT(M/2)) KD=4 CALL CVA2(KD,M,Q,A) IF (Q.LE.1.0D0) THEN QM=7.5+56.1*SQRT(Q)-134.7*Q+90.7*SQRT(Q)*Q ELSE QM=17.0+3.1*SQRT(Q)-.126*Q+.0037*SQRT(Q)*Q ENDIF KM=INT(QM+0.5*M) IF(KM.GE.251) THEN F1R=DNAN() D1R=DNAN() F2R=DNAN() D2R=DNAN() RETURN END IF CALL FCOEF(KD,M,Q,A,FG) IC=INT(M/2)+1 IF (KD.EQ.4) IC=M/2 C1=EXP(-X) C2=EXP(X) U1=DSQRT(Q)*C1 U2=DSQRT(Q)*C2 CALL JYNB(KM+1,U1,NM,BJ1,DJ1,BY1,DY1) CALL JYNB(KM+1,U2,NM,BJ2,DJ2,BY2,DY2) W1=0.0D0 W2=0.0D0 IF (KC.EQ.2) GO TO 50 F1R=0.0D0 DO 30 K=1,KM IF (KD.EQ.1) THEN F1R=F1R+(-1)**(IC+K)*FG(K)*BJ1(K-1)*BJ2(K-1) ELSE IF (KD.EQ.2.OR.KD.EQ.3) THEN F1R=F1R+(-1)**(IC+K)*FG(K)*(BJ1(K-1)*BJ2(K) & +(-1)**KD*BJ1(K)*BJ2(K-1)) ELSE F1R=F1R+(-1)**(IC+K)*FG(K)*(BJ1(K-1)*BJ2(K+1) & -BJ1(K+1)*BJ2(K-1)) ENDIF IF (K.GE.5.AND.DABS(F1R-W1).LT.DABS(F1R)*EPS) GO TO 35 30 W1=F1R 35 F1R=F1R/FG(1) D1R=0.0D0 DO 40 K=1,KM IF (KD.EQ.1) THEN D1R=D1R+(-1)**(IC+K)*FG(K)*(C2*BJ1(K-1)*DJ2(K-1) & -C1*DJ1(K-1)*BJ2(K-1)) ELSE IF (KD.EQ.2.OR.KD.EQ.3) THEN D1R=D1R+(-1)**(IC+K)*FG(K)*(C2*(BJ1(K-1)*DJ2(K) & +(-1)**KD*BJ1(K)*DJ2(K-1))-C1*(DJ1(K-1)*BJ2(K) & +(-1)**KD*DJ1(K)*BJ2(K-1))) ELSE D1R=D1R+(-1)**(IC+K)*FG(K)*(C2*(BJ1(K-1)*DJ2(K+1) & -BJ1(K+1)*DJ2(K-1))-C1*(DJ1(K-1)*BJ2(K+1) & -DJ1(K+1)*BJ2(K-1))) ENDIF IF (K.GE.5.AND.DABS(D1R-W2).LT.DABS(D1R)*EPS) GO TO 45 40 W2=D1R 45 D1R=D1R*DSQRT(Q)/FG(1) IF (KC.EQ.1) RETURN 50 F2R=0.0D0 DO 55 K=1,KM IF (KD.EQ.1) THEN F2R=F2R+(-1)**(IC+K)*FG(K)*BJ1(K-1)*BY2(K-1) ELSE IF (KD.EQ.2.OR.KD.EQ.3) THEN F2R=F2R+(-1)**(IC+K)*FG(K)*(BJ1(K-1)*BY2(K) & +(-1)**KD*BJ1(K)*BY2(K-1)) ELSE F2R=F2R+(-1)**(IC+K)*FG(K)*(BJ1(K-1)*BY2(K+1) & -BJ1(K+1)*BY2(K-1)) ENDIF IF (K.GE.5.AND.DABS(F2R-W1).LT.DABS(F2R)*EPS) GO TO 60 55 W1=F2R 60 F2R=F2R/FG(1) D2R=0.0D0 DO 65 K=1,KM IF (KD.EQ.1) THEN D2R=D2R+(-1)**(IC+K)*FG(K)*(C2*BJ1(K-1)*DY2(K-1) & -C1*DJ1(K-1)*BY2(K-1)) ELSE IF (KD.EQ.2.OR.KD.EQ.3) THEN D2R=D2R+(-1)**(IC+K)*FG(K)*(C2*(BJ1(K-1)*DY2(K) & +(-1)**KD*BJ1(K)*DY2(K-1))-C1*(DJ1(K-1)*BY2(K) & +(-1)**KD*DJ1(K)*BY2(K-1))) ELSE D2R=D2R+(-1)**(IC+K)*FG(K)*(C2*(BJ1(K-1)*DY2(K+1) & -BJ1(K+1)*DY2(K-1))-C1*(DJ1(K-1)*BY2(K+1) & -DJ1(K+1)*BY2(K-1))) ENDIF IF (K.GE.5.AND.DABS(D2R-W2).LT.DABS(D2R)*EPS) GO TO 70 65 W2=D2R 70 D2R=D2R*DSQRT(Q)/FG(1) RETURN END C ********************************** SUBROUTINE CIK01(Z,CBI0,CDI0,CBI1,CDI1,CBK0,CDK0,CBK1,CDK1) C C ========================================================== C Purpose: Compute modified Bessel functions I0(z), I1(z), C K0(z), K1(z), and their derivatives for a C complex argument C Input : z --- Complex argument C Output: CBI0 --- I0(z) C CDI0 --- I0'(z) C CBI1 --- I1(z) C CDI1 --- I1'(z) C CBK0 --- K0(z) C CDK0 --- K0'(z) C CBK1 --- K1(z) C CDK1 --- K1'(z) C ========================================================== C IMPLICIT DOUBLE PRECISION (A,B,D-H,O-Y) IMPLICIT COMPLEX*16 (C,Z) DIMENSION A(12),B(12),A1(10) PI=3.141592653589793D0 CI=(0.0D0,1.0D0) A0=ABS(Z) Z2=Z*Z Z1=Z IF (A0.EQ.0.0D0) THEN CBI0=(1.0D0,0.0D0) CBI1=(0.0D0,0.0D0) CDI0=(0.0D0,0.0D0) CDI1=(0.5D0,0.0D0) CBK0=(1.0D+300,0.0D0) CBK1=(1.0D+300,0.0D0) CDK0=-(1.0D+300,0.0D0) CDK1=-(1.0D+300,0.0D0) RETURN ENDIF IF (DBLE(Z).LT.0.0) Z1=-Z IF (A0.LE.18.0) THEN CBI0=(1.0D0,0.0D0) CR=(1.0D0,0.0D0) DO 10 K=1,50 CR=0.25D0*CR*Z2/(K*K) CBI0=CBI0+CR IF (ABS(CR/CBI0).LT.1.0D-15) GO TO 15 10 CONTINUE 15 CBI1=(1.0D0,0.0D0) CR=(1.0D0,0.0D0) DO 20 K=1,50 CR=0.25D0*CR*Z2/(K*(K+1)) CBI1=CBI1+CR IF (ABS(CR/CBI1).LT.1.0D-15) GO TO 25 20 CONTINUE 25 CBI1=0.5D0*Z1*CBI1 ELSE DATA A/0.125D0,7.03125D-2, & 7.32421875D-2,1.1215209960938D-1, & 2.2710800170898D-1,5.7250142097473D-1, & 1.7277275025845D0,6.0740420012735D0, & 2.4380529699556D01,1.1001714026925D02, & 5.5133589612202D02,3.0380905109224D03/ DATA B/-0.375D0,-1.171875D-1, & -1.025390625D-1,-1.4419555664063D-1, & -2.7757644653320D-1,-6.7659258842468D-1, & -1.9935317337513D0,-6.8839142681099D0, & -2.7248827311269D01,-1.2159789187654D02, & -6.0384407670507D02,-3.3022722944809D03/ K0=12 IF (A0.GE.35.0) K0=9 IF (A0.GE.50.0) K0=7 CA=EXP(Z1)/SQRT(2.0D0*PI*Z1) CBI0=(1.0D0,0.0D0) ZR=1.0D0/Z1 DO 30 K=1,K0 30 CBI0=CBI0+A(K)*ZR**K CBI0=CA*CBI0 CBI1=(1.0D0,0.0D0) DO 35 K=1,K0 35 CBI1=CBI1+B(K)*ZR**K CBI1=CA*CBI1 ENDIF IF (A0.LE.9.0) THEN CS=(0.0D0,0.0D0) CT=-LOG(0.5D0*Z1)-0.5772156649015329D0 W0=0.0D0 CR=(1.0D0,0.0D0) DO 40 K=1,50 W0=W0+1.0D0/K CR=0.25D0*CR/(K*K)*Z2 CS=CS+CR*(W0+CT) IF (ABS((CS-CW)/CS).LT.1.0D-15) GO TO 45 40 CW=CS 45 CBK0=CT+CS ELSE DATA A1/0.125D0,0.2109375D0, & 1.0986328125D0,1.1775970458984D01, & 2.1461706161499D02,5.9511522710323D03, & 2.3347645606175D05,1.2312234987631D07, & 8.401390346421D08,7.2031420482627D10/ CB=0.5D0/Z1 ZR2=1.0D0/Z2 CBK0=(1.0D0,0.0D0) DO 50 K=1,10 50 CBK0=CBK0+A1(K)*ZR2**K CBK0=CB*CBK0/CBI0 ENDIF CBK1=(1.0D0/Z1-CBI1*CBK0)/CBI0 IF (DBLE(Z).LT.0.0) THEN IF (DIMAG(Z).LT.0.0) CBK0=CBK0+CI*PI*CBI0 IF (DIMAG(Z).GT.0.0) CBK0=CBK0-CI*PI*CBI0 IF (DIMAG(Z).LT.0.0) CBK1=-CBK1+CI*PI*CBI1 IF (DIMAG(Z).GT.0.0) CBK1=-CBK1-CI*PI*CBI1 CBI1=-CBI1 ENDIF CDI0=CBI1 CDI1=CBI0-1.0D0/Z*CBI1 CDK0=-CBK1 CDK1=-CBK0-1.0D0/Z*CBK1 RETURN END C ********************************** SUBROUTINE CPSI(X,Y,PSR,PSI) C C ============================================= C Purpose: Compute the psi function for a C complex argument C Input : x --- Real part of z C y --- Imaginary part of z C Output: PSR --- Real part of psi(z) C PSI --- Imaginary part of psi(z) C ============================================= C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION A(8) DATA A/-.8333333333333D-01,.83333333333333333D-02, & -.39682539682539683D-02,.41666666666666667D-02, & -.75757575757575758D-02,.21092796092796093D-01, & -.83333333333333333D-01,.4432598039215686D0/ PI=3.141592653589793D0 IF (Y.EQ.0.0D0.AND.X.EQ.INT(X).AND.X.LE.0.0D0) THEN PSR=1.0D+300 PSI=0.0D0 ELSE X1=X Y1=Y IF (X.LT.0.0D0) THEN X=-X Y=-Y ENDIF X0=X N=0 IF (X.LT.8.0D0) THEN N=8-INT(X) X0=X+N ENDIF TH=0.0D0 IF (X0.EQ.0.0D0.AND.Y.NE.0.0D0) TH=0.5D0*PI IF (X0.NE.0.0D0) TH=DATAN(Y/X0) Z2=X0*X0+Y*Y Z0=DSQRT(Z2) PSR=DLOG(Z0)-0.5D0*X0/Z2 PSI=TH+0.5D0*Y/Z2 DO 10 K=1,8 PSR=PSR+A(K)*Z2**(-K)*DCOS(2.0D0*K*TH) 10 PSI=PSI-A(K)*Z2**(-K)*DSIN(2.0D0*K*TH) IF (X.LT.8.0D0) THEN RR=0.0D0 RI=0.0D0 DO 20 K=1,N RR=RR+(X0-K)/((X0-K)**2.0D0+Y*Y) 20 RI=RI+Y/((X0-K)**2.0D0+Y*Y) PSR=PSR-RR PSI=PSI+RI ENDIF IF (X1.LT.0.0D0) THEN TN=DTAN(PI*X) TM=DTANH(PI*Y) CT2=TN*TN+TM*TM PSR=PSR+X/(X*X+Y*Y)+PI*(TN-TN*TM*TM)/CT2 PSI=PSI-Y/(X*X+Y*Y)-PI*TM*(1.0D0+TN*TN)/CT2 X=X1 Y=Y1 ENDIF ENDIF RETURN END C ********************************** SUBROUTINE SPHY(N,X,NM,SY,DY) C C ====================================================== C Purpose: Compute spherical Bessel functions yn(x) and C their derivatives C Input : x --- Argument of yn(x) ( x ≥ 0 ) C n --- Order of yn(x) ( n = 0,1,… ) C Output: SY(n) --- yn(x) C DY(n) --- yn'(x) C NM --- Highest order computed C ====================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION SY(0:N),DY(0:N) NM=N IF (X.LT.1.0D-60) THEN DO 10 K=0,N SY(K)=-1.0D+300 10 DY(K)=1.0D+300 RETURN ENDIF SY(0)=-DCOS(X)/X F0=SY(0) DY(0)=(DSIN(X)+DCOS(X)/X)/X IF (N.LT.1) THEN RETURN ENDIF SY(1)=(SY(0)-DSIN(X))/X F1=SY(1) DO 15 K=2,N F=(2.0D0*K-1.0D0)*F1/X-F0 SY(K)=F IF (DABS(F).GE.1.0D+300) GO TO 20 F0=F1 15 F1=F 20 NM=K-1 DO 25 K=1,NM 25 DY(K)=SY(K-1)-(K+1.0D0)*SY(K)/X RETURN END C ********************************** SUBROUTINE JELP(U,HK,ESN,ECN,EDN,EPH) C C ======================================================== C Purpose: Compute Jacobian elliptic functions sn u, cn u C and dn u C Input : u --- Argument of Jacobian elliptic functions C Hk --- Modulus k ( 0 ≤ k ≤ 1 ) C Output : ESN --- sn u C ECN --- cn u C EDN --- dn u C EPH --- phi ( in degrees ) C ======================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION R(40) PI=3.14159265358979D0 A0=1.0D0 B0=DSQRT(1.0D0-HK*HK) DO 10 N=1,40 A=(A0+B0)/2.0D0 B=DSQRT(A0*B0) C=(A0-B0)/2.0D0 R(N)=C/A IF (C.LT.1.0D-7) GO TO 15 A0=A 10 B0=B 15 DN=2.0D0**N*A*U D=0.0D0 DO 20 J=N,1,-1 T=R(J)*DSIN(DN) SA=DATAN(T/DSQRT(DABS(1.0D0-T*T))) D=.5D0*(DN+SA) 20 DN=D EPH=D*180.0D0/PI ESN=DSIN(D) ECN=DCOS(D) EDN=DSQRT(1.0D0-HK*HK*ESN*ESN) RETURN END