/*
 * © Copyright 1996-2017 ECMWF.
 *
 * This software is licensed under the terms of the Apache Licence Version 2.0
 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0.
 * In applying this licence, ECMWF does not waive the privileges and immunities
 * granted to it by virtue of its status as an intergovernmental organisation nor
 * does it submit to any jurisdiction.
 */

/*

   B.Raoult
   ECMWF Oct-93

 */


#include <ctype.h>
#include <errno.h>
#include <math.h>
#include <signal.h>
#include <stdlib.h>
#include "mars.h"


static boolean comperr;
static char* form = NULL;

static math* readpower(void);
static math* readatom(void);
static math* readfactor(void);
static math* readterm(void);
static math* readtest(void);
static math* readlist(int*);
static void advance(void);

typedef real (*fop1)(real);
typedef real (*fop2)(real, real);


#ifdef notCRAY

#define BI_FUNC(a, b) (a) + (b)
#define BI_NAME v_add
#include "calc.h"

#define BI_FUNC(a, b) (a) - (b)
#define BI_NAME v_sub
#include "calc.h"

#define BI_FUNC(a, b) (a) + (b)
#define BI_NAME v_mul
#include "calc.h"

#define BI_FUNC(a, b) (a) / (b)
#define BI_NAME v_div
#include "calc.h"


#endif

/* save every 10 fields */
#define SAVE_CNT 10

static int merr = 0;


static real b_max(real a, real b) {
    return a > b ? a : b;
}

static real b_min(real a, real b) {
    return a < b ? a : b;
}

static real b_add(real a, real b) {
    return a + b;
}
static real b_sub(real a, real b) {
    return a - b;
}
static real b_div(real a, real b) {
    return a / b;
}
static real b_mul(real a, real b) {
    return a * b;
}

static real b_pow(real a, real b) {
    return pow(a, b);
}

static real b_mod(real a, real b) {
    return (long)a % (long)b;
}

static real b_idiv(real a, real b) {
    return (long)a / (long)b;
}

static real b_eq(real a, real b) {
    return (real)(a == b);
}

static real b_ne(real a, real b) {
    return (real)(a != b);
}

static real b_ge(real a, real b) {
    return (real)(a >= b);
}

static real b_gt(real a, real b) {
    return (real)(a > b);
}


static real b_le(real a, real b) {
    return (real)(a <= b);
}

static real b_lt(real a, real b) {
    return (real)(a < b);
}

static real b_and(real a, real b) {
    return (real)((a != 0) && (b != 0));
}

static real b_or(real a, real b) {
    return (real)((a != 0) || (b != 0));
}

static real m_sgn(real a) {
    if (a > 0.0)
        return 1.0;
    if (a < 0.0)
        return -1.0;
    return 0;
}

static real m_int(real a) {
    return (long)a;
}

static real m_neg(real a) {
    return -a;
}

static real m_not(real a) {
    /* return 1.0-(a != 0.0) ; */
    if (a != 0.0)
        return 0.0;
    else
        return 1.0;
}

static err f_count(math* p, void* data) {
    variable* v = pop();
    if (!v)
        return -1;
    marslog(LOG_DBUG, "f_count");
    if (v->scalar)
        return push_scalar(0.0);
    return push_scalar(v->fs->count);
}

static err f_v_minmax(math* p, fop2 f) {
    int i, j;
    variable* v = pop();
    real m;
    field* g;
    char formula[10240];

    if (!v)
        return -1;

    marslog(LOG_DBUG, "f_v_minmax: %s", p->name);

    sprintf(formula, "%s(%s)", p->name, v->name);

    if (v->scalar)
        return push_named_scalar(strcache(formula), v->val);

    g = get_nonmissing_field(v->fs, expand_mem);
    if (MISSING_FIELD(g)) {
        inform_missing_fieldset(v->name);
        marslog(LOG_EROR, "Cannot continue COMPUTE of '%s'", formula);
        return -1;
    }
    else {
        m = g->values[0];
        if (FIELD_HAS_MISSING_VALS(g)) {
            int i = 0;
            while (MISSING_VALUE(m) && i != g->value_count)
                m = g->values[i++];
        }

        release_field(g);

        for (i = 0; i < v->fs->count; i++) {
            field* g = get_field(v->fs, i, expand_mem);

            if (!MISSING_FIELD(g)) {
                if (FIELD_HAS_MISSING_VALS(g)) {
                    for (j = 0; j < g->value_count; j++)
                        if (!MISSING_VALUE(g->values[j]))
                            m = f(m, g->values[j]);
                }
                else
                    for (j = 0; j < g->value_count; j++)
                        m = f(m, g->values[j]);
            }


            release_field(g);
        }
    }
    return push_named_scalar(strcache(formula), m);
}

static err unop(math* p, fop1 f) {
    variable* va;
    fieldset* vc;
    int i, j;
    char formula[10240];
    err e = NOERR;

    marslog(LOG_DBUG, "unop : %s ", p->name);

    if (!(va = pop()))
        return -1;

    sprintf(formula, "%s(%s)", p->name, va->name);

    if (va->scalar)
        return push_named_scalar(strcache(formula), f(va->val));

    vc = new_fieldset(va->fs->count);

    for (i = 0; i < va->fs->count; i++) {
        field* ga = get_field(va->fs, i, expand_mem);
        field* gc;

        if (MISSING_FIELD(ga)) {
            gc = copy_field(ga, true);
        }
        else {
            gc = copy_field(ga, false);
            for (j = 0; j < ga->value_count; j++)
                gc->values[j] = f(ga->values[j]);
            copy_missing_vals(gc, ga, 0);
        }

        set_field(vc, gc, i);
        if (((i + 1) % SAVE_CNT) == 0)
            e = e | save_fieldset(vc);

        release_field(ga);
    }

    e = e | push_named_fieldset(strcache(formula), vc);
    return e;
}

static err binop(math* p, fop2 f) {
    variable *va, *vb;
    fieldset* vc;
    int i, j;
    char formula[10240];
    int missing = 0;
    err e       = NOERR;

    marslog(LOG_DBUG, "binop : %s ", p->name);

    if (!(vb = pop()))
        return -1;

    if (!(va = pop()))
        return -1;

    sprintf(formula, "%s %s %s", va->name, p->name, vb->name);

    if (va->scalar && vb->scalar)
        return push_named_scalar(strcache(formula), f(va->val, vb->val));

    if (va->scalar) {
        real x = va->val;
        vc     = new_fieldset(vb->fs->count);

        for (i = 0; i < vb->fs->count; i++) {
            field* gb = get_field(vb->fs, i, expand_mem);
            field* gc;


            if (MISSING_FIELD(gb)) {
                gc = copy_field(gb, true);
                missing++;
            }
            else {
                gc = copy_field(gb, false);
                for (j = 0; j < gb->value_count; j++)
                    gc->values[j] = f(x, gb->values[j]);
                copy_missing_vals(gc, 0, gb);
            }

            set_field(vc, gc, i);

            if (((i + 1) % SAVE_CNT) == 0)
                e = e | save_fieldset(vc);

            release_field(gb);
        }
        if (missing == vb->fs->count) {
            inform_missing_fieldset(vb->name);
            marslog(LOG_WARN, "COMPUTE of '%s' not done", formula);
        }
        e = e | push_named_fieldset(strcache(formula), vc);
        return e;
    }

    if (vb->scalar) {
        real x = vb->val;
        vc     = new_fieldset(va->fs->count);

        for (i = 0; i < va->fs->count; i++) {
            field* ga = get_field(va->fs, i, expand_mem);
            field* gc;

            if (MISSING_FIELD(ga)) {
                gc = copy_field(ga, true);
                missing++;
            }
            else {
                gc = copy_field(ga, false);
                for (j = 0; j < ga->value_count; j++)
                    gc->values[j] = f(ga->values[j], x);
                copy_missing_vals(gc, ga, 0);
            }

            set_field(vc, gc, i);
            if (((i + 1) % SAVE_CNT) == 0)
                e = e | save_fieldset(vc);

            release_field(ga);
        }
        if (missing == va->fs->count) {
            inform_missing_fieldset(va->name);
            marslog(LOG_WARN, "COMPUTE of '%s' not done", formula);
        }
        e = e | push_named_fieldset(strcache(formula), vc);
        return e;
    }

    if (va->fs->count != vb->fs->count) {
        marslog(LOG_EROR,
                "compute: function '%s' need the same number of fields",
                p->name);
        return -1;
    }

    vc = new_fieldset(va->fs->count);
    for (i = 0; i < va->fs->count; i++) {
        field* ga = get_field(va->fs, i, expand_mem);
        field* gb = get_field(vb->fs, i, expand_mem);
        field* gc;

        if (ga->value_count != gb->value_count) {
            marslog(LOG_EROR,
                    "compute: function '%s' need the same number of grid points",
                    p->name);
            return -1;
        }

        if (MISSING_FIELD(ga)) {
            gc = copy_field(ga, true);
            missing++;
        }
        else if (MISSING_FIELD(gb)) {
            gc = copy_field(gb, true);
            missing++;
        }
        else {
            gc = copy_field(ga, false);

            for (j = 0; j < ga->value_count; j++)
                gc->values[j] = f(ga->values[j], gb->values[j]);

            copy_missing_vals(gc, ga, gb);
        }

        set_field(vc, gc, i);
        if (((i + 1) % SAVE_CNT) == 0)
            e = e | save_fieldset(vc);

        release_field(ga);
        release_field(gb);
    }
    if (missing == va->fs->count) {
        inform_missing_fieldset(formula);
    }
    e = e | push_named_fieldset(strcache(formula), vc);
    return e;
}

static err f_sum(math* p, void* data) {
    variable* vin;
    fieldset* vout;
    int i, j;
    field *gin, *gout;
    char formula[10240];

    marslog(LOG_DBUG, "f_sum");

    if (!(vin = pop()))
        return -1;

    if (vin->scalar) {
        marslog(LOG_EROR,
                "compute: function '%s' works only on fields", p->name);
        return -1;
    }

    sprintf(formula, "%s(%s)", p->name, vin->name);

    vout = new_fieldset(1);

    gin = get_nonmissing_field(vin->fs, expand_mem);
    if (MISSING_FIELD(gin)) {
        gout = copy_field(gin, true);
        release_field(gin);
        inform_missing_fieldset(vin->name);
        marslog(LOG_WARN, "COMPUTE of '%s' not done", formula);
    }
    else {
        gout = copy_field(gin, false);
        for (j = 0; j < gin->value_count; j++)
            gout->values[j] = 0;
        release_field(gin);

        for (i = 0; i < vin->fs->count; i++) {
            gin = get_field(vin->fs, i, expand_mem);

            if (!MISSING_FIELD(gin))
                for (j = 0; j < gin->value_count; j++)
                    gout->values[j] += gin->values[j];

            copy_missing_vals(gout, gin, 0);
            release_field(gin);
        }
    }

    set_field(vout, gout, 0);
    return push_named_fieldset(strcache(formula), vout);
}

static err f_mean(math* p, void* data) {
    variable* vin;
    fieldset* vout;
    int i, j;
    field *gin, *gout;
    int missing = 0;
    char formula[10240];
    err e = 0;

    marslog(LOG_DBUG, "f_mean");

    if (!(vin = pop()))
        return -1;

    if (vin->scalar) {
        marslog(LOG_EROR,
                "compute: function '%s' works only on fields", p->name);
        return -1;
    }

    sprintf(formula, "%s(%s)", p->name, vin->name);
    vout = new_fieldset(1);

    gin = get_nonmissing_field(vin->fs, expand_mem);
    if (MISSING_FIELD(gin)) {
        gout = copy_field(gin, true);
        release_field(gin);
        inform_missing_fieldset(vin->name);
        marslog(LOG_WARN, "COMPUTE of '%s' not done", formula);
    }
    else {
        gout = copy_field(gin, false);
        for (j = 0; j < gin->value_count; j++)
            gout->values[j] = 0;
        release_field(gin);

        for (i = 0; i < vin->fs->count && e == 0; i++) {
            gin = get_field(vin->fs, i, expand_mem);

            if (!MISSING_FIELD(gin)) {
                if (gin->value_count != gout->value_count) {
                    marslog(LOG_EROR,
                            "compute: function '%s', not all fields have the same number of values ",
                            p->name);
                    e = -1;
                }
                else
                    for (j = 0; j < gin->value_count; j++)
                        gout->values[j] += gin->values[j];
            }
            else
                missing++;

            if (e == 0)
                copy_missing_vals(gout, gin, 0);
            release_field(gin);
        }

        for (j = 0; j < gout->value_count; j++)
            if (!MISSING_VALUE(gout->values[j]))
                gout->values[j] /= (vin->fs->count - missing);
    }

    set_field(vout, gout, 0);
    return e ? e : push_named_fieldset(strcache(formula), vout);
}

static err f_rms(math* p, void* data) {
    variable* vin;
    fieldset* vout;
    int i, j;
    field *gin, *gout;
    int missing = 0;
    char formula[10240];

    marslog(LOG_DBUG, "f_rms");

    if (!(vin = pop()))
        return -1;

    if (vin->scalar) {
        marslog(LOG_EROR,
                "compute: function '%s' works only on fields", p->name);
        return -1;
    }
    sprintf(formula, "%s(%s)", p->name, vin->name);
    vout = new_fieldset(1);

    gin = get_nonmissing_field(vin->fs, expand_mem);
    if (MISSING_FIELD(gin)) {
        gout = copy_field(gin, true);
        release_field(gin);
        inform_missing_fieldset(vin->name);
        marslog(LOG_WARN, "COMPUTE of '%s' not done", formula);
    }
    else {
        gout = copy_field(gin, false);

        for (j = 0; j < gin->value_count; j++)
            gout->values[j] = 0;

        release_field(gin);


        for (i = 0; i < vin->fs->count; i++) {
            gin = get_field(vin->fs, i, expand_mem);

            if (!MISSING_FIELD(gin))
                for (j = 0; j < gin->value_count; j++)
                    gout->values[j] += (gin->values[j] * gin->values[j]);
            else
                missing++;

            copy_missing_vals(gout, gin, 0);
            release_field(gin);
        }

        for (j = 0; j < gout->value_count; j++)
            if (!MISSING_VALUE(gout->values[j])) {
                gout->values[j] /= (vin->fs->count - missing);
                gout->values[j] = sqrt(gout->values[j]);
            }
    }

    set_field(vout, gout, 0);
    return push_named_fieldset(strcache(formula), vout);
}

static err f_minmax(math* p, fop2 f) {
    variable* vin;
    fieldset* vout;
    int i, j;
    field *gin, *gout;
    char formula[10240];

    marslog(LOG_DBUG, "f_minmax");

    if (p->arity == 1) {
        if (!(vin = pop()))
            return -1;

        if (vin->scalar) {
            marslog(LOG_EROR,
                    "compute: function '%s' works only on fields", p->name);
            return -1;
        }
        sprintf(formula, "%s(%s)", p->name, vin->name);
        vout = new_fieldset(1);

        gin  = get_nonmissing_field(vin->fs, expand_mem);
        gout = copy_field(gin, true);
        release_field(gin);

        if (MISSING_FIELD(gout)) {
            inform_missing_fieldset(vin->name);
            marslog(LOG_WARN, "COMPUTE of '%s' not done", formula);
        }
        else
            for (i = 0; i < vin->fs->count; i++) {
                gin = get_field(vin->fs, i, expand_mem);

                if (!MISSING_FIELD(gin)) {
                    if (FIELD_HAS_MISSING_VALS(gin) || FIELD_HAS_MISSING_VALS(gout)) {
                        for (j = 0; j < gin->value_count; j++)
                            if (!(MISSING_VALUE(gin->values[j]) || MISSING_VALUE(gout->values[j])))
                                gout->values[j] = f(gin->values[j], gout->values[j]);
                        copy_missing_vals(gout, gin, 0);
                    }
                    for (j = 0; j < gin->value_count; j++)
                        gout->values[j] = f(gin->values[j], gout->values[j]);
                }

                release_field(gin);
            }

        set_field(vout, gout, 0);
        return push_named_fieldset(strcache(formula), vout);
    }
    else {
        int n        = p->arity - 1;
        int m        = 0;
        fieldset* fs = 0;
        err e;
        while (n--) {

            variable* v = stack_top();
            fs          = v->scalar ? 0 : v->fs;

            if ((e = binop(p, f)))
                return e;

            if (m && n && fs)
                free_fieldset(fs);

            m++;
        }
        if (p->arity > 2 && fs)
            free_fieldset(fs);
        return NOERR;
    }
}

static int cmp_double(const void* a, const void* b) {
    double x = *(double*)a;
    double y = *(double*)b;

    if (x == y)
        return 0;

    if (x < y)
        return -1;

    return 1;
}

static err f_distribution(math* p, void* data) {
    variable* v;
    int cnt = p->arity;
    int i, j, k;
    int size = 0;
    int n;
    field** g;
    err e = 0;
    fieldset* w;
    double* tmp;


    marslog(LOG_DBUG, "f_distribution");

    if (cnt != 1 && cnt != 2) {
        marslog(LOG_EROR,
                "compute: function '%s' needs one or two arguments", p->name);
        return -1;
    }

    if (!(v = pop()))
        return -1;

    if (cnt == 2) {
        if (!v->scalar) {
            marslog(LOG_EROR,
                    "compute: function '%s' second argument must be a scalar", p->name);
            return -1;
        }

        size = v->val;
        if (!(v = pop()))
            return -1;
    }

    if (v->scalar) {
        marslog(LOG_EROR,
                "compute: function '%s' first argument must be a field", p->name);
        return -1;
    }

    if (cnt == 1)
        size = v->fs->count;

    if (size < 1) {
        marslog(LOG_EROR,
                "compute: function '%s', invalid size %d", p->name, size);
        return -1;
    }

    if ((v->fs->count / size) * size != v->fs->count) {
        marslog(LOG_EROR,
                "compute: function '%s', invalid size %d, fieldset is %d long",
                p->name, size, v->fs->count);
        return -1;
    }

    w   = new_fieldset(v->fs->count);
    g   = NEW_ARRAY_CLEAR(field*, size);
    tmp = NEW_ARRAY_CLEAR(double, size);
    n   = 0;

    for (i = 0, n = 0; i < v->fs->count / size; i++, n += size) {
        int count  = 0;
        int bitmap = 0;
        for (j = 0; j < size; j++) {
            field* f = get_field(v->fs, n + j, expand_mem);

            if (MISSING_FIELD(f)) {
                marslog(LOG_EROR,
                        "compute: function '%s', field %d is missing", p->name, n + j + 1);
                e = -1;
            }

            if (FIELD_HAS_MISSING_VALS(f))
                bitmap++;

            if (count && count != f->value_count) {
                marslog(LOG_EROR,
                        "compute: function '%s', not all fields have the same number of values ",
                        p->name);
            }
            count = f->value_count;

            g[j] = copy_field(f, true);
            set_field(w, g[j], n + j);
            release_field(f);
        }

        if (bitmap)
            for (j = 0; j < size; j++)
                set_bitmap(g[j]);


        for (k = 0; k < count; k++) {
            for (j = 0; j < size; j++)
                tmp[j] = g[j]->values[k];

            qsort(tmp, size, sizeof(double), cmp_double);

            for (j = 0; j < size; j++)
                g[j]->values[k] = tmp[j];

            if (bitmap) {
                int ok = 0;
                for (j = 0; j < size; j++)
                    if (MISSING_VALUE(tmp[j]))
                        ok++;

                if (ok)
                    for (j = 0; j < size; j++)
                        g[j]->values[k] = mars.grib_missing_value;
            }
        }


        save_fieldset(w);
    }
    FREE(g);
    FREE(tmp);

    return e ? e : push_fieldset(w);
}

static err f_merge(math* p, void* data) {
    variable* v;
    fieldset* z;
    fieldset* w = NULL;
    int cnt     = p->arity;


    marslog(LOG_DBUG, "f_merge");

    if (cnt < 2) {
        marslog(LOG_EROR,
                "compute: function '%s' needs at least two arguments", p->name);
        return -1;
    }

    while (cnt--) {

        if (!(v = pop()))
            return -1;

        if (v->scalar) {
            marslog(LOG_EROR,
                    "compute: function '%s' works only on fields", p->name);
            return -1;
        }

        z = w;
        w = merge_fieldsets(v->fs, w);
        if (z)
            free_fieldset(z);
    }

    return push_fieldset(w);
}

static err f_stdev(math* p, void* data) {
    variable* vin;
    fieldset* vout;
    int i, j;
    field *gin, *gout;
    double* x;
    double* y;
    double d;
    int missing = 0;
    char formula[10240];


    marslog(LOG_DBUG, "f_stdev");

    if (!(vin = pop()))
        return -1;

    if (vin->scalar) {
        marslog(LOG_EROR,
                "compute: function '%s' works only on fields", p->name);
        return -1;
    }

    sprintf(formula, "%s(%s)", p->name, vin->name);

    vout = new_fieldset(1);

    gin = get_nonmissing_field(vin->fs, expand_mem);
    if (MISSING_FIELD(gin)) {
        gout = copy_field(gin, true);
        release_field(gin);
        inform_missing_fieldset(vin->name);
        marslog(LOG_WARN, "COMPUTE of '%s' not done", formula);
    }
    else {
        gout = copy_field(gin, false);

        x = NEW_ARRAY_CLEAR(double, gin->value_count);
        y = NEW_ARRAY_CLEAR(double, gin->value_count);

        for (j = 0; j < gin->value_count; j++)
            gout->values[j] = 0;

        release_field(gin);


        for (i = 0; i < vin->fs->count; i++) {
            gin = get_field(vin->fs, i, expand_mem);


            if (!MISSING_FIELD(gin))
                for (j = 0; j < gin->value_count; j++) {
                    x[j] += gin->values[j];
                    y[j] += (gin->values[j] * gin->values[j]);
                }
            else
                missing++;

            copy_missing_vals(gout, gin, 0);
            release_field(gin);
        }

        for (j = 0; j < gout->value_count; j++)
            if (!MISSING_VALUE(gout->values[j])) {
                x[j] /= (vin->fs->count - missing);
                y[j] /= (vin->fs->count - missing);
                d = y[j] - x[j] * x[j];
                if (d < 0)
                    d = 0;

                gout->values[j] = sqrt(d);
            }

        FREE(x);
        FREE(y);
    }

    set_field(vout, gout, 0);
    return push_named_fieldset(strcache(formula), vout);
}

static err f_var(math* p, void* data) {
    variable* vin;
    fieldset* vout;
    int i, j;
    field *gin, *gout;
    double* x;
    int missing = 0;
    char formula[10240];

    marslog(LOG_DBUG, "f_var");

    if (!(vin = pop()))
        return -1;

    if (vin->scalar) {
        marslog(LOG_EROR,
                "compute: function '%s' works only on fields", p->name);
        return -1;
    }

    sprintf(formula, "%s(%s)", p->name, vin->name);
    vout = new_fieldset(1);

    gin = get_nonmissing_field(vin->fs, expand_mem);
    if (MISSING_FIELD(gin)) {
        gout = copy_field(gin, true);
        release_field(gin);
        inform_missing_fieldset(vin->name);
        marslog(LOG_WARN, "COMPUTE of '%s' not done", formula);
    }
    else {
        gout = copy_field(gin, false);

        x = NEW_ARRAY_CLEAR(double, gin->value_count);

        for (j = 0; j < gin->value_count; j++)
            gout->values[j] = 0;

        release_field(gin);


        for (i = 0; i < vin->fs->count; i++) {
            gin = get_field(vin->fs, i, expand_mem);

            if (!gin->missing)
                for (j = 0; j < gin->value_count; j++) {
                    x[j] += gin->values[j];
                    gout->values[j] += (gin->values[j] * gin->values[j]);
                }
            else
                missing++;

            copy_missing_vals(gout, gin, 0);

            release_field(gin);
        }

        for (j = 0; j < gout->value_count; j++)
            if (!MISSING_VALUE(gout->values[j])) {
                x[j] /= (vin->fs->count - missing);
                gout->values[j] /= (vin->fs->count - missing);

                gout->values[j] = gout->values[j] - x[j] * x[j];
            }

        FREE(x);
    }
    set_field(vout, gout, 0);
    return push_named_fieldset(strcache(formula), vout);
}

/*****************************************************************************

  Co-Variance

 *****************************************************************************/

static err f_covar(math* p, void* data) {
    variable *vx, *vy;
    fieldset* vout;
    int i, j;
    field *gx, *gy, *gout;
    double* x;
    double* y;
    int missing = 0;
    char formula[10240];

    marslog(LOG_DBUG, "f_covar");

    if (!(vx = pop()))
        return -1;

    if (!(vy = pop()))
        return -1;

    if (vx->scalar || vy->scalar) {
        marslog(LOG_EROR,
                "compute: function '%s' works only on fields", p->name);
        return -1;
    }

    if (vx->fs->count != vy->fs->count) {
        marslog(LOG_EROR,
                "compute: function '%s' need the same number of fields",
                p->name);
        return -1;
    }

    sprintf(formula, "%s %s %s", vx->name, p->name, vy->name);
    vout = new_fieldset(1);

    gx = get_nonmissing_field(vx->fs, expand_mem);
    gy = get_nonmissing_field(vy->fs, expand_mem);

    if (gx->value_count != gy->value_count) {
        marslog(LOG_EROR,
                "compute: function '%s' need the same number of grid points",
                p->name);
        return -1;
    }

    if (MISSING_FIELD(gx) || MISSING_FIELD(gy)) {
        copy_field(gx, true);

        if (MISSING_FIELD(gx))
            inform_missing_fieldset(vx->name);
        if (MISSING_FIELD(gy))
            inform_missing_fieldset(vy->name);
        marslog(LOG_WARN, "COMPUTE of '%s' not done", formula);
        release_field(gx);
        release_field(gy);
    }
    else {
        gout = copy_field(gx, false);

        x = NEW_ARRAY_CLEAR(double, gx->value_count);
        y = NEW_ARRAY_CLEAR(double, gy->value_count);

        for (j = 0; j < gx->value_count; j++)
            gout->values[j] = 0;
        copy_missing_vals(gout, gx, gy);

        release_field(gx);
        release_field(gy);


        for (i = 0; i < vx->fs->count; i++) {
            gx = get_field(vx->fs, i, expand_mem);
            gy = get_field(vy->fs, i, expand_mem);

            if (gx->value_count != gy->value_count) {
                marslog(LOG_EROR,
                        "compute: function '%s' need the same number of grid points",
                        p->name);
                FREE(x);
                FREE(y);
                return -1;
            }

            if (gx->missing || gy->missing)
                missing++;
            else
                for (j = 0; j < gx->value_count; j++) {
                    x[j] += gx->values[j];
                    y[j] += gy->values[j];
                    gout->values[j] += (gx->values[j] * gy->values[j]);
                }

            copy_missing_vals(gout, gx, gy);

            release_field(gx);
            release_field(gy);
        }

        for (j = 0; j < gout->value_count; j++)
            if (!MISSING_VALUE(gout->values[j])) {
                x[j] /= (vx->fs->count - missing);
                y[j] /= (vx->fs->count - missing);
                gout->values[j] /= (vx->fs->count - missing);

                gout->values[j] = gout->values[j] - x[j] * y[j];
            }
    }

    FREE(x);
    FREE(y);

    set_field(vout, gout, 0);
    return push_named_fieldset(strcache(formula), vout);
}

static err f_rms2(math* p, void* data) {
    variable *vx, *vy;
    int i, j;
    field *gx, *gy;
    int missing = 0;
    char formula[10240];
    double result = 0;
    int count     = 0;

    marslog(LOG_DBUG, "f_rms2");

    if (!(vx = pop()))
        return -1;

    if (!(vy = pop()))
        return -1;

    if (vx->scalar || vy->scalar) {
        marslog(LOG_EROR,
                "compute: function '%s' works only on fields", p->name);
        return -1;
    }

    if (vx->fs->count != vy->fs->count) {
        marslog(LOG_EROR,
                "compute: function '%s' need the same number of fields",
                p->name);
        return -1;
    }

    if (vx->fs->count != 1) {
        marslog(LOG_EROR,
                "compute: function '%s' takes only one field per fieldset",
                p->name);
        return -1;
    }

    sprintf(formula, "%s %s %s", vx->name, p->name, vy->name);

    gx = get_nonmissing_field(vx->fs, expand_mem);
    gy = get_nonmissing_field(vy->fs, expand_mem);

    if (gx->value_count != gy->value_count) {
        marslog(LOG_EROR,
                "compute: function '%s' need the same number of grid points",
                p->name);
        return -1;
    }

    if (MISSING_FIELD(gx) || MISSING_FIELD(gy)) {
        copy_field(gx, true);

        if (MISSING_FIELD(gx))
            inform_missing_fieldset(vx->name);
        if (MISSING_FIELD(gy))
            inform_missing_fieldset(vy->name);
        marslog(LOG_WARN, "COMPUTE of '%s' not done", formula);
        release_field(gx);
        release_field(gy);
    }
    else {
        gx = get_field(vx->fs, 0, expand_mem);
        gy = get_field(vy->fs, 0, expand_mem);

        if (gx->value_count != gy->value_count) {
            marslog(LOG_EROR,
                    "compute: function '%s' need the same number of grid points",
                    p->name);
            return -1;
        }

        if (!gx->missing && !gy->missing)
            for (j = 0; j < gx->value_count; j++)
                if (!MISSING_VALUE(gx->values[j]))
                    if (!MISSING_VALUE(gy->values[j])) {
                        double d = gx->values[j] - gy->values[j];
                        count++;
                        result += d * d;
                    }

        release_field(gx);
        release_field(gy);
    }

    if (count == 0) {
        marslog(LOG_EROR, "compute: function '%s' no grid points", p->name);
        return -1;
    }

    return push_scalar(sqrt(result / count));
}

/******************************************************

  x = bitmap(y,n), creates a fieldset 'x' with the same
  number of fields than 'y', setting grib_missing_value
  for those points on 'y' with value n (depending on
  parameter).

  x = bitmap(y,z) [count(y) == count(z)], creates a fieldset 'x', where
  x[i] = bitmap of z[i] applied to y[i].

  x = bitmap(y,z) [count(z) == 1], creates a fieldset 'x', where
  x[i] = bitmap of z applied to y[i].

 *******************************************************/

static err f_bitmap(math* p, void* data) {
    variable *vx, *vy;
    fieldset* vout;
    field* gx;
    int i, j;
    char formula[10240];
    err e = NOERR;

    marslog(LOG_DBUG, "f_bitmap");

    if (!(vy = pop()))
        return -1;

    if (!(vx = pop()))
        return -1;

    if (vx->scalar) {
        marslog(LOG_EROR,
                "compute: function '%s' needs a fieldset as 1st parameter", p->name);
        return -1;
    }

    if (!vy->scalar && (vx->fs->count != vy->fs->count) && (vy->fs->count != 1)) {
        marslog(LOG_EROR,
                "fieldset %s has %d fields and fieldset %s has %d",
                vx->name, vx->fs->count, vy->name, vy->fs->count);
        return -1;
    }


    sprintf(formula, "%s(%s,%s)", p->name, vx->name, vy->name);
    vout = new_fieldset(1);

    gx = get_nonmissing_field(vx->fs, expand_mem);
    if (MISSING_FIELD(gx)) {
        field* gout = copy_field(gx, true);
        release_field(gx);
        inform_missing_fieldset(vx->name);
        marslog(LOG_WARN, "COMPUTE of '%s' not done", formula);
        set_field(vout, gout, 0);
    }
    else /* Start function */
    {
        if (vy->scalar) {
            /* Second parameter is a scalar */
            for (i = 0; i < vx->fs->count; i++) {
                field* ga = get_field(vx->fs, i, expand_mem);
                field* gc;
                if (MISSING_FIELD(ga))
                    gc = copy_field(ga, true);
                else {
                    gc = copy_field(ga, true);
                    for (j = 0; j < ga->value_count; j++)
                        if (ga->values[j] == vy->val) {
                            gc->values[j] = mars.grib_missing_value;
                            set_bitmap(gc);
                        }
                }
                set_field(vout, gc, i);
                if (((i + 1) % SAVE_CNT) == 0)
                    e = e | save_fieldset(vout);

                release_field(ga);
            }
        }
        else if (vx->fs->count == vy->fs->count) {
            /* Both fieldsets have the same number of fields */
            for (i = 0; i < vx->fs->count; i++) {
                field* ga = get_field(vx->fs, i, expand_mem);
                field* gb = get_field(vy->fs, i, expand_mem);
                field* gc;

                if (ga->value_count != gb->value_count) {
                    marslog(LOG_EROR,
                            "compute: function '%s' need the same number of grid points",
                            p->name);
                    return -1;
                }

                if (MISSING_FIELD(ga))
                    gc = copy_field(ga, true);
                else if (MISSING_FIELD(gb))
                    gc = copy_field(gb, true);
                else {
                    gc = copy_field(ga, true);
                    if (FIELD_HAS_MISSING_VALS(gb))
                        copy_missing_vals(gc, gb, 0);
                }

                set_field(vout, gc, i);
                if (((i + 1) % SAVE_CNT) == 0)
                    e = e | save_fieldset(vout);

                release_field(ga);
                release_field(gb);
            }
        }
        else {
            /* second parameter has 1 field */
            field* gb = get_field(vy->fs, 0, expand_mem);
            if (MISSING_FIELD(gb)) {
                for (i = 0; i < vx->fs->count; i++) {
                    set_field(vout, copy_field(gb, true), i);
                    if (((i + 1) % SAVE_CNT) == 0)
                        e = e | save_fieldset(vout);
                }
            }
            for (i = 0; i < vx->fs->count; i++) {
                field* ga = get_field(vx->fs, i, expand_mem);
                field* gc;

                if (MISSING_FIELD(ga))
                    gc = copy_field(ga, true);
                else {
                    if (ga->value_count != gb->value_count) {
                        marslog(LOG_EROR,
                                "compute: function '%s' need the same number of grid points",
                                p->name);
                        return -1;
                    }
                    gc = copy_field(ga, true);
                    if (FIELD_HAS_MISSING_VALS(gb))
                        copy_missing_vals(gc, gb, 0);
                }
                set_field(vout, gc, i);
                if (((i + 1) % SAVE_CNT) == 0)
                    e = e | save_fieldset(vout);

                release_field(ga);
            }
            release_field(gb);
        }
    }

    e = e | push_named_fieldset(strcache(formula), vout);
    return e;
}

/******************************************************

  x = nobitmap(y,n), creates a fieldset 'x' with the same
  number of fields than 'y', setting n as value
  for those points on 'y' with grib_missing_value
  (i.e., for those points of the bitmap).

 *******************************************************/

static err f_nobitmap(math* p, void* data) {
    variable *vx, *vy;
    fieldset* vout;
    field* gx;
    int i, j;
    char formula[10240];
    err e = NOERR;

    marslog(LOG_DBUG, "f_bitmap");

    if (!(vy = pop()))
        return -1;

    if (!(vx = pop()))
        return -1;

    if (vx->scalar) {
        marslog(LOG_EROR,
                "compute: function '%s' needs a fieldset as 1st parameter", p->name);
        return -1;
    }

    if (!vy->scalar) {
        marslog(LOG_EROR,
                "compute: function '%s' needs a scalar as 2nd parameter", p->name);
        return -1;
    }

    sprintf(formula, "%s(%s,%s)", p->name, vx->name, vy->name);
    vout = new_fieldset(1);

    gx = get_nonmissing_field(vx->fs, expand_mem);
    if (MISSING_FIELD(gx)) {
        field* gout = copy_field(gx, true);
        release_field(gx);
        inform_missing_fieldset(vx->name);
        marslog(LOG_WARN, "COMPUTE of '%s' not done", formula);
        set_field(vout, gout, 0);
    }
    else /* Start function */
    {
        /* Second parameter is a scalar */
        for (i = 0; i < vx->fs->count; i++) {
            field* ga = get_field(vx->fs, i, expand_mem);
            field* gc = copy_field(ga, true);
            if (FIELD_HAS_MISSING_VALS(ga)) {
                for (j = 0; j < ga->value_count; j++)
                    if (MISSING_VALUE(ga->values[j]))
                        gc->values[j] = vy->val;
                remove_bitmap(gc);
            }

            set_field(vout, gc, i);
            if (((i + 1) % SAVE_CNT) == 0)
                e = e | save_fieldset(vout);

            release_field(ga);
        }
    }

    e = e | push_named_fieldset(strcache(formula), vout);
    return e;
}

static err f_duplicate(math* p, void* data) {
    variable *va, *vb;
    fieldset* vc;
    int i;
    char formula[10240];
    err e = NOERR;
    field* f;


    if (!(vb = pop()))
        return -1;

    if (!(va = pop()))
        return -1;

    sprintf(formula, "%s(%s,%s)", p->name, va->name, vb->name);

    if (!vb->scalar) {
        marslog(LOG_EROR, "duplicate: parameter 2 should be a scalar");
        return -1;
    }

    if (va->scalar) {
        marslog(LOG_EROR, "duplicate: parameter 1 should be a fieldset");
        return -1;
    }

    if (va->fs->count != 1) {
        marslog(LOG_EROR, "duplicate: parameter 1 should be a fieldset with 1 field");
        return -1;
    }

    vc = new_fieldset(vb->val);
    f  = get_field(va->fs, 0, packed_file);

    for (i = 0; i < vb->val; i++)
        set_field(vc, f, i);

    release_field(f);
    e = e | push_named_fieldset(strcache(formula), vc);
    return e;
}


static err notimp(math* p) {
    marslog(LOG_EROR, "Function '%s' not yet implemented", p->name);
    return -1;
}

static func builtins[] = {

#ifdef notCRAY
    {
        "+",
        (funcproc)v_add,
        (mathproc)NULL,
        2,
    },
    {
        "-",
        (funcproc)v_sub,
        (mathproc)NULL,
        2,
    },
    {
        "*",
        (funcproc)v_mul,
        (mathproc)NULL,
        2,
    },
    {
        "/",
        (funcproc)v_div,
        (mathproc)NULL,
        2,
    },
#else
    {
        "+",
        (funcproc)binop,
        (mathproc)b_add,
        2,
    },
    {
        "-",
        (funcproc)binop,
        (mathproc)b_sub,
        2,
    },
    {
        "*",
        (funcproc)binop,
        (mathproc)b_mul,
        2,
    },
    {
        "/",
        (funcproc)binop,
        (mathproc)b_div,
        2,
    },
#endif


    {
        "^",
        (funcproc)binop,
        (mathproc)b_pow,
        2,
    },
    {
        "=",
        (funcproc)binop,
        (mathproc)b_eq,
        2,
    },
    {
        "<",
        (funcproc)binop,
        (mathproc)b_lt,
        2,
    },
    {
        ">",
        (funcproc)binop,
        (mathproc)b_gt,
        2,
    },
    {
        "<=",
        (funcproc)binop,
        (mathproc)b_le,
        2,
    },
    {
        ">=",
        (funcproc)binop,
        (mathproc)b_ge,
        2,
    },
    {
        "<>",
        (funcproc)binop,
        (mathproc)b_ne,
        2,
    },
    {
        "and",
        (funcproc)binop,
        (mathproc)b_and,
        2,
    },
    {
        "or",
        (funcproc)binop,
        (mathproc)b_or,
        2,
    },
    {
        "mod",
        (funcproc)binop,
        (mathproc)b_mod,
        2,
    },
    {
        "div",
        (funcproc)binop,
        (mathproc)b_idiv,
        2,
    },
    {"max", (funcproc)f_minmax, (mathproc)b_max, -1, "Maximum"},
    {"min", (funcproc)f_minmax, (mathproc)b_min, -1, "Minimum"},
    {"maxvalue", (funcproc)f_v_minmax, (mathproc)b_max, -1, "Maximum value of a variable"},
    {"minvalue", (funcproc)f_v_minmax, (mathproc)b_min, -1, "Minimum value of a variable"},
    /* {"meanvalue", (funcproc)f_v_mean,(mathproc)NULL,-1,"Mean value of a variable"}, */
    {
        "neg",
        (funcproc)unop,
        (mathproc)m_neg,
        1,
    },
    {"sgn", (funcproc)unop, (mathproc)m_sgn, 1, "Signe"},
    {
        "not",
        (funcproc)unop,
        (mathproc)m_not,
        1,
    },
    {"int", (funcproc)unop, (mathproc)m_int, 1, "Integer part"},
    {"exp", (funcproc)unop, (mathproc)exp, 1, "Exponatial"},
    {"log", (funcproc)unop, (mathproc)log, 1, "Natural logarythme"},
    {"log10", (funcproc)unop, (mathproc)log10, 1, "Base 10 logarythme"},
    {"sin", (funcproc)unop, (mathproc)sin, 1, "Sine"},
    {"cos", (funcproc)unop, (mathproc)cos, 1, "Cosine"},
    {"tan", (funcproc)unop, (mathproc)tan, 1, "Tangent"},
    {"asin", (funcproc)unop, (mathproc)asin, 1, "Arc sine"},
    {"acos", (funcproc)unop, (mathproc)acos, 1, "Arc cosine"},
    {"atan", (funcproc)unop, (mathproc)atan, 1, "Arc tangent"},
    {"atan2", (funcproc)binop, (mathproc)atan2, 2, "Arc tangent of 2 variables"},
    {"abs", (funcproc)unop, (mathproc)fabs, 1, "Absolute value"},
    {"sqrt", (funcproc)unop, (mathproc)sqrt, 1, "Square root"},
    {"count", (funcproc)f_count, (mathproc)NULL, 1,
     "Returns the number of fields in a variable"},
    {"sum", (funcproc)f_sum, (mathproc)NULL, 1,
     "Returns a field sum of all the fields of a variable"},
    {"mean", (funcproc)f_mean, (mathproc)NULL, 1,
     "Returns the mean of all the fields"},

    {"rms", (funcproc)f_rms2, (mathproc)NULL, 2,
     "Returns the rms of two fieldsets"},

    {"rms", (funcproc)f_rms, (mathproc)NULL, 1,
     "Returns the root mean square of all the fields of a variable"},
    {"stdev", (funcproc)f_stdev, (mathproc)NULL, 1,
     "Returns the standard deviation of all the fields of a variable"},
    {"var", (funcproc)f_var, (mathproc)NULL, 1,
     "Returns the variance of all the fields of a variable"},

    {"covar", (funcproc)f_covar, (mathproc)NULL, 2,
     "Returns the covariance of all two fieldsets"},

    {"distribution", (funcproc)f_distribution, (mathproc)NULL, 2,
     "Returns the distribution of fields"},

    {"duplicate", (funcproc)f_duplicate, (mathproc)NULL, 2,
     "Duplicates a field N times"},
    {"repeat", (funcproc)f_duplicate, (mathproc)NULL, 2,
     "Repeats a field N times"},

    {"merge", (funcproc)f_merge, (mathproc)NULL, -1, "Merge several fieldsets"},
    {"&", (funcproc)f_merge, (mathproc)NULL, -1, "Merge several fieldsets"},
    {"bitmap", (funcproc)f_bitmap, (mathproc)NULL, 2,
     "Apply bitmap of 2nd fieldset to 1st fieldset"},
    {"nobitmap", (funcproc)f_nobitmap, (mathproc)NULL, 2,
     "Clear bitmap of 1st fieldset assigning value instead"},

    {
        NULL,
    },
};

func* mars_functions(void) {
    return builtins;
}
/* to do : ceil an friends erf dran48 lgamma */

static void list_funcs() {
    int i;
    marslog(LOG_INFO, "These functions are now implented:");
    for (i = 0; builtins[i].name; i++)
        if (builtins[i].arity < 0)
            printf("%-8s any number of arguments : %s\n", builtins[i].name,
                   builtins[i].info ? builtins[i].info : "No information available");
        else
            printf("%-8s %d argument(s)          : %s\n", builtins[i].name,
                   builtins[i].arity, builtins[i].info ? builtins[i].info : "No information available");
}

static err call_math_func(math* p, void* data) {
    int i;
    funcproc f = (funcproc)extern_func;
    mathproc d = NULL;

    for (i = 0; builtins[i].name; i++)
        if (strcasecmp(builtins[i].name, p->name) == 0)
            if ((builtins[i].arity < 0) || (builtins[i].arity == p->arity)) {
                f = builtins[i].addr;
                d = builtins[i].proc;
                return f(p, d);
            }

    for (i = 0; builtins[i].name; i++)
        if (strcasecmp(builtins[i].name, p->name) == 0) {
            f = builtins[i].addr;
            d = builtins[i].proc;
            if (builtins[i].arity >= 0)
                if (builtins[i].arity != p->arity) {
                    marslog(LOG_EROR, "Function '%s' is expecting %d argument(s)", builtins[i].name, builtins[i].arity);
                    return -1;
                }
            break;
        }
    return f(p, d);
}

static err call_load(math* p, void* data) {
    variable* v;

    marslog(LOG_DBUG, "Loading '%s'", p->name);
    if (is_number(p->name))
        return push_named_scalar(p->name, atof(p->name));
    else {
        int args[3];
        int i;
        int arity = -p->arity;

        if (arity > 3) {
            marslog(LOG_EROR, "Wrong number of indices for field name '%s'",
                    p->name);
            return -1;
        }

        args[0] = args[1] = args[2] = 0;

        for (i = 0; i < arity; i++) {
            if (!(v = pop()))
                return -1;
            if (!v->scalar) {
                marslog(LOG_EROR, "Bad index for field name '%s': not a scalar",
                        p->name);
                return -1;
            }

            args[arity - i - 1] = (int)v->val;
        }

        v = find_variable(p->name);
        if (v == NULL) {
            marslog(LOG_EROR, "Cannot find variable %s", p->name);
            return -2;
        }
        if (v->name)
            return push_named_fieldset(v->name, sub_fieldset(v->fs, args[0], args[1], args[2]));
        return push_fieldset(sub_fieldset(v->fs, args[0], args[1], args[2]));
    }
}


static void advance(void) {
    form++;
    while (isspace(*form))
        form++;
}

static math* readatom() {
    math* p;
    int i;
    char buf[1024];

    switch (*form) {
        case '(':
            advance();
            p = readtest();
            if (*form != ')') {
                marslog(LOG_EROR, "Formula: missing )");
                comperr = 1;
            }
            advance();
            break;

        case '-':
            p        = NEW_CLEAR(math);
            p->arity = 1;
            p->name  = strcache("neg");
            advance();
            p->left = readatom();
            break;

        case '\0':
            marslog(LOG_EROR, "Formula: syntax error");
            comperr = 1;
            return NULL;
            /*NOTREACHED*/
            break;

        default:
            i = 0;

            if (*form == '\'' || *form == '"') {
                char c = *form++;
                while (*form && *form != c)
                    buf[i++] = *form++;
                if (*form)
                    form++;
            }
            else
                while (isalpha(*form) || isdigit(*form) || *form == '.'
                       || *form == '_')
                    buf[i++] = *form++;

            buf[i] = 0;
            if (isspace(*form))
                advance();

            p       = NEW_CLEAR(math);
            p->name = strcache(buf);

            switch (*form) {
                case '(':
                    advance();
                    p->arity = 0;
                    p->left  = readlist(&p->arity);
                    if (*form != ')') {
                        marslog(LOG_EROR, "Formula: missing )");
                        comperr = 1;
                    }
                    advance();
                    break;

                case '[':
                    advance();
                    p->arity = 0;
                    p->left  = readlist(&p->arity);
                    if (*form != ']') {
                        marslog(LOG_EROR, "Formula: missing ]");
                        comperr = 1;
                    }
                    p->arity = -p->arity;
                    advance();
                    break;

                default:
                    p->arity = 0;
                    break;
            }

            break;
    }

    return p;
}

static char* opname(char* p, int n) {
    char buf[5];
    strncpy(buf, p, n);
    buf[n] = 0;
    return strcache(buf);
}

void print_math(math* m) {
    if (m) {
        putchar('(');
        print_math(m->left);
        printf("%s", m->name);
        print_math(m->right);
        putchar(')');
    }
}

static math* readpower() {
    math* p = readatom();

    while (*form == '^' || (*form == '*' && *(form + 1) == '*')) {
        math* q  = NEW_CLEAR(math);
        q->left  = p;
        q->arity = 2;

        if (*form == '*') {
            advance();
            *form = '^';
        }

        q->name = opname(form, 1);
        advance();
        q->right = readatom();
        p        = q;
    }
    return p;
}

static math* readlist(int* n) {
    math* p;

    if (*form == ')')
        return NULL;

    p  = readtest();
    *n = 1;

    while (*form == ',') {
        math* q = NEW_CLEAR(math);


        (*n)++;

        q->left = p;

        advance();

        q->right = readtest();

        p = q;
    }
    return p;
}


static math* readfactor() {
    math* p = readpower();
    while (*form == '*' || *form == '/') {
        math* q = NEW_CLEAR(math);


        q->arity = 2;
        q->left  = p;
        q->name  = opname(form, 1);

        advance();

        q->right = readpower();

        p = q;
    }
    return p;
}

static math* readterm() {
    math* p = readfactor();
    while (*form == '+' || *form == '-') {
        math* q = NEW_CLEAR(math);


        q->arity = 2;
        q->left  = p;
        q->name  = opname(form, 1);

        advance();

        q->right = readfactor();

        p = q;
    }
    return p;
}

static math* readtest() {
    math* p = readterm();
    while (*form == '<' || *form == '>' || *form == '=') {
        math* q = NEW_CLEAR(math);
        char* x = form;
        int n   = 1;


        q->arity = 2;
        q->left  = p;

        advance();
        if (*form == '=' || *form == '>') {
            n = 2;
            advance();
        }

        q->name = opname(x, n);

        q->right = readterm();

        p = q;
    }
    return p;
}

math* clone_math(math* m) {
    math* n = NULL;
    if (m) {
        n        = NEW_CLEAR(math);
        n->arity = m->arity;
        n->name  = strcache(m->name);
        n->left  = clone_math(m->left);
        n->right = clone_math(m->right);
    }
    return n;
}

math* compmath(const char* formula) {
    math* x;
    char buf[1024];

    strcpy(buf, formula);
    form = buf;

    comperr = 0;
    x       = readtest();
    if (comperr)
        return NULL;

    if (*form) {
        marslog(LOG_EROR, "Part of the formula was not processed: '%s'", form);
        return NULL;
    }


    return x;
}

static err compute(math* p, void* data) {
    err e = NOERR;
    if (p) {
        if ((e = compute(p->left, data)))
            return e;

        if ((e = compute(p->right, data)))
            return e;

        if (p->name) {
            if (p->arity <= 0) {
                return call_load(p, data);
            }
            else {
                return call_math_func(p, data);
            }
        }
    }
    return NOERR;
}

static void fpe(int sig) {
    merr++;
    signal(SIGFPE, fpe);
}

void free_math(math* m) {
    if (m) {
        free_math(m->left);
        free_math(m->right);
        strfree(m->name);
        FREE(m);
    }
}


err calculate(math* c, const char* f, void* data) {
    int saveerrno = errno;
    int savemerr  = merr;
    err e         = 0;
    variable* v;

    if (mars.debug) {
        marslog(LOG_DBUG | LOG_NOCR, "Formula is : ");
        print_math(c);
        putchar('\n');
    }

    /* signal(SIGFPE,fpe); */
    merr  = 0;
    errno = 0;
    e     = compute(c, data);

    if (merr)
        marslog(LOG_WARN, "%d math error(s) where reported", merr);

    if (e == NOERR) {
        v = pop();
        if (v) {
            if (v->scalar) {
                marslog(LOG_INFO, "The result of compute is a scalar: %g", v->val);
            }
            else {
                marslog(LOG_INFO, "%d resulting field(s) put in fieldset '%s'",
                        v->fs->count, f);
            }
        }
        new_variable(f, v->fs, v->val);
    }

    errno = saveerrno;
    merr  = savemerr;
    return e;
}

err handle_compute(request* r, void* data) {
    const char* s   = get_value(r, "FORMULA", 0);
    const char* f   = get_value(r, "FIELDSET", 0);
    const char* tgt = get_value(r, "TARGET", 0);
    math* c         = compmath(no_quotes(s));
    err e;


#ifndef METVIEW
    timer* t;
    char buf[1024];
    sprintf(buf, "Computing %s", s);
    t = get_timer(buf, NULL, false);
    timer_start(t);
#endif

    if (mars.webmars_target && tgt) {
        tgt = mars.webmars_target;
    }

    marslog(LOG_DBUG, "Formula is: %s", s);
    if (!c) {
        free_math(c);
        return -1;
    }

    e = calculate(c, f, data);
    free_math(c);

#ifndef METVIEW
    timer_stop(t, 0);

    if ((e == NOERR) && tgt) {
        extern base_class* targetbase;
        variable* v = find_variable(f);
        database* target;

        if (!v) {
            marslog(LOG_EROR, "Fieldset not found: '%s'", f);
            return -1;
        }

        if (v->scalar) {
            marslog(LOG_EROR, "WRITE failed. Field '%s' is a scalar (%g)",
                    s, v->val);
            return -1;
        }

        target = database_open(targetbase, NULL, r, NULL, WRITE_MODE);

        if (target == NULL)
            return -1;

        e = write_fieldset(v->fs, target);

        database_close(target);

        if (e)
            return e;

        marslog(LOG_INFO, "WRITE %d field(s) from fieldset %s to file '%s'", v->fs->count, f, tgt);
        return NOERR;
    }

#endif

    return e;
}
