int SLang_pop_complex (double *r, double *i)
{
double *c;
switch (SLang_peek_at_stack ())
{
case SLANG_COMPLEX_TYPE:
if (-1 == SLclass_pop_ptr_obj (SLANG_COMPLEX_TYPE, VOID_STAR_STAR(&c)))
return -1;
*r = c[0];
*i = c[1];
SLfree ((char *) c);
break;
default:
*i = 0.0;
if (-1 == SLang_pop_double (r))
return -1;
break;
case -1:
return -1;
}
return 0;
}
/* usage here is a1 a2 ... an n x ==> a1x^n + a2 x ^(n - 1) + ... + an */
static double math_poly (void)
{
int n;
double xn = 1.0, sum = 0.0;
double an, x;
if ((SLang_pop_double(&x))
|| (SLang_pop_integer(&n))) return(0.0);
while (n-- > 0)
{
if (SLang_pop_double(&an)) break;
sum += an * xn;
xn = xn * x;
}
return (double) sum;
}
int SLang_pop_float (float *x)
{
double d;
/* Pop it as a double and let the double function do all the typcasting */
if (-1 == SLang_pop_double (&d))
return -1;
*x = (float) d;
return 0;
}
static int get_tolorances (int nargs, Feqs_Err_Type *ep)
{
switch (nargs)
{
case 2:
if ((-1 == SLang_pop_double (&ep->abserr))
|| (-1 == SLang_pop_double (&ep->relerr)))
return -1;
break;
case 1:
if (-1 == SLang_pop_double (&ep->relerr))
return -1;
ep->abserr = 0.0;
break;
default:
ep->relerr = 0.01;
ep->abserr = 1e-6;
break;
}
return 0;
}
static int pop_array_or_scalar (Array_Or_Scalar_Type *ast)
{
SLang_Array_Type *at;
ast->at = NULL;
ast->inc = 0;
ast->num = 1;
switch (SLang_peek_at_stack1 ())
{
case -1:
return -1;
case SLANG_FLOAT_TYPE:
ast->is_float = 1;
if (SLang_peek_at_stack () == SLANG_ARRAY_TYPE)
{
if (-1 == SLang_pop_array_of_type (&at, SLANG_FLOAT_TYPE))
return -1;
ast->fptr = (float *) at->data;
ast->inc = 1;
ast->num = at->num_elements;
ast->at = at;
return 0;
}
ast->fptr = &ast->f;
if (-1 == SLang_pop_float (ast->fptr))
return -1;
return 0;
default:
ast->is_float = 0;
if (SLang_peek_at_stack () == SLANG_ARRAY_TYPE)
{
if (-1 == SLang_pop_array_of_type (&at, SLANG_DOUBLE_TYPE))
return -1;
ast->dptr = (double *) at->data;
ast->inc = 1;
ast->num = at->num_elements;
ast->at = at;
return 0;
}
ast->dptr = &ast->d;
if (-1 == SLang_pop_double (ast->dptr))
return -1;
return 0;
}
}
static void nint_intrin (void)
{
double x;
SLang_Array_Type *at, *bt;
int (*at_to_int_fun)(SLang_Array_Type *, SLang_Array_Type *);
if (SLang_peek_at_stack () != SLANG_ARRAY_TYPE)
{
if (-1 == SLang_pop_double (&x))
return;
(void) SLang_push_int (do_nint (x));
return;
}
switch (SLang_peek_at_stack1 ())
{
case -1:
return;
case SLANG_INT_TYPE:
return;
case SLANG_FLOAT_TYPE:
if (-1 == SLang_pop_array_of_type (&at, SLANG_FLOAT_TYPE))
return;
at_to_int_fun = float_to_nint;
break;
case SLANG_DOUBLE_TYPE:
default:
if (-1 == SLang_pop_array_of_type (&at, SLANG_DOUBLE_TYPE))
return;
at_to_int_fun = double_to_nint;
break;
}
if (NULL == (bt = SLang_create_array1 (SLANG_INT_TYPE, 0, NULL, at->dims, at->num_dims, 1)))
{
SLang_free_array (at);
return;
}
if (0 == (*at_to_int_fun) (at, bt))
(void) SLang_push_array (bt, 0);
SLang_free_array (bt);
SLang_free_array (at);
}
static double _ftime_cmd (void)
{
double e = 0.0;
if (SLang_Num_Function_Args == 1)
{
if (-1 == SLang_pop_double (&e))
return -1.0;
}
# ifdef HAVE_GETTIMEOFDAY
{
struct timeval tv;
(void) gettimeofday (&tv, NULL);
return (tv.tv_sec - e) + 1e-6*tv.tv_usec;
}
# else
return (double)time(NULL) - e;
# endif
}
static int apply_line_modifier (Model_t *m, Model_Info_Type *info, DB_line_t *line, double *emis) /*{{{*/
{
Plasma_State_Type lm_state;
lm_state.temperature = m->temperature;
lm_state.ndensity = m->density;
SLang_start_arg_list ();
SLang_push_array (info->line_emis_modifier_params, 0);
SLang_push_int (line->indx);
if (-1 == SLang_push_cstruct ((VOID_STAR)&lm_state, Plasma_State_Layout))
return -1;
SLang_push_double (*emis);
if (info->line_emis_modifier_args != NULL)
isis_push_args (info->line_emis_modifier_args);
if (info->line_emis_modifier_qualifiers == NULL)
{
SLang_end_arg_list ();
if (-1 == SLexecute_function (info->line_emis_modifier))
return -1;
}
else
{
if ((-1 == SLang_push_function (info->line_emis_modifier))
|| (-1 == SLang_push_struct (info->line_emis_modifier_qualifiers)))
return -1;
SLang_end_arg_list ();
if (-1 == SLang_execute_function ("_isis->do_eval_with_qualifiers"))
return -1;
}
if (-1 == SLang_pop_double (emis))
return -1;
return 0;
}
static void sleep_cmd (void)
{
unsigned int secs;
#if SLANG_HAS_FLOAT
unsigned long usecs;
double x;
if (-1 == SLang_pop_double (&x))
return;
if (x < 0.0)
x = 0.0;
secs = (unsigned int) x;
sleep (secs);
x -= (double) secs;
usecs = (unsigned long) (1e6 * x);
if (usecs > 0) _pSLusleep (usecs);
#else
if (-1 == SLang_pop_uinteger (&secs))
return;
if (secs != 0) sleep (secs);
#endif
}
static int double_pop (SLtype unused, VOID_STAR ptr)
{
(void) unused;
return SLang_pop_double ((double *) ptr);
}
static void setitimer_intrinsic (void)
{
SLang_Ref_Type *interval_ref = NULL, *value_ref = NULL;
int w;
struct itimerval new_value, old_value;
double interval = 0.0, value;
int argc = SLang_Num_Function_Args;
if (SLang_peek_at_stack () == SLANG_REF_TYPE)
{
if (-1 == SLang_pop_ref (&value_ref))
return;
argc--;
if (SLang_peek_at_stack() == SLANG_REF_TYPE)
{
interval_ref = value_ref;
if (-1 == SLang_pop_ref (&value_ref))
goto free_and_return;
argc--;
}
}
switch (argc)
{
case 3:
if (-1 == SLang_pop_double (&interval))
goto free_and_return;
/* drop */
case 2:
default:
if ((-1 == SLang_pop_double (&value))
|| (-1 == SLang_pop_int (&w)))
goto free_and_return;
}
double_to_timeval (interval, &new_value.it_interval);
double_to_timeval (value, &new_value.it_value);
if (-1 == setitimer (w, &new_value, &old_value))
{
SLerrno_set_errno (errno);
SLang_verror (SL_OS_Error, "setitimer failed: %s", SLerrno_strerror (errno));
goto free_and_return;
}
if (value_ref != NULL)
{
value = timeval_to_double (&old_value.it_value);
if (-1 == SLang_assign_to_ref (value_ref, SLANG_DOUBLE_TYPE, &value))
goto free_and_return;
}
if (interval_ref != NULL)
{
interval = timeval_to_double (&old_value.it_interval);
if (-1 == SLang_assign_to_ref (interval_ref, SLANG_DOUBLE_TYPE, &interval))
goto free_and_return;
}
free_and_return:
if (value_ref != NULL)
SLang_free_ref (value_ref);
if (interval_ref != NULL)
SLang_free_ref (interval_ref);
}
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;
}
static int penalty_statistic (Isis_Fit_Statistic_Type *st, /*{{{*/
double *y, double *fx, double *w,
unsigned int npts, double *vec, double *stat)
{
SLang_Array_Type *sl_pars = NULL;
double *pars = NULL;
double old_stat, new_stat, penalty, b, vec_penalty;
SLindex_Type num;
unsigned int i, n;
if (-1 == (*st->assigned_fun)(st, y, fx, w, npts, vec, stat))
return -1;
if (st->constraint_fun == NULL)
return 0;
if (-1 == Fit_copy_fun_params ("constraint", 1, &pars, &n))
return -1;
num = n;
if (num > 0)
{
sl_pars = SLang_create_array (SLANG_DOUBLE_TYPE, 0, pars, &num, 1);
if (NULL == sl_pars)
return -1;
}
old_stat = *stat;
SLang_start_arg_list ();
/* NULL sl_pars is ok */
if ((-1 == SLang_push_double (*stat))
|| (-1 == SLang_push_array (sl_pars, 0)))
{
SLang_end_arg_list ();
SLang_free_array (sl_pars);
return -1;
}
SLang_end_arg_list ();
if ((-1 == SLexecute_function ((SLang_Name_Type *)st->constraint_fun))
|| -1 == SLang_pop_double (&new_stat))
{
isis_vmesg (FAIL, I_FAILED, __FILE__, __LINE__, "evaluating fit-constraint function");
SLang_free_array (sl_pars);
return -1;
}
SLang_free_array (sl_pars);
*stat = new_stat;
/* The penalty must also affect the vector statistic somehow.
* Try spreading it uniformly over all bins, assuming that
* the base statistic is the Euclidean norm = sum (vec^2);
* We want to define:
* new_vec = old_vec + vec_penalty
* so that
* new_stat = sum(new_vec^2) = old_stat + penalty.
*
* FIXME? This seems ok for chi-square, but perhaps something
* different would be better for max. likelihood or cash statistic?
* Maybe the statistic object should have a vec_penalty() method?
*/
b = 2 * isis_kahan_sum (vec, npts) / npts;
penalty = new_stat - old_stat;
vec_penalty = -0.5*b + sqrt (0.25*b*b + penalty / npts);
for (i = 0; i < npts; i++)
{
vec[i] += vec_penalty;
}
return 0;
}
