static void get_weight_factor(struct efp *efp, double *mass_fact, mat_t *inertia_fact)
{
size_t n_frags;
check_fail(efp_get_frag_count(efp, &n_frags));
double xyzabc[6 * n_frags];
check_fail(efp_get_coordinates(efp, xyzabc));
for (size_t i = 0; i < n_frags; i++) {
double mass;
check_fail(efp_get_frag_mass(efp, i, &mass));
double inertia[3];
check_fail(efp_get_frag_inertia(efp, i, inertia));
double a = xyzabc[6 * i + 3];
double b = xyzabc[6 * i + 4];
double c = xyzabc[6 * i + 5];
mat_t rotmat;
euler_to_matrix(a, b, c, &rotmat);
mass_fact[i] = 1.0 / sqrt(mass);
get_inertia_factor(inertia, &rotmat, inertia_fact + i);
}
}
int lp_parse(lp_parse_env* lp_p)
{
check_null(lp_p, LP_FAIL);
check_null(lp_p->token_list, LP_FAIL);
while(lp_p->read_inx < lp_p->token_list->list_len)
{
lp_token* lp_t = lp_at_token(lp_p);
assert(lp_t);
switch(lp_t->type)
{
case t_Kmessage:
check_fail(lp_parse_message(lp_p, NULL), LP_FAIL);
break;
case t_Kextern:
check_fail(lp_parse_extern(lp_p), LP_FAIL);
break;
default:
print("parse[error line: %d] the error token!\n", lp_t->line);
return LP_FAIL;
}
}
return LP_TRUE;
}
static void compute_forces(struct md *md)
{
for (size_t i = 0; i < md->n_bodies; i++) {
double crd[12];
memcpy(crd, &md->bodies[i].pos, 3 * sizeof(double));
memcpy(crd + 3, &md->bodies[i].rotmat, 9 * sizeof(double));
check_fail(efp_set_frag_coordinates(md->state->efp, i, EFP_COORD_TYPE_ROTMAT, crd));
}
compute_energy(md->state, true);
md->potential_energy = md->state->energy;
for (size_t i = 0; i < md->n_bodies; i++) {
struct body *body = md->bodies + i;
body->force.x = -md->state->grad[6 * i + 0];
body->force.y = -md->state->grad[6 * i + 1];
body->force.z = -md->state->grad[6 * i + 2];
body->torque.x = -md->state->grad[6 * i + 3];
body->torque.y = -md->state->grad[6 * i + 4];
body->torque.z = -md->state->grad[6 * i + 5];
/* convert torque to body frame */
body->torque = mat_trans_vec(&body->rotmat, &body->torque);
}
}
static void mass_weight_hessian(struct efp *efp, const double *in, double *out)
{
size_t n_frags, n_coord;
check_fail(efp_get_frag_count(efp, &n_frags));
n_coord = 6 * n_frags;
double mass_fact[n_frags];
mat_t inertia_fact[n_frags];
get_weight_factor(efp, mass_fact, inertia_fact);
for (size_t i = 0; i < n_frags; i++) {
for (size_t j = 0; j < n_frags; j++) {
size_t offset = 6 * n_coord * i + 6 * j;
w_tr_tr(mass_fact[i], mass_fact[j], n_coord,
in + offset,
out + offset);
w_tr_rot(mass_fact[i], inertia_fact + j, n_coord,
in + offset + 3,
out + offset + 3);
w_rot_tr(inertia_fact + i, mass_fact[j], n_coord,
in + offset + 3 * n_coord,
out + offset + 3 * n_coord);
w_rot_rot(inertia_fact + i, inertia_fact + j, n_coord,
in + offset + 3 * n_coord + 3,
out + offset + 3 * n_coord + 3);
}
}
}
static void print_restart(const struct md *md)
{
msg(" RESTART DATA\n\n");
for (size_t i = 0; i < md->n_bodies; i++) {
struct body *body = md->bodies + i;
char name[64];
check_fail(efp_get_frag_name(md->state->efp, i, sizeof(name), name));
double xyzabc[6] = { body->pos.x * BOHR_RADIUS,
body->pos.y * BOHR_RADIUS,
body->pos.z * BOHR_RADIUS };
matrix_to_euler(&body->rotmat, xyzabc + 3, xyzabc + 4, xyzabc + 5);
double vel[6] = { body->vel.x,
body->vel.y,
body->vel.z,
body->angmom.x * body->inertia_inv.x,
body->angmom.y * body->inertia_inv.y,
body->angmom.z * body->inertia_inv.z };
print_fragment(name, xyzabc, vel);
}
msg("\n");
}
static void set_body_mass_and_inertia(struct efp *efp, size_t idx, struct body *body)
{
double mass, inertia[3];
check_fail(efp_get_frag_mass(efp, idx, &mass));
check_fail(efp_get_frag_inertia(efp, idx, inertia));
body->mass = AMU_TO_AU * mass;
body->inertia.x = AMU_TO_AU * inertia[0];
body->inertia.y = AMU_TO_AU * inertia[1];
body->inertia.z = AMU_TO_AU * inertia[2];
body->inertia_inv.x = body->inertia.x < EPSILON ? 0.0 : 1.0 / body->inertia.x;
body->inertia_inv.y = body->inertia.y < EPSILON ? 0.0 : 1.0 / body->inertia.y;
body->inertia_inv.z = body->inertia.z < EPSILON ? 0.0 : 1.0 / body->inertia.z;
}
static int sl_Wmessage(slice* out, llp_mes* lms)
{
int i=0;
check_fail(sl_W32(out, (llp_uint32)sl_lens(&lms->sio)), LP_FAIL); // write lens
for(i=0; i<sl_lens(&lms->sio); i++) // write message body
sl_Wbyte(out, lms->sio.b_sp[i]);
return LP_TRUE;
}
SEXP R_match_soundex(SEXP x, SEXP table, SEXP nomatch, SEXP matchNA) {
int nx = length(x);
int ntable = length(table);
int no_match = INTEGER(nomatch)[0];
int match_na = INTEGER(matchNA)[0];
int bytes = IS_CHARACTER(x);
// when a and b are character vectors; create unsigned int vectors in which
// the elements of and b will be copied
unsigned int *s = NULL, *t = NULL;
if (bytes) {
int ml_x = max_length(x);
int ml_t = max_length(table);
s = (unsigned int *) malloc((ml_x + ml_t) * sizeof(unsigned int));
t = s + ml_x;
if (s == NULL) {
free(s);
error("Unable to allocate enough memory");
}
}
// output vector
SEXP yy = allocVector(INTSXP, nx);
PROTECT(yy);
int* y = INTEGER(yy);
int index, isna_s, isna_t, len_s, len_t;
unsigned int nfail = 0;
double d;
for (int i=0; i<nx; ++i) {
index = no_match;
s = get_elem(x, i, bytes, &len_s, &isna_s, s);
for (int j=0; j<ntable; ++j) {
t = get_elem(table, j, bytes, &len_t, &isna_t, t);
if (!isna_s && !isna_t) { // both are char (usual case)
d = soundex_dist(s, t, len_s, len_t, &nfail);
if (d < 0.5) { // exact match as d can only take on values 0 and 1
index = j + 1;
break;
}
} else if (isna_s && isna_t) { // both are NA
index = match_na ? j + 1 : no_match;
break;
}
}
y[i] = index;
}
// cleanup and return
check_fail(nfail);
if (bytes) free(s);
UNPROTECT(1);
return(yy);
}
int sl_Rlens(slice* sl, llp_uint32* out)
{
check_sl(sl);
check_fail(sl_Ruint(sl, out), LP_FAIL);
sl->sp += (*out);
check_sl(sl);
sl->sp -= (*out);
return LP_TRUE;
}
static int sl_Wbytes(slice* out, slice* sl)
{
size_t i=0;
check_fail(sl_Wint32(out, (llp_int32)(sl->sp_size)), LP_FAIL);
for(i=0; i<sl->sp_size; i++)
{
sl_Wbyte(out, sl->b_sp[i]);
}
return LP_TRUE;
}
// api
LLP_API slice* llp_out_message(llp_mes* lms)
{
check_fail(_llp_out_message(lms), NULL);
lms->sret.b_sp = lms->sio.b_sp;
lms->sret.sp = lms->sio.b_sp;
lms->sret.sp_size = lms->sio.sp - lms->sio.b_sp;
return &lms->sret;
}
static int sl_Rbytes(slice* in, slice* sl)
{
slice ret= {0};
check_fail(sl_R32(in, (llp_uint32*)(&ret.sp_size)), LP_FAIL);
if(sl_emp(in)<ret.sp_size)
return LP_FAIL;
ret.b_sp=ret.sp = in->sp;
in->sp += ret.sp_size;
*sl = ret;
return LP_TRUE;
}
static void compute_gradient(struct state *state, size_t n_frags,
const double *xyzabc, double *grad)
{
check_fail(efp_set_coordinates(state->efp, EFP_COORD_TYPE_XYZABC, xyzabc));
compute_energy(state, true);
memcpy(grad, state->grad, n_frags * 6 * sizeof(double));
for (size_t i = 0; i < n_frags; i++) {
const double *euler = xyzabc + 6 * i + 3;
double *gradptr = grad + 6 * i + 3;
efp_torque_to_derivative(euler, gradptr, gradptr);
}
}
static void
test_fail ()
{
if (GNUNET_SYSERR == check_fail (""))
GNUNET_break (0);
if (GNUNET_SYSERR == check_fail ("http"))
GNUNET_break (0);
if (GNUNET_SYSERR == check_fail ("://"))
GNUNET_break (0);
if (GNUNET_SYSERR == check_fail ("http://"))
GNUNET_break (0);
if (GNUNET_SYSERR == check_fail ("//localhost"))
GNUNET_break (0);
if (GNUNET_SYSERR == check_fail ("//:80"))
GNUNET_break (0);
if (GNUNET_SYSERR == check_fail ("//:80/"))
GNUNET_break (0);
if (GNUNET_SYSERR == check_fail ("//:80:"))
GNUNET_break (0);
if (GNUNET_SYSERR == check_fail ("http://localhost:a/"))
GNUNET_break (0);
if (GNUNET_SYSERR == check_fail ("http://127.0.0.1:a/"))
GNUNET_break (0);
}
void sim_hess(struct state *state)
{
msg("HESSIAN JOB\n\n\n");
print_geometry(state->efp);
compute_energy(state, true);
print_energy(state);
print_gradient(state);
size_t n_frags, n_coord;
double *hess, *mass_hess, *eigen;
check_fail(efp_get_frag_count(state->efp, &n_frags));
n_coord = 6 * n_frags;
hess = xmalloc(n_coord * n_coord * sizeof(double));
compute_hessian(state, hess);
msg(" HESSIAN MATRIX\n\n");
print_matrix(n_coord, n_coord, hess);
mass_hess = xmalloc(n_coord * n_coord * sizeof(double));
mass_weight_hessian(state->efp, hess, mass_hess);
msg(" MASS-WEIGHTED HESSIAN MATRIX\n\n");
print_matrix(n_coord, n_coord, mass_hess);
msg(" NORMAL MODE ANALYSIS\n\n");
eigen = xmalloc(n_coord * sizeof(double));
if (efp_dsyev('V', 'U', (int)n_coord, mass_hess, (int)n_coord, eigen))
error("unable to diagonalize mass-weighted hessian matrix");
for (size_t i = 0; i < n_coord; i++) {
print_mode(i + 1, eigen[i]);
print_vector(n_coord, mass_hess + i * n_coord);
}
free(hess);
free(mass_hess);
free(eigen);
msg("HESSIAN JOB COMPLETED SUCCESSFULLY\n");
}
SEXP R_soundex_dist(SEXP a, SEXP b) {
int na = length(a);
int nb = length(b);
int nt = MAX(na,nb);
int bytes = IS_CHARACTER(a);
// when a and b are character vectors; create unsigned int vectors in which
// the elements of and b will be copied
unsigned int *s = NULL, *t = NULL;
if (bytes) {
int ml_a = max_length(a);
int ml_b = max_length(b);
s = (unsigned int *) malloc((ml_a + ml_b) * sizeof(unsigned int));
t = s + ml_a;
if (s == NULL) {
free(s);
error("Unable to allocate enough memory");
}
}
// create output variable
SEXP yy = allocVector(REALSXP, nt);
PROTECT(yy);
double *y = REAL(yy);
// compute distances, skipping NA's
unsigned int nfail = 0;
int len_s, len_t, isna_s, isna_t;
for (int k=0; k < nt; ++k, ++y) {
s = get_elem(a, k % na, bytes, &len_s, &isna_s, s);
t = get_elem(b, k % nb, bytes, &len_t, &isna_t, t);
if (isna_s || isna_t) {
(*y) = NA_REAL;
} else {
(*y) = soundex_dist(s, t, len_s, len_t, &nfail);
}
}
// cleanup and return
check_fail(nfail);
if (bytes) free(s);
UNPROTECT(1);
return yy;
}
static double get_pressure(const struct md *md)
{
double volume = get_volume(md);
vec_t pressure = vec_zero;
for (size_t i = 0; i < md->n_bodies; i++) {
const struct body *body = md->bodies + i;
pressure.x += body->mass * body->vel.x * body->vel.x;
pressure.y += body->mass * body->vel.y * body->vel.y;
pressure.z += body->mass * body->vel.z * body->vel.z;
}
mat_t stress;
check_fail(efp_get_stress_tensor(md->state->efp, (double *)&stress));
pressure.x = (pressure.x + stress.xx) / volume;
pressure.y = (pressure.y + stress.yy) / volume;
pressure.z = (pressure.z + stress.zz) / volume;
return (pressure.x + pressure.y + pressure.z) / 3.0;
}
/*
* Reference
*
* Simone Melchionna, Giovanni Ciccotti, Brad Lee Holian
*
* Hoover NPT dynamics for systems varying in shape and size
*
* Mol. Phys. 78, 533 (1993)
*/
static void update_step_npt(struct md *md)
{
struct npt_data *data = (struct npt_data *)md->data;
double dt = cfg_get_double(md->state->cfg, "time_step");
double t_tau = cfg_get_double(md->state->cfg, "thermostat_tau");
double t_target = cfg_get_double(md->state->cfg, "temperature");
double p_tau = cfg_get_double(md->state->cfg, "barostat_tau");
double p_target = cfg_get_double(md->state->cfg, "pressure");
double t_tau2 = t_tau * t_tau;
double p_tau2 = p_tau * p_tau;
double kbt = BOLTZMANN * t_target;
double t0 = get_temperature(md);
double p0 = get_pressure(md);
double v0 = get_volume(md);
for (size_t i = 0; i < md->n_bodies; i++) {
struct body *body = md->bodies + i;
body->vel.x += 0.5 * dt * (body->force.x / body->mass -
body->vel.x * (data->chi + data->eta));
body->vel.y += 0.5 * dt * (body->force.y / body->mass -
body->vel.y * (data->chi + data->eta));
body->vel.z += 0.5 * dt * (body->force.z / body->mass -
body->vel.z * (data->chi + data->eta));
body->angmom.x += 0.5 * dt * (body->torque.x -
body->angmom.x * data->chi);
body->angmom.y += 0.5 * dt * (body->torque.y -
body->angmom.y * data->chi);
body->angmom.z += 0.5 * dt * (body->torque.z -
body->angmom.z * data->chi);
rotate_body(body, dt);
}
data->chi += 0.5 * dt * (t0 / t_target - 1.0) / t_tau2;
data->chi_dt += 0.5 * dt * data->chi;
data->eta += 0.5 * dt * v0 * (p0 - p_target) / md->n_bodies / kbt / p_tau2;
vec_t com = get_system_com(md);
vec_t pos_init[md->n_bodies];
for (size_t i = 0; i < md->n_bodies; i++)
pos_init[i] = md->bodies[i].pos;
for (size_t iter = 1; iter <= MAX_ITER; iter++) {
bool done = true;
for (size_t i = 0; i < md->n_bodies; i++) {
struct body *body = md->bodies + i;
vec_t pos = wrap(md, &body->pos);
vec_t v = {
data->eta * (pos.x - com.x),
data->eta * (pos.y - com.y),
data->eta * (pos.z - com.z)
};
vec_t new_pos = {
pos_init[i].x + dt * (body->vel.x + v.x),
pos_init[i].y + dt * (body->vel.y + v.y),
pos_init[i].z + dt * (body->vel.z + v.z)
};
done = done && vec_dist(&body->pos, &new_pos) < EPSILON;
body->pos = new_pos;
}
if (done)
break;
if (iter == MAX_ITER)
msg("WARNING: NPT UPDATE DID NOT CONVERGE\n\n");
}
vec_scale(&md->box, exp(dt * data->eta));
check_fail(efp_set_periodic_box(md->state->efp, md->box.x, md->box.y, md->box.z));
compute_forces(md);
double chi_init = data->chi, eta_init = data->eta;
vec_t angmom_init[md->n_bodies], vel_init[md->n_bodies];
for (size_t i = 0; i < md->n_bodies; i++) {
angmom_init[i] = md->bodies[i].angmom;
vel_init[i] = md->bodies[i].vel;
}
for (size_t iter = 1; iter <= MAX_ITER; iter++) {
double chi_prev = data->chi;
double eta_prev = data->eta;
double t_cur = get_temperature(md);
double p_cur = get_pressure(md);
double v_cur = get_volume(md);
data->chi = chi_init + 0.5 * dt * (t_cur / t_target - 1.0) / t_tau2;
data->eta = eta_init + 0.5 * dt * v_cur * (p_cur - p_target) /
md->n_bodies / kbt / p_tau2;
for (size_t i = 0; i < md->n_bodies; i++) {
struct body *body = md->bodies + i;
body->vel.x = vel_init[i].x + 0.5 * dt *
(body->force.x / body->mass -
vel_init[i].x * (data->chi + data->eta));
body->vel.y = vel_init[i].y + 0.5 * dt *
(body->force.y / body->mass -
vel_init[i].y * (data->chi + data->eta));
body->vel.z = vel_init[i].z + 0.5 * dt *
(body->force.z / body->mass -
vel_init[i].z * (data->chi + data->eta));
body->angmom.x = angmom_init[i].x + 0.5 * dt *
(body->torque.x - angmom_init[i].x * data->chi);
body->angmom.y = angmom_init[i].y + 0.5 * dt *
(body->torque.y - angmom_init[i].y * data->chi);
body->angmom.z = angmom_init[i].z + 0.5 * dt *
(body->torque.z - angmom_init[i].z * data->chi);
}
if (fabs(data->chi - chi_prev) < EPSILON &&
fabs(data->eta - eta_prev) < EPSILON)
break;
if (iter == MAX_ITER)
msg("WARNING: NPT UPDATE DID NOT CONVERGE\n\n");
}
data->chi_dt += 0.5 * dt * data->chi;
}
static int _llp_out_message(llp_mes* lms)
{
unsigned int inx =0;
size_t i=0;
check_null(lms, LP_FAIL);
llp_out_open(&lms->sio); // open out buff
// sl_W32(lms->d_mes->message_id); // if write id?
for(i=0; i<lms->field_lens; i++)
{
switch(tag_type(lms->d_mes->message_tfl[i].tag))
{
case LLPT_INTEGER:
{
for(inx=0; inx<lms->field_al[i].lens; inx++)
{
llp_value* lv = lib_array_inx(&lms->field_al[i], inx);
sl_Wtag(&lms->sio, o_num, i);
sl_Winteger(&lms->sio, lv->lp_integer);
}
}
break;
case LLPT_REAL:
{
for(inx=0; inx<lms->field_al[i].lens; inx++)
{
llp_value* lv = lib_array_inx(&lms->field_al[i], inx);
sl_Wtag(&lms->sio, o_num, i);
sl_Wreal(&lms->sio, lv->lp_real);
}
}
break;
case LLPT_STRING:
{
for(inx=0; inx<lms->field_al[i].lens; inx++)
{
llp_value* lv = lib_array_inx(&lms->field_al[i], inx);
sl_Wtag(&lms->sio, o_str, i);
sl_Wstring(&lms->sio, lv->lp_str);
}
}
break;
case LLPT_BYTES:
{
for(inx=0; inx<lms->field_al[i].lens; inx++)
{
llp_value* lv = lib_array_inx(&lms->field_al[i], inx);
sl_Wtag(&lms->sio, o_bytes, i);
sl_Wbytes(&lms->sio, lv->lp_bytes);
}
}
break;
case LLPT_MESSAGE:
{
for(inx=0; inx<lms->field_al[i].lens; inx++)
{
llp_value* lv = lib_array_inx(&lms->field_al[i], inx);
sl_Wtag(&lms->sio, o_mes, i);
check_fail(_llp_out_message(lv->lp_mes), LP_FAIL);
sl_Wmessage(&lms->sio, lv->lp_mes);
llp_out_close(&lv->lp_mes->sio); // close the message slice
}
}
break;
default:
return LP_FAIL;
}
}
return LP_TRUE;
}
LLP_API int llp_in_message(slice* in, llp_mes* lms)
{
size_t Ri = 0;
byte tt = 0;
llp_uint32 Rtag =0;
check_null(lms, LP_FAIL);
check_null(in, LP_FAIL);
check_null(in->sp, LP_FAIL);
while(sl_is_end(in)==0)
{
check_fail(sl_R32(in, &Rtag), LP_FAIL); // read tag
if( (Ri=Rtag_id(Rtag))>=lms->field_lens ) // check ID is true
return LP_FAIL;
// check tag type is true
switch(tt=(byte)tag_type(lms->d_mes->message_tfl[Ri].tag))
{
case LLPT_INTEGER:
{
llp_integer temp=0;
if(Rtag_type(Rtag)!= o_num)
return LP_FAIL;
check_fail(sl_Rinteger(in, &temp), LP_FAIL);
check_fail(_llp_Wmes(lms, Ri, tt, (void*)(&temp)), LP_FAIL);
}
break;
case LLPT_REAL:
{
llp_real temp = 0.0;
if(Rtag_type(Rtag)!= o_num)
return LP_FAIL;
check_fail(sl_Rreal(in, &temp), LP_FAIL);
check_fail(_llp_Wmes(lms, Ri, tt, (void*)(&temp)), LP_FAIL);
}
break;
case LLPT_STRING:
{
char* temp = NULL;
if(Rtag_type(Rtag)!= o_str)
return LP_FAIL;
check_fail(sl_Rstring(in, &temp), LP_FAIL);
check_fail(_llp_Wmes(lms, Ri, tt, (void*)(temp)), LP_FAIL);
}
break;
case LLPT_BYTES:
{
slice temp = {0};
if(Rtag_type(Rtag)!= o_bytes)
return LP_FAIL;
check_fail(sl_Rbytes(in, &temp), LP_FAIL);
check_fail(_llp_Wmes(lms, Ri, tt, (void*)(&temp)), LP_FAIL);
}
break;
case LLPT_MESSAGE:
{
slice st = {0};
llp_mes* temp = NULL;
if(Rtag_type(Rtag)!= o_mes)
return LP_FAIL;
check_fail(sl_R32(in, (llp_uint32*)(&st.sp_size)), LP_FAIL); // read message lens
st.sp = in->sp;
st.b_sp = st.sp;
check_fail(_llp_Wmes(lms, Ri, tt, (void*)(&temp)), LP_FAIL);
check_fail(llp_in_message(&st, temp), LP_FAIL);
in->sp += st.sp_size;
}
break;
default:
return LP_FAIL;
}
}
return LP_TRUE;
}
/* current coordinates from efp struct are used */
void compute_energy(struct state *state, bool do_grad)
{
struct efp_atom *atoms;
struct efp_energy efp_energy;
double xyz[3], xyzabc[6], *grad;
size_t ifrag, nfrag, iatom, natom;
int itotal;
check_fail(efp_compute(state->efp, do_grad));
check_fail(efp_get_energy(state->efp, &efp_energy));
check_fail(efp_get_frag_count(state->efp, &nfrag));
if (do_grad) {
check_fail(efp_get_gradient(state->efp, state->grad));
check_fail(efp_get_point_charge_gradient(state->efp, state->grad + 6 * nfrag));
}
state->energy = efp_energy.total;
if (state->ff == NULL)
return;
for (ifrag = 0, itotal = 0; ifrag < nfrag; ifrag++) {
check_fail(efp_get_frag_atom_count(state->efp, ifrag, &natom));
atoms = malloc(natom * sizeof(struct efp_atom));
check_fail(efp_get_frag_atoms(state->efp, ifrag, natom, atoms));
for (iatom = 0; iatom < natom; iatom++, itotal++)
ff_set_atom_xyz(state->ff, itotal, &atoms[iatom].x);
free(atoms);
}
ff_compute(state->ff, do_grad);
if (do_grad) {
for (ifrag = 0, itotal = 0, grad = state->grad; ifrag < nfrag; ifrag++, grad += 6) {
check_fail(efp_get_frag_xyzabc(state->efp, ifrag, xyzabc));
check_fail(efp_get_frag_atom_count(state->efp, ifrag, &natom));
atoms = malloc(natom * sizeof(struct efp_atom));
check_fail(efp_get_frag_atoms(state->efp, ifrag, natom, atoms));
for (iatom = 0; iatom < natom; iatom++, itotal++) {
ff_get_atom_gradient(state->ff, itotal, xyz);
grad[0] += xyz[0];
grad[1] += xyz[1];
grad[2] += xyz[2];
grad[3] += (atoms[iatom].y - xyzabc[1]) * xyz[2] -
(atoms[iatom].z - xyzabc[2]) * xyz[1];
grad[4] += (atoms[iatom].z - xyzabc[2]) * xyz[0] -
(atoms[iatom].x - xyzabc[0]) * xyz[2];
grad[5] += (atoms[iatom].x - xyzabc[0]) * xyz[1] -
(atoms[iatom].y - xyzabc[1]) * xyz[0];
}
free(atoms);
}
}
state->energy += ff_get_energy(state->ff);
}
/* current coordinates from efp struct are used */
void compute_energy(struct state *state, bool do_grad)
{
struct efp_atom *atoms;
struct efp_energy efp_energy;
double xyz[3], xyzabc[6], *grad;
size_t ifrag, nfrag, iatom, natom;
int itotal;
/* EFP part */
check_fail(efp_compute(state->efp, do_grad));
check_fail(efp_get_energy(state->efp, &efp_energy));
check_fail(efp_get_frag_count(state->efp, &nfrag));
if (do_grad) {
check_fail(efp_get_gradient(state->efp, state->grad));
check_fail(efp_get_point_charge_gradient(state->efp,
state->grad + 6 * nfrag));
}
state->energy = efp_energy.total;
/* constraints */
for (ifrag = 0; ifrag < nfrag; ifrag++) {
const struct frag *frag = state->sys->frags + ifrag;
check_fail(efp_get_frag_xyzabc(state->efp, ifrag, xyzabc));
if (frag->constraint_enable) {
double dr2, drx, dry, drz;
drx = xyzabc[0] - frag->constraint_xyz.x;
dry = xyzabc[1] - frag->constraint_xyz.y;
drz = xyzabc[2] - frag->constraint_xyz.z;
dr2 = drx * drx + dry * dry + drz * drz;
state->energy += 0.5 * frag->constraint_k * dr2;
if (do_grad) {
grad = state->grad + 6 * ifrag;
grad[0] += frag->constraint_k * drx;
grad[1] += frag->constraint_k * dry;
grad[2] += frag->constraint_k * drz;
}
}
}
/* MM force field part */
if (state->ff == NULL)
return;
for (ifrag = 0, itotal = 0; ifrag < nfrag; ifrag++) {
check_fail(efp_get_frag_atom_count(state->efp, ifrag, &natom));
atoms = malloc(natom * sizeof(struct efp_atom));
check_fail(efp_get_frag_atoms(state->efp, ifrag, natom, atoms));
for (iatom = 0; iatom < natom; iatom++, itotal++)
ff_set_atom_xyz(state->ff, itotal, &atoms[iatom].x);
free(atoms);
}
ff_compute(state->ff, do_grad);
if (do_grad) {
for (ifrag = 0, itotal = 0, grad = state->grad; ifrag < nfrag; ifrag++, grad += 6) {
check_fail(efp_get_frag_xyzabc(state->efp, ifrag, xyzabc));
check_fail(efp_get_frag_atom_count(state->efp, ifrag, &natom));
atoms = malloc(natom * sizeof(struct efp_atom));
check_fail(efp_get_frag_atoms(state->efp, ifrag, natom, atoms));
for (iatom = 0; iatom < natom; iatom++, itotal++) {
ff_get_atom_gradient(state->ff, itotal, xyz);
grad[0] += xyz[0];
grad[1] += xyz[1];
grad[2] += xyz[2];
grad[3] += (atoms[iatom].y - xyzabc[1]) * xyz[2] -
(atoms[iatom].z - xyzabc[2]) * xyz[1];
grad[4] += (atoms[iatom].z - xyzabc[2]) * xyz[0] -
(atoms[iatom].x - xyzabc[0]) * xyz[2];
grad[5] += (atoms[iatom].x - xyzabc[0]) * xyz[1] -
(atoms[iatom].y - xyzabc[1]) * xyz[0];
}
free(atoms);
}
}
state->energy += ff_get_energy(state->ff);
}
int main(int argc, char *argv[]) {
const char *theResponse;
RL_init();
check_fail(strcmp("empty",RL_env_message(0))!=0);
check_fail(strcmp("empty",RL_env_message(""))!=0);
check_fail(strcmp("empty",RL_agent_message(0))!=0);
check_fail(strcmp("empty",RL_agent_message(""))!=0);
check_fail(strcmp("",RL_env_message("empty"))!=0);
check_fail(strcmp("",RL_agent_message("empty"))!=0);
theResponse=RL_env_message("null");
check_fail(!(theResponse!=0 ||strcmp("",theResponse)!=0));
theResponse=RL_agent_message("null");
check_fail(!(theResponse!=0 ||strcmp("",theResponse)!=0));
check_fail(strcmp("1",RL_env_message("1"))!=0);
check_fail(strcmp("1",RL_agent_message("1"))!=0);
check_fail(strcmp("1000000000000000000000",RL_env_message("1000000000000000000000"))!=0);
check_fail(strcmp("1000000000000000000000",RL_agent_message("1000000000000000000000"))!=0);
check_fail(strcmp("21111111111111111111111111111111111111111111111111111111311111111111111111111111111111111111111111111111111111113",RL_env_message("21111111111111111111111111111111111111111111111111111111311111111111111111111111111111111111111111111111111111113"))!=0);
check_fail(strcmp("45555555555555555555555555555555555555555555555555555555655555555555555555555555555555555555555555555555555555559",RL_agent_message("45555555555555555555555555555555555555555555555555555555655555555555555555555555555555555555555555555555555555559"))!=0);
RL_cleanup();
if(tests_failed!=0)
printf("Failed %d / %d checks in %s\n",tests_failed,test_count, __FILE__);
else
printf("Passed all %d checks in %s\n",test_count,__FILE__);
return tests_failed;
}
int
main(int argc, char **argv)
{
RSA *rsa = NULL;
TSS_HCONTEXT hContext;
TSS_HKEY hKey, hSRK, hCAKey;
TSS_HPOLICY hTPMPolicy, hidpol;
TSS_UUID srkUUID = TSS_UUID_SRK;
TSS_HPOLICY srkpol;
TSS_HTPM hTPM;
UINT32 idbloblen, ch;
int ret,i, blobos, fd;
BYTE *srkpass, *tpmpass;
BYTE *blobo, *idblob;
srkpass = tpmpass = NULL;
while ((ch = getopt(argc, argv, "hs:t:")) != -1) {
switch (ch) {
case 's':
srkpass = optarg;
break;
case 't':
tpmpass = optarg;
break;
case 'h':
default:
usage(argv[0]);
break;
}
}
if (!srkpass || !tpmpass)
usage(argv[0]);
/* create context and connect */
ret = Tspi_Context_Create(&hContext);
check_fail("context create", ret);
ret = Tspi_Context_Connect(hContext, NULL);
check_fail("context connect", ret);
ret = Tspi_Context_LoadKeyByUUID(hContext, TSS_PS_TYPE_SYSTEM, srkUUID,
&hSRK);
check_fail("loadkeybyuuid", ret);
ret = Tspi_GetPolicyObject(hSRK, TSS_POLICY_USAGE, &srkpol);
check_fail("get policy object", ret);
//ret = Tspi_Policy_SetSecret(srkpol, TSS_SECRET_MODE_PLAIN, 4, "1234");
ret = Tspi_Policy_SetSecret(srkpol, TSS_SECRET_MODE_PLAIN,
strlen(srkpass), srkpass);
check_fail("policy set secret", ret);
ret = Tspi_Context_GetTpmObject(hContext, &hTPM);
check_fail("get policy object", ret);
//Insert the owner auth into the TPM's policy
ret = Tspi_GetPolicyObject(hTPM, TSS_POLICY_USAGE, &hTPMPolicy);
check_fail("get tpm policy", ret);
ret = Tspi_Policy_SetSecret(hTPMPolicy, TSS_SECRET_MODE_PLAIN,
strlen(tpmpass), tpmpass);
check_fail("set owner secret", ret);
ret = Tspi_Context_CreateObject(hContext, TSS_OBJECT_TYPE_RSAKEY,
//TSS_KEY_TYPE_STORAGE
TSS_KEY_TYPE_IDENTITY
//TSS_KEY_TYPE_SIGNING
| TSS_KEY_SIZE_2048 | TSS_KEY_NO_AUTHORIZATION
| TSS_KEY_NOT_MIGRATABLE | TSS_KEY_VOLATILE
, &hKey);
check_fail("create object - key", ret);
ret = Tspi_GetPolicyObject(hKey, TSS_POLICY_USAGE, &hidpol);
check_fail("get id key policy", ret);
ret = Tspi_Policy_SetSecret(hidpol, TSS_SECRET_MODE_PLAIN,
strlen(srkpass), srkpass);
check_fail("set idkey secret", ret);
/* We must create this fake privacy CA key in software so that
* Tspi_TPM_CollateIdentityRequest will happily work. It needs it to
* create the cert request which is required in a normal remote
* attestion procedure. It is not needed in our setup though.
*/
ret = make_fake_key(hContext, &hCAKey, &rsa, RSA_PKCS1_OAEP_PADDING);
check_fail("ca nonsense", ret);
/* We do not care about idblob - that is the certificate request that
* we are supposed to send to our CA in normal remote attestation. The
* fifth argument is our identity label (it is supposed to be unicode).
*/
ret = Tspi_TPM_CollateIdentityRequest(hTPM, hSRK, hCAKey, 8, "id label",
hKey, TSS_ALG_3DES, &idbloblen, &idblob);
check_fail("collate id", ret);
blobo = NULL;
/*ret = Tspi_GetAttribData(hKey, TSS_TSPATTRIB_KEY_BLOB,
TSS_TSPATTRIB_KEYBLOB_PUBLIC_KEY, &blobos, &blobo);*/
ret = Tspi_GetAttribData(hKey, TSS_TSPATTRIB_KEY_BLOB,
TSS_TSPATTRIB_KEYBLOB_BLOB, &blobos, &blobo);
check_fail("get blob", ret);
if (!blobo) {
Tspi_Context_FreeMemory(hContext, NULL);
Tspi_Context_Close(hContext);
FATAL("no blobo");
}
printf("size: %d\n", blobos);
for (i = 0;i < blobos; i++) {
printf("\\x%x", blobo[i]);
}
printf("\n");
fd = open("key.blob", O_WRONLY | O_CREAT | O_TRUNC, S_IRUSR | S_IWUSR);
if (fd == -1) {
Tspi_Context_FreeMemory(hContext, NULL);
Tspi_Context_Close(hContext);
FATAL("Open\n");
}
ret = write(fd, blobo, blobos);
if (ret != blobos)
printf("Warning: couldn't write the whole key\n");
close(fd);
Tspi_Context_FreeMemory(hContext, NULL);
Tspi_Context_Close(hContext);
return 0;
}
static struct md *md_create(struct state *state)
{
struct md *md = xcalloc(1, sizeof(struct md));
md->state = state;
md->box = box_from_str(cfg_get_string(state->cfg, "periodic_box"));
switch (cfg_get_enum(state->cfg, "ensemble")) {
case ENSEMBLE_TYPE_NVE:
md->get_invariant = get_invariant_nve;
md->update_step = update_step_nve;
break;
case ENSEMBLE_TYPE_NVT:
md->get_invariant = get_invariant_nvt;
md->update_step = update_step_nvt;
md->data = xcalloc(1, sizeof(struct nvt_data));
break;
case ENSEMBLE_TYPE_NPT:
md->get_invariant = get_invariant_npt;
md->update_step = update_step_npt;
md->data = xcalloc(1, sizeof(struct npt_data));
break;
default:
assert(0);
}
md->n_bodies = state->sys->n_frags;
md->bodies = xcalloc(md->n_bodies, sizeof(struct body));
double coord[6 * md->n_bodies];
check_fail(efp_get_coordinates(state->efp, coord));
for (size_t i = 0; i < md->n_bodies; i++) {
struct body *body = md->bodies + i;
body->pos.x = coord[6 * i + 0];
body->pos.y = coord[6 * i + 1];
body->pos.z = coord[6 * i + 2];
double a = coord[6 * i + 3];
double b = coord[6 * i + 4];
double c = coord[6 * i + 5];
euler_to_matrix(a, b, c, &body->rotmat);
body->vel.x = md->state->sys->frags[i].vel[0];
body->vel.y = md->state->sys->frags[i].vel[1];
body->vel.z = md->state->sys->frags[i].vel[2];
set_body_mass_and_inertia(state->efp, i, body);
body->angmom.x = md->state->sys->frags[i].vel[3] * body->inertia.x;
body->angmom.y = md->state->sys->frags[i].vel[4] * body->inertia.y;
body->angmom.z = md->state->sys->frags[i].vel[5] * body->inertia.z;
md->n_freedom += 3;
if (body->inertia.x > EPSILON)
md->n_freedom++;
if (body->inertia.y > EPSILON)
md->n_freedom++;
if (body->inertia.z > EPSILON)
md->n_freedom++;
}
return (md);
}
int main(int argc, char *argv[]) {
const reward_observation_action_terminal_t *roat;
const char* task_spec;
task_spec=RL_init();
RL_start();
roat=RL_step();
check_fail(roat->observation->numInts!=1);
check_fail(roat->observation->numDoubles!=0);
check_fail(roat->observation->numChars!=0);
check_fail(roat->observation->intArray[0]!=0);
check_fail(strcmp("one|1.|one",RL_env_message("one"))!=0);
check_fail(strcmp("one|1.|one",RL_agent_message("one"))!=0);
check_fail(roat->terminal!=0);
roat=RL_step();
check_fail(strcmp("two|2.2.|two",RL_env_message("two"))!=0);
check_fail(strcmp("two|2.2.|two",RL_agent_message("two"))!=0);
check_fail(roat->terminal!=0);
check_fail(roat->observation->numInts!=1);
check_fail(roat->observation->numDoubles!=0);
check_fail(roat->observation->numChars!=0);
check_fail(roat->observation->intArray[0]!=1);
roat=RL_step();
check_fail(strcmp("three||three",RL_env_message("three"))!=0);
check_fail(strcmp("three||three",RL_agent_message("three"))!=0);
check_fail(roat->terminal!=0);
check_fail(roat->observation->numInts!=1);
check_fail(roat->observation->numDoubles!=0);
check_fail(roat->observation->numChars!=0);
check_fail(roat->observation->intArray[0]!=2);
roat=RL_step();
check_fail(strcmp("four|4.|four",RL_env_message("four"))!=0);
check_fail(strcmp("four|4.|four",RL_agent_message("four"))!=0);
check_fail(roat->terminal!=0);
check_fail(roat->observation->numInts!=1);
check_fail(roat->observation->numDoubles!=0);
check_fail(roat->observation->numChars!=0);
check_fail(roat->observation->intArray[0]!=3);
roat=RL_step();
check_fail(strcmp("five|5.5.|five",RL_env_message("five"))!=0);
check_fail(strcmp("five|4.|five",RL_agent_message("five"))!=0);
check_fail(roat->terminal==0);
/* Gabor has made it so this environment will step past terminal. This is
not something we want to do in general at all.
But, in order to keep the other tests all working, I'll allow it*/
roat=RL_step();
check_fail(roat->observation->numInts!=5);
check_fail(roat->observation->numDoubles!=5);
check_fail(roat->observation->numChars!=5);
check_fail(roat->observation->intArray[0]!=173);
check_fail(roat->observation->intArray[1]!=-173);
check_fail(roat->observation->intArray[2]!=2147483647);
check_fail(roat->observation->intArray[3]!=0);
check_fail(roat->observation->intArray[4]!=-2147483648);
check_fail(roat->observation->doubleArray[0]!=0.0078125);
check_fail(roat->observation->doubleArray[1]!=-0.0078125);
check_fail(roat->observation->doubleArray[2]!=0);
check_fail(roat->observation->doubleArray[3]!=0.0078125e150);
check_fail(roat->observation->doubleArray[4]!=-0.0078125e150);
check_fail(roat->observation->charArray[0]!='g');
check_fail(roat->observation->charArray[1]!='F');
check_fail(roat->observation->charArray[2]!='?');
check_fail(roat->observation->charArray[3]!=' ');
check_fail(roat->observation->charArray[4]!='&');
RL_cleanup();
if(tests_failed!=0)
printf("Failed %d / %d checks in %s\n",tests_failed,test_count, __FILE__);
else
printf("Passed all %d checks in %s\n",test_count,__FILE__);
return tests_failed;
}
int main(int argc, char *argv[]) {
RL_init();
/* No cutoff */
int isTerminal = RL_episode(0);
check_fail(isTerminal!=1);
check_fail(RL_num_steps()!=5);
isTerminal = RL_episode(1);
check_fail(isTerminal!=0);
check_fail(RL_num_steps()!=1);
isTerminal = RL_episode(2);
check_fail(isTerminal!=0);
check_fail(RL_num_steps()!=2);
isTerminal = RL_episode(4);
check_fail(isTerminal!=0);
check_fail(RL_num_steps()!=4);
isTerminal = RL_episode(5);
check_fail(isTerminal!=0);
check_fail(RL_num_steps()!=5);
isTerminal = RL_episode(6);
check_fail(isTerminal!=1);
check_fail(RL_num_steps()!=5);
isTerminal = RL_episode(7);
check_fail(isTerminal!=1);
check_fail(RL_num_steps()!=5);
RL_cleanup();
if(tests_failed!=0)
printf("Failed %d / %d checks in %s\n",tests_failed,test_count, __FILE__);
else
printf("Passed all %d checks in %s\n",test_count,__FILE__);
return tests_failed;
}
static int lp_parse_closure(lp_parse_env* lp_p, lp_list* lp_out, llp_uint32* out_count, lp_table* ide_table, char* at_mes)
{
byte tag = 0;
byte lt;
lp_token* temp = NULL;
lp_token* ide = NULL;
int fmes = fmes_internal;
check_null(lp_p, LP_FAIL);
check_null(lp_out, LP_FAIL);
check_null(at_mes, LP_FAIL);
check_null(ide_table, LP_FAIL);
check_null(out_count, LP_FAIL);
lp_watch(lp_p, t_lb);
temp = lp_at_token(lp_p);
if(temp == NULL)
lp_watch(lp_p, t_rb);
for( ;(temp=lp_at_token(lp_p))!=NULL; )
{
switch(temp->type)
{
case t_Kinteger:
case t_Kreal:
case t_kstring:
case t_Kbytes:
case t_ide:
{
lp_token* tt = NULL;
if(temp->type != t_ide)
{
lt = tt2lt(temp->type);
lp_watch(lp_p, temp->type);
}
else
{
lt = LLPT_MESSAGE;
lp_string_clear(&lp_p->mes_name);
check_fail(lp_parse_defM(lp_p, at_mes, &lp_p->mes_name, &fmes), LP_FAIL);
}
tt= lp_at_token(lp_p);
if(tt == NULL)
lp_watch(lp_p, t_rb);
if(tt->type == t_ll) // if is arraylist []
{
lp_watch(lp_p, t_ll);
lp_watch(lp_p, t_rl);
tag = lp_tag(lt, e_rep);
lp_get_token(lp_p, t_ide, ide);
lp_watch(lp_p, t_end);
}
else if(tt->type == t_ide)
{
ide = tt;
tag = lp_tag(lt, e_req);
lp_watch(lp_p, t_ide);
lp_watch(lp_p, t_end); // ;
}
else
{
print("parse[error line: %d]not find ide!\n", tt->line);
return LP_FAIL;
}
{
char a=0;
size_t i=0;
int ret = 0;
if( (ret=lp_table_add(ide_table, (char*)ide->name.str.list_p, fmes_internal))==LP_EXIST)
{
print("parse[error line: %d] the ide \"%s\" is redef!\n", lp_p->line, (char*)ide->name.str.list_p);
return LP_FAIL;
}
else if(ret == LP_FAIL)
{
print("Serious error[line: %d]: add ide is error! \n", lp_p->line);
return LP_FAIL;
}
lp_list_add(lp_out, &tag); // push tag
if(temp->type==t_ide) // push message type name
{
union {
int v;
byte ei;
}v;
v.v = fmes;
lp_list_add(lp_out, &(v.ei));
for(i=0; i<lp_p->mes_name.str.list_len; i++)
lp_list_add(lp_out, lp_p->mes_name.str.list_p+i);
lp_list_add(lp_out, (byte*)(&a));
}
for(i=0; i<ide->name.str.list_len; i++) // push ide name
lp_list_add(lp_out, ide->name.str.list_p+i);
lp_list_add(lp_out, (byte*)&a);
(*out_count)++;
}
}
break;
case t_Kmessage:
check_fail(lp_parse_message(lp_p, at_mes), LP_FAIL);
break;
case t_rb:
lp_watch(lp_p, t_rb);
// if(back_out_lens >= lp_out->list_len)
// {
// print("parse[error line: %d] at message \"%s\" is empty body!\n", lp_p->line, at_mes);
// return LP_FAIL;
// }
goto CLO_END;
default:
print("parse[error line: %d] at {} not allow!\n", temp->line);
return LP_FAIL;
}
}
print("parse[error line: %d] you are lose \"}\"!\n", lp_p->line);
return LP_FAIL;
CLO_END:
return LP_TRUE;
}
static void compute_hessian(struct state *state, double *hess)
{
size_t n_frags, n_coord;
double *xyzabc, *grad_f, *grad_b;
bool central = cfg_get_bool(state->cfg, "hess_central");
check_fail(efp_get_frag_count(state->efp, &n_frags));
n_coord = 6 * n_frags;
xyzabc = xmalloc(n_coord * sizeof(double));
grad_f = xmalloc(n_coord * sizeof(double));
grad_b = xmalloc(n_coord * sizeof(double));
check_fail(efp_get_coordinates(state->efp, xyzabc));
if (!central) {
memcpy(grad_b, state->grad, n_frags * 6 * sizeof(double));
for (size_t i = 0; i < n_frags; i++) {
const double *euler = xyzabc + 6 * i + 3;
double *gradptr = grad_b + 6 * i + 3;
efp_torque_to_derivative(euler, gradptr, gradptr);
}
}
for (size_t i = 0; i < n_coord; i++) {
double save = xyzabc[i];
double step = i % 6 < 3 ? cfg_get_double(state->cfg, "num_step_dist") :
cfg_get_double(state->cfg, "num_step_angle");
show_progress(i + 1, n_coord, "FORWARD");
xyzabc[i] = save + step;
compute_gradient(state, n_frags, xyzabc, grad_f);
if (central) {
show_progress(i + 1, n_coord, "BACKWARD");
xyzabc[i] = save - step;
compute_gradient(state, n_frags, xyzabc, grad_b);
}
double delta = central ? 2.0 * step : step;
for (size_t j = 0; j < n_coord; j++)
hess[i * n_coord + j] = (grad_f[j] - grad_b[j]) / delta;
xyzabc[i] = save;
}
/* restore original coordinates */
check_fail(efp_set_coordinates(state->efp, EFP_COORD_TYPE_XYZABC, xyzabc));
/* reduce error by computing the average of H(i,j) and H(j,i) */
for (size_t i = 0; i < n_coord; i++) {
for (size_t j = i + 1; j < n_coord; j++) {
double sum = hess[i * n_coord + j] + hess[j * n_coord + i];
hess[i * n_coord + j] = 0.5 * sum;
hess[j * n_coord + i] = hess[i * n_coord + j];
}
}
free(xyzabc);
free(grad_f);
free(grad_b);
msg("\n\n");
}
SEXP R_soundex(SEXP x) {
int n = length(x);
int bytes = IS_CHARACTER(x);
// when a and b are character vectors; create unsigned int vectors in which
// the elements of and b will be copied
unsigned int *s = NULL;
if (bytes) {
int ml = max_length(x);
s = (unsigned int *) malloc(ml*sizeof(unsigned int));
if (s == NULL) {
free(s);
error("Unable to allocate enough memory");
}
}
if (bytes) {
// create output variable
SEXP y = allocVector(STRSXP, n);
PROTECT(y);
// compute soundexes, skipping NA's
unsigned int nfail = 0;
int len_s, isna_s;
char sndx[5];
unsigned int sndx_int[4];
for (int i = 0; i < n; ++i) {
s = get_elem(x, i, bytes, &len_s, &isna_s, s);
if (isna_s) {
SET_STRING_ELT(y, i, R_NaString);
} else {
nfail += soundex(s, len_s, sndx_int);
for (unsigned int j = 0; j < 4; ++j) sndx[j] = sndx_int[j];
sndx[4] = 0;
SET_STRING_ELT(y, i, mkChar(sndx));
}
}
// cleanup and return
check_fail(nfail);
free(s);
UNPROTECT(1);
return y;
} else {
// create output variable
SEXP y = allocVector(VECSXP, n);
PROTECT(y);
// compute soundexes, skipping NA's
unsigned int nfail = 0;
int len_s, isna_s;
for (int i = 0; i < n; ++i) {
s = get_elem(x, i, bytes, &len_s, &isna_s, s);
if (isna_s) {
SEXP sndx = allocVector(INTSXP, 1);
PROTECT(sndx);
INTEGER(sndx)[0] = NA_INTEGER;
SET_VECTOR_ELT(y, i, sndx);
UNPROTECT(1);
} else {
SEXP sndx = allocVector(INTSXP, 4);
PROTECT(sndx);
nfail += soundex(s, len_s, (unsigned int *)INTEGER(sndx));
SET_VECTOR_ELT(y, i, sndx);
UNPROTECT(1);
}
}
// cleanup and return
check_fail(nfail);
UNPROTECT(1);
return y;
}
}
