function beta ( x, a, b ) c*********************************************************************72 c cc beta() returns the value of the Beta density function. c c Discussion: c c This function returns the value of the Beta density function c BETA(X|A,B), where A and B are the parameters of the Beta. c c Modified: c c 24 April 2013 c c Reference: c c Roger Abernathy, Robert Smith, c Algorithm 724: Program to calculate F-percentiles, c ACM Transactions on Mathematical Software, c Volume 19, Number 4, December 1993, pages 481-483. c c Parameters: c C X - The argument of the Beta density function. C X is a real number. c C A,B - The parameters of the Beta density function. C A and B are real numbers of the form (integer)/2. C double precision beta double precision pi, tol parameter ( pi=3.14159265359d0, tol=1d-4 ) double precision a, b, x double precision at, bt, hold, temp, xt, yt intrinsic dabs, dble, dexp, dlog, dsqrt at = a bt = b xt = x yt = 1.0d0 - xt if (at.lt.bt) then hold = at at = bt bt = hold yt = xt xt = 1.0d0 - xt endif if (at .gt. 60.0d0) then if (bt .gt. 60.0d0) then temp = (at-0.5d0)*dlog(xt*(at+bt-1.0d0)/(at-1.0d0)) + + (bt-0.5d0)*dlog(yt*(at+bt-1.0d0)/(bt-1.0d0)) temp = dexp(temp-1.0d0)*dsqrt((at+bt-1.0d0)/ + (dble(2)*pi*xt*yt)) else temp = 1.0d0 10 if (bt .le. (1.0d0+tol)) goto 20 bt = bt - 1.0d0 temp = temp*yt*(at+bt)/bt goto 10 20 continue if (dabs(bt-0.5d0).lt.tol) temp = temp/dsqrt(pi*yt) temp = dlog(temp) - bt + + (at-0.5d0)*dlog(xt*(at+bt-1.0d0)/(at-1.0d0)) + + bt*dlog(at+bt-1.0d0) temp = dexp(temp)/dsqrt(xt) endif else temp = 1.0d0 30 if (at.le.(1.0d0+tol)) goto 40 at = at - 1.0d0 temp = temp*xt*(at+bt)/at goto 30 40 if (bt.le.(1.0d0+tol)) goto 50 bt = bt - 1.0d0 temp = temp*yt*(at+bt)/bt goto 40 50 if (dabs(at+bt-1.5d0).lt.tol) temp = temp*0.5d0*dsqrt(pi) if (dabs(at-0.5d0).lt.tol) temp = temp/dsqrt(pi*xt) if (dabs(bt-0.5d0).lt.tol) temp = temp/dsqrt(pi*yt) endif beta = temp return end function binv ( a, b, vapp, p ) c*********************************************************************72 c cc BINV computes percentage points for the Beta distribution. c c Discussion: c c This function uses a series expansion method to compute c percentage points for the Beta distribution. c c Modified: c c 24 April 2013 c c Reference: c c Roger Abernathy, Robert Smith, c Algorithm 724: Program to calculate F-percentiles, c ACM Transactions on Mathematical Software, c Volume 19, Number 4, December 1993, pages 481-483. c c Parameters: c C A,B - The parameters of the Beta distribution. C A and B must both be positive real numbers of the form C (integer)/2. c C VAPP - The initial approximation to the Beta percentile. C VAPP is a real number between 0.0 and 1.0. c C P - The probability for which the inverse Beta percentile is C to be evaluated. C P is a real number between 0.0 and 1.0. C C EXTERNAL FUNCTION CALLED: C BETA - BETA(A,B,X) returns the value of the density function for C a Beta(A,B) random variable. C A and B are elements in {N/2 | N is a positive integer}. C 0 <= X <= 1. C C DBETAI - DBETAI(X,A,B) returns the probability that a random C variable from a Beta distribution having parameters (A,B) C will be less than or equal to X --- P{B(A,B) <= X} = DBETAI. C A and B are positive real numbers. C double precision binv double precision error, errapp parameter ( error = 1.0d-8, errapp = 1.0d-3 ) double precision a, b, p, vapp double precision bcoeff, q, s1, s2, sum, t, tail, + vhold, v integer i, j, k, loopct double precision d(2:20,0:18) double precision beta, dbetai external beta, dbetai intrinsic dabs, dble, dmax1, dmin1 v = vapp vhold = 0.0d0 loopct = 2 10 if ((dabs((v-vhold)/v).ge.errapp).and.(loopct.ne.0)) then vhold = v loopct = loopct - 1 c ( use dbetai to find f(v) = prob{ beta(a,b) <= v }. ) c ( and then compute q = (p - f(v))/f(v). ) q = (p-dbetai(v,a,b))/beta(v,a,b) c ( let d(n,k) = c(n,k)*q**(n+k-1)/(n-1)! ) t = 1.0d0 - v s1 = q*(b-1.0d0)/t s2 = q*(1.0d0-a)/v d(2,0) = s1 + s2 tail = d(2,0)*q/2.0d0 v = v + q + tail k = 3 20 if ((dabs(tail/v).gt.error).and.(k.le.20)) then c ( first find d(2,k-2). ) s1 = q*(dble(k)-2.0d0)*s1/t s2 = q*(2.0d0-dble(k))*s2/v d(2,k-2) = s1 + s2 c ( now find d(3,k-3), d(4,k-4), d(5,k-5), ... , d(k-1,1). ) do 40 i=3,k-1 sum = d(2,0)*d(i-1,k-i) bcoeff = 1.0d0 do 30 j = 1,k-i bcoeff = (bcoeff*dble(k-i-j+1))/dble(j) sum = sum + bcoeff*d(2,j)*d(i-1,k-i-j) 30 continue d(i,k-i) = sum + d(i-1,k-i+1)/dble(i-1) 40 continue c ( and then compute d(k,0) and use it to expand the series. ) d(k,0) = d(2,0)*d(k-1,0) + d(k-1,1)/dble(k-1) tail = d(k,0)*q/dble(k) v = v + tail c ( check for a divergent series. ) if ((v .le. 0.0d0) .or. (v .ge. 1.0d0)) then print *,'series in binv diverges' v = -1.0d0 go to 50 end if k = k+1 go to 20 end if go to 10 end if 50 binv = v return end function dbetai ( x, pin, qin ) c*********************************************************************72 c cc DBETAI evaluates the incomplete beta function ratio. c c Discussion: c c This function evaluates the incomplete beta function ratio. c c Modified: c c 24 April 2013 c c Reference: c c Roger Abernathy, Robert Smith, c Algorithm 724: Program to calculate F-percentiles, c ACM Transactions on Mathematical Software, c Volume 19, Number 4, December 1993, pages 481-483. c c Parameters: c C X - Upper Limit of integration. C X must be in the interval (0.0,1.0) inclusive. C PIN - First beta distribution parameter C PIN must be a positive real number. C QIN - Second beta distribution parameter C QIN must be a positive real number. C C EXTERNAL FUNCTIONS CALLED: C DLBETA-DLBETA(A,B) returns the value of the logarithm of the Beta C function having parameters A and B. C C Note: DBETAI is an IMSL library routine. The authors have been C granted special permission to include this source code from C the IMSL library. C However, anyone wishing to use this code must first C purchased the library routines from IMSL. c double precision dbetai double precision x, pin, qin double precision c, finsum, p, p1, ps, q, term, xb, y c integer max1 c real sngl double precision alneps, alnsml, eps, sml save alneps, alnsml, eps, sml double precision dlbeta external dlbeta intrinsic dble, dexp, dint, dlog, dmax1, dmin1, + max1, sngl data alneps/0.0d0/, alnsml/0.0d0/, + eps/0.0d0/, sml/0.0d0/ if (eps .eq. 0.0d0) then eps = 1.19237d-7 alneps = dlog(eps) sml = 100.0d0*2.93941d-39 alnsml = dlog(sml) end if y = x p = pin q = qin if (q. le. p .and. x .lt. 0.8d0) go to 10 if (x .lt. 0.2d0) go to 10 y = 1.0d0 - y p = qin q = pin 10 if ((p+q)*y/(p+1.0d0) .lt. eps) go to 70 ps = q - dint(q) if (ps .eq. 0.0d0) ps = 1.0d0 xb = p*dlog(y) - dlbeta(ps,p) - dlog(p) dbetai = 0.0d0 if (xb .lt. alnsml) go to 30 dbetai = dexp(xb) term = dbetai*p if (ps .eq. 1.0d0) go to 30 n = max1(sngl(alneps/dlog(y)),4.0) do i=1, n term = term *(dble(i) - ps)*y/dble(i) dbetai = dbetai + term/(p+dble(i)) end do 30 if (q .le. 1.0d0) go to 60 xb = p*dlog(y) + q*dlog(1.0d0-y) - dlbeta(p,q) - dlog(q) ib = max1(sngl(xb/alnsml),0.0) term = dexp(xb-dble(ib)*alnsml) c = 1.0d0/(1.0d0-y) p1 = q*c/(p+q-1.0d0) finsum = 0.0d0 n = int ( q ) if (q .eq. dble(n)) n = n - 1 do 40 i=1, n if (p1.le.1.0d0 .and. term/eps.le.finsum) go to 50 term = (q-dble(i)+1.0d0)*c*term/(p+q-dble(i)) if (term .gt. 1.0d0) then ib = ib - 1 term = term*sml end if if (ib .eq. 0) finsum = finsum + term 40 continue 50 dbetai = dbetai + finsum 60 if (y.ne.x .or. p.ne.pin) dbetai = 1.0d0 - dbetai dbetai = dmax1(dmin1(dbetai,1.0d0),0.0d0) go to 9000 70 dbetai = 0.0d0 xb = p*dlog(dmax1(y,sml)) - dlog(p) - dlbeta(p,q) if (xb.gt.alnsml .and. y.ne.0.0d0) dbetai = dexp(xb) if (y.ne.x .or. p.ne.pin) dbetai = 1.0 - dbetai 9000 return end function dlbeta ( a, b ) c*********************************************************************72 c cc DLBETA returns the log of Gamma(A)*Gamma(B)/Gamma(A+B) c c Discussion: c c This function returns the logarithm of the ratio: c Gamma(A)*Gamma(B)/Gamma(A+B). c c This routine was written by the authors to complement the c IMSL routine DBETAI which calls this function. c c Modified: c c 24 April 2013 c c Reference: c c Roger Abernathy, Robert Smith, c Algorithm 724: Program to calculate F-percentiles, c ACM Transactions on Mathematical Software, c Volume 19, Number 4, December 1993, pages 481-483. c c Parameters: c C A, B - These are the parameters of the Beta distribution. C A and B are real numbers of the form (integer)/2. C double precision dlbeta double precision pi, tol parameter (pi = 3.14159265359d0, tol = 1d-4) double precision a, b double precision at, bt, dspi, hold, temp intrinsic dabs, dble, dexp, dlog, dsqrt dspi = dsqrt(pi) at = a bt = b if (at.lt.bt) then hold = at at = bt bt = hold endif if (at .gt. 60.0d0) then if (bt .gt. 60.0d0) then temp = at*dlog((at+bt)/at) + bt*dlog((at+bt)/bt) temp = dexp(temp)*dsqrt(at*bt/(dble(2)*pi*(at+bt))) else temp = 1.0d0 10 if (bt.le.(1.0d0+tol)) goto 20 bt = bt - 1.0d0 temp = temp*(at+bt)/bt goto 10 20 continue if (dabs(bt-0.5d0).lt.tol) temp = temp/dspi temp = dlog(temp) + at*dlog((at+bt)/at) - bt temp = dexp(temp)*dsqrt(at) if(dabs(bt-1.0d0).lt.tol) temp=temp*dsqrt(at+bt) endif else temp = 1.0d0 30 if (at.le.(1.0d0+tol)) goto 40 at = at - 1.0d0 temp = temp*(at+bt)/at goto 30 40 if (bt.le.(1.0d0+tol)) goto 50 bt = bt - 1.0d0 temp = temp*(at+bt)/bt goto 40 50 if (dabs(at+bt-1.5d0).lt.tol) temp = temp*0.5d0*dspi if (dabs(at-0.5d0).lt.tol) temp = temp/dspi if (dabs(bt-0.5d0).lt.tol) temp = temp/dspi endif dlbeta = -dlog(temp) return end function finit ( m, n, p ) c*********************************************************************72 c cc FINIT approximates the percentage points of the F distribution. c c Discussion: c c This function returns an approximation to the pth percentile c for an F distribution with (m,n) degrees of freedom. c c This approximation is due to Carter (1947). c c Modified: c c 24 April 2013 c c Reference: c c Roger Abernathy, Robert Smith, c Algorithm 724: Program to calculate F-percentiles, c ACM Transactions on Mathematical Software, c Volume 19, Number 4, December 1993, pages 481-483. c c Parameters: c C M,N - The degrees of freedom of the F distribution. C M and N are positive integers, M >=3 and N >= 3. C C EXTERNAL FUNCTION CALLED: C ZINV - ZINV returns X, the inverse probability for a Standard C Normal distribution function --- P{Z <= X} = P. C double precision finit double precision p integer m, n double precision a, b, c ,d, x double precision zinv external zinv intrinsic dble, dexp, dsqrt c ( use zinv to find x when p = prob{ n(0,1) <= x }. ) x = zinv(p) a = 1.0d0/(dble(m)-1.0d0) + 1.0d0/(dble(n)-1.0d0) b = 1.0d0/(dble(m)-1.0d0) - 1.0d0/(dble(n)-1.0d0) c = (x*x-3.0d0)/6.0d0 d = x*a*dsqrt((2.0d0/a)+c) - 2.0d0*b*(c+5.0d0/6.0d0-a/3.0d0) finit = dexp(d) return end function finv ( m, n, p ) c*********************************************************************72 c cc FINV returns percentage points for an F distribution. c c Discussion: c c This function returns percentage points for an F-distribution c having (M,N) degrees of freedom --- P{F(M,N) <= FINV} = P. c c Modified: c c 24 April 2013 c c Reference: c c Roger Abernathy, Robert Smith, c Algorithm 724: Program to calculate F-percentiles, c ACM Transactions on Mathematical Software, c Volume 19, Number 4, December 1993, pages 481-483. c c Parameters: c C M,N - The degrees of freedom of an F-distribution. C M and N must both be positive integers. C P - The probability for which the inverse of the F-distribution C is to be evaluated. 0 <= P < 1. C FINV - Function value (output) C The probability that a random variable with F-distribution C takes a value less than or equal to FINV is equal to P. C If M or N is negative, or if P >=1 or < 0, then FINV C returns with a negative value and an appropriate error C message is sent to standard output. C C EXTERNAL FUNCTIONS CALLED: C C BINV - BINV(A,B,VAPP,P) returns the percentage points for a Beta C random variable, B(A,B) --- P{B(A,B) <= BINV} = P. C 0 <= VAPP <= 1 is an initial approximation to BINV. C A and B are elements in {N/2 | N is a positive integer}. C If the series used in BINV does not converge, the C expansion is terminated, a negative value is returned and C a message noting this divergence is sent to standard C output. C C FINIT - FINIT(M,N,P) returns an initial approximation for the C point x such that a random variable, F, with F-distribution C having (M,N) degrees of freedom will satisfy P{F <= x} = P. C 0 < P < 1 and M,N are positive integers >= 3. C This is the approximation due to Carter (1947). C C TINIT - TINIT(N,P) returns an initial approximation for the point C x such that a random variable, T, with t-distribution having C N degrees of freedom will satisfy P{T >= x} = P. C 0 < P < 1 and N is a positive integer. C This is the approximation due to Goldberg and Levine (1945). C double precision finv double precision pi parameter ( pi = 3.14159265359d0 ) integer m, n double precision p double precision a, b, power, t, f double precision binv, finit, tinit external binv, finit, tinit intrinsic dtan, dble c ( first, eliminate bad values for p. ) if ((p.le.0.0d0).or.(p.ge.1.0d0)) then if (p.eq.0.0d0) then finv = 0.0d0 else if ((p.lt. 0.0d0).or.(p.ge.1.0d0)) then finv = -1.0d0 print *,'error: probability p is out of range' end if else if ((m.le.0).or.(n.le.0)) then finv = -1.0d0 print *,'error: a parameter values (m or n) is negative' c ( then, consider special cases. ) c case: m>2 and n>2: ( f-distribution--convert to beta. ) else if ((m.gt.2).and.(n.gt.2)) then f = finit(m,n,p) c ( transform f approximation to beta approximation. ) b = dble(n)/(dble(n)+dble(m)*f) c ( find the beta percentage point. ) a = binv( dble(n)/2.0d0, dble(m)/2.0d0, b, 1.0d0 - p ) c ( convert result to f percentage point. ) finv = ( (1.0d0-a)*dble(n))/(a*dble(m) ) c case: m=1, n=1: ( cauchy distribution--do direct calculation.) else if ((m.eq.1).and.(n.eq.1)) then a = dtan(p*pi/2) finv = a*a c case: m=1 or n=1, but not both: ( t distribution--convert to beta. ) else if ((m.eq.1).or.(n.eq.1)) then c ( get initial approximation for t, convert to f. ) if (m.eq.1) then t = tinit(n,(1.0d0-p)/2.0d0) f = t*t else t = tinit(m,p/2.0d0) f = 1.0d0/(t*t) endif c ( transform f approximation to beta approximation. ) b = dble(n)/(dble(n)+dble(m)*f) c ( find the beta percentage point. ) a = binv( dble(n)/2.0d0, dble(m)/2.0d0, b, 1.0d0 - p ) c ( convert result to f percentage point. ) finv = ( (1.0d0-a)*dble(n))/(a*dble(m) ) c case: m=2 or n=2: ( polynomial density--do direct calculation. ) else if(m.eq.2) then power = (1.0d0-p)**(2.0d0/dble(n)) finv = dble(n)*(1.0d0-power)/(2.0d0*power) else power = p**(2.0d0/dble(m)) finv = (2.0d0*power)/((1.0d0-power)*dble(m)) endif endif return end subroutine timestamp ( ) c*********************************************************************72 c cc TIMESTAMP prints out the current YMDHMS date as a timestamp. c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 12 January 2007 c c Author: c c John Burkardt c c Parameters: c c None c implicit none character * ( 8 ) ampm integer d character * ( 8 ) date integer h integer m integer mm character * ( 9 ) month(12) integer n integer s character * ( 10 ) time integer y save month data month / & 'January ', 'February ', 'March ', 'April ', & 'May ', 'June ', 'July ', 'August ', & 'September', 'October ', 'November ', 'December ' / call date_and_time ( date, time ) read ( date, '(i4,i2,i2)' ) y, m, d read ( time, '(i2,i2,i2,1x,i3)' ) h, n, s, mm if ( h .lt. 12 ) then ampm = 'AM' else if ( h .eq. 12 ) then if ( n .eq. 0 .and. s .eq. 0 ) then ampm = 'Noon' else ampm = 'PM' end if else h = h - 12 if ( h .lt. 12 ) then ampm = 'PM' else if ( h .eq. 12 ) then if ( n .eq. 0 .and. s .eq. 0 ) then ampm = 'Midnight' else ampm = 'AM' end if end if end if write ( *, & '(i2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) & d, month(m), y, h, ':', n, ':', s, '.', mm, ampm return end function tinit ( n, p ) c*********************************************************************72 c cc TINIT approximates the percentage points of the Students T distribution. c c Discussion: c c This function returns an approximation to the pth percentile c for a Students T distribution with N degrees of freedom. c c This approximation is due to Goldberg and Levine (1945). c c Modified: c c 24 April 2013 c c Reference: c c Roger Abernathy, Robert Smith, c Algorithm 724: Program to calculate F-percentiles, c ACM Transactions on Mathematical Software, c Volume 19, Number 4, December 1993, pages 481-483. c c Parameters: c c Input, integer N, the degree of freedom of the Students T distribution. c 0 < N. c c Input, double precision P, the percentile. c c Output, double precision TINIT, the percentage point. c integer n double precision p double precision tinit double precision x double precision xsquar double precision zinv x = zinv ( p ) xsquar = x * x tinit = x + x * ( xsquar + 1.0D+00 ) / ( 4.0D+00 * dble ( n ) ) & + x * ( xsquar * ( xsquar * 5.0D+00 + 16.0D+00 ) & + 3.0D+00 ) / ( 96.0D+00 * dble ( n * n ) ) return end function zinv ( p ) c*********************************************************************72 c cc ZINV approximates the percentage points of the normal distribution. c c Discussion: c c This function returns an approximation for the pth percentile c of the standard normal distribution function. c c This approximation is due to Hastings (1955). c c Modified: c c 24 April 2013 c c Reference: c c Roger Abernathy, Robert Smith, c Algorithm 724: Program to calculate F-percentiles, c ACM Transactions on Mathematical Software, c Volume 19, Number 4, December 1993, pages 481-483. c c Parameters: c C P - The given percentile. C P is a real number between 0.0 and 1.0. C c double precision zinv double precision p double precision c0, c1, c2, d1, d2, d3, + denom, numer, ptemp, z intrinsic dlog, dsqrt data c0,c1,c2 / 2.515517d0, 0.802853d0, 0.010328d0 / data d1,d2,d3 / 1.432788d0, 0.189269d0, 0.001308d0 / ptemp = p if (p .gt. 0.5d0) ptemp = 1.0d0 - p z = dsqrt(-2.0d0*dlog(ptemp)) numer = c0 + z*(c1 + z*c2) denom = 1.0d0 + z*(d1 + z*(d2 + z*d3)) z = z - numer/denom if (p .le. 0.5d0) z = -z zinv = z return end