Mercurial > hg > octave-nkf
changeset 3984:addebffd4961
[project @ 2002-07-11 03:39:33 by jwe]
author | jwe |
---|---|
date | Thu, 11 Jul 2002 03:39:34 +0000 |
parents | 7a37caf6ed43 |
children | fa0ae9105656 |
files | liboctave/ChangeLog liboctave/Makefile.in liboctave/ODE.h liboctave/ODES.cc liboctave/ODES.h liboctave/ODESFunc.h liboctave/ODESSA.cc liboctave/ODESSA.h liboctave/base-de.h src/ChangeLog src/DLD-FUNCTIONS/odessa.cc src/Makefile.in |
diffstat | 12 files changed, 2138 insertions(+), 70 deletions(-) [+] |
line wrap: on
line diff
--- a/liboctave/ChangeLog +++ b/liboctave/ChangeLog @@ -1,3 +1,13 @@ +2002-07-10 John W. Eaton <jwe@bevo.che.wisc.edu> + + * ODE.h: Move integrate and do_integrate method declarations and + definitions here. + * base-de.h: From here. + + * ODES.h, ODES.cc, ODESFunc.h, ODESSA.h, ODESSA.cc: New files. + * Makefile.in: Add them to the appropriate lists. + (LIBOCTAVE_CXX_SOURCES): + 2002-07-02 John W. Eaton <jwe@bevo.che.wisc.edu> * NLEqn.cc (NLEqn::error_message): New function.
--- a/liboctave/Makefile.in +++ b/liboctave/Makefile.in @@ -46,7 +46,8 @@ INCLUDES := Bounds.h CollocWt.h DAE.h DAEFunc.h DASPK.h DASSL.h FEGrid.h \ LinConst.h LP.h LPsolve.h LSODE.h NLConst.h NLEqn.h NLFunc.h \ - NLP.h ODE.h ODEFunc.h Objective.h QP.h Quad.h Range.h base-de.h \ + NLP.h ODE.h ODEFunc.h ODES.h ODESFunc.h ODESSA.h \ + Objective.h QP.h Quad.h Range.h base-de.h \ base-min.h byte-swap.h cmd-edit.h cmd-hist.h data-conv.h \ dir-ops.h file-ops.h file-stat.h getopt.h glob-match.h \ idx-vector.h lo-ieee.h lo-mappers.h lo-specfun.h lo-sysdep.h \ @@ -84,9 +85,10 @@ vx-rv-cs.cc vx-s-ccv.cc vx-s-crv.cc \ vx-rv-crv.cc vx-cv-ccv.cc vx-crv-rv.cc vx-ccv-cv.cc -LIBOCTAVE_CXX_SOURCES := Bounds.cc CollocWt.cc DAE.cc DASPK.cc \ - DASSL.cc FEGrid.cc LinConst.cc LPsolve.cc LSODE.cc \ - NLEqn.cc Quad.cc Range.cc data-conv.cc dir-ops.cc \ +LIBOCTAVE_CXX_SOURCES := Bounds.cc CollocWt.cc DAE.cc \ + DASPK.cc DASSL.cc FEGrid.cc LinConst.cc LPsolve.cc \ + LSODE.cc NLEqn.cc ODES.cc ODESSA.cc Quad.cc \ + Range.cc data-conv.cc dir-ops.cc \ file-ops.cc file-stat.cc glob-match.cc idx-vector.cc \ lo-ieee.cc lo-mappers.cc lo-specfun.cc lo-sysdep.cc \ lo-utils.cc mach-info.cc oct-alloc.cc oct-env.cc \
--- a/liboctave/ODE.h +++ b/liboctave/ODE.h @@ -51,6 +51,64 @@ } ~ODE (void) { } + + // Derived classes must provide functions to actually do the + // integration. + + // Return the vector of states at output time t. + virtual ColumnVector do_integrate (double tt) = 0; + + // Return a matrix of states at each output time specified by t. + // The rows of the result matrix should each correspond to a new + // output time. + virtual Matrix do_integrate (const ColumnVector& tt) = 0; + + virtual Matrix do_integrate (const ColumnVector& tt, + const ColumnVector& ttcrit) = 0; + + // Lots of ways to call the single function and optionally set and + // get additional information. + + // Integrate to t from current point. + virtual ColumnVector integrate (double tt) + { return do_integrate (tt); } + + // Set new x0, t0 and integrate to t. + virtual ColumnVector integrate (const ColumnVector& x0, double t0, double tt) + { + initialize (x0, t0); + return do_integrate (tt); + } + + // Integrate from current point and return output at all points + // specified by t. + virtual Matrix integrate (const ColumnVector& tt) + { return do_integrate (tt); } + + // Set new x0, t0 and integrate to return output at all points + // specified by t. + virtual Matrix integrate (const ColumnVector& x0, double t0, + const ColumnVector& tt) + { + initialize (x0, t0); + return do_integrate (tt); + } + + // Integrate from current point and return output at all points + // specified by t. + virtual Matrix integrate (const ColumnVector& tt, + const ColumnVector& ttcrit) + { return do_integrate (tt, ttcrit); } + + // Set new x0, t0 and integrate to return output at all points + // specified by t. + virtual Matrix integrate (const ColumnVector& x0, double t0, + const ColumnVector& tt, + const ColumnVector& ttcrit) + { + initialize (x0, t0); + return do_integrate (tt, ttcrit); + } }; #endif
new file mode 100644 --- /dev/null +++ b/liboctave/ODES.cc @@ -0,0 +1,54 @@ +/* + +Copyright (C) 2002 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +*/ + +#if defined (__GNUG__) +#pragma implementation +#endif + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include "ODES.h" +#include "lo-error.h" + +void +ODES::initialize (const ColumnVector& xx, double t) +{ + base_diff_eqn::initialize (xx, t); + xdot = ColumnVector (xx.length (), 0.0); +} + +void +ODES::initialize (const ColumnVector& xx, double t, + const ColumnVector& xtheta) +{ + base_diff_eqn::initialize (xx, t); + xdot = ColumnVector (xx.length (), 0.0); + theta = xtheta; +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; End: *** +*/
new file mode 100644 --- /dev/null +++ b/liboctave/ODES.h @@ -0,0 +1,89 @@ +/* + +Copyright (C) 2002 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +*/ + +#if !defined (octave_ODES_h) +#define octave_ODES_h 1 + +#if defined (__GNUG__) +#pragma interface +#endif + +#include "ODESFunc.h" +#include "base-de.h" + +class +ODES : public base_diff_eqn, public ODESFunc +{ +public: + + ODES (void) + : base_diff_eqn (), ODESFunc (), theta () { } + + ODES (const ColumnVector& x, double t, ODESFunc& f) + : base_diff_eqn (x, t), ODESFunc (f), xdot (x.length (), 0.0), theta () { } + + ODES (const ColumnVector& x, const ColumnVector& xtheta, double t, + ODESFunc& f) + : base_diff_eqn (x, t), ODESFunc (f), xdot (x.length (), 0.0), + theta (xtheta) { } + + ODES (const ODES& a) + : base_diff_eqn (a), ODESFunc (a), theta (a.theta) { } + + ODES& operator = (const ODES& a) + { + if (this != &a) + { + base_diff_eqn::operator = (a); + ODESFunc::operator = (a); + + xdot = a.xdot; + theta = a.theta; + } + return *this; + } + + ~ODES (void) { } + + ColumnVector parameter_vector (void) { return theta; } + + void initialize (const ColumnVector& x, double t); + + void initialize (const ColumnVector& x, double t, + const ColumnVector& theta); + +protected: + + // State vector time derivatives. + ColumnVector xdot; + + // Parameter vector. + ColumnVector theta; +}; + +#endif + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; End: *** +*/
new file mode 100644 --- /dev/null +++ b/liboctave/ODESFunc.h @@ -0,0 +1,117 @@ +/* + +Copyright (C) 2002 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +*/ + +#if !defined (octave_ODESFunc_h) +#define octave_ODESFunc_h 1 + +#include "dMatrix.h" + +class +ODESFunc +{ +public: + + struct DAEJac + { + Matrix *dfdxdot; + Matrix *dfdx; + }; + + typedef ColumnVector (*ODES_fsub) (double, const ColumnVector& x, + const ColumnVector& theta); + + typedef ColumnVector (*ODES_bsub) (double, const ColumnVector& x, + const ColumnVector& theta, int column); + + typedef Matrix (*ODES_jsub) (double, const ColumnVector& x, + const ColumnVector& theta); + + ODESFunc (void) + : fsub (0), bsub (0), jsub (0) { } + + ODESFunc (ODES_fsub f) + : fsub (f), bsub (0), jsub (0) { } + + ODESFunc (ODES_fsub f, ODES_bsub b) + : fsub (f), bsub (b), jsub (0) { } + + ODESFunc (ODES_fsub f, ODES_bsub b, ODES_jsub j) + : fsub (f), bsub (b), jsub (j) { } + + ODESFunc (const ODESFunc& a) + : fsub (a.fsub), bsub (a.bsub), jsub (a.jsub) { } + + ODESFunc& operator = (const ODESFunc& a) + { + if (this != &a) + { + fsub = a.fsub; + bsub = a.bsub; + jsub = a.jsub; + } + return *this; + } + + ~ODESFunc (void) { } + + ODES_fsub fsub_function (void) const { return fsub; } + + ODESFunc& set_fsub_function (ODES_fsub f) + { + fsub = f; + return *this; + } + + ODES_bsub bsub_function (void) const { return bsub; } + + ODESFunc& set_bsub_function (ODES_bsub b) + { + bsub = b; + return *this; + } + + ODES_jsub jsub_function (void) const { return jsub; } + + ODESFunc& set_jsub_function (ODES_jsub j) + { + jsub = j; + return *this; + } + +protected: + + ODES_fsub fsub; + ODES_bsub bsub; + ODES_jsub jsub; +}; + +#endif + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; End: *** +*/ + + + +
new file mode 100644 --- /dev/null +++ b/liboctave/ODESSA.cc @@ -0,0 +1,722 @@ +/* + +Copyright (C) 2002 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +*/ + +#if defined (__GNUG__) +#pragma implementation +#endif + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include <iostream.h> + +#include <cstdlib> +#include <cfloat> +#include <cmath> + +// For instantiating the Array<Matrix> object. +#include "Array.h" +#include "Array.cc" + +#include "ODESSA.h" +#include "f77-fcn.h" +#include "lo-error.h" +#include "error.h" +#include "gripes.h" +#include "oct-obj.h" +#include "ov-fcn.h" +#include "pager.h" +#include "parse.h" +#include "unwind-prot.h" +#include "utils.h" +#include "variables.h" + +#ifndef F77_FUNC +#define F77_FUNC(x, X) F77_FCN (x, X) +#endif +void +ODESSA_options::set_integration_method (const std::string& val) +{ + if (val == "stiff" || val == "bdf") + x_integration_method = "stiff"; + else if (val == "non-stiff" || val == "adams") + x_integration_method = "non-stiff"; + else + (*current_liboctave_error_handler) + ("odessa_options: method must be \"stiff\", \"bdf\", \"non-stiff\", or \"adams\""); +} + +typedef int (*odessa_fcn_ptr) (int*, const double&, double*, + double*, double*); + +typedef int (*odessa_jac_ptr) (int*, const double&, double*, + double*, const int&, const int&, + double*, const int&); + +typedef int (*odessa_dfdp_ptr) (int*, const double&, double*, + double*, double*, const int&); + + +extern "C" +int F77_FUNC (odessa, ODESSA) (odessa_fcn_ptr, odessa_dfdp_ptr, int*, + double*, double*, double&, double&, + int&, double&, const double*, int&, + int&, int*, double*, int&, int*, int&, + odessa_jac_ptr, int&); + +template class Array<Matrix>; + +static ODESFunc::ODES_fsub user_fsub; +static ODESFunc::ODES_bsub user_bsub; +static ODESFunc::ODES_jsub user_jsub; + + +static int +odessa_f (int* neq, const double& t, double *state, + double *par, double *fval) +{ + int n = neq[0]; + int n_par = neq[1]; + + // Load the state and parameter arrays as Octave objects + + ColumnVector tmp_state (n); + for (int i = 0; i < n; i++) + tmp_state(i) = state[i]; + + ColumnVector tmp_param (n_par); + for (int i = 0; i < n_par; i++) + tmp_param(i) = par[i]; + + ColumnVector tmp_fval = user_fsub (t, tmp_state, tmp_param); + + // Return the function value as a C array object + + for (int i = 0; i < n; i++) + { + fval[i] = tmp_fval(i); + } + + return 0; +} + +static int +odessa_j (int* neq, const double& t, double *state, + double *par, const int& ml, const int& mu, double *pd, const + int& nrowpd) +{ + int n = neq[0]; + int n_par = neq[1]; + + // Load the state and parameter arrays as Octave objects + ColumnVector tmp_state (n); + for (int i = 0; i < n; i++) + tmp_state(i) = state[i]; + + ColumnVector tmp_param (n_par); + for (int i = 0; i < n_par; i++) + tmp_param(i) = par[i]; + + Matrix tmp_fval = user_jsub (t, tmp_state, tmp_param); + + for (int j = 0; j < n; j++) + for (int i = 0; i < nrowpd; i++) + pd[nrowpd*j+i] = tmp_fval(i,j); + + return 0; +} + +static int +odessa_b (int* neq, const double& t, double *state, + double *par, double *dfdp, const int& jpar) + +{ + int n = neq[0]; + int n_par = neq[1]; + + // Load the state and parameter arrays as Octave objects + ColumnVector tmp_state (n); + for (int i = 0; i < n; i++) + tmp_state(i) = state[i]; + + ColumnVector tmp_param (n_par); + for (int i = 0; i < n_par; i++) + tmp_param(i) = par[i]; + + ColumnVector tmp_fval = user_bsub (t, tmp_state, tmp_param, jpar); + + for (int i = 0; i < n; i++) + dfdp[i] = tmp_fval(i); + + return 0; +} + +ODESSA::ODESSA (void) : ODES (), ODESSA_options () +{ + neq.resize(2); + n = size (); + + stop_time_set = false; + stop_time = 0.0; + + integration_error = false; + restart = true; + iopt.resize(4); + + istate = 1; + itask = 1; + iopt(0) = 0; + isopt = 0; + iopt(1) = isopt; + npar = 0; + neq(0) = n; + neq(1) = npar; + + sanity_checked = false; +} + +ODESSA::ODESSA (const ColumnVector& state, double time, ODESFunc& f) + : ODES (state, time, f), ODESSA_options () +{ + neq.resize(2); + n = size (); + + stop_time_set = false; + stop_time = 0.0; + + ODESFunc::operator = (f); + + integration_error = false; + restart = true; + + iopt.resize(4); + istate = 1; + itask = 1; + iopt(0) = 0; + isopt = 0; + iopt(1) = isopt; + + sanity_checked = false; + + npar = 0; + neq(0) = n; + neq(1) = npar; + + y.resize (n, 1, 0.0); +} + +ODESSA::ODESSA (const ColumnVector& state, const ColumnVector& theta, + const Matrix& sensitivity_guess, double time, ODESFunc& f) + : ODES (state, theta, time, f) +{ + initialized = false; + restart = false; + + neq.resize(2); + n = state.length(); + npar = theta.length(); + + neq(0) = n; + neq(1) = npar; + + stop_time_set = false; + stop_time = 0.0; + + ODESFunc::operator = (f); + + sx0 = sensitivity_guess; + par.resize (npar); + + for (int i = 0; i < npar; i++) + { + par(i) = theta(i); + } + + sanity_checked = false; + + npar = theta.length (); + + iopt.resize(4); + istate = 1; + itask = 1; + iopt(0) = 0; + isopt = 1; + iopt(1) = isopt; + + y.resize (n, npar+1, 0.0); +} + +void +ODESSA::force_restart (void) +{ + restart = true; +} + +void +ODESSA::set_stop_time (double time) +{ + stop_time_set = true; + stop_time = time; +} + +void +ODESSA::clear_stop_time (void) +{ + stop_time_set = 0; +} + +void +ODESSA::integrate (double tout) +{ + ODESSA_result retval; + if (! initialized) + { + + for (int i = 0; i < n; i++) + y(i,0) = x(i); + + if (npar > 0) + { + for (int j = 0; j < npar; j++) + for (int i = 0; i < n; i++) + y(i,j+1) = sx0(i,j); + } + + integration_error = false; + + user_fsub = ODESFunc::fsub_function (); + user_bsub = ODESFunc::bsub_function (); + user_jsub = ODESFunc::jsub_function (); + + int idf; + + if (user_bsub) + idf = 1; + else + idf = 0; + + iopt(2) = idf; + + + if (restart) + { + restart = false; + istate = 1; + } + + if (integration_method () == "stiff") + { + if (user_jsub) + method_flag = 21; + else + method_flag = 22; + if (isopt) + { + liw = 21 + n + npar; + lrw = 22 + 8*(npar+1)*n + n*n + n; + } + else + { + liw = 20 + n; + lrw = 22 + 9*n + n*n; + } + } + else + { + if (isopt) + { + if (user_jsub) + method_flag = 11; + else + method_flag = 12; + liw = 21 + n + npar; + lrw = 22 + 15*(npar+1)*n + n*n + n; + } + else + { + method_flag = 10; + liw = 20 + n; + lrw = 22 + 16 * n; + } + } + + if (iwork.length () != liw) + { + iwork.resize (liw); + + for (int i = 4; i < 10; i++) + iwork.elem (i) = 0; + } + + if (rwork.length () != lrw) + { + rwork.resize (lrw); + + for (int i = 4; i < 10; i++) + rwork.elem (i) = 0.0; + } + + initialized = true; + } + integration_error = false; + + // NOTE: this won't work if LSODE passes copies of the state vector. + // In that case we have to create a temporary vector object + // and copy. + + + if (! sanity_checked) + { + ColumnVector fval = user_fsub (t, x, theta); + + if (fval.length () != x.length ()) + { + (*current_liboctave_error_handler) + ("odessa: inconsistent sizes for state and residual vectors"); + + integration_error = true; + return; + } + + sanity_checked = true; + } + + if (stop_time_set) + { + itask = 4; + rwork.elem (0) = stop_time; + iopt(0) = 1; + } + else + { + itask = 1; + } + + double rel_tol = relative_tolerance (); + + Array<double> abs_tol = absolute_tolerance (); //note; this should + // be a matrix, not a vector + + int abs_tol_len = abs_tol.length (); + + int itol; + + if (abs_tol_len == 1) + itol = 1; + else if (abs_tol_len == n) + itol = 2; + else + { + (*current_liboctave_error_handler) + ("lsode: inconsistent sizes for state and absolute tolerance vectors"); + + integration_error = 1; + return; + } + + if (initial_step_size () >= 0.0) + { + rwork.elem (4) = initial_step_size (); + iopt(0) = 1; + } + + if (maximum_step_size () >= 0.0) + { + rwork.elem (5) = maximum_step_size (); + iopt(0) = 1; + } + + if (minimum_step_size () >= 0.0) + { + rwork.elem (6) = minimum_step_size (); + iopt(0) = 1; + } + + if (step_limit () > 0) + { + iwork.elem (5) = step_limit (); + iopt(0) = 1; + } + + py = y.fortran_vec (); + piwork = iwork.fortran_vec (); + prwork = rwork.fortran_vec (); + ppar = par.fortran_vec (); + piopt = iopt.fortran_vec (); + pneq = neq.fortran_vec (); + + const double *pabs_tol = abs_tol.fortran_vec (); + + F77_XFCN (odessa, ODESSA, (odessa_f,odessa_b,pneq,py,ppar,t, tout, + itol,rel_tol,pabs_tol,itask,istate, + piopt,prwork,lrw,piwork,liw,odessa_j, + method_flag)); + + if (f77_exception_encountered) + { + integration_error = true; + (*current_liboctave_error_handler) ("unrecoverable error in odessa"); + } + else + { + switch (istate) + { + case -13: // Return requested in user-supplied function. + case -6: // error weight became zero during problem. (solution + // component i vanished, and atol or atol(i) = 0.) + case -5: // repeated convergence failures (perhaps bad jacobian + // supplied or wrong choice of mf or tolerances). + case -4: // repeated error test failures (check all inputs). + case -3: // illegal input detected (see printed message). + case -2: // excess accuracy requested (tolerances too small). + case -1: // excess work done on this call (perhaps wrong mf). + integration_error = 1; + break; + + case 1: // tout is same as t + case 2: // lsode was successful + t = tout; + break; + + default: // Error? + (*current_liboctave_error_handler) + ("unrecognized value of istate returned from lsode"); + break; + } + } +} + +std::string +ODESSA::error_message (void) const +{ + std::string retval; + + switch (istate) + { + case -13: + retval = "return requested in user-supplied function"; + break; + + case -6: + retval = "Error weight became zero during problem.\ + (solution component i vanished, and atol or atol(i) == 0)"; + break; + + case -5: + retval = "repeated convergence failures (perhaps bad jacobian\ + supplied or wrong choice of integration method or tolerances)"; + break; + + case -4: + retval = "repeated error test failures (check all inputs)"; + break; + + case -3: + retval = "invalid input detected (see printed message)"; + break; + + case -2: + retval = "excess accuracy requested (tolerances too small)"; + break; + + case -1: + retval = "excess work on this call (perhaps wrong integration method)"; + break; + + case 1: + retval = "prior to initial call"; + break; + + case 2: + retval = "successful exit"; + break; + + case 3: + retval = "prior to continuation call with modified parameters"; + break; + + default: + retval = "unknown error state"; + break; + } + + return retval; +} + + +ODESSA_result +ODESSA::integrate (const ColumnVector& tout) +{ + ODESSA_result retval; + + Matrix x_out; + + Array<Matrix> x_s_out; + + int n_out = tout.capacity (); + + if (n_out > 0 && n > 0) + { + x_out.resize (n_out, n); + + x_s_out.resize (npar, Matrix (n_out, n, 0.0)); + + for (int j = 0; j < n_out; j++) + { + integrate (tout(j)); + + if (integration_error) + { + retval = ODESSA_result (x_out, x_s_out); + return retval; + } + + for (int i = 0; i < n; i++) + { + x_out(j,i) = y(i,0); + + for (int k = 0; k < npar; k++) + { + x_s_out(k)(j,i) = y(i,k+1); + } + } + } + } + + retval = ODESSA_result (x_out, x_s_out); + + return retval; +} + +ODESSA_result +ODESSA::integrate (const ColumnVector& tout, const ColumnVector& tcrit) +{ + ODESSA_result retval; + + Matrix x_out; + + Array<Matrix> x_s_out; + + int n_out = tout.capacity (); + + if (n_out > 0 && n > 0) + { + x_out.resize (n_out, n); + + x_s_out.resize (npar, Matrix (n_out, n, 0.0)); + + int n_crit = tcrit.capacity (); + + if (n_crit > 0) + { + int i_crit = 0; + int i_out = 0; + double next_crit = tcrit(0); + double next_out; + while (i_out < n_out) + { + bool do_restart = false; + + next_out = tout(i_out); + if (i_crit < n_crit) + next_crit = tcrit(i_crit); + + int save_output; + double t_out; + + if (next_crit == next_out) + { + set_stop_time (next_crit); + t_out = next_out; + save_output = true; + i_out++; + i_crit++; + do_restart = true; + } + else if (next_crit < next_out) + { + if (i_crit < n_crit) + { + set_stop_time (next_crit); + t_out = next_crit; + save_output = false; + i_crit++; + do_restart = true; + } + else + { + clear_stop_time (); + t_out = next_out; + save_output = true; + i_out++; + } + } + else + { + set_stop_time (next_crit); + t_out = next_out; + save_output = true; + i_out++; + } + integrate (t_out); + if (integration_error) + { + retval = ODESSA_result (x_out, x_s_out); + return retval; + } + if (save_output) + { + for (int i = 0; i < n; i++) + { + x_out(i_out-1,i) = y(i,0); + + for (int k = 0; k < npar; k++) + { + x_s_out(k)(i_out-1,i) = y(i,k+1); + } + } + } + + if (do_restart) + force_restart (); + } + + retval = ODESSA_result (x_out, x_s_out); + } + else + { + retval = integrate (tout); + + if (integration_error) + return retval; + } + } + + return retval; +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; End: *** +*/
new file mode 100644 --- /dev/null +++ b/liboctave/ODESSA.h @@ -0,0 +1,265 @@ +/* + +Copyright (C) 2002 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +*/ + +#if !defined (octave_ODESSA_h) +#define octave_ODESSA_h 1 + +#if defined (__GNUG__) +#pragma interface +#endif + +#include <cfloat> +#include <cmath> + +#include "ODES.h" + +class +ODESSA_options +{ +public: + + ODESSA_options (void) { init (); } + + ODESSA_options (const ODESSA_options& opt) { copy (opt); } + + ODESSA_options& operator = (const ODESSA_options& opt) + { + if (this != &opt) + copy (opt); + + return *this; + } + + ~ODESSA_options (void) { } + + void init (void) + { + double sqrt_eps = ::sqrt (DBL_EPSILON); + x_absolute_tolerance.resize (1); + x_absolute_tolerance(0) = sqrt_eps; + x_initial_step_size = -1.0; + x_integration_method = "stiff"; + x_maximum_step_size = -1.0; + x_minimum_step_size = 0.0; + x_relative_tolerance = sqrt_eps; + + // This is consistent with earlier versions of Octave, and is + // much larger than the default of 500 specified in the LSODE + // sources. + x_step_limit = 100000; + } + + void copy (const ODESSA_options& opt) + { + x_absolute_tolerance = opt.x_absolute_tolerance; + x_initial_step_size = opt.x_initial_step_size; + x_integration_method = opt.x_integration_method; + x_maximum_step_size = opt.x_maximum_step_size; + x_minimum_step_size = opt.x_minimum_step_size; + x_relative_tolerance = opt.x_relative_tolerance; + x_step_limit = opt.x_step_limit; + } + + void set_default_options (void) { init (); } + + void set_absolute_tolerance (double val) + { + x_absolute_tolerance.resize (1); + x_absolute_tolerance(0) = (val > 0.0) ? val : ::sqrt (DBL_EPSILON); + } + + void set_absolute_tolerance (const Array<double>& val) + { x_absolute_tolerance = val; } + + void set_initial_step_size (double val) + { x_initial_step_size = (val >= 0.0) ? val : -1.0; } + + void set_integration_method (const std::string& val); + + + void set_maximum_step_size (double val) + { x_maximum_step_size = (val >= 0.0) ? val : -1.0; } + + void set_minimum_step_size (double val) + { x_minimum_step_size = (val >= 0.0) ? val : 0.0; } + + void set_relative_tolerance (double val) + { x_relative_tolerance = (val > 0.0) ? val : ::sqrt (DBL_EPSILON); } + + void set_step_limit (int val) + { x_step_limit = val; } + + Array<double> absolute_tolerance (void) const + { return x_absolute_tolerance; } + + double initial_step_size (void) const + { return x_initial_step_size; } + + std::string integration_method (void) const + { return x_integration_method; } + + double maximum_step_size (void) const + { return x_maximum_step_size; } + + double minimum_step_size (void) const + { return x_minimum_step_size; } + + double relative_tolerance (void) const + { return x_relative_tolerance; } + + int step_limit (void) const + { return x_step_limit; } + +private: + + Array<double> x_absolute_tolerance; + double x_initial_step_size; + std::string x_integration_method; + double x_maximum_step_size; + double x_minimum_step_size; + double x_relative_tolerance; + + int x_step_limit; +}; + + +class +ODESSA_result +{ +public: + + ODESSA_result (void) { } + + ODESSA_result (const Matrix& xx, + const Array<Matrix>& xx_s) + + : x (xx), x_s (xx_s) { } + + ODESSA_result (const ODESSA_result& r) + : x (r.x), x_s (r.x_s) { } + + ODESSA_result& operator = (const ODESSA_result& r) + { + if (this != &r) + { + x = r.x; + x_s = r.x_s; + } + return *this; + } + + ~ODESSA_result (void) { } + + Matrix state (void) const { return x; } + Array<Matrix> state_sensitivity (void) const { return x_s; } + +private: + + Matrix x; + Array<Matrix> x_s; +}; + +class +ODESSA : public ODES, public ODESSA_options +{ +public: + + ODESSA (void); + + ODESSA (const ColumnVector& x, double time, ODESFunc& f); + + ODESSA (const ColumnVector& x, const ColumnVector& theta, + const Matrix& sensitivity_guess, double time, ODESFunc& f); + + ~ODESSA (void) { } + + void force_restart (void); + + void set_stop_time (double t); + void clear_stop_time (void); + + ODESSA_result integrate (const ColumnVector& tout); + + ODESSA_result integrate (const ColumnVector& tout, + const ColumnVector& tcrit); + + int integration_state (void) const { return istate; } + + bool integration_ok (void) const { return ! integration_error; } + + std::string error_message (void) const; + +private: + + bool initialized; + + bool sanity_checked; + + bool stop_time_set; + double stop_time; + + bool restart; + + bool integration_error; + + int liw; + int lrw; + int method_flag; + Array<int> iwork; + Array<double> rwork; + int istate; + int itask; + Array<int> iopt; + int isopt; + + Array<int> neq; + + int n; + int npar; + + // Hey, check out this crap: ZZZZ + Array<double> par; + + Matrix sx0; + + Matrix y; + + + double *py; + double *ppar; + int *piwork; + int *piopt; + int *pneq; + double *prwork; + + void init_work_size (int); + + void integrate (double t); +}; + +#endif + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; End: *** +*/
--- a/liboctave/base-de.h +++ b/liboctave/base-de.h @@ -49,69 +49,11 @@ return *this; } - // Derived classes must provide functions to actually do the - // integration. - - // Return the vector of states at output time t. - virtual ColumnVector do_integrate (double tt) = 0; + // There must be a way for us to force the integration to restart. - // Return a matrix of states at each output time specified by t. - // The rows of the result matrix should each correspond to a new - // output time. - virtual Matrix do_integrate (const ColumnVector& tt) = 0; - - virtual Matrix do_integrate (const ColumnVector& tt, - const ColumnVector& ttcrit) = 0; - - // There must also be a way for us to force the integration to - // restart. virtual void force_restart (void) = 0; - // Lots of ways to call the single function and optionally set and - // get additional information. - - // Integrate to t from current point. - virtual ColumnVector integrate (double tt) - { return do_integrate (tt); } - - // Set new x0, t0 and integrate to t. - virtual ColumnVector integrate (const ColumnVector& x0, double t0, double tt) - { - initialize (x0, t0); - return do_integrate (tt); - } - - // Integrate from current point and return output at all points - // specified by t. - virtual Matrix integrate (const ColumnVector& tt) - { return do_integrate (tt); } - - // Set new x0, t0 and integrate to return output at all points - // specified by t. - virtual Matrix integrate (const ColumnVector& x0, double t0, - const ColumnVector& tt) - { - initialize (x0, t0); - return do_integrate (tt); - } - - // Integrate from current point and return output at all points - // specified by t. - virtual Matrix integrate (const ColumnVector& tt, - const ColumnVector& ttcrit) - { return do_integrate (tt, ttcrit); } - - // Set new x0, t0 and integrate to return output at all points - // specified by t. - virtual Matrix integrate (const ColumnVector& x0, double t0, - const ColumnVector& tt, - const ColumnVector& ttcrit) - { - initialize (x0, t0); - return do_integrate (tt, ttcrit); - } - - virtual void initialize (const ColumnVector& x0, double t0) + void initialize (const ColumnVector& x0, double t0) { x = x0; t = t0;
--- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,8 @@ +2002-07-10 John W. Eaton <jwe@bevo.che.wisc.edu> + + * DLD-FUNCTIONS/odessa.cc: New file. + * Makefile.in (DLD_XSRC): Add it to the list. + 2002-07-05 John W. Eaton <jwe@bevo.che.wisc.edu> * pt-assign.cc (tree_multi_assignment::rvalue): Call
new file mode 100644 --- /dev/null +++ b/src/DLD-FUNCTIONS/odessa.cc @@ -0,0 +1,803 @@ +/* + +Copyright (C) 2002 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include <string> + +#include <iomanip> +#include <iostream> + +#include "ODESSA.h" +#include "lo-mappers.h" + +#include "defun-dld.h" +#include "error.h" +#include "gripes.h" +#include "oct-obj.h" +#include "ov-fcn.h" +#include "pager.h" +#include "pr-output.h" +#include "unwind-prot.h" +#include "utils.h" +#include "variables.h" +#include "parse.h" + +// Global pointer for user defined function required by odessa. +static octave_function *odessa_f; +static octave_function *odessa_j; +static octave_function *odessa_b; + +static ODESSA_options odessa_opts; + +// Is this a recursive call? +static int call_depth = 0; + +static ColumnVector +odessa_user_f (double t, const ColumnVector& x, const ColumnVector& theta) +{ + ColumnVector retval; + + octave_value_list args; + + int n = x.length (); + int npar = theta.length (); + + if (npar > 1) + args(2) = theta; + else if (npar == 1) + args(2) = theta(0); + else + args(2) = Matrix (); + + if (n > 1) + args(1) = x; + else if (n == 1) + args(1) = x(0); + else + args(1) = Matrix (); + + args(0) = t; + + if (odessa_f) + { + octave_value_list tmp = odessa_f->do_multi_index_op (1, args); + + if (error_state) + { + gripe_user_supplied_eval ("odessa"); + return retval; + } + + if (tmp.length () > 0 && tmp(0).is_defined ()) + { + retval = ColumnVector (tmp(0).vector_value ()); + + if (error_state || retval.length () == 0) + gripe_user_supplied_eval ("odessa"); + } + else + gripe_user_supplied_eval ("odessa"); + } + + return retval; +} + +static Matrix +odessa_user_mf (double t, const ColumnVector& x, const ColumnVector& theta, + octave_function *mf) +{ + Matrix retval; + + if (mf) + { + octave_value_list args; + + int n = x.length (); + int npar = theta.length (); + + if (npar > 1) + args(2) = theta; + else if (npar == 1) + args(2) = theta(0); + else + args(2) = Matrix (); + + if (n > 1) + args(1) = x; + else if (n == 1) + args(1) = x(0); + else + args(1) = Matrix (); + + args(0) = t; + + octave_value_list tmp = mf->do_multi_index_op (1, args); + + if (error_state) + { + gripe_user_supplied_eval ("odessa"); + return retval; + } + + if (tmp.length () > 0 && tmp(0).is_defined ()) + { + retval = tmp(0).matrix_value (); + + if (error_state || retval.length () == 0) + gripe_user_supplied_eval ("odessa"); + } + else + gripe_user_supplied_eval ("odessa"); + } + + return retval; +} + +static Matrix +odessa_user_j (double t, const ColumnVector& x, const ColumnVector& theta) +{ + return odessa_user_mf (t, x, theta, odessa_j); +} + +static ColumnVector +odessa_user_b (double t, const ColumnVector& x, + const ColumnVector& theta, int column) +{ + ColumnVector retval; + + if (odessa_b) + { + octave_value_list args; + + int n = x.length (); + int npar = theta.length (); + + args(3) = static_cast<double> (column); + + if (npar > 1) + args(2) = theta; + else if (npar == 1) + args(2) = theta(0); + else + args(2) = Matrix (); + + if (n > 1) + args(1) = x; + else if (n == 1) + args(1) = x(0); + else + args(1) = Matrix (); + + args(0) = t; + + octave_value_list tmp = odessa_b->do_multi_index_op (1, args); + + if (error_state) + { + gripe_user_supplied_eval ("odessa"); + return retval; + } + + if (tmp.length () > 0 && tmp(0).is_defined ()) + { + retval = ColumnVector (tmp(0).vector_value ()); + + if (error_state || retval.length () == 0) + gripe_user_supplied_eval ("odessa"); + } + else + gripe_user_supplied_eval ("odessa"); + } + + return retval; +} + +static octave_value_list +make_list (const Array<Matrix>& m_array) +{ + octave_value_list retval; + + int len = m_array.length (); + + retval.resize (len); + + for (int i = 0; i < len; i++) + retval(i) = m_array(i); + + return retval; +} + +#define ODESSA_ABORT() \ + do \ + { \ + unwind_protect::run_frame ("Fodessa"); \ + return retval; \ + } \ + while (0) + +#define ODESSA_ABORT1(msg) \ + do \ + { \ + ::error ("odessa: " msg); \ + ODESSA_ABORT (); \ + } \ + while (0) + +#define ODESSA_ABORT2(fmt, arg) \ + do \ + { \ + ::error ("odessa: " fmt, arg); \ + ODESSA_ABORT (); \ + } \ + while (0) + +// -------------------------------- +// Everthing is so great above here +// -------------------------------- + +DEFUN_DLD (odessa, args, , + "odessa (\"f\", x_0, theta, sx_0, t_out, t_crit)\n\ +\n\ +The string \"f\" may be substituted for the vector of strings\n\ +\n\ + [\"f\"; \"j\"; \"b\"] \n\ +\n\ +You can use the function @code{odessa_options} to set optional\n\ +parameters for @code{odessa}.") +{ + octave_value_list retval; + + unwind_protect::begin_frame ("Fodessa"); + + unwind_protect_int (call_depth); + call_depth++; + + if (call_depth > 1) + ODESSA_ABORT1 ("invalid recursive call"); + + int nargin = args.length (); + + if (nargin < 5 || nargin > 6) + { + print_usage ("odessa"); + unwind_protect::run_frame ("Fodessa"); + return retval; + } + + odessa_f = 0; + odessa_j = 0; + odessa_b = 0; + + octave_value f_arg = args(0); + + if (f_arg.is_string ()) + { + string_vector f_str_arg = f_arg.all_strings (); + + int len = f_str_arg.length (); + + if (len > 2) + { + string t = f_str_arg(2); + + if (t.length () > 0) + { + odessa_b = is_valid_function (t, "odessa", true); + + if (! odessa_b) + ODESSA_ABORT1 + ("expecting b function name as argument 1"); + } + } + + if (len > 1) + { + string t = f_str_arg(1); + + if (t.length () > 0) + { + odessa_j = is_valid_function (t, "odessa", true); + + if (! odessa_j) + ODESSA_ABORT1 + ("expecting function name as argument 1"); + } + } + + if (len > 0) + odessa_f = is_valid_function (f_str_arg(0), "odessa", true); + + if (! odessa_f) + ODESSA_ABORT1 ("expecting function name as argument 1"); + } + + ColumnVector state (args(1).vector_value ()); + + if (error_state) + ODESSA_ABORT1 ("expecting state vector as argument 2"); + + bool have_parameters = false; + + ColumnVector theta; + Matrix sensitivity_guess; + + if (nargin == 5 || nargin == 6) + { + octave_value theta_arg = args(2); + + if (! theta_arg.is_empty ()) + { + theta = ColumnVector (theta_arg.vector_value ()); + + if (error_state) + ODESSA_ABORT1 + ("expecting parameter vector as argument 3"); + } + + have_parameters = (theta.length () > 0); + + if (have_parameters) + { + sensitivity_guess = args(3).matrix_value (); + + if (error_state) + ODESSA_ABORT1 + ("expecting sensitivity guess as argument 4"); + + if (sensitivity_guess.rows () != state.length () + || sensitivity_guess.columns () != theta.length ()) + ODESSA_ABORT1 + ("incorrect dimension for sensitivity guess"); + } + } + + ColumnVector out_times (args(4).vector_value ()); + + if (error_state) + ODESSA_ABORT1 + ("expecting output time vector as %s argument 5"); + + ColumnVector crit_times; + + bool crit_times_set = false; + + if (nargin==6) + { + crit_times = ColumnVector (args(5).vector_value ()); + + if (error_state) + ODESSA_ABORT1 + ("expecting critical time vector as argument 6"); + + crit_times_set = true; + } + + ODESFunc func (odessa_user_f); + + if (odessa_j) + func.set_jsub_function (odessa_user_j); + + if (odessa_b) + func.set_bsub_function (odessa_user_b); + + double tzero = out_times (0); + + ODESSA_result output; + + if (have_parameters) + { + ODESSA dae = ODESSA (state, theta, sensitivity_guess, tzero, func); + + dae.copy (odessa_opts); + + if (crit_times_set) + output = dae.integrate (out_times, crit_times); + else + output = dae.integrate (out_times); + } + else + { + ODESSA dae = ODESSA (state, tzero, func); + + dae.copy (odessa_opts); + + if (crit_times_set) + output = dae.integrate (out_times, crit_times); + else + output = dae.integrate (out_times); + } + + if (! error_state) + { + if (have_parameters) + { + retval(1) = make_list (output.state_sensitivity ()); + } + + retval(0) = output.state (); + } + + unwind_protect::run_frame ("Fodessa"); + + return retval; +} +// ----------------------------- +// EVERYTHING SWELL BELOW HERE +// ----------------------------- + + +typedef void (ODESSA_options::*da_set_opt_mf) (const Array<double>&); +typedef void (ODESSA_options::*d_set_opt_mf) (double); +typedef void (ODESSA_options::*i_set_opt_mf) (int); +typedef void (ODESSA_options::*s_set_opt_mf) (const std::string&); + +typedef Array<double> (ODESSA_options::*da_get_opt_mf) (void) const; +typedef double (ODESSA_options::*d_get_opt_mf) (void) const; +typedef int (ODESSA_options::*i_get_opt_mf) (void) const; +typedef std::string (ODESSA_options::*s_get_opt_mf) (void) const; + +#define MAX_TOKENS 3 + +struct ODESSA_OPTIONS +{ + const char *keyword; + const char *kw_tok[MAX_TOKENS + 1]; + int min_len[MAX_TOKENS + 1]; + int min_toks_to_match; + da_set_opt_mf da_set_fcn; + d_set_opt_mf d_set_fcn; + i_set_opt_mf i_set_fcn; + s_set_opt_mf s_set_fcn; + da_get_opt_mf da_get_fcn; + d_get_opt_mf d_get_fcn; + i_get_opt_mf i_get_fcn; + s_get_opt_mf s_get_fcn; +}; + +static ODESSA_OPTIONS odessa_option_table [] = +{ + { "absolute tolerance", + { "absolute", "tolerance", 0, 0, }, + { 1, 0, 0, 0, }, 1, + &ODESSA_options::set_absolute_tolerance, 0, 0, 0, + &ODESSA_options::absolute_tolerance, 0, 0, 0, }, + + { "initial step size", + { "initial", "step", "size", 0, }, + { 3, 0, 0, 0, }, 1, + 0, &ODESSA_options::set_initial_step_size, 0, 0, + 0, &ODESSA_options::initial_step_size, 0, 0, }, + + { "integration method", + { "integration", "method", 0, 0, }, + { 3, 0, 0, 0, }, 1, + 0, 0, 0, &ODESSA_options::set_integration_method, + 0, 0, 0, &ODESSA_options::integration_method, }, + + { "maximum step size", + { "maximum", "step", "size", 0, }, + { 2, 0, 0, 0, }, 1, + 0, &ODESSA_options::set_maximum_step_size, 0, 0, + 0, &ODESSA_options::maximum_step_size, 0, 0, }, + + { "minimum step size", + { "minimum", "step", "size", 0, }, + { 2, 0, 0, 0, }, 1, + 0, &ODESSA_options::set_minimum_step_size, 0, 0, + 0, &ODESSA_options::minimum_step_size, 0, 0, }, + + { "relative tolerance", + { "relative", "tolerance", 0, 0, }, + { 1, 0, 0, 0, }, 1, + 0, &ODESSA_options::set_relative_tolerance, 0, 0, + 0, &ODESSA_options::relative_tolerance, 0, 0, }, + + { "step limit", + { "step", "limit", 0, 0, }, + { 1, 0, 0, 0, }, 1, + 0, 0, &ODESSA_options::set_step_limit, 0, + 0, 0, &ODESSA_options::step_limit, 0, }, + + { 0, + { 0, 0, 0, 0, }, + { 0, 0, 0, 0, }, 0, + 0, 0, 0, 0, + 0, 0, 0, 0, }, +}; + +static void +print_odessa_option_list (std::ostream& os) +{ + print_usage ("odessa_options", 1); + + os << "\n" + << "Options for odessa include:\n\n" + << " keyword value\n" + << " ------- -----\n\n"; + + ODESSA_OPTIONS *list = odessa_option_table; + + const char *keyword; + while ((keyword = list->keyword) != 0) + { + os << " " + << std::setiosflags (std::ios::left) << std::setw (40) + << keyword + << std::resetiosflags (std::ios::left) + << " "; + + if (list->da_get_fcn) + { + Array<double> val = (odessa_opts.*list->da_get_fcn) (); + if (val.length () == 1) + { + if (val(0) < 0.0) + os << "computed automatically"; + else + os << val(0); + } + else + { + os << "\n\n"; + // XXX FIXME XXX + Matrix tmp = Matrix (ColumnVector (val)); + octave_print_internal (os, tmp, false, 2); + os << "\n"; + } + } + else if (list->d_get_fcn) + { + double val = (odessa_opts.*list->d_get_fcn) (); + if (val < 0.0) + os << "computed automatically"; + else + os << val; + } + else if (list->i_get_fcn) + { + int val = (odessa_opts.*list->i_get_fcn) (); + if (val < 0) + os << "infinite"; + else + os << val; + } + else if (list->s_get_fcn) + { + os << (odessa_opts.*list->s_get_fcn) (); + } + else + panic_impossible (); + + os << "\n"; + list++; + } + + os << "\n"; +} + +static void +set_odessa_option (const std::string& keyword, double val) +{ + ODESSA_OPTIONS *list = odessa_option_table; + + while (list->keyword != 0) + { + if (keyword_almost_match (list->kw_tok, list->min_len, keyword, + list->min_toks_to_match, MAX_TOKENS)) + { + if (list->da_set_fcn) + { + Array<double> tmp (1, val); + (odessa_opts.*list->da_set_fcn) (tmp); + } + else if (list->d_set_fcn) + { + (odessa_opts.*list->d_set_fcn) (val); + } + else + { + if (xisnan (val)) + { + error ("odessa_options: %s: expecting integer, found NaN", + keyword.c_str ()); + } + else + (odessa_opts.*list->i_set_fcn) (NINT (val)); + } + return; + } + list++; + } + + warning ("odessa_options: no match for `%s'", keyword.c_str ()); +} + +static void +set_odessa_option (const std::string& keyword, const Array<double>& val) +{ + ODESSA_OPTIONS *list = odessa_option_table; + + while (list->keyword != 0) + { + if (keyword_almost_match (list->kw_tok, list->min_len, keyword, + list->min_toks_to_match, MAX_TOKENS)) + { + if (list->da_set_fcn) + (odessa_opts.*list->da_set_fcn) (val); + else + error ("odessa_options: no function to handle vector option"); + + return; + } + list++; + } + + warning ("odessa_options: no match for `%s'", keyword.c_str ()); +} + +static void +set_odessa_option (const std::string& keyword, const std::string& val) +{ + ODESSA_OPTIONS *list = odessa_option_table; + + while (list->keyword != 0) + { + if (keyword_almost_match (list->kw_tok, list->min_len, keyword, + list->min_toks_to_match, MAX_TOKENS)) + { + if (list->s_set_fcn) + (odessa_opts.*list->s_set_fcn) (val); + else + error ("odessa_options: no function to handle string option"); + + return; + } + list++; + } + + warning ("odessa_options: no match for `%s'", keyword.c_str ()); +} + +static octave_value_list +show_odessa_option (const std::string& keyword) +{ + octave_value retval; + + ODESSA_OPTIONS *list = odessa_option_table; + + while (list->keyword != 0) + { + if (keyword_almost_match (list->kw_tok, list->min_len, keyword, + list->min_toks_to_match, MAX_TOKENS)) + { + if (list->da_get_fcn) + { + Array<double> val = (odessa_opts.*list->da_get_fcn) (); + if (val.length () == 1) + { + if (val(0) < 0.0) + retval = "computed automatically"; + else + retval = val(0); + } + else + retval = ColumnVector (val); + } + else if (list->d_get_fcn) + { + double val = (odessa_opts.*list->d_get_fcn) (); + if (val < 0.0) + retval = "computed automatically"; + else + retval = val; + } + else if (list->i_get_fcn) + { + int val = (odessa_opts.*list->i_get_fcn) (); + if (val < 0) + retval = "infinite"; + else + retval = static_cast<double> (val); + } + else if (list->s_get_fcn) + { + retval = (odessa_opts.*list->s_get_fcn) (); + } + else + panic_impossible (); + + return retval; + } + list++; + } + + warning ("odessa_options: no match for `%s'", keyword.c_str ()); + + return retval; +} + +DEFUN_DLD (odessa_options, args, , + "-*- texinfo -*-\n\ +@deftypefn {Loadable Function} {} odessa_options (@var{opt}, @var{val})\n\ +When called with two arguments, this function allows you set options\n\ +parameters for the function @code{odessa}. Given one argument,\n\ +@code{odessa_options} returns the value of the corresponding option. If\n\ +no arguments are supplied, the names of all the available options and\n\ +their current values are displayed.\n\ +@end deftypefn") +{ + octave_value_list retval; + + int nargin = args.length (); + + if (nargin == 0) + { + print_odessa_option_list (octave_stdout); + } + else if (nargin == 1 || nargin == 2) + { + std::string keyword = args(0).string_value (); + + if (! error_state) + { + if (nargin == 1) + retval = show_odessa_option (keyword); + else + { + if (args(1).is_string ()) + { + std::string val = args(1).string_value (); + + if (! error_state) + set_odessa_option (keyword, val); + } + else if (args(1).is_scalar_type ()) + { + double val = args(1).double_value (); + + if (! error_state) + set_odessa_option (keyword, val); + } + else + { + Array<double> val = args(1).vector_value (); + + if (! error_state) + set_odessa_option (keyword, val); + } + } + } + } + else + print_usage ("odessa_options"); + + return retval; +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; End: *** +*/
--- a/src/Makefile.in +++ b/src/Makefile.in @@ -39,12 +39,13 @@ endif endif -DLD_XSRC := balance.cc besselj.cc betainc.cc chol.cc colloc.cc daspk.cc \ - dassl.cc det.cc eig.cc expm.cc fft.cc fft2.cc filter.cc find.cc \ - fsolve.cc gammainc.cc getgrent.cc getpwent.cc getrusage.cc \ - givens.cc hess.cc ifft.cc ifft2.cc inv.cc kron.cc log.cc lpsolve.cc \ - lsode.cc lu.cc minmax.cc pinv.cc qr.cc quad.cc qz.cc rand.cc \ - schur.cc sort.cc svd.cc syl.cc time.cc +DLD_XSRC := balance.cc besselj.cc betainc.cc chol.cc colloc.cc \ + daspk.cc dassl.cc det.cc eig.cc expm.cc fft.cc fft2.cc \ + filter.cc find.cc fsolve.cc gammainc.cc getgrent.cc \ + getpwent.cc getrusage.cc givens.cc hess.cc ifft.cc ifft2.cc \ + inv.cc kron.cc log.cc lpsolve.cc lsode.cc lu.cc minmax.cc \ + odessa.cc pinv.cc qr.cc quad.cc qz.cc rand.cc schur.cc \ + sort.cc svd.cc syl.cc time.cc DLD_SRC := $(addprefix DLD-FUNCTIONS/, $(DLD_XSRC))