/* 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 lbfgs(long n, long m, double x[], double *f, double g[],
int diagco, double diag[],
double eps, double xtol, double w[], long *iflag)
{
long iprint[2];
iprint[0] = -1;
iprint[1] = 0;
lbfgs_(&n, &m, x, f, g, &diagco, diag, iprint, &eps, &xtol, w, iflag);
}
/* x is the n-dimension variable
* f is the current value of objective function
* g is the n-dimension gradient of f
*
* return value:
* = 0: success
* < 0: some error occur, see comment in lbfgs.f for detail
* = 1: user must evaluate F and G
* = 2: user must provide the diagonal matrix Hk0.
*/
int lbfgs_run(lbfgs_t* opt, double* x, double* f, double* g) {
lbfgs_(&opt->n, &opt->m, x, f, g, &opt->diagco, opt->diag,
opt->iprint, &opt->eps, &opt->xtol, opt->w, &opt->iflag,
&opt->niter, &opt->nfuns);
return opt->iflag;
}
nlopt_result lbfgsb_minimize(int n, nlopt_func func, void *f_data,
const double *lb, const double *ub, /* bounds */
double *x, /* in: initial guess, out: minimizer */
double *minf,
nlopt_stopping *stop,
int mf)
{
int funcEval = 0;
int nParams = n;
int iflag = 0;
int memSize = 10;
int verbosity = 0;
double* Xvals = new double[nParams];
double* work = new double[nParams*(2*memSize+1) + 2*memSize];
double* gvals = new double[nParams];
double* diagVals = new double[nParams];
double* X = new double[nParams];
double* g = new double[nParams];
nlopt_result ret = NLOPT_SUCCESS;
int iPrint[2] ={-1, 0};
if(verbosity>2)
{
iPrint[0] = 1;
}
double f = 0.0;
memcpy(X,x,sizeof(double)*nParams);//getOptParams(X);
while(funcEval<stop->maxeval)
{
f = func(n,x,g,f_data); //f = computeObjectiveGradParams(g);
for (int i = 0; i < nParams; i++)
{
Xvals[i] = X[i];
gvals[i] = g[i];
}
lbfgs_(nParams, memSize, Xvals, f, gvals, 0, diagVals, iPrint, stop->ftol_rel, stop->xtol_rel, work, iflag);
if(iflag<=0)
{
if(iflag==-1)
{
//DBWARNING("Warning: lbfgsOptimise: linesearch failed.");
ret = NLOPT_FTOL_REACHED;
break;
}
else if(iflag == -2)
{
//DBERROR("An element of the inverse Hessian provided is not positive.");
ret = NLOPT_FORCED_STOP;
}
else if(iflag == -3)
{
//DBERROR("Inproper input to lbfgs_.");
ret = NLOPT_INVALID_ARGS;
}
}
else if(iflag==0)
{
break;
}
else if(iflag==1)
{
for (int i = 0; i < nParams; i++)
X[i] = Xvals[i];
for (int i = 0; i < nParams; i++)
x[i] = X[i];
funcEval++;
}
else
{
//DBERROR("Unhandled iflag.");
ret = NLOPT_INVALID_ARGS;
}
}
// Clean up.
delete[] Xvals;
delete[] work;
delete[] gvals;
delete[] diagVals;
delete[] X;
delete[] g;
return ret;
}
