!***************************************************************************************** !> ! Computation of special functions ! ! Shanjie Zhang and Jianming Jin ! ! Copyrighted but permission granted to use code in programs. ! Buy their book "Computation of Special Functions", 1996, John Wiley & Sons, Inc. ! !### Scipy changes: ! ! * Compiled into a single source file and changed REAL To DBLE throughout. ! * Changed according to ERRATA. ! * Changed GAMMA to GAMMA2 and PSI to PSI_SPEC to avoid potential conflicts. ! * Made functions return sf_error codes in ISFER variables instead ! of printing warnings. The codes are: ! ! * `SF_ERROR_OK` = `0` : no error ! * `SF_ERROR_SINGULAR` = `1` : singularity encountered ! * `SF_ERROR_UNDERFLOW` = `2` : floating point underflow ! * `SF_ERROR_OVERFLOW` = `3` : floating point overflow ! * `SF_ERROR_SLOW` = `4` : too many iterations required ! * `SF_ERROR_LOSS` = `5` : loss of precision ! * `SF_ERROR_NO_RESULT` = `6` : no result obtained ! * `SF_ERROR_DOMAIN` = `7` : out of domain ! * `SF_ERROR_ARG` = `8` : invalid input parameter ! * `SF_ERROR_OTHER` = `9` : unclassified error module specfun_module use iso_fortran_env implicit none #ifdef REAL32 integer,parameter,private :: wp = real32 !! Real working precision [4 bytes] #elif REAL64 integer,parameter,private :: wp = real64 !! Real working precision [8 bytes] #elif REAL128 integer,parameter,private :: wp = real128 !! Real working precision [16 bytes] #else integer,parameter,private :: wp = real64 !! Real working precision if not specified [8 bytes] #endif integer,parameter,public :: specfun_wp = wp !! Working precision real(wp),parameter,private :: pi = acos(-1.0_wp) real(wp),parameter,private :: sqrtpi = sqrt(pi) real(wp),parameter,private :: halfpi = 0.5_wp*pi real(wp),parameter,private :: twopi = 2.0_wp*pi real(wp),parameter,private :: sq2 = sqrt(2.0_wp) real(wp),parameter :: gamma = 0.57721566490153286060651209008240243104215933593992_wp !! Euler's constant to 50 decimal places. !! `.5772156649015329D0` in the original code contains !***************************************************************************************** ! JW: should probably remove these two... real(wp) function dnan() dnan = 0.0_wp dnan = 0.0_wp/dnan end function dnan real(wp) function dinf() dinf = 1.0e300_wp dinf = dinf*dinf end function dinf !***************************************************************************************** !> ! Compute complex parabolic cylinder function `Dn(z)` for small argument subroutine cpdsa(n,z,Cdn) integer,intent(in) :: n !! Order of D(z) (n = 0,-1,-2,...) complex(wp),intent(in) :: z !! complex argument of D(z) complex(wp),intent(out) :: Cdn !! Dn(z) complex(wp) :: ca0 , cb0 , cdw , cr real(wp) :: g0 , g1 , ga0 , gm , pd , va0 , vm , vt , xn integer :: m real(wp),parameter :: eps = 1.0e-15_wp ca0 = exp(-0.25_wp*z*z) va0 = 0.5_wp*(1.0_wp-n) if ( n==0 ) then Cdn = ca0 elseif ( abs(z)==0.0_wp ) then if ( va0<=0.0_wp .and. va0==int(va0) ) then Cdn = 0.0_wp else call gaih(va0,ga0) pd = sqrtpi/(2.0_wp**(-0.5_wp*n)*ga0) Cdn = cmplx(pd,0.0_wp,wp) endif else xn = -n call gaih(xn,g1) cb0 = 2.0_wp**(-0.5_wp*n-1.0_wp)*ca0/g1 vt = -0.5_wp*n call gaih(vt,g0) Cdn = cmplx(g0,0.0_wp,wp) cr = (1.0_wp,0.0_wp) do m = 1 , 250 vm = 0.5_wp*(m-n) call gaih(vm,gm) cr = -cr*sq2*z/m cdw = gm*cr Cdn = Cdn + cdw if ( abs(cdw)<abs(Cdn)*eps ) exit enddo Cdn = cb0*Cdn endif end subroutine cpdsa !***************************************************************************************** !> ! Compute complex Fresnel Integral S(z) and S'(z) subroutine cfs(z,Zf,Zd) complex(wp),intent(in) :: z !! Argument of S(z) complex(wp),intent(out) :: Zf !! S(z) complex(wp),intent(out) :: Zd !! S'(z) complex(wp) :: cf , cf0 , cf1 , cg , cr , d , s , z0 , zp , zp2 real(wp) :: w0 , wb , wb0 integer :: k , m real(wp),parameter :: eps = 1.0e-14_wp w0 = abs(z) zp = halfpi*z*z zp2 = zp*zp z0 = (0.0_wp,0.0_wp) if ( z==z0 ) then s = z0 elseif ( w0<=2.5_wp ) then s = z*zp/3.0_wp cr = s wb0 = 0.0_wp do k = 1 , 80 cr = -0.5_wp*cr*(4.0_wp*k-1.0_wp)/k/(2.0_wp*k+1.0_wp) & /(4.0_wp*k+3.0_wp)*zp2 s = s + cr wb = abs(s) if ( abs(wb-wb0)<eps .and. k>10 ) exit wb0 = wb enddo elseif ( w0>2.5_wp .and. w0<4.5_wp ) then m = 85 s = z0 cf1 = z0 cf0 = (1.0e-100_wp,0.0_wp) do k = m , 0 , -1 cf = (2.0_wp*k+3.0_wp)*cf0/zp - cf1 if ( k/=int(k/2)*2 ) s = s + cf cf1 = cf0 cf0 = cf enddo s = 2.0_wp/(pi*z)*sin(zp)/cf*s else ! Auxiliary functions f(z) and g(z) can be computed using an ! asymptotic expansion in the right quadrant |arg(z)| <= pi/4, not pi/2 ! as sometimes suggested. Use the symmetry S(z) = -iS(-iz). ! Interestingly, most of the expansion code is the same across ! the quadrants. (The fourth power in Z is the equalizer here.) ! Only one constant has to be adapted. if ( aimag(z)>-real(z,wp) .and. aimag(z)<=real(z,wp) ) then ! right quadrant d = cmplx(0.5_wp,0.0_wp,wp) elseif ( aimag(z)>real(z,wp) .and. aimag(z)>=-real(z,wp) ) then ! upper quadrant d = cmplx(0.0_wp,-0.5_wp,wp) elseif ( aimag(z)<-real(z,wp) .and. aimag(z)>=real(z,wp) ) then ! left quadrant d = cmplx(-0.5_wp,0.0_wp,wp) else ! lower quadrant d = cmplx(0.0_wp,0.5_wp,wp) endif cr = (1.0_wp,0.0_wp) cf = (1.0_wp,0.0_wp) do k = 1 , 20 cr = -0.25_wp*cr*(4.0_wp*k-1.0_wp)*(4.0_wp*k-3.0_wp)/zp2 cf = cf + cr enddo cr = (1.0_wp,0.0_wp) cg = (1.0_wp,0.0_wp) do k = 1 , 12 cr = -0.25_wp*cr*(4.0_wp*k+1.0_wp)*(4.0_wp*k-1.0_wp)/zp2 cg = cg + cr enddo cg = cg/(pi*z*z) s = d - (cf*cos(zp)+cg*sin(zp))/(pi*z) endif Zf = s Zd = sin(halfpi*z*z) end subroutine cfs !***************************************************************************************** !> ! Compute the associated Legendre functions of the second kind, Qmn(x) and Qmn'(x) subroutine lqmn(Mm,m,n,x,Qm,Qd) real(wp),intent(in) :: x !! Argument of Qmn(x) integer,intent(in) :: m !! Order of Qmn(x) ( m = 0,1,2,… ) integer,intent(in) :: n !! Degree of Qmn(x) ( n = 0,1,2,… ) integer,intent(in) :: mm !! Physical dimension of QM and QD real(wp),intent(out) :: Qm(0:Mm,0:n) !! Qmn(x) real(wp),intent(out) :: Qd(0:Mm,0:n) !! Qmn'(x) integer :: i , j , k , km , ls real(wp) :: q0 , q1 , q10 , qf , qf0 , qf1 , qf2 , xq , xs if ( abs(x)==1.0_wp ) then do i = 0 , m do j = 0 , n Qm(i,j) = 1.0e+300_wp Qd(i,j) = 1.0e+300_wp enddo enddo return endif ls = 1 if ( abs(x)>1.0_wp ) ls = -1 xs = ls*(1.0_wp-x*x) xq = sqrt(xs) q0 = 0.5_wp*log(abs((x+1.0_wp)/(x-1.0_wp))) if ( abs(x)<1.0001_wp ) then Qm(0,0) = q0 Qm(0,1) = x*q0 - 1.0_wp Qm(1,0) = -1.0_wp/xq Qm(1,1) = -ls*xq*(q0+x/(1.0_wp-x*x)) do i = 0 , 1 do j = 2 , n Qm(i,j) = ((2.0_wp*j-1.0_wp)*x*Qm(i,j-1)-(j+i-1.0_wp) & *Qm(i,j-2))/(j-i) enddo enddo do j = 0 , n do i = 2 , m Qm(i,j) = -2.0_wp*(i-1.0_wp)*x/xq*Qm(i-1,j) & - ls*(j+i-1.0_wp)*(j-i+2.0_wp)*Qm(i-2,j) enddo enddo else if ( abs(x)>1.1_wp ) then km = 40 + m + n else km = (40+m+n)*int(-1.0_wp-1.8_wp*log(x-1.0_wp)) endif qf2 = 0.0_wp qf1 = 1.0_wp qf0 = 0.0_wp do k = km , 0 , -1 qf0 = ((2*k+3.0_wp)*x*qf1-(k+2.0_wp)*qf2)/(k+1.0_wp) if ( k<=n ) Qm(0,k) = qf0 qf2 = qf1 qf1 = qf0 enddo do k = 0 , n Qm(0,k) = q0*Qm(0,k)/qf0 enddo qf2 = 0.0_wp qf1 = 1.0_wp do k = km , 0 , -1 qf0 = ((2*k+3.0_wp)*x*qf1-(k+1.0_wp)*qf2)/(k+2.0_wp) if ( k<=n ) Qm(1,k) = qf0 qf2 = qf1 qf1 = qf0 enddo q10 = -1.0_wp/xq do k = 0 , n Qm(1,k) = q10*Qm(1,k)/qf0 enddo do j = 0 , n q0 = Qm(0,j) q1 = Qm(1,j) do i = 0 , m - 2 qf = -2.0_wp*(i+1)*x/xq*q1 + (j-i)*(j+i+1.0_wp)*q0 Qm(i+2,j) = qf q0 = q1 q1 = qf enddo enddo endif Qd(0,0) = ls/xs do j = 1 , n Qd(0,j) = ls*j*(Qm(0,j-1)-x*Qm(0,j))/xs enddo do j = 0 , n do i = 1 , m Qd(i,j) = ls*i*x/xs*Qm(i,j) + (i+j)*(j-i+1.0_wp)/xq*Qm(i-1,j) enddo enddo end subroutine lqmn !***************************************************************************************** !> ! Compute the associated Legendre functions Pmn(z) ! and their derivatives Pmn'(z) for a complex ! argument subroutine clpmn(Mm,m,n,x,y,Ntype,Cpm,Cpd) integer,intent(in) :: mm !! Physical dimension of CPM and CPD integer,intent(in) :: m !! Order of Pmn(z), m = 0,1,2,...,n integer,intent(in) :: n !! Degree of Pmn(z), n = 0,1,2,...,N real(wp),intent(in) :: x !! Real part of z real(wp),intent(in) :: y !! Imaginary part of z integer,intent(in) :: ntype !! type of cut, either 2 or 3 complex(wp),intent(out) :: Cpm(0:Mm,0:n) !! Pmn(z) complex(wp),intent(out) :: Cpd(0:Mm,0:n) !! Pmn'(z) integer :: i , j , ls complex(wp) :: z , zq , zs z = cmplx(x,y,wp) do i = 0 , n do j = 0 , m Cpm(j,i) = (0.0_wp,0.0_wp) Cpd(j,i) = (0.0_wp,0.0_wp) enddo enddo Cpm(0,0) = (1.0_wp,0.0_wp) if ( n==0 ) return if ( abs(x)==1.0_wp .and. y==0.0_wp ) then do i = 1 , n Cpm(0,i) = x**i Cpd(0,i) = 0.5_wp*i*(i+1)*x**(i+1) enddo do j = 1 , n do i = 1 , m if ( i==1 ) then Cpd(i,j) = dinf() elseif ( i==2 ) then Cpd(i,j) = -0.25_wp*(j+2)*(j+1)*j*(j-1)*x**(j+1) endif enddo enddo return endif if ( Ntype==2 ) then ! sqrt(1 - z^2) with branch cut on |x|>1 zs = (1.0_wp-z*z) zq = -sqrt(zs) ls = -1 else ! sqrt(z^2 - 1) with branch cut between [-1, 1] zs = (z*z-1.0_wp) zq = sqrt(zs) if ( x<0.0_wp ) zq = -zq ls = 1 endif do i = 1 , m ! DLMF 14.7.15 Cpm(i,i) = (2.0_wp*i-1.0_wp)*zq*Cpm(i-1,i-1) enddo do i = 0 , min(m,n-1) ! DLMF 14.10.7 Cpm(i,i+1) = (2.0_wp*i+1.0_wp)*z*Cpm(i,i) enddo do i = 0 , m do j = i + 2 , n ! DLMF 14.10.3 Cpm(i,j) = ((2.0_wp*j-1.0_wp)*z*Cpm(i,j-1)-(i+j-1.0_wp) & *Cpm(i,j-2))/(j-i) enddo enddo Cpd(0,0) = (0.0_wp,0.0_wp) do j = 1 , n ! DLMF 14.10.5 Cpd(0,j) = ls*j*(z*Cpm(0,j)-Cpm(0,j-1))/zs enddo do i = 1 , m do j = i , n ! derivative of DLMF 14.7.11 & DLMF 14.10.6 for type 3 ! 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.0_wp) & /zq*Cpm(i-1,j)) enddo enddo end subroutine clpmn !***************************************************************************************** !> ! Compute parabolic cylinder function Vv(x) ! for small argument subroutine vvsa(Va,x,Pv) real(wp),intent(in) :: Va !! Order real(wp),intent(in) :: x !! Argument real(wp),intent(out) :: Pv !! Vv(x) real(wp) :: a0 , ep , fac , g1 , ga0 , gm , gw , & r , r1 , sv , sv0 , v1 , va0 , & vb0 , vm integer :: m real(wp),parameter :: eps = 1.0e-15_wp ep = exp(-0.25_wp*x*x) va0 = 1.0_wp + 0.5_wp*Va if ( x/=0.0_wp ) then a0 = 2.0_wp**(-0.5_wp*Va)*ep/(twopi) sv = sin(-(Va+0.5_wp)*pi) v1 = -0.5_wp*Va call gamma2(v1,g1) Pv = (sv+1.0_wp)*g1 r = 1.0_wp fac = 1.0_wp do m = 1 , 250 vm = 0.5_wp*(m-Va) call gamma2(vm,gm) r = r*sq2*x/m fac = -fac gw = fac*sv + 1.0_wp r1 = gw*r*gm Pv = Pv + r1 if ( abs(r1/Pv)<eps .and. gw/=0.0_wp ) exit enddo Pv = a0*Pv elseif ( va0<=0.0_wp .and. va0==int(va0) .or. Va==0.0_wp ) then Pv = 0.0_wp else vb0 = -0.5_wp*Va sv0 = sin(va0*pi) call gamma2(va0,ga0) Pv = 2.0_wp**vb0*sv0/ga0 endif end subroutine vvsa !***************************************************************************************** !> ! Compute the zeros of Bessel functions Jn(x) and ! Jn'(x), and arrange them in the order of their ! magnitudes ! !@note: SciPy: Changed `P` from a character array to an integer array. subroutine jdzo(Nt,n,m,p,Zo) integer,intent(in) :: Nt !! Number of total zeros ( NT ≤ 1200 ) integer,intent(out) :: n(1400) !! n, order of Jn(x) or Jn'(x) associated !! with the L-th zero integer,intent(out) :: m(1400) !! m, serial number of the zeros of Jn(x) !! or Jn'(x) associated with the L-th zero !! ( L is the serial number of all the !! zeros of Jn(x) and Jn'(x) ) integer,intent(out) :: p(1400) !! 0 (TM) or 1 (TE), a code for designating the !! zeros of Jn(x) or Jn'(x). !! In the waveguide applications, the zeros !! of Jn(x) correspond to TM modes and !! those of Jn'(x) correspond to TE modes real(wp),intent(out) :: Zo(0:1400) !! Value of the L-th zero of Jn(x) !! and Jn'(x) real(wp) :: x , x0 , x1 , x2 , xm integer :: i , j , k , l , l0 , l1 , l2 , mm , nm integer,dimension(70) :: n1, m1, p1 real(wp),dimension(0:70) :: zoc real(wp),dimension(101) :: bj , dj , fj real(wp),parameter :: tol = 1.0e-10_wp x = 0 zoc(0) = 0 if ( Nt<600 ) then xm = -1.0_wp + 2.248485_wp*Nt**0.5_wp - .0159382_wp*Nt + 3.208775e-4_wp*Nt**1.5_wp nm = int(14.5_wp+.05875_wp*Nt) mm = int(.02_wp*Nt) + 6 else xm = 5.0_wp + 1.445389_wp*Nt**.5_wp + .01889876_wp*Nt - 2.147763e-4_wp*Nt**1.5_wp nm = int(27.8_wp+.0327_wp*Nt) mm = int(.01088_wp*Nt) + 10 endif l0 = 0 do i = 1 , nm x1 = .407658_wp + .4795504_wp*(i-1)**.5_wp + .983618_wp*(i-1) x2 = 1.99535_wp + .8333883_wp*(i-1)**.5_wp + .984584_wp*(i-1) l1 = 0 do j = 1 , mm main : block if ( i/=1 .or. j/=1 ) then x = x1 do call bjndd(i,x,bj,dj,fj) x0 = x x = x - dj(i)/fj(i) if ( x1>xm ) exit main if ( abs(x-x0)<=tol) exit end do endif l1 = l1 + 1 n1(l1) = i - 1 m1(l1) = j if ( i==1 ) m1(l1) = j - 1 p1(l1) = 1 zoc(l1) = x if ( i<=15 ) then x1 = x + 3.057_wp + .0122_wp*(i-1) + (1.555_wp+.41575_wp*(i-1))/(j+1)**2 else x1 = x + 2.918_wp + .01924_wp*(i-1) + (6.26_wp+.13205_wp*(i-1))/(j+1)**2 endif end block main x = x2 do call bjndd(i,x,bj,dj,fj) x0 = x x = x - bj(i)/dj(i) if ( x<=xm ) exit if ( abs(x-x0)<=tol ) then l1 = l1 + 1 n1(l1) = i - 1 m1(l1) = j p1(l1) = 0 zoc(l1) = x if ( i<=15 ) then x2 = x + 3.11_wp + .0138_wp*(i-1) + (.04832_wp+.2804_wp*(i-1))/(j+1)**2 else x2 = x + 3.001_wp + .0105_wp*(i-1) + (11.52_wp+.48525_wp*(i-1))/(j+3)**2 endif exit end if end do enddo l = l0 + l1 l2 = l do if ( l0==0 ) then do k = 1 , l Zo(k) = zoc(k) n(k) = n1(k) m(k) = m1(k) p(k) = p1(k) enddo l1 = 0 elseif ( l0/=0 ) then if ( Zo(l0)>=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==0 ) exit end do l0 = l2 enddo end subroutine jdzo !***************************************************************************************** !> ! Compute coefficient Bk's for oblate radial ! functions with a small argument subroutine cbk(m,n,c,Cv,Qt,Ck,Bk) integer,intent(in) :: m integer,intent(in) :: n real(wp),intent(in) :: c real(wp),intent(in) :: Cv real(wp),intent(in) :: Qt real(wp),intent(in) :: Ck(200) real(wp),intent(out) :: Bk(200) real(wp) :: r1 , s1 , sw , t , u(200) , v(200) , w(200) integer :: i , i1 , ip , j , k , n2 , nm real(wp),parameter :: eps = 1.0e-14_wp ip = 1 if ( n-m==2*int((n-m)/2) ) ip = 0 nm = 25 + int(0.5_wp*(n-m)+c) u(1) = 0.0_wp n2 = nm - 2 do j = 2 , n2 u(j) = c*c enddo do j = 1 , n2 v(j) = (2.0_wp*j-1.0_wp-ip)*(2.0_wp*(j-m)-ip) + m*(m-1.0_wp) - Cv enddo do j = 1 , nm - 1 w(j) = (2.0_wp*j-ip)*(2.0_wp*j+1.0_wp-ip) enddo if ( ip==0 ) then sw = 0.0_wp do k = 0 , n2 - 1 s1 = 0.0_wp i1 = k - m + 1 do i = i1 , nm if ( i>=0 ) then r1 = 1.0_wp do j = 1 , k r1 = r1*(i+m-j)/j enddo s1 = s1 + Ck(i+1)*(2.0_wp*i+m)*r1 if ( abs(s1-sw)<abs(s1)*eps ) exit sw = s1 endif enddo Bk(k+1) = Qt*s1 enddo elseif ( ip==1 ) then sw = 0.0_wp do k = 0 , n2 - 1 s1 = 0.0_wp i1 = k - m + 1 do i = i1 , nm if ( i>=0 ) then r1 = 1.0_wp do j = 1 , k r1 = r1*(i+m-j)/j enddo if ( i>0 ) s1 = s1 + Ck(i)*(2.0_wp*i+m-1)*r1 s1 = s1 - Ck(i+1)*(2.0_wp*i+m)*r1 if ( abs(s1-sw)<abs(s1)*eps ) exit sw = s1 endif enddo Bk(k+1) = Qt*s1 enddo endif w(1) = w(1)/v(1) Bk(1) = Bk(1)/v(1) do k = 2 , n2 t = v(k) - w(k-1)*u(k) w(k) = w(k)/t Bk(k) = (Bk(k)-Bk(k-1)*u(k))/t enddo do k = n2 - 1 , 1 , -1 Bk(k) = Bk(k) - w(k)*Bk(k+1) enddo end subroutine cbk !***************************************************************************************** !> ! Compute prolate spheroidal radial function ! of the second kind with a small argument subroutine rmn2sp(m,n,c,x,Cv,Df,Kd,R2f,R2d) integer,intent(in) :: m integer,intent(in) :: n real(wp) :: c real(wp) :: x real(wp) :: Cv real(wp) :: Df(200) integer :: Kd real(wp),intent(out) :: R2f real(wp),intent(out) :: R2d real(wp),dimension(0:251) :: pd , pm , qd , qm real(wp),dimension(200) :: dn real(wp) :: ck1 , ck2 , ga , gb , gc , r1 , r2 , & r3 , r4, sd , sd0 , sd1 , sd2 , sdm , sf , spd1 , & spd2 , spl , su0 , su1 , su2 , sum , sw integer :: ip , j , j1 , j2 , k , ki , l1 , nm , nm1 , & nm2 , nm3 real(wp),parameter :: eps = 1.0e-14_wp if ( abs(Df(1))<1.0e-280_wp ) then R2f = 1.0e+300_wp R2d = 1.0e+300_wp return endif ip = 1 nm1 = int((n-m)/2) if ( n-m==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.0_wp sw = 0.0_wp do k = 1 , nm j = 2*k - 2 + m + ip su0 = su0 + Df(k)*qm(j) if ( k>nm1 .and. abs(su0-sw)<abs(su0)*eps ) exit sw = su0 enddo sd0 = 0.0_wp do k = 1 , nm j = 2*k - 2 + m + ip sd0 = sd0 + Df(k)*qd(j) if ( k>nm1 .and. abs(sd0-sw)<abs(sd0)*eps ) exit sw = sd0 enddo su1 = 0.0_wp sd1 = 0.0_wp do k = 1 , m j = m - 2*k + ip if ( j<0 ) j = -j - 1 su1 = su1 + dn(k)*qm(j) sd1 = sd1 + dn(k)*qd(j) enddo ga = ((x-1.0_wp)/(x+1.0_wp))**(0.5_wp*m) do k = 1 , m j = m - 2*k + ip if ( j<0 ) then if ( j<0 ) j = -j - 1 r1 = 1.0_wp do j1 = 1 , j r1 = (m+j1)*r1 enddo r2 = 1.0_wp do j2 = 1 , m - j - 2 r2 = j2*r2 enddo r3 = 1.0_wp sf = 1.0_wp do l1 = 1 , j r3 = 0.5_wp*r3*(-j+l1-1.0_wp)*(j+l1)/((m+l1)*l1)*(1.0_wp-x) sf = sf + r3 enddo if ( m-j>=2 ) gb = (m-j-1.0_wp)*r2 if ( m-j<=1 ) gb = 1.0_wp spl = r1*ga*gb*sf su1 = su1 + (-1)**(j+m)*dn(k)*spl spd1 = m/(x*x-1.0_wp)*spl gc = 0.5_wp*j*(j+1.0_wp)/(m+1.0_wp) sd = 1.0_wp r4 = 1.0_wp do l1 = 1 , j - 1 r4 = 0.5_wp*r4*(-j+l1)*(j+l1+1.0_wp)/((m+l1+1.0_wp)*l1)*(1.0_wp-x) sd = sd + r4 enddo spd2 = r1*ga*gb*gc*sd sd1 = sd1 + (-1)**(j+m)*dn(k)*(spd1+spd2) endif enddo su2 = 0.0_wp ki = (2*m+1+ip)/2 nm3 = nm + ki do k = ki , nm3 j = 2*k - 1 - m - ip su2 = su2 + dn(k)*pm(j) if ( j>m .and. abs(su2-sw)<abs(su2)*eps ) exit sw = su2 enddo sd2 = 0.0_wp do k = ki , nm3 j = 2*k - 1 - m - ip sd2 = sd2 + dn(k)*pd(j) if ( j>m .and. abs(sd2-sw)<abs(sd2)*eps ) exit sw = sd2 enddo sum = su0 + su1 + su2 sdm = sd0 + sd1 + sd2 R2f = sum/ck2 R2d = sdm/ck2 end subroutine rmn2sp !***************************************************************************************** !> ! Compute Bernoulli number Bn subroutine bernob(n,Bn) integer,intent(in) :: n !! Serial number real(wp),intent(out) :: Bn(0:n) !! `Bn` real(wp) :: r1 , r2 , s integer :: k , m real(wp),parameter :: tol = 1.0e-15_wp integer,parameter :: maxiter = 10000 Bn(0) = 1.0_wp Bn(1) = -0.5_wp Bn(2) = 1.0_wp/6.0_wp r1 = (2.0_wp/twopi)**2 do m = 4 , n , 2 r1 = -r1*(m-1)*m/(twopi*twopi) r2 = 1.0_wp do k = 2 , maxiter s = (1.0_wp/k)**m r2 = r2 + s if ( s<tol ) exit enddo Bn(m) = r1*r2 enddo end subroutine bernob !***************************************************************************************** !> ! Compute Bernoulli number Bn subroutine bernoa(n,Bn) integer,intent(in) :: n !! Serial number real(wp),intent(out) :: Bn(0:n) !! `Bn` real(wp) :: r , s integer :: j , k , m Bn(0) = 1.0_wp Bn(1) = -0.5_wp do m = 2 , n s = -(1.0_wp/(m+1.0_wp)-0.5_wp) do k = 2 , m - 1 r = 1.0_wp do j = 2 , k r = r*(j+m-k)/j enddo s = s - r*Bn(k) enddo Bn(m) = s enddo do m = 3 , n , 2 Bn(m) = 0.0_wp enddo end subroutine bernoa !***************************************************************************************** !> ! Compute Q*mn(-ic) for oblate radial functions ! with a small argument subroutine qstar(m,n,c,Ck,Ck1,Qs,Qt) integer,intent(in) :: m integer,intent(in) :: n real(wp),intent(in) :: c real(wp),intent(in) :: Ck(200) real(wp),intent(in) :: Ck1 real(wp),intent(out) :: Qs real(wp),intent(out) :: Qt real(wp) :: ap(200) , qs0 , r , s , sk integer :: i , ip , k , l ip = 1 if ( n-m==2*int((n-m)/2) ) ip = 0 r = 1.0_wp/Ck(1)**2 ap(1) = r do i = 1 , m s = 0.0_wp do l = 1 , i sk = 0.0_wp do k = 0 , l sk = sk + Ck(k+1)*Ck(l-k+1) enddo s = s + sk*ap(i-l+1) enddo ap(i+1) = -r*s enddo qs0 = ap(m+1) do l = 1 , m r = 1.0_wp do k = 1 , l r = r*(2.0_wp*k+ip)*(2.0_wp*k-1.0_wp+ip)/(2.0_wp*k)**2 enddo qs0 = qs0 + ap(m-l+1)*r enddo Qs = (-1)**ip*Ck1*(Ck1*qs0)/c Qt = -2.0_wp/Ck1*Qs end subroutine qstar !***************************************************************************************** !> ! Compute the initial characteristic value of ! Mathieu functions for m ≤ 12 or q ≤ 300 or ! q ≥ m*m subroutine cv0(Kd,m,q,a0) integer,intent(in) :: Kd integer,intent(in) :: m !! Order of Mathieu functions real(wp),intent(in) :: q !! Parameter of Mathieu functions real(wp),intent(out) :: a0 !! Characteristic value real(wp) :: q2 q2 = q*q if ( m==0 ) then if ( q<=1.0_wp ) then a0 = (((.0036392_wp*q2-.0125868_wp)*q2+.0546875_wp)*q2-.5_wp)*q2 elseif ( q<=10.0_wp ) then a0 = ((3.999267e-3_wp*q-9.638957e-2_wp)*q-.88297_wp)*q + .5542818_wp else call cvql(Kd,m,q,a0) endif elseif ( m==1 ) then if ( q<=1.0 .and. Kd==2 ) then a0 = (((-6.51e-4_wp*q-.015625_wp)*q-.125_wp)*q+1.0_wp)*q + 1.0_wp elseif ( q<=1.0 .and. Kd==3 ) then a0 = (((-6.51e-4_wp*q+.015625_wp)*q-.125_wp)*q-1.0_wp)*q + 1.0_wp elseif ( q<=10.0 .and. Kd==2 ) then a0 = (((-4.94603e-4_wp*q+1.92917e-2_wp)*q-.3089229_wp)*q+1.33372_wp) & & *q + .811752_wp elseif ( q<=10.0_wp .and. Kd==3 ) then a0 = ((1.971096e-3_wp*q-5.482465e-2_wp)*q-1.152218_wp)*q + 1.10427_wp else call cvql(Kd,m,q,a0) endif elseif ( m==2 ) then if ( q<=1.0 .and. Kd==1 ) then a0 = (((-.0036391_wp*q2+.0125888_wp)*q2-.0551939_wp)*q2+.416667_wp) & *q2 + 4.0_wp elseif ( q<=1.0_wp .and. Kd==4 ) then a0 = (.0003617_wp*q2-.0833333_wp)*q2 + 4.0_wp elseif ( q<=15 .and. Kd==1 ) then a0 = (((3.200972e-4_wp*q-8.667445e-3_wp)*q-1.829032e-4_wp) & *q+.9919999_wp)*q + 3.3290504_wp elseif ( q<=10.0_wp .and. Kd==4 ) then a0 = ((2.38446e-3_wp*q-.08725329_wp)*q-4.732542e-3_wp)*q + 4.00909_wp else call cvql(Kd,m,q,a0) endif elseif ( m==3 ) then if ( q<=1.0_wp .and. Kd==2 ) then a0 = ((6.348e-4_wp*q+.015625_wp)*q+.0625_wp)*q2 + 9.0_wp elseif ( q<=1.0_wp .and. Kd==3 ) then a0 = ((6.348e-4_wp*q-.015625_wp)*q+.0625_wp)*q2 + 9.0 elseif ( q<=20.0_wp .and. Kd==2 ) then a0 = (((3.035731e-4_wp*q-1.453021e-2_wp)*q+.19069602_wp)*q-.1039356_wp) & *q + 8.9449274_wp elseif ( q<=15.0_wp .and. Kd==3 ) then a0 = ((9.369364e-5_wp*q-.03569325_wp)*q+.2689874_wp)*q + 8.771735_wp else call cvql(Kd,m,q,a0) endif elseif ( m==4 ) then if ( q<=1.0 .and. Kd==1 ) then a0 = ((-2.1e-6_wp*q2+5.012e-4_wp)*q2+.0333333_wp)*q2 + 16.0_wp elseif ( q<=1.0_wp .and. Kd==4 ) then a0 = ((3.7e-6_wp*q2-3.669e-4_wp)*q2+.0333333_wp)*q2 + 16.0_wp elseif ( q<=25.0_wp .and. Kd==1 ) then a0 = (((1.076676e-4_wp*q-7.9684875e-3_wp)*q+.17344854_wp)*q-.5924058_wp) & *q + 16.620847_wp elseif ( q<=20.0_wp .and. Kd==4 ) then a0 = ((-7.08719e-4_wp*q+3.8216144e-3_wp)*q+.1907493_wp)*q + 15.744_wp else call cvql(Kd,m,q,a0) endif elseif ( m==5 ) then if ( q<=1.0_wp .and. Kd==2 ) then a0 = ((6.8e-6_wp*q+1.42e-5_wp)*q2+.0208333_wp)*q2 + 25.0_wp elseif ( q<=1.0_wp .and. Kd==3 ) then a0 = ((-6.8e-6_wp*q+1.42e-5_wp)*q2+.0208333_wp)*q2 + 25.0_wp elseif ( q<=35.0_wp .and. Kd==2 ) then a0 = (((2.238231e-5_wp*q-2.983416e-3_wp)*q+.10706975_wp)*q-.600205_wp) & *q + 25.93515_wp elseif ( q<=25.0_wp .and. Kd==3 ) then a0 = ((-7.425364e-4_wp*q+2.18225e-2_wp)*q+4.16399e-2_wp)*q + 24.897_wp else call cvql(Kd,m,q,a0) endif elseif ( m==6 ) then if ( q<=1.0_wp ) then a0 = (.4e-6_wp*q2+.0142857_wp)*q2 + 36.0_wp elseif ( q<=40.0_wp .and. Kd==1 ) then a0 = (((-1.66846e-5_wp*q+4.80263e-4_wp)*q+2.53998e-2_wp)*q-.181233_wp) & *q + 36.423_wp elseif ( q<=35.0_wp .and. Kd==4 ) then a0 = ((-4.57146e-4_wp*q+2.16609e-2_wp)*q-2.349616e-2_wp)*q + 35.99251_wp else call cvql(Kd,m,q,a0) endif elseif ( m==7 ) then if ( q<=10.0_wp ) then call cvqm(m,q,a0) elseif ( q<=50.0_wp .and. Kd==2 ) then a0 = (((-1.411114e-5_wp*q+9.730514e-4_wp)*q-3.097887e-3_wp) & & *q+3.533597e-2_wp)*q + 49.0547_wp elseif ( q<=40.0_wp .and. Kd==3 ) then a0 = ((-3.043872e-4_wp*q+2.05511e-2_wp)*q-9.16292e-2_wp)*q + 49.19035_wp else call cvql(Kd,m,q,a0) endif elseif ( m>=8 ) then if ( q<=3.0_wp*m ) then call cvqm(m,q,a0) elseif ( q>m*m ) then call cvql(Kd,m,q,a0) elseif ( m==8 .and. Kd==1 ) then a0 = (((8.634308e-6_wp*q-2.100289e-3_wp)*q+.169072_wp)*q-4.64336_wp) & *q + 109.4211_wp elseif ( m==8 .and. Kd==4 ) then a0 = ((-6.7842e-5_wp*q+2.2057e-3_wp)*q+.48296_wp)*q + 56.59_wp elseif ( m==9 .and. Kd==2 ) then a0 = (((2.906435e-6_wp*q-1.019893e-3_wp)*q+.1101965_wp)*q-3.821851_wp) & *q + 127.6098_wp elseif ( m==9 .and. Kd==3 ) then a0 = ((-9.577289e-5_wp*q+.01043839_wp)*q+.06588934_wp)*q + 78.0198_wp elseif ( m==10 .and. Kd==1 ) then a0 = (((5.44927e-7_wp*q-3.926119e-4_wp)*q+.0612099_wp)*q-2.600805_wp) & *q + 138.1923_wp elseif ( m==10 .and. Kd==4 ) then a0 = ((-7.660143e-5_wp*q+.01132506_wp)*q-.09746023_wp)*q + 99.29494_wp elseif ( m==11 .and. Kd==2 ) then a0 = (((-5.67615e-7_wp*q+7.152722e-6_wp)*q+.01920291_wp)*q-1.081583_wp) & *q + 140.88_wp elseif ( m==11 .and. Kd==3 ) then a0 = ((-6.310551e-5_wp*q+.0119247_wp)*q-.2681195_wp)*q + 123.667_wp elseif ( m==12 .and. Kd==1 ) then a0 = (((-2.38351e-7_wp*q-2.90139e-5_wp)*q+.02023088_wp)*q-1.289_wp) & & *q + 171.2723_wp elseif ( m==12 .and. Kd==4 ) then a0 = (((3.08902e-7_wp*q-1.577869e-4_wp)*q+.0247911_wp)*q-1.05454_wp) & *q + 161.471_wp endif endif end subroutine cv0 !***************************************************************************************** !> ! Compute the characteristic value of Mathieu ! functions for q ≤ m*m subroutine cvqm(m,q,a0) integer,intent(in) :: m !! Order of Mathieu functions real(wp),intent(in) :: q !! Parameter of Mathieu functions real(wp),intent(out) :: a0 !! Initial characteristic value real(wp) :: hm1 , hm3 , hm5 hm1 = 0.5_wp*q/(m*m-1.0_wp) hm3 = 0.25_wp*hm1**3/(m*m-4.0_wp) hm5 = hm1*hm3*q/((m*m-1.0_wp)*(m*m-9.0_wp)) a0 = m*m + q*(hm1+(5.0_wp*m*m+7.0_wp)*hm3+(9.0_wp*m**4+58.0_wp*m*m+29.0_wp)*hm5) end subroutine cvqm !***************************************************************************************** !> ! Compute the characteristic value of Mathieu ! functions for q ≥ 3m subroutine cvql(Kd,m,q,a0) integer,intent(in) :: Kd integer,intent(in) :: m !! Order of Mathieu functions real(wp),intent(in) :: q !! Parameter of Mathieu functions real(wp),intent(out) :: a0 !! Initial characteristic value real(wp) :: c1 , cv1 , cv2 , d1 , d2 , d3 , d4 , p1 , & p2 , w , w2 , w3 , w4 , w6 select case (Kd) case(1,2) w = 2.0_wp*m + 1.0_wp case(3,4) w = 2.0_wp*m - 1.0_wp case default w = 0.0_wp end select w2 = w*w w3 = w*w2 w4 = w2*w2 w6 = w2*w4 d1 = 5.0_wp + 34.0_wp/w2 + 9.0_wp/w4 d2 = (33.0_wp+410.0_wp/w2+405.0_wp/w4)/w d3 = (63.0_wp+1260.0_wp/w2+2943.0_wp/w4+486.0_wp/w6)/w2 d4 = (527.0_wp+15617.0_wp/w2+69001.0_wp/w4+41607.0_wp/w6)/w3 c1 = 128.0_wp p2 = q/w4 p1 = sqrt(p2) cv1 = -2.0_wp*q + 2.0_wp*w*sqrt(q) - (w2+1.0_wp)/8.0_wp cv2 = (w+3.0_wp/w) + d1/(32.0_wp*p1) + d2/(8.0_wp*c1*p2) cv2 = cv2 + d3/(64.0_wp*c1*p1*p2) + d4/(16.0_wp*c1*c1*p2*p2) a0 = cv1 - cv2/(c1*p1) end subroutine cvql !***************************************************************************************** !> ! Determine the starting point for backward ! recurrence such that the magnitude of ! Jn(x) at that point is about 10^(-MP) function msta1(x,Mp) result(nn) real(wp),intent(in) :: x !! Argument of Jn(x) integer,intent(in) :: Mp !! Value of magnitude integer :: nn !! Starting point real(wp) :: a0 , f , f0 , f1 integer :: it , n0 , n1 a0 = abs(x) n0 = int(1.1_wp*a0) + 1 f0 = envj(n0,a0) - Mp n1 = n0 + 5 f1 = envj(n1,a0) - Mp do it = 1 , 20 nn = n1 - (n1-n0)/(1.0_wp-f0/f1) f = envj(nn,a0) - Mp if ( abs(nn-n1)<1 ) exit n0 = n1 f0 = f1 n1 = nn f1 = f enddo end function msta1 !***************************************************************************************** !> ! Determine the starting point for backward ! recurrence such that all Jn(x) has MP ! significant digits function msta2(x,n,Mp) result(nn) real(wp),intent(in) :: x !! Argument of Jn(x) integer,intent(in) :: n !! Order of Jn(x) integer,intent(in) :: Mp !! Significant digit integer :: nn !! Starting point real(wp) :: a0 , ejn , f , f0 , f1 , hmp , obj integer :: it , n0 , n1 a0 = abs(x) hmp = 0.5_wp*Mp ejn = envj(n,a0) if ( ejn<=hmp ) then obj = Mp n0 = int(1.1_wp*a0) + 1 else obj = hmp + ejn n0 = n endif f0 = envj(n0,a0) - obj n1 = n0 + 5 f1 = envj(n1,a0) - obj do it = 1 , 20 nn = n1 - (n1-n0)/(1.0_wp-f0/f1) f = envj(nn,a0) - obj if ( abs(nn-n1)<1 ) exit n0 = n1 f0 = f1 n1 = nn f1 = f enddo nn = nn + 10 end function msta2 !***************************************************************************************** !> ! real(wp) function envj(n,x) integer,intent(in) :: n real(wp),intent(in) :: x envj = 0.5_wp*log10(6.28_wp*n) - n*log10(1.36_wp*x/n) end function envj !***************************************************************************************** !> ! Integrate [1-J0(t)]/t with respect to t from 0 ! to x, and Y0(t)/t with respect to t from x to ∞ subroutine ittjyb(x,Ttj,Tty) real(wp),intent(in) :: x !! Variable in the limits ( x ≥ 0 ) real(wp),intent(out) :: Ttj !! Integration of [1-J0(t)]/t from 0 to x real(wp),intent(out) :: Tty !! Integration of Y0(t)/t from x to ∞ real(wp) :: e0 , f0 , g0 , t , t1 , x1 , xt if ( x==0.0_wp ) then Ttj = 0.0_wp Tty = -1.0e+300_wp elseif ( x<=4.0_wp ) then x1 = x/4.0_wp t = x1*x1 Ttj = ((((((.35817e-4_wp*t-.639765e-3_wp)*t+.7092535e-2_wp)*t- & .055544803_wp)*t+.296292677_wp)*t-.999999326_wp) & *t+1.999999936_wp)*t Tty = (((((((-.3546e-5_wp*t+.76217e-4_wp)*t-.1059499e-2_wp)*t+ & .010787555_wp)*t-.07810271_wp)*t+.377255736_wp) & *t-1.114084491_wp)*t+1.909859297_wp)*t e0 = gamma + log(x/2.0_wp) Tty = pi/6.0_wp + e0/pi*(2.0_wp*Ttj-e0) - Tty elseif ( x<=8.0_wp ) then xt = x + .25_wp*pi t1 = 4.0_wp/x t = t1*t1 f0 = (((((.0145369_wp*t-.0666297_wp)*t+.1341551_wp)*t-.1647797_wp) & *t+.1608874_wp)*t-.2021547_wp)*t + .7977506_wp g0 = ((((((.0160672_wp*t-.0759339_wp)*t+.1576116_wp)*t-.1960154_wp) & *t+.1797457_wp)*t-.1702778_wp)*t+.3235819_wp)*t1 Ttj = (f0*cos(xt)+g0*sin(xt))/(sqrt(x)*x) Ttj = Ttj + gamma + log(x/2.0_wp) Tty = (f0*sin(xt)-g0*cos(xt))/(sqrt(x)*x) else t = 8.0_wp/x xt = x + .25_wp*pi f0 = (((((.18118e-2_wp*t-.91909e-2_wp)*t+.017033_wp)*t-.9394e-3_wp) & *t-.051445_wp)*t-.11e-5_wp)*t + .7978846_wp g0 = (((((-.23731e-2_wp*t+.59842e-2_wp)*t+.24437e-2_wp)*t-.0233178_wp) & *t+.595e-4_wp)*t+.1620695_wp)*t Ttj = (f0*cos(xt)+g0*sin(xt))/(sqrt(x)*x) & + gamma + log(x/2.0_wp) Tty = (f0*sin(xt)-g0*cos(xt))/(sqrt(x)*x) endif end subroutine ittjyb !***************************************************************************************** !> ! Integrate [1-J0(t)]/t with respect to t from 0 ! to x, and Y0(t)/t with respect to t from x to ∞ subroutine ittjya(x,Ttj,Tty) real(wp),intent(in) :: x !! Variable in the limits ( x ≥ 0 ) real(wp),intent(out) :: Ttj !! Integration of [1-J0(t)]/t from 0 to x real(wp),intent(out) :: Tty !! Integration of Y0(t)/t from x to ∞ real(wp) :: a0 , b1 , bj0 , bj1 , by0 , by1 , e0 , g0 , & g1 , px , qx , r , r0 , r1 , r2 , rs , t , vt , xk integer :: k , l if ( x==0.0_wp ) then Ttj = 0.0_wp Tty = -1.0e+300_wp elseif ( x<=20.0_wp ) then Ttj = 1.0_wp r = 1.0_wp do k = 2 , 100 r = -0.25_wp*r*(k-1.0_wp)/(k*k*k)*x*x Ttj = Ttj + r if ( abs(r)<abs(Ttj)*1.0e-12_wp ) exit enddo Ttj = Ttj*.125_wp*x*x e0 = 0.5_wp*(pi*pi/6.0_wp-gamma*gamma) - (0.5_wp*log(x/2.0_wp)+gamma) & *log(x/2.0_wp) b1 = gamma + log(x/2.0_wp) - 1.5_wp rs = 1.0_wp r = -1.0_wp do k = 2 , 100 r = -0.25_wp*r*(k-1.0_wp)/(k*k*k)*x*x rs = rs + 1.0_wp/k r2 = r*(rs+1.0_wp/(2.0_wp*k)-(gamma+log(x/2.0_wp))) b1 = b1 + r2 if ( abs(r2)<abs(b1)*1.0e-12_wp ) exit enddo Tty = 2.0_wp/pi*(e0+.125_wp*x*x*b1) else a0 = sqrt(2.0_wp/(pi*x)) bj0 = 0.0_wp by0 = 0.0_wp bj1 = 0.0_wp do l = 0 , 1 vt = 4.0_wp*l*l px = 1.0_wp r = 1.0_wp do k = 1 , 14 r = -.0078125_wp*r*(vt-(4.0_wp*k-3.0_wp)**2)/(x*k) & *(vt-(4.0_wp*k-1.0_wp)**2)/((2.0_wp*k-1.0_wp)*x) px = px + r if ( abs(r)<abs(px)*1.0e-12_wp ) exit enddo qx = 1.0_wp r = 1.0_wp do k = 1 , 14 r = -.0078125_wp*r*(vt-(4.0_wp*k-1.0_wp)**2)/(x*k) & *(vt-(4.0_wp*k+1.0_wp)**2)/(2.0_wp*k+1.0_wp)/x qx = qx + r if ( abs(r)<abs(qx)*1.0e-12_wp ) exit enddo qx = .125_wp*(vt-1.0_wp)/x*qx xk = x - (.25_wp+.5_wp*l)*pi bj1 = a0*(px*cos(xk)-qx*sin(xk)) by1 = a0*(px*sin(xk)+qx*cos(xk)) if ( l==0 ) then bj0 = bj1 by0 = by1 endif enddo t = 2.0_wp/x g0 = 1.0_wp r0 = 1.0_wp do k = 1 , 10 r0 = -k*k*t*t*r0 g0 = g0 + r0 enddo g1 = 1.0_wp r1 = 1.0_wp do k = 1 , 10 r1 = -k*(k+1.0_wp)*t*t*r1 g1 = g1 + r1 enddo Ttj = 2.0_wp*g1*bj0/(x*x) - g0*bj1/x + gamma + log(x/2.0_wp) Tty = 2.0_wp*g1*by0/(x*x) - g0*by1/x endif end subroutine ittjya !***************************************************************************************** !> ! Compute Bessel functions Jv(z) and Yv(z) ! and their derivatives with a complex ! argument and a large order subroutine cjylv(v,z,Cbjv,Cdjv,Cbyv,Cdyv) real(wp),intent(in) :: v !! Order of Jv(z) and Yv(z) complex(wp),intent(in) :: z !! Complex argument real(wp),intent(out) :: Cbjv !! Jv(z) real(wp),intent(out) :: Cdjv !! Jv'(z) real(wp),intent(out) :: Cbyv !! Yv(z) real(wp),intent(out) :: Cdyv !! Yv'(z) real(wp) :: a(91) , v0 , vr complex(wp) :: ceta , cf(12) , cfj , cfy , csj , csy , ct , ct2 , cws integer :: i , k , km , l , l0 , lf km = 12 call cjk(km,a) do l = 1 , 0 , -1 v0 = v - l cws = sqrt(1.0_wp-(z/v0)*(z/v0)) ceta = cws + log(z/v0/(1.0_wp+cws)) ct = 1.0_wp/cws ct2 = ct*ct do k = 1 , km l0 = k*(k+1)/2 + 1 lf = l0 + k cf(k) = a(lf) do i = lf - 1 , l0 , -1 cf(k) = cf(k)*ct2 + a(i) enddo cf(k) = cf(k)*ct**k enddo vr = 1.0_wp/v0 csj = (1.0_wp,0.0_wp) do k = 1 , km csj = csj + cf(k)*vr**k enddo Cbjv = sqrt(ct/(twopi*v0))*exp(v0*ceta)*csj if ( l==1 ) cfj = Cbjv csy = (1.0_wp,0.0_wp) do k = 1 , km csy = csy + (-1)**k*cf(k)*vr**k enddo Cbyv = -sqrt(2.0_wp*ct/(pi*v0))*exp(-v0*ceta)*csy if ( l==1 ) cfy = Cbyv enddo Cdjv = -v/z*Cbjv + cfj Cdyv = -v/z*Cbyv + cfy end subroutine cjylv !***************************************************************************************** !> ! Compute prolate and oblate spheroidal radial ! functions of the second kind for given m, n, ! c and a large cx subroutine rmn2l(m,n,c,x,Df,Kd,R2f,R2d,Id) real(wp) :: a0 , b0 , c , cx , Df , dy , eps1 , eps2 , & r , r0 , R2d , R2f , reg , suc , sud , sw , sy , & x integer :: Id , id1 , id2 , ip , j , k , Kd , l , lg , m , n , nm , & nm1 , nm2 , np dimension Df(200) , sy(0:251) , dy(0:251) real(wp),parameter :: eps = 1.0e-14_wp ip = 1 nm1 = int((n-m)/2) if ( n-m==2*nm1 ) ip = 0 nm = 25 + nm1 + int(c) reg = 1.0_wp if ( m+nm>80 ) reg = 1.0e-200_wp nm2 = 2*nm + m cx = c*x call sphy(nm2,cx,nm2,sy,dy) r0 = reg do j = 1 , 2*m + ip r0 = r0*j enddo r = r0 suc = r*Df(1) sw = 0.0_wp do k = 2 , nm r = r*(m+k-1.0_wp)*(m+k+ip-1.5_wp)/(k-1.0_wp)/(k+ip-1.5_wp) suc = suc + r*Df(k) if ( k>nm1 .and. abs(suc-sw)<abs(suc)*eps ) exit sw = suc enddo a0 = (1.0_wp-Kd/(x*x))**(0.5_wp*m)/suc R2f = 0.0_wp eps1 = 0.0_wp np = 0 do k = 1 , nm l = 2*k + m - n - 2 + ip lg = 1 if ( l/=4*int(l/4) ) lg = -1 if ( k==1 ) then r = r0 else r = r*(m+k-1.0_wp)*(m+k+ip-1.5_wp)/(k-1.0_wp)/(k+ip-1.5_wp) endif np = m + 2*k - 2 + ip R2f = R2f + lg*r*(Df(k)*sy(np)) eps1 = abs(R2f-sw) if ( k>nm1 .and. eps1<abs(R2f)*eps ) exit sw = R2f enddo id1 = int(log10(eps1/abs(R2f)+eps)) R2f = R2f*a0 if ( np>=nm2 ) then Id = 10 return endif b0 = Kd*m/x**3.0_wp/(1.0-Kd/(x*x))*R2f sud = 0.0_wp eps2 = 0.0_wp do k = 1 , nm l = 2*k + m - n - 2 + ip lg = 1 if ( l/=4*int(l/4) ) lg = -1 if ( k==1 ) then r = r0 else r = r*(m+k-1.0_wp)*(m+k+ip-1.5_wp)/(k-1.0_wp)/(k+ip-1.5_wp) endif np = m + 2*k - 2 + ip sud = sud + lg*r*(Df(k)*dy(np)) eps2 = abs(sud-sw) if ( k>nm1 .and. eps2<abs(sud)*eps ) exit sw = sud enddo R2d = b0 + a0*c*sud id2 = int(log10(eps2/abs(sud)+eps)) Id = max(id1,id2) end subroutine rmn2l !***************************************************************************************** !> ! Compute Psi function subroutine psi_spec(x,Ps) real(wp),intent(in) :: x !! Argument of `psi(x)` real(wp),intent(out) :: Ps !! `psi(x)` real(wp) :: a1 , a2 , a3 , a4 , a5 , a6 , a7 , a8 , & s , x2 , xa integer k , n xa = abs(x) s = 0.0_wp if ( x==int(x) .and. x<=0.0_wp ) then Ps = 1.0e+300_wp return elseif ( xa==int(xa) ) then n = int(xa) do k = 1 , n - 1 s = s + 1.0_wp/k enddo Ps = -gamma + s elseif ( xa+0.5_wp==int(xa+0.5_wp) ) then n = int(xa - 0.5_wp) do k = 1 , n s = s + 1.0/(2.0_wp*k-1.0_wp) enddo Ps = -gamma + 2.0_wp*s - 1.386294361119891_wp else if ( xa<10.0_wp ) then n = 10 - int(xa) do k = 0 , n - 1 s = s + 1.0_wp/(xa+k) enddo xa = xa + n endif x2 = 1.0_wp/(xa*xa) a1 = -.8333333333333e-01_wp a2 = .83333333333333333e-02_wp a3 = -.39682539682539683e-02_wp a4 = .41666666666666667e-02_wp a5 = -.75757575757575758e-02_wp a6 = .21092796092796093e-01_wp a7 = -.83333333333333333e-01_wp a8 = .4432598039215686e0_wp Ps = log(xa) - 0.5_wp/xa + & x2*(((((((a8*x2+a7)*x2+a6)*x2+a5)*x2+a4)*x2+a3)*x2+a2) & *x2+a1) Ps = Ps - s endif if ( x<0.0_wp ) Ps = Ps - pi*cos(pi*x)/sin(pi*x) - 1.0_wp/x end subroutine psi_spec !***************************************************************************************** !> ! Calculate a specific characteristic value of ! Mathieu functions subroutine cva2(Kd,m,q,a) integer,intent(in) :: m !! Order of Mathieu functions real(wp),intent(in) :: q !! Parameter of Mathieu functions integer,intent(in) :: Kd !! Case code: !! !! * KD=1 for cem(x,q) ( m = 0,2,4,...) !! * KD=2 for cem(x,q) ( m = 1,3,5,...) !! * KD=3 for sem(x,q) ( m = 1,3,5,...) !! * KD=4 for sem(x,q) ( m = 2,4,6,...) real(wp),intent(out) :: a !! Characteristic value real(wp) :: a1 , a2 , delta , q1 , q2 , qq integer :: i , iflag , ndiv , nn if ( m<=12 .or. q<=3.0_wp*m .or. q>m*m ) then call cv0(Kd,m,q,a) if ( q/=0.0_wp .and. m/=2 ) call refine(Kd,m,q,a) if ( q>2.0e-3_wp .and. m==2 ) call refine(Kd,m,q,a) else ndiv = 10 delta = (m-3.0_wp)*m/ndiv if ( (q-3.0_wp*m)<=(m*m-q) ) then do nn = int((q-3.0_wp*m)/delta) + 1 delta = (q-3.0_wp*m)/nn q1 = 2.0_wp*m call cvqm(m,q1,a1) q2 = 3.0_wp*m call cvqm(m,q2,a2) qq = 3.0_wp*m do i = 1 , nn qq = qq + delta a = (a1*q2-a2*q1+(a2-a1)*qq)/(q2-q1) iflag = 1 if ( i==nn ) iflag = -1 call refine(Kd,m,qq,a) q1 = q2 q2 = qq a1 = a2 a2 = a enddo if ( iflag/=-10 ) exit ndiv = ndiv*2 delta = (m-3.0_wp)*m/ndiv end do else do nn = int((m*m-q)/delta) + 1 delta = (m*m-q)/nn q1 = m*(m-1.0_wp) call cvql(Kd,m,q1,a1) q2 = m*m call cvql(Kd,m,q2,a2) qq = m*m do i = 1 , nn qq = qq - delta a = (a1*q2-a2*q1+(a2-a1)*qq)/(q2-q1) iflag = 1 if ( i==nn ) iflag = -1 call refine(Kd,m,qq,a) q1 = q2 q2 = qq a1 = a2 a2 = a enddo if ( iflag/=-10 ) exit ndiv = ndiv*2 delta = (m-3.0_wp)*m/ndiv end do endif endif end subroutine cva2 !***************************************************************************************** !> ! Compute associated Legendre functions Pmn(x) ! and Pmn'(x) for a given order subroutine lpmns(m,n,x,Pm,Pd) real(wp),intent(in) :: x !! Argument of `Pmn(x)` integer,intent(in) :: m !! Order of `Pmn(x), m = 0,1,2,...,n` integer,intent(in) :: n !! Degree of `Pmn(x), n = 0,1,2,...,N` real(wp),intent(out) :: Pm(0:n) !! `Pmn(x)` real(wp),intent(out) :: Pd(0:n) !! `Pmn'(x)` integer :: k real(wp) :: pm0 , pm1 , pm2 , pmk , x0 do k = 0 , n Pm(k) = 0.0_wp Pd(k) = 0.0_wp enddo if ( abs(x)==1.0_wp ) then do k = 0 , n if ( m==0 ) then Pm(k) = 1.0_wp Pd(k) = 0.5_wp*k*(k+1.0_wp) if ( x<0.0_wp ) then Pm(k) = (-1)**k*Pm(k) Pd(k) = (-1)**(k+1)*Pd(k) endif elseif ( m==1 ) then Pd(k) = 1.0e+300_wp elseif ( m==2 ) then Pd(k) = -0.25_wp*(k+2.0_wp)*(k+1.0_wp)*k*(k-1.0_wp) if ( x<0.0_wp ) Pd(k) = (-1)**(k+1)*Pd(k) endif enddo return endif x0 = abs(1.0_wp-x*x) pm0 = 1.0_wp pmk = pm0 do k = 1 , m pmk = (2.0_wp*k-1.0_wp)*sqrt(x0)*pm0 pm0 = pmk enddo pm1 = (2.0_wp*m+1.0_wp)*x*pm0 Pm(m) = pmk Pm(m+1) = pm1 do k = m + 2 , n pm2 = ((2.0_wp*k-1.0_wp)*x*pm1-(k+m-1.0_wp)*pmk)/(k-m) Pm(k) = pm2 pmk = pm1 pm1 = pm2 enddo Pd(0) = ((1.0_wp-m)*Pm(1)-x*Pm(0))/(x*x-1.0_wp) do k = 1 , n Pd(k) = (k*x*Pm(k)-(k+m)*Pm(k-1))/(x*x-1.0_wp) enddo do k = 1 , n Pm(k) = (-1)**m*Pm(k) Pd(k) = (-1)**m*Pd(k) enddo end subroutine lpmns !***************************************************************************************** !> ! Compute complex Error function `erf(z)` & `erf'(z)` subroutine cerf(z,Cer,Cder) complex(wp),intent(in) :: z !! Complex argument of erf(z) complex(wp),intent(out) :: Cer !! `erf(z)` complex(wp),intent(out) :: Cder !! `erf'(z)` real(wp) :: c0 , cs , ei1 , ei2 , er , er0 , er1 , & er2 , eri , err , r , ss , w , w1 , w2 , x ,& x2 , y integer :: k , n real(wp),parameter :: eps = 1.0e-12_wp x = real(z,wp) y = aimag(z) x2 = x*x if ( x<=3.5_wp ) then er = 1.0_wp r = 1.0_wp w = 0.0_wp do k = 1 , 100 r = r*x2/(k+0.5_wp) er = er + r if ( abs(er-w)<=eps*abs(er) ) exit w = er enddo c0 = 2.0_wp/sqrtpi*x*exp(-x2) er0 = c0*er else er = 1.0_wp r = 1.0_wp do k = 1 , 12 r = -r*(k-0.5_wp)/x2 er = er + r enddo c0 = exp(-x2)/(x*sqrtpi) er0 = 1.0_wp - c0*er endif if ( y==0.0_wp ) then err = er0 eri = 0.0_wp else cs = cos(2.0_wp*x*y) ss = sin(2.0_wp*x*y) er1 = exp(-x2)*(1.0_wp-cs)/(twopi*x) ei1 = exp(-x2)*ss/(twopi*x) er2 = 0.0_wp w1 = 0.0_wp do n = 1 , 100 er2 = er2 + exp(-0.25_wp*n*n)/(n*n+4.0_wp*x2) & *(2.0_wp*x-2.0_wp*x*cosh(n*y)*cs+n*sinh(n*y)*ss) if ( abs((er2-w1)/er2)<eps ) exit w1 = er2 enddo c0 = 2.0_wp*exp(-x2)/pi err = er0 + er1 + c0*er2 ei2 = 0.0_wp w2 = 0.0_wp do n = 1 , 100 ei2 = ei2 + exp(-0.25_wp*n*n)/(n*n+4.0_wp*x2) & *(2.0_wp*x*cosh(n*y)*ss+n*sinh(n*y)*cs) if ( abs((ei2-w2)/ei2)<eps ) exit w2 = ei2 enddo eri = ei1 + c0*ei2 endif Cer = cmplx(err,eri,kind=wp) Cder = 2.0_wp/sqrtpi*exp(-z*z) end subroutine cerf !***************************************************************************************** !> ! Compute prolate spheriodal radial functions of the ! first and second kinds, and their derivatives subroutine rswfp(m,n,c,x,Cv,Kf,R1f,R1d,R2f,R2d) integer,intent(in) :: m !! Mode parameter, `m = 0,1,2,...` integer,intent(in) :: n !! Mode parameter, `n = m,m+1,m+2,...` real(wp),intent(in) :: c !! Spheroidal parameter real(wp),intent(in) :: x !! Argument of radial function ( `x > 1.0` ) real(wp),intent(in) :: cv !! Characteristic value integer,intent(in) :: Kf !! Function code: !! * `KF=1` for the first kind !! * `KF=2` for the second kind !! * `KF=3` for both the first and second kinds real(wp),intent(out) :: R1f !! Radial function of the first kind real(wp),intent(out) :: R1d !! Derivative of the radial function of !! the first kind real(wp),intent(out) :: R2f !! Radial function of the second kind real(wp),intent(out) :: R2d !! Derivative of the radial function of !! the second kind real(wp) :: df(200) integer :: id , kd kd = 1 call sdmn(m,n,c,Cv,kd,df) if ( Kf/=2 ) call rmn1(m,n,c,x,df,kd,R1f,R1d) if ( Kf>1 ) then call rmn2l(m,n,c,x,df,kd,R2f,R2d,id) if ( id>-8 ) call rmn2sp(m,n,c,x,Cv,df,kd,R2f,R2d) endif end subroutine rswfp !***************************************************************************************** !> ! Compute Bessel functions `Jn(x)` and `Yn(x)`, and ! their first and second derivatives subroutine jyndd(n,x,Bjn,Djn,Fjn,Byn,Dyn,Fyn) real(wp),intent(in) :: x !! Argument of Jn(x) and Yn(x) ( x > 0 ) integer,intent(in) :: n !! Order of Jn(x) and Yn(x) real(wp),intent(out) :: Bjn !! `Jn(x)` real(wp),intent(out) :: Djn !! `Jn'(x)` real(wp),intent(out) :: Fjn !! `Jn"(x)` real(wp),intent(out) :: Byn !! `Yn(x)` real(wp),intent(out) :: Dyn !! `Yn'(x)` real(wp),intent(out) :: Fyn !! `Yn"(x)` real(wp),dimension(2) :: bj , by integer :: nm call jynbh(n+1,n,x,nm,bj,by) ! 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.0_wp)*Bjn - Djn/x Fyn = (n*n/(x*x)-1.0_wp)*Byn - Dyn/x end subroutine jyndd !***************************************************************************************** !> ! Compute gamma function Г(x) subroutine gam0(x,Ga) real(wp),intent(in) :: x !! Argument of `Г(x) ( |x| ≤ 1 )` real(wp),intent(out) :: Ga !! `Г(x)` real(wp) :: gr integer :: k real(wp),dimension(25),parameter :: g = [ 1.0_wp , & gamma , & -0.6558780715202538_wp , & -0.420026350340952e-1_wp , & 0.1665386113822915_wp , & -0.421977345555443e-1_wp , & -0.96219715278770e-2_wp , & 0.72189432466630e-2_wp , & -0.11651675918591e-2_wp , & -0.2152416741149e-3_wp , & 0.1280502823882e-3_wp , & -0.201348547807e-4_wp , & -0.12504934821e-5_wp , & 0.11330272320e-5_wp , & -0.2056338417e-6_wp , & 0.61160950e-8_wp , & 0.50020075e-8_wp , & -0.11812746e-8_wp , & 0.1043427e-9_wp , & 0.77823e-11_wp , & -0.36968e-11_wp , & 0.51e-12_wp , & -0.206e-13_wp , & -0.54e-14_wp , & 0.14e-14_wp] gr = g(25) ! JW: typo in the original code do k = 24 , 1 , -1 gr = gr*x + g(k) enddo Ga = 1.0_wp/(gr*x) end subroutine gam0 !***************************************************************************************** !> ! Compute cosine and sine integrals ! `Si(x)` and `Ci(x)` ( `x ≥ 0` ) subroutine cisib(x,Ci,Si) real(wp),intent(in) :: x !! Argument of `Ci(x)` and `Si(x)` real(wp),intent(out) :: Ci !! `Ci(x)` real(wp),intent(out) :: Si !! `Si(x)` real(wp) :: fx , gx , x2 x2 = x*x if ( x==0.0_wp ) then Ci = -1.0e+300_wp Si = 0.0_wp elseif ( x<=1.0_wp ) then Ci = ((((-3.0e-8_wp*x2+3.10e-6_wp)*x2-2.3148e-4_wp)*x2+1.041667e-2_wp) & & *x2-0.25)*x2 + 0.577215665_wp + log(x) Si = ((((3.1e-7_wp*x2-2.834e-5_wp)*x2+1.66667e-003_wp)*x2-5.555556e-002_wp)& & *x2+1.0_wp)*x else fx = ((((x2+38.027264_wp)*x2+265.187033_wp)*x2+335.67732_wp) & & *x2+38.102495_wp) & & /((((x2+40.021433_wp)*x2+322.624911_wp)*x2+570.23628_wp) & & *x2+157.105423d0) gx = ((((x2+42.242855_wp)*x2+302.757865_wp)*x2+352.018498_wp) & & *x2+21.821899_wp) & & /((((x2+48.196927_wp)*x2+482.485984_wp)*x2+1114.978885_wp) & & *x2+449.690326_wp)/x Ci = fx*sin(x)/x - gx*cos(x)/x Si = 1.570796327_wp - fx*cos(x)/x - gx*sin(x)/x endif end subroutine cisib !***************************************************************************************** !> ! Compute Euler number En subroutine eulera(n,En) integer,intent(in) :: n !! Serial number real(wp),intent(out) :: En(0:n) !! `En` real(wp) :: r , s integer :: j , k , m En(0) = 1.0_wp do m = 1 , n/2 s = 1.0_wp do k = 1 , m - 1 r = 1.0_wp do j = 1 , 2*k r = r*(2.0_wp*m-2.0_wp*k+j)/j enddo s = s + r*En(2*k) enddo En(2*m) = -s enddo end subroutine eulera !***************************************************************************************** !> ! calculate the accurate characteristic value ! by the secant method subroutine refine(Kd,m,q,a) integer,intent(in) :: Kd integer,intent(in) :: m !! Order of Mathieu functions real(wp),intent(in) :: q !! Parameter of Mathieu functions real(wp),intent(inout) :: a !! Parameter of Mathieu functions real(wp) :: ca , delta , f , f0 , f1 , x , x0 , x1 integer :: it , mj real(wp),parameter :: eps = 1.0e-14_wp mj = 10 + m ca = a delta = 0.0_wp x0 = a call cvf(Kd,m,q,x0,mj,f0) x1 = 1.002_wp*a call cvf(Kd,m,q,x1,mj,f1) do it = 1 , 100 mj = mj + 1 x = x1 - (x1-x0)/(1.0_wp-f0/f1) call cvf(Kd,m,q,x,mj,f) if ( abs(1.0_wp-x1/x)<eps .or. f==0.0_wp ) exit x0 = x1 f0 = f1 x1 = x f1 = f enddo a = x end subroutine refine !***************************************************************************************** !> ! Compute cosine and sine integrals ! `Si(x)` and `Ci(x)` ( `x ≥ 0` ) subroutine cisia(x,Ci,Si) real(wp),intent(in) :: x !! Argument of `Ci(x)` and `Si(x)` real(wp),intent(out) :: Ci !! `Ci(x)` real(wp),intent(out) :: Si !! `Si(x)` real(wp) :: bj(101) , eps, x2 , xa , & xa0 , xa1 , xcs , xf , xg , xg1 , xg2 , xr , xs ,& xss integer :: k , m real(wp),parameter :: p2 = pi / 2.0_wp !1.570796326794897d0 eps = 1.0e-15_wp x2 = x*x if ( x==0.0_wp ) then Ci = -1.0e+300_wp Si = 0.0_wp elseif ( x<=16.0_wp ) then xr = -0.25_wp*x2 Ci = gamma + log(x) + xr do k = 2 , 40 xr = -0.5_wp*xr*(k-1)/(k*k*(2*k-1))*x2 Ci = Ci + xr if ( abs(xr)<abs(Ci)*eps ) exit enddo xr = x Si = x do k = 1 , 40 xr = -0.5_wp*xr*(2*k-1)/k/(4*k*k+4*k+1)*x2 Si = Si + xr if ( abs(xr)<abs(Si)*eps ) return enddo elseif ( x<=32.0_wp ) then m = int(47.2_wp+.82_wp*x) xa1 = 0.0_wp xa0 = 1.0e-100_wp do k = m , 1 , -1 xa = 4.0_wp*k*xa0/x - xa1 bj(k) = xa xa1 = xa0 xa0 = xa enddo xs = bj(1) do k = 3 , m , 2 xs = xs + 2.0_wp*bj(k) enddo bj(1) = bj(1)/xs do k = 2 , m bj(k) = bj(k)/xs enddo xr = 1.0_wp xg1 = bj(1) do k = 2 , m xr = .25_wp*xr*(2.0_wp*k-3.0_wp)**2/((k-1.0_wp)*(2.0_wp*k-1.0_wp)**2)*x xg1 = xg1 + bj(k)*xr enddo xr = 1.0_wp xg2 = bj(1) do k = 2 , m xr = .25_wp*xr*(2.0_wp*k-5.0_wp)**2/((k-1.0_wp)*(2.0_wp*k-3.0_wp)**2)*x xg2 = xg2 + bj(k)*xr enddo xcs = cos(x/2.0_wp) xss = sin(x/2.0_wp) Ci = gamma + log(x) - x*xss*xg1 + 2*xcs*xg2 - 2*xcs*xcs Si = x*xcs*xg1 + 2*xss*xg2 - sin(x) else xr = 1.0_wp xf = 1.0_wp do k = 1 , 9 xr = -2.0_wp*xr*k*(2*k-1)/x2 xf = xf + xr enddo xr = 1.0_wp/x xg = xr do k = 1 , 8 xr = -2.0_wp*xr*(2*k+1)*k/x2 xg = xg + xr enddo Ci = xf*sin(x)/x - xg*cos(x)/x Si = p2 - xf*cos(x)/x - xg*sin(x)/x endif end subroutine cisia !***************************************************************************************** !> ! Evaluate the integral of modified Struve function ! L0(t) with respect to t from 0 to x subroutine itsl0(x,Tl0) real(wp),intent(in) :: x !! Upper limit ( x ≥ 0 ) real(wp),intent(out) :: Tl0 !! Integration of L0(t) from 0 to x real(wp) :: a(18) , a0 , a1 , af , r , rd , s , s0 , ti integer :: k real(wp),parameter :: two_pi = 2.0_wp * pi r = 1.0_wp if ( x<=20.0_wp ) then s = 0.5_wp do k = 1 , 100 rd = 1.0_wp if ( k==1 ) rd = 0.5_wp r = r*rd*k/(k+1.0_wp)*(x/(2.0_wp*k+1.0_wp))**2 s = s + r if ( abs(r/s)<1.0e-12_wp ) exit enddo Tl0 = 2.0_wp/pi*x*x*s else s = 1.0_wp do k = 1 , 10 r = r*k/(k+1.0_wp)*((2.0_wp*k+1.0_wp)/x)**2 s = s + r if ( abs(r/s)<1.0e-12_wp ) exit enddo s0 = -s/(pi*x*x) + 2.0_wp/pi*(log(2.0_wp*x)+gamma) a0 = 1.0_wp a1 = 5.0_wp/8.0_wp a(1) = a1 do k = 1 , 10 af = ((1.5_wp*(k+0.50_wp)*(k+5.0_wp/6.0_wp)*a1-0.5_wp*(k+0.5_wp) & **2*(k-0.5_wp)*a0))/(k+1.0_wp) a(k+1) = af a0 = a1 a1 = af enddo ti = 1.0_wp r = 1.0_wp do k = 1 , 11 r = r/x ti = ti + a(k)*r enddo Tl0 = ti/sqrt(two_pi*x)*exp(x) + s0 endif end subroutine itsl0 !***************************************************************************************** !> ! Compute the Legendre functions `Qn(z)` and ! their derivatives `Qn'(z)` for a complex ! argument subroutine clqn(n,x,y,Cqn,Cqd) integer,intent(in) :: n !! Degree of Qn(z), n = 0,1,2,... real(wp),intent(in) :: x !! Real part of z real(wp),intent(in) :: y !! Imaginary part of z complex(wp),intent(out) :: Cqn(0:n) !! `Cqn` complex(wp),intent(out) :: Cqd(0:n) !! `Cqd` complex(wp) :: cq0 , cq1 , cqf0 , cqf1 , cqf2 , z integer :: k , km , ls z = cmplx(x,y,kind=wp) if ( z==1.0_wp ) then do k = 0 , n Cqn(k) = (1.0e+300_wp,0.0_wp) Cqd(k) = (1.0e+300_wp,0.0_wp) enddo return endif ls = 1 if ( abs(z)>1.0_wp ) ls = -1 cq0 = 0.5_wp*log(ls*(1.0_wp+z)/(1.0_wp-z)) cq1 = z*cq0 - 1.0_wp Cqn(0) = cq0 Cqn(1) = cq1 if ( abs(z)<1.0001_wp ) then cqf0 = cq0 cqf1 = cq1 do k = 2 , n cqf2 = ((2.0_wp*k-1.0_wp)*z*cqf1-(k-1.0_wp)*cqf0)/k Cqn(k) = cqf2 cqf0 = cqf1 cqf1 = cqf2 enddo else if ( abs(z)>1.1_wp ) then km = 40 + n else km = (40+n)*int(-1.0_wp-1.8_wp*log(abs(z-1.0_wp))) endif cqf2 = 0.0_wp cqf1 = 1.0_wp do k = km , 0 , -1 cqf0 = ((2*k+3.0_wp)*z*cqf1-(k+2.0_wp)*cqf2)/(k+1.0_wp) if ( k<=n ) Cqn(k) = cqf0 cqf2 = cqf1 cqf1 = cqf0 enddo do k = 0 , n Cqn(k) = Cqn(k)*cq0/cqf0 enddo endif Cqd(0) = (Cqn(1)-z*Cqn(0))/(z*z-1.0_wp) do k = 1 , n Cqd(k) = (k*z*Cqn(k)-k*Cqn(k-1))/(z*z-1.0_wp) enddo end subroutine clqn !***************************************************************************************** !> ! Compute the first NT zeros of Airy functions ! Ai(x) and Ai'(x), a and a', and the associated ! values of Ai(a') and Ai'(a); and the first NT ! zeros of Airy functions Bi(x) and Bi'(x), b and ! b', and the associated values of Bi(b') and ! Bi'(b) subroutine airyzo(Nt,Kf,Xa,Xb,Xc,Xd) integer,intent(in) :: Nt !! Total number of zeros integer,intent(in) :: Kf !! Function code: !! !! * KF=1 for Ai(x) and Ai'(x) !! * KF=2 for Bi(x) and Bi'(x) real(wp),intent(out) :: Xa(Nt) !! a, the m-th zero of Ai(x) or b, the m-th zero of Bi(x) real(wp),intent(out) :: Xb(Nt) !! a', the m-th zero of Ai'(x) or b', the m-th zero of Bi'(x) real(wp),intent(out) :: Xc(Nt) !! Ai(a') or Bi(b') real(wp),intent(out) :: Xd(Nt) !! Ai'(a) or Bi'(b) ( The index is the serial number of zeros ) real(wp) :: ad , ai , bd , bi , err , rt , rt0 , u , u1 , x integer :: i rt = 0.0_wp do i = 1 , Nt rt0 = 0.0_wp if ( Kf==1 ) then u = 3.0_wp*pi*(4.0_wp*i-1)/8.0_wp u1 = 1/(u*u) elseif ( Kf==2 ) then if ( i==1 ) then rt0 = -1.17371d0 else u = 3.0_wp*pi*(4.0_wp*i-3.0_wp)/8.0_wp u1 = 1.0_wp/(u*u) endif endif ! DLMF 9.9.18 if ( rt0==0 ) rt0 = -(u*u)**(1.0_wp/3.0_wp) & *(+1.0_wp+u1*(5.0_wp/48.0_wp+u1* & (-5.0_wp/36.0_wp+u1*(77125.0_wp/82944.0_wp+ & u1*(-108056875.0_wp/6967296.0_wp))))) do x = rt0 call airyb(x,ai,bi,ad,bd) if ( Kf==1 ) rt = rt0 - ai/ad if ( Kf==2 ) rt = rt0 - bi/bd err = abs((rt-rt0)/rt) if ( err>1.0e-12_wp ) then rt0 = rt else Xa(i) = rt if ( err>1.0e-14_wp ) call airyb(rt,ai,bi,ad,bd) if ( Kf==1 ) Xd(i) = ad if ( Kf==2 ) Xd(i) = bd exit endif end do enddo do i = 1 , Nt rt0 = 0.0_wp if ( Kf==1 ) then if ( i==1 ) then rt0 = -1.01879_wp else u = 3.0_wp*pi*(4.0_wp*i-3.0_wp)/8.0_wp u1 = 1/(u*u) endif elseif ( Kf==2 ) then if ( i==1 ) then rt0 = -2.29444_wp else u = 3.0_wp*pi*(4.0_wp*i-1.0_wp)/8.0_wp u1 = 1/(u*u) endif endif ! DLMF 9.9.19 if ( rt0==0 ) rt0 = -(u*u)**(1.0_wp/3.0_wp) & *(+1.0_wp+u1*(-7.0_wp/48.0_wp+u1* & (+35.0_wp/288.0_wp+u1*(-181223.0_wp/207360.0_wp+ & u1*(18683371.0_wp/1244160.0_wp))))) do x = rt0 call airyb(x,ai,bi,ad,bd) if ( Kf==1 ) rt = rt0 - ad/(ai*x) if ( Kf==2 ) rt = rt0 - bd/(bi*x) err = abs((rt-rt0)/rt) if ( err>1.0e-12_wp ) then rt0 = rt else Xb(i) = rt if ( err>1.0e-14_wp ) call airyb(rt,ai,bi,ad,bd) if ( Kf==1 ) Xc(i) = ai if ( Kf==2 ) Xc(i) = bi exit endif end do enddo end subroutine airyzo !***************************************************************************************** !> ! Compute error function erf(x) subroutine error(x,Err) real(wp),intent(in) :: x !! Argument of `erf(x)` real(wp),intent(out) :: Err !! `erf(x)` real(wp) :: c0 , er , r , x2 integer :: k real(wp),parameter :: eps = 1.0e-15_wp x2 = x*x if ( abs(x)<3.5_wp ) then er = 1.0_wp r = 1.0_wp do k = 1 , 50 r = r*x2/(k+0.5_wp) er = er + r if ( abs(r)<=abs(er)*eps ) exit enddo c0 = 2.0_wp/sqrtpi*x*exp(-x2) Err = c0*er else er = 1.0_wp r = 1.0_wp do k = 1 , 12 r = -r*(k-0.5_wp)/x2 er = er + r enddo c0 = exp(-x2)/(abs(x)*sqrtpi) Err = 1.0_wp - c0*er if ( x<0.0_wp ) Err = -Err endif end subroutine error !***************************************************************************************** !> ! Compute error function `erf(z)` for a complex ! argument `(z=x+iy)` subroutine cerror(z,Cer) complex(wp),intent(in) :: z !! Complex argument complex(wp),intent(out) :: Cer !! `erf(z)` complex(wp) :: c0 , cl , cr , cs , z1 integer :: k real(wp) :: a0 a0 = abs(z) c0 = exp(-z*z) z1 = z if ( real(z,wp)<0.0_wp ) z1 = -z ! ! Cutoff radius R = 4.36; determined by balancing rounding error ! and asymptotic expansion error, see below. ! ! The resulting maximum global accuracy expected is around 1e-8 ! if ( a0<=4.36_wp ) then ! ! Rounding error in the Taylor expansion is roughly ! ! ~ R*R * EPSILON * R**(2 R**2) / (2 R**2 Gamma(R**2 + 1/2)) ! cs = z1 cr = z1 do k = 1 , 120 cr = cr*z1*z1/(k+0.5_wp) cs = cs + cr if ( abs(cr/cs)<1.0e-15_wp ) exit enddo Cer = 2.0_wp*c0*cs/sqrtpi else cl = 1.0_wp/z1 cr = cl ! ! Asymptotic series; maximum K must be at most ~ R^2. ! ! The maximum accuracy obtainable from this expansion is roughly ! ! ~ Gamma(2R**2 + 2) / ( ! (2 R**2)**(R**2 + 1/2) Gamma(R**2 + 3/2) 2**(R**2 + 1/2)) ! do k = 1 , 20 cr = -cr*(k-0.5_wp)/(z1*z1) cl = cl + cr if ( abs(cr/cl)<1.0e-15_wp ) exit enddo Cer = 1.0_wp - c0*cl/sqrtpi endif if ( real(z,wp)<0.0_wp ) Cer = -Cer end subroutine cerror !***************************************************************************************** !> ! Compute Euler number En subroutine eulerb(n,En) integer,intent(in) :: n !! Serial number real(wp),intent(out) :: En(0:n) !! `En` real(wp) :: r1 , r2 , s integer :: isgn , k , m real(wp),parameter :: hpi = 2.0_wp / pi ! 2.0_wp/3.141592653589793d0 En(0) = 1.0_wp En(2) = -1.0_wp r1 = -4.0_wp*hpi**3 do m = 4 , n , 2 r1 = -r1*(m-1)*m*hpi*hpi r2 = 1.0_wp isgn = 1.0_wp do k = 3 , 1000 , 2 isgn = -isgn s = (1.0_wp/k)**(m+1) r2 = r2 + isgn*s if ( s<1.0e-15_wp ) exit enddo En(m) = r1*r2 enddo end subroutine eulerb !***************************************************************************************** !> ! Compute a sequence of characteristic values of ! Mathieu functions subroutine cva1(Kd,m,q,Cv) integer,intent(in) :: Kd !! Case code: !! !! * `KD=1` for `cem(x,q)` ( `m = 0,2,4,…` ) !! * `KD=2` for `cem(x,q)` ( `m = 1,3,5,…` ) !! * `KD=3` for `sem(x,q)` ( `m = 1,3,5,…` ) !! * `KD=4` for `sem(x,q)` ( `m = 2,4,6,…` ) integer,intent(in) :: m !! Maximum order of Mathieu functions real(wp),intent(in) :: q !! Parameter of Mathieu functions real(wp),intent(out) :: Cv(200) !! CV(I) --- Characteristic values; I = 1,2,3,... !! !! * For `KD=1, CV(1), CV(2), CV(3),...`, correspond to !! the characteristic values of `cem` for `m = 0,2,4,...` !! * For `KD=2, CV(1), CV(2), CV(3),...`, correspond to !! the characteristic values of `cem` for `m = 1,3,5,...` !! * For `KD=3, CV(1), CV(2), CV(3),...`, correspond to !! the characteristic values of `sem` for `m = 1,3,5,...` !! * For `KD=4, CV(1), CV(2), CV(3),...`, correspond to !! the characteristic values of `sem` for `m = 0,2,4,...` real(wp),dimension(500) :: d , e , f real(wp),dimension(200) :: g , h real(wp) :: s , t , t1 , x1 , xa , xb integer :: i , ic , icm , j , k , k1 , nm , nm1 real(wp),parameter :: eps = 1.0e-14_wp icm = int(m/2) + 1 if ( Kd==4 ) icm = m/2 if ( q/=0.0_wp ) then nm = int(10.0_wp+1.5_wp*m+0.5_wp*q) e(1) = 0.0_wp f(1) = 0.0_wp if ( Kd==1 ) then d(1) = 0.0_wp do i = 2 , nm d(i) = 4.0_wp*(i-1.0_wp)**2 e(i) = q f(i) = q*q enddo e(2) = sq2*q f(2) = 2.0_wp*q*q elseif ( Kd/=4 ) then d(1) = 1.0_wp + (-1)**Kd*q do i = 2 , nm d(i) = (2.0_wp*i-1.0_wp)**2 e(i) = q f(i) = q*q enddo else d(1) = 4.0_wp do i = 2 , nm d(i) = 4.0_wp*i*i e(i) = q f(i) = q*q enddo endif xa = d(nm) + abs(e(nm)) xb = d(nm) - abs(e(nm)) nm1 = nm - 1 do i = 1 , nm1 t = abs(e(i)) + abs(e(i+1)) t1 = d(i) + t if ( xa<t1 ) xa = t1 t1 = d(i) - t if ( t1<xb ) xb = t1 enddo do i = 1 , icm g(i) = xa h(i) = xb enddo do k = 1 , icm do k1 = k , icm if ( g(k1)<g(k) ) then g(k) = g(k1) exit endif enddo if ( k/=1 .and. h(k)<h(k-1) ) h(k) = h(k-1) do x1 = (g(k)+h(k))/2.0_wp Cv(k) = x1 if ( abs((g(k)-h(k))/x1)<eps ) then Cv(k) = x1 exit else j = 0 s = 1.0_wp do i = 1 , nm if ( s==0.0_wp ) s = s + 1.0e-30_wp t = f(i)/s s = d(i) - t - x1 if ( s<0.0_wp ) j = j + 1 enddo if ( j<k ) then h(k) = x1 else g(k) = x1 if ( j>=icm ) then g(icm) = x1 else if ( h(j+1)<x1 ) h(j+1) = x1 if ( x1<g(j) ) g(j) = x1 endif endif endif end do enddo elseif ( Kd==1 ) then do ic = 1 , icm Cv(ic) = 4.0_wp*(ic-1.0_wp)**2 enddo elseif ( Kd/=4 ) then do ic = 1 , icm Cv(ic) = (2.0_wp*ic-1.0_wp)**2 enddo else do ic = 1 , icm Cv(ic) = 4.0_wp*ic*ic enddo endif end subroutine cva1 !***************************************************************************************** !> ! Integrate [I0(t)-1]/t with respect to t from 0 ! to x, and K0(t)/t with respect to t from x to ∞ subroutine ittikb(x,Tti,Ttk) real(wp),intent(in) :: x !! Variable in the limits ( x ≥ 0 ) real(wp),intent(out) :: Tti !! Integration of [I0(t)-1]/t from 0 to x real(wp),intent(out) :: Ttk !! Integration of K0(t)/t from x to ∞ real(wp) :: e0 , t , t1 , x1 if ( x==0.0_wp ) then Tti = 0.0_wp elseif ( x<=5.0_wp ) then x1 = x/5.0_wp t = x1*x1 Tti = (((((((.1263e-3_wp*t+.96442e-3_wp)*t+.968217e-2_wp)*t+.06615507_wp)& *t+.33116853_wp)*t+1.13027241_wp)*t+2.44140746_wp) & *t+3.12499991_wp)*t else t = 5.0_wp/x Tti = (((((((((2.1945464_wp*t-3.5195009_wp)*t-11.9094395_wp)*t+ & 40.394734_wp)*t-48.0524115_wp)*t+28.1221478_wp) & *t-8.6556013_wp)*t+1.4780044_wp)*t-.0493843_wp) & *t+.1332055_wp)*t + .3989314_wp Tti = Tti*exp(x)/(sqrt(x)*x) endif if ( x==0.0_wp ) then Ttk = 1.0e+300_wp elseif ( x<=2.0_wp ) then t1 = x/2.0_wp t = t1*t1 Ttk = (((((.77e-6_wp*t+.1544e-4_wp)*t+.48077e-3_wp)*t+.925821e-2_wp) & & *t+.10937537_wp)*t+.74999993_wp)*t e0 = gamma + log(x/2.0_wp) Ttk = pi*pi/24.0_wp + e0*(0.5_wp*e0+Tti) - Ttk elseif ( x<=4.0_wp ) then t = 2.0_wp/x Ttk = (((.06084_wp*t-.280367_wp)*t+.590944_wp)*t-.850013_wp) & & *t + 1.234684_wp Ttk = Ttk*exp(-x)/(sqrt(x)*x) else t = 4.0_wp/x Ttk = (((((.02724_wp*t-.1110396_wp)*t+.2060126_wp)*t-.2621446_wp) & & *t+.3219184_wp)*t-.5091339_wp)*t + 1.2533141_wp Ttk = Ttk*exp(-x)/(sqrt(x)*x) endif end subroutine ittikb !***************************************************************************************** !> ! Compute Legendre functions `Qn(x)` & `Qn'(x)` subroutine lqnb(n,x,Qn,Qd) real(wp),intent(in) :: x !! Argument of Qn(x) integer,intent(in) :: n !! Degree of Qn(x) ( n = 0,1,2,…) real(wp),intent(out) :: Qn(0:n) !! Qn(x) real(wp),intent(out) :: Qd(0:n) !! Qn'(x) real(wp) :: q0 , q1 , qc1 , qc2 , qf , qf0 , qf1 , qf2 , qr , x2 integer :: j , k , l , nl real(wp),parameter :: eps = 1.0e-14_wp if ( abs(x)==1.0_wp ) then do k = 0 , n Qn(k) = 1.0e+300_wp Qd(k) = 1.0e+300_wp enddo return endif if ( x<=1.021_wp ) then x2 = abs((1.0_wp+x)/(1.0_wp-x)) q0 = 0.5_wp*log(x2) q1 = x*q0 - 1.0_wp Qn(0) = q0 Qn(1) = q1 Qd(0) = 1.0_wp/(1.0_wp-x*x) Qd(1) = Qn(0) + x*Qd(0) do k = 2 , n qf = ((2.0_wp*k-1.0_wp)*x*q1-(k-1.0_wp)*q0)/k Qn(k) = qf Qd(k) = (Qn(k-1)-x*qf)*k/(1.0_wp-x*x) q0 = q1 q1 = qf enddo else qc1 = 0.0_wp qc2 = 1.0_wp/x do j = 1 , n qc2 = qc2*j/((2.0_wp*j+1.0_wp)*x) if ( j==n-1 ) qc1 = qc2 enddo do l = 0 , 1 nl = n + l qf = 1.0_wp qr = 1.0_wp do k = 1 , 500 qr = qr*(0.5_wp*nl+k-1.0_wp)*(0.5_wp*(nl-1)+k) & /((nl+k-0.5_wp)*k*x*x) qf = qf + qr if ( abs(qr/qf)<eps ) exit enddo if ( l==0 ) then Qn(n-1) = qf*qc1 else Qn(n) = qf*qc2 endif enddo qf2 = Qn(n) qf1 = Qn(n-1) do k = n , 2 , -1 qf0 = ((2*k-1.0_wp)*x*qf1-k*qf2)/(k-1.0_wp) Qn(k-2) = qf0 qf2 = qf1 qf1 = qf0 enddo Qd(0) = 1.0_wp/(1.0_wp-x*x) do k = 1 , n Qd(k) = k*(Qn(k-1)-x*Qn(k))/(1.0_wp-x*x) enddo endif end subroutine lqnb !***************************************************************************************** !> ! Compute the expansion coefficients for the ! asymptotic expansion of Bessel functions ! with large orders subroutine cjk(Km,a) integer,intent(in) :: Km !! Maximum k real(wp),dimension(*),intent(out) :: a !! A(L) --- Cj(k) where j and k are related to L !! by L=j+1+[k*(k+1)]/2; j,k=0,1,...,Km real(wp) :: f , f0 , g , g0 integer :: j , k , l1 , l2 , l3 , l4 a(1) = 1.0_wp f0 = 1.0_wp g0 = 1.0_wp do k = 0 , Km - 1 l1 = (k+1)*(k+2)/2 + 1 l2 = (k+1)*(k+2)/2 + k + 2 f = (0.5_wp*k+0.125_wp/(k+1))*f0 g = -(1.5_wp*k+0.625_wp/(3.0_wp*(k+1.0_wp)))*g0 a(l1) = f a(l2) = g f0 = f g0 = g enddo do k = 1 , Km - 1 do j = 1 , k l3 = k*(k+1)/2 + j + 1 l4 = (k+1)*(k+2)/2 + j + 1 a(l4) = (j+0.5_wp*k+0.125_wp/(2.0_wp*j+k+1.0_wp))*a(l3) & & - (j+0.5_wp*k-1.0_wp+0.625_wp/(2.0_wp*j+k+1.0_wp))*a(l3-1) enddo enddo end subroutine cjk !***************************************************************************************** !> ! Integrate [I0(t)-1]/t with respect to t from 0 ! to x, and K0(t)/t with respect to t from x to ∞ subroutine ittika(x,Tti,Ttk) real(wp),intent(in) :: x !! Variable in the limits ( x ≥ 0 ) real(wp),intent(out) :: Tti !! Integration of [I0(t)-1]/t from 0 to x real(wp),intent(out) :: Ttk !! Integration of K0(t)/t from x to ∞ real(wp) :: b1 , e0 , r , r2 , rc , rs integer :: k real(wp),dimension(8),parameter :: c = [1.625_wp , & 4.1328125_wp , & 1.45380859375e+1_wp , & 6.553353881835e+1_wp , & 3.6066157150269e+2_wp , & 2.3448727161884e+3_wp , & 1.7588273098916e+4_wp , & 1.4950639538279e+5_wp] if ( x==0.0_wp ) then Tti = 0.0_wp Ttk = 1.0e+300_wp return endif if ( x<40.0_wp ) then Tti = 1.0_wp r = 1.0_wp do k = 2 , 50 r = .25_wp*r*(k-1.0_wp)/(k*k*k)*x*x Tti = Tti + r if ( abs(r/Tti)<1.0e-12_wp ) exit enddo Tti = Tti*.125_wp*x*x else Tti = 1.0_wp r = 1.0_wp do k = 1 , 8 r = r/x Tti = Tti + c(k)*r enddo rc = x*sqrt(twopi*x) Tti = Tti*exp(x)/rc endif if ( x<=12.0_wp ) then e0 = (0.5_wp*log(x/2.0_wp)+gamma)*log(x/2.0_wp) + pi*pi/24.0_wp + & 0.5_wp*gamma*gamma b1 = 1.5_wp - (gamma+log(x/2.0_wp)) rs = 1.0_wp r = 1.0_wp do k = 2 , 50 r = .25_wp*r*(k-1.0_wp)/(k*k*k)*x*x rs = rs + 1.0_wp/k r2 = r*(rs+1.0_wp/(2.0_wp*k)-(gamma+log(x/2.0_wp))) b1 = b1 + r2 if ( abs(r2/b1)<1.0e-12_wp ) exit enddo Ttk = e0 - .125_wp*x*x*b1 else Ttk = 1.0_wp r = 1.0_wp do k = 1 , 8 r = -r/x Ttk = Ttk + c(k)*r enddo rc = x*sqrt(2.0_wp/pi*x) Ttk = Ttk*exp(-x)/rc endif end subroutine ittika !***************************************************************************************** !> ! Compute lambda function with arbitrary order `v`, ! and their derivative ! !@note In the original version of this routine, `x` was returned modified as `x = abs(x)`. subroutine lamv(v,xi,Vm,Vl,Dl) real(wp),intent(in) :: v !! Order of lambda function real(wp),intent(in) :: xi !! Argument of lambda function real(wp),intent(out) :: Vm !! Highest order computed real(wp),dimension(0:*),intent(out) :: Vl !! Lambda function of order `n+v0` real(wp),dimension(0:*),intent(out) :: Dl !! Derivative of lambda function real(wp) :: a0 , bjv0 , bjv1 , bk , ck , cs , f , f0 , & f1 , f2 , fac , ga , px , qx , r , r0 , rc ,& rp, x, rq , sk , uk , v0 , vk , vv , x2 , xk integer :: i , j , k , k0 , m , n real(wp),parameter :: rp2 = 2.0_wp / pi ! 0.63661977236758d0 x = abs(xi) x2 = x*x n = int(v) v0 = v - n Vm = v if ( x<=12.0_wp ) then do k = 0 , n vk = v0 + k bk = 1.0_wp r = 1.0_wp do i = 1 , 50 r = -0.25_wp*r*x2/(i*(i+vk)) bk = bk + r if ( abs(r)<abs(bk)*1.0e-15_wp ) exit enddo Vl(k) = bk uk = 1.0_wp r = 1.0_wp do i = 1 , 50 r = -0.25_wp*r*x2/(i*(i+vk+1.0_wp)) uk = uk + r if ( abs(r)<abs(uk)*1.0e-15_wp ) exit enddo Dl(k) = -0.5_wp*x/(vk+1.0_wp)*uk enddo return endif k0 = 11 if ( x>=35.0_wp ) k0 = 10 if ( x>=50.0_wp ) k0 = 8 bjv0 = 0.0_wp bjv1 = 0.0_wp do j = 0 , 1 vv = 4.0_wp*(j+v0)*(j+v0) px = 1.0_wp rp = 1.0_wp do k = 1 , k0 rp = -0.78125e-2_wp*rp*(vv-(4.0_wp*k-3.0_wp)**2.0_wp) & *(vv-(4.0_wp*k-1.0_wp)**2.0_wp)/(k*(2.0_wp*k-1.0_wp)*x2) px = px + rp enddo qx = 1.0_wp rq = 1.0_wp do k = 1 , k0 rq = -0.78125e-2_wp*rq*(vv-(4.0_wp*k-1.0_wp)**2.0_wp) & *(vv-(4.0_wp*k+1.0_wp)**2.0_wp)/(k*(2.0_wp*k+1.0_wp)*x2) qx = qx + rq enddo qx = 0.125_wp*(vv-1.0_wp)*qx/x xk = x - (0.5_wp*(j+v0)+0.25_wp)*pi a0 = sqrt(rp2/x) ck = cos(xk) sk = sin(xk) if ( j==0 ) bjv0 = a0*(px*ck-qx*sk) if ( j==1 ) bjv1 = a0*(px*ck-qx*sk) enddo if ( v0==0.0_wp ) then ga = 1.0_wp else call gam0(v0,ga) ga = v0*ga endif fac = (2.0_wp/x)**v0*ga Vl(0) = bjv0 Dl(0) = -bjv1 + v0/x*bjv0 Vl(1) = bjv1 Dl(1) = bjv0 - (1.0_wp+v0)/x*bjv1 r0 = 2.0_wp*(1.0_wp+v0)/x if ( n<=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.0_wp+v0)/x*Vl(1) return endif if ( n>=2 .and. n<=int(0.9_wp*x) ) then f0 = bjv0 f1 = bjv1 do k = 2 , n f = 2.0_wp*(k+v0-1.0_wp)/x*f1 - f0 f0 = f1 f1 = f Vl(k) = f enddo elseif ( n>=2 ) then m = msta1(x,200) if ( m<n ) then n = m else m = msta2(x,n,15) endif f = 0.0_wp f2 = 0.0_wp f1 = 1.0e-100_wp do k = m , 0 , -1 f = 2.0_wp*(v0+k+1.0_wp)/x*f1 - f2 if ( k<=n ) Vl(k) = f f2 = f1 f1 = f enddo cs = 0.0_wp if ( abs(bjv0)>abs(bjv1) ) then cs = bjv0/f else cs = bjv1/f2 endif do k = 0 , n Vl(k) = cs*Vl(k) enddo endif Vl(0) = fac*Vl(0) do j = 1 , n rc = fac*r0 Vl(j) = rc*Vl(j) Dl(j-1) = -0.5_wp*x/(j+v0)*Vl(j) r0 = 2.0_wp*(j+v0+1)/x*r0 enddo Dl(n) = 2.0_wp*(v0+n)*(Vl(n-1)-Vl(n))/x Vm = n + v0 end subroutine lamv !***************************************************************************************** !> ! Compute hypergeometric function U(a,b,x) by ! using Gaussian-Legendre integration (n=60) subroutine chguit(a,b,x,Hu,Id) real(wp),intent(in) :: a !! Parameter ( `a > 0` ) real(wp),intent(in) :: b !! Parameter real(wp),intent(in) :: x !! Argument ( `x > 0` ) real(wp),intent(out) :: Hu !! `U(a,b,z)` integer,intent(out) :: Id !! Estimated number of significant digits real(wp) :: a1 , b1 , c , d , f1 , f2 , g , ga ,& hu0 , hu1 , hu2 , s, t1 , t2 , t3 , t4 integer :: j , k , m real(wp),dimension(30),parameter :: t = & [.259597723012478e-01_wp , .778093339495366e-01_wp , & .129449135396945e+00_wp , .180739964873425e+00_wp , & .231543551376029e+00_wp , .281722937423262e+00_wp , & .331142848268448e+00_wp , .379670056576798e+00_wp , & .427173741583078e+00_wp , .473525841761707e+00_wp , & .518601400058570e+00_wp , .562278900753945e+00_wp , & .604440597048510e+00_wp , .644972828489477e+00_wp , & .683766327381356e+00_wp , .720716513355730e+00_wp , & .755723775306586e+00_wp , .788693739932264e+00_wp , & .819537526162146e+00_wp , .848171984785930e+00_wp , & .874519922646898e+00_wp , .898510310810046e+00_wp , & .920078476177628e+00_wp , .939166276116423e+00_wp , & .955722255839996e+00_wp , .969701788765053e+00_wp , & .981067201752598e+00_wp , .989787895222222e+00_wp , & .995840525118838e+00_wp , .999210123227436e+00_wp ] real(wp),dimension(30),parameter :: w = & [ .519078776312206e-01_wp , .517679431749102e-01_wp , & .514884515009810e-01_wp , .510701560698557e-01_wp , & .505141845325094e-01_wp , .498220356905502e-01_wp , & .489955754557568e-01_wp , .480370318199712e-01_wp , & .469489888489122e-01_wp , .457343797161145e-01_wp , & .443964787957872e-01_wp , .429388928359356e-01_wp , & .413655512355848e-01_wp , .396806954523808e-01_wp , & .378888675692434e-01_wp , .359948980510845e-01_wp , & .340038927249464e-01_wp , .319212190192963e-01_wp , & .297524915007890e-01_wp , .275035567499248e-01_wp , & .251804776215213e-01_wp , .227895169439978e-01_wp , & .203371207294572e-01_wp , .178299010142074e-01_wp , & .152746185967848e-01_wp , .126781664768159e-01_wp , & .100475571822880e-01_wp , .738993116334531e-02_wp , & .471272992695363e-02_wp , .202681196887362e-02_wp ] Id = 9 ! DLMF 13.4.4, integration up to C=12/X a1 = a - 1.0_wp b1 = b - a - 1.0_wp c = 12.0_wp/x hu0 = 0.0_wp do m = 10 , 100 , 5 hu1 = 0.0_wp g = 0.5_wp*c/m d = g do j = 1 , m s = 0.0_wp do k = 1 , 30 t1 = d + g*t(k) t2 = d - g*t(k) f1 = exp(-x*t1)*t1**a1*(1.0_wp+t1)**b1 f2 = exp(-x*t2)*t2**a1*(1.0_wp+t2)**b1 s = s + w(k)*(f1+f2) enddo hu1 = hu1 + s*g d = d + 2.0_wp*g enddo if ( abs(1.0_wp-hu0/hu1)<1.0e-9_wp ) exit hu0 = hu1 enddo call gamma2(a,ga) hu1 = hu1/ga ! DLMF 13.4.4 with substitution t=C/(1-u) ! integration u from 0 to 1, i.e. t from C=12/X to infinity do m = 2 , 10 , 2 hu2 = 0.0_wp g = 0.5_wp/m d = g do j = 1 , m s = 0.0_wp do k = 1 , 30 t1 = d + g*t(k) t2 = d - g*t(k) t3 = c/(1.0_wp-t1) t4 = c/(1.0_wp-t2) f1 = t3*t3/c*exp(-x*t3)*t3**a1*(1.0_wp+t3)**b1 f2 = t4*t4/c*exp(-x*t4)*t4**a1*(1.0_wp+t4)**b1 s = s + w(k)*(f1+f2) enddo hu2 = hu2 + s*g d = d + 2.0_wp*g enddo if ( abs(1.0_wp-hu0/hu2)<1.0e-9_wp ) exit hu0 = hu2 enddo call gamma2(a,ga) hu2 = hu2/ga Hu = hu1 + hu2 end subroutine chguit !***************************************************************************************** !> ! Compute the expansion coefficients of the ! prolate and oblate spheroidal functions ! and joining factors subroutine kmn(m,n,c,Cv,Kd,Df,Dn,Ck1,Ck2) integer :: m integer :: n real(wp) :: c integer :: Kd real(wp),dimension(200) :: Df real(wp),dimension(200) :: Dn real(wp) :: Ck1 real(wp) :: Ck2 real(wp) :: cs , Cv , dnp , g0 , gk0 , gk1 , gk2 , gk3 , & r , r1 , r2 , r3 , r4 , r5 , rk(200) , sa0 , sb0 , & su0 , sw , t , tp(200) , u(200) , v(200) , w(200) integer :: i , ip , j , k , l , nm , nm1 , nn nm = 25 + int(0.5_wp*(n-m)+c) nn = nm + m cs = c*c*Kd ip = 1 if ( n-m==2*int((n-m)/2) ) ip = 0 k = 0 do i = 1 , nn + 3 if ( ip==0 ) k = -2*(i-1) if ( ip==1 ) k = -(2*i-3) gk0 = 2.0_wp*m + k gk1 = (m+k)*(m+k+1.0_wp) gk2 = 2.0_wp*(m+k) - 1.0_wp gk3 = 2.0_wp*(m+k) + 3.0_wp u(i) = gk0*(gk0-1.0_wp)*cs/(gk2*(gk2+2.0_wp)) v(i) = gk1 - Cv + (2.0_wp*(gk1-m*m)-1.0_wp)*cs/(gk2*gk3) w(i) = (k+1.0_wp)*(k+2.0_wp)*cs/((gk2+2.0_wp)*gk3) enddo do k = 1 , m t = v(m+1) do l = 0 , m - k - 1 t = v(m-l) - w(m-l+1)*u(m-l)/t enddo rk(k) = -u(k)/t enddo r = 1.0_wp do k = 1 , m r = r*rk(k) Dn(k) = Df(1)*r enddo tp(nn) = v(nn+1) do k = nn - 1 , m + 1 , -1 tp(k) = v(k+1) - w(k+2)*u(k+1)/tp(k+1) if ( k>m+1 ) rk(k) = -u(k)/tp(k) enddo if ( m==0 ) dnp = Df(1) if ( m/=0 ) dnp = Dn(m) Dn(m+1) = (-1)**ip*dnp*cs/((2.0_wp*m-1.0_wp)*(2.0_wp*m+1.0-4.0_wp*ip)*tp(m+1)) do k = m + 2 , nn Dn(k) = rk(k)*Dn(k-1) enddo r1 = 1.0_wp do j = 1 , (n+m+ip)/2 r1 = r1*(j+0.5_wp*(n+m+ip)) enddo nm1 = (n-m)/2 r = 1.0_wp do j = 1 , 2*m + ip r = r*j enddo su0 = r*Df(1) sw = 0.0_wp do k = 2 , nm r = r*(m+k-1.0_wp)*(m+k+ip-1.5_wp)/(k-1.0_wp)/(k+ip-1.5_wp) su0 = su0 + r*Df(k) if ( k>nm1 .and. abs((su0-sw)/su0)<1.0e-14_wp ) exit sw = su0 enddo if ( Kd/=1 ) then r2 = 1.0_wp do j = 1 , m r2 = 2.0_wp*c*r2*j enddo r3 = 1.0_wp do j = 1 , (n-m-ip)/2 r3 = r3*j enddo sa0 = (2.0_wp*(m+ip)+1.0_wp)*r1/(2.0_wp**n*c**ip*r2*r3*Df(1)) Ck1 = sa0*su0 if ( Kd==-1 ) return endif r4 = 1.0_wp do j = 1 , (n-m-ip)/2 r4 = 4.0_wp*r4*j enddo r5 = 1.0_wp do j = 1 , m r5 = r5*(j+m)/c enddo g0 = Dn(m) if ( m==0 ) g0 = Df(1) sb0 = (ip+1.0_wp)*c**(ip+1)/(2.0_wp*ip*(m-2.0_wp)+1.0_wp)/(2.0_wp*m-1.0_wp) Ck2 = (-1)**ip*sb0*r4*r5*g0/r1*su0 end subroutine kmn !***************************************************************************************** !> ! Compute the zeros of Laguerre polynomial Ln(x) ! in the interval [0,∞], and the corresponding ! weighting coefficients for Gauss-Laguerre ! integration subroutine lagzo(n,x,w) integer,intent(in) :: n !! Order of the Laguerre polynomial real(wp),dimension(n),intent(out) :: x !! Zeros of the Laguerre polynomial real(wp),dimension(n),intent(out) :: w !! Corresponding weighting coefficients real(wp) :: f0 , f1 , fd , gd , hn , p , pd , pf , q , & wp_ , z , z0 integer :: i , it , j , k , nr integer,parameter :: max_iter = 40 hn = 1.0_wp/n pf = 0.0_wp pd = 0.0_wp do nr = 1 , n z = hn if ( nr>1 ) z = x(nr-1) + hn*nr**1.27_wp it = 0 do it = it + 1 z0 = z p = 1.0_wp do i = 1 , nr - 1 p = p*(z-x(i)) enddo f0 = 1.0_wp f1 = 1.0_wp - z do k = 2 , n pf = ((2.0_wp*k-1.0_wp-z)*f1-(k-1.0_wp)*f0)/k pd = k/z*(pf-f1) f0 = f1 f1 = pf enddo fd = pf/p q = 0.0_wp do i = 1 , nr - 1 wp_ = 1.0_wp do j = 1 , nr - 1 if ( j/=i ) wp_ = wp_*(z-x(j)) enddo q = q + wp_ enddo gd = (pd-q*fd)/p z = z - fd/gd if ( it<=max_iter .and. abs((z-z0)/z)>1.0e-15_wp ) cycle exit end do x(nr) = z w(nr) = 1.0_wp/(z*pd*pd) enddo end subroutine lagzo !***************************************************************************************** !> ! Compute parabolic cylinder function `Vv(x)` ! for large argument subroutine vvla(Va,x,Pv) real(wp),intent(in) :: x !! Argument real(wp),intent(in) :: Va !! Order real(wp),intent(out) :: Pv !! `Vv(x)` real(wp) :: a0 , dsl , gl , pdl , qe , r , x1 integer :: k real(wp),parameter :: eps = 1.0e-12_wp qe = exp(0.25_wp*x*x) a0 = abs(x)**(-Va-1.0_wp)*sqrt(2.0_wp/pi)*qe r = 1.0_wp Pv = 1.0_wp do k = 1 , 18 r = 0.5_wp*r*(2.0_wp*k+Va-1.0_wp)*(2.0_wp*k+Va)/(k*x*x) Pv = Pv + r if ( abs(r/Pv)<eps ) exit enddo Pv = a0*Pv if ( x<0.0_wp ) then x1 = -x call dvla(Va,x1,pdl) call gamma2(-Va,gl) dsl = sin(pi*Va)*sin(pi*Va) Pv = dsl*gl/pi*pdl - cos(pi*Va)*Pv endif end subroutine vvla !***************************************************************************************** !> ! Compute Bessel functions `Jv(z)`, `Yv(z)` and their ! derivatives for a complex argument subroutine cjyva(v,z,Vm,Cbj,Cdj,Cby,Cdy) real(wp),intent(in) :: v !! Order of `Jv(z)` and `Yv(z)` !! ( `v = n+v0`, `n = 0,1,2,...`, `0 ≤ v0 < 1 `) complex(wp),intent(in) :: z !! Complex argument integer,intent(out) :: Vm !! Highest order computed complex(wp),dimension(0:*),intent(out) :: Cbj !! `CBJ(n)` --- `Jn+v0(z)` complex(wp),dimension(0:*),intent(out) :: Cdj !! `CDJ(n)` --- `Jn+v0'(z)` complex(wp),dimension(0:*),intent(out) :: Cby !! `CBY(n)` --- `Yn+v0(z)` complex(wp),dimension(0:*),intent(out) :: Cdy !! `CDY(n)` --- `Yn+v0'(z)` real(wp) :: a0 , ga , gb , pv0 , pv1 , v0 , vg , vl , & vv , w0 , w1 , wa , ya0 , ya1 , yak complex(wp) :: ca , ca0 , cb , cck , cec , & cf , cf0 , cf1 , cf2 , cfac0 , cfac1 , cg0 , cg1 , & ch0 , ch1 , ch2 , ci , cju0 , cju1 , cjv0 , cjv1 , & cjvl , cp11 , cp12 , cp21 , cp22 , cpz , cqz , cr , & cr0 , cr1 , crp , crq , cs , cs0 , cs1 , csk , cyk , & cyl1 , cyl2 , cylk , cyv0 , cyv1 , z1 , z2 , zk integer :: j , k , k0 , l , lb , lb0 , m , n real(wp),parameter :: rp2 = 2.0_wp / pi ! 0.63661977236758d0 ci = (0.0_wp,1.0_wp) a0 = abs(z) z1 = z z2 = z*z n = int(v) v0 = v - n pv0 = pi*v0 pv1 = pi*(1.0_wp+v0) if ( a0<1.0e-100_wp ) then do k = 0 , n Cbj(k) = (0.0_wp,0.0_wp) Cdj(k) = (0.0_wp,0.0_wp) Cby(k) = -(1.0e+300_wp,0.0_wp) Cdy(k) = (1.0e+300_wp,0.0_wp) enddo if ( v0==0.0_wp ) then Cbj(0) = (1.0_wp,0.0_wp) Cdj(1) = (0.5_wp,0.0_wp) else Cdj(0) = (1.0e+300_wp,0.0_wp) endif Vm = v return endif lb0 = 0.0_wp if ( real(z,wp)<0.0_wp ) z1 = -z if ( a0<=12.0_wp ) then do l = 0 , 1 vl = v0 + l cjvl = (1.0_wp,0.0_wp) cr = (1.0_wp,0.0_wp) do k = 1 , 40 cr = -0.25_wp*cr*z2/(k*(k+vl)) cjvl = cjvl + cr if ( abs(cr)<abs(cjvl)*1.0e-15_wp ) exit enddo vg = 1.0_wp + vl call gamma2(vg,ga) ca = (0.5_wp*z1)**vl/ga if ( l==0 ) cjv0 = cjvl*ca if ( l==1 ) cjv1 = cjvl*ca enddo else k0 = 11 if ( a0>=35.0_wp ) k0 = 10 if ( a0>=50.0_wp ) k0 = 8 do j = 0 , 1 vv = 4.0_wp*(j+v0)*(j+v0) cpz = (1.0_wp,0.0_wp) crp = (1.0_wp,0.0_wp) do k = 1 , k0 crp = -0.78125e-2_wp*crp*(vv-(4.0_wp*k-3.0_wp)**2.0_wp) & *(vv-(4.0_wp*k-1.0_wp)**2.0_wp)/(k*(2.0_wp*k-1.0_wp)*z2) cpz = cpz + crp enddo cqz = (1.0_wp,0.0_wp) crq = (1.0_wp,0.0_wp) do k = 1 , k0 crq = -0.78125e-2_wp*crq*(vv-(4.0_wp*k-1.0_wp)**2.0_wp) & & *(vv-(4.0_wp*k+1.0_wp)**2.0_wp)/(k*(2.0_wp*k+1.0_wp)*z2) cqz = cqz + crq enddo cqz = 0.125_wp*(vv-1.0_wp)*cqz/z1 zk = z1 - (0.5_wp*(j+v0)+0.25_wp)*pi ca0 = sqrt(rp2/z1) cck = cos(zk) csk = sin(zk) if ( j==0 ) then cjv0 = ca0*(cpz*cck-cqz*csk) cyv0 = ca0*(cpz*csk+cqz*cck) elseif ( j==1 ) then cjv1 = ca0*(cpz*cck-cqz*csk) cyv1 = ca0*(cpz*csk+cqz*cck) endif enddo endif if ( a0<=12.0_wp ) then if ( v0/=0.0_wp ) then do l = 0 , 1 vl = v0 + l cjvl = (1.0_wp,0.0_wp) cr = (1.0_wp,0.0_wp) do k = 1 , 40 cr = -0.25_wp*cr*z2/(k*(k-vl)) cjvl = cjvl + cr if ( abs(cr)<abs(cjvl)*1.0e-15_wp ) exit enddo vg = 1.0_wp - vl call gamma2(vg,gb) cb = (2.0_wp/z1)**vl/gb if ( l==0 ) cju0 = cjvl*cb if ( l==1 ) cju1 = cjvl*cb enddo cyv0 = (cjv0*cos(pv0)-cju0)/sin(pv0) cyv1 = (cjv1*cos(pv1)-cju1)/sin(pv1) else cec = log(z1/2.0_wp) + gamma ! 0.5772156649015329 cs0 = (0.0_wp,0.0_wp) w0 = 0.0_wp cr0 = (1.0_wp,0.0_wp) do k = 1 , 30 w0 = w0 + 1.0_wp/k cr0 = -0.25_wp*cr0/(k*k)*z2 cs0 = cs0 + cr0*w0 enddo cyv0 = rp2*(cec*cjv0-cs0) cs1 = (1.0_wp,0.0_wp) w1 = 0.0_wp cr1 = (1.0_wp,0.0_wp) do k = 1 , 30 w1 = w1 + 1.0_wp/k cr1 = -0.25_wp*cr1/(k*(k+1))*z2 cs1 = cs1 + cr1*(2.0_wp*w1+1.0_wp/(k+1.0_wp)) enddo cyv1 = rp2*(cec*cjv1-1.0_wp/z1-0.25_wp*z1*cs1) endif endif if ( real(z,wp)<0.0_wp ) then cfac0 = exp(pv0*ci) cfac1 = exp(pv1*ci) if ( aimag(z)<0.0_wp ) then cyv0 = cfac0*cyv0 - 2.0_wp*ci*cos(pv0)*cjv0 cyv1 = cfac1*cyv1 - 2.0_wp*ci*cos(pv1)*cjv1 cjv0 = cjv0/cfac0 cjv1 = cjv1/cfac1 elseif ( aimag(z)>0.0_wp ) then cyv0 = cyv0/cfac0 + 2.0_wp*ci*cos(pv0)*cjv0 cyv1 = cyv1/cfac1 + 2.0_wp*ci*cos(pv1)*cjv1 cjv0 = cfac0*cjv0 cjv1 = cfac1*cjv1 endif endif Cbj(0) = cjv0 Cbj(1) = cjv1 if ( n>=2 .and. n<=int(0.25_wp*a0) ) then cf0 = cjv0 cf1 = cjv1 do k = 2 , n cf = 2.0_wp*(k+v0-1.0_wp)/z*cf1 - cf0 Cbj(k) = cf cf0 = cf1 cf1 = cf enddo elseif ( n>=2 ) then m = msta1(a0,200) if ( m<n ) then n = m else m = msta2(a0,n,15) endif cf2 = (0.0_wp,0.0_wp) cf1 = (1.0e-100_wp,0.0_wp) do k = m , 0 , -1 cf = 2.0_wp*(v0+k+1.0_wp)/z*cf1 - cf2 if ( k<=n ) Cbj(k) = cf cf2 = cf1 cf1 = cf enddo if ( abs(cjv0)>abs(cjv1) ) cs = cjv0/cf if ( abs(cjv0)<=abs(cjv1) ) cs = cjv1/cf2 do k = 0 , n Cbj(k) = cs*Cbj(k) enddo endif Cdj(0) = v0/z*Cbj(0) - Cbj(1) do k = 1 , n Cdj(k) = -(k+v0)/z*Cbj(k) + Cbj(k-1) enddo Cby(0) = cyv0 Cby(1) = cyv1 ya0 = abs(cyv0) lb = 0 cg0 = cyv0 cg1 = cyv1 do k = 2 , n cyk = 2.0_wp*(v0+k-1.0_wp)/z*cg1 - cg0 if ( abs(cyk)<=1.0e+290_wp ) then yak = abs(cyk) ya1 = abs(cg0) if ( yak<ya0 .and. yak<ya1 ) lb = k Cby(k) = cyk cg0 = cg1 cg1 = cyk endif enddo if ( lb>4 .and. aimag(z)/=0.0_wp ) then do if ( lb/=lb0 ) then ch2 = (1.0_wp,0.0_wp) ch1 = (0.0_wp,0.0_wp) lb0 = lb do k = lb , 1 , -1 ch0 = 2.0_wp*(k+v0)/z*ch1 - ch2 ch2 = ch1 ch1 = ch0 enddo cp12 = ch0 cp22 = ch2 ch2 = (0.0_wp,0.0_wp) ch1 = (1.0_wp,0.0_wp) do k = lb , 1 , -1 ch0 = 2.0_wp*(k+v0)/z*ch1 - ch2 ch2 = ch1 ch1 = ch0 enddo cp11 = ch0 cp21 = ch2 if ( lb==n ) Cbj(lb+1) = 2.0_wp*(lb+v0)/z*Cbj(lb) - Cbj(lb-1) if ( abs(Cbj(0))>abs(Cbj(1)) ) then Cby(lb+1) = (Cbj(lb+1)*cyv0-2.0_wp*cp11/(pi*z))/Cbj(0) Cby(lb) = (Cbj(lb)*cyv0+2.0_wp*cp12/(pi*z))/Cbj(0) else Cby(lb+1) = (Cbj(lb+1)*cyv1-2.0_wp*cp21/(pi*z))/Cbj(1) Cby(lb) = (Cbj(lb)*cyv1+2.0_wp*cp22/(pi*z))/Cbj(1) endif cyl2 = Cby(lb+1) cyl1 = Cby(lb) do k = lb - 1 , 0 , -1 cylk = 2.0_wp*(k+v0+1.0_wp)/z*cyl1 - cyl2 Cby(k) = cylk cyl2 = cyl1 cyl1 = cylk enddo cyl1 = Cby(lb) cyl2 = Cby(lb+1) do k = lb + 1 , n - 1 cylk = 2.0_wp*(k+v0)/z*cyl2 - cyl1 Cby(k+1) = cylk cyl1 = cyl2 cyl2 = cylk enddo do k = 2 , n wa = abs(Cby(k)) if ( wa<abs(Cby(k-1)) ) lb = k enddo else exit endif end do endif Cdy(0) = v0/z*Cby(0) - Cby(1) do k = 1 , n Cdy(k) = Cby(k-1) - (k+v0)/z*Cby(k) enddo Vm = n + v0 end subroutine cjyva !***************************************************************************************** !> ! Compute Bessel functions Jv(z), Yv(z) and their ! derivatives for a complex argument subroutine cjyvb(v,z,Vm,Cbj,Cdj,Cby,Cdy) ! Input : z --- Complex argument ! v --- Order of Jv(z) and Yv(z) ! ( v = n+v0, n = 0,1,2,..., 0 ≤ v0 < 1 ) ! Output: CBJ(n) --- Jn+v0(z) ! CDJ(n) --- Jn+v0'(z) ! CBY(n) --- Yn+v0(z) ! CDY(n) --- Yn+v0'(z) ! VM --- Highest order computed real(wp) a0 , ga , gb , pv0 , rp2 , v , v0 , vg , & & Vm , vv , w0 complex(wp) ca , ca0 , cb , Cbj , Cby , cck , Cdj , Cdy , cec , & & cf , cf1 , cf2 , cfac0 , ci , cju0 , cjv0 , cjvn , & & cpz , cqz , cr complex(wp) cr0 , crp , crq , cs , cs0 , csk , cyv0 , cyy , z , & & z1 , z2 , zk integer k , k0 , m , n dimension Cbj(0:*) , Cdj(0:*) , Cby(0:*) , Cdy(0:*) rp2 = .63661977236758d0 ci = (0.0_wp,1.0_wp) a0 = abs(z) z1 = z z2 = z*z n = int(v) v0 = v - n pv0 = pi*v0 if ( a0<1.0e-100_wp ) then do k = 0 , n Cbj(k) = (0.0_wp,0.0_wp) Cdj(k) = (0.0_wp,0.0_wp) Cby(k) = -(1.0e+300_wp,0.0_wp) Cdy(k) = (1.0e+300_wp,0.0_wp) enddo if ( v0==0.0_wp ) then Cbj(0) = (1.0_wp,0.0_wp) Cdj(1) = (0.5_wp,0.0_wp) else Cdj(0) = (1.0e+300_wp,0.0_wp) endif Vm = v return endif if ( real(z,wp)<0.0_wp ) z1 = -z if ( a0<=12.0_wp ) then cjv0 = (1.0_wp,0.0_wp) cr = (1.0_wp,0.0_wp) do k = 1 , 40 cr = -0.25_wp*cr*z2/(k*(k+v0)) cjv0 = cjv0 + cr if ( abs(cr)<abs(cjv0)*1.0e-15_wp ) exit enddo vg = 1.0_wp + v0 call gamma2(vg,ga) ca = (0.5_wp*z1)**v0/ga cjv0 = cjv0*ca else k0 = 11 if ( a0>=35.0_wp ) k0 = 10 if ( a0>=50.0_wp ) k0 = 8 vv = 4.0_wp*v0*v0 cpz = (1.0_wp,0.0_wp) crp = (1.0_wp,0.0_wp) do k = 1 , k0 crp = -0.78125d-2*crp*(vv-(4.0_wp*k-3.0_wp)**2.0_wp) & & *(vv-(4.0_wp*k-1.0_wp)**2.0_wp)/(k*(2.0_wp*k-1.0_wp)*z2) cpz = cpz + crp enddo cqz = (1.0_wp,0.0_wp) crq = (1.0_wp,0.0_wp) do k = 1 , k0 crq = -0.78125d-2*crq*(vv-(4.0_wp*k-1.0_wp)**2.0_wp) & & *(vv-(4.0_wp*k+1.0_wp)**2.0_wp)/(k*(2.0_wp*k+1.0_wp)*z2) cqz = cqz + crq enddo cqz = 0.125_wp*(vv-1.0_wp)*cqz/z1 zk = z1 - (0.5_wp*v0+0.25_wp)*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<=12.0_wp ) then if ( v0/=0.0_wp ) then cjvn = (1.0_wp,0.0_wp) cr = (1.0_wp,0.0_wp) do k = 1 , 40 cr = -0.25_wp*cr*z2/(k*(k-v0)) cjvn = cjvn + cr if ( abs(cr)<abs(cjvn)*1.0e-15_wp ) exit enddo vg = 1.0_wp - v0 call gamma2(vg,gb) cb = (2.0_wp/z1)**v0/gb cju0 = cjvn*cb cyv0 = (cjv0*cos(pv0)-cju0)/sin(pv0) else cec = log(z1/2.0_wp) + gamma cs0 = (0.0_wp,0.0_wp) w0 = 0.0_wp cr0 = (1.0_wp,0.0_wp) do k = 1 , 30 w0 = w0 + 1.0_wp/k cr0 = -0.25_wp*cr0/(k*k)*z2 cs0 = cs0 + cr0*w0 enddo cyv0 = rp2*(cec*cjv0-cs0) endif endif if ( n==0 ) n = 1 m = msta1(a0,200) if ( m<n ) then n = m else m = msta2(a0,n,15) endif cf2 = (0.0_wp,0.0_wp) cf1 = (1.0e-100_wp,0.0_wp) do k = m , 0 , -1 cf = 2.0_wp*(v0+k+1.0_wp)/z1*cf1 - cf2 if ( k<=n ) Cbj(k) = cf cf2 = cf1 cf1 = cf enddo cs = cjv0/cf do k = 0 , n Cbj(k) = cs*Cbj(k) enddo if ( real(z,wp)<0.0_wp ) then cfac0 = exp(pv0*ci) if ( aimag(z)<0.0_wp ) then cyv0 = cfac0*cyv0 - 2.0_wp*ci*cos(pv0)*cjv0 elseif ( aimag(z)>0.0_wp ) then cyv0 = cyv0/cfac0 + 2.0_wp*ci*cos(pv0)*cjv0 endif do k = 0 , n if ( aimag(z)<0.0_wp ) then Cbj(k) = exp(-pi*(k+v0)*ci)*Cbj(k) elseif ( aimag(z)>0.0_wp ) then Cbj(k) = exp(pi*(k+v0)*ci)*Cbj(k) endif enddo z1 = z1 endif Cby(0) = cyv0 do k = 1 , n cyy = (Cbj(k)*Cby(k-1)-2.0_wp/(pi*z))/Cbj(k-1) Cby(k) = cyy enddo Cdj(0) = v0/z*Cbj(0) - Cbj(1) do k = 1 , n Cdj(k) = -(k+v0)/z*Cbj(k) + Cbj(k-1) enddo Cdy(0) = v0/z*Cby(0) - Cby(1) do k = 1 , n Cdy(k) = Cby(k-1) - (k+v0)/z*Cby(k) enddo Vm = n + v0 end subroutine cjyvb !***************************************************************************************** !> ! Compute Bessel functions J0(x), J1(x), Y0(x), ! Y1(x), and their derivatives subroutine jy01a(x,Bj0,Dj0,Bj1,Dj1,By0,Dy0,By1,Dy1) ! Input : x --- Argument of Jn(x) & Yn(x) ( x ≥ 0 ) ! Output: BJ0 --- J0(x) ! DJ0 --- J0'(x) ! BJ1 --- J1(x) ! DJ1 --- J1'(x) ! BY0 --- Y0(x) ! DY0 --- Y0'(x) ! BY1 --- Y1(x) ! DY1 --- Y1'(x) real(wp) a , a1 , b , b1 , Bj0 , Bj1 , By0 , By1 , cs0 , & & cs1 , cu , Dj0 , Dj1 , Dy0 , Dy1 , ec , p0 , p1 ,& & q0 real(wp) q1 , r , r0 , r1 , rp2 , t1 , t2 , w0 , w1 , x , & & x2 integer k , k0 dimension a(12) , b(12) , a1(12) , b1(12) rp2 = 0.63661977236758d0 x2 = x*x if ( x==0.0_wp ) then Bj0 = 1.0_wp Bj1 = 0.0_wp Dj0 = 0.0_wp Dj1 = 0.5_wp By0 = -1.0e+300_wp By1 = -1.0e+300_wp Dy0 = 1.0e+300_wp Dy1 = 1.0e+300_wp return endif if ( x<=12.0d0 ) then Bj0 = 1.0_wp r = 1.0_wp do k = 1 , 30 r = -0.25_wp*r*x2/(k*k) Bj0 = Bj0 + r if ( abs(r)<abs(Bj0)*1.0e-15_wp ) exit enddo Bj1 = 1.0_wp r = 1.0_wp do k = 1 , 30 r = -0.25_wp*r*x2/(k*(k+1.0_wp)) Bj1 = Bj1 + r if ( abs(r)<abs(Bj1)*1.0e-15_wp ) exit enddo Bj1 = 0.5_wp*x*Bj1 ec = log(x/2.0_wp) + gamma cs0 = 0.0_wp w0 = 0.0_wp r0 = 1.0_wp do k = 1 , 30 w0 = w0 + 1.0_wp/k r0 = -0.25_wp*r0/(k*k)*x2 r = r0*w0 cs0 = cs0 + r if ( abs(r)<abs(cs0)*1.0e-15_wp ) exit enddo By0 = rp2*(ec*Bj0-cs0) cs1 = 1.0_wp w1 = 0.0_wp r1 = 1.0_wp do k = 1 , 30 w1 = w1 + 1.0_wp/k r1 = -0.25_wp*r1/(k*(k+1))*x2 r = r1*(2.0_wp*w1+1.0_wp/(k+1.0_wp)) cs1 = cs1 + r if ( abs(r)<abs(cs1)*1.0e-15_wp ) exit enddo By1 = rp2*(ec*Bj1-1.0_wp/x-0.25_wp*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>=35.0_wp ) k0 = 10 if ( x>=50.0_wp ) k0 = 8 t1 = x - 0.25_wp*pi p0 = 1.0_wp q0 = -0.125_wp/x do k = 1 , k0 p0 = p0 + a(k)*x**(-2*k) q0 = q0 + b(k)*x**(-2*k-1) enddo cu = sqrt(rp2/x) Bj0 = cu*(p0*cos(t1)-q0*sin(t1)) By0 = cu*(p0*sin(t1)+q0*cos(t1)) t2 = x - 0.75d0*pi p1 = 1.0_wp q1 = 0.375d0/x do k = 1 , k0 p1 = p1 + a1(k)*x**(-2*k) q1 = q1 + b1(k)*x**(-2*k-1) enddo cu = sqrt(rp2/x) Bj1 = cu*(p1*cos(t2)-q1*sin(t2)) By1 = cu*(p1*sin(t2)+q1*cos(t2)) endif Dj0 = -Bj1 Dj1 = Bj0 - Bj1/x Dy0 = -By1 Dy1 = By0 - By1/x end !***************************************************************************************** !> ! Compute the incomplete gamma function ! r(a,x), Г(a,x) and P(a,x) subroutine incog(a,x,Gin,Gim,Gip,Isfer) ! Input : a --- Parameter ( a ≤ 170 ) ! x --- Argument ! Output: GIN --- r(a,x) ! GIM --- Г(a,x) ! GIP --- P(a,x) ! ISFER --- Error flag real(wp) a , ga , Gim , Gin , Gip , r , s , t0 , x , xam integer Isfer , k Isfer = 0 xam = -x + a*log(x) if ( xam>700.0 .or. a>170.0_wp ) then Isfer = 6 return endif if ( x==0.0_wp ) then Gin = 0.0 call gamma2(a,ga) Gim = ga Gip = 0.0 elseif ( x<=1.0+a ) then s = 1.0_wp/a r = s do k = 1 , 60 r = r*x/(a+k) s = s + r if ( abs(r/s)<1.0e-15_wp ) exit enddo Gin = exp(xam)*s call gamma2(a,ga) Gip = Gin/ga Gim = ga - Gin elseif ( x>1.0+a ) then t0 = 0.0_wp do k = 60 , 1 , -1 t0 = (k-a)/(1.0_wp+k/(x+t0)) enddo Gim = exp(xam)/(x+t0) call gamma2(a,ga) Gin = ga - Gim Gip = 1.0_wp - Gim/ga endif end !***************************************************************************************** !> ! Integrate Bessel functions I0(t) and K0(t) ! with respect to t from 0 to x subroutine itikb(x,Ti,Tk) ! Input : x --- Upper limit of the integral ( x ≥ 0 ) ! Output: TI --- Integration of I0(t) from 0 to x ! TK --- Integration of K0(t) from 0 to x real(wp) t , t1 , Ti , Tk , x if ( x==0.0_wp ) then Ti = 0.0_wp elseif ( x<5.0_wp ) then t1 = x/5.0_wp 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.0_wp)*t1 elseif ( x>=5.0 .and. x<=8.0_wp ) then t = 5.0_wp/x Ti = (((-.015166d0*t-.0202292d0)*t+.1294122d0)*t-.0302912d0) & & *t + .4161224d0 Ti = Ti*exp(x)/sqrt(x) else t = 8.0_wp/x Ti = (((((-.0073995d0*t+.017744d0)*t-.0114858d0)*t+.55956d-2) & & *t+.59191d-2)*t+.0311734d0)*t + .3989423d0 Ti = Ti*exp(x)/sqrt(x) endif if ( x==0.0_wp ) then Tk = 0.0_wp elseif ( x<=2.0_wp ) then t1 = x/2.0_wp t = t1*t1 Tk = ((((((.116d-5*t+.2069d-4)*t+.62664d-3)*t+.01110118d0)*t+ & & .11227902d0)*t+.50407836d0)*t+.84556868d0)*t1 Tk = Tk - log(x/2.0_wp)*Ti elseif ( x>2.0 .and. x<=4.0_wp ) then t = 2.0_wp/x Tk = (((.0160395d0*t-.0781715d0)*t+.185984d0)*t-.3584641d0) & & *t + 1.2494934d0 Tk = pi/2.0_wp - Tk*exp(-x)/sqrt(x) elseif ( x>4.0 .and. x<=7.0_wp ) then t = 4.0_wp/x Tk = (((((.37128d-2*t-.0158449d0)*t+.0320504d0)*t-.0481455d0) & & *t+.0787284d0)*t-.1958273d0)*t + 1.2533141d0 Tk = pi/2.0_wp - Tk*exp(-x)/sqrt(x) else t = 7.0_wp/x Tk = (((((.33934d-3*t-.163271d-2)*t+.417454d-2)*t-.933944d-2) & & *t+.02576646d0)*t-.11190289d0)*t + 1.25331414d0 Tk = pi/2.0_wp - Tk*exp(-x)/sqrt(x) endif end !***************************************************************************************** !> ! Integrate modified Bessel functions I0(t) and ! K0(t) with respect to t from 0 to x subroutine itika(x,Ti,Tk) ! Input : x --- Upper limit of the integral ( x ≥ 0 ) ! Output: TI --- Integration of I0(t) from 0 to x ! TK --- Integration of K0(t) from 0 to x real(wp) a , b1 , b2 , e0 , r , rc1 , rc2 , rs ,& & Ti , Tk , tw , x , x2 integer k dimension a(10) 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==0.0_wp ) then Ti = 0.0_wp Tk = 0.0_wp return elseif ( x<20.0_wp ) then x2 = x*x Ti = 1.0_wp r = 1.0_wp do k = 1 , 50 r = .25_wp*r*(2*k-1.0_wp)/(2*k+1.0_wp)/(k*k)*x2 Ti = Ti + r if ( abs(r/Ti)<1.0e-12_wp ) exit enddo Ti = Ti*x else x2 = 0.0_wp Ti = 1.0_wp r = 1.0_wp do k = 1 , 10 r = r/x Ti = Ti + a(k)*r enddo rc1 = 1.0_wp/sqrt(twopi*x) Ti = rc1*exp(x)*Ti endif if ( x<12.0d0 ) then e0 = gamma + log(x/2.0_wp) b1 = 1.0_wp - e0 b2 = 0.0_wp rs = 0.0_wp r = 1.0_wp tw = 0.0_wp do k = 1 , 50 r = .25_wp*r*(2*k-1.0_wp)/(2*k+1.0_wp)/(k*k)*x2 b1 = b1 + r*(1.0_wp/(2*k+1)-e0) rs = rs + 1.0_wp/k b2 = b2 + r*rs Tk = b1 + b2 if ( abs((Tk-tw)/Tk)<1.0e-12_wp ) exit tw = Tk enddo Tk = Tk*x else Tk = 1.0_wp r = 1.0_wp do k = 1 , 10 r = -r/x Tk = Tk + a(k)*r enddo rc2 = sqrt(pi/(2.0_wp*x)) Tk = pi/2.0_wp - rc2*Tk*exp(-x) endif end !***************************************************************************************** !> ! Compute Bessel functions Jv(x) and Yv(x) ! and their derivatives subroutine jyv(v,x,Vm,Bj,Dj,By,Dy) ! Input : x --- Argument of Jv(x) and Yv(x) ! v --- Order of Jv(x) and Yv(x) ! ( v = n+v0, 0 ≤ v0 < 1, n = 0,1,2,... ) ! Output: BJ(n) --- Jn+v0(x) ! DJ(n) --- Jn+v0'(x) ! BY(n) --- Yn+v0(x) ! DY(n) --- Yn+v0'(x) ! VM --- Highest order computed real(wp) a , a0 , b , Bj , bju0 , bju1 , bjv0 , bjv1 , & & bjvl , By , byv0 , byv1 , byvk , ck , cs , cs0 , & & cs1 , Dj , Dy , ec real(wp) f , f0 , f1 , f2 , ga , gb , pv0 , & & pv1 , px , qx , r , r0 , r1 , rp , rp2 , rq , & & sk , v real(wp) v0 , vg , vl , Vm , vv , w0 , w1 , x , x2 , xk integer j , k , k0 , l , m , n dimension Bj(0:*) , Dj(0:*) , By(0:*) , Dy(0:*) rp2 = .63661977236758d0 x2 = x*x n = int(v) v0 = v - n if ( x<1.0e-100_wp ) then do k = 0 , n Bj(k) = 0.0_wp Dj(k) = 0.0_wp By(k) = -1.0e+300_wp Dy(k) = 1.0e+300_wp enddo if ( v0==0.0_wp ) then Bj(0) = 1.0_wp Dj(1) = 0.5_wp else Dj(0) = 1.0e+300_wp endif Vm = v return endif bjv0 = 0.0_wp bjv1 = 0.0_wp byv0 = 0.0_wp byv1 = 0.0_wp if ( x<=12.0_wp ) then do l = 0 , 1 vl = v0 + l bjvl = 1.0_wp r = 1.0_wp do k = 1 , 40 r = -0.25_wp*r*x2/(k*(k+vl)) bjvl = bjvl + r if ( abs(r)<abs(bjvl)*1.0e-15_wp ) exit enddo vg = 1.0_wp + vl call gamma2(vg,ga) a = (0.5_wp*x)**vl/ga if ( l==0 ) bjv0 = bjvl*a if ( l==1 ) bjv1 = bjvl*a enddo else k0 = 11 if ( x>=35.0_wp ) k0 = 10 if ( x>=50.0_wp ) k0 = 8 do j = 0 , 1 vv = 4.0_wp*(j+v0)*(j+v0) px = 1.0_wp rp = 1.0_wp do k = 1 , k0 rp = -0.78125d-2*rp*(vv-(4.0_wp*k-3.0_wp)**2.0_wp) & & *(vv-(4.0_wp*k-1.0_wp)**2.0_wp)/(k*(2.0_wp*k-1.0_wp)*x2) px = px + rp enddo qx = 1.0_wp rq = 1.0_wp do k = 1 , k0 rq = -0.78125d-2*rq*(vv-(4.0_wp*k-1.0_wp)**2.0_wp) & & *(vv-(4.0_wp*k+1.0_wp)**2.0_wp)/(k*(2.0_wp*k+1.0_wp)*x2) qx = qx + rq enddo qx = 0.125_wp*(vv-1.0_wp)*qx/x xk = x - (0.5_wp*(j+v0)+0.25_wp)*pi a0 = sqrt(rp2/x) ck = cos(xk) sk = sin(xk) if ( j==0 ) then bjv0 = a0*(px*ck-qx*sk) byv0 = a0*(px*sk+qx*ck) elseif ( j==1 ) then bjv1 = a0*(px*ck-qx*sk) byv1 = a0*(px*sk+qx*ck) endif enddo endif Bj(0) = bjv0 Bj(1) = bjv1 Dj(0) = v0/x*Bj(0) - Bj(1) Dj(1) = -(1.0_wp+v0)/x*Bj(1) + Bj(0) if ( n>=2 .and. n<=int(0.9*x) ) then f0 = bjv0 f1 = bjv1 do k = 2 , n f = 2.0_wp*(k+v0-1.0_wp)/x*f1 - f0 Bj(k) = f f0 = f1 f1 = f enddo elseif ( n>=2 ) then m = msta1(x,200) if ( m<n ) then n = m else m = msta2(x,n,15) endif f = 0.0_wp f2 = 0.0_wp f1 = 1.0e-100_wp do k = m , 0 , -1 f = 2.0_wp*(v0+k+1.0_wp)/x*f1 - f2 if ( k<=n ) Bj(k) = f f2 = f1 f1 = f enddo if ( abs(bjv0)>abs(bjv1) ) then cs = bjv0/f else cs = bjv1/f2 endif do k = 0 , n Bj(k) = cs*Bj(k) enddo endif do k = 2 , n Dj(k) = -(k+v0)/x*Bj(k) + Bj(k-1) enddo if ( x<=12.0d0 ) then if ( v0/=0.0_wp ) then bju0 = 0.0_wp bju1 = 0.0_wp do l = 0 , 1 vl = v0 + l bjvl = 1.0_wp r = 1.0_wp do k = 1 , 40 r = -0.25_wp*r*x2/(k*(k-vl)) bjvl = bjvl + r if ( abs(r)<abs(bjvl)*1.0e-15_wp ) exit enddo vg = 1.0_wp - vl call gamma2(vg,gb) b = (2.0_wp/x)**vl/gb if ( l==0 ) bju0 = bjvl*b if ( l==1 ) bju1 = bjvl*b enddo pv0 = pi*v0 pv1 = pi*(1.0_wp+v0) byv0 = (bjv0*cos(pv0)-bju0)/sin(pv0) byv1 = (bjv1*cos(pv1)-bju1)/sin(pv1) else ec = log(x/2.0_wp) + gamma cs0 = 0.0_wp w0 = 0.0_wp r0 = 1.0_wp do k = 1 , 30 w0 = w0 + 1.0_wp/k r0 = -0.25_wp*r0/(k*k)*x2 cs0 = cs0 + r0*w0 enddo byv0 = rp2*(ec*bjv0-cs0) cs1 = 1.0_wp w1 = 0.0_wp r1 = 1.0_wp do k = 1 , 30 w1 = w1 + 1.0_wp/k r1 = -0.25_wp*r1/(k*(k+1))*x2 cs1 = cs1 + r1*(2.0_wp*w1+1.0_wp/(k+1.0_wp)) enddo byv1 = rp2*(ec*bjv1-1.0_wp/x-0.25_wp*x*cs1) endif endif By(0) = byv0 By(1) = byv1 do k = 2 , n byvk = 2.0_wp*(v0+k-1.0_wp)/x*byv1 - byv0 By(k) = byvk byv0 = byv1 byv1 = byvk enddo Dy(0) = v0/x*By(0) - By(1) do k = 1 , n Dy(k) = -(k+v0)/x*By(k) + By(k-1) enddo Vm = n + v0 end !***************************************************************************************** !> ! Compute Bessel functions Jn(x), Yn(x) and ! their derivatives subroutine jynb(n,x,Nm,Bj,Dj,By,Dy) ! Input : x --- Argument of Jn(x) and Yn(x) ( x ≥ 0 ) ! n --- Order of Jn(x) and Yn(x) ! Output: BJ(n) --- Jn(x) ! DJ(n) --- Jn'(x) ! BY(n) --- Yn(x) ! DY(n) --- Yn'(x) ! NM --- Highest order computed ! Routines called: ! JYNBH to calculate the Jn and Yn real(wp) Bj , By , Dj , Dy , x integer k , n , Nm dimension Bj(0:n) , Dj(0:n) , By(0:n) , Dy(0:n) call jynbh(n,0,x,Nm,Bj,By) ! Compute derivatives by differentiation formulas if ( x<1.0e-100_wp ) then do k = 0 , n Dj(k) = 0.0_wp Dy(k) = 1.0e+300_wp enddo Dj(1) = 0.5_wp else Dj(0) = -Bj(1) do k = 1 , Nm Dj(k) = Bj(k-1) - k/x*Bj(k) enddo Dy(0) = -By(1) do k = 1 , Nm Dy(k) = By(k-1) - k*By(k)/x enddo endif end !***************************************************************************************** !> ! Compute Bessel functions Jn(x), Yn(x) subroutine jynbh(n,Nmin,x,Nm,Bj,By) ! Input : x --- Argument of Jn(x) and Yn(x) ( x ≥ 0 ) ! n --- Highest order of Jn(x) and Yn(x) computed ( n ≥ 0 ) ! nmin -- Lowest order computed ( nmin ≥ 0 ) ! Output: BJ(n-NMIN) --- Jn(x) ; if indexing starts at 0 ! BY(n-NMIN) --- Yn(x) ; if indexing starts at 0 ! NM --- Highest order computed real(wp) a , a1 , b , b1 , Bj , bj0 , bj1 , bjk , bs , & & By , by0 , by1 , byk , cu , ec , f , f1 , f2 , & & p0 , p1 real(wp) q0 , q1 , r2p , s0 , su , sv , t1 , t2 , x integer k , ky , m , n , Nm , Nmin dimension Bj(0:n-Nmin) , By(0:n-Nmin) , a(4) , b(4) , a1(4) , & & b1(4) r2p = .63661977236758d0 Nm = n if ( x<1.0e-100_wp ) then do k = Nmin , n Bj(k-Nmin) = 0.0_wp By(k-Nmin) = -1.0e+300_wp enddo if ( Nmin==0 ) Bj(0) = 1.0_wp return endif if ( x<=300.0 .or. n>int(0.9*x) ) then ! Backward recurrence for Jn if ( n==0 ) Nm = 1 m = msta1(x,200) if ( m<Nm ) then Nm = m else m = msta2(x,Nm,15) endif bs = 0.0_wp su = 0.0_wp sv = 0.0_wp f2 = 0.0_wp f1 = 1.0e-100_wp f = 0.0_wp do k = m , 0 , -1 f = 2.0_wp*(k+1.0_wp)/x*f1 - f2 if ( k<=Nm .and. k>=Nmin ) Bj(k-Nmin) = f if ( k==2*int(k/2) .and. k/=0 ) then bs = bs + 2.0_wp*f su = su + (-1)**(k/2)*f/k elseif ( k>1 ) then sv = sv + (-1)**(k/2)*k/(k*k-1.0_wp)*f endif f2 = f1 f1 = f enddo s0 = bs + f do k = Nmin , Nm Bj(k-Nmin) = Bj(k-Nmin)/s0 enddo ! Estimates for Yn at start of recurrence bj0 = f1/s0 bj1 = f2/s0 ec = log(x/2.0_wp) + gamma by0 = r2p*(ec*bj0-4.0_wp*su/s0) by1 = r2p*((ec-1.0_wp)*bj1-bj0/x-4.0_wp*sv/s0) if ( 0>=Nmin ) By(0-Nmin) = by0 if ( 1>=Nmin ) By(1-Nmin) = by1 ky = 2 else ! 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.25_wp*pi p0 = 1.0_wp q0 = -0.125_wp/x do k = 1 , 4 p0 = p0 + a(k)*x**(-2*k) q0 = q0 + b(k)*x**(-2*k-1) enddo cu = sqrt(r2p/x) bj0 = cu*(p0*cos(t1)-q0*sin(t1)) by0 = cu*(p0*sin(t1)+q0*cos(t1)) if ( 0>=Nmin ) Bj(0-Nmin) = bj0 if ( 0>=Nmin ) By(0-Nmin) = by0 t2 = x - 0.75d0*pi p1 = 1.0_wp q1 = 0.375d0/x do k = 1 , 4 p1 = p1 + a1(k)*x**(-2*k) q1 = q1 + b1(k)*x**(-2*k-1) enddo bj1 = cu*(p1*cos(t2)-q1*sin(t2)) by1 = cu*(p1*sin(t2)+q1*cos(t2)) if ( 1>=Nmin ) Bj(1-Nmin) = bj1 if ( 1>=Nmin ) By(1-Nmin) = by1 do k = 2 , Nm bjk = 2.0_wp*(k-1.0_wp)/x*bj1 - bj0 if ( k>=Nmin ) Bj(k-Nmin) = bjk bj0 = bj1 bj1 = bjk enddo ky = 2 endif ! Forward recurrence for Yn do k = ky , Nm byk = 2.0_wp*(k-1.0_wp)*by1/x - by0 if ( k>=Nmin ) By(k-Nmin) = byk by0 = by1 by1 = byk enddo end !***************************************************************************************** !> ! Compute the zeros of Legendre polynomial Pn(x) ! in the interval [-1,1], and the corresponding ! weighting coefficients for Gauss-Legendre ! integration subroutine legzo(n,x,w) ! Input : n --- Order of the Legendre polynomial ! Output: X(n) --- Zeros of the Legendre polynomial ! W(n) --- Corresponding weighting coefficients real(wp) f0 , f1 , fd , gd , p , pd , pf , q , w , wp_ , & & x , z , z0 integer i , j , k , n , n0 , nr dimension x(n) , w(n) n0 = (n+1)/2 pf = 0.0_wp pd = 0.0_wp do nr = 1 , n0 z = cos(3.1415926d0*(nr-0.25_wp)/n) 50 z0 = z p = 1.0_wp do i = 1 , nr - 1 p = p*(z-x(i)) enddo f0 = 1.0_wp if ( nr==n0 .and. n/=2*int(n/2) ) z = 0.0_wp f1 = z do k = 2 , n pf = (2.0_wp-1.0_wp/k)*z*f1 - (1.0_wp-1.0_wp/k)*f0 pd = k*(f1-z*pf)/(1.0_wp-z*z) f0 = f1 f1 = pf enddo if ( z/=0.0_wp ) then fd = pf/p q = 0.0_wp do i = 1 , nr wp_ = 1.0_wp do j = 1 , nr if ( j/=i ) wp_ = wp_*(z-x(j)) enddo q = q + wp_ enddo gd = (pd-q*fd)/p z = z - fd/gd if ( abs(z-z0)>abs(z)*1.0e-15_wp ) goto 50 endif x(nr) = z x(n+1-nr) = -z w(nr) = 2.0_wp/((1.0_wp-z*z)*pd*pd) w(n+1-nr) = w(nr) enddo end !***************************************************************************************** !> ! Compute the prolate and oblate spheroidal angular ! functions of the first kind and their derivatives subroutine aswfa(m,n,c,x,Kd,Cv,S1f,S1d) ! Input : m --- Mode parameter, m = 0,1,2,... ! n --- Mode parameter, n = m,m+1,... ! c --- Spheroidal parameter ! x --- Argument of angular function, |x| < 1.0 ! KD --- Function code ! KD=1 for prolate; KD=-1 for oblate ! cv --- Characteristic value ! Output: S1F --- Angular function of the first kind ! S1D --- Derivative of the angular function of ! the first kind real(wp) a0 , c , ck , Cv , d0 , d1 , df , r , S1d ,& & S1f , su1 , su2 , x , x0 , x1 integer ip , k , Kd , m , n , nm , nm2 dimension ck(200) , df(200) real(wp),parameter :: eps = 1.0e-14_wp x0 = x x = abs(x) ip = 1 if ( n-m==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.0_wp - x*x if ( m==0 .and. x1==0.0_wp ) then a0 = 1.0_wp else a0 = x1**(0.5_wp*m) endif su1 = ck(1) do k = 1 , nm2 r = ck(k+1)*x1**k su1 = su1 + r if ( k>=10 .and. abs(r/su1)<eps ) exit enddo S1f = a0*x**ip*su1 if ( x==1.0_wp ) then if ( m==0 ) S1d = ip*ck(1) - 2.0_wp*ck(2) if ( m==1 ) S1d = -1.0d+100 if ( m==2 ) S1d = -2.0_wp*ck(1) if ( m>=3 ) S1d = 0.0_wp else d0 = ip - m/x1*x**(ip+1.0_wp) d1 = -2.0_wp*a0*x**(ip+1.0_wp) su2 = ck(2) do k = 2 , nm2 r = k*ck(k+1)*x1**(k-1.0_wp) su2 = su2 + r if ( k>=10 .and. abs(r/su2)<eps ) exit enddo S1d = d0*a0*su1 + d1*su2 endif if ( x0<0.0_wp .and. ip==0 ) S1d = -S1d if ( x0<0.0_wp .and. ip==1 ) S1f = -S1f x = x0 end !***************************************************************************************** !> ! Compute Bessel functions Jn(x) & Yn(x) and ! their derivatives subroutine jyna(n,x,Nm,Bj,Dj,By,Dy) ! Input : x --- Argument of Jn(x) & Yn(x) ( x ≥ 0 ) ! n --- Order of Jn(x) & Yn(x) ! Output: BJ(n) --- Jn(x) ! DJ(n) --- Jn'(x) ! BY(n) --- Yn(x) ! DY(n) --- Yn'(x) ! NM --- Highest order computed real(wp) Bj , bj0 , bj1 , bjk , By , by0 , by1 , cs , Dj ,& & dj0 , dj1 , Dy , dy0 , dy1 , f , f0 , f1 , f2 , x integer k , m , n , Nm dimension Bj(0:n) , By(0:n) , Dj(0:n) , Dy(0:n) Nm = n if ( x<1.0e-100_wp ) then do k = 0 , n Bj(k) = 0.0_wp Dj(k) = 0.0_wp By(k) = -1.0e+300_wp Dy(k) = 1.0e+300_wp enddo Bj(0) = 1.0_wp Dj(1) = 0.5_wp 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<=1 ) return if ( n<int(0.9*x) ) then do k = 2 , n bjk = 2.0_wp*(k-1.0_wp)/x*bj1 - bj0 Bj(k) = bjk bj0 = bj1 bj1 = bjk enddo else m = msta1(x,200) if ( m<n ) then Nm = m else m = msta2(x,n,15) endif f2 = 0.0_wp f1 = 1.0e-100_wp f = 0.0_wp do k = m , 0 , -1 f = 2.0_wp*(k+1.0_wp)/x*f1 - f2 if ( k<=Nm ) Bj(k) = f f2 = f1 f1 = f enddo if ( abs(bj0)>abs(bj1) ) then cs = bj0/f else cs = bj1/f2 endif do k = 0 , Nm Bj(k) = cs*Bj(k) enddo endif do k = 2 , Nm Dj(k) = Bj(k-1) - k/x*Bj(k) enddo f0 = By(0) f1 = By(1) do k = 2 , Nm f = 2.0_wp*(k-1.0_wp)/x*f1 - f0 By(k) = f f0 = f1 f1 = f enddo do k = 2 , Nm Dy(k) = By(k-1) - k*By(k)/x enddo end !***************************************************************************************** !> ! Compute parabolic cylinder functions Dv(x) ! and their derivatives subroutine pbdv(v,x,Dv,Dp,Pdf,Pdd) ! Input: x --- Argument of Dv(x) ! v --- Order of Dv(x) ! Output: DV(na) --- Dn+v0(x) ! DP(na) --- Dn+v0'(x) ! ( na = |n|, v0 = v-n, |v0| < 1, ! n = 0,±1,±2,… ) ! PDF --- Dv(x) ! PDD --- Dv'(x) real(wp) Dp , Dv , ep , f , f0 , f1 , pd , pd0 , pd1 , & & Pdd , Pdf , s0 , v , v0 , v1 , v2 , vh , x , xa integer ja , k , l , m , na , nk , nv dimension Dv(0:*) , Dp(0:*) xa = abs(x) vh = v v = v + sign(1.0_wp,v) nv = int(v) v0 = v - nv na = abs(nv) ep = exp(-0.25_wp*x*x) ja = 0 if ( na>=1 ) ja = 1 if ( v>=0.0_wp ) then if ( v0==0.0_wp ) then pd0 = ep pd1 = x*ep else do l = 0 , ja v1 = v0 + l if ( xa<=5.8 ) call dvsa(v1,x,pd1) if ( xa>5.8 ) call dvla(v1,x,pd1) if ( l==0 ) pd0 = pd1 enddo endif Dv(0) = pd0 Dv(1) = pd1 do k = 2 , na Pdf = x*pd1 - (k+v0-1.0_wp)*pd0 Dv(k) = Pdf pd0 = pd1 pd1 = Pdf enddo elseif ( x<=0.0_wp ) then if ( xa<=5.8d0 ) then call dvsa(v0,x,pd0) v1 = v0 - 1.0_wp call dvsa(v1,x,pd1) else call dvla(v0,x,pd0) v1 = v0 - 1.0_wp call dvla(v1,x,pd1) endif Dv(0) = pd0 Dv(1) = pd1 do k = 2 , na pd = (-x*pd1+pd0)/(k-1.0_wp-v0) Dv(k) = pd pd0 = pd1 pd1 = pd enddo elseif ( x<=2.0_wp ) then v2 = nv + v0 if ( nv==0 ) v2 = v2 - 1.0_wp nk = int(-v2) call dvsa(v2,x,f1) v1 = v2 + 1.0_wp call dvsa(v1,x,f0) Dv(nk) = f1 Dv(nk-1) = f0 do k = nk - 2 , 0 , -1 f = x*f0 + (k-v0+1.0_wp)*f1 Dv(k) = f f1 = f0 f0 = f enddo else if ( xa<=5.8 ) call dvsa(v0,x,pd0) if ( xa>5.8 ) call dvla(v0,x,pd0) Dv(0) = pd0 m = 100 + na f1 = 0.0_wp f0 = 1.0d-30 f = 0.0_wp do k = m , 0 , -1 f = x*f0 + (k-v0+1.0_wp)*f1 if ( k<=na ) Dv(k) = f f1 = f0 f0 = f enddo s0 = pd0/f do k = 0 , na Dv(k) = s0*Dv(k) enddo endif do k = 0 , na - 1 v1 = abs(v0) + k if ( v>=0.0_wp ) then Dp(k) = 0.5_wp*x*Dv(k) - Dv(k+1) else Dp(k) = -0.5_wp*x*Dv(k) - v1*Dv(k+1) endif enddo Pdf = Dv(na-1) Pdd = Dp(na-1) v = vh end !***************************************************************************************** !> ! Evaluate the integral of Struve function ! H0(t) with respect to t from 0 and x subroutine itsh0(x,Th0) ! Input : x --- Upper limit ( x ≥ 0 ) ! Output: TH0 --- Integration of H0(t) from 0 and x real(wp) a , a0 , a1 , af , bf , bg , r , rd , & & s , s0 , Th0 , ty , x , xp integer k dimension a(25) r = 1.0_wp if ( x<=30.0_wp ) then s = 0.5_wp do k = 1 , 100 rd = 1.0_wp if ( k==1 ) rd = 0.5_wp r = -r*rd*k/(k+1.0_wp)*(x/(2.0_wp*k+1.0_wp))**2 s = s + r if ( abs(r)<abs(s)*1.0e-12_wp ) exit enddo Th0 = 2.0_wp/pi*x*x*s else s = 1.0_wp do k = 1 , 12 r = -r*k/(k+1.0_wp)*((2.0_wp*k+1.0_wp)/x)**2 s = s + r if ( abs(r)<abs(s)*1.0e-12_wp ) exit enddo s0 = s/(pi*x*x) + 2.0_wp/pi*(log(2.0_wp*x)+gamma) a0 = 1.0_wp a1 = 5.0_wp/8.0_wp a(1) = a1 do k = 1 , 20 af = ((1.5_wp*(k+0.5_wp)*(k+5.0_wp/6.0_wp)*a1-0.5_wp*(k+0.5_wp) & & *(k+0.5_wp)*(k-0.5_wp)*a0))/(k+1.0_wp) a(k+1) = af a0 = a1 a1 = af enddo bf = 1.0_wp r = 1.0_wp do k = 1 , 10 r = -r/(x*x) bf = bf + a(2*k)*r enddo bg = a(1)/x r = 1.0_wp/x do k = 1 , 10 r = -r/(x*x) bg = bg + a(2*k+1)*r enddo xp = x + .25_wp*pi ty = sqrt(2.0_wp/(pi*x))*(bg*cos(xp)-bf*sin(xp)) Th0 = ty + s0 endif end !***************************************************************************************** !> ! Evaluate the complex zeros of error function erf(z) ! using the modified Newton's iteration method subroutine cerzo(Nt,Zo) ! Input : NT --- Total number of zeros ! Output: ZO(L) --- L-th zero of erf(z), L=1,2,...,NT integer i , it , j , nr , Nt real(wp) pu , pv , px , py , w , w0 complex(wp) z , zd , zf , zfd , zgd , Zo , zp , zq , zw dimension Zo(Nt) w = 0.0_wp do nr = 1 , Nt pu = sqrt(pi*(4.0_wp*nr-0.5_wp)) pv = pi*sqrt(2.0_wp*nr-0.25_wp) px = 0.5*pu - 0.5*log(pv)/pu py = 0.5*pu + 0.5*log(pv)/pu z = cmplx(px,py,kind=wp) it = 0 50 it = it + 1 call cerf(z,zf,zd) zp = (1.0_wp,0.0_wp) do i = 1 , nr - 1 zp = zp*(z-Zo(i)) enddo zfd = zf/zp zq = (0.0_wp,0.0_wp) do i = 1 , nr - 1 zw = (1.0_wp,0.0_wp) do j = 1 , nr - 1 if ( j/=i ) zw = zw*(z-Zo(j)) enddo zq = zq + zw enddo zgd = (zd-zq*zfd)/zp z = z - zfd/zgd w0 = w w = abs(z) if ( it<=50 .and. abs((w-w0)/w)>1.0d-11 ) goto 50 Zo(nr) = z enddo end !***************************************************************************************** !> ! Compute gamma function Г(x) subroutine gamma2(x,Ga) ! Input : x --- Argument of Г(x) ! ( x is not equal to 0,-1,-2,…) ! Output: GA --- Г(x) real(wp) g , Ga , gr , r , x , z integer k , m , m1 dimension g(26) if ( x/=int(x) ) then r = 1.0_wp if ( abs(x)>1.0_wp ) then z = abs(x) m = int(z) do k = 1 , m r = r*(z-k) enddo z = z - m else z = x endif data g/1.0_wp , gamma , -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 k = 25 , 1 , -1 gr = gr*z + g(k) enddo Ga = 1.0_wp/(gr*z) if ( abs(x)>1.0_wp ) then Ga = Ga*r if ( x<0.0_wp ) Ga = -pi/(x*Ga*sin(pi*x)) endif elseif ( x>0.0_wp ) then Ga = 1.0_wp m1 = x - 1 do k = 2 , m1 Ga = Ga*k enddo else Ga = 1.0e+300_wp endif end !***************************************************************************************** !> ! Compute the confluent hypergeometric function U(a,b,x) subroutine chgu(a,b,x,Hu,Md,Isfer) ! Input : a --- Parameter ! b --- Parameter ! x --- Argument ( x > 0 ) ! Output: HU --- U(a,b,x) ! MD --- Method code ! ISFER --- Error flag real(wp) a , a00 , aa , b , b00 , Hu , hu1 , x integer id , id1 , Isfer , Md logical il1 , il2 , il3 , bl1 , bl2 , bl3 , bn aa = a - b + 1.0_wp Isfer = 0 il1 = a==int(a) .and. a<=0.0 il2 = aa==int(aa) .and. aa<=0.0 il3 = abs(a*(a-b+1.0_wp))/x<=2.0 bl1 = x<=5.0 .or. (x<=10.0 .and. a<=2.0_wp) bl2 = (x>5.0 .and. x<=12.5) .and. (a>=1.0 .and. b>=a+4.0_wp) bl3 = x>12.5 .and. a>=5.0 .and. b>=a + 5.0 bn = b==int(b) .and. b/=0.0 id1 = -100 hu1 = 0.0_wp if ( b/=int(b) ) then call chgus(a,b,x,Hu,id1) Md = 1 if ( id1>=9 ) return hu1 = Hu endif if ( il1 .or. il2 .or. il3 ) then call chgul(a,b,x,Hu,id) Md = 2 if ( id>=9 ) return if ( id1>id ) then Md = 1 id = id1 Hu = hu1 endif endif if ( a>=1.0_wp ) 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 elseif ( b<=a ) then a00 = a b00 = b a = a - b + 1.0_wp b = 2.0_wp - b call chguit(a,b,x,Hu,id) Hu = x**(1.0_wp-b00)*Hu a = a00 b = b00 Md = 4 elseif ( bn .and. (.not.il1) ) then call chgubi(a,b,x,Hu,id) Md = 3 endif if ( id<6 ) Isfer = 6 end !***************************************************************************************** !> ! Compute lambda functions and their derivatives subroutine lamn(n,x,Nm,Bl,Dl) ! Input: x --- Argument of lambda function ! n --- Order of lambda function ! Output: BL(n) --- Lambda function of order n ! DL(n) --- Derivative of lambda function ! NM --- Highest order computed real(wp) bg , bk , Bl , bs , Dl , f , f0 , f1 , r , r0 , & & uk , x , x2 integer i , k , m , n , Nm dimension Bl(0:n) , Dl(0:n) Nm = n if ( abs(x)<1.0e-100_wp ) then do k = 0 , n Bl(k) = 0.0_wp Dl(k) = 0.0_wp enddo Bl(0) = 1.0_wp Dl(1) = 0.5_wp return endif if ( x<=12.0d0 ) then x2 = x*x do k = 0 , n bk = 1.0_wp r = 1.0_wp do i = 1 , 50 r = -0.25_wp*r*x2/(i*(i+k)) bk = bk + r if ( abs(r)<abs(bk)*1.0e-15_wp ) exit enddo Bl(k) = bk if ( k>=1 ) Dl(k-1) = -0.5_wp*x/k*bk enddo uk = 1.0_wp r = 1.0_wp do i = 1 , 50 r = -0.25_wp*r*x2/(i*(i+n+1.0_wp)) uk = uk + r if ( abs(r)<abs(uk)*1.0e-15_wp ) exit enddo Dl(n) = -0.5_wp*x/(n+1.0_wp)*uk return endif if ( n==0 ) Nm = 1 m = msta1(x,200) if ( m<Nm ) then Nm = m else m = msta2(x,Nm,15) endif bs = 0.0_wp f = 0.0_wp f0 = 0.0_wp f1 = 1.0e-100_wp do k = m , 0 , -1 f = 2.0_wp*(k+1.0_wp)*f1/x - f0 if ( k<=Nm ) Bl(k) = f if ( k==2*int(k/2) ) bs = bs + 2.0_wp*f f0 = f1 f1 = f enddo bg = bs - f do k = 0 , Nm Bl(k) = Bl(k)/bg enddo r0 = 1.0_wp do k = 1 , Nm r0 = 2.0_wp*r0*k/x Bl(k) = r0*Bl(k) enddo Dl(0) = -0.5_wp*x*Bl(1) do k = 1 , Nm Dl(k) = 2.0_wp*k/x*(Bl(k-1)-Bl(k)) enddo end !***************************************************************************************** !> ! Compute complete elliptic integrals K(k) and E(k) subroutine comelp(Hk,Ck,Ce) ! Input : K --- Modulus k ( 0 ≤ k ≤ 1 ) ! Output : CK --- K(k) ! CE --- E(k) real(wp) ae , ak , be , bk , Ce , Ck , Hk , pk pk = 1.0_wp - Hk*Hk if ( Hk==1.0_wp ) then Ck = 1.0e+300_wp Ce = 1.0_wp else ak = (((.01451196212d0*pk+.03742563713d0)*pk+.03590092383d0) & & *pk+.09666344259d0)*pk + 1.38629436112d0 bk = (((.00441787012d0*pk+.03328355346d0)*pk+.06880248576d0) & & *pk+.12498593597d0)*pk + 0.5_wp Ck = ak - bk*log(pk) ae = (((.01736506451d0*pk+.04757383546d0)*pk+.0626060122d0) & & *pk+.44325141463d0)*pk + 1.0_wp be = (((.00526449639d0*pk+.04069697526d0)*pk+.09200180037d0) & & *pk+.2499836831d0)*pk Ce = ae - be*log(pk) endif end !***************************************************************************************** !> ! Compute the incomplete beta function Ix(a,b) subroutine incob(a,b,x,Bix) ! Input : a --- Parameter ! b --- Parameter ! x --- Argument ( 0 ≤ x ≤ 1 ) ! Output: BIX --- Ix(a,b) real(wp) a , b , Bix , bt , dk , fk , s0 , t1 , t2 , ta , & & tb , x integer k dimension dk(51) , fk(51) s0 = (a+1.0_wp)/(a+b+2.0_wp) call beta(a,b,bt) if ( x<=s0 ) then do k = 1 , 20 dk(2*k) = k*(b-k)*x/(a+2.0_wp*k-1.0_wp)/(a+2.0_wp*k) enddo do k = 0 , 20 dk(2*k+1) = -(a+k)*(a+b+k)*x/(a+2.d0*k)/(a+2.0_wp*k+1.0_wp) enddo t1 = 0.0_wp do k = 20 , 1 , -1 t1 = dk(k)/(1.0_wp+t1) enddo ta = 1.0_wp/(1.0_wp+t1) Bix = x**a*(1.0_wp-x)**b/(a*bt)*ta else do k = 1 , 20 fk(2*k) = k*(a-k)*(1.0_wp-x)/(b+2.*k-1.0_wp)/(b+2.0_wp*k) enddo do k = 0 , 20 fk(2*k+1) = -(b+k)*(a+b+k)*(1.d0-x)/(b+2.d0*k) & & /(b+2.d0*k+1.d0) enddo t2 = 0.0_wp do k = 20 , 1 , -1 t2 = fk(k)/(1.0_wp+t2) enddo tb = 1.0_wp/(1.0_wp+t2) Bix = 1.0_wp - x**a*(1.0_wp-x)**b/(b*bt)*tb endif end !***************************************************************************************** !> ! Compute the value of F for characteristic ! equation of Mathieu functions subroutine cvf(Kd,m,q,a,Mj,f) ! Input : m --- Order of Mathieu functions ! q --- Parameter of Mathieu functions ! A --- Characteristic value ! Output: F --- Value of F for characteristic equation real(wp) a , b , f , q , t0 , t1 , t2 integer ic , j , j0 , jf , Kd , l , l0 , m , Mj b = a ic = int(m/2) l = 0 l0 = 0 j0 = 2 jf = ic if ( Kd==1 ) l0 = 2 if ( Kd==1 ) j0 = 3 if ( Kd==2 .or. Kd==3 ) l = 1 if ( Kd==4 ) jf = ic - 1 t1 = 0.0_wp do j = Mj , ic + 1 , -1 t1 = -q*q/((2.0_wp*j+l)**2-b+t1) enddo if ( m<=2 ) then t2 = 0.0_wp if ( Kd==1 .and. m==0 ) t1 = t1 + t1 if ( Kd==1 .and. m==2 ) t1 = -2.0_wp*q*q/(4.0_wp-b+t1) - 4.0_wp if ( Kd==2 .and. m==1 ) t1 = t1 + q if ( Kd==3 .and. m==1 ) t1 = t1 - q else t0 = 0.0_wp if ( Kd==1 ) t0 = 4.0_wp - b + 2.0_wp*q*q/b if ( Kd==2 ) t0 = 1.0_wp - b + q if ( Kd==3 ) t0 = 1.0_wp - b - q if ( Kd==4 ) t0 = 4.0_wp - b t2 = -q*q/t0 do j = j0 , jf t2 = -q*q/((2.0_wp*j-l-l0)**2-b+t2) enddo endif f = (2.0_wp*ic+l)**2 + t1 + t2 - b end !***************************************************************************************** !> ! Compute Legendre polynomials Pn(z) and ! their derivatives Pn'(z) for a complex ! argument subroutine clpn(n,x,y,Cpn,Cpd) ! Input : x --- Real part of z ! y --- Imaginary part of z ! n --- Degree of Pn(z), n = 0,1,2,... ! Output: CPN(n) --- Pn(z) ! CPD(n) --- Pn'(z) complex(wp) cp0 , cp1 , Cpd , cpf , Cpn , z integer k , n real(wp) x , y dimension Cpn(0:n) , Cpd(0:n) z = cmplx(x,y,kind=wp) Cpn(0) = (1.0_wp,0.0_wp) Cpn(1) = z Cpd(0) = (0.0_wp,0.0_wp) Cpd(1) = (1.0_wp,0.0_wp) cp0 = (1.0_wp,0.0_wp) cp1 = z do k = 2 , n cpf = (2.0_wp*k-1.0_wp)/k*z*cp1 - (k-1.0_wp)/k*cp0 Cpn(k) = cpf if ( abs(x)==1.0_wp .and. y==0.0_wp ) then Cpd(k) = 0.5_wp*x**(k+1)*k*(k+1.0_wp) else Cpd(k) = k*(cp1-z*cpf)/(1.0_wp-z*z) endif cp0 = cp1 cp1 = cpf enddo end !***************************************************************************************** !> ! Compute associated Legendre functions Qmn(x) ! and Qmn'(x) for a given order subroutine lqmns(m,n,x,Qm,Qd) ! Input : x --- Argument of Qmn(x) ! m --- Order of Qmn(x), m = 0,1,2,... ! n --- Degree of Qmn(x), n = 0,1,2,... ! Output: QM(n) --- Qmn(x) ! QD(n) --- Qmn'(x) integer k , km , l , ls , m , n real(wp) q0 , q00 , q01 , q0l , q10 , q11 , q1l , Qd , & & qf0 , qf1 , qf2 , qg0 , qg1 , qh0 , qh1 , qh2 , & & Qm , qm0 , qm1 , qmk real(wp) x , xq dimension Qm(0:n) , Qd(0:n) do k = 0 , n Qm(k) = 0.0_wp Qd(k) = 0.0_wp enddo if ( abs(x)==1.0_wp ) then do k = 0 , n Qm(k) = 1.0e+300_wp Qd(k) = 1.0e+300_wp enddo return endif ls = 1 if ( abs(x)>1.0_wp ) ls = -1 xq = sqrt(ls*(1.0_wp-x*x)) q0 = 0.5_wp*log(abs((x+1.0_wp)/(x-1.0_wp))) q00 = q0 q10 = -1.0_wp/xq q01 = x*q0 - 1.0_wp q11 = -ls*xq*(q0+x/(1.0_wp-x*x)) qf0 = q00 qf1 = q10 qm0 = 0.0_wp qm1 = 0.0_wp do k = 2 , m qm0 = -2.0_wp*(k-1.0_wp)/xq*x*qf1 - ls*(k-1.0_wp)*(2.0-k)*qf0 qf0 = qf1 qf1 = qm0 enddo if ( m==0 ) qm0 = q00 if ( m==1 ) qm0 = q10 Qm(0) = qm0 if ( abs(x)<1.0001_wp ) then if ( m==0 .and. n>0 ) then qf0 = q00 qf1 = q01 do k = 2 , n qf2 = ((2.0_wp*k-1.0_wp)*x*qf1-(k-1.0_wp)*qf0)/k Qm(k) = qf2 qf0 = qf1 qf1 = qf2 enddo endif qg0 = q01 qg1 = q11 do k = 2 , m qm1 = -2.0_wp*(k-1.0_wp)/xq*x*qg1 - ls*k*(3.0-k)*qg0 qg0 = qg1 qg1 = qm1 enddo if ( m==0 ) qm1 = q01 if ( m==1 ) qm1 = q11 Qm(1) = qm1 if ( m==1 .and. n>1 ) then qh0 = q10 qh1 = q11 do k = 2 , n qh2 = ((2.0_wp*k-1.0_wp)*x*qh1-k*qh0)/(k-1.0_wp) Qm(k) = qh2 qh0 = qh1 qh1 = qh2 enddo elseif ( m>=2 ) then qg0 = q00 qg1 = q01 qh0 = q10 qh1 = q11 qmk = 0.0_wp do l = 2 , n q0l = ((2.0_wp*l-1.0_wp)*x*qg1-(l-1.0_wp)*qg0)/l q1l = ((2.0_wp*l-1.0_wp)*x*qh1-l*qh0)/(l-1.0_wp) qf0 = q0l qf1 = q1l do k = 2 , m qmk = -2.0_wp*(k-1.0_wp)/xq*x*qf1 - ls*(k+l-1.0_wp)*(l+2.0-k)& & *qf0 qf0 = qf1 qf1 = qmk enddo Qm(l) = qmk qg0 = qg1 qg1 = q0l qh0 = qh1 qh1 = q1l enddo endif else if ( abs(x)>1.1 ) then km = 40 + m + n else km = (40+m+n)*int(-1.0-1.8*log(x-1.0_wp)) endif qf2 = 0.0_wp qf1 = 1.0_wp do k = km , 0 , -1 qf0 = ((2.0_wp*k+3.0_wp)*x*qf1-(k+2.0-m)*qf2)/(k+m+1.0_wp) if ( k<=n ) Qm(k) = qf0 qf2 = qf1 qf1 = qf0 enddo do k = 0 , n Qm(k) = Qm(k)*qm0/qf0 enddo endif if ( abs(x)<1.0_wp ) then do k = 0 , n Qm(k) = (-1)**m*Qm(k) enddo endif Qd(0) = ((1.0_wp-m)*Qm(1)-x*Qm(0))/(x*x-1.0_wp) do k = 1 , n Qd(k) = (k*x*Qm(k)-(k+m)*Qm(k-1))/(x*x-1.0_wp) enddo end !***************************************************************************************** !> ! Compute modified Bessel functions Iv(z) and ! Kv(z) and their derivatives with a complex ! argument and a large order subroutine ciklv(v,z,Cbiv,Cdiv,Cbkv,Cdkv) ! Input: v --- Order of Iv(z) and Kv(z) ! z --- Complex argument ! Output: CBIV --- Iv(z) ! CDIV --- Iv'(z) ! CBKV --- Kv(z) ! CDKV --- Kv'(z) real(wp) a , v , v0 , vr complex(wp) Cbiv , Cbkv , Cdiv , Cdkv , ceta , cf , cfi , cfk , & & csi , csk , ct , ct2 , cws , z integer i , k , km , l , l0 , lf dimension cf(12) , a(91) km = 12 call cjk(km,a) do l = 1 , 0 , -1 v0 = v - l cws = sqrt(1.0_wp+(z/v0)*(z/v0)) ceta = cws + log(z/v0/(1.0_wp+cws)) ct = 1.0_wp/cws ct2 = ct*ct do k = 1 , km l0 = k*(k+1)/2 + 1 lf = l0 + k cf(k) = a(lf) do i = lf - 1 , l0 , -1 cf(k) = cf(k)*ct2 + a(i) enddo cf(k) = cf(k)*ct**k enddo vr = 1.0_wp/v0 csi = (1.0_wp,0.0_wp) do k = 1 , km csi = csi + cf(k)*vr**k enddo Cbiv = sqrt(ct/(twopi*v0))*exp(v0*ceta)*csi if ( l==1 ) cfi = Cbiv csk = (1.0_wp,0.0_wp) do k = 1 , km csk = csk + (-1)**k*cf(k)*vr**k enddo Cbkv = sqrt(pi*ct/(2.0_wp*v0))*exp(-v0*ceta)*csk if ( l==1 ) cfk = Cbkv enddo Cdiv = cfi - v/z*Cbiv Cdkv = -cfk - v/z*Cbkv end !***************************************************************************************** !> ! Compute complete and incomplete elliptic ! integrals F(k,phi) and E(k,phi) subroutine elit(Hk,Phi,Fe,Ee) ! Input : HK --- Modulus k ( 0 ≤ k ≤ 1 ) ! Phi --- Argument ( in degrees ) ! Output : FE --- F(k,phi) ! EE --- E(k,phi) real(wp) a , a0 , b , b0 , c , ce , ck , d , d0 , Ee , & & fac , Fe , g , Hk , Phi , r integer n g = 0.0_wp a0 = 1.0_wp b0 = sqrt(1.0_wp-Hk*Hk) d0 = (pi/180.0d0)*Phi r = Hk*Hk if ( Hk==1.0_wp .and. Phi==90.0d0 ) then Fe = 1.0e+300_wp Ee = 1.0_wp elseif ( Hk==1.0_wp ) then Fe = log((1.0_wp+sin(d0))/cos(d0)) Ee = sin(d0) else fac = 1.0_wp d = 0.0_wp do n = 1 , 40 a = (a0+b0)/2.0_wp b = sqrt(a0*b0) c = (a0-b0)/2.0_wp fac = 2.0_wp*fac r = r + fac*c*c if ( Phi/=90.0d0 ) then d = d0 + atan((b0/a0)*tan(d0)) g = g + c*sin(d) d0 = d + pi*int(d/pi+0.5_wp) endif a0 = a b0 = b if ( c<1.0d-7 ) exit enddo ck = pi/(2.0_wp*a) ce = pi*(2.0_wp-r)/(4.0_wp*a) if ( Phi==90.0d0 ) then Fe = ck Ee = ce else Fe = d/(fac*a) Ee = Fe*ce/ck + g endif endif end !***************************************************************************************** !> ! Compute the elliptic integral of the third kind ! using Gauss-Legendre quadrature subroutine elit3(Phi,Hk,c,El3) ! Input : Phi --- Argument ( in degrees ) ! k --- Modulus ( 0 ≤ k ≤ 1.0 ) ! c --- Parameter ( 0 ≤ c ≤ 1.0 ) ! Output: EL3 --- Value of the elliptic integral of the ! third kind real(wp) c , c0 , c1 , c2 , El3 , f1 , f2 , Hk , Phi , t ,& & t1 , t2 , w integer i 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==1.0_wp .and. abs(Phi-90.0_wp)<=1.0d-8 lb2 = c==1.0_wp .and. abs(Phi-90.0_wp)<=1.0d-8 if ( lb1 .or. lb2 ) then El3 = 1.0e+300_wp return endif c1 = 0.87266462599716d-2*Phi c2 = c1 El3 = 0.0_wp do i = 1 , 10 c0 = c2*t(i) t1 = c1 + c0 t2 = c1 - c0 f1 = 1.0_wp/((1.0_wp-c*sin(t1)*sin(t1)) & & *sqrt(1.0_wp-Hk*Hk*sin(t1)*sin(t1))) f2 = 1.0_wp/((1.0_wp-c*sin(t2)*sin(t2)) & & *sqrt(1.0_wp-Hk*Hk*sin(t2)*sin(t2))) El3 = El3 + w(i)*(f1+f2) enddo El3 = c1*El3 end !***************************************************************************************** !> ! Compute exponential integral Ei(x) subroutine eix(x,Ei) ! Input : x --- Argument of Ei(x) ! Output: EI --- Ei(x) real(wp) Ei , ga , r , x integer k if ( x==0.0_wp ) then Ei = -1.0e+300_wp elseif ( x<0 ) then call e1xb(-x,Ei) Ei = -Ei elseif ( abs(x)<=40.0_wp ) then ! Power series around x=0 Ei = 1.0_wp r = 1.0_wp do k = 1 , 100 r = r*k*x/(k+1.0_wp)**2 Ei = Ei + r if ( abs(r/Ei)<=1.0e-15_wp ) exit enddo ga = 0.5772156649015328d0 Ei = ga + log(x) + x*Ei else ! Asymptotic expansion (the series is not convergent) Ei = 1.0_wp r = 1.0_wp do k = 1 , 20 r = r*k/x Ei = Ei + r enddo Ei = exp(x)/x*Ei endif end !***************************************************************************************** !> ! Compute exponential integral Ei(x) subroutine eixz(z,Cei) ! Input : x --- Complex argument of Ei(x) ! Output: EI --- Ei(x) complex(wp) z , Cei call e1z(-z,Cei) Cei = -Cei if ( aimag(z)>0 ) then Cei = Cei + (0d0,1d0)*pi elseif ( aimag(z)<0 ) then Cei = Cei - (0d0,1d0)*pi elseif ( aimag(z)==0 ) then if ( real(z,wp)>0 ) Cei = Cei + (0d0,1d0)*sign(pi,aimag(z)) endif end !***************************************************************************************** !> ! Compute exponential integral E1(x) subroutine e1xb(x,e1) ! Input : x --- Argument of E1(x) ! Output: E1 --- E1(x) ( x > 0 ) real(wp) e1 , ga , r , t , t0 , x integer k , m if ( x==0.0_wp ) then e1 = 1.0e+300_wp elseif ( x<=1.0_wp ) then e1 = 1.0_wp r = 1.0_wp do k = 1 , 25 r = -r*k*x/(k+1.0_wp)**2 e1 = e1 + r if ( abs(r)<=abs(e1)*1.0e-15_wp ) exit enddo ga = 0.5772156649015328d0 e1 = -ga - log(x) + x*e1 else m = 20 + int(80.0/x) t0 = 0.0_wp do k = m , 1 , -1 t0 = k/(1.0_wp+k/(x+t0)) enddo t = 1.0_wp/(x+t0) e1 = exp(-x)*t endif end !***************************************************************************************** !> ! Compute confluent hypergeometric function M(a,b,x) subroutine chgm(a,b,x,Hg) ! Input : a --- Parameter ! b --- Parameter ( b <> 0,-1,-2,... ) ! x --- Argument ! Output: HG --- M(a,b,x) ! Routine called: CGAMA for computing complex ln[Г(x)] real(wp) a , a0 , a1 , b , Hg , hg1 , hg2 , r1 , r2 ,& & rg , sum1 , sum2 , tai , tar , tbai , tbar , & & tbi , tbr , x real(wp) x0 , xg , y , y0 , y1 complex(wp) cta , ctb , ctba integer i , j , la , n , nl a0 = a a1 = a x0 = x Hg = 0.0_wp ! DLMF 13.2.39 if ( x<0.0_wp ) then a = b - a a0 = a x = abs(x) endif nl = 0 la = 0 if ( a>=2.0_wp ) then ! preparing terms for DLMF 13.3.1 nl = 1 la = int(a) a = a - la - 1.0_wp endif y0 = 0.0_wp y1 = 0.0_wp do n = 0 , nl if ( a0>=2.0_wp ) a = a + 1.0_wp if ( x<=30.0d0+abs(b) .or. a<0.0_wp ) then Hg = 1.0_wp rg = 1.0_wp do j = 1 , 500 rg = rg*(a+j-1.0_wp)/(j*(b+j-1.0_wp))*x Hg = Hg + rg if ( Hg/=0d0 .and. abs(rg/Hg)<1.0e-15_wp ) then ! DLMF 13.2.39 (cf. above) if ( x0<0.0_wp ) Hg = Hg*exp(x0) goto 50 endif enddo else ! DLMF 13.7.2 & 13.2.4, SUM2 corresponds to first sum y = 0.0_wp call cgama(a,y,0,tar,tai) cta = cmplx(tar,tai,kind=wp) y = 0.0_wp call cgama(b,y,0,tbr,tbi) ctb = cmplx(tbr,tbi,kind=wp) xg = b - a y = 0.0_wp call cgama(xg,y,0,tbar,tbai) ctba = cmplx(tbar,tbai,kind=wp) sum1 = 1.0_wp sum2 = 1.0_wp r1 = 1.0_wp r2 = 1.0_wp do i = 1 , 8 r1 = -r1*(a+i-1.0_wp)*(a-b+i)/(x*i) r2 = -r2*(b-a+i-1.0_wp)*(a-i)/(x*i) sum1 = sum1 + r1 sum2 = sum2 + r2 enddo if ( x0>=0.0_wp ) then hg1 = dble(exp(ctb-ctba))*x**(-a)*cos(pi*a)*sum1 hg2 = dble(exp(ctb-cta+x))*x**(a-b)*sum2 else ! DLMF 13.2.39 (cf. above) hg1 = dble(exp(ctb-ctba+x0))*x**(-a)*cos(pi*a)*sum1 hg2 = dble(exp(ctb-cta))*x**(a-b)*sum2 endif Hg = hg1 + hg2 endif 50 if ( n==0 ) y0 = Hg if ( n==1 ) y1 = Hg enddo if ( a0>=2.0_wp ) then ! DLMF 13.3.1 do i = 1 , la - 1 Hg = ((2.0_wp*a-b+x)*y1+(b-a)*y0)/a y0 = y1 y1 = Hg a = a + 1.0_wp enddo endif a = a1 x = x0 end !***************************************************************************************** !> ! Compute hypergeometric function F(a,b,c,x) subroutine hygfx(a,b,c,x,Hf,Isfer) ! Input : a --- Parameter ! b --- Parameter ! c --- Parameter, c <> 0,-1,-2,... ! x --- Argument ( x < 1 ) ! Output: HF --- F(a,b,c,x) ! ISFER --- Error flag real(wp) a , a0 , aa , b , bb , c , c0 , c1 , eps , & & f0 , f1 , g0 , g1 , g2 , g3 , ga , gabc , gam , & & gb real(wp) gbm , gc , gca , gcab , gcb , gm , Hf , hw , pa ,& & pb , r , r0 , r1 , rm , rp , sm , sp , sp0 ,& & x real(wp) x1 integer Isfer , j , k , m , nm logical l0 , l1 , l2 , l3 , l4 , l5 Isfer = 0 l0 = c==int(c) .and. c<0.0 l1 = 1.0_wp - x<1.0e-15_wp .and. c - a - b<=0.0 l2 = a==int(a) .and. a<0.0 l3 = b==int(b) .and. b<0.0 l4 = c - a==int(c-a) .and. c - a<=0.0 l5 = c - b==int(c-b) .and. c - b<=0.0 if ( l0 .or. l1 ) then Isfer = 3 return endif eps = 1.0e-15_wp if ( x>0.95 ) eps = 1.0d-8 if ( x==0.0 .or. a==0.0 .or. b==0.0_wp ) then Hf = 1.0_wp return elseif ( 1.0_wp-x==eps .and. c-a-b>0.0_wp ) 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 elseif ( 1.0_wp+x<=eps .and. abs(c-a+b-1.0_wp)<=eps ) then g0 = sqrtpi*2.0_wp**(-a) call gamma2(c,g1) call gamma2(1.0_wp+a/2.0-b,g2) call gamma2(0.5_wp+0.5*a,g3) Hf = g0*g1/(g2*g3) return elseif ( l2 .or. l3 ) then if ( l2 ) nm = int(abs(a)) if ( l3 ) nm = int(abs(b)) Hf = 1.0_wp r = 1.0_wp do k = 1 , nm r = r*(a+k-1.0_wp)*(b+k-1.0_wp)/(k*(c+k-1.0_wp))*x Hf = Hf + r enddo return elseif ( l4 .or. l5 ) then if ( l4 ) nm = int(abs(c-a)) if ( l5 ) nm = int(abs(c-b)) Hf = 1.0_wp r = 1.0_wp do k = 1 , nm r = r*(c-a+k-1.0_wp)*(c-b+k-1.0_wp)/(k*(c+k-1.0_wp))*x Hf = Hf + r enddo Hf = (1.0_wp-x)**(c-a-b)*Hf return endif aa = a bb = b x1 = x if ( x<0.0_wp ) then x = x/(x-1.0_wp) if ( c>a .and. b<a .and. b>0.0_wp ) then a = bb b = aa endif b = c - b endif hw = 0.0_wp if ( x>=0.75d0 ) then gm = 0.0_wp if ( abs(c-a-b-int(c-a-b))<1.0e-15_wp ) 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/=0 ) gm = 1.0_wp do j = 1 , abs(m) - 1 gm = gm*j enddo rm = 1.0_wp do j = 1 , abs(m) rm = rm*j enddo f0 = 1.0_wp r0 = 1.0_wp r1 = 1.0_wp sp0 = 0.d0 sp = 0.0_wp if ( m>=0 ) then c0 = gm*gc/(gam*gbm) c1 = -gc*(x-1.0_wp)**m/(ga*gb*rm) do k = 1 , m - 1 r0 = r0*(a+k-1.0_wp)*(b+k-1.0_wp)/(k*(k-m))*(1.0-x) f0 = f0 + r0 enddo do k = 1 , m sp0 = sp0 + 1.0_wp/(a+k-1.0_wp) + 1.0/(b+k-1.0_wp) - 1.0/k enddo f1 = pa + pb + sp0 + 2.0_wp*gamma + log(1.0_wp-x) do k = 1 , 250 sp = sp + (1.0_wp-a)/(k*(a+k-1.0_wp)) + (1.0-b) & & /(k*(b+k-1.0_wp)) sm = 0.0_wp do j = 1 , m sm = sm + (1.0_wp-a)/((j+k)*(a+j+k-1.0_wp)) & & + 1.0/(b+j+k-1.0_wp) enddo rp = pa + pb + 2.0_wp*gamma + sp + sm + log(1.0_wp-x) r1 = r1*(a+m+k-1.0_wp)*(b+m+k-1.0_wp)/(k*(m+k))*(1.0-x) f1 = f1 + r1*rp if ( abs(f1-hw)<abs(f1)*eps ) exit hw = f1 enddo Hf = f0*c0 + f1*c1 elseif ( m<0 ) then m = -m c0 = gm*gc/(ga*gb*(1.0_wp-x)**m) c1 = -(-1)**m*gc/(gam*gbm*rm) do k = 1 , m - 1 r0 = r0*(a-m+k-1.0_wp)*(b-m+k-1.0_wp)/(k*(k-m))*(1.0-x) f0 = f0 + r0 enddo do k = 1 , m sp0 = sp0 + 1.0_wp/k enddo f1 = pa + pb - sp0 + 2.0_wp*gamma + log(1.0_wp-x) do k = 1 , 250 sp = sp + (1.0_wp-a)/(k*(a+k-1.0_wp)) + (1.0-b) & & /(k*(b+k-1.0_wp)) sm = 0.0_wp do j = 1 , m sm = sm + 1.0_wp/(j+k) enddo rp = pa + pb + 2.0_wp*gamma + sp - sm + log(1.0_wp-x) r1 = r1*(a+k-1.0_wp)*(b+k-1.0_wp)/(k*(m+k))*(1.0-x) f1 = f1 + r1*rp if ( abs(f1-hw)<abs(f1)*eps ) exit hw = f1 enddo 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.0_wp-x)**(c-a-b) Hf = 0.0_wp r0 = c0 r1 = c1 do k = 1 , 250 r0 = r0*(a+k-1.0_wp)*(b+k-1.0_wp)/(k*(a+b-c+k))*(1.0-x) r1 = r1*(c-a+k-1.0_wp)*(c-b+k-1.0_wp)/(k*(c-a-b+k))*(1.0-x) Hf = Hf + r0 + r1 if ( abs(Hf-hw)<abs(Hf)*eps ) exit hw = Hf enddo Hf = Hf + c0 + c1 endif else a0 = 1.0_wp if ( c>a .and. c<2.0_wp*a .and. c>b .and. c<2.0_wp*b ) then a0 = (1.0_wp-x)**(c-a-b) a = c - a b = c - b endif Hf = 1.0_wp r = 1.0_wp do k = 1 , 250 r = r*(a+k-1.0_wp)*(b+k-1.0_wp)/(k*(c+k-1.0_wp))*x Hf = Hf + r if ( abs(Hf-hw)<=abs(Hf)*eps ) exit hw = Hf enddo Hf = a0*Hf endif if ( x1<0.0_wp ) then x = x1 c0 = 1.0_wp/(1.0_wp-x)**aa Hf = c0*Hf endif a = aa b = bb if ( k>120 ) Isfer = 5 end !***************************************************************************************** !> ! Compute confluent hypergeometric function ! M(a,b,z) with real parameters a, b and a ! complex argument z subroutine cchg(a,b,z,Chg) ! Input : a --- Parameter ! b --- Parameter ! z --- Complex argument ! Output: CHG --- M(a,b,z) real(wp) a , a0 , a1 , b , ba , g1i , g1r , g2i , g2r , & & g3i , g3r , phi , x , x0 , y complex(wp) cfac , cg1 , cg2 , cg3 , Chg , chg1 , chg2 , chw , ci ,& & cr , cr1 , cr2 , crg , cs1 , cs2 , cy0 , cy1 , z , z0 integer i , j , k , la , m , n , nl , ns ci = (0.0_wp,1.0_wp) a0 = a a1 = a z0 = z if ( b==0.0 .or. b==-int(abs(b)) ) then Chg = (1.0e+300_wp,0.0_wp) elseif ( a==0.0_wp .or. z==0.0_wp ) then Chg = (1.0_wp,0.0_wp) elseif ( a==-1.0_wp ) then Chg = 1.0_wp - z/b elseif ( a==b ) then Chg = exp(z) elseif ( a-b==1.0_wp ) then Chg = (1.0_wp+z/b)*exp(z) elseif ( a==1.0_wp .and. b==2.0_wp ) then Chg = (exp(z)-1.0_wp)/z elseif ( a==int(a) .and. a<0.0_wp ) then m = int(-a) cr = (1.0_wp,0.0_wp) Chg = (1.0_wp,0.0_wp) do k = 1 , m cr = cr*(a+k-1.0_wp)/k/(b+k-1.0_wp)*z Chg = Chg + cr enddo else x0 = real(z,wp) if ( x0<0.0_wp ) then a = b - a a0 = a z = -z endif nl = 0 la = 0 if ( a>=2.0_wp ) then nl = 1 la = int(a) a = a - la - 1.0_wp endif ns = 0 do n = 0 , nl if ( a0>=2.0_wp ) a = a + 1.0_wp if ( abs(z)<20.0_wp+abs(b) .or. a<0.0_wp ) then Chg = (1.0_wp,0.0_wp) crg = (1.0_wp,0.0_wp) do j = 1 , 500 crg = crg*(a+j-1.0_wp)/(j*(b+j-1.0_wp))*z Chg = Chg + crg if ( abs((Chg-chw)/Chg)<1.d-15 ) goto 20 chw = Chg enddo else y = 0.0_wp call cgama(a,y,0,g1r,g1i) cg1 = cmplx(g1r,g1i,kind=wp) y = 0.0_wp call cgama(b,y,0,g2r,g2i) cg2 = cmplx(g2r,g2i,kind=wp) ba = b - a y = 0.0_wp call cgama(ba,y,0,g3r,g3i) cg3 = cmplx(g3r,g3i,kind=wp) cs1 = (1.0_wp,0.0_wp) cs2 = (1.0_wp,0.0_wp) cr1 = (1.0_wp,0.0_wp) cr2 = (1.0_wp,0.0_wp) do i = 1 , 8 cr1 = -cr1*(a+i-1.0_wp)*(a-b+i)/(z*i) cr2 = cr2*(b-a+i-1.0_wp)*(i-a)/(z*i) cs1 = cs1 + cr1 cs2 = cs2 + cr2 enddo x = real(z,wp) y = aimag(z) if ( x==0.0 .and. y>=0.0_wp ) then phi = halfpi elseif ( x==0.0 .and. y<=0.0_wp ) then phi = -halfpi else phi = atan(y/x) endif if ( phi>-halfpi .and. phi<1.5*pi ) ns = 1 if ( phi>-1.5*pi .and. phi<=-halfpi ) ns = -1 cfac = exp(ns*ci*pi*a) if ( y==0.0_wp ) cfac = cos(pi*a) chg1 = exp(cg2-cg3)*z**(-a)*cfac*cs1 chg2 = exp(cg2-cg1+z)*z**(a-b)*cs2 Chg = chg1 + chg2 endif 20 if ( n==0 ) cy0 = Chg if ( n==1 ) cy1 = Chg enddo if ( a0>=2.0_wp ) then do i = 1 , la - 1 Chg = ((2.0_wp*a-b+z)*cy1+(b-a)*cy0)/a cy0 = cy1 cy1 = Chg a = a + 1.0_wp enddo endif if ( x0<0.0_wp ) Chg = Chg*exp(-z) endif a = a1 z = z0 end !***************************************************************************************** !> ! Compute the hypergeometric function for a ! complex argument, F(a,b,c,z) subroutine hygfz(a,b,c,z,Zhf,Isfer) ! Input : a --- Parameter ! b --- Parameter ! c --- Parameter, c <> 0,-1,-2,... ! z --- Complex argument ! Output: ZHF --- F(a,b,c,z) ! ISFER --- Error flag real(wp) a , a0 , aa , b , bb , c , ca , cb , eps , & & g0 , g1 , g2 , g3 , ga , gab , gabc , gam , gb , & & gba real(wp) gbm , gc , gca , gcab , gcb , gcbk , gm , pa , & & pac , pb , pca , rk1 , rk2 , rm , sj1 , & & sj2 , sm , sp , sp0 real(wp) sq , t0 , w0 , ws , x , y integer Isfer , j , k , m , mab , mcab , nca , ncb , nm complex(wp) z , z00 , z1 , zc0 , zc1 , zf0 , zf1 , Zhf , zp , zp0 ,& & zr , zr0 , zr1 , zw logical l0 , l1 , l2 , l3 , l4 , l5 , l6 x = real(z,wp) y = aimag(z) eps = 1.0e-15_wp Isfer = 0 l0 = c==int(c) .and. c<0.0_wp l1 = abs(1.0_wp-x)<eps .and. y==0.0_wp .and. c - a - b<=0.0_wp l2 = abs(z+1.0_wp)<eps .and. abs(c-a+b-1.0_wp)<eps l3 = a==int(a) .and. a<0.0_wp l4 = b==int(b) .and. b<0.0_wp l5 = c - a==int(c-a) .and. c - a<=0.0_wp l6 = c - b==int(c-b) .and. c - b<=0.0_wp aa = a bb = b a0 = abs(z) if ( a0>0.95d0 ) eps = 1.0d-8 if ( l0 .or. l1 ) then Isfer = 3 return endif nm = 0 if ( a0==0.0_wp .or. a==0.0_wp .or. b==0.0_wp ) then Zhf = (1.0_wp,0.0_wp) elseif ( z==1.0_wp .and. c-a-b>0.0_wp ) 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) elseif ( l2 ) then g0 = sqrtpi*2.0_wp**(-a) call gamma2(c,g1) call gamma2(1.0_wp+a/2.0_wp-b,g2) call gamma2(0.5_wp+0.5_wp*a,g3) Zhf = g0*g1/(g2*g3) elseif ( l3 .or. l4 ) then if ( l3 ) nm = int(abs(a)) if ( l4 ) nm = int(abs(b)) Zhf = (1.0_wp,0.0_wp) zr = (1.0_wp,0.0_wp) do k = 1 , nm zr = zr*(a+k-1.0_wp)*(b+k-1.0_wp)/(k*(c+k-1.0_wp))*z Zhf = Zhf + zr enddo elseif ( l5 .or. l6 ) then if ( l5 ) nm = int(abs(c-a)) if ( l6 ) nm = int(abs(c-b)) Zhf = (1.0_wp,0.0_wp) zr = (1.0_wp,0.0_wp) do k = 1 , nm zr = zr*(c-a+k-1.0_wp)*(c-b+k-1.0_wp)/(k*(c+k-1.0_wp))*z Zhf = Zhf + zr enddo Zhf = (1.0_wp-z)**(c-a-b)*Zhf elseif ( a0<=1.0_wp ) then if ( x<0.0_wp ) then z1 = z/(z-1.0_wp) if ( c>a .and. b<a .and. b>0.0_wp ) then a = bb b = aa endif zc0 = 1.0_wp/((1.0_wp-z)**a) Zhf = (1.0_wp,0.0_wp) zr0 = (1.0_wp,0.0_wp) do k = 1 , 500 zr0 = zr0*(a+k-1.0_wp)*(c-b+k-1.0_wp)/(k*(c+k-1.0_wp))*z1 Zhf = Zhf + zr0 if ( abs(Zhf-zw)<abs(Zhf)*eps ) exit zw = Zhf enddo Zhf = zc0*Zhf elseif ( a0>=0.90d0 ) then gm = 0.0_wp mcab = int(c-a-b+eps*sign(1.0_wp,c-a-b)) if ( abs(c-a-b-mcab)<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/=0 ) gm = 1.0_wp do j = 1 , abs(m) - 1 gm = gm*j enddo rm = 1.0_wp do j = 1 , abs(m) rm = rm*j enddo zf0 = (1.0_wp,0.0_wp) zr0 = (1.0_wp,0.0_wp) zr1 = (1.0_wp,0.0_wp) sp0 = 0.d0 sp = 0.0_wp if ( m>=0 ) then zc0 = gm*gc/(gam*gbm) zc1 = -gc*(z-1.0_wp)**m/(ga*gb*rm) do k = 1 , m - 1 zr0 = zr0*(a+k-1.d0)*(b+k-1.d0)/(k*(k-m))*(1.d0-z) zf0 = zf0 + zr0 enddo do k = 1 , m sp0 = sp0 + 1.0_wp/(a+k-1.0_wp) + 1.0/(b+k-1.0_wp) & & - 1.d0/k enddo zf1 = pa + pb + sp0 + 2.0_wp*gamma + log(1.0_wp-z) do k = 1 , 500 sp = sp + (1.0_wp-a)/(k*(a+k-1.0_wp)) + (1.0_wp-b) & & /(k*(b+k-1.0_wp)) sm = 0.0_wp do j = 1 , m sm = sm + (1.0_wp-a)/((j+k)*(a+j+k-1.0_wp)) & & + 1.0_wp/(b+j+k-1.0_wp) enddo zp = pa + pb + 2.0_wp*gamma + sp + sm + log(1.0_wp-z) zr1 = zr1*(a+m+k-1.0_wp)*(b+m+k-1.0_wp)/(k*(m+k)) & & *(1.0_wp-z) zf1 = zf1 + zr1*zp if ( abs(zf1-zw)<abs(zf1)*eps ) exit zw = zf1 enddo Zhf = zf0*zc0 + zf1*zc1 elseif ( m<0 ) then m = -m zc0 = gm*gc/(ga*gb*(1.0_wp-z)**m) zc1 = -(-1)**m*gc/(gam*gbm*rm) do k = 1 , m - 1 zr0 = zr0*(a-m+k-1.0_wp)*(b-m+k-1.0_wp)/(k*(k-m)) & & *(1.0_wp-z) zf0 = zf0 + zr0 enddo do k = 1 , m sp0 = sp0 + 1.0_wp/k enddo zf1 = pa + pb - sp0 + 2.0_wp*gamma + log(1.0_wp-z) do k = 1 , 500 sp = sp + (1.0_wp-a)/(k*(a+k-1.0_wp)) + (1.0_wp-b) & & /(k*(b+k-1.0_wp)) sm = 0.0_wp do j = 1 , m sm = sm + 1.0_wp/(j+k) enddo zp = pa + pb + 2.0_wp*gamma + sp - sm + log(1.0_wp-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)<abs(zf1)*eps ) exit zw = zf1 enddo 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.0_wp-z)**(c-a-b) Zhf = (0.0_wp,0.0_wp) zr0 = zc0 zr1 = zc1 do 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.0_wp)*(c-b+k-1.0_wp)/(k*(c-a-b+k)) & & *(1.0_wp-z) Zhf = Zhf + zr0 + zr1 if ( abs(Zhf-zw)<abs(Zhf)*eps ) exit zw = Zhf enddo Zhf = Zhf + zc0 + zc1 endif else z00 = (1.0_wp,0.0_wp) if ( c-a<a .and. c-b<b ) then z00 = (1.0_wp-z)**(c-a-b) a = c - a b = c - b endif Zhf = (1.0_wp,0.d0) zr = (1.0_wp,0.0_wp) do k = 1 , 1500 zr = zr*(a+k-1.0_wp)*(b+k-1.0_wp)/(k*(c+k-1.0_wp))*z Zhf = Zhf + zr if ( abs(Zhf-zw)<=abs(Zhf)*eps ) exit zw = Zhf enddo Zhf = z00*Zhf endif elseif ( a0>1.0_wp ) then mab = int(a-b+eps*sign(1.0_wp,a-b)) if ( abs(a-b-mab)<eps .and. a0<=1.1_wp ) b = b + eps if ( abs(a-b-mab)>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.0_wp,0.0_wp) do k = 1 , 500 zr0 = zr0*(a+k-1.0_wp)*(a-c+k)/((a-b+k)*k*z) zr1 = zr1*(b+k-1.0_wp)*(b-c+k)/((b-a+k)*k*z) Zhf = Zhf + zr0 + zr1 if ( abs((Zhf-zw)/Zhf)<=eps ) exit zw = Zhf enddo Zhf = Zhf + zc0 + zc1 else if ( a-b<0.0_wp ) then a = bb b = aa endif ca = c - a cb = c - b nca = int(ca+eps*sign(1.0_wp,ca)) ncb = int(cb+eps*sign(1.0_wp,cb)) if ( abs(ca-nca)<eps .or. abs(cb-ncb)<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 k = 1 , mab - 1 zr = zr*(b+k-1.0_wp)/(k*z) t0 = a - b - k call gamma2(t0,g0) call gamma2(c-b-k,gcbk) zf0 = zf0 + zr*g0/gcbk enddo if ( mab==0 ) zf0 = (0.0_wp,0.0_wp) zc1 = gc/(ga*gcb*(-z)**a) sp = -2.0_wp*gamma - pa - pca do j = 1 , mab sp = sp + 1.0_wp/j enddo zp0 = sp + log(-z) sq = 1.0_wp do j = 1 , mab sq = sq*(b+j-1.0_wp)*(b-c+j)/j enddo zf1 = (sq*zp0)*zc1 zr = zc1 rk1 = 1.0_wp sj1 = 0.0_wp w0 = 0.0_wp do k = 1 , 10000 zr = zr/z rk1 = rk1*(b+k-1.0_wp)*(b-c+k)/(k*k) rk2 = rk1 do j = k + 1 , k + mab rk2 = rk2*(b+j-1.0_wp)*(b-c+j)/j enddo sj1 = sj1 + (a-1.0_wp)/(k*(a+k-1.0_wp)) + (a-c-1.0_wp) & & /(k*(a-c+k-1.0_wp)) sj2 = sj1 do j = k + 1 , k + mab sj2 = sj2 + 1.0_wp/j enddo zp = -2.0_wp*gamma - pa - pac + sj2 - 1.0_wp/(k+a-c) & & - pi/tan(pi*(k+a-c)) + log(-z) zf1 = zf1 + rk2*zr*zp ws = abs(zf1) if ( abs((ws-w0)/ws)<eps ) exit w0 = ws enddo Zhf = zf0 + zf1 endif endif a = aa b = bb if ( k>150 ) Isfer = 5 end !***************************************************************************************** !> ! Compute the integrals of Airy fnctions with ! respect to t from 0 and x ( x ≥ 0 ) subroutine itairy(x,Apt,Bpt,Ant,Bnt) ! Input : x --- Upper limit of the integral ! Output : APT --- Integration of Ai(t) from 0 and x ! BPT --- Integration of Bi(t) from 0 and x ! ANT --- Integration of Ai(-t) from 0 and x ! BNT --- Integration of Bi(-t) from 0 and x real(wp) a , Ant , Apt , Bnt , Bpt , c1 , c2 , eps , fx , & & gx , q0 , q1 , q2 , r , sr3 , su1 , su2 , & & su3 , su4 real(wp) su5 , su6 , x , xe , xp6 , xr1 , xr2 integer k , l dimension a(16) eps = 1.0e-15_wp c1 = .355028053887817d0 c2 = .258819403792807d0 sr3 = 1.732050807568877d0 if ( x==0.0_wp ) then Apt = 0.0_wp Bpt = 0.0_wp Ant = 0.0_wp Bnt = 0.0_wp elseif ( abs(x)<=9.25_wp ) then do l = 0 , 1 x = (-1)**l*x fx = x r = x do k = 1 , 40 r = r*(3.0_wp*k-2.0_wp)/(3.0_wp*k+1.0_wp)*x/(3.0_wp*k) & & *x/(3.0_wp*k-1.0_wp)*x fx = fx + r if ( abs(r)<abs(fx)*eps ) exit enddo gx = 0.5_wp*x*x r = gx do k = 1 , 40 r = r*(3.0_wp*k-1.0_wp)/(3.0_wp*k+2.0_wp)*x/(3.0_wp*k) & & *x/(3.0_wp*k+1.0_wp)*x gx = gx + r if ( abs(r)<abs(gx)*eps ) exit enddo Ant = c1*fx - c2*gx Bnt = sr3*(c1*fx+c2*gx) if ( l==0 ) then Apt = Ant Bpt = Bnt else Ant = -Ant Bnt = -Bnt x = -x endif enddo 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*sqrt(x)/1.5_wp xp6 = 1.0_wp/sqrt(6.0_wp*pi*xe) su1 = 1.0_wp r = 1.0_wp xr1 = 1.0_wp/xe do k = 1 , 16 r = -r*xr1 su1 = su1 + a(k)*r enddo su2 = 1.0_wp r = 1.0_wp do k = 1 , 16 r = r*xr1 su2 = su2 + a(k)*r enddo Apt = q0 - exp(-xe)*xp6*su1 Bpt = 2.0_wp*exp(xe)*xp6*su2 su3 = 1.0_wp r = 1.0_wp xr2 = 1.0_wp/(xe*xe) do k = 1 , 8 r = -r*xr2 su3 = su3 + a(2*k)*r enddo su4 = a(1)*xr1 r = xr1 do k = 1 , 7 r = -r*xr2 su4 = su4 + a(2*k+1)*r enddo su5 = su3 + su4 su6 = su3 - su4 Ant = q1 - q2*xp6*(su5*cos(xe)-su6*sin(xe)) Bnt = q2*xp6*(su5*sin(xe)+su6*cos(xe)) endif end !***************************************************************************************** !> ! Compute modified Bessel functions In(x) and ! Kn(x), and their derivatives subroutine ikna(n,x,Nm,Bi,Di,Bk,Dk) ! Input: x --- Argument of In(x) and Kn(x) ( x ≥ 0 ) ! n --- Order of In(x) and Kn(x) ! Output: BI(n) --- In(x) ! DI(n) --- In'(x) ! BK(n) --- Kn(x) ! DK(n) --- Kn'(x) ! NM --- Highest order computed real(wp) Bi , bi0 , bi1 , Bk , bk0 , bk1 , Di , di0 , & & di1 , Dk , dk0 , dk1 , f , f0 , f1 , g , g0 , & & g1 , h , h0 real(wp) h1 , s0 , x integer k , m , n , Nm dimension Bi(0:n) , Di(0:n) , Bk(0:n) , Dk(0:n) Nm = n if ( x<=1.0e-100_wp ) then do k = 0 , n Bi(k) = 0.0_wp Di(k) = 0.0_wp Bk(k) = 1.0e+300_wp Dk(k) = -1.0e+300_wp enddo Bi(0) = 1.0_wp Di(1) = 0.5_wp 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<=1 ) return if ( x>40.0 .and. n<int(0.25_wp*x) ) then h0 = bi0 h1 = bi1 do k = 2 , n h = -2.0_wp*(k-1.0_wp)/x*h1 + h0 Bi(k) = h h0 = h1 h1 = h enddo else m = msta1(x,200) if ( m<n ) then Nm = m else m = msta2(x,n,15) endif f0 = 0.0_wp f1 = 1.0e-100_wp f = 0.0_wp do k = m , 0 , -1 f = 2.0_wp*(k+1.0_wp)*f1/x + f0 if ( k<=Nm ) Bi(k) = f f0 = f1 f1 = f enddo s0 = bi0/f do k = 0 , Nm Bi(k) = s0*Bi(k) enddo endif g0 = bk0 g1 = bk1 do k = 2 , Nm g = 2.0_wp*(k-1.0_wp)/x*g1 + g0 Bk(k) = g g0 = g1 g1 = g enddo do k = 2 , Nm Di(k) = Bi(k-1) - k/x*Bi(k) Dk(k) = -Bk(k-1) - k/x*Bk(k) enddo end !***************************************************************************************** !> ! Compute Bessel functions Jn(z), Yn(z) and ! their derivatives for a complex argument subroutine cjynb(n,z,Nm,Cbj,Cdj,Cby,Cdy) ! Input : z --- Complex argument of Jn(z) and Yn(z) ! n --- Order of Jn(z) and Yn(z) ! Output: CBJ(n) --- Jn(z) ! CDJ(n) --- Jn'(z) ! CBY(n) --- Yn(z) ! CDY(n) --- Yn'(z) ! NM --- Highest order computed real(wp) a , a0 , a1 , b , b1 , r2p , y0 complex(wp) Cbj , cbj0 , cbj1 , cbjk , cbs , Cby , cby0 , cby1 , & & Cdj , Cdy , ce , cf , cf1 , cf2 , cp0 , cp1 , cq0 , & & cq1 , cs0 , csu complex(wp) csv , ct1 , ct2 , cu , cyy , z integer k , m , n , Nm dimension Cbj(0:n) , Cdj(0:n) , Cby(0:n) , Cdy(0:n) , a(4) , & & b(4) , a1(4) , b1(4) r2p = .63661977236758d0 y0 = abs(aimag(z)) a0 = abs(z) Nm = n if ( a0<1.0e-100_wp ) then do k = 0 , n Cbj(k) = (0.0_wp,0.0_wp) Cdj(k) = (0.0_wp,0.0_wp) Cby(k) = -(1.0e+300_wp,0.0_wp) Cdy(k) = (1.0e+300_wp,0.0_wp) enddo Cbj(0) = (1.0_wp,0.0_wp) Cdj(1) = (0.5_wp,0.0_wp) return endif if ( a0<=300.d0 .or. n>80 ) then if ( n==0 ) Nm = 1 m = msta1(a0,200) if ( m<Nm ) then Nm = m else m = msta2(a0,Nm,15) endif cbs = (0.0_wp,0.0_wp) csu = (0.0_wp,0.0_wp) csv = (0.0_wp,0.0_wp) cf2 = (0.0_wp,0.0_wp) cf1 = (1.0e-100_wp,0.0_wp) do k = m , 0 , -1 cf = 2.0_wp*(k+1.0_wp)/z*cf1 - cf2 if ( k<=Nm ) Cbj(k) = cf if ( k==2*int(k/2) .and. k/=0 ) then if ( y0<=1.0_wp ) then cbs = cbs + 2.0_wp*cf else cbs = cbs + (-1)**(k/2)*2.0_wp*cf endif csu = csu + (-1)**(k/2)*cf/k elseif ( k>1 ) then csv = csv + (-1)**(k/2)*k/(k*k-1.0_wp)*cf endif cf2 = cf1 cf1 = cf enddo if ( y0<=1.0_wp ) then cs0 = cbs + cf else cs0 = (cbs+cf)/cos(z) endif do k = 0 , Nm Cbj(k) = Cbj(k)/cs0 enddo ce = log(z/2.0_wp) + gamma Cby(0) = r2p*(ce*Cbj(0)-4.0_wp*csu/cs0) Cby(1) = r2p*(-Cbj(0)/z+(ce-1.0_wp)*Cbj(1)-4.0_wp*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.25_wp*pi cp0 = (1.0_wp,0.0_wp) do k = 1 , 4 cp0 = cp0 + a(k)*z**(-2*k) enddo cq0 = -0.125_wp/z do k = 1 , 4 cq0 = cq0 + b(k)*z**(-2*k-1) enddo 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.0_wp,0.0_wp) do k = 1 , 4 cp1 = cp1 + a1(k)*z**(-2*k) enddo cq1 = 0.375d0/z do k = 1 , 4 cq1 = cq1 + b1(k)*z**(-2*k-1) enddo cbj1 = cu*(cp1*cos(ct2)-cq1*sin(ct2)) cby1 = cu*(cp1*sin(ct2)+cq1*cos(ct2)) Cbj(1) = cbj1 Cby(1) = cby1 do k = 2 , Nm cbjk = 2.0_wp*(k-1.0_wp)/z*cbj1 - cbj0 Cbj(k) = cbjk cbj0 = cbj1 cbj1 = cbjk enddo endif Cdj(0) = -Cbj(1) do k = 1 , Nm Cdj(k) = Cbj(k-1) - k/z*Cbj(k) enddo if ( abs(Cbj(0))>1.0_wp ) Cby(1) = (Cbj(1)*Cby(0)-2.0_wp/(pi*z)) & & /Cbj(0) do k = 2 , Nm if ( abs(Cbj(k-1))>=abs(Cbj(k-2)) ) then cyy = (Cbj(k)*Cby(k-1)-2.0_wp/(pi*z))/Cbj(k-1) else cyy = (Cbj(k)*Cby(k-2)-4.0_wp*(k-1.0_wp)/(pi*z*z))/Cbj(k-2) endif Cby(k) = cyy enddo Cdy(0) = -Cby(1) do k = 1 , Nm Cdy(k) = Cby(k-1) - k/z*Cby(k) enddo end !***************************************************************************************** !> ! Compute modified Bessel functions In(x) and Kn(x), ! and their derivatives subroutine iknb(n,x,Nm,Bi,Di,Bk,Dk) ! Input: x --- Argument of In(x) and Kn(x) ( 0 ≤ x ≤ 700 ) ! n --- Order of In(x) and Kn(x) ! Output: BI(n) --- In(x) ! DI(n) --- In'(x) ! BK(n) --- Kn(x) ! DK(n) --- Kn'(x) ! NM --- Highest order computed real(wp) a0 , Bi , Bk , bkl , bs , Di , Dk , f , f0 ,& & f1 , g , g0 , g1 , r , s0 , sk0 , vt , x integer k , k0 , l , m , n , Nm dimension Bi(0:n) , Di(0:n) , Bk(0:n) , Dk(0:n) Nm = n if ( x<=1.0e-100_wp ) then do k = 0 , n Bi(k) = 0.0_wp Di(k) = 0.0_wp Bk(k) = 1.0e+300_wp Dk(k) = -1.0e+300_wp enddo Bi(0) = 1.0_wp Di(1) = 0.5_wp return endif if ( n==0 ) Nm = 1 m = msta1(x,200) if ( m<Nm ) then Nm = m else m = msta2(x,Nm,15) endif bs = 0.0_wp sk0 = 0.0_wp f = 0.0_wp f0 = 0.0_wp f1 = 1.0e-100_wp do k = m , 0 , -1 f = 2.0_wp*(k+1.0_wp)/x*f1 + f0 if ( k<=Nm ) Bi(k) = f if ( k/=0 .and. k==2*int(k/2) ) sk0 = sk0 + 4.0_wp*f/k bs = bs + 2.0_wp*f f0 = f1 f1 = f enddo s0 = exp(x)/(bs-f) do k = 0 , Nm Bi(k) = s0*Bi(k) enddo if ( x<=8.0_wp ) then Bk(0) = -(log(0.5_wp*x)+gamma)*Bi(0) + s0*sk0 Bk(1) = (1.0_wp/x-Bi(1)*Bk(0))/Bi(0) else a0 = sqrt(pi/(2.0_wp*x))*exp(-x) k0 = 16 if ( x>=25.0_wp ) k0 = 10 if ( x>=80.0_wp ) k0 = 8 if ( x>=200.0_wp ) k0 = 6 do l = 0 , 1 bkl = 1.0_wp vt = 4.0_wp*l r = 1.0_wp do k = 1 , k0 r = 0.125_wp*r*(vt-(2.0_wp*k-1.0_wp)**2)/(k*x) bkl = bkl + r enddo Bk(l) = a0*bkl enddo endif g0 = Bk(0) g1 = Bk(1) do k = 2 , Nm g = 2.0_wp*(k-1.0_wp)/x*g1 + g0 Bk(k) = g g0 = g1 g1 = g enddo Di(0) = Bi(1) Dk(0) = -Bk(1) do k = 1 , Nm Di(k) = Bi(k-1) - k/x*Bi(k) Dk(k) = -Bk(k-1) - k/x*Bk(k) enddo end !***************************************************************************************** !> ! Compute the associated Legendre functions ! Pmn(x) and their derivatives Pmn'(x) for ! real argument subroutine lpmn(Mm,m,n,x,Pm,Pd) ! Input : x --- Argument of Pmn(x) ! m --- Order of Pmn(x), m = 0,1,2,...,n ! n --- Degree of Pmn(x), n = 0,1,2,...,N ! mm --- Physical dimension of PM and PD ! Output: PM(m,n) --- Pmn(x) ! PD(m,n) --- Pmn'(x) real(wp) Pd , Pm , x , xq , xs integer i , j , ls , m , Mm , n dimension Pm(0:Mm,0:n) , Pd(0:Mm,0:n) do i = 0 , n do j = 0 , m Pm(j,i) = 0.0_wp Pd(j,i) = 0.0_wp enddo enddo Pm(0,0) = 1.0_wp if ( n==0 ) return if ( abs(x)==1.0_wp ) then do i = 1 , n Pm(0,i) = x**i Pd(0,i) = 0.5_wp*i*(i+1.0_wp)*x**(i+1) enddo do j = 1 , n do i = 1 , m if ( i==1 ) then Pd(i,j) = dinf() elseif ( i==2 ) then Pd(i,j) = -0.25_wp*(j+2)*(j+1)*j*(j-1)*x**(j+1) endif enddo enddo return endif ls = 1 if ( abs(x)>1.0_wp ) ls = -1 xq = sqrt(ls*(1.0_wp-x*x)) ! Ensure connection to the complex-valued function for |x| > 1 if ( x<-1d0 ) xq = -xq xs = ls*(1.0_wp-x*x) do i = 1 , m Pm(i,i) = -ls*(2.0_wp*i-1.0_wp)*xq*Pm(i-1,i-1) enddo do i = 0 , min(m,n-1) Pm(i,i+1) = (2.0_wp*i+1.0_wp)*x*Pm(i,i) enddo do i = 0 , m do j = i + 2 , n Pm(i,j) = ((2.0_wp*j-1.0_wp)*x*Pm(i,j-1)-(i+j-1.0_wp)*Pm(i,j-2)& & )/(j-i) enddo enddo Pd(0,0) = 0.0_wp do j = 1 , n Pd(0,j) = ls*j*(Pm(0,j-1)-x*Pm(0,j))/xs enddo do i = 1 , m do j = i , n Pd(i,j) = ls*i*x*Pm(i,j)/xs + (j+i)*(j-i+1.0_wp)/xq*Pm(i-1,j) enddo enddo end !***************************************************************************************** !> ! Compute Mathieu functions cem(x,q) and sem(x,q) ! and their derivatives ( q ≥ 0 ) subroutine mtu0(Kf,m,q,x,Csf,Csd) ! Input : KF --- Function code ! KF=1 for computing cem(x,q) and cem'(x,q) ! KF=2 for computing sem(x,q) and sem'(x,q) ! m --- Order of Mathieu functions ! q --- Parameter of Mathieu functions ! x --- Argument of Mathieu functions (in degrees) ! Output: CSF --- cem(x,q) or sem(x,q) ! CSD --- cem'x,q) or sem'x,q) ! Routines called: ! (1) CVA2 for computing the characteristic values ! (2) FCOEF for computing the expansion coefficients real(wp) a , Csd , Csf , fg , q , qm , rd , & & x , xr integer ic , k , kd , Kf , km , m dimension fg(251) real(wp),parameter :: eps = 1.0e-14_wp if ( Kf==1 .and. m==2*int(m/2) ) kd = 1 if ( Kf==1 .and. m/=2*int(m/2) ) kd = 2 if ( Kf==2 .and. m/=2*int(m/2) ) kd = 3 if ( Kf==2 .and. m==2*int(m/2) ) kd = 4 call cva2(kd,m,q,a) if ( q<=1.0_wp ) 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>251 ) then Csf = dnan() Csd = dnan() return endif call fcoef(kd,m,q,a,fg) ic = int(m/2) + 1 rd = 1.74532925199433d-2 xr = x*rd Csf = 0.0_wp do k = 1 , km if ( kd==1 ) then Csf = Csf + fg(k)*cos((2*k-2)*xr) elseif ( kd==2 ) then Csf = Csf + fg(k)*cos((2*k-1)*xr) elseif ( kd==3 ) then Csf = Csf + fg(k)*sin((2*k-1)*xr) elseif ( kd==4 ) then Csf = Csf + fg(k)*sin(2*k*xr) endif if ( k>=ic .and. abs(fg(k))<abs(Csf)*eps ) exit enddo Csd = 0.0_wp do k = 1 , km if ( kd==1 ) then Csd = Csd - (2*k-2)*fg(k)*sin((2*k-2)*xr) elseif ( kd==2 ) then Csd = Csd - (2*k-1)*fg(k)*sin((2*k-1)*xr) elseif ( kd==3 ) then Csd = Csd + (2*k-1)*fg(k)*cos((2*k-1)*xr) elseif ( kd==4 ) then Csd = Csd + 2.0_wp*k*fg(k)*cos(2*k*xr) endif if ( k>=ic .and. abs(fg(k))<abs(Csd)*eps ) exit enddo end !***************************************************************************************** !> ! Compute complex Bessel functions Y0(z), Y1(z) ! and their derivatives subroutine cy01(Kf,z,Zf,Zd) ! Input : z --- Complex argument of Yn(z) ( n=0,1 ) ! KF --- Function choice code ! KF=0 for ZF=Y0(z) and ZD=Y0'(z) ! KF=1 for ZF=Y1(z) and ZD=Y1'(z) ! KF=2 for ZF=Y1'(z) and ZD=Y1''(z) ! Output: ZF --- Y0(z) or Y1(z) or Y1'(z) ! ZD --- Y0'(z) or Y1'(z) or Y1''(z) real(wp) a , a0 , a1 , b , b1 , rp2 , w0 , w1 complex(wp) cbj0 , cbj1 , cby0 , cby1 , cdy0 , cdy1 , ci , cp , & & cp0 , cp1 , cq0 , cq1 , cr , cs , ct1 , ct2 , cu , z , & & z1 , z2 complex(wp) Zd , Zf integer k , k0 , Kf dimension a(12) , b(12) , a1(12) , b1(12) rp2 = 2.0_wp/pi ci = (0.0_wp,1.0_wp) a0 = abs(z) z2 = z*z z1 = z if ( a0==0.0_wp ) then cbj0 = (1.0_wp,0.0_wp) cbj1 = (0.0_wp,0.0_wp) cby0 = -(1.0d300,0.0_wp) cby1 = -(1.0d300,0.0_wp) cdy0 = (1.0d300,0.0_wp) cdy1 = (1.0d300,0.0_wp) goto 300 endif if ( real(z,wp)<0.0_wp ) z1 = -z if ( a0<=12.0_wp ) then cbj0 = (1.0_wp,0.0_wp) cr = (1.0_wp,0.0_wp) do k = 1 , 40 cr = -0.25_wp*cr*z2/(k*k) cbj0 = cbj0 + cr if ( abs(cr)<abs(cbj0)*1.0e-15_wp ) exit enddo cbj1 = (1.0_wp,0.0_wp) cr = (1.0_wp,0.0_wp) do k = 1 , 40 cr = -0.25_wp*cr*z2/(k*(k+1.0_wp)) cbj1 = cbj1 + cr if ( abs(cr)<abs(cbj1)*1.0e-15_wp ) exit enddo cbj1 = 0.5_wp*z1*cbj1 w0 = 0.0_wp cr = (1.0_wp,0.0_wp) cs = (0.0_wp,0.0_wp) do k = 1 , 40 w0 = w0 + 1.0_wp/k cr = -0.25_wp*cr/(k*k)*z2 cp = cr*w0 cs = cs + cp if ( abs(cp)<abs(cs)*1.0e-15_wp ) exit enddo cby0 = rp2*(log(z1/2.0_wp)+gamma)*cbj0 - rp2*cs w1 = 0.0_wp cr = (1.0_wp,0.0_wp) cs = (1.0_wp,0.0_wp) do k = 1 , 40 w1 = w1 + 1.0_wp/k cr = -0.25_wp*cr/(k*(k+1))*z2 cp = cr*(2.0_wp*w1+1.0_wp/(k+1.0_wp)) cs = cs + cp if ( abs(cp)<abs(cs)*1.0e-15_wp ) exit enddo cby1 = rp2*((log(z1/2.0_wp)+gamma)*cbj1-1.0_wp/z1-0.25_wp*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>=35.0_wp ) k0 = 10 if ( a0>=50.0_wp ) k0 = 8 ct1 = z1 - .25_wp*pi cp0 = (1.0_wp,0.0_wp) do k = 1 , k0 cp0 = cp0 + a(k)*z1**(-2*k) enddo cq0 = -0.125_wp/z1 do k = 1 , k0 cq0 = cq0 + b(k)*z1**(-2*k-1) enddo 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.0_wp,0.0_wp) do k = 1 , k0 cp1 = cp1 + a1(k)*z1**(-2*k) enddo cq1 = 0.375d0/z1 do k = 1 , k0 cq1 = cq1 + b1(k)*z1**(-2*k-1) enddo cbj1 = cu*(cp1*cos(ct2)-cq1*sin(ct2)) cby1 = cu*(cp1*sin(ct2)+cq1*cos(ct2)) endif if ( real(z,wp)<0.0_wp ) then if ( aimag(z)<0.0_wp ) cby0 = cby0 - 2.0_wp*ci*cbj0 if ( aimag(z)>0.0_wp ) cby0 = cby0 + 2.0_wp*ci*cbj0 if ( aimag(z)<0.0_wp ) cby1 = -(cby1-2.0_wp*ci*cbj1) if ( aimag(z)>0.0_wp ) cby1 = -(cby1+2.0_wp*ci*cbj1) cbj1 = -cbj1 endif cdy0 = -cby1 cdy1 = cby0 - 1.0_wp/z*cby1 300 if ( Kf==0 ) then Zf = cby0 Zd = cdy0 elseif ( Kf==1 ) then Zf = cby1 Zd = cdy1 elseif ( Kf==2 ) then Zf = cdy1 Zd = -cdy1/z - (1.0_wp-1.0_wp/(z*z))*cby1 endif end !***************************************************************************************** !> ! Compute modified Fresnel integrals F±(x) ! and K±(x) subroutine ffk(Ks,x,Fr,Fi,Fm,Fa,Gr,Gi,Gm,Ga) ! Input : x --- Argument of F±(x) and K±(x) ! KS --- Sign code ! KS=0 for calculating F+(x) and K+(x) ! KS=1 for calculating F_(x) and K_(x) ! Output: FR --- Re[F±(x)] ! FI --- Im[F±(x)] ! FM --- |F±(x)| ! FA --- Arg[F±(x)] (Degs.) ! GR --- Re[K±(x)] ! GI --- Im[K±(x)] ! GM --- |K±(x)| ! GA --- Arg[K±(x)] (Degs.) real(wp) c1 , cs , eps , Fa , Fi , fi0 , Fm , Fr , Ga , & & Gi , Gm , Gr , p2p , pp2 , s1 , srd , ss , & & x , x2 real(wp) x4 , xa , xc , xf , xf0 , xf1 , xg , xp , xq , & & xq2 , xr , xs , xsu , xw integer k , Ks , m srd = 57.29577951308233d0 eps = 1.0e-15_wp pp2 = 1.2533141373155d0 p2p = .7978845608028654d0 xa = abs(x) x2 = x*x x4 = x2*x2 if ( x==0.0_wp ) then Fr = 0.5_wp*sqrt(halfpi) Fi = (-1)**Ks*Fr Fm = sqrt(0.25_wp*pi) Fa = (-1)**Ks*45.0d0 Gr = 0.5_wp Gi = 0.0_wp Gm = 0.5_wp Ga = 0.0_wp else if ( xa<=2.5_wp ) then xr = p2p*xa c1 = xr do k = 1 , 50 xr = -0.5_wp*xr*(4.0_wp*k-3.0_wp)/k/(2.0_wp*k-1.0_wp) & & /(4.0_wp*k+1.0_wp)*x4 c1 = c1 + xr if ( abs(xr/c1)<eps ) exit enddo s1 = p2p*xa*xa*xa/3.0_wp xr = s1 do k = 1 , 50 xr = -0.5_wp*xr*(4.0_wp*k-1.0_wp)/k/(2.0_wp*k+1.0_wp) & & /(4.0_wp*k+3.0_wp)*x4 s1 = s1 + xr if ( abs(xr/s1)<eps ) goto 50 enddo elseif ( xa<5.5_wp ) then m = int(42+1.75*x2) xsu = 0.0_wp xc = 0.0_wp xs = 0.0_wp xf1 = 0.0_wp xf0 = 1d-100 do k = m , 0 , -1 xf = (2.0_wp*k+3.0_wp)*xf0/x2 - xf1 if ( k==2*int(k/2) ) then xc = xc + xf else xs = xs + xf endif xsu = xsu + (2.0_wp*k+1.0_wp)*xf*xf xf1 = xf0 xf0 = xf enddo xq = sqrt(xsu) xw = p2p*xa/xq c1 = xc*xw s1 = xs*xw else xr = 1.0_wp xf = 1.0_wp do k = 1 , 12 xr = -0.25_wp*xr*(4.0_wp*k-1.0_wp)*(4.0_wp*k-3.0_wp)/x4 xf = xf + xr enddo xr = 1.0_wp/(2.0_wp*xa*xa) xg = xr do k = 1 , 12 xr = -0.25_wp*xr*(4.0_wp*k+1.0_wp)*(4.0_wp*k-1.0_wp)/x4 xg = xg + xr enddo c1 = 0.5_wp + (xf*sin(x2)-xg*cos(x2))/sqrt(twopi)/xa s1 = 0.5_wp - (xf*cos(x2)+xg*sin(x2))/sqrt(twopi)/xa endif 50 Fr = pp2*(0.5_wp-c1) fi0 = pp2*(0.5_wp-s1) Fi = (-1)**Ks*fi0 Fm = sqrt(Fr*Fr+Fi*Fi) if ( Fr>=0.0_wp ) then Fa = srd*atan(Fi/Fr) elseif ( Fi>0.0_wp ) then Fa = srd*(atan(Fi/Fr)+pi) elseif ( Fi<0.0_wp ) then Fa = srd*(atan(Fi/Fr)-pi) endif xp = x*x + pi/4.0_wp cs = cos(xp) ss = sin(xp) xq2 = 1.0_wp/sqrtpi Gr = xq2*(Fr*cs+fi0*ss) Gi = (-1)**Ks*xq2*(fi0*cs-Fr*ss) Gm = sqrt(Gr*Gr+Gi*Gi) if ( Gr>=0.0_wp ) then Ga = srd*atan(Gi/Gr) elseif ( Gi>0.0_wp ) then Ga = srd*(atan(Gi/Gr)+pi) elseif ( Gi<0.0_wp ) then Ga = srd*(atan(Gi/Gr)-pi) endif if ( x<0.0_wp ) then Fr = pp2 - Fr Fi = (-1)**Ks*pp2 - Fi Fm = sqrt(Fr*Fr+Fi*Fi) Fa = srd*atan(Fi/Fr) Gr = cos(x*x) - Gr Gi = -(-1)**Ks*sin(x*x) - Gi Gm = sqrt(Gr*Gr+Gi*Gi) Ga = srd*atan(Gi/Gr) endif endif end !***************************************************************************************** !> ! Compute Airy functions and their derivatives subroutine airya(x,Ai,Bi,Ad,Bd) ! Input: x --- Argument of Airy function ! Output: AI --- Ai(x) ! BI --- Bi(x) ! AD --- Ai'(x) ! BD --- Bi'(x) real(wp) Ad , Ai , Bd , Bi , c1 , c2 , pir , sr3 , vi1 , & & vi2 , vj1 , vj2 , vk1 , vk2 , vy1 , vy2 , x , & & xa , xq , z xa = abs(x) pir = 0.318309886183891d0 c1 = 0.355028053887817d0 c2 = 0.258819403792807d0 sr3 = 1.732050807568877d0 z = xa**1.5/1.5_wp xq = sqrt(xa) call ajyik(z,vj1,vj2,vy1,vy2,vi1,vi2,vk1,vk2) if ( x==0.0_wp ) then Ai = c1 Bi = sr3*c1 Ad = -c2 Bd = sr3*c2 elseif ( x>0.0_wp ) then Ai = pir*xq/sr3*vk1 Bi = xq*(pir*vk1+2.0_wp/sr3*vi1) Ad = -xa/sr3*pir*vk2 Bd = xa*(pir*vk2+2.0_wp/sr3*vi2) else Ai = 0.5_wp*xq*(vj1-vy1/sr3) Bi = -0.5_wp*xq*(vj1/sr3+vy1) Ad = 0.5_wp*xa*(vj2+vy2/sr3) Bd = 0.5_wp*xa*(vj2/sr3-vy2) endif end !***************************************************************************************** !> ! Compute Airy functions and their derivatives subroutine airyb(x,Ai,Bi,Ad,Bd) ! Input: x --- Argument of Airy function ! Output: AI --- Ai(x) ! BI --- Bi(x) ! AD --- Ai'(x) ! BD --- Bi'(x) real(wp) Ad , Ai , Bd , Bi , c1 , c2 , ck , df , dg , dk ,& & eps , fx , gx , r , rp , sad , sai , sbd , & & sbi real(wp) sda , sdb , sr3 , ssa , ssb , x , xa , xar , & & xcs , xe , xf , xm , xp1 , xq , xr1 , xr2 , xss integer k , km , km2 , kmax dimension ck(51) , dk(51) eps = 1.0e-15_wp c1 = 0.355028053887817d0 c2 = 0.258819403792807d0 sr3 = 1.732050807568877d0 xa = abs(x) xq = sqrt(xa) xm = 8.0_wp if ( x>0.0_wp ) xm = 5.0_wp if ( x==0.0_wp ) then Ai = c1 Bi = sr3*c1 Ad = -c2 Bd = sr3*c2 return endif if ( xa<=xm ) then fx = 1.0_wp r = 1.0_wp do k = 1 , 40 r = r*x/(3.0_wp*k)*x/(3.0_wp*k-1.0_wp)*x fx = fx + r if ( abs(r)<abs(fx)*eps ) exit enddo gx = x r = x do k = 1 , 40 r = r*x/(3.0_wp*k)*x/(3.0_wp*k+1.0_wp)*x gx = gx + r if ( abs(r)<abs(gx)*eps ) exit enddo Ai = c1*fx - c2*gx Bi = sr3*(c1*fx+c2*gx) df = 0.5_wp*x*x r = df do k = 1 , 40 r = r*x/(3.0_wp*k)*x/(3.0_wp*k+2.0_wp)*x df = df + r if ( abs(r)<abs(df)*eps ) exit enddo dg = 1.0_wp r = 1.0_wp do k = 1 , 40 r = r*x/(3.0_wp*k)*x/(3.0_wp*k-2.0_wp)*x dg = dg + r if ( abs(r)<abs(dg)*eps ) exit enddo Ad = c1*df - c2*dg Bd = sr3*(c1*df+c2*dg) else km = int(24.5-xa) if ( xa<6.0_wp ) km = 14 if ( xa>15.0_wp ) km = 10 if ( x>0.0_wp ) then kmax = km else ! Choose cutoffs so that the remainder term in asymptotic ! expansion is epsilon size. The X<0 branch needs to be fast ! in order to make AIRYZO efficient if ( xa>70.0_wp ) km = 3 if ( xa>500.0_wp ) km = 2 if ( xa>1000.0_wp ) km = 1 km2 = km if ( xa>150.0_wp ) km2 = 1 if ( xa>3000.0_wp ) km2 = 0 kmax = 2*km + 1 endif xe = xa*xq/1.5_wp xr1 = 1.0_wp/xe xar = 1.0_wp/xq xf = sqrt(xar) rp = 0.5641895835477563d0 r = 1.0_wp do k = 1 , kmax r = r*(6.0_wp*k-1.0_wp)/216.0d0*(6.0_wp*k-3.0_wp) & & /k*(6.0_wp*k-5.0_wp)/(2.0_wp*k-1.0_wp) ck(k) = r dk(k) = -(6.0_wp*k+1.0_wp)/(6.0_wp*k-1.0_wp)*ck(k) enddo if ( x>0.0_wp ) then sai = 1.0_wp sad = 1.0_wp r = 1.0_wp do k = 1 , km r = -r*xr1 sai = sai + ck(k)*r sad = sad + dk(k)*r enddo sbi = 1.0_wp sbd = 1.0_wp r = 1.0_wp do k = 1 , km r = r*xr1 sbi = sbi + ck(k)*r sbd = sbd + dk(k)*r enddo xp1 = exp(-xe) Ai = 0.5_wp*rp*xf*xp1*sai Bi = rp*xf/xp1*sbi Ad = -0.5_wp*rp/xf*xp1*sad Bd = rp/xf/xp1*sbd else xcs = cos(xe+pi/4.0_wp) xss = sin(xe+pi/4.0_wp) ssa = 1.0_wp sda = 1.0_wp r = 1.0_wp xr2 = 1.0_wp/(xe*xe) do k = 1 , km r = -r*xr2 ssa = ssa + ck(2*k)*r sda = sda + dk(2*k)*r enddo ssb = ck(1)*xr1 sdb = dk(1)*xr1 r = xr1 do k = 1 , km2 r = -r*xr2 ssb = ssb + ck(2*k+1)*r sdb = sdb + dk(2*k+1)*r enddo 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 end !***************************************************************************************** !> ! Compute the expansion coefficients of the ! prolate and oblate spheroidal functions, c2k subroutine scka(m,n,c,Cv,Kd,Ck) ! Input : m --- Mode parameter ! n --- Mode parameter ! c --- Spheroidal parameter ! cv --- Characteristic value ! KD --- Function code ! KD=1 for prolate; KD=-1 for oblate ! Output: CK(k) --- Expansion coefficients ck; ! CK(1), CK(2),... correspond to ! c0, c2,... real(wp) c , Ck , cs , Cv , f , f0 , f1 , f2 , fl , fs , & & r1 , r2 , s0 , su1 , su2 integer ip , j , k , k1 , kb , Kd , m , n , nm dimension Ck(200) if ( c<=1.0d-10 ) c = 1.0d-10 nm = 25 + int((n-m)/2+c) cs = c*c*Kd ip = 1 if ( n-m==2*int((n-m)/2) ) ip = 0 fs = 1.0_wp f1 = 0.0_wp f0 = 1.0e-100_wp kb = 0 Ck(nm+1) = 0.0_wp fl = 0.0_wp do k = nm , 1 , -1 f = (((2.0_wp*k+m+ip)*(2.0_wp*k+m+1.0_wp+ip)-Cv+cs) & & *f0-4.0_wp*(k+1.0_wp)*(k+m+1.0_wp)*f1)/cs if ( abs(f)>abs(Ck(k+1)) ) then Ck(k) = f f1 = f0 f0 = f if ( abs(f)>1.0d+100 ) then do k1 = nm , k , -1 Ck(k1) = Ck(k1)*1.0e-100_wp enddo f1 = f1*1.0e-100_wp f0 = f0*1.0e-100_wp endif else kb = k fl = Ck(k+1) f1 = 1.0_wp f2 = 0.25_wp*((m+ip)*(m+ip+1.0_wp)-Cv+cs)/(m+1.0_wp)*f1 Ck(1) = f1 if ( kb==1 ) then fs = f2 elseif ( kb==2 ) then Ck(2) = f2 fs = 0.125_wp*(((m+ip+2.0_wp)*(m+ip+3.0_wp)-Cv+cs)*f2-cs*f1) & & /(m+2.0_wp) else Ck(2) = f2 do j = 3 , kb + 1 f = 0.25_wp*(((2.0_wp*j+m+ip-4.0_wp)*(2.0_wp*j+m+ip-3.0_wp)-Cv+cs) & & *f2-cs*f1)/((j-1.0_wp)*(j+m-1.0_wp)) if ( j<=kb ) Ck(j) = f f1 = f2 f2 = f enddo fs = f endif goto 100 endif enddo 100 su1 = 0.0_wp do k = 1 , kb su1 = su1 + Ck(k) enddo su2 = 0.0_wp do k = kb + 1 , nm su2 = su2 + Ck(k) enddo r1 = 1.0_wp do j = 1 , (n+m+ip)/2 r1 = r1*(j+0.5_wp*(n+m+ip)) enddo r2 = 1.0_wp do j = 1 , (n-m-ip)/2 r2 = -r2*j enddo if ( kb==0 ) then s0 = r1/(2.0_wp**n*r2*su2) else s0 = r1/(2.0_wp**n*r2*(fl/fs*su1+su2)) endif do k = 1 , kb Ck(k) = fl/fs*s0*Ck(k) enddo do k = kb + 1 , nm Ck(k) = s0*Ck(k) enddo end !***************************************************************************************** !> ! Compute the expansion coefficients of the ! prolate and oblate spheroidal functions subroutine sckb(m,n,c,Df,Ck) ! Input : m --- Mode parameter ! n --- Mode parameter ! c --- Spheroidal parameter ! DF(k) --- Expansion coefficients dk ! Output: CK(k) --- Expansion coefficients ck; ! CK(1), CK(2), ... correspond to ! c0, c2, ... real(wp) c , Ck , d1 , d2 , d3 , Df , fac , r , r1 , reg ,& & sum , sw integer i , i1 , i2 , ip , k , m , n , nm dimension Df(200) , Ck(200) if ( c<=1.0d-10 ) c = 1.0d-10 nm = 25 + int(0.5*(n-m)+c) ip = 1 if ( n-m==2*int((n-m)/2) ) ip = 0 reg = 1.0_wp if ( m+nm>80 ) reg = 1.0e-200_wp fac = -0.5_wp**m sw = 0.0_wp do k = 0 , nm - 1 fac = -fac i1 = 2*k + ip + 1 r = reg do i = i1 , i1 + 2*m - 1 r = r*i enddo i2 = k + m + ip do i = i2 , i2 + k - 1 r = r*(i+0.5_wp) enddo sum = r*Df(k+1) do i = k + 1 , nm d1 = 2.0_wp*i + ip d2 = 2.0_wp*m + d1 d3 = i + m + ip - 0.5_wp r = r*d2*(d2-1.0_wp)*i*(d3+k)/(d1*(d1-1.0_wp)*(i-k)*d3) sum = sum + r*Df(i+1) if ( abs(sw-sum)<abs(sum)*1.0d-14 ) exit sw = sum enddo r1 = reg do i = 2 , m + k r1 = r1*i enddo Ck(k+1) = fac*sum/r1 enddo end !***************************************************************************************** !> ! Compute complex parabolic cylinder function Dn(z) ! for large argument subroutine cpdla(n,z,Cdn) ! Input: z --- Complex argument of Dn(z) ! n --- Order of Dn(z) (n = 0,±1,±2,…) ! Output: CDN --- Dn(z) complex(wp) cb0 , Cdn , cr , z integer k , n cb0 = z**n*exp(-0.25_wp*z*z) cr = (1.0_wp,0.0_wp) Cdn = (1.0_wp,0.0_wp) do k = 1 , 16 cr = -0.5_wp*cr*(2.0_wp*k-n-1.0_wp)*(2.0_wp*k-n-2.0_wp)/(k*z*z) Cdn = Cdn + cr if ( abs(cr)<abs(Cdn)*1.0e-12_wp ) exit enddo Cdn = cb0*Cdn end !***************************************************************************************** !> ! Compute the complex zeros of Fresnel integral C(z) ! or S(z) using modified Newton's iteration method subroutine fcszo(Kf,Nt,Zo) ! Input : KF --- Function code ! KF=1 for C(z) or KF=2 for S(z) ! NT --- Total number of zeros ! Output: ZO(L) --- L-th zero of C(z) or S(z) integer i , it , j , Kf , nr , Nt real(wp) psq , px , py , w , w0 complex(wp) z , zd , zf , zfd , zgd , Zo , zp , zq , zw dimension Zo(Nt) psq = 0.0_wp w = 0.0_wp do nr = 1 , Nt if ( Kf==1 ) psq = sqrt(4.0_wp*nr-1.0_wp) if ( Kf==2 ) psq = 2.0_wp*nr**(0.5) px = psq - log(pi*psq)/(pi*pi*psq**3.0_wp) py = log(pi*psq)/(pi*psq) z = cmplx(px,py,kind=wp) if ( Kf==2 ) then if ( nr==2 ) z = (2.8334,0.2443) if ( nr==3 ) z = (3.4674,0.2185) if ( nr==4 ) z = (4.0025,0.2008) endif it = 0 50 it = it + 1 if ( Kf==1 ) call cfc(z,zf,zd) if ( Kf==2 ) call cfs(z,zf,zd) zp = (1.0_wp,0.0_wp) do i = 1 , nr - 1 zp = zp*(z-Zo(i)) enddo zfd = zf/zp zq = (0.0_wp,0.0_wp) do i = 1 , nr - 1 zw = (1.0_wp,0.0_wp) do j = 1 , nr - 1 if ( j/=i ) zw = zw*(z-Zo(j)) enddo zq = zq + zw enddo zgd = (zd-zq*zfd)/zp z = z - zfd/zgd w0 = w w = abs(z) if ( it<=50 .and. abs((w-w0)/w)>1.0e-12_wp ) goto 50 Zo(nr) = z enddo end !***************************************************************************************** !> ! Compute exponential integral E1(x) subroutine e1xa(x,e1) ! Input : x --- Argument of E1(x) ! Output: E1 --- E1(x) ( x > 0 ) real(wp) e1 , es1 , es2 , x if ( x==0.0_wp ) then e1 = 1.0e+300_wp elseif ( x<=1.0_wp ) then e1 = -log(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 end !***************************************************************************************** !> ! Compute the associated Legendre function ! Pmv(x) with an integer order and an arbitrary ! nonnegative degree v subroutine lpmv0(v,m,x,Pmv) ! Input : x --- Argument of Pm(x) ( -1 ≤ x ≤ 1 ) ! m --- Order of Pmv(x) ! v --- Degree of Pmv(x) ! Output: PMV --- Pmv(x) real(wp) c0 , pa , Pmv , pss , psv , pv0 ,& & qr , r , r0 , r1 , r2 , rg , s , s0 , s1 , s2 , v real(wp) v0 , vs , x , xq integer j , k , m , nv real(wp),parameter :: eps = 1.0e-14_wp nv = int(v) v0 = v - nv if ( x==-1.0_wp .and. v/=nv ) then if ( m==0 ) Pmv = -1.0e+300_wp if ( m/=0 ) Pmv = 1.0e+300_wp return endif c0 = 1.0_wp if ( m/=0 ) then rg = v*(v+m) do j = 1 , m - 1 rg = rg*(v*v-j*j) enddo xq = sqrt(1.0_wp-x*x) r0 = 1.0_wp do j = 1 , m r0 = 0.5_wp*r0*xq/j enddo c0 = r0*rg endif if ( v0==0.0_wp ) then ! DLMF 14.3.4, 14.7.17, 15.2.4 Pmv = 1.0_wp r = 1.0_wp do k = 1 , nv - m r = 0.5_wp*r*(-nv+m+k-1.0_wp)*(nv+m+k)/(k*(k+m))*(1.0_wp+x) Pmv = Pmv + r enddo Pmv = (-1)**nv*c0*Pmv elseif ( x>=-0.35d0 ) then ! DLMF 14.3.4, 15.2.1 Pmv = 1.0_wp r = 1.0_wp do k = 1 , 100 r = 0.5_wp*r*(-v+m+k-1.0_wp)*(v+m+k)/(k*(m+k))*(1.0_wp-x) Pmv = Pmv + r if ( k>12 .and. abs(r/Pmv)<eps ) exit enddo Pmv = (-1)**m*c0*Pmv else ! DLMF 14.3.5, 15.8.10 vs = sin(v*pi)/pi pv0 = 0.0_wp if ( m/=0 ) then qr = sqrt((1.0_wp-x)/(1.0_wp+x)) r2 = 1.0_wp do j = 1 , m r2 = r2*qr*j enddo s0 = 1.0_wp r1 = 1.0_wp do k = 1 , m - 1 r1 = 0.5_wp*r1*(-v+k-1)*(v+k)/(k*(k-m))*(1.0_wp+x) s0 = s0 + r1 enddo pv0 = -vs*r2/m*s0 endif call psi_spec(v,psv) pa = 2.0_wp*(psv+gamma) + pi/tan(pi*v) + 1.0_wp/v s1 = 0.0_wp do j = 1 , m s1 = s1 + (j*j+v*v)/(j*(j*j-v*v)) enddo Pmv = pa + s1 - 1.0_wp/(m-v) + log(0.5_wp*(1.0_wp+x)) r = 1.0_wp do k = 1 , 100 r = 0.5_wp*r*(-v+m+k-1.0_wp)*(v+m+k)/(k*(k+m))*(1.0_wp+x) s = 0.0_wp do j = 1 , m s = s + ((k+j)**2+v*v)/((k+j)*((k+j)**2-v*v)) enddo s2 = 0.0_wp do j = 1 , k s2 = s2 + 1.0_wp/(j*(j*j-v*v)) enddo pss = pa + s + 2.0_wp*v*v*s2 - 1.0_wp/(m+k-v) & & + log(0.5_wp*(1.0_wp+x)) r2 = pss*r Pmv = Pmv + r2 if ( abs(r2/Pmv)<eps ) exit enddo Pmv = pv0 + Pmv*vs*c0 endif end !***************************************************************************************** !> ! Compute the associated Legendre function ! Pmv(x) with an integer order and an arbitrary ! degree v, using recursion for large degrees subroutine lpmv(v,m,x,Pmv) ! Input : x --- Argument of Pm(x) ( -1 ≤ x ≤ 1 ) ! m --- Order of Pmv(x) ! v --- Degree of Pmv(x) ! Output: PMV --- Pmv(x) real(wp) g1 , g2 , p0 , p1 , Pmv , v , v0 , & & vx , x integer j , m , mx , neg_m , nv if ( x==-1.0_wp .and. v/=int(v) ) then if ( m==0 ) Pmv = -dinf() if ( m/=0 ) Pmv = dinf() return endif vx = v mx = m ! DLMF 14.9.5 if ( v<0 ) vx = -vx - 1 neg_m = 0 if ( m<0 ) then if ( (vx+m+1)>0d0 .or. vx/=int(vx) ) then neg_m = 1 mx = -m else ! We don't handle cases where DLMF 14.9.3 doesn't help Pmv = dnan() return endif endif nv = int(vx) v0 = vx - nv if ( nv>2 .and. nv>mx ) then ! 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 j = mx + 2 , nv Pmv = ((2*(v0+j)-1)*x*p1-(v0+j-1+mx)*p0)/(v0+j-mx) p0 = p1 p1 = Pmv enddo else call lpmv0(vx,mx,x,Pmv) endif if ( neg_m/=0 .and. abs(Pmv)<1.0e+300_wp ) then ! DLMF 14.9.3 call gamma2(vx-mx+1,g1) call gamma2(vx+mx+1,g2) Pmv = Pmv*g1/g2*(-1)**mx endif end !***************************************************************************************** !> ! Compute the gamma function Г(z) or ln[Г(z)] ! for a complex argument subroutine cgama(x,y,Kf,Gr,Gi) ! Input : x --- Real part of z ! y --- Imaginary part of z ! KF --- Function code ! KF=0 for ln[Г(z)] ! KF=1 for Г(z) ! Output: GR --- Real part of ln[Г(z)] or Г(z) real(wp) a , g0 , Gi , gi1 , Gr , gr1 , si , sr , t ,& & th , th1 , th2 , x , x0 , x1 , y , y1 , z1 , z2 integer j , k , Kf , na 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/ if ( y==0.0_wp .and. x==int(x) .and. x<=0.0_wp ) then Gr = 1.0e+300_wp Gi = 0.0_wp return elseif ( x<0.0_wp ) then x1 = x y1 = y x = -x y = -y else y1 = 0.0_wp x1 = x endif x0 = x na = 0 if ( x<=7.0_wp ) then na = int(7-x) x0 = x + na endif z1 = sqrt(x0*x0+y*y) th = atan(y/x0) Gr = (x0-0.5_wp)*log(z1) - th*y - x0 + 0.5_wp*log(twopi) Gi = th*(x0-0.5_wp) + y*log(z1) - y do k = 1 , 10 t = z1**(1-2*k) Gr = Gr + a(k)*t*cos((2.0_wp*k-1.0_wp)*th) Gi = Gi - a(k)*t*sin((2.0_wp*k-1.0_wp)*th) enddo if ( x<=7.0_wp ) then gr1 = 0.0_wp gi1 = 0.0_wp do j = 0 , na - 1 gr1 = gr1 + 0.5_wp*log((x+j)**2+y*y) gi1 = gi1 + atan(y/(x+j)) enddo Gr = Gr - gr1 Gi = Gi - gi1 endif if ( x1<0.0_wp ) then z1 = sqrt(x*x+y*y) th1 = atan(y/x) sr = -sin(pi*x)*cosh(pi*y) si = -cos(pi*x)*sinh(pi*y) z2 = sqrt(sr*sr+si*si) th2 = atan(si/sr) if ( sr<0.0_wp ) th2 = pi + th2 Gr = log(pi/(z1*z2)) - Gr Gi = -th1 - th2 - Gi x = x1 y = y1 endif if ( Kf==1 ) then g0 = exp(Gr) Gr = g0*cos(Gi) Gi = g0*sin(Gi) endif end !***************************************************************************************** !> ! Compute the prolate and oblate spheroidal angular ! functions of the first kind and their derivatives subroutine aswfb(m,n,c,x,Kd,Cv,S1f,S1d) ! Input : m --- Mode parameter, m = 0,1,2,... ! n --- Mode parameter, n = m,m+1,... ! c --- Spheroidal parameter ! x --- Argument of angular function, |x| < 1.0 ! KD --- Function code ! KD=1 for prolate; KD=-1 for oblate ! cv --- Characteristic value ! Output: S1F --- Angular function of the first kind ! S1D --- Derivative of the angular function of ! the first kind real(wp) c , Cv , df , pd , pm , S1d , S1f , su1 , & & sw , x integer ip , k , Kd , m , mk , n , nm , nm2 dimension df(200) , pm(0:251) , pd(0:251) real(wp),parameter :: eps = 1.0e-14_wp ip = 1 if ( n-m==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.0_wp su1 = 0.0_wp do k = 1 , nm mk = m + 2*(k-1) + ip su1 = su1 + df(k)*pm(mk) if ( abs(sw-su1)<abs(su1)*eps ) exit sw = su1 enddo S1f = (-1)**m*su1 su1 = 0.0_wp do k = 1 , nm mk = m + 2*(k-1) + ip su1 = su1 + df(k)*pd(mk) if ( abs(sw-su1)<abs(su1)*eps ) exit sw = su1 enddo S1d = (-1)**m*su1 end !***************************************************************************************** !> ! Compute confluent hypergeometric function ! U(a,b,x) for small argument x subroutine chgus(a,b,x,Hu,Id) ! Input : a --- Parameter ! b --- Parameter ( b <> 0,-1,-2,...) ! x --- Argument ! Output: HU --- U(a,b,x) ! ID --- Estimated number of significant digits ! ! DLMF 13.2.42 with prefactors rewritten according to ! DLMF 5.5.3, M(a, b, x) with DLMF 13.2.2 real(wp) a , b , d1 , d2 , ga , gab , gb , gb2 , h0 , & & hmax , hmin , Hu , hu0 , hua , r1 , r2 , x ,& & xg1 , xg2 integer Id , j Id = -100 call gamma2(a,ga) call gamma2(b,gb) xg1 = 1.0_wp + a - b call gamma2(xg1,gab) xg2 = 2.0_wp - b call gamma2(xg2,gb2) hu0 = pi/sin(pi*b) r1 = hu0/(gab*gb) r2 = hu0*x**(1.0_wp-b)/(ga*gb2) Hu = r1 - r2 hmax = 0.0_wp hmin = 1.0e+300_wp h0 = 0.0_wp do j = 1 , 150 r1 = r1*(a+j-1.0_wp)/(j*(b+j-1.0_wp))*x r2 = r2*(a-b+j)/(j*(1.0_wp-b+j))*x Hu = Hu + r1 - r2 hua = abs(Hu) if ( hua>hmax ) hmax = hua if ( hua<hmin ) hmin = hua if ( abs(Hu-h0)<abs(Hu)*1.0e-15_wp ) exit h0 = Hu enddo d1 = log10(hmax) d2 = 0.0_wp if ( hmin/=0.0_wp ) d2 = log10(hmin) Id = 15 - abs(d1-d2) end !***************************************************************************************** !> ! Evaluate the integral H0(t)/t with respect to t ! from x to infinity subroutine itth0(x,Tth) ! Input : x --- Lower limit ( x ≥ 0 ) ! Output: TTH --- Integration of H0(t)/t from x to infinity real(wp) f0 , g0 , r , s , t , Tth , tty , x , xt integer k s = 1.0_wp r = 1.0_wp if ( x<24.5_wp ) then do k = 1 , 60 r = -r*x*x*(2.0_wp*k-1.0_wp)/(2.0_wp*k+1.0_wp)**3 s = s + r if ( abs(r)<abs(s)*1.0e-12_wp ) exit enddo Tth = pi/2.0_wp - 2.0_wp/pi*x*s else do k = 1 , 10 r = -r*(2.0_wp*k-1.0_wp)**3/((2.0_wp*k+1.0_wp)*x*x) s = s + r if ( abs(r)<abs(s)*1.0e-12_wp ) exit enddo Tth = 2.0_wp/(pi*x)*s t = 8.0_wp/x xt = x + .25_wp*pi f0 = (((((.18118e-2_wp*t-.91909e-2_wp)*t+.017033_wp)*t-.9394e-3_wp) & & *t-.051445_wp)*t-.11e-5_wp)*t + .7978846_wp g0 = (((((-.23731e-2_wp*t+.59842e-2_wp)*t+.24437e-2_wp)*t-.0233178_wp) & & *t+.595e-4_wp)*t+.1620695_wp)*t tty = (f0*sin(xt)-g0*cos(xt))/(sqrt(x)*x) Tth = Tth + tty endif end !***************************************************************************************** !> ! Compute gamma function Г(x) or ln[Г(x)] subroutine lgama(Kf,x,Gl) ! Input: x --- Argument of Г(x) ( x > 0 ) ! KF --- Function code ! KF=1 for Г(x); KF=0 for ln[Г(x)] ! Output: GL --- Г(x) or ln[Г(x)] real(wp) a , Gl , gl0 , x , x0 , x2 , xp integer k , Kf , n 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==1.0 .or. x==2.0_wp ) then Gl = 0.0_wp goto 100 elseif ( x<=7.0_wp ) then n = int(7-x) x0 = x + n endif x2 = 1.0_wp/(x0*x0) xp = 6.283185307179586477d0 gl0 = a(10) do k = 9 , 1 , -1 gl0 = gl0*x2 + a(k) enddo Gl = gl0/x0 + 0.5_wp*log(xp) + (x0-0.5_wp)*log(x0) - x0 if ( x<=7.0_wp ) then do k = 1 , n Gl = Gl - log(x0-1.0_wp) x0 = x0 - 1.0_wp enddo endif 100 if ( Kf==1 ) Gl = exp(Gl) end !***************************************************************************************** !> ! Compute Legendre functions Qn(x) and Qn'(x) subroutine lqna(n,x,Qn,Qd) ! Input : x --- Argument of Qn(x) ( -1 ≤ x ≤ 1 ) ! n --- Degree of Qn(x) ( n = 0,1,2,… ) ! Output: QN(n) --- Qn(x) ! QD(n) --- Qn'(x) ! ( 1.0D+300 stands for infinity ) integer k , n real(wp) q0 , q1 , Qd , qf , Qn , x dimension Qn(0:n) , Qd(0:n) if ( abs(x)==1.0_wp ) then do k = 0 , n Qn(k) = 1.0e+300_wp Qd(k) = -1.0e+300_wp enddo elseif ( abs(x)<1.0_wp ) then q0 = 0.5_wp*log((1.0_wp+x)/(1.0_wp-x)) q1 = x*q0 - 1.0_wp Qn(0) = q0 Qn(1) = q1 Qd(0) = 1.0_wp/(1.0_wp-x*x) Qd(1) = Qn(0) + x*Qd(0) do 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.0_wp-x*x) q0 = q1 q1 = qf enddo endif end !***************************************************************************************** !> ! Compute parabolic cylinder functions Dv(x) ! for large argument subroutine dvla(Va,x,Pd) ! Input: x --- Argument ! va --- Order ! Output: PD --- Dv(x) real(wp) a0 , ep , eps , gl , Pd , r , Va , vl , x , & & x1 integer k eps = 1.0e-12_wp ep = exp(-.25*x*x) a0 = abs(x)**Va*ep r = 1.0_wp Pd = 1.0_wp do k = 1 , 16 r = -0.5_wp*r*(2.0_wp*k-Va-1.0_wp)*(2.0_wp*k-Va-2.0_wp)/(k*x*x) Pd = Pd + r if ( abs(r/Pd)<eps ) exit enddo Pd = a0*Pd if ( x<0.0_wp ) then x1 = -x call vvla(Va,x1,vl) call gamma2(-Va,gl) Pd = pi*vl/gl + cos(pi*Va)*Pd endif end !***************************************************************************************** !> ! Compute modified Bessel functions I0(x), I1(1), ! K0(x) and K1(x), and their derivatives subroutine ik01a(x,Bi0,Di0,Bi1,Di1,Bk0,Dk0,Bk1,Dk1) ! Input : x --- Argument ( x ≥ 0 ) ! Output: BI0 --- I0(x) ! DI0 --- I0'(x) ! BI1 --- I1(x) ! DI1 --- I1'(x) ! BK0 --- K0(x) ! DK0 --- K0'(x) ! BK1 --- K1(x) ! DK1 --- K1'(x) real(wp) a , a1 , b , Bi0 , Bi1 , Bk0 , Bk1 , ca , cb , & & ct , Di0 , Di1 , Dk0 , Dk1 , r , w0 , & & ww , x real(wp) x2 , xr , xr2 integer k , k0 dimension a(12) , b(12) , a1(8) x2 = x*x if ( x==0.0_wp ) then Bi0 = 1.0_wp Bi1 = 0.0_wp Bk0 = 1.0e+300_wp Bk1 = 1.0e+300_wp Di0 = 0.0_wp Di1 = 0.5_wp Dk0 = -1.0e+300_wp Dk1 = -1.0e+300_wp return elseif ( x<=18.0d0 ) then Bi0 = 1.0_wp r = 1.0_wp do k = 1 , 50 r = 0.25_wp*r*x2/(k*k) Bi0 = Bi0 + r if ( abs(r/Bi0)<1.0e-15_wp ) exit enddo Bi1 = 1.0_wp r = 1.0_wp do k = 1 , 50 r = 0.25_wp*r*x2/(k*(k+1)) Bi1 = Bi1 + r if ( abs(r/Bi1)<1.0e-15_wp ) exit enddo Bi1 = 0.5_wp*x*Bi1 else data a/0.125_wp , 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>=35.0_wp ) k0 = 9 if ( x>=50.0_wp ) k0 = 7 ca = exp(x)/sqrt(twopi*x) Bi0 = 1.0_wp xr = 1.0_wp/x do k = 1 , k0 Bi0 = Bi0 + a(k)*xr**k enddo Bi0 = ca*Bi0 Bi1 = 1.0_wp do k = 1 , k0 Bi1 = Bi1 + b(k)*xr**k enddo Bi1 = ca*Bi1 endif ww = 0.0_wp if ( x<=9.0_wp ) then ct = -(log(x/2.0_wp)+gamma) Bk0 = 0.0_wp w0 = 0.0_wp r = 1.0_wp do k = 1 , 50 w0 = w0 + 1.0_wp/k r = 0.25_wp*r/(k*k)*x2 Bk0 = Bk0 + r*(w0+ct) if ( abs((Bk0-ww)/Bk0)<1.0e-15_wp ) exit ww = Bk0 enddo Bk0 = Bk0 + ct else data a1/0.125_wp , 0.2109375d0 , 1.0986328125d0 , & & 1.1775970458984d01 , 2.1461706161499d02 , & & 5.9511522710323d03 , 2.3347645606175d05 , & & 1.2312234987631d07/ cb = 0.5_wp/x xr2 = 1.0_wp/x2 Bk0 = 1.0_wp do k = 1 , 8 Bk0 = Bk0 + a1(k)*xr2**k enddo Bk0 = cb*Bk0/Bi0 endif Bk1 = (1.0_wp/x-Bi1*Bk0)/Bi0 Di0 = Bi1 Di1 = Bi0 - Bi1/x Dk0 = -Bk1 Dk1 = -Bk0 - Bk1/x end !***************************************************************************************** !> ! Compute the parabolic cylinder functions ! Dn(z) and Dn'(z) for a complex argument subroutine cpbdn(n,z,Cpb,Cpd) ! Input: z --- Complex argument of Dn(z) ! n --- Order of Dn(z) ( n=0,±1,±2,… ) ! Output: CPB(|n|) --- Dn(z) ! CPD(|n|) --- Dn'(z) real(wp) a0 , x complex(wp) c0 , ca0 , cf , cf0 , cf1 , cfa , cfb , Cpb , Cpd , & & cs0 , z , z1 integer k , m , n , n0 , n1 , nm1 dimension Cpb(0:*) , Cpd(0:*) x = real(z,wp) a0 = abs(z) c0 = (0.0_wp,0.0_wp) ca0 = exp(-0.25_wp*z*z) n0 = 0 if ( n>=0 ) then cf0 = ca0 cf1 = z*ca0 Cpb(0) = cf0 Cpb(1) = cf1 do k = 2 , n cf = z*cf1 - (k-1.0_wp)*cf0 Cpb(k) = cf cf0 = cf1 cf1 = cf enddo else n0 = -n if ( x<=0.0 .or. abs(z)==0.0_wp ) then cf0 = ca0 Cpb(0) = cf0 z1 = -z if ( a0<=7.0_wp ) then call cpdsa(-1,z1,cf1) else call cpdla(-1,z1,cf1) endif cf1 = sqrt(twopi)/ca0 - cf1 Cpb(1) = cf1 do k = 2 , n0 cf = (-z*cf1+cf0)/(k-1.0_wp) Cpb(k) = cf cf0 = cf1 cf1 = cf enddo elseif ( a0<=3.0_wp ) then call cpdsa(-n0,z,cfa) Cpb(n0) = cfa n1 = n0 + 1 call cpdsa(-n1,z,cfb) Cpb(n1) = cfb nm1 = n0 - 1 do k = nm1 , 0 , -1 cf = z*cfa + (k+1.0_wp)*cfb Cpb(k) = cf cfb = cfa cfa = cf enddo else m = 100 + abs(n) cfa = c0 cfb = (1.0d-30,0.0_wp) do k = m , 0 , -1 cf = z*cfb + (k+1.0_wp)*cfa if ( k<=n0 ) Cpb(k) = cf cfa = cfb cfb = cf enddo cs0 = ca0/cf do k = 0 , n0 Cpb(k) = cs0*Cpb(k) enddo endif endif Cpd(0) = -0.5_wp*z*Cpb(0) if ( n>=0 ) then do k = 1 , n Cpd(k) = -0.5_wp*z*Cpb(k) + k*Cpb(k-1) enddo else do k = 1 , n0 Cpd(k) = 0.5_wp*z*Cpb(k) - Cpb(k-1) enddo endif end !***************************************************************************************** !> ! Compute modified Bessel functions I0(x), I1(1), ! K0(x) and K1(x), and their derivatives subroutine ik01b(x,Bi0,Di0,Bi1,Di1,Bk0,Dk0,Bk1,Dk1) ! Input : x --- Argument ( x ≥ 0 ) ! Output: BI0 --- I0(x) ! DI0 --- I0'(x) ! BI1 --- I1(x) ! DI1 --- I1'(x) ! BK0 --- K0(x) ! DK0 --- K0'(x) ! BK1 --- K1(x) ! DK1 --- K1'(x) real(wp) Bi0 , Bi1 , Bk0 , Bk1 , Di0 , Di1 , Dk0 , Dk1 , & & t , t2 , x if ( x==0.0_wp ) then Bi0 = 1.0_wp Bi1 = 0.0_wp Bk0 = 1.0e+300_wp Bk1 = 1.0e+300_wp Di0 = 0.0_wp Di1 = 0.5_wp Dk0 = -1.0e+300_wp Dk1 = -1.0e+300_wp return elseif ( x<=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.0_wp Bi1 = x*((((((.00032411d0*t2+.00301532d0)*t2+.02658733d0)*t2+ & & .15084934d0)*t2+.51498869d0)*t2+.87890594d0)*t2+0.5_wp) 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)/sqrt(x) Bi1 = ((((((((-.420059d-2*t+.01787654d0)*t-.02895312d0)*t+ & & .02282967d0)*t-.01031555d0)*t+.163801d-2)*t-.00362018d0) & & *t-.03988024d0)*t+.39894228d0)*exp(x)/sqrt(x) endif if ( x<=2.0_wp ) then t = x/2.0_wp t2 = t*t Bk0 = (((((.0000074d0*t2+.0001075d0)*t2+.00262698d0)*t2+ & & .0348859d0)*t2+.23069756d0)*t2+.4227842d0) & & *t2 - .57721566d0 - Bi0*log(t) Bk1 = ((((((-.00004686d0*t2-.00110404d0)*t2-.01919402d0)*t2- & & .18156897d0)*t2-.67278579d0)*t2+.15443144d0)*t2+1.0_wp) & & /x + Bi1*log(t) else t = 2.0_wp/x t2 = t*t Bk0 = ((((((.00053208d0*t-.0025154d0)*t+.00587872d0)*t- & & .01062446d0)*t+.02189568d0)*t-.07832358d0) & & *t+1.25331414d0)*exp(-x)/sqrt(x) Bk1 = ((((((-.00068245d0*t+.00325614d0)*t-.00780353d0)*t+ & & .01504268d0)*t-.0365562d0)*t+.23498619d0)*t+1.25331414d0)& & *exp(-x)/sqrt(x) endif Di0 = Bi1 Di1 = Bi0 - Bi1/x Dk0 = -Bk1 Dk1 = -Bk0 - Bk1/x end !***************************************************************************************** !> ! Compute the beta function B(p,q) subroutine beta(p,q,Bt) ! Input : p --- Parameter ( p > 0 ) ! q --- Parameter ( q > 0 ) ! Output: BT --- B(p,q) real(wp) Bt , gp , gpq , gq , p , ppq , q call gamma2(p,gp) call gamma2(q,gq) ppq = p + q call gamma2(ppq,gpq) Bt = gp*gq/gpq end !***************************************************************************************** !> ! Compute Legendre polynomials Pn(x) ! and their derivatives Pn'(x) subroutine lpn(n,x,Pn,Pd) ! Input : x --- Argument of Pn(x) ! n --- Degree of Pn(x) ( n = 0,1,...) ! Output: PN(n) --- Pn(x) ! PD(n) --- Pn'(x) integer k , n real(wp) p0 , p1 , Pd , pf , Pn , x dimension Pn(0:n) , Pd(0:n) Pn(0) = 1.0_wp Pn(1) = x Pd(0) = 0.0_wp Pd(1) = 1.0_wp p0 = 1.0_wp p1 = x do k = 2 , n pf = (2.0_wp*k-1.0_wp)/k*x*p1 - (k-1.0_wp)/k*p0 Pn(k) = pf if ( abs(x)==1.0_wp ) then Pd(k) = 0.5_wp*x**(k+1)*k*(k+1.0_wp) else Pd(k) = k*(p1-x*pf)/(1.0_wp-x*x) endif p0 = p1 p1 = pf enddo end !***************************************************************************************** !> ! Compute expansion coefficients for Mathieu ! functions and modified Mathieu functions subroutine fcoef(Kd,m,q,a,Fc) ! Input : m --- Order of Mathieu functions ! q --- Parameter of Mathieu functions ! KD --- Case code ! KD=1 for cem(x,q) ( m = 0,2,4,...) ! KD=2 for cem(x,q) ( m = 1,3,5,...) ! KD=3 for sem(x,q) ( m = 1,3,5,...) ! KD=4 for sem(x,q) ( m = 2,4,6,...) ! A --- Characteristic value of Mathieu ! functions for given m and q ! Output: FC(k) --- Expansion coefficients of Mathieu ! functions ( k= 1,2,...,KM ) ! FC(1),FC(2),FC(3),... correspond to ! A0,A2,A4,... for KD=1 case, A1,A3, ! A5,... for KD=2 case, B1,B3,B5,... ! for KD=3 case and B2,B4,B6,... for ! KD=4 case real(wp) a , f , f1 , f2 , f3 , Fc , fnan , q , & & qm , s , s0 , sp , ss , u , v integer i , j , jm , k , kb , Kd , km , m dimension Fc(251) do i = 1 , 251 Fc(i) = 0.0_wp enddo if ( abs(q)<=1.0d-7 ) then ! Expansion up to order Q^1 (Abramowitz & Stegun 20.2.27-28) if ( Kd==1 ) then jm = m/2 + 1 elseif ( Kd==2 .or. Kd==3 ) then jm = (m-1)/2 + 1 elseif ( Kd==4 ) then jm = m/2 endif ! Check for overflow if ( jm+1>251 ) then fnan = dnan() do i = 1 , 251 Fc(i) = fnan enddo return endif ! Proceed using the simplest expansion if ( Kd==1 .or. Kd==2 ) then if ( m==0 ) then Fc(1) = 1/sq2 Fc(2) = -q/2.0_wp/sq2 elseif ( m==1 ) then Fc(1) = 1.0_wp Fc(2) = -q/8.0_wp elseif ( m==2 ) then Fc(1) = q/4.0_wp Fc(2) = 1.0_wp Fc(3) = -q/12.0d0 else Fc(jm) = 1.0_wp Fc(jm+1) = -q/(4.0_wp*(m+1)) Fc(jm-1) = q/(4.0_wp*(m-1)) endif elseif ( Kd==3 .or. Kd==4 ) then if ( m==1 ) then Fc(1) = 1.0_wp Fc(2) = -q/8.0_wp elseif ( m==2 ) then Fc(1) = 1.0_wp Fc(2) = -q/12.0d0 else Fc(jm) = 1.0_wp Fc(jm+1) = -q/(4.0_wp*(m+1)) Fc(jm-1) = q/(4.0_wp*(m-1)) endif endif return elseif ( q<=1.0_wp ) 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>251 ) then ! Overflow, generate NaNs fnan = dnan() do i = 1 , 251 Fc(i) = fnan enddo return endif kb = 0 s = 0.0_wp f = 1.0e-100_wp u = 0.0_wp Fc(km) = 0.0_wp f2 = 0.0_wp if ( Kd==1 ) then do k = km , 3 , -1 v = u u = f f = (a-4.0_wp*k*k)*u/q - v if ( abs(f)<abs(Fc(k+1)) ) then kb = k Fc(1) = 1.0e-100_wp sp = 0.0_wp f3 = Fc(k+1) Fc(2) = a/q*Fc(1) Fc(3) = (a-4.0_wp)*Fc(2)/q - 2.0_wp*Fc(1) u = Fc(2) f1 = Fc(3) do i = 3 , kb v = u u = f1 f1 = (a-4.0_wp*(i-1.0_wp)**2)*u/q - v Fc(i+1) = f1 if ( i==kb ) f2 = f1 if ( i/=kb ) sp = sp + f1*f1 enddo sp = sp + 2.0_wp*Fc(1)**2 + Fc(2)**2 + Fc(3)**2 ss = s + sp*(f3/f2)**2 s0 = sqrt(1.0_wp/ss) do j = 1 , km if ( j<=kb+1 ) then Fc(j) = s0*Fc(j)*f3/f2 else Fc(j) = s0*Fc(j) endif enddo goto 200 else Fc(k) = f s = s + f*f endif enddo Fc(2) = q*Fc(3)/(a-4.0_wp-2.0_wp*q*q/a) Fc(1) = q/a*Fc(2) s = s + 2.0_wp*Fc(1)**2 + Fc(2)**2 s0 = sqrt(1.0_wp/s) do k = 1 , km Fc(k) = s0*Fc(k) enddo elseif ( Kd==2 .or. Kd==3 ) then do k = km , 3 , -1 v = u u = f f = (a-(2.0_wp*k-1)**2)*u/q - v if ( abs(f)>=abs(Fc(k)) ) then Fc(k-1) = f s = s + f*f else kb = k f3 = Fc(k) goto 50 endif enddo Fc(1) = q/(a-1.0_wp-(-1)**Kd*q)*Fc(2) s = s + Fc(1)*Fc(1) s0 = sqrt(1.0_wp/s) do k = 1 , km Fc(k) = s0*Fc(k) enddo goto 200 50 Fc(1) = 1.0e-100_wp Fc(2) = (a-1.0_wp-(-1)**Kd*q)/q*Fc(1) sp = 0.0_wp u = Fc(1) f1 = Fc(2) do i = 2 , kb - 1 v = u u = f1 f1 = (a-(2.0_wp*i-1.0_wp)**2)*u/q - v if ( i/=kb-1 ) then Fc(i+1) = f1 sp = sp + f1*f1 else f2 = f1 endif enddo sp = sp + Fc(1)**2 + Fc(2)**2 ss = s + sp*(f3/f2)**2 s0 = 1.0_wp/sqrt(ss) do j = 1 , km if ( j<kb ) Fc(j) = s0*Fc(j)*f3/f2 if ( j>=kb ) Fc(j) = s0*Fc(j) enddo elseif ( Kd==4 ) then do k = km , 3 , -1 v = u u = f f = (a-4.0_wp*k*k)*u/q - v if ( abs(f)>=abs(Fc(k)) ) then Fc(k-1) = f s = s + f*f else kb = k f3 = Fc(k) goto 100 endif enddo Fc(1) = q/(a-4.0_wp)*Fc(2) s = s + Fc(1)*Fc(1) s0 = sqrt(1.0_wp/s) do k = 1 , km Fc(k) = s0*Fc(k) enddo goto 200 100 Fc(1) = 1.0e-100_wp Fc(2) = (a-4.0_wp)/q*Fc(1) sp = 0.0_wp u = Fc(1) f1 = Fc(2) do i = 2 , kb - 1 v = u u = f1 f1 = (a-4.0_wp*i*i)*u/q - v if ( i/=kb-1 ) then Fc(i+1) = f1 sp = sp + f1*f1 else f2 = f1 endif enddo sp = sp + Fc(1)**2 + Fc(2)**2 ss = s + sp*(f3/f2)**2 s0 = 1.0_wp/sqrt(ss) do j = 1 , km if ( j<kb ) Fc(j) = s0*Fc(j)*f3/f2 if ( j>=kb ) Fc(j) = s0*Fc(j) enddo endif 200 if ( Fc(1)<0.0_wp ) then do j = 1 , km Fc(j) = -Fc(j) enddo endif end !***************************************************************************************** !> ! Compute modified spherical Bessel functions ! of the first kind, in(x) and in'(x) subroutine sphi(n,x,Nm,Si,Di) ! Input : x --- Argument of in(x) ! n --- Order of in(x) ( n = 0,1,2,... ) ! Output: SI(n) --- in(x) ! DI(n) --- in'(x) ! NM --- Highest order computed real(wp) cs , Di , f , f0 , f1 , Si , si0 , x integer k , m , n , Nm dimension Si(0:n) , Di(0:n) Nm = n if ( abs(x)<1.0e-100_wp ) then do k = 0 , n Si(k) = 0.0_wp Di(k) = 0.0_wp enddo Si(0) = 1.0_wp Di(1) = 0.333333333333333d0 return endif Si(0) = sinh(x)/x Si(1) = -(sinh(x)/x-cosh(x))/x si0 = Si(0) if ( n>=2 ) then m = msta1(x,200) if ( m<n ) then Nm = m else m = msta2(x,n,15) endif f = 0.0_wp f0 = 0.0_wp f1 = 1.0_wp - 100 do k = m , 0 , -1 f = (2.0_wp*k+3.0_wp)*f1/x + f0 if ( k<=Nm ) Si(k) = f f0 = f1 f1 = f enddo cs = si0/f do k = 0 , Nm Si(k) = cs*Si(k) enddo endif Di(0) = Si(1) do k = 1 , Nm Di(k) = Si(k-1) - (k+1.0_wp)/x*Si(k) enddo end !***************************************************************************************** !> ! Compute parabolic cylinder functions W(a,±x) ! and their derivatives subroutine pbwa(a,x,W1f,W1d,W2f,W2d) ! Input : a --- Parameter ( 0 ≤ |a| ≤ 5 ) ! x --- Argument of W(a,±x) ( 0 ≤ |x| ≤ 5 ) ! Output : W1F --- W(a,x) ! W1D --- W'(a,x) ! W2F --- W(a,-x) ! W2D --- W'(a,-x) real(wp) a , d , d1 , d2 , dl , eps , f1 , f2 , g1 , g2 , & & h , h0 , h1 , hl , p0 , r , r1 , ugi , ugr , vgi real(wp) vgr , W1d , W1f , W2d , W2f , x , x1 , x2 , y1 , & & y1d , y1f , y2d , y2f integer k , l1 , l2 , m dimension h(100) , d(80) eps = 1.0e-15_wp p0 = 0.59460355750136d0 if ( a==0.0_wp ) then g1 = 3.625609908222d0 g2 = 1.225416702465d0 else x1 = 0.25_wp y1 = 0.5_wp*a call cgama(x1,y1,1,ugr,ugi) g1 = sqrt(ugr*ugr+ugi*ugi) x2 = 0.75d0 call cgama(x2,y1,1,vgr,vgi) g2 = sqrt(vgr*vgr+vgi*vgi) endif f1 = sqrt(g1/g2) f2 = sqrt(2.0_wp*g2/g1) h0 = 1.0_wp h1 = a h(1) = a do l1 = 4 , 200 , 2 m = l1/2 hl = a*h1 - 0.25_wp*(l1-2.0_wp)*(l1-3.0_wp)*h0 h(m) = hl h0 = h1 h1 = hl enddo y1f = 1.0_wp r = 1.0_wp do k = 1 , 100 r = 0.5_wp*r*x*x/(k*(2.0_wp*k-1.0_wp)) r1 = h(k)*r y1f = y1f + r1 if ( abs(r1)<=eps*abs(y1f) .and. k>30 ) exit enddo y1d = a r = 1.0_wp do k = 1 , 99 r = 0.5_wp*r*x*x/(k*(2.0_wp*k+1.0_wp)) r1 = h(k+1)*r y1d = y1d + r1 if ( abs(r1)<=eps*abs(y1d) .and. k>30 ) exit enddo y1d = x*y1d d1 = 1.0_wp d2 = a d(1) = 1.0_wp d(2) = a do l2 = 5 , 160 , 2 m = (l2+1)/2 dl = a*d2 - 0.25_wp*(l2-2.0_wp)*(l2-3.0_wp)*d1 d(m) = dl d1 = d2 d2 = dl enddo y2f = 1.0_wp r = 1.0_wp do k = 1 , 79 r = 0.5_wp*r*x*x/(k*(2.0_wp*k+1.0_wp)) r1 = d(k+1)*r y2f = y2f + r1 if ( abs(r1)<=eps*abs(y2f) .and. k>30 ) exit enddo y2f = x*y2f y2d = 1.0_wp r = 1.0_wp do k = 1 , 79 r = 0.5_wp*r*x*x/(k*(2.0_wp*k-1.0_wp)) r1 = d(k+1)*r y2d = y2d + r1 if ( abs(r1)<=eps*abs(y2f) .and. k>30 ) exit enddo W1f = p0*(f1*y1f-f2*y2f) W2f = p0*(f1*y1f+f2*y2f) W1d = p0*(f1*y1d-f2*y2d) W2d = p0*(f1*y1d+f2*y2d) end !***************************************************************************************** !> ! Compute prolate and oblate spheroidal radial ! functions of the first kind for given m, n, ! c and x subroutine rmn1(m,n,c,x,Df,Kd,R1f,R1d) real(wp) a0 , b0 , c , ck , cx , Df , dj , r , r0 , & & r1 , R1d , R1f , r2 , r3 , reg , sa0 , sj , suc ,& & sud real(wp) sum , sw , sw1 , x integer ip , j , k , Kd , l , lg , m , n , nm , nm1 , nm2 , np dimension ck(200) , Df(200) , sj(0:251) , dj(0:251) real(wp),parameter :: eps = 1.0e-14_wp ip = 1 nm1 = int((n-m)/2) if ( n-m==2*nm1 ) ip = 0 nm = 25 + nm1 + int(c) reg = 1.0_wp if ( m+nm>80 ) reg = 1.0e-200_wp r0 = reg do j = 1 , 2*m + ip r0 = r0*j enddo r = r0 suc = r*Df(1) sw = 0.0_wp do k = 2 , nm r = r*(m+k-1.0_wp)*(m+k+ip-1.5_wp)/(k-1.0_wp)/(k+ip-1.5_wp) suc = suc + r*Df(k) if ( k>nm1 .and. abs(suc-sw)<abs(suc)*eps ) exit sw = suc enddo if ( x==0.0_wp ) then call sckb(m,n,c,Df,ck) sum = 0.0_wp sw1 = 0.0_wp do j = 1 , nm sum = sum + ck(j) if ( abs(sum-sw1)<abs(sum)*eps ) exit sw1 = sum enddo r1 = 1.0_wp do j = 1 , (n+m+ip)/2 r1 = r1*(j+0.5_wp*(n+m+ip)) enddo r2 = 1.0_wp do j = 1 , m r2 = 2.0_wp*c*r2*j enddo r3 = 1.0_wp do j = 1 , (n-m-ip)/2 r3 = r3*j enddo sa0 = (2.0_wp*(m+ip)+1.0_wp)*r1/(2.0_wp**n*c**ip*r2*r3) if ( ip==0 ) then R1f = sum/(sa0*suc)*Df(1)*reg R1d = 0.0_wp elseif ( ip==1 ) then R1f = 0.0_wp 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.0_wp-Kd/(x*x))**(0.5_wp*m)/suc R1f = 0.0_wp sw = 0.0_wp lg = 0 do k = 1 , nm l = 2*k + m - n - 2 + ip if ( l==4*int(l/4) ) lg = 1 if ( l/=4*int(l/4) ) lg = -1 if ( k==1 ) then r = r0 else r = r*(m+k-1.0_wp)*(m+k+ip-1.5_wp)/(k-1.0_wp)/(k+ip-1.5_wp) endif np = m + 2*k - 2 + ip R1f = R1f + lg*r*Df(k)*sj(np) if ( k>nm1 .and. abs(R1f-sw)<abs(R1f)*eps ) exit sw = R1f enddo R1f = R1f*a0 b0 = Kd*m/x**3.0_wp/(1.0-Kd/(x*x))*R1f sud = 0.0_wp sw = 0.0_wp do k = 1 , nm l = 2*k + m - n - 2 + ip if ( l==4*int(l/4) ) lg = 1 if ( l/=4*int(l/4) ) lg = -1 if ( k==1 ) then r = r0 else r = r*(m+k-1.0_wp)*(m+k+ip-1.5_wp)/(k-1.0_wp)/(k+ip-1.5_wp) endif np = m + 2*k - 2 + ip sud = sud + lg*r*Df(k)*dj(np) if ( k>nm1 .and. abs(sud-sw)<abs(sud)*eps ) exit sw = sud enddo R1d = b0 + a0*c*sud end !***************************************************************************************** !> ! Compute parabolic cylinder function Dv(x) ! for small argument subroutine dvsa(Va,x,Pd) ! Input: x --- Argument ! va --- Order ! Output: PD --- Dv(x) real(wp) a0 , ep , eps , g0 , g1 , ga0 , gm , Pd , & & r , r1 , Va , va0 , vm , vt , x integer m eps = 1.0e-15_wp ep = exp(-0.25_wp*x*x) va0 = 0.5_wp*(1.0_wp-Va) if ( Va==0.0_wp ) then Pd = ep elseif ( x==0.0_wp ) then if ( va0<=0.0 .and. va0==int(va0) ) then Pd = 0.0_wp else call gamma2(va0,ga0) Pd = sqrtpi/(2.0_wp**(-0.5_wp*Va)*ga0) endif else call gamma2(-Va,g1) a0 = 2.0_wp**(-0.5_wp*Va-1.0_wp)*ep/g1 vt = -0.5_wp*Va call gamma2(vt,g0) Pd = g0 r = 1.0_wp do m = 1 , 250 vm = 0.5_wp*(m-Va) call gamma2(vm,gm) r = -r*sq2*x/m r1 = gm*r Pd = Pd + r1 if ( abs(r1)<abs(Pd)*eps ) exit enddo Pd = a0*Pd endif end !***************************************************************************************** !> ! Compute complex exponential integral E1(z) subroutine e1z(z,Ce1) ! Input : z --- Argument of E1(z) ! Output: CE1 --- E1(z) real(wp) a0 , x , xt complex(wp) Ce1 , cr , z , zc , zd , zdc integer k x = real(z,wp) a0 = abs(z) ! Continued fraction converges slowly near negative real axis, ! so use power series in a wedge around it until radius 40.0 xt = -2*abs(aimag(z)) if ( a0==0.0_wp ) then Ce1 = (1.0e+300_wp,0.0_wp) elseif ( a0<=5.0 .or. x<xt .and. a0<40.0_wp ) then ! Power series Ce1 = (1.0_wp,0.0_wp) cr = (1.0_wp,0.0_wp) do k = 1 , 500 cr = -cr*k*z/(k+1.0_wp)**2 Ce1 = Ce1 + cr if ( abs(cr)<=abs(Ce1)*1.0e-15_wp ) exit enddo if ( x<=0.0 .and. aimag(z)==0.0_wp ) then ! Careful on the branch cut -- use the sign of the imaginary part ! to get the right sign on the factor if pi. Ce1 = -gamma - log(-z) + z*Ce1 - sign(pi,aimag(z)) & & *(0.0_wp,1.0_wp) else Ce1 = -gamma - log(z) + z*Ce1 endif else ! Continued fraction https://dlmf.nist.gov/6.9 ! ! 1 1 1 2 2 3 3 ! E1 = exp(-z) * ----- ----- ----- ----- ----- ----- ----- ... ! Z + 1 + Z + 1 + Z + 1 + Z + zc = 0d0 zd = 1/z zdc = 1*zd zc = zc + zdc do 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)<=abs(zc)*1.0e-15_wp .and. k>20 ) exit enddo Ce1 = exp(-z)*zc if ( x<=0.0 .and. aimag(z)==0.0_wp ) Ce1 = Ce1 - pi*(0.0_wp,1.0_wp) endif end !***************************************************************************************** !> ! Integrate Bessel functions J0(t) and Y0(t) ! with respect to t from 0 to x ( x ≥ 0 ) subroutine itjyb(x,Tj,Ty) ! Input : x --- Upper limit of the integral ! Output: TJ --- Integration of J0(t) from 0 to x ! TY --- Integration of Y0(t) from 0 to x real(wp) f0 , g0 , t , Tj , Ty , x , x1 , xt if ( x==0.0_wp ) then Tj = 0.0_wp Ty = 0.0_wp elseif ( x<=4.0_wp ) then x1 = x/4.0_wp t = x1*x1 Tj = (((((((-.133718d-3*t+.2362211d-2)*t-.025791036d0)*t+ & & .197492634d0)*t-1.015860606d0)*t+3.199997842d0) & & *t-5.333333161d0)*t+4.0_wp)*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.0_wp/pi*log(x/2.0_wp)*Tj - Ty elseif ( x<=8.0_wp ) then xt = x - .25_wp*pi t = 16.0_wp/(x*x) f0 = ((((((.1496119d-2*t-.739083d-2)*t+.016236617d0)*t- & & .022007499d0)*t+.023644978d0)*t-.031280848d0) & & *t+.124611058d0)*4.0_wp/x g0 = (((((.1076103d-2*t-.5434851d-2)*t+.01242264d0)*t- & & .018255209)*t+.023664841d0)*t-.049635633d0) & & *t + .79784879d0 Tj = 1.0_wp - (f0*cos(xt)-g0*sin(xt))/sqrt(x) Ty = -(f0*sin(xt)+g0*cos(xt))/sqrt(x) else t = 64.0d0/(x*x) xt = x - .25_wp*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.0_wp/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.0_wp - (f0*cos(xt)-g0*sin(xt))/sqrt(x) Ty = -(f0*sin(xt)+g0*cos(xt))/sqrt(x) endif end !***************************************************************************************** !> ! Compute the confluent hypergeometric function ! U(a,b,x) for large argument x subroutine chgul(a,b,x,Hu,Id) ! Input : a --- Parameter ! b --- Parameter ! x --- Argument ! Output: HU --- U(a,b,x) ! ID --- Estimated number of significant digits real(wp) a , aa , b , Hu , r , r0 , ra , x integer Id , k , nm logical il1 , il2 Id = -100 aa = a - b + 1.0_wp il1 = a==int(a) .and. a<=0.0 il2 = aa==int(aa) .and. aa<=0.0 nm = 0 if ( il1 ) nm = abs(a) if ( il2 ) nm = abs(aa) ! IL1: DLMF 13.2.7 with k=-s-a ! IL2: DLMF 13.2.8 if ( il1 .or. il2 ) then Hu = 1.0_wp r = 1.0_wp do k = 1 , nm r = -r*(a+k-1.0_wp)*(a-b+k)/(k*x) Hu = Hu + r enddo Hu = x**(-a)*Hu Id = 10 else ! DLMF 13.7.3 Hu = 1.0_wp r = 1.0_wp do k = 1 , 25 r = -r*(a+k-1.0_wp)*(a-b+k)/(k*x) ra = abs(r) if ( k>5 .and. ra>=r0 .or. ra<1.0e-15_wp ) exit r0 = ra Hu = Hu + r enddo Id = abs(log10(ra)) Hu = x**(-a)*Hu endif end !***************************************************************************************** !> ! Compute gmn(-ic,ix) and its derivative for oblate ! radial functions with a small argument subroutine gmn(m,n,c,x,Bk,Gf,Gd) real(wp) Bk , c , Gd , gd0 , gd1 , Gf , gf0 , gw , & & x , xm integer ip , k , m , n , nm dimension Bk(200) real(wp),parameter :: eps = 1.0e-14_wp ip = 1 if ( n-m==2*int((n-m)/2) ) ip = 0 nm = 25 + int(0.5*(n-m)+c) xm = (1.0_wp+x*x)**(-0.5_wp*m) gf0 = 0.0_wp gw = 0.0_wp do k = 1 , nm gf0 = gf0 + Bk(k)*x**(2.0_wp*k-2.0_wp) if ( abs((gf0-gw)/gf0)<eps .and. k>=10 ) exit gw = gf0 enddo Gf = xm*gf0*x**(1-ip) gd1 = -m*x/(1.0_wp+x*x)*Gf gd0 = 0.0_wp do k = 1 , nm if ( ip==0 ) then gd0 = gd0 + (2.0_wp*k-1.0_wp)*Bk(k)*x**(2.0_wp*k-2.0_wp) else gd0 = gd0 + 2.0_wp*k*Bk(k+1)*x**(2.0_wp*k-1.0_wp) endif if ( abs((gd0-gw)/gd0)<eps .and. k>=10 ) exit gw = gd0 enddo Gd = gd1 + xm*gd0 end !***************************************************************************************** !> ! Integrate Bessel functions J0(t) & Y0(t) with ! respect to t from 0 to x subroutine itjya(x,Tj,Ty) ! Input : x --- Upper limit of the integral ( x >= 0 ) ! Output: TJ --- Integration of J0(t) from 0 to x ! TY --- Integration of Y0(t) from 0 to x real(wp) a , a0 , a1 , af , bf , bg , r , & & r2 , rc , rs , Tj , Ty , ty1 , ty2 , x , x2 , xp integer k dimension a(18) real(wp),parameter :: eps = 1.0e-12_wp if ( x==0.0_wp ) then Tj = 0.0_wp Ty = 0.0_wp elseif ( x<=20.0_wp ) then x2 = x*x Tj = x r = x do k = 1 , 60 r = -0.25_wp*r*(2*k-1.0_wp)/(2*k+1.0_wp)/(k*k)*x2 Tj = Tj + r if ( abs(r)<abs(Tj)*eps ) exit enddo ty1 = (gamma+log(x/2.0_wp))*Tj rs = 0.0_wp ty2 = 1.0_wp r = 1.0_wp do k = 1 , 60 r = -0.25_wp*r*(2*k-1.0_wp)/(2*k+1.0_wp)/(k*k)*x2 rs = rs + 1.0_wp/k r2 = r*(rs+1.0_wp/(2.0_wp*k+1.0_wp)) ty2 = ty2 + r2 if ( abs(r2)<abs(ty2)*eps ) exit enddo Ty = (ty1-x*ty2)*2.0_wp/pi else a0 = 1.0_wp a1 = 5.0_wp/8.0_wp a(1) = a1 do k = 1 , 16 af = ((1.5_wp*(k+0.5_wp)*(k+5.0_wp/6.0_wp)*a1-0.5_wp*(k+0.5_wp) & & *(k+0.5_wp)*(k-0.5_wp)*a0))/(k+1.0_wp) a(k+1) = af a0 = a1 a1 = af enddo bf = 1.0_wp r = 1.0_wp do k = 1 , 8 r = -r/(x*x) bf = bf + a(2*k)*r enddo bg = a(1)/x r = 1.0_wp/x do k = 1 , 8 r = -r/(x*x) bg = bg + a(2*k+1)*r enddo xp = x + .25_wp*pi rc = sqrt(2.0_wp/(pi*x)) Tj = 1.0_wp - rc*(bf*cos(xp)+bg*sin(xp)) Ty = rc*(bg*cos(xp)-bf*sin(xp)) endif end !***************************************************************************************** !> ! Compute Riccati-Bessel functions of the second ! kind and their derivatives subroutine rcty(n,x,Nm,Ry,Dy) ! Input: x --- Argument of Riccati-Bessel function ! n --- Order of yn(x) ! Output: RY(n) --- x·yn(x) ! DY(n) --- [x·yn(x)]' ! NM --- Highest order computed real(wp) Dy , rf0 , rf1 , rf2 , Ry , x integer k , n , Nm dimension Ry(0:n) , Dy(0:n) Nm = n if ( x<1.0d-60 ) then do k = 0 , n Ry(k) = -1.0e+300_wp Dy(k) = 1.0e+300_wp enddo Ry(0) = -1.0_wp Dy(0) = 0.0_wp return endif Ry(0) = -cos(x) Ry(1) = Ry(0)/x - sin(x) rf0 = Ry(0) rf1 = Ry(1) do k = 2 , n rf2 = (2.0_wp*k-1.0_wp)*rf1/x - rf0 if ( abs(rf2)>1.0e+300_wp ) exit Ry(k) = rf2 rf0 = rf1 rf1 = rf2 enddo Nm = k - 1 Dy(0) = sin(x) do k = 1 , Nm Dy(k) = -k*Ry(k)/x + Ry(k-1) enddo end !***************************************************************************************** !> ! Compute Legendre polynomials Pn(x), Pn'(x) ! and the integral of Pn(t) from 0 to x subroutine lpni(n,x,Pn,Pd,Pl) ! Input : x --- Argument of Pn(x) ! n --- Degree of Pn(x) ( n = 0,1,... ) ! Output: PN(n) --- Pn(x) ! PD(n) --- Pn'(x) ! PL(n) --- Integral of Pn(t) from 0 to x integer j , k , n , n1 real(wp) p0 , p1 , Pd , pf , Pl , Pn , r , x dimension Pn(0:n) , Pd(0:n) , Pl(0:n) Pn(0) = 1.0_wp Pn(1) = x Pd(0) = 0.0_wp Pd(1) = 1.0_wp Pl(0) = x Pl(1) = 0.5_wp*x*x p0 = 1.0_wp p1 = x do k = 2 , n pf = (2.0_wp*k-1.0_wp)/k*x*p1 - (k-1.0_wp)/k*p0 Pn(k) = pf if ( abs(x)==1.0_wp ) then Pd(k) = 0.5_wp*x**(k+1)*k*(k+1.0_wp) else Pd(k) = k*(p1-x*pf)/(1.0_wp-x*x) endif Pl(k) = (x*Pn(k)-Pn(k-1))/(k+1.0_wp) p0 = p1 p1 = pf if ( k/=2*int(k/2) ) then r = 1.0_wp/(k+1.0_wp) n1 = (k-1)/2 do j = 1 , n1 r = (0.5_wp/j-1.0_wp)*r enddo Pl(k) = Pl(k) + r endif enddo end !***************************************************************************************** !> ! Compute Kelvin functions ber x, bei x, ker x ! and kei x, and their derivatives ( x > 0 ) subroutine klvna(x,Ber,Bei,Ger,Gei,Der,Dei,Her,Hei) ! Input : x --- Argument of Kelvin functions ! Output: BER --- ber x ! BEI --- bei x ! GER --- ker x ! GEI --- kei x ! DER --- ber'x ! DEI --- bei'x ! HER --- ker'x ! HEI --- kei'x real(wp) Bei , Ber , cn0 , cp0 , cs , Dei , Der , & fac , Gei , Ger , gs , Hei , Her , & pn0 , pn1 , pp0 , pp1 real(wp) qn0 , qn1 , qp0 , qp1 , r , r0 , r1 , rc , rs , & sn0 , sp0 , ss , x , x2 , x4 , xc1 , xc2 , xd , & xe1 , xe2 real(wp) xt integer k , km , m real(wp),parameter :: eps = 1.0e-15_wp if ( x==0.0_wp ) then Ber = 1.0_wp Bei = 0.0_wp Ger = 1.0e+300_wp Gei = -0.25_wp*pi Der = 0.0_wp Dei = 0.0_wp Her = -1.0e+300_wp Hei = 0.0_wp return endif x2 = 0.25_wp*x*x x4 = x2*x2 if ( abs(x)<10.0_wp ) then Ber = 1.0_wp r = 1.0_wp do m = 1 , 60 r = -0.25_wp*r/(m*m)/(2.0_wp*m-1.0_wp)**2*x4 Ber = Ber + r if ( abs(r)<abs(Ber)*eps ) exit enddo Bei = x2 r = x2 do m = 1 , 60 r = -0.25_wp*r/(m*m)/(2.0_wp*m+1.0_wp)**2*x4 Bei = Bei + r if ( abs(r)<abs(Bei)*eps ) exit enddo Ger = -(log(x/2.0_wp)+gamma)*Ber + 0.25_wp*pi*Bei r = 1.0_wp gs = 0.0_wp do m = 1 , 60 r = -0.25_wp*r/(m*m)/(2.0_wp*m-1.0_wp)**2*x4 gs = gs + 1.0_wp/(2.0_wp*m-1.0_wp) + 1.0_wp/(2.0_wp*m) Ger = Ger + r*gs if ( abs(r*gs)<abs(Ger)*eps ) exit enddo Gei = x2 - (log(x/2.0_wp)+gamma)*Bei - 0.25_wp*pi*Ber r = x2 gs = 1.0_wp do m = 1 , 60 r = -0.25_wp*r/(m*m)/(2.0_wp*m+1.0_wp)**2*x4 gs = gs + 1.0_wp/(2.0_wp*m) + 1.0_wp/(2.0_wp*m+1.0_wp) Gei = Gei + r*gs if ( abs(r*gs)<abs(Gei)*eps ) exit enddo Der = -0.25_wp*x*x2 r = Der do m = 1 , 60 r = -0.25_wp*r/m/(m+1.0_wp)/(2.0_wp*m+1.0_wp)**2*x4 Der = Der + r if ( abs(r)<abs(Der)*eps ) exit enddo Dei = 0.5_wp*x r = Dei do m = 1 , 60 r = -0.25_wp*r/(m*m)/(2.d0*m-1.d0)/(2.d0*m+1.d0)*x4 Dei = Dei + r if ( abs(r)<abs(Dei)*eps ) exit enddo r = -0.25_wp*x*x2 gs = 1.5_wp Her = 1.5_wp*r - Ber/x - (log(x/2.d0)+gamma)*Der + 0.25_wp*pi*Dei do m = 1 , 60 r = -0.25_wp*r/m/(m+1.0_wp)/(2.0_wp*m+1.0_wp)**2*x4 gs = gs + 1.0_wp/(2*m+1.0_wp) + 1.0_wp/(2*m+2.0_wp) Her = Her + r*gs if ( abs(r*gs)<abs(Her)*eps ) exit enddo r = 0.5_wp*x gs = 1.0_wp Hei = 0.5_wp*x - Bei/x - (log(x/2.d0)+gamma)*Dei - 0.25_wp*pi*Der do m = 1 , 60 r = -0.25_wp*r/(m*m)/(2*m-1.0_wp)/(2*m+1.0_wp)*x4 gs = gs + 1.0_wp/(2.0_wp*m) + 1.0_wp/(2*m+1.0_wp) Hei = Hei + r*gs if ( abs(r*gs)<abs(Hei)*eps ) return enddo else pp0 = 1.0_wp pn0 = 1.0_wp qp0 = 0.0_wp qn0 = 0.0_wp r0 = 1.0_wp km = 18 if ( abs(x)>=40.0_wp ) km = 10 fac = 1.0_wp do k = 1 , km fac = -fac xt = 0.25_wp*k*pi - int(0.125_wp*k)*twopi cs = cos(xt) ss = sin(xt) r0 = 0.125_wp*r0*(2.0_wp*k-1.0_wp)**2/k/x rc = r0*cs rs = r0*ss pp0 = pp0 + rc pn0 = pn0 + fac*rc qp0 = qp0 + rs qn0 = qn0 + fac*rs enddo xd = x/sq2 xe1 = exp(xd) xe2 = exp(-xd) xc1 = 1.d0/sqrt(twopi*x) xc2 = sqrt(0.5_wp*pi/x) cp0 = cos(xd+0.125_wp*pi) cn0 = cos(xd-0.125_wp*pi) sp0 = sin(xd+0.125_wp*pi) sn0 = sin(xd-0.125_wp*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.0_wp pn1 = 1.0_wp qp1 = 0.0_wp qn1 = 0.0_wp r1 = 1.0_wp fac = 1.0_wp do k = 1 , km fac = -fac xt = 0.25_wp*k*pi - int(0.125_wp*k)*twopi cs = cos(xt) ss = sin(xt) r1 = 0.125_wp*r1*(4.d0-(2.0_wp*k-1.0_wp)**2)/k/x rc = r1*cs rs = r1*ss pp1 = pp1 + fac*rc pn1 = pn1 + rc qp1 = qp1 + fac*rs qn1 = qn1 + rs enddo 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 end !***************************************************************************************** !> ! Compute confluent hypergeometric function ! U(a,b,x) with integer b ( b = ±1,±2,... ) subroutine chgubi(a,b,x,Hu,Id) ! Input : a --- Parameter ! b --- Parameter ! x --- Argument ! Output: HU --- U(a,b,x) ! ID --- Estimated number of significant digits real(wp) a , a0 , a1 , a2 , b , da1 , da2 , db1 , db2 , & ga , ga1 , h0 , hm1 , hm2 , hm3 , hmax , & hmin , Hu , hu1 real(wp) hu2 , hw , ps , r , rn , rn1 , s0 , s1 , s2 , & sa , sb , ua , ub , x integer Id , id1 , id2 , j , k , m , n Id = -100 n = abs(b-1) rn1 = 1.0_wp rn = 1.0_wp do j = 1 , n rn = rn*j if ( j==n-1 ) rn1 = rn enddo call psi_spec(a,ps) call gamma2(a,ga) if ( b>0.0_wp ) 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.0_wp r = 1.0_wp hmax = 0.0_wp hmin = 1.0e+300_wp h0 = 0d0 do k = 1 , 150 r = r*(a0+k-1.0_wp)*x/((n+k)*k) hm1 = hm1 + r hu1 = abs(hm1) if ( hu1>hmax ) hmax = hu1 if ( hu1<hmin ) hmin = hu1 if ( abs(hm1-h0)<abs(hm1)*1.0e-15_wp ) exit h0 = hm1 enddo da1 = log10(hmax) da2 = 0.0_wp if ( hmin/=0.0_wp ) da2 = log10(hmin) Id = 15 - abs(da1-da2) hm1 = hm1*log(x) s0 = 0.0_wp do m = 1 , n if ( b>=0.0_wp ) s0 = s0 - 1.0_wp/m if ( b<0.0_wp ) s0 = s0 + (1.0_wp-a)/(m*(a+m-1.0_wp)) enddo hm2 = ps + 2.0_wp*gamma + s0 r = 1.0_wp hmax = 0.0_wp hmin = 1.0e+300_wp do k = 1 , 150 s1 = 0.0_wp s2 = 0.0_wp if ( b>0.0_wp ) then do m = 1 , k s1 = s1 - (m+2.0_wp*a-2.0_wp)/(m*(m+a-1.0_wp)) enddo do m = 1 , n s2 = s2 + 1.0_wp/(k+m) enddo else do m = 1 , k + n s1 = s1 + (1.0_wp-a)/(m*(m+a-1.0_wp)) enddo do m = 1 , k s2 = s2 + 1.0_wp/m enddo endif hw = 2.0_wp*gamma + ps + s1 - s2 r = r*(a0+k-1.0_wp)*x/((n+k)*k) hm2 = hm2 + r*hw hu2 = abs(hm2) if ( hu2>hmax ) hmax = hu2 if ( hu2<hmin ) hmin = hu2 if ( abs((hm2-h0)/hm2)<1.0e-15_wp ) exit h0 = hm2 enddo db1 = log10(hmax) db2 = 0.0_wp if ( hmin/=0.0_wp ) db2 = log10(hmin) id1 = 15 - abs(db1-db2) if ( id1<Id ) Id = id1 hm3 = 1.0_wp if ( n==0 ) hm3 = 0.0_wp r = 1.0_wp do k = 1 , n - 1 r = r*(a2+k-1.0_wp)/((k-n)*k)*x hm3 = hm3 + r enddo sa = ua*(hm1+hm2) sb = ub*hm3 Hu = sa + sb id2 = 0.0_wp if ( sa/=0.0_wp ) id1 = int(log10(abs(sa))) if ( Hu/=0.0_wp ) id2 = int(log10(abs(Hu))) if ( sa*sb<0.0_wp ) Id = Id - abs(id1-id2) end !***************************************************************************************** !> ! Compute the complex zeros of Y0(z), Y1(z) and ! Y1'(z), and their associated values at the zeros ! using the modified Newton's iteration method subroutine cyzo(Nt,Kf,Kc,Zo,Zv) ! Input: NT --- Total number of zeros/roots ! KF --- Function choice code ! KF=0 for Y0(z) & Y1(z0) ! KF=1 for Y1(z) & Y0(z1) ! KF=2 for Y1'(z) & Y1(z1') ! KC --- Choice code ! KC=0 for complex roots ! KC=1 for real roots ! Output: ZO(L) --- L-th zero of Y0(z) or Y1(z) or Y1'(z) ! ZV(L) --- Value of Y0'(z) or Y1'(z) or Y1(z) ! at the L-th zero real(wp) h , w , w0 , x , y integer i , it , j , Kc , Kf , nr , Nt complex(wp) z , zd , zf , zfd , zgd , Zo , zp , zq , Zv , zw dimension Zo(Nt) , Zv(Nt) x = 0.0_wp y = 0.0_wp h = 0.0_wp if ( Kc==0 ) then x = -2.4d0 y = 0.54d0 h = 3.14d0 ! JW : is this pi ? elseif ( Kc==1 ) then x = 0.89 y = 0.0 h = -3.14 ! JW : is this pi ? endif if ( Kf==1 ) x = -0.503 if ( Kf==2 ) x = 0.577 z = cmplx(x,y,kind=wp) w = 0.0_wp do nr = 1 , Nt if ( nr/=1 ) z = Zo(nr-1) - h it = 0 50 it = it + 1 call cy01(Kf,z,zf,zd) zp = (1.0_wp,0.0_wp) do i = 1 , nr - 1 zp = zp*(z-Zo(i)) enddo zfd = zf/zp zq = (0.0_wp,0.0_wp) do i = 1 , nr - 1 zw = (1.0_wp,0.0_wp) do j = 1 , nr - 1 if ( j/=i ) zw = zw*(z-Zo(j)) enddo zq = zq + zw enddo zgd = (zd-zq*zfd)/zp z = z - zfd/zgd w0 = w w = abs(z) if ( it<=50 .and. abs((w-w0)/w)>1.0e-12_wp ) goto 50 Zo(nr) = z enddo do i = 1 , Nt z = Zo(i) if ( Kf==0 .or. Kf==2 ) then call cy01(1,z,zf,zd) Zv(i) = zf elseif ( Kf==1 ) then call cy01(0,z,zf,zd) Zv(i) = zf endif enddo end !***************************************************************************************** !> ! Compute Kelvin functions ber x, bei x, ker x ! and kei x, and their derivatives ( x > 0 ) subroutine klvnb(x,Ber,Bei,Ger,Gei,Der,Dei,Her,Hei) ! Input : x --- Argument of Kelvin functions ! Output: BER --- ber x ! BEI --- bei x ! GER --- ker x ! GEI --- kei x ! DER --- ber'x ! DEI --- bei'x ! HER --- ker'x ! HEI --- kei'x real(wp) Bei , Ber , csn , csp , Dei , Der , fxi , fxr , & & Gei , Ger , Hei , Her , pni , pnr , ppi , & & ppr , ssn , ssp , t real(wp) t2 , tni , tnr , tpi , tpr , u , v , x , yc1 , & & yc2 , yd , ye1 , ye2 integer l if ( x==0.0_wp ) then Ber = 1.0_wp Bei = 0.0_wp Ger = 1.0e+300_wp Gei = -0.25_wp*pi Der = 0.0_wp Dei = 0.0_wp Her = -1.0e+300_wp Hei = 0.0_wp elseif ( x<8.0_wp ) then t = x/8.0_wp 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.0_wp Bei = t*t*((((((.11346d-3*u-.01103667d0)*u+.52185615d0)*u- & & 10.56765779d0)*u+72.81777742d0)*u-113.77777774d0) & & *u+16.0_wp) Ger = ((((((-.2458d-4*u+.309699d-2)*u-.19636347d0)*u+ & & 5.65539121d0)*u-60.60977451d0)*u+171.36272133d0) & & *u-59.05819744d0)*u - .57721566d0 Ger = Ger - log(0.5_wp*x)*Ber + .25_wp*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 - log(0.5_wp*x)*Bei - .25_wp*pi*Ber Der = x*t2* & & ((((((-.394d-5*u+.45957d-3)*u-.02609253d0)*u+.66047849d0)& & *u-6.0681481d0)*u+14.22222222d0)*u-4.0_wp) Dei = x*((((((.4609d-4*u-.379386d-2)*u+.14677204d0)*u- & & 2.31167514d0)*u+11.37777772d0)*u-10.66666666d0)*u+0.5_wp) Her = x*t2*((((((-.1075d-4*u+.116137d-2)*u-.06136358d0)*u+ & & 1.4138478d0)*u-11.36433272d0)*u+21.42034017d0) & & *u-3.69113734d0) Her = Her - log(0.5_wp*x)*Der - Ber/x + .25_wp*pi*Dei Hei = x*((((((.11997d-3*u-.926707d-2)*u+.33049424d0)*u- & & 4.65950823d0)*u+19.41182758d0)*u-13.39858846d0) & & *u+.21139217d0) Hei = Hei - log(0.5_wp*x)*Dei - Bei/x - .25_wp*pi*Der else t = 8.0_wp/x tnr = 0.0_wp tni = 0.0_wp do 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==1 ) then tnr = tpr tni = tpi endif enddo yd = x/sq2 ye1 = exp(yd+tpr) ye2 = exp(-yd+tnr) yc1 = 1.0_wp/sqrt(twopi*x) yc2 = sqrt(pi/(2.0_wp*x)) csp = cos(yd+tpi) ssp = sin(yd+tpi) csn = cos(-yd+tni) ssn = sin(-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.0_wp pni = 0.0_wp do 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==1 ) then pnr = ppr pni = ppi endif enddo 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 end !***************************************************************************************** !> ! Compute oblate radial functions of the second kind ! with a small argument, Rmn(-ic,ix) & Rmn'(-ic,ix) subroutine rmn2so(m,n,c,x,Cv,Df,Kd,R2f,R2d) real(wp) bk , c , ck , ck1 , ck2 , Cv , Df , dn , & & gd , gf , h0 , qs , qt , r1d , r1f , R2d , & & R2f , sum real(wp) sw , x integer ip , j , Kd , m , n , nm dimension bk(200) , ck(200) , Df(200) , dn(200) real(wp),parameter :: eps = 1.0e-14_wp if ( abs(Df(1))<=1.0d-280 ) then R2f = 1.0e+300_wp R2d = 1.0e+300_wp return endif nm = 25 + int((n-m)/2+c) ip = 1 if ( n-m==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==0.0_wp ) then sum = 0.0_wp sw = 0.0_wp do j = 1 , nm sum = sum + ck(j) if ( abs(sum-sw)<abs(sum)*eps ) exit sw = sum enddo if ( ip==0 ) then r1f = sum/ck1 R2f = -halfpi*qs*r1f R2d = qs*r1f + bk(1) elseif ( ip==1 ) then r1d = sum/ck1 R2f = bk(1) R2d = -halfpi*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 = atan(x) - halfpi R2f = qs*r1f*h0 + gf R2d = qs*(r1d*h0+r1f/(1.0_wp+x*x)) + gd endif end !***************************************************************************************** !> ! Compute Bessel functions Jn(x) and their ! first and second derivatives ( n= 0,1,… ) subroutine bjndd(n,x,Bj,Dj,Fj) ! Input: x --- Argument of Jn(x) ( x ≥ 0 ) ! n --- Order of Jn(x) ! Output: BJ(n+1) --- Jn(x) ! DJ(n+1) --- Jn'(x) ! FJ(n+1) --- Jn"(x) real(wp) Bj , bs , Dj , f , f0 , f1 , Fj , x integer k , m , mt , n , nt dimension Bj(101) , Dj(101) , Fj(101) do nt = 1 , 900 mt = int(0.5*log10(6.28*nt)-nt*log10(1.36*abs(x)/nt)) if ( mt>20 ) exit enddo m = nt bs = 0.0_wp f = 0.0_wp f0 = 0.0_wp f1 = 1.0d-35 do k = m , 0 , -1 f = 2.0_wp*(k+1.0_wp)*f1/x - f0 if ( k<=n ) Bj(k+1) = f if ( k==2*int(k/2) ) bs = bs + 2.0_wp*f f0 = f1 f1 = f enddo do k = 0 , n Bj(k+1) = Bj(k+1)/(bs-f) enddo Dj(1) = -Bj(2) Fj(1) = -1.0_wp*Bj(1) - Dj(1)/x do k = 1 , n Dj(k+1) = Bj(k) - k*Bj(k+1)/x Fj(k+1) = (k*k/(x*x)-1.0_wp)*Bj(k+1) - Dj(k+1)/x enddo end !***************************************************************************************** !> ! Compute spherical Bessel functions jn(x) and ! their derivatives subroutine sphj(n,x,Nm,Sj,Dj) ! MODIFIED to ALLOW N=0 CASE (ALSO IN SPHY) ! ! ======================================================= ! Input : x --- Argument of jn(x) ! n --- Order of jn(x) ( n = 0,1,… ) ! Output: SJ(n) --- jn(x) ! DJ(n) --- jn'(x) ! NM --- Highest order computed ! Routines called: ! MSTA1 and MSTA2 for computing the starting ! point for backward recurrence real(wp) cs , Dj , f , f0 , f1 , sa , sb , Sj , x integer k , m , n , Nm dimension Sj(0:n) , Dj(0:n) Nm = n if ( abs(x)<1.0e-100_wp ) then do k = 0 , n Sj(k) = 0.0_wp Dj(k) = 0.0_wp enddo Sj(0) = 1.0_wp if ( n>0 ) Dj(1) = .3333333333333333d0 return endif Sj(0) = sin(x)/x Dj(0) = (cos(x)-sin(x)/x)/x if ( n<1 ) return Sj(1) = (Sj(0)-cos(x))/x if ( n>=2 ) then sa = Sj(0) sb = Sj(1) m = msta1(x,200) if ( m<n ) then Nm = m else m = msta2(x,n,15) endif f = 0.0_wp f0 = 0.0_wp f1 = 1.0_wp - 100 do k = m , 0 , -1 f = (2.0_wp*k+3.0_wp)*f1/x - f0 if ( k<=Nm ) Sj(k) = f f0 = f1 f1 = f enddo cs = 0.0_wp if ( abs(sa)>abs(sb) ) cs = sa/f if ( abs(sa)<=abs(sb) ) cs = sb/f0 do k = 0 , Nm Sj(k) = cs*Sj(k) enddo endif do k = 1 , Nm Dj(k) = Sj(k-1) - (k+1.0_wp)*Sj(k)/x enddo end !***************************************************************************************** !> ! Compute orthogonal polynomials: Tn(x) or Un(x), ! or Ln(x) or Hn(x), and their derivatives subroutine othpl(Kf,n,x,Pl,Dpl) ! Input : KF --- Function code ! KF=1 for Chebyshev polynomial Tn(x) ! KF=2 for Chebyshev polynomial Un(x) ! KF=3 for Laguerre polynomial Ln(x) ! KF=4 for Hermite polynomial Hn(x) ! n --- Order of orthogonal polynomials ! x --- Argument of orthogonal polynomials ! Output: PL(n) --- Tn(x) or Un(x) or Ln(x) or Hn(x) ! DPL(n)--- Tn'(x) or Un'(x) or Ln'(x) or Hn'(x) real(wp) a , b , c , Dpl , dy0 , dy1 , dyn , Pl , x , y0 ,& & y1 , yn integer k , Kf , n dimension Pl(0:n) , Dpl(0:n) a = 2.0_wp b = 0.0_wp c = 1.0_wp y0 = 1.0_wp y1 = 2.0_wp*x dy0 = 0.0_wp dy1 = 2.0_wp Pl(0) = 1.0_wp Pl(1) = 2.0_wp*x Dpl(0) = 0.0_wp Dpl(1) = 2.0_wp if ( Kf==1 ) then y1 = x dy1 = 1.0_wp Pl(1) = x Dpl(1) = 1.0_wp elseif ( Kf==3 ) then y1 = 1.0_wp - x dy1 = -1.0_wp Pl(1) = 1.0_wp - x Dpl(1) = -1.0_wp endif do k = 2 , n if ( Kf==3 ) then a = -1.0_wp/k b = 2.0_wp + a c = 1.0_wp + a elseif ( Kf==4 ) then c = 2.0_wp*(k-1.0_wp) 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 dy1 = dyn enddo end !***************************************************************************************** !> ! Compute the zeros of Kelvin functions subroutine klvnzo(Nt,Kd,Zo) ! Input : NT --- Total number of zeros ! KD --- Function code ! KD=1 to 8 for ber x, bei x, ker x, kei x, ! ber'x, bei'x, ker'x and kei'x, ! respectively. ! Output: ZO(M) --- the M-th zero of Kelvin function ! for code KD real(wp) bei , ber , ddi , ddr , dei , der , gdi , gdr , & & gei , ger , hei , her , rt , rt0 , Zo integer Kd , m , Nt 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 m = 1 , Nt call klvna(rt,ber,bei,ger,gei,der,dei,her,hei) if ( Kd==1 ) then rt = rt - ber/der elseif ( Kd==2 ) then rt = rt - bei/dei elseif ( Kd==3 ) then rt = rt - ger/her elseif ( Kd==4 ) then rt = rt - gei/hei elseif ( Kd==5 ) then ddr = -bei - der/rt rt = rt - der/ddr elseif ( Kd==6 ) then ddi = ber - dei/rt rt = rt - dei/ddi elseif ( Kd==7 ) then gdr = -gei - her/rt rt = rt - her/gdr else gdi = ger - hei/rt rt = rt - hei/gdi endif if ( abs(rt-rt0(Kd))>5.0d-10 ) then rt0(Kd) = rt cycle endif Zo(m) = rt rt = rt + 4.44d0 enddo end !***************************************************************************************** !> ! Compute oblate radial functions of the first ! and second kinds, and their derivatives subroutine rswfo(m,n,c,x,Cv,Kf,R1f,R1d,R2f,R2d) ! Input : m --- Mode parameter, m = 0,1,2,... ! n --- Mode parameter, n = m,m+1,m+2,... ! c --- Spheroidal parameter ! x --- Argument (x ≥ 0) ! cv --- Characteristic value ! KF --- Function code ! KF=1 for the first kind ! KF=2 for the second kind ! KF=3 for both the first and second kinds ! Output: R1F --- Radial function of the first kind ! R1D --- Derivative of the radial function of ! the first kind ! R2F --- Radial function of the second kind ! R2D --- Derivative of the radial function of ! the second kind real(wp) c , Cv , df , R1d , R1f , R2d , R2f , x integer id , kd , Kf , m , n dimension df(200) kd = -1 call sdmn(m,n,c,Cv,kd,df) if ( Kf/=2 ) call rmn1(m,n,c,x,df,kd,R1f,R1d) if ( Kf>1 ) then id = 10 if ( x>1.0d-8 ) call rmn2l(m,n,c,x,df,kd,R2f,R2d,id) if ( id>-1 ) call rmn2so(m,n,c,x,Cv,df,kd,R2f,R2d) endif end !***************************************************************************************** !> ! Compute Hankel functions of the first and ! second kinds and their derivatives for a ! complex argument subroutine ch12n(n,z,Nm,Chf1,Chd1,Chf2,Chd2) ! Input : z --- Complex argument ! n --- Order of Hn(1)(z) and Hn(2)(z) ! Output: CHF1(n) --- Hn(1)(z) ! CHD1(n) --- Hn(1)'(z) ! CHF2(n) --- Hn(2)(z) ! CHD2(n) --- Hn(2)'(z) ! NM --- Highest order computed complex(wp) cbi , cbj , cbk , cby , cdi , cdj , cdk , cdy , cf1 , & & cfac , Chd1 , Chd2 , Chf1 , Chf2 , ci , z , zi integer k , n , Nm 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.0_wp,1.0_wp) if ( aimag(z)<0.0_wp ) then call cjynb(n,z,Nm,cbj,cdj,cby,cdy) do k = 0 , Nm Chf1(k) = cbj(k) + ci*cby(k) Chd1(k) = cdj(k) + ci*cdy(k) enddo zi = ci*z call ciknb(n,zi,Nm,cbi,cdi,cbk,cdk) cfac = -2.0_wp/(pi*ci) do k = 0 , Nm Chf2(k) = cfac*cbk(k) Chd2(k) = cfac*ci*cdk(k) cfac = cfac*ci enddo elseif ( aimag(z)>0.0_wp ) then zi = -ci*z call ciknb(n,zi,Nm,cbi,cdi,cbk,cdk) cf1 = -ci cfac = 2.0_wp/(pi*ci) do k = 0 , Nm Chf1(k) = cfac*cbk(k) Chd1(k) = -cfac*ci*cdk(k) cfac = cfac*cf1 enddo call cjynb(n,z,Nm,cbj,cdj,cby,cdy) do k = 0 , Nm Chf2(k) = cbj(k) - ci*cby(k) Chd2(k) = cdj(k) - ci*cdy(k) enddo else call cjynb(n,z,Nm,cbj,cdj,cby,cdy) do k = 0 , Nm Chf1(k) = cbj(k) + ci*cby(k) Chd1(k) = cdj(k) + ci*cdy(k) Chf2(k) = cbj(k) - ci*cby(k) Chd2(k) = cdj(k) - ci*cdy(k) enddo endif end !***************************************************************************************** !> ! Compute the zeros of Bessel functions Jn(x), ! Yn(x), and their derivatives subroutine jyzo(n,Nt,Rj0,Rj1,Ry0,Ry1) ! Input : n --- Order of Bessel functions (n >= 0) ! NT --- Number of zeros (roots) ! Output: RJ0(L) --- L-th zero of Jn(x), L=1,2,...,NT ! RJ1(L) --- L-th zero of Jn'(x), L=1,2,...,NT ! RY0(L) --- L-th zero of Yn(x), L=1,2,...,NT ! RY1(L) --- L-th zero of Yn'(x), L=1,2,...,NT real(wp) bjn , byn , djn , dyn , fjn , fyn , Rj0 , & & Rj1 , Ry0 , Ry1 , x , x0 , xguess integer l , n , Nt dimension Rj0(Nt) , Rj1(Nt) , Ry0(Nt) , Ry1(Nt) ! -- Newton method for j_{N,L} ! 1) initial guess for j_{N,1} if ( n<=20 ) then x = 2.82141 + 1.15859*n else ! Abr & Stg (9.5.14) x = n + 1.85576*n**0.33333 + 1.03315/n**0.33333 endif l = 0 ! 2) iterate xguess = x 100 x0 = x call jyndd(n,x,bjn,djn,fjn,byn,dyn,fyn) x = x - bjn/djn if ( x-x0<-1 ) x = x0 - 1 if ( x-x0>1 ) x = x0 + 1 if ( abs(x-x0)>1.0d-11 ) goto 100 ! 3) initial guess for j_{N,L+1} if ( l>=1 ) then if ( x<=Rj0(l)+0.5 ) then x = xguess + pi xguess = x goto 100 endif endif l = l + 1 Rj0(l) = x ! 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<Nt ) goto 100 ! -- Newton method for j_{N,L}' if ( n<=20 ) then x = 0.961587 + 1.07703*n else x = n + 0.80861*n**0.33333 + 0.07249/n**0.33333 endif if ( n==0 ) x = 3.8317 l = 0 xguess = x 200 x0 = x call jyndd(n,x,bjn,djn,fjn,byn,dyn,fyn) x = x - djn/fjn if ( x-x0<-1 ) x = x0 - 1 if ( x-x0>1 ) x = x0 + 1 if ( abs(x-x0)>1.0d-11 ) goto 200 if ( l>=1 ) then if ( x<=Rj1(l)+0.5 ) then x = xguess + pi xguess = x goto 200 endif endif l = l + 1 Rj1(l) = x ! 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<Nt ) goto 200 ! -- Newton method for y_{N,L} if ( n<=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 300 x0 = x call jyndd(n,x,bjn,djn,fjn,byn,dyn,fyn) x = x - byn/dyn if ( x-x0<-1 ) x = x0 - 1 if ( x-x0>1 ) x = x0 + 1 if ( abs(x-x0)>1.0d-11 ) goto 300 if ( l>=1 ) then if ( x<=Ry0(l)+0.5 ) then x = xguess + pi xguess = x goto 300 endif endif l = l + 1 Ry0(l) = x ! 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<Nt ) goto 300 ! -- Newton method for y_{N,L}' if ( n<=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 400 x0 = x call jyndd(n,x,bjn,djn,fjn,byn,dyn,fyn) x = x - dyn/fyn if ( abs(x-x0)>1.0d-11 ) goto 400 if ( l>=1 ) then if ( x<=Ry1(l)+0.5 ) then x = xguess + pi xguess = x goto 400 endif endif l = l + 1 Ry1(l) = x ! 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<Nt ) goto 400 end !***************************************************************************************** !> ! Compute modified Bessel functions Iv(x) and ! Kv(x), and their derivatives subroutine ikv(v,x,Vm,Bi,Di,Bk,Dk) ! Input : x --- Argument ( x ≥ 0 ) ! v --- Order of Iv(x) and Kv(x) ! ( v = n+v0, n = 0,1,2,..., 0 ≤ v0 < 1 ) ! Output: BI(n) --- In+v0(x) ! DI(n) --- In+v0'(x) ! BK(n) --- Kn+v0(x) ! DK(n) --- Kn+v0'(x) ! VM --- Highest order computed real(wp) a1 , a2 , Bi , bi0 , Bk , bk0 , bk1 , bk2 , ca , & & cb , cs , ct , Di , Dk , f , f1 , f2 , gan , & & gap real(wp) piv , r , r1 , r2 , sum , v , v0 , v0n , v0p , & & Vm , vt , w0 , wa , ww , x , x2 integer k , k0 , m , n dimension Bi(0:*) , Di(0:*) , Bk(0:*) , Dk(0:*) x2 = x*x n = int(v) v0 = v - n if ( n==0 ) n = 1 if ( x<1.0e-100_wp ) then do k = 0 , n Bi(k) = 0.0_wp Di(k) = 0.0_wp Bk(k) = -1.0e+300_wp Dk(k) = 1.0e+300_wp enddo if ( v==0.0_wp ) then Bi(0) = 1.0_wp Di(1) = 0.5_wp endif Vm = v return endif piv = pi*v0 vt = 4.0_wp*v0*v0 if ( v0==0.0_wp ) then a1 = 1.0_wp else v0p = 1.0_wp + v0 call gamma2(v0p,gap) a1 = (0.5_wp*x)**v0/gap endif k0 = 14 if ( x>=35.0_wp ) k0 = 10 if ( x>=50.0_wp ) k0 = 8 if ( x<=18.0_wp ) then bi0 = 1.0_wp r = 1.0_wp do k = 1 , 30 r = 0.25_wp*r*x2/(k*(k+v0)) bi0 = bi0 + r if ( abs(r/bi0)<1.0e-15_wp ) exit enddo bi0 = bi0*a1 else ca = exp(x)/sqrt(twopi*x) sum = 1.0_wp r = 1.0_wp do k = 1 , k0 r = -0.125_wp*r*(vt-(2.0_wp*k-1.0_wp)**2.0_wp)/(k*x) sum = sum + r enddo bi0 = ca*sum endif m = msta1(x,200) if ( m<n ) then n = m else m = msta2(x,n,15) endif f = 0.0_wp f2 = 0.0_wp f1 = 1.0e-100_wp ww = 0.0_wp do k = m , 0 , -1 f = 2.0_wp*(v0+k+1.0_wp)/x*f1 + f2 if ( k<=n ) Bi(k) = f f2 = f1 f1 = f enddo cs = bi0/f do k = 0 , n Bi(k) = cs*Bi(k) enddo Di(0) = v0/x*Bi(0) + Bi(1) do k = 1 , n Di(k) = -(k+v0)/x*Bi(k) + Bi(k-1) enddo if ( x>9.0_wp ) then cb = exp(-x)*sqrt(halfpi/x) sum = 1.0_wp r = 1.0_wp do k = 1 , k0 r = 0.125_wp*r*(vt-(2.0_wp*k-1.0_wp)**2.0_wp)/(k*x) sum = sum + r enddo bk0 = cb*sum elseif ( v0==0.0_wp ) then ct = -log(0.5_wp*x) - gamma cs = 0.0_wp w0 = 0.0_wp r = 1.0_wp do k = 1 , 50 w0 = w0 + 1.0_wp/k r = 0.25_wp*r/(k*k)*x2 cs = cs + r*(w0+ct) wa = abs(cs) if ( abs((wa-ww)/wa)<1.0e-15_wp ) exit ww = wa enddo bk0 = ct + cs else v0n = 1.0_wp - v0 call gamma2(v0n,gan) a2 = 1.0_wp/(gan*(0.5_wp*x)**v0) a1 = (0.5_wp*x)**v0/gap sum = a2 - a1 r1 = 1.0_wp r2 = 1.0_wp do k = 1 , 120 r1 = 0.25_wp*r1*x2/(k*(k-v0)) r2 = 0.25_wp*r2*x2/(k*(k+v0)) sum = sum + a2*r1 - a1*r2 wa = abs(sum) if ( abs((wa-ww)/wa)<1.0e-15_wp ) exit ww = wa enddo bk0 = halfpi*sum/sin(piv) endif bk1 = (1.0_wp/x-Bi(1)*bk0)/Bi(0) Bk(0) = bk0 Bk(1) = bk1 do k = 2 , n bk2 = 2.0_wp*(v0+k-1.0_wp)/x*bk1 + bk0 Bk(k) = bk2 bk0 = bk1 bk1 = bk2 enddo Dk(0) = v0/x*Bk(0) - Bk(1) do k = 1 , n Dk(k) = -(k+v0)/x*Bk(k) - Bk(k-1) enddo Vm = n + v0 end !***************************************************************************************** !> ! Compute the expansion coefficients of the ! prolate and oblate spheroidal functions, dk subroutine sdmn(m,n,c,Cv,Kd,Df) ! Input : m --- Mode parameter ! n --- Mode parameter ! c --- Spheroidal parameter ! cv --- Characteristic value ! KD --- Function code ! KD=1 for prolate; KD=-1 for oblate ! Output: DF(k) --- Expansion coefficients dk; ! DF(1), DF(2), ... correspond to ! d0, d2, ... for even n-m and d1, ! d3, ... for odd n-m real(wp) a , c , cs , Cv , d , d2k , Df , dk0 , dk1 , & & dk2 , f , f0 , f1 , f2 , fl , fs , g , r1 , r3 , & & r4 real(wp) s0 , su1 , su2 , sw integer i , ip , j , k , k1 , kb , Kd , m , n , nm dimension a(200) , d(200) , g(200) , Df(200) nm = 25 + int(0.5*(n-m)+c) if ( c<1.0d-10 ) then do i = 1 , nm Df(i) = 0d0 enddo Df((n-m)/2+1) = 1.0_wp return endif cs = c*c*Kd ip = 1 k = 0 if ( n-m==2*int((n-m)/2) ) ip = 0 do i = 1 , nm + 2 if ( ip==0 ) k = 2*(i-1) if ( ip==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_wp)*(d2k+1.0_wp)/((dk2+3.0_wp)*(dk2+5.0_wp))*cs d(i) = dk0*dk1 + (2.0_wp*dk0*dk1-2.0_wp*m*m-1.0_wp) & & /((dk2-1.0_wp)*(dk2+3.0_wp))*cs g(i) = k*(k-1.0_wp)/((dk2-3.0_wp)*(dk2-1.0_wp))*cs enddo fs = 1.0_wp f1 = 0.0_wp f0 = 1.0e-100_wp kb = 0 Df(nm+1) = 0.0_wp fl = 0.0_wp do k = nm , 1 , -1 f = -((d(k+1)-Cv)*f0+a(k+1)*f1)/g(k+1) if ( abs(f)>abs(Df(k+1)) ) then Df(k) = f f1 = f0 f0 = f if ( abs(f)>1.0d+100 ) then do k1 = k , nm Df(k1) = Df(k1)*1.0e-100_wp enddo f1 = f1*1.0e-100_wp f0 = f0*1.0e-100_wp endif else kb = k fl = Df(k+1) f1 = 1.0e-100_wp f2 = -(d(1)-Cv)/a(1)*f1 Df(1) = f1 if ( kb==1 ) then fs = f2 elseif ( kb==2 ) then Df(2) = f2 fs = -((d(2)-Cv)*f2+g(2)*f1)/a(2) else Df(2) = f2 do j = 3 , kb + 1 f = -((d(j-1)-Cv)*f2+g(j-1)*f1)/a(j-1) if ( j<=kb ) Df(j) = f if ( abs(f)>1.0d+100 ) then do k1 = 1 , j Df(k1) = Df(k1)*1.0e-100_wp enddo f = f*1.0e-100_wp f2 = f2*1.0e-100_wp endif f1 = f2 f2 = f enddo fs = f endif exit endif enddo su1 = 0.0_wp r1 = 1.0_wp do j = m + ip + 1 , 2*(m+ip) r1 = r1*j enddo su1 = Df(1)*r1 do k = 2 , kb r1 = -r1*(k+m+ip-1.5_wp)/(k-1.0_wp) su1 = su1 + r1*Df(k) enddo su2 = 0.0_wp sw = 0.0_wp do k = kb + 1 , nm if ( k/=1 ) r1 = -r1*(k+m+ip-1.5_wp)/(k-1.0_wp) su2 = su2 + r1*Df(k) if ( abs(sw-su2)<abs(su2)*1.0d-14 ) exit sw = su2 enddo r3 = 1.0_wp do j = 1 , (m+n+ip)/2 r3 = r3*(j+0.5_wp*(n+m+ip)) enddo r4 = 1.0_wp do j = 1 , (n-m-ip)/2 r4 = -4.0_wp*r4*j enddo s0 = r3/(fl*(su1/fs)+su2)/r4 do k = 1 , kb Df(k) = fl/fs*s0*Df(k) enddo do k = kb + 1 , nm Df(k) = s0*Df(k) enddo end !***************************************************************************************** !> ! Compute Bessel functions Jv(x) and Yv(x), ! and modified Bessel functions Iv(x) and ! Kv(x), and their derivatives with v=1/3,2/3 subroutine ajyik(x,Vj1,Vj2,Vy1,Vy2,Vi1,Vi2,Vk1,Vk2) ! Input : x --- Argument of Jv(x),Yv(x),Iv(x) and ! Kv(x) ( x ≥ 0 ) ! Output: VJ1 --- J1/3(x) ! VJ2 --- J2/3(x) ! VY1 --- Y1/3(x) ! VY2 --- Y2/3(x) ! VI1 --- I1/3(x) ! VI2 --- I2/3(x) ! VK1 --- K1/3(x) ! VK2 --- K2/3(x) real(wp) a0 , b0 , c0 , ck , gn , gn1 , gn2 , gp1 , gp2 , & & pv1 , pv2 , px , qx , r , rp , rp2 , rq , & & sk , sum real(wp) uj1 , uj2 , uu0 , Vi1 , Vi2 , vil , Vj1 , Vj2 , & & vjl , Vk1 , Vk2 , vl , vsl , vv , vv0 , Vy1 , & & Vy2 , x , x2 , xk integer k , k0 , l if ( x==0.0_wp ) then Vj1 = 0.0_wp Vj2 = 0.0_wp Vy1 = -1.0e+300_wp Vy2 = 1.0e+300_wp Vi1 = 0.0_wp Vi2 = 0.0_wp Vk1 = -1.0e+300_wp Vk2 = -1.0e+300_wp return endif 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>=35.0_wp ) k0 = 10 if ( x>=50.0_wp ) k0 = 8 if ( x<=12.0_wp ) then do l = 1 , 2 vl = l/3.0_wp vjl = 1.0_wp r = 1.0_wp do k = 1 , 40 r = -0.25_wp*r*x2/(k*(k+vl)) vjl = vjl + r if ( abs(r)<1.0e-15_wp ) exit enddo a0 = (0.5_wp*x)**vl if ( l==1 ) Vj1 = a0/gp1*vjl if ( l==2 ) Vj2 = a0/gp2*vjl enddo else do l = 1 , 2 vv = vv0*l*l px = 1.0_wp rp = 1.0_wp do k = 1 , k0 rp = -0.78125d-2*rp*(vv-(4.0_wp*k-3.0_wp)**2.0_wp) & & *(vv-(4.0_wp*k-1.0_wp)**2.0_wp)/(k*(2.0_wp*k-1.0_wp)*x2) px = px + rp enddo qx = 1.0_wp rq = 1.0_wp do k = 1 , k0 rq = -0.78125d-2*rq*(vv-(4.0_wp*k-1.0_wp)**2.0_wp) & & *(vv-(4.0_wp*k+1.0_wp)**2.0_wp)/(k*(2.0_wp*k+1.0_wp)*x2) qx = qx + rq enddo qx = 0.125_wp*(vv-1.0_wp)*qx/x xk = x - (0.5_wp*l/3.0_wp+0.25_wp)*pi a0 = sqrt(rp2/x) ck = cos(xk) sk = sin(xk) if ( l==1 ) then Vj1 = a0*(px*ck-qx*sk) Vy1 = a0*(px*sk+qx*ck) elseif ( l==2 ) then Vj2 = a0*(px*ck-qx*sk) Vy2 = a0*(px*sk+qx*ck) endif enddo endif if ( x<=12.0d0 ) then uj1 = 0.0_wp uj2 = 0.0_wp do l = 1 , 2 vl = l/3.0_wp vjl = 1.0_wp r = 1.0_wp do k = 1 , 40 r = -0.25_wp*r*x2/(k*(k-vl)) vjl = vjl + r if ( abs(r)<1.0e-15_wp ) exit enddo b0 = (2.0_wp/x)**vl if ( l==1 ) uj1 = b0*vjl/gn1 if ( l==2 ) uj2 = b0*vjl/gn2 enddo pv1 = pi/3.0_wp pv2 = pi/1.5_wp Vy1 = uu0*(Vj1*cos(pv1)-uj1) Vy2 = uu0*(Vj2*cos(pv2)-uj2) endif if ( x<=18.0_wp ) then do l = 1 , 2 vl = l/3.0_wp vil = 1.0_wp r = 1.0_wp do k = 1 , 40 r = 0.25_wp*r*x2/(k*(k+vl)) vil = vil + r if ( abs(r)<1.0e-15_wp ) exit enddo a0 = (0.5_wp*x)**vl if ( l==1 ) Vi1 = a0/gp1*vil if ( l==2 ) Vi2 = a0/gp2*vil enddo else c0 = exp(x)/sqrt(twopi*x) do l = 1 , 2 vv = vv0*l*l vsl = 1.0_wp r = 1.0_wp do k = 1 , k0 r = -0.125_wp*r*(vv-(2.0_wp*k-1.0_wp)**2.0_wp)/(k*x) vsl = vsl + r enddo if ( l==1 ) Vi1 = c0*vsl if ( l==2 ) Vi2 = c0*vsl enddo endif if ( x<=9.0_wp ) then gn = 0.0_wp do l = 1 , 2 vl = l/3.0_wp if ( l==1 ) gn = gn1 if ( l==2 ) gn = gn2 a0 = (2.0_wp/x)**vl/gn sum = 1.0_wp r = 1.0_wp do k = 1 , 60 r = 0.25_wp*r*x2/(k*(k-vl)) sum = sum + r if ( abs(r)<1.0e-15_wp ) exit enddo if ( l==1 ) Vk1 = 0.5_wp*uu0*pi*(sum*a0-Vi1) if ( l==2 ) Vk2 = 0.5_wp*uu0*pi*(sum*a0-Vi2) enddo else c0 = exp(-x)*sqrt(halfpi/x) do l = 1 , 2 vv = vv0*l*l sum = 1.0_wp r = 1.0_wp do k = 1 , k0 r = 0.125_wp*r*(vv-(2.0_wp*k-1.0_wp)**2.0_wp)/(k*x) sum = sum + r enddo if ( l==1 ) Vk1 = c0*sum if ( l==2 ) Vk2 = c0*sum enddo endif end !***************************************************************************************** !> ! Compute the modified Bessel functions Iv(z), Kv(z) ! and their derivatives for an arbitrary order and ! complex argument subroutine cikvb(v,z,Vm,Cbi,Cdi,Cbk,Cdk) ! Input : z --- Complex argument z ! v --- Real order of Iv(z) and Kv(z) ! ( v =n+v0, n = 0,1,2,..., 0 ≤ v0 < 1 ) ! Output: CBI(n) --- In+v0(z) ! CDI(n) --- In+v0'(z) ! CBK(n) --- Kn+v0(z) ! CDK(n) --- Kn+v0'(z) ! VM --- Highest order computed real(wp) a0 , gan , gap , piv , v , v0 , v0n , v0p , & & Vm , vt , w0 complex(wp) ca , ca1 , ca2 , cb , Cbi , cbi0 , Cbk , cbk0 , Cdi , & & Cdk , cf , cf1 , cf2 , ci , ci0 , ckk , cp , cr , cr1 ,& & cr2 complex(wp) cs , csu , ct , cvk , z , z1 , z2 integer k , k0 , m , n dimension Cbi(0:*) , Cdi(0:*) , Cbk(0:*) , Cdk(0:*) z1 = z z2 = z*z a0 = abs(z) ci = (0.0_wp,1.0_wp) n = int(v) v0 = v - n piv = pi*v0 vt = 4.0_wp*v0*v0 if ( n==0 ) n = 1 if ( a0<1.0e-100_wp ) then do k = 0 , n Cbi(k) = 0.0_wp Cdi(k) = 0.0_wp Cbk(k) = -1.0e+300_wp Cdk(k) = 1.0e+300_wp enddo if ( v0==0.0_wp ) then Cbi(0) = (1.0_wp,0.0_wp) Cdi(1) = (0.5_wp,0.0_wp) endif Vm = v return endif k0 = 14 if ( a0>=35.0_wp ) k0 = 10 if ( a0>=50.0_wp ) k0 = 8 if ( real(z,wp)<0.0_wp ) z1 = -z if ( a0<18.0_wp ) then if ( v0==0.0_wp ) then ca1 = (1.0_wp,0.0_wp) else v0p = 1.0_wp + v0 call gamma2(v0p,gap) ca1 = (0.5_wp*z1)**v0/gap endif ci0 = (1.0_wp,0.0_wp) cr = (1.0_wp,0.0_wp) do k = 1 , 50 cr = 0.25_wp*cr*z2/(k*(k+v0)) ci0 = ci0 + cr if ( abs(cr/ci0)<1.0e-15_wp ) exit enddo cbi0 = ci0*ca1 else ca = exp(z1)/sqrt(twopi*z1) cs = (1.0_wp,0.0_wp) cr = (1.0_wp,0.0_wp) do k = 1 , k0 cr = -0.125_wp*cr*(vt-(2.0_wp*k-1.0_wp)**2.0_wp)/(k*z1) cs = cs + cr enddo cbi0 = ca*cs endif m = msta1(a0,200) if ( m<n ) then n = m else m = msta2(a0,n,15) endif cf2 = (0.0_wp,0.0_wp) cf1 = (1.0e-100_wp,0.0_wp) do k = m , 0 , -1 cf = 2.0_wp*(v0+k+1.0_wp)/z1*cf1 + cf2 if ( k<=n ) Cbi(k) = cf cf2 = cf1 cf1 = cf enddo cs = cbi0/cf do k = 0 , n Cbi(k) = cs*Cbi(k) enddo if ( a0>9.0_wp ) then cb = exp(-z1)*sqrt(halfpi/z1) cs = (1.0_wp,0.0_wp) cr = (1.0_wp,0.0_wp) do k = 1 , k0 cr = 0.125_wp*cr*(vt-(2.0_wp*k-1.0_wp)**2.0_wp)/(k*z1) cs = cs + cr enddo cbk0 = cb*cs elseif ( v0==0.0_wp ) then ct = -log(0.5_wp*z1) - gamma cs = (0.0_wp,0.0_wp) w0 = 0.0_wp cr = (1.0_wp,0.0_wp) do k = 1 , 50 w0 = w0 + 1.0_wp/k cr = 0.25_wp*cr/(k*k)*z2 cp = cr*(w0+ct) cs = cs + cp if ( k>=10 .and. abs(cp/cs)<1.0e-15_wp ) exit enddo cbk0 = ct + cs else v0n = 1.0_wp - v0 call gamma2(v0n,gan) ca2 = 1.0_wp/(gan*(0.5_wp*z1)**v0) ca1 = (0.5_wp*z1)**v0/gap csu = ca2 - ca1 cr1 = (1.0_wp,0.0_wp) cr2 = (1.0_wp,0.0_wp) do k = 1 , 50 cr1 = 0.25_wp*cr1*z2/(k*(k-v0)) cr2 = 0.25_wp*cr2*z2/(k*(k+v0)) cp = ca2*cr1 - ca1*cr2 csu = csu + cp if ( k>=10 .and. abs(cp/csu)<1.0e-15_wp ) exit enddo cbk0 = halfpi*csu/sin(piv) endif Cbk(0) = cbk0 if ( real(z,wp)<0.0_wp ) then do k = 0 , n cvk = exp((k+v0)*pi*ci) if ( aimag(z)<0.0_wp ) then Cbk(k) = cvk*Cbk(k) + pi*ci*Cbi(k) Cbi(k) = Cbi(k)/cvk elseif ( aimag(z)>0.0_wp ) then Cbk(k) = Cbk(k)/cvk - pi*ci*Cbi(k) Cbi(k) = cvk*Cbi(k) endif enddo endif do k = 1 , n ckk = (1.0_wp/z-Cbi(k)*Cbk(k-1))/Cbi(k-1) Cbk(k) = ckk enddo Cdi(0) = v0/z*Cbi(0) + Cbi(1) Cdk(0) = v0/z*Cbk(0) - Cbk(1) do k = 1 , n Cdi(k) = -(k+v0)/z*Cbi(k) + Cbi(k-1) Cdk(k) = -(k+v0)/z*Cbk(k) - Cbk(k-1) enddo Vm = n + v0 end !***************************************************************************************** !> ! Compute the modified Bessel functions Iv(z), Kv(z) ! and their derivatives for an arbitrary order and ! complex argument subroutine cikva(v,z,Vm,Cbi,Cdi,Cbk,Cdk) ! Input : z --- Complex argument ! v --- Real order of Iv(z) and Kv(z) ! ( v = n+v0, n = 0,1,2,…, 0 ≤ v0 < 1 ) ! Output: CBI(n) --- In+v0(z) ! CDI(n) --- In+v0'(z) ! CBK(n) --- Kn+v0(z) ! CDK(n) --- Kn+v0'(z) ! VM --- Highest order computed real(wp) a0 , gan , gap , piv , v , v0 , v0n , v0p , & & Vm , vt , w0 , ws , ws0 complex(wp) ca , ca1 , ca2 , cb , Cbi , cbi0 , Cbk , cbk0 , cbk1 , & & Cdi , Cdk , cf , cf1 , cf2 , cg0 , cg1 , cgk , ci , & & ci0 , cp complex(wp) cr , cr1 , cr2 , cs , csu , ct , cvk , z , z1 , z2 integer k , k0 , m , n dimension Cbi(0:*) , Cdi(0:*) , Cbk(0:*) , Cdk(0:*) ci = (0.0_wp,1.0_wp) a0 = abs(z) z1 = z z2 = z*z n = int(v) v0 = v - n piv = pi*v0 vt = 4.0_wp*v0*v0 if ( n==0 ) n = 1 if ( a0<1.0e-100_wp ) then do k = 0 , n Cbi(k) = 0.0_wp Cdi(k) = 0.0_wp Cbk(k) = -1.0e+300_wp Cdk(k) = 1.0e+300_wp enddo if ( v0==0.0_wp ) then Cbi(0) = (1.0_wp,0.0_wp) Cdi(1) = (0.5_wp,0.0_wp) endif Vm = v return endif k0 = 14 if ( a0>=35.0_wp ) k0 = 10 if ( a0>=50.0_wp ) k0 = 8 if ( real(z,wp)<0.0_wp ) z1 = -z if ( a0<18.0_wp ) then if ( v0==0.0_wp ) then ca1 = (1.0_wp,0.0_wp) else v0p = 1.0_wp + v0 call gamma2(v0p,gap) ca1 = (0.5_wp*z1)**v0/gap endif ci0 = (1.0_wp,0.0_wp) cr = (1.0_wp,0.0_wp) do k = 1 , 50 cr = 0.25_wp*cr*z2/(k*(k+v0)) ci0 = ci0 + cr if ( abs(cr)<abs(ci0)*1.0e-15_wp ) exit enddo cbi0 = ci0*ca1 else ca = exp(z1)/sqrt(twopi*z1) cs = (1.0_wp,0.0_wp) cr = (1.0_wp,0.0_wp) do k = 1 , k0 cr = -0.125_wp*cr*(vt-(2.0_wp*k-1.0_wp)**2.0_wp)/(k*z1) cs = cs + cr enddo cbi0 = ca*cs endif m = msta1(a0,200) if ( m<n ) then n = m else m = msta2(a0,n,15) endif cf2 = (0.0_wp,0.0_wp) cf1 = (1.0e-100_wp,0.0_wp) do k = m , 0 , -1 cf = 2.0_wp*(v0+k+1.0_wp)/z1*cf1 + cf2 if ( k<=n ) Cbi(k) = cf cf2 = cf1 cf1 = cf enddo cs = cbi0/cf do k = 0 , n Cbi(k) = cs*Cbi(k) enddo if ( a0>9.0_wp ) then cb = exp(-z1)*sqrt(halfpi/z1) cs = (1.0_wp,0.0_wp) cr = (1.0_wp,0.0_wp) do k = 1 , k0 cr = 0.125_wp*cr*(vt-(2.0_wp*k-1.0_wp)**2.0_wp)/(k*z1) cs = cs + cr enddo cbk0 = cb*cs elseif ( v0==0.0_wp ) then ct = -log(0.5_wp*z1) - gamma cs = (0.0_wp,0.0_wp) w0 = 0.0_wp cr = (1.0_wp,0.0_wp) do k = 1 , 50 w0 = w0 + 1.0_wp/k cr = 0.25_wp*cr/(k*k)*z2 cp = cr*(w0+ct) cs = cs + cp if ( k>=10 .and. abs(cp/cs)<1.0e-15_wp ) exit enddo cbk0 = ct + cs else v0n = 1.0_wp - v0 call gamma2(v0n,gan) ca2 = 1.0_wp/(gan*(0.5_wp*z1)**v0) ca1 = (0.5_wp*z1)**v0/gap csu = ca2 - ca1 cr1 = (1.0_wp,0.0_wp) cr2 = (1.0_wp,0.0_wp) ws0 = 0.0_wp do k = 1 , 50 cr1 = 0.25_wp*cr1*z2/(k*(k-v0)) cr2 = 0.25_wp*cr2*z2/(k*(k+v0)) csu = csu + ca2*cr1 - ca1*cr2 ws = abs(csu) if ( k>=10 .and. abs(ws-ws0)/ws<1.0e-15_wp ) exit ws0 = ws enddo cbk0 = halfpi*csu/sin(piv) endif cbk1 = (1.0_wp/z1-Cbi(1)*cbk0)/Cbi(0) Cbk(0) = cbk0 Cbk(1) = cbk1 cg0 = cbk0 cg1 = cbk1 do k = 2 , n cgk = 2.0_wp*(v0+k-1.0_wp)/z1*cg1 + cg0 Cbk(k) = cgk cg0 = cg1 cg1 = cgk enddo if ( real(z,wp)<0.0_wp ) then do k = 0 , n cvk = exp((k+v0)*pi*ci) if ( aimag(z)<0.0_wp ) then Cbk(k) = cvk*Cbk(k) + pi*ci*Cbi(k) Cbi(k) = Cbi(k)/cvk elseif ( aimag(z)>0.0_wp ) then Cbk(k) = Cbk(k)/cvk - pi*ci*Cbi(k) Cbi(k) = cvk*Cbi(k) endif enddo endif Cdi(0) = v0/z*Cbi(0) + Cbi(1) Cdk(0) = v0/z*Cbk(0) - Cbk(1) do k = 1 , n Cdi(k) = -(k+v0)/z*Cbi(k) + Cbi(k-1) Cdk(k) = -(k+v0)/z*Cbk(k) - Cbk(k-1) enddo Vm = n + v0 end !***************************************************************************************** !> ! Compute complex Fresnel integral C(z) and C'(z) subroutine cfc(z,Zf,Zd) ! Input : z --- Argument of C(z) ! Output: ZF --- C(z) ! ZD --- C'(z) complex(wp) c , cf , cf0 , cf1 , cg , cr , d , z , z0 , Zd , Zf , & & zp , zp2 real(wp) w0 , wa , wa0 integer k , m real(wp),parameter :: eps = 1.0e-14_wp w0 = abs(z) zp = halfpi*z*z zp2 = zp*zp z0 = (0.0_wp,0.0_wp) if ( z==z0 ) then c = z0 elseif ( w0<=2.5 ) then cr = z c = cr wa0 = 0.0_wp do k = 1 , 80 cr = -0.5_wp*cr*(4.0_wp*k-3.0_wp)/k/(2.0_wp*k-1.0_wp) & & /(4.0_wp*k+1.0_wp)*zp2 c = c + cr wa = abs(c) if ( abs((wa-wa0)/wa)<eps .and. k>10 ) goto 100 wa0 = wa enddo elseif ( w0>2.5 .and. w0<4.5 ) then m = 85 c = z0 cf1 = z0 cf0 = (1.0e-100_wp,0.0_wp) do k = m , 0 , -1 cf = (2.0_wp*k+3.0_wp)*cf0/zp - cf1 if ( k==int(k/2)*2 ) c = c + cf cf1 = cf0 cf0 = cf enddo c = 2.0_wp/(pi*z)*sin(zp)/cf*c else ! See comment at CFS(), use C(z) = iC(-iz) if ( aimag(z)>-real(z,wp) .and. aimag(z)<=real(z,wp) ) then ! right quadrant d = cmplx(0.5_wp,0.0_wp,kind=wp) elseif ( aimag(z)>real(z,wp) .and. aimag(z)>=-real(z,wp) ) then ! upper quadrant d = cmplx(0.0_wp,0.5_wp,kind=wp) elseif ( aimag(z)<-real(z,wp) .and. aimag(z)>=real(z,wp) ) then ! left quadrant d = cmplx(-0.5_wp,0.0_wp,kind=wp) else ! lower quadrant d = cmplx(0.0_wp,-0.5_wp,kind=wp) endif cr = (1.0_wp,0.0_wp) cf = (1.0_wp,0.0_wp) do k = 1 , 20 cr = -0.25_wp*cr*(4.0_wp*k-1.0_wp)*(4.0_wp*k-3.0_wp)/zp2 cf = cf + cr enddo cr = 1.0_wp/(pi*z*z) cg = cr do k = 1 , 12 cr = -0.25_wp*cr*(4.0_wp*k+1.0_wp)*(4.0_wp*k-1.0_wp)/zp2 cg = cg + cr enddo c = d + (cf*sin(zp)-cg*cos(zp))/(pi*z) endif 100 Zf = c Zd = cos(halfpi*z*z) end !***************************************************************************************** !> ! Compute Fresnel integrals C(x) and S(x) subroutine fcs(x,c,s) ! Input : x --- Argument of C(x) and S(x) ! Output: C --- C(x) ! S --- S(x) real(wp) c , f , f0 , f1 , g , px , q , r , s ,& & su , t , t0 , t2 , x , xa integer k , m real(wp),parameter :: eps = 1.0e-15_wp xa = abs(x) px = pi*xa t = 0.5_wp*px*xa t2 = t*t if ( xa==0.0_wp ) then c = 0.0_wp s = 0.0_wp elseif ( xa<2.5_wp ) then r = xa c = r do k = 1 , 50 r = -0.5_wp*r*(4.0_wp*k-3.0_wp)/k/(2.0_wp*k-1.0_wp) & & /(4.0_wp*k+1.0_wp)*t2 c = c + r if ( abs(r)<abs(c)*eps ) exit enddo s = xa*t/3.0_wp r = s do k = 1 , 50 r = -0.5_wp*r*(4.0_wp*k-1.0_wp)/k/(2.0_wp*k+1.0_wp) & & /(4.0_wp*k+3.0_wp)*t2 s = s + r if ( abs(r)<abs(s)*eps ) goto 100 enddo elseif ( xa<4.5_wp ) then m = int(42.0+1.75*t) su = 0.0_wp c = 0.0_wp s = 0.0_wp f1 = 0.0_wp f0 = 1.0e-100_wp do k = m , 0 , -1 f = (2.0_wp*k+3.0_wp)*f0/t - f1 if ( k==int(k/2)*2 ) then c = c + f else s = s + f endif su = su + (2.0_wp*k+1.0_wp)*f*f f1 = f0 f0 = f enddo q = sqrt(su) c = c*xa/q s = s*xa/q else r = 1.0_wp f = 1.0_wp do k = 1 , 20 r = -0.25_wp*r*(4.0_wp*k-1.0_wp)*(4.0_wp*k-3.0_wp)/t2 f = f + r enddo r = 1.0_wp/(px*xa) g = r do k = 1 , 12 r = -0.25_wp*r*(4.0_wp*k+1.0_wp)*(4.0_wp*k-1.0_wp)/t2 g = g + r enddo t0 = t - int(t/(twopi))*twopi c = 0.5_wp + (f*sin(t0)-g*cos(t0))/px s = 0.5_wp - (f*cos(t0)+g*sin(t0))/px endif 100 if ( x<0.0_wp ) then c = -c s = -s endif end !***************************************************************************************** !> ! Compute Riccati-Bessel functions of the first ! kind and their derivatives subroutine rctj(n,x,Nm,Rj,Dj) ! Input: x --- Argument of Riccati-Bessel function ! n --- Order of jn(x) ( n = 0,1,2,... ) ! Output: RJ(n) --- x·jn(x) ! DJ(n) --- [x·jn(x)]' ! NM --- Highest order computed real(wp) cs , Dj , f , f0 , f1 , Rj , rj0 , rj1 , x integer k , m , n , Nm dimension Rj(0:n) , Dj(0:n) Nm = n if ( abs(x)<1.0e-100_wp ) then do k = 0 , n Rj(k) = 0.0_wp Dj(k) = 0.0_wp enddo Dj(0) = 1.0_wp return endif Rj(0) = sin(x) Rj(1) = Rj(0)/x - cos(x) rj0 = Rj(0) rj1 = Rj(1) cs = 0.0_wp f = 0.0_wp if ( n>=2 ) then m = msta1(x,200) if ( m<n ) then Nm = m else m = msta2(x,n,15) endif f0 = 0.0_wp f1 = 1.0e-100_wp do k = m , 0 , -1 f = (2.0_wp*k+3.0_wp)*f1/x - f0 if ( k<=Nm ) Rj(k) = f f0 = f1 f1 = f enddo if ( abs(rj0)>abs(rj1) ) cs = rj0/f if ( abs(rj0)<=abs(rj1) ) cs = rj1/f0 do k = 0 , Nm Rj(k) = cs*Rj(k) enddo endif Dj(0) = cos(x) do k = 1 , Nm Dj(k) = -k*Rj(k)/x + Rj(k-1) enddo end !***************************************************************************************** !> ! Compute the zeros of Hermite polynomial Ln(x) ! in the interval [-∞,∞], and the corresponding ! weighting coefficients for Gauss-Hermite ! integration subroutine herzo(n,x,w) ! Input : n --- Order of the Hermite polynomial ! X(n) --- Zeros of the Hermite polynomial ! W(n) --- Corresponding weighting coefficients real(wp) f0 , f1 , fd , gd , hd , hf , hn , p , q , r , & & r1 , r2 , w , wp_ , x , z , z0 , zl integer i , it , j , k , n , nr dimension x(n) , w(n) hn = 1.0_wp/n zl = -1.1611d0 + 1.46d0*n**0.5 z = 0.0_wp hf = 0.0_wp hd = 0.0_wp do nr = 1 , n/2 if ( nr==1 ) z = zl if ( nr/=1 ) z = z - hn*(n/2+1-nr) it = 0 50 it = it + 1 z0 = z f0 = 1.0_wp f1 = 2.0_wp*z do k = 2 , n hf = 2.0_wp*z*f1 - 2.0_wp*(k-1.0_wp)*f0 hd = 2.0_wp*k*f1 f0 = f1 f1 = hf enddo p = 1.0_wp do i = 1 , nr - 1 p = p*(z-x(i)) enddo fd = hf/p q = 0.0_wp do i = 1 , nr - 1 wp_ = 1.0_wp do j = 1 , nr - 1 if ( j/=i ) wp_ = wp_*(z-x(j)) enddo q = q + wp_ enddo gd = (hd-q*fd)/p z = z - fd/gd if ( it<=40 .and. abs((z-z0)/z)>1.0e-15_wp ) goto 50 x(nr) = z x(n+1-nr) = -z r = 1.0_wp do k = 1 , n r = 2.0_wp*r*k enddo w(nr) = 3.544907701811d0*r/(hd*hd) w(n+1-nr) = w(nr) enddo if ( n/=2*int(n/2) ) then r1 = 1.0_wp r2 = 1.0_wp do j = 1 , n r1 = 2.0_wp*r1*j if ( j>=(n+1)/2 ) r2 = r2*j enddo w(n/2+1) = 0.88622692545276d0*r1/(r2*r2) x(n/2+1) = 0.0_wp endif end !***************************************************************************************** !> ! Compute Bessel functions J0(x), J1(x), Y0(x), ! Y1(x), and their derivatives subroutine jy01b(x,Bj0,Dj0,Bj1,Dj1,By0,Dy0,By1,Dy1) ! Input : x --- Argument of Jn(x) & Yn(x) ( x ≥ 0 ) ! Output: BJ0 --- J0(x) ! DJ0 --- J0'(x) ! BJ1 --- J1(x) ! DJ1 --- J1'(x) ! BY0 --- Y0(x) ! DY0 --- Y0'(x) ! BY1 --- Y1(x) ! DY1 --- Y1'(x) real(wp) a0 , Bj0 , Bj1 , By0 , By1 , Dj0 , Dj1 , Dy0 , & & Dy1 , p0 , p1 , q0 , q1 , t , t2 , ta0 , & & ta1 , x if ( x==0.0_wp ) then Bj0 = 1.0_wp Bj1 = 0.0_wp Dj0 = 0.0_wp Dj1 = 0.5_wp By0 = -1.0e+300_wp By1 = -1.0e+300_wp Dy0 = 1.0e+300_wp Dy1 = 1.0e+300_wp return elseif ( x<=4.0_wp ) then t = x/4.0_wp t2 = t*t Bj0 = ((((((-.5014415d-3*t2+.76771853d-2)*t2-.0709253492d0)*t2+& & .4443584263d0)*t2-1.7777560599d0)*t2+3.9999973021d0) & & *t2-3.9999998721d0)*t2 + 1.0_wp 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.0_wp/pi*log(x/2.0_wp)*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.0_wp/pi*log(x/2.0_wp)*Bj1 + By1 else t = 4.0_wp/x t2 = t*t a0 = sqrt(2.0_wp/(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 - .25_wp*pi Bj0 = a0*(p0*cos(ta0)-q0*sin(ta0)) By0 = a0*(p0*sin(ta0)+q0*cos(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*cos(ta1)-q1*sin(ta1)) By1 = a0*(p1*sin(ta1)+q1*cos(ta1)) endif Dj0 = -Bj1 Dj1 = Bj0 - Bj1/x Dy0 = -By1 Dy1 = By0 - By1/x end !***************************************************************************************** !> ! Compute exponential integral En(x) subroutine enxb(n,x,En) ! Input : x --- Argument of En(x) ! n --- Order of En(x) (n = 0,1,2,...) ! Output: EN(n) --- En(x) real(wp) En , ens , ps , r , rp , s , s0 , t , t0 , x integer j , k , l , m , n dimension En(0:n) if ( x==0.0_wp ) then En(0) = 1.0e+300_wp En(1) = 1.0e+300_wp do k = 2 , n En(k) = 1.0_wp/(k-1.0_wp) enddo return elseif ( x<=1.0_wp ) then En(0) = exp(-x)/x s0 = 0.0_wp do l = 1 , n rp = 1.0_wp do j = 1 , l - 1 rp = -rp*x/j enddo ps = -0.5772156649015328d0 do m = 1 , l - 1 ps = ps + 1.0_wp/m enddo ens = rp*(-log(x)+ps) s = 0.0_wp do m = 0 , 20 if ( m/=l-1 ) then r = 1.0_wp do j = 1 , m r = -r*x/j enddo s = s + r/(m-l+1.0_wp) if ( abs(s-s0)<abs(s)*1.0e-15_wp ) exit s0 = s endif enddo En(l) = ens - s enddo else En(0) = exp(-x)/x m = 15 + int(100.0/x) do l = 1 , n t0 = 0.0_wp do k = m , 1 , -1 t0 = (l+k-1.0_wp)/(1.0_wp+k/(x+t0)) enddo t = 1.0_wp/(x+t0) En(l) = exp(-x)*t enddo endif end !***************************************************************************************** !> ! Compute modified spherical Bessel functions ! of the second kind, kn(x) and kn'(x) subroutine sphk(n,x,Nm,Sk,Dk) ! Input : x --- Argument of kn(x) ( x ≥ 0 ) ! n --- Order of kn(x) ( n = 0,1,2,... ) ! Output: SK(n) --- kn(x) ! DK(n) --- kn'(x) ! NM --- Highest order computed real(wp) Dk , f , f0 , f1 , Sk , x integer k , n , Nm dimension Sk(0:n) , Dk(0:n) Nm = n if ( x<1.0d-60 ) then do k = 0 , n Sk(k) = 1.0e+300_wp Dk(k) = -1.0e+300_wp enddo return endif Sk(0) = halfpi/x*exp(-x) Sk(1) = Sk(0)*(1.0_wp+1.0_wp/x) f0 = Sk(0) f1 = Sk(1) do k = 2 , n f = (2.0_wp*k-1.0_wp)*f1/x + f0 Sk(k) = f if ( abs(f)>1.0e+300_wp ) exit f0 = f1 f1 = f enddo Nm = k - 1 Dk(0) = -Sk(1) do k = 1 , Nm Dk(k) = -Sk(k-1) - (k+1.0_wp)/x*Sk(k) enddo end !***************************************************************************************** !> ! Compute exponential integral En(x) subroutine enxa(n,x,En) ! Input : x --- Argument of En(x) ( x ≤ 20 ) ! n --- Order of En(x) ! Output: EN(n) --- En(x) real(wp) e1 , ek , En , x integer k , n dimension En(0:n) En(0) = exp(-x)/x call e1xb(x,e1) En(1) = e1 do k = 2 , n ek = (exp(-x)-x*e1)/(k-1.0_wp) En(k) = ek e1 = ek enddo end !***************************************************************************************** !> ! Compute gamma function Г(x) subroutine gaih(x,Ga) ! Input : x --- Argument of Г(x), x = n/2, n=1,2,… ! Output: GA --- Г(x) real(wp) Ga , x integer k , m , m1 if ( x==int(x) .and. x>0.0_wp ) then Ga = 1.0_wp m1 = int(x-1.0_wp) do k = 2 , m1 Ga = Ga*k enddo elseif ( x+.5_wp==int(x+0.5_wp) .and. x>0.0_wp ) then m = int(x) Ga = sqrtpi do k = 1 , m Ga = 0.5_wp*Ga*(2.0_wp*k-1.0_wp) enddo endif end !***************************************************************************************** !> ! Compute parabolic cylinder functions Vv(x) ! and their derivatives subroutine pbvv(v,x,Vv,Vp,Pvf,Pvd) ! Input: x --- Argument of Vv(x) ! v --- Order of Vv(x) ! Output: VV(na) --- Vv(x) ! VP(na) --- Vv'(x) ! ( na = |n|, v = n+v0, |v0| < 1 ! n = 0,±1,±2,… ) ! PVF --- Vv(x) ! PVD --- Vv'(x) real(wp) f , f0 , f1 , pv0 , Pvd , Pvf , q2p , qe , & & s0 , v , v0 , v1 , v2 , vh , Vp , Vv , x , xa integer ja , k , kv , l , m , na , nv dimension Vv(0:*) , Vp(0:*) xa = abs(x) vh = v v = v + sign(1.0_wp,v) nv = int(v) v0 = v - nv na = abs(nv) qe = exp(0.25_wp*x*x) q2p = sqrt(2.0_wp/pi) ja = 0 if ( na>=1 ) ja = 1 f = 0.0_wp if ( v<=0.0_wp ) then if ( v0==0.0_wp ) then if ( xa<=7.5 ) call vvsa(v0,x,pv0) if ( xa>7.5 ) call vvla(v0,x,pv0) f0 = q2p*qe f1 = x*f0 Vv(0) = pv0 Vv(1) = f0 Vv(2) = f1 else do l = 0 , ja v1 = v0 - l if ( xa<=7.5 ) call vvsa(v1,x,f1) if ( xa>7.5 ) call vvla(v1,x,f1) if ( l==0 ) f0 = f1 enddo Vv(0) = f0 Vv(1) = f1 endif kv = 2 if ( v0==0.0_wp ) kv = 3 do k = kv , na f = x*f1 + (k-v0-2.0_wp)*f0 Vv(k) = f f0 = f1 f1 = f enddo elseif ( x>=0.0 .and. x<=7.5_wp ) then v2 = v if ( v2<1.0_wp ) v2 = v2 + 1.0_wp call vvsa(v2,x,f1) v1 = v2 - 1.0_wp kv = int(v2) call vvsa(v1,x,f0) Vv(kv) = f1 Vv(kv-1) = f0 do k = kv - 2 , 0 , -1 f = x*f0 - (k+v0+2.0_wp)*f1 if ( k<=na ) Vv(k) = f f1 = f0 f0 = f enddo elseif ( x>7.5_wp ) then call vvla(v0,x,pv0) m = 100 + abs(na) Vv(1) = pv0 f1 = 0.0_wp f0 = 1.0d-40 do k = m , 0 , -1 f = x*f0 - (k+v0+2.0_wp)*f1 if ( k<=na ) Vv(k) = f f1 = f0 f0 = f enddo s0 = pv0/f do k = 0 , na Vv(k) = s0*Vv(k) enddo else if ( xa<=7.5_wp ) then call vvsa(v0,x,f0) v1 = v0 + 1.0 call vvsa(v1,x,f1) else call vvla(v0,x,f0) v1 = v0 + 1.0_wp call vvla(v1,x,f1) endif Vv(0) = f0 Vv(1) = f1 do k = 2 , na f = (x*f1-f0)/(k+v0) Vv(k) = f f0 = f1 f1 = f enddo endif do k = 0 , na - 1 v1 = v0 + k if ( v>=0.0_wp ) then Vp(k) = 0.5_wp*x*Vv(k) - (v1+1.0_wp)*Vv(k+1) else Vp(k) = -0.5_wp*x*Vv(k) + Vv(k+1) endif enddo Pvf = Vv(na-1) Pvd = Vp(na-1) v = vh end !***************************************************************************************** !> ! Compute the associated Legendre functions of ! the second kind, Qmn(z) and Qmn'(z), for a ! complex argument subroutine clqmn(Mm,m,n,x,y,Cqm,Cqd) ! Input : x --- Real part of z ! y --- Imaginary part of z ! m --- Order of Qmn(z) ( m = 0,1,2,… ) ! n --- Degree of Qmn(z) ( n = 0,1,2,… ) ! mm --- Physical dimension of CQM and CQD ! Output: CQM(m,n) --- Qmn(z) ! CQD(m,n) --- Qmn'(z) complex(wp) cq0 , cq1 , cq10 , Cqd , cqf , cqf0 , cqf1 , cqf2 , & & Cqm , z , zq , zs integer i , j , k , km , ls , m , Mm , n real(wp) x , xc , y dimension Cqm(0:Mm,0:n) , Cqd(0:Mm,0:n) z = cmplx(x,y,kind=wp) if ( abs(x)==1.0_wp .and. y==0.0_wp ) then do i = 0 , m do j = 0 , n Cqm(i,j) = (1.0e+300_wp,0.0_wp) Cqd(i,j) = (1.0e+300_wp,0.0_wp) enddo enddo return endif xc = abs(z) ls = 0 if ( aimag(z)==0.0_wp .or. xc<1.0_wp ) ls = 1 if ( xc>1.0_wp ) ls = -1 zq = sqrt(ls*(1.0_wp-z*z)) zs = ls*(1.0_wp-z*z) cq0 = 0.5_wp*log(ls*(1.0_wp+z)/(1.0_wp-z)) if ( xc<1.0001_wp ) then Cqm(0,0) = cq0 Cqm(0,1) = z*cq0 - 1.0_wp Cqm(1,0) = -1.0_wp/zq Cqm(1,1) = -zq*(cq0+z/(1.0_wp-z*z)) do i = 0 , 1 do j = 2 , n Cqm(i,j) = ((2.0_wp*j-1.0_wp)*z*Cqm(i,j-1)-(j+i-1.0_wp) & & *Cqm(i,j-2))/(j-i) enddo enddo do j = 0 , n do i = 2 , m Cqm(i,j) = -2.0_wp*(i-1.0_wp)*z/zq*Cqm(i-1,j) & & - ls*(j+i-1.0_wp)*(j-i+2.0_wp)*Cqm(i-2,j) enddo enddo else if ( xc>1.1 ) then km = 40 + m + n else km = (40+m+n)*int(-1.0-1.8*log(xc-1.0_wp)) endif cqf2 = (0.0_wp,0.0_wp) cqf1 = (1.0_wp,0.0_wp) do k = km , 0 , -1 cqf0 = ((2*k+3.0_wp)*z*cqf1-(k+2.0_wp)*cqf2)/(k+1.0_wp) if ( k<=n ) Cqm(0,k) = cqf0 cqf2 = cqf1 cqf1 = cqf0 enddo do k = 0 , n Cqm(0,k) = cq0*Cqm(0,k)/cqf0 enddo cqf2 = 0.0_wp cqf1 = 1.0_wp do k = km , 0 , -1 cqf0 = ((2*k+3.0_wp)*z*cqf1-(k+1.0_wp)*cqf2)/(k+2.0_wp) if ( k<=n ) Cqm(1,k) = cqf0 cqf2 = cqf1 cqf1 = cqf0 enddo cq10 = -1.0_wp/zq do k = 0 , n Cqm(1,k) = cq10*Cqm(1,k)/cqf0 enddo do j = 0 , n cq0 = Cqm(0,j) cq1 = Cqm(1,j) do i = 0 , m - 2 cqf = -2.0_wp*(i+1)*z/zq*cq1 + (j-i)*(j+i+1.0_wp)*cq0 Cqm(i+2,j) = cqf cq0 = cq1 cq1 = cqf enddo enddo endif Cqd(0,0) = ls/zs do j = 1 , n Cqd(0,j) = ls*j*(Cqm(0,j-1)-z*Cqm(0,j))/zs enddo do j = 0 , n do i = 1 , m Cqd(i,j) = ls*i*z/zs*Cqm(i,j) + (i+j)*(j-i+1.0_wp) & & /zq*Cqm(i-1,j) enddo enddo end !***************************************************************************************** !> ! Compute the characteristic values of spheroidal ! wave functions subroutine segv(m,n,c,Kd,Cv,Eg) ! Input : m --- Mode parameter ! n --- Mode parameter ! c --- Spheroidal parameter ! KD --- Function code ! KD=1 for Prolate; KD=-1 for Oblate ! Output: CV --- Characteristic value for given m, n and c ! EG(L) --- Characteristic value for mode m and n' ! ( L = n' - m + 1 ) real(wp) a , b , c , cs , Cv , cv0 , d , d2k , dk0 , dk1 ,& & dk2 , e , Eg , f , g , h , s , t , t1 , x1 real(wp) xa , xb integer i , icm , j , k , k1 , Kd , l , m , n , nm , nm1 dimension b(100) , h(100) , d(300) , e(300) , f(300) , cv0(100) , & & a(300) , g(300) , Eg(200) if ( c<1.0d-10 ) then do i = 1 , n - m + 1 Eg(i) = (i+m)*(i+m-1.0_wp) enddo goto 100 endif icm = (n-m+2)/2 nm = 10 + int(0.5*(n-m)+c) cs = c*c*Kd k = 0 do l = 0 , 1 do i = 1 , nm if ( l==0 ) k = 2*(i-1) if ( l==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_wp)*(d2k+1.0_wp)/((dk2+3.0_wp)*(dk2+5.0_wp))*cs d(i) = dk0*dk1 + (2.0_wp*dk0*dk1-2.0_wp*m*m-1.0_wp) & & /((dk2-1.0_wp)*(dk2+3.0_wp))*cs g(i) = k*(k-1.0_wp)/((dk2-3.0_wp)*(dk2-1.0_wp))*cs enddo do k = 2 , nm e(k) = sqrt(a(k-1)*g(k)) f(k) = e(k)*e(k) enddo f(1) = 0.0_wp e(1) = 0.0_wp xa = d(nm) + abs(e(nm)) xb = d(nm) - abs(e(nm)) nm1 = nm - 1 do i = 1 , nm1 t = abs(e(i)) + abs(e(i+1)) t1 = d(i) + t if ( xa<t1 ) xa = t1 t1 = d(i) - t if ( t1<xb ) xb = t1 enddo do i = 1 , icm b(i) = xa h(i) = xb enddo do k = 1 , icm do k1 = k , icm if ( b(k1)<b(k) ) then b(k) = b(k1) exit endif enddo if ( k/=1 ) then if ( h(k)<h(k-1) ) h(k) = h(k-1) endif 40 x1 = (b(k)+h(k))/2.0_wp cv0(k) = x1 if ( abs((b(k)-h(k))/x1)<1.0d-14 ) then cv0(k) = x1 if ( l==0 ) Eg(2*k-1) = cv0(k) if ( l==1 ) Eg(2*k) = cv0(k) else j = 0 s = 1.0_wp do i = 1 , nm if ( s==0.0_wp ) s = s + 1.0d-30 t = f(i)/s s = d(i) - t - x1 if ( s<0.0_wp ) j = j + 1 enddo if ( j<k ) then h(k) = x1 else b(k) = x1 if ( j>=icm ) then b(icm) = x1 else if ( h(j+1)<x1 ) h(j+1) = x1 if ( x1<b(j) ) b(j) = x1 endif endif goto 40 endif enddo enddo 100 Cv = Eg(n-m+1) end !***************************************************************************************** !> ! Compute modified Bessel functions In(z) and Kn(z), ! and their derivatives for a complex argument subroutine ciknb(n,z,Nm,Cbi,Cdi,Cbk,Cdk) ! Input: z --- Complex argument ! n --- Order of In(z) and Kn(z) ! Output: CBI(n) --- In(z) ! CDI(n) --- In'(z) ! CBK(n) --- Kn(z) ! CDK(n) --- Kn'(z) ! NM --- Highest order computed real(wp) a0 , fac , vt complex(wp) ca0 , Cbi , Cbk , cbkl , cbs , Cdi , Cdk , cf , cf0 , & & cf1 , cg , cg0 , cg1 , ci , cr , cs0 , csk0 , z , z1 integer k , k0 , l , m , n , Nm dimension Cbi(0:n) , Cdi(0:n) , Cbk(0:n) , Cdk(0:n) a0 = abs(z) Nm = n if ( a0<1.0e-100_wp ) then do k = 0 , n Cbi(k) = (0.0_wp,0.0_wp) Cbk(k) = (1.0e+300_wp,0.0_wp) Cdi(k) = (0.0_wp,0.0_wp) Cdk(k) = -(1.0e+300_wp,0.0_wp) enddo Cbi(0) = (1.0_wp,0.0_wp) Cdi(1) = (0.5_wp,0.0_wp) return endif z1 = z ci = (0.0_wp,1.0_wp) if ( real(z,wp)<0.0_wp ) z1 = -z if ( n==0 ) Nm = 1 m = msta1(a0,200) if ( m<Nm ) then Nm = m else m = msta2(a0,Nm,15) endif cbs = 0.0_wp csk0 = 0.0_wp cf0 = 0.0_wp cf1 = 1.0e-100_wp do k = m , 0 , -1 cf = 2.0_wp*(k+1.0_wp)*cf1/z1 + cf0 if ( k<=Nm ) Cbi(k) = cf if ( k/=0 .and. k==2*int(k/2) ) csk0 = csk0 + 4.0_wp*cf/k cbs = cbs + 2.0_wp*cf cf0 = cf1 cf1 = cf enddo cs0 = exp(z1)/(cbs-cf) do k = 0 , Nm Cbi(k) = cs0*Cbi(k) enddo if ( a0<=9.0_wp ) then Cbk(0) = -(log(0.5_wp*z1)+gamma)*Cbi(0) + cs0*csk0 Cbk(1) = (1.0_wp/z1-Cbi(1)*Cbk(0))/Cbi(0) else ca0 = sqrt(pi/(2.0_wp*z1))*exp(-z1) k0 = 16 if ( a0>=25.0_wp ) k0 = 10 if ( a0>=80.0_wp ) k0 = 8 if ( a0>=200.0_wp ) k0 = 6 do l = 0 , 1 cbkl = 1.0_wp vt = 4.0_wp*l cr = (1.0_wp,0.0_wp) do k = 1 , k0 cr = 0.125_wp*cr*(vt-(2.0_wp*k-1.0_wp)**2)/(k*z1) cbkl = cbkl + cr enddo Cbk(l) = ca0*cbkl enddo endif cg0 = Cbk(0) cg1 = Cbk(1) do k = 2 , Nm cg = 2.0_wp*(k-1.0_wp)/z1*cg1 + cg0 Cbk(k) = cg cg0 = cg1 cg1 = cg enddo if ( real(z,wp)<0.0_wp ) then fac = 1.0_wp do k = 0 , Nm if ( aimag(z)<0.0_wp ) 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 enddo endif Cdi(0) = Cbi(1) Cdk(0) = -Cbk(1) do k = 1 , Nm Cdi(k) = Cbi(k-1) - k/z*Cbi(k) Cdk(k) = -Cbk(k-1) - k/z*Cbk(k) enddo end !***************************************************************************************** !> ! Compute modified Bessel functions In(z), Kn(x) ! and their derivatives for a complex argument subroutine cikna(n,z,Nm,Cbi,Cdi,Cbk,Cdk) ! Input : z --- Complex argument of In(z) and Kn(z) ! n --- Order of In(z) and Kn(z) ! Output: CBI(n) --- In(z) ! CDI(n) --- In'(z) ! CBK(n) --- Kn(z) ! CDK(n) --- Kn'(z) ! NM --- Highest order computed real(wp) a0 complex(wp) Cbi , cbi0 , cbi1 , Cbk , cbk0 , cbk1 , Cdi , cdi0 , & & cdi1 , Cdk , cdk0 , cdk1 , cf , cf1 , cf2 , ckk , cs , & & z integer k , m , n , Nm dimension Cbi(0:n) , Cdi(0:n) , Cbk(0:n) , Cdk(0:n) a0 = abs(z) Nm = n if ( a0<1.0e-100_wp ) then do k = 0 , n Cbi(k) = (0.0_wp,0.0_wp) Cdi(k) = (0.0_wp,0.0_wp) Cbk(k) = -(1.0e+300_wp,0.0_wp) Cdk(k) = (1.0e+300_wp,0.0_wp) enddo Cbi(0) = (1.0_wp,0.0_wp) Cdi(1) = (0.5_wp,0.0_wp) 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<=1 ) return m = msta1(a0,200) if ( m<n ) then Nm = m else m = msta2(a0,n,15) endif cf2 = (0.0_wp,0.0_wp) cf1 = (1.0e-100_wp,0.0_wp) do k = m , 0 , -1 cf = 2.0_wp*(k+1.0_wp)/z*cf1 + cf2 if ( k<=Nm ) Cbi(k) = cf cf2 = cf1 cf1 = cf enddo cs = cbi0/cf do k = 0 , Nm Cbi(k) = cs*Cbi(k) enddo do k = 2 , Nm if ( abs(Cbi(k-1))>abs(Cbi(k-2)) ) then ckk = (1.0_wp/z-Cbi(k)*Cbk(k-1))/Cbi(k-1) else ckk = (Cbi(k)*Cbk(k-2)+2.0_wp*(k-1.0_wp)/(z*z))/Cbi(k-2) endif Cbk(k) = ckk enddo do k = 2 , Nm Cdi(k) = Cbi(k-1) - k/z*Cbi(k) Cdk(k) = -Cbk(k-1) - k/z*Cbk(k) enddo end !***************************************************************************************** !> ! Compute modified Mathieu functions of the first and ! second kinds, Mcm(1)(2)(x,q) and Msm(1)(2)(x,q), ! and their derivatives subroutine mtu12(Kf,Kc,m,q,x,F1r,D1r,F2r,D2r) ! Input: KF --- Function code ! KF=1 for computing Mcm(x,q) ! KF=2 for computing Msm(x,q) ! KC --- Function Code ! KC=1 for computing the first kind ! KC=2 for computing the second kind ! or Msm(2)(x,q) and Msm(2)'(x,q) ! KC=3 for computing both the first ! and second kinds ! m --- Order of Mathieu functions ! q --- Parameter of Mathieu functions ( q ≥ 0 ) ! x --- Argument of Mathieu functions ! Output: F1R --- Mcm(1)(x,q) or Msm(1)(x,q) ! D1R --- Derivative of Mcm(1)(x,q) or Msm(1)(x,q) ! F2R --- Mcm(2)(x,q) or Msm(2)(x,q) ! D2R --- Derivative of Mcm(2)(x,q) or Msm(2)(x,q) real(wp) a , bj1 , bj2 , by1 , by2 , c1 , c2 , D1r , D2r ,& & dj1 , dj2 , dy1 , dy2 , F1r , F2r , & & fg , q , qm real(wp) u1 , u2 , w1 , w2 , x integer ic , k , Kc , kd , Kf , km , m , nm 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) real(wp),parameter :: eps = 1.0e-14_wp if ( Kf==1 .and. m==2*int(m/2) ) kd = 1 if ( Kf==1 .and. m/=2*int(m/2) ) kd = 2 if ( Kf==2 .and. m/=2*int(m/2) ) kd = 3 if ( Kf==2 .and. m==2*int(m/2) ) kd = 4 call cva2(kd,m,q,a) if ( q<=1.0_wp ) 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>=251 ) then F1r = dnan() D1r = dnan() F2r = dnan() D2r = dnan() return endif call fcoef(kd,m,q,a,fg) ic = int(m/2) + 1 if ( kd==4 ) ic = m/2 c1 = exp(-x) c2 = exp(x) u1 = sqrt(q)*c1 u2 = sqrt(q)*c2 call jynb(km+1,u1,nm,bj1,dj1,by1,dy1) call jynb(km+1,u2,nm,bj2,dj2,by2,dy2) w1 = 0.0_wp w2 = 0.0_wp if ( Kc/=2 ) then F1r = 0.0_wp do k = 1 , km if ( kd==1 ) then F1r = F1r + (-1)**(ic+k)*fg(k)*bj1(k-1)*bj2(k-1) elseif ( kd==2 .or. kd==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>=5 .and. abs(F1r-w1)<abs(F1r)*eps ) exit w1 = F1r enddo F1r = F1r/fg(1) D1r = 0.0_wp do k = 1 , km if ( kd==1 ) then D1r = D1r + (-1)**(ic+k)*fg(k) & & *(c2*bj1(k-1)*dj2(k-1)-c1*dj1(k-1)*bj2(k-1)) elseif ( kd==2 .or. kd==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>=5 .and. abs(D1r-w2)<abs(D1r)*eps ) exit w2 = D1r enddo D1r = D1r*sqrt(q)/fg(1) if ( Kc==1 ) return endif F2r = 0.0_wp do k = 1 , km if ( kd==1 ) then F2r = F2r + (-1)**(ic+k)*fg(k)*bj1(k-1)*by2(k-1) elseif ( kd==2 .or. kd==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>=5 .and. abs(F2r-w1)<abs(F2r)*eps ) exit w1 = F2r enddo F2r = F2r/fg(1) D2r = 0.0_wp do k = 1 , km if ( kd==1 ) then D2r = D2r + (-1)**(ic+k)*fg(k) & & *(c2*bj1(k-1)*dy2(k-1)-c1*dj1(k-1)*by2(k-1)) elseif ( kd==2 .or. kd==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>=5 .and. abs(D2r-w2)<abs(D2r)*eps ) exit w2 = D2r enddo D2r = D2r*sqrt(q)/fg(1) end !***************************************************************************************** !> ! Compute modified Bessel functions I0(z), I1(z), ! K0(z), K1(z), and their derivatives for a ! complex argument subroutine cik01(z,Cbi0,Cdi0,Cbi1,Cdi1,Cbk0,Cdk0,Cbk1,Cdk1) ! Input : z --- Complex argument ! Output: CBI0 --- I0(z) ! CDI0 --- I0'(z) ! CBI1 --- I1(z) ! CDI1 --- I1'(z) ! CBK0 --- K0(z) ! CDK0 --- K0'(z) ! CBK1 --- K1(z) ! CDK1 --- K1'(z) real(wp) a , a0 , a1 , b , w0 complex(wp) ca , cb , Cbi0 , Cbi1 , Cbk0 , Cbk1 , Cdi0 , Cdi1 , & & Cdk0 , Cdk1 , ci , cr , cs , ct , cw , z , z1 , z2 , & & zr , zr2 integer k , k0 dimension a(12) , b(12) , a1(10) ci = (0.0_wp,1.0_wp) a0 = abs(z) z2 = z*z z1 = z if ( a0==0.0_wp ) then Cbi0 = (1.0_wp,0.0_wp) Cbi1 = (0.0_wp,0.0_wp) Cdi0 = (0.0_wp,0.0_wp) Cdi1 = (0.5_wp,0.0_wp) Cbk0 = (1.0e+300_wp,0.0_wp) Cbk1 = (1.0e+300_wp,0.0_wp) Cdk0 = -(1.0e+300_wp,0.0_wp) Cdk1 = -(1.0e+300_wp,0.0_wp) return endif if ( real(z,wp)<0.0_wp ) z1 = -z if ( a0<=18.0_wp ) then Cbi0 = (1.0_wp,0.0_wp) cr = (1.0_wp,0.0_wp) do k = 1 , 50 cr = 0.25_wp*cr*z2/(k*k) Cbi0 = Cbi0 + cr if ( abs(cr/Cbi0)<1.0e-15_wp ) exit enddo Cbi1 = (1.0_wp,0.0_wp) cr = (1.0_wp,0.0_wp) do k = 1 , 50 cr = 0.25_wp*cr*z2/(k*(k+1)) Cbi1 = Cbi1 + cr if ( abs(cr/Cbi1)<1.0e-15_wp ) exit enddo Cbi1 = 0.5_wp*z1*Cbi1 else data a/0.125_wp , 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>=35.0_wp ) k0 = 9 if ( a0>=50.0_wp ) k0 = 7 ca = exp(z1)/sqrt(twopi*z1) Cbi0 = (1.0_wp,0.0_wp) zr = 1.0_wp/z1 do k = 1 , k0 Cbi0 = Cbi0 + a(k)*zr**k enddo Cbi0 = ca*Cbi0 Cbi1 = (1.0_wp,0.0_wp) do k = 1 , k0 Cbi1 = Cbi1 + b(k)*zr**k enddo Cbi1 = ca*Cbi1 endif if ( a0<=9.0_wp ) then cs = (0.0_wp,0.0_wp) ct = -log(0.5_wp*z1) - gamma w0 = 0.0_wp cr = (1.0_wp,0.0_wp) do k = 1 , 50 w0 = w0 + 1.0_wp/k cr = 0.25_wp*cr/(k*k)*z2 cs = cs + cr*(w0+ct) if ( abs((cs-cw)/cs)<1.0e-15_wp ) exit cw = cs enddo Cbk0 = ct + cs else data a1/0.125_wp , 0.2109375d0 , 1.0986328125d0 , & & 1.1775970458984d01 , 2.1461706161499d02 , & & 5.9511522710323d03 , 2.3347645606175d05 , & & 1.2312234987631d07 , 8.401390346421d08 , & & 7.2031420482627d10/ cb = 0.5_wp/z1 zr2 = 1.0_wp/z2 Cbk0 = (1.0_wp,0.0_wp) do k = 1 , 10 Cbk0 = Cbk0 + a1(k)*zr2**k enddo Cbk0 = cb*Cbk0/Cbi0 endif Cbk1 = (1.0_wp/z1-Cbi1*Cbk0)/Cbi0 if ( real(z,wp)<0.0_wp ) then if ( aimag(z)<0.0_wp ) Cbk0 = Cbk0 + ci*pi*Cbi0 if ( aimag(z)>0.0_wp ) Cbk0 = Cbk0 - ci*pi*Cbi0 if ( aimag(z)<0.0_wp ) Cbk1 = -Cbk1 + ci*pi*Cbi1 if ( aimag(z)>0.0_wp ) Cbk1 = -Cbk1 - ci*pi*Cbi1 Cbi1 = -Cbi1 endif Cdi0 = Cbi1 Cdi1 = Cbi0 - 1.0_wp/z*Cbi1 Cdk0 = -Cbk1 Cdk1 = -Cbk0 - 1.0_wp/z*Cbk1 end !***************************************************************************************** !> ! Compute the psi function for a complex argument subroutine cpsi(x,y,Psr,Psi) ! Input : x --- Real part of z ! y --- Imaginary part of z ! Output: PSR --- Real part of psi(z) ! PSI --- Imaginary part of psi(z) real(wp) a , ct2 , Psi , Psr , ri , rr , th , tm , & & tn , x , x0 , x1 , y , y1 , z0 , z2 integer k , n dimension a(8) data a/ - .8333333333333d-01 , .83333333333333333d-02 , & & -.39682539682539683d-02 , .41666666666666667d-02 , & & -.75757575757575758d-02 , .21092796092796093d-01 , & & -.83333333333333333d-01 , .4432598039215686d0/ if ( y==0.0_wp .and. x==int(x) .and. x<=0.0_wp ) then Psr = 1.0e+300_wp Psi = 0.0_wp else x1 = x y1 = y if ( x<0.0_wp ) then x = -x y = -y endif x0 = x n = 0 if ( x<8.0_wp ) then n = 8 - int(x) x0 = x + n endif th = 0.0_wp if ( x0==0.0_wp .and. y/=0.0_wp ) th = halfpi if ( x0/=0.0_wp ) th = atan(y/x0) z2 = x0*x0 + y*y z0 = sqrt(z2) Psr = log(z0) - 0.5_wp*x0/z2 Psi = th + 0.5_wp*y/z2 do k = 1 , 8 Psr = Psr + a(k)*z2**(-k)*cos(2.0_wp*k*th) Psi = Psi - a(k)*z2**(-k)*sin(2.0_wp*k*th) enddo if ( x<8.0_wp ) then rr = 0.0_wp ri = 0.0_wp do k = 1 , n rr = rr + (x0-k)/((x0-k)**2.0_wp+y*y) ri = ri + y/((x0-k)**2.0_wp+y*y) enddo Psr = Psr - rr Psi = Psi + ri endif if ( x1<0.0_wp ) then tn = tan(pi*x) tm = tanh(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.0_wp+tn*tn)/ct2 x = x1 y = y1 endif endif end !***************************************************************************************** !> ! Compute spherical Bessel functions yn(x) and ! their derivatives subroutine sphy(n,x,Nm,Sy,Dy) ! Input : x --- Argument of yn(x) ( x ≥ 0 ) ! n --- Order of yn(x) ( n = 0,1,… ) ! Output: SY(n) --- yn(x) ! DY(n) --- yn'(x) ! NM --- Highest order computed real(wp) Dy , f , f0 , f1 , Sy , x integer k , n , Nm dimension Sy(0:n) , Dy(0:n) Nm = n if ( x<1.0d-60 ) then do k = 0 , n Sy(k) = -1.0e+300_wp Dy(k) = 1.0e+300_wp enddo return endif Sy(0) = -cos(x)/x f0 = Sy(0) Dy(0) = (sin(x)+cos(x)/x)/x if ( n<1 ) return Sy(1) = (Sy(0)-sin(x))/x f1 = Sy(1) do k = 2 , n f = (2.0_wp*k-1.0_wp)*f1/x - f0 Sy(k) = f if ( abs(f)>=1.0e+300_wp ) exit f0 = f1 f1 = f enddo Nm = k - 1 do k = 1 , Nm Dy(k) = Sy(k-1) - (k+1.0_wp)*Sy(k)/x enddo end !***************************************************************************************** !> ! Compute Jacobian elliptic functions sn u, cn u ! and dn u subroutine jelp(u,Hk,Esn,Ecn,Edn,Eph) ! Input : u --- Argument of Jacobian elliptic functions ! Hk --- Modulus k ( 0 ≤ k ≤ 1 ) ! Output : ESN --- sn u ! ECN --- cn u ! EDN --- dn u ! EPH --- phi ( in degrees ) real(wp) a , a0 , b , b0 , c , d , dn , Ecn , Edn , Eph , & & Esn , Hk , r , sa , t , u integer j , n dimension r(40) a0 = 1.0_wp b0 = sqrt(1.0_wp-Hk*Hk) do n = 1 , 40 a = (a0+b0)/2.0_wp b = sqrt(a0*b0) c = (a0-b0)/2.0_wp r(n) = c/a if ( c<1.0d-7 ) exit a0 = a b0 = b enddo dn = 2.0_wp**n*a*u d = 0.0_wp do j = n , 1 , -1 t = r(j)*sin(dn) sa = atan(t/sqrt(abs(1.0_wp-t*t))) d = 0.5_wp*(dn+sa) dn = d enddo Eph = d*180.0d0/pi Esn = sin(d) Ecn = cos(d) Edn = sqrt(1.0_wp-Hk*Hk*Esn*Esn) end end module specfun_module