diff --git a/CHANGELOG b/CHANGELOG index 34c00e23..3b02302f 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -2,6 +2,8 @@ --- Assimulo-3.2.8 --- * Sundials 5.x port + * Improved asserts in tests + * Added C version of the Radau5 solver --- Assimulo-3.2.7 --- * Resolved deprecation warnings visible when using numpy 1.20. diff --git a/doc/sphinx/source/changelog.rst b/doc/sphinx/source/changelog.rst index 12d1d0f6..fa7927e3 100644 --- a/doc/sphinx/source/changelog.rst +++ b/doc/sphinx/source/changelog.rst @@ -3,6 +3,11 @@ Changelog ========== +--- Assimulo-3.2.8 --- + * Sundials 5.x port + * Improved asserts in tests + * Added C version of the Radau5 solver + --- Assimulo-3.2.7 --- * Resolved deprecation warnings visible when using numpy 1.20, related to deprecation of the alias numpy.float. * Resolved deprecation warnings visible when creating an ndarray from ragged nested sequences. diff --git a/doc/sphinx/source/conf.py b/doc/sphinx/source/conf.py index 91787881..3d25dce6 100644 --- a/doc/sphinx/source/conf.py +++ b/doc/sphinx/source/conf.py @@ -50,9 +50,9 @@ # built documents. # # The short X.Y version. -version = '3.2.7' +version = '3.2.8' # The full version, including alpha/beta/rc tags. -release = '3.2.7' +release = '3.2.8' # The language for content autogenerated by Sphinx. Refer to documentation # for a list of supported languages. @@ -109,7 +109,7 @@ # The name for this set of Sphinx documents. If None, it defaults to # " v documentation". -html_title = 'Assimulo 3.2.7 documentation' +html_title = 'Assimulo 3.2.8 documentation' # A shorter title for the navigation bar. Default is the same as html_title. #html_short_title = None diff --git a/examples/cvode_stability.py b/examples/cvode_stability.py index 314867ba..1386c275 100644 --- a/examples/cvode_stability.py +++ b/examples/cvode_stability.py @@ -89,7 +89,7 @@ def f(t,y): #Basic test x1 = y[:,0] - assert N.abs(x1[-1]-1.8601438) < 1e-1 #For test purpose + nose.tools.assert_less(N.abs(float(x1[-1]) - 1.8601438), 1e-1) return exp_mod, exp_sim diff --git a/examples/euler_vanderpol.py b/examples/euler_vanderpol.py index 12e75ba8..e5af0d89 100644 --- a/examples/euler_vanderpol.py +++ b/examples/euler_vanderpol.py @@ -86,7 +86,7 @@ def jac(t,y): #Basic test x1 = y[:,0] - assert N.abs(x1[-1]-1.8601438) < 1e-1 #For test purpose + nose.tools.assert_less(N.abs(float(x1[-1]) - 1.8601438), 1e-1) return exp_mod, exp_sim diff --git a/examples/glimda_vanderpol.py b/examples/glimda_vanderpol.py index 8fd819c9..a7a1a531 100644 --- a/examples/glimda_vanderpol.py +++ b/examples/glimda_vanderpol.py @@ -86,7 +86,7 @@ def f(t,y,yd): #Basic test x1 = y[:,0] - assert N.abs(x1[-1]-1.706168035) < 1e-3 #For test purpose + nose.tools.assert_almost_equal(float(x1[-1]), 1.706168035, 3) return imp_mod, imp_sim diff --git a/examples/lsodar_vanderpol.py b/examples/lsodar_vanderpol.py index 22728927..10b8e2ce 100644 --- a/examples/lsodar_vanderpol.py +++ b/examples/lsodar_vanderpol.py @@ -75,7 +75,7 @@ def f(t,y): #Basic test x1 = y[:,0] - assert N.abs(x1[-1]-1.706168035) < 1e-3 #For test purpose + nose.tools.assert_less(N.abs(x1[-1] - 1.706168035), 1e-3) return exp_mod, exp_sim diff --git a/examples/lsodar_with_disc.py b/examples/lsodar_with_disc.py index 5f87a279..0ce1b1b1 100644 --- a/examples/lsodar_with_disc.py +++ b/examples/lsodar_with_disc.py @@ -67,7 +67,6 @@ def state_events(self,t,y,sw): return N.array([event_0,event_1,event_2]) - #Responsible for handling the events. def handle_event(self, solver, event_info): """ @@ -121,8 +120,6 @@ def init_mode(self, solver): solver.y[1] = (-1.0 if solver.sw[1] else 3.0) solver.y[2] = (0.0 if solver.sw[2] else 2.0) - - def run_example(with_plots=True): r""" Example of the use of Euler's method for a differential equation @@ -154,15 +151,12 @@ def run_example(with_plots=True): P.xlabel('Time') P.show() - return exp_mod, exp_sim - #Basic test nose.tools.assert_almost_equal(y[-1][0],8.0) nose.tools.assert_almost_equal(y[-1][1],3.0) nose.tools.assert_almost_equal(y[-1][2],2.0) + + return exp_mod, exp_sim if __name__=="__main__": mod,sim = run_example() - - - diff --git a/examples/mech_system_pendulum.py b/examples/mech_system_pendulum.py index fc646c61..ff994078 100644 --- a/examples/mech_system_pendulum.py +++ b/examples/mech_system_pendulum.py @@ -19,6 +19,7 @@ import assimulo.problem as ap import assimulo.special_systems as ass import numpy as N +import nose import scipy.linalg as sl from assimulo.solvers import IDA, ODASSL @@ -63,7 +64,7 @@ def run_example(index="ind1", with_plots=True, with_test=False): print(final_residual, 'Norm: ', sl.norm(final_residual)) if with_test: - assert(sl.norm(final_residual) < 1.5e-1) + nose.tools.assert_less(sl.norm(final_residual), 1.5e-1) if with_plots: dae_pend.plot(mask=[1,1]+(len(my_pend.y0)-2)*[0]) return my_pend, dae_pend @@ -75,9 +76,3 @@ def run_example(index="ind1", with_plots=True, with_test=False): mod={} for ind in index_values: mod[ind], sim[ind]=run_example(index=ind) - - - - - - diff --git a/examples/radau5dae_time_events.py b/examples/radau5dae_time_events.py index 13e4a5e9..1eb5afea 100644 --- a/examples/radau5dae_time_events.py +++ b/examples/radau5dae_time_events.py @@ -49,7 +49,7 @@ def time_events(self, t,y,yd,sw): def handle_event(self, solver, event_info): self.my *= 1e-1 -def run_example(with_plots=True): +def run_example(with_plots=True, solver='c'): y0 = [2.0,-0.6] #Initial conditions yd0 = [-.6,-200000.] @@ -59,6 +59,7 @@ def run_example(with_plots=True): #Define an explicit solver imp_sim = Radau5DAE(imp_mod) #Create a Radau5 solver + imp_sim.solver = solver #Simulate t, y, yd = imp_sim.simulate(8.) #Simulate 8 seconds @@ -74,8 +75,8 @@ def run_example(with_plots=True): #Basic test x1 = y[:,0] - assert N.abs(x1[-1]-1.14330840983) < 1e-3 #For test purpose + nose.tools.assert_less(N.abs(float(x1[-1]) - 1.14330840983), 1e-3) + return imp_mod, imp_sim if __name__=='__main__': mod,sim = run_example() - diff --git a/examples/radau5dae_vanderpol.py b/examples/radau5dae_vanderpol.py index 39e14163..05217b20 100644 --- a/examples/radau5dae_vanderpol.py +++ b/examples/radau5dae_vanderpol.py @@ -20,7 +20,7 @@ from assimulo.solvers import Radau5DAE from assimulo.problem import Implicit_Problem -def run_example(with_plots=True): +def run_example(with_plots=True,solver='c'): r""" Example for the use of Radau5DAE to solve Van der Pol's equation @@ -61,6 +61,7 @@ def f(t,y,yd): #Define an explicit solver imp_sim = Radau5DAE(imp_mod) #Create a Radau5 solver + imp_sim.solver = solver #Sets the parameters imp_sim.atol = 1e-4 #Default 1e-6 @@ -86,9 +87,9 @@ def f(t,y,yd): #Basic test x1 = y[:,0] - assert N.abs(x1[-1]-1.706168035) < 1e-3 #For test purpose + nose.tools.assert_less(N.abs(float(x1[-1]) - 1.706168035), 1e-3) + return imp_mod, imp_sim if __name__=='__main__': mod,sim = run_example() - diff --git a/examples/radau5ode_vanderpol.py b/examples/radau5ode_vanderpol.py index 26bc87a2..484de363 100644 --- a/examples/radau5ode_vanderpol.py +++ b/examples/radau5ode_vanderpol.py @@ -20,7 +20,7 @@ from assimulo.solvers import Radau5ODE from assimulo.problem import Explicit_Problem -def run_example(with_plots=True): +def run_example(with_plots=True,solver='c'): r""" Example for the use of the implicit Euler method to solve Van der Pol's equation @@ -56,6 +56,7 @@ def f(t,y): #Define an explicit solver exp_sim = Radau5ODE(exp_mod) #Create a Radau5 solver + exp_sim.solver = solver #Sets the parameters exp_sim.atol = 1e-4 #Default 1e-6 @@ -76,10 +77,9 @@ def f(t,y): #Basic test x1 = y[:,0] - assert N.abs(x1[-1]-1.706168035) < 1e-3 #For test purpose + nose.tools.assert_less(N.abs(float(x1[-1]) - 1.706168035), 1e-3) return exp_mod, exp_sim if __name__=='__main__': mod,sim = run_example() - diff --git a/examples/radau5ode_with_disc.py b/examples/radau5ode_with_disc.py index 0e4da63a..e9eb1bd1 100644 --- a/examples/radau5ode_with_disc.py +++ b/examples/radau5ode_with_disc.py @@ -123,11 +123,12 @@ def init_mode(self, solver): -def run_example(with_plots=True): +def run_example(with_plots=True,solver='c'): #Create an instance of the problem exp_mod = Extended_Problem() #Create the problem exp_sim = Radau5ODE(exp_mod) #Create the solver + exp_sim.solver = solver exp_sim.verbosity = 0 exp_sim.report_continuously = True @@ -153,6 +154,4 @@ def run_example(with_plots=True): if __name__=="__main__": mod,sim = run_example() - - diff --git a/examples/rodasode_vanderpol.py b/examples/rodasode_vanderpol.py index 3d86a7c6..0ce7330b 100644 --- a/examples/rodasode_vanderpol.py +++ b/examples/rodasode_vanderpol.py @@ -86,7 +86,8 @@ def jac(t,y): #Basic test x1 = y[:,0] - assert N.abs(x1[-1]-1.706168035) < 1e-3 #For test purpose + nose.tools.assert_less(N.abs(float(x1[-1]) - 1.706168035), 1e-3) + return exp_mod, exp_sim diff --git a/examples/rungekutta34_with_disc.py b/examples/rungekutta34_with_disc.py index 84753e77..5e9e7ee3 100644 --- a/examples/rungekutta34_with_disc.py +++ b/examples/rungekutta34_with_disc.py @@ -153,6 +153,3 @@ def run_example(with_plots=True): if __name__=="__main__": mod,sim = run_example() - - - diff --git a/setup.py b/setup.py index d1289482..2e45d832 100644 --- a/setup.py +++ b/setup.py @@ -209,7 +209,6 @@ def _set_directories(self): self.desThirdParty=dict([(thp,os.path.join(self.curdir,self.build_assimulo_thirdparty,thp)) for thp in self.thirdparty_methods]) # filelists - self.fileSrc = os.listdir("src") self.fileLib = os.listdir(os.path.join("src","lib")) self.fileSolvers = os.listdir(os.path.join("src","solvers")) @@ -459,12 +458,13 @@ def check_LAPACK(self): def cython_extensionlists(self): extra_link_flags = self.static_link_gcc + self.flag_32bit - + #Cythonize main modules ext_list = cythonize(["assimulo"+os.path.sep+"*.pyx"], include_path=[".","assimulo"]) - #Cythonize Solvers - # Euler + + #Cythonize Solvers + # Euler ext_list += cythonize(["assimulo"+os.path.sep+"solvers"+os.path.sep+"euler.pyx"], include_path=[".","assimulo"]) for el in ext_list: @@ -493,7 +493,6 @@ def cython_extensionlists(self): ext_list[-1].include_dirs.append(self.SLUincdir) ext_list[-1].library_dirs.append(self.SLUlibdir) ext_list[-1].libraries.extend(self.superLUFiles) - #Kinsol ext_list += cythonize(["assimulo"+os.path.sep+"solvers"+os.path.sep+"kinsol.pyx"], @@ -507,6 +506,16 @@ def cython_extensionlists(self): ext_list[-1].include_dirs.append(self.SLUincdir) ext_list[-1].library_dirs.append(self.SLUlibdir) ext_list[-1].libraries.extend(self.superLUFiles) + + ## Radau + ext_list += cythonize([os.path.join("assimulo","thirdparty","hairer","radau5_c_py.pyx")], + include_path=[".", "assimulo", os.path.join("assimulo", "lib")], + force = True) + ext_list[-1].include_dirs = [np.get_include(), "assimulo", os.path.join("assimulo", "lib"), + os.path.join("assimulo","thirdparty","hairer"), + self.incdirs] + ext_list[-1].sources = ext_list[-1].sources + [os.path.join("assimulo","thirdparty","hairer","radau_decsol_c.c")] + ext_list[-1].name = "assimulo.lib.radau5_c_py" for el in ext_list: #Debug @@ -597,10 +606,8 @@ def fortran_extensionlists(self): else: L.warning("Could not find Blas or Lapack, disabling support for the solver GLIMDA.") - return config.todict()["ext_modules"] - - + prepare=Assimulo_prepare(args, thirdparty_methods) curr_dir=os.getcwd() if not os.path.isdir("assimulo"): diff --git a/src/lib/radau_core.py b/src/lib/radau_core.py index a5857e4a..0b9e4b40 100644 --- a/src/lib/radau_core.py +++ b/src/lib/radau_core.py @@ -434,3 +434,41 @@ def _set_maxsteps(self, max_steps): self.options["maxsteps"] = max_steps maxsteps = property(_get_maxsteps, _set_maxsteps) + + def _get_solver(self): + """ + Solver implementation used, "f" for Fortran, "c" for C + + Parameters:: + + solver + - Default "f" + + - needs to be either "f" (Fotran) or "c" (C) + """ + return self.options["solver"] + + def _set_solver(self, solver): + try: + solver.lower() + except: + raise Radau_Exception("'solver' parameters needs to be the STRING 'c' or 'f'. Set value: {}, type: {}".format(solver, type(solver))) + if solver.lower() == "f": ## Fortran + try: + from assimulo.lib import radau5 as radau5_f + self.radau5 = radau5_f + self.solver_module_imported = True + except: + raise Radau_Exception("Failed to import the Fotran based Radau5 solver. Try using solver = 'c' for the C based solver instead.") + elif solver.lower() == "c": + try: + from assimulo.lib import radau5_c_py as radau5_c + self.radau5 = radau5_c + self.solver_module_imported = True + except: + raise Radau_Exception("Failed to import the C based Radau5 solver. Try using solver = 'f' for the Fortran based solver instead.") + else: + raise Radau_Exception("Solver parameters needs to be either 'f' or 'c'. Set value: {}".format(solver)) + self.options["solver"] = solver.lower() + + solver = property(_get_solver, _set_solver) diff --git a/src/solvers/radau5.py b/src/solvers/radau5.py index 2b2d1209..eaac94ea 100644 --- a/src/solvers/radau5.py +++ b/src/solvers/radau5.py @@ -27,8 +27,6 @@ from assimulo.implicit_ode import Implicit_ODE from assimulo.lib.radau_core import Radau_Common -from assimulo.lib import radau5 - class Radau5Error(AssimuloException): """ Defines the Radau5Error and provides the textual error message. @@ -94,6 +92,8 @@ def __init__(self, problem): self.options["rtol"] = 1.0e-6 #Relative tolerance self.options["usejac"] = True if self.problem_info["jac_fcn"] else False self.options["maxsteps"] = 100000 + self.options["solver"] = "c" #internal solver; "f" for fortran, "c" for c based code + self.solver_module_imported = False # flag if the internal solver module has been imported or not #Solver support self.supports["report_continuously"] = True @@ -110,6 +110,8 @@ def initialize(self): self.statistics.reset() #for k in self.statistics.keys(): # self.statistics[k] = 0 + if not self.solver_module_imported: + self.solver = self.options["solver"] def set_problem_data(self): if self.problem_info["state_events"]: @@ -141,7 +143,8 @@ def f(t, y): def interpolate(self, time): y = N.empty(self._leny) for i in range(self._leny): - y[i] = radau5.contr5(i+1, time, self.cont) + # Note: index shift to Fortan based indices + y[i] = self.radau5.contr5(i+1, time, self.cont) return y @@ -211,7 +214,7 @@ def integrate(self, t, y, tf, opts): MUMAS = self.problem_info["dim"] #See MLMAS IOUT = 1 #solout is called after every step WORK = N.array([0.0]*(4*self.problem_info["dim"]**2+12*self.problem_info["dim"]+20)) #Work (double) vector - IWORK = N.array([0]*(3*self.problem_info["dim"]+20)) #Work (integer) vector + IWORK = N.array([0]*(3*self.problem_info["dim"]+20),dtype=N.intc) #Work (integer) vector #Setting work options WORK[1] = self.safe @@ -241,9 +244,9 @@ def integrate(self, t, y, tf, opts): #Store the opts self._opts = opts - t, y, h, iwork, flag = radau5.radau5(self.f, t, y.copy(), tf, self.inith, self.rtol*N.ones(self.problem_info["dim"]), self.atol, + t, y, h, iwork, flag = self.radau5.radau5(self.f, t, y.copy(), tf, self.inith, self.rtol*N.ones(self.problem_info["dim"]), self.atol, ITOL, jac_dummy, IJAC, MLJAC, MUJAC, mas_dummy, IMAS, MLMAS, MUMAS, self._solout, IOUT, WORK, IWORK) - + #Checking return if flag == 1: flag = ID_PY_COMPLETE @@ -844,6 +847,8 @@ def __init__(self, problem): self.options["rtol"] = 1.0e-6 #Relative tolerance self.options["usejac"] = True if self.problem_info["jac_fcn"] else False self.options["maxsteps"] = 100000 + self.options["solver"] = "c" #internal solver; "f" for fortran, "c" for c based code + self.solver_module_imported = False # flag if the internal solver module has been imported or not #Solver support self.supports["report_continuously"] = True @@ -859,6 +864,8 @@ def initialize(self): self.statistics.reset() #for k in self.statistics.keys(): # self.statistics[k] = 0 + if not self.solver_module_imported: + self.solver = self.options["solver"] def set_problem_data(self): if self.problem_info["state_events"]: @@ -888,13 +895,14 @@ def f(t, y): def interpolate(self, time, k=0): y = N.empty(self._leny*2) for i in range(self._leny*2): - y[i] = radau5.contr5(i+1, time, self.cont) + # Note: index shift to Fortan based indices + y[i] = self.radau5.contr5(i+1, time, self.cont) if k == 0: return y[:self._leny] elif k == 1: return y[self._leny:2*self._leny] - def _solout(self, nrsol, told, t, y, cont, lrc, irtrn): + def _solout(self, nrsol, told, t, y, cont, werr, lrc, irtrn): """ This method is called after every successful step taken by Radau5 """ @@ -954,7 +962,7 @@ def integrate(self, t, y, yd, tf, opts): MUMAS = 0 #The mass matrix is only defined on the diagonal IOUT = 1 #solout is called after every step WORK = N.array([0.0]*(5*((self.problem_info["dim"]*2)**2+12)+20)) #Work (double) vector - IWORK = N.array([0]*(3*(self.problem_info["dim"]*2)+20)) #Work (integer) vector + IWORK = N.array([0]*(3*(self.problem_info["dim"]*2)+20),dtype=N.intc) #Work (integer) vector #Setting work options WORK[1] = self.safe @@ -995,10 +1003,10 @@ def integrate(self, t, y, yd, tf, opts): self._mass_matrix = N.array([[0]*self._leny]) atol = N.append(self.atol, self.atol) - - t, y, h, iwork, flag = radau5.radau5(self._f, t, y.copy(), tf, self.inith, self.rtol*N.ones(self.problem_info["dim"]*2), atol, + + t, y, h, iwork, flag = self.radau5.radau5(self._f, t, y.copy(), tf, self.inith, self.rtol*N.ones(self.problem_info["dim"]*2), atol, ITOL, jac_dummy, IJAC, MLJAC, MUJAC, self._mas_f, IMAS, MLMAS, MUMAS, self._solout, IOUT, WORK, IWORK) - + #Checking return if flag == 1: flag = ID_PY_COMPLETE @@ -1015,7 +1023,7 @@ def integrate(self, t, y, yd, tf, opts): #self.statistics["nstepstotal"] += iwork[15] self.statistics["nerrfails"] += iwork[17] self.statistics["nlus"] += iwork[18] - + return flag, self._tlist, self._ylist, self._ydlist def state_event_info(self): diff --git a/tests/solvers/test_euler.py b/tests/solvers/test_euler.py index 2148d424..b47e09b4 100644 --- a/tests/solvers/test_euler.py +++ b/tests/solvers/test_euler.py @@ -173,8 +173,8 @@ def handle_event(solver, event_info): solver.y+= 1.0 global tnext nose.tools.assert_almost_equal(solver.t, tnext) - assert event_info[0] == [] - assert event_info[1] == True + nose.tools.assert_equal(event_info[0], []) + nose.tools.assert_true(event_info[1]) exp_mod = Explicit_Problem(f,0.0) exp_mod.time_events = time_events @@ -184,7 +184,7 @@ def handle_event(solver, event_info): exp_sim = ExplicitEuler(exp_mod) exp_sim(5.,100) - assert nevent == 5 + nose.tools.assert_equal(nevent, 5) @testattr(stddist = True) def test_integrator(self): @@ -239,9 +239,9 @@ def handle_event(solver, event_info): mod.handle_event = handle_event sim = ExplicitEuler(mod) - assert sim.sw[0] == True + nose.tools.assert_true(sim.sw[0]) sim.simulate(3) - assert sim.sw[0] == False + nose.tools.assert_false(sim.sw[0]) class Test_Implicit_Euler: @@ -257,13 +257,13 @@ def setUp(self): @testattr(stddist = True) def test_reset_statistics(self): - assert self.simulator.statistics["nsteps"] == 0 + nose.tools.assert_equal(self.simulator.statistics["nsteps"], 0) self.simulator.simulate(5) nsteps = self.simulator.statistics["nsteps"] self.simulator.simulate(6) - assert self.simulator.statistics["nsteps"] < nsteps + nose.tools.assert_less(self.simulator.statistics["nsteps"], nsteps) @testattr(stddist = True) def test_usejac_csc_matrix(self): @@ -279,7 +279,7 @@ def test_usejac_csc_matrix(self): exp_sim = ImplicitEuler(exp_mod) exp_sim.simulate(5.,100) - assert exp_sim.statistics["nfcnjacs"] == 0 + nose.tools.assert_equal(exp_sim.statistics["nfcnjacs"], 0) nose.tools.assert_almost_equal(exp_sim.y_sol[-1][0], -121.995500, 4) exp_sim.reset() @@ -287,7 +287,7 @@ def test_usejac_csc_matrix(self): exp_sim.simulate(5.,100) nose.tools.assert_almost_equal(exp_sim.y_sol[-1][0], -121.995500, 4) - assert exp_sim.statistics["nfcnjacs"] > 0 + nose.tools.assert_greater(exp_sim.statistics["nfcnjacs"], 0) @testattr(stddist = True) def test_h(self): @@ -320,8 +320,8 @@ def handle_event(solver, event_info): solver.y+= 1.0 global tnext nose.tools.assert_almost_equal(solver.t, tnext) - assert event_info[0] == [] - assert event_info[1] == True + nose.tools.assert_equal(event_info[0], []) + nose.tools.assert_true(event_info[1]) exp_mod = Explicit_Problem(f,0.0) exp_mod.time_events = time_events @@ -331,7 +331,7 @@ def handle_event(solver, event_info): exp_sim = ImplicitEuler(exp_mod) exp_sim(5.,100) - assert nevent == 5 + nose.tools.assert_equal(nevent, 5) @testattr(stddist = True) def test_integrator(self): @@ -369,7 +369,7 @@ def test_stiff_problem(self): y_correct = lambda t: N.exp(-15*t) abs_err = N.abs(y[:,0]-y_correct(N.array(t))) - assert N.max(abs_err) < 0.1 + nose.tools.assert_less(N.max(abs_err), 0.1) @testattr(stddist = True) def test_switches(self): @@ -388,6 +388,6 @@ def handle_event(solver, event_info): mod.handle_event = handle_event sim = ImplicitEuler(mod) - assert sim.sw[0] == True + nose.tools.assert_true(sim.sw[0]) sim.simulate(3) - assert sim.sw[0] == False + nose.tools.assert_false(sim.sw[0]) diff --git a/tests/solvers/test_glimda.py b/tests/solvers/test_glimda.py index 1974f16c..1fb91e49 100644 --- a/tests/solvers/test_glimda.py +++ b/tests/solvers/test_glimda.py @@ -70,7 +70,7 @@ def test_simulate_explicit(self): problem = Explicit_Problem(f,y0) simulator = GLIMDA(problem) - assert simulator.yd0[0] == -simulator.y0[0] + nose.tools.assert_equal(simulator.yd0[0], -simulator.y0[0]) t,y = simulator.simulate(1.0) @@ -81,13 +81,13 @@ def test_maxord(self): """ Tests the maximum order of GLIMDA. """ - assert self.sim.maxord == 3 #Default - assert self.sim.options["maxord"] == 3 + nose.tools.assert_equal(self.sim.maxord, 3)#Default + nose.tools.assert_equal(self.sim.options["maxord"], 3) self.sim.maxord = 2 - assert self.sim.maxord == 2 #Default - assert self.sim.options["maxord"] == 2 + nose.tools.assert_equal(self.sim.maxord, 2)#Default + nose.tools.assert_equal(self.sim.options["maxord"], 2) nose.tools.assert_raises(GLIMDA_Exception, self.sim._set_maxord, 4) nose.tools.assert_raises(GLIMDA_Exception, self.sim._set_maxord, 0) @@ -97,13 +97,13 @@ def test_minord(self): """ Tests the minimum order of GLIMDA. """ - assert self.sim.minord == 1 #Default - assert self.sim.options["minord"] == 1 + nose.tools.assert_equal(self.sim.minord, 1)#Default + nose.tools.assert_equal(self.sim.options["minord"], 1) self.sim.minord = 2 - assert self.sim.minord == 2 #Default - assert self.sim.options["minord"] == 2 + nose.tools.assert_equal(self.sim.minord, 2)#Default + nose.tools.assert_equal(self.sim.options["minord"], 2) nose.tools.assert_raises(GLIMDA_Exception, self.sim._set_minord, 4) nose.tools.assert_raises(GLIMDA_Exception, self.sim._set_minord, 0) @@ -113,13 +113,13 @@ def test_maxsteps(self): """ Tests the maximum allowed steps of GLIMDA """ - assert self.sim.maxsteps == 100000 - assert self.sim.options["maxsteps"] == 100000 + nose.tools.assert_equal(self.sim.maxsteps, 100000) + nose.tools.assert_equal(self.sim.options["maxsteps"], 100000) self.sim.maxsteps = 100 - assert self.sim.maxsteps == 100 - assert self.sim.options["maxsteps"] == 100 + nose.tools.assert_equal(self.sim.maxsteps, 100) + nose.tools.assert_equal(self.sim.options["maxsteps"], 100) nose.tools.assert_raises(GLIMDA_Exception, self.sim._set_maxsteps, -1) @@ -128,13 +128,13 @@ def test_newt(self): """ Tests the maximum allowed number of Newton iterations GLIMDA """ - assert self.sim.newt == 5 - assert self.sim.options["newt"] == 5 + nose.tools.assert_equal(self.sim.newt, 5) + nose.tools.assert_equal(self.sim.options["newt"], 5) self.sim.newt = 3 - assert self.sim.newt == 3 - assert self.sim.options["newt"] == 3 + nose.tools.assert_equal(self.sim.newt, 3) + nose.tools.assert_equal(self.sim.options["newt"], 3) nose.tools.assert_raises(GLIMDA_Exception, self.sim._set_newt, -1) @@ -143,26 +143,26 @@ def test_minh(self): """ Tests the minimum stepsize of GLIMDA. """ - assert self.sim.minh == N.finfo(N.double).eps - assert self.sim.options["minh"] == N.finfo(N.double).eps + nose.tools.assert_equal(self.sim.minh, N.finfo(N.double).eps) + nose.tools.assert_equal(self.sim.options["minh"], N.finfo(N.double).eps) self.sim.minh = 1e-5 - assert self.sim.minh == 1e-5 - assert self.sim.options["minh"] == 1e-5 + nose.tools.assert_equal(self.sim.minh, 1e-5) + nose.tools.assert_equal(self.sim.options["minh"], 1e-5) @testattr(stddist = True) def test_order(self): """ Tests the order of GLIMDA. """ - assert self.sim.order == 0 - assert self.sim.options["order"] == 0 + nose.tools.assert_equal(self.sim.order, 0) + nose.tools.assert_equal(self.sim.options["order"], 0) self.sim.order = 1 - assert self.sim.order == 1 - assert self.sim.options["order"] == 1 + nose.tools.assert_equal(self.sim.order, 1) + nose.tools.assert_equal(self.sim.options["order"], 1) nose.tools.assert_raises(GLIMDA_Exception, self.sim._set_order, -1) @@ -171,26 +171,25 @@ def test_maxh(self): """ Tests the maximum stepsize of GLIMDA. """ - assert self.sim.maxh == N.inf - assert self.sim.options["maxh"] == N.inf + nose.tools.assert_equal(self.sim.maxh, N.inf) + nose.tools.assert_equal(self.sim.options["maxh"], N.inf) self.sim.maxh = 1e5 - assert self.sim.maxh == 1e5 - assert self.sim.options["maxh"] == 1e5 + nose.tools.assert_equal(self.sim.maxh, 1e5) + nose.tools.assert_equal(self.sim.options["maxh"], 1e5) @testattr(stddist = True) def test_maxretry(self): """ Tests the maximum number of retries of GLIMDA. """ - assert self.sim.maxretry == 15 - assert self.sim.options["maxretry"] == 15 + nose.tools.assert_equal(self.sim.maxretry, 15) + nose.tools.assert_equal(self.sim.options["maxretry"], 15) self.sim.maxretry = 10 - assert self.sim.maxretry == 10 - assert self.sim.options["maxretry"] == 10 + nose.tools.assert_equal(self.sim.maxretry, 10) + nose.tools.assert_equal(self.sim.options["maxretry"], 10) nose.tools.assert_raises(GLIMDA_Exception, self.sim._set_maxretry, -1) - diff --git a/tests/solvers/test_kinsol.py b/tests/solvers/test_kinsol.py index f9eaf6e7..bd3c0761 100644 --- a/tests/solvers/test_kinsol.py +++ b/tests/solvers/test_kinsol.py @@ -27,9 +27,9 @@ class Test_KINSOL: def test_problem_name_attribute(self): res = lambda y: y model = Algebraic_Problem(res, 1) - assert model.name == "---" + nose.tools.assert_equal(model.name, "---") model = Algebraic_Problem(res, 1, name="Test") - assert model.name == "Test" + nose.tools.assert_equal(model.name, "Test") @testattr(stddist = True) def test_properties_simple(self): @@ -38,19 +38,19 @@ def test_properties_simple(self): solver = KINSOL(model) solver.max_iter = 150 - assert solver.max_iter == 150 + nose.tools.assert_equal(solver.max_iter, 150) solver.no_initial_setup = True - assert solver.no_initial_setup == True + nose.tools.assert_true(solver.no_initial_setup) solver.max_solves_between_setup_calls = 15 - assert solver.max_solves_between_setup_calls == 15 + nose.tools.assert_equal(solver.max_solves_between_setup_calls, 15) solver.max_newton_step = 1.0 - assert solver.max_newton_step == 1.0 + nose.tools.assert_equal(solver.max_newton_step, 1.0) solver.no_min_epsilon = True - assert solver.no_min_epsilon == True + nose.tools.assert_true(solver.no_min_epsilon) solver.max_beta_fails = 15 - assert solver.max_beta_fails == 15 + nose.tools.assert_equal(solver.max_beta_fails, 15) diff --git a/tests/solvers/test_odepack.py b/tests/solvers/test_odepack.py index f758c396..48d0fc1a 100644 --- a/tests/solvers/test_odepack.py +++ b/tests/solvers/test_odepack.py @@ -296,7 +296,7 @@ def test_usejac_csc_matrix(self): self.sim_sp.simulate(2.) #Simulate 2 seconds - assert self.sim_sp.statistics["nfcnjacs"] == 0 + nose.tools.assert_equal(self.sim_sp.statistics["nfcnjacs"], 0) nose.tools.assert_almost_equal(self.sim_sp.y_sol[-1][0], 1.7061680350, 4) @@ -310,12 +310,12 @@ def test_simulation_ncp_list(self): def test_maxh(self): self.sim.hmax = 1.0 - assert self.sim.options["maxh"] == 1.0 - assert self.sim.maxh == 1.0 + nose.tools.assert_equal(self.sim.options["maxh"], 1.0) + nose.tools.assert_equal(self.sim.maxh, 1.0) self.sim.maxh = 2.0 - assert self.sim.options["maxh"] == 2.0 - assert self.sim.maxh == 2.0 + nose.tools.assert_equal(self.sim.options["maxh"], 2.0) + nose.tools.assert_equal(self.sim.maxh, 2.0) @testattr(stddist = True) def test_simulation_ncp_list_2(self): diff --git a/tests/solvers/test_radau5.py b/tests/solvers/test_radau5.py index 2cf841cf..5d808932 100644 --- a/tests/solvers/test_radau5.py +++ b/tests/solvers/test_radau5.py @@ -20,6 +20,7 @@ from assimulo.solvers.radau5 import * from assimulo.solvers.radau5 import Radau5DAE, _Radau5DAE from assimulo.solvers.radau5 import Radau5ODE, _Radau5ODE +from assimulo.solvers.radau5 import Radau5Error from assimulo.problem import Explicit_Problem from assimulo.problem import Implicit_Problem from assimulo.exception import * @@ -118,7 +119,7 @@ def init_mode(self, solver): class Test_Explicit_Radau5: """ - Tests the explicit Radau solver. + Tests the explicit Radau solver (Python implementation). """ def setUp(self): """ @@ -163,11 +164,287 @@ def jac(t,y): self.sim.inith = 1.e-4 #Initial step-size self.sim.usejac = False + @testattr(stddist = True) + def test_event_localizer(self): + pass + # exp_mod = Extended_Problem() #Create the problem + + # exp_sim = _Radau5ODE(exp_mod) #Create the solver + + # exp_sim.verbosity = 0 + # exp_sim.report_continuously = True + + # #Simulate + # t, y = exp_sim.simulate(10.0,1000) #Simulate 10 seconds with 1000 communications points + + # #Basic test + # nose.tools.assert_almost_equal(y[-1][0],8.0) + # nose.tools.assert_almost_equal(y[-1][1],3.0) + # nose.tools.assert_almost_equal(y[-1][2],2.0) + + @testattr(stddist = True) + def test_time_event(self): + f = lambda t,y: [1.0] + global tnext + global nevent + tnext = 0.0 + nevent = 0 + def time_events(t,y,sw): + global tnext,nevent + events = [1.0, 2.0, 2.5, 3.0] + for ev in events: + if t < ev: + tnext = ev + break + else: + tnext = None + nevent += 1 + return tnext + + def handle_event(solver, event_info): + solver.y+= 1.0 + global tnext + nose.tools.assert_almost_equal(solver.t, tnext) + nose.tools.assert_equal(event_info[0], []) + nose.tools.assert_true(event_info[1]) + + exp_mod = Explicit_Problem(f,0.0) + exp_mod.time_events = time_events + exp_mod.handle_event = handle_event + + #CVode + exp_sim = _Radau5ODE(exp_mod) + exp_sim(5.,100) + + nose.tools.assert_equal(nevent, 5) + + @testattr(stddist = True) + def test_init(self): + + #Test both y0 in problem and not. + sim = _Radau5ODE(self.mod) + + nose.tools.assert_equal(sim._leny, 2) + + @testattr(stddist = True) + def test_collocation_polynomial(self): + """ + This tests the functionality of the collocation polynomial (communication points) + """ + self.sim.report_continuously = False + + self.sim.simulate(2.,200) #Simulate 2 seconds + + nose.tools.assert_less(self.sim.statistics["nsteps"], 300) + + #nose.tools.assert_almost_equal(self.sim.y[-2][0], 1.71505001, 4) + print + nose.tools.assert_almost_equal(self.sim.y_sol[-1][0], 1.7061680350, 4) + + self.sim.report_continuously = True + self.sim.reset() + self.sim.simulate(2.,200) #Simulate 2 seconds + + nose.tools.assert_less(self.sim.statistics["nsteps"], 300) + + #nose.tools.assert_almost_equal(self.sim.y[-2][0], 1.71505001, 4) + nose.tools.assert_almost_equal(self.sim.y_sol[-1][0], 1.7061680350, 4) + + self.sim_t0.simulate(3.) + nose.tools.assert_almost_equal(self.sim_t0.t_sol[0], 1.0000000, 4) + nose.tools.assert_almost_equal(self.sim_t0.t_sol[-1], 3.0000000, 4) + nose.tools.assert_almost_equal(self.sim_t0.y_sol[-1][0], 1.7061680350, 4) + + @testattr(stddist = True) + def test_simulation(self): + """ + This tests the Radau5 with a simulation of the van der Pol problem. + """ + self.sim.simulate(2.) #Simulate 2 seconds + + nose.tools.assert_less(self.sim.statistics["nsteps"], 300) + + nose.tools.assert_almost_equal(self.sim.y_sol[-1][0], 1.7061680350, 4) + + @testattr(stddist = True) + def test_simulation_ncp(self): + """ + Test a simulation with ncp. + """ + self.sim.report_continuously = True + + self.sim.simulate(1.0, 200) #Simulate 1 second + nose.tools.assert_equal(len(self.sim.t_sol), 201) + + self.sim.reset() + self.sim.report_continuously = False + + self.sim.simulate(1.0, 200) #Simulate 1 second + nose.tools.assert_equal(len(self.sim.t_sol), 201) + + @testattr(stddist = True) + def test_usejac(self): + """ + This tests the usejac property. + """ + self.sim.usejac = True + + self.sim.simulate(2.) #Simulate 2 seconds + + nose.tools.assert_equal(self.sim.statistics["nfcnjacs"], 0) + + nose.tools.assert_almost_equal(self.sim.y_sol[-1][0], 1.7061680350, 4) + + @testattr(stddist = True) + def test_thet(self): + """ + This tests a negative value of thet. + """ + self.sim.thet = -1 + self.sim.simulate(2.) #Simulate 2 seconds + + nose.tools.assert_equal(self.sim.statistics["nsteps"], self.sim.statistics["njacs"]) + + @testattr(stddist = True) + def test_maxh(self): + """ + This tests the maximum step length. + """ + self.sim.maxh = 0.01 + self.sim.simulate(0.5) + nose.tools.assert_less_equal(max(N.diff(self.sim.t_sol))-N.finfo('double').eps, 0.01) + + @testattr(stddist = True) + def test_newt(self): + """ + This tests the maximum number of newton iterations. + """ + self.sim.newt = 10 + self.sim.simulate(1.0) + + nose.tools.assert_equal(self.sim.statistics["nnfails"], 1) + + @testattr(stddist = True) + def test_safe(self): + """ + This tests the safety factor in the step-size prediction. + """ + self.sim.safe = 0.99 + self.sim.simulate(1.0) + nose.tools.assert_less(self.sim.statistics["nsteps"], 150) + + @testattr(stddist = True) + def test_reset_statistics(self): + """ + Tests that the statistics are reset. + """ + self.sim.simulate(1.0) + steps = self.sim.statistics["nsteps"] + + self.sim.reset() + self.sim.simulate(1.0) + + nose.tools.assert_less(self.sim.statistics["nsteps"], steps*1.5) + + @testattr(stddist = True) + def test_atol(self): + """ + This test the absolute tolerance. + """ + self.sim.simulate(1.0) + + steps = self.sim.statistics["nsteps"] + + self.sim.reset() + + self.sim.rtol = 1e-8 + self.sim.atol = 1e-8 + + self.sim.simulate(1.0) + steps2 = self.sim.statistics["nsteps"] + + nose.tools.assert_greater(steps2, steps) + + self.sim.reset() + self.sim.atol = [1e-8, 1e-8] + + steps3 = self.sim.statistics["nsteps"] + + nose.tools.assert_equal(steps3, steps2) + + nose.tools.assert_raises(Radau_Exception, self.sim._set_atol, [1e-6,1e-6,1e-6]) + +class Test_Explicit_Fortran_Radau5: + """ + Tests the explicit Radau solver. + """ + def setUp(self): + """ + This sets up the test case. + """ + def f(t,y): + eps = 1.e-6 + my = 1./eps + yd_0 = y[1] + yd_1 = my*((1.-y[0]**2)*y[1]-y[0]) + + return N.array([yd_0,yd_1]) + + def jac(t,y): + eps = 1.e-6 + my = 1./eps + J = N.zeros([2,2]) + + J[0,0]=0. + J[0,1]=1. + J[1,0]=my*(-2.*y[0]*y[1]-1.) + J[1,1]=my*(1.-y[0]**2) + + return J + + def jac_sparse(t,y): + eps = 1.e-6 + my = 1./eps + J = N.zeros([2,2]) + + J[0,0]=0. + J[0,1]=1. + J[1,0]=my*(-2.*y[0]*y[1]-1.) + J[1,1]=my*(1.-y[0]**2) + + return sp.csc_matrix(J) + + #Define an Assimulo problem + y0 = [2.0,-0.6] #Initial conditions + + exp_mod = Explicit_Problem(f,y0) + exp_mod_t0 = Explicit_Problem(f,y0,1.0) + exp_mod_sp = Explicit_Problem(f,y0) + + exp_mod.jac = jac + exp_mod_sp.jac = jac_sparse + self.mod = exp_mod + + #Define an explicit solver + self.sim = Radau5ODE(exp_mod) #Create a Radau5 solve + self.sim.solver = 'f' + self.sim_t0 = Radau5ODE(exp_mod_t0) + self.sim_t0.solver = 'f' + self.sim_sp = Radau5ODE(exp_mod_sp) + self.sim_sp.solver = 'f' + + #Sets the parameters + self.sim.atol = 1e-4 #Default 1e-6 + self.sim.rtol = 1e-4 #Default 1e-6 + self.sim.inith = 1.e-4 #Initial step-size + self.sim.usejac = False + @testattr(stddist = True) def test_event_localizer(self): exp_mod = Extended_Problem() #Create the problem exp_sim = Radau5ODE(exp_mod) #Create the solver + exp_sim.solver = 'f' exp_sim.verbosity = 0 exp_sim.report_continuously = True @@ -180,6 +457,22 @@ def test_event_localizer(self): nose.tools.assert_almost_equal(y[-1][1],3.0) nose.tools.assert_almost_equal(y[-1][2],2.0) + @testattr(stddist = True) + def test_nbr_fcn_evals_due_to_jac(self): + sim = Radau5ODE(self.mod) + sim.solver = 'f' + + sim.usejac = False + sim.simulate(1) + + nose.tools.assert_greater(sim.statistics["nfcnjacs"], 0) + + sim = Radau5ODE(self.mod) + sim.solver = 'f' + sim.simulate(1) + + nose.tools.assert_equal(sim.statistics["nfcnjacs"], 0) + @testattr(stddist = True) def test_time_event(self): f = lambda t,y: [1.0] @@ -203,26 +496,28 @@ def handle_event(solver, event_info): solver.y+= 1.0 global tnext nose.tools.assert_almost_equal(solver.t, tnext) - assert event_info[0] == [] - assert event_info[1] == True + nose.tools.assert_equal(event_info[0], []) + nose.tools.assert_true(event_info[1]) exp_mod = Explicit_Problem(f,0.0) exp_mod.time_events = time_events exp_mod.handle_event = handle_event #CVode - exp_sim = _Radau5ODE(exp_mod) + exp_sim = Radau5ODE(exp_mod) + exp_sim.solver = 'f' exp_sim(5.,100) - assert nevent == 5 + nose.tools.assert_equal(nevent, 5) @testattr(stddist = True) def test_init(self): #Test both y0 in problem and not. - sim = _Radau5ODE(self.mod) + sim = Radau5ODE(self.mod) + sim.solver = 'f' - assert sim._leny == 2 + nose.tools.assert_equal(sim._leny, 2) @testattr(stddist = True) def test_collocation_polynomial(self): @@ -233,7 +528,7 @@ def test_collocation_polynomial(self): self.sim.simulate(2.,200) #Simulate 2 seconds - assert self.sim.statistics["nsteps"] < 300 + nose.tools.assert_less(self.sim.statistics["nsteps"], 300) #nose.tools.assert_almost_equal(self.sim.y[-2][0], 1.71505001, 4) nose.tools.assert_almost_equal(self.sim.y_sol[-1][0], 1.7061680350, 4) @@ -242,7 +537,7 @@ def test_collocation_polynomial(self): self.sim.reset() self.sim.simulate(2.,200) #Simulate 2 seconds - assert self.sim.statistics["nsteps"] < 300 + nose.tools.assert_less(self.sim.statistics["nsteps"], 300) #nose.tools.assert_almost_equal(self.sim.y[-2][0], 1.71505001, 4) nose.tools.assert_almost_equal(self.sim.y_sol[-1][0], 1.7061680350, 4) @@ -255,11 +550,11 @@ def test_collocation_polynomial(self): @testattr(stddist = True) def test_simulation(self): """ - This tests the Radau5 with a simulation of the van der Pol problem. + This tests the Radau5 with a simulation of the van der pol problem. """ self.sim.simulate(2.) #Simulate 2 seconds - assert self.sim.statistics["nsteps"] < 300 + nose.tools.assert_less(self.sim.statistics["nsteps"], 300) nose.tools.assert_almost_equal(self.sim.y_sol[-1][0], 1.7061680350, 4) @@ -271,13 +566,13 @@ def test_simulation_ncp(self): self.sim.report_continuously = True self.sim.simulate(1.0, 200) #Simulate 1 second - assert len(self.sim.t_sol) == 201 + nose.tools.assert_equal(len(self.sim.t_sol), 201) self.sim.reset() self.sim.report_continuously = False self.sim.simulate(1.0, 200) #Simulate 1 second - assert len(self.sim.t_sol) == 201 + nose.tools.assert_equal(len(self.sim.t_sol), 201) @testattr(stddist = True) def test_usejac(self): @@ -288,10 +583,23 @@ def test_usejac(self): self.sim.simulate(2.) #Simulate 2 seconds - assert self.sim.statistics["nfcnjacs"] == 0 + nose.tools.assert_equal(self.sim.statistics["nfcnjacs"], 0) nose.tools.assert_almost_equal(self.sim.y_sol[-1][0], 1.7061680350, 4) - + + @testattr(stddist = True) + def test_usejac_csc_matrix(self): + """ + This tests the functionality of the property usejac. + """ + self.sim_sp.usejac = True + + self.sim_sp.simulate(2.) #Simulate 2 seconds + + nose.tools.assert_equal(self.sim_sp.statistics["nfcnjacs"], 0) + + nose.tools.assert_almost_equal(self.sim_sp.y_sol[-1][0], 1.7061680350, 4) + @testattr(stddist = True) def test_thet(self): """ @@ -300,7 +608,7 @@ def test_thet(self): self.sim.thet = -1 self.sim.simulate(2.) #Simulate 2 seconds - assert self.sim.statistics["nsteps"] == self.sim.statistics["njacs"] + nose.tools.assert_equal(self.sim.statistics["nsteps"], self.sim.statistics["njacs"]) @testattr(stddist = True) def test_maxh(self): @@ -309,17 +617,20 @@ def test_maxh(self): """ self.sim.maxh = 0.01 self.sim.simulate(0.5) - assert max(N.diff(self.sim.t_sol))-N.finfo('double').eps <= 0.01 + nose.tools.assert_less_equal(max(N.diff(self.sim.t_sol))-N.finfo('double').eps, 0.01) @testattr(stddist = True) def test_newt(self): """ This tests the maximum number of newton iterations. """ - self.sim.newt = 10 - self.sim.simulate(1.0) + pass + # self.sim.simulate(1.0) + # self.sim.reset() + # self.sim.newt = 10 + # self.sim.simulate(1.0) - assert self.sim.statistics["nnfails"] == 1 + # nose.tools.assert_equal(self.sim.statistics["nniterfail"], 1) @testattr(stddist = True) def test_safe(self): @@ -328,7 +639,7 @@ def test_safe(self): """ self.sim.safe = 0.99 self.sim.simulate(1.0) - assert self.sim.statistics["nsteps"] < 150 + nose.tools.assert_less(self.sim.statistics["nsteps"], 150) @testattr(stddist = True) def test_reset_statistics(self): @@ -341,7 +652,25 @@ def test_reset_statistics(self): self.sim.reset() self.sim.simulate(1.0) - assert self.sim.statistics["nsteps"] < steps*1.5 + nose.tools.assert_less(self.sim.statistics["nsteps"], steps*1.5) + + @testattr(stddist = True) + def test_weighted_error(self): + + def handle_result(solver, t, y): + err = solver.get_weighted_local_errors() + nose.tools.assert_equal(len(err), len(y)) + + self.mod.handle_result = handle_result + + #Define an explicit solver + sim = Radau5ODE(self.mod) #Create a Radau5 solve + sim.solver = 'f' + + sim.get_weighted_local_errors() + + sim.simulate(1) + @testattr(stddist = True) def test_atol(self): @@ -360,18 +689,82 @@ def test_atol(self): self.sim.simulate(1.0) steps2 = self.sim.statistics["nsteps"] - assert steps2 > steps + nose.tools.assert_greater(steps2, steps) self.sim.reset() self.sim.atol = [1e-8, 1e-8] steps3 = self.sim.statistics["nsteps"] - assert steps3==steps2 + nose.tools.assert_equal(steps3, steps2) nose.tools.assert_raises(Radau_Exception, self.sim._set_atol, [1e-6,1e-6,1e-6]) + + @testattr(stddist = True) + def test_switches(self): + """ + This tests that the switches are actually turned when override. + """ + f = lambda t,x,sw: N.array([1.0]) + state_events = lambda t,x,sw: N.array([x[0]-1.]) + def handle_event(solver, event_info): + solver.sw = [False] #Override the switches to point to another instance + + mod = Explicit_Problem(f,[0.0]) + mod.sw0 = [True] -class Test_Explicit_Fortran_Radau5: + mod.state_events = state_events + mod.handle_event = handle_event + + sim = Radau5ODE(mod) + nose.tools.assert_true(sim.sw[0]) + sim.simulate(3) + nose.tools.assert_false(sim.sw[0]) + + @testattr(stddist = True) + def test_nmax_steps(self): + """ + This tests the error upon exceeding a set maximum number of steps + """ + sim = Radau5ODE(self.mod) + sim.solver = 'f' + + sim.maxh = 1.e-1 + sim.maxsteps = 9 + + nose.tools.assert_raises(Radau5Error, sim.simulate, 1.) + + @testattr(stddist = True) + def test_step_size_too_small(self): + """ + This tests the error for too small step-sizes + """ + sim = Radau5ODE(self.mod) + sim.solver = 'f' + + sim.atol = 1.e10 + sim.rtol = 1.e10 + + sim.inith = 1.e-1 + sim.maxh = 1.e-1 + + nose.tools.assert_raises(Radau5Error, sim.simulate, 1. + 1.e-16) + + @testattr(stddist = True) + def test_repeated_unexpected_step_rejections(self): + """ + This tests the error for repeated unexpected step rejections + """ + def f(t, y): + raise N.linalg.LinAlgError() + y0 = N.array([1.]) + prob = Explicit_Problem(f, y0) + sim = Radau5ODE(prob) + sim.solver = 'f' + + nose.tools.assert_raises(Radau5Error, sim.simulate, 1.) + +class Test_Explicit_C_Radau5: """ Tests the explicit Radau solver. """ @@ -424,28 +817,51 @@ def jac_sparse(t,y): #Define an explicit solver self.sim = Radau5ODE(exp_mod) #Create a Radau5 solve + self.sim.solver = 'c' self.sim_t0 = Radau5ODE(exp_mod_t0) + self.sim_t0.solver = 'c' self.sim_sp = Radau5ODE(exp_mod_sp) + self.sim_sp.solver = 'c' + + #Sets the parameters + self.sim.atol = 1e-4 #Default 1e-6 + self.sim.rtol = 1e-4 #Default 1e-6 + self.sim.inith = 1.e-4 #Initial step-size + self.sim.usejac = False + + @testattr(stddist = True) + def test_event_localizer(self): + exp_mod = Extended_Problem() #Create the problem + + exp_sim = Radau5ODE(exp_mod) #Create the solver + exp_sim.solver = 'c' + + exp_sim.verbosity = 0 + exp_sim.report_continuously = True - #Sets the parameters - self.sim.atol = 1e-4 #Default 1e-6 - self.sim.rtol = 1e-4 #Default 1e-6 - self.sim.inith = 1.e-4 #Initial step-size - self.sim.usejac = False + #Simulate + t, y = exp_sim.simulate(10.0,1000) #Simulate 10 seconds with 1000 communications points + + #Basic test + nose.tools.assert_almost_equal(y[-1][0],8.0) + nose.tools.assert_almost_equal(y[-1][1],3.0) + nose.tools.assert_almost_equal(y[-1][2],2.0) @testattr(stddist = True) def test_nbr_fcn_evals_due_to_jac(self): sim = Radau5ODE(self.mod) + sim.solver = 'c' sim.usejac = False sim.simulate(1) - assert sim.statistics["nfcnjacs"] > 0 + nose.tools.assert_greater(sim.statistics["nfcnjacs"], 0) sim = Radau5ODE(self.mod) + sim.solver = 'c' sim.simulate(1) - assert sim.statistics["nfcnjacs"] == 0 + nose.tools.assert_equal(sim.statistics["nfcnjacs"], 0) @testattr(stddist = True) def test_time_event(self): @@ -470,8 +886,8 @@ def handle_event(solver, event_info): solver.y+= 1.0 global tnext nose.tools.assert_almost_equal(solver.t, tnext) - assert event_info[0] == [] - assert event_info[1] == True + nose.tools.assert_equal(event_info[0], []) + nose.tools.assert_true(event_info[1]) exp_mod = Explicit_Problem(f,0.0) exp_mod.time_events = time_events @@ -479,17 +895,19 @@ def handle_event(solver, event_info): #CVode exp_sim = Radau5ODE(exp_mod) + exp_sim.solver = 'c' exp_sim(5.,100) - assert nevent == 5 + nose.tools.assert_equal(nevent, 5) @testattr(stddist = True) def test_init(self): #Test both y0 in problem and not. sim = Radau5ODE(self.mod) + sim.solver = 'c' - assert sim._leny == 2 + nose.tools.assert_equal(sim._leny, 2) @testattr(stddist = True) def test_collocation_polynomial(self): @@ -500,7 +918,7 @@ def test_collocation_polynomial(self): self.sim.simulate(2.,200) #Simulate 2 seconds - assert self.sim.statistics["nsteps"] < 300 + nose.tools.assert_less(self.sim.statistics["nsteps"], 300) #nose.tools.assert_almost_equal(self.sim.y[-2][0], 1.71505001, 4) nose.tools.assert_almost_equal(self.sim.y_sol[-1][0], 1.7061680350, 4) @@ -509,7 +927,7 @@ def test_collocation_polynomial(self): self.sim.reset() self.sim.simulate(2.,200) #Simulate 2 seconds - assert self.sim.statistics["nsteps"] < 300 + nose.tools.assert_less(self.sim.statistics["nsteps"], 300) #nose.tools.assert_almost_equal(self.sim.y[-2][0], 1.71505001, 4) nose.tools.assert_almost_equal(self.sim.y_sol[-1][0], 1.7061680350, 4) @@ -526,7 +944,7 @@ def test_simulation(self): """ self.sim.simulate(2.) #Simulate 2 seconds - assert self.sim.statistics["nsteps"] < 300 + nose.tools.assert_less(self.sim.statistics["nsteps"], 300) nose.tools.assert_almost_equal(self.sim.y_sol[-1][0], 1.7061680350, 4) @@ -538,13 +956,13 @@ def test_simulation_ncp(self): self.sim.report_continuously = True self.sim.simulate(1.0, 200) #Simulate 1 second - assert len(self.sim.t_sol) == 201 + nose.tools.assert_equal(len(self.sim.t_sol), 201) self.sim.reset() self.sim.report_continuously = False self.sim.simulate(1.0, 200) #Simulate 1 second - assert len(self.sim.t_sol) == 201 + nose.tools.assert_equal(len(self.sim.t_sol), 201) @testattr(stddist = True) def test_usejac(self): @@ -555,7 +973,7 @@ def test_usejac(self): self.sim.simulate(2.) #Simulate 2 seconds - assert self.sim.statistics["nfcnjacs"] == 0 + nose.tools.assert_equal(self.sim.statistics["nfcnjacs"], 0) nose.tools.assert_almost_equal(self.sim.y_sol[-1][0], 1.7061680350, 4) @@ -568,7 +986,7 @@ def test_usejac_csc_matrix(self): self.sim_sp.simulate(2.) #Simulate 2 seconds - assert self.sim_sp.statistics["nfcnjacs"] == 0 + nose.tools.assert_equal(self.sim_sp.statistics["nfcnjacs"], 0) nose.tools.assert_almost_equal(self.sim_sp.y_sol[-1][0], 1.7061680350, 4) @@ -580,7 +998,7 @@ def test_thet(self): self.sim.thet = -1 self.sim.simulate(2.) #Simulate 2 seconds - assert self.sim.statistics["nsteps"] == self.sim.statistics["njacs"] + nose.tools.assert_equal(self.sim.statistics["nsteps"], self.sim.statistics["njacs"]) @testattr(stddist = True) def test_maxh(self): @@ -589,7 +1007,7 @@ def test_maxh(self): """ self.sim.maxh = 0.01 self.sim.simulate(0.5) - assert max(N.diff(self.sim.t_sol))-N.finfo('double').eps <= 0.01 + nose.tools.assert_less_equal(max(N.diff(self.sim.t_sol))-N.finfo('double').eps, 0.01) @testattr(stddist = True) def test_newt(self): @@ -597,12 +1015,11 @@ def test_newt(self): This tests the maximum number of newton iterations. """ pass - #self.sim.simulate(1.0) - #self.sim.reset() - #self.sim.newt = 10 - #self.sim.simulate(1.0) - - #assert self.sim.statistics["nniterfail"] == 1 + # self.sim.simulate(1.0) + # self.sim.reset() + # self.sim.newt = 10 + # self.sim.simulate(1.0) + # nose.tools.assert_equal(self.sim.statistics["nniterfail"], 1) @testattr(stddist = True) def test_safe(self): @@ -611,7 +1028,7 @@ def test_safe(self): """ self.sim.safe = 0.99 self.sim.simulate(1.0) - assert self.sim.statistics["nsteps"] < 150 + nose.tools.assert_less(self.sim.statistics["nsteps"], 150) @testattr(stddist = True) def test_reset_statistics(self): @@ -624,19 +1041,20 @@ def test_reset_statistics(self): self.sim.reset() self.sim.simulate(1.0) - assert self.sim.statistics["nsteps"] < steps*1.5 + nose.tools.assert_less(self.sim.statistics["nsteps"], steps*1.5) @testattr(stddist = True) def test_weighted_error(self): def handle_result(solver, t, y): err = solver.get_weighted_local_errors() - assert len(err) == len(y) + nose.tools.assert_equal(len(err), len(y)) self.mod.handle_result = handle_result #Define an explicit solver sim = Radau5ODE(self.mod) #Create a Radau5 solve + sim.solver = 'c' sim.get_weighted_local_errors() @@ -660,14 +1078,14 @@ def test_atol(self): self.sim.simulate(1.0) steps2 = self.sim.statistics["nsteps"] - assert steps2 > steps + nose.tools.assert_greater(steps2, steps) self.sim.reset() self.sim.atol = [1e-8, 1e-8] steps3 = self.sim.statistics["nsteps"] - assert steps3==steps2 + nose.tools.assert_equal(steps3, steps2) nose.tools.assert_raises(Radau_Exception, self.sim._set_atol, [1e-6,1e-6,1e-6]) @@ -688,10 +1106,53 @@ def handle_event(solver, event_info): mod.handle_event = handle_event sim = Radau5ODE(mod) - assert sim.sw[0] == True + sim.solver = 'c' + nose.tools.assert_true(sim.sw[0]) sim.simulate(3) - assert sim.sw[0] == False + nose.tools.assert_false(sim.sw[0]) + + @testattr(stddist = True) + def test_nmax_steps(self): + """ + This tests the error upon exceeding a set maximum number of steps + """ + sim = Radau5ODE(self.mod) + sim.solver = 'c' + + sim.maxh = 1.e-1 + sim.maxsteps = 9 + + nose.tools.assert_raises(Radau5Error, sim.simulate, 1.) + + @testattr(stddist = True) + def test_step_size_too_small(self): + """ + This tests the error for too small step-sizes + """ + sim = Radau5ODE(self.mod) + sim.solver = 'c' + + sim.atol = 1.e10 + sim.rtol = 1.e10 + + sim.inith = 1.e-1 + sim.maxh = 1.e-1 + + nose.tools.assert_raises(Radau5Error, sim.simulate, 1. + 1.e-16) + + @testattr(stddist = True) + def test_repeated_unexpected_step_rejections(self): + """ + This tests the error for repeated unexpected step rejections + """ + def f(t, y): + raise N.linalg.LinAlgError() + y0 = N.array([1.]) + prob = Explicit_Problem(f, y0) + sim = Radau5ODE(prob) + sim.solver = 'c' + nose.tools.assert_raises(Radau5Error, sim.simulate, 1.) class Test_Implicit_Fortran_Radau5: """ @@ -722,7 +1183,9 @@ def f(t,y,yd): #Define an explicit solver self.sim = Radau5DAE(self.mod) #Create a Radau5 solve + self.sim.solver = 'f' self.sim_t0 = Radau5DAE(self.mod_t0) + self.sim_t0.solver = 'f' #Sets the parameters self.sim.atol = 1e-4 #Default 1e-6 @@ -732,11 +1195,12 @@ def f(t,y,yd): @testattr(stddist = True) def test_nbr_fcn_evals_due_to_jac(self): sim = Radau5DAE(self.mod) + sim.solver = 'f' sim.usejac = False sim.simulate(1) - assert sim.statistics["nfcnjacs"] > 0 + nose.tools.assert_greater(sim.statistics["nfcnjacs"], 0) @testattr(stddist = True) def test_simulate_explicit(self): @@ -748,8 +1212,9 @@ def test_simulate_explicit(self): problem = Explicit_Problem(f,y0) simulator = Radau5DAE(problem) + simulator.solver = 'f' - assert simulator.yd0[0] == -simulator.y0[0] + nose.tools.assert_equal(simulator.yd0[0], -simulator.y0[0]) t,y = simulator.simulate(1.0) @@ -778,8 +1243,8 @@ def handle_event(solver, event_info): #solver.y+= 1.0 global tnext nose.tools.assert_almost_equal(solver.t, tnext) - assert event_info[0] == [] - assert event_info[1] == True + nose.tools.assert_equal(event_info[0], []) + nose.tools.assert_true(event_info[1]) exp_mod = Implicit_Problem(f,0.0,0.0) exp_mod.time_events = time_events @@ -787,10 +1252,11 @@ def handle_event(solver, event_info): #CVode exp_sim = Radau5DAE(exp_mod) + exp_sim.solver = 'f' exp_sim.verbosity = 0 exp_sim(5.,100) - assert nevent == 5 + nose.tools.assert_equal(nevent, 5) @testattr(stddist = True) def test_init(self): @@ -800,8 +1266,9 @@ def test_init(self): #Test both y0 in problem and not. sim = Radau5DAE(self.mod) + sim.solver = 'f' - assert sim._leny == 2 + nose.tools.assert_equal(sim._leny, 2) @testattr(stddist = True) def test_thet(self): @@ -811,7 +1278,7 @@ def test_thet(self): self.sim.thet = -1 self.sim.simulate(.5) #Simulate 2 seconds - assert self.sim.statistics["nsteps"] == self.sim.statistics["njacs"] + nose.tools.assert_equal(self.sim.statistics["nsteps"], self.sim.statistics["njacs"]) @testattr(stddist = True) def test_simulation(self): @@ -843,13 +1310,13 @@ def test_simulation_ncp(self): self.sim.report_continuously = True self.sim.simulate(1.0, 200) #Simulate 1 second - assert len(self.sim.t_sol) == 201 + nose.tools.assert_equal(len(self.sim.t_sol), 201) self.sim.reset() self.sim.report_continuously = False self.sim.simulate(1.0, 200) #Simulate 1 second - assert len(self.sim.t_sol) == 201 + nose.tools.assert_equal(len(self.sim.t_sol), 201) @testattr(stddist = True) def test_maxh(self): @@ -858,7 +1325,7 @@ def test_maxh(self): """ self.sim.maxh = 0.01 self.sim.simulate(0.5) - assert max(N.diff(self.sim.t_sol))-N.finfo('double').eps <= 0.01 + nose.tools.assert_less_equal(max(N.diff(self.sim.t_sol))-N.finfo('double').eps, 0.01) @testattr(stddist = True) @@ -878,12 +1345,62 @@ def handle_event(solver, event_info): mod.handle_event = handle_event sim = Radau5DAE(mod) - assert sim.sw[0] == True + sim.solver = 'f' + nose.tools.assert_true(sim.sw[0]) sim.simulate(3) - assert sim.sw[0] == False + nose.tools.assert_false(sim.sw[0]) + + @testattr(stddist = True) + def test_nmax_steps(self): + """ + This tests the error upon exceeding a set maximum number of steps + """ + sim = Radau5DAE(self.mod) + sim.solver = 'f' + sim.maxh = 1.e-1 + sim.maxsteps = 9 -class Test_Implicit_Radau5: + nose.tools.assert_raises(Radau5Error, sim.simulate, 1.) + + @testattr(stddist = True) + def test_step_size_too_small(self): + """ + This tests the error for too small step-sizes + """ + f = lambda t, y, yd: -y + y0 = N.array([1.]) + yd0 = N.array([0.]) + + prob = Implicit_Problem(f, y0, yd0) + + sim = Radau5DAE(prob) + sim.solver = 'f' + + sim.atol = 1.e10 + sim.rtol = 1.e10 + + sim.inith = 1.e-1 + sim.maxh = 1.e-1 + + nose.tools.assert_raises(Radau5Error, sim.simulate, 1. + 1.e-16) + + @testattr(stddist = True) + def test_repeated_unexpected_step_rejections(self): + """ + This tests the error for repeated unexpected step rejections + """ + pass + # def f(t, y, yd): + # raise N.linalg.LinAlgError() + # prob = Implicit_Problem(f, N.array([1.]), N.array([1.])) + # sim = Radau5DAE(prob) + # sim.solver = 'f' + + # nose.tools.assert_raises(Radau5Error, sim.simulate, 1.) + + +class Test_Implicit_C_Radau5: """ Tests the implicit Radau solver. """ @@ -910,6 +1427,252 @@ def f(t,y,yd): self.mod = Implicit_Problem(f,y0,yd0) self.mod_t0 = Implicit_Problem(f,y0,yd0,1.0) + #Define an explicit solver + self.sim = Radau5DAE(self.mod) #Create a Radau5 solve + self.sim.solver = 'c' + self.sim_t0 = Radau5DAE(self.mod_t0) + self.sim_t0.solver = 'c' + + #Sets the parameters + self.sim.atol = 1e-4 #Default 1e-6 + self.sim.rtol = 1e-4 #Default 1e-6 + self.sim.inith = 1.e-4 #Initial step-size + + @testattr(stddist = True) + def test_nbr_fcn_evals_due_to_jac(self): + sim = Radau5DAE(self.mod) + sim.solver = 'c' + + sim.usejac = False + sim.simulate(1) + + nose.tools.assert_greater(sim.statistics["nfcnjacs"], 0) + + @testattr(stddist = True) + def test_simulate_explicit(self): + """ + Test a simulation of an explicit problem using Radau5DAE. + """ + f = lambda t,y:N.array(-y) + y0 = [1.0] + + problem = Explicit_Problem(f,y0) + simulator = Radau5DAE(problem) + simulator.solver = 'c' + + nose.tools.assert_equal(simulator.yd0[0], -simulator.y0[0]) + + t,y = simulator.simulate(1.0) + + nose.tools.assert_almost_equal(float(y[-1]), float(N.exp(-1.0)),4) + + @testattr(stddist = True) + def test_time_event(self): + f = lambda t,y,yd: y-yd + global tnext + global nevent + tnext = 0.0 + nevent = 0 + def time_events(t,y,yd,sw): + global tnext,nevent + events = [1.0, 2.0, 2.5, 3.0] + for ev in events: + if t < ev: + tnext = ev + break + else: + tnext = None + nevent += 1 + return tnext + + def handle_event(solver, event_info): + #solver.y+= 1.0 + global tnext + nose.tools.assert_almost_equal(solver.t, tnext) + nose.tools.assert_equal(event_info[0], []) + nose.tools.assert_true(event_info[1]) + + exp_mod = Implicit_Problem(f,0.0,0.0) + exp_mod.time_events = time_events + exp_mod.handle_event = handle_event + + #CVode + exp_sim = Radau5DAE(exp_mod) + exp_sim.solver = 'c' + exp_sim.verbosity = 0 + exp_sim(5.,100) + + nose.tools.assert_equal(nevent, 5) + + @testattr(stddist = True) + def test_init(self): + """ + This tests the functionality of Radau5 Implicit Init. + """ + #Test both y0 in problem and not. + + sim = Radau5DAE(self.mod) + sim.solver = 'c' + + nose.tools.assert_equal(sim._leny, 2) + + @testattr(stddist = True) + def test_thet(self): + """ + This tests a negative value of thet. + """ + self.sim.thet = -1 + self.sim.simulate(.5) #Simulate 2 seconds + + nose.tools.assert_equal(self.sim.statistics["nsteps"], self.sim.statistics["njacs"]) + + @testattr(stddist = True) + def test_simulation(self): + """ + Test a simulation of the van der Pol equations (1). + """ + #Simulate + self.sim.simulate(2.) #Simulate 2 seconds + nose.tools.assert_almost_equal(self.sim.y_sol[-1][0], 1.706272, 3) + + self.sim.reset() + + self.sim.report_continuously = True + + #Simulate + self.sim.simulate(2.) #Simulate 2 seconds + nose.tools.assert_almost_equal(self.sim.y_sol[-1][0], 1.706166, 3) + + self.sim_t0.simulate(3.) + nose.tools.assert_almost_equal(self.sim_t0.t_sol[0], 1.0000000, 4) + nose.tools.assert_almost_equal(self.sim_t0.t_sol[-1], 3.0000000, 4) + nose.tools.assert_almost_equal(self.sim_t0.y_sol[-1][0], 1.7061680350, 4) + + @testattr(stddist = True) + def test_simulation_ncp(self): + """ + Test a simulation with ncp. + """ + self.sim.report_continuously = True + + self.sim.simulate(1.0, 200) #Simulate 1 second + nose.tools.assert_equal(len(self.sim.t_sol), 201) + + self.sim.reset() + self.sim.report_continuously = False + + self.sim.simulate(1.0, 200) #Simulate 1 second + nose.tools.assert_equal(len(self.sim.t_sol), 201) + + @testattr(stddist = True) + def test_maxh(self): + """ + Tests implicit radau with maxh. + """ + self.sim.maxh = 0.01 + self.sim.simulate(0.5) + nose.tools.assert_less_equal(max(N.diff(self.sim.t_sol))-N.finfo('double').eps, 0.01) + + + @testattr(stddist = True) + def test_switches(self): + """ + This tests that the switches are actually turned when override. + """ + res = lambda t,x,xd,sw: N.array([1.0 - xd]) + state_events = lambda t,x,xd,sw: N.array([x[0]-1.]) + def handle_event(solver, event_info): + solver.sw = [False] #Override the switches to point to another instance + + mod = Implicit_Problem(res,[0.0], [1.0]) + mod.sw0 = [True] + + mod.state_events = state_events + mod.handle_event = handle_event + + sim = Radau5DAE(mod) + sim.solver = 'c' + nose.tools.assert_true(sim.sw[0]) + sim.simulate(3) + nose.tools.assert_false(sim.sw[0]) + + @testattr(stddist = True) + def test_nmax_steps(self): + """ + This tests the error upon exceeding a set maximum number of steps + """ + sim = Radau5DAE(self.mod) + sim.solver = 'c' + + sim.maxh = 1.e-1 + sim.maxsteps = 9 + + nose.tools.assert_raises(Radau5Error, sim.simulate, 1.) + + @testattr(stddist = True) + def test_step_size_too_small(self): + """ + This tests the error for too small step-sizes + """ + f = lambda t, y, yd: -y + y0 = N.array([1.]) + yd0 = N.array([0.]) + + prob = Implicit_Problem(f, y0, yd0) + + sim = Radau5DAE(prob) + sim.solver = 'c' + + sim.atol = 1.e10 + sim.rtol = 1.e10 + + sim.inith = 1.e-1 + sim.maxh = 1.e-1 + + nose.tools.assert_raises(Radau5Error, sim.simulate, 1. + 1.e-16) + + @testattr(stddist = True) + def test_repeated_unexpected_step_rejections(self): + """ + This tests the error for repeated unexpected step rejections + """ + pass + # def f(t, y, yd): + # raise N.linalg.LinAlgError() + # prob = Implicit_Problem(f, N.array([1.]), N.array([1.])) + # sim = Radau5DAE(prob) + # sim.solver = 'c' + + # nose.tools.assert_raises(Radau5Error, sim.simulate, 1.) + + +class Test_Implicit_Radau5: + """ + Tests the implicit Radau solver (Python implementation). + """ + def setUp(self): + """ + This sets up the test case. + """ + #Define the residual + def f(t,y,yd): + eps = 1.e-6 + my = 1./eps + yd_0 = y[1] + yd_1 = my*((1.-y[0]**2)*y[1]-y[0]) + + res_0 = yd[0]-yd_0 + res_1 = yd[1]-yd_1 + + return N.array([res_0,res_1]) + + y0 = [2.0,-0.6] #Initial conditions + yd0 = [-.6,-200000.] + + #Define an Assimulo problem + self.mod = Implicit_Problem(f,y0,yd0) + self.mod_t0 = Implicit_Problem(f,y0,yd0,1.0) + #Define an explicit solver self.sim = _Radau5DAE(self.mod) #Create a Radau5 solve self.sim_t0 = _Radau5DAE(self.mod_t0) @@ -942,8 +1705,8 @@ def handle_event(solver, event_info): #solver.y+= 1.0 global tnext nose.tools.assert_almost_equal(solver.t, tnext) - assert event_info[0] == [] - assert event_info[1] == True + nose.tools.assert_equal(event_info[0], []) + nose.tools.assert_true(event_info[1]) exp_mod = Implicit_Problem(f,0.0,0.0) exp_mod.time_events = time_events @@ -954,7 +1717,7 @@ def handle_event(solver, event_info): exp_sim.verbosity = 0 exp_sim(5.,100) - assert nevent == 5 + nose.tools.assert_equal(nevent, 5) @testattr(stddist = True) def test_init(self): @@ -965,7 +1728,7 @@ def test_init(self): sim = _Radau5DAE(self.mod) - assert sim._leny == 2 + nose.tools.assert_equal(sim._leny, 2) @testattr(stddist = True) def test_thet(self): @@ -975,7 +1738,7 @@ def test_thet(self): self.sim.thet = -1 self.sim.simulate(.5) #Simulate 2 seconds - assert self.sim.statistics["nsteps"] == self.sim.statistics["njacs"] + nose.tools.assert_equal(self.sim.statistics["nsteps"], self.sim.statistics["njacs"]) @testattr(stddist = True) def test_simulation(self): @@ -1007,13 +1770,13 @@ def test_simulation_ncp(self): self.sim.report_continuously = True self.sim.simulate(1.0, 200) #Simulate 1 second - assert len(self.sim.t_sol) == 201 + nose.tools.assert_equal(len(self.sim.t_sol), 201) self.sim.reset() self.sim.report_continuously = False self.sim.simulate(1.0, 200) #Simulate 1 second - assert len(self.sim.t_sol) == 201 + nose.tools.assert_equal(len(self.sim.t_sol), 201) @testattr(stddist = True) def test_maxh(self): @@ -1022,7 +1785,7 @@ def test_maxh(self): """ self.sim.maxh = 0.01 self.sim.simulate(0.5) - assert max(N.diff(self.sim.t_sol))-N.finfo('double').eps <= 0.01 + nose.tools.assert_less_equal(max(N.diff(self.sim.t_sol))-N.finfo('double').eps, 0.01) class Test_Radau_Common: """ @@ -1046,9 +1809,9 @@ def test_fac1(self): This tests the functionality of the property fac1. """ self.sim.fac1 = 0.01 - assert self.sim.fac1 == 0.01 + nose.tools.assert_equal(self.sim.fac1, 0.01) self.sim.fac1 = 0.001 - assert self.sim.fac1 == 0.001 + nose.tools.assert_equal(self.sim.fac1, 0.001) nose.tools.assert_raises(Radau_Exception, self.sim._set_fac1, 'Test') nose.tools.assert_raises(Radau_Exception, self.sim._set_fac1, [-1.0]) @@ -1059,9 +1822,9 @@ def test_fac2(self): This tests the functionality of the property fac2. """ self.sim.fac2 = 0.01 - assert self.sim.fac2 == 0.01 + nose.tools.assert_equal(self.sim.fac2, 0.01) self.sim.fac2 = 0.001 - assert self.sim.fac2 == 0.001 + nose.tools.assert_equal(self.sim.fac2, 0.001) nose.tools.assert_raises(Radau_Exception, self.sim._set_fac2, 'Test') nose.tools.assert_raises(Radau_Exception, self.sim._set_fac2, [-1.0]) @@ -1072,9 +1835,9 @@ def test_fnewt(self): This tests the functionality of the property fnewt. """ self.sim.fnewt = 0.01 - assert self.sim.fnewt == 0.01 + nose.tools.assert_equal(self.sim.fnewt, 0.01) self.sim.fnewt = 0.001 - assert self.sim.fnewt == 0.001 + nose.tools.assert_equal(self.sim.fnewt, 0.001) nose.tools.assert_raises(Radau_Exception, self.sim._set_fnewt, 'Test') nose.tools.assert_raises(Radau_Exception, self.sim._set_fnewt, [-1.0]) @@ -1085,9 +1848,9 @@ def test_h(self): This tests the functionality of the property h. """ self.sim.h = 0.01 - assert self.sim.h == 0.01 + nose.tools.assert_equal(self.sim.h, 0.01) self.sim.h = 0.001 - assert self.sim.h == 0.001 + nose.tools.assert_equal(self.sim.h, 0.001) @testattr(stddist = True) def test_initial_step(self): @@ -1095,9 +1858,9 @@ def test_initial_step(self): This tests the functionality of the property initial step. """ self.sim.inith = 0.01 - assert self.sim.inith == 0.01 + nose.tools.assert_equal(self.sim.inith, 0.01) self.sim.inith = 0.001 - assert self.sim.inith == 0.001 + nose.tools.assert_equal(self.sim.inith, 0.001) nose.tools.assert_raises(Radau_Exception, self.sim._set_initial_step, 'Test') nose.tools.assert_raises(Radau_Exception, self.sim._set_initial_step, [-1.0]) @@ -1108,11 +1871,11 @@ def test_newt(self): This tests the functionality of the property newt. """ self.sim.newt = 1 - assert self.sim.newt == 1 + nose.tools.assert_equal(self.sim.newt, 1) self.sim.newt = 10 - assert self.sim.newt == 10 + nose.tools.assert_equal(self.sim.newt, 10) self.sim.newt = 9.8 - assert self.sim.newt == 9 + nose.tools.assert_equal(self.sim.newt, 9) nose.tools.assert_raises(Radau_Exception, self.sim._set_newt, 'Test') nose.tools.assert_raises(Radau_Exception, self.sim._set_newt, [-1.0]) @@ -1123,9 +1886,9 @@ def test_quot1(self): This tests the functionality of the property quot1. """ self.sim.quot1 = 0.01 - assert self.sim.quot1 == 0.01 + nose.tools.assert_equal(self.sim.quot1, 0.01) self.sim.quot1 = 0.001 - assert self.sim.quot1 == 0.001 + nose.tools.assert_equal(self.sim.quot1, 0.001) nose.tools.assert_raises(Radau_Exception, self.sim._set_quot1, 'Test') nose.tools.assert_raises(Radau_Exception, self.sim._set_quot1, [-1.0]) @@ -1136,9 +1899,9 @@ def test_quot2(self): This tests the functionality of the property quot2. """ self.sim.quot2 = 0.01 - assert self.sim.quot2 == 0.01 + nose.tools.assert_equal(self.sim.quot2, 0.01) self.sim.quot2 = 0.001 - assert self.sim.quot2 == 0.001 + nose.tools.assert_equal(self.sim.quot2, 0.001) nose.tools.assert_raises(Radau_Exception, self.sim._set_quot2, 'Test') nose.tools.assert_raises(Radau_Exception, self.sim._set_quot2, [-1.0]) @@ -1149,9 +1912,9 @@ def test_safe(self): This tests the functionality of the property safe. """ self.sim.safe = 0.01 - assert self.sim.safe == 0.01 + nose.tools.assert_equal(self.sim.safe, 0.01) self.sim.safe = 0.001 - assert self.sim.safe == 0.001 + nose.tools.assert_equal(self.sim.safe, 0.001) nose.tools.assert_raises(Radau_Exception, self.sim._set_safe, 'Test') nose.tools.assert_raises(Radau_Exception, self.sim._set_safe, [-1.0]) @@ -1162,9 +1925,9 @@ def test_thet(self): This tests the functionality of the property thet. """ self.sim.thet = 0.01 - assert self.sim.thet == 0.01 + nose.tools.assert_equal(self.sim.thet, 0.01) self.sim.thet = 0.001 - assert self.sim.thet == 0.001 + nose.tools.assert_equal(self.sim.thet, 0.001) nose.tools.assert_raises(Radau_Exception, self.sim._set_thet, 'Test') nose.tools.assert_raises(Radau_Exception, self.sim._set_thet, [-1.0]) @@ -1175,11 +1938,26 @@ def test_usejac(self): This tests the functionality of the property usejac. """ self.sim.usejac = True - assert self.sim.usejac == True + nose.tools.assert_true(self.sim.usejac) self.sim.usejac = False - assert self.sim.usejac == False + nose.tools.assert_false(self.sim.usejac) self.sim.usejac = 1 - assert self.sim.usejac == True + nose.tools.assert_true(self.sim.usejac) self.sim.usejac = [] - assert self.sim.usejac == False + nose.tools.assert_false(self.sim.usejac) + @testattr(stddist = True) + def test_solver(self): + """ + This tests the functionality of the property solver. + """ + self.sim.solver = 'f' + nose.tools.assert_equal(self.sim.solver, 'f') + self.sim.solver = 'c' + nose.tools.assert_equal(self.sim.solver, 'c') + self.sim.solver = 'F' + nose.tools.assert_equal(self.sim.solver, 'f') + self.sim.solver = 'C' + nose.tools.assert_equal(self.sim.solver, 'c') + nose.tools.assert_raises(Radau_Exception, self.sim._set_solver, 'Python') + nose.tools.assert_raises(Radau_Exception, self.sim._set_solver, True) diff --git a/tests/solvers/test_rosenbrock.py b/tests/solvers/test_rosenbrock.py index a2035e07..4b17778b 100644 --- a/tests/solvers/test_rosenbrock.py +++ b/tests/solvers/test_rosenbrock.py @@ -69,12 +69,12 @@ def test_nbr_fcn_evals_due_to_jac(self): sim.usejac = False sim.simulate(1) - assert sim.statistics["nfcnjacs"] > 0 + nose.tools.assert_greater(sim.statistics["nfcnjacs"], 0) sim = RodasODE(self.mod) sim.simulate(1) - assert sim.statistics["nfcnjacs"] == 0 + nose.tools.assert_equal(sim.statistics["nfcnjacs"], 0) @testattr(stddist = True) def test_usejac_csc_matrix(self): @@ -84,6 +84,6 @@ def test_usejac_csc_matrix(self): sim.simulate(2.) #Simulate 2 seconds - assert sim.statistics["nfcnjacs"] == 0 + nose.tools.assert_equal(sim.statistics["nfcnjacs"], 0) nose.tools.assert_almost_equal(sim.y_sol[-1][0], 1.7061680350, 4) diff --git a/tests/solvers/test_rungekutta.py b/tests/solvers/test_rungekutta.py index 45649bea..1ab00742 100644 --- a/tests/solvers/test_rungekutta.py +++ b/tests/solvers/test_rungekutta.py @@ -67,8 +67,8 @@ def handle_event(solver, event_info): solver.y+= 1.0 global tnext nose.tools.assert_almost_equal(solver.t, tnext) - assert event_info[0] == [] - assert event_info[1] == True + nose.tools.assert_equal(event_info[0], []) + nose.tools.assert_true(event_info[1]) exp_mod = Explicit_Problem(f,0.0) exp_mod.time_events = time_events @@ -78,7 +78,7 @@ def handle_event(solver, event_info): exp_sim = Dopri5(exp_mod) exp_sim(5.,100) - assert nevent == 5 + nose.tools.assert_equal(nevent, 5) def test_switches(self): """ @@ -96,9 +96,9 @@ def handle_event(solver, event_info): mod.handle_event = handle_event sim = Dopri5(mod) - assert sim.sw[0] == True + nose.tools.assert_true(sim.sw[0]) sim.simulate(3) - assert sim.sw[0] == False + nose.tools.assert_false(sim.sw[0]) class Test_RungeKutta34: @@ -159,8 +159,8 @@ def handle_event(solver, event_info): solver.y+= 1.0 global tnext nose.tools.assert_almost_equal(solver.t, tnext) - assert event_info[0] == [] - assert event_info[1] == True + nose.tools.assert_equal(event_info[0], []) + nose.tools.assert_true(event_info[1]) exp_mod = Explicit_Problem(f,0.0) exp_mod.time_events = time_events @@ -170,7 +170,7 @@ def handle_event(solver, event_info): exp_sim = RungeKutta34(exp_mod) exp_sim(5.,100) - assert nevent == 5 + nose.tools.assert_equal(nevent, 5) @testattr(stddist = True) def test_tolerance(self): @@ -182,12 +182,12 @@ def test_tolerance(self): nose.tools.assert_raises(Explicit_ODE_Exception, self.simulator._set_rtol, -1) self.simulator.rtol = 1.0 - assert self.simulator._get_rtol() == 1.0 + nose.tools.assert_equal(self.simulator._get_rtol(), 1.0) self.simulator.rtol = 1 - assert self.simulator._get_rtol() == 1 + nose.tools.assert_equal(self.simulator._get_rtol(), 1) self.simulator.atol = 1.0 - assert self.simulator.atol == 1.0 + nose.tools.assert_equal(self.simulator.atol, 1.0) nose.tools.assert_raises(Explicit_ODE_Exception, self.simulator._set_atol, [1.0,1.0]) @@ -209,9 +209,9 @@ def handle_event(solver, event_info): mod.handle_event = handle_event sim = RungeKutta34(mod) - assert sim.sw[0] == True + nose.tools.assert_true(sim.sw[0]) sim.simulate(3) - assert sim.sw[0] == False + nose.tools.assert_false(sim.sw[0]) class Test_RungeKutta4: @@ -249,8 +249,8 @@ def handle_event(solver, event_info): solver.y+= 1.0 global tnext nose.tools.assert_almost_equal(solver.t, tnext) - assert event_info[0] == [] - assert event_info[1] == True + nose.tools.assert_equal(event_info[0], []) + nose.tools.assert_true(event_info[1]) exp_mod = Explicit_Problem(f,0.0) exp_mod.time_events = time_events @@ -260,7 +260,7 @@ def handle_event(solver, event_info): exp_sim = RungeKutta4(exp_mod) exp_sim(5.,100) - assert nevent == 5 + nose.tools.assert_equal(nevent, 5) @testattr(stddist = True) def test_integrate(self): diff --git a/tests/solvers/test_sundials.py b/tests/solvers/test_sundials.py index e8392de6..d6a4841f 100644 --- a/tests/solvers/test_sundials.py +++ b/tests/solvers/test_sundials.py @@ -138,14 +138,14 @@ def f(t, y): sim.backward = True t, y = sim.simulate(0, ncp_list=np.arange(1, 10)) - assert np.all(t == np.arange(0,11)[::-1]) + nose.tools.assert_true(np.all(t == np.arange(0,11)[::-1])) mod = Explicit_Problem(f, y0=[1, 0], t0=10) sim = CVode(mod) sim.backward = True t, y = sim.simulate(0, ncp_list=np.arange(1, 10)[::-1]) - assert np.all(t == np.arange(0,11)[::-1]) + nose.tools.assert_true(np.all(t == np.arange(0,11)[::-1])) @testattr(stddist = True) def test_event_localizer(self): @@ -171,7 +171,7 @@ def test_get_error_weights(self): self.simulator.simulate(1.0) weights = self.simulator.get_error_weights() - assert weights[0] < 1e6 + nose.tools.assert_less(weights[0], 1e6) @testattr(stddist = True) def test_get_used_initial_step(self): @@ -186,7 +186,7 @@ def test_get_used_initial_step(self): self.simulator.simulate(1.0) step = self.simulator.get_used_initial_step() - assert N.abs(step-1e-8) < 1e-2 + nose.tools.assert_less(N.abs(step-1e-8), 1e-2) @testattr(stddist = True) @@ -196,7 +196,7 @@ def test_get_local_errors(self): self.simulator.simulate(1.0) err = self.simulator.get_local_errors() - assert err[0] < 1e-5 + nose.tools.assert_less(err[0], 1e-5) @testattr(stddist = True) def test_get_last_order(self): @@ -205,31 +205,31 @@ def test_get_last_order(self): self.simulator.simulate(1.0) qlast = self.simulator.get_last_order() - assert qlast == 4 + nose.tools.assert_equal(qlast, 4) @testattr(stddist = True) def test_max_convergence_failures(self): - assert self.simulator.maxncf == self.simulator.options["maxncf"] + nose.tools.assert_equal(self.simulator.maxncf, self.simulator.options["maxncf"]) self.simulator.maxncf = 15 - assert self.simulator.maxncf == 15 + nose.tools.assert_equal(self.simulator.maxncf, 15) nose.tools.assert_raises(AssimuloException, self.simulator._set_max_conv_fails, -1) @testattr(stddist = True) def test_max_error_tests_failures(self): - assert self.simulator.maxnef == self.simulator.options["maxnef"] + nose.tools.assert_equal(self.simulator.maxnef, self.simulator.options["maxnef"]) self.simulator.maxnef = 15 - assert self.simulator.maxnef == 15 - assert self.simulator.options["maxnef"] == 15 + nose.tools.assert_equal(self.simulator.maxnef, 15) + nose.tools.assert_equal(self.simulator.options["maxnef"], 15) nose.tools.assert_raises(AssimuloException, self.simulator._set_max_err_fails, -1) @testattr(stddist = True) def test_max_nonlinear_iterations(self): - assert self.simulator.maxcor == self.simulator.options["maxcor"] + nose.tools.assert_equal(self.simulator.maxcor, self.simulator.options["maxcor"]) self.simulator.maxcor = 15 - assert self.simulator.maxcor == 15 - assert self.simulator.options["maxcor"] == 15 + nose.tools.assert_equal(self.simulator.maxcor, 15) + nose.tools.assert_equal(self.simulator.options["maxcor"], 15) #nose.tools.assert_raises(AssimuloException, self.simulator._set_max_err_fails, -1) @@ -241,7 +241,7 @@ def test_get_current_order(self): self.simulator.simulate(1.0) qcur = self.simulator.get_current_order() - assert qcur == 4 + nose.tools.assert_equal(qcur, 4) @@ -250,15 +250,15 @@ def test_init(self): """ This tests the functionality of the method __init__. """ - #assert self.simulator.f == 'Test function' - assert self.simulator.y == 1.0 - assert self.simulator.discr == 'BDF' - assert self.simulator.iter == 'Newton' - assert self.simulator.maxord == 5 + # nose.tools.assert_equal(self.simulator.f, 'Test function') + nose.tools.assert_equal(self.simulator.y, 1.0) + nose.tools.assert_equal(self.simulator.discr, 'BDF') + nose.tools.assert_equal(self.simulator.iter, 'Newton') + nose.tools.assert_equal(self.simulator.maxord, 5) self.simulator.discr = 'Adams' - assert self.simulator.discr == 'Adams' - assert self.simulator.maxord == 12 + nose.tools.assert_equal(self.simulator.discr, 'Adams') + nose.tools.assert_equal(self.simulator.maxord, 12) @testattr(stddist = True) def test_time_event(self): @@ -283,8 +283,8 @@ def handle_event(solver, event_info): solver.y+= 1.0 global tnext nose.tools.assert_almost_equal(solver.t, tnext) - assert event_info[0] == [] - assert event_info[1] == True + nose.tools.assert_equal(event_info[0], []) + nose.tools.assert_true(event_info[1]) exp_mod = Explicit_Problem(f,0.0) exp_mod.time_events = time_events @@ -294,7 +294,7 @@ def handle_event(solver, event_info): exp_sim = CVode(exp_mod) exp_sim(5.,100) - assert nevent == 5 + nose.tools.assert_equal(nevent, 5) @testattr(stddist = True) def test_clear_event_log(self): @@ -319,8 +319,8 @@ def handle_event(solver, event_info): solver.y+= 1.0 global tnext nose.tools.assert_almost_equal(solver.t, tnext) - assert event_info[0] == [] - assert event_info[1] == True + nose.tools.assert_equal(event_info[0], []) + nose.tools.assert_true(event_info[1]) exp_mod = Explicit_Problem(f,0.0) exp_mod.time_events = time_events @@ -331,16 +331,16 @@ def handle_event(solver, event_info): exp_sim.verbosity = 10 exp_sim(5.,100) - assert len(exp_sim.event_data) == 4 + nose.tools.assert_equal(len(exp_sim.event_data), 4) tnext = 0.0 nevent = 0 exp_sim.reset() - assert len(exp_sim.event_data) == 0 + nose.tools.assert_equal(len(exp_sim.event_data), 0) exp_sim(5.,100) - assert len(exp_sim.event_data) == 4 + nose.tools.assert_equal(len(exp_sim.event_data), 4) @testattr(stddist = True) def test_time_limit(self): @@ -369,9 +369,9 @@ def test_discr_method(self): nose.tools.assert_raises(Exception, self.simulator._set_discr_method, ['Test']) self.simulator.discr = 'BDF' - assert self.simulator.discr == 'BDF' + nose.tools.assert_equal(self.simulator.discr, 'BDF') self.simulator.discr = 'Adams' - assert self.simulator.discr == 'Adams' + nose.tools.assert_equal(self.simulator.discr, 'Adams') @testattr(stddist = True) def test_change_discr(self): @@ -386,20 +386,20 @@ def test_change_discr(self): exp_sim.iter = "FixedPoint" exp_sim.simulate(1) - assert exp_sim.statistics["njacs"] == 0 + nose.tools.assert_equal(exp_sim.statistics["njacs"], 0) exp_sim.iter = "Newton" exp_sim.simulate(2) - assert exp_sim.statistics["njacs"] > 0 + nose.tools.assert_greater(exp_sim.statistics["njacs"], 0) @testattr(stddist = True) def test_change_norm(self): - assert self.simulator.options["norm"] == "WRMS" + nose.tools.assert_equal(self.simulator.options["norm"], "WRMS") self.simulator.norm = 'WRMS' - assert self.simulator.norm == 'WRMS' + nose.tools.assert_equal(self.simulator.norm, 'WRMS') self.simulator.norm = 'EUCLIDEAN' - assert self.simulator.options["norm"] == "EUCLIDEAN" - assert self.simulator.norm == 'EUCLIDEAN' + nose.tools.assert_equal(self.simulator.options["norm"], "EUCLIDEAN") + nose.tools.assert_equal(self.simulator.norm, 'EUCLIDEAN') f = lambda t,y: N.array([1.0]) y0 = 4.0 #Initial conditions @@ -432,7 +432,7 @@ def test_usejac(self): exp_sim.iter='Newton' exp_sim.simulate(5.,100) - assert exp_sim.statistics["nfcnjacs"] == 0 + nose.tools.assert_equal(exp_sim.statistics["nfcnjacs"], 0) nose.tools.assert_almost_equal(exp_sim.y_sol[-1][0], -121.75000143, 4) exp_sim.reset() @@ -440,7 +440,7 @@ def test_usejac(self): exp_sim.simulate(5.,100) nose.tools.assert_almost_equal(exp_sim.y_sol[-1][0], -121.75000143, 4) - assert exp_sim.statistics["nfcnjacs"] > 0 + nose.tools.assert_greater(exp_sim.statistics["nfcnjacs"], 0) @testattr(stddist = True) def test_usejac_csc_matrix(self): @@ -458,7 +458,7 @@ def test_usejac_csc_matrix(self): exp_sim.iter='Newton' exp_sim.simulate(5.,100) - assert exp_sim.statistics["nfcnjacs"] == 0 + nose.tools.assert_equal(exp_sim.statistics["nfcnjacs"], 0) nose.tools.assert_almost_equal(exp_sim.y_sol[-1][0], -121.75000143, 4) exp_sim.reset() @@ -466,7 +466,7 @@ def test_usejac_csc_matrix(self): exp_sim.simulate(5.,100) nose.tools.assert_almost_equal(exp_sim.y_sol[-1][0], -121.75000143, 4) - assert exp_sim.statistics["nfcnjacs"] > 0 + nose.tools.assert_greater(exp_sim.statistics["nfcnjacs"], 0) @testattr(stddist = True) def test_switches(self): @@ -485,9 +485,9 @@ def handle_event(solver, event_info): mod.handle_event = handle_event sim = CVode(mod) - assert sim.sw[0] == True + nose.tools.assert_true(sim.sw[0]) sim.simulate(3) - assert sim.sw[0] == False + nose.tools.assert_false(sim.sw[0]) @testattr(stddist = True) def test_iter_method(self): @@ -503,9 +503,9 @@ def test_iter_method(self): nose.tools.assert_raises(Exception, self.simulator._set_iter_method, 11.1) self.simulator.iter = 'Newton' - assert self.simulator.iter == 'Newton' + nose.tools.assert_equal(self.simulator.iter, 'Newton') self.simulator.iter = 'FixedPoint' - assert self.simulator.iter == 'FixedPoint' + nose.tools.assert_equal(self.simulator.iter, 'FixedPoint') @testattr(stddist = True) def test_initial_step(self): @@ -516,11 +516,11 @@ def test_initial_step(self): nose.tools.assert_raises(Exception, self.simulator._set_initial_step, 'Test') nose.tools.assert_raises(Exception, self.simulator._set_initial_step, ['Test']) - assert self.simulator.inith == 0.0 + nose.tools.assert_equal(self.simulator.inith, 0.0) self.simulator.inith = 10.0 - assert self.simulator.inith == 10.0 + nose.tools.assert_equal(self.simulator.inith, 10.0) self.simulator.inith = 1 - assert self.simulator.inith == 1.0 + nose.tools.assert_equal(self.simulator.inith, 1.0) @testattr(stddist = True) def test_interpolate(self): @@ -558,7 +558,7 @@ def test_handle_result(self): """ f = lambda t,x: x**0.25 def handle_result(solver,t,y): - assert solver.t == t + nose.tools.assert_equal(solver.t, t) prob = Explicit_Problem(f, [1.0]) prob.handle_result = handle_result @@ -578,11 +578,11 @@ def test_max_order(self): nose.tools.assert_raises(Exception, self.simulator._set_max_ord, [1,1]) self.simulator.maxord = -1 - assert self.simulator.maxord == 1 + nose.tools.assert_equal(self.simulator.maxord, 1) self.simulator.maxord = 2 - assert self.simulator.maxord == 2 + nose.tools.assert_equal(self.simulator.maxord, 2) self.simulator.maxord = 13 - assert self.simulator.maxord == 12 + nose.tools.assert_equal(self.simulator.maxord, 12) self.simulator.discr='BDF' @@ -590,11 +590,11 @@ def test_max_order(self): nose.tools.assert_raises(Exception, self.simulator._set_max_ord, [1,1]) self.simulator.maxord = -1 - assert self.simulator.maxord == 1 + nose.tools.assert_equal(self.simulator.maxord, 1) self.simulator.maxord = 2 - assert self.simulator.maxord == 2 + nose.tools.assert_equal(self.simulator.maxord, 2) self.simulator.maxord = 6 - assert self.simulator.maxord == 5 + nose.tools.assert_equal(self.simulator.maxord, 5) @testattr(stddist = True) def test_spgmr(self): @@ -663,28 +663,28 @@ def test_max_order_discr(self): """ self.simulator.discr = "Adams" self.simulator.maxord = 7 - assert self.simulator.maxord == 7 + nose.tools.assert_equal(self.simulator.maxord, 7) self.simulator.discr = 'Adams' - assert self.simulator.maxord == 12 + nose.tools.assert_equal(self.simulator.maxord, 12) self.simulator.discr = 'BDF' - assert self.simulator.maxord == 5 + nose.tools.assert_equal(self.simulator.maxord, 5) self.simulator.discr = 'Adams' - assert self.simulator.maxord == 12 + nose.tools.assert_equal(self.simulator.maxord, 12) self.simulator.maxord = 4 self.simulator.discr = 'BDF' - assert self.simulator.maxord == 5 + nose.tools.assert_equal(self.simulator.maxord, 5) self.simulator.discr = 'Adams' - assert self.simulator.maxord == 12 + nose.tools.assert_equal(self.simulator.maxord, 12) @testattr(stddist = True) def test_pretype(self): """ This tests the precondition option. """ - assert self.simulator.precond == 'PREC_NONE' + nose.tools.assert_equal(self.simulator.precond, 'PREC_NONE') self.simulator.precond = 'prec_none' - assert self.simulator.precond == 'PREC_NONE' + nose.tools.assert_equal(self.simulator.precond, 'PREC_NONE') nose.tools.assert_raises(Exception, self.simulator._set_pre_cond, -1.0) nose.tools.assert_raises(Exception, self.simulator._set_pre_cond, 'PREC_BOTH1') @@ -694,31 +694,31 @@ def test_maxkrylov(self): """ This test the maximum number of krylov subspaces. """ - assert self.simulator.maxkrylov == 5 + nose.tools.assert_equal(self.simulator.maxkrylov, 5) self.simulator.maxkrylov = 3 - assert self.simulator.maxkrylov == 3 + nose.tools.assert_equal(self.simulator.maxkrylov, 3) self.simulator.maxkrylov = 4.5 - assert self.simulator.maxkrylov == 4 + nose.tools.assert_equal(self.simulator.maxkrylov, 4) nose.tools.assert_raises(Exception, self.simulator._set_max_krylov, 'Test') @testattr(stddist = True) def test_stablimit(self): - assert self.simulator.stablimit == False + nose.tools.assert_false(self.simulator.stablimit) self.simulator.stablimit = True - assert self.simulator.stablimit == True - assert self.simulator.options["stablimit"] == True + nose.tools.assert_true(self.simulator.stablimit) + nose.tools.assert_true(self.simulator.options["stablimit"]) @testattr(stddist = True) def test_linearsolver(self): """ This test the choice of the linear solver. """ - assert self.simulator.linear_solver == 'DENSE' + nose.tools.assert_equal(self.simulator.linear_solver, 'DENSE') self.simulator.linear_solver = 'dense' - assert self.simulator.linear_solver == 'DENSE' + nose.tools.assert_equal(self.simulator.linear_solver, 'DENSE') self.simulator.linear_solver = 'spgmr' - assert self.simulator.linear_solver == 'SPGMR' + nose.tools.assert_equal(self.simulator.linear_solver, 'SPGMR') nose.tools.assert_raises(Exception, self.simulator._set_linear_solver, 'Test') @@ -761,14 +761,14 @@ def completed_step(solver): sim = CVode(mod) sim.simulate(2., 100) - assert len(sim.t_sol) == 101 - assert nsteps == sim.statistics["nsteps"] + nose.tools.assert_equal(len(sim.t_sol), 101) + nose.tools.assert_equal(nsteps, sim.statistics["nsteps"]) sim = CVode(mod) nsteps = 0 sim.simulate(2.) - assert len(sim.t_sol) == sim.statistics["nsteps"]+1 - assert nsteps == sim.statistics["nsteps"] + nose.tools.assert_equal(len(sim.t_sol), sim.statistics["nsteps"]+1) + nose.tools.assert_equal(nsteps, sim.statistics["nsteps"]) class Test_IDA: @@ -807,7 +807,7 @@ def test_simulate_explicit(self): problem = Explicit_Problem(f,y0) simulator = IDA(problem) - assert simulator.yd0[0] == -simulator.y0[0] + nose.tools.assert_equal(simulator.yd0[0], -simulator.y0[0]) t,y = simulator.simulate(1.0) @@ -818,11 +818,11 @@ def test_init(self): """ This tests the functionality of the method __init__. """ - assert self.simulator.suppress_alg == False - assert self.simulator.algvar[0] == 1.0 - assert self.simulator.sw == None - assert self.simulator.maxsteps == 10000 - assert self.simulator.y[0] == 1.0 + nose.tools.assert_false(self.simulator.suppress_alg) + nose.tools.assert_equal(self.simulator.algvar[0], 1.0) + nose.tools.assert_equal(self.simulator.sw, None) + nose.tools.assert_equal(self.simulator.maxsteps, 10000) + nose.tools.assert_equal(self.simulator.y[0], 1.0) @testattr(stddist = True) def test_interpolate(self): @@ -848,7 +848,7 @@ def test_handle_result(self): """ f = lambda t,x,xd: x**0.25-xd def handle_result(solver, t ,y, yd): - assert solver.t == t + nose.tools.assert_equal(solver.t, t) prob = Implicit_Problem(f, [1.0],[1.0]) prob.handle_result = handle_result @@ -869,11 +869,11 @@ def test_max_order(self): self.simulator.maxord = -1 - assert self.simulator.maxord == 1 + nose.tools.assert_equal(self.simulator.maxord, 1) self.simulator.maxord = 2 - assert self.simulator.maxord == 2 + nose.tools.assert_equal(self.simulator.maxord, 2) self.simulator.maxord = 6 - assert self.simulator.maxord == 5 + nose.tools.assert_equal(self.simulator.maxord, 5) @testattr(stddist = True) def test_tout1(self): @@ -884,22 +884,22 @@ def test_tout1(self): nose.tools.assert_raises(Exception, self.simulator._set_tout1, [1,1]) nose.tools.assert_raises(Exception, self.simulator._set_tout1, 'Test') - assert self.simulator.tout1 == 0.0001 + nose.tools.assert_equal(self.simulator.tout1, 0.0001) self.simulator.tout1 = -0.001 - assert self.simulator.tout1 == -0.001 + nose.tools.assert_equal(self.simulator.tout1, -0.001) self.simulator.tout1 = 1 - assert self.simulator.tout1 == 1.0 + nose.tools.assert_equal(self.simulator.tout1, 1.0) @testattr(stddist = True) def test_lsoff(self): """ This tests the functionality of the property lsoff. """ - assert self.simulator.lsoff == False + nose.tools.assert_false(self.simulator.lsoff) self.simulator.lsoff = True - assert self.simulator.lsoff == True + nose.tools.assert_true(self.simulator.lsoff) self.simulator.lsoff = False - assert self.simulator.lsoff == False + nose.tools.assert_false(self.simulator.lsoff) @testattr(stddist = True) def test_initstep(self): @@ -1001,14 +1001,14 @@ def handle_event(solver, event_info): sim = IDA(mod) sim.verbosity = 10 - assert len(sim.event_data) == 0 + nose.tools.assert_equal(len(sim.event_data), 0) sim.simulate(5.0) - assert len(sim.event_data) > 0 + nose.tools.assert_greater(len(sim.event_data), 0) sim.reset() - assert len(sim.event_data) == 0 + nose.tools.assert_equal(len(sim.event_data), 0) sim.simulate(5.0) - assert len(sim.event_data) > 0 + nose.tools.assert_greater(len(sim.event_data), 0) @testattr(stddist = True) def test_usejac(self): @@ -1025,7 +1025,7 @@ def test_usejac(self): imp_sim.simulate(3,100) - assert imp_sim.statistics["nfcnjacs"] == 0 + nose.tools.assert_equal(imp_sim.statistics["nfcnjacs"], 0) nose.tools.assert_almost_equal(imp_sim.y_sol[-1][0], 45.1900000, 4) imp_sim.reset() @@ -1033,7 +1033,7 @@ def test_usejac(self): imp_sim.simulate(3.,100) nose.tools.assert_almost_equal(imp_sim.y_sol[-1][0], 45.1900000, 4) - assert imp_sim.statistics["nfcnjacs"] > 0 + nose.tools.assert_greater(imp_sim.statistics["nfcnjacs"], 0) @testattr(stddist = True) def test_terminate_simulation(self): @@ -1108,8 +1108,8 @@ def handle_event(solver, event_info): solver.y+= 1.0 global tnext nose.tools.assert_almost_equal(solver.t, tnext) - assert event_info[0] == [] - assert event_info[1] == True + nose.tools.assert_equal(event_info[0], []) + nose.tools.assert_true(event_info[1]) exp_mod = Implicit_Problem(f,0.0,0.0) exp_mod.time_events = time_events @@ -1119,7 +1119,7 @@ def handle_event(solver, event_info): exp_sim = IDA(exp_mod) exp_sim(5.,100) - assert nevent == 5 + nose.tools.assert_equal(nevent, 5) @testattr(stddist = True) def test_suppress_alg(self): @@ -1127,9 +1127,9 @@ def test_suppress_alg(self): This tests the functionality of the property suppress_alg. """ self.simulator.suppress_alg = True - assert self.simulator.suppress_alg == True + nose.tools.assert_true(self.simulator.suppress_alg) self.simulator.suppress_alg = False - assert self.simulator.suppress_alg == False + nose.tools.assert_false(self.simulator.suppress_alg) @testattr(stddist = True) def test_make_consistency(self): @@ -1172,9 +1172,9 @@ def handle_event(solver, event_info): mod.handle_event = handle_event sim = IDA(mod) - assert sim.sw[0] == True + nose.tools.assert_true(sim.sw[0]) sim.simulate(3) - assert sim.sw[0] == False + nose.tools.assert_false(sim.sw[0]) @testattr(stddist = True) def test_completed_step(self): @@ -1200,14 +1200,14 @@ def completed_step(solver): sim = IDA(mod) sim.simulate(2., 100) - assert len(sim.t_sol) == 101 - assert nsteps == sim.statistics["nsteps"] + nose.tools.assert_equal(len(sim.t_sol), 101) + nose.tools.assert_equal(nsteps, sim.statistics["nsteps"]) sim = IDA(mod) nsteps = 0 sim.simulate(2.) - assert len(sim.t_sol) == sim.statistics["nsteps"] + 1 - assert nsteps == sim.statistics["nsteps"] + nose.tools.assert_equal(len(sim.t_sol), sim.statistics["nsteps"] + 1) + nose.tools.assert_equal(nsteps, sim.statistics["nsteps"]) @@ -1254,8 +1254,8 @@ def test_atol(self): """ This tests the functionality of the property atol. """ - assert self.simulators[1].atol == 1.0e-6 - assert self.simulators[0].atol == 1.0e-6 + nose.tools.assert_equal(self.simulators[1].atol, 1.0e-6) + nose.tools.assert_equal(self.simulators[0].atol, 1.0e-6) for i in range(len(self.simulators)): nose.tools.assert_raises(Exception, self.simulators[i]._set_atol, -1.0) @@ -1263,26 +1263,26 @@ def test_atol(self): nose.tools.assert_raises(Exception, self.simulators[i]._set_atol, "Test") self.simulators[i].atol = 1.0e-5 - assert self.simulators[i].atol == 1.0e-5 + nose.tools.assert_equal(self.simulators[i].atol, 1.0e-5) self.simulators[i].atol = 1.0 - assert self.simulators[i].atol == 1.0 + nose.tools.assert_equal(self.simulators[i].atol, 1.0) self.simulators[i].atol = 1 - assert self.simulators[i].atol == 1.0 + nose.tools.assert_equal(self.simulators[i].atol, 1.0) self.simulators[i].atol = 1001.0 - assert self.simulators[i].atol == 1001.0 + nose.tools.assert_equal(self.simulators[i].atol, 1001.0) self.simulators[i].atol = [N.array([1e-5])] - assert len(self.simulators[i].atol.shape) == 1 - assert self.simulators[i].atol == 1e-5 + nose.tools.assert_equal(len(self.simulators[i].atol.shape), 1) + nose.tools.assert_equal(self.simulators[i].atol, 1e-5) """ self.simulators[i].Integrator.dim = 3 nose.tools.assert_raises(Exception, self.simulators[i]._set_atol, [1.0, 1.0]) nose.tools.assert_raises(Exception, self.simulators[i]._set_atol, [1.0, 1.0, -1.0]) self.simulators[i].atol = [1.0, 1.0, 1.0] - assert self.simulators[i].atol == [1.0, 1.0, 1.0] + nose.tools.assert_equal(self.simulators[i].atol, [1.0, 1.0, 1.0]) self.simulators[i].atol = N.array([1.0, 1.0, 1.0]) - assert self.simulators[i].atol[0] == 1.0 + nose.tools.assert_equal(self.simulators[i].atol[0], 1.0) self.simulators[i].atol = N.array([1, 5, 1.0]) - assert self.simulators[i].atol[0] == 1.0 + nose.tools.assert_equal(self.simulators[i].atol[0], 1.0) """ @@ -1297,13 +1297,13 @@ def test_rtol(self): nose.tools.assert_raises(Exception, self.simulators[i]._set_rtol, "Test") self.simulators[i].rtol = 1.0e-5 - assert self.simulators[i].rtol == 1.0e-5 + nose.tools.assert_equal(self.simulators[i].rtol, 1.0e-5) self.simulators[i].rtol = 1.0 - assert self.simulators[i].rtol == 1.0 + nose.tools.assert_equal(self.simulators[i].rtol, 1.0) self.simulators[i].rtol = 1001.0 - assert self.simulators[i].rtol == 1001.0 + nose.tools.assert_equal(self.simulators[i].rtol, 1001.0) self.simulators[i].rtol = 1001 - assert self.simulators[i].rtol == 1001.0 + nose.tools.assert_equal(self.simulators[i].rtol, 1001.0) @testattr(stddist = True) def test_maxh(self): @@ -1315,11 +1315,11 @@ def test_maxh(self): nose.tools.assert_raises(Exception, self.simulators[i]._set_max_h, "Test") self.simulators[i].maxh = 1.0e-5 - assert self.simulators[i].maxh == 1.0e-5 + nose.tools.assert_equal(self.simulators[i].maxh, 1.0e-5) self.simulators[i].maxh = 1.0 - assert self.simulators[i].maxh == 1.0 + nose.tools.assert_equal(self.simulators[i].maxh, 1.0) self.simulators[i].maxh = 1001.0 - assert self.simulators[i].maxh == 1001.0 + nose.tools.assert_equal(self.simulators[i].maxh, 1001.0) @testattr(stddist = True) def test_dqtype(self): @@ -1327,17 +1327,17 @@ def test_dqtype(self): Tests the property of dqtype. """ - assert self.sim.dqtype == 'CENTERED' #Test the default value. + nose.tools.assert_equal(self.sim.dqtype, 'CENTERED') #Test the default value. self.sim.dqtype = 'FORWARD' - assert self.sim.dqtype == 'FORWARD' + nose.tools.assert_equal(self.sim.dqtype, 'FORWARD') self.sim.dqtype = 'CENTERED' - assert self.sim.dqtype == 'CENTERED' + nose.tools.assert_equal(self.sim.dqtype, 'CENTERED') self.sim.dqtype = 'forward' - assert self.sim.dqtype == 'FORWARD' + nose.tools.assert_equal(self.sim.dqtype, 'FORWARD') self.sim.dqtype = 'centered' - assert self.sim.dqtype == 'CENTERED' + nose.tools.assert_equal(self.sim.dqtype, 'CENTERED') nose.tools.assert_raises(Exception,self.sim._set_dqtype, 1) nose.tools.assert_raises(Exception,self.sim._set_dqtype, 'IDA_CE') @@ -1349,12 +1349,12 @@ def test_dqrhomax(self): """ Tests the property of DQrhomax. """ - assert self.sim.dqrhomax == 0.0 #Test the default value. + nose.tools.assert_equal(self.sim.dqrhomax, 0.0) #Test the default value. self.sim.dqrhomax = 1.0 - assert self.sim.dqrhomax == 1.0 + nose.tools.assert_equal(self.sim.dqrhomax, 1.0) self.sim.dqrhomax = 10 - assert self.sim.dqrhomax == 10 + nose.tools.assert_equal(self.sim.dqrhomax, 10) nose.tools.assert_raises(Exception,self.sim._set_dqrhomax, -1) nose.tools.assert_raises(Exception,self.sim._set_dqrhomax, 'str') @@ -1366,30 +1366,30 @@ def test_usesens(self): """ Tests the property of usesens. """ - assert self.sim.usesens == True #Test the default value. + nose.tools.assert_true(self.sim.usesens)#Test the default value. self.sim.usesens = False - assert self.sim.usesens == False + nose.tools.assert_false(self.sim.usesens) self.sim.usesens = 0 - assert self.sim.usesens == False + nose.tools.assert_false(self.sim.usesens) self.sim.usesens = 1 - assert self.sim.usesens == True + nose.tools.assert_true(self.sim.usesens) @testattr(stddist = True) def test_sensmethod(self): """ Tests the property of sensmethod. """ - assert self.sim.sensmethod == 'STAGGERED' #Test the default value + nose.tools.assert_equal(self.sim.sensmethod, 'STAGGERED') #Test the default value self.sim.sensmethod = 'SIMULTANEOUS' - assert self.sim.sensmethod == 'SIMULTANEOUS' + nose.tools.assert_equal(self.sim.sensmethod, 'SIMULTANEOUS') self.sim.sensmethod = 'STAGGERED' - assert self.sim.sensmethod == 'STAGGERED' + nose.tools.assert_equal(self.sim.sensmethod, 'STAGGERED') self.sim.sensmethod = 'simultaneous' - assert self.sim.sensmethod == 'SIMULTANEOUS' + nose.tools.assert_equal(self.sim.sensmethod, 'SIMULTANEOUS') self.sim.sensmethod = 'staggered' - assert self.sim.sensmethod == 'STAGGERED' + nose.tools.assert_equal(self.sim.sensmethod, 'STAGGERED') nose.tools.assert_raises(Exception,self.sim._set_sensitivity_method, 1) nose.tools.assert_raises(Exception,self.sim._set_sensitivity_method, 'IDA_CE') @@ -1401,24 +1401,24 @@ def test_suppress_sens(self): """ Tests the property of suppress_sens. """ - assert self.sim.suppress_sens == False + nose.tools.assert_false(self.sim.suppress_sens) self.sim.suppress_sens = False - assert self.sim.suppress_sens == False + nose.tools.assert_false(self.sim.suppress_sens) self.sim.suppress_sens = 0 - assert self.sim.suppress_sens == False + nose.tools.assert_false(self.sim.suppress_sens) self.sim.suppress_sens = 1 - assert self.sim.suppress_sens == True + nose.tools.assert_true(self.sim.suppress_sens) @testattr(stddist = True) def test_maxsensiter(self): """ Tests the property of maxsensiter. """ - assert self.sim.maxcorS == 3 #Test the default value + nose.tools.assert_equal(self.sim.maxcorS, 3) #Test the default value self.sim.maxcorS = 1 - assert self.sim.maxcorS == 1 + nose.tools.assert_equal(self.sim.maxcorS, 1) self.sim.maxcorS = 10.5 - assert self.sim.maxcorS == 10 + nose.tools.assert_equal(self.sim.maxcorS, 10) #nose.tools.assert_raises(Exception, self.sim._set_max_cor_S, 0) nose.tools.assert_raises(Exception, self.sim._set_max_cor_S, 'str') diff --git a/tests/test_examples.py b/tests/test_examples.py index efd76779..724382f3 100644 --- a/tests/test_examples.py +++ b/tests/test_examples.py @@ -1,223 +1,239 @@ -#!/usr/bin/env python -# -*- coding: utf-8 -*- - -# Copyright (C) 2010 Modelon AB -# -# This program is free software: you can redistribute it and/or modify -# it under the terms of the GNU Lesser General Public License as published by -# the Free Software Foundation, version 3 of the License. -# -# This program 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 Lesser General Public License for more details. -# -# You should have received a copy of the GNU Lesser General Public License -# along with this program. If not, see . - -import nose -from assimulo import testattr -from assimulo.exception import * -from assimulo.examples import * - -class Test_Examples: - - - @testattr(stddist = True) - def test_cvode_with_jac_sparse(self): - try: - cvode_with_jac_sparse.run_example(with_plots=False) - except AssimuloException: - pass #Handle the case when SuperLU is not installed - - @testattr(stddist = True) - def test_ida_with_user_defined_handle_result(self): - ida_with_user_defined_handle_result.run_example(with_plots=False) - - @testattr(stddist = True) - def test_radau5dae_time_events(self): - radau5dae_time_events.run_example(with_plots=False) - - @testattr(stddist = True) - def test_kinsol_basic(self): - kinsol_basic.run_example(with_plots=False) - - @testattr(stddist = True) - def test_kinsol_with_jac(self): - kinsol_with_jac.run_example(with_plots=False) - - @testattr(stddist = True) - def test_kinsol_ors(self): - kinsol_ors.run_example(with_plots=False) - - @testattr(stddist = True) - def test_cvode_with_preconditioning(self): - cvode_with_preconditioning.run_example(with_plots=False) - - @testattr(stddist = True) - def test_dasp3_basic(self): - print("Currently not running test_dasp3_basic. Numerically unstable problem.") - #dasp3_basic.run_example(with_plots=False) - - @testattr(stddist = True) - def test_cvode_gyro(self): - cvode_gyro.run_example(with_plots=False) - - @testattr(stddist = True) - def test_cvode_basic(self): - cvode_basic.run_example(with_plots=False) - - @testattr(stddist = True) - def test_cvode_with_disc(self): - cvode_with_disc.run_example(with_plots=False) - - @testattr(stddist = True) - def test_cvode_with_initial_sensitivity(self): - cvode_with_initial_sensitivity.run_example(with_plots=False) - - @testattr(stddist = True) - def test_cvode_with_jac(self): - cvode_with_jac.run_example(with_plots=False) - - @testattr(stddist = True) - def test_cvode_with_jac_spgmr(self): - cvode_with_jac_spgmr.run_example(with_plots=False) - - @testattr(stddist = True) - def test_ida_with_jac_spgmr(self): - ida_with_jac_spgmr.run_example(with_plots=False) - - @testattr(stddist = True) - def test_cvode_with_parameters(self): - cvode_with_parameters.run_example(with_plots=False) - - @testattr(stddist = True) - def test_cvode_with_parameters_fcn(self): - cvode_with_parameters_fcn.run_example(with_plots=False) - - @testattr(stddist = True) - def test_cvode_with_parameters_modified(self): - cvode_with_parameters_modified.run_example(with_plots=False) - - @testattr(stddist = True) - def test_euler_basic(self): - euler_basic.run_example(with_plots=False) - - @testattr(stddist = True) - def test_euler_with_disc(self): - euler_with_disc.run_example(with_plots=False) - - @testattr(stddist = True) - def test_rungekutta4_basic(self): - rungekutta4_basic.run_example(with_plots=False) - - @testattr(stddist = True) - def test_rungekutta34_basic(self): - rungekutta34_basic.run_example(with_plots=False) - - @testattr(stddist = True) - def test_rungekutta34_with_disc(self): - rungekutta34_with_disc.run_example(with_plots=False) - - @testattr(stddist = True) - def test_ida_with_disc(self): - ida_with_disc.run_example(with_plots=False) - - @testattr(stddist = True) - def test_ida_with_initial_sensitivity(self): - ida_with_initial_sensitivity.run_example(with_plots=False) - - @testattr(stddist = True) - def test_ida_with_jac(self): - ida_with_jac.run_example(with_plots=False) - - @testattr(stddist = True) - def test_ida_with_parameters(self): - ida_with_parameters.run_example(with_plots=False) - - @testattr(stddist = True) - def test_radau5ode_vanderpol(self): - radau5ode_vanderpol.run_example(with_plots=False) - - @testattr(stddist = True) - def test_radau5ode_with_disc(self): - radau5ode_with_disc.run_example(with_plots=False) - - @testattr(stddist = True) - def test_radau5dae_vanderpol(self): - radau5dae_vanderpol.run_example(with_plots=False) - - @testattr(stddist = True) - def test_dopri5_basic(self): - dopri5_basic.run_example(with_plots=False) - - @testattr(stddist = True) - def test_dopri5_with_disc(self): - dopri5_with_disc.run_example(with_plots=False) - - @testattr(stddist = True) - def test_rodasode_vanderpol(self): - rodasode_vanderpol.run_example(with_plots=False) - - @testattr(stddist = True) - def test_mech_system_pendulum1(self): - """ - This tests the class Mechanical_system together with ind1 and ida - """ - mech_system_pendulum.run_example('ind1',with_plots=False,with_test=True) - - @testattr(stddist = True) - def test_mech_system_pendulum2(self): - """ - This tests the class Mechanical_system together with ind2 and ida - """ - mech_system_pendulum.run_example('ind2',with_plots=False,with_test=True) - - @testattr(stddist = True) - def test_mech_system_pendulum3(self): - """ - This tests the class Mechanical_system together with ind3 and ida - """ - mech_system_pendulum.run_example('ind3',with_plots=False,with_test=True) - - @testattr(stddist = True) - def test_mech_system_pendulum_ggl2(self): - """ - This tests the class Mechanical_system together with ggl2 and ida - """ - mech_system_pendulum.run_example('ggl2',with_plots=False,with_test=True) - - @testattr(stddist = True) - def test_mech_system_pendulum_ovstab2(self): - """ - This tests the class Mechanical_system together with ovstab2 and odassl - """ - mech_system_pendulum.run_example('ovstab2',with_plots=False,with_test=True) - - @testattr(stddist = True) - def test_mech_system_pendulum_ovstab1(self): - """ - This tests the class Mechanical_system together with ovstab1 and odassl - """ - mech_system_pendulum.run_example('ovstab1',with_plots=False,with_test=True) - - - @testattr(stddist = True) - def test_lsodar_vanderpol(self): - lsodar_vanderpol.run_example(with_plots=False) - - @testattr(stddist = True) - def test_lsodar_with_disc(self): - lsodar_with_disc.run_example(with_plots=False) - - @testattr(stddist = True) - def test_euler_vanderpol(self): - euler_vanderpol.run_example(with_plots=False) - - @testattr(stddist = True) - def test_cvode_basic_backward(self): - cvode_basic_backward.run_example(with_plots=False) - - @testattr(stddist = True) - def test_ida_basic_backward(self): - ida_basic_backward.run_example(with_plots=False) +#!/usr/bin/env python +# -*- coding: utf-8 -*- + +# Copyright (C) 2010 Modelon AB +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU Lesser General Public License as published by +# the Free Software Foundation, version 3 of the License. +# +# This program 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 Lesser General Public License for more details. +# +# You should have received a copy of the GNU Lesser General Public License +# along with this program. If not, see . + +import nose +from assimulo import testattr +from assimulo.exception import * +from assimulo.examples import * + +class Test_Examples: + + + @testattr(stddist = True) + def test_cvode_with_jac_sparse(self): + try: + cvode_with_jac_sparse.run_example(with_plots=False) + except AssimuloException: + pass #Handle the case when SuperLU is not installed + + @testattr(stddist = True) + def test_ida_with_user_defined_handle_result(self): + ida_with_user_defined_handle_result.run_example(with_plots=False) + + @testattr(stddist = True) + def test_radau5dae_time_events_c(self): + radau5dae_time_events.run_example(with_plots=False,solver='c') + + @testattr(stddist = True) + def test_radau5dae_time_events_f(self): + radau5dae_time_events.run_example(with_plots=False,solver='f') + + @testattr(stddist = True) + def test_kinsol_basic(self): + kinsol_basic.run_example(with_plots=False) + + @testattr(stddist = True) + def test_kinsol_with_jac(self): + kinsol_with_jac.run_example(with_plots=False) + + @testattr(stddist = True) + def test_kinsol_ors(self): + kinsol_ors.run_example(with_plots=False) + + @testattr(stddist = True) + def test_cvode_with_preconditioning(self): + cvode_with_preconditioning.run_example(with_plots=False) + + @testattr(stddist = True) + def test_dasp3_basic(self): + print("Currently not running test_dasp3_basic. Numerically unstable problem.") + #dasp3_basic.run_example(with_plots=False) + + @testattr(stddist = True) + def test_cvode_gyro(self): + cvode_gyro.run_example(with_plots=False) + + @testattr(stddist = True) + def test_cvode_basic(self): + cvode_basic.run_example(with_plots=False) + + @testattr(stddist = True) + def test_cvode_with_disc(self): + cvode_with_disc.run_example(with_plots=False) + + @testattr(stddist = True) + def test_cvode_with_initial_sensitivity(self): + cvode_with_initial_sensitivity.run_example(with_plots=False) + + @testattr(stddist = True) + def test_cvode_with_jac(self): + cvode_with_jac.run_example(with_plots=False) + + @testattr(stddist = True) + def test_cvode_with_jac_spgmr(self): + cvode_with_jac_spgmr.run_example(with_plots=False) + + @testattr(stddist = True) + def test_ida_with_jac_spgmr(self): + ida_with_jac_spgmr.run_example(with_plots=False) + + @testattr(stddist = True) + def test_cvode_with_parameters(self): + cvode_with_parameters.run_example(with_plots=False) + + @testattr(stddist = True) + def test_cvode_with_parameters_fcn(self): + cvode_with_parameters_fcn.run_example(with_plots=False) + + @testattr(stddist = True) + def test_cvode_with_parameters_modified(self): + cvode_with_parameters_modified.run_example(with_plots=False) + + @testattr(stddist = True) + def test_euler_basic(self): + euler_basic.run_example(with_plots=False) + + @testattr(stddist = True) + def test_euler_with_disc(self): + euler_with_disc.run_example(with_plots=False) + + @testattr(stddist = True) + def test_rungekutta4_basic(self): + rungekutta4_basic.run_example(with_plots=False) + + @testattr(stddist = True) + def test_rungekutta34_basic(self): + rungekutta34_basic.run_example(with_plots=False) + + @testattr(stddist = True) + def test_rungekutta34_with_disc(self): + rungekutta34_with_disc.run_example(with_plots=False) + + @testattr(stddist = True) + def test_ida_with_disc(self): + ida_with_disc.run_example(with_plots=False) + + @testattr(stddist = True) + def test_ida_with_initial_sensitivity(self): + ida_with_initial_sensitivity.run_example(with_plots=False) + + @testattr(stddist = True) + def test_ida_with_jac(self): + ida_with_jac.run_example(with_plots=False) + + @testattr(stddist = True) + def test_ida_with_parameters(self): + ida_with_parameters.run_example(with_plots=False) + + @testattr(stddist = True) + def test_radau5ode_vanderpol_c(self): + radau5ode_vanderpol.run_example(with_plots=False,solver='c') + + @testattr(stddist = True) + def test_radau5ode_vanderpol_f(self): + radau5ode_vanderpol.run_example(with_plots=False,solver='f') + + @testattr(stddist = True) + def test_radau5ode_with_disc_c(self): + radau5ode_with_disc.run_example(with_plots=False,solver='c') + + @testattr(stddist = True) + def test_radau5ode_with_disc_f(self): + radau5ode_with_disc.run_example(with_plots=False,solver='c') + + @testattr(stddist = True) + def test_radau5dae_vanderpol_c(self): + radau5dae_vanderpol.run_example(with_plots=False,solver='c') + + @testattr(stddist = True) + def test_radau5dae_vanderpol_f(self): + radau5dae_vanderpol.run_example(with_plots=False,solver='f') + + @testattr(stddist = True) + def test_dopri5_basic(self): + dopri5_basic.run_example(with_plots=False) + + @testattr(stddist = True) + def test_dopri5_with_disc(self): + dopri5_with_disc.run_example(with_plots=False) + + @testattr(stddist = True) + def test_rodasode_vanderpol(self): + rodasode_vanderpol.run_example(with_plots=False) + + @testattr(stddist = True) + def test_mech_system_pendulum1(self): + """ + This tests the class Mechanical_system together with ind1 and ida + """ + mech_system_pendulum.run_example('ind1',with_plots=False,with_test=True) + + @testattr(stddist = True) + def test_mech_system_pendulum2(self): + """ + This tests the class Mechanical_system together with ind2 and ida + """ + mech_system_pendulum.run_example('ind2',with_plots=False,with_test=True) + + @testattr(stddist = True) + def test_mech_system_pendulum3(self): + """ + This tests the class Mechanical_system together with ind3 and ida + """ + mech_system_pendulum.run_example('ind3',with_plots=False,with_test=True) + + @testattr(stddist = True) + def test_mech_system_pendulum_ggl2(self): + """ + This tests the class Mechanical_system together with ggl2 and ida + """ + mech_system_pendulum.run_example('ggl2',with_plots=False,with_test=True) + + @testattr(stddist = True) + def test_mech_system_pendulum_ovstab2(self): + """ + This tests the class Mechanical_system together with ovstab2 and odassl + """ + mech_system_pendulum.run_example('ovstab2',with_plots=False,with_test=True) + + @testattr(stddist = True) + def test_mech_system_pendulum_ovstab1(self): + """ + This tests the class Mechanical_system together with ovstab1 and odassl + """ + mech_system_pendulum.run_example('ovstab1',with_plots=False,with_test=True) + + + @testattr(stddist = True) + def test_lsodar_vanderpol(self): + lsodar_vanderpol.run_example(with_plots=False) + + @testattr(stddist = True) + def test_lsodar_with_disc(self): + lsodar_with_disc.run_example(with_plots=False) + + @testattr(stddist = True) + def test_euler_vanderpol(self): + euler_vanderpol.run_example(with_plots=False) + + @testattr(stddist = True) + def test_cvode_basic_backward(self): + cvode_basic_backward.run_example(with_plots=False) + + @testattr(stddist = True) + def test_ida_basic_backward(self): + ida_basic_backward.run_example(with_plots=False) diff --git a/tests/test_explicit_ode.py b/tests/test_explicit_ode.py index 64042daa..69299ac0 100644 --- a/tests/test_explicit_ode.py +++ b/tests/test_explicit_ode.py @@ -31,16 +31,16 @@ def test_elapsed_step_time(self): prob = Explicit_Problem(rhs, 0.0) solv = Explicit_ODE(prob) - assert solv.get_elapsed_step_time() == -1.0 + nose.tools.assert_equal(solv.get_elapsed_step_time(), -1.0) @testattr(stddist = True) def test_problem_name_attribute(self): rhs = lambda t,y: y prob = Explicit_Problem(rhs, 0.0) - assert prob.name == "---" + nose.tools.assert_equal(prob.name, "---") prob = Explicit_Problem(rhs, 0.0, name="Test") - assert prob.name == "Test" + nose.tools.assert_equal(prob.name, "Test") @testattr(stddist = True) def test_re_init(self): @@ -50,10 +50,10 @@ def test_re_init(self): prob = Explicit_Problem(rhs, 0.0) solv = Explicit_ODE(prob) - assert solv.t == 0.0 - assert solv.y[0] == 0.0 + nose.tools.assert_equal(solv.t, 0.0) + nose.tools.assert_equal(solv.y[0], 0.0) solv.re_init(1.0, 2.0) - assert solv.t == 1.0 - assert solv.y[0] == 2.0 + nose.tools.assert_equal(solv.t, 1.0) + nose.tools.assert_equal(solv.y[0], 2.0) diff --git a/tests/test_implicit_ode.py b/tests/test_implicit_ode.py index c4ed8797..2e705096 100644 --- a/tests/test_implicit_ode.py +++ b/tests/test_implicit_ode.py @@ -29,17 +29,17 @@ def test_elapsed_step_time(self): prob = Implicit_Problem(res, 0.0, 0.0) solv = Implicit_ODE(prob) - - assert solv.get_elapsed_step_time() == -1.0 + + nose.tools.assert_equal(solv.get_elapsed_step_time(), -1.0) @testattr(stddist = True) def test_problem_name_attribute(self): res = lambda t,y,yd: y prob = Implicit_Problem(res, 0.0, 0.0) - assert prob.name == "---" + nose.tools.assert_equal(prob.name, "---") prob = Implicit_Problem(res, 0.0, 0.0, name="Test") - assert prob.name == "Test" + nose.tools.assert_equal(prob.name, "Test") @testattr(stddist = True) def test_re_init(self): @@ -49,12 +49,12 @@ def test_re_init(self): prob = Implicit_Problem(res, 0.0, 0.0) solv = Implicit_ODE(prob) - assert solv.t == 0.0 - assert solv.y[0] == 0.0 - assert solv.yd[0] == 0.0 + nose.tools.assert_equal(solv.t, 0.0) + nose.tools.assert_equal(solv.y[0], 0.0) + nose.tools.assert_equal(solv.yd[0], 0.0) solv.re_init(1.0, 2.0, 3.0) - assert solv.t == 1.0 - assert solv.y[0] == 2.0 - assert solv.yd[0] == 3.0 + nose.tools.assert_equal(solv.t, 1.0) + nose.tools.assert_equal(solv.y[0], 2.0) + nose.tools.assert_equal(solv.yd[0], 3.0) diff --git a/tests/test_ode.py b/tests/test_ode.py index 31e1e138..8bf31c43 100644 --- a/tests/test_ode.py +++ b/tests/test_ode.py @@ -32,8 +32,8 @@ def test_init(self): """ This tests the functionality of the method __init__. """ - assert self.simulator.verbosity == NORMAL - assert self.simulator.report_continuously == False + nose.tools.assert_equal(self.simulator.verbosity, NORMAL) + nose.tools.assert_false(self.simulator.report_continuously) @testattr(stddist = True) def test_verbosity(self): @@ -45,22 +45,22 @@ def test_verbosity(self): nose.tools.assert_raises(AssimuloException, self.simulator._set_verbosity, [1]) self.simulator.verbosity=1 - assert self.simulator.verbosity==1 - assert self.simulator.options["verbosity"] == 1 + nose.tools.assert_equal(self.simulator.verbosity, 1) + nose.tools.assert_equal(self.simulator.options["verbosity"], 1) self.simulator.verbosity=4 - assert self.simulator.verbosity==4 - assert self.simulator.options["verbosity"] == 4 + nose.tools.assert_equal(self.simulator.verbosity, 4) + nose.tools.assert_equal(self.simulator.options["verbosity"], 4) @testattr(stddist = True) def test_report_continuously(self): """ This tests the functionality of the property report_continuously. """ - assert self.simulator.report_continuously == False #Test the default value + nose.tools.assert_false(self.simulator.report_continuously) #Test the default value self.simulator.report_continuously = True - assert self.simulator.report_continuously == True - assert self.simulator.options["report_continuously"] == True + nose.tools.assert_true(self.simulator.report_continuously) + nose.tools.assert_true(self.simulator.options["report_continuously"]) def test_step_events_report_continuously(self): """ This test tests if report_continuously is set correctly, when step_events are present. @@ -70,5 +70,4 @@ def test_step_events_report_continuously(self): self.simulator.problem_info["step_events"] = True self.simulator.problem=self.problem self.simulator(10.,ncp=10) # output points and step events should set report_continuously to True - assert self.simulator.report_continuously == True - + nose.tools.assert_true(self.simulator.report_continuously) diff --git a/tests/test_solvers.py b/tests/test_solvers.py index d4a73174..799622c0 100644 --- a/tests/test_solvers.py +++ b/tests/test_solvers.py @@ -40,16 +40,36 @@ def estate_events(t, y, sw): class Test_Solvers: @testattr(stddist = True) - def test_radau5dae_state_events(self): + def test_radau5dae_state_events_c(self): solver = Radau5DAE(problem) + solver.solver = 'c' t,y,yd = solver.simulate(2,33) nose.tools.assert_almost_equal(float(y[-1]), 0.135, 3) + + @testattr(stddist = True) + def test_radau5dae_state_events_f(self): + solver = Radau5DAE(problem) + solver.solver = 'f' + + t,y,yd = solver.simulate(2,33) + + nose.tools.assert_almost_equal(float(y[-1]), 0.135, 3) + + @testattr(stddist = True) + def test_radau5ode_state_events_c(self): + solver = Radau5ODE(eproblem) + solver.solver = 'c' + + t,y = solver.simulate(2,33) + nose.tools.assert_almost_equal(float(y[-1]), 0.135, 3) + @testattr(stddist = True) - def test_radau5ode_state_events(self): + def test_radau5ode_state_events_f(self): solver = Radau5ODE(eproblem) + solver.solver = 'f' t,y = solver.simulate(2,33) @@ -70,5 +90,3 @@ def test_rodasode_state_events(self): t,y = solver.simulate(2,33) nose.tools.assert_almost_equal(float(y[-1]), 0.135, 3) - - diff --git a/thirdparty/hairer/radau5_c_py.pxd b/thirdparty/hairer/radau5_c_py.pxd new file mode 100644 index 00000000..14b1a5da --- /dev/null +++ b/thirdparty/hairer/radau5_c_py.pxd @@ -0,0 +1,45 @@ +#!/usr/bin/env python +# -*- coding: utf-8 -*- + +# Copyright (C) 2021 Modelon AB +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU Lesser General Public License as published by +# the Free Software Foundation, version 3 of the License. +# +# This program 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 Lesser General Public License for more details. +# +# You should have received a copy of the GNU Lesser General Public License +# along with this program. If not, see . + +from numpy cimport int64_t + +cdef extern from "string.h": + void *memcpy(void *s1, void *s2, int n) + +cdef extern from "radau_decsol_c.h": + ctypedef int64_t integer + ctypedef double doublereal + + ## FunctionPointer_CallBack + ctypedef int (*FP_CB_f)(integer*, doublereal*, doublereal*, doublereal*, + doublereal*, integer*, void*) + ctypedef int (*FP_CB_jac)(integer*, doublereal*, doublereal*, doublereal*, + integer*, doublereal*, integer*, void*) + ctypedef int (*FP_CB_mas)(integer*, doublereal*, integer*, doublereal*, + integer*, void*) + ctypedef int (*FP_CB_solout)(integer*, doublereal*, doublereal*, doublereal*, + doublereal*, doublereal*, integer*, integer*, + doublereal*, integer*, integer*, void*) + + int radau5_c(integer*, FP_CB_f, void*, doublereal*, doublereal*, + doublereal*, doublereal*, doublereal*, doublereal*, + integer*, FP_CB_jac, void*, integer*, integer*, integer*, + FP_CB_mas, void*, integer*, integer*, integer*, FP_CB_solout, + void*, integer*, doublereal*, integer*, integer*, integer*, + doublereal*, integer*, integer*) + + doublereal contr5_c(integer*, doublereal*, doublereal*, integer*) diff --git a/thirdparty/hairer/radau5_c_py.pyx b/thirdparty/hairer/radau5_c_py.pyx new file mode 100644 index 00000000..25d0e66a --- /dev/null +++ b/thirdparty/hairer/radau5_c_py.pyx @@ -0,0 +1,249 @@ +#!/usr/bin/env python +# -*- coding: utf-8 -*- + +# Copyright (C) 2021 Modelon AB +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU Lesser General Public License as published by +# the Free Software Foundation, version 3 of the License. +# +# This program 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 Lesser General Public License for more details. +# +# You should have received a copy of the GNU Lesser General Public License +# along with this program. If not, see . + +cimport radau5_c_py +cimport cython + +import numpy as np +cimport numpy as np + +from numpy cimport PyArray_DATA + +@cython.boundscheck(False) +@cython.wraparound(False) +cdef void py2c(double* dest, object source, int dim): + """ + Copy 1D numpy array data to (double *) C vector + """ + cdef double* data + if not (isinstance(source, np.ndarray) and source.flags.contiguous and source.dtype == np.float): + source = np.ascontiguousarray(source, dtype=np.float) + assert source.size >= dim, "The dimension of the vector is {} and not equal to the problem dimension {}. Please verify the output vectors from the min/max/nominal/evalute methods in the Problem class.".format(source.size, dim) + data = PyArray_DATA(source) + memcpy(dest, data, dim*sizeof(double)) + +@cython.boundscheck(False) +@cython.wraparound(False) +cdef void py2c_matrix_flat_F(double* dest, object source, int nrow, int ncol): + """ + Copy (square) 2D numpy array (order = c) to (double *) C matrix (with Fortran-style column major ordering) + """ + cdef np.ndarray[double, ndim=2] source_np = np.array(source, copy=False, dtype = np.float) + for i in range(ncol): + for j in range(nrow): + dest[j + i*nrow] = source_np[j][i] + +@cython.boundscheck(False) +@cython.wraparound(False) +cdef void c2py(np.ndarray[double, ndim=1, mode='c'] dest, double* source, int dim): + """ + Copy (double *) C vector to 1D numpy array + """ + memcpy(dest.data, source, dim*sizeof(double)) + +@cython.boundscheck(False) +@cython.wraparound(False) +cdef void c2py_mat_F(np.ndarray[double, ndim=2, mode='fortran'] dest, double* source, int dim): + """ + Copy (double *) C matrix (Fotran-style column major ordering) to 2D numpy array + """ + memcpy(dest.data, source, dim*sizeof(double)) + +cdef int callback_fcn(integer* n, doublereal* x, doublereal* y_in, doublereal* y_out, + doublereal* rpar, integer* ipar, void* fcn_PY): + """ + Internal callback function to enable call to Python based rhs function from C + """ + cdef np.ndarray[double, ndim=1, mode="c"]y_py_in = np.empty(n[0], dtype = np.double) + c2py(y_py_in, y_in, n[0]) + res = (fcn_PY)(x[0], y_py_in) + py2c(y_out, res[0], len(res[0])) + ipar[0] = res[1][0] + return 0 + +cdef int callback_jac(integer* n, doublereal* x, doublereal* y, doublereal* fjac, + integer* ldjac, doublereal* rpar, integer* ipar, void* jac_PY): + """ + Internal callback function to enable call to Python based Jacobian function from C + """ + cdef np.ndarray[double, ndim=1, mode="c"]y_py_in = np.empty(n[0], dtype = np.double) + c2py(y_py_in, y, n[0]) + res = (jac_PY)(x[0], y_py_in) + py2c_matrix_flat_F(fjac, res, res.shape[0], res.shape[1]) + return 0 + +cdef int callback_mas(integer* n, doublereal* am, integer* lmas, doublereal* rpar, + integer* ipar, void* mas_PY): + """ + Internal callback function to enable call to Python based mass matrix function from C + """ + cdef np.ndarray[double, mode="fortran", ndim=2]am_py = np.empty((lmas[0], n[0]), order = 'F', dtype = np.double) + c2py_mat_F(am_py, am, n[0]*lmas[0]) + res = (mas_PY)(am_py) + py2c_matrix_flat_F(am, res, res.shape[0], res.shape[1]) + return 0 + +cdef int callback_solout(integer* nrsol, doublereal* xosol, doublereal* xsol, doublereal* y, + doublereal* cont, doublereal* werr, integer* lrc, integer* nsolu, + doublereal* rpar, integer* ipar, integer* irtrn, void* solout_PY): + """ + Internal callback function to enable call to Python based solution output function from C + """ + cdef np.ndarray[double, ndim=1, mode="c"]y_py = np.empty(nsolu[0], dtype = np.double) + cdef np.ndarray[double, ndim=1, mode="c"]cont_py = np.empty(4*nsolu[0], dtype = np.double) + cdef np.ndarray[double, ndim=1, mode="c"]werr_py = np.empty(nsolu[0], dtype = np.double) + c2py(y_py, y, nsolu[0]) + c2py(cont_py, cont, 4*nsolu[0]) + c2py(werr_py, werr, nsolu[0]) + + irtrn[0] = (solout_PY)(nrsol[0], xosol[0], xsol[0], + y_py, cont_py, werr_py, + lrc[0], irtrn[0]) + + return irtrn[0] + +cpdef radau5(fcn_PY, doublereal x, np.ndarray y, + doublereal xend, doublereal h__, np.ndarray rtol, np.ndarray atol, + integer itol, jac_PY, integer ijac, integer mljac, integer mujac, + mas_PY, integer imas, integer mlmas, integer mumas, solout_PY, + integer iout, np.ndarray work, np.ndarray iwork): + """ + Python interface for calling the C based Radau solver + + Parameters:: + + fcn_PY + - Right-hand side function f(x, y), where 'x' is time, returning the evaluated value, + x + - Start time + y + - Array, initial value + xend + - End time + h__ + - Initial step-size guess + rtol + - Array (len == len(y)) or scalar, Relative error tolerance in step-size control + atol + - Array (len == len(y)) or scalar, Absolute error tolerance in step-size control + itol + - Switch for rtol and atol: + itol == 0: Both are scalars + itol == 1: Both are vectors + jac_PY + - Jacobian function jac(x, y), where 'x' is time + ijac + - Switch for Jacobian computation: + ijac == 0: C based finite differences + ijac == 1: Calls supplied 'jac_PY' function + mljac + - Switch for banded structure of Jacobian (used when solving the arising linear systems) + mljac == len(y): Full matrix Gauss-elimination + 0 <= mljac < len(y): Size of non-zero lower diagonal bandwidth + mujac + - Compare 'mljac', size of non-zero upper diagonal bandwidth, ignored if mljac == len(y) + mas_PY + - Mass matrix function mas_PY(am) + imas + - Switch for mass matrix: + imas == 0: Mass matrix is identity, 'mas_PY' never called + imas == 1: 'mas_PY' is used to determine mass matrix + mlmas + - Switch for banded structure of Mass matrix, supposed to fulfill mlmas <= mljac + mlmas == len(y): Full matrix Gauss-elimination + 0 <= mlmas < len(y): Size of non-zero lower diagonal bandwidth + mumas + - Compare 'mumax', size of non-zero upper diagonal bandwidth, ignored if mlmas == len(y), supposed to fulfill mumas <= mujac + solout_PY + - Callback function for logging solution of time-integration: + solout_PY(nrsol, told, t, y, cont, werr, lrc, irtrn) + - nrsol: number of solution point + - told: Previous time-point + - t: Current time-point + - y: Solution at current time-point + - cont: Output to be used to obtain high-order dense output, via the 'contr5' function + - werr: Local error estimate + - lrc: Unsused optional parameter + - irtrn: Optional parameter for interrupting time-integation if irtrn < 0 + iout + - Switch for using solout_PY: + iout == 0: solout_PY is never called + iout == 1: solout_PY is called after each successful time-integration step + work + - Advanced tuning parameters of Radau solver, see radau_decsol.c for details + iwork + - Advanced tuning parameters of Radau solver, see radau_decsol.c for details + Returns:: + + x + - Final time for which a solution has been computed, x == xend, if succesful + y + - Final solution + h__ + - Prediced size of last accepted step + iwork + - Statistics about number of function calls etc, see radau_decsol.c for details + idid + - Return flag, see radau_decsol.c for details (1 == Successful computation) + """ + # array lengthes, required for C call + cdef integer n = len(y) + cdef integer lwork = len(work) + cdef integer liwork = len(iwork) + + # UNUSED: optional parameters used for communication between fcn, jac, mas, solout + cdef doublereal rpar = 0 + cdef integer ipar = 0 + + cdef integer idid = 1 ## "Successful compution" + + iwork_in = np.array(iwork, dtype = np.int64) + cdef np.ndarray[double, mode="c", ndim=1] y_vec = y + cdef np.ndarray[double, mode="c", ndim=1] rtol_vec = rtol + cdef np.ndarray[double, mode="c", ndim=1] atol_vec = atol + cdef np.ndarray[double, mode="c", ndim=1] work_vec = work + cdef np.ndarray[integer, mode="c", ndim=1] iwork_vec = iwork_in + + radau5_c_py.radau5_c(&n, callback_fcn, fcn_PY, &x, &y_vec[0], &xend, + &h__, &rtol_vec[0], &rtol_vec[0], &itol, callback_jac, jac_PY, + &ijac, &mljac, &mujac, callback_mas, mas_PY, &imas, &mlmas, &mumas, + callback_solout, solout_PY, &iout, &work_vec[0], &lwork, &iwork_vec[0], &liwork, &rpar, + &ipar, &idid) + + return x, y, h__, np.array(iwork_in, dtype = int), idid + +cpdef contr5(integer i__, doublereal x, np.ndarray cont): + """ + Python interface for calling the C based interpolation function using dense output + Returns 'i'-th component at time 'x'. IMPORTANT: This function uses index 1 based notation. + + Parameters:: + + i + - Which component to compute the solution for. IMPORTANT: starting index is 1, not 0 + x + - time-point at which the solution is requested. Needs to be within the time-interval defined by the last successful step. + cont + - 'cont' input parameter to 'solout_PY' callback in 'radau5' function + + Returns:: + - See function description + + """ + cdef integer lrc = len(cont) + cdef np.ndarray[double, mode="c", ndim=1] cont_vec = cont + return radau5_c_py.contr5_c(&i__, &x, &cont_vec[0], &lrc) diff --git a/thirdparty/hairer/radau_decsol_c.c b/thirdparty/hairer/radau_decsol_c.c new file mode 100644 index 00000000..e641513f --- /dev/null +++ b/thirdparty/hairer/radau_decsol_c.c @@ -0,0 +1,6493 @@ +// based on f2c (version 20100827) translation of radau_decsol.f. +// Note: Due to this, matrices (doublereal*) are stored in Fortran-style column major format + +#include +#include +#include +#include "radau_decsol_c.h" +#include + +/* Common Block Declarations */ + +struct { + integer nn, nn2, nn3, nn4; + doublereal xsol, hsol, c2m1, c1m1; +} conra5_; + +#define conra5_1 conra5_ + +struct { + integer mle, mue, mbjac, mbb, mdiag, mdiff, mbdiag; +} linal_; + +#define linal_1 linal_ + +/* Table of constant values */ + +static integer c__1 = 1; +static doublereal c_b54 = .5; +static doublereal c_b91 = 81.; +static doublereal c_b92 = .33333333333333331; +static doublereal c_b93 = 9.; +static doublereal c_b114 = .8; +static doublereal c_b116 = .25; + +/* Subroutine */ int radau5_c(integer *n, FP_CB_f fcn, void* fcn_PY, doublereal *x, doublereal * + y, doublereal *xend, doublereal *h__, doublereal *rtol, doublereal * + atol, integer *itol, FP_CB_jac jac, void* jac_PY, integer *ijac, integer *mljac, integer + *mujac, FP_CB_mas mas, void* mas_PY, integer *imas, integer *mlmas, integer *mumas, FP_CB_solout + solout, void* solout_PY, integer *iout, doublereal *work, integer *lwork, integer * + iwork, integer *liwork, doublereal *rpar, integer *ipar, integer * + idid) +{ + /* System generated locals */ + integer i__1; + doublereal d__1, d__2, d__3, d__4; + + /* Local variables */ + static integer i__, m1, m2, nm1, nit, iee1, ief1, lde1, ief2, ief3, iey0, + iez1, iez2, iez3; + static doublereal facl; + static integer ndec, njac; + static doublereal facr, safe; + static integer ijob, nfcn; + static logical pred; + static doublereal hmax; + static integer nmax; + static doublereal thet, expm; + static integer nsol; + static doublereal quot; + static integer iee2i, iee2r, ieip1, ieip2, nind1, nind2, nind3; + static doublereal quot1, quot2; + static integer iejac, ldjac; + static logical jband; + static integer iecon, iemas, ldmas, ieiph; + static logical arret; + static doublereal fnewt; + static integer nstep; + static doublereal tolst; + static integer ldmas2, iescal, naccpt; + extern /* Subroutine */ int radcor_(integer *, FP_CB_f, void*, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, integer *, FP_CB_jac, void*, integer *, integer *, + integer *, FP_CB_mas, void*, integer *, integer *, FP_CB_solout, void*, integer *, integer * + , integer *, doublereal *, doublereal *, doublereal *, doublereal + *, doublereal *, doublereal *, integer *, integer *, logical *, + integer *, integer *, integer *, logical *, doublereal *, + doublereal *, integer *, integer *, integer *, logical *, logical + *, integer *, integer *, integer *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, integer *, integer *, + integer *, doublereal *, integer *, integer *, integer *, integer + *, integer *, integer *, integer *, doublereal *, integer *); + static integer nrejct; + static logical implct; + static integer istore; + static logical startn; + static doublereal uround; + +/* ---------------------------------------------------------- */ +/* NUMERICAL SOLUTION OF A STIFF (OR DIFFERENTIAL ALGEBRAIC) */ +/* SYSTEM OF FIRST 0RDER ORDINARY DIFFERENTIAL EQUATIONS */ +/* M*Y'=F(X,Y). */ +/* THE SYSTEM CAN BE (LINEARLY) IMPLICIT (MASS-MATRIX M .NE. I) */ +/* OR EXPLICIT (M=I). */ +/* THE METHOD USED IS AN IMPLICIT RUNGE-KUTTA METHOD (RADAU IIA) */ +/* OF ORDER 5 WITH STEP SIZE CONTROL AND CONTINUOUS OUTPUT. */ +/* CF. SECTION IV.8 */ + +/* AUTHORS: E. HAIRER AND G. WANNER */ +/* UNIVERSITE DE GENEVE, DEPT. DE MATHEMATIQUES */ +/* CH-1211 GENEVE 24, SWITZERLAND */ +/* E-MAIL: Ernst.Hairer@math.unige.ch */ +/* Gerhard.Wanner@math.unige.ch */ + +/* THIS CODE IS PART OF THE BOOK: */ +/* E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL */ +/* EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS. */ +/* SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS 14, */ +/* SPRINGER-VERLAG 1991, SECOND EDITION 1996. */ + +/* VERSION OF JULY 9, 1996 */ +/* (latest small correction: January 18, 2002) */ + +/* INPUT PARAMETERS */ +/* ---------------- */ +/* N DIMENSION OF THE SYSTEM */ + +/* FCN NAME (EXTERNAL) OF SUBROUTINE COMPUTING THE */ +/* VALUE OF F(X,Y): */ +/* SUBROUTINE FCN(N,X,Y,F,RPAR,IPAR) */ +/* DOUBLE PRECISION X,Y(N),F(N) */ +/* F(1)=... ETC. */ +/* RPAR, IPAR (SEE BELOW) */ + +/* X INITIAL X-VALUE */ + +/* Y(N) INITIAL VALUES FOR Y */ + +/* XEND FINAL X-VALUE (XEND-X MAY BE POSITIVE OR NEGATIVE) */ + +/* H INITIAL STEP SIZE GUESS; */ +/* FOR STIFF EQUATIONS WITH INITIAL TRANSIENT, */ +/* H=1.D0/(NORM OF F'), USUALLY 1.D-3 OR 1.D-5, IS GOOD. */ +/* THIS CHOICE IS NOT VERY IMPORTANT, THE STEP SIZE IS */ +/* QUICKLY ADAPTED. (IF H=0.D0, THE CODE PUTS H=1.D-6). */ + +/* RTOL,ATOL RELATIVE AND ABSOLUTE ERROR TOLERANCES. THEY */ +/* CAN BE BOTH SCALARS OR ELSE BOTH VECTORS OF LENGTH N. */ + +/* ITOL SWITCH FOR RTOL AND ATOL: */ +/* ITOL=0: BOTH RTOL AND ATOL ARE SCALARS. */ +/* THE CODE KEEPS, ROUGHLY, THE LOCAL ERROR OF */ +/* Y(I) BELOW RTOL*ABS(Y(I))+ATOL */ +/* ITOL=1: BOTH RTOL AND ATOL ARE VECTORS. */ +/* THE CODE KEEPS THE LOCAL ERROR OF Y(I) BELOW */ +/* RTOL(I)*ABS(Y(I))+ATOL(I). */ + +/* JAC NAME (EXTERNAL) OF THE SUBROUTINE WHICH COMPUTES */ +/* THE PARTIAL DERIVATIVES OF F(X,Y) WITH RESPECT TO Y */ +/* (THIS ROUTINE IS ONLY CALLED IF IJAC=1; SUPPLY */ +/* A DUMMY SUBROUTINE IN THE CASE IJAC=0). */ +/* FOR IJAC=1, THIS SUBROUTINE MUST HAVE THE FORM */ +/* SUBROUTINE JAC(N,X,Y,DFY,LDFY,RPAR,IPAR) */ +/* DOUBLE PRECISION X,Y(N),DFY(LDFY,N) */ +/* DFY(1,1)= ... */ +/* LDFY, THE COLUMN-LENGTH OF THE ARRAY, IS */ +/* FURNISHED BY THE CALLING PROGRAM. */ +/* IF (MLJAC.EQ.N) THE JACOBIAN IS SUPPOSED TO */ +/* BE FULL AND THE PARTIAL DERIVATIVES ARE */ +/* STORED IN DFY AS */ +/* DFY(I,J) = PARTIAL F(I) / PARTIAL Y(J) */ +/* ELSE, THE JACOBIAN IS TAKEN AS BANDED AND */ +/* THE PARTIAL DERIVATIVES ARE STORED */ +/* DIAGONAL-WISE AS */ +/* DFY(I-J+MUJAC+1,J) = PARTIAL F(I) / PARTIAL Y(J). */ + +/* IJAC SWITCH FOR THE COMPUTATION OF THE JACOBIAN: */ +/* IJAC=0: JACOBIAN IS COMPUTED INTERNALLY BY FINITE */ +/* DIFFERENCES, SUBROUTINE "JAC" IS NEVER CALLED. */ +/* IJAC=1: JACOBIAN IS SUPPLIED BY SUBROUTINE JAC. */ + +/* MLJAC SWITCH FOR THE BANDED STRUCTURE OF THE JACOBIAN: */ +/* MLJAC=N: JACOBIAN IS A FULL MATRIX. THE LINEAR */ +/* ALGEBRA IS DONE BY FULL-MATRIX GAUSS-ELIMINATION. */ +/* 0<=MLJAC= NUMBER OF NON-ZERO DIAGONALS BELOW */ +/* THE MAIN DIAGONAL). */ + +/* MUJAC UPPER BANDWITH OF JACOBIAN MATRIX (>= NUMBER OF NON- */ +/* ZERO DIAGONALS ABOVE THE MAIN DIAGONAL). */ +/* NEED NOT BE DEFINED IF MLJAC=N. */ + +/* ---- MAS,IMAS,MLMAS, AND MUMAS HAVE ANALOG MEANINGS ----- */ +/* ---- FOR THE "MASS MATRIX" (THE MATRIX "M" OF SECTION IV.8): - */ + +/* MAS NAME (EXTERNAL) OF SUBROUTINE COMPUTING THE MASS- */ +/* MATRIX M. */ +/* IF IMAS=0, THIS MATRIX IS ASSUMED TO BE THE IDENTITY */ +/* MATRIX AND NEEDS NOT TO BE DEFINED; */ +/* SUPPLY A DUMMY SUBROUTINE IN THIS CASE. */ +/* IF IMAS=1, THE SUBROUTINE MAS IS OF THE FORM */ +/* SUBROUTINE MAS(N,AM,LMAS,RPAR,IPAR) */ +/* DOUBLE PRECISION AM(LMAS,N) */ +/* AM(1,1)= .... */ +/* IF (MLMAS.EQ.N) THE MASS-MATRIX IS STORED */ +/* AS FULL MATRIX LIKE */ +/* AM(I,J) = M(I,J) */ +/* ELSE, THE MATRIX IS TAKEN AS BANDED AND STORED */ +/* DIAGONAL-WISE AS */ +/* AM(I-J+MUMAS+1,J) = M(I,J). */ + +/* IMAS GIVES INFORMATION ON THE MASS-MATRIX: */ +/* IMAS=0: M IS SUPPOSED TO BE THE IDENTITY */ +/* MATRIX, MAS IS NEVER CALLED. */ +/* IMAS=1: MASS-MATRIX IS SUPPLIED. */ + +/* MLMAS SWITCH FOR THE BANDED STRUCTURE OF THE MASS-MATRIX: */ +/* MLMAS=N: THE FULL MATRIX CASE. THE LINEAR */ +/* ALGEBRA IS DONE BY FULL-MATRIX GAUSS-ELIMINATION. */ +/* 0<=MLMAS= NUMBER OF NON-ZERO DIAGONALS BELOW */ +/* THE MAIN DIAGONAL). */ +/* MLMAS IS SUPPOSED TO BE .LE. MLJAC. */ + +/* MUMAS UPPER BANDWITH OF MASS-MATRIX (>= NUMBER OF NON- */ +/* ZERO DIAGONALS ABOVE THE MAIN DIAGONAL). */ +/* NEED NOT BE DEFINED IF MLMAS=N. */ +/* MUMAS IS SUPPOSED TO BE .LE. MUJAC. */ + +/* SOLOUT NAME (EXTERNAL) OF SUBROUTINE PROVIDING THE */ +/* NUMERICAL SOLUTION DURING INTEGRATION. */ +/* IF IOUT=1, IT IS CALLED AFTER EVERY SUCCESSFUL STEP. */ +/* SUPPLY A DUMMY SUBROUTINE IF IOUT=0. */ +/* IT MUST HAVE THE FORM */ +/* SUBROUTINE SOLOUT (NR,XOLD,X,Y,CONT,LRC,N, */ +/* RPAR,IPAR,IRTRN) */ +/* DOUBLE PRECISION X,Y(N),CONT(LRC) */ +/* .... */ +/* SOLOUT FURNISHES THE SOLUTION "Y" AT THE NR-TH */ +/* GRID-POINT "X" (THEREBY THE INITIAL VALUE IS */ +/* THE FIRST GRID-POINT). */ +/* "XOLD" IS THE PRECEEDING GRID-POINT. */ +/* "IRTRN" SERVES TO INTERRUPT THE INTEGRATION. IF IRTRN */ +/* IS SET <0, RADAU5 RETURNS TO THE CALLING PROGRAM. */ + +/* ----- CONTINUOUS OUTPUT: ----- */ +/* DURING CALLS TO "SOLOUT", A CONTINUOUS SOLUTION */ +/* FOR THE INTERVAL [XOLD,X] IS AVAILABLE THROUGH */ +/* THE FUNCTION */ +/* >>> CONTR5(I,S,CONT,LRC) <<< */ +/* WHICH PROVIDES AN APPROXIMATION TO THE I-TH */ +/* COMPONENT OF THE SOLUTION AT THE POINT S. THE VALUE */ +/* S SHOULD LIE IN THE INTERVAL [XOLD,X]. */ +/* DO NOT CHANGE THE ENTRIES OF CONT(LRC), IF THE */ +/* DENSE OUTPUT FUNCTION IS USED. */ + +/* IOUT SWITCH FOR CALLING THE SUBROUTINE SOLOUT: */ +/* IOUT=0: SUBROUTINE IS NEVER CALLED */ +/* IOUT=1: SUBROUTINE IS AVAILABLE FOR OUTPUT. */ + +/* WORK ARRAY OF WORKING SPACE OF LENGTH "LWORK". */ +/* WORK(1), WORK(2),.., WORK(20) SERVE AS PARAMETERS */ +/* FOR THE CODE. FOR STANDARD USE OF THE CODE */ +/* WORK(1),..,WORK(20) MUST BE SET TO ZERO BEFORE */ +/* CALLING. SEE BELOW FOR A MORE SOPHISTICATED USE. */ +/* WORK(21),..,WORK(LWORK) SERVE AS WORKING SPACE */ +/* FOR ALL VECTORS AND MATRICES. */ +/* "LWORK" MUST BE AT LEAST */ +/* N*(LJAC+LMAS+3*LE+12)+20 */ +/* WHERE */ +/* LJAC=N IF MLJAC=N (FULL JACOBIAN) */ +/* LJAC=MLJAC+MUJAC+1 IF MLJAC0 THEN "LWORK" MUST BE AT LEAST */ +/* N*(LJAC+12)+(N-M1)*(LMAS+3*LE)+20 */ +/* WHERE IN THE DEFINITIONS OF LJAC, LMAS AND LE THE */ +/* NUMBER N CAN BE REPLACED BY N-M1. */ + +/* LWORK DECLARED LENGTH OF ARRAY "WORK". */ + +/* IWORK INTEGER WORKING SPACE OF LENGTH "LIWORK". */ +/* IWORK(1),IWORK(2),...,IWORK(20) SERVE AS PARAMETERS */ +/* FOR THE CODE. FOR STANDARD USE, SET IWORK(1),.., */ +/* IWORK(20) TO ZERO BEFORE CALLING. */ +/* IWORK(21),...,IWORK(LIWORK) SERVE AS WORKING AREA. */ +/* "LIWORK" MUST BE AT LEAST 3*N+20. */ + +/* LIWORK DECLARED LENGTH OF ARRAY "IWORK". */ + +/* RPAR, IPAR REAL AND INTEGER PARAMETERS (OR PARAMETER ARRAYS) WHICH */ +/* CAN BE USED FOR COMMUNICATION BETWEEN YOUR CALLING */ +/* PROGRAM AND THE FCN, JAC, MAS, SOLOUT SUBROUTINES. */ + +/* ---------------------------------------------------------------------- */ + +/* SOPHISTICATED SETTING OF PARAMETERS */ +/* ----------------------------------- */ +/* SEVERAL PARAMETERS OF THE CODE ARE TUNED TO MAKE IT WORK */ +/* WELL. THEY MAY BE DEFINED BY SETTING WORK(1),... */ +/* AS WELL AS IWORK(1),... DIFFERENT FROM ZERO. */ +/* FOR ZERO INPUT, THE CODE CHOOSES DEFAULT VALUES: */ + +/* IWORK(1) IF IWORK(1).NE.0, THE CODE TRANSFORMS THE JACOBIAN */ +/* MATRIX TO HESSENBERG FORM. THIS IS PARTICULARLY */ +/* ADVANTAGEOUS FOR LARGE SYSTEMS WITH FULL JACOBIAN. */ +/* IT DOES NOT WORK FOR BANDED JACOBIAN (MLJAC 1. */ +/* THE FUNCTION-SUBROUTINE SHOULD BE WRITTEN SUCH THAT */ +/* THE INDEX 1,2,3 VARIABLES APPEAR IN THIS ORDER. */ +/* IN ESTIMATING THE ERROR THE INDEX 2 VARIABLES ARE */ +/* MULTIPLIED BY H, THE INDEX 3 VARIABLES BY H**2. */ + +/* IWORK(5) DIMENSION OF THE INDEX 1 VARIABLES (MUST BE > 0). FOR */ +/* ODE'S THIS EQUALS THE DIMENSION OF THE SYSTEM. */ +/* DEFAULT IWORK(5)=N. */ + +/* IWORK(6) DIMENSION OF THE INDEX 2 VARIABLES. DEFAULT IWORK(6)=0. */ + +/* IWORK(7) DIMENSION OF THE INDEX 3 VARIABLES. DEFAULT IWORK(7)=0. */ + +/* IWORK(8) SWITCH FOR STEP SIZE STRATEGY */ +/* IF IWORK(8).EQ.1 MOD. PREDICTIVE CONTROLLER (GUSTAFSSON) */ +/* IF IWORK(8).EQ.2 CLASSICAL STEP SIZE CONTROL */ +/* THE DEFAULT VALUE (FOR IWORK(8)=0) IS IWORK(8)=1. */ +/* THE CHOICE IWORK(8).EQ.1 SEEMS TO PRODUCE SAFER RESULTS; */ +/* FOR SIMPLE PROBLEMS, THE CHOICE IWORK(8).EQ.2 PRODUCES */ +/* OFTEN SLIGHTLY FASTER RUNS */ + +/* IF THE DIFFERENTIAL SYSTEM HAS THE SPECIAL STRUCTURE THAT */ +/* Y(I)' = Y(I+M2) FOR I=1,...,M1, */ +/* WITH M1 A MULTIPLE OF M2, A SUBSTANTIAL GAIN IN COMPUTERTIME */ +/* CAN BE ACHIEVED BY SETTING THE PARAMETERS IWORK(9) AND IWORK(10). */ +/* E.G., FOR SECOND ORDER SYSTEMS P'=V, V'=G(P,V), WHERE P AND V ARE */ +/* VECTORS OF DIMENSION N/2, ONE HAS TO PUT M1=M2=N/2. */ +/* FOR M1>0 SOME OF THE INPUT PARAMETERS HAVE DIFFERENT MEANINGS: */ +/* - JAC: ONLY THE ELEMENTS OF THE NON-TRIVIAL PART OF THE */ +/* JACOBIAN HAVE TO BE STORED */ +/* IF (MLJAC.EQ.N-M1) THE JACOBIAN IS SUPPOSED TO BE FULL */ +/* DFY(I,J) = PARTIAL F(I+M1) / PARTIAL Y(J) */ +/* FOR I=1,N-M1 AND J=1,N. */ +/* ELSE, THE JACOBIAN IS BANDED ( M1 = M2 * MM ) */ +/* DFY(I-J+MUJAC+1,J+K*M2) = PARTIAL F(I+M1) / PARTIAL Y(J+K*M2) */ +/* FOR I=1,MLJAC+MUJAC+1 AND J=1,M2 AND K=0,MM. */ +/* - MLJAC: MLJAC=N-M1: IF THE NON-TRIVIAL PART OF THE JACOBIAN IS FULL */ +/* 0<=MLJAC1.0D0 */ + if (work[1] == 0.) { + uround = 1e-16; + } else { + uround = work[1]; + if (uround <= 1e-19 || uround >= 1.) { + printf(" COEFFICIENTS HAVE 20 DIGITS, UROUND= \t %e \n", uround); + arret = TRUE_; + } + } + /* -------- CHECK AND CHANGE THE TOLERANCES */ + expm = .66666666666666663; + if (*itol == 0) { + if (atol[1] <= 0. || rtol[1] <= uround * 10.) { + printf(" TOLERANCES ARE TOO SMALL \n"); + arret = TRUE_; + } else { + quot = atol[1] / rtol[1]; + rtol[1] = pow(rtol[1], expm) * .1; + atol[1] = rtol[1] * quot; + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (atol[i__] <= 0. || rtol[i__] <= uround * 10.) { + printf("TOLERANCES (%"PRId64") ARE TOO SMALL \n", i__); + arret = TRUE_; + } else { + quot = atol[i__] / rtol[i__]; + rtol[i__] = pow(rtol[i__], expm) * .1; + atol[i__] = rtol[i__] * quot; + } + } + } + /* -------- NMAX , THE MAXIMAL NUMBER OF STEPS ----- */ + if (iwork[2] == 0) { + nmax = 100000; + } else { + nmax = iwork[2]; + if (nmax <= 0) { + printf("WRONG INPUT IWORK(2)= %"PRId64" \n", nmax); + arret = TRUE_; + } + } + /* -------- NIT MAXIMAL NUMBER OF NEWTON ITERATIONS */ + if (iwork[3] == 0) { + nit = 7; + } else { + nit = iwork[3]; + if (nit <= 0) { + printf("CURIOUS INPUT IWORK(3)= %"PRId64" \n", nit); + arret = TRUE_; + } + } + /* -------- STARTN SWITCH FOR STARTING VALUES OF NEWTON ITERATIONS */ + if (iwork[4] == 0) { + startn = FALSE_; + } else { + startn = TRUE_; + } + /* -------- PARAMETER FOR DIFFERENTIAL-ALGEBRAIC COMPONENTS */ + nind1 = iwork[5]; + nind2 = iwork[6]; + nind3 = iwork[7]; + if (nind1 == 0) { + nind1 = *n; + } + if (nind1 + nind2 + nind3 != *n) { + printf("CURIOUS INPUT FOR IWORK(5,6,7)= \t %"PRId64"\t %"PRId64"\t %"PRId64"\n", nind1, nind2, nind3); + arret = TRUE_; + } + /* -------- PRED STEP SIZE CONTROL */ + if (iwork[8] <= 1) { + pred = TRUE_; + } else { + pred = FALSE_; + } + /* -------- PARAMETER FOR SECOND ORDER EQUATIONS */ + m1 = iwork[9]; + m2 = iwork[10]; + nm1 = *n - m1; + if (m1 == 0) { + m2 = *n; + } + if (m2 == 0) { + m2 = m1; + } + if (m1 < 0 || m2 < 0 || m1 + m2 > *n) { + printf("CURIOUS INPUT FOR IWORK(9,10)= \t %"PRId64"\t %"PRId64"\n", m1, m2); + arret = TRUE_; + } + /* --------- SAFE SAFETY FACTOR IN STEP SIZE PREDICTION */ + if (work[2] == 0.) { + safe = .9; + } else { + safe = work[2]; + if (safe <= .001 || safe >= 1.) { + printf("CURIOUS INPUT FOR WORK(2)= %f \n", safe); + arret = TRUE_; + } + } + /* ------ THET DECIDES WHETHER THE JACOBIAN SHOULD BE RECOMPUTED; */ + if (work[3] == 0.) { + thet = .001; + } else { + thet = work[3]; + if (thet >= 1.) { + printf("CURIOUS INPUT FOR WORK(3)= %f \n", thet); + arret = TRUE_; + } + } + /* --- FNEWT STOPPING CRITERION FOR NEWTON'S METHOD, USUALLY CHOSEN <1. */ + tolst = rtol[1]; + if (work[4] == 0.) { + /* Computing MAX */ + /* Computing MIN */ + d__3 = .03, d__4 = pow(tolst, c_b54); + d__1 = uround * 10 / tolst, d__2 = min(d__3,d__4); + fnewt = max(d__1,d__2); + } else { + fnewt = work[4]; + if (fnewt <= uround / tolst) { + printf("CURIOUS INPUT FOR WORK(4)= %f \n", fnewt); + arret = TRUE_; + } + } + /* --- QUOT1 AND QUOT2: IF QUOT1 < HNEW/HOLD < QUOT2, STEP SIZE = CONST. */ + if (work[5] == 0.) { + quot1 = 1.; + } else { + quot1 = work[5]; + } + if (work[6] == 0.) { + quot2 = 1.2; + } else { + quot2 = work[6]; + } + if (quot1 > 1. || quot2 < 1.) { + printf("CURIOUS INPUT FOR WORK(5, 6)= %f \t %f \n", quot1, quot2); + arret = TRUE_; + } + /* -------- MAXIMAL STEP SIZE */ + if (work[7] == 0.) { + hmax = *xend - *x; + } else { + hmax = work[7]; + } + /* ------- FACL,FACR PARAMETERS FOR STEP SIZE SELECTION */ + if (work[8] == 0.) { + facl = 5.; + } else { + facl = 1. / work[8]; + } + if (work[9] == 0.) { + facr = .125; + } else { + facr = 1. / work[9]; + } + if (facl < 1. || facr > 1.) { + printf("CURIOUS INPUT FOR WORK(8, 9)= %f \t %f \n", facl, facr); + arret = TRUE_; + } + /* *** *** *** *** *** *** *** *** *** *** *** *** *** */ + /* COMPUTATION OF ARRAY ENTRIES */ + /* *** *** *** *** *** *** *** *** *** *** *** *** *** */ + /* ---- IMPLICIT, BANDED OR NOT ? */ + implct = *imas != 0; + jband = *mljac < nm1; + /* -------- COMPUTATION OF THE ROW-DIMENSIONS OF THE 2-ARRAYS --- */ + /* -- JACOBIAN AND MATRICES E1, E2 */ + if (jband) { + ldjac = *mljac + *mujac + 1; + lde1 = *mljac + ldjac; + } else { + *mljac = nm1; + *mujac = nm1; + ldjac = nm1; + lde1 = nm1; + } + /* -- MASS MATRIX */ + if (implct) { + if (*mlmas != nm1) { + ldmas = *mlmas + *mumas + 1; + if (jband) { + ijob = 4; + } else { + ijob = 3; + } + } else { + *mumas = nm1; + ldmas = nm1; + ijob = 5; + } + /* ------ BANDWITH OF "MAS" NOT SMALLER THAN BANDWITH OF "JAC" */ + if (*mlmas > *mljac || *mumas > *mujac) { + printf("BANDWITH OF \"MAS\" NOT SMALLER THAN BANDWITH OF \"JAC\"\n"); + arret = TRUE_; + } + } else { + ldmas = 0; + if (jband) { + ijob = 2; + } else { + ijob = 1; + if (*n > 2 && iwork[1] != 0) { + ijob = 7; + } + } + } + ldmas2 = max(1,ldmas); + /* ------ HESSENBERG OPTION ONLY FOR EXPLICIT EQU. WITH FULL JACOBIAN */ + if ((implct || jband) && ijob == 7) { + printf(" HESSENBERG OPTION ONLY FOR EXPLICIT EQUATIONS WITH FULL JACOBIAN\n"); + arret = TRUE_; + } + /* ------- PREPARE THE ENTRY-POINTS FOR THE ARRAYS IN WORK ----- */ + iez1 = 21; + iez2 = iez1 + *n; + iez3 = iez2 + *n; + iey0 = iez3 + *n; + iescal = iey0 + *n; + ief1 = iescal + *n; + ief2 = ief1 + *n; + ief3 = ief2 + *n; + iecon = ief3 + *n; + iejac = iecon + (*n << 2); + iemas = iejac + *n * ldjac; + iee1 = iemas + nm1 * ldmas; + iee2r = iee1 + nm1 * lde1; + iee2i = iee2r + nm1 * lde1; + /* ------ TOTAL STORAGE REQUIREMENT ----------- */ + istore = iee2i + nm1 * lde1 - 1; + if (istore > *lwork) { + printf("INSUFFICIENT STORAGE FOR WORK, MIN. LWORK= %"PRId64"\n", istore); + arret = TRUE_; + } + /* ------- ENTRY POINTS FOR INTEGER WORKSPACE ----- */ + ieip1 = 21; + ieip2 = ieip1 + nm1; + ieiph = ieip2 + nm1; + /* --------- TOTAL REQUIREMENT --------------- */ + istore = ieiph + nm1 - 1; + if (istore > *liwork) { + printf("INSUFF. STORAGE FOR IWORK, MIN. LIWORK= %"PRId64"\n", istore); + arret = TRUE_; + } + /* ------ WHEN A FAIL HAS OCCURED, WE RETURN WITH IDID=-1 */ + if (arret) { + *idid = -1; + return 0; + } + /* -------- CALL TO CORE INTEGRATOR ------------ */ + radcor_(n, (FP_CB_f)fcn, fcn_PY, x, &y[1], xend, &hmax, h__, &rtol[1], &atol[1], + itol, (FP_CB_jac)jac, jac_PY, ijac, mljac, mujac, (FP_CB_mas)mas, mas_PY, mlmas, mumas, ( + FP_CB_solout)solout, solout_PY, iout, idid, &nmax, &uround, &safe, &thet, &fnewt, & + quot1, "2, &nit, &ijob, &startn, &nind1, &nind2, &nind3, & + pred, &facl, &facr, &m1, &m2, &nm1, &implct, &jband, &ldjac, & + lde1, &ldmas2, &work[iez1], &work[iez2], &work[iez3], &work[iey0], + &work[iescal], &work[ief1], &work[ief2], &work[ief3], &work[ + iejac], &work[iee1], &work[iee2r], &work[iee2i], &work[iemas], & + iwork[ieip1], &iwork[ieip2], &iwork[ieiph], &work[iecon], &nfcn, & + njac, &nstep, &naccpt, &nrejct, &ndec, &nsol, &rpar[1], &ipar[1]); + iwork[14] = nfcn; + iwork[15] = njac; + iwork[16] = nstep; + iwork[17] = naccpt; + iwork[18] = nrejct; + iwork[19] = ndec; + iwork[20] = nsol; + /* -------- RESTORE TOLERANCES */ + expm = 1. / expm; + if (*itol == 0) { + quot = atol[1] / rtol[1]; + d__1 = rtol[1] * 10.; + rtol[1] = pow(d__1, expm); + atol[1] = rtol[1] * quot; + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + quot = atol[i__] / rtol[i__]; + d__1 = rtol[i__] * 10.; + rtol[i__] = pow(d__1, expm); + atol[i__] = rtol[i__] * quot; + } + } + /* ----------- RETURN ----------- */ + return 0; +} /* radau5_ */ + + +/* END OF SUBROUTINE RADAU5 */ + +/* *********************************************************** */ + +/* Subroutine */ int radcor_(integer *n, FP_CB_f fcn, void* fcn_PY, doublereal *x, doublereal * + y, doublereal *xend, doublereal *hmax, doublereal *h__, doublereal * + rtol, doublereal *atol, integer *itol, FP_CB_jac jac, void* jac_PY, integer *ijac, + integer *mljac, integer *mujac, FP_CB_mas mas, void* mas_PY, integer *mlmas, integer * + mumas, FP_CB_solout solout, void* solout_PY, integer *iout, integer *idid, integer *nmax, + doublereal *uround, doublereal *safe, doublereal *thet, doublereal * + fnewt, doublereal *quot1, doublereal *quot2, integer *nit, integer * + ijob, logical *startn, integer *nind1, integer *nind2, integer *nind3, + logical *pred, doublereal *facl, doublereal *facr, integer *m1, + integer *m2, integer *nm1, logical *implct, logical *banded, integer * + ldjac, integer *lde1, integer *ldmas, doublereal *z1, doublereal *z2, + doublereal *z3, doublereal *y0, doublereal *scal, doublereal *f1, + doublereal *f2, doublereal *f3, doublereal *fjac, doublereal *e1, + doublereal *e2r, doublereal *e2i, doublereal *fmas, integer *ip1, + integer *ip2, integer *iphes, doublereal *cont, integer *nfcn, + integer *njac, integer *nstep, integer *naccpt, integer *nrejct, + integer *ndec, integer *nsol, doublereal *rpar, integer *ipar) +{ + /* System generated locals */ + integer fjac_dim1, fjac_offset, fmas_dim1, fmas_offset, e1_dim1, + e1_offset, e2r_dim1, e2r_offset, e2i_dim1, e2i_offset, i__1, i__2, + i__3, i__4; + doublereal d__1, d__2, d__3, d__4; + + /* Local variables */ + static integer i__, j, k, l; + static doublereal a1, a2, c1, c2, a3; + static integer j1, n2, n3; + static doublereal u1; + static integer nunexpect; + static doublereal ak; + static integer md; + static doublereal t11, t12, t13, t21, t22, t23, t31; + static integer mm; + static doublereal qt, dd1, dd2, dd3, ak1, ak2, ak3, f1i, f2i, f3i, c1q, + c2q, c3q, z1i, z2i, z3i, sq6, fac, ti11, cno; + static integer lrc; + static doublereal ti12, ti13, ti21, ti22, ti23, ti31, ti32, ti33; + static integer ier; + static doublereal xph, thq, err, fac1, cfac, hacc, c1mc2, beta; + static integer lbeg; + static doublereal alph, hold; + static integer lend; + static doublereal delt, hnew; + static logical last; + static doublereal hopt, xold; + static integer newt; + static doublereal dyno, dyth, quot, hhfac, betan, alphn, denom, theta, + ysafe, hmaxn; + static integer nsing; + static logical first; + static integer irtrn, nrsol, nsolu; + static doublereal qnewt, xosol, acont3; + static logical index1, index2, index3, caljac; + static doublereal faccon; + extern /* Subroutine */ int decomc_(integer *, doublereal *, integer *, + doublereal *, integer *, integer *, integer *, integer *, integer + *, integer *, doublereal *, doublereal *, doublereal *, + doublereal *, integer *, integer *, integer *, integer *); + static logical calhes; + static doublereal erracc; + static integer mujacj; + extern /* Subroutine */ int decomr_(integer *, doublereal *, integer *, + doublereal *, integer *, integer *, integer *, integer *, integer + *, integer *, doublereal *, doublereal *, integer *, integer *, + integer *, integer *, logical *, integer *); + static logical reject; + static doublereal facgus; + static integer mujacp; + extern /* Subroutine */ int estrad_(integer *, doublereal *, integer *, + integer *, integer *, doublereal *, integer *, integer *, integer + *, doublereal *, doublereal *, doublereal *, doublereal *, FP_CB_f, void*, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, integer *, integer *, doublereal *, integer *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, integer *, integer *, + doublereal *, doublereal *, logical *, logical *, doublereal *, + doublereal *, integer *); + static doublereal dynold, posneg; + extern /* Subroutine */ int slvrad_(integer *, doublereal *, integer *, + integer *, integer *, doublereal *, integer *, integer *, integer + *, integer *, integer *, integer *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, integer *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, integer *, integer *, + integer *, integer *, integer *); + static doublereal thqold; + + /* ---------------------------------------------------------- */ + /* CORE INTEGRATOR FOR RADAU5 */ + /* PARAMETERS SAME AS IN RADAU5 WITH WORKSPACE ADDED */ + /* ---------------------------------------------------------- */ + /* DECLARATIONS */ + /* ---------------------------------------------------------- */ + /* *** *** *** *** *** *** *** */ + /* INITIALISATIONS */ + /* *** *** *** *** *** *** *** */ + /* --------- DUPLIFY N FOR COMMON BLOCK CONT ----- */ + + /* Parameter adjustments */ + doublereal *werr = (doublereal*) malloc(*n * sizeof(doublereal)); + --cont; + --f3; + --f2; + --f1; + --scal; + --y0; + --z3; + --z2; + --z1; + --y; + --rtol; + --atol; + --iphes; + --ip2; + --ip1; + --werr; + fjac_dim1 = *ldjac; + fjac_offset = 1 + fjac_dim1; + fjac -= fjac_offset; + e2i_dim1 = *lde1; + e2i_offset = 1 + e2i_dim1; + e2i -= e2i_offset; + e2r_dim1 = *lde1; + e2r_offset = 1 + e2r_dim1; + e2r -= e2r_offset; + e1_dim1 = *lde1; + e1_offset = 1 + e1_dim1; + e1 -= e1_offset; + fmas_dim1 = *ldmas; + fmas_offset = 1 + fmas_dim1; + fmas -= fmas_offset; + --rpar; + --ipar; + + /* Function Body */ + conra5_1.nn = *n; + conra5_1.nn2 = *n << 1; + conra5_1.nn3 = *n * 3; + lrc = *n << 2; + /* -------- CHECK THE INDEX OF THE PROBLEM ----- */ + index1 = *nind1 != 0; + index2 = *nind2 != 0; + index3 = *nind3 != 0; + /* ------- COMPUTE MASS MATRIX FOR IMPLICIT CASE ---------- */ + if (*implct) { + (*mas)(nm1, &fmas[fmas_offset], ldmas, &rpar[1], &ipar[1], mas_PY); + } + /* ---------- CONSTANTS --------- */ + sq6 = sqrt(6.); + c1 = (4. - sq6) / 10.; + c2 = (sq6 + 4.) / 10.; + conra5_1.c1m1 = c1 - 1.; + conra5_1.c2m1 = c2 - 1.; + c1mc2 = c1 - c2; + dd1 = -(sq6 * 7. + 13.) / 3.; + dd2 = (sq6 * 7. - 13.) / 3.; + dd3 = -.33333333333333331; + u1 = (pow(c_b91, c_b92) + 6. - pow(c_b93, c_b92)) / 30.; + alph = (12. - pow(c_b91, c_b92) + pow(c_b93, c_b92)) / 60.; + beta = (pow(c_b91, c_b92) + pow(c_b93, c_b92)) * sqrt(3.) / 60.; + /* Computing 2nd power */ + d__1 = alph; + /* Computing 2nd power */ + d__2 = beta; + cno = d__1 * d__1 + d__2 * d__2; + u1 = 1. / u1; + alph /= cno; + beta /= cno; + t11 = .091232394870892942792; + t12 = -.14125529502095420843; + t13 = -.030029194105147424492; + t21 = .24171793270710701896; + t22 = .20412935229379993199; + t23 = .38294211275726193779; + t31 = .96604818261509293619; + ti11 = 4.325579890063155351; + ti12 = .33919925181580986954; + ti13 = .54177053993587487119; + ti21 = -4.1787185915519047273; + ti22 = -.32768282076106238708; + ti23 = .47662355450055045196; + ti31 = -.50287263494578687595; + ti32 = 2.5719269498556054292; + ti33 = -.59603920482822492497; + if (*m1 > 0) { + *ijob += 10; + } + d__1 = *xend - *x; + posneg = copysign(1., d__1); + /* Computing MIN */ + d__2 = abs(*hmax), d__3 = (d__1 = *xend - *x, abs(d__1)); + hmaxn = min(d__2,d__3); + if (abs(*h__) <= *uround * 10.) { + *h__ = 1e-6; + } + /* Computing MIN */ + d__1 = abs(*h__); + *h__ = min(d__1,hmaxn); + *h__ = copysign(*h__, posneg); + hold = *h__; + reject = FALSE_; + first = TRUE_; + last = FALSE_; + if ((*x + *h__ * 1.0001 - *xend) * posneg >= 0.) { + *h__ = *xend - *x; + last = TRUE_; + } + hopt = *h__; + faccon = 1.; + cfac = *safe * ((*nit << 1) + 1); + nsing = 0; + nunexpect = 0; + xold = *x; + if (*iout != 0) { + irtrn = 1; + nrsol = 1; + xosol = xold; + conra5_1.xsol = *x; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + werr[i__] = 0.; + cont[i__] = y[i__]; + } + nsolu = *n; + conra5_1.hsol = hold; + (*solout)(&nrsol, &xosol, &conra5_1.xsol, &y[1], &cont[1], &werr[1], & + lrc, &nsolu, &rpar[1], &ipar[1], &irtrn, solout_PY); + if (irtrn < 0) { + goto L179; + } + } + linal_1.mle = *mljac; + linal_1.mue = *mujac; + linal_1.mbjac = *mljac + *mujac + 1; + linal_1.mbb = *mlmas + *mumas + 1; + linal_1.mdiag = linal_1.mle + linal_1.mue + 1; + linal_1.mdiff = linal_1.mle + linal_1.mue - *mumas; + linal_1.mbdiag = *mumas + 1; + n2 = *n << 1; + n3 = *n * 3; + if (*itol == 0) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + scal[i__] = atol[1] + rtol[1] * (d__1 = y[i__], abs(d__1)); + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + scal[i__] = atol[i__] + rtol[i__] * (d__1 = y[i__], abs(d__1)); + } + } + hhfac = *h__; + (*fcn)(n, x, &y[1], &y0[1], &rpar[1], &ipar[1], fcn_PY); + ++(*nfcn); +/* --- BASIC INTEGRATION STEP */ +L10: +/* *** *** *** *** *** *** *** */ +/* COMPUTATION OF THE JACOBIAN */ +/* *** *** *** *** *** *** *** */ + ++(*njac); + if (*ijac == 0) { + /* --- COMPUTE JACOBIAN MATRIX NUMERICALLY */ + if (*banded) { + /* --- JACOBIAN IS BANDED */ + mujacp = *mujac + 1; + md = min(linal_1.mbjac,*m2); + i__1 = *m1 / *m2 + 1; + for (mm = 1; mm <= i__1; ++mm) { + i__2 = md; + for (k = 1; k <= i__2; ++k) { + j = k + (mm - 1) * *m2; +L12: + f1[j] = y[j]; + /* Computing MAX */ + d__2 = 1e-5, d__3 = (d__1 = y[j], abs(d__1)); + f2[j] = sqrt(*uround * max(d__2,d__3)); + y[j] += f2[j]; + j += md; + if (j <= mm * *m2) { + goto L12; + } + (*fcn)(n, x, &y[1], &cont[1], &rpar[1], &ipar[1], fcn_PY); + j = k + (mm - 1) * *m2; + j1 = k; + /* Computing MAX */ + i__3 = 1, i__4 = j1 - *mujac; + lbeg = max(i__3,i__4) + *m1; +L14: + /* Computing MIN */ + i__3 = *m2, i__4 = j1 + *mljac; + lend = min(i__3,i__4) + *m1; + y[j] = f1[j]; + mujacj = mujacp - j1 - *m1; + i__3 = lend; + for (l = lbeg; l <= i__3; ++l) { + fjac[l + mujacj + j * fjac_dim1] = (cont[l] - y0[l]) / f2[j]; + } + j += md; + j1 += md; + lbeg = lend + 1; + if (j <= mm * *m2) { + goto L14; + } + } + } + } else { + /* --- JACOBIAN IS FULL */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + ysafe = y[i__]; + /* Computing MAX */ + d__1 = 1e-5, d__2 = abs(ysafe); + delt = sqrt(*uround * max(d__1,d__2)); + y[i__] = ysafe + delt; + (*fcn)(n, x, &y[1], &cont[1], &rpar[1], &ipar[1], fcn_PY); + if (ipar[1] < 0) { + y[i__] = ysafe - delt; + (*fcn)(n, x, &y[1], &cont[1], &rpar[1], &ipar[1], fcn_PY); + if (ipar[1] < 0) { + y[i__] = ysafe; + goto L79; + } + i__2 = *n; + for (j = *m1 + 1; j <= i__2; ++j) { + fjac[j - *m1 + i__ * fjac_dim1] = (y0[j] - cont[j]) / delt; + } + } else { + i__2 = *n; + for (j = *m1 + 1; j <= i__2; ++j) { + fjac[j - *m1 + i__ * fjac_dim1] = (cont[j] - y0[j]) / delt; + } + } + y[i__] = ysafe; + } + } + } else { + /* --- COMPUTE JACOBIAN MATRIX ANALYTICALLY */ + (*jac)(n, x, &y[1], &fjac[fjac_offset], ldjac, &rpar[1], &ipar[1], jac_PY); + } + caljac = TRUE_; + calhes = TRUE_; +L20: +/* --- COMPUTE THE MATRICES E1 AND E2 AND THEIR DECOMPOSITIONS */ + fac1 = u1 / *h__; + alphn = alph / *h__; + betan = beta / *h__; + decomr_(n, &fjac[fjac_offset], ldjac, &fmas[fmas_offset], ldmas, mlmas, + mumas, m1, m2, nm1, &fac1, &e1[e1_offset], lde1, &ip1[1], &ier, + ijob, &calhes, &iphes[1]); + if (ier != 0) { + goto L78; + } + decomc_(n, &fjac[fjac_offset], ldjac, &fmas[fmas_offset], ldmas, mlmas, + mumas, m1, m2, nm1, &alphn, &betan, &e2r[e2r_offset], &e2i[ + e2i_offset], lde1, &ip2[1], &ier, ijob); + if (ier != 0) { + goto L78; + } + ++(*ndec); +L30: + ++(*nstep); + if (*nstep > *nmax) { + goto L178; + } + if (abs(*h__) * .1 <= abs(*x) * *uround) { + goto L177; + } + if (index2) { + i__1 = *nind1 + *nind2; + for (i__ = *nind1 + 1; i__ <= i__1; ++i__) { + scal[i__] /= hhfac; + } + } + if (index3) { + i__1 = *nind1 + *nind2 + *nind3; + for (i__ = *nind1 + *nind2 + 1; i__ <= i__1; ++i__) { + scal[i__] /= hhfac * hhfac; + } + } + xph = *x + *h__; + /* *** *** *** *** *** *** *** */ + /* STARTING VALUES FOR NEWTON ITERATION */ + /* *** *** *** *** *** *** *** */ + if (first || *startn) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + z1[i__] = 0.; + z2[i__] = 0.; + z3[i__] = 0.; + f1[i__] = 0.; + f2[i__] = 0.; + f3[i__] = 0.; + } + } else { + c3q = *h__ / hold; + c1q = c1 * c3q; + c2q = c2 * c3q; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + ak1 = cont[i__ + *n]; + ak2 = cont[i__ + n2]; + ak3 = cont[i__ + n3]; + z1i = c1q * (ak1 + (c1q - conra5_1.c2m1) * (ak2 + (c1q - + conra5_1.c1m1) * ak3)); + z2i = c2q * (ak1 + (c2q - conra5_1.c2m1) * (ak2 + (c2q - + conra5_1.c1m1) * ak3)); + z3i = c3q * (ak1 + (c3q - conra5_1.c2m1) * (ak2 + (c3q - + conra5_1.c1m1) * ak3)); + z1[i__] = z1i; + z2[i__] = z2i; + z3[i__] = z3i; + f1[i__] = ti11 * z1i + ti12 * z2i + ti13 * z3i; + f2[i__] = ti21 * z1i + ti22 * z2i + ti23 * z3i; + f3[i__] = ti31 * z1i + ti32 * z2i + ti33 * z3i; + } + } + /* *** *** *** *** *** *** *** */ + /* LOOP FOR THE SIMPLIFIED NEWTON ITERATION */ + /* *** *** *** *** *** *** *** */ + newt = 0; + d__1 = max(faccon,*uround); + faccon = pow(d__1, c_b114); + theta = abs(*thet); +L40: + if (newt >= *nit) { + goto L78; + } + /* --- COMPUTE THE RIGHT-HAND SIDE */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + cont[i__] = y[i__] + z1[i__]; + } + d__1 = *x + c1 * *h__; + (*fcn)(n, &d__1, &cont[1], &z1[1], &rpar[1], &ipar[1], fcn_PY); + ++(*nfcn); + if (ipar[1] < 0) { + goto L79; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + cont[i__] = y[i__] + z2[i__]; + } + d__1 = *x + c2 * *h__; + (*fcn)(n, &d__1, &cont[1], &z2[1], &rpar[1], &ipar[1], fcn_PY); + ++(*nfcn); + if (ipar[1] < 0) { + goto L79; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + cont[i__] = y[i__] + z3[i__]; + } + (*fcn)(n, &xph, &cont[1], &z3[1], &rpar[1], &ipar[1], fcn_PY); + ++(*nfcn); + if (ipar[1] < 0) { + goto L79; + } +/* --- SOLVE THE LINEAR SYSTEMS */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + a1 = z1[i__]; + a2 = z2[i__]; + a3 = z3[i__]; + z1[i__] = ti11 * a1 + ti12 * a2 + ti13 * a3; + z2[i__] = ti21 * a1 + ti22 * a2 + ti23 * a3; + z3[i__] = ti31 * a1 + ti32 * a2 + ti33 * a3; + } + slvrad_(n, &fjac[fjac_offset], ldjac, mljac, mujac, &fmas[fmas_offset], + ldmas, mlmas, mumas, m1, m2, nm1, &fac1, &alphn, &betan, &e1[ + e1_offset], &e2r[e2r_offset], &e2i[e2i_offset], lde1, &z1[1], &z2[ + 1], &z3[1], &f1[1], &f2[1], &f3[1], &cont[1], &ip1[1], &ip2[1], & + iphes[1], &ier, ijob); + ++(*nsol); + ++newt; + dyno = 0.; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + denom = scal[i__]; + /* Computing 2nd power */ + d__1 = z1[i__] / denom; + /* Computing 2nd power */ + d__2 = z2[i__] / denom; + /* Computing 2nd power */ + d__3 = z3[i__] / denom; + dyno = dyno + d__1 * d__1 + d__2 * d__2 + d__3 * d__3; + } + dyno = sqrt(dyno / n3); + /* --- BAD CONVERGENCE OR NUMBER OF ITERATIONS TO LARGE */ + if (newt > 1 && newt < *nit) { + thq = dyno / dynold; + if (newt == 2) { + theta = thq; + } else { + theta = sqrt(thq * thqold); + } + thqold = thq; + if (theta < .99) { + faccon = theta / (1. - theta); + i__1 = *nit - 1 - newt; + dyth = faccon * dyno * pow(theta, i__1) / *fnewt; + if (dyth >= 1.) { + /* Computing MAX */ + d__1 = 1e-4, d__2 = min(20.,dyth); + qnewt = max(d__1,d__2); + d__1 = -1. / (*nit + 4. - 1 - newt); + hhfac = pow(qnewt, d__1) * .8; + *h__ = hhfac * *h__; + reject = TRUE_; + last = FALSE_; + if (caljac) { + goto L20; + } + goto L10; + } + } else { + goto L78; + } + } + dynold = max(dyno,*uround); + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + f1i = f1[i__] + z1[i__]; + f2i = f2[i__] + z2[i__]; + f3i = f3[i__] + z3[i__]; + f1[i__] = f1i; + f2[i__] = f2i; + f3[i__] = f3i; + z1[i__] = t11 * f1i + t12 * f2i + t13 * f3i; + z2[i__] = t21 * f1i + t22 * f2i + t23 * f3i; + z3[i__] = t31 * f1i + f2i; + } + if (faccon * dyno > *fnewt) { + goto L40; + } + /* --- ERROR ESTIMATION */ + estrad_(n, &fjac[fjac_offset], ldjac, mljac, mujac, &fmas[fmas_offset], + ldmas, mlmas, mumas, h__, &dd1, &dd2, &dd3, (FP_CB_f) fcn, fcn_PY, nfcn, &y0[ + 1], &y[1], ijob, x, m1, m2, nm1, &e1[e1_offset], lde1, &z1[1], & + z2[1], &z3[1], &cont[1], &werr[1], &f1[1], &f2[1], &ip1[1], & + iphes[1], &scal[1], &err, &first, &reject, &fac1, &rpar[1], &ipar[ + 1]); + /* --- COMPUTATION OF HNEW */ + /* --- WE REQUIRE .2<=HNEW/H<=8. */ + /* Computing MIN */ + d__1 = *safe, d__2 = cfac / (newt + (*nit << 1)); + fac = min(d__1,d__2); + /* Computing MAX */ + /* Computing MIN */ + d__3 = *facl, d__4 = pow(err, c_b116) / fac; + d__1 = *facr, d__2 = min(d__3,d__4); + quot = max(d__1,d__2); + hnew = *h__ / quot; + /* *** *** *** *** *** *** *** */ + /* IS THE ERROR SMALL ENOUGH ? */ + /* *** *** *** *** *** *** *** */ + if (err < 1.) { + /* --- STEP IS ACCEPTED */ + first = FALSE_; + ++(*naccpt); + if (*pred) { + /* --- PREDICTIVE CONTROLLER OF GUSTAFSSON */ + if (*naccpt > 1) { + /* Computing 2nd power */ + d__2 = err; + d__1 = d__2 * d__2 / erracc; + facgus = hacc / *h__ * pow(d__1, c_b116) / *safe; + /* Computing MAX */ + d__1 = *facr, d__2 = min(*facl,facgus); + facgus = max(d__1,d__2); + quot = max(quot,facgus); + hnew = *h__ / quot; + } + hacc = *h__; + erracc = max(.01,err); + } + xold = *x; + hold = *h__; + *x = xph; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] += z3[i__]; + z2i = z2[i__]; + z1i = z1[i__]; + cont[i__ + *n] = (z2i - z3[i__]) / conra5_1.c2m1; + ak = (z1i - z2i) / c1mc2; + acont3 = z1i / c1; + acont3 = (ak - acont3) / c2; + cont[i__ + n2] = (ak - cont[i__ + *n]) / conra5_1.c1m1; + cont[i__ + n3] = cont[i__ + n2] - acont3; + } + if (*itol == 0) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + scal[i__] = atol[1] + rtol[1] * (d__1 = y[i__], abs(d__1)); + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + scal[i__] = atol[i__] + rtol[i__] * (d__1 = y[i__], abs(d__1)); + } + } + if (*iout != 0) { + nrsol = *naccpt + 1; + conra5_1.xsol = *x; + xosol = xold; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + cont[i__] = y[i__]; + } + nsolu = *n; + conra5_1.hsol = hold; + (*solout)(&nrsol, &xosol, &conra5_1.xsol, &y[1], &cont[1], &werr[ + 1], &lrc, &nsolu, &rpar[1], &ipar[1], &irtrn, solout_PY); + if (irtrn < 0) { + goto L179; + } + } + caljac = FALSE_; + if (last) { + *h__ = hopt; + *idid = 1; + return 0; + } + (*fcn)(n, x, &y[1], &y0[1], &rpar[1], &ipar[1], fcn_PY); + ++(*nfcn); + /* Computing MIN */ + d__1 = abs(hnew); + hnew = posneg * min(d__1,hmaxn); + hopt = hnew; + hopt = min(*h__,hnew); + if (reject) { + /* Computing MIN */ + d__1 = abs(hnew), d__2 = abs(*h__); + hnew = posneg * min(d__1,d__2); + } + reject = FALSE_; + if ((*x + hnew / *quot1 - *xend) * posneg >= 0.) { + *h__ = *xend - *x; + last = TRUE_; + } else { + qt = hnew / *h__; + hhfac = *h__; + if (theta <= *thet && qt >= *quot1 && qt <= *quot2) { + goto L30; + } + *h__ = hnew; + } + hhfac = *h__; + if (theta <= *thet) { + goto L20; + } + goto L10; + } else { + /* --- STEP IS REJECTED */ + reject = TRUE_; + last = FALSE_; + if (first) { + *h__ *= .1; + hhfac = .1; + } else { + hhfac = hnew / *h__; + *h__ = hnew; + } + if (*naccpt >= 1) { + ++(*nrejct); + } + if (caljac) { + goto L20; + } + goto L10; + } +/* --- UNEXPECTED STEP-REJECTION */ +L78: + if (ier != 0) { + ++nsing; + if (nsing >= 5) { + goto L176; + } + } + *h__ *= .5; + hhfac = .5; + reject = TRUE_; + last = FALSE_; + if (caljac) { + goto L20; + } + goto L10; +L79: + ++nunexpect; + if (nunexpect >= 10) { + goto L175; + } + *h__ *= .5; + hhfac = .5; + reject = TRUE_; + last = FALSE_; + if (caljac) { + goto L20; + } + goto L10; +/* --- FAIL EXIT */ +L175: + printf("EXIT OF RADAU5 AT X = %e \n", *x); + printf("REPEATEDLY UNEXPECTED STEP REJECTIONS\n"); + *idid = -5; + return 0; +L176: + printf("EXIT OF RADAU5 AT X = %e \n", *x); + printf("MATRIX IS REPEATEDLY SINGULAR IER= %"PRId64"\n", ier); + *idid = -4; + return 0; +L177: + printf("EXIT OF RADAU5 AT X = %e \n", *x); + printf("STEP SIZE TOO SMALL, H= %e", *h__); + *idid = -3; + return 0; +L178: + printf("EXIT OF RADAU5 AT X = %e \n", *x); + printf("MORE THAN NMAX = %"PRId64" STEPS ARE NEEDED", *nmax); + *idid = -2; + return 0; +/* --- EXIT CAUSED BY SOLOUT */ +L179: +/* WRITE(6,979)X */ + *idid = 2; + return 0; +} /* radcor_ */ + + +/* END OF SUBROUTINE RADCOR */ + +/* *********************************************************** */ + +doublereal contr5_c(integer *i__, doublereal *x, doublereal *cont, integer * + lrc) +{ + /* System generated locals */ + doublereal ret_val; + + /* Local variables */ + static doublereal s; + +/* ---------------------------------------------------------- */ +/* THIS FUNCTION CAN BE USED FOR CONINUOUS OUTPUT. IT PROVIDES AN */ +/* APPROXIMATION TO THE I-TH COMPONENT OF THE SOLUTION AT X. */ +/* IT GIVES THE VALUE OF THE COLLOCATION POLYNOMIAL, DEFINED FOR */ +/* THE LAST SUCCESSFULLY COMPUTED STEP (BY RADAU5). */ +/* ---------------------------------------------------------- */ + /* Parameter adjustments */ + --cont; + + /* Function Body */ + s = (*x - conra5_1.xsol) / conra5_1.hsol; + ret_val = cont[*i__] + s * (cont[*i__ + conra5_1.nn] + (s - conra5_1.c2m1) + * (cont[*i__ + conra5_1.nn2] + (s - conra5_1.c1m1) * cont[*i__ + + conra5_1.nn3])); + return ret_val; +} /* contr5_ */ + + +/* END OF FUNCTION CONTR5 */ + +/* *********************************************************** */ +/* Subroutine */ int dec_(integer *n, integer *ndim, doublereal *a, integer * + ip, integer *ier) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + doublereal d__1, d__2; + + /* Local variables */ + static integer i__, j, k, m; + static doublereal t; + static integer nm1, kp1; + +/* VERSION REAL DOUBLE PRECISION */ +/* ----------------------------------------------------------------------- */ +/* MATRIX TRIANGULARIZATION BY GAUSSIAN ELIMINATION. */ +/* INPUT.. */ +/* N = ORDER OF MATRIX. */ +/* NDIM = DECLARED DIMENSION OF ARRAY A . */ +/* A = MATRIX TO BE TRIANGULARIZED. */ +/* OUTPUT.. */ +/* A(I,J), I.LE.J = UPPER TRIANGULAR FACTOR, U . */ +/* A(I,J), I.GT.J = MULTIPLIERS = LOWER TRIANGULAR FACTOR, I - L. */ +/* IP(K), K.LT.N = INDEX OF K-TH PIVOT ROW. */ +/* IP(N) = (-1)**(NUMBER OF INTERCHANGES) OR O . */ +/* IER = 0 IF MATRIX A IS NONSINGULAR, OR K IF FOUND TO BE */ +/* SINGULAR AT STAGE K. */ +/* USE SOL TO OBTAIN SOLUTION OF LINEAR SYSTEM. */ +/* DETERM(A) = IP(N)*A(1,1)*A(2,2)*...*A(N,N). */ +/* IF IP(N)=O, A IS SINGULAR, SOL WILL DIVIDE BY ZERO. */ + +/* REFERENCE.. */ +/* C. B. MOLER, ALGORITHM 423, LINEAR EQUATION SOLVER, */ +/* C.A.C.M. 15 (1972), P. 274. */ +/* ----------------------------------------------------------------------- */ + /* Parameter adjustments */ + --ip; + a_dim1 = *ndim; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + *ier = 0; + ip[*n] = 1; + if (*n == 1) { + goto L70; + } + nm1 = *n - 1; + i__1 = nm1; + for (k = 1; k <= i__1; ++k) { + kp1 = k + 1; + m = k; + i__2 = *n; + for (i__ = kp1; i__ <= i__2; ++i__) { + if ((d__1 = a[i__ + k * a_dim1], abs(d__1)) > (d__2 = a[m + k * + a_dim1], abs(d__2))) { + m = i__; + } + /* L10: */ + } + ip[k] = m; + t = a[m + k * a_dim1]; + if (m == k) { + goto L20; + } + ip[*n] = -ip[*n]; + a[m + k * a_dim1] = a[k + k * a_dim1]; + a[k + k * a_dim1] = t; +L20: + if (t == 0.) { + goto L80; + } + t = 1. / t; + i__2 = *n; + for (i__ = kp1; i__ <= i__2; ++i__) { + /* L30: */ + a[i__ + k * a_dim1] = -a[i__ + k * a_dim1] * t; + } + i__2 = *n; + for (j = kp1; j <= i__2; ++j) { + t = a[m + j * a_dim1]; + a[m + j * a_dim1] = a[k + j * a_dim1]; + a[k + j * a_dim1] = t; + if (t == 0.) { + goto L45; + } + i__3 = *n; + for (i__ = kp1; i__ <= i__3; ++i__) { + /* L40: */ + a[i__ + j * a_dim1] += a[i__ + k * a_dim1] * t; + } +L45: + /* L50: */ + ; + } + /* L60: */ + } +L70: + k = *n; + if (a[*n + *n * a_dim1] == 0.) { + goto L80; + } + return 0; +L80: + *ier = k; + ip[*n] = 0; + return 0; +/* ----------------------- END OF SUBROUTINE DEC ------------------------- */ +} /* dec_ */ + + + +/* Subroutine */ int sol_(integer *n, integer *ndim, doublereal *a, + doublereal *b, integer *ip) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + static integer i__, k, m; + static doublereal t; + static integer kb, km1, nm1, kp1; + +/* VERSION REAL DOUBLE PRECISION */ +/* ----------------------------------------------------------------------- */ +/* SOLUTION OF LINEAR SYSTEM, A*X = B . */ +/* INPUT.. */ +/* N = ORDER OF MATRIX. */ +/* NDIM = DECLARED DIMENSION OF ARRAY A . */ +/* A = TRIANGULARIZED MATRIX OBTAINED FROM DEC. */ +/* B = RIGHT HAND SIDE VECTOR. */ +/* IP = PIVOT VECTOR OBTAINED FROM DEC. */ +/* DO NOT USE IF DEC HAS SET IER .NE. 0. */ +/* OUTPUT.. */ +/* B = SOLUTION VECTOR, X . */ +/* ----------------------------------------------------------------------- */ + /* Parameter adjustments */ + --ip; + --b; + a_dim1 = *ndim; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + if (*n == 1) { + goto L50; + } + nm1 = *n - 1; + i__1 = nm1; + for (k = 1; k <= i__1; ++k) { + kp1 = k + 1; + m = ip[k]; + t = b[m]; + b[m] = b[k]; + b[k] = t; + i__2 = *n; + for (i__ = kp1; i__ <= i__2; ++i__) { + /* L10: */ + b[i__] += a[i__ + k * a_dim1] * t; + } + /* L20: */ + } + i__1 = nm1; + for (kb = 1; kb <= i__1; ++kb) { + km1 = *n - kb; + k = km1 + 1; + b[k] /= a[k + k * a_dim1]; + t = -b[k]; + i__2 = km1; + for (i__ = 1; i__ <= i__2; ++i__) { + /* L30: */ + b[i__] += a[i__ + k * a_dim1] * t; + } + /* L40: */ + } +L50: + b[1] /= a[a_dim1 + 1]; + return 0; +/* ----------------------- END OF SUBROUTINE SOL ------------------------- */ +} /* sol_ */ + + + +/* Subroutine */ int dech_(integer *n, integer *ndim, doublereal *a, integer * + lb, integer *ip, integer *ier) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + doublereal d__1, d__2; + + /* Local variables */ + static integer i__, j, k, m; + static doublereal t; + static integer na, nm1, kp1; + +/* VERSION REAL DOUBLE PRECISION */ +/* ----------------------------------------------------------------------- */ +/* MATRIX TRIANGULARIZATION BY GAUSSIAN ELIMINATION OF A HESSENBERG */ +/* MATRIX WITH LOWER BANDWIDTH LB */ +/* INPUT.. */ +/* N = ORDER OF MATRIX A. */ +/* NDIM = DECLARED DIMENSION OF ARRAY A . */ +/* A = MATRIX TO BE TRIANGULARIZED. */ +/* LB = LOWER BANDWIDTH OF A (DIAGONAL IS NOT COUNTED, LB.GE.1). */ +/* OUTPUT.. */ +/* A(I,J), I.LE.J = UPPER TRIANGULAR FACTOR, U . */ +/* A(I,J), I.GT.J = MULTIPLIERS = LOWER TRIANGULAR FACTOR, I - L. */ +/* IP(K), K.LT.N = INDEX OF K-TH PIVOT ROW. */ +/* IP(N) = (-1)**(NUMBER OF INTERCHANGES) OR O . */ +/* IER = 0 IF MATRIX A IS NONSINGULAR, OR K IF FOUND TO BE */ +/* SINGULAR AT STAGE K. */ +/* USE SOLH TO OBTAIN SOLUTION OF LINEAR SYSTEM. */ +/* DETERM(A) = IP(N)*A(1,1)*A(2,2)*...*A(N,N). */ +/* IF IP(N)=O, A IS SINGULAR, SOL WILL DIVIDE BY ZERO. */ + +/* REFERENCE.. */ +/* THIS IS A SLIGHT MODIFICATION OF */ +/* C. B. MOLER, ALGORITHM 423, LINEAR EQUATION SOLVER, */ +/* C.A.C.M. 15 (1972), P. 274. */ +/* ----------------------------------------------------------------------- */ + /* Parameter adjustments */ + --ip; + a_dim1 = *ndim; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + *ier = 0; + ip[*n] = 1; + if (*n == 1) { + goto L70; + } + nm1 = *n - 1; + i__1 = nm1; + for (k = 1; k <= i__1; ++k) { + kp1 = k + 1; + m = k; + /* Computing MIN */ + i__2 = *n, i__3 = *lb + k; + na = min(i__2,i__3); + i__2 = na; + for (i__ = kp1; i__ <= i__2; ++i__) { + if ((d__1 = a[i__ + k * a_dim1], abs(d__1)) > (d__2 = a[m + k * + a_dim1], abs(d__2))) { + m = i__; + } + /* L10: */ + } + ip[k] = m; + t = a[m + k * a_dim1]; + if (m == k) { + goto L20; + } + ip[*n] = -ip[*n]; + a[m + k * a_dim1] = a[k + k * a_dim1]; + a[k + k * a_dim1] = t; +L20: + if (t == 0.) { + goto L80; + } + t = 1. / t; + i__2 = na; + for (i__ = kp1; i__ <= i__2; ++i__) { + /* L30: */ + a[i__ + k * a_dim1] = -a[i__ + k * a_dim1] * t; + } + i__2 = *n; + for (j = kp1; j <= i__2; ++j) { + t = a[m + j * a_dim1]; + a[m + j * a_dim1] = a[k + j * a_dim1]; + a[k + j * a_dim1] = t; + if (t == 0.) { + goto L45; + } + i__3 = na; + for (i__ = kp1; i__ <= i__3; ++i__) { + /* L40: */ + a[i__ + j * a_dim1] += a[i__ + k * a_dim1] * t; + } +L45: + /* L50: */ + ; + } + /* L60: */ + } +L70: + k = *n; + if (a[*n + *n * a_dim1] == 0.) { + goto L80; + } + return 0; +L80: + *ier = k; + ip[*n] = 0; + return 0; +/* ----------------------- END OF SUBROUTINE DECH ------------------------ */ +} /* dech_ */ + + + +/* Subroutine */ int solh_(integer *n, integer *ndim, doublereal *a, integer * + lb, doublereal *b, integer *ip) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + + /* Local variables */ + static integer i__, k, m; + static doublereal t; + static integer kb, na, km1, nm1, kp1; + +/* VERSION REAL DOUBLE PRECISION */ +/* ----------------------------------------------------------------------- */ +/* SOLUTION OF LINEAR SYSTEM, A*X = B . */ +/* INPUT.. */ +/* N = ORDER OF MATRIX A. */ +/* NDIM = DECLARED DIMENSION OF ARRAY A . */ +/* A = TRIANGULARIZED MATRIX OBTAINED FROM DECH. */ +/* LB = LOWER BANDWIDTH OF A. */ +/* B = RIGHT HAND SIDE VECTOR. */ +/* IP = PIVOT VECTOR OBTAINED FROM DEC. */ +/* DO NOT USE IF DECH HAS SET IER .NE. 0. */ +/* OUTPUT.. */ +/* B = SOLUTION VECTOR, X . */ +/* ----------------------------------------------------------------------- */ + /* Parameter adjustments */ + --ip; + --b; + a_dim1 = *ndim; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + if (*n == 1) { + goto L50; + } + nm1 = *n - 1; + i__1 = nm1; + for (k = 1; k <= i__1; ++k) { + kp1 = k + 1; + m = ip[k]; + t = b[m]; + b[m] = b[k]; + b[k] = t; + /* Computing MIN */ + i__2 = *n, i__3 = *lb + k; + na = min(i__2,i__3); + i__2 = na; + for (i__ = kp1; i__ <= i__2; ++i__) { + /* L10: */ + b[i__] += a[i__ + k * a_dim1] * t; + } + /* L20: */ + } + i__1 = nm1; + for (kb = 1; kb <= i__1; ++kb) { + km1 = *n - kb; + k = km1 + 1; + b[k] /= a[k + k * a_dim1]; + t = -b[k]; + i__2 = km1; + for (i__ = 1; i__ <= i__2; ++i__) { + /* L30: */ + b[i__] += a[i__ + k * a_dim1] * t; + } + /* L40: */ + } +L50: + b[1] /= a[a_dim1 + 1]; + return 0; +/* ----------------------- END OF SUBROUTINE SOLH ------------------------ */ +} /* solh_ */ + + +/* Subroutine */ int decc_(integer *n, integer *ndim, doublereal *ar, + doublereal *ai, integer *ip, integer *ier) +{ + /* System generated locals */ + integer ar_dim1, ar_offset, ai_dim1, ai_offset, i__1, i__2, i__3; + doublereal d__1, d__2, d__3, d__4; + + /* Local variables */ + static integer i__, j, k, m; + static doublereal ti, tr; + static integer nm1, kp1; + static doublereal den, prodi, prodr; + +/* VERSION COMPLEX DOUBLE PRECISION */ +/* ----------------------------------------------------------------------- */ +/* MATRIX TRIANGULARIZATION BY GAUSSIAN ELIMINATION */ +/* ------ MODIFICATION FOR COMPLEX MATRICES -------- */ +/* INPUT.. */ +/* N = ORDER OF MATRIX. */ +/* NDIM = DECLARED DIMENSION OF ARRAYS AR AND AI . */ +/* (AR, AI) = MATRIX TO BE TRIANGULARIZED. */ +/* OUTPUT.. */ +/* AR(I,J), I.LE.J = UPPER TRIANGULAR FACTOR, U ; REAL PART. */ +/* AI(I,J), I.LE.J = UPPER TRIANGULAR FACTOR, U ; IMAGINARY PART. */ +/* AR(I,J), I.GT.J = MULTIPLIERS = LOWER TRIANGULAR FACTOR, I - L. */ +/* REAL PART. */ +/* AI(I,J), I.GT.J = MULTIPLIERS = LOWER TRIANGULAR FACTOR, I - L. */ +/* IMAGINARY PART. */ +/* IP(K), K.LT.N = INDEX OF K-TH PIVOT ROW. */ +/* IP(N) = (-1)**(NUMBER OF INTERCHANGES) OR O . */ +/* IER = 0 IF MATRIX A IS NONSINGULAR, OR K IF FOUND TO BE */ +/* SINGULAR AT STAGE K. */ +/* USE SOL TO OBTAIN SOLUTION OF LINEAR SYSTEM. */ +/* IF IP(N)=O, A IS SINGULAR, SOL WILL DIVIDE BY ZERO. */ + +/* REFERENCE.. */ +/* C. B. MOLER, ALGORITHM 423, LINEAR EQUATION SOLVER, */ +/* C.A.C.M. 15 (1972), P. 274. */ +/* ----------------------------------------------------------------------- */ + /* Parameter adjustments */ + --ip; + ai_dim1 = *ndim; + ai_offset = 1 + ai_dim1; + ai -= ai_offset; + ar_dim1 = *ndim; + ar_offset = 1 + ar_dim1; + ar -= ar_offset; + + /* Function Body */ + *ier = 0; + ip[*n] = 1; + if (*n == 1) { + goto L70; + } + nm1 = *n - 1; + i__1 = nm1; + for (k = 1; k <= i__1; ++k) { + kp1 = k + 1; + m = k; + i__2 = *n; + for (i__ = kp1; i__ <= i__2; ++i__) { + if ((d__1 = ar[i__ + k * ar_dim1], abs(d__1)) + (d__2 = ai[i__ + + k * ai_dim1], abs(d__2)) > (d__3 = ar[m + k * ar_dim1], + abs(d__3)) + (d__4 = ai[m + k * ai_dim1], abs(d__4))) { + m = i__; + } + /* L10: */ + } + ip[k] = m; + tr = ar[m + k * ar_dim1]; + ti = ai[m + k * ai_dim1]; + if (m == k) { + goto L20; + } + ip[*n] = -ip[*n]; + ar[m + k * ar_dim1] = ar[k + k * ar_dim1]; + ai[m + k * ai_dim1] = ai[k + k * ai_dim1]; + ar[k + k * ar_dim1] = tr; + ai[k + k * ai_dim1] = ti; +L20: + if (abs(tr) + abs(ti) == 0.) { + goto L80; + } + den = tr * tr + ti * ti; + tr /= den; + ti = -ti / den; + i__2 = *n; + for (i__ = kp1; i__ <= i__2; ++i__) { + prodr = ar[i__ + k * ar_dim1] * tr - ai[i__ + k * ai_dim1] * ti; + prodi = ai[i__ + k * ai_dim1] * tr + ar[i__ + k * ar_dim1] * ti; + ar[i__ + k * ar_dim1] = -prodr; + ai[i__ + k * ai_dim1] = -prodi; + /* L30: */ + } + i__2 = *n; + for (j = kp1; j <= i__2; ++j) { + tr = ar[m + j * ar_dim1]; + ti = ai[m + j * ai_dim1]; + ar[m + j * ar_dim1] = ar[k + j * ar_dim1]; + ai[m + j * ai_dim1] = ai[k + j * ai_dim1]; + ar[k + j * ar_dim1] = tr; + ai[k + j * ai_dim1] = ti; + if (abs(tr) + abs(ti) == 0.) { + goto L48; + } + if (ti == 0.) { + i__3 = *n; + for (i__ = kp1; i__ <= i__3; ++i__) { + prodr = ar[i__ + k * ar_dim1] * tr; + prodi = ai[i__ + k * ai_dim1] * tr; + ar[i__ + j * ar_dim1] += prodr; + ai[i__ + j * ai_dim1] += prodi; + /* L40: */ + } + goto L48; + } + if (tr == 0.) { + i__3 = *n; + for (i__ = kp1; i__ <= i__3; ++i__) { + prodr = -ai[i__ + k * ai_dim1] * ti; + prodi = ar[i__ + k * ar_dim1] * ti; + ar[i__ + j * ar_dim1] += prodr; + ai[i__ + j * ai_dim1] += prodi; + /* L45: */ + } + goto L48; + } + i__3 = *n; + for (i__ = kp1; i__ <= i__3; ++i__) { + prodr = ar[i__ + k * ar_dim1] * tr - ai[i__ + k * ai_dim1] * ti; + prodi = ai[i__ + k * ai_dim1] * tr + ar[i__ + k * ar_dim1] * ti; + ar[i__ + j * ar_dim1] += prodr; + ai[i__ + j * ai_dim1] += prodi; + /* L47: */ + } +L48: + /* L50: */ + ; + } + /* L60: */ + } +L70: + k = *n; + if ((d__1 = ar[*n + *n * ar_dim1], abs(d__1)) + (d__2 = ai[*n + *n * + ai_dim1], abs(d__2)) == 0.) { + goto L80; + } + return 0; +L80: + *ier = k; + ip[*n] = 0; + return 0; +/* ----------------------- END OF SUBROUTINE DECC ------------------------ */ +} /* decc_ */ + + + +/* Subroutine */ int solc_(integer *n, integer *ndim, doublereal *ar, + doublereal *ai, doublereal *br, doublereal *bi, integer *ip) +{ + /* System generated locals */ + integer ar_dim1, ar_offset, ai_dim1, ai_offset, i__1, i__2; + + /* Local variables */ + static integer i__, k, m, kb; + static doublereal ti, tr; + static integer km1, nm1, kp1; + static doublereal den, prodi, prodr; + +/* VERSION COMPLEX DOUBLE PRECISION */ +/* ----------------------------------------------------------------------- */ +/* SOLUTION OF LINEAR SYSTEM, A*X = B . */ +/* INPUT.. */ +/* N = ORDER OF MATRIX. */ +/* NDIM = DECLARED DIMENSION OF ARRAYS AR AND AI. */ +/* (AR,AI) = TRIANGULARIZED MATRIX OBTAINED FROM DEC. */ +/* (BR,BI) = RIGHT HAND SIDE VECTOR. */ +/* IP = PIVOT VECTOR OBTAINED FROM DEC. */ +/* DO NOT USE IF DEC HAS SET IER .NE. 0. */ +/* OUTPUT.. */ +/* (BR,BI) = SOLUTION VECTOR, X . */ +/* ----------------------------------------------------------------------- */ + /* Parameter adjustments */ + --ip; + --bi; + --br; + ai_dim1 = *ndim; + ai_offset = 1 + ai_dim1; + ai -= ai_offset; + ar_dim1 = *ndim; + ar_offset = 1 + ar_dim1; + ar -= ar_offset; + + /* Function Body */ + if (*n == 1) { + goto L50; + } + nm1 = *n - 1; + i__1 = nm1; + for (k = 1; k <= i__1; ++k) { + kp1 = k + 1; + m = ip[k]; + tr = br[m]; + ti = bi[m]; + br[m] = br[k]; + bi[m] = bi[k]; + br[k] = tr; + bi[k] = ti; + i__2 = *n; + for (i__ = kp1; i__ <= i__2; ++i__) { + prodr = ar[i__ + k * ar_dim1] * tr - ai[i__ + k * ai_dim1] * ti; + prodi = ai[i__ + k * ai_dim1] * tr + ar[i__ + k * ar_dim1] * ti; + br[i__] += prodr; + bi[i__] += prodi; + /* L10: */ + } + /* L20: */ + } + i__1 = nm1; + for (kb = 1; kb <= i__1; ++kb) { + km1 = *n - kb; + k = km1 + 1; + den = ar[k + k * ar_dim1] * ar[k + k * ar_dim1] + ai[k + k * ai_dim1] + * ai[k + k * ai_dim1]; + prodr = br[k] * ar[k + k * ar_dim1] + bi[k] * ai[k + k * ai_dim1]; + prodi = bi[k] * ar[k + k * ar_dim1] - br[k] * ai[k + k * ai_dim1]; + br[k] = prodr / den; + bi[k] = prodi / den; + tr = -br[k]; + ti = -bi[k]; + i__2 = km1; + for (i__ = 1; i__ <= i__2; ++i__) { + prodr = ar[i__ + k * ar_dim1] * tr - ai[i__ + k * ai_dim1] * ti; + prodi = ai[i__ + k * ai_dim1] * tr + ar[i__ + k * ar_dim1] * ti; + br[i__] += prodr; + bi[i__] += prodi; + /* L30: */ + } + /* L40: */ + } +L50: + den = ar[ar_dim1 + 1] * ar[ar_dim1 + 1] + ai[ai_dim1 + 1] * ai[ai_dim1 + 1]; + prodr = br[1] * ar[ar_dim1 + 1] + bi[1] * ai[ai_dim1 + 1]; + prodi = bi[1] * ar[ar_dim1 + 1] - br[1] * ai[ai_dim1 + 1]; + br[1] = prodr / den; + bi[1] = prodi / den; + return 0; +/* ----------------------- END OF SUBROUTINE SOLC ------------------------ */ +} /* solc_ */ + + + +/* Subroutine */ int dechc_(integer *n, integer *ndim, doublereal *ar, + doublereal *ai, integer *lb, integer *ip, integer *ier) +{ + /* System generated locals */ + integer ar_dim1, ar_offset, ai_dim1, ai_offset, i__1, i__2, i__3; + doublereal d__1, d__2, d__3, d__4; + + /* Local variables */ + static integer i__, j, k, m, na; + static doublereal ti, tr; + static integer nm1, kp1; + static doublereal den, prodi, prodr; + +/* VERSION COMPLEX DOUBLE PRECISION */ +/* ----------------------------------------------------------------------- */ +/* MATRIX TRIANGULARIZATION BY GAUSSIAN ELIMINATION */ +/* ------ MODIFICATION FOR COMPLEX MATRICES -------- */ +/* INPUT.. */ +/* N = ORDER OF MATRIX. */ +/* NDIM = DECLARED DIMENSION OF ARRAYS AR AND AI . */ +/* (AR, AI) = MATRIX TO BE TRIANGULARIZED. */ +/* OUTPUT.. */ +/* AR(I,J), I.LE.J = UPPER TRIANGULAR FACTOR, U ; REAL PART. */ +/* AI(I,J), I.LE.J = UPPER TRIANGULAR FACTOR, U ; IMAGINARY PART. */ +/* AR(I,J), I.GT.J = MULTIPLIERS = LOWER TRIANGULAR FACTOR, I - L. */ +/* REAL PART. */ +/* AI(I,J), I.GT.J = MULTIPLIERS = LOWER TRIANGULAR FACTOR, I - L. */ +/* IMAGINARY PART. */ +/* LB = LOWER BANDWIDTH OF A (DIAGONAL NOT COUNTED), LB.GE.1. */ +/* IP(K), K.LT.N = INDEX OF K-TH PIVOT ROW. */ +/* IP(N) = (-1)**(NUMBER OF INTERCHANGES) OR O . */ +/* IER = 0 IF MATRIX A IS NONSINGULAR, OR K IF FOUND TO BE */ +/* SINGULAR AT STAGE K. */ +/* USE SOL TO OBTAIN SOLUTION OF LINEAR SYSTEM. */ +/* IF IP(N)=O, A IS SINGULAR, SOL WILL DIVIDE BY ZERO. */ + +/* REFERENCE.. */ +/* C. B. MOLER, ALGORITHM 423, LINEAR EQUATION SOLVER, */ +/* C.A.C.M. 15 (1972), P. 274. */ +/* ----------------------------------------------------------------------- */ + /* Parameter adjustments */ + --ip; + ai_dim1 = *ndim; + ai_offset = 1 + ai_dim1; + ai -= ai_offset; + ar_dim1 = *ndim; + ar_offset = 1 + ar_dim1; + ar -= ar_offset; + + /* Function Body */ + *ier = 0; + ip[*n] = 1; + if (*lb == 0) { + goto L70; + } + if (*n == 1) { + goto L70; + } + nm1 = *n - 1; + i__1 = nm1; + for (k = 1; k <= i__1; ++k) { + kp1 = k + 1; + m = k; + /* Computing MIN */ + i__2 = *n, i__3 = *lb + k; + na = min(i__2,i__3); + i__2 = na; + for (i__ = kp1; i__ <= i__2; ++i__) { + if ((d__1 = ar[i__ + k * ar_dim1], abs(d__1)) + (d__2 = ai[i__ + + k * ai_dim1], abs(d__2)) > (d__3 = ar[m + k * ar_dim1], + abs(d__3)) + (d__4 = ai[m + k * ai_dim1], abs(d__4))) { + m = i__; + } + /* L10: */ + } + ip[k] = m; + tr = ar[m + k * ar_dim1]; + ti = ai[m + k * ai_dim1]; + if (m == k) { + goto L20; + } + ip[*n] = -ip[*n]; + ar[m + k * ar_dim1] = ar[k + k * ar_dim1]; + ai[m + k * ai_dim1] = ai[k + k * ai_dim1]; + ar[k + k * ar_dim1] = tr; + ai[k + k * ai_dim1] = ti; +L20: + if (abs(tr) + abs(ti) == 0.) { + goto L80; + } + den = tr * tr + ti * ti; + tr /= den; + ti = -ti / den; + i__2 = na; + for (i__ = kp1; i__ <= i__2; ++i__) { + prodr = ar[i__ + k * ar_dim1] * tr - ai[i__ + k * ai_dim1] * ti; + prodi = ai[i__ + k * ai_dim1] * tr + ar[i__ + k * ar_dim1] * ti; + ar[i__ + k * ar_dim1] = -prodr; + ai[i__ + k * ai_dim1] = -prodi; + /* L30: */ + } + i__2 = *n; + for (j = kp1; j <= i__2; ++j) { + tr = ar[m + j * ar_dim1]; + ti = ai[m + j * ai_dim1]; + ar[m + j * ar_dim1] = ar[k + j * ar_dim1]; + ai[m + j * ai_dim1] = ai[k + j * ai_dim1]; + ar[k + j * ar_dim1] = tr; + ai[k + j * ai_dim1] = ti; + if (abs(tr) + abs(ti) == 0.) { + goto L48; + } + if (ti == 0.) { + i__3 = na; + for (i__ = kp1; i__ <= i__3; ++i__) { + prodr = ar[i__ + k * ar_dim1] * tr; + prodi = ai[i__ + k * ai_dim1] * tr; + ar[i__ + j * ar_dim1] += prodr; + ai[i__ + j * ai_dim1] += prodi; + /* L40: */ + } + goto L48; + } + if (tr == 0.) { + i__3 = na; + for (i__ = kp1; i__ <= i__3; ++i__) { + prodr = -ai[i__ + k * ai_dim1] * ti; + prodi = ar[i__ + k * ar_dim1] * ti; + ar[i__ + j * ar_dim1] += prodr; + ai[i__ + j * ai_dim1] += prodi; + /* L45: */ + } + goto L48; + } + i__3 = na; + for (i__ = kp1; i__ <= i__3; ++i__) { + prodr = ar[i__ + k * ar_dim1] * tr - ai[i__ + k * ai_dim1] * ti; + prodi = ai[i__ + k * ai_dim1] * tr + ar[i__ + k * ar_dim1] * ti; + ar[i__ + j * ar_dim1] += prodr; + ai[i__ + j * ai_dim1] += prodi; + /* L47: */ + } +L48: + /* L50: */ + ; + } + /* L60: */ + } +L70: + k = *n; + if ((d__1 = ar[*n + *n * ar_dim1], abs(d__1)) + (d__2 = ai[*n + *n * + ai_dim1], abs(d__2)) == 0.) { + goto L80; + } + return 0; +L80: + *ier = k; + ip[*n] = 0; + return 0; +/* ----------------------- END OF SUBROUTINE DECHC ----------------------- */ +} /* dechc_ */ + + + +/* Subroutine */ int solhc_(integer *n, integer *ndim, doublereal *ar, + doublereal *ai, integer *lb, doublereal *br, doublereal *bi, integer * + ip) +{ + /* System generated locals */ + integer ar_dim1, ar_offset, ai_dim1, ai_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + static integer i__, k, m, kb; + static doublereal ti, tr; + static integer km1, nm1, kp1; + static doublereal den, prodi, prodr; + +/* VERSION COMPLEX DOUBLE PRECISION */ +/* ----------------------------------------------------------------------- */ +/* SOLUTION OF LINEAR SYSTEM, A*X = B . */ +/* INPUT.. */ +/* N = ORDER OF MATRIX. */ +/* NDIM = DECLARED DIMENSION OF ARRAYS AR AND AI. */ +/* (AR,AI) = TRIANGULARIZED MATRIX OBTAINED FROM DEC. */ +/* (BR,BI) = RIGHT HAND SIDE VECTOR. */ +/* LB = LOWER BANDWIDTH OF A. */ +/* IP = PIVOT VECTOR OBTAINED FROM DEC. */ +/* DO NOT USE IF DEC HAS SET IER .NE. 0. */ +/* OUTPUT.. */ +/* (BR,BI) = SOLUTION VECTOR, X . */ +/* ----------------------------------------------------------------------- */ + /* Parameter adjustments */ + --ip; + --bi; + --br; + ai_dim1 = *ndim; + ai_offset = 1 + ai_dim1; + ai -= ai_offset; + ar_dim1 = *ndim; + ar_offset = 1 + ar_dim1; + ar -= ar_offset; + + /* Function Body */ + if (*n == 1) { + goto L50; + } + nm1 = *n - 1; + if (*lb == 0) { + goto L25; + } + i__1 = nm1; + for (k = 1; k <= i__1; ++k) { + kp1 = k + 1; + m = ip[k]; + tr = br[m]; + ti = bi[m]; + br[m] = br[k]; + bi[m] = bi[k]; + br[k] = tr; + bi[k] = ti; + /* Computing MIN */ + i__3 = *n, i__4 = *lb + k; + i__2 = min(i__3,i__4); + for (i__ = kp1; i__ <= i__2; ++i__) { + prodr = ar[i__ + k * ar_dim1] * tr - ai[i__ + k * ai_dim1] * ti; + prodi = ai[i__ + k * ai_dim1] * tr + ar[i__ + k * ar_dim1] * ti; + br[i__] += prodr; + bi[i__] += prodi; + /* L10: */ + } + /* L20: */ + } +L25: + i__1 = nm1; + for (kb = 1; kb <= i__1; ++kb) { + km1 = *n - kb; + k = km1 + 1; + den = ar[k + k * ar_dim1] * ar[k + k * ar_dim1] + ai[k + k * ai_dim1] + * ai[k + k * ai_dim1]; + prodr = br[k] * ar[k + k * ar_dim1] + bi[k] * ai[k + k * ai_dim1]; + prodi = bi[k] * ar[k + k * ar_dim1] - br[k] * ai[k + k * ai_dim1]; + br[k] = prodr / den; + bi[k] = prodi / den; + tr = -br[k]; + ti = -bi[k]; + i__2 = km1; + for (i__ = 1; i__ <= i__2; ++i__) { + prodr = ar[i__ + k * ar_dim1] * tr - ai[i__ + k * ai_dim1] * ti; + prodi = ai[i__ + k * ai_dim1] * tr + ar[i__ + k * ar_dim1] * ti; + br[i__] += prodr; + bi[i__] += prodi; + /* L30: */ + } + /* L40: */ + } +L50: + den = ar[ar_dim1 + 1] * ar[ar_dim1 + 1] + ai[ai_dim1 + 1] * ai[ai_dim1 + 1]; + prodr = br[1] * ar[ar_dim1 + 1] + bi[1] * ai[ai_dim1 + 1]; + prodi = bi[1] * ar[ar_dim1 + 1] - br[1] * ai[ai_dim1 + 1]; + br[1] = prodr / den; + bi[1] = prodi / den; + return 0; +/* ----------------------- END OF SUBROUTINE SOLHC ----------------------- */ +} /* solhc_ */ + + +/* Subroutine */ int decb_(integer *n, integer *ndim, doublereal *a, integer * + ml, integer *mu, integer *ip, integer *ier) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + doublereal d__1, d__2; + + /* Local variables */ + static integer i__, j, k, m; + static doublereal t; + static integer md, jk, mm, ju, md1, nm1, kp1, mdl, ijk; + +/* ----------------------------------------------------------------------- */ +/* MATRIX TRIANGULARIZATION BY GAUSSIAN ELIMINATION OF A BANDED */ +/* MATRIX WITH LOWER BANDWIDTH ML AND UPPER BANDWIDTH MU */ +/* INPUT.. */ +/* N ORDER OF THE ORIGINAL MATRIX A. */ +/* NDIM DECLARED DIMENSION OF ARRAY A. */ +/* A CONTAINS THE MATRIX IN BAND STORAGE. THE COLUMNS */ +/* OF THE MATRIX ARE STORED IN THE COLUMNS OF A AND */ +/* THE DIAGONALS OF THE MATRIX ARE STORED IN ROWS */ +/* ML+1 THROUGH 2*ML+MU+1 OF A. */ +/* ML LOWER BANDWIDTH OF A (DIAGONAL IS NOT COUNTED). */ +/* MU UPPER BANDWIDTH OF A (DIAGONAL IS NOT COUNTED). */ +/* OUTPUT.. */ +/* A AN UPPER TRIANGULAR MATRIX IN BAND STORAGE AND */ +/* THE MULTIPLIERS WHICH WERE USED TO OBTAIN IT. */ +/* IP INDEX VECTOR OF PIVOT INDICES. */ +/* IP(N) (-1)**(NUMBER OF INTERCHANGES) OR O . */ +/* IER = 0 IF MATRIX A IS NONSINGULAR, OR = K IF FOUND TO BE */ +/* SINGULAR AT STAGE K. */ +/* USE SOLB TO OBTAIN SOLUTION OF LINEAR SYSTEM. */ +/* DETERM(A) = IP(N)*A(MD,1)*A(MD,2)*...*A(MD,N) WITH MD=ML+MU+1. */ +/* IF IP(N)=O, A IS SINGULAR, SOLB WILL DIVIDE BY ZERO. */ + +/* REFERENCE.. */ +/* THIS IS A MODIFICATION OF */ +/* C. B. MOLER, ALGORITHM 423, LINEAR EQUATION SOLVER, */ +/* C.A.C.M. 15 (1972), P. 274. */ +/* ----------------------------------------------------------------------- */ + /* Parameter adjustments */ + --ip; + a_dim1 = *ndim; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + *ier = 0; + ip[*n] = 1; + md = *ml + *mu + 1; + md1 = md + 1; + ju = 0; + if (*ml == 0) { + goto L70; + } + if (*n == 1) { + goto L70; + } + if (*n < *mu + 2) { + goto L7; + } + i__1 = *n; + for (j = *mu + 2; j <= i__1; ++j) { + i__2 = *ml; + for (i__ = 1; i__ <= i__2; ++i__) { + /* L5: */ + a[i__ + j * a_dim1] = 0.; + } + } +L7: + nm1 = *n - 1; + i__2 = nm1; + for (k = 1; k <= i__2; ++k) { + kp1 = k + 1; + m = md; + /* Computing MIN */ + i__1 = *ml, i__3 = *n - k; + mdl = min(i__1,i__3) + md; + i__1 = mdl; + for (i__ = md1; i__ <= i__1; ++i__) { + if ((d__1 = a[i__ + k * a_dim1], abs(d__1)) > (d__2 = a[m + k * + a_dim1], abs(d__2))) { + m = i__; + } + /* L10: */ + } + ip[k] = m + k - md; + t = a[m + k * a_dim1]; + if (m == md) { + goto L20; + } + ip[*n] = -ip[*n]; + a[m + k * a_dim1] = a[md + k * a_dim1]; + a[md + k * a_dim1] = t; +L20: + if (t == 0.) { + goto L80; + } + t = 1. / t; + i__1 = mdl; + for (i__ = md1; i__ <= i__1; ++i__) { + /* L30: */ + a[i__ + k * a_dim1] = -a[i__ + k * a_dim1] * t; + } + /* Computing MIN */ + /* Computing MAX */ + i__3 = ju, i__4 = *mu + ip[k]; + i__1 = max(i__3,i__4); + ju = min(i__1,*n); + mm = md; + if (ju < kp1) { + goto L55; + } + i__1 = ju; + for (j = kp1; j <= i__1; ++j) { + --m; + --mm; + t = a[m + j * a_dim1]; + if (m == mm) { + goto L35; + } + a[m + j * a_dim1] = a[mm + j * a_dim1]; + a[mm + j * a_dim1] = t; +L35: + if (t == 0.) { + goto L45; + } + jk = j - k; + i__3 = mdl; + for (i__ = md1; i__ <= i__3; ++i__) { + ijk = i__ - jk; + /* L40: */ + a[ijk + j * a_dim1] += a[i__ + k * a_dim1] * t; + } +L45: + /* L50: */ + ; + } +L55: + /* L60: */ + ; + } +L70: + k = *n; + if (a[md + *n * a_dim1] == 0.) { + goto L80; + } + return 0; +L80: + *ier = k; + ip[*n] = 0; + return 0; +/* ----------------------- END OF SUBROUTINE DECB ------------------------ */ +} /* decb_ */ + + + +/* Subroutine */ int solb_(integer *n, integer *ndim, doublereal *a, integer * + ml, integer *mu, doublereal *b, integer *ip) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + + /* Local variables */ + static integer i__, k, m; + static doublereal t; + static integer kb, md, lm, md1, nm1, imd, kmd, mdl, mdm; + +/* ----------------------------------------------------------------------- */ +/* SOLUTION OF LINEAR SYSTEM, A*X = B . */ +/* INPUT.. */ +/* N ORDER OF MATRIX A. */ +/* NDIM DECLARED DIMENSION OF ARRAY A . */ +/* A TRIANGULARIZED MATRIX OBTAINED FROM DECB. */ +/* ML LOWER BANDWIDTH OF A (DIAGONAL IS NOT COUNTED). */ +/* MU UPPER BANDWIDTH OF A (DIAGONAL IS NOT COUNTED). */ +/* B RIGHT HAND SIDE VECTOR. */ +/* IP PIVOT VECTOR OBTAINED FROM DECB. */ +/* DO NOT USE IF DECB HAS SET IER .NE. 0. */ +/* OUTPUT.. */ +/* B SOLUTION VECTOR, X . */ +/* ----------------------------------------------------------------------- */ + /* Parameter adjustments */ + --ip; + --b; + a_dim1 = *ndim; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + md = *ml + *mu + 1; + md1 = md + 1; + mdm = md - 1; + nm1 = *n - 1; + if (*ml == 0) { + goto L25; + } + if (*n == 1) { + goto L50; + } + i__1 = nm1; + for (k = 1; k <= i__1; ++k) { + m = ip[k]; + t = b[m]; + b[m] = b[k]; + b[k] = t; + /* Computing MIN */ + i__2 = *ml, i__3 = *n - k; + mdl = min(i__2,i__3) + md; + i__2 = mdl; + for (i__ = md1; i__ <= i__2; ++i__) { + imd = i__ + k - md; + /* L10: */ + b[imd] += a[i__ + k * a_dim1] * t; + } + /* L20: */ + } +L25: + i__1 = nm1; + for (kb = 1; kb <= i__1; ++kb) { + k = *n + 1 - kb; + b[k] /= a[md + k * a_dim1]; + t = -b[k]; + kmd = md - k; + /* Computing MAX */ + i__2 = 1, i__3 = kmd + 1; + lm = max(i__2,i__3); + i__2 = mdm; + for (i__ = lm; i__ <= i__2; ++i__) { + imd = i__ - kmd; + /* L30: */ + b[imd] += a[i__ + k * a_dim1] * t; + } + /* L40: */ + } +L50: + b[1] /= a[md + a_dim1]; + return 0; +/* ----------------------- END OF SUBROUTINE SOLB ------------------------ */ +} /* solb_ */ + + +/* Subroutine */ int decbc_(integer *n, integer *ndim, doublereal *ar, + doublereal *ai, integer *ml, integer *mu, integer *ip, integer *ier) +{ + /* System generated locals */ + integer ar_dim1, ar_offset, ai_dim1, ai_offset, i__1, i__2, i__3, i__4; + doublereal d__1, d__2, d__3, d__4; + + /* Local variables */ + static integer i__, j, k, m, md, jk, mm; + static doublereal ti; + static integer ju; + static doublereal tr; + static integer md1, nm1, kp1; + static doublereal den; + static integer mdl, ijk; + static doublereal prodi, prodr; + +/* ----------------------------------------------------------------------- */ +/* MATRIX TRIANGULARIZATION BY GAUSSIAN ELIMINATION OF A BANDED COMPLEX */ +/* MATRIX WITH LOWER BANDWIDTH ML AND UPPER BANDWIDTH MU */ +/* INPUT.. */ +/* N ORDER OF THE ORIGINAL MATRIX A. */ +/* NDIM DECLARED DIMENSION OF ARRAY A. */ +/* AR, AI CONTAINS THE MATRIX IN BAND STORAGE. THE COLUMNS */ +/* OF THE MATRIX ARE STORED IN THE COLUMNS OF AR (REAL */ +/* PART) AND AI (IMAGINARY PART) AND */ +/* THE DIAGONALS OF THE MATRIX ARE STORED IN ROWS */ +/* ML+1 THROUGH 2*ML+MU+1 OF AR AND AI. */ +/* ML LOWER BANDWIDTH OF A (DIAGONAL IS NOT COUNTED). */ +/* MU UPPER BANDWIDTH OF A (DIAGONAL IS NOT COUNTED). */ +/* OUTPUT.. */ +/* AR, AI AN UPPER TRIANGULAR MATRIX IN BAND STORAGE AND */ +/* THE MULTIPLIERS WHICH WERE USED TO OBTAIN IT. */ +/* IP INDEX VECTOR OF PIVOT INDICES. */ +/* IP(N) (-1)**(NUMBER OF INTERCHANGES) OR O . */ +/* IER = 0 IF MATRIX A IS NONSINGULAR, OR = K IF FOUND TO BE */ +/* SINGULAR AT STAGE K. */ +/* USE SOLBC TO OBTAIN SOLUTION OF LINEAR SYSTEM. */ +/* DETERM(A) = IP(N)*A(MD,1)*A(MD,2)*...*A(MD,N) WITH MD=ML+MU+1. */ +/* IF IP(N)=O, A IS SINGULAR, SOLBC WILL DIVIDE BY ZERO. */ + +/* REFERENCE.. */ +/* THIS IS A MODIFICATION OF */ +/* C. B. MOLER, ALGORITHM 423, LINEAR EQUATION SOLVER, */ +/* C.A.C.M. 15 (1972), P. 274. */ +/* ----------------------------------------------------------------------- */ + /* Parameter adjustments */ + --ip; + ai_dim1 = *ndim; + ai_offset = 1 + ai_dim1; + ai -= ai_offset; + ar_dim1 = *ndim; + ar_offset = 1 + ar_dim1; + ar -= ar_offset; + + /* Function Body */ + *ier = 0; + ip[*n] = 1; + md = *ml + *mu + 1; + md1 = md + 1; + ju = 0; + if (*ml == 0) { + goto L70; + } + if (*n == 1) { + goto L70; + } + if (*n < *mu + 2) { + goto L7; + } + i__1 = *n; + for (j = *mu + 2; j <= i__1; ++j) { + i__2 = *ml; + for (i__ = 1; i__ <= i__2; ++i__) { + ar[i__ + j * ar_dim1] = 0.; + ai[i__ + j * ai_dim1] = 0.; + /* L5: */ + } + } +L7: + nm1 = *n - 1; + i__2 = nm1; + for (k = 1; k <= i__2; ++k) { + kp1 = k + 1; + m = md; + /* Computing MIN */ + i__1 = *ml, i__3 = *n - k; + mdl = min(i__1,i__3) + md; + i__1 = mdl; + for (i__ = md1; i__ <= i__1; ++i__) { + if ((d__1 = ar[i__ + k * ar_dim1], abs(d__1)) + (d__2 = ai[i__ + + k * ai_dim1], abs(d__2)) > (d__3 = ar[m + k * ar_dim1], + abs(d__3)) + (d__4 = ai[m + k * ai_dim1], abs(d__4))) { + m = i__; + } + /* L10: */ + } + ip[k] = m + k - md; + tr = ar[m + k * ar_dim1]; + ti = ai[m + k * ai_dim1]; + if (m == md) { + goto L20; + } + ip[*n] = -ip[*n]; + ar[m + k * ar_dim1] = ar[md + k * ar_dim1]; + ai[m + k * ai_dim1] = ai[md + k * ai_dim1]; + ar[md + k * ar_dim1] = tr; + ai[md + k * ai_dim1] = ti; +L20: + if (abs(tr) + abs(ti) == 0.) { + goto L80; + } + den = tr * tr + ti * ti; + tr /= den; + ti = -ti / den; + i__1 = mdl; + for (i__ = md1; i__ <= i__1; ++i__) { + prodr = ar[i__ + k * ar_dim1] * tr - ai[i__ + k * ai_dim1] * ti; + prodi = ai[i__ + k * ai_dim1] * tr + ar[i__ + k * ar_dim1] * ti; + ar[i__ + k * ar_dim1] = -prodr; + ai[i__ + k * ai_dim1] = -prodi; + /* L30: */ + } + /* Computing MIN */ + /* Computing MAX */ + i__3 = ju, i__4 = *mu + ip[k]; + i__1 = max(i__3,i__4); + ju = min(i__1,*n); + mm = md; + if (ju < kp1) { + goto L55; + } + i__1 = ju; + for (j = kp1; j <= i__1; ++j) { + --m; + --mm; + tr = ar[m + j * ar_dim1]; + ti = ai[m + j * ai_dim1]; + if (m == mm) { + goto L35; + } + ar[m + j * ar_dim1] = ar[mm + j * ar_dim1]; + ai[m + j * ai_dim1] = ai[mm + j * ai_dim1]; + ar[mm + j * ar_dim1] = tr; + ai[mm + j * ai_dim1] = ti; +L35: + if (abs(tr) + abs(ti) == 0.) { + goto L48; + } + jk = j - k; + if (ti == 0.) { + i__3 = mdl; + for (i__ = md1; i__ <= i__3; ++i__) { + ijk = i__ - jk; + prodr = ar[i__ + k * ar_dim1] * tr; + prodi = ai[i__ + k * ai_dim1] * tr; + ar[ijk + j * ar_dim1] += prodr; + ai[ijk + j * ai_dim1] += prodi; + /* L40: */ + } + goto L48; + } + if (tr == 0.) { + i__3 = mdl; + for (i__ = md1; i__ <= i__3; ++i__) { + ijk = i__ - jk; + prodr = -ai[i__ + k * ai_dim1] * ti; + prodi = ar[i__ + k * ar_dim1] * ti; + ar[ijk + j * ar_dim1] += prodr; + ai[ijk + j * ai_dim1] += prodi; + /* L45: */ + } + goto L48; + } + i__3 = mdl; + for (i__ = md1; i__ <= i__3; ++i__) { + ijk = i__ - jk; + prodr = ar[i__ + k * ar_dim1] * tr - ai[i__ + k * ai_dim1] * ti; + prodi = ai[i__ + k * ai_dim1] * tr + ar[i__ + k * ar_dim1] * ti; + ar[ijk + j * ar_dim1] += prodr; + ai[ijk + j * ai_dim1] += prodi; + /* L47: */ + } +L48: + /* L50: */ + ; + } +L55: + /* L60: */ + ; + } +L70: + k = *n; + if ((d__1 = ar[md + *n * ar_dim1], abs(d__1)) + (d__2 = ai[md + *n * + ai_dim1], abs(d__2)) == 0.) { + goto L80; + } + return 0; +L80: + *ier = k; + ip[*n] = 0; + return 0; +/* ----------------------- END OF SUBROUTINE DECBC ------------------------ */ +} /* decbc_ */ + + + +/* Subroutine */ int solbc_(integer *n, integer *ndim, doublereal *ar, + doublereal *ai, integer *ml, integer *mu, doublereal *br, doublereal * + bi, integer *ip) +{ + /* System generated locals */ + integer ar_dim1, ar_offset, ai_dim1, ai_offset, i__1, i__2, i__3; + + /* Local variables */ + static integer i__, k, m, kb, md, lm; + static doublereal ti, tr; + static integer md1, nm1; + static doublereal den; + static integer imd, kmd, mdl, mdm; + static doublereal prodi, prodr; + +/* ----------------------------------------------------------------------- */ +/* SOLUTION OF LINEAR SYSTEM, A*X = B , */ +/* VERSION BANDED AND COMPLEX-DOUBLE PRECISION. */ +/* INPUT.. */ +/* N ORDER OF MATRIX A. */ +/* NDIM DECLARED DIMENSION OF ARRAY A . */ +/* AR, AI TRIANGULARIZED MATRIX OBTAINED FROM DECB (REAL AND IMAG. PART). */ +/* ML LOWER BANDWIDTH OF A (DIAGONAL IS NOT COUNTED). */ +/* MU UPPER BANDWIDTH OF A (DIAGONAL IS NOT COUNTED). */ +/* BR, BI RIGHT HAND SIDE VECTOR (REAL AND IMAG. PART). */ +/* IP PIVOT VECTOR OBTAINED FROM DECBC. */ +/* DO NOT USE IF DECB HAS SET IER .NE. 0. */ +/* OUTPUT.. */ +/* BR, BI SOLUTION VECTOR, X (REAL AND IMAG. PART). */ +/* ----------------------------------------------------------------------- */ + /* Parameter adjustments */ + --ip; + --bi; + --br; + ai_dim1 = *ndim; + ai_offset = 1 + ai_dim1; + ai -= ai_offset; + ar_dim1 = *ndim; + ar_offset = 1 + ar_dim1; + ar -= ar_offset; + + /* Function Body */ + md = *ml + *mu + 1; + md1 = md + 1; + mdm = md - 1; + nm1 = *n - 1; + if (*ml == 0) { + goto L25; + } + if (*n == 1) { + goto L50; + } + i__1 = nm1; + for (k = 1; k <= i__1; ++k) { + m = ip[k]; + tr = br[m]; + ti = bi[m]; + br[m] = br[k]; + bi[m] = bi[k]; + br[k] = tr; + bi[k] = ti; + /* Computing MIN */ + i__2 = *ml, i__3 = *n - k; + mdl = min(i__2,i__3) + md; + i__2 = mdl; + for (i__ = md1; i__ <= i__2; ++i__) { + imd = i__ + k - md; + prodr = ar[i__ + k * ar_dim1] * tr - ai[i__ + k * ai_dim1] * ti; + prodi = ai[i__ + k * ai_dim1] * tr + ar[i__ + k * ar_dim1] * ti; + br[imd] += prodr; + bi[imd] += prodi; + /* L10: */ + } + /* L20: */ + } +L25: + i__1 = nm1; + for (kb = 1; kb <= i__1; ++kb) { + k = *n + 1 - kb; + den = ar[md + k * ar_dim1] * ar[md + k * ar_dim1] + ai[md + k * + ai_dim1] * ai[md + k * ai_dim1]; + prodr = br[k] * ar[md + k * ar_dim1] + bi[k] * ai[md + k * ai_dim1]; + prodi = bi[k] * ar[md + k * ar_dim1] - br[k] * ai[md + k * ai_dim1]; + br[k] = prodr / den; + bi[k] = prodi / den; + tr = -br[k]; + ti = -bi[k]; + kmd = md - k; + /* Computing MAX */ + i__2 = 1, i__3 = kmd + 1; + lm = max(i__2,i__3); + i__2 = mdm; + for (i__ = lm; i__ <= i__2; ++i__) { + imd = i__ - kmd; + prodr = ar[i__ + k * ar_dim1] * tr - ai[i__ + k * ai_dim1] * ti; + prodi = ai[i__ + k * ai_dim1] * tr + ar[i__ + k * ar_dim1] * ti; + br[imd] += prodr; + bi[imd] += prodi; + /* L30: */ + } + /* L40: */ + } + den = ar[md + ar_dim1] * ar[md + ar_dim1] + ai[md + ai_dim1] * ai[md + ai_dim1]; + prodr = br[1] * ar[md + ar_dim1] + bi[1] * ai[md + ai_dim1]; + prodi = bi[1] * ar[md + ar_dim1] - br[1] * ai[md + ai_dim1]; + br[1] = prodr / den; + bi[1] = prodi / den; +L50: + return 0; +/* ----------------------- END OF SUBROUTINE SOLBC ------------------------ */ +} /* solbc_ */ + + + +/* Subroutine */ int elmhes_(integer *nm, integer *n, integer *low, integer * + igh, doublereal *a, integer *int__) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + doublereal d__1; + + /* Local variables */ + static integer i__, j, m; + static doublereal x, y; + static integer la, mm1, kp1, mp1; + + + +/* this subroutine is a translation of the algol procedure elmhes, */ +/* num. math. 12, 349-368(1968) by martin and wilkinson. */ +/* handbook for auto. comp., vol.ii-linear algebra, 339-358(1971). */ + +/* given a real general matrix, this subroutine */ +/* reduces a submatrix situated in rows and columns */ +/* low through igh to upper hessenberg form by */ +/* stabilized elementary similarity transformations. */ + +/* on input: */ + +/* nm must be set to the row dimension of two-dimensional */ +/* array parameters as declared in the calling program */ +/* dimension statement; */ + +/* n is the order of the matrix; */ + +/* low and igh are integers determined by the balancing */ +/* subroutine balanc. if balanc has not been used, */ +/* set low=1, igh=n; */ + +/* a contains the input matrix. */ + +/* on output: */ + +/* a contains the hessenberg matrix. the multipliers */ +/* which were used in the reduction are stored in the */ +/* remaining triangle under the hessenberg matrix; */ + +/* int contains information on the rows and columns */ +/* interchanged in the reduction. */ +/* only elements low through igh are used. */ + +/* questions and comments should be directed to b. s. garbow, */ +/* applied mathematics division, argonne national laboratory */ + +/* ------------------------------------------------------------------ */ + + /* Parameter adjustments */ + a_dim1 = *nm; + a_offset = 1 + a_dim1; + a -= a_offset; + --int__; + + /* Function Body */ + la = *igh - 1; + kp1 = *low + 1; + if (la < kp1) { + goto L200; + } + + i__1 = la; + for (m = kp1; m <= i__1; ++m) { + mm1 = m - 1; + x = 0.; + i__ = m; + + i__2 = *igh; + for (j = m; j <= i__2; ++j) { + if ((d__1 = a[j + mm1 * a_dim1], abs(d__1)) <= abs(x)) { + goto L100; + } + x = a[j + mm1 * a_dim1]; + i__ = j; +L100: + ; + } + + int__[m] = i__; + if (i__ == m) { + goto L130; + } + /* :::::::::: interchange rows and columns of a :::::::::: */ + i__2 = *n; + for (j = mm1; j <= i__2; ++j) { + y = a[i__ + j * a_dim1]; + a[i__ + j * a_dim1] = a[m + j * a_dim1]; + a[m + j * a_dim1] = y; + /* L110: */ + } + + i__2 = *igh; + for (j = 1; j <= i__2; ++j) { + y = a[j + i__ * a_dim1]; + a[j + i__ * a_dim1] = a[j + m * a_dim1]; + a[j + m * a_dim1] = y; + /* L120: */ + } + /* :::::::::: end interchange :::::::::: */ +L130: + if (x == 0.) { + goto L180; + } + mp1 = m + 1; + + i__2 = *igh; + for (i__ = mp1; i__ <= i__2; ++i__) { + y = a[i__ + mm1 * a_dim1]; + if (y == 0.) { + goto L160; + } + y /= x; + a[i__ + mm1 * a_dim1] = y; + + i__3 = *n; + for (j = m; j <= i__3; ++j) { + /* L140: */ + a[i__ + j * a_dim1] -= y * a[m + j * a_dim1]; + } + + i__3 = *igh; + for (j = 1; j <= i__3; ++j) { + /* L150: */ + a[j + m * a_dim1] += y * a[j + i__ * a_dim1]; + } + +L160: + ; + } + +L180: + ; + } + +L200: + return 0; +/* :::::::::: last card of elmhes :::::::::: */ +} /* elmhes_ */ + +/* ****************************************** */ +/* VERSION OF SEPTEMBER 18, 1995 */ +/* ****************************************** */ + +/* Subroutine */ int decomr_(integer *n, doublereal *fjac, integer *ldjac, + doublereal *fmas, integer *ldmas, integer *mlmas, integer *mumas, + integer *m1, integer *m2, integer *nm1, doublereal *fac1, doublereal * + e1, integer *lde1, integer *ip1, integer *ier, integer *ijob, logical + *calhes, integer *iphes) +{ + /* System generated locals */ + integer fjac_dim1, fjac_offset, fmas_dim1, fmas_offset, e1_dim1, + e1_offset, i__1, i__2, i__3, i__4, i__5, i__6; + + /* Local variables */ + static integer i__, j, k, j1, ib, mm, jm1; + extern /* Subroutine */ int dec_(integer *, integer *, doublereal *, + integer *, integer *); + static doublereal sum; + extern /* Subroutine */ int decb_(integer *, integer *, doublereal *, + integer *, integer *, integer *, integer *), dech_(integer *, + integer *, doublereal *, integer *, integer *, integer *), + elmhes_(integer *, integer *, integer *, integer *, doublereal *, + integer *); + + + /* Parameter adjustments */ + --iphes; + fjac_dim1 = *ldjac; + fjac_offset = 1 + fjac_dim1; + fjac -= fjac_offset; + --ip1; + fmas_dim1 = *ldmas; + fmas_offset = 1 + fmas_dim1; + fmas -= fmas_offset; + e1_dim1 = *lde1; + e1_offset = 1 + e1_dim1; + e1 -= e1_offset; + + /* Function Body */ + switch (*ijob) { + case 1: goto L1; + case 2: goto L2; + case 3: goto L3; + case 4: goto L4; + case 5: goto L5; + case 6: goto L6; + case 7: goto L7; + case 8: goto L55; + case 9: goto L55; + case 10: goto L55; + case 11: goto L11; + case 12: goto L12; + case 13: goto L13; + case 14: goto L14; + case 15: goto L15; + } + +/* ----------------------------------------------------------- */ + +L1: +/* --- B=IDENTITY, JACOBIAN A FULL MATRIX */ + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + e1[i__ + j * e1_dim1] = -fjac[i__ + j * fjac_dim1]; + } + e1[j + j * e1_dim1] += *fac1; + } + dec_(n, lde1, &e1[e1_offset], &ip1[1], ier); + return 0; + +/* ----------------------------------------------------------- */ + +L11: +/* --- B=IDENTITY, JACOBIAN A FULL MATRIX, SECOND ORDER */ + i__1 = *nm1; + for (j = 1; j <= i__1; ++j) { + jm1 = j + *m1; + i__2 = *nm1; + for (i__ = 1; i__ <= i__2; ++i__) { + e1[i__ + j * e1_dim1] = -fjac[i__ + jm1 * fjac_dim1]; + } + e1[j + j * e1_dim1] += *fac1; + } +L45: + mm = *m1 / *m2; + i__1 = *m2; + for (j = 1; j <= i__1; ++j) { + i__2 = *nm1; + for (i__ = 1; i__ <= i__2; ++i__) { + sum = 0.; + i__3 = mm - 1; + for (k = 0; k <= i__3; ++k) { + sum = (sum + fjac[i__ + (j + k * *m2) * fjac_dim1]) / *fac1; + } + e1[i__ + j * e1_dim1] -= sum; + } + } + dec_(nm1, lde1, &e1[e1_offset], &ip1[1], ier); + return 0; + +/* ----------------------------------------------------------- */ + +L2: +/* --- B=IDENTITY, JACOBIAN A BANDED MATRIX */ + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = linal_1.mbjac; + for (i__ = 1; i__ <= i__2; ++i__) { + e1[i__ + linal_1.mle + j * e1_dim1] = -fjac[i__ + j * fjac_dim1]; + } + e1[linal_1.mdiag + j * e1_dim1] += *fac1; + } + decb_(n, lde1, &e1[e1_offset], &linal_1.mle, &linal_1.mue, &ip1[1], ier); + return 0; + +/* ----------------------------------------------------------- */ + +L12: +/* --- B=IDENTITY, JACOBIAN A BANDED MATRIX, SECOND ORDER */ + i__1 = *nm1; + for (j = 1; j <= i__1; ++j) { + jm1 = j + *m1; + i__2 = linal_1.mbjac; + for (i__ = 1; i__ <= i__2; ++i__) { + e1[i__ + linal_1.mle + j * e1_dim1] = -fjac[i__ + jm1 * fjac_dim1]; + } + e1[linal_1.mdiag + j * e1_dim1] += *fac1; + } +L46: + mm = *m1 / *m2; + i__1 = *m2; + for (j = 1; j <= i__1; ++j) { + i__2 = linal_1.mbjac; + for (i__ = 1; i__ <= i__2; ++i__) { + sum = 0.; + i__3 = mm - 1; + for (k = 0; k <= i__3; ++k) { + sum = (sum + fjac[i__ + (j + k * *m2) * fjac_dim1]) / *fac1; + } + e1[i__ + linal_1.mle + j * e1_dim1] -= sum; + } + } + decb_(nm1, lde1, &e1[e1_offset], &linal_1.mle, &linal_1.mue, &ip1[1], ier); + return 0; + +/* ----------------------------------------------------------- */ + +L3: +/* --- B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX */ + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + e1[i__ + j * e1_dim1] = -fjac[i__ + j * fjac_dim1]; + } + /* Computing MAX */ + i__2 = 1, i__3 = j - *mumas; + /* Computing MIN */ + i__5 = *n, i__6 = j + *mlmas; + i__4 = min(i__5,i__6); + for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { + e1[i__ + j * e1_dim1] += *fac1 * fmas[i__ - j + linal_1.mbdiag + j * fmas_dim1]; + } + } + dec_(n, lde1, &e1[e1_offset], &ip1[1], ier); + return 0; + +/* ----------------------------------------------------------- */ + +L13: +/* --- B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER */ + i__1 = *nm1; + for (j = 1; j <= i__1; ++j) { + jm1 = j + *m1; + i__4 = *nm1; + for (i__ = 1; i__ <= i__4; ++i__) { + e1[i__ + j * e1_dim1] = -fjac[i__ + jm1 * fjac_dim1]; + } + /* Computing MAX */ + i__4 = 1, i__2 = j - *mumas; + /* Computing MIN */ + i__5 = *nm1, i__6 = j + *mlmas; + i__3 = min(i__5,i__6); + for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) { + e1[i__ + j * e1_dim1] += *fac1 * fmas[i__ - j + linal_1.mbdiag + j * fmas_dim1]; + } + } + goto L45; +/* ----------------------------------------------------------- */ + +L4: +/* --- B IS A BANDED MATRIX, JACOBIAN A BANDED MATRIX */ + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__3 = linal_1.mbjac; + for (i__ = 1; i__ <= i__3; ++i__) { + e1[i__ + linal_1.mle + j * e1_dim1] = -fjac[i__ + j * fjac_dim1]; + } + i__3 = linal_1.mbb; + for (i__ = 1; i__ <= i__3; ++i__) { + ib = i__ + linal_1.mdiff; + e1[ib + j * e1_dim1] += *fac1 * fmas[i__ + j * fmas_dim1]; + } + } + decb_(n, lde1, &e1[e1_offset], &linal_1.mle, &linal_1.mue, &ip1[1], ier); + return 0; + +/* ----------------------------------------------------------- */ + +L14: +/* --- B IS A BANDED MATRIX, JACOBIAN A BANDED MATRIX, SECOND ORDER */ + i__1 = *nm1; + for (j = 1; j <= i__1; ++j) { + jm1 = j + *m1; + i__3 = linal_1.mbjac; + for (i__ = 1; i__ <= i__3; ++i__) { + e1[i__ + linal_1.mle + j * e1_dim1] = -fjac[i__ + jm1 * fjac_dim1]; + } + i__3 = linal_1.mbb; + for (i__ = 1; i__ <= i__3; ++i__) { + ib = i__ + linal_1.mdiff; + e1[ib + j * e1_dim1] += *fac1 * fmas[i__ + j * fmas_dim1]; + } + } + goto L46; + +/* ----------------------------------------------------------- */ + +L5: +/* --- B IS A FULL MATRIX, JACOBIAN A FULL MATRIX */ + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + e1[i__ + j * e1_dim1] = fmas[i__ + j * fmas_dim1] * *fac1 - fjac[i__ + j * fjac_dim1]; + } + } + dec_(n, lde1, &e1[e1_offset], &ip1[1], ier); + return 0; + +/* ----------------------------------------------------------- */ + +L15: +/* --- B IS A FULL MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER */ + i__1 = *nm1; + for (j = 1; j <= i__1; ++j) { + jm1 = j + *m1; + i__3 = *nm1; + for (i__ = 1; i__ <= i__3; ++i__) { + e1[i__ + j * e1_dim1] = fmas[i__ + j * fmas_dim1] * *fac1 - fjac[i__ + jm1 * fjac_dim1]; + } + } + goto L45; + +/* ----------------------------------------------------------- */ + +L6: +/* --- B IS A FULL MATRIX, JACOBIAN A BANDED MATRIX */ +/* --- THIS OPTION IS NOT PROVIDED */ + return 0; + +/* ----------------------------------------------------------- */ + +L7: +/* --- B=IDENTITY, JACOBIAN A FULL MATRIX, HESSENBERG-OPTION */ + if (*calhes) { + elmhes_(ldjac, n, &c__1, n, &fjac[fjac_offset], &iphes[1]); + } + *calhes = FALSE_; + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + j1 = j + 1; + e1[j1 + j * e1_dim1] = -fjac[j1 + j * fjac_dim1]; + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__3 = j; + for (i__ = 1; i__ <= i__3; ++i__) { + e1[i__ + j * e1_dim1] = -fjac[i__ + j * fjac_dim1]; + } + e1[j + j * e1_dim1] += *fac1; + } + dech_(n, lde1, &e1[e1_offset], &c__1, &ip1[1], ier); + return 0; + +/* ----------------------------------------------------------- */ + +L55: + return 0; +} /* decomr_ */ + + +/* END OF SUBROUTINE DECOMR */ + +/* *********************************************************** */ + +/* Subroutine */ int decomc_(integer *n, doublereal *fjac, integer *ldjac, + doublereal *fmas, integer *ldmas, integer *mlmas, integer *mumas, + integer *m1, integer *m2, integer *nm1, doublereal *alphn, doublereal + *betan, doublereal *e2r, doublereal *e2i, integer *lde1, integer *ip2, + integer *ier, integer *ijob) +{ + /* System generated locals */ + integer fjac_dim1, fjac_offset, fmas_dim1, fmas_offset, e2r_dim1, + e2r_offset, e2i_dim1, e2i_offset, i__1, i__2, i__3, i__4, i__5, + i__6; + doublereal d__1, d__2; + + /* Local variables */ + static integer i__, j, k, j1; + static doublereal bb; + static integer ib, mm, jm1; + static doublereal bet, alp; + extern /* Subroutine */ int decc_(integer *, integer *, doublereal *, + doublereal *, integer *, integer *); + static doublereal ffma, abno; + static integer imle; + static doublereal sumi, sumr, sums; + extern /* Subroutine */ int decbc_(integer *, integer *, doublereal *, + doublereal *, integer *, integer *, integer *, integer *), dechc_( + integer *, integer *, doublereal *, doublereal *, integer *, + integer *, integer *); + + + /* Parameter adjustments */ + fjac_dim1 = *ldjac; + fjac_offset = 1 + fjac_dim1; + fjac -= fjac_offset; + --ip2; + fmas_dim1 = *ldmas; + fmas_offset = 1 + fmas_dim1; + fmas -= fmas_offset; + e2i_dim1 = *lde1; + e2i_offset = 1 + e2i_dim1; + e2i -= e2i_offset; + e2r_dim1 = *lde1; + e2r_offset = 1 + e2r_dim1; + e2r -= e2r_offset; + + /* Function Body */ + switch (*ijob) { + case 1: goto L1; + case 2: goto L2; + case 3: goto L3; + case 4: goto L4; + case 5: goto L5; + case 6: goto L6; + case 7: goto L7; + case 8: goto L55; + case 9: goto L55; + case 10: goto L55; + case 11: goto L11; + case 12: goto L12; + case 13: goto L13; + case 14: goto L14; + case 15: goto L15; + } + +/* ----------------------------------------------------------- */ + +L1: +/* --- B=IDENTITY, JACOBIAN A FULL MATRIX */ + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + e2r[i__ + j * e2r_dim1] = -fjac[i__ + j * fjac_dim1]; + e2i[i__ + j * e2i_dim1] = 0.; + } + e2r[j + j * e2r_dim1] += *alphn; + e2i[j + j * e2i_dim1] = *betan; + } + decc_(n, lde1, &e2r[e2r_offset], &e2i[e2i_offset], &ip2[1], ier); + return 0; + +/* ----------------------------------------------------------- */ + +L11: +/* --- B=IDENTITY, JACOBIAN A FULL MATRIX, SECOND ORDER */ + i__1 = *nm1; + for (j = 1; j <= i__1; ++j) { + jm1 = j + *m1; + i__2 = *nm1; + for (i__ = 1; i__ <= i__2; ++i__) { + e2r[i__ + j * e2r_dim1] = -fjac[i__ + jm1 * fjac_dim1]; + e2i[i__ + j * e2i_dim1] = 0.; + } + e2r[j + j * e2r_dim1] += *alphn; + e2i[j + j * e2i_dim1] = *betan; + } +L45: + mm = *m1 / *m2; +/* Computing 2nd power */ + d__1 = *alphn; +/* Computing 2nd power */ + d__2 = *betan; + abno = d__1 * d__1 + d__2 * d__2; + alp = *alphn / abno; + bet = *betan / abno; + i__1 = *m2; + for (j = 1; j <= i__1; ++j) { + i__2 = *nm1; + for (i__ = 1; i__ <= i__2; ++i__) { + sumr = 0.; + sumi = 0.; + i__3 = mm - 1; + for (k = 0; k <= i__3; ++k) { + sums = sumr + fjac[i__ + (j + k * *m2) * fjac_dim1]; + sumr = sums * alp + sumi * bet; + sumi = sumi * alp - sums * bet; + } + e2r[i__ + j * e2r_dim1] -= sumr; + e2i[i__ + j * e2i_dim1] -= sumi; + } + } + decc_(nm1, lde1, &e2r[e2r_offset], &e2i[e2i_offset], &ip2[1], ier); + return 0; + +/* ----------------------------------------------------------- */ + +L2: +/* --- B=IDENTITY, JACOBIAN A BANDED MATRIX */ + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = linal_1.mbjac; + for (i__ = 1; i__ <= i__2; ++i__) { + imle = i__ + linal_1.mle; + e2r[imle + j * e2r_dim1] = -fjac[i__ + j * fjac_dim1]; + e2i[imle + j * e2i_dim1] = 0.; + } + e2r[linal_1.mdiag + j * e2r_dim1] += *alphn; + e2i[linal_1.mdiag + j * e2i_dim1] = *betan; + } + decbc_(n, lde1, &e2r[e2r_offset], &e2i[e2i_offset], &linal_1.mle, & + linal_1.mue, &ip2[1], ier); + return 0; + +/* ----------------------------------------------------------- */ + +L12: +/* --- B=IDENTITY, JACOBIAN A BANDED MATRIX, SECOND ORDER */ + i__1 = *nm1; + for (j = 1; j <= i__1; ++j) { + jm1 = j + *m1; + i__2 = linal_1.mbjac; + for (i__ = 1; i__ <= i__2; ++i__) { + e2r[i__ + linal_1.mle + j * e2r_dim1] = -fjac[i__ + jm1 * fjac_dim1]; + e2i[i__ + linal_1.mle + j * e2i_dim1] = 0.; + } + e2r[linal_1.mdiag + j * e2r_dim1] += *alphn; + e2i[linal_1.mdiag + j * e2i_dim1] += *betan; + } +L46: + mm = *m1 / *m2; +/* Computing 2nd power */ + d__1 = *alphn; +/* Computing 2nd power */ + d__2 = *betan; + abno = d__1 * d__1 + d__2 * d__2; + alp = *alphn / abno; + bet = *betan / abno; + i__1 = *m2; + for (j = 1; j <= i__1; ++j) { + i__2 = linal_1.mbjac; + for (i__ = 1; i__ <= i__2; ++i__) { + sumr = 0.; + sumi = 0.; + i__3 = mm - 1; + for (k = 0; k <= i__3; ++k) { + sums = sumr + fjac[i__ + (j + k * *m2) * fjac_dim1]; + sumr = sums * alp + sumi * bet; + sumi = sumi * alp - sums * bet; + } + imle = i__ + linal_1.mle; + e2r[imle + j * e2r_dim1] -= sumr; + e2i[imle + j * e2i_dim1] -= sumi; + } + } + decbc_(nm1, lde1, &e2r[e2r_offset], &e2i[e2i_offset], &linal_1.mle, & + linal_1.mue, &ip2[1], ier); + return 0; + +/* ----------------------------------------------------------- */ + +L3: +/* --- B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX */ + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + e2r[i__ + j * e2r_dim1] = -fjac[i__ + j * fjac_dim1]; + e2i[i__ + j * e2i_dim1] = 0.; + } + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + /* Computing MAX */ + i__2 = 1, i__3 = j - *mumas; + /* Computing MIN */ + i__5 = *n, i__6 = j + *mlmas; + i__4 = min(i__5,i__6); + for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { + bb = fmas[i__ - j + linal_1.mbdiag + j * fmas_dim1]; + e2r[i__ + j * e2r_dim1] += *alphn * bb; + e2i[i__ + j * e2i_dim1] = *betan * bb; + } + } + decc_(n, lde1, &e2r[e2r_offset], &e2i[e2i_offset], &ip2[1], ier); + return 0; + +/* ----------------------------------------------------------- */ + +L13: +/* --- B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER */ + i__1 = *nm1; + for (j = 1; j <= i__1; ++j) { + jm1 = j + *m1; + i__4 = *nm1; + for (i__ = 1; i__ <= i__4; ++i__) { + e2r[i__ + j * e2r_dim1] = -fjac[i__ + jm1 * fjac_dim1]; + e2i[i__ + j * e2i_dim1] = 0.; + } + /* Computing MAX */ + i__4 = 1, i__2 = j - *mumas; + /* Computing MIN */ + i__5 = *nm1, i__6 = j + *mlmas; + i__3 = min(i__5,i__6); + for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) { + ffma = fmas[i__ - j + linal_1.mbdiag + j * fmas_dim1]; + e2r[i__ + j * e2r_dim1] += *alphn * ffma; + e2i[i__ + j * e2i_dim1] += *betan * ffma; + } + } + goto L45; + +/* ----------------------------------------------------------- */ + +L4: +/* --- B IS A BANDED MATRIX, JACOBIAN A BANDED MATRIX */ + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__3 = linal_1.mbjac; + for (i__ = 1; i__ <= i__3; ++i__) { + imle = i__ + linal_1.mle; + e2r[imle + j * e2r_dim1] = -fjac[i__ + j * fjac_dim1]; + e2i[imle + j * e2i_dim1] = 0.; + } + /* Computing MAX */ + i__3 = 1, i__4 = *mumas + 2 - j; + /* Computing MIN */ + i__5 = linal_1.mbb, i__6 = *mumas + 1 - j + *n; + i__2 = min(i__5,i__6); + for (i__ = max(i__3,i__4); i__ <= i__2; ++i__) { + ib = i__ + linal_1.mdiff; + bb = fmas[i__ + j * fmas_dim1]; + e2r[ib + j * e2r_dim1] += *alphn * bb; + e2i[ib + j * e2i_dim1] = *betan * bb; + } + } + decbc_(n, lde1, &e2r[e2r_offset], &e2i[e2i_offset], &linal_1.mle, & + linal_1.mue, &ip2[1], ier); + return 0; + +/* ----------------------------------------------------------- */ + +L14: +/* --- B IS A BANDED MATRIX, JACOBIAN A BANDED MATRIX, SECOND ORDER */ + i__1 = *nm1; + for (j = 1; j <= i__1; ++j) { + jm1 = j + *m1; + i__2 = linal_1.mbjac; + for (i__ = 1; i__ <= i__2; ++i__) { + e2r[i__ + linal_1.mle + j * e2r_dim1] = -fjac[i__ + jm1 * fjac_dim1]; + e2i[i__ + linal_1.mle + j * e2i_dim1] = 0.; + } + i__2 = linal_1.mbb; + for (i__ = 1; i__ <= i__2; ++i__) { + ib = i__ + linal_1.mdiff; + ffma = fmas[i__ + j * fmas_dim1]; + e2r[ib + j * e2r_dim1] += *alphn * ffma; + e2i[ib + j * e2i_dim1] += *betan * ffma; + } + } + goto L46; + +/* ----------------------------------------------------------- */ + +L5: +/* --- B IS A FULL MATRIX, JACOBIAN A FULL MATRIX */ + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + bb = fmas[i__ + j * fmas_dim1]; + e2r[i__ + j * e2r_dim1] = bb * *alphn - fjac[i__ + j * fjac_dim1]; + e2i[i__ + j * e2i_dim1] = bb * *betan; + } + } + decc_(n, lde1, &e2r[e2r_offset], &e2i[e2i_offset], &ip2[1], ier); + return 0; + +/* ----------------------------------------------------------- */ + +L15: +/* --- B IS A FULL MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER */ + i__1 = *nm1; + for (j = 1; j <= i__1; ++j) { + jm1 = j + *m1; + i__2 = *nm1; + for (i__ = 1; i__ <= i__2; ++i__) { + e2r[i__ + j * e2r_dim1] = *alphn * fmas[i__ + j * fmas_dim1] - fjac[i__ + jm1 * fjac_dim1]; + e2i[i__ + j * e2i_dim1] = *betan * fmas[i__ + j * fmas_dim1]; + } + } + goto L45; + +/* ----------------------------------------------------------- */ + +L6: +/* --- B IS A FULL MATRIX, JACOBIAN A BANDED MATRIX */ +/* --- THIS OPTION IS NOT PROVIDED */ + return 0; + +/* ----------------------------------------------------------- */ + +L7: +/* --- B=IDENTITY, JACOBIAN A FULL MATRIX, HESSENBERG-OPTION */ + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + j1 = j + 1; + e2r[j1 + j * e2r_dim1] = -fjac[j1 + j * fjac_dim1]; + e2i[j1 + j * e2i_dim1] = 0.; + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + e2i[i__ + j * e2i_dim1] = 0.; + e2r[i__ + j * e2r_dim1] = -fjac[i__ + j * fjac_dim1]; + } + e2r[j + j * e2r_dim1] += *alphn; + e2i[j + j * e2i_dim1] = *betan; + } + dechc_(n, lde1, &e2r[e2r_offset], &e2i[e2i_offset], &c__1, &ip2[1], ier); + return 0; + +/* ----------------------------------------------------------- */ + +L55: + return 0; +} /* decomc_ */ + + +/* END OF SUBROUTINE DECOMC */ + +/* *********************************************************** */ + +/* Subroutine */ int slvrar_(integer *n, doublereal *fjac, integer *ldjac, + integer *mljac, integer *mujac, doublereal *fmas, integer *ldmas, + integer *mlmas, integer *mumas, integer *m1, integer *m2, integer * + nm1, doublereal *fac1, doublereal *e1, integer *lde1, doublereal *z1, + doublereal *f1, integer *ip1, integer *iphes, integer *ier, integer * + ijob) +{ + /* System generated locals */ + integer fjac_dim1, fjac_offset, fmas_dim1, fmas_offset, e1_dim1, + e1_offset, i__1, i__2, i__3, i__4, i__5, i__6; + + /* Local variables */ + static integer i__, j, k; + static doublereal s1; + static integer mm, mp, im1, mp1, jkm; + extern /* Subroutine */ int sol_(integer *, integer *, doublereal *, + doublereal *, integer *); + static doublereal sum1; + extern /* Subroutine */ int solb_(integer *, integer *, doublereal *, + integer *, integer *, doublereal *, integer *), solh_(integer *, + integer *, doublereal *, integer *, doublereal *, integer *); + static doublereal zsafe; + + + /* Parameter adjustments */ + --iphes; + --f1; + --z1; + fjac_dim1 = *ldjac; + fjac_offset = 1 + fjac_dim1; + fjac -= fjac_offset; + --ip1; + fmas_dim1 = *ldmas; + fmas_offset = 1 + fmas_dim1; + fmas -= fmas_offset; + e1_dim1 = *lde1; + e1_offset = 1 + e1_dim1; + e1 -= e1_offset; + + /* Function Body */ + switch (*ijob) { + case 1: goto L1; + case 2: goto L2; + case 3: goto L3; + case 4: goto L4; + case 5: goto L5; + case 6: goto L6; + case 7: goto L7; + case 8: goto L55; + case 9: goto L55; + case 10: goto L55; + case 11: goto L11; + case 12: goto L12; + case 13: goto L13; + case 14: goto L13; + case 15: goto L15; + } + +/* ----------------------------------------------------------- */ + +L1: +/* --- B=IDENTITY, JACOBIAN A FULL MATRIX */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + z1[i__] -= f1[i__] * *fac1; + } + sol_(n, lde1, &e1[e1_offset], &z1[1], &ip1[1]); + return 0; + +/* ----------------------------------------------------------- */ + +L11: +/* --- B=IDENTITY, JACOBIAN A FULL MATRIX, SECOND ORDER */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + z1[i__] -= f1[i__] * *fac1; + } +L48: + mm = *m1 / *m2; + i__1 = *m2; + for (j = 1; j <= i__1; ++j) { + sum1 = 0.; + for (k = mm - 1; k >= 0; --k) { + jkm = j + k * *m2; + sum1 = (z1[jkm] + sum1) / *fac1; + i__2 = *nm1; + for (i__ = 1; i__ <= i__2; ++i__) { + im1 = i__ + *m1; + z1[im1] += fjac[i__ + jkm * fjac_dim1] * sum1; + } + } + } + sol_(nm1, lde1, &e1[e1_offset], &z1[*m1 + 1], &ip1[1]); +L49: + for (i__ = *m1; i__ >= 1; --i__) { + z1[i__] = (z1[i__] + z1[*m2 + i__]) / *fac1; + } + return 0; + +/* ----------------------------------------------------------- */ + +L2: +/* --- B=IDENTITY, JACOBIAN A BANDED MATRIX */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + z1[i__] -= f1[i__] * *fac1; + } + solb_(n, lde1, &e1[e1_offset], &linal_1.mle, &linal_1.mue, &z1[1], &ip1[1]); + return 0; + +/* ----------------------------------------------------------- */ + +L12: +/* --- B=IDENTITY, JACOBIAN A BANDED MATRIX, SECOND ORDER */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + z1[i__] -= f1[i__] * *fac1; + } +L45: + mm = *m1 / *m2; + i__1 = *m2; + for (j = 1; j <= i__1; ++j) { + sum1 = 0.; + for (k = mm - 1; k >= 0; --k) { + jkm = j + k * *m2; + sum1 = (z1[jkm] + sum1) / *fac1; + /* Computing MAX */ + i__2 = 1, i__3 = j - *mujac; + /* Computing MIN */ + i__5 = *nm1, i__6 = j + *mljac; + i__4 = min(i__5,i__6); + for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { + im1 = i__ + *m1; + z1[im1] += fjac[i__ + *mujac + 1 - j + jkm * fjac_dim1] * sum1; + } + } + } + solb_(nm1, lde1, &e1[e1_offset], &linal_1.mle, &linal_1.mue, &z1[*m1 + 1], &ip1[1]); + goto L49; + +/* ----------------------------------------------------------- */ + +L3: +/* --- B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + s1 = 0.; + /* Computing MAX */ + i__4 = 1, i__2 = i__ - *mlmas; + /* Computing MIN */ + i__5 = *n, i__6 = i__ + *mumas; + i__3 = min(i__5,i__6); + for (j = max(i__4,i__2); j <= i__3; ++j) { + s1 -= fmas[i__ - j + linal_1.mbdiag + j * fmas_dim1] * f1[j]; + } + z1[i__] += s1 * *fac1; + } + sol_(n, lde1, &e1[e1_offset], &z1[1], &ip1[1]); + return 0; + +/* ----------------------------------------------------------- */ + +L13: +/* --- B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER */ + i__1 = *m1; + for (i__ = 1; i__ <= i__1; ++i__) { + z1[i__] -= f1[i__] * *fac1; + } + i__1 = *nm1; + for (i__ = 1; i__ <= i__1; ++i__) { + im1 = i__ + *m1; + s1 = 0.; + /* Computing MAX */ + i__3 = 1, i__4 = i__ - *mlmas; + /* Computing MIN */ + i__5 = *nm1, i__6 = i__ + *mumas; + i__2 = min(i__5,i__6); + for (j = max(i__3,i__4); j <= i__2; ++j) { + s1 -= fmas[i__ - j + linal_1.mbdiag + j * fmas_dim1] * f1[j + *m1]; + } + z1[im1] += s1 * *fac1; + } + if (*ijob == 14) { + goto L45; + } + goto L48; + +/* ----------------------------------------------------------- */ + +L4: +/* --- B IS A BANDED MATRIX, JACOBIAN A BANDED MATRIX */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + s1 = 0.; + /* Computing MAX */ + i__2 = 1, i__3 = i__ - *mlmas; + /* Computing MIN */ + i__5 = *n, i__6 = i__ + *mumas; + i__4 = min(i__5,i__6); + for (j = max(i__2,i__3); j <= i__4; ++j) { + s1 -= fmas[i__ - j + linal_1.mbdiag + j * fmas_dim1] * f1[j]; + } + z1[i__] += s1 * *fac1; + } + solb_(n, lde1, &e1[e1_offset], &linal_1.mle, &linal_1.mue, &z1[1], &ip1[1]); + return 0; + +/* ----------------------------------------------------------- */ + +L5: +/* --- B IS A FULL MATRIX, JACOBIAN A FULL MATRIX */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + s1 = 0.; + i__4 = *n; + for (j = 1; j <= i__4; ++j) { + s1 -= fmas[i__ + j * fmas_dim1] * f1[j]; + } + z1[i__] += s1 * *fac1; + } + sol_(n, lde1, &e1[e1_offset], &z1[1], &ip1[1]); + return 0; + +/* ----------------------------------------------------------- */ + +L15: +/* --- B IS A FULL MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER */ + i__1 = *m1; + for (i__ = 1; i__ <= i__1; ++i__) { + z1[i__] -= f1[i__] * *fac1; + } + i__1 = *nm1; + for (i__ = 1; i__ <= i__1; ++i__) { + im1 = i__ + *m1; + s1 = 0.; + i__4 = *nm1; + for (j = 1; j <= i__4; ++j) { + s1 -= fmas[i__ + j * fmas_dim1] * f1[j + *m1]; + } + z1[im1] += s1 * *fac1; + } + goto L48; + +/* ----------------------------------------------------------- */ + +L6: +/* --- B IS A FULL MATRIX, JACOBIAN A BANDED MATRIX */ +/* --- THIS OPTION IS NOT PROVIDED */ + return 0; + +/* ----------------------------------------------------------- */ + +L7: +/* --- B=IDENTITY, JACOBIAN A FULL MATRIX, HESSENBERG-OPTION */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + z1[i__] -= f1[i__] * *fac1; + } + for (mm = *n - 2; mm >= 1; --mm) { + mp = *n - mm; + mp1 = mp - 1; + i__ = iphes[mp]; + if (i__ == mp) { + goto L746; + } + zsafe = z1[mp]; + z1[mp] = z1[i__]; + z1[i__] = zsafe; +L746: + i__1 = *n; + for (i__ = mp + 1; i__ <= i__1; ++i__) { + z1[i__] -= fjac[i__ + mp1 * fjac_dim1] * z1[mp]; + } + } + solh_(n, lde1, &e1[e1_offset], &c__1, &z1[1], &ip1[1]); + i__1 = *n - 2; + for (mm = 1; mm <= i__1; ++mm) { + mp = *n - mm; + mp1 = mp - 1; + i__4 = *n; + for (i__ = mp + 1; i__ <= i__4; ++i__) { + z1[i__] += fjac[i__ + mp1 * fjac_dim1] * z1[mp]; + } + i__ = iphes[mp]; + if (i__ == mp) { + goto L750; + } + zsafe = z1[mp]; + z1[mp] = z1[i__]; + z1[i__] = zsafe; +L750: + ; + } + return 0; + +/* ----------------------------------------------------------- */ + +L55: + return 0; +} /* slvrar_ */ + + +/* END OF SUBROUTINE SLVRAR */ + +/* *********************************************************** */ + +/* Subroutine */ int slvrai_(integer *n, doublereal *fjac, integer *ldjac, + integer *mljac, integer *mujac, doublereal *fmas, integer *ldmas, + integer *mlmas, integer *mumas, integer *m1, integer *m2, integer * + nm1, doublereal *alphn, doublereal *betan, doublereal *e2r, + doublereal *e2i, integer *lde1, doublereal *z2, doublereal *z3, + doublereal *f2, doublereal *f3, doublereal *cont, integer *ip2, + integer *iphes, integer *ier, integer *ijob) +{ + /* System generated locals */ + integer fjac_dim1, fjac_offset, fmas_dim1, fmas_offset, e2r_dim1, + e2r_offset, e2i_dim1, e2i_offset, i__1, i__2, i__3, i__4, i__5, + i__6; + doublereal d__1, d__2; + + /* Local variables */ + static integer i__, j, k; + static doublereal s2, s3, bb; + static integer mm, mp, im1, jm1, mp1; + static doublereal z2i, z3i; + static integer jkm, mpi; + static doublereal sum2, sum3, abno; + extern /* Subroutine */ int solc_(integer *, integer *, doublereal *, + doublereal *, doublereal *, doublereal *, integer *); + static integer iimu; + static doublereal sumh, e1imp; + extern /* Subroutine */ int solbc_(integer *, integer *, doublereal *, + doublereal *, integer *, integer *, doublereal *, doublereal *, + integer *); + static doublereal zsafe; + extern /* Subroutine */ int solhc_(integer *, integer *, doublereal *, + doublereal *, integer *, doublereal *, doublereal *, integer *); + + + /* Parameter adjustments */ + --iphes; + --f3; + --f2; + --z3; + --z2; + fjac_dim1 = *ldjac; + fjac_offset = 1 + fjac_dim1; + fjac -= fjac_offset; + --ip2; + fmas_dim1 = *ldmas; + fmas_offset = 1 + fmas_dim1; + fmas -= fmas_offset; + e2i_dim1 = *lde1; + e2i_offset = 1 + e2i_dim1; + e2i -= e2i_offset; + e2r_dim1 = *lde1; + e2r_offset = 1 + e2r_dim1; + e2r -= e2r_offset; + + /* Function Body */ + switch (*ijob) { + case 1: goto L1; + case 2: goto L2; + case 3: goto L3; + case 4: goto L4; + case 5: goto L5; + case 6: goto L6; + case 7: goto L7; + case 8: goto L55; + case 9: goto L55; + case 10: goto L55; + case 11: goto L11; + case 12: goto L12; + case 13: goto L13; + case 14: goto L13; + case 15: goto L15; + } + +/* ----------------------------------------------------------- */ + +L1: +/* --- B=IDENTITY, JACOBIAN A FULL MATRIX */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + s2 = -f2[i__]; + s3 = -f3[i__]; + z2[i__] = z2[i__] + s2 * *alphn - s3 * *betan; + z3[i__] = z3[i__] + s3 * *alphn + s2 * *betan; + } + solc_(n, lde1, &e2r[e2r_offset], &e2i[e2i_offset], &z2[1], &z3[1], &ip2[1]); + return 0; + +/* ----------------------------------------------------------- */ + +L11: +/* --- B=IDENTITY, JACOBIAN A FULL MATRIX, SECOND ORDER */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + s2 = -f2[i__]; + s3 = -f3[i__]; + z2[i__] = z2[i__] + s2 * *alphn - s3 * *betan; + z3[i__] = z3[i__] + s3 * *alphn + s2 * *betan; + } +L48: + /* Computing 2nd power */ + d__1 = *alphn; + /* Computing 2nd power */ + d__2 = *betan; + abno = d__1 * d__1 + d__2 * d__2; + mm = *m1 / *m2; + i__1 = *m2; + for (j = 1; j <= i__1; ++j) { + sum2 = 0.; + sum3 = 0.; + for (k = mm - 1; k >= 0; --k) { + jkm = j + k * *m2; + sumh = (z2[jkm] + sum2) / abno; + sum3 = (z3[jkm] + sum3) / abno; + sum2 = sumh * *alphn + sum3 * *betan; + sum3 = sum3 * *alphn - sumh * *betan; + i__2 = *nm1; + for (i__ = 1; i__ <= i__2; ++i__) { + im1 = i__ + *m1; + z2[im1] += fjac[i__ + jkm * fjac_dim1] * sum2; + z3[im1] += fjac[i__ + jkm * fjac_dim1] * sum3; + } + } + } + solc_(nm1, lde1, &e2r[e2r_offset], &e2i[e2i_offset], &z2[*m1 + 1], &z3[* + m1 + 1], &ip2[1]); +L49: + for (i__ = *m1; i__ >= 1; --i__) { + mpi = *m2 + i__; + z2i = z2[i__] + z2[mpi]; + z3i = z3[i__] + z3[mpi]; + z3[i__] = (z3i * *alphn - z2i * *betan) / abno; + z2[i__] = (z2i * *alphn + z3i * *betan) / abno; + } + return 0; + +/* ----------------------------------------------------------- */ + +L2: +/* --- B=IDENTITY, JACOBIAN A BANDED MATRIX */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + s2 = -f2[i__]; + s3 = -f3[i__]; + z2[i__] = z2[i__] + s2 * *alphn - s3 * *betan; + z3[i__] = z3[i__] + s3 * *alphn + s2 * *betan; + } + solbc_(n, lde1, &e2r[e2r_offset], &e2i[e2i_offset], &linal_1.mle, & + linal_1.mue, &z2[1], &z3[1], &ip2[1]); + return 0; + +/* ----------------------------------------------------------- */ + +L12: +/* --- B=IDENTITY, JACOBIAN A BANDED MATRIX, SECOND ORDER */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + s2 = -f2[i__]; + s3 = -f3[i__]; + z2[i__] = z2[i__] + s2 * *alphn - s3 * *betan; + z3[i__] = z3[i__] + s3 * *alphn + s2 * *betan; + } +L45: + /* Computing 2nd power */ + d__1 = *alphn; + /* Computing 2nd power */ + d__2 = *betan; + abno = d__1 * d__1 + d__2 * d__2; + mm = *m1 / *m2; + i__1 = *m2; + for (j = 1; j <= i__1; ++j) { + sum2 = 0.; + sum3 = 0.; + for (k = mm - 1; k >= 0; --k) { + jkm = j + k * *m2; + sumh = (z2[jkm] + sum2) / abno; + sum3 = (z3[jkm] + sum3) / abno; + sum2 = sumh * *alphn + sum3 * *betan; + sum3 = sum3 * *alphn - sumh * *betan; + /* Computing MAX */ + i__2 = 1, i__3 = j - *mujac; + /* Computing MIN */ + i__5 = *nm1, i__6 = j + *mljac; + i__4 = min(i__5,i__6); + for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { + im1 = i__ + *m1; + iimu = i__ + *mujac + 1 - j; + z2[im1] += fjac[iimu + jkm * fjac_dim1] * sum2; + z3[im1] += fjac[iimu + jkm * fjac_dim1] * sum3; + } + } + } + solbc_(nm1, lde1, &e2r[e2r_offset], &e2i[e2i_offset], &linal_1.mle, & + linal_1.mue, &z2[*m1 + 1], &z3[*m1 + 1], &ip2[1]); + goto L49; + +/* ----------------------------------------------------------- */ + +L3: +/* --- B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + s2 = 0.; + s3 = 0.; + /* Computing MAX */ + i__4 = 1, i__2 = i__ - *mlmas; + /* Computing MIN */ + i__5 = *n, i__6 = i__ + *mumas; + i__3 = min(i__5,i__6); + for (j = max(i__4,i__2); j <= i__3; ++j) { + bb = fmas[i__ - j + linal_1.mbdiag + j * fmas_dim1]; + s2 -= bb * f2[j]; + s3 -= bb * f3[j]; + } + z2[i__] = z2[i__] + s2 * *alphn - s3 * *betan; + z3[i__] = z3[i__] + s3 * *alphn + s2 * *betan; + } + solc_(n, lde1, &e2r[e2r_offset], &e2i[e2i_offset], &z2[1], &z3[1], &ip2[1]); + return 0; + +/* ----------------------------------------------------------- */ + +L13: +/* --- B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER */ + i__1 = *m1; + for (i__ = 1; i__ <= i__1; ++i__) { + s2 = -f2[i__]; + s3 = -f3[i__]; + z2[i__] = z2[i__] + s2 * *alphn - s3 * *betan; + z3[i__] = z3[i__] + s3 * *alphn + s2 * *betan; + } + i__1 = *nm1; + for (i__ = 1; i__ <= i__1; ++i__) { + im1 = i__ + *m1; + s2 = 0.; + s3 = 0.; + /* Computing MAX */ + i__3 = 1, i__4 = i__ - *mlmas; + /* Computing MIN */ + i__5 = *nm1, i__6 = i__ + *mumas; + i__2 = min(i__5,i__6); + for (j = max(i__3,i__4); j <= i__2; ++j) { + jm1 = j + *m1; + bb = fmas[i__ - j + linal_1.mbdiag + j * fmas_dim1]; + s2 -= bb * f2[jm1]; + s3 -= bb * f3[jm1]; + } + z2[im1] = z2[im1] + s2 * *alphn - s3 * *betan; + z3[im1] = z3[im1] + s3 * *alphn + s2 * *betan; + } + if (*ijob == 14) { + goto L45; + } + goto L48; + +/* ----------------------------------------------------------- */ + +L4: +/* --- B IS A BANDED MATRIX, JACOBIAN A BANDED MATRIX */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + s2 = 0.; + s3 = 0.; + /* Computing MAX */ + i__2 = 1, i__3 = i__ - *mlmas; + /* Computing MIN */ + i__5 = *n, i__6 = i__ + *mumas; + i__4 = min(i__5,i__6); + for (j = max(i__2,i__3); j <= i__4; ++j) { + bb = fmas[i__ - j + linal_1.mbdiag + j * fmas_dim1]; + s2 -= bb * f2[j]; + s3 -= bb * f3[j]; + } + z2[i__] = z2[i__] + s2 * *alphn - s3 * *betan; + z3[i__] = z3[i__] + s3 * *alphn + s2 * *betan; + } + solbc_(n, lde1, &e2r[e2r_offset], &e2i[e2i_offset], &linal_1.mle, & + linal_1.mue, &z2[1], &z3[1], &ip2[1]); + return 0; + +/* ----------------------------------------------------------- */ + +L5: +/* --- B IS A FULL MATRIX, JACOBIAN A FULL MATRIX */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + s2 = 0.; + s3 = 0.; + i__4 = *n; + for (j = 1; j <= i__4; ++j) { + bb = fmas[i__ + j * fmas_dim1]; + s2 -= bb * f2[j]; + s3 -= bb * f3[j]; + } + z2[i__] = z2[i__] + s2 * *alphn - s3 * *betan; + z3[i__] = z3[i__] + s3 * *alphn + s2 * *betan; + } + solc_(n, lde1, &e2r[e2r_offset], &e2i[e2i_offset], &z2[1], &z3[1], &ip2[1]); + return 0; + +/* ----------------------------------------------------------- */ + +L15: +/* --- B IS A FULL MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER */ + i__1 = *m1; + for (i__ = 1; i__ <= i__1; ++i__) { + s2 = -f2[i__]; + s3 = -f3[i__]; + z2[i__] = z2[i__] + s2 * *alphn - s3 * *betan; + z3[i__] = z3[i__] + s3 * *alphn + s2 * *betan; + } + i__1 = *nm1; + for (i__ = 1; i__ <= i__1; ++i__) { + im1 = i__ + *m1; + s2 = 0.; + s3 = 0.; + i__4 = *nm1; + for (j = 1; j <= i__4; ++j) { + jm1 = j + *m1; + bb = fmas[i__ + j * fmas_dim1]; + s2 -= bb * f2[jm1]; + s3 -= bb * f3[jm1]; + } + z2[im1] = z2[im1] + s2 * *alphn - s3 * *betan; + z3[im1] = z3[im1] + s3 * *alphn + s2 * *betan; + } + goto L48; + +/* ----------------------------------------------------------- */ + +L6: +/* --- B IS A FULL MATRIX, JACOBIAN A BANDED MATRIX */ +/* --- THIS OPTION IS NOT PROVIDED */ + return 0; + +/* ----------------------------------------------------------- */ + +L7: +/* --- B=IDENTITY, JACOBIAN A FULL MATRIX, HESSENBERG-OPTION */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + s2 = -f2[i__]; + s3 = -f3[i__]; + z2[i__] = z2[i__] + s2 * *alphn - s3 * *betan; + z3[i__] = z3[i__] + s3 * *alphn + s2 * *betan; + } + for (mm = *n - 2; mm >= 1; --mm) { + mp = *n - mm; + mp1 = mp - 1; + i__ = iphes[mp]; + if (i__ == mp) { + goto L746; + } + zsafe = z2[mp]; + z2[mp] = z2[i__]; + z2[i__] = zsafe; + zsafe = z3[mp]; + z3[mp] = z3[i__]; + z3[i__] = zsafe; +L746: + i__1 = *n; + for (i__ = mp + 1; i__ <= i__1; ++i__) { + e1imp = fjac[i__ + mp1 * fjac_dim1]; + z2[i__] -= e1imp * z2[mp]; + z3[i__] -= e1imp * z3[mp]; + } + } + solhc_(n, lde1, &e2r[e2r_offset], &e2i[e2i_offset], &c__1, &z2[1], &z3[1],&ip2[1]); + i__1 = *n - 2; + for (mm = 1; mm <= i__1; ++mm) { + mp = *n - mm; + mp1 = mp - 1; + i__4 = *n; + for (i__ = mp + 1; i__ <= i__4; ++i__) { + e1imp = fjac[i__ + mp1 * fjac_dim1]; + z2[i__] += e1imp * z2[mp]; + z3[i__] += e1imp * z3[mp]; + } + i__ = iphes[mp]; + if (i__ == mp) { + goto L750; + } + zsafe = z2[mp]; + z2[mp] = z2[i__]; + z2[i__] = zsafe; + zsafe = z3[mp]; + z3[mp] = z3[i__]; + z3[i__] = zsafe; +L750: + ; + } + return 0; + +/* ----------------------------------------------------------- */ + +L55: + return 0; +} /* slvrai_ */ + + +/* END OF SUBROUTINE SLVRAI */ + +/* *********************************************************** */ + +/* Subroutine */ int slvrad_(integer *n, doublereal *fjac, integer *ldjac, + integer *mljac, integer *mujac, doublereal *fmas, integer *ldmas, + integer *mlmas, integer *mumas, integer *m1, integer *m2, integer * + nm1, doublereal *fac1, doublereal *alphn, doublereal *betan, + doublereal *e1, doublereal *e2r, doublereal *e2i, integer *lde1, + doublereal *z1, doublereal *z2, doublereal *z3, doublereal *f1, + doublereal *f2, doublereal *f3, doublereal *cont, integer *ip1, + integer *ip2, integer *iphes, integer *ier, integer *ijob) +{ + /* System generated locals */ + integer fjac_dim1, fjac_offset, fmas_dim1, fmas_offset, e1_dim1, + e1_offset, e2r_dim1, e2r_offset, e2i_dim1, e2i_offset, i__1, i__2, + i__3, i__4, i__5, i__6; + doublereal d__1, d__2; + + /* Local variables */ + static integer i__, j, k; + static doublereal s1, s2, s3, bb; + static integer mm, mp, j1b, j2b, im1, jm1, mp1; + static doublereal z2i, z3i; + static integer jkm, mpi; + extern /* Subroutine */ int sol_(integer *, integer *, doublereal *, + doublereal *, integer *); + static doublereal sum1, sum2, sum3, ffja, abno; + extern /* Subroutine */ int solb_(integer *, integer *, doublereal *, + integer *, integer *, doublereal *, integer *), solc_(integer *, + integer *, doublereal *, doublereal *, doublereal *, doublereal *, + integer *), solh_(integer *, integer *, doublereal *, integer *, + doublereal *, integer *); + static doublereal sumh, e1imp; + extern /* Subroutine */ int solbc_(integer *, integer *, doublereal *, + doublereal *, integer *, integer *, doublereal *, doublereal *, + integer *); + static doublereal zsafe; + extern /* Subroutine */ int solhc_(integer *, integer *, doublereal *, + doublereal *, integer *, doublereal *, doublereal *, integer *); + + + /* Parameter adjustments */ + --iphes; + --f3; + --f2; + --f1; + --z3; + --z2; + --z1; + fjac_dim1 = *ldjac; + fjac_offset = 1 + fjac_dim1; + fjac -= fjac_offset; + --ip2; + --ip1; + fmas_dim1 = *ldmas; + fmas_offset = 1 + fmas_dim1; + fmas -= fmas_offset; + e2i_dim1 = *lde1; + e2i_offset = 1 + e2i_dim1; + e2i -= e2i_offset; + e2r_dim1 = *lde1; + e2r_offset = 1 + e2r_dim1; + e2r -= e2r_offset; + e1_dim1 = *lde1; + e1_offset = 1 + e1_dim1; + e1 -= e1_offset; + + /* Function Body */ + switch (*ijob) { + case 1: goto L1; + case 2: goto L2; + case 3: goto L3; + case 4: goto L4; + case 5: goto L5; + case 6: goto L6; + case 7: goto L7; + case 8: goto L55; + case 9: goto L55; + case 10: goto L55; + case 11: goto L11; + case 12: goto L12; + case 13: goto L13; + case 14: goto L13; + case 15: goto L15; + } + +/* ----------------------------------------------------------- */ + +L1: +/* --- B=IDENTITY, JACOBIAN A FULL MATRIX */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + s2 = -f2[i__]; + s3 = -f3[i__]; + z1[i__] -= f1[i__] * *fac1; + z2[i__] = z2[i__] + s2 * *alphn - s3 * *betan; + z3[i__] = z3[i__] + s3 * *alphn + s2 * *betan; + } + sol_(n, lde1, &e1[e1_offset], &z1[1], &ip1[1]); + solc_(n, lde1, &e2r[e2r_offset], &e2i[e2i_offset], &z2[1], &z3[1], &ip2[1]); + return 0; + +/* ----------------------------------------------------------- */ + +L11: +/* --- B=IDENTITY, JACOBIAN A FULL MATRIX, SECOND ORDER */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + s2 = -f2[i__]; + s3 = -f3[i__]; + z1[i__] -= f1[i__] * *fac1; + z2[i__] = z2[i__] + s2 * *alphn - s3 * *betan; + z3[i__] = z3[i__] + s3 * *alphn + s2 * *betan; + } +L48: +/* Computing 2nd power */ + d__1 = *alphn; +/* Computing 2nd power */ + d__2 = *betan; + abno = d__1 * d__1 + d__2 * d__2; + mm = *m1 / *m2; + i__1 = *m2; + for (j = 1; j <= i__1; ++j) { + sum1 = 0.; + sum2 = 0.; + sum3 = 0.; + for (k = mm - 1; k >= 0; --k) { + jkm = j + k * *m2; + sum1 = (z1[jkm] + sum1) / *fac1; + sumh = (z2[jkm] + sum2) / abno; + sum3 = (z3[jkm] + sum3) / abno; + sum2 = sumh * *alphn + sum3 * *betan; + sum3 = sum3 * *alphn - sumh * *betan; + i__2 = *nm1; + for (i__ = 1; i__ <= i__2; ++i__) { + im1 = i__ + *m1; + z1[im1] += fjac[i__ + jkm * fjac_dim1] * sum1; + z2[im1] += fjac[i__ + jkm * fjac_dim1] * sum2; + z3[im1] += fjac[i__ + jkm * fjac_dim1] * sum3; + } + } + } + sol_(nm1, lde1, &e1[e1_offset], &z1[*m1 + 1], &ip1[1]); + solc_(nm1, lde1, &e2r[e2r_offset], &e2i[e2i_offset], &z2[*m1 + 1], &z3[* + m1 + 1], &ip2[1]); +L49: + for (i__ = *m1; i__ >= 1; --i__) { + mpi = *m2 + i__; + z1[i__] = (z1[i__] + z1[mpi]) / *fac1; + z2i = z2[i__] + z2[mpi]; + z3i = z3[i__] + z3[mpi]; + z3[i__] = (z3i * *alphn - z2i * *betan) / abno; + z2[i__] = (z2i * *alphn + z3i * *betan) / abno; + } + return 0; + +/* ----------------------------------------------------------- */ + +L2: +/* --- B=IDENTITY, JACOBIAN A BANDED MATRIX */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + s2 = -f2[i__]; + s3 = -f3[i__]; + z1[i__] -= f1[i__] * *fac1; + z2[i__] = z2[i__] + s2 * *alphn - s3 * *betan; + z3[i__] = z3[i__] + s3 * *alphn + s2 * *betan; + } + solb_(n, lde1, &e1[e1_offset], &linal_1.mle, &linal_1.mue, &z1[1], &ip1[1]); + solbc_(n, lde1, &e2r[e2r_offset], &e2i[e2i_offset], &linal_1.mle, & + linal_1.mue, &z2[1], &z3[1], &ip2[1]); + return 0; + +/* ----------------------------------------------------------- */ + +L12: +/* --- B=IDENTITY, JACOBIAN A BANDED MATRIX, SECOND ORDER */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + s2 = -f2[i__]; + s3 = -f3[i__]; + z1[i__] -= f1[i__] * *fac1; + z2[i__] = z2[i__] + s2 * *alphn - s3 * *betan; + z3[i__] = z3[i__] + s3 * *alphn + s2 * *betan; + } +L45: +/* Computing 2nd power */ + d__1 = *alphn; +/* Computing 2nd power */ + d__2 = *betan; + abno = d__1 * d__1 + d__2 * d__2; + mm = *m1 / *m2; + i__1 = *m2; + for (j = 1; j <= i__1; ++j) { + sum1 = 0.; + sum2 = 0.; + sum3 = 0.; + for (k = mm - 1; k >= 0; --k) { + jkm = j + k * *m2; + sum1 = (z1[jkm] + sum1) / *fac1; + sumh = (z2[jkm] + sum2) / abno; + sum3 = (z3[jkm] + sum3) / abno; + sum2 = sumh * *alphn + sum3 * *betan; + sum3 = sum3 * *alphn - sumh * *betan; + /* Computing MAX */ + i__2 = 1, i__3 = j - *mujac; + /* Computing MIN */ + i__5 = *nm1, i__6 = j + *mljac; + i__4 = min(i__5,i__6); + for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { + im1 = i__ + *m1; + ffja = fjac[i__ + *mujac + 1 - j + jkm * fjac_dim1]; + z1[im1] += ffja * sum1; + z2[im1] += ffja * sum2; + z3[im1] += ffja * sum3; + } + } + } + solb_(nm1, lde1, &e1[e1_offset], &linal_1.mle, &linal_1.mue, &z1[*m1 + 1],&ip1[1]); + solbc_(nm1, lde1, &e2r[e2r_offset], &e2i[e2i_offset], &linal_1.mle, & + linal_1.mue, &z2[*m1 + 1], &z3[*m1 + 1], &ip2[1]); + goto L49; + +/* ----------------------------------------------------------- */ + +L3: +/* --- B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + s1 = 0.; + s2 = 0.; + s3 = 0.; + /* Computing MAX */ + i__4 = 1, i__2 = i__ - *mlmas; + /* Computing MIN */ + i__5 = *n, i__6 = i__ + *mumas; + i__3 = min(i__5,i__6); + for (j = max(i__4,i__2); j <= i__3; ++j) { + bb = fmas[i__ - j + linal_1.mbdiag + j * fmas_dim1]; + s1 -= bb * f1[j]; + s2 -= bb * f2[j]; + s3 -= bb * f3[j]; + } + z1[i__] += s1 * *fac1; + z2[i__] = z2[i__] + s2 * *alphn - s3 * *betan; + z3[i__] = z3[i__] + s3 * *alphn + s2 * *betan; + } + sol_(n, lde1, &e1[e1_offset], &z1[1], &ip1[1]); + solc_(n, lde1, &e2r[e2r_offset], &e2i[e2i_offset], &z2[1], &z3[1], &ip2[1]); + return 0; + +/* ----------------------------------------------------------- */ + +L13: +/* --- B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER */ + i__1 = *m1; + for (i__ = 1; i__ <= i__1; ++i__) { + s2 = -f2[i__]; + s3 = -f3[i__]; + z1[i__] -= f1[i__] * *fac1; + z2[i__] = z2[i__] + s2 * *alphn - s3 * *betan; + z3[i__] = z3[i__] + s3 * *alphn + s2 * *betan; + } + i__1 = *nm1; + for (i__ = 1; i__ <= i__1; ++i__) { + im1 = i__ + *m1; + s1 = 0.; + s2 = 0.; + s3 = 0.; + /* Computing MAX */ + i__3 = 1, i__4 = i__ - *mlmas; + j1b = max(i__3,i__4); + /* Computing MIN */ + i__3 = *nm1, i__4 = i__ + *mumas; + j2b = min(i__3,i__4); + i__3 = j2b; + for (j = j1b; j <= i__3; ++j) { + jm1 = j + *m1; + bb = fmas[i__ - j + linal_1.mbdiag + j * fmas_dim1]; + s1 -= bb * f1[jm1]; + s2 -= bb * f2[jm1]; + s3 -= bb * f3[jm1]; + } + z1[im1] += s1 * *fac1; + z2[im1] = z2[im1] + s2 * *alphn - s3 * *betan; + z3[im1] = z3[im1] + s3 * *alphn + s2 * *betan; + } + if (*ijob == 14) { + goto L45; + } + goto L48; + +/* ----------------------------------------------------------- */ + +L4: +/* --- B IS A BANDED MATRIX, JACOBIAN A BANDED MATRIX */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + s1 = 0.; + s2 = 0.; + s3 = 0.; + /* Computing MAX */ + i__3 = 1, i__4 = i__ - *mlmas; + /* Computing MIN */ + i__5 = *n, i__6 = i__ + *mumas; + i__2 = min(i__5,i__6); + for (j = max(i__3,i__4); j <= i__2; ++j) { + bb = fmas[i__ - j + linal_1.mbdiag + j * fmas_dim1]; + s1 -= bb * f1[j]; + s2 -= bb * f2[j]; + s3 -= bb * f3[j]; + } + z1[i__] += s1 * *fac1; + z2[i__] = z2[i__] + s2 * *alphn - s3 * *betan; + z3[i__] = z3[i__] + s3 * *alphn + s2 * *betan; + } + solb_(n, lde1, &e1[e1_offset], &linal_1.mle, &linal_1.mue, &z1[1], &ip1[1]); + solbc_(n, lde1, &e2r[e2r_offset], &e2i[e2i_offset], &linal_1.mle, & + linal_1.mue, &z2[1], &z3[1], &ip2[1]); + return 0; + +/* ----------------------------------------------------------- */ + +L5: +/* --- B IS A FULL MATRIX, JACOBIAN A FULL MATRIX */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + s1 = 0.; + s2 = 0.; + s3 = 0.; + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + bb = fmas[i__ + j * fmas_dim1]; + s1 -= bb * f1[j]; + s2 -= bb * f2[j]; + s3 -= bb * f3[j]; + } + z1[i__] += s1 * *fac1; + z2[i__] = z2[i__] + s2 * *alphn - s3 * *betan; + z3[i__] = z3[i__] + s3 * *alphn + s2 * *betan; + } + sol_(n, lde1, &e1[e1_offset], &z1[1], &ip1[1]); + solc_(n, lde1, &e2r[e2r_offset], &e2i[e2i_offset], &z2[1], &z3[1], &ip2[1]); + return 0; + +/* ----------------------------------------------------------- */ + +L15: +/* --- B IS A FULL MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER */ + i__1 = *m1; + for (i__ = 1; i__ <= i__1; ++i__) { + s2 = -f2[i__]; + s3 = -f3[i__]; + z1[i__] -= f1[i__] * *fac1; + z2[i__] = z2[i__] + s2 * *alphn - s3 * *betan; + z3[i__] = z3[i__] + s3 * *alphn + s2 * *betan; + } + i__1 = *nm1; + for (i__ = 1; i__ <= i__1; ++i__) { + im1 = i__ + *m1; + s1 = 0.; + s2 = 0.; + s3 = 0.; + i__2 = *nm1; + for (j = 1; j <= i__2; ++j) { + jm1 = j + *m1; + bb = fmas[i__ + j * fmas_dim1]; + s1 -= bb * f1[jm1]; + s2 -= bb * f2[jm1]; + s3 -= bb * f3[jm1]; + } + z1[im1] += s1 * *fac1; + z2[im1] = z2[im1] + s2 * *alphn - s3 * *betan; + z3[im1] = z3[im1] + s3 * *alphn + s2 * *betan; + } + goto L48; + +/* ----------------------------------------------------------- */ + +L6: +/* --- B IS A FULL MATRIX, JACOBIAN A BANDED MATRIX */ +/* --- THIS OPTION IS NOT PROVIDED */ + return 0; + +/* ----------------------------------------------------------- */ + +L7: +/* --- B=IDENTITY, JACOBIAN A FULL MATRIX, HESSENBERG-OPTION */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + s2 = -f2[i__]; + s3 = -f3[i__]; + z1[i__] -= f1[i__] * *fac1; + z2[i__] = z2[i__] + s2 * *alphn - s3 * *betan; + z3[i__] = z3[i__] + s3 * *alphn + s2 * *betan; + } + for (mm = *n - 2; mm >= 1; --mm) { + mp = *n - mm; + mp1 = mp - 1; + i__ = iphes[mp]; + if (i__ == mp) { + goto L746; + } + zsafe = z1[mp]; + z1[mp] = z1[i__]; + z1[i__] = zsafe; + zsafe = z2[mp]; + z2[mp] = z2[i__]; + z2[i__] = zsafe; + zsafe = z3[mp]; + z3[mp] = z3[i__]; + z3[i__] = zsafe; +L746: + i__1 = *n; + for (i__ = mp + 1; i__ <= i__1; ++i__) { + e1imp = fjac[i__ + mp1 * fjac_dim1]; + z1[i__] -= e1imp * z1[mp]; + z2[i__] -= e1imp * z2[mp]; + z3[i__] -= e1imp * z3[mp]; + } + } + solh_(n, lde1, &e1[e1_offset], &c__1, &z1[1], &ip1[1]); + solhc_(n, lde1, &e2r[e2r_offset], &e2i[e2i_offset], &c__1, &z2[1], &z3[1],&ip2[1]); + i__1 = *n - 2; + for (mm = 1; mm <= i__1; ++mm) { + mp = *n - mm; + mp1 = mp - 1; + i__2 = *n; + for (i__ = mp + 1; i__ <= i__2; ++i__) { + e1imp = fjac[i__ + mp1 * fjac_dim1]; + z1[i__] += e1imp * z1[mp]; + z2[i__] += e1imp * z2[mp]; + z3[i__] += e1imp * z3[mp]; + } + i__ = iphes[mp]; + if (i__ == mp) { + goto L750; + } + zsafe = z1[mp]; + z1[mp] = z1[i__]; + z1[i__] = zsafe; + zsafe = z2[mp]; + z2[mp] = z2[i__]; + z2[i__] = zsafe; + zsafe = z3[mp]; + z3[mp] = z3[i__]; + z3[i__] = zsafe; +L750: + ; + } + return 0; + +/* ----------------------------------------------------------- */ + +L55: + return 0; +} /* slvrad_ */ + + +/* END OF SUBROUTINE SLVRAD */ + +/* *********************************************************** */ + +/* Subroutine */ int estrad_(integer *n, doublereal *fjac, integer *ldjac, + integer *mljac, integer *mujac, doublereal *fmas, integer *ldmas, + integer *mlmas, integer *mumas, doublereal *h__, doublereal *dd1, + doublereal *dd2, doublereal *dd3, FP_CB_f fcn, void* fcn_PY, integer *nfcn, doublereal + *y0, doublereal *y, integer *ijob, doublereal *x, integer *m1, + integer *m2, integer *nm1, doublereal *e1, integer *lde1, doublereal * + z1, doublereal *z2, doublereal *z3, doublereal *cont, doublereal * + werr, doublereal *f1, doublereal *f2, integer *ip1, integer *iphes, + doublereal *scal, doublereal *err, logical *first, logical *reject, + doublereal *fac1, doublereal *rpar, integer *ipar) +{ + /* System generated locals */ + integer fjac_dim1, fjac_offset, fmas_dim1, fmas_offset, e1_dim1, + e1_offset, i__1, i__2, i__3, i__4, i__5, i__6; + doublereal d__1; + + /* Local variables */ + static integer i__, j, k, mm, mp, im1; + extern /* Subroutine */ int sol_(integer *, integer *, doublereal *, + doublereal *, integer *); + static doublereal sum, hee1, hee2, hee3, sum1; + extern /* Subroutine */ int solb_(integer *, integer *, doublereal *, + integer *, integer *, doublereal *, integer *), solh_(integer *, + integer *, doublereal *, integer *, doublereal *, integer *); + static doublereal zsafe; + + /* Parameter adjustments */ + --scal; + --iphes; + --f2; + --f1; + --werr; + --cont; + --z3; + --z2; + --z1; + --y; + --y0; + fjac_dim1 = *ldjac; + fjac_offset = 1 + fjac_dim1; + fjac -= fjac_offset; + --ip1; + fmas_dim1 = *ldmas; + fmas_offset = 1 + fmas_dim1; + fmas -= fmas_offset; + e1_dim1 = *lde1; + e1_offset = 1 + e1_dim1; + e1 -= e1_offset; + --rpar; + --ipar; + + /* Function Body */ + hee1 = *dd1 / *h__; + hee2 = *dd2 / *h__; + hee3 = *dd3 / *h__; + switch (*ijob) { + case 1: goto L1; + case 2: goto L2; + case 3: goto L3; + case 4: goto L4; + case 5: goto L5; + case 6: goto L6; + case 7: goto L7; + case 8: goto L55; + case 9: goto L55; + case 10: goto L55; + case 11: goto L11; + case 12: goto L12; + case 13: goto L13; + case 14: goto L14; + case 15: goto L15; + } + +L1: +/* ------ B=IDENTITY, JACOBIAN A FULL MATRIX */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + f2[i__] = hee1 * z1[i__] + hee2 * z2[i__] + hee3 * z3[i__]; + cont[i__] = f2[i__] + y0[i__]; + } + sol_(n, lde1, &e1[e1_offset], &cont[1], &ip1[1]); + goto L77; + +L11: +/* ------ B=IDENTITY, JACOBIAN A FULL MATRIX, SECOND ORDER */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + f2[i__] = hee1 * z1[i__] + hee2 * z2[i__] + hee3 * z3[i__]; + cont[i__] = f2[i__] + y0[i__]; + } +L48: + mm = *m1 / *m2; + i__1 = *m2; + for (j = 1; j <= i__1; ++j) { + sum1 = 0.; + for (k = mm - 1; k >= 0; --k) { + sum1 = (cont[j + k * *m2] + sum1) / *fac1; + i__2 = *nm1; + for (i__ = 1; i__ <= i__2; ++i__) { + im1 = i__ + *m1; + cont[im1] += fjac[i__ + (j + k * *m2) * fjac_dim1] * sum1; + } + } + } + sol_(nm1, lde1, &e1[e1_offset], &cont[*m1 + 1], &ip1[1]); + for (i__ = *m1; i__ >= 1; --i__) { + cont[i__] = (cont[i__] + cont[*m2 + i__]) / *fac1; + } + goto L77; + +L2: +/* ------ B=IDENTITY, JACOBIAN A BANDED MATRIX */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + f2[i__] = hee1 * z1[i__] + hee2 * z2[i__] + hee3 * z3[i__]; + cont[i__] = f2[i__] + y0[i__]; + } + solb_(n, lde1, &e1[e1_offset], &linal_1.mle, &linal_1.mue, &cont[1], &ip1[1]); + goto L77; + +L12: +/* ------ B=IDENTITY, JACOBIAN A BANDED MATRIX, SECOND ORDER */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + f2[i__] = hee1 * z1[i__] + hee2 * z2[i__] + hee3 * z3[i__]; + cont[i__] = f2[i__] + y0[i__]; + } +L45: + mm = *m1 / *m2; + i__1 = *m2; + for (j = 1; j <= i__1; ++j) { + sum1 = 0.; + for (k = mm - 1; k >= 0; --k) { + sum1 = (cont[j + k * *m2] + sum1) / *fac1; + /* Computing MAX */ + i__2 = 1, i__3 = j - *mujac; + /* Computing MIN */ + i__5 = *nm1, i__6 = j + *mljac; + i__4 = min(i__5,i__6); + for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { + im1 = i__ + *m1; + cont[im1] += fjac[i__ + *mujac + 1 - j + (j + k * *m2) * fjac_dim1] * sum1; + } + } + } + solb_(nm1, lde1, &e1[e1_offset], &linal_1.mle, &linal_1.mue, &cont[*m1 + 1], &ip1[1]); + for (i__ = *m1; i__ >= 1; --i__) { + cont[i__] = (cont[i__] + cont[*m2 + i__]) / *fac1; + } + goto L77; + +L3: +/* ------ B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + f1[i__] = hee1 * z1[i__] + hee2 * z2[i__] + hee3 * z3[i__]; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = 0.; + /* Computing MAX */ + i__4 = 1, i__2 = i__ - *mlmas; + /* Computing MIN */ + i__5 = *n, i__6 = i__ + *mumas; + i__3 = min(i__5,i__6); + for (j = max(i__4,i__2); j <= i__3; ++j) { + sum += fmas[i__ - j + linal_1.mbdiag + j * fmas_dim1] * f1[j]; + } + f2[i__] = sum; + cont[i__] = sum + y0[i__]; + } + sol_(n, lde1, &e1[e1_offset], &cont[1], &ip1[1]); + goto L77; + +L13: +/* ------ B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER */ + i__1 = *m1; + for (i__ = 1; i__ <= i__1; ++i__) { + f2[i__] = hee1 * z1[i__] + hee2 * z2[i__] + hee3 * z3[i__]; + cont[i__] = f2[i__] + y0[i__]; + } + i__1 = *n; + for (i__ = *m1 + 1; i__ <= i__1; ++i__) { + f1[i__] = hee1 * z1[i__] + hee2 * z2[i__] + hee3 * z3[i__]; + } + i__1 = *nm1; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = 0.; + /* Computing MAX */ + i__3 = 1, i__4 = i__ - *mlmas; + /* Computing MIN */ + i__5 = *nm1, i__6 = i__ + *mumas; + i__2 = min(i__5,i__6); + for (j = max(i__3,i__4); j <= i__2; ++j) { + sum += fmas[i__ - j + linal_1.mbdiag + j * fmas_dim1] * f1[j + *m1]; + } + im1 = i__ + *m1; + f2[im1] = sum; + cont[im1] = sum + y0[im1]; + } + goto L48; + +L4: +/* ------ B IS A BANDED MATRIX, JACOBIAN A BANDED MATRIX */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + f1[i__] = hee1 * z1[i__] + hee2 * z2[i__] + hee3 * z3[i__]; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = 0.; + /* Computing MAX */ + i__2 = 1, i__3 = i__ - *mlmas; + /* Computing MIN */ + i__5 = *n, i__6 = i__ + *mumas; + i__4 = min(i__5,i__6); + for (j = max(i__2,i__3); j <= i__4; ++j) { + sum += fmas[i__ - j + linal_1.mbdiag + j * fmas_dim1] * f1[j]; + } + f2[i__] = sum; + cont[i__] = sum + y0[i__]; + } + solb_(n, lde1, &e1[e1_offset], &linal_1.mle, &linal_1.mue, &cont[1], &ip1[1]); + goto L77; + +L14: +/* ------ B IS A BANDED MATRIX, JACOBIAN A BANDED MATRIX, SECOND ORDER */ + i__1 = *m1; + for (i__ = 1; i__ <= i__1; ++i__) { + f2[i__] = hee1 * z1[i__] + hee2 * z2[i__] + hee3 * z3[i__]; + cont[i__] = f2[i__] + y0[i__]; + } + i__1 = *n; + for (i__ = *m1 + 1; i__ <= i__1; ++i__) { + f1[i__] = hee1 * z1[i__] + hee2 * z2[i__] + hee3 * z3[i__]; + } + i__1 = *nm1; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = 0.; + /* Computing MAX */ + i__4 = 1, i__2 = i__ - *mlmas; + /* Computing MIN */ + i__5 = *nm1, i__6 = i__ + *mumas; + i__3 = min(i__5,i__6); + for (j = max(i__4,i__2); j <= i__3; ++j) { + sum += fmas[i__ - j + linal_1.mbdiag + j * fmas_dim1] * f1[j + *m1]; + } + im1 = i__ + *m1; + f2[im1] = sum; + cont[im1] = sum + y0[im1]; + } + goto L45; + +L5: +/* ------ B IS A FULL MATRIX, JACOBIAN A FULL MATRIX */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + f1[i__] = hee1 * z1[i__] + hee2 * z2[i__] + hee3 * z3[i__]; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = 0.; + i__3 = *n; + for (j = 1; j <= i__3; ++j) { + sum += fmas[i__ + j * fmas_dim1] * f1[j]; + } + f2[i__] = sum; + cont[i__] = sum + y0[i__]; + } + sol_(n, lde1, &e1[e1_offset], &cont[1], &ip1[1]); + goto L77; + +L15: +/* ------ B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER */ + i__1 = *m1; + for (i__ = 1; i__ <= i__1; ++i__) { + f2[i__] = hee1 * z1[i__] + hee2 * z2[i__] + hee3 * z3[i__]; + cont[i__] = f2[i__] + y0[i__]; + } + i__1 = *n; + for (i__ = *m1 + 1; i__ <= i__1; ++i__) { + f1[i__] = hee1 * z1[i__] + hee2 * z2[i__] + hee3 * z3[i__]; + } + i__1 = *nm1; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = 0.; + i__3 = *nm1; + for (j = 1; j <= i__3; ++j) { + sum += fmas[i__ + j * fmas_dim1] * f1[j + *m1]; + } + im1 = i__ + *m1; + f2[im1] = sum; + cont[im1] = sum + y0[im1]; + } + goto L48; + +L6: +/* ------ B IS A FULL MATRIX, JACOBIAN A BANDED MATRIX */ +/* ------ THIS OPTION IS NOT PROVIDED */ + return 0; + +L7: +/* ------ B=IDENTITY, JACOBIAN A FULL MATRIX, HESSENBERG-OPTION */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + f2[i__] = hee1 * z1[i__] + hee2 * z2[i__] + hee3 * z3[i__]; + cont[i__] = f2[i__] + y0[i__]; + } + for (mm = *n - 2; mm >= 1; --mm) { + mp = *n - mm; + i__ = iphes[mp]; + if (i__ == mp) { + goto L310; + } + zsafe = cont[mp]; + cont[mp] = cont[i__]; + cont[i__] = zsafe; +L310: + i__1 = *n; + for (i__ = mp + 1; i__ <= i__1; ++i__) { + cont[i__] -= fjac[i__ + (mp - 1) * fjac_dim1] * cont[mp]; + } + } + solh_(n, lde1, &e1[e1_offset], &c__1, &cont[1], &ip1[1]); + i__1 = *n - 2; + for (mm = 1; mm <= i__1; ++mm) { + mp = *n - mm; + i__3 = *n; + for (i__ = mp + 1; i__ <= i__3; ++i__) { + cont[i__] += fjac[i__ + (mp - 1) * fjac_dim1] * cont[mp]; + } + i__ = iphes[mp]; + if (i__ == mp) { + goto L440; + } + zsafe = cont[mp]; + cont[mp] = cont[i__]; + cont[i__] = zsafe; +L440: + ; + } + +/* -------------------------------------- */ + +L77: + *err = 0.; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + werr[i__] = cont[i__] / scal[i__]; + /* Computing 2nd power */ + d__1 = werr[i__]; + *err += d__1 * d__1; + } + /* Computing MAX */ + d__1 = sqrt(*err / *n); + *err = max(d__1,1e-10); + + if (*err < 1.) { + return 0; + } + if (*first || *reject) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + cont[i__] = y[i__] + cont[i__]; + } + (*fcn)(n, x, &cont[1], &f1[1], &rpar[1], &ipar[1], fcn_PY); + ++(*nfcn); + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + cont[i__] = f1[i__] + f2[i__]; + } + switch (*ijob) { + case 1: goto L31; + case 2: goto L32; + case 3: goto L31; + case 4: goto L32; + case 5: goto L31; + case 6: goto L32; + case 7: goto L33; + case 8: goto L55; + case 9: goto L55; + case 10: goto L55; + case 11: goto L41; + case 12: goto L42; + case 13: goto L41; + case 14: goto L42; + case 15: goto L41; + } + /* ------ FULL MATRIX OPTION */ +L31: + sol_(n, lde1, &e1[e1_offset], &cont[1], &ip1[1]); + goto L88; + /* ------ FULL MATRIX OPTION, SECOND ORDER */ +L41: + i__1 = *m2; + for (j = 1; j <= i__1; ++j) { + sum1 = 0.; + for (k = mm - 1; k >= 0; --k) { + sum1 = (cont[j + k * *m2] + sum1) / *fac1; + i__3 = *nm1; + for (i__ = 1; i__ <= i__3; ++i__) { + im1 = i__ + *m1; + cont[im1] += fjac[i__ + (j + k * *m2) * fjac_dim1] * sum1; + } + } + } + sol_(nm1, lde1, &e1[e1_offset], &cont[*m1 + 1], &ip1[1]); + for (i__ = *m1; i__ >= 1; --i__) { + cont[i__] = (cont[i__] + cont[*m2 + i__]) / *fac1; + } + goto L88; + /* ------ BANDED MATRIX OPTION */ + L32: + solb_(n, lde1, &e1[e1_offset], &linal_1.mle, &linal_1.mue, &cont[1], &ip1[1]); + goto L88; + /* ------ BANDED MATRIX OPTION, SECOND ORDER */ + L42: + i__1 = *m2; + for (j = 1; j <= i__1; ++j) { + sum1 = 0.; + for (k = mm - 1; k >= 0; --k) { + sum1 = (cont[j + k * *m2] + sum1) / *fac1; + /* Computing MAX */ + i__3 = 1, i__4 = j - *mujac; + /* Computing MIN */ + i__5 = *nm1, i__6 = j + *mljac; + i__2 = min(i__5,i__6); + for (i__ = max(i__3,i__4); i__ <= i__2; ++i__) { + im1 = i__ + *m1; + cont[im1] += fjac[i__ + *mujac + 1 - j + (j + k * *m2) * + fjac_dim1] * sum1; + } + } + } + solb_(nm1, lde1, &e1[e1_offset], &linal_1.mle, &linal_1.mue, &cont[* + m1 + 1], &ip1[1]); + for (i__ = *m1; i__ >= 1; --i__) { + cont[i__] = (cont[i__] + cont[*m2 + i__]) / *fac1; + } + goto L88; + /* ------ HESSENBERG MATRIX OPTION */ +L33: + for (mm = *n - 2; mm >= 1; --mm) { + mp = *n - mm; + i__ = iphes[mp]; + if (i__ == mp) { + goto L510; + } + zsafe = cont[mp]; + cont[mp] = cont[i__]; + cont[i__] = zsafe; +L510: + i__1 = *n; + for (i__ = mp + 1; i__ <= i__1; ++i__) { + cont[i__] -= fjac[i__ + (mp - 1) * fjac_dim1] * cont[mp]; + } + } + solh_(n, lde1, &e1[e1_offset], &c__1, &cont[1], &ip1[1]); + i__1 = *n - 2; + for (mm = 1; mm <= i__1; ++mm) { + mp = *n - mm; + i__2 = *n; + for (i__ = mp + 1; i__ <= i__2; ++i__) { + cont[i__] += fjac[i__ + (mp - 1) * fjac_dim1] * cont[mp]; + } + i__ = iphes[mp]; + if (i__ == mp) { + goto L640; + } + zsafe = cont[mp]; + cont[mp] = cont[i__]; + cont[i__] = zsafe; +L640: + ; + } + /* ----------------------------------- */ +L88: + *err = 0.; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + werr[i__] = cont[i__] / scal[i__]; + /* Computing 2nd power */ + d__1 = werr[i__]; + *err += d__1 * d__1; + } + /* Computing MAX */ + d__1 = sqrt(*err / *n); + *err = max(d__1,1e-10); + } + return 0; +/* ----------------------------------------------------------- */ +L55: + return 0; +} /* estrad_ */ + + +/* END OF SUBROUTINE ESTRAD */ + +/* *********************************************************** */ + +/* Subroutine */ int estrav_(integer *n, doublereal *fjac, integer *ldjac, + integer *mljac, integer *mujac, doublereal *fmas, integer *ldmas, + integer *mlmas, integer *mumas, doublereal *h__, doublereal *dd, FP_CB_f + fcn, void* fcn_PY, integer *nfcn, doublereal *y0, doublereal *y, integer *ijob, + doublereal *x, integer *m1, integer *m2, integer *nm1, integer *ns, + integer *nns, doublereal *e1, integer *lde1, doublereal *zz, + doublereal *cont, doublereal *ff, integer *ip1, integer *iphes, + doublereal *scal, doublereal *err, logical *first, logical *reject, + doublereal *fac1, doublereal *rpar, integer *ipar) +{ + /* System generated locals */ + integer fjac_dim1, fjac_offset, fmas_dim1, fmas_offset, e1_dim1, + e1_offset, i__1, i__2, i__3, i__4, i__5, i__6; + doublereal d__1; + + /* Local variables */ + static integer i__, j, k, mm, mp, im1; + extern /* Subroutine */ int sol_(integer *, integer *, doublereal *, + doublereal *, integer *); + static doublereal sum, sum1; + extern /* Subroutine */ int solb_(integer *, integer *, doublereal *, + integer *, integer *, doublereal *, integer *), solh_(integer *, + integer *, doublereal *, integer *, doublereal *, integer *); + static doublereal zsafe; + + /* Parameter adjustments */ + --scal; + --iphes; + --cont; + --y; + --y0; + fjac_dim1 = *ldjac; + fjac_offset = 1 + fjac_dim1; + fjac -= fjac_offset; + --ip1; + fmas_dim1 = *ldmas; + fmas_offset = 1 + fmas_dim1; + fmas -= fmas_offset; + --dd; + --ff; + --zz; + e1_dim1 = *lde1; + e1_offset = 1 + e1_dim1; + e1 -= e1_offset; + --rpar; + --ipar; + + /* Function Body */ + switch (*ijob) { + case 1: goto L1; + case 2: goto L2; + case 3: goto L3; + case 4: goto L4; + case 5: goto L5; + case 6: goto L6; + case 7: goto L7; + case 8: goto L55; + case 9: goto L55; + case 10: goto L55; + case 11: goto L11; + case 12: goto L12; + case 13: goto L13; + case 14: goto L14; + case 15: goto L15; + } + +L1: +/* ------ B=IDENTITY, JACOBIAN A FULL MATRIX */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = 0.; + i__2 = *ns; + for (k = 1; k <= i__2; ++k) { + sum += dd[k] * zz[i__ + (k - 1) * *n]; + } + ff[i__ + *n] = sum / *h__; + cont[i__] = ff[i__ + *n] + y0[i__]; + } + sol_(n, lde1, &e1[e1_offset], &cont[1], &ip1[1]); + goto L77; + +L11: +/* ------ B=IDENTITY, JACOBIAN A FULL MATRIX, SECOND ORDER */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = 0.; + i__2 = *ns; + for (k = 1; k <= i__2; ++k) { + sum += dd[k] * zz[i__ + (k - 1) * *n]; + } + ff[i__ + *n] = sum / *h__; + cont[i__] = ff[i__ + *n] + y0[i__]; + } +L48: + mm = *m1 / *m2; + i__1 = *m2; + for (j = 1; j <= i__1; ++j) { + sum1 = 0.; + for (k = mm - 1; k >= 0; --k) { + sum1 = (cont[j + k * *m2] + sum1) / *fac1; + i__2 = *nm1; + for (i__ = 1; i__ <= i__2; ++i__) { + im1 = i__ + *m1; + cont[im1] += fjac[i__ + (j + k * *m2) * fjac_dim1] * sum1; + } + } + } + sol_(nm1, lde1, &e1[e1_offset], &cont[*m1 + 1], &ip1[1]); + for (i__ = *m1; i__ >= 1; --i__) { + cont[i__] = (cont[i__] + cont[*m2 + i__]) / *fac1; + } + goto L77; + +L2: +/* ------ B=IDENTITY, JACOBIAN A BANDED MATRIX */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = 0.; + i__2 = *ns; + for (k = 1; k <= i__2; ++k) { + sum += dd[k] * zz[i__ + (k - 1) * *n]; + } + ff[i__ + *n] = sum / *h__; + cont[i__] = ff[i__ + *n] + y0[i__]; + } + solb_(n, lde1, &e1[e1_offset], &linal_1.mle, &linal_1.mue, &cont[1], &ip1[1]); + goto L77; + +L12: +/* ------ B=IDENTITY, JACOBIAN A BANDED MATRIX, SECOND ORDER */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = 0.; + i__2 = *ns; + for (k = 1; k <= i__2; ++k) { + sum += dd[k] * zz[i__ + (k - 1) * *n]; + } + ff[i__ + *n] = sum / *h__; + cont[i__] = ff[i__ + *n] + y0[i__]; + } +L45: + mm = *m1 / *m2; + i__1 = *m2; + for (j = 1; j <= i__1; ++j) { + sum1 = 0.; + for (k = mm - 1; k >= 0; --k) { + sum1 = (cont[j + k * *m2] + sum1) / *fac1; + /* Computing MAX */ + i__2 = 1, i__3 = j - *mujac; + /* Computing MIN */ + i__5 = *nm1, i__6 = j + *mljac; + i__4 = min(i__5,i__6); + for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { + im1 = i__ + *m1; + cont[im1] += fjac[i__ + *mujac + 1 - j + (j + k * *m2) * fjac_dim1] * sum1; + } + } + } + solb_(nm1, lde1, &e1[e1_offset], &linal_1.mle, &linal_1.mue, &cont[*m1 + 1], &ip1[1]); + for (i__ = *m1; i__ >= 1; --i__) { + cont[i__] = (cont[i__] + cont[*m2 + i__]) / *fac1; + } + goto L77; + +L3: +/* ------ B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = 0.; + i__4 = *ns; + for (k = 1; k <= i__4; ++k) { + sum += dd[k] * zz[i__ + (k - 1) * *n]; + } + ff[i__] = sum / *h__; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = 0.; + /* Computing MAX */ + i__4 = 1, i__2 = i__ - *mlmas; + /* Computing MIN */ + i__5 = *n, i__6 = i__ + *mumas; + i__3 = min(i__5,i__6); + for (j = max(i__4,i__2); j <= i__3; ++j) { + sum += fmas[i__ - j + linal_1.mbdiag + j * fmas_dim1] * ff[j]; + } + ff[i__ + *n] = sum; + cont[i__] = sum + y0[i__]; + } + sol_(n, lde1, &e1[e1_offset], &cont[1], &ip1[1]); + goto L77; + +L13: +/* ------ B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER */ + i__1 = *m1; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = 0.; + i__3 = *ns; + for (k = 1; k <= i__3; ++k) { + sum += dd[k] * zz[i__ + (k - 1) * *n]; + } + ff[i__ + *n] = sum / *h__; + cont[i__] = ff[i__ + *n] + y0[i__]; + } + i__1 = *n; + for (i__ = *m1 + 1; i__ <= i__1; ++i__) { + sum = 0.; + i__3 = *ns; + for (k = 1; k <= i__3; ++k) { + sum += dd[k] * zz[i__ + (k - 1) * *n]; + } + ff[i__] = sum / *h__; + } + i__1 = *nm1; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = 0.; + /* Computing MAX */ + i__3 = 1, i__4 = i__ - *mlmas; + /* Computing MIN */ + i__5 = *nm1, i__6 = i__ + *mumas; + i__2 = min(i__5,i__6); + for (j = max(i__3,i__4); j <= i__2; ++j) { + sum += fmas[i__ - j + linal_1.mbdiag + j * fmas_dim1] * ff[j + *m1]; + } + im1 = i__ + *m1; + ff[im1 + *n] = sum; + cont[im1] = sum + y0[im1]; + } + goto L48; + +L4: +/* ------ B IS A BANDED MATRIX, JACOBIAN A BANDED MATRIX */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = 0.; + i__2 = *ns; + for (k = 1; k <= i__2; ++k) { + sum += dd[k] * zz[i__ + (k - 1) * *n]; + } + ff[i__] = sum / *h__; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = 0.; + /* Computing MAX */ + i__2 = 1, i__3 = i__ - *mlmas; + /* Computing MIN */ + i__5 = *n, i__6 = i__ + *mumas; + i__4 = min(i__5,i__6); + for (j = max(i__2,i__3); j <= i__4; ++j) { + sum += fmas[i__ - j + linal_1.mbdiag + j * fmas_dim1] * ff[j]; + } + ff[i__ + *n] = sum; + cont[i__] = sum + y0[i__]; + } + solb_(n, lde1, &e1[e1_offset], &linal_1.mle, &linal_1.mue, &cont[1], &ip1[1]); + goto L77; + +L14: +/* ------ B IS A BANDED MATRIX, JACOBIAN A BANDED MATRIX, SECOND ORDER */ + i__1 = *m1; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = 0.; + i__4 = *ns; + for (k = 1; k <= i__4; ++k) { + sum += dd[k] * zz[i__ + (k - 1) * *n]; + } + ff[i__ + *n] = sum / *h__; + cont[i__] = ff[i__ + *n] + y0[i__]; + } + i__1 = *n; + for (i__ = *m1 + 1; i__ <= i__1; ++i__) { + sum = 0.; + i__4 = *ns; + for (k = 1; k <= i__4; ++k) { + sum += dd[k] * zz[i__ + (k - 1) * *n]; + } + ff[i__] = sum / *h__; + } + i__1 = *nm1; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = 0.; + /* Computing MAX */ + i__4 = 1, i__2 = i__ - *mlmas; + /* Computing MIN */ + i__5 = *nm1, i__6 = i__ + *mumas; + i__3 = min(i__5,i__6); + for (j = max(i__4,i__2); j <= i__3; ++j) { + sum += fmas[i__ - j + linal_1.mbdiag + j * fmas_dim1] * ff[j + *m1]; + } + im1 = i__ + *m1; + ff[im1 + *n] = sum; + cont[im1] = sum + y0[im1]; + } + goto L45; + +L5: +/* ------ B IS A FULL MATRIX, JACOBIAN A FULL MATRIX */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = 0.; + i__3 = *ns; + for (k = 1; k <= i__3; ++k) { + sum += dd[k] * zz[i__ + (k - 1) * *n]; + } + ff[i__] = sum / *h__; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = 0.; + i__3 = *n; + for (j = 1; j <= i__3; ++j) { + sum += fmas[i__ + j * fmas_dim1] * ff[j]; + } + ff[i__ + *n] = sum; + cont[i__] = sum + y0[i__]; + } + sol_(n, lde1, &e1[e1_offset], &cont[1], &ip1[1]); + goto L77; + +L15: +/* ------ B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER */ + i__1 = *m1; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = 0.; + i__3 = *ns; + for (k = 1; k <= i__3; ++k) { + sum += dd[k] * zz[i__ + (k - 1) * *n]; + } + ff[i__ + *n] = sum / *h__; + cont[i__] = ff[i__ + *n] + y0[i__]; + } + i__1 = *n; + for (i__ = *m1 + 1; i__ <= i__1; ++i__) { + sum = 0.; + i__3 = *ns; + for (k = 1; k <= i__3; ++k) { + sum += dd[k] * zz[i__ + (k - 1) * *n]; + } + ff[i__] = sum / *h__; + } + i__1 = *nm1; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = 0.; + i__3 = *nm1; + for (j = 1; j <= i__3; ++j) { + sum += fmas[i__ + j * fmas_dim1] * ff[j + *m1]; + } + im1 = i__ + *m1; + ff[im1 + *n] = sum; + cont[im1] = sum + y0[im1]; + } + goto L48; + +L6: +/* ------ B IS A FULL MATRIX, JACOBIAN A BANDED MATRIX */ +/* ------ THIS OPTION IS NOT PROVIDED */ + return 0; + +L7: +/* ------ B=IDENTITY, JACOBIAN A FULL MATRIX, HESSENBERG-OPTION */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = 0.; + i__3 = *ns; + for (k = 1; k <= i__3; ++k) { + sum += dd[k] * zz[i__ + (k - 1) * *n]; + } + ff[i__ + *n] = sum / *h__; + cont[i__] = ff[i__ + *n] + y0[i__]; + } + for (mm = *n - 2; mm >= 1; --mm) { + mp = *n - mm; + i__ = iphes[mp]; + if (i__ == mp) { + goto L310; + } + zsafe = cont[mp]; + cont[mp] = cont[i__]; + cont[i__] = zsafe; +L310: + i__1 = *n; + for (i__ = mp + 1; i__ <= i__1; ++i__) { + cont[i__] -= fjac[i__ + (mp - 1) * fjac_dim1] * cont[mp]; + } + } + solh_(n, lde1, &e1[e1_offset], &c__1, &cont[1], &ip1[1]); + i__1 = *n - 2; + for (mm = 1; mm <= i__1; ++mm) { + mp = *n - mm; + i__3 = *n; + for (i__ = mp + 1; i__ <= i__3; ++i__) { + cont[i__] += fjac[i__ + (mp - 1) * fjac_dim1] * cont[mp]; + } + i__ = iphes[mp]; + if (i__ == mp) { + goto L440; + } + zsafe = cont[mp]; + cont[mp] = cont[i__]; + cont[i__] = zsafe; +L440: + ; + } + +/* -------------------------------------- */ + +L77: + *err = 0.; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + /* Computing 2nd power */ + d__1 = cont[i__] / scal[i__]; + *err += d__1 * d__1; + } +/* Computing MAX */ + d__1 = sqrt(*err / *n); + *err = max(d__1,1e-10); + + if (*err < 1.) { + return 0; + } + if (*first || *reject) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + cont[i__] = y[i__] + cont[i__]; + } + (*fcn)(n, x, &cont[1], &ff[1], &rpar[1], &ipar[1], fcn_PY); + ++(*nfcn); + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + cont[i__] = ff[i__] + ff[i__ + *n]; + } + switch (*ijob) { + case 1: goto L31; + case 2: goto L32; + case 3: goto L31; + case 4: goto L32; + case 5: goto L31; + case 6: goto L32; + case 7: goto L33; + case 8: goto L55; + case 9: goto L55; + case 10: goto L55; + case 11: goto L41; + case 12: goto L42; + case 13: goto L41; + case 14: goto L42; + case 15: goto L41; + } + /* ------ FULL MATRIX OPTION */ +L31: + sol_(n, lde1, &e1[e1_offset], &cont[1], &ip1[1]); + goto L88; + /* ------ FULL MATRIX OPTION, SECOND ORDER */ +L41: + i__1 = *m2; + for (j = 1; j <= i__1; ++j) { + sum1 = 0.; + for (k = mm - 1; k >= 0; --k) { + sum1 = (cont[j + k * *m2] + sum1) / *fac1; + i__3 = *nm1; + for (i__ = 1; i__ <= i__3; ++i__) { + im1 = i__ + *m1; + cont[im1] += fjac[i__ + (j + k * *m2) * fjac_dim1] * sum1; + } + } + } + sol_(nm1, lde1, &e1[e1_offset], &cont[*m1 + 1], &ip1[1]); + for (i__ = *m1; i__ >= 1; --i__) { + cont[i__] = (cont[i__] + cont[*m2 + i__]) / *fac1; + } + goto L88; + /* ------ BANDED MATRIX OPTION */ +L32: + solb_(n, lde1, &e1[e1_offset], &linal_1.mle, &linal_1.mue, &cont[1], &ip1[1]); + goto L88; + /* ------ BANDED MATRIX OPTION, SECOND ORDER */ +L42: + i__1 = *m2; + for (j = 1; j <= i__1; ++j) { + sum1 = 0.; + for (k = mm - 1; k >= 0; --k) { + sum1 = (cont[j + k * *m2] + sum1) / *fac1; + /* Computing MAX */ + i__3 = 1, i__4 = j - *mujac; + /* Computing MIN */ + i__5 = *nm1, i__6 = j + *mljac; + i__2 = min(i__5,i__6); + for (i__ = max(i__3,i__4); i__ <= i__2; ++i__) { + im1 = i__ + *m1; + cont[im1] += fjac[i__ + *mujac + 1 - j + (j + k * *m2) * + fjac_dim1] * sum1; + } + } + } + solb_(nm1, lde1, &e1[e1_offset], &linal_1.mle, &linal_1.mue, &cont[* + m1 + 1], &ip1[1]); + for (i__ = *m1; i__ >= 1; --i__) { + cont[i__] = (cont[i__] + cont[*m2 + i__]) / *fac1; + } + goto L88; + /* ------ HESSENBERG MATRIX OPTION */ +L33: + for (mm = *n - 2; mm >= 1; --mm) { + mp = *n - mm; + i__ = iphes[mp]; + if (i__ == mp) { + goto L510; + } + zsafe = cont[mp]; + cont[mp] = cont[i__]; + cont[i__] = zsafe; +L510: + i__1 = *n; + for (i__ = mp + 1; i__ <= i__1; ++i__) { + cont[i__] -= fjac[i__ + (mp - 1) * fjac_dim1] * cont[mp]; + } + } + solh_(n, lde1, &e1[e1_offset], &c__1, &cont[1], &ip1[1]); + i__1 = *n - 2; + for (mm = 1; mm <= i__1; ++mm) { + mp = *n - mm; + i__2 = *n; + for (i__ = mp + 1; i__ <= i__2; ++i__) { + cont[i__] += fjac[i__ + (mp - 1) * fjac_dim1] * cont[mp]; + } + i__ = iphes[mp]; + if (i__ == mp) { + goto L640; + } + zsafe = cont[mp]; + cont[mp] = cont[i__]; + cont[i__] = zsafe; +L640: + ; + } + /* ----------------------------------- */ + L88: + *err = 0.; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + /* Computing 2nd power */ + d__1 = cont[i__] / scal[i__]; + *err += d__1 * d__1; + } + /* Computing MAX */ + d__1 = sqrt(*err / *n); + *err = max(d__1,1e-10); + } + return 0; + +/* ----------------------------------------------------------- */ + +L55: + return 0; +} /* estrav_ */ + + +/* END OF SUBROUTINE ESTRAV */ + +/* *********************************************************** */ + +/* Subroutine */ int slvrod_(integer *n, doublereal *fjac, integer *ldjac, + integer *mljac, integer *mujac, doublereal *fmas, integer *ldmas, + integer *mlmas, integer *mumas, integer *m1, integer *m2, integer * + nm1, doublereal *fac1, doublereal *e, integer *lde, integer *ip, + doublereal *dy, doublereal *ak, doublereal *fx, doublereal *ynew, + doublereal *hd, integer *ijob, logical *stage1) +{ + /* System generated locals */ + integer fjac_dim1, fjac_offset, fmas_dim1, fmas_offset, e_dim1, e_offset, + i__1, i__2, i__3, i__4, i__5, i__6; + + /* Local variables */ + static integer i__, j, k, mm, im1, jkm; + extern /* Subroutine */ int sol_(integer *, integer *, doublereal *, + doublereal *, integer *); + static doublereal sum; + extern /* Subroutine */ int solb_(integer *, integer *, doublereal *, + integer *, integer *, doublereal *, integer *); + + + /* Parameter adjustments */ + --ynew; + --fx; + --ak; + --dy; + fjac_dim1 = *ldjac; + fjac_offset = 1 + fjac_dim1; + fjac -= fjac_offset; + --ip; + fmas_dim1 = *ldmas; + fmas_offset = 1 + fmas_dim1; + fmas -= fmas_offset; + e_dim1 = *lde; + e_offset = 1 + e_dim1; + e -= e_offset; + + /* Function Body */ + if (*hd == 0.) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + ak[i__] = dy[i__]; + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + ak[i__] = dy[i__] + *hd * fx[i__]; + } + } + + switch (*ijob) { + case 1: goto L1; + case 2: goto L2; + case 3: goto L3; + case 4: goto L4; + case 5: goto L5; + case 6: goto L6; + case 7: goto L55; + case 8: goto L55; + case 9: goto L55; + case 10: goto L55; + case 11: goto L11; + case 12: goto L12; + case 13: goto L13; + case 14: goto L13; + case 15: goto L15; + } + +/* ----------------------------------------------------------- */ + +L1: +/* --- B=IDENTITY, JACOBIAN A FULL MATRIX */ + if (*stage1) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + ak[i__] += ynew[i__]; + } + } + sol_(n, lde, &e[e_offset], &ak[1], &ip[1]); + return 0; + +/* ----------------------------------------------------------- */ + +L11: +/* --- B=IDENTITY, JACOBIAN A FULL MATRIX, SECOND ORDER */ + if (*stage1) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + ak[i__] += ynew[i__]; + } + } +L48: + mm = *m1 / *m2; + i__1 = *m2; + for (j = 1; j <= i__1; ++j) { + sum = 0.; + for (k = mm - 1; k >= 0; --k) { + jkm = j + k * *m2; + sum = (ak[jkm] + sum) / *fac1; + i__2 = *nm1; + for (i__ = 1; i__ <= i__2; ++i__) { + im1 = i__ + *m1; + ak[im1] += fjac[i__ + jkm * fjac_dim1] * sum; + } + } + } + sol_(nm1, lde, &e[e_offset], &ak[*m1 + 1], &ip[1]); + for (i__ = *m1; i__ >= 1; --i__) { + ak[i__] = (ak[i__] + ak[*m2 + i__]) / *fac1; + } + return 0; + +/* ----------------------------------------------------------- */ + +L2: +/* --- B=IDENTITY, JACOBIAN A BANDED MATRIX */ + if (*stage1) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + ak[i__] += ynew[i__]; + } + } + solb_(n, lde, &e[e_offset], &linal_1.mle, &linal_1.mue, &ak[1], &ip[1]); + return 0; + +/* ----------------------------------------------------------- */ + +L12: +/* --- B=IDENTITY, JACOBIAN A BANDED MATRIX, SECOND ORDER */ + if (*stage1) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + ak[i__] += ynew[i__]; + } + } +L45: + mm = *m1 / *m2; + i__1 = *m2; + for (j = 1; j <= i__1; ++j) { + sum = 0.; + for (k = mm - 1; k >= 0; --k) { + jkm = j + k * *m2; + sum = (ak[jkm] + sum) / *fac1; + /* Computing MAX */ + i__2 = 1, i__3 = j - *mujac; + /* Computing MIN */ + i__5 = *nm1, i__6 = j + *mljac; + i__4 = min(i__5,i__6); + for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { + im1 = i__ + *m1; + ak[im1] += fjac[i__ + *mujac + 1 - j + jkm * fjac_dim1] * sum; + } + } + } + solb_(nm1, lde, &e[e_offset], &linal_1.mle, &linal_1.mue, &ak[*m1 + 1], &ip[1]); + for (i__ = *m1; i__ >= 1; --i__) { + ak[i__] = (ak[i__] + ak[*m2 + i__]) / *fac1; + } + return 0; + +/* ----------------------------------------------------------- */ + +L3: +/* --- B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX */ + if (*stage1) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = 0.; + /* Computing MAX */ + i__4 = 1, i__2 = i__ - *mlmas; + /* Computing MIN */ + i__5 = *n, i__6 = i__ + *mumas; + i__3 = min(i__5,i__6); + for (j = max(i__4,i__2); j <= i__3; ++j) { + sum += fmas[i__ - j + linal_1.mbdiag + j * fmas_dim1] * ynew[j]; + } + ak[i__] += sum; + } + } + sol_(n, lde, &e[e_offset], &ak[1], &ip[1]); + return 0; + +/* ----------------------------------------------------------- */ + +L13: +/* --- B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER */ + if (*stage1) { + i__1 = *m1; + for (i__ = 1; i__ <= i__1; ++i__) { + ak[i__] += ynew[i__]; + } + i__1 = *nm1; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = 0.; + /* Computing MAX */ + i__3 = 1, i__4 = i__ - *mlmas; + /* Computing MIN */ + i__5 = *nm1, i__6 = i__ + *mumas; + i__2 = min(i__5,i__6); + for (j = max(i__3,i__4); j <= i__2; ++j) { + sum += fmas[i__ - j + linal_1.mbdiag + j * fmas_dim1] * ynew[j + *m1]; + } + im1 = i__ + *m1; + ak[im1] += sum; + } + } + if (*ijob == 14) { + goto L45; + } + goto L48; + +/* ----------------------------------------------------------- */ + +L4: +/* --- B IS A BANDED MATRIX, JACOBIAN A BANDED MATRIX */ + if (*stage1) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = 0.; + /* Computing MAX */ + i__2 = 1, i__3 = i__ - *mlmas; + /* Computing MIN */ + i__5 = *n, i__6 = i__ + *mumas; + i__4 = min(i__5,i__6); + for (j = max(i__2,i__3); j <= i__4; ++j) { + sum += fmas[i__ - j + linal_1.mbdiag + j * fmas_dim1] * ynew[j]; + } + ak[i__] += sum; + } + } + solb_(n, lde, &e[e_offset], &linal_1.mle, &linal_1.mue, &ak[1], &ip[1]); + return 0; + +/* ----------------------------------------------------------- */ + +L5: +/* --- B IS A FULL MATRIX, JACOBIAN A FULL MATRIX */ + if (*stage1) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = 0.; + i__4 = *n; + for (j = 1; j <= i__4; ++j) { + sum += fmas[i__ + j * fmas_dim1] * ynew[j]; + } + ak[i__] += sum; + } + } + sol_(n, lde, &e[e_offset], &ak[1], &ip[1]); + return 0; + +/* ----------------------------------------------------------- */ + +L15: +/* --- B IS A FULL MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER */ + if (*stage1) { + i__1 = *m1; + for (i__ = 1; i__ <= i__1; ++i__) { + ak[i__] += ynew[i__]; + } + i__1 = *nm1; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = 0.; + i__4 = *nm1; + for (j = 1; j <= i__4; ++j) { + sum += fmas[i__ + j * fmas_dim1] * ynew[j + *m1]; + } + im1 = i__ + *m1; + ak[im1] += sum; + } + } + goto L48; + +/* ----------------------------------------------------------- */ + +L6: +/* --- B IS A FULL MATRIX, JACOBIAN A BANDED MATRIX */ +/* --- THIS OPTION IS NOT PROVIDED */ + if (*stage1) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = 0.; + i__4 = *n; + for (j = 1; j <= i__4; ++j) { + /* L623: */ + sum += fmas[i__ + j * fmas_dim1] * ynew[j]; + } + /* L624: */ + ak[i__] += sum; + } + solb_(n, lde, &e[e_offset], &linal_1.mle, &linal_1.mue, &ak[1], &ip[1]); + } + return 0; + +/* ----------------------------------------------------------- */ + +L55: + return 0; +} /* slvrod_ */ + + +/* END OF SUBROUTINE SLVROD */ + + +/* *********************************************************** */ + +/* Subroutine */ int slvseu_(integer *n, doublereal *fjac, integer *ldjac, + integer *mljac, integer *mujac, doublereal *fmas, integer *ldmas, + integer *mlmas, integer *mumas, integer *m1, integer *m2, integer * + nm1, doublereal *fac1, doublereal *e, integer *lde, integer *ip, + integer *iphes, doublereal *del, integer *ijob) +{ + /* System generated locals */ + integer fjac_dim1, fjac_offset, fmas_dim1, fmas_offset, e_dim1, e_offset, + i__1, i__2, i__3, i__4, i__5, i__6; + + /* Local variables */ + static integer i__, j, k, mm, mp, im1, mp1, jkm, mmm; + extern /* Subroutine */ int sol_(integer *, integer *, doublereal *, + doublereal *, integer *); + static doublereal sum; + extern /* Subroutine */ int solb_(integer *, integer *, doublereal *, + integer *, integer *, doublereal *, integer *), solh_(integer *, + integer *, doublereal *, integer *, doublereal *, integer *); + static doublereal zsafe; + + + /* Parameter adjustments */ + --del; + --iphes; + fjac_dim1 = *ldjac; + fjac_offset = 1 + fjac_dim1; + fjac -= fjac_offset; + --ip; + fmas_dim1 = *ldmas; + fmas_offset = 1 + fmas_dim1; + fmas -= fmas_offset; + e_dim1 = *lde; + e_offset = 1 + e_dim1; + e -= e_offset; + + /* Function Body */ + switch (*ijob) { + case 1: goto L1; + case 2: goto L2; + case 3: goto L1; + case 4: goto L2; + case 5: goto L1; + case 6: goto L55; + case 7: goto L7; + case 8: goto L55; + case 9: goto L55; + case 10: goto L55; + case 11: goto L11; + case 12: goto L12; + case 13: goto L11; + case 14: goto L12; + case 15: goto L11; + } + +/* ----------------------------------------------------------- */ + +L1: +/* --- B=IDENTITY, JACOBIAN A FULL MATRIX */ + sol_(n, lde, &e[e_offset], &del[1], &ip[1]); + return 0; + +/* ----------------------------------------------------------- */ + +L11: +/* --- B=IDENTITY, JACOBIAN A FULL MATRIX, SECOND ORDER */ + mm = *m1 / *m2; + i__1 = *m2; + for (j = 1; j <= i__1; ++j) { + sum = 0.; + for (k = mm - 1; k >= 0; --k) { + jkm = j + k * *m2; + sum = (del[jkm] + sum) / *fac1; + i__2 = *nm1; + for (i__ = 1; i__ <= i__2; ++i__) { + im1 = i__ + *m1; + del[im1] += fjac[i__ + jkm * fjac_dim1] * sum; + } + } + } + sol_(nm1, lde, &e[e_offset], &del[*m1 + 1], &ip[1]); + for (i__ = *m1; i__ >= 1; --i__) { + del[i__] = (del[i__] + del[*m2 + i__]) / *fac1; + } + return 0; + +/* ----------------------------------------------------------- */ + +L2: +/* --- B=IDENTITY, JACOBIAN A BANDED MATRIX */ + solb_(n, lde, &e[e_offset], &linal_1.mle, &linal_1.mue, &del[1], &ip[1]); + return 0; + +/* ----------------------------------------------------------- */ + +L12: +/* --- B=IDENTITY, JACOBIAN A BANDED MATRIX, SECOND ORDER */ + mm = *m1 / *m2; + i__1 = *m2; + for (j = 1; j <= i__1; ++j) { + sum = 0.; + for (k = mm - 1; k >= 0; --k) { + jkm = j + k * *m2; + sum = (del[jkm] + sum) / *fac1; + /* Computing MAX */ + i__2 = 1, i__3 = j - *mujac; + /* Computing MIN */ + i__5 = *nm1, i__6 = j + *mljac; + i__4 = min(i__5,i__6); + for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { + im1 = i__ + *m1; + del[im1] += fjac[i__ + *mujac + 1 - j + jkm * fjac_dim1] * sum; + } + } + } + solb_(nm1, lde, &e[e_offset], &linal_1.mle, &linal_1.mue, &del[*m1 + 1], &ip[1]); + for (i__ = *m1; i__ >= 1; --i__) { + del[i__] = (del[i__] + del[*m2 + i__]) / *fac1; + } + return 0; + +/* ----------------------------------------------------------- */ + +L7: +/* --- HESSENBERG OPTION */ + for (mmm = *n - 2; mmm >= 1; --mmm) { + mp = *n - mmm; + mp1 = mp - 1; + i__ = iphes[mp]; + if (i__ == mp) { + goto L110; + } + zsafe = del[mp]; + del[mp] = del[i__]; + del[i__] = zsafe; +L110: + i__1 = *n; + for (i__ = mp + 1; i__ <= i__1; ++i__) { + del[i__] -= fjac[i__ + mp1 * fjac_dim1] * del[mp]; + } + } + solh_(n, lde, &e[e_offset], &c__1, &del[1], &ip[1]); + i__1 = *n - 2; + for (mmm = 1; mmm <= i__1; ++mmm) { + mp = *n - mmm; + mp1 = mp - 1; + i__4 = *n; + for (i__ = mp + 1; i__ <= i__4; ++i__) { + del[i__] += fjac[i__ + mp1 * fjac_dim1] * del[mp]; + } + i__ = iphes[mp]; + if (i__ == mp) { + goto L240; + } + zsafe = del[mp]; + del[mp] = del[i__]; + del[i__] = zsafe; +L240: + ; + } + return 0; + +/* ----------------------------------------------------------- */ + +L55: + return 0; +} /* slvseu_ */ diff --git a/thirdparty/hairer/radau_decsol_c.h b/thirdparty/hairer/radau_decsol_c.h new file mode 100644 index 00000000..0e524ad1 --- /dev/null +++ b/thirdparty/hairer/radau_decsol_c.h @@ -0,0 +1,38 @@ +#ifndef RADAU_DECSOL_C_H +#define RADAU_DECSOL_C_H + +#include + +#define TRUE_ (1) +#define FALSE_ (0) +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (doublereal)abs(x) +#define min(a,b) ((a) <= (b) ? (a) : (b)) +#define max(a,b) ((a) >= (b) ? (a) : (b)) + +typedef int64_t integer; +typedef double doublereal; +typedef int64_t logical; + +// FP_CB = FunctionPointer_CallBack +typedef int (*FP_CB_f)(integer*, doublereal*, doublereal*, doublereal*, + doublereal*, integer*, void*); +typedef int (*FP_CB_jac)(integer*, doublereal*, doublereal*, doublereal*, + integer*, doublereal*, integer*, void*); +typedef int (*FP_CB_mas)(integer*, doublereal*, integer*, doublereal*, + integer*, void*); +typedef int (*FP_CB_solout)(integer*, doublereal*, doublereal*, doublereal*, + doublereal*, doublereal*, integer*, integer*, + doublereal*, integer*, integer*, void*); + +int radau5_c(integer *n, FP_CB_f fcn, void* fcn_PY, doublereal *x, doublereal * + y, doublereal *xend, doublereal *h__, doublereal *rtol, doublereal * + atol, integer *itol, FP_CB_jac jac, void* jac_PY, integer *ijac, integer *mljac, integer + *mujac, FP_CB_mas mas, void* mas_PY, integer *imas, integer *mlmas, integer *mumas, FP_CB_solout + solout, void* solout_PY, integer *iout, doublereal *work, integer *lwork, integer * + iwork, integer *liwork, doublereal *rpar, integer *ipar, integer * + idid); + +doublereal contr5_c(integer *i__, doublereal *x, doublereal *cont, integer * lrc); + +#endif