From b9f6a8c2bb2f4242b93b04aa87e41f7a95f37fd9 Mon Sep 17 00:00:00 2001 From: stevenj Date: Tue, 1 Jun 2010 11:17:31 -0400 Subject: [PATCH] added new Fortran API, removed unnecessary --with-windows-f77-mangling darcs-hash:20100601151731-c8de0-094eca40a2ca0b04dbb029cb111b2284ede822da.gz --- api/Makefile.am | 2 +- api/f77api.c | 66 +++++++++++---------- api/f77funcs.h | 8 ++- api/f77funcs_.h | 133 +++++++++++++++++++++++++++++++++++++++++++ api/nlopt-internal.h | 2 + api/options.c | 16 +++++- configure.ac | 5 -- 7 files changed, 191 insertions(+), 41 deletions(-) create mode 100644 api/f77funcs_.h diff --git a/api/Makefile.am b/api/Makefile.am index b6fe33b..0cf1a55 100644 --- a/api/Makefile.am +++ b/api/Makefile.am @@ -5,7 +5,7 @@ noinst_LTLIBRARIES = libapi.la dist_man_MANS = nlopt.3 libapi_la_SOURCES = general.c options.c optimize.c deprecated.c \ -nlopt-internal.h nlopt.h f77api.c f77funcs.h +nlopt-internal.h nlopt.h f77api.c f77funcs.h f77funcs_.h BUILT_SOURCES = nlopt.f nlopt.hpp EXTRA_DIST = nlopt-in.hpp diff --git a/api/f77api.c b/api/f77api.c index 5f91d6a..a3c9e1a 100644 --- a/api/f77api.c +++ b/api/f77api.c @@ -22,8 +22,7 @@ #include -#include "nlopt.h" -#include "nlopt-util.h" +#include "nlopt-internal.h" /*-----------------------------------------------------------------------*/ /* wrappers around f77 procedures */ @@ -37,7 +36,7 @@ typedef struct { void *f_data; } f77_func_data; -static double f77_func_wrap(int n, const double *x, double *grad, void *data) +static double f77_func_wrap_old(int n, const double *x, double *grad, void *data) { f77_func_data *d = (f77_func_data *) data; double val; @@ -46,39 +45,52 @@ static double f77_func_wrap(int n, const double *x, double *grad, void *data) return val; } +static double f77_func_wrap(unsigned n, const double *x, double *grad, void *data) +{ + f77_func_data *d = (f77_func_data *) data; + int ni = (int) n; + double val; + int need_gradient = grad != 0; + d->f(&val, &ni, x, grad, &need_gradient, d->f_data); + return val; +} + +/*-----------------------------------------------------------------------*/ + +#define F77_GET(name,NAME,T) void F77_(nlo_get_##name,NLO_GET_##NAME)(T *val, nlopt_opt *opt) { *val = (T) nlopt_get_##name(*opt); } +#define F77_SET(name,NAME,T) void F77_(nlo_set_##name,NLO_SET_##NAME)(int *ret, nlopt_opt *opt, T *val) { *ret = (int) nlopt_set_##name(*opt, *val); } +#define F77_GETSET(name,NAME,T) F77_GET(name,NAME,T) F77_SET(name,NAME,T) + +#define F77_GETA(name,NAME,T) void F77_(nlo_get_##name,NLO_GET_##NAME)(int *ret, T *val, nlopt_opt *opt) { *ret = (int) nlopt_get_##name(*opt, val); } +#define F77_SETA(name,NAME,T) void F77_(nlo_set_##name,NLO_SET_##NAME)(int *ret, nlopt_opt *opt, T *val) { *ret = (int) nlopt_set_##name(*opt, val); } +#define F77_GETSETA(name,NAME,T) F77_GETA(name,NAME,T) F77_SETA(name,NAME,T) F77_SET(name##1,NAME##1,T) + /*-----------------------------------------------------------------------*/ /* rather than trying to detect the Fortran name-mangling scheme with autoconf, we just include wrappers with all common name-mangling schemes ... this avoids problems and also allows us to work with - multiple Fortran compilers on the same machine . - - Note that our Fortran function names do not contain underscores; - otherwise, we would need to deal with the additional headache that - g77 appends two underscores in that case. */ - -#ifndef WINDOWS_F77_MANGLING + multiple Fortran compilers on the same machine. Since the Fortran + wrapper functions are so small, the library bloat of including them + multiple times is negligible and seems well worth the benefit. */ /* name + underscore is by far the most common (gfortran, g77, Intel, ...) */ # define F77(a, A) a ## _ # include "f77funcs.h" +/* also include g77 convention of name + double underscore for identifiers + containing underscores */ +# define F77_(a, A) a ## __ +# include "f77funcs_.h" +# undef F77_ + /* AIX and HPUX use just the lower-case name */ # undef F77 # define F77(a, A) a # include "f77funcs.h" -/* old Cray UNICOS used just the upper-case name */ -# undef F77 -# define F77(a, A) A -# include "f77funcs.h" - -#else /* WINDOWS_F77_MANGLING */ - -/* Various mangling conventions common (?) under Windows. */ - -/* name + underscore for gfortran, g77, ...? */ -# define F77(a, A) a ## _ -# include "f77funcs.h" +/* Old Cray Unicos, as well as several Windows Fortran compilers + (Digital/Compaq/HP Visual Fortran and Intel Fortran) use all-uppercase + name */ /* Digital/Compaq/HP Visual Fortran, Intel Fortran. stdcall attribute is apparently required to adjust for calling conventions (callee @@ -86,13 +98,5 @@ static double f77_func_wrap(int n, const double *x, double *grad, void *data) http://msdn.microsoft.com/library/en-us/vccore98/html/_core_mixed.2d.language_programming.3a_.overview.asp */ # undef F77 -# if defined(__GNUC__) -# define F77(a, A) __attribute__((stdcall)) A -# elif defined(_MSC_VER) || defined(_ICC) || defined(_STDCALL_SUPPORTED) -# define F77(a, A) __stdcall A -# else -# define F77(a, A) A /* oh well */ -# endif +# define F77(a, A) NLOPT_STDCALL A # include "f77funcs.h" - -#endif /* WINDOWS_F77_MANGLING */ diff --git a/api/f77funcs.h b/api/f77funcs.h index 2e41e29..62667fd 100644 --- a/api/f77funcs.h +++ b/api/f77funcs.h @@ -55,8 +55,8 @@ void F77(nloptc,NLOPTC)(int *info, } *info = nlopt_minimize_constrained((nlopt_algorithm) *algorithm, - *n, f77_func_wrap, &d, - *m, f77_func_wrap, + *n, f77_func_wrap_old, &d, + *m, f77_func_wrap_old, dc, sizeof(f77_func_data), lb, ub, x, minf, *minf_max, *ftol_rel, *ftol_abs, @@ -112,3 +112,7 @@ void F77(nlossp,NLOSSP)(const int *pop) { nlopt_set_stochastic_population(*pop); } + +#define F77_(name,NAME) F77(name,NAME) +# include "f77funcs_.h" +#undef F77_ diff --git a/api/f77funcs_.h b/api/f77funcs_.h new file mode 100644 index 0000000..388a40c --- /dev/null +++ b/api/f77funcs_.h @@ -0,0 +1,133 @@ +/* Copyright (c) 2007-2010 Massachusetts Institute of Technology + * + * Permission is hereby granted, free of charge, to any person obtaining + * a copy of this software and associated documentation files (the + * "Software"), to deal in the Software without restriction, including + * without limitation the rights to use, copy, modify, merge, publish, + * distribute, sublicense, and/or sell copies of the Software, and to + * permit persons to whom the Software is furnished to do so, subject to + * the following conditions: + * + * The above copyright notice and this permission notice shall be + * included in all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND + * NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE + * LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION + * OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION + * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + */ + +/* Fortran API wrappers, using the F77 macro defined in f77api.c. + This header file is #included one or more times from f77api.c + in order to define verions of the Fortran API for various compilers. + + All of the functions in this file have underscores in their names, + which means that they are treated differently for name-mangling + (thank you, g77 and f2c) than names without underscores. + + The return value of a function is converted to the first argument + of a subroutine. */ + +void F77_(nlo_create,NLO_CREATE)(nlopt_opt *opt, int *alg, int *n) +{ + if (*n < 0) *opt = NULL; + else { + *opt = nlopt_create((nlopt_algorithm) *alg, (unsigned) *n); + (*opt)->free_f_data = 1; + } +} + +void F77_(nlo_destroy,NLO_DESTROY)(nlopt_opt *opt) +{ + nlopt_destroy(*opt); +} + +void F77_(nlo_optimize,NLO_OPTIMIZE)(int *ret, + nlopt_opt *opt, double *x, double *optf) +{ + *ret = (int) nlopt_optimize(*opt, x, optf); +} + +void F77_(nlo_set_min_objective,NLO_SET_MIN_OBJECTIVE)( + int *ret, nlopt_opt *opt, nlopt_f77_func f, void *f_data) +{ + f77_func_data *d = (f77_func_data*) malloc(sizeof(f77_func_data)); + if (!d) { *ret = (int) NLOPT_OUT_OF_MEMORY; return; } + d->f = f; + d->f_data = f_data; + *ret = (int) nlopt_set_min_objective(*opt, f77_func_wrap, d); + /* FIXME: memory leak in nlopt_destroy */ +} + +void F77_(nlo_set_max_objective,NLO_SET_MAX_OBJECTIVE)( + int *ret, nlopt_opt *opt, nlopt_f77_func f, void *f_data) +{ + f77_func_data *d = (f77_func_data*) malloc(sizeof(f77_func_data)); + if (!d) { *ret = (int) NLOPT_OUT_OF_MEMORY; return; } + d->f = f; + d->f_data = f_data; + *ret = (int) nlopt_set_max_objective(*opt, f77_func_wrap, d); +} + +F77_GET(algorithm, ALGORITHM, int) +F77_GET(dimension, DIMENSION, int) + +F77_GETSETA(lower_bounds, LOWER_BOUNDS, double) +F77_GETSETA(upper_bounds, UPPER_BOUNDS, double) + +void F77_(nlo_remove_inequality_constraints,NLO_REMOVE_INEQUALITY_CONSTRAINTS)( + int *ret, nlopt_opt *opt) { + *ret = (int) nlopt_remove_inequality_constraints(*opt); +} + +void F77_(nlo_add_inequality_constraint,NLO_ADD_INEQUALITY_CONSTRAINT)( + int *ret, nlopt_opt *opt, nlopt_f77_func fc, void *fc_data, double *tol) +{ + f77_func_data *d = (f77_func_data*) malloc(sizeof(f77_func_data)); + if (!d) { *ret = (int) NLOPT_OUT_OF_MEMORY; return; } + d->f = fc; + d->f_data = fc_data; + *ret = (int) nlopt_add_inequality_constraint(*opt, f77_func_wrap,d, *tol); +} + +void F77_(nlo_remove_equality_constraints,NLO_REMOVE_EQUALITY_CONSTRAINTS)( + int *ret, nlopt_opt *opt) { + *ret = (int) nlopt_remove_equality_constraints(*opt); +} + +void F77_(nlo_add_equality_constraint,NLO_ADD_EQUALITY_CONSTRAINT)( + int *ret, nlopt_opt *opt, nlopt_f77_func fc, void *fc_data, double *tol) +{ + f77_func_data *d = (f77_func_data*) malloc(sizeof(f77_func_data)); + if (!d) { *ret = (int) NLOPT_OUT_OF_MEMORY; return; } + d->f = fc; + d->f_data = fc_data; + *ret = (int) nlopt_add_equality_constraint(*opt, f77_func_wrap,d, *tol); +} + +F77_GETSET(stopval, STOPVAL, double) +F77_GETSET(ftol_rel, FTOL_REL, double) +F77_GETSET(ftol_abs, FTOL_ABS, double) +F77_GETSET(xtol_rel, XTOL_REL, double) +F77_GETSETA(xtol_abs, XTOL_ABS, double) +F77_GETSET(maxeval, MAXEVAL, int) +F77_GETSET(maxtime, MAXTIME, double) + +F77_GETSET(force_stop, FORCE_STOP, int) +void F77_(nlo_force_stop,NLO_FORCE_STOP)(int *ret, nlopt_opt *opt) { + *ret = (int) nlopt_force_stop(*opt); +} + +F77_SET(local_optimizer, LOCAL_OPTIMIZER, nlopt_opt) +F77_GETSET(population, POPULATION, unsigned) + +F77_SETA(default_initial_step, DEFAULT_INITIAL_STEP, double) +F77_SETA(initial_step, INITIAL_STEP, double) +F77_SET(initial_step1, INITIAL_STEP1, double) +void F77_(nlo_get_initial_step, NLO_GET_INITIAL_STEP)( + int *ret, nlopt_opt *opt, const double *x, double *dx) { + *ret = (int) nlopt_get_initial_step(*opt, x, dx); +} diff --git a/api/nlopt-internal.h b/api/nlopt-internal.h index b0f16c6..e3389ef 100644 --- a/api/nlopt-internal.h +++ b/api/nlopt-internal.h @@ -50,6 +50,8 @@ struct nlopt_opt_s { unsigned p_alloc; /* number of inequality constraints allocated */ nlopt_constraint *h; /* equality constraints, length p_alloc */ + int free_f_data; /* flag (for f77 api) to free f_data in nlopt_destroy */ + /* stopping criteria */ double stopval; /* stop when f reaches stopval or better */ double ftol_rel, ftol_abs; /* relative/absolute f tolerances */ diff --git a/api/options.c b/api/options.c index f002a7b..890fbb9 100644 --- a/api/options.c +++ b/api/options.c @@ -34,6 +34,14 @@ void nlopt_destroy(nlopt_opt opt) { if (opt) { + if (opt->free_f_data) { + unsigned i; + free(opt->f_data); + for (i = 0; i < opt->m; ++i) + free(opt->fc[i].f_data); + for (i = 0; i < opt->p; ++i) + free(opt->h[i].f_data); + } free(opt->lb); free(opt->ub); free(opt->xtol_abs); free(opt->fc); @@ -57,6 +65,7 @@ nlopt_opt nlopt_create(nlopt_algorithm algorithm, unsigned n) opt->n = n; opt->f = NULL; opt->f_data = NULL; opt->maximize = 0; + opt->free_f_data = 0; opt->lb = opt->ub = NULL; opt->m = opt->m_alloc = 0; @@ -108,6 +117,7 @@ nlopt_opt nlopt_copy(const nlopt_opt opt) nopt->local_opt = NULL; nopt->dx = NULL; opt->force_stop_child = NULL; + opt->free_f_data = 0; if (opt->n > 0) { nopt->lb = (double *) malloc(sizeof(double) * (opt->n)); @@ -162,6 +172,7 @@ nlopt_result nlopt_set_min_objective(nlopt_opt opt, nlopt_func f, void *f_data) { if (opt) { opt->f = f; opt->f_data = f_data; + if (f_data) opt->free_f_data = 0; opt->maximize = 0; if (nlopt_isinf(opt->stopval) && opt->stopval > 0) opt->stopval = -HUGE_VAL; /* switch default from max to min */ @@ -174,6 +185,7 @@ nlopt_result nlopt_set_max_objective(nlopt_opt opt, nlopt_func f, void *f_data) { if (opt) { opt->f = f; opt->f_data = f_data; + if (f_data) opt->free_f_data = 0; opt->maximize = 1; if (nlopt_isinf(opt->stopval) && opt->stopval < 0) opt->stopval = +HUGE_VAL; /* switch default from min to max */ @@ -295,7 +307,7 @@ nlopt_result nlopt_add_inequality_constraint(nlopt_opt opt, && opt->algorithm != NLOPT_GN_ORIG_DIRECT && opt->algorithm != NLOPT_GN_ORIG_DIRECT_L) return NLOPT_INVALID_ARGS; - + if (fc_data) opt->free_f_data = 0; return add_constraint(&opt->m, &opt->m_alloc, &opt->fc, fc, fc_data, tol); } @@ -318,7 +330,7 @@ nlopt_result nlopt_add_equality_constraint(nlopt_opt opt, /* equality constraints (h(x) = 0) only via some algorithms */ if (!AUGLAG_ALG(opt->algorithm) && opt->algorithm != NLOPT_GN_ISRES) return NLOPT_INVALID_ARGS; - + if (h_data) opt->free_f_data = 0; return add_constraint(&opt->p, &opt->p_alloc, &opt->h, h, h_data, tol); } diff --git a/configure.ac b/configure.ac index fcf4b81..ae7d3f9 100644 --- a/configure.ac +++ b/configure.ac @@ -33,11 +33,6 @@ if test "x$with_cxx" = xyes; then fi AC_SUBST(NLOPT_SUFFIX) -AC_ARG_WITH(windows-f77-mangling, [AC_HELP_STRING([--with-windows-f77-mangling],[use common Win32 Fortran interface styles])], with_windows_f77_mangling=$withval, with_windows_f77_mangling=no) -if test "$with_windows_f77_mangling" = "yes"; then - AC_DEFINE(WINDOWS_F77_MANGLING,1,[Use common Windows Fortran mangling styles for the Fortran interfaces.]) -fi - dnl Checks for typedefs, structures, and compiler characteristics. AC_HEADER_STDC AC_HEADER_TIME -- 2.30.2