double rk_beta(rk_state *state, double a, double b)
{
double Ga, Gb;
if ((a <= 1.0) && (b <= 1.0))
{
double U, V, X, Y;
/* Use Jonk's algorithm */
while (1)
{
U = rk_double(state);
V = rk_double(state);
X = pow(U, 1.0/a);
Y = pow(V, 1.0/b);
if ((X + Y) <= 1.0)
{
return X / (X + Y);
}
}
}
else
{
Ga = rk_standard_gamma(state, a);
Gb = rk_standard_gamma(state, b);
return Ga/(Ga + Gb);
}
}
long rk_logseries(rk_state *state, double p)
{
double q, r, U, V;
long result;
r = log(1.0 - p);
while (1) {
V = rk_double(state);
if (V >= p) {
return 1;
}
U = rk_double(state);
q = 1.0 - exp(r*U);
if (V <= q*q) {
result = (long)floor(1 + log(V)/log(q));
if (result < 1) {
continue;
}
else {
return result;
}
}
if (V >= q) {
return 1;
}
return 2;
}
}
double rk_standard_gamma(rk_state *state, double shape)
{
double b, c;
double U, V, X, Y;
if (shape == 1.0)
{
return rk_standard_exponential(state);
}
else if (shape < 1.0)
{
for (;;)
{
U = rk_double(state);
V = rk_standard_exponential(state);
if (U <= 1.0 - shape)
{
X = pow(U, 1./shape);
if (X <= V)
{
return X;
}
}
else
{
Y = -log((1-U)/shape);
X = pow(1.0 - shape + shape*Y, 1./shape);
if (X <= (V + Y))
{
return X;
}
}
}
}
else
{
b = shape - 1./3.;
c = 1./sqrt(9*b);
for (;;)
{
do
{
X = rk_gauss(state);
V = 1.0 + c*X;
} while (V <= 0.0);
V = V*V*V;
U = rk_double(state);
if (U < 1.0 - 0.0331*(X*X)*(X*X)) return (b*V);
if (log(U) < 0.5*X*X + b*(1. - V + log(V))) return (b*V);
}
}
}
long rk_hypergeometric_hrua(rk_state *state, long good, long bad, long sample)
{
long mingoodbad, maxgoodbad, popsize, m, d9;
double d4, d5, d6, d7, d8, d10, d11;
long Z;
double T, W, X, Y;
mingoodbad = min(good, bad);
popsize = good + bad;
maxgoodbad = max(good, bad);
m = min(sample, popsize - sample);
d4 = ((double)mingoodbad) / popsize;
d5 = 1.0 - d4;
d6 = m*d4 + 0.5;
d7 = sqrt((popsize - m) * sample * d4 *d5 / (popsize-1) + 0.5);
d8 = D1*d7 + D2;
d9 = (long)floor((double)((m+1)*(mingoodbad+1))/(popsize+2));
d10 = (loggam(d9+1) + loggam(mingoodbad-d9+1) + loggam(m-d9+1) +
loggam(maxgoodbad-m+d9+1));
d11 = min(min(m, mingoodbad)+1.0, floor(d6+16*d7));
/* 16 for 16-decimal-digit precision in D1 and D2 */
while (1)
{
X = rk_double(state);
Y = rk_double(state);
W = d6 + d8*(Y- 0.5)/X;
/* fast rejection: */
if ((W < 0.0) || (W >= d11)) continue;
Z = (long)floor(W);
T = d10 - (loggam(Z+1) + loggam(mingoodbad-Z+1) + loggam(m-Z+1) +
loggam(maxgoodbad-m+Z+1));
/* fast acceptance: */
if ((X*(4.0-X)-3.0) <= T) break;
/* fast rejection: */
if (X*(X-T) >= 1) continue;
if (2.0*log(X) <= T) break; /* acceptance */
}
/* this is a correction to HRUA* by Ivan Frohne in rv.py */
if (good > bad) Z = m - Z;
/* another fix from rv.py to allow sample to exceed popsize/2 */
if (m < sample) Z = good - Z;
return Z;
}
/* Uses the rejection algorithm compared against the wrapped Cauchy
distribution suggested by Best and Fisher and documented in
Chapter 9 of Luc's Non-Uniform Random Variate Generation.
http://cg.scs.carleton.ca/~luc/rnbookindex.html
(but corrected to match the algorithm in R and Python)
*/
double rk_vonmises(rk_state *state, double mu, double kappa)
{
double r, rho, s;
double U, V, W, Y, Z;
double result, mod;
int neg;
if (kappa < 1e-8)
{
return M_PI * (2*rk_double(state)-1);
}
else
{
r = 1 + sqrt(1 + 4*kappa*kappa);
rho = (r - sqrt(2*r))/(2*kappa);
s = (1 + rho*rho)/(2*rho);
while (1)
{
U = rk_double(state);
Z = cos(M_PI*U);
W = (1 + s*Z)/(s + Z);
Y = kappa * (s - W);
V = rk_double(state);
if ((Y*(2-Y) - V >= 0) || (log(Y/V)+1 - Y >= 0))
{
break;
}
}
U = rk_double(state);
result = acos(W);
if (U < 0.5)
{
result = -result;
}
result += mu;
neg = (result < 0);
mod = fabs(result);
mod = (fmod(mod+M_PI, 2*M_PI)-M_PI);
if (neg)
{
mod *= -1;
}
return mod;
}
}
void
move_packet_across_shell_boundary (rpacket_t * packet,
storage_model_t * storage, double distance, rk_state *mt_state)
{
move_packet (packet, storage, distance);
if (rpacket_get_virtual_packet (packet) > 0)
{
double delta_tau_event = rpacket_get_chi_continuum(packet) * distance;
rpacket_set_tau_event (packet,
rpacket_get_tau_event (packet) +
delta_tau_event);
}
else
{
rpacket_reset_tau_event (packet, mt_state);
}
if ((rpacket_get_current_shell_id (packet) < storage->no_of_shells - 1
&& rpacket_get_next_shell_id (packet) == 1)
|| (rpacket_get_current_shell_id (packet) > 0
&& rpacket_get_next_shell_id (packet) == -1))
{
rpacket_set_current_shell_id (packet,
rpacket_get_current_shell_id (packet) +
rpacket_get_next_shell_id (packet));
}
else if (rpacket_get_next_shell_id (packet) == 1)
{
rpacket_set_status (packet, TARDIS_PACKET_STATUS_EMITTED);
}
else if ((storage->reflective_inner_boundary == 0) ||
(rk_double (mt_state) > storage->inner_boundary_albedo))
{
rpacket_set_status (packet, TARDIS_PACKET_STATUS_REABSORBED);
}
else
{
double doppler_factor = rpacket_doppler_factor (packet, storage);
double comov_nu = rpacket_get_nu (packet) * doppler_factor;
double comov_energy = rpacket_get_energy (packet) * doppler_factor;
rpacket_set_mu (packet, rk_double (mt_state));
double inverse_doppler_factor = 1.0 / rpacket_doppler_factor (packet, storage);
rpacket_set_nu (packet, comov_nu * inverse_doppler_factor);
rpacket_set_energy (packet, comov_energy * inverse_doppler_factor);
if (rpacket_get_virtual_packet_flag (packet) > 0)
{
montecarlo_one_packet (storage, packet, -2, mt_state);
}
}
}
/* Random interpolation. */
static inline void _rand_interpolation(unsigned int i,
double* H, unsigned int clampJ,
const signed short* J,
const double* W,
int nn,
void* params)
{
rk_state* rng = (rk_state*)params;
int k;
unsigned int clampJ_i = clampJ*i;
const double *bufW;
double sumW, draw;
for(k=0, bufW=W, sumW=0.0; k<nn; k++, bufW++)
sumW += *bufW;
draw = sumW*rk_double(rng);
for(k=0, bufW=W, sumW=0.0; k<nn; k++, bufW++) {
sumW += *bufW;
if (sumW > draw)
break;
}
H[J[k]+clampJ_i] += 1;
return;
}
double rk_logistic(rk_state *state, double loc, double scale)
{
double U;
U = rk_double(state);
return loc + scale * log(U/(1.0 - U));
}
double rk_gumbel(rk_state *state, double loc, double scale)
{
double U;
U = 1.0 - rk_double(state);
return loc - scale * log(-log(U));
}
montecarlo_event_handler_t
montecarlo_continuum_event_handler(rpacket_t * packet, storage_model_t * storage, rk_state *mt_state)
{
if (storage->cont_status == CONTINUUM_OFF)
{
return &montecarlo_thomson_scatter;
}
else
{
double zrand = (rk_double(mt_state));
double normaliz_cont_th = rpacket_get_chi_electron(packet)/rpacket_get_chi_continuum(packet);
double normaliz_cont_bf = rpacket_get_chi_boundfree(packet)/rpacket_get_chi_continuum(packet);
if (zrand < normaliz_cont_th)
{
//Return the electron scatter event function
return &montecarlo_thomson_scatter;
}
else if (zrand < (normaliz_cont_th + normaliz_cont_bf))
{
//Return the bound-free scatter event function
return &montecarlo_bound_free_scatter;
}
else
{
//Return the free-free scatter event function
return &montecarlo_free_free_scatter;
}
}
}
int64_t montecarlo_one_packet(storage_model_t *storage, rpacket_t *packet, int64_t virtual_mode)
{
int64_t i;
rpacket_t virt_packet;
double mu_bin;
double mu_min;
double doppler_factor_ratio;
double weight;
int64_t virt_id_nu;
if (virtual_mode == 0)
{
montecarlo_one_packet_loop(storage, packet, 0);
}
else
{
for (i = 0; i < rpacket_get_virtual_packet_flag(packet); i++)
{
memcpy((void *)&virt_packet, (void *)packet, sizeof(rpacket_t));
if (virt_packet.r > storage->r_inner[0])
{
mu_min = -1.0 * sqrt(1.0 - (storage->r_inner[0] / virt_packet.r) *
(storage->r_inner[0] / virt_packet.r));
}
else
{
mu_min = 0.0;
}
mu_bin = (1.0 - mu_min) / rpacket_get_virtual_packet_flag(packet);
virt_packet.mu = mu_min + (i + rk_double(&mt_state)) * mu_bin;
switch(virtual_mode)
{
case -2:
weight = 1.0 / rpacket_get_virtual_packet_flag(packet);
break;
case -1:
weight = 2.0 * virt_packet.mu / rpacket_get_virtual_packet_flag(packet);
break;
case 1:
weight = (1.0 - mu_min) / 2.0 / rpacket_get_virtual_packet_flag(packet);
break;
default:
fprintf(stderr, "Something has gone horribly wrong!\n");
}
doppler_factor_ratio =
rpacket_doppler_factor(packet, storage) /
rpacket_doppler_factor(&virt_packet, storage);
virt_packet.energy = rpacket_get_energy(packet) * doppler_factor_ratio;
virt_packet.nu = rpacket_get_nu(packet) * doppler_factor_ratio;
montecarlo_one_packet_loop(storage, &virt_packet, 1);
if ((virt_packet.nu < storage->spectrum_end_nu) &&
(virt_packet.nu > storage->spectrum_start_nu))
{
virt_id_nu = floor((virt_packet.nu - storage->spectrum_start_nu) /
storage->spectrum_delta_nu);
storage->spectrum_virt_nu[virt_id_nu] += virt_packet.energy * weight;
}
}
}
}
void move_packet_across_shell_boundary(rpacket_t *packet, storage_model_t *storage, double distance)
{
double comov_energy, doppler_factor, comov_nu, inverse_doppler_factor;
move_packet(packet, storage, distance);
if (rpacket_get_virtual_packet(packet) > 0)
{
double delta_tau_event = distance *
storage->electron_densities[rpacket_get_current_shell_id(packet)] *
storage->sigma_thomson;
rpacket_set_tau_event(packet, rpacket_get_tau_event(packet) + delta_tau_event);
}
else
{
rpacket_reset_tau_event(packet);
}
if ((rpacket_get_current_shell_id(packet) < storage->no_of_shells - 1 && rpacket_get_next_shell_id(packet) == 1) ||
(rpacket_get_current_shell_id(packet) > 0 && rpacket_get_next_shell_id(packet) == -1))
{
rpacket_set_current_shell_id(packet, rpacket_get_current_shell_id(packet) + rpacket_get_next_shell_id(packet));
rpacket_set_recently_crossed_boundary(packet, rpacket_get_next_shell_id(packet));
}
else if (rpacket_get_next_shell_id(packet) == 1)
{
rpacket_set_status(packet, TARDIS_PACKET_STATUS_EMITTED);
}
else if ((storage->reflective_inner_boundary == 0) ||
(rk_double(&mt_state) > storage->inner_boundary_albedo))
{
rpacket_set_status(packet, TARDIS_PACKET_STATUS_REABSORBED);
}
else
{
doppler_factor = rpacket_doppler_factor(packet, storage);
comov_nu = rpacket_get_nu(packet) * doppler_factor;
comov_energy = rpacket_get_energy(packet) * doppler_factor;
rpacket_set_mu(packet, rk_double(&mt_state));
inverse_doppler_factor = 1.0 / rpacket_doppler_factor(packet, storage);
rpacket_set_nu(packet, comov_nu * inverse_doppler_factor);
rpacket_set_energy(packet, comov_energy * inverse_doppler_factor);
rpacket_set_recently_crossed_boundary(packet, 1);
if (rpacket_get_virtual_packet_flag(packet) > 0)
{
montecarlo_one_packet(storage, packet, -2);
}
}
}
long rk_binomial_inversion(rk_state *state, long n, double p)
{
double q, qn, np, px, U;
long X, bound;
if (!(state->has_binomial) ||
(state->nsave != n) ||
(state->psave != p))
{
state->nsave = n;
state->psave = p;
state->has_binomial = 1;
state->q = q = 1.0 - p;
state->r = qn = exp(n * log(q));
state->c = np = n*p;
state->m = bound = min(n, np + 10.0*sqrt(np*q + 1));
} else
{
q = state->q;
qn = state->r;
np = state->c;
bound = state->m;
}
X = 0;
px = qn;
U = rk_double(state);
while (U > px)
{
X++;
if (X > bound)
{
X = 0;
px = qn;
U = rk_double(state);
} else
{
U -= px;
px = ((n-X+1) * p * px)/(X*q);
}
}
return X;
}
void
montecarlo_bound_free_scatter (rpacket_t * packet, storage_model_t * storage, double distance, rk_state *mt_state)
{
/* current position in list of continuum edges -> indicates which bound-free processes are possible */
int64_t current_continuum_id = rpacket_get_current_continuum_id(packet);
// Determine in which continuum the bf-absorption occurs
double nu = rpacket_get_nu(packet);
double chi_bf = rpacket_get_chi_boundfree(packet);
// get new zrand
double zrand = rk_double(mt_state);
double zrand_x_chibf = zrand * chi_bf;
int64_t ccontinuum = current_continuum_id; /* continuum_id of the continuum in which bf-absorption occurs */
while (storage->chi_bf_tmp_partial[ccontinuum] <= zrand_x_chibf)
{
ccontinuum++;
}
// Alternative way to choose a continuum for bf-absorption:
// error =
// binary_search(storage->chi_bf_tmp_partial, zrand_x_chibf, current_continuum_id,no_of_continuum_edges-1,&ccontinuum);
// if (error == TARDIS_ERROR_BOUNDS_ERROR) // x_insert < x[imin] -> set index equal to imin
// {
// ccontinuum = current_continuum_id;
// }
zrand = rk_double(mt_state);
if (zrand < storage->continuum_list_nu[ccontinuum] / nu)
{
// go to ionization energy
rpacket_set_status (packet, TARDIS_PACKET_STATUS_REABSORBED);
}
else
{
//go to the thermal pool
//create_kpacket(packet);
rpacket_set_status (packet, TARDIS_PACKET_STATUS_REABSORBED);
}
}
double rk_laplace(rk_state *state, double loc, double scale)
{
double U;
U = rk_double(state);
if (U < 0.5)
{
U = loc + scale * log(U + U);
} else
{
U = loc - scale * log(2.0 - U - U);
}
return U;
}
long rk_zipf(rk_state *state, double a)
{
double T, U, V;
long X;
double am1, b;
am1 = a - 1.0;
b = pow(2.0, am1);
do
{
U = 1.0-rk_double(state);
V = rk_double(state);
X = (long)floor(pow(U, -1.0/am1));
/* The real result may be above what can be represented in a signed
* long. It will get casted to -sys.maxint-1. Since this is
* a straightforward rejection algorithm, we can just reject this value
* in the rejection condition below. This function then models a Zipf
* distribution truncated to sys.maxint.
*/
T = pow(1.0 + 1.0/X, am1);
} while (((V*X*(T-1.0)/(b-1.0)) > (T/b)) || X < 1);
return X;
}
long rk_poisson_ptrs(rk_state *state, double lam)
{
long k;
double U, V, slam, loglam, a, b, invalpha, vr, us;
slam = sqrt(lam);
loglam = log(lam);
b = 0.931 + 2.53*slam;
a = -0.059 + 0.02483*b;
invalpha = 1.1239 + 1.1328/(b-3.4);
vr = 0.9277 - 3.6224/(b-2);
while (1)
{
U = rk_double(state) - 0.5;
V = rk_double(state);
us = 0.5 - fabs(U);
k = (long)floor((2*a/us + b)*U + lam + 0.43);
if ((us >= 0.07) && (V <= vr))
{
return k;
}
if ((k < 0) ||
((us < 0.013) && (V > us)))
{
continue;
}
if ((log(V) + log(invalpha) - log(a/(us*us)+b)) <=
(-lam + k*loglam - loggam(k+1)))
{
return k;
}
}
}
/* Obtain a sample via Sampford's rejection method. */
int
sampford_pps(Sampford* sampford, int* sample, rk_state* rng_state_ptr) {
int i, j, k, duplicate, ntry;
int npopn, nsamp;
double val, tot;
npopn = sampford->npopn;
nsamp = sampford->nsamp;
/* Cycle the rejection loop until nsamp distinct members get selected. */
ntry = 0;
do {
ntry++;
/* Pick the first value based on the raw weights. */
/* val = sampford->cumwts[npopn-1] * (1.*rand())/(RAND_MAX+1.); */
val = sampford->cumwts[npopn-1] * rk_double(rng_state_ptr);
for (i=0; i<npopn; i++) {
if (val <= sampford->cumwts[i]) break;
}
sample[0] = i;
/* PySys_WriteStdout("First sample unit: %i %i\n", i, ntry); */
/* Pick subsequent samples based on the ratios, rejecting sequences with duplicates. */
duplicate = 0;
tot = sampford->cumratios[npopn-1];
for (j=1; j<nsamp; j++) {
val = tot * (1.*rand())/(RAND_MAX+1.);
for (i=0; i<npopn; i++) {
if (val <= sampford->cumratios[i]) break;
}
/* If i was already selected, note a duplicate and end the ratio loop. */
for (k=0; k<j; k++) {
if (sample[k] == i) {
duplicate = 1;
break;
}
}
/* PySys_WriteStdout("j, choice, dup: %i %i %i\n", j, i, duplicate); */
if (duplicate) break;
sample[j] = i;
}
/* End the rejection loop if there are no duplicates; else start over. */
} while (duplicate);
return ntry;
}
void montecarlo_thomson_scatter(rpacket_t *packet, storage_model_t *storage, double distance)
{
double comov_energy, doppler_factor, comov_nu, inverse_doppler_factor;
doppler_factor = move_packet(packet, storage, distance);
comov_nu = rpacket_get_nu(packet) * doppler_factor;
comov_energy = rpacket_get_energy(packet) * doppler_factor;
rpacket_set_mu(packet, 2.0 * rk_double(&mt_state) - 1.0);
inverse_doppler_factor = 1.0 / rpacket_doppler_factor(packet, storage);
rpacket_set_nu(packet, comov_nu * inverse_doppler_factor);
rpacket_set_energy(packet, comov_energy * inverse_doppler_factor);
rpacket_reset_tau_event(packet);
rpacket_set_recently_crossed_boundary(packet, 0);
storage->last_interaction_type[storage->current_packet_id] = 1;
if (rpacket_get_virtual_packet_flag(packet) > 0)
{
montecarlo_one_packet(storage, packet, 1);
}
}
double rk_wald(rk_state *state, double mean, double scale)
{
double U, X, Y;
double mu_2l;
mu_2l = mean / (2*scale);
Y = rk_gauss(state);
Y = mean*Y*Y;
X = mean + mu_2l*(Y - sqrt(4*scale*Y + Y*Y));
U = rk_double(state);
if (U <= mean/(mean+X))
{
return X;
} else
{
return mean*mean/X;
}
}
long rk_geometric_search(rk_state *state, double p)
{
double U;
long X;
double sum, prod, q;
X = 1;
sum = prod = p;
q = 1.0 - p;
U = rk_double(state);
while (U > sum)
{
prod *= q;
sum += prod;
X++;
}
return X;
}
void
montecarlo_thomson_scatter (rpacket_t * packet, storage_model_t * storage,
double distance, rk_state *mt_state)
{
move_packet (packet, storage, distance);
double doppler_factor = rpacket_doppler_factor (packet, storage);
double comov_nu = rpacket_get_nu (packet) * doppler_factor;
double comov_energy = rpacket_get_energy (packet) * doppler_factor;
rpacket_set_mu (packet, 2.0 * rk_double (mt_state) - 1.0);
double inverse_doppler_factor = 1.0 / rpacket_doppler_factor (packet, storage);
rpacket_set_nu (packet, comov_nu * inverse_doppler_factor);
rpacket_set_energy (packet, comov_energy * inverse_doppler_factor);
rpacket_reset_tau_event (packet, mt_state);
storage->last_interaction_type[rpacket_get_id (packet)] = 1;
if (rpacket_get_virtual_packet_flag (packet) > 0)
{
montecarlo_one_packet (storage, packet, 1, mt_state);
}
}
inline int64_t macro_atom(rpacket_t *packet, storage_model_t *storage)
{
int emit, i = 0;
double p, event_random;
int activate_level = storage->line2macro_level_upper[rpacket_get_next_line_id(packet) - 1];
while (emit != -1)
{
event_random = rk_double(&mt_state);
i = storage->macro_block_references[activate_level] - 1;
p = 0.0;
do
{
p += storage->transition_probabilities[rpacket_get_current_shell_id(packet) * storage->transition_probabilities_nd + (++i)];
} while (p <= event_random);
emit = storage->transition_type[i];
activate_level = storage->destination_level_id[i];
}
return storage->transition_line_id[i];
}
double rk_triangular(rk_state *state, double left, double mode, double right)
{
double base, leftbase, ratio, leftprod, rightprod;
double U;
base = right - left;
leftbase = mode - left;
ratio = leftbase / base;
leftprod = leftbase*base;
rightprod = (right - mode)*base;
U = rk_double(state);
if (U <= ratio)
{
return left + sqrt(U*leftprod);
} else
{
return right - sqrt((1.0 - U) * rightprod);
}
}
long rk_hypergeometric_hyp(rk_state *state, long good, long bad, long sample)
{
long d1, K, Z;
double d2, U, Y;
d1 = bad + good - sample;
d2 = (double)min(bad, good);
Y = d2;
K = sample;
while (Y > 0.0)
{
U = rk_double(state);
Y -= (long)floor(U + Y/(d1 + K));
K--;
if (K == 0) break;
}
Z = (long)(d2 - Y);
if (good > bad) Z = sample - Z;
return Z;
}
long rk_poisson_mult(rk_state *state, double lam)
{
long X;
double prod, U, enlam;
enlam = exp(-lam);
X = 0;
prod = 1.0;
while (1)
{
U = rk_double(state);
prod *= U;
if (prod > enlam)
{
X += 1;
}
else
{
return X;
}
}
}
int64_t
macro_atom (const rpacket_t * packet, const storage_model_t * storage, rk_state *mt_state)
{
int emit = 0, i = 0, offset = -1;
uint64_t activate_level =
storage->line2macro_level_upper[rpacket_get_next_line_id (packet)];
while (emit != -1)
{
double event_random = rk_double (mt_state);
i = storage->macro_block_references[activate_level] - 1;
double p = 0.0;
offset = storage->transition_probabilities_nd *
rpacket_get_current_shell_id (packet);
do
{
++i;
p += storage->transition_probabilities[offset + i];
}
while (p <= event_random);
emit = storage->transition_type[i];
activate_level = storage->destination_level_id[i];
}
return storage->transition_line_id[i];
}
long rk_geometric_inversion(rk_state *state, double p)
{
return (long)ceil(log(1.0-rk_double(state))/log(1.0-p));
}
double rk_rayleigh(rk_state *state, double mode)
{
return mode*sqrt(-2.0 * log(1.0 - rk_double(state)));
}
long rk_binomial_btpe(rk_state *state, long n, double p)
{
double r,q,fm,p1,xm,xl,xr,c,laml,lamr,p2,p3,p4;
double a,u,v,s,F,rho,t,A,nrq,x1,x2,f1,f2,z,z2,w,w2,x;
long m,y,k,i;
if (!(state->has_binomial) ||
(state->nsave != n) ||
(state->psave != p))
{
/* initialize */
state->nsave = n;
state->psave = p;
state->has_binomial = 1;
state->r = r = min(p, 1.0-p);
state->q = q = 1.0 - r;
state->fm = fm = n*r+r;
state->m = m = (long)floor(state->fm);
state->p1 = p1 = floor(2.195*sqrt(n*r*q)-4.6*q) + 0.5;
state->xm = xm = m + 0.5;
state->xl = xl = xm - p1;
state->xr = xr = xm + p1;
state->c = c = 0.134 + 20.5/(15.3 + m);
a = (fm - xl)/(fm-xl*r);
state->laml = laml = a*(1.0 + a/2.0);
a = (xr - fm)/(xr*q);
state->lamr = lamr = a*(1.0 + a/2.0);
state->p2 = p2 = p1*(1.0 + 2.0*c);
state->p3 = p3 = p2 + c/laml;
state->p4 = p4 = p3 + c/lamr;
}
else
{
r = state->r;
q = state->q;
fm = state->fm;
m = state->m;
p1 = state->p1;
xm = state->xm;
xl = state->xl;
xr = state->xr;
c = state->c;
laml = state->laml;
lamr = state->lamr;
p2 = state->p2;
p3 = state->p3;
p4 = state->p4;
}
/* sigh ... */
Step10:
nrq = n*r*q;
u = rk_double(state)*p4;
v = rk_double(state);
if (u > p1) goto Step20;
y = (long)floor(xm - p1*v + u);
goto Step60;
Step20:
if (u > p2) goto Step30;
x = xl + (u - p1)/c;
v = v*c + 1.0 - fabs(m - x + 0.5)/p1;
if (v > 1.0) goto Step10;
y = (long)floor(x);
goto Step50;
Step30:
if (u > p3) goto Step40;
y = (long)floor(xl + log(v)/laml);
if (y < 0) goto Step10;
v = v*(u-p2)*laml;
goto Step50;
Step40:
y = (long)floor(xr - log(v)/lamr);
if (y > n) goto Step10;
v = v*(u-p3)*lamr;
Step50:
k = fabs(y - m);
if ((k > 20) && (k < ((nrq)/2.0 - 1))) goto Step52;
s = r/q;
a = s*(n+1);
F = 1.0;
if (m < y)
{
for (i=m+1; i<=y; i++)
{
F *= (a/i - s);
}
}
else if (m > y)
{
for (i=y+1; i<=m; i++)
{
F /= (a/i - s);
}
}
if (v > F) goto Step10;
goto Step60;
Step52:
rho = (k/(nrq))*((k*(k/3.0 + 0.625) + 0.16666666666666666)/nrq + 0.5);
t = -k*k/(2*nrq);
A = log(v);
if (A < (t - rho)) goto Step60;
if (A > (t + rho)) goto Step10;
x1 = y+1;
f1 = m+1;
z = n+1-m;
w = n-y+1;
x2 = x1*x1;
f2 = f1*f1;
z2 = z*z;
w2 = w*w;
if (A > (xm*log(f1/x1)
+ (n-m+0.5)*log(z/w)
+ (y-m)*log(w*r/(x1*q))
+ (13680.-(462.-(132.-(99.-140./f2)/f2)/f2)/f2)/f1/166320.
+ (13680.-(462.-(132.-(99.-140./z2)/z2)/z2)/z2)/z/166320.
+ (13680.-(462.-(132.-(99.-140./x2)/x2)/x2)/x2)/x1/166320.
+ (13680.-(462.-(132.-(99.-140./w2)/w2)/w2)/w2)/w/166320.))
{
goto Step10;
}
Step60:
if (p > 0.5)
{
y = n - y;
}
return y;
}