mnormt/0000755000176200001440000000000013615767442011605 5ustar liggesusersmnormt/NAMESPACE0000644000176200001440000000015112620607714013007 0ustar liggesusersimportFrom("stats", "cov2cor", "dnorm", "dt", "pnorm", "pt", "rchisq", "rnorm") exportPattern(".") mnormt/ChangeLog0000644000176200001440000000255712354254143013354 0ustar liggesusersR package 'mnormt' history file ------------------------------- 2005-nov. : built private version 2006-01-23: 1.0-0 first version uploaded on CRAN 2006-04-26: 1.0-1 fixed a bug of non-compliance to R programming standards 2006-10-09: 1.1-0 adopt amedend Fortran code of Alan Genz (subtroutine TRESTR) 2006-10-26: 1.2-0 fixed a bug in function rmt 2007-03-16: 1.2-1 some amendments in documentation 2008-06-12: 1.3-0 added Fortran code for the bivariate case; improved R coding 2009-01-26: 1.3-2 minor modification to F77 code to avoid GOTO outside IF block 2009-03-21: 1.3-3 romoved check on the R version, at request of the R Core team 2009-11-25: 1.3-4 fixed a bug affecting the case d>2 & df=Inf 2011-01-16: 1.4-0 pd.solve() introduced; argument 'mean' can now be a matrix 2011-04-06: 1.4-1 fixed documentation, coding of dmnorm & dmt is straightened, log.det in pd.solve() provided only on request 2011-04-28: 1.4-2 fixed bug of biv.not.prob if some (lower=-Inf & upper=Inf) 2011-05-03: 1.4-3 fixed bug as above for sadmvn and sadmvt 2012-01-06: 1.4-5 NAMESPACE introduced on request from R Core Team 2013-12-04: 1.4-7 .First.lib() removed on request from CRAN, other minor fixes 2014-06-25: 1.5-0 improved coding of dmnorm and dmt functions, allow calling pmnorm and pmt with a matrix argument 2014-06-30: 1.5-1 fixes a minor bug of version 1.5-0 mnormt/man/0000755000176200001440000000000013615601355012346 5ustar liggesusersmnormt/man/dmnorm.Rd0000644000176200001440000001507112714114522014127 0ustar liggesusers\name{dmnorm} \alias{dmnorm} \alias{pmnorm} \alias{rmnorm} \alias{sadmvn} \title{Multivariate normal distribution} \description{ The probability density function, the distribution function and random number generation for the multivariate normal (Gaussian) distribution } \usage{ dmnorm(x, mean = rep(0, d), varcov, log = FALSE) pmnorm(x, mean = rep(0, d), varcov, ...) rmnorm(n = 1, mean = rep(0, d), varcov, sqrt=NULL) sadmvn(lower, upper, mean, varcov, maxpts = 2000*d, abseps = 1e-06, releps = 0) } \arguments{ \item{x}{either a vector of length \code{d} or a matrix with \code{d} columns, where \code{d=ncol(varcov)}, representing the coordinates of the point(s) where the density must be evaluated; for \code{pmnorm}, \code{d} cannot exceed \code{20}.} \item{mean}{either a vector of length \code{d}, representing the mean value, or (except for \code{rmnorm}) a matrix whose rows represent different mean vectors; in the matrix case, only allowed for \code{dmnorm} and \code{pmnorm}, its dimensions must match those of \code{x}.} \item{varcov}{a symmetric positive-definite matrix representing the variance-covariance matrix of the distribution; a vector of length 1 is also allowed (in this case, \code{d=1} is set).} \item{sqrt}{if not \code{NULL} (default value is \code{NULL}), a square root of the intended \code{varcov} matrix; see \sQuote{Details} for a full description.} \item{log}{a logical value (default value is \code{FALSE}); if \code{TRUE}, the logarithm of the density is computed.} \item{...}{parameters passed to \code{sadmvn}, among \code{maxpts}, \code{abseps}, \code{releps}.} \item{n}{the number of random vectors to be generated.} \item{lower}{a numeric vector of lower integration limits of the density function; must be of maximal length \code{20}; \code{+Inf} and \code{-Inf} entries are allowed.} \item{upper}{ a numeric vector of upper integration limits of the density function; must be of maximal length \code{20}; \code{+Inf} and \code{-Inf} entries are allowed.} \item{maxpts}{the maximum number of function evaluations (default value: \code{2000*d}).} \item{abseps}{absolute error tolerance (default value: \code{1e-6}).} \item{releps}{relative error tolerance (default value: \code{0}).} } \details{ The function \code{pmnorm} works by making a suitable call to \code{sadmvn} if \code{d>2}, or to \code{biv.nt.prob} if \code{d=2}, or to \code{pnorm} if \code{d=1}. Function \code{sadmvn} is an interface to a Fortran-77 routine with the same name written by Alan Genz, available from his web page, which works using an adaptive integration method. This Fortran-77 routine makes uses of some auxiliary functions whose authors are documented in the code. If \code{sqrt=NULL} (default value), the working of \code{rmnorm} involves computation of a square root of \code{varcov} via the Cholesky decomposition. If a non-\code{NULL} value of \code{sqrt} is supplied, it is assumed that it represents a matrix, \eqn{R} say, such that \eqn{R' R} represents the required variance-covariance matrix of the distribution; in this case, the argument \code{varcov} is ignored. This mechanism is intended primarily for use in a sequence of calls to \code{rmnorm}, all sampling from a distribution with fixed variance matrix; a suitable matrix \code{sqrt} can then be computed only once beforehand, avoiding that the same operation is repeated multiple times along the sequence of calls; see the examples below. Another use of \code{sqrt} is to supply a different form of square root of the variance-covariance matrix, in place of the Cholesky factor. For efficiency reasons, \code{rmnorm} does not perform checks on the supplied arguments. If, after setting the same seed value to \code{\link[base:Random]{set.seed}}, two calls to \code{rmnorm} are made with the same arguments except that one generates \code{n1} vectors and the other \code{n2} vectors, with \code{n12}, if \code{d} denotes the number of dimensions. } \section{Licence}{ This package and its documentation are usable under the terms of the \dQuote{GNU General Public License} version 3 or version 2, as you prefer; a copy of them is available from \url{https://www.R-project.org/Licenses/}.} \author{ Adelchi Azzalini (R code and package creation) and Alan Genz (Fortran code, see references below; this incorporates routines of other authors) } \references{ Genz, A. (1992). Numerical Computation of Multivariate Normal Probabilities. \emph{J. Computational and Graphical Statist.}, \bold{1}, 141-149. Genz, A. (1993). Comparison of methods for the computation of multivariate normal probabilities. \emph{Computing Science and Statistics}, \bold{25}, 400-405. Genz, A.: Fortran code available at \url{http://www.math.wsu.edu/math/faculty/genz/software/fort77/mvn.f} } \keyword{package} \keyword{distribution} \keyword{multivariate} mnormt/man/pd.solve.Rd0000644000176200001440000000253312666762020014374 0ustar liggesusers\name{pd.solve} \alias{pd.solve} \title{Inverse of a symmetric positive-definite matrix} \description{ The inverse of a symmetric positive-definite matrix and its log-determinant } \usage{ pd.solve(x, silent = FALSE, log.det=FALSE) } \arguments{ \item{x}{a symmetric positive-definite matrix.} \item{silent}{a logical value which indicates the action to take in case of an error. If \code{silent==TRUE} and an error occurs, the function silently returns a \code{NULL} value; if \code{silent==FALSE} (default), an error generates a \code{stop} with an error message.} \item{log.det}{ a logical value to indicate whether the log-determinant of \code{x} is required (default is \code{FALSE}).} } \value{ the inverse matrix of \code{x}; if \code{log.det=TRUE}, this inverse has an attribute which contains the logarithm of the determinant of \code{x}. } \details{The function checks that \code{x} is a symmetric positive-definite matrix. If an error is detected, an action is taken which depends on the value of the argument \code{silent}. } \author{Adelchi Azzalini} \examples{ x <- toeplitz(rev(1:4)) x.inv <- pd.solve(x) print(x.inv \%*\% x) x.inv <- pd.solve(x, log.det=TRUE) logDet <- attr(x.inv, "log.det") print(abs(logDet - determinant(x, logarithm=TRUE)$modulus)) } \keyword{algebra} \keyword{array} mnormt/man/dmt.Rd0000644000176200001440000001510112714651310013412 0ustar liggesusers\name{dmt} \alias{dmt} \alias{pmt} \alias{rmt} \alias{sadmvt} \alias{biv.nt.prob} \title{Multivariate \emph{t} distribution} \description{ The probability density function, the distribution function and random number generation for the multivariate Student's \emph{t} distribution } \usage{ dmt(x, mean = rep(0, d), S, df=Inf, log = FALSE) pmt(x, mean = rep(0, d), S, df=Inf, ...) rmt(n = 1, mean = rep(0, d), S, df=Inf, sqrt=NULL) sadmvt(df, lower, upper, mean, S, maxpts = 2000*d, abseps = 1e-06, releps = 0) biv.nt.prob(df, lower, upper, mean, S) } \arguments{ \item{x}{ either a vector of length \code{d} or a matrix with \code{d} columns, where \code{d=ncol(S)}, giving the coordinates of the point(s) where the density must be evaluated; for \code{pmt}, \code{d} cannot exceed \code{20}.} \item{mean}{either a vector of length \code{d}, representing the location parameter (equal to the mean vector when \code{df>1}) or a matrix whose rows represent different mean vectors (except for \code{rmt}); in the matrix case, its dimensions must match those of \code{x}.} \item{S}{a symmetric positive-definite matrix representing the scale matrix of the distribution, such that \code{S*df/(df-2)} is the variance-covariance matrix when \code{df>2}; a vector of length \code{1} is also allowed (in this case, \code{d=1} is set).} \item{df}{degrees of freedom; it must be a positive integer for \code{pmt}, \code{sadmvt} and \code{biv.nt.prob}, otherwise a positive number. If \code{df=Inf} (default value), the corresponding \code{*mnorm} function is called, unless \code{d=2}; in this case \code{biv.nt.prob} is used. If \code{biv.nt.prob} is called with \code{df=Inf}, it returns the probability of a rectangle assigned by a bivariate normal distribution.} \item{log}{a logical value(default value is \code{FALSE}); if \code{TRUE}, the logarithm of the density is computed.} \item{sqrt}{if not \code{NULL} (default value is \code{NULL}), a square root of the intended scale matrix \code{S}; see \sQuote{Details} for a full description.} \item{...}{parameters passed to \code{sadmvt}, among \code{maxpts}, \code{absrel}, \code{releps}.} \item{n}{the number of random vectors to be generated} \item{lower}{a numeric vector of lower integration limits of the density function; must be of maximal length \code{20}; \code{+Inf} and \code{-Inf} entries are allowed.} \item{upper}{ a numeric vector of upper integration limits of the density function; must be of maximal length \code{20}; \code{+Inf} and \code{-Inf} entries are allowed } \item{maxpts}{the maximum number of function evaluations (default value: \code{2000*d})} \item{abseps}{absolute error tolerance (default value: \code{1e-6}).} \item{releps}{relative error tolerance (default value: \code{0}).} } \details{ The functions \code{sadmvt} and \code{biv.nt.prob} are interfaces to Fortran-77 routines by Alan Genz, and available from his web page; they makes uses of some auxiliary functions whose authors are documented in the Fortran code. The routine \code{sadmvt} uses an adaptive integration method. The routine \code{biv.nt.prob} is specific for the bivariate case; if \code{df<1} or \code{df=Inf}, it computes the bivariate normal distribution function using a non-iterative method described in a reference given below. If \code{pmt} is called with \code{d>2}, this is converted into a suitable call to \code{sadmvt}; if \code{d=2}, a call to \code{biv.nt.prob} is used; if \code{d=1}, then \code{pt} is used. If \code{sqrt=NULL} (default value), the working of \code{rmt} involves computation of a square root of \code{S} via the Cholesky decomposition. If a non-\code{NULL} value of \code{sqrt} is supplied, it is assumed that it represents a square root of the scale matrix, otherwise represented by \code{S}, whose value is ignored in this case. This mechanism is intended primarily for use in a sequence of calls to \code{rmt}, all sampling from a distribution with fixed scale matrix; a suitable matrix \code{sqrt} can then be computed only once beforehand, avoiding that the same operation is repeated multiple times along the sequence of calls. For examples of use of this argument, see those in the documentation of \code{\link{rmnorm}}. Another use of \code{sqrt} is to supply a different form of square root of the scale matrix, in place of the Cholesky factor. For efficiency reasons, \code{rmt} does not perform checks on the supplied arguments. } \value{ \code{dmt} returns a vector of density values (possibly log-transformed); \code{pmt} and \code{sadmvt} return a single probability with attributes giving details on the achieved accuracy, provided \code{x} of \code{pmnorm} is a vector; \code{rmt} returns a matrix of \code{n} rows of random vectors } \references{ Genz, A.: Fortran code in files \code{mvt.f} and \code{mvtdstpack.f} available at \url{http://www.math.wsu.edu/math/faculty/genz/software/} Dunnett, C.W. and Sobel, M. (1954). A bivariate generalization of Student's \emph{t}-distribution with tables for certain special cases. \emph{Biometrika} 41, 153--169. } \author{ Fortran code of \code{SADMVT} and most auxiliary functions by Alan Genz, some additional auxiliary functions by people referred to within his program; interface to \R and additional \R code by Adelchi Azzalini.} \note{ The attributes \code{error} and \code{status} of the probability returned by \code{sadmvt} and by \code{pmt} (the latter only if \code{x} is a vector and \code{d>2}) indicate whether the function had a normal termination, achieving the required accuracy. If this is not the case, re-run the function with a higher value of \code{maxpts}. } \seealso{\code{\link[stats:TDist]{dt}}, \code{\link{rmnorm}} for use of argument \code{sqrt}} \examples{ x <- seq(-2,4,length=21) y <- 2*x+10 z <- x+cos(y) mu <- c(1,12,2) Sigma <- matrix(c(1,2,0,2,5,0.5,0,0.5,3), 3, 3) df <- 4 f <- dmt(cbind(x,y,z), mu, Sigma,df) p1 <- pmt(c(2,11,3), mu, Sigma, df) p2 <- pmt(c(2,11,3), mu, Sigma, df, maxpts=10000, abseps=1e-8) x <- rmt(10, mu, Sigma, df) p <- sadmvt(df, lower=c(2,11,3), upper=rep(Inf,3), mu, Sigma) # upper tail # p0 <- pmt(c(2,11), mu[1:2], Sigma[1:2,1:2], df=5) p1 <- biv.nt.prob(5, lower=rep(-Inf,2), upper=c(2, 11), mu[1:2], Sigma[1:2,1:2]) p2 <- sadmvt(5, lower=rep(-Inf,2), upper=c(2, 11), mu[1:2], Sigma[1:2,1:2]) c(p0, p1, p2, p0-p1, p0-p2) } \keyword{distribution} \keyword{multivariate} mnormt/DESCRIPTION0000644000176200001440000000151613615767442013316 0ustar liggesusersPackage: mnormt Version: 1.5-6 Date: 2020-02-02 Title: The Multivariate Normal and t Distributions Author: Fortran code by Alan Genz and other people referred to in the code, R code by Adelchi Azzalini Maintainer: Adelchi Azzalini Depends: R (>= 2.2.0) Description: Functions are provided for computing the density and the distribution function of multivariate normal and "t" random variables, and for generating random vectors sampled from these distributions. Probabilities are computed via non-Monte Carlo methods; different routines are used in the case d=1, d=2, d>2, if d denotes the number of dimensions. License: GPL-2 | GPL-3 URL: http://azzalini.stat.unipd.it/SW/Pkg-mnormt NeedsCompilation: yes Packaged: 2020-02-02 17:21:41 UTC; aa Repository: CRAN Date/Publication: 2020-02-03 10:00:02 UTC mnormt/src/0000755000176200001440000000000013615601356012363 5ustar liggesusersmnormt/src/biv-nt.f0000644000176200001440000004364413572504542013745 0ustar liggesusers* Selected portion of code taken from: * http://www.math.wsu.edu/faculty/genz/software/mvtdstpack.f * to compute bivariate normal and Student's t distribution functions. * * Author: * Alan Genz * Department of Mathematics * Washington State University * Pullman, WA 99164-3113 * Email : alangenz@wsu.edu * * except for some auxiliary functions whose authors are indicated * in the respective code below. * * In addition the dummy subroutine below has been added, needed to interface * R and Fortran. Adelchi Azzalini, 2008-12-06 SUBROUTINE SMVBVT(PROB, NU, LOWER, UPPER, INFIN, CORREL) DOUBLE PRECISION PROB, LOWER(*), UPPER(*), CORREL, MVBVT INTEGER NU, INFIN(*) PROB = MVBVT(NU, LOWER, UPPER, INFIN, CORREL) RETURN END ************************************************************************ * DOUBLE PRECISION FUNCTION MVBVN( LOWER, UPPER, INFIN, CORREL ) * * A function for computing bivariate normal probabilities. * * Parameters * * LOWER REAL, array of lower integration limits. * UPPER REAL, array of upper integration limits. * INFIN INTEGER, array of integration limits flags: * if INFIN(I) = 0, Ith limits are (-infinity, UPPER(I)]; * if INFIN(I) = 1, Ith limits are [LOWER(I), infinity); * if INFIN(I) = 2, Ith limits are [LOWER(I), UPPER(I)]. * CORREL REAL, correlation coefficient. * DOUBLE PRECISION LOWER(*), UPPER(*), CORREL, MVBVU INTEGER INFIN(*) IF ( INFIN(1) .EQ. 2 .AND. INFIN(2) .EQ. 2 ) THEN MVBVN = MVBVU ( LOWER(1), LOWER(2), CORREL ) + - MVBVU ( UPPER(1), LOWER(2), CORREL ) + - MVBVU ( LOWER(1), UPPER(2), CORREL ) + + MVBVU ( UPPER(1), UPPER(2), CORREL ) ELSE IF ( INFIN(1) .EQ. 2 .AND. INFIN(2) .EQ. 1 ) THEN MVBVN = MVBVU ( LOWER(1), LOWER(2), CORREL ) + - MVBVU ( UPPER(1), LOWER(2), CORREL ) ELSE IF ( INFIN(1) .EQ. 1 .AND. INFIN(2) .EQ. 2 ) THEN MVBVN = MVBVU ( LOWER(1), LOWER(2), CORREL ) + - MVBVU ( LOWER(1), UPPER(2), CORREL ) ELSE IF ( INFIN(1) .EQ. 2 .AND. INFIN(2) .EQ. 0 ) THEN MVBVN = MVBVU ( -UPPER(1), -UPPER(2), CORREL ) + - MVBVU ( -LOWER(1), -UPPER(2), CORREL ) ELSE IF ( INFIN(1) .EQ. 0 .AND. INFIN(2) .EQ. 2 ) THEN MVBVN = MVBVU ( -UPPER(1), -UPPER(2), CORREL ) + - MVBVU ( -UPPER(1), -LOWER(2), CORREL ) ELSE IF ( INFIN(1) .EQ. 1 .AND. INFIN(2) .EQ. 0 ) THEN MVBVN = MVBVU ( LOWER(1), -UPPER(2), -CORREL ) ELSE IF ( INFIN(1) .EQ. 0 .AND. INFIN(2) .EQ. 1 ) THEN MVBVN = MVBVU ( -UPPER(1), LOWER(2), -CORREL ) ELSE IF ( INFIN(1) .EQ. 1 .AND. INFIN(2) .EQ. 1 ) THEN MVBVN = MVBVU ( LOWER(1), LOWER(2), CORREL ) ELSE IF ( INFIN(1) .EQ. 0 .AND. INFIN(2) .EQ. 0 ) THEN MVBVN = MVBVU ( -UPPER(1), -UPPER(2), CORREL ) ELSE MVBVN = 1 END IF END DOUBLE PRECISION FUNCTION MVBVU( SH, SK, R ) * * A function for computing bivariate normal probabilities; * developed using * Drezner, Z. and Wesolowsky, G. O. (1989), * On the Computation of the Bivariate Normal Integral, * J. Stat. Comput. Simul.. 35 pp. 101-107. * with extensive modications for double precisions by * Alan Genz and Yihong Ge * Department of Mathematics * Washington State University * Pullman, WA 99164-3113 * Email : alangenz@wsu.edu * * BVN - calculate the probability that X is larger than SH and Y is * larger than SK. * * Parameters * * SH REAL, integration limit * SK REAL, integration limit * R REAL, correlation coefficient * LG INTEGER, number of Gauss Rule Points and Weights * DOUBLE PRECISION BVN, SH, SK, R, ZERO, TWOPI INTEGER I, LG, NG PARAMETER ( ZERO = 0, TWOPI = 6.283185307179586D0 ) DOUBLE PRECISION X(10,3), W(10,3), AS, A, B, C, D, RS, XS DOUBLE PRECISION MVPHI, SN, ASR, H, K, BS, HS, HK SAVE X, W * Gauss Legendre Points and Weights, N = 6 DATA ( W(I,1), X(I,1), I = 1, 3 ) / * 0.1713244923791705D+00,-0.9324695142031522D+00, * 0.3607615730481384D+00,-0.6612093864662647D+00, * 0.4679139345726904D+00,-0.2386191860831970D+00/ * Gauss Legendre Points and Weights, N = 12 DATA ( W(I,2), X(I,2), I = 1, 6 ) / * 0.4717533638651177D-01,-0.9815606342467191D+00, * 0.1069393259953183D+00,-0.9041172563704750D+00, * 0.1600783285433464D+00,-0.7699026741943050D+00, * 0.2031674267230659D+00,-0.5873179542866171D+00, * 0.2334925365383547D+00,-0.3678314989981802D+00, * 0.2491470458134029D+00,-0.1252334085114692D+00/ * Gauss Legendre Points and Weights, N = 20 DATA ( W(I,3), X(I,3), I = 1, 10 ) / * 0.1761400713915212D-01,-0.9931285991850949D+00, * 0.4060142980038694D-01,-0.9639719272779138D+00, * 0.6267204833410906D-01,-0.9122344282513259D+00, * 0.8327674157670475D-01,-0.8391169718222188D+00, * 0.1019301198172404D+00,-0.7463319064601508D+00, * 0.1181945319615184D+00,-0.6360536807265150D+00, * 0.1316886384491766D+00,-0.5108670019508271D+00, * 0.1420961093183821D+00,-0.3737060887154196D+00, * 0.1491729864726037D+00,-0.2277858511416451D+00, * 0.1527533871307259D+00,-0.7652652113349733D-01/ IF ( ABS(R) .LT. 0.3 ) THEN NG = 1 LG = 3 ELSE IF ( ABS(R) .LT. 0.75 ) THEN NG = 2 LG = 6 ELSE NG = 3 LG = 10 ENDIF H = SH K = SK HK = H*K BVN = 0 IF ( ABS(R) .LT. 0.925 ) THEN HS = ( H*H + K*K )/2 ASR = ASIN(R) DO I = 1, LG SN = SIN(ASR*( X(I,NG)+1 )/2) BVN = BVN + W(I,NG)*EXP( ( SN*HK - HS )/( 1 - SN*SN ) ) SN = SIN(ASR*(-X(I,NG)+1 )/2) BVN = BVN + W(I,NG)*EXP( ( SN*HK - HS )/( 1 - SN*SN ) ) END DO BVN = BVN*ASR/(2*TWOPI) + MVPHI(-H)*MVPHI(-K) ELSE IF ( R .LT. 0 ) THEN K = -K HK = -HK ENDIF IF ( ABS(R) .LT. 1 ) THEN AS = ( 1 - R )*( 1 + R ) A = SQRT(AS) BS = ( H - K )**2 C = ( 4 - HK )/8 D = ( 12 - HK )/16 BVN = A*EXP( -(BS/AS + HK)/2 ) + *( 1 - C*(BS - AS)*(1 - D*BS/5)/3 + C*D*AS*AS/5 ) IF ( HK .GT. -160 ) THEN B = SQRT(BS) BVN = BVN - EXP(-HK/2)*SQRT(TWOPI)*MVPHI(-B/A)*B + *( 1 - C*BS*( 1 - D*BS/5 )/3 ) ENDIF A = A/2 DO I = 1, LG XS = ( A*(X(I,NG)+1) )**2 RS = SQRT( 1 - XS ) BVN = BVN + A*W(I,NG)* + ( EXP( -BS/(2*XS) - HK/(1+RS) )/RS + - EXP( -(BS/XS+HK)/2 )*( 1 + C*XS*( 1 + D*XS ) ) ) XS = AS*(-X(I,NG)+1)**2/4 RS = SQRT( 1 - XS ) BVN = BVN + A*W(I,NG)*EXP( -(BS/XS + HK)/2 ) + *( EXP( -HK*(1-RS)/(2*(1+RS)) )/RS + - ( 1 + C*XS*( 1 + D*XS ) ) ) END DO BVN = -BVN/TWOPI ENDIF IF ( R .GT. 0 ) BVN = BVN + MVPHI( -MAX( H, K ) ) IF ( R .LT. 0 ) BVN = -BVN + MAX( ZERO, MVPHI(-H) - MVPHI(-K) ) ENDIF MVBVU = BVN END * DOUBLE PRECISION FUNCTION MVSTDT( NU, T ) * * Student t Distribution Function * * T * TSTDNT = C I ( 1 + y*y/NU )**( -(NU+1)/2 ) dy * NU -INF * INTEGER NU, J DOUBLE PRECISION MVPHI, T, CSTHE, SNTHE, POLYN, TT, TS, RN, PI PARAMETER ( PI = 3.141592653589793D0 ) IF ( NU .LT. 1 ) THEN MVSTDT = MVPHI( T ) ELSE IF ( NU .EQ. 1 ) THEN MVSTDT = ( 1 + 2*ATAN( T )/PI )/2 ELSE IF ( NU .EQ. 2) THEN MVSTDT = ( 1 + T/SQRT( 2 + T*T ))/2 ELSE TT = T*T CSTHE = NU/( NU + TT ) POLYN = 1 DO J = NU - 2, 2, -2 POLYN = 1 + ( J - 1 )*CSTHE*POLYN/J END DO IF ( MOD( NU, 2 ) .EQ. 1 ) THEN RN = NU TS = T/SQRT(RN) MVSTDT = ( 1 + 2*( ATAN( TS ) + TS*CSTHE*POLYN )/PI )/2 ELSE SNTHE = T/SQRT( NU + TT ) MVSTDT = ( 1 + SNTHE*POLYN )/2 END IF IF ( MVSTDT .LT. 0 ) MVSTDT = 0 ENDIF END * DOUBLE PRECISION FUNCTION MVBVT( NU, LOWER, UPPER, INFIN, CORREL ) * * A function for computing bivariate normal and t probabilities. * * Parameters * * NU INTEGER degrees of freedom parameter; NU < 1 gives normal case. * LOWER REAL, array of lower integration limits. * UPPER REAL, array of upper integration limits. * INFIN INTEGER, array of integration limits flags: * if INFIN(I) = 0, Ith limits are (-infinity, UPPER(I)]; * if INFIN(I) = 1, Ith limits are [LOWER(I), infinity); * if INFIN(I) = 2, Ith limits are [LOWER(I), UPPER(I)]. * CORREL REAL, correlation coefficient. * DOUBLE PRECISION LOWER(*), UPPER(*), CORREL, MVBVN, MVBVTL INTEGER NU, INFIN(*) IF ( NU .LT. 1 ) THEN MVBVT = MVBVN ( LOWER, UPPER, INFIN, CORREL ) ELSE IF ( INFIN(1) .EQ. 2 .AND. INFIN(2) .EQ. 2 ) THEN MVBVT = MVBVTL ( NU, UPPER(1), UPPER(2), CORREL ) + - MVBVTL ( NU, UPPER(1), LOWER(2), CORREL ) + - MVBVTL ( NU, LOWER(1), UPPER(2), CORREL ) + + MVBVTL ( NU, LOWER(1), LOWER(2), CORREL ) ELSE IF ( INFIN(1) .EQ. 2 .AND. INFIN(2) .EQ. 1 ) THEN MVBVT = MVBVTL ( NU, -LOWER(1), -LOWER(2), CORREL ) + - MVBVTL ( NU, -UPPER(1), -LOWER(2), CORREL ) ELSE IF ( INFIN(1) .EQ. 1 .AND. INFIN(2) .EQ. 2 ) THEN MVBVT = MVBVTL ( NU, -LOWER(1), -LOWER(2), CORREL ) + - MVBVTL ( NU, -LOWER(1), -UPPER(2), CORREL ) ELSE IF ( INFIN(1) .EQ. 2 .AND. INFIN(2) .EQ. 0 ) THEN MVBVT = MVBVTL ( NU, UPPER(1), UPPER(2), CORREL ) + - MVBVTL ( NU, LOWER(1), UPPER(2), CORREL ) ELSE IF ( INFIN(1) .EQ. 0 .AND. INFIN(2) .EQ. 2 ) THEN MVBVT = MVBVTL ( NU, UPPER(1), UPPER(2), CORREL ) + - MVBVTL ( NU, UPPER(1), LOWER(2), CORREL ) ELSE IF ( INFIN(1) .EQ. 1 .AND. INFIN(2) .EQ. 0 ) THEN MVBVT = MVBVTL ( NU, -LOWER(1), UPPER(2), -CORREL ) ELSE IF ( INFIN(1) .EQ. 0 .AND. INFIN(2) .EQ. 1 ) THEN MVBVT = MVBVTL ( NU, UPPER(1), -LOWER(2), -CORREL ) ELSE IF ( INFIN(1) .EQ. 1 .AND. INFIN(2) .EQ. 1 ) THEN MVBVT = MVBVTL ( NU, -LOWER(1), -LOWER(2), CORREL ) ELSE IF ( INFIN(1) .EQ. 0 .AND. INFIN(2) .EQ. 0 ) THEN MVBVT = MVBVTL ( NU, UPPER(1), UPPER(2), CORREL ) ELSE MVBVT = 1 END IF END IF END * DOUBLE PRECISION FUNCTION MVBVTC( NU, L, U, INFIN, RHO ) * * A function for computing complementary bivariate normal and t * probabilities. * * Parameters * * NU INTEGER degrees of freedom parameter. * L REAL, array of lower integration limits. * U REAL, array of upper integration limits. * INFIN INTEGER, array of integration limits flags: * if INFIN(1) INFIN(2), then MVBVTC computes * 0 0 P( X>U(1), Y>U(2) ) * 1 0 P( XU(2) ) * 0 1 P( X>U(1), YU(1), Y>U(2) ) + P( XU(2) ) * 2 1 P( X>U(1), YU(1), Y>U(2) ) + P( X>U(1), YU(2) ) + P( XU(1), YU(1), Y>U(2) ) + P( XU(2) ) * * RHO REAL, correlation coefficient. * DOUBLE PRECISION L(*), U(*), LW(2), UP(2), B, RHO, MVBVT INTEGER I, NU, INFIN(*), INF(2) * DO I = 1, 2 IF ( MOD( INFIN(I), 2 ) .EQ. 0 ) THEN INF(I) = 1 LW(I) = U(I) ELSE INF(I) = 0 UP(I) = L(I) END IF END DO B = MVBVT( NU, LW, UP, INF, RHO ) DO I = 1, 2 IF ( INFIN(I) .EQ. 2 ) THEN INF(I) = 0 UP(I) = L(I) B = B + MVBVT( NU, LW, UP, INF, RHO ) END IF END DO IF ( INFIN(1) .EQ. 2 .AND. INFIN(2) .EQ. 2 ) THEN INF(1) = 1 LW(1) = U(1) B = B + MVBVT( NU, LW, UP, INF, RHO ) END IF MVBVTC = B END * double precision function mvbvtl( nu, dh, dk, r ) * * a function for computing bivariate t probabilities. * * Alan Genz * Department of Mathematics * Washington State University * Pullman, Wa 99164-3113 * Email : alangenz@wsu.edu * * this function is based on the method described by * Dunnett, C.W. and M. Sobel, (1954), * A bivariate generalization of Student's t-distribution * with tables for certain special cases, * Biometrika 41, pp. 153-169. * * mvbvtl - calculate the probability that x < dh and y < dk. * * parameters * * nu number of degrees of freedom * dh 1st lower integration limit * dk 2nd lower integration limit * r correlation coefficient * integer nu, j, hs, ks double precision dh, dk, r double precision tpi, pi, ors, hrk, krh, bvt, snu double precision gmph, gmpk, xnkh, xnhk, qhrk, hkn, hpk, hkrn double precision btnckh, btnchk, btpdkh, btpdhk, one parameter ( pi = 3.14159265358979323844d0, tpi = 2*pi, one = 1 ) snu = sqrt( dble(nu) ) ors = 1 - r*r hrk = dh - r*dk krh = dk - r*dh if ( abs(hrk) + ors .gt. 0 ) then xnhk = hrk**2/( hrk**2 + ors*( nu + dk**2 ) ) xnkh = krh**2/( krh**2 + ors*( nu + dh**2 ) ) else xnhk = 0 xnkh = 0 end if hs = sign( one, dh - r*dk ) ks = sign( one, dk - r*dh ) if ( mod( nu, 2 ) .eq. 0 ) then bvt = atan2( sqrt(ors), -r )/tpi gmph = dh/sqrt( 16*( nu + dh**2 ) ) gmpk = dk/sqrt( 16*( nu + dk**2 ) ) btnckh = 2*atan2( sqrt( xnkh ), sqrt( 1 - xnkh ) )/pi btpdkh = 2*sqrt( xnkh*( 1 - xnkh ) )/pi btnchk = 2*atan2( sqrt( xnhk ), sqrt( 1 - xnhk ) )/pi btpdhk = 2*sqrt( xnhk*( 1 - xnhk ) )/pi do j = 1, nu/2 bvt = bvt + gmph*( 1 + ks*btnckh ) bvt = bvt + gmpk*( 1 + hs*btnchk ) btnckh = btnckh + btpdkh btpdkh = 2*j*btpdkh*( 1 - xnkh )/( 2*j + 1 ) btnchk = btnchk + btpdhk btpdhk = 2*j*btpdhk*( 1 - xnhk )/( 2*j + 1 ) gmph = gmph*( 2*j - 1 )/( 2*j*( 1 + dh**2/nu ) ) gmpk = gmpk*( 2*j - 1 )/( 2*j*( 1 + dk**2/nu ) ) end do else qhrk = sqrt( dh**2 + dk**2 - 2*r*dh*dk + nu*ors ) hkrn = dh*dk + r*nu hkn = dh*dk - nu hpk = dh + dk bvt = atan2(-snu*(hkn*qhrk+hpk*hkrn),hkn*hkrn-nu*hpk*qhrk)/tpi if ( bvt .lt. -1d-15 ) bvt = bvt + 1 gmph = dh/( tpi*snu*( 1 + dh**2/nu ) ) gmpk = dk/( tpi*snu*( 1 + dk**2/nu ) ) btnckh = sqrt( xnkh ) btpdkh = btnckh btnchk = sqrt( xnhk ) btpdhk = btnchk do j = 1, ( nu - 1 )/2 bvt = bvt + gmph*( 1 + ks*btnckh ) bvt = bvt + gmpk*( 1 + hs*btnchk ) btpdkh = ( 2*j - 1 )*btpdkh*( 1 - xnkh )/( 2*j ) btnckh = btnckh + btpdkh btpdhk = ( 2*j - 1 )*btpdhk*( 1 - xnhk )/( 2*j ) btnchk = btnchk + btpdhk gmph = 2*j*gmph/( ( 2*j + 1 )*( 1 + dh**2/nu ) ) gmpk = 2*j*gmpk/( ( 2*j + 1 )*( 1 + dk**2/nu ) ) end do end if mvbvtl = bvt * * end mvbvtl * end * * DOUBLE PRECISION FUNCTION MVPHI(Z) * * Normal distribution probabilities accurate to 1d-15. * Reference: J.L. Schonfelder, Math Comp 32(1978), pp 1232-1240. * INTEGER I, IM DOUBLE PRECISION A(0:43), BM, B, BP, P, RTWO, T, XA, Z PARAMETER( RTWO = 1.414213562373095048801688724209D0, IM = 24 ) SAVE A DATA ( A(I), I = 0, 43 )/ & 6.10143081923200417926465815756D-1, & -4.34841272712577471828182820888D-1, & 1.76351193643605501125840298123D-1, & -6.0710795609249414860051215825D-2, & 1.7712068995694114486147141191D-2, & -4.321119385567293818599864968D-3, & 8.54216676887098678819832055D-4, & -1.27155090609162742628893940D-4, & 1.1248167243671189468847072D-5, 3.13063885421820972630152D-7, & -2.70988068537762022009086D-7, 3.0737622701407688440959D-8, & 2.515620384817622937314D-9, -1.028929921320319127590D-9, & 2.9944052119949939363D-11, 2.6051789687266936290D-11, & -2.634839924171969386D-12, -6.43404509890636443D-13, & 1.12457401801663447D-13, 1.7281533389986098D-14, & -4.264101694942375D-15, -5.45371977880191D-16, & 1.58697607761671D-16, 2.0899837844334D-17, & -5.900526869409D-18, -9.41893387554D-19, 2.14977356470D-19, & 4.6660985008D-20, -7.243011862D-21, -2.387966824D-21, & 1.91177535D-22, 1.20482568D-22, -6.72377D-25, -5.747997D-24, & -4.28493D-25, 2.44856D-25, 4.3793D-26, -8.151D-27, -3.089D-27, & 9.3D-29, 1.74D-28, 1.6D-29, -8.0D-30, -2.0D-30 / * XA = ABS(Z)/RTWO IF ( XA .GT. 100 ) THEN P = 0 ELSE T = ( 8*XA - 30 ) / ( 4*XA + 15 ) BM = 0 B = 0 DO I = IM, 0, -1 BP = B B = BM BM = T*B - BP + A(I) END DO P = EXP( -XA*XA )*( BM - BP )/4 END IF IF ( Z .GT. 0 ) P = 1 - P MVPHI = P END * mnormt/src/sadmvnt.f0000644000176200001440000017104713615562005014215 0ustar liggesusers* Selected portions of code taken from: * http://www.math.wsu.edu/math/faculty/genz/software/mvn.f * http://www.math.wsu.edu/math/faculty/genz/software/mvt.f * with a few minor modifications (search for 'AA' to find them) * * Author: * Alan Genz * Department of Mathematics * Washington State University * Pullman, WA 99164-3113 * Email : alangenz@wsu.edu * except for some auxiliary functions whose authors are indicated * in the respective code below. *----------------------------------------------------------------------- SUBROUTINE SADMVN( N, LOWER, UPPER, INFIN, CORREL, MAXPTS, & ABSEPS, RELEPS, ERROR, VALUE, INFORM ) * * A subroutine for computing multivariate normal probabilities. * This subroutine uses an algorithm given in the paper * "Numerical Computation of Multivariate Normal Probabilities", in * J. of Computational and Graphical Stat., 1(1992), pp. 141-149, by * Alan Genz * Department of Mathematics * Washington State University * Pullman, WA 99164-3113 * Email : alangenz@wsu.edu * * Parameters * * N INTEGER, the number of variables. * LOWER REAL, array of lower integration limits. * UPPER REAL, array of upper integration limits. * INFIN INTEGER, array of integration limits flags: * if INFIN(I) < 0, Ith limits are (-infinity, infinity); * if INFIN(I) = 0, Ith limits are (-infinity, UPPER(I)]; * if INFIN(I) = 1, Ith limits are [LOWER(I), infinity); * if INFIN(I) = 2, Ith limits are [LOWER(I), UPPER(I)]. * CORREL REAL, array of correlation coefficients; the correlation * coefficient in row I column J of the correlation matrix * should be stored in CORREL( J + ((I-2)*(I-1))/2 ), for J < I. * MAXPTS INTEGER, maximum number of function values allowed. This * parameter can be used to limit the time taken. A * sensible strategy is to start with MAXPTS = 1000*N, and then * increase MAXPTS if ERROR is too large. * ABSEPS REAL absolute error tolerance. * RELEPS REAL relative error tolerance. * ERROR REAL estimated absolute error, with 99% confidence level. * VALUE REAL estimated value for the integral * INFORM INTEGER, termination status parameter: * if INFORM = 0, normal completion with ERROR < EPS; * if INFORM = 1, completion with ERROR > EPS and MAXPTS * function vaules used; increase MAXPTS to * decrease ERROR; * if INFORM = 2, N > 20 or N < 1. * EXTERNAL MVNFNC INTEGER N, NL, M, INFIN(*), LENWRK, MAXPTS, INFORM, INFIS, & RULCLS, TOTCLS, NEWCLS, MAXCLS DOUBLE PRECISION & CORREL(*), LOWER(*), UPPER(*), ABSEPS, RELEPS, ERROR, VALUE, & OLDVAL, D, E, MVNNIT, MVNFNC PARAMETER ( NL = 20 ) PARAMETER ( LENWRK = 20*NL**2 ) DOUBLE PRECISION WORK(LENWRK) * * [AA (2014-06-25)] next DO loop initializes WORK array, * un-initialized in original code which caused complaints of some compilers * DO I = 1,LENWRK WORK(I) = 0.0D0 ENDDO IF ( N .GT. 20 .OR. N .LT. 1 ) THEN INFORM = 2 VALUE = 0 ERROR = 1 RETURN ENDIF INFORM = MVNNIT( N, CORREL, LOWER, UPPER, INFIN, INFIS, D, E ) M = N - INFIS IF ( M .EQ. 0 ) THEN VALUE = 1 ERROR = 0 ELSE IF ( M .EQ. 1 ) THEN VALUE = E - D ERROR = 2E-16 ELSE * * Call the subregion adaptive integration subroutine * M = M - 1 RULCLS = 1 CALL ADAPT( M, RULCLS, 0, MVNFNC, ABSEPS, RELEPS, & LENWRK, WORK, ERROR, VALUE, INFORM ) MAXCLS = MIN( 10*RULCLS, MAXPTS ) TOTCLS = 0 CALL ADAPT(M, TOTCLS, MAXCLS, MVNFNC, ABSEPS, RELEPS, & LENWRK, WORK, ERROR, VALUE, INFORM) IF ( ERROR .GT. MAX( ABSEPS, RELEPS*ABS(VALUE) ) ) THEN 10 OLDVAL = VALUE MAXCLS = MAX( 2*RULCLS, MIN( 3*MAXCLS/2, MAXPTS - TOTCLS ) ) NEWCLS = -1 CALL ADAPT(M, NEWCLS, MAXCLS, MVNFNC, ABSEPS, RELEPS, & LENWRK, WORK, ERROR, VALUE, INFORM) TOTCLS = TOTCLS + NEWCLS ERROR = ABS(VALUE-OLDVAL) + SQRT(RULCLS*ERROR**2/TOTCLS) IF ( ERROR .GT. MAX( ABSEPS, RELEPS*ABS(VALUE) ) ) THEN IF ( MAXPTS - TOTCLS .GT. 2*RULCLS ) GO TO 10 ELSE INFORM = 0 END IF ENDIF ENDIF END *-------------------------------------------------------------------------- * SUBROUTINE ADAPT(NDIM, MINCLS, MAXCLS, FUNCTN, & ABSREQ, RELREQ, LENWRK, WORK, ABSEST, FINEST, INFORM) * * Adaptive Multidimensional Integration Subroutine * * Author: Alan Genz * Department of Mathematics * Washington State University * Pullman, WA 99164-3113 USA * * This subroutine computes an approximation to the integral * * 1 1 1 * I I ... I FUNCTN(NDIM,X) dx(NDIM)...dx(2)dx(1) * 0 0 0 * *************** Parameters for ADAPT ******************************** * ****** Input Parameters * * NDIM Integer number of integration variables. * MINCLS Integer minimum number of FUNCTN calls to be allowed; MINCLS * must not exceed MAXCLS. If MINCLS < 0, then ADAPT assumes * that a previous call of ADAPT has been made with the same * integrand and continues that calculation. * MAXCLS Integer maximum number of FUNCTN calls to be used; MAXCLS * must be >= RULCLS, the number of function calls required for * one application of the basic integration rule. * IF ( NDIM .EQ. 1 ) THEN * RULCLS = 11 * ELSE IF ( NDIM .LT. 15 ) THEN * RULCLS = 2**NDIM + 2*NDIM*(NDIM+3) + 1 * ELSE * RULCLS = 1 + NDIM*(24-NDIM*(6-NDIM*4))/3 * ENDIF * FUNCTN Externally declared real user defined integrand. Its * parameters must be (NDIM, Z), where Z is a real array of * length NDIM. * ABSREQ Real required absolute accuracy. * RELREQ Real required relative accuracy. * LENWRK Integer length of real array WORK (working storage); ADAPT * needs LENWRK >= 16*NDIM + 27. For maximum efficiency LENWRK * should be about 2*NDIM*MAXCLS/RULCLS if MAXCLS FUNCTN * calls are needed. If LENWRK is significantly less than this, * ADAPT may be less efficient. * ****** Output Parameters * * MINCLS Actual number of FUNCTN calls used by ADAPT. * WORK Real array (length LENWRK) of working storage. This contains * information that is needed for additional calls of ADAPT * using the same integrand (input MINCLS < 0). * ABSEST Real estimated absolute accuracy. * FINEST Real estimated value of integral. * INFORM INFORM = 0 for normal exit, when ABSEST <= ABSREQ or * ABSEST <= |FINEST|*RELREQ with MINCLS <= MAXCLS. * INFORM = 1 if MAXCLS was too small for ADAPT to obtain the * result FINEST to within the requested accuracy. * INFORM = 2 if MINCLS > MAXCLS, LENWRK < 16*NDIM + 27 or * RULCLS > MAXCLS. * ************************************************************************ * * Begin driver routine. This routine partitions the working storage * array and then calls the main subroutine ADBASE. * EXTERNAL FUNCTN INTEGER NDIM, MINCLS, MAXCLS, LENWRK, INFORM DOUBLE PRECISION & FUNCTN, ABSREQ, RELREQ, WORK(LENWRK), ABSEST, FINEST INTEGER SBRGNS, MXRGNS, RULCLS, LENRUL, & INERRS, INVALS, INPTRS, INLWRS, INUPRS, INMSHS, INPNTS, INWGTS, & INLOWR, INUPPR, INWDTH, INMESH, INWORK IF ( NDIM .EQ. 1 ) THEN LENRUL = 5 RULCLS = 9 ELSE IF ( NDIM .LT. 12 ) THEN LENRUL = 6 RULCLS = 2**NDIM + 2*NDIM*(NDIM+2) + 1 ELSE LENRUL = 6 RULCLS = 1 + 2*NDIM*(1+2*NDIM) ENDIF IF ( LENWRK .GE. LENRUL*(NDIM+4) + 10*NDIM + 3 .AND. & RULCLS. LE. MAXCLS .AND. MINCLS .LE. MAXCLS ) THEN MXRGNS = ( LENWRK - LENRUL*(NDIM+4) - 7*NDIM )/( 3*NDIM + 3 ) INERRS = 1 INVALS = INERRS + MXRGNS INPTRS = INVALS + MXRGNS INLWRS = INPTRS + MXRGNS INUPRS = INLWRS + MXRGNS*NDIM INMSHS = INUPRS + MXRGNS*NDIM INWGTS = INMSHS + MXRGNS*NDIM INPNTS = INWGTS + LENRUL*4 INLOWR = INPNTS + LENRUL*NDIM INUPPR = INLOWR + NDIM INWDTH = INUPPR + NDIM INMESH = INWDTH + NDIM INWORK = INMESH + NDIM IF ( MINCLS .LT. 0 ) SBRGNS = WORK(LENWRK) CALL ADBASE(NDIM, MINCLS, MAXCLS, FUNCTN, ABSREQ, RELREQ, & ABSEST, FINEST, SBRGNS, MXRGNS, RULCLS, LENRUL, & WORK(INERRS), WORK(INVALS), WORK(INPTRS), WORK(INLWRS), & WORK(INUPRS), WORK(INMSHS), WORK(INWGTS), WORK(INPNTS), & WORK(INLOWR), WORK(INUPPR), WORK(INWDTH), WORK(INMESH), & WORK(INWORK), INFORM) WORK(LENWRK) = SBRGNS ELSE INFORM = 2 MINCLS = RULCLS ENDIF END * SUBROUTINE ADBASE(NDIM, MINCLS, MAXCLS, FUNCTN, ABSREQ, RELREQ, & ABSEST, FINEST, SBRGNS, MXRGNS, RULCLS, LENRUL, & ERRORS, VALUES, PONTRS, LOWERS, & UPPERS, MESHES, WEGHTS, POINTS, & LOWER, UPPER, WIDTH, MESH, WORK, INFORM) * * Main adaptive integration subroutine * EXTERNAL FUNCTN INTEGER I, J, NDIM, MINCLS, MAXCLS, SBRGNS, MXRGNS, & RULCLS, LENRUL, INFORM, NWRGNS DOUBLE PRECISION FUNCTN, ABSREQ, RELREQ, ABSEST, FINEST, & ERRORS(*), VALUES(*), PONTRS(*), & LOWERS(NDIM,*), UPPERS(NDIM,*), & MESHES(NDIM,*),WEGHTS(*), POINTS(*), & LOWER(*), UPPER(*), WIDTH(*), MESH(*), WORK(*) INTEGER DIVAXN, TOP, RGNCLS, FUNCLS, DIFCLS * * Initialization of subroutine * INFORM = 2 FUNCLS = 0 DIVAXN = 0 CALL BSINIT(NDIM, WEGHTS, LENRUL, POINTS) IF ( MINCLS .GE. 0) THEN * * When MINCLS >= 0 determine initial subdivision of the * integration region and apply basic rule to each subregion. * SBRGNS = 0 DO I = 1,NDIM LOWER(I) = 0 MESH(I) = 1 WIDTH(I) = 1/(2*MESH(I)) UPPER(I) = 1 END DO RGNCLS = RULCLS NWRGNS = 1 10 CALL DIFFER(NDIM, LOWER, UPPER, WIDTH, WORK, WORK(NDIM+1), & FUNCTN, DIVAXN, DIFCLS) FUNCLS = FUNCLS + DIFCLS IF ( FUNCLS + RGNCLS*(MESH(DIVAXN)+1)/MESH(DIVAXN) & .LE. MINCLS ) THEN RGNCLS = RGNCLS*(MESH(DIVAXN)+1)/MESH(DIVAXN) NWRGNS = NWRGNS*(MESH(DIVAXN)+1)/MESH(DIVAXN) MESH(DIVAXN) = MESH(DIVAXN) + 1 WIDTH(DIVAXN) = 1/( 2*MESH(DIVAXN) ) GO TO 10 ENDIF IF ( NWRGNS .LE. MXRGNS ) THEN DO I = 1,NDIM UPPER(I) = LOWER(I) + 2*WIDTH(I) MESH(I) = 1 END DO ENDIF * * Apply basic rule to subregions and store results in heap. * 20 SBRGNS = SBRGNS + 1 CALL BASRUL(NDIM, LOWER, UPPER, WIDTH, FUNCTN, & WEGHTS, LENRUL, POINTS, WORK, WORK(NDIM+1), & ERRORS(SBRGNS),VALUES(SBRGNS)) CALL TRESTR(SBRGNS, SBRGNS, PONTRS, ERRORS) DO I = 1,NDIM LOWERS(I,SBRGNS) = LOWER(I) UPPERS(I,SBRGNS) = UPPER(I) MESHES(I,SBRGNS) = MESH(I) END DO DO I = 1,NDIM LOWER(I) = UPPER(I) UPPER(I) = LOWER(I) + 2*WIDTH(I) IF ( LOWER(I)+WIDTH(I) .LT. 1 ) GO TO 20 LOWER(I) = 0 UPPER(I) = LOWER(I) + 2*WIDTH(I) END DO FUNCLS = FUNCLS + SBRGNS*RULCLS ENDIF * * Check for termination * 30 FINEST = 0 ABSEST = 0 DO I = 1, SBRGNS FINEST = FINEST + VALUES(I) ABSEST = ABSEST + ERRORS(I) END DO IF ( ABSEST .GT. MAX( ABSREQ, RELREQ*ABS(FINEST) ) & .OR. FUNCLS .LT. MINCLS ) THEN * * Prepare to apply basic rule in (parts of) subregion with * largest error. * TOP = PONTRS(1) RGNCLS = RULCLS DO I = 1,NDIM LOWER(I) = LOWERS(I,TOP) UPPER(I) = UPPERS(I,TOP) MESH(I) = MESHES(I,TOP) WIDTH(I) = (UPPER(I)-LOWER(I))/(2*MESH(I)) RGNCLS = RGNCLS*MESH(I) END DO CALL DIFFER(NDIM, LOWER, UPPER, WIDTH, WORK, WORK(NDIM+1), & FUNCTN, DIVAXN, DIFCLS) FUNCLS = FUNCLS + DIFCLS RGNCLS = RGNCLS*(MESH(DIVAXN)+1)/MESH(DIVAXN) IF ( FUNCLS + RGNCLS .LE. MAXCLS ) THEN IF ( SBRGNS + 1 .LE. MXRGNS ) THEN * * Prepare to subdivide into two pieces. * NWRGNS = 1 WIDTH(DIVAXN) = WIDTH(DIVAXN)/2 ELSE NWRGNS = 0 WIDTH(DIVAXN) = WIDTH(DIVAXN) & *MESH(DIVAXN)/( MESH(DIVAXN) + 1 ) MESHES(DIVAXN,TOP) = MESH(DIVAXN) + 1 ENDIF IF ( NWRGNS .GT. 0 ) THEN * * Only allow local subdivision when space is available. * DO J = SBRGNS+1,SBRGNS+NWRGNS DO I = 1,NDIM LOWERS(I,J) = LOWER(I) UPPERS(I,J) = UPPER(I) MESHES(I,J) = MESH(I) END DO END DO UPPERS(DIVAXN,TOP) = LOWER(DIVAXN) + 2*WIDTH(DIVAXN) LOWERS(DIVAXN,SBRGNS+1) = UPPERS(DIVAXN,TOP) ENDIF FUNCLS = FUNCLS + RGNCLS CALL BASRUL(NDIM, LOWERS(1,TOP), UPPERS(1,TOP), WIDTH, & FUNCTN, WEGHTS, LENRUL, POINTS, WORK, WORK(NDIM+1), & ERRORS(TOP), VALUES(TOP)) CALL TRESTR(TOP, SBRGNS, PONTRS, ERRORS) DO I = SBRGNS+1, SBRGNS+NWRGNS * * Apply basic rule and store results in heap. * CALL BASRUL(NDIM, LOWERS(1,I), UPPERS(1,I), WIDTH, & FUNCTN, WEGHTS, LENRUL, POINTS, WORK, WORK(NDIM+1), & ERRORS(I), VALUES(I)) CALL TRESTR(I, I, PONTRS, ERRORS) END DO SBRGNS = SBRGNS + NWRGNS GO TO 30 ELSE INFORM = 1 ENDIF ELSE INFORM = 0 ENDIF MINCLS = FUNCLS END SUBROUTINE BSINIT(NDIM, W, LENRUL, G) * * For initializing basic rule weights and symmetric sum parameters. * INTEGER NDIM, LENRUL, RULPTS(6), I, J, NUMNUL, SDIM PARAMETER ( NUMNUL = 4, SDIM = 12 ) DOUBLE PRECISION W(LENRUL,4), G(NDIM,LENRUL) DOUBLE PRECISION LAM1, LAM2, LAM3, LAMP, RULCON * * The following code determines rule parameters and weights for a * degree 7 rule (W(1,1),...,W(5,1)), two degree 5 comparison rules * (W(1,2),...,W(5,2) and W(1,3),...,W(5,3)) and a degree 3 * comparison rule (W(1,4),...W(5,4)). * * If NDIM = 1, then LENRUL = 5 and total points = 9. * If NDIM < SDIM, then LENRUL = 6 and * total points = 1+2*NDIM*(NDIM+2)+2**NDIM. * If NDIM > = SDIM, then LENRUL = 6 and * total points = 1+2*NDIM*(1+2*NDIM). * DO I = 1,LENRUL DO J = 1,NDIM G(J,I) = 0 END DO DO J = 1,NUMNUL W(I,J) = 0 END DO END DO RULPTS(5) = 2*NDIM*(NDIM-1) RULPTS(4) = 2*NDIM RULPTS(3) = 2*NDIM RULPTS(2) = 2*NDIM RULPTS(1) = 1 LAMP = 0.85 LAM3 = 0.4707 LAM2 = 4/(15 - 5/LAM3) W(5,1) = ( 3 - 5*LAM3 )/( 180*(LAM2-LAM3)*LAM2**2 ) IF ( NDIM .LT. SDIM ) THEN LAM1 = 8*LAM3*(31*LAM3-15)/( (3*LAM3-1)*(5*LAM3-3)*35 ) W(LENRUL,1) = 1/(3*LAM3)**3/2**NDIM ELSE LAM1 = ( LAM3*(15 - 21*LAM2) + 35*(NDIM-1)*(LAM2-LAM3)/9 ) & / ( LAM3*(21 - 35*LAM2) + 35*(NDIM-1)*(LAM2/LAM3-1)/9 ) W(6,1) = 1/(4*(3*LAM3)**3) ENDIF W(3,1) = ( 15 - 21*(LAM3+LAM1) + 35*LAM3*LAM1 ) & /( 210*LAM2*(LAM2-LAM3)*(LAM2-LAM1) ) - 2*(NDIM-1)*W(5,1) W(2,1) = ( 15 - 21*(LAM3+LAM2) + 35*LAM3*LAM2 ) & /( 210*LAM1*(LAM1-LAM3)*(LAM1-LAM2) ) IF ( NDIM .LT. SDIM ) THEN RULPTS(LENRUL) = 2**NDIM LAM3 = SQRT(LAM3) DO I = 1,NDIM G(I,LENRUL) = LAM3 END DO ELSE W(6,1) = 1/(4*(3*LAM3)**3) RULPTS(6) = 2*NDIM*(NDIM-1) LAM3 = SQRT(LAM3) DO I = 1,2 G(I,6) = LAM3 END DO ENDIF IF ( NDIM .GT. 1 ) THEN W(5,2) = 1/(6*LAM2)**2 W(5,3) = 1/(6*LAM2)**2 ENDIF W(3,2) = ( 3 - 5*LAM1 )/( 30*LAM2*(LAM2-LAM1) ) & - 2*(NDIM-1)*W(5,2) W(2,2) = ( 3 - 5*LAM2 )/( 30*LAM1*(LAM1-LAM2) ) W(4,3) = ( 3 - 5*LAM2 )/( 30*LAMP*(LAMP-LAM2) ) W(3,3) = ( 3 - 5*LAMP )/( 30*LAM2*(LAM2-LAMP) ) & - 2*(NDIM-1)*W(5,3) W(2,4) = 1/(6*LAM1) LAMP = SQRT(LAMP) LAM2 = SQRT(LAM2) LAM1 = SQRT(LAM1) G(1,2) = LAM1 G(1,3) = LAM2 G(1,4) = LAMP IF ( NDIM .GT. 1 ) THEN G(1,5) = LAM2 G(2,5) = LAM2 ENDIF DO J = 1, NUMNUL W(1,J) = 1 DO I = 2,LENRUL W(1,J) = W(1,J) - RULPTS(I)*W(I,J) END DO END DO RULCON = 2 CALL RULNRM( LENRUL, NUMNUL, RULPTS, W, RULCON ) END * SUBROUTINE RULNRM( LENRUL, NUMNUL, RULPTS, W, RULCON ) INTEGER LENRUL, NUMNUL, I, J, K, RULPTS(*) DOUBLE PRECISION ALPHA, NORMCF, NORMNL, W(LENRUL, *), RULCON * * Compute orthonormalized null rules. * NORMCF = 0 DO I = 1,LENRUL NORMCF = NORMCF + RULPTS(I)*W(I,1)*W(I,1) END DO DO K = 2,NUMNUL DO I = 1,LENRUL W(I,K) = W(I,K) - W(I,1) END DO DO J = 2,K-1 ALPHA = 0 DO I = 1,LENRUL ALPHA = ALPHA + RULPTS(I)*W(I,J)*W(I,K) END DO ALPHA = -ALPHA/NORMCF DO I = 1,LENRUL W(I,K) = W(I,K) + ALPHA*W(I,J) END DO END DO NORMNL = 0 DO I = 1,LENRUL NORMNL = NORMNL + RULPTS(I)*W(I,K)*W(I,K) END DO ALPHA = SQRT(NORMCF/NORMNL) DO I = 1,LENRUL W(I,K) = ALPHA*W(I,K) END DO END DO DO J = 2, NUMNUL DO I = 1,LENRUL W(I,J) = W(I,J)/RULCON END DO END DO END *-------------------------------------------------------------------------- DOUBLE PRECISION FUNCTION MVNFNC(N, W) * * Integrand subroutine * INTEGER N, INFIN(*), INFIS DOUBLE PRECISION W(*), LOWER(*), UPPER(*), CORREL(*), ONE INTEGER NL, IJ, I, J PARAMETER ( NL = 100, ONE = 1 ) DOUBLE PRECISION COV((NL*(NL+1))/2), A(NL), B(NL), Y(NL), BVN INTEGER INFI(NL) DOUBLE PRECISION PROD, D1, E1, DI, EI, SUM, PHINV, D, E, MVNNIT SAVE D1, E1, A, B, INFI, COV DI = D1 EI = E1 PROD = E1 - D1 IJ = 1 DO I = 1,N Y(I) = PHINV( DI + W(I)*(EI-DI) ) SUM = 0 DO J = 1,I IJ = IJ + 1 SUM = SUM + COV(IJ)*Y(J) END DO IJ = IJ + 1 IF ( COV(IJ) .GT. 0 ) THEN CALL LIMITS( A(I+1)-SUM, B(I+1)-SUM, INFI(I+1), DI, EI ) ELSE DI = ( 1 + SIGN( ONE, A(I+1)-SUM ) )/2 EI = ( 1 + SIGN( ONE, B(I+1)-SUM ) )/2 ENDIF PROD = PROD*(EI-DI) END DO MVNFNC = PROD RETURN * * Entry point for intialization. * ENTRY MVNNIT(N, CORREL, LOWER, UPPER, INFIN, INFIS, D, E) MVNNIT = 0 * * Initialization and computation of covariance Cholesky factor. * CALL NCVSRT(N, LOWER,UPPER,CORREL,INFIN,Y, INFIS,A,B,INFI,COV,D,E) D1 = D E1 = E IF ( N - INFIS .EQ. 2 ) THEN D = SQRT( 1 + COV(2)**2 ) A(2) = A(2)/D B(2) = B(2)/D E = BVN( A, B, INFI, COV(2)/D ) D = 0 INFIS = INFIS + 1 END IF END SUBROUTINE LIMITS( A, B, INFIN, LOWER, UPPER ) DOUBLE PRECISION A, B, LOWER, UPPER, PHI INTEGER INFIN LOWER = 0 UPPER = 1 IF ( INFIN .GE. 0 ) THEN IF ( INFIN .NE. 0 ) LOWER = PHI(A) IF ( INFIN .NE. 1 ) UPPER = PHI(B) ENDIF END *-------------------------------------------------------------------------- DOUBLE PRECISION FUNCTION PHI(Z) * * Normal distribution probabilities accurate to 1.e-15. * Z = no. of standard deviations from the mean. * * Based upon algorithm 5666 for the error function, from: * Hart, J.F. et al, 'Computer Approximations', Wiley 1968 * * Programmer: Alan Miller * * Latest revision - 30 March 1986 * DOUBLE PRECISION P0, P1, P2, P3, P4, P5, P6, & Q0, Q1, Q2, Q3, Q4, Q5, Q6, Q7, & Z, P, EXPNTL, CUTOFF, ROOTPI, ZABS PARAMETER( & P0 = 220.20 68679 12376 1D0, & P1 = 221.21 35961 69931 1D0, & P2 = 112.07 92914 97870 9D0, & P3 = 33.912 86607 83830 0D0, & P4 = 6.3739 62203 53165 0D0, & P5 = .70038 30644 43688 1D0, & P6 = .035262 49659 98910 9D0) PARAMETER( & Q0 = 440.41 37358 24752 2D0, & Q1 = 793.82 65125 19948 4D0, & Q2 = 637.33 36333 78831 1D0, & Q3 = 296.56 42487 79673 7D0, & Q4 = 86.780 73220 29460 8D0, & Q5 = 16.064 17757 92069 5D0, & Q6 = 1.7556 67163 18264 2D0, & Q7 = .088388 34764 83184 4D0) PARAMETER(ROOTPI = 2.5066 28274 63100 1D0) PARAMETER(CUTOFF = 7.0710 67811 86547 5D0) * ZABS = ABS(Z) * * |Z| > 37 * IF (ZABS .GT. 37) THEN P = 0 ELSE * * |Z| <= 37 * EXPNTL = EXP(-ZABS**2/2) * * |Z| < CUTOFF = 10/SQRT(2) * IF (ZABS .LT. CUTOFF) THEN P = EXPNTL*((((((P6*ZABS + P5)*ZABS + P4)*ZABS + P3)*ZABS & + P2)*ZABS + P1)*ZABS + P0)/(((((((Q7*ZABS + Q6)*ZABS & + Q5)*ZABS + Q4)*ZABS + Q3)*ZABS + Q2)*ZABS + Q1)*ZABS & + Q0) * * |Z| >= CUTOFF. * ELSE P = EXPNTL/(ZABS + 1/(ZABS + 2/(ZABS + 3/(ZABS + 4/ & (ZABS + 0.65D0)))))/ROOTPI END IF END IF IF (Z .GT. 0) P = 1 - P PHI = P END * DOUBLE PRECISION FUNCTION PHINV(P) * * ALGORITHM AS241 APPL. STATIST. (1988) VOL. 37, NO. 3 * * Produces the normal deviate Z corresponding to a given lower * tail area of P. * * The hash sums below are the sums of the mantissas of the * coefficients. They are included for use in checking * transcription. * DOUBLE PRECISION SPLIT1, SPLIT2, CONST1, CONST2, & A0, A1, A2, A3, A4, A5, A6, A7, B1, B2, B3, B4, B5, B6, B7, & C0, C1, C2, C3, C4, C5, C6, C7, D1, D2, D3, D4, D5, D6, D7, & E0, E1, E2, E3, E4, E5, E6, E7, F1, F2, F3, F4, F5, F6, F7, & P, Q, R PARAMETER (SPLIT1 = 0.425, SPLIT2 = 5, & CONST1 = 0.180625D0, CONST2 = 1.6D0) * * Coefficients for P close to 0.5 * PARAMETER ( & A0 = 3.38713 28727 96366 6080D0, & A1 = 1.33141 66789 17843 7745D+2, & A2 = 1.97159 09503 06551 4427D+3, & A3 = 1.37316 93765 50946 1125D+4, & A4 = 4.59219 53931 54987 1457D+4, & A5 = 6.72657 70927 00870 0853D+4, & A6 = 3.34305 75583 58812 8105D+4, & A7 = 2.50908 09287 30122 6727D+3, & B1 = 4.23133 30701 60091 1252D+1, & B2 = 6.87187 00749 20579 0830D+2, & B3 = 5.39419 60214 24751 1077D+3, & B4 = 2.12137 94301 58659 5867D+4, & B5 = 3.93078 95800 09271 0610D+4, & B6 = 2.87290 85735 72194 2674D+4, & B7 = 5.22649 52788 52854 5610D+3) * HASH SUM AB 55.88319 28806 14901 4439 * * Coefficients for P not close to 0, 0.5 or 1. * PARAMETER ( & C0 = 1.42343 71107 49683 57734D0, & C1 = 4.63033 78461 56545 29590D0, & C2 = 5.76949 72214 60691 40550D0, & C3 = 3.64784 83247 63204 60504D0, & C4 = 1.27045 82524 52368 38258D0, & C5 = 2.41780 72517 74506 11770D-1, & C6 = 2.27238 44989 26918 45833D-2, & C7 = 7.74545 01427 83414 07640D-4, & D1 = 2.05319 16266 37758 82187D0, & D2 = 1.67638 48301 83803 84940D0, & D3 = 6.89767 33498 51000 04550D-1, & D4 = 1.48103 97642 74800 74590D-1, & D5 = 1.51986 66563 61645 71966D-2, & D6 = 5.47593 80849 95344 94600D-4, & D7 = 1.05075 00716 44416 84324D-9) * HASH SUM CD 49.33206 50330 16102 89036 * * Coefficients for P near 0 or 1. * PARAMETER ( & E0 = 6.65790 46435 01103 77720D0, & E1 = 5.46378 49111 64114 36990D0, & E2 = 1.78482 65399 17291 33580D0, & E3 = 2.96560 57182 85048 91230D-1, & E4 = 2.65321 89526 57612 30930D-2, & E5 = 1.24266 09473 88078 43860D-3, & E6 = 2.71155 55687 43487 57815D-5, & E7 = 2.01033 43992 92288 13265D-7, & F1 = 5.99832 20655 58879 37690D-1, & F2 = 1.36929 88092 27358 05310D-1, & F3 = 1.48753 61290 85061 48525D-2, & F4 = 7.86869 13114 56132 59100D-4, & F5 = 1.84631 83175 10054 68180D-5, & F6 = 1.42151 17583 16445 88870D-7, & F7 = 2.04426 31033 89939 78564D-15) * HASH SUM EF 47.52583 31754 92896 71629 * Q = ( 2*P - 1 )/2 IF ( ABS(Q) .LE. SPLIT1 ) THEN R = CONST1 - Q*Q PHINV = Q*(((((((A7*R + A6)*R + A5)*R + A4)*R + A3) & *R + A2)*R + A1)*R + A0) / & (((((((B7*R + B6)*R + B5)*R + B4)*R + B3) & *R + B2)*R + B1)*R + 1) ELSE R = MIN( P, 1 - P ) IF (R .GT. 0) THEN R = SQRT( -LOG(R) ) IF ( R .LE. SPLIT2 ) THEN R = R - CONST2 PHINV = (((((((C7*R + C6)*R + C5)*R + C4)*R + C3) & *R + C2)*R + C1)*R + C0) / & (((((((D7*R + D6)*R + D5)*R + D4)*R + D3) & *R + D2)*R + D1)*R + 1) ELSE R = R - SPLIT2 PHINV = (((((((E7*R + E6)*R + E5)*R + E4)*R + E3) & *R + E2)*R + E1)*R + E0) / & (((((((F7*R + F6)*R + F5)*R + F4)*R + F3) & *R + F2)*R + F1)*R + 1) END IF ELSE PHINV = 9 END IF IF ( Q .LT. 0 ) PHINV = - PHINV END IF END DOUBLE PRECISION FUNCTION BVN ( LOWER, UPPER, INFIN, CORREL ) * * A function for computing bivariate normal probabilities. * * Parameters * * LOWER REAL, array of lower integration limits. * UPPER REAL, array of upper integration limits. * INFIN INTEGER, array of integration limits flags: * if INFIN(I) = 0, Ith limits are (-infinity, UPPER(I)]; * if INFIN(I) = 1, Ith limits are [LOWER(I), infinity); * if INFIN(I) = 2, Ith limits are [LOWER(I), UPPER(I)]. * CORREL REAL, correlation coefficient. * DOUBLE PRECISION LOWER(*), UPPER(*), CORREL, BVNU INTEGER INFIN(*) IF ( INFIN(1) .EQ. 2 .AND. INFIN(2) .EQ. 2 ) THEN BVN = BVNU ( LOWER(1), LOWER(2), CORREL ) + - BVNU ( UPPER(1), LOWER(2), CORREL ) + - BVNU ( LOWER(1), UPPER(2), CORREL ) + + BVNU ( UPPER(1), UPPER(2), CORREL ) ELSE IF ( INFIN(1) .EQ. 2 .AND. INFIN(2) .EQ. 1 ) THEN BVN = BVNU ( LOWER(1), LOWER(2), CORREL ) + - BVNU ( UPPER(1), LOWER(2), CORREL ) ELSE IF ( INFIN(1) .EQ. 1 .AND. INFIN(2) .EQ. 2 ) THEN BVN = BVNU ( LOWER(1), LOWER(2), CORREL ) + - BVNU ( LOWER(1), UPPER(2), CORREL ) ELSE IF ( INFIN(1) .EQ. 2 .AND. INFIN(2) .EQ. 0 ) THEN BVN = BVNU ( -UPPER(1), -UPPER(2), CORREL ) + - BVNU ( -LOWER(1), -UPPER(2), CORREL ) ELSE IF ( INFIN(1) .EQ. 0 .AND. INFIN(2) .EQ. 2 ) THEN BVN = BVNU ( -UPPER(1), -UPPER(2), CORREL ) + - BVNU ( -UPPER(1), -LOWER(2), CORREL ) ELSE IF ( INFIN(1) .EQ. 1 .AND. INFIN(2) .EQ. 0 ) THEN BVN = BVNU ( LOWER(1), -UPPER(2), -CORREL ) ELSE IF ( INFIN(1) .EQ. 0 .AND. INFIN(2) .EQ. 1 ) THEN BVN = BVNU ( -UPPER(1), LOWER(2), -CORREL ) ELSE IF ( INFIN(1) .EQ. 1 .AND. INFIN(2) .EQ. 1 ) THEN BVN = BVNU ( LOWER(1), LOWER(2), CORREL ) ELSE IF ( INFIN(1) .EQ. 0 .AND. INFIN(2) .EQ. 0 ) THEN BVN = BVNU ( -UPPER(1), -UPPER(2), CORREL ) END IF END DOUBLE PRECISION FUNCTION BVNU( SH, SK, R ) * * A function for computing bivariate normal probabilities. * * Yihong Ge * Department of Computer Science and Electrical Engineering * Washington State University * Pullman, WA 99164-2752 * Email : yge@eecs.wsu.edu * and * Alan Genz * Department of Mathematics * Washington State University * Pullman, WA 99164-3113 * Email : alangenz@wsu.edu * * BVN - calculate the probability that X is larger than SH and Y is * larger than SK. * * Parameters * * SH REAL, integration limit * SK REAL, integration limit * R REAL, correlation coefficient * LG INTEGER, number of Gauss Rule Points and Weights * DOUBLE PRECISION BVN, SH, SK, R, ZERO, TWOPI INTEGER I, LG, NG PARAMETER ( ZERO = 0, TWOPI = 6.2831 85307 179586 ) DOUBLE PRECISION X(10,3), W(10,3), AS, A, B, C, D, RS, XS DOUBLE PRECISION PHI, SN, ASR, H, K, BS, HS, HK * Gauss Legendre Points and Weights, N = 6 DATA ( W(I,1), X(I,1), I = 1,3) / & 0.1713244923791705D+00,-0.9324695142031522D+00, & 0.3607615730481384D+00,-0.6612093864662647D+00, & 0.4679139345726904D+00,-0.2386191860831970D+00/ * Gauss Legendre Points and Weights, N = 12 DATA ( W(I,2), X(I,2), I = 1,6) / & 0.4717533638651177D-01,-0.9815606342467191D+00, & 0.1069393259953183D+00,-0.9041172563704750D+00, & 0.1600783285433464D+00,-0.7699026741943050D+00, & 0.2031674267230659D+00,-0.5873179542866171D+00, & 0.2334925365383547D+00,-0.3678314989981802D+00, & 0.2491470458134029D+00,-0.1252334085114692D+00/ * Gauss Legendre Points and Weights, N = 20 DATA ( W(I,3), X(I,3), I = 1,10) / & 0.1761400713915212D-01,-0.9931285991850949D+00, & 0.4060142980038694D-01,-0.9639719272779138D+00, & 0.6267204833410906D-01,-0.9122344282513259D+00, & 0.8327674157670475D-01,-0.8391169718222188D+00, & 0.1019301198172404D+00,-0.7463319064601508D+00, & 0.1181945319615184D+00,-0.6360536807265150D+00, & 0.1316886384491766D+00,-0.5108670019508271D+00, & 0.1420961093183821D+00,-0.3737060887154196D+00, & 0.1491729864726037D+00,-0.2277858511416451D+00, & 0.1527533871307259D+00,-0.7652652113349733D-01/ SAVE X, W IF ( ABS(R) .LT. 0.3 ) THEN NG = 1 LG = 3 ELSE IF ( ABS(R) .LT. 0.75 ) THEN NG = 2 LG = 6 ELSE NG = 3 LG = 10 ENDIF H = SH K = SK HK = H*K BVN = 0 IF ( ABS(R) .LT. 0.925 ) THEN HS = ( H*H + K*K )/2 ASR = ASIN(R) DO 10 I = 1, LG SN = SIN(ASR*( X(I,NG)+1 )/2) BVN = BVN + W(I,NG)*EXP( ( SN*HK - HS )/( 1 - SN*SN ) ) SN = SIN(ASR*(-X(I,NG)+1 )/2) BVN = BVN + W(I,NG)*EXP( ( SN*HK - HS )/( 1 - SN*SN ) ) 10 CONTINUE BVN = BVN*ASR/(2*TWOPI) + PHI(-H)*PHI(-K) ELSE IF ( R .LT. 0 ) THEN K = -K HK = -HK ENDIF IF ( ABS(R) .LT. 1 ) THEN AS = ( 1 - R )*( 1 + R ) A = SQRT(AS) BS = ( H - K )**2 C = ( 4 - HK )/8 D = ( 12 - HK )/16 BVN = A*EXP( -(BS/AS + HK)/2 ) + *( 1 - C*(BS - AS)*(1 - D*BS/5)/3 + C*D*AS*AS/5 ) IF ( HK .GT. -160 ) THEN B = SQRT(BS) BVN = BVN - EXP(-HK/2)*SQRT(TWOPI)*PHI(-B/A)*B + *( 1 - C*BS*( 1 - D*BS/5 )/3 ) ENDIF A = A/2 DO 20 I = 1, LG XS = ( A*(X(I,NG)+1) )**2 RS = SQRT( 1 - XS ) BVN = BVN + A*W(I,NG)* + ( EXP( -BS/(2*XS) - HK/(1+RS) )/RS + - EXP( -(BS/XS+HK)/2 )*( 1 + C*XS*( 1 + D*XS ) ) ) XS = AS*(-X(I,NG)+1)**2/4 RS = SQRT( 1 - XS ) BVN = BVN + A*W(I,NG)*EXP( -(BS/XS + HK)/2 ) + *( EXP( -HK*(1-RS)/(2*(1+RS)) )/RS + - ( 1 + C*XS*( 1 + D*XS ) ) ) 20 CONTINUE BVN = -BVN/TWOPI ENDIF IF ( R .GT. 0 ) BVN = BVN + PHI( -MAX( H, K ) ) IF ( R .LT. 0 ) BVN = -BVN + MAX( ZERO, PHI(-H) - PHI(-K) ) ENDIF BVNU = BVN END * *-------------------------------------------------------------------------- SUBROUTINE NCVSRT( N, LOWER, UPPER, CORREL, INFIN, Y, INFIS, & A, B, INFI, COV, D, E ) * * Subroutine to sort integration limits. * INTEGER N, INFI(*), INFIN(*), INFIS, iflag DOUBLE PRECISION & A(*), B(*), COV(*), LOWER(*), UPPER(*), CORREL(*), Y(*), D, E INTEGER I, J, K, IJ, II, JMIN DOUBLE PRECISION SUMSQ, ZERO PARAMETER ( ZERO = 0 ) DOUBLE PRECISION AJ, BJ, SUM, SQTWPI DOUBLE PRECISION CVDIAG, AMIN, BMIN, DMIN, EMIN, YL, YU PARAMETER ( SQTWPI = 2.50662 82746 31000 50240 ) IJ = 0 II = 0 INFIS = 0 DO I = 1,N INFI(I) = INFIN(I) IF ( INFI(I) .LT. 0 ) THEN INFIS = INFIS + 1 ELSE A(I) = 0 B(I) = 0 IF ( INFI(I) .NE. 0 ) A(I) = LOWER(I) IF ( INFI(I) .NE. 1 ) B(I) = UPPER(I) ENDIF DO J = 1,I-1 IJ = IJ + 1 II = II + 1 COV(IJ) = CORREL(II) END DO IJ = IJ + 1 COV(IJ) = 1 END DO * * First move any doubly infinite limits to innermost positions * [AA, recoded to avoid GOTO jump outside IF block] * IF ( INFIS .LT. N ) THEN DO I = N,N-INFIS+1,-1 iflag = 0 IF ( INFI(I) .GE. 0 ) THEN DO J = 1,I-1 IF ( INFI(J) .LT. 0 .and. iflag .eq. 0) THEN CALL RCSWAP(J, I, A, B, INFI, N, COV) iflag = 1 ENDIF END DO ENDIF 10 END DO * * Sort remaining limits and determine Cholesky decomposition * II = 0 DO I = 1,N-INFIS * * Determine the integration limits for variable with minimum * expected probability and interchange that variable with Ith. * EMIN = 1 DMIN = 0 JMIN = I CVDIAG = 0 IJ = II DO J = I, N-INFIS SUM = 0 SUMSQ = 0 DO K = 1, I-1 SUM = SUM + COV(IJ+K)*Y(K) SUMSQ = SUMSQ + COV(IJ+K)**2 END DO IJ = IJ + J SUMSQ = SQRT( MAX( COV(IJ)-SUMSQ, ZERO ) ) IF ( SUMSQ .GT. 0 ) THEN IF ( INFI(J) .NE. 0 ) AJ = ( A(J) - SUM )/SUMSQ IF ( INFI(J) .NE. 1 ) BJ = ( B(J) - SUM )/SUMSQ CALL LIMITS( AJ, BJ, INFI(J), D, E ) IF ( EMIN - DMIN .GE. E - D ) THEN JMIN = J IF ( INFI(J) .NE. 0 ) AMIN = AJ IF ( INFI(J) .NE. 1 ) BMIN = BJ DMIN = D EMIN = E CVDIAG = SUMSQ ENDIF ENDIF END DO IF ( JMIN .NE. I) CALL RCSWAP(I, JMIN, A, B, INFI, N, COV) * * Compute Ith column of Cholesky factor. * IJ = II + I COV(IJ) = CVDIAG DO J = I+1, N-INFIS IF ( CVDIAG .GT. 0 ) THEN SUM = COV(IJ+I) DO K = 1, I-1 SUM = SUM - COV(II+K)*COV(IJ+K) END DO COV(IJ+I) = SUM/CVDIAG ELSE COV(IJ+I) = 0 ENDIF IJ = IJ + J END DO * * Compute expected value for Ith integration variable and * scale Ith covariance matrix row and limits. * IF ( CVDIAG .GT. 0 ) THEN IF ( EMIN .GT. DMIN + 1D-8 ) THEN YL = 0 YU = 0 IF ( INFI(I) .NE. 0 ) YL = -EXP( -AMIN**2/2 )/SQTWPI IF ( INFI(I) .NE. 1 ) YU = -EXP( -BMIN**2/2 )/SQTWPI Y(I) = ( YU - YL )/( EMIN - DMIN ) ELSE IF ( INFI(I) .EQ. 0 ) Y(I) = BMIN IF ( INFI(I) .EQ. 1 ) Y(I) = AMIN IF ( INFI(I) .EQ. 2 ) Y(I) = ( AMIN + BMIN )/2 END IF DO J = 1,I II = II + 1 COV(II) = COV(II)/CVDIAG END DO IF ( INFI(I) .NE. 0 ) A(I) = A(I)/CVDIAG IF ( INFI(I) .NE. 1 ) B(I) = B(I)/CVDIAG ELSE Y(I) = 0 II = II + I ENDIF END DO CALL LIMITS( A(1), B(1), INFI(1), D, E) ENDIF END *-------------------------------------------------------------------------- SUBROUTINE BASRUL( NDIM, A, B, WIDTH, FUNCTN, W, LENRUL, G, & CENTER, Z, RGNERT, BASEST ) * * For application of basic integration rule * EXTERNAL FUNCTN INTEGER I, LENRUL, NDIM DOUBLE PRECISION & A(NDIM), B(NDIM), WIDTH(NDIM), FUNCTN, W(LENRUL,4), & G(NDIM,LENRUL), CENTER(NDIM), Z(NDIM), RGNERT, BASEST DOUBLE PRECISION & FULSUM, FSYMSM, RGNCMP, RGNVAL, RGNVOL, RGNCPT, RGNERR * * Compute Volume and Center of Subregion * RGNVOL = 1 DO I = 1,NDIM RGNVOL = 2*RGNVOL*WIDTH(I) CENTER(I) = A(I) + WIDTH(I) END DO BASEST = 0 RGNERT = 0 * * Compute basic rule and error * 10 RGNVAL = 0 RGNERR = 0 RGNCMP = 0 RGNCPT = 0 DO I = 1,LENRUL FSYMSM = FULSUM(NDIM, CENTER, WIDTH, Z, G(1,I), FUNCTN) * Basic Rule RGNVAL = RGNVAL + W(I,1)*FSYMSM * First comparison rule RGNERR = RGNERR + W(I,2)*FSYMSM * Second comparison rule RGNCMP = RGNCMP + W(I,3)*FSYMSM * Third Comparison rule RGNCPT = RGNCPT + W(I,4)*FSYMSM END DO * * Error estimation * RGNERR = SQRT(RGNCMP**2 + RGNERR**2) RGNCMP = SQRT(RGNCPT**2 + RGNCMP**2) IF ( 4*RGNERR .LT. RGNCMP ) RGNERR = RGNERR/2 IF ( 2*RGNERR .GT. RGNCMP ) RGNERR = MAX( RGNERR, RGNCMP ) RGNERT = RGNERT + RGNVOL*RGNERR BASEST = BASEST + RGNVOL*RGNVAL * * When subregion has more than one piece, determine next piece and * loop back to apply basic rule. * DO I = 1,NDIM CENTER(I) = CENTER(I) + 2*WIDTH(I) IF ( CENTER(I) .LT. B(I) ) GO TO 10 CENTER(I) = A(I) + WIDTH(I) END DO END DOUBLE PRECISION FUNCTION FULSUM(S, CENTER, HWIDTH, X, G, F) * **** To compute fully symmetric basic rule sum * EXTERNAL F INTEGER S, IXCHNG, LXCHNG, I, L DOUBLE PRECISION CENTER(S), HWIDTH(S), X(S), G(S), F DOUBLE PRECISION INTSUM, GL, GI FULSUM = 0 * * Compute centrally symmetric sum for permutation of G * 10 INTSUM = 0 DO I = 1,S X(I) = CENTER(I) + G(I)*HWIDTH(I) END DO 20 INTSUM = INTSUM + F(S,X) DO I = 1,S G(I) = -G(I) X(I) = CENTER(I) + G(I)*HWIDTH(I) IF ( G(I) .LT. 0 ) GO TO 20 END DO FULSUM = FULSUM + INTSUM * * Find next distinct permuation of G and loop back for next sum * DO I = 2,S IF ( G(I-1) .GT. G(I) ) THEN GI = G(I) IXCHNG = I - 1 DO L = 1,(I-1)/2 GL = G(L) G(L) = G(I-L) G(I-L) = GL IF ( GL .LE. GI ) IXCHNG = IXCHNG - 1 IF ( G(L) .GT. GI ) LXCHNG = L END DO IF ( G(IXCHNG) .LE. GI ) IXCHNG = LXCHNG G(I) = G(IXCHNG) G(IXCHNG) = GI GO TO 10 ENDIF END DO * * End loop for permutations of G and associated sums * * Restore original order to G's * DO I = 1,S/2 GI = G(I) G(I) = G(S+1-I) G(S+1-I) = GI END DO END SUBROUTINE DIFFER(NDIM, A, B, WIDTH, Z, DIF, FUNCTN, & DIVAXN, DIFCLS) * * Compute fourth differences and subdivision axes * EXTERNAL FUNCTN INTEGER I, NDIM, DIVAXN, DIFCLS DOUBLE PRECISION & A(NDIM), B(NDIM), WIDTH(NDIM), Z(NDIM), DIF(NDIM), FUNCTN DOUBLE PRECISION FRTHDF, FUNCEN, WIDTHI DIFCLS = 0 DIVAXN = MOD( DIVAXN, NDIM ) + 1 IF ( NDIM .GT. 1 ) THEN DO I = 1,NDIM DIF(I) = 0 Z(I) = A(I) + WIDTH(I) END DO 10 FUNCEN = FUNCTN(NDIM, Z) DO I = 1,NDIM WIDTHI = WIDTH(I)/5 FRTHDF = 6*FUNCEN Z(I) = Z(I) - 4*WIDTHI FRTHDF = FRTHDF + FUNCTN(NDIM,Z) Z(I) = Z(I) + 2*WIDTHI FRTHDF = FRTHDF - 4*FUNCTN(NDIM,Z) Z(I) = Z(I) + 4*WIDTHI FRTHDF = FRTHDF - 4*FUNCTN(NDIM,Z) Z(I) = Z(I) + 2*WIDTHI FRTHDF = FRTHDF + FUNCTN(NDIM,Z) * Do not include differences below roundoff IF ( FUNCEN + FRTHDF/8 .NE. FUNCEN ) & DIF(I) = DIF(I) + ABS(FRTHDF)*WIDTH(I) Z(I) = Z(I) - 4*WIDTHI END DO DIFCLS = DIFCLS + 4*NDIM + 1 DO I = 1,NDIM Z(I) = Z(I) + 2*WIDTH(I) IF ( Z(I) .LT. B(I) ) GO TO 10 Z(I) = A(I) + WIDTH(I) END DO DO I = 1,NDIM IF ( DIF(DIVAXN) .LT. DIF(I) ) DIVAXN = I END DO ENDIF END *-------- SUBROUTINE TRESTR(POINTR, SBRGNS, PONTRS, RGNERS) ****BEGIN PROLOGUE TRESTR ****PURPOSE TRESTR maintains a heap for subregions. ****DESCRIPTION TRESTR maintains a heap for subregions. * The subregions are ordered according to the size of the * greatest error estimates of each subregion (RGNERS). * * PARAMETERS * * POINTR Integer. * The index for the subregion to be inserted in the heap. * SBRGNS Integer. * Number of subregions in the heap. * PONTRS Real array of dimension SBRGNS. * Used to store the indices for the greatest estimated errors * for each subregion. * RGNERS Real array of dimension SBRGNS. * Used to store the greatest estimated errors for each * subregion. * ****ROUTINES CALLED NONE ****END PROLOGUE TRESTR * * Global variables. * INTEGER POINTR, SBRGNS DOUBLE PRECISION PONTRS(*), RGNERS(*) * * Local variables. * * RGNERR Intermediate storage for the greatest error of a subregion. * SUBRGN Position of child/parent subregion in the heap. * SUBTMP Position of parent/child subregion in the heap. * INTEGER SUBRGN, SUBTMP, POINTP, POINTS DOUBLE PRECISION RGNERR * ****FIRST PROCESSING STATEMENT TRESTR * RGNERR = RGNERS(POINTR) IF ( POINTR .EQ. PONTRS(1) ) THEN * * Move the new subregion inserted at the top of the heap * to its correct position in the heap. * SUBRGN = 1 10 SUBTMP = 2*SUBRGN IF ( SUBTMP .LE. SBRGNS ) THEN IF ( SUBTMP .NE. SBRGNS ) THEN * * Find maximum of left and right child. * POINTS = PONTRS(SUBTMP) POINTP = PONTRS(SUBTMP+1) IF ( RGNERS(POINTS) .LT. + RGNERS(POINTP) ) SUBTMP = SUBTMP + 1 ENDIF * * Compare maximum child with parent. * If parent is maximum, then done. * POINTS = PONTRS(SUBTMP) IF ( RGNERR .LT. RGNERS(POINTS) ) THEN * * Move the pointer at position subtmp up the heap. * PONTRS(SUBRGN) = PONTRS(SUBTMP) SUBRGN = SUBTMP GO TO 10 ENDIF ENDIF ELSE * * Insert new subregion in the heap. * SUBRGN = SBRGNS 20 SUBTMP = SUBRGN/2 IF ( SUBTMP .GE. 1 ) THEN * * Compare child with parent. If parent is maximum, then done. * POINTS = PONTRS(SUBTMP) IF ( RGNERR .GT. RGNERS(POINTS) ) THEN * * Move the pointer at position subtmp down the heap. * PONTRS(SUBRGN) = PONTRS(SUBTMP) SUBRGN = SUBTMP GO TO 20 ENDIF ENDIF ENDIF PONTRS(SUBRGN) = POINTR * ****END TRESTR * END *-------------------------------------------------------------------------- SUBROUTINE RCSWAP(P, Q, A, B, INFIN, N, C) * * Swaps rows and columns P and Q in situ. * DOUBLE PRECISION A(*), B(*), C(*), T INTEGER INFIN(*), P, Q, N, I, J, II, JJ T = A(P) A(P) = A(Q) A(Q) = T T = B(P) B(P) = B(Q) B(Q) = T J = INFIN(P) INFIN(P) = INFIN(Q) INFIN(Q) = J JJ = (P*(P-1))/2 II = (Q*(Q-1))/2 T = C(JJ+P) C(JJ+P) = C(II+Q) C(II+Q) = T DO J = 1, P-1 T = C(JJ+J) C(JJ+J) = C(II+J) C(II+J) = T END DO JJ = JJ + P DO I = P+1, Q-1 T = C(JJ+P) C(JJ+P) = C(II+I) C(II+I) = T JJ = JJ + I END DO II = II + Q DO I = Q+1, N T = C(II+P) C(II+P) = C(II+Q) C(II+Q) = T II = II + I END DO END *-------------------------------------------------------------------------- *-------------------------------------------------------------------------- *-------------------------------------------------------------------------- *-------------------------------------------------------------------------- *-------------------------------------------------------------------------- *-------------------------------------------------------------------------- *-------------------------------------------------------------------------- *-------------------------------------------------------------------------- * SUBROUTINE SADMVT(N, NU, LOWER, UPPER, INFIN, CORREL, MAXPTS, * ABSEPS, RELEPS, ERROR, VALUE, INFORM) * * A subroutine for computing multivariate t probabilities. * Alan Genz * Department of Mathematics * Washington State University * Pullman, WA 99164-3113 * Email : AlanGenz@wsu.edu * * Parameters * * N INTEGER, the number of variables. * NU INTEGER, the number of degrees of freedom. * LOWER REAL, array of lower integration limits. * UPPER REAL, array of upper integration limits. * INFIN INTEGER, array of integration limits flags: * if INFIN(I) < 0, Ith limits are (-infinity, infinity); * if INFIN(I) = 0, Ith limits are (-infinity, UPPER(I)]; * if INFIN(I) = 1, Ith limits are [LOWER(I), infinity); * if INFIN(I) = 2, Ith limits are [LOWER(I), UPPER(I)]. * CORREL REAL, array of correlation coefficients; the correlation * coefficient in row I column J of the correlation matrix * should be stored in CORREL( J + ((I-2)*(I-1))/2 ), for J < I. * MAXPTS INTEGER, maximum number of function values allowed. This * parameter can be used to limit the time taken. A sensible * strategy is to start with MAXPTS = 1000*N, and then * increase MAXPTS if ERROR is too large. * ABSEPS REAL absolute error tolerance. * RELEPS REAL relative error tolerance. * ERROR REAL, estimated absolute error, with 99% confidence level. * VALUE REAL, estimated value for the integral * INFORM INTEGER, termination status parameter: * if INFORM = 0, normal completion with ERROR < EPS; * if INFORM = 1, completion with ERROR > EPS and MAXPTS * function vaules used; increase MAXPTS to * decrease ERROR; * if INFORM = 2, N > 20 or N < 1. * EXTERNAL FNCMVT INTEGER NL, N, NU, M, INFIN(*), LENWRK, MAXPTS, INFORM, INFIS, & RULCLS, TOTCLS, NEWCLS, MAXCLS DOUBLE PRECISION CORREL(*), LOWER(*), UPPER(*), ABSEPS, RELEPS, & ERROR, VALUE, OLDVAL, D, E, MVTNIT PARAMETER ( NL = 20 ) PARAMETER ( LENWRK = 20*NL**2 ) DOUBLE PRECISION WORK(LENWRK) DOUBLE PRECISION FNCMVT * * [AA (2014-06-25)] next DO loop initializes WORK array, * un-initialized in original code which caused complaints of some compilers * DO I = 1,LENWRK WORK(I) = 0.0D0 ENDDO IF ( N .GT. 20 .OR. N .LT. 1 ) THEN INFORM = 2 VALUE = 0 ERROR = 1 RETURN ENDIF INFORM = MVTNIT( N, NU, CORREL, LOWER, UPPER, INFIN, INFIS, D, E ) M = N - INFIS IF ( M .EQ. 0 ) THEN VALUE = 1 ERROR = 0 ELSE IF ( M .EQ. 1 ) THEN VALUE = E - D ERROR = 2E-16 ELSE * * Call the subregion adaptive integration subroutine * M = M - 1 RULCLS = 1 CALL ADAPT( M, RULCLS, 0, FNCMVT, ABSEPS, RELEPS, * LENWRK, WORK, ERROR, VALUE, INFORM ) MAXCLS = MIN( 10*RULCLS, MAXPTS ) TOTCLS = 0 CALL ADAPT( M, TOTCLS, MAXCLS, FNCMVT, ABSEPS, RELEPS, * LENWRK, WORK, ERROR, VALUE, INFORM ) IF ( ERROR .GT. MAX( ABSEPS, RELEPS*ABS(VALUE) ) ) THEN 10 OLDVAL = VALUE MAXCLS = MAX( 2*RULCLS, MIN( 3*MAXCLS/2, MAXPTS - TOTCLS ) ) NEWCLS = -1 CALL ADAPT( M, NEWCLS, MAXCLS, FNCMVT, ABSEPS, RELEPS, * LENWRK, WORK, ERROR, VALUE, INFORM ) TOTCLS = TOTCLS + NEWCLS ERROR = ABS(VALUE-OLDVAL) + SQRT(RULCLS*ERROR**2/TOTCLS) IF ( ERROR .GT. MAX( ABSEPS, RELEPS*ABS(VALUE) ) ) THEN IF ( MAXPTS - TOTCLS .GT. 2*RULCLS ) GO TO 10 ELSE INFORM = 0 END IF ENDIF ENDIF END * DOUBLE PRECISION FUNCTION FNCMVT(N, W) * * Integrand subroutine * INTEGER N, NUIN, INFIN(*), INFIS DOUBLE PRECISION W(*), LOWER(*), UPPER(*), CORREL(*), D, E INTEGER NL, IJ, I, J, NU PARAMETER ( NL = 20 ) DOUBLE PRECISION COV((NL*(NL+1))/2), A(NL), B(NL), Y(NL) INTEGER INFI(NL) DOUBLE PRECISION PROD, D1, E1, DI, EI, SUM, STDINV, YD, UI, MVTNIT SAVE NU, D1, E1, A, B, INFI, COV DI = D1 EI = E1 PROD = EI - DI IJ = 1 YD = 1 DO I = 1, N UI = STDINV( NU+I-1, DI + W(I)*( EI - DI ) ) Y(I) = UI/YD YD = YD/SQRT( 1 + ( UI - 1 )*( UI + 1 )/( NU + I ) ) SUM = 0 DO J = 1, I IJ = IJ + 1 SUM = SUM + COV(IJ)*Y(J) END DO IJ = IJ + 1 CALL MVTLMS( NU+I, ( A(I+1) - SUM )*YD, ( B(I+1) - SUM )*YD, & INFI(I+1), DI, EI ) PROD = PROD*( EI - DI ) END DO FNCMVT = PROD RETURN * * Entry point for intialization * ENTRY MVTNIT( N, NUIN, CORREL, LOWER, UPPER, INFIN, INFIS, D, E ) MVTNIT = 0 * * Initialization and computation of covariance matrix Cholesky factor * CALL MVTSRT( N, NUIN, LOWER, UPPER, CORREL, INFIN, Y, INFIS, & A, B, INFI, COV, D, E ) NU = NUIN D1 = D E1 = E END SUBROUTINE MVTLMS( NU, A, B, INFIN, LOWER, UPPER ) DOUBLE PRECISION A, B, LOWER, UPPER, STUDNT INTEGER NU, INFIN LOWER = 0 UPPER = 1 IF ( INFIN .GE. 0 ) THEN IF ( INFIN .NE. 0 ) LOWER = STUDNT( NU, A ) IF ( INFIN .NE. 1 ) UPPER = STUDNT( NU, B ) ENDIF END * SUBROUTINE MVTSRT( N, NU, LOWER, UPPER, CORREL, INFIN, Y, INFIS, & A, B, INFI, COV, D, E ) * * Sort limits * INTEGER N, NU, INFI(*), INFIN(*), INFIS DOUBLE PRECISION & A(*), B(*), COV(*), LOWER(*), UPPER(*), CORREL(*), Y(*), D, E INTEGER I, J, K, IJ, II, JMIN, iflag DOUBLE PRECISION SUMSQ, ZERO, TWO, PI, CVDIAG DOUBLE PRECISION AI, BI, SUM, YL, YU, YD DOUBLE PRECISION AMIN, BMIN, DMIN, EMIN, CON, CONODD, CONEVN PARAMETER ( ZERO = 0, TWO = 2, PI = 3.14159 26535 89793 23844 ) IJ = 0 II = 0 INFIS = 0 DO I = 1, N INFI(I) = INFIN(I) IF ( INFI(I) .LT. 0 ) THEN INFIS = INFIS + 1 ELSE A(I) = 0 B(I) = 0 IF ( INFI(I) .NE. 0 ) A(I) = LOWER(I) IF ( INFI(I) .NE. 1 ) B(I) = UPPER(I) ENDIF DO J = 1,I-1 IJ = IJ + 1 II = II + 1 COV(IJ) = CORREL(II) END DO IJ = IJ + 1 COV(IJ) = 1 END DO CONODD = 1/PI CONEVN = 1/TWO DO I = 1, NU - 1 IF ( MOD(I,2) .EQ. 0 ) THEN IF ( I .GT. 2 ) CONEVN = CONEVN*(I-1)/(I-2) ELSE IF ( I .GT. 2 ) CONODD = CONODD*(I-1)/(I-2) ENDIF END DO * * First move any doubly infinite limits to innermost positions * [AA, recoded to avoid GOTO jump outside IF block] * IF ( INFIS .LT. N ) THEN DO I = N, N-INFIS+1, -1 iflag = 0 IF ( INFI(I) .GE. 0 ) THEN DO J = 1, I-1 IF ( INFI(J) .LT. 0 .and. iflag .eq. 0) THEN CALL RCSWAP( J, I, A, B, INFI, N, COV ) iflag = 1 ENDIF END DO ENDIF 10 END DO * * Sort remaining limits and determine Cholesky decomposition * II = 0 YD = 1 DO I = 1, N-INFIS * * Determine the integration limits for variable with minimum * expected probability and interchange that variable with Ith. * EMIN = 1 DMIN = 0 JMIN = I CVDIAG = 0 IJ = II DO J = I, N-INFIS SUM = 0 SUMSQ = 0 DO K = 1, I-1 SUM = SUM + COV(IJ+K)*Y(K) SUMSQ = SUMSQ + COV(IJ+K)**2 END DO IJ = IJ + J SUMSQ = SQRT( MAX( COV(IJ)-SUMSQ, ZERO ) ) IF ( SUMSQ .GT. 0 ) THEN AI = YD*( A(J) - SUM )/SUMSQ BI = YD*( B(J) - SUM )/SUMSQ CALL MVTLMS( NU+J-1, AI, BI, INFI(J), D, E ) IF ( EMIN - DMIN .GE. E - D ) THEN JMIN = J AMIN = AI BMIN = BI DMIN = D EMIN = E CVDIAG = SUMSQ ENDIF ENDIF END DO IF ( JMIN .NE. I ) CALL RCSWAP( I, JMIN, A,B, INFI, N,COV ) * * Compute Ith column of Cholesky factor. * IJ = II + I COV(IJ) = CVDIAG DO J = I+1, N-INFIS IF ( CVDIAG .GT. 0 ) THEN SUM = COV(IJ+I) DO K = 1, I-1 SUM = SUM - COV(II+K)*COV(IJ+K) END DO COV(IJ+I) = SUM/CVDIAG ELSE COV(IJ+I) = 0 ENDIF IJ = IJ + J END DO * * Compute expected value for Ith integration variable and * scale Ith covariance matrix row and limits. * IF ( MOD(NU+I-1,2) .EQ. 0 ) THEN IF ( NU+I-3 .GT. 0 ) CONEVN = CONEVN*(NU+I-2)/(NU+I-3) CON = CONEVN ELSE IF ( NU+I-3 .GT. 0 ) CONODD = CONODD*(NU+I-2)/(NU+I-3) CON = CONODD ENDIF IF ( CVDIAG .GT. 0 ) THEN YL = 0 YU = 0 IF ( INFI(I) .NE. 0 .AND. NU+I-2 .GT. 0 ) & YL = -CON*(NU+I-1)/(NU+I-2) & /( 1 + AMIN**2/(NU+I-1) )**( (NU+I-2)/TWO ) IF ( INFI(I) .NE. 1 .AND. NU+I-2 .GT. 0 ) & YU = -CON*(NU+I-1)/(NU+I-2) & /( 1 + BMIN**2/(NU+I-1) )**( (NU+I-2)/TWO ) Y(I) = ( YU - YL )/( EMIN - DMIN )/YD DO J = 1,I II = II + 1 COV(II) = COV(II)/CVDIAG END DO IF ( INFI(I) .NE. 0 ) A(I) = A(I)/CVDIAG IF ( INFI(I) .NE. 1 ) B(I) = B(I)/CVDIAG ELSE Y(I) = 0 II = II + I ENDIF YD = YD/SQRT( 1 + ( Y(I)*YD + 1 )*( Y(I)*YD - 1 )/(NU+I) ) END DO CALL MVTLMS( NU, A(1), B(1), INFI(1), D, E) ENDIF END *-- DOUBLE PRECISION FUNCTION STUDNT( NU, T ) * * Student t Distribution Function * * T * STUDNT = C I ( 1 + y*y/NU )**( -(NU+1)/2 ) dy * NU -INF * INTEGER NU, J DOUBLE PRECISION T, CSSTHE, SNTHE, POLYN, TT, TS, RN, PI, ZERO PARAMETER ( PI = 3.14159 26535 89793D0, ZERO = 0 ) IF ( NU .EQ. 1 ) THEN STUDNT = ( 1 + 2*ATAN(T)/PI )/2 ELSE IF ( NU .EQ. 2) THEN STUDNT = ( 1 + T/SQRT( 2 + T*T ))/2 ELSE TT = T*T CSSTHE = 1/( 1 + TT/NU ) POLYN = 1 DO J = NU-2, 2, -2 POLYN = 1 + ( J - 1 )*CSSTHE*POLYN/J END DO IF ( MOD( NU, 2 ) .EQ. 1 ) THEN RN = NU TS = T/SQRT(RN) STUDNT = ( 1 + 2*( ATAN(TS) + TS*CSSTHE*POLYN )/PI )/2 ELSE SNTHE = T/SQRT( NU + TT ) STUDNT = ( 1 + SNTHE*POLYN )/2 END IF STUDNT = MAX( ZERO, STUDNT ) ENDIF END *-- DOUBLE PRECISION FUNCTION STDINV( N, Z ) * * Inverse Student t Distribution Function * * STDINV * Z = C I (1 + y*y/N)**(-(N+1)/2) dy * N -INF * * Reference: G.W. Hill, Comm. ACM Algorithm 395 * Comm. ACM 13 (1970), pp. 619-620. * * Conversions to double precision and other modifications by * Alan Genz, 1993-4. * INTEGER N DOUBLE PRECISION Z, P, PHINV, A, B, C, D, X, Y, PI, TWO DOUBLE PRECISION STUDNT, STDJAC PARAMETER ( PI = 3.14159 26535 89793D0, TWO = 2 ) IF ( 0 .LT. Z .AND. Z .LT. 1 ) THEN IF ( N .EQ. 1 ) THEN STDINV = TAN( PI*( 2*Z - 1 )/2 ) ELSE IF ( N .EQ. 2) THEN STDINV = ( 2*Z - 1 )/SQRT( 2*Z*( 1 - Z ) ) ELSE IF ( 2*Z .GE. 1 ) THEN P = 2*( 1 - Z ) ELSE P = 2*Z END IF A = 1/( N - 0.5 ) B = 48/( A*A ) C = ( ( 20700*A/B - 98 )*A - 16 )*A + 96.36 D = ( ( 94.5/( B + C ) - 3 )/B + 1 )*SQRT( A*PI/2 )*N X = D*P Y = X**( TWO/N ) IF ( Y .GT. A + 0.05 ) THEN X = PHINV( P/2 ) Y = X*X IF ( N .LT. 5 ) C = C + 3*( N - 4.5 )*( 10*X + 6 )/100 C = ( ( (D*X - 100)*X/20 - 7 )*X - 2 )*X + B + C Y = ( ( ( ( (4*Y+63)*Y/10+36 )*Y+94.5 )/C-Y-3 )/B + 1 )*X Y = A*Y*Y IF ( Y .GT. 0.002 ) THEN Y = EXP(Y) - 1 ELSE Y = Y*( 1 + Y/2 ) ENDIF ELSE Y = ( ( 1/( ( (N+6)/(N*Y) - 0.089*D - 0.822 )*(3*N+6) ) & + 0.5/(N+4) )*Y - 1 )*(N+1)/(N+2) + 1/Y END IF STDINV = SQRT(N*Y) IF ( 2*Z .LT. 1 ) STDINV = -STDINV IF ( ABS( STDINV ) .GT. 0 ) THEN * * Use one third order correction to the single precision result * X = STDINV D = Z - STUDNT(N,X) STDINV = X + 2*D/( 2/STDJAC(N,X) - D*(N+1)/(N/X+X) ) END IF END IF ELSE * * Use cutoff values for Z near 0 or 1. * STDINV = SQRT( N/( 2D-16*SQRT( 2*PI*N ) )**( TWO/N ) ) IF ( 2*Z .LT. 1 ) STDINV = -STDINV END IF END *-- DOUBLE PRECISION FUNCTION STDJAC( NU, T ) * * Student t Distribution Transformation Jacobean * * T STDINV(NU,T) * I f(y) dy = I f(STDINV(NU,Z) STDJAC(NU,STDINV(NU,Z)) dZ * -INF 0 * INTEGER NU, J DOUBLE PRECISION CONST, NUOLD, PI, T, TT PARAMETER ( PI = 3.14159 26535 89793D0 ) SAVE NUOLD, CONST DATA NUOLD/ 0D0 / IF ( NU .EQ. 1 ) THEN STDJAC = PI*( 1 + T*T ) ELSE IF ( NU .EQ. 2 ) THEN STDJAC = SQRT( 2 + T*T )**3 ELSE IF ( NU .NE. NUOLD ) THEN NUOLD = NU IF ( MOD( NU, 2 ) .EQ. 0 ) THEN CONST = SQRT(NUOLD)*2 ELSE CONST = SQRT(NUOLD)*PI END IF DO J = NU-2, 1, -2 CONST = J*CONST/(J+1) END DO END IF TT = 1 + T*T/NU STDJAC = CONST*TT**( (NU+1)/2 ) IF ( MOD( NU, 2 ) .EQ. 0 ) STDJAC = STDJAC*SQRT( TT ) END IF END * mnormt/NEWS0000644000176200001440000000421113615601731012266 0ustar liggesusersR package 'mnormt' history file ------------------------------- 2020-02-02: 1.5-6 fixed problem connected to use of 'unintialized' variable in Fortan code 2019-12-06: replaced is.matrix(.) with code compliant with changes in R 4.0.0 2016-10-15: 1.5-5 fix a bug in rmt 2016-03-08: 1.5-4 improved NAMESPACE and documentation; more flexible use of mean in {d,p,r}mnorm and {d,p,r}mt; pd.solve transfers dimnames(x) to output. 2015-05-25: 1.5-3 rmt and rmnorm output with d=1 have now the same structure; improved checks on arguments supplied to dmnorm and dmt. 2015-04-02: 1.5-2 new argument 'sqrt' of dmnorm and dmt; limited check of the arguments is introduced (earlier skipped for speed); calls to rmt with a smaller/larger of 'n' generate a sub/superset of values. 2014-06-30: 1.5-1 fixes a bug of parameter checking in dmnorm and dmt 2014-06-25: 1.5-0 improved coding of dmnorm and dmt functions (avoids 'apply'); allow calling pmnorm and pmt with a matrix argument 'x'. 2013-12-04: 1.4-7 .First.lib() removed on request from CRAN, other minor fixes. 2012-01-06: 1.4-5 NAMESPACE introduced on request by the R Core Team. 2011-05-03: 1.4-3 fixed bug as above for sadmvn and sadmvt. 2011-04-28: 1.4-2 fixed bug of biv.not.prob if some (lower=-Inf & upper=Inf). 2011-04-06: 1.4-1 fixed documentation; coding of dmnorm & dmt is straightened; log.det in pd.solve() is returned only on request. 2011-01-16: 1.4-0 pd.solve() introduced; argument 'mean' can now be a matrix for {d,p}mnorm and {d,p}mt. 2009-11-25: 1.3-4 fixed a bug affecting the case d>2 & df=Inf. 2009-03-21: 1.3-3 removed check on the R version on request of the R Core team. 2009-01-26: 1.3-2 minor modification to F77 code to avoid GOTO out of IF block. 2008-06-12: 1.3-0 added Fortran code for the bivariate case; improved R coding. 2007-03-16: 1.2-1 some amendments in documentation. 2006-10-26: 1.2-0 fixed a bug in function rmt. 2006-10-09: 1.1-0 adopt amedend Fortran code of Alan Genz (subtroutine TRESTR). 2006-04-26: 1.0-1 fixed a bug of non-compliance to R programming standards. 2006-01-23: 1.0-0 first version uploaded on CRAN. 2005-nov. : built private version. mnormt/COPYING0000644000176200001440000004307010365160235012626 0ustar liggesusers GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 675 Mass Ave, Cambridge, MA 02139, USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19yy name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Library General Public License instead of this License. mnormt/R/0000755000176200001440000000000013615601355011774 5ustar liggesusersmnormt/R/mnormt.R0000644000176200001440000002145613572705736013455 0ustar liggesusers# R code of package 'mnormt' # Author: Adelchi Azzalini (University of Padua, Italy) dmnorm <- function(x, mean=rep(0,d), varcov, log=FALSE) { d <- if(is.matrix(varcov)) ncol(varcov) else 1 if(d==1) return(dnorm(x, mean, sqrt(varcov), log=log)) x <- if (is.vector(x)) t(matrix(x)) else data.matrix(x) if(ncol(x) != d) stop("mismatch of dimensions of 'x' and 'varcov'") if(is.matrix(mean)) { if ((nrow(x) != nrow(mean)) || (ncol(mean) != d)) stop("mismatch of dimensions of 'x' and 'mean'") } if(is.vector(mean)) mean <- outer(rep(1, nrow(x)), as.vector(matrix(mean,d))) X <- t(x - mean) conc <- pd.solve(varcov, log.det=TRUE) Q <- colSums((conc %*% X)* X) log.det <- attr(conc, "log.det") logPDF <- as.vector(Q + d*logb(2*pi) + log.det)/(-2) if(log) logPDF else exp(logPDF) } rmnorm <- function(n=1, mean=rep(0,d), varcov, sqrt=NULL) { sqrt.varcov <- if(is.null(sqrt)) chol(varcov) else sqrt d <- if(is.matrix(sqrt.varcov)) ncol(sqrt.varcov) else 1 mean <- outer(rep(1,n), as.vector(matrix(mean,d))) drop(mean + t(matrix(rnorm(n*d), d, n)) %*% sqrt.varcov) } pmnorm <- function(x, mean=rep(0, d), varcov, ...) { d <- NCOL(varcov) x <- if (is.vector(x)) matrix(x, 1, d) else data.matrix(x) n <- nrow(x) if(is.vector(mean)) mean <- outer(rep(1, n), as.vector(matrix(mean,d))) if(d == 1) p <- as.vector(pnorm(x, mean, sqrt(varcov))) else { pv <- numeric(n) for (j in 1:n) p <- pv[j] <- if(d == 2) biv.nt.prob(0, lower=rep(-Inf, 2), upper=x[j,], mean[j,], varcov) else sadmvn(lower=rep(-Inf, d), upper=x[j,], mean[j,], varcov, ...) if(n > 1) p <- pv } return(p) } sadmvn <- function(lower, upper, mean, varcov, maxpts=2000*d, abseps=1e-6, releps=0) { if(any(lower > upper)) stop("lower>upper integration limits") if(any(lower == upper)) return(0) d <- as.integer(if(is.matrix(varcov)) ncol(varcov) else 1) varcov <- matrix(varcov, d, d) sd <- sqrt(diag(varcov)) rho <- cov2cor(varcov) lower <- as.double((lower-mean)/sd) upper <- as.double((upper-mean)/sd) if(d == 1) return(pnorm(upper) - pnorm(lower)) infin <- rep(2,d) infin <- replace(infin, (upper == Inf) & (lower > -Inf), 1) infin <- replace(infin, (upper < Inf) & (lower == -Inf), 0) infin <- replace(infin, (upper == Inf) & (lower == -Inf), -1) infin <- as.integer(infin) if(any(infin == -1)) { if(all(infin == -1)) return(1) k <- which(infin != -1) d <- length(k) lower <- lower[k] upper <- upper[k] if(d == 1) return(pnorm(upper) - pnorm(lower)) rho <- rho[k, k] infin <- infin[k] if(d == 2) return(biv.nt.prob(0, lower, upper, rep(0,2), rho)) } lower <- replace(lower, lower == -Inf, 0) upper <- replace(upper, upper == Inf, 0) correl <- as.double(rho[upper.tri(rho, diag=FALSE)]) maxpts <- as.integer(maxpts) abseps <- as.double(abseps) releps <- as.double(releps) error <- as.double(0) value <- as.double(0) inform <- as.integer(0) result <- .Fortran("sadmvn", d, lower, upper, infin, correl, maxpts, abseps, releps, error, value, inform, PACKAGE="mnormt") prob <- result[[10]] attr(prob,"error") <- result[[9]] attr(prob,"status") <- switch(1 + result[[11]], "normal completion", "accuracy non achieved", "oversize") return(prob) } #---- dmt <- function (x, mean=rep(0,d), S, df = Inf, log = FALSE) { if (df == Inf) return(dmnorm(x, mean, S, log = log)) d <- if(is.matrix(S)) ncol(S) else 1 if (d==1) { y <- dt((x-mean)/sqrt(S), df=df, log=log) if(log) y <- (y - 0.5*logb(S)) else y <- y/sqrt(S) return(y) } x <- if (is.vector(x)) t(matrix(x)) else data.matrix(x) if (ncol(x) != d) stop("mismatch of dimensions of 'x' and 'varcov'") if (is.matrix(mean)) {if ((nrow(x) != nrow(mean)) || (ncol(mean) != d)) stop("mismatch of dimensions of 'x' and 'mean'") } if(is.vector(mean)) mean <- outer(rep(1, nrow(x)), as.vector(matrix(mean,d))) X <- t(x - mean) S.inv <- pd.solve(S, log.det=TRUE) Q <- colSums((S.inv %*% X) * X) logDet <- attr(S.inv, "log.det") logPDF <- (lgamma((df + d)/2) - 0.5 * (d * logb(pi * df) + logDet) - lgamma(df/2) - 0.5 * (df + d) * logb(1 + Q/df)) if(log) logPDF else exp(logPDF) } rmt <- function(n=1, mean=rep(0,d), S, df=Inf, sqrt=NULL) { sqrt.S <- if(is.null(sqrt)) chol(S) else sqrt d <- if(is.matrix(sqrt.S)) ncol(sqrt.S) else 1 x <- if(df==Inf) 1 else rchisq(n, df)/df z <- rmnorm(n, rep(0, d), sqrt=sqrt.S) mean <- outer(rep(1, n), as.vector(matrix(mean,d))) drop(mean + z/sqrt(x)) } pmt <- function(x, mean=rep(0, d), S, df=Inf, ...){ d <- NCOL(S) x <- if(is.vector(x)) matrix(x, 1, d) else data.matrix(x) n <- nrow(x) if(is.vector(mean)) mean <- outer(rep(1, n), as.vector(matrix(mean,d))) if(d == 1) p <- as.vector(pt((x-mean)/sqrt(S), df=df)) else { pv <- numeric(n) for (j in 1:n) p <- pv[j] <- if(d == 2) biv.nt.prob(df, lower=rep(-Inf, 2), upper=x[j,], mean[j,], S) else sadmvt(df, lower=rep(-Inf, d), upper=x[j,], mean[j,], S, ...) if(n > 1) p <- pv } return(p) } sadmvt <- function(df, lower, upper, mean, S, maxpts=2000*d, abseps=1e-6, releps=0) { if(df == Inf) return(sadmvn(lower, upper, mean, S, maxpts, abseps, releps)) if(any(lower > upper)) stop("lower>upper integration limits") if(any(lower == upper)) return(0) if(round(df) != df) warning("non integer df is rounded to integer") df <- as.integer(round(df)) d <- as.integer(if(is.matrix(S)) ncol(S) else 1) S <- matrix(S, d, d) sd <- sqrt(diag(S)) rho <- cov2cor(S) lower <- as.double((lower-mean)/sd) upper <- as.double((upper-mean)/sd) if(d == 1) return(pt(upper, df) - pt(lower, df)) infin <- rep(2,d) infin <- replace(infin, (upper == Inf) & (lower > -Inf), 1) infin <- replace(infin, (upper < Inf) & (lower == -Inf), 0) infin <- replace(infin, (upper == Inf) & (lower == -Inf), -1) infin <- as.integer(infin) if(any(infin == -1)) { if(all(infin == -1)) return(1) k <- which(infin != -1) d <- length(k) lower <- lower[k] upper <- upper[k] if(d == 1) return(pt(upper, df=df) - pt(lower, df=df)) rho <- rho[k, k] infin <- infin[k] if(d == 2) return(biv.nt.prob(df, lower, upper, rep(0,2), rho)) } lower <- replace(lower, lower == -Inf, 0) upper <- replace(upper, upper == Inf, 0) correl <- rho[upper.tri(rho, diag=FALSE)] maxpts <- as.integer(maxpts) abseps <- as.double(abseps) releps <- as.double(releps) error <- as.double(0) value <- as.double(0) inform <- as.integer(0) result <- .Fortran("sadmvt", d, df, lower, upper, infin, correl, maxpts, abseps, releps, error, value, inform, PACKAGE="mnormt") prob <- result[[11]] attr(prob,"error") <- result[[10]] attr(prob,"status") <- switch(1+result[[12]], "normal completion", "accuracy non achieved", "oversize") return(prob) } biv.nt.prob <- function(df, lower, upper, mean, S){ if(any(dim(S) != c(2,2))) stop("dimensions mismatch") if(length(mean) != 2) stop("dimensions mismatch") if(round(df) != df) warning("non integer df is rounded to integer") nu <- if(df upper)) stop("lower>upper integration limits") if(any(lower == upper)) return(0) infin <- c(2,2) infin <- replace(infin, (upper == Inf) & (lower > -Inf), 1) infin <- replace(infin, (upper < Inf) & (lower == -Inf), 0) infin <- replace(infin, (upper == Inf) & (lower == -Inf), -1) infin <- as.integer(infin) if(any(infin == -1)) { if(all(infin == -1)) return(1) k <- which(infin != -1) return(pt(upper[k], df=df) - pt(lower[k], df=df)) } lower <- replace(lower, lower == -Inf, 0) upper <- replace(upper, upper == Inf, 0) rho <- as.double(rho) prob <- as.double(0) a <- .Fortran("smvbvt", prob, nu, lower, upper, infin, rho, PACKAGE="mnormt") return(a[[1]]) } pd.solve <- function(x, silent=FALSE, log.det=FALSE) { if(is.null(x)) return(NULL) if(any(is.na(x))) {if(silent) return (NULL) else stop("NA's in x") } if(length(x) == 1) x <- as.matrix(x) if(!(inherits(x, "matrix"))) {if(silent) return(NULL) else stop("x is not a matrix")} if(max(abs(x - t(x))) > .Machine$double.eps) {if(silent) return (NULL) else stop("x appears to be not symmetric") } x <- (x + t(x))/2 u <- try(chol(x, pivot = FALSE), silent = silent) if(inherits(u, "try-error")) { if(silent) return(NULL) else stop("x appears to be not positive definite") } inv <- chol2inv(u) if(log.det) attr(inv, "log.det") <- 2 * sum(log(diag(u))) dimnames(inv) <- rev(dimnames(x)) return(inv) } .onLoad <- function(library, pkg) { library.dynam("mnormt", pkg, library) invisible() } mnormt/MD50000644000176200001440000000120213615767442012110 0ustar liggesusers18810669f13b87348459e611d31ab760 *COPYING cdd9aa8be3a6b0dfc7ea79c45271c7bf *ChangeLog e163394a166f35b8fe4be62e719b1ad9 *DESCRIPTION 1dd2a7082fe30724bf4731703ff32395 *INDEX 59a70a90c29823d59abb5918617ef85f *NAMESPACE 68a194b98eb50071d3d3d7ebc71fea36 *NEWS 3ad036630a87e54da3a5669f93b6cbc4 *R/mnormt.R 34c9e3fe8edb7374af9b84dde8036195 *inst/CITATION c6f01150cb5daff7ba0aed3f1200c272 *man/dmnorm.Rd 91f5df9196ebdcf859a3c48679dda690 *man/dmt.Rd b5b67965fb74c35a296d3cd3d57ff64a *man/mnormt-package.Rd fdf8bdc0bd32882cd29bcf93e6024bb0 *man/pd.solve.Rd cc41051046bdd43c68311e28c702b78e *src/biv-nt.f 712e27ee1dc23ae62696023226e98aa7 *src/sadmvnt.f mnormt/INDEX0000644000176200001440000000055412247625354012376 0ustar liggesusersbiv.nt.prob rectagle probabilities of bivariate normal and "t" dmnorm multivariate normal distribution dmt multivariate "t" distribution pd.solve inverse of a symmetric positive-definite matrix sadmvn rectangle probabilities of multivariate normal sadmvt rectangle probabilities of multivariate "t" mnormt/inst/0000755000176200001440000000000013000146544012540 5ustar liggesusersmnormt/inst/CITATION0000644000176200001440000000173513000146544013703 0ustar liggesuserscitHeader("To cite the 'mnormt' package in publications use:") if(!exists("meta") || is.null(meta)) meta <- packageDescription("mnormt") citEntry(entry="manual", title = paste("The {R} package \\texttt{mnormt}: ", "The multivariate normal and $t$ distributions (version ", meta$Version, ")", sep=""), author = personList( person("Adelchi", "Azzalini", role=c("aut", "cre")), person("Alan", "Genz", role="aut", comment="Fortran code")), year = substr(meta$Date, 1, 4), url = "http://azzalini.stat.unipd.it/SW/Pkg-mnormt", textVersion = paste("Azzalini, A. and Genz, A. (", substr(meta$Date, 1, 4), "). ", "The R package 'mnormt': ", "The multivariate normal and 't' distributions ", "(version ", meta$Version, "). ", "URL http://azzalini.stat.unipd.it/SW/Pkg-mnormt", sep="") )