Ejemplo n.º 1
0
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;
}
Ejemplo n.º 2
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;
}
Ejemplo n.º 3
0
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;
}
Ejemplo n.º 4
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;
}
Ejemplo n.º 5
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;
     }
}
Ejemplo n.º 6
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);
}
Ejemplo n.º 7
0
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
}
Ejemplo n.º 8
0
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;
}
Ejemplo n.º 9
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
}
Ejemplo n.º 10
0
static int double_pop (SLtype unused, VOID_STAR ptr)
{
    (void) unused;
    return SLang_pop_double ((double *) ptr);
}
Ejemplo n.º 11
0
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);
}
Ejemplo n.º 12
0
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;
}
Ejemplo n.º 13
0
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;
}