//******************************************
BOOLEAN PERMUTATION::lazy_advance(
TRANSPOSITION & transp) //out
{
//advance one transposition at a time
nexper(its_len, its_array_p, its_more_pmuts, transp.x, transp.y);
return its_more_pmuts;
}
void mvn1(int m, double w[], double x[], double r[][M], int nsim, double eps,
double *pr, double *sd, int *ifail)
/* first order approximation for conditional probabilities */
/* ref. Joe (1993). Approximations to Multivariate Normal Rectangle
Probabilities Based on Conditional Expectations*/
/* INPUT
m = dimension of multivariate normal probability
w = vector of lower bounds
x = vector of upper bounds
r = correlation matrix (1's on the diagonal)
nsim = number of random permutations used
[ nsim=0 for enumerating all permutations, otherwise random perms
nsim=0 recommended for m<=6 ]
eps = error bound for 2-D bivariate probabilities (1.e-6 recommended)
OUTPUT
pr = probability of rectangle: P(w_i<X_i<z_i, i=1,...,n)
sd = measurement of accuracy (SD from the permuted conditional prob's)
ifail = code for whether prob was succesfully computed
(ifail =0 for success, ifail >0 for failure)
ROUTINES CALLED (directly or indirectly):
mulnor (Schervish's MVN prob)
bivnor (Donnelly's bivariate normal upper quadrant prob)
pnorms (univariate standard normal cdf)
approx1, cond1 (approx to conditional probs)
nexper (generate permutations systematically)
isamp (generate random permutations)
gepp (linear system solver, Gaussian elim with partial pivoting)
*/
/* w[0], x[0], r[0][], r[][0] not used here */
/* No checks are done on r, eg., positive definiteness not checked,
an error may or may not occur if r is not a corr. matrix (user-beware) */
/* for the positive equicorrelated case, use
the 1-dimensional integral given on page 193 of Tong's book
on the multivariate normal distribution */
{ double lb[8],ub[8],bound,eps1,s[22],tem;
double p[M],pp[M][M],sc,sc2,rect;
int i,ifault,inf[8],m1,j,ii,is,even,a[M],idet,isim,k,mm;
int typ[M];
void isamp(int *, int);
double pnorms(double);
void mulnor(double [], double [], double [], double, int,
int [], double *, double *, int *);
void nexper(int, int [], int *, int *);
void approx1(double [], double [], double [][M], int, int [],
double [], double [][M], double *, int *);
*ifail=0;
for(i=1;i<=m;i++) { if(w[i]>=x[i]) { *ifail=1; *pr=0.; *sd=0.; return;}}
if(m==1) { *pr=pnorms(x[1])-pnorms(w[1]); *sd=1.e-6; return;}
if(m==2)
{ inf[0]=2; inf[1]=2; eps1=1.e-6;
lb[0]=w[1]; lb[1]=w[2]; ub[0]=x[1]; ub[1]=x[2]; s[0]=r[1][2];
mulnor(ub,lb,s,eps1,m,inf,&rect,&bound,&ifault);
if(ifault!=0) printf("error in mulnor %d\n", ifault);
*pr=rect; *sd=bound; *ifail=ifault; return;
}
/* m>=3 */
/* some changes for x_i or w_i = oo, May 13, 1994 */
/* for(i=1;i<=m;i++)
{ p[i]=pnorms(x[i])-pnorms(w[i]);}
m1=2; inf[0]=2; inf[1]=2;*/
for(i=1;i<=m;i++)
{ if (w[i]<=-5.) { typ[i]=1; p[i]=pnorms(x[i]);}
else if(x[i]>=5.) {typ[i]=0; p[i]=1.-pnorms(w[i]);}
else { typ[i]=2; p[i]=pnorms(x[i])-pnorms(w[i]);}
}
m1=2;
for(i=1;i<=m;i++) pp[i][i]=p[i]*(1.-p[i]);
for(i=1;i<m;i++)
{ for(j=i+1;j<=m;j++)
{ lb[0]=w[i]; lb[1]=w[j]; ub[0]=x[i]; ub[1]=x[j];
s[0]=r[i][j];
inf[0]=typ[i]; inf[1]=typ[j];
mulnor(ub,lb,s,eps,m1,inf,&tem,&bound,&ifault);
if(ifault!=0)
{ printf("error in mulnor %d\n", ifault);
*pr=0.; *sd=bound; *ifail=ifault; return;
}
pp[i][j]=tem-p[j]*p[i];
pp[j][i]=pp[i][j];
}
}
if(nsim==0) { /*enumerate all permutations */
is=0; ii=0; sc=0.; sc2=0.;
for(i=2,mm=1;i<=m;i++) mm*=i;
for(k=1;k<=mm;k++)
/*do*/ { nexper(m,a,&is,&even);
if(a[1]<a[2])
{ approx1(w,x,r,m,a,p,pp,&rect,&idet);
if(idet==1) { ii++; sc+=rect; sc2+=rect*rect;
/*printf("%8.4f", rect);*/
}
// HJ check May 11, 2004
//printf("%d %8.4f\n", k,rect);
}
} /*while(is==1);*/
/*printf("\n");*/
}
else /* random permutations */
{ ii=0; sc=0.; sc2=0.;
for(isim=1;isim<=nsim;isim++)
{ isamp(a,m);
approx1(w,x,r,m,a,p,pp,&rect,&idet);
if(idet==1) { ii++; sc+=rect; sc2+=rect*rect;}
}
}
sc/=ii; sc2=(sc2-ii*sc*sc)/(ii-1.);
*pr=sc; if(sc2>0.) *sd=sqrt(sc2); else *sd=0.;
/* printf(" mean approx=%9.5f %9.5f %3d\n\n",sc,*sd,ii);*/
}
void mvn2(int m, double w[], double x[], double r[][M], int nsim, double eps,
double *pr, double *sd, int *ifail)
/* int igenz, double *pr, double *sd, int *ifail)
igenz = 1 if genz's method used for 4-dim MVN prob,
otherwise schervish's routine is used.
(code allowing igenz=1 has been commented out,
genz's method is slower for 4D)
*/
/* second order approximation for conditional probabilities */
/* ref. Joe (1993). Approximations to Multivariate Normal Rectangle
Probabilities Based on Conditional Expectations*/
/* INPUT
m = dimension of multivariate normal probability
w = vector of lower bounds
x = vector of upper bounds
r = correlation matrix (1's on the diagonal)
nsim = number of random permutations used
[ nsim=0 for enumerating all permutations, otherwise random perms
nsim=0 recommended for m<=6 ]
eps = error bound for 4-D bivariate probabilities (1.e-4 or 1.e-5
recommended depending on m)
OUTPUT
pr = probability of rectangle: P(w_i<X_i<z_i, i=1,...,n)
sd = measurement of accuracy (SD from the permuted conditional prob's)
ifail = code for whether prob was succesfully computed
(ifail =0 for success, ifail >0 for failure)
ROUTINES CALLED (directly or indirectly):
mulnor (Schervish's MVN prob)
bivnor (Donnelly's bivariate normal upper quadrant prob)
pnorms (univariate standard normal cdf)
approx2, cond2 (approx to conditional probs)
iorder (auxiliary routine)
nexper (generate permutations systematically)
isamp (generate random permutations)
gepp (linear system solver, Gaussian elim with partial pivoting)
*/
/* w[0], x[0], r[0][], r[][0] not used here */
/* No checks are done on r, eg., positive definiteness not checked,
an error may or may not occur if r is not a corr. matrix (user-beware) */
/* for the positive equicorrelated case, use
the 1-dimensional integral given on page 193 of Tong's book
on the multivariate normal distribution */
{ double rect;
double lb[8],ub[8],eps1,bound,s[22];
double p[M],pp[M][M],sc,sc2;
double p3[M][M][M],p4[M][M][M][M],q4[M][M][M][M],tem;
double rr[M][M];
int i,ifault,inf[8],m1,k,j,ii,is,even,a[M],idet,isim;
int m2,mm,l,i1,j1,k1,l1;
int typ[M];
void isamp(int *, int);
double pnorms(double);
void mulnor(double [], double [], double [], double, int,
int [], double *, double *, int *);
void iorder(int, int, int, int, int *, int *, int *, int *);
void nexper(int, int [], int *, int *);
void approx2(int, int [],
double [], double [][M], double [][M][M], double [][M][M][M],
double *, int *);
*ifail=0;
for(i=1;i<=m;i++) { if(w[i]>=x[i]) { *ifail=1; *pr=0.; *sd=0.; return;}}
if(m==1) { *pr=pnorms(x[1])-pnorms(w[1]); *sd=1.e-6; return;}
if(m==2)
{ inf[0]=2; inf[1]=2; eps1=1.e-6;
lb[0]=w[1]; lb[1]=w[2]; ub[0]=x[1]; ub[1]=x[2]; s[0]=r[1][2];
mulnor(ub,lb,s,eps1,m,inf,&rect,&bound,&ifault);
if(ifault!=0) printf("error in mulnor %d\n", ifault);
*pr=rect; *sd=bound; *ifail=ifault; return;
}
if(m==3 || m==4)
{ eps1=1.e-6; /* changed on Apr 21, 1994*/ eps1=1.e-5;
for(i=0;i<m;i++) {inf[i]=2; lb[i]=w[i+1]; ub[i]=x[i+1];}
for(i=2,k=0;i<=m;i++)
{ for(j=1;j<i;j++) { s[k]=r[i][j]; k++;}}
/* s[0]=r[1][2]; s[1]=r[1][3]; s[2]=r[2][3];*/
/* addition on Apr 24, 1994 */
for(i=0;i<m;i++)
{ if(ub[i]>=5.) inf[i]=0;
if(lb[i]<=-5.) inf[i]=1;
}
mulnor(ub,lb,s,eps1,m,inf,&rect,&bound,&ifault);
if(ifault!=0) printf("error in mulnor %d\n", ifault);
*pr=rect; *sd=bound; *ifail=ifault; return;
}
/* m>=5 */
eps1=1.e-6; m1=2;
for(i=1;i<=4;i++) rr[i][i]=1.;
for(i=1;i<=m;i++)
{ p[i]=pnorms(x[i])-pnorms(w[i]); pp[i][i]=p[i];}
for(i=0;i<4;i++) inf[i]=2;
for(i=1;i<m;i++)
{ for(j=i+1;j<=m;j++)
{ lb[0]=w[i]; lb[1]=w[j]; ub[0]=x[i]; ub[1]=x[j];
s[0]=r[i][j];
mulnor(ub,lb,s,eps1,m1,inf,&tem,&bound,&ifault);
if(ifault!=0) printf("error in mulnor %d\n", ifault);
pp[i][j]=tem;
pp[j][i]=pp[i][j];
}
}
/* 3 and 4 dimensional arrays (of moments) */
eps1=1.e-5; m1=3; m2=4;
/* addition on Apr 25, 1994 */
for(i=1;i<=m;i++)
{ if(x[i]>=5.) typ[i]=0;
else if(w[i]<=-5.) typ[i]=1;
else typ[i]=2;
}
for(i=1;i<=m;i++)
{ for(j=1;j<m;j++)
{ for(k=j+1;k<=m;k++)
{ if(i==j || i==k) { p3[i][j][k]=pp[j][k]; p3[i][k][j]=pp[j][k];}
else
{ ub[0]=x[i]; ub[1]=x[j]; ub[2]=x[k];
lb[0]=w[i]; lb[1]=w[j]; lb[2]=w[k];
/* addition on Apr 25, 1994 */
inf[0]=typ[i]; inf[1]=typ[j]; inf[2]=typ[k];
s[0]=r[i][j]; s[1]=r[i][k]; s[2]=r[j][k];
mulnor(ub,lb,s,eps1,m1,inf,&tem,&bound,&ifault);
if(ifault!=0) printf("error in mulnor %d\n", ifault);
p3[i][j][k]=tem; p3[i][k][j]=tem;
}
}
}
}
for(i=1;i<m;i++)
{ for(j=i+1;j<=m;j++)
{ for(k=1;k<m;k++)
{ for(l=k+1;l<=m;l++)
{ if(i==k && j==l) p4[i][j][k][l]=pp[i][j]*(1.-pp[i][j]);
else if (i==k) p4[i][j][k][l]=p3[l][i][j]-pp[i][j]*pp[k][l];
else if (j==l) p4[i][j][k][l]=p3[k][i][j]-pp[i][j]*pp[k][l];
else if (j==k) p4[i][j][k][l]=p3[l][i][j]-pp[i][j]*pp[k][l];
else if (i==l) p4[i][j][k][l]=p3[k][i][j]-pp[i][j]*pp[k][l];
/* else if (m==4) p4[i][j][k][l]=0.;*/
else if(i<j && j<k && k<l)
{ /* schervish's routine */
ub[0]=x[i]; ub[1]=x[j]; ub[2]=x[k]; ub[3]=x[l];
lb[0]=w[i]; lb[1]=w[j]; lb[2]=w[k]; lb[3]=w[l];
s[0]=r[i][j]; s[1]=r[i][k]; s[2]=r[j][k];
s[3]=r[i][l]; s[4]=r[j][l]; s[5]=r[k][l];
/* addition on Apr 25, 1994 */
inf[0]=typ[i]; inf[1]=typ[j]; inf[2]=typ[k]; inf[3]=typ[l];
mulnor(ub,lb,s,eps,m2,inf,&tem,&bound,&ifault);
if(ifault!=0) printf("error in mulnor %d\n", ifault);
q4[i][j][k][l]=tem;
p4[i][j][k][l]=tem-pp[i][j]*pp[k][l];
}
else
{ iorder(i,j,k,l,&i1,&j1,&k1,&l1);
p4[i][j][k][l]=q4[i1][j1][k1][l1]-pp[i][j]*pp[k][l];
}
p4[j][i][k][l]=p4[i][j][k][l];
p4[i][j][l][k]=p4[i][j][k][l];
p4[j][i][l][k]=p4[i][j][k][l];
}
}
}
}
for(i=1;i<=m;i++)
{ for(j=1;j<m;j++)
{ for(k=j+1;k<=m;k++)
{ p3[i][j][k]-=p[i]*pp[j][k]; p3[i][k][j]=p3[i][j][k];
}
}
}
if(nsim==0) { /*enumerate all permutations */
for(i=2,mm=1;i<=m;i++) mm*=i;
is=0; ii=0; sc=0.; sc2=0.;
for(k=1;k<=mm;k++)
{ nexper(m,a,&is,&even);
if(a[1]<a[2] && a[2]<a[3] && a[3]<a[4])
{ /*approx2(w,x,r,m,a,p,pp,p3,p4,&rect,&idet);*/
approx2(m,a,p,pp,p3,p4,&rect,&idet);
if(idet==1) { ii++; sc+=rect; sc2+=rect*rect;
/* printf("%8.4f", rect);*/
}
}
}/* while(is==1);*/
/*printf("\n");*/
}
else /* random permutations */
{ ii=0; sc=0.; sc2=0.;
for(isim=1;isim<=nsim;isim++)
{ isamp(a,m);
approx2(m,a,p,pp,p3,p4,&rect,&idet);
if(idet==1) { ii++; sc+=rect; sc2+=rect*rect;}
}
}
sc/=ii; sc2=(sc2-ii*sc*sc)/(ii-1.);
*pr=sc; if(sc2>0.) *sd=sqrt(sc2); else *sd=0.;
/* printf(" mean approx=%9.5f %9.5f %3d\n\n",sc,*sd,ii);*/
}
