static int slfe_optimize (Isis_Fit_Type *ift, void *clientdata, /*{{{*/
double *x, double *y, double *weights, unsigned int npts,
double *pars, unsigned int npars)
{
Isis_Fit_Engine_Type *e;
SLang_Array_Type *sl_pars=NULL, *sl_pars_min=NULL, *sl_pars_max=NULL;
SLang_Array_Type *sl_new_pars=NULL;
SLindex_Type n;
int status = -1;
(void) clientdata; (void) x; (void) y; (void) weights; (void) npts;
if ((ift == NULL) || (pars == NULL) || (npars <= 0)
|| (Current_Fit_Object_MMT == NULL))
return -1;
e = ift->engine;
n = (SLindex_Type) npars;
sl_pars = SLang_create_array (SLANG_DOUBLE_TYPE, 0, NULL, &n, 1);
sl_pars_min = SLang_create_array (SLANG_DOUBLE_TYPE, 0, NULL, &n, 1);
sl_pars_max = SLang_create_array (SLANG_DOUBLE_TYPE, 0, NULL, &n, 1);
if ((NULL == sl_pars) || (NULL == sl_pars_min) || (NULL == sl_pars_max))
return -1;
memcpy ((char *)sl_pars->data, (char *)pars, npars * sizeof(double));
memcpy ((char *)sl_pars_min->data, (char *)e->par_min, npars * sizeof(double));
memcpy ((char *)sl_pars_max->data, (char *)e->par_max, npars * sizeof(double));
/* FIXME: Increment the reference count to prevent a segv.
* There must be a better way.
*/
SLang_inc_mmt (Current_Fit_Object_MMT);
SLang_start_arg_list ();
if ((-1 == SLang_push_mmt (Current_Fit_Object_MMT))
|| (-1 == SLang_push_array (sl_pars, 1))
|| (-1 == SLang_push_array (sl_pars_min, 1))
|| (-1 == SLang_push_array (sl_pars_max, 1)))
{
isis_vmesg (FAIL, I_FAILED, __FILE__, __LINE__,
"calling user-defined optimization method '%s'",
e->engine_name);
goto return_error;
}
SLang_end_arg_list ();
if (-1 == SLexecute_function (e->sl_optimize))
{
isis_vmesg (FAIL, I_FAILED, __FILE__, __LINE__,
"executing optimization method '%s'",
e->engine_name);
goto return_error;
}
if (-1 == SLang_pop_array_of_type (&sl_new_pars, SLANG_DOUBLE_TYPE))
{
isis_vmesg (FAIL, I_FAILED, __FILE__, __LINE__,
"returning results from optimization method '%s'",
e->engine_name);
goto return_error;
}
if ((sl_new_pars == NULL) || (sl_new_pars->num_elements != npars))
{
isis_vmesg (FAIL, I_ERROR, __FILE__, __LINE__,
"corrupted parameter array returned from optimization method '%s'",
e->engine_name);
goto return_error;
}
memcpy ((char *)pars, (char *)sl_new_pars->data, npars * sizeof(double));
status = 0;
return_error:
SLang_free_array (sl_new_pars);
if (SLang_get_error())
{
isis_throw_exception (SLang_get_error());
return -1;
}
return status;
}
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);
}
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 int sl_statistic_function (Isis_Fit_Statistic_Type *s,/*{{{*/
double *y, double *fx, double *w, unsigned int npts,
double *vec, double *stat)
{
SLang_Array_Type *a_fx, *a_w, *a_y, *sl_vec;
SLindex_Type n;
double st;
int ret = -1;
*stat = -1.0;
if (s == NULL || s->sl_fun == NULL)
return -1;
sl_vec = NULL;
a_fx = a_w = a_y = NULL;
n = npts;
st = -1.0;
if ((NULL == (a_y = SLang_create_array (SLANG_DOUBLE_TYPE, 0, NULL, &n, 1)))
|| (NULL == (a_fx = SLang_create_array (SLANG_DOUBLE_TYPE, 0, NULL, &n, 1)))
|| ((NULL == (a_w = SLang_create_array (SLANG_DOUBLE_TYPE, 0, NULL, &n, 1)))))
goto free_and_return;
memcpy (a_y->data, y, npts*sizeof(double));
memcpy (a_fx->data, fx, npts*sizeof(double));
memcpy (a_w->data, w, npts*sizeof(double));
/* (vec, stat) = slang_statistic (y, fx, w)
* OR, if opt_data is used:
* (vec, stat) = slang_statistic (y, fx, w, opt_data)
*/
SLang_start_arg_list ();
if ((-1 == SLang_push_array (a_y, 0))
|| (-1 == SLang_push_array (a_fx, 0))
|| (-1 == SLang_push_array (a_w, 0))
|| ((s->uses_opt_data != 0) && (-1 == push_opt_data (s->opt_data))))
goto free_and_return;
SLang_end_arg_list ();
if (-1 != SLexecute_function (s->sl_fun))
{
(void) SLang_pop_double (&st);
if ((-1 == SLang_pop_array_of_type (&sl_vec, SLANG_DOUBLE_TYPE))
|| (sl_vec == NULL)
|| (sl_vec->num_elements != npts))
{
isis_throw_exception (Isis_Error);
}
else
{
ret = 0;
memcpy ((char *)vec, (char *)sl_vec->data, npts * sizeof(double));
}
}
/* drop */
free_and_return:
SLang_free_array (a_y);
SLang_free_array (a_fx);
SLang_free_array (a_w);
SLang_free_array (sl_vec);
*stat = st;
return ret;
}
