[Fortran] 纯文本查看 复制代码
SUBROUTINE cbdb(cz,cnu,fn,w)
!-----------------------------------------------------------------------
! CALCULATION OF J (CZ) BY THE DEBYE APPROXIMATION
! CNU
! ------------------
! IT IS ASSUMED THAT REAL(CZ) .GE. 0 AND THAT REAL(CNU) = FN + K
! WHERE K IS AN INTEGER.
!-----------------------------------------------------------------------
COMPLEX (dp), INTENT(IN) :: cz, cnu
REAL (dp), INTENT(IN) :: fn
COMPLEX (dp), INTENT(OUT) :: w
! Local variables
REAL (dp) :: is, inu, izn
COMPLEX (dp) :: c1, c2, eta, nu, p, p1, q, r, s, s1, s2, sm, t, z, zn
!----------------------
! C = 1/SQRT(2*PI)
! BND = PI/3
!----------------------
REAL (dp), PARAMETER :: c = .398942280401433_dp, pi = 3.14159265358979_dp, &
pi2 = 6.28318530717959_dp, bnd = 1.04719755119660_dp
COMPLEX (dp), PARAMETER :: j = (0.0, 1.0)
REAL (dp) :: alpha, am, aq, ar
REAL (dp) :: phi, sgn, theta
REAL (dp) :: u, v, x, y
INTEGER :: ind, k, l, m
!----------------------
! COEFFICIENTS OF THE FIRST 16 POLYNOMIALS
! IN THE DEBYE APPROXIMATION
!----------------------
REAL (dp) :: a(136) = (/ 1.0_dp, -.208333333333333_dp, .125000000000000_dp, .334201388888889_dp, &
-.401041666666667_dp, .703125000000000D-01,-.102581259645062D+01, .184646267361111D+01, &
-.891210937500000_dp, .732421875000000D-01, .466958442342625D+01,-.112070026162230D+02, &
.878912353515625D+01,-.236408691406250D+01, .112152099609375_dp,-.282120725582002D+02, &
.846362176746007D+02,-.918182415432400D+02, .425349987453885D+02,-.736879435947963D+01, &
.227108001708984_dp, .212570130039217D+03,-.765252468141182D+03, .105999045252800D+04, &
-.699579627376133D+03, .218190511744212D+03,-.264914304869516D+02, .572501420974731_dp, &
-.191945766231841D+04, .806172218173731D+04,-.135865500064341D+05, .116553933368645D+05, &
-.530564697861340D+04, .120090291321635D+04,-.108090919788395D+03, .172772750258446D+01, &
.202042913309661D+05,-.969805983886375D+05, .192547001232532D+06,-.203400177280416D+06, &
.122200464983017D+06,-.411926549688976D+05, .710951430248936D+04,-.493915304773088D+03, &
.607404200127348D+01,-.242919187900551D+06, .131176361466298D+07,-.299801591853811D+07, &
.376327129765640D+07,-.281356322658653D+07, .126836527332162D+07,-.331645172484564D+06, &
.452187689813627D+05,-.249983048181121D+04, .243805296995561D+02, .328446985307204D+07, &
-.197068191184322D+08, .509526024926646D+08,-.741051482115327D+08, .663445122747290D+08, &
-.375671766607634D+08, .132887671664218D+08,-.278561812808645D+07, .308186404612662D+06, &
-.138860897537170D+05, .110017140269247D+03,-.493292536645100D+08, .325573074185766D+09, &
-.939462359681578D+09, .155359689957058D+10,-.162108055210834D+10, .110684281682301D+10, &
-.495889784275030D+09, .142062907797533D+09,-.244740627257387D+08, .224376817792245D+07, &
-.840054336030241D+05, .551335896122021D+03, .814789096118312D+09,-.586648149205185D+10, &
.186882075092958D+11,-.346320433881588D+11, .412801855797540D+11,-.330265997498007D+11, &
.179542137311556D+11,-.656329379261928D+10, .155927986487926D+10,-.225105661889415D+09, &
.173951075539782D+08,-.549842327572289D+06, .303809051092238D+04,-.146792612476956D+11, &
.114498237732026D+12,-.399096175224466D+12, .819218669548577D+12,-.109837515608122D+13, &
.100815810686538D+13,-.645364869245377D+12, .287900649906151D+12,-.878670721780233D+11, &
.176347306068350D+11,-.216716498322380D+10, .143157876718889D+09,-.387183344257261D+07, &
.182577554742932D+05, .286464035717679D+12,-.240629790002850D+13, .910934118523990D+13, &
-.205168994109344D+14, .305651255199353D+14,-.316670885847852D+14, .233483640445818D+14, &
-.123204913055983D+14, .461272578084913D+13,-.119655288019618D+13, .205914503232410D+12, &
-.218229277575292D+11, .124700929351271D+10,-.291883881222208D+08, .118838426256783D+06, &
-.601972341723401D+13, .541775107551060D+14,-.221349638702525D+15, .542739664987660D+15, &
-.889496939881026D+15, .102695519608276D+16,-.857461032982895D+15, .523054882578445D+15, &
-.232604831188940D+15, .743731229086791D+14,-.166348247248925D+14, .248500092803409D+13, &
-.229619372968246D+12, .114657548994482D+11,-.234557963522252D+09, .832859304016289D+06 /)
z = cz
nu = cnu
inu = AIMAG(cnu)
IF (inu < 0.0D0) THEN
z = CONJG(z)
nu = CONJG(nu)
END IF
x = REAL(z, KIND=dp)
y = AIMAG(z)
! TANH(GAMMA) = SQRT(1 - (Z/NU)**2) = W/NU
! T = EXP(NU*(TANH(GAMMA) - GAMMA))
zn = z / nu
izn = AIMAG(zn)
IF (ABS(izn) <= 0.1D0*ABS(REAL(zn, KIND=dp))) THEN
s = (1.0D0-zn) * (1.0D0+zn)
eta = 1.0D0 / s
q = SQRT(s)
s = 1.0D0 / (nu*q)
t = zn / (1.0D0 + q)
t = EXP(nu*(q + LOG(t)))
ELSE
s = (nu-z) * (nu+z)
eta = (nu*nu) / s
w = SQRT(s)
q = w / nu
IF (REAL(q, KIND=dp) < 0.0D0) w = -w
s = 1.0D0 / w
t = z / (nu+w)
t = EXP(w + nu*LOG(t))
END IF
is = AIMAG(s)
r = SQRT(s)
c1 = r * t
ar = REAL(r, KIND=dp) * REAL(r, KIND=dp) + AIMAG(r) * AIMAG(r)
aq = -1.0D0 / (REAL(q, KIND=dp)*REAL(q, KIND=dp) + AIMAG(q)*AIMAG(q))
phi = ATAN2(y,x) / 3.0D0
q = nu - z
theta = ATAN2(AIMAG(q),REAL(q, KIND=dp)) - phi
ind = 0
IF (ABS(theta) >= 2.0D0*bnd) THEN
ind = 1
CALL dcrec(REAL(t, KIND=dp), AIMAG(t),u,v)
c2 = -j * r * CMPLX(u,v, KIND=dp)
IF (is >= 0.0D0) THEN
IF (is > 0.0D0) GO TO 10
IF (REAL(s, KIND=dp) <= 0.0D0) GO TO 10
END IF
c2 = -c2
END IF
! SUMMATION OF THE SERIES S1 AND S2
10 sm = s * s
p = (a(2)*eta + a(3)) * s
p1 = ((a(4)*eta + a(5))*eta + a(6)) * sm
s1 = (1.0D0 + p) + p1
IF (ind /= 0) s2 = (1.0D0-p) + p1
sgn = 1.0D0
am = ar * ar
m = 4
l = 6
! P = VALUE OF THE M-TH POLYNOMIAL
20 l = l + 1
alpha = a(l)
p = CMPLX(a(l),0.0D0, KIND=dp)
DO k = 2, m
l = l + 1
alpha = a(l) + aq * alpha
p = a(l) + eta * p
END DO
! ONLY THE S1 SUM IS FORMED WHEN IND = 0
sm = s * sm
p = p * sm
s1 = s1 + p
IF (ind /= 0) THEN
sgn = -sgn
s2 = s2 + sgn * p
END IF
am = ar * am
IF (1.0D0 + alpha*am /= 1.0D0) THEN
m = m + 1
IF (m <= 16) GO TO 20
END IF
! FINAL ASSEMBLY
s1 = c * c1 * s1
IF (ind == 0) THEN
w = s1
ELSE
s2 = c * c2 * s2
q = nu + z
theta = ATAN2(AIMAG(q),REAL(q, KIND=dp)) - phi
IF (ABS(theta) <= bnd) THEN
w = s1 + s2
ELSE
alpha = pi2
IF (izn < 0.0D0) alpha = -alpha
t = alpha * CMPLX(ABS(inu),-fn, KIND=dp)
alpha = EXP(REAL(t))
u = AIMAG(t)
r = CMPLX(COS(u),SIN(u), KIND=dp)
t = s1 - (alpha*r) * s1
IF (x == 0.0D0 .AND. inu == 0.0D0) t = -t
IF (y < 0.0D0) THEN
IF (izn >= 0.0D0 .AND. theta <= SIGN(pi,theta)) s2 = &
s2 * ( CONJG(r)/alpha)
IF (x == 0.0D0) GO TO 40
IF (izn >= 0.0D0) THEN
IF (is < 0.0D0) GO TO 40
END IF
END IF
w = s2 + t
GO TO 50
40 w = s2 - t
END IF
END IF
50 IF (inu < 0.0D0) w = CONJG(w)
RETURN
END SUBROUTINE cbdb
SUBROUTINE cbja(cz,cnu,w)
!-----------------------------------------------------------------------
! COMPUTATION OF J(NU,Z) BY THE ASYMPTOTIC EXPANSION
!-----------------------------------------------------------------------
COMPLEX (dp), INTENT(IN) :: cz
COMPLEX (dp), INTENT(IN) :: cnu
COMPLEX (dp), INTENT(OUT) :: w
! Local variables
REAL (dp) :: eps, inu, m
COMPLEX (dp) :: a, a1, arg, e, eta, nu, p, q, t, z, zr, zz
!--------------------------
REAL (dp) :: r, rnu, tol, u, v
REAL (dp) :: x, y
INTEGER :: i, ind
!--------------------------
! PIHALF = PI/2
! C = 2*PI**(-1/2)
!--------------------------
REAL (dp), PARAMETER :: pihalf = 1.5707963267949_dp, c = 1.12837916709551_dp
COMPLEX (dp), PARAMETER :: j = (0.0_dp, 1.0_dp)
!--------------------------
! ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE
! SMALLEST NUMBER SUCH THAT 1.0 + EPS .GT. 1.0 .
eps = EPSILON(0.0_dp)
!--------------------------
z = cz
x = REAL(z, KIND=dp)
y = AIMAG(z)
nu = cnu
ind = 0
IF (ABS(x) <= 1.d-2*ABS(y)) THEN
IF (AIMAG(nu) < 0.0D0 .AND. ABS(REAL(nu)) < 1.d-2*ABS(AIMAG(nu))) THEN
ind = 1
nu = CONJG(nu)
z = CONJG(z)
y = -y
END IF
END IF
IF (x < -1.d-2*y) z = -z
zz = z + z
CALL dcrec(REAL(zz, KIND=dp),AIMAG(zz),u,v)
zr = CMPLX(u,v, KIND=dp)
eta = -zr * zr
p = (0.0D0,0.0D0)
q = (0.0D0,0.0D0)
a1 = nu * nu - 0.25D0
a = a1
t = a1
m = 1.0D0
tol = eps * anorm(a1)
DO i = 1, 16
a = a - 2.0D0 * m
m = m + 1.0D0
t = t * a * eta / m
p = p + t
a = a - 2.0D0 * m
m = m + 1.0D0
t = t * a / m
q = q + t
IF (anorm(t) <= tol) GO TO 20
END DO
20 p = p + 1.0D0
q = (q+a1) * zr
w = z - pihalf * nu
IF (ABS(AIMAG(w)) <= 1.0D0) THEN
arg = w - 0.5D0 * pihalf
w = c * SQRT(zr) * (p*COS(arg) - q*SIN(arg))
ELSE
e = EXP(-j*w)
t = q - j * p
IF (AIMAG(z) > 0.0D0 .AND. REAL(z, KIND=dp) <= 1.d-2*AIMAG(z).AND. &
ABS(REAL(nu, KIND=dp)) < 1.d-2*AIMAG(nu)) t = 0.5D0 * t
CALL dcrec(REAL(e, KIND=dp),AIMAG(e),u,v)
w = 0.5D0 * c * SQRT(j*zr) * ((p-j*q)*e + t*CMPLX(u,v, KIND=dp))
END IF
IF (x < -1.d-2*y) THEN
IF (y < 0.0D0) nu = -nu
! COMPUTATION OF EXP(I*PI*NU)
rnu = REAL(nu, KIND=dp)
inu = AIMAG(nu)
r = EXP(-2.0D0*pihalf*inu)
u = r * dcos1(rnu)
v = r * dsin1(rnu)
w = w * CMPLX(u,v, KIND=dp)
END IF
IF (ind /= 0) w = CONJG(w)
RETURN
END SUBROUTINE cbja