/* interface calling into the fortran routine */
static int lbfgs(index_t *x0, at *f, at *g, double gtol, htable_t *p, at *vargs)
{
/* argument checking and setup */
extern void lbfgs_(int *n, int *m, double *x, double *fval, double *gval, \
int *diagco, double *diag, int iprint[2], double *gtol, \
double *xtol, double *w, int *iflag);
ifn (IND_STTYPE(x0) == ST_DOUBLE)
error(NIL, "not an array of doubles", x0->backptr);
ifn (Class(f)->listeval)
error(NIL, "not a function", f);
ifn (Class(f)->listeval)
error(NIL, "not a function", g);
ifn (gtol > 0)
error(NIL, "threshold value not positive", NEW_NUMBER(gtol));
at *gx = copy_array(x0)->backptr;
at *(*listeval_f)(at *, at *) = Class(f)->listeval;
at *(*listeval_g)(at *, at *) = Class(g)->listeval;
at *callf = new_cons(f, new_cons(x0->backptr, vargs));
at *callg = new_cons(g, new_cons(gx, new_cons(x0->backptr, vargs)));
htable_t *params = lbfgs_params();
if (p) htable_update(params, p);
int iprint[2];
iprint[0] = (int)Number(htable_get(params, NEW_SYMBOL("iprint-1")));
iprint[1] = (int)Number(htable_get(params, NEW_SYMBOL("iprint-2")));
lb3_.gtol = Number(htable_get(params, NEW_SYMBOL("ls-gtol")));
lb3_.stpmin = Number(htable_get(params, NEW_SYMBOL("ls-stpmin")));
lb3_.stpmax = Number(htable_get(params, NEW_SYMBOL("ls-stpmax")));
int m = (int)Number(htable_get(params, NEW_SYMBOL("lbfgs-m")));
int n = index_nelems(x0);
double *x = IND_ST(x0)->data;
double fval;
double *gval = IND_ST(Mptr(gx))->data;
int diagco = false;
double *diag = mm_blob(n*sizeof(double));
double *w = mm_blob((n*(m+m+1)+m+m)*sizeof(double));
double xtol = eps(1); /* machine precision */
int iflag = 0;
ifn (n>0)
error(NIL, "empty array", x0->backptr);
ifn (m>0)
error(NIL, "m-parameter must be positive", NEW_NUMBER(m));
/* reverse communication loop */
do {
fval = Number(listeval_f(Car(callf), callf));
listeval_g(Car(callg), callg);
lbfgs_(&n, &m, x, &fval, gval, &diagco, diag, iprint, >ol, &xtol, w, &iflag);
assert(iflag<2);
} while (iflag > 0);
return iflag;
}
void cg_grad_adaptor(double *g, double *x, int n)
{
static at *call = NIL;
static int nx = -1;
static storage_t *stx = NULL;
static storage_t *stg = NULL;
static at *(*listeval)(at *, at *) = NULL;
if (n == -1) {
/* initialize */
at *x0 = var_get(named("x0"));
at *vargs = var_get(named("vargs"));
at *g = var_get(named("g"));
ifn (x0)
error(NIL, "x0 not found", NIL);
ifn (INDEXP(x0) && IND_STTYPE((index_t *)Mptr(x0)))
error(NIL, "x0 not a double index", x0);
ifn (g)
error(NIL, "g not found", NIL);
listeval = Class(g)->listeval;
index_t *ind = Mptr(x0);
nx = storage_nelems(IND_ST(ind));
stx = new_storage(ST_DOUBLE);
stx->flags = STS_FOREIGN;
stx->size = nx;
stx->data = (char *)-1;
stg = new_storage(ST_DOUBLE);
stg->flags = STS_FOREIGN;
stg->size = nx;
stg->data = (char *)-1;
call = new_cons(g,
new_cons(NEW_INDEX(stg, IND_SHAPE(ind)),
new_cons(NEW_INDEX(stx, IND_SHAPE(ind)),
vargs)));
} else {
if (n != nx)
error(NIL, "vector of different size expected", NEW_NUMBER(n));
stx->data = x;
stg->data = g;
listeval(Car(call), call);
}
}
double cg_value_adaptor(double *x, int n)
{
static at *call = NIL;
static int nx = -1;
static storage_t *st = NULL;
static at *(*listeval)(at *, at *) = NULL;
if (n == -1) {
/* initialize */
at *x0 = var_get(named("x0"));
at *vargs = var_get(named("vargs"));
at *f = var_get(named("f"));
ifn (x0)
error(NIL, "x0 not found", NIL);
ifn (INDEXP(x0) && IND_STTYPE((index_t *)Mptr(x0)))
error(NIL, "x0 not a double index", x0);
ifn (f)
error(NIL, "f not found", NIL);
listeval = Class(f)->listeval;
index_t *ind = Mptr(x0);
nx = storage_nelems(IND_ST(ind));
st = new_storage(ST_DOUBLE);
st->flags = STS_FOREIGN;
st->size = nx;
st->data = (char *)-1;
call = new_cons(f, new_cons(NEW_INDEX(st, IND_SHAPE(ind)), vargs));
return NAN;
} else {
if (n != nx)
error(NIL, "vector of different size expected", NEW_NUMBER(n));
st->data = x;
return Number(listeval(Car(call), call));
}
}
