#include <assert.h>

#include <gsl/gsl_statistics_double.h>
#include <hdf5.h>
#include <hdf5_hl.h>

#include <qdm.h>

qdm_evaluation *
qdm_evaluation_new(const qdm_parameters *parameters)
{
  qdm_evaluation *e = malloc(sizeof(qdm_evaluation));

  e->parameters = *parameters;

  e->rng = gsl_rng_alloc(gsl_rng_default);

  e->years_min = 0;
  e->years_max = 0;

  e->lower_bound = 0;
  e->upper_bound = 0;

  e->waic = 0;
  e->pwaic = 0;
  e->dic = 0;
  e->pd = 0;

  e->t = NULL;

  e->mcmc = NULL;

  e->theta_bar = NULL;
  e->theta_star_bar = NULL;

  e->xi_cov = NULL;
  e->theta_star_cov = NULL;

  e->xi_low_bar = 0;
  e->xi_high_bar = 0;

  e->theta_acc = NULL;
  e->xi_acc = NULL;

  e->m_knots = NULL;

  e->rng_seed = 0;

  e->elapsed = 0;

  return e;
}

void
qdm_evaluation_free(qdm_evaluation *e)
{
  if (e == NULL) {
    return;
  }

  e->rng_seed = 0;

  gsl_vector_free(e->m_knots);
  e->m_knots = NULL;

  gsl_vector_free(e->xi_acc);
  e->xi_acc = NULL;

  gsl_matrix_free(e->theta_acc);
  e->theta_acc = NULL;

  gsl_matrix_free(e->theta_star_cov);
  e->theta_bar = NULL;

  gsl_matrix_free(e->xi_cov);
  e->theta_bar = NULL;

  gsl_matrix_free(e->theta_star_bar);
  e->theta_bar = NULL;

  gsl_matrix_free(e->theta_bar);
  e->theta_bar = NULL;

  qdm_mcmc_free(e->mcmc);
  e->mcmc = NULL;

  qdm_tau_free(e->t);
  e->t = NULL;

  gsl_rng_free(e->rng);
  e->rng = NULL;

  free(e);
}

void
qdm_evaluation_fprint(
    FILE *f,
    const qdm_evaluation *e
)
{
  const char *prefix = "  ";

  fprintf(f, "%sparameters:\n", prefix);
  qdm_parameters_fprint(f, &e->parameters);

  fprintf(f, "%syears_min: %f\n", prefix, e->years_min);
  fprintf(f, "%syears_max: %f\n", prefix, e->years_max);

  fprintf(f, "%slower_bound: %f\n", prefix, e->lower_bound);
  fprintf(f, "%supper_bound: %f\n", prefix, e->upper_bound);

  fprintf(f, "%swaic: %f\n", prefix, e->waic);
  fprintf(f, "%spwaic: %f\n", prefix, e->pwaic);
  fprintf(f, "%sdic: %f\n", prefix, e->dic);
  fprintf(f, "%spd: %f\n", prefix, e->pd);

  fprintf(f, "%smcmc r.s: %zu\n", prefix, e->mcmc->r.s);

  fprintf(f, "%stheta_bar:\n", prefix);
  qdm_matrix_csv_fwrite(f, e->theta_bar);

  fprintf(f, "%stheta_star_bar:\n", prefix);
  qdm_matrix_csv_fwrite(f, e->theta_star_bar);

  fprintf(f, "%sxi_cov:\n", prefix);
  qdm_matrix_csv_fwrite(f, e->xi_cov);

  fprintf(f, "%stheta_star_cov:\n", prefix);
  qdm_matrix_csv_fwrite(f, e->theta_star_cov);

  fprintf(f, "%sxi_low_bar: %f\n", prefix, e->xi_low_bar);
  fprintf(f, "%sxi_high_bar: %f\n", prefix, e->xi_high_bar);

  fprintf(f, "%stheta_acc:\n", prefix);
  qdm_matrix_csv_fwrite(f, e->theta_acc);

  fprintf(f, "%sxi_acc:\n", prefix);
  qdm_vector_csv_fwrite(f, e->xi_acc);

  fprintf(f, "%sm_knots:\n", prefix);
  qdm_vector_csv_fwrite(f, e->m_knots);

  fprintf(f, "%srng_seed: %lu\n", prefix, e->rng_seed);

  fprintf(f, "%selapsed: %f\n", prefix, e->elapsed);
}

int
qdm_evaluation_read(
    hid_t id,
    qdm_evaluation **e
)
{
  int status = 0;

  hid_t parameters_group = -1;
  hid_t mcmc_group = -1;

  parameters_group = H5Gopen(id, "parameters", H5P_DEFAULT);
  if (parameters_group < 0) {
    status = parameters_group;

    goto cleanup;
  }

  qdm_parameters parameters = {0};
  status = qdm_parameters_read(parameters_group, &parameters);
  if (status != 0) {
    goto cleanup;
  }

  *e = qdm_evaluation_new(&parameters);

#define READ(t, n) \
  status = H5LTread_dataset_##t(id, #n, &(*e)->n); \
  if (status < 0) { \
    goto cleanup; \
  }

  READ(double, years_min);
  READ(double, years_max);

  READ(double, lower_bound);
  READ(double, upper_bound);

  READ(double, waic);
  READ(double, pwaic);
  READ(double, dic);
  READ(double, pd);

  mcmc_group = H5Gopen(id, "mcmc", H5P_DEFAULT);
  if (mcmc_group < 0) {
    status = mcmc_group;

    goto cleanup;
  }

  status = qdm_mcmc_read(mcmc_group, &(*e)->mcmc);
  if (status != 0) {
    goto cleanup;
  }

  status = qdm_matrix_hd5_read(id, "theta_bar", &(*e)->theta_bar);
  if (status != 0) {
    goto cleanup;
  }

  status = qdm_matrix_hd5_read(id, "theta_star_bar", &(*e)->theta_star_bar);
  if (status != 0) {
    goto cleanup;
  }

  status = qdm_matrix_hd5_read(id, "xi_cov", &(*e)->xi_cov);
  if (status != 0) {
    goto cleanup;
  }

  status = qdm_matrix_hd5_read(id, "theta_star_cov", &(*e)->theta_star_cov);
  if (status != 0) {
    goto cleanup;
  }

  READ(double, xi_high_bar);
  READ(double, xi_low_bar);

  status = qdm_matrix_hd5_read(id, "theta_acc", &(*e)->theta_acc);
  if (status != 0) {
    goto cleanup;
  }

  status = qdm_vector_hd5_read(id, "xi_acc", &(*e)->xi_acc);
  if (status != 0) {
    goto cleanup;
  }

  status = qdm_vector_hd5_read(id, "m_knots", &(*e)->m_knots);
  if (status != 0) {
    goto cleanup;
  }

  status = H5LTread_dataset(id, "rng_seed", H5T_NATIVE_ULONG, &(*e)->rng_seed);
  if (status < 0) {
    goto cleanup;
  }

  READ(double, elapsed);

#undef READ

  (*e)->t = qdm_tau_alloc(
      (*e)->parameters.tau_table,
      (*e)->parameters.tau_low,
      (*e)->parameters.tau_high,
      (*e)->parameters.spline_df,
      (*e)->m_knots
  );

cleanup:
  if (parameters_group >= 0) {
    H5Gclose(parameters_group);
  }

  if (mcmc_group >= 0) {
    H5Gclose(mcmc_group);
  }

  return status;
}

int
qdm_evaluation_write(
    hid_t id,
    const qdm_evaluation *e
)
{
  int status = 0;

  hid_t parameters_group = -1;
  hid_t mcmc_group = -1;

#define WRITE_DOUBLE(n) \
  status = qdm_double_write(id, #n, e->n); \
  if (status != 0) { \
    goto cleanup; \
  }

  parameters_group = qdm_data_create_group(id, "parameters");
  if (parameters_group < 0) {
    status = parameters_group;

    goto cleanup;
  }

  status = qdm_parameters_write(parameters_group, &e->parameters);
  if (status != 0) {
    goto cleanup;
  }

  WRITE_DOUBLE(years_min);
  WRITE_DOUBLE(years_max);

  WRITE_DOUBLE(lower_bound);
  WRITE_DOUBLE(upper_bound);

  WRITE_DOUBLE(waic);
  WRITE_DOUBLE(pwaic);
  WRITE_DOUBLE(dic);
  WRITE_DOUBLE(pd);

  mcmc_group = qdm_data_create_group(id, "mcmc");
  if (mcmc_group < 0) {
    status = mcmc_group;

    goto cleanup;
  }

  status = qdm_mcmc_write(mcmc_group, e->mcmc);
  if (status != 0) {
    goto cleanup;
  }

  status = qdm_matrix_hd5_write(id, "theta_bar", e->theta_bar);
  if (status != 0) {
    goto cleanup;
  }

  status = qdm_matrix_hd5_write(id, "theta_star_bar", e->theta_star_bar);
  if (status != 0) {
    goto cleanup;
  }

  status = qdm_matrix_hd5_write(id, "xi_cov", e->xi_cov);
  if (status != 0) {
    goto cleanup;
  }

  status = qdm_matrix_hd5_write(id, "theta_star_cov", e->theta_star_cov);
  if (status != 0) {
    goto cleanup;
  }

  WRITE_DOUBLE(xi_high_bar);
  WRITE_DOUBLE(xi_low_bar);

  status = qdm_matrix_hd5_write(id, "theta_acc", e->theta_acc);
  if (status != 0) {
    goto cleanup;
  }

  status = qdm_vector_hd5_write(id, "xi_acc", e->xi_acc);
  if (status != 0) {
    goto cleanup;
  }

  status = qdm_vector_hd5_write(id, "m_knots", e->m_knots);
  if (status != 0) {
    goto cleanup;
  }

  {
    hsize_t dims[1] = {1};
    unsigned long int data[1] = {e->rng_seed};

    status = H5LTmake_dataset(id, "rng_seed", 1, dims, H5T_NATIVE_ULONG, data);
    if (status < 0) {
      goto cleanup;
    }
  }

  WRITE_DOUBLE(elapsed);

#undef WRITE_DOUBLE

cleanup:
  if (parameters_group >= 0) {
    H5Gclose(parameters_group);
  }

  if (mcmc_group >= 0) {
    H5Gclose(mcmc_group);
  }

  return status;
}

int
qdm_evaluation_run(
    qdm_evaluation *e,
    const gsl_matrix *data,
    size_t data_year_idx,
    size_t data_month_idx,
    size_t data_value_idx
)
{
  int status = 0;

  clock_t started_at = clock();

  gsl_vector *years = NULL;
  gsl_vector *years_norm = NULL;

  gsl_vector *values = NULL;
  gsl_vector *values_sorted = NULL;

  gsl_vector *interior_knots = NULL;

  gsl_vector *m_knots = NULL;
  gsl_matrix *theta = NULL;
  gsl_vector *ll = NULL;
  gsl_vector *tau = NULL;

  gsl_matrix *theta_tune = NULL;
  gsl_matrix *theta_acc = NULL;
  gsl_vector *xi_tune = NULL;
  gsl_vector *xi_acc = NULL;

  gsl_vector *xi = gsl_vector_alloc(2);
  gsl_vector_set(xi, 0, e->parameters.xi_low);
  gsl_vector_set(xi, 1, e->parameters.xi_high);

  /* Initialize RNG */

  gsl_rng_set(e->rng, e->parameters.rng_seed);

  /* Normalize Years */

  {
    years = qdm_matrix_filter(data, data_month_idx, e->parameters.month, data_year_idx);
    years_norm = qdm_matrix_filter(data, data_month_idx, e->parameters.month, data_year_idx);

    gsl_vector_minmax(years, &e->years_min, &e->years_max);

    double years_range = e->years_max - e->years_min;

    status = gsl_vector_add_constant(years_norm, -e->years_min);
    if (status != 0) {
      goto cleanup;
    }

    status = gsl_vector_scale(years_norm, 1 / years_range);
    if (status != 0) {
      goto cleanup;
    }
  }

  /* Extract Values */

  {
    values = qdm_matrix_filter(data, data_month_idx, e->parameters.month, data_value_idx);
    values_sorted = qdm_vector_sorted(values);

    e->lower_bound = gsl_vector_get(values_sorted, 0) - e->parameters.bound;
    e->upper_bound = gsl_vector_get(values_sorted, values_sorted->size - 1) + e->parameters.bound;
  }

  /* Optimize Knots */

  {
    gsl_vector *middle = qdm_vector_seq(e->parameters.tau_low, e->parameters.tau_high, 0.005);

    double possible_low = e->parameters.tau_low + 0.1;
    double possible_high = e->parameters.tau_high - 0.1;
    double possible_delta = (possible_high - possible_low) / 19;

    gsl_vector *possible_knots = qdm_vector_seq(possible_low, possible_high, possible_delta);

    interior_knots = gsl_vector_calloc(e->parameters.knot);

    status = qdm_knots_optimize(
        interior_knots,

        e->rng,

        values_sorted,
        middle,
        possible_knots,

        e->parameters.knot_try,
        e->parameters.spline_df
    );
    if (status != 0) {
      goto cleanup;
    }

    gsl_vector_free(possible_knots);
    gsl_vector_free(middle);
  }

  /* Optimize Theta */

  {
    size_t m = e->parameters.spline_df + e->parameters.knot;

    m_knots = qdm_knots_vector(e->parameters.spline_df, interior_knots);
    e->t = qdm_tau_alloc(
        e->parameters.tau_table,
        e->parameters.tau_low,
        e->parameters.tau_high,
        e->parameters.spline_df,
        m_knots
    );

    gsl_vector *middle = qdm_vector_seq(e->parameters.tau_low, e->parameters.tau_high, 0.01);

    gsl_matrix *ix = gsl_matrix_alloc(middle->size, m+1);
    qdm_ispline_matrix(ix, middle, e->parameters.spline_df, m_knots);

    theta = gsl_matrix_alloc(2, ix->size2);
    gsl_vector_view theta0 = gsl_matrix_row(theta, 0);
    gsl_vector_view theta1 = gsl_matrix_row(theta, 1);

    size_t theta_pivot = qdm_vector_greater_than(years_norm, 0.3);
    gsl_vector_view values0 = gsl_vector_subvector(values, 0, theta_pivot);
    gsl_vector_view values1 = gsl_vector_subvector(values, theta_pivot, values->size - theta_pivot);
    assert(values0.vector.size + values1.vector.size == values->size);

    gsl_vector *eq0 = qdm_vector_quantile(&values0.vector, middle);
    status = qdm_theta_optimize(&theta0.vector, eq0, ix);
    if (status != 0) {
      goto cleanup;
    }

    gsl_vector *eq1 = NULL;

    if (e->parameters.truncate) {
      gsl_vector_set_zero(&theta1.vector);
    } else {
      eq1 = qdm_vector_quantile(&values1.vector, middle);
      status = qdm_theta_optimize(&theta1.vector, eq1, ix);
      if (status != 0) {
        goto cleanup;
      }

      status = gsl_vector_sub(&theta1.vector, &theta0.vector);
      if (status != 0) {
        goto cleanup;
      }
    }

    qdm_theta_matrix_constrain(theta, e->parameters.theta_min);

    ll = gsl_vector_alloc(values->size);
    tau = gsl_vector_alloc(values->size);

    for (size_t i = 0; i < values->size; i++) {
      qdm_logl_3(
          &ll->data[i],
          &tau->data[i],

          gsl_vector_get(years_norm, i),
          gsl_vector_get(values, i),

          e->t,
          xi,

          theta
      );
    }

    gsl_vector_free(eq1);
    gsl_vector_free(eq0);
    gsl_matrix_free(ix);
    gsl_vector_free(middle);
  }

  /* MCMC */

  {
    qdm_mcmc_parameters mcmc_p = {
      .rng = e->rng,

      .burn = e->parameters.burn,
      .iter = e->parameters.iter,
      .thin = e->parameters.thin,

      .acc_check = e->parameters.acc_check,
      .spline_df = e->parameters.spline_df,

      .xi    = xi,
      .ll    = ll,
      .tau   = tau,
      .theta = theta,

      .xi_prior_mean = e->parameters.xi_prior_mean,
      .xi_prior_var  = e->parameters.xi_prior_var,
      .xi_tune_sd    = e->parameters.xi_tune_sd,

      .theta_min     = e->parameters.theta_min,
      .theta_tune_sd = e->parameters.theta_tune_sd,

      .x = years_norm,
      .y = values,

      .t = e->t,
      .m_knots = m_knots,

      .truncate = e->parameters.truncate,
    };

    e->mcmc = qdm_mcmc_alloc(mcmc_p);

    status = qdm_mcmc_run(e->mcmc);
    if (status != 0) {
      goto cleanup;
    }
  }

  /* Model Diagnostics */

  {
    // WAIC

    gsl_vector *ll_exp = gsl_vector_calloc(e->mcmc->r.s);

    gsl_vector *lppd = gsl_vector_calloc(values->size);
    gsl_vector *vlog = gsl_vector_calloc(values->size);

    for (size_t j = 0; j < values->size; j++) {
      gsl_vector_view ll_k = qdm_ijk_get_k(e->mcmc->r.ll, 0, j);

      for (size_t i = 0; i < ll_k.vector.size; i++) {
        gsl_vector_set(ll_exp, i, exp(gsl_vector_get(&ll_k.vector, i)));
      }

      gsl_vector_set(lppd, j, log(gsl_stats_mean(ll_exp->data, ll_exp->stride, ll_exp->size)));
      gsl_vector_set(vlog, j, gsl_stats_variance(ll_k.vector.data, ll_k.vector.stride, ll_k.vector.size));
    }

    status = gsl_vector_sub(lppd, vlog);
    if (status != 0) {
      goto cleanup;
    }

    e->waic = -2 * qdm_vector_sum(lppd);
    e->pwaic = qdm_vector_sum(vlog);

    // DIC

    gsl_vector *ll_sum = gsl_vector_alloc(e->mcmc->r.s);

    for (size_t k = 0; k < e->mcmc->r.s; k++) {
      gsl_matrix_view ll_ij_m = qdm_ijk_get_ij(e->mcmc->r.ll, k);
      gsl_vector_view ll_ij = gsl_matrix_row(&ll_ij_m.matrix, 0);

      gsl_vector_set(ll_sum, k, qdm_vector_sum(&ll_ij.vector));
    }

    status = gsl_vector_scale(ll_sum, -2);
    if (status != 0) {
      goto cleanup;
    }

    double d_bar = gsl_stats_mean(ll_sum->data, ll_sum->stride, ll_sum->size);
    double d_theta_bar = 0;

    gsl_vector_view xi_low = qdm_ijk_get_k(e->mcmc->r.xi, 0, 0);
    gsl_vector_view xi_high = qdm_ijk_get_k(e->mcmc->r.xi, 0, 1);

    double xi_low_bar = gsl_stats_mean(xi_low.vector.data, xi_low.vector.stride, xi_low.vector.size);
    double xi_high_bar = gsl_stats_mean(xi_high.vector.data, xi_high.vector.stride, xi_high.vector.size);

    gsl_vector *xi_bar = gsl_vector_alloc(2);
    gsl_vector_set(xi_bar, 0, xi_low_bar);
    gsl_vector_set(xi_bar, 1, xi_high_bar);

    gsl_matrix *theta_bar = gsl_matrix_alloc(theta->size1, theta->size2);

    for (size_t i = 0; i < e->mcmc->r.theta->size1; i++) {
      for (size_t j = 0; j < e->mcmc->r.theta->size2; j++) {
        gsl_vector_view theta_k = qdm_ijk_get_k(e->mcmc->r.theta, i, j);

        gsl_matrix_set(theta_bar, i, j, gsl_stats_mean(theta_k.vector.data, theta_k.vector.stride, theta_k.vector.size));
      }
    }

    gsl_matrix *theta_star_bar = gsl_matrix_alloc(theta->size1, theta->size2);

    for (size_t i = 0; i < e->mcmc->r.theta_star->size1; i++) {
      for (size_t j = 0; j < e->mcmc->r.theta_star->size2; j++) {
        gsl_vector_view theta_k = qdm_ijk_get_k(e->mcmc->r.theta_star, i, j);

        gsl_matrix_set(theta_star_bar, i, j, gsl_stats_mean(theta_k.vector.data, theta_k.vector.stride, theta_k.vector.size));
      }
    }

    for (size_t i = 0; i < values->size; i++) {
      double theta_bar_ll = 0;
      double tau_tmp = 0;

      qdm_logl_3(
          &theta_bar_ll,
          &tau_tmp,

          gsl_vector_get(years_norm, i),
          gsl_vector_get(values, i),

          e->t,
          xi_bar,

          theta_bar
      );

      d_theta_bar = d_theta_bar + -2 * theta_bar_ll;
    }

    e->pd = d_bar - d_theta_bar;
    e->dic = e->pd + d_bar;

    e->theta_bar = qdm_matrix_copy(theta_bar);
    e->theta_star_bar = qdm_matrix_copy(theta_star_bar);

    e->xi_cov = qdm_ijk_cov(e->mcmc->r.xi);
    e->theta_star_cov = qdm_ijk_cov(e->mcmc->r.theta_star);

    e->xi_low_bar = xi_low_bar;
    e->xi_high_bar = xi_high_bar;

    gsl_vector_free(xi_bar);
    gsl_matrix_free(theta_star_bar);
    gsl_matrix_free(theta_bar);
    gsl_vector_free(ll_sum);

    gsl_vector_free(vlog);
    gsl_vector_free(lppd);
    gsl_vector_free(ll_exp);
  }

  /* Results */
  {
    e->theta_acc = qdm_matrix_copy(e->mcmc->w.theta_acc);
    e->xi_acc = qdm_vector_copy(e->mcmc->w.xi_acc);

    e->m_knots = qdm_vector_copy(m_knots);

    e->rng_seed = gsl_rng_get(e->rng);
  }

  gsl_vector_free(years);
  gsl_vector_free(years_norm);
  gsl_vector_free(values);
  gsl_vector_free(values_sorted);
  gsl_vector_free(interior_knots);
  gsl_vector_free(m_knots);
  gsl_matrix_free(theta);
  gsl_vector_free(ll);
  gsl_vector_free(tau);

  gsl_matrix_free(theta_tune);
  gsl_matrix_free(theta_acc);
  gsl_vector_free(xi_tune);
  gsl_vector_free(xi_acc);

cleanup:
  e->elapsed = ((double)(clock() - started_at)) / CLOCKS_PER_SEC;

  return status;
}


/* histogram/init2d.c
 *
 * Copyright (C) 1996, 1997, 1998, 1999, 2000 Brian Gough
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or (at
 * your option) any later version.
 *
 * This program is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 */

#include <config.h>
#include <stdlib.h>
#include <gsl/gsl_errno.h>
#include <gsl/gsl_histogram2d.h>

gsl_histogram2d *
gsl_histogram2d_alloc (const size_t nx, const size_t ny)
{
  gsl_histogram2d *h;

  if (nx == 0)
    {
      GSL_ERROR_VAL ("histogram2d length nx must be positive integer",
			GSL_EDOM, 0);
    }

  if (ny == 0)
    {
      GSL_ERROR_VAL ("histogram2d length ny must be positive integer",
			GSL_EDOM, 0);
    }

  h = (gsl_histogram2d *) malloc (sizeof (gsl_histogram2d));

  if (h == 0)
    {
      GSL_ERROR_VAL ("failed to allocate space for histogram2d struct",
			GSL_ENOMEM, 0);
    }

  h->xrange = (double *) malloc ((nx + 1) * sizeof (double));

  if (h->xrange == 0)
    {
      free (h);		/* exception in constructor, avoid memory leak */

      GSL_ERROR_VAL ("failed to allocate space for histogram2d x ranges",
			GSL_ENOMEM, 0);
    }

  h->yrange = (double *) malloc ((ny + 1) * sizeof (double));

  if (h->yrange == 0)
    {
      free (h->xrange);
      free (h);		/* exception in constructor, avoid memory leak */

      GSL_ERROR_VAL ("failed to allocate space for histogram2d y ranges",
			GSL_ENOMEM, 0);
    }

  h->bin = (double *) malloc (nx * ny * sizeof (double));

  if (h->bin == 0)
    {
      free (h->xrange);
      free (h->yrange);
      free (h);		/* exception in constructor, avoid memory leak */

      GSL_ERROR_VAL ("failed to allocate space for histogram bins",
			GSL_ENOMEM, 0);
    }

  h->nx = nx;
  h->ny = ny;

  return h;
}

gsl_histogram2d *
gsl_histogram2d_calloc_uniform (const size_t nx, const size_t ny,
				const double xmin, const double xmax,
				const double ymin, const double ymax)
{
  gsl_histogram2d *h;

  if (xmin >= xmax)
    {
      GSL_ERROR_VAL ("xmin must be less than xmax", GSL_EINVAL, 0);
    }

  if (ymin >= ymax)
    {
      GSL_ERROR_VAL ("ymin must be less than ymax", GSL_EINVAL, 0);
    }

  h = gsl_histogram2d_calloc (nx, ny);

  if (h == 0)
    {
      return h;
    }

  {
    size_t i;

    for (i = 0; i < nx + 1; i++)
      {
	h->xrange[i] = xmin + ((double) i / (double) nx) * (xmax - xmin);
      }

    for (i = 0; i < ny + 1; i++)
      {
	h->yrange[i] = ymin + ((double) i / (double) ny) * (ymax - ymin);
      }
  }

  return h;
}

gsl_histogram2d *
gsl_histogram2d_calloc (const size_t nx, const size_t ny)
{
  gsl_histogram2d *h;

  if (nx == 0)
    {
      GSL_ERROR_VAL ("histogram2d length nx must be positive integer",
			GSL_EDOM, 0);
    }

  if (ny == 0)
    {
      GSL_ERROR_VAL ("histogram2d length ny must be positive integer",
			GSL_EDOM, 0);
    }

  h = (gsl_histogram2d *) malloc (sizeof (gsl_histogram2d));

  if (h == 0)
    {
      GSL_ERROR_VAL ("failed to allocate space for histogram2d struct",
			GSL_ENOMEM, 0);
    }

  h->xrange = (double *) malloc ((nx + 1) * sizeof (double));

  if (h->xrange == 0)
    {
      free (h);		/* exception in constructor, avoid memory leak */

      GSL_ERROR_VAL ("failed to allocate space for histogram2d x ranges",
			GSL_ENOMEM, 0);
    }

  h->yrange = (double *) malloc ((ny + 1) * sizeof (double));

  if (h->yrange == 0)
    {
      free (h->xrange);
      free (h);		/* exception in constructor, avoid memory leak */

      GSL_ERROR_VAL ("failed to allocate space for histogram2d y ranges",
			GSL_ENOMEM, 0);
    }

  h->bin = (double *) malloc (nx * ny * sizeof (double));

  if (h->bin == 0)
    {
      free (h->xrange);
      free (h->yrange);
      free (h);		/* exception in constructor, avoid memory leak */

      GSL_ERROR_VAL ("failed to allocate space for histogram bins",
			GSL_ENOMEM, 0);
    }

  {
    size_t i;

    for (i = 0; i < nx + 1; i++)
      {
	h->xrange[i] = i;
      }

    for (i = 0; i < ny + 1; i++)
      {
	h->yrange[i] = i;
      }

    for (i = 0; i < nx * ny; i++)
      {
	h->bin[i] = 0;
      }
  }

  h->nx = nx;
  h->ny = ny;

  return h;
}

void
gsl_histogram2d_free (gsl_histogram2d * h)
{
  free (h->xrange);
  free (h->yrange);
  free (h->bin);
  free (h);
}

int
gsl_histogram2d_set_ranges_uniform (gsl_histogram2d * h,
                                    double xmin, double xmax,
                                    double ymin, double ymax)
{
  size_t i;
  const size_t nx = h->nx, ny = h->ny;

  if (xmin >= xmax)
    {
      GSL_ERROR_VAL ("xmin must be less than xmax", GSL_EINVAL, 0);
    }

  if (ymin >= ymax)
    {
      GSL_ERROR_VAL ("ymin must be less than ymax", GSL_EINVAL, 0);
    }

  /* initialize ranges */

  for (i = 0; i <= nx; i++)
    {
      h->xrange[i] = xmin + ((double) i / (double) nx) * (xmax - xmin);
    }

  for (i = 0; i <= ny; i++)
    {
      h->yrange[i] = ymin + ((double) i / (double) ny) * (ymax - ymin);
    }

  /* clear contents */

  for (i = 0; i < nx * ny; i++)
    {
      h->bin[i] = 0;
    }

  return GSL_SUCCESS;
}

int
gsl_histogram2d_set_ranges (gsl_histogram2d * h,
                            const double xrange[], size_t xsize,
                            const double yrange[], size_t ysize)
{
  size_t i;
  const size_t nx = h->nx, ny = h->ny;

  if (xsize != (nx + 1))
    {
      GSL_ERROR_VAL ("size of xrange must match size of histogram",
                     GSL_EINVAL, 0);
    }

  if (ysize != (ny + 1))
    {
      GSL_ERROR_VAL ("size of yrange must match size of histogram",
                     GSL_EINVAL, 0);
    }

  /* initialize ranges */

  for (i = 0; i <= nx; i++)
    {
      h->xrange[i] = xrange[i];
    }

  for (i = 0; i <= ny; i++)
    {
      h->yrange[i] = yrange[i];
    }

  /* clear contents */

  for (i = 0; i < nx * ny; i++)
    {
      h->bin[i] = 0;
    }

  return GSL_SUCCESS;
}


#undef FP_T
#undef FP_ID
#undef VECTOR_T
#undef VECTOR_ID
#undef MATRIX_T
#undef MATRIX_ID

#ifdef GSL_FLOAT
#define MATLAB_NAMESPACE matlab_float
#define BCT_NAMESPACE bct_float
#define FP_T float
#define FP_ID(id) id##_##float
#define VECTOR_T gsl_vector_float
#define VECTOR_ID(id) gsl_vector_float##_##id
#define MATRIX_T gsl_matrix_float
#define MATRIX_ID(id) gsl_matrix_float##_##id
#include <gsl/gsl_matrix_float.h>
#include <gsl/gsl_vector_float.h>
#endif

#ifdef GSL_DOUBLE
#define MATLAB_NAMESPACE matlab
#define BCT_NAMESPACE bct
#define FP_T double
#define FP_ID(id) id##_##double
#define VECTOR_T gsl_vector
#define VECTOR_ID(id) gsl_vector##_##id
#define MATRIX_T gsl_matrix
#define MATRIX_ID(id) gsl_matrix##_##id
#include <gsl/gsl_matrix.h>
#include <gsl/gsl_vector.h>
#endif

#ifdef GSL_LONG_DOUBLE
#define MATLAB_NAMESPACE matlab_long_double
#define BCT_NAMESPACE bct_long_double
#define FP_T long double
#define FP_ID(id) id##_##long_double
#define VECTOR_T gsl_vector_long_double
#define VECTOR_ID(id) gsl_vector_long_double##_##id
#define MATRIX_T gsl_matrix_long_double
#define MATRIX_ID(id) gsl_matrix_long_double##_##id
#include <gsl/gsl_matrix_long_double.h>
#include <gsl/gsl_vector_long_double.h>
#endif


#ifndef _OPTIMIZE_STATE_RECONSTRUCTOR_GSL_H_
#define _OPTIMIZE_STATE_RECONSTRUCTOR_GSL_H_

using namespace std;

#include <armadillo>
using namespace arma;

#include "rate_model.h"
#include "state_reconstructor.h"

#include <gsl/gsl_vector.h>

class OptimizeStateReconstructor{
private:
    RateModel * rm;
    StateReconstructor * sr;
    mat * free_variables;
    int nfree_variables;
    int maxiterations;
    double stoppingprecision;

    double GetLikelihoodWithOptimized(const gsl_vector * variables);
    static double GetLikelihoodWithOptimized_gsl(const gsl_vector * variables, void *obj);

public:
    OptimizeStateReconstructor(RateModel *,StateReconstructor *, mat *, int);
    mat optimize();
};

#endif /* _OPTIMIZE_STATE_RECONSTRUCTOR_GSL_H_ */


/**
  * THE BIG PICTURE
  *
  * This file:
  * 1) (libmtm.a, actually) loads and parses the input matrix
  * 2) iterates through a sequence of feature pairs specified in one of
  *    a variety of ways
  * 3) for each pair it calls a high-level analysis method that selects
  *    and executes an appropriate covariate analysis.
  * 4) routes the analysis results to either
  *    a) immediate output using a specified formatter or
  *    b) a cache to be post-processed (for FDR control) and subsequently
  *       output.
  *
  * Implementation notes:
  *   1) If row labels are present then, by default, they are parsed to
  *      infer the statistical class of the row. Moreover, the parser is
  *      one for "TCGA" format by default. This is so that Sheila et al.'s
  *      scripts need not pass an option for something they consider
  *      "standard." In order to minimize the danger of mis-interpreted
  *      row labels a conservative definition is used (by the
  *      mtm_sclass_by_prefix function). The first two characters of the row
  *      label must match /[BCDFNO][[:punct:]]/.
  *      Otherwise, mtm_sclass_by_prefix returns MTM_STATCLASS_UNKNOWN,
  *      and the class is inferred from the data content of the row.
  * Audit:
  *   1) All error exits return -1. When used as webservice proper status
  *      returns is the least we can do...
  *   2) stdout is ONLY used for data output (at verbosity 0)
  *   3) Analysis failures (because of degeneracy) still return something
  *      the web service can deal with. Striving for data-as-error,
  *      instead of a separate error channel.
  *   4) Insure mtm_resort is called before named rows are used.
  *   5) Every statistical test must fully initialize 1st 4 members of
  *      struct Statistic
  *   6) Casts, ALL casts!
  */

#include <stdio.h>
#include <stdlib.h>
#include <errno.h>
#include <string.h>
#include <time.h>
#include <math.h>
#include <signal.h>
#include <time.h>
#include <sys/types.h>
#include <sys/stat.h>
#include <unistd.h>
#include <getopt.h>
#include <stdbool.h>
#include <assert.h>
#include <ctype.h>
#include <err.h>
#include <alloca.h>

#include <gsl/gsl_errno.h>

#include "mtmatrix.h"
#include "mtheader.h"
#include "mtsclass.h"
#include "mterror.h"
#include "featpair.h"
#include "stattest.h"
#include "analysis.h"
#include "varfmt.h"
#include "fixfmt.h"
#include "limits.h"
#include "version.h"

#ifdef HAVE_LUA
#include "lua.h"
#include "lauxlib.h"
#include "lualib.h"
#endif

/***************************************************************************
 * externs
 */

extern int mtm_sclass_by_prefix( const char *token );

extern int get_base10_ints( FILE *fp, int *index, int n );

/***************************************************************************
 * Globals & statics
 */

static const char *MAGIC_SUFFIX         = "-www";
static const char *MAGIC_FORMAT_ID_STD  = "std";
static const char *MAGIC_FORMAT_ID_TCGA = "tcga";

static const char *TYPE_PARSER_INFER    = "auto";

const char *AUTHOR_EMAIL = "rkramer@systemsbiology.org";

/**
  * False Discovery Rate control state.
  */

static double arg_q_value = 0.0;
#define USE_FDR_CONTROL (arg_q_value > 0.0)

/**
  * This is used simply to preclude bloating the FDR cache with results
  * that can't possibly be relevant to the final BH-calculated p-value
  * threshold for FDR.
  * I'm setting this high for safety since it's just an optimization, but
  * it could probably be MUCH smaller.
  */
static double opt_fdr_cache_threshold = 0.5;

// No default on opt_script because looking for a "default.lua" script
// or any *.lua file invites all sorts of confusion with the defaults
// and precedence of other row selection methods.
static const char *opt_script          = NULL;
static bool        opt_header          = true;
static bool        opt_row_labels      = true;
static const char *opt_type_parser     = NULL;
static const char *opt_preproc_matrix  = NULL; // ...or optarg
static       char *opt_single_pair     = NULL; // non-const because it's split

static const char *opt_pairlist_source = NULL;

static const char *NO_ROW_LABELS       = "matrix has no row labels";
static bool        opt_by_name         = false;
#ifdef HAVE_LUA
static const char *DEFAULT_COROUTINE   = "pair_generator";
#endif
static const char *opt_coroutine       = NULL;
static bool        opt_dry_run         = false;
static const char *opt_format          = "tcga";
static bool     opt_warnings_are_fatal = false;

/**
  * Primary output and critical error messages.
  */
#define V_ESSENTIAL (1)

/**
  * Non-critical information that may, nonetheless, be helpful.
  */
#define V_WARNINGS  (2)

/**
  * Purely informational.
  */
#define V_INFO      (3)

static int opt_verbosity = V_ESSENTIAL;

#ifdef _DEBUG
static bool  dbg_silent               = false;
#endif

#define GLOBAL
GLOBAL unsigned  arg_min_cell_count   = 5;
GLOBAL unsigned  arg_min_mixb_count   = 1;
GLOBAL unsigned  arg_min_sample_count = 2; // < 2 NEVER makes sense
#undef  GLOBAL

static const char *opt_na_regex       = NULL; // must be initialized in main

static double      opt_p_value        = 1.0;

/**
  * Eventually it is (was) intended to support delegating row label
  * interpretation--in particular inference of a row's statistical class
  * based on its row label--to a user-provided Lua function.
  * Currently, only the default interpreter built into libmtm is actually
  * supported, which interprets row labels according to "ISB conventions."
  */
static MTM_ROW_LABEL_INTERPRETER _interpret_row_label = mtm_sclass_by_prefix;

static unsigned opt_status_mask       = COVAN_E_MASK;

#ifdef HAVE_LUA
static lua_State *_L = NULL;
/**
  * Delegate inference of a row's statistical class to a user-provided
  * function.
  */
int _lua_statclass_inference( const char *label ) {
	fprintf( stderr, "interpret %s\n", label );
	return MTM_STATCLASS_UNKNOWN;
}

static void _freeLua() {
	lua_close( _L );
}

/**
  * <source> may be literal Lua code or a filename reference.
  */
static int _load_script( const char *source, lua_State *state ) {

	struct stat info;
	return (access( source, R_OK ) == 0) && (stat( source, &info ) == 0)
		? luaL_dofile(   state, source )
		: luaL_dostring( state, source );
}

#endif

static FILE *_fp_output = NULL;
static void (*_emit)( EMITTER_SIG ) = format_tcga;

static bool _sigint_received = false;

/**
  * Records the number of pairwise tests COMPLETED WITHOUT ERROR
  * but not emitted (because they didn't pass the p-value threshold
  * for emission.
  *
  * This is NOT used when FDR control is active in pairwise; rather it is
  * for use in FDR control calculations *outside* the context of pairwise.
  *
  * Note that the total number of tests *attempted* is *not* separately
  * counted because it is assumed that that is known to the caller who
  * set up the run, after all.
  */
static unsigned _insignificant = 0;
static unsigned _untested      = 0;

/**
  * The binary matrix is accessed at runtime through this variable.
  * Notice, in particular, that the analysis code (analysis.cpp)
  * only has access to pairs of rows, NOT the whole matrix.
  * The matrix' structure and implementation is strictly encapsulated
  * within this file, and code in here dolls out just what analysis
  * requires: row pairs.
  */
static struct mtm_matrix _matrix;

static void _freeMatrix( void ) {
	_matrix.destroy( &_matrix );
}

static void _interrupt( int n ) {
	_sigint_received = true;
}

/***************************************************************************
 * Pipeline
 * A) explicit pairs
 *    1. row pair -> analysis -> filtering -> output
 * B) all-pairs or Lua generated pair lists
 *    1. row pair -> analysis -> filtering -> output
 *    2. row pair -> analysis -> fdr aggregation -> re-processing ->output
 */

/**
  * Analysis results on feature pairs are passed EITHER to:
  * 1. an emitter for immediate output (single pair only)
  * 2. a filter (and then possibly to an emitter)
  * 3. an aggregator (to be filtered and stored for later emission)
  *
  * All three of these methods must have the same signature.
  */
#define ANALYSIS_FN_SIG const struct feature_pair *pair

typedef void (*ANALYSIS_FN)( ANALYSIS_FN_SIG );

/***************************************************************************
 * Encapsulates all the decision making regarding actual emission of
 * results.
 */
static void _filter( ANALYSIS_FN_SIG ) {

	struct CovariateAnalysis covan;
	memset( &covan, 0, sizeof(covan) );
	covan_exec( pair, &covan );

	// One last thing to check before filtering to insure corner cases
	// don't fall through the following conditionals....

	if( ! ( isfinite( covan.result.probability ) && fpclassify( covan.result.probability ) != FP_SUBNORMAL ) ) {
		covan.result.probability = 1.0;
		covan.status             = COVAN_E_MATH;
		// The assumption is that if a NaN shows up in the result, it was
		// triggered by an un"pre"detected degeneracy, and so the pair was
		// in fact untestable (how it will be interpreted below).
	}

#ifdef _DEBUG
	if( ! dbg_silent ) {
#endif

		if( ( covan.status & opt_status_mask ) == 0 ) {
			if( covan.result.probability <= opt_p_value )
				_emit( pair, &covan, _fp_output );
			else
				_insignificant += 1;
		} else
			_untested += 1;

#ifdef _DEBUG
	}
#endif
}

static ANALYSIS_FN _analyze = _filter;

static void _error_handler(const char * reason,
                        const char * file,
                        int line,
                        int gsl_errno) {
	fprintf( stderr,
		"#GSL error(%d): %s\n"
		"#GSL error  at: %s:%d\n",
		gsl_errno, reason, file, line );
}

static FILE *_fdr_cache_fp = NULL;

/***************************************************************************
  * FDR processing
  * This currently involves some redundant computation in the interest of
  * simplicity. Since the whole point of FDR is to limit output, though, the
  * actual runtime cost should be bearabe. Specifically...
  *
  * 1. Two passes are made over the (selected) pairs.
  * 2. The offsets and p-value of the result of the first pass are cached
  *    in a tmp file.
  * 3. After completion, the p-value appropriate for the given q-value is
  *    determined and results from the 1st pass with sufficiently low
  *    p-values are recalculated and, this time, fully emitted.
  *
  * TODO: Optimization: Pairs with very high p-values (i.e. *clearly*
  * uninteresting pairs) can be omitted from the cache even in the first
  * pass and merely counted as tests since their recomputation will *almost*
  * certainly, depending ultimately on the threshold, not be required.
  */

struct FDRCacheRecord {
	double p;
	unsigned a,b;
} __attribute__((packed));
typedef struct FDRCacheRecord FDRCacheRecord_t;
typedef const FDRCacheRecord_t FDRCACHERECORD_T;

static int _cmp_fdr_cache_records( const void *pvl, const void *pvr ) {

	FDRCACHERECORD_T *l = (FDRCACHERECORD_T*)pvl;
	FDRCACHERECORD_T *r = (FDRCACHERECORD_T*)pvr;

	if( l->p == r->p )
		return  0;
	else
		return (l->p < r->p) ? -1 : +1;
}

static int _fdr_uncached_count = 0;

/**
  * Analyze the pair and cache just the offsets and p-value of the result
  * for possible recalculation during post-processing--after FDR control
  * has calculated an appropriate p-value threshold from the q-value.
  */
static void _fdr_cache( ANALYSIS_FN_SIG ) {

	struct CovariateAnalysis covan;
	memset( &covan, 0, sizeof(covan) );

	covan_exec( pair, &covan );

	// Failed tests (for reasons of one kind of degeneracy or another)
	// do not contribute to the calculation of the p-value threshold.

	if( covan.status == 0
		&& isfinite( covan.result.probability ) ) {

		// ...then, whatever the p-value, the test was at least
		// successfully *executed*.

		if( covan.result.probability <= opt_fdr_cache_threshold ) {
			struct FDRCacheRecord rec = {
				.p = covan.result.probability,
				.a = pair->l.offset,
				.b = pair->r.offset
			};
			fwrite( &rec, sizeof(rec), 1, _fdr_cache_fp );
		} else
			_fdr_uncached_count += 1;
	}
}

/**
  * This implements the Benjamini-Hochberg algorithm as described on
  * page 49 of "Large-Scale Inference", Bradley Efron, Cambridge.
  * "...for a fixed value of q in (0,1), let i_max be the largest
  *  index for which
  *                     p_(i) <= (i/N)q
  *
  *  ...and reject H_{0(i)}, the null hypothesis corresponding to
  *  p_(i), if
  *                         i <= i_max,
  *
  *  ...accepting H_{0(i)} otherwise."
  *
  * [...And i is 1-based in this notation!]
  */
static void _fdr_postprocess( FILE *cache, double Q, FILE *final_output, bool minimal_output ) {

	const unsigned CACHED_COUNT
		= ftell( cache ) / sizeof(struct FDRCacheRecord);
	const unsigned TESTED_COUNT
		= CACHED_COUNT
		+ _fdr_uncached_count;

	struct FDRCacheRecord *prec, *sortbuf
		= calloc( CACHED_COUNT, sizeof(struct FDRCacheRecord) );

	const double RATIO
		= Q/TESTED_COUNT;
	int i = 0;

	// Load and sort the cached test records...

	rewind( cache );
	fread( sortbuf, sizeof(struct FDRCacheRecord), CACHED_COUNT, cache );
	qsort( sortbuf, CACHED_COUNT, sizeof(struct FDRCacheRecord), _cmp_fdr_cache_records );

	// ...and recompute the full statistics of all earlier tests that
	// pass the now-established p-value threshold.

	prec = sortbuf;
	if( minimal_output ) {

		while( prec->p <= (i+1)*RATIO && i < CACHED_COUNT)
			fprintf( final_output, "%d\t%d\t%.3e\n", prec->a, prec->b, prec->p );

	} else {

		while( prec->p <= (i+1)*RATIO && i < CACHED_COUNT) {

			struct feature_pair fpair;
			struct CovariateAnalysis covan;
			memset( &covan, 0, sizeof(covan) );

			fpair.l.offset = prec->a;
			fpair.r.offset = prec->b;
			fetch_by_offset( &_matrix, &fpair );

			covan_exec( &fpair, &covan );

			// At this point emission is unconditional; FDR control has
			// already filtered all that will be filtered...

			_emit( &fpair, &covan, final_output );

			if( _sigint_received ) {
				time_t now = time(NULL);
				fprintf( stderr, "# FDR postprocess interrupted @ %s", ctime(&now) );
				break;
			}

			prec += 1;
			i    += 1;
		}
	}

	// However, the preceding loop exited

	if( opt_verbosity >= V_WARNINGS ) {
		if( i > 0 )
			fprintf( final_output, "# max p-value %.3f\n", sortbuf[i-1].p );
		else
			fprintf( final_output, "# no values passed FDR control\n" );
	}
	if( sortbuf )
		free( sortbuf );
}

/***************************************************************************
  * Row selection iterators
  * Each of these 5 methods takes arguments specific to the
  * source of input pairs and uses file static state for output.
  * All but the first delegate to the _analyze function which may be a
  * filter on immediate-mode output or a caching function for FDR.
  */

// BEGIN:RSI

static int /*ANCP*/ _analyze_cross_product(
		const struct mtm_matrix_header *hdr, FILE *fp[] ) {

	bool completed = true;
	struct feature_pair fpair;
	struct mtm_row *rrid;

	/**
	  * Location of left data won't change: same buffer, same offset for
	  * duration of iteration.
	  */
	fpair.l.data
		= calloc( _matrix.columns, sizeof(mtm_int_t) );

	/**
	  * TODO: I actually could enumerate the disk-resident matrix'
	  * row names just as I do the descriptors. In general, the
	  * pervasive assumption throughout this source that the input
	  * is exactly one matrix needs to be revisited.
	  */
	fpair.l.name = NULL;

	if( fpair.l.data == NULL )
		return -1;

	assert( ! _matrix.lexigraphic_order /* should be row order */ );

	for(fpair.l.offset = 0;
		fpair.l.offset < hdr->rows;
		fpair.l.offset++ ) {

		/**
		  * Read the "left" feature's data and descriptor
		  */

		if( fread( (void*)fpair.l.data, sizeof(mtm_int_t), hdr->columns,  fp[0] ) != hdr->columns )
			break;
		if( fread( &fpair.l.desc, sizeof(struct mtm_descriptor), 1, fp[1] ) != 1 )
			break;

		/**
		  * RAM-resident matrix is *fully* reset for each row of disk-
		  * resident matrix...
		  */

		fpair.r.data = _matrix.data;
		rrid         = _matrix.row_map; // may be NULL

		for(fpair.r.offset = 0;
			fpair.r.offset < _matrix.rows;
			fpair.r.offset++ ) {

			fpair.r.name = rrid ? rrid->string : "";
			fpair.r.desc = _matrix.desc[ fpair.r.offset ];

			_analyze( &fpair );

			if( _sigint_received ) {
				time_t now = time(NULL);
				fprintf( stderr, "# main analysis loop interrupted @ %s", ctime(&now) );
				completed = false;
				break;
			}

			fpair.r.data += _matrix.columns;
			if( rrid ) rrid += 1;

		} // inner for
	}

	if( ferror( fp[0] ) || ferror( fp[1] ) ) {
		warn( "reading row %d of preprocessed matrix", fpair.l.offset );
		completed = false;
	}

	if( fpair.l.data )
		free( (void*)fpair.l.data );

	return completed ? 0 : -1;
}

static bool _is_integer( const char *pc ) {
	while( *pc ) if( ! isdigit(*pc++) ) return false;
	return true;
}

static int _analyze_single_pair( const char *csv, const bool HAVE_ROW_LABELS ) {

	static const char *MISSING_MSG
		= "you specified row %s for a matrix without row names.\n";

	int econd;
	char *right, *left = alloca( strlen(csv)+1 );
	struct CovariateAnalysis covan;
	struct feature_pair pair;

	memset( &pair,  0, sizeof(pair) );
	memset( &covan, 0, sizeof(covan) );

	// Split the string in two...

	strcpy( left, csv );
	right = strchr( left, ',' );
	if( NULL == right )
		errx( -1, "missing comma separator in feature pair \"%s\"", left );
	*right++ = '\0';

	// Lookup each part.(They need not be the same format.)

	if( _is_integer( left ) ) {
		pair.l.offset = atoi( left );
		mtm_resort_rowmap( &_matrix, MTM_RESORT_BYROWOFFSET );
		econd = mtm_fetch_by_offset( &_matrix, &(pair.l) );
	} else
	if( HAVE_ROW_LABELS ) {
		pair.l.name   = left;
		if( mtm_resort_rowmap( &_matrix, MTM_RESORT_LEXIGRAPHIC ) )
			errx( -1, NO_ROW_LABELS );
		econd = mtm_fetch_by_name( &_matrix, &(pair.l) );
	} else
		errx( -1, MISSING_MSG, left );

	if( _is_integer( right ) ) {
		pair.r.offset = atoi( right );
		mtm_resort_rowmap( &_matrix, MTM_RESORT_BYROWOFFSET );
		econd = mtm_fetch_by_offset( &_matrix, &(pair.r) );
	} else
	if( HAVE_ROW_LABELS ) {
		pair.r.name = right;
		if( mtm_resort_rowmap( &_matrix, MTM_RESORT_LEXIGRAPHIC ) )
			errx( -1, NO_ROW_LABELS );
		econd = mtm_fetch_by_name( &_matrix, &(pair.r) );
	} else
		errx( -1, MISSING_MSG, right );

	covan_exec( &pair, &covan );

	_emit( &pair, &covan, _fp_output );

	return 0;
}

static int /*ANAM*/ _analyze_named_pair_list( FILE *fp ) {

	struct feature_pair fpair;

	size_t blen = 0;
	ssize_t llen;
	char *right, *left = NULL;

	while( ( llen = getline( &left, &blen, fp ) ) > 0 ) {

		// Trim off the newline char.

		if( left[llen-1] == '\n' )
			left[--llen] = '\0'; // Strip the NL

		// Parse the two names out of the line.

		right = strchr( left, '\t' );
		if( right )
			*right++ = '\0';
		else {
			fprintf( stderr, "error: no tab found in '%s'.\n", left );
			if( opt_warnings_are_fatal )
				break;
			else
				continue; // no reason we -can't- continue
		}

		fpair.l.name  = left;
		fpair.r.name = right;

		if( fetch_by_name( &_matrix, &fpair ) ) {

			warnx( "error: one or both of...\n"
				"\t1) %s\n"
				"\t2) %s\n"
				"\t...not found.\n",
				fpair.l.name,
				fpair.r.name );
			if( opt_warnings_are_fatal )
				break;
			else
				continue; // no reason we -can't- continue
		} else
			_analyze( &fpair );
	}

	if( left )
		free( left );

	return 0;
}

static int /*ANUM*/ _analyze_pair_list( FILE *fp ) {

	struct feature_pair fpair;

	int arr[2];

	while( get_base10_ints( fp, arr, 2 ) == 2 ) {

		fpair.l.offset = arr[0];
		fpair.r.offset = arr[1];

		if( fetch_by_offset( &_matrix, &fpair ) ) {
			warnx( "error: one of row indices (%d,%d) not in [0,%d)\n"
				"\tjust before byte offset %ld in the stream.\n"
				"\tAborting...\n",
				fpair.l.offset,
				fpair.r.offset,
				_matrix.rows,
				ftell( fp ) );
			if( opt_warnings_are_fatal )
				break;
			else
				continue; // no reason we -can't- continue
		} else
			_analyze( &fpair );
	}
	return 0;
}

#ifdef HAVE_LUA
static int /*ALUA*/ _analyze_generated_pair_list( lua_State *state ) {

	struct feature_pair fpair;
	int isnum, lua_status;

	lua_getglobal( _L, opt_coroutine );

	assert( ! lua_isnil( _L, -1 ) /* because it was checked early */ );

	do {

		lua_pushnumber( _L, _matrix.rows );
		lua_status = lua_resume( _L, NULL, 1 );

		if( lua_status == LUA_YIELD ) {

			fpair.r.offset = lua_tonumberx( _L, -1, &isnum );
			fpair.l.offset = lua_tonumberx( _L, -2, &isnum );
			lua_pop( _L, 2 );

			if( fetch_by_offset( &_matrix, &fpair ) ) {
				warnx( "one or both of %s-generated row indices (%d,%d) not in [0,%d)\n",
					opt_coroutine,
					fpair.l.offset,
					fpair.r.offset,
					_matrix.rows );
				if( opt_warnings_are_fatal )
					break;
				else
					continue; // no reason we -can't- continue
			} else
				_analyze( &fpair );

		} else
		if( lua_status == LUA_OK )
			break;
		else { // some sort of error occurred.
			fputs( lua_tostring( _L, -1 ), stderr );
		}

		if( _sigint_received ) {
			time_t now = time(NULL);
			fprintf( stderr, "analysis loop interrupted @ %s", ctime(&now) );
			break;
		}

	} while( lua_status == LUA_YIELD );

	return 0;
}
#endif

/**
  * This clause serves the primary use case motivating this
  * application: FAST, EXHAUSTIVE (n-choose-2) pairwise analysis.
  * As a result, the coding of this iteration schema is quite
  * different from the others. In particular:
  * 1. Since I -know- the order of feature pair evaluation I can
  *    preclude lots of useless work by entirely skipping outer loop
  * features with univariate degeneracy. This isn't feasible in
  * the other iteration sc
  * I'm dispensing with "pretty" and doing the
  * pointer arithmetic locally to eek out maximum possible speed.
  * In particular, I set up lots of ptrs below to obviate
  * redundant pointer arithmetic--only do fixed additions.
  */
static int /*AALL*/ _analyze_all_pairs( void ) {

	bool completed = true;
	struct feature_pair fpair;

	struct mtm_row *lrid, *rrid;

	assert( ! _matrix.lexigraphic_order /* should be row order */ );

	fpair.l.data = _matrix.data;
	lrid         = _matrix.row_map; // may be NULL

	for(fpair.l.offset = 0;
		fpair.l.offset < _matrix.rows;
		fpair.l.offset++ ) {

		fpair.l.name = lrid ? lrid->string : "";
		fpair.l.desc = _matrix.desc[ fpair.l.offset ];

		fpair.r.data = fpair.l.data + _matrix.columns;
		rrid = lrid ? lrid + 1 : NULL;

		for(fpair.r.offset = fpair.l.offset+1;
			fpair.r.offset < _matrix.rows;
			fpair.r.offset++ ) {

			fpair.r.name = rrid ? rrid->string : "";
			fpair.r.desc = _matrix.desc[ fpair.r.offset ];

			_analyze( &fpair );

			if( _sigint_received ) {
				time_t now = time(NULL);
				fprintf( stderr, "# main analysis loop interrupted @ %s", ctime(&now) );
				completed = false;
				break;
			}

			fpair.r.data += _matrix.columns;
			if( rrid ) rrid += 1;

		} // inner for

		fpair.l.data += _matrix.columns;
		if( lrid ) lrid += 1;
	}
	return completed ? 0 : -1;
}

// END:RSI

/**
  * Initializations for which static initialization can't/shouldn't
  * be relied upon. Common to executable and Python extension.
  */
static void _jit_initialization( void ) {
	opt_na_regex = mtm_default_NA_regex;
	memset( &_matrix,  0, sizeof(struct mtm_matrix) );
	gsl_set_error_handler( _error_handler );
}

/***************************************************************************
  * Online help
  */

static const char *_YN( bool y ) {
	return y ? "yes" : "no";
}

#define USAGE_SHORT false
#define USAGE_LONG  true

static void _print_usage( const char *exename, FILE *fp, bool exhaustive ) {

	extern const char *USAGE_UNABRIDGED;
	extern const char *USAGE_ABRIDGED;

	char debug_state[64];
	debug_state[0] = 0;
#ifdef _DEBUG
	sprintf( debug_state, "(DEBUG) Compiled %s %s", __DATE__,__TIME__ );
#endif

	if( exhaustive )
		fprintf( fp, USAGE_UNABRIDGED,
			exename, VER_MAJOR, VER_MINOR, VER_PATCH, VER_TAG, debug_state,
			exename,
			exename,
			TYPE_PARSER_INFER,
			opt_na_regex,
#ifdef HAVE_LUA
			DEFAULT_COROUTINE,
#endif
			arg_min_cell_count,
			arg_min_mixb_count,
			arg_min_sample_count,

			opt_p_value,
			opt_status_mask,
			opt_format,
			MAGIC_FORMAT_ID_STD, MAGIC_FORMAT_ID_TCGA,
			_YN(opt_warnings_are_fatal),
			opt_verbosity,
			MAGIC_SUFFIX,
			MAX_CATEGORY_COUNT,
			MTM_MAX_MISSING_VALUES,
			AUTHOR_EMAIL );
	else
		fprintf( fp, USAGE_ABRIDGED,
			exename, VER_MAJOR, VER_MINOR, VER_PATCH, VER_TAG, debug_state,
			exename,
			opt_p_value,
		  	AUTHOR_EMAIL );
}

int main( int argc, char *argv[] ) {

	int exit_status = EXIT_SUCCESS;

	const char *i_file = NULL;
	const char *o_file = NULL;
	FILE *fp           = NULL;

	if( argc < 2 ) { // absolute minimum args: <executable name> <input matrix>
		_print_usage( argv[0], stdout, USAGE_SHORT );
		exit( EXIT_SUCCESS );
	}

	_jit_initialization();

	do {

		static const char *CHAR_OPTIONS
#ifdef HAVE_LUA
			= "s:hrt:N:C:P:n:x:c:DM:p:f:q:v:?X";
#else
			= "hrt:N:C:P:n:x:DM:p:f:q:v:?X";
#endif

		static struct option LONG_OPTIONS[] = {
#ifdef HAVE_LUA
			{"script",        required_argument,  0,'s'},
#endif
			{"no-header",     no_argument,        0,'h'},
			{"no-row-labels", no_argument,        0,'r'},
			{"type-parser",   required_argument,  0,'t'},
			{"na-regex",      required_argument,  0,'N'},

			{"crossprod",     required_argument,  0,'C'},
			{"pair",          required_argument,  0,'P'},
			{"by-name",       required_argument,  0,'n'},
			{"by-index",      required_argument,  0,'x'},
#ifdef HAVE_LUA
			{"coroutine",     required_argument,  0,'c'},
#endif
			{"dry-run",       no_argument,        0,'D'},

			{"min-ct-cell",   required_argument,  0, 256 }, // no short equivalents
			{"min-mx-cell",   required_argument,  0, 257 }, // no short equivalents
			{"min-samples",   required_argument,  0,'M'},

			{"p-value",       required_argument,  0,'p'},
			{"format",        required_argument,  0,'f'},
			{"fdr",           required_argument,  0,'q'},
			{"verbosity",     required_argument,  0,'v'},
#ifdef _DEBUG
			{"debug",         required_argument,  0, 258 }, // no short equivalents
#endif
			{"help",          no_argument,        0,'?'},
			{ NULL,           0,                  0, 0 }
		};

		int arg_index = 0;
		const int c
			= getopt_long( argc, argv, CHAR_OPTIONS, LONG_OPTIONS, &arg_index );

		switch (c) {

		case 's': // script
			opt_script      = optarg;
			break;
		case 'h': // no-header
			opt_header      = false;
			break;
		case 'r': // no-row-labels
			opt_row_labels  = false;
			break;
		case 't': // type-parser
			opt_type_parser = optarg;
			break;
		case 'N': // na-regex
			opt_na_regex    = optarg;
			break;
		case 'C': // cross-product of matrices
			opt_preproc_matrix = optarg;
			break;
		case 'P': // pair
			opt_single_pair = optarg;
			break;
		case 'n': // by-name
			opt_pairlist_source = optarg;
			opt_by_name         = true;
			break;
		case 'x': // by-index
			opt_pairlist_source = optarg;
			opt_by_name         = false;
			break;
		case 'c': // coroutine
			opt_coroutine       = optarg;
			break;
		case 'D': // dry-run
			opt_dry_run         = true;
			break;

		////////////////////////////////////////////////////////////////////
		case 256: // ...because I haven't defined a short form for this
			arg_min_cell_count = atoi( optarg );
			break;

		case 257: // ...because I haven't defined a short form for this
			arg_min_mixb_count = atoi( optarg );
			break;

		case 'M':
			arg_min_sample_count = atoi( optarg );
			if( arg_min_sample_count < 2 ) {
				warnx( "Seriously...%d samples is acceptable?\n"
					"I don't think so... ;)\n",
					arg_min_sample_count );
				exit( EXIT_FAILURE );
			}
			break;
		////////////////////////////////////////////////////////////////////

		case 'p':
			opt_p_value = atof( optarg );
			if( ! ( 0 < opt_p_value ) ) {
				warnx( "specified p-value %.3f will preclude all output.\n",
					opt_p_value );
				abort();
			} else
			if( ! ( opt_p_value < 1.0 ) ) {
				warnx( "p-value %.3f will filter nothing.\n"
					"\tIs this really what you want?\n",
					opt_p_value );
			}
			break;

		case 'J': // JSON format
		case 'f': // tabular format
			// Check for magic-value strings first
			if( strcmp( MAGIC_FORMAT_ID_STD, optarg ) == 0 )
				_emit = format_standard;
			else
			if( strcmp( MAGIC_FORMAT_ID_TCGA, optarg ) == 0 )
				_emit = format_tcga;
			else {
				const char *specifier
					= emit_config( optarg, c=='J' ? FORMAT_JSON : FORMAT_TABULAR );
				if( specifier ) {
					errx( -1, "invalid specifier \"%s\"", specifier );
				}
				_emit = emit_exec;
			}
			break;

		case 'q':
			arg_q_value = atof( optarg );
			_analyze = _fdr_cache;
			break;

		case 'v': // verbosity
			opt_verbosity = atoi( optarg );
			break;

		case '?': // help
			_print_usage( argv[0], stdout, USAGE_SHORT );
			exit( EXIT_SUCCESS );
			break;

		case 'X': // help
			_print_usage( argv[0], stdout, USAGE_LONG );
			exit( EXIT_SUCCESS );
			break;

#ifdef _DEBUG
		case 258:
			if( strchr( optarg, 'X' ) != NULL ) {
				// Turn OFF all filtering to turn on "exhaustive"
				// output mode.
				opt_status_mask = 0;
				opt_p_value     = 1.0;
			}
			dbg_silent     = strchr( optarg, 'S' ) != NULL;
			break;
#endif
		case -1: // ...signals no more options.
			break;
		default:
			printf ("error: unknown option: %c\n", c );
			exit( EXIT_FAILURE );
		}
		if( -1 == c ) break;

	} while( true );

#ifdef HAVE_LUA

	if( opt_script ) {

		/**
		  * Create a Lua state machine and load/run the Lua script from file
		  * or command line before anything else.
		  */

		_L = luaL_newstate();
		if( _L ) {
			atexit( _freeLua ); // ...so lua_close needed NOWHERE else.
			luaL_openlibs( _L );
			if( _load_script( opt_script, _L ) != LUA_OK ) {
				errx( -1, "in \"%s\": %s",
					opt_script, lua_tostring( _L,-1) );
			}
		} else
			errx( -1, "failed creating Lua statespace" );

		/**
		  * Fail early!
		  * If the user provided a coroutine name, check for its presence.
		  * Otherwise, see if the default coroutine is present.
		  * Otherwise, Lua is not being used to generate pairs.
		  */

		if( opt_coroutine ) {

			lua_getglobal( _L, opt_coroutine );
			if( lua_isnil( _L, -1 ) ) {
				errx( -1, "pair generator coroutine \"%s\" not defined in \"%s\"",
					opt_coroutine, opt_script );
			}

		} else {

			lua_getglobal( _L, DEFAULT_COROUTINE );

			if( ! lua_isnil( _L, -1 ) )
				opt_coroutine = DEFAULT_COROUTINE;

			// Non-existence of DEFAULT_COROUTINE is not an error;
			// we assume user does NOT intend Lua to generate the pairs.
		}

		lua_pop( _L, 1 ); // clean the stack

		/**
		  * Similarly verify NOW that the a specified type parser is present.
		  */
		if( opt_type_parser ) {
			lua_getglobal( _L, opt_type_parser );
			if( lua_isnil( _L, -1 ) ) {
				errx( -1, "pair generator coroutine \"%s\" not defined in \"%s\"",
					opt_type_parser, opt_script );
			}
			lua_pop( _L, 1 ); // clean the stack
		}

		/**
		  * Load Lua script and execute a dry-run if applicable.
		  * This is in advance of other argument validation since other
		  * arguments will be ignored...
		  */

		if( opt_dry_run && opt_coroutine != NULL ) {

			const int COUNT
				= getenv("DRY_RUN_COUNT")
				? atoi( getenv("DRY_RUN_COUNT") )
				: 8;

			int isnum, lua_status = LUA_YIELD;

			lua_getglobal( _L, opt_coroutine );
			if( lua_isnil( _L, -1 ) )
				errx( -1, "%s not defined (in Lua's global namespace)",
					opt_coroutine );

			while( lua_status == LUA_YIELD ) {
				lua_pushnumber( _L, COUNT );
				lua_status = lua_resume( _L, NULL, 1 );
				if( lua_status <= LUA_YIELD /* OK == 0, YIELD == 1*/ ) {
					// Only output coroutine.yield'ed values...
					if( lua_status == LUA_YIELD ) {
						const int b = lua_tonumberx( _L, -1, &isnum );
						const int a = lua_tonumberx( _L, -2, &isnum );
						lua_pop( _L, 2 );
						fprintf( stdout, "%d %d\n", a, b );
					}
				} else
					fputs( lua_tostring( _L, -1 ), stderr );
			}

			exit( EXIT_SUCCESS );
		}
	} else
	if( opt_coroutine ) {
		errx( -1, "coroutine specified (\"%s\") but no script", opt_coroutine );
	}

#endif

	/**
	  * Catch simple argument inconsistencies and fail early!
	  */

	if( opt_single_pair ) {
		if( USE_FDR_CONTROL ) {
			warnx( "FDR is senseless on a single pair.\n" );
			if( opt_warnings_are_fatal )
				abort();
			else
				arg_q_value = 0.0;
		}
	}

	/**
	  * The last two positional arguments are expected to be filenames
	  * ... <filename1>
	  */

	static const char *NAME_STDIN  = "stdin";
	static const char *NAME_STDOUT = "stdout";

	switch( argc - optind ) {

	case 0: // input MUST be stdin, output stdout
		i_file = NAME_STDIN;
		o_file = NAME_STDOUT;
		break;

	case 1:
		if( access( argv[ optind ], R_OK ) == 0 ) {
			i_file = argv[ optind++ ];
			o_file = NAME_STDOUT;
		} else {
			i_file = NAME_STDIN;
			o_file = argv[ optind++ ];
		}
		break;

	case 2:
	default:
		i_file = argv[ optind++ ];
		o_file = argv[ optind++ ];
		if( (argc-optind) > 0 && opt_verbosity >= V_ESSENTIAL ) {
			// This behavior of ignoring "extra" arguments is implemented
			// ONLY so that this executable plays nicely with a job control
			// system which uses extra command line args NOT intended for
			// the executable. TODO: Revisit this!
			fprintf( stderr,
				"warning: ignoring %d trailing positional arguments.\n", argc-optind );
			while( optind < argc )
				fprintf( stderr, "\t\"%s\"\n", argv[optind++] );
			if( opt_warnings_are_fatal )
				exit( EXIT_FAILURE );
		}
	}

	if( opt_pairlist_source != NULL
			&& strcmp( opt_pairlist_source, i_file ) == 0 ) {
		errx( -1, "error: stdin specified (or implied) for both pair list and the input matrix\n" );
	}

	/**
	  * Emit intentions...
	  */

	if( opt_verbosity >= V_INFO ) {

#define MAXLEN_FS 75

		char feature_selection[MAXLEN_FS+1];
		feature_selection[MAXLEN_FS] = 0; // insure NUL termination

		/**
		  * Following conditional cascade must exactly match the larger
		  * one below in order to accurately report feature selection method.
		  */
		if( opt_single_pair ) {
			strncpy( feature_selection, opt_single_pair, MAXLEN_FS );
		} else
		if( opt_pairlist_source ) {
			snprintf( feature_selection,
				MAXLEN_FS,
				"by %s in %s",
				opt_by_name ? "name" : "offset", opt_pairlist_source );
		} else {
#ifdef HAVE_LUA
			if( opt_coroutine )
				snprintf( feature_selection,
					MAXLEN_FS,
					"%s in %s",
					opt_coroutine, opt_script /* may be literal source */ );
			else
#endif
				strncpy( feature_selection, "all-pairs", MAXLEN_FS );
		}

		fprintf( stderr,
			"       input: %s\n"
			"      select: %s\n"
			"      output: %s\n"
#ifdef _DEBUG
			"       debug: silent: %s\n"
#endif
			,i_file,
			feature_selection,
			o_file
#ifdef _DEBUG
			, _YN( dbg_silent )
#endif
			);
	}

	/**
	  * Load the input matrix.
	  */

	fp = strcmp( i_file, NAME_STDIN )
		? fopen( i_file, "r" )
		: stdin;
	if( fp ) {

		const unsigned int FLAGS
			= ( opt_header ? MTM_MATRIX_HAS_HEADER : 0 )
			| ( opt_row_labels ? MTM_MATRIX_HAS_ROW_NAMES : 0 )
			| ( opt_verbosity & MTM_VERBOSITY_MASK);

		const int econd
			= mtm_parse( fp,
				FLAGS,
				opt_na_regex,
				MAX_CATEGORY_COUNT,
				opt_row_labels ? _interpret_row_label : NULL,
				NULL, // ...since no persistent binary matrix is needed.
				&_matrix );
		fclose( fp );

		if( econd )
			errx( -1, "mtm_parse returned (%d)", econd );
		else
			atexit( _freeMatrix );
	}

	if( opt_dry_run ) { // a second possible
		exit( EXIT_SUCCESS );
	}

	if( SIG_ERR == signal( SIGINT, _interrupt ) ) {
		warn( "failed installing interrupt handler\n"
			"\tCtrl-C will terminated gracelessly\n" );
	}

	/**
	  * Choose and open, if necessary, an output stream.
	  */

	_fp_output
		= (strcmp( o_file, NAME_STDOUT ) == 0 )
		? stdout
		: fopen( o_file, "w" );

	if( NULL == _fp_output ) {
		err( -1, "opening output file \"%s\"", o_file );
	}

	if( covan_init( _matrix.columns ) ) {
		err( -1, "error: covan_init(%d)\n", _matrix.columns );
	} else
		atexit( covan_fini );

	if( opt_verbosity >= V_INFO )
		fprintf( _fp_output, "# %d rows/features X %d columns/samples\n", _matrix.rows, _matrix.columns );

	if( USE_FDR_CONTROL ) {
		_fdr_cache_fp = tmpfile();
		_fdr_uncached_count = 0;
		if( NULL == _fdr_cache_fp )
			err( -1, "creating a temporary file" );
	}

	/**
	  * Here the main decision is made regarding feature selection.
	  * In order of precedence:
	  * 0. cross-product of matrices
	  * 1. single pair
	  * 2. explicit pairs (by name or by offset)
	  * 3. Lua-generated offsets
	  * 4. all-pairs
	  */

	if( opt_preproc_matrix ) {
		FILE *ppm[2];
		ppm[0] = fopen( opt_preproc_matrix, "r" );
		if( ppm[0] ) {

			struct mtm_matrix_header hdr;

			/**
			  * Open a second stream on the file to access the
			  * descriptor table.
			  */
			ppm[1] = fopen( opt_preproc_matrix, "r" );

			/**
			  * Read the header and verify compatibility
			  */

			if( mtm_load_header( ppm[0], &hdr ) != MTM_OK )
				err( -1, "failed reading preprocessed matrix' (%s) header",
					opt_preproc_matrix );

			// Verify file is the preprocessed matrix the user thinks it is.

			if( strcmp( hdr.sig, MTM_SIGNATURE ) )
				errx( -1, "%s has wrong signature."
					"Are you sure this is a preprocessed matrix",
					opt_preproc_matrix );

			// Verify equality of columns

			if( _matrix.columns != hdr.columns )
				errx( -1, "processed matrix has %d columns; other has %d",
					hdr.columns, _matrix.columns );

			// Skip past the header to the row data.

			if( fseek( ppm[0], hdr.section[ S_DATA ].offset, SEEK_SET ) )
				err( -1, "failed seeking to start of data" );

			// Skip to the descriptor table in the 2nd stream.

			if( fseek( ppm[1], hdr.section[ S_DESC ].offset, SEEK_SET ) )
				err( -1, "failed seeking to start of data" );

			_analyze_cross_product( &hdr, ppm );

			fclose( ppm[1] );
			fclose( ppm[0] );
		}
	} else
	if( opt_single_pair ) {

		_analyze_single_pair( opt_single_pair, opt_row_labels );

	} else
	if( opt_pairlist_source ) {

		FILE *fp
			= strcmp(opt_pairlist_source,NAME_STDIN)
			? fopen( opt_pairlist_source, "r" )
			: stdin;

		if( opt_by_name ) {
			if( mtm_resort_rowmap( &_matrix, MTM_RESORT_LEXIGRAPHIC ) )
				errx( -1, NO_ROW_LABELS );
		}

		if( fp ) {
			const int econd
				= opt_by_name
				? _analyze_named_pair_list( fp )
				: _analyze_pair_list( fp );
			if( econd )
				warn( "error (%d) analyzing%s pair list",
					econd, opt_by_name ? " named" : "" );
			fclose( fp );
		} else
			warn( "opening \"%s\"", opt_pairlist_source );

	} else {

#ifdef HAVE_LUA
		if( opt_coroutine )
			_analyze_generated_pair_list( _L );
		else
#endif
			_analyze_all_pairs();
	}

	// Post process results if FDR is in effect and the 1st pass was
	// allowed to complete. (Post-processing involves a repetition of
	// analysis FOR A SUBSET of the original input.)

	if( USE_FDR_CONTROL && (! _sigint_received) ) {
		_fdr_postprocess( _fdr_cache_fp, arg_q_value, _fp_output, opt_preproc_matrix != NULL );
	} else
	if( opt_verbosity >= V_ESSENTIAL ) {
		fprintf( _fp_output,
				"# %d filtered for insignificance\n"
				"# %d filtered for some sort of degeneracy\n",
				_insignificant,
				_untested );
		// ...which does not apply in FDR control context.
	}

	if( _fdr_cache_fp )
		fclose( _fdr_cache_fp );

	if( _fp_output )
		fclose( _fp_output );

	return exit_status;
}


// Copyright (c) 2017, Lawrence Livermore National Security, LLC. Produced at
// the Lawrence Livermore National Laboratory. LLNL-CODE-734707. All Rights
// reserved. See files LICENSE and NOTICE for details.
//
// This file is part of CEED, a collection of benchmarks, miniapps, software
// libraries and APIs for efficient high-order finite element and spectral
// element discretizations for exascale applications. For more information and
// source code availability see http://github.com/ceed.
//
// The CEED research is supported by the Exascale Computing Project 17-SC-20-SC,
// a collaborative effort of two U.S. Department of Energy organizations (Office
// of Science and the National Nuclear Security Administration) responsible for
// the planning and preparation of a capable exascale ecosystem, including
// software, applications, hardware, advanced system engineering and early
// testbed platforms, in support of the nation's exascale computing imperative.

#ifndef setup_h
#define setup_h

#include <stdbool.h>
#include <string.h>
#include <petsc.h>
#include <petscdmplex.h>
#include <petscfe.h>
#include <ceed.h>
#include "qfunctions/bps/common.h"
#include "qfunctions/bps/bp1.h"
#include "qfunctions/bps/bp2.h"
#include "qfunctions/bps/bp3.h"
#include "qfunctions/bps/bp4.h"

// -----------------------------------------------------------------------------
// PETSc Operator Structs
// -----------------------------------------------------------------------------

// Data for PETSc Matshell
typedef struct UserO_ *UserO;
struct UserO_ {
  MPI_Comm comm;
  DM dm;
  Vec Xloc, Yloc, diag;
  CeedVector xceed, yceed;
  CeedOperator op;
  Ceed ceed;
};

// Data for PETSc Interp/Restrict Matshells
typedef struct UserIR_ *UserIR;
struct UserIR_ {
  MPI_Comm comm;
  DM dmc, dmf;
  Vec Xloc, Yloc, mult;
  CeedVector ceedvecc, ceedvecf;
  CeedOperator op;
  Ceed ceed;
};

// -----------------------------------------------------------------------------
// libCEED Data Struct
// -----------------------------------------------------------------------------

// libCEED data struct for level
typedef struct CeedData_ *CeedData;
struct CeedData_ {
  Ceed ceed;
  CeedBasis basisx, basisu, basisctof;
  CeedElemRestriction Erestrictx, Erestrictu, Erestrictxi, Erestrictui,
                      Erestrictqdi;
  CeedQFunction qf_apply;
  CeedOperator op_apply, op_restrict, op_interp;
  CeedVector qdata, xceed, yceed;
};

// -----------------------------------------------------------------------------
// Command Line Options
// -----------------------------------------------------------------------------

// Coarsening options
typedef enum {
  COARSEN_UNIFORM = 0, COARSEN_LOGARITHMIC = 1
} coarsenType;
static const char *const coarsenTypes [] = {"uniform","logarithmic",
                                            "coarsenType","COARSEN",0
                                           };

// -----------------------------------------------------------------------------
// Boundary Conditions
// -----------------------------------------------------------------------------

// Diff boundary condition function
PetscErrorCode BCsDiff(PetscInt dim, PetscReal time, const PetscReal x[],
                       PetscInt ncompu, PetscScalar *u, void *ctx) {
  // *INDENT-OFF*
  #ifndef M_PI
  #define M_PI    3.14159265358979323846
  #endif
  // *INDENT-ON*
  const CeedScalar c[3] = { 0, 1., 2. };
  const CeedScalar k[3] = { 1., 2., 3. };

  PetscFunctionBeginUser;

  for (PetscInt i = 0; i < ncompu; i++)
    u[i] = sin(M_PI*(c[0] + k[0]*x[0])) *
           sin(M_PI*(c[1] + k[1]*x[1])) *
           sin(M_PI*(c[2] + k[2]*x[2]));

  PetscFunctionReturn(0);
}

// Mass boundary condition function
PetscErrorCode BCsMass(PetscInt dim, PetscReal time, const PetscReal x[],
                       PetscInt ncompu, PetscScalar *u, void *ctx) {
  PetscFunctionBeginUser;

  for (PetscInt i = 0; i < ncompu; i++)
    u[i] = PetscSqrtScalar(PetscSqr(x[0]) + PetscSqr(x[1]) +
                           PetscSqr(x[2]));

  PetscFunctionReturn(0);
}

// Create BC label
static PetscErrorCode CreateBCLabel(DM dm, const char name[]) {
  int ierr;
  DMLabel label;

  PetscFunctionBeginUser;

  ierr = DMCreateLabel(dm, name); CHKERRQ(ierr);
  ierr = DMGetLabel(dm, name, &label); CHKERRQ(ierr);
  ierr = DMPlexMarkBoundaryFaces(dm, 1, label); CHKERRQ(ierr);
  ierr = DMPlexLabelComplete(dm, label); CHKERRQ(ierr);

  PetscFunctionReturn(0);
}

// -----------------------------------------------------------------------------
// BP Option Data
// -----------------------------------------------------------------------------

// BP options
typedef enum {
  CEED_BP1 = 0, CEED_BP2 = 1, CEED_BP3 = 2,
  CEED_BP4 = 3, CEED_BP5 = 4, CEED_BP6 = 5
} bpType;
static const char *const bpTypes[] = {"bp1","bp2","bp3","bp4","bp5","bp6",
                                      "bpType","CEED_BP",0
                                     };

// BP specific data
typedef struct {
  CeedInt ncompu, qdatasize, qextra;
  CeedQFunctionUser setupgeo, setuprhs, apply, error;
  const char *setupgeofname, *setuprhsfname, *applyfname, *errorfname;
  CeedEvalMode inmode, outmode;
  CeedQuadMode qmode;
  PetscBool enforce_bc;
  PetscErrorCode (*bcs_func)(PetscInt, PetscReal, const PetscReal *,
                             PetscInt, PetscScalar *, void *);
} bpData;

bpData bpOptions[6] = {
  [CEED_BP1] = {
    .ncompu = 1,
    .qdatasize = 1,
    .qextra = 1,
    .setupgeo = SetupMassGeo,
    .setuprhs = SetupMassRhs,
    .apply = Mass,
    .error = Error,
    .setupgeofname = SetupMassGeo_loc,
    .setuprhsfname = SetupMassRhs_loc,
    .applyfname = Mass_loc,
    .errorfname = Error_loc,
    .inmode = CEED_EVAL_INTERP,
    .outmode = CEED_EVAL_INTERP,
    .qmode = CEED_GAUSS,
    .enforce_bc = false,
    .bcs_func = BCsMass
  },
  [CEED_BP2] = {
    .ncompu = 3,
    .qdatasize = 1,
    .qextra = 1,
    .setupgeo = SetupMassGeo,
    .setuprhs = SetupMassRhs3,
    .apply = Mass3,
    .error = Error3,
    .setupgeofname = SetupMassGeo_loc,
    .setuprhsfname = SetupMassRhs3_loc,
    .applyfname = Mass3_loc,
    .errorfname = Error3_loc,
    .inmode = CEED_EVAL_INTERP,
    .outmode = CEED_EVAL_INTERP,
    .qmode = CEED_GAUSS,
    .enforce_bc = false,
    .bcs_func = BCsMass
  },
  [CEED_BP3] = {
    .ncompu = 1,
    .qdatasize = 6,
    .qextra = 1,
    .setupgeo = SetupDiffGeo,
    .setuprhs = SetupDiffRhs,
    .apply = Diff,
    .error = Error,
    .setupgeofname = SetupDiffGeo_loc,
    .setuprhsfname = SetupDiffRhs_loc,
    .applyfname = Diff_loc,
    .errorfname = Error_loc,
    .inmode = CEED_EVAL_GRAD,
    .outmode = CEED_EVAL_GRAD,
    .qmode = CEED_GAUSS,
    .enforce_bc = true,
    .bcs_func = BCsDiff
  },
  [CEED_BP4] = {
    .ncompu = 3,
    .qdatasize = 6,
    .qextra = 1,
    .setupgeo = SetupDiffGeo,
    .setuprhs = SetupDiffRhs3,
    .apply = Diff3,
    .error = Error3,
    .setupgeofname = SetupDiffGeo_loc,
    .setuprhsfname = SetupDiffRhs3_loc,
    .applyfname = Diff_loc,
    .errorfname = Error3_loc,
    .inmode = CEED_EVAL_GRAD,
    .outmode = CEED_EVAL_GRAD,
    .qmode = CEED_GAUSS,
    .enforce_bc = true,
    .bcs_func = BCsDiff
  },
  [CEED_BP5] = {
    .ncompu = 1,
    .qdatasize = 6,
    .qextra = 0,
    .setupgeo = SetupDiffGeo,
    .setuprhs = SetupDiffRhs,
    .apply = Diff,
    .error = Error,
    .setupgeofname = SetupDiffGeo_loc,
    .setuprhsfname = SetupDiffRhs_loc,
    .applyfname = Diff_loc,
    .errorfname = Error_loc,
    .inmode = CEED_EVAL_GRAD,
    .outmode = CEED_EVAL_GRAD,
    .qmode = CEED_GAUSS_LOBATTO,
    .enforce_bc = true,
    .bcs_func = BCsDiff
  },
  [CEED_BP6] = {
    .ncompu = 3,
    .qdatasize = 6,
    .qextra = 0,
    .setupgeo = SetupDiffGeo,
    .setuprhs = SetupDiffRhs3,
    .apply = Diff3,
    .error = Error3,
    .setupgeofname = SetupDiffGeo_loc,
    .setuprhsfname = SetupDiffRhs3_loc,
    .applyfname = Diff_loc,
    .errorfname = Error3_loc,
    .inmode = CEED_EVAL_GRAD,
    .outmode = CEED_EVAL_GRAD,
    .qmode = CEED_GAUSS_LOBATTO,
    .enforce_bc = true,
    .bcs_func = BCsDiff
  }
};

// -----------------------------------------------------------------------------
// PETSc FE Boilerplate
// -----------------------------------------------------------------------------

// Create FE by degree
static int PetscFECreateByDegree(DM dm, PetscInt dim, PetscInt Nc,
                                 PetscBool isSimplex, const char prefix[],
                                 PetscInt order, PetscFE *fem) {
  PetscQuadrature q, fq;
  DM              K;
  PetscSpace      P;
  PetscDualSpace  Q;
  PetscInt        quadPointsPerEdge;
  PetscBool       tensor = isSimplex ? PETSC_FALSE : PETSC_TRUE;
  PetscErrorCode  ierr;

  PetscFunctionBeginUser;
  /* Create space */
  ierr = PetscSpaceCreate(PetscObjectComm((PetscObject) dm), &P); CHKERRQ(ierr);
  ierr = PetscObjectSetOptionsPrefix((PetscObject) P, prefix); CHKERRQ(ierr);
  ierr = PetscSpacePolynomialSetTensor(P, tensor); CHKERRQ(ierr);
  ierr = PetscSpaceSetFromOptions(P); CHKERRQ(ierr);
  ierr = PetscSpaceSetNumComponents(P, Nc); CHKERRQ(ierr);
  ierr = PetscSpaceSetNumVariables(P, dim); CHKERRQ(ierr);
  ierr = PetscSpaceSetDegree(P, order, order); CHKERRQ(ierr);
  ierr = PetscSpaceSetUp(P); CHKERRQ(ierr);
  ierr = PetscSpacePolynomialGetTensor(P, &tensor); CHKERRQ(ierr);
  /* Create dual space */
  ierr = PetscDualSpaceCreate(PetscObjectComm((PetscObject) dm), &Q);
  CHKERRQ(ierr);
  ierr = PetscDualSpaceSetType(Q,PETSCDUALSPACELAGRANGE); CHKERRQ(ierr);
  ierr = PetscObjectSetOptionsPrefix((PetscObject) Q, prefix); CHKERRQ(ierr);
  ierr = PetscDualSpaceCreateReferenceCell(Q, dim, isSimplex, &K); CHKERRQ(ierr);
  ierr = PetscDualSpaceSetDM(Q, K); CHKERRQ(ierr);
  ierr = DMDestroy(&K); CHKERRQ(ierr);
  ierr = PetscDualSpaceSetNumComponents(Q, Nc); CHKERRQ(ierr);
  ierr = PetscDualSpaceSetOrder(Q, order); CHKERRQ(ierr);
  ierr = PetscDualSpaceLagrangeSetTensor(Q, tensor); CHKERRQ(ierr);
  ierr = PetscDualSpaceSetFromOptions(Q); CHKERRQ(ierr);
  ierr = PetscDualSpaceSetUp(Q); CHKERRQ(ierr);
  /* Create element */
  ierr = PetscFECreate(PetscObjectComm((PetscObject) dm), fem); CHKERRQ(ierr);
  ierr = PetscObjectSetOptionsPrefix((PetscObject) *fem, prefix); CHKERRQ(ierr);
  ierr = PetscFESetFromOptions(*fem); CHKERRQ(ierr);
  ierr = PetscFESetBasisSpace(*fem, P); CHKERRQ(ierr);
  ierr = PetscFESetDualSpace(*fem, Q); CHKERRQ(ierr);
  ierr = PetscFESetNumComponents(*fem, Nc); CHKERRQ(ierr);
  ierr = PetscFESetUp(*fem); CHKERRQ(ierr);
  ierr = PetscSpaceDestroy(&P); CHKERRQ(ierr);
  ierr = PetscDualSpaceDestroy(&Q); CHKERRQ(ierr);
  /* Create quadrature */
  quadPointsPerEdge = PetscMax(order + 1,1);
  if (isSimplex) {
    ierr = PetscDTGaussJacobiQuadrature(dim,   1, quadPointsPerEdge, -1.0, 1.0,
                                        &q); CHKERRQ(ierr);
    ierr = PetscDTGaussJacobiQuadrature(dim-1, 1, quadPointsPerEdge, -1.0, 1.0,
                                        &fq); CHKERRQ(ierr);
  } else {
    ierr = PetscDTGaussTensorQuadrature(dim,   1, quadPointsPerEdge, -1.0, 1.0,
                                        &q); CHKERRQ(ierr);
    ierr = PetscDTGaussTensorQuadrature(dim-1, 1, quadPointsPerEdge, -1.0, 1.0,
                                        &fq); CHKERRQ(ierr);
  }
  ierr = PetscFESetQuadrature(*fem, q); CHKERRQ(ierr);
  ierr = PetscFESetFaceQuadrature(*fem, fq); CHKERRQ(ierr);
  ierr = PetscQuadratureDestroy(&q); CHKERRQ(ierr);
  ierr = PetscQuadratureDestroy(&fq); CHKERRQ(ierr);

  PetscFunctionReturn(0);
}

// -----------------------------------------------------------------------------
// PETSc Setup for Level
// -----------------------------------------------------------------------------

// This function sets up a DM for a given degree
static int SetupDMByDegree(DM dm, PetscInt degree, PetscInt ncompu,
                           bpType bpChoice) {
  PetscInt ierr, dim, marker_ids[1] = {1};
  PetscFE fe;

  PetscFunctionBeginUser;

  // Setup FE
  ierr = DMGetDimension(dm, &dim); CHKERRQ(ierr);
  ierr = PetscFECreateByDegree(dm, dim, ncompu, PETSC_FALSE, NULL, degree, &fe);
  CHKERRQ(ierr);
  ierr = DMSetFromOptions(dm); CHKERRQ(ierr);
  ierr = DMAddField(dm, NULL, (PetscObject)fe); CHKERRQ(ierr);

  // Setup DM
  ierr = DMCreateDS(dm); CHKERRQ(ierr);
  if (bpOptions[bpChoice].enforce_bc) {
    PetscBool hasLabel;
    DMHasLabel(dm, "marker", &hasLabel);
    if (!hasLabel) {CreateBCLabel(dm, "marker");}
    ierr = DMAddBoundary(dm, DM_BC_ESSENTIAL, "wall", "marker", 0, 0, NULL,
                         (void(*)(void))bpOptions[bpChoice].bcs_func,
                         1, marker_ids, NULL);
    CHKERRQ(ierr);
  }
  ierr = DMPlexSetClosurePermutationTensor(dm, PETSC_DETERMINE, NULL);
  CHKERRQ(ierr);
  ierr = PetscFEDestroy(&fe); CHKERRQ(ierr);

  PetscFunctionReturn(0);
}

// -----------------------------------------------------------------------------
// libCEED Setup for Level
// -----------------------------------------------------------------------------

// Destroy libCEED operator objects
static PetscErrorCode CeedDataDestroy(CeedInt i, CeedData data) {
  PetscInt ierr;

  CeedVectorDestroy(&data->qdata);
  CeedVectorDestroy(&data->xceed);
  CeedVectorDestroy(&data->yceed);
  CeedBasisDestroy(&data->basisx);
  CeedBasisDestroy(&data->basisu);
  CeedElemRestrictionDestroy(&data->Erestrictu);
  CeedElemRestrictionDestroy(&data->Erestrictx);
  CeedElemRestrictionDestroy(&data->Erestrictui);
  CeedElemRestrictionDestroy(&data->Erestrictxi);
  CeedElemRestrictionDestroy(&data->Erestrictqdi);
  CeedQFunctionDestroy(&data->qf_apply);
  CeedOperatorDestroy(&data->op_apply);
  if (i > 0) {
    CeedOperatorDestroy(&data->op_interp);
    CeedBasisDestroy(&data->basisctof);
    CeedOperatorDestroy(&data->op_restrict);
  }
  ierr = PetscFree(data); CHKERRQ(ierr);

  PetscFunctionReturn(0);
}

// Get CEED restriction data from DMPlex
static int CreateRestrictionPlex(Ceed ceed, CeedInt P, CeedInt ncomp,
                                 CeedElemRestriction *Erestrict, DM dm) {
  PetscInt ierr;
  PetscInt c, cStart, cEnd, nelem, nnodes, *erestrict, eoffset;
  PetscSection section;
  Vec Uloc;

  PetscFunctionBeginUser;

  // Get Nelem
  ierr = DMGetSection(dm, &section); CHKERRQ(ierr);
  ierr = DMPlexGetHeightStratum(dm, 0, &cStart,& cEnd); CHKERRQ(ierr);
  nelem = cEnd - cStart;

  // Get indices
  ierr = PetscMalloc1(nelem*P*P*P, &erestrict); CHKERRQ(ierr);
  for (c=cStart, eoffset=0; c<cEnd; c++) {
    PetscInt numindices, *indices, i;
    ierr = DMPlexGetClosureIndices(dm, section, section, c, &numindices,
                                   &indices, NULL); CHKERRQ(ierr);
    for (i=0; i<numindices; i+=ncomp) {
      for (PetscInt j=0; j<ncomp; j++) {
        if (indices[i+j] != indices[i] + (PetscInt)(copysign(j, indices[i])))
          SETERRQ1(PETSC_COMM_SELF, PETSC_ERR_ARG_INCOMP,
                   "Cell %D closure indices not interlaced", c);
      }
      // Essential boundary conditions are encoded as -(loc+1)
      PetscInt loc = indices[i] >= 0 ? indices[i] : -(indices[i] + 1);
      erestrict[eoffset++] = loc/ncomp;
    }
    ierr = DMPlexRestoreClosureIndices(dm, section, section, c, &numindices,
                                       &indices, NULL); CHKERRQ(ierr);
  }

  // Setup CEED restriction
  ierr = DMGetLocalVector(dm, &Uloc); CHKERRQ(ierr);
  ierr = VecGetLocalSize(Uloc, &nnodes); CHKERRQ(ierr);

  ierr = DMRestoreLocalVector(dm, &Uloc); CHKERRQ(ierr);
  CeedElemRestrictionCreate(ceed, nelem, P*P*P, nnodes/ncomp, ncomp,
                            CEED_MEM_HOST, CEED_COPY_VALUES, erestrict,
                            Erestrict);
  ierr = PetscFree(erestrict); CHKERRQ(ierr);

  PetscFunctionReturn(0);
}

// Set up libCEED for a given degree
static int SetupLibceedByDegree(DM dm, Ceed ceed, CeedInt degree, CeedInt dim,
                                CeedInt qextra, PetscInt ncompu, PetscInt gsize,
                                PetscInt xlsize, bpType bpChoice, CeedData data,
                                PetscBool setup_rhs, CeedVector rhsceed,
                                CeedVector *target) {
  int ierr;
  DM dmcoord;
  PetscSection section;
  Vec coords;
  const PetscScalar *coordArray;
  CeedBasis basisx, basisu;
  CeedElemRestriction Erestrictx, Erestrictu, Erestrictxi,
                      Erestrictui, Erestrictqdi;
  CeedQFunction qf_setupgeo, qf_apply;
  CeedOperator op_setupgeo, op_apply;
  CeedVector xcoord, qdata, xceed, yceed;
  CeedInt qdatasize = bpOptions[bpChoice].qdatasize, ncompx = dim, P, Q,
          cStart, cEnd, nelem;

  // CEED bases
  P = degree + 1;
  Q = P + qextra;
  CeedBasisCreateTensorH1Lagrange(ceed, dim, ncompu, P, Q,
                                  bpOptions[bpChoice].qmode, &basisu);
  CeedBasisCreateTensorH1Lagrange(ceed, dim, ncompx, 2, Q,
                                  bpOptions[bpChoice].qmode, &basisx);

  // CEED restrictions
  ierr = DMGetCoordinateDM(dm, &dmcoord); CHKERRQ(ierr);
  ierr = DMPlexSetClosurePermutationTensor(dmcoord, PETSC_DETERMINE, NULL);
  CHKERRQ(ierr);

  CreateRestrictionPlex(ceed, 2, ncompx, &Erestrictx, dmcoord);
  CreateRestrictionPlex(ceed, P, ncompu, &Erestrictu, dm);

  ierr = DMPlexGetHeightStratum(dm, 0, &cStart, &cEnd); CHKERRQ(ierr);
  nelem = cEnd - cStart;

  CeedElemRestrictionCreateIdentity(ceed, nelem, Q*Q*Q, nelem*Q*Q*Q, ncompu,
                                    &Erestrictui); CHKERRQ(ierr);
  CeedElemRestrictionCreateIdentity(ceed, nelem, Q*Q*Q, nelem*Q*Q*Q,
                                    qdatasize, &Erestrictqdi); CHKERRQ(ierr);
  CeedElemRestrictionCreateIdentity(ceed, nelem, Q*Q*Q, nelem*Q*Q*Q, ncompx,
                                    &Erestrictxi); CHKERRQ(ierr);

  // Element coordinates
  ierr = DMGetCoordinatesLocal(dm, &coords); CHKERRQ(ierr);
  ierr = VecGetArrayRead(coords, &coordArray); CHKERRQ(ierr);
  ierr = DMGetSection(dmcoord, &section); CHKERRQ(ierr);

  CeedElemRestrictionCreateVector(Erestrictx, &xcoord, NULL);
  CeedVectorSetArray(xcoord, CEED_MEM_HOST, CEED_COPY_VALUES,
                     (PetscScalar *)coordArray);
  ierr = VecRestoreArrayRead(coords, &coordArray); CHKERRQ(ierr);

  // Create the persistent vectors that will be needed in setup and apply
  CeedInt nqpts;
  CeedBasisGetNumQuadraturePoints(basisu, &nqpts);
  CeedVectorCreate(ceed, qdatasize*nelem*nqpts, &qdata);
  CeedVectorCreate(ceed, xlsize, &xceed);
  CeedVectorCreate(ceed, xlsize, &yceed);

  // Create the Q-function that builds the operator (i.e. computes its
  // quadrature data) and set its context data
  CeedQFunctionCreateInterior(ceed, 1, bpOptions[bpChoice].setupgeo,
                              bpOptions[bpChoice].setupgeofname, &qf_setupgeo);
  CeedQFunctionAddInput(qf_setupgeo, "dx", ncompx*dim, CEED_EVAL_GRAD);
  CeedQFunctionAddInput(qf_setupgeo, "weight", 1, CEED_EVAL_WEIGHT);
  CeedQFunctionAddOutput(qf_setupgeo, "qdata", qdatasize, CEED_EVAL_NONE);

  // Set up PDE operator
  CeedInt inscale = bpOptions[bpChoice].inmode==CEED_EVAL_GRAD ? dim : 1;
  CeedInt outscale = bpOptions[bpChoice].outmode==CEED_EVAL_GRAD ? dim : 1;
  CeedQFunctionCreateInterior(ceed, 1, bpOptions[bpChoice].apply,
                              bpOptions[bpChoice].applyfname, &qf_apply);
  CeedQFunctionAddInput(qf_apply, "u", ncompu*inscale,
                        bpOptions[bpChoice].inmode);
  CeedQFunctionAddInput(qf_apply, "qdata", qdatasize, CEED_EVAL_NONE);
  CeedQFunctionAddOutput(qf_apply, "v", ncompu*outscale,
                         bpOptions[bpChoice].outmode);

  // Create the operator that builds the quadrature data for the operator
  CeedOperatorCreate(ceed, qf_setupgeo, CEED_QFUNCTION_NONE,
                     CEED_QFUNCTION_NONE, &op_setupgeo);
  CeedOperatorSetField(op_setupgeo, "dx", Erestrictx, CEED_TRANSPOSE,
                       basisx, CEED_VECTOR_ACTIVE);
  CeedOperatorSetField(op_setupgeo, "weight", Erestrictxi, CEED_NOTRANSPOSE,
                       basisx, CEED_VECTOR_NONE);
  CeedOperatorSetField(op_setupgeo, "qdata", Erestrictqdi, CEED_NOTRANSPOSE,
                       CEED_BASIS_COLLOCATED, CEED_VECTOR_ACTIVE);

  // Create the operator
  CeedOperatorCreate(ceed, qf_apply, CEED_QFUNCTION_NONE, CEED_QFUNCTION_NONE,
                     &op_apply);
  CeedOperatorSetField(op_apply, "u", Erestrictu, CEED_TRANSPOSE,
                       basisu, CEED_VECTOR_ACTIVE);
  CeedOperatorSetField(op_apply, "qdata", Erestrictqdi, CEED_NOTRANSPOSE,
                       CEED_BASIS_COLLOCATED, qdata);
  CeedOperatorSetField(op_apply, "v", Erestrictu, CEED_TRANSPOSE,
                       basisu, CEED_VECTOR_ACTIVE);

  // Setup qdata
  CeedOperatorApply(op_setupgeo, xcoord, qdata, CEED_REQUEST_IMMEDIATE);

  // Set up RHS if needed
  if (setup_rhs) {
    CeedQFunction qf_setuprhs;
    CeedOperator op_setuprhs;
    CeedVectorCreate(ceed, nelem*nqpts*ncompu, target);

    // Create the q-function that sets up the RHS and true solution
    CeedQFunctionCreateInterior(ceed, 1, bpOptions[bpChoice].setuprhs,
                                bpOptions[bpChoice].setuprhsfname, &qf_setuprhs);
    CeedQFunctionAddInput(qf_setuprhs, "x", dim, CEED_EVAL_INTERP);
    CeedQFunctionAddInput(qf_setuprhs, "dx", ncompx*dim, CEED_EVAL_GRAD);
    CeedQFunctionAddInput(qf_setuprhs, "weight", 1, CEED_EVAL_WEIGHT);
    CeedQFunctionAddOutput(qf_setuprhs, "true_soln", ncompu, CEED_EVAL_NONE);
    CeedQFunctionAddOutput(qf_setuprhs, "rhs", ncompu, CEED_EVAL_INTERP);

    // Create the operator that builds the RHS and true solution
    CeedOperatorCreate(ceed, qf_setuprhs, CEED_QFUNCTION_NONE,
                       CEED_QFUNCTION_NONE, &op_setuprhs);
    CeedOperatorSetField(op_setuprhs, "x", Erestrictx, CEED_TRANSPOSE,
                         basisx, CEED_VECTOR_ACTIVE);
    CeedOperatorSetField(op_setuprhs, "dx", Erestrictx, CEED_TRANSPOSE,
                         basisx, CEED_VECTOR_ACTIVE);
    CeedOperatorSetField(op_setuprhs, "weight", Erestrictxi, CEED_NOTRANSPOSE,
                         basisx, CEED_VECTOR_NONE);
    CeedOperatorSetField(op_setuprhs, "true_soln", Erestrictui, CEED_NOTRANSPOSE,
                         CEED_BASIS_COLLOCATED, *target);
    CeedOperatorSetField(op_setuprhs, "rhs", Erestrictu, CEED_TRANSPOSE,
                         basisu, CEED_VECTOR_ACTIVE);

    // Setup RHS and target
    CeedOperatorApply(op_setuprhs, xcoord, rhsceed, CEED_REQUEST_IMMEDIATE);
    CeedVectorSyncArray(rhsceed, CEED_MEM_HOST);

    // Cleanup
    CeedQFunctionDestroy(&qf_setuprhs);
    CeedOperatorDestroy(&op_setuprhs);
  }

  // Cleanup
  CeedQFunctionDestroy(&qf_setupgeo);
  CeedOperatorDestroy(&op_setupgeo);
  CeedVectorDestroy(&xcoord);

  // Save libCEED data required for level
  data->basisx = basisx; data->basisu = basisu;
  data->Erestrictx = Erestrictx;
  data->Erestrictu = Erestrictu;
  data->Erestrictxi = Erestrictxi;
  data->Erestrictui = Erestrictui;
  data->Erestrictqdi = Erestrictqdi;
  data->qf_apply = qf_apply;
  data->op_apply = op_apply;
  data->qdata = qdata;
  data->xceed = xceed;
  data->yceed = yceed;

  PetscFunctionReturn(0);
}

#ifdef multigrid
// Setup libCEED level transfer operator objects
static PetscErrorCode CeedLevelTransferSetup(Ceed ceed, CeedInt numlevels,
    CeedInt ncompu, bpType bpChoice, CeedData *data, CeedInt *leveldegrees,
    CeedQFunction qf_restrict, CeedQFunction qf_prolong) {
  // Return early if numlevels=1
  if (numlevels==1)
    PetscFunctionReturn(0);

  // Set up each level
  for (CeedInt i=1; i<numlevels; i++) {
    // P coarse and P fine
    CeedInt Pc = leveldegrees[i-1] + 1;
    CeedInt Pf = leveldegrees[i] + 1;

    // Restriction - Fine to corse
    CeedBasis basisctof;
    CeedOperator op_restrict;

    // Basis
    CeedBasisCreateTensorH1Lagrange(ceed, 3, ncompu, Pc, Pf,
                                    CEED_GAUSS_LOBATTO, &basisctof);

    // Create the restriction operator
    CeedOperatorCreate(ceed, qf_restrict, CEED_QFUNCTION_NONE,
                       CEED_QFUNCTION_NONE, &op_restrict);
    CeedOperatorSetField(op_restrict, "input", data[i]->Erestrictu,
                         CEED_NOTRANSPOSE, CEED_BASIS_COLLOCATED,
                         CEED_VECTOR_ACTIVE);
    CeedOperatorSetField(op_restrict, "output", data[i-1]->Erestrictu,
                         CEED_TRANSPOSE, basisctof, CEED_VECTOR_ACTIVE);

    // Save libCEED data required for level
    data[i]->basisctof = basisctof;
    data[i]->op_restrict = op_restrict;

    // Interpolation - Corse to fine
    CeedOperator op_interp;

    // Create the prolongation operator
    CeedOperatorCreate(ceed, qf_prolong, CEED_QFUNCTION_NONE,
                       CEED_QFUNCTION_NONE, &op_interp);
    CeedOperatorSetField(op_interp, "input", data[i-1]->Erestrictu,
                         CEED_NOTRANSPOSE, basisctof, CEED_VECTOR_ACTIVE);
    CeedOperatorSetField(op_interp, "output", data[i]->Erestrictu,
                         CEED_TRANSPOSE, CEED_BASIS_COLLOCATED,
                         CEED_VECTOR_ACTIVE);

    // Save libCEED data required for level
    data[i]->op_interp = op_interp;
  }

  PetscFunctionReturn(0);
}
#endif

// -----------------------------------------------------------------------------
// Mat Shell Functions
// -----------------------------------------------------------------------------

#ifdef multigrid
// This function returns the computed diagonal of the operator
static PetscErrorCode MatGetDiag(Mat A, Vec D) {
  PetscErrorCode ierr;
  UserO user;

  PetscFunctionBeginUser;
  ierr = MatShellGetContext(A, &user); CHKERRQ(ierr);

  ierr = VecCopy(user->diag, D); CHKERRQ(ierr);

  PetscFunctionReturn(0);
}
#endif

// This function uses libCEED to compute the action of the Laplacian with
// Dirichlet boundary conditions
static PetscErrorCode MatMult_Ceed(Mat A, Vec X, Vec Y) {
  PetscErrorCode ierr;
  UserO user;
  PetscScalar *x, *y;

  PetscFunctionBeginUser;
  ierr = MatShellGetContext(A, &user); CHKERRQ(ierr);

  // Global-to-local
  ierr = DMGlobalToLocalBegin(user->dm, X, INSERT_VALUES, user->Xloc);
  CHKERRQ(ierr);
  ierr = DMGlobalToLocalEnd(user->dm, X, INSERT_VALUES, user->Xloc);
  CHKERRQ(ierr);
  ierr = VecZeroEntries(user->Yloc); CHKERRQ(ierr);

  // Setup CEED vectors
  ierr = VecGetArrayRead(user->Xloc, (const PetscScalar **)&x); CHKERRQ(ierr);
  ierr = VecGetArray(user->Yloc, &y); CHKERRQ(ierr);
  CeedVectorSetArray(user->xceed, CEED_MEM_HOST, CEED_USE_POINTER, x);
  CeedVectorSetArray(user->yceed, CEED_MEM_HOST, CEED_USE_POINTER, y);

  // Apply CEED operator
  CeedOperatorApply(user->op, user->xceed, user->yceed, CEED_REQUEST_IMMEDIATE);
  CeedVectorSyncArray(user->yceed, CEED_MEM_HOST);

  // Restore PETSc vectors
  ierr = VecRestoreArrayRead(user->Xloc, (const PetscScalar **)&x);
  CHKERRQ(ierr);
  ierr = VecRestoreArray(user->Yloc, &y); CHKERRQ(ierr);

  // Local-to-global
  ierr = VecZeroEntries(Y); CHKERRQ(ierr);
  ierr = DMLocalToGlobalBegin(user->dm, user->Yloc, ADD_VALUES, Y);
  CHKERRQ(ierr);
  ierr = DMLocalToGlobalEnd(user->dm, user->Yloc, ADD_VALUES, Y);
  CHKERRQ(ierr);

  PetscFunctionReturn(0);
}

#ifdef multigrid
// This function uses libCEED to compute the action of the interp operator
static PetscErrorCode MatMult_Interp(Mat A, Vec X, Vec Y) {
  PetscErrorCode ierr;
  UserIR user;
  PetscScalar *x, *y;

  PetscFunctionBeginUser;
  ierr = MatShellGetContext(A, &user); CHKERRQ(ierr);

  // Global-to-local
  ierr = VecZeroEntries(user->Xloc); CHKERRQ(ierr);
  ierr = DMGlobalToLocalBegin(user->dmc, X, INSERT_VALUES, user->Xloc);
  CHKERRQ(ierr);
  ierr = DMGlobalToLocalEnd(user->dmc, X, INSERT_VALUES, user->Xloc);
  CHKERRQ(ierr);
  ierr = VecZeroEntries(user->Yloc); CHKERRQ(ierr);

  // Setup CEED vectors
  ierr = VecGetArrayRead(user->Xloc, (const PetscScalar **)&x); CHKERRQ(ierr);
  ierr = VecGetArray(user->Yloc, &y); CHKERRQ(ierr);
  CeedVectorSetArray(user->ceedvecc, CEED_MEM_HOST, CEED_USE_POINTER, x);
  CeedVectorSetArray(user->ceedvecf, CEED_MEM_HOST, CEED_USE_POINTER, y);

  // Apply CEED operator
  CeedOperatorApply(user->op, user->ceedvecc, user->ceedvecf,
                    CEED_REQUEST_IMMEDIATE);
  CeedVectorSyncArray(user->ceedvecf, CEED_MEM_HOST);

  // Restore PETSc vectors
  ierr = VecRestoreArrayRead(user->Xloc, (const PetscScalar **)&x);
  CHKERRQ(ierr);
  ierr = VecRestoreArray(user->Yloc, &y); CHKERRQ(ierr);

  // Multiplicity
  ierr = VecPointwiseMult(user->Yloc, user->Yloc, user->mult);

  // Local-to-global
  ierr = VecZeroEntries(Y); CHKERRQ(ierr);
  ierr = DMLocalToGlobalBegin(user->dmf, user->Yloc, ADD_VALUES, Y);
  CHKERRQ(ierr);
  ierr = DMLocalToGlobalEnd(user->dmf, user->Yloc, ADD_VALUES, Y);
  CHKERRQ(ierr);

  PetscFunctionReturn(0);
}

// This function uses libCEED to compute the action of the restriction operator
static PetscErrorCode MatMult_Restrict(Mat A, Vec X, Vec Y) {
  PetscErrorCode ierr;
  UserIR user;
  PetscScalar *x, *y;

  PetscFunctionBeginUser;
  ierr = MatShellGetContext(A, &user); CHKERRQ(ierr);

  // Global-to-local
  ierr = VecZeroEntries(user->Xloc); CHKERRQ(ierr);
  ierr = DMGlobalToLocalBegin(user->dmf, X, INSERT_VALUES, user->Xloc);
  CHKERRQ(ierr);
  ierr = DMGlobalToLocalEnd(user->dmf, X, INSERT_VALUES, user->Xloc);
  CHKERRQ(ierr);
  ierr = VecZeroEntries(user->Yloc); CHKERRQ(ierr);

  // Multiplicity
  ierr = VecPointwiseMult(user->Xloc, user->Xloc, user->mult); CHKERRQ(ierr);

  // Setup CEED vectors
  ierr = VecGetArrayRead(user->Xloc, (const PetscScalar **)&x); CHKERRQ(ierr);
  ierr = VecGetArray(user->Yloc, &y); CHKERRQ(ierr);
  CeedVectorSetArray(user->ceedvecf, CEED_MEM_HOST, CEED_USE_POINTER, x);
  CeedVectorSetArray(user->ceedvecc, CEED_MEM_HOST, CEED_USE_POINTER, y);

  // Apply CEED operator
  CeedOperatorApply(user->op, user->ceedvecf, user->ceedvecc,
                    CEED_REQUEST_IMMEDIATE);
  CeedVectorSyncArray(user->ceedvecc, CEED_MEM_HOST);

  // Restore PETSc vectors
  ierr = VecRestoreArrayRead(user->Xloc, (const PetscScalar **)&x);
  CHKERRQ(ierr);
  ierr = VecRestoreArray(user->Yloc, &y); CHKERRQ(ierr);

  // Local-to-global
  ierr = VecZeroEntries(Y); CHKERRQ(ierr);
  ierr = DMLocalToGlobalBegin(user->dmc, user->Yloc, ADD_VALUES, Y);
  CHKERRQ(ierr);
  ierr = DMLocalToGlobalEnd(user->dmc, user->Yloc, ADD_VALUES, Y);
  CHKERRQ(ierr);

  PetscFunctionReturn(0);
}
#endif

// This function calculates the error in the final solution
static PetscErrorCode ComputeErrorMax(UserO user, CeedOperator op_error,
                                      Vec X, CeedVector target,
                                      PetscReal *maxerror) {
  PetscErrorCode ierr;
  PetscScalar *x;
  CeedVector collocated_error;
  CeedInt length;

  PetscFunctionBeginUser;
  CeedVectorGetLength(target, &length);
  CeedVectorCreate(user->ceed, length, &collocated_error);

  // Global-to-local
  ierr = DMGlobalToLocal(user->dm, X, INSERT_VALUES, user->Xloc); CHKERRQ(ierr);

  // Setup CEED vector
  ierr = VecGetArrayRead(user->Xloc, (const PetscScalar **)&x); CHKERRQ(ierr);
  CeedVectorSetArray(user->xceed, CEED_MEM_HOST, CEED_USE_POINTER, x);

  // Apply CEED operator
  CeedOperatorApply(op_error, user->xceed, collocated_error,
                    CEED_REQUEST_IMMEDIATE);

  // Restore PETSc vector
  VecRestoreArrayRead(user->Xloc, (const PetscScalar **)&x); CHKERRQ(ierr);

  // Reduce max error
  *maxerror = 0;
  const CeedScalar *e;
  CeedVectorGetArrayRead(collocated_error, CEED_MEM_HOST, &e);
  for (CeedInt i=0; i<length; i++) {
    *maxerror = PetscMax(*maxerror, PetscAbsScalar(e[i]));
  }
  CeedVectorRestoreArrayRead(collocated_error, &e);
  ierr = MPI_Allreduce(MPI_IN_PLACE, maxerror,
                       1, MPIU_REAL, MPIU_MAX, user->comm); CHKERRQ(ierr);

  // Cleanup
  CeedVectorDestroy(&collocated_error);

  PetscFunctionReturn(0);
}
#endif