Mercurial > octave-nkf
diff liboctave/DASPK.cc @ 4049:a35a3c5d4740
[project @ 2002-08-16 08:54:31 by jwe]
author | jwe |
---|---|
date | Fri, 16 Aug 2002 08:54:31 +0000 |
parents | 7b0c139ac8af |
children | b79da8779a0e |
line wrap: on
line diff
--- a/liboctave/DASPK.cc Fri Aug 16 02:43:14 2002 +0000 +++ b/liboctave/DASPK.cc Fri Aug 16 08:54:31 2002 +0000 @@ -64,47 +64,7 @@ static DAEFunc::DAEJacFunc user_jac; static int nn; -DASPK::DASPK (void) : DAE () -{ - sanity_checked = 0; - - info.resize (20); - - for (int i = 0; i < 20; i++) - info.elem (i) = 0; -} - -DASPK::DASPK (const ColumnVector& state, double time, DAEFunc& f) - : DAE (state, time, f) -{ - n = size (); - - sanity_checked = 0; - - info.resize (20); - - for (int i = 0; i < 20; i++) - info.elem (i) = 0; -} - -DASPK::DASPK (const ColumnVector& state, const ColumnVector& deriv, - double time, DAEFunc& f) - : DAE (state, deriv, time, f) -{ - n = size (); - - DAEFunc::set_function (f.function ()); - DAEFunc::set_jacobian_function (f.jacobian_function ()); - - sanity_checked = 0; - - info.resize (20); - - for (int i = 0; i < 20; i++) - info.elem (i) = 0; -} - -int +static int ddaspk_f (const double& time, const double *state, const double *deriv, const double&, double *delta, int& ires, double *, int *) { @@ -137,7 +97,7 @@ //NEQ, T, Y, YPRIME, SAVR, WK, CJ, WGHT, //C WP, IWP, B, EPLIN, IER, RPAR, IPAR) -int +static int ddaspk_psol (const int& neq, const double& time, const double *state, const double *deriv, const double *savr, const double& cj, const double *wght, double *wp, @@ -149,7 +109,7 @@ } -int +static int ddaspk_j (const double& time, const double *state, const double *deriv, double *pd, const double& cj, double *, int *) { @@ -181,178 +141,220 @@ ColumnVector retval; - if (restart) + if (! initialized || restart || DAEFunc::reset|| DASPK_options::reset) { - restart = false; - info.elem (0) = 0; - } + integration_error = false; + + initialized = true; + + info.resize (20); - liw = 40 + n; - if (info(9) == 1 || info(9) == 3) - liw += n; - if (info (10) == 1 || info(15) == 1) - liw += n; + for (int i = 0; i < 20; i++) + info(i) = 0; + + pinfo = info.fortran_vec (); - lrw = 50 + 9*n; - if (info(5) == 0) - lrw += n*n; - if (info(15) == 1) - lrw += n; + int n = size (); - if (iwork.length () != liw) - iwork.resize (liw); + nn = n; + + info(0) = 0; - if (rwork.length () != lrw) - rwork.resize (lrw); - - integration_error = false; + if (stop_time_set) + { + rwork(0) = stop_time; + info(3) = 1; + } + else + info(3) = 0; - if (DAEFunc::jacobian_function ()) - info.elem (4) = 1; - else - info.elem (4) = 0; + px = x.fortran_vec (); + pxdot = xdot.fortran_vec (); + + // DAEFunc + + user_fun = DAEFunc::function (); + user_jac = DAEFunc::jacobian_function (); - double *px = x.fortran_vec (); - double *pxdot = xdot.fortran_vec (); + if (user_fun) + { + int ires = 0; - nn = n; - user_fun = DAEFunc::fun; - user_jac = DAEFunc::jac; + ColumnVector res = (*user_fun) (x, xdot, t, ires); - if (! sanity_checked) - { - int ires = 0; + if (res.length () != x.length ()) + { + (*current_liboctave_error_handler) + ("daspk: inconsistent sizes for state and residual vectors"); - ColumnVector res = (*user_fun) (x, xdot, t, ires); - - if (res.length () != x.length ()) + integration_error = true; + return retval; + } + } + else { (*current_liboctave_error_handler) - ("daspk: inconsistent sizes for state and residual vectors"); + ("daspk: no user supplied RHS subroutine!"); + + integration_error = true; + return retval; + } + + info(4) = user_jac ? 1 : 0; + + DAEFunc::reset = false; + + // DASPK_options + + Array<double> abs_tol = absolute_tolerance (); + Array<double> rel_tol = relative_tolerance (); + + int abs_tol_len = abs_tol.length (); + int rel_tol_len = rel_tol.length (); + + if (abs_tol_len == 1 && rel_tol_len == 1) + { + info(1) = 0; + } + else if (abs_tol_len == n && rel_tol_len == n) + { + info(1) = 1; + } + else + { + (*current_liboctave_error_handler) + ("daspk: inconsistent sizes for tolerance arrays"); integration_error = true; return retval; } - sanity_checked = 1; - } - - if (stop_time_set) - { - rwork.elem (0) = stop_time; - info.elem (3) = 1; - } - else - info.elem (3) = 0; - - Array<double> abs_tol = absolute_tolerance (); - Array<double> rel_tol = relative_tolerance (); - - int abs_tol_len = abs_tol.length (); - int rel_tol_len = rel_tol.length (); - - if (abs_tol_len == 1 && rel_tol_len == 1) - { - info.elem (1) = 0; - } - else if (abs_tol_len == n && rel_tol_len == n) - { - info.elem (1) = 1; - } - else - { - (*current_liboctave_error_handler) - ("daspk: inconsistent sizes for tolerance arrays"); + double hmax = maximum_step_size (); + if (hmax >= 0.0) + { + rwork(1) = hmax; + info(6) = 1; + } + else + info(6) = 0; - integration_error = true; - return retval; - } - - double hmax = maximum_step_size (); - if (hmax >= 0.0) - { - rwork.elem (1) = hmax; - info.elem (6) = 1; - } - else - info.elem (6) = 0; - - double h0 = initial_step_size (); - if (h0 >= 0.0) - { - rwork.elem (2) = h0; - info.elem (7) = 1; - } - else - info.elem (7) = 0; - - int maxord = maximum_order (); - if (maxord >= 0) - { - if (maxord > 0 && maxord < 6) + double h0 = initial_step_size (); + if (h0 >= 0.0) { - info(8) = 1; - iwork(2) = maxord; + rwork(2) = h0; + info(7) = 1; } else + info(7) = 0; + + int maxord = maximum_order (); + if (maxord >= 0) { + if (maxord > 0 && maxord < 6) + { + info(8) = 1; + iwork(2) = maxord; + } + else + { + (*current_liboctave_error_handler) + ("daspk: invalid value for maximum order"); + integration_error = true; + return retval; + } + } + + int eiq = enforce_inequality_constraints (); + switch (eiq) + { + case 1: + case 3: + { + Array<int> ict = inequality_constraint_types (); + + if (ict.length () == n) + { + for (int i = 0; i < n; i++) + { + int val = ict(i); + if (val < -2 || val > 2) + { + (*current_liboctave_error_handler) + ("daspk: invalid value for inequality constraint type"); + integration_error = true; + return retval; + } + iwork(40+i) = val; + } + } + else + { + (*current_liboctave_error_handler) + ("daspk: inequality constraint types size mismatch"); + integration_error = true; + return retval; + } + } + // Fall through... + + case 2: + info(9) = eiq; + break; + + default: (*current_liboctave_error_handler) - ("daspk: invalid value for maximum order"); + ("daspk: invalid value for enforce inequality constraints option"); integration_error = true; return retval; } - } + + int ccic = compute_consistent_initial_condition (); + if (ccic) + { + if (ccic == 1) + { + // XXX FIXME XXX -- this code is duplicated below. + + Array<int> av = algebraic_variables (); - int eiq = enforce_inequality_constraints (); - switch (eiq) - { - case 1: - case 3: - { - Array<int> ict = inequality_constraint_types (); + if (av.length () == n) + { + int lid; + if (eiq == 0 || eiq == 2) + lid = 40; + else if (eiq == 1 || eiq == 3) + lid = 40 + n; + else + abort (); - if (ict.length () == n) - { - for (int i = 0; i < n; i++) - { - int val = ict(i); - if (val < -2 || val > 2) - { - (*current_liboctave_error_handler) - ("daspk: invalid value for inequality constraint type"); - integration_error = true; - return retval; - } - iwork(40+i) = val; - } - } - else - { - (*current_liboctave_error_handler) - ("daspk: inequality constraint types size mismatch"); - integration_error = true; - return retval; - } - } - // Fall through... + for (int i = 0; i < n; i++) + iwork(lid+i) = av(i) ? -1 : 1; + } + else + { + (*current_liboctave_error_handler) + ("daspk: algebraic variables size mismatch"); + integration_error = true; + return retval; + } + } + else if (ccic != 2) + { + (*current_liboctave_error_handler) + ("daspk: invalid value for compute consistent initial condition option"); + integration_error = true; + return retval; + } - case 2: - info(9) = eiq; - break; + info(10) = ccic; + } - default: - (*current_liboctave_error_handler) - ("daspk: invalid value for enforce inequality constraints option"); - integration_error = true; - return retval; - } + int eavfet = exclude_algebraic_variables_from_error_test (); + if (eavfet) + { + info(15) = 1; - int ccic = compute_consistent_initial_condition (); - if (ccic) - { - if (ccic == 1) - { - // XXX FIXME XXX -- this code is duplicated below. + // XXX FIXME XXX -- this code is duplicated above. Array<int> av = algebraic_variables (); @@ -369,102 +371,77 @@ for (int i = 0; i < n; i++) iwork(lid+i) = av(i) ? -1 : 1; } + } + + if (use_initial_condition_heuristics ()) + { + Array<double> ich = initial_condition_heuristics (); + + if (ich.length () == 6) + { + iwork(31) = NINT (ich(0)); + iwork(32) = NINT (ich(1)); + iwork(33) = NINT (ich(2)); + iwork(34) = NINT (ich(3)); + + rwork(13) = ich(4); + rwork(14) = ich(5); + } else { (*current_liboctave_error_handler) - ("daspk: algebraic variables size mismatch"); + ("daspk: invalid initial condition heuristics option"); integration_error = true; return retval; } + + info(16) = 1; } - else if (ccic != 2) + + int pici = print_initial_condition_info (); + switch (pici) { + case 0: + case 1: + case 2: + info(17) = pici; + break; + + default: (*current_liboctave_error_handler) - ("daspk: invalid value for compute consistent initial condition option"); + ("daspk: invalid value for print initial condition info option"); integration_error = true; return retval; + break; } - info(10) = ccic; - } + DASPK_options::reset = false; - if (exclude_algebraic_variables_from_error_test ()) - { - info(15) = 1; - - // XXX FIXME XXX -- this code is duplicated above. - - Array<int> av = algebraic_variables (); + liw = 40 + n; + if (eiq == 1 || eiq == 3) + liw += n; + if (ccic == 1 || eavfet == 1) + liw += n; - if (av.length () == n) - { - int lid; - if (eiq == 0 || eiq == 2) - lid = 40; - else if (eiq == 1 || eiq == 3) - lid = 40 + n; - else - abort (); + lrw = 50 + 9*n; + if (! user_jac) + lrw += n*n; + if (eavfet == 1) + lrw += n; - for (int i = 0; i < n; i++) - iwork(lid+i) = av(i) ? -1 : 1; - } + iwork.resize (liw); + rwork.resize (lrw); + + piwork = iwork.fortran_vec (); + prwork = rwork.fortran_vec (); + + restart = false; } - if (use_initial_condition_heuristics ()) - { - Array<double> ich = initial_condition_heuristics (); - - if (ich.length () == 6) - { - iwork(31) = NINT (ich(0)); - iwork(32) = NINT (ich(1)); - iwork(33) = NINT (ich(2)); - iwork(34) = NINT (ich(3)); - - rwork(13) = ich(4); - rwork(14) = ich(5); - } - else - { - (*current_liboctave_error_handler) - ("daspk: invalid initial condition heuristics option"); - integration_error = true; - return retval; - } - - info(16) = 1; - } + static double *dummy = 0; + static int *idummy = 0; - int pici = print_initial_condition_info (); - switch (pici) - { - case 0: - case 1: - case 2: - info(17) = pici; - break; - - default: - (*current_liboctave_error_handler) - ("daspk: invalid value for print initial condition info option"); - integration_error = true; - return retval; - break; - } - - double *dummy = 0; - int *idummy = 0; - - int *pinfo = info.fortran_vec (); - int *piwork = iwork.fortran_vec (); - double *prwork = rwork.fortran_vec (); - double *pabs_tol = abs_tol.fortran_vec (); - double *prel_tol = rel_tol.fortran_vec (); - -// again: - - F77_XFCN (ddaspk, DDASPK, (ddaspk_f, n, t, px, pxdot, tout, pinfo, + F77_XFCN (ddaspk, DDASPK, (ddaspk_f, nn, t, px, pxdot, tout, pinfo, prel_tol, pabs_tol, istate, prwork, lrw, piwork, liw, dummy, idummy, ddaspk_j, ddaspk_psol)); @@ -546,7 +523,9 @@ DASPK::integrate (const ColumnVector& tout, Matrix& xdot_out) { Matrix retval; + int n_out = tout.capacity (); + int n = size (); if (n_out > 0 && n > 0) { @@ -589,7 +568,9 @@ const ColumnVector& tcrit) { Matrix retval; + int n_out = tout.capacity (); + int n = size (); if (n_out > 0 && n > 0) {