Isis_Rmf_Grid_Type *Isis_new_rmf_grid (unsigned int nbins, double *lo, double *hi) /*{{{*/
{
Isis_Rmf_Grid_Type *g;
if (NULL == (g = (Isis_Rmf_Grid_Type *) ISIS_MALLOC (sizeof(Isis_Rmf_Grid_Type))))
return NULL;
memset ((char *)g, 0, sizeof (*g));
g->nbins = nbins;
g->units = -1;
if (NULL == (g->bin_lo = (double *) ISIS_MALLOC (nbins * sizeof(double)))
|| NULL == (g->bin_hi = (double *) ISIS_MALLOC (nbins * sizeof(double))))
{
Isis_free_rmf_grid (g);
g = NULL;
return g;
}
if (lo == NULL)
memset ((char *)g->bin_lo, 0, nbins*sizeof(double));
else
memcpy ((char *)g->bin_lo, (char *)lo, nbins * sizeof(double));
if (hi == NULL)
memset ((char *)g->bin_hi, 0, nbins*sizeof(double));
else
memcpy ((char *)g->bin_hi, (char *)hi, nbins * sizeof(double));
return g;
}
static Isis_Fit_Statistic_Optional_Data_Type *allocate_statistic_opt_data (int n) /*{{{*/
{
Isis_Fit_Statistic_Optional_Data_Type *opt_data;
if (NULL == (opt_data = (Isis_Fit_Statistic_Optional_Data_Type *)ISIS_MALLOC (sizeof *opt_data)))
return NULL;
memset ((char *)opt_data, 0, sizeof *opt_data);
opt_data->num = n;
opt_data->malloced = 1;
if ((NULL == (opt_data->bkg = (double *)ISIS_MALLOC (n * sizeof(double))))
||(NULL == (opt_data->bkg_at = (double *)ISIS_MALLOC (n * sizeof(double))))
||(NULL == (opt_data->src_at = (double *)ISIS_MALLOC (n * sizeof(double))))
)
{
free_statistic_opt_data (opt_data);
return NULL;
}
memset ((char *)opt_data->bkg, 0, n*sizeof(double));
memset ((char *)opt_data->bkg_at, 0, n*sizeof(double));
memset ((char *)opt_data->src_at, 0, n*sizeof(double));
return opt_data;
}
static Isis_Rmf_t *new_rmf (void) /*{{{*/
{
Isis_Rmf_t *rmf;
if (NULL == (rmf = (Isis_Rmf_t *) ISIS_MALLOC (sizeof(Isis_Rmf_t))))
return NULL;
memset ((char *)rmf, 0, sizeof(*rmf));
rmf->next = NULL;
rmf->index = 0;
rmf->ref_count = 0;
rmf->order = 0;
rmf->grating[0] = 0;
rmf->instrument[0] = 0;
rmf->arg_string = NULL;
rmf->method = RMF_DELTA;
rmf->includes_effective_area = 0;
rmf->set_arf_grid = NULL;
rmf->get_arf_grid = NULL;
rmf->set_data_grid = NULL;
rmf->get_data_grid = NULL;
rmf->redistribute = NULL;
rmf->delete_client_data = NULL;
rmf->set_noticed_model_bins = default_set_noticed_model_bins;
rmf->rebin_rmf = default_rebin_rmf;
rmf->factor_rsp = default_factor_rsp;
return rmf;
}
int isis_fit_perform_fit (Isis_Fit_Type *f, void *clientdata, /*{{{*/
double *x, double *y, double *weights, unsigned int npts,
double *pars, unsigned int npars, double *statistic)
{
Isis_Fit_Engine_Type *e;
double *save_pars = NULL;
int status;
if (f == NULL)
return -1;
e = f->engine;
if (NULL == (save_pars = (double *) ISIS_MALLOC (npars * sizeof(double))))
return -1;
memcpy ((char *)save_pars, (char *)pars, npars * sizeof(double));
status = e->method (f, clientdata, x, y, weights, npts, pars, npars);
*statistic = f->statistic;
/* validate returned parameter values */
if (isis_invalid_params (e, pars, npars))
{
memcpy ((char *)pars, (char *)save_pars, npars * sizeof(double));
*statistic = DBL_MAX;
status = -1;
}
ISIS_FREE(save_pars);
return status;
}
static void lu_solve_intrin (void)
{
Linear_System_Type t;
SLang_Array_Type *sl_b = NULL;
unsigned int *piv = NULL;
if ((-1 == pop_linear_system (&t))
|| (NULL == (piv = (unsigned int *) ISIS_MALLOC (t.n * sizeof(unsigned int)))))
{
isis_throw_exception (Isis_Error);
goto the_return;
}
if (-1 == isis_lu_solve (t.a, t.n, piv, t.b))
goto the_return;
sl_b = SLang_create_array (SLANG_DOUBLE_TYPE, 0, NULL, &t.n, 1);
if (sl_b != NULL)
{
memcpy ((char *)sl_b->data, (char *)t.b, t.n * sizeof (double));
}
the_return:
SLang_push_array (sl_b, 1);
free_linear_system (&t);
ISIS_FREE(piv);
}
int Rmf_id_list (Isis_Rmf_t *head, unsigned int **ids, unsigned int *num) /*{{{*/
{
Isis_Rmf_t *r;
unsigned int n;
*ids = NULL;
*num = 0;
if (head == NULL)
return 0;
for (r = head->next; r != NULL; r = r->next)
{
*num += 1;
}
if (*num == 0)
return 0;
if (NULL == (*ids = (unsigned int *) ISIS_MALLOC (*num * sizeof (unsigned int))))
return -1;
n = 0;
for (r = head->next; r != NULL; r = r->next)
{
(*ids)[n++] = r->index;
}
return 0;
}
static int compute_gainshift_kernel (Isis_Kernel_t *k, double *result, Isis_Hist_t *g, double *par, unsigned int num, /*{{{*/
int (*fun)(Isis_Hist_t *))
{
Isis_Rmf_t *rmf = k->rsp.rmf;
double *ylo=NULL, *yhi=NULL;
double *tmp, *shift_lo, *shift_hi;
double r0 = par[0]/KEV_ANGSTROM, slope = par[1];
unsigned int i, len, n;
int status = -1;
if (-1 == compute_kernel (k, result, g, par, num, fun))
return -1;
if ((par[0] < 0) || (par[1] == 0.0))
{
isis_vmesg(FAIL, I_ERROR, __FILE__, __LINE__,
"gainshift kernel: parameters (%g, %g) define an invalid grid",
par[0], par[1]);
return -1;
}
if (-1 == rmf->get_data_grid (rmf, &ylo, &yhi, &n, NULL))
return -1;
len = 3 * n * sizeof(double);
if (NULL == (tmp = (double *) ISIS_MALLOC (len)))
goto return_error;
shift_lo = tmp + n;
shift_hi = tmp + 2*n;
#define NEW_LAMBDA(y) (1.0/(1.0/y/slope - r0))
shift_lo[0] = NEW_LAMBDA(ylo[0]);
for (i = 1; i < n; i++)
{
shift_lo[i] = NEW_LAMBDA(ylo[i]);
shift_hi[i-1] = shift_lo[i];
}
shift_hi[n-1] = NEW_LAMBDA(yhi[n-1]);
if (-1 == rebin_histogram (result, ylo, yhi, n,
tmp, shift_lo, shift_hi, n))
{
ISIS_FREE(tmp);
isis_vmesg(FAIL, I_ERROR, __FILE__, __LINE__,
"gainshift kernel failed while rebinning histogram");
goto return_error;
}
memcpy ((char *)result, (char *)tmp, n * sizeof(double));
ISIS_FREE(tmp);
status = 0;
return_error:
ISIS_FREE(ylo);
ISIS_FREE(yhi);
return status;
}
static int cash_function (Isis_Fit_Statistic_Type *st, /*{{{*/
double *y, double *fx, double *w, unsigned int npts,
double *vec, double *stat)
{
double sum, s, *val;
unsigned int i;
(void) w;
(void) st;
sum = 0.0;
if (NULL == (val = (double *) ISIS_MALLOC (npts * sizeof(double))))
return -1;
/* The form of the statistic is modified according to the
* suggestion of Castor described in the XSPEC manual.
*/
for (i = 0; i < npts; i++)
{
double fxi = fx[i];
double yi = y[i];
double log_fxi;
/* Want sum += (yi - fxi) + yi * log (fxi/yi);
* but must avoid log(0) and f/0
*/
if (yi <= 0) yi = 1.e-5;
log_fxi = (fxi > 0) ? log(fxi) : (double) DBL_MIN_10_EXP;
s = (yi - fxi);
s += yi * (log_fxi - log (yi));
s *= -2;
/* sum += s; */
val[i] = s;
vec[i] = isfinite(s) ? (s * SIGN(yi-fxi)) : DBL_MAX;
}
sum = isis_kahan_sum (val, npts);
ISIS_FREE(val);
if (0 == isfinite (sum))
sum = DBL_MAX;
*stat = sum;
return 0;
}
Isis_Kernel_Def_t * Fit_new_kernel (void) /*{{{*/
{
Isis_Kernel_Def_t *def;
if (NULL == (def = (Isis_Kernel_Def_t *) ISIS_MALLOC (sizeof(Isis_Kernel_Def_t))))
return NULL;
memset ((char *)def, 0, sizeof(*def));
def->fun_type = UINT_MAX;
def->kernel_id = UINT_MAX;
def->malloced_kernel = 1;
def->next = NULL;
return def;
}
static Kernel_Info_t *new_kernel_info (int hist_index) /*{{{*/
{
Kernel_Info_t *p;
p = (Kernel_Info_t *) ISIS_MALLOC (sizeof(Kernel_Info_t));
if (p)
{
p->next = NULL;
p->saved = NULL;
p->kernel_params = NULL;
p->hist_index = hist_index;
p->kernel_id = 0;
}
return p;
}
static int init_buf (Buffer_Type *b) /*{{{*/
{
enum {DEFAULT_BUFSIZE = 8192};
if (b->bufsize)
return 0;
b->buf = (char *) ISIS_MALLOC (DEFAULT_BUFSIZE * sizeof(char));
if (b->buf == NULL)
return -1;
b->bufsize = DEFAULT_BUFSIZE;
b->len = 0;
return 0;
}
/**
* isis_update_option_string assumes that *optstring starts with a name
* from which the first updatable option is separated by a ';',
* in order to prevent, e.g.,
* isis_update_option_string ("simann;initial_step=0.05;t=1.0", "t", "2")
* to produce
* *optstring = "simann;init=2;t=1.0"
*/
int isis_update_option_string (char **optstring, char *optname, char *optvalue)
{
char *start, *end, *newstring, *s;
int len12, len3, len4;
if (optstring == NULL || optname == NULL)
return -1;
/* *optstring = $12 + $3 + $4
* where $12 = $prefix + ";" + $optname
* $3 = "=" + $optvalue
* (opt.) $4 = ";" + $suffix
*/
/* find option */
start = *optstring;
do
if (NULL == (start = strstr (start+1, optname)))
return -1;
while (*(start-1) != ';');
/* NULL means this option appears last */
end = strchr (start, ';');
len12 = start - *optstring + strlen(optname);
len3 = optvalue ? strlen(optvalue) + 1 : 0;
len4 = end ? strlen (end) : 0;
if (NULL == (newstring = (char *) ISIS_MALLOC (len12 + len3 + len4 + 1)))
return -1;
s = isis_strcpy (newstring, *optstring, len12);
if (len3 > 0)
{
sprintf (s, "=%s", optvalue);
s += len3;
}
if (len4 > 0)
{
s = isis_strcpy (s, end, len4 + 1);
}
ISIS_FREE (*optstring);
*optstring = newstring;
return 0;
}
static Isis_Fit_Engine_Type *add_slang_fit_engine (char *eng_name, char *stat_name) /*{{{*/
{
Isis_Fit_Engine_Type *e;
if (NULL == (e = (Isis_Fit_Engine_Type *) ISIS_MALLOC (sizeof(Isis_Fit_Engine_Type))))
return NULL;
memset ((char *)e, 0, sizeof (*e));
if ((NULL == (e->engine_name = isis_make_string (eng_name)))
|| (NULL == (e->default_statistic_name = isis_make_string (stat_name))))
{
slfe_deallocate (e);
ISIS_FREE (e);
return NULL;
}
e->method = &slfe_optimize;
e->deallocate = &slfe_deallocate;
e->set_options = &slfe_set_options;
e->set_range_hook = NULL;
e->range_hook = NULL;
e->verbose_hook = NULL;
e->warn_hook = NULL;
if (NULL == (e->sl_optimize = SLang_pop_function ()))
{
slfe_deallocate (e);
return NULL;
}
if (SLANG_NULL_TYPE == SLang_peek_at_stack())
SLdo_pop();
else if (NULL == (e->sl_set_options = SLang_pop_function ()))
{
slfe_deallocate (e);
return NULL;
}
if (NULL == (e->option_string = isis_make_string (eng_name)))
{
slfe_deallocate (e);
return NULL;
}
return e;
}
char *isis_add_option (char *subsystem, char *option)
{
unsigned int len;
char *s;
if (option == NULL)
option = "";
if (subsystem == NULL)
subsystem = "";
len = strlen (subsystem) + strlen (option) + 2;
if (NULL == (s = (char *) ISIS_MALLOC (len * sizeof(char))))
return s;
sprintf (s, "%s;%s", subsystem, option);
return s;
}
char *isis_make_default_option_string (const char *subsystem, Isis_Option_Table_Type *table)
{
Isis_Option_Table_Type *t;
char *s, *ps;
int len, o;
/* start with subsystem name */
len = strlen(subsystem);
for (t = table; t->optname != NULL; t++)
{
/* semicolon + option name */
len += strlen(t->optname) + 1;
if (t->default_value_string != NULL)
{
/* equals-sign plus option value */
len += strlen(t->default_value_string) + 1;
}
}
/* trailing null */
len += 1;
if (NULL == (s = (char *) ISIS_MALLOC(len*sizeof *s)))
return NULL;
o = sprintf (s, "%s", subsystem);
ps = s + o;
for (t = table; t->optname != NULL; t++)
{
char *name = t->optname;
char *value = t->default_value_string;
if (value == NULL)
o = sprintf (ps, ";%s", name);
else
o = sprintf (ps, ";%s=%s", name, value);
ps += o;
}
return s;
}
static Model_t *new_model_node (void) /*{{{*/
{
Model_t *m;
if (NULL == (m = (Model_t *) ISIS_MALLOC (sizeof(Model_t))))
return NULL;
memset ((char *) m, 0, sizeof(*m));
m->id = 1;
m->next = NULL;
m->metal_abund = 1.0;
m->redshift = 0.0;
m->line_flux = NULL;
m->last_ionpop = NULL;
memset ((char *) m->rel_abund, 0, (ISIS_MAX_PROTON_NUMBER+1)*sizeof(float));
return m;
}
static Isis_Fit_Statistic_Type *init_sl_statistic (void) /*{{{*/
{
SLang_Name_Type *statistic_fun, *report_fun;
Isis_Fit_Statistic_Type *s;
if (NULL == (s = (Isis_Fit_Statistic_Type *) ISIS_MALLOC (sizeof(Isis_Fit_Statistic_Type))))
return NULL;
memset ((char *)s, 0, sizeof (*s));
if (NULL == (report_fun = SLang_pop_function ()))
{
ISIS_FREE (s);
return NULL;
}
if (NULL == (statistic_fun = SLang_pop_function ()))
{
ISIS_FREE (s);
SLang_free_function (report_fun);
return NULL;
}
if (NULL == (s->symbol = isis_make_string (statistic_fun->name)))
{
ISIS_FREE(s);
SLang_free_function (report_fun);
SLang_free_function (statistic_fun);
return NULL;
}
s->compute_statistic = sl_statistic_function;
s->deallocate = sl_deallocate_function;
s->report = sl_report_function;
s->sl_fun = statistic_fun;
s->sl_report = report_fun;
return s;
}
int isis_fit_add_statistic (char *name, Isis_Fit_Statistic_Init_Type *init) /*{{{*/
{
Statistic_List_Type *s;
if ((name == NULL)
|| (init == NULL))
return -1;
if (NULL == (s = (Statistic_List_Type *) ISIS_MALLOC (sizeof *s)))
return -1;
memset ((char *)s, 0, sizeof (*s));
if (NULL == (s->sname = isis_make_string (name)))
{
free_statistic_type (s);
return -1;
}
if (NULL == (s->stat = (*init)()))
{
free_statistic_type (s);
return -1;
}
/* Keep a read-only backup copy of the s->fun pointer
* so we can temporarily over-write it and then restore
* the original (e.g. to introduce Lagrange multiplier
* constraints).
*/
s->stat->assigned_fun = s->stat->compute_statistic;
s->next = Statistic_List;
Statistic_List = s;
return 0;
}
Isis_Option_Type *isis_parse_option_string (char *str)
{
unsigned int num;
Isis_Option_Type *t;
char *estr;
if (NULL == (t = (Isis_Option_Type *) ISIS_MALLOC (sizeof(Isis_Option_Type))))
return NULL;
memset ((char *) t, 0, sizeof (Isis_Option_Type));
if (str == NULL)
str = "";
str = isis_skip_whitespace (str);
if (NULL == (str = isis_make_string (str)))
{
ISIS_FREE (t);
return NULL;
}
t->subsystem = str;
/* Now skip to the first field */
str = skip_and_truncate_field (str, FIELD_SEP_CHAR);
unescape_and_trim_string (t->subsystem);
/* Count the number of commas as an estimate on the number of fields */
/* Allow for a final NULL. */
num = 2;
estr = str;
while (NULL != (estr = strchr (estr, FIELD_SEP_CHAR)))
{
num++;
estr++;
}
if (NULL == (t->option_names = (char **) ISIS_MALLOC (num * sizeof(char *))))
{
isis_free_options (t);
return NULL;
}
if (NULL == (t->option_values = (char **) ISIS_MALLOC (num * sizeof(char *))))
{
isis_free_options (t);
return NULL;
}
/* Ok, now get the options */
num = 0;
while (1)
{
str = isis_skip_whitespace (str);
if (*str == 0)
break;
t->option_names[num] = str;
estr = skip_and_truncate_field (str, FIELD_SEP_CHAR);
/* Now look for = form */
str = skip_and_truncate_field (str, '=');
str = isis_skip_whitespace (str);
if (*str == 0)
t->option_values[num] = NULL;
else
t->option_values[num] = str;
unescape_and_trim_string (t->option_names[num]);
unescape_and_trim_string (t->option_values[num]);
str = estr;
num++;
}
t->option_values [num] = NULL;
t->option_names [num] = NULL;
t->num_options = num;
return t;
}
static void make_2d_histogram (int *reverse) /*{{{*/
{
SLang_Array_Type *grid_x, *grid_y, *sl_x, *sl_y, *b;
SLang_Array_Type *rev;
double *x, *y, *bx, *by;
double xmax, ymax;
SLindex_Type *num;
SLindex_Type dims[2];
SLindex_Type i, n, nx, ny, nbins;
SLindex_Type *r = NULL;
grid_x = grid_y = sl_x = sl_y = b = rev = NULL;
if (-1 == pop_two_darrays (&grid_x, &grid_y))
goto push_result;
/* need at least 1 point */
if ((-1 == pop_two_darrays (&sl_x, &sl_y))
|| (sl_x->num_elements != sl_y->num_elements)
|| (sl_x->num_elements < 1))
goto push_result;
n = sl_x->num_elements;
nx = grid_x->num_elements;
ny = grid_y->num_elements;
if (*reverse == 0)
r = NULL;
else
{
if (NULL == (r = (SLindex_Type *) ISIS_MALLOC (n * sizeof (SLindex_Type))))
{
isis_throw_exception (Isis_Error);
goto push_result;
}
for (i = 0; i < n; i++)
{
r[i] = -1;
}
}
dims[0] = nx;
dims[1] = ny;
nbins = dims[0] * dims[1];
if (NULL == (b = SLang_create_array (SLANG_INT_TYPE, 0, NULL, dims, 2)))
{
isis_throw_exception (Isis_Error);
goto push_result;
}
num = (SLindex_Type *)b->data;
memset ((char *)num, 0, nbins * sizeof(SLindex_Type));
bx = (double *)sl_x->data;
by = (double *)sl_y->data;
x = (double *)grid_x->data;
y = (double *)grid_y->data;
xmax = x[nx-1];
ymax = y[ny-1];
for (i = 0; i < n; i++)
{
double b_x = bx[i];
double b_y = by[i];
SLindex_Type ix, iy, k;
if (b_x >= xmax)
ix = nx-1;
else if ((ix = find_bin (b_x, x, x+1, nx-1)) < 0)
continue;
if (b_y >= ymax)
iy = ny-1;
else if ((iy = find_bin (b_y, y, y+1, ny-1)) < 0)
continue;
k = iy + ny * ix;
num[k] += 1;
if (r != NULL) r[i] = k;
}
if ((r != NULL)
&& (NULL == (rev = convert_reverse_indices (r, n, nx*ny))))
goto push_result;
push_result:
SLang_free_array (sl_x);
SLang_free_array (sl_y);
SLang_free_array (grid_x);
SLang_free_array (grid_y);
ISIS_FREE(r);
SLang_push_array (b, 1);
SLang_push_array (rev, 1);
}
static void make_1d_histogram (int *reverse) /*{{{*/
{
SLang_Array_Type *v, *lo, *hi, *b, *rev;
double *xlo, *xhi, *bv;
unsigned int *num;
SLindex_Type i, n, nbins;
SLindex_Type *r = NULL;
v = lo = hi = b = rev = NULL;
if ((-1 == pop_two_darrays (&lo, &hi))
|| -1 == SLang_pop_array_of_type (&v, SLANG_DOUBLE_TYPE)
|| (v == NULL))
goto push_result;
if (lo->num_elements != hi->num_elements)
{
isis_vmesg (INTR, I_ERROR, __FILE__, __LINE__, "inconsistent array sizes");
goto push_result;
}
n = v->num_elements;
nbins = lo->num_elements;
if (n < 1 || nbins < 1)
goto push_result;
if (*reverse == 0)
r = NULL;
else
{
if (NULL == (r = (SLindex_Type *) ISIS_MALLOC (n * sizeof(SLindex_Type))))
{
isis_throw_exception (Isis_Error);
goto push_result;
}
for (i = 0; i < n; i++)
r[i] = -1;
}
if (NULL == (b = SLang_create_array (SLANG_INT_TYPE, 0, NULL, &nbins, 1)))
{
isis_throw_exception (Isis_Error);
goto push_result;
}
num = (unsigned int *)b->data;
memset ((char *)num, 0, nbins * sizeof(unsigned int));
bv = (double *)v->data;
xlo = (double *)lo->data;
xhi = (double *)hi->data;
/* If the (lo,hi) grid has holes, this algorithm will
* give the wrong answer because every item will go
* into a bin. But what if the grid has holes by
* accident because it was poorly constructed?
* Perhaps that is a strong reason to deprecate this
* interface.
*/
for (i = 0; i < n; i++)
{
double t = bv[i];
int k = find_bin (t, xlo, xhi, (int) nbins);
if (k >= 0)
{
num[k] += 1;
if (r != NULL) r[i] = k;
}
}
if ((r != NULL)
&& (NULL == (rev = convert_reverse_indices (r, n, nbins))))
goto push_result;
push_result:
SLang_free_array (v);
SLang_free_array (hi);
SLang_free_array (lo);
ISIS_FREE(r);
SLang_push_array (b, 1);
SLang_push_array (rev, 1);
}
int Plot_set_library_interface (void) /*{{{*/
{
Plot_Library_Interface_Type *pli;
int status = -1;
if (NULL == (pli = (Plot_Library_Interface_Type *) ISIS_MALLOC (sizeof *pli)))
return -1;
if (-1 == SLang_pop_cstruct ((VOID_STAR)pli, Plot_Library_Interface_Table))
{
isis_vmesg (INTR, I_FAILED, __FILE__, __LINE__, "couldn't set library interface");
return -1;
}
#define PLI_SET(field) \
do { \
if (pli->field##_ref == NULL) \
goto return_status; \
else { \
pli->field = SLang_get_fun_from_ref (pli->field##_ref); \
if (pli->field == NULL) \
goto return_status; \
} \
} while (0)
PLI_SET(open);
PLI_SET(close);
PLI_SET(subdivide);
PLI_SET(select_window);
PLI_SET(select_viewport);
PLI_SET(set_plot_limits);
PLI_SET(query_plot_limits);
PLI_SET(erase);
PLI_SET(update);
PLI_SET(next_page);
PLI_SET(get_color);
PLI_SET(set_color);
PLI_SET(set_line_style);
PLI_SET(set_clipping);
PLI_SET(set_line_width);
PLI_SET(plot_xy);
PLI_SET(plot_points);
PLI_SET(plot_symbol_points);
PLI_SET(plot_histogram);
PLI_SET(plot_y_errorbar);
PLI_SET(set_viewer_size);
PLI_SET(set_char_size);
PLI_SET(draw_box);
PLI_SET(label_axes);
PLI_SET(put_text_xy);
PLI_SET(put_text_offset);
PLI_SET(default_axis);
PLI_SET(configure_axis);
PLI_SET(read_cursor);
#undef PLI_SET
Plot_free_library_interface ();
PLI = pli;
status = 0;
return_status:
if (status)
{
SLang_free_cstruct ((VOID_STAR)pli, Plot_Library_Interface_Table);
ISIS_FREE(pli);
}
return status;
}
int Model_spectrum (Model_t *h, Model_Info_Type *info, /*{{{*/
double *wllo, double *wlhi, int nbins, double *val)
{
Model_t *m;
EM_cont_type_t *cont = NULL;
double *tmp_val = NULL;
float *ionpop_new = NULL;
char *flag = NULL;
int i, cont_nbins, include_lines, include_contin, ret = -1;
SLindex_Type db_nlines;
if (NULL == h || NULL == info)
return -1;
if (NULL == val || NULL == wllo || NULL == wlhi || nbins < 1)
return -1;
if (NULL == info->em || NULL == info->db)
return -1;
switch (info->contrib_flag)
{
case MODEL_LINES_AND_CONTINUUM:
include_lines = 1;
include_contin = 1;
break;
case MODEL_LINES:
include_lines = 1;
include_contin = 0;
break;
case MODEL_CONTIN:
case MODEL_CONTIN_PSEUDO:
case MODEL_CONTIN_TRUE:
include_lines = 0;
include_contin = 1;
break;
default:
isis_vmesg (WARN, I_INVALID, __FILE__, __LINE__, "contrib_flag=%d; using default",
info->contrib_flag);
info->contrib_flag = MODEL_LINES_AND_CONTINUUM;
include_lines = 1;
include_contin = 1;
break;
}
memset ((char *)val, 0, nbins * sizeof(double));
/* add_spread_lines has side effect of incrementing these
* fluxes -- so zero them out first.
*/
if (-1 == DB_zero_line_flux (info->db))
return -1;
if (-1 == (db_nlines = DB_get_nlines (info->db)))
return -1;
if ((info->line_list != NULL) && (info->line_list->data_type != SLANG_NULL_TYPE))
{
int *line_list = (int *) info->line_list->data;
int num_lines = info->line_list->num_elements;
if (num_lines > 0)
{
flag = DB_flag_array_from_list (line_list, num_lines, info->db);
if (NULL == flag)
return -1;
}
}
if (info->ionpop_modifier != NULL)
{
int n = ISIS_MAX_PROTON_NUMBER+1;
if (NULL == (ionpop_new = (float *) ISIS_MALLOC (n*n*sizeof(float))))
goto finish;
memset ((char *)ionpop_new, 0, n*n*sizeof(float));
}
if ((NULL == (cont = EM_new_continuum (nbins)))
|| (NULL == (tmp_val = (double *) ISIS_MALLOC (nbins * sizeof(double)))))
goto finish;
cont_nbins = cont->nbins;
/* 1) Shift the input observer frame grid into the source frame
* 2) Compute the emissivity in each rest-frame bin
* 3) Shift the emissivity in each bin back to the observer frame,
* (just the time-dilation factor, since I'm assuming that
* the model values are photons/sec/whatever
* NOT ergs/sec/whatever!).
*/
for (m = h; m != NULL; m = m->next)
{
EM_line_emis_t *emis_list = NULL;
double *val_ptr;
if (isis_user_break())
{
ret = 0;
goto finish;
}
if (m->line_flux == NULL)
{
if (NULL == (m->line_flux = SLang_create_array (SLANG_FLOAT_TYPE, 1, NULL, &db_nlines, 1)))
goto finish;
}
memset ((char *)m->line_flux->data, 0, db_nlines * sizeof(float));
if (m->norm == 0)
continue;
if (m->redshift != 0.0)
{
memset ((char *)tmp_val, 0, nbins * sizeof(double));
val_ptr = tmp_val;
}
else val_ptr = val;
if (-1 == shift_grid_to_emitter_frame (cont, wllo, wlhi, m->redshift))
goto finish;
if (info->ionpop_modifier != NULL)
{
if (-1 == call_ionpop_modifier (m, info, ionpop_new))
goto finish;
}
if (include_lines)
{
emis_list = EM_get_line_spectrum (flag, m->temperature, m->density, ionpop_new, info->em);
if (NULL == emis_list)
goto finish;
if (-1 == add_spread_lines (val_ptr, cont->wllo, cont->wlhi, cont->nbins,
emis_list, m, info))
goto finish;
EM_free_line_emis_list (emis_list);
emis_list = NULL;
}
if (include_contin)
{
EM_cont_select_t s;
double m_norm;
double *c_val, *p_val;
s.Z = 0; s.q = -1; s.rel_abun = m->rel_abund;
if (-1 == EM_get_continuum (cont, m->temperature, m->density, ionpop_new, &s, info->em))
goto finish;
m_norm = m->norm;
switch (info->contrib_flag)
{
case MODEL_CONTIN_TRUE:
c_val = cont->true_contin;
for (i = 0; i < cont_nbins; i++)
val_ptr[i] += m_norm * c_val[i];
break;
case MODEL_CONTIN_PSEUDO:
c_val = cont->pseudo;
for (i = 0; i < cont_nbins; i++)
val_ptr[i] += m_norm * c_val[i];
break;
default:
c_val = cont->true_contin;
p_val = cont->pseudo;
for (i = 0; i < cont_nbins; i++)
val_ptr[i] += m_norm * (c_val[i] + p_val[i]);
break;
}
}
if (m->redshift != 0.0)
{
float gm = lorentz_gamma (m->redshift);
for (i = 0; i < cont_nbins; i++)
val[i] += tmp_val[i] / gm;
}
}
ret = 0;
finish:
if (ret)
isis_vmesg (FAIL, I_FAILED, __FILE__, __LINE__, "computing model spectrum");
ISIS_FREE (ionpop_new);
ISIS_FREE (flag);
ISIS_FREE (tmp_val);
EM_free_continuum (cont);
return ret;
}
static int compute_yshift_kernel (Isis_Kernel_t *k, double *result, Isis_Hist_t *g, double *par, unsigned int num, /*{{{*/
int (*fun)(Isis_Hist_t *))
{
Isis_Rmf_t *rmf = k->rsp.rmf;
double *ylo=NULL, *yhi=NULL;
double dy = par[0];
unsigned int n;
int status = -1;
if (-1 == compute_kernel (k, result, g, par, num, fun))
return -1;
if (dy == 0.0)
return 0;
if (-1 == rmf->get_data_grid (rmf, &ylo, &yhi, &n, NULL))
return -1;
if (ylo[0] + dy > 0.0)
{
double *tmp, *shift_lo, *shift_hi;
unsigned int i, len;
len = 3 * n * sizeof(double);
if (NULL == (tmp = (double *) ISIS_MALLOC (len)))
goto return_error;
shift_lo = tmp + n;
shift_hi = tmp + 2*n;
/* dy > 0 moves features to longer wavelengths */
shift_lo[0] = ylo[0] - dy;
for (i = 1; i < n; i++)
{
shift_lo[i] = ylo[i] - dy;
shift_hi[i-1] = shift_lo[i];
}
shift_hi[n-1] = yhi[n-1] - dy;
if (-1 == rebin_histogram (result, ylo, yhi, n,
tmp, shift_lo, shift_hi, n))
{
ISIS_FREE(tmp);
isis_vmesg(FAIL, I_ERROR, __FILE__, __LINE__,
"shift kernel failed while rebinning histogram");
goto return_error;
}
memcpy ((char *)result, (char *)tmp, n * sizeof(double));
ISIS_FREE(tmp);
}
else
{
isis_vmesg(FAIL, I_ERROR, __FILE__, __LINE__, "offset=%g yields invalid grid", dy);
goto return_error;
}
status = 0;
return_error:
ISIS_FREE(ylo);
ISIS_FREE(yhi);
return status;
}
static int match_arf_grid (Isis_Kernel_t *k, Isis_Rsp_t *rsp, Isis_Hist_t *g, Isis_Hist_t *m) /*{{{*/
{
Isis_Arf_t *a;
double *g_val, *m_val;
int i;
g_val = m_val = NULL;
/* When there's only one ARF, the model is computed on that grid.
* If we've got multiple responses, we interpolate the model
* onto the current ARF grid
*/
if (k->rsp.next == NULL)
{ /* easy case: The model is on the ARF grid */
m->val = g->val;
m->notice_list = g->notice_list;
m->n_notice = g->n_notice;
return 0;
}
/* harder case: map the model onto the ARF grid */
a = rsp->arf;
m->nbins = a->nbins;
m->bin_lo = a->bin_lo;
m->bin_hi = a->bin_hi;
m->n_notice = 0;
m->val = NULL;
m->notice = NULL;
m->notice_list = NULL;
if ((NULL == (m_val = (double *) ISIS_MALLOC (m->nbins * sizeof(double))))
|| (NULL == (m->notice = (int *) ISIS_MALLOC (m->nbins * sizeof(int))))
|| (NULL == (g_val = (double *) ISIS_MALLOC (g->nbins * sizeof(double)))))
{
goto fail;
}
memset ((char *)m->notice, 0, m->nbins * sizeof(int));
memset ((char *)g_val, 0, g->nbins * sizeof(double));
if (-1 == unpack_noticed (g->val, g->notice_list, g->n_notice, g->nbins, g_val))
goto fail;
if ((-1 == rebin_histogram (g_val, g->bin_lo, g->bin_hi, g->nbins,
m_val, m->bin_lo, m->bin_hi, m->nbins))
|| (-1 == transfer_notice (g->bin_lo, g->bin_hi, g->notice_list, g->n_notice,
m->bin_lo, m->bin_hi, m->nbins, m->notice))
|| (-1 == _update_notice_list (m->notice, &m->notice_list, &m->n_notice, m->nbins)))
{
goto fail;
}
/* Finish by packing according to the notice list */
if (NULL == (m->val = (double *) ISIS_MALLOC (m->n_notice * sizeof(double))))
goto fail;
for (i = 0; i < m->n_notice; i++)
{
int n = m->notice_list[i];
m->val[i] = m_val[n];
}
ISIS_FREE (g_val);
ISIS_FREE (m_val);
ISIS_FREE (m->notice);
return 1;
fail:
ISIS_FREE (g_val);
ISIS_FREE (m_val);
ISIS_FREE (m->notice);
ISIS_FREE (m->val);
ISIS_FREE (m->notice_list);
m->n_notice = 0;
return -1;
}
Isis_Fit_Type *isis_fit_open_fit (char *name, char *sname, Isis_Fit_Fun_Type *fun, /*{{{*/
SLang_Name_Type *constraint_fun, int n)
{
Isis_Fit_Engine_Type *e;
Isis_Fit_Statistic_Type *s;
Isis_Fit_Type *f;
if (fun == NULL)
{
fprintf (stderr, "fit_open_fit: invalid parameters\n");
return NULL;
}
if (NULL == (e = isis_find_fit_engine (name)))
return NULL;
if ((sname == NULL)
|| (0 == strcmp (sname, "default")))
sname = e->default_statistic_name;
if (NULL == (s = isis_find_fit_statistic (sname)))
{
fprintf (stderr, "fit_open_fit: statistic %s does not exist\n", sname);
return NULL;
}
if (NULL == (f = (Isis_Fit_Type *) ISIS_MALLOC (sizeof(Isis_Fit_Type))))
return NULL;
if (s->uses_opt_data)
{
if (NULL == (s->opt_data = allocate_statistic_opt_data (n)))
{
ISIS_FREE(f);
return NULL;
}
}
/* When a constraint function is provided, we call it
* by introducing an extra indirection. When the
* constraint is removed, we restore the original
* function pointer.
*/
if (constraint_fun)
{
s->constraint_fun = constraint_fun;
s->compute_statistic = &penalty_statistic;
}
else
{
s->constraint_fun = NULL;
s->compute_statistic = s->assigned_fun;
}
f->compute_model = fun;
f->engine = e;
f->stat = s;
f->statistic = DBL_MAX;
f->covariance_matrix = NULL;
Isis_Fit_In_Progress = 1;
return f;
}
/* cols[] must be sorted in increasing order and with no values repeated */
static int ascii_readcol (FILE *fp, unsigned int *cols, unsigned int ncols, /*{{{*/
double **px, unsigned int *pnx)
{
enum {START_ROWS = 1024};
const char *sepchars = " ,\t";
Buffer_Type b = {NULL, 0, 0};
unsigned int *last_col = cols + ncols;
unsigned int k, line, nx = START_ROWS * ncols;
double *x = NULL;
int ret = -1;
*px = NULL;
*pnx = 0;
if (ncols == 0)
return -1;
if (NULL == (x = (double *) ISIS_MALLOC (nx * sizeof(double))))
return -1;
k = 0;
line = 0;
do
{
unsigned int *want_col = NULL;
unsigned int c, k_save;
char *word = NULL;
int ch;
k_save = k;
if (-1 == (ch = readline (fp, &b)))
break;
line++;
if (ch == COMMENT_CHAR)
continue;
word = strtok (b.buf, sepchars);
want_col = cols;
c = 1;
while ((word != NULL) && (want_col < last_col))
{
if (c == *want_col)
{
double d;
if (1 != sscanf (word, "%le", &d))
{
char *p = strchr (word, '\n');
if (p) *p = 0;
isis_vmesg (FAIL, I_READ_FAILED, __FILE__, __LINE__, "invalid input: '%s'", word);
goto finish;
}
if (k >= nx)
{
unsigned int new_size = 2 * nx * sizeof(double);
double *tmp;
if (NULL == (tmp = (double *) ISIS_REALLOC (x, new_size)))
goto finish;
x = tmp;
nx *= 2;
}
x[k++] = d;
want_col++;
}
word = strtok (NULL, sepchars);
c++;
}
/* support skipping blank lines */
if ((want_col < last_col) && (c > 1))
{
isis_vmesg (FAIL, I_READ_FAILED, __FILE__, __LINE__, "at line %u: couldn't read all requested columns", line);
k = k_save;
break;
}
} while (!feof(fp));
ret = 0;
finish:
free_buf (&b);
if (ret)
ISIS_FREE (x);
else
{
*px = x;
*pnx = k;
}
return ret;
}
int Rmf_find_peaks (Isis_Rmf_t *rmf, double **h_P, int *num) /*{{{*/
{
double *arf_lo, *arf_hi, *ebounds_lo, *ebounds_hi, *profile;
unsigned int arf_n, ebounds_n, k;
unsigned int *indices;
int status = -1;
if (rmf == NULL || h_P == NULL || num == NULL)
return -1;
profile = arf_lo = arf_hi = ebounds_lo = ebounds_hi = NULL;
indices = NULL;
*h_P = NULL;
/* wavelength grids */
if ((-1 == rmf->get_arf_grid (rmf, &arf_lo, &arf_hi, &arf_n))
|| (-1 == rmf->get_data_grid (rmf, &ebounds_lo, &ebounds_hi, &ebounds_n, NULL)))
goto return_error;
*num = arf_n;
if ((NULL == (*h_P = (double *) ISIS_MALLOC (arf_n * sizeof(double))))
|| (NULL == (indices = (unsigned int *) ISIS_MALLOC (ebounds_n * sizeof(unsigned int))))
|| (NULL == (profile = (double *) ISIS_MALLOC (ebounds_n * sizeof(double)))))
goto return_error;
/* For each arf wavelength, fold a delta-function source
* through the rmf, find the peak in the output, and record
* the bin-center wavelength of that peak
*/
for (k = 0; k < arf_n; k++)
{
double peak_value;
unsigned int i, num_indices;
for (i = 0; i < ebounds_n; i++)
profile[i] = 0.0;
/* set default value */
(*h_P)[k] = (double) k;
if (-1 == rmf->redistribute (rmf, k, 1.0, profile, ebounds_n))
goto return_error;
peak_value = 0.0;
for (i = 0; i < ebounds_n; i++)
{
if (profile[i] > peak_value)
peak_value = profile[i];
}
if (peak_value == 0.0)
continue;
num_indices = 0;
for (i = 0; i < ebounds_n; i++)
{
if (profile[i] == peak_value)
indices[num_indices++] = i;
}
if (num_indices != 0)
{
#if 0
(*h_P)[k] = indices[num_indices/2];
#else
unsigned int hw = 3;
i = indices[num_indices/2];
if ((hw <= i) && (i + hw < ebounds_n))
{
double s, xp;
unsigned int j;
s = xp = 0.0;
for (j=i-hw; j<=i+hw; j++)
{
xp += j * profile[j];
s += profile[j];
}
(*h_P)[k] = xp / s;
}
#endif
}
}
status = 0;
return_error:
ISIS_FREE (indices);
ISIS_FREE (profile);
ISIS_FREE (arf_lo);
ISIS_FREE (arf_hi);
ISIS_FREE (ebounds_lo);
ISIS_FREE (ebounds_hi);
if ((status != 0) && (h_P != NULL))
ISIS_FREE (*h_P);
return status;
}
