Blame view
fvn_fnlib/c9lgmc.f
2.02 KB
38581db0c
git-svn-id: https...
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 |
complex function c9lgmc (zin)
c april 1978 edition. w. fullerton c3, los alamos scientific lab.
c
c compute the log gamma correction term for large cabs(z) when real(z)
c .ge. 0.0 and for large abs(aimag(y)) when real(z) .lt. 0.0. we find
c c9lgmc so that
c clog(cgamma(z)) = 0.5*alog(2.*pi) + (z-0.5)*clog(z) - z + c9lgmc(z).
c
complex zin, z, z2inv
external r1mach
c
dimension bern(11)
data bern( 1) / .08333333333 3333333e0 /
data bern( 2) / -.002777777777 7777778e0 /
data bern( 3) / .0007936507936 5079365e0 /
data bern( 4) / -.0005952380952 3809524e0 /
data bern( 5) / .0008417508417 5084175e0 /
data bern( 6) / -.001917526917 5269175e0 /
data bern( 7) / .006410256410 2564103e0 /
data bern( 8) / -.02955065359 4771242e0 /
data bern( 9) / .1796443723 6883057e0 /
data bern(10) / -1.392432216 9059011e0 /
data bern(11) / 13.40286404 4168392e0 /
c
data nterm, bound, xbig, xmax / 0, 3*0.0 /
c
if (nterm.ne.0) go to 10
c
nterm = -0.30*alog(r1mach(3))
bound = 0.1170*float(nterm)*
1 (0.1*r1mach(3))**(-1./(2.*float(nterm)-1.))
xbig = 1.0/sqrt(r1mach(3))
xmax = exp (amin1(alog(r1mach(2)/12.0), -alog(12.*r1mach(1))) )
c
10 z = zin
x = real (z)
y = aimag(z)
cabsz = cabs(z)
c
if (x.lt.0.0 .and. abs(y).lt.bound) call seteru ( 69hc9lgmc c9lgm
1c not valid for negative real(z) and small abs(aimag(z)), 69, 2,2)
if (cabsz.lt.bound) call seteru (
1 42hc9lgmc c9lgmc not valid for small cabs(z), 42, 3, 2)
c
if (cabsz.ge.xmax) go to 50
c
if (cabsz.ge.xbig) c9lgmc = 1.0/(12.0*z)
if (cabsz.ge.xbig) return
c
z2inv = 1.0/z**2
c9lgmc = (0.0, 0.0)
do 40 i=1,nterm
ndx = nterm + 1 - i
c9lgmc = bern(ndx) + c9lgmc*z2inv
40 continue
c
c9lgmc = c9lgmc/z
return
c
50 c9lgmc = (0.0, 0.0)
call seteru (34hc9lgmc z so big c9lgmc underflows, 34, 1, 0)
return
c
end
|