/*--------------------------------------------------------------------------*/
fint hov_forward_(fint* ftag,
fint* fm,
fint* fn,
fint* fd,
fint* fp,
fdouble* fbase,
fdouble* fx,
fdouble* fvalue,
fdouble* fy) {
int rc= -1;
int tag=*ftag, m=*fm, n=*fn, d=*fd, p=*fp;
double* base = myalloc1(n);
double* value = myalloc1(m);
double*** X = myalloc3(n,p,d);
double*** Y = myalloc3(m,p,d);
spread1(n,fbase,base);
spread3(n,p,d,fx,X);
rc= hov_forward(tag,m,n,d,p,base,X,value,Y);
pack3(m,p,d,Y,fy);
pack1(m,value,fvalue);
free((char*)**X);
free((char*)*X);
free((char*)X);
free((char*)**Y);
free((char*)*Y);
free((char*)Y);
free((char*)base);
free((char*)value);
return rc;
}
BEGIN_C_DECLS
/*--------------------------------------------------------------------------*/
fint hos_forward_(fint* ftag,
fint* fm,
fint* fn,
fint* fd,
fint* fk,
fdouble* fbase,
fdouble* fx,
fdouble* fvalue,
fdouble* fy) {
int rc= -1;
int tag=*ftag, m=*fm, n=*fn, d=*fd, k=*fk;
double* base = myalloc1(n);
double* value = myalloc1(m);
double** X = myalloc2(n,d);
double** Y = myalloc2(m,d);
spread1(n,fbase,base);
spread2(n,d,fx,X);
rc= hos_forward(tag,m,n,d,k,base,X,value,Y);
pack2(m,d,Y,fy);
pack1(m,value,fvalue);
free((char*)*X);
free((char*)X);
free((char*)*Y);
free((char*)Y);
free((char*)base);
free((char*)value);
return rc;
}
/* hess_vec(tag, n, x[n], v[n], w[n]) */
fint hess_vec_(fint* ftag,
fint* fn,
fdouble *fargument,
fdouble *ftangent,
fdouble *fresult) {
int rc= -1;
int tag=*ftag, n=*fn;
double *argument = myalloc1(n);
double *tangent = myalloc1(n);
double *result = myalloc1(n);
spread1(n,fargument,argument);
spread1(n,ftangent,tangent);
rc= hess_vec(tag,n,argument,tangent,result);
pack1(n,result,fresult);
free((char*)argument);
free((char*)tangent);
free((char*)result);
return rc;
}
/* jac_vec(tag, m, n, x[n], v[n], u[m]); */
fint jac_vec_(fint* ftag,
fint* fm,
fint* fn,
fdouble* fargument,
fdouble* ftangent,
fdouble* fcolumn) {
int rc= -1;
int tag=*ftag, m=*fm, n=*fn;
double* argument = myalloc1(n);
double* tangent = myalloc1(n);
double* column = myalloc1(m);
spread1(n,ftangent,tangent);
spread1(n,fargument,argument);
rc= jac_vec(tag,m,n,argument,tangent,column);
pack1(m,column,fcolumn);
free((char*)argument);
free((char*)tangent);
free((char*)column);
return rc;
}
/* vec_jac(tag, m, n, repeat, x[n], u[m], v[n]) */
fint vec_jac_(fint* ftag,
fint* fm,
fint* fn,
fint* frepeat,
fdouble* fargument,
fdouble* flagrange,
fdouble* frow) {
int rc= -1;
int tag=*ftag, m=*fm, n=*fn, repeat=*frepeat;
double* argument = myalloc1(n);
double* lagrange = myalloc1(m);
double* row = myalloc1(n);
spread1(m,flagrange,lagrange);
spread1(n,fargument,argument);
rc= vec_jac(tag,m,n,repeat,argument,lagrange, row);
pack1(n,row,frow);
free((char*)argument);
free((char*)lagrange);
free((char*)row);
return rc;
}
/* gradient(tag, n, x[n], g[n]) */
fint gradient_(fint* ftag,
fint* fn,
fdouble* fargument,
fdouble* fresult) {
int rc= -1;
int tag=*ftag, n=*fn;
double* argument=myalloc1(n);
double* result=myalloc1(n);
spread1(n,fargument,argument);
rc= gradient(tag,n,argument,result);
pack1(n,result,fresult);
free((char*)result);
free((char*)argument);
return rc;
}
/* lagra_hess_vec(tag, m, n, x[n], v[n], u[m], w[n]) */
fint lagra_hess_vec_(fint* ftag,
fint* fm,
fint* fn,
fdouble *fargument,
fdouble *ftangent,
fdouble *flagrange,
fdouble *fresult) {
int rc=-1;
int tag=*ftag, m=*fm, n=*fn;
double *argument = myalloc1(n);
double *tangent = myalloc1(n);
double *lagrange = myalloc1(m);
double *result = myalloc1(n);
spread1(n,fargument,argument);
spread1(n,ftangent,tangent);
spread1(m,flagrange,lagrange);
rc= lagra_hess_vec(tag,m,n,argument,tangent,lagrange,result);
pack1(n,result,fresult);
free((char*)argument);
free((char*)tangent);
free((char*)lagrange);
free((char*)result);
return rc;
}
/*--------------------------------------------------------------------------*/
fint fos_reverse_(fint* ftag,
fint* fm,
fint* fn,
fdouble* fu,
fdouble* fz) {
int rc=-1;
int tag=*ftag, m=*fm, n=*fn;
double* u = myalloc1(m);
double* Z = myalloc1(n);
spread1(m,fu,u);
rc=fos_reverse(tag,m,n,u,Z);
pack1(n,Z,fz);
free((char*)Z);
free((char*)u);
return rc;
}
/*--------------------------------------------------------------------------*/
fint zos_forward_(fint* ftag,
fint* fm,
fint* fn,
fint* fk,
fdouble* fbase,
fdouble* fvalue) {
int rc=-1;
int tag=*ftag, m=*fm, n=*fn, k=*fk;
double* base=myalloc1(n);
double* value = myalloc1(m);
spread1(n,fbase,base);
rc=zos_forward(tag,m,n,k,base,value);
pack1(m,value,fvalue);
free((char*)base);
free((char*)value);
return rc;
}
/* jacobian(tag, m, n, x[n], J[m][n]) */
fint jacobian_(fint* ftag,
fint* fdepen,
fint* findep,
fdouble *fargument,
fdouble *fjac) {
int rc= -1;
int tag=*ftag, depen=*fdepen, indep=*findep;
double** Jac = myalloc2(depen,indep);
double* argument = myalloc1(indep);
spread1(indep,fargument,argument);
rc= jacobian(tag,depen,indep,argument,Jac);
pack2(depen,indep,Jac,fjac);
free((char*)*Jac);
free((char*)Jac);
free((char*)argument);
return rc;
}
/*--------------------------------------------------------------------------*/
fint hos_reverse_(fint* ftag,
fint* fm,
fint* fn,
fint* fd,
fdouble* fu,
fdouble* fz) {
int rc=-1;
int tag=*ftag, m=*fm, n=*fn, d=*fd;
double** Z = myalloc2(n,d+1);
double* u = myalloc1(m);
spread1(m,fu,u);
rc=hos_reverse(tag,m,n,d,u,Z);
pack2(n,d+1,Z,fz);
free((char*)*Z);
free((char*)Z);
free((char*)u);
return rc;
}
/* hessian(tag, n, x[n], lower triangle of H[n][n]) */
fint hessian_(fint* ftag,
fint* fn,
fdouble* fx,
fdouble* fh) /* length of h should be n*n but the
upper half of this matrix remains unchanged */
{
int rc= -1;
int tag=*ftag, n=*fn;
double** H = myalloc2(n,n);
double* x = myalloc1(n);
spread1(n,fx,x);
rc= hessian(tag,n,x,H);
pack2(n,n,H,fh);
free((char*)*H);
free((char*)H);
free((char*)x);
return rc;
}
BEGIN_C_DECLS
/****************************************************************************/
/* DRIVERS FOR OPTIMIZATION AND NONLINEAR EQUATIONS */
/*--------------------------------------------------------------------------*/
/* function */
/* function(tag, m, n, x[n], y[m]) */
fint function_(fint* ftag,
fint* fm,
fint* fn,
fdouble* fargument,
fdouble* fresult) {
int rc= -1;
int tag=*ftag, m=*fm, n=*fn;
double* argument = myalloc1(n);
double* result = myalloc1(m);
spread1(n,fargument,argument);
rc= function(tag,m,n,argument,result);
pack1(m,result,fresult);
free((char*)argument);
free((char*)result);
return rc;
}
void mgauss (header *hd)
{ spread1(gauss,0,hd);
test_error("normaldis");
}
void mgamma (header *hd)
{ spread1(gamm,0,hd);
test_error("gamma");
}
void mgammaln (header *hd)
{ spread1(gammln,0,hd);
test_error("gammaln");
}