Blame view
fvn_fnlib/poch.f
3.25 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 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 |
function poch (a, x) c august 1980 edition. w. fullerton, c3, los alamos scientific lab. c error handling when poch (a, x) is less than half precision is c probably incorrect. grossly wrong arguments are not handled right. c c evaluate a generalization of pochhammer-s symbol c (a)-sub-x = gamma(a+x)/gamma(a). for x a non-negative integer, c poch(a,x) is just pochhammer-s symbol. c external alnrel, fac, gamma, gamr, r1mach, 1 r9lgmc data pi / 3.1415926535 89793238 e0 / data eps, sqeps / 2*0.0 / c if (eps.ne.0.0) go to 10 eps = r1mach(4) sqeps = sqrt(eps) c 10 ax = a + x if (ax.gt.0.0) go to 30 if (aint(ax).ne.ax) go to 30 c if (a.gt.0.0 .or. aint(a).ne.a) call seteru ( 1 48hpoch a+x is non-positive integer but a is not, 48, 2, 2) c c we know here that both a+x and a are non-positive integers. c poch = 1.0 if (x.eq.0.0) return c n = x if (amin1(a+x,a).lt.(-20.0)) go to 20 c poch = (-1.0)**n * fac(-int(a))/fac(-int(a)-n) return c 20 poch = (-1.0)**n * exp ((a-0.5)*alnrel(x/(a-1.0)) 1 + x*alog(-a+1.0-x) - x + r9lgmc(-a+1.) - r9lgmc(-a-x+1.) ) return c c here we know a+x is not zero or a negative integer. c 30 poch = 0.0 if (a.le.0.0 .and. aint(a).eq.a) return c n = abs(x) if (float(n).ne.x .or. n.gt.20) go to 50 c c x is a small non-positive integer, presummably a common case. c poch = 1.0 if (n.eq.0) return do 40 i=1,n poch = poch * (a+float(i-1)) 40 continue return c 50 absax = abs(a+x) absa = abs(a) if (amax1(absax,absa).gt.20.0) go to 60 c if (abs(x).gt.absax/sqeps) call seteru (67hpoch answer lt half 1precision, a+x cannot be computed accurately, 67, 1, 1) poch = gamma(a+x)*gamr(a) c error handling above is probably bad when a almost = -n and when x is c small. maybe use reflection formula below in modified form. return c 60 if (abs(x).gt.0.5*absa) go to 70 c c here abs(x) is small and both abs(a+x) and abs(a) are large. thus, c a+x and a must have the same sign. for negative a, we use c gamma(a+x)/gamma(a) = gamma(-a+1)/gamma(-a-x+1) * c sin(pi*a)/sin(pi*(a+x)) c b = a if (b.lt.0.0) b = -a - x + 1.0 poch = exp ((b-0.5)*alnrel(x/b) + x*alog(b+x) - x + 1 r9lgmc(b+x) - r9lgmc(b) ) c if (a.ge.0.0 .or. poch.eq.0.0) return call entsrc (irold, 1) cospix = cos (pi*x) call erroff sinpix = sin (pi*x) call erroff cospia = cos (pi*a) call erroff sinpia = sin (pi*a) call erroff call entsrc (irold2, irold) c errpch = abs(x)*(1.0+alog(b)) den = cospix + cospia*sinpix/sinpia err = (abs(x)*(abs(sinpix)+abs(cospia*cospix/sinpia)) 1 + abs(a*sinpix)/sinpia**2)*pi err = errpch + err/abs(den) if (err.gt.1.0/eps) call seteru (73hpoch answer has no precisio 1n, a or a+x too close to a negative integer, 73, 3, 2) if (err.gt.1.0/sqeps) call seteru (72hpoch answer lt half preci 1on, a or a+x too close to a negative integer, 72, 2, 1) c poch = poch/den return c 70 call algams (a+x, alngax, sgngax) call algams (a, alnga, sgnga) poch = sgngax * sgnga * exp(alngax-alnga) c return end |