Mercurial > octave
diff libinterp/dldfcn/__ode15__.cc @ 22901:4c56f3ffec04
Add functions ode15i and ode15s
* libinterp/dldfcn/__ode15__.cc: Add oct-file backend for
m-files ode15i.m and ode15s.m.
* scripts/ode/ode15i.m: Add wrapper function ode15i.m.
* scripts/ode/ode15s.m: Add wrapper function ode15s.m.
* scripts/ode/private/check_default_input.m: Add private
function to check default input of ode15i and ode15s.
* libinterp/dldfcn/module-files: Add __ode15__.cc and its flags.
author | Francesco Faccio <francesco.faccio@mail.polimi.it> |
---|---|
date | Tue, 23 Aug 2016 03:19:11 +0200 |
parents | |
children | 284bbb0328f2 |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/libinterp/dldfcn/__ode15__.cc Tue Aug 23 03:19:11 2016 +0200 @@ -0,0 +1,1321 @@ +/* + +Copyright (C) 2016 Francesco Faccio <francesco.faccio@mail.polimi.it> + +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 3 of the License, 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, see +<http://www.gnu.org/licenses/>. + +*/ + +#if defined (HAVE_CONFIG_H) +# include "config.h" +#endif + +#if defined (HAVE_IDA_IDA_H) +#include <ida/ida.h> +#include <ida/ida_dense.h> +#include <ida/ida_klu.h> +#include <sundials/sundials_sparse.h> +#endif + +#if defined (HAVE_NVECTOR_NVECTOR_SERIAL_H) +#include <nvector/nvector_serial.h> +#endif + + +#include <oct.h> +#include <parse.h> +#include <time.h> + +#include "defun-dld.h" +#include "iostream" +#include "error.h" +#include "ov.h" +#include "ov-struct.h" +#include "errwarn.h" + +#include "algorithm" +#include "iterator" + + +#if defined (HAVE_SUNDIALS) + +namespace octave +{ + class IDA + { + public: + + typedef + ColumnVector (*DAERHSFuncIDA) (const ColumnVector& x, + const ColumnVector& xdot, + realtype t, octave_function *idaf); + + typedef + Matrix (*DAEJacFuncDense) (const ColumnVector& x, + const ColumnVector& xdot, realtype t, + realtype cj, octave_function *idaj); + + typedef + SparseMatrix (*DAEJacFuncSparse) (const ColumnVector& x, + const ColumnVector& xdot, + realtype t, realtype cj, + octave_function *idaj); + + typedef + Matrix (*DAEJacCellDense) (Matrix *dfdy, Matrix *dfdyp, + realtype cj); + + typedef + SparseMatrix (*DAEJacCellSparse) (SparseMatrix *dfdy, + SparseMatrix *dfdyp, realtype cj); + + //Default + IDA (void) + : t0 (0.0), y0 (), yp0 (), havejac (false), havejacfun (false), + havejacsparse (false), mem (NULL), num (), ida_fun (NULL), + ida_jac (NULL), dfdy (NULL), dfdyp (NULL), spdfdy (NULL), + spdfdyp (NULL), fun (0), jacfun (NULL), jacspfun (0), + jacdcell (0), jacspcell (0) + { }; + + + IDA (realtype t, ColumnVector y, ColumnVector yp, + octave_function *ida_fcn, DAERHSFuncIDA daefun) + : t0 (t), y0 (y), yp0 (yp), havejac (false), havejacfun (false), + havejacsparse (false), mem (NULL), num (), ida_fun (ida_fcn), + ida_jac (NULL), dfdy (NULL), dfdyp (NULL), spdfdy (NULL), + spdfdyp (NULL), fun (daefun), jacfun (NULL), jacspfun (0), + jacdcell (0), jacspcell (0) + { }; + + + ~IDA (void) { IDAFree (&mem); } + + IDA& + set_jacobian (octave_function *jac, DAEJacFuncDense j) + { + jacfun = j; + ida_jac = jac; + havejac = true; + havejacfun = true; + havejacsparse = false; + return *this; + } + + IDA& + set_jacobian (octave_function *jac, DAEJacFuncSparse j) + { + jacspfun = j; + ida_jac = jac; + havejac = true; + havejacfun = true; + havejacsparse = true; + return *this; + } + + IDA& + set_jacobian (Matrix *dy, Matrix *dyp, DAEJacCellDense j) + { + jacdcell = j; + dfdy = dy; + dfdyp = dyp; + havejac = true; + havejacfun = false; + havejacsparse = false; + return *this; + } + + IDA& + set_jacobian (SparseMatrix *dy, SparseMatrix *dyp, + DAEJacCellSparse j) + { + jacspcell = j; + spdfdy = dy; + spdfdyp = dyp; + havejac = true; + havejacfun = false; + havejacsparse = true; + return *this; + } + + void + set_userdata (void); + + void + initialize (void); + + static ColumnVector + NVecToCol (N_Vector& v, long int n); + + static N_Vector + ColToNVec (const ColumnVector& data, long int n); + + void + set_up (void); + + void + set_tolerance (ColumnVector& abstol, realtype reltol); + + void + set_tolerance (realtype abstol, realtype reltol); + + static int + resfun (realtype t, N_Vector yy, N_Vector yyp, + N_Vector rr, void *user_data); + + void + resfun_impl (realtype t, N_Vector& yy, + N_Vector& yyp, N_Vector& rr); + + static int + jacdense (long int Neq, realtype t, realtype cj, + N_Vector yy, N_Vector yyp, N_Vector resvec, + DlsMat JJ, void *user_data, N_Vector tempv1, + N_Vector tempv2, N_Vector tempv3) + { + IDA *self = + static_cast <IDA *> (user_data); + + self -> jacdense_impl (Neq, t, cj, yy, yyp, JJ); + return 0; + } + + void + jacdense_impl (long int Neq, realtype t, realtype cj, + N_Vector& yy, N_Vector& yyp, DlsMat& JJ); + + static int + jacsparse (realtype t, realtype cj, N_Vector yy, N_Vector yyp, + N_Vector r, SlsMat Jac, void *user_data, N_Vector tmp1, + N_Vector tmp2, N_Vector tmp3) + { + IDA *self = + static_cast <IDA *> (user_data); + + self -> jacsparse_impl (t, cj, yy, yyp, Jac); + return 0; + } + + void + jacsparse_impl (realtype t, realtype cj, N_Vector& yy, + N_Vector& yyp, SlsMat& Jac); + + void + set_maxstep (realtype maxstep); + + void + set_initialstep (realtype initialstep); + + bool + interpolate (int& cont, Matrix& output, ColumnVector& tout, + int refine, realtype tend, bool haveoutputfcn, + bool haveoutputsel, octave_function *output_fcn, + ColumnVector& outputsel, bool haveeventfunction, + octave_function * event_fcn, ColumnVector& te, + Matrix& ye, ColumnVector& ie, ColumnVector& oldval, + ColumnVector& oldisterminal, ColumnVector& olddir, + int& temp, ColumnVector& yold); + + bool + outputfun (octave_function *output_fcn, bool haveoutputsel, + const ColumnVector& output, realtype tout, realtype tend, + ColumnVector& outputsel, std::string flag); + + + bool + event (octave_function *event_fcn, + ColumnVector& te, Matrix& ye, ColumnVector& ie, + realtype tsol, const ColumnVector& y, std::string flag, + const ColumnVector& yp, ColumnVector& oldval, + ColumnVector& oldisterminal, ColumnVector& olddir, + int cont, int& temp, realtype told, ColumnVector& yold); + + void + set_maxorder (int maxorder); + + octave_value_list + integrate (const int numt, const ColumnVector& tt, + const ColumnVector& y0, const ColumnVector& yp0, + const int refine, bool haverefine, bool haveoutputfcn, + octave_function *output_fcn, bool haveoutputsel, + ColumnVector& outputsel, bool haveeventfunction, + octave_function *event_fcn); + + void + print_stat (void); + + private: + + realtype t0; + ColumnVector y0; + ColumnVector yp0; + bool havejac; + bool havejacfun; + bool havejacsparse; + void *mem; + int num; + octave_function *ida_fun; + octave_function *ida_jac; + Matrix *dfdy; + Matrix *dfdyp; + SparseMatrix *spdfdy; + SparseMatrix *spdfdyp; + DAERHSFuncIDA fun; + DAEJacFuncDense jacfun; + DAEJacFuncSparse jacspfun; + DAEJacCellDense jacdcell; + DAEJacCellSparse jacspcell; + + }; + + int + IDA::resfun (realtype t, N_Vector yy, N_Vector yyp, N_Vector rr, + void *user_data) + { + IDA *self = + static_cast <IDA *> (user_data); + + self -> resfun_impl (t, yy, yyp, rr); + return 0; + } + + void + IDA::resfun_impl (realtype t, N_Vector& yy, + N_Vector& yyp, N_Vector& rr) + { + BEGIN_INTERRUPT_WITH_EXCEPTIONS; + + ColumnVector y = + IDA::NVecToCol (yy, num); + + ColumnVector yp = + IDA::NVecToCol (yyp, num); + + ColumnVector res = + (*fun) (y, yp, t, ida_fun); + + realtype *puntrr = + NV_DATA_S (rr); + + for (octave_idx_type i = 0; i < num; i++) + puntrr [i] = res (i); + + END_INTERRUPT_WITH_EXCEPTIONS; + } + + void + IDA::set_up (void) + { + if (havejacsparse) + { + int flag = + IDAKLU (mem, num, num*num); + if (flag != 0) + { + error ("IDAKLU solver not initialized"); + } + flag = IDASlsSetSparseJacFn (mem, IDA::jacsparse); + } + else + { + int flag = + IDADense (mem, num); + if (flag != 0) + { + error ("IDADense solver not initialized"); + } + if (havejac) + { + flag = IDADlsSetDenseJacFn (mem, IDA::jacdense); + if (flag != 0) + { + error ("Dense Jacobian not set"); + } + } + } + } + + void + IDA::jacdense_impl (long int Neq, realtype t, realtype cj, + N_Vector& yy, N_Vector& yyp, DlsMat& JJ) + + { + BEGIN_INTERRUPT_WITH_EXCEPTIONS; + + ColumnVector y = + NVecToCol (yy, Neq); + + ColumnVector yp = + NVecToCol (yyp, Neq); + + Matrix jac; + + if (havejacfun) + jac = (*jacfun) (y, yp, t, cj, ida_jac); + else + jac = (*jacdcell) (dfdy, dfdyp, cj); + + std::copy (jac.fortran_vec (), + jac.fortran_vec () + jac.numel (), + JJ -> data); + + END_INTERRUPT_WITH_EXCEPTIONS; + } + + void + IDA::jacsparse_impl (realtype t, realtype cj, N_Vector& yy, N_Vector& yyp, + SlsMat& Jac) + + { + BEGIN_INTERRUPT_WITH_EXCEPTIONS; + + ColumnVector y = + NVecToCol (yy, num); + + ColumnVector yp = + NVecToCol (yyp, num); + + SparseMatrix jac; + + if (havejacfun) + jac = (*jacspfun) (y, yp, t, cj, ida_jac); + else + jac = (*jacspcell) (spdfdy, spdfdyp, cj); + + SlsSetToZero (Jac); + + for (int i = 0; i < num + 1; i++) + Jac -> colptrs [i] = jac.cidx (i); + + for (int i = 0; i < jac.nnz (); i++) + { + Jac -> rowvals [i] = jac.ridx (i); + Jac -> data [i] = jac.data (i); + } + + END_INTERRUPT_WITH_EXCEPTIONS; + } + + ColumnVector + IDA::NVecToCol (N_Vector& v, long int n) + { + ColumnVector data (n); + realtype *punt; + punt = NV_DATA_S (v); + + for (octave_idx_type i = 0; i < n; i++) + data (i) = punt [i]; + + return data; + } + + N_Vector + IDA::ColToNVec (const ColumnVector &data, long int n) + { + N_Vector v = + N_VNew_Serial (n); + + realtype * punt; + punt = NV_DATA_S (v); + + for (octave_idx_type i = 0; i < n; i++) + punt [i] = data (i); + + return v; + } + + void + IDA::set_userdata (void) + { + void * userdata = this; + + int flag = + IDASetUserData(mem, userdata); + if (flag != 0) + { + error ("User data not set"); + } + } + + void + IDA::initialize (void) + { + num = y0.numel(); + mem = IDACreate (); + + N_Vector yy = + ColToNVec(y0, num); + + N_Vector yyp = + ColToNVec(yp0, num); + + IDA::set_userdata (); + + int flag = + IDAInit (mem, IDA::resfun, t0, yy, yyp); + if (flag != 0) + { + error ("IDA not initialized"); + } + } + + void + IDA::set_tolerance (ColumnVector& abstol, realtype reltol) + { + N_Vector abs_tol = + ColToNVec (abstol, num); + + int flag = + IDASVtolerances (mem, reltol, abs_tol); + if (flag != 0) + { + error ("IDA: Tolerance not set"); + } + N_VDestroy_Serial (abs_tol); + } + + void + IDA::set_tolerance (realtype abstol, realtype reltol) + { + int flag = + IDASStolerances (mem, reltol, abstol); + if (flag != 0) + { + error ("IDA: Tolerance not set"); + } + } + + octave_value_list + IDA::integrate (const int numt, const ColumnVector& tspan, + const ColumnVector& y, const ColumnVector& yp, + const int refine, bool haverefine, bool haveoutputfcn, + octave_function *output_fcn, bool haveoutputsel, + ColumnVector& outputsel, bool haveeventfunction, + octave_function *event_fcn) + { + // Set up output + ColumnVector tout, yout (num), ypout (num), ysel (outputsel.numel ()); + ColumnVector ie, te, oldval, oldisterminal, olddir; + Matrix output, ye; + int cont = 0, flag = 0, temp = 0; + bool status = 0; + std::string string = ""; + ColumnVector yold = y; + octave_value_list retval; + + realtype tsol = + tspan (0); + realtype tend = + tspan (numt - 1); + + N_Vector yyp = + ColToNVec (yp, num); + + N_Vector yy = + ColToNVec (y, num); + + // Initialize OutputFcn + if (haveoutputfcn) + status = IDA::outputfun (output_fcn, haveoutputsel, y, + tsol, tend, outputsel, "init"); + + // Initialize Events + if (haveeventfunction) + status = IDA::event (event_fcn, te, ye, ie, tsol, y, + "init", yp, oldval, oldisterminal, + olddir, cont, temp, tsol, yold); + + if (numt > 2) + { + // First output value + tout.resize (numt); + tout (0) = tsol; + output.resize (numt, num); + + for (octave_idx_type i = 0; i < num; i++) + output.elem (0, i) = y.elem (i); + + //Main loop + for (octave_idx_type j = 1; j < numt && status == 0; j++) + { + // IDANORMAL already interpolates tspan(j) + flag = IDASolve (mem, tspan (j), &tsol, yy, yyp, IDA_NORMAL); + if (flag != 0) + { + error ("IDASolve failed"); + } + + yout = NVecToCol (yy, num); + ypout = NVecToCol (yyp, num); + tout (j) = tsol; + + for (octave_idx_type i = 0; i < num; i++) + output.elem (j, i) = yout.elem (i); + + if (haveoutputfcn) + status = IDA::outputfun (output_fcn, haveoutputsel, yout, tsol, + tend, outputsel, string); + + if (haveeventfunction) + status = IDA::event (event_fcn, te, ye, ie, tout (j), yout, + string, ypout, oldval, oldisterminal, + olddir, j, temp, tout (j - 1), yold); + + // If integration is stopped, return only the reached steps + if (status == 1) + { + output.resize (j + 1, num); + tout.resize (j + 1); + } + + } + } + else // numel (tspan) == 2 + { + // First output value + tout.resize (1); + tout (0) = tsol; + output.resize (1, num); + + for (octave_idx_type i = 0; i < num; i++) + output.elem (0, i) = y.elem (i); + + bool posdirection = + (tend > tsol); + + //main loop + while (((posdirection == 1 && tsol < tend) + || (posdirection == 0 && tsol > tend)) + && status == 0) + { + flag = IDASolve (mem, tend, &tsol, yy, yyp, IDA_ONE_STEP); + if (flag != 0) + { + error ("IDASolve failed"); + } + + if (haverefine) + status = IDA::interpolate (cont, output, tout, refine, tend, + haveoutputfcn, haveoutputsel, + output_fcn, outputsel, + haveeventfunction, event_fcn, te, + ye, ie, oldval, oldisterminal, + olddir, temp, yold); + + ypout = NVecToCol (yyp, num); + cont += 1; + output.resize (cont + 1, num); // This may be not efficient + tout.resize (cont + 1); + tout (cont) = tsol; + yout = NVecToCol (yy, num); + + for (octave_idx_type i = 0; i < num; i++) + output.elem (cont, i) = yout.elem (i); + + if (haveoutputfcn && ! haverefine && tout (cont) < tend) + status = IDA::outputfun (output_fcn, haveoutputsel, yout, tsol, + tend, outputsel, string); + + if (haveeventfunction && ! haverefine && tout (cont) < tend) + status = IDA::event (event_fcn, te, ye, ie, tout (cont), yout, + string, ypout, oldval, oldisterminal, + olddir, cont, temp, tout (cont - 1), yold); + } + if (status == 0) + { + // Interpolate in tend + N_Vector dky = + N_VNew_Serial (num); + + flag = IDAGetDky (mem, tend, 0, dky); + if (flag != 0) + { + error ("IDA failed to interpolate y"); + } + + tout (cont) = tend; + yout = NVecToCol (dky, num); + + for (octave_idx_type i = 0; i < num; i++) + output.elem (cont, i) = yout.elem (i); + + // Plot final value + if (haveoutputfcn) + { + status = IDA::outputfun (output_fcn, haveoutputsel, yout, + tend, tend, outputsel, string); + + // Events during last step + if (haveeventfunction) + status = IDA::event (event_fcn, te, ye, ie, tend, yout, + string, ypout, oldval, oldisterminal, + olddir, cont, temp, tout (cont - 1), + yold); + } + + N_VDestroy_Serial (dky); + } + // Cleanup plotter + status = IDA::outputfun (output_fcn, haveoutputsel, yout, tend, tend, + outputsel, "done"); + + } + + retval (0) = tout; + retval (1) = output; + retval (2) = te; + retval (3) = ye; + retval (4) = ie; + + return retval; + } + + bool + IDA::event (octave_function *event_fcn, + ColumnVector& te, Matrix& ye, ColumnVector& ie, + realtype tsol, const ColumnVector& y, std::string flag, + const ColumnVector& yp, ColumnVector& oldval, + ColumnVector& oldisterminal, ColumnVector& olddir, int cont, + int& temp, realtype told, ColumnVector& yold) + { + bool status = 0; + octave_value_list args (3); + octave_value_list output (3); + ColumnVector val, isterminal, dir; + args (0) = tsol; + args (1) = y; + args (2) = yp; + + // cont is the number of steps reached by the solver + // temp is the number of events registered + + if (flag == "init") + { + output = feval (event_fcn, args, 3); + oldval = output(0).vector_value (); + oldisterminal = output(1).vector_value (); + olddir = output(2).vector_value (); + } + else if (flag == "") + { + ColumnVector index (0); + output = feval (event_fcn, args, 3); + val = output(0).vector_value (); + isterminal = output(1).vector_value (); + dir = output(2).vector_value (); + + // Get the index of the changed values + for (octave_idx_type i = 0; i < val.numel (); i++) + { + if ((val(i) > 0 && oldval(i) < 0 && dir(i) != -1) // increasing + || (val(i) < 0 && oldval(i) > 0 && dir(i) != 1)) // decreasing + { + index.resize (index.numel () + 1); + index (index.numel () - 1) = i; + } + } + + if (cont == 1 && index.numel () > 0) // Events in first step + { + temp = 1; // register only the first event + te.resize (1); + ye.resize (1, num); + ie.resize (1); + + // Linear interpolation + ie (0) = index (0); + te (0) = tsol - val (index (0)) * (tsol - told) + / (val (index (0)) - oldval (index (0))); + + ColumnVector ytemp = + y - ((tsol - te (0)) * (y - yold ) / (tsol - told)); + + for (octave_idx_type i = 0; i < num; i++) + ye.elem (0, i) = ytemp.elem (i); + + } + else if (index.numel () > 0) + // Not first step: register all events and test if stop integration or not + { + te.resize (temp + index.numel ()); + ye.resize (temp + index.numel (), num); + ie.resize (temp + index.numel ()); + + for (octave_idx_type i = 0; i < index.numel (); i++) + { + + if (isterminal (index (i)) == 1) + status = 1; // Stop integration + + // Linear interpolation + ie (temp + i) = index (i); + te (temp + i) = tsol - + val (index (i)) * (tsol - told) / + (val (index (i)) - oldval (index (i))); + + ColumnVector ytemp = + y - (tsol - te (temp + i)) * (y - yold) / (tsol - told); + + for (octave_idx_type j = 0; j < num; j++) + ye.elem (temp + i, j) = ytemp.elem (j); + + } + + temp += index.numel (); + } + + // Update variables + yold = y; + told = tsol; + olddir = dir; + oldval = val; + oldisterminal = isterminal; + } + + return status; + } + + bool + IDA::interpolate (int& cont, Matrix& output, ColumnVector& tout, + int refine, realtype tend, bool haveoutputfcn, + bool haveoutputsel, octave_function *output_fcn, + ColumnVector& outputsel, bool haveeventfunction, + octave_function * event_fcn, ColumnVector& te, + Matrix& ye, ColumnVector& ie, ColumnVector& oldval, + ColumnVector& oldisterminal, ColumnVector& olddir, + int& temp, ColumnVector& yold) + { + realtype h = 0, tcur = 0; + bool status = 0; + + N_Vector dky = + N_VNew_Serial (num); + + N_Vector dkyp = + N_VNew_Serial (num); + + ColumnVector yout (num); + ColumnVector ypout (num); + std::string string = ""; + + int flag = + IDAGetLastStep (mem, &h); + + if (flag != 0) + { + error ("IDA failed to return last step"); + } + flag = IDAGetCurrentTime (mem, &tcur); + if (flag != 0) + { + error ("IDA failed to return the current time"); + } + + realtype tin = + tcur - h; + + realtype step = + h / refine; + + for (octave_idx_type i = 1; i < refine && tin + step * i < tend + && status == 0; i++) + { + flag = IDAGetDky (mem, tin + step*i, 0, dky); + if (flag != 0) + { + error ("IDA failed to interpolate y"); + } + flag = IDAGetDky (mem, tin + step*i, 1, dkyp); + if (flag != 0) + { + error ("IDA failed to interpolate yp"); + } + cont += 1; + output.resize (cont + 1, num); + tout.resize (cont + 1); + + tout (cont) = tin + step * i; + yout = NVecToCol (dky, num); + ypout = NVecToCol (dkyp, num); + + for (octave_idx_type j = 0; j < num; j++) + output.elem (cont, j) = yout.elem (j); + + if (haveoutputfcn) + status = IDA::outputfun (output_fcn, haveoutputsel, yout, + tout (cont), tend, outputsel, ""); + + if (haveeventfunction) + status = IDA::event (event_fcn, te, ye, ie, tout (cont), + yout, string, ypout, oldval, + oldisterminal, olddir, cont, temp, + tout (cont - 1), yold); + } + N_VDestroy_Serial (dky); + return status; + } + + bool + IDA::outputfun (octave_function *output_fcn, bool haveoutputsel, + const ColumnVector& yout, realtype tsol, + realtype tend, ColumnVector& outputsel, + std::string flag) + { + bool status = 0; + octave_value_list output, val; + ColumnVector ysel (outputsel.numel ()); + + if (haveoutputsel) + { + for (octave_idx_type i = 0; i < outputsel.numel (); i++) + ysel (i) = yout (outputsel (i)); + + output (1) = ysel; + } + else + output (1) = yout; + + output (2) = flag; + + if (flag == "init") + { + ColumnVector toutput (2); + toutput (0) = tsol; + toutput (1) = tend; + output (0) = toutput; + + feval (output_fcn, output, 0); + } + else if (flag == "") + { + output (0) = tsol; + val = feval (output_fcn, output, 1); + status = val(0).bool_value (); + } + else + { // Cleanup plotter + output (0) = tend; + feval (output_fcn, output, 0); + } + + return status; + } + + void + IDA::set_maxstep (realtype maxstep) + { + int flag = + IDASetMaxStep (mem, maxstep); + + if (flag != 0) + { + error ("IDA: Max Step not set"); + } + } + + void + IDA::set_initialstep (realtype initialstep) + { + int flag = + IDASetInitStep (mem, initialstep); + + if (flag != 0) + { + error ("IDA: Initial Step not set"); + } + } + + void + IDA::set_maxorder (int maxorder) + { + int flag = + IDASetMaxOrd (mem, maxorder); + + if (flag != 0) + { + error ("IDA: Max Order not set"); + } + } + + void + IDA::print_stat (void) + { + long int nsteps = 0, netfails = 0, nrevals = 0; + int flag = + IDAGetNumSteps(mem, &nsteps); + + if (flag != 0) + { + error ("IDA failed to return the number of internal steps"); + } + flag = IDAGetNumErrTestFails(mem, &netfails); + if (flag != 0) + { + error ("IDA failed to return the number of internal errors"); + } + flag = IDAGetNumResEvals(mem, &nrevals); + if (flag != 0) + { + error ("IDA failed to return the number of residual evaluations"); + } + + std::cout<<nsteps<<" successful steps\n"; + std::cout<<netfails<<" failed attempts\n"; + std::cout<<nrevals<<" function evaluations\n"; + //std::cout<<<<" partial derivatives\n"; + //std::cout<<<<" LU decompositions\n"; + //std::cout<<<<" solutions of linear systems\n"; + } + + ColumnVector + ida_user_function (const ColumnVector& x, const ColumnVector& xdot, + double t, octave_function *ida_fc) + { + ColumnVector retval; + octave_value_list args; + + args(2) = xdot; + args(1) = x; + args(0) = t; + + octave_value_list tmp; + + try + { + tmp = ida_fc -> do_multi_index_op (1, args); + } + catch (octave::execution_exception& e) + { + err_user_supplied_eval (e, "__ode15__"); + } + + retval = tmp(0).vector_value (); + + return retval; + } + + Matrix + ida_dense_jac (const ColumnVector& x, const ColumnVector& xdot, + double t, double cj, octave_function *ida_jc) + { + Matrix retval; + octave_value_list newargs (3); + + newargs (0) = t; + newargs (1) = x; + newargs (2) = xdot; + + octave_value_list tmp; + + try + { + tmp = ida_jc -> do_multi_index_op (2, newargs); + } + catch (octave::execution_exception& e) + { + err_user_supplied_eval (e, "__ode15__"); + } + + retval = tmp(0).matrix_value () + cj * tmp(1).matrix_value (); + + return retval; + } + + SparseMatrix + ida_sparse_jac (const ColumnVector& x, const ColumnVector& xdot, + double t, double cj, octave_function *ida_jc) + { + SparseMatrix retval; + octave_value_list newargs (3); + + newargs (0) = t; + newargs (1) = x; + newargs (2) = xdot; + + octave_value_list tmp; + + try + { + tmp = ida_jc -> do_multi_index_op (2, newargs); + } + catch (octave::execution_exception& e) + { + err_user_supplied_eval (e, "__ode15__"); + } + + retval = tmp(0).sparse_matrix_value () + + cj * tmp(1).sparse_matrix_value (); + + return retval; + } + + Matrix + ida_dense_cell_jac (Matrix *dfdy, Matrix *dfdyp, double cj) + { + Matrix retval; + retval = (*dfdy) + cj * (*dfdyp); + return retval; + } + + SparseMatrix + ida_sparse_cell_jac (SparseMatrix *spdfdy, SparseMatrix *spdfdyp, + double cj) + { + SparseMatrix retval; + retval = (*spdfdy) + cj * (*spdfdyp); + return retval; + } + + octave_value_list + do_ode15 (octave_function *ida_fcn, + const ColumnVector &tspan, + const int numt, + const realtype t0, + const ColumnVector &y0, + const ColumnVector &yp0, + const octave_scalar_map &options) + { + octave_value_list retval; + + // Create object + IDA dae (t0, y0, yp0, ida_fcn, ida_user_function); + + // Set Jacobian + bool havejac = + options.getfield ("havejac").bool_value (); + + bool havejacsparse = + options.getfield ("havejacsparse").bool_value (); + + bool havejacfun = + options.getfield ("havejacfun").bool_value (); + + Matrix ida_dfdy, ida_dfdyp, *dfdy, *dfdyp; + SparseMatrix ida_spdfdy, ida_spdfdyp, *spdfdy, *spdfdyp; + octave_function *ida_jac; + Cell jaccell; + + if (havejac) + { + if (havejacfun) + { + ida_jac = options.getfield ("Jacobian").function_value (); + if (havejacsparse) + dae.set_jacobian (ida_jac, ida_sparse_jac); + else + dae.set_jacobian (ida_jac, ida_dense_jac); + } + else + { + jaccell = options.getfield ("Jacobian").cell_value (); + + if (havejacsparse) + { + ida_spdfdy = jaccell(0).sparse_matrix_value (); + ida_spdfdyp = jaccell(1).sparse_matrix_value (); + spdfdy = &ida_spdfdy; + spdfdyp = &ida_spdfdyp; + dae.set_jacobian (spdfdy, spdfdyp, ida_sparse_cell_jac); + } + else + { + ida_dfdy = jaccell(0).matrix_value (); + ida_dfdyp = jaccell(1).matrix_value (); + dfdy = &ida_dfdy; + dfdyp = &ida_dfdyp; + dae.set_jacobian (dfdy, dfdyp, ida_dense_cell_jac); + } + } + } + + // Initialize IDA + dae.initialize (); + + // Set tolerances + realtype rel_tol = + options.getfield("RelTol").double_value (); + + bool haveabstolvec = + options.getfield ("haveabstolvec").bool_value (); + + if (haveabstolvec) + { + ColumnVector abs_tol = + options.getfield("AbsTol").vector_value (); + + dae.set_tolerance (abs_tol, rel_tol); + } + else + { + realtype abs_tol = + options.getfield("AbsTol").double_value (); + + dae.set_tolerance (abs_tol, rel_tol); + } + + //Set max step + realtype maxstep = + options.getfield("MaxStep").double_value (); + + dae.set_maxstep (maxstep); + + //Set initial step + if (!(options.getfield("InitialStep").is_empty ())) + { + realtype initialstep = + options.getfield("InitialStep").double_value (); + + dae.set_initialstep (initialstep); + } + + //Set max order FIXME: it doesn't work + int maxorder = + options.getfield("MaxOrder").int_value (); + + dae.set_maxorder (maxorder); + + //Set Refine + const int refine = + options.getfield("Refine").int_value (); + + bool haverefine = + (refine > 1); + + octave_function *output_fcn = NULL; + ColumnVector outputsel; + + // OutputFcn + bool haveoutputfunction = + options.getfield("haveoutputfunction").bool_value (); + + if (haveoutputfunction) + output_fcn = options.getfield("OutputFcn").function_value (); + + // OutputSel + bool haveoutputsel = + options.getfield("haveoutputselection").bool_value (); + + if (haveoutputsel) + outputsel = options.getfield("OutputSel").vector_value (); + + octave_function *event_fcn = NULL; + + // Events + bool haveeventfunction = + options.getfield("haveeventfunction").bool_value (); + + if (haveeventfunction) + event_fcn = options.getfield("Events").function_value (); + + // Set up linear solver + dae.set_up (); + + // Integrate + retval = dae.integrate (numt, tspan, y0, yp0, refine, + haverefine, haveoutputfunction, + output_fcn, haveoutputsel, outputsel, + haveeventfunction, event_fcn); + + // Statistics + bool havestats = + options.getfield("havestats").bool_value (); + + if (havestats) + dae.print_stat (); + + return retval; + } +} +#endif + + +DEFUN_DLD (__ode15__, args, nargout, doc: /* -*- texinfo -*- +@deftypefn {} {@var{t}, @var{y} =} __ode15__ (@var{fun}, @ +@var{tspan}, @var{y0}, @var{yp0}, @var{options}) +Undocumented internal function. +@end deftypefn */) +{ + +#if defined (HAVE_SUNDIALS) + + // Check number of parameters + int nargin = args.length (); + + if (nargin != 5 || nargout != 5) + print_usage (); + + // Check odefun + octave_function *ida_fcn = NULL; + + octave_value f_arg = args(0); + + if (f_arg.is_function_handle ()) + ida_fcn = f_arg.function_value (); + else + error ("__ode15__: odefun must be a function handle"); + + // Check input tspan + ColumnVector tspan = + args(1).xvector_value ("__ode15__: TRANGE must be a vector of numbers"); + + int numt = + tspan.numel (); + + realtype t0 = + tspan (0); + + if (numt < 2) + error ("__ode15__: TRANGE must contain at least 2 elements"); + else if (!(tspan.is_sorted ()) || (tspan(0) == tspan(numt - 1))) + error ("__ode15__: TRANGE must be strictly monotonic"); + + // input y0 and yp0 + ColumnVector y0 = + args(2).xvector_value ("__ode15__: initial state y0 must be a vector"); + + ColumnVector yp0 = + args(3).xvector_value ("__ode15__: initial state yp0 must be a vector"); + + + if (y0.numel () != yp0.numel ()) + error ("__ode15__: initial state y0 and yp0 must have the same length"); + else if (y0.numel () < 1) + error ("__ode15__: initial state yp0 must be a vector or a scalar"); + + + if (! args(4).is_map ()) + error ("__ode15__: OPTS argument must be a structure"); + + octave_scalar_map options = + args(4).xscalar_map_value ("__ode15__:", + "OPTS argument must be a scalar structure"); + + + return octave::do_ode15 (ida_fcn, tspan, numt, t0, + y0, yp0, options); + + +#else + + octave_unused_parameter (args); + err_disabled_feature ("__ode15__", "sundials_ida, sundials_nvecserial"); + +#endif +} + + +