double random_switch(int *model, struct Var *vars, int n, int pmodel, int *varin, int *varout) {
int j, k, swapin, swapout, num_to_swap_in, num_to_swap_out;
j = 0; k = 0;
while (j < n && k < pmodel)
{
if (model[vars[j].index]==1) {varin[k] = vars[j].index; k++;}
j++ ;
}
num_to_swap_in = k;
j = 0; k = 0;
while (j< n)
{
if (model[vars[j].index]==0) {varout[k] = vars[j].index; k++;}
j++ ;
}
num_to_swap_out = k;
swapin = ftrunc(unif_rand()*num_to_swap_in); // swapin :corresponds to position of randomly chosen included variable
swapout = ftrunc(unif_rand()*num_to_swap_out); // swapout :corresponds to position of randomly chosen excluded variable
model[varin[swapin]] = 0;
model[varout[swapout]] =1;
return(1.0);
}
void marker_loglik(int n_ind, int n_gen, int *geno,
double error_prob, double initf(int, int *),
double emitf(int, int, double, int *),
double *loglik)
{
int i, v;
double temp;
int cross_scheme[2];
/* cross scheme hidden in loglik argument; used by hmm_bcsft */
cross_scheme[0] = (int) ftrunc(*loglik / 1000.0);
cross_scheme[1] = ((int) *loglik) - 1000 * cross_scheme[0];
*loglik = 0.0;
for(i=0; i<n_ind; i++) { /* i = individual */
R_CheckUserInterrupt(); /* check for ^C */
temp = initf(1, cross_scheme) + emitf(geno[i], 1, error_prob, cross_scheme);
for(v=1; v<n_gen; v++)
temp = addlog(temp, initf(v+1, cross_scheme) + emitf(geno[i], v+1, error_prob, cross_scheme));
(*loglik) += temp;
}
}
void fexp(_MIPD_ flash x,flash y)
{ /* calculates y=exp(x) */
int i,n,nsq,m,sqrn,op[5];
BOOL minus,rem;
#ifndef MR_GENERIC_MT
miracl *mr_mip=get_mip();
#endif
if (mr_mip->ERNUM) return;
if (size(x)==0)
{
convert(_MIPP_ 1,y);
return;
}
copy(x,y);
MR_IN(54)
minus=FALSE;
if (size(y)<0)
{
minus=TRUE;
negate(y,y);
}
ftrunc(_MIPP_ y,y,mr_mip->w9);
n=size(y);
if (n==MR_TOOBIG)
{
mr_berror(_MIPP_ MR_ERR_FLASH_OVERFLOW);
MR_OUT
return;
}
void fmodulo(_MIPD_ flash x,flash y,flash z)
{ /* sets z=x mod y */
#ifdef MR_OS_THREADS
miracl *mr_mip=get_mip();
#endif
if (mr_mip->ERNUM) return;
MR_IN(89)
fdiv(_MIPP_ x,y,mr_mip->w8);
ftrunc(_MIPP_ mr_mip->w8,mr_mip->w8,mr_mip->w8);
fmul(_MIPP_ mr_mip->w8,y,mr_mip->w8);
fsub(_MIPP_ x,mr_mip->w8,z);
MR_OUT
}
/* preparation for Grid */
void GridPrep(
double **W1g, /* grids holder for W1 */
double **W2g, /* grids holder for W2 */
double **X, /* data: [X Y] */
double *maxW1, /* upper bound for W1 */
double *minW1, /* lower bound for W1 */
int *n_grid, /* number of grids */
int n_samp, /* sample size */
int n_step /* step size */
)
{
int i, j;
double dtemp;
double *resid = doubleArray(n_samp);
for(i=0; i<n_samp; i++)
for (j=0; j<n_step; j++){
W1g[i][j]=0;
W2g[i][j]=0;
}
for(i=0;i<n_samp;i++) {
if (X[i][1]!=0 && X[i][1]!=1) {
/* 1/n_step is the length of the grid */
dtemp=(double)1/n_step;
if ((maxW1[i]-minW1[i]) > (2*dtemp)) {
n_grid[i]=ftrunc((maxW1[i]-minW1[i])*n_step);
resid[i]=(maxW1[i]-minW1[i])-n_grid[i]*dtemp;
/*if (maxW1[i]-minW1[i]==1) resid[i]=dtemp/4; */
j=0;
while (j<n_grid[i]) {
W1g[i][j]=minW1[i]+(j+1)*dtemp-(dtemp+resid[i])/2;
if ((W1g[i][j]-minW1[i])<resid[i]/2) W1g[i][j]+=resid[i]/2;
if ((maxW1[i]-W1g[i][j])<resid[i]/2) W1g[i][j]-=resid[i]/2;
W2g[i][j]=(X[i][1]-X[i][0]*W1g[i][j])/(1-X[i][0]);
j++;
}
}
else {
W1g[i][0]=minW1[i]+(maxW1[i]-minW1[i])/3;
W2g[i][0]=(X[i][1]-X[i][0]*W1g[i][0])/(1-X[i][0]);
W1g[i][1]=minW1[i]+2*(maxW1[i]-minW1[i])/3;
W2g[i][1]=(X[i][1]-X[i][0]*W1g[i][1])/(1-X[i][0]);
n_grid[i]=2;
}
}
}
free(resid);
}
void alpha3d(int *n1, int *n2, double *xtab, double *ytab, double *xref, double *yref,
double *lambda, double *res1, double *alpha)
{
int i, j, k, test_max, in, ind1;
for(i=0; i < *n2; i++)
{
//initialisation
in=0;
for(j=0; j < *n1; j++)
{
// efficiency score calculated in the output direction
test_max=0;
for(k=0; k < 2; k++)
{if(xtab[2*j+k]<=xref[2*i+k]) // test if the xtab<xref
{test_max = test_max + 1;
}
}
if(test_max==2)
{
res1[j]=ytab[j]/yref[i];
}
else
{res1[j]=0;
in=in+1;}
}
if(in==*n1)
{lambda[i]=-1;}
else
{R_rsort(res1, *n1);
ind1=imin2(*n1-1,ftrunc(in+*alpha*(*n1-in)));
//if(ind1!=(in+*alpha*(*n1-in)))
// {ind1=ind1+1;}
lambda[i]=res1[ind1];
}
}
}
void ftan(_MIPD_ flash x,flash y)
{ /* calculates y=tan(x) */
int i,n,nsq,m,sqrn,sgn,op[5];
#ifndef MR_GENERIC_MT
miracl *mr_mip=get_mip();
#endif
copy(x,y);
if (mr_mip->ERNUM || size(y)==0) return;
MR_IN(57)
sgn=norm(_MIPP_ TAN,y);
ftrunc(_MIPP_ y,y,mr_mip->w10);
n=size(y);
if (n!=0) build(_MIPP_ y,tan1);
if (size(mr_mip->w10)==0)
{
insign(sgn,y);
MR_OUT
return;
}
static int norm(_MIPD_ int type,flash y)
{ /* convert y to first quadrant angle *
* and return sign of result */
int s;
#ifndef MR_GENERIC_MT
miracl *mr_mip=get_mip();
#endif
if (mr_mip->ERNUM) return 0;
s=PLUS;
if (size(y)<0)
{
negify(y,y);
if (type!=COS) s=(-s);
}
fpi(_MIPP_ mr_mip->pi);
fpmul(_MIPP_ mr_mip->pi,1,2,mr_mip->w8);
if (fcomp(_MIPP_ y,mr_mip->w8)<=0) return s;
fpmul(_MIPP_ mr_mip->pi,2,1,mr_mip->w8);
if (fcomp(_MIPP_ y,mr_mip->w8)>0)
{ /* reduce mod 2.pi */
fdiv(_MIPP_ y,mr_mip->w8,mr_mip->w9);
ftrunc(_MIPP_ mr_mip->w9,mr_mip->w9,mr_mip->w9);
fmul(_MIPP_ mr_mip->w9,mr_mip->w8,mr_mip->w9);
fsub(_MIPP_ y,mr_mip->w9,y);
}
if (fcomp(_MIPP_ y,mr_mip->pi)>0)
{ /* if greater than pi */
fsub(_MIPP_ y,mr_mip->pi,y);
if (type!=TAN) s=(-s);
}
fpmul(_MIPP_ mr_mip->pi,1,2,mr_mip->w8);
if (fcomp(_MIPP_ y,mr_mip->w8)>0)
{ /* if greater than pi/2 */
fsub(_MIPP_ mr_mip->pi,y,y);
if (type!=SIN) s=(-s);
}
return s;
}
void orderalpha(int *n1, int *n2, int *pinput, int *qoutput, double *xtab,
double *ytab, double *xref, double *yref, double *lambda, double *output_ref,
double *theta, double *input_ref, double *gammaa, double *hyper_ref,
double *res1, double *res2, double *res3, double *alpha)
{
int i, j, k, l, test_max, test_min, in, out, ind1, ind2, ind3;
double min_ref, max_ref, minmax_ref;
for(i=0; i < *n2; i++)
{
//initialisation
in=0;
out=0;
for(j=0; j < *n1; j++)
{
// efficiency score calculated in the output direction
test_max=0;
for(k=0; k < *pinput; k++)
{if(xtab[*pinput*j+k]<=xref[*pinput*i+k]) // test if the xtab<xref
{test_max = test_max + 1;
}
}
if(test_max==*pinput)
{
min_ref=ytab[*qoutput*j]/yref[*qoutput*i];
for(l=1; l < *qoutput; l++) // research of which output
{min_ref=fmin2(min_ref, ytab[*qoutput*j+l]/yref[*qoutput*i+l]);}
// if(lambda[i]<min_ref)
// {lambda[i]=min_ref;
// output_ref[i]=j+1;
// }
res1[j]=min_ref;
}
else
{res1[j]=0;
in=in+1;}
// efficiency score calculated in the input direction
test_min=0;
for(k=0; k < *qoutput; k++)
{if(ytab[*qoutput*j+k]>=yref[*qoutput*i+k]) // test if the ytab>yref
{test_min = test_min + 1;
}
}
if(test_min==*qoutput)
{
max_ref=xtab[*pinput*j]/xref[*pinput*i];
for(l=1; l < *pinput; l++) // research of which output
{max_ref=fmax2(max_ref,xtab[*pinput*j+l]/xref[*pinput*i+l]);}
if(theta[i]==0) // initialisation of theta[i]
{theta[i]=max_ref;
input_ref[i]=j+1;
}
// if(theta[i]>max_ref)
// {theta[i]=max_ref;
// input_ref[i]=j+1;
// }
res2[j]=max_ref;
}
else
{res2[j]=999;
out=out+1;
}
// efficiency score calculated in the hyperbolic direction
max_ref=xtab[*pinput*j]/xref[*pinput*i];
for(l=1; l < *pinput; l++) // research of which output
{max_ref=fmax2(max_ref,xtab[*pinput*j+l]/xref[*pinput*i+l]);}
min_ref=yref[*qoutput*i]/ytab[*qoutput*j];
for(l=1; l < *qoutput; l++) // research of which output
{min_ref=fmax2(min_ref,yref[*qoutput*i+l]/ytab[*qoutput*j+l]);}
minmax_ref=fmax2(min_ref,max_ref);
// if(gammaa[i]>minmax_ref)
// {gammaa[i]=minmax_ref;
// hyper_ref[i]=j+1;}
res3[j]=minmax_ref;
}
if(in==*n1)
{lambda[i]=-1;}
else
{R_rsort(res1, *n1);
ind1=imin2(*n1-1,ftrunc(in+alpha[i]*(*n1-in)));
//if(ind1!=(in+*alpha*(*n1-in)))
// {ind1=ind1+1;}
lambda[i]=res1[ind1];
}
if(out==*n1)
{theta[i]=-1;}
else
{ R_rsort(res2, *n1);
ind2=ftrunc((1-alpha[i])*(*n1-out));
// if(ind2!=((1-*alpha)*(*n1-out)))
// {ind2=ind2+1;}
theta[i]=res2[ind2];}
R_rsort(res3, *n1);
ind3=ftrunc((1-alpha[i])**n1);
// if(ind3!=fround(((1-*alpha)**n1),5))
// {ind3=fmin2(ind3+1,(*n1-1));}
gammaa[i]=res3[ind3];
}
}
void NIbprobitMixed(int *Y, /* binary outcome variable */
int *R, /* recording indicator for Y */
int *grp, /* group indicator */
int *in_grp, /* number of groups */
int *max_samp_grp, /* max # of obs within group */
double *dXo, /* fixed effects covariates */
double *dXr, /* fixed effects covariates */
double *dZo, /* random effects covariates */
double *dZr, /* random effects covariates */
double *beta, /* coefficients */
double *delta, /* coefficients */
double *dPsio, /* random effects variance */
double *dPsir, /* random effects variance */
int *insamp, /* # of obs */
int *incovo, /* # of fixed effects */
int *incovr, /* # of fixed effects */
int *incovoR, /* # of random effects */
int *incovrR, /* # of random effects */
int *intreat, /* # of treatments */
double *beta0, /* prior mean */
double *delta0, /* prior mean */
double *dAo, /* prior precision */
double *dAr, /* prior precision */
int *dfo, /* prior degrees of freedom */
int *dfr, /* prior degrees of freedom */
double *dS0o, /* prior scale */
double *dS0r, /* prior scale */
int *Insample, /* insample QoI */
int *param, /* store parameters? */
int *mda, /* marginal data augmentation? */
int *ndraws, /* # of gibbs draws */
int *iBurnin, /* # of burnin */
int *iKeep, /* every ?th draws to keep */
int *verbose,
double *coefo, /* storage for coefficients */
double *coefr, /* storage for coefficients */
double *sPsiO, /* storage for variance */
double *sPsiR, /* storage for variance */
double *ATE, /* storage for ATE */
double *BASE /* storage for baseline */
) {
/*** counters ***/
int n_samp = *insamp; /* sample size */
int n_gen = *ndraws; /* number of gibbs draws */
int n_grp = *in_grp; /* number of groups */
int n_covo = *incovo; /* number of fixed effects */
int n_covr = *incovr; /* number of fixed effects */
int n_covoR = *incovoR; /* number of random effects */
int n_covrR = *incovrR; /* number of random effects */
int n_treat = *intreat; /* number of treatments */
/*** data ***/
/* covariates for the response model */
double **Xr = doubleMatrix(n_samp+n_covr, n_covr+1);
/* covariates for the outcome model */
double **Xo = doubleMatrix(n_samp+n_covo, n_covo+1);
/* random effects covariates */
double ***Zo = doubleMatrix3D(n_grp, *max_samp_grp + n_covoR,
n_covoR + 1);
double ***Zr = doubleMatrix3D(n_grp, *max_samp_grp + n_covrR,
n_covrR + 1);
/*** model parameters ***/
double **PsiO = doubleMatrix(n_covoR, n_covoR);
double **PsiR = doubleMatrix(n_covrR, n_covrR);
double **xiO = doubleMatrix(n_grp, n_covoR);
double **xiR = doubleMatrix(n_grp, n_covrR);
double **S0o = doubleMatrix(n_covoR, n_covoR);
double **S0r = doubleMatrix(n_covrR, n_covrR);
double **Ao = doubleMatrix(n_covo, n_covo);
double **Ar = doubleMatrix(n_covr, n_covr);
double **mtemp1 = doubleMatrix(n_covo, n_covo);
double **mtemp2 = doubleMatrix(n_covr, n_covr);
/*** QoIs ***/
double *base = doubleArray(n_treat);
double *cATE = doubleArray(n_treat);
/*** storage parameters and loop counters **/
int progress = 1;
int keep = 1;
int i, j, k, main_loop;
int itemp, itemp0, itemp1, itemp2, itemp3 = 0, itempP = ftrunc((double) n_gen/10);
int *vitemp = intArray(n_grp);
double dtemp, pj, r0, r1;
/*** get random seed **/
GetRNGstate();
/*** fixed effects ***/
itemp = 0;
for (j = 0; j < n_covo; j++)
for (i = 0; i < n_samp; i++)
Xo[i][j] = dXo[itemp++];
itemp = 0;
for (j = 0; j < n_covr; j++)
for (i = 0; i < n_samp; i++)
Xr[i][j] = dXr[itemp++];
/* prior */
itemp = 0;
for (k = 0; k < n_covo; k++)
for (j = 0; j < n_covo; j++)
Ao[j][k] = dAo[itemp++];
itemp = 0;
for (k = 0; k < n_covr; k++)
for (j = 0; j < n_covr; j++)
Ar[j][k] = dAr[itemp++];
dcholdc(Ao, n_covo, mtemp1);
for(i = 0; i < n_covo; i++) {
Xo[n_samp+i][n_covo] = 0;
for(j = 0; j < n_covo; j++) {
Xo[n_samp+i][n_covo] += mtemp1[i][j]*beta0[j];
Xo[n_samp+i][j] = mtemp1[i][j];
}
}
dcholdc(Ar, n_covr, mtemp2);
for(i = 0; i < n_covr; i++) {
Xr[n_samp+i][n_covr] = 0;
for(j = 0; j < n_covr; j++) {
Xr[n_samp+i][n_covr] += mtemp2[i][j]*delta0[j];
Xr[n_samp+i][j] = mtemp2[i][j];
}
}
/* random effects */
itemp = 0;
for (j = 0; j < n_grp; j++)
vitemp[j] = 0;
for (i = 0; i < n_samp; i++) {
for (j = 0; j < n_covoR; j++)
Zo[grp[i]][vitemp[grp[i]]][j] = dZo[itemp++];
vitemp[grp[i]]++;
}
itemp = 0;
for (j = 0; j < n_grp; j++)
vitemp[j] = 0;
for (i = 0; i < n_samp; i++) {
for (j = 0; j < n_covrR; j++)
Zr[grp[i]][vitemp[grp[i]]][j] = dZr[itemp++];
vitemp[grp[i]]++;
}
/* prior variance for random effects */
itemp = 0;
for (k = 0; k < n_covoR; k++)
for (j = 0; j < n_covoR; j++)
PsiO[j][k] = dPsio[itemp++];
itemp = 0;
for (k = 0; k < n_covrR; k++)
for (j = 0; j < n_covrR; j++)
PsiR[j][k] = dPsir[itemp++];
itemp = 0;
for (k = 0; k < n_covoR; k++)
for (j = 0; j < n_grp; j++)
xiO[j][k] = norm_rand();
itemp = 0;
for (k = 0; k < n_covrR; k++)
for (j = 0; j < n_grp; j++)
xiR[j][k] = norm_rand();
/* hyper prior scale parameter for random effects */
itemp = 0;
for (k = 0; k < n_covoR; k++)
for (j = 0; j < n_covoR; j++)
S0o[j][k] = dS0o[itemp++];
itemp = 0;
for (k = 0; k < n_covrR; k++)
for (j = 0; j < n_covrR; j++)
S0r[j][k] = dS0r[itemp++];
/*** Gibbs Sampler! ***/
itemp = 0; itemp0 = 0; itemp1 = 0; itemp2 = 0;
for(main_loop = 1; main_loop <= n_gen; main_loop++){
/** Response Model: binary Probit **/
bprobitMixedGibbs(R, Xr, Zr, grp, delta, xiR, PsiR, n_samp,
n_covr, n_covrR, n_grp, 0, delta0, Ar, *dfr, S0r,
1);
/** Outcome Model: binary probit **/
bprobitMixedGibbs(Y, Xo, Zr, grp, beta, xiO, PsiO, n_samp, n_covo,
n_covoR, n_grp, 0, beta0, Ao, *dfo, S0o, 1);
/** Imputing the missing data **/
for (j = 0; j < n_grp; j++)
vitemp[j] = 0;
for (i = 0; i < n_samp; i++) {
if (R[i] == 0) {
pj = 0;
r0 = delta[0];
r1 = delta[1];
for (j = 0; j < n_covo; j++)
pj += Xo[i][j]*beta[j];
for (j = 2; j < n_covr; j++) {
r0 += Xr[i][j]*delta[j];
r1 += Xr[i][j]*delta[j];
}
for (j = 0; j < n_covoR; j++)
pj += Zo[grp[i]][vitemp[grp[i]]][j]*xiO[grp[i]][j];
for (j = 0; j < n_covrR; j++) {
r0 += Zr[grp[i]][vitemp[grp[i]]][j]*xiR[grp[i]][j];
r1 += Zr[grp[i]][vitemp[grp[i]]][j]*xiR[grp[i]][j];
}
pj = pnorm(0, pj, 1, 0, 0);
r0 = pnorm(0, r0, 1, 0, 0);
r1 = pnorm(0, r1, 1, 0, 0);
if (unif_rand() < ((1-r1)*pj/((1-r1)*pj+(1-r0)*(1-pj)))) {
Y[i] = 1;
Xr[i][0] = 0;
Xr[i][1] = 1;
} else {
Y[i] = 0;
Xr[i][0] = 1;
Xr[i][1] = 0;
}
}
vitemp[grp[i]]++;
}
/** Compute quantities of interest **/
for (j = 0; j < n_grp; j++)
vitemp[j] = 0;
for (j = 0; j < n_treat; j++)
base[j] = 0;
for (i = 0; i < n_samp; i++) {
dtemp = 0;
for (j = n_treat; j < n_covo; j++)
dtemp += Xo[i][j]*beta[j];
for (j = 0; j < n_covoR; j++)
dtemp += Zo[grp[i]][vitemp[grp[i]]][j]*xiO[grp[i]][j];
for (j = 0; j < n_treat; j++) {
if (*Insample) {
if (Xo[i][j] == 1)
base[j] += (double)Y[i];
else
base[j] += (double)((dtemp+beta[j]+norm_rand()) > 0);
} else
base[j] += pnorm(0, dtemp+beta[j], 1, 0, 0);
}
vitemp[grp[i]]++;
}
for (j = 0; j < n_treat; j++)
base[j] /= (double)n_samp;
/** Storing the results **/
if (main_loop > *iBurnin) {
if (keep == *iKeep) {
for (j = 0; j < (n_treat-1); j++)
ATE[itemp0++] = base[j+1] - base[0];
for (j = 0; j < n_treat; j++)
BASE[itemp++] = base[j];
if (*param) {
for (i = 0; i < n_covo; i++)
coefo[itemp1++] = beta[i];
for (i = 0; i < n_covr; i++)
coefr[itemp2++] = delta[i];
for (i = 0; i < n_covoR; i++)
for (j = i; j < n_covoR; j++)
sPsiO[itemp3++] = PsiO[i][j];
for (i = 0; i < n_covrR; i++)
for (j = i; j < n_covrR; j++)
sPsiR[itemp3++] = PsiR[i][j];
}
keep = 1;
}
else
keep++;
}
if(*verbose) {
if(main_loop == itempP) {
Rprintf("%3d percent done.\n", progress*10);
itempP += ftrunc((double) n_gen/10);
progress++;
R_FlushConsole();
}
}
R_CheckUserInterrupt();
} /* end of Gibbs sampler */
/** write out the random seed **/
PutRNGstate();
/** freeing memory **/
FreeMatrix(Xr, n_samp+n_covr);
FreeMatrix(Xo, n_samp+n_covo);
Free3DMatrix(Zo, n_grp, *max_samp_grp + n_covoR);
Free3DMatrix(Zr, n_grp, *max_samp_grp + n_covrR);
FreeMatrix(PsiO, n_covoR);
FreeMatrix(PsiR, n_covrR);
FreeMatrix(xiO, n_grp);
FreeMatrix(xiR, n_grp);
FreeMatrix(S0o, n_covoR);
FreeMatrix(S0r, n_covrR);
FreeMatrix(Ao, n_covo);
FreeMatrix(Ar, n_covr);
FreeMatrix(mtemp1, n_covo);
FreeMatrix(mtemp2, n_covr);
free(base);
free(cATE);
free(vitemp);
} /* NIbprobitMixed */
void NIbprobit(int *Y, /* binary outcome variable */
int *R, /* recording indicator for Y */
double *dXo, /* covariates */
double *dXr, /* covariates */
double *beta, /* coefficients */
double *delta, /* coefficients */
int *insamp, /* # of obs */
int *incovo, /* # of covariates */
int *incovr, /* # of covariates */
int *intreat, /* # of treatments */
double *beta0, /* prior mean */
double *delta0, /* prior mean */
double *dAo, /* prior precision */
double *dAr, /* prior precision */
int *Insample, /* insample QoI */
int *param, /* store parameters? */
int *mda, /* marginal data augmentation? */
int *ndraws, /* # of gibbs draws */
int *iBurnin, /* # of burnin */
int *iKeep, /* every ?th draws to keep */
int *verbose,
double *coefo, /* storage for coefficients */
double *coefr, /* storage for coefficients */
double *ATE, /* storage for ATE */
double *BASE /* storage for baseline */
) {
/*** counters ***/
int n_samp = *insamp; /* sample size */
int n_gen = *ndraws; /* number of gibbs draws */
int n_covo = *incovo; /* number of covariates */
int n_covr = *incovr; /* number of covariates */
int n_treat = *intreat; /* number of treatments */
/*** data ***/
/* covariates for the response model */
double **Xr = doubleMatrix(n_samp+n_covr, n_covr+1);
/* covariates for the outcome model */
double **Xo = doubleMatrix(n_samp+n_covo, n_covo+1);
/*** model parameters ***/
double **Ao = doubleMatrix(n_covo, n_covo);
double **Ar = doubleMatrix(n_covr, n_covr);
double **mtemp1 = doubleMatrix(n_covo, n_covo);
double **mtemp2 = doubleMatrix(n_covr, n_covr);
/*** QoIs ***/
double *base = doubleArray(n_treat);
double *cATE = doubleArray(n_treat);
/*** storage parameters and loop counters **/
int progress = 1;
int keep = 1;
int i, j, k, main_loop;
int itemp, itemp0, itemp1, itemp2, itempP = ftrunc((double) n_gen/10);
double dtemp, pj, r0, r1;
/*** get random seed **/
GetRNGstate();
/*** read the data ***/
itemp = 0;
for (j = 0; j < n_covo; j++)
for (i = 0; i < n_samp; i++)
Xo[i][j] = dXo[itemp++];
itemp = 0;
for (j = 0; j < n_covr; j++)
for (i = 0; i < n_samp; i++)
Xr[i][j] = dXr[itemp++];
/*** read the prior and it as additional data points ***/
itemp = 0;
for (k = 0; k < n_covo; k++)
for (j = 0; j < n_covo; j++)
Ao[j][k] = dAo[itemp++];
itemp = 0;
for (k = 0; k < n_covr; k++)
for (j = 0; j < n_covr; j++)
Ar[j][k] = dAr[itemp++];
dcholdc(Ao, n_covo, mtemp1);
for(i = 0; i < n_covo; i++) {
Xo[n_samp+i][n_covo] = 0;
for(j = 0; j < n_covo; j++) {
Xo[n_samp+i][n_covo] += mtemp1[i][j]*beta0[j];
Xo[n_samp+i][j] = mtemp1[i][j];
}
}
dcholdc(Ar, n_covr, mtemp2);
for(i = 0; i < n_covr; i++) {
Xr[n_samp+i][n_covr] = 0;
for(j = 0; j < n_covr; j++) {
Xr[n_samp+i][n_covr] += mtemp2[i][j]*delta0[j];
Xr[n_samp+i][j] = mtemp2[i][j];
}
}
/*** Gibbs Sampler! ***/
itemp = 0; itemp0 = 0; itemp1 = 0; itemp2 = 0;
for(main_loop = 1; main_loop <= n_gen; main_loop++){
/** Response Model: binary Probit **/
bprobitGibbs(R, Xr, delta, n_samp, n_covr, 0, delta0, Ar, *mda, 1);
/** Outcome Model: binary probit **/
bprobitGibbs(Y, Xo, beta, n_samp, n_covo, 0, beta0, Ao, *mda, 1);
/** Imputing the missing data **/
for (i = 0; i < n_samp; i++) {
if (R[i] == 0) {
pj = 0;
r0 = delta[0];
r1 = delta[1];
for (j = 0; j < n_covo; j++)
pj += Xo[i][j]*beta[j];
for (j = 2; j < n_covr; j++) {
r0 += Xr[i][j]*delta[j];
r1 += Xr[i][j]*delta[j];
}
pj = pnorm(0, pj, 1, 0, 0);
r0 = pnorm(0, r0, 1, 0, 0);
r1 = pnorm(0, r1, 1, 0, 0);
if (unif_rand() < ((1-r1)*pj/((1-r1)*pj+(1-r0)*(1-pj)))) {
Y[i] = 1;
Xr[i][0] = 0;
Xr[i][1] = 1;
} else {
Y[i] = 0;
Xr[i][0] = 1;
Xr[i][1] = 0;
}
}
}
/** Compute quantities of interest **/
for (j = 0; j < n_treat; j++)
base[j] = 0;
for (i = 0; i < n_samp; i++) {
dtemp = 0;
for (j = n_treat; j < n_covo; j++)
dtemp += Xo[i][j]*beta[j];
for (j = 0; j < n_treat; j++) {
if (*Insample) {
if (Xo[i][j] == 1)
base[j] += (double)Y[i];
else
base[j] += (double)((dtemp+beta[j]+norm_rand()) > 0);
} else
base[j] += pnorm(0, dtemp+beta[j], 1, 0, 0);
}
}
for (j = 0; j < n_treat; j++)
base[j] /= (double)n_samp;
/** Storing the results **/
if (main_loop > *iBurnin) {
if (keep == *iKeep) {
for (j = 0; j < (n_treat-1); j++)
ATE[itemp0++] = base[j+1] - base[0];
for (j = 0; j < n_treat; j++)
BASE[itemp++] = base[j];
if (*param) {
for (i = 0; i < n_covo; i++)
coefo[itemp1++] = beta[i];
for (i = 0; i < n_covr; i++)
coefr[itemp2++] = delta[i];
}
keep = 1;
}
else
keep++;
}
if(*verbose) {
if(main_loop == itempP) {
Rprintf("%3d percent done.\n", progress*10);
itempP += ftrunc((double) n_gen/10);
progress++;
R_FlushConsole();
}
}
R_CheckUserInterrupt();
} /* end of Gibbs sampler */
/** write out the random seed **/
PutRNGstate();
/** freeing memory **/
FreeMatrix(Xr, n_samp+n_covr);
FreeMatrix(Xo, n_samp+n_covo);
FreeMatrix(Ao, n_covo);
FreeMatrix(Ar, n_covr);
FreeMatrix(mtemp1, n_covo);
FreeMatrix(mtemp2, n_covr);
free(base);
free(cATE);
} /* NIbprobit */
void est_map(int n_ind, int n_mar, int n_gen, int *geno, double *rf,
double *rf2, double error_prob, double initf(int, int *),
double emitf(int, int, double, int *),
double stepf(int, int, double, double, int *),
double nrecf1(int, int, double, int*), double nrecf2(int, int, double, int*),
double *loglik, int maxit, double tol, int sexsp,
int verbose)
{
int i, j, j2, v, v2, it, flag=0, **Geno, ndigits;
double s, **alpha, **beta, **gamma, *cur_rf, *cur_rf2;
double curloglik, maxdif, temp;
char pattern[100], text[200];
int cross_scheme[2];
/* cross scheme hidden in loglik argument; used by hmm_bcsft */
cross_scheme[0] = (int) ftrunc(*loglik / 1000.0);
cross_scheme[1] = ((int) *loglik) - 1000 * cross_scheme[0];
*loglik = 0.0;
/* allocate space for beta and reorganize geno */
reorg_geno(n_ind, n_mar, geno, &Geno);
allocate_alpha(n_mar, n_gen, &alpha);
allocate_alpha(n_mar, n_gen, &beta);
allocate_dmatrix(n_gen, n_gen, &gamma);
allocate_double(n_mar-1, &cur_rf);
allocate_double(n_mar-1, &cur_rf2);
/* digits in verbose output */
if(verbose) {
ndigits = (int)ceil(-log10(tol));
if(ndigits > 16) ndigits=16;
sprintf(pattern, "%s%d.%df", "%", ndigits+3, ndigits+1);
}
/* begin EM algorithm */
for(it=0; it<maxit; it++) {
for(j=0; j<n_mar-1; j++) {
cur_rf[j] = cur_rf2[j] = rf[j];
rf[j] = 0.0;
if(sexsp) {
cur_rf2[j] = rf2[j];
rf2[j] = 0.0;
}
}
for(i=0; i<n_ind; i++) { /* i = individual */
R_CheckUserInterrupt(); /* check for ^C */
/* initialize alpha and beta */
for(v=0; v<n_gen; v++) {
alpha[v][0] = initf(v+1, cross_scheme) + emitf(Geno[0][i], v+1, error_prob, cross_scheme);
beta[v][n_mar-1] = 0.0;
}
/* forward-backward equations */
for(j=1,j2=n_mar-2; j<n_mar; j++, j2--) {
for(v=0; v<n_gen; v++) {
alpha[v][j] = alpha[0][j-1] + stepf(1, v+1, cur_rf[j-1], cur_rf2[j-1], cross_scheme);
beta[v][j2] = beta[0][j2+1] + stepf(v+1,1,cur_rf[j2], cur_rf2[j2], cross_scheme) +
emitf(Geno[j2+1][i],1,error_prob, cross_scheme);
for(v2=1; v2<n_gen; v2++) {
alpha[v][j] = addlog(alpha[v][j], alpha[v2][j-1] +
stepf(v2+1,v+1,cur_rf[j-1],cur_rf2[j-1], cross_scheme));
beta[v][j2] = addlog(beta[v][j2], beta[v2][j2+1] +
stepf(v+1,v2+1,cur_rf[j2],cur_rf2[j2], cross_scheme) +
emitf(Geno[j2+1][i],v2+1,error_prob, cross_scheme));
}
alpha[v][j] += emitf(Geno[j][i],v+1,error_prob, cross_scheme);
}
}
for(j=0; j<n_mar-1; j++) {
/* calculate gamma = log Pr(v1, v2, O) */
for(v=0, s=0.0; v<n_gen; v++) {
for(v2=0; v2<n_gen; v2++) {
gamma[v][v2] = alpha[v][j] + beta[v2][j+1] +
emitf(Geno[j+1][i], v2+1, error_prob, cross_scheme) +
stepf(v+1, v2+1, cur_rf[j], cur_rf2[j], cross_scheme);
if(v==0 && v2==0) s = gamma[v][v2];
else s = addlog(s, gamma[v][v2]);
}
}
for(v=0; v<n_gen; v++) {
for(v2=0; v2<n_gen; v2++) {
rf[j] += nrecf1(v+1,v2+1, cur_rf[j], cross_scheme) * exp(gamma[v][v2] - s);
if(sexsp) rf2[j] += nrecf2(v+1,v2+1, cur_rf[j], cross_scheme) * exp(gamma[v][v2] - s);
}
}
}
} /* loop over individuals */
/* rescale */
for(j=0; j<n_mar-1; j++) {
rf[j] /= (double)n_ind;
if(rf[j] < tol/1000.0) rf[j] = tol/1000.0;
else if(rf[j] > 0.5-tol/1000.0) rf[j] = 0.5-tol/1000.0;
if(sexsp) {
rf2[j] /= (double)n_ind;
if(rf2[j] < tol/1000.0) rf2[j] = tol/1000.0;
else if(rf2[j] > 0.5-tol/1000.0) rf2[j] = 0.5-tol/1000.0;
}
else rf2[j] = rf[j];
}
if(verbose>1) {
/* print estimates as we go along*/
Rprintf(" %4d ", it+1);
maxdif=0.0;
for(j=0; j<n_mar-1; j++) {
temp = fabs(rf[j] - cur_rf[j])/(cur_rf[j]+tol*100.0);
if(maxdif < temp) maxdif = temp;
if(sexsp) {
temp = fabs(rf2[j] - cur_rf2[j])/(cur_rf2[j]+tol*100.0);
if(maxdif < temp) maxdif = temp;
}
/* bsy add */
if(verbose > 2)
Rprintf("%d %f %f\n", j+1, cur_rf[j], rf[j]);
/* bsy add */
}
sprintf(text, "%s%s\n", " max rel've change = ", pattern);
Rprintf(text, maxdif);
}
/* check convergence */
for(j=0, flag=0; j<n_mar-1; j++) {
if(fabs(rf[j] - cur_rf[j]) > tol*(cur_rf[j]+tol*100.0) ||
(sexsp && fabs(rf2[j] - cur_rf2[j]) > tol*(cur_rf2[j]+tol*100.0))) {
flag = 1;
break;
}
}
if(!flag) break;
} /* end EM algorithm */
if(flag) warning("Didn't converge!\n");
/* calculate log likelihood */
*loglik = 0.0;
for(i=0; i<n_ind; i++) { /* i = individual */
/* initialize alpha */
for(v=0; v<n_gen; v++) {
alpha[v][0] = initf(v+1, cross_scheme) + emitf(Geno[0][i], v+1, error_prob, cross_scheme);
}
/* forward equations */
for(j=1; j<n_mar; j++) {
for(v=0; v<n_gen; v++) {
alpha[v][j] = alpha[0][j-1] +
stepf(1, v+1, rf[j-1], rf2[j-1], cross_scheme);
for(v2=1; v2<n_gen; v2++)
alpha[v][j] = addlog(alpha[v][j], alpha[v2][j-1] +
stepf(v2+1,v+1,rf[j-1],rf2[j-1], cross_scheme));
alpha[v][j] += emitf(Geno[j][i],v+1,error_prob, cross_scheme);
}
}
curloglik = alpha[0][n_mar-1];
for(v=1; v<n_gen; v++)
curloglik = addlog(curloglik, alpha[v][n_mar-1]);
*loglik += curloglik;
}
if(verbose) {
if(verbose < 2) {
/* print final estimates */
Rprintf(" no. iterations = %d\n", it+1);
maxdif=0.0;
for(j=0; j<n_mar-1; j++) {
temp = fabs(rf[j] - cur_rf[j])/(cur_rf[j]+tol*100.0);
if(maxdif < temp) maxdif = temp;
if(sexsp) {
temp = fabs(rf2[j] - cur_rf2[j])/(cur_rf2[j]+tol*100.0);
if(maxdif < temp) maxdif = temp;
}
}
sprintf(text, "%s%s\n", " max rel've change at last step = ", pattern);
Rprintf(text, maxdif);
}
Rprintf(" loglik: %10.4lf\n\n", *loglik);
}
}
double random_walk(int *model, struct Var *vars, int n) {
int index;
index = ftrunc(n*unif_rand());
model[vars[index].index] = 1 - model[vars[index].index];
return(1.0);
}
double attribute_hidden gamma_cody(double x)
{
/* ----------------------------------------------------------------------
This routine calculates the GAMMA function for a float argument X.
Computation is based on an algorithm outlined in reference [1].
The program uses rational functions that approximate the GAMMA
function to at least 20 significant decimal digits. Coefficients
for the approximation over the interval (1,2) are unpublished.
Those for the approximation for X >= 12 are from reference [2].
The accuracy achieved depends on the arithmetic system, the
compiler, the intrinsic functions, and proper selection of the
machine-dependent constants.
*******************************************************************
Error returns
The program returns the value XINF for singularities or
when overflow would occur. The computation is believed
to be free of underflow and overflow.
Intrinsic functions required are:
INT, DBLE, EXP, LOG, REAL, SIN
References:
[1] "An Overview of Software Development for Special Functions",
W. J. Cody, Lecture Notes in Mathematics, 506,
Numerical Analysis Dundee, 1975, G. A. Watson (ed.),
Springer Verlag, Berlin, 1976.
[2] Computer Approximations, Hart, Et. Al., Wiley and sons, New York, 1968.
Latest modification: October 12, 1989
Authors: W. J. Cody and L. Stoltz
Applied Mathematics Division
Argonne National Laboratory
Argonne, IL 60439
----------------------------------------------------------------------*/
/* ----------------------------------------------------------------------
Mathematical constants
----------------------------------------------------------------------*/
const static double sqrtpi = .9189385332046727417803297; /* == ??? */
/* *******************************************************************
Explanation of machine-dependent constants
beta - radix for the floating-point representation
maxexp - the smallest positive power of beta that overflows
XBIG - the largest argument for which GAMMA(X) is representable
in the machine, i.e., the solution to the equation
GAMMA(XBIG) = beta**maxexp
XINF - the largest machine representable floating-point number;
approximately beta**maxexp
EPS - the smallest positive floating-point number such that 1.0+EPS > 1.0
XMININ - the smallest positive floating-point number such that
1/XMININ is machine representable
Approximate values for some important machines are:
beta maxexp XBIG
CRAY-1 (S.P.) 2 8191 966.961
Cyber 180/855
under NOS (S.P.) 2 1070 177.803
IEEE (IBM/XT,
SUN, etc.) (S.P.) 2 128 35.040
IEEE (IBM/XT,
SUN, etc.) (D.P.) 2 1024 171.624
IBM 3033 (D.P.) 16 63 57.574
VAX D-Format (D.P.) 2 127 34.844
VAX G-Format (D.P.) 2 1023 171.489
XINF EPS XMININ
CRAY-1 (S.P.) 5.45E+2465 7.11E-15 1.84E-2466
Cyber 180/855
under NOS (S.P.) 1.26E+322 3.55E-15 3.14E-294
IEEE (IBM/XT,
SUN, etc.) (S.P.) 3.40E+38 1.19E-7 1.18E-38
IEEE (IBM/XT,
SUN, etc.) (D.P.) 1.79D+308 2.22D-16 2.23D-308
IBM 3033 (D.P.) 7.23D+75 2.22D-16 1.39D-76
VAX D-Format (D.P.) 1.70D+38 1.39D-17 5.88D-39
VAX G-Format (D.P.) 8.98D+307 1.11D-16 1.12D-308
*******************************************************************
----------------------------------------------------------------------
Machine dependent parameters
----------------------------------------------------------------------
*/
const static double xbig = 171.624;
/* ML_POSINF == const double xinf = 1.79e308;*/
/* DBL_EPSILON = const double eps = 2.22e-16;*/
/* DBL_MIN == const double xminin = 2.23e-308;*/
/*----------------------------------------------------------------------
Numerator and denominator coefficients for rational minimax
approximation over (1,2).
----------------------------------------------------------------------*/
const static double p[8] = {
-1.71618513886549492533811,
24.7656508055759199108314,-379.804256470945635097577,
629.331155312818442661052,866.966202790413211295064,
-31451.2729688483675254357,-36144.4134186911729807069,
66456.1438202405440627855 };
const static double q[8] = {
-30.8402300119738975254353,
315.350626979604161529144,-1015.15636749021914166146,
-3107.77167157231109440444,22538.1184209801510330112,
4755.84627752788110767815,-134659.959864969306392456,
-115132.259675553483497211 };
/*----------------------------------------------------------------------
Coefficients for minimax approximation over (12, INF).
----------------------------------------------------------------------*/
const static double c[7] = {
-.001910444077728,8.4171387781295e-4,
-5.952379913043012e-4,7.93650793500350248e-4,
-.002777777777777681622553,.08333333333333333331554247,
.0057083835261 };
/* Local variables */
long i, n;
long int parity;/*logical*/
double fact, xden, xnum, y, z, yi, res, sum, ysq;
parity = (0);
fact = 1.;
n = 0;
y = x;
if (y <= 0.) {
/* -------------------------------------------------------------
Argument is negative
------------------------------------------------------------- */
y = -x;
yi = ftrunc(y);
res = y - yi;
if (res != 0.) {
if (yi != ftrunc(yi * .5) * 2.)
parity = (1);
fact = -M_PI / sin(M_PI * res);
y += 1.;
} else {
return(ML_POSINF);
}
}
/* -----------------------------------------------------------------
Argument is positive
-----------------------------------------------------------------*/
if (y < DBL_EPSILON) {
/* --------------------------------------------------------------
Argument < EPS
-------------------------------------------------------------- */
if (y >= DBL_MIN) {
res = 1. / y;
} else {
return(ML_POSINF);
}
} else if (y < 12.) {
yi = y;
if (y < 1.) {
/* ---------------------------------------------------------
EPS < argument < 1
--------------------------------------------------------- */
z = y;
y += 1.;
} else {
/* -----------------------------------------------------------
1 <= argument < 12, reduce argument if necessary
----------------------------------------------------------- */
n = (long) y - 1;
y -= (double) n;
z = y - 1.;
}
/* ---------------------------------------------------------
Evaluate approximation for 1. < argument < 2.
---------------------------------------------------------*/
xnum = 0.;
xden = 1.;
for (i = 0; i < 8; ++i) {
xnum = (xnum + p[i]) * z;
xden = xden * z + q[i];
}
res = xnum / xden + 1.;
if (yi < y) {
/* --------------------------------------------------------
Adjust result for case 0. < argument < 1.
-------------------------------------------------------- */
res /= yi;
} else if (yi > y) {
/* ----------------------------------------------------------
Adjust result for case 2. < argument < 12.
---------------------------------------------------------- */
for (i = 0; i < n; ++i) {
res *= y;
y += 1.;
}
}
} else {
/* -------------------------------------------------------------
Evaluate for argument >= 12.,
------------------------------------------------------------- */
if (y <= xbig) {
ysq = y * y;
sum = c[6];
for (i = 0; i < 6; ++i) {
sum = sum / ysq + c[i];
}
sum = sum / y - y + sqrtpi;
sum += (y - .5) * log(y);
res = exp(sum);
} else {
return(ML_POSINF);
}
}
/* ----------------------------------------------------------------------
Final adjustments and return
----------------------------------------------------------------------*/
if (parity)
res = -res;
if (fact != 1.)
res = fact / res;
return res;
}
void isevect(double *t, int *delta, int *n, int *nboot, double *gridise, int *legridise, double *gridbw1, int *legridbw1, double *gridbw2, int *legridbw2, int *nkernel, int * dup, int *nestimand, double *phat, double *estim, int* presmoothing, double *isev){
int i, j, k, boot, *indices, *deltaboot, *pnull;
double *pnull2, *ptemp, *estimboot, *tboot, *integrand, *isecomp, *deltabootdbl;
indices = malloc(*n * sizeof(int));
ptemp = malloc(*n * sizeof(double));
estimboot = malloc(*legridise * sizeof(double));
tboot = malloc(*n * sizeof(double));
integrand = malloc(*legridise * sizeof(double));
isecomp = malloc(sizeof(double));
GetRNGstate();
if(*presmoothing == 1){ // with presmoothing
deltaboot = malloc(*n * sizeof(int));
switch(*nestimand){
// S
case 1:
pnull = calloc(1, sizeof(int));
pnull2 = calloc(1, sizeof(double));
for (boot = 0; boot < *nboot; boot++){
R_FlushConsole();
R_ProcessEvents();
for (i = 0; i < *n; i++)
indices[i] = (int)ftrunc(runif(0, 1) * (*n));
R_isort(indices, *n);
for (i = 0; i < *n; i++){
tboot[i] = t[indices[i]];
deltaboot[i] = (int)rbinom(1, phat[indices[i]]);
}
for (i = 0; i < *legridbw1; i++){
nadarayawatson(tboot, n, tboot, deltaboot, n, &(gridbw1[i]), nkernel, ptemp);
presmestim(gridise, legridise, tboot, n, pnull2, pnull, pnull, ptemp, pnull, nestimand, estimboot);
for (j = 0; j < *legridise; j++)
integrand[j] = (estimboot[j] - estim[j])*(estimboot[j] - estim[j]);
simpson(integrand, legridise, isecomp);
isev[i] += *isecomp;
}
}
free(pnull);
free(pnull2);
break;
// H
case 2:
pnull = calloc(1, sizeof(int));
for (boot = 0; boot < *nboot; boot++){
R_FlushConsole();
R_ProcessEvents();
for (i = 0; i < *n; i++)
indices[i] = (int)ftrunc(runif(0, 1) * (*n));
R_isort(indices, *n);
for (i = 0; i < *n; i++){
tboot[i] = t[indices[i]];
deltaboot[i] = (int)rbinom(1, phat[indices[i]]);
}
for (i = 0; i < *legridbw1; i++){
nadarayawatson(tboot, n, tboot, deltaboot, n, &(gridbw1[i]), nkernel, ptemp);
presmestim(gridise, legridise, tboot, n, gridbw2, nkernel, pnull, ptemp, dup, nestimand, estimboot);
for (j = 0; j < *legridise; j++)
integrand[j] = (estimboot[j] - estim[j])*(estimboot[j] - estim[j]);
simpson(integrand, legridise, isecomp);
isev[i] += *isecomp;
}
}
free(pnull);
break;
// f
case 3:
for (boot = 0; boot < *nboot; boot++){
R_FlushConsole();
R_ProcessEvents();
for (i = 0; i < *n; i++)
indices[i] = (int)ftrunc(runif(0, 1) * (*n));
R_isort(indices, *n);
for (i = 0; i < *n; i++){
tboot[i] = t[indices[i]];
deltaboot[i] = (int)rbinom(1, phat[indices[i]]);
}
for (j = 0; j < *legridbw2; j++)
for (i = 0; i < *legridbw1; i++){
nadarayawatson(tboot, n, tboot, deltaboot, n, &(gridbw1[i]), nkernel, ptemp);
presmdensfast(gridise, legridise, tboot, n, &(gridbw2[j]), nkernel, ptemp, estimboot);
for (k = 0; k < *legridise; k++)
integrand[k] = (estimboot[k] - estim[k])*(estimboot[k] - estim[k]);
simpson(integrand, legridise, isecomp);
isev[j * (*legridbw1) + i] += *isecomp;
}
}
break;
// h
case 4:
for (boot = 0; boot < *nboot; boot++){
R_FlushConsole();
R_ProcessEvents();
for (i = 0; i < *n; i++)
indices[i] = (int)ftrunc(runif(0, 1) * (*n));
R_isort(indices, *n);
for (i = 0; i < *n; i++){
tboot[i] = t[indices[i]];
deltaboot[i] = (int)rbinom(1, phat[indices[i]]);
}
for (j = 0; j < *legridbw2; j++)
for (i = 0; i < *legridbw1; i++){
nadarayawatson(tboot, n, tboot, deltaboot, n, &(gridbw1[i]), nkernel, ptemp);
presmtwfast(gridise, legridise, tboot, n, &(gridbw2[j]), nkernel, dup, ptemp, estimboot);
for (k = 0; k < *legridise; k++)
integrand[k] = (estimboot[k] - estim[k])*(estimboot[k] - estim[k]);
simpson(integrand, legridise, isecomp);
isev[j * (*legridbw1) + i] += *isecomp;
}
}
break;
default:
break;
}
free(deltaboot);
}
else{ // without presmoothing
deltabootdbl = malloc(*n * sizeof(double));
if(*nestimand == 3){
// f
for (boot = 0; boot < *nboot; boot++){
R_FlushConsole();
R_ProcessEvents();
for (i = 0; i < *n; i++)
indices[i] = (int)ftrunc(runif(0, 1) * (*n));
R_isort(indices, *n);
for (i = 0; i < *n; i++){
tboot[i] = t[indices[i]];
deltabootdbl[i] = (double)delta[indices[i]];
}
for (i = 0; i < *legridbw2; i++){
presmdensfast(gridise, legridise, tboot, n, &(gridbw2[i]), nkernel, deltabootdbl, estimboot);
for (j = 0; j < *legridise; j++)
integrand[j] = (estimboot[j] - estim[j])*(estimboot[j] - estim[j]);
simpson(integrand, legridise, isecomp);
isev[i] += *isecomp;
}
}
}
else{
// h
for (boot = 0; boot < *nboot; boot++){
R_FlushConsole();
R_ProcessEvents();
for (i = 0; i < *n; i++)
indices[i] = (int)ftrunc(runif(0, 1) * (*n));
R_isort(indices, *n);
for (i = 0; i < *n; i++){
tboot[i] = t[indices[i]];
deltabootdbl[i] = (double)delta[indices[i]];
}
for (i = 0; i < *legridbw2; i++){
presmtwfast(gridise, legridise, tboot, n, &(gridbw2[i]), nkernel, dup, deltabootdbl, estimboot);
for (j = 0; j < *legridise; j++)
integrand[j] = (estimboot[j] - estim[j])*(estimboot[j] - estim[j]);
simpson(integrand, legridise, isecomp);
isev[i] += *isecomp;
}
}
}
free(deltabootdbl);
}
PutRNGstate();
free(indices);
free(ptemp);
free(estimboot);
free(tboot);
free(integrand);
free(isecomp);
}
void MARprobit(int *Y, /* binary outcome variable */
int *Ymiss, /* missingness indicator for Y */
int *iYmax, /* maximum value of Y; 0,1,...,Ymax */
int *Z, /* treatment assignment */
int *D, /* treatment status */
int *C, /* compliance status */
double *dX, double *dXo, /* covariates */
double *dBeta, double *dGamma, /* coefficients */
int *iNsamp, int *iNgen, int *iNcov, int *iNcovo,
int *iNcovoX, int *iN11,
/* counters */
double *beta0, double *gamma0, double *dA, double *dAo, /*prior */
int *insample, /* 1: insample inference, 2: conditional inference */
int *smooth,
int *param, int *mda, int *iBurnin,
int *iKeep, int *verbose, /* options */
double *pdStore
) {
/*** counters ***/
int n_samp = *iNsamp; /* sample size */
int n_gen = *iNgen; /* number of gibbs draws */
int n_cov = *iNcov; /* number of covariates */
int n_covo = *iNcovo; /* number of all covariates for outcome model */
int n_covoX = *iNcovoX; /* number of covariates excluding smooth
terms */
int n11 = *iN11; /* number of compliers in the treament group */
/*** data ***/
double **X; /* covariates for the compliance model */
double **Xo; /* covariates for the outcome model */
double *W; /* latent variable */
int Ymax = *iYmax;
/*** model parameters ***/
double *beta; /* coef for compliance model */
double *gamma; /* coef for outcomme model */
double *q; /* some parameters for sampling C */
double *pc;
double *pn;
double pcmean;
double pnmean;
double **SS; /* matrix folders for SWEEP */
double **SSo;
// HJ commented it out on April 17, 2018
// double **SSr;
double *meanb; /* means for beta and gamma */
double *meano;
double *meanr;
double **V; /* variances for beta and gamma */
double **Vo;
double **Vr;
double **A;
double **Ao;
double *tau; /* thresholds: tau_0, ..., tau_{Ymax-1} */
double *taumax; /* corresponding max and min for tau */
double *taumin; /* tau_0 is fixed to 0 */
double *treat; /* smooth function for treat */
/*** quantities of interest ***/
int n_comp, n_compC, n_ncompC;
double *ITTc;
double *base;
/*** storage parameters and loop counters **/
int progress = 1;
int keep = 1;
int i, j, k, main_loop;
int itemp, itempP = ftrunc((double) n_gen/10);
double dtemp, ndraw, cdraw;
double *vtemp;
double **mtemp, **mtempo;
/*** marginal data augmentation ***/
double sig2 = 1;
int nu0 = 1;
double s0 = 1;
/*** get random seed **/
GetRNGstate();
/*** define vectors and matricies **/
X = doubleMatrix(n_samp+n_cov, n_cov+1);
Xo = doubleMatrix(n_samp+n_covo, n_covo+1);
W = doubleArray(n_samp);
tau = doubleArray(Ymax);
taumax = doubleArray(Ymax);
taumin = doubleArray(Ymax);
SS = doubleMatrix(n_cov+1, n_cov+1);
SSo = doubleMatrix(n_covo+1, n_covo+1);
// HJ commented it out on April 17, 2018
// SSr = doubleMatrix(4, 4);
V = doubleMatrix(n_cov, n_cov);
Vo = doubleMatrix(n_covo, n_covo);
Vr = doubleMatrix(3, 3);
beta = doubleArray(n_cov);
gamma = doubleArray(n_covo);
meanb = doubleArray(n_cov);
meano = doubleArray(n_covo);
meanr = doubleArray(3);
q = doubleArray(n_samp);
pc = doubleArray(n_samp);
pn = doubleArray(n_samp);
A = doubleMatrix(n_cov, n_cov);
Ao = doubleMatrix(n_covo, n_covo);
vtemp = doubleArray(n_samp);
mtemp = doubleMatrix(n_cov, n_cov);
mtempo = doubleMatrix(n_covo, n_covo);
ITTc = doubleArray(Ymax+1);
treat = doubleArray(n11);
base = doubleArray(2);
/*** read the data ***/
itemp = 0;
for (j =0; j < n_cov; j++)
for (i = 0; i < n_samp; i++)
X[i][j] = dX[itemp++];
itemp = 0;
for (j =0; j < n_covo; j++)
for (i = 0; i < n_samp; i++)
Xo[i][j] = dXo[itemp++];
/*** read the prior and it as additional data points ***/
itemp = 0;
for (k = 0; k < n_cov; k++)
for (j = 0; j < n_cov; j++)
A[j][k] = dA[itemp++];
itemp = 0;
for (k = 0; k < n_covo; k++)
for (j = 0; j < n_covo; j++)
Ao[j][k] = dAo[itemp++];
dcholdc(A, n_cov, mtemp);
for(i = 0; i < n_cov; i++) {
X[n_samp+i][n_cov]=0;
for(j = 0; j < n_cov; j++) {
X[n_samp+i][n_cov] += mtemp[i][j]*beta0[j];
X[n_samp+i][j] = mtemp[i][j];
}
}
dcholdc(Ao, n_covo, mtempo);
for(i = 0; i < n_covo; i++) {
Xo[n_samp+i][n_covo]=0;
for(j = 0; j < n_covo; j++) {
Xo[n_samp+i][n_covo] += mtempo[i][j]*gamma0[j];
Xo[n_samp+i][j] = mtempo[i][j];
}
}
/*** starting values ***/
for (i = 0; i < n_cov; i++)
beta[i] = dBeta[i];
for (i = 0; i < n_covo; i++)
gamma[i] = dGamma[i];
if (Ymax > 1) {
tau[0] = 0.0;
taumax[0] = 0.0;
taumin[0] = 0.0;
for (i = 1; i < Ymax; i++)
tau[i] = tau[i-1]+2/(double)(Ymax-1);
}
for (i = 0; i < n_samp; i++) {
pc[i] = unif_rand();
pn[i] = unif_rand();
}
/*** Gibbs Sampler! ***/
itemp=0;
for(main_loop = 1; main_loop <= n_gen; main_loop++){
/** COMPLIANCE MODEL **/
if (*mda) sig2 = s0/rchisq((double)nu0);
/* Draw complier status for control group */
for(i = 0; i < n_samp; i++){
dtemp = 0;
for(j = 0; j < n_cov; j++)
dtemp += X[i][j]*beta[j];
if(Z[i] == 0){
q[i] = pnorm(dtemp, 0, 1, 1, 0);
if(unif_rand() < (q[i]*pc[i]/(q[i]*pc[i]+(1-q[i])*pn[i]))) {
C[i] = 1; Xo[i][1] = 1;
}
else {
C[i] = 0; Xo[i][1] = 0;
}
}
/* Sample W */
if(C[i]==0)
W[i] = TruncNorm(dtemp-100,0,dtemp,1,0);
else
W[i] = TruncNorm(0,dtemp+100,dtemp,1,0);
X[i][n_cov] = W[i]*sqrt(sig2);
W[i] *= sqrt(sig2);
}
/* SS matrix */
for(j = 0; j <= n_cov; j++)
for(k = 0; k <= n_cov; k++)
SS[j][k]=0;
for(i = 0; i < n_samp+n_cov; i++)
for(j = 0; j <= n_cov; j++)
for(k = 0; k <= n_cov; k++)
SS[j][k] += X[i][j]*X[i][k];
/* SWEEP SS matrix */
for(j = 0; j < n_cov; j++)
SWP(SS, j, n_cov+1);
/* draw beta */
for(j = 0; j < n_cov; j++)
meanb[j] = SS[j][n_cov];
if (*mda)
sig2=(SS[n_cov][n_cov]+s0)/rchisq((double)n_samp+nu0);
for(j = 0; j < n_cov; j++)
for(k = 0; k < n_cov; k++) V[j][k] = -SS[j][k]*sig2;
rMVN(beta, meanb, V, n_cov);
/* rescale the parameters */
if(*mda) {
for (i = 0; i < n_cov; i++) beta[i] /= sqrt(sig2);
}
/** OUTCOME MODEL **/
/* Sample W */
if (Ymax > 1) { /* tau_0=0, tau_1, ... */
for (j = 1; j < (Ymax - 1); j++) {
taumax[j] = tau[j+1];
taumin[j] = tau[j-1];
}
taumax[Ymax-1] = tau[Ymax-1]+100;
taumin[Ymax-1] = tau[Ymax-2];
}
if (*mda) sig2 = s0/rchisq((double)nu0);
for (i = 0; i < n_samp; i++){
dtemp = 0;
for (j = 0; j < n_covo; j++) dtemp += Xo[i][j]*gamma[j];
if (Ymiss[i] == 1) {
W[i] = dtemp + norm_rand();
if (Ymax == 1) { /* binary probit */
if (W[i] > 0) Y[i] = 1;
else Y[i] = 0;
}
else { /* ordered probit */
if (W[i] >= tau[Ymax-1])
Y[i] = Ymax;
else {
j = 0;
while (W[i] > tau[j] && j < Ymax) j++;
Y[i] = j;
}
}
}
else {
if(Ymax == 1) { /* binary probit */
if(Y[i] == 0) W[i] = TruncNorm(dtemp-100,0,dtemp,1,0);
else W[i] = TruncNorm(0,dtemp+100,dtemp,1,0);
}
else { /* ordered probit */
if (Y[i] == 0)
W[i] = TruncNorm(dtemp-100, 0, dtemp, 1, 0);
else if (Y[i] == Ymax) {
W[i] = TruncNorm(tau[Ymax-1], dtemp+100, dtemp, 1, 0);
if (W[i] < taumax[Ymax-1]) taumax[Ymax-1] = W[i];
}
else {
W[i] = TruncNorm(tau[Y[i]-1], tau[Y[i]], dtemp, 1, 0);
if (W[i] > taumin[Y[i]]) taumin[Y[i]] = W[i];
if (W[i] < taumax[Y[i]-1]) taumax[Y[i]-1] = W[i];
}
}
}
Xo[i][n_covo] = W[i]*sqrt(sig2);
W[i] *= sqrt(sig2);
}
/* draw tau */
if (Ymax > 1)
for (j = 1; j < Ymax; j++)
tau[j] = runif(taumin[j], taumax[j])*sqrt(sig2);
/* SS matrix */
for(j = 0; j <= n_covo; j++)
for(k = 0; k <= n_covo; k++)
SSo[j][k]=0;
for(i = 0;i < n_samp+n_covo; i++)
for(j = 0;j <= n_covo; j++)
for(k = 0; k <= n_covo; k++)
SSo[j][k] += Xo[i][j]*Xo[i][k];
/* SWEEP SS matrix */
for(j = 0; j < n_covo; j++)
SWP(SSo, j, n_covo+1);
/* draw gamma */
for(j = 0; j < n_covo; j++)
meano[j] = SSo[j][n_covo];
if (*mda)
sig2=(SSo[n_covo][n_covo]+s0)/rchisq((double)n_samp+nu0);
for(j = 0; j < n_covo; j++)
for(k = 0; k < n_covo; k++) Vo[j][k]=-SSo[j][k]*sig2;
rMVN(gamma, meano, Vo, n_covo);
/* rescaling the parameters */
if(*mda) {
for (i = 0; i < n_covo; i++) gamma[i] /= sqrt(sig2);
if (Ymax > 1)
for (i = 1; i < Ymax; i++)
tau[i] /= sqrt(sig2);
}
/* computing smooth terms */
if (*smooth) {
for (i = 0; i < n11; i++) {
treat[i] = 0;
for (j = n_covoX; j < n_covo; j++)
treat[i] += Xo[i][j]*gamma[j];
}
}
/** Compute probabilities **/
for(i = 0; i < n_samp; i++){
vtemp[i] = 0;
for(j = 0; j < n_covo; j++)
vtemp[i] += Xo[i][j]*gamma[j];
}
for(i = 0; i < n_samp; i++){
if(Z[i]==0){
if (C[i] == 1) {
pcmean = vtemp[i];
if (*smooth)
pnmean = vtemp[i]-gamma[0];
else
pnmean = vtemp[i]-gamma[1];
}
else {
if (*smooth)
pcmean = vtemp[i]+gamma[0];
else
pcmean = vtemp[i]+gamma[1];
pnmean = vtemp[i];
}
if (Y[i] == 0){
pc[i] = pnorm(0, pcmean, 1, 1, 0);
pn[i] = pnorm(0, pnmean, 1, 1, 0);
}
else {
if (Ymax == 1) { /* binary probit */
pc[i] = pnorm(0, pcmean, 1, 0, 0);
pn[i] = pnorm(0, pnmean, 1, 0, 0);
}
else { /* ordered probit */
if (Y[i] == Ymax) {
pc[i] = pnorm(tau[Ymax-1], pcmean, 1, 0, 0);
pn[i] = pnorm(tau[Ymax-1], pnmean, 1, 0, 0);
}
else {
pc[i] = pnorm(tau[Y[i]], pcmean, 1, 1, 0) -
pnorm(tau[Y[i]-1], pcmean, 1, 1, 0);
pn[i] = pnorm(tau[Y[i]], pnmean, 1, 1, 0) -
pnorm(tau[Y[i]-1], pnmean, 1, 1, 0);
}
}
}
}
}
/** Compute quantities of interest **/
n_comp = 0; n_compC = 0; n_ncompC = 0; base[0] = 0; base[1] = 0;
for (i = 0; i <= Ymax; i++)
ITTc[i] = 0;
if (*smooth) {
for(i = 0; i < n11; i++){
if(C[i] == 1) {
n_comp++;
if (Z[i] == 0) {
n_compC++;
base[0] += (double)Y[i];
}
pcmean = vtemp[i];
pnmean = vtemp[i]-treat[i]+gamma[0];
ndraw = rnorm(pnmean, 1);
cdraw = rnorm(pcmean, 1);
if (*insample && Ymiss[i]==0)
dtemp = (double)(Y[i]==0) - (double)(ndraw < 0);
else
dtemp = pnorm(0, pcmean, 1, 1, 0) - pnorm(0, pnmean, 1, 1, 0);
ITTc[0] += dtemp;
if (Ymax == 1) { /* binary probit */
if (*insample && Ymiss[i]==0)
dtemp = (double)Y[i] - (double)(ndraw > 0);
else
dtemp = pnorm(0, pcmean, 1, 0, 0) - pnorm(0, pnmean, 1, 0, 0);
ITTc[1] += dtemp;
}
else { /* ordered probit */
if (*insample && Ymiss[i]==0)
dtemp = (double)(Y[i]==Ymax) - (double)(ndraw > tau[Ymax-1]);
else
dtemp = pnorm(tau[Ymax-1], pcmean, 1, 0, 0) -
pnorm(tau[Ymax-1], pnmean, 1, 0, 0);
ITTc[Ymax] += dtemp;
for (j = 1; j < Ymax; j++) {
if (*insample && Ymiss[i]==0)
dtemp = (double)(Y[i]==j) - (double)(ndraw < tau[j] &&
ndraw > tau[j-1]);
else
dtemp = (pnorm(tau[j], pcmean, 1, 1, 0) -
pnorm(tau[j-1], pcmean, 1, 1, 0))
- (pnorm(tau[j], pnmean, 1, 1, 0) -
pnorm(tau[j-1], pnmean, 1, 1, 0));
ITTc[j] += dtemp;
}
}
}
else
if (Z[i] == 0) {
n_ncompC++;
base[1] += (double)Y[i];
}
}
}
else {
for(i = 0; i < n_samp; i++){
if(C[i] == 1) {
n_comp++;
if (Z[i] == 1) {
pcmean = vtemp[i];
pnmean = vtemp[i]-gamma[0]+gamma[1];
}
else {
n_compC++;
base[0] += (double)Y[i];
pcmean = vtemp[i]+gamma[0]-gamma[1];
pnmean = vtemp[i];
}
ndraw = rnorm(pnmean, 1);
cdraw = rnorm(pcmean, 1);
if (*insample && Ymiss[i]==0) {
if (Z[i] == 1)
dtemp = (double)(Y[i]==0) - (double)(ndraw < 0);
else
dtemp = (double)(cdraw < 0) - (double)(Y[i]==0);
}
else
dtemp = pnorm(0, pcmean, 1, 1, 0) - pnorm(0, pnmean, 1, 1, 0);
ITTc[0] += dtemp;
if (Ymax == 1) { /* binary probit */
if (*insample && Ymiss[i]==0) {
if (Z[i] == 1)
dtemp = (double)Y[i] - (double)(ndraw > 0);
else
dtemp = (double)(cdraw > 0) - (double)Y[i];
}
else
dtemp = pnorm(0, pcmean, 1, 0, 0) - pnorm(0, pnmean, 1, 0, 0);
ITTc[1] += dtemp;
}
else { /* ordered probit */
if (*insample && Ymiss[i]==0) {
if (Z[i] == 1)
dtemp = (double)(Y[i]==Ymax) - (double)(ndraw > tau[Ymax-1]);
else
dtemp = (double)(cdraw > tau[Ymax-1]) - (double)(Y[i]==Ymax);
}
else
dtemp = pnorm(tau[Ymax-1], pcmean, 1, 0, 0) -
pnorm(tau[Ymax-1], pnmean, 1, 0, 0);
ITTc[Ymax] += dtemp;
for (j = 1; j < Ymax; j++) {
if (*insample && Ymiss[i]==0) {
if (Z[i] == 1)
dtemp = (double)(Y[i]==j) - (double)(ndraw < tau[j] && ndraw > tau[j-1]);
else
dtemp = (pnorm(tau[j], pcmean, 1, 1, 0) -
pnorm(tau[j-1], pcmean, 1, 1, 0)) - (double)(Y[i]==j);
}
else
dtemp = (pnorm(tau[j], pcmean, 1, 1, 0) -
pnorm(tau[j-1], pcmean, 1, 1, 0))
- (pnorm(tau[j], pnmean, 1, 1, 0) -
pnorm(tau[j-1], pnmean, 1, 1, 0));
ITTc[j] += dtemp;
}
}
}
else
if (Z[i] == 0) {
n_ncompC++;
base[1] += (double)Y[i];
}
}
}
/** storing the results **/
if (main_loop > *iBurnin) {
if (keep == *iKeep) {
pdStore[itemp++]=(double)n_comp/(double)n_samp;
if (Ymax == 1) {
pdStore[itemp++]=ITTc[1]/(double)n_comp;
pdStore[itemp++]=ITTc[1]/(double)n_samp;
pdStore[itemp++] = base[0]/(double)n_compC;
pdStore[itemp++] = base[1]/(double)n_ncompC;
pdStore[itemp++] = (base[0]+base[1])/(double)(n_compC+n_ncompC);
}
else {
for (i = 0; i <= Ymax; i++)
pdStore[itemp++]=ITTc[i]/(double)n_comp;
for (i = 0; i <= Ymax; i++)
pdStore[itemp++]=ITTc[i]/(double)n_samp;
}
if (*param) {
for(i = 0; i < n_cov; i++)
pdStore[itemp++]=beta[i];
if (*smooth) {
for(i = 0; i < n_covoX; i++)
pdStore[itemp++]=gamma[i];
for(i = 0; i < n11; i++)
pdStore[itemp++]=treat[i];
}
else
for(i = 0; i < n_covo; i++)
pdStore[itemp++]=gamma[i];
if (Ymax > 1)
for (i = 0; i < Ymax; i++)
pdStore[itemp++]=tau[i];
}
keep = 1;
}
else
keep++;
}
if(*verbose) {
if(main_loop == itempP) {
Rprintf("%3d percent done.\n", progress*10);
itempP += ftrunc((double) n_gen/10);
progress++;
R_FlushConsole();
}
}
R_FlushConsole();
R_CheckUserInterrupt();
} /* end of Gibbs sampler */
/** write out the random seed **/
PutRNGstate();
/** freeing memory **/
FreeMatrix(X, n_samp+n_cov);
FreeMatrix(Xo, n_samp+n_covo);
free(W);
free(beta);
free(gamma);
free(q);
free(pc);
free(pn);
FreeMatrix(SS, n_cov+1);
FreeMatrix(SSo, n_covo+1);
free(meanb);
free(meano);
free(meanr);
FreeMatrix(V, n_cov);
FreeMatrix(Vo, n_covo);
FreeMatrix(Vr, 3);
FreeMatrix(A, n_cov);
FreeMatrix(Ao, n_covo);
free(tau);
free(taumax);
free(taumin);
free(ITTc);
free(vtemp);
free(treat);
free(base);
FreeMatrix(mtemp, n_cov);
FreeMatrix(mtempo, n_covo);
} /* main */
static void K_bessel(double *x, double *alpha, long *nb,
long *ize, double *bk, long *ncalc)
{
/*-------------------------------------------------------------------
This routine calculates modified Bessel functions
of the third kind, K_(N+ALPHA) (X), for non-negative
argument X, and non-negative order N+ALPHA, with or without
exponential scaling.
Explanation of variables in the calling sequence
X - Non-negative argument for which
K's or exponentially scaled K's (K*EXP(X))
are to be calculated. If K's are to be calculated,
X must not be greater than XMAX_BESS_K.
ALPHA - Fractional part of order for which
K's or exponentially scaled K's (K*EXP(X)) are
to be calculated. 0 <= ALPHA < 1.0.
NB - Number of functions to be calculated, NB > 0.
The first function calculated is of order ALPHA, and the
last is of order (NB - 1 + ALPHA).
IZE - Type. IZE = 1 if unscaled K's are to be calculated,
= 2 if exponentially scaled K's are to be calculated.
BK - Output vector of length NB. If the
routine terminates normally (NCALC=NB), the vector BK
contains the functions K(ALPHA,X), ... , K(NB-1+ALPHA,X),
or the corresponding exponentially scaled functions.
If (0 < NCALC < NB), BK(I) contains correct function
values for I <= NCALC, and contains the ratios
K(ALPHA+I-1,X)/K(ALPHA+I-2,X) for the rest of the array.
NCALC - Output variable indicating possible errors.
Before using the vector BK, the user should check that
NCALC=NB, i.e., all orders have been calculated to
the desired accuracy. See error returns below.
*******************************************************************
Error returns
In case of an error, NCALC != NB, and not all K's are
calculated to the desired accuracy.
NCALC < -1: An argument is out of range. For example,
NB <= 0, IZE is not 1 or 2, or IZE=1 and ABS(X) >= XMAX_BESS_K.
In this case, the B-vector is not calculated,
and NCALC is set to MIN0(NB,0)-2 so that NCALC != NB.
NCALC = -1: Either K(ALPHA,X) >= XINF or
K(ALPHA+NB-1,X)/K(ALPHA+NB-2,X) >= XINF. In this case,
the B-vector is not calculated. Note that again
NCALC != NB.
0 < NCALC < NB: Not all requested function values could
be calculated accurately. BK(I) contains correct function
values for I <= NCALC, and contains the ratios
K(ALPHA+I-1,X)/K(ALPHA+I-2,X) for the rest of the array.
Intrinsic functions required are:
ABS, AINT, EXP, INT, LOG, MAX, MIN, SINH, SQRT
Acknowledgement
This program is based on a program written by J. B. Campbell
(2) that computes values of the Bessel functions K of float
argument and float order. Modifications include the addition
of non-scaled functions, parameterization of machine
dependencies, and the use of more accurate approximations
for SINH and SIN.
References: "On Temme's Algorithm for the Modified Bessel
Functions of the Third Kind," Campbell, J. B.,
TOMS 6(4), Dec. 1980, pp. 581-586.
"A FORTRAN IV Subroutine for the Modified Bessel
Functions of the Third Kind of Real Order and Real
Argument," Campbell, J. B., Report NRC/ERB-925,
National Research Council, Canada.
Latest modification: May 30, 1989
Modified by: W. J. Cody and L. Stoltz
Applied Mathematics Division
Argonne National Laboratory
Argonne, IL 60439
-------------------------------------------------------------------
*/
/*---------------------------------------------------------------------
* Mathematical constants
* A = LOG(2) - Euler's constant
* D = SQRT(2/PI)
---------------------------------------------------------------------*/
const static double a = .11593151565841244881;
/*---------------------------------------------------------------------
P, Q - Approximation for LOG(GAMMA(1+ALPHA))/ALPHA + Euler's constant
Coefficients converted from hex to decimal and modified
by W. J. Cody, 2/26/82 */
const static double p[8] = { .805629875690432845,20.4045500205365151,
157.705605106676174,536.671116469207504,900.382759291288778,
730.923886650660393,229.299301509425145,.822467033424113231 };
const static double q[7] = { 29.4601986247850434,277.577868510221208,
1206.70325591027438,2762.91444159791519,3443.74050506564618,
2210.63190113378647,572.267338359892221 };
/* R, S - Approximation for (1-ALPHA*PI/SIN(ALPHA*PI))/(2.D0*ALPHA) */
const static double r[5] = { -.48672575865218401848,13.079485869097804016,
-101.96490580880537526,347.65409106507813131,
3.495898124521934782e-4 };
const static double s[4] = { -25.579105509976461286,212.57260432226544008,
-610.69018684944109624,422.69668805777760407 };
/* T - Approximation for SINH(Y)/Y */
const static double t[6] = { 1.6125990452916363814e-10,
2.5051878502858255354e-8,2.7557319615147964774e-6,
1.9841269840928373686e-4,.0083333333333334751799,
.16666666666666666446 };
/*---------------------------------------------------------------------*/
const static double estm[6] = { 52.0583,5.7607,2.7782,14.4303,185.3004, 9.3715 };
const static double estf[7] = { 41.8341,7.1075,6.4306,42.511,1.35633,84.5096,20.};
/* Local variables */
long iend, i, j, k, m, ii, mplus1;
double x2by4, twox, c, blpha, ratio, wminf;
double d1, d2, d3, f0, f1, f2, p0, q0, t1, t2, twonu;
double dm, ex, bk1, bk2, nu;
ii = 0; /* -Wall */
ex = *x;
nu = *alpha;
*ncalc = min0(*nb,0) - 2;
if (*nb > 0 && (0. <= nu && nu < 1.) && (1 <= *ize && *ize <= 2)) {
if(ex <= 0 || (*ize == 1 && ex > xmax_BESS_K)) {
if(ex <= 0) {
if(ex < 0) ML_ERROR(ME_RANGE, "K_bessel");
for(i=0; i < *nb; i++)
bk[i] = ML_POSINF;
} else /* would only have underflow */
for(i=0; i < *nb; i++)
bk[i] = 0.;
*ncalc = *nb;
return;
}
k = 0;
if (nu < sqxmin_BESS_K) {
nu = 0.;
} else if (nu > .5) {
k = 1;
nu -= 1.;
}
twonu = nu + nu;
iend = *nb + k - 1;
c = nu * nu;
d3 = -c;
if (ex <= 1.) {
/* ------------------------------------------------------------
Calculation of P0 = GAMMA(1+ALPHA) * (2/X)**ALPHA
Q0 = GAMMA(1-ALPHA) * (X/2)**ALPHA
------------------------------------------------------------ */
d1 = 0.; d2 = p[0];
t1 = 1.; t2 = q[0];
for (i = 2; i <= 7; i += 2) {
d1 = c * d1 + p[i - 1];
d2 = c * d2 + p[i];
t1 = c * t1 + q[i - 1];
t2 = c * t2 + q[i];
}
d1 = nu * d1;
t1 = nu * t1;
f1 = log(ex);
f0 = a + nu * (p[7] - nu * (d1 + d2) / (t1 + t2)) - f1;
q0 = exp(-nu * (a - nu * (p[7] + nu * (d1-d2) / (t1-t2)) - f1));
f1 = nu * f0;
p0 = exp(f1);
/* -----------------------------------------------------------
Calculation of F0 =
----------------------------------------------------------- */
d1 = r[4];
t1 = 1.;
for (i = 0; i < 4; ++i) {
d1 = c * d1 + r[i];
t1 = c * t1 + s[i];
}
/* d2 := sinh(f1)/ nu = sinh(f1)/(f1/f0)
* = f0 * sinh(f1)/f1 */
if (fabs(f1) <= .5) {
f1 *= f1;
d2 = 0.;
for (i = 0; i < 6; ++i) {
d2 = f1 * d2 + t[i];
}
d2 = f0 + f0 * f1 * d2;
} else {
d2 = sinh(f1) / nu;
}
f0 = d2 - nu * d1 / (t1 * p0);
if (ex <= 1e-10) {
/* ---------------------------------------------------------
X <= 1.0E-10
Calculation of K(ALPHA,X) and X*K(ALPHA+1,X)/K(ALPHA,X)
--------------------------------------------------------- */
bk[0] = f0 + ex * f0;
if (*ize == 1) {
bk[0] -= ex * bk[0];
}
ratio = p0 / f0;
c = ex * DBL_MAX;
if (k != 0) {
/* ---------------------------------------------------
Calculation of K(ALPHA,X)
and X*K(ALPHA+1,X)/K(ALPHA,X), ALPHA >= 1/2
--------------------------------------------------- */
*ncalc = -1;
if (bk[0] >= c / ratio) {
return;
}
bk[0] = ratio * bk[0] / ex;
twonu += 2.;
ratio = twonu;
}
*ncalc = 1;
if (*nb == 1)
return;
/* -----------------------------------------------------
Calculate K(ALPHA+L,X)/K(ALPHA+L-1,X),
L = 1, 2, ... , NB-1
----------------------------------------------------- */
*ncalc = -1;
for (i = 1; i < *nb; ++i) {
if (ratio >= c)
return;
bk[i] = ratio / ex;
twonu += 2.;
ratio = twonu;
}
*ncalc = 1;
goto L420;
} else {
/* ------------------------------------------------------
10^-10 < X <= 1.0
------------------------------------------------------ */
c = 1.;
x2by4 = ex * ex / 4.;
p0 = .5 * p0;
q0 = .5 * q0;
d1 = -1.;
d2 = 0.;
bk1 = 0.;
bk2 = 0.;
f1 = f0;
f2 = p0;
do {
d1 += 2.;
d2 += 1.;
d3 = d1 + d3;
c = x2by4 * c / d2;
f0 = (d2 * f0 + p0 + q0) / d3;
p0 /= d2 - nu;
q0 /= d2 + nu;
t1 = c * f0;
t2 = c * (p0 - d2 * f0);
bk1 += t1;
bk2 += t2;
} while (fabs(t1 / (f1 + bk1)) > DBL_EPSILON ||
fabs(t2 / (f2 + bk2)) > DBL_EPSILON);
bk1 = f1 + bk1;
bk2 = 2. * (f2 + bk2) / ex;
if (*ize == 2) {
d1 = exp(ex);
bk1 *= d1;
bk2 *= d1;
}
wminf = estf[0] * ex + estf[1];
}
} else if (DBL_EPSILON * ex > 1.) {
/* -------------------------------------------------
X > 1./EPS
------------------------------------------------- */
*ncalc = *nb;
bk1 = 1. / (M_SQRT_2dPI * sqrt(ex));
for (i = 0; i < *nb; ++i)
bk[i] = bk1;
return;
} else {
/* -------------------------------------------------------
X > 1.0
------------------------------------------------------- */
twox = ex + ex;
blpha = 0.;
ratio = 0.;
if (ex <= 4.) {
/* ----------------------------------------------------------
Calculation of K(ALPHA+1,X)/K(ALPHA,X), 1.0 <= X <= 4.0
----------------------------------------------------------*/
d2 = ftrunc(estm[0] / ex + estm[1]);
m = (long) d2;
d1 = d2 + d2;
d2 -= .5;
d2 *= d2;
for (i = 2; i <= m; ++i) {
d1 -= 2.;
d2 -= d1;
ratio = (d3 + d2) / (twox + d1 - ratio);
}
/* -----------------------------------------------------------
Calculation of I(|ALPHA|,X) and I(|ALPHA|+1,X) by backward
recurrence and K(ALPHA,X) from the wronskian
-----------------------------------------------------------*/
d2 = ftrunc(estm[2] * ex + estm[3]);
m = (long) d2;
c = fabs(nu);
d3 = c + c;
d1 = d3 - 1.;
f1 = DBL_MIN;
f0 = (2. * (c + d2) / ex + .5 * ex / (c + d2 + 1.)) * DBL_MIN;
for (i = 3; i <= m; ++i) {
d2 -= 1.;
f2 = (d3 + d2 + d2) * f0;
blpha = (1. + d1 / d2) * (f2 + blpha);
f2 = f2 / ex + f1;
f1 = f0;
f0 = f2;
}
f1 = (d3 + 2.) * f0 / ex + f1;
d1 = 0.;
t1 = 1.;
for (i = 1; i <= 7; ++i) {
d1 = c * d1 + p[i - 1];
t1 = c * t1 + q[i - 1];
}
p0 = exp(c * (a + c * (p[7] - c * d1 / t1) - log(ex))) / ex;
f2 = (c + .5 - ratio) * f1 / ex;
bk1 = p0 + (d3 * f0 - f2 + f0 + blpha) / (f2 + f1 + f0) * p0;
if (*ize == 1) {
bk1 *= exp(-ex);
}
wminf = estf[2] * ex + estf[3];
} else {
/* ---------------------------------------------------------
Calculation of K(ALPHA,X) and K(ALPHA+1,X)/K(ALPHA,X), by
backward recurrence, for X > 4.0
----------------------------------------------------------*/
dm = ftrunc(estm[4] / ex + estm[5]);
m = (long) dm;
d2 = dm - .5;
d2 *= d2;
d1 = dm + dm;
for (i = 2; i <= m; ++i) {
dm -= 1.;
d1 -= 2.;
d2 -= d1;
ratio = (d3 + d2) / (twox + d1 - ratio);
blpha = (ratio + ratio * blpha) / dm;
}
bk1 = 1. / ((M_SQRT_2dPI + M_SQRT_2dPI * blpha) * sqrt(ex));
if (*ize == 1)
bk1 *= exp(-ex);
wminf = estf[4] * (ex - fabs(ex - estf[6])) + estf[5];
}
/* ---------------------------------------------------------
Calculation of K(ALPHA+1,X)
from K(ALPHA,X) and K(ALPHA+1,X)/K(ALPHA,X)
--------------------------------------------------------- */
bk2 = bk1 + bk1 * (nu + .5 - ratio) / ex;
}
/*--------------------------------------------------------------------
Calculation of 'NCALC', K(ALPHA+I,X), I = 0, 1, ... , NCALC-1,
& K(ALPHA+I,X)/K(ALPHA+I-1,X), I = NCALC, NCALC+1, ... , NB-1
-------------------------------------------------------------------*/
*ncalc = *nb;
bk[0] = bk1;
if (iend == 0)
return;
j = 1 - k;
if (j >= 0)
bk[j] = bk2;
if (iend == 1)
return;
m = min0((long) (wminf - nu),iend);
for (i = 2; i <= m; ++i) {
t1 = bk1;
bk1 = bk2;
twonu += 2.;
if (ex < 1.) {
if (bk1 >= DBL_MAX / twonu * ex)
break;
} else {
if (bk1 / ex >= DBL_MAX / twonu)
break;
}
bk2 = twonu / ex * bk1 + t1;
ii = i;
++j;
if (j >= 0) {
bk[j] = bk2;
}
}
m = ii;
if (m == iend) {
return;
}
ratio = bk2 / bk1;
mplus1 = m + 1;
*ncalc = -1;
for (i = mplus1; i <= iend; ++i) {
twonu += 2.;
ratio = twonu / ex + 1./ratio;
++j;
if (j >= 1) {
bk[j] = ratio;
} else {
if (bk2 >= DBL_MAX / ratio)
return;
bk2 *= ratio;
}
}
*ncalc = max0(1, mplus1 - k);
if (*ncalc == 1)
bk[0] = bk2;
if (*nb == 1)
return;
L420:
for (i = *ncalc; i < *nb; ++i) { /* i == *ncalc */
#ifndef IEEE_754
if (bk[i-1] >= DBL_MAX / bk[i])
return;
#endif
bk[i] *= bk[i-1];
(*ncalc)++;
}
}
}
static void Y_bessel(double *x, double *alpha, long *nb,
double *by, long *ncalc)
{
/* ----------------------------------------------------------------------
This routine calculates Bessel functions Y_(N+ALPHA) (X)
for non-negative argument X, and non-negative order N+ALPHA.
Explanation of variables in the calling sequence
X - Non-negative argument for which
Y's are to be calculated.
ALPHA - Fractional part of order for which
Y's are to be calculated. 0 <= ALPHA < 1.0.
NB - Number of functions to be calculated, NB > 0.
The first function calculated is of order ALPHA, and the
last is of order (NB - 1 + ALPHA).
BY - Output vector of length NB. If the
routine terminates normally (NCALC=NB), the vector BY
contains the functions Y(ALPHA,X), ... , Y(NB-1+ALPHA,X),
If (0 < NCALC < NB), BY(I) contains correct function
values for I <= NCALC, and contains the ratios
Y(ALPHA+I-1,X)/Y(ALPHA+I-2,X) for the rest of the array.
NCALC - Output variable indicating possible errors.
Before using the vector BY, the user should check that
NCALC=NB, i.e., all orders have been calculated to
the desired accuracy. See error returns below.
*******************************************************************
Error returns
In case of an error, NCALC != NB, and not all Y's are
calculated to the desired accuracy.
NCALC < -1: An argument is out of range. For example,
NB <= 0, IZE is not 1 or 2, or IZE=1 and ABS(X) >=
XMAX. In this case, BY[0] = 0.0, the remainder of the
BY-vector is not calculated, and NCALC is set to
MIN0(NB,0)-2 so that NCALC != NB.
NCALC = -1: Y(ALPHA,X) >= XINF. The requested function
values are set to 0.0.
1 < NCALC < NB: Not all requested function values could
be calculated accurately. BY(I) contains correct function
values for I <= NCALC, and and the remaining NB-NCALC
array elements contain 0.0.
Intrinsic functions required are:
DBLE, EXP, INT, MAX, MIN, REAL, SQRT
Acknowledgement
This program draws heavily on Temme's Algol program for Y(a,x)
and Y(a+1,x) and on Campbell's programs for Y_nu(x). Temme's
scheme is used for x < THRESH, and Campbell's scheme is used
in the asymptotic region. Segments of code from both sources
have been translated into Fortran 77, merged, and heavily modified.
Modifications include parameterization of machine dependencies,
use of a new approximation for ln(gamma(x)), and built-in
protection against over/underflow.
References: "Bessel functions J_nu(x) and Y_nu(x) of float
order and float argument," Campbell, J. B.,
Comp. Phy. Comm. 18, 1979, pp. 133-142.
"On the numerical evaluation of the ordinary
Bessel function of the second kind," Temme,
N. M., J. Comput. Phys. 21, 1976, pp. 343-350.
Latest modification: March 19, 1990
Modified by: W. J. Cody
Applied Mathematics Division
Argonne National Laboratory
Argonne, IL 60439
----------------------------------------------------------------------*/
/* ----------------------------------------------------------------------
Mathematical constants
FIVPI = 5*PI
PIM5 = 5*PI - 15
----------------------------------------------------------------------*/
const static double fivpi = 15.707963267948966192;
const static double pim5 = .70796326794896619231;
/*----------------------------------------------------------------------
Coefficients for Chebyshev polynomial expansion of
1/gamma(1-x), abs(x) <= .5
----------------------------------------------------------------------*/
const static double ch[21] = { -6.7735241822398840964e-24,
-6.1455180116049879894e-23,2.9017595056104745456e-21,
1.3639417919073099464e-19,2.3826220476859635824e-18,
-9.0642907957550702534e-18,-1.4943667065169001769e-15,
-3.3919078305362211264e-14,-1.7023776642512729175e-13,
9.1609750938768647911e-12,2.4230957900482704055e-10,
1.7451364971382984243e-9,-3.3126119768180852711e-8,
-8.6592079961391259661e-7,-4.9717367041957398581e-6,
7.6309597585908126618e-5,.0012719271366545622927,
.0017063050710955562222,-.07685284084478667369,
-.28387654227602353814,.92187029365045265648 };
/* Local variables */
long i, k, na;
double alfa, div, ddiv, even, gamma, term, cosmu, sinmu,
b, c, d, e, f, g, h, p, q, r, s, d1, d2, q0, pa,pa1, qa,qa1,
en, en1, nu, ex, ya,ya1, twobyx, den, odd, aye, dmu, x2, xna;
en1 = ya = ya1 = 0; /* -Wall */
ex = *x;
nu = *alpha;
if (*nb > 0 && 0. <= nu && nu < 1.) {
if(ex < DBL_MIN || ex > xlrg_BESS_Y) {
/* Warning is not really appropriate, give
* proper limit:
* ML_ERROR(ME_RANGE, "Y_bessel"); */
*ncalc = *nb;
if(ex > xlrg_BESS_Y) by[0]= 0.; /*was ML_POSINF */
else if(ex < DBL_MIN) by[0]=ML_NEGINF;
for(i=0; i < *nb; i++)
by[i] = by[0];
return;
}
xna = ftrunc(nu + .5);
na = (long) xna;
if (na == 1) {/* <==> .5 <= *alpha < 1 <==> -5. <= nu < 0 */
nu -= xna;
}
if (nu == -.5) {
p = M_SQRT_2dPI / sqrt(ex);
ya = p * sin(ex);
ya1 = -p * cos(ex);
} else if (ex < 3.) {
/* -------------------------------------------------------------
Use Temme's scheme for small X
------------------------------------------------------------- */
b = ex * .5;
d = -log(b);
f = nu * d;
e = pow(b, -nu);
if (fabs(nu) < M_eps_sinc)
c = M_1_PI;
else
c = nu / sin(nu * M_PI);
/* ------------------------------------------------------------
Computation of sinh(f)/f
------------------------------------------------------------ */
if (fabs(f) < 1.) {
x2 = f * f;
en = 19.;
s = 1.;
for (i = 1; i <= 9; ++i) {
s = s * x2 / en / (en - 1.) + 1.;
en -= 2.;
}
} else {
s = (e - 1. / e) * .5 / f;
}
/* --------------------------------------------------------
Computation of 1/gamma(1-a) using Chebyshev polynomials */
x2 = nu * nu * 8.;
aye = ch[0];
even = 0.;
alfa = ch[1];
odd = 0.;
for (i = 3; i <= 19; i += 2) {
even = -(aye + aye + even);
aye = -even * x2 - aye + ch[i - 1];
odd = -(alfa + alfa + odd);
alfa = -odd * x2 - alfa + ch[i];
}
even = (even * .5 + aye) * x2 - aye + ch[20];
odd = (odd + alfa) * 2.;
gamma = odd * nu + even;
/* End of computation of 1/gamma(1-a)
----------------------------------------------------------- */
g = e * gamma;
e = (e + 1. / e) * .5;
f = 2. * c * (odd * e + even * s * d);
e = nu * nu;
p = g * c;
q = M_1_PI / g;
c = nu * M_PI_2;
if (fabs(c) < M_eps_sinc)
r = 1.;
else
r = sin(c) / c;
r = M_PI * c * r * r;
c = 1.;
d = -b * b;
h = 0.;
ya = f + r * q;
ya1 = p;
en = 1.;
while (fabs(g / (1. + fabs(ya))) +
fabs(h / (1. + fabs(ya1))) > DBL_EPSILON) {
f = (f * en + p + q) / (en * en - e);
c *= (d / en);
p /= en - nu;
q /= en + nu;
g = c * (f + r * q);
h = c * p - en * g;
ya += g;
ya1+= h;
en += 1.;
}
ya = -ya;
ya1 = -ya1 / b;
} else if (ex < thresh_BESS_Y) {
/* --------------------------------------------------------------
Use Temme's scheme for moderate X : 3 <= x < 16
-------------------------------------------------------------- */
c = (.5 - nu) * (.5 + nu);
b = ex + ex;
e = ex * M_1_PI * cos(nu * M_PI) / DBL_EPSILON;
e *= e;
p = 1.;
q = -ex;
r = 1. + ex * ex;
s = r;
en = 2.;
while (r * en * en < e) {
en1 = en + 1.;
d = (en - 1. + c / en) / s;
p = (en + en - p * d) / en1;
q = (-b + q * d) / en1;
s = p * p + q * q;
r *= s;
en = en1;
}
f = p / s;
p = f;
g = -q / s;
q = g;
L220:
en -= 1.;
if (en > 0.) {
r = en1 * (2. - p) - 2.;
s = b + en1 * q;
d = (en - 1. + c / en) / (r * r + s * s);
p = d * r;
q = d * s;
e = f + 1.;
f = p * e - g * q;
g = q * e + p * g;
en1 = en;
goto L220;
}
f = 1. + f;
d = f * f + g * g;
pa = f / d;
qa = -g / d;
d = nu + .5 - p;
q += ex;
pa1 = (pa * q - qa * d) / ex;
qa1 = (qa * q + pa * d) / ex;
b = ex - M_PI_2 * (nu + .5);
c = cos(b);
s = sin(b);
d = M_SQRT_2dPI / sqrt(ex);
ya = d * (pa * s + qa * c);
ya1 = d * (qa1 * s - pa1 * c);
} else { /* x > thresh_BESS_Y */
/* ----------------------------------------------------------
Use Campbell's asymptotic scheme.
---------------------------------------------------------- */
na = 0;
d1 = ftrunc(ex / fivpi);
i = (long) d1;
dmu = ex - 15. * d1 - d1 * pim5 - (*alpha + .5) * M_PI_2;
if (i - (i / 2 << 1) == 0) {
cosmu = cos(dmu);
sinmu = sin(dmu);
} else {
cosmu = -cos(dmu);
sinmu = -sin(dmu);
}
ddiv = 8. * ex;
dmu = *alpha;
den = sqrt(ex);
for (k = 1; k <= 2; ++k) {
p = cosmu;
cosmu = sinmu;
sinmu = -p;
d1 = (2. * dmu - 1.) * (2. * dmu + 1.);
d2 = 0.;
div = ddiv;
p = 0.;
q = 0.;
q0 = d1 / div;
term = q0;
for (i = 2; i <= 20; ++i) {
d2 += 8.;
d1 -= d2;
div += ddiv;
term = -term * d1 / div;
p += term;
d2 += 8.;
d1 -= d2;
div += ddiv;
term *= (d1 / div);
q += term;
if (fabs(term) <= DBL_EPSILON) {
break;
}
}
p += 1.;
q += q0;
if (k == 1)
ya = M_SQRT_2dPI * (p * cosmu - q * sinmu) / den;
else
ya1 = M_SQRT_2dPI * (p * cosmu - q * sinmu) / den;
dmu += 1.;
}
}
if (na == 1) {
h = 2. * (nu + 1.) / ex;
if (h > 1.) {
if (fabs(ya1) > DBL_MAX / h) {
h = 0.;
ya = 0.;
}
}
h = h * ya1 - ya;
ya = ya1;
ya1 = h;
}
/* ---------------------------------------------------------------
Now have first one or two Y's
--------------------------------------------------------------- */
by[0] = ya;
*ncalc = 1;
if(*nb > 1) {
by[1] = ya1;
if (ya1 != 0.) {
aye = 1. + *alpha;
twobyx = 2. / ex;
*ncalc = 2;
for (i = 2; i < *nb; ++i) {
if (twobyx < 1.) {
if (fabs(by[i - 1]) * twobyx >= DBL_MAX / aye)
goto L450;
} else {
if (fabs(by[i - 1]) >= DBL_MAX / aye / twobyx)
goto L450;
}
by[i] = twobyx * aye * by[i - 1] - by[i - 2];
aye += 1.;
++(*ncalc);
}
}
}
L450:
for (i = *ncalc; i < *nb; ++i)
by[i] = ML_NEGINF;/* was 0 */
} else {
by[0] = 0.;
*ncalc = imin2(*nb,0) - 1;
}
}
static void J_bessel(double *x, double *alpha, long *nb,
double *b, long *ncalc)
{
/*
Calculates Bessel functions J_{n+alpha} (x)
for non-negative argument x, and non-negative order n+alpha, n = 0,1,..,nb-1.
Explanation of variables in the calling sequence.
X - Non-negative argument for which J's are to be calculated.
ALPHA - Fractional part of order for which
J's are to be calculated. 0 <= ALPHA < 1.
NB - Number of functions to be calculated, NB >= 1.
The first function calculated is of order ALPHA, and the
last is of order (NB - 1 + ALPHA).
B - Output vector of length NB. If RJBESL
terminates normally (NCALC=NB), the vector B contains the
functions J/ALPHA/(X) through J/NB-1+ALPHA/(X).
NCALC - Output variable indicating possible errors.
Before using the vector B, the user should check that
NCALC=NB, i.e., all orders have been calculated to
the desired accuracy. See the following
****************************************************************
Error return codes
In case of an error, NCALC != NB, and not all J's are
calculated to the desired accuracy.
NCALC < 0: An argument is out of range. For example,
NBES <= 0, ALPHA < 0 or > 1, or X is too large.
In this case, b[1] is set to zero, the remainder of the
B-vector is not calculated, and NCALC is set to
MIN(NB,0)-1 so that NCALC != NB.
NB > NCALC > 0: Not all requested function values could
be calculated accurately. This usually occurs because NB is
much larger than ABS(X). In this case, b[N] is calculated
to the desired accuracy for N <= NCALC, but precision
is lost for NCALC < N <= NB. If b[N] does not vanish
for N > NCALC (because it is too small to be represented),
and b[N]/b[NCALC] = 10^(-K), then only the first NSIG - K
significant figures of b[N] can be trusted.
Acknowledgement
This program is based on a program written by David J. Sookne
(2) that computes values of the Bessel functions J or I of float
argument and long order. Modifications include the restriction
of the computation to the J Bessel function of non-negative float
argument, the extension of the computation to arbitrary positive
order, and the elimination of most underflow.
References:
Olver, F.W.J., and Sookne, D.J. (1972)
"A Note on Backward Recurrence Algorithms";
Math. Comp. 26, 941-947.
Sookne, D.J. (1973)
"Bessel Functions of Real Argument and Integer Order";
NBS Jour. of Res. B. 77B, 125-132.
Latest modification: March 19, 1990
Author: W. J. Cody
Applied Mathematics Division
Argonne National Laboratory
Argonne, IL 60439
*******************************************************************
*/
/* ---------------------------------------------------------------------
Mathematical constants
PI2 = 2 / PI
TWOPI1 = first few significant digits of 2 * PI
TWOPI2 = (2*PI - TWOPI1) to working precision, i.e.,
TWOPI1 + TWOPI2 = 2 * PI to extra precision.
--------------------------------------------------------------------- */
const static double pi2 = .636619772367581343075535;
const static double twopi1 = 6.28125;
const static double twopi2 = .001935307179586476925286767;
/*---------------------------------------------------------------------
* Factorial(N)
*--------------------------------------------------------------------- */
const static double fact[25] = { 1.,1.,2.,6.,24.,120.,720.,5040.,40320.,
362880.,3628800.,39916800.,479001600.,6227020800.,87178291200.,
1.307674368e12,2.0922789888e13,3.55687428096e14,6.402373705728e15,
1.21645100408832e17,2.43290200817664e18,5.109094217170944e19,
1.12400072777760768e21,2.585201673888497664e22,
6.2044840173323943936e23 };
/* Local variables */
long nend, intx, nbmx, i, j, k, l, m, n, nstart;
double nu, twonu, capp, capq, pold, vcos, test, vsin;
double p, s, t, z, alpem, halfx, aa, bb, cc, psave, plast;
double tover, t1, alp2em, em, en, xc, xk, xm, psavel, gnu, xin, sum;
/* Parameter adjustment */
--b;
nu = *alpha;
twonu = nu + nu;
/*-------------------------------------------------------------------
Check for out of range arguments.
-------------------------------------------------------------------*/
if (*nb > 0 && *x >= 0. && 0. <= nu && nu < 1.) {
*ncalc = *nb;
if(*x > xlrg_BESS_IJ) {
ML_ERROR(ME_RANGE, "J_bessel");
/* indeed, the limit is 0,
* but the cutoff happens too early */
for(i=1; i <= *nb; i++)
b[i] = 0.; /*was ML_POSINF (really nonsense) */
return;
}
intx = (long) (*x);
/* Initialize result array to zero. */
for (i = 1; i <= *nb; ++i)
b[i] = 0.;
/*===================================================================
Branch into 3 cases :
1) use 2-term ascending series for small X
2) use asymptotic form for large X when NB is not too large
3) use recursion otherwise
===================================================================*/
if (*x < rtnsig_BESS) {
/* ---------------------------------------------------------------
Two-term ascending series for small X.
--------------------------------------------------------------- */
alpem = 1. + nu;
halfx = (*x > enmten_BESS) ? .5 * *x : 0.;
aa = (nu != 0.) ? pow(halfx, nu) / (nu * gamma_cody(nu)) : 1.;
bb = (*x + 1. > 1.)? -halfx * halfx : 0.;
b[1] = aa + aa * bb / alpem;
if (*x != 0. && b[1] == 0.)
*ncalc = 0;
if (*nb != 1) {
if (*x <= 0.) {
for (n = 2; n <= *nb; ++n)
b[n] = 0.;
}
else {
/* ----------------------------------------------
Calculate higher order functions.
---------------------------------------------- */
if (bb == 0.)
tover = (enmten_BESS + enmten_BESS) / *x;
else
tover = enmten_BESS / bb;
cc = halfx;
for (n = 2; n <= *nb; ++n) {
aa /= alpem;
alpem += 1.;
aa *= cc;
if (aa <= tover * alpem)
aa = 0.;
b[n] = aa + aa * bb / alpem;
if (b[n] == 0. && *ncalc > n)
*ncalc = n - 1;
}
}
}
} else if (*x > 25. && *nb <= intx + 1) {
/* ------------------------------------------------------------
Asymptotic series for X > 25 (and not too large nb)
------------------------------------------------------------ */
xc = sqrt(pi2 / *x);
xin = 1 / (64 * *x * *x);
if (*x >= 130.) m = 4;
else if (*x >= 35.) m = 8;
else m = 11;
xm = 4. * (double) m;
/* ------------------------------------------------
Argument reduction for SIN and COS routines.
------------------------------------------------ */
t = ftrunc(*x / (twopi1 + twopi2) + .5);
z = (*x - t * twopi1) - t * twopi2 - (nu + .5) / pi2;
vsin = sin(z);
vcos = cos(z);
gnu = twonu;
for (i = 1; i <= 2; ++i) {
s = (xm - 1. - gnu) * (xm - 1. + gnu) * xin * .5;
t = (gnu - (xm - 3.)) * (gnu + (xm - 3.));
t1= (gnu - (xm + 1.)) * (gnu + (xm + 1.));
k = m + m;
capp = s * t / fact[k];
capq = s * t1/ fact[k + 1];
xk = xm;
for (; k >= 4; k -= 2) {/* k + 2(j-2) == 2m */
xk -= 4.;
s = (xk - 1. - gnu) * (xk - 1. + gnu);
t1 = t;
t = (gnu - (xk - 3.)) * (gnu + (xk - 3.));
capp = (capp + 1. / fact[k - 2]) * s * t * xin;
capq = (capq + 1. / fact[k - 1]) * s * t1 * xin;
}
capp += 1.;
capq = (capq + 1.) * (gnu * gnu - 1.) * (.125 / *x);
b[i] = xc * (capp * vcos - capq * vsin);
if (*nb == 1)
return;
/* vsin <--> vcos */ t = vsin; vsin = -vcos; vcos = t;
gnu += 2.;
}
/* -----------------------------------------------
If NB > 2, compute J(X,ORDER+I) for I = 2, NB-1
----------------------------------------------- */
if (*nb > 2)
for (gnu = twonu + 2., j = 3; j <= *nb; j++, gnu += 2.)
b[j] = gnu * b[j - 1] / *x - b[j - 2];
}
else {
/* rtnsig_BESS <= x && ( x <= 25 || intx+1 < *nb ) :
--------------------------------------------------------
Use recurrence to generate results.
First initialize the calculation of P*S.
-------------------------------------------------------- */
nbmx = *nb - intx;
n = intx + 1;
en = (double)(n + n) + twonu;
plast = 1.;
p = en / *x;
/* ---------------------------------------------------
Calculate general significance test.
--------------------------------------------------- */
test = ensig_BESS + ensig_BESS;
if (nbmx >= 3) {
/* ------------------------------------------------------------
Calculate P*S until N = NB-1. Check for possible overflow.
---------------------------------------------------------- */
tover = enten_BESS / ensig_BESS;
nstart = intx + 2;
nend = *nb - 1;
en = (double) (nstart + nstart) - 2. + twonu;
for (k = nstart; k <= nend; ++k) {
n = k;
en += 2.;
pold = plast;
plast = p;
p = en * plast / *x - pold;
if (p > tover) {
/* -------------------------------------------
To avoid overflow, divide P*S by TOVER.
Calculate P*S until ABS(P) > 1.
-------------------------------------------*/
tover = enten_BESS;
p /= tover;
plast /= tover;
psave = p;
psavel = plast;
nstart = n + 1;
do {
++n;
en += 2.;
pold = plast;
plast = p;
p = en * plast / *x - pold;
} while (p <= 1.);
bb = en / *x;
/* -----------------------------------------------
Calculate backward test and find NCALC,
the highest N such that the test is passed.
----------------------------------------------- */
test = pold * plast * (.5 - .5 / (bb * bb));
test /= ensig_BESS;
p = plast * tover;
--n;
en -= 2.;
nend = imin2(*nb,n);
for (l = nstart; l <= nend; ++l) {
pold = psavel;
psavel = psave;
psave = en * psavel / *x - pold;
if (psave * psavel > test) {
*ncalc = l - 1;
goto L190;
}
}
*ncalc = nend;
goto L190;
}
}
n = nend;
en = (double) (n + n) + twonu;
/* -----------------------------------------------------
Calculate special significance test for NBMX > 2.
-----------------------------------------------------*/
test = fmax2(test, sqrt(plast * ensig_BESS) * sqrt(p + p));
}
/* ------------------------------------------------
Calculate P*S until significance test passes. */
do {
++n;
en += 2.;
pold = plast;
plast = p;
p = en * plast / *x - pold;
} while (p < test);
L190:
/*---------------------------------------------------------------
Initialize the backward recursion and the normalization sum.
--------------------------------------------------------------- */
++n;
en += 2.;
bb = 0.;
aa = 1. / p;
m = n / 2;
em = (double)m;
m = (n << 1) - (m << 2);/* = 2 n - 4 (n/2)
= 0 for even, 2 for odd n */
if (m == 0)
sum = 0.;
else {
alpem = em - 1. + nu;
alp2em = em + em + nu;
sum = aa * alpem * alp2em / em;
}
nend = n - *nb;
/* if (nend > 0) */
/* --------------------------------------------------------
Recur backward via difference equation, calculating
(but not storing) b[N], until N = NB.
-------------------------------------------------------- */
for (l = 1; l <= nend; ++l) {
--n;
en -= 2.;
cc = bb;
bb = aa;
aa = en * bb / *x - cc;
m = m ? 0 : 2; /* m = 2 - m failed on gcc4-20041019 */
if (m != 0) {
em -= 1.;
alp2em = em + em + nu;
if (n == 1)
break;
alpem = em - 1. + nu;
if (alpem == 0.)
alpem = 1.;
sum = (sum + aa * alp2em) * alpem / em;
}
}
/*--------------------------------------------------
Store b[NB].
--------------------------------------------------*/
b[n] = aa;
if (nend >= 0) {
if (*nb <= 1) {
if (nu + 1. == 1.)
alp2em = 1.;
else
alp2em = nu;
sum += b[1] * alp2em;
goto L250;
}
else {/*-- nb >= 2 : ---------------------------
Calculate and store b[NB-1].
----------------------------------------*/
--n;
en -= 2.;
b[n] = en * aa / *x - bb;
if (n == 1)
goto L240;
m = m ? 0 : 2; /* m = 2 - m failed on gcc4-20041019 */
if (m != 0) {
em -= 1.;
alp2em = em + em + nu;
alpem = em - 1. + nu;
if (alpem == 0.)
alpem = 1.;
sum = (sum + b[n] * alp2em) * alpem / em;
}
}
}
/* if (n - 2 != 0) */
/* --------------------------------------------------------
Calculate via difference equation and store b[N],
until N = 2.
-------------------------------------------------------- */
for (n = n-1; n >= 2; n--) {
en -= 2.;
b[n] = en * b[n + 1] / *x - b[n + 2];
m = m ? 0 : 2; /* m = 2 - m failed on gcc4-20041019 */
if (m != 0) {
em -= 1.;
alp2em = em + em + nu;
alpem = em - 1. + nu;
if (alpem == 0.)
alpem = 1.;
sum = (sum + b[n] * alp2em) * alpem / em;
}
}
/* ---------------------------------------
Calculate b[1].
-----------------------------------------*/
b[1] = 2. * (nu + 1.) * b[2] / *x - b[3];
L240:
em -= 1.;
alp2em = em + em + nu;
if (alp2em == 0.)
alp2em = 1.;
sum += b[1] * alp2em;
L250:
/* ---------------------------------------------------
Normalize. Divide all b[N] by sum.
---------------------------------------------------*/
/* if (nu + 1. != 1.) poor test */
if(fabs(nu) > 1e-15)
sum *= (gamma_cody(nu) * pow(.5* *x, -nu));
aa = enmten_BESS;
if (sum > 1.)
aa *= sum;
for (n = 1; n <= *nb; ++n) {
if (fabs(b[n]) < aa)
b[n] = 0.;
else
b[n] /= sum;
}
}
}
else {
/* Error return -- X, NB, or ALPHA is out of range : */
b[1] = 0.;
*ncalc = imin2(*nb,0) - 1;
}
}
static void equals(int no)
{ /* perform binary operation */
BOOL pop;
newx=FALSE;
pop=TRUE;
while (pop)
{
if (prec(no)>prop[sp])
{ /* if higher precedence, keep this one pending */
if (sp==top)
{
mip->ERNUM=(-1);
result=FALSE;
newx=TRUE;
}
else sp++;
return;
}
newx=TRUE;
if (flag && op[sp]!=3 && op[sp]!=0) swap();
switch (op[sp])
{
case 7: fdiv(x,y[sp],t);
ftrunc(t,t,t);
fmul(t,y[sp],t);
fsub(x,t,x);
break;
case 6: fpowf(x,y[sp],x);
break;
case 5: frecip(y[sp],t);
fpowf(x,t,x);
break;
case 4: fdiv(x,y[sp],x);
break;
case 3: fmul(x,y[sp],x);
break;
case 2: fsub(x,y[sp],x);
break;
case 1: fadd(x,y[sp],x);
break;
case 0: break;
}
if (sp>0 && (prec(no)<=prop[sp-1])) sp--;
else pop=FALSE;
}
}