-
git-svn-id: https://lxsd.femto-st.fr/svn/fvn@70 b657c933-2333-4658-acf2-d3c7c2708721
z9lgmc.f
2.14 KB
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
65
66
67
complex(kind(1.d0)) function z9lgmc (zin)
implicit none
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(kind(1.d0)) zin, z, z2inv
real(kind(1.d0)) d1mach,bern,xbig,xmax,bound,cabsz,x,y
integer nterm,i,ndx
external d1mach
c
dimension bern(11)
data bern( 1) / .08333333333 3333333d0 /
data bern( 2) / -.002777777777 7777778d0 /
data bern( 3) / .0007936507936 5079365d0 /
data bern( 4) / -.0005952380952 3809524d0 /
data bern( 5) / .0008417508417 5084175d0 /
data bern( 6) / -.001917526917 5269175d0 /
data bern( 7) / .006410256410 2564103d0 /
data bern( 8) / -.02955065359 4771242d0 /
data bern( 9) / .1796443723 6883057d0 /
data bern(10) / -1.392432216 9059011d0 /
data bern(11) / 13.40286404 4168392d0 /
c
data nterm, bound, xbig, xmax / 0d0, 3*0.0d0 /
c
if (nterm.ne.0) go to 10
c
nterm = -0.30*log(d1mach(3))
bound = 0.1170*dble(nterm)*
1 (0.1*d1mach(3))**(-1./(2.*dble(nterm)-1.))
xbig = 1.0/sqrt(d1mach(3))
xmax = exp (min(log(d1mach(2)/12.0), -log(12.*d1mach(1))) )
c
10 z = zin
x = real (z)
y = aimag(z)
cabsz = abs(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 42hz9lgmc z9lgmc not valid for small cabs(z), 42, 3, 2)
c
if (cabsz.ge.xmax) go to 50
c
if (cabsz.ge.xbig) z9lgmc = 1.0/(12.0*z)
if (cabsz.ge.xbig) return
c
z2inv = 1.0/z**2
z9lgmc = (0.0, 0.0)
do 40 i=1,nterm
ndx = nterm + 1 - i
z9lgmc = bern(ndx) + z9lgmc*z2inv
40 continue
c
z9lgmc = z9lgmc/z
return
c
50 z9lgmc = (0.0, 0.0)
call seteru (34hz9lgmc z so big z9lgmc underflows, 34, 1, 0)
return
c
end