Blame view

fvn_fnlib/betai.f 2.6 KB
38581db0c   daniau   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
        function betai (x, pin, qin)
  c august 1980 version.  w. fullerton, c3, los alamos scientific lab.
  c based on bosten and battiste, remark on algorithm 179, comm. acm,
  c v 17, p 153, (1974).
  c
  c             input arguments --
  c x      upper limit of integration.  x must be in (0,1) inclusive.
  c p      first beta distribution parameter.  p must be gt 0.0.
  c q      second beta distribution parameter.  q must be gt 0.0.
  c betai  the incomplete beta function ratio is the probability that a
  c        random variable from a beta distribution having parameters
  c        p and q will be less than or equal to x.
  c
        external  albeta, r1mach
        data eps, alneps, sml, alnsml / 4*0.0 /
  c
        if (eps.ne.0.) go to 10
        eps = r1mach(3)
        alneps = alog(eps)
        sml = r1mach(1)
        alnsml = alog(sml)
  c
   10   if (x.lt.0. .or. x.gt.1.0) call seteru (
       1  35hbetai   x is not in the range (0,1), 35, 1, 2)
        if (pin.le.0. .or. qin.le.0.) call seteru (
       1  29hbetai   a and/or b is le zero, 29, 2, 2)
  c
        y = x
        p = pin
        q = qin
        if (q.le.p .and. x.lt.0.8) go to 20
        if (x.lt.0.2) go to 20
        y = 1.0 - y
        p = qin
        q = pin
  c
   20   if ((p+q)*y/(p+1.).lt.eps) go to 80
  c
  c evaluate the infinite sum first.
  c term will equal y**p/beta(ps,p) * (1.-ps)i * y**i / fac(i)
  c
        ps = q - aint(q)
        if (ps.eq.0.) ps = 1.0
        xb = p*alog(y) -  albeta(ps, p) - alog(p)
        betai = 0.0
        if (xb.lt.alnsml) go to 40
  c
        betai = exp (xb)
        term = betai*p
        if (ps.eq.1.0) go to 40
  c
        n = amax1 (alneps/alog(y), 4.0)
        do 30 i=1,n
          term = term*(float(i)-ps)*y/float(i)
          betai = betai + term/(p+float(i))
   30   continue
  c
  c now evaluate the finite sum, maybe.
  c
   40   if (q.le.1.0) go to 70
  c
        xb = p*alog(y) + q*alog(1.0-y) - albeta(p,q) - alog(q)
        ib = amax1 (xb/alnsml, 0.0)
        term = exp (xb - float(ib)*alnsml)
        c = 1.0/(1.0-y)
        p1 = q*c/(p+q-1.)
  c
        finsum = 0.0
        n = q
        if (q.eq.float(n)) n = n - 1
        do 50 i=1,n
          if (p1.le.1.0 .and. term/eps.le.finsum) go to 60
          term = (q-float(i-1))*c*term/(p+q-float(i))
  c
          if (term.gt.1.0) ib = ib - 1
          if (term.gt.1.0) term = term*sml
  c
          if (ib.eq.0) finsum = finsum + term
   50   continue
  c
   60   betai = betai + finsum
   70   if (y.ne.x .or. p.ne.pin) betai = 1.0 - betai
        betai = amax1 (amin1 (betai, 1.0), 0.0)
        return
  c
   80   betai = 0.0
        xb = p*alog(amax1(y,sml)) - alog(p) - albeta(p,q)
        if (xb.gt.alnsml .and. y.ne.0.) betai = exp (xb)
        if (y.ne.x .or. p.ne.pin) betai = 1.0 - betai
        return
  c
        end