double gennor(lua_RNG *o,double av,double sd)
/*
**********************************************************************
GENerate random deviate from a NORmal distribution
Function
Generates a single random deviate from a normal distribution
with mean, AV, and standard deviation, SD.
Arguments
av --> Mean of the normal distribution.
sd --> Standard deviation of the normal distribution.
Method
Renames SNORM from TOMS as slightly modified by BWB to use RANF
instead of SUNIF.
For details see:
Ahrens, J.H. and Dieter, U.
Extensions of Forsythe's Method for Random
Sampling from the Normal Distribution.
Math. Comput., 27,124 (Oct. 1973), 927 - 937.
**********************************************************************
*/
{
static double gennor;
gennor = sd*snorm(o)+av;
return gennor;
}
/* inputs
d0 = d = dimension
cpar = parameter vector with correlations with latent and df for mvt
copcode = copula code (see the above #define)
output
zvec = random normal or t d-vector with 1-factor structure
*/
void sim1factmvt(int *d0, double *cpar, int *copcode, double *zvec)
{ int cop,j,d;
double df,w1,z,rho,rhe,denom;
double snorm(),rgamma(double,double); // in file rt.c
cop=*copcode; d=*d0; df=cpar[d];
//printf("copcode=%d\n", cop);
w1=snorm(); // latent variable
//printf("%f ", w1);
for(j=0;j<d;j++)
{ z=snorm();
//printf("%f ", z);
rho=cpar[j]; rhe=sqrt(1.-rho*rho);
zvec[j]=rho*w1+rhe*z;
}
//printf("\n");
if(cop==BVT && df<300. && df>0.) // bivariate t
{ denom=rgamma(df/2.,2.) / df; denom=sqrt(denom);
for(j=0;j<d;j++) zvec[j]/=denom;
}
}
double PoissonRandom(double mean)
{
// Call into ranlib for the Poisson deviate.
if (mean == 0) {
return 0;
} else if (mean > 1e3) {
return (mean + sqrt(mean)*snorm());
} else if (mean > 1e6) {
return mean;
} else
return static_cast<double>(ignpoi(static_cast<float>(mean)));
}
// propose a new value of the population parameters
virtual svector Propose() {
// get the unit proposal
for (int k=0; k<dtheta; k++) {
snorm_deviate[k] = snorm(rng);
}
// transform unit proposal so that is has a multivariate normal distribution
svector proposed_theta(dtheta);
std::fill(proposed_theta.begin(), proposed_theta.end(), 0.0);
int cholfact_index = 0;
for (int j=0; j<dtheta; j++) {
for (int k=0; k<(j+1); k++) {
// cholfact is lower-diagonal matrix stored as a 1-d array
scaled_proposal[j] += cholfact[cholfact_index] * snorm_deviate[k];
cholfact_index++;
}
proposed_theta[j] = theta[j] + scaled_proposal[j];
}
return proposed_theta;
}
/*-------------------*
* Function Normal |
*--------------------*
| Returns Normal rv with mean mu, variance sigsq.
| Uses snorm function of Brown and Lovato. By JKP
*/
double RNormal(double mu, double sd)
{
double snorm();
return (mu+ sd*snorm());
}
void semip_gc(
//Output Arguments
double *bdraw, // draws for beta (ndraw - nomit,k) matrix
double *adraw, // draws for regional effects, a, (m,1) vector
double *pdraw, // draws for rho (ndraw - nomit,1) vector
double *sdraw, // draws for sige (ndraw - nomit,1) vector
double *rdraw, // draws for rval (ndraw - nomit,1) vector (if mm != 0)
double *vmean, // mean of vi draws (n,1) vector
double *amean, // mean of a-draws (m,1) vector
double *zmean, // mean of latent z-draws (n,1) vector
double *yhat, // mean of posterior predicted y (n,1) vector
//Input Arguments
double *y, // (n,1) lhs vector with 0,1 values
double *x, // (n,k) matrix of explanatory variables
double *W, // (m,m) weight matrix
int ndraw, // # of draws
int nomit, // # of burn-in draws to omit
int nsave, // # of draws saved (= ndraw - nomit)
int n, // # of observations
int k, // # of explanatory variables
int m, // # of regions
int *mobs, // (m,1) vector of obs numbers in each region
double *a, // (m,1) vector of regional effects
double nu, // prior parameter for sige
double d0, // prior parameter for sige
double rval, // hyperparameter r
double mm, // prior parameter for rval
double kk, // prior parameter for rval
double *detval, // (ngrid,2) matrix with [rho , log det values]
int ngrid, // # of values in detval (rows)
double *TI, // prior var-cov for beta (inverted in matlab)
double *TIc) // prior var-cov * prior mean
{
// Local Variables
int i,j,l,iter,invt,accept,rcount,cobs,obsi,zflag;
double rmin,rmax,sige,chi,ee,ratio,p,rho,rho_new;
double junk,aBBa,vsqrt,ru,rhox,rhoy,phi,awi,aw2i,bi,di;
double *z,*tvec,*e,*e0,*xb,*mn,*ys,*limit1,*limit2,*zmt;
double *bhat,*b0,*b0tmp,*v,*vv,*b1,*b1tmp,*Bpa,*rdet,*ldet,*w1;
double **xs,**xst,**xsxs,**A0,**A1,**Bpt,**Bp,**xmat,**W2;
double *Wa, **Wmat;
double c0, c1,c2;
// Allocate Matrices and Vectors
xs = dmatrix(0,n-1,0,k-1);
xst = dmatrix(0,k-1,0,n-1);
xsxs = dmatrix(0,k-1,0,k-1);
A0 = dmatrix(0,k-1,0,k-1);
A1 = dmatrix(0,m-1,0,m-1);
Bp = dmatrix(0,m-1,0,m-1);
Bpt = dmatrix(0,m-1,0,m-1);
xmat = dmatrix(0,n-1,0,k-1);
W2 = dmatrix(0,m-1,0,m-1);
Wmat = dmatrix(0,m-1,0,m-1);
z = dvector(0,n-1);
tvec = dvector(0,n-1);
e = dvector(0,n-1);
e0 = dvector(0,n-1);
xb = dvector(0,n-1);
mn = dvector(0,n-1);
ys = dvector(0,n-1);
limit1 = dvector(0,n-1);
limit2 = dvector(0,n-1);
zmt = dvector(0,n-1);
vv = dvector(0,n-1);
bhat = dvector(0,k-1);
b0 = dvector(0,k-1);
b0tmp = dvector(0,k-1);
v = dvector(0,m-1);
b1 = dvector(0,m-1);
b1tmp = dvector(0,m-1);
Bpa = dvector(0,m-1);
w1 = dvector(0,m-1);
rdet = dvector(0,ngrid-1);
ldet = dvector(0,ngrid-1);
Wa = dvector(0,m-1);
// Initializations
junk = 0.0; // Placeholder for mean in meanvar()
rho = 0.5;
sige = 1.0;
zflag = 0; // a flag for 0,1 y-values
// Initialize (z,vv,limits,tvec)
for(i=0; i<n; i++){
z[i] = y[i];
vv[i] = 1.0;
tvec[i] = 1.0;
if (y[i] == 0.0){
limit1[i] = -10000;
limit2[i] = 0.0;
zflag = 1; // we have 0,1 y-values so sample z
}else{
limit1[i] = 0.0;
limit2[i] = 10000;
}
}
// Initialize v, b1tmp, Bp
for(i=0; i<m; i++){
v[i] = 1.0;
b1tmp[i] = 1.0;
for(j=0; j<m; j++){
if (j == i){
Bp[i][j] = 1 - rho*W[i + j*m];
}else{
Bp[i][j] = - rho*W[i + j*m];
}
Wmat[i][j] = W[i + j*m];
}
}
// Parse detval into rdet and ldet vectors
// and define (rmin,rmax)
for(i=0; i<ngrid; i++){
j=0;
rdet[i] = detval[i + j*ngrid];
j=1;
ldet[i] = detval[i + j*ngrid];
}
rmin = rdet[0];
rmax = rdet[ngrid-1];
// Put x into xmat
for(i=0; i<n; i++){
for(j=0; j<k; j++)
xmat[i][j] = x[i + j*n];
}
// Compute matrices to be used for updating a-vector
if(m > 100){ // Used only for large m
for(i=0; i<m; i++){
w1[i] = 0.0; // Form w1[i]
for(j=0;j<m;j++){
w1[i] = w1[i] + (W[j + i*m]*W[j + i*m]);
}
for(j=0;j<m;j++){ // Form W2[i][*]
W2[i][j] = 0.0;
if(j != i){
for(l=0;l<m;l++){
W2[i][j] = W2[i][j] + W[l + i*m]*W[l + j*m];
}
} // Note that W2[i][i] = 0.0 by construction
}
}
} // End if(m > 10)
// ======================================
// Start the Sampler
// ======================================
for(iter=0; iter<ndraw; iter++){
// UPDATE: beta
// (1) Apply stnd devs (vsqrt) to x, z, z - tvec
for(i=0; i<n; i++){
vsqrt = sqrt(vv[i]);
zmt[i] = (z[i] - tvec[i])/vsqrt;
for(j=0; j<k; j++)
xs[i][j] = x[i + j*n]/vsqrt;
}
// (2) Construct A0 matrix
transpose(xs,n,k,xst); // form xs'
matmat(xst,k,n,xs,k,xsxs); // form xs'*xs
for(i=0; i<k; i++){ // form xs'*xs + TI
for(j=0; j<k; j++)
A0[i][j] = xsxs[i][j] + TI[i + j*k];
}
invt = inverse(A0, k); // replace A0 = inv(A0)
if (invt != 1)
mexPrintf("semip_gc: Inversion error in beta conditional \n");
// (3) Construct b0 vector
matvec(xst,k,n,zmt,b0tmp); //form xs'*zmt
for(i=0; i<k; i++){
b0tmp[i] = b0tmp[i] + TIc[i]; //form b0tmp = xs'*zmt + TIc
}
matvec(A0,k,k,b0tmp,b0); //form b0 = A0*b0tmp
// (4) Do multivariate normal draw from N(b0,A0)
normal_rndc(A0, k, bhat); // generate N(0,A0) vector
for(i=0; i<k; i++){
bhat[i] = bhat[i] + b0[i]; // add mean vector, b0
}
// (5) Now update related values:
matvec(xmat,n,k,bhat,xb); // form xb = xmat*bhat
for(i=0; i<n; i++){ // form e0 = z - x*bhat
e0[i] = z[i] - xb[i];
}
cobs = 0;
for(i=0; i<m; i++){ // form b1tmp = e0i/v[i]
obsi = mobs[i];
b1tmp[i] = 0.0;
for(j=cobs; j<cobs + obsi; j++){
b1tmp[i] = b1tmp[i] + (e0[j]/v[i]);
}
cobs = cobs + obsi;
}
// UPDATE: a
if(m <= 100){ // For small m use straight inverse
// (1) Define A1 and b1
transpose(Bp,m,m,Bpt); // form Bp'
matmat(Bpt,m,m,Bp,m,A1); // form Bp'*Bp
for(i=0; i<m; i++){ // form A1 = (1/sige)*Bp'Bp + diag(mobs/v)
for(j=0; j<m; j++){
if (j == i){
A1[i][j] = (1/sige)*A1[i][j] + ((double)mobs[i])/v[i];
}else{
A1[i][j] = (1/sige)*A1[i][j];
}
}
}
inverse(A1,m); // set A1 = inv(A1)
matvec(A1,m,m,b1tmp,b1); // form b1
// (2) Do multivariate normal draw from N(b1,A1)
normal_rndc(A1,m,a); // generate N(0,A1) vector
for(i=0; i<m; i++){
a[i] = a[i] + b1[i]; // add mean vector, b1
}
}else{ // For large m use marginal distributions
cobs = 0;
for(i=0;i<m;i++){
obsi = mobs[i];
phi = 0.0;
for(j=cobs;j<cobs+obsi;j++){
phi = phi + ((z[j] - xb[j])/v[i]); // form phi
}
awi = 0.0;
aw2i = 0.0;
for(j=0;j<m;j++){ // form awi and aw2i
aw2i = aw2i + W2[i][j]*a[j]; // (W2[i][i] = 0)
if(j != i){
awi = awi + (W[i + j*m] + W[j + i*m])*a[j];
}
}
bi = phi + (rho/sige)*awi - ((rho*rho)/sige)*aw2i;
di = (1/sige) + ((rho*rho)/sige)*w1[i] + (obsi/v[i]);
a[i] = (bi/di) + sqrt(1/di)*snorm(); // Form a[i]
cobs = cobs + obsi;
}
} // End update of a
// Compute tvec = del*a
cobs = 0;
for(i=0; i<m; i++){
obsi = mobs[i];
for(j=cobs; j<cobs + obsi; j++){
tvec[j] = a[i];
}
cobs = cobs + obsi;
}
//UPDATE: sige
matvec(Bp,m,m,a,Bpa); //form Bp*a
aBBa = 0.0; //form aBBa = a'*Bp'*Bp*a
for(i=0; i<m; i++){
aBBa = aBBa + Bpa[i]*Bpa[i];
}
chi = genchi(m + 2.0*nu);
sige = (aBBa + 2.0*d0)/chi;
//UPDATE: v (and vv = del*v)
for(i=0; i<n; i++){
e[i] = e0[i] - tvec[i]; //form e = z - x*bhat - tvec
}
cobs = 0;
for(i=0; i<m; i++){
obsi = mobs[i];
chi = genchi(rval + obsi);
ee = 0.0;
for(j=cobs; j<cobs + obsi; j++){ // form ee
ee = ee + e[j]*e[j];
}
v[i] = (ee + rval)/chi; // form v
for(j=cobs; j<cobs + obsi; j++){
vv[j] = v[i]; // form vv
}
cobs = cobs + obsi;
}
//UPDATE: rval (if necessary)
if (mm != 0.0){
rval = gengam(mm,kk);
}
//UPDATE: rho (using univariate integration)
matvec(Wmat,m,m,a,Wa); // form Wa vector
c0 = 0.0; // form a'*a
c1 = 0.0; // form a'*Wa
c2 = 0.0; // form (Wa)'*Wa
for(i=0; i<m; i++){
c0 = c0 + a[i]*a[i];
c1 = c1 + a[i]*Wa[i];
c2 = c2 + Wa[i]*Wa[i];
}
rho = draw_rho(rdet,ldet,c0,c1,c2,sige,ngrid,m,k,rho);
// (4) Update Bp matrix using new rho
for(i=0; i<m; i++){
for(j=0; j<m; j++){
if (j == i){
Bp[i][j] = 1 - rho*W[i + j*m];
}else{
Bp[i][j] = - rho*W[i + j*m];
}
}
}
//UPDATE: z
if (zflag == 1){ // skip this for continuous y-values
// (1) Generate vector of means
cobs = 0;
for(i=0; i<m; i++){
obsi = mobs[i];
for(j=cobs; j<cobs + obsi; j++){
mn[j] = xb[j] + a[i];
}
cobs = cobs + obsi;
}
// (2) Sample truncated normal for latent z values
normal_truncc(n,mn,vv,limit1,limit2,z);
// (3) Compute associated sample y vector: ys
for(i=0; i<n; i++){
if(z[i]<0){
ys[i] = 0.0;
}else{
ys[i] = 1.0;
}
}
} // end of if zflag == 1
// ===================
// Save sample draws
// ===================
if (iter > nomit-1){
pdraw[iter - nomit] = rho; //save rho-draws
sdraw[iter - nomit] = sige; //save sige-draws
if(mm != 0.0)
rdraw[iter - nomit] = rval; //save r-draws (if necessary)
for(j=0; j<k; j++)
bdraw[(iter - nomit) + j*nsave] = bhat[j]; //save beta-draws
for(i=0; i<m; i++){
vmean[i] = vmean[i] + v[i]/((double) (nsave)); //save mean v-draws
adraw[(iter - nomit) + i*nsave] = a[i]; //save a-draws
amean[i] = amean[i] + a[i]/((double) (nsave)); //save mean a-draws
}
for(i=0; i<n; i++){
zmean[i] = zmean[i] + z[i]/((double) (nsave)); //save mean z-draws
yhat[i] = yhat[i] + mn[i]/((double) (nsave)); //save mean y-values
}
}
} // End iteration loop
// ===============================
// END SAMPLER
// ===============================
// Free up allocated vectors
free_dmatrix(xs,0,n-1,0);
free_dmatrix(xst,0,k-1,0);
free_dmatrix(xsxs,0,k-1,0);
free_dmatrix(A0,0,k-1,0);
free_dmatrix(A1,0,m-1,0);
free_dmatrix(Bp,0,m-1,0);
free_dmatrix(Bpt,0,m-1,0);
free_dmatrix(W2,0,m-1,0);
free_dmatrix(xmat,0,n-1,0);
free_dmatrix(Wmat,0,m-1,0);
free_dvector(z,0);
free_dvector(tvec,0);
free_dvector(e,0);
free_dvector(e0,0);
free_dvector(xb,0);
free_dvector(mn,0);
free_dvector(ys,0);
free_dvector(limit1,0);
free_dvector(limit2,0);
free_dvector(zmt,0);
free_dvector(vv,0);
free_dvector(bhat,0);
free_dvector(b0,0);
free_dvector(b0tmp,0);
free_dvector(v,0);
free_dvector(b1,0);
free_dvector(b1tmp,0);
free_dvector(Bpa,0);
free_dvector(rdet,0);
free_dvector(ldet,0);
free_dvector(w1,0);
free_dvector(Wa,0);
} // End of semip_gc
static double sgamma(lua_RNG *o,double a)
/*
**********************************************************************
(STANDARD-) G A M M A DISTRIBUTION
**********************************************************************
**********************************************************************
PARAMETER A >= 1.0 !
**********************************************************************
FOR DETAILS SEE:
AHRENS, J.H. AND DIETER, U.
GENERATING GAMMA VARIATES BY A
MODIFIED REJECTION TECHNIQUE.
COMM. ACM, 25,1 (JAN. 1982), 47 - 54.
STEP NUMBERS CORRESPOND TO ALGORITHM 'GD' IN THE ABOVE PAPER
(STRAIGHTFORWARD IMPLEMENTATION)
Modified by Barry W. Brown, Feb 3, 1988 to use RANF instead of
SUNIF. The argument IR thus goes away.
**********************************************************************
PARAMETER 0.0 < A < 1.0 !
**********************************************************************
FOR DETAILS SEE:
AHRENS, J.H. AND DIETER, U.
COMPUTER METHODS FOR SAMPLING FROM GAMMA,
BETA, POISSON AND BINOMIAL DISTRIBUTIONS.
COMPUTING, 12 (1974), 223 - 246.
(ADAPTED IMPLEMENTATION OF ALGORITHM 'GS' IN THE ABOVE PAPER)
**********************************************************************
INPUT: A =PARAMETER (MEAN) OF THE STANDARD GAMMA DISTRIBUTION
OUTPUT: SGAMMA = SAMPLE FROM THE GAMMA-(A)-DISTRIBUTION
COEFFICIENTS Q(K) - FOR Q0 = SUM(Q(K)*A**(-K))
COEFFICIENTS A(K) - FOR Q = Q0+(T*T/2)*SUM(A(K)*V**K)
COEFFICIENTS E(K) - FOR EXP(Q)-1 = SUM(E(K)*Q**K)
PREVIOUS A PRE-SET TO ZERO - AA IS A', AAA IS A"
SQRT32 IS THE SQUAREROOT OF 32 = 5.656854249492380
*/
{
static double q1 = 4.166669E-2;
static double q2 = 2.083148E-2;
static double q3 = 8.01191E-3;
static double q4 = 1.44121E-3;
static double q5 = -7.388E-5;
static double q6 = 2.4511E-4;
static double q7 = 2.424E-4;
static double a1 = 0.3333333;
static double a2 = -0.250003;
static double a3 = 0.2000062;
static double a4 = -0.1662921;
static double a5 = 0.1423657;
static double a6 = -0.1367177;
static double a7 = 0.1233795;
static double e1 = 1.0;
static double e2 = 0.4999897;
static double e3 = 0.166829;
static double e4 = 4.07753E-2;
static double e5 = 1.0293E-2;
static double aa = 0.0;
static double aaa = 0.0;
static double sqrt32 = 5.656854;
static double sgamma,s2,s,d,t,x,u,r,q0,b,si,c,v,q,e,w,p;
if(a == aa) goto S10;
if(a < 1.0) goto S120;
/*
STEP 1: RECALCULATIONS OF S2,S,D IF A HAS CHANGED
*/
aa = a;
s2 = a-0.5;
s = sqrt(s2);
d = sqrt32-12.0*s;
S10:
/*
STEP 2: T=STANDARD NORMAL DEVIATE,
X=(S,1/2)-NORMAL DEVIATE.
IMMEDIATE ACCEPTANCE (I)
*/
t = snorm(o);
x = s+0.5*t;
sgamma = x*x;
if(t >= 0.0) return sgamma;
/*
STEP 3: U= 0,1 -UNIFORM SAMPLE. SQUEEZE ACCEPTANCE (S)
*/
u = ranf(o);
if(d*u <= t*t*t) return sgamma;
/*
STEP 4: RECALCULATIONS OF Q0,B,SI,C IF NECESSARY
*/
if(a == aaa) goto S40;
aaa = a;
r = 1.0/ a;
q0 = ((((((q7*r+q6)*r+q5)*r+q4)*r+q3)*r+q2)*r+q1)*r;
/*
APPROXIMATION DEPENDING ON SIZE OF PARAMETER A
THE CONSTANTS IN THE EXPRESSIONS FOR B, SI AND
C WERE ESTABLISHED BY NUMERICAL EXPERIMENTS
*/
if(a <= 3.686) goto S30;
if(a <= 13.022) goto S20;
/*
CASE 3: A .GT. 13.022
*/
b = 1.77;
si = 0.75;
c = 0.1515/s;
goto S40;
S20:
/*
CASE 2: 3.686 .LT. A .LE. 13.022
*/
b = 1.654+7.6E-3*s2;
si = 1.68/s+0.275;
c = 6.2E-2/s+2.4E-2;
goto S40;
S30:
/*
CASE 1: A .LE. 3.686
*/
b = 0.463+s+0.178*s2;
si = 1.235;
c = 0.195/s-7.9E-2+1.6E-1*s;
S40:
/*
STEP 5: NO QUOTIENT TEST IF X NOT POSITIVE
*/
if(x <= 0.0) goto S70;
/*
STEP 6: CALCULATION OF V AND QUOTIENT Q
*/
v = t/(s+s);
if(fabs(v) <= 0.25) goto S50;
q = q0-s*t+0.25*t*t+(s2+s2)*log(1.0+v);
goto S60;
S50:
q = q0+0.5*t*t*((((((a7*v+a6)*v+a5)*v+a4)*v+a3)*v+a2)*v+a1)*v;
S60:
/*
STEP 7: QUOTIENT ACCEPTANCE (Q)
*/
if(log(1.0-u) <= q) return sgamma;
S70:
/*
STEP 8: E=STANDARD EXPONENTIAL DEVIATE
U= 0,1 -UNIFORM DEVIATE
T=(B,SI)-DOUBLE EXPONENTIAL (LAPLACE) SAMPLE
*/
e = sexpo(o);
u = ranf(o);
u += (u-1.0);
t = b+fsign(si*e,u);
/*
STEP 9: REJECTION IF T .LT. TAU(1) = -.71874483771719
*/
if(t < -0.7187449) goto S70;
/*
STEP 10: CALCULATION OF V AND QUOTIENT Q
*/
v = t/(s+s);
if(fabs(v) <= 0.25) goto S80;
q = q0-s*t+0.25*t*t+(s2+s2)*log(1.0+v);
goto S90;
S80:
q = q0+0.5*t*t*((((((a7*v+a6)*v+a5)*v+a4)*v+a3)*v+a2)*v+a1)*v;
S90:
/*
STEP 11: HAT ACCEPTANCE (H) (IF Q NOT POSITIVE GO TO STEP 8)
*/
if(q <= 0.0) goto S70;
if(q <= 0.5) goto S100;
w = exp(q)-1.0;
goto S110;
S100:
w = ((((e5*q+e4)*q+e3)*q+e2)*q+e1)*q;
S110:
/*
IF T IS REJECTED, SAMPLE AGAIN AT STEP 8
*/
if(c*fabs(u) > w*exp(e-0.5*t*t)) goto S70;
x = s+0.5*t;
sgamma = x*x;
return sgamma;
S120:
/*
ALTERNATE METHOD FOR PARAMETERS A BELOW 1 (.3678794=EXP(-1.))
*/
aa = 0.0;
b = 1.0+0.3678794*a;
S130:
p = b*ranf(o);
if(p >= 1.0) goto S140;
sgamma = exp(log(p)/ a);
if(sexpo(o) < sgamma) goto S130;
return sgamma;
S140:
sgamma = -log((b-p)/ a);
if(sexpo(o) < (1.0-a)*log(sgamma)) goto S130;
return sgamma;
}
long ignpoi(lua_RNG *o,double mu)
/*
**********************************************************************
GENerate POIsson random deviate
Function
Generates a single random deviate from a Poisson
distribution with mean AV.
Arguments
av --> The mean of the Poisson distribution from which
a random deviate is to be generated.
genexp <-- The random deviate.
Method
Renames KPOIS from TOMS as slightly modified by BWB to use RANF
instead of SUNIF.
For details see:
Ahrens, J.H. and Dieter, U.
Computer Generation of Poisson Deviates
From Modified Normal Distributions.
ACM Trans. Math. Software, 8, 2
(June 1982),163-179
**********************************************************************
**********************************************************************
P O I S S O N DISTRIBUTION
**********************************************************************
**********************************************************************
FOR DETAILS SEE:
AHRENS, J.H. AND DIETER, U.
COMPUTER GENERATION OF POISSON DEVIATES
FROM MODIFIED NORMAL DISTRIBUTIONS.
ACM TRANS. MATH. SOFTWARE, 8,2 (JUNE 1982), 163 - 179.
(SLIGHTLY MODIFIED VERSION OF THE PROGRAM IN THE ABOVE ARTICLE)
**********************************************************************
INTEGER FUNCTION IGNPOI(IR,MU)
INPUT: IR=CURRENT STATE OF BASIC RANDOM NUMBER GENERATOR
MU=MEAN MU OF THE POISSON DISTRIBUTION
OUTPUT: IGNPOI=SAMPLE FROM THE POISSON-(MU)-DISTRIBUTION
MUPREV=PREVIOUS MU, MUOLD=MU AT LAST EXECUTION OF STEP P OR B.
TABLES: COEFFICIENTS A0-A7 FOR STEP F. FACTORIALS FACT
COEFFICIENTS A(K) - FOR PX = FK*V*V*SUM(A(K)*V**K)-DEL
SEPARATION OF CASES A AND B
*/
{
static double a0 = -0.5;
static double a1 = 0.3333333;
static double a2 = -0.2500068;
static double a3 = 0.2000118;
static double a4 = -0.1661269;
static double a5 = 0.1421878;
static double a6 = -0.1384794;
static double a7 = 0.125006;
static double muold = 0.0;
static double muprev = 0.0;
static double fact[10] = {
1.0,1.0,2.0,6.0,24.0,120.0,720.0,5040.0,40320.0,362880.0
};
static long ignpoi,j,k,kflag,l,m;
static double b1,b2,c,c0,c1,c2,c3,d,del,difmuk,e,fk,fx,fy,g,omega,p,p0,px,py,q,s,
t,u,v,x,xx,pp[35];
if(mu == muprev) goto S10;
if(mu < 10.0) goto S120;
/*
C A S E A. (RECALCULATION OF S,D,L IF MU HAS CHANGED)
*/
muprev = mu;
s = sqrt(mu);
d = 6.0*mu*mu;
/*
THE POISSON PROBABILITIES PK EXCEED THE DISCRETE NORMAL
PROBABILITIES FK WHENEVER K >= M(MU). L=IFIX(MU-1.1484)
IS AN UPPER BOUND TO M(MU) FOR ALL MU >= 10 .
*/
l = (long) (mu-1.1484);
S10:
/*
STEP N. NORMAL SAMPLE - SNORM(IR) FOR STANDARD NORMAL DEVIATE
*/
g = mu+s*snorm(o);
if(g < 0.0) goto S20;
ignpoi = (long) (g);
/*
STEP I. IMMEDIATE ACCEPTANCE IF IGNPOI IS LARGE ENOUGH
*/
if(ignpoi >= l) return ignpoi;
/*
STEP S. SQUEEZE ACCEPTANCE - SUNIF(IR) FOR (0,1)-SAMPLE U
*/
fk = (float)ignpoi;
difmuk = mu-fk;
u = ranf(o);
if(d*u >= difmuk*difmuk*difmuk) return ignpoi;
S20:
/*
STEP P. PREPARATIONS FOR STEPS Q AND H.
(RECALCULATIONS OF PARAMETERS IF NECESSARY)
.3989423=(2*PI)**(-.5) .416667E-1=1./24. .1428571=1./7.
THE QUANTITIES B1, B2, C3, C2, C1, C0 ARE FOR THE HERMITE
APPROXIMATIONS TO THE DISCRETE NORMAL PROBABILITIES FK.
C=.1069/MU GUARANTEES MAJORIZATION BY THE 'HAT'-FUNCTION.
*/
if(mu == muold) goto S30;
muold = mu;
omega = 0.3989423/s;
b1 = 4.166667E-2/mu;
b2 = 0.3*b1*b1;
c3 = 0.1428571*b1*b2;
c2 = b2-15.0*c3;
c1 = b1-6.0*b2+45.0*c3;
c0 = 1.0-b1+3.0*b2-15.0*c3;
c = 0.1069/mu;
S30:
if(g < 0.0) goto S50;
/*
'SUBROUTINE' F IS CALLED (KFLAG=0 FOR CORRECT RETURN)
*/
kflag = 0;
goto S70;
S40:
/*
STEP Q. QUOTIENT ACCEPTANCE (RARE CASE)
*/
if(fy-u*fy <= py*exp(px-fx)) return ignpoi;
S50:
/*
STEP E. EXPONENTIAL SAMPLE - SEXPO(IR) FOR STANDARD EXPONENTIAL
DEVIATE E AND SAMPLE T FROM THE LAPLACE 'HAT'
(IF T <= -.6744 THEN PK < FK FOR ALL MU >= 10.)
*/
e = sexpo(o);
u = ranf(o);
u += (u-1.0);
t = 1.8+fsign(e,u);
if(t <= -0.6744) goto S50;
ignpoi = (long) (mu+s*t);
fk = (float)ignpoi;
difmuk = mu-fk;
/*
'SUBROUTINE' F IS CALLED (KFLAG=1 FOR CORRECT RETURN)
*/
kflag = 1;
goto S70;
S60:
/*
STEP H. HAT ACCEPTANCE (E IS REPEATED ON REJECTION)
*/
if(c*fabs(u) > py*exp(px+e)-fy*exp(fx+e)) goto S50;
return ignpoi;
S70:
/*
STEP F. 'SUBROUTINE' F. CALCULATION OF PX,PY,FX,FY.
CASE IGNPOI .LT. 10 USES FACTORIALS FROM TABLE FACT
*/
if(ignpoi >= 10) goto S80;
px = -mu;
py = pow(mu,(double)ignpoi)/ *(fact+ignpoi);
goto S110;
S80:
/*
CASE IGNPOI .GE. 10 USES POLYNOMIAL APPROXIMATION
A0-A7 FOR ACCURACY WHEN ADVISABLE
.8333333E-1=1./12. .3989423=(2*PI)**(-.5)
*/
del = 8.333333E-2/fk;
del -= (4.8*del*del*del);
v = difmuk/fk;
if(fabs(v) <= 0.25) goto S90;
px = fk*log(1.0+v)-difmuk-del;
goto S100;
S90:
px = fk*v*v*(((((((a7*v+a6)*v+a5)*v+a4)*v+a3)*v+a2)*v+a1)*v+a0)-del;
S100:
py = 0.3989423/sqrt(fk);
S110:
x = (0.5-difmuk)/s;
xx = x*x;
fx = -0.5*xx;
fy = omega*(((c3*xx+c2)*xx+c1)*xx+c0);
if(kflag <= 0) goto S40;
goto S60;
S120:
/*
C A S E B. (START NEW TABLE AND CALCULATE P0 IF NECESSARY)
*/
muprev = 0.0;
if(mu == muold) goto S130;
muold = mu;
m = max(1L,(long) (mu));
l = 0;
p = exp(-mu);
q = p0 = p;
S130:
/*
STEP U. UNIFORM SAMPLE FOR INVERSION METHOD
*/
u = ranf(o);
ignpoi = 0;
if(u <= p0) return ignpoi;
/*
STEP T. TABLE COMPARISON UNTIL THE END PP(L) OF THE
PP-TABLE OF CUMULATIVE POISSON PROBABILITIES
(0.458=PP(9) FOR MU=10)
*/
if(l == 0) goto S150;
j = 1;
if(u > 0.458) j = min(l,m);
for(k=j; k<=l; k++) {
if(u <= *(pp+k-1)) goto S180;
}
if(l == 35) goto S130;
S150:
/*
STEP C. CREATION OF NEW POISSON PROBABILITIES P
AND THEIR CUMULATIVES Q=PP(K)
*/
l += 1;
for(k=l; k<=35; k++) {
p = p*mu/(float)k;
q += p;
*(pp+k-1) = q;
if(u <= q) goto S170;
}
l = 35;
goto S130;
S170:
l = k;
S180:
ignpoi = k;
return ignpoi;
}
void apprcirc(long *n, double *Hurst, double *L, int *cum, long *seed1,
long *seed2, double *output) {
/* function that generates a fractional Brownian motion or fractional */
/* Gaussian noise sample using the approximate circulant method. */
/* Input: *n determines the sample size N by N=2^(*n) */
/* *Hurst the Hurst parameter of the trace */
/* *L the sample is generated on [0,L] */
/* *cum = 0: fractional Gaussian noise is produced */
/* = 1: fractional Brownian motion is produced */
/* *seed1 seed1 for the random generator */
/* *seed2 seed2 for the random generator */
/* Output: *seed1 new seed1 of the random generator */
/* *seed2 new seed2 of the random generator */
/* *output the resulting sample is stored in this array */
long i, N, halfN, generator;
double scaling, H;
double *pow_spec;
double aux;
complex *a;
halfN = pow(2,*n);
H = *Hurst;
N = 2*halfN;
/* set random generator and seeds */
snorm();
generator = 1;
gscgn(1, &generator);
setall(*seed1,*seed2);
/* allocate memory */
pow_spec = (double*) malloc((halfN+1)*sizeof(double));
/* approximate spectral density */
FGN_spectrum(pow_spec,halfN,H);
a = malloc(N*sizeof(complex));
a[0].re = sqrt(2*(pow(N,2*H)-pow(N-1,2*H)))*snorm();
a[0].im = 0.;
a[halfN].re = sqrt(2*pow_spec[halfN])*snorm();
a[halfN].im = 0.;
for(i=1; i<halfN; i++) {
aux = sqrt(pow_spec[i]);
a[i].re = aux*snorm();
a[i].im = aux*snorm();
}
for(i=halfN+1; i<N; i++) {
a[i].re = a[N-i].re;
a[i].im = -a[N-i].im;
}
/* real part of Fourier transform of a_re + i a_im gives sample path */
fft(N,a,1,1.0);
/* rescale to obtain a sample of size 2^(*n) on [0,L] */
scaling = pow(*L/halfN,H)/sqrt(2*N);
for(i=0;i<halfN;i++) {
output[i] = scaling*(a[i].re);
if (*cum && i>0) {
output[i] += output[i-1];
}
}
/* store the new random seeds and free memory */
getsd(seed1,seed2);
free(pow_spec);
free(a);
}
double NormalRandom(double mean, double var)
{
return (mean + sqrt(var)*snorm());
}
double NormalRandom()
{
// Only generate standard random number
return snorm();
}
/*@C
D_SFischer - Calculates an element of the B-subdifferential of the
smoothed Fischer-Burmeister function for complementarity problems.
Input Parameters:
+ this - the jacobian of tf at tx
. tx - current point
. tf - function evaluated at tx
. tl - lower bounds
. tu - upper bounds
. mu - smoothing parameter
. tt1 - work vector
- tt2 - work vector
Output Parameter:
+ tda - diagonal perturbation component of the result
. tdb - row scaling component of the result
- tdm - derivative with respect to scaling parameter
Level: intermediate
.seealso TaoVec::SFischer()
@*/
int TaoMat::D_SFischer(TaoVec *tx, TaoVec *tf,
TaoVec *tl, TaoVec *tu, double mu,
TaoVec *tt1, TaoVec *tt2,
TaoVec *tda, TaoVec *tdb, TaoVec *tdm)
{
int i, info;
TaoInt nn1, nn2, nn3, nn4, nn5, nn6, nn7;
TaoTruth flag;
TaoScalar *x, *f, *l, *u, *da, *db, *dm;
TaoScalar ai, bi, ci, di, ei, fi;
TaoFunctionBegin;
if ((mu >= -TAO_EPSILON) && (mu <= TAO_EPSILON)) {
tdm->SetToZero();
D_Fischer(tx, tf, tl, tu, tt1, tt2, tda, tdb);
}
else {
info = this->Compatible(tx, tx, &flag); CHKERRQ(info);
info = tx->GetArray(&x, &nn1); CHKERRQ(info);
info = tf->GetArray(&f, &nn2); CHKERRQ(info);
info = tl->GetArray(&l, &nn3); CHKERRQ(info);
info = tu->GetArray(&u, &nn4); CHKERRQ(info);
info = tda->GetArray(&da, &nn5); CHKERRQ(info);
info = tdb->GetArray(&db, &nn6); CHKERRQ(info);
info = tdm->GetArray(&dm, &nn7); CHKERRQ(info);
if (nn1!=nn2 || nn2!=nn3 || nn3!=nn4 || nn4!=nn5 || nn5!=nn6 || nn6!=nn7) {
TaoFunctionReturn(1);
}
for (i = 0; i < nn1; ++i) {
if ((l[i] <= -TAO_INFINITY) && (u[i] >= TAO_INFINITY)) {
da[i] = -mu;
db[i] = -1;
dm[i] = -x[i];
}
else if (l[i] <= -TAO_INFINITY) {
bi = u[i] - x[i];
ai = snorm(bi, f[i], mu);
ai = TaoMax(TAO_EPSILON, ai);
da[i] = bi / ai - 1;
db[i] = -f[i] / ai - 1;
dm[i] = 2.0 * mu / ai;
}
else if (u[i] >= TAO_INFINITY) {
bi = x[i] - l[i];
ai = snorm(bi, f[i], mu);
ai = TaoMax(TAO_EPSILON, ai);
da[i] = bi / ai - 1;
db[i] = f[i] / ai - 1;
dm[i] = 2.0 * mu / ai;
}
else if (l[i] == u[i]) {
da[i] = -1;
db[i] = 0;
dm[i] = 0;
}
else {
bi = x[i] - u[i];
ai = snorm(bi, f[i], mu);
ai = TaoMax(TAO_EPSILON, ai);
ci = bi / ai + 1;
di = f[i] / ai + 1;
fi = 2.0 * mu / ai;
ei = sfischer(u[i] - x[i], -f[i], mu);
ai = snorm(x[i] - l[i], ei, mu);
ai = TaoMax(TAO_EPSILON, ai);
bi = ei / ai - 1;
ei = 2.0 * mu / ei;
ai = (x[i] - l[i]) / ai - 1;
da[i] = ai + bi*ci;
db[i] = bi*di;
dm[i] = ei + bi*fi;
}
}
info = tx->RestoreArray(&x, &nn1); CHKERRQ(info);
info = tf->RestoreArray(&f, &nn2); CHKERRQ(info);
info = tl->RestoreArray(&l, &nn3); CHKERRQ(info);
info = tu->RestoreArray(&u, &nn4); CHKERRQ(info);
info = tda->RestoreArray(&da, &nn5); CHKERRQ(info);
info = tdb->RestoreArray(&db, &nn6); CHKERRQ(info);
info = tdm->RestoreArray(&dm, &nn7); CHKERRQ(info);
}
TaoFunctionReturn(0);
}
