[Fortran] syntaxhighlighter_viewsource syntaxhighlighter_copycode
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