chiark / gitweb /
Use trusty
[nlopt.git] / api / f77api.c
index 1adf45c33786b14b7c671782ac4500cb00662725..e753c86ae84dc7e0549a89eb75ddff9e59df13a2 100644 (file)
@@ -1,4 +1,4 @@
-/* Copyright (c) 2007-2008 Massachusetts Institute of Technology
+/* Copyright (c) 2007-2014 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
@@ -21,9 +21,9 @@
  */
 
 #include <stdlib.h>
+#include <string.h>
 
 #include "nlopt.h"
-#include "config.h"
 
 /*-----------------------------------------------------------------------*/
 /* wrappers around f77 procedures */
@@ -32,12 +32,25 @@ typedef void (*nlopt_f77_func)(double *val, const int *n, const double *x,
                               double *gradient, const int *need_gradient,
                               void *func_data);
 
+typedef void (*nlopt_f77_mfunc)(const int *m,
+                               double *val, const int *n, const double *x,
+                               double *gradient, const int *need_gradient,
+                               void *func_data);
+
 typedef struct {
      nlopt_f77_func f;
+     nlopt_f77_mfunc mf;
      void *f_data;
 } f77_func_data;
 
-static double f77_func_wrap(int n, const double *x, double *grad, void *data)
+static void *free_f77_func_data(void *p) { free(p); return NULL; }
+static void *dup_f77_func_data(void *p) { 
+     void *pnew = (void*) malloc(sizeof(f77_func_data));
+     if (pnew) memcpy(pnew, p, sizeof(f77_func_data));
+     return pnew;
+}
+
+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 +59,63 @@ 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;
+}
+
+static void f77_mfunc_wrap(unsigned m, double *result, unsigned n, const double *x, double *grad, void *data)
+{
+     f77_func_data *d = (f77_func_data *) data;
+     int mi = (int) m;
+     int ni = (int) n;
+     int need_gradient = grad != 0;
+     d->mf(&mi, result, &ni, x, grad, &need_gradient, d->f_data);
+}
+
+/*-----------------------------------------------------------------------*/
+
+#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, nlopt_opt *opt, T *val) { *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 . 
+   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. */
 
-   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
+#  define F77CALL(a, A) F77(a, A)
 
 /* 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 +123,7 @@ 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
+#  undef F77CALL
+#  define F77(a, A) NLOPT_STDCALL A
+#  define F77CALL(a, A) A
 #  include "f77funcs.h"
-
-#endif /* WINDOWS_F77_MANGLING */