/* 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)); } }