diff --git a/.gitignore b/.gitignore index a76dcfbbdb5260e4b049874bb3599ec97ec7f303..3836aaf2e780ba2a579c4e37e66800cc59690e7a 100644 --- a/.gitignore +++ b/.gitignore @@ -1,11 +1,77 @@ -boxmox/boxmox/README.aux -boxmox/boxmox/README.log -boxmox/boxmox/README.toc -boxmox/boxmox/README.pdf -boxmox/boxmox/compiled_mechs -boxmox/bin/kpp -boxmox/src/*.o -boxmox/src/lex.yy.c -boxmox/src/y.tab.c -boxmox/src/y.tab.h +bin/ +share +build +src/kpp +boxmox*.tar.gz + +boxmox/UserManual.toc +boxmox/UserManual.aux +boxmox/UserManual.log +boxmox/UserManual.pdf +doc/boxmox_UserManual.pdf + +src/bison.c +src/bison.h +src/yacc.c + +**~ + +# bc we create this automatically using build_dist.sh +Makefile.am + +doc/boxmox_README.pdf + **.DS_Store + +# http://www.gnu.org/software/automake + +Makefile.in +/ar-lib +/mdate-sh +/py-compile +/test-driver +/ylwrap +.deps/ +.dirstamp + +# http://www.gnu.org/software/autoconf + +autom4te.cache +/autoscan.log +/autoscan-*.log +/aclocal.m4 +/compile +/config.cache +/config.guess +/config.h.in +/config.log +/config.status +/config.sub +/configure +/configure.scan +/depcomp +/install-sh +/missing +/stamp-h1 + +# https://www.gnu.org/software/libtool/ + +/ltmain.sh + +# http://www.gnu.org/software/texinfo + +/texinfo.tex + +# http://www.gnu.org/software/m4/ + +m4/libtool.m4 +m4/ltoptions.m4 +m4/ltsugar.m4 +m4/ltversion.m4 +m4/lt~obsolete.m4 + +# Generated Makefile +# (meta build system like autotools, +# can automatically generate from config.status script +# (which is called by configure script)) +Makefile diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 3174bc3b64f64813000feb40170b602c0e5429af..c5fe95026a06fb8467bb9065bb3467a94a340f96 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -1,53 +1,17 @@ -create_patch: - image: ubuntu:rolling - script: - - bash create_BOXMOX_patch.bash - tags: - - ehs_vm - -boxmox_latest: - image: ubuntu:rolling - script: - - cp -r boxmox boxmox_latest - - bash prep_BOXMOX_src_directory.bash boxmox_latest latest - - tar cvzf boxmox_latest.tar.gz boxmox_latest - tags: - - ehs_vm - artifacts: - paths: - - boxmox_latest.tar.gz +image: ubuntu:rolling -.compile: - script: - - bash install_BOXMOX.bash COMPILE_ONLY - - export KPP_HOME=$(pwd)/boxmox - - export PATH=$KPP_HOME/bin:$KPP_HOME/boxmox/bin:$PATH - - cd boxmox/models - - prepare_BOXMOX_mechanism MOZART_4 - - new_BOXMOX_experiment_from_example chamber_experiment - - for mechpath in *def; - do - mech=${mechpath/.def/}; - echo ${mech}; - if [ "${mech}" != "CB05TUCl_EPA" ] && [ "${mech}" != "MCMv3_3" ]; - then - prepare_BOXMOX_mechanism -f ${mech}; - new_BOXMOX_experiment ${mech} chamber_experiment_${mech}; - cp chamber_experiment/*csv chamber_experiment_${mech}/; - cd chamber_experiment_${mech}; - ./${mech}.exe; - cd ..; - fi; - done - tags: - - ehs_vm +cache: + paths: + - "$CI_PROJECT_DIR/build/" -compile_ubuntu_latest: - image: ubuntu:rolling - extends: .compile +build: before_script: - DEBIAN_FRONTEND=noninteractive apt-get -qq update - - DEBIAN_FRONTEND=noninteractive apt-get -qq install wget patch make gcc gfortran flex bison texlive - tags: - - ehs_vm - + - DEBIAN_FRONTEND=noninteractive apt-get -qq install wget patch make gcc gfortran flex bison texlive autoconf autotools-dev + - "[ -f ./version ] && export VERSION=$(cat ./version)" + script: + - . build_dist.sh "$CI_PROJECT_DIR/build" + artifacts: + name: boxmox-latest + paths: + - boxmox-*.tar.gz diff --git a/LICENSE b/COPYING similarity index 100% rename from LICENSE rename to COPYING diff --git a/Makefile.am_BLUEPRINT b/Makefile.am_BLUEPRINT new file mode 100644 index 0000000000000000000000000000000000000000..35571740a9ad07c637e8a3aa2648c8f30684a737 --- /dev/null +++ b/Makefile.am_BLUEPRINT @@ -0,0 +1,71 @@ +######################################################################################## +# +# KPP - The Kinetic PreProcessor +# Builds simulation code for chemical kinetic systems +# +# Copyright (C) 1995-1996 Valeriu Damian and Adrian Sandu +# Copyright (C) 1997-2004 Adrian Sandu +# +# KPP is free software; you can redistribute it and/or modify it under the +# terms of the GNU General Public License as published by the Free Software +# Foundation (http://www.gnu.org/copyleft/gpl.html); either version 2 of the +# License, or (at your option) any later version. +# +# KPP is distributed in the hope that it will be useful, but WITHOUT ANY +# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along +## with this program; if not, consult http://www.gnu.org/copyleft/gpl.html or +# write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +# Boston, MA 02111-1307, USA. +# +# Adrian Sandu +# Computer Science Department +# Virginia Polytechnic Institute and State University +# Blacksburg, VA 24060 +# E-mail: sandu@cs.vt.edu +# +####################################################################################### + +SUBDIRS = src +EXTRA_DIST = src/bison.h src/code.h src/gdata.h src/gdef.h src/scan.h + +dist_doc_DATA = README.md doc/kpp_UserManual.pdf doc/boxmox_UserManual.pdf +dist_bin_SCRIPTS = scripts/list_BOXMOX_mechanisms \ + scripts/new_BOXMOX_experiment \ + scripts/new_BOXMOX_experiment_from_example \ + scripts/prepare_BOXMOX_mechanism \ + scripts/validate_BOXMOX_installation + +install-data-local: + $(MKDIR_P) $(DESTDIR)$(pkgdatadir)/compiled_mechs + +uninstall-local: + rmdir $(DESTDIR)$(pkgdatadir)/compiled_mechs 2>/dev/null || : + +dist-hook: + chmod u+w $(distdir)/boxmox/wrapper + @sed 's/__BOXMOX_VERSION__/'$(VERSION)'/g' $(distdir)/boxmox/wrapper > tmp; mv tmp $(distdir)/boxmox/wrapper + chmod u+w $(distdir)/drv/boxmox.f90 + @sed 's/__BOXMOX_VERSION__/'$(VERSION)'/g' $(distdir)/drv/boxmox.f90 > tmp; mv tmp $(distdir)/drv/boxmox.f90 + chmod u+w $(distdir)/drv/boxmox_adjoint.f90 + @sed 's/__BOXMOX_VERSION__/'$(VERSION)'/g' $(distdir)/drv/boxmox_adjoint.f90 > tmp; mv tmp $(distdir)/drv/boxmox_adjoint.f90 + chmod u+w $(distdir)/scripts/new_BOXMOX_experiment + @sed 's/__BOXMOX_VERSION__/'$(VERSION)'/g' $(distdir)/scripts/new_BOXMOX_experiment > tmp; mv tmp $(distdir)/scripts/new_BOXMOX_experiment + chmod u+w $(distdir)/scripts/new_BOXMOX_experiment_from_example + @sed 's/__BOXMOX_VERSION__/'$(VERSION)'/g' $(distdir)/scripts/new_BOXMOX_experiment_from_example > tmp; mv tmp $(distdir)/scripts/new_BOXMOX_experiment_from_example + +install-data-hook: + @echo " " + @echo " --- YOU ARE GOOD TO GO ---" + @echo " " + @echo "To use BOXMOX, you need to add the following lines to" + @echo "your .bashrc, .profile (a hidden file in your home directory)" + @echo "or similar, so they are executed upon login:" + @echo " " + @echo "export KPP_HOME=${prefix}/share/boxmox" + @echo "export PATH=${prefix}/bin:\$$PATH" + @echo " " + diff --git a/README.md b/README.md index 788a115511c57a35907571d063dd20ffb7167bb4..412e13b2adc28f759b70a68a26cf8780c5fce655 100644 --- a/README.md +++ b/README.md @@ -4,35 +4,51 @@ Documentation, user downloads, online tools and further information can be found [here](https://mbees.med.uni-augsburg.de/boxmodeling/). -This is the development repository. BOXMOX is an extension to KPP, hence it lives as part of KPP. For distribution, a patch against standard KPP is created, KPP is downloaded from the original location, and the code is patched. For testing, each commit creates a [downloadable distribution](https://git.rz.uni-augsburg.de/knotechr/boxmox/-/jobs/artifacts/master/download?job=boxmox_latest) which can used directly for testing. +This is the development repository. -Feel free to push merge requests and add issues if you should encounter any. +## Latest distributable archive -Please cite our work when BOXMOX use constituted a relevant contribution to your scientific work. The citation for BOXMOX is [Knote et al., Atm. Env., 2015](http://dx.doi.org/10.1016/j.atmosenv.2014.11.066). - -## Code structure +The most current BOXMOX distribution .tar.gz can be found [here](https://mbees.med.uni-augsburg.de/gitlab/mbees/boxmox/-/jobs/artifacts/master/download?job=build). -`boxmox/` +## Contributing -Main KPP directory, patched and extended for BOXMOX. +We are looking forward to receiving your [new issue report](https://mbees.med.uni-augsburg.de/gitlab/mbees/boxmox/-/issues/new). -`boxmox/boxmox/` +If you'd like to contribute source code directly, please [create a fork](https://mbees.med.uni-augsburg.de/gitlab/mbees/boxmox), make your changes and then [submit a merge request](https://mbees.med.uni-augsburg.de/gitlab/mbees/boxmox/-/merge_requests/new) to the original project. -Additional data and code for BOXMOX. +## Citation -`boxmox/boxmox/wrapper` +Please cite our work when BOXMOX use constituted a relevant contribution to your scientific work. The citation for BOXMOX is [Knote et al., Atm. Env., 2015](http://dx.doi.org/10.1016/j.atmosenv.2014.11.066). -Main BOXMOX user code file. +## Where does BOXMOX extend KPP? -`boxmox/boxmox/boxmox(_adjoint).f90` +`drv/boxmox.f90`/ `drv/boxmox_adjoint.f90` KPP (adjoint) driver for BOXMOX. -`boxmox/boxmox/examples` +`drv/wrapper` + +This is where all BOXMOX extension code lives. + +`case_studies/` Test cases for BOXMOX usage. -[Christoph Knote](mailto:christoph.knote@med.uni-augsburg.de), [MBEES, Faculty of Medicine, University of Augsburg](https://mbees.med.uni-augsburg.de), Germany +`doc/boxmox_README.tex` + +BOXMOX documentation. + +`models/` + +Additional chemistry mechanisms included with BOXMOX. + +`scripts/` + +Command-line scripts to drive BOXMOX. + +`util/UserRateLaws_BOXMOX.f90` + +Rate constant equations for BOXMOX. ## License statement @@ -49,3 +65,7 @@ GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . +## Contact + +[Christoph Knote](mailto:christoph.knote@med.uni-augsburg.de), [MBEES, Faculty of Medicine, University of Augsburg](https://mbees.med.uni-augsburg.de), Germany + diff --git a/boxmox/Makefile.defs b/boxmox/Makefile.defs deleted file mode 100644 index c381888c1c83cb2d83fc3abaca00c4837384337e..0000000000000000000000000000000000000000 --- a/boxmox/Makefile.defs +++ /dev/null @@ -1,70 +0,0 @@ -# -*- sh -*- -############################################################################## -# -# KPP - The Kinetic PreProcessor -# Builds simulation code for chemical kinetic systems -# -# Copyright (C) 1995-1997 Valeriu Damian and Adrian Sandu -# Copyright (C) 1997-2005 Adrian Sandu -# -# KPP is free software; you can redistribute it and/or modify it under the -# terms of the GNU General Public License as published by the Free Software -# Foundation (http://www.gnu.org/copyleft/gpl.html); either version 2 of the -# License, or (at your option) any later version. -# -# KPP is distributed in the hope that it will be useful, but WITHOUT ANY -# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS -# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more -# details. -# -# You should have received a copy of the GNU General Public License along -## with this program; if not, consult http://www.gnu.org/copyleft/gpl.html or -# write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -# Boston, MA 02111-1307, USA. -# -# Adrian Sandu -# Computer Science Department -# Virginia Polytechnic Institute and State University -# Blacksburg, VA 24060 -# E-mail: sandu@cs.vt.edu -# -############################################################################## - -# In order to compile KPP you have to provide the following information: - -# 1. The name of the compiler you want to use. Normaly this -# is either GNU C compiler (gcc) or the native compiler (cc) -# You can use the complete pathname if the compiler is not in $PATH -# Note that for SUN machines is better to use gcc. -# For GNU C compiler use: -# CC=gcc -# For the native compiler use: -# CC=cc - -CC=gcc - -# 2. The name of your lexical analizer. KPP requires FLEX to be used. -# FLEX is a public domain lexical analizer and you can download it from -# http://www.gnu.org/software/flex/ or any other mirror site. If flex -# directory is not included in your path use the complete pathname. - -FLEX=flex - -# 3. The complete pathname of the FLEX library (libfl.a). -# On many systems this is either: -# /usr/lib, /usr/lib64, /usr/local/util/lib/flex - -FLEX_LIB_DIR=/usr/lib - -# 4. Platform independent C compiler flags. By default "-O" is used which -# turns on optimization. If you are experiencing problems you may try -# "-g" to include debuging informations. - -CC_FLAGS= -g -Wall - -# 5. Path to include additional directories -# Typically: /usr/include on Linux -# /usr/include/sys on Mac OS X -INCLUDE_DIR = /usr/include - -############################################################################## diff --git a/boxmox/boxmox/README.tex b/boxmox/UserManual.tex similarity index 94% rename from boxmox/boxmox/README.tex rename to boxmox/UserManual.tex index 93e9eae2bd15674095053a7a149498a2929e843d..8290b6883283fb7cbea17642af9cac58170ea6ed 100644 --- a/boxmox/boxmox/README.tex +++ b/boxmox/UserManual.tex @@ -15,11 +15,11 @@ \ \\[8cm] {\LARGE BOXMOX extensions to KPP} \\[1cm] -Christoph Knote (christoph.knote@lmu.de)\\ -Meteorological Institute, LMU Munich, Germany +Christoph Knote (christoph.knote@med.uni-augsburg.de)\\ +Model-Based Environmental Exposure Science, Faculty of Medicine, University of Augsburg, Germany \\[1cm] -Version 1.8a\\ -09/2019 +Version 1.8\\ +03/2022 % version name comment % 0.9 CK initial release @@ -34,6 +34,7 @@ Version 1.8a\\ % 1.7 CK revamped mixing process options, included simple aerosol as % surface density area and radius % 1.8a CK implemented NOx fixing +% 1.8 CK move to GNU autotools for distribution \end{center} \thispagestyle{empty} @@ -46,11 +47,20 @@ Version 1.8a\\ \section*{Version history} -\subsection*{1.8a} +\subsection*{1.8} \textit{not released yet} New features +\begin{itemize} + \item Move to GNU autotools for distribution +\end{itemize} + +\subsection*{1.8a} +\textit{not released} + +New features + \begin{itemize} \item Implemented NO$_x$ fixing method for steady state calculations \end{itemize} @@ -200,49 +210,22 @@ doi:10.5194/acp-6-187-2006, 2006. \emph{BOXMOX is a Linux program, we assume you are working on a reasonably recent Linux distribution.} -You should have received or downloaded the \emph{install\_BOXMOX.bash} shell -script. The script is written in {\tt bash}, a shell that is installed on most -*nix machines, but might not be your default. Do not worry. Open the script in -your favorite text editor and adapt the user section to your machine. You need -to set +Requirements for installing and running BOXMOX: \begin{itemize} - \item absolute path to the location you want BOXMOX to be \item C compiler (usually {\tt gcc} or {\tt cc}) - \item C compile flags (if any) - \item absolute path to the FLEX binary (test with {\tt which flex}) - \item absolute path to the FLEX library (libfl.a, try {\tt type -a libfl.a}) + \item Fortran compiler ({\tt gfortran} is assumed) + \item flex (test with {\tt which flex}) + \item flex library (libfl.a, try {\tt type -a libfl.a}) + \item yacc or bison \end{itemize} -Save the file. Now execute it: +BOXMOX installation is then straightforward: \begin{verbatim} -me@mymachine> bash install_BOXMOX.bash - -BOXMOX extension to KPP (1.7) - -Output directory: /glade/u/home/knote/testy -C compiler: gcc -C compiler flags: -O -FLEX binary: /usr/bin/flex -FLEX library: /usr/lib64/libfl.a - -Downloading BOXMOX -Downloading KPP -Unpacking KPP -Patching KPP -Compiling KPP -Tex'ing BOXMOX readme (boxmox/README.pdf) - - --- YOU ARE GOOD TO GO --- - -Remember to set the following env. variables and -add them to your .bashrc. to remember them permanently: - -export KPP_HOME=/glade/u/home/knote/boxmox -export PATH=$KPP_HOME/bin:$PATH - -me@mymachine> +./configure --prefix= +make +make install \end{verbatim} Once you see the message ``YOU ARE GOOD TO GO'', everything should have worked @@ -288,7 +271,7 @@ me@mymachine> This creates a box model executable for the chosen mechanism (in this case, MOZART-4) which you can now use for your experiments. The executables can be -found in \emph{\$KPP\_HOME/boxmox/compiled\_mechs/\mech}. +found in \emph{\$KPP\_HOME/compiled\_mechs/\mech}. \subsubsection{{\tt new\_BOXMOX\_experiment}} @@ -343,7 +326,7 @@ values. A typical \emph{BOXMOX.nml} file looks like this: \begin{alltt} -\input{examples/BOXMOX.nml} +\input{../case_studies/BOXMOX.nml} \end{alltt} @@ -758,7 +741,7 @@ Make sure the following variables are set: #LANGUAGE Fortran90 #DOUBLE ON #INTEGRATOR rosenbrock -#DRIVER ../boxmox/boxmox +#DRIVER boxmox #JACOBIAN SPARSE_LU_ROW #HESSIAN OFF \end{verbatim} diff --git a/boxmox/boxmox/README.pdf b/boxmox/boxmox/README.pdf deleted file mode 100644 index 92a064faf9e06cca8fc4b2ac3eacdac71cd752d2..0000000000000000000000000000000000000000 Binary files a/boxmox/boxmox/README.pdf and /dev/null differ diff --git a/boxmox/cflags b/boxmox/cflags deleted file mode 100755 index 8d1c8b69c3fce7bea45c73efd06983e3c419a92f..0000000000000000000000000000000000000000 --- a/boxmox/cflags +++ /dev/null @@ -1 +0,0 @@ - diff --git a/boxmox/cflags.guess b/boxmox/cflags.guess deleted file mode 100755 index 9b0af15f368bb9203d656e8000d7f034db27b20a..0000000000000000000000000000000000000000 --- a/boxmox/cflags.guess +++ /dev/null @@ -1,39 +0,0 @@ -#!/bin/sh -UNAME_MACHINE=`(uname -m) 2>/dev/null` || UNAME_MACHINE=unknown -UNAME_RELEASE=`(uname -r) 2>/dev/null` || UNAME_RELEASE=unknown -UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown -UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown - -CC=cc -if [ x$1 != x ]; then CC=$1; fi - -exec 5>./cflags - -# Note: order is significant - the case branches are not exclusive. - -case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}:${CC}" in - - *:HP-UX:*:*:cc*) # For HP-UX workstations - echo " -Aa -D_HPUX_SOURCE " 1>&5; exit 0 ;; - - *:AIX:*:*:cc*) # For machines running AIX - echo " -Aa " 1>&5; exit 0 ;; - - *:IRIX:*:*:cc*) # For machines running IRIX - echo " " 1>&5; exit 0 ;; - - *:IRIX64:*:*:cc*) # For machines running IRIX64 - echo " " 1>&5; exit 0 ;; - - *:Linux:*:*:cc*) # For Linux machines - echo " " 1>&5; exit 0 ;; - - *:SunOS:*:*:cc*) # For SUN machines - echo " Please use gcc compiler on SUN machines."; exit 1 ;; - - *:*:*:*:gcc*) # this is the default case, for gcc - echo " " 1>&5; exit 0 ;; - - *:*:*:*:*) # this is the default case - echo " " 1>&5; exit 0 ;; -esac diff --git a/boxmox/int.modified_WCOPY/kpp_lsode.f90 b/boxmox/int.modified_WCOPY/kpp_lsode.f90 deleted file mode 100644 index 44c845e21512f1c004787aedb915aedc8fff799d..0000000000000000000000000000000000000000 --- a/boxmox/int.modified_WCOPY/kpp_lsode.f90 +++ /dev/null @@ -1,3421 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! -! LSODE - Stiff method based on backward differentiation formulas (BDF) ! -! By default the code employs the KPP sparse linear algebra routines ! -! Compile with -DFULL_ALGEBRA to use full linear algebra (LAPACK) ! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! -! A. Sandu - version of July 2005 - -MODULE KPP_ROOT_Integrator - - USE KPP_ROOT_Precision - USE KPP_ROOT_Global, ONLY: FIX, RCONST, TIME, ATOL, RTOL - USE KPP_ROOT_Parameters, ONLY: NVAR, NSPEC, NFIX, LU_NONZERO - USE KPP_ROOT_JacobianSP, ONLY: LU_DIAG - USE KPP_ROOT_LinearAlgebra, ONLY: KppDecomp, KppSolve, & - Set2zero, WLAMCH - - IMPLICIT NONE - PUBLIC - SAVE - - !~~~> Statistics on the work performed by the LSODE method - INTEGER :: Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng - INTEGER, PARAMETER :: ifun=1, ijac=2, istp=3, iacc=4, & - irej=5, idec=6, isol=7, isng=8, itexit=1, ihexit=2 - ! SDIRK method coefficients - KPP_REAL :: rkAlpha(5,4), rkBeta(5,4), rkD(4,5), & - rkGamma, rkA(5,5), rkB(5), rkC(5) - - ! mz_rs_20050717: TODO: use strings of IERR_NAMES for error messages - ! description of the error numbers IERR - CHARACTER(LEN=50), PARAMETER, DIMENSION(-8:1) :: IERR_NAMES = (/ & - 'Matrix is repeatedly singular ', & ! -8 - 'Step size too small ', & ! -7 - 'No of steps exceeds maximum bound ', & ! -6 - 'Improper tolerance values ', & ! -5 - 'FacMin/FacMax/FacRej must be positive ', & ! -4 - 'Hmin/Hmax/Hstart must be positive ', & ! -3 - 'Improper value for maximal no of Newton iterations', & ! -2 - 'Improper value for maximal no of steps ', & ! -1 - ' ', & ! 0 (not used) - 'Success ' /) ! 1 - -CONTAINS - -SUBROUTINE INTEGRATE( TIN, TOUT, & - ICNTRL_U, RCNTRL_U, ISTATUS_U, RSTATUS_U, IERR_U ) - - USE KPP_ROOT_Parameters - USE KPP_ROOT_Global - IMPLICIT NONE - - KPP_REAL, INTENT(IN) :: TIN ! Start Time - KPP_REAL, INTENT(IN) :: TOUT ! End Time - ! Optional input parameters and statistics - INTEGER, INTENT(IN), OPTIONAL :: ICNTRL_U(20) - KPP_REAL, INTENT(IN), OPTIONAL :: RCNTRL_U(20) - INTEGER, INTENT(OUT), OPTIONAL :: ISTATUS_U(20) - KPP_REAL, INTENT(OUT), OPTIONAL :: RSTATUS_U(20) - INTEGER, INTENT(OUT), OPTIONAL :: IERR_U - - KPP_REAL :: RCNTRL(20), RSTATUS(20) - INTEGER :: ICNTRL(20), ISTATUS(20), IERR -!!$ INTEGER, SAVE :: Ntotal = 0 - - ICNTRL(:) = 0 - RCNTRL(:) = 0.0_dp - ISTATUS(:) = 0 - RSTATUS(:) = 0.0_dp - - ICNTRL(5) = 2 ! maximal order - - ! If optional parameters are given, and if they are >0, - ! then they overwrite default settings. - IF (PRESENT(ICNTRL_U)) THEN - WHERE(ICNTRL_U(:) > 0) ICNTRL(:) = ICNTRL_U(:) - END IF - IF (PRESENT(RCNTRL_U)) THEN - WHERE(RCNTRL_U(:) > 0) RCNTRL(:) = RCNTRL_U(:) - END IF - - CALL KppLsode( TIN,TOUT,VAR,RTOL,ATOL, & - RCNTRL,ICNTRL,RSTATUS,ISTATUS,IERR ) - -! mz_rs_20050716: IERR and ISTATUS are returned to the user who then -! decides what to do about it, i.e. either stop the run or ignore it. -!!$ IF (IERR < 0) THEN -!!$ PRINT*,'LSODE: Unsuccessful exit at T=',TIN,' (IERR=',IERR,')' -!!$ STOP -!!$ ENDIF -!!$ Ntotal = Ntotal + ISTATUS(3) -!!$ PRINT*,'Nsteps = ', ISTATUS(3),' (',Ntotal,')' - - STEPMIN = RSTATUS(ihexit) ! Save last step - - ! if optional parameters are given for output they to return information - IF (PRESENT(ISTATUS_U)) ISTATUS_U(:) = ISTATUS(1:20) - IF (PRESENT(RSTATUS_U)) RSTATUS_U(:) = RSTATUS(1:20) - IF (PRESENT(IERR_U)) THEN - IF (IERR==2) THEN ! DLSODE returns "2" after successful completion - IERR_U = 1 ! IERR_U will return "1" for successful completion - ELSE - IERR_U = IERR - ENDIF - ENDIF - - END SUBROUTINE INTEGRATE - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE KppLsode( TIN,TOUT,Y,RelTol,AbsTol, & - RCNTRL,ICNTRL,RSTATUS,ISTATUS,IERR ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!~~~> INPUT PARAMETERS: -! -! Note: For input parameters equal to zero the default values of the -! corresponding variables are used. -! -! Note: For input parameters equal to zero the default values of the -! corresponding variables are used. -!~~~> -! ICNTRL(1) = not used -! -! ICNTRL(2) = 0: AbsTol, RelTol are NVAR-dimensional vectors -! = 1: AbsTol, RelTol are scalars -! -! ICNTRL(3) = not used -! -! ICNTRL(4) -> maximum number of integration steps -! For ICNTRL(4)=0 the default value of 100000 is used -! -! ICNTRL(5) -> maximum order of the integration formula allowed -! -!~~~> Real parameters -! -! RCNTRL(1) -> Hmin, lower bound for the integration step size -! It is strongly recommended to keep Hmin = ZERO -! RCNTRL(2) -> Hmax, upper bound for the integration step size -! RCNTRL(3) -> Hstart, starting value for the integration step size -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!~~~> OUTPUT PARAMETERS: -! -! Note: each call to Rosenbrock adds the current no. of fcn calls -! to previous value of ISTATUS(1), and similar for the other params. -! Set ISTATUS(1:10) = 0 before call to avoid this accumulation. -! -! ISTATUS(1) = No. of function calls -! ISTATUS(2) = No. of jacobian calls -! ISTATUS(3) = No. of steps -! -! RSTATUS(1) -> Texit, the time corresponding to the -! computed Y upon return -! RSTATUS(2) -> Hexit, last predicted step before exit -! For multiple restarts, use Hexit as Hstart in the following run -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - KPP_REAL :: Y(NVAR), AbsTol(NVAR), RelTol(NVAR), TIN, TOUT - KPP_REAL :: RCNTRL(20), RSTATUS(20) - INTEGER :: ICNTRL(20), ISTATUS(20) - INTEGER, PARAMETER :: LRW = 25 + 9*NVAR+2*NVAR*NVAR, & - LIW = 32 + NVAR - KPP_REAL :: RWORK(LRW), RPAR(1) - INTEGER :: IWORK(LIW), IPAR(1), ITOL, ITASK, & - IERR, IOPT, MF - - !~~~> NORMAL COMPUTATION - ITASK = 1 - IERR = 1 - IOPT = 1 ! 0=no/1=use optional input - - RWORK(1:30) = 0.0d0 - IWORK(1:30) = 0 - - IF (ICNTRL(2)==0) THEN - ITOL = 4 ! Abs/RelTol are both vectors - ELSE - ITOL = 1 ! Abs/RelTol are both scalars - END IF - IWORK(6) = ICNTRL(4) ! max number of internal steps - IWORK(5) = ICNTRL(5) ! maximal order - - MF = 21 !~~~> stiff case, analytic full Jacobian - - RWORK(5) = RCNTRL(3) ! Hstart - RWORK(6) = RCNTRL(2) ! Hmax - RWORK(7) = RCNTRL(1) ! Hmin - - CALL DLSODE ( FUN_CHEM, NVAR, Y, TIN, TOUT, ITOL, RelTol, AbsTol, ITASK,& - IERR, IOPT, RWORK, LRW, IWORK, LIW, JAC_CHEM, MF) - - ISTATUS(1) = IWORK(12) ! Number of function evaluations - ISTATUS(2) = IWORK(13) ! Number of Jacobian evaluations - ISTATUS(3) = IWORK(11) ! Number of steps - - RSTATUS(1) = TOUT ! mz_rs_20050717 - RSTATUS(2) = RWORK(11) ! mz_rs_20050717 - - END SUBROUTINE KppLsode -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!DECK DLSODE - SUBROUTINE DLSODE (F, NEQ, Y, T, TOUT, ITOL, RelTol, AbsTol, ITASK, & - ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, MF) - EXTERNAL F, JAC - INTEGER NEQ, ITOL, ITASK, ISTATE, IOPT, LRW, LIW, IWORK(LIW), MF - KPP_REAL Y(*), T, TOUT, RelTol(*), AbsTol(*), RWORK(LRW) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!***BEGIN PROLOGUE DLSODE -!***PURPOSE Livermore Solver for Ordinary Differential Equations. -! DLSODE solves the initial-value problem for stiff or -! nonstiff systems of first-order ODE's, -! dy/dt = f(t,y), or, in component form, -! dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(N)), i=1,...,N. -!***CATEGORY I1A -!***TYPE KPP_REAL (SLSODE-S, DLSODE-D) -!***KEYWORDS ORDINARY DIFFERENTIAL EQUATIONS, INITIAL VALUE PROBLEM, -! STIFF, NONSTIFF -!***AUTHOR Hindmarsh, Alan C., (LLNL) -! Center for Applied Scientific Computing, L-561 -! Lawrence Livermore National Laboratory -! Livermore, CA 94551. -!***DESCRIPTION -! -! NOTE: The "Usage" and "Arguments" sections treat only a subset of -! available options, in condensed fashion. The options -! covered and the information supplied will support most -! standard uses of DLSODE. -! -! For more sophisticated uses, full details on all options are -! given in the concluding section, headed "Long Description." -! A synopsis of the DLSODE Long Description is provided at the -! beginning of that section; general topics covered are: -! - Elements of the call sequence; optional input and output -! - Optional supplemental routines in the DLSODE package -! - internal COMMON block -! -! *Usage: -! Communication between the user and the DLSODE package, for normal -! situations, is summarized here. This summary describes a subset -! of the available options. See "Long Description" for complete -! details, including optional communication, nonstandard options, -! and instructions for special situations. -! -! A sample program is given in the "Examples" section. -! -! Refer to the argument descriptions for the definitions of the -! quantities that appear in the following sample declarations. -! -! For MF = 10, -! PARAMETER (LRW = 20 + 16*NEQ, LIW = 20) -! For MF = 21 or 22, -! PARAMETER (LRW = 22 + 9*NEQ + NEQ**2, LIW = 20 + NEQ) -! For MF = 24 or 25, -! PARAMETER (LRW = 22 + 10*NEQ + (2*ML+MU)*NEQ, -! * LIW = 20 + NEQ) -! -! EXTERNAL F, JAC -! INTEGER NEQ, ITOL, ITASK, ISTATE, IOPT, LRW, IWORK(LIW), -! * LIW, MF -! KPP_REAL Y(NEQ), T, TOUT, RelTol, AbsTol(ntol), RWORK(LRW) -! -! CALL DLSODE (F, NEQ, Y, T, TOUT, ITOL, RelTol, AbsTol, ITASK, -! * ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, MF) -! -! *Arguments: -! F :EXT Name of subroutine for right-hand-side vector f. -! This name must be declared EXTERNAL in calling -! program. The form of F must be: -! -! SUBROUTINE F (NEQ, T, Y, YDOT) -! INTEGER NEQ -! KPP_REAL T, Y(*), YDOT(*) -! -! The inputs are NEQ, T, Y. F is to set -! -! YDOT(i) = f(i,T,Y(1),Y(2),...,Y(NEQ)), -! i = 1, ..., NEQ . -! -! NEQ :IN Number of first-order ODE's. -! -! Y :INOUT Array of values of the y(t) vector, of length NEQ. -! Input: For the first call, Y should contain the -! values of y(t) at t = T. (Y is an input -! variable only if ISTATE = 1.) -! Output: On return, Y will contain the values at the -! new t-value. -! -! T :INOUT Value of the independent variable. On return it -! will be the current value of t (normally TOUT). -! -! TOUT :IN Next point where output is desired (.NE. T). -! -! ITOL :IN 1 or 2 according as AbsTol (below) is a scalar or -! an array. -! -! RelTol :IN Relative tolerance parameter (scalar). -! -! AbsTol :IN Absolute tolerance parameter (scalar or array). -! If ITOL = 1, AbsTol need not be dimensioned. -! If ITOL = 2, AbsTol must be dimensioned at least NEQ. -! -! The estimated local error in Y(i) will be controlled -! so as to be roughly less (in magnitude) than -! -! EWT(i) = RelTol*ABS(Y(i)) + AbsTol if ITOL = 1, or -! EWT(i) = RelTol*ABS(Y(i)) + AbsTol(i) if ITOL = 2. -! -! Thus the local error test passes if, in each -! component, either the absolute error is less than -! AbsTol (or AbsTol(i)), or the relative error is less -! than RelTol. -! -! Use RelTol = 0.0 for pure absolute error control, and -! use AbsTol = 0.0 (or AbsTol(i) = 0.0) for pure relative -! error control. Caution: Actual (global) errors may -! exceed these local tolerances, so choose them -! conservatively. -! -! ITASK :IN Flag indicating the task DLSODE is to perform. -! Use ITASK = 1 for normal computation of output -! values of y at t = TOUT. -! -! ISTATE:INOUT Index used for input and output to specify the state -! of the calculation. -! Input: -! 1 This is the first call for a problem. -! 2 This is a subsequent call. -! Output: -! 1 Nothing was done, because TOUT was equal to T. -! 2 DLSODE was successful (otherwise, negative). -! Note that ISTATE need not be modified after a -! successful return. -! -1 Excess work done on this call (perhaps wrong -! MF). -! -2 Excess accuracy requested (tolerances too -! small). -! -3 Illegal input detected (see printed message). -! -4 Repeated error test failures (check all -! inputs). -! -5 Repeated convergence failures (perhaps bad -! Jacobian supplied or wrong choice of MF or -! tolerances). -! -6 Error weight became zero during problem -! (solution component i vanished, and AbsTol or -! AbsTol(i) = 0.). -! -! IOPT :IN Flag indicating whether optional inputs are used: -! 0 No. -! 1 Yes. (See "Optional inputs" under "Long -! Description," Part 1.) -! -! RWORK :WORK Real work array of length at least: -! 20 + 16*NEQ for MF = 10, -! 22 + 9*NEQ + NEQ**2 for MF = 21 or 22, -! 22 + 10*NEQ + (2*ML + MU)*NEQ for MF = 24 or 25. -! -! LRW :IN Declared length of RWORK (in user's DIMENSION -! statement). -! -! IWORK :WORK Integer work array of length at least: -! 20 for MF = 10, -! 20 + NEQ for MF = 21, 22, 24, or 25. -! -! If MF = 24 or 25, input in IWORK(1),IWORK(2) the -! lower and upper Jacobian half-bandwidths ML,MU. -! -! On return, IWORK contains information that may be -! of interest to the user: -! -! Name Location Meaning -! ----- --------- ----------------------------------------- -! NST IWORK(11) Number of steps taken for the problem so -! far. -! NFE IWORK(12) Number of f evaluations for the problem -! so far. -! NJE IWORK(13) Number of Jacobian evaluations (and of -! matrix LU decompositions) for the problem -! so far. -! NQU IWORK(14) Method order last used (successfully). -! LENRW IWORK(17) Length of RWORK actually required. This -! is defined on normal returns and on an -! illegal input return for insufficient -! storage. -! LENIW IWORK(18) Length of IWORK actually required. This -! is defined on normal returns and on an -! illegal input return for insufficient -! storage. -! -! LIW :IN Declared length of IWORK (in user's DIMENSION -! statement). -! -! JAC :EXT Name of subroutine for Jacobian matrix (MF = -! 21 or 24). If used, this name must be declared -! EXTERNAL in calling program. If not used, pass a -! dummy name. The form of JAC must be: -! -! SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD) -! INTEGER NEQ, ML, MU, NROWPD -! KPP_REAL T, Y(*), PD(NROWPD,*) -! -! See item c, under "Description" below for more -! information about JAC. -! -! MF :IN Method flag. Standard values are: -! 10 Nonstiff (Adams) method, no Jacobian used. -! 21 Stiff (BDF) method, user-supplied full Jacobian. -! 22 Stiff method, internally generated full -! Jacobian. -! 24 Stiff method, user-supplied banded Jacobian. -! 25 Stiff method, internally generated banded -! Jacobian. -! -! *Description: -! DLSODE solves the initial value problem for stiff or nonstiff -! systems of first-order ODE's, -! -! dy/dt = f(t,y) , -! -! or, in component form, -! -! dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(NEQ)) -! (i = 1, ..., NEQ) . -! -! DLSODE is a package based on the GEAR and GEARB packages, and on -! the October 23, 1978, version of the tentative ODEPACK user -! interface standard, with minor modifications. -! -! The steps in solving such a problem are as follows. -! -! a. First write a subroutine of the form -! -! SUBROUTINE F (NEQ, T, Y, YDOT) -! INTEGER NEQ -! KPP_REAL T, Y(*), YDOT(*) -! -! which supplies the vector function f by loading YDOT(i) with -! f(i). -! -! b. Next determine (or guess) whether or not the problem is stiff. -! Stiffness occurs when the Jacobian matrix df/dy has an -! eigenvalue whose real part is negative and large in magnitude -! compared to the reciprocal of the t span of interest. If the -! problem is nonstiff, use method flag MF = 10. If it is stiff, -! there are four standard choices for MF, and DLSODE requires the -! Jacobian matrix in some form. This matrix is regarded either -! as full (MF = 21 or 22), or banded (MF = 24 or 25). In the -! banded case, DLSODE requires two half-bandwidth parameters ML -! and MU. These are, respectively, the widths of the lower and -! upper parts of the band, excluding the main diagonal. Thus the -! band consists of the locations (i,j) with -! -! i - ML <= j <= i + MU , -! -! and the full bandwidth is ML + MU + 1 . -! -! c. If the problem is stiff, you are encouraged to supply the -! Jacobian directly (MF = 21 or 24), but if this is not feasible, -! DLSODE will compute it internally by difference quotients (MF = -! 22 or 25). If you are supplying the Jacobian, write a -! subroutine of the form -! -! SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD) -! INTEGER NEQ, ML, MU, NRWOPD -! KPP_REAL T, Y(*), PD(NROWPD,*) -! -! which provides df/dy by loading PD as follows: -! - For a full Jacobian (MF = 21), load PD(i,j) with df(i)/dy(j), -! the partial derivative of f(i) with respect to y(j). (Ignore -! the ML and MU arguments in this case.) -! - For a banded Jacobian (MF = 24), load PD(i-j+MU+1,j) with -! df(i)/dy(j); i.e., load the diagonal lines of df/dy into the -! rows of PD from the top down. -! - In either case, only nonzero elements need be loaded. -! -! d. Write a main program that calls subroutine DLSODE once for each -! point at which answers are desired. This should also provide -! for possible use of logical unit 6 for output of error messages -! by DLSODE. -! -! Before the first call to DLSODE, set ISTATE = 1, set Y and T to -! the initial values, and set TOUT to the first output point. To -! continue the integration after a successful return, simply -! reset TOUT and call DLSODE again. No other parameters need be -! reset. -! -! *Examples: -! The following is a simple example problem, with the coding needed -! for its solution by DLSODE. The problem is from chemical kinetics, -! and consists of the following three rate equations: -! -! dy1/dt = -.04*y1 + 1.E4*y2*y3 -! dy2/dt = .04*y1 - 1.E4*y2*y3 - 3.E7*y2**2 -! dy3/dt = 3.E7*y2**2 -! -! on the interval from t = 0.0 to t = 4.E10, with initial conditions -! y1 = 1.0, y2 = y3 = 0. The problem is stiff. -! -! The following coding solves this problem with DLSODE, using -! MF = 21 and printing results at t = .4, 4., ..., 4.E10. It uses -! ITOL = 2 and AbsTol much smaller for y2 than for y1 or y3 because y2 -! has much smaller values. At the end of the run, statistical -! quantities of interest are printed. -! -! EXTERNAL FEX, JEX -! INTEGER IOPT, IOUT, ISTATE, ITASK, ITOL, IWORK(23), LIW, LRW, -! * MF, NEQ -! KPP_REAL AbsTol(3), RelTol, RWORK(58), T, TOUT, Y(3) -! NEQ = 3 -! Y(1) = 1.D0 -! Y(2) = 0.D0 -! Y(3) = 0.D0 -! T = 0.D0 -! TOUT = .4D0 -! ITOL = 2 -! RelTol = 1.D-4 -! AbsTol(1) = 1.D-6 -! AbsTol(2) = 1.D-10 -! AbsTol(3) = 1.D-6 -! ITASK = 1 -! ISTATE = 1 -! IOPT = 0 -! LRW = 58 -! LIW = 23 -! MF = 21 -! DO 40 IOUT = 1,12 -! CALL DLSODE (FEX, NEQ, Y, T, TOUT, ITOL, RelTol, AbsTol, ITASK, -! * ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JEX, MF) -! WRITE(6,20) T, Y(1), Y(2), Y(3) -! 20 FORMAT(' At t =',D12.4,' y =',3D14.6) -! IF (ISTATE .LT. 0) GO TO 80 -! 40 TOUT = TOUT*10.D0 -! WRITE(6,60) IWORK(11), IWORK(12), IWORK(13) -! 60 FORMAT(/' No. steps =',i4,', No. f-s =',i4,', No. J-s =',i4) -! STOP -! 80 WRITE(6,90) ISTATE -! 90 FORMAT(///' Error halt.. ISTATE =',I3) -! STOP -! END -! -! SUBROUTINE FEX (NEQ, T, Y, YDOT) -! INTEGER NEQ -! KPP_REAL T, Y(3), YDOT(3) -! YDOT(1) = -.04D0*Y(1) + 1.D4*Y(2)*Y(3) -! YDOT(3) = 3.D7*Y(2)*Y(2) -! YDOT(2) = -YDOT(1) - YDOT(3) -! RETURN -! END -! -! SUBROUTINE JEX (NEQ, T, Y, ML, MU, PD, NRPD) -! INTEGER NEQ, ML, MU, NRPD -! KPP_REAL T, Y(3), PD(NRPD,3) -! PD(1,1) = -.04D0 -! PD(1,2) = 1.D4*Y(3) -! PD(1,3) = 1.D4*Y(2) -! PD(2,1) = .04D0 -! PD(2,3) = -PD(1,3) -! PD(3,2) = 6.D7*Y(2) -! PD(2,2) = -PD(1,2) - PD(3,2) -! RETURN -! END -! -! The output from this program (on a Cray-1 in single precision) -! is as follows. -! -! At t = 4.0000e-01 y = 9.851726e-01 3.386406e-05 1.479357e-02 -! At t = 4.0000e+00 y = 9.055142e-01 2.240418e-05 9.446344e-02 -! At t = 4.0000e+01 y = 7.158050e-01 9.184616e-06 2.841858e-01 -! At t = 4.0000e+02 y = 4.504846e-01 3.222434e-06 5.495122e-01 -! At t = 4.0000e+03 y = 1.831701e-01 8.940379e-07 8.168290e-01 -! At t = 4.0000e+04 y = 3.897016e-02 1.621193e-07 9.610297e-01 -! At t = 4.0000e+05 y = 4.935213e-03 1.983756e-08 9.950648e-01 -! At t = 4.0000e+06 y = 5.159269e-04 2.064759e-09 9.994841e-01 -! At t = 4.0000e+07 y = 5.306413e-05 2.122677e-10 9.999469e-01 -! At t = 4.0000e+08 y = 5.494530e-06 2.197825e-11 9.999945e-01 -! At t = 4.0000e+09 y = 5.129458e-07 2.051784e-12 9.999995e-01 -! At t = 4.0000e+10 y = -7.170603e-08 -2.868241e-13 1.000000e+00 -! -! No. steps = 330, No. f-s = 405, No. J-s = 69 -! -! *Accuracy: -! The accuracy of the solution depends on the choice of tolerances -! RelTol and AbsTol. Actual (global) errors may exceed these local -! tolerances, so choose them conservatively. -! -! *Cautions: -! The work arrays should not be altered between calls to DLSODE for -! the same problem, except possibly for the conditional and optional -! inputs. -! -! *Portability: -! Since NEQ is dimensioned inside DLSODE, some compilers may object -! to a call to DLSODE with NEQ a scalar variable. In this event, -! use DIMENSION NEQ. Similar remarks apply to RelTol and AbsTol. -! -! Note to Cray users: -! For maximum efficiency, use the CFT77 compiler. Appropriate -! compiler optimization directives have been inserted for CFT77. -! -! *Reference: -! Alan C. Hindmarsh, "ODEPACK, A Systematized Collection of ODE -! Solvers," in Scientific Computing, R. S. Stepleman, et al., Eds. -! (North-Holland, Amsterdam, 1983), pp. 55-64. -! -! *Long Description: -! The following complete description of the user interface to -! DLSODE consists of four parts: -! -! 1. The call sequence to subroutine DLSODE, which is a driver -! routine for the solver. This includes descriptions of both -! the call sequence arguments and user-supplied routines. -! Following these descriptions is a description of optional -! inputs available through the call sequence, and then a -! description of optional outputs in the work arrays. -! -! 2. Descriptions of other routines in the DLSODE package that may -! be (optionally) called by the user. These provide the ability -! to alter error message handling, save and restore the internal -! COMMON, and obtain specified derivatives of the solution y(t). -! -! 3. Descriptions of COMMON block to be declared in overlay or -! similar environments, or to be saved when doing an interrupt -! of the problem and continued solution later. -! -! 4. Description of two routines in the DLSODE package, either of -! which the user may replace with his own version, if desired. -! These relate to the measurement of errors. -! -! -! Part 1. Call Sequence -! ---------------------- -! -! Arguments -! --------- -! The call sequence parameters used for input only are -! -! F, NEQ, TOUT, ITOL, RelTol, AbsTol, ITASK, IOPT, LRW, LIW, JAC, MF, -! -! and those used for both input and output are -! -! Y, T, ISTATE. -! -! The work arrays RWORK and IWORK are also used for conditional and -! optional inputs and optional outputs. (The term output here -! refers to the return from subroutine DLSODE to the user's calling -! program.) -! -! The legality of input parameters will be thoroughly checked on the -! initial call for the problem, but not checked thereafter unless a -! change in input parameters is flagged by ISTATE = 3 on input. -! -! The descriptions of the call arguments are as follows. -! -! F The name of the user-supplied subroutine defining the ODE -! system. The system must be put in the first-order form -! dy/dt = f(t,y), where f is a vector-valued function of -! the scalar t and the vector y. Subroutine F is to compute -! the function f. It is to have the form -! -! SUBROUTINE F (NEQ, T, Y, YDOT) -! KPP_REAL T, Y(*), YDOT(*) -! -! where NEQ, T, and Y are input, and the array YDOT = -! f(T,Y) is output. Y and YDOT are arrays of length NEQ. -! Subroutine F should not alter Y(1),...,Y(NEQ). F must be -! declared EXTERNAL in the calling program. -! -! Subroutine F may access user-defined quantities in -! NEQ(2),... and/or in Y(NEQ+1),..., if NEQ is an array -! (dimensioned in F) and/or Y has length exceeding NEQ. -! See the descriptions of NEQ and Y below. -! -! If quantities computed in the F routine are needed -! externally to DLSODE, an extra call to F should be made -! for this purpose, for consistent and accurate results. -! If only the derivative dy/dt is needed, use DINTDY -! instead. -! -! NEQ The size of the ODE system (number of first-order -! ordinary differential equations). Used only for input. -! NEQ may be decreased, but not increased, during the -! problem. If NEQ is decreased (with ISTATE = 3 on input), -! the remaining components of Y should be left undisturbed, -! if these are to be accessed in F and/or JAC. -! -! Normally, NEQ is a scalar, and it is generally referred -! to as a scalar in this user interface description. -! However, NEQ may be an array, with NEQ set to the -! system size. (The DLSODE package accesses only NEQ.) -! In either case, this parameter is passed as the NEQ -! argument in all calls to F and JAC. Hence, if it is an -! array, locations NEQ(2),... may be used to store other -! integer data and pass it to F and/or JAC. Subroutines -! F and/or JAC must include NEQ in a DIMENSION statement -! in that case. -! -! Y A real array for the vector of dependent variables, of -! length NEQ or more. Used for both input and output on -! the first call (ISTATE = 1), and only for output on -! other calls. On the first call, Y must contain the -! vector of initial values. On output, Y contains the -! computed solution vector, evaluated at T. If desired, -! the Y array may be used for other purposes between -! calls to the solver. -! -! This array is passed as the Y argument in all calls to F -! and JAC. Hence its length may exceed NEQ, and locations -! Y(NEQ+1),... may be used to store other real data and -! pass it to F and/or JAC. (The DLSODE package accesses -! only Y(1),...,Y(NEQ).) -! -! T The independent variable. On input, T is used only on -! the first call, as the initial point of the integration. -! On output, after each call, T is the value at which a -! computed solution Y is evaluated (usually the same as -! TOUT). On an error return, T is the farthest point -! reached. -! -! TOUT The next value of T at which a computed solution is -! desired. Used only for input. -! -! When starting the problem (ISTATE = 1), TOUT may be equal -! to T for one call, then should not equal T for the next -! call. For the initial T, an input value of TOUT .NE. T -! is used in order to determine the direction of the -! integration (i.e., the algebraic sign of the step sizes) -! and the rough scale of the problem. Integration in -! either direction (forward or backward in T) is permitted. -! -! If ITASK = 2 or 5 (one-step modes), TOUT is ignored -! after the first call (i.e., the first call with -! TOUT .NE. T). Otherwise, TOUT is required on every call. -! -! If ITASK = 1, 3, or 4, the values of TOUT need not be -! monotone, but a value of TOUT which backs up is limited -! to the current internal T interval, whose endpoints are -! TCUR - HU and TCUR. (See "Optional Outputs" below for -! TCUR and HU.) -! -! -! ITOL An indicator for the type of error control. See -! description below under AbsTol. Used only for input. -! -! RelTol A relative error tolerance parameter, either a scalar or -! an array of length NEQ. See description below under -! AbsTol. Input only. -! -! AbsTol An absolute error tolerance parameter, either a scalar or -! an array of length NEQ. Input only. -! -! The input parameters ITOL, RelTol, and AbsTol determine the -! error control performed by the solver. The solver will -! control the vector e = (e(i)) of estimated local errors -! in Y, according to an inequality of the form -! -! rms-norm of ( e(i)/EWT(i) ) <= 1, -! -! where -! -! EWT(i) = RelTol(i)*ABS(Y(i)) + AbsTol(i), -! -! and the rms-norm (root-mean-square norm) here is -! -! rms-norm(v) = SQRT(sum v(i)**2 / NEQ). -! -! Here EWT = (EWT(i)) is a vector of weights which must -! always be positive, and the values of RelTol and AbsTol -! should all be nonnegative. The following table gives the -! types (scalar/array) of RelTol and AbsTol, and the -! corresponding form of EWT(i). -! -! ITOL RelTol AbsTol EWT(i) -! ---- ------ ------ ----------------------------- -! 1 scalar scalar RelTol*ABS(Y(i)) + AbsTol -! 2 scalar array RelTol*ABS(Y(i)) + AbsTol(i) -! 3 array scalar RelTol(i)*ABS(Y(i)) + AbsTol -! 4 array array RelTol(i)*ABS(Y(i)) + AbsTol(i) -! -! When either of these parameters is a scalar, it need not -! be dimensioned in the user's calling program. -! -! If none of the above choices (with ITOL, RelTol, and AbsTol -! fixed throughout the problem) is suitable, more general -! error controls can be obtained by substituting -! user-supplied routines for the setting of EWT and/or for -! the norm calculation. See Part 4 below. -! -! If global errors are to be estimated by making a repeated -! run on the same problem with smaller tolerances, then all -! components of RelTol and AbsTol (i.e., of EWT) should be -! scaled down uniformly. -! -! ITASK An index specifying the task to be performed. Input -! only. ITASK has the following values and meanings: -! 1 Normal computation of output values of y(t) at -! t = TOUT (by overshooting and interpolating). -! 2 Take one step only and return. -! 3 Stop at the first internal mesh point at or beyond -! t = TOUT and return. -! 4 Normal computation of output values of y(t) at -! t = TOUT but without overshooting t = TCRIT. TCRIT -! must be input as RWORK(1). TCRIT may be equal to or -! beyond TOUT, but not behind it in the direction of -! integration. This option is useful if the problem -! has a singularity at or beyond t = TCRIT. -! 5 Take one step, without passing TCRIT, and return. -! TCRIT must be input as RWORK(1). -! -! Note: If ITASK = 4 or 5 and the solver reaches TCRIT -! (within roundoff), it will return T = TCRIT (exactly) to -! indicate this (unless ITASK = 4 and TOUT comes before -! TCRIT, in which case answers at T = TOUT are returned -! first). -! -! ISTATE An index used for input and output to specify the state -! of the calculation. -! -! On input, the values of ISTATE are as follows: -! 1 This is the first call for the problem -! (initializations will be done). See "Note" below. -! 2 This is not the first call, and the calculation is to -! continue normally, with no change in any input -! parameters except possibly TOUT and ITASK. (If ITOL, -! RelTol, and/or AbsTol are changed between calls with -! ISTATE = 2, the new values will be used but not -! tested for legality.) -! 3 This is not the first call, and the calculation is to -! continue normally, but with a change in input -! parameters other than TOUT and ITASK. Changes are -! allowed in NEQ, ITOL, RelTol, AbsTol, IOPT, LRW, LIW, MF, -! ML, MU, and any of the optional inputs except H0. -! (See IWORK description for ML and MU.) -! -! Note: A preliminary call with TOUT = T is not counted as -! a first call here, as no initialization or checking of -! input is done. (Such a call is sometimes useful for the -! purpose of outputting the initial conditions.) Thus the -! first call for which TOUT .NE. T requires ISTATE = 1 on -! input. -! -! On output, ISTATE has the following values and meanings: -! 1 Nothing was done, as TOUT was equal to T with -! ISTATE = 1 on input. -! 2 The integration was performed successfully. -! -1 An excessive amount of work (more than MXSTEP steps) -! was done on this call, before completing the -! requested task, but the integration was otherwise -! successful as far as T. (MXSTEP is an optional input -! and is normally 500.) To continue, the user may -! simply reset ISTATE to a value >1 and call again (the -! excess work step counter will be reset to 0). In -! addition, the user may increase MXSTEP to avoid this -! error return; see "Optional Inputs" below. -! -2 Too much accuracy was requested for the precision of -! the machine being used. This was detected before -! completing the requested task, but the integration -! was successful as far as T. To continue, the -! tolerance parameters must be reset, and ISTATE must -! be set to 3. The optional output TOLSF may be used -! for this purpose. (Note: If this condition is -! detected before taking any steps, then an illegal -! input return (ISTATE = -3) occurs instead.) -! -3 Illegal input was detected, before taking any -! integration steps. See written message for details. -! (Note: If the solver detects an infinite loop of -! calls to the solver with illegal input, it will cause -! the run to stop.) -! -4 There were repeated error-test failures on one -! attempted step, before completing the requested task, -! but the integration was successful as far as T. The -! problem may have a singularity, or the input may be -! inappropriate. -! -5 There were repeated convergence-test failures on one -! attempted step, before completing the requested task, -! but the integration was successful as far as T. This -! may be caused by an inaccurate Jacobian matrix, if -! one is being used. -! -6 EWT(i) became zero for some i during the integration. -! Pure relative error control (AbsTol(i)=0.0) was -! requested on a variable which has now vanished. The -! integration was successful as far as T. -! -! Note: Since the normal output value of ISTATE is 2, it -! does not need to be reset for normal continuation. Also, -! since a negative input value of ISTATE will be regarded -! as illegal, a negative output value requires the user to -! change it, and possibly other inputs, before calling the -! solver again. -! -! IOPT An integer flag to specify whether any optional inputs -! are being used on this call. Input only. The optional -! inputs are listed under a separate heading below. -! 0 No optional inputs are being used. Default values -! will be used in all cases. -! 1 One or more optional inputs are being used. -! -! RWORK A real working array (double precision). The length of -! RWORK must be at least -! -! 20 + NYH*(MAXORD + 1) + 3*NEQ + LWM -! -! where -! NYH = the initial value of NEQ, -! MAXORD = 12 (if METH = 1) or 5 (if METH = 2) (unless a -! smaller value is given as an optional input), -! LWM = 0 if MITER = 0, -! LWM = NEQ**2 + 2 if MITER = 1 or 2, -! LWM = NEQ + 2 if MITER = 3, and -! LWM = (2*ML + MU + 1)*NEQ + 2 -! if MITER = 4 or 5. -! (See the MF description below for METH and MITER.) -! -! Thus if MAXORD has its default value and NEQ is constant, -! this length is: -! 20 + 16*NEQ for MF = 10, -! 22 + 16*NEQ + NEQ**2 for MF = 11 or 12, -! 22 + 17*NEQ for MF = 13, -! 22 + 17*NEQ + (2*ML + MU)*NEQ for MF = 14 or 15, -! 20 + 9*NEQ for MF = 20, -! 22 + 9*NEQ + NEQ**2 for MF = 21 or 22, -! 22 + 10*NEQ for MF = 23, -! 22 + 10*NEQ + (2*ML + MU)*NEQ for MF = 24 or 25. -! -! The first 20 words of RWORK are reserved for conditional -! and optional inputs and optional outputs. -! -! The following word in RWORK is a conditional input: -! RWORK(1) = TCRIT, the critical value of t which the -! solver is not to overshoot. Required if ITASK -! is 4 or 5, and ignored otherwise. See ITASK. -! -! LRW The length of the array RWORK, as declared by the user. -! (This will be checked by the solver.) -! -! IWORK An integer work array. Its length must be at least -! 20 if MITER = 0 or 3 (MF = 10, 13, 20, 23), or -! 20 + NEQ otherwise (MF = 11, 12, 14, 15, 21, 22, 24, 25). -! (See the MF description below for MITER.) The first few -! words of IWORK are used for conditional and optional -! inputs and optional outputs. -! -! The following two words in IWORK are conditional inputs: -! IWORK(1) = ML These are the lower and upper half- -! IWORK(2) = MU bandwidths, respectively, of the banded -! Jacobian, excluding the main diagonal. -! The band is defined by the matrix locations -! (i,j) with i - ML <= j <= i + MU. ML and MU -! must satisfy 0 <= ML,MU <= NEQ - 1. These are -! required if MITER is 4 or 5, and ignored -! otherwise. ML and MU may in fact be the band -! parameters for a matrix to which df/dy is only -! approximately equal. -! -! LIW The length of the array IWORK, as declared by the user. -! (This will be checked by the solver.) -! -! Note: The work arrays must not be altered between calls to DLSODE -! for the same problem, except possibly for the conditional and -! optional inputs, and except for the last 3*NEQ words of RWORK. -! The latter space is used for internal scratch space, and so is -! available for use by the user outside DLSODE between calls, if -! desired (but not for use by F or JAC). -! -! JAC The name of the user-supplied routine (MITER = 1 or 4) to -! compute the Jacobian matrix, df/dy, as a function of the -! scalar t and the vector y. (See the MF description below -! for MITER.) It is to have the form -! -! SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD) -! KPP_REAL T, Y(*), PD(NROWPD,*) -! -! where NEQ, T, Y, ML, MU, and NROWPD are input and the -! array PD is to be loaded with partial derivatives -! (elements of the Jacobian matrix) on output. PD must be -! given a first dimension of NROWPD. T and Y have the same -! meaning as in subroutine F. -! -! In the full matrix case (MITER = 1), ML and MU are -! ignored, and the Jacobian is to be loaded into PD in -! columnwise manner, with df(i)/dy(j) loaded into PD(i,j). -! -! In the band matrix case (MITER = 4), the elements within -! the band are to be loaded into PD in columnwise manner, -! with diagonal lines of df/dy loaded into the rows of PD. -! Thus df(i)/dy(j) is to be loaded into PD(i-j+MU+1,j). ML -! and MU are the half-bandwidth parameters (see IWORK). -! The locations in PD in the two triangular areas which -! correspond to nonexistent matrix elements can be ignored -! or loaded arbitrarily, as they are overwritten by DLSODE. -! -! JAC need not provide df/dy exactly. A crude approximation -! (possibly with a smaller bandwidth) will do. -! -! In either case, PD is preset to zero by the solver, so -! that only the nonzero elements need be loaded by JAC. -! Each call to JAC is preceded by a call to F with the same -! arguments NEQ, T, and Y. Thus to gain some efficiency, -! intermediate quantities shared by both calculations may -! be saved in a user COMMON block by F and not recomputed -! by JAC, if desired. Also, JAC may alter the Y array, if -! desired. JAC must be declared EXTERNAL in the calling -! program. -! -! Subroutine JAC may access user-defined quantities in -! NEQ(2),... and/or in Y(NEQ+1),... if NEQ is an array -! (dimensioned in JAC) and/or Y has length exceeding -! NEQ. See the descriptions of NEQ and Y above. -! -! MF The method flag. Used only for input. The legal values -! of MF are 10, 11, 12, 13, 14, 15, 20, 21, 22, 23, 24, -! and 25. MF has decimal digits METH and MITER: -! MF = 10*METH + MITER . -! -! METH indicates the basic linear multistep method: -! 1 Implicit Adams method. -! 2 Method based on backward differentiation formulas -! (BDF's). -! -! MITER indicates the corrector iteration method: -! 0 Functional iteration (no Jacobian matrix is -! involved). -! 1 Chord iteration with a user-supplied full (NEQ by -! NEQ) Jacobian. -! 2 Chord iteration with an internally generated -! (difference quotient) full Jacobian (using NEQ -! extra calls to F per df/dy value). -! 3 Chord iteration with an internally generated -! diagonal Jacobian approximation (using one extra call -! to F per df/dy evaluation). -! 4 Chord iteration with a user-supplied banded Jacobian. -! 5 Chord iteration with an internally generated banded -! Jacobian (using ML + MU + 1 extra calls to F per -! df/dy evaluation). -! -! If MITER = 1 or 4, the user must supply a subroutine JAC -! (the name is arbitrary) as described above under JAC. -! For other values of MITER, a dummy argument can be used. -! -! Optional Inputs -! --------------- -! The following is a list of the optional inputs provided for in the -! call sequence. (See also Part 2.) For each such input variable, -! this table lists its name as used in this documentation, its -! location in the call sequence, its meaning, and the default value. -! The use of any of these inputs requires IOPT = 1, and in that case -! all of these inputs are examined. A value of zero for any of -! these optional inputs will cause the default value to be used. -! Thus to use a subset of the optional inputs, simply preload -! locations 5 to 10 in RWORK and IWORK to 0.0 and 0 respectively, -! and then set those of interest to nonzero values. -! -! Name Location Meaning and default value -! ------ --------- ----------------------------------------------- -! H0 RWORK(5) Step size to be attempted on the first step. -! The default value is determined by the solver. -! HMAX RWORK(6) Maximum absolute step size allowed. The -! default value is infinite. -! HMIN RWORK(7) Minimum absolute step size allowed. The -! default value is 0. (This lower bound is not -! enforced on the final step before reaching -! TCRIT when ITASK = 4 or 5.) -! MAXORD IWORK(5) Maximum order to be allowed. The default value -! is 12 if METH = 1, and 5 if METH = 2. (See the -! MF description above for METH.) If MAXORD -! exceeds the default value, it will be reduced -! to the default value. If MAXORD is changed -! during the problem, it may cause the current -! order to be reduced. -! MXSTEP IWORK(6) Maximum number of (internally defined) steps -! allowed during one call to the solver. The -! default value is 500. -! MXHNIL IWORK(7) Maximum number of messages printed (per -! problem) warning that T + H = T on a step -! (H = step size). This must be positive to -! result in a nondefault value. The default -! value is 10. -! -! Optional Outputs -! ---------------- -! As optional additional output from DLSODE, the variables listed -! below are quantities related to the performance of DLSODE which -! are available to the user. These are communicated by way of the -! work arrays, but also have internal mnemonic names as shown. -! Except where stated otherwise, all of these outputs are defined on -! any successful return from DLSODE, and on any return with ISTATE = -! -1, -2, -4, -5, or -6. On an illegal input return (ISTATE = -3), -! they will be unchanged from their existing values (if any), except -! possibly for TOLSF, LENRW, and LENIW. On any error return, -! outputs relevant to the error will be defined, as noted below. -! -! Name Location Meaning -! ----- --------- ------------------------------------------------ -! HU RWORK(11) Step size in t last used (successfully). -! HCUR RWORK(12) Step size to be attempted on the next step. -! TCUR RWORK(13) Current value of the independent variable which -! the solver has actually reached, i.e., the -! current internal mesh point in t. On output, -! TCUR will always be at least as far as the -! argument T, but may be farther (if interpolation -! was done). -! TOLSF RWORK(14) Tolerance scale factor, greater than 1.0, -! computed when a request for too much accuracy -! was detected (ISTATE = -3 if detected at the -! start of the problem, ISTATE = -2 otherwise). -! If ITOL is left unaltered but RelTol and AbsTol are -! uniformly scaled up by a factor of TOLSF for the -! next call, then the solver is deemed likely to -! succeed. (The user may also ignore TOLSF and -! alter the tolerance parameters in any other way -! appropriate.) -! NST IWORK(11) Number of steps taken for the problem so far. -! NFE IWORK(12) Number of F evaluations for the problem so far. -! NJE IWORK(13) Number of Jacobian evaluations (and of matrix LU -! decompositions) for the problem so far. -! NQU IWORK(14) Method order last used (successfully). -! NQCUR IWORK(15) Order to be attempted on the next step. -! IMXER IWORK(16) Index of the component of largest magnitude in -! the weighted local error vector ( e(i)/EWT(i) ), -! on an error return with ISTATE = -4 or -5. -! LENRW IWORK(17) Length of RWORK actually required. This is -! defined on normal returns and on an illegal -! input return for insufficient storage. -! LENIW IWORK(18) Length of IWORK actually required. This is -! defined on normal returns and on an illegal -! input return for insufficient storage. -! -! The following two arrays are segments of the RWORK array which may -! also be of interest to the user as optional outputs. For each -! array, the table below gives its internal name, its base address -! in RWORK, and its description. -! -! Name Base address Description -! ---- ------------ ---------------------------------------------- -! YH 21 The Nordsieck history array, of size NYH by -! (NQCUR + 1), where NYH is the initial value of -! NEQ. For j = 0,1,...,NQCUR, column j + 1 of -! YH contains HCUR**j/factorial(j) times the jth -! derivative of the interpolating polynomial -! currently representing the solution, evaluated -! at t = TCUR. -! ACOR LENRW-NEQ+1 Array of size NEQ used for the accumulated -! corrections on each step, scaled on output to -! represent the estimated local error in Y on -! the last step. This is the vector e in the -! description of the error control. It is -! defined only on successful return from DLSODE. -! -! -! Part 2. Other Callable Routines -! -------------------------------- -! -! The following are optional calls which the user may make to gain -! additional capabilities in conjunction with DLSODE. -! -! Form of call Function -! ------------------------ ---------------------------------------- -! CALL XSETUN(LUN) Set the logical unit number, LUN, for -! output of messages from DLSODE, if the -! default is not desired. The default -! value of LUN is 6. This call may be made -! at any time and will take effect -! immediately. -! CALL XSETF(MFLAG) Set a flag to control the printing of -! messages by DLSODE. MFLAG = 0 means do -! not print. (Danger: this risks losing -! valuable information.) MFLAG = 1 means -! print (the default). This call may be -! made at any time and will take effect -! immediately. -! CALL DSRCOM(RSAV,ISAV,JOB) Saves and restores the contents of the -! internal COMMON blocks used by DLSODE -! (see Part 3 below). RSAV must be a -! real array of length 218 or more, and -! ISAV must be an integer array of length -! 37 or more. JOB = 1 means save COMMON -! into RSAV/ISAV. JOB = 2 means restore -! COMMON from same. DSRCOM is useful if -! one is interrupting a run and restarting -! later, or alternating between two or -! more problems solved with DLSODE. -! CALL DINTDY(,,,,,) Provide derivatives of y, of various -! (see below) orders, at a specified point t, if -! desired. It may be called only after a -! successful return from DLSODE. Detailed -! instructions follow. -! -! Detailed instructions for using DINTDY -! -------------------------------------- -! The form of the CALL is: -! -! CALL DINTDY (T, K, RWORK(21), NYH, DKY, IFLAG) -! -! The input parameters are: -! -! T Value of independent variable where answers are -! desired (normally the same as the T last returned by -! DLSODE). For valid results, T must lie between -! TCUR - HU and TCUR. (See "Optional Outputs" above -! for TCUR and HU.) -! K Integer order of the derivative desired. K must -! satisfy 0 <= K <= NQCUR, where NQCUR is the current -! order (see "Optional Outputs"). The capability -! corresponding to K = 0, i.e., computing y(t), is -! already provided by DLSODE directly. Since -! NQCUR >= 1, the first derivative dy/dt is always -! available with DINTDY. -! RWORK(21) The base address of the history array YH. -! NYH Column length of YH, equal to the initial value of NEQ. -! -! The output parameters are: -! -! DKY Real array of length NEQ containing the computed value -! of the Kth derivative of y(t). -! IFLAG Integer flag, returned as 0 if K and T were legal, -! -1 if K was illegal, and -2 if T was illegal. -! On an error return, a message is also written. -! -! -! Part 3. Common Blocks -! ---------------------- -! -! If DLSODE is to be used in an overlay situation, the user must -! declare, in the primary overlay, the variables in: -! (1) the call sequence to DLSODE, -! (2) the internal COMMON block /DLS001/, of length 255 -! (218 double precision words followed by 37 integer words). -! -! If DLSODE is used on a system in which the contents of internal -! COMMON blocks are not preserved between calls, the user should -! declare the above COMMON block in his main program to insure that -! its contents are preserved. -! -! If the solution of a given problem by DLSODE is to be interrupted -! and then later continued, as when restarting an interrupted run or -! alternating between two or more problems, the user should save, -! following the return from the last DLSODE call prior to the -! interruption, the contents of the call sequence variables and the -! internal COMMON block, and later restore these values before the -! next DLSODE call for that problem. In addition, if XSETUN and/or -! XSETF was called for non-default handling of error messages, then -! these calls must be repeated. To save and restore the COMMON -! block, use subroutine DSRCOM (see Part 2 above). -! -! -! Part 4. Optionally Replaceable Solver Routines -! ----------------------------------------------- -! -! Below are descriptions of two routines in the DLSODE package which -! relate to the measurement of errors. Either routine can be -! replaced by a user-supplied version, if desired. However, since -! such a replacement may have a major impact on performance, it -! should be done only when absolutely necessary, and only with great -! caution. (Note: The means by which the package version of a -! routine is superseded by the user's version may be system- -! dependent.) -! -! DEWSET -! ------ -! The following subroutine is called just before each internal -! integration step, and sets the array of error weights, EWT, as -! described under ITOL/RelTol/AbsTol above: -! -! SUBROUTINE DEWSET (NEQ, ITOL, RelTol, AbsTol, YCUR, EWT) -! -! where NEQ, ITOL, RelTol, and AbsTol are as in the DLSODE call -! sequence, YCUR contains the current dependent variable vector, -! and EWT is the array of weights set by DEWSET. -! -! If the user supplies this subroutine, it must return in EWT(i) -! (i = 1,...,NEQ) a positive quantity suitable for comparing errors -! in Y(i) to. The EWT array returned by DEWSET is passed to the -! DVNORM routine (see below), and also used by DLSODE in the -! computation of the optional output IMXER, the diagonal Jacobian -! approximation, and the increments for difference quotient -! Jacobians. -! -! In the user-supplied version of DEWSET, it may be desirable to use -! the current values of derivatives of y. Derivatives up to order NQ -! are available from the history array YH, described above under -! optional outputs. In DEWSET, YH is identical to the YCUR array, -! extended to NQ + 1 columns with a column length of NYH and scale -! factors of H**j/factorial(j). On the first call for the problem, -! given by NST = 0, NQ is 1 and H is temporarily set to 1.0. -! NYH is the initial value of NEQ. The quantities NQ, H, and NST -! can be obtained by including in SEWSET the statements: -! KPP_REAL RLS -! COMMON /DLS001/ RLS(218),ILS(37) -! NQ = ILS(33) -! NST = ILS(34) -! H = RLS(212) -! Thus, for example, the current value of dy/dt can be obtained as -! YCUR(NYH+i)/H (i=1,...,NEQ) (and the division by H is unnecessary -! when NST = 0). -! -! DVNORM -! ------ -! DVNORM is a real function routine which computes the weighted -! root-mean-square norm of a vector v: -! -! d = DVNORM (n, v, w) -! -! where: -! n = the length of the vector, -! v = real array of length n containing the vector, -! w = real array of length n containing weights, -! d = SQRT( (1/n) * sum(v(i)*w(i))**2 ). -! -! DVNORM is called with n = NEQ and with w(i) = 1.0/EWT(i), where -! EWT is as set by subroutine DEWSET. -! -! If the user supplies this function, it should return a nonnegative -! value of DVNORM suitable for use in the error control in DLSODE. -! None of the arguments should be altered by DVNORM. For example, a -! user-supplied DVNORM routine might: -! - Substitute a max-norm of (v(i)*w(i)) for the rms-norm, or -! - Ignore some components of v in the norm, with the effect of -! suppressing the error control on those components of Y. -! --------------------------------------------------------------------- -!***ROUTINES CALLED DEWSET, DINTDY, DUMACH, DSTODE, DVNORM, XERRWD -!***COMMON BLOCKS DLS001 -!***REVISION HISTORY (YYYYMMDD) -! 19791129 DATE WRITTEN -! 19791213 Minor changes to declarations; DELP init. in STODE. -! 19800118 Treat NEQ as array; integer declarations added throughout; -! minor changes to prologue. -! 19800306 Corrected TESCO(1,NQP1) setting in CFODE. -! 19800519 Corrected access of YH on forced order reduction; -! numerous corrections to prologues and other comments. -! 19800617 In main driver, added loading of SQRT(UROUND) in RWORK; -! minor corrections to main prologue. -! 19800923 Added zero initialization of HU and NQU. -! 19801218 Revised XERRWD routine; minor corrections to main prologue. -! 19810401 Minor changes to comments and an error message. -! 19810814 Numerous revisions: replaced EWT by 1/EWT; used flags -! JCUR, ICF, IERPJ, IERSL between STODE and subordinates; -! added tuning parameters CCMAX, MAXCOR, MSBP, MXNCF; -! reorganized returns from STODE; reorganized type decls.; -! fixed message length in XERRWD; changed default LUNIT to 6; -! changed Common lengths; changed comments throughout. -! 19870330 Major update by ACH: corrected comments throughout; -! removed TRET from Common; rewrote EWSET with 4 loops; -! fixed t test in INTDY; added Cray directives in STODE; -! in STODE, fixed DELP init. and logic around PJAC call; -! combined routines to save/restore Common; -! passed LEVEL = 0 in error message calls (except run abort). -! 19890426 Modified prologue to SLATEC/LDOC format. (FNF) -! 19890501 Many improvements to prologue. (FNF) -! 19890503 A few final corrections to prologue. (FNF) -! 19890504 Minor cosmetic changes. (FNF) -! 19890510 Corrected description of Y in Arguments section. (FNF) -! 19890517 Minor corrections to prologue. (FNF) -! 19920514 Updated with prologue edited 891025 by G. Shaw for manual. -! 19920515 Converted source lines to upper case. (FNF) -! 19920603 Revised XERRWD calls using mixed upper-lower case. (ACH) -! 19920616 Revised prologue comment regarding CFT. (ACH) -! 19921116 Revised prologue comments regarding Common. (ACH). -! 19930326 Added comment about non-reentrancy. (FNF) -! 19930723 Changed D1MACH to DUMACH. (FNF) -! 19930801 Removed ILLIN and NTREP from Common (affects driver logic); -! minor changes to prologue and internal comments; -! changed Hollerith strings to quoted strings; -! changed internal comments to mixed case; -! replaced XERRWD with new version using character type; -! changed dummy dimensions from 1 to *. (ACH) -! 19930809 Changed to generic intrinsic names; changed names of -! subprograms and Common blocks to DLSODE etc. (ACH) -! 19930929 Eliminated use of REAL intrinsic; other minor changes. (ACH) -! 20010412 Removed all 'own' variables from Common block /DLS001/ -! (affects declarations in 6 routines). (ACH) -! 20010509 Minor corrections to prologue. (ACH) -! 20031105 Restored 'own' variables to Common block /DLS001/, to -! enable interrupt/restart feature. (ACH) -! 20031112 Added SAVE statements for data-loaded constants. -! -!***END PROLOGUE DLSODE -! -!*Internal Notes: -! -! Other Routines in the DLSODE Package. -! -! In addition to Subroutine DLSODE, the DLSODE package includes the -! following subroutines and function routines: -! DINTDY computes an interpolated value of the y vector at t = TOUT. -! DSTODE is the core integrator, which does one step of the -! integration and the associated error control. -! DCFODE sets all method coefficients and test constants. -! DPREPJ computes and preprocesses the Jacobian matrix J = df/dy -! and the Newton iteration matrix P = I - h*l0*J. -! DSOLSY manages solution of linear system in chord iteration. -! DEWSET sets the error weight vector EWT before each step. -! DVNORM computes the weighted R.M.S. norm of a vector. -! DSRCOM is a user-callable routine to save and restore -! the contents of the internal Common block. -! DGEFA and DGESL are routines from LINPACK for solving full -! systems of linear algebraic equations. -! DGBFA and DGBSL are routines from LINPACK for solving banded -! linear systems. -! DUMACH computes the unit roundoff in a machine-independent manner. -! XERRWD, XSETUN, XSETF, IXSAV, IUMACH handle the printing of all -! error messages and warnings. XERRWD is machine-dependent. -! Note: DVNORM, DUMACH, IXSAV, and IUMACH are function routines. -! All the others are subroutines. -! -!**End -! -! Declare externals. -! Note: they are now internal - !EXTERNAL DPREPJ, DSOLSY - !KPP_REAL DUMACH, DVNORM -! -! Declare all other variables. - INTEGER INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, IOWNS, & - ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, & - LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, & - MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU - INTEGER I, I1, I2, IFLAG, IMXER, KGO, LF0, & - LENIW, LENRW, LENWM, ML, MORD(2), MU, MXHNL0, MXSTP0 - KPP_REAL ROWNS, & - CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND - KPP_REAL AbsTolI, AYI, BIG, EWTI, H0, HMAX, HMX, RH, RelTolI, & - TCRIT, TDIST, TNEXT, TOL, TOLSF, TP, SIZE, SUM, W0 - - LOGICAL IHIT - CHARACTER*80 MSG - SAVE MORD, MXSTP0, MXHNL0 -!----------------------------------------------------------------------- -! The following internal Common block contains -! (a) variables which are local to any subroutine but whose values must -! be preserved between calls to the routine ("own" variables), and -! (b) variables which are communicated between subroutines. -! The block DLS001 is declared in subroutines DLSODE, DINTDY, DSTODE, -! DPREPJ, and DSOLSY. -! Groups of variables are replaced by dummy arrays in the Common -! declarations in routines where those variables are not used. -!----------------------------------------------------------------------- - COMMON /DLS001/ ROWNS(209), & - CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, & - INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, IOWNS(6), & - ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, & - LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, & - MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU -! - DATA MORD(1),MORD(2)/12,5/, MXSTP0/500/, MXHNL0/10/ -!----------------------------------------------------------------------- -! Block A. -! This code block is executed on every call. -! It tests ISTATE and ITASK for legality and branches appropriately. -! If ISTATE .GT. 1 but the flag INIT shows that initialization has -! not yet been done, an error return occurs. -! If ISTATE = 1 and TOUT = T, return immediately. -!----------------------------------------------------------------------- -! -!***FIRST EXECUTABLE STATEMENT DLSODE - IF (ISTATE .LT. 1 .OR. ISTATE .GT. 3) GO TO 601 - IF (ITASK .LT. 1 .OR. ITASK .GT. 5) GO TO 602 - IF (ISTATE .EQ. 1) GO TO 10 - IF (INIT .EQ. 0) GO TO 603 - IF (ISTATE .EQ. 2) GO TO 200 - GO TO 20 - 10 INIT = 0 - IF (TOUT .EQ. T) RETURN -!----------------------------------------------------------------------- -! Block B. -! The next code block is executed for the initial call (ISTATE = 1), -! or for a continuation call with parameter changes (ISTATE = 3). -! It contains checking of all inputs and various initializations. -! -! First check legality of the non-optional inputs NEQ, ITOL, IOPT, -! MF, ML, and MU. -!----------------------------------------------------------------------- - 20 IF (NEQ .LE. 0) GO TO 604 - IF (ISTATE .EQ. 1) GO TO 25 - IF (NEQ .GT. N) GO TO 605 - 25 N = NEQ - IF (ITOL .LT. 1 .OR. ITOL .GT. 4) GO TO 606 - IF (IOPT .LT. 0 .OR. IOPT .GT. 1) GO TO 607 - METH = MF/10 - MITER = MF - 10*METH - IF (METH .LT. 1 .OR. METH .GT. 2) GO TO 608 - IF (MITER .LT. 0 .OR. MITER .GT. 5) GO TO 608 - IF (MITER .LE. 3) GO TO 30 - ML = IWORK(1) - MU = IWORK(2) - IF (ML .LT. 0 .OR. ML .GE. N) GO TO 609 - IF (MU .LT. 0 .OR. MU .GE. N) GO TO 610 - 30 CONTINUE -! Next process and check the optional inputs. -------------------------- - IF (IOPT .EQ. 1) GO TO 40 - MAXORD = MORD(METH) - MXSTEP = MXSTP0 - MXHNIL = MXHNL0 - IF (ISTATE .EQ. 1) H0 = 0.0D0 - HMXI = 0.0D0 - HMIN = 0.0D0 - GO TO 60 - 40 MAXORD = IWORK(5) - IF (MAXORD .LT. 0) GO TO 611 - IF (MAXORD .EQ. 0) MAXORD = 100 - MAXORD = MIN(MAXORD,MORD(METH)) - MXSTEP = IWORK(6) - IF (MXSTEP .LT. 0) GO TO 612 - IF (MXSTEP .EQ. 0) MXSTEP = MXSTP0 - MXHNIL = IWORK(7) - IF (MXHNIL .LT. 0) GO TO 613 - IF (MXHNIL .EQ. 0) MXHNIL = MXHNL0 - IF (ISTATE .NE. 1) GO TO 50 - H0 = RWORK(5) - IF ((TOUT - T)*H0 .LT. 0.0D0) GO TO 614 - 50 HMAX = RWORK(6) - IF (HMAX .LT. 0.0D0) GO TO 615 - HMXI = 0.0D0 - IF (HMAX .GT. 0.0D0) HMXI = 1.0D0/HMAX - HMIN = RWORK(7) - IF (HMIN .LT. 0.0D0) GO TO 616 -!----------------------------------------------------------------------- -! Set work array pointers and check lengths LRW and LIW. -! Pointers to segments of RWORK and IWORK are named by prefixing L to -! the name of the segment. E.g., the segment YH starts at RWORK(LYH). -! Segments of RWORK (in order) are denoted YH, WM, EWT, SAVF, ACOR. -!----------------------------------------------------------------------- - 60 LYH = 21 - IF (ISTATE .EQ. 1) NYH = N - LWM = LYH + (MAXORD + 1)*NYH - IF (MITER .EQ. 0) LENWM = 0 - IF (MITER .EQ. 1 .OR. MITER .EQ. 2) LENWM = N*N + 2 - IF (MITER .EQ. 3) LENWM = N + 2 - IF (MITER .GE. 4) LENWM = (2*ML + MU + 1)*N + 2 - LEWT = LWM + LENWM - LSAVF = LEWT + N - LACOR = LSAVF + N - LENRW = LACOR + N - 1 - IWORK(17) = LENRW - LIWM = 1 - LENIW = 20 + N - IF (MITER .EQ. 0 .OR. MITER .EQ. 3) LENIW = 20 - IWORK(18) = LENIW - IF (LENRW .GT. LRW) GO TO 617 - IF (LENIW .GT. LIW) GO TO 618 -! Check RelTol and AbsTol for legality. ------------------------------------ - RelTolI = RelTol(1) - AbsTolI = AbsTol(1) - DO 70 I = 1,N - IF (ITOL .GE. 3) RelTolI = RelTol(I) - IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) AbsTolI = AbsTol(I) - IF (RelTolI .LT. 0.0D0) GO TO 619 - IF (AbsTolI .LT. 0.0D0) GO TO 620 - 70 CONTINUE - IF (ISTATE .EQ. 1) GO TO 100 -! If ISTATE = 3, set flag to signal parameter changes to DSTODE. ------- - JSTART = -1 - IF (NQ .LE. MAXORD) GO TO 90 -! MAXORD was reduced below NQ. Copy YH(*,MAXORD+2) into SAVF. --------- - DO 80 I = 1,N - 80 RWORK(I+LSAVF-1) = RWORK(I+LWM-1) -! Reload WM(1) = RWORK(LWM), since LWM may have changed. --------------- - 90 IF (MITER .GT. 0) RWORK(LWM) = SQRT(UROUND) - IF (N .EQ. NYH) GO TO 200 -! NEQ was reduced. Zero part of YH to avoid undefined references. ----- - I1 = LYH + L*NYH - I2 = LYH + (MAXORD + 1)*NYH - 1 - IF (I1 .GT. I2) GO TO 200 - DO 95 I = I1,I2 - 95 RWORK(I) = 0.0D0 - GO TO 200 -!----------------------------------------------------------------------- -! Block C. -! The next block is for the initial call only (ISTATE = 1). -! It contains all remaining initializations, the initial call to F, -! and the calculation of the initial step size. -! The error weights in EWT are inverted after being loaded. -!----------------------------------------------------------------------- - 100 UROUND = DUMACH() - TN = T - IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 110 - TCRIT = RWORK(1) - IF ((TCRIT - TOUT)*(TOUT - T) .LT. 0.0D0) GO TO 625 - IF (H0 .NE. 0.0D0 .AND. (T + H0 - TCRIT)*H0 .GT. 0.0D0) & - H0 = TCRIT - T - 110 JSTART = 0 - IF (MITER .GT. 0) RWORK(LWM) = SQRT(UROUND) - NHNIL = 0 - NST = 0 - NJE = 0 - NSLAST = 0 - HU = 0.0D0 - NQU = 0 - CCMAX = 0.3D0 - MAXCOR = 3 - MSBP = 20 - MXNCF = 10 -! Initial call to F. (LF0 points to YH(*,2).) ------------------------- - LF0 = LYH + NYH - CALL F (NEQ, T, Y, RWORK(LF0)) - NFE = 1 -! Load the initial value vector in YH. --------------------------------- - DO 115 I = 1,N - 115 RWORK(I+LYH-1) = Y(I) -! Load and invert the EWT array. (H is temporarily set to 1.0.) ------- - NQ = 1 - H = 1.0D0 - CALL DEWSET (N, ITOL, RelTol, AbsTol, RWORK(LYH), RWORK(LEWT)) - DO 120 I = 1,N - IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 621 - 120 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) -!----------------------------------------------------------------------- -! The coding below computes the step size, H0, to be attempted on the -! first step, unless the user has supplied a value for this. -! First check that TOUT - T differs significantly from zero. -! A scalar tolerance quantity TOL is computed, as MAX(RelTol(I)) -! if this is positive, or MAX(AbsTol(I)/ABS(Y(I))) otherwise, adjusted -! so as to be between 100*UROUND and 1.0E-3. -! Then the computed value H0 is given by.. -! NEQ -! H0**2 = TOL / ( w0**-2 + (1/NEQ) * SUM ( f(i)/ywt(i) )**2 ) -! 1 -! where w0 = MAX ( ABS(T), ABS(TOUT) ), -! f(i) = i-th component of initial value of f, -! ywt(i) = EWT(i)/TOL (a weight for y(i)). -! The sign of H0 is inferred from the initial values of TOUT and T. -!----------------------------------------------------------------------- - IF (H0 .NE. 0.0D0) GO TO 180 - TDIST = ABS(TOUT - T) - W0 = MAX(ABS(T),ABS(TOUT)) - IF (TDIST .LT. 2.0D0*UROUND*W0) GO TO 622 - TOL = RelTol(1) - IF (ITOL .LE. 2) GO TO 140 - DO 130 I = 1,N - 130 TOL = MAX(TOL,RelTol(I)) - 140 IF (TOL .GT. 0.0D0) GO TO 160 - AbsTolI = AbsTol(1) - DO 150 I = 1,N - IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) AbsTolI = AbsTol(I) - AYI = ABS(Y(I)) - IF (AYI .NE. 0.0D0) TOL = MAX(TOL,AbsTolI/AYI) - 150 CONTINUE - 160 TOL = MAX(TOL,100.0D0*UROUND) - TOL = MIN(TOL,0.001D0) - SUM = DVNORM (N, RWORK(LF0), RWORK(LEWT)) - SUM = 1.0D0/(TOL*W0*W0) + TOL*SUM**2 - H0 = 1.0D0/SQRT(SUM) - H0 = MIN(H0,TDIST) - H0 = SIGN(H0,TOUT-T) -! Adjust H0 if necessary to meet HMAX bound. --------------------------- - 180 RH = ABS(H0)*HMXI - IF (RH .GT. 1.0D0) H0 = H0/RH -! Load H with H0 and scale YH(*,2) by H0. ------------------------------ - H = H0 - DO 190 I = 1,N - 190 RWORK(I+LF0-1) = H0*RWORK(I+LF0-1) - GO TO 270 -!----------------------------------------------------------------------- -! Block D. -! The next code block is for continuation calls only (ISTATE = 2 or 3) -! and is to check stop conditions before taking a step. -!----------------------------------------------------------------------- - 200 NSLAST = NST - GO TO (210, 250, 220, 230, 240), ITASK - 210 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 - CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) - IF (IFLAG .NE. 0) GO TO 627 - T = TOUT - GO TO 420 - 220 TP = TN - HU*(1.0D0 + 100.0D0*UROUND) - IF ((TP - TOUT)*H .GT. 0.0D0) GO TO 623 - IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 - GO TO 400 - 230 TCRIT = RWORK(1) - IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 - IF ((TCRIT - TOUT)*H .LT. 0.0D0) GO TO 625 - IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 245 - CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) - IF (IFLAG .NE. 0) GO TO 627 - T = TOUT - GO TO 420 - 240 TCRIT = RWORK(1) - IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 - 245 HMX = ABS(TN) + ABS(H) - IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX - IF (IHIT) GO TO 400 - TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) - IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 - H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) - IF (ISTATE .EQ. 2) JSTART = -2 -!----------------------------------------------------------------------- -! Block E. -! The next block is normally executed for all calls and contains -! the call to the one-step core integrator DSTODE. -! -! This is a looping point for the integration steps. -! -! First check for too many steps being taken, update EWT (if not at -! start of problem), check for too much accuracy being requested, and -! check for H below the roundoff level in T. -!----------------------------------------------------------------------- - 250 CONTINUE - IF ((NST-NSLAST) .GE. MXSTEP) GO TO 500 - CALL DEWSET (N, ITOL, RelTol, AbsTol, RWORK(LYH), RWORK(LEWT)) - DO 260 I = 1,N - IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 510 - 260 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) - 270 TOLSF = UROUND*DVNORM (N, RWORK(LYH), RWORK(LEWT)) - IF (TOLSF .LE. 1.0D0) GO TO 280 - TOLSF = TOLSF*2.0D0 - IF (NST .EQ. 0) GO TO 626 - GO TO 520 - 280 IF ((TN + H) .NE. TN) GO TO 290 - NHNIL = NHNIL + 1 - IF (NHNIL .GT. MXHNIL) GO TO 290 - MSG = 'DLSODE- Warning..internal T (=R1) and H (=R2) are' - CALL XERRWD (MSG, 50, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) - MSG=' such that in the machine, T + H = T on the next step ' - CALL XERRWD (MSG, 60, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) - MSG = ' (H = step size). Solver will continue anyway' - CALL XERRWD (MSG, 50, 101, 0, 0, 0, 0, 2, TN, H) - IF (NHNIL .LT. MXHNIL) GO TO 290 - MSG = 'DLSODE- Above warning has been issued I1 times. ' - CALL XERRWD (MSG, 50, 102, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) - MSG = ' It will not be issued again for this problem' - CALL XERRWD (MSG, 50, 102, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) - 290 CONTINUE -!----------------------------------------------------------------------- -! CALL DSTODE(NEQ,Y,YH,NYH,YH,EWT,SAVF,ACOR,WM,IWM,F,JAC,DPREPJ,DSOLSY) -!----------------------------------------------------------------------- - CALL DSTODE (NEQ, Y, RWORK(LYH), NYH, RWORK(LYH), RWORK(LEWT), & - RWORK(LSAVF), RWORK(LACOR), RWORK(LWM), IWORK(LIWM), & - F, JAC) - !F, JAC, DPREPJ, DSOLSY) - KGO = 1 - KFLAG - GO TO (300, 530, 540), KGO -!----------------------------------------------------------------------- -! Block F. -! The following block handles the case of a successful return from the -! core integrator (KFLAG = 0). Test for stop conditions. -!----------------------------------------------------------------------- - 300 INIT = 1 - GO TO (310, 400, 330, 340, 350), ITASK -! ITASK = 1. If TOUT has been reached, interpolate. ------------------- - 310 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 - CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) - T = TOUT - GO TO 420 -! ITASK = 3. Jump to exit if TOUT was reached. ------------------------ - 330 IF ((TN - TOUT)*H .GE. 0.0D0) GO TO 400 - GO TO 250 -! ITASK = 4. See if TOUT or TCRIT was reached. Adjust H if necessary. - 340 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 345 - CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) - T = TOUT - GO TO 420 - 345 HMX = ABS(TN) + ABS(H) - IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX - IF (IHIT) GO TO 400 - TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) - IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 - H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) - JSTART = -2 - GO TO 250 -! ITASK = 5. See if TCRIT was reached and jump to exit. --------------- - 350 HMX = ABS(TN) + ABS(H) - IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX -!----------------------------------------------------------------------- -! Block G. -! The following block handles all successful returns from DLSODE. -! If ITASK .NE. 1, Y is loaded from YH and T is set accordingly. -! ISTATE is set to 2, and the optional outputs are loaded into the -! work arrays before returning. -!----------------------------------------------------------------------- - 400 DO 410 I = 1,N - 410 Y(I) = RWORK(I+LYH-1) - T = TN - IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 420 - IF (IHIT) T = TCRIT - 420 ISTATE = 2 - RWORK(11) = HU - RWORK(12) = H - RWORK(13) = TN - IWORK(11) = NST - IWORK(12) = NFE - IWORK(13) = NJE - IWORK(14) = NQU - IWORK(15) = NQ - RETURN -!----------------------------------------------------------------------- -! Block H. -! The following block handles all unsuccessful returns other than -! those for illegal input. First the error message routine is called. -! If there was an error test or convergence test failure, IMXER is set. -! Then Y is loaded from YH and T is set to TN. The optional outputs -! are loaded into the work arrays before returning. -!----------------------------------------------------------------------- -! The maximum number of steps was taken before reaching TOUT. ---------- - 500 MSG = 'DLSODE- At current T (=R1), MXSTEP (=I1) steps ' - CALL XERRWD (MSG, 50, 201, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) - MSG = ' taken on this call before reaching TOUT ' - CALL XERRWD (MSG, 50, 201, 0, 1, MXSTEP, 0, 1, TN, 0.0D0) - ISTATE = -1 - GO TO 580 -! EWT(I) .LE. 0.0 for some I (not at start of problem). ---------------- - 510 EWTI = RWORK(LEWT+I-1) - MSG = 'DLSODE- At T (=R1), EWT(I1) has become R2 .LE. 0.' - CALL XERRWD (MSG, 50, 202, 0, 1, I, 0, 2, TN, EWTI) - ISTATE = -6 - GO TO 580 -! Too much accuracy requested for machine precision. ------------------- - 520 MSG = 'DLSODE- At T (=R1), too much accuracy requested ' - CALL XERRWD (MSG, 50, 203, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) - MSG = ' for precision of machine.. see TOLSF (=R2) ' - CALL XERRWD (MSG, 50, 203, 0, 0, 0, 0, 2, TN, TOLSF) - RWORK(14) = TOLSF - ISTATE = -2 - GO TO 580 -! KFLAG = -1. Error test failed repeatedly or with ABS(H) = HMIN. ----- - 530 MSG = 'DLSODE- At T(=R1) and step size H(=R2), the error' - CALL XERRWD (MSG, 50, 204, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) - MSG = ' test failed repeatedly or with ABS(H) = HMIN' - CALL XERRWD (MSG, 50, 204, 0, 0, 0, 0, 2, TN, H) - ISTATE = -4 - GO TO 560 -! KFLAG = -2. Convergence failed repeatedly or with ABS(H) = HMIN. ---- - 540 MSG = 'DLSODE- At T (=R1) and step size H (=R2), the ' - CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) - MSG = ' corrector convergence failed repeatedly ' - CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) - MSG = ' or with ABS(H) = HMIN ' - CALL XERRWD (MSG, 30, 205, 0, 0, 0, 0, 2, TN, H) - ISTATE = -5 -! Compute IMXER if relevant. ------------------------------------------- - 560 BIG = 0.0D0 - IMXER = 1 - DO 570 I = 1,N - SIZE = ABS(RWORK(I+LACOR-1)*RWORK(I+LEWT-1)) - IF (BIG .GE. SIZE) GO TO 570 - BIG = SIZE - IMXER = I - 570 CONTINUE - IWORK(16) = IMXER -! Set Y vector, T, and optional outputs. ------------------------------- - 580 DO 590 I = 1,N - 590 Y(I) = RWORK(I+LYH-1) - T = TN - RWORK(11) = HU - RWORK(12) = H - RWORK(13) = TN - IWORK(11) = NST - IWORK(12) = NFE - IWORK(13) = NJE - IWORK(14) = NQU - IWORK(15) = NQ - RETURN -!----------------------------------------------------------------------- -! Block I. -! The following block handles all error returns due to illegal input -! (ISTATE = -3), as detected before calling the core integrator. -! First the error message routine is called. If the illegal input -! is a negative ISTATE, the run is aborted (apparent infinite loop). -!----------------------------------------------------------------------- - 601 MSG = 'DLSODE- ISTATE (=I1) illegal ' - CALL XERRWD (MSG, 30, 1, 0, 1, ISTATE, 0, 0, 0.0D0, 0.0D0) - IF (ISTATE .LT. 0) GO TO 800 - GO TO 700 - 602 MSG = 'DLSODE- ITASK (=I1) illegal ' - CALL XERRWD (MSG, 30, 2, 0, 1, ITASK, 0, 0, 0.0D0, 0.0D0) - GO TO 700 - 603 MSG = 'DLSODE- ISTATE .GT. 1 but DLSODE not initialized ' - CALL XERRWD (MSG, 50, 3, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) - GO TO 700 - 604 MSG = 'DLSODE- NEQ (=I1) .LT. 1 ' - CALL XERRWD (MSG, 30, 4, 0, 1, NEQ, 0, 0, 0.0D0, 0.0D0) - GO TO 700 - 605 MSG = 'DLSODE- ISTATE = 3 and NEQ increased (I1 to I2) ' - CALL XERRWD (MSG, 50, 5, 0, 2, N, NEQ, 0, 0.0D0, 0.0D0) - GO TO 700 - 606 MSG = 'DLSODE- ITOL (=I1) illegal ' - CALL XERRWD (MSG, 30, 6, 0, 1, ITOL, 0, 0, 0.0D0, 0.0D0) - GO TO 700 - 607 MSG = 'DLSODE- IOPT (=I1) illegal ' - CALL XERRWD (MSG, 30, 7, 0, 1, IOPT, 0, 0, 0.0D0, 0.0D0) - GO TO 700 - 608 MSG = 'DLSODE- MF (=I1) illegal ' - CALL XERRWD (MSG, 30, 8, 0, 1, MF, 0, 0, 0.0D0, 0.0D0) - GO TO 700 - 609 MSG = 'DLSODE- ML (=I1) illegal.. .LT.0 or .GE.NEQ (=I2)' - CALL XERRWD (MSG, 50, 9, 0, 2, ML, NEQ, 0, 0.0D0, 0.0D0) - GO TO 700 - 610 MSG = 'DLSODE- MU (=I1) illegal.. .LT.0 or .GE.NEQ (=I2)' - CALL XERRWD (MSG, 50, 10, 0, 2, MU, NEQ, 0, 0.0D0, 0.0D0) - GO TO 700 - 611 MSG = 'DLSODE- MAXORD (=I1) .LT. 0 ' - CALL XERRWD (MSG, 30, 11, 0, 1, MAXORD, 0, 0, 0.0D0, 0.0D0) - GO TO 700 - 612 MSG = 'DLSODE- MXSTEP (=I1) .LT. 0 ' - CALL XERRWD (MSG, 30, 12, 0, 1, MXSTEP, 0, 0, 0.0D0, 0.0D0) - GO TO 700 - 613 MSG = 'DLSODE- MXHNIL (=I1) .LT. 0 ' - CALL XERRWD (MSG, 30, 13, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) - GO TO 700 - 614 MSG = 'DLSODE- TOUT (=R1) behind T (=R2) ' - CALL XERRWD (MSG, 40, 14, 0, 0, 0, 0, 2, TOUT, T) - MSG = ' Integration direction is given by H0 (=R1) ' - CALL XERRWD (MSG, 50, 14, 0, 0, 0, 0, 1, H0, 0.0D0) - GO TO 700 - 615 MSG = 'DLSODE- HMAX (=R1) .LT. 0.0 ' - CALL XERRWD (MSG, 30, 15, 0, 0, 0, 0, 1, HMAX, 0.0D0) - GO TO 700 - 616 MSG = 'DLSODE- HMIN (=R1) .LT. 0.0 ' - CALL XERRWD (MSG, 30, 16, 0, 0, 0, 0, 1, HMIN, 0.0D0) - GO TO 700 - 617 CONTINUE - MSG='DLSODE- RWORK length needed, LENRW (=I1), exceeds LRW (=I2)' - CALL XERRWD (MSG, 60, 17, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) - GO TO 700 - 618 CONTINUE - MSG='DLSODE- IWORK length needed, LENIW (=I1), exceeds LIW (=I2)' - CALL XERRWD (MSG, 60, 18, 0, 2, LENIW, LIW, 0, 0.0D0, 0.0D0) - GO TO 700 - 619 MSG = 'DLSODE- RelTol(I1) is R1 .LT. 0.0 ' - CALL XERRWD (MSG, 40, 19, 0, 1, I, 0, 1, RelTolI, 0.0D0) - GO TO 700 - 620 MSG = 'DLSODE- AbsTol(I1) is R1 .LT. 0.0 ' - CALL XERRWD (MSG, 40, 20, 0, 1, I, 0, 1, AbsTolI, 0.0D0) - GO TO 700 - 621 EWTI = RWORK(LEWT+I-1) - MSG = 'DLSODE- EWT(I1) is R1 .LE. 0.0 ' - CALL XERRWD (MSG, 40, 21, 0, 1, I, 0, 1, EWTI, 0.0D0) - GO TO 700 - 622 CONTINUE - MSG='DLSODE- TOUT (=R1) too close to T(=R2) to start integration' - CALL XERRWD (MSG, 60, 22, 0, 0, 0, 0, 2, TOUT, T) - GO TO 700 - 623 CONTINUE - MSG='DLSODE- ITASK = I1 and TOUT (=R1) behind TCUR - HU (= R2) ' - CALL XERRWD (MSG, 60, 23, 0, 1, ITASK, 0, 2, TOUT, TP) - GO TO 700 - 624 CONTINUE - MSG='DLSODE- ITASK = 4 OR 5 and TCRIT (=R1) behind TCUR (=R2) ' - CALL XERRWD (MSG, 60, 24, 0, 0, 0, 0, 2, TCRIT, TN) - GO TO 700 - 625 CONTINUE - MSG='DLSODE- ITASK = 4 or 5 and TCRIT (=R1) behind TOUT (=R2) ' - CALL XERRWD (MSG, 60, 25, 0, 0, 0, 0, 2, TCRIT, TOUT) - GO TO 700 - 626 MSG = 'DLSODE- At start of problem, too much accuracy ' - CALL XERRWD (MSG, 50, 26, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) - MSG=' requested for precision of machine.. See TOLSF (=R1) ' - CALL XERRWD (MSG, 60, 26, 0, 0, 0, 0, 1, TOLSF, 0.0D0) - RWORK(14) = TOLSF - GO TO 700 - 627 MSG = 'DLSODE- Trouble in DINTDY. ITASK = I1, TOUT = R1' - CALL XERRWD (MSG, 50, 27, 0, 1, ITASK, 0, 1, TOUT, 0.0D0) -! - 700 ISTATE = -3 - RETURN -! - 800 MSG = 'DLSODE- Run aborted.. apparent infinite loop ' - CALL XERRWD (MSG, 50, 303, 2, 0, 0, 0, 0, 0.0D0, 0.0D0) - RETURN -!----------------------- END OF SUBROUTINE DLSODE ---------------------- - !END SUBROUTINE DLSODE - CONTAINS - - -!DECK DUMACH - KPP_REAL FUNCTION DUMACH () -!***BEGIN PROLOGUE DUMACH -!***PURPOSE Compute the unit roundoff of the machine. -!***CATEGORY R1 -!***TYPE KPP_REAL (RUMACH-S, DUMACH-D) -!***KEYWORDS MACHINE CONSTANTS -!***AUTHOR Hindmarsh, Alan C., (LLNL) -!***DESCRIPTION -! *Usage: -! KPP_REAL A, DUMACH -! A = DUMACH() -! -! *Function Return Values: -! A : the unit roundoff of the machine. -! -! *Description: -! The unit roundoff is defined as the smallest positive machine -! number u such that 1.0 + u .ne. 1.0. This is computed by DUMACH -! in a machine-independent manner. -! -!***REFERENCES (NONE) -!***ROUTINES CALLED DUMSUM -!***REVISION HISTORY (YYYYMMDD) -! 19930216 DATE WRITTEN -! 19930818 Added SLATEC-format prologue. (FNF) -! 20030707 Added DUMSUM to force normal storage of COMP. (ACH) -!***END PROLOGUE DUMACH -! - KPP_REAL U, COMP -!***FIRST EXECUTABLE STATEMENT DUMACH - U = 1.0D0 - 10 U = U*0.5D0 - CALL DUMSUM(1.0D0, U, COMP) - IF (COMP .NE. 1.0D0) GO TO 10 - DUMACH = U*2.0D0 - RETURN -!----------------------- End of Function DUMACH ------------------------ - END FUNCTION DUMACH - - SUBROUTINE DUMSUM(A,B,C) -! Routine to force normal storing of A + B, for DUMACH. - KPP_REAL A, B, C - C = A + B - RETURN - END SUBROUTINE DUMSUM -!DECK DCFODE - SUBROUTINE DCFODE (METH, ELCO, TESCO) -!***BEGIN PROLOGUE DCFODE -!***SUBSIDIARY -!***PURPOSE Set ODE integrator coefficients. -!***TYPE KPP_REAL (SCFODE-S, DCFODE-D) -!***AUTHOR Hindmarsh, Alan C., (LLNL) -!***DESCRIPTION -! -! DCFODE is called by the integrator routine to set coefficients -! needed there. The coefficients for the current method, as -! given by the value of METH, are set for all orders and saved. -! The maximum order assumed here is 12 if METH = 1 and 5 if METH = 2. -! (A smaller value of the maximum order is also allowed.) -! DCFODE is called once at the beginning of the problem, -! and is not called again unless and until METH is changed. -! -! The ELCO array contains the basic method coefficients. -! The coefficients el(i), 1 .le. i .le. nq+1, for the method of -! order nq are stored in ELCO(i,nq). They are given by a genetrating -! polynomial, i.e., -! l(x) = el(1) + el(2)*x + ... + el(nq+1)*x**nq. -! For the implicit Adams methods, l(x) is given by -! dl/dx = (x+1)*(x+2)*...*(x+nq-1)/factorial(nq-1), l(-1) = 0. -! For the BDF methods, l(x) is given by -! l(x) = (x+1)*(x+2)* ... *(x+nq)/K, -! where K = factorial(nq)*(1 + 1/2 + ... + 1/nq). -! -! The TESCO array contains test constants used for the -! local error test and the selection of step size and/or order. -! At order nq, TESCO(k,nq) is used for the selection of step -! size at order nq - 1 if k = 1, at order nq if k = 2, and at order -! nq + 1 if k = 3. -! -!***SEE ALSO DLSODE -!***ROUTINES CALLED (NONE) -!***REVISION HISTORY (YYMMDD) -! 791129 DATE WRITTEN -! 890501 Modified prologue to SLATEC/LDOC format. (FNF) -! 890503 Minor cosmetic changes. (FNF) -! 930809 Renamed to allow single/double precision versions. (ACH) -!***END PROLOGUE DCFODE -!**End - INTEGER METH - INTEGER I, IB, NQ, NQM1, NQP1 - KPP_REAL ELCO(13,12), TESCO(3,12), PC(12) - KPP_REAL AGAMQ, FNQ, FNQM1, PINT, RAGQ, RQFAC, RQ1FAC, TSIGN, XPIN -! -!***FIRST EXECUTABLE STATEMENT DCFODE - GO TO (100, 200), METH -! - 100 ELCO(1,1) = 1.0D0 - ELCO(2,1) = 1.0D0 - TESCO(1,1) = 0.0D0 - TESCO(2,1) = 2.0D0 - TESCO(1,2) = 1.0D0 - TESCO(3,12) = 0.0D0 - PC(1) = 1.0D0 - RQFAC = 1.0D0 - DO 140 NQ = 2,12 -!----------------------------------------------------------------------- -! The PC array will contain the coefficients of the polynomial -! p(x) = (x+1)*(x+2)*...*(x+nq-1). -! Initially, p(x) = 1. -!----------------------------------------------------------------------- - RQ1FAC = RQFAC - RQFAC = RQFAC/NQ - NQM1 = NQ - 1 - FNQM1 = NQM1 - NQP1 = NQ + 1 -! Form coefficients of p(x)*(x+nq-1). ---------------------------------- - PC(NQ) = 0.0D0 - DO 110 IB = 1,NQM1 - I = NQP1 - IB - 110 PC(I) = PC(I-1) + FNQM1*PC(I) - PC(1) = FNQM1*PC(1) -! Compute integral, -1 to 0, of p(x) and x*p(x). ----------------------- - PINT = PC(1) - XPIN = PC(1)/2.0D0 - TSIGN = 1.0D0 - DO 120 I = 2,NQ - TSIGN = -TSIGN - PINT = PINT + TSIGN*PC(I)/I - 120 XPIN = XPIN + TSIGN*PC(I)/(I+1) -! Store coefficients in ELCO and TESCO. -------------------------------- - ELCO(1,NQ) = PINT*RQ1FAC - ELCO(2,NQ) = 1.0D0 - DO 130 I = 2,NQ - 130 ELCO(I+1,NQ) = RQ1FAC*PC(I)/I - AGAMQ = RQFAC*XPIN - RAGQ = 1.0D0/AGAMQ - TESCO(2,NQ) = RAGQ - IF (NQ .LT. 12) TESCO(1,NQP1) = RAGQ*RQFAC/NQP1 - TESCO(3,NQM1) = RAGQ - 140 CONTINUE - RETURN -! - 200 PC(1) = 1.0D0 - RQ1FAC = 1.0D0 - DO 230 NQ = 1,5 -!----------------------------------------------------------------------- -! The PC array will contain the coefficients of the polynomial -! p(x) = (x+1)*(x+2)*...*(x+nq). -! Initially, p(x) = 1. -!----------------------------------------------------------------------- - FNQ = NQ - NQP1 = NQ + 1 -! Form coefficients of p(x)*(x+nq). ------------------------------------ - PC(NQP1) = 0.0D0 - DO 210 IB = 1,NQ - I = NQ + 2 - IB - 210 PC(I) = PC(I-1) + FNQ*PC(I) - PC(1) = FNQ*PC(1) -! Store coefficients in ELCO and TESCO. -------------------------------- - DO 220 I = 1,NQP1 - 220 ELCO(I,NQ) = PC(I)/PC(2) - ELCO(2,NQ) = 1.0D0 - TESCO(1,NQ) = RQ1FAC - TESCO(2,NQ) = NQP1/ELCO(1,NQ) - TESCO(3,NQ) = (NQ+2)/ELCO(1,NQ) - RQ1FAC = RQ1FAC/FNQ - 230 CONTINUE - RETURN -!----------------------- END OF SUBROUTINE DCFODE ---------------------- - END SUBROUTINE DCFODE -!DECK DINTDY - SUBROUTINE DINTDY (T, K, YH, NYH, DKY, IFLAG) -!***BEGIN PROLOGUE DINTDY -!***SUBSIDIARY -!***PURPOSE Interpolate solution derivatives. -!***TYPE KPP_REAL (SINTDY-S, DINTDY-D) -!***AUTHOR Hindmarsh, Alan C., (LLNL) -!***DESCRIPTION -! -! DINTDY computes interpolated values of the K-th derivative of the -! dependent variable vector y, and stores it in DKY. This routine -! is called within the package with K = 0 and T = TOUT, but may -! also be called by the user for any K up to the current order. -! (See detailed instructions in the usage documentation.) -! -! The computed values in DKY are gotten by interpolation using the -! Nordsieck history array YH. This array corresponds uniquely to a -! vector-valued polynomial of degree NQCUR or less, and DKY is set -! to the K-th derivative of this polynomial at T. -! The formula for DKY is: -! q -! DKY(i) = sum c(j,K) * (T - tn)**(j-K) * h**(-j) * YH(i,j+1) -! j=K -! where c(j,K) = j*(j-1)*...*(j-K+1), q = NQCUR, tn = TCUR, h = HCUR. -! The quantities nq = NQCUR, l = nq+1, N = NEQ, tn, and h are -! communicated by COMMON. The above sum is done in reverse order. -! IFLAG is returned negative if either K or T is out of bounds. -! -!***SEE ALSO DLSODE -!***ROUTINES CALLED XERRWD -!***COMMON BLOCKS DLS001 -!***REVISION HISTORY (YYMMDD) -! 791129 DATE WRITTEN -! 890501 Modified prologue to SLATEC/LDOC format. (FNF) -! 890503 Minor cosmetic changes. (FNF) -! 930809 Renamed to allow single/double precision versions. (ACH) -! 010418 Reduced size of Common block /DLS001/. (ACH) -! 031105 Restored 'own' variables to Common block /DLS001/, to -! enable interrupt/restart feature. (ACH) -! 050427 Corrected roundoff decrement in TP. (ACH) -!***END PROLOGUE DINTDY -!**End - INTEGER K, NYH, IFLAG - KPP_REAL T, YH(NYH,*), DKY(*) - INTEGER IOWND, IOWNS, & - ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, & - LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, & - MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU - KPP_REAL ROWNS, & - CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND - COMMON /DLS001/ ROWNS(209), & - CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, & - IOWND(6), IOWNS(6), & - ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, & - LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, & - MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU - INTEGER I, IC, J, JB, JB2, JJ, JJ1, JP1 - KPP_REAL C, R, S, TP - CHARACTER*80 MSG -! -!***FIRST EXECUTABLE STATEMENT DINTDY - IFLAG = 0 - IF (K .LT. 0 .OR. K .GT. NQ) GO TO 80 - TP = TN - HU - 100.0D0*UROUND*SIGN(ABS(TN) + ABS(HU), HU) - IF ((T-TP)*(T-TN) .GT. 0.0D0) GO TO 90 -! - S = (T - TN)/H - IC = 1 - IF (K .EQ. 0) GO TO 15 - JJ1 = L - K - DO 10 JJ = JJ1,NQ - 10 IC = IC*JJ - 15 C = IC - DO 20 I = 1,N - 20 DKY(I) = C*YH(I,L) - IF (K .EQ. NQ) GO TO 55 - JB2 = NQ - K - DO 50 JB = 1,JB2 - J = NQ - JB - JP1 = J + 1 - IC = 1 - IF (K .EQ. 0) GO TO 35 - JJ1 = JP1 - K - DO 30 JJ = JJ1,J - 30 IC = IC*JJ - 35 C = IC - DO 40 I = 1,N - 40 DKY(I) = C*YH(I,JP1) + S*DKY(I) - 50 CONTINUE - IF (K .EQ. 0) RETURN - 55 R = H**(-K) - DO 60 I = 1,N - 60 DKY(I) = R*DKY(I) - RETURN -! - 80 MSG = 'DINTDY- K (=I1) illegal ' - CALL XERRWD (MSG, 30, 51, 0, 1, K, 0, 0, 0.0D0, 0.0D0) - IFLAG = -1 - RETURN - 90 MSG = 'DINTDY- T (=R1) illegal ' - CALL XERRWD (MSG, 30, 52, 0, 0, 0, 0, 1, T, 0.0D0) - MSG=' T not in interval TCUR - HU (= R1) to TCUR (=R2) ' - CALL XERRWD (MSG, 60, 52, 0, 0, 0, 0, 2, TP, TN) - IFLAG = -2 - RETURN -!----------------------- END OF SUBROUTINE DINTDY ---------------------- - END SUBROUTINE DINTDY -!DECK DPREPJ - SUBROUTINE DPREPJ (NEQ, Y, YH, NYH, EWT, FTEM, SAVF, WM, IWM, F, JAC) -!***BEGIN PROLOGUE DPREPJ -!***SUBSIDIARY -!***PURPOSE Compute and process Newton iteration matrix. -!***TYPE KPP_REAL (SPREPJ-S, DPREPJ-D) -!***AUTHOR Hindmarsh, Alan C., (LLNL) -!***DESCRIPTION -! -! DPREPJ is called by DSTODE to compute and process the matrix -! P = I - h*el(1)*J , where J is an approximation to the Jacobian. -! Here J is computed by the user-supplied routine JAC if -! MITER = 1 or 4, or by finite differencing if MITER = 2, 3, or 5. -! If MITER = 3, a diagonal approximation to J is used. -! J is stored in WM and replaced by P. If MITER .ne. 3, P is then -! subjected to LU decomposition in preparation for later solution -! of linear systems with P as coefficient matrix. This is done -! by DGEFA if MITER = 1 or 2, and by DGBFA if MITER = 4 or 5. -! -! In addition to variables described in DSTODE and DLSODE prologues, -! communication with DPREPJ uses the following: -! Y = array containing predicted values on entry. -! FTEM = work array of length N (ACOR in DSTODE). -! SAVF = array containing f evaluated at predicted y. -! WM = real work space for matrices. On output it contains the -! inverse diagonal matrix if MITER = 3 and the LU decomposition -! of P if MITER is 1, 2 , 4, or 5. -! Storage of matrix elements starts at WM(3). -! WM also contains the following matrix-related data: -! WM(1) = SQRT(UROUND), used in numerical Jacobian increments. -! WM(2) = H*EL0, saved for later use if MITER = 3. -! IWM = integer work space containing pivot information, starting at -! IWM(21), if MITER is 1, 2, 4, or 5. IWM also contains band -! parameters ML = IWM(1) and MU = IWM(2) if MITER is 4 or 5. -! EL0 = EL(1) (input). -! IERPJ = output error flag, = 0 if no trouble, .gt. 0 if -! P matrix found to be singular. -! JCUR = output flag = 1 to indicate that the Jacobian matrix -! (or approximation) is now current. -! This routine also uses the COMMON variables EL0, H, TN, UROUND, -! MITER, N, NFE, and NJE. -! -!***SEE ALSO DLSODE -!***ROUTINES CALLED DGBFA, DGEFA, DVNORM -!***COMMON BLOCKS DLS001 -!***REVISION HISTORY (YYMMDD) -! 791129 DATE WRITTEN -! 890501 Modified prologue to SLATEC/LDOC format. (FNF) -! 890504 Minor cosmetic changes. (FNF) -! 930809 Renamed to allow single/double precision versions. (ACH) -! 010418 Reduced size of Common block /DLS001/. (ACH) -! 031105 Restored 'own' variables to Common block /DLS001/, to -! enable interrupt/restart feature. (ACH) -!***END PROLOGUE DPREPJ -!**End - EXTERNAL F, JAC - INTEGER NEQ, NYH, IWM(*) - KPP_REAL Y(*), YH(NYH,*), EWT(*), FTEM(*), SAVF(*), WM(*) - INTEGER IOWND, IOWNS, & - ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, & - LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, & - MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU - KPP_REAL ROWNS, & - CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND - COMMON /DLS001/ ROWNS(209), & - CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, & - IOWND(6), IOWNS(6), & - ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, & - LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, & - MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU - INTEGER I, I1, I2, IER, II, J, J1, JJ, LENP, & - MBA, MBAND, MEB1, MEBAND, ML, ML3, MU, NP1 - KPP_REAL CON, DI, FAC, HL0, R, R0, SRUR, YI, YJ, YJJ - !KPP_REAL DVNORM -! -!***FIRST EXECUTABLE STATEMENT DPREPJ - NJE = NJE + 1 - IERPJ = 0 - JCUR = 1 - HL0 = H*EL0 - CON = -HL0 - -#ifdef FULL_ALGEBRA - LENP = N*N - DO i = 1,LENP - WM(i+2) = 0.0D0 - END DO - CALL JAC_CHEM (NEQ, TN, Y, WM(3)) - DO I = 1,LENP - WM(I+2) = WM(I+2)*CON - END DO - ! Add identity matrix - J = 3 - NP1 = N + 1 - DO I = 1,N - WM(J) = WM(J) + 1.0D0 - J = J + NP1 - END DO - ! Do LU decomposition on P - CALL DGETRF(N,N,WM(3),N,IWM(21),IER) -#else - CALL JAC_CHEM (NEQ, TN, Y, WM(3)) - DO i = 1,LU_NONZERO - WM(i+2) = WM(i+2)*CON - END DO - ! Add identity matrix - DO i = 1,N - j = 2+LU_DIAG(i) - WM(j) = WM(j) + 1.0D0 - END DO - ! Do LU decomposition on P - CALL KppDecomp(WM(3),IER) -#endif - IF (IER .NE. 0) IERPJ = 1 - RETURN - !----------------------- END OF SUBROUTINE DPREPJ ---------------------- - END SUBROUTINE DPREPJ -!DECK DSOLSY - SUBROUTINE DSOLSY (WM, IWM, X, TEM) -!***BEGIN PROLOGUE DSOLSY -!***SUBSIDIARY -!***PURPOSE ODEPACK linear system solver. -!***TYPE KPP_REAL (SSOLSY-S, DSOLSY-D) -!***AUTHOR Hindmarsh, Alan C., (LLNL) -!***DESCRIPTION -! -! This routine manages the solution of the linear system arising from -! a chord iteration. It is called if MITER .ne. 0. -! If MITER is 1 or 2, it calls DGESL to accomplish this. -! If MITER = 3 it updates the coefficient h*EL0 in the diagonal -! matrix, and then computes the solution. -! If MITER is 4 or 5, it calls DGBSL. -! Communication with DSOLSY uses the following variables: -! WM = real work space containing the inverse diagonal matrix if -! MITER = 3 and the LU decomposition of the matrix otherwise. -! Storage of matrix elements starts at WM(3). -! WM also contains the following matrix-related data: -! WM(1) = SQRT(UROUND) (not used here), -! WM(2) = HL0, the previous value of h*EL0, used if MITER = 3. -! IWM = integer work space containing pivot information, starting at -! IWM(21), if MITER is 1, 2, 4, or 5. IWM also contains band -! parameters ML = IWM(1) and MU = IWM(2) if MITER is 4 or 5. -! X = the right-hand side vector on input, and the solution vector -! on output, of length N. -! TEM = vector of work space of length N, not used in this version. -! IERSL = output flag (in COMMON). IERSL = 0 if no trouble occurred. -! IERSL = 1 if a singular matrix arose with MITER = 3. -! This routine also uses the COMMON variables EL0, H, MITER, and N. -! -!***SEE ALSO DLSODE -!***ROUTINES CALLED DGBSL, DGESL -!***COMMON BLOCKS DLS001 -!***REVISION HISTORY (YYMMDD) -! 791129 DATE WRITTEN -! 890501 Modified prologue to SLATEC/LDOC format. (FNF) -! 890503 Minor cosmetic changes. (FNF) -! 930809 Renamed to allow single/double precision versions. (ACH) -! 010418 Reduced size of Common block /DLS001/. (ACH) -! 031105 Restored 'own' variables to Common block /DLS001/, to -! enable interrupt/restart feature. (ACH) -!***END PROLOGUE DSOLSY -!**End - INTEGER IWM(*) - KPP_REAL WM(*), X(*), TEM(*) - INTEGER IOWND, IOWNS, & - ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, & - LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, & - MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU - KPP_REAL ROWNS, & - CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND - COMMON /DLS001/ ROWNS(209), & - CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, & - IOWND(6), IOWNS(6), & - ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, & - LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, & - MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU - INTEGER I, MEBAND, ML, MU - KPP_REAL DI, HL0, PHL0, R -! -!***FIRST EXECUTABLE STATEMENT DSOLSY - IERSL = 0 -#ifdef FULL_ALGEBRA - CALL DGETRS ('N',N,1,WM(3),N,IWM(21),X,N,0) -#else - CALL KppSolve(WM(3),X) -#endif - RETURN -!----------------------- END OF SUBROUTINE DSOLSY ---------------------- - END SUBROUTINE DSOLSY -!DECK DSRCOM - SUBROUTINE DSRCOM (RSAV, ISAV, JOB) -!***BEGIN PROLOGUE DSRCOM -!***SUBSIDIARY -!***PURPOSE Save/restore ODEPACK COMMON blocks. -!***TYPE KPP_REAL (SSRCOM-S, DSRCOM-D) -!***AUTHOR Hindmarsh, Alan C., (LLNL) -!***DESCRIPTION -! -! This routine saves or restores (depending on JOB) the contents of -! the COMMON block DLS001, which is used internally -! by one or more ODEPACK solvers. -! -! RSAV = real array of length 218 or more. -! ISAV = integer array of length 37 or more. -! JOB = flag indicating to save or restore the COMMON blocks: -! JOB = 1 if COMMON is to be saved (written to RSAV/ISAV) -! JOB = 2 if COMMON is to be restored (read from RSAV/ISAV) -! A call with JOB = 2 presumes a prior call with JOB = 1. -! -!***SEE ALSO DLSODE -!***ROUTINES CALLED (NONE) -!***COMMON BLOCKS DLS001 -!***REVISION HISTORY (YYMMDD) -! 791129 DATE WRITTEN -! 890501 Modified prologue to SLATEC/LDOC format. (FNF) -! 890503 Minor cosmetic changes. (FNF) -! 921116 Deleted treatment of block /EH0001/. (ACH) -! 930801 Reduced Common block length by 2. (ACH) -! 930809 Renamed to allow single/double precision versions. (ACH) -! 010418 Reduced Common block length by 209+12. (ACH) -! 031105 Restored 'own' variables to Common block /DLS001/, to -! enable interrupt/restart feature. (ACH) -! 031112 Added SAVE statement for data-loaded constants. -!***END PROLOGUE DSRCOM -!**End - INTEGER ISAV(*), JOB - INTEGER ILS - INTEGER I, LENILS, LENRLS - KPP_REAL RSAV(*), RLS - SAVE LENRLS, LENILS - COMMON /DLS001/ RLS(218), ILS(37) - DATA LENRLS/218/, LENILS/37/ -! -!***FIRST EXECUTABLE STATEMENT DSRCOM - IF (JOB .EQ. 2) GO TO 100 -! - DO 10 I = 1,LENRLS - 10 RSAV(I) = RLS(I) - DO 20 I = 1,LENILS - 20 ISAV(I) = ILS(I) - RETURN -! - 100 CONTINUE - DO 110 I = 1,LENRLS - 110 RLS(I) = RSAV(I) - DO 120 I = 1,LENILS - 120 ILS(I) = ISAV(I) - RETURN -!----------------------- END OF SUBROUTINE DSRCOM ---------------------- - END SUBROUTINE DSRCOM -!DECK DSTODE - SUBROUTINE DSTODE (NEQ, Y, YH, NYH, YH1, EWT, SAVF, ACOR, & - WM, IWM, F, JAC) - !WM, IWM, F, JAC, PJAC, SLVS) -!***BEGIN PROLOGUE DSTODE -!***SUBSIDIARY -!***PURPOSE Performs one step of an ODEPACK integration. -!***TYPE KPP_REAL (SSTODE-S, DSTODE-D) -!***AUTHOR Hindmarsh, Alan C., (LLNL) -!***DESCRIPTION -! -! DSTODE performs one step of the integration of an initial value -! problem for a system of ordinary differential equations. -! Note: DSTODE is independent of the value of the iteration method -! indicator MITER, when this is .ne. 0, and hence is independent -! of the type of chord method used, or the Jacobian structure. -! Communication with DSTODE is done with the following variables: -! -! NEQ = integer array containing problem size in NEQ, and -! passed as the NEQ argument in all calls to F and JAC. -! Y = an array of length .ge. N used as the Y argument in -! all calls to F and JAC. -! YH = an NYH by LMAX array containing the dependent variables -! and their approximate scaled derivatives, where -! LMAX = MAXORD + 1. YH(i,j+1) contains the approximate -! j-th derivative of y(i), scaled by h**j/factorial(j) -! (j = 0,1,...,NQ). on entry for the first step, the first -! two columns of YH must be set from the initial values. -! NYH = a constant integer .ge. N, the first dimension of YH. -! YH1 = a one-dimensional array occupying the same space as YH. -! EWT = an array of length N containing multiplicative weights -! for local error measurements. Local errors in Y(i) are -! compared to 1.0/EWT(i) in various error tests. -! SAVF = an array of working storage, of length N. -! Also used for input of YH(*,MAXORD+2) when JSTART = -1 -! and MAXORD .lt. the current order NQ. -! ACOR = a work array of length N, used for the accumulated -! corrections. On a successful return, ACOR(i) contains -! the estimated one-step local error in Y(i). -! WM,IWM = real and integer work arrays associated with matrix -! operations in chord iteration (MITER .ne. 0). -! PJAC = name of routine to evaluate and preprocess Jacobian matrix -! and P = I - h*el0*JAC, if a chord method is being used. -! SLVS = name of routine to solve linear system in chord iteration. -! CCMAX = maximum relative change in h*el0 before PJAC is called. -! H = the step size to be attempted on the next step. -! H is altered by the error control algorithm during the -! problem. H can be either positive or negative, but its -! sign must remain constant throughout the problem. -! HMIN = the minimum absolute value of the step size h to be used. -! HMXI = inverse of the maximum absolute value of h to be used. -! HMXI = 0.0 is allowed and corresponds to an infinite hmax. -! HMIN and HMXI may be changed at any time, but will not -! take effect until the next change of h is considered. -! TN = the independent variable. TN is updated on each step taken. -! JSTART = an integer used for input only, with the following -! values and meanings: -! 0 perform the first step. -! .gt.0 take a new step continuing from the last. -! -1 take the next step with a new value of H, MAXORD, -! N, METH, MITER, and/or matrix parameters. -! -2 take the next step with a new value of H, -! but with other inputs unchanged. -! On return, JSTART is set to 1 to facilitate continuation. -! KFLAG = a completion code with the following meanings: -! 0 the step was succesful. -! -1 the requested error could not be achieved. -! -2 corrector convergence could not be achieved. -! -3 fatal error in PJAC or SLVS. -! A return with KFLAG = -1 or -2 means either -! abs(H) = HMIN or 10 consecutive failures occurred. -! On a return with KFLAG negative, the values of TN and -! the YH array are as of the beginning of the last -! step, and H is the last step size attempted. -! MAXORD = the maximum order of integration method to be allowed. -! MAXCOR = the maximum number of corrector iterations allowed. -! MSBP = maximum number of steps between PJAC calls (MITER .gt. 0). -! MXNCF = maximum number of convergence failures allowed. -! METH/MITER = the method flags. See description in driver. -! N = the number of first-order differential equations. -! The values of CCMAX, H, HMIN, HMXI, TN, JSTART, KFLAG, MAXORD, -! MAXCOR, MSBP, MXNCF, METH, MITER, and N are communicated via COMMON. -! -!***SEE ALSO DLSODE -!***ROUTINES CALLED DCFODE, DVNORM -!***COMMON BLOCKS DLS001 -!***REVISION HISTORY (YYMMDD) -! 791129 DATE WRITTEN -! 890501 Modified prologue to SLATEC/LDOC format. (FNF) -! 890503 Minor cosmetic changes. (FNF) -! 930809 Renamed to allow single/double precision versions. (ACH) -! 010418 Reduced size of Common block /DLS001/. (ACH) -! 031105 Restored 'own' variables to Common block /DLS001/, to -! enable interrupt/restart feature. (ACH) -!***END PROLOGUE DSTODE -!**End - EXTERNAL F, JAC !, PJAC, SLVS - INTEGER NEQ, NYH, IWM(*) - KPP_REAL Y(*), YH(NYH,*), YH1(*), EWT(*), SAVF(*), & - ACOR(*), WM(*) - INTEGER IOWND, IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, & - ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, & - LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, & - MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU - INTEGER I, I1, IREDO, IRET, J, JB, M, NCF, NEWQ - KPP_REAL CONIT, CRATE, EL, ELCO, HOLD, RMAX, TESCO, & - CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND - KPP_REAL DCON, DDN, DEL, DELP, DSM, DUP, EXDN, EXSM, & - EXUP,R, RH, RHDN, RHSM, RHUP, TOLD - !KPP_REAL DVNORM - COMMON /DLS001/ CONIT, CRATE, EL(13), ELCO(13,12), & - HOLD, RMAX, TESCO(3,12), & - CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, & - IOWND(6), IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, & - ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, & - LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, & - MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU -! -!***FIRST EXECUTABLE STATEMENT DSTODE - KFLAG = 0 - TOLD = TN - NCF = 0 - IERPJ = 0 - IERSL = 0 - JCUR = 0 - ICF = 0 - DELP = 0.0D0 - IF (JSTART .GT. 0) GO TO 200 - IF (JSTART .EQ. -1) GO TO 100 - IF (JSTART .EQ. -2) GO TO 160 -!----------------------------------------------------------------------- -! On the first call, the order is set to 1, and other variables are -! initialized. RMAX is the maximum ratio by which H can be increased -! in a single step. It is initially 1.E4 to compensate for the small -! initial H, but then is normally equal to 10. If a failure -! occurs (in corrector convergence or error test), RMAX is set to 2 -! for the next increase. -!----------------------------------------------------------------------- - LMAX = MAXORD + 1 - NQ = 1 - L = 2 - IALTH = 2 - RMAX = 10000.0D0 - RC = 0.0D0 - EL0 = 1.0D0 - CRATE = 0.7D0 - HOLD = H - MEO = METH - NSLP = 0 - IPUP = MITER - IRET = 3 - GO TO 140 -!----------------------------------------------------------------------- -! The following block handles preliminaries needed when JSTART = -1. -! IPUP is set to MITER to force a matrix update. -! If an order increase is about to be considered (IALTH = 1), -! IALTH is reset to 2 to postpone consideration one more step. -! If the caller has changed METH, DCFODE is called to reset -! the coefficients of the method. -! If the caller has changed MAXORD to a value less than the current -! order NQ, NQ is reduced to MAXORD, and a new H chosen accordingly. -! If H is to be changed, YH must be rescaled. -! If H or METH is being changed, IALTH is reset to L = NQ + 1 -! to prevent further changes in H for that many steps. -!----------------------------------------------------------------------- - 100 IPUP = MITER - LMAX = MAXORD + 1 - IF (IALTH .EQ. 1) IALTH = 2 - IF (METH .EQ. MEO) GO TO 110 - CALL DCFODE (METH, ELCO, TESCO) - MEO = METH - IF (NQ .GT. MAXORD) GO TO 120 - IALTH = L - IRET = 1 - GO TO 150 - 110 IF (NQ .LE. MAXORD) GO TO 160 - 120 NQ = MAXORD - L = LMAX - DO 125 I = 1,L - 125 EL(I) = ELCO(I,NQ) - NQNYH = NQ*NYH - RC = RC*EL(1)/EL0 - EL0 = EL(1) - CONIT = 0.5D0/(NQ+2) - DDN = DVNORM (N, SAVF, EWT)/TESCO(1,L) - EXDN = 1.0D0/L - RHDN = 1.0D0/(1.3D0*DDN**EXDN + 0.0000013D0) - RH = MIN(RHDN,1.0D0) - IREDO = 3 - IF (H .EQ. HOLD) GO TO 170 - RH = MIN(RH,ABS(H/HOLD)) - H = HOLD - GO TO 175 -!----------------------------------------------------------------------- -! DCFODE is called to get all the integration coefficients for the -! current METH. Then the EL vector and related constants are reset -! whenever the order NQ is changed, or at the start of the problem. -!----------------------------------------------------------------------- - 140 CALL DCFODE (METH, ELCO, TESCO) - 150 DO 155 I = 1,L - 155 EL(I) = ELCO(I,NQ) - NQNYH = NQ*NYH - RC = RC*EL(1)/EL0 - EL0 = EL(1) - CONIT = 0.5D0/(NQ+2) - GO TO (160, 170, 200), IRET -!----------------------------------------------------------------------- -! If H is being changed, the H ratio RH is checked against -! RMAX, HMIN, and HMXI, and the YH array rescaled. IALTH is set to -! L = NQ + 1 to prevent a change of H for that many steps, unless -! forced by a convergence or error test failure. -!----------------------------------------------------------------------- - 160 IF (H .EQ. HOLD) GO TO 200 - RH = H/HOLD - H = HOLD - IREDO = 3 - GO TO 175 - 170 RH = MAX(RH,HMIN/ABS(H)) - 175 RH = MIN(RH,RMAX) - RH = RH/MAX(1.0D0,ABS(H)*HMXI*RH) - R = 1.0D0 - DO 180 J = 2,L - R = R*RH - DO 180 I = 1,N - 180 YH(I,J) = YH(I,J)*R - H = H*RH - RC = RC*RH - IALTH = L - IF (IREDO .EQ. 0) GO TO 690 -!----------------------------------------------------------------------- -! This section computes the predicted values by effectively -! multiplying the YH array by the Pascal Triangle matrix. -! RC is the ratio of new to old values of the coefficient H*EL(1). -! When RC differs from 1 by more than CCMAX, IPUP is set to MITER -! to force PJAC to be called, if a Jacobian is involved. -! In any case, PJAC is called at least every MSBP steps. -!----------------------------------------------------------------------- - 200 IF (ABS(RC-1.0D0) .GT. CCMAX) IPUP = MITER - IF (NST .GE. NSLP+MSBP) IPUP = MITER - TN = TN + H - I1 = NQNYH + 1 - DO 215 JB = 1,NQ - I1 = I1 - NYH -!dir$ ivdep - DO 210 I = I1,NQNYH - 210 YH1(I) = YH1(I) + YH1(I+NYH) - 215 CONTINUE -!----------------------------------------------------------------------- -! Up to MAXCOR corrector iterations are taken. A convergence test is -! made on the R.M.S. norm of each correction, weighted by the error -! weight vector EWT. The sum of the corrections is accumulated in the -! vector ACOR(i). The YH array is not altered in the corrector loop. -!----------------------------------------------------------------------- - 220 M = 0 - DO 230 I = 1,N - 230 Y(I) = YH(I,1) - CALL F (NEQ, TN, Y, SAVF) - NFE = NFE + 1 - IF (IPUP .LE. 0) GO TO 250 -!----------------------------------------------------------------------- -! If indicated, the matrix P = I - h*el(1)*J is reevaluated and -! preprocessed before starting the corrector iteration. IPUP is set -! to 0 as an indicator that this has been done. -!----------------------------------------------------------------------- - !CALL PJAC (NEQ, Y, YH, NYH, EWT, ACOR, SAVF, WM, IWM, F, JAC) - CALL DPREPJ(NEQ, Y, YH, NYH, EWT, ACOR, SAVF, WM, IWM, F, JAC) - IPUP = 0 - RC = 1.0D0 - NSLP = NST - CRATE = 0.7D0 - IF (IERPJ .NE. 0) GO TO 430 - 250 DO 260 I = 1,N - 260 ACOR(I) = 0.0D0 - 270 IF (MITER .NE. 0) GO TO 350 -!----------------------------------------------------------------------- -! In the case of functional iteration, update Y directly from -! the result of the last function evaluation. -!----------------------------------------------------------------------- - DO 290 I = 1,N - SAVF(I) = H*SAVF(I) - YH(I,2) - 290 Y(I) = SAVF(I) - ACOR(I) - DEL = DVNORM (N, Y, EWT) - DO 300 I = 1,N - Y(I) = YH(I,1) + EL(1)*SAVF(I) - 300 ACOR(I) = SAVF(I) - GO TO 400 -!----------------------------------------------------------------------- -! In the case of the chord method, compute the corrector error, -! and solve the linear system with that as right-hand side and -! P as coefficient matrix. -!----------------------------------------------------------------------- - 350 DO 360 I = 1,N - 360 Y(I) = H*SAVF(I) - (YH(I,2) + ACOR(I)) - !CALL SLVS (WM, IWM, Y, SAVF) - CALL DSOLSY(WM, IWM, Y, SAVF) - IF (IERSL .LT. 0) GO TO 430 - IF (IERSL .GT. 0) GO TO 410 - DEL = DVNORM (N, Y, EWT) - DO 380 I = 1,N - ACOR(I) = ACOR(I) + Y(I) - 380 Y(I) = YH(I,1) + EL(1)*ACOR(I) -!----------------------------------------------------------------------- -! Test for convergence. If M.gt.0, an estimate of the convergence -! rate constant is stored in CRATE, and this is used in the test. -!----------------------------------------------------------------------- - 400 IF (M .NE. 0) CRATE = MAX(0.2D0*CRATE,DEL/DELP) - DCON = DEL*MIN(1.0D0,1.5D0*CRATE)/(TESCO(2,NQ)*CONIT) - IF (DCON .LE. 1.0D0) GO TO 450 - M = M + 1 - IF (M .EQ. MAXCOR) GO TO 410 - IF (M .GE. 2 .AND. DEL .GT. 2.0D0*DELP) GO TO 410 - DELP = DEL - CALL F (NEQ, TN, Y, SAVF) - NFE = NFE + 1 - GO TO 270 -!----------------------------------------------------------------------- -! The corrector iteration failed to converge. -! If MITER .ne. 0 and the Jacobian is out of date, PJAC is called for -! the next try. Otherwise the YH array is retracted to its values -! before prediction, and H is reduced, if possible. If H cannot be -! reduced or MXNCF failures have occurred, exit with KFLAG = -2. -!----------------------------------------------------------------------- - 410 IF (MITER .EQ. 0 .OR. JCUR .EQ. 1) GO TO 430 - ICF = 1 - IPUP = MITER - GO TO 220 - 430 ICF = 2 - NCF = NCF + 1 - RMAX = 2.0D0 - TN = TOLD - I1 = NQNYH + 1 - DO 445 JB = 1,NQ - I1 = I1 - NYH -!dir$ ivdep - DO 440 I = I1,NQNYH - 440 YH1(I) = YH1(I) - YH1(I+NYH) - 445 CONTINUE - IF (IERPJ .LT. 0 .OR. IERSL .LT. 0) GO TO 680 - IF (ABS(H) .LE. HMIN*1.00001D0) GO TO 670 - IF (NCF .EQ. MXNCF) GO TO 670 - RH = 0.25D0 - IPUP = MITER - IREDO = 1 - GO TO 170 -!----------------------------------------------------------------------- -! The corrector has converged. JCUR is set to 0 -! to signal that the Jacobian involved may need updating later. -! The local error test is made and control passes to statement 500 -! if it fails. -!----------------------------------------------------------------------- - 450 JCUR = 0 - IF (M .EQ. 0) DSM = DEL/TESCO(2,NQ) - IF (M .GT. 0) DSM = DVNORM (N, ACOR, EWT)/TESCO(2,NQ) - IF (DSM .GT. 1.0D0) GO TO 500 -!----------------------------------------------------------------------- -! After a successful step, update the YH array. -! Consider changing H if IALTH = 1. Otherwise decrease IALTH by 1. -! If IALTH is then 1 and NQ .lt. MAXORD, then ACOR is saved for -! use in a possible order increase on the next step. -! If a change in H is considered, an increase or decrease in order -! by one is considered also. A change in H is made only if it is by a -! factor of at least 1.1. If not, IALTH is set to 3 to prevent -! testing for that many steps. -!----------------------------------------------------------------------- - KFLAG = 0 - IREDO = 0 - NST = NST + 1 - HU = H - NQU = NQ - DO 470 J = 1,L - DO 470 I = 1,N - 470 YH(I,J) = YH(I,J) + EL(J)*ACOR(I) - IALTH = IALTH - 1 - IF (IALTH .EQ. 0) GO TO 520 - IF (IALTH .GT. 1) GO TO 700 - IF (L .EQ. LMAX) GO TO 700 - DO 490 I = 1,N - 490 YH(I,LMAX) = ACOR(I) - GO TO 700 -!----------------------------------------------------------------------- -! The error test failed. KFLAG keeps track of multiple failures. -! Restore TN and the YH array to their previous values, and prepare -! to try the step again. Compute the optimum step size for this or -! one lower order. After 2 or more failures, H is forced to decrease -! by a factor of 0.2 or less. -!----------------------------------------------------------------------- - 500 KFLAG = KFLAG - 1 - TN = TOLD - I1 = NQNYH + 1 - DO 515 JB = 1,NQ - I1 = I1 - NYH -!dir$ ivdep - DO 510 I = I1,NQNYH - 510 YH1(I) = YH1(I) - YH1(I+NYH) - 515 CONTINUE - RMAX = 2.0D0 - IF (ABS(H) .LE. HMIN*1.00001D0) GO TO 660 - IF (KFLAG .LE. -3) GO TO 640 - IREDO = 2 - RHUP = 0.0D0 - GO TO 540 -!----------------------------------------------------------------------- -! Regardless of the success or failure of the step, factors -! RHDN, RHSM, and RHUP are computed, by which H could be multiplied -! at order NQ - 1, order NQ, or order NQ + 1, respectively. -! In the case of failure, RHUP = 0.0 to avoid an order increase. -! The largest of these is determined and the new order chosen -! accordingly. If the order is to be increased, we compute one -! additional scaled derivative. -!----------------------------------------------------------------------- - 520 RHUP = 0.0D0 - IF (L .EQ. LMAX) GO TO 540 - DO 530 I = 1,N - 530 SAVF(I) = ACOR(I) - YH(I,LMAX) - DUP = DVNORM (N, SAVF, EWT)/TESCO(3,NQ) - EXUP = 1.0D0/(L+1) - RHUP = 1.0D0/(1.4D0*DUP**EXUP + 0.0000014D0) - 540 EXSM = 1.0D0/L - RHSM = 1.0D0/(1.2D0*DSM**EXSM + 0.0000012D0) - RHDN = 0.0D0 - IF (NQ .EQ. 1) GO TO 560 - DDN = DVNORM (N, YH(1,L), EWT)/TESCO(1,NQ) - EXDN = 1.0D0/NQ - RHDN = 1.0D0/(1.3D0*DDN**EXDN + 0.0000013D0) - 560 IF (RHSM .GE. RHUP) GO TO 570 - IF (RHUP .GT. RHDN) GO TO 590 - GO TO 580 - 570 IF (RHSM .LT. RHDN) GO TO 580 - NEWQ = NQ - RH = RHSM - GO TO 620 - 580 NEWQ = NQ - 1 - RH = RHDN - IF (KFLAG .LT. 0 .AND. RH .GT. 1.0D0) RH = 1.0D0 - GO TO 620 - 590 NEWQ = L - RH = RHUP - IF (RH .LT. 1.1D0) GO TO 610 - R = EL(L)/L - DO 600 I = 1,N - 600 YH(I,NEWQ+1) = ACOR(I)*R - GO TO 630 - 610 IALTH = 3 - GO TO 700 - 620 IF ((KFLAG .EQ. 0) .AND. (RH .LT. 1.1D0)) GO TO 610 - IF (KFLAG .LE. -2) RH = MIN(RH,0.2D0) -!----------------------------------------------------------------------- -! If there is a change of order, reset NQ, l, and the coefficients. -! In any case H is reset according to RH and the YH array is rescaled. -! Then exit from 690 if the step was OK, or redo the step otherwise. -!----------------------------------------------------------------------- - IF (NEWQ .EQ. NQ) GO TO 170 - 630 NQ = NEWQ - L = NQ + 1 - IRET = 2 - GO TO 150 -!----------------------------------------------------------------------- -! Control reaches this section if 3 or more failures have occured. -! If 10 failures have occurred, exit with KFLAG = -1. -! It is assumed that the derivatives that have accumulated in the -! YH array have errors of the wrong order. Hence the first -! derivative is recomputed, and the order is set to 1. Then -! H is reduced by a factor of 10, and the step is retried, -! until it succeeds or H reaches HMIN. -!----------------------------------------------------------------------- - 640 IF (KFLAG .EQ. -10) GO TO 660 - RH = 0.1D0 - RH = MAX(HMIN/ABS(H),RH) - H = H*RH - DO 645 I = 1,N - 645 Y(I) = YH(I,1) - CALL F (NEQ, TN, Y, SAVF) - NFE = NFE + 1 - DO 650 I = 1,N - 650 YH(I,2) = H*SAVF(I) - IPUP = MITER - IALTH = 5 - IF (NQ .EQ. 1) GO TO 200 - NQ = 1 - L = 2 - IRET = 3 - GO TO 150 -!----------------------------------------------------------------------- -! All returns are made through this section. H is saved in HOLD -! to allow the caller to change H on the next step. -!----------------------------------------------------------------------- - 660 KFLAG = -1 - GO TO 720 - 670 KFLAG = -2 - GO TO 720 - 680 KFLAG = -3 - GO TO 720 - 690 RMAX = 10.0D0 - 700 R = 1.0D0/TESCO(2,NQU) - DO 710 I = 1,N - 710 ACOR(I) = ACOR(I)*R - 720 HOLD = H - JSTART = 1 - RETURN -!----------------------- END OF SUBROUTINE DSTODE ---------------------- - END SUBROUTINE DSTODE -!DECK DEWSET - SUBROUTINE DEWSET (N, ITOL, RelTol, AbsTol, YCUR, EWT) -!***BEGIN PROLOGUE DEWSET -!***SUBSIDIARY -!***PURPOSE Set error weight vector. -!***TYPE KPP_REAL (SEWSET-S, DEWSET-D) -!***AUTHOR Hindmarsh, Alan C., (LLNL) -!***DESCRIPTION -! -! This subroutine sets the error weight vector EWT according to -! EWT(i) = RelTol(i)*ABS(YCUR(i)) + AbsTol(i), i = 1,...,N, -! with the subscript on RelTol and/or AbsTol possibly replaced by 1 above, -! depending on the value of ITOL. -! -!***SEE ALSO DLSODE -!***ROUTINES CALLED (NONE) -!***REVISION HISTORY (YYMMDD) -! 791129 DATE WRITTEN -! 890501 Modified prologue to SLATEC/LDOC format. (FNF) -! 890503 Minor cosmetic changes. (FNF) -! 930809 Renamed to allow single/double precision versions. (ACH) -!***END PROLOGUE DEWSET -!**End - INTEGER N, ITOL - INTEGER I - KPP_REAL RelTol(*), AbsTol(*), YCUR(N), EWT(N) -! -!***FIRST EXECUTABLE STATEMENT DEWSET - GO TO (10, 20, 30, 40), ITOL - 10 CONTINUE - DO 15 I = 1,N - 15 EWT(I) = RelTol(1)*ABS(YCUR(I)) + AbsTol(1) - RETURN - 20 CONTINUE - DO 25 I = 1,N - 25 EWT(I) = RelTol(1)*ABS(YCUR(I)) + AbsTol(I) - RETURN - 30 CONTINUE - DO 35 I = 1,N - 35 EWT(I) = RelTol(I)*ABS(YCUR(I)) + AbsTol(1) - RETURN - 40 CONTINUE - DO 45 I = 1,N - 45 EWT(I) = RelTol(I)*ABS(YCUR(I)) + AbsTol(I) - RETURN -!----------------------- END OF SUBROUTINE DEWSET ---------------------- - END SUBROUTINE DEWSET -!DECK DVNORM - KPP_REAL FUNCTION DVNORM (N, V, W) -!***BEGIN PROLOGUE DVNORM -!***SUBSIDIARY -!***PURPOSE Weighted root-mean-square vector norm. -!***TYPE KPP_REAL (SVNORM-S, DVNORM-D) -!***AUTHOR Hindmarsh, Alan C., (LLNL) -!***DESCRIPTION -! -! This function routine computes the weighted root-mean-square norm -! of the vector of length N contained in the array V, with weights -! contained in the array W of length N: -! DVNORM = SQRT( (1/N) * SUM( V(i)*W(i) )**2 ) -! -!***SEE ALSO DLSODE -!***ROUTINES CALLED (NONE) -!***REVISION HISTORY (YYMMDD) -! 791129 DATE WRITTEN -! 890501 Modified prologue to SLATEC/LDOC format. (FNF) -! 890503 Minor cosmetic changes. (FNF) -! 930809 Renamed to allow single/double precision versions. (ACH) -!***END PROLOGUE DVNORM -!**End - INTEGER N, I - KPP_REAL V(N), W(N), SUM -! -!***FIRST EXECUTABLE STATEMENT DVNORM - SUM = 0.0D0 - DO 10 I = 1,N - 10 SUM = SUM + (V(I)*W(I))**2 - DVNORM = SQRT(SUM/N) - RETURN -!----------------------- END OF FUNCTION DVNORM ------------------------ - END FUNCTION DVNORM -!DECK XERRWD - SUBROUTINE XERRWD (MSG, NMES, NERR, LEVEL, NI, I1, I2, NR, R1, R2) -!***BEGIN PROLOGUE XERRWD -!***SUBSIDIARY -!***PURPOSE Write error message with values. -!***CATEGORY R3C -!***TYPE KPP_REAL (XERRWV-S, XERRWD-D) -!***AUTHOR Hindmarsh, Alan C., (LLNL) -!***DESCRIPTION -! -! Subroutines XERRWD, XSETF, XSETUN, and the function routine IXSAV, -! as given here, constitute a simplified version of the SLATEC error -! handling package. -! -! All arguments are input arguments. -! -! MSG = The message (character array). -! NMES = The length of MSG (number of characters). -! NERR = The error number (not used). -! LEVEL = The error level.. -! 0 or 1 means recoverable (control returns to caller). -! 2 means fatal (run is aborted--see note below). -! NI = Number of integers (0, 1, or 2) to be printed with message. -! I1,I2 = Integers to be printed, depending on NI. -! NR = Number of reals (0, 1, or 2) to be printed with message. -! R1,R2 = Reals to be printed, depending on NR. -! -! Note.. this routine is machine-dependent and specialized for use -! in limited context, in the following ways.. -! 1. The argument MSG is assumed to be of type CHARACTER, and -! the message is printed with a format of (1X,A). -! 2. The message is assumed to take only one line. -! Multi-line messages are generated by repeated calls. -! 3. If LEVEL = 2, control passes to the statement STOP -! to abort the run. This statement may be machine-dependent. -! 4. R1 and R2 are assumed to be in double precision and are printed -! in D21.13 format. -! -!***ROUTINES CALLED IXSAV -!***REVISION HISTORY (YYMMDD) -! 920831 DATE WRITTEN -! 921118 Replaced MFLGSV/LUNSAV by IXSAV. (ACH) -! 930329 Modified prologue to SLATEC format. (FNF) -! 930407 Changed MSG from CHARACTER*1 array to variable. (FNF) -! 930922 Minor cosmetic change. (FNF) -!***END PROLOGUE XERRWD -! -!*Internal Notes: -! -! For a different default logical unit number, IXSAV (or a subsidiary -! routine that it calls) will need to be modified. -! For a different run-abort command, change the statement following -! statement 100 at the end. -!----------------------------------------------------------------------- -! Subroutines called by XERRWD.. None -! Function routine called by XERRWD.. IXSAV -!----------------------------------------------------------------------- -!**End -! -! Declare arguments. -! - KPP_REAL R1, R2 - INTEGER NMES, NERR, LEVEL, NI, I1, I2, NR - CHARACTER*(*) MSG -! -! Declare local variables. -! - INTEGER LUNIT, MESFLG !, IXSAV -! -! Get logical unit number and message print flag. -! -!***FIRST EXECUTABLE STATEMENT XERRWD - LUNIT = IXSAV (1, 0, .FALSE.) - MESFLG = IXSAV (2, 0, .FALSE.) - IF (MESFLG .EQ. 0) GO TO 100 -! -! Write the message. -! - WRITE (LUNIT,10) MSG - 10 FORMAT(1X,A) - IF (NI .EQ. 1) WRITE (LUNIT, 20) I1 - 20 FORMAT(6X,'In above message, I1 =',I10) - IF (NI .EQ. 2) WRITE (LUNIT, 30) I1,I2 - 30 FORMAT(6X,'In above message, I1 =',I10,3X,'I2 =',I10) - IF (NR .EQ. 1) WRITE (LUNIT, 40) R1 - 40 FORMAT(6X,'In above message, R1 =',D21.13) - IF (NR .EQ. 2) WRITE (LUNIT, 50) R1,R2 - 50 FORMAT(6X,'In above, R1 =',D21.13,3X,'R2 =',D21.13) -! -! Abort the run if LEVEL = 2. -! - 100 IF (LEVEL .NE. 2) RETURN - STOP -!----------------------- End of Subroutine XERRWD ---------------------- - END SUBROUTINE XERRWD -!DECK XSETF - SUBROUTINE XSETF (MFLAG) -!***BEGIN PROLOGUE XSETF -!***PURPOSE Reset the error print control flag. -!***CATEGORY R3A -!***TYPE ALL (XSETF-A) -!***KEYWORDS ERROR CONTROL -!***AUTHOR Hindmarsh, Alan C., (LLNL) -!***DESCRIPTION -! -! XSETF sets the error print control flag to MFLAG: -! MFLAG=1 means print all messages (the default). -! MFLAG=0 means no printing. -! -!***SEE ALSO XERRWD, XERRWV -!***REFERENCES (NONE) -!***ROUTINES CALLED IXSAV -!***REVISION HISTORY (YYMMDD) -! 921118 DATE WRITTEN -! 930329 Added SLATEC format prologue. (FNF) -! 930407 Corrected SEE ALSO section. (FNF) -! 930922 Made user-callable, and other cosmetic changes. (FNF) -!***END PROLOGUE XSETF -! -! Subroutines called by XSETF.. None -! Function routine called by XSETF.. IXSAV -!----------------------------------------------------------------------- -!**End - INTEGER MFLAG, JUNK !, IXSAV -! -!***FIRST EXECUTABLE STATEMENT XSETF - IF (MFLAG .EQ. 0 .OR. MFLAG .EQ. 1) JUNK = IXSAV (2,MFLAG,.TRUE.) - RETURN -!----------------------- End of Subroutine XSETF ----------------------- - END SUBROUTINE XSETF -!DECK XSETUN - SUBROUTINE XSETUN (LUN) -!***BEGIN PROLOGUE XSETUN -!***PURPOSE Reset the logical unit number for error messages. -!***CATEGORY R3B -!***TYPE ALL (XSETUN-A) -!***KEYWORDS ERROR CONTROL -!***DESCRIPTION -! -! XSETUN sets the logical unit number for error messages to LUN. -! -!***AUTHOR Hindmarsh, Alan C., (LLNL) -!***SEE ALSO XERRWD, XERRWV -!***REFERENCES (NONE) -!***ROUTINES CALLED IXSAV -!***REVISION HISTORY (YYMMDD) -! 921118 DATE WRITTEN -! 930329 Added SLATEC format prologue. (FNF) -! 930407 Corrected SEE ALSO section. (FNF) -! 930922 Made user-callable, and other cosmetic changes. (FNF) -!***END PROLOGUE XSETUN -! -! Subroutines called by XSETUN.. None -! Function routine called by XSETUN.. IXSAV -!----------------------------------------------------------------------- -!**End - INTEGER LUN, JUNK !, IXSAV -! -!***FIRST EXECUTABLE STATEMENT XSETUN - IF (LUN .GT. 0) JUNK = IXSAV (1,LUN,.TRUE.) - RETURN -!----------------------- End of Subroutine XSETUN ---------------------- - END SUBROUTINE XSETUN -!DECK IXSAV - INTEGER FUNCTION IXSAV (IPAR, IVALUE, ISET) -!***BEGIN PROLOGUE IXSAV -!***SUBSIDIARY -!***PURPOSE Save and recall error message control parameters. -!***CATEGORY R3C -!***TYPE ALL (IXSAV-A) -!***AUTHOR Hindmarsh, Alan C., (LLNL) -!***DESCRIPTION -! -! IXSAV saves and recalls one of two error message parameters: -! LUNIT, the logical unit number to which messages are printed, and -! MESFLG, the message print flag. -! This is a modification of the SLATEC library routine J4SAVE. -! -! Saved local variables.. -! LUNIT = Logical unit number for messages. The default is obtained -! by a call to IUMACH (may be machine-dependent). -! MESFLG = Print control flag.. -! 1 means print all messages (the default). -! 0 means no printing. -! -! On input.. -! IPAR = Parameter indicator (1 for LUNIT, 2 for MESFLG). -! IVALUE = The value to be set for the parameter, if ISET = .TRUE. -! ISET = Logical flag to indicate whether to read or write. -! If ISET = .TRUE., the parameter will be given -! the value IVALUE. If ISET = .FALSE., the parameter -! will be unchanged, and IVALUE is a dummy argument. -! -! On return.. -! IXSAV = The (old) value of the parameter. -! -!***SEE ALSO XERRWD, XERRWV -!***ROUTINES CALLED IUMACH -!***REVISION HISTORY (YYMMDD) -! 921118 DATE WRITTEN -! 930329 Modified prologue to SLATEC format. (FNF) -! 930915 Added IUMACH call to get default output unit. (ACH) -! 930922 Minor cosmetic changes. (FNF) -! 010425 Type declaration for IUMACH added. (ACH) -!***END PROLOGUE IXSAV -! -! Subroutines called by IXSAV.. None -! Function routine called by IXSAV.. IUMACH -!----------------------------------------------------------------------- -!**End - LOGICAL ISET - INTEGER IPAR, IVALUE -!----------------------------------------------------------------------- - INTEGER LUNIT, MESFLG!, IUMACH -!----------------------------------------------------------------------- -! The following Fortran-77 declaration is to cause the values of the -! listed (local) variables to be saved between calls to this routine. -!----------------------------------------------------------------------- - SAVE LUNIT, MESFLG - DATA LUNIT/-1/, MESFLG/1/ -! -!***FIRST EXECUTABLE STATEMENT IXSAV - IF (IPAR .EQ. 1) THEN - IF (LUNIT .EQ. -1) LUNIT = IUMACH() - IXSAV = LUNIT - IF (ISET) LUNIT = IVALUE - ENDIF -! - IF (IPAR .EQ. 2) THEN - IXSAV = MESFLG - IF (ISET) MESFLG = IVALUE - ENDIF -! - RETURN -!----------------------- End of Function IXSAV ------------------------- - END FUNCTION IXSAV -!DECK IUMACH - INTEGER FUNCTION IUMACH() -!***BEGIN PROLOGUE IUMACH -!***PURPOSE Provide standard output unit number. -!***CATEGORY R1 -!***TYPE INTEGER (IUMACH-I) -!***KEYWORDS MACHINE CONSTANTS -!***AUTHOR Hindmarsh, Alan C., (LLNL) -!***DESCRIPTION -! *Usage: -! INTEGER LOUT, IUMACH -! LOUT = IUMACH() -! -! *Function Return Values: -! LOUT : the standard logical unit for Fortran output. -! -!***REFERENCES (NONE) -!***ROUTINES CALLED (NONE) -!***REVISION HISTORY (YYMMDD) -! 930915 DATE WRITTEN -! 930922 Made user-callable, and other cosmetic changes. (FNF) -!***END PROLOGUE IUMACH -! -!*Internal Notes: -! The built-in value of 6 is standard on a wide range of Fortran -! systems. This may be machine-dependent. -!**End -!***FIRST EXECUTABLE STATEMENT IUMACH - IUMACH = 6 -! - RETURN -!----------------------- End of Function IUMACH ------------------------ - END FUNCTION IUMACH - -!---- END OF SUBROUTINE DLSODE AND ITS INTERNAL PROCEDURES - END SUBROUTINE DLSODE -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE FUN_CHEM(N, T, V, FCT) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - USE KPP_ROOT_Parameters - USE KPP_ROOT_Global - USE KPP_ROOT_Function, ONLY: Fun - USE KPP_ROOT_Rates - - IMPLICIT NONE - - INTEGER :: N - KPP_REAL :: V(NVAR), FCT(NVAR), T, TOLD - -! TOLD = TIME -! TIME = T -! CALL Update_SUN() -! CALL Update_RCONST() -! CALL Update_PHOTO() -! TIME = TOLD - - CALL Fun(V, FIX, RCONST, FCT) - - !Nfun=Nfun+1 - - END SUBROUTINE FUN_CHEM - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE JAC_CHEM (N, T, V, JF) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - USE KPP_ROOT_Parameters - USE KPP_ROOT_Global - USE KPP_ROOT_JacobianSP - USE KPP_ROOT_Jacobian, ONLY: Jac_SP - USE KPP_ROOT_Rates - - IMPLICIT NONE - - KPP_REAL :: V(NVAR), T, TOLD - INTEGER :: I, J, N, ML, MU, NROWPD -#ifdef FULL_ALGEBRA - KPP_REAL :: JV(LU_NONZERO), JF(NVAR,NVAR) -#else - KPP_REAL :: JF(LU_NONZERO) -#endif - -! TOLD = TIME -! TIME = T -! CALL Update_SUN() -! CALL Update_RCONST() -! CALL Update_PHOTO() -! TIME = TOLD - -#ifdef FULL_ALGEBRA - CALL Jac_SP(V, FIX, RCONST, JV) - DO j=1,NVAR - DO i=1,NVAR - JF(i,j) = 0.0d0 - END DO - END DO - DO i=1,LU_NONZERO - JF(LU_IROW(i),LU_ICOL(i)) = JV(i) - END DO -#else - CALL Jac_SP(V, FIX, RCONST, JF) -#endif - !Njac=Njac+1 - - END SUBROUTINE JAC_CHEM - - -END MODULE KPP_ROOT_Integrator diff --git a/boxmox/int.modified_WCOPY/kpp_radau5.f90 b/boxmox/int.modified_WCOPY/kpp_radau5.f90 deleted file mode 100644 index 876c88b5c58e0645c0ec46d0b0a3532644fab5db..0000000000000000000000000000000000000000 --- a/boxmox/int.modified_WCOPY/kpp_radau5.f90 +++ /dev/null @@ -1,1201 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! -! RADAU5 - Runge-Kutta method based on Radau-2A quadrature ! -! (2 stages, order 5) ! -! By default the code employs the KPP sparse linear algebra routines ! -! Compile with -DFULL_ALGEBRA to use full linear algebra (LAPACK) ! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! - -MODULE KPP_ROOT_Integrator - - USE KPP_ROOT_Precision, ONLY: dp - USE KPP_ROOT_Parameters, ONLY: NVAR, LU_NONZERO - USE KPP_ROOT_Jacobian, ONLY: LU_DIAG - USE KPP_ROOT_LinearAlgebra - - IMPLICIT NONE - PUBLIC - SAVE - - ! Statistics - INTEGER :: Nfun, Njac, Nstp, Nacc, Nrej, Ndec, Nsol, Nsng - - ! Method parameters - KPP_REAL :: Transf(3,3), TransfInv(3,3), & - rkA(3,3), rkB(3), rkC(3), rkE(3), & - rkGamma, rkAlpha, rkBeta - - ! description of the error numbers IERR - CHARACTER(LEN=50), PARAMETER, DIMENSION(-11:1) :: IERR_NAMES = (/ & - 'Matrix is repeatedly singular ', & ! -11 - 'Step size too small: T + 10*H = T or H < Roundoff ', & ! -10 - 'No of steps exceeds maximum bound ', & ! -9 - 'Tolerances are too small ', & ! -8 - 'Improper values for Qmin, Qmax ', & ! -7 - 'Newton stopping tolerance too small ', & ! -6 - 'Improper value for ThetaMin ', & ! -5 - 'Improper values for FacMin/FacMax/FacSafe/FacRej ', & ! -4 - 'Hmin/Hmax/Hstart must be positive ', & ! -3 - 'Improper value for maximal no of Newton iterations', & ! -2 - 'Improper value for maximal no of steps ', & ! -1 - ' ', & ! 0 (not used) - 'Success ' /) ! 1 - -CONTAINS - - ! ************************************************************************** - - SUBROUTINE INTEGRATE( TIN, TOUT, & - ICNTRL_U, RCNTRL_U, ISTATUS_U, RSTATUS_U, IERR_U ) - - USE KPP_ROOT_Parameters, ONLY: NVAR - USE KPP_ROOT_Global, ONLY: ATOL,RTOL,VAR - - IMPLICIT NONE - - KPP_REAL :: TIN ! TIN - Start Time - KPP_REAL :: TOUT ! TOUT - End Time - INTEGER, INTENT(IN), OPTIONAL :: ICNTRL_U(20) - KPP_REAL, INTENT(IN), OPTIONAL :: RCNTRL_U(20) - INTEGER, INTENT(OUT), OPTIONAL :: ISTATUS_U(20) - KPP_REAL, INTENT(OUT), OPTIONAL :: RSTATUS_U(20) - INTEGER, INTENT(OUT), OPTIONAL :: IERR_U - - KPP_REAL, SAVE :: H - INTEGER :: IERR - - KPP_REAL :: RCNTRL(20), RSTATUS(20) - INTEGER :: ICNTRL(20), ISTATUS(20) - INTEGER, SAVE :: Ntotal = 0 - - H =0.0_dp - - !~~~> fine-tune the integrator: - ICNTRL(:) = 0 - ICNTRL(2) = 0 ! 0=vector tolerances, 1=scalar tolerances - ICNTRL(5) = 8 ! Max no. of Newton iterations - ICNTRL(6) = 1 ! Starting values for Newton are interpolated (0) or zero (1) - ICNTRL(11) = 1 ! Gustaffson (1) or classic(2) controller - RCNTRL(1:20) = 0._dp - - !~~~> if optional parameters are given, and if they are >0, - ! then use them to overwrite default settings - IF (PRESENT(ICNTRL_U)) ICNTRL(1:20) = ICNTRL_U(1:20) - IF (PRESENT(RCNTRL_U)) RCNTRL(1:20) = RCNTRL_U(1:20) - - - CALL RADAU5( NVAR,TIN,TOUT,VAR,H, & - RTOL,ATOL, & - RCNTRL,ICNTRL,RSTATUS,ISTATUS,IERR ) - -!!$ Ntotal = Ntotal + Nstp -!!$ PRINT*,'NSTEPS=',Nstp,' (',Ntotal,')' - - Nfun = Nfun + ISTATUS(1) - Njac = Njac + ISTATUS(2) - Nstp = Nstp + ISTATUS(3) - Nacc = Nacc + ISTATUS(4) - Nrej = Nrej + ISTATUS(5) - Ndec = Ndec + ISTATUS(6) - Nsol = Nsol + ISTATUS(7) - Nsng = Nsng + ISTATUS(8) - - ! if optional parameters are given for output - ! use them to store information in them - IF (PRESENT(ISTATUS_U)) THEN - ISTATUS_U(:) = 0 - ISTATUS_U(1) = Nfun ! function calls - ISTATUS_U(2) = Njac ! jacobian calls - ISTATUS_U(3) = Nstp ! steps - ISTATUS_U(4) = Nacc ! accepted steps - ISTATUS_U(5) = Nrej ! rejected steps (except at the beginning) - ISTATUS_U(6) = Ndec ! LU decompositions - ISTATUS_U(7) = Nsol ! forward/backward substitutions - ENDIF - IF (PRESENT(RSTATUS_U)) THEN - RSTATUS_U(:) = 0. - RSTATUS_U(1) = TOUT ! final time - ENDIF - IF (PRESENT(IERR_U)) IERR_U = IERR - -! mz_rs_20050716: IERR is returned to the user who then decides what to do -! about it, i.e. either stop the run or ignore it. -!!$ IF (IERR < 0) THEN -!!$ PRINT *,'RADAU: Unsuccessful exit at T=', TIN,' (IERR=',IERR,')' -!!$ STOP -!!$ ENDIF - - END SUBROUTINE INTEGRATE - - SUBROUTINE RADAU5(N,T,Tend,Y,H,RelTol,AbsTol, & - RCNTRL,ICNTRL,RSTATUS,ISTATUS,IDID) - -!~~~>----------------------------------------------- -! NUMERICAL SOLUTION OF A STIFF (OR DIFFERENTIAL ALGEBRAIC) -! SYSTEM OF FirstStep 0RDER ORDINARY DIFFERENTIAL EQUATIONS -! M*Y'=F(T,Y). -! THE SYSTEM CAN BE (LINEARLY) IMPLICIT (MASS-MATRIX M /= 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. -! C.F. SECTION IV.8 -! -! AUTHORS: E. HAIRER AND G. WANNER -! UNIVERSITE DE GENEVE, DEPT. DE MATHEMATIQUES -! CH-1211 GENEVE 24, SWITZERLAND -! E-MAIL: HAIRER@DIVSUN.UNIGE.CH, WANNER@DIVSUN.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) -! -! VERSION OF SEPTEMBER 30, 1995 -! -! INPUT PARAMETERS -! ---------------- -! N DIMENSION OF THE SYSTEM -! -! FCN NAME (EXTERNAL) OF SUBROUTINE COMPUTING THE -! VALUE OF F(T,Y): -! SUBROUTINE FCN(N,T,Y,F) -! KPP_REAL T,Y(N),F(N) -! F(1)=... ETC. -! RPAR, IPAR (SEE BELOW) -! -! T INITIAL TIME VALUE -! -! Tend FINAL T-VALUE (Tend-T MAY BE POSITIVE OR NEGATIVE) -! -! Y(N) INITIAL VALUES FOR Y -! -! H INITIALL STEP SIZE GUESS; -! FOR STIFF EQUATIONS WITH INITIALL 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). -! -! RelTol,AbsTol RELATIVE AND ABSOLUTE ERROR TOLERANCES. -! for ICNTRL(2) = 0: AbsTol, RelTol are N-dimensional vectors -! = 1: AbsTol, RelTol are scalars -! -! ----- CONTINUOUS OUTPUT: ----- -! DURING CALLS TO "SOLOUT", A CONTINUOUS SOLUTION -! FOR THE INTERVAL [Told,T] 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 [Told,T]. -! DO NOT CHANGE THE ENTRIES OF CONT(LRC), IF THE -! DENSE OUTPUT FUNCTION IS USED. -!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!~~~> INPUT PARAMETERS: -! -! Note: For input parameters equal to zero the default values of the -! corresponding variables are used. -! -!~~~> Integer input parameters: -! -! ICNTRL(1) = not used -! -! ICNTRL(2) = 0: AbsTol, RelTol are NVAR-dimensional vectors -! = 1: AbsTol, RelTol are scalars -! -! ICNTRL(3) = not used -! -! ICNTRL(4) -> maximum number of integration steps -! For ICNTRL(4)=0 the default value of 10000 is used -! -! ICNTRL(5) -> maximum number of Newton iterations -! For ICNTRL(5)=0 the default value of 8 is used -! -! ICNTRL(6) -> starting values of Newton iterations: -! ICNTRL(6)=0 : starting values are obtained from -! the extrapolated collocation solution -! (the default) -! ICNTRL(6)=1 : starting values are zero -! -! ICNTRL(11) -> switch for step size strategy -! ICNTRL(8) == 1: mod. predictive controller (Gustafsson) -! ICNTRL(8) == 2: classical step size control -! the default value (for iwork(8)=0) is iwork(8)=1. -! the choice iwork(8) == 1 seems to produce safer results; -! for simple problems, the choice iwork(8) == 2 produces -! often slightly faster runs -! ( currently unused ) -! -!~~~> Real input parameters: -! -! RCNTRL(1) -> not used -! -! RCNTRL(2) -> Hmax, upper bound for the integration step size -! -! RCNTRL(3) -> not used -! -! RCNTRL(4) -> FacMin, lower bound on step decrease factor (default=0.2) -! -! RCNTRL(5) -> FacMax, upper bound on step increase factor (default=6) -! -! RCNTRL(6) -> FacRej, step decrease factor after multiple rejections -! (default=0.1) -! -! RCNTRL(7) -> FacSafe, by which the new step is slightly smaller -! than the predicted value (default=0.9) -! -! RCNTRL(8) -> ThetaMin. If Newton convergence rate smaller -! than ThetaMin the Jacobian is not recomputed; -! (default=0.001) -! -! RCNTRL(9) -> NewtonTol, stopping criterion for Newton's method -! (default=0.03) -! -! RCNTRL(10) -> Qmin -! -! RCNTRL(11) -> Qmax. If Qmin < Hnew/Hold < Qmax, then the -! step size is kept constant and the LU factorization -! reused (default Qmin=1, Qmax=1.2) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -! -! OUTPUT PARAMETERS -! ----------------- -! T T-VALUE FOR WHICH THE SOLUTION HAS BEEN COMPUTED -! (AFTER SUCCESSFUL RETURN T=Tend). -! -! Y(N) NUMERICAL SOLUTION AT T -! -! H PREDICTED STEP SIZE OF THE LastStep ACCEPTED STEP -! -! IDID REPORTS ON SUCCESSFULNESS UPON RETURN: -! -! ISTATUS(1) = No. of function calls -! ISTATUS(2) = No. of jacobian calls -! ISTATUS(3) = No. of steps -! ISTATUS(4) = No. of accepted steps -! ISTATUS(5) = No. of rejected steps (except at the beginning) -! ISTATUS(6) = No. of LU decompositions -! ISTATUS(7) = No. of forward/backward substitutions -! ISTATUS(8) = No. of singular matrix decompositions -! -! RSTATUS(1) -> Texit, the time corresponding to the -! computed Y upon return -! RSTATUS(2) -> Hexit, last accepted step before exit -! For multiple restarts, use Hexit as Hstart -! in the subsequent run -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - - INTEGER :: N - KPP_REAL :: Y(N),AbsTol(N),RelTol(N),RCNTRL(20),RSTATUS(20) - INTEGER :: ICNTRL(20), ISTATUS(20) - LOGICAL :: StartNewton, Gustafsson - INTEGER :: IDID, ITOL - KPP_REAL :: H,Tend,T - - !~~~> Control arguments - INTEGER :: Max_no_steps, NewtonMaxit - KPP_REAL :: Hstart,Hmin,Hmax,Qmin,Qmax - KPP_REAL :: Roundoff, ThetaMin,TolNewton - KPP_REAL :: FacSafe,FacMin,FacMax,FacRej - !~~~> Local variables - INTEGER :: i - KPP_REAL, PARAMETER :: ZERO = 0.0d0, ONE = 1.0d0 - - !~~~> variables from the former COMMON block /CONRA5/ - ! KPP_REAL :: Tsol, Hsol - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! SETTING THE PARAMETERS -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Nfun=0 - Njac=0 - Nstp=0 - Nacc=0 - Nrej=0 - Ndec=0 - Nsol=0 - IDID = 0 - -!~~~> ICNTRL(1) - autonomous system - not used -!~~~> ITOL: 1 for vector and 0 for scalar AbsTol/RelTol - IF (ICNTRL(2) == 0) THEN - ITOL = 1 - ELSE - ITOL = 0 - END IF -!~~~> ICNTRL(3) - method selection - not used -!~~~> Max_no_steps: the maximal number of time steps - IF (ICNTRL(4) == 0) THEN - Max_no_steps = 10000 - ELSE - Max_no_steps=ICNTRL(4) - IF (Max_no_steps <= 0) THEN - WRITE(6,*) 'ICNTRL(4)=',ICNTRL(4) - CALL RAD_ErrorMsg(-1,T,ZERO,IDID) - END IF - END IF -!~~~> NewtonMaxit MAXIMAL NUMBER OF NEWTON ITERATIONS - IF (ICNTRL(5) == 0) THEN - NewtonMaxit = 8 - ELSE - NewtonMaxit=ICNTRL(5) - IF (NewtonMaxit <= 0) THEN - WRITE(6,*) 'ICNTRL(5)=',ICNTRL(5) - CALL RAD_ErrorMsg(-2,T,ZERO,IDID) - END IF - END IF -!~~~> StartNewton: Use extrapolation for starting values of Newton iterations - IF (ICNTRL(6) == 0) THEN - StartNewton = .TRUE. - ELSE - StartNewton = .FALSE. - END IF -!~~~> Gustafsson: step size controller - IF(ICNTRL(11) == 0)THEN - Gustafsson=.TRUE. - ELSE - Gustafsson=.FALSE. - END IF - - -!~~~> Roundoff SMALLEST NUMBER SATISFYING 1.0d0+Roundoff>1.0d0 - Roundoff=WLAMCH('E'); - -!~~~> RCNTRL(1) = Hmin - not used - Hmin = ZERO -!~~~> Hmax = maximal step size - IF (RCNTRL(2) == ZERO) THEN - Hmax=Tend-T - ELSE - Hmax=MAX(ABS(RCNTRL(7)),ABS(Tend-T)) - END IF -!~~~> RCNTRL(3) = Hstart - not used - Hstart = ZERO -!~~~> FacMin: lower bound on step decrease factor - IF(RCNTRL(4) == ZERO)THEN - FacMin = 0.2d0 - ELSE - FacMin = RCNTRL(4) - END IF -!~~~> FacMax: upper bound on step increase factor - IF(RCNTRL(5) == ZERO)THEN - FacMax = 8.D0 - ELSE - FacMax = RCNTRL(5) - END IF -!~~~> FacRej: step decrease factor after 2 consecutive rejections - IF(RCNTRL(6) == ZERO)THEN - FacRej = 0.1d0 - ELSE - FacRej = RCNTRL(6) - END IF -!~~~> FacSafe: by which the new step is slightly smaller -! than the predicted value - IF (RCNTRL(7) == ZERO) THEN - FacSafe=0.9d0 - ELSE - FacSafe=RCNTRL(7) - END IF - IF ( (FacMax < ONE) .OR. (FacMin > ONE) .OR. & - (FacSafe <= 0.001D0) .OR. (FacSafe >= 1.0d0) ) THEN - WRITE(6,*)'RCNTRL(4:7)=',RCNTRL(4:7) - CALL RAD_ErrorMsg(-4,T,ZERO,IDID) - END IF - -!~~~> ThetaMin: decides whether the Jacobian should be recomputed - IF (RCNTRL(8) == ZERO) THEN - ThetaMin = 1.0d-3 - ELSE - ThetaMin=RCNTRL(8) - IF (ThetaMin <= 0.0d0 .OR. ThetaMin >= 1.0d0) THEN - WRITE(6,*) 'RCNTRL(8)=', RCNTRL(8) - CALL RAD_ErrorMsg(-5,T,ZERO,IDID) - END IF - END IF -!~~~> TolNewton: stopping crierion for Newton's method - IF (RCNTRL(9) == ZERO) THEN - TolNewton = 3.0d-2 - ELSE - TolNewton = RCNTRL(9) - IF (TolNewton <= Roundoff) THEN - WRITE(6,*) 'RCNTRL(9)=',RCNTRL(9) - CALL RAD_ErrorMsg(-6,T,ZERO,IDID) - END IF - END IF -!~~~> Qmin AND Qmax: IF Qmin < Hnew/Hold < Qmax, STEP SIZE = CONST. - IF (RCNTRL(10) == ZERO) THEN - Qmin=1.D0 - ELSE - Qmin=RCNTRL(10) - END IF - IF (RCNTRL(11) == ZERO) THEN - Qmax=1.2D0 - ELSE - Qmax=RCNTRL(11) - END IF - IF (Qmin > ONE .OR. Qmax < ONE) THEN - WRITE(6,*) 'RCNTRL(10:11)=',Qmin,Qmax - CALL RAD_ErrorMsg(-7,T,ZERO,IDID) - END IF -!~~~> Check if tolerances are reasonable - IF (ITOL == 0) THEN - IF (AbsTol(1) <= ZERO.OR.RelTol(1) <= 10.d0*Roundoff) THEN - WRITE (6,*) 'AbsTol/RelTol=',AbsTol,RelTol - CALL RAD_ErrorMsg(-8,T,ZERO,IDID) - END IF - ELSE - DO i=1,N - IF (AbsTol(i) <= ZERO.OR.RelTol(i) <= 10.d0*Roundoff) THEN - WRITE (6,*) 'AbsTol/RelTol(',i,')=',AbsTol(i),RelTol(i) - CALL RAD_ErrorMsg(-8,T,ZERO,IDID) - END IF - END DO - END IF - -!~~~> WHEN A FAIL HAS OCCURED, RETURN - IF (IDID < 0) RETURN - - -!~~~> CALL TO CORE INTEGRATOR ------------ - CALL RAD_Integrator( N,T,Y,Tend,Hmax,H,RelTol,AbsTol,ITOL,IDID, & - Max_no_steps,Roundoff,FacSafe,ThetaMin,TolNewton,Qmin,Qmax, & - NewtonMaxit,StartNewton,Gustafsson,FacMin,FacMax,FacRej ) - - ISTATUS(1)=Nfun - ISTATUS(2)=Njac - ISTATUS(3)=Nstp - ISTATUS(4)=Nacc - ISTATUS(5)=Nrej - ISTATUS(6)=Ndec - ISTATUS(7)=Nsol - ISTATUS(8)=Nsng - - ! END SUBROUTINE RADAU5 - CONTAINS ! INTERNAL PROCEDURES TO RADAU5 - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE RAD_Integrator( N,T,Y,Tend,Hmax,H,RelTol,AbsTol,ITOL,IDID, & - Max_no_steps,Roundoff,FacSafe,ThetaMin,TolNewton,Qmin,Qmax, & - NewtonMaxit,StartNewton,Gustafsson,FacMin,FacMax,FacRej ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! CORE INTEGRATOR FOR RADAU5 -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - INTEGER :: N - KPP_REAL Y(NVAR),Z1(NVAR),Z2(NVAR),Z3(NVAR),Y0(NVAR),& - SCAL(NVAR),F1(NVAR),F2(NVAR),F3(NVAR), & - CONT(N,4),AbsTol(NVAR),RelTol(NVAR) - -#ifdef FULL_ALGEBRA - KPP_REAL :: FJAC(NVAR,NVAR), E1(NVAR,NVAR) - DOUBLE COMPLEX :: E2(NVAR,NVAR) -#else - KPP_REAL :: FJAC(LU_NONZERO), E1(LU_NONZERO) - DOUBLE COMPLEX :: E2(LU_NONZERO) -#endif - - !~~~> Local variables - KPP_REAL :: TMP(NVAR), T, Tend, Tdirection, & - H, Hmax, HmaxN, Hacc, Hnew, Hopt, Hold, & - Fac, FacMin, Facmax, FacSafe, FacRej, FacGus, FacConv, & - Theta, ThetaMin, TolNewton, ERR, ERRACC, & - Qmin, Qmax, DYNO, Roundoff, & - AK, AK1, AK2, AK3, C3Q, & - Qnewton, DYTH, THQ, THQOLD, DYNOLD, & - DENOM, C1Q, C2Q, ALPHA, BETA, GAMMA, CFAC, ACONT3, QT - INTEGER :: IP1(NVAR),IP2(NVAR), ITOL, IDID, Max_no_steps, & - NewtonIter, NewtonMaxit, ISING - LOGICAL :: REJECT, FirstStep, FreshJac, LastStep, & - Gustafsson, StartNewton, NewtonDone - ! KPP_REAL, PARAMETER :: ONE = 1.0d0, ZERO = 0.0d0 - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! INITIALISATIONS -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - CALL RAD_Coefficients - - Tdirection=SIGN(1.D0,Tend-T) - HmaxN=MIN(ABS(Hmax),ABS(Tend-T)) - H=MIN(ABS(Hmin),ABS(Hstart)) - H=MIN(ABS(H),HmaxN) - IF (ABS(H) <= 10.D0*Roundoff) H=1.0D-6 - H=SIGN(H,Tdirection) - Hold=H - REJECT=.FALSE. - FirstStep=.TRUE. - LastStep=.FALSE. - FreshJac=.FALSE.; Theta=1.0d0 - IF ((T+H*1.0001D0-Tend)*Tdirection >= 0.D0) THEN - H=Tend-T - LastStep=.TRUE. - END IF - FacConv=1.D0 - CFAC=FacSafe*(1+2*NewtonMaxit) - Nsng=0 -! Told=T - CALL RAD_ErrorScale(N,ITOL,AbsTol,RelTol,Y,SCAL) - CALL FUN_CHEM(T,Y,Y0) - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Time loop begins -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Tloop: DO WHILE ( (Tend-T)*Tdirection - Roundoff > ZERO ) - - !~~~> COMPUTE JACOBIAN MATRIX ANALYTICALLY - IF ( (.NOT.FreshJac) .AND. (Theta > ThetaMin) ) THEN - CALL JAC_CHEM(T,Y,FJAC) - FreshJac=.TRUE. - END IF - - !~~~> Compute the matrices E1 and E2 and their decompositions - GAMMA = rkGamma/H - ALPHA = rkAlpha/H - BETA = rkBeta/H - CALL RAD_DecompReal(N,FJAC,GAMMA,E1,IP1,ISING) - IF (ISING /= 0) THEN - Nsng=Nsng+1 - IF (Nsng >= 5) THEN - CALL RAD_ErrorMsg(-12,T,H,IDID); RETURN - END IF - H=H*0.5D0; REJECT=.TRUE.; LastStep=.FALSE. - CYCLE Tloop - END IF - CALL RAD_DecompCmplx(N,FJAC,ALPHA,BETA,E2,IP2,ISING) - IF (ISING /= 0) THEN - Nsng=Nsng+1 - IF (Nsng >= 5) THEN - CALL RAD_ErrorMsg(-12,T,H,IDID); RETURN - END IF - H=H*0.5D0; REJECT=.TRUE.; LastStep=.FALSE. - CYCLE Tloop - END IF - - 30 CONTINUE - Nstp=Nstp+1 - IF (Nstp > Max_no_steps) THEN - PRINT*,'Max number of time steps is ',Max_no_steps - CALL RAD_ErrorMsg(-9,T,H,IDID); RETURN - END IF - IF (0.1D0*ABS(H) <= ABS(T)*Roundoff) THEN - CALL RAD_ErrorMsg(-10,T,H,IDID); RETURN - END IF - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! STARTING VALUES FOR NEWTON ITERATION -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IF ( FirstStep .OR. (.NOT.StartNewton) ) THEN - CALL Set2zero(N,Z1) - CALL Set2zero(N,Z2) - CALL Set2zero(N,Z3) - CALL Set2zero(N,F1) - CALL Set2zero(N,F2) - CALL Set2zero(N,F3) - ELSE - C3Q=H/Hold - C1Q=rkC(1)*C3Q - C2Q=rkC(2)*C3Q - DO i=1,N - AK1=CONT(i,2) - AK2=CONT(i,3) - AK3=CONT(i,4) - Z1(i)=C1Q*(AK1+(C1Q-rkC(2)+ONE)*(AK2+(C1Q-rkC(1)+ONE)*AK3)) - Z2(i)=C2Q*(AK1+(C2Q-rkC(2)+ONE)*(AK2+(C2Q-rkC(1)+ONE)*AK3)) - Z3(i)=C3Q*(AK1+(C3Q-rkC(2)+ONE)*(AK2+(C3Q-rkC(1)+ONE)*AK3)) - END DO - ! F(1,2,3) = TransfInv x Z(1,2,3) - CALL RAD_Transform(N,TransfInv,Z1,Z2,Z3,F1,F2,F3) - END IF -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! LOOP FOR THE SIMPLIFIED NEWTON ITERATION -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - FacConv = MAX(FacConv,Roundoff)**0.8D0 - Theta=ABS(ThetaMin) - -NewtonLoop:DO NewtonIter = 1, NewtonMaxit - - !~~~> The right-hand side - DO i=1,N - TMP(i)=Y(i)+Z1(i) - END DO - CALL FUN_CHEM(T+rkC(1)*H,TMP,Z1) - DO i=1,N - TMP(i)=Y(i)+Z2(i) - END DO - CALL FUN_CHEM(T+rkC(2)*H,TMP,Z2) - DO i=1,N - TMP(i)=Y(i)+Z3(i) - END DO - CALL FUN_CHEM(T+rkC(3)*H,TMP,Z3) - - !~~~> Solve the linear systems - ! Z(1,2,3) = TransfInv x Z(1,2,3) - CALL RAD_Transform(N,TransfInv,Z1,Z2,Z3,Z1,Z2,Z3) - CALL RAD_Solve( N,FJAC,GAMMA,ALPHA,BETA,E1,E2, & - Z1,Z2,Z3,F1,F2,F3,CONT,IP1,IP2,ISING ) - Nsol=Nsol+1 - - DYNO=0.0d0 - DO i=1,N - DENOM=SCAL(i) - DYNO=DYNO+(Z1(i)/DENOM)**2+(Z2(i)/DENOM)**2+(Z3(i)/DENOM)**2 - END DO - DYNO=SQRT(DYNO/(3*N)) - - !~~~> Bad convergence or number of iterations too large - IF ( (NewtonIter > 1) .AND. (NewtonIter < NewtonMaxit) ) THEN - THQ=DYNO/DYNOLD - IF (NewtonIter == 2) THEN - Theta=THQ - ELSE - Theta=SQRT(THQ*THQOLD) - END IF - THQOLD=THQ - IF (Theta < 0.99d0) THEN - FacConv=Theta/(1.0d0-Theta) - DYTH=FacConv*DYNO*Theta**(NewtonMaxit-1-NewtonIter)/TolNewton - IF (DYTH >= 1.0d0) THEN - Qnewton=MAX(1.0D-4,MIN(20.0d0,DYTH)) - FAC=.8D0*Qnewton**(-1.0d0/(4.0d0+NewtonMaxit-1-NewtonIter)) - H=FAC*H - REJECT=.TRUE. - LastStep=.FALSE. - CYCLE Tloop - END IF - ELSE ! Non-convergence of Newton - H=H*0.5D0; REJECT=.TRUE.; LastStep=.FALSE. - CYCLE Tloop - END IF - END IF - DYNOLD=MAX(DYNO,Roundoff) - CALL WAXPY(N,ONE,Z1,1,F1,1) ! F1 <- F1 + Z1 - CALL WAXPY(N,ONE,Z2,1,F2,1) ! F2 <- F2 + Z2 - CALL WAXPY(N,ONE,Z3,1,F3,1) ! F3 <- F3 + Z3 - ! Z(1,2,3) = Transf x F(1,2,3) - CALL RAD_Transform(N,Transf,F1,F2,F3,Z1,Z2,Z3) - NewtonDone = (FacConv*DYNO <= TolNewton) - IF (NewtonDone) EXIT NewtonLoop - - END DO NewtonLoop - - IF (.NOT.NewtonDone) THEN - CALL RAD_ErrorMsg(-8,T,H,IDID); - H=H*0.5D0; REJECT=.TRUE.; LastStep=.FALSE. - CYCLE Tloop - END IF - - -!~~~> ERROR ESTIMATION - CALL RAD_ErrorEstimate(N,FJAC,H,Y0,Y,T, & - E1,Z1,Z2,Z3,IP1,SCAL,ERR, & - FirstStep,REJECT,GAMMA) -!~~~> COMPUTATION OF Hnew - Fac = ERR**(-0.25d0)* & - MIN(FacSafe,(NewtonIter+2*NewtonMaxit)/CFAC) - Fac = MIN(FacMax,MAX(FacMin,Fac)) - Hnew = Fac*H - -!~~~> IS THE ERROR SMALL ENOUGH ? -accept:IF (ERR < ONE) THEN !~~~> STEP IS ACCEPTED - FirstStep=.FALSE. - Nacc=Nacc+1 - IF (Gustafsson) THEN - !~~~> Predictive controller of Gustafsson - !~~~> Currently not implemented - IF (Nacc > 1) THEN - FacGus=FacSafe*(H/Hacc)*(ERR**2/ERRACC)**(-0.25d0) - FacGus=MIN(FacMax,MAX(FacMin,FacGus)) - Fac=MIN(Fac,FacGus) - Hnew=H*Fac - END IF - Hacc=H - ERRACC=MAX(1.0D-2,ERR) - END IF - ! Told = T - Hold = H - T=T+H - DO i=1,N - Y(i)=Y(i)+Z3(i) - CONT(i,2)=(Z2(i)-Z3(i))/(rkC(2)-ONE) - AK=(Z1(i)-Z2(i))/(rkC(1)-rkC(2)) - ACONT3=Z1(i)/rkC(1) - ACONT3=(AK-ACONT3)/rkC(2) - CONT(i,3)=(AK-CONT(i,2))/(rkC(1)-ONE) - CONT(i,4)=CONT(i,3)-ACONT3 - END DO - CALL RAD_ErrorScale(N,ITOL,AbsTol,RelTol,Y,SCAL) - FreshJac=.FALSE. - IF (LastStep) THEN - H=Hopt - IDID=1 - RETURN - END IF - CALL FUN_CHEM(T,Y,Y0) - Hnew=Tdirection*MIN(ABS(Hnew),HmaxN) - Hopt=Hnew - Hopt=MIN(H,Hnew) - IF (REJECT) Hnew=Tdirection*MIN(ABS(Hnew),ABS(H)) - REJECT=.FALSE. - IF ((T+Hnew/Qmin-Tend)*Tdirection >= 0.D0) THEN - H=Tend-T - LastStep=.TRUE. - ELSE - QT=Hnew/H - IF ( (Theta<=ThetaMin) .AND. (QT>=Qmin) & - .AND. (QT<=Qmax) ) GOTO 30 - H=Hnew - END IF - CYCLE Tloop - ELSE accept !~~~> STEP IS REJECTED - REJECT=.TRUE. - LastStep=.FALSE. - IF (FirstStep) THEN - H=H*FacRej - ELSE - H=Hnew - END IF - IF (Nacc >= 1) Nrej=Nrej+1 - CYCLE Tloop - END IF accept - - - END DO Tloop - - - END SUBROUTINE RAD_Integrator - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE RAD_ErrorMsg(Code,T,H,IERR) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Handles all error messages -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - KPP_REAL, INTENT(IN) :: T, H - INTEGER, INTENT(IN) :: Code - INTEGER, INTENT(OUT) :: IERR - - IERR = Code - PRINT * , & - 'Forced exit from RADAU5 due to the following error:' - IF ((Code>=-11).AND.(Code<=-1)) THEN - PRINT *, IERR_NAMES(Code) - ELSE - PRINT *, 'Unknown Error code: ', Code - ENDIF - - PRINT *, "T=", T, "and H=", H - - END SUBROUTINE RAD_ErrorMsg - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE RAD_ErrorScale(N,ITOL,AbsTol,RelTol,Y,SCAL) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Handles all error messages -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - INTEGER, INTENT(IN) :: N, ITOL - KPP_REAL, INTENT(IN) :: AbsTol(*), RelTol(*), Y(N) - KPP_REAL, INTENT(OUT) :: SCAL(N) - INTEGER :: i - - IF (ITOL==0) THEN - DO i=1,N - SCAL(i)=AbsTol(1)+RelTol(1)*ABS(Y(i)) - END DO - ELSE - DO i=1,N - SCAL(i)=AbsTol(i)+RelTol(i)*ABS(Y(i)) - END DO - END IF - - END SUBROUTINE RAD_ErrorScale - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE RAD_Transform(N,Tr,Z1,Z2,Z3,F1,F2,F3) -!~~~> F = Tr x Z -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - INTEGER :: N, i - KPP_REAL :: Tr(3,3),Z1(N),Z2(N),Z3(N),F1(N),F2(N),F3(N) - KPP_REAL :: x1, x2, x3 - DO i=1,N - x1 = Z1(i); x2 = Z2(i); x3 = Z3(i) - F1(i) = Tr(1,1)*x1 + Tr(1,2)*x2 + Tr(1,3)*x3 - F2(i) = Tr(2,1)*x1 + Tr(2,2)*x2 + Tr(2,3)*x3 - F3(i) = Tr(3,1)*x1 + Tr(3,2)*x2 + Tr(3,3)*x3 - END DO - END SUBROUTINE RAD_Transform - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE RAD_Coefficients -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - KPP_REAL :: s2,s3,s6,x1,x2,x3,x4,y1,y2,y3,y4,y5 - - s2 = SQRT(2.0d0); - s3 = SQRT(3.0d0); - s6 = SQRT(6.0d0); - x1 = 3.d0**(1.d0/3.d0); - x2 = 3.d0**(2.d0/3.d0); - x3 = 3.d0**(1.d0/6.d0); - x4 = 3.d0**(5.d0/6.d0); - - rkA(1,1) = 11.d0/45.d0-7.d0/360.d0*s6 - rkA(1,2) = 37.d0/225.d0-169.d0/1800.d0*s6 - rkA(1,3) = -2.d0/225.d0+s6/75 - rkA(2,1) = 37.d0/225.d0+169.d0/1800.d0*s6 - rkA(2,2) = 11.d0/45.d0+7.d0/360.d0*s6 - rkA(2,3) = -2.d0/225.d0-s6/75 - rkA(3,1) = 4.d0/9.d0-s6/36 - rkA(3,2) = 4.d0/9.d0+s6/36 - rkA(3,3) = 1.d0/9.d0 - - rkB(1) = 4.d0/9.d0-s6/36 - rkB(2) = 4.d0/9.d0+s6/36 - rkB(3) = 1.d0/9.d0 - - rkC(1) = 2.d0/5.d0-s6/10 - rkC(2) = 2.d0/5.d0+s6/10 - rkC(3) = 1.d0 - - ! Error estimation - rkE(1) = -(13.d0+7.d0*s6)/3.d0 - rkE(2) = (-13.d0+7.d0*s6)/3.d0 - rkE(3) = -1.d0/3.d0 - - !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - !~~~> Diagonalize the RK matrix: - ! TransfInv * inv(rkA) * Transf = - ! | rkGamma 0 0 | - ! | 0 rkAlpha -rkBeta | - ! | 0 rkBeta rkAlpha | - !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - rkGamma = 3-x1+x2 - rkAlpha = x1/2-x2/2+3 - rkBeta = -x4/2-3.d0/2.d0*x3 - - y1 = 36.d0/625.d0*s6 - y2 = 129.d0/2500.d0*x1 - y3 = 111.d0/2500.d0*x3*s2 - Transf(1,1) = -31.d0/1250.d0*s6*x1+37.d0/1250.d0*s6*x2-y1 & - +129.d0/1250.d0*x1-33.d0/1250.d0*x2+49.d0/625.d0 - Transf(1,2) = -y1-y2-y3 & - +31.d0/2500.d0*x4*s2+33.d0/2500.d0*x2+49.d0/625.d0 - Transf(1,3) = 3.d0/2500.d0*x3*(-33-43*x2+31*x3*s2+37*s3*s2) - Transf(2,1) = 31.d0/1250.d0*s6*x1-37.d0/1250.d0*s6*x2+y1 & - +129.d0/1250.d0*x1-33.d0/1250.d0*x2+49.d0/625.d0 - Transf(2,2) = y1-y2+y3& - -31.d0/2500.d0*x4*s2+33.d0/2500.d0*x2+49.d0/625.d0 - Transf(2,3) = -3.d0/2500.d0*x3*(33+43*x2+31*x3*s2+37*s3*s2) - Transf(3,1) = 1.d0 - Transf(3,2) = 1.d0 - Transf(3,3) = 0.d0 - - y1 = 11.d0/36.d0*x3*s2 + 43.d0/108.d0*x4*s2 - y2 = 11.d0/36.d0*s2*x2 - 43.d0/36.d0*s2*x1 - y3 = 31.d0/54.d0*x1 + 37.d0/54.d0*x2 - y4 = 31.d0/54.d0*x4-37.d0/18.d0*x3 - y5 = -x2/27+5.d0/27.d0*x1 - TransfInv(1,1) = y1 + y3 - TransfInv(1,2) = -y1 + y3 - TransfInv(1,3) = y5 + 1.d0/3.d0 - TransfInv(2,1) = -y1 - y3 - TransfInv(2,2) = y1 - y3 - TransfInv(2,3) = -y5 + 2.d0/3.d0 - TransfInv(3,1) = y4 - y2 - TransfInv(3,2) = y4 + y2 - TransfInv(3,3) = x3/9+5.d0/27.d0*x4 - - END SUBROUTINE RAD_Coefficients - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE RAD_DecompReal(N,FJAC,GAMMA,E1,IP1,ISING) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - - INTEGER :: N, ISING - KPP_REAL :: GAMMA -#ifdef FULL_ALGEBRA - KPP_REAL :: FJAC(NVAR,NVAR),E1(NVAR,NVAR) -#else - KPP_REAL :: FJAC(LU_NONZERO),E1(LU_NONZERO) -#endif - INTEGER :: IP1(N), i, j - -#ifdef FULL_ALGEBRA - DO j=1,N - DO i=1,N - E1(i,j)=-FJAC(i,j) - END DO - E1(j,j)=E1(j,j)+GAMMA - END DO - CALL DGETRF(N,N,E1,N,IP1,ISING) -#else - DO i=1,LU_NONZERO - E1(i)=-FJAC(i) - END DO - DO i=1,NVAR - j = LU_DIAG(i); E1(j)=E1(j)+GAMMA - END DO - CALL KppDecomp(E1,ISING) -#endif - - END SUBROUTINE RAD_DecompReal - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE RAD_DecompCmplx(N,FJAC,ALPHA,BETA,E2,IP2,ISING) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - INTEGER :: N, ISING -#ifdef FULL_ALGEBRA - KPP_REAL :: FJAC(N,N) - DOUBLE COMPLEX :: E2(N,N) -#else - KPP_REAL :: FJAC(LU_NONZERO) - DOUBLE COMPLEX :: E2(LU_NONZERO) -#endif - KPP_REAL :: ALPHA, BETA - INTEGER :: IP2(N), i, j - -#ifdef FULL_ALGEBRA - DO j=1,N - DO i=1,N - E2(i,j) = DCMPLX( -FJAC(i,j), 0.0d0 ) - END DO - E2(j,j) = E2(j,j) + DCMPLX( ALPHA, BETA ) - END DO - CALL ZGETRF(N,N,E2,N,IP2,ISING) -#else - DO i=1,LU_NONZERO - E2(i) = DCMPLX( -FJAC(i), 0.0d0 ) - END DO - DO i=1,NVAR - j = LU_DIAG(i); E2(j)=E2(j)+DCMPLX( ALPHA, BETA ) - END DO - CALL KppDecompCmplx(E2,ISING) -#endif - Ndec=Ndec+1 - - END SUBROUTINE RAD_DecompCmplx - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE RAD_Solve(N,FJAC,GAMMA,ALPHA,BETA,E1,E2,& - Z1,Z2,Z3,F1,F2,F3,CONT,IP1,IP2,ISING) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - INTEGER :: N,IP1(NVAR),IP2(NVAR),ISING -#ifdef FULL_ALGEBRA - KPP_REAL :: FJAC(NVAR,NVAR), E1(NVAR,NVAR) - DOUBLE COMPLEX :: E2(NVAR,NVAR) -#else - KPP_REAL :: FJAC(LU_NONZERO), E1(LU_NONZERO) - DOUBLE COMPLEX :: E2(LU_NONZERO) -#endif - KPP_REAL :: Z1(N),Z2(N),Z3(N), & - F1(N),F2(N),F3(N),CONT(N), & - GAMMA,ALPHA,BETA - DOUBLE COMPLEX :: BC(N) - INTEGER :: i,j - KPP_REAL :: S2, S3 -! - DO i=1,N - S2=-F2(i) - S3=-F3(i) - Z1(i)=Z1(i)-F1(i)*GAMMA - Z2(i)=Z2(i)+S2*ALPHA-S3*BETA - Z3(i)=Z3(i)+S3*ALPHA+S2*BETA - END DO -#ifdef FULL_ALGEBRA - CALL DGETRS ('N',N,1,E1,N,IP1,Z1,N,0) -#else - CALL KppSolve (E1,Z1) -#endif - - DO j=1,N - BC(j) = DCMPLX(Z2(j),Z3(j)) - END DO -#ifdef FULL_ALGEBRA - CALL ZGETRS ('N',N,1,E2,N,IP2,BC,N,0) -#else - CALL KppSolveCmplx (E2,BC) -#endif - DO j=1,N - Z2(j) = DBLE( BC(j) ) - Z3(j) = AIMAG( BC(j) ) - END DO - - END SUBROUTINE RAD_Solve - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE RAD_ErrorEstimate(N,FJAC,H,Y0,Y,T,& - E1,Z1,Z2,Z3,IP1,SCAL,ERR, & - FirstStep,REJECT,GAMMA) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - - INTEGER :: N -#ifdef FULL_ALGEBRA - KPP_REAL :: FJAC(NVAR,NVAR), E1(NVAR,NVAR) -#else - KPP_REAL :: FJAC(LU_NONZERO), E1(LU_NONZERO) -#endif - KPP_REAL :: SCAL(N),Z1(N),Z2(N),Z3(N),F1(N),F2(N), & - Y0(N),Y(N),TMP(N),T,H,GAMMA - INTEGER :: IP1(N), i - LOGICAL FirstStep,REJECT - KPP_REAL :: HEE1,HEE2,HEE3,ERR - - HEE1 = rkE(1)/H - HEE2 = rkE(2)/H - HEE3 = rkE(3)/H - - DO i=1,N - F2(i)=HEE1*Z1(i)+HEE2*Z2(i)+HEE3*Z3(i) - TMP(i)=F2(i)+Y0(i) - END DO - -#ifdef FULL_ALGEBRA - CALL DGETRS ('N',N,1,E1,N,IP1,TMP,N,0) -#else - CALL KppSolve (E1, TMP) -#endif - - ERR=0.D0 - DO i=1,N - ERR=ERR+(TMP(i)/SCAL(i))**2 - END DO - ERR=MAX(SQRT(ERR/N),1.D-10) -! - IF (ERR < 1.D0) RETURN -firej:IF (FirstStep.OR.REJECT) THEN - DO i=1,N - TMP(i)=Y(i)+TMP(i) - END DO - CALL FUN_CHEM(T,TMP,F1) - DO i=1,N - TMP(i)=F1(i)+F2(i) - END DO - -#ifdef FULL_ALGEBRA - CALL DGETRS ('N',N,1,E1,N,IP1,TMP,N,0) -#else - CALL KppSolve (E1, TMP) -#endif - ERR=0.D0 - DO i=1,N - ERR=ERR+(TMP(i)/SCAL(i))**2 - END DO - ERR=MAX(SQRT(ERR/N),1.0d-10) - END IF firej - - END SUBROUTINE RAD_ErrorEstimate - -!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! KPP_REAL FUNCTION CONTR5(I,N,T,CONT) -!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!! THIS FUNCTION CAN BE USED FOR CONTINUOUS OUTPUT. IT PROVIDES AN -!! APPROXIMATION TO THE I-TH COMPONENT OF THE SOLUTION AT T. -!! IT GIVES THE VALUE OF THE COLLOCATION POLYNOMIAL, DEFINED FOR -!! THE STEP SUCCESSFULLY COMPUTED STEP (BY RADAU5). -!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! IMPLICIT NONE -! INTEGER :: I, N -! KPP_REAL :: T, CONT(N,4) -! KPP_REAL :: S -! KPP_REAL, PARAMETER :: ONE = 1.0d0 -! S=(T-Tsol)/Hsol -! CONTR5=CONT(i,1)+S* & -! (CONT(i,2)+(S-rkC(2)+ONE)*(CONT(i,3)+(S-rkC(1)+ONE)*CONT(i,4))) -! END FUNCTION CONTR5 - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - END SUBROUTINE RADAU5 ! AND ALL ITS INTERNAL PROCEDURES -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE FUN_CHEM(T, V, FCT) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - USE KPP_ROOT_Parameters - USE KPP_ROOT_Global - USE KPP_ROOT_Function, ONLY: Fun - USE KPP_ROOT_Rates, ONLY: Update_SUN, Update_RCONST, Update_PHOTO - - IMPLICIT NONE - - KPP_REAL :: V(NVAR), FCT(NVAR) - KPP_REAL :: T, Told - - !Told = TIME - !TIME = T - !CALL Update_SUN() - !CALL Update_RCONST() - !CALL Update_PHOTO() - !TIME = Told - - CALL Fun(V, FIX, RCONST, FCT) - - Nfun=Nfun+1 - - END SUBROUTINE FUN_CHEM - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE JAC_CHEM (T, V, JF) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - USE KPP_ROOT_Parameters - USE KPP_ROOT_Global - USE KPP_ROOT_JacobianSP - USE KPP_ROOT_Jacobian, ONLY: Jac_SP - USE KPP_ROOT_Rates, ONLY: Update_SUN, Update_RCONST, Update_PHOTO - - IMPLICIT NONE - - KPP_REAL :: V(NVAR), T, Told -#ifdef FULL_ALGEBRA - KPP_REAL :: JV(LU_NONZERO), JF(NVAR,NVAR) - INTEGER :: i, j -#else - KPP_REAL :: JF(LU_NONZERO) -#endif - - !Told = TIME - !TIME = T - !CALL Update_SUN() - !CALL Update_RCONST() - !CALL Update_PHOTO() - !TIME = Told - -#ifdef FULL_ALGEBRA - CALL Jac_SP(V, FIX, RCONST, JV) - DO j=1,NVAR - DO i=1,NVAR - JF(i,j) = 0.0d0 - END DO - END DO - DO i=1,LU_NONZERO - JF(LU_IROW(i),LU_ICOL(i)) = JV(i) - END DO -#else - CALL Jac_SP(V, FIX, RCONST, JF) -#endif - - Njac=Njac+1 - - END SUBROUTINE JAC_CHEM - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -END MODULE KPP_ROOT_Integrator diff --git a/boxmox/int.modified_WCOPY/kpp_sdirk4.f90 b/boxmox/int.modified_WCOPY/kpp_sdirk4.f90 deleted file mode 100644 index 93b37e1adf41c6f2f52f18413d2b0d502600ce79..0000000000000000000000000000000000000000 --- a/boxmox/int.modified_WCOPY/kpp_sdirk4.f90 +++ /dev/null @@ -1,972 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! -! SDIRK - Singly-Diagonally-Implicit Runge-Kutta method ! -! (L-stable, 5 stages, order 4) ! -! By default the code employs the KPP sparse linear algebra routines ! -! Compile with -DFULL_ALGEBRA to use full linear algebra (LAPACK) ! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! -! A. Sandu - version of July 10, 2005 - -MODULE KPP_ROOT_Integrator - - USE KPP_ROOT_Precision - USE KPP_ROOT_Global, ONLY: FIX, RCONST, TIME - USE KPP_ROOT_Parameters, ONLY: NVAR, NSPEC, NFIX, LU_NONZERO - USE KPP_ROOT_JacobianSP, ONLY: LU_DIAG - USE KPP_ROOT_LinearAlgebra, ONLY: KppDecomp, KppSolve, & - Set2zero, WLAMCH, WAXPY, WCOPY - - IMPLICIT NONE - PUBLIC - SAVE - - !~~~> Statistics on the work performed by the SDIRK method - INTEGER :: Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng - INTEGER, PARAMETER :: ifun=1, ijac=2, istp=3, iacc=4, & - irej=5, idec=6, isol=7, isng=8, itexit=1, ihexit=2 - ! SDIRK method coefficients - KPP_REAL :: rkAlpha(5,4), rkBeta(5,4), rkD(4,5), & - rkGamma, rkA(5,5), rkB(5), rkC(5) - - ! description of the error numbers IERR - CHARACTER(LEN=50), PARAMETER, DIMENSION(-8:1) :: IERR_NAMES = (/ & - 'Matrix is repeatedly singular ', & ! -8 - 'Step size too small: T + 10*H = T or H < Roundoff ', & ! -7 - 'No of steps exceeds maximum bound ', & ! -6 - 'Improper tolerance values ', & ! -5 - 'FacMin/FacMax/FacRej must be positive ', & ! -4 - 'Hmin/Hmax/Hstart must be positive ', & ! -3 - 'Improper value for maximal no of Newton iterations', & ! -2 - 'Improper value for maximal no of steps ', & ! -1 - ' ', & ! 0 (not used) - 'Success ' /) ! 1 - -CONTAINS - -SUBROUTINE INTEGRATE( TIN, TOUT, & - ICNTRL_U, RCNTRL_U, ISTATUS_U, RSTATUS_U, IERR_U ) - - USE KPP_ROOT_Parameters - USE KPP_ROOT_Global - IMPLICIT NONE - - KPP_REAL, INTENT(IN) :: TIN ! Start Time - KPP_REAL, INTENT(IN) :: TOUT ! End Time - ! Optional input parameters and statistics - INTEGER, INTENT(IN), OPTIONAL :: ICNTRL_U(20) - KPP_REAL, INTENT(IN), OPTIONAL :: RCNTRL_U(20) - INTEGER, INTENT(OUT), OPTIONAL :: ISTATUS_U(20) - KPP_REAL, INTENT(OUT), OPTIONAL :: RSTATUS_U(20) - INTEGER, INTENT(OUT), OPTIONAL :: IERR_U - - !INTEGER, SAVE :: Ntotal = 0 - KPP_REAL :: RCNTRL(20), RSTATUS(20) - INTEGER :: ICNTRL(20), ISTATUS(20), IERR - - ICNTRL(:) = 0 - RCNTRL(:) = 0.0_dp - ISTATUS(:) = 0 - - ! If optional parameters are given, and if they are >0, - ! then they overwrite default settings. - IF (PRESENT(ICNTRL_U)) THEN - WHERE(ICNTRL_U(:) > 0) ICNTRL(:) = ICNTRL_U(:) - END IF - IF (PRESENT(RCNTRL_U)) THEN - WHERE(RCNTRL_U(:) > 0) RCNTRL(:) = RCNTRL_U(:) - END IF - - CALL SDIRK( NVAR,TIN,TOUT,VAR,RTOL,ATOL, & - RCNTRL,ICNTRL,RSTATUS,ISTATUS,IERR ) - -! mz_rs_20050716: IERR and ISTATUS(istp) are returned to the user who then -! decides what to do about it, i.e. either stop the run or ignore it. -!!$ IF (IERR < 0) THEN -!!$ PRINT *,'SDIRK: Unsuccessful exit at T=',TIN,' (IERR=',IERR,')' -!!$ ENDIF -!!$ Ntotal = Ntotal + Nstp -!!$ PRINT*,'NSTEPS=',Nstp, '(',Ntotal,')' - - STEPMIN = RSTATUS(ihexit) ! Save last step - - ! if optional parameters are given for output they to return information - IF (PRESENT(ISTATUS_U)) ISTATUS_U(:) = ISTATUS(:) - IF (PRESENT(RSTATUS_U)) THEN - RSTATUS_U(:) = RSTATUS(:) - RSTATUS_U(1) = TOUT ! final time - END IF - IF (PRESENT(IERR_U)) IERR_U = IERR - - END SUBROUTINE INTEGRATE - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SDIRK(N, Tinitial, Tfinal, Y, RelTol, AbsTol, & - RCNTRL, ICNTRL, RSTATUS, ISTATUS, IDID) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -! Solves the system y'=F(t,y) using a Singly-Diagonally-Implicit -! Runge-Kutta (SDIRK) method. -! -! For details on SDIRK methods and their implementation consult: -! E. Hairer and G. Wanner -! "Solving ODEs II. Stiff and differential-algebraic problems". -! Springer series in computational mathematics, Springer-Verlag, 1996. -! This code is based on the SDIRK4 routine in the above book. -! -! (C) Adrian Sandu, July 2005 -! Virginia Polytechnic Institute and State University -! Contact: sandu@cs.vt.edu -! This implementation is part of KPP - the Kinetic PreProcessor -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!~~~> INPUT ARGUMENTS: -! -!- Y(NVAR) = vector of initial conditions (at T=Tinitial) -!- [Tinitial,Tfinal] = time range of integration -! (if Tinitial>Tfinal the integration is performed backwards in time) -!- RelTol, AbsTol = user precribed accuracy -!- SUBROUTINE ode_Fun( T, Y, Ydot ) = ODE function, -! returns Ydot = Y' = F(T,Y) -!- SUBROUTINE ode_Fun( T, Y, Ydot ) = Jacobian of the ODE function, -! returns Jcb = dF/dY -!- ICNTRL(1:20) = integer inputs parameters -!- RCNTRL(1:20) = real inputs parameters -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!~~~> OUTPUT ARGUMENTS: -! -!- Y(NVAR) -> vector of final states (at T->Tfinal) -!- ISTATUS(1:20) -> integer output parameters -!- RSTATUS(1:20) -> real output parameters -!- IDID -> job status upon return -! success (positive value) or -! failure (negative value) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!~~~> INPUT PARAMETERS: -! -! Note: For input parameters equal to zero the default values of the -! corresponding variables are used. -! -! Note: For input parameters equal to zero the default values of the -! corresponding variables are used. -!~~~> -! ICNTRL(1) = not used -! -! ICNTRL(2) = 0: AbsTol, RelTol are NVAR-dimensional vectors -! = 1: AbsTol, RelTol are scalars -! -! ICNTRL(3) = not used -! -! ICNTRL(4) -> maximum number of integration steps -! For ICNTRL(4)=0 the default value of 100000 is used -! -! ICNTRL(5) -> maximum number of Newton iterations -! For ICNTRL(5)=0 the default value of 8 is used -! -! ICNTRL(6) -> starting values of Newton iterations: -! ICNTRL(6)=0 : starting values are interpolated (the default) -! ICNTRL(6)=1 : starting values are zero -! -!~~~> Real parameters -! -! RCNTRL(1) -> Hmin, lower bound for the integration step size -! It is strongly recommended to keep Hmin = ZERO -! RCNTRL(2) -> Hmax, upper bound for the integration step size -! RCNTRL(3) -> Hstart, starting value for the integration step size -! -! RCNTRL(4) -> FacMin, lower bound on step decrease factor (default=0.2) -! RCNTRL(5) -> FacMax, upper bound on step increase factor (default=6) -! RCNTRL(6) -> FacRej, step decrease factor after multiple rejections -! (default=0.1) -! RCNTRL(7) -> FacSafe, by which the new step is slightly smaller -! than the predicted value (default=0.9) -! RCNTRL(8) -> ThetaMin. If Newton convergence rate smaller -! than ThetaMin the Jacobian is not recomputed; -! (default=0.001) -! RCNTRL(9) -> NewtonTol, stopping criterion for Newton's method -! (default=0.03) -! RCNTRL(10) -> Qmin -! RCNTRL(11) -> Qmax. If Qmin < Hnew/Hold < Qmax, then the -! step size is kept constant and the LU factorization -! reused (default Qmin=1, Qmax=1.2) -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!~~~> OUTPUT PARAMETERS: -! -! Note: each call to Rosenbrock adds the current no. of fcn calls -! to previous value of ISTATUS(1), and similar for the other params. -! Set ISTATUS(1:10) = 0 before call to avoid this accumulation. -! -! ISTATUS(1) = No. of function calls -! ISTATUS(2) = No. of jacobian calls -! ISTATUS(3) = No. of steps -! ISTATUS(4) = No. of accepted steps -! ISTATUS(5) = No. of rejected steps (except at the beginning) -! ISTATUS(6) = No. of LU decompositions -! ISTATUS(7) = No. of forward/backward substitutions -! ISTATUS(8) = No. of singular matrix decompositions -! -! RSTATUS(1) -> Texit, the time corresponding to the -! computed Y upon return -! RSTATUS(2) -> Hexit, last predicted step before exit -! For multiple restarts, use Hexit as Hstart in the following run -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - -! Arguments - INTEGER, INTENT(IN) :: N, ICNTRL(20) - KPP_REAL, INTENT(IN) :: Tinitial, Tfinal, & - RelTol(NVAR), AbsTol(NVAR), RCNTRL(20) - KPP_REAL, INTENT(INOUT) :: Y(NVAR) - INTEGER, INTENT(OUT) :: IDID - INTEGER, INTENT(INOUT) :: ISTATUS(20) - KPP_REAL, INTENT(OUT) :: RSTATUS(20) - -! Local variables - KPP_REAL :: Hmin, Hmax, Hstart, Roundoff, & - FacMin, Facmax, FacSafe, FacRej, & - ThetaMin, NewtonTol, Qmin, Qmax, & - Texit, Hexit - INTEGER :: ITOL, NewtonMaxit, Max_no_steps, i - KPP_REAL, PARAMETER :: ZERO = 0.0d0 - -!~~~> Initialize statistics - Nfun = ISTATUS(ifun) - Njac = ISTATUS(ijac) - Nstp = ISTATUS(istp) - Nacc = ISTATUS(iacc) - Nrej = ISTATUS(irej) - Ndec = ISTATUS(idec) - Nsol = ISTATUS(isol) - Nsng = ISTATUS(isng) -! Nfun=0; Njac=0; Nstp=0; Nacc=0 -! Nrej=0; Ndec=0; Nsol=0; Nsng=0 - - IDID = 0 - -!~~~> For Scalar tolerances (ICNTRL(2).NE.0) the code uses AbsTol(1) and RelTol(1) -! For Vector tolerances (ICNTRL(2) == 0) the code uses AbsTol(1:NVAR) and RelTol(1:NVAR) - IF (ICNTRL(2) == 0) THEN - ITOL = 1 - ELSE - ITOL = 0 - END IF - -!~~~> The maximum number of time steps admitted - IF (ICNTRL(3) == 0) THEN - Max_no_steps = 100000 - ELSEIF (Max_no_steps > 0) THEN - Max_no_steps=ICNTRL(3) - ELSE - PRINT * ,'User-selected ICNTRL(3)=',ICNTRL(3) - CALL SDIRK_ErrorMsg(-1,Tinitial,ZERO,IDID) - END IF - - -!~~~> The maximum number of Newton iterations admitted - IF(ICNTRL(4) == 0)THEN - NewtonMaxit=8 - ELSE - NewtonMaxit=ICNTRL(4) - IF(NewtonMaxit <= 0)THEN - PRINT * ,'User-selected ICNTRL(4)=',ICNTRL(4) - CALL SDIRK_ErrorMsg(-2,Tinitial,ZERO,IDID) - END IF - END IF - -!~~~> Unit roundoff (1+Roundoff>1) - Roundoff = WLAMCH('E') - -!~~~> Lower bound on the step size: (positive value) - IF (RCNTRL(1) == ZERO) THEN - Hmin = ZERO - ELSEIF (RCNTRL(1) > ZERO) THEN - Hmin = RCNTRL(1) - ELSE - PRINT * , 'User-selected RCNTRL(1)=', RCNTRL(1) - CALL SDIRK_ErrorMsg(-3,Tinitial,ZERO,IDID) - END IF - -!~~~> Upper bound on the step size: (positive value) - IF (RCNTRL(2) == ZERO) THEN - Hmax = ABS(Tfinal-Tinitial) - ELSEIF (RCNTRL(2) > ZERO) THEN - Hmax = MIN(ABS(RCNTRL(2)),ABS(Tfinal-Tinitial)) - ELSE - PRINT * , 'User-selected RCNTRL(2)=', RCNTRL(2) - CALL SDIRK_ErrorMsg(-3,Tinitial,ZERO,IDID) - END IF - -!~~~> Starting step size: (positive value) - IF (RCNTRL(3) == ZERO) THEN - Hstart = MAX(Hmin,Roundoff) - ELSEIF (RCNTRL(3) > ZERO) THEN - Hstart = MIN(ABS(RCNTRL(3)),ABS(Tfinal-Tinitial)) - ELSE - PRINT * , 'User-selected Hstart: RCNTRL(3)=', RCNTRL(3) - CALL SDIRK_ErrorMsg(-3,Tinitial,ZERO,IDID) - END IF - -!~~~> Step size can be changed s.t. FacMin < Hnew/Hexit < FacMax - IF (RCNTRL(4) == ZERO) THEN - FacMin = 0.2_dp - ELSEIF (RCNTRL(4) > ZERO) THEN - FacMin = RCNTRL(4) - ELSE - PRINT * , 'User-selected FacMin: RCNTRL(4)=', RCNTRL(4) - CALL SDIRK_ErrorMsg(-4,Tinitial,ZERO,IDID) - END IF - IF (RCNTRL(5) == ZERO) THEN - FacMax = 10.0_dp - ELSEIF (RCNTRL(5) > ZERO) THEN - FacMax = RCNTRL(5) - ELSE - PRINT * , 'User-selected FacMax: RCNTRL(5)=', RCNTRL(5) - CALL SDIRK_ErrorMsg(-4,Tinitial,ZERO,IDID) - END IF -!~~~> FacRej: Factor to decrease step after 2 succesive rejections - IF (RCNTRL(6) == ZERO) THEN - FacRej = 0.1_dp - ELSEIF (RCNTRL(6) > ZERO) THEN - FacRej = RCNTRL(6) - ELSE - PRINT * , 'User-selected FacRej: RCNTRL(6)=', RCNTRL(6) - CALL SDIRK_ErrorMsg(-4,Tinitial,ZERO,IDID) - END IF -!~~~> FacSafe: Safety Factor in the computation of new step size - IF (RCNTRL(7) == ZERO) THEN - FacSafe = 0.9_dp - ELSEIF (RCNTRL(7) > ZERO) THEN - FacSafe = RCNTRL(7) - ELSE - PRINT * , 'User-selected FacSafe: RCNTRL(7)=', RCNTRL(7) - CALL SDIRK_ErrorMsg(-4,Tinitial,ZERO,IDID) - END IF - -!~~~> DECIDES WHETHER THE JACOBIAN SHOULD BE RECOMPUTED; - IF(RCNTRL(8) == 0.D0)THEN - ThetaMin = 1.0d-3 - ELSE - ThetaMin = RCNTRL(8) - END IF - -!~~~> STOPPING CRITERION FOR NEWTON'S METHOD - IF(RCNTRL(9) == 0.0d0)THEN - NewtonTol = 3.0d-2 - ELSE - NewtonTol =RCNTRL(9) - END IF - -!~~~> Qmin AND Qmax: IF Qmin < Hnew/Hold < Qmax, STEP SIZE = CONST. - IF(RCNTRL(10) == 0.D0)THEN - Qmin=1.D0 - ELSE - Qmin=RCNTRL(10) - END IF - IF(RCNTRL(11) == 0.D0)THEN - Qmax=1.2D0 - ELSE - Qmax=RCNTRL(11) - END IF - -!~~~> Check if tolerances are reasonable - IF (ITOL == 0) THEN - IF (AbsTol(1) <= 0.D0.OR.RelTol(1) <= 10.D0*Roundoff) THEN - PRINT * , ' Scalar AbsTol = ',AbsTol(1) - PRINT * , ' Scalar RelTol = ',RelTol(1) - CALL SDIRK_ErrorMsg(-5,Tinitial,ZERO,IDID) - END IF - ELSE - DO i=1,N - IF (AbsTol(i) <= 0.D0.OR.RelTol(i) <= 10.D0*Roundoff) THEN - PRINT * , ' AbsTol(',i,') = ',AbsTol(i) - PRINT * , ' RelTol(',i,') = ',RelTol(i) - CALL SDIRK_ErrorMsg(-5,Tinitial,ZERO,IDID) - END IF - END DO - END IF - - IF (IDID < 0) RETURN - - -!~~~> CALL TO CORE INTEGRATOR - CALL SDIRK_Integrator( N,Tinitial,Tfinal,Y,Hmin,Hmax,Hstart, & - RelTol,AbsTol,ITOL, Max_no_steps, NewtonMaxit, & - Roundoff, FacMin, FacMax, FacRej, FacSafe, ThetaMin, & - NewtonTol, Qmin, Qmax, Hexit, Texit, IDID ) - -!~~~> Collect run statistics - ISTATUS(ifun) = Nfun - ISTATUS(ijac) = Njac - ISTATUS(istp) = Nstp - ISTATUS(iacc) = Nacc - ISTATUS(irej) = Nrej - ISTATUS(idec) = Ndec - ISTATUS(isol) = Nsol - ISTATUS(isng) = Nsng -!~~~> Last T and H - RSTATUS(:) = 0.0_dp - RSTATUS(itexit) = Texit - RSTATUS(ihexit) = Hexit - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - CONTAINS ! PROCEDURES INTERNAL TO SDIRK -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SDIRK_Integrator( N,Tinitial,Tfinal,Y,Hmin,Hmax,Hstart, & - RelTol,AbsTol,ITOL, Max_no_steps, NewtonMaxit, & - Roundoff, FacMin, FacMax, FacRej, FacSafe, ThetaMin, & - NewtonTol, Qmin, Qmax, Hexit, Texit, IDID ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! CORE INTEGRATOR FOR SDIRK4 -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - USE KPP_ROOT_Parameters - IMPLICIT NONE - -!~~~> Arguments: - INTEGER :: N - KPP_REAL, INTENT(INOUT) :: Y(NVAR) - KPP_REAL, INTENT(IN) :: Tinitial, Tfinal, Hmin, Hmax, Hstart, & - RelTol(NVAR), AbsTol(NVAR), Roundoff, & - FacMin, FacMax, FacRej, FacSafe, ThetaMin, & - NewtonTol, Qmin, Qmax - KPP_REAL, INTENT(OUT) :: Hexit, Texit - INTEGER, INTENT(IN) :: ITOL, Max_no_steps, NewtonMaxit - INTEGER, INTENT(OUT) :: IDID - -!~~~> Local variables: - KPP_REAL :: Z(NVAR,5), FV(NVAR,5), CONT(NVAR,4), & - NewtonFactor(5), SCAL(NVAR), RHS(NVAR), & - G(NVAR), Yhat(NVAR), TMP(NVAR), & - T, H, Hold, Theta, Hratio, Hmax1, W, & - HGammaInv, DYTH, QNEWT, ERR, Fac, Hnew, & - Tdirection, NewtonErr, NewtonErrOld - INTEGER :: i, j, IER, istage, NewtonIter, IP(NVAR) - LOGICAL :: Reject, FIRST, NewtonReject, FreshJac, SkipJacUpdate, SkipLU - -#ifdef FULL_ALGEBRA - KPP_REAL FJAC(NVAR,NVAR), E(NVAR,NVAR) -#else - KPP_REAL FJAC(LU_NONZERO), E(LU_NONZERO) -#endif - KPP_REAL, PARAMETER :: ZERO = 0.0d0, ONE = 1.0d0 - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! INITIALISATIONS -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - CALL SDIRK_Coefficients - T = Tinitial - Tdirection = SIGN(1.D0,Tfinal-Tinitial) - Hmax1=MIN(ABS(Hmax),ABS(Tfinal-Tinitial)) - H = MAX(ABS(Hmin),ABS(Hstart)) - IF (ABS(H) <= 10.D0*Roundoff) H=1.0D-6 - H=MIN(ABS(H),Hmax1) - H=SIGN(H,Tdirection) - Hold=H - NewtonReject=.FALSE. - SkipLU =.FALSE. - FreshJac = .FALSE. - SkipJacUpdate = .FALSE. - Reject=.FALSE. - FIRST=.TRUE. - NewtonFactor(1:5)=ONE - - CALL SDIRK_ErrorScale(ITOL, AbsTol, RelTol, Y, SCAL) - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Time loop begins -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Tloop: DO WHILE ( (Tfinal-T)*Tdirection - Roundoff > ZERO ) - - -!~~~> Compute E = 1/(h*gamma)-Jac and its LU decomposition - IF ( SkipLU ) THEN ! This time around skip the Jac update and LU - SkipLU = .FALSE.; FreshJac = .FALSE.; SkipJacUpdate = .FALSE. - ELSE - CALL SDIRK_PrepareMatrix ( H, T, Y, FJAC, & - FreshJac, SkipJacUpdate, E, IP, Reject, IER ) - IF (IER /= 0) THEN - CALL SDIRK_ErrorMsg(-8,T,H,IDID); RETURN - END IF - END IF - - IF (Nstp>Max_no_steps) THEN - CALL SDIRK_ErrorMsg(-6,T,H,IDID); RETURN - END IF - IF ( (T+0.1d0*H == T) .OR. (ABS(H) <= Roundoff) ) THEN - CALL SDIRK_ErrorMsg(-7,T,H,IDID); RETURN - END IF - - HGammaInv = ONE/(H*rkGamma) - -!~~~> NEWTON ITERATION -stages:DO istage=1,5 - - NewtonFactor(istage) = MAX(NewtonFactor(istage),Roundoff)**0.8d0 - -!~~~> STARTING VALUES FOR NEWTON ITERATION - CALL Set2zero(N,G) - CALL Set2zero(N,Z(1,istage)) - IF (istage==1) THEN - IF (FIRST.OR.NewtonReject) THEN - CALL Set2zero(N,Z(1,istage)) - ELSE - W=ONE+rkGamma*H/Hold - DO i=1,N - Z(i,istage)=W*(CONT(i,1)+W*(CONT(i,2)+W*(CONT(i,3)+W*CONT(i,4))))-Yhat(i) - END DO - END IF - ELSE - DO j = 1, istage-1 - ! Gj(:) = sum_j Beta(i,j)*Zj(:) = H * sum_j A(i,j)*Fun(Zj(:)) - CALL WAXPY(N,rkBeta(istage,j),Z(1,j),1,G,1) - ! CALL WAXPY(N,H*rkA(istage,j),FV(1,j),1,G,1) - ! Zi(:) = sum_j Alpha(i,j)*Zj(:) - CALL WAXPY(N,rkAlpha(istage,j),Z(1,j),1,Z(1,istage),1) - END DO - IF (istage==5) CALL WCOPY(N,Z(1,istage),1,Yhat,1) ! Yhat(:) <- Z5(:) - END IF - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! LOOP FOR THE SIMPLIFIED NEWTON ITERATION -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - NewtonIter=0 - Theta=ABS(ThetaMin) - IF (Reject) Theta=2*ABS(ThetaMin) - NewtonErr = 1.0e+6 ! To force-enter Newton loop - - Newton: DO WHILE (NewtonFactor(istage)*NewtonErr > NewtonTol) - - IF (NewtonIter >= NewtonMaxit) THEN - H=H*0.5d0 - Reject=.TRUE. - NewtonReject=.TRUE. - CYCLE Tloop - END IF - NewtonIter=NewtonIter+1 - -!~~~> COMPUTE THE RIGHT-HAND SIDE - TMP(1:N) = Y(1:N) + Z(1:N,istage) - CALL FUN_CHEM(T+rkC(istage)*H,TMP,RHS) - TMP(1:N) = G(1:N) - Z(1:N,istage) - CALL WAXPY(N,HGammaInv,TMP,1,RHS,1) ! RHS(:) <- RHS(:) + HGammaInv*(G(:)-Z(:)) - -!~~~> SOLVE THE LINEAR SYSTEMS -#ifdef FULL_ALGEBRA - CALL DGETRS( 'N', N, 1, E, N, IP, RHS, N, IER ) -#else - CALL KppSolve(E, RHS) -#endif - Nsol=Nsol+1 - -!~~~> CHECK CONVERGENCE OR IF NUMBER OF ITERATIONS TOO LARGE - CALL SDIRK_ErrorNorm(N, RHS, SCAL, NewtonErr) - IF ( (NewtonIter >= 2) .AND. (NewtonIter < NewtonMaxit) ) THEN - Theta = NewtonErr/NewtonErrOld - IF (Theta < 0.99d0) THEN - NewtonFactor(istage)=Theta/(ONE-Theta) - DYTH = NewtonFactor(istage)*NewtonErr* & - Theta**(NewtonMaxit-1-NewtonIter) - QNEWT = MAX(1.0d-4,MIN(16.0d0,DYTH/NewtonTol)) - IF (QNEWT >= ONE) THEN - H=.8D0*H*QNEWT**(-ONE/(NewtonMaxit-NewtonIter)) - Reject=.TRUE. - NewtonReject=.TRUE. - CYCLE Tloop ! go back to the beginning of DO step - END IF - ELSE - NewtonReject=.TRUE. - H=H*0.5d0 - Reject=.TRUE. - CYCLE Tloop ! go back to the beginning of DO step - END IF - END IF - NewtonErrOld = NewtonErr - CALL WAXPY(N,ONE,RHS,1,Z(1,istage),1) ! Z(:) <-- Z(:)+RHS(:) - - END DO Newton - -!~~> END OF SIMPLIFIED NEWTON ITERATION - ! Save function values - TMP(1:N) = Y(1:N) + Z(1:N,istage) - CALL FUN_CHEM(T+rkC(istage)*H,TMP,FV(1,istage)) - - END DO stages - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! ERROR ESTIMATION -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Nstp=Nstp+1 - TMP(1:N)=HGammaInv*(Z(1:N,5)-Yhat(1:N)) - -#ifdef FULL_ALGEBRA - CALL DGETRS( 'N', N, 1, E, N, IP, TMP, N, IER ) -#else - CALL KppSolve(E, TMP) -#endif - - CALL SDIRK_ErrorNorm(N, TMP, SCAL, ERR) - -!~~~> COMPUTATION OF Hnew: WE REQUIRE FacMin <= Hnew/H <= FacMax - !Safe = FacSafe*DBLE(1+2*NewtonMaxit)/DBLE(NewtonIter+2*NewtonMaxit) - Fac = MAX(FacMin,MIN(FacMax,(ERR)**(-0.25d0)*FacSafe)) - Hnew = H*Fac - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! ACCEPT/Reject STEP -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -accept: IF ( ERR < ONE ) THEN !~~~> STEP IS ACCEPTED - - FIRST=.FALSE. - Nacc=Nacc+1 - Hold=H - -!~~~> COEFFICIENTS FOR CONTINUOUS SOLUTION - CALL WAXPY(N,ONE,Z(1,5),1,Y,1) ! Y(:) <-- Y(:)+Z5(:) - CALL WCOPY(N,Z(1,5),1,Yhat,1) ! Yhat <-- Z5 - - DO i=1,4 ! CONTi <-- Sum_j rkD(i,j)*Zj - CALL Set2zero(N,CONT(1,i)) - DO j = 1,5 - CALL WAXPY(N,rkD(i,j),Z(1,j),1,CONT(1,i),1) - END DO - END DO - - CALL SDIRK_ErrorScale(ITOL, AbsTol, RelTol, Y, SCAL) - - T=T+H - FreshJac=.FALSE. - - Hnew = Tdirection*MIN(ABS(Hnew),Hmax1) - Hexit = Hnew - IF (Reject) Hnew=Tdirection*MIN(ABS(Hnew),ABS(H)) - Reject = .FALSE. - NewtonReject = .FALSE. - IF ((T+Hnew/Qmin-Tfinal)*Tdirection > 0.D0) THEN - H = Tfinal-T - ELSE - Hratio=Hnew/H - ! If step not changed too much, keep it as is; - ! do not update Jacobian and reuse LU - IF ( (Theta <= ThetaMin) .AND. (Hratio >= Qmin) & - .AND. (Hratio <= Qmax) ) THEN - SkipJacUpdate = .TRUE. - SkipLU = .TRUE. - ELSE - H = Hnew - END IF - END IF - ! If convergence is fast enough, do not update Jacobian - IF (Theta <= ThetaMin) SkipJacUpdate = .TRUE. - - ELSE accept !~~~> STEP IS REJECTED - - Reject=.TRUE. - IF (FIRST) THEN - H=H*FacRej - ELSE - H=Hnew - END IF - IF (Nacc >= 1) Nrej=Nrej+1 - - END IF accept - - END DO Tloop - - ! Successful return - Texit = T - IDID = 1 - - END SUBROUTINE SDIRK_Integrator - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SDIRK_ErrorScale(ITOL, AbsTol, RelTol, Y, SCAL) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - INTEGER :: i, ITOL - KPP_REAL :: AbsTol(NVAR), RelTol(NVAR), & - Y(NVAR), SCAL(NVAR) - IF (ITOL == 0) THEN - DO i=1,NVAR - SCAL(i) = 1.0d0 / ( AbsTol(1)+RelTol(1)*ABS(Y(i)) ) - END DO - ELSE - DO i=1,NVAR - SCAL(i) = 1.0d0 / ( AbsTol(i)+RelTol(i)*ABS(Y(i)) ) - END DO - END IF - END SUBROUTINE SDIRK_ErrorScale - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SDIRK_ErrorNorm(N, Y, SCAL, ERR) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! - INTEGER :: i, N - KPP_REAL :: Y(N), SCAL(N), ERR - ERR=0.0d0 - DO i=1,N - ERR = ERR+(Y(i)*SCAL(i))**2 - END DO - ERR = MAX( SQRT(ERR/DBLE(N)), 1.0d-10 ) -! - END SUBROUTINE SDIRK_ErrorNorm - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SDIRK_ErrorMsg(Code,T,H,IERR) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Handles all error messages -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - KPP_REAL, INTENT(IN) :: T, H - INTEGER, INTENT(IN) :: Code - INTEGER, INTENT(OUT) :: IERR - - IERR = Code - PRINT * , & - 'Forced exit from SDIRK due to the following error:' - IF ((Code>=-8).AND.(Code<=-1)) THEN - PRINT *, IERR_NAMES(Code) - ELSE - PRINT *, 'Unknown Error code: ', Code - ENDIF - - PRINT *, "T=", T, "and H=", H - - END SUBROUTINE SDIRK_ErrorMsg - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SDIRK_PrepareMatrix ( H, T, Y, FJAC, & - FreshJac, SkipJacUpdate, E, IP, Reject, IER ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! - IMPLICIT NONE - - KPP_REAL, INTENT(INOUT) :: H - KPP_REAL, INTENT(IN) :: T, Y(NVAR) - LOGICAL, INTENT(INOUT) :: FreshJac, SkipJacUpdate - INTEGER, INTENT(OUT) :: IER, IP(NVAR) - LOGICAL, INTENT(INOUT) :: Reject -#ifdef FULL_ALGEBRA - KPP_REAL, INTENT(INOUT) :: FJAC(NVAR,NVAR) - KPP_REAL, INTENT(OUT) :: E(NVAR,NVAR) -#else - KPP_REAL, INTENT(INOUT) :: FJAC(LU_NONZERO) - KPP_REAL, INTENT(OUT) :: E(LU_NONZERO) -#endif - KPP_REAL :: HGammaInv - INTEGER :: i, j, ConsecutiveSng - KPP_REAL, PARAMETER :: ONE = 1.0d0 - - 20 CONTINUE - -!~~~> COMPUTE THE JACOBIAN - IF (SkipJacUpdate) THEN - SkipJacUpdate = .FALSE. - ELSE IF ( .NOT.FreshJac ) THEN - CALL JAC_CHEM( T, Y, FJAC ) - FreshJac = .TRUE. - END IF - -!~~~> Compute the matrix E = 1/(H*GAMMA)*Jac, and its decomposition - ConsecutiveSng = 0 - IER = 1 - -Hloop: DO WHILE (IER /= 0) - - HGammaInv = ONE/(H*rkGamma) - -#ifdef FULL_ALGEBRA - DO j=1,NVAR - DO i=1,NVAR - E(i,j)=-FJAC(i,j) - END DO - E(j,j)=E(j,j)+HGammaInv - END DO - CALL DGETRF( NVAR, NVAR, E, NVAR, IP, IER ) -#else - DO i = 1,LU_NONZERO - E(i) = -FJAC(i) - END DO - DO i = 1,NVAR - j = LU_DIAG(i); E(j) = E(j) + HGammaInv - END DO - CALL KppDecomp ( E, IER) - IP(1) = 1 -#endif - Ndec=Ndec+1 - - IF (IER /= 0) THEN - WRITE (6,*) ' MATRIX IS SINGULAR, IER=',IER,' T=',T,' H=',H - Nsng = Nsng+1; ConsecutiveSng = ConsecutiveSng + 1 - IF (ConsecutiveSng >= 6) RETURN ! Failure - H=H*0.5d0 - Reject=.TRUE. - !~~~> Update Jacobian if not fresh - IF ( .NOT.FreshJac ) GOTO 20 - END IF - - END DO Hloop - - END SUBROUTINE SDIRK_PrepareMatrix - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SDIRK_Coefficients -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - rkGamma=4.0d0/15.0d0 - - rkA(1,1)= 4.d0/15.d0 - rkA(2,1)= 1.d0/2.d0 - rkA(2,2)= 4.d0/15.d0 - rkA(3,1)= 51069.d0/144200.d0 - rkA(3,2)=-7809.d0/144200.d0 - rkA(3,3)= 4.d0/15.d0 - rkA(4,1)= 12047244770625658.d0/141474406359725325.d0 - rkA(4,2)=-3057890203562191.d0/47158135453241775.d0 - rkA(4,3)= 2239631894905804.d0/28294881271945065.d0 - rkA(4,4)= 4.d0/15.d0 - rkA(5,1)= 181513.d0/86430.d0 - rkA(5,2)=-89074.d0/116015.d0 - rkA(5,3)= 83636.d0/34851.d0 - rkA(5,4)=-69863904375173.d0/23297141763930.d0 - rkA(5,5)= 4.d0/15.d0 - - rkB(1)= 181513.d0/86430.d0 - rkB(2)=-89074.d0/116015.d0 - rkB(3)= 83636.d0/34851.d0 - rkB(4)=-69863904375173.d0/23297141763930.d0 - rkB(5)= 4/15.d0 - - rkC(1)=4.d0/15.d0 - rkC(2)=23.d0/30.d0 - rkC(3)=17.d0/30.d0 - rkC(4)=707.d0/1931.d0 - rkC(5)=1.d0 - - rkBeta(2,1)=15.0d0/8.0d0 - rkBeta(3,1)=1577061.0d0/922880.0d0 - rkBeta(3,2)=-23427.0d0/115360.0d0 - rkBeta(4,1)=647163682356923881.0d0/2414496535205978880.0d0 - rkBeta(4,2)=-593512117011179.0d0/3245291041943520.0d0 - rkBeta(4,3)=559907973726451.0d0/1886325418129671.0d0 - rkBeta(5,1)=724545451.0d0/796538880.0d0 - rkBeta(5,2)=-830832077.0d0/267298560.0d0 - rkBeta(5,3)=30957577.0d0/2509272.0d0 - rkBeta(5,4)=-69863904375173.0d0/6212571137048.0d0 - - rkAlpha(2,1)= 23.d0/8.d0 - rkAlpha(3,1)= 0.9838473040915402d0 - rkAlpha(3,2)= 0.3969226768377252d0 - rkAlpha(4,1)= 0.6563374010466914d0 - rkAlpha(4,2)= 0.0d0 - rkAlpha(4,3)= 0.3372498196189311d0 - rkAlpha(5,1)=7752107607.0d0/11393456128.0d0 - rkAlpha(5,2)=-17881415427.0d0/11470078208.0d0 - rkAlpha(5,3)=2433277665.0d0/179459416.0d0 - rkAlpha(5,4)=-96203066666797.0d0/6212571137048.0d0 - - rkD(1,1)= 24.74416644927758d0 - rkD(1,2)= -4.325375951824688d0 - rkD(1,3)= 41.39683763286316d0 - rkD(1,4)= -61.04144619901784d0 - rkD(1,5)= -3.391332232917013d0 - rkD(2,1)= -51.98245719616925d0 - rkD(2,2)= 10.52501981094525d0 - rkD(2,3)= -154.2067922191855d0 - rkD(2,4)= 214.3082125319825d0 - rkD(2,5)= 14.71166018088679d0 - rkD(3,1)= 33.14347947522142d0 - rkD(3,2)= -19.72986789558523d0 - rkD(3,3)= 230.4878502285804d0 - rkD(3,4)= -287.6629744338197d0 - rkD(3,5)= -18.99932366302254d0 - rkD(4,1)= -5.905188728329743d0 - rkD(4,2)= 13.53022403646467d0 - rkD(4,3)= -117.6778956422581d0 - rkD(4,4)= 134.3962081008550d0 - rkD(4,5)= 8.678995715052762d0 - - END SUBROUTINE SDIRK_Coefficients - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - END SUBROUTINE SDIRK ! AND ALL ITS INTERNAL PROCEDURES -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE FUN_CHEM( T, Y, P ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - USE KPP_ROOT_Parameters, ONLY: NVAR, LU_NONZERO - USE KPP_ROOT_Global, ONLY: TIME, FIX, RCONST - USE KPP_ROOT_Function - USE KPP_ROOT_Rates, ONLY: Update_SUN, Update_RCONST - - INTEGER N - KPP_REAL T, Told - KPP_REAL Y(NVAR), P(NVAR) - - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - - CALL Fun( Y, FIX, RCONST, P ) - - TIME = Told - Nfun=Nfun+1 - - END SUBROUTINE FUN_CHEM - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE JAC_CHEM( T, Y, JV ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - USE KPP_ROOT_Parameters, ONLY: NVAR, LU_NONZERO - USE KPP_ROOT_Global, ONLY: TIME, FIX, RCONST - USE KPP_ROOT_Jacobian - USE KPP_ROOT_Rates, ONLY: Update_SUN, Update_RCONST - - INTEGER N - KPP_REAL T, Told - KPP_REAL Y(NVAR) -#ifdef FULL_ALGEBRA - KPP_REAL :: JS(LU_NONZERO), JV(NVAR,NVAR) - INTEGER :: i, j -#else - KPP_REAL :: JV(LU_NONZERO) -#endif - - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - -#ifdef FULL_ALGEBRA - CALL Jac_SP(Y, FIX, RCONST, JS) - DO j=1,NVAR - DO j=1,NVAR - JV(i,j) = 0.0D0 - END DO - END DO - DO i=1,LU_NONZERO - JV(LU_IROW(i),LU_ICOL(i)) = JS(i) - END DO -#else - CALL Jac_SP(Y, FIX, RCONST, JV) -#endif - TIME = Told - Njac = Njac+1 - - END SUBROUTINE JAC_CHEM - -END MODULE KPP_ROOT_Integrator diff --git a/boxmox/int.modified_WCOPY/rosenbrock.f90 b/boxmox/int.modified_WCOPY/rosenbrock.f90 deleted file mode 100644 index 98434632f12e1b4d2c26d1477973f1e018f888d3..0000000000000000000000000000000000000000 --- a/boxmox/int.modified_WCOPY/rosenbrock.f90 +++ /dev/null @@ -1,1308 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! -! Rosenbrock - Implementation of several Rosenbrock methods: ! -! * Ros2 ! -! * Ros3 ! -! * Ros4 ! -! * Rodas3 ! -! * Rodas4 ! -! By default the code employs the KPP sparse linear algebra routines ! -! Compile with -DFULL_ALGEBRA to use full linear algebra (LAPACK) ! -! ! -! (C) Adrian Sandu, August 2004 ! -! Virginia Polytechnic Institute and State University ! -! Contact: sandu@cs.vt.edu ! -! Revised by Philipp Miehe and Adrian Sandu, May 2006 ! ! -! This implementation is part of KPP - the Kinetic PreProcessor ! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! - -MODULE KPP_ROOT_Integrator - - USE KPP_ROOT_Parameters, ONLY: NVAR, NFIX, NSPEC, LU_NONZERO - USE KPP_ROOT_Global - IMPLICIT NONE - PUBLIC - SAVE - -!~~~> Statistics on the work performed by the Rosenbrock method - INTEGER, PARAMETER :: Nfun=1, Njac=2, Nstp=3, Nacc=4, & - Nrej=5, Ndec=6, Nsol=7, Nsng=8, & - Ntexit=1, Nhexit=2, Nhnew = 3 - -CONTAINS - -SUBROUTINE INTEGRATE( TIN, TOUT, & - ICNTRL_U, RCNTRL_U, ISTATUS_U, RSTATUS_U, IERR_U ) - - IMPLICIT NONE - - KPP_REAL, INTENT(IN) :: TIN ! Start Time - KPP_REAL, INTENT(IN) :: TOUT ! End Time - ! Optional input parameters and statistics - INTEGER, INTENT(IN), OPTIONAL :: ICNTRL_U(20) - KPP_REAL, INTENT(IN), OPTIONAL :: RCNTRL_U(20) - INTEGER, INTENT(OUT), OPTIONAL :: ISTATUS_U(20) - KPP_REAL, INTENT(OUT), OPTIONAL :: RSTATUS_U(20) - INTEGER, INTENT(OUT), OPTIONAL :: IERR_U - - KPP_REAL :: RCNTRL(20), RSTATUS(20) - INTEGER :: ICNTRL(20), ISTATUS(20), IERR - - INTEGER, SAVE :: Ntotal = 0 - - ICNTRL(:) = 0 - RCNTRL(:) = 0.0_dp - ISTATUS(:) = 0 - RSTATUS(:) = 0.0_dp - - !~~~> fine-tune the integrator: - ICNTRL(1) = 0 ! 0 - non-autonomous, 1 - autonomous - ICNTRL(2) = 0 ! 0 - vector tolerances, 1 - scalars - - ! If optional parameters are given, and if they are >0, - ! then they overwrite default settings. - IF (PRESENT(ICNTRL_U)) THEN - WHERE(ICNTRL_U(:) > 0) ICNTRL(:) = ICNTRL_U(:) - END IF - IF (PRESENT(RCNTRL_U)) THEN - WHERE(RCNTRL_U(:) > 0) RCNTRL(:) = RCNTRL_U(:) - END IF - - - CALL Rosenbrock(NVAR,VAR,TIN,TOUT, & - ATOL,RTOL, & - RCNTRL,ICNTRL,RSTATUS,ISTATUS,IERR) - - !~~~> Debug option: show no of steps - ! Ntotal = Ntotal + ISTATUS(Nstp) - ! PRINT*,'NSTEPS=',ISTATUS(Nstp),' (',Ntotal,')',' O3=', VAR(ind_O3) - - STEPMIN = RSTATUS(Nhexit) - ! if optional parameters are given for output they - ! are updated with the return information - IF (PRESENT(ISTATUS_U)) ISTATUS_U(:) = ISTATUS(:) - IF (PRESENT(RSTATUS_U)) RSTATUS_U(:) = RSTATUS(:) - IF (PRESENT(IERR_U)) IERR_U = IERR - -END SUBROUTINE INTEGRATE - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -SUBROUTINE Rosenbrock(N,Y,Tstart,Tend, & - AbsTol,RelTol, & - RCNTRL,ICNTRL,RSTATUS,ISTATUS,IERR) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -! Solves the system y'=F(t,y) using a Rosenbrock method defined by: -! -! G = 1/(H*gamma(1)) - Jac(t0,Y0) -! T_i = t0 + Alpha(i)*H -! Y_i = Y0 + \sum_{j=1}^{i-1} A(i,j)*K_j -! G * K_i = Fun( T_i, Y_i ) + \sum_{j=1}^S C(i,j)/H * K_j + -! gamma(i)*dF/dT(t0, Y0) -! Y1 = Y0 + \sum_{j=1}^S M(j)*K_j -! -! For details on Rosenbrock methods and their implementation consult: -! E. Hairer and G. Wanner -! "Solving ODEs II. Stiff and differential-algebraic problems". -! Springer series in computational mathematics, Springer-Verlag, 1996. -! The codes contained in the book inspired this implementation. -! -! (C) Adrian Sandu, August 2004 -! Virginia Polytechnic Institute and State University -! Contact: sandu@cs.vt.edu -! Revised by Philipp Miehe and Adrian Sandu, May 2006 -! This implementation is part of KPP - the Kinetic PreProcessor -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!~~~> INPUT ARGUMENTS: -! -!- Y(N) = vector of initial conditions (at T=Tstart) -!- [Tstart,Tend] = time range of integration -! (if Tstart>Tend the integration is performed backwards in time) -!- RelTol, AbsTol = user precribed accuracy -!- SUBROUTINE Fun( T, Y, Ydot ) = ODE function, -! returns Ydot = Y' = F(T,Y) -!- SUBROUTINE Jac( T, Y, Jcb ) = Jacobian of the ODE function, -! returns Jcb = dFun/dY -!- ICNTRL(1:20) = integer inputs parameters -!- RCNTRL(1:20) = real inputs parameters -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!~~~> OUTPUT ARGUMENTS: -! -!- Y(N) -> vector of final states (at T->Tend) -!- ISTATUS(1:20) -> integer output parameters -!- RSTATUS(1:20) -> real output parameters -!- IERR -> job status upon return -! success (positive value) or -! failure (negative value) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!~~~> INPUT PARAMETERS: -! -! Note: For input parameters equal to zero the default values of the -! corresponding variables are used. -! -! ICNTRL(1) = 1: F = F(y) Independent of T (AUTONOMOUS) -! = 0: F = F(t,y) Depends on T (NON-AUTONOMOUS) -! -! ICNTRL(2) = 0: AbsTol, RelTol are N-dimensional vectors -! = 1: AbsTol, RelTol are scalars -! -! ICNTRL(3) -> selection of a particular Rosenbrock method -! = 0 : Rodas3 (default) -! = 1 : Ros2 -! = 2 : Ros3 -! = 3 : Ros4 -! = 4 : Rodas3 -! = 5 : Rodas4 -! -! ICNTRL(4) -> maximum number of integration steps -! For ICNTRL(4)=0) the default value of 100000 is used -! -! RCNTRL(1) -> Hmin, lower bound for the integration step size -! It is strongly recommended to keep Hmin = ZERO -! RCNTRL(2) -> Hmax, upper bound for the integration step size -! RCNTRL(3) -> Hstart, starting value for the integration step size -! -! RCNTRL(4) -> FacMin, lower bound on step decrease factor (default=0.2) -! RCNTRL(5) -> FacMax, upper bound on step increase factor (default=6) -! RCNTRL(6) -> FacRej, step decrease factor after multiple rejections -! (default=0.1) -! RCNTRL(7) -> FacSafe, by which the new step is slightly smaller -! than the predicted value (default=0.9) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -! -! OUTPUT ARGUMENTS: -! ----------------- -! -! T -> T value for which the solution has been computed -! (after successful return T=Tend). -! -! Y(N) -> Numerical solution at T -! -! IDID -> Reports on successfulness upon return: -! = 1 for success -! < 0 for error (value equals error code) -! -! ISTATUS(1) -> No. of function calls -! ISTATUS(2) -> No. of jacobian calls -! ISTATUS(3) -> No. of steps -! ISTATUS(4) -> No. of accepted steps -! ISTATUS(5) -> No. of rejected steps (except at very beginning) -! ISTATUS(6) -> No. of LU decompositions -! ISTATUS(7) -> No. of forward/backward substitutions -! ISTATUS(8) -> No. of singular matrix decompositions -! -! RSTATUS(1) -> Texit, the time corresponding to the -! computed Y upon return -! RSTATUS(2) -> Hexit, last accepted step before exit -! RSTATUS(3) -> Hnew, last predicted step (not yet taken) -! For multiple restarts, use Hnew as Hstart -! in the subsequent run -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - USE KPP_ROOT_Parameters - USE KPP_ROOT_LinearAlgebra - IMPLICIT NONE - -!~~~> Arguments - INTEGER, INTENT(IN) :: N - KPP_REAL, INTENT(INOUT) :: Y(N) - KPP_REAL, INTENT(IN) :: Tstart,Tend - KPP_REAL, INTENT(IN) :: AbsTol(N),RelTol(N) - INTEGER, INTENT(IN) :: ICNTRL(20) - KPP_REAL, INTENT(IN) :: RCNTRL(20) - INTEGER, INTENT(INOUT) :: ISTATUS(20) - KPP_REAL, INTENT(INOUT) :: RSTATUS(20) - INTEGER, INTENT(OUT) :: IERR -!~~~> Parameters of the Rosenbrock method, up to 6 stages - INTEGER :: ros_S, rosMethod - INTEGER, PARAMETER :: RS2=1, RS3=2, RS4=3, RD3=4, RD4=5, RG3=6 - KPP_REAL :: ros_A(15), ros_C(15), ros_M(6), ros_E(6), & - ros_Alpha(6), ros_Gamma(6), ros_ELO - LOGICAL :: ros_NewF(6) - CHARACTER(LEN=12) :: ros_Name -!~~~> Local variables - KPP_REAL :: Roundoff, FacMin, FacMax, FacRej, FacSafe - KPP_REAL :: Hmin, Hmax, Hstart - KPP_REAL :: Texit - INTEGER :: i, UplimTol, Max_no_steps - LOGICAL :: Autonomous, VectorTol -!~~~> Parameters - KPP_REAL, PARAMETER :: ZERO = 0.0_dp, ONE = 1.0_dp - KPP_REAL, PARAMETER :: DeltaMin = 1.0E-5_dp - -!~~~> Initialize statistics - ISTATUS(1:8) = 0 - RSTATUS(1:3) = ZERO - -!~~~> Autonomous or time dependent ODE. Default is time dependent. - Autonomous = .NOT.(ICNTRL(1) == 0) - -!~~~> For Scalar tolerances (ICNTRL(2).NE.0) the code uses AbsTol(1) and RelTol(1) -! For Vector tolerances (ICNTRL(2) == 0) the code uses AbsTol(1:N) and RelTol(1:N) - IF (ICNTRL(2) == 0) THEN - VectorTol = .TRUE. - UplimTol = N - ELSE - VectorTol = .FALSE. - UplimTol = 1 - END IF - -!~~~> Initialize the particular Rosenbrock method selected - SELECT CASE (ICNTRL(3)) - CASE (1) - CALL Ros2 - CASE (2) - CALL Ros3 - CASE (3) - CALL Ros4 - CASE (0,4) - CALL Rodas3 - CASE (5) - CALL Rodas4 - CASE (6) - CALL Rang3 - CASE DEFAULT - PRINT * , 'Unknown Rosenbrock method: ICNTRL(3)=',ICNTRL(3) - CALL ros_ErrorMsg(-2,Tstart,ZERO,IERR) - RETURN - END SELECT - -!~~~> The maximum number of steps admitted - IF (ICNTRL(4) == 0) THEN - Max_no_steps = 200000 - ELSEIF (ICNTRL(4) > 0) THEN - Max_no_steps=ICNTRL(4) - ELSE - PRINT * ,'User-selected max no. of steps: ICNTRL(4)=',ICNTRL(4) - CALL ros_ErrorMsg(-1,Tstart,ZERO,IERR) - RETURN - END IF - -!~~~> Unit roundoff (1+Roundoff>1) - Roundoff = WLAMCH('E') - -!~~~> Lower bound on the step size: (positive value) - IF (RCNTRL(1) == ZERO) THEN - Hmin = ZERO - ELSEIF (RCNTRL(1) > ZERO) THEN - Hmin = RCNTRL(1) - ELSE - PRINT * , 'User-selected Hmin: RCNTRL(1)=', RCNTRL(1) - CALL ros_ErrorMsg(-3,Tstart,ZERO,IERR) - RETURN - END IF -!~~~> Upper bound on the step size: (positive value) - IF (RCNTRL(2) == ZERO) THEN - Hmax = ABS(Tend-Tstart) - ELSEIF (RCNTRL(2) > ZERO) THEN - Hmax = MIN(ABS(RCNTRL(2)),ABS(Tend-Tstart)) - ELSE - PRINT * , 'User-selected Hmax: RCNTRL(2)=', RCNTRL(2) - CALL ros_ErrorMsg(-3,Tstart,ZERO,IERR) - RETURN - END IF -!~~~> Starting step size: (positive value) - IF (RCNTRL(3) == ZERO) THEN - Hstart = MAX(Hmin,DeltaMin) - ELSEIF (RCNTRL(3) > ZERO) THEN - Hstart = MIN(ABS(RCNTRL(3)),ABS(Tend-Tstart)) - ELSE - PRINT * , 'User-selected Hstart: RCNTRL(3)=', RCNTRL(3) - CALL ros_ErrorMsg(-3,Tstart,ZERO,IERR) - RETURN - END IF -!~~~> Step size can be changed s.t. FacMin < Hnew/Hold < FacMax - IF (RCNTRL(4) == ZERO) THEN - FacMin = 0.2_dp - ELSEIF (RCNTRL(4) > ZERO) THEN - FacMin = RCNTRL(4) - ELSE - PRINT * , 'User-selected FacMin: RCNTRL(4)=', RCNTRL(4) - CALL ros_ErrorMsg(-4,Tstart,ZERO,IERR) - RETURN - END IF - IF (RCNTRL(5) == ZERO) THEN - FacMax = 6.0_dp - ELSEIF (RCNTRL(5) > ZERO) THEN - FacMax = RCNTRL(5) - ELSE - PRINT * , 'User-selected FacMax: RCNTRL(5)=', RCNTRL(5) - CALL ros_ErrorMsg(-4,Tstart,ZERO,IERR) - RETURN - END IF -!~~~> FacRej: Factor to decrease step after 2 succesive rejections - IF (RCNTRL(6) == ZERO) THEN - FacRej = 0.1_dp - ELSEIF (RCNTRL(6) > ZERO) THEN - FacRej = RCNTRL(6) - ELSE - PRINT * , 'User-selected FacRej: RCNTRL(6)=', RCNTRL(6) - CALL ros_ErrorMsg(-4,Tstart,ZERO,IERR) - RETURN - END IF -!~~~> FacSafe: Safety Factor in the computation of new step size - IF (RCNTRL(7) == ZERO) THEN - FacSafe = 0.9_dp - ELSEIF (RCNTRL(7) > ZERO) THEN - FacSafe = RCNTRL(7) - ELSE - PRINT * , 'User-selected FacSafe: RCNTRL(7)=', RCNTRL(7) - CALL ros_ErrorMsg(-4,Tstart,ZERO,IERR) - RETURN - END IF -!~~~> Check if tolerances are reasonable - DO i=1,UplimTol - IF ( (AbsTol(i) <= ZERO) .OR. (RelTol(i) <= 10.0_dp*Roundoff) & - .OR. (RelTol(i) >= 1.0_dp) ) THEN - PRINT * , ' AbsTol(',i,') = ',AbsTol(i) - PRINT * , ' RelTol(',i,') = ',RelTol(i) - CALL ros_ErrorMsg(-5,Tstart,ZERO,IERR) - RETURN - END IF - END DO - - -!~~~> CALL Rosenbrock method - CALL ros_Integrator(Y, Tstart, Tend, Texit, & - AbsTol, RelTol, & -! Integration parameters - Autonomous, VectorTol, Max_no_steps, & - Roundoff, Hmin, Hmax, Hstart, & - FacMin, FacMax, FacRej, FacSafe, & -! Error indicator - IERR) - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -CONTAINS ! SUBROUTINES internal to Rosenbrock -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_ErrorMsg(Code,T,H,IERR) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Handles all error messages -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - KPP_REAL, INTENT(IN) :: T, H - INTEGER, INTENT(IN) :: Code - INTEGER, INTENT(OUT) :: IERR - - IERR = Code - PRINT * , & - 'Forced exit from Rosenbrock due to the following error:' - - SELECT CASE (Code) - CASE (-1) - PRINT * , '--> Improper value for maximal no of steps' - CASE (-2) - PRINT * , '--> Selected Rosenbrock method not implemented' - CASE (-3) - PRINT * , '--> Hmin/Hmax/Hstart must be positive' - CASE (-4) - PRINT * , '--> FacMin/FacMax/FacRej must be positive' - CASE (-5) - PRINT * , '--> Improper tolerance values' - CASE (-6) - PRINT * , '--> No of steps exceeds maximum bound' - CASE (-7) - PRINT * , '--> Step size too small: T + 10*H = T', & - ' or H < Roundoff' - CASE (-8) - PRINT * , '--> Matrix is repeatedly singular' - CASE DEFAULT - PRINT *, 'Unknown Error code: ', Code - END SELECT - - PRINT *, "T=", T, "and H=", H - - END SUBROUTINE ros_ErrorMsg - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_Integrator (Y, Tstart, Tend, T, & - AbsTol, RelTol, & -!~~~> Integration parameters - Autonomous, VectorTol, Max_no_steps, & - Roundoff, Hmin, Hmax, Hstart, & - FacMin, FacMax, FacRej, FacSafe, & -!~~~> Error indicator - IERR ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Template for the implementation of a generic Rosenbrock method -! defined by ros_S (no of stages) -! and its coefficients ros_{A,C,M,E,Alpha,Gamma} -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - -!~~~> Input: the initial condition at Tstart; Output: the solution at T - KPP_REAL, INTENT(INOUT) :: Y(N) -!~~~> Input: integration interval - KPP_REAL, INTENT(IN) :: Tstart,Tend -!~~~> Output: time at which the solution is returned (T=Tend if success) - KPP_REAL, INTENT(OUT) :: T -!~~~> Input: tolerances - KPP_REAL, INTENT(IN) :: AbsTol(N), RelTol(N) -!~~~> Input: integration parameters - LOGICAL, INTENT(IN) :: Autonomous, VectorTol - KPP_REAL, INTENT(IN) :: Hstart, Hmin, Hmax - INTEGER, INTENT(IN) :: Max_no_steps - KPP_REAL, INTENT(IN) :: Roundoff, FacMin, FacMax, FacRej, FacSafe -!~~~> Output: Error indicator - INTEGER, INTENT(OUT) :: IERR -! ~~~~ Local variables - KPP_REAL :: Ynew(N), Fcn0(N), Fcn(N) - KPP_REAL :: K(N*ros_S), dFdT(N) -#ifdef FULL_ALGEBRA - KPP_REAL :: Jac0(N,N), Ghimj(N,N) -#else - KPP_REAL :: Jac0(LU_NONZERO), Ghimj(LU_NONZERO) -#endif - KPP_REAL :: H, Hnew, HC, HG, Fac, Tau - KPP_REAL :: Err, Yerr(N) - INTEGER :: Pivot(N), Direction, ioffset, j, istage - LOGICAL :: RejectLastH, RejectMoreH, Singular -!~~~> Local parameters - KPP_REAL, PARAMETER :: ZERO = 0.0_dp, ONE = 1.0_dp - KPP_REAL, PARAMETER :: DeltaMin = 1.0E-5_dp -!~~~> Locally called functions -! KPP_REAL WLAMCH -! EXTERNAL WLAMCH -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - -!~~~> Initial preparations - T = Tstart - RSTATUS(Nhexit) = ZERO - H = MIN( MAX(ABS(Hmin),ABS(Hstart)) , ABS(Hmax) ) - IF (ABS(H) <= 10.0_dp*Roundoff) H = DeltaMin - - IF (Tend >= Tstart) THEN - Direction = +1 - ELSE - Direction = -1 - END IF - H = Direction*H - - RejectLastH=.FALSE. - RejectMoreH=.FALSE. - -!~~~> Time loop begins below - -TimeLoop: DO WHILE ( (Direction > 0).AND.((T-Tend)+Roundoff <= ZERO) & - .OR. (Direction < 0).AND.((Tend-T)+Roundoff <= ZERO) ) - - IF ( ISTATUS(Nstp) > Max_no_steps ) THEN ! Too many steps - CALL ros_ErrorMsg(-6,T,H,IERR) - RETURN - END IF - IF ( ((T+0.1_dp*H) == T).OR.(H <= Roundoff) ) THEN ! Step size too small - CALL ros_ErrorMsg(-7,T,H,IERR) - RETURN - END IF - -!~~~> Limit H if necessary to avoid going beyond Tend - H = MIN(H,ABS(Tend-T)) - -!~~~> Compute the function at current time - CALL FunTemplate(T,Y,Fcn0) - ISTATUS(Nfun) = ISTATUS(Nfun) + 1 - -!~~~> Compute the function derivative with respect to T - IF (.NOT.Autonomous) THEN - CALL ros_FunTimeDerivative ( T, Roundoff, Y, & - Fcn0, dFdT ) - END IF - -!~~~> Compute the Jacobian at current time - CALL JacTemplate(T,Y,Jac0) - ISTATUS(Njac) = ISTATUS(Njac) + 1 - -!~~~> Repeat step calculation until current step accepted -UntilAccepted: DO - - CALL ros_PrepareMatrix(H,Direction,ros_Gamma(1), & - Jac0,Ghimj,Pivot,Singular) - IF (Singular) THEN ! More than 5 consecutive failed decompositions - CALL ros_ErrorMsg(-8,T,H,IERR) - RETURN - END IF - -!~~~> Compute the stages -Stage: DO istage = 1, ros_S - - ! Current istage offset. Current istage vector is K(ioffset+1:ioffset+N) - ioffset = N*(istage-1) - - ! For the 1st istage the function has been computed previously - IF ( istage == 1 ) THEN - CALL WCOPY(N,Fcn0,1,Fcn,1) - ! istage>1 and a new function evaluation is needed at the current istage - ELSEIF ( ros_NewF(istage) ) THEN - CALL WCOPY(N,Y,1,Ynew,1) - DO j = 1, istage-1 - CALL WAXPY(N,ros_A((istage-1)*(istage-2)/2+j), & - K(N*(j-1)+1:N*j),1,Ynew,1) - END DO - Tau = T + ros_Alpha(istage)*Direction*H - CALL FunTemplate(Tau,Ynew,Fcn) - ISTATUS(Nfun) = ISTATUS(Nfun) + 1 - END IF ! if istage == 1 elseif ros_NewF(istage) - CALL WCOPY(N,Fcn,1,K(ioffset+1:ioffset+N),1) - DO j = 1, istage-1 - HC = ros_C((istage-1)*(istage-2)/2+j)/(Direction*H) - CALL WAXPY(N,HC,K(N*(j-1)+1:N*j),1,K(ioffset+1:ioffset+N),1) - END DO - IF ((.NOT. Autonomous).AND.(ros_Gamma(istage).NE.ZERO)) THEN - HG = Direction*H*ros_Gamma(istage) - CALL WAXPY(N,HG,dFdT,1,K(ioffset+1:ioffset+N),1) - END IF - CALL ros_Solve(Ghimj, Pivot, K(ioffset+1:ioffset+N)) - - END DO Stage - - -!~~~> Compute the new solution - CALL WCOPY(N,Y,1,Ynew,1) - DO j=1,ros_S - CALL WAXPY(N,ros_M(j),K(N*(j-1)+1:N*j),1,Ynew,1) - END DO - -!~~~> Compute the error estimation - CALL WSCAL(N,ZERO,Yerr,1) - DO j=1,ros_S - CALL WAXPY(N,ros_E(j),K(N*(j-1)+1:N*j),1,Yerr,1) - END DO - Err = ros_ErrorNorm ( Y, Ynew, Yerr, AbsTol, RelTol, VectorTol ) - -!~~~> New step size is bounded by FacMin <= Hnew/H <= FacMax - Fac = MIN(FacMax,MAX(FacMin,FacSafe/Err**(ONE/ros_ELO))) - Hnew = H*Fac - -!~~~> Check the error magnitude and adjust step size - ISTATUS(Nstp) = ISTATUS(Nstp) + 1 - IF ( (Err <= ONE).OR.(H <= Hmin) ) THEN !~~~> Accept step - ISTATUS(Nacc) = ISTATUS(Nacc) + 1 - CALL WCOPY(N,Ynew,1,Y,1) - T = T + Direction*H - Hnew = MAX(Hmin,MIN(Hnew,Hmax)) - IF (RejectLastH) THEN ! No step size increase after a rejected step - Hnew = MIN(Hnew,H) - END IF - RSTATUS(Nhexit) = H - RSTATUS(Nhnew) = Hnew - RSTATUS(Ntexit) = T - RejectLastH = .FALSE. - RejectMoreH = .FALSE. - H = Hnew - EXIT UntilAccepted ! EXIT THE LOOP: WHILE STEP NOT ACCEPTED - ELSE !~~~> Reject step - IF (RejectMoreH) THEN - Hnew = H*FacRej - END IF - RejectMoreH = RejectLastH - RejectLastH = .TRUE. - H = Hnew - IF (ISTATUS(Nacc) >= 1) ISTATUS(Nrej) = ISTATUS(Nrej) + 1 - END IF ! Err <= 1 - - END DO UntilAccepted - - END DO TimeLoop - -!~~~> Succesful exit - IERR = 1 !~~~> The integration was successful - - END SUBROUTINE ros_Integrator - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - KPP_REAL FUNCTION ros_ErrorNorm ( Y, Ynew, Yerr, & - AbsTol, RelTol, VectorTol ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Computes the "scaled norm" of the error vector Yerr -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - -! Input arguments - KPP_REAL, INTENT(IN) :: Y(N), Ynew(N), & - Yerr(N), AbsTol(N), RelTol(N) - LOGICAL, INTENT(IN) :: VectorTol -! Local variables - KPP_REAL :: Err, Scale, Ymax - INTEGER :: i - KPP_REAL, PARAMETER :: ZERO = 0.0_dp - - Err = ZERO - DO i=1,N - Ymax = MAX(ABS(Y(i)),ABS(Ynew(i))) - IF (VectorTol) THEN - Scale = AbsTol(i)+RelTol(i)*Ymax - ELSE - Scale = AbsTol(1)+RelTol(1)*Ymax - END IF - Err = Err+(Yerr(i)/Scale)**2 - END DO - Err = SQRT(Err/N) - - ros_ErrorNorm = MAX(Err,1.0d-10) - - END FUNCTION ros_ErrorNorm - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_FunTimeDerivative ( T, Roundoff, Y, & - Fcn0, dFdT ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> The time partial derivative of the function by finite differences -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - -!~~~> Input arguments - KPP_REAL, INTENT(IN) :: T, Roundoff, Y(N), Fcn0(N) -!~~~> Output arguments - KPP_REAL, INTENT(OUT) :: dFdT(N) -!~~~> Local variables - KPP_REAL :: Delta - KPP_REAL, PARAMETER :: ONE = 1.0_dp, DeltaMin = 1.0E-6_dp - - Delta = SQRT(Roundoff)*MAX(DeltaMin,ABS(T)) - CALL FunTemplate(T+Delta,Y,dFdT) - ISTATUS(Nfun) = ISTATUS(Nfun) + 1 - CALL WAXPY(N,(-ONE),Fcn0,1,dFdT,1) - CALL WSCAL(N,(ONE/Delta),dFdT,1) - - END SUBROUTINE ros_FunTimeDerivative - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_PrepareMatrix ( H, Direction, gam, & - Jac0, Ghimj, Pivot, Singular ) -! --- --- --- --- --- --- --- --- --- --- --- --- --- -! Prepares the LHS matrix for stage calculations -! 1. Construct Ghimj = 1/(H*ham) - Jac0 -! "(Gamma H) Inverse Minus Jacobian" -! 2. Repeat LU decomposition of Ghimj until successful. -! -half the step size if LU decomposition fails and retry -! -exit after 5 consecutive fails -! --- --- --- --- --- --- --- --- --- --- --- --- --- - IMPLICIT NONE - -!~~~> Input arguments -#ifdef FULL_ALGEBRA - KPP_REAL, INTENT(IN) :: Jac0(N,N) -#else - KPP_REAL, INTENT(IN) :: Jac0(LU_NONZERO) -#endif - KPP_REAL, INTENT(IN) :: gam - INTEGER, INTENT(IN) :: Direction -!~~~> Output arguments -#ifdef FULL_ALGEBRA - KPP_REAL, INTENT(OUT) :: Ghimj(N,N) -#else - KPP_REAL, INTENT(OUT) :: Ghimj(LU_NONZERO) -#endif - LOGICAL, INTENT(OUT) :: Singular - INTEGER, INTENT(OUT) :: Pivot(N) -!~~~> Inout arguments - KPP_REAL, INTENT(INOUT) :: H ! step size is decreased when LU fails -!~~~> Local variables - INTEGER :: i, ising, Nconsecutive - KPP_REAL :: ghinv - KPP_REAL, PARAMETER :: ONE = 1.0_dp, HALF = 0.5_dp - - Nconsecutive = 0 - Singular = .TRUE. - - DO WHILE (Singular) - -!~~~> Construct Ghimj = 1/(H*gam) - Jac0 -#ifdef FULL_ALGEBRA - CALL WCOPY(N*N,Jac0,1,Ghimj,1) - CALL WSCAL(N*N,(-ONE),Ghimj,1) - ghinv = ONE/(Direction*H*gam) - DO i=1,N - Ghimj(i,i) = Ghimj(i,i)+ghinv - END DO -#else - CALL WCOPY(LU_NONZERO,Jac0,1,Ghimj,1) - CALL WSCAL(LU_NONZERO,(-ONE),Ghimj,1) - ghinv = ONE/(Direction*H*gam) - DO i=1,N - Ghimj(LU_DIAG(i)) = Ghimj(LU_DIAG(i))+ghinv - END DO -#endif -!~~~> Compute LU decomposition - CALL ros_Decomp( Ghimj, Pivot, ising ) - IF (ising == 0) THEN -!~~~> If successful done - Singular = .FALSE. - ELSE ! ising .ne. 0 -!~~~> If unsuccessful half the step size; if 5 consecutive fails then return - ISTATUS(Nsng) = ISTATUS(Nsng) + 1 - Nconsecutive = Nconsecutive+1 - Singular = .TRUE. - PRINT*,'Warning: LU Decomposition returned ising = ',ising - IF (Nconsecutive <= 5) THEN ! Less than 5 consecutive failed decompositions - H = H*HALF - ELSE ! More than 5 consecutive failed decompositions - RETURN - END IF ! Nconsecutive - END IF ! ising - - END DO ! WHILE Singular - - END SUBROUTINE ros_PrepareMatrix - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_Decomp( A, Pivot, ising ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Template for the LU decomposition -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE -!~~~> Inout variables - KPP_REAL, INTENT(INOUT) :: A(LU_NONZERO) -!~~~> Output variables - INTEGER, INTENT(OUT) :: Pivot(N), ising - -#ifdef FULL_ALGEBRA - CALL DGETRF( N, N, A, N, Pivot, ising ) -#else - CALL KppDecomp ( A, ising ) - Pivot(1) = 1 -#endif - ISTATUS(Ndec) = ISTATUS(Ndec) + 1 - - END SUBROUTINE ros_Decomp - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_Solve( A, Pivot, b ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Template for the forward/backward substitution (using pre-computed LU decomposition) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE -!~~~> Input variables - KPP_REAL, INTENT(IN) :: A(LU_NONZERO) - INTEGER, INTENT(IN) :: Pivot(N) -!~~~> InOut variables - KPP_REAL, INTENT(INOUT) :: b(N) - -#ifdef FULL_ALGEBRA - CALL DGETRS( 'N', N , 1, A, N, Pivot, b, N, 0 ) -#else - CALL KppSolve( A, b ) -#endif - - ISTATUS(Nsol) = ISTATUS(Nsol) + 1 - - END SUBROUTINE ros_Solve - - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Ros2 -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! --- AN L-STABLE METHOD, 2 stages, order 2 -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - DOUBLE PRECISION g - - g = 1.0_dp + 1.0_dp/SQRT(2.0_dp) - rosMethod = RS2 -!~~~> Name of the method - ros_Name = 'ROS-2' -!~~~> Number of stages - ros_S = 2 - -!~~~> The coefficient matrices A and C are strictly lower triangular. -! The lower triangular (subdiagonal) elements are stored in row-wise order: -! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. -! The general mapping formula is: -! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) -! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) - - ros_A(1) = (1.0_dp)/g - ros_C(1) = (-2.0_dp)/g -!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) -! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) - ros_NewF(1) = .TRUE. - ros_NewF(2) = .TRUE. -!~~~> M_i = Coefficients for new step solution - ros_M(1)= (3.0_dp)/(2.0_dp*g) - ros_M(2)= (1.0_dp)/(2.0_dp*g) -! E_i = Coefficients for error estimator - ros_E(1) = 1.0_dp/(2.0_dp*g) - ros_E(2) = 1.0_dp/(2.0_dp*g) -!~~~> ros_ELO = estimator of local order - the minimum between the -! main and the embedded scheme orders plus one - ros_ELO = 2.0_dp -!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) - ros_Alpha(1) = 0.0_dp - ros_Alpha(2) = 1.0_dp -!~~~> Gamma_i = \sum_j gamma_{i,j} - ros_Gamma(1) = g - ros_Gamma(2) =-g - - END SUBROUTINE Ros2 - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Ros3 -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! --- AN L-STABLE METHOD, 3 stages, order 3, 2 function evaluations -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - rosMethod = RS3 -!~~~> Name of the method - ros_Name = 'ROS-3' -!~~~> Number of stages - ros_S = 3 - -!~~~> The coefficient matrices A and C are strictly lower triangular. -! The lower triangular (subdiagonal) elements are stored in row-wise order: -! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. -! The general mapping formula is: -! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) -! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) - - ros_A(1)= 1.0_dp - ros_A(2)= 1.0_dp - ros_A(3)= 0.0_dp - - ros_C(1) = -0.10156171083877702091975600115545E+01_dp - ros_C(2) = 0.40759956452537699824805835358067E+01_dp - ros_C(3) = 0.92076794298330791242156818474003E+01_dp -!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) -! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) - ros_NewF(1) = .TRUE. - ros_NewF(2) = .TRUE. - ros_NewF(3) = .FALSE. -!~~~> M_i = Coefficients for new step solution - ros_M(1) = 0.1E+01_dp - ros_M(2) = 0.61697947043828245592553615689730E+01_dp - ros_M(3) = -0.42772256543218573326238373806514_dp -! E_i = Coefficients for error estimator - ros_E(1) = 0.5_dp - ros_E(2) = -0.29079558716805469821718236208017E+01_dp - ros_E(3) = 0.22354069897811569627360909276199_dp -!~~~> ros_ELO = estimator of local order - the minimum between the -! main and the embedded scheme orders plus 1 - ros_ELO = 3.0_dp -!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) - ros_Alpha(1)= 0.0_dp - ros_Alpha(2)= 0.43586652150845899941601945119356_dp - ros_Alpha(3)= 0.43586652150845899941601945119356_dp -!~~~> Gamma_i = \sum_j gamma_{i,j} - ros_Gamma(1)= 0.43586652150845899941601945119356_dp - ros_Gamma(2)= 0.24291996454816804366592249683314_dp - ros_Gamma(3)= 0.21851380027664058511513169485832E+01_dp - - END SUBROUTINE Ros3 - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Ros4 -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! L-STABLE ROSENBROCK METHOD OF ORDER 4, WITH 4 STAGES -! L-STABLE EMBEDDED ROSENBROCK METHOD OF ORDER 3 -! -! E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL -! EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS. -! SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS, -! SPRINGER-VERLAG (1990) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - - rosMethod = RS4 -!~~~> Name of the method - ros_Name = 'ROS-4' -!~~~> Number of stages - ros_S = 4 - -!~~~> The coefficient matrices A and C are strictly lower triangular. -! The lower triangular (subdiagonal) elements are stored in row-wise order: -! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. -! The general mapping formula is: -! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) -! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) - - ros_A(1) = 0.2000000000000000E+01_dp - ros_A(2) = 0.1867943637803922E+01_dp - ros_A(3) = 0.2344449711399156_dp - ros_A(4) = ros_A(2) - ros_A(5) = ros_A(3) - ros_A(6) = 0.0_dp - - ros_C(1) =-0.7137615036412310E+01_dp - ros_C(2) = 0.2580708087951457E+01_dp - ros_C(3) = 0.6515950076447975_dp - ros_C(4) =-0.2137148994382534E+01_dp - ros_C(5) =-0.3214669691237626_dp - ros_C(6) =-0.6949742501781779_dp -!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) -! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) - ros_NewF(1) = .TRUE. - ros_NewF(2) = .TRUE. - ros_NewF(3) = .TRUE. - ros_NewF(4) = .FALSE. -!~~~> M_i = Coefficients for new step solution - ros_M(1) = 0.2255570073418735E+01_dp - ros_M(2) = 0.2870493262186792_dp - ros_M(3) = 0.4353179431840180_dp - ros_M(4) = 0.1093502252409163E+01_dp -!~~~> E_i = Coefficients for error estimator - ros_E(1) =-0.2815431932141155_dp - ros_E(2) =-0.7276199124938920E-01_dp - ros_E(3) =-0.1082196201495311_dp - ros_E(4) =-0.1093502252409163E+01_dp -!~~~> ros_ELO = estimator of local order - the minimum between the -! main and the embedded scheme orders plus 1 - ros_ELO = 4.0_dp -!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) - ros_Alpha(1) = 0.0_dp - ros_Alpha(2) = 0.1145640000000000E+01_dp - ros_Alpha(3) = 0.6552168638155900_dp - ros_Alpha(4) = ros_Alpha(3) -!~~~> Gamma_i = \sum_j gamma_{i,j} - ros_Gamma(1) = 0.5728200000000000_dp - ros_Gamma(2) =-0.1769193891319233E+01_dp - ros_Gamma(3) = 0.7592633437920482_dp - ros_Gamma(4) =-0.1049021087100450_dp - - END SUBROUTINE Ros4 - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Rodas3 -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! --- A STIFFLY-STABLE METHOD, 4 stages, order 3 -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - - rosMethod = RD3 -!~~~> Name of the method - ros_Name = 'RODAS-3' -!~~~> Number of stages - ros_S = 4 - -!~~~> The coefficient matrices A and C are strictly lower triangular. -! The lower triangular (subdiagonal) elements are stored in row-wise order: -! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. -! The general mapping formula is: -! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) -! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) - - ros_A(1) = 0.0_dp - ros_A(2) = 2.0_dp - ros_A(3) = 0.0_dp - ros_A(4) = 2.0_dp - ros_A(5) = 0.0_dp - ros_A(6) = 1.0_dp - - ros_C(1) = 4.0_dp - ros_C(2) = 1.0_dp - ros_C(3) =-1.0_dp - ros_C(4) = 1.0_dp - ros_C(5) =-1.0_dp - ros_C(6) =-(8.0_dp/3.0_dp) - -!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) -! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) - ros_NewF(1) = .TRUE. - ros_NewF(2) = .FALSE. - ros_NewF(3) = .TRUE. - ros_NewF(4) = .TRUE. -!~~~> M_i = Coefficients for new step solution - ros_M(1) = 2.0_dp - ros_M(2) = 0.0_dp - ros_M(3) = 1.0_dp - ros_M(4) = 1.0_dp -!~~~> E_i = Coefficients for error estimator - ros_E(1) = 0.0_dp - ros_E(2) = 0.0_dp - ros_E(3) = 0.0_dp - ros_E(4) = 1.0_dp -!~~~> ros_ELO = estimator of local order - the minimum between the -! main and the embedded scheme orders plus 1 - ros_ELO = 3.0_dp -!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) - ros_Alpha(1) = 0.0_dp - ros_Alpha(2) = 0.0_dp - ros_Alpha(3) = 1.0_dp - ros_Alpha(4) = 1.0_dp -!~~~> Gamma_i = \sum_j gamma_{i,j} - ros_Gamma(1) = 0.5_dp - ros_Gamma(2) = 1.5_dp - ros_Gamma(3) = 0.0_dp - ros_Gamma(4) = 0.0_dp - - END SUBROUTINE Rodas3 - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Rodas4 -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! STIFFLY-STABLE ROSENBROCK METHOD OF ORDER 4, WITH 6 STAGES -! -! E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL -! EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS. -! SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS, -! SPRINGER-VERLAG (1996) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - - rosMethod = RD4 -!~~~> Name of the method - ros_Name = 'RODAS-4' -!~~~> Number of stages - ros_S = 6 - -!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) - ros_Alpha(1) = 0.000_dp - ros_Alpha(2) = 0.386_dp - ros_Alpha(3) = 0.210_dp - ros_Alpha(4) = 0.630_dp - ros_Alpha(5) = 1.000_dp - ros_Alpha(6) = 1.000_dp - -!~~~> Gamma_i = \sum_j gamma_{i,j} - ros_Gamma(1) = 0.2500000000000000_dp - ros_Gamma(2) =-0.1043000000000000_dp - ros_Gamma(3) = 0.1035000000000000_dp - ros_Gamma(4) =-0.3620000000000023E-01_dp - ros_Gamma(5) = 0.0_dp - ros_Gamma(6) = 0.0_dp - -!~~~> The coefficient matrices A and C are strictly lower triangular. -! The lower triangular (subdiagonal) elements are stored in row-wise order: -! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. -! The general mapping formula is: A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) -! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) - - ros_A(1) = 0.1544000000000000E+01_dp - ros_A(2) = 0.9466785280815826_dp - ros_A(3) = 0.2557011698983284_dp - ros_A(4) = 0.3314825187068521E+01_dp - ros_A(5) = 0.2896124015972201E+01_dp - ros_A(6) = 0.9986419139977817_dp - ros_A(7) = 0.1221224509226641E+01_dp - ros_A(8) = 0.6019134481288629E+01_dp - ros_A(9) = 0.1253708332932087E+02_dp - ros_A(10) =-0.6878860361058950_dp - ros_A(11) = ros_A(7) - ros_A(12) = ros_A(8) - ros_A(13) = ros_A(9) - ros_A(14) = ros_A(10) - ros_A(15) = 1.0_dp - - ros_C(1) =-0.5668800000000000E+01_dp - ros_C(2) =-0.2430093356833875E+01_dp - ros_C(3) =-0.2063599157091915_dp - ros_C(4) =-0.1073529058151375_dp - ros_C(5) =-0.9594562251023355E+01_dp - ros_C(6) =-0.2047028614809616E+02_dp - ros_C(7) = 0.7496443313967647E+01_dp - ros_C(8) =-0.1024680431464352E+02_dp - ros_C(9) =-0.3399990352819905E+02_dp - ros_C(10) = 0.1170890893206160E+02_dp - ros_C(11) = 0.8083246795921522E+01_dp - ros_C(12) =-0.7981132988064893E+01_dp - ros_C(13) =-0.3152159432874371E+02_dp - ros_C(14) = 0.1631930543123136E+02_dp - ros_C(15) =-0.6058818238834054E+01_dp - -!~~~> M_i = Coefficients for new step solution - ros_M(1) = ros_A(7) - ros_M(2) = ros_A(8) - ros_M(3) = ros_A(9) - ros_M(4) = ros_A(10) - ros_M(5) = 1.0_dp - ros_M(6) = 1.0_dp - -!~~~> E_i = Coefficients for error estimator - ros_E(1) = 0.0_dp - ros_E(2) = 0.0_dp - ros_E(3) = 0.0_dp - ros_E(4) = 0.0_dp - ros_E(5) = 0.0_dp - ros_E(6) = 1.0_dp - -!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) -! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) - ros_NewF(1) = .TRUE. - ros_NewF(2) = .TRUE. - ros_NewF(3) = .TRUE. - ros_NewF(4) = .TRUE. - ros_NewF(5) = .TRUE. - ros_NewF(6) = .TRUE. - -!~~~> ros_ELO = estimator of local order - the minimum between the -! main and the embedded scheme orders plus 1 - ros_ELO = 4.0_dp - - END SUBROUTINE Rodas4 -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Rang3 -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! STIFFLY-STABLE W METHOD OF ORDER 3, WITH 4 STAGES -! -! J. RANG and L. ANGERMANN -! NEW ROSENBROCK W-METHODS OF ORDER 3 -! FOR PARTIAL DIFFERENTIAL ALGEBRAIC -! EQUATIONS OF INDEX 1 -! BIT Numerical Mathematics (2005) 45: 761-787 -! DOI: 10.1007/s10543-005-0035-y -! Table 4.1-4.2 -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - - rosMethod = RG3 -!~~~> Name of the method - ros_Name = 'RANG-3' -!~~~> Number of stages - ros_S = 4 - - ros_A(1) = 5.09052051067020d+00; - ros_A(2) = 5.09052051067020d+00; - ros_A(3) = 0.0d0; - ros_A(4) = 4.97628111010787d+00; - ros_A(5) = 2.77268164715849d-02; - ros_A(6) = 2.29428036027904d-01; - - ros_C(1) = -1.16790812312283d+01; - ros_C(2) = -1.64057326467367d+01; - ros_C(3) = -2.77268164715850d-01; - ros_C(4) = -8.38103960500476d+00; - ros_C(5) = -8.48328409199343d-01; - ros_C(6) = 2.87009860433106d-01; - - ros_M(1) = 5.22582761233094d+00; - ros_M(2) = -5.56971148154165d-01; - ros_M(3) = 3.57979469353645d-01; - ros_M(4) = 1.72337398521064d+00; - - ros_E(1) = -5.16845212784040d+00; - ros_E(2) = -1.26351942603842d+00; - ros_E(3) = -1.11022302462516d-16; - ros_E(4) = 2.22044604925031d-16; - - ros_Alpha(1) = 0.0d00; - ros_Alpha(2) = 2.21878746765329d+00; - ros_Alpha(3) = 2.21878746765329d+00; - ros_Alpha(4) = 1.55392337535788d+00; - - ros_Gamma(1) = 4.35866521508459d-01; - ros_Gamma(2) = -1.78292094614483d+00; - ros_Gamma(3) = -2.46541900496934d+00; - ros_Gamma(4) = -8.05529997906370d-01; - - -!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) -! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) - ros_NewF(1) = .TRUE. - ros_NewF(2) = .TRUE. - ros_NewF(3) = .TRUE. - ros_NewF(4) = .TRUE. - -!~~~> ros_ELO = estimator of local order - the minimum between the -! main and the embedded scheme orders plus 1 - ros_ELO = 3.0_dp - - END SUBROUTINE Rang3 -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! End of the set of internal Rosenbrock subroutines -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -END SUBROUTINE Rosenbrock -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -SUBROUTINE FunTemplate( T, Y, Ydot ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Template for the ODE function call. -! Updates the rate coefficients (and possibly the fixed species) at each call -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - USE KPP_ROOT_Parameters, ONLY: NVAR, LU_NONZERO - USE KPP_ROOT_Global, ONLY: FIX, RCONST, TIME - USE KPP_ROOT_Function, ONLY: Fun - USE KPP_ROOT_Rates, ONLY: Update_SUN, Update_RCONST -!~~~> Input variables - KPP_REAL :: T, Y(NVAR) -!~~~> Output variables - KPP_REAL :: Ydot(NVAR) -!~~~> Local variables - KPP_REAL :: Told - - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Fun( Y, FIX, RCONST, Ydot ) - TIME = Told - -END SUBROUTINE FunTemplate - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -SUBROUTINE JacTemplate( T, Y, Jcb ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Template for the ODE Jacobian call. -! Updates the rate coefficients (and possibly the fixed species) at each call -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - USE KPP_ROOT_Parameters, ONLY: NVAR, LU_NONZERO - USE KPP_ROOT_Global, ONLY: FIX, RCONST, TIME - USE KPP_ROOT_Jacobian, ONLY: Jac_SP, LU_IROW, LU_ICOL - USE KPP_ROOT_LinearAlgebra - USE KPP_ROOT_Rates, ONLY: Update_SUN, Update_RCONST -!~~~> Input variables - KPP_REAL :: T, Y(NVAR) -!~~~> Output variables -#ifdef FULL_ALGEBRA - KPP_REAL :: JV(LU_NONZERO), Jcb(NVAR,NVAR) -#else - KPP_REAL :: Jcb(LU_NONZERO) -#endif -!~~~> Local variables - KPP_REAL :: Told -#ifdef FULL_ALGEBRA - INTEGER :: i, j -#endif - - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() -#ifdef FULL_ALGEBRA - CALL Jac_SP(Y, FIX, RCONST, JV) - DO j=1,NVAR - DO i=1,NVAR - Jcb(i,j) = 0.0_dp - END DO - END DO - DO i=1,LU_NONZERO - Jcb(LU_IROW(i),LU_ICOL(i)) = JV(i) - END DO -#else - CALL Jac_SP( Y, FIX, RCONST, Jcb ) -#endif - TIME = Told - -END SUBROUTINE JacTemplate - -END MODULE KPP_ROOT_Integrator - - - - diff --git a/boxmox/int.modified_WCOPY/rosenbrock_adj.f90 b/boxmox/int.modified_WCOPY/rosenbrock_adj.f90 deleted file mode 100644 index b610bcb91b34f7b57c0db2a1718454484f10ea23..0000000000000000000000000000000000000000 --- a/boxmox/int.modified_WCOPY/rosenbrock_adj.f90 +++ /dev/null @@ -1,2575 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! -! Discrete adjoints of Rosenbrock, ! -! for several Rosenbrock methods: ! -! * Ros2 ! -! * Ros3 ! -! * Ros4 ! -! * Rodas3 ! -! * Rodas4 ! -! By default the code employs the KPP sparse linear algebra routines ! -! Compile with -DFULL_ALGEBRA to use full linear algebra (LAPACK) ! -! ! -! (C) Adrian Sandu, August 2004 ! -! Virginia Polytechnic Institute and State University ! -! Contact: sandu@cs.vt.edu ! -! Revised by Philipp Miehe and Adrian Sandu, May 2006 ! -! This implementation is part of KPP - the Kinetic PreProcessor ! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! - -MODULE KPP_ROOT_Integrator - - USE KPP_ROOT_Precision - USE KPP_ROOT_Parameters - USE KPP_ROOT_Global - USE KPP_ROOT_LinearAlgebra - USE KPP_ROOT_Rates - USE KPP_ROOT_Function - USE KPP_ROOT_Jacobian - USE KPP_ROOT_Hessian - USE KPP_ROOT_Util - - IMPLICIT NONE - PUBLIC - SAVE - -!~~~> Statistics on the work performed by the Rosenbrock method - INTEGER, PARAMETER :: Nfun=1, Njac=2, Nstp=3, Nacc=4, & - Nrej=5, Ndec=6, Nsol=7, Nsng=8, & - Ntexit=1, Nhexit=2, Nhnew = 3 - - -CONTAINS ! Routines in the module KPP_ROOT_Integrator - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -SUBROUTINE INTEGRATE_ADJ( NADJ, Y, Lambda, TIN, TOUT, & - ATOL_adj, RTOL_adj, & - ICNTRL_U, RCNTRL_U, ISTATUS_U, RSTATUS_U ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - -!~~~> Y - Concentrations - KPP_REAL :: Y(NVAR) -!~~~> NADJ - No. of cost functionals for which adjoints -! are evaluated simultaneously -! If single cost functional is considered (like in -! most applications) simply set NADJ = 1 - INTEGER NADJ -!~~~> Lambda - Sensitivities w.r.t. concentrations -! Note: Lambda (1:NVAR,j) contains sensitivities of -! the j-th cost functional w.r.t. Y(1:NVAR), j=1...NADJ - KPP_REAL :: Lambda(NVAR,NADJ) - KPP_REAL, INTENT(IN) :: TIN ! TIN - Start Time - KPP_REAL, INTENT(IN) :: TOUT ! TOUT - End Time -!~~~> Tolerances for adjoint calculations -! (used only for full continuous adjoint) - KPP_REAL, INTENT(IN) :: ATOL_adj(NVAR,NADJ), RTOL_adj(NVAR,NADJ) -!~~~> Optional input parameters and statistics - INTEGER, INTENT(IN), OPTIONAL :: ICNTRL_U(20) - KPP_REAL, INTENT(IN), OPTIONAL :: RCNTRL_U(20) - INTEGER, INTENT(OUT), OPTIONAL :: ISTATUS_U(20) - KPP_REAL, INTENT(OUT), OPTIONAL :: RSTATUS_U(20) - - KPP_REAL :: RCNTRL(20), RSTATUS(20) - INTEGER :: ICNTRL(20), ISTATUS(20), IERR - - INTEGER, SAVE :: Ntotal - - - ICNTRL(1:20) = 0 - RCNTRL(1:20) = 0.0_dp - ISTATUS(1:20) = 0 - RSTATUS(1:20) = 0.0_dp - - -!~~~> fine-tune the integrator: -! ICNTRL(1) = 0 ! 0 = non-autonomous, 1 = autonomous -! ICNTRL(2) = 1 ! 0 = scalar, 1 = vector tolerances -! RCNTRL(3) = STEPMIN ! starting step -! ICNTRL(3) = 5 ! choice of the method for forward integration -! ICNTRL(6) = 1 ! choice of the method for continuous adjoint -! ICNTRL(7) = 2 ! 1=none, 2=discrete, 3=full continuous, 4=simplified continuous adjoint -! ICNTRL(8) = 1 ! Save fwd LU factorization: 0 = *don't* save, 1 = save - - - ! if optional parameters are given, and if they are >=0, then they overwrite default settings - IF (PRESENT(ICNTRL_U)) THEN - WHERE(ICNTRL_U(:) >= 0) ICNTRL(:) = ICNTRL_U(:) - END IF - IF (PRESENT(RCNTRL_U)) THEN - WHERE(RCNTRL_U(:) >= 0) RCNTRL(:) = RCNTRL_U(:) - END IF - - - CALL RosenbrockADJ(Y, NADJ, Lambda, & - TIN, TOUT, & - ATOL, RTOL, ATOL_adj, RTOL_adj, & - RCNTRL, ICNTRL, RSTATUS, ISTATUS, IERR) - - -!~~~> Debug option: show number of steps -! Ntotal = Ntotal + ISTATUS(Nstp) -! WRITE(6,777) ISTATUS(Nstp),Ntotal,VAR(ind_O3),VAR(ind_NO2) -!777 FORMAT('NSTEPS=',I6,' (',I6,') O3=',E24.14,' NO2=',E24.14) - - IF (IERR < 0) THEN - print *,'RosenbrockADJ: Unsucessful step at T=', & - TIN,' (IERR=',IERR,')' - END IF - - STEPMIN = RSTATUS(Nhexit) - ! if optional parameters are given for output - ! copy to them to return information - IF (PRESENT(ISTATUS_U)) ISTATUS_U(:) = ISTATUS(:) - IF (PRESENT(RSTATUS_U)) RSTATUS_U(:) = RSTATUS(:) - -END SUBROUTINE INTEGRATE_ADJ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -SUBROUTINE RosenbrockADJ( Y, NADJ, Lambda, & - Tstart, Tend, & - AbsTol, RelTol, AbsTol_adj, RelTol_adj, & - RCNTRL, ICNTRL, RSTATUS, ISTATUS, IERR) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -! ADJ = Adjoint of the Tangent Linear Model of a Rosenbrock Method -! -! Solves the system y'=F(t,y) using a RosenbrockADJ method defined by: -! -! G = 1/(H*gamma(1)) - Jac(t0,Y0) -! T_i = t0 + Alpha(i)*H -! Y_i = Y0 + \sum_{j=1}^{i-1} A(i,j)*K_j -! G * K_i = Fun( T_i, Y_i ) + \sum_{j=1}^S C(i,j)/H * K_j + -! gamma(i)*dF/dT(t0, Y0) -! Y1 = Y0 + \sum_{j=1}^S M(j)*K_j -! -! For details on RosenbrockADJ methods and their implementation consult: -! E. Hairer and G. Wanner -! "Solving ODEs II. Stiff and differential-algebraic problems". -! Springer series in computational mathematics, Springer-Verlag, 1996. -! The codes contained in the book inspired this implementation. -! -! (C) Adrian Sandu, August 2004 -! Virginia Polytechnic Institute and State University -! Contact: sandu@cs.vt.edu -! Revised by Philipp Miehe and Adrian Sandu, May 2006 -! This implementation is part of KPP - the Kinetic PreProcessor -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!~~~> INPUT ARGUMENTS: -! -!- Y(NVAR) = vector of initial conditions (at T=Tstart) -! NADJ -> dimension of linearized system, -! i.e. the number of sensitivity coefficients -!- Lambda(NVAR,NADJ) -> vector of initial sensitivity conditions (at T=Tstart) -!- [Tstart,Tend] = time range of integration -! (if Tstart>Tend the integration is performed backwards in time) -!- RelTol, AbsTol = user precribed accuracy -!- SUBROUTINE Fun( T, Y, Ydot ) = ODE function, -! returns Ydot = Y' = F(T,Y) -!- SUBROUTINE Jac( T, Y, Jcb ) = Jacobian of the ODE function, -! returns Jcb = dF/dY -!- ICNTRL(1:10) = integer inputs parameters -!- RCNTRL(1:10) = real inputs parameters -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!~~~> OUTPUT ARGUMENTS: -! -!- Y(NVAR) -> vector of final states (at T->Tend) -!- Lambda(NVAR,NADJ) -> vector of final sensitivities (at T=Tend) -!- ICNTRL(11:20) -> integer output parameters -!- RCNTRL(11:20) -> real output parameters -!- IERR -> job status upon return -! - succes (positive value) or failure (negative value) - -! = 1 : Success -! = -1 : Improper value for maximal no of steps -! = -2 : Selected RosenbrockADJ method not implemented -! = -3 : Hmin/Hmax/Hstart must be positive -! = -4 : FacMin/FacMax/FacRej must be positive -! = -5 : Improper tolerance values -! = -6 : No of steps exceeds maximum bound -! = -7 : Step size too small -! = -8 : Matrix is repeatedly singular -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!~~~> INPUT PARAMETERS: -! -! Note: For input parameters equal to zero the default values of the -! corresponding variables are used. -! -! ICNTRL(1) = 1: F = F(y) Independent of T (AUTONOMOUS) -! = 0: F = F(t,y) Depends on T (NON-AUTONOMOUS) -! -! ICNTRL(2) = 0: AbsTol, RelTol are NVAR-dimensional vectors -! = 1: AbsTol, RelTol are scalars -! -! ICNTRL(3) -> selection of a particular Rosenbrock method -! = 0 : default method is Rodas3 -! = 1 : method is Ros2 -! = 2 : method is Ros3 -! = 3 : method is Ros4 -! = 4 : method is Rodas3 -! = 5: method is Rodas4 -! -! ICNTRL(4) -> maximum number of integration steps -! For ICNTRL(4)=0) the default value of BUFSIZE is used -! -! ICNTRL(6) -> selection of a particular Rosenbrock method for the -! continuous adjoint integration - for cts adjoint it -! can be different than the forward method ICNTRL(3) -! Note 1: to avoid interpolation errors (which can be huge!) -! it is recommended to use only ICNTRL(7) = 2 or 4 -! Note 2: the performance of the full continuous adjoint -! strongly depends on the forward solution accuracy Abs/RelTol -! -! ICNTRL(7) -> Type of adjoint algorithm -! = 0 : default is discrete adjoint ( of method ICNTRL(3) ) -! = 1 : no adjoint -! = 2 : discrete adjoint ( of method ICNTRL(3) ) -! = 3 : fully adaptive continuous adjoint ( with method ICNTRL(6) ) -! = 4 : simplified continuous adjoint ( with method ICNTRL(6) ) -! -! ICNTRL(8) -> checkpointing the LU factorization at each step: -! ICNTRL(8)=0 : do *not* save LU factorization (the default) -! ICNTRL(8)=1 : save LU factorization -! Note: if ICNTRL(7)=1 the LU factorization is *not* saved -! -!~~~> Real input parameters: -! -! RCNTRL(1) -> Hmin, lower bound for the integration step size -! It is strongly recommended to keep Hmin = ZERO -! -! RCNTRL(2) -> Hmax, upper bound for the integration step size -! -! RCNTRL(3) -> Hstart, starting value for the integration step size -! -! RCNTRL(4) -> FacMin, lower bound on step decrease factor (default=0.2) -! -! RCNTRL(5) -> FacMax, upper bound on step increase factor (default=6) -! -! RCNTRL(6) -> FacRej, step decrease factor after multiple rejections -! (default=0.1) -! -! RCNTRL(7) -> FacSafe, by which the new step is slightly smaller -! than the predicted value (default=0.9) -! -! RCNTRL(8) -> ThetaMin. If Newton convergence rate smaller -! than ThetaMin the Jacobian is not recomputed; -! (default=0.001) -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!~~~> OUTPUT PARAMETERS: -! -! Note: each call to RosenbrockADJ adds the corrent no. of fcn calls -! to previous value of ISTATUS(1), and similar for the other params. -! Set ISTATUS(1:10) = 0 before call to avoid this accumulation. -! -! ISTATUS(1) = No. of function calls -! ISTATUS(2) = No. of jacobian calls -! ISTATUS(3) = No. of steps -! ISTATUS(4) = No. of accepted steps -! ISTATUS(5) = No. of rejected steps (except at the beginning) -! ISTATUS(6) = No. of LU decompositions -! ISTATUS(7) = No. of forward/backward substitutions -! ISTATUS(8) = No. of singular matrix decompositions -! -! RSTATUS(1) -> Texit, the time corresponding to the -! computed Y upon return -! RSTATUS(2) -> Hexit, last accepted step before exit -! For multiple restarts, use Hexit as Hstart in the following run -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - -!~~~> Arguments - KPP_REAL, INTENT(INOUT) :: Y(NVAR) - INTEGER, INTENT(IN) :: NADJ - KPP_REAL, INTENT(INOUT) :: Lambda(NVAR,NADJ) - KPP_REAL, INTENT(IN) :: Tstart,Tend - KPP_REAL, INTENT(IN) :: AbsTol(NVAR),RelTol(NVAR) - KPP_REAL, INTENT(IN) :: AbsTol_adj(NVAR,NADJ), RelTol_adj(NVAR,NADJ) - INTEGER, INTENT(IN) :: ICNTRL(20) - KPP_REAL, INTENT(IN) :: RCNTRL(20) - INTEGER, INTENT(INOUT) :: ISTATUS(20) - KPP_REAL, INTENT(INOUT) :: RSTATUS(20) - INTEGER, INTENT(OUT) :: IERR -!~~~> Parameters of the Rosenbrock method, up to 6 stages - INTEGER :: ros_S, rosMethod - INTEGER, PARAMETER :: RS2=1, RS3=2, RS4=3, RD3=4, RD4=5 - KPP_REAL :: ros_A(15), ros_C(15), ros_M(6), ros_E(6), & - ros_Alpha(6), ros_Gamma(6), ros_ELO - LOGICAL :: ros_NewF(6) - CHARACTER(LEN=12) :: ros_Name -!~~~> Types of Adjoints Implemented - INTEGER, PARAMETER :: Adj_none = 1, Adj_discrete = 2, & - Adj_continuous = 3, Adj_simple_continuous = 4 -!~~~> Checkpoints in memory - INTEGER, PARAMETER :: bufsize = 200000 - INTEGER :: stack_ptr = 0 ! last written entry - KPP_REAL, DIMENSION(:), POINTER :: chk_H, chk_T - KPP_REAL, DIMENSION(:,:), POINTER :: chk_Y, chk_K, chk_J - KPP_REAL, DIMENSION(:,:), POINTER :: chk_dY, chk_d2Y -!~~~> Local variables - KPP_REAL :: Roundoff, FacMin, FacMax, FacRej, FacSafe - KPP_REAL :: Hmin, Hmax, Hstart - KPP_REAL :: Texit - INTEGER :: i, UplimTol, Max_no_steps - INTEGER :: AdjointType, CadjMethod - LOGICAL :: Autonomous, VectorTol, SaveLU -!~~~> Parameters - KPP_REAL, PARAMETER :: ZERO = 0.0d0, ONE = 1.0d0 - KPP_REAL, PARAMETER :: DeltaMin = 1.0d-5 - -!~~~> Initialize statistics - ISTATUS(1:20) = 0 - RSTATUS(1:20) = ZERO - -!~~~> Autonomous or time dependent ODE. Default is time dependent. - Autonomous = .NOT.(ICNTRL(1) == 0) - -!~~~> For Scalar tolerances (ICNTRL(2).NE.0) the code uses AbsTol(1) and RelTol(1) -! For Vector tolerances (ICNTRL(2) == 0) the code uses AbsTol(1:NVAR) and RelTol(1:NVAR) - IF (ICNTRL(2) == 0) THEN - VectorTol = .TRUE. - UplimTol = NVAR - ELSE - VectorTol = .FALSE. - UplimTol = 1 - END IF - -!~~~> Initialize the particular Rosenbrock method selected - SELECT CASE (ICNTRL(3)) - CASE (1) - CALL Ros2 - CASE (2) - CALL Ros3 - CASE (3) - CALL Ros4 - CASE (0,4) - CALL Rodas3 - CASE (5) - CALL Rodas4 - CASE DEFAULT - PRINT * , 'Unknown Rosenbrock method: ICNTRL(3)=',ICNTRL(3) - CALL ros_ErrorMsg(-2,Tstart,ZERO,IERR) - RETURN - END SELECT - -!~~~> The maximum number of steps admitted - IF (ICNTRL(4) == 0) THEN - Max_no_steps = bufsize - 1 - ELSEIF (Max_no_steps > 0) THEN - Max_no_steps=ICNTRL(4) - ELSE - PRINT * ,'User-selected max no. of steps: ICNTRL(4)=',ICNTRL(4) - CALL ros_ErrorMsg(-1,Tstart,ZERO,IERR) - RETURN - END IF - -!~~~> The particular Rosenbrock method chosen for integrating the cts adjoint - IF (ICNTRL(6) == 0) THEN - CadjMethod = 4 - ELSEIF ( (ICNTRL(6) >= 1).AND.(ICNTRL(6) <= 5) ) THEN - CadjMethod = ICNTRL(6) - ELSE - PRINT * , 'Unknown CADJ Rosenbrock method: ICNTRL(6)=', CadjMethod - CALL ros_ErrorMsg(-2,Tstart,ZERO,IERR) - RETURN - END IF - -!~~~> Discrete or continuous adjoint formulation - IF ( ICNTRL(7) == 0 ) THEN - AdjointType = Adj_discrete - ELSEIF ( (ICNTRL(7) >= 1).AND.(ICNTRL(7) <= 4) ) THEN - AdjointType = ICNTRL(7) - ELSE - PRINT * , 'User-selected adjoint type: ICNTRL(7)=', AdjointType - CALL ros_ErrorMsg(-9,Tstart,ZERO,IERR) - RETURN - END IF - -!~~~> Save or not the forward LU factorization - SaveLU = (ICNTRL(8) /= 0) - - -!~~~> Unit roundoff (1+Roundoff>1) - Roundoff = WLAMCH('E') - -!~~~> Lower bound on the step size: (positive value) - IF (RCNTRL(1) == ZERO) THEN - Hmin = ZERO - ELSEIF (RCNTRL(1) > ZERO) THEN - Hmin = RCNTRL(1) - ELSE - PRINT * , 'User-selected Hmin: RCNTRL(1)=', RCNTRL(1) - CALL ros_ErrorMsg(-3,Tstart,ZERO,IERR) - RETURN - END IF -!~~~> Upper bound on the step size: (positive value) - IF (RCNTRL(2) == ZERO) THEN - Hmax = ABS(Tend-Tstart) - ELSEIF (RCNTRL(2) > ZERO) THEN - Hmax = MIN(ABS(RCNTRL(2)),ABS(Tend-Tstart)) - ELSE - PRINT * , 'User-selected Hmax: RCNTRL(2)=', RCNTRL(2) - CALL ros_ErrorMsg(-3,Tstart,ZERO,IERR) - RETURN - END IF -!~~~> Starting step size: (positive value) - IF (RCNTRL(3) == ZERO) THEN - Hstart = MAX(Hmin,DeltaMin) - ELSEIF (RCNTRL(3) > ZERO) THEN - Hstart = MIN(ABS(RCNTRL(3)),ABS(Tend-Tstart)) - ELSE - PRINT * , 'User-selected Hstart: RCNTRL(3)=', RCNTRL(3) - CALL ros_ErrorMsg(-3,Tstart,ZERO,IERR) - RETURN - END IF -!~~~> Step size can be changed s.t. FacMin < Hnew/Hold < FacMax - IF (RCNTRL(4) == ZERO) THEN - FacMin = 0.2d0 - ELSEIF (RCNTRL(4) > ZERO) THEN - FacMin = RCNTRL(4) - ELSE - PRINT * , 'User-selected FacMin: RCNTRL(4)=', RCNTRL(4) - CALL ros_ErrorMsg(-4,Tstart,ZERO,IERR) - RETURN - END IF - IF (RCNTRL(5) == ZERO) THEN - FacMax = 6.0d0 - ELSEIF (RCNTRL(5) > ZERO) THEN - FacMax = RCNTRL(5) - ELSE - PRINT * , 'User-selected FacMax: RCNTRL(5)=', RCNTRL(5) - CALL ros_ErrorMsg(-4,Tstart,ZERO,IERR) - RETURN - END IF -!~~~> FacRej: Factor to decrease step after 2 succesive rejections - IF (RCNTRL(6) == ZERO) THEN - FacRej = 0.1d0 - ELSEIF (RCNTRL(6) > ZERO) THEN - FacRej = RCNTRL(6) - ELSE - PRINT * , 'User-selected FacRej: RCNTRL(6)=', RCNTRL(6) - CALL ros_ErrorMsg(-4,Tstart,ZERO,IERR) - RETURN - END IF -!~~~> FacSafe: Safety Factor in the computation of new step size - IF (RCNTRL(7) == ZERO) THEN - FacSafe = 0.9d0 - ELSEIF (RCNTRL(7) > ZERO) THEN - FacSafe = RCNTRL(7) - ELSE - PRINT * , 'User-selected FacSafe: RCNTRL(7)=', RCNTRL(7) - CALL ros_ErrorMsg(-4,Tstart,ZERO,IERR) - RETURN - END IF -!~~~> Check if tolerances are reasonable - DO i=1,UplimTol - IF ( (AbsTol(i) <= ZERO) .OR. (RelTol(i) <= 10.d0*Roundoff) & - .OR. (RelTol(i) >= 1.0d0) ) THEN - PRINT * , ' AbsTol(',i,') = ',AbsTol(i) - PRINT * , ' RelTol(',i,') = ',RelTol(i) - CALL ros_ErrorMsg(-5,Tstart,ZERO,IERR) - RETURN - END IF - END DO - - -!~~~> Allocate checkpoint space or open checkpoint files - IF (AdjointType == Adj_discrete) THEN - CALL ros_AllocateDBuffers( ros_S ) - ELSEIF ( (AdjointType == Adj_continuous).OR. & - (AdjointType == Adj_simple_continuous) ) THEN - CALL ros_AllocateCBuffers - END IF - -!~~~> CALL Forward Rosenbrock method - CALL ros_FwdInt(Y,Tstart,Tend,Texit, & - AbsTol, RelTol, & -! Error indicator - IERR) - - PRINT*,'FORWARD STATISTICS' - PRINT*,'Step=',Nstp,' Acc=',Nacc, & - ' Rej=',Nrej, ' Singular=',Nsng - -!~~~> If Forward integration failed return - IF (IERR<0) RETURN - -!~~~> Initialize the particular Rosenbrock method for continuous adjoint - IF ( (AdjointType == Adj_continuous).OR. & - (AdjointType == Adj_simple_continuous) ) THEN - SELECT CASE (CadjMethod) - CASE (1) - CALL Ros2 - CASE (2) - CALL Ros3 - CASE (3) - CALL Ros4 - CASE (4) - CALL Rodas3 - CASE (5) - CALL Rodas4 - CASE DEFAULT - PRINT * , 'Unknown Rosenbrock method: ICNTRL(3)=', ICNTRL(3) - CALL ros_ErrorMsg(-2,Tstart,ZERO,IERR) - RETURN - END SELECT - END IF - - SELECT CASE (AdjointType) - CASE (Adj_discrete) - CALL ros_DadjInt ( & - NADJ, Lambda, & - Tstart, Tend, Texit, & - IERR ) - CASE (Adj_continuous) - CALL ros_CadjInt ( & - NADJ, Lambda, & - Tend, Tstart, Texit, & - AbsTol_adj, RelTol_adj, & - IERR ) - CASE (Adj_simple_continuous) - CALL ros_SimpleCadjInt ( & - NADJ, Lambda, & - Tstart, Tend, Texit, & - IERR ) - END SELECT ! AdjointType - - PRINT*,'ADJOINT STATISTICS' - PRINT*,'Step=',Nstp,' Acc=',Nacc, & - ' Rej=',Nrej, ' Singular=',Nsng - -!~~~> Free checkpoint space or close checkpoint files - IF (AdjointType == Adj_discrete) THEN - CALL ros_FreeDBuffers - ELSEIF ( (AdjointType == Adj_continuous) .OR. & - (AdjointType == Adj_simple_continuous) ) THEN - CALL ros_FreeCBuffers - END IF - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -CONTAINS ! Procedures internal to RosenbrockADJ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_AllocateDBuffers( S ) -!~~~> Allocate buffer space for discrete adjoint -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - INTEGER :: i, S - - ALLOCATE( chk_H(bufsize), STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed allocation of buffer H'; STOP - END IF - ALLOCATE( chk_T(bufsize), STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed allocation of buffer T'; STOP - END IF - ALLOCATE( chk_Y(NVAR*S,bufsize), STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed allocation of buffer Y'; STOP - END IF - ALLOCATE( chk_K(NVAR*S,bufsize), STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed allocation of buffer K'; STOP - END IF - IF (SaveLU) THEN -#ifdef FULL_ALGEBRA - ALLOCATE( chk_J(NVAR*NVAR,bufsize), STAT=i ) -#else - ALLOCATE( chk_J(LU_NONZERO,bufsize), STAT=i ) -#endif - IF (i/=0) THEN - PRINT*,'Failed allocation of buffer J'; STOP - END IF - END IF - - END SUBROUTINE ros_AllocateDBuffers - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_FreeDBuffers -!~~~> Dallocate buffer space for discrete adjoint -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - INTEGER :: i - - DEALLOCATE( chk_H, STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed deallocation of buffer H'; STOP - END IF - DEALLOCATE( chk_T, STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed deallocation of buffer T'; STOP - END IF - DEALLOCATE( chk_Y, STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed deallocation of buffer Y'; STOP - END IF - DEALLOCATE( chk_K, STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed deallocation of buffer K'; STOP - END IF - IF (SaveLU) THEN - DEALLOCATE( chk_J, STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed deallocation of buffer J'; STOP - END IF - END IF - - END SUBROUTINE ros_FreeDBuffers - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_AllocateCBuffers -!~~~> Allocate buffer space for continuous adjoint -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - INTEGER :: i - - ALLOCATE( chk_H(bufsize), STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed allocation of buffer H'; STOP - END IF - ALLOCATE( chk_T(bufsize), STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed allocation of buffer T'; STOP - END IF - ALLOCATE( chk_Y(NVAR,bufsize), STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed allocation of buffer Y'; STOP - END IF - ALLOCATE( chk_dY(NVAR,bufsize), STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed allocation of buffer dY'; STOP - END IF - ALLOCATE( chk_d2Y(NVAR,bufsize), STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed allocation of buffer d2Y'; STOP - END IF - - END SUBROUTINE ros_AllocateCBuffers - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_FreeCBuffers -!~~~> Dallocate buffer space for continuous adjoint -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - INTEGER :: i - - DEALLOCATE( chk_H, STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed deallocation of buffer H'; STOP - END IF - DEALLOCATE( chk_T, STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed deallocation of buffer T'; STOP - END IF - DEALLOCATE( chk_Y, STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed deallocation of buffer Y'; STOP - END IF - DEALLOCATE( chk_dY, STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed deallocation of buffer dY'; STOP - END IF - DEALLOCATE( chk_d2Y, STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed deallocation of buffer d2Y'; STOP - END IF - - END SUBROUTINE ros_FreeCBuffers - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_DPush( S, T, H, Ystage, K, E, P ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Saves the next trajectory snapshot for discrete adjoints -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - INTEGER :: S ! no of stages - KPP_REAL :: T, H, Ystage(NVAR*S), K(NVAR*S) - INTEGER :: P(NVAR) -#ifdef FULL_ALGEBRA - KPP_REAL :: E(NVAR,NVAR) -#else - KPP_REAL :: E(LU_NONZERO) -#endif - - stack_ptr = stack_ptr + 1 - IF ( stack_ptr > bufsize ) THEN - PRINT*,'Push failed: buffer overflow' - STOP - END IF - chk_H( stack_ptr ) = H - chk_T( stack_ptr ) = T - !CALL WCOPY(NVAR*S,Ystage,1,chk_Y(1,stack_ptr),1) - !CALL WCOPY(NVAR*S,K,1,chk_K(1,stack_ptr),1) - chk_Y(1:NVAR*S,stack_ptr) = Ystage(1:NVAR*S) - chk_K(1:NVAR*S,stack_ptr) = K(1:NVAR*S) - IF (SaveLU) THEN -#ifdef FULL_ALGEBRA - chk_J(1:NVAR,1:NVAR,stack_ptr) = E(1:NVAR,1:NVAR) - chk_P(1:NVAR,stack_ptr) = P(1:NVAR) -#else - chk_J(1:LU_NONZERO,stack_ptr) = E(1:LU_NONZERO) -#endif - END IF - - END SUBROUTINE ros_DPush - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_DPop( S, T, H, Ystage, K, E, P ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Retrieves the next trajectory snapshot for discrete adjoints -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - INTEGER :: S ! no of stages - KPP_REAL :: T, H, Ystage(NVAR*S), K(NVAR*S) - INTEGER :: P(NVAR) -#ifdef FULL_ALGEBRA - KPP_REAL :: E(NVAR,NVAR) -#else - KPP_REAL :: E(LU_NONZERO) -#endif - - IF ( stack_ptr <= 0 ) THEN - PRINT*,'Pop failed: empty buffer' - STOP - END IF - H = chk_H( stack_ptr ) - T = chk_T( stack_ptr ) - !CALL WCOPY(NVAR*S,chk_Y(1,stack_ptr),1,Ystage,1) - !CALL WCOPY(NVAR*S,chk_K(1,stack_ptr),1,K,1) - Ystage(1:NVAR*S) = chk_Y(1:NVAR*S,stack_ptr) - K(1:NVAR*S) = chk_K(1:NVAR*S,stack_ptr) - !CALL WCOPY(LU_NONZERO,chk_J(1,stack_ptr),1,Jcb,1) - IF (SaveLU) THEN -#ifdef FULL_ALGEBRA - E(1:NVAR,1:NVAR) = chk_J(1:NVAR,1:NVAR,stack_ptr) - P(1:NVAR) = chk_P(1:NVAR,stack_ptr) -#else - E(1:LU_NONZERO) = chk_J(1:LU_NONZERO,stack_ptr) -#endif - END IF - - stack_ptr = stack_ptr - 1 - - END SUBROUTINE ros_DPop - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_CPush( T, H, Y, dY, d2Y ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Saves the next trajectory snapshot for discrete adjoints -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - KPP_REAL :: T, H, Y(NVAR), dY(NVAR), d2Y(NVAR) - - stack_ptr = stack_ptr + 1 - IF ( stack_ptr > bufsize ) THEN - PRINT*,'Push failed: buffer overflow' - STOP - END IF - chk_H( stack_ptr ) = H - chk_T( stack_ptr ) = T - !CALL WCOPY(NVAR,Y,1,chk_Y(1,stack_ptr),1) - !CALL WCOPY(NVAR,dY,1,chk_dY(1,stack_ptr),1) - !CALL WCOPY(NVAR,d2Y,1,chk_d2Y(1,stack_ptr),1) - chk_Y(1:NVAR,stack_ptr) = Y(1:NVAR) - chk_dY(1:NVAR,stack_ptr) = dY(1:NVAR) - chk_d2Y(1:NVAR,stack_ptr) = d2Y(1:NVAR) - END SUBROUTINE ros_CPush - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_CPop( T, H, Y, dY, d2Y ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Retrieves the next trajectory snapshot for discrete adjoints -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - KPP_REAL :: T, H, Y(NVAR), dY(NVAR), d2Y(NVAR) - - IF ( stack_ptr <= 0 ) THEN - PRINT*,'Pop failed: empty buffer' - STOP - END IF - H = chk_H( stack_ptr ) - T = chk_T( stack_ptr ) - !CALL WCOPY(NVAR,chk_Y(1,stack_ptr),1,Y,1) - !CALL WCOPY(NVAR,chk_dY(1,stack_ptr),1,dY,1) - !CALL WCOPY(NVAR,chk_d2Y(1,stack_ptr),1,d2Y,1) - Y(1:NVAR) = chk_Y(1:NVAR,stack_ptr) - dY(1:NVAR) = chk_dY(1:NVAR,stack_ptr) - d2Y(1:NVAR) = chk_d2Y(1:NVAR,stack_ptr) - - stack_ptr = stack_ptr - 1 - - END SUBROUTINE ros_CPop - - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_ErrorMsg(Code,T,H,IERR) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Handles all error messages -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - KPP_REAL, INTENT(IN) :: T, H - INTEGER, INTENT(IN) :: Code - INTEGER, INTENT(OUT) :: IERR - - IERR = Code - PRINT * , & - 'Forced exit from RosenbrockADJ due to the following error:' - - SELECT CASE (Code) - CASE (-1) - PRINT * , '--> Improper value for maximal no of steps' - CASE (-2) - PRINT * , '--> Selected RosenbrockADJ method not implemented' - CASE (-3) - PRINT * , '--> Hmin/Hmax/Hstart must be positive' - CASE (-4) - PRINT * , '--> FacMin/FacMax/FacRej must be positive' - CASE (-5) - PRINT * , '--> Improper tolerance values' - CASE (-6) - PRINT * , '--> No of steps exceeds maximum buffer bound' - CASE (-7) - PRINT * , '--> Step size too small: T + 10*H = T', & - ' or H < Roundoff' - CASE (-8) - PRINT * , '--> Matrix is repeatedly singular' - CASE (-9) - PRINT * , '--> Improper type of adjoint selected' - CASE DEFAULT - PRINT *, 'Unknown Error code: ', Code - END SELECT - - PRINT *, "T=", T, "and H=", H - - END SUBROUTINE ros_ErrorMsg - - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_FwdInt (Y, & - Tstart, Tend, T, & - AbsTol, RelTol, & -!~~~> Error indicator - IERR ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Template for the implementation of a generic RosenbrockADJ method -! defined by ros_S (no of stages) -! and its coefficients ros_{A,C,M,E,Alpha,Gamma} -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - -!~~~> Input: the initial condition at Tstart; Output: the solution at T - KPP_REAL, INTENT(INOUT) :: Y(NVAR) -!~~~> Input: integration interval - KPP_REAL, INTENT(IN) :: Tstart,Tend -!~~~> Output: time at which the solution is returned (T=Tend if success) - KPP_REAL, INTENT(OUT) :: T -!~~~> Input: tolerances - KPP_REAL, INTENT(IN) :: AbsTol(NVAR), RelTol(NVAR) -!~~~> Output: Error indicator - INTEGER, INTENT(OUT) :: IERR -! ~~~~ Local variables - KPP_REAL :: Ynew(NVAR), Fcn0(NVAR), Fcn(NVAR) - KPP_REAL :: K(NVAR*ros_S), dFdT(NVAR) - KPP_REAL, DIMENSION(:), POINTER :: Ystage -#ifdef FULL_ALGEBRA - KPP_REAL :: Jac0(NVAR,NVAR), Ghimj(NVAR,NVAR) -#else - KPP_REAL :: Jac0(LU_NONZERO), Ghimj(LU_NONZERO) -#endif - KPP_REAL :: H, Hnew, HC, HG, Fac, Tau - KPP_REAL :: Err, Yerr(NVAR) - INTEGER :: Pivot(NVAR), Direction, ioffset, i, j, istage - LOGICAL :: RejectLastH, RejectMoreH, Singular -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -!~~~> Allocate stage vector buffer if needed - IF (AdjointType == Adj_discrete) THEN - ALLOCATE(Ystage(NVAR*ros_S), STAT=i) - ! Uninitialized Ystage may lead to NaN on some compilers - Ystage = 0.0d0 - IF (i/=0) THEN - PRINT*,'Allocation of Ystage failed' - STOP - END IF - END IF - -!~~~> Initial preparations - T = Tstart - RSTATUS(Nhexit) = ZERO - H = MIN( MAX(ABS(Hmin),ABS(Hstart)) , ABS(Hmax) ) - IF (ABS(H) <= 10.0_dp*Roundoff) H = DeltaMin - - IF (Tend >= Tstart) THEN - Direction = +1 - ELSE - Direction = -1 - END IF - H = Direction*H - - RejectLastH=.FALSE. - RejectMoreH=.FALSE. - -!~~~> Time loop begins below - -TimeLoop: DO WHILE ( (Direction > 0).AND.((T-Tend)+Roundoff <= ZERO) & - .OR. (Direction < 0).AND.((Tend-T)+Roundoff <= ZERO) ) - - IF ( ISTATUS(Nstp) > Max_no_steps ) THEN ! Too many steps - CALL ros_ErrorMsg(-6,T,H,IERR) - RETURN - END IF - IF ( ((T+0.1d0*H) == T).OR.(H <= Roundoff) ) THEN ! Step size too small - CALL ros_ErrorMsg(-7,T,H,IERR) - RETURN - END IF - -!~~~> Limit H if necessary to avoid going beyond Tend - RSTATUS(Nhexit) = H - H = MIN(H,ABS(Tend-T)) - -!~~~> Compute the function at current time - CALL Fun_Template(T,Y,Fcn0) - ISTATUS(Nfun) = ISTATUS(Nfun) + 1 - -!~~~> Compute the function derivative with respect to T - IF (.NOT.Autonomous) THEN - CALL ros_FunTimeDerivative ( T, Roundoff, Y, & - Fcn0, dFdT ) - END IF - -!~~~> Compute the Jacobian at current time - CALL Jac_Template(T,Y,Jac0) - ISTATUS(Njac) = ISTATUS(Njac) + 1 - -!~~~> Repeat step calculation until current step accepted -UntilAccepted: DO - - CALL ros_PrepareMatrix(H,Direction,ros_Gamma(1), & - Jac0,Ghimj,Pivot,Singular) - IF (Singular) THEN ! More than 5 consecutive failed decompositions - CALL ros_ErrorMsg(-8,T,H,IERR) - RETURN - END IF - -!~~~> Compute the stages -Stage: DO istage = 1, ros_S - - ! Current istage offset. Current istage vector is K(ioffset+1:ioffset+NVAR) - ioffset = NVAR*(istage-1) - - ! For the 1st istage the function has been computed previously - IF ( istage == 1 ) THEN - CALL WCOPY(NVAR,Fcn0,1,Fcn,1) - IF (AdjointType == Adj_discrete) THEN ! Save stage solution - ! CALL WCOPY(NVAR,Y,1,Ystage(1),1) - Ystage(1:NVAR) = Y(1:NVAR) - CALL WCOPY(NVAR,Y,1,Ynew,1) - END IF - ! istage>1 and a new function evaluation is needed at the current istage - ELSEIF ( ros_NewF(istage) ) THEN - CALL WCOPY(NVAR,Y,1,Ynew,1) - DO j = 1, istage-1 - CALL WAXPY(NVAR,ros_A((istage-1)*(istage-2)/2+j), & - K(NVAR*(j-1)+1:NVAR*j),1,Ynew,1) - END DO - Tau = T + ros_Alpha(istage)*Direction*H - CALL Fun_Template(Tau,Ynew,Fcn) - ISTATUS(Nfun) = ISTATUS(Nfun) + 1 - END IF ! if istage == 1 elseif ros_NewF(istage) - ! save stage solution every time even if ynew is not updated - IF ( ( istage > 1 ).AND.(AdjointType == Adj_discrete) ) THEN - ! CALL WCOPY(NVAR,Ynew,1,Ystage(ioffset+1:ioffset+NVAR),1) - Ystage(ioffset+1:ioffset+NVAR) = Ynew(1:NVAR) - END IF - !CALL WCOPY(NVAR,Fcn,1,K(ioffset+1:ioffset+NVAR),1) - K(ioffset+1:ioffset+NVAR) = Fcn(1:NVAR) - DO j = 1, istage-1 - HC = ros_C((istage-1)*(istage-2)/2+j)/(Direction*H) - CALL WAXPY(NVAR,HC,K(NVAR*(j-1)+1:NVAR*j),1,K(ioffset+1:ioffset+NVAR),1) - END DO - IF ((.NOT. Autonomous).AND.(ros_Gamma(istage).NE.ZERO)) THEN - HG = Direction*H*ros_Gamma(istage) - CALL WAXPY(NVAR,HG,dFdT,1,K(ioffset+1:ioffset+NVAR),1) - END IF - CALL ros_Solve('N', Ghimj, Pivot, K(ioffset+1:ioffset+NVAR)) - - END DO Stage - - -!~~~> Compute the new solution - CALL WCOPY(NVAR,Y,1,Ynew,1) - DO j=1,ros_S - CALL WAXPY(NVAR,ros_M(j),K(NVAR*(j-1)+1:NVAR*j),1,Ynew,1) - END DO - -!~~~> Compute the error estimation - CALL WSCAL(NVAR,ZERO,Yerr,1) - DO j=1,ros_S - CALL WAXPY(NVAR,ros_E(j),K(NVAR*(j-1)+1:NVAR*j),1,Yerr,1) - END DO - Err = ros_ErrorNorm ( Y, Ynew, Yerr, AbsTol, RelTol, VectorTol ) - -!~~~> New step size is bounded by FacMin <= Hnew/H <= FacMax - Fac = MIN(FacMax,MAX(FacMin,FacSafe/Err**(ONE/ros_ELO))) - Hnew = H*Fac - -!~~~> Check the error magnitude and adjust step size - ISTATUS(Nstp) = ISTATUS(Nstp) + 1 - IF ( (Err <= ONE).OR.(H <= Hmin) ) THEN !~~~> Accept step - ISTATUS(Nacc) = ISTATUS(Nacc) + 1 - IF (AdjointType == Adj_discrete) THEN ! Save current state - CALL ros_DPush( ros_S, T, H, Ystage, K, Ghimj, Pivot ) - ELSEIF ( (AdjointType == Adj_continuous) .OR. & - (AdjointType == Adj_simple_continuous) ) THEN -#ifdef FULL_ALGEBRA - K = MATMUL(Jac0,Fcn0) -#else - CALL Jac_SP_Vec( Jac0, Fcn0, K(1:NVAR) ) -#endif - IF (.NOT. Autonomous) THEN - CALL WAXPY(NVAR,ONE,dFdT,1,K(1:NVAR),1) - END IF - CALL ros_CPush( T, H, Y, Fcn0, K(1:NVAR) ) - END IF - CALL WCOPY(NVAR,Ynew,1,Y,1) - T = T + Direction*H - Hnew = MAX(Hmin,MIN(Hnew,Hmax)) - IF (RejectLastH) THEN ! No step size increase after a rejected step - Hnew = MIN(Hnew,H) - END IF - RSTATUS(Nhexit) = H - RSTATUS(Nhnew) = Hnew - RSTATUS(Ntexit) = T - RejectLastH = .FALSE. - RejectMoreH = .FALSE. - H = Hnew - EXIT UntilAccepted ! EXIT THE LOOP: WHILE STEP NOT ACCEPTED - ELSE !~~~> Reject step - IF (RejectMoreH) THEN - Hnew = H*FacRej - END IF - RejectMoreH = RejectLastH - RejectLastH = .TRUE. - H = Hnew - IF (ISTATUS(Nacc) >= 1) THEN - ISTATUS(Nrej) = ISTATUS(Nrej) + 1 - END IF - END IF ! Err <= 1 - - END DO UntilAccepted - - END DO TimeLoop - -!~~~> Save last state: only needed for continuous adjoint - IF ( (AdjointType == Adj_continuous) .OR. & - (AdjointType == Adj_simple_continuous) ) THEN - CALL Fun_Template(T,Y,Fcn0) - ISTATUS(Nfun) = ISTATUS(Nfun) + 1 - CALL Jac_Template(T,Y,Jac0) - ISTATUS(Njac) = ISTATUS(Njac) + 1 -#ifdef FULL_ALGEBRA - K = MATMUL(Jac0,Fcn0) -#else - CALL Jac_SP_Vec( Jac0, Fcn0, K(1:NVAR) ) -#endif - IF (.NOT. Autonomous) THEN - CALL ros_FunTimeDerivative ( T, Roundoff, Y, & - Fcn0, dFdT ) - CALL WAXPY(NVAR,ONE,dFdT,1,K(1:NVAR),1) - END IF - CALL ros_CPush( T, H, Y, Fcn0, K(1:NVAR) ) -!~~~> Deallocate stage buffer: only needed for discrete adjoint - ELSEIF (AdjointType == Adj_discrete) THEN - DEALLOCATE(Ystage, STAT=i) - IF (i/=0) THEN - PRINT*,'Deallocation of Ystage failed' - STOP - END IF - END IF - -!~~~> Succesful exit - IERR = 1 !~~~> The integration was successful - - END SUBROUTINE ros_FwdInt - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_DadjInt ( & - NADJ, Lambda, & - Tstart, Tend, T, & -!~~~> Error indicator - IERR ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Template for the implementation of a generic RosenbrockSOA method -! defined by ros_S (no of stages) -! and its coefficients ros_{A,C,M,E,Alpha,Gamma} -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - -!~~~> Input: the initial condition at Tstart; Output: the solution at T - INTEGER, INTENT(IN) :: NADJ -!~~~> First order adjoint - KPP_REAL, INTENT(INOUT) :: Lambda(NVAR,NADJ) -!!~~~> Input: integration interval - KPP_REAL, INTENT(IN) :: Tstart,Tend -!~~~> Output: time at which the solution is returned (T=Tend if success) - KPP_REAL, INTENT(OUT) :: T -!~~~> Output: Error indicator - INTEGER, INTENT(OUT) :: IERR -! ~~~~ Local variables - KPP_REAL :: Ystage(NVAR*ros_S), K(NVAR*ros_S) - KPP_REAL :: U(NVAR*ros_S,NADJ), V(NVAR*ros_S,NADJ) -#ifdef FULL_ALGEBRA - KPP_REAL, DIMENSION(NVAR,NVAR) :: Jac, dJdT, Ghimj -#else - KPP_REAL, DIMENSION(LU_NONZERO) :: Jac, dJdT, Ghimj -#endif - KPP_REAL :: Hes0(NHESS) - KPP_REAL :: Tmp(NVAR), Tmp2(NVAR) - KPP_REAL :: H, HC, HA, Tau - INTEGER :: Pivot(NVAR), Direction - INTEGER :: i, j, m, istage, ioffset, joffset -!~~~> Local parameters - KPP_REAL, PARAMETER :: ZERO = 0.0d0, ONE = 1.0d0 - KPP_REAL, PARAMETER :: DeltaMin = 1.0d-5 -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - - - IF (Tend >= Tstart) THEN - Direction = +1 - ELSE - Direction = -1 - END IF - -!~~~> Time loop begins below -TimeLoop: DO WHILE ( stack_ptr > 0 ) - - !~~~> Recover checkpoints for stage values and vectors - CALL ros_DPop( ros_S, T, H, Ystage, K, Ghimj, Pivot ) - -! ISTATUS(Nstp) = ISTATUS(Nstp) + 1 - -!~~~> Compute LU decomposition - IF (.NOT.SaveLU) THEN - CALL Jac_Template(T,Ystage(1:NVAR),Ghimj) - ISTATUS(Njac) = ISTATUS(Njac) + 1 - Tau = ONE/(Direction*H*ros_Gamma(1)) -#ifdef FULL_ALGEBRA - Ghimj(1:NVAR,1:NVAR) = -Ghimj(1:NVAR,1:NVAR) - DO i=1,NVAR - Ghimj(i,i) = Ghimj(i,i)+Tau - END DO -#else - CALL WSCAL(LU_NONZERO,(-ONE),Ghimj,1) - DO i=1,NVAR - Ghimj(LU_DIAG(i)) = Ghimj(LU_DIAG(i))+Tau - END DO -#endif - CALL ros_Decomp( Ghimj, Pivot, j ) - END IF - -!~~~> Compute Hessian at the beginning of the interval - CALL Hess_Template(T,Ystage(1:NVAR),Hes0) - -!~~~> Compute the stages -Stage: DO istage = ros_S, 1, -1 - - !~~~> Current istage first entry - ioffset = NVAR*(istage-1) - - !~~~> Compute U - DO m = 1,NADJ - !CALL WCOPY(NVAR,Lambda(1:NVAR,m),1,U(ioffset+1:ioffset+NVAR,m),1) - U(ioffset+1:ioffset+NVAR,m) = Lambda(1:NVAR,m) - CALL WSCAL(NVAR,ros_M(istage),U(ioffset+1:ioffset+NVAR,m),1) - END DO ! m=1:NADJ - DO j = istage+1, ros_S - joffset = NVAR*(j-1) - HA = ros_A((j-1)*(j-2)/2+istage) - HC = ros_C((j-1)*(j-2)/2+istage)/(Direction*H) - DO m = 1,NADJ - CALL WAXPY(NVAR,HA,V(joffset+1:joffset+NVAR,m),1,U(ioffset+1:ioffset+NVAR,m),1) - CALL WAXPY(NVAR,HC,U(joffset+1:joffset+NVAR,m),1,U(ioffset+1:ioffset+NVAR,m),1) - END DO ! m=1:NADJ - END DO - DO m = 1,NADJ - CALL ros_Solve('T', Ghimj, Pivot, U(ioffset+1:ioffset+NVAR,m)) - END DO ! m=1:NADJ - !~~~> Compute V - Tau = T + ros_Alpha(istage)*Direction*H - CALL Jac_Template(Tau,Ystage(ioffset+1:ioffset+NVAR),Jac) - ISTATUS(Njac) = ISTATUS(Njac) + 1 - DO m = 1,NADJ -#ifdef FULL_ALGEBRA - V(ioffset+1:ioffset+NVAR,m) = MATMUL(TRANSPOSE(Jac),U(ioffset+1:ioffset+NVAR,m)) -#else - CALL JacTR_SP_Vec(Jac,U(ioffset+1:ioffset+NVAR,m),V(ioffset+1:ioffset+NVAR,m)) -#endif - END DO ! m=1:NADJ - - END DO Stage - - IF (.NOT.Autonomous) THEN -!~~~> Compute the Jacobian derivative with respect to T. -! Last "Jac" computed for stage 1 - CALL ros_JacTimeDerivative ( T, Roundoff, Ystage(1), Jac, dJdT ) - END IF - -!~~~> Compute the new solution - - !~~~> Compute Lambda - DO istage=1,ros_S - ioffset = NVAR*(istage-1) - DO m = 1,NADJ - ! Add V_i - CALL WAXPY(NVAR,ONE,V(ioffset+1:ioffset+NVAR,m),1,Lambda(1,m),1) - ! Add (H0xK_i)^T * U_i - CALL HessTR_Vec ( Hes0, U(ioffset+1:ioffset+NVAR,m), & - K(ioffset+1:ioffset+NVAR), Tmp ) - CALL WAXPY(NVAR,ONE,Tmp,1,Lambda(1:NVAR,m),1) - END DO ! m=1:NADJ - END DO - ! Add H * dJac_dT_0^T * \sum(gamma_i U_i) - ! Tmp holds sum gamma_i U_i - IF (.NOT.Autonomous) THEN - DO m = 1,NADJ - Tmp(1:NVAR) = ZERO - DO istage = 1, ros_S - ioffset = NVAR*(istage-1) - CALL WAXPY(NVAR,ros_Gamma(istage),U(ioffset+1:ioffset+NVAR,m),1,Tmp,1) - END DO -#ifdef FULL_ALGEBRA - Tmp2 = MATMUL(TRANSPOSE(dJdT),Tmp) -#else - CALL JacTR_SP_Vec(dJdT,Tmp,Tmp2) -#endif - CALL WAXPY(NVAR,H,Tmp2,1,Lambda(1:NVAR,m),1) - END DO ! m=1:NADJ - END IF ! .NOT.Autonomous - - - END DO TimeLoop - -!~~~> Save last state - -!~~~> Succesful exit - IERR = 1 !~~~> The integration was successful - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - END SUBROUTINE ros_DadjInt -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_CadjInt ( & - NADJ, Y, & - Tstart, Tend, T, & - AbsTol_adj, RelTol_adj, & -!~~~> Error indicator - IERR ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Template for the implementation of a generic RosenbrockADJ method -! defined by ros_S (no of stages) -! and its coefficients ros_{A,C,M,E,Alpha,Gamma} -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - -!~~~> Input: the initial condition at Tstart; Output: the solution at T - INTEGER, INTENT(IN) :: NADJ - KPP_REAL, INTENT(INOUT) :: Y(NVAR,NADJ) -!~~~> Input: integration interval - KPP_REAL, INTENT(IN) :: Tstart,Tend -!~~~> Input: adjoint tolerances - KPP_REAL, INTENT(IN) :: AbsTol_adj(NVAR,NADJ), RelTol_adj(NVAR,NADJ) -!~~~> Output: time at which the solution is returned (T=Tend if success) - KPP_REAL, INTENT(OUT) :: T -!~~~> Output: Error indicator - INTEGER, INTENT(OUT) :: IERR -! ~~~~ Local variables - KPP_REAL :: Y0(NVAR) - KPP_REAL :: Ynew(NVAR,NADJ), Fcn0(NVAR,NADJ), Fcn(NVAR,NADJ) - KPP_REAL :: K(NVAR*ros_S,NADJ), dFdT(NVAR,NADJ) -#ifdef FULL_ALGEBRA - KPP_REAL, DIMENSION(NVAR,NVAR) :: Jac0, Ghimj, Jac, dJdT -#else - KPP_REAL, DIMENSION(LU_NONZERO) :: Jac0, Ghimj, Jac, dJdT -#endif - KPP_REAL :: H, Hnew, HC, HG, Fac, Tau - KPP_REAL :: Err, Yerr(NVAR,NADJ) - INTEGER :: Pivot(NVAR), Direction, ioffset, j, istage, iadj - LOGICAL :: RejectLastH, RejectMoreH, Singular -!~~~> Local parameters - KPP_REAL, PARAMETER :: ZERO = 0.0d0, ONE = 1.0d0 - KPP_REAL, PARAMETER :: DeltaMin = 1.0d-5 -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - -!~~~> Initial preparations - T = Tstart - RSTATUS(Nhexit) = 0.0_dp - H = MIN( MAX(ABS(Hmin),ABS(Hstart)) , ABS(Hmax) ) - IF (ABS(H) <= 10.0_dp*Roundoff) H = DeltaMin - - IF (Tend >= Tstart) THEN - Direction = +1 - ELSE - Direction = -1 - END IF - H = Direction*H - - RejectLastH=.FALSE. - RejectMoreH=.FALSE. - -!~~~> Time loop begins below - -TimeLoop: DO WHILE ( (Direction > 0).AND.((T-Tend)+Roundoff <= ZERO) & - .OR. (Direction < 0).AND.((Tend-T)+Roundoff <= ZERO) ) - - IF ( ISTATUS(Nstp) > Max_no_steps ) THEN ! Too many steps - CALL ros_ErrorMsg(-6,T,H,IERR) - RETURN - END IF - IF ( ((T+0.1d0*H) == T).OR.(H <= Roundoff) ) THEN ! Step size too small - CALL ros_ErrorMsg(-7,T,H,IERR) - RETURN - END IF - -!~~~> Limit H if necessary to avoid going beyond Tend - RSTATUS(Nhexit) = H - H = MIN(H,ABS(Tend-T)) - -!~~~> Interpolate forward solution - CALL ros_cadj_Y( T, Y0 ) -!~~~> Compute the Jacobian at current time - CALL Jac_Template(T, Y0, Jac0) - ISTATUS(Njac) = ISTATUS(Njac) + 1 - -!~~~> Compute the function derivative with respect to T - IF (.NOT.Autonomous) THEN - CALL ros_JacTimeDerivative ( T, Roundoff, Y0, & - Jac0, dJdT ) - DO iadj = 1, NADJ -#ifdef FULL_ALGEBRA - dFdT(1:NVAR,iadj) = MATMUL(TRANSPOSE(dJdT),Y(1:NVAR,iadj)) -#else - CALL JacTR_SP_Vec(dJdT,Y(1:NVAR,iadj),dFdT(1:NVAR,iadj)) -#endif - CALL WSCAL(NVAR,(-ONE),dFdT(1:NVAR,iadj),1) - END DO - END IF - -!~~~> Ydot = -J^T*Y -#ifdef FULL_ALGEBRA - Jac0(1:NVAR,1:NVAR) = -Jac0(1:NVAR,1:NVAR) -#else - CALL WSCAL(LU_NONZERO,(-ONE),Jac0,1) -#endif - DO iadj = 1, NADJ -#ifdef FULL_ALGEBRA - Fcn0(1:NVAR,iadj) = MATMUL(TRANSPOSE(Jac0),Y(1:NVAR,iadj)) -#else - CALL JacTR_SP_Vec(Jac0,Y(1:NVAR,iadj),Fcn0(1:NVAR,iadj)) -#endif - END DO - -!~~~> Repeat step calculation until current step accepted -UntilAccepted: DO - - CALL ros_PrepareMatrix(H,Direction,ros_Gamma(1), & - Jac0,Ghimj,Pivot,Singular) - IF (Singular) THEN ! More than 5 consecutive failed decompositions - CALL ros_ErrorMsg(-8,T,H,IERR) - RETURN - END IF - -!~~~> Compute the stages -Stage: DO istage = 1, ros_S - - ! Current istage offset. Current istage vector is K(ioffset+1:ioffset+NVAR) - ioffset = NVAR*(istage-1) - - ! For the 1st istage the function has been computed previously - IF ( istage == 1 ) THEN - DO iadj = 1, NADJ - !CALL WCOPY(NVAR,Fcn0(1,iadj),1,Fcn(1,iadj),1) - Fcn(1:NVAR,iadj) = Fcn0(1:NVAR,iadj) - END DO - ! istage>1 and a new function evaluation is needed at the current istage - ELSEIF ( ros_NewF(istage) ) THEN - CALL WCOPY(NVAR*NADJ,Y,1,Ynew,1) - DO j = 1, istage-1 - DO iadj = 1, NADJ - CALL WAXPY(NVAR,ros_A((istage-1)*(istage-2)/2+j), & - K(NVAR*(j-1)+1:NVAR*j,iadj),1,Ynew(1,iadj),1) - END DO - END DO - Tau = T + ros_Alpha(istage)*Direction*H - ! CALL Fun_Template(Tau,Ynew,Fcn) - ! ISTATUS(Nfun) = ISTATUS(Nfun) + 1 - CALL ros_cadj_Y( Tau, Y0 ) - CALL Jac_Template(Tau, Y0, Jac) - ISTATUS(Njac) = ISTATUS(Njac) + 1 -#ifdef FULL_ALGEBRA - Jac(1:NVAR,1:NVAR) = -Jac(1:NVAR,1:NVAR) -#else - CALL WSCAL(LU_NONZERO,(-ONE),Jac,1) -#endif - DO iadj = 1, NADJ -#ifdef FULL_ALGEBRA - Fcn(1:NVAR,iadj) = MATMUL(TRANSPOSE(Jac),Ynew(1:NVAR,iadj)) -#else - CALL JacTR_SP_Vec(Jac,Ynew(1:NVAR,iadj),Fcn(1:NVAR,iadj)) -#endif - !CALL WSCAL(NVAR,(-ONE),Fcn(1,iadj),1) - END DO - END IF ! if istage == 1 elseif ros_NewF(istage) - - DO iadj = 1, NADJ - !CALL WCOPY(NVAR,Fcn(1,iadj),1,K(ioffset+1,iadj),1) - K(ioffset+1:ioffset+NVAR,iadj) = Fcn(1:NVAR,iadj) - END DO - DO j = 1, istage-1 - HC = ros_C((istage-1)*(istage-2)/2+j)/(Direction*H) - DO iadj = 1, NADJ - CALL WAXPY(NVAR,HC,K(NVAR*(j-1)+1:NVAR*j,iadj),1, & - K(ioffset+1:ioffset+NVAR,iadj),1) - END DO - END DO - IF ((.NOT. Autonomous).AND.(ros_Gamma(istage).NE.ZERO)) THEN - HG = Direction*H*ros_Gamma(istage) - DO iadj = 1, NADJ - CALL WAXPY(NVAR,HG,dFdT(1:NVAR,iadj),1,K(ioffset+1:ioffset+NVAR,iadj),1) - END DO - END IF - DO iadj = 1, NADJ - CALL ros_Solve('T', Ghimj, Pivot, K(ioffset+1:ioffset+NVAR,iadj)) - END DO - - END DO Stage - - -!~~~> Compute the new solution - DO iadj = 1, NADJ - !CALL WCOPY(NVAR,Y(1:NVAR,iadj),1,Ynew(1,iadj),1) - Ynew(1:NVAR,iadj) = Y(1:NVAR,iadj) - DO j=1,ros_S - CALL WAXPY(NVAR,ros_M(j),K(NVAR*(j-1)+1:NVAR*j,iadj),1,Ynew(1:NVAR,iadj),1) - END DO - END DO - -!~~~> Compute the error estimation - CALL WSCAL(NVAR*NADJ,ZERO,Yerr,1) - DO j=1,ros_S - DO iadj = 1, NADJ - CALL WAXPY(NVAR,ros_E(j),K(NVAR*(j-1)+1:NVAR*j,iadj),1,Yerr(1:NVAR,iadj),1) - END DO - END DO -!~~~> Max error among all adjoint components - iadj = 1 - Err = ros_ErrorNorm ( Y(1:NVAR,iadj), Ynew(1,iadj), Yerr(1,iadj), & - AbsTol_adj(1,iadj), RelTol_adj(1,iadj), VectorTol ) - -!~~~> New step size is bounded by FacMin <= Hnew/H <= FacMax - Fac = MIN(FacMax,MAX(FacMin,FacSafe/Err**(ONE/ros_ELO))) - Hnew = H*Fac - -!~~~> Check the error magnitude and adjust step size -! ISTATUS(Nstp) = ISTATUS(Nstp) + 1 - IF ( (Err <= ONE).OR.(H <= Hmin) ) THEN !~~~> Accept step - ISTATUS(Nacc) = ISTATUS(Nacc) + 1 - CALL WCOPY(NVAR*NADJ,Ynew,1,Y,1) - T = T + Direction*H - Hnew = MAX(Hmin,MIN(Hnew,Hmax)) - IF (RejectLastH) THEN ! No step size increase after a rejected step - Hnew = MIN(Hnew,H) - END IF - RSTATUS(Nhexit) = H - RSTATUS(Nhnew) = Hnew - RSTATUS(Ntexit) = T - RejectLastH = .FALSE. - RejectMoreH = .FALSE. - H = Hnew - EXIT UntilAccepted ! EXIT THE LOOP: WHILE STEP NOT ACCEPTED - ELSE !~~~> Reject step - IF (RejectMoreH) THEN - Hnew = H*FacRej - END IF - RejectMoreH = RejectLastH - RejectLastH = .TRUE. - H = Hnew - IF (ISTATUS(Nacc) >= 1) THEN - ISTATUS(Nrej) = ISTATUS(Nrej) + 1 - END IF - END IF ! Err <= 1 - - END DO UntilAccepted - - END DO TimeLoop - -!~~~> Succesful exit - IERR = 1 !~~~> The integration was successful - - END SUBROUTINE ros_CadjInt - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_SimpleCadjInt ( & - NADJ, Y, & - Tstart, Tend, T, & -!~~~> Error indicator - IERR ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Template for the implementation of a generic RosenbrockADJ method -! defined by ros_S (no of stages) -! and its coefficients ros_{A,C,M,E,Alpha,Gamma} -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - -!~~~> Input: the initial condition at Tstart; Output: the solution at T - INTEGER, INTENT(IN) :: NADJ - KPP_REAL, INTENT(INOUT) :: Y(NVAR,NADJ) -!~~~> Input: integration interval - KPP_REAL, INTENT(IN) :: Tstart,Tend -!~~~> Output: time at which the solution is returned (T=Tend if success) - KPP_REAL, INTENT(OUT) :: T -!~~~> Output: Error indicator - INTEGER, INTENT(OUT) :: IERR -! ~~~~ Local variables - KPP_REAL :: Y0(NVAR) - KPP_REAL :: Ynew(NVAR,NADJ), Fcn0(NVAR,NADJ), Fcn(NVAR,NADJ) - KPP_REAL :: K(NVAR*ros_S,NADJ), dFdT(NVAR,NADJ) -#ifdef FULL_ALGEBRA - KPP_REAL,DIMENSION(NVAR,NVAR) :: Jac0, Ghimj, Jac, dJdT -#else - KPP_REAL,DIMENSION(LU_NONZERO) :: Jac0, Ghimj, Jac, dJdT -#endif - KPP_REAL :: H, HC, HG, Tau - KPP_REAL :: ghinv - INTEGER :: Pivot(NVAR), Direction, ioffset, i, j, istage, iadj - INTEGER :: istack -!~~~> Local parameters - KPP_REAL, PARAMETER :: ZERO = 0.0d0, ONE = 1.0d0 - KPP_REAL, PARAMETER :: DeltaMin = 1.0d-5 -!~~~> Locally called functions -! KPP_REAL WLAMCH -! EXTERNAL WLAMCH -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - -!~~~> INITIAL PREPARATIONS - - IF (Tend >= Tstart) THEN - Direction = -1 - ELSE - Direction = +1 - END IF - -!~~~> Time loop begins below -TimeLoop: DO istack = stack_ptr,2,-1 - - T = chk_T(istack) - H = chk_H(istack-1) - !CALL WCOPY(NVAR,chk_Y(1,istack),1,Y0,1) - Y0(1:NVAR) = chk_Y(1:NVAR,istack) - -!~~~> Compute the Jacobian at current time - CALL Jac_Template(T, Y0, Jac0) - ISTATUS(Njac) = ISTATUS(Njac) + 1 - -!~~~> Compute the function derivative with respect to T - IF (.NOT.Autonomous) THEN - CALL ros_JacTimeDerivative ( T, Roundoff, Y0, & - Jac0, dJdT ) - DO iadj = 1, NADJ -#ifdef FULL_ALGEBRA - dFdT(1:NVAR,iadj) = MATMUL(TRANSPOSE(dJdT),Y(1:NVAR,iadj)) -#else - CALL JacTR_SP_Vec(dJdT,Y(1:NVAR,iadj),dFdT(1:NVAR,iadj)) -#endif - CALL WSCAL(NVAR,(-ONE),dFdT(1:NVAR,iadj),1) - END DO - END IF - -!~~~> Ydot = -J^T*Y -#ifdef FULL_ALGEBRA - Jac0(1:NVAR,1:NVAR) = -Jac0(1:NVAR,1:NVAR) -#else - CALL WSCAL(LU_NONZERO,(-ONE),Jac0,1) -#endif - DO iadj = 1, NADJ -#ifdef FULL_ALGEBRA - Fcn0(1:NVAR,iadj) = MATMUL(TRANSPOSE(Jac0),Y(1:NVAR,iadj)) -#else - CALL JacTR_SP_Vec(Jac0,Y(1:NVAR,iadj),Fcn0(1:NVAR,iadj)) -#endif - END DO - -!~~~> Construct Ghimj = 1/(H*ham) - Jac0 - ghinv = ONE/(Direction*H*ros_Gamma(1)) -#ifdef FULL_ALGEBRA - Ghimj(1:NVAR,1:NVAR) = -Jac0(1:NVAR,1:NVAR) - DO i=1,NVAR - Ghimj(i,i) = Ghimj(i,i)+ghinv - END DO -#else - CALL WCOPY(LU_NONZERO,Jac0,1,Ghimj,1) - CALL WSCAL(LU_NONZERO,(-ONE),Ghimj,1) - DO i=1,NVAR - Ghimj(LU_DIAG(i)) = Ghimj(LU_DIAG(i))+ghinv - END DO -#endif -!~~~> Compute LU decomposition - CALL ros_Decomp( Ghimj, Pivot, j ) - IF (j /= 0) THEN - CALL ros_ErrorMsg(-8,T,H,IERR) - PRINT*,' The matrix is singular !' - STOP - END IF - -!~~~> Compute the stages -Stage: DO istage = 1, ros_S - - ! Current istage offset. Current istage vector is K(ioffset+1:ioffset+NVAR) - ioffset = NVAR*(istage-1) - - ! For the 1st istage the function has been computed previously - IF ( istage == 1 ) THEN - DO iadj = 1, NADJ - CALL WCOPY(NVAR,Fcn0(1,iadj),1,Fcn(1,iadj),1) - END DO - ! istage>1 and a new function evaluation is needed at the current istage - ELSEIF ( ros_NewF(istage) ) THEN - CALL WCOPY(NVAR*NADJ,Y,1,Ynew,1) - DO j = 1, istage-1 - DO iadj = 1, NADJ - CALL WAXPY(NVAR,ros_A((istage-1)*(istage-2)/2+j), & - K(NVAR*(j-1)+1:NVAR*j,iadj),1,Ynew(1:NVAR,iadj),1) - END DO - END DO - Tau = T + ros_Alpha(istage)*Direction*H - CALL ros_Hermite3( chk_T(istack-1), chk_T(istack), Tau, & - chk_Y(1:NVAR,istack-1), chk_Y(1:NVAR,istack), & - chk_dY(1:NVAR,istack-1), chk_dY(1:NVAR,istack), Y0 ) - CALL Jac_Template(Tau, Y0, Jac) - ISTATUS(Njac) = ISTATUS(Njac) + 1 -#ifdef FULL_ALGEBRA - Jac(1:NVAR,1:NVAR) = -Jac(1:NVAR,1:NVAR) -#else - CALL WSCAL(LU_NONZERO,(-ONE),Jac,1) -#endif - DO iadj = 1, NADJ -#ifdef FULL_ALGEBRA - Fcn(1:NVAR,iadj) = MATMUL(TRANSPOSE(Jac),Ynew(1:NVAR,iadj)) -#else - CALL JacTR_SP_Vec(Jac,Ynew(1:NVAR,iadj),Fcn(1:NVAR,iadj)) -#endif - END DO - END IF ! if istage == 1 elseif ros_NewF(istage) - - DO iadj = 1, NADJ - CALL WCOPY(NVAR,Fcn(1,iadj),1,K(ioffset+1,iadj),1) - END DO - DO j = 1, istage-1 - HC = ros_C((istage-1)*(istage-2)/2+j)/(Direction*H) - DO iadj = 1, NADJ - CALL WAXPY(NVAR,HC,K(NVAR*(j-1)+1:NVAR*j,iadj),1, & - K(ioffset+1:ioffset+NVAR,iadj),1) - END DO - END DO - IF ((.NOT. Autonomous).AND.(ros_Gamma(istage).NE.ZERO)) THEN - HG = Direction*H*ros_Gamma(istage) - DO iadj = 1, NADJ - CALL WAXPY(NVAR,HG,dFdT(1:NVAR,iadj),1,K(ioffset+1:ioffset+NVAR,iadj),1) - END DO - END IF - DO iadj = 1, NADJ - CALL ros_Solve('T', Ghimj, Pivot, K(ioffset+1:ioffset+NVAR,iadj)) - END DO - - END DO Stage - - -!~~~> Compute the new solution - DO iadj = 1, NADJ - DO j=1,ros_S - CALL WAXPY(NVAR,ros_M(j),K(NVAR*(j-1)+1:NVAR*j,iadj),1,Y(1:NVAR,iadj),1) - END DO - END DO - - END DO TimeLoop - -!~~~> Succesful exit - IERR = 1 !~~~> The integration was successful - - END SUBROUTINE ros_SimpleCadjInt - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - KPP_REAL FUNCTION ros_ErrorNorm ( Y, Ynew, Yerr, & - AbsTol, RelTol, VectorTol ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Computes the "scaled norm" of the error vector Yerr -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - -! Input arguments - KPP_REAL, INTENT(IN) :: Y(NVAR), Ynew(NVAR), & - Yerr(NVAR), AbsTol(NVAR), RelTol(NVAR) - LOGICAL, INTENT(IN) :: VectorTol -! Local variables - KPP_REAL :: Err, Scale, Ymax - INTEGER :: i - - Err = ZERO - DO i=1,NVAR - Ymax = MAX(ABS(Y(i)),ABS(Ynew(i))) - IF (VectorTol) THEN - Scale = AbsTol(i)+RelTol(i)*Ymax - ELSE - Scale = AbsTol(1)+RelTol(1)*Ymax - END IF - Err = Err+(Yerr(i)/Scale)**2 - END DO - Err = SQRT(Err/NVAR) - - ros_ErrorNorm = MAX(Err,1.0d-10) - - END FUNCTION ros_ErrorNorm - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_FunTimeDerivative ( T, Roundoff, Y, Fcn0, dFdT ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> The time partial derivative of the function by finite differences -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - -!~~~> Input arguments - KPP_REAL, INTENT(IN) :: T, Roundoff, Y(NVAR), Fcn0(NVAR) -!~~~> Output arguments - KPP_REAL, INTENT(OUT) :: dFdT(NVAR) -!~~~> Local variables - KPP_REAL :: Delta - KPP_REAL, PARAMETER :: ONE = 1.0d0, DeltaMin = 1.0d-6 - - Delta = SQRT(Roundoff)*MAX(DeltaMin,ABS(T)) - CALL Fun_Template(T+Delta,Y,dFdT) - ISTATUS(Nfun) = ISTATUS(Nfun) + 1 - CALL WAXPY(NVAR,(-ONE),Fcn0,1,dFdT,1) - CALL WSCAL(NVAR,(ONE/Delta),dFdT,1) - - END SUBROUTINE ros_FunTimeDerivative - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_JacTimeDerivative ( T, Roundoff, Y, & - Jac0, dJdT ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> The time partial derivative of the Jacobian by finite differences -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - -!~~~> Arguments - KPP_REAL, INTENT(IN) :: T, Roundoff, Y(NVAR) -#ifdef FULL_ALGEBRA - KPP_REAL, INTENT(IN) :: Jac0(NVAR,NVAR) - KPP_REAL, INTENT(OUT) :: dJdT(NVAR,NVAR) -#else - KPP_REAL, INTENT(IN) :: Jac0(LU_NONZERO) - KPP_REAL, INTENT(OUT) :: dJdT(LU_NONZERO) -#endif -!~~~> Local variables - KPP_REAL :: Delta - - Delta = SQRT(Roundoff)*MAX(DeltaMin,ABS(T)) - CALL Jac_Template(T+Delta,Y,dJdT) - ISTATUS(Njac) = ISTATUS(Njac) + 1 -#ifdef FULL_ALGEBRA - CALL WAXPY(NVAR*NVAR,(-ONE),Jac0,1,dJdT,1) - CALL WSCAL(NVAR*NVAR,(ONE/Delta),dJdT,1) -#else - CALL WAXPY(LU_NONZERO,(-ONE),Jac0,1,dJdT,1) - CALL WSCAL(LU_NONZERO,(ONE/Delta),dJdT,1) -#endif - - END SUBROUTINE ros_JacTimeDerivative - - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_PrepareMatrix ( H, Direction, gam, & - Jac0, Ghimj, Pivot, Singular ) -! --- --- --- --- --- --- --- --- --- --- --- --- --- -! Prepares the LHS matrix for stage calculations -! 1. Construct Ghimj = 1/(H*gam) - Jac0 -! "(Gamma H) Inverse Minus Jacobian" -! 2. Repeat LU decomposition of Ghimj until successful. -! -half the step size if LU decomposition fails and retry -! -exit after 5 consecutive fails -! --- --- --- --- --- --- --- --- --- --- --- --- --- - IMPLICIT NONE - -!~~~> Input arguments -#ifdef FULL_ALGEBRA - KPP_REAL, INTENT(IN) :: Jac0(NVAR,NVAR) -#else - KPP_REAL, INTENT(IN) :: Jac0(LU_NONZERO) -#endif - KPP_REAL, INTENT(IN) :: gam - INTEGER, INTENT(IN) :: Direction -!~~~> Output arguments -#ifdef FULL_ALGEBRA - KPP_REAL, INTENT(OUT) :: Ghimj(NVAR,NVAR) -#else - KPP_REAL, INTENT(OUT) :: Ghimj(LU_NONZERO) -#endif - LOGICAL, INTENT(OUT) :: Singular - INTEGER, INTENT(OUT) :: Pivot(NVAR) -!~~~> Inout arguments - KPP_REAL, INTENT(INOUT) :: H ! step size is decreased when LU fails -!~~~> Local variables - INTEGER :: i, ising, Nconsecutive - KPP_REAL :: ghinv - KPP_REAL, PARAMETER :: ONE = 1.0_dp, HALF = 0.5_dp - - Nconsecutive = 0 - Singular = .TRUE. - - DO WHILE (Singular) - -!~~~> Construct Ghimj = 1/(H*gam) - Jac0 -#ifdef FULL_ALGEBRA - CALL WCOPY(NVAR*NVAR,Jac0,1,Ghimj,1) - CALL WSCAL(NVAR*NVAR,(-ONE),Ghimj,1) - ghinv = ONE/(Direction*H*gam) - DO i=1,NVAR - Ghimj(i,i) = Ghimj(i,i)+ghinv - END DO -#else - CALL WCOPY(LU_NONZERO,Jac0,1,Ghimj,1) - CALL WSCAL(LU_NONZERO,(-ONE),Ghimj,1) - ghinv = ONE/(Direction*H*gam) - DO i=1,NVAR - Ghimj(LU_DIAG(i)) = Ghimj(LU_DIAG(i))+ghinv - END DO -#endif -!~~~> Compute LU decomposition - CALL ros_Decomp( Ghimj, Pivot, ising ) - IF (ising == 0) THEN -!~~~> If successful done - Singular = .FALSE. - ELSE ! ising .ne. 0 -!~~~> If unsuccessful half the step size; if 5 consecutive fails then return - ISTATUS(Nsng) = ISTATUS(Nsng) + 1 - Nconsecutive = Nconsecutive+1 - Singular = .TRUE. - PRINT*,'Warning: LU Decomposition returned ising = ',ising - IF (Nconsecutive <= 5) THEN ! Less than 5 consecutive failed decompositions - H = H*HALF - ELSE ! More than 5 consecutive failed decompositions - RETURN - END IF ! Nconsecutive - END IF ! ising - - END DO ! WHILE Singular - - END SUBROUTINE ros_PrepareMatrix - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_Decomp( A, Pivot, ising ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Template for the LU decomposition -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE -!~~~> Inout variables -#ifdef FULL_ALGEBRA - KPP_REAL, INTENT(INOUT) :: A(NVAR,NVAR) -#else - KPP_REAL, INTENT(INOUT) :: A(LU_NONZERO) -#endif -!~~~> Output variables - INTEGER, INTENT(OUT) :: Pivot(NVAR), ising - -#ifdef FULL_ALGEBRA - CALL DGETRF( NVAR, NVAR, A, NVAR, Pivot, ising ) -#else - CALL KppDecomp ( A, ising ) - Pivot(1) = 1 -#endif - ISTATUS(Ndec) = ISTATUS(Ndec) + 1 - - END SUBROUTINE ros_Decomp - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_Solve( How, A, Pivot, b ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Template for the forward/backward substitution (using pre-computed LU decomposition) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE -!~~~> Input variables - CHARACTER, INTENT(IN) :: How -#ifdef FULL_ALGEBRA - KPP_REAL, INTENT(IN) :: A(NVAR,NVAR) -#else - KPP_REAL, INTENT(IN) :: A(LU_NONZERO) -#endif - INTEGER, INTENT(IN) :: Pivot(NVAR) -!~~~> InOut variables - KPP_REAL, INTENT(INOUT) :: b(NVAR) - - SELECT CASE (How) - CASE ('N') -#ifdef FULL_ALGEBRA - CALL DGETRS( 'N', NVAR , 1, A, NVAR, Pivot, b, NVAR, 0 ) -#else - CALL KppSolve( A, b ) -#endif - CASE ('T') -#ifdef FULL_ALGEBRA - CALL DGETRS( 'T', NVAR , 1, A, NVAR, Pivot, b, NVAR, 0 ) -#else - CALL KppSolveTR( A, b, b ) -#endif - CASE DEFAULT - PRINT*,'Error: unknown argument in ros_Solve: How=',How - STOP - END SELECT - ISTATUS(Nsol) = ISTATUS(Nsol) + 1 - - END SUBROUTINE ros_Solve - - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_cadj_Y( T, Y ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Finds the solution Y at T by interpolating the stored forward trajectory -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE -!~~~> Input variables - KPP_REAL, INTENT(IN) :: T -!~~~> Output variables - KPP_REAL, INTENT(OUT) :: Y(NVAR) -!~~~> Local variables - INTEGER :: i - KPP_REAL, PARAMETER :: ONE = 1.0d0 - -! chk_H, chk_T, chk_Y, chk_dY, chk_d2Y - - IF( (T < chk_T(1)).OR.(T> chk_T(stack_ptr)) ) THEN - PRINT*,'Cannot locate solution at T = ',T - PRINT*,'Stored trajectory is between Tstart = ',chk_T(1) - PRINT*,' and Tend = ',chk_T(stack_ptr) - STOP - END IF - DO i = 1, stack_ptr-1 - IF( (T>= chk_T(i)).AND.(T<= chk_T(i+1)) ) EXIT - END DO - - -! IF (.FALSE.) THEN -! -! CALL ros_Hermite5( chk_T(i), chk_T(i+1), T, & -! chk_Y(1,i), chk_Y(1,i+1), & -! chk_dY(1,i), chk_dY(1,i+1), & -! chk_d2Y(1,i), chk_d2Y(1,i+1), Y ) -! -! ELSE - - CALL ros_Hermite3( chk_T(i), chk_T(i+1), T, & - chk_Y(1:NVAR,i), chk_Y(1:NVAR,i+1), & - chk_dY(1:NVAR,i), chk_dY(1:NVAR,i+1), & - Y ) - -! -! END IF - - END SUBROUTINE ros_cadj_Y - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_Hermite3( a, b, T, Ya, Yb, Ja, Jb, Y ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Template for Hermite interpolation of order 5 on the interval [a,b] -! P = c(1) + c(2)*(x-a) + ... + c(4)*(x-a)^3 -! P[a,b] = [Ya,Yb], P'[a,b] = [Ja,Jb] -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE -!~~~> Input variables - KPP_REAL, INTENT(IN) :: a, b, T, Ya(NVAR), Yb(NVAR) - KPP_REAL, INTENT(IN) :: Ja(NVAR), Jb(NVAR) -!~~~> Output variables - KPP_REAL, INTENT(OUT) :: Y(NVAR) -!~~~> Local variables - KPP_REAL :: Tau, amb(3), C(NVAR,4) - KPP_REAL, PARAMETER :: ZERO = 0.0d0 - INTEGER :: i, j - - amb(1) = 1.0d0/(a-b) - DO i=2,3 - amb(i) = amb(i-1)*amb(1) - END DO - - -! c(1) = ya; - CALL WCOPY(NVAR,Ya,1,C(1:NVAR,1),1) -! c(2) = ja; - CALL WCOPY(NVAR,Ja,1,C(1:NVAR,2),1) -! c(3) = 2/(a-b)*ja + 1/(a-b)*jb - 3/(a - b)^2*ya + 3/(a - b)^2*yb ; - CALL WCOPY(NVAR,Ya,1,C(1:NVAR,3),1) - CALL WSCAL(NVAR,-3.0*amb(2),C(1:NVAR,3),1) - CALL WAXPY(NVAR,3.0*amb(2),Yb,1,C(1:NVAR,3),1) - CALL WAXPY(NVAR,2.0*amb(1),Ja,1,C(1:NVAR,3),1) - CALL WAXPY(NVAR,amb(1),Jb,1,C(1:NVAR,3),1) -! c(4) = 1/(a-b)^2*ja + 1/(a-b)^2*jb - 2/(a-b)^3*ya + 2/(a-b)^3*yb ; - CALL WCOPY(NVAR,Ya,1,C(1:NVAR,4),1) - CALL WSCAL(NVAR,-2.0*amb(3),C(1:NVAR,4),1) - CALL WAXPY(NVAR,2.0*amb(3),Yb,1,C(1:NVAR,4),1) - CALL WAXPY(NVAR,amb(2),Ja,1,C(1:NVAR,4),1) - CALL WAXPY(NVAR,amb(2),Jb,1,C(1:NVAR,4),1) - - Tau = T - a - CALL WCOPY(NVAR,C(1:NVAR,4),1,Y,1) - CALL WSCAL(NVAR,Tau**3,Y,1) - DO j = 3,1,-1 - CALL WAXPY(NVAR,TAU**(j-1),C(1:NVAR,j),1,Y,1) - END DO - - END SUBROUTINE ros_Hermite3 - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_Hermite5( a, b, T, Ya, Yb, Ja, Jb, Ha, Hb, Y ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Template for Hermite interpolation of order 5 on the interval [a,b] -! P = c(1) + c(2)*(x-a) + ... + c(6)*(x-a)^5 -! P[a,b] = [Ya,Yb], P'[a,b] = [Ja,Jb], P"[a,b] = [Ha,Hb] -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE -!~~~> Input variables - KPP_REAL, INTENT(IN) :: a, b, T, Ya(NVAR), Yb(NVAR) - KPP_REAL, INTENT(IN) :: Ja(NVAR), Jb(NVAR), Ha(NVAR), Hb(NVAR) -!~~~> Output variables - KPP_REAL, INTENT(OUT) :: Y(NVAR) -!~~~> Local variables - KPP_REAL :: Tau, amb(5), C(NVAR,6) - KPP_REAL, PARAMETER :: ZERO = 0.0d0, HALF = 0.5d0 - INTEGER :: i, j - - amb(1) = 1.0d0/(a-b) - DO i=2,5 - amb(i) = amb(i-1)*amb(1) - END DO - -! c(1) = ya; - CALL WCOPY(NVAR,Ya,1,C(1:NVAR,1),1) -! c(2) = ja; - CALL WCOPY(NVAR,Ja,1,C(1:NVAR,2),1) -! c(3) = ha/2; - CALL WCOPY(NVAR,Ha,1,C(1:NVAR,3),1) - CALL WSCAL(NVAR,HALF,C(1:NVAR,3),1) - -! c(4) = 10*amb(3)*ya - 10*amb(3)*yb - 6*amb(2)*ja - 4*amb(2)*jb + 1.5*amb(1)*ha - 0.5*amb(1)*hb ; - CALL WCOPY(NVAR,Ya,1,C(1:NVAR,4),1) - CALL WSCAL(NVAR,10.0*amb(3),C(1:NVAR,4),1) - CALL WAXPY(NVAR,-10.0*amb(3),Yb,1,C(1:NVAR,4),1) - CALL WAXPY(NVAR,-6.0*amb(2),Ja,1,C(1:NVAR,4),1) - CALL WAXPY(NVAR,-4.0*amb(2),Jb,1,C(1:NVAR,4),1) - CALL WAXPY(NVAR, 1.5*amb(1),Ha,1,C(1:NVAR,4),1) - CALL WAXPY(NVAR,-0.5*amb(1),Hb,1,C(1:NVAR,4),1) - -! c(5) = 15*amb(4)*ya - 15*amb(4)*yb - 8.*amb(3)*ja - 7*amb(3)*jb + 1.5*amb(2)*ha - 1*amb(2)*hb ; - CALL WCOPY(NVAR,Ya,1,C(1:NVAR,5),1) - CALL WSCAL(NVAR, 15.0*amb(4),C(1:NVAR,5),1) - CALL WAXPY(NVAR,-15.0*amb(4),Yb,1,C(1:NVAR,5),1) - CALL WAXPY(NVAR,-8.0*amb(3),Ja,1,C(1:NVAR,5),1) - CALL WAXPY(NVAR,-7.0*amb(3),Jb,1,C(1:NVAR,5),1) - CALL WAXPY(NVAR,1.5*amb(2),Ha,1,C(1:NVAR,5),1) - CALL WAXPY(NVAR,-amb(2),Hb,1,C(1:NVAR,5),1) - -! c(6) = 6*amb(5)*ya - 6*amb(5)*yb - 3.*amb(4)*ja - 3.*amb(4)*jb + 0.5*amb(3)*ha -0.5*amb(3)*hb ; - CALL WCOPY(NVAR,Ya,1,C(1:NVAR,6),1) - CALL WSCAL(NVAR, 6.0*amb(5),C(1:NVAR,6),1) - CALL WAXPY(NVAR,-6.0*amb(5),Yb,1,C(1:NVAR,6),1) - CALL WAXPY(NVAR,-3.0*amb(4),Ja,1,C(1:NVAR,6),1) - CALL WAXPY(NVAR,-3.0*amb(4),Jb,1,C(1:NVAR,6),1) - CALL WAXPY(NVAR, 0.5*amb(3),Ha,1,C(1:NVAR,6),1) - CALL WAXPY(NVAR,-0.5*amb(3),Hb,1,C(1:NVAR,6),1) - - Tau = T - a - CALL WCOPY(NVAR,C(1:NVAR,6),1,Y,1) - DO j = 5,1,-1 - CALL WSCAL(NVAR,Tau,Y,1) - CALL WAXPY(NVAR,ONE,C(1:NVAR,j),1,Y,1) - END DO - - END SUBROUTINE ros_Hermite5 - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Ros2 -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! --- AN L-STABLE METHOD, 2 stages, order 2 -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - DOUBLE PRECISION g - - g = 1.0d0 + 1.0d0/SQRT(2.0d0) - - rosMethod = RS2 -!~~~> Name of the method - ros_Name = 'ROS-2' -!~~~> Number of stages - ros_S = 2 - -!~~~> The coefficient matrices A and C are strictly lower triangular. -! The lower triangular (subdiagonal) elements are stored in row-wise order: -! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. -! The general mapping formula is: -! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) -! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) - - ros_A(1) = (1.d0)/g - ros_C(1) = (-2.d0)/g -!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) -! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) - ros_NewF(1) = .TRUE. - ros_NewF(2) = .TRUE. -!~~~> M_i = Coefficients for new step solution - ros_M(1)= (3.d0)/(2.d0*g) - ros_M(2)= (1.d0)/(2.d0*g) -! E_i = Coefficients for error estimator - ros_E(1) = 1.d0/(2.d0*g) - ros_E(2) = 1.d0/(2.d0*g) -!~~~> ros_ELO = estimator of local order - the minimum between the -! main and the embedded scheme orders plus one - ros_ELO = 2.0d0 -!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) - ros_Alpha(1) = 0.0d0 - ros_Alpha(2) = 1.0d0 -!~~~> Gamma_i = \sum_j gamma_{i,j} - ros_Gamma(1) = g - ros_Gamma(2) =-g - - END SUBROUTINE Ros2 - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Ros3 -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! --- AN L-STABLE METHOD, 3 stages, order 3, 2 function evaluations -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - - rosMethod = RS3 -!~~~> Name of the method - ros_Name = 'ROS-3' -!~~~> Number of stages - ros_S = 3 - -!~~~> The coefficient matrices A and C are strictly lower triangular. -! The lower triangular (subdiagonal) elements are stored in row-wise order: -! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. -! The general mapping formula is: -! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) -! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) - - ros_A(1)= 1.d0 - ros_A(2)= 1.d0 - ros_A(3)= 0.d0 - - ros_C(1) = -0.10156171083877702091975600115545d+01 - ros_C(2) = 0.40759956452537699824805835358067d+01 - ros_C(3) = 0.92076794298330791242156818474003d+01 -!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) -! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) - ros_NewF(1) = .TRUE. - ros_NewF(2) = .TRUE. - ros_NewF(3) = .FALSE. -!~~~> M_i = Coefficients for new step solution - ros_M(1) = 0.1d+01 - ros_M(2) = 0.61697947043828245592553615689730d+01 - ros_M(3) = -0.42772256543218573326238373806514d+00 -! E_i = Coefficients for error estimator - ros_E(1) = 0.5d+00 - ros_E(2) = -0.29079558716805469821718236208017d+01 - ros_E(3) = 0.22354069897811569627360909276199d+00 -!~~~> ros_ELO = estimator of local order - the minimum between the -! main and the embedded scheme orders plus 1 - ros_ELO = 3.0d0 -!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) - ros_Alpha(1)= 0.0d+00 - ros_Alpha(2)= 0.43586652150845899941601945119356d+00 - ros_Alpha(3)= 0.43586652150845899941601945119356d+00 -!~~~> Gamma_i = \sum_j gamma_{i,j} - ros_Gamma(1)= 0.43586652150845899941601945119356d+00 - ros_Gamma(2)= 0.24291996454816804366592249683314d+00 - ros_Gamma(3)= 0.21851380027664058511513169485832d+01 - - END SUBROUTINE Ros3 - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Ros4 -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! L-STABLE ROSENBROCK METHOD OF ORDER 4, WITH 4 STAGES -! L-STABLE EMBEDDED ROSENBROCK METHOD OF ORDER 3 -! -! E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL -! EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS. -! SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS, -! SPRINGER-VERLAG (1990) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - - rosMethod = RS4 -!~~~> Name of the method - ros_Name = 'ROS-4' -!~~~> Number of stages - ros_S = 4 - -!~~~> The coefficient matrices A and C are strictly lower triangular. -! The lower triangular (subdiagonal) elements are stored in row-wise order: -! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. -! The general mapping formula is: -! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) -! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) - - ros_A(1) = 0.2000000000000000d+01 - ros_A(2) = 0.1867943637803922d+01 - ros_A(3) = 0.2344449711399156d+00 - ros_A(4) = ros_A(2) - ros_A(5) = ros_A(3) - ros_A(6) = 0.0D0 - - ros_C(1) =-0.7137615036412310d+01 - ros_C(2) = 0.2580708087951457d+01 - ros_C(3) = 0.6515950076447975d+00 - ros_C(4) =-0.2137148994382534d+01 - ros_C(5) =-0.3214669691237626d+00 - ros_C(6) =-0.6949742501781779d+00 -!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) -! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) - ros_NewF(1) = .TRUE. - ros_NewF(2) = .TRUE. - ros_NewF(3) = .TRUE. - ros_NewF(4) = .FALSE. -!~~~> M_i = Coefficients for new step solution - ros_M(1) = 0.2255570073418735d+01 - ros_M(2) = 0.2870493262186792d+00 - ros_M(3) = 0.4353179431840180d+00 - ros_M(4) = 0.1093502252409163d+01 -!~~~> E_i = Coefficients for error estimator - ros_E(1) =-0.2815431932141155d+00 - ros_E(2) =-0.7276199124938920d-01 - ros_E(3) =-0.1082196201495311d+00 - ros_E(4) =-0.1093502252409163d+01 -!~~~> ros_ELO = estimator of local order - the minimum between the -! main and the embedded scheme orders plus 1 - ros_ELO = 4.0d0 -!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) - ros_Alpha(1) = 0.D0 - ros_Alpha(2) = 0.1145640000000000d+01 - ros_Alpha(3) = 0.6552168638155900d+00 - ros_Alpha(4) = ros_Alpha(3) -!~~~> Gamma_i = \sum_j gamma_{i,j} - ros_Gamma(1) = 0.5728200000000000d+00 - ros_Gamma(2) =-0.1769193891319233d+01 - ros_Gamma(3) = 0.7592633437920482d+00 - ros_Gamma(4) =-0.1049021087100450d+00 - - END SUBROUTINE Ros4 - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Rodas3 -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! --- A STIFFLY-STABLE METHOD, 4 stages, order 3 -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - - rosMethod = RD3 -!~~~> Name of the method - ros_Name = 'RODAS-3' -!~~~> Number of stages - ros_S = 4 - -!~~~> The coefficient matrices A and C are strictly lower triangular. -! The lower triangular (subdiagonal) elements are stored in row-wise order: -! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. -! The general mapping formula is: -! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) -! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) - - ros_A(1) = 0.0d+00 - ros_A(2) = 2.0d+00 - ros_A(3) = 0.0d+00 - ros_A(4) = 2.0d+00 - ros_A(5) = 0.0d+00 - ros_A(6) = 1.0d+00 - - ros_C(1) = 4.0d+00 - ros_C(2) = 1.0d+00 - ros_C(3) =-1.0d+00 - ros_C(4) = 1.0d+00 - ros_C(5) =-1.0d+00 - ros_C(6) =-(8.0d+00/3.0d+00) - -!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) -! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) - ros_NewF(1) = .TRUE. - ros_NewF(2) = .FALSE. - ros_NewF(3) = .TRUE. - ros_NewF(4) = .TRUE. -!~~~> M_i = Coefficients for new step solution - ros_M(1) = 2.0d+00 - ros_M(2) = 0.0d+00 - ros_M(3) = 1.0d+00 - ros_M(4) = 1.0d+00 -!~~~> E_i = Coefficients for error estimator - ros_E(1) = 0.0d+00 - ros_E(2) = 0.0d+00 - ros_E(3) = 0.0d+00 - ros_E(4) = 1.0d+00 -!~~~> ros_ELO = estimator of local order - the minimum between the -! main and the embedded scheme orders plus 1 - ros_ELO = 3.0d+00 -!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) - ros_Alpha(1) = 0.0d+00 - ros_Alpha(2) = 0.0d+00 - ros_Alpha(3) = 1.0d+00 - ros_Alpha(4) = 1.0d+00 -!~~~> Gamma_i = \sum_j gamma_{i,j} - ros_Gamma(1) = 0.5d+00 - ros_Gamma(2) = 1.5d+00 - ros_Gamma(3) = 0.0d+00 - ros_Gamma(4) = 0.0d+00 - - END SUBROUTINE Rodas3 - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Rodas4 -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! STIFFLY-STABLE ROSENBROCK METHOD OF ORDER 4, WITH 6 STAGES -! -! E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL -! EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS. -! SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS, -! SPRINGER-VERLAG (1996) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - - rosMethod = RD4 -!~~~> Name of the method - ros_Name = 'RODAS-4' -!~~~> Number of stages - ros_S = 6 - -!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) - ros_Alpha(1) = 0.000d0 - ros_Alpha(2) = 0.386d0 - ros_Alpha(3) = 0.210d0 - ros_Alpha(4) = 0.630d0 - ros_Alpha(5) = 1.000d0 - ros_Alpha(6) = 1.000d0 - -!~~~> Gamma_i = \sum_j gamma_{i,j} - ros_Gamma(1) = 0.2500000000000000d+00 - ros_Gamma(2) =-0.1043000000000000d+00 - ros_Gamma(3) = 0.1035000000000000d+00 - ros_Gamma(4) =-0.3620000000000023d-01 - ros_Gamma(5) = 0.0d0 - ros_Gamma(6) = 0.0d0 - -!~~~> The coefficient matrices A and C are strictly lower triangular. -! The lower triangular (subdiagonal) elements are stored in row-wise order: -! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. -! The general mapping formula is: A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) -! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) - - ros_A(1) = 0.1544000000000000d+01 - ros_A(2) = 0.9466785280815826d+00 - ros_A(3) = 0.2557011698983284d+00 - ros_A(4) = 0.3314825187068521d+01 - ros_A(5) = 0.2896124015972201d+01 - ros_A(6) = 0.9986419139977817d+00 - ros_A(7) = 0.1221224509226641d+01 - ros_A(8) = 0.6019134481288629d+01 - ros_A(9) = 0.1253708332932087d+02 - ros_A(10) =-0.6878860361058950d+00 - ros_A(11) = ros_A(7) - ros_A(12) = ros_A(8) - ros_A(13) = ros_A(9) - ros_A(14) = ros_A(10) - ros_A(15) = 1.0d+00 - - ros_C(1) =-0.5668800000000000d+01 - ros_C(2) =-0.2430093356833875d+01 - ros_C(3) =-0.2063599157091915d+00 - ros_C(4) =-0.1073529058151375d+00 - ros_C(5) =-0.9594562251023355d+01 - ros_C(6) =-0.2047028614809616d+02 - ros_C(7) = 0.7496443313967647d+01 - ros_C(8) =-0.1024680431464352d+02 - ros_C(9) =-0.3399990352819905d+02 - ros_C(10) = 0.1170890893206160d+02 - ros_C(11) = 0.8083246795921522d+01 - ros_C(12) =-0.7981132988064893d+01 - ros_C(13) =-0.3152159432874371d+02 - ros_C(14) = 0.1631930543123136d+02 - ros_C(15) =-0.6058818238834054d+01 - -!~~~> M_i = Coefficients for new step solution - ros_M(1) = ros_A(7) - ros_M(2) = ros_A(8) - ros_M(3) = ros_A(9) - ros_M(4) = ros_A(10) - ros_M(5) = 1.0d+00 - ros_M(6) = 1.0d+00 - -!~~~> E_i = Coefficients for error estimator - ros_E(1) = 0.0d+00 - ros_E(2) = 0.0d+00 - ros_E(3) = 0.0d+00 - ros_E(4) = 0.0d+00 - ros_E(5) = 0.0d+00 - ros_E(6) = 1.0d+00 - -!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) -! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) - ros_NewF(1) = .TRUE. - ros_NewF(2) = .TRUE. - ros_NewF(3) = .TRUE. - ros_NewF(4) = .TRUE. - ros_NewF(5) = .TRUE. - ros_NewF(6) = .TRUE. - -!~~~> ros_ELO = estimator of local order - the minimum between the -! main and the embedded scheme orders plus 1 - ros_ELO = 4.0d0 - - END SUBROUTINE Rodas4 - - -END SUBROUTINE RosenbrockADJ ! and its internal procedures - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -SUBROUTINE Fun_Template( T, Y, Ydot ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Template for the ODE function call. -! Updates the rate coefficients (and possibly the fixed species) at each call -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -!~~~> Input variables - KPP_REAL, INTENT(IN) :: T, Y(NVAR) -!~~~> Output variables - KPP_REAL, INTENT(OUT) :: Ydot(NVAR) -!~~~> Local variables - KPP_REAL :: Told - - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Fun( Y, FIX, RCONST, Ydot ) - TIME = Told - -END SUBROUTINE Fun_Template - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -SUBROUTINE Jac_Template( T, Y, Jcb ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Template for the ODE Jacobian call. -! Updates the rate coefficients (and possibly the fixed species) at each call -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -!~~~> Input variables - KPP_REAL :: T, Y(NVAR) -!~~~> Output variables -#ifdef FULL_ALGEBRA - KPP_REAL :: JV(LU_NONZERO), Jcb(NVAR,NVAR) -#else - KPP_REAL :: Jcb(LU_NONZERO) -#endif -!~~~> Local variables - KPP_REAL :: Told -#ifdef FULL_ALGEBRA - INTEGER :: i, j -#endif - - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() -#ifdef FULL_ALGEBRA - CALL Jac_SP(Y, FIX, RCONST, JV) - DO j=1,NVAR - DO i=1,NVAR - Jcb(i,j) = 0.0_dp - END DO - END DO - DO i=1,LU_NONZERO - Jcb(LU_IROW(i),LU_ICOL(i)) = JV(i) - END DO -#else - CALL Jac_SP( Y, FIX, RCONST, Jcb ) -#endif - TIME = Told - -END SUBROUTINE Jac_Template - - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -SUBROUTINE Hess_Template( T, Y, Hes ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Template for the ODE Hessian call. -! Updates the rate coefficients (and possibly the fixed species) at each call -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -!~~~> Input variables - KPP_REAL, INTENT(IN) :: T, Y(NVAR) -!~~~> Output variables - KPP_REAL, INTENT(OUT) :: Hes(NHESS) -!~~~> Local variables - KPP_REAL :: Told - - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Hessian( Y, FIX, RCONST, Hes ) - TIME = Told - -END SUBROUTINE Hess_Template - -END MODULE KPP_ROOT_Integrator - - - - diff --git a/boxmox/int.modified_WCOPY/rosenbrock_soa.def b/boxmox/int.modified_WCOPY/rosenbrock_soa.def deleted file mode 100644 index d61b065590d0e95869da0ee3fdb16ca4cbe00730..0000000000000000000000000000000000000000 --- a/boxmox/int.modified_WCOPY/rosenbrock_soa.def +++ /dev/null @@ -1,23 +0,0 @@ - -#FUNCTION AGGREGATE -#JACOBIAN SPARSE_LU_ROW - -#DOUBLE ON -#INTFILE rosenbrock_soa - -#INLINE F90_GLOBAL - INTEGER Autonomous - COMMON /INTGDATA/ Autonomous - REAL*8 STEPSTART - COMMON /GDATA/ STEPSTART -#ENDINLINE - -#INLINE F90_INIT - STEPMIN=0.0001 - STEPMAX=3600. - Autonomous = 1 - STEPSTART=STEPMIN -#ENDINLINE - - - diff --git a/boxmox/int.modified_WCOPY/rosenbrock_soa.f90 b/boxmox/int.modified_WCOPY/rosenbrock_soa.f90 deleted file mode 100644 index 7e4d20eb5f8f638c1649b493f55d5d35f86db7be..0000000000000000000000000000000000000000 --- a/boxmox/int.modified_WCOPY/rosenbrock_soa.f90 +++ /dev/null @@ -1,1942 +0,0 @@ -MODULE KPP_ROOT_Integrator - - USE KPP_ROOT_Precision - USE KPP_ROOT_Parameters - USE KPP_ROOT_Global - USE KPP_ROOT_Function - USE KPP_ROOT_Jacobian - USE KPP_ROOT_Hessian - USE KPP_ROOT_LinearAlgebra - USE KPP_ROOT_Rates - - IMPLICIT NONE - PUBLIC - SAVE -!~~~> Statistics on the work performed by the Rosenbrock method - INTEGER :: Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng - INTEGER, PARAMETER :: ifun=11, ijac=12, istp=13, & - iacc=14, irej=15, idec=16, isol=17, & - isng=18, itexit=11,ihexit=12 -!~~~> Checkpoints in memory - INTEGER, PARAMETER :: bufsize = 1500 - INTEGER :: stack_ptr = 0 ! last written entry - KPP_REAL, DIMENSION(:), POINTER :: buf_H, buf_T - KPP_REAL, DIMENSION(:,:), POINTER :: buf_Y, buf_K - KPP_REAL, DIMENSION(:,:), POINTER :: buf_Y_tlm, buf_K_tlm - -CONTAINS - - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE INTEGRATE_SOA( NSOA, Y, Y_tlm, Y_adj, Y_soa, TIN, TOUT, & - AtolAdj, RtolAdj, ICNTRL_U, RCNTRL_U, ISTATUS_U, RSTATUS_U ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - -!~~~> NSOA - No. of vectors to multiply SOA with - INTEGER :: NSOA -!~~~> Y - Forward model variables - KPP_REAL, INTENT(INOUT) :: Y(NVAR) -!~~~> Y_adj - Tangent linear variables - KPP_REAL, INTENT(INOUT) :: Y_tlm(NVAR,NSOA) -!~~~> Y_adj - First order adjoint - KPP_REAL, INTENT(INOUT) :: Y_adj(NVAR) -!~~~> Y_soa - Second order adjoint - KPP_REAL, INTENT(INOUT) :: Y_soa(NVAR,NSOA) -!~~~> - KPP_REAL, INTENT(IN) :: TIN ! TIN - Start Time - KPP_REAL, INTENT(IN) :: TOUT ! TOUT - End Time -!~~~> Optional input parameters and statistics - INTEGER, INTENT(IN), OPTIONAL :: ICNTRL_U(20) - KPP_REAL, INTENT(IN), OPTIONAL :: RCNTRL_U(20) - INTEGER, INTENT(OUT), OPTIONAL :: ISTATUS_U(20) - KPP_REAL, INTENT(OUT), OPTIONAL :: RSTATUS_U(20) - - INTEGER N_stp, N_acc, N_rej, N_sng, IERR - SAVE N_stp, N_acc, N_rej, N_sng - INTEGER i - KPP_REAL :: RCNTRL(20), RSTATUS(20) - KPP_REAL :: AtolAdj(NVAR), RtolAdj(NVAR) - INTEGER :: ICNTRL(20), ISTATUS(20) - - ICNTRL(1:20) = 0 - RCNTRL(1:20) = 0.0_dp - ISTATUS(1:20) = 0 - RSTATUS(1:20) = 0.0_dp - - ICNTRL(1) = 0 ! 0 = non-autonomous, 1 = autonomous - ICNTRL(2) = 1 ! 0 = scalar, 1 = vector tolerances - RCNTRL(3) = STEPMIN ! starting step - ICNTRL(4) = 5 ! choice of the method for forward and adjoint integration - -! Tighter tolerances, especially atol, are needed for the full continuous adjoint -! (Atol on sensitivities is different than on concentrations) -! CADJ_ATOL(1:NVAR) = 1.0d-5 -! CADJ_RTOL(1:NVAR) = 1.0d-4 - - ! if optional parameters are given, and if they are >=0, - ! then they overwrite default settings - IF (PRESENT(ICNTRL_U)) THEN - WHERE(ICNTRL_U(:) >= 0) ICNTRL(:) = ICNTRL_U(:) - ENDIF - IF (PRESENT(RCNTRL_U)) THEN - WHERE(RCNTRL_U(:) >= 0) RCNTRL(:) = RCNTRL_U(:) - ENDIF - - - CALL RosenbrockSOA(NSOA, & - Y, Y_tlm, Y_adj, Y_soa, & - TIN,TOUT, & - ATOL,RTOL, & - Fun_Template,Jac_Template,Hess_Template, & - RCNTRL,ICNTRL,RSTATUS,ISTATUS,IERR) - - -! N_stp = N_stp + ICNTRL(istp) -! N_acc = N_acc + ICNTRL(iacc) -! N_rej = N_rej + ICNTRL(irej) -! N_sng = N_sng + ICNTRL(isng) -! PRINT*,'Step=',N_stp,' Acc=',N_acc,' Rej=',N_rej, & -! ' Singular=',N_sng - - IF (IERR < 0) THEN - print *,'RosenbrockSOA: Unsucessful step at T=', & - TIN,' (IERR=',IERR,')' - ENDIF - - STEPMIN = RCNTRL(ihexit) - ! if optional parameters are given for output they to return information - IF (PRESENT(ISTATUS_U)) ISTATUS_U(:) = ISTATUS(:) - IF (PRESENT(RSTATUS_U)) RSTATUS_U(:) = RSTATUS(:) - -END SUBROUTINE INTEGRATE_SOA - - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -SUBROUTINE RosenbrockSOA( NSOA, & - Y, Y_tlm, Y_adj, Y_soa, & - Tstart,Tend, & - AbsTol,RelTol, & - ode_Fun,ode_Jac , ode_Hess, & - RCNTRL,ICNTRL,RSTATUS,ISTATUS,IERR) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -! ADJ = Adjoint of the Tangent Linear Model of a RosenbrockSOA Method -! -! Solves the system y'=F(t,y) using a RosenbrockSOA method defined by: -! -! G = 1/(H*gamma(1)) - ode_Jac(t0,Y0) -! T_i = t0 + Alpha(i)*H -! Y_i = Y0 + \sum_{j=1}^{i-1} A(i,j)*K_j -! G * K_i = ode_Fun( T_i, Y_i ) + \sum_{j=1}^S C(i,j)/H * K_j + -! gamma(i)*dF/dT(t0, Y0) -! Y1 = Y0 + \sum_{j=1}^S M(j)*K_j -! -! For details on RosenbrockSOA methods and their implementation consult: -! E. Hairer and G. Wanner -! "Solving ODEs II. Stiff and differential-algebraic problems". -! Springer series in computational mathematics, Springer-Verlag, 1996. -! The codes contained in the book inspired this implementation. -! -! (C) Adrian Sandu, August 2004 -! Virginia Polytechnic Institute and State University -! Contact: sandu@cs.vt.edu -! This implementation is part of KPP - the Kinetic PreProcessor -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!~~~> INPUT ARGUMENTS: -! -!- Y(NVAR) -> vector of initial conditions (at T=Tstart) -! NSOA -> dimension of linearized system, -! i.e. the number of sensitivity coefficients -!- Y_adj(NVAR) -> vector of initial sensitivity conditions (at T=Tstart) -!- [Tstart,Tend] = time range of integration -! (if Tstart>Tend the integration is performed backwards in time) -!- RelTol, AbsTol = user precribed accuracy -!- SUBROUTINE ode_Fun( T, Y, Ydot ) = ODE function, -! returns Ydot = Y' = F(T,Y) -!- SUBROUTINE ode_Fun( T, Y, Ydot ) = Jacobian of the ODE function, -! returns Jcb = dF/dY -!- ICNTRL(1:10) = integer inputs parameters -!- RCNTRL(1:10) = real inputs parameters -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!~~~> OUTPUT ARGUMENTS: -! -!- Y(NVAR) -> vector of final states (at T->Tend) -!- Y_adj(NVAR) -> vector of final sensitivities (at T=Tend) -!- ICNTRL(11:20) -> integer output parameters -!- RCNTRL(11:20) -> real output parameters -!- IERR -> job status upon return -! - succes (positive value) or failure (negative value) - -! = 1 : Success -! = -1 : Improper value for maximal no of steps -! = -2 : Selected RosenbrockSOA method not implemented -! = -3 : Hmin/Hmax/Hstart must be positive -! = -4 : FacMin/FacMax/FacRej must be positive -! = -5 : Improper tolerance values -! = -6 : No of steps exceeds maximum bound -! = -7 : Step size too small -! = -8 : Matrix is repeatedly singular -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!~~~> INPUT PARAMETERS: -! -! Note: For input parameters equal to zero the default values of the -! corresponding variables are used. -! -! ICNTRL(1) = 1: F = F(y) Independent of T (AUTONOMOUS) -! = 0: F = F(t,y) Depends on T (NON-AUTONOMOUS) -! ICNTRL(2) = 0: AbsTol, RelTol are NVAR-dimensional vectors -! = 1: AbsTol, RelTol are scalars -! ICNTRL(3) -> maximum number of integration steps -! For ICNTRL(3)=0) the default value of 100000 is used -! -! ICNTRL(4) -> selection of a particular Rosenbrock method -! = 0 : default method is Rodas3 -! = 1 : method is Ros2 -! = 2 : method is Ros3 -! = 3 : method is Ros4 -! = 4 : method is Rodas3 -! = 5: method is Rodas4 -! -! ICNTRL(5) -> Type of adjoint algorithm -! = 0 : default is discrete adjoint ( of method ICNTRL(4) ) -! = 1 : no adjoint -! = 2 : discrete adjoint ( of method ICNTRL(4) ) -! = 3 : fully adaptive continuous adjoint ( with method ICNTRL(6) ) -! = 4 : simplified continuous adjoint ( with method ICNTRL(6) ) -! -! ICNTRL(6) -> selection of a particular Rosenbrock method for the -! continuous adjoint integration - for cts adjoint it -! can be different than the forward method ICNTRL(4) -! Note 1: to avoid interpolation errors (which can be huge!) -! it is recommended to use only ICNTRL(6) = 1 or 4 -! Note 2: the performance of the full continuous adjoint -! strongly depends on the forward solution accuracy Abs/RelTol -! -! RCNTRL(1) -> Hmin, lower bound for the integration step size -! It is strongly recommended to keep Hmin = ZERO -! RCNTRL(2) -> Hmax, upper bound for the integration step size -! RCNTRL(3) -> Hstart, starting value for the integration step size -! -! RCNTRL(4) -> FacMin, lower bound on step decrease factor (default=0.2) -! RCNTRL(5) -> FacMin,upper bound on step increase factor (default=6) -! RCNTRL(6) -> FacRej, step decrease factor after multiple rejections -! (default=0.1) -! RCNTRL(7) -> FacSafe, by which the new step is slightly smaller -! than the predicted value (default=0.9) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!~~~> OUTPUT PARAMETERS: -! -! Note: each call to RosenbrockSOA adds the corrent no. of fcn calls -! to previous value of ISTATUS(1), and similar for the other params. -! Set ISTATUS(1:10) = 0 before call to avoid this accumulation. -! -! ISTATUS(1) = No. of function calls -! ISTATUS(2) = No. of jacobian calls -! ISTATUS(3) = No. of steps -! ISTATUS(4) = No. of accepted steps -! ISTATUS(5) = No. of rejected steps (except at the beginning) -! ISTATUS(6) = No. of LU decompositions -! ISTATUS(7) = No. of forward/backward substitutions -! ISTATUS(8) = No. of singular matrix decompositions -! -! RSTATUS(1) -> Texit, the time corresponding to the -! computed Y upon return -! RSTATUS(2) -> Hexit, last accepted step before exit -! For multiple restarts, use Hexit as Hstart in the following run -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - -!~~~> Arguments - INTEGER, INTENT(IN) :: NSOA - KPP_REAL, INTENT(INOUT) :: Y(NVAR) - KPP_REAL, INTENT(INOUT) :: Y_tlm(NVAR,NSOA) - KPP_REAL, INTENT(INOUT) :: Y_adj(NVAR) - KPP_REAL, INTENT(INOUT) :: Y_soa(NVAR,NSOA) - KPP_REAL, INTENT(IN) :: Tstart, Tend - KPP_REAL, INTENT(IN) :: AbsTol(NVAR),RelTol(NVAR) - INTEGER, INTENT(IN) :: ICNTRL(20) - KPP_REAL, INTENT(IN) :: RCNTRL(20) - INTEGER, INTENT(INOUT) :: ISTATUS(20) - KPP_REAL, INTENT(INOUT) :: RSTATUS(20) - INTEGER, INTENT(OUT) :: IERR -!~~~> The method parameters - INTEGER, PARAMETER :: Smax = 6 - INTEGER :: Method, ros_S - KPP_REAL, DIMENSION(Smax) :: ros_M, ros_E, ros_Alpha, ros_Gamma - KPP_REAL, DIMENSION(Smax*(Smax-1)/2) :: ros_A, ros_C - KPP_REAL :: ros_ELO - LOGICAL, DIMENSION(Smax) :: ros_NewF - CHARACTER(LEN=12) :: ros_Name -!~~~> Local variables - KPP_REAL :: Roundoff, FacMin, FacMax, FacRej, FacSafe - KPP_REAL :: Hmin, Hmax, Hstart, Hexit - KPP_REAL :: T - INTEGER :: i, UplimTol, Max_no_steps - LOGICAL :: Autonomous, VectorTol -!~~~> Parameters - KPP_REAL, PARAMETER :: ZERO = 0.0d0, ONE = 1.0d0 - KPP_REAL, PARAMETER :: DeltaMin = 1.0d-5 -!~~~> Functions - EXTERNAL ode_Fun, ode_Jac, ode_Hess - -!~~~> Initialize statistics - Nfun = ISTATUS(ifun) - Njac = ISTATUS(ijac) - Nstp = ISTATUS(istp) - Nacc = ISTATUS(iacc) - Nrej = ISTATUS(irej) - Ndec = ISTATUS(idec) - Nsol = ISTATUS(isol) - Nsng = ISTATUS(isng) - -!~~~> Autonomous or time dependent ODE. Default is time dependent. - Autonomous = .NOT.(ICNTRL(1) == 0) - -!~~~> For Scalar tolerances (ICNTRL(2).NE.0) -! the code uses AbsTol(1) and RelTol(1) -! For Vector tolerances (ICNTRL(2) == 0) -! the code uses AbsTol(1:NVAR) and RelTol(1:NVAR) - IF (ICNTRL(2) == 0) THEN - VectorTol = .TRUE. - UplimTol = NVAR - ELSE - VectorTol = .FALSE. - UplimTol = 1 - END IF - -!~~~> The maximum number of steps admitted - IF (ICNTRL(3) == 0) THEN - Max_no_steps = bufsize - 1 - ELSEIF (Max_no_steps > 0) THEN - Max_no_steps=ICNTRL(3) - ELSE - PRINT * ,'User-selected max no. of steps: ICNTRL(3)=',ICNTRL(3) - CALL ros_ErrorMsg(-1,Tstart,ZERO,IERR) - RETURN - END IF - -!~~~> The particular Rosenbrock method chosen - IF (ICNTRL(4) == 0) THEN - Method = 5 - ELSEIF ( (ICNTRL(4) >= 1).AND.(ICNTRL(4) <= 5) ) THEN - Method = ICNTRL(4) - ELSE - PRINT * , 'User-selected Rosenbrock method: ICNTRL(4)=', Method - CALL ros_ErrorMsg(-2,Tstart,ZERO,IERR) - RETURN - END IF - - -!~~~> Unit roundoff (1+Roundoff>1) - Roundoff = WLAMCH('E') - -!~~~> Lower bound on the step size: (positive value) - IF (RCNTRL(1) == ZERO) THEN - Hmin = ZERO - ELSEIF (RCNTRL(1) > ZERO) THEN - Hmin = RCNTRL(1) - ELSE - PRINT * , 'User-selected Hmin: RCNTRL(1)=', RCNTRL(1) - CALL ros_ErrorMsg(-3,Tstart,ZERO,IERR) - RETURN - END IF -!~~~> Upper bound on the step size: (positive value) - IF (RCNTRL(2) == ZERO) THEN - Hmax = ABS(Tend-Tstart) - ELSEIF (RCNTRL(2) > ZERO) THEN - Hmax = MIN(ABS(RCNTRL(2)),ABS(Tend-Tstart)) - ELSE - PRINT * , 'User-selected Hmax: RCNTRL(2)=', RCNTRL(2) - CALL ros_ErrorMsg(-3,Tstart,ZERO,IERR) - RETURN - END IF -!~~~> Starting step size: (positive value) - IF (RCNTRL(3) == ZERO) THEN - Hstart = MAX(Hmin,DeltaMin) - ELSEIF (RCNTRL(3) > ZERO) THEN - Hstart = MIN(ABS(RCNTRL(3)),ABS(Tend-Tstart)) - ELSE - PRINT * , 'User-selected Hstart: RCNTRL(3)=', RCNTRL(3) - CALL ros_ErrorMsg(-3,Tstart,ZERO,IERR) - RETURN - END IF -!~~~> Step size can be changed s.t. FacMin < Hnew/Hexit < FacMax - IF (RCNTRL(4) == ZERO) THEN - FacMin = 0.2d0 - ELSEIF (RCNTRL(4) > ZERO) THEN - FacMin = RCNTRL(4) - ELSE - PRINT * , 'User-selected FacMin: RCNTRL(4)=', RCNTRL(4) - CALL ros_ErrorMsg(-4,Tstart,ZERO,IERR) - RETURN - END IF - IF (RCNTRL(5) == ZERO) THEN - FacMax = 6.0d0 - ELSEIF (RCNTRL(5) > ZERO) THEN - FacMax = RCNTRL(5) - ELSE - PRINT * , 'User-selected FacMax: RCNTRL(5)=', RCNTRL(5) - CALL ros_ErrorMsg(-4,Tstart,ZERO,IERR) - RETURN - END IF -!~~~> FacRej: Factor to decrease step after 2 succesive rejections - IF (RCNTRL(6) == ZERO) THEN - FacRej = 0.1d0 - ELSEIF (RCNTRL(6) > ZERO) THEN - FacRej = RCNTRL(6) - ELSE - PRINT * , 'User-selected FacRej: RCNTRL(6)=', RCNTRL(6) - CALL ros_ErrorMsg(-4,Tstart,ZERO,IERR) - RETURN - END IF -!~~~> FacSafe: Safety Factor in the computation of new step size - IF (RCNTRL(7) == ZERO) THEN - FacSafe = 0.9d0 - ELSEIF (RCNTRL(7) > ZERO) THEN - FacSafe = RCNTRL(7) - ELSE - PRINT * , 'User-selected FacSafe: RCNTRL(7)=', RCNTRL(7) - CALL ros_ErrorMsg(-4,Tstart,ZERO,IERR) - RETURN - END IF -!~~~> Check if tolerances are reasonable - DO i=1,UplimTol - IF ( (AbsTol(i) <= ZERO) .OR. (RelTol(i) <= 10.d0*Roundoff) & - .OR. (RelTol(i) >= 1.0d0) ) THEN - PRINT * , ' AbsTol(',i,') = ',AbsTol(i) - PRINT * , ' RelTol(',i,') = ',RelTol(i) - CALL ros_ErrorMsg(-5,Tstart,ZERO,IERR) - RETURN - END IF - END DO - - -!~~~> Initialize the particular RosenbrockSOA method - SELECT CASE (Method) - CASE (1) - CALL Ros2(ros_S, ros_A, ros_C, ros_M, ros_E, & - ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) - CASE (2) - CALL Ros3(ros_S, ros_A, ros_C, ros_M, ros_E, & - ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) - CASE (3) - CALL Ros4(ros_S, ros_A, ros_C, ros_M, ros_E, & - ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) - CASE (4) - CALL Rodas3(ros_S, ros_A, ros_C, ros_M, ros_E, & - ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) - CASE (5) - CALL Rodas4(ros_S, ros_A, ros_C, ros_M, ros_E, & - ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) - CASE DEFAULT - PRINT * , 'Unknown Rosenbrock method: ICNTRL(4)=', Method - CALL ros_ErrorMsg(-2,Tstart,ZERO,IERR) - RETURN - END SELECT - -!~~~> Allocate checkpoint space or open checkpoint files - CALL ros_AllocateDBuffers( ros_S ) - -!~~~> Forward Rosenbrock and TLM integration - CALL ros_TlmInt (NSOA, Y, Y_tlm, & - Tstart, Tend, T, & - AbsTol, RelTol, & - ode_Fun, ode_Jac, ode_Hess, & -!~~~> Rosenbrock method coefficients - ros_S, ros_M, ros_E, ros_A, ros_C, & - ros_Alpha, ros_Gamma, ros_ELO, ros_NewF, & -!~~~> Integration parameters - Autonomous, VectorTol, Max_no_steps, & - Roundoff, Hmin, Hmax, Hstart, Hexit, & - FacMin, FacMax, FacRej, FacSafe, & -!~~~> Error indicator - IERR ) - - PRINT*,'FORWARD STATISTICS' - PRINT*,'Step=',Nstp,' Acc=',Nacc, & - ' Rej=',Nrej, ' Singular=',Nsng - Nstp = 0 - Nacc = 0 - Nrej = 0 - Nsng = 0 - -!~~~> If Forward integration failed return - IF (IERR<0) RETURN - -!~~~> Backward ADJ and SOADJ Rosenbrock integration - CALL ros_SoaInt ( & - NSOA, Y_adj, Y_soa, & - Tstart, Tend, T, & - AbsTol, RelTol, & - ode_Fun, ode_Jac, ode_Hess, & -!~~~> RosenbrockSOA method coefficients - ros_S, ros_M, ros_E, ros_A, ros_C, & - ros_Alpha, ros_Gamma, ros_ELO, ros_NewF, & -!~~~> Integration parameters - Autonomous, VectorTol, Max_no_steps, & - Roundoff, Hmin, Hmax, Hstart, & - FacMin, FacMax, FacRej, FacSafe, & -!~~~> Error indicator - IERR ) - - - PRINT*,'ADJOINT STATISTICS' - PRINT*,'Step=',Nstp,' Acc=',Nacc, & - ' Rej=',Nrej, ' Singular=',Nsng - -!~~~> Free checkpoint space or close checkpoint files - CALL ros_FreeDBuffers - -!~~~> Collect run statistics - ISTATUS(ifun) = Nfun - ISTATUS(ijac) = Njac - ISTATUS(istp) = Nstp - ISTATUS(iacc) = Nacc - ISTATUS(irej) = Nrej - ISTATUS(idec) = Ndec - ISTATUS(isol) = Nsol - ISTATUS(isng) = Nsng -!~~~> Last T and H - RSTATUS(itexit) = T - RSTATUS(ihexit) = Hexit - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - END SUBROUTINE RosenbrockSOA -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_ErrorMsg(Code,T,H,IERR) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Handles all error messages -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - KPP_REAL, INTENT(IN) :: T, H - INTEGER, INTENT(IN) :: Code - INTEGER, INTENT(OUT) :: IERR - - IERR = Code - PRINT * , & - 'Forced exit from RosenbrockSOA due to the following error:' - - SELECT CASE (Code) - CASE (-1) - PRINT * , '--> Improper value for maximal no of steps' - CASE (-2) - PRINT * , '--> Selected RosenbrockSOA method not implemented' - CASE (-3) - PRINT * , '--> Hmin/Hmax/Hstart must be positive' - CASE (-4) - PRINT * , '--> FacMin/FacMax/FacRej must be positive' - CASE (-5) - PRINT * , '--> Improper tolerance values' - CASE (-6) - PRINT * , '--> No of steps exceeds maximum bound' - CASE (-7) - PRINT * , '--> Step size too small: T + 10*H = T', & - ' or H < Roundoff' - CASE (-8) - PRINT * , '--> Matrix is repeatedly singular' - CASE (-9) - PRINT * , '--> Improper type of adjoint selected' - CASE DEFAULT - PRINT *, 'Unknown Error code: ', Code - END SELECT - - PRINT *, "T=", T, "and H=", H - - END SUBROUTINE ros_ErrorMsg - - - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_TlmInt (NSOA, Y, Y_tlm, & - Tstart, Tend, T, & - AbsTol, RelTol, & - ode_Fun, ode_Jac, ode_Hess, & -!~~~> Rosenbrock method coefficients - ros_S, ros_M, ros_E, ros_A, ros_C, & - ros_Alpha, ros_Gamma, ros_ELO, ros_NewF, & -!~~~> Integration parameters - Autonomous, VectorTol, Max_no_steps, & - Roundoff, Hmin, Hmax, Hstart, Hexit, & - FacMin, FacMax, FacRej, FacSafe, & -!~~~> Error indicator - IERR ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Template for the implementation of a generic Rosenbrock method -! defined by ros_S (no of stages) -! and its coefficients ros_{A,C,M,E,Alpha,Gamma} -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - -!~~~> Input: the initial condition at Tstart; Output: the solution at T - KPP_REAL, INTENT(INOUT) :: Y(NVAR) -!~~~> Input: Number of sensitivity coefficients - INTEGER, INTENT(IN) :: NSOA -!~~~> Input: the initial sensitivites at Tstart; Output: the sensitivities at T - KPP_REAL, INTENT(INOUT) :: Y_tlm(NVAR,NSOA) -!~~~> Input: integration interval - KPP_REAL, INTENT(IN) :: Tstart,Tend -!~~~> Output: time at which the solution is returned (T=Tend if success) - KPP_REAL, INTENT(OUT) :: T -!~~~> Input: tolerances - KPP_REAL, INTENT(IN) :: AbsTol(NVAR), RelTol(NVAR) -!~~~> Input: ode function and its Jacobian - EXTERNAL ode_Fun, ode_Jac, ode_Hess -!~~~> Input: The Rosenbrock method parameters - INTEGER, INTENT(IN) :: ros_S - KPP_REAL, INTENT(IN) :: ros_M(ros_S), ros_E(ros_S), & - ros_Alpha(ros_S), ros_A(ros_S*(ros_S-1)/2), & - ros_Gamma(ros_S), ros_C(ros_S*(ros_S-1)/2), ros_ELO - LOGICAL, INTENT(IN) :: ros_NewF(ros_S) -!~~~> Input: integration parameters - LOGICAL, INTENT(IN) :: Autonomous, VectorTol - KPP_REAL, INTENT(IN) :: Hstart, Hmin, Hmax - INTEGER, INTENT(IN) :: Max_no_steps - KPP_REAL, INTENT(IN) :: Roundoff, FacMin, FacMax, FacRej, FacSafe -!~~~> Output: last accepted step - KPP_REAL, INTENT(OUT) :: Hexit -!~~~> Output: Error indicator - INTEGER, INTENT(OUT) :: IERR -! ~~~~ Local variables - KPP_REAL :: Ystage(NVAR*ros_S), Fcn0(NVAR), Fcn(NVAR) - KPP_REAL :: K(NVAR*ros_S), Tmp(NVAR) - KPP_REAL :: Ystage_tlm(NVAR*ros_S,NSOA), Fcn0_tlm(NVAR,NSOA), Fcn_tlm(NVAR,NSOA) - KPP_REAL :: K_tlm(NVAR*ros_S,NSOA) - KPP_REAL :: Hes0(NHESS) - KPP_REAL :: dFdT(NVAR), dJdT(LU_NONZERO) - KPP_REAL :: Jac0(LU_NONZERO), Jac(LU_NONZERO), Ghimj(LU_NONZERO) - KPP_REAL :: H, Hnew, HC, HG, Fac, Tau - KPP_REAL :: Err, Yerr(NVAR), Ynew(NVAR), Ynew_tlm(NVAR,NSOA) - INTEGER :: Pivot(NVAR), Direction, ioffset, joffset, j, istage, mtlm - LOGICAL :: RejectLastH, RejectMoreH, Singular -!~~~> Local parameters - KPP_REAL, PARAMETER :: ZERO = 0.0d0, ONE = 1.0d0 - KPP_REAL, PARAMETER :: DeltaMin = 1.0d-5 -!~~~> Locally called functions -! KPP_REAL WLAMCH -! EXTERNAL WLAMCH -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - -!~~~> Initial preparations - T = Tstart - Hexit = 0.0_dp - H = MIN(Hstart,Hmax) - IF (ABS(H) <= 10.D0*Roundoff) H = DeltaMin - - IF (Tend >= Tstart) THEN - Direction = +1 - ELSE - Direction = -1 - END IF - - RejectLastH=.FALSE. - RejectMoreH=.FALSE. - -!~~~> Time loop begins below - -TimeLoop: DO WHILE ( (Direction > 0).AND.((T-Tend)+Roundoff <= ZERO) & - .OR. (Direction < 0).AND.((Tend-T)+Roundoff <= ZERO) ) - - IF ( Nstp > Max_no_steps ) THEN ! Too many steps - CALL ros_ErrorMsg(-6,T,H,IERR) - RETURN - END IF - IF ( ((T+0.1d0*H) == T).OR.(H <= Roundoff) ) THEN ! Step size too small - CALL ros_ErrorMsg(-7,T,H,IERR) - RETURN - END IF - -!~~~> Limit H if necessary to avoid going beyond Tend - Hexit = H - H = MIN(H,ABS(Tend-T)) - -!~~~> Compute the function at current time - CALL ode_Fun(T,Y,Fcn0) - -!~~~> Compute the Jacobian at current time - CALL ode_Jac(T,Y,Jac0) - -!~~~> Compute the Hessian at current time - CALL ode_Hess(T,Y,Hes0) - -!~~~> Compute the TLM function at current time - DO mtlm = 1, NSOA - CALL Jac_SP_Vec ( Jac0, Y_tlm(1:NVAR,mtlm), Fcn0_tlm(1:NVAR,mtlm) ) - END DO - -!~~~> Compute the function and Jacobian derivatives with respect to T - IF (.NOT.Autonomous) THEN - CALL ros_FunTimeDerivative ( T, Roundoff, Y, & - Fcn0, ode_Fun, dFdT ) - CALL ros_JacTimeDerivative ( T, Roundoff, Y, & - Jac0, ode_Jac, dJdT ) - END IF - -!~~~> Repeat step calculation until current step accepted -UntilAccepted: DO - - CALL ros_PrepareMatrix(H,Direction,ros_Gamma(1),& - Jac0,Ghimj,Pivot,Singular) - IF (Singular) THEN ! More than 5 consecutive failed decompositions - CALL ros_ErrorMsg(-8,T,H,IERR) - RETURN - END IF - -!~~~> Compute the stages -Stage: DO istage = 1, ros_S - - ! Current istage vector is K(ioffset+1:ioffset+NVAR:ioffset+1+NVAR-1) - ioffset = NVAR*(istage-1) - - ! For the 1st istage the function has been computed previously - IF ( istage == 1 ) THEN - CALL WCOPY(NVAR,Y,1,Ystage(ioffset+1:ioffset+NVAR),1) - DO mtlm=1,NSOA - CALL WCOPY(NVAR,Y_tlm(1:NVAR,mtlm),1,Ystage_tlm(ioffset+1:ioffset+NVAR,mtlm),1) - END DO - CALL WCOPY(NVAR,Fcn0,1,Fcn,1) - CALL WCOPY(NVAR*NSOA,Fcn0_tlm,1,Fcn_tlm,1) - ! istage>1 and a new function evaluation is needed at the current istage - ELSEIF ( ros_NewF(istage) ) THEN - CALL WCOPY(NVAR,Y,1,Ystage(ioffset+1:ioffset+NVAR),1) - DO mtlm=1,NSOA - CALL WCOPY(NVAR,Y_tlm(1:NVAR,mtlm),1,Ystage_tlm(ioffset+1:ioffset+NVAR,mtlm),1) - END DO - DO j = 1, istage-1 - joffset = NVAR*(j-1) - CALL WAXPY(NVAR,ros_A((istage-1)*(istage-2)/2+j), & - K(joffset+1:joffset+NVAR),1,Ystage(ioffset+1:ioffset+NVAR),1) - DO mtlm=1,NSOA - CALL WAXPY(NVAR,ros_A((istage-1)*(istage-2)/2+j), & - K_tlm(joffset+1:joffset+NVAR,mtlm),1,Ystage_tlm(ioffset+1:ioffset+NVAR,mtlm),1) - END DO - END DO - Tau = T + ros_Alpha(istage)*Direction*H - CALL ode_Fun(Tau,Ystage(ioffset+1:ioffset+NVAR),Fcn) - CALL ode_Jac(Tau,Ystage(ioffset+1:ioffset+NVAR),Jac) - DO mtlm=1,NSOA - CALL Jac_SP_Vec ( Jac, Ystage_tlm(ioffset+1:ioffset+NVAR,mtlm), Fcn_tlm(1:NVAR,mtlm) ) - END DO - END IF ! if istage == 1 elseif ros_NewF(istage) - - CALL WCOPY(NVAR,Fcn,1,K(ioffset+1:ioffset+NVAR),1) - DO mtlm=1,NSOA - CALL WCOPY(NVAR,Fcn_tlm(1:NVAR,mtlm),1,K_tlm(ioffset+1:ioffset+NVAR,mtlm),1) - END DO - DO j = 1, istage-1 - HC = ros_C((istage-1)*(istage-2)/2+j)/(Direction*H) - CALL WAXPY(NVAR,HC,K(NVAR*(j-1)+1:NVAR*j),1,K(ioffset+1:ioffset+NVAR),1) - DO mtlm=1,NSOA - CALL WAXPY(NVAR,HC,K_tlm(NVAR*(j-1)+1:NVAR*j,mtlm),1,K_tlm(ioffset+1:ioffset+NVAR,mtlm),1) - END DO - END DO - IF ((.NOT. Autonomous).AND.(ros_Gamma(istage).NE.ZERO)) THEN - HG = Direction*H*ros_Gamma(istage) - CALL WAXPY(NVAR,HG,dFdT,1,K(ioffset+1:ioffset+NVAR),1) - DO mtlm=1,NSOA - CALL Jac_SP_Vec ( dJdT, Ystage_tlm(ioffset+1:ioffset+NVAR,mtlm), Fcn_tlm(1:NVAR,mtlm) ) - CALL WAXPY(NVAR,HG,Fcn_tlm(1:NVAR,mtlm),1,K_tlm(ioffset+1:ioffset+NVAR,mtlm),1) - END DO - END IF - CALL ros_Solve('N', Ghimj, Pivot, K(ioffset+1:ioffset+NVAR)) - DO mtlm=1,NSOA - CALL Hess_Vec ( Hes0, K(ioffset+1:ioffset+NVAR), Y_tlm(1:NVAR,mtlm), Tmp ) - CALL WAXPY(NVAR,ONE,Tmp,1,K_tlm(ioffset+1:ioffset+NVAR,mtlm),1) - CALL ros_Solve('N', Ghimj, Pivot, K_tlm(ioffset+1:ioffset+NVAR,mtlm)) - END DO - - END DO Stage - - -!~~~> Compute the new solution - CALL WCOPY(NVAR,Y,1,Ynew,1) - DO j=1,ros_S - CALL WAXPY(NVAR,ros_M(j),K(NVAR*(j-1)+1:NVAR*j),1,Ynew,1) - END DO - DO mtlm=1,NSOA - CALL WCOPY(NVAR,Y_tlm(1:NVAR,mtlm),1,Ynew_tlm(1:NVAR,mtlm),1) - DO j=1,ros_S - joffset = NVAR*(j-1) - CALL WAXPY(NVAR,ros_M(j),K_tlm(joffset+1:joffset+NVAR,mtlm),1,Ynew_tlm(1:NVAR,mtlm),1) - END DO - END DO - -!~~~> Compute the error estimation - CALL WSCAL(NVAR,ZERO,Yerr,1) - DO j=1,ros_S - CALL WAXPY(NVAR,ros_E(j),K(NVAR*(j-1)+1:NVAR*j),1,Yerr,1) - END DO - Err = ros_ErrorNorm ( Y, Ynew, Yerr, AbsTol, RelTol, VectorTol ) - -!~~~> New step size is bounded by FacMin <= Hnew/H <= FacMax - Fac = MIN(FacMax,MAX(FacMin,FacSafe/Err**(ONE/ros_ELO))) - Hnew = H*Fac - -!~~~> Check the error magnitude and adjust step size - Nstp = Nstp+1 - IF ( (Err <= ONE).OR.(H <= Hmin) ) THEN !~~~> Accept step - Nacc = Nacc+1 - !~~~> Checkpoints for stage values and vectors - CALL ros_DPush( ros_S, NSOA, T, H, Ystage, K, Ystage_tlm, K_tlm ) - !~~~> Accept new solution, etc. - CALL WCOPY(NVAR,Ynew,1,Y,1) - CALL WCOPY(NVAR*NSOA,Ynew_tlm,1,Y_tlm,1) - T = T + Direction*H - Hnew = MAX(Hmin,MIN(Hnew,Hmax)) - IF (RejectLastH) THEN ! No step size increase after a rejected step - Hnew = MIN(Hnew,H) - END IF - RejectLastH = .FALSE. - RejectMoreH = .FALSE. - H = Hnew - EXIT UntilAccepted ! EXIT THE LOOP: WHILE STEP NOT ACCEPTED - ELSE !~~~> Reject step - IF (RejectMoreH) THEN - Hnew = H*FacRej - END IF - RejectMoreH = RejectLastH - RejectLastH = .TRUE. - H = Hnew - IF (Nacc >= 1) THEN - Nrej = Nrej+1 - END IF - END IF ! Err <= 1 - - END DO UntilAccepted - - END DO TimeLoop - -!~~~> Succesful exit - IERR = 1 !~~~> The integration was successful - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - END SUBROUTINE ros_TlmInt -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_SoaInt ( & - NSOA, Lambda, Sigma, & - Tstart, Tend, T, & - AbsTol, RelTol, & - ode_Fun, ode_Jac, ode_Hess, & -!~~~> RosenbrockSOA method coefficients - ros_S, ros_M, ros_E, ros_A, ros_C, & - ros_Alpha, ros_Gamma, ros_ELO, ros_NewF, & -!~~~> Integration parameters - Autonomous, VectorTol, Max_no_steps, & - Roundoff, Hmin, Hmax, Hstart, & - FacMin, FacMax, FacRej, FacSafe, & -!~~~> Error indicator - IERR ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Template for the implementation of a generic RosenbrockSOA method -! defined by ros_S (no of stages) -! and its coefficients ros_{A,C,M,E,Alpha,Gamma} -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - -!~~~> Input: the initial condition at Tstart; Output: the solution at T - INTEGER, INTENT(IN) :: NSOA -!~~~> First order adjoint - KPP_REAL, INTENT(INOUT) :: Lambda(NVAR) -!~~~> Second order adjoint - KPP_REAL, INTENT(INOUT) :: Sigma(NVAR,NSOA) -!~~~> Input: integration interval - KPP_REAL, INTENT(IN) :: Tstart,Tend -!~~~> Output: time at which the solution is returned (T=Tend if success) - KPP_REAL, INTENT(OUT) :: T -!~~~> Input: tolerances - KPP_REAL, INTENT(IN) :: AbsTol(NVAR), RelTol(NVAR) -!~~~> Input: ode function and its Jacobian - EXTERNAL ode_Fun, ode_Jac, ode_Hess -!~~~> Input: The RosenbrockSOA method parameters - INTEGER, INTENT(IN) :: ros_S - KPP_REAL, INTENT(IN) :: ros_M(ros_S), ros_E(ros_S), & - ros_Alpha(ros_S), ros_A(ros_S*(ros_S-1)/2), & - ros_Gamma(ros_S), ros_C(ros_S*(ros_S-1)/2), ros_ELO - LOGICAL, INTENT(IN) :: ros_NewF(ros_S) -!~~~> Input: integration parameters - LOGICAL, INTENT(IN) :: Autonomous, VectorTol - KPP_REAL, INTENT(IN) :: Hstart, Hmin, Hmax - INTEGER, INTENT(IN) :: Max_no_steps - KPP_REAL, INTENT(IN) :: Roundoff, FacMin, FacMax, FacRej, FacSafe -!~~~> Output: Error indicator - INTEGER, INTENT(OUT) :: IERR -! ~~~~ Local variables - !KPP_REAL :: Ystage_adj(NVAR,NSOA) - !KPP_REAL :: dFdT(NVAR) - KPP_REAL :: Ystage(NVAR*ros_S), K(NVAR*ros_S) - KPP_REAL :: Ystage_tlm(NVAR*ros_S,NSOA), K_tlm(NVAR*ros_S,NSOA) - KPP_REAL :: U(NVAR*ros_S), V(NVAR*ros_S) - KPP_REAL :: W(NVAR*ros_S,NSOA), Z(NVAR*ros_S,NSOA) - KPP_REAL :: Jac(LU_NONZERO), dJdT(LU_NONZERO), Ghimj(LU_NONZERO) - KPP_REAL :: Hes0(NHESS), Hes1(NHESS), dHdT(NHESS) - KPP_REAL :: Tmp(NVAR), Tmp2(NVAR) - KPP_REAL :: H, HC, HA, Tau - INTEGER :: Pivot(NVAR), Direction, i, ioffset, joffset - INTEGER :: msoa, j, istage -!~~~> Local parameters - KPP_REAL, PARAMETER :: ZERO = 0.0d0, ONE = 1.0d0 - KPP_REAL, PARAMETER :: DeltaMin = 1.0d-5 -!~~~> Locally called functions -! KPP_REAL WLAMCH -! EXTERNAL WLAMCH -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - - - IF (Tend >= Tstart) THEN - Direction = +1 - ELSE - Direction = -1 - END IF - -!~~~> Time loop begins below -TimeLoop: DO WHILE ( stack_ptr > 0 ) - - !~~~> Recover checkpoints for stage values and vectors - CALL ros_DPop( ros_S, NSOA, T, H, Ystage, K, Ystage_tlm, K_tlm ) - - Nstp = Nstp+1 - -!~~~> Compute LU decomposition - CALL ode_Jac(T,Ystage(1:NVAR),Ghimj) - CALL WSCAL(LU_NONZERO,(-ONE),Ghimj,1) - Tau = ONE/(Direction*H*ros_Gamma(1)) - DO i=1,NVAR - Ghimj(LU_DIAG(i)) = Ghimj(LU_DIAG(i))+Tau - END DO - CALL ros_Decomp( Ghimj, Pivot, j ) - -!~~~> Compute Hessian at the beginning of the interval - CALL ode_Hess(T,Ystage(1),Hes0) - -!~~~> Compute the stages -Stage: DO istage = ros_S, 1, -1 - - !~~~> Current istage offset. - ioffset = NVAR*(istage-1) - - !~~~> Compute U - CALL WCOPY(NVAR,Lambda,1,U(ioffset+1:ioffset+NVAR),1) - CALL WSCAL(NVAR,ros_M(istage),U(ioffset+1:ioffset+NVAR),1) - DO j = istage+1, ros_S - joffset = NVAR*(j-1) - HA = ros_A((j-1)*(j-2)/2+istage) - HC = ros_C((j-1)*(j-2)/2+istage)/(Direction*H) - CALL WAXPY(NVAR,HA,V(joffset+1:joffset+NVAR),1,U(ioffset+1:ioffset+NVAR),1) - CALL WAXPY(NVAR,HC,U(joffset+1:joffset+NVAR),1,U(ioffset+1:ioffset+NVAR),1) - END DO - CALL ros_Solve('T', Ghimj, Pivot, U(ioffset+1:ioffset+NVAR)) - !~~~> Compute W - DO msoa = 1, NSOA - CALL WCOPY(NVAR,Sigma(1:NVAR,msoa),1,W(ioffset+1:ioffset+NVAR,msoa),1) - CALL WSCAL(NVAR,ros_M(istage),W(ioffset+1:ioffset+NVAR,msoa),1) - END DO - DO j = istage+1, ros_S - joffset = NVAR*(j-1) - HA = ros_A((j-1)*(j-2)/2+istage) - HC = ros_C((j-1)*(j-2)/2+istage)/(Direction*H) - DO msoa = 1, NSOA - CALL WAXPY(NVAR,HA, & - Z(joffset+1:joffset+NVAR,msoa),1,W(ioffset+1:ioffset+NVAR,msoa),1) - CALL WAXPY(NVAR,HC, & - W(joffset+1:joffset+NVAR,msoa),1,W(ioffset+1:ioffset+NVAR,msoa),1) - END DO - END DO - DO msoa = 1, NSOA - CALL HessTR_Vec( Hes0, U(ioffset+1:ioffset+NVAR), Ystage_tlm(ioffset+1:ioffset+NVAR,msoa), Tmp ) - CALL WAXPY(NVAR,ONE,Tmp,1,W(ioffset+1:ioffset+NVAR,msoa),1) - CALL ros_Solve('T', Ghimj, Pivot, W(ioffset+1:ioffset+NVAR,msoa)) - END DO - !~~~> Compute V - Tau = T + ros_Alpha(istage)*Direction*H - CALL ode_Jac(Tau,Ystage(ioffset+1:ioffset+NVAR),Jac) - CALL JacTR_SP_Vec(Jac,U(ioffset+1:ioffset+NVAR),V(ioffset+1:ioffset+NVAR)) - !~~~> Compute Z - CALL ode_Hess(T,Ystage(ioffset+1:ioffset+NVAR),Hes1) - DO msoa = 1, NSOA - CALL JacTR_SP_Vec(Jac,W(ioffset+1:ioffset+NVAR,msoa),Z(ioffset+1:ioffset+NVAR,msoa)) - CALL HessTR_Vec( Hes1, U(ioffset+1:ioffset+NVAR), Ystage_tlm(ioffset+1:ioffset+NVAR,msoa), Tmp ) - CALL WAXPY(NVAR,ONE,Tmp,1,Z(ioffset+1:ioffset+NVAR,msoa),1) - END DO - - END DO Stage - - IF (.NOT.Autonomous) THEN -!~~~> Compute the Jacobian derivative with respect to T. -! Last "Jac" computed for stage 1 - CALL ros_JacTimeDerivative ( T, Roundoff, Ystage(1), & - Jac, ode_Jac, dJdT ) -!~~~> Compute the Hessian derivative with respect to T. -! Last "Jac" computed for stage 1 - CALL ros_HesTimeDerivative ( T, Roundoff, Ystage(1), & - Hes0, ode_Hess, dHdT ) - END IF - -!~~~> Compute the new solution - - !~~~> Compute Lambda - DO istage=1,ros_S - ioffset = NVAR*(istage-1) - ! Add V_i - CALL WAXPY(NVAR,ONE,V(ioffset+1:ioffset+NVAR),1,Lambda,1) - ! Add (H0xK_i)^T * U_i - CALL HessTR_Vec ( Hes0, U(ioffset+1:ioffset+NVAR), K(ioffset+1:ioffset+NVAR), Tmp ) - CALL WAXPY(NVAR,ONE,Tmp,1,Lambda,1) - END DO - ! Add H * dJac_dT_0^T * \sum(gamma_i U_i) - ! Tmp holds sum gamma_i U_i - IF (.NOT.Autonomous) THEN - Tmp(1:NVAR) = ZERO - DO istage = 1, ros_S - ioffset = NVAR*(istage-1) - CALL WAXPY(NVAR,ros_Gamma(istage),U(ioffset+1:ioffset+NVAR),1,Tmp,1) - END DO - CALL JacTR_SP_Vec(dJdT,Tmp,Tmp2) - CALL WAXPY(NVAR,H,Tmp2,1,Lambda,1) - END IF ! .NOT.Autonomous - - !~~~> Compute Sigma - DO msoa = 1, NSOA - - DO istage=1,ros_S - ioffset = NVAR*(istage-1) - ! Add Z_i - CALL WAXPY(NVAR,ONE,Z(ioffset+1:ioffset+NVAR,msoa),1,Sigma(1:NVAR,msoa),1) - ! Add (Hess_0 x K_i)^T * W_i - CALL HessTR_Vec ( Hes0, W(ioffset+1:ioffset+NVAR,msoa), K(ioffset+1:ioffset+NVAR), Tmp ) - CALL WAXPY(NVAR,ONE,Tmp,1,Sigma(1:NVAR,msoa),1) - ! Add (Hess_0 x K_tlm_i)^T * U_i - CALL HessTR_Vec ( Hes0, U(ioffset+1:ioffset+NVAR), K_tlm(ioffset+1:ioffset+NVAR,msoa), Tmp ) - CALL WAXPY(NVAR,ONE,Tmp,1,Sigma(1:NVAR,msoa),1) - END DO - - !~~~> Add high derivative terms - DO istage=1,ros_S - ioffset = NVAR*(istage-1) - CALL ros_HighDerivative ( T, Roundoff, Ystage(1), Hes0, K(ioffset+1:ioffset+NVAR), & - U(ioffset+1:ioffset+NVAR), Ystage_tlm(1:NVAR,msoa), ode_Hess, Tmp) - CALL WAXPY(NVAR,ONE,Tmp,1,Sigma(1:NVAR,msoa),1) - END DO - - IF (.NOT.Autonomous) THEN - ! Add H * dJac_dT_0^T * \sum(gamma_i W_i) - ! Tmp holds sum gamma_i W_i - Tmp(1:NVAR) = ZERO - DO istage = 1, ros_S - ioffset = NVAR*(istage-1) - CALL WAXPY(NVAR,ros_Gamma(istage),W(ioffset+1:ioffset+NVAR,msoa),1,Tmp,1) - END DO - CALL JacTR_SP_Vec(dJdT,Tmp,Tmp2) - CALL WAXPY(NVAR,H,Tmp2,1,Sigma(1:NVAR,msoa),1) - ! Add H * ( dHess_dT_0 x Y_tlm_0)^T * \sum(gamma_i U_i) - ! Tmp holds sum gamma_i U_i - Tmp(1:NVAR) = ZERO - DO istage = 1, ros_S - ioffset = NVAR*(istage-1) - CALL WAXPY(NVAR,ros_Gamma(istage),U(ioffset+1:ioffset+NVAR),1,Tmp,1) - END DO - CALL HessTR_Vec ( dHdT, Tmp, Ystage_tlm(ioffset+1:ioffset+NVAR,msoa), Tmp2 ) - CALL WAXPY(NVAR,H,Tmp2,1,Sigma(1:NVAR,msoa),1) - END IF ! .NOT.Autonomous - - END DO ! msoa - - - END DO TimeLoop - -!~~~> Save last state - -!~~~> Succesful exit - IERR = 1 !~~~> The integration was successful - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - END SUBROUTINE ros_SoaInt -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - KPP_REAL FUNCTION ros_ErrorNorm ( Y, Ynew, Yerr, & - AbsTol, RelTol, VectorTol ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Computes the "scaled norm" of the error vector Yerr -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - -! Input arguments - KPP_REAL, INTENT(IN) :: Y(NVAR), Ynew(NVAR), & - Yerr(NVAR), AbsTol(NVAR), RelTol(NVAR) - LOGICAL, INTENT(IN) :: VectorTol -! Local variables - KPP_REAL :: Err, Scale, Ymax - INTEGER :: i - KPP_REAL, PARAMETER :: ZERO = 0.0d0 - - Err = ZERO - DO i=1,NVAR - Ymax = MAX(ABS(Y(i)),ABS(Ynew(i))) - IF (VectorTol) THEN - Scale = AbsTol(i)+RelTol(i)*Ymax - ELSE - Scale = AbsTol(1)+RelTol(1)*Ymax - END IF - Err = Err+(Yerr(i)/Scale)**2 - END DO - Err = SQRT(Err/NVAR) - - ros_ErrorNorm = MAX(Err,1.0d-10) - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - END FUNCTION ros_ErrorNorm -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_FunTimeDerivative ( T, Roundoff, Y, & - Fcn0, ode_Fun, dFdT ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> The time partial derivative of the function by finite differences -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - -!~~~> Input arguments - KPP_REAL, INTENT(IN) :: T, Roundoff, Y(NVAR), Fcn0(NVAR) - EXTERNAL ode_Fun -!~~~> Output arguments - KPP_REAL, INTENT(OUT) :: dFdT(NVAR) -!~~~> Local variables - KPP_REAL :: Delta - KPP_REAL, PARAMETER :: ONE = 1.0d0, DeltaMin = 1.0d-6 - - Delta = SQRT(Roundoff)*MAX(DeltaMin,ABS(T)) - CALL ode_Fun(T+Delta,Y,dFdT) - CALL WAXPY(NVAR,(-ONE),Fcn0,1,dFdT,1) - CALL WSCAL(NVAR,(ONE/Delta),dFdT,1) - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - END SUBROUTINE ros_FunTimeDerivative -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_JacTimeDerivative ( T, Roundoff, Y, & - Jac0, ode_Jac, dJdT ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> The time partial derivative of the Jacobian by finite differences -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - -!~~~> Input arguments - KPP_REAL, INTENT(IN) :: T, Roundoff, Y(NVAR), Jac0(LU_NONZERO) - EXTERNAL ode_Jac -!~~~> Output arguments - KPP_REAL, INTENT(OUT) :: dJdT(LU_NONZERO) -!~~~> Local variables - KPP_REAL Delta - KPP_REAL, PARAMETER :: ONE = 1.0d0, DeltaMin = 1.0d-6 - - Delta = SQRT(Roundoff)*MAX(DeltaMin,ABS(T)) - CALL ode_Jac( T+Delta, Y, dJdT ) - CALL WAXPY(LU_NONZERO,(-ONE),Jac0,1,dJdT,1) - CALL WSCAL(LU_NONZERO,(ONE/Delta),dJdT,1) - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - END SUBROUTINE ros_JacTimeDerivative -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_HesTimeDerivative ( T, Roundoff, Y, Hes0, ode_Hess, dHdT ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> The time partial derivative of the Hessian by finite differences -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - -!~~~> Input arguments - KPP_REAL, INTENT(IN) :: T, Roundoff, Y(NVAR), Hes0(NHESS) - EXTERNAL ode_Hess -!~~~> Output arguments - KPP_REAL, INTENT(OUT) :: dHdT(NHESS) -!~~~> Local variables - KPP_REAL Delta - KPP_REAL, PARAMETER :: ONE = 1.0d0, DeltaMin = 1.0d-6 - - Delta = SQRT(Roundoff)*MAX(DeltaMin,ABS(T)) - CALL ode_Hess( T+Delta, Y, dHdT ) - CALL WAXPY(NHESS,(-ONE),Hes0,1,dHdT,1) - CALL WSCAL(NHESS,(ONE/Delta),dHdT,1) - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - END SUBROUTINE ros_HesTimeDerivative -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_HighDerivative ( T, Roundoff, Y, Hes0, K, U, Y_tlm, & - ode_Hess, Term) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> High order derivative by finite differences: -! d/dy { (Hes0 x K_i)^T * U_i } * Y_tlm -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - -!~~~> Input arguments - KPP_REAL, INTENT(IN) :: T, Roundoff, Y(NVAR), Hes0(NHESS) - KPP_REAL, INTENT(IN) :: K(NVAR), U(NVAR), Y_tlm(NVAR) - EXTERNAL ode_Hess -!~~~> Output arguments - KPP_REAL, INTENT(OUT) :: Term(NVAR) -!~~~> Local variables - KPP_REAL :: Delta, Y1(NVAR), Hes1(NHESS), Tmp(NVAR) - KPP_REAL, PARAMETER :: ONE = 1.0d0, DeltaMin = 1.0d-6 - - CALL HessTR_Vec ( Hes0, U, K, Tmp ) - - Delta = SQRT(Roundoff)*MAX(DeltaMin,ABS(T)) - Y1(1:NVAR) = Y(1:NVAR) + Delta*Y_tlm(1:NVAR) - CALL ode_Hess( T, Y1, Hes1 ) - ! Add (Hess_0 x K_i)^T * U_i - CALL HessTR_Vec ( Hes1, U, K, Term ) - - CALL WAXPY(NVAR,(-ONE),Tmp,1,Term,1) - CALL WSCAL(NVAR,(ONE/Delta),Term,1) - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - END SUBROUTINE ros_HighDerivative -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_PrepareMatrix ( H, Direction, gam, & - Jac0, Ghimj, Pivot, Singular ) -! --- --- --- --- --- --- --- --- --- --- --- --- --- -! Prepares the LHS matrix for stage calculations -! 1. Construct Ghimj = 1/(H*ham) - Jac0 -! "(Gamma H) Inverse Minus Jacobian" -! 2. Repeat LU decomposition of Ghimj until successful. -! -half the step size if LU decomposition fails and retry -! -exit after 5 consecutive fails -! --- --- --- --- --- --- --- --- --- --- --- --- --- - IMPLICIT NONE - -!~~~> Input arguments - KPP_REAL, INTENT(IN) :: gam, Jac0(LU_NONZERO) - INTEGER, INTENT(IN) :: Direction -!~~~> Output arguments - KPP_REAL, INTENT(OUT) :: Ghimj(LU_NONZERO) - LOGICAL, INTENT(OUT) :: Singular - INTEGER, INTENT(OUT) :: Pivot(NVAR) -!~~~> Inout arguments - KPP_REAL, INTENT(INOUT) :: H ! step size is decreased when LU fails -!~~~> Local variables - INTEGER :: i, ising, Nconsecutive - KPP_REAL :: ghinv - KPP_REAL, PARAMETER :: ONE = 1.0d0, HALF = 0.5d0 - - Nconsecutive = 0 - Singular = .TRUE. - - DO WHILE (Singular) - -!~~~> Construct Ghimj = 1/(H*ham) - Jac0 - CALL WCOPY(LU_NONZERO,Jac0,1,Ghimj,1) - CALL WSCAL(LU_NONZERO,(-ONE),Ghimj,1) - ghinv = ONE/(Direction*H*gam) - DO i=1,NVAR - Ghimj(LU_DIAG(i)) = Ghimj(LU_DIAG(i))+ghinv - END DO -!~~~> Compute LU decomposition - CALL ros_Decomp( Ghimj, Pivot, ising ) - IF (ising == 0) THEN -!~~~> If successful done - Singular = .FALSE. - ELSE ! ising .ne. 0 -!~~~> If unsuccessful half the step size; if 5 consecutive fails then return - Nsng = Nsng+1 - Nconsecutive = Nconsecutive+1 - Singular = .TRUE. - PRINT*,'Warning: LU Decomposition returned ising = ',ising - IF (Nconsecutive <= 5) THEN ! Less than 5 consecutive failed decomps - H = H*HALF - ELSE ! More than 5 consecutive failed decompositions - RETURN - END IF ! Nconsecutive - END IF ! ising - - END DO ! WHILE Singular - - END SUBROUTINE ros_PrepareMatrix - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_Decomp( A, Pivot, ising ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Template for the LU decomposition -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE -!~~~> Inout variables - KPP_REAL, INTENT(INOUT) :: A(LU_NONZERO) -!~~~> Output variables - INTEGER, INTENT(OUT) :: Pivot(NVAR), ising - - CALL KppDecomp ( A, ising ) -!~~~> Note: for a full matrix use Lapack: -! CALL DGETRF( NVAR, NVAR, A, NVAR, Pivot, ising ) - Pivot(1) = 1 - - Ndec = Ndec + 1 - - END SUBROUTINE ros_Decomp - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_Solve( C, A, Pivot, b ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Template for the forward/backward substitution (using pre-computed LU decomp) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE -!~~~> Input variables - CHARACTER, INTENT(IN) :: C - KPP_REAL, INTENT(IN) :: A(LU_NONZERO) - INTEGER, INTENT(IN) :: Pivot(NVAR) -!~~~> InOut variables - KPP_REAL, INTENT(INOUT) :: b(NVAR) - - SELECT CASE (C) - CASE ('N') - CALL KppSolve( A, b ) - CASE ('T') - CALL KppSolveTR( A, b, b ) - CASE DEFAULT - PRINT*,'Unknown C = (',C,') in ros_Solve' - STOP - END SELECT -!~~~> Note: for a full matrix use Lapack: -! NRHS = 1 -! CALL DGETRS( C, NVAR , NRHS, A, NVAR, Pivot, b, NVAR, INFO ) - - Nsol = Nsol+1 - - END SUBROUTINE ros_Solve - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Ros2 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha,& - ros_Gamma,ros_NewF,ros_ELO,ros_Name) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! --- AN L-STABLE METHOD, 2 stages, order 2 -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - - INTEGER, PARAMETER :: S = 2 - INTEGER, INTENT(OUT) :: ros_S - KPP_REAL, DIMENSION(S), INTENT(OUT) :: ros_M,ros_E,ros_Alpha,ros_Gamma - KPP_REAL, DIMENSION(S*(S-1)/2), INTENT(OUT) :: ros_A, ros_C - KPP_REAL, INTENT(OUT) :: ros_ELO - LOGICAL, DIMENSION(S), INTENT(OUT) :: ros_NewF - CHARACTER(LEN=12), INTENT(OUT) :: ros_Name - KPP_REAL :: g - - g = 1.0d0 + 1.0d0/SQRT(2.0d0) - -!~~~> Name of the method - ros_Name = 'ROS-2' -!~~~> Number of stages - ros_S = S - -!~~~> The coefficient matrices A and C are strictly lower triangular. -! The lower triangular (subdiagonal) elements are stored in row-wise order: -! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. -! The general mapping formula is: -! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) -! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) - - ros_A(1) = (1.d0)/g - ros_C(1) = (-2.d0)/g -!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) -! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) - ros_NewF(1) = .TRUE. - ros_NewF(2) = .TRUE. -!~~~> M_i = Coefficients for new step solution - ros_M(1)= (3.d0)/(2.d0*g) - ros_M(2)= (1.d0)/(2.d0*g) -! E_i = Coefficients for error estimator - ros_E(1) = 1.d0/(2.d0*g) - ros_E(2) = 1.d0/(2.d0*g) -!~~~> ros_ELO = estimator of local order - the minimum between the -! main and the embedded scheme orders plus one - ros_ELO = 2.0d0 -!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) - ros_Alpha(1) = 0.0d0 - ros_Alpha(2) = 1.0d0 -!~~~> Gamma_i = \sum_j gamma_{i,j} - ros_Gamma(1) = g - ros_Gamma(2) =-g - - END SUBROUTINE Ros2 - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Ros3 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha,& - ros_Gamma,ros_NewF,ros_ELO,ros_Name) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! --- AN L-STABLE METHOD, 3 stages, order 3, 2 function evaluations -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - - INTEGER, PARAMETER :: S = 3 - INTEGER, INTENT(OUT) :: ros_S - KPP_REAL, DIMENSION(S), INTENT(OUT) :: ros_M,ros_E,ros_Alpha,ros_Gamma - KPP_REAL, DIMENSION(S*(S-1)/2), INTENT(OUT) :: ros_A, ros_C - KPP_REAL, INTENT(OUT) :: ros_ELO - LOGICAL, DIMENSION(S), INTENT(OUT) :: ros_NewF - CHARACTER(LEN=12), INTENT(OUT) :: ros_Name - -!~~~> Name of the method - ros_Name = 'ROS-3' -!~~~> Number of stages - ros_S = S - -!~~~> The coefficient matrices A and C are strictly lower triangular. -! The lower triangular (subdiagonal) elements are stored in row-wise order: -! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. -! The general mapping formula is: -! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) -! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) - - ros_A(1)= 1.d0 - ros_A(2)= 1.d0 - ros_A(3)= 0.d0 - - ros_C(1) = -0.10156171083877702091975600115545d+01 - ros_C(2) = 0.40759956452537699824805835358067d+01 - ros_C(3) = 0.92076794298330791242156818474003d+01 -!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) -! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) - ros_NewF(1) = .TRUE. - ros_NewF(2) = .TRUE. - ros_NewF(3) = .FALSE. -!~~~> M_i = Coefficients for new step solution - ros_M(1) = 0.1d+01 - ros_M(2) = 0.61697947043828245592553615689730d+01 - ros_M(3) = -0.42772256543218573326238373806514d+00 -! E_i = Coefficients for error estimator - ros_E(1) = 0.5d+00 - ros_E(2) = -0.29079558716805469821718236208017d+01 - ros_E(3) = 0.22354069897811569627360909276199d+00 -!~~~> ros_ELO = estimator of local order - the minimum between the -! main and the embedded scheme orders plus 1 - ros_ELO = 3.0d0 -!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) - ros_Alpha(1)= 0.0d+00 - ros_Alpha(2)= 0.43586652150845899941601945119356d+00 - ros_Alpha(3)= 0.43586652150845899941601945119356d+00 -!~~~> Gamma_i = \sum_j gamma_{i,j} - ros_Gamma(1)= 0.43586652150845899941601945119356d+00 - ros_Gamma(2)= 0.24291996454816804366592249683314d+00 - ros_Gamma(3)= 0.21851380027664058511513169485832d+01 - - END SUBROUTINE Ros3 - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Ros4 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha,& - ros_Gamma,ros_NewF,ros_ELO,ros_Name) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! L-STABLE ROSENBROCK METHOD OF ORDER 4, WITH 4 STAGES -! L-STABLE EMBEDDED ROSENBROCK METHOD OF ORDER 3 -! -! E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL -! EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS. -! SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS, -! SPRINGER-VERLAG (1990) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - - INTEGER, PARAMETER :: S=4 - INTEGER, INTENT(OUT) :: ros_S - KPP_REAL, DIMENSION(S), INTENT(OUT) :: ros_M,ros_E,ros_Alpha,ros_Gamma - KPP_REAL, DIMENSION(S*(S-1)/2), INTENT(OUT) :: ros_A, ros_C - KPP_REAL, INTENT(OUT) :: ros_ELO - LOGICAL, DIMENSION(S), INTENT(OUT) :: ros_NewF - CHARACTER(LEN=12), INTENT(OUT) :: ros_Name - - -!~~~> Name of the method - ros_Name = 'ROS-4' -!~~~> Number of stages - ros_S = S - -!~~~> The coefficient matrices A and C are strictly lower triangular. -! The lower triangular (subdiagonal) elements are stored in row-wise order: -! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. -! The general mapping formula is: -! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) -! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) - - ros_A(1) = 0.2000000000000000d+01 - ros_A(2) = 0.1867943637803922d+01 - ros_A(3) = 0.2344449711399156d+00 - ros_A(4) = ros_A(2) - ros_A(5) = ros_A(3) - ros_A(6) = 0.0D0 - - ros_C(1) =-0.7137615036412310d+01 - ros_C(2) = 0.2580708087951457d+01 - ros_C(3) = 0.6515950076447975d+00 - ros_C(4) =-0.2137148994382534d+01 - ros_C(5) =-0.3214669691237626d+00 - ros_C(6) =-0.6949742501781779d+00 -!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) -! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) - ros_NewF(1) = .TRUE. - ros_NewF(2) = .TRUE. - ros_NewF(3) = .TRUE. - ros_NewF(4) = .FALSE. -!~~~> M_i = Coefficients for new step solution - ros_M(1) = 0.2255570073418735d+01 - ros_M(2) = 0.2870493262186792d+00 - ros_M(3) = 0.4353179431840180d+00 - ros_M(4) = 0.1093502252409163d+01 -!~~~> E_i = Coefficients for error estimator - ros_E(1) =-0.2815431932141155d+00 - ros_E(2) =-0.7276199124938920d-01 - ros_E(3) =-0.1082196201495311d+00 - ros_E(4) =-0.1093502252409163d+01 -!~~~> ros_ELO = estimator of local order - the minimum between the -! main and the embedded scheme orders plus 1 - ros_ELO = 4.0d0 -!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) - ros_Alpha(1) = 0.D0 - ros_Alpha(2) = 0.1145640000000000d+01 - ros_Alpha(3) = 0.6552168638155900d+00 - ros_Alpha(4) = ros_Alpha(3) -!~~~> Gamma_i = \sum_j gamma_{i,j} - ros_Gamma(1) = 0.5728200000000000d+00 - ros_Gamma(2) =-0.1769193891319233d+01 - ros_Gamma(3) = 0.7592633437920482d+00 - ros_Gamma(4) =-0.1049021087100450d+00 - - END SUBROUTINE Ros4 - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Rodas3 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha,& - ros_Gamma,ros_NewF,ros_ELO,ros_Name) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! --- A STIFFLY-STABLE METHOD, 4 stages, order 3 -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - - INTEGER, PARAMETER :: S=4 - INTEGER, INTENT(OUT) :: ros_S - KPP_REAL, DIMENSION(S), INTENT(OUT) :: ros_M,ros_E,ros_Alpha,ros_Gamma - KPP_REAL, DIMENSION(S*(S-1)/2), INTENT(OUT) :: ros_A, ros_C - KPP_REAL, INTENT(OUT) :: ros_ELO - LOGICAL, DIMENSION(S), INTENT(OUT) :: ros_NewF - CHARACTER(LEN=12), INTENT(OUT) :: ros_Name - - -!~~~> Name of the method - ros_Name = 'RODAS-3' -!~~~> Number of stages - ros_S = S - -!~~~> The coefficient matrices A and C are strictly lower triangular. -! The lower triangular (subdiagonal) elements are stored in row-wise order: -! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. -! The general mapping formula is: -! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) -! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) - - ros_A(1) = 0.0d+00 - ros_A(2) = 2.0d+00 - ros_A(3) = 0.0d+00 - ros_A(4) = 2.0d+00 - ros_A(5) = 0.0d+00 - ros_A(6) = 1.0d+00 - - ros_C(1) = 4.0d+00 - ros_C(2) = 1.0d+00 - ros_C(3) =-1.0d+00 - ros_C(4) = 1.0d+00 - ros_C(5) =-1.0d+00 - ros_C(6) =-(8.0d+00/3.0d+00) - -!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) -! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) - ros_NewF(1) = .TRUE. - ros_NewF(2) = .FALSE. - ros_NewF(3) = .TRUE. - ros_NewF(4) = .TRUE. -!~~~> M_i = Coefficients for new step solution - ros_M(1) = 2.0d+00 - ros_M(2) = 0.0d+00 - ros_M(3) = 1.0d+00 - ros_M(4) = 1.0d+00 -!~~~> E_i = Coefficients for error estimator - ros_E(1) = 0.0d+00 - ros_E(2) = 0.0d+00 - ros_E(3) = 0.0d+00 - ros_E(4) = 1.0d+00 -!~~~> ros_ELO = estimator of local order - the minimum between the -! main and the embedded scheme orders plus 1 - ros_ELO = 3.0d+00 -!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) - ros_Alpha(1) = 0.0d+00 - ros_Alpha(2) = 0.0d+00 - ros_Alpha(3) = 1.0d+00 - ros_Alpha(4) = 1.0d+00 -!~~~> Gamma_i = \sum_j gamma_{i,j} - ros_Gamma(1) = 0.5d+00 - ros_Gamma(2) = 1.5d+00 - ros_Gamma(3) = 0.0d+00 - ros_Gamma(4) = 0.0d+00 - - END SUBROUTINE Rodas3 - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Rodas4 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha,& - ros_Gamma,ros_NewF,ros_ELO,ros_Name) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! STIFFLY-STABLE ROSENBROCK METHOD OF ORDER 4, WITH 6 STAGES -! -! E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL -! EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS. -! SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS, -! SPRINGER-VERLAG (1996) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - - INTEGER, PARAMETER :: S=6 - INTEGER, INTENT(OUT) :: ros_S - KPP_REAL, DIMENSION(S), INTENT(OUT) :: ros_M,ros_E,ros_Alpha,ros_Gamma - KPP_REAL, DIMENSION(S*(S-1)/2), INTENT(OUT) :: ros_A, ros_C - KPP_REAL, INTENT(OUT) :: ros_ELO - LOGICAL, DIMENSION(S), INTENT(OUT) :: ros_NewF - CHARACTER(LEN=12), INTENT(OUT) :: ros_Name - - -!~~~> Name of the method - ros_Name = 'RODAS-4' -!~~~> Number of stages - ros_S = S - -!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) - ros_Alpha(1) = 0.000d0 - ros_Alpha(2) = 0.386d0 - ros_Alpha(3) = 0.210d0 - ros_Alpha(4) = 0.630d0 - ros_Alpha(5) = 1.000d0 - ros_Alpha(6) = 1.000d0 - -!~~~> Gamma_i = \sum_j gamma_{i,j} - ros_Gamma(1) = 0.2500000000000000d+00 - ros_Gamma(2) =-0.1043000000000000d+00 - ros_Gamma(3) = 0.1035000000000000d+00 - ros_Gamma(4) =-0.3620000000000023d-01 - ros_Gamma(5) = 0.0d0 - ros_Gamma(6) = 0.0d0 - -!~~~> The coefficient matrices A and C are strictly lower triangular. -! The lower triangular (subdiagonal) elements are stored in row-wise order: -! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. -! The general mapping formula is: A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) -! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) - - ros_A(1) = 0.1544000000000000d+01 - ros_A(2) = 0.9466785280815826d+00 - ros_A(3) = 0.2557011698983284d+00 - ros_A(4) = 0.3314825187068521d+01 - ros_A(5) = 0.2896124015972201d+01 - ros_A(6) = 0.9986419139977817d+00 - ros_A(7) = 0.1221224509226641d+01 - ros_A(8) = 0.6019134481288629d+01 - ros_A(9) = 0.1253708332932087d+02 - ros_A(10) =-0.6878860361058950d+00 - ros_A(11) = ros_A(7) - ros_A(12) = ros_A(8) - ros_A(13) = ros_A(9) - ros_A(14) = ros_A(10) - ros_A(15) = 1.0d+00 - - ros_C(1) =-0.5668800000000000d+01 - ros_C(2) =-0.2430093356833875d+01 - ros_C(3) =-0.2063599157091915d+00 - ros_C(4) =-0.1073529058151375d+00 - ros_C(5) =-0.9594562251023355d+01 - ros_C(6) =-0.2047028614809616d+02 - ros_C(7) = 0.7496443313967647d+01 - ros_C(8) =-0.1024680431464352d+02 - ros_C(9) =-0.3399990352819905d+02 - ros_C(10) = 0.1170890893206160d+02 - ros_C(11) = 0.8083246795921522d+01 - ros_C(12) =-0.7981132988064893d+01 - ros_C(13) =-0.3152159432874371d+02 - ros_C(14) = 0.1631930543123136d+02 - ros_C(15) =-0.6058818238834054d+01 - -!~~~> M_i = Coefficients for new step solution - ros_M(1) = ros_A(7) - ros_M(2) = ros_A(8) - ros_M(3) = ros_A(9) - ros_M(4) = ros_A(10) - ros_M(5) = 1.0d+00 - ros_M(6) = 1.0d+00 - -!~~~> E_i = Coefficients for error estimator - ros_E(1) = 0.0d+00 - ros_E(2) = 0.0d+00 - ros_E(3) = 0.0d+00 - ros_E(4) = 0.0d+00 - ros_E(5) = 0.0d+00 - ros_E(6) = 1.0d+00 - -!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) -! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) - ros_NewF(1) = .TRUE. - ros_NewF(2) = .TRUE. - ros_NewF(3) = .TRUE. - ros_NewF(4) = .TRUE. - ros_NewF(5) = .TRUE. - ros_NewF(6) = .TRUE. - -!~~~> ros_ELO = estimator of local order - the minimum between the -! main and the embedded scheme orders plus 1 - ros_ELO = 4.0d0 - - END SUBROUTINE Rodas4 - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Fun_Template( T, Y, Ydot ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Template for the ODE function call. -! Updates the rate coefficients (and possibly the fixed species) at each call -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Input variables - KPP_REAL T, Y(NVAR) -!~~~> Output variables - KPP_REAL Ydot(NVAR) -!~~~> Local variables - KPP_REAL Told - - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Fun( Y, FIX, RCONST, Ydot ) - TIME = Told - - Nfun = Nfun+1 - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - END SUBROUTINE Fun_Template -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Jac_Template( T, Y, Jcb ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Template for the ODE Jacobian call. -! Updates the rate coefficients (and possibly the fixed species) at each call -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -!~~~> Input variables - KPP_REAL T, Y(NVAR) -!~~~> Output variables - KPP_REAL Jcb(LU_NONZERO) -!~~~> Local variables - KPP_REAL Told - - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Jac_SP( Y, FIX, RCONST, Jcb ) - TIME = Told - - Njac = Njac+1 - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - END SUBROUTINE Jac_Template -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Hess_Template( T, Y, Hes ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Template for the ODE Hessian call. -! Updates the rate coefficients (and possibly the fixed species) at each call -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Input variables - KPP_REAL T, Y(NVAR) -!~~~> Output variables - KPP_REAL Hes(NHESS) -!~~~> Local variables - KPP_REAL Told - - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Hessian( Y, FIX, RCONST, Hes ) - TIME = Told - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - END SUBROUTINE Hess_Template -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_AllocateDBuffers( S ) -!~~~> Allocate buffer space for discrete adjoint -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - INTEGER :: i, S - - ALLOCATE( buf_H(bufsize), STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed allocation of buffer H'; STOP - END IF - ALLOCATE( buf_T(bufsize), STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed allocation of buffer T'; STOP - END IF - ALLOCATE( buf_Y(NVAR*S,bufsize), STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed allocation of buffer Y'; STOP - END IF - ALLOCATE( buf_K(NVAR*S,bufsize), STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed allocation of buffer K'; STOP - END IF - ALLOCATE( buf_Y_tlm(NVAR*S,bufsize), STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed allocation of buffer Y_tlm'; STOP - END IF - ALLOCATE( buf_K_tlm(NVAR*S,bufsize), STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed allocation of buffer K_tlm'; STOP - END IF - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - END SUBROUTINE ros_AllocateDBuffers -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_FreeDBuffers -!~~~> Dallocate buffer space for discrete adjoint -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - INTEGER :: i - - DEALLOCATE( buf_H, STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed deallocation of buffer H'; STOP - END IF - DEALLOCATE( buf_T, STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed deallocation of buffer T'; STOP - END IF - DEALLOCATE( buf_Y, STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed deallocation of buffer Y'; STOP - END IF - DEALLOCATE( buf_K, STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed deallocation of buffer K'; STOP - END IF - DEALLOCATE( buf_Y_tlm, STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed deallocation of buffer Y_tlm'; STOP - END IF - DEALLOCATE( buf_K_tlm, STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed deallocation of buffer K_tlm'; STOP - END IF - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - END SUBROUTINE ros_FreeDBuffers -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_DPush( S, NSOA, T, H, Ystage, K, Ystage_tlm, K_tlm ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Saves the next trajectory snapshot for discrete adjoints -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - INTEGER, INTENT(IN) :: S ! no of stages - INTEGER, INTENT(IN) :: NSOA ! no of second order adjoints - KPP_REAL :: T, H, Ystage(NVAR*S), K(NVAR*S) - KPP_REAL :: Ystage_tlm(NVAR*S,NSOA), K_tlm(NVAR*S,NSOA) - - stack_ptr = stack_ptr + 1 - IF ( stack_ptr > bufsize ) THEN - PRINT*,'Push failed: buffer overflow' - STOP - END IF - buf_H( stack_ptr ) = H - buf_T( stack_ptr ) = T - CALL WCOPY(NVAR*S,Ystage,1,buf_Y(1:NVAR*S,stack_ptr),1) - CALL WCOPY(NVAR*S,K,1,buf_K(1:NVAR*S,stack_ptr),1) - CALL WCOPY(NVAR*S*NSOA,Ystage_tlm,1,buf_Y_tlm(1:NVAR*S*NSOA,stack_ptr),1) - CALL WCOPY(NVAR*S*NSOA,K_tlm,1,buf_K_tlm(1:NVAR*S*NSOA,stack_ptr),1) - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - END SUBROUTINE ros_DPush -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_DPop( S, NSOA, T, H, Ystage, K, Ystage_tlm, K_tlm ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Retrieves the next trajectory snapshot for discrete adjoints -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - INTEGER, INTENT(IN) :: S ! no of stages - INTEGER, INTENT(IN) :: NSOA ! no of second order adjoints - KPP_REAL, INTENT(OUT) :: T, H, Ystage(NVAR*S), K(NVAR*S) - KPP_REAL, INTENT(OUT) :: Ystage_tlm(NVAR*S,NSOA), K_tlm(NVAR*S,NSOA) - - IF ( stack_ptr <= 0 ) THEN - PRINT*,'Pop failed: empty buffer' - STOP - END IF - H = buf_H( stack_ptr ) - T = buf_T( stack_ptr ) - CALL WCOPY(NVAR*S,buf_Y(1:NVAR*S,stack_ptr),1,Ystage,1) - CALL WCOPY(NVAR*S,buf_K(1:NVAR*S,stack_ptr),1,K,1) - CALL WCOPY(NVAR*S*NSOA,buf_Y_tlm(1:NVAR*S*NSOA,stack_ptr),1,Ystage_tlm,1) - CALL WCOPY(NVAR*S*NSOA,buf_K_tlm(1:NVAR*S*NSOA,stack_ptr),1,K_tlm,1) - - stack_ptr = stack_ptr - 1 - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - END SUBROUTINE ros_DPop -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -END MODULE KPP_ROOT_Integrator - diff --git a/boxmox/int.modified_WCOPY/rosenbrock_tlm.f90 b/boxmox/int.modified_WCOPY/rosenbrock_tlm.f90 deleted file mode 100644 index e15efebfb8228ebc21bb23e3ff492030edf9d8ff..0000000000000000000000000000000000000000 --- a/boxmox/int.modified_WCOPY/rosenbrock_tlm.f90 +++ /dev/null @@ -1,1357 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! -! Rosenbrock_TLM - Implementation of the Tangent Linear Model ! -! for several Rosenbrock methods: ! -! * Ros2 ! -! * Ros3 ! -! * Ros4 ! -! * Rodas3 ! -! * Rodas4 ! -! By default the code employs the KPP sparse linear algebra routines ! -! Compile with -DFULL_ALGEBRA to use full linear algebra (LAPACK) ! -! ! -! (C) Adrian Sandu, August 2004 ! -! Virginia Polytechnic Institute and State University ! -! Contact: sandu@cs.vt.edu ! -! Revised by Philipp Miehe and Adrian Sandu, May 2006 ! -! This implementation is part of KPP - the Kinetic PreProcessor ! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! - -MODULE KPP_ROOT_Integrator - - USE KPP_ROOT_Precision - USE KPP_ROOT_Parameters - USE KPP_ROOT_Global - USE KPP_ROOT_LinearAlgebra - USE KPP_ROOT_Rates - USE KPP_ROOT_Function - USE KPP_ROOT_Jacobian - USE KPP_ROOT_Hessian - USE KPP_ROOT_Util - - IMPLICIT NONE - PUBLIC - SAVE - -!~~~> Statistics on the work performed by the Rosenbrock method - INTEGER, PARAMETER :: Nfun=1, Njac=2, Nstp=3, Nacc=4, & - Nrej=5, Ndec=6, Nsol=7, Nsng=8, & - Nhes=9, Ntexit=1, Nhexit=2, Nhnew = 3 - - -CONTAINS ! Functions in the module KPP_ROOT_Integrator - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -SUBROUTINE INTEGRATE_TLM( NTLM, Y, Y_tlm, TIN, TOUT, ATOL_tlm, RTOL_tlm,& - ICNTRL_U, RCNTRL_U, ISTATUS_U, RSTATUS_U ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - -!~~~> Y - Concentrations - KPP_REAL :: Y(NVAR) -!~~~> NTLM - No. of sensitivity coefficients - INTEGER NTLM -!~~~> Y_tlm - Sensitivities of concentrations -! Note: Y_tlm (1:NVAR,j) contains sensitivities of -! Y(1:NVAR) w.r.t. the j-th parameter, j=1...NTLM - KPP_REAL :: Y_tlm(NVAR,NTLM) - KPP_REAL, INTENT(IN) :: TIN ! TIN - Start Time - KPP_REAL, INTENT(IN) :: TOUT ! TOUT - End Time -!~~~> Optional input parameters and statistics - INTEGER, INTENT(IN), OPTIONAL :: ICNTRL_U(20) - KPP_REAL, INTENT(IN), OPTIONAL :: RCNTRL_U(20) - INTEGER, INTENT(OUT), OPTIONAL :: ISTATUS_U(20) - KPP_REAL, INTENT(OUT), OPTIONAL :: RSTATUS_U(20) - KPP_REAL, INTENT(IN), OPTIONAL :: RTOL_tlm(NVAR,NTLM),ATOL_tlm(NVAR,NTLM) - - INTEGER, SAVE :: IERR - KPP_REAL :: RCNTRL(20), RSTATUS(20) - INTEGER :: ICNTRL(20), ISTATUS(20) - INTEGER, SAVE :: Ntotal = 0 - - ICNTRL(1:20) = 0 - RCNTRL(1:20) = 0.0_dp - ISTATUS(1:20) = 0 - RSTATUS(1:20) = 0.0_dp - - ICNTRL(1) = 0 ! non-autonomous - ICNTRL(2) = 1 ! vector tolerances - ICNTRL(3) = 5 ! choice of the method - ICNTRL(12) = 1 ! 0 - fwd trunc error only, 1 - tlm trunc error - RCNTRL(3) = STEPMIN ! starting step - - ! if optional parameters are given, and if they are >=0, then they overwrite default settings - IF (PRESENT(ICNTRL_U)) THEN - WHERE(ICNTRL_U(:) >= 0) ICNTRL(:) = ICNTRL_U(:) - ENDIF - IF (PRESENT(RCNTRL_U)) THEN - WHERE(RCNTRL_U(:) >= 0) RCNTRL(:) = RCNTRL_U(:) - ENDIF - - CALL RosenbrockTLM(NVAR, VAR, NTLM, Y_tlm, & - TIN,TOUT,ATOL,RTOL,ATOL_tlm,RTOL_tlm, & - RCNTRL,ICNTRL,RSTATUS,ISTATUS,IERR) - -!~~~> Debug option: show number of steps -! Ntotal = Ntotal + ISTATUS(Nstp) -! PRINT*,'NSTEPS=',ISTATUS(Nstp),' (',Ntotal,')',' O3=', VAR(ind_O3) - - IF (IERR < 0) THEN - print *,'Rosenbrock: Unsucessful step at T=', & - TIN,' (IERR=',IERR,')' - END IF - - STEPMIN = RSTATUS(Nhexit) - ! if optional parameters are given for output they return information - IF (PRESENT(ISTATUS_U)) ISTATUS_U(:) = ISTATUS(:) - IF (PRESENT(RSTATUS_U)) RSTATUS_U(:) = RSTATUS(:) - -END SUBROUTINE INTEGRATE_TLM - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -SUBROUTINE RosenbrockTLM(N,Y,NTLM,Y_tlm, & - Tstart,Tend,AbsTol,RelTol,AbsTol_tlm,RelTol_tlm, & - RCNTRL,ICNTRL,RSTATUS,ISTATUS,IERR) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -! TLM = Tangent Linear Model of a Rosenbrock Method -! -! Solves the system y'=F(t,y) using a Rosenbrock method defined by: -! -! G = 1/(H*gamma(1)) - Jac(t0,Y0) -! T_i = t0 + Alpha(i)*H -! Y_i = Y0 + \sum_{j=1}^{i-1} A(i,j)*K_j -! G * K_i = Fun( T_i, Y_i ) + \sum_{j=1}^S C(i,j)/H * K_j + -! gamma(i)*dF/dT(t0, Y0) -! Y1 = Y0 + \sum_{j=1}^S M(j)*K_j -! -! For details on Rosenbrock methods and their implementation consult: -! E. Hairer and G. Wanner -! "Solving ODEs II. Stiff and differential-algebraic problems". -! Springer series in computational mathematics, Springer-Verlag, 1996. -! The codes contained in the book inspired this implementation. -! -! (C) Adrian Sandu, August 2004 -! Virginia Polytechnic Institute and State University -! Contact: sandu@cs.vt.edu -! Revised by Philipp Miehe and Adrian Sandu, May 2006 -! This implementation is part of KPP - the Kinetic PreProcessor -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!~~~> INPUT ARGUMENTS: -! -!- Y(N) -> vector of initial conditions (at T=Tstart) -! NTLM -> dimension of linearized system, -! i.e. the number of sensitivity coefficients -!- Y_tlm(N*NTLM) -> vector of initial sensitivity conditions (at T=Tstart) -!- [Tstart,Tend] -> time range of integration -! (if Tstart>Tend the integration is performed backwards in time) -!- RelTol, AbsTol -> user precribed accuracy -!- SUBROUTINE Fun( T, Y, Ydot ) -> ODE function, -! returns Ydot = Y' = F(T,Y) -!- SUBROUTINE Jac( T, Y, Jcb ) -> Jacobian of the ODE function, -! returns Jcb = dF/dY -!- ICNTRL(1:20) -> integer inputs parameters -!- RCNTRL(1:20) -> real inputs parameters -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!~~~> OUTPUT ARGUMENTS: -! -!- Y(N) -> vector of final states (at T->Tend) -!- Y_tlm(N*NTLM)-> vector of final sensitivities (at T=Tend) -!- ISTATUS(1:20) -> integer output parameters -!- RSTATUS(:20) -> real output parameters -!- IERR -> job status upon return -! - succes (positive value) or failure (negative value) - -! = 1 : Success -! = -1 : Improper value for maximal no of steps -! = -2 : Selected Rosenbrock method not implemented -! = -3 : Hmin/Hmax/Hstart must be positive -! = -4 : FacMin/FacMax/FacRej must be positive -! = -5 : Improper tolerance values -! = -6 : No of steps exceeds maximum bound -! = -7 : Step size too small -! = -8 : Matrix is repeatedly singular -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!~~~> INPUT PARAMETERS: -! -! Note: For input parameters equal to zero the default values of the -! corresponding variables are used. -! -! ICNTRL(1) = 1: F = F(y) Independent of T (AUTONOMOUS) -! = 0: F = F(t,y) Depends on T (NON-AUTONOMOUS) -! -! ICNTRL(2) = 0: AbsTol, RelTol are N-dimensional vectors -! = 1: AbsTol, RelTol are scalars -! -! ICNTRL(3) -> selection of a particular Rosenbrock method -! = 0 : default method is Rodas3 -! = 1 : method is Ros2 -! = 2 : method is Ros3 -! = 3 : method is Ros4 -! = 4 : method is Rodas3 -! = 5 : method is Rodas4 -! -! ICNTRL(4) -> maximum number of integration steps -! For ICNTRL(4)=0) the default value of 100000 is used -! -! ICNTRL(12) -> switch for TLM truncation error control -! ICNTRL(12) = 0: TLM error is not used -! ICNTRL(12) = 1: TLM error is computed and used -! -! RCNTRL(1) -> Hmin, lower bound for the integration step size -! It is strongly recommended to keep Hmin = ZERO -! RCNTRL(2) -> Hmax, upper bound for the integration step size -! RCNTRL(3) -> Hstart, starting value for the integration step size -! -! RCNTRL(4) -> FacMin, lower bound on step decrease factor (default=0.2) -! RCNTRL(5) -> FacMin,upper bound on step increase factor (default=6) -! RCNTRL(6) -> FacRej, step decrease factor after multiple rejections -! (default=0.1) -! RCNTRL(7) -> FacSafe, by which the new step is slightly smaller -! than the predicted value (default=0.9) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!~~~> OUTPUT PARAMETERS: -! -! Note: each call to Rosenbrock adds the corrent no. of fcn calls -! to previous value of ISTATUS(1), and similar for the other params. -! Set ISTATUS(1:10) = 0 before call to avoid this accumulation. -! -! ISTATUS(1) = No. of function calls -! ISTATUS(2) = No. of Jacobian calls -! ISTATUS(3) = No. of steps -! ISTATUS(4) = No. of accepted steps -! ISTATUS(5) = No. of rejected steps (except at the beginning) -! ISTATUS(6) = No. of LU decompositions -! ISTATUS(7) = No. of forward/backward substitutions -! ISTATUS(8) = No. of singular matrix decompositions -! ISTATUS(9) = No. of Hessian calls -! -! RSTATUS(1) -> Texit, the time corresponding to the -! computed Y upon return -! RSTATUS(2) -> Hexit, last accepted step before exit -! For multiple restarts, use Hexit as Hstart in the following run -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - -!~~~> Arguments - INTEGER, INTENT(IN) :: N, NTLM - KPP_REAL, INTENT(INOUT) :: Y(N) - KPP_REAL, INTENT(INOUT) :: Y_tlm(N,NTLM) - KPP_REAL, INTENT(IN) :: Tstart, Tend - KPP_REAL, INTENT(IN) :: AbsTol(N),RelTol(N) - KPP_REAL, INTENT(IN) :: AbsTol_tlm(N,NTLM),RelTol_tlm(N,NTLM) - INTEGER, INTENT(IN) :: ICNTRL(20) - KPP_REAL, INTENT(IN) :: RCNTRL(20) - INTEGER, INTENT(INOUT) :: ISTATUS(20) - KPP_REAL, INTENT(INOUT) :: RSTATUS(20) - INTEGER, INTENT(OUT) :: IERR -!~~~> Parameters of the Rosenbrock method, up to 6 stages - INTEGER :: ros_S, rosMethod - INTEGER, PARAMETER :: RS2=1, RS3=2, RS4=3, RD3=4, RD4=5 - KPP_REAL :: ros_A(15), ros_C(15), ros_M(6), ros_E(6), & - ros_Alpha(6), ros_Gamma(6), ros_ELO - LOGICAL :: ros_NewF(6) - CHARACTER(LEN=12) :: ros_Name -!~~~> Local variables - KPP_REAL :: Roundoff, FacMin, FacMax, FacRej, FacSafe - KPP_REAL :: Hmin, Hmax, Hstart, Hexit - KPP_REAL :: Texit - INTEGER :: i, UplimTol, Max_no_steps - LOGICAL :: Autonomous, VectorTol, TLMtruncErr -!~~~> Parameters - KPP_REAL, PARAMETER :: ZERO = 0.0d0, ONE = 1.0d0 - KPP_REAL, PARAMETER :: DeltaMin = 1.0d-5 - -!~~~> Initialize the statistics - IERR = 0 - ISTATUS(1:20) = 0 - RSTATUS(1:20) = ZERO - -!~~~> Autonomous or time dependent ODE. Default is time dependent. - Autonomous = .NOT.(ICNTRL(1) == 0) - -!~~~> For Scalar tolerances (ICNTRL(2).NE.0) the code uses AbsTol(1) and RelTol(1) -! For Vector tolerances (ICNTRL(2) == 0) the code uses AbsTol(1:N) and RelTol(1:N) - IF (ICNTRL(2) == 0) THEN - VectorTol = .TRUE. - UplimTol = N - ELSE - VectorTol = .FALSE. - UplimTol = 1 - END IF - -!~~~> Initialize the particular Rosenbrock method selected - SELECT CASE (ICNTRL(3)) - CASE (1) - CALL Ros2 - CASE (2) - CALL Ros3 - CASE (3) - CALL Ros4 - CASE (0,4) - CALL Rodas3 - CASE (5) - CALL Rodas4 - CASE DEFAULT - PRINT * , 'Unknown Rosenbrock method: ICNTRL(3)=',ICNTRL(3) - CALL ros_ErrorMsg(-2,Tstart,ZERO,IERR) - RETURN - END SELECT - -!~~~> The maximum number of steps admitted - IF (ICNTRL(4) == 0) THEN - Max_no_steps = 200000 - ELSEIF (Max_no_steps > 0) THEN - Max_no_steps=ICNTRL(4) - ELSE - PRINT * ,'User-selected max no. of steps: ICNTRL(4)=',ICNTRL(4) - CALL ros_ErrorMsg(-1,Tstart,ZERO,IERR) - RETURN - END IF -!~~~> TLM truncation error control selection - IF (ICNTRL(12) == 0) THEN - TLMtruncErr = .FALSE. - ELSE - TLMtruncErr = .TRUE. - END IF - -!~~~> Unit roundoff (1+Roundoff>1) - Roundoff = WLAMCH('E') - -!~~~> Lower bound on the step size: (positive value) - IF (RCNTRL(1) == ZERO) THEN - Hmin = ZERO - ELSEIF (RCNTRL(1) > ZERO) THEN - Hmin = RCNTRL(1) - ELSE - PRINT * , 'User-selected Hmin: RCNTRL(1)=', RCNTRL(1) - CALL ros_ErrorMsg(-3,Tstart,ZERO,IERR) - RETURN - END IF -!~~~> Upper bound on the step size: (positive value) - IF (RCNTRL(2) == ZERO) THEN - Hmax = ABS(Tend-Tstart) - ELSEIF (RCNTRL(2) > ZERO) THEN - Hmax = MIN(ABS(RCNTRL(2)),ABS(Tend-Tstart)) - ELSE - PRINT * , 'User-selected Hmax: RCNTRL(2)=', RCNTRL(2) - CALL ros_ErrorMsg(-3,Tstart,ZERO,IERR) - RETURN - END IF -!~~~> Starting step size: (positive value) - IF (RCNTRL(3) == ZERO) THEN - Hstart = MAX(Hmin,DeltaMin) - ELSEIF (RCNTRL(3) > ZERO) THEN - Hstart = MIN(ABS(RCNTRL(3)),ABS(Tend-Tstart)) - ELSE - PRINT * , 'User-selected Hstart: RCNTRL(3)=', RCNTRL(3) - CALL ros_ErrorMsg(-3,Tstart,ZERO,IERR) - RETURN - END IF -!~~~> Step size can be changed s.t. FacMin < Hnew/Hexit < FacMax - IF (RCNTRL(4) == ZERO) THEN - FacMin = 0.2d0 - ELSEIF (RCNTRL(4) > ZERO) THEN - FacMin = RCNTRL(4) - ELSE - PRINT * , 'User-selected FacMin: RCNTRL(4)=', RCNTRL(4) - CALL ros_ErrorMsg(-4,Tstart,ZERO,IERR) - RETURN - END IF - IF (RCNTRL(5) == ZERO) THEN - FacMax = 6.0d0 - ELSEIF (RCNTRL(5) > ZERO) THEN - FacMax = RCNTRL(5) - ELSE - PRINT * , 'User-selected FacMax: RCNTRL(5)=', RCNTRL(5) - CALL ros_ErrorMsg(-4,Tstart,ZERO,IERR) - RETURN - END IF -!~~~> FacRej: Factor to decrease step after 2 succesive rejections - IF (RCNTRL(6) == ZERO) THEN - FacRej = 0.1d0 - ELSEIF (RCNTRL(6) > ZERO) THEN - FacRej = RCNTRL(6) - ELSE - PRINT * , 'User-selected FacRej: RCNTRL(6)=', RCNTRL(6) - CALL ros_ErrorMsg(-4,Tstart,ZERO,IERR) - RETURN - END IF -!~~~> FacSafe: Safety Factor in the computation of new step size - IF (RCNTRL(7) == ZERO) THEN - FacSafe = 0.9d0 - ELSEIF (RCNTRL(7) > ZERO) THEN - FacSafe = RCNTRL(7) - ELSE - PRINT * , 'User-selected FacSafe: RCNTRL(7)=', RCNTRL(7) - CALL ros_ErrorMsg(-4,Tstart,ZERO,IERR) - RETURN - END IF -!~~~> Check if tolerances are reasonable - DO i=1,UplimTol - IF ( (AbsTol(i) <= ZERO) .OR. (RelTol(i) <= 10.d0*Roundoff) & - .OR. (RelTol(i) >= 1.0d0) ) THEN - PRINT * , ' AbsTol(',i,') = ',AbsTol(i) - PRINT * , ' RelTol(',i,') = ',RelTol(i) - CALL ros_ErrorMsg(-5,Tstart,ZERO,IERR) - RETURN - END IF - END DO - - -!~~~> CALL Rosenbrock method - CALL ros_TLM_Int(Y, NTLM, Y_tlm, & - Tstart, Tend, Texit, & -! Error indicator - IERR) - - -CONTAINS ! Procedures internal to RosenbrockTLM - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_ErrorMsg(Code,T,H,IERR) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Handles all error messages -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - KPP_REAL, INTENT(IN) :: T, H - INTEGER, INTENT(IN) :: Code - INTEGER, INTENT(OUT) :: IERR - - IERR = Code - PRINT * , & - 'Forced exit from Rosenbrock due to the following error:' - - SELECT CASE (Code) - CASE (-1) - PRINT * , '--> Improper value for maximal no of steps' - CASE (-2) - PRINT * , '--> Selected Rosenbrock method not implemented' - CASE (-3) - PRINT * , '--> Hmin/Hmax/Hstart must be positive' - CASE (-4) - PRINT * , '--> FacMin/FacMax/FacRej must be positive' - CASE (-5) - PRINT * , '--> Improper tolerance values' - CASE (-6) - PRINT * , '--> No of steps exceeds maximum bound' - CASE (-7) - PRINT * , '--> Step size too small: T + 10*H = T', & - ' or H < Roundoff' - CASE (-8) - PRINT * , '--> Matrix is repeatedly singular' - CASE DEFAULT - PRINT *, 'Unknown Error code: ', Code - END SELECT - - PRINT *, "T=", T, "and H=", H - - END SUBROUTINE ros_ErrorMsg - - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_TLM_Int (Y, NTLM, Y_tlm, & - Tstart, Tend, T, & -!~~~> Error indicator - IERR ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Template for the implementation of a generic Rosenbrock method -! defined by ros_S (no of stages) -! and its coefficients ros_{A,C,M,E,Alpha,Gamma} -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - -!~~~> Input: the initial condition at Tstart; Output: the solution at T - KPP_REAL, INTENT(INOUT) :: Y(N) -!~~~> Input: Number of sensitivity coefficients - INTEGER, INTENT(IN) :: NTLM -!~~~> Input: the initial sensitivites at Tstart; Output: the sensitivities at T - KPP_REAL, INTENT(INOUT) :: Y_tlm(N,NTLM) -!~~~> Input: integration interval - KPP_REAL, INTENT(IN) :: Tstart,Tend -!~~~> Output: time at which the solution is returned (T=Tend if success) - KPP_REAL, INTENT(OUT) :: T -!~~~> Output: Error indicator - INTEGER, INTENT(OUT) :: IERR -! ~~~~ Local variables - KPP_REAL :: Ynew(N), Fcn0(N), Fcn(N) - KPP_REAL :: K(N*ros_S) - KPP_REAL :: Ynew_tlm(N,NTLM), Fcn0_tlm(N,NTLM), Fcn_tlm(N,NTLM) - KPP_REAL :: K_tlm(N*ros_S,NTLM) - KPP_REAL :: Hes0(NHESS), Tmp(N) - KPP_REAL :: dFdT(N), dJdT(LU_NONZERO) - KPP_REAL :: Jac0(LU_NONZERO), Jac(LU_NONZERO), Ghimj(LU_NONZERO) - KPP_REAL :: H, Hnew, HC, HG, Fac, Tau - KPP_REAL :: Err, Err0, Err1, Yerr(N), Yerr_tlm(N,NTLM) - INTEGER :: Pivot(N), Direction, ioffset, j, istage, itlm - LOGICAL :: RejectLastH, RejectMoreH, Singular -!~~~> Local parameters - KPP_REAL, PARAMETER :: DeltaMin = 1.0d-5 -!~~~> Locally called functions -! KPP_REAL WLAMCH -! EXTERNAL WLAMCH -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - -!~~~> Initial preparations - T = Tstart - RSTATUS(Nhexit) = ZERO - H = MIN( MAX(ABS(Hmin),ABS(Hstart)) , ABS(Hmax) ) - IF (ABS(H) <= 10.D0*Roundoff) H = DeltaMin - - IF (Tend >= Tstart) THEN - Direction = +1 - ELSE - Direction = -1 - END IF - H = Direction*H - - RejectLastH=.FALSE. - RejectMoreH=.FALSE. - -!~~~> Time loop begins below - -TimeLoop: DO WHILE ( (Direction > 0).AND.((T-Tend)+Roundoff <= ZERO) & - .OR. (Direction < 0).AND.((Tend-T)+Roundoff <= ZERO) ) - - IF ( ISTATUS(Nstp) > Max_no_steps ) THEN ! Too many steps - CALL ros_ErrorMsg(-6,T,H,IERR) - RETURN - END IF - IF ( ((T+0.1d0*H) == T).OR.(H <= Roundoff) ) THEN ! Step size too small - CALL ros_ErrorMsg(-7,T,H,IERR) - RETURN - END IF - -!~~~> Limit H if necessary to avoid going beyond Tend - Hexit = H - H = MIN(H,ABS(Tend-T)) - -!~~~> Compute the function at current time - CALL FunTemplate(T,Y,Fcn0) - ISTATUS(Nfun) = ISTATUS(Nfun) + 1 - -!~~~> Compute the Jacobian at current time - CALL JacTemplate(T,Y,Jac0) - ISTATUS(Njac) = ISTATUS(Njac) + 1 - -!~~~> Compute the Hessian at current time - CALL HessTemplate(T,Y,Hes0) - ISTATUS(Nhes) = ISTATUS(Nhes) + 1 - -!~~~> Compute the TLM function at current time - DO itlm = 1, NTLM - CALL Jac_SP_Vec ( Jac0, Y_tlm(1:N,itlm), Fcn0_tlm(1:N,itlm) ) - END DO - -!~~~> Compute the function and Jacobian derivatives with respect to T - IF (.NOT.Autonomous) THEN - CALL ros_FunTimeDerivative ( T, Roundoff, Y, Fcn0, dFdT ) - CALL ros_JacTimeDerivative ( T, Roundoff, Y, Jac0, dJdT ) - END IF - -!~~~> Repeat step calculation until current step accepted -UntilAccepted: DO - - CALL ros_PrepareMatrix(H,Direction,ros_Gamma(1),& - Jac0,Ghimj,Pivot,Singular) - IF (Singular) THEN ! More than 5 consecutive failed decompositions - CALL ros_ErrorMsg(-8,T,H,IERR) - RETURN - END IF - -!~~~> Compute the stages -Stage: DO istage = 1, ros_S - - ! Current istage offset. Current istage vector is K(ioffset+1:ioffset+N) - ioffset = N*(istage-1) - - ! Initialize stage solution - CALL WCOPY(N,Y,1,Ynew,1) - CALL WCOPY(N*NTLM,Y_tlm,1,Ynew_tlm,1) - - ! For the 1st istage the function has been computed previously - IF ( istage == 1 ) THEN - CALL WCOPY(N,Fcn0,1,Fcn,1) - CALL WCOPY(N*NTLM,Fcn0_tlm,1,Fcn_tlm,1) - ! istage>1 and a new function evaluation is needed at the current istage - ELSEIF ( ros_NewF(istage) ) THEN - DO j = 1, istage-1 - CALL WAXPY(N,ros_A((istage-1)*(istage-2)/2+j), & - K(N*(j-1)+1:N*j),1,Ynew,1) - DO itlm=1,NTLM - CALL WAXPY(N,ros_A((istage-1)*(istage-2)/2+j), & - K_tlm(N*(j-1)+1:N*j,itlm),1,Ynew_tlm(1:N,itlm),1) - END DO - END DO - Tau = T + ros_Alpha(istage)*Direction*H - CALL FunTemplate(Tau,Ynew,Fcn) - ISTATUS(Nfun) = ISTATUS(Nfun) + 1 - CALL JacTemplate(Tau,Ynew,Jac) - ISTATUS(Njac) = ISTATUS(Njac) + 1 - DO itlm=1,NTLM - CALL Jac_SP_Vec ( Jac, Ynew_tlm(1:N,itlm), Fcn_tlm(1:N,itlm) ) - END DO - END IF ! if istage == 1 elseif ros_NewF(istage) - CALL WCOPY(N,Fcn,1,K(ioffset+1:ioffset+N),1) - DO itlm=1,NTLM - CALL WCOPY(N,Fcn_tlm(1:N,itlm),1,K_tlm(ioffset+1:ioffset+N,itlm),1) - END DO - DO j = 1, istage-1 - HC = ros_C((istage-1)*(istage-2)/2+j)/(Direction*H) - CALL WAXPY(N,HC,K(N*(j-1)+1:N*j),1,K(ioffset+1:ioffset+N),1) - DO itlm=1,NTLM - CALL WAXPY(N,HC,K_tlm(N*(j-1)+1:N*j,itlm),1,K_tlm(ioffset+1:ioffset+N,itlm),1) - END DO - END DO - IF ((.NOT. Autonomous).AND.(ros_Gamma(istage).NE.ZERO)) THEN - HG = Direction*H*ros_Gamma(istage) - CALL WAXPY(N,HG,dFdT(1:N),1,K(ioffset+1:ioffset+N),1) - DO itlm=1,NTLM - CALL Jac_SP_Vec ( dJdT, Ynew_tlm(1:N,itlm), Tmp ) - CALL WAXPY(N,HG,Tmp,1,K_tlm(ioffset+1:ioffset+N,itlm),1) - END DO - END IF - CALL ros_Solve(Ghimj, Pivot, K(ioffset+1:ioffset+N)) - DO itlm=1,NTLM - CALL Hess_Vec ( Hes0, K(ioffset+1:ioffset+N), Y_tlm(1:N,itlm), Tmp ) - CALL WAXPY(N,ONE,Tmp,1,K_tlm(ioffset+1:ioffset+N,itlm),1) - CALL ros_Solve(Ghimj, Pivot, K_tlm(ioffset+1:ioffset+N,itlm)) - END DO - - END DO Stage - - -!~~~> Compute the new solution - CALL WCOPY(N,Y,1,Ynew,1) - DO j=1,ros_S - CALL WAXPY(N,ros_M(j),K(N*(j-1)+1:N*j),1,Ynew,1) - END DO - DO itlm=1,NTLM - CALL WCOPY(N,Y_tlm(1:N,itlm),1,Ynew_tlm(1:N,itlm),1) - DO j=1,ros_S - CALL WAXPY(N,ros_M(j),K_tlm(N*(j-1)+1:N*j,itlm),1,Ynew_tlm(1:N,itlm),1) - END DO - END DO - -!~~~> Compute the error estimation - CALL Set2zero(N,Yerr) - DO j=1,ros_S - CALL WAXPY(N,ros_E(j),K(N*(j-1)+1:N*j),1,Yerr,1) - END DO - Err = ros_ErrorNorm ( Y, Ynew, Yerr, AbsTol, RelTol, VectorTol ) - IF (TLMtruncErr) THEN - Err1 = 0.0d0 - CALL Set2zero(N*NTLM,Yerr_tlm) - DO itlm=1,NTLM - DO j=1,ros_S - CALL WAXPY(N,ros_E(j),K_tlm(N*(j-1)+1:N*j,itlm),1,Yerr_tlm(1:N,itlm),1) - END DO - END DO - Err = ros_ErrorNorm_tlm(Y_tlm,Ynew_tlm,Yerr_tlm,AbsTol_tlm,RelTol_tlm,Err,VectorTol) - END IF - -!~~~> New step size is bounded by FacMin <= Hnew/H <= FacMax - Fac = MIN(FacMax,MAX(FacMin,FacSafe/Err**(ONE/ros_ELO))) - Hnew = H*Fac - -!~~~> Check the error magnitude and adjust step size - ISTATUS(Nstp) = ISTATUS(Nstp) + 1 - IF ( (Err <= ONE).OR.(H <= Hmin) ) THEN !~~~> Accept step - ISTATUS(Nacc) = ISTATUS(Nacc) + 1 - CALL WCOPY(N,Ynew,1,Y,1) - CALL WCOPY(N*NTLM,Ynew_tlm,1,Y_tlm,1) - T = T + Direction*H - Hnew = MAX(Hmin,MIN(Hnew,Hmax)) - IF (RejectLastH) THEN ! No step size increase after a rejected step - Hnew = MIN(Hnew,H) - END IF - RSTATUS(Nhexit) = H - RSTATUS(Nhnew) = Hnew - RSTATUS(Ntexit) = T - RejectLastH = .FALSE. - RejectMoreH = .FALSE. - H = Hnew - EXIT UntilAccepted ! EXIT THE LOOP: WHILE STEP NOT ACCEPTED - ELSE !~~~> Reject step - IF (RejectMoreH) THEN - Hnew = H*FacRej - END IF - RejectMoreH = RejectLastH - RejectLastH = .TRUE. - H = Hnew - IF (ISTATUS(Nacc) >= 1) THEN - ISTATUS(Nrej) = ISTATUS(Nrej) + 1 - END IF - END IF ! Err <= 1 - - END DO UntilAccepted - - END DO TimeLoop - -!~~~> Succesful exit - IERR = 1 !~~~> The integration was successful - - END SUBROUTINE ros_TLM_Int - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - KPP_REAL FUNCTION ros_ErrorNorm ( Y, Ynew, Yerr, & - AbsTol, RelTol, VectorTol ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Computes the "scaled norm" of the error vector Yerr -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - -! Input arguments - KPP_REAL, INTENT(IN) :: Y(N), Ynew(N), & - Yerr(N), AbsTol(N), RelTol(N) - LOGICAL, INTENT(IN) :: VectorTol -! Local variables - KPP_REAL :: Err, Scale, Ymax - INTEGER :: i - KPP_REAL, PARAMETER :: ZERO = 0.0d0 - - Err = ZERO - DO i=1,N - Ymax = MAX(ABS(Y(i)),ABS(Ynew(i))) - IF (VectorTol) THEN - Scale = AbsTol(i)+RelTol(i)*Ymax - ELSE - Scale = AbsTol(1)+RelTol(1)*Ymax - END IF - Err = Err+(Yerr(i)/Scale)**2 - END DO - Err = SQRT(Err/N) - - ros_ErrorNorm = MAX(Err,1.0d-10) - - END FUNCTION ros_ErrorNorm - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - KPP_REAL FUNCTION ros_ErrorNorm_tlm ( Y_tlm, Ynew_tlm, Yerr_tlm, & - AbsTol_tlm, RelTol_tlm, Fwd_Err, VectorTol ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Computes the "scaled norm" of the error vector Yerr_tlm -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - -! Input arguments - KPP_REAL, INTENT(IN) :: Y_tlm(N,NTLM), Ynew_tlm(N,NTLM), & - Yerr_tlm(N,NTLM), AbsTol_tlm(N,NTLM), RelTol_tlm(N,NTLM), Fwd_Err - LOGICAL, INTENT(IN) :: VectorTol -! Local variables - KPP_REAL :: TMP, Err - INTEGER :: itlm - - Err = FWD_Err - DO itlm = 1,NTLM - TMP = ros_ErrorNorm(Y_tlm(1,itlm), Ynew_tlm(1,itlm),Yerr_tlm(1,itlm), & - AbsTol_tlm(1,itlm), RelTol_tlm(1,itlm), VectorTol) - Err = MAX(Err, TMP) - END DO - - ros_ErrorNorm_tlm = MAX(Err,1.0d-10) - - END FUNCTION ros_ErrorNorm_tlm - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_FunTimeDerivative ( T, Roundoff, Y, & - Fcn0, dFdT ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> The time partial derivative of the function by finite differences -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - -!~~~> Input arguments - KPP_REAL, INTENT(IN) :: T, Roundoff, Y(N), Fcn0(N) -!~~~> Output arguments - KPP_REAL, INTENT(OUT) :: dFdT(N) -!~~~> Local variables - KPP_REAL :: Delta - KPP_REAL, PARAMETER :: DeltaMin = 1.0d-6 - - Delta = SQRT(Roundoff)*MAX(DeltaMin,ABS(T)) - CALL FunTemplate(T+Delta,Y,dFdT) - ISTATUS(Nfun) = ISTATUS(Nfun) + 1 - CALL WAXPY(N,(-ONE),Fcn0,1,dFdT,1) - CALL WSCAL(N,(ONE/Delta),dFdT,1) - - END SUBROUTINE ros_FunTimeDerivative - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_JacTimeDerivative ( T, Roundoff, Y, & - Jac0, dJdT ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> The time partial derivative of the Jacobian by finite differences -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - -!~~~> Input arguments - KPP_REAL, INTENT(IN) :: T, Roundoff, Y(N), Jac0(LU_NONZERO) -!~~~> Output arguments - KPP_REAL, INTENT(OUT) :: dJdT(LU_NONZERO) -!~~~> Local variables - KPP_REAL Delta - KPP_REAL, PARAMETER :: ONE = 1.0d0, DeltaMin = 1.0d-6 - - Delta = SQRT(Roundoff)*MAX(DeltaMin,ABS(T)) - CALL JacTemplate(T+Delta,Y,dJdT) - ISTATUS(Njac) = ISTATUS(Njac) + 1 - CALL WAXPY(LU_NONZERO,(-ONE),Jac0,1,dJdT,1) - CALL WSCAL(LU_NONZERO,(ONE/Delta),dJdT,1) - - END SUBROUTINE ros_JacTimeDerivative - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_PrepareMatrix ( H, Direction, gam, & - Jac0, Ghimj, Pivot, Singular ) -! --- --- --- --- --- --- --- --- --- --- --- --- --- -! Prepares the LHS matrix for stage calculations -! 1. Construct Ghimj = 1/(H*ham) - Jac0 -! "(Gamma H) Inverse Minus Jacobian" -! 2. Repeat LU decomposition of Ghimj until successful. -! -half the step size if LU decomposition fails and retry -! -exit after 5 consecutive fails -! --- --- --- --- --- --- --- --- --- --- --- --- --- - IMPLICIT NONE - -!~~~> Input arguments - KPP_REAL, INTENT(IN) :: gam, Jac0(LU_NONZERO) - INTEGER, INTENT(IN) :: Direction -!~~~> Output arguments - KPP_REAL, INTENT(OUT) :: Ghimj(LU_NONZERO) - LOGICAL, INTENT(OUT) :: Singular - INTEGER, INTENT(OUT) :: Pivot(N) -!~~~> Inout arguments - KPP_REAL, INTENT(INOUT) :: H ! step size is decreased when LU fails -!~~~> Local variables - INTEGER :: i, ising, Nconsecutive - KPP_REAL :: ghinv - KPP_REAL, PARAMETER :: ONE = 1.0d0, HALF = 0.5d0 - - Nconsecutive = 0 - Singular = .TRUE. - - DO WHILE (Singular) - -!~~~> Construct Ghimj = 1/(H*ham) - Jac0 - CALL WCOPY(LU_NONZERO,Jac0,1,Ghimj,1) - CALL WSCAL(LU_NONZERO,(-ONE),Ghimj,1) - ghinv = ONE/(Direction*H*gam) - DO i=1,N - Ghimj(LU_DIAG(i)) = Ghimj(LU_DIAG(i))+ghinv - END DO -!~~~> Compute LU decomposition - CALL ros_Decomp( Ghimj, Pivot, ising ) - IF (ising == 0) THEN -!~~~> If successful done - Singular = .FALSE. - ELSE ! ising .ne. 0 -!~~~> If unsuccessful half the step size; if 5 consecutive fails then return - ISTATUS(Nsng) = ISTATUS(Nsng) + 1 - Nconsecutive = Nconsecutive+1 - Singular = .TRUE. - PRINT*,'Warning: LU Decomposition returned ising = ',ising - IF (Nconsecutive <= 5) THEN ! Less than 5 consecutive failed decompositions - H = H*HALF - ELSE ! More than 5 consecutive failed decompositions - RETURN - END IF ! Nconsecutive - END IF ! ising - - END DO ! WHILE Singular - - END SUBROUTINE ros_PrepareMatrix - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_Decomp( A, Pivot, ising ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Template for the LU decomposition -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE -!~~~> Inout variables - KPP_REAL, INTENT(INOUT) :: A(LU_NONZERO) -!~~~> Output variables - INTEGER, INTENT(OUT) :: Pivot(N), ising - - CALL KppDecomp ( A, ising ) -!~~~> Note: for a full matrix use Lapack: -! CALL DGETRF( N, N, A, N, Pivot, ising ) - Pivot(1) = 1 - - ISTATUS(Ndec) = ISTATUS(Ndec) + 1 - - END SUBROUTINE ros_Decomp - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_Solve( A, Pivot, b ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Template for the forward/backward substitution (using pre-computed LU decomposition) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE -!~~~> Input variables - KPP_REAL, INTENT(IN) :: A(LU_NONZERO) - INTEGER, INTENT(IN) :: Pivot(N) -!~~~> InOut variables - KPP_REAL, INTENT(INOUT) :: b(N) - - CALL KppSolve( A, b ) -!~~~> Note: for a full matrix use Lapack: -! NRHS = 1 -! CALL DGETRS( 'N', N , NRHS, A, N, Pivot, b, N, INFO ) - - ISTATUS(Nsol) = ISTATUS(Nsol) + 1 - - END SUBROUTINE ros_Solve - - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Ros2 -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! --- AN L-STABLE METHOD, 2 stages, order 2 -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - DOUBLE PRECISION g - - g = 1.0d0 + 1.0d0/SQRT(2.0d0) - - rosMethod = RS2 -!~~~> Name of the method - ros_Name = 'ROS-2' -!~~~> Number of stages - ros_S = 2 - -!~~~> The coefficient matrices A and C are strictly lower triangular. -! The lower triangular (subdiagonal) elements are stored in row-wise order: -! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. -! The general mapping formula is: -! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) -! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) - - ros_A(1) = (1.d0)/g - ros_C(1) = (-2.d0)/g -!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) -! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) - ros_NewF(1) = .TRUE. - ros_NewF(2) = .TRUE. -!~~~> M_i = Coefficients for new step solution - ros_M(1)= (3.d0)/(2.d0*g) - ros_M(2)= (1.d0)/(2.d0*g) -! E_i = Coefficients for error estimator - ros_E(1) = 1.d0/(2.d0*g) - ros_E(2) = 1.d0/(2.d0*g) -!~~~> ros_ELO = estimator of local order - the minimum between the -! main and the embedded scheme orders plus one - ros_ELO = 2.0d0 -!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) - ros_Alpha(1) = 0.0d0 - ros_Alpha(2) = 1.0d0 -!~~~> Gamma_i = \sum_j gamma_{i,j} - ros_Gamma(1) = g - ros_Gamma(2) =-g - - END SUBROUTINE Ros2 - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Ros3 -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! --- AN L-STABLE METHOD, 3 stages, order 3, 2 function evaluations -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - - rosMethod = RS3 -!~~~> Name of the method - ros_Name = 'ROS-3' -!~~~> Number of stages - ros_S = 3 - -!~~~> The coefficient matrices A and C are strictly lower triangular. -! The lower triangular (subdiagonal) elements are stored in row-wise order: -! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. -! The general mapping formula is: -! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) -! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) - - ros_A(1)= 1.d0 - ros_A(2)= 1.d0 - ros_A(3)= 0.d0 - - ros_C(1) = -0.10156171083877702091975600115545d+01 - ros_C(2) = 0.40759956452537699824805835358067d+01 - ros_C(3) = 0.92076794298330791242156818474003d+01 -!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) -! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) - ros_NewF(1) = .TRUE. - ros_NewF(2) = .TRUE. - ros_NewF(3) = .FALSE. -!~~~> M_i = Coefficients for new step solution - ros_M(1) = 0.1d+01 - ros_M(2) = 0.61697947043828245592553615689730d+01 - ros_M(3) = -0.42772256543218573326238373806514d+00 -! E_i = Coefficients for error estimator - ros_E(1) = 0.5d+00 - ros_E(2) = -0.29079558716805469821718236208017d+01 - ros_E(3) = 0.22354069897811569627360909276199d+00 -!~~~> ros_ELO = estimator of local order - the minimum between the -! main and the embedded scheme orders plus 1 - ros_ELO = 3.0d0 -!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) - ros_Alpha(1)= 0.0d+00 - ros_Alpha(2)= 0.43586652150845899941601945119356d+00 - ros_Alpha(3)= 0.43586652150845899941601945119356d+00 -!~~~> Gamma_i = \sum_j gamma_{i,j} - ros_Gamma(1)= 0.43586652150845899941601945119356d+00 - ros_Gamma(2)= 0.24291996454816804366592249683314d+00 - ros_Gamma(3)= 0.21851380027664058511513169485832d+01 - - END SUBROUTINE Ros3 - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Ros4 -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! L-STABLE ROSENBROCK METHOD OF ORDER 4, WITH 4 STAGES -! L-STABLE EMBEDDED ROSENBROCK METHOD OF ORDER 3 -! -! E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL -! EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS. -! SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS, -! SPRINGER-VERLAG (1990) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - - rosMethod = RS4 -!~~~> Name of the method - ros_Name = 'ROS-4' -!~~~> Number of stages - ros_S = 4 - -!~~~> The coefficient matrices A and C are strictly lower triangular. -! The lower triangular (subdiagonal) elements are stored in row-wise order: -! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. -! The general mapping formula is: -! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) -! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) - - ros_A(1) = 0.2000000000000000d+01 - ros_A(2) = 0.1867943637803922d+01 - ros_A(3) = 0.2344449711399156d+00 - ros_A(4) = ros_A(2) - ros_A(5) = ros_A(3) - ros_A(6) = 0.0D0 - - ros_C(1) =-0.7137615036412310d+01 - ros_C(2) = 0.2580708087951457d+01 - ros_C(3) = 0.6515950076447975d+00 - ros_C(4) =-0.2137148994382534d+01 - ros_C(5) =-0.3214669691237626d+00 - ros_C(6) =-0.6949742501781779d+00 -!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) -! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) - ros_NewF(1) = .TRUE. - ros_NewF(2) = .TRUE. - ros_NewF(3) = .TRUE. - ros_NewF(4) = .FALSE. -!~~~> M_i = Coefficients for new step solution - ros_M(1) = 0.2255570073418735d+01 - ros_M(2) = 0.2870493262186792d+00 - ros_M(3) = 0.4353179431840180d+00 - ros_M(4) = 0.1093502252409163d+01 -!~~~> E_i = Coefficients for error estimator - ros_E(1) =-0.2815431932141155d+00 - ros_E(2) =-0.7276199124938920d-01 - ros_E(3) =-0.1082196201495311d+00 - ros_E(4) =-0.1093502252409163d+01 -!~~~> ros_ELO = estimator of local order - the minimum between the -! main and the embedded scheme orders plus 1 - ros_ELO = 4.0d0 -!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) - ros_Alpha(1) = 0.D0 - ros_Alpha(2) = 0.1145640000000000d+01 - ros_Alpha(3) = 0.6552168638155900d+00 - ros_Alpha(4) = ros_Alpha(3) -!~~~> Gamma_i = \sum_j gamma_{i,j} - ros_Gamma(1) = 0.5728200000000000d+00 - ros_Gamma(2) =-0.1769193891319233d+01 - ros_Gamma(3) = 0.7592633437920482d+00 - ros_Gamma(4) =-0.1049021087100450d+00 - - END SUBROUTINE Ros4 - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Rodas3 -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! --- A STIFFLY-STABLE METHOD, 4 stages, order 3 -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - - rosMethod = RD3 -!~~~> Name of the method - ros_Name = 'RODAS-3' -!~~~> Number of stages - ros_S = 4 - -!~~~> The coefficient matrices A and C are strictly lower triangular. -! The lower triangular (subdiagonal) elements are stored in row-wise order: -! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. -! The general mapping formula is: -! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) -! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) - - ros_A(1) = 0.0d+00 - ros_A(2) = 2.0d+00 - ros_A(3) = 0.0d+00 - ros_A(4) = 2.0d+00 - ros_A(5) = 0.0d+00 - ros_A(6) = 1.0d+00 - - ros_C(1) = 4.0d+00 - ros_C(2) = 1.0d+00 - ros_C(3) =-1.0d+00 - ros_C(4) = 1.0d+00 - ros_C(5) =-1.0d+00 - ros_C(6) =-(8.0d+00/3.0d+00) - -!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) -! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) - ros_NewF(1) = .TRUE. - ros_NewF(2) = .FALSE. - ros_NewF(3) = .TRUE. - ros_NewF(4) = .TRUE. -!~~~> M_i = Coefficients for new step solution - ros_M(1) = 2.0d+00 - ros_M(2) = 0.0d+00 - ros_M(3) = 1.0d+00 - ros_M(4) = 1.0d+00 -!~~~> E_i = Coefficients for error estimator - ros_E(1) = 0.0d+00 - ros_E(2) = 0.0d+00 - ros_E(3) = 0.0d+00 - ros_E(4) = 1.0d+00 -!~~~> ros_ELO = estimator of local order - the minimum between the -! main and the embedded scheme orders plus 1 - ros_ELO = 3.0d+00 -!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) - ros_Alpha(1) = 0.0d+00 - ros_Alpha(2) = 0.0d+00 - ros_Alpha(3) = 1.0d+00 - ros_Alpha(4) = 1.0d+00 -!~~~> Gamma_i = \sum_j gamma_{i,j} - ros_Gamma(1) = 0.5d+00 - ros_Gamma(2) = 1.5d+00 - ros_Gamma(3) = 0.0d+00 - ros_Gamma(4) = 0.0d+00 - - END SUBROUTINE Rodas3 - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Rodas4 -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! STIFFLY-STABLE ROSENBROCK METHOD OF ORDER 4, WITH 6 STAGES -! -! E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL -! EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS. -! SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS, -! SPRINGER-VERLAG (1996) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - - rosMethod = RD4 -!~~~> Name of the method - ros_Name = 'RODAS-4' -!~~~> Number of stages - ros_S = 6 - -!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) - ros_Alpha(1) = 0.000d0 - ros_Alpha(2) = 0.386d0 - ros_Alpha(3) = 0.210d0 - ros_Alpha(4) = 0.630d0 - ros_Alpha(5) = 1.000d0 - ros_Alpha(6) = 1.000d0 - -!~~~> Gamma_i = \sum_j gamma_{i,j} - ros_Gamma(1) = 0.2500000000000000d+00 - ros_Gamma(2) =-0.1043000000000000d+00 - ros_Gamma(3) = 0.1035000000000000d+00 - ros_Gamma(4) =-0.3620000000000023d-01 - ros_Gamma(5) = 0.0d0 - ros_Gamma(6) = 0.0d0 - -!~~~> The coefficient matrices A and C are strictly lower triangular. -! The lower triangular (subdiagonal) elements are stored in row-wise order: -! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. -! The general mapping formula is: A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) -! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) - - ros_A(1) = 0.1544000000000000d+01 - ros_A(2) = 0.9466785280815826d+00 - ros_A(3) = 0.2557011698983284d+00 - ros_A(4) = 0.3314825187068521d+01 - ros_A(5) = 0.2896124015972201d+01 - ros_A(6) = 0.9986419139977817d+00 - ros_A(7) = 0.1221224509226641d+01 - ros_A(8) = 0.6019134481288629d+01 - ros_A(9) = 0.1253708332932087d+02 - ros_A(10) =-0.6878860361058950d+00 - ros_A(11) = ros_A(7) - ros_A(12) = ros_A(8) - ros_A(13) = ros_A(9) - ros_A(14) = ros_A(10) - ros_A(15) = 1.0d+00 - - ros_C(1) =-0.5668800000000000d+01 - ros_C(2) =-0.2430093356833875d+01 - ros_C(3) =-0.2063599157091915d+00 - ros_C(4) =-0.1073529058151375d+00 - ros_C(5) =-0.9594562251023355d+01 - ros_C(6) =-0.2047028614809616d+02 - ros_C(7) = 0.7496443313967647d+01 - ros_C(8) =-0.1024680431464352d+02 - ros_C(9) =-0.3399990352819905d+02 - ros_C(10) = 0.1170890893206160d+02 - ros_C(11) = 0.8083246795921522d+01 - ros_C(12) =-0.7981132988064893d+01 - ros_C(13) =-0.3152159432874371d+02 - ros_C(14) = 0.1631930543123136d+02 - ros_C(15) =-0.6058818238834054d+01 - -!~~~> M_i = Coefficients for new step solution - ros_M(1) = ros_A(7) - ros_M(2) = ros_A(8) - ros_M(3) = ros_A(9) - ros_M(4) = ros_A(10) - ros_M(5) = 1.0d+00 - ros_M(6) = 1.0d+00 - -!~~~> E_i = Coefficients for error estimator - ros_E(1) = 0.0d+00 - ros_E(2) = 0.0d+00 - ros_E(3) = 0.0d+00 - ros_E(4) = 0.0d+00 - ros_E(5) = 0.0d+00 - ros_E(6) = 1.0d+00 - -!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) -! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) - ros_NewF(1) = .TRUE. - ros_NewF(2) = .TRUE. - ros_NewF(3) = .TRUE. - ros_NewF(4) = .TRUE. - ros_NewF(5) = .TRUE. - ros_NewF(6) = .TRUE. - -!~~~> ros_ELO = estimator of local order - the minimum between the -! main and the embedded scheme orders plus 1 - ros_ELO = 4.0d0 - - END SUBROUTINE Rodas4 - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -END SUBROUTINE RosenbrockTLM -! and all its internal procedures -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -SUBROUTINE FunTemplate( T, Y, Ydot ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Template for the ODE function call. -! Updates the rate coefficients (and possibly the fixed species) at each call -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE -!~~~> Input variables - KPP_REAL :: T, Y(NVAR) -!~~~> Output variables - KPP_REAL :: Ydot(NVAR) -!~~~> Local variables - KPP_REAL :: Told - - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Fun( Y, FIX, RCONST, Ydot ) - TIME = Told - -END SUBROUTINE FunTemplate - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -SUBROUTINE JacTemplate( T, Y, Jcb ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Template for the ODE Jacobian call. -! Updates the rate coefficients (and possibly the fixed species) at each call -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - -!~~~> Input variables - KPP_REAL :: T, Y(NVAR) -!~~~> Output variables - KPP_REAL :: Jcb(LU_NONZERO) -!~~~> Local variables - KPP_REAL :: Told - - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Jac_SP( Y, FIX, RCONST, Jcb ) - TIME = Told - -END SUBROUTINE JacTemplate - - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -SUBROUTINE HessTemplate( T, Y, Hes ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Template for the ODE Hessian call. -! Updates the rate coefficients (and possibly the fixed species) at each call -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - -!~~~> Input variables - KPP_REAL :: T, Y(NVAR) -!~~~> Output variables - KPP_REAL :: Hes(NHESS) -!~~~> Local variables - KPP_REAL :: Told - - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Hessian( Y, FIX, RCONST, Hes ) - TIME = Told - -END SUBROUTINE HessTemplate - -END MODULE KPP_ROOT_Integrator - - - - diff --git a/boxmox/int.modified_WCOPY/runge_kutta.f90 b/boxmox/int.modified_WCOPY/runge_kutta.f90 deleted file mode 100644 index 87388a35f0d23564e8588c62693784d8e22c4aec..0000000000000000000000000000000000000000 --- a/boxmox/int.modified_WCOPY/runge_kutta.f90 +++ /dev/null @@ -1,1881 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! -! RungeKutta - Fully Implicit 3-stage Runge-Kutta methods based on: ! -! * Radau-2A quadrature (order 5) ! -! * Radau-1A quadrature (order 5) ! -! * Lobatto-3C quadrature (order 4) ! -! * Gauss quadrature (order 6) ! -! By default the code employs the KPP sparse linear algebra routines ! -! Compile with -DFULL_ALGEBRA to use full linear algebra (LAPACK) ! -! ! -! (C) Adrian Sandu, August 2005 ! -! Virginia Polytechnic Institute and State University ! -! Contact: sandu@cs.vt.edu ! -! Revised by Philipp Miehe and Adrian Sandu, May 2006 ! -! This implementation is part of KPP - the Kinetic PreProcessor ! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! - -MODULE KPP_ROOT_Integrator - - USE KPP_ROOT_Precision - USE KPP_ROOT_Parameters, ONLY: NVAR, NSPEC, NFIX, LU_NONZERO - USE KPP_ROOT_Global, ONLY: FIX, RCONST, TIME - USE KPP_ROOT_Jacobian, ONLY: LU_DIAG - USE KPP_ROOT_LinearAlgebra - - IMPLICIT NONE - PUBLIC - SAVE - -!~~~> Statistics on the work performed by the Runge-Kutta method - INTEGER, PARAMETER :: Nfun=1, Njac=2, Nstp=3, Nacc=4, & - Nrej=5, Ndec=6, Nsol=7, Nsng=8, Ntexit=1, Nhacc=2, Nhnew=3 - -CONTAINS - - ! ************************************************************************** - - SUBROUTINE INTEGRATE( TIN, TOUT, & - ICNTRL_U, RCNTRL_U, ISTATUS_U, RSTATUS_U, IERR_U ) - - USE KPP_ROOT_Parameters, ONLY: NVAR - USE KPP_ROOT_Global, ONLY: ATOL,RTOL,VAR - - IMPLICIT NONE - - KPP_REAL :: TIN ! TIN - Start Time - KPP_REAL :: TOUT ! TOUT - End Time - INTEGER, INTENT(IN), OPTIONAL :: ICNTRL_U(20) - KPP_REAL, INTENT(IN), OPTIONAL :: RCNTRL_U(20) - INTEGER, INTENT(OUT), OPTIONAL :: ISTATUS_U(20) - KPP_REAL, INTENT(OUT), OPTIONAL :: RSTATUS_U(20) - INTEGER, INTENT(OUT), OPTIONAL :: IERR_U - - INTEGER :: IERR - - KPP_REAL :: RCNTRL(20), RSTATUS(20), T1, T2 - INTEGER :: ICNTRL(20), ISTATUS(20) - INTEGER, SAVE :: Ntotal = 0 - - RCNTRL(1:20) = 0.0_dp - ICNTRL(1:20) = 0 - - !~~~> fine-tune the integrator: - ICNTRL(2) = 0 ! 0=vector tolerances, 1=scalar tolerances - ICNTRL(5) = 8 ! Max no. of Newton iterations - ICNTRL(6) = 0 ! Starting values for Newton are interpolated (0) or zero (1) - ICNTRL(10) = 1 ! 0 - classic or 1 - SDIRK error estimation - ICNTRL(11) = 0 ! Gustaffson (0) or classic(1) controller - - !~~~> if optional parameters are given, and if they are >0, - ! then use them to overwrite default settings - IF (PRESENT(ICNTRL_U)) THEN - WHERE(ICNTRL_U(:) > 0) ICNTRL(:) = ICNTRL_U(:) - END IF - IF (PRESENT(RCNTRL_U)) THEN - WHERE(RCNTRL_U(:) > 0) RCNTRL(:) = RCNTRL_U(:) - END IF - - - T1 = TIN; T2 = TOUT - CALL RungeKutta( NVAR, T1, T2, VAR, RTOL, ATOL, & - RCNTRL,ICNTRL,RSTATUS,ISTATUS,IERR ) - - Ntotal = Ntotal + ISTATUS(Nstp) - PRINT*,'NSTEPS=',ISTATUS(Nstp),' (',Ntotal,')',' O3=', VAR(ind_O3) - - ! if optional parameters are given for output - ! use them to store information in them - IF (PRESENT(ISTATUS_U)) ISTATUS_U(:) = ISTATUS(:) - IF (PRESENT(RSTATUS_U)) RSTATUS_U(:) = RSTATUS(:) - IF (PRESENT(IERR_U)) IERR_U = IERR - - IF (IERR < 0) THEN - PRINT *,'Runge-Kutta: Unsuccessful exit at T=', TIN,' (IERR=',IERR,')' - ENDIF - - END SUBROUTINE INTEGRATE - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE RungeKutta( N,T,Tend,Y,RelTol,AbsTol, & - RCNTRL,ICNTRL,RSTATUS,ISTATUS,IERR ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -! This implementation is based on the book and the code Radau5: -! -! E. HAIRER AND G. WANNER -! "SOLVING ORDINARY DIFFERENTIAL EQUATIONS II. -! STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS." -! SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS 14, -! SPRINGER-VERLAG (1991) -! -! UNIVERSITE DE GENEVE, DEPT. DE MATHEMATIQUES -! CH-1211 GENEVE 24, SWITZERLAND -! E-MAIL: HAIRER@DIVSUN.UNIGE.CH, WANNER@DIVSUN.UNIGE.CH -! -! Methods: -! * Radau-2A quadrature (order 5) -! * Radau-1A quadrature (order 5) -! * Lobatto-3C quadrature (order 4) -! * Gauss quadrature (order 6) -! -! (C) Adrian Sandu, August 2005 -! Virginia Polytechnic Institute and State University -! Contact: sandu@cs.vt.edu -! Revised by Philipp Miehe and Adrian Sandu, May 2006 -! This implementation is part of KPP - the Kinetic PreProcessor -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!~~~> INPUT ARGUMENTS: -! ---------------- -! -! Note: For input parameters equal to zero the default values of the -! corresponding variables are used. -! -! N Dimension of the system -! T Initial time value -! -! Tend Final T value (Tend-T may be positive or negative) -! -! Y(N) Initial values for Y -! -! RelTol,AbsTol Relative and absolute error tolerances. -! for ICNTRL(2) = 0: AbsTol, RelTol are N-dimensional vectors -! = 1: AbsTol, RelTol are scalars -! -!~~~> Integer input parameters: -! -! ICNTRL(1) = not used -! -! ICNTRL(2) = 0: AbsTol, RelTol are NVAR-dimensional vectors -! = 1: AbsTol, RelTol are scalars -! -! ICNTRL(3) = RK method selection -! = 1: Radau-2A (the default) -! = 2: Lobatto-3C -! = 3: Gauss -! = 4: Radau-1A -! = 5: Lobatto-3A (not yet implemented) -! -! ICNTRL(4) -> maximum number of integration steps -! For ICNTRL(4)=0 the default value of 10000 is used -! -! ICNTRL(5) -> maximum number of Newton iterations -! For ICNTRL(5)=0 the default value of 8 is used -! -! ICNTRL(6) -> starting values of Newton iterations: -! ICNTRL(6)=0 : starting values are obtained from -! the extrapolated collocation solution -! (the default) -! ICNTRL(6)=1 : starting values are zero -! -! ICNTRL(10) -> switch for error estimation strategy -! ICNTRL(10) = 0: one additional stage at c=0, -! see Hairer (default) -! ICNTRL(10) = 1: two additional stages at c=0 -! and SDIRK at c=1, stiffly accurate -! -! ICNTRL(11) -> switch for step size strategy -! ICNTRL(11)=0: mod. predictive controller (Gustafsson, default) -! ICNTRL(11)=1: classical step size control -! the choice 1 seems to produce safer results; -! for simple problems, the choice 2 produces -! often slightly faster runs -! -!~~~> Real input parameters: -! -! RCNTRL(1) -> Hmin, lower bound for the integration step size -! (highly recommended to keep Hmin = ZERO, the default) -! -! RCNTRL(2) -> Hmax, upper bound for the integration step size -! -! RCNTRL(3) -> Hstart, the starting step size -! -! RCNTRL(4) -> FacMin, lower bound on step decrease factor (default=0.2) -! -! RCNTRL(5) -> FacMax, upper bound on step increase factor (default=6) -! -! RCNTRL(6) -> FacRej, step decrease factor after multiple rejections -! (default=0.1) -! -! RCNTRL(7) -> FacSafe, by which the new step is slightly smaller -! than the predicted value (default=0.9) -! -! RCNTRL(8) -> ThetaMin. If Newton convergence rate smaller -! than ThetaMin the Jacobian is not recomputed; -! (default=0.001) -! -! RCNTRL(9) -> NewtonTol, stopping criterion for Newton's method -! (default=0.03) -! -! RCNTRL(10) -> Qmin -! -! RCNTRL(11) -> Qmax. If Qmin < Hnew/Hold < Qmax, then the -! step size is kept constant and the LU factorization -! reused (default Qmin=1, Qmax=1.2) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -! -! OUTPUT ARGUMENTS: -! ----------------- -! -! T -> T value for which the solution has been computed -! (after successful return T=Tend). -! -! Y(N) -> Numerical solution at T -! -! IERR -> Reports on successfulness upon return: -! = 1 for success -! < 0 for error (value equals error code) -! -! ISTATUS(1) -> No. of function calls -! ISTATUS(2) -> No. of Jacobian calls -! ISTATUS(3) -> No. of steps -! ISTATUS(4) -> No. of accepted steps -! ISTATUS(5) -> No. of rejected steps (except at very beginning) -! ISTATUS(6) -> No. of LU decompositions -! ISTATUS(7) -> No. of forward/backward substitutions -! ISTATUS(8) -> No. of singular matrix decompositions -! -! RSTATUS(1) -> Texit, the time corresponding to the -! computed Y upon return -! RSTATUS(2) -> Hexit, last accepted step before exit -! RSTATUS(3) -> Hnew, last predicted step (not yet taken) -! For multiple restarts, use Hnew as Hstart -! in the subsequent run -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - - INTEGER :: N - KPP_REAL :: Y(N),AbsTol(N),RelTol(N),RCNTRL(20),RSTATUS(20) - INTEGER :: ICNTRL(20), ISTATUS(20) - LOGICAL :: StartNewton, Gustafsson, SdirkError - INTEGER :: IERR, ITOL - KPP_REAL :: T,Tend - - !~~~> Control arguments - INTEGER :: Max_no_steps, NewtonMaxit, rkMethod - KPP_REAL :: Hmin,Hmax,Hstart,Qmin,Qmax - KPP_REAL :: Roundoff, ThetaMin, NewtonTol - KPP_REAL :: FacSafe,FacMin,FacMax,FacRej - ! Runge-Kutta method parameters - INTEGER, PARAMETER :: R2A=1, R1A=2, L3C=3, GAU=4, L3A=5 - KPP_REAL :: rkT(3,3), rkTinv(3,3), rkTinvAinv(3,3), rkAinvT(3,3), & - rkA(0:3,0:3), rkB(0:3), rkC(0:3), rkD(0:3), rkE(0:3), & - rkBgam(0:4), rkBhat(0:4), rkTheta(0:3), rkF(0:4), & - rkGamma, rkAlpha, rkBeta, rkELO - !~~~> Local variables - INTEGER :: i - KPP_REAL, PARAMETER :: ZERO = 0.0d0, ONE = 1.0d0 - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! SETTING THE PARAMETERS -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IERR = 0 - ISTATUS(1:20) = 0 - RSTATUS(1:20) = ZERO - -!~~~> ICNTRL(1) - autonomous system - not used -!~~~> ITOL: 1 for vector and 0 for scalar AbsTol/RelTol - IF (ICNTRL(2) == 0) THEN - ITOL = 1 - ELSE - ITOL = 0 - END IF -!~~~> Error control selection - IF (ICNTRL(10) == 0) THEN - SdirkError = .FALSE. - ELSE - SdirkError = .TRUE. - END IF -!~~~> Method selection - SELECT CASE (ICNTRL(3)) - CASE (0,1) - CALL Radau2A_Coefficients - CASE (2) - CALL Lobatto3C_Coefficients - CASE (3) - CALL Gauss_Coefficients - CASE (4) - CALL Radau1A_Coefficients - CASE (5) - CALL Lobatto3A_Coefficients - CASE DEFAULT - WRITE(6,*) 'ICNTRL(3)=',ICNTRL(3) - CALL RK_ErrorMsg(-13,T,ZERO,IERR) - END SELECT -!~~~> Max_no_steps: the maximal number of time steps - IF (ICNTRL(4) == 0) THEN - Max_no_steps = 200000 - ELSE - Max_no_steps=ICNTRL(4) - IF (Max_no_steps <= 0) THEN - WRITE(6,*) 'ICNTRL(4)=',ICNTRL(4) - CALL RK_ErrorMsg(-1,T,ZERO,IERR) - END IF - END IF -!~~~> NewtonMaxit maximal number of Newton iterations - IF (ICNTRL(5) == 0) THEN - NewtonMaxit = 8 - ELSE - NewtonMaxit=ICNTRL(5) - IF (NewtonMaxit <= 0) THEN - WRITE(6,*) 'ICNTRL(5)=',ICNTRL(5) - CALL RK_ErrorMsg(-2,T,ZERO,IERR) - END IF - END IF -!~~~> StartNewton: Use extrapolation for starting values of Newton iterations - IF (ICNTRL(6) == 0) THEN - StartNewton = .TRUE. - ELSE - StartNewton = .FALSE. - END IF -!~~~> Gustafsson: step size controller - IF(ICNTRL(11) == 0)THEN - Gustafsson = .TRUE. - ELSE - Gustafsson = .FALSE. - END IF - -!~~~> Roundoff: smallest number s.t. 1.0 + Roundoff > 1.0 - Roundoff=WLAMCH('E'); - -!~~~> Hmin = minimal step size - IF (RCNTRL(1) == ZERO) THEN - Hmin = ZERO - ELSE - Hmin = MIN(ABS(RCNTRL(1)),ABS(Tend-T)) - END IF -!~~~> Hmax = maximal step size - IF (RCNTRL(2) == ZERO) THEN - Hmax = ABS(Tend-T) - ELSE - Hmax = MIN(ABS(RCNTRL(2)),ABS(Tend-T)) - END IF -!~~~> Hstart = starting step size - IF (RCNTRL(3) == ZERO) THEN - Hstart = ZERO - ELSE - Hstart = MIN(ABS(RCNTRL(3)),ABS(Tend-T)) - END IF -!~~~> FacMin: lower bound on step decrease factor - IF(RCNTRL(4) == ZERO)THEN - FacMin = 0.2d0 - ELSE - FacMin = RCNTRL(4) - END IF -!~~~> FacMax: upper bound on step increase factor - IF(RCNTRL(5) == ZERO)THEN - FacMax = 8.D0 - ELSE - FacMax = RCNTRL(5) - END IF -!~~~> FacRej: step decrease factor after 2 consecutive rejections - IF(RCNTRL(6) == ZERO)THEN - FacRej = 0.1d0 - ELSE - FacRej = RCNTRL(6) - END IF -!~~~> FacSafe: by which the new step is slightly smaller -! than the predicted value - IF (RCNTRL(7) == ZERO) THEN - FacSafe=0.9d0 - ELSE - FacSafe=RCNTRL(7) - END IF - IF ( (FacMax < ONE) .OR. (FacMin > ONE) .OR. & - (FacSafe <= 1.0d-3) .OR. (FacSafe >= ONE) ) THEN - WRITE(6,*)'RCNTRL(4:7)=',RCNTRL(4:7) - CALL RK_ErrorMsg(-4,T,ZERO,IERR) - END IF - -!~~~> ThetaMin: decides whether the Jacobian should be recomputed - IF (RCNTRL(8) == ZERO) THEN - ThetaMin = 1.0d-3 - ELSE - ThetaMin=RCNTRL(8) - IF (ThetaMin <= 0.0d0 .OR. ThetaMin >= 1.0d0) THEN - WRITE(6,*) 'RCNTRL(8)=', RCNTRL(8) - CALL RK_ErrorMsg(-5,T,ZERO,IERR) - END IF - END IF -!~~~> NewtonTol: stopping crierion for Newton's method - IF (RCNTRL(9) == ZERO) THEN - NewtonTol = 3.0d-2 - ELSE - NewtonTol = RCNTRL(9) - IF (NewtonTol <= Roundoff) THEN - WRITE(6,*) 'RCNTRL(9)=',RCNTRL(9) - CALL RK_ErrorMsg(-6,T,ZERO,IERR) - END IF - END IF -!~~~> Qmin AND Qmax: IF Qmin < Hnew/Hold < Qmax then step size = const. - IF (RCNTRL(10) == ZERO) THEN - Qmin=1.D0 - ELSE - Qmin=RCNTRL(10) - END IF - IF (RCNTRL(11) == ZERO) THEN - Qmax=1.2D0 - ELSE - Qmax=RCNTRL(11) - END IF - IF (Qmin > ONE .OR. Qmax < ONE) THEN - WRITE(6,*) 'RCNTRL(10:11)=',Qmin,Qmax - CALL RK_ErrorMsg(-7,T,ZERO,IERR) - END IF -!~~~> Check if tolerances are reasonable - IF (ITOL == 0) THEN - IF (AbsTol(1) <= ZERO.OR.RelTol(1) <= 10.d0*Roundoff) THEN - WRITE (6,*) 'AbsTol/RelTol=',AbsTol,RelTol - CALL RK_ErrorMsg(-8,T,ZERO,IERR) - END IF - ELSE - DO i=1,N - IF (AbsTol(i) <= ZERO.OR.RelTol(i) <= 10.d0*Roundoff) THEN - WRITE (6,*) 'AbsTol/RelTol(',i,')=',AbsTol(i),RelTol(i) - CALL RK_ErrorMsg(-8,T,ZERO,IERR) - END IF - END DO - END IF - -!~~~> Parameters are wrong - IF (IERR < 0) RETURN - -!~~~> Call the core method - CALL RK_Integrator( N,T,Tend,Y,IERR ) - - CONTAINS ! Internal procedures to RungeKutta - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE RK_Integrator( N,T,Tend,Y,IERR ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE -!~~~> Arguments - INTEGER, INTENT(IN) :: N - KPP_REAL, INTENT(IN) :: Tend - KPP_REAL, INTENT(INOUT) :: T, Y(NVAR) - INTEGER, INTENT(OUT) :: IERR - -!~~~> Local variables -#ifdef FULL_ALGEBRA - KPP_REAL :: FJAC(NVAR,NVAR), E1(NVAR,NVAR) - COMPLEX(kind=dp) :: E2(NVAR,NVAR) -#else - KPP_REAL :: FJAC(LU_NONZERO), E1(LU_NONZERO) - COMPLEX(kind=dp) :: E2(LU_NONZERO) -#endif - KPP_REAL, DIMENSION(NVAR) :: Z1,Z2,Z3,Z4,SCAL,DZ1,DZ2,DZ3,DZ4, & - G,TMP,F0 - KPP_REAL :: CONT(NVAR,3), Tdirection, H, Hacc, Hnew, Hold, Fac, & - FacGus, Theta, Err, ErrOld, NewtonRate, NewtonIncrement, & - Hratio, Qnewton, NewtonPredictedErr,NewtonIncrementOld, ThetaSD - INTEGER :: IP1(NVAR),IP2(NVAR),NewtonIter, ISING, Nconsecutive - LOGICAL :: Reject, FirstStep, SkipJac, NewtonDone, SkipLU - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Initial setting -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Tdirection = SIGN(ONE,Tend-T) - H = MIN( MAX(ABS(Hmin),ABS(Hstart)) , Hmax ) - IF (ABS(H) <= 10.d0*Roundoff) H = 1.0d-6 - H = SIGN(H,Tdirection) - Hold = H - Reject = .FALSE. - FirstStep = .TRUE. - SkipJac = .FALSE. - SkipLU = .FALSE. - IF ((T+H*1.0001D0-Tend)*Tdirection >= ZERO) THEN - H = Tend-T - END IF - Nconsecutive = 0 - CALL RK_ErrorScale(N,ITOL,AbsTol,RelTol,Y,SCAL) - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Time loop begins -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Tloop: DO WHILE ( (Tend-T)*Tdirection - Roundoff > ZERO ) - - !IF ( .NOT.Reject ) THEN - CALL FUN_CHEM(T,Y,F0) - ISTATUS(Nfun) = ISTATUS(Nfun) + 1 - !END IF - - IF ( .NOT.SkipLU ) THEN ! This time around skip the Jac update and LU - !~~~> Compute the Jacobian matrix - IF ( .NOT.SkipJac ) THEN - CALL JAC_CHEM(T,Y,FJAC) - ISTATUS(Njac) = ISTATUS(Njac) + 1 - END IF - !~~~> Compute the matrices E1 and E2 and their decompositions - CALL RK_Decomp(N,H,FJAC,E1,IP1,E2,IP2,ISING) - IF (ISING /= 0) THEN - ISTATUS(Nsng) = ISTATUS(Nsng) + 1; Nconsecutive = Nconsecutive + 1 - IF (Nconsecutive >= 5) THEN - CALL RK_ErrorMsg(-12,T,H,IERR); RETURN - END IF - H=H*0.5d0; Reject=.TRUE.; SkipJac = .TRUE.; SkipLU = .FALSE. - CYCLE Tloop - ELSE - Nconsecutive = 0 - END IF - END IF ! SkipLU - - ISTATUS(Nstp) = ISTATUS(Nstp) + 1 - IF (ISTATUS(Nstp) > Max_no_steps) THEN - PRINT*,'Max number of time steps is ',Max_no_steps - CALL RK_ErrorMsg(-9,T,H,IERR); RETURN - END IF - IF (0.1D0*ABS(H) <= ABS(T)*Roundoff) THEN - CALL RK_ErrorMsg(-10,T,H,IERR); RETURN - END IF - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Loop for the simplified Newton iterations -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - !~~~> Starting values for Newton iteration - IF ( FirstStep .OR. (.NOT.StartNewton) ) THEN - CALL Set2zero(N,Z1) - CALL Set2zero(N,Z2) - CALL Set2zero(N,Z3) - ELSE - ! Evaluate quadratic polynomial - CALL RK_Interpolate('eval',N,H,Hold,Z1,Z2,Z3,CONT) - END IF - - !~~~> Initializations for Newton iteration - NewtonDone = .FALSE. - Fac = 0.5d0 ! Step reduction if too many iterations - -NewtonLoop:DO NewtonIter = 1, NewtonMaxit - - !~~~> Prepare the right-hand side - CALL RK_PrepareRHS(N,T,H,Y,F0,Z1,Z2,Z3,DZ1,DZ2,DZ3) - - !~~~> Solve the linear systems - CALL RK_Solve( N,H,E1,IP1,E2,IP2,DZ1,DZ2,DZ3,ISING ) - - NewtonIncrement = SQRT( ( RK_ErrorNorm(N,SCAL,DZ1)**2 + & - RK_ErrorNorm(N,SCAL,DZ2)**2 + & - RK_ErrorNorm(N,SCAL,DZ3)**2 )/3.0d0 ) - - IF ( NewtonIter == 1 ) THEN - Theta = ABS(ThetaMin) - NewtonRate = 2.0d0 - ELSE - Theta = NewtonIncrement/NewtonIncrementOld - IF (Theta < 0.99d0) THEN - NewtonRate = Theta/(ONE-Theta) - ELSE ! Non-convergence of Newton: Theta too large - EXIT NewtonLoop - END IF - IF ( NewtonIter < NewtonMaxit ) THEN - ! Predict error at the end of Newton process - NewtonPredictedErr = NewtonIncrement & - *Theta**(NewtonMaxit-NewtonIter)/(ONE-Theta) - IF (NewtonPredictedErr >= NewtonTol) THEN - ! Non-convergence of Newton: predicted error too large - Qnewton = MIN(10.0d0,NewtonPredictedErr/NewtonTol) - Fac=0.8d0*Qnewton**(-ONE/(1+NewtonMaxit-NewtonIter)) - EXIT NewtonLoop - END IF - END IF - END IF - - NewtonIncrementOld = MAX(NewtonIncrement,Roundoff) - ! Update solution - CALL WAXPY(N,-ONE,DZ1,1,Z1,1) ! Z1 <- Z1 - DZ1 - CALL WAXPY(N,-ONE,DZ2,1,Z2,1) ! Z2 <- Z2 - DZ2 - CALL WAXPY(N,-ONE,DZ3,1,Z3,1) ! Z3 <- Z3 - DZ3 - - ! Check error in Newton iterations - NewtonDone = (NewtonRate*NewtonIncrement <= NewtonTol) - IF (NewtonDone) EXIT NewtonLoop - IF (NewtonIter == NewtonMaxit) THEN - PRINT*, 'Slow or no convergence in Newton Iteration: Max no. of', & - 'Newton iterations reached' - END IF - - END DO NewtonLoop - - IF (.NOT.NewtonDone) THEN - !CALL RK_ErrorMsg(-12,T,H,IERR); - H = Fac*H; Reject=.TRUE.; SkipJac = .TRUE.; SkipLU = .FALSE. - CYCLE Tloop - END IF - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> SDIRK Stage -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IF (SdirkError) THEN - -!~~~> Starting values for Newton iterations - Z4(1:N) = Z3(1:N) - -!~~~> Prepare the loop-independent part of the right-hand side -! G = H*rkBgam(0)*F0 + rkTheta(1)*Z1 + rkTheta(2)*Z2 + rkTheta(3)*Z3 - CALL Set2Zero(N, G) - IF (rkMethod/=L3A) CALL WAXPY(N,rkBgam(0)*H, F0,1,G,1) - CALL WAXPY(N,rkTheta(1),Z1,1,G,1) - CALL WAXPY(N,rkTheta(2),Z2,1,G,1) - CALL WAXPY(N,rkTheta(3),Z3,1,G,1) - - !~~~> Initializations for Newton iteration - NewtonDone = .FALSE. - Fac = 0.5d0 ! Step reduction factor if too many iterations - -SDNewtonLoop:DO NewtonIter = 1, NewtonMaxit - -!~~~> Prepare the loop-dependent part of the right-hand side - CALL WADD(N,Y,Z4,TMP) ! TMP <- Y + Z4 - CALL FUN_CHEM(T+H,TMP,DZ4) ! DZ4 <- Fun(Y+Z4) - ISTATUS(Nfun) = ISTATUS(Nfun) + 1 -! DZ4(1:N) = (G(1:N)-Z4(1:N))*(rkGamma/H) + DZ4(1:N) - CALL WAXPY (N, -ONE*rkGamma/H, Z4, 1, DZ4, 1) - CALL WAXPY (N, rkGamma/H, G,1, DZ4,1) - -!~~~> Solve the linear system -#ifdef FULL_ALGEBRA - CALL DGETRS( 'N', N, 1, E1, N, IP1, DZ4, N, ISING ) -#else - CALL KppSolve(E1, DZ4) -#endif - -!~~~> Check convergence of Newton iterations - NewtonIncrement = RK_ErrorNorm(N,SCAL,DZ4) - IF ( NewtonIter == 1 ) THEN - ThetaSD = ABS(ThetaMin) - NewtonRate = 2.0d0 - ELSE - ThetaSD = NewtonIncrement/NewtonIncrementOld - IF (ThetaSD < 0.99d0) THEN - NewtonRate = ThetaSD/(ONE-ThetaSD) - ! Predict error at the end of Newton process - NewtonPredictedErr = NewtonIncrement & - *ThetaSD**(NewtonMaxit-NewtonIter)/(ONE-ThetaSD) - IF (NewtonPredictedErr >= NewtonTol) THEN - ! Non-convergence of Newton: predicted error too large - !PRINT*,'Error too large: ', NewtonPredictedErr - Qnewton = MIN(10.0d0,NewtonPredictedErr/NewtonTol) - Fac = 0.8d0*Qnewton**(-ONE/(1+NewtonMaxit-NewtonIter)) - EXIT SDNewtonLoop - END IF - ELSE ! Non-convergence of Newton: Theta too large - !PRINT*,'Theta too large: ',ThetaSD - EXIT SDNewtonLoop - END IF - END IF - NewtonIncrementOld = NewtonIncrement - ! Update solution: Z4 <-- Z4 + DZ4 - CALL WAXPY(N,ONE,DZ4,1,Z4,1) - - ! Check error in Newton iterations - NewtonDone = (NewtonRate*NewtonIncrement <= NewtonTol) - IF (NewtonDone) EXIT SDNewtonLoop - - END DO SDNewtonLoop - - IF (.NOT.NewtonDone) THEN - H = Fac*H; Reject=.TRUE.; SkipJac = .TRUE.; SkipLU = .FALSE. - CYCLE Tloop - END IF - END IF -!~~~> End of implified SDIRK Newton iterations - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Error estimation -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IF (SdirkError) THEN - CALL Set2Zero(N, DZ4) - IF (rkMethod==L3A) THEN - DZ4(1:N) = H*rkF(0)*F0(1:N) - IF (rkF(1) /= ZERO) CALL WAXPY(N, rkF(1), Z1, 1, DZ4, 1) - IF (rkF(2) /= ZERO) CALL WAXPY(N, rkF(2), Z2, 1, DZ4, 1) - IF (rkF(3) /= ZERO) CALL WAXPY(N, rkF(3), Z3, 1, DZ4, 1) - TMP = Y + Z4 - CALL FUN_CHEM(T+H,TMP,DZ1) - CALL WAXPY(N, H*rkBgam(4), DZ1, 1, DZ4, 1) - ELSE -! DZ4(1:N) = rkD(1)*Z1 + rkD(2)*Z2 + rkD(3)*Z3 - Z4 - IF (rkD(1) /= ZERO) CALL WAXPY(N, rkD(1), Z1, 1, DZ4, 1) - IF (rkD(2) /= ZERO) CALL WAXPY(N, rkD(2), Z2, 1, DZ4, 1) - IF (rkD(3) /= ZERO) CALL WAXPY(N, rkD(3), Z3, 1, DZ4, 1) - CALL WAXPY(N, -ONE, Z4, 1, DZ4, 1) - END IF - Err = RK_ErrorNorm(N,SCAL,DZ4) - ELSE - CALL RK_ErrorEstimate(N,H,T,Y,F0, & - E1,IP1,Z1,Z2,Z3,SCAL,Err,FirstStep,Reject) - END IF - -!~~~> Computation of new step size Hnew - Fac = Err**(-ONE/rkELO)* & - MIN(FacSafe,(ONE+2*NewtonMaxit)/(NewtonIter+2*NewtonMaxit)) - Fac = MIN(FacMax,MAX(FacMin,Fac)) - Hnew = Fac*H - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Accept/reject step -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -accept:IF (Err < ONE) THEN !~~~> STEP IS ACCEPTED - FirstStep=.FALSE. - ISTATUS(Nacc) = ISTATUS(Nacc) + 1 - IF (Gustafsson) THEN - !~~~> Predictive controller of Gustafsson - IF (ISTATUS(Nacc) > 1) THEN - FacGus=FacSafe*(H/Hacc)*(Err**2/ErrOld)**(-0.25d0) - FacGus=MIN(FacMax,MAX(FacMin,FacGus)) - Fac=MIN(Fac,FacGus) - Hnew = Fac*H - END IF - Hacc=H - ErrOld=MAX(1.0d-2,Err) - END IF - Hold = H - T = T+H - ! Update solution: Y <- Y + sum(d_i Z_i) - IF (rkD(1) /= ZERO) CALL WAXPY(N,rkD(1),Z1,1,Y,1) - IF (rkD(2) /= ZERO) CALL WAXPY(N,rkD(2),Z2,1,Y,1) - IF (rkD(3) /= ZERO) CALL WAXPY(N,rkD(3),Z3,1,Y,1) - ! Construct the solution quadratic interpolant Q(c_i) = Z_i, i=1:3 - IF (StartNewton) CALL RK_Interpolate('make',N,H,Hold,Z1,Z2,Z3,CONT) - CALL RK_ErrorScale(N,ITOL,AbsTol,RelTol,Y,SCAL) - RSTATUS(Ntexit) = T - RSTATUS(Nhnew) = Hnew - RSTATUS(Nhacc) = H - Hnew = Tdirection*MIN( MAX(ABS(Hnew),Hmin) , Hmax ) - IF (Reject) Hnew = Tdirection*MIN(ABS(Hnew),ABS(H)) - Reject = .FALSE. - IF ((T+Hnew/Qmin-Tend)*Tdirection >= ZERO) THEN - H = Tend-T - ELSE - Hratio=Hnew/H - ! Reuse the LU decomposition - SkipLU = (Theta<=ThetaMin) .AND. (Hratio>=Qmin) .AND. (Hratio<=Qmax) - IF (.NOT.SkipLU) H=Hnew - END IF - ! If convergence is fast enough, do not update Jacobian -! SkipJac = (Theta <= ThetaMin) - SkipJac = .FALSE. - - ELSE accept !~~~> Step is rejected - IF (FirstStep .OR. Reject) THEN - H = FacRej*H - ELSE - H = Hnew - END IF - Reject = .TRUE. - SkipJac = .TRUE. ! Skip if rejected - Jac is independent of H - SkipLU = .FALSE. - IF (ISTATUS(Nacc) >= 1) ISTATUS(Nrej) = ISTATUS(Nrej) + 1 - END IF accept - - END DO Tloop - - ! Successful exit - IERR = 1 - - END SUBROUTINE RK_Integrator - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE RK_ErrorMsg(Code,T,H,IERR) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Handles all error messages -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - KPP_REAL, INTENT(IN) :: T, H - INTEGER, INTENT(IN) :: Code - INTEGER, INTENT(OUT) :: IERR - - IERR = Code - PRINT * , & - 'Forced exit from RungeKutta due to the following error:' - - - SELECT CASE (Code) - CASE (-1) - PRINT * , '--> Improper value for maximal no of steps' - CASE (-2) - PRINT * , '--> Improper value for maximal no of Newton iterations' - CASE (-3) - PRINT * , '--> Hmin/Hmax/Hstart must be positive' - CASE (-4) - PRINT * , '--> Improper values for FacMin/FacMax/FacSafe/FacRej' - CASE (-5) - PRINT * , '--> Improper value for ThetaMin' - CASE (-6) - PRINT * , '--> Newton stopping tolerance too small' - CASE (-7) - PRINT * , '--> Improper values for Qmin, Qmax' - CASE (-8) - PRINT * , '--> Tolerances are too small' - CASE (-9) - PRINT * , '--> No of steps exceeds maximum bound' - CASE (-10) - PRINT * , '--> Step size too small: T + 10*H = T', & - ' or H < Roundoff' - CASE (-11) - PRINT * , '--> Matrix is repeatedly singular' - CASE (-12) - PRINT * , '--> Non-convergence of Newton iterations' - CASE (-13) - PRINT * , '--> Requested RK method not implemented' - CASE DEFAULT - PRINT *, 'Unknown Error code: ', Code - END SELECT - - WRITE(6,FMT="(5X,'T=',E12.5,' H=',E12.5)") T, H - - END SUBROUTINE RK_ErrorMsg - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE RK_ErrorScale(N,ITOL,AbsTol,RelTol,Y,SCAL) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Handles all error messages -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - INTEGER, INTENT(IN) :: N, ITOL - KPP_REAL, INTENT(IN) :: AbsTol(*), RelTol(*), Y(N) - KPP_REAL, INTENT(OUT) :: SCAL(N) - INTEGER :: i - - IF (ITOL==0) THEN - DO i=1,N - SCAL(i)= ONE/(AbsTol(1)+RelTol(1)*ABS(Y(i))) - END DO - ELSE - DO i=1,N - SCAL(i)=ONE/(AbsTol(i)+RelTol(i)*ABS(Y(i))) - END DO - END IF - - END SUBROUTINE RK_ErrorScale - - -!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! SUBROUTINE RK_Transform(N,Tr,Z1,Z2,Z3,W1,W2,W3) -!!~~~> W <-- Tr x Z -!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! IMPLICIT NONE -! INTEGER :: N, i -! KPP_REAL :: Tr(3,3),Z1(N),Z2(N),Z3(N),W1(N),W2(N),W3(N) -! KPP_REAL :: x1, x2, x3 -! DO i=1,N -! x1 = Z1(i); x2 = Z2(i); x3 = Z3(i) -! W1(i) = Tr(1,1)*x1 + Tr(1,2)*x2 + Tr(1,3)*x3 -! W2(i) = Tr(2,1)*x1 + Tr(2,2)*x2 + Tr(2,3)*x3 -! W3(i) = Tr(3,1)*x1 + Tr(3,2)*x2 + Tr(3,3)*x3 -! END DO -! END SUBROUTINE RK_Transform - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE RK_Interpolate(action,N,H,Hold,Z1,Z2,Z3,CONT) -!~~~> Constructs or evaluates a quadratic polynomial -! that interpolates the Z solution at current step -! and provides starting values for the next step -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - INTEGER :: N, i - KPP_REAL :: H,Hold,Z1(N),Z2(N),Z3(N),CONT(N,3) - KPP_REAL :: r, x1, x2, x3, den - CHARACTER(LEN=4) :: action - - SELECT CASE (action) - CASE ('make') - ! Construct the solution quadratic interpolant Q(c_i) = Z_i, i=1:3 - den = (rkC(3)-rkC(2))*(rkC(2)-rkC(1))*(rkC(1)-rkC(3)) - DO i=1,N - CONT(i,1)=(-rkC(3)**2*rkC(2)*Z1(i)+Z3(i)*rkC(2)*rkC(1)**2 & - +rkC(2)**2*rkC(3)*Z1(i)-rkC(2)**2*rkC(1)*Z3(i) & - +rkC(3)**2*rkC(1)*Z2(i)-Z2(i)*rkC(3)*rkC(1)**2)& - /den-Z3(i) - CONT(i,2)= -( rkC(1)**2*(Z3(i)-Z2(i)) + rkC(2)**2*(Z1(i) & - -Z3(i)) +rkC(3)**2*(Z2(i)-Z1(i)) )/den - CONT(i,3)= ( rkC(1)*(Z3(i)-Z2(i)) + rkC(2)*(Z1(i)-Z3(i)) & - +rkC(3)*(Z2(i)-Z1(i)) )/den - END DO - CASE ('eval') - ! Evaluate quadratic polynomial - r = H/Hold - x1 = ONE + rkC(1)*r - x2 = ONE + rkC(2)*r - x3 = ONE + rkC(3)*r - DO i=1,N - Z1(i) = CONT(i,1)+x1*(CONT(i,2)+x1*CONT(i,3)) - Z2(i) = CONT(i,1)+x2*(CONT(i,2)+x2*CONT(i,3)) - Z3(i) = CONT(i,1)+x3*(CONT(i,2)+x3*CONT(i,3)) - END DO - END SELECT - END SUBROUTINE RK_Interpolate - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE RK_PrepareRHS(N,T,H,Y,F0,Z1,Z2,Z3,R1,R2,R3) -!~~~> Prepare the right-hand side for Newton iterations -! R = Z - hA x F -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - - INTEGER :: N - KPP_REAL :: T, H - KPP_REAL, DIMENSION(N) :: Y,Z1,Z2,Z3,F0,F,R1,R2,R3,TMP - - CALL WCOPY(N,Z1,1,R1,1) ! R1 <- Z1 - CALL WCOPY(N,Z2,1,R2,1) ! R2 <- Z2 - CALL WCOPY(N,Z3,1,R3,1) ! R3 <- Z3 - - IF (rkMethod==L3A) THEN - CALL WAXPY(N,-H*rkA(1,0),F0,1,R1,1) ! R1 <- R1 - h*A_10*F0 - CALL WAXPY(N,-H*rkA(2,0),F0,1,R2,1) ! R2 <- R2 - h*A_20*F0 - CALL WAXPY(N,-H*rkA(3,0),F0,1,R3,1) ! R3 <- R3 - h*A_30*F0 - END IF - - CALL WADD(N,Y,Z1,TMP) ! TMP <- Y + Z1 - CALL FUN_CHEM(T+rkC(1)*H,TMP,F) ! F1 <- Fun(Y+Z1) - CALL WAXPY(N,-H*rkA(1,1),F,1,R1,1) ! R1 <- R1 - h*A_11*F1 - CALL WAXPY(N,-H*rkA(2,1),F,1,R2,1) ! R2 <- R2 - h*A_21*F1 - CALL WAXPY(N,-H*rkA(3,1),F,1,R3,1) ! R3 <- R3 - h*A_31*F1 - - CALL WADD(N,Y,Z2,TMP) ! TMP <- Y + Z2 - CALL FUN_CHEM(T+rkC(2)*H,TMP,F) ! F2 <- Fun(Y+Z2) - CALL WAXPY(N,-H*rkA(1,2),F,1,R1,1) ! R1 <- R1 - h*A_12*F2 - CALL WAXPY(N,-H*rkA(2,2),F,1,R2,1) ! R2 <- R2 - h*A_22*F2 - CALL WAXPY(N,-H*rkA(3,2),F,1,R3,1) ! R3 <- R3 - h*A_32*F2 - - CALL WADD(N,Y,Z3,TMP) ! TMP <- Y + Z3 - CALL FUN_CHEM(T+rkC(3)*H,TMP,F) ! F3 <- Fun(Y+Z3) - CALL WAXPY(N,-H*rkA(1,3),F,1,R1,1) ! R1 <- R1 - h*A_13*F3 - CALL WAXPY(N,-H*rkA(2,3),F,1,R2,1) ! R2 <- R2 - h*A_23*F3 - CALL WAXPY(N,-H*rkA(3,3),F,1,R3,1) ! R3 <- R3 - h*A_33*F3 - - END SUBROUTINE RK_PrepareRHS - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE RK_Decomp(N,H,FJAC,E1,IP1,E2,IP2,ISING) - !~~~> Compute the matrices E1 and E2 and their decompositions -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - - INTEGER :: N, ISING - KPP_REAL :: H, Alpha, Beta, Gamma -#ifdef FULL_ALGEBRA - KPP_REAL :: FJAC(NVAR,NVAR),E1(NVAR,NVAR) - COMPLEX(kind=dp) :: E2(N,N) -#else - KPP_REAL :: FJAC(LU_NONZERO),E1(LU_NONZERO) - COMPLEX(kind=dp) :: E2(LU_NONZERO) -#endif - INTEGER :: IP1(N), IP2(N), i, j - - Gamma = rkGamma/H - Alpha = rkAlpha/H - Beta = rkBeta /H - -#ifdef FULL_ALGEBRA - DO j=1,N - DO i=1,N - E1(i,j)=-FJAC(i,j) - END DO - E1(j,j)=E1(j,j)+Gamma - END DO - CALL DGETRF(N,N,E1,N,IP1,ISING) -#else - DO i=1,LU_NONZERO - E1(i)=-FJAC(i) - END DO - DO i=1,NVAR - j=LU_DIAG(i); E1(j)=E1(j)+Gamma - END DO - CALL KppDecomp(E1,ISING) -#endif - - IF (ISING /= 0) THEN - ISTATUS(Ndec) = ISTATUS(Ndec) + 1 - RETURN - END IF - -#ifdef FULL_ALGEBRA - DO j=1,N - DO i=1,N - E2(i,j) = DCMPLX( -FJAC(i,j), ZERO ) - END DO - E2(j,j) = E2(j,j) + CMPLX( Alpha, Beta ) - END DO - CALL ZGETRF(N,N,E2,N,IP2,ISING) -#else - DO i=1,LU_NONZERO - E2(i) = DCMPLX( -FJAC(i), ZERO ) - END DO - DO i=1,NVAR - j=LU_DIAG(i); E2(j)=E2(j) + CMPLX( Alpha, Beta ) - END DO - CALL KppDecompCmplx(E2,ISING) -#endif - ISTATUS(Ndec) = ISTATUS(Ndec) + 1 - - END SUBROUTINE RK_Decomp - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE RK_Solve(N,H,E1,IP1,E2,IP2,R1,R2,R3,ISING) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - INTEGER :: N,IP1(NVAR),IP2(NVAR),ISING -#ifdef FULL_ALGEBRA - KPP_REAL :: E1(NVAR,NVAR) - COMPLEX(kind=dp) :: E2(NVAR,NVAR) -#else - KPP_REAL :: E1(LU_NONZERO) - COMPLEX(kind=dp) :: E2(LU_NONZERO) -#endif - KPP_REAL :: R1(N),R2(N),R3(N) - KPP_REAL :: H, x1, x2, x3 - COMPLEX(kind=dp) :: BC(N) - INTEGER :: i -! - ! Z <- h^{-1) T^{-1) A^{-1) x Z - DO i=1,N - x1 = R1(i)/H; x2 = R2(i)/H; x3 = R3(i)/H - R1(i) = rkTinvAinv(1,1)*x1 + rkTinvAinv(1,2)*x2 + rkTinvAinv(1,3)*x3 - R2(i) = rkTinvAinv(2,1)*x1 + rkTinvAinv(2,2)*x2 + rkTinvAinv(2,3)*x3 - R3(i) = rkTinvAinv(3,1)*x1 + rkTinvAinv(3,2)*x2 + rkTinvAinv(3,3)*x3 - END DO - -#ifdef FULL_ALGEBRA - CALL DGETRS ('N',N,1,E1,N,IP1,R1,N,0) -#else - CALL KppSolve (E1,R1) -#endif -! - DO i=1,N - BC(i) = DCMPLX(R2(i),R3(i)) - END DO -#ifdef FULL_ALGEBRA - CALL ZGETRS ('N',N,1,E2,N,IP2,BC,N,0) -#else - CALL KppSolveCmplx (E2,BC) -#endif - DO i=1,N - R2(i) = DBLE( BC(i) ) - R3(i) = AIMAG( BC(i) ) - END DO - - ! Z <- T x Z - DO i=1,N - x1 = R1(i); x2 = R2(i); x3 = R3(i) - R1(i) = rkT(1,1)*x1 + rkT(1,2)*x2 + rkT(1,3)*x3 - R2(i) = rkT(2,1)*x1 + rkT(2,2)*x2 + rkT(2,3)*x3 - R3(i) = rkT(3,1)*x1 + rkT(3,2)*x2 + rkT(3,3)*x3 - END DO - - ISTATUS(Nsol) = ISTATUS(Nsol) + 1 - - END SUBROUTINE RK_Solve - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE RK_ErrorEstimate(N,H,T,Y,F0, & - E1,IP1,Z1,Z2,Z3,SCAL,Err, & - FirstStep,Reject) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - - INTEGER :: N -#ifdef FULL_ALGEBRA - KPP_REAL :: E1(NVAR,NVAR) -#else - KPP_REAL :: E1(LU_NONZERO) -#endif - KPP_REAL :: SCAL(N),Z1(N),Z2(N),Z3(N),F1(N),F2(N), & - F0(N),Y(N),TMP(N),T,H - INTEGER :: IP1(N), i - LOGICAL FirstStep,Reject - KPP_REAL :: HrkE1,HrkE2,HrkE3,Err - - HrkE1 = rkE(1)/H - HrkE2 = rkE(2)/H - HrkE3 = rkE(3)/H - - DO i=1,N - F2(i) = HrkE1*Z1(i)+HrkE2*Z2(i)+HrkE3*Z3(i) - TMP(i) = rkE(0)*F0(i) + F2(i) - END DO - - -#ifdef FULL_ALGEBRA - CALL DGETRS ('N',N,1,E1,N,IP1,TMP,N,0) - IF ((rkMethod==R1A).OR.(rkMethod==GAU).OR.(rkMethod==L3A)) CALL DGETRS ('N',N,1,E1,N,IP1,TMP,N,0) - IF (rkMethod==GAU) CALL DGETRS ('N',N,1,E1,N,IP1,TMP,N,0) -#else - CALL KppSolve (E1, TMP) - IF ((rkMethod==R1A).OR.(rkMethod==GAU).OR.(rkMethod==L3A)) CALL KppSolve (E1,TMP) - IF (rkMethod==GAU) CALL KppSolve (E1,TMP) -#endif - - Err = RK_ErrorNorm(N,SCAL,TMP) -! - IF (Err < ONE) RETURN -firej:IF (FirstStep.OR.Reject) THEN - DO i=1,N - TMP(i)=Y(i)+TMP(i) - END DO - CALL FUN_CHEM(T,TMP,F1) - ISTATUS(Nfun) = ISTATUS(Nfun) + 1 - DO i=1,N - TMP(i)=F1(i)+F2(i) - END DO - -#ifdef FULL_ALGEBRA - CALL DGETRS ('N',N,1,E1,N,IP1,TMP,N,0) -#else - CALL KppSolve (E1, TMP) -#endif - Err = RK_ErrorNorm(N,SCAL,TMP) - END IF firej - - END SUBROUTINE RK_ErrorEstimate - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - KPP_REAL FUNCTION RK_ErrorNorm(N,SCAL,DY) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - - INTEGER :: N - KPP_REAL :: SCAL(N),DY(N) - INTEGER :: i - - RK_ErrorNorm = ZERO - DO i=1,N - RK_ErrorNorm = RK_ErrorNorm + (DY(i)*SCAL(i))**2 - END DO - RK_ErrorNorm = MAX( SQRT(RK_ErrorNorm/N), 1.0d-10 ) - - END FUNCTION RK_ErrorNorm - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Radau2A_Coefficients -! The coefficients of the 3-stage Radau-2A method -! (given to ~30 accurate digits) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE -! The coefficients of the Radau2A method - KPP_REAL :: b0 - -! b0 = 1.0d0 - IF (SdirkError) THEN - b0 = 0.2d-1 - ELSE - b0 = 0.5d-1 - END IF - -! The coefficients of the Radau2A method - rkMethod = R2A - - rkA(1,1) = 1.968154772236604258683861429918299d-1 - rkA(1,2) = -6.55354258501983881085227825696087d-2 - rkA(1,3) = 2.377097434822015242040823210718965d-2 - rkA(2,1) = 3.944243147390872769974116714584975d-1 - rkA(2,2) = 2.920734116652284630205027458970589d-1 - rkA(2,3) = -4.154875212599793019818600988496743d-2 - rkA(3,1) = 3.764030627004672750500754423692808d-1 - rkA(3,2) = 5.124858261884216138388134465196080d-1 - rkA(3,3) = 1.111111111111111111111111111111111d-1 - - rkB(1) = 3.764030627004672750500754423692808d-1 - rkB(2) = 5.124858261884216138388134465196080d-1 - rkB(3) = 1.111111111111111111111111111111111d-1 - - rkC(1) = 1.550510257216821901802715925294109d-1 - rkC(2) = 6.449489742783178098197284074705891d-1 - rkC(3) = 1.0d0 - - ! New solution: H* Sum B_j*f(Z_j) = Sum D_j*Z_j - rkD(1) = 0.0d0 - rkD(2) = 0.0d0 - rkD(3) = 1.0d0 - - ! Classical error estimator: - ! H* Sum (B_j-Bhat_j)*f(Z_j) = H*E(0)*f(0) + Sum E_j*Z_j - rkE(0) = 1.0d0*b0 - rkE(1) = -10.04880939982741556246032950764708d0*b0 - rkE(2) = 1.382142733160748895793662840980412d0*b0 - rkE(3) = -.3333333333333333333333333333333333d0*b0 - - ! Sdirk error estimator - rkBgam(0) = b0 - rkBgam(1) = .3764030627004672750500754423692807d0-1.558078204724922382431975370686279d0*b0 - rkBgam(2) = .8914115380582557157653087040196118d0*b0+.5124858261884216138388134465196077d0 - rkBgam(3) = -.1637777184845662566367174924883037d0-.3333333333333333333333333333333333d0*b0 - rkBgam(4) = .2748888295956773677478286035994148d0 - - ! H* Sum Bgam_j*f(Z_j) = H*Bgam(0)*f(0) + Sum Theta_j*Z_j - rkTheta(1) = -1.520677486405081647234271944611547d0-10.04880939982741556246032950764708d0*b0 - rkTheta(2) = 2.070455145596436382729929151810376d0+1.382142733160748895793662840980413d0*b0 - rkTheta(3) = -.3333333333333333333333333333333333d0*b0-.3744441479783868387391430179970741d0 - - ! Local order of error estimator - IF (b0==0.0d0) THEN - rkELO = 6.0d0 - ELSE - rkELO = 4.0d0 - END IF - - !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - !~~~> Diagonalize the RK matrix: - ! rkTinv * inv(rkA) * rkT = - ! | rkGamma 0 0 | - ! | 0 rkAlpha -rkBeta | - ! | 0 rkBeta rkAlpha | - !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - rkGamma = 3.637834252744495732208418513577775d0 - rkAlpha = 2.681082873627752133895790743211112d0 - rkBeta = 3.050430199247410569426377624787569d0 - - rkT(1,1) = 9.443876248897524148749007950641664d-2 - rkT(1,2) = -1.412552950209542084279903838077973d-1 - rkT(1,3) = -3.00291941051474244918611170890539d-2 - rkT(2,1) = 2.502131229653333113765090675125018d-1 - rkT(2,2) = 2.041293522937999319959908102983381d-1 - rkT(2,3) = 3.829421127572619377954382335998733d-1 - rkT(3,1) = 1.0d0 - rkT(3,2) = 1.0d0 - rkT(3,3) = 0.0d0 - - rkTinv(1,1) = 4.178718591551904727346462658512057d0 - rkTinv(1,2) = 3.27682820761062387082533272429617d-1 - rkTinv(1,3) = 5.233764454994495480399309159089876d-1 - rkTinv(2,1) = -4.178718591551904727346462658512057d0 - rkTinv(2,2) = -3.27682820761062387082533272429617d-1 - rkTinv(2,3) = 4.766235545005504519600690840910124d-1 - rkTinv(3,1) = -5.02872634945786875951247343139544d-1 - rkTinv(3,2) = 2.571926949855605429186785353601676d0 - rkTinv(3,3) = -5.960392048282249249688219110993024d-1 - - rkTinvAinv(1,1) = 1.520148562492775501049204957366528d+1 - rkTinvAinv(1,2) = 1.192055789400527921212348994770778d0 - rkTinvAinv(1,3) = 1.903956760517560343018332287285119d0 - rkTinvAinv(2,1) = -9.669512977505946748632625374449567d0 - rkTinvAinv(2,2) = -8.724028436822336183071773193986487d0 - rkTinvAinv(2,3) = 3.096043239482439656981667712714881d0 - rkTinvAinv(3,1) = -1.409513259499574544876303981551774d+1 - rkTinvAinv(3,2) = 5.895975725255405108079130152868952d0 - rkTinvAinv(3,3) = -1.441236197545344702389881889085515d-1 - - rkAinvT(1,1) = .3435525649691961614912493915818282d0 - rkAinvT(1,2) = -.4703191128473198422370558694426832d0 - rkAinvT(1,3) = .3503786597113668965366406634269080d0 - rkAinvT(2,1) = .9102338692094599309122768354288852d0 - rkAinvT(2,2) = 1.715425895757991796035292755937326d0 - rkAinvT(2,3) = .4040171993145015239277111187301784d0 - rkAinvT(3,1) = 3.637834252744495732208418513577775d0 - rkAinvT(3,2) = 2.681082873627752133895790743211112d0 - rkAinvT(3,3) = -3.050430199247410569426377624787569d0 - - END SUBROUTINE Radau2A_Coefficients - - - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Lobatto3C_Coefficients -! The coefficients of the 3-stage Lobatto-3C method -! (given to ~30 accurate digits) -! The parameter b0 can be chosen to tune the error estimator -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - KPP_REAL :: b0 - - rkMethod = L3C - -! b0 = 1.0d0 - IF (SdirkError) THEN - b0 = 0.2d0 - ELSE - b0 = 0.5d0 - END IF -! The coefficients of the Lobatto3C method - - rkA(1,1) = .1666666666666666666666666666666667d0 - rkA(1,2) = -.3333333333333333333333333333333333d0 - rkA(1,3) = .1666666666666666666666666666666667d0 - rkA(2,1) = .1666666666666666666666666666666667d0 - rkA(2,2) = .4166666666666666666666666666666667d0 - rkA(2,3) = -.8333333333333333333333333333333333d-1 - rkA(3,1) = .1666666666666666666666666666666667d0 - rkA(3,2) = .6666666666666666666666666666666667d0 - rkA(3,3) = .1666666666666666666666666666666667d0 - - rkB(1) = .1666666666666666666666666666666667d0 - rkB(2) = .6666666666666666666666666666666667d0 - rkB(3) = .1666666666666666666666666666666667d0 - - rkC(1) = 0.0d0 - rkC(2) = 0.5d0 - rkC(3) = 1.0d0 - - ! Classical error estimator, embedded solution: - rkBhat(0) = b0 - rkBhat(1) = .16666666666666666666666666666666667d0-b0 - rkBhat(2) = .66666666666666666666666666666666667d0 - rkBhat(3) = .16666666666666666666666666666666667d0 - - ! New solution: h Sum_j b_j f(Z_j) = sum d_j Z_j - rkD(1) = 0.0d0 - rkD(2) = 0.0d0 - rkD(3) = 1.0d0 - - ! Classical error estimator: - ! H* Sum (B_j-Bhat_j)*f(Z_j) = H*E(0)*f(0) + Sum E_j*Z_j - rkE(0) = .3808338772072650364017425226487022*b0 - rkE(1) = -1.142501631621795109205227567946107*b0 - rkE(2) = -1.523335508829060145606970090594809*b0 - rkE(3) = .3808338772072650364017425226487022*b0 - - ! Sdirk error estimator - rkBgam(0) = b0 - rkBgam(1) = .1666666666666666666666666666666667d0-1.d0*b0 - rkBgam(2) = .6666666666666666666666666666666667d0 - rkBgam(3) = -.2141672105405983697350758559820354d0 - rkBgam(4) = .3808338772072650364017425226487021d0 - - ! H* Sum Bgam_j*f(Z_j) = H*Bgam(0)*f(0) + Sum Theta_j*Z_j - rkTheta(1) = -3.d0*b0-.3808338772072650364017425226487021d0 - rkTheta(2) = -4.d0*b0+1.523335508829060145606970090594808d0 - rkTheta(3) = -.142501631621795109205227567946106d0+b0 - - ! Local order of error estimator - IF (b0==0.0d0) THEN - rkELO = 5.0d0 - ELSE - rkELO = 4.0d0 - END IF - - !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - !~~~> Diagonalize the RK matrix: - ! rkTinv * inv(rkA) * rkT = - ! | rkGamma 0 0 | - ! | 0 rkAlpha -rkBeta | - ! | 0 rkBeta rkAlpha | - !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - rkGamma = 2.625816818958466716011888933765284d0 - rkAlpha = 1.687091590520766641994055533117359d0 - rkBeta = 2.508731754924880510838743672432351d0 - - rkT(1,1) = 1.d0 - rkT(1,2) = 1.d0 - rkT(1,3) = 0.d0 - rkT(2,1) = .4554100411010284672111720348287483d0 - rkT(2,2) = -.6027050205505142336055860174143743d0 - rkT(2,3) = -.4309321229203225731070721341350346d0 - rkT(3,1) = 2.195823345445647152832799205549709d0 - rkT(3,2) = -1.097911672722823576416399602774855d0 - rkT(3,3) = .7850032632435902184104551358922130d0 - - rkTinv(1,1) = .4205559181381766909344950150991349d0 - rkTinv(1,2) = .3488903392193734304046467270632057d0 - rkTinv(1,3) = .1915253879645878102698098373933487d0 - rkTinv(2,1) = .5794440818618233090655049849008650d0 - rkTinv(2,2) = -.3488903392193734304046467270632057d0 - rkTinv(2,3) = -.1915253879645878102698098373933487d0 - rkTinv(3,1) = -.3659705575742745254721332009249516d0 - rkTinv(3,2) = -1.463882230297098101888532803699806d0 - rkTinv(3,3) = .4702733607340189781407813565524989d0 - - rkTinvAinv(1,1) = 1.104302803159744452668648155627548d0 - rkTinvAinv(1,2) = .916122120694355522658740710823143d0 - rkTinvAinv(1,3) = .5029105849749601702795812241441172d0 - rkTinvAinv(2,1) = 1.895697196840255547331351844372453d0 - rkTinvAinv(2,2) = 3.083877879305644477341259289176857d0 - rkTinvAinv(2,3) = -1.502910584974960170279581224144117d0 - rkTinvAinv(3,1) = .8362439183082935036129145574774502d0 - rkTinvAinv(3,2) = -3.344975673233174014451658229909802d0 - rkTinvAinv(3,3) = .312908409479233358005944466882642d0 - - rkAinvT(1,1) = 2.625816818958466716011888933765282d0 - rkAinvT(1,2) = 1.687091590520766641994055533117358d0 - rkAinvT(1,3) = -2.508731754924880510838743672432351d0 - rkAinvT(2,1) = 1.195823345445647152832799205549710d0 - rkAinvT(2,2) = -2.097911672722823576416399602774855d0 - rkAinvT(2,3) = .7850032632435902184104551358922130d0 - rkAinvT(3,1) = 5.765829871932827589653709477334136d0 - rkAinvT(3,2) = .1170850640335862051731452613329320d0 - rkAinvT(3,3) = 4.078738281412060947659653944216779d0 - - END SUBROUTINE Lobatto3C_Coefficients - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Gauss_Coefficients -! The coefficients of the 3-stage Gauss method -! (given to ~30 accurate digits) -! The parameter b3 can be chosen by the user -! to tune the error estimator -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - KPP_REAL :: b0 -! The coefficients of the Gauss method - - - rkMethod = GAU - -! b0 = 4.0d0 - b0 = 0.1d0 - -! The coefficients of the Gauss method - - rkA(1,1) = .1388888888888888888888888888888889d0 - rkA(1,2) = -.359766675249389034563954710966045d-1 - rkA(1,3) = .97894440153083260495800422294756d-2 - rkA(2,1) = .3002631949808645924380249472131556d0 - rkA(2,2) = .2222222222222222222222222222222222d0 - rkA(2,3) = -.224854172030868146602471694353778d-1 - rkA(3,1) = .2679883337624694517281977355483022d0 - rkA(3,2) = .4804211119693833479008399155410489d0 - rkA(3,3) = .1388888888888888888888888888888889d0 - - rkB(1) = .2777777777777777777777777777777778d0 - rkB(2) = .4444444444444444444444444444444444d0 - rkB(3) = .2777777777777777777777777777777778d0 - - rkC(1) = .1127016653792583114820734600217600d0 - rkC(2) = .5000000000000000000000000000000000d0 - rkC(3) = .8872983346207416885179265399782400d0 - - ! Classical error estimator, embedded solution: - rkBhat(0) = b0 - rkBhat(1) =-1.4788305577012361475298775666303999d0*b0 & - +.27777777777777777777777777777777778d0 - rkBhat(2) = .44444444444444444444444444444444444d0 & - +.66666666666666666666666666666666667d0*b0 - rkBhat(3) = -.18783610896543051913678910003626672d0*b0 & - +.27777777777777777777777777777777778d0 - - ! New solution: h Sum_j b_j f(Z_j) = sum d_j Z_j - rkD(1) = .1666666666666666666666666666666667d1 - rkD(2) = -.1333333333333333333333333333333333d1 - rkD(3) = .1666666666666666666666666666666667d1 - - ! Classical error estimator: - ! H* Sum (B_j-Bhat_j)*f(Z_j) = H*E(0)*f(0) + Sum E_j*Z_j - rkE(0) = .2153144231161121782447335303806954d0*b0 - rkE(1) = -2.825278112319014084275808340593191d0*b0 - rkE(2) = .2870858974881495709929780405075939d0*b0 - rkE(3) = -.4558086256248162565397206448274867d-1*b0 - - ! Sdirk error estimator - rkBgam(0) = 0.d0 - rkBgam(1) = .2373339543355109188382583162660537d0 - rkBgam(2) = .5879873931885192299409334646982414d0 - rkBgam(3) = -.4063577064014232702392531134499046d-1 - rkBgam(4) = .2153144231161121782447335303806955d0 - - ! H* Sum Bgam_j*f(Z_j) = H*Bgam(0)*f(0) + Sum Theta_j*Z_j - rkTheta(1) = -2.594040933093095272574031876464493d0 - rkTheta(2) = 1.824611539036311947589425112250199d0 - rkTheta(3) = .1856563166634371860478043996459493d0 - - ! ELO = local order of classical error estimator - rkELO = 4.0d0 - - !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - !~~~> Diagonalize the RK matrix: - ! rkTinv * inv(rkA) * rkT = - ! | rkGamma 0 0 | - ! | 0 rkAlpha -rkBeta | - ! | 0 rkBeta rkAlpha | - !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - rkGamma = 4.644370709252171185822941421408064d0 - rkAlpha = 3.677814645373914407088529289295970d0 - rkBeta = 3.508761919567443321903661209182446d0 - - rkT(1,1) = .7215185205520017032081769924397664d-1 - rkT(1,2) = -.8224123057363067064866206597516454d-1 - rkT(1,3) = -.6012073861930850173085948921439054d-1 - rkT(2,1) = .1188325787412778070708888193730294d0 - rkT(2,2) = .5306509074206139504614411373957448d-1 - rkT(2,3) = .3162050511322915732224862926182701d0 - rkT(3,1) = 1.d0 - rkT(3,2) = 1.d0 - rkT(3,3) = 0.d0 - - rkTinv(1,1) = 5.991698084937800775649580743981285d0 - rkTinv(1,2) = 1.139214295155735444567002236934009d0 - rkTinv(1,3) = .4323121137838583855696375901180497d0 - rkTinv(2,1) = -5.991698084937800775649580743981285d0 - rkTinv(2,2) = -1.139214295155735444567002236934009d0 - rkTinv(2,3) = .5676878862161416144303624098819503d0 - rkTinv(3,1) = -1.246213273586231410815571640493082d0 - rkTinv(3,2) = 2.925559646192313662599230367054972d0 - rkTinv(3,3) = -.2577352012734324923468722836888244d0 - - rkTinvAinv(1,1) = 27.82766708436744962047620566703329d0 - rkTinvAinv(1,2) = 5.290933503982655311815946575100597d0 - rkTinvAinv(1,3) = 2.007817718512643701322151051660114d0 - rkTinvAinv(2,1) = -17.66368928942422710690385180065675d0 - rkTinvAinv(2,2) = -14.45491129892587782538830044147713d0 - rkTinvAinv(2,3) = 2.992182281487356298677848948339886d0 - rkTinvAinv(3,1) = -25.60678350282974256072419392007303d0 - rkTinvAinv(3,2) = 6.762434375611708328910623303779923d0 - rkTinvAinv(3,3) = 1.043979339483109825041215970036771d0 - - rkAinvT(1,1) = .3350999483034677402618981153470483d0 - rkAinvT(1,2) = -.5134173605009692329246186488441294d0 - rkAinvT(1,3) = .6745196507033116204327635673208923d-1 - rkAinvT(2,1) = .5519025480108928886873752035738885d0 - rkAinvT(2,2) = 1.304651810077110066076640761092008d0 - rkAinvT(2,3) = .9767507983414134987545585703726984d0 - rkAinvT(3,1) = 4.644370709252171185822941421408064d0 - rkAinvT(3,2) = 3.677814645373914407088529289295970d0 - rkAinvT(3,3) = -3.508761919567443321903661209182446d0 - - END SUBROUTINE Gauss_Coefficients - - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Radau1A_Coefficients -! The coefficients of the 3-stage Gauss method -! (given to ~30 accurate digits) -! The parameter b3 can be chosen by the user -! to tune the error estimator -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE -! KPP_REAL :: b0 = 0.3d0 - KPP_REAL :: b0 = 0.1d0 - -! The coefficients of the Radau1A method - - rkMethod = R1A - - rkA(1,1) = .1111111111111111111111111111111111d0 - rkA(1,2) = -.1916383190435098943442935597058829d0 - rkA(1,3) = .8052720793239878323318244859477174d-1 - rkA(2,1) = .1111111111111111111111111111111111d0 - rkA(2,2) = .2920734116652284630205027458970589d0 - rkA(2,3) = -.481334970546573839513422644787591d-1 - rkA(3,1) = .1111111111111111111111111111111111d0 - rkA(3,2) = .5370223859435462728402311533676479d0 - rkA(3,3) = .1968154772236604258683861429918299d0 - - rkB(1) = .1111111111111111111111111111111111d0 - rkB(2) = .5124858261884216138388134465196080d0 - rkB(3) = .3764030627004672750500754423692808d0 - - rkC(1) = 0.d0 - rkC(2) = .3550510257216821901802715925294109d0 - rkC(3) = .8449489742783178098197284074705891d0 - - ! Classical error estimator, embedded solution: - rkBhat(0) = b0 - rkBhat(1) = .11111111111111111111111111111111111d0-b0 - rkBhat(2) = .51248582618842161383881344651960810d0 - rkBhat(3) = .37640306270046727505007544236928079d0 - - ! New solution: H* Sum B_j*f(Z_j) = Sum D_j*Z_j - rkD(1) = .3333333333333333333333333333333333d0 - rkD(2) = -.8914115380582557157653087040196127d0 - rkD(3) = .1558078204724922382431975370686279d1 - - ! Classical error estimator: - ! H* Sum (b_j-bhat_j) f(Z_j) = H*E(0)*F(0) + Sum E_j Z_j - rkE(0) = .2748888295956773677478286035994148d0*b0 - rkE(1) = -1.374444147978386838739143017997074d0*b0 - rkE(2) = -1.335337922441686804550326197041126d0*b0 - rkE(3) = .235782604058977333559011782643466d0*b0 - - ! Sdirk error estimator - rkBgam(0) = 0.0d0 - rkBgam(1) = .1948150124588532186183490991130616d-1 - rkBgam(2) = .7575249005733381398986810981093584d0 - rkBgam(3) = -.518952314149008295083446116200793d-1 - rkBgam(4) = .2748888295956773677478286035994148d0 - - ! H* Sum Bgam_j*f(Z_j) = H*Bgam(0)*f(0) + Sum Theta_j*Z_j - rkTheta(1) = -1.224370034375505083904362087063351d0 - rkTheta(2) = .9340045331532641409047527962010133d0 - rkTheta(3) = .4656990124352088397561234800640929d0 - - ! ELO = local order of classical error estimator - rkELO = 4.0d0 - - !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - !~~~> Diagonalize the RK matrix: - ! rkTinv * inv(rkA) * rkT = - ! | rkGamma 0 0 | - ! | 0 rkAlpha -rkBeta | - ! | 0 rkBeta rkAlpha | - !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - rkGamma = 3.637834252744495732208418513577775d0 - rkAlpha = 2.681082873627752133895790743211112d0 - rkBeta = 3.050430199247410569426377624787569d0 - - rkT(1,1) = .424293819848497965354371036408369d0 - rkT(1,2) = -.3235571519651980681202894497035503d0 - rkT(1,3) = -.522137786846287839586599927945048d0 - rkT(2,1) = .57594609499806128896291585429339d-1 - rkT(2,2) = .3148663231849760131614374283783d-2 - rkT(2,3) = .452429247674359778577728510381731d0 - rkT(3,1) = 1.d0 - rkT(3,2) = 1.d0 - rkT(3,3) = 0.d0 - - rkTinv(1,1) = 1.233523612685027760114769983066164d0 - rkTinv(1,2) = 1.423580134265707095505388133369554d0 - rkTinv(1,3) = .3946330125758354736049045150429624d0 - rkTinv(2,1) = -1.233523612685027760114769983066164d0 - rkTinv(2,2) = -1.423580134265707095505388133369554d0 - rkTinv(2,3) = .6053669874241645263950954849570376d0 - rkTinv(3,1) = -.1484438963257383124456490049673414d0 - rkTinv(3,2) = 2.038974794939896109682070471785315d0 - rkTinv(3,3) = -.544501292892686735299355831692542d-1 - - rkTinvAinv(1,1) = 4.487354449794728738538663081025420d0 - rkTinvAinv(1,2) = 5.178748573958397475446442544234494d0 - rkTinvAinv(1,3) = 1.435609490412123627047824222335563d0 - rkTinvAinv(2,1) = -2.854361287939276673073807031221493d0 - rkTinvAinv(2,2) = -1.003648660720543859000994063139137d+1 - rkTinvAinv(2,3) = 1.789135380979465422050817815017383d0 - rkTinvAinv(3,1) = -4.160768067752685525282947313530352d0 - rkTinvAinv(3,2) = 1.124128569859216916690209918405860d0 - rkTinvAinv(3,3) = 1.700644430961823796581896350418417d0 - - rkAinvT(1,1) = 1.543510591072668287198054583233180d0 - rkAinvT(1,2) = -2.460228411937788329157493833295004d0 - rkAinvT(1,3) = -.412906170450356277003910443520499d0 - rkAinvT(2,1) = .209519643211838264029272585946993d0 - rkAinvT(2,2) = 1.388545667194387164417459732995766d0 - rkAinvT(2,3) = 1.20339553005832004974976023130002d0 - rkAinvT(3,1) = 3.637834252744495732208418513577775d0 - rkAinvT(3,2) = 2.681082873627752133895790743211112d0 - rkAinvT(3,3) = -3.050430199247410569426377624787569d0 - - END SUBROUTINE Radau1A_Coefficients - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Lobatto3A_Coefficients -! The coefficients of the 4-stage Lobatto-3A method -! (given to ~30 accurate digits) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - -! The coefficients of the Lobatto-3A method - - rkMethod = L3A - - rkA(0,0) = 0.0d0 - rkA(0,1) = 0.0d0 - rkA(0,2) = 0.0d0 - rkA(0,3) = 0.0d0 - rkA(1,0) = .11030056647916491413674311390609397d0 - rkA(1,1) = .1896994335208350858632568860939060d0 - rkA(1,2) = -.339073642291438837776604807792215d-1 - rkA(1,3) = .1030056647916491413674311390609397d-1 - rkA(2,0) = .73032766854168419196590219427239365d-1 - rkA(2,1) = .4505740308958105504443271474458881d0 - rkA(2,2) = .2269672331458315808034097805727606d0 - rkA(2,3) = -.2696723314583158080340978057276063d-1 - rkA(3,0) = .83333333333333333333333333333333333d-1 - rkA(3,1) = .4166666666666666666666666666666667d0 - rkA(3,2) = .4166666666666666666666666666666667d0 - rkA(3,3) = .8333333333333333333333333333333333d-1 - - rkB(0) = .83333333333333333333333333333333333d-1 - rkB(1) = .4166666666666666666666666666666667d0 - rkB(2) = .4166666666666666666666666666666667d0 - rkB(3) = .8333333333333333333333333333333333d-1 - - rkC(0) = 0.0d0 - rkC(1) = .2763932022500210303590826331268724d0 - rkC(2) = .7236067977499789696409173668731276d0 - rkC(3) = 1.0d0 - - ! New solution: H*Sum B_j*f(Z_j) = Sum D_j*Z_j - rkD(0) = 0.0d0 - rkD(1) = 0.0d0 - rkD(2) = 0.0d0 - rkD(3) = 1.0d0 - - ! Classical error estimator, embedded solution: - rkBhat(0) = .90909090909090909090909090909090909d-1 - rkBhat(1) = .39972675774621371442114262372173276d0 - rkBhat(2) = .43360657558711961891219070961160058d0 - rkBhat(3) = .15151515151515151515151515151515152d-1 - - ! Classical error estimator: - ! H* Sum (B_j-Bhat_j)*f(Z_j) = H*E(0)*f(0) + Sum E_j*Z_j - - rkE(0) = .1957403846510110711315759367097231d-1 - rkE(1) = -.1986820345632580910316020806676438d0 - rkE(2) = .1660586371214229125096727578826900d0 - rkE(3) = -.9787019232550553556578796835486154d-1 - - ! Sdirk error estimator: - rkF(0) = 0.0d0 - rkF(1) = -.66535815876916686607437314126436349d0 - rkF(2) = 1.7419302743497277572980407931678409d0 - rkF(3) = -1.2918865386966730694684011822841728d0 - - ! ELO = local order of classical error estimator - rkELO = 4.0d0 - - ! Sdirk error estimator: - rkBgam(0) = .2950472755430528877214995073815946d-1 - rkBgam(1) = .5370310883226113978352873633882769d0 - rkBgam(2) = .2963022450107219354980459699450564d0 - rkBgam(3) = -.7815248400375080035021681445218837d-1 - rkBgam(4) = .2153144231161121782447335303806956d0 - - ! H* Sum Bgam_j*f(Z_j) = H*Bgam(0)*f(0) + Sum Theta_j*Z_j - rkTheta(0) = 0.0d0 - rkTheta(1) = -.6653581587691668660743731412643631d0 - rkTheta(2) = 1.741930274349727757298040793167842d0 - rkTheta(3) = -.291886538696673069468401182284174d0 - - - !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - !~~~> Diagonalize the RK matrix: - ! rkTinv * inv(rkA) * rkT = - ! | rkGamma 0 0 | - ! | 0 rkAlpha -rkBeta | - ! | 0 rkBeta rkAlpha | - !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - rkGamma = 4.644370709252171185822941421408063d0 - rkAlpha = 3.677814645373914407088529289295968d0 - rkBeta = 3.508761919567443321903661209182446d0 - - rkT(1,1) = .5303036326129938105898786144870856d-1 - rkT(1,2) = -.7776129960563076320631956091016914d-1 - rkT(1,3) = .6043307469475508514468017399717112d-2 - rkT(2,1) = .2637242522173698467283726114649606d0 - rkT(2,2) = .2193839918662961493126393244533346d0 - rkT(2,3) = .3198765142300936188514264752235344d0 - rkT(3,1) = 1.d0 - rkT(3,2) = 1.d0 - rkT(3,3) = 0.d0 - - rkTinv(1,1) = 7.695032983257654470769069079238553d0 - rkTinv(1,2) = -.1453793830957233720334601186354032d0 - rkTinv(1,3) = .6302696746849084900422461036874826d0 - rkTinv(2,1) = -7.695032983257654470769069079238553d0 - rkTinv(2,2) = .1453793830957233720334601186354032d0 - rkTinv(2,3) = .3697303253150915099577538963125174d0 - rkTinv(3,1) = -1.066660885401270392058552736086173d0 - rkTinv(3,2) = 3.146358406832537460764521760668932d0 - rkTinv(3,3) = -.7732056038202974770406168510664738d0 - - rkTinvAinv(1,1) = 35.73858579417120341641749040405149d0 - rkTinvAinv(1,2) = -.675195748578927863668368190236025d0 - rkTinvAinv(1,3) = 2.927206016036483646751158874041632d0 - rkTinvAinv(2,1) = -24.55824590667225493437162206039511d0 - rkTinvAinv(2,2) = -10.50514413892002061837750015342036 - rkTinvAinv(2,3) = 4.072793983963516353248841125958369d0 - rkTinvAinv(3,1) = -30.92301972744621647251975054630589d0 - rkTinvAinv(3,2) = 12.08182467154052413351908559269928d0 - rkTinvAinv(3,3) = -1.546411207640594954081233702132946d0 - - rkAinvT(1,1) = .2462926658317812882584158369803835d0 - rkAinvT(1,2) = -.2647871194157644619747121197289574d0 - rkAinvT(1,3) = .2950720515900466654896406799284586d0 - rkAinvT(2,1) = 1.224833192317784474576995878738004d0 - rkAinvT(2,2) = 1.929224190340981580557006261869763d0 - rkAinvT(2,3) = .4066803323234419988910915619080306d0 - rkAinvT(3,1) = 4.644370709252171185822941421408064d0 - rkAinvT(3,2) = 3.677814645373914407088529289295968d0 - rkAinvT(3,3) = -3.508761919567443321903661209182446d0 - - END SUBROUTINE Lobatto3A_Coefficients - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - END SUBROUTINE RungeKutta ! and all its internal procedures -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE FUN_CHEM(T, V, FCT) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - USE KPP_ROOT_Parameters - USE KPP_ROOT_Global - USE KPP_ROOT_Function, ONLY: Fun - USE KPP_ROOT_Rates, ONLY: Update_SUN, Update_RCONST, Update_PHOTO - - IMPLICIT NONE - - KPP_REAL :: V(NVAR), FCT(NVAR) - KPP_REAL :: T, Told - - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Update_PHOTO() - TIME = Told - - CALL Fun(V, FIX, RCONST, FCT) - - END SUBROUTINE FUN_CHEM - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE JAC_CHEM (T, V, JF) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - USE KPP_ROOT_Parameters - USE KPP_ROOT_Global - USE KPP_ROOT_JacobianSP - USE KPP_ROOT_Jacobian, ONLY: Jac_SP - USE KPP_ROOT_Rates, ONLY: Update_SUN, Update_RCONST, Update_PHOTO - - IMPLICIT NONE - - KPP_REAL :: V(NVAR), T , Told -#ifdef FULL_ALGEBRA - KPP_REAL :: JV(LU_NONZERO), JF(NVAR,NVAR) - INTEGER :: i, j -#else - KPP_REAL :: JF(LU_NONZERO) -#endif - - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Update_PHOTO() - TIME = Told - -#ifdef FULL_ALGEBRA - CALL Jac_SP(V, FIX, RCONST, JV) - DO j=1,NVAR - DO i=1,NVAR - JF(i,j) = 0.0d0 - END DO - END DO - DO i=1,LU_NONZERO - JF(LU_IROW(i),LU_ICOL(i)) = JV(i) - END DO -#else - CALL Jac_SP(V, FIX, RCONST, JF) -#endif - - END SUBROUTINE JAC_CHEM - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -END MODULE KPP_ROOT_Integrator - - diff --git a/boxmox/int.modified_WCOPY/runge_kutta_adj.f90 b/boxmox/int.modified_WCOPY/runge_kutta_adj.f90 deleted file mode 100644 index dca6fd1ddb296e950524bd7d45bcc37f2728c4f6..0000000000000000000000000000000000000000 --- a/boxmox/int.modified_WCOPY/runge_kutta_adj.f90 +++ /dev/null @@ -1,2687 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! -! RungeKuttaADJ - Adjoint Model of Fully Implicit 3-stage Runge-Kutta: ! -! * Radau-2A quadrature (order 5) ! -! * Radau-1A quadrature (order 5) ! -! * Lobatto-3C quadrature (order 4) ! -! * Gauss quadrature (order 6) ! -! By default the code employs the KPP sparse linear algebra routines ! -! Compile with -DFULL_ALGEBRA to use full linear algebra (LAPACK) ! -! ! -! (C) Adrian Sandu, August 2005 ! -! Virginia Polytechnic Institute and State University ! -! Contact: sandu@cs.vt.edu ! -! Revised by Philipp Miehe and Adrian Sandu, May 2006 ! -! This implementation is part of KPP - the Kinetic PreProcessor ! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! - -MODULE KPP_ROOT_Integrator - - USE KPP_ROOT_Precision - USE KPP_ROOT_Parameters, ONLY: NVAR, NSPEC, NFIX, LU_NONZERO - USE KPP_ROOT_Global, ONLY: FIX, RCONST, TIME - USE KPP_ROOT_Jacobian - USE KPP_ROOT_LinearAlgebra - - IMPLICIT NONE - PUBLIC - SAVE - -!~~~> Statistics on the work performed by the Runge-Kutta method - INTEGER :: Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng - INTEGER, PARAMETER :: ifun=1, ijac=2, istp=3, iacc=4, & - irej=5, idec=6, isol=7, isng=8, itexit=1, ihacc=2, ihnew=3 - -CONTAINS - - ! ************************************************************************** - - SUBROUTINE INTEGRATE_ADJ(NADJ, Y, Lambda, TIN, TOUT, & - ATOL_adj, RTOL_adj, & - ICNTRL_U, RCNTRL_U, ISTATUS_U, RSTATUS_U, IERR_U ) - - USE KPP_ROOT_Parameters, ONLY: NVAR - USE KPP_ROOT_Global, ONLY: ATOL,RTOL - - IMPLICIT NONE - -!~~~> Y - Concentrations - KPP_REAL :: Y(NVAR) -!~~~> NADJ - No. of cost functionals for which adjoints -! are evaluated simultaneously -! If single cost functional is considered (like in -! most applications) simply set NADJ = 1 - INTEGER NADJ -!~~~> Lambda - Sensitivities of concentrations -! Note: Lambda (1:NVAR,j) contains sensitivities of -! the j-th cost functional w.r.t. Y(1:NVAR), j=1...NADJ - KPP_REAL :: Lambda(NVAR,NADJ) -!~~~> Tolerances for adjoint calculations -! (used for full continuous adjoint, and for controlling -! the convergence of iterations for solving the discrete adjoint) - KPP_REAL, INTENT(IN) :: ATOL_adj(NVAR,NADJ), RTOL_adj(NVAR,NADJ) - KPP_REAL :: TIN ! TIN - Start Time - KPP_REAL :: TOUT ! TOUT - End Time - INTEGER, INTENT(IN), OPTIONAL :: ICNTRL_U(20) - KPP_REAL, INTENT(IN), OPTIONAL :: RCNTRL_U(20) - INTEGER, INTENT(OUT), OPTIONAL :: ISTATUS_U(20) - KPP_REAL, INTENT(OUT), OPTIONAL :: RSTATUS_U(20) - INTEGER, INTENT(OUT), OPTIONAL :: IERR_U - - INTEGER :: IERR - - KPP_REAL :: RCNTRL(20), RSTATUS(20), T1, T2 - INTEGER :: ICNTRL(20), ISTATUS(20) - INTEGER, SAVE :: Ntotal = 0 - - - ICNTRL(1:20) = 0 - RCNTRL(1:20) = 0.0_dp - - !~~~> fine-tune the integrator: - ICNTRL(2) = 0 ! 0=vector tolerances, 1=scalar tolerances - ICNTRL(5) = 8 ! Max no. of Newton iterations - ICNTRL(6) = 0 ! Starting values for Newton are: 0=interpolated, 1=zero - ICNTRL(7) = 2 ! Adj. system solved by: 1=iteration, 2=direct, 3=adaptive - ICNTRL(8) = 0 ! Adj. LU decomp: 0=compute, 1=save from fwd - ICNTRL(9) = 2 ! Adjoint: 1=none, 2=discrete, 3=full continuous, 4=simplified continuous - ICNTRL(10) = 0 ! Error estimator: 0=classic, 1=SDIRK - ICNTRL(11) = 1 ! Step controller: 1=Gustaffson, 2=classic - - - !~~~> if optional parameters are given, and if they are >0, - ! then use them to overwrite default settings - IF (PRESENT(ICNTRL_U)) THEN - WHERE(ICNTRL_U(:) > 0) ICNTRL(:) = ICNTRL_U(:) - END IF - IF (PRESENT(RCNTRL_U)) THEN - WHERE(RCNTRL_U(:) > 0) RCNTRL(:) = RCNTRL_U(:) - END IF - - - T1 = TIN; T2 = TOUT - CALL RungeKuttaADJ(NVAR, Y, NADJ, Lambda, T1, T2, & - RTOL, ATOL, ATOL_adj, RTOL_adj, & - RCNTRL, ICNTRL, RSTATUS, ISTATUS, IERR ) - - Ntotal = Ntotal + ISTATUS(istp) -! PRINT*,'NSTEPS=',ISTATUS(istp),' (',Ntotal,')',' O3=', VAR(ind_O3) - - ! if optional parameters are given for output - ! use them to store information in them - IF (PRESENT(ISTATUS_U)) ISTATUS_U(:) = ISTATUS(:) - IF (PRESENT(RSTATUS_U)) RSTATUS_U(:) = RSTATUS(:) - IF (PRESENT(IERR_U)) IERR_U = IERR - - IF (IERR < 0) THEN - PRINT *,'Runge-Kutta-ADJ: Unsuccessful exit at T=', TIN,' (IERR=',IERR,')' - ENDIF - - END SUBROUTINE INTEGRATE_ADJ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE RungeKuttaADJ( N, Y, NADJ, Lambda,Tstart,Tend, & - RelTol, AbsTol, RelTol_adj, AbsTol_adj, & - RCNTRL, ICNTRL, RSTATUS, ISTATUS, IERR ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -! This implementation is based on the book and the code Radau5: -! -! E. HAIRER AND G. WANNER -! "SOLVING ORDINARY DIFFERENTIAL EQUATIONS II. -! STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS." -! SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS 14, -! SPRINGER-VERLAG (1991) -! -! UNIVERSITE DE GENEVE, DEPT. DE MATHEMATIQUES -! CH-1211 GENEVE 24, SWITZERLAND -! E-MAIL: HAIRER@DIVSUN.UNIGE.CH, WANNER@DIVSUN.UNIGE.CH -! -! Methods: -! * Radau-2A quadrature (order 5) -! * Radau-1A quadrature (order 5) -! * Lobatto-3C quadrature (order 4) -! * Gauss quadrature (order 6) -! -! (C) Adrian Sandu, August 2005 -! Virginia Polytechnic Institute and State University -! Contact: sandu@cs.vt.edu -! Revised by Philipp Miehe and Adrian Sandu, May 2006 -! This implementation is part of KPP - the Kinetic PreProcessor -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!~~~> INPUT ARGUMENTS: -! ---------------- -! -! Note: For input parameters equal to zero the default values of the -! corresponding variables are used. -! -! N Dimension of the system -! T Initial time value -! -! Tend Final T value (Tend-T may be positive or negative) -! -! Y(N) Initial values for Y -! -! RelTol,AbsTol Relative and absolute error tolerances. -! for ICNTRL(2) = 0: AbsTol, RelTol are N-dimensional vectors -! = 1: AbsTol, RelTol are scalars -! -!~~~> Integer input parameters: -! -! ICNTRL(1) = not used -! -! ICNTRL(2) = 0: AbsTol, RelTol are NVAR-dimensional vectors -! = 1: AbsTol, RelTol are scalars -! -! ICNTRL(3) = RK method selection -! = 1: Radau-2A (the default) -! = 2: Lobatto-3C -! = 3: Gauss -! = 4: Radau-1A -! -! ICNTRL(4) -> maximum number of integration steps -! For ICNTRL(4)=0 the default value of 10000 is used -! -! ICNTRL(5) -> maximum number of Newton iterations -! For ICNTRL(5)=0 the default value of 8 is used -! -! ICNTRL(6) -> starting values of Newton iterations: -! ICNTRL(6)=0 : starting values are obtained from -! the extrapolated collocation solution -! (the default) -! ICNTRL(6)=1 : starting values are zero -! -! ICNTRL(7) -> method to solve the linear ADJ equations: -! ICNTRL(7)=0,1 : modified Newton re-using LU (the default) -! with a fixed number of iterations -! ICNTRL(7)=2 : direct solution (additional one LU factorization -! of 3Nx3N matrix per step); good for debugging -! ICNTRL(7)=3 : adaptive solution (if Newton does not converge -! switch to direct) -! -! ICNTRL(8) -> checkpointing the LU factorization at each step: -! ICNTRL(8)=0 : do *not* save LU factorization (the default) -! ICNTRL(8)=1 : save LU factorization -! Note: if ICNTRL(7)=1 the LU factorization is *not* saved -! -! ICNTRL(9) -> Type of adjoint algorithm -! = 0 : default is discrete adjoint ( of method ICNTRL(3) ) -! = 1 : no adjoint -! = 2 : discrete adjoint ( of method ICNTRL(3) ) -! = 3 : fully adaptive continuous adjoint ( with method ICNTRL(6) ) -! = 4 : simplified continuous adjoint ( with method ICNTRL(6) ) -! -! ICNTRL(10) -> switch for error estimation strategy -! ICNTRL(10) = 0: one additional stage at c=0, -! see Hairer (default) -! ICNTRL(10) = 1: two additional stages at c=0 -! and SDIRK at c=1, stiffly accurate -! -! ICNTRL(11) -> switch for step size strategy -! ICNTRL(11)=1: mod. predictive controller (Gustafsson, default) -! ICNTRL(11)=2: classical step size control -! the choice 1 seems to produce safer results; -! for simple problems, the choice 2 produces -! often slightly faster runs -! -!~~~> Real input parameters: -! -! RCNTRL(1) -> Hmin, lower bound for the integration step size -! (highly recommended to keep Hmin = ZERO, the default) -! -! RCNTRL(2) -> Hmax, upper bound for the integration step size -! -! RCNTRL(3) -> Hstart, the starting step size -! -! RCNTRL(4) -> FacMin, lower bound on step decrease factor (default=0.2) -! -! RCNTRL(5) -> FacMax, upper bound on step increase factor (default=6) -! -! RCNTRL(6) -> FacRej, step decrease factor after multiple rejections -! (default=0.1) -! -! RCNTRL(7) -> FacSafe, by which the new step is slightly smaller -! than the predicted value (default=0.9) -! -! RCNTRL(8) -> ThetaMin. If Newton convergence rate smaller -! than ThetaMin the Jacobian is not recomputed; -! (default=0.001) -! -! RCNTRL(9) -> NewtonTol, stopping criterion for Newton's method -! (default=0.03) -! -! RCNTRL(10) -> Qmin -! -! RCNTRL(11) -> Qmax. If Qmin < Hnew/Hold < Qmax, then the -! step size is kept constant and the LU factorization -! reused (default Qmin=1, Qmax=1.2) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -! -! OUTPUT ARGUMENTS: -! ----------------- -! -! T -> T value for which the solution has been computed -! (after successful return T=Tend). -! -! Y(N) -> Numerical solution at T -! -! IERR -> Reports on successfulness upon return: -! = 1 for success -! < 0 for error (value equals error code) -! -! ISTATUS(1) -> No. of function calls -! ISTATUS(2) -> No. of Jacobian calls -! ISTATUS(3) -> No. of steps -! ISTATUS(4) -> No. of accepted steps -! ISTATUS(5) -> No. of rejected steps (except at very beginning) -! ISTATUS(6) -> No. of LU decompositions -! ISTATUS(7) -> No. of forward/backward substitutions -! ISTATUS(8) -> No. of singular matrix decompositions -! -! RSTATUS(1) -> Texit, the time corresponding to the -! computed Y upon return -! RSTATUS(2) -> Hexit, last accepted step before exit -! RSTATUS(3) -> Hnew, last predicted step (not yet taken) -! For multiple restarts, use Hnew as Hstart -! in the subsequent run -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - - INTEGER :: N - INTEGER, INTENT(IN) :: NADJ - KPP_REAL, INTENT(INOUT) :: Lambda(N,NADJ) - KPP_REAL, INTENT(IN) :: AbsTol_adj(N,NADJ), RelTol_adj(N,NADJ) - KPP_REAL :: Y(N),AbsTol(N),RelTol(N),RCNTRL(20),RSTATUS(20) - INTEGER :: ICNTRL(20), ISTATUS(20) - LOGICAL :: StartNewton, Gustafsson, SdirkError, SaveLU - INTEGER :: IERR, ITOL - KPP_REAL, INTENT(IN):: Tstart,Tend - KPP_REAL :: Texit - - !~~~> Control arguments - INTEGER :: Max_no_steps, NewtonMaxit, AdjointType, rkMethod - KPP_REAL :: Hmin,Hmax,Hstart,Qmin,Qmax - KPP_REAL :: Roundoff, ThetaMin, NewtonTol - KPP_REAL :: FacSafe,FacMin,FacMax,FacRej - ! Runge-Kutta method parameters - INTEGER, PARAMETER :: R2A=1, R1A=2, L3C=3, GAU=4, L3A=5 - KPP_REAL :: rkT(3,3), rkTinv(3,3), rkTinvAinv(3,3), rkAinvT(3,3), & - rkA(3,3), rkB(3), rkC(3), rkD(0:3), rkE(0:3), & - rkBgam(0:4), rkBhat(0:4), rkTheta(0:3), & - rkGamma, rkAlpha, rkBeta, rkELO - ! ADJ method parameters - INTEGER, PARAMETER :: KPP_ROOT_none = 1, KPP_ROOT_discrete = 2, & - KPP_ROOT_continuous = 3, KPP_ROOT_simple_continuous = 4 - INTEGER :: AdjointSolve - INTEGER, PARAMETER :: Solve_direct = 1, Solve_fixed = 2, & - Solve_adaptive = 3 - INTEGER, PARAMETER :: bufsize = 10000 - INTEGER :: stack_ptr = 0 ! last written entry - KPP_REAL, DIMENSION(:), POINTER :: chk_H, chk_T - KPP_REAL, DIMENSION(:,:), POINTER :: chk_Y, chk_Z, chk_E1 - INTEGER, DIMENSION(:), POINTER :: chk_NiT - COMPLEX(kind=dp), DIMENSION(:,:), POINTER :: chk_E2 - KPP_REAL, DIMENSION(:,:), POINTER :: chk_dY, chk_d2Y - !~~~> Local variables - INTEGER :: i - KPP_REAL, PARAMETER :: ZERO = 0.0d0, ONE = 1.0d0 - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! SETTING THE PARAMETERS -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IERR = 0 - ISTATUS(1:20) = 0 - RSTATUS(1:20) = ZERO - -!~~~> ICNTRL(1) - autonomous system - not used -!~~~> ITOL: 1 for vector and 0 for scalar AbsTol/RelTol - IF (ICNTRL(2) == 0) THEN - ITOL = 1 - ELSE - ITOL = 0 - END IF -!~~~> Error control selection - IF (ICNTRL(10) == 0) THEN - SdirkError = .FALSE. - ELSE - SdirkError = .TRUE. - END IF -!~~~> Method selection - SELECT CASE (ICNTRL(3)) - CASE (0,1) - CALL Radau2A_Coefficients - CASE (2) - CALL Lobatto3C_Coefficients - CASE (3) - CALL Gauss_Coefficients - CASE (4) - CALL Radau1A_Coefficients - CASE DEFAULT - WRITE(6,*) 'ICNTRL(3)=',ICNTRL(3) - CALL RK_ErrorMsg(-13,Tstart,ZERO,IERR) - END SELECT -!~~~> Max_no_steps: the maximal number of time steps - IF (ICNTRL(4) == 0) THEN - Max_no_steps = 200000 - ELSE - Max_no_steps=ICNTRL(4) - IF (Max_no_steps <= 0) THEN - WRITE(6,*) 'ICNTRL(4)=',ICNTRL(4) - CALL RK_ErrorMsg(-1,Tstart,ZERO,IERR) - END IF - END IF -!~~~> NewtonMaxit maximal number of Newton iterations - IF (ICNTRL(5) == 0) THEN - NewtonMaxit = 8 - ELSE - NewtonMaxit=ICNTRL(5) - IF (NewtonMaxit <= 0) THEN - WRITE(6,*) 'ICNTRL(5)=',ICNTRL(5) - CALL RK_ErrorMsg(-2,Tstart,ZERO,IERR) - END IF - END IF -!~~~> StartNewton: Use extrapolation for starting values of Newton iterations - IF (ICNTRL(6) == 0) THEN - StartNewton = .TRUE. - ELSE - StartNewton = .FALSE. - END IF -!~~~> How to solve the linear adjoint system - SELECT CASE (ICNTRL(7)) - CASE (0,1) - AdjointSolve = Solve_fixed - CASE (2) - AdjointSolve = Solve_direct - CASE (3) - AdjointSolve = Solve_adaptive - CASE DEFAULT - PRINT * , 'User-selected adjoint solution: ICNTRL(7)=', ICNTRL(7) - PRINT * , 'Implemented: =(0,1) (fixed), =2 (direct), =3 (adaptive)' - CALL rk_ErrorMsg(-9,Tstart,ZERO,IERR) - RETURN - END SELECT -!~~~> Discrete or continuous adjoint formulation - SELECT CASE (ICNTRL(9)) - CASE (0,2) - AdjointType = KPP_ROOT_discrete - CASE (1) - AdjointType = KPP_ROOT_none - CASE DEFAULT - PRINT * , 'User-selected adjoint type: ICNTRL(9)=', ICNTRL(9) - PRINT * , 'Implemented: =(0,2) (discrete adj) and =1 (no adj)' - CALL rk_ErrorMsg(-9,Tstart,ZERO,IERR) - RETURN - END SELECT -!~~~> Save or not the forward LU factorization - SaveLU = (ICNTRL(8) /= 0) - IF (AdjointSolve == Solve_direct) SaveLU = .FALSE. -!~~~> Gustafsson: step size controller - IF (ICNTRL(11) == 0) THEN - Gustafsson = .TRUE. - ELSE - Gustafsson = .FALSE. - END IF - -!~~~> Roundoff: smallest number s.t. 1.0 + Roundoff > 1.0 - Roundoff = WLAMCH('E'); - -!~~~> Hmin = minimal step size - IF (RCNTRL(1) == ZERO) THEN - Hmin = ZERO - ELSE - Hmin = MIN(ABS(RCNTRL(1)),ABS(Tend-Tstart)) - END IF -!~~~> Hmax = maximal step size - IF (RCNTRL(2) == ZERO) THEN - Hmax = ABS(Tend-Tstart) - ELSE - Hmax = MIN(ABS(RCNTRL(2)),ABS(Tend-Tstart)) - END IF -!~~~> Hstart = starting step size - IF (RCNTRL(3) == ZERO) THEN - Hstart = ZERO - ELSE - Hstart = MIN(ABS(RCNTRL(3)),ABS(Tend-Tstart)) - END IF -!~~~> FacMin: lower bound on step decrease factor - IF(RCNTRL(4) == ZERO)THEN - FacMin = 0.2d0 - ELSE - FacMin = RCNTRL(4) - END IF -!~~~> FacMax: upper bound on step increase factor - IF(RCNTRL(5) == ZERO)THEN - FacMax = 8.D0 - ELSE - FacMax = RCNTRL(5) - END IF -!~~~> FacRej: step decrease factor after 2 consecutive rejections - IF(RCNTRL(6) == ZERO)THEN - FacRej = 0.1d0 - ELSE - FacRej = RCNTRL(6) - END IF -!~~~> FacSafe: by which the new step is slightly smaller -! than the predicted value - IF (RCNTRL(7) == ZERO) THEN - FacSafe=0.9d0 - ELSE - FacSafe=RCNTRL(7) - END IF - IF ( (FacMax < ONE) .OR. (FacMin > ONE) .OR. & - (FacSafe <= 1.0d-3) .OR. (FacSafe >= ONE) ) THEN - WRITE(6,*)'RCNTRL(4:7)=',RCNTRL(4:7) - CALL RK_ErrorMsg(-4,Tstart,ZERO,IERR) - END IF - -!~~~> ThetaMin: decides whether the Jacobian should be recomputed - IF (RCNTRL(8) == ZERO) THEN - ThetaMin = 1.0d-3 - ELSE - ThetaMin=RCNTRL(8) - IF (ThetaMin <= 0.0d0 .OR. ThetaMin >= 1.0d0) THEN - WRITE(6,*) 'RCNTRL(8)=', RCNTRL(8) - CALL RK_ErrorMsg(-5,Tstart,ZERO,IERR) - END IF - END IF -!~~~> NewtonTol: stopping crierion for Newton's method - IF (RCNTRL(9) == ZERO) THEN - NewtonTol = 3.0d-2 - ELSE - NewtonTol = RCNTRL(9) - IF (NewtonTol <= Roundoff) THEN - WRITE(6,*) 'RCNTRL(9)=',RCNTRL(9) - CALL RK_ErrorMsg(-6,Tstart,ZERO,IERR) - END IF - END IF -!~~~> Qmin AND Qmax: IF Qmin < Hnew/Hold < Qmax then step size = const. - IF (RCNTRL(10) == ZERO) THEN - Qmin=1.D0 - ELSE - Qmin=RCNTRL(10) - END IF - IF (RCNTRL(11) == ZERO) THEN - Qmax=1.2D0 - ELSE - Qmax=RCNTRL(11) - END IF - IF (Qmin > ONE .OR. Qmax < ONE) THEN - WRITE(6,*) 'RCNTRL(10:11)=',Qmin,Qmax - CALL RK_ErrorMsg(-7,Tstart,ZERO,IERR) - END IF -!~~~> Check if tolerances are reasonable - IF (ITOL == 0) THEN - IF (AbsTol(1) <= ZERO.OR.RelTol(1) <= 10.d0*Roundoff) THEN - WRITE (6,*) 'AbsTol/RelTol=',AbsTol,RelTol - CALL RK_ErrorMsg(-8,Tstart,ZERO,IERR) - END IF - ELSE - DO i=1,N - IF (AbsTol(i) <= ZERO.OR.RelTol(i) <= 10.d0*Roundoff) THEN - WRITE (6,*) 'AbsTol/RelTol(',i,')=',AbsTol(i),RelTol(i) - CALL RK_ErrorMsg(-8,Tstart,ZERO,IERR) - END IF - END DO - END IF - -!~~~> Parameters are wrong - IF (IERR < 0) RETURN - -!~~~> Allocate checkpoint space or open checkpoint files - IF (AdjointType == KPP_ROOT_discrete) THEN - CALL rk_AllocateDBuffers() - ELSEIF ( (AdjointType == KPP_ROOT_continuous).OR. & - (AdjointType == KPP_ROOT_simple_continuous) ) THEN - CALL rk_AllocateCBuffers - END IF - -!~~~> Call the core method - CALL RK_FwdIntegrator( N,Tstart,Tend,Y,AdjointType,IERR ) -! PRINT*,'FORWARD STATISTICS' -! PRINT*,'Step=',Istatus(istp),' Acc=',Istatus(iacc), & -! ' Rej=',Istatus(irej), ' Singular=',Istatus(isng) - Nstp = 0 - Nacc = 0 - Nrej = 0 - Nsng = 0 - -!~~~> If Forward integration failed return - IF (IERR<0) RETURN - - SELECT CASE (AdjointType) - CASE (KPP_ROOT_discrete) - CALL rk_DadjInt ( & - NADJ, Lambda, & - Tstart, Tend, Texit, & - IERR ) - CASE (KPP_ROOT_continuous) - CALL rk_CadjInt ( & - NADJ, Lambda, & - Tend, Tstart, Texit, & - IERR ) - CASE (KPP_ROOT_simple_continuous) - CALL rk_SimpleCadjInt ( & - NADJ, Lambda, & - Tstart, Tend, Texit, & - IERR ) - END SELECT ! AdjointType -! PRINT*,'ADJOINT STATISTICS' -! PRINT*,'Step=',Nstp,' Acc=',Nacc, & -! ' Rej=',Nrej, ' Singular=',Nsng - -!~~~> Free checkpoint space or close checkpoint files - IF (AdjointType == KPP_ROOT_discrete) THEN - CALL rk_FreeDBuffers - ELSEIF ( (AdjointType == KPP_ROOT_continuous) .OR. & - (AdjointType == KPP_ROOT_simple_continuous) ) THEN - CALL rk_FreeCBuffers - END IF - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -CONTAINS ! Internal procedures to RungeKuttaADJ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE rk_AllocateDBuffers() -!~~~> Allocate buffer space for discrete adjoint -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - INTEGER :: i - - ALLOCATE( chk_H(bufsize), STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed allocation of buffer H'; STOP - END IF - ALLOCATE( chk_T(bufsize), STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed allocation of buffer T'; STOP - END IF - ALLOCATE( chk_Y(NVAR,bufsize), STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed allocation of buffer Y'; STOP - END IF - ALLOCATE( chk_Z(NVAR*3,bufsize), STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed allocation of buffer Z'; STOP - END IF - ALLOCATE( chk_NiT(bufsize), STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed allocation of buffer NiT'; STOP - END IF - IF (SaveLU) THEN -#ifdef FULL_ALGEBRA - ALLOCATE( chk_E1(NVAR*NVAR,bufsize), STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed allocation of buffer E1'; STOP - END IF - ALLOCATE( chk_E2(NVAR*NVAR,bufsize), STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed allocation of buffer E2'; STOP - END IF -#else - ALLOCATE( chk_E1(LU_NONZERO,bufsize), STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed allocation of buffer E1'; STOP - END IF - ALLOCATE( chk_E2(LU_NONZERO,bufsize), STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed allocation of buffer E2'; STOP - END IF -#endif - END IF - - - END SUBROUTINE rk_AllocateDBuffers - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE rk_FreeDBuffers() -!~~~> Dallocate buffer space for discrete adjoint -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - INTEGER :: i - - DEALLOCATE( chk_H, STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed deallocation of buffer H'; STOP - END IF - DEALLOCATE( chk_T, STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed deallocation of buffer T'; STOP - END IF - DEALLOCATE( chk_Y, STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed deallocation of buffer Y'; STOP - END IF - DEALLOCATE( chk_Z, STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed deallocation of buffer Z'; STOP - END IF - DEALLOCATE( chk_NiT, STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed deallocation of buffer NiT'; STOP - END IF - IF (SaveLU) THEN - DEALLOCATE( chk_E1, STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed allocation of buffer E1'; STOP - END IF - DEALLOCATE( chk_E2, STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed allocation of buffer E2'; STOP - END IF - END IF - - END SUBROUTINE rk_FreeDBuffers - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE rk_AllocateCBuffers() -!~~~> Allocate buffer space for continuous adjoint -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - INTEGER :: i - - ALLOCATE( chk_H(bufsize), STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed allocation of buffer H'; STOP - END IF - ALLOCATE( chk_T(bufsize), STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed allocation of buffer T'; STOP - END IF - ALLOCATE( chk_Y(NVAR,bufsize), STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed allocation of buffer Y'; STOP - END IF - ALLOCATE( chk_dY(NVAR,bufsize), STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed allocation of buffer dY'; STOP - END IF - ALLOCATE( chk_d2Y(NVAR,bufsize), STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed allocation of buffer d2Y'; STOP - END IF - - END SUBROUTINE rk_AllocateCBuffers - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE rk_FreeCBuffers() -!~~~> Dallocate buffer space for continuous adjoint -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - INTEGER :: i - print*,'cbuffers deallocate???' - DEALLOCATE( chk_H, STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed deallocation of buffer H'; STOP - END IF - DEALLOCATE( chk_T, STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed deallocation of buffer T'; STOP - END IF - DEALLOCATE( chk_Y, STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed deallocation of buffer Y'; STOP - END IF - DEALLOCATE( chk_dY, STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed deallocation of buffer dY'; STOP - END IF - DEALLOCATE( chk_d2Y, STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed deallocation of buffer d2Y'; STOP - END IF - - END SUBROUTINE rk_FreeCBuffers - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE rk_DPush( T, H, Y, Zstage, NewIt, E1, E2 )!, Jcb ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Saves the next trajectory snapshot for discrete adjoints -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - KPP_REAL :: T, H, Y(NVAR), Zstage(NVAR*3) - INTEGER :: NewIt -#ifdef FULL_ALGEBRA - KPP_REAL :: E1(NVAR,NVAR) - COMPLEX(kind=dp) :: E2(NVAR,NVAR) - INTEGER :: i, j -#else - KPP_REAL :: E1(LU_NONZERO) - COMPLEX(kind=dp) :: E2(LU_NONZERO) -#endif - - stack_ptr = stack_ptr + 1 - IF ( stack_ptr > bufsize ) THEN - PRINT*,'Push failed: buffer overflow' - STOP - END IF - chk_H( stack_ptr ) = H - chk_T( stack_ptr ) = T - ! CALL WCOPY(NVAR,Y,1,chk_Y(1,stack_ptr),1) - ! CALL WCOPY(NVAR*3,Zstage,1,chk_Z(1,stack_ptr),1) - chk_Y(1:N,stack_ptr) = Y(1:N) - chk_Z(1:3*N,stack_ptr) = Zstage(1:3*N) - chk_NiT( stack_ptr ) = NewIt - IF (SaveLU) THEN -#ifdef FULL_ALGEBRA - ! CALL WCOPY(NVAR*NVAR, E1,1,chk_E1(1,stack_ptr),1) - ! CALL WCOPYCmplx(NVAR*NVAR, E2,1,chk_E2(1,stack_ptr),1) - DO j=1,NVAR - DO i=1,NVAR - chk_E1(NVAR*(j-1)+i,stack_ptr) = E1(i,j) - chk_E2(NVAR*(j-1)+i,stack_ptr) = E2(i,j) - END DO - END DO -#else - ! CALL WCOPY(LU_NONZERO, E1,1,chk_E1(1,stack_ptr),1) - ! CALL WCOPYCmplx(LU_NONZERO, E2,1,chk_E2(1,stack_ptr),1) - chk_E1(1:LU_NONZERO,stack_ptr) = E1(1:LU_NONZERO) - chk_E2(1:LU_NONZERO,stack_ptr) = E2(1:LU_NONZERO) -#endif - END IF - !CALL WCOPY(LU_NONZERO,Jcb,1,chk_J(1,stack_ptr),1) - - END SUBROUTINE rk_DPush - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE rk_DPop( T, H, Y, Zstage, NewIt, E1, E2 ) !, Jcb ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Retrieves the next trajectory snapshot for discrete adjoints -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - KPP_REAL :: T, H, Y(NVAR), Zstage(NVAR*3) ! , Jcb(LU_NONZERO) - INTEGER :: NewIt -#ifdef FULL_ALGEBRA - KPP_REAL :: E1(NVAR,NVAR) - COMPLEX(kind=dp) :: E2(NVAR,NVAR) - INTEGER :: i, j -#else - KPP_REAL :: E1(LU_NONZERO) - COMPLEX(kind=dp) :: E2(LU_NONZERO) -#endif - - IF ( stack_ptr <= 0 ) THEN - PRINT*,'Pop failed: empty buffer' - STOP - END IF - H = chk_H( stack_ptr ) - T = chk_T( stack_ptr ) - ! CALL WCOPY(NVAR,chk_Y(1,stack_ptr),1,Y,1) - Y(1:NVAR) = chk_Y(1:NVAR,stack_ptr) - ! CALL WCOPY(NVAR*3,chk_Z(1,stack_ptr),1,Zstage,1) - Zstage(1:3*NVAR) = chk_Z(1:3*NVAR,stack_ptr) - NewIt = chk_NiT( stack_ptr ) - IF (SaveLU) THEN -#ifdef FULL_ALGEBRA - ! CALL WCOPY(NVAR*NVAR,chk_E1(1,stack_ptr),1, E1,1) - ! CALL WCOPYCmplx(NVAR*NVAR,chk_E2(1,stack_ptr),1, E2,1) - DO j=1,NVAR - DO i=1,NVAR - E1(i,j) = chk_E1(NVAR*(j-1)+i,stack_ptr) - E2(i,j) = chk_E2(NVAR*(j-1)+i,stack_ptr) - END DO - END DO -#else - ! CALL WCOPY(LU_NONZERO,chk_E1(1,stack_ptr),1, E1,1) - ! CALL WCOPYCmplx(LU_NONZERO,chk_E2(1,stack_ptr),1, E2,1) - E1(1:LU_NONZERO) = chk_E1(1:LU_NONZERO,stack_ptr) - E2(1:LU_NONZERO) = chk_E2(1:LU_NONZERO,stack_ptr) -#endif - END IF - !CALL WCOPY(LU_NONZERO,chk_J(1,stack_ptr),1,Jcb,1) - - stack_ptr = stack_ptr - 1 - - END SUBROUTINE rk_DPop - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE rk_CPush(T, H, Y, dY, d2Y ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Saves the next trajectory snapshot for discrete adjoints -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - KPP_REAL :: T, H, Y(NVAR), dY(NVAR), d2Y(NVAR) - - stack_ptr = stack_ptr + 1 - IF ( stack_ptr > bufsize ) THEN - PRINT*,'Push failed: buffer overflow' - STOP - END IF - chk_H( stack_ptr ) = H - chk_T( stack_ptr ) = T - ! CALL WCOPY(NVAR,Y,1,chk_Y(1,stack_ptr),1) - ! CALL WCOPY(NVAR,dY,1,chk_dY(1,stack_ptr),1) - ! CALL WCOPY(NVAR,d2Y,1,chk_d2Y(1,stack_ptr),1) - chk_Y(1:NVAR,stack_ptr) = Y(1:NVAR) - chk_dY(1:NVAR,stack_ptr) = dY(1:NVAR) - chk_d2Y(1:NVAR,stack_ptr)= d2Y(1:NVAR) - - END SUBROUTINE rk_CPush - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE rk_CPop( T, H, Y, dY, d2Y ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Retrieves the next trajectory snapshot for discrete adjoints -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - KPP_REAL :: T, H, Y(NVAR), dY(NVAR), d2Y(NVAR) - - IF ( stack_ptr <= 0 ) THEN - PRINT*,'Pop failed: empty buffer' - STOP - END IF - H = chk_H( stack_ptr ) - T = chk_T( stack_ptr ) - ! CALL WCOPY(NVAR,chk_Y(1,stack_ptr),1,Y,1) - ! CALL WCOPY(NVAR,chk_dY(1,stack_ptr),1,dY,1) - ! CALL WCOPY(NVAR,chk_d2Y(1,stack_ptr),1,d2Y,1) - Y(1:NVAR) = chk_Y(1:NVAR,stack_ptr) - dY(1:NVAR) = chk_dY(1:NVAR,stack_ptr) - d2Y(1:NVAR) = chk_d2Y(1:NVAR,stack_ptr) - - stack_ptr = stack_ptr - 1 - - END SUBROUTINE rk_CPop - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE RK_FwdIntegrator( N,Tstart,Tend,Y,AdjointType,IERR ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE -!~~~> Arguments - INTEGER, INTENT(IN) :: N - KPP_REAL, INTENT(IN) :: Tend, Tstart - KPP_REAL, INTENT(INOUT) :: Y(N) - INTEGER, INTENT(OUT) :: IERR - INTEGER, INTENT(IN) :: AdjointType - -!~~~> Local variables -#ifdef FULL_ALGEBRA - KPP_REAL :: FJAC(N,N), E1(N,N) - COMPLEX(kind=dp) :: E2(N,N) -#else - KPP_REAL :: FJAC(LU_NONZERO), E1(LU_NONZERO) - COMPLEX(kind=dp) :: E2(LU_NONZERO) -#endif - KPP_REAL, DIMENSION(N) :: Z1,Z2,Z3,Z4,SCAL,DZ1,DZ2,DZ3,DZ4,G,TMP,FCN0 - KPP_REAL :: CONT(N,3), Tdirection, H, T, Hacc, Hnew, Hold, Fac, & - FacGus, Theta, Err, ErrOld, NewtonRate, NewtonIncrement, & - Hratio, Qnewton, NewtonPredictedErr,NewtonIncrementOld, ThetaSD - INTEGER :: IP1(N),IP2(N),NewtonIter, ISING, Nconsecutive, NewIt - LOGICAL :: Reject, FirstStep, SkipJac, NewtonDone, SkipLU - - KPP_REAL, DIMENSION(:), POINTER :: Zstage - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Initial setting -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IF (AdjointType == KPP_ROOT_discrete) THEN ! Save stage solution - ALLOCATE(Zstage(N*3), STAT=i) - IF (i/=0) THEN - PRINT*,'Allocation of Zstage failed' - STOP - END IF - END IF - T=Tstart - - Tdirection = SIGN(ONE,Tend-Tstart) - H = MIN( MAX(ABS(Hmin),ABS(Hstart)) , Hmax ) - IF (ABS(H) <= 10.d0*Roundoff) H = 1.0d-6 - H = SIGN(H,Tdirection) - Hold = H - Reject = .FALSE. - FirstStep = .TRUE. - SkipJac = .FALSE. - SkipLU = .FALSE. - IF ((T+H*1.0001D0-Tend)*Tdirection >= ZERO) THEN - H = Tend-T - END IF - Nconsecutive = 0 - CALL RK_ErrorScale(N,ITOL,AbsTol,RelTol,Y,SCAL) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Time loop begins -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Tloop: DO WHILE ( (Tend-T)*Tdirection - Roundoff > ZERO ) - - IF ( .NOT.SkipLU ) THEN ! This time around skip the Jac update and LU - !~~~> Compute the Jacobian matrix - IF ( .NOT.SkipJac ) THEN - CALL JAC_CHEM(T,Y,FJAC) - ISTATUS(ijac) = ISTATUS(ijac) + 1 - END IF - !~~~> Compute the matrices E1 and E2 and their decompositions - CALL RK_Decomp(N,H,FJAC,E1,IP1,E2,IP2,ISING) - IF (ISING /= 0) THEN - ISTATUS(isng) = ISTATUS(isng) + 1; Nconsecutive = Nconsecutive + 1 - IF (Nconsecutive >= 5) THEN - CALL RK_ErrorMsg(-12,T,H,IERR); RETURN - END IF - H=H*0.5d0; Reject=.TRUE.; SkipJac = .TRUE.; SkipLU = .FALSE. - CYCLE Tloop - ELSE - Nconsecutive = 0 - END IF - END IF ! SkipLU - - ISTATUS(istp) = ISTATUS(istp) + 1 - IF (ISTATUS(istp) > Max_no_steps) THEN - PRINT*,'Max number of time steps is ',Max_no_steps - CALL RK_ErrorMsg(-9,T,H,IERR); RETURN - END IF - IF (0.1D0*ABS(H) <= ABS(T)*Roundoff) THEN - CALL RK_ErrorMsg(-10,T,H,IERR); RETURN - END IF - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Loop for the simplified Newton iterations -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - !~~~> Starting values for Newton iteration - IF ( FirstStep .OR. (.NOT.StartNewton) ) THEN - CALL Set2zero(N,Z1) - CALL Set2zero(N,Z2) - CALL Set2zero(N,Z3) - ELSE - ! Evaluate quadratic polynomial - CALL RK_Interpolate('eval',N,H,Hold,Z1,Z2,Z3,CONT) - END IF - - !~~~> Initializations for Newton iteration - NewtonDone = .FALSE. - Fac = 0.5d0 ! Step reduction if too many iterations - -NewtonLoop:DO NewtonIter = 1, NewtonMaxit - - !~~~> Prepare the right-hand side - CALL RK_PrepareRHS(N,T,H,Y,Z1,Z2,Z3,DZ1,DZ2,DZ3) - - !~~~> Solve the linear systems - CALL RK_Solve( N,H,E1,IP1,E2,IP2,DZ1,DZ2,DZ3,ISING ) - - - NewtonIncrement = SQRT( ( RK_ErrorNorm(N,SCAL,DZ1)**2 + & - RK_ErrorNorm(N,SCAL,DZ2)**2 + & - RK_ErrorNorm(N,SCAL,DZ3)**2 )/3.0d0 ) - - IF ( NewtonIter == 1 ) THEN - Theta = ABS(ThetaMin) - NewtonRate = 2.0d0 - ELSE - Theta = NewtonIncrement/NewtonIncrementOld - IF (Theta < 0.99d0) THEN - NewtonRate = Theta/(ONE-Theta) - ELSE ! Non-convergence of Newton: Theta too large - EXIT NewtonLoop - END IF - IF ( NewtonIter < NewtonMaxit ) THEN - ! Predict error at the end of Newton process - NewtonPredictedErr = NewtonIncrement & - *Theta**(NewtonMaxit-NewtonIter)/(ONE-Theta) - IF (NewtonPredictedErr >= NewtonTol) THEN - ! Non-convergence of Newton: predicted error too large - Qnewton = MIN(10.0d0,NewtonPredictedErr/NewtonTol) - Fac=0.8d0*Qnewton**(-ONE/(1+NewtonMaxit-NewtonIter)) - EXIT NewtonLoop - END IF - END IF - END IF - - NewtonIncrementOld = MAX(NewtonIncrement,Roundoff) - ! Update solution - CALL WAXPY(N,-ONE,DZ1,1,Z1,1) ! Z1 <- Z1 - DZ1 - CALL WAXPY(N,-ONE,DZ2,1,Z2,1) ! Z2 <- Z2 - DZ2 - CALL WAXPY(N,-ONE,DZ3,1,Z3,1) ! Z3 <- Z3 - DZ3 - - ! Check error in Newton iterations - NewtonDone = (NewtonRate*NewtonIncrement <= NewtonTol) - IF (NewtonDone) THEN - NewIt = NewtonIter - EXIT NewtonLoop - END IF - IF (NewtonIter == NewtonMaxit) THEN - PRINT*, 'Slow or no convergence in Newton Iteration: Max no. of', & - 'Newton iterations reached' - END IF - - END DO NewtonLoop - - - IF (.NOT.NewtonDone) THEN - !CALL RK_ErrorMsg(-12,T,H,IERR); - H = Fac*H; Reject=.TRUE.; SkipJac = .TRUE.; SkipLU = .FALSE. - ISTATUS(irej) = ISTATUS(irej) + 1 - CYCLE Tloop - END IF - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> SDIRK Stage -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IF (SdirkError) THEN - -!~~~> Starting values for Newton iterations - Z4(1:N) = Z3(1:N) - -!~~~> Prepare the loop-independent part of the right-hand side - CALL FUN_CHEM(T,Y,DZ4) - ISTATUS(Nfun) = ISTATUS(Nfun) + 1 - -! G = H*rkBgam(0)*DZ4 + rkTheta(1)*Z1 + rkTheta(2)*Z2 + rkTheta(3)*Z3 - CALL Set2Zero(N, G) - CALL WAXPY(N,rkBgam(0)*H, DZ4,1,G,1) - CALL WAXPY(N,rkTheta(1),Z1,1,G,1) - CALL WAXPY(N,rkTheta(2),Z2,1,G,1) - CALL WAXPY(N,rkTheta(3),Z3,1,G,1) - - !~~~> Initializations for Newton iteration - NewtonDone = .FALSE. - Fac = 0.5d0 ! Step reduction factor if too many iterations - -SDNewtonLoop:DO NewtonIter = 1, NewtonMaxit - -!~~~> Prepare the loop-dependent part of the right-hand side - CALL WADD(N,Y,Z4,TMP) ! TMP <- Y + Z4 - CALL FUN_CHEM(T+H,TMP,DZ4) ! DZ4 <- Fun(Y+Z4) - ISTATUS(Nfun) = ISTATUS(Nfun) + 1 -! DZ4(1:N) = (G(1:N)-Z4(1:N))*(rkGamma/H) + DZ4(1:N) - CALL WAXPY (N, -ONE*rkGamma/H, Z4, 1, DZ4, 1) - CALL WAXPY (N, rkGamma/H, G,1, DZ4,1) - -!~~~> Solve the linear system -#ifdef FULL_ALGEBRA - CALL DGETRS( 'N', N, 1, E1, N, IP1, DZ4, N, ISING ) -#else - CALL KppSolve(E1, DZ4) -#endif - -!~~~> Check convergence of Newton iterations - NewtonIncrement = RK_ErrorNorm(N,SCAL,DZ4) - IF ( NewtonIter == 1 ) THEN - ThetaSD = ABS(ThetaMin) - NewtonRate = 2.0d0 - ELSE - ThetaSD = NewtonIncrement/NewtonIncrementOld - IF (ThetaSD < 0.99d0) THEN - NewtonRate = ThetaSD/(ONE-ThetaSD) - ! Predict error at the end of Newton process - NewtonPredictedErr = NewtonIncrement & - *ThetaSD**(NewtonMaxit-NewtonIter)/(ONE-ThetaSD) - IF (NewtonPredictedErr >= NewtonTol) THEN - ! Non-convergence of Newton: predicted error too large - !print*,'Error too large: ', NewtonPredictedErr - Qnewton = MIN(10.0d0,NewtonPredictedErr/NewtonTol) - Fac = 0.8d0*Qnewton**(-ONE/(1+NewtonMaxit-NewtonIter)) - EXIT SDNewtonLoop - END IF - ELSE ! Non-convergence of Newton: ThetaSD too large - !print*,'Theta too large: ',ThetaSD - EXIT SDNewtonLoop - END IF - END IF - NewtonIncrementOld = NewtonIncrement - ! Update solution: Z4 <-- Z4 + DZ4 - CALL WAXPY(N,ONE,DZ4,1,Z4,1) - - ! Check error in Newton iterations - NewtonDone = (NewtonRate*NewtonIncrement <= NewtonTol) - IF (NewtonDone) EXIT SDNewtonLoop - - END DO SDNewtonLoop - - IF (.NOT.NewtonDone) THEN - H = Fac*H; Reject=.TRUE.; SkipJac = .TRUE.; SkipLU = .FALSE. - CYCLE Tloop - END IF - END IF -!~~~> End of implified SDIRK Newton iterations - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Error estimation -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IF (SdirkError) THEN -! DZ4(1:N) = rkD(1)*Z1 + rkD(2)*Z2 + rkD(3)*Z3 - Z4 - CALL Set2Zero(N, DZ4) - IF (rkD(1) /= ZERO) CALL WAXPY(N, rkD(1), Z1, 1, DZ4, 1) - IF (rkD(2) /= ZERO) CALL WAXPY(N, rkD(2), Z2, 1, DZ4, 1) - IF (rkD(3) /= ZERO) CALL WAXPY(N, rkD(3), Z3, 1, DZ4, 1) - CALL WAXPY(N, -ONE, Z4, 1, DZ4, 1) - Err = RK_ErrorNorm(N,SCAL,DZ4) - ELSE - CALL RK_ErrorEstimate(N,H,Y,T, & - E1,IP1,Z1,Z2,Z3,SCAL,Err,FirstStep,Reject) - END IF -!~~~> Computation of new step size Hnew - Fac = Err**(-ONE/rkELO)* & - MIN(FacSafe,(ONE+2*NewtonMaxit)/(NewtonIter+2*NewtonMaxit)) - Fac = MIN(FacMax,MAX(FacMin,Fac)) - Hnew = Fac*H - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Accept/reject step -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -accept:IF (Err < ONE) THEN !~~~> STEP IS ACCEPTED - IF (AdjointType == KPP_ROOT_discrete) THEN ! Save stage solution - ! CALL WCOPY(N,Z1,1,Zstage(1),1) - ! CALL WCOPY(N,Z2,1,Zstage(N+1),1) - ! CALL WCOPY(N,Z3,1,Zstage(2*N+1),1) - Zstage(1:N) = Z1(1:N) - Zstage(N+1:2*N) = Z2(1:N) - Zstage(2*N+1:3*N) = Z3(1:N) - ! Push old Y - Y at the beginning of the stage - CALL rk_DPush(T, H, Y, Zstage, NewIt, E1, E2) - END IF - - FirstStep=.FALSE. - ISTATUS(iacc) = ISTATUS(iacc) + 1 - IF (Gustafsson) THEN - !~~~> Predictive controller of Gustafsson - IF (ISTATUS(iacc) > 1) THEN - FacGus=FacSafe*(H/Hacc)*(Err**2/ErrOld)**(-0.25d0) - FacGus=MIN(FacMax,MAX(FacMin,FacGus)) - Fac=MIN(Fac,FacGus) - Hnew = Fac*H - END IF - Hacc=H - ErrOld=MAX(1.0d-2,Err) - END IF - Hold = H - T = T+H - ! Update solution: Y <- Y + sum (d_i Z_i) - IF (rkD(1) /= ZERO) CALL WAXPY(N,rkD(1),Z1,1,Y,1) - IF (rkD(2) /= ZERO) CALL WAXPY(N,rkD(2),Z2,1,Y,1) - IF (rkD(3) /= ZERO) CALL WAXPY(N,rkD(3),Z3,1,Y,1) - ! Construct the solution quadratic interpolant Q(c_i) = Z_i, i=1:3 - IF (StartNewton) CALL RK_Interpolate('make',N,H,Hold,Z1,Z2,Z3,CONT) - CALL RK_ErrorScale(N,ITOL,AbsTol,RelTol,Y,SCAL) - RSTATUS(itexit) = T - RSTATUS(ihnew) = Hnew - RSTATUS(ihacc) = H - Hnew = Tdirection*MIN( MAX(ABS(Hnew),Hmin) , Hmax ) - IF (Reject) Hnew = Tdirection*MIN(ABS(Hnew),ABS(H)) - Reject = .FALSE. - IF ((T+Hnew/Qmin-Tend)*Tdirection >= ZERO) THEN - H = Tend-T - ELSE - Hratio=Hnew/H - ! Reuse the LU decomposition - SkipLU = (Theta<=ThetaMin) .AND. (Hratio>=Qmin) .AND. (Hratio<=Qmax) - SkipLU = .false. - IF (.NOT.SkipLU) H=Hnew - END IF - ! If convergence is fast enough, do not update Jacobian - ! SkipJac = (Theta <= ThetaMin) - SkipJac = .FALSE. - - ELSE accept !~~~> Step is rejected - IF (FirstStep .OR. Reject) THEN - H = FacRej*H - ELSE - H = Hnew - END IF - Reject = .TRUE. - SkipJac = .TRUE. - SkipLU = .FALSE. - IF (ISTATUS(iacc) >= 1) ISTATUS(irej) = ISTATUS(irej) + 1 - END IF accept - - END DO Tloop - -!~~~> Save last state: only needed for continuous adjoint - IF ( (AdjointType == KPP_ROOT_continuous) .OR. & - (AdjointType == KPP_ROOT_simple_continuous) ) THEN - CALL Fun_Chem(T,Y,Fcn0) - CALL rk_CPush( T, H, Y, Fcn0, DZ3) -!~~~> Deallocate stage buffer: only needed for discrete adjoint - ELSEIF (AdjointType == KPP_ROOT_discrete) THEN - DEALLOCATE(Zstage, STAT=i) - IF (i/=0) THEN - PRINT*,'Deallocation of Zstage failed' - STOP - END IF - END IF - - ! Successful exit - IERR = 1 - - END SUBROUTINE RK_FwdIntegrator - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE rk_DadjInt( NADJ,Lambda,Tstart,Tend,T,IERR ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE -!~~~> Arguments -!~~~> Input: the initial condition at Tstart; Output: the solution at T - INTEGER, INTENT(IN) :: NADJ -!~~~> First order adjoint - KPP_REAL, INTENT(INOUT) :: Lambda(N,NADJ) - KPP_REAL, INTENT(IN) :: Tstart, Tend - KPP_REAL, INTENT(INOUT) :: T - INTEGER, INTENT(OUT) :: IERR - -!~~~> Local variables -#ifdef FULL_ALGEBRA - KPP_REAL :: Jac0(N,N), Jac1(N,N),Jac2(N,N),Jac3(N,N), E1(N,N) - COMPLEX(kind=dp) :: E2(N,N) - KPP_REAL :: Jbig(3*N,3*N), X(3*N) - INTEGER :: IPbig(3*N) -#else - KPP_REAL, DIMENSION(LU_NONZERO) :: Jac0, Jac1, Jac2, Jac3, E1 - COMPLEX(kind=dp), DIMENSION(LU_NONZERO) :: E2 - ! Next two lines for sparse big algebra: - ! KPP_REAL :: Jbig(3,3,LU_NONZERO), X(3,N) - ! INTEGER :: IPbig(3,N) - KPP_REAL :: Jbig(3*N,3*N), X(3*N) - INTEGER :: IPbig(3*N) -#endif - KPP_REAL, DIMENSION(N,NADJ) :: U1,U2,U3 - KPP_REAL, DIMENSION(N) :: SCAL,DU1,DU2,DU3 - KPP_REAL :: Y(N), Zstage(3*N) - KPP_REAL :: H, NewtonRate, NewtonIncrement, NewtonIncrementOld - INTEGER :: IP1(N),IP2(N),NewtonIter, ISING, iadj, NewIt - LOGICAL :: Reject, NewtonDone, NewtonConverge - KPP_REAL :: T1, Theta - KPP_REAL, DIMENSION(N) :: TMP, G1, G2, G3 - INTEGER :: info, i, j - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Initial setting -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - T1 = Tend -! Tdirection = SIGN(ONE,Tend-Tstart) - NewtonConverge = .TRUE. - Reject = .FALSE. - -!~~~> Time loop begins below -TimeLoop:DO WHILE ( stack_ptr > 0 ) - - IF (.not.Reject) THEN - - !~~~> Recover checkpoints for stage values and vectors - CALL rk_DPop(T, H, Y, Zstage, NewIt, E1, E2) - - !~~~> Compute LU decomposition - IF (.NOT.SaveLU) THEN - !~~~> Compute the Jacobian matrix - CALL JAC_CHEM(T,Y,Jac0) - ISTATUS(ijac) = ISTATUS(ijac) + 1 - !~~~> Compute the matrices E1 and E2 and their decompositions - CALL RK_Decomp(N,H,Jac0,E1,IP1,E2,IP2,ISING) - END IF - - !~~~> Jacobian values at stage vectors - CALL WADD(N,Y,Zstage(1),TMP) ! TMP <- Y + Z1 - CALL JAC_CHEM(T+rkC(1)*H,TMP,Jac1) ! Jac1 <- Jac(Y+Z1) - CALL WADD(N,Y,Zstage(1+N),TMP) ! TMP <- Y + Z2 - CALL JAC_CHEM(T+rkC(2)*H,TMP,Jac2) ! Jac2 <- Jac(Y+Z2) - CALL WADD(N,Y,Zstage(1+2*N),TMP) ! TMP <- Y + Z3 - CALL JAC_CHEM(T+rkC(3)*H,TMP,Jac3) ! Jac3 <- Jac(Y+Z3) - - END IF ! .not.Reject - -111 CONTINUE - - IF ( (AdjointSolve == Solve_adaptive .and. .not.NewtonConverge) & - .or. (AdjointSolve == Solve_direct) ) THEN -#ifdef FULL_ALGEBRA - DO j=1,N - DO i=1,N - Jbig(i,j) = -H*rkA(1,1)*Jac1(i,j) - Jbig(N+i,j) = -H*rkA(2,1)*Jac1(i,j) - Jbig(2*N+i,j) = -H*rkA(3,1)*Jac1(i,j) - Jbig(i,N+j) = -H*rkA(1,2)*Jac2(i,j) - Jbig(N+i,N+j) = -H*rkA(2,2)*Jac2(i,j) - Jbig(2*N+i,N+j) = -H*rkA(3,2)*Jac2(i,j) - Jbig(i,2*N+j) = -H*rkA(1,3)*Jac3(i,j) - Jbig(N+i,2*N+j) = -H*rkA(2,3)*Jac3(i,j) - Jbig(2*N+i,2*N+j) = -H*rkA(3,3)*Jac3(i,j) - END DO - END DO - DO i=1,3*N - Jbig(i,i) = Jbig(i,i) + ONE - END DO - CALL DGETRF(3*N,3*N,Jbig,3*N,IPbig,info) - ! CALL WGEFA(3*N,Jbig,IPbig,info) - IF (info /= 0) THEN - PRINT*,'Big guy is singular'; STOP - END IF -#else -! Commented lines for sparse big algebra: -! !~~~> Construct the big Jacobian -! DO j=1,LU_NONZERO -! DO i=1,3 -! Jbig(i,1,j) = -H*rkA(i,1)*Jac1(j) -! Jbig(i,2,j) = -H*rkA(i,2)*Jac2(j) -! Jbig(i,3,j) = -H*rkA(i,3)*Jac3(j) -! END DO -! END DO -! DO j=1,NVAR -! DO i=1,3 -! Jbig(i,i,LU_DIAG(j)) = ONE + Jbig(i,i,LU_DIAG(j)) -! END DO -! END DO -! !~~~> Solve the big system -! CALL KppDecompBig( Jbig, IPbig, info ) -! Use full big algebra: - Jbig(1:3*N,1:3*N) = 0.0d0 - DO i=1,LU_NONZERO - Jbig(LU_irow(i),LU_icol(i)) = -H*rkA(1,1)*Jac1(i) - Jbig(LU_irow(i),N+LU_icol(i)) = -H*rkA(1,2)*Jac2(i) - Jbig(LU_irow(i),2*N+LU_icol(i)) = -H*rkA(1,3)*Jac3(i) - Jbig(N+LU_irow(i),LU_icol(i)) = -H*rkA(2,1)*Jac1(i) - Jbig(N+LU_irow(i),N+LU_icol(i)) = -H*rkA(2,2)*Jac2(i) - Jbig(N+LU_irow(i),2*N+LU_icol(i)) = -H*rkA(2,3)*Jac3(i) - Jbig(2*N+LU_irow(i),LU_icol(i)) = -H*rkA(3,1)*Jac1(i) - Jbig(2*N+LU_irow(i),N+LU_icol(i)) = -H*rkA(3,2)*Jac2(i) - Jbig(2*N+LU_irow(i),2*N+LU_icol(i)) = -H*rkA(3,3)*Jac3(i) - END DO - DO i=1, 3*N - Jbig(i,i) = ONE + Jbig(i,i) - END DO - ! CALL DGETRF(3*N,3*N,Jbig,3*N,IPbig,info) - CALL WGEFA(3*N,Jbig,IPbig,info) - IF (info /= 0) THEN - PRINT*,'Big guy is singular'; STOP - END IF -#endif - END IF - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Loop for the simplified Newton iterations -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Adj:DO iadj = 1, NADJ - !~~~> Starting values for Newton iteration - ! CALL WCOPY(N,Lambda(1,iadj),1,U1(1,iadj),1) - ! CALL WCOPY(N,Lambda(1,iadj),1,U2(1,iadj),1) - ! CALL WCOPY(N,Lambda(1,iadj),1,U3(1,iadj),1) - CALL Set2Zero(N,U1(1,iadj)) - CALL Set2Zero(N,U2(1,iadj)) - CALL Set2Zero(N,U3(1,iadj)) - - !~~~> Initializations for Newton iteration - NewtonDone = .FALSE. - !~~~> Right Hand Side - part G for all Newton iterations - CALL RK_PrepareRHS_G(N,H,Jac1,Jac2,Jac3,Lambda(1,iadj), & - G1, G2, G3) - - IF ( (AdjointSolve == Solve_adaptive .and. NewtonConverge) & - .or. (AdjointSolve == Solve_fixed) ) THEN - -NewtonLoopAdj:DO NewtonIter = 1, NewtonMaxit - - !~~~> Prepare the right-hand side - CALL RK_PrepareRHS_Adj(N,H,Jac1,Jac2,Jac3,Lambda(1,iadj), & - U1(1,iadj),U2(1,iadj),U3(1,iadj), & - G1, G2, G3, DU1,DU2,DU3) - - !~~~> Solve the linear systems - CALL RK_SolveTR( N,H,E1,IP1,E2,IP2,DU1,DU2,DU3,ISING ) - -!~~~> The following code performs an adaptive number of Newton -! iterations for solving adjoint system - IF (AdjointSolve == Solve_adaptive) THEN - - CALL RK_ErrorScale(N,ITOL, & - AbsTol_adj(1:N,iadj),RelTol_adj(1:N,iadj), & - Lambda(1:N,iadj),SCAL) - - ! SCAL(1:N) = 1.0d0 - NewtonIncrement = SQRT( ( RK_ErrorNorm(N,SCAL,DU1)**2 + & - RK_ErrorNorm(N,SCAL,DU2)**2 + & - RK_ErrorNorm(N,SCAL,DU3)**2 )/3.0d0 ) - - - IF ( NewtonIter == 1 ) THEN - Theta = ABS(ThetaMin) - NewtonRate = 2.0d0 - ELSE - Theta = NewtonIncrement/NewtonIncrementOld - IF (Theta < 0.99d0) THEN - NewtonRate = Theta/(ONE-Theta) - ELSE ! Non-convergence of Newton: Theta too large - Reject = .TRUE. - NewtonDone = .FALSE. - EXIT NewtonLoopAdj - END IF - - END IF - - NewtonIncrementOld = MAX(NewtonIncrement,Roundoff) - - END IF ! (AdjointSolve == Solve_adaptive) - - ! Update solution - CALL WAXPY(N,-ONE,DU1,1,U1(1,iadj),1) ! U1 <- U1 - DU1 - CALL WAXPY(N,-ONE,DU2,1,U2(1,iadj),1) ! U2 <- U2 - DU2 - CALL WAXPY(N,-ONE,DU3,1,U3(1,iadj),1) ! U3 <- U3 - DU3 - - IF (AdjointSolve == Solve_adaptive) THEN - ! When performing an adaptive number of iterations - ! check the error in Newton iterations - NewtonDone = (NewtonRate*NewtonIncrement <= NewtonTol) - IF ((NewtonDone).and.(NewtonIter>NewIt+1)) EXIT NewtonLoopAdj - ELSE IF (AdjointSolve == Solve_fixed) THEN - IF (NewtonIter>MAX(NewIt+1,6)) EXIT NewtonLoopAdj - END IF - - END DO NewtonLoopAdj - - IF ((AdjointSolve==Solve_adaptive).AND.(.NOT.NewtonDone)) THEN - ! print*,'Newton iterations do not converge, switching to full system.' - NewtonConverge = .FALSE. - Reject = .TRUE. - GOTO 111 - END IF - - ! Update adjoint solution: Y_adj <- Y_adj + sum (U_i) - CALL WAXPY(N,ONE,U1(1,iadj),1,Lambda(1,iadj),1) - CALL WAXPY(N,ONE,U2(1,iadj),1,Lambda(1,iadj),1) - CALL WAXPY(N,ONE,U3(1,iadj),1,Lambda(1,iadj),1) - - ELSE ! NewtonConverge = .false. - -#ifdef FULL_ALGEBRA - X(1:N) = -G1(1:N) - X(N+1:2*N) = -G2(1:N) - X(2*N+1:3*N) = -G3(1:N) - CALL DGETRS('T',3*N,1,Jbig,3*N,IPbig,X,3*N,0) - ! CALL WGESL('T',3*N,Jbig,IPbig,X) - Lambda(1:N,iadj) = Lambda(1:N,iadj)+X(1:N)+X(N+1:2*N)+X(2*N+1:3*N) -#else -! Commented lines for sparse big algebra: -! X(1,1:N) = -G1(1:N) -! X(2,1:N) = -G2(1:N) -! X(3,1:N) = -G3(1:N) -! CALL KppSolveBigTR( Jbig, IPbig, X ) -! Lambda(1:N,iadj) = Lambda(1:N,iadj)+X(1,1:N)+X(2,1:N)+X(3,1:N) -! Use fill big algebra: - X(1:N) = -G1(1:N) - X(N+1:2*N) = -G2(1:N) - X(2*N+1:3*N) = -G3(1:N) - ! CALL DGETRS('T',3*N,1,Jbig,3*N,IPbig,X,3*N,0) - CALL WGESL('T',3*N,Jbig,IPbig,X) - Lambda(1:N,iadj) = Lambda(1:N,iadj)+X(1:N)+X(N+1:2*N)+X(2*N+1:3*N) -#endif - IF ((AdjointSolve==Solve_adaptive).AND.(iadj>=NADJ)) THEN - NewtonConverge = .TRUE. - Reject = .FALSE. - END IF - - END IF ! NewtonConverge - - END DO Adj - - T1 = T1-H - - END DO TimeLoop - - ! Successful exit - IERR = 1 - - END SUBROUTINE RK_DadjInt - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE rk_CadjInt ( & - NADJ, Y, & - Tstart, Tend, T, IERR) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE -!~~~> Arguments -!~~~> Input: the initial condition at Tstart; Output: the solution at T - INTEGER, INTENT(IN) :: NADJ -!~~~> First order adjoint - KPP_REAL, INTENT(INOUT) :: Y(N,NADJ) - KPP_REAL, INTENT(IN) :: Tstart, Tend - KPP_REAL, INTENT(INOUT) :: T - INTEGER, INTENT(OUT) :: IERR - - END SUBROUTINE rk_CadjInt - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE rk_SimpleCadjInt ( & - NADJ, Y, & - Tstart, Tend, T, & - IERR ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE -!~~~> Arguments -!~~~> Input: the initial condition at Tstart; Output: the solution at T - INTEGER, INTENT(IN) :: NADJ -!~~~> First order adjoint - KPP_REAL, INTENT(INOUT) :: Y(N,NADJ) - KPP_REAL, INTENT(IN) :: Tstart, Tend - KPP_REAL, INTENT(INOUT) :: T - INTEGER, INTENT(OUT) :: IERR - - END SUBROUTINE rk_SimpleCadjInt - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE RK_ErrorMsg(Code,T,H,IERR) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Handles all error messages -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - KPP_REAL, INTENT(IN) :: T, H - INTEGER, INTENT(IN) :: Code - INTEGER, INTENT(OUT) :: IERR - - IERR = Code - PRINT * , & - 'Forced exit from RungeKutta due to the following error:' - - - SELECT CASE (Code) - CASE (-1) - PRINT * , '--> Improper value for maximal no of steps' - CASE (-2) - PRINT * , '--> Improper value for maximal no of Newton iterations' - CASE (-3) - PRINT * , '--> Hmin/Hmax/Hstart must be positive' - CASE (-4) - PRINT * , '--> Improper values for FacMin/FacMax/FacSafe/FacRej' - CASE (-5) - PRINT * , '--> Improper value for ThetaMin' - CASE (-6) - PRINT * , '--> Newton stopping tolerance too small' - CASE (-7) - PRINT * , '--> Improper values for Qmin, Qmax' - CASE (-8) - PRINT * , '--> Tolerances are too small' - CASE (-9) - PRINT * , '--> No of steps exceeds maximum bound' - CASE (-10) - PRINT * , '--> Step size too small: T + 10*H = T', & - ' or H < Roundoff' - CASE (-11) - PRINT * , '--> Matrix is repeatedly singular' - CASE (-12) - PRINT * , '--> Non-convergence of Newton iterations' - CASE (-13) - PRINT * , '--> Requested RK method not implemented' - CASE DEFAULT - PRINT *, 'Unknown Error code: ', Code - END SELECT - - WRITE(6,FMT="(5X,'T=',E12.5,' H=',E12.5)") T, H - - END SUBROUTINE RK_ErrorMsg - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE RK_ErrorScale(N,ITOL,AbsTol,RelTol,Y,SCAL) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Handles all error messages -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - INTEGER, INTENT(IN) :: N, ITOL - KPP_REAL, INTENT(IN) :: AbsTol(*), RelTol(*), Y(N) - KPP_REAL, INTENT(OUT) :: SCAL(N) - INTEGER :: i - - IF (ITOL==0) THEN - DO i=1,N - SCAL(i)= ONE/(AbsTol(1)+RelTol(1)*ABS(Y(i))) - END DO - ELSE - DO i=1,N - SCAL(i)=ONE/(AbsTol(i)+RelTol(i)*ABS(Y(i))) - END DO - END IF - - END SUBROUTINE RK_ErrorScale - - -!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! SUBROUTINE RK_Transform(N,Tr,Z1,Z2,Z3,W1,W2,W3) -!!~~~> W <-- Tr x Z -!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! IMPLICIT NONE -! INTEGER :: N, i -! KPP_REAL :: Tr(3,3),Z1(N),Z2(N),Z3(N),W1(N),W2(N),W3(N) -! KPP_REAL :: x1, x2, x3 -! DO i=1,N -! x1 = Z1(i); x2 = Z2(i); x3 = Z3(i) -! W1(i) = Tr(1,1)*x1 + Tr(1,2)*x2 + Tr(1,3)*x3 -! W2(i) = Tr(2,1)*x1 + Tr(2,2)*x2 + Tr(2,3)*x3 -! W3(i) = Tr(3,1)*x1 + Tr(3,2)*x2 + Tr(3,3)*x3 -! END DO -! END SUBROUTINE RK_Transform - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE RK_Interpolate(action,N,H,Hold,Z1,Z2,Z3,CONT) -!~~~> Constructs or evaluates a quadratic polynomial -! that interpolates the Z solution at current step -! and provides starting values for the next step -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - INTEGER :: N, i - KPP_REAL :: H,Hold,Z1(N),Z2(N),Z3(N),CONT(N,3) - KPP_REAL :: r, x1, x2, x3, den - CHARACTER(LEN=4) :: action - - SELECT CASE (action) - CASE ('make') - ! Construct the solution quadratic interpolant Q(c_i) = Z_i, i=1:3 - den = (rkC(3)-rkC(2))*(rkC(2)-rkC(1))*(rkC(1)-rkC(3)) - DO i=1,N - CONT(i,1)=(-rkC(3)**2*rkC(2)*Z1(i)+Z3(i)*rkC(2)*rkC(1)**2 & - +rkC(2)**2*rkC(3)*Z1(i)-rkC(2)**2*rkC(1)*Z3(i) & - +rkC(3)**2*rkC(1)*Z2(i)-Z2(i)*rkC(3)*rkC(1)**2)& - /den-Z3(i) - CONT(i,2)= -( rkC(1)**2*(Z3(i)-Z2(i)) + rkC(2)**2*(Z1(i) & - -Z3(i)) +rkC(3)**2*(Z2(i)-Z1(i)) )/den - CONT(i,3)= ( rkC(1)*(Z3(i)-Z2(i)) + rkC(2)*(Z1(i)-Z3(i)) & - +rkC(3)*(Z2(i)-Z1(i)) )/den - END DO - CASE ('eval') - ! Evaluate quadratic polynomial - r = H/Hold - x1 = ONE + rkC(1)*r - x2 = ONE + rkC(2)*r - x3 = ONE + rkC(3)*r - DO i=1,N - Z1(i) = CONT(i,1)+x1*(CONT(i,2)+x1*CONT(i,3)) - Z2(i) = CONT(i,1)+x2*(CONT(i,2)+x2*CONT(i,3)) - Z3(i) = CONT(i,1)+x3*(CONT(i,2)+x3*CONT(i,3)) - END DO - END SELECT - END SUBROUTINE RK_Interpolate - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE RK_PrepareRHS(N,T,H,Y,Z1,Z2,Z3,R1,R2,R3) -!~~~> Prepare the right-hand side for Newton iterations -! R = Z - hA x F -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - - INTEGER :: N - KPP_REAL :: T,H - KPP_REAL, DIMENSION(N) :: Y,Z1,Z2,Z3,F,R1,R2,R3,TMP - - CALL WCOPY(N,Z1,1,R1,1) ! R1 <- Z1 - CALL WCOPY(N,Z2,1,R2,1) ! R2 <- Z2 - CALL WCOPY(N,Z3,1,R3,1) ! R3 <- Z3 - - CALL WADD(N,Y,Z1,TMP) ! TMP <- Y + Z1 - CALL FUN_CHEM(T+rkC(1)*H,TMP,F) ! F1 <- Fun(Y+Z1) - CALL WAXPY(N,-H*rkA(1,1),F,1,R1,1) ! R1 <- R1 - h*A_11*F1 - CALL WAXPY(N,-H*rkA(2,1),F,1,R2,1) ! R2 <- R2 - h*A_21*F1 - CALL WAXPY(N,-H*rkA(3,1),F,1,R3,1) ! R3 <- R3 - h*A_31*F1 - - CALL WADD(N,Y,Z2,TMP) ! TMP <- Y + Z2 - CALL FUN_CHEM(T+rkC(2)*H,TMP,F) ! F2 <- Fun(Y+Z2) - CALL WAXPY(N,-H*rkA(1,2),F,1,R1,1) ! R1 <- R1 - h*A_12*F2 - CALL WAXPY(N,-H*rkA(2,2),F,1,R2,1) ! R2 <- R2 - h*A_22*F2 - CALL WAXPY(N,-H*rkA(3,2),F,1,R3,1) ! R3 <- R3 - h*A_32*F2 - - CALL WADD(N,Y,Z3,TMP) ! TMP <- Y + Z3 - CALL FUN_CHEM(T+rkC(3)*H,TMP,F) ! F3 <- Fun(Y+Z3) - CALL WAXPY(N,-H*rkA(1,3),F,1,R1,1) ! R1 <- R1 - h*A_13*F3 - CALL WAXPY(N,-H*rkA(2,3),F,1,R2,1) ! R2 <- R2 - h*A_23*F3 - CALL WAXPY(N,-H*rkA(3,3),F,1,R3,1) ! R3 <- R3 - h*A_33*F3 - - END SUBROUTINE RK_PrepareRHS - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE RK_PrepareRHS_Adj(N,H,Jac1,Jac2,Jac3,Lambda, & - U1,U2,U3,G1,G2,G3,R1,R2,R3) -!~~~> Prepare the right-hand side for Newton iterations -! R = Z_adj - hA x Jac*Z_adj - h J^t b lambda -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - - INTEGER, INTENT(IN) :: N - KPP_REAL, INTENT(IN) :: H - KPP_REAL, DIMENSION(N), INTENT(IN) :: U1,U2,U3,Lambda,G1,G2,G3 - KPP_REAL, DIMENSION(N), INTENT(OUT) :: R1,R2,R3 -#ifdef FULL_ALGEBRA - KPP_REAL, DIMENSION(N,N), INTENT(IN) :: Jac1, Jac2, Jac3 -#else - KPP_REAL, DIMENSION(LU_NONZERO),INTENT(IN) :: Jac1, Jac2, Jac3 -#endif - KPP_REAL, DIMENSION(N) :: F,TMP - - - CALL WCOPY(N,G1,1,R1,1) ! R1 <- G1 - CALL WCOPY(N,G2,1,R2,1) ! R2 <- G2 - CALL WCOPY(N,G3,1,R3,1) ! R3 <- G3 - - CALL SET2ZERO(N,F) - CALL WAXPY(N,-H*rkA(1,1),U1,1,F,1) ! F1 <- -h*A_11*U1 - CALL WAXPY(N,-H*rkA(2,1),U2,1,F,1) ! F1 <- F1 - h*A_21*U2 - CALL WAXPY(N,-H*rkA(3,1),U3,1,F,1) ! F1 <- F1 - h*A_31*U3 -#ifdef FULL_ALGEBRA - TMP = MATMUL(TRANSPOSE(Jac1),F) -#else - CALL JacTR_SP_Vec ( Jac1, F, TMP ) ! R1 <- -Jac(Y+Z1)^t*h*sum(A_j1*U_j) -#endif - CALL WAXPY(N,ONE,U1,1,TMP,1) ! R1 <- U1 -Jac(Y+Z1)^t*h*sum(A_j1*U_j) - CALL WAXPY(N,ONE,TMP,1,R1,1) ! R1 <- U1 -Jac(Y+Z1)^t*h*sum(A_j1*U_j) - - CALL SET2ZERO(N,F) - CALL WAXPY(N,-H*rkA(1,2),U1,1,F,1) ! F2 <- -h*A_11*U1 - CALL WAXPY(N,-H*rkA(2,2),U2,1,F,1) ! F2 <- F2 - h*A_21*U2 - CALL WAXPY(N,-H*rkA(3,2),U3,1,F,1) ! F2 <- F2 - h*A_31*U3 -#ifdef FULL_ALGEBRA - TMP = MATMUL(TRANSPOSE(Jac2),F) -#else - CALL JacTR_SP_Vec ( Jac2, F, TMP ) ! R2 <- -Jac(Y+Z2)^t*h*sum(A_j2*U_j) -#endif - CALL WAXPY(N,ONE,U2,1,TMP,1) ! R2 <- U2 -Jac(Y+Z2)^t*h*sum(A_j2*U_j) - CALL WAXPY(N,ONE,TMP,1,R2,1) ! R2 <- U2 -Jac(Y+Z2)^t*h*sum(A_j2*U_j) - - CALL SET2ZERO(N,F) - CALL WAXPY(N,-H*rkA(1,3),U1,1,F,1) ! F3 <- -h*A_11*U1 - CALL WAXPY(N,-H*rkA(2,3),U2,1,F,1) ! F3 <- F3 - h*A_21*U2 - CALL WAXPY(N,-H*rkA(3,3),U3,1,F,1) ! F3 <- F3 - h*A_31*U3 -#ifdef FULL_ALGEBRA - TMP = MATMUL(TRANSPOSE(Jac3),F) -#else - CALL JacTR_SP_Vec ( Jac3, F, TMP ) ! R3 <- -Jac(Y+Z3)^t*h*sum(A_j3*U_j) -#endif - CALL WAXPY(N,ONE,U3,1,TMP,1) ! R3 <- U3 -Jac(Y+Z3)^t*h*sum(A_j3*U_j) - CALL WAXPY(N,ONE,TMP,1,R3,1) ! R3 <- U3 -Jac(Y+Z3)^t*h*sum(A_j3*U_j) - - - END SUBROUTINE RK_PrepareRHS_Adj - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE RK_PrepareRHS_G(N,H,Jac1,Jac2,Jac3,Lambda, & - G1,G2,G3) -!~~~> Prepare the right-hand side for Newton iterations -! R = Z_adj - hA x Jac*Z_adj - h J^t b lambda -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - - INTEGER, INTENT(IN) :: N - KPP_REAL, INTENT(IN) :: H - KPP_REAL, DIMENSION(N), INTENT(IN) :: Lambda - KPP_REAL, DIMENSION(N), INTENT(OUT) :: G1,G2,G3 -#ifdef FULL_ALGEBRA - KPP_REAL, DIMENSION(N,N), INTENT(IN) :: Jac1, Jac2, Jac3 -#else - KPP_REAL, DIMENSION(LU_NONZERO),INTENT(IN) :: Jac1, Jac2, Jac3 -#endif - KPP_REAL, DIMENSION(N) :: F - - CALL SET2ZERO(N,G1) - CALL SET2ZERO(N,G2) - CALL SET2ZERO(N,G3) -#ifdef FULL_ALGEBRA - F = MATMUL(TRANSPOSE(Jac1),Lambda) -#else - CALL JacTR_SP_Vec ( Jac1, Lambda, F ) ! F1 <- Jac(Y+Z1)^t*Lambda -#endif - CALL WAXPY(N,-H*rkB(1),F,1,G1,1) ! R1 <- R1 - h*B_1*F1 - -#ifdef FULL_ALGEBRA - F = MATMUL(TRANSPOSE(Jac2),Lambda) -#else - CALL JacTR_SP_Vec ( Jac2, Lambda, F ) ! F2 <- Jac(Y+Z2)^t*Lambda -#endif - CALL WAXPY(N,-H*rkB(2),F,1,G2,1) ! R2 <- R2 - h*B_2*F2 - -#ifdef FULL_ALGEBRA - F = MATMUL(TRANSPOSE(Jac3),Lambda) -#else - CALL JacTR_SP_Vec ( Jac3, Lambda, F ) ! F3 <- Jac(Y+Z3)^t*Lambda -#endif - CALL WAXPY(N,-H*rkB(3),F,1,G3,1) ! R3 <- R3 - h*B_3*F3 - - - END SUBROUTINE RK_PrepareRHS_G - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE RK_Decomp(N,H,FJAC,E1,IP1,E2,IP2,ISING) - !~~~> Compute the matrices E1 and E2 and their decompositions -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - - INTEGER :: N, ISING - KPP_REAL :: H, Alpha, Beta, Gamma -#ifdef FULL_ALGEBRA - KPP_REAL :: FJAC(N,N),E1(N,N) - COMPLEX(kind=dp) :: E2(N,N) -#else - KPP_REAL :: FJAC(LU_NONZERO),E1(LU_NONZERO) - COMPLEX(kind=dp) :: E2(LU_NONZERO) -#endif - INTEGER :: IP1(N), IP2(N), i, j - - Gamma = rkGamma/H - Alpha = rkAlpha/H - Beta = rkBeta /H - -#ifdef FULL_ALGEBRA - DO j=1,N - DO i=1,N - E1(i,j)=-FJAC(i,j) - END DO - E1(j,j)=E1(j,j)+Gamma - END DO - CALL DGETRF(N,N,E1,N,IP1,ISING) -#else - DO i=1,LU_NONZERO - E1(i)=-FJAC(i) - END DO - DO i=1,N - j=LU_DIAG(i); E1(j)=E1(j)+Gamma - END DO - CALL KppDecomp(E1,ISING) -#endif - - IF (ISING /= 0) THEN - ISTATUS(idec) = ISTATUS(idec) + 1 - RETURN - END IF - -#ifdef FULL_ALGEBRA - DO j=1,N - DO i=1,N - E2(i,j) = DCMPLX( -FJAC(i,j), ZERO ) - END DO - E2(j,j) = E2(j,j) + CMPLX( Alpha, Beta ) - END DO - CALL ZGETRF(N,N,E2,N,IP2,ISING) -#else - DO i=1,LU_NONZERO - E2(i) = DCMPLX( -FJAC(i), ZERO ) - END DO - DO i=1,N - j = LU_DIAG(i); E2(j)=E2(j) + CMPLX( Alpha, Beta ) - END DO - CALL KppDecompCmplx(E2,ISING) -#endif - ISTATUS(idec) = ISTATUS(idec) + 1 - - END SUBROUTINE RK_Decomp - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE RK_Solve(N,H,E1,IP1,E2,IP2,R1,R2,R3,ISING) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - INTEGER :: N,IP1(N),IP2(N),ISING -#ifdef FULL_ALGEBRA - KPP_REAL :: E1(N,N) - COMPLEX(kind=dp) :: E2(N,N) -#else - KPP_REAL :: E1(LU_NONZERO) - COMPLEX(kind=dp) :: E2(LU_NONZERO) -#endif - KPP_REAL :: R1(N),R2(N),R3(N) - KPP_REAL :: H, x1, x2, x3 - COMPLEX(kind=dp) :: BC(N) - INTEGER :: i -! - ! Z <- h^{-1) T^{-1) A^{-1) x Z - DO i=1,N - x1 = R1(i)/H; x2 = R2(i)/H; x3 = R3(i)/H - R1(i) = rkTinvAinv(1,1)*x1 + rkTinvAinv(1,2)*x2 + rkTinvAinv(1,3)*x3 - R2(i) = rkTinvAinv(2,1)*x1 + rkTinvAinv(2,2)*x2 + rkTinvAinv(2,3)*x3 - R3(i) = rkTinvAinv(3,1)*x1 + rkTinvAinv(3,2)*x2 + rkTinvAinv(3,3)*x3 - END DO - -#ifdef FULL_ALGEBRA - CALL DGETRS ('N',N,1,E1,N,IP1,R1,N,0) -#else - CALL KppSolve (E1,R1) -#endif -! - DO i=1,N - BC(i) = DCMPLX(R2(i),R3(i)) - END DO -#ifdef FULL_ALGEBRA - CALL ZGETRS ('N',N,1,E2,N,IP2,BC,N,0) -#else - CALL KppSolveCmplx (E2,BC) -#endif - DO i=1,N - R2(i) = DBLE( BC(i) ) - R3(i) = AIMAG( BC(i) ) - END DO - - ! Z <- T x Z - DO i=1,N - x1 = R1(i); x2 = R2(i); x3 = R3(i) - R1(i) = rkT(1,1)*x1 + rkT(1,2)*x2 + rkT(1,3)*x3 - R2(i) = rkT(2,1)*x1 + rkT(2,2)*x2 + rkT(2,3)*x3 - R3(i) = rkT(3,1)*x1 + rkT(3,2)*x2 + rkT(3,3)*x3 - END DO - - ISTATUS(isol) = ISTATUS(isol) + 1 - - END SUBROUTINE RK_Solve - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE RK_SolveTR(N,H,E1,IP1,E2,IP2,R1,R2,R3,ISING) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - INTEGER, INTENT(IN) :: N,IP1(N),IP2(N) - INTEGER, INTENT(OUT) :: ISING -#ifdef FULL_ALGEBRA - KPP_REAL, INTENT(IN) :: E1(N,N) - COMPLEX(kind=dp), INTENT(IN) :: E2(N,N) -#else - KPP_REAL, INTENT(IN) :: E1(LU_NONZERO) - COMPLEX(kind=dp), INTENT(IN) :: E2(LU_NONZERO) -#endif - KPP_REAL, INTENT(INOUT) :: R1(N),R2(N),R3(N) - KPP_REAL :: H, x1, x2, x3 - COMPLEX(kind=dp) :: BC(N) - INTEGER :: i -! - ! RHS <- h^{-1) (A^{-1) T^{-1))^t x RHS - DO i=1,N - x1 = R1(i)/H; x2 = R2(i)/H; x3 = R3(i)/H - R1(i) = rkAinvT(1,1)*x1 + rkAinvT(2,1)*x2 + rkAinvT(3,1)*x3 - R2(i) = rkAinvT(1,2)*x1 + rkAinvT(2,2)*x2 + rkAinvT(3,2)*x3 - R3(i) = rkAinvT(1,3)*x1 + rkAinvT(2,3)*x2 + rkAinvT(3,3)*x3 - END DO - -#ifdef FULL_ALGEBRA - CALL DGETRS ('T',N,1,E1,N,IP1,R1,N,0) -#else - CALL KppSolveTR (E1,R1,R1) -#endif -! - DO i=1,N - BC(i) = DCMPLX(R2(i),-R3(i)) - END DO -#ifdef FULL_ALGEBRA - CALL ZGETRS ('T',N,1,E2,N,IP2,BC,N,0) -#else - CALL KppSolveTRCmplx (E2,BC) -#endif - DO i=1,N - R2(i) = DBLE( BC(i) ) - R3(i) = -AIMAG( BC(i) ) - END DO - - ! X <- (T^{-1})^t x X - DO i=1,N - x1 = R1(i); x2 = R2(i); x3 = R3(i) - R1(i) = rkTinv(1,1)*x1 + rkTinv(2,1)*x2 + rkTinv(3,1)*x3 - R2(i) = rkTinv(1,2)*x1 + rkTinv(2,2)*x2 + rkTinv(3,2)*x3 - R3(i) = rkTinv(1,3)*x1 + rkTinv(2,3)*x2 + rkTinv(3,3)*x3 - END DO - - ISTATUS(isol) = ISTATUS(isol) + 1 - - END SUBROUTINE RK_SolveTR - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE RK_ErrorEstimate(N,H,Y,T, & - E1,IP1,Z1,Z2,Z3,SCAL,Err, & - FirstStep,Reject) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - - INTEGER :: N -#ifdef FULL_ALGEBRA - KPP_REAL :: E1(N,N) -#else - KPP_REAL :: E1(LU_NONZERO) -#endif - KPP_REAL :: SCAL(N),Z1(N),Z2(N),Z3(N),F1(N),F2(N), & - F0(N),Y(N),TMP(N),T,H - INTEGER :: IP1(N), i - LOGICAL FirstStep,Reject - KPP_REAL :: HEE1,HEE2,HEE3,Err - - HEE1 = rkE(1)/H - HEE2 = rkE(2)/H - HEE3 = rkE(3)/H - - CALL FUN_CHEM(T,Y,F0) - ISTATUS(ifun) = ISTATUS(ifun) + 1 - - DO i=1,N - F2(i) = HEE1*Z1(i)+HEE2*Z2(i)+HEE3*Z3(i) - TMP(i) = rkE(0)*F0(i) + F2(i) - END DO - -#ifdef FULL_ALGEBRA - CALL DGETRS ('N',N,1,E1,N,IP1,TMP,N,0) - IF ((rkMethod==R1A).OR.(rkMethod==GAU).OR.(rkMethod==L3A)) CALL DGETRS ('N',N,1,E1,N,IP1,TMP,N,0) - IF (rkMethod==GAU) CALL DGETRS ('N',N,1,E1,N,IP1,TMP,N,0) -#else - CALL KppSolve (E1, TMP) - IF ((rkMethod==R1A).OR.(rkMethod==GAU).OR.(rkMethod==L3A)) CALL KppSolve (E1,TMP) - IF (rkMethod==GAU) CALL KppSolve (E1,TMP) -#endif - - Err = RK_ErrorNorm(N,SCAL,TMP) -! - IF (Err < ONE) RETURN -firej:IF (FirstStep.OR.Reject) THEN - DO i=1,N - TMP(i)=Y(i)+TMP(i) - END DO - CALL FUN_CHEM(T,TMP,F1) - ISTATUS(ifun) = ISTATUS(ifun) + 1 - DO i=1,N - TMP(i)=F1(i)+F2(i) - END DO - -#ifdef FULL_ALGEBRA - CALL DGETRS ('N',N,1,E1,N,IP1,TMP,N,0) -#else - CALL KppSolve (E1, TMP) -#endif - Err = RK_ErrorNorm(N,SCAL,TMP) - END IF firej - - END SUBROUTINE RK_ErrorEstimate - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - KPP_REAL FUNCTION RK_ErrorNorm(N,SCAL,DY) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - - INTEGER :: N - KPP_REAL :: SCAL(N),DY(N) - INTEGER :: i - - RK_ErrorNorm = ZERO - DO i=1,N - RK_ErrorNorm = RK_ErrorNorm + (DY(i)*SCAL(i))**2 - END DO - RK_ErrorNorm = MAX( SQRT(RK_ErrorNorm/N), 1.0d-10 ) - - END FUNCTION RK_ErrorNorm - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Radau2A_Coefficients -! The coefficients of the 3-stage Radau-2A method -! (given to ~30 accurate digits) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE -! The coefficients of the Radau2A method - KPP_REAL :: b0 - -! b0 = 1.0d0 - IF (SdirkError) THEN - b0 = 0.2d-1 - ELSE - b0 = 0.5d-1 - END IF - -! The coefficients of the Radau2A method - rkMethod = R2A - - rkA(1,1) = 1.968154772236604258683861429918299d-1 - rkA(1,2) = -6.55354258501983881085227825696087d-2 - rkA(1,3) = 2.377097434822015242040823210718965d-2 - rkA(2,1) = 3.944243147390872769974116714584975d-1 - rkA(2,2) = 2.920734116652284630205027458970589d-1 - rkA(2,3) = -4.154875212599793019818600988496743d-2 - rkA(3,1) = 3.764030627004672750500754423692808d-1 - rkA(3,2) = 5.124858261884216138388134465196080d-1 - rkA(3,3) = 1.111111111111111111111111111111111d-1 - - rkB(1) = 3.764030627004672750500754423692808d-1 - rkB(2) = 5.124858261884216138388134465196080d-1 - rkB(3) = 1.111111111111111111111111111111111d-1 - - rkC(1) = 1.550510257216821901802715925294109d-1 - rkC(2) = 6.449489742783178098197284074705891d-1 - rkC(3) = 1.0d0 - - ! New solution: H* Sum B_j*f(Z_j) = Sum D_j*Z_j - rkD(1) = 0.0d0 - rkD(2) = 0.0d0 - rkD(3) = 1.0d0 - - ! Classical error estimator: - ! H* Sum (B_j-Bhat_j)*f(Z_j) = H*E(0)*f(0) + Sum E_j*Z_j - rkE(0) = 1.0d0*b0 - rkE(1) = -10.04880939982741556246032950764708d0*b0 - rkE(2) = 1.382142733160748895793662840980412d0*b0 - rkE(3) = -.3333333333333333333333333333333333d0*b0 - - ! Sdirk error estimator - rkBgam(0) = b0 - rkBgam(1) = .3764030627004672750500754423692807d0-1.558078204724922382431975370686279d0*b0 - rkBgam(2) = .8914115380582557157653087040196118d0*b0+.5124858261884216138388134465196077d0 - rkBgam(3) = -.1637777184845662566367174924883037d0-.3333333333333333333333333333333333d0*b0 - rkBgam(4) = .2748888295956773677478286035994148d0 - - ! H* Sum Bgam_j*f(Z_j) = H*Bgam(0)*f(0) + Sum Theta_j*Z_j - rkTheta(1) = -1.520677486405081647234271944611547d0-10.04880939982741556246032950764708d0*b0 - rkTheta(2) = 2.070455145596436382729929151810376d0+1.382142733160748895793662840980413d0*b0 - rkTheta(3) = -.3333333333333333333333333333333333d0*b0-.3744441479783868387391430179970741d0 - - ! Local order of error estimator - IF (b0==0.0d0) THEN - rkELO = 6.0d0 - ELSE - rkELO = 4.0d0 - END IF - - !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - !~~~> Diagonalize the RK matrix: - ! rkTinv * inv(rkA) * rkT = - ! | rkGamma 0 0 | - ! | 0 rkAlpha -rkBeta | - ! | 0 rkBeta rkAlpha | - !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - rkGamma = 3.637834252744495732208418513577775d0 - rkAlpha = 2.681082873627752133895790743211112d0 - rkBeta = 3.050430199247410569426377624787569d0 - - rkT(1,1) = 9.443876248897524148749007950641664d-2 - rkT(1,2) = -1.412552950209542084279903838077973d-1 - rkT(1,3) = -3.00291941051474244918611170890539d-2 - rkT(2,1) = 2.502131229653333113765090675125018d-1 - rkT(2,2) = 2.041293522937999319959908102983381d-1 - rkT(2,3) = 3.829421127572619377954382335998733d-1 - rkT(3,1) = 1.0d0 - rkT(3,2) = 1.0d0 - rkT(3,3) = 0.0d0 - - rkTinv(1,1) = 4.178718591551904727346462658512057d0 - rkTinv(1,2) = 3.27682820761062387082533272429617d-1 - rkTinv(1,3) = 5.233764454994495480399309159089876d-1 - rkTinv(2,1) = -4.178718591551904727346462658512057d0 - rkTinv(2,2) = -3.27682820761062387082533272429617d-1 - rkTinv(2,3) = 4.766235545005504519600690840910124d-1 - rkTinv(3,1) = -5.02872634945786875951247343139544d-1 - rkTinv(3,2) = 2.571926949855605429186785353601676d0 - rkTinv(3,3) = -5.960392048282249249688219110993024d-1 - - rkTinvAinv(1,1) = 1.520148562492775501049204957366528d+1 - rkTinvAinv(1,2) = 1.192055789400527921212348994770778d0 - rkTinvAinv(1,3) = 1.903956760517560343018332287285119d0 - rkTinvAinv(2,1) = -9.669512977505946748632625374449567d0 - rkTinvAinv(2,2) = -8.724028436822336183071773193986487d0 - rkTinvAinv(2,3) = 3.096043239482439656981667712714881d0 - rkTinvAinv(3,1) = -1.409513259499574544876303981551774d+1 - rkTinvAinv(3,2) = 5.895975725255405108079130152868952d0 - rkTinvAinv(3,3) = -1.441236197545344702389881889085515d-1 - - rkAinvT(1,1) = .3435525649691961614912493915818282d0 - rkAinvT(1,2) = -.4703191128473198422370558694426832d0 - rkAinvT(1,3) = .3503786597113668965366406634269080d0 - rkAinvT(2,1) = .9102338692094599309122768354288852d0 - rkAinvT(2,2) = 1.715425895757991796035292755937326d0 - rkAinvT(2,3) = .4040171993145015239277111187301784d0 - rkAinvT(3,1) = 3.637834252744495732208418513577775d0 - rkAinvT(3,2) = 2.681082873627752133895790743211112d0 - rkAinvT(3,3) = -3.050430199247410569426377624787569d0 - - END SUBROUTINE Radau2A_Coefficients - - - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Lobatto3C_Coefficients -! The coefficients of the 3-stage Lobatto-3C method -! (given to ~30 accurate digits) -! The parameter b0 can be chosen to tune the error estimator -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - KPP_REAL :: b0 - - rkMethod = L3C - -! b0 = 1.0d0 - IF (SdirkError) THEN - b0 = 0.2d0 - ELSE - b0 = 0.5d0 - END IF -! The coefficients of the Lobatto3C method - - rkA(1,1) = .1666666666666666666666666666666667d0 - rkA(1,2) = -.3333333333333333333333333333333333d0 - rkA(1,3) = .1666666666666666666666666666666667d0 - rkA(2,1) = .1666666666666666666666666666666667d0 - rkA(2,2) = .4166666666666666666666666666666667d0 - rkA(2,3) = -.8333333333333333333333333333333333d-1 - rkA(3,1) = .1666666666666666666666666666666667d0 - rkA(3,2) = .6666666666666666666666666666666667d0 - rkA(3,3) = .1666666666666666666666666666666667d0 - - rkB(1) = .1666666666666666666666666666666667d0 - rkB(2) = .6666666666666666666666666666666667d0 - rkB(3) = .1666666666666666666666666666666667d0 - - rkC(1) = 0.0d0 - rkC(2) = 0.5d0 - rkC(3) = 1.0d0 - - ! Classical error estimator, embedded solution: - rkBhat(0) = b0 - rkBhat(1) = .16666666666666666666666666666666667d0-b0 - rkBhat(2) = .66666666666666666666666666666666667d0 - rkBhat(3) = .16666666666666666666666666666666667d0 - - ! New solution: h Sum_j b_j f(Z_j) = sum d_j Z_j - rkD(1) = 0.0d0 - rkD(2) = 0.0d0 - rkD(3) = 1.0d0 - - ! Classical error estimator: - ! H* Sum (B_j-Bhat_j)*f(Z_j) = H*E(0)*f(0) + Sum E_j*Z_j - rkE(0) = .3808338772072650364017425226487022*b0 - rkE(1) = -1.142501631621795109205227567946107*b0 - rkE(2) = -1.523335508829060145606970090594809*b0 - rkE(3) = .3808338772072650364017425226487022*b0 - - ! Sdirk error estimator - rkBgam(0) = b0 - rkBgam(1) = .1666666666666666666666666666666667d0-1.d0*b0 - rkBgam(2) = .6666666666666666666666666666666667d0 - rkBgam(3) = -.2141672105405983697350758559820354d0 - rkBgam(4) = .3808338772072650364017425226487021d0 - - ! H* Sum Bgam_j*f(Z_j) = H*Bgam(0)*f(0) + Sum Theta_j*Z_j - rkTheta(1) = -3.d0*b0-.3808338772072650364017425226487021d0 - rkTheta(2) = -4.d0*b0+1.523335508829060145606970090594808d0 - rkTheta(3) = -.142501631621795109205227567946106d0+b0 - - ! Local order of error estimator - IF (b0==0.0d0) THEN - rkELO = 5.0d0 - ELSE - rkELO = 4.0d0 - END IF - - !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - !~~~> Diagonalize the RK matrix: - ! rkTinv * inv(rkA) * rkT = - ! | rkGamma 0 0 | - ! | 0 rkAlpha -rkBeta | - ! | 0 rkBeta rkAlpha | - !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - rkGamma = 2.625816818958466716011888933765284d0 - rkAlpha = 1.687091590520766641994055533117359d0 - rkBeta = 2.508731754924880510838743672432351d0 - - rkT(1,1) = 1.d0 - rkT(1,2) = 1.d0 - rkT(1,3) = 0.d0 - rkT(2,1) = .4554100411010284672111720348287483d0 - rkT(2,2) = -.6027050205505142336055860174143743d0 - rkT(2,3) = -.4309321229203225731070721341350346d0 - rkT(3,1) = 2.195823345445647152832799205549709d0 - rkT(3,2) = -1.097911672722823576416399602774855d0 - rkT(3,3) = .7850032632435902184104551358922130d0 - - rkTinv(1,1) = .4205559181381766909344950150991349d0 - rkTinv(1,2) = .3488903392193734304046467270632057d0 - rkTinv(1,3) = .1915253879645878102698098373933487d0 - rkTinv(2,1) = .5794440818618233090655049849008650d0 - rkTinv(2,2) = -.3488903392193734304046467270632057d0 - rkTinv(2,3) = -.1915253879645878102698098373933487d0 - rkTinv(3,1) = -.3659705575742745254721332009249516d0 - rkTinv(3,2) = -1.463882230297098101888532803699806d0 - rkTinv(3,3) = .4702733607340189781407813565524989d0 - - rkTinvAinv(1,1) = 1.104302803159744452668648155627548d0 - rkTinvAinv(1,2) = .916122120694355522658740710823143d0 - rkTinvAinv(1,3) = .5029105849749601702795812241441172d0 - rkTinvAinv(2,1) = 1.895697196840255547331351844372453d0 - rkTinvAinv(2,2) = 3.083877879305644477341259289176857d0 - rkTinvAinv(2,3) = -1.502910584974960170279581224144117d0 - rkTinvAinv(3,1) = .8362439183082935036129145574774502d0 - rkTinvAinv(3,2) = -3.344975673233174014451658229909802d0 - rkTinvAinv(3,3) = .312908409479233358005944466882642d0 - - rkAinvT(1,1) = 2.625816818958466716011888933765282d0 - rkAinvT(1,2) = 1.687091590520766641994055533117358d0 - rkAinvT(1,3) = -2.508731754924880510838743672432351d0 - rkAinvT(2,1) = 1.195823345445647152832799205549710d0 - rkAinvT(2,2) = -2.097911672722823576416399602774855d0 - rkAinvT(2,3) = .7850032632435902184104551358922130d0 - rkAinvT(3,1) = 5.765829871932827589653709477334136d0 - rkAinvT(3,2) = .1170850640335862051731452613329320d0 - rkAinvT(3,3) = 4.078738281412060947659653944216779d0 - - END SUBROUTINE Lobatto3C_Coefficients - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Gauss_Coefficients -! The coefficients of the 3-stage Gauss method -! (given to ~30 accurate digits) -! The parameter b3 can be chosen by the user -! to tune the error estimator -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - KPP_REAL :: b0 -! The coefficients of the Gauss method - - - rkMethod = GAU - -! b0 = 4.0d0 - b0 = 0.1d0 - -! The coefficients of the Gauss method - - rkA(1,1) = .1388888888888888888888888888888889d0 - rkA(1,2) = -.359766675249389034563954710966045d-1 - rkA(1,3) = .97894440153083260495800422294756d-2 - rkA(2,1) = .3002631949808645924380249472131556d0 - rkA(2,2) = .2222222222222222222222222222222222d0 - rkA(2,3) = -.224854172030868146602471694353778d-1 - rkA(3,1) = .2679883337624694517281977355483022d0 - rkA(3,2) = .4804211119693833479008399155410489d0 - rkA(3,3) = .1388888888888888888888888888888889d0 - - rkB(1) = .2777777777777777777777777777777778d0 - rkB(2) = .4444444444444444444444444444444444d0 - rkB(3) = .2777777777777777777777777777777778d0 - - rkC(1) = .1127016653792583114820734600217600d0 - rkC(2) = .5000000000000000000000000000000000d0 - rkC(3) = .8872983346207416885179265399782400d0 - - ! Classical error estimator, embedded solution: - rkBhat(0) = b0 - rkBhat(1) =-1.4788305577012361475298775666303999d0*b0 & - +.27777777777777777777777777777777778d0 - rkBhat(2) = .44444444444444444444444444444444444d0 & - +.66666666666666666666666666666666667d0*b0 - rkBhat(3) = -.18783610896543051913678910003626672d0*b0 & - +.27777777777777777777777777777777778d0 - - ! New solution: h Sum_j b_j f(Z_j) = sum d_j Z_j - rkD(1) = .1666666666666666666666666666666667d1 - rkD(2) = -.1333333333333333333333333333333333d1 - rkD(3) = .1666666666666666666666666666666667d1 - - ! Classical error estimator: - ! H* Sum (B_j-Bhat_j)*f(Z_j) = H*E(0)*f(0) + Sum E_j*Z_j - rkE(0) = .2153144231161121782447335303806954d0*b0 - rkE(1) = -2.825278112319014084275808340593191d0*b0 - rkE(2) = .2870858974881495709929780405075939d0*b0 - rkE(3) = -.4558086256248162565397206448274867d-1*b0 - - ! Sdirk error estimator - rkBgam(0) = 0.d0 - rkBgam(1) = .2373339543355109188382583162660537d0 - rkBgam(2) = .5879873931885192299409334646982414d0 - rkBgam(3) = -.4063577064014232702392531134499046d-1 - rkBgam(4) = .2153144231161121782447335303806955d0 - - ! H* Sum Bgam_j*f(Z_j) = H*Bgam(0)*f(0) + Sum Theta_j*Z_j - rkTheta(1) = -2.594040933093095272574031876464493d0 - rkTheta(2) = 1.824611539036311947589425112250199d0 - rkTheta(3) = .1856563166634371860478043996459493d0 - - ! ELO = local order of classical error estimator - rkELO = 4.0d0 - - !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - !~~~> Diagonalize the RK matrix: - ! rkTinv * inv(rkA) * rkT = - ! | rkGamma 0 0 | - ! | 0 rkAlpha -rkBeta | - ! | 0 rkBeta rkAlpha | - !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - rkGamma = 4.644370709252171185822941421408064d0 - rkAlpha = 3.677814645373914407088529289295970d0 - rkBeta = 3.508761919567443321903661209182446d0 - - rkT(1,1) = .7215185205520017032081769924397664d-1 - rkT(1,2) = -.8224123057363067064866206597516454d-1 - rkT(1,3) = -.6012073861930850173085948921439054d-1 - rkT(2,1) = .1188325787412778070708888193730294d0 - rkT(2,2) = .5306509074206139504614411373957448d-1 - rkT(2,3) = .3162050511322915732224862926182701d0 - rkT(3,1) = 1.d0 - rkT(3,2) = 1.d0 - rkT(3,3) = 0.d0 - - rkTinv(1,1) = 5.991698084937800775649580743981285d0 - rkTinv(1,2) = 1.139214295155735444567002236934009d0 - rkTinv(1,3) = .4323121137838583855696375901180497d0 - rkTinv(2,1) = -5.991698084937800775649580743981285d0 - rkTinv(2,2) = -1.139214295155735444567002236934009d0 - rkTinv(2,3) = .5676878862161416144303624098819503d0 - rkTinv(3,1) = -1.246213273586231410815571640493082d0 - rkTinv(3,2) = 2.925559646192313662599230367054972d0 - rkTinv(3,3) = -.2577352012734324923468722836888244d0 - - rkTinvAinv(1,1) = 27.82766708436744962047620566703329d0 - rkTinvAinv(1,2) = 5.290933503982655311815946575100597d0 - rkTinvAinv(1,3) = 2.007817718512643701322151051660114d0 - rkTinvAinv(2,1) = -17.66368928942422710690385180065675d0 - rkTinvAinv(2,2) = -14.45491129892587782538830044147713d0 - rkTinvAinv(2,3) = 2.992182281487356298677848948339886d0 - rkTinvAinv(3,1) = -25.60678350282974256072419392007303d0 - rkTinvAinv(3,2) = 6.762434375611708328910623303779923d0 - rkTinvAinv(3,3) = 1.043979339483109825041215970036771d0 - - rkAinvT(1,1) = .3350999483034677402618981153470483d0 - rkAinvT(1,2) = -.5134173605009692329246186488441294d0 - rkAinvT(1,3) = .6745196507033116204327635673208923d-1 - rkAinvT(2,1) = .5519025480108928886873752035738885d0 - rkAinvT(2,2) = 1.304651810077110066076640761092008d0 - rkAinvT(2,3) = .9767507983414134987545585703726984d0 - rkAinvT(3,1) = 4.644370709252171185822941421408064d0 - rkAinvT(3,2) = 3.677814645373914407088529289295970d0 - rkAinvT(3,3) = -3.508761919567443321903661209182446d0 - - END SUBROUTINE Gauss_Coefficients - - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Radau1A_Coefficients -! The coefficients of the 3-stage Gauss method -! (given to ~30 accurate digits) -! The parameter b3 can be chosen by the user -! to tune the error estimator -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE -! KPP_REAL :: b0 = 0.3d0 - KPP_REAL :: b0 = 0.1d0 - -! The coefficients of the Radau1A method - - rkMethod = R1A - - rkA(1,1) = .1111111111111111111111111111111111d0 - rkA(1,2) = -.1916383190435098943442935597058829d0 - rkA(1,3) = .8052720793239878323318244859477174d-1 - rkA(2,1) = .1111111111111111111111111111111111d0 - rkA(2,2) = .2920734116652284630205027458970589d0 - rkA(2,3) = -.481334970546573839513422644787591d-1 - rkA(3,1) = .1111111111111111111111111111111111d0 - rkA(3,2) = .5370223859435462728402311533676479d0 - rkA(3,3) = .1968154772236604258683861429918299d0 - - rkB(1) = .1111111111111111111111111111111111d0 - rkB(2) = .5124858261884216138388134465196080d0 - rkB(3) = .3764030627004672750500754423692808d0 - - rkC(1) = 0.d0 - rkC(2) = .3550510257216821901802715925294109d0 - rkC(3) = .8449489742783178098197284074705891d0 - - ! Classical error estimator, embedded solution: - rkBhat(0) = b0 - rkBhat(1) = .11111111111111111111111111111111111d0-b0 - rkBhat(2) = .51248582618842161383881344651960810d0 - rkBhat(3) = .37640306270046727505007544236928079d0 - - ! New solution: H* Sum B_j*f(Z_j) = Sum D_j*Z_j - rkD(1) = .3333333333333333333333333333333333d0 - rkD(2) = -.8914115380582557157653087040196127d0 - rkD(3) = .1558078204724922382431975370686279d1 - - ! Classical error estimator: - ! H* Sum (b_j-bhat_j) f(Z_j) = H*E(0)*F(0) + Sum E_j Z_j - rkE(0) = .2748888295956773677478286035994148d0*b0 - rkE(1) = -1.374444147978386838739143017997074d0*b0 - rkE(2) = -1.335337922441686804550326197041126d0*b0 - rkE(3) = .235782604058977333559011782643466d0*b0 - - ! Sdirk error estimator - rkBgam(0) = 0.0d0 - rkBgam(1) = .1948150124588532186183490991130616d-1 - rkBgam(2) = .7575249005733381398986810981093584d0 - rkBgam(3) = -.518952314149008295083446116200793d-1 - rkBgam(4) = .2748888295956773677478286035994148d0 - - ! H* Sum Bgam_j*f(Z_j) = H*Bgam(0)*f(0) + Sum Theta_j*Z_j - rkTheta(1) = -1.224370034375505083904362087063351d0 - rkTheta(2) = .9340045331532641409047527962010133d0 - rkTheta(3) = .4656990124352088397561234800640929d0 - - ! ELO = local order of classical error estimator - rkELO = 4.0d0 - - !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - !~~~> Diagonalize the RK matrix: - ! rkTinv * inv(rkA) * rkT = - ! | rkGamma 0 0 | - ! | 0 rkAlpha -rkBeta | - ! | 0 rkBeta rkAlpha | - !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - rkGamma = 3.637834252744495732208418513577775d0 - rkAlpha = 2.681082873627752133895790743211112d0 - rkBeta = 3.050430199247410569426377624787569d0 - - rkT(1,1) = .424293819848497965354371036408369d0 - rkT(1,2) = -.3235571519651980681202894497035503d0 - rkT(1,3) = -.522137786846287839586599927945048d0 - rkT(2,1) = .57594609499806128896291585429339d-1 - rkT(2,2) = .3148663231849760131614374283783d-2 - rkT(2,3) = .452429247674359778577728510381731d0 - rkT(3,1) = 1.d0 - rkT(3,2) = 1.d0 - rkT(3,3) = 0.d0 - - rkTinv(1,1) = 1.233523612685027760114769983066164d0 - rkTinv(1,2) = 1.423580134265707095505388133369554d0 - rkTinv(1,3) = .3946330125758354736049045150429624d0 - rkTinv(2,1) = -1.233523612685027760114769983066164d0 - rkTinv(2,2) = -1.423580134265707095505388133369554d0 - rkTinv(2,3) = .6053669874241645263950954849570376d0 - rkTinv(3,1) = -.1484438963257383124456490049673414d0 - rkTinv(3,2) = 2.038974794939896109682070471785315d0 - rkTinv(3,3) = -.544501292892686735299355831692542d-1 - - rkTinvAinv(1,1) = 4.487354449794728738538663081025420d0 - rkTinvAinv(1,2) = 5.178748573958397475446442544234494d0 - rkTinvAinv(1,3) = 1.435609490412123627047824222335563d0 - rkTinvAinv(2,1) = -2.854361287939276673073807031221493d0 - rkTinvAinv(2,2) = -1.003648660720543859000994063139137d+1 - rkTinvAinv(2,3) = 1.789135380979465422050817815017383d0 - rkTinvAinv(3,1) = -4.160768067752685525282947313530352d0 - rkTinvAinv(3,2) = 1.124128569859216916690209918405860d0 - rkTinvAinv(3,3) = 1.700644430961823796581896350418417d0 - - rkAinvT(1,1) = 1.543510591072668287198054583233180d0 - rkAinvT(1,2) = -2.460228411937788329157493833295004d0 - rkAinvT(1,3) = -.412906170450356277003910443520499d0 - rkAinvT(2,1) = .209519643211838264029272585946993d0 - rkAinvT(2,2) = 1.388545667194387164417459732995766d0 - rkAinvT(2,3) = 1.20339553005832004974976023130002d0 - rkAinvT(3,1) = 3.637834252744495732208418513577775d0 - rkAinvT(3,2) = 2.681082873627752133895790743211112d0 - rkAinvT(3,3) = -3.050430199247410569426377624787569d0 - - END SUBROUTINE Radau1A_Coefficients - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - END SUBROUTINE RungeKuttaADJ ! and all its internal procedures -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE FUN_CHEM(T, V, FCT) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - USE KPP_ROOT_Parameters - USE KPP_ROOT_Global - USE KPP_ROOT_Function, ONLY: Fun - USE KPP_ROOT_Rates, ONLY: Update_SUN, Update_RCONST, Update_PHOTO - - IMPLICIT NONE - - KPP_REAL :: V(NVAR), FCT(NVAR) - KPP_REAL :: T, Told - - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Update_PHOTO() - TIME = Told - - CALL Fun(V, FIX, RCONST, FCT) - - END SUBROUTINE FUN_CHEM - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE JAC_CHEM (T, V, JF) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - USE KPP_ROOT_Parameters - USE KPP_ROOT_Global - USE KPP_ROOT_JacobianSP - USE KPP_ROOT_Jacobian, ONLY: Jac_SP - USE KPP_ROOT_Rates, ONLY: Update_SUN, Update_RCONST, Update_PHOTO - - IMPLICIT NONE - - KPP_REAL :: V(NVAR), T , Told -#ifdef FULL_ALGEBRA - KPP_REAL :: JV(LU_NONZERO), JF(NVAR,NVAR) - INTEGER :: i, j -#else - KPP_REAL :: JF(LU_NONZERO) -#endif - - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Update_PHOTO() - TIME = Told - -#ifdef FULL_ALGEBRA - CALL Jac_SP(V, FIX, RCONST, JV) - DO j=1,NVAR - DO i=1,NVAR - JF(i,j) = 0.0d0 - END DO - END DO - DO i=1,LU_NONZERO - JF(LU_IROW(i),LU_ICOL(i)) = JV(i) - END DO -#else - CALL Jac_SP(V, FIX, RCONST, JF) -#endif - - END SUBROUTINE JAC_CHEM - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -END MODULE KPP_ROOT_Integrator diff --git a/boxmox/int.modified_WCOPY/runge_kutta_tlm.f90 b/boxmox/int.modified_WCOPY/runge_kutta_tlm.f90 deleted file mode 100644 index af7433c09b020e9d3171dc97dcb9b027db118008..0000000000000000000000000000000000000000 --- a/boxmox/int.modified_WCOPY/runge_kutta_tlm.f90 +++ /dev/null @@ -1,2218 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! -! RungeKuttaTLM - Tangent Linear Model of Fully Implicit 3-stage RK: ! -! * Radau-2A quadrature (order 5) ! -! * Radau-1A quadrature (order 5) ! -! * Lobatto-3C quadrature (order 4) ! -! * Gauss quadrature (order 6) ! -! By default the code employs the KPP sparse linear algebra routines ! -! Compile with -DFULL_ALGEBRA to use full linear algebra (LAPACK) ! -! ! -! (C) Adrian Sandu, August 2005 ! -! Virginia Polytechnic Institute and State University ! -! Contact: sandu@cs.vt.edu ! -! Revised by Philipp Miehe and Adrian Sandu, May 2006 ! -! This implementation is part of KPP - the Kinetic PreProcessor ! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! - -MODULE KPP_ROOT_Integrator - - USE KPP_ROOT_Precision - USE KPP_ROOT_Parameters, ONLY: NVAR, NSPEC, NFIX, LU_NONZERO - USE KPP_ROOT_Global, ONLY: FIX, RCONST, TIME - USE KPP_ROOT_Jacobian - USE KPP_ROOT_LinearAlgebra - - IMPLICIT NONE - PUBLIC - SAVE - -!~~~> Statistics on the work performed by the Runge-Kutta method - INTEGER, PARAMETER :: Nfun=1, Njac=2, Nstp=3, Nacc=4, & - Nrej=5, Ndec=6, Nsol=7, Nsng=8, Ntexit=1, Nhacc=2, Nhnew=3 - -CONTAINS - - ! ************************************************************************** - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -SUBROUTINE INTEGRATE_TLM( NTLM, Y, Y_tlm, TIN, TOUT, ATOL_tlm, RTOL_tlm, & - ICNTRL_U, RCNTRL_U, ISTATUS_U, RSTATUS_U, IERR_U ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - USE KPP_ROOT_Parameters, ONLY: NVAR - USE KPP_ROOT_Global, ONLY: ATOL,RTOL,VAR - - IMPLICIT NONE - -!~~~> Y - Concentrations - KPP_REAL :: Y(NVAR) -!~~~> NTLM - No. of sensitivity coefficients - INTEGER NTLM -!~~~> Y_tlm - Sensitivities of concentrations -! Note: Y_tlm (1:NVAR,j) contains sensitivities of -! Y(1:NVAR) w.r.t. the j-th parameter, j=1...NTLM - KPP_REAL :: Y_tlm(NVAR,NTLM) - KPP_REAL :: TIN ! TIN - Start Time - KPP_REAL :: TOUT ! TOUT - End Time - KPP_REAL, INTENT(IN), OPTIONAL :: RTOL_tlm(NVAR,NTLM),ATOL_tlm(NVAR,NTLM) - INTEGER, INTENT(IN), OPTIONAL :: ICNTRL_U(20) - KPP_REAL, INTENT(IN), OPTIONAL :: RCNTRL_U(20) - INTEGER, INTENT(OUT), OPTIONAL :: ISTATUS_U(20) - KPP_REAL, INTENT(OUT), OPTIONAL :: RSTATUS_U(20) - INTEGER, INTENT(OUT), OPTIONAL :: IERR_U - - INTEGER :: IERR - - KPP_REAL :: RCNTRL(20), RSTATUS(20), T1, T2 - INTEGER :: ICNTRL(20), ISTATUS(20) - INTEGER, SAVE :: Ntotal = 0 - - ICNTRL(1:20) = 0 - RCNTRL(1:20) = 0.0_dp - - !~~~> fine-tune the integrator: - ICNTRL(2) = 0 ! Tolerances: 0=vector, 1=scalar - ICNTRL(5) = 8 ! Max no. of Newton iterations - ICNTRL(6) = 0 ! Starting values for Newton are: 0=interpolated, 1=zero - ICNTRL(7) = 1 ! TLM solution: 0=iterations, 1=direct - ICNTRL(9) = 0 ! TLM Newton iteration error: 0=fwd Newton, 1=TLM Newton error est - ICNTRL(10) = 1 ! FWD error estimation: 0=classic, 1=SDIRK - ICNTRL(11) = 1 ! Step size ontroller: 1=Gustaffson, 2=classic - ICNTRL(12) = 0 ! Trunc. error estimate: 0=fwd only, 1=fwd and TLM - - !~~~> if optional parameters are given, and if they are >0, - ! then use them to overwrite default settings - IF (PRESENT(ICNTRL_U)) THEN - WHERE(ICNTRL_U(:) > 0) ICNTRL(:) = ICNTRL_U(:) - END IF - IF (PRESENT(RCNTRL_U)) THEN - WHERE(RCNTRL_U(:) > 0) RCNTRL(:) = RCNTRL_U(:) - END IF - - T1 = TIN; T2 = TOUT - CALL RungeKuttaTLM( NVAR, NTLM, Y, Y_tlm, T1, T2, RTOL, ATOL, & - RTOL_tlm, ATOL_tlm, & - RCNTRL,ICNTRL,RSTATUS,ISTATUS,IERR ) - - Ntotal = Ntotal + ISTATUS(Nstp) - PRINT*,'NSTEPS=',ISTATUS(Nstp),' (',Ntotal,')',' O3=', VAR(ind_O3) - - ! if optional parameters are given for output - ! use them to store information in them - IF (PRESENT(ISTATUS_U)) ISTATUS_U(:) = ISTATUS(:) - IF (PRESENT(RSTATUS_U)) RSTATUS_U(:) = RSTATUS(:) - IF (PRESENT(IERR_U)) IERR_U = IERR - - IF (IERR < 0) THEN - PRINT *,'Runge-Kutta-TLM: Unsuccessful exit at T=', TIN,' (IERR=',IERR,')' - ENDIF - - END SUBROUTINE INTEGRATE_TLM - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE RungeKuttaTLM( N, NTLM, Y, Y_tlm, T, Tend,RelTol,AbsTol, & - RelTol_tlm,AbsTol_tlm,RCNTRL,ICNTRL,RSTATUS,ISTATUS,IERR ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -! This implementation is based on the book and the code Radau5: -! -! E. HAIRER AND G. WANNER -! "SOLVING ORDINARY DIFFERENTIAL EQUATIONS II. -! STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS." -! SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS 14, -! SPRINGER-VERLAG (1991) -! -! UNIVERSITE DE GENEVE, DEPT. DE MATHEMATIQUES -! CH-1211 GENEVE 24, SWITZERLAND -! E-MAIL: HAIRER@DIVSUN.UNIGE.CH, WANNER@DIVSUN.UNIGE.CH -! -! Methods: -! * Radau-2A quadrature (order 5) -! * Radau-1A quadrature (order 5) -! * Lobatto-3C quadrature (order 4) -! * Gauss quadrature (order 6) -! -! (C) Adrian Sandu, August 2005 -! Virginia Polytechnic Institute and State University -! Contact: sandu@cs.vt.edu -! Revised by Philipp Miehe and Adrian Sandu, May 2006 -! This implementation is part of KPP - the Kinetic PreProcessor -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!~~~> INPUT ARGUMENTS: -! ---------------- -! -! Note: For input parameters equal to zero the default values of the -! corresponding variables are used. -! -! N Dimension of the system -! T Initial time value -! -! Tend Final T value (Tend-T may be positive or negative) -! -! Y(N) Initial values for Y -! -! RelTol,AbsTol Relative and absolute error tolerances. -! for ICNTRL(2) = 0: AbsTol, RelTol are N-dimensional vectors -! = 1: AbsTol, RelTol are scalars -! -!~~~> Integer input parameters: -! -! ICNTRL(1) = not used -! -! ICNTRL(2) = 0: AbsTol, RelTol are NVAR-dimensional vectors -! = 1: AbsTol, RelTol are scalars -! -! ICNTRL(3) = RK method selection -! = 1: Radau-2A (the default) -! = 2: Lobatto-3C -! = 3: Gauss -! = 4: Radau-1A -! -! ICNTRL(4) -> maximum number of integration steps -! For ICNTRL(4)=0 the default value of 100000 is used -! -! ICNTRL(5) -> maximum number of Newton iterations -! For ICNTRL(5)=0 the default value of 8 is used -! -! ICNTRL(6) -> starting values of Newton iterations: -! ICNTRL(6)=0 : starting values are obtained from -! the extrapolated collocation solution -! (the default) -! ICNTRL(6)=1 : starting values are zero -! -! ICNTRL(7) -> method to solve TLM equations: -! ICNTRL(7)=0 : modified Newton re-using LU (the default) -! ICNTRL(7)=1 : direct solution (additional one *big* LU factorization) -! -! ICNTRL(9) -> switch for TLM Newton iteration error estimation strategy -! ICNTRL(9) = 0: base number of iterations as forward solution -! ICNTRL(9) = 1: use RTOL_tlm and ATOL_tlm to calculate -! error estimation for TLM at Newton stages -! -! ICNTRL(10) -> switch for error estimation strategy -! ICNTRL(10) = 0: one additional stage: at c=0, -! see Hairer (default) -! ICNTRL(10) = 1: two additional stages: one at c=0 -! and one SDIRK at c=1, stiffly accurate -! -! ICNTRL(11) -> switch for step size strategy -! ICNTRL(11)=1: mod. predictive controller (Gustafsson, default) -! ICNTRL(11)=2: classical step size control -! the choice 1 seems to produce safer results; -! for simple problems, the choice 2 produces -! often slightly faster runs -! -! ICNTRL(12) -> switch for TLM truncation error control -! ICNTRL(12) = 0: TLM error is not used -! ICNTRL(12) = 1: TLM error is computed and used -! -! -!~~~> Real input parameters: -! -! RCNTRL(1) -> Hmin, lower bound for the integration step size -! (highly recommended to keep Hmin = ZERO, the default) -! -! RCNTRL(2) -> Hmax, upper bound for the integration step size -! -! RCNTRL(3) -> Hstart, the starting step size -! -! RCNTRL(4) -> FacMin, lower bound on step decrease factor (default=0.2) -! -! RCNTRL(5) -> FacMax, upper bound on step increase factor (default=6) -! -! RCNTRL(6) -> FacRej, step decrease factor after multiple rejections -! (default=0.1) -! -! RCNTRL(7) -> FacSafe, by which the new step is slightly smaller -! than the predicted value (default=0.9) -! -! RCNTRL(8) -> ThetaMin. If Newton convergence rate smaller -! than ThetaMin the Jacobian is not recomputed; -! (default=0.001) -! -! RCNTRL(9) -> NewtonTol, stopping criterion for Newton's method -! (default=0.03) -! -! RCNTRL(10) -> Qmin -! -! RCNTRL(11) -> Qmax. If Qmin < Hnew/Hold < Qmax, then the -! step size is kept constant and the LU factorization -! reused (default Qmin=1, Qmax=1.2) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -! -! OUTPUT ARGUMENTS: -! ----------------- -! -! T -> T value for which the solution has been computed -! (after successful return T=Tend). -! -! Y(N) -> Numerical solution at T -! -! IERR -> Reports on successfulness upon return: -! = 1 for success -! < 0 for error (value equals error code) -! -! ISTATUS(1) -> No. of function calls -! ISTATUS(2) -> No. of jacobian calls -! ISTATUS(3) -> No. of steps -! ISTATUS(4) -> No. of accepted steps -! ISTATUS(5) -> No. of rejected steps (except at very beginning) -! ISTATUS(6) -> No. of LU decompositions -! ISTATUS(7) -> No. of forward/backward substitutions -! ISTATUS(8) -> No. of singular matrix decompositions -! -! RSTATUS(1) -> Texit, the time corresponding to the -! computed Y upon return -! RSTATUS(2) -> Hexit, last accepted step before exit -! RSTATUS(3) -> Hnew, last predicted step (not yet taken) -! For multiple restarts, use Hnew as Hstart -! in the subsequent run -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - - INTEGER :: N, NTLM - KPP_REAL :: Y(N),Y_tlm(N,NTLM) - KPP_REAL :: AbsTol(N),RelTol(N),RCNTRL(20),RSTATUS(20) - KPP_REAL :: AbsTol_tlm(N,NTLM),RelTol_tlm(N,NTLM) - INTEGER :: ICNTRL(20), ISTATUS(20) - LOGICAL :: StartNewton, Gustafsson, SdirkError, TLMNewtonEst, & - TLMtruncErr, TLMDirect - INTEGER :: IERR, ITOL - KPP_REAL :: T,Tend - - !~~~> Control arguments - INTEGER :: Max_no_steps, NewtonMaxit, rkMethod - KPP_REAL :: Hmin,Hmax,Hstart,Qmin,Qmax - KPP_REAL :: Roundoff, ThetaMin, NewtonTol - KPP_REAL :: FacSafe,FacMin,FacMax,FacRej - ! Runge-Kutta method parameters - INTEGER, PARAMETER :: R2A=1, R1A=2, L3C=3, GAU=4, L3A=5 - KPP_REAL :: rkT(3,3), rkTinv(3,3), rkTinvAinv(3,3), rkAinvT(3,3), & - rkA(3,3), rkB(3), rkC(3), rkD(0:3), rkE(0:3), & - rkBgam(0:4), rkBhat(0:4), rkTheta(0:3), & - rkGamma, rkAlpha, rkBeta, rkELO - !~~~> Local variables - INTEGER :: i - KPP_REAL, PARAMETER :: ZERO = 0.0d0, ONE = 1.0d0 - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! SETTING THE PARAMETERS -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IERR = 0 - ISTATUS(1:20) = 0 - RSTATUS(1:20) = ZERO - -!~~~> ICNTRL(1) - autonomous system - not used -!~~~> ITOL: 1 for vector and 0 for scalar AbsTol/RelTol - IF (ICNTRL(2) == 0) THEN - ITOL = 1 - ELSE - ITOL = 0 - END IF -!~~~> Error control selection - IF (ICNTRL(10) == 0) THEN - SdirkError = .FALSE. - ELSE - SdirkError = .TRUE. - END IF -!~~~> Method selection - SELECT CASE (ICNTRL(3)) - CASE (0,1) - CALL Radau2A_Coefficients - CASE (2) - CALL Lobatto3C_Coefficients - CASE (3) - CALL Gauss_Coefficients - CASE (4) - CALL Radau1A_Coefficients - CASE DEFAULT - WRITE(6,*) 'ICNTRL(3)=',ICNTRL(3) - CALL RK_ErrorMsg(-13,T,ZERO,IERR) - END SELECT -!~~~> Max_no_steps: the maximal number of time steps - IF (ICNTRL(4) == 0) THEN - Max_no_steps = 200000 - ELSE - Max_no_steps=ICNTRL(4) - IF (Max_no_steps <= 0) THEN - WRITE(6,*) 'ICNTRL(4)=',ICNTRL(4) - CALL RK_ErrorMsg(-1,T,ZERO,IERR) - END IF - END IF -!~~~> NewtonMaxit maximal number of Newton iterations - IF (ICNTRL(5) == 0) THEN - NewtonMaxit = 8 - ELSE - NewtonMaxit=ICNTRL(5) - IF (NewtonMaxit <= 0) THEN - WRITE(6,*) 'ICNTRL(5)=',ICNTRL(5) - CALL RK_ErrorMsg(-2,T,ZERO,IERR) - END IF - END IF -!~~~> StartNewton: Use extrapolation for starting values of Newton iterations - IF (ICNTRL(6) == 0) THEN - StartNewton = .TRUE. - ELSE - StartNewton = .FALSE. - END IF -!~~~> Solve TLM equations directly or by Newton iterations - IF (ICNTRL(7) == 0) THEN - TLMDirect = .FALSE. - ELSE - TLMDirect = .TRUE. - END IF -!~~~> Newton iteration error control selection - IF (ICNTRL(9) == 0) THEN - TLMNewtonEst = .FALSE. - ELSE - TLMNewtonEst = .TRUE. - END IF -!~~~> Gustafsson: step size controller - IF(ICNTRL(11) == 0)THEN - Gustafsson = .TRUE. - ELSE - Gustafsson = .FALSE. - END IF -!~~~> TLM truncation error control selection - IF (ICNTRL(12) == 0) THEN - TLMtruncErr = .FALSE. - ELSE - TLMtruncErr = .TRUE. - END IF - -!~~~> Roundoff: smallest number s.t. 1.0 + Roundoff > 1.0 - Roundoff=WLAMCH('E'); - -!~~~> Hmin = minimal step size - IF (RCNTRL(1) == ZERO) THEN - Hmin = ZERO - ELSE - Hmin = MIN(ABS(RCNTRL(1)),ABS(Tend-T)) - END IF -!~~~> Hmax = maximal step size - IF (RCNTRL(2) == ZERO) THEN - Hmax = ABS(Tend-T) - ELSE - Hmax = MIN(ABS(RCNTRL(2)),ABS(Tend-T)) - END IF -!~~~> Hstart = starting step size - IF (RCNTRL(3) == ZERO) THEN - Hstart = ZERO - ELSE - Hstart = MIN(ABS(RCNTRL(3)),ABS(Tend-T)) - END IF -!~~~> FacMin: lower bound on step decrease factor - IF(RCNTRL(4) == ZERO)THEN - FacMin = 0.2d0 - ELSE - FacMin = RCNTRL(4) - END IF -!~~~> FacMax: upper bound on step increase factor - IF(RCNTRL(5) == ZERO)THEN - FacMax = 8.D0 - ELSE - FacMax = RCNTRL(5) - END IF -!~~~> FacRej: step decrease factor after 2 consecutive rejections - IF(RCNTRL(6) == ZERO)THEN - FacRej = 0.1d0 - ELSE - FacRej = RCNTRL(6) - END IF -!~~~> FacSafe: by which the new step is slightly smaller -! than the predicted value - IF (RCNTRL(7) == ZERO) THEN - FacSafe=0.9d0 - ELSE - FacSafe=RCNTRL(7) - END IF - IF ( (FacMax < ONE) .OR. (FacMin > ONE) .OR. & - (FacSafe <= 1.0d-3) .OR. (FacSafe >= ONE) ) THEN - WRITE(6,*)'RCNTRL(4:7)=',RCNTRL(4:7) - CALL RK_ErrorMsg(-4,T,ZERO,IERR) - END IF - -!~~~> ThetaMin: decides whether the Jacobian should be recomputed - IF (RCNTRL(8) == ZERO) THEN - ThetaMin = 1.0d-3 - ELSE - ThetaMin=RCNTRL(8) - IF (ThetaMin <= 0.0d0 .OR. ThetaMin >= 1.0d0) THEN - WRITE(6,*) 'RCNTRL(8)=', RCNTRL(8) - CALL RK_ErrorMsg(-5,T,ZERO,IERR) - END IF - END IF -!~~~> NewtonTol: stopping crierion for Newton's method - IF (RCNTRL(9) == ZERO) THEN - NewtonTol = 3.0d-2 - ELSE - NewtonTol = RCNTRL(9) - IF (NewtonTol <= Roundoff) THEN - WRITE(6,*) 'RCNTRL(9)=',RCNTRL(9) - CALL RK_ErrorMsg(-6,T,ZERO,IERR) - END IF - END IF -!~~~> Qmin AND Qmax: IF Qmin < Hnew/Hold < Qmax then step size = const. - IF (RCNTRL(10) == ZERO) THEN - Qmin=1.D0 - ELSE - Qmin=RCNTRL(10) - END IF - IF (RCNTRL(11) == ZERO) THEN - Qmax=1.2D0 - ELSE - Qmax=RCNTRL(11) - END IF - IF (Qmin > ONE .OR. Qmax < ONE) THEN - WRITE(6,*) 'RCNTRL(10:11)=',Qmin,Qmax - CALL RK_ErrorMsg(-7,T,ZERO,IERR) - END IF -!~~~> Check if tolerances are reasonable - IF (ITOL == 0) THEN - IF (AbsTol(1) <= ZERO.OR.RelTol(1) <= 10.d0*Roundoff) THEN - WRITE (6,*) 'AbsTol/RelTol=',AbsTol,RelTol - CALL RK_ErrorMsg(-8,T,ZERO,IERR) - END IF - ELSE - DO i=1,N - IF (AbsTol(i) <= ZERO.OR.RelTol(i) <= 10.d0*Roundoff) THEN - WRITE (6,*) 'AbsTol/RelTol(',i,')=',AbsTol(i),RelTol(i) - CALL RK_ErrorMsg(-8,T,ZERO,IERR) - END IF - END DO - END IF - -!~~~> Parameters are wrong - IF (IERR < 0) RETURN - -!~~~> Call the core method - CALL RK_IntegratorTLM( N,NTLM,T,Tend,Y,Y_tlm,IERR ) - - CONTAINS ! Internal procedures to RungeKutta - - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE RK_IntegratorTLM( N,NTLM,T,Tend,Y,Y_tlm,IERR ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE -!~~~> Arguments - INTEGER, INTENT(IN) :: N, NTLM - KPP_REAL, INTENT(IN) :: Tend - KPP_REAL, INTENT(INOUT) :: T, Y(N), Y_tlm(NVAR,NTLM) - INTEGER, INTENT(OUT) :: IERR - -!~~~> Local variables -#ifdef FULL_ALGEBRA - KPP_REAL, DIMENSION(NVAR,NVAR) :: & - FJAC, E1, Jac1, Jac2, Jac3 - COMPLEX(kind=dp), DIMENSION(NVAR,NVAR) :: E2 - KPP_REAL, DIMENSION(3*NVAR,3*NVAR) :: Jbig, Ebig - KPP_REAL, DIMENSION(3*NVAR) :: Zbig - INTEGER, DIMENSION(3*NVAR) :: IPbig -#else - KPP_REAL, DIMENSION(LU_NONZERO) :: & - FJAC, E1, Jac1, Jac2, Jac3 - COMPLEX(kind=dp), DIMENSION(LU_NONZERO) :: E2 -! Next 3 commented lines for sparse big linear algebra: -! KPP_REAL, DIMENSION(3,3,LU_NONZERO) :: Jbig -! KPP_REAL, DIMENSION(3,NVAR) :: Zbig -! INTEGER, DIMENSION(3,NVAR) :: IPbig - KPP_REAL, DIMENSION(3*NVAR,3*NVAR) :: Jbig, Ebig - KPP_REAL, DIMENSION(3*NVAR) :: Zbig - INTEGER, DIMENSION(3*NVAR) :: IPbig -#endif - KPP_REAL, DIMENSION(NVAR) :: Z1,Z2,Z3,Z4,SCAL,DZ1,DZ2,DZ3,DZ4, & - G,TMP,SCAL_tlm - KPP_REAL, DIMENSION(NVAR,NTLM) :: Z1_tlm,Z2_tlm,Z3_tlm - KPP_REAL :: CONT(NVAR,3), Tdirection, H, Hacc, Hnew, Hold, Fac, & - FacGus, Theta, Err, ErrOld, NewtonRate, NewtonIncrement, & - Hratio, Qnewton, NewtonPredictedErr,NewtonIncrementOld, & - ThetaTLM, ThetaSD - INTEGER :: i,j,IP1(NVAR),IP2(NVAR),NewtonIter, ISING, Nconsecutive, itlm - INTEGER :: saveNiter, NewtonIterTLM, info - LOGICAL :: Reject, FirstStep, SkipJac, NewtonDone, SkipLU - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Initial setting -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Tdirection = SIGN(ONE,Tend-T) - H = MIN( MAX(ABS(Hmin),ABS(Hstart)) , Hmax ) - IF (ABS(H) <= 10.d0*Roundoff) H = 1.0d-6 - H = SIGN(H,Tdirection) - Hold = H - Reject = .FALSE. - FirstStep = .TRUE. - SkipJac = .FALSE. - SkipLU = .FALSE. - IF ((T+H*1.0001D0-Tend)*Tdirection >= ZERO) THEN - H = Tend-T - END IF - Nconsecutive = 0 - CALL RK_ErrorScale(N,ITOL,AbsTol,RelTol,Y,SCAL) - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Time loop begins -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Tloop: DO WHILE ( (Tend-T)*Tdirection - Roundoff > ZERO ) - - IF ( .NOT.SkipLU ) THEN ! This time around skip the Jac update and LU - !~~~> Compute the Jacobian matrix - IF ( .NOT.SkipJac ) THEN - CALL JAC_CHEM(T,Y,FJAC) - ISTATUS(Njac) = ISTATUS(Njac) + 1 - END IF - !~~~> Compute the matrices E1 and E2 and their decompositions - CALL RK_Decomp(N,H,FJAC,E1,IP1,E2,IP2,ISING) - IF (ISING /= 0) THEN - ISTATUS(Nsng) = ISTATUS(Nsng) + 1; Nconsecutive = Nconsecutive + 1 - IF (Nconsecutive >= 5) THEN - CALL RK_ErrorMsg(-12,T,H,IERR); RETURN - END IF - H=H*0.5d0; Reject=.TRUE.; SkipJac = .TRUE.; SkipLU = .FALSE. - CYCLE Tloop - ELSE - Nconsecutive = 0 - END IF - END IF ! SkipLU - - ISTATUS(Nstp) = ISTATUS(Nstp) + 1 - IF (ISTATUS(Nstp) > Max_no_steps) THEN - PRINT*,'Max number of time steps is ',Max_no_steps - CALL RK_ErrorMsg(-9,T,H,IERR); RETURN - END IF - IF (0.1D0*ABS(H) <= ABS(T)*Roundoff) THEN - CALL RK_ErrorMsg(-10,T,H,IERR); RETURN - END IF - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Loop for the simplified Newton iterations -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - !~~~> Starting values for Newton iteration - IF ( FirstStep .OR. (.NOT.StartNewton) ) THEN - CALL Set2zero(N,Z1) - CALL Set2zero(N,Z2) - CALL Set2zero(N,Z3) - ELSE - ! Evaluate quadratic polynomial - CALL RK_Interpolate('eval',N,H,Hold,Z1,Z2,Z3,CONT) - END IF - - !~~~> Initializations for Newton iteration - NewtonDone = .FALSE. - Fac = 0.5d0 ! Step reduction if too many iterations - -NewtonLoop:DO NewtonIter = 1, NewtonMaxit - - !~~~> Prepare the right-hand side - CALL RK_PrepareRHS(N,T,H,Y,Z1,Z2,Z3,DZ1,DZ2,DZ3) - - !~~~> Solve the linear systems - CALL RK_Solve( N,H,E1,IP1,E2,IP2,DZ1,DZ2,DZ3,ISING ) - - NewtonIncrement = SQRT( ( RK_ErrorNorm(N,SCAL,DZ1)**2 + & - RK_ErrorNorm(N,SCAL,DZ2)**2 + & - RK_ErrorNorm(N,SCAL,DZ3)**2 )/3.0d0 ) - - IF ( NewtonIter == 1 ) THEN - Theta = ABS(ThetaMin) - NewtonRate = 2.0d0 - ELSE - Theta = NewtonIncrement/NewtonIncrementOld - IF (Theta < 0.99d0) THEN - NewtonRate = Theta/(ONE-Theta) - ELSE ! Non-convergence of Newton: Theta too large - EXIT NewtonLoop - END IF - IF ( NewtonIter < NewtonMaxit ) THEN - ! Predict error at the end of Newton process - NewtonPredictedErr = NewtonIncrement & - *Theta**(NewtonMaxit-NewtonIter)/(ONE-Theta) - IF (NewtonPredictedErr >= NewtonTol) THEN - ! Non-convergence of Newton: predicted error too large - Qnewton = MIN(10.0d0,NewtonPredictedErr/NewtonTol) - Fac=0.8d0*Qnewton**(-ONE/(1+NewtonMaxit-NewtonIter)) - EXIT NewtonLoop - END IF - END IF - END IF - - NewtonIncrementOld = MAX(NewtonIncrement,Roundoff) - ! Update solution - CALL WAXPY(N,-ONE,DZ1,1,Z1,1) ! Z1 <- Z1 - DZ1 - CALL WAXPY(N,-ONE,DZ2,1,Z2,1) ! Z2 <- Z2 - DZ2 - CALL WAXPY(N,-ONE,DZ3,1,Z3,1) ! Z3 <- Z3 - DZ3 - - ! Check error in Newton iterations - NewtonDone = (NewtonRate*NewtonIncrement <= NewtonTol) - IF (NewtonDone) THEN - ! Tune error in TLM variables by defining the minimal number of Newton iterations. - saveNiter = NewtonIter+1 - EXIT NewtonLoop - END IF - IF (NewtonIter == NewtonMaxit) THEN - PRINT*, 'Slow or no convergence in Newton Iteration: Max no. of', & - 'Newton iterations reached' - END IF - - END DO NewtonLoop - - IF (.NOT.NewtonDone) THEN - !CALL RK_ErrorMsg(-12,T,H,IERR); - H = Fac*H; Reject=.TRUE.; SkipJac = .TRUE.; SkipLU = .FALSE. - CYCLE Tloop - END IF - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> SDIRK Stage -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IF (SdirkError) THEN - -!~~~> Starting values for Newton iterations - Z4(1:N) = Z3(1:N) - -!~~~> Prepare the loop-independent part of the right-hand side - CALL FUN_CHEM(T,Y,DZ4) - ISTATUS(Nfun) = ISTATUS(Nfun) + 1 - -! G = H*rkBgam(0)*DZ4 + rkTheta(1)*Z1 + rkTheta(2)*Z2 + rkTheta(3)*Z3 - CALL Set2Zero(N, G) - CALL WAXPY(N,rkBgam(0)*H, DZ4,1,G,1) - CALL WAXPY(N,rkTheta(1),Z1,1,G,1) - CALL WAXPY(N,rkTheta(2),Z2,1,G,1) - CALL WAXPY(N,rkTheta(3),Z3,1,G,1) - - !~~~> Initializations for Newton iteration - NewtonDone = .FALSE. - Fac = 0.5d0 ! Step reduction factor if too many iterations - -SDNewtonLoop:DO NewtonIter = 1, NewtonMaxit - -!~~~> Prepare the loop-dependent part of the right-hand side - CALL WADD(N,Y,Z4,TMP) ! TMP <- Y + Z4 - CALL FUN_CHEM(T+H,TMP,DZ4) ! DZ4 <- Fun(Y+Z4) - ISTATUS(Nfun) = ISTATUS(Nfun) + 1 -! DZ4(1:N) = (G(1:N)-Z4(1:N))*(rkGamma/H) + DZ4(1:N) - CALL WAXPY (N, -ONE*rkGamma/H, Z4, 1, DZ4, 1) - CALL WAXPY (N, rkGamma/H, G,1, DZ4,1) - -!~~~> Solve the linear system -#ifdef FULL_ALGEBRA - CALL DGETRS( 'N', N, 1, E1, N, IP1, DZ4, N, ISING ) -#else - CALL KppSolve(E1, DZ4) -#endif - -!~~~> Check convergence of Newton iterations - NewtonIncrement = RK_ErrorNorm(N,SCAL,DZ4) - IF ( NewtonIter == 1 ) THEN - ThetaSD = ABS(ThetaMin) - NewtonRate = 2.0d0 - ELSE - ThetaSD = NewtonIncrement/NewtonIncrementOld - IF (ThetaSD < 0.99d0) THEN - NewtonRate = ThetaSD/(ONE-ThetaSD) - ! Predict error at the end of Newton process - NewtonPredictedErr = NewtonIncrement & - *ThetaSD**(NewtonMaxit-NewtonIter)/(ONE-ThetaSD) - IF (NewtonPredictedErr >= NewtonTol) THEN - ! Non-convergence of Newton: predicted error too large - Qnewton = MIN(10.0d0,NewtonPredictedErr/NewtonTol) - Fac = 0.8d0*Qnewton**(-ONE/(1+NewtonMaxit-NewtonIter)) - EXIT SDNewtonLoop - END IF - ELSE ! Non-convergence of Newton: Theta too large - print*,'Theta too large: ',ThetaSD - EXIT SDNewtonLoop - END IF - END IF - NewtonIncrementOld = NewtonIncrement - ! Update solution: Z4 <-- Z4 + DZ4 - CALL WAXPY(N,ONE,DZ4,1,Z4,1) - - ! Check error in Newton iterations - NewtonDone = (NewtonRate*NewtonIncrement <= NewtonTol) - IF (NewtonDone) EXIT SDNewtonLoop - - END DO SDNewtonLoop - - IF (.NOT.NewtonDone) THEN - H = Fac*H; Reject=.TRUE.; SkipJac = .TRUE.; SkipLU = .FALSE. - CYCLE Tloop - END IF - -!~~~> End of implified SDIRK Newton iterations - END IF - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Error estimation, forward solution -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IF (SdirkError) THEN -! DZ4(1:N) = rkD(1)*Z1 + rkD(2)*Z2 + rkD(3)*Z3 - Z4 - CALL Set2Zero(N, DZ4) - IF (rkD(1) /= ZERO) CALL WAXPY(N, rkD(1), Z1, 1, DZ4, 1) - IF (rkD(2) /= ZERO) CALL WAXPY(N, rkD(2), Z2, 1, DZ4, 1) - IF (rkD(3) /= ZERO) CALL WAXPY(N, rkD(3), Z3, 1, DZ4, 1) - CALL WAXPY(N, -ONE, Z4, 1, DZ4, 1) - Err = RK_ErrorNorm(N,SCAL,DZ4) - ELSE - CALL RK_ErrorEstimate(N,H,Y,T, & - E1,IP1,Z1,Z2,Z3,SCAL,Err,FirstStep,Reject) - END IF - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> If error small enough, compute TLM solution -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IF (Err < ONE) THEN - - !~~~> Jacobian values - CALL WADD(N,Y,Z1,TMP) ! TMP <- Y + Z1 - CALL JAC_CHEM(T+rkC(1)*H,TMP,Jac1) ! Jac1 <- Jac(Y+Z1) - CALL WADD(N,Y,Z2,TMP) ! TMP <- Y + Z2 - CALL JAC_CHEM(T+rkC(2)*H,TMP,Jac2) ! Jac2 <- Jac(Y+Z2) - CALL WADD(N,Y,Z3,TMP) ! TMP <- Y + Z3 - CALL JAC_CHEM(T+rkC(3)*H,TMP,Jac3) ! Jac3 <- Jac(Y+Z3) - -TLMDIR: IF (TLMDirect) THEN - -#ifdef FULL_ALGEBRA - !~~~> Construct the full Jacobian - DO j=1,N - DO i=1,N - Jbig(i,j) = -H*rkA(1,1)*Jac1(i,j) - Jbig(N+i,j) = -H*rkA(2,1)*Jac1(i,j) - Jbig(2*N+i,j) = -H*rkA(3,1)*Jac1(i,j) - Jbig(i,N+j) = -H*rkA(1,2)*Jac2(i,j) - Jbig(N+i,N+j) = -H*rkA(2,2)*Jac2(i,j) - Jbig(2*N+i,N+j) = -H*rkA(3,2)*Jac2(i,j) - Jbig(i,2*N+j) = -H*rkA(1,3)*Jac3(i,j) - Jbig(N+i,2*N+j) = -H*rkA(2,3)*Jac3(i,j) - Jbig(2*N+i,2*N+j) = -H*rkA(3,3)*Jac3(i,j) - END DO - END DO - Ebig = -Jbig - DO i=1,3*NVAR - Jbig(i,i) = ONE + Jbig(i,i) - END DO - !~~~> Solve the big system - ! CALL DGETRF(3*NVAR,3*NVAR,Jbig,3*NVAR,IPbig,j) - CALL WGEFA(3*N,Jbig,IPbig,info) - IF (info /= 0) THEN - PRINT*,'Big big guy is singular'; STOP - END IF - DO itlm = 1, NTLM - DO j=1,NVAR - Zbig(j) = Y_tlm(j,itlm) - Zbig(NVAR+j) = Y_tlm(j,itlm) - Zbig(2*NVAR+j) = Y_tlm(j,itlm) - END DO - Zbig = MATMUL(Ebig,Zbig) - !CALL DGETRS ('N',3*NVAR,1,Jbig,3*NVAR,IPbig,Zbig,3*NVAR,0) - CALL WGESL('N',3*N,Jbig,IPbig,Zbig) - DO j=1,NVAR - Z1_tlm(j,itlm) = Zbig(j) - Z2_tlm(j,itlm) = Zbig(NVAR+j) - Z3_tlm(j,itlm) = Zbig(2*NVAR+j) - END DO - END DO -#else -! Commented code for sparse big linear algebra: -! !~~~> Construct the big Jacobian -! DO j=1,LU_NONZERO -! DO i=1,3 -! Jbig(i,1,j) = -H*rkA(i,1)*Jac1(j) -! Jbig(i,2,j) = -H*rkA(i,2)*Jac2(j) -! Jbig(i,3,j) = -H*rkA(i,3)*Jac3(j) -! END DO -! END DO -! DO j=1,NVAR -! DO i=1,3 -! Jbig(i,i,LU_DIAG(j)) = ONE + Jbig(i,i,LU_DIAG(j)) -! END DO -! END DO -! !~~~> Solve the big system -! CALL KppDecompBig( Jbig, IPbig, j ) -! Use full big linear algebra: - Jbig(1:3*N,1:3*N) = 0.0d0 - DO i=1,LU_NONZERO - Jbig(LU_irow(i),LU_icol(i)) = -H*rkA(1,1)*Jac1(i) - Jbig(LU_irow(i),N+LU_icol(i)) = -H*rkA(1,2)*Jac2(i) - Jbig(LU_irow(i),2*N+LU_icol(i)) = -H*rkA(1,3)*Jac3(i) - Jbig(N+LU_irow(i),LU_icol(i)) = -H*rkA(2,1)*Jac1(i) - Jbig(N+LU_irow(i),N+LU_icol(i)) = -H*rkA(2,2)*Jac2(i) - Jbig(N+LU_irow(i),2*N+LU_icol(i)) = -H*rkA(2,3)*Jac3(i) - Jbig(2*N+LU_irow(i),LU_icol(i)) = -H*rkA(3,1)*Jac1(i) - Jbig(2*N+LU_irow(i),N+LU_icol(i)) = -H*rkA(3,2)*Jac2(i) - Jbig(2*N+LU_irow(i),2*N+LU_icol(i)) = -H*rkA(3,3)*Jac3(i) - END DO - Ebig = -Jbig - DO i=1, 3*N - Jbig(i,i) = ONE + Jbig(i,i) - END DO - ! CALL DGETRF(3*N,3*N,Jbig,3*N,IPbig,info) - CALL WGEFA(3*N,Jbig,IPbig,info) - IF (info /= 0) THEN - PRINT*,'Big guy is singular'; STOP - END IF - - DO itlm = 1, NTLM -! Commented code for sparse big linear algebra: -! ! Compute RHS -! CALL RK_PrepareRHS_TLMdirect(N,H,Jac1,Jac2,Jac3,Y_tlm(1,itlm),Zbig) -! ! Solve the system -! CALL KppSolveBig( Jbig, IPbig, Zbig ) -! DO j=1,NVAR -! Z1_tlm(j,itlm) = Zbig(1,j) -! Z2_tlm(j,itlm) = Zbig(2,j) -! Z3_tlm(j,itlm) = Zbig(3,j) -! END DO - ! Compute RHS - CALL RK_PrepareRHS_TLMdirect(N,H,Jac1,Jac2,Jac3,Y_tlm(1,itlm),Zbig) - ! Solve the system - ! CALL DGETRS('N',3*N,1,Jbig,3*N,IPbig,Zbig,3*N,0) - CALL WGESL('N',3*N,Jbig,IPbig,Zbig) - Z1_tlm(1:NVAR,itlm) = Zbig(1:NVAR) - Z2_tlm(1:NVAR,itlm) = Zbig(NVAR+1:2*NVAR) - Z3_tlm(1:NVAR,itlm) = Zbig(2*NVAR+1:3*NVAR) - END DO -#endif - - ELSE TLMDIR - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Loop for Newton iterations, TLM variables -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Tlm:DO itlm = 1, NTLM - - !~~~> Starting values for Newton iteration - CALL Set2zero(N,Z1_tlm(1,itlm)) - CALL Set2zero(N,Z2_tlm(1,itlm)) - CALL Set2zero(N,Z3_tlm(1,itlm)) - - !~~~> Initializations for Newton iteration - IF (TLMNewtonEst) THEN - NewtonDone = .FALSE. - Fac = 0.5d0 ! Step reduction if too many iterations - - CALL RK_ErrorScale(N,ITOL,AbsTol_tlm(1,itlm),RelTol_tlm(1,itlm), & - Y_tlm(1,itlm),SCAL_tlm) - END IF - -NewtonLoopTLM:DO NewtonIterTLM = 1, NewtonMaxit - - !~~~> Prepare the right-hand side - CALL RK_PrepareRHS_TLM(N,H,Jac1,Jac2,Jac3,Y_tlm(1,itlm), & - Z1_tlm(1,itlm),Z2_tlm(1,itlm),Z3_tlm(1,itlm), & - DZ1,DZ2,DZ3) - - !~~~> Solve the linear systems - CALL RK_Solve( N,H,E1,IP1,E2,IP2,DZ1,DZ2,DZ3,ISING ) - - IF (TLMNewtonEst) THEN -!~~~> Check convergence of Newton iterations - NewtonIncrement = SQRT( ( RK_ErrorNorm(N,SCAL_tlm,DZ1)**2 + & - RK_ErrorNorm(N,SCAL_tlm,DZ2)**2 + & - RK_ErrorNorm(N,SCAL_tlm,DZ3)**2 )/3.0d0 ) - IF ( NewtonIterTLM == 1 ) THEN - ThetaTLM = ABS(ThetaMin) - NewtonRate = 2.0d0 - ELSE - ThetaTLM = NewtonIncrement/NewtonIncrementOld - IF (ThetaTLM < 0.99d0) THEN - NewtonRate = ThetaTLM/(ONE-ThetaTLM) - ELSE ! Non-convergence of Newton: ThetaTLM too large - EXIT NewtonLoopTLM - END IF - IF ( NewtonIterTLM < NewtonMaxit ) THEN - ! Predict error at the end of Newton process - NewtonPredictedErr = NewtonIncrement & - *ThetaTLM**(NewtonMaxit-NewtonIterTLM)/(ONE-ThetaTLM) - IF (NewtonPredictedErr >= NewtonTol) THEN - ! Non-convergence of Newton: predicted error too large - Qnewton = MIN(10.0d0,NewtonPredictedErr/NewtonTol) - Fac=0.8d0*Qnewton**(-ONE/(1+NewtonMaxit-NewtonIterTLM)) - EXIT NewtonLoopTLM - END IF - END IF - END IF - - NewtonIncrementOld = MAX(NewtonIncrement,Roundoff) - END IF !(TLMNewtonEst) - ! Update solution - CALL WAXPY(N,-ONE,DZ1,1,Z1_tlm(1,itlm),1) ! Z1 <- Z1 - DZ1 - CALL WAXPY(N,-ONE,DZ2,1,Z2_tlm(1,itlm),1) ! Z2 <- Z2 - DZ2 - CALL WAXPY(N,-ONE,DZ3,1,Z3_tlm(1,itlm),1) ! Z3 <- Z3 - DZ3 - - ! Check error in Newton iterations - IF (TLMNewtonEst) THEN - NewtonDone = (NewtonRate*NewtonIncrement <= NewtonTol) - IF (NewtonDone) EXIT NewtonLoopTLM - ELSE - ! Minimum number of iterations same as FWD iterations - IF (NewtonIterTLM>=saveNiter) EXIT NewtonLoopTLM - END IF - - END DO NewtonLoopTLM - - IF ((TLMNewtonEst) .AND. (.NOT.NewtonDone)) THEN - !CALL RK_ErrorMsg(-12,T,H,IERR); - H = Fac*H; Reject=.TRUE.; SkipJac = .TRUE.; SkipLU = .FALSE. - CYCLE Tloop - END IF - - END DO Tlm - - END IF TLMDIR - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Error estimation, TLM solution -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IF (TLMtruncErr) THEN - CALL RK_ErrorEstimate_tlm(N,NTLM,T,H,FJAC,Y, Y_tlm, & - E1,IP1,Z1_tlm,Z2_tlm,Z3_tlm,Err,FirstStep,Reject) - END IF - - END IF ! (Err Computation of new step size Hnew - Fac = Err**(-ONE/rkELO)* & - MIN(FacSafe,(ONE+2*NewtonMaxit)/(NewtonIter+2*NewtonMaxit)) - Fac = MIN(FacMax,MAX(FacMin,Fac)) - Hnew = Fac*H - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Accept/reject step -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -accept:IF (Err < ONE) THEN !~~~> STEP IS ACCEPTED - - FirstStep=.FALSE. - ISTATUS(Nacc) = ISTATUS(Nacc) + 1 - IF (Gustafsson) THEN - !~~~> Predictive controller of Gustafsson - IF (ISTATUS(Nacc) > 1) THEN - FacGus=FacSafe*(H/Hacc)*(Err**2/ErrOld)**(-0.25d0) - FacGus=MIN(FacMax,MAX(FacMin,FacGus)) - Fac=MIN(Fac,FacGus) - Hnew = Fac*H - END IF - Hacc=H - ErrOld=MAX(1.0d-2,Err) - END IF - Hold = H - T = T+H - ! Update solution: Y <- Y + sum(d_i Z_i) - IF (rkD(1)/=ZERO) CALL WAXPY(N,rkD(1),Z1,1,Y,1) - IF (rkD(2)/=ZERO) CALL WAXPY(N,rkD(2),Z2,1,Y,1) - IF (rkD(3)/=ZERO) CALL WAXPY(N,rkD(3),Z3,1,Y,1) - ! Update TLM solution: Y <- Y + sum(d_i*Z_i_tlm) - DO itlm = 1,NTLM - IF (rkD(1)/=ZERO) CALL WAXPY(N,rkD(1),Z1_tlm(1,itlm),1,Y_tlm(1,itlm),1) - IF (rkD(2)/=ZERO) CALL WAXPY(N,rkD(2),Z2_tlm(1,itlm),1,Y_tlm(1,itlm),1) - IF (rkD(3)/=ZERO) CALL WAXPY(N,rkD(3),Z3_tlm(1,itlm),1,Y_tlm(1,itlm),1) - END DO - ! Construct the solution quadratic interpolant Q(c_i) = Z_i, i=1:3 - IF (StartNewton) CALL RK_Interpolate('make',N,H,Hold,Z1,Z2,Z3,CONT) - CALL RK_ErrorScale(N,ITOL,AbsTol,RelTol,Y,SCAL) - RSTATUS(Ntexit) = T - RSTATUS(Nhnew) = Hnew - RSTATUS(Nhacc) = H - Hnew = Tdirection*MIN( MAX(ABS(Hnew),Hmin) , Hmax ) - IF (Reject) Hnew = Tdirection*MIN(ABS(Hnew),ABS(H)) - Reject = .FALSE. - IF ((T+Hnew/Qmin-Tend)*Tdirection >= ZERO) THEN - H = Tend-T - ELSE - Hratio=Hnew/H - ! Reuse the LU decomposition - SkipLU = (Theta<=ThetaMin) .AND. (Hratio>=Qmin) .AND. (Hratio<=Qmax) - ! For TLM: do not skip LU (decrease TLM error) - SkipLU = .FALSE. - IF (.NOT.SkipLU) H=Hnew - END IF - ! If convergence is fast enough, do not update Jacobian -! SkipJac = (Theta <= ThetaMin) - SkipJac = .FALSE. ! For TLM: do not skip jac - - ELSE accept !~~~> Step is rejected - - IF (FirstStep .OR. Reject) THEN - H = FacRej*H - ELSE - H = Hnew - END IF - Reject = .TRUE. - SkipJac = .TRUE. - SkipLU = .FALSE. - IF (ISTATUS(Nacc) >= 1) ISTATUS(Nrej) = ISTATUS(Nrej) + 1 - - END IF accept - - END DO Tloop - - ! Successful exit - IERR = 1 - - END SUBROUTINE RK_IntegratorTLM - - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE RK_ErrorMsg(Code,T,H,IERR) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Handles all error messages -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - KPP_REAL, INTENT(IN) :: T, H - INTEGER, INTENT(IN) :: Code - INTEGER, INTENT(OUT) :: IERR - - IERR = Code - PRINT * , & - 'Forced exit from RungeKutta due to the following error:' - - - SELECT CASE (Code) - CASE (-1) - PRINT * , '--> Improper value for maximal no of steps' - CASE (-2) - PRINT * , '--> Improper value for maximal no of Newton iterations' - CASE (-3) - PRINT * , '--> Hmin/Hmax/Hstart must be positive' - CASE (-4) - PRINT * , '--> Improper values for FacMin/FacMax/FacSafe/FacRej' - CASE (-5) - PRINT * , '--> Improper value for ThetaMin' - CASE (-6) - PRINT * , '--> Newton stopping tolerance too small' - CASE (-7) - PRINT * , '--> Improper values for Qmin, Qmax' - CASE (-8) - PRINT * , '--> Tolerances are too small' - CASE (-9) - PRINT * , '--> No of steps exceeds maximum bound' - CASE (-10) - PRINT * , '--> Step size too small: T + 10*H = T', & - ' or H < Roundoff' - CASE (-11) - PRINT * , '--> Matrix is repeatedly singular' - CASE (-12) - PRINT * , '--> Non-convergence of Newton iterations' - CASE (-13) - PRINT * , '--> Requested RK method not implemented' - CASE DEFAULT - PRINT *, 'Unknown Error code: ', Code - END SELECT - - WRITE(6,FMT="(5X,'T=',E12.5,' H=',E12.5)") T, H - - END SUBROUTINE RK_ErrorMsg - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE RK_ErrorScale(N,ITOL,AbsTol,RelTol,Y,SCAL) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Handles all error messages -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - INTEGER, INTENT(IN) :: N, ITOL - KPP_REAL, INTENT(IN) :: AbsTol(*), RelTol(*), Y(N) - KPP_REAL, INTENT(OUT) :: SCAL(N) - INTEGER :: i - - IF (ITOL==0) THEN - DO i=1,N - SCAL(i)= ONE/(AbsTol(1)+RelTol(1)*ABS(Y(i))) - END DO - ELSE - DO i=1,N - SCAL(i)=ONE/(AbsTol(i)+RelTol(i)*ABS(Y(i))) - END DO - END IF - - END SUBROUTINE RK_ErrorScale - - -!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! SUBROUTINE RK_Transform(N,Tr,Z1,Z2,Z3,W1,W2,W3) -!!~~~> W <-- Tr x Z -!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! IMPLICIT NONE -! INTEGER :: N, i -! KPP_REAL :: Tr(3,3),Z1(N),Z2(N),Z3(N),W1(N),W2(N),W3(N) -! KPP_REAL :: x1, x2, x3 -! DO i=1,N -! x1 = Z1(i); x2 = Z2(i); x3 = Z3(i) -! W1(i) = Tr(1,1)*x1 + Tr(1,2)*x2 + Tr(1,3)*x3 -! W2(i) = Tr(2,1)*x1 + Tr(2,2)*x2 + Tr(2,3)*x3 -! W3(i) = Tr(3,1)*x1 + Tr(3,2)*x2 + Tr(3,3)*x3 -! END DO -! END SUBROUTINE RK_Transform - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE RK_Interpolate(action,N,H,Hold,Z1,Z2,Z3,CONT) -!~~~> Constructs or evaluates a quadratic polynomial -! that interpolates the Z solution at current step -! and provides starting values for the next step -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - INTEGER, INTENT(IN) :: N - KPP_REAL, INTENT(IN) :: H,Hold - KPP_REAL, INTENT(INOUT) :: Z1(N),Z2(N),Z3(N),CONT(N,3) - CHARACTER(LEN=4), INTENT(IN) :: action - KPP_REAL :: r, x1, x2, x3, den - INTEGER :: i - - SELECT CASE (action) - CASE ('make') - ! Construct the solution quadratic interpolant Q(c_i) = Z_i, i=1:3 - den = (rkC(3)-rkC(2))*(rkC(2)-rkC(1))*(rkC(1)-rkC(3)) - DO i=1,N - CONT(i,1)=(-rkC(3)**2*rkC(2)*Z1(i)+Z3(i)*rkC(2)*rkC(1)**2 & - +rkC(2)**2*rkC(3)*Z1(i)-rkC(2)**2*rkC(1)*Z3(i) & - +rkC(3)**2*rkC(1)*Z2(i)-Z2(i)*rkC(3)*rkC(1)**2)& - /den-Z3(i) - CONT(i,2)= -( rkC(1)**2*(Z3(i)-Z2(i)) + rkC(2)**2*(Z1(i) & - -Z3(i)) +rkC(3)**2*(Z2(i)-Z1(i)) )/den - CONT(i,3)= ( rkC(1)*(Z3(i)-Z2(i)) + rkC(2)*(Z1(i)-Z3(i)) & - +rkC(3)*(Z2(i)-Z1(i)) )/den - END DO - CASE ('eval') - ! Evaluate quadratic polynomial - r = H/Hold - x1 = ONE + rkC(1)*r - x2 = ONE + rkC(2)*r - x3 = ONE + rkC(3)*r - DO i=1,N - Z1(i) = CONT(i,1)+x1*(CONT(i,2)+x1*CONT(i,3)) - Z2(i) = CONT(i,1)+x2*(CONT(i,2)+x2*CONT(i,3)) - Z3(i) = CONT(i,1)+x3*(CONT(i,2)+x3*CONT(i,3)) - END DO - END SELECT - END SUBROUTINE RK_Interpolate - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE RK_PrepareRHS(N,T,H,Y,Z1,Z2,Z3,R1,R2,R3) -!~~~> Prepare the right-hand side for Newton iterations -! R = Z - hA x F -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - - INTEGER, INTENT(IN) :: N - KPP_REAL, INTENT(IN) :: T, H - KPP_REAL, INTENT(IN), DIMENSION(N) :: Y,Z1,Z2,Z3 - KPP_REAL, INTENT(INOUT), DIMENSION(N) :: R1,R2,R3 - KPP_REAL, DIMENSION(N) :: F, TMP - - CALL WCOPY(N,Z1,1,R1,1) ! R1 <- Z1 - CALL WCOPY(N,Z2,1,R2,1) ! R2 <- Z2 - CALL WCOPY(N,Z3,1,R3,1) ! R3 <- Z3 - - CALL WADD(N,Y,Z1,TMP) ! TMP <- Y + Z1 - CALL FUN_CHEM(T+rkC(1)*H,TMP,F) ! F1 <- Fun(Y+Z1) - CALL WAXPY(N,-H*rkA(1,1),F,1,R1,1) ! R1 <- R1 - h*A_11*F1 - CALL WAXPY(N,-H*rkA(2,1),F,1,R2,1) ! R2 <- R2 - h*A_21*F1 - CALL WAXPY(N,-H*rkA(3,1),F,1,R3,1) ! R3 <- R3 - h*A_31*F1 - - CALL WADD(N,Y,Z2,TMP) ! TMP <- Y + Z2 - CALL FUN_CHEM(T+rkC(2)*H,TMP,F) ! F2 <- Fun(Y+Z2) - CALL WAXPY(N,-H*rkA(1,2),F,1,R1,1) ! R1 <- R1 - h*A_12*F2 - CALL WAXPY(N,-H*rkA(2,2),F,1,R2,1) ! R2 <- R2 - h*A_22*F2 - CALL WAXPY(N,-H*rkA(3,2),F,1,R3,1) ! R3 <- R3 - h*A_32*F2 - - CALL WADD(N,Y,Z3,TMP) ! TMP <- Y + Z3 - CALL FUN_CHEM(T+rkC(3)*H,TMP,F) ! F3 <- Fun(Y+Z3) - CALL WAXPY(N,-H*rkA(1,3),F,1,R1,1) ! R1 <- R1 - h*A_13*F3 - CALL WAXPY(N,-H*rkA(2,3),F,1,R2,1) ! R2 <- R2 - h*A_23*F3 - CALL WAXPY(N,-H*rkA(3,3),F,1,R3,1) ! R3 <- R3 - h*A_33*F3 - - END SUBROUTINE RK_PrepareRHS - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE RK_PrepareRHS_TLM(N,H,Jac1,Jac2,Jac3,Y_tlm, & - Z1_tlm,Z2_tlm,Z3_tlm,R1,R2,R3) -!~~~> Prepare the right-hand side for Newton iterations -! R = Z_tlm - hA x Jac*Z_tlm -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - - INTEGER, INTENT(IN) :: N - KPP_REAL, INTENT(IN) :: H - KPP_REAL, INTENT(IN), DIMENSION(N) :: Y_tlm,Z1_tlm,Z2_tlm,Z3_tlm - KPP_REAL, INTENT(INOUT), DIMENSION(N) :: R1,R2,R3 -#ifdef FULL_ALGEBRA - KPP_REAL, INTENT(IN), DIMENSION(NVAR,NVAR) :: Jac1, Jac2, Jac3 -#else - KPP_REAL, INTENT(IN), DIMENSION(LU_NONZERO) :: Jac1, Jac2, Jac3 -#endif - KPP_REAL, DIMENSION(N) :: F, TMP - - CALL WCOPY(N,Z1_tlm,1,R1,1) ! R1 <- Z1_tlm - CALL WCOPY(N,Z2_tlm,1,R2,1) ! R2 <- Z2_tlm - CALL WCOPY(N,Z3_tlm,1,R3,1) ! R3 <- Z3_tlm - - CALL WADD(N,Y_tlm,Z1_tlm,TMP) ! TMP <- Y + Z1 -#ifdef FULL_ALGEBRA - F = MATMUL(Jac1,TMP) -#else - CALL Jac_SP_Vec ( Jac1, TMP, F ) ! F1 <- Jac(Y+Z1)*(Y_tlm+Z1_tlm) -#endif - CALL WAXPY(N,-H*rkA(1,1),F,1,R1,1) ! R1 <- R1 - h*A_11*F1 - CALL WAXPY(N,-H*rkA(2,1),F,1,R2,1) ! R2 <- R2 - h*A_21*F1 - CALL WAXPY(N,-H*rkA(3,1),F,1,R3,1) ! R3 <- R3 - h*A_31*F1 - - CALL WADD(N,Y_tlm,Z2_tlm,TMP) ! TMP <- Y + Z2 -#ifdef FULL_ALGEBRA - F = MATMUL(Jac2,TMP) -#else - CALL Jac_SP_Vec ( Jac2, TMP, F ) ! F2 <- Jac(Y+Z2)*(Y_tlm+Z2_tlm) -#endif - CALL WAXPY(N,-H*rkA(1,2),F,1,R1,1) ! R1 <- R1 - h*A_12*F2 - CALL WAXPY(N,-H*rkA(2,2),F,1,R2,1) ! R2 <- R2 - h*A_22*F2 - CALL WAXPY(N,-H*rkA(3,2),F,1,R3,1) ! R3 <- R3 - h*A_32*F2 - - CALL WADD(N,Y_tlm,Z3_tlm,TMP) ! TMP <- Y + Z3 -#ifdef FULL_ALGEBRA - F = MATMUL(Jac3,TMP) -#else - CALL Jac_SP_Vec ( Jac3, TMP, F ) ! F3 <- Jac(Y+Z3)*(Y_tlm+Z3_tlm) -#endif - CALL WAXPY(N,-H*rkA(1,3),F,1,R1,1) ! R1 <- R1 - h*A_13*F3 - CALL WAXPY(N,-H*rkA(2,3),F,1,R2,1) ! R2 <- R2 - h*A_23*F3 - CALL WAXPY(N,-H*rkA(3,3),F,1,R3,1) ! R3 <- R3 - h*A_33*F3 - - END SUBROUTINE RK_PrepareRHS_TLM - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE RK_PrepareRHS_TLMdirect(N,H,Jac1,Jac2,Jac3,Y_tlm,Zbig) -!~~~> Prepare the right-hand side for direct solution -! Z = hA x Jac*Y_tlm -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - - INTEGER, INTENT(IN) :: N - KPP_REAL, INTENT(IN) :: H - KPP_REAL, INTENT(IN), DIMENSION(N) :: Y_tlm -! Commented code for sparse big linear algebra: -! KPP_REAL, INTENT(OUT), DIMENSION(3,N) :: Zbig - KPP_REAL, INTENT(OUT), DIMENSION(3*N) :: Zbig -#ifdef FULL_ALGEBRA - KPP_REAL, INTENT(IN), DIMENSION(NVAR,NVAR) :: Jac1, Jac2, Jac3 -#else - KPP_REAL, INTENT(IN), DIMENSION(LU_NONZERO) :: Jac1, Jac2, Jac3 -#endif - KPP_REAL, DIMENSION(N) :: F, TMP - -#ifdef FULL_ALGEBRA - F = MATMUL(Jac1,Y_tlm) -#else - CALL Jac_SP_Vec ( Jac1, Y_tlm, F ) ! F1 <- Jac(Y+Z1)*(Y_tlm) -#endif -! Commented code for sparse big linear algebra: -! Zbig(1,1:N) = H*rkA(1,1)*F(1:N) -! Zbig(2,1:N) = H*rkA(2,1)*F(1:N) -! Zbig(3,1:N) = H*rkA(3,1)*F(1:N) - Zbig(1:N) = H*rkA(1,1)*F(1:N) - Zbig(N+1:2*N) = H*rkA(2,1)*F(1:N) - Zbig(2*N+1:3*N) = H*rkA(3,1)*F(1:N) - -#ifdef FULL_ALGEBRA - F = MATMUL(Jac2,Y_tlm) -#else - CALL Jac_SP_Vec ( Jac2, Y_tlm, F ) ! F2 <- Jac(Y+Z2)*(Y_tlm) -#endif -! Commented code for sparse big linear algebra: -! Zbig(1,1:N) = Zbig(1,1:N) + H*rkA(1,2)*F(1:N) -! Zbig(2,1:N) = Zbig(2,1:N) + H*rkA(2,2)*F(1:N) -! Zbig(3,1:N) = Zbig(3,1:N) + H*rkA(3,2)*F(1:N) - Zbig(1:N) = Zbig(1:N) + H*rkA(1,2)*F(1:N) - Zbig(N+1:2*N) = Zbig(N+1:2*N) + H*rkA(2,2)*F(1:N) - Zbig(2*N+1:3*N) = Zbig(2*N+1:3*N) + H*rkA(3,2)*F(1:N) - -#ifdef FULL_ALGEBRA - F = MATMUL(Jac3,Y_tlm) -#else - CALL Jac_SP_Vec ( Jac3, Y_tlm, F ) ! F3 <- Jac(Y+Z3)*(Y_tlm) -#endif -! Commented code for sparse big linear algebra: -! Zbig(1,1:N) = Zbig(1,1:N) + H*rkA(1,3)*F(1:N) -! Zbig(2,1:N) = Zbig(2,1:N) + H*rkA(2,3)*F(1:N) -! Zbig(3,1:N) = Zbig(3,1:N) + H*rkA(3,3)*F(1:N) - Zbig(1:N) = Zbig(1:N) + H*rkA(1,3)*F(1:N) - Zbig(N+1:2*N) = Zbig(N+1:2*N) + H*rkA(2,3)*F(1:N) - Zbig(2*N+1:3*N) = Zbig(2*N+1:3*N) + H*rkA(3,3)*F(1:N) - - END SUBROUTINE RK_PrepareRHS_TLMdirect - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE RK_Decomp(N,H,FJAC,E1,IP1,E2,IP2,ISING) - !~~~> Compute the matrices E1 and E2 and their decompositions -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - - INTEGER, INTENT(IN) :: N - KPP_REAL, INTENT(IN) :: H -#ifdef FULL_ALGEBRA - KPP_REAL, INTENT(IN) :: FJAC(NVAR,NVAR) - KPP_REAL, INTENT(OUT) ::E1(NVAR,NVAR) - COMPLEX(kind=dp), INTENT(OUT) :: E2(N,N) -#else - KPP_REAL, INTENT(IN) :: FJAC(LU_NONZERO) - KPP_REAL, INTENT(OUT) :: E1(LU_NONZERO) - COMPLEX(kind=dp),INTENT(OUT) :: E2(LU_NONZERO) -#endif - INTEGER, INTENT(OUT) :: IP1(N), IP2(N), ISING - - INTEGER :: i, j - KPP_REAL :: Alpha, Beta, Gamma - - Gamma = rkGamma/H - Alpha = rkAlpha/H - Beta = rkBeta /H - -#ifdef FULL_ALGEBRA - DO j=1,N - DO i=1,N - E1(i,j)=-FJAC(i,j) - END DO - E1(j,j)=E1(j,j)+Gamma - END DO - CALL DGETRF(N,N,E1,N,IP1,ISING) -#else - DO i=1,LU_NONZERO - E1(i)=-FJAC(i) - END DO - DO i=1,NVAR - j=LU_DIAG(i); E1(j)=E1(j)+Gamma - END DO - CALL KppDecomp(E1,ISING) -#endif - - IF (ISING /= 0) THEN - ISTATUS(Ndec) = ISTATUS(Ndec) + 1 - RETURN - END IF - -#ifdef FULL_ALGEBRA - DO j=1,N - DO i=1,N - E2(i,j) = DCMPLX( -FJAC(i,j), ZERO ) - END DO - E2(j,j) = E2(j,j) + CMPLX( Alpha, Beta ) - END DO - CALL ZGETRF(N,N,E2,N,IP2,ISING) -#else - DO i=1,LU_NONZERO - E2(i) = DCMPLX( -FJAC(i), ZERO ) - END DO - DO i=1,NVAR - j = LU_DIAG(i); E2(j)=E2(j) + CMPLX( Alpha, Beta ) - END DO - CALL KppDecompCmplx(E2,ISING) -#endif - ISTATUS(Ndec) = ISTATUS(Ndec) + 1 - - END SUBROUTINE RK_Decomp - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE RK_Solve(N,H,E1,IP1,E2,IP2,R1,R2,R3,ISING) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - INTEGER, INTENT(IN) :: N,IP1(NVAR),IP2(NVAR) - INTEGER, INTENT(OUT) :: ISING -#ifdef FULL_ALGEBRA - KPP_REAL, INTENT(IN) :: E1(NVAR,NVAR) - COMPLEX(kind=dp), INTENT(IN) :: E2(NVAR,NVAR) -#else - KPP_REAL, INTENT(IN) :: E1(LU_NONZERO) - COMPLEX(kind=dp), INTENT(IN) :: E2(LU_NONZERO) -#endif - KPP_REAL, INTENT(IN) :: H - KPP_REAL, INTENT(INOUT) :: R1(N),R2(N),R3(N) - - KPP_REAL :: x1, x2, x3 - COMPLEX(kind=dp) :: BC(N) - INTEGER :: i -! - ! Z <- h^{-1) T^{-1) A^{-1) x Z - DO i=1,N - x1 = R1(i)/H; x2 = R2(i)/H; x3 = R3(i)/H - R1(i) = rkTinvAinv(1,1)*x1 + rkTinvAinv(1,2)*x2 + rkTinvAinv(1,3)*x3 - R2(i) = rkTinvAinv(2,1)*x1 + rkTinvAinv(2,2)*x2 + rkTinvAinv(2,3)*x3 - R3(i) = rkTinvAinv(3,1)*x1 + rkTinvAinv(3,2)*x2 + rkTinvAinv(3,3)*x3 - END DO - -#ifdef FULL_ALGEBRA - CALL DGETRS ('N',N,1,E1,N,IP1,R1,N,0) -#else - CALL KppSolve (E1,R1) -#endif -! - DO i=1,N - BC(i) = DCMPLX(R2(i),R3(i)) - END DO -#ifdef FULL_ALGEBRA - CALL ZGETRS ('N',N,1,E2,N,IP2,BC,N,0) -#else - CALL KppSolveCmplx (E2,BC) -#endif - DO i=1,N - R2(i) = DBLE( BC(i) ) - R3(i) = AIMAG( BC(i) ) - END DO - - ! Z <- T x Z - DO i=1,N - x1 = R1(i); x2 = R2(i); x3 = R3(i) - R1(i) = rkT(1,1)*x1 + rkT(1,2)*x2 + rkT(1,3)*x3 - R2(i) = rkT(2,1)*x1 + rkT(2,2)*x2 + rkT(2,3)*x3 - R3(i) = rkT(3,1)*x1 + rkT(3,2)*x2 + rkT(3,3)*x3 - END DO - - ISTATUS(Nsol) = ISTATUS(Nsol) + 1 - - END SUBROUTINE RK_Solve - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE RK_ErrorEstimate(N,H,Y,T, & - E1,IP1,Z1,Z2,Z3,SCAL,Err, & - FirstStep,Reject) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - - INTEGER, INTENT(IN) :: N, IP1(N) -#ifdef FULL_ALGEBRA - KPP_REAL, INTENT(IN) :: E1(NVAR,NVAR) -#else - KPP_REAL, INTENT(IN) :: E1(LU_NONZERO) -#endif - KPP_REAL, INTENT(IN) :: T,H,SCAL(N),Z1(N),Z2(N),Z3(N),Y(N) - LOGICAL,INTENT(IN) :: FirstStep,Reject - KPP_REAL, INTENT(INOUT) :: Err - - KPP_REAL :: F1(N),F2(N),F0(N),TMP(N) - INTEGER :: i - KPP_REAL :: HEE1,HEE2,HEE3 - - HEE1 = rkE(1)/H - HEE2 = rkE(2)/H - HEE3 = rkE(3)/H - - CALL FUN_CHEM(T,Y,F0) - ISTATUS(Nfun) = ISTATUS(Nfun) + 1 - - DO i=1,N - F2(i) = HEE1*Z1(i)+HEE2*Z2(i)+HEE3*Z3(i) - TMP(i) = rkE(0)*F0(i) + F2(i) - END DO - -#ifdef FULL_ALGEBRA - CALL DGETRS ('N',N,1,E1,N,IP1,TMP,N,0) - IF ((rkMethod==R1A).OR.(rkMethod==GAU).OR.(rkMethod==L3A)) CALL DGETRS ('N',N,1,E1,N,IP1,TMP,N,0) - IF (rkMethod==GAU) CALL DGETRS ('N',N,1,E1,N,IP1,TMP,N,0) -#else - CALL KppSolve (E1, TMP) - IF ((rkMethod==R1A).OR.(rkMethod==GAU).OR.(rkMethod==L3A)) CALL KppSolve (E1,TMP) - IF (rkMethod==GAU) CALL KppSolve (E1,TMP) -#endif - - Err = RK_ErrorNorm(N,SCAL,TMP) -! - IF (Err < ONE) RETURN -firej:IF (FirstStep.OR.Reject) THEN - DO i=1,N - TMP(i)=Y(i)+TMP(i) - END DO - CALL FUN_CHEM(T,TMP,F1) - ISTATUS(Nfun) = ISTATUS(Nfun) + 1 - DO i=1,N - TMP(i)=F1(i)+F2(i) - END DO - -#ifdef FULL_ALGEBRA - CALL DGETRS ('N',N,1,E1,N,IP1,TMP,N,0) -#else - CALL KppSolve (E1, TMP) -#endif - Err = RK_ErrorNorm(N,SCAL,TMP) - END IF firej - - END SUBROUTINE RK_ErrorEstimate - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE RK_ErrorEstimate_tlm(N,NTLM,T,H,FJAC,Y,Y_tlm, & - E1,IP1,Z1_tlm,Z2_tlm,Z3_tlm,FWD_Err, & - FirstStep,Reject) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - - INTEGER, INTENT(IN) :: N,NTLM,IP1(N) -#ifdef FULL_ALGEBRA - KPP_REAL, INTENT(IN) :: FJAC(N,N), E1(N,N) - KPP_REAL :: J0(N,N) -#else - KPP_REAL, INTENT(IN) :: FJAC(LU_NONZERO), E1(LU_NONZERO) - KPP_REAL :: J0(LU_NONZERO) -#endif - KPP_REAL, INTENT(IN) :: T,H, Z1_tlm(N,NTLM),Z2_tlm(N,NTLM),Z3_tlm(N,NTLM), & - Y_tlm(N,NTLM), Y(N) - LOGICAL, INTENT(IN) :: FirstStep, Reject - KPP_REAL, INTENT(INOUT) :: FWD_Err - - INTEGER :: itlm - KPP_REAL :: HEE1,HEE2,HEE3, SCAL_tlm(N), Err, TMP(N), TMP2(N), JY_tlm(N) - - HEE1 = rkE(1)/H - HEE2 = rkE(2)/H - HEE3 = rkE(3)/H - - DO itlm=1,NTLM - CALL RK_ErrorScale(N,ITOL,AbsTol_tlm(1,itlm),RelTol_tlm(1,itlm), & - Y_tlm(1,itlm),SCAL_tlm) - - CALL JAC_CHEM(T,Y,J0) - ISTATUS(Njac) = ISTATUS(Njac) + 1 - CALL JAC_SP_Vec(J0,Y_tlm(1,itlm),JY_tlm) - - DO i=1,N - TMP2(i) = HEE1*Z1_tlm(i,itlm)+HEE2*Z2_tlm(i,itlm)+HEE3*Z3_tlm(i,itlm) - TMP(i) = rkE(0)*JY_tlm(i) + TMP2(i) - END DO - -#ifdef FULL_ALGEBRA - CALL DGETRS ('N',N,1,E1,N,IP1,TMP,N,0) -! IF ((ICNTRL(3)==3).OR.(ICNTRL(3)==4)) CALL DGETRS ('N',N,1,E1,N,IP1,TMP,N,0) -! IF (ICNTRL(3)==3) CALL DGETRS ('N',N,1,E1,N,IP1,TMP,N,0) -#else - CALL KppSolve (E1, TMP) -! IF ((ICNTRL(3)==3).OR.(ICNTRL(3)==4)) THEN -! CALL KppSolve (E1,TMP) -! END IF -! IF (ICNTRL(3)==3) THEN -! CALL KppSolve (E1,TMP) -! END IF -#endif - - Err = RK_ErrorNorm(N,SCAL_tlm,TMP) -! - FWD_Err = MAX(FWD_Err, Err) - END DO - - END SUBROUTINE RK_ErrorEstimate_tlm - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - KPP_REAL FUNCTION RK_ErrorNorm(N,SCAL,DY) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - - INTEGER, INTENT(IN) :: N - KPP_REAL, INTENT(IN) :: SCAL(N),DY(N) - INTEGER :: i - - RK_ErrorNorm = ZERO - DO i=1,N - RK_ErrorNorm = RK_ErrorNorm + (DY(i)*SCAL(i))**2 - END DO - RK_ErrorNorm = MAX( SQRT(RK_ErrorNorm/N), 1.0d-10 ) - - END FUNCTION RK_ErrorNorm - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Radau2A_Coefficients -! The coefficients of the 3-stage Radau-2A method -! (given to ~30 accurate digits) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE -! The coefficients of the Radau2A method - KPP_REAL :: b0 - -! b0 = 1.0d0 - IF (SdirkError) THEN - b0 = 0.2d-1 - ELSE - b0 = 0.5d-1 - END IF - -! The coefficients of the Radau2A method - rkMethod = R2A - - rkA(1,1) = 1.968154772236604258683861429918299d-1 - rkA(1,2) = -6.55354258501983881085227825696087d-2 - rkA(1,3) = 2.377097434822015242040823210718965d-2 - rkA(2,1) = 3.944243147390872769974116714584975d-1 - rkA(2,2) = 2.920734116652284630205027458970589d-1 - rkA(2,3) = -4.154875212599793019818600988496743d-2 - rkA(3,1) = 3.764030627004672750500754423692808d-1 - rkA(3,2) = 5.124858261884216138388134465196080d-1 - rkA(3,3) = 1.111111111111111111111111111111111d-1 - - rkB(1) = 3.764030627004672750500754423692808d-1 - rkB(2) = 5.124858261884216138388134465196080d-1 - rkB(3) = 1.111111111111111111111111111111111d-1 - - rkC(1) = 1.550510257216821901802715925294109d-1 - rkC(2) = 6.449489742783178098197284074705891d-1 - rkC(3) = 1.0d0 - - ! New solution: H* Sum B_j*f(Z_j) = Sum D_j*Z_j - rkD(1) = 0.0d0 - rkD(2) = 0.0d0 - rkD(3) = 1.0d0 - - ! Classical error estimator: - ! H* Sum (B_j-Bhat_j)*f(Z_j) = H*E(0)*f(0) + Sum E_j*Z_j - rkE(0) = 1.0d0*b0 - rkE(1) = -10.04880939982741556246032950764708d0*b0 - rkE(2) = 1.382142733160748895793662840980412d0*b0 - rkE(3) = -.3333333333333333333333333333333333d0*b0 - - ! Sdirk error estimator - rkBgam(0) = b0 - rkBgam(1) = .3764030627004672750500754423692807d0-1.558078204724922382431975370686279d0*b0 - rkBgam(2) = .8914115380582557157653087040196118d0*b0+.5124858261884216138388134465196077d0 - rkBgam(3) = -.1637777184845662566367174924883037d0-.3333333333333333333333333333333333d0*b0 - rkBgam(4) = .2748888295956773677478286035994148d0 - - ! H* Sum Bgam_j*f(Z_j) = H*Bgam(0)*f(0) + Sum Theta_j*Z_j - rkTheta(1) = -1.520677486405081647234271944611547d0-10.04880939982741556246032950764708d0*b0 - rkTheta(2) = 2.070455145596436382729929151810376d0+1.382142733160748895793662840980413d0*b0 - rkTheta(3) = -.3333333333333333333333333333333333d0*b0-.3744441479783868387391430179970741d0 - - ! Local order of error estimator - IF (b0==0.0d0) THEN - rkELO = 6.0d0 - ELSE - rkELO = 4.0d0 - END IF - - !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - !~~~> Diagonalize the RK matrix: - ! rkTinv * inv(rkA) * rkT = - ! | rkGamma 0 0 | - ! | 0 rkAlpha -rkBeta | - ! | 0 rkBeta rkAlpha | - !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - rkGamma = 3.637834252744495732208418513577775d0 - rkAlpha = 2.681082873627752133895790743211112d0 - rkBeta = 3.050430199247410569426377624787569d0 - - rkT(1,1) = 9.443876248897524148749007950641664d-2 - rkT(1,2) = -1.412552950209542084279903838077973d-1 - rkT(1,3) = -3.00291941051474244918611170890539d-2 - rkT(2,1) = 2.502131229653333113765090675125018d-1 - rkT(2,2) = 2.041293522937999319959908102983381d-1 - rkT(2,3) = 3.829421127572619377954382335998733d-1 - rkT(3,1) = 1.0d0 - rkT(3,2) = 1.0d0 - rkT(3,3) = 0.0d0 - - rkTinv(1,1) = 4.178718591551904727346462658512057d0 - rkTinv(1,2) = 3.27682820761062387082533272429617d-1 - rkTinv(1,3) = 5.233764454994495480399309159089876d-1 - rkTinv(2,1) = -4.178718591551904727346462658512057d0 - rkTinv(2,2) = -3.27682820761062387082533272429617d-1 - rkTinv(2,3) = 4.766235545005504519600690840910124d-1 - rkTinv(3,1) = -5.02872634945786875951247343139544d-1 - rkTinv(3,2) = 2.571926949855605429186785353601676d0 - rkTinv(3,3) = -5.960392048282249249688219110993024d-1 - - rkTinvAinv(1,1) = 1.520148562492775501049204957366528d+1 - rkTinvAinv(1,2) = 1.192055789400527921212348994770778d0 - rkTinvAinv(1,3) = 1.903956760517560343018332287285119d0 - rkTinvAinv(2,1) = -9.669512977505946748632625374449567d0 - rkTinvAinv(2,2) = -8.724028436822336183071773193986487d0 - rkTinvAinv(2,3) = 3.096043239482439656981667712714881d0 - rkTinvAinv(3,1) = -1.409513259499574544876303981551774d+1 - rkTinvAinv(3,2) = 5.895975725255405108079130152868952d0 - rkTinvAinv(3,3) = -1.441236197545344702389881889085515d-1 - - rkAinvT(1,1) = .3435525649691961614912493915818282d0 - rkAinvT(1,2) = -.4703191128473198422370558694426832d0 - rkAinvT(1,3) = .3503786597113668965366406634269080d0 - rkAinvT(2,1) = .9102338692094599309122768354288852d0 - rkAinvT(2,2) = 1.715425895757991796035292755937326d0 - rkAinvT(2,3) = .4040171993145015239277111187301784d0 - rkAinvT(3,1) = 3.637834252744495732208418513577775d0 - rkAinvT(3,2) = 2.681082873627752133895790743211112d0 - rkAinvT(3,3) = -3.050430199247410569426377624787569d0 - - END SUBROUTINE Radau2A_Coefficients - - - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Lobatto3C_Coefficients -! The coefficients of the 3-stage Lobatto-3C method -! (given to ~30 accurate digits) -! The parameter b0 can be chosen to tune the error estimator -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - KPP_REAL :: b0 - - rkMethod = L3C - -! b0 = 1.0d0 - IF (SdirkError) THEN - b0 = 0.2d0 - ELSE - b0 = 0.5d0 - END IF -! The coefficients of the Lobatto3C method - - rkA(1,1) = .1666666666666666666666666666666667d0 - rkA(1,2) = -.3333333333333333333333333333333333d0 - rkA(1,3) = .1666666666666666666666666666666667d0 - rkA(2,1) = .1666666666666666666666666666666667d0 - rkA(2,2) = .4166666666666666666666666666666667d0 - rkA(2,3) = -.8333333333333333333333333333333333d-1 - rkA(3,1) = .1666666666666666666666666666666667d0 - rkA(3,2) = .6666666666666666666666666666666667d0 - rkA(3,3) = .1666666666666666666666666666666667d0 - - rkB(1) = .1666666666666666666666666666666667d0 - rkB(2) = .6666666666666666666666666666666667d0 - rkB(3) = .1666666666666666666666666666666667d0 - - rkC(1) = 0.0d0 - rkC(2) = 0.5d0 - rkC(3) = 1.0d0 - - ! Classical error estimator, embedded solution: - rkBhat(0) = b0 - rkBhat(1) = .16666666666666666666666666666666667d0-b0 - rkBhat(2) = .66666666666666666666666666666666667d0 - rkBhat(3) = .16666666666666666666666666666666667d0 - - ! New solution: h Sum_j b_j f(Z_j) = sum d_j Z_j - rkD(1) = 0.0d0 - rkD(2) = 0.0d0 - rkD(3) = 1.0d0 - - ! Classical error estimator: - ! H* Sum (B_j-Bhat_j)*f(Z_j) = H*E(0)*f(0) + Sum E_j*Z_j - rkE(0) = .3808338772072650364017425226487022*b0 - rkE(1) = -1.142501631621795109205227567946107*b0 - rkE(2) = -1.523335508829060145606970090594809*b0 - rkE(3) = .3808338772072650364017425226487022*b0 - - ! Sdirk error estimator - rkBgam(0) = b0 - rkBgam(1) = .1666666666666666666666666666666667d0-1.d0*b0 - rkBgam(2) = .6666666666666666666666666666666667d0 - rkBgam(3) = -.2141672105405983697350758559820354d0 - rkBgam(4) = .3808338772072650364017425226487021d0 - - ! H* Sum Bgam_j*f(Z_j) = H*Bgam(0)*f(0) + Sum Theta_j*Z_j - rkTheta(1) = -3.d0*b0-.3808338772072650364017425226487021d0 - rkTheta(2) = -4.d0*b0+1.523335508829060145606970090594808d0 - rkTheta(3) = -.142501631621795109205227567946106d0+b0 - - ! Local order of error estimator - IF (b0==0.0d0) THEN - rkELO = 5.0d0 - ELSE - rkELO = 4.0d0 - END IF - - !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - !~~~> Diagonalize the RK matrix: - ! rkTinv * inv(rkA) * rkT = - ! | rkGamma 0 0 | - ! | 0 rkAlpha -rkBeta | - ! | 0 rkBeta rkAlpha | - !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - rkGamma = 2.625816818958466716011888933765284d0 - rkAlpha = 1.687091590520766641994055533117359d0 - rkBeta = 2.508731754924880510838743672432351d0 - - rkT(1,1) = 1.d0 - rkT(1,2) = 1.d0 - rkT(1,3) = 0.d0 - rkT(2,1) = .4554100411010284672111720348287483d0 - rkT(2,2) = -.6027050205505142336055860174143743d0 - rkT(2,3) = -.4309321229203225731070721341350346d0 - rkT(3,1) = 2.195823345445647152832799205549709d0 - rkT(3,2) = -1.097911672722823576416399602774855d0 - rkT(3,3) = .7850032632435902184104551358922130d0 - - rkTinv(1,1) = .4205559181381766909344950150991349d0 - rkTinv(1,2) = .3488903392193734304046467270632057d0 - rkTinv(1,3) = .1915253879645878102698098373933487d0 - rkTinv(2,1) = .5794440818618233090655049849008650d0 - rkTinv(2,2) = -.3488903392193734304046467270632057d0 - rkTinv(2,3) = -.1915253879645878102698098373933487d0 - rkTinv(3,1) = -.3659705575742745254721332009249516d0 - rkTinv(3,2) = -1.463882230297098101888532803699806d0 - rkTinv(3,3) = .4702733607340189781407813565524989d0 - - rkTinvAinv(1,1) = 1.104302803159744452668648155627548d0 - rkTinvAinv(1,2) = .916122120694355522658740710823143d0 - rkTinvAinv(1,3) = .5029105849749601702795812241441172d0 - rkTinvAinv(2,1) = 1.895697196840255547331351844372453d0 - rkTinvAinv(2,2) = 3.083877879305644477341259289176857d0 - rkTinvAinv(2,3) = -1.502910584974960170279581224144117d0 - rkTinvAinv(3,1) = .8362439183082935036129145574774502d0 - rkTinvAinv(3,2) = -3.344975673233174014451658229909802d0 - rkTinvAinv(3,3) = .312908409479233358005944466882642d0 - - rkAinvT(1,1) = 2.625816818958466716011888933765282d0 - rkAinvT(1,2) = 1.687091590520766641994055533117358d0 - rkAinvT(1,3) = -2.508731754924880510838743672432351d0 - rkAinvT(2,1) = 1.195823345445647152832799205549710d0 - rkAinvT(2,2) = -2.097911672722823576416399602774855d0 - rkAinvT(2,3) = .7850032632435902184104551358922130d0 - rkAinvT(3,1) = 5.765829871932827589653709477334136d0 - rkAinvT(3,2) = .1170850640335862051731452613329320d0 - rkAinvT(3,3) = 4.078738281412060947659653944216779d0 - - END SUBROUTINE Lobatto3C_Coefficients - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Gauss_Coefficients -! The coefficients of the 3-stage Gauss method -! (given to ~30 accurate digits) -! The parameter b3 can be chosen by the user -! to tune the error estimator -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - KPP_REAL :: b0 -! The coefficients of the Gauss method - - - rkMethod = GAU - -! b0 = 4.0d0 - b0 = 0.1d0 - -! The coefficients of the Gauss method - - rkA(1,1) = .1388888888888888888888888888888889d0 - rkA(1,2) = -.359766675249389034563954710966045d-1 - rkA(1,3) = .97894440153083260495800422294756d-2 - rkA(2,1) = .3002631949808645924380249472131556d0 - rkA(2,2) = .2222222222222222222222222222222222d0 - rkA(2,3) = -.224854172030868146602471694353778d-1 - rkA(3,1) = .2679883337624694517281977355483022d0 - rkA(3,2) = .4804211119693833479008399155410489d0 - rkA(3,3) = .1388888888888888888888888888888889d0 - - rkB(1) = .2777777777777777777777777777777778d0 - rkB(2) = .4444444444444444444444444444444444d0 - rkB(3) = .2777777777777777777777777777777778d0 - - rkC(1) = .1127016653792583114820734600217600d0 - rkC(2) = .5000000000000000000000000000000000d0 - rkC(3) = .8872983346207416885179265399782400d0 - - ! Classical error estimator, embedded solution: - rkBhat(0) = b0 - rkBhat(1) =-1.4788305577012361475298775666303999d0*b0 & - +.27777777777777777777777777777777778d0 - rkBhat(2) = .44444444444444444444444444444444444d0 & - +.66666666666666666666666666666666667d0*b0 - rkBhat(3) = -.18783610896543051913678910003626672d0*b0 & - +.27777777777777777777777777777777778d0 - - ! New solution: h Sum_j b_j f(Z_j) = sum d_j Z_j - rkD(1) = .1666666666666666666666666666666667d1 - rkD(2) = -.1333333333333333333333333333333333d1 - rkD(3) = .1666666666666666666666666666666667d1 - - ! Classical error estimator: - ! H* Sum (B_j-Bhat_j)*f(Z_j) = H*E(0)*f(0) + Sum E_j*Z_j - rkE(0) = .2153144231161121782447335303806954d0*b0 - rkE(1) = -2.825278112319014084275808340593191d0*b0 - rkE(2) = .2870858974881495709929780405075939d0*b0 - rkE(3) = -.4558086256248162565397206448274867d-1*b0 - - ! Sdirk error estimator - rkBgam(0) = 0.d0 - rkBgam(1) = .2373339543355109188382583162660537d0 - rkBgam(2) = .5879873931885192299409334646982414d0 - rkBgam(3) = -.4063577064014232702392531134499046d-1 - rkBgam(4) = .2153144231161121782447335303806955d0 - - ! H* Sum Bgam_j*f(Z_j) = H*Bgam(0)*f(0) + Sum Theta_j*Z_j - rkTheta(1) = -2.594040933093095272574031876464493d0 - rkTheta(2) = 1.824611539036311947589425112250199d0 - rkTheta(3) = .1856563166634371860478043996459493d0 - - ! ELO = local order of classical error estimator - rkELO = 4.0d0 - - !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - !~~~> Diagonalize the RK matrix: - ! rkTinv * inv(rkA) * rkT = - ! | rkGamma 0 0 | - ! | 0 rkAlpha -rkBeta | - ! | 0 rkBeta rkAlpha | - !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - rkGamma = 4.644370709252171185822941421408064d0 - rkAlpha = 3.677814645373914407088529289295970d0 - rkBeta = 3.508761919567443321903661209182446d0 - - rkT(1,1) = .7215185205520017032081769924397664d-1 - rkT(1,2) = -.8224123057363067064866206597516454d-1 - rkT(1,3) = -.6012073861930850173085948921439054d-1 - rkT(2,1) = .1188325787412778070708888193730294d0 - rkT(2,2) = .5306509074206139504614411373957448d-1 - rkT(2,3) = .3162050511322915732224862926182701d0 - rkT(3,1) = 1.d0 - rkT(3,2) = 1.d0 - rkT(3,3) = 0.d0 - - rkTinv(1,1) = 5.991698084937800775649580743981285d0 - rkTinv(1,2) = 1.139214295155735444567002236934009d0 - rkTinv(1,3) = .4323121137838583855696375901180497d0 - rkTinv(2,1) = -5.991698084937800775649580743981285d0 - rkTinv(2,2) = -1.139214295155735444567002236934009d0 - rkTinv(2,3) = .5676878862161416144303624098819503d0 - rkTinv(3,1) = -1.246213273586231410815571640493082d0 - rkTinv(3,2) = 2.925559646192313662599230367054972d0 - rkTinv(3,3) = -.2577352012734324923468722836888244d0 - - rkTinvAinv(1,1) = 27.82766708436744962047620566703329d0 - rkTinvAinv(1,2) = 5.290933503982655311815946575100597d0 - rkTinvAinv(1,3) = 2.007817718512643701322151051660114d0 - rkTinvAinv(2,1) = -17.66368928942422710690385180065675d0 - rkTinvAinv(2,2) = -14.45491129892587782538830044147713d0 - rkTinvAinv(2,3) = 2.992182281487356298677848948339886d0 - rkTinvAinv(3,1) = -25.60678350282974256072419392007303d0 - rkTinvAinv(3,2) = 6.762434375611708328910623303779923d0 - rkTinvAinv(3,3) = 1.043979339483109825041215970036771d0 - - rkAinvT(1,1) = .3350999483034677402618981153470483d0 - rkAinvT(1,2) = -.5134173605009692329246186488441294d0 - rkAinvT(1,3) = .6745196507033116204327635673208923d-1 - rkAinvT(2,1) = .5519025480108928886873752035738885d0 - rkAinvT(2,2) = 1.304651810077110066076640761092008d0 - rkAinvT(2,3) = .9767507983414134987545585703726984d0 - rkAinvT(3,1) = 4.644370709252171185822941421408064d0 - rkAinvT(3,2) = 3.677814645373914407088529289295970d0 - rkAinvT(3,3) = -3.508761919567443321903661209182446d0 - - END SUBROUTINE Gauss_Coefficients - - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Radau1A_Coefficients -! The coefficients of the 3-stage Gauss method -! (given to ~30 accurate digits) -! The parameter b3 can be chosen by the user -! to tune the error estimator -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE -! KPP_REAL :: b0 = 0.3d0 - KPP_REAL :: b0 = 0.1d0 - -! The coefficients of the Radau1A method - - rkMethod = R1A - - rkA(1,1) = .1111111111111111111111111111111111d0 - rkA(1,2) = -.1916383190435098943442935597058829d0 - rkA(1,3) = .8052720793239878323318244859477174d-1 - rkA(2,1) = .1111111111111111111111111111111111d0 - rkA(2,2) = .2920734116652284630205027458970589d0 - rkA(2,3) = -.481334970546573839513422644787591d-1 - rkA(3,1) = .1111111111111111111111111111111111d0 - rkA(3,2) = .5370223859435462728402311533676479d0 - rkA(3,3) = .1968154772236604258683861429918299d0 - - rkB(1) = .1111111111111111111111111111111111d0 - rkB(2) = .5124858261884216138388134465196080d0 - rkB(3) = .3764030627004672750500754423692808d0 - - rkC(1) = 0.d0 - rkC(2) = .3550510257216821901802715925294109d0 - rkC(3) = .8449489742783178098197284074705891d0 - - ! Classical error estimator, embedded solution: - rkBhat(0) = b0 - rkBhat(1) = .11111111111111111111111111111111111d0-b0 - rkBhat(2) = .51248582618842161383881344651960810d0 - rkBhat(3) = .37640306270046727505007544236928079d0 - - ! New solution: H* Sum B_j*f(Z_j) = Sum D_j*Z_j - rkD(1) = .3333333333333333333333333333333333d0 - rkD(2) = -.8914115380582557157653087040196127d0 - rkD(3) = .1558078204724922382431975370686279d1 - - ! Classical error estimator: - ! H* Sum (b_j-bhat_j) f(Z_j) = H*E(0)*F(0) + Sum E_j Z_j - rkE(0) = .2748888295956773677478286035994148d0*b0 - rkE(1) = -1.374444147978386838739143017997074d0*b0 - rkE(2) = -1.335337922441686804550326197041126d0*b0 - rkE(3) = .235782604058977333559011782643466d0*b0 - - ! Sdirk error estimator - rkBgam(0) = 0.0d0 - rkBgam(1) = .1948150124588532186183490991130616d-1 - rkBgam(2) = .7575249005733381398986810981093584d0 - rkBgam(3) = -.518952314149008295083446116200793d-1 - rkBgam(4) = .2748888295956773677478286035994148d0 - - ! H* Sum Bgam_j*f(Z_j) = H*Bgam(0)*f(0) + Sum Theta_j*Z_j - rkTheta(1) = -1.224370034375505083904362087063351d0 - rkTheta(2) = .9340045331532641409047527962010133d0 - rkTheta(3) = .4656990124352088397561234800640929d0 - - ! ELO = local order of classical error estimator - rkELO = 4.0d0 - - !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - !~~~> Diagonalize the RK matrix: - ! rkTinv * inv(rkA) * rkT = - ! | rkGamma 0 0 | - ! | 0 rkAlpha -rkBeta | - ! | 0 rkBeta rkAlpha | - !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - rkGamma = 3.637834252744495732208418513577775d0 - rkAlpha = 2.681082873627752133895790743211112d0 - rkBeta = 3.050430199247410569426377624787569d0 - - rkT(1,1) = .424293819848497965354371036408369d0 - rkT(1,2) = -.3235571519651980681202894497035503d0 - rkT(1,3) = -.522137786846287839586599927945048d0 - rkT(2,1) = .57594609499806128896291585429339d-1 - rkT(2,2) = .3148663231849760131614374283783d-2 - rkT(2,3) = .452429247674359778577728510381731d0 - rkT(3,1) = 1.d0 - rkT(3,2) = 1.d0 - rkT(3,3) = 0.d0 - - rkTinv(1,1) = 1.233523612685027760114769983066164d0 - rkTinv(1,2) = 1.423580134265707095505388133369554d0 - rkTinv(1,3) = .3946330125758354736049045150429624d0 - rkTinv(2,1) = -1.233523612685027760114769983066164d0 - rkTinv(2,2) = -1.423580134265707095505388133369554d0 - rkTinv(2,3) = .6053669874241645263950954849570376d0 - rkTinv(3,1) = -.1484438963257383124456490049673414d0 - rkTinv(3,2) = 2.038974794939896109682070471785315d0 - rkTinv(3,3) = -.544501292892686735299355831692542d-1 - - rkTinvAinv(1,1) = 4.487354449794728738538663081025420d0 - rkTinvAinv(1,2) = 5.178748573958397475446442544234494d0 - rkTinvAinv(1,3) = 1.435609490412123627047824222335563d0 - rkTinvAinv(2,1) = -2.854361287939276673073807031221493d0 - rkTinvAinv(2,2) = -1.003648660720543859000994063139137d+1 - rkTinvAinv(2,3) = 1.789135380979465422050817815017383d0 - rkTinvAinv(3,1) = -4.160768067752685525282947313530352d0 - rkTinvAinv(3,2) = 1.124128569859216916690209918405860d0 - rkTinvAinv(3,3) = 1.700644430961823796581896350418417d0 - - rkAinvT(1,1) = 1.543510591072668287198054583233180d0 - rkAinvT(1,2) = -2.460228411937788329157493833295004d0 - rkAinvT(1,3) = -.412906170450356277003910443520499d0 - rkAinvT(2,1) = .209519643211838264029272585946993d0 - rkAinvT(2,2) = 1.388545667194387164417459732995766d0 - rkAinvT(2,3) = 1.20339553005832004974976023130002d0 - rkAinvT(3,1) = 3.637834252744495732208418513577775d0 - rkAinvT(3,2) = 2.681082873627752133895790743211112d0 - rkAinvT(3,3) = -3.050430199247410569426377624787569d0 - - END SUBROUTINE Radau1A_Coefficients - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - END SUBROUTINE RungeKuttaTLM ! and all its internal procedures -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE FUN_CHEM(T, V, FCT) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - USE KPP_ROOT_Parameters - USE KPP_ROOT_Global - USE KPP_ROOT_Function, ONLY: Fun - USE KPP_ROOT_Rates, ONLY: Update_SUN, Update_RCONST, Update_PHOTO - - IMPLICIT NONE - - KPP_REAL, INTENT(IN) :: V(NVAR), T - KPP_REAL, INTENT(INOUT) :: FCT(NVAR) - KPP_REAL :: Told - - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Update_PHOTO() - TIME = Told - - CALL Fun(V, FIX, RCONST, FCT) - - END SUBROUTINE FUN_CHEM - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE JAC_CHEM (T, V, JF) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - USE KPP_ROOT_Parameters - USE KPP_ROOT_Global - USE KPP_ROOT_JacobianSP - USE KPP_ROOT_Jacobian, ONLY: Jac_SP - USE KPP_ROOT_Rates, ONLY: Update_SUN, Update_RCONST, Update_PHOTO - - IMPLICIT NONE - - KPP_REAL, INTENT(IN) :: V(NVAR), T -#ifdef FULL_ALGEBRA - KPP_REAL, INTENT(INOUT) :: JF(NVAR,NVAR) - KPP_REAL :: JV(LU_NONZERO) - INTEGER :: i, j -#else - KPP_REAL, INTENT(INOUT) :: JF(LU_NONZERO) -#endif - - KPP_REAL :: Told - - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Update_PHOTO() - TIME = Told - -#ifdef FULL_ALGEBRA - CALL Jac_SP(V, FIX, RCONST, JV) - DO j=1,NVAR - DO i=1,NVAR - JF(i,j) = 0.0d0 - END DO - END DO - DO i=1,LU_NONZERO - JF(LU_IROW(i),LU_ICOL(i)) = JV(i) - END DO -#else - CALL Jac_SP(V, FIX, RCONST, JF) -#endif - - END SUBROUTINE JAC_CHEM - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -END MODULE KPP_ROOT_Integrator -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - diff --git a/boxmox/int.modified_WCOPY/sdirk_adj.f90 b/boxmox/int.modified_WCOPY/sdirk_adj.f90 deleted file mode 100644 index 086598b95ba495438192b2cf591122835549ed7a..0000000000000000000000000000000000000000 --- a/boxmox/int.modified_WCOPY/sdirk_adj.f90 +++ /dev/null @@ -1,1669 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! -! Adjoint of SDIRK - Singly-Diagonally-Implicit Runge-Kutta method ! -! * Sdirk 2a, 2b: L-stable, 2 stages, order 2 ! -! * Sdirk 3a: L-stable, 3 stages, order 2, adj-invariant ! -! * Sdirk 4a, 4b: L-stable, 5 stages, order 4 ! -! By default the code employs the KPP sparse linear algebra routines ! -! Compile with -DFULL_ALGEBRA to use full linear algebra (LAPACK) ! -! ! -! (C) Adrian Sandu, July 2005 ! -! Virginia Polytechnic Institute and State University ! -! Contact: sandu@cs.vt.edu ! -! Revised by Philipp Miehe and Adrian Sandu, May 2006 ! -! This implementation is part of KPP - the Kinetic PreProcessor ! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! - -MODULE KPP_ROOT_Integrator - - USE KPP_ROOT_Precision - USE KPP_ROOT_Global, ONLY: FIX, RCONST, TIME - USE KPP_ROOT_Parameters, ONLY: NVAR, NSPEC, NFIX, LU_NONZERO - USE KPP_ROOT_JacobianSP, ONLY: LU_DIAG - USE KPP_ROOT_Jacobian, ONLY: Jac_SP_Vec, JacTR_SP_Vec - USE KPP_ROOT_LinearAlgebra, ONLY: KppDecomp, KppSolve, & - KppSolveTR, Set2zero, WLAMCH, WCOPY, WAXPY, WSCAL, WADD - - IMPLICIT NONE - PUBLIC - SAVE - -!~~~> Statistics on the work performed by the SDIRK method - INTEGER, PARAMETER :: Nfun=1, Njac=2, Nstp=3, Nacc=4, & - Nrej=5, Ndec=6, Nsol=7, Nsng=8, & - Ntexit=1, Nhexit=2, Nhnew=3 - -CONTAINS - -SUBROUTINE INTEGRATE_ADJ( NADJ, Y, Lambda, TIN, TOUT, & - ATOL_adj, RTOL_adj, & - ICNTRL_U, RCNTRL_U, ISTATUS_U, RSTATUS_U, Ierr_U ) - - USE KPP_ROOT_Parameters - USE KPP_ROOT_Global - IMPLICIT NONE - -!~~~> Y - Concentrations - KPP_REAL :: Y(NVAR) -!~~~> NADJ - No. of cost functionals for which adjoints -! are evaluated simultaneously -! If single cost functional is considered (like in -! most applications) simply set NADJ = 1 - INTEGER :: NADJ -!~~~> Lambda - Sensitivities w.r.t. concentrations -! Note: Lambda (1:NVAR,j) contains sensitivities of -! the j-th cost functional w.r.t. Y(1:NVAR), j=1...NADJ - KPP_REAL :: Lambda(NVAR,NADJ) -!~~~> Tolerances for adjoint calculations -! (used for full continuous adjoint, and for controlling -! iterations when used to solve the discrete adjoint) - KPP_REAL, INTENT(IN) :: ATOL_adj(NVAR,NADJ), RTOL_adj(NVAR,NADJ) - KPP_REAL, INTENT(IN) :: TIN ! Start Time - KPP_REAL, INTENT(IN) :: TOUT ! End Time - ! Optional input parameters and statistics - INTEGER, INTENT(IN), OPTIONAL :: ICNTRL_U(20) - KPP_REAL, INTENT(IN), OPTIONAL :: RCNTRL_U(20) - INTEGER, INTENT(OUT), OPTIONAL :: ISTATUS_U(20) - KPP_REAL, INTENT(OUT), OPTIONAL :: RSTATUS_U(20) - INTEGER, INTENT(OUT), OPTIONAL :: Ierr_U - - INTEGER, SAVE :: Ntotal = 0 - KPP_REAL :: RCNTRL(20), RSTATUS(20), T1, T2 - INTEGER :: ICNTRL(20), ISTATUS(20), Ierr - - ICNTRL(:) = 0 - RCNTRL(:) = 0.0_dp - ISTATUS(:) = 0 - RSTATUS(:) = 0.0_dp - - !~~~> fine-tune the integrator: - ICNTRL(5) = 8 ! Max no. of Newton iterations - ICNTRL(7) = 1 ! Adjoint solution by: 0=Newton, 1=direct - ICNTRL(8) = 1 ! Save fwd LU factorization: 0 = do *not* save, 1 = save - - ! If optional parameters are given, and if they are >0, - ! then they overwrite default settings. - IF (PRESENT(ICNTRL_U)) THEN - WHERE(ICNTRL_U(:) > 0) ICNTRL(:) = ICNTRL_U(:) - END IF - IF (PRESENT(RCNTRL_U)) THEN - WHERE(RCNTRL_U(:) > 0) RCNTRL(:) = RCNTRL_U(:) - END IF - - - T1 = TIN; T2 = TOUT - CALL SDIRKADJ( NVAR, NADJ, T1, T2, Y, Lambda, & - RTOL, ATOL, ATOL_adj, RTOL_adj, & - RCNTRL, ICNTRL, RSTATUS, ISTATUS, Ierr ) - - !~~~> Debug option: number of steps - ! Ntotal = Ntotal + ISTATUS(Nstp) - ! WRITE(6,777) ISTATUS(Nstp),Ntotal,VAR(ind_O3),VAR(ind_NO2) - ! 777 FORMAT('NSTEPS=',I5,' (',I5,') O3=',E24.14,' NO2=',E24.14) - - IF (Ierr < 0) THEN - PRINT *,'SDIRK: Unsuccessful exit at T=',TIN,' (Ierr=',Ierr,')' - ENDIF - - ! if optional parameters are given for output they to return information - IF (PRESENT(ISTATUS_U)) ISTATUS_U(:) = ISTATUS(:) - IF (PRESENT(RSTATUS_U)) RSTATUS_U(:) = RSTATUS(:) - IF (PRESENT(Ierr_U)) Ierr_U = Ierr - - END SUBROUTINE INTEGRATE_ADJ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SDIRKADJ(N, NADJ, Tinitial, Tfinal, Y, Lambda, & - RelTol, AbsTol, RelTol_adj, AbsTol_adj, & - RCNTRL, ICNTRL, RSTATUS, ISTATUS, Ierr) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -! Solves the system y'=F(t,y) using a Singly-Diagonally-Implicit -! Runge-Kutta (SDIRK) method. -! -! This implementation is based on the book and the code Sdirk4: -! -! E. Hairer and G. Wanner -! "Solving ODEs II. Stiff and differential-algebraic problems". -! Springer series in computational mathematics, Springer-Verlag, 1996. -! This code is based on the SDIRK4 routine in the above book. -! -! Methods: -! * Sdirk 2a, 2b: L-stable, 2 stages, order 2 -! * Sdirk 3a: L-stable, 3 stages, order 2, adjoint-invariant -! * Sdirk 4a, 4b: L-stable, 5 stages, order 4 -! -! (C) Adrian Sandu, July 2005 -! Virginia Polytechnic Institute and State University -! Contact: sandu@cs.vt.edu -! Revised by Philipp Miehe and Adrian Sandu, May 2006 -! This implementation is part of KPP - the Kinetic PreProcessor -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!~~~> INPUT ARGUMENTS: -! -!- Y(NVAR) = vector of initial conditions (at T=Tinitial) -!- [Tinitial,Tfinal] = time range of integration -! (if Tinitial>Tfinal the integration is performed backwards in time) -!- RelTol, AbsTol = user precribed accuracy -!- SUBROUTINE ode_Fun( T, Y, Ydot ) = ODE function, -! returns Ydot = Y' = F(T,Y) -!- SUBROUTINE ode_Fun( T, Y, Ydot ) = Jacobian of the ODE function, -! returns Jcb = dF/dY -!- ICNTRL(1:20) = integer inputs parameters -!- RCNTRL(1:20) = real inputs parameters -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!~~~> OUTPUT ARGUMENTS: -! -!- Y(NVAR) -> vector of final states (at T->Tfinal) -!- ISTATUS(1:20) -> integer output parameters -!- RSTATUS(1:20) -> real output parameters -!- Ierr -> job status upon return -! success (positive value) or -! failure (negative value) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!~~~> INPUT PARAMETERS: -! -! Note: For input parameters equal to zero the default values of the -! corresponding variables are used. -! -! Note: For input parameters equal to zero the default values of the -! corresponding variables are used. -!~~~> -! ICNTRL(1) = not used -! -! ICNTRL(2) = 0: AbsTol, RelTol are NVAR-dimensional vectors -! = 1: AbsTol, RelTol are scalars -! -! ICNTRL(3) = Method -! -! ICNTRL(4) -> maximum number of integration steps -! For ICNTRL(4)=0 the default value of 1500 is used -! Note: use a conservative estimate, since the checkpoint -! buffers are allocated to hold Max_no_steps -! -! ICNTRL(5) -> maximum number of Newton iterations -! For ICNTRL(5)=0 the default value of 8 is used -! -! ICNTRL(6) -> starting values of Newton iterations: -! ICNTRL(6)=0 : starting values are interpolated (the default) -! ICNTRL(6)=1 : starting values are zero -! -! ICNTRL(7) -> method to solve ADJ equations: -! ICNTRL(7)=0 : modified Newton re-using LU (the default) -! ICNTRL(7)=1 : direct solution (additional one LU factorization per stage) -! -! ICNTRL(8) -> checkpointing the LU factorization at each step: -! ICNTRL(8)=0 : do *not* save LU factorization (the default) -! ICNTRL(8)=1 : save LU factorization -! Note: if ICNTRL(7)=1 the LU factorization is *not* saved -! -!~~~> Real parameters -! -! RCNTRL(1) -> Hmin, lower bound for the integration step size -! It is strongly recommended to keep Hmin = ZERO -! RCNTRL(2) -> Hmax, upper bound for the integration step size -! RCNTRL(3) -> Hstart, starting value for the integration step size -! -! RCNTRL(4) -> FacMin, lower bound on step decrease factor (default=0.2) -! RCNTRL(5) -> FacMax, upper bound on step increase factor (default=6) -! RCNTRL(6) -> FacRej, step decrease factor after multiple rejections -! (default=0.1) -! RCNTRL(7) -> FacSafe, by which the new step is slightly smaller -! than the predicted value (default=0.9) -! RCNTRL(8) -> ThetaMin. If Newton convergence rate smaller -! than ThetaMin the Jacobian is not recomputed; -! (default=0.001) -! RCNTRL(9) -> NewtonTol, stopping criterion for Newton's method -! (default=0.03) -! RCNTRL(10) -> Qmin -! RCNTRL(11) -> Qmax. If Qmin < Hnew/Hold < Qmax, then the -! step size is kept constant and the LU factorization -! reused (default Qmin=1, Qmax=1.2) -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!~~~> OUTPUT PARAMETERS: -! -! Note: each call to Rosenbrock adds the current no. of fcn calls -! to previous value of ISTATUS(1), and similar for the other params. -! Set ISTATUS(1:10) = 0 before call to avoid this accumulation. -! -! ISTATUS(1) = No. of function calls -! ISTATUS(2) = No. of jacobian calls -! ISTATUS(3) = No. of steps -! ISTATUS(4) = No. of accepted steps -! ISTATUS(5) = No. of rejected steps (except at the beginning) -! ISTATUS(6) = No. of LU decompositions -! ISTATUS(7) = No. of forward/backward substitutions -! ISTATUS(8) = No. of singular matrix decompositions -! -! RSTATUS(1) -> Texit, the time corresponding to the -! computed Y upon return -! RSTATUS(2) -> Hexit,last accepted step before return -! RSTATUS(3) -> Hnew, last predicted step before return -! For multiple restarts, use Hnew as Hstart in the following run -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - -! Arguments - INTEGER, INTENT(IN) :: N, NADJ, ICNTRL(20) - KPP_REAL, INTENT(INOUT) :: Y(NVAR), Lambda(NVAR,NADJ) - KPP_REAL, INTENT(IN) :: Tinitial, Tfinal, & - RelTol(NVAR), AbsTol(NVAR), RCNTRL(20), & - RelTol_adj(NVAR,NADJ), AbsTol_adj(NVAR,NADJ) - INTEGER, INTENT(OUT) :: Ierr - INTEGER, INTENT(INOUT) :: ISTATUS(20) - KPP_REAL, INTENT(OUT) :: RSTATUS(20) - -!~~~> SDIRK method coefficients, up to 5 stages - INTEGER, PARAMETER :: Smax = 5 - INTEGER, PARAMETER :: S2A=1, S2B=2, S3A=3, S4A=4, S4B=5 - KPP_REAL :: rkGamma, rkA(Smax,Smax), rkB(Smax), rkC(Smax), & - rkD(Smax), rkE(Smax), rkBhat(Smax), rkELO, & - rkAlpha(Smax,Smax), rkTheta(Smax,Smax) - INTEGER :: sdMethod, rkS ! The number of stages - -!~~~> Checkpoints in memory buffers - INTEGER :: stack_ptr = 0 ! last written entry in checkpoint - KPP_REAL, DIMENSION(:), POINTER :: chk_H, chk_T - KPP_REAL, DIMENSION(:,:), POINTER :: chk_Y - KPP_REAL, DIMENSION(:,:,:), POINTER :: chk_Z - INTEGER, DIMENSION(:,:), POINTER :: chk_P -#ifdef FULL_ALGEBRA - KPP_REAL, DIMENSION(:,:,:), POINTER :: chk_J -#else - KPP_REAL, DIMENSION(:,:), POINTER :: chk_J -#endif -! Local variables - KPP_REAL :: Hmin, Hmax, Hstart, Roundoff, & - FacMin, Facmax, FacSafe, FacRej, & - ThetaMin, NewtonTol, Qmin, Qmax - LOGICAL :: SaveLU, DirectADJ - INTEGER :: ITOL, NewtonMaxit, Max_no_steps, i - KPP_REAL, PARAMETER :: ZERO = 0.0d0, ONE = 1.0d0 - KPP_REAL, PARAMETER :: DeltaMin = 1.0d-5 - - -!~~~> Initialize statistics - ISTATUS(1:20) = 0 - RSTATUS(1:20) = ZERO - Ierr = 0 - -!~~~> For Scalar tolerances (ICNTRL(2).NE.0) the code uses AbsTol(1) and RelTol(1) -! For Vector tolerances (ICNTRL(2) == 0) the code uses AbsTol(1:NVAR) and RelTol(1:NVAR) - IF (ICNTRL(2) == 0) THEN - ITOL = 1 - ELSE - ITOL = 0 - END IF - -!~~~> ICNTRL(3) - method selection - SELECT CASE (ICNTRL(3)) - CASE (0,1) - CALL Sdirk2a - CASE (2) - CALL Sdirk2b - CASE (3) - CALL Sdirk3a - CASE (4) - CALL Sdirk4a - CASE (5) - CALL Sdirk4b - CASE DEFAULT - CALL Sdirk2a - END SELECT - -!~~~> The maximum number of time steps admitted - IF (ICNTRL(4) == 0) THEN - Max_no_steps = 200000 - ELSEIF (ICNTRL(4) > 0) THEN - Max_no_steps = ICNTRL(4) - ELSE - PRINT * ,'User-selected ICNTRL(4)=',ICNTRL(4) - CALL SDIRK_ErrorMsg(-1,Tinitial,ZERO,Ierr) - END IF - -!~~~> The maximum number of Newton iterations admitted - IF(ICNTRL(5) == 0)THEN - NewtonMaxit=8 - ELSE - NewtonMaxit=ICNTRL(5) - IF(NewtonMaxit <= 0)THEN - PRINT * ,'User-selected ICNTRL(5)=',ICNTRL(5) - CALL SDIRK_ErrorMsg(-2,Tinitial,ZERO,Ierr) - END IF - END IF - -!~~~> Solve ADJ equations directly or by Newton iterations - DirectADJ = (ICNTRL(7) == 1) - -!~~~> Save or not the forward LU factorization - SaveLU = (ICNTRL(8) /= 0) .AND. (.NOT.DirectADJ) - -!~~~> Unit roundoff (1+Roundoff>1) - Roundoff = WLAMCH('E') - -!~~~> Lower bound on the step size: (positive value) - IF (RCNTRL(1) == ZERO) THEN - Hmin = ZERO - ELSEIF (RCNTRL(1) > ZERO) THEN - Hmin = RCNTRL(1) - ELSE - PRINT * , 'User-selected RCNTRL(1)=', RCNTRL(1) - CALL SDIRK_ErrorMsg(-3,Tinitial,ZERO,Ierr) - END IF - -!~~~> Upper bound on the step size: (positive value) - IF (RCNTRL(2) == ZERO) THEN - Hmax = ABS(Tfinal-Tinitial) - ELSEIF (RCNTRL(2) > ZERO) THEN - Hmax = MIN(ABS(RCNTRL(2)),ABS(Tfinal-Tinitial)) - ELSE - PRINT * , 'User-selected RCNTRL(2)=', RCNTRL(2) - CALL SDIRK_ErrorMsg(-3,Tinitial,ZERO,Ierr) - END IF - -!~~~> Starting step size: (positive value) - IF (RCNTRL(3) == ZERO) THEN - Hstart = MAX(Hmin,Roundoff) - ELSEIF (RCNTRL(3) > ZERO) THEN - Hstart = MIN(ABS(RCNTRL(3)),ABS(Tfinal-Tinitial)) - ELSE - PRINT * , 'User-selected Hstart: RCNTRL(3)=', RCNTRL(3) - CALL SDIRK_ErrorMsg(-3,Tinitial,ZERO,Ierr) - END IF - -!~~~> Step size can be changed s.t. FacMin < Hnew/Hexit < FacMax - IF (RCNTRL(4) == ZERO) THEN - FacMin = 0.2_dp - ELSEIF (RCNTRL(4) > ZERO) THEN - FacMin = RCNTRL(4) - ELSE - PRINT * , 'User-selected FacMin: RCNTRL(4)=', RCNTRL(4) - CALL SDIRK_ErrorMsg(-4,Tinitial,ZERO,Ierr) - END IF - IF (RCNTRL(5) == ZERO) THEN - FacMax = 10.0_dp - ELSEIF (RCNTRL(5) > ZERO) THEN - FacMax = RCNTRL(5) - ELSE - PRINT * , 'User-selected FacMax: RCNTRL(5)=', RCNTRL(5) - CALL SDIRK_ErrorMsg(-4,Tinitial,ZERO,Ierr) - END IF -!~~~> FacRej: Factor to decrease step after 2 succesive rejections - IF (RCNTRL(6) == ZERO) THEN - FacRej = 0.1_dp - ELSEIF (RCNTRL(6) > ZERO) THEN - FacRej = RCNTRL(6) - ELSE - PRINT * , 'User-selected FacRej: RCNTRL(6)=', RCNTRL(6) - CALL SDIRK_ErrorMsg(-4,Tinitial,ZERO,Ierr) - END IF -!~~~> FacSafe: Safety Factor in the computation of new step size - IF (RCNTRL(7) == ZERO) THEN - FacSafe = 0.9_dp - ELSEIF (RCNTRL(7) > ZERO) THEN - FacSafe = RCNTRL(7) - ELSE - PRINT * , 'User-selected FacSafe: RCNTRL(7)=', RCNTRL(7) - CALL SDIRK_ErrorMsg(-4,Tinitial,ZERO,Ierr) - END IF - -!~~~> ThetaMin: decides whether the Jacobian should be recomputed - IF(RCNTRL(8) == 0.D0)THEN - ThetaMin = 1.0d-3 - ELSE - ThetaMin = RCNTRL(8) - END IF - -!~~~> Stopping criterion for Newton's method - IF(RCNTRL(9) == ZERO)THEN - NewtonTol = 3.0d-2 - ELSE - NewtonTol = RCNTRL(9) - END IF - -!~~~> Qmin, Qmax: IF Qmin < Hnew/Hold < Qmax, STEP SIZE = CONST. - IF(RCNTRL(10) == ZERO)THEN - Qmin=ONE - ELSE - Qmin=RCNTRL(10) - END IF - IF(RCNTRL(11) == ZERO)THEN - Qmax=1.2D0 - ELSE - Qmax=RCNTRL(11) - END IF - -!~~~> Check if tolerances are reasonable - IF (ITOL == 0) THEN - IF (AbsTol(1) <= ZERO .OR. RelTol(1) <= 10.D0*Roundoff) THEN - PRINT * , ' Scalar AbsTol = ',AbsTol(1) - PRINT * , ' Scalar RelTol = ',RelTol(1) - CALL SDIRK_ErrorMsg(-5,Tinitial,ZERO,Ierr) - END IF - ELSE - DO i=1,N - IF (AbsTol(i) <= 0.D0.OR.RelTol(i) <= 10.D0*Roundoff) THEN - PRINT * , ' AbsTol(',i,') = ',AbsTol(i) - PRINT * , ' RelTol(',i,') = ',RelTol(i) - CALL SDIRK_ErrorMsg(-5,Tinitial,ZERO,Ierr) - END IF - END DO - END IF - - IF (Ierr < 0) RETURN - -!~~~> Allocate memory buffers - CALL SDIRK_AllocBuffers - -!~~~> Call forward integration - CALL SDIRK_FwdInt( N, Tinitial, Tfinal, Y, Ierr ) - -!~~~> Call adjoint integration - CALL SDIRK_DadjInt( N, NADJ, Lambda, Ierr ) - -!~~~> Free memory buffers - CALL SDIRK_FreeBuffers - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - CONTAINS ! Procedures internal to SDIRKADJ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SDIRK_FwdInt( N,Tinitial,Tfinal,Y,Ierr ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - USE KPP_ROOT_Parameters - IMPLICIT NONE - -!~~~> Arguments: - INTEGER :: N - KPP_REAL, INTENT(INOUT) :: Y(NVAR) - KPP_REAL, INTENT(IN) :: Tinitial, Tfinal - INTEGER, INTENT(OUT) :: Ierr - -!~~~> Local variables: - KPP_REAL :: Z(NVAR,Smax), G(NVAR), TMP(NVAR), & - NewtonRate, SCAL(NVAR), RHS(NVAR), & - T, H, Theta, Hratio, NewtonPredictedErr, & - Qnewton, Err, Fac, Hnew,Tdirection, & - NewtonIncrement, NewtonIncrementOld - INTEGER :: j, IER, istage, NewtonIter, IP(NVAR) - LOGICAL :: Reject, FirstStep, SkipJac, SkipLU, NewtonDone - -#ifdef FULL_ALGEBRA - KPP_REAL, DIMENSION(NVAR,NVAR) :: FJAC, E -#else - KPP_REAL, DIMENSION(LU_NONZERO):: FJAC, E -#endif - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Initializations -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - T = Tinitial - Tdirection = SIGN(ONE,Tfinal-Tinitial) - H = MAX(ABS(Hmin),ABS(Hstart)) - IF (ABS(H) <= 10.D0*Roundoff) H=1.0D-6 - H=MIN(ABS(H),Hmax) - H=SIGN(H,Tdirection) - SkipLU =.FALSE. - SkipJac = .FALSE. - Reject=.FALSE. - FirstStep=.TRUE. - - CALL SDIRK_ErrorScale(ITOL, AbsTol, RelTol, Y, SCAL) - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Time loop begins -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Tloop: DO WHILE ( (Tfinal-T)*Tdirection - Roundoff > ZERO ) - - -!~~~> Compute E = 1/(h*gamma)-Jac and its LU decomposition - IF ( .NOT.SkipLU ) THEN ! This time around skip the Jac update and LU - CALL SDIRK_PrepareMatrix ( H, T, Y, FJAC, & - SkipJac, SkipLU, E, IP, Reject, IER ) - IF (IER /= 0) THEN - CALL SDIRK_ErrorMsg(-8,T,H,Ierr); RETURN - END IF - END IF - - IF (ISTATUS(Nstp) > Max_no_steps) THEN - CALL SDIRK_ErrorMsg(-6,T,H,Ierr); RETURN - END IF - IF ( (T+0.1d0*H == T) .OR. (ABS(H) <= Roundoff) ) THEN - CALL SDIRK_ErrorMsg(-7,T,H,Ierr); RETURN - END IF - -stages:DO istage = 1, rkS - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Simplified Newton iterations -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -!~~~> Starting values for Newton iterations - CALL Set2zero(N,Z(1,istage)) - -!~~~> Prepare the loop-independent part of the right-hand side - CALL Set2zero(N,G) - IF (istage > 1) THEN - DO j = 1, istage-1 - ! Gj(:) = sum_j Theta(i,j)*Zj(:) = H * sum_j A(i,j)*Fun(Zj(:)) - CALL WAXPY(N,rkTheta(istage,j),Z(1,j),1,G,1) - ! Zi(:) = sum_j Alpha(i,j)*Zj(:) - CALL WAXPY(N,rkAlpha(istage,j),Z(1,j),1,Z(1,istage),1) - END DO - END IF - - !~~~> Initializations for Newton iteration - NewtonDone = .FALSE. - Fac = 0.5d0 ! Step reduction factor if too many iterations - -NewtonLoop:DO NewtonIter = 1, NewtonMaxit - -!~~~> Prepare the loop-dependent part of the right-hand side - CALL WADD(N,Y,Z(1,istage),TMP) ! TMP <- Y + Zi - CALL FUN_CHEM(T+rkC(istage)*H,TMP,RHS) ! RHS <- Fun(Y+Zi) - ISTATUS(Nfun) = ISTATUS(Nfun) + 1 -! RHS(1:N) = G(1:N) - Z(1:N,istage) + (H*rkGamma)*RHS(1:N) - CALL WSCAL(N, H*rkGamma, RHS, 1) - CALL WAXPY (N, -ONE, Z(1,istage), 1, RHS, 1) - CALL WAXPY (N, ONE, G,1, RHS,1) - -!~~~> Solve the linear system - CALL SDIRK_Solve ( 'N', H, N, E, IP, IER, RHS ) - -!~~~> Check convergence of Newton iterations - CALL SDIRK_ErrorNorm(N, RHS, SCAL, NewtonIncrement) - IF ( NewtonIter == 1 ) THEN - Theta = ABS(ThetaMin) - NewtonRate = 2.0d0 - ELSE - Theta = NewtonIncrement/NewtonIncrementOld - IF (Theta < 0.99d0) THEN - NewtonRate = Theta/(ONE-Theta) - ! Predict error at the end of Newton process - NewtonPredictedErr = NewtonIncrement & - *Theta**(NewtonMaxit-NewtonIter)/(ONE-Theta) - IF (NewtonPredictedErr >= NewtonTol) THEN - ! Non-convergence of Newton: predicted error too large - Qnewton = MIN(10.0d0,NewtonPredictedErr/NewtonTol) - Fac = 0.8d0*Qnewton**(-ONE/(1+NewtonMaxit-NewtonIter)) - EXIT NewtonLoop - END IF - ELSE ! Non-convergence of Newton: Theta too large - EXIT NewtonLoop - END IF - END IF - NewtonIncrementOld = NewtonIncrement - ! Update solution: Z(:) <-- Z(:)+RHS(:) - CALL WAXPY(N,ONE,RHS,1,Z(1,istage),1) - - ! Check error in Newton iterations - NewtonDone = (NewtonRate*NewtonIncrement <= NewtonTol) - IF (NewtonDone) EXIT NewtonLoop - - END DO NewtonLoop - - IF (.NOT.NewtonDone) THEN - !CALL RK_ErrorMsg(-12,T,H,Ierr); - H = Fac*H; Reject=.TRUE. - SkipJac = .TRUE.; SkipLU = .FALSE. - CYCLE Tloop - END IF - -!~~~> End of implified Newton iterations - - - END DO stages - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Error estimation -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ISTATUS(Nstp) = ISTATUS(Nstp) + 1 - CALL Set2zero(N,TMP) - DO i = 1,rkS - IF (rkE(i)/=ZERO) CALL WAXPY(N,rkE(i),Z(1,i),1,TMP,1) - END DO - - CALL SDIRK_Solve( 'N', H, N, E, IP, IER, TMP ) - CALL SDIRK_ErrorNorm(N, TMP, SCAL, Err) - -!~~~> Computation of new step size Hnew - Fac = FacSafe*(Err)**(-ONE/rkELO) - Fac = MAX(FacMin,MIN(FacMax,Fac)) - Hnew = H*Fac - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Accept/Reject step -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -accept: IF ( Err < ONE ) THEN !~~~> Step is accepted - - FirstStep=.FALSE. - ISTATUS(Nacc) = ISTATUS(Nacc) + 1 - -!~~~> Checkpoint solution - CALL SDIRK_Push( T, H, Y, Z, E, IP ) - -!~~~> Update time and solution - T = T + H - ! Y(:) <-- Y(:) + Sum_j rkD(j)*Z_j(:) - DO i = 1,rkS - IF (rkD(i)/=ZERO) CALL WAXPY(N,rkD(i),Z(1,i),1,Y,1) - END DO - -!~~~> Update scaling coefficients - CALL SDIRK_ErrorScale(ITOL, AbsTol, RelTol, Y, SCAL) - -!~~~> Next time step - Hnew = Tdirection*MIN(ABS(Hnew),Hmax) - ! Last T and H - RSTATUS(Ntexit) = T - RSTATUS(Nhexit) = H - RSTATUS(Nhnew) = Hnew - ! No step increase after a rejection - IF (Reject) Hnew = Tdirection*MIN(ABS(Hnew),ABS(H)) - Reject = .FALSE. - IF ((T+Hnew/Qmin-Tfinal)*Tdirection > ZERO) THEN - H = Tfinal-T - ELSE - Hratio=Hnew/H - ! If step not changed too much keep Jacobian and reuse LU - SkipLU = ( (Theta <= ThetaMin) .AND. (Hratio >= Qmin) & - .AND. (Hratio <= Qmax) ) - IF (.NOT.SkipLU) H = Hnew - END IF - ! If convergence is fast enough, do not update Jacobian -! SkipJac = (Theta <= ThetaMin) - SkipJac = .FALSE. - - ELSE accept !~~~> Step is rejected - - IF (FirstStep .OR. Reject) THEN - H = FacRej*H - ELSE - H = Hnew - END IF - Reject = .TRUE. - SkipJac = .TRUE. - SkipLU = .FALSE. - IF (ISTATUS(Nacc) >= 1) ISTATUS(Nrej) = ISTATUS(Nrej) + 1 - - END IF accept - - END DO Tloop - - ! Successful return - Ierr = 1 - - END SUBROUTINE SDIRK_FwdInt - - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SDIRK_DadjInt( N, NADJ, Lambda, Ierr ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - USE KPP_ROOT_Parameters - IMPLICIT NONE - -!~~~> Arguments: - INTEGER, INTENT(IN) :: N, NADJ - KPP_REAL, INTENT(INOUT) :: Lambda(NVAR,NADJ) - INTEGER, INTENT(OUT) :: Ierr - -!~~~> Local variables: - KPP_REAL :: Y(NVAR) - KPP_REAL :: Z(NVAR,Smax), U(NVAR,NADJ,Smax), & - TMP(NVAR), G(NVAR), & - NewtonRate, SCAL(NVAR), DU(NVAR), & - T, H, Theta, NewtonPredictedErr, & - NewtonIncrement, NewtonIncrementOld - INTEGER :: j, IER, istage, iadj, NewtonIter, & - IP(NVAR), IP_adj(NVAR) - LOGICAL :: Reject, SkipJac, SkipLU, NewtonDone - -#ifdef FULL_ALGEBRA - KPP_REAL, DIMENSION(NVAR,NVAR) :: E, Jac, E_adj -#else - KPP_REAL, DIMENSION(LU_NONZERO):: E, Jac, E_adj -#endif - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Time loop begins -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Tloop: DO WHILE ( stack_ptr > 0 ) - - !~~~> Recover checkpoints for stage values and vectors - CALL SDIRK_Pop( T, H, Y, Z, E, IP ) - -!~~~> Compute E = 1/(h*gamma)-Jac and its LU decomposition - IF (.NOT.SaveLU) THEN - SkipJac = .FALSE.; SkipLU = .FALSE. - CALL SDIRK_PrepareMatrix ( H, T, Y, Jac, & - SkipJac, SkipLU, E, IP, Reject, IER ) - IF (IER /= 0) THEN - CALL SDIRK_ErrorMsg(-8,T,H,Ierr); RETURN - END IF - END IF - -stages:DO istage = rkS, 1, -1 - -!~~~> Jacobian of the current stage solution - TMP(1:N) = Y(1:N) + Z(1:N,istage) - CALL JAC_CHEM(T+rkC(istage)*H,TMP,Jac) - ISTATUS(Njac) = ISTATUS(Njac) + 1 - - IF (DirectADJ) THEN -#ifdef FULL_ALGEBRA - E_adj(1:N,1:N) = -Jac(1:N,1:N) - DO j=1,N - E_adj(j,j) = E_adj(j,j) + ONE/(H*rkGamma) - END DO - CALL DGETRF( N, N, E_adj, N, IP_adj, IER ) -#else - E_adj(1:LU_NONZERO) = -Jac(1:LU_NONZERO) - DO i = 1,NVAR - j = LU_DIAG(i); E_adj(j) = E_adj(j) + ONE/(H*rkGamma) - END DO - CALL KppDecomp ( E_adj, IER) -#endif - ISTATUS(Ndec) = ISTATUS(Ndec) + 1 - IF (IER /= 0) THEN - PRINT*,'At stage ',istage,' the matrix used in adjoint', & - ' computation is singular' - CALL SDIRK_ErrorMsg(-8,T,H,Ierr); RETURN - END IF - END IF - -adj: DO iadj = 1, NADJ - -!~~~> Update scaling coefficients - CALL SDIRK_ErrorScale(ITOL, AbsTol_adj(1:NVAR,iadj), & - RelTol_adj(1:NVAR,iadj), Lambda(1:NVAR,iadj), SCAL) - -!~~~> Prepare the loop-independent part of the right-hand side -! G(:) = H*Jac^T*( B(i)*Lambda + sum_j A(j,i)*Uj(:) ) - G(1:N) = rkB(istage)*Lambda(1:N,iadj) - IF (istage < rkS) THEN - DO j = istage+1, rkS - CALL WAXPY(N,rkA(j,istage),U(1,iadj,j),1,G,1) - END DO - END IF -#ifdef FULL_ALGEBRA - TMP = MATMUL(TRANSPOSE(Jac),G) ! DZ <- Jac(Y+Z)*Y_tlm -#else - CALL JacTR_SP_Vec ( Jac, G, TMP ) -#endif - G(1:N) = H*TMP(1:N) - -DirADJ:IF (DirectADJ) THEN - - CALL SDIRK_Solve ( 'T', H, N, E_adj, IP_adj, IER, G ) - U(1:N,iadj,istage) = G(1:N) - - ELSE DirADJ - - !~~~> Initializations for Newton iteration - CALL Set2zero(N,U(1,iadj,istage)) - NewtonDone = .FALSE. - -NewtonLoop:DO NewtonIter = 1, NewtonMaxit - -!~~~> Prepare the loop-dependent part of the right-hand side -#ifdef FULL_ALGEBRA - TMP = MATMUL(TRANSPOSE(Jac),U(1:N,iadj,istage)) -#else - CALL JacTR_SP_Vec ( Jac, U(1:N,iadj,istage), TMP ) -#endif - DU(1:N) = U(1:N,iadj,istage) - (H*rkGamma)*TMP(1:N) - G(1:N) - -!~~~> Solve the linear system - CALL SDIRK_Solve ( 'T', H, N, E, IP, IER, DU ) - -!~~~> Check convergence of Newton iterations - - CALL SDIRK_ErrorNorm(N, DU, SCAL, NewtonIncrement) - IF ( NewtonIter == 1 ) THEN - Theta = ABS(ThetaMin) - NewtonRate = 2.0d0 - ELSE - Theta = NewtonIncrement/NewtonIncrementOld - IF (Theta < 0.99d0) THEN - NewtonRate = Theta/(ONE-Theta) - ! Predict error at the end of Newton process - NewtonPredictedErr = NewtonIncrement & - *Theta**(NewtonMaxit-NewtonIter)/(ONE-Theta) - ! Non-convergence of Newton: predicted error too large - IF (NewtonPredictedErr >= NewtonTol) EXIT NewtonLoop - ELSE ! Non-convergence of Newton: Theta too large - EXIT NewtonLoop - END IF - END IF - NewtonIncrementOld = NewtonIncrement - ! Update solution - U(1:N,iadj,istage) = U(1:N,iadj,istage) - DU(1:N) - - ! Check error in Newton iterations - NewtonDone = (NewtonRate*NewtonIncrement <= NewtonTol) - ! AbsTol is often inappropriate for adjoints - - ! we do at least 4 Newton iterations to ensure convergence - ! of all adjoint components - IF ((NewtonIter>=4) .AND. NewtonDone) EXIT NewtonLoop - - END DO NewtonLoop - - !~~~> If Newton iterations fail employ the direct solution - IF (.NOT.NewtonDone) THEN - PRINT*,'Problems with Newton Adjoint!!!' -#ifdef FULL_ALGEBRA - E_adj(1:N,1:N) = -Jac(1:N,1:N) - DO j=1,N - E_adj(j,j) = E_adj(j,j) + ONE/(H*rkGamma) - END DO - CALL DGETRF( N, N, E_adj, N, IP_adj, IER ) -#else - E_adj(1:LU_NONZERO) = -Jac(1:LU_NONZERO) - DO i = 1,NVAR - j = LU_DIAG(i); E_adj(j) = E_adj(j) + ONE/(H*rkGamma) - END DO - CALL KppDecomp ( E_adj, IER) -#endif - ISTATUS(Ndec) = ISTATUS(Ndec) + 1 - IF (IER /= 0) THEN - PRINT*,'At stage ',istage,' the matrix used in adjoint', & - ' computation is singular' - CALL SDIRK_ErrorMsg(-8,T,H,Ierr); RETURN - END IF - CALL SDIRK_Solve ( 'T', H, N, E_adj, IP_adj, IER, G ) - U(1:N,iadj,istage) = G(1:N) - - END IF - -!~~~> End of simplified Newton iterations - - END IF DirADJ - - END DO adj - - END DO stages - -!~~~> Update adjoint solution - ! Y(:) <-- Y(:) + Sum_j rkD(j)*Z_j(:) - DO istage = 1,rkS - DO iadj = 1,NADJ - Lambda(1:N,iadj) = Lambda(1:N,iadj) + U(1:N,iadj,istage) - !CALL WAXPY(N,ONE,U(1:N,iadj,istage),1,Lambda(1,iadj),1) - END DO - END DO - - END DO Tloop - - ! Successful return - Ierr = 1 - - END SUBROUTINE SDIRK_DadjInt - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SDIRK_AllocBuffers -!~~~> Allocate buffer space for checkpointing -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - INTEGER :: i - - ALLOCATE( chk_H(Max_no_steps), STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed allocation of buffer H'; STOP - END IF - ALLOCATE( chk_T(Max_no_steps), STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed allocation of buffer T'; STOP - END IF - ALLOCATE( chk_Y(NVAR,Max_no_steps), STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed allocation of buffer Y'; STOP - END IF - ALLOCATE( chk_Z(NVAR,rkS,Max_no_steps), STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed allocation of buffer K'; STOP - END IF - IF (SaveLU) THEN -#ifdef FULL_ALGEBRA - ALLOCATE( chk_J(NVAR,NVAR,Max_no_steps), STAT=i ) -#else - ALLOCATE( chk_J(LU_NONZERO,Max_no_steps), STAT=i ) -#endif - IF (i/=0) THEN - PRINT*,'Failed allocation of buffer J'; STOP - END IF - ALLOCATE( chk_P(NVAR,Max_no_steps), STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed allocation of buffer P'; STOP - END IF - END IF - - END SUBROUTINE SDIRK_AllocBuffers - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SDIRK_FreeBuffers -!~~~> Dallocate buffer space for discrete adjoint -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - INTEGER :: i - - DEALLOCATE( chk_H, STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed deallocation of buffer H'; STOP - END IF - DEALLOCATE( chk_T, STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed deallocation of buffer T'; STOP - END IF - DEALLOCATE( chk_Y, STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed deallocation of buffer Y'; STOP - END IF - DEALLOCATE( chk_Z, STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed deallocation of buffer K'; STOP - END IF - IF (SaveLU) THEN - DEALLOCATE( chk_J, STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed deallocation of buffer J'; STOP - END IF - DEALLOCATE( chk_P, STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed deallocation of buffer P'; STOP - END IF - END IF - - END SUBROUTINE SDIRK_FreeBuffers - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SDIRK_Push( T, H, Y, Z, E, P ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Saves the next trajectory snapshot for discrete adjoints -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - KPP_REAL :: T, H, Y(NVAR), Z(NVAR,Smax) - INTEGER :: P(NVAR) -#ifdef FULL_ALGEBRA - KPP_REAL :: E(NVAR,NVAR) -#else - KPP_REAL :: E(LU_NONZERO) -#endif - - stack_ptr = stack_ptr + 1 - IF ( stack_ptr > Max_no_steps ) THEN - PRINT*,'Push failed: buffer overflow' - STOP - END IF - chk_H( stack_ptr ) = H - chk_T( stack_ptr ) = T - chk_Y(1:NVAR,stack_ptr) = Y(1:NVAR) - chk_Z(1:NVAR,1:rkS,stack_ptr) = Z(1:NVAR,1:rkS) - IF (SaveLU) THEN -#ifdef FULL_ALGEBRA - chk_J(1:NVAR,1:NVAR,stack_ptr) = E(1:NVAR,1:NVAR) - chk_P(1:NVAR,stack_ptr) = P(1:NVAR) -#else - chk_J(1:LU_NONZERO,stack_ptr) = E(1:LU_NONZERO) -#endif - END IF - - END SUBROUTINE SDIRK_Push - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SDIRK_Pop( T, H, Y, Z, E, P ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Retrieves the next trajectory snapshot for discrete adjoints -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - KPP_REAL :: T, H, Y(NVAR), Z(NVAR,Smax) - INTEGER :: P(NVAR) -#ifdef FULL_ALGEBRA - KPP_REAL :: E(NVAR,NVAR) -#else - KPP_REAL :: E(LU_NONZERO) -#endif - - IF ( stack_ptr <= 0 ) THEN - PRINT*,'Pop failed: empty buffer' - STOP - END IF - H = chk_H( stack_ptr ) - T = chk_T( stack_ptr ) - Y(1:NVAR) = chk_Y(1:NVAR,stack_ptr) - Z(1:NVAR,1:rkS) = chk_Z(1:NVAR,1:rkS,stack_ptr) - IF (SaveLU) THEN -#ifdef FULL_ALGEBRA - E(1:NVAR,1:NVAR) = chk_J(1:NVAR,1:NVAR,stack_ptr) - P(1:NVAR) = chk_P(1:NVAR,stack_ptr) -#else - E(1:LU_NONZERO) = chk_J(1:LU_NONZERO,stack_ptr) -#endif - END IF - - stack_ptr = stack_ptr - 1 - - END SUBROUTINE SDIRK_Pop - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SDIRK_ErrorScale(ITOL, AbsTol, RelTol, Y, SCAL) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - INTEGER :: i, ITOL - KPP_REAL :: AbsTol(NVAR), RelTol(NVAR), & - Y(NVAR), SCAL(NVAR) - IF (ITOL == 0) THEN - DO i=1,NVAR - SCAL(i) = ONE / ( AbsTol(1)+RelTol(1)*ABS(Y(i)) ) - END DO - ELSE - DO i=1,NVAR - SCAL(i) = ONE / ( AbsTol(i)+RelTol(i)*ABS(Y(i)) ) - END DO - END IF - END SUBROUTINE SDIRK_ErrorScale - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SDIRK_ErrorNorm(N, Y, SCAL, Err) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! - INTEGER :: i, N - KPP_REAL :: Y(N), SCAL(N), Err - Err = ZERO - DO i=1,N - Err = Err+(Y(i)*SCAL(i))**2 - END DO - Err = MAX( SQRT(Err/DBLE(N)), 1.0d-10 ) -! - END SUBROUTINE SDIRK_ErrorNorm - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -SUBROUTINE SDIRK_ErrorMsg(Code,T,H,Ierr) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Handles all error messages -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - KPP_REAL, INTENT(IN) :: T, H - INTEGER, INTENT(IN) :: Code - INTEGER, INTENT(OUT) :: Ierr - - Ierr = Code - PRINT * , & - 'Forced exit from SDIRK due to the following error:' - - SELECT CASE (Code) - CASE (-1) - PRINT * , '--> Improper value for maximal no of steps' - CASE (-2) - PRINT * , '--> Improper value for maximal no of Newton iterations' - CASE (-3) - PRINT * , '--> Hmin/Hmax/Hstart must be positive' - CASE (-4) - PRINT * , '--> FacMin/FacMax/FacRej must be positive' - CASE (-5) - PRINT * , '--> Improper tolerance values' - CASE (-6) - PRINT * , '--> No of steps exceeds maximum bound', max_no_steps - CASE (-7) - PRINT * , '--> Step size too small: T + 10*H = T', & - ' or H < Roundoff' - CASE (-8) - PRINT * , '--> Matrix is repeatedly singular' - CASE DEFAULT - PRINT *, 'Unknown Error code: ', Code - END SELECT - - PRINT *, "T=", T, "and H=", H - - END SUBROUTINE SDIRK_ErrorMsg - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SDIRK_PrepareMatrix ( H, T, Y, FJAC, & - SkipJac, SkipLU, E, IP, Reject, ISING ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Compute the matrix E = 1/(H*GAMMA)*Jac, and its decomposition -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - - KPP_REAL, INTENT(INOUT) :: H - KPP_REAL, INTENT(IN) :: T, Y(NVAR) - LOGICAL, INTENT(INOUT) :: SkipJac,SkipLU,Reject - INTEGER, INTENT(OUT) :: ISING, IP(NVAR) -#ifdef FULL_ALGEBRA - KPP_REAL, INTENT(INOUT) :: FJAC(NVAR,NVAR) - KPP_REAL, INTENT(OUT) :: E(NVAR,NVAR) -#else - KPP_REAL, INTENT(INOUT) :: FJAC(LU_NONZERO) - KPP_REAL, INTENT(OUT) :: E(LU_NONZERO) -#endif - KPP_REAL :: HGammaInv - INTEGER :: i, j, ConsecutiveSng - - ConsecutiveSng = 0 - ISING = 1 - -Hloop: DO WHILE (ISING /= 0) - - HGammaInv = ONE/(H*rkGamma) - -!~~~> Compute the Jacobian -! IF (SkipJac) THEN -! SkipJac = .FALSE. -! ELSE - IF (.NOT. SkipJac) THEN - CALL JAC_CHEM( T, Y, FJAC ) - ISTATUS(Njac) = ISTATUS(Njac) + 1 - END IF - -#ifdef FULL_ALGEBRA - DO j=1,NVAR - DO i=1,NVAR - E(i,j) = -FJAC(i,j) - END DO - E(j,j) = E(j,j)+HGammaInv - END DO - CALL DGETRF( NVAR, NVAR, E, NVAR, IP, ISING ) -#else - DO i = 1,LU_NONZERO - E(i) = -FJAC(i) - END DO - DO i = 1,NVAR - j = LU_DIAG(i); E(j) = E(j) + HGammaInv - END DO - CALL KppDecomp ( E, ISING) - IP(1) = 1 -#endif - ISTATUS(Ndec) = ISTATUS(Ndec) + 1 - - IF (ISING /= 0) THEN - WRITE (6,*) ' MATRIX IS SINGULAR, ISING=',ISING,' T=',T,' H=',H - ISTATUS(Nsng) = ISTATUS(Nsng) + 1; ConsecutiveSng = ConsecutiveSng + 1 - IF (ConsecutiveSng >= 6) RETURN ! Failure - H = 0.5d0*H - SkipJac = .FALSE. - SkipLU = .FALSE. - Reject = .TRUE. - END IF - - END DO Hloop - - END SUBROUTINE SDIRK_PrepareMatrix - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SDIRK_Solve ( Transp, H, N, E, IP, ISING, RHS ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Solves the system (H*Gamma-Jac)*x = R -! using the LU decomposition of E = I - 1/(H*Gamma)*Jac -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - INTEGER, INTENT(IN) :: N, IP(N), ISING - CHARACTER, INTENT(IN) :: Transp - KPP_REAL, INTENT(IN) :: H -#ifdef FULL_ALGEBRA - KPP_REAL, INTENT(IN) :: E(NVAR,NVAR) -#else - KPP_REAL, INTENT(IN) :: E(LU_NONZERO) -#endif - KPP_REAL, INTENT(INOUT) :: RHS(N) - KPP_REAL :: HGammaInv - - HGammaInv = ONE/(H*rkGamma) - CALL WSCAL(N,HGammaInv,RHS,1) - SELECT CASE (TRANSP) - CASE ('N') -#ifdef FULL_ALGEBRA - CALL DGETRS( 'N', N, 1, E, N, IP, RHS, N, ISING ) -#else - CALL KppSolve(E, RHS) -#endif - CASE ('T') -#ifdef FULL_ALGEBRA - CALL DGETRS( 'T', N, 1, E, N, IP, RHS, N, ISING ) -#else - CALL KppSolveTR(E, RHS, RHS) -#endif - CASE DEFAULT - PRINT*,'Error in SDIRK_Solve. Unknown Transp argument:',Transp - STOP - END SELECT - ISTATUS(Nsol) = ISTATUS(Nsol) + 1 - - END SUBROUTINE SDIRK_Solve - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Sdirk4a -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - sdMethod = S4A -! Number of stages - rkS = 5 - -! Method coefficients - rkGamma = .2666666666666666666666666666666667d0 - - rkA(1,1) = .2666666666666666666666666666666667d0 - rkA(2,1) = .5000000000000000000000000000000000d0 - rkA(2,2) = .2666666666666666666666666666666667d0 - rkA(3,1) = .3541539528432732316227461858529820d0 - rkA(3,2) = -.5415395284327323162274618585298197d-1 - rkA(3,3) = .2666666666666666666666666666666667d0 - rkA(4,1) = .8515494131138652076337791881433756d-1 - rkA(4,2) = -.6484332287891555171683963466229754d-1 - rkA(4,3) = .7915325296404206392428857585141242d-1 - rkA(4,4) = .2666666666666666666666666666666667d0 - rkA(5,1) = 2.100115700566932777970612055999074d0 - rkA(5,2) = -.7677800284445976813343102185062276d0 - rkA(5,3) = 2.399816361080026398094746205273880d0 - rkA(5,4) = -2.998818699869028161397714709433394d0 - rkA(5,5) = .2666666666666666666666666666666667d0 - - rkB(1) = 2.100115700566932777970612055999074d0 - rkB(2) = -.7677800284445976813343102185062276d0 - rkB(3) = 2.399816361080026398094746205273880d0 - rkB(4) = -2.998818699869028161397714709433394d0 - rkB(5) = .2666666666666666666666666666666667d0 - - rkBhat(1)= 2.885264204387193942183851612883390d0 - rkBhat(2)= -.1458793482962771337341223443218041d0 - rkBhat(3)= 2.390008682465139866479830743628554d0 - rkBhat(4)= -4.129393538556056674929560012190140d0 - rkBhat(5)= 0.d0 - - rkC(1) = .2666666666666666666666666666666667d0 - rkC(2) = .7666666666666666666666666666666667d0 - rkC(3) = .5666666666666666666666666666666667d0 - rkC(4) = .3661315380631796996374935266701191d0 - rkC(5) = 1.d0 - -! Ynew = Yold + h*Sum_i {rkB_i*k_i} = Yold + Sum_i {rkD_i*Z_i} - rkD(1) = 0.d0 - rkD(2) = 0.d0 - rkD(3) = 0.d0 - rkD(4) = 0.d0 - rkD(5) = 1.d0 - -! Err = h * Sum_i {(rkB_i-rkBhat_i)*k_i} = Sum_i {rkE_i*Z_i} - rkE(1) = -.6804000050475287124787034884002302d0 - rkE(2) = 1.558961944525217193393931795738823d0 - rkE(3) = -13.55893003128907927748632408763868d0 - rkE(4) = 15.48522576958521253098585004571302d0 - rkE(5) = 1.d0 - -! Local order of Err estimate - rkElo = 4 - -! h*Sum_j {rkA_ij*k_j} = Sum_j {rkTheta_ij*Z_j} - rkTheta(2,1) = 1.875000000000000000000000000000000d0 - rkTheta(3,1) = 1.708847304091539528432732316227462d0 - rkTheta(3,2) = -.2030773231622746185852981969486824d0 - rkTheta(4,1) = .2680325578937783958847157206823118d0 - rkTheta(4,2) = -.1828840955527181631794050728644549d0 - rkTheta(4,3) = .2968246986151577397160821594427966d0 - rkTheta(5,1) = .9096171815241460655379433581446771d0 - rkTheta(5,2) = -3.108254967778352416114774430509465d0 - rkTheta(5,3) = 12.33727431701306195581826123274001d0 - rkTheta(5,4) = -11.24557012450885560524143016037523d0 - -! Starting value for Newton iterations: Z_i^0 = Sum_j {rkAlpha_ij*Z_j} - rkAlpha(2,1) = 2.875000000000000000000000000000000d0 - rkAlpha(3,1) = .8500000000000000000000000000000000d0 - rkAlpha(3,2) = .4434782608695652173913043478260870d0 - rkAlpha(4,1) = .7352046091658870564637910527807370d0 - rkAlpha(4,2) = -.9525565003057343527941920657462074d-1 - rkAlpha(4,3) = .4290111305453813852259481840631738d0 - rkAlpha(5,1) = -16.10898993405067684831655675112808d0 - rkAlpha(5,2) = 6.559571569643355712998131800797873d0 - rkAlpha(5,3) = -15.90772144271326504260996815012482d0 - rkAlpha(5,4) = 25.34908987169226073668861694892683d0 - -!~~~> Coefficients for continuous solution -! rkD(1,1)= 24.74416644927758d0 -! rkD(1,2)= -4.325375951824688d0 -! rkD(1,3)= 41.39683763286316d0 -! rkD(1,4)= -61.04144619901784d0 -! rkD(1,5)= -3.391332232917013d0 -! rkD(2,1)= -51.98245719616925d0 -! rkD(2,2)= 10.52501981094525d0 -! rkD(2,3)= -154.2067922191855d0 -! rkD(2,4)= 214.3082125319825d0 -! rkD(2,5)= 14.71166018088679d0 -! rkD(3,1)= 33.14347947522142d0 -! rkD(3,2)= -19.72986789558523d0 -! rkD(3,3)= 230.4878502285804d0 -! rkD(3,4)= -287.6629744338197d0 -! rkD(3,5)= -18.99932366302254d0 -! rkD(4,1)= -5.905188728329743d0 -! rkD(4,2)= 13.53022403646467d0 -! rkD(4,3)= -117.6778956422581d0 -! rkD(4,4)= 134.3962081008550d0 -! rkD(4,5)= 8.678995715052762d0 -! -! DO i=1,4 ! CONTi <-- Sum_j rkD(i,j)*Zj -! CALL Set2zero(N,CONT(1,i)) -! DO j = 1,rkS -! CALL WAXPY(N,rkD(i,j),Z(1,j),1,CONT(1,i),1) -! END DO -! END DO - - rkELO = 4.0d0 - - END SUBROUTINE Sdirk4a - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Sdirk4b -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - sdMethod = S4B -! Number of stages - rkS = 5 - -! Method coefficients - rkGamma = .25d0 - - rkA(1,1) = 0.25d0 - rkA(2,1) = 0.5d00 - rkA(2,2) = 0.25d0 - rkA(3,1) = 0.34d0 - rkA(3,2) =-0.40d-1 - rkA(3,3) = 0.25d0 - rkA(4,1) = 0.2727941176470588235294117647058824d0 - rkA(4,2) =-0.5036764705882352941176470588235294d-1 - rkA(4,3) = 0.2757352941176470588235294117647059d-1 - rkA(4,4) = 0.25d0 - rkA(5,1) = 1.041666666666666666666666666666667d0 - rkA(5,2) =-1.020833333333333333333333333333333d0 - rkA(5,3) = 7.812500000000000000000000000000000d0 - rkA(5,4) =-7.083333333333333333333333333333333d0 - rkA(5,5) = 0.25d0 - - rkB(1) = 1.041666666666666666666666666666667d0 - rkB(2) = -1.020833333333333333333333333333333d0 - rkB(3) = 7.812500000000000000000000000000000d0 - rkB(4) = -7.083333333333333333333333333333333d0 - rkB(5) = 0.250000000000000000000000000000000d0 - - rkBhat(1)= 1.069791666666666666666666666666667d0 - rkBhat(2)= -0.894270833333333333333333333333333d0 - rkBhat(3)= 7.695312500000000000000000000000000d0 - rkBhat(4)= -7.083333333333333333333333333333333d0 - rkBhat(5)= 0.212500000000000000000000000000000d0 - - rkC(1) = 0.25d0 - rkC(2) = 0.75d0 - rkC(3) = 0.55d0 - rkC(4) = 0.50d0 - rkC(5) = 1.00d0 - -! Ynew = Yold + h*Sum_i {rkB_i*k_i} = Yold + Sum_i {rkD_i*Z_i} - rkD(1) = 0.0d0 - rkD(2) = 0.0d0 - rkD(3) = 0.0d0 - rkD(4) = 0.0d0 - rkD(5) = 1.0d0 - -! Err = h * Sum_i {(rkB_i-rkBhat_i)*k_i} = Sum_i {rkE_i*Z_i} - rkE(1) = 0.5750d0 - rkE(2) = 0.2125d0 - rkE(3) = -4.6875d0 - rkE(4) = 4.2500d0 - rkE(5) = 0.1500d0 - -! Local order of Err estimate - rkElo = 4 - -! h*Sum_j {rkA_ij*k_j} = Sum_j {rkTheta_ij*Z_j} - rkTheta(2,1) = 2.d0 - rkTheta(3,1) = 1.680000000000000000000000000000000d0 - rkTheta(3,2) = -.1600000000000000000000000000000000d0 - rkTheta(4,1) = 1.308823529411764705882352941176471d0 - rkTheta(4,2) = -.1838235294117647058823529411764706d0 - rkTheta(4,3) = 0.1102941176470588235294117647058824d0 - rkTheta(5,1) = -3.083333333333333333333333333333333d0 - rkTheta(5,2) = -4.291666666666666666666666666666667d0 - rkTheta(5,3) = 34.37500000000000000000000000000000d0 - rkTheta(5,4) = -28.33333333333333333333333333333333d0 - -! Starting value for Newton iterations: Z_i^0 = Sum_j {rkAlpha_ij*Z_j} - rkAlpha(2,1) = 3. - rkAlpha(3,1) = .8800000000000000000000000000000000d0 - rkAlpha(3,2) = .4400000000000000000000000000000000d0 - rkAlpha(4,1) = .1666666666666666666666666666666667d0 - rkAlpha(4,2) = -.8333333333333333333333333333333333d-1 - rkAlpha(4,3) = .9469696969696969696969696969696970d0 - rkAlpha(5,1) = -6.d0 - rkAlpha(5,2) = 9.d0 - rkAlpha(5,3) = -56.81818181818181818181818181818182d0 - rkAlpha(5,4) = 54.d0 - - END SUBROUTINE Sdirk4b - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Sdirk2a -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - sdMethod = S2A -! Number of stages - rkS = 2 - -! Method coefficients - rkGamma = .2928932188134524755991556378951510d0 - - rkA(1,1) = .2928932188134524755991556378951510d0 - rkA(2,1) = .7071067811865475244008443621048490d0 - rkA(2,2) = .2928932188134524755991556378951510d0 - - rkB(1) = .7071067811865475244008443621048490d0 - rkB(2) = .2928932188134524755991556378951510d0 - - rkBhat(1)= .6666666666666666666666666666666667d0 - rkBhat(2)= .3333333333333333333333333333333333d0 - - rkC(1) = 0.292893218813452475599155637895151d0 - rkC(2) = 1.0d0 - -! Ynew = Yold + h*Sum_i {rkB_i*k_i} = Yold + Sum_i {rkD_i*Z_i} - rkD(1) = 0.0d0 - rkD(2) = 1.0d0 - -! Err = h * Sum_i {(rkB_i-rkBhat_i)*k_i} = Sum_i {rkE_i*Z_i} - rkE(1) = 0.4714045207910316829338962414032326d0 - rkE(2) = -0.1380711874576983496005629080698993d0 - -! Local order of Err estimate - rkElo = 2 - -! h*Sum_j {rkA_ij*k_j} = Sum_j {rkTheta_ij*Z_j} - rkTheta(2,1) = 2.414213562373095048801688724209698d0 - -! Starting value for Newton iterations: Z_i^0 = Sum_j {rkAlpha_ij*Z_j} - rkAlpha(2,1) = 3.414213562373095048801688724209698d0 - - END SUBROUTINE Sdirk2a - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Sdirk2b -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - sdMethod = S2B -! Number of stages - rkS = 2 - -! Method coefficients - rkGamma = 1.707106781186547524400844362104849d0 - - rkA(1,1) = 1.707106781186547524400844362104849d0 - rkA(2,1) = -.707106781186547524400844362104849d0 - rkA(2,2) = 1.707106781186547524400844362104849d0 - - rkB(1) = -.707106781186547524400844362104849d0 - rkB(2) = 1.707106781186547524400844362104849d0 - - rkBhat(1)= .6666666666666666666666666666666667d0 - rkBhat(2)= .3333333333333333333333333333333333d0 - - rkC(1) = 1.707106781186547524400844362104849d0 - rkC(2) = 1.0d0 - -! Ynew = Yold + h*Sum_i {rkB_i*k_i} = Yold + Sum_i {rkD_i*Z_i} - rkD(1) = 0.0d0 - rkD(2) = 1.0d0 - -! Err = h * Sum_i {(rkB_i-rkBhat_i)*k_i} = Sum_i {rkE_i*Z_i} - rkE(1) = -.4714045207910316829338962414032326d0 - rkE(2) = .8047378541243650162672295747365659d0 - -! Local order of Err estimate - rkElo = 2 - -! h*Sum_j {rkA_ij*k_j} = Sum_j {rkTheta_ij*Z_j} - rkTheta(2,1) = -.414213562373095048801688724209698d0 - -! Starting value for Newton iterations: Z_i^0 = Sum_j {rkAlpha_ij*Z_j} - rkAlpha(2,1) = .5857864376269049511983112757903019d0 - - END SUBROUTINE Sdirk2b - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Sdirk3a -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - sdMethod = S3A -! Number of stages - rkS = 3 - -! Method coefficients - rkGamma = .2113248654051871177454256097490213d0 - - rkA(1,1) = .2113248654051871177454256097490213d0 - rkA(2,1) = .2113248654051871177454256097490213d0 - rkA(2,2) = .2113248654051871177454256097490213d0 - rkA(3,1) = .2113248654051871177454256097490213d0 - rkA(3,2) = .5773502691896257645091487805019573d0 - rkA(3,3) = .2113248654051871177454256097490213d0 - - rkB(1) = .2113248654051871177454256097490213d0 - rkB(2) = .5773502691896257645091487805019573d0 - rkB(3) = .2113248654051871177454256097490213d0 - - rkBhat(1)= .2113248654051871177454256097490213d0 - rkBhat(2)= .6477918909913548037576239837516312d0 - rkBhat(3)= .1408832436034580784969504064993475d0 - - rkC(1) = .2113248654051871177454256097490213d0 - rkC(2) = .4226497308103742354908512194980427d0 - rkC(3) = 1.d0 - -! Ynew = Yold + h*Sum_i {rkB_i*k_i} = Yold + Sum_i {rkD_i*Z_i} - rkD(1) = 0.d0 - rkD(2) = 0.d0 - rkD(3) = 1.d0 - -! Err = h * Sum_i {(rkB_i-rkBhat_i)*k_i} = Sum_i {rkE_i*Z_i} - rkE(1) = 0.9106836025229590978424821138352906d0 - rkE(2) = -1.244016935856292431175815447168624d0 - rkE(3) = 0.3333333333333333333333333333333333d0 - -! Local order of Err estimate - rkElo = 2 - -! h*Sum_j {rkA_ij*k_j} = Sum_j {rkTheta_ij*Z_j} - rkTheta(2,1) = 1.0d0 - rkTheta(3,1) = -1.732050807568877293527446341505872d0 - rkTheta(3,2) = 2.732050807568877293527446341505872d0 - -! Starting value for Newton iterations: Z_i^0 = Sum_j {rkAlpha_ij*Z_j} - rkAlpha(2,1) = 2.0d0 - rkAlpha(3,1) = -12.92820323027550917410978536602349d0 - rkAlpha(3,2) = 8.83012701892219323381861585376468d0 - - END SUBROUTINE Sdirk3a - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - END SUBROUTINE SDIRKADJ ! AND ALL ITS INTERNAL PROCEDURES -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE FUN_CHEM( T, Y, P ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - USE KPP_ROOT_Parameters, ONLY: NVAR - USE KPP_ROOT_Global, ONLY: TIME, FIX, RCONST - USE KPP_ROOT_Function, ONLY: Fun - USE KPP_ROOT_Rates, ONLY: Update_SUN, Update_RCONST, Update_PHOTO - - KPP_REAL :: T, Told - KPP_REAL :: Y(NVAR), P(NVAR) - - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - - CALL Fun( Y, FIX, RCONST, P ) - - TIME = Told - - END SUBROUTINE FUN_CHEM - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE JAC_CHEM( T, Y, JV ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - USE KPP_ROOT_Parameters, ONLY: NVAR, LU_NONZERO - USE KPP_ROOT_Global, ONLY: TIME, FIX, RCONST - USE KPP_ROOT_Jacobian, ONLY: Jac_SP,LU_IROW,LU_ICOL - USE KPP_ROOT_Rates, ONLY: Update_SUN, Update_RCONST, Update_PHOTO - - KPP_REAL :: T, Told - KPP_REAL :: Y(NVAR) -#ifdef FULL_ALGEBRA - KPP_REAL :: JS(LU_NONZERO), JV(NVAR,NVAR) - INTEGER :: i, j -#else - KPP_REAL :: JV(LU_NONZERO) -#endif - - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - -#ifdef FULL_ALGEBRA - CALL Jac_SP(Y, FIX, RCONST, JS) - DO j=1,NVAR - DO j=1,NVAR - JV(i,j) = 0.0d0 - END DO - END DO - DO i=1,LU_NONZERO - JV(LU_IROW(i),LU_ICOL(i)) = JS(i) - END DO -#else - CALL Jac_SP(Y, FIX, RCONST, JV) -#endif - TIME = Told - - END SUBROUTINE JAC_CHEM - -END MODULE KPP_ROOT_Integrator - - diff --git a/boxmox/int.modified_WCOPY/sdirk_soa.def b/boxmox/int.modified_WCOPY/sdirk_soa.def deleted file mode 100644 index 4d21fdb69463761ff7c3d408d2f5f6378f665708..0000000000000000000000000000000000000000 --- a/boxmox/int.modified_WCOPY/sdirk_soa.def +++ /dev/null @@ -1,20 +0,0 @@ - -#FUNCTION AGGREGATE -#JACOBIAN SPARSE_LU_ROW - -#DOUBLE ON -#INTFILE sdirk_soa - -#INLINE F77_GLOBAL - REAL*8 STEPSTART - COMMON /GDATA/ STEPSTART -#ENDINLINE - -#INLINE F77_INIT - STEPMIN=0.0001 - STEPMAX=3600. - STEPSTART=STEPMIN -#ENDINLINE - - - diff --git a/boxmox/int.modified_WCOPY/sdirk_soa.f90 b/boxmox/int.modified_WCOPY/sdirk_soa.f90 deleted file mode 100644 index e49f2ddfa10d7344cf8ce9f68f919759a53ed7b4..0000000000000000000000000000000000000000 --- a/boxmox/int.modified_WCOPY/sdirk_soa.f90 +++ /dev/null @@ -1,1758 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! -! Second Order Adjoint of SDIRK - Singly-Diagonally-Implicit Runge-Kutta ! -! * Sdirk 2a, 2b: L-stable, 2 stages, order 2 ! -! * Sdirk 3a: L-stable, 3 stages, order 2, adj-invariant ! -! * Sdirk 4a, 4b: L-stable, 5 stages, order 4 ! -! By default the code employs the KPP sparse linear algebra routines ! -! Compile with -DFULL_ALGEBRA to use full linear algebra (LAPACK) ! -! ! -! (C) Adrian Sandu, July 2007 ! -! Virginia Polytechnic Institute and State University ! -! Contact: sandu@cs.vt.edu ! -! This implementation is part of KPP - the Kinetic PreProcessor ! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! - -MODULE KPP_ROOT_Integrator - - USE KPP_ROOT_Precision - USE KPP_ROOT_Global, ONLY: FIX, RCONST, TIME - USE KPP_ROOT_Parameters, ONLY: NVAR, NSPEC, NFIX, LU_NONZERO, NHESS - USE KPP_ROOT_JacobianSP, ONLY: LU_DIAG - USE KPP_ROOT_Jacobian, ONLY: Jac_SP_Vec, JacTR_SP_Vec - USE KPP_ROOT_LinearAlgebra, ONLY: KppDecomp, KppSolve, & - KppSolveTR, Set2zero, WLAMCH, WCOPY, WAXPY, WSCAL, WADD - USE KPP_ROOT_Hessian - USE KPP_ROOT_Util - - IMPLICIT NONE - PUBLIC - SAVE - -!~~~> Statistics on the work performed by the SDIRK method - INTEGER, PARAMETER :: Nfun=1, Njac=2, Nstp=3, Nacc=4, & - Nrej=5, Ndec=6, Nsol=7, Nsng=8, & - Ntexit=1, Nhexit=2, Nhnew=3 - -CONTAINS - -SUBROUTINE INTEGRATE_SOA( NSOA, Y, Y_tlm, Lambda, Sigma, & - TIN, TOUT, ATOL_adj, RTOL_adj, & - ICNTRL_U, RCNTRL_U, ISTATUS_U, RSTATUS_U, Ierr_U ) - - USE KPP_ROOT_Parameters - USE KPP_ROOT_Global - IMPLICIT NONE - -!~~~> Y - Concentrations - KPP_REAL :: Y(NVAR) -!~~~> NSOA - No. of vectors U_j for which -! Hessian*U_j is computed - INTEGER :: NSOA -!~~~> Y_tlm - Forward sensitivities -! Initially Y_tlm(1:NVAR,j) = U_j - KPP_REAL :: Y_tlm(NVAR,NSOA) -!~~~> ADJ - No. of cost functionals (always 1) - INTEGER, PARAMETER :: NADJ = 1 -!~~~> Lambda - Sensitivities w.r.t. concentrations -! Note: Lambda (1:NVAR,j) contains sensitivities of -! the j-th cost functional w.r.t. Y(1:NVAR), j=1...NADJ - KPP_REAL :: Lambda(NVAR,NADJ) -!~~~> Sigma - Second order adjoint sensitivities -! Note: Sigma(1:NVAR,j) = Hessian*U_j - KPP_REAL :: Sigma(NVAR,NSOA) -!~~~> Tolerances for adjoint calculations -! (used for full continuous adjoint, and for controlling -! iterations when used to solve the discrete adjoint) - KPP_REAL, INTENT(IN) :: ATOL_adj(NVAR,NADJ), RTOL_adj(NVAR,NADJ) - KPP_REAL, INTENT(IN) :: TIN ! Start Time - KPP_REAL, INTENT(IN) :: TOUT ! End Time - ! Optional input parameters and statistics - INTEGER, INTENT(IN), OPTIONAL :: ICNTRL_U(20) - KPP_REAL, INTENT(IN), OPTIONAL :: RCNTRL_U(20) - INTEGER, INTENT(OUT), OPTIONAL :: ISTATUS_U(20) - KPP_REAL, INTENT(OUT), OPTIONAL :: RSTATUS_U(20) - INTEGER, INTENT(OUT), OPTIONAL :: Ierr_U - - INTEGER, SAVE :: Ntotal = 0 - KPP_REAL :: RCNTRL(20), RSTATUS(20), T1, T2 - INTEGER :: ICNTRL(20), ISTATUS(20), Ierr - - ICNTRL(:) = 0 - RCNTRL(:) = 0.0_dp - ISTATUS(:) = 0 - RSTATUS(:) = 0.0_dp - - !~~~> fine-tune the integrator: - ICNTRL(5) = 8 ! Max no. of Newton iterations - ICNTRL(7) = 1 ! Adjoint solution by: 0=Newton, 1=direct - ICNTRL(8) = 1 ! Save fwd LU factorization: 0 = do *not* save, 1 = save - - ! If optional parameters are given, and if they are >0, - ! then they overwrite default settings. - IF (PRESENT(ICNTRL_U)) THEN - WHERE(ICNTRL_U(:) > 0) ICNTRL(:) = ICNTRL_U(:) - END IF - IF (PRESENT(RCNTRL_U)) THEN - WHERE(RCNTRL_U(:) > 0) RCNTRL(:) = RCNTRL_U(:) - END IF - - - T1 = TIN; T2 = TOUT - CALL SDIRK_SOA(NVAR, NSOA, T1, T2, Y, Y_tlm, Lambda, Sigma, & - RTOL, ATOL, ATOL_adj, RTOL_adj, & - RCNTRL, ICNTRL, RSTATUS, ISTATUS, Ierr ) - - !~~~> Debug option: number of steps - ! Ntotal = Ntotal + ISTATUS(Nstp) - ! WRITE(6,777) ISTATUS(Nstp),Ntotal,VAR(ind_O3),VAR(ind_NO2) - ! 777 FORMAT('NSTEPS=',I5,' (',I5,') O3=',E24.14,' NO2=',E24.14) - - IF (Ierr < 0) THEN - PRINT *,'SDIRK: Unsuccessful exit at T=',TIN,' (Ierr=',Ierr,')' - ENDIF - - ! if optional parameters are given for output they to return information - IF (PRESENT(ISTATUS_U)) ISTATUS_U(:) = ISTATUS(:) - IF (PRESENT(RSTATUS_U)) RSTATUS_U(:) = RSTATUS(:) - IF (PRESENT(Ierr_U)) Ierr_U = Ierr - - END SUBROUTINE INTEGRATE_SOA - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SDIRK_SOA(N, NSOA, Tinitial, Tfinal, & - Y, Y_tlm, Lambda, Sigma, & - RelTol, AbsTol, RelTol_adj, AbsTol_adj, & - RCNTRL, ICNTRL, RSTATUS, ISTATUS, Ierr) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -! Solves the system y'=F(t,y) using a Singly-Diagonally-Implicit -! Runge-Kutta (SDIRK) method. -! -! This implementation is based on the book and the code Sdirk4: -! -! E. Hairer and G. Wanner -! "Solving ODEs II. Stiff and differential-algebraic problems". -! Springer series in computational mathematics, Springer-Verlag, 1996. -! This code is based on the SDIRK4 routine in the above book. -! -! Methods: -! * Sdirk 2a, 2b: L-stable, 2 stages, order 2 -! * Sdirk 3a: L-stable, 3 stages, order 2, adjoint-invariant -! * Sdirk 4a, 4b: L-stable, 5 stages, order 4 -! -! (C) Adrian Sandu, July 2005 -! Virginia Polytechnic Institute and State University -! Contact: sandu@cs.vt.edu -! Revised by Philipp Miehe and Adrian Sandu, May 2006 -! This implementation is part of KPP - the Kinetic PreProcessor -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!~~~> INPUT ARGUMENTS: -! -!- Y(NVAR) = vector of initial conditions (at T=Tinitial) -!- [Tinitial,Tfinal] = time range of integration -! (if Tinitial>Tfinal the integration is performed backwards in time) -!- RelTol, AbsTol = user precribed accuracy -!- SUBROUTINE ode_Fun( T, Y, Ydot ) = ODE function, -! returns Ydot = Y' = F(T,Y) -!- SUBROUTINE ode_Fun( T, Y, Ydot ) = Jacobian of the ODE function, -! returns Jcb = dF/dY -!- ICNTRL(1:20) = integer inputs parameters -!- RCNTRL(1:20) = real inputs parameters -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!~~~> OUTPUT ARGUMENTS: -! -!- Y(NVAR) -> vector of final states (at T->Tfinal) -!- ISTATUS(1:20) -> integer output parameters -!- RSTATUS(1:20) -> real output parameters -!- Ierr -> job status upon return -! success (positive value) or -! failure (negative value) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!~~~> INPUT PARAMETERS: -! -! Note: For input parameters equal to zero the default values of the -! corresponding variables are used. -! -! Note: For input parameters equal to zero the default values of the -! corresponding variables are used. -!~~~> -! ICNTRL(1) = not used -! -! ICNTRL(2) = 0: AbsTol, RelTol are NVAR-dimensional vectors -! = 1: AbsTol, RelTol are scalars -! -! ICNTRL(3) = Method -! -! ICNTRL(4) -> maximum number of integration steps -! For ICNTRL(4)=0 the default value of 100000 is used -! -! ICNTRL(5) -> maximum number of Newton iterations -! For ICNTRL(5)=0 the default value of 8 is used -! -! ICNTRL(6) -> starting values of Newton iterations: -! ICNTRL(6)=0 : starting values are interpolated (the default) -! ICNTRL(6)=1 : starting values are zero -! -! ICNTRL(7) -> method to solve TLM equations: -! ICNTRL(7)=0 : modified Newton re-using LU (the default) -! ICNTRL(7)=1 : direct solution (additional one LU factorization per stage) -! -! ICNTRL(9) -> switch for TLM Newton iteration error estimation strategy -! ICNTRL(9) = 0: base number of iterations as forward solution -! ICNTRL(9) = 1: use RTOL_tlm and ATOL_tlm to calculate -! error estimation for TLM at Newton stages -! -! ICNTRL(12) -> switch for TLM truncation error control -! ICNTRL(12) = 0: TLM error is not used -! ICNTRL(12) = 1: TLM error is computed and used -! -! -!~~~> Real parameters -! -! RCNTRL(1) -> Hmin, lower bound for the integration step size -! It is strongly recommended to keep Hmin = ZERO -! RCNTRL(2) -> Hmax, upper bound for the integration step size -! RCNTRL(3) -> Hstart, starting value for the integration step size -! -! RCNTRL(4) -> FacMin, lower bound on step decrease factor (default=0.2) -! RCNTRL(5) -> FacMax, upper bound on step increase factor (default=6) -! RCNTRL(6) -> FacRej, step decrease factor after multiple rejections -! (default=0.1) -! RCNTRL(7) -> FacSafe, by which the new step is slightly smaller -! than the predicted value (default=0.9) -! RCNTRL(8) -> ThetaMin. If Newton convergence rate smaller -! than ThetaMin the Jacobian is not recomputed; -! (default=0.001) -! RCNTRL(9) -> NewtonTol, stopping criterion for Newton's method -! (default=0.03) -! RCNTRL(10) -> Qmin -! RCNTRL(11) -> Qmax. If Qmin < Hnew/Hold < Qmax, then the -! step size is kept constant and the LU factorization -! reused (default Qmin=1, Qmax=1.2) -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!~~~> OUTPUT PARAMETERS: -! -! Note: each call to Rosenbrock adds the current no. of fcn calls -! to previous value of ISTATUS(1), and similar for the other params. -! Set ISTATUS(1:10) = 0 before call to avoid this accumulation. -! -! ISTATUS(1) = No. of function calls -! ISTATUS(2) = No. of jacobian calls -! ISTATUS(3) = No. of steps -! ISTATUS(4) = No. of accepted steps -! ISTATUS(5) = No. of rejected steps (except at the beginning) -! ISTATUS(6) = No. of LU decompositions -! ISTATUS(7) = No. of forward/backward substitutions -! ISTATUS(8) = No. of singular matrix decompositions -! -! RSTATUS(1) -> Texit, the time corresponding to the -! computed Y upon return -! RSTATUS(2) -> Hexit,last accepted step before return -! RSTATUS(3) -> Hnew, last predicted step before return -! For multiple restarts, use Hnew as Hstart in the following run -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - - -! Arguments - INTEGER, PARAMETER :: NADJ = 1 - INTEGER, INTENT(IN) :: N, NSOA - KPP_REAL, INTENT(INOUT) :: Y(NVAR), Y_tlm(NVAR,NSOA) - KPP_REAL, INTENT(INOUT) :: Lambda(NVAR,NADJ) - KPP_REAL, INTENT(INOUT) :: Sigma(NVAR,NSOA) - INTEGER, INTENT(IN) :: ICNTRL(20) - KPP_REAL, INTENT(IN) :: Tinitial, Tfinal, & - RelTol(N), AbsTol(N), RCNTRL(20), & - RelTol_adj(N,NSOA), AbsTol_adj(N,NSOA) - INTEGER, INTENT(OUT) :: Ierr - INTEGER, INTENT(INOUT) :: ISTATUS(20) - KPP_REAL, INTENT(OUT) :: RSTATUS(20) - -!~~~> SDIRK method coefficients, up to 5 stages - INTEGER, PARAMETER :: Smax = 5 - INTEGER, PARAMETER :: S2A=1, S2B=2, S3A=3, S4A=4, S4B=5 - KPP_REAL :: rkGamma, rkA(Smax,Smax), rkB(Smax), rkC(Smax), & - rkD(Smax), rkE(Smax), rkBhat(Smax), rkELO, & - rkAlpha(Smax,Smax), rkTheta(Smax,Smax) - INTEGER :: sdMethod, rkS ! The number of stages - -!~~~> Checkpoints in memory buffers - INTEGER :: stack_ptr = 0 ! last written entry in checkpoint - KPP_REAL, DIMENSION(:), POINTER :: chk_H, chk_T - KPP_REAL, DIMENSION(:,:), POINTER :: chk_Y - KPP_REAL, DIMENSION(:,:,:), POINTER :: chk_Z - KPP_REAL, DIMENSION(:,:,:), POINTER :: chk_Y_tlm - KPP_REAL, DIMENSION(:,:,:,:), POINTER :: chk_Z_tlm - INTEGER, DIMENSION(:,:), POINTER :: chk_P -#ifdef FULL_ALGEBRA - KPP_REAL, DIMENSION(:,:,:), POINTER :: chk_J -#else - KPP_REAL, DIMENSION(:,:), POINTER :: chk_J -#endif - -!~~~> Local variables - KPP_REAL :: Hmin, Hmax, Hstart, Roundoff, & - FacMin, Facmax, FacSafe, FacRej, & - ThetaMin, NewtonTol, Qmin, Qmax - LOGICAL :: SaveLU, DirectADJ - INTEGER :: ITOL, NewtonMaxit, Max_no_steps, i - LOGICAL :: StartNewton, DirectTLM, TLMNewtonEst, TLMtruncErr - KPP_REAL, PARAMETER :: ZERO = 0.0d0, ONE = 1.0d0 - - - Ierr = 0 - ISTATUS(1:20) = 0 - RSTATUS(1:20) = ZERO - -!~~~> For Scalar tolerances (ICNTRL(2).NE.0) the code uses AbsTol(1) and RelTol(1) -! For Vector tolerances (ICNTRL(2) == 0) the code uses AbsTol(1:NVAR) and RelTol(1:NVAR) - IF (ICNTRL(2) == 0) THEN - ITOL = 1 - ELSE - ITOL = 0 - END IF - -!~~~> ICNTRL(3) - method selection - SELECT CASE (ICNTRL(3)) - CASE (0,1) - CALL Sdirk2a - CASE (2) - CALL Sdirk2b - CASE (3) - CALL Sdirk3a - CASE (4) - CALL Sdirk4a - CASE (5) - CALL Sdirk4b - CASE DEFAULT - CALL Sdirk2a - END SELECT - -!~~~> The maximum number of time steps admitted - IF (ICNTRL(4) == 0) THEN - Max_no_steps = 200000 - ELSEIF (ICNTRL(4) > 0) THEN - Max_no_steps=ICNTRL(4) - ELSE - PRINT * ,'User-selected ICNTRL(4)=',ICNTRL(4) - CALL SDIRK_ErrorMsg(-1,Tinitial,ZERO,Ierr) - END IF - !~~~> The maximum number of Newton iterations admitted - IF(ICNTRL(5) == 0)THEN - NewtonMaxit=8 - ELSE - NewtonMaxit=ICNTRL(5) - IF(NewtonMaxit <= 0)THEN - PRINT * ,'User-selected ICNTRL(5)=',ICNTRL(5) - CALL SDIRK_ErrorMsg(-2,Tinitial,ZERO,Ierr) - END IF - END IF -!~~~> StartNewton: Use extrapolation for starting values of Newton iterations - IF (ICNTRL(6) == 0) THEN - StartNewton = .TRUE. - ELSE - StartNewton = .FALSE. - END IF - -!~~~> Solve ADJ equations directly or by Newton iterations - DirectADJ = (ICNTRL(7) == 1) - -!~~~> Save or not the forward LU factorization - SaveLU = (ICNTRL(8) /= 0) .AND. (.NOT.DirectADJ) - -!~~~> Newton iteration error control selection - IF (ICNTRL(9) == 0) THEN - TLMNewtonEst = .FALSE. - ELSE - TLMNewtonEst = .TRUE. - END IF -!~~~> TLM truncation error control selection - IF (ICNTRL(12) == 0) THEN - TLMtruncErr = .FALSE. - ELSE - TLMtruncErr = .TRUE. - END IF - -!~~~> Unit roundoff (1+Roundoff>1) - Roundoff = WLAMCH('E') - -!~~~> Lower bound on the step size: (positive value) - IF (RCNTRL(1) == ZERO) THEN - Hmin = ZERO - ELSEIF (RCNTRL(1) > ZERO) THEN - Hmin = RCNTRL(1) - ELSE - PRINT * , 'User-selected RCNTRL(1)=', RCNTRL(1) - CALL SDIRK_ErrorMsg(-3,Tinitial,ZERO,Ierr) - END IF - -!~~~> Upper bound on the step size: (positive value) - IF (RCNTRL(2) == ZERO) THEN - Hmax = ABS(Tfinal-Tinitial) - ELSEIF (RCNTRL(2) > ZERO) THEN - Hmax = MIN(ABS(RCNTRL(2)),ABS(Tfinal-Tinitial)) - ELSE - PRINT * , 'User-selected RCNTRL(2)=', RCNTRL(2) - CALL SDIRK_ErrorMsg(-3,Tinitial,ZERO,Ierr) - END IF - -!~~~> Starting step size: (positive value) - IF (RCNTRL(3) == ZERO) THEN - Hstart = MAX(Hmin,Roundoff) - ELSEIF (RCNTRL(3) > ZERO) THEN - Hstart = MIN(ABS(RCNTRL(3)),ABS(Tfinal-Tinitial)) - ELSE - PRINT * , 'User-selected Hstart: RCNTRL(3)=', RCNTRL(3) - CALL SDIRK_ErrorMsg(-3,Tinitial,ZERO,Ierr) - END IF - -!~~~> Step size can be changed s.t. FacMin < Hnew/Hexit < FacMax - IF (RCNTRL(4) == ZERO) THEN - FacMin = 0.2_dp - ELSEIF (RCNTRL(4) > ZERO) THEN - FacMin = RCNTRL(4) - ELSE - PRINT * , 'User-selected FacMin: RCNTRL(4)=', RCNTRL(4) - CALL SDIRK_ErrorMsg(-4,Tinitial,ZERO,Ierr) - END IF - IF (RCNTRL(5) == ZERO) THEN - FacMax = 10.0_dp - ELSEIF (RCNTRL(5) > ZERO) THEN - FacMax = RCNTRL(5) - ELSE - PRINT * , 'User-selected FacMax: RCNTRL(5)=', RCNTRL(5) - CALL SDIRK_ErrorMsg(-4,Tinitial,ZERO,Ierr) - END IF -!~~~> FacRej: Factor to decrease step after 2 succesive rejections - IF (RCNTRL(6) == ZERO) THEN - FacRej = 0.1_dp - ELSEIF (RCNTRL(6) > ZERO) THEN - FacRej = RCNTRL(6) - ELSE - PRINT * , 'User-selected FacRej: RCNTRL(6)=', RCNTRL(6) - CALL SDIRK_ErrorMsg(-4,Tinitial,ZERO,Ierr) - END IF -!~~~> FacSafe: Safety Factor in the computation of new step size - IF (RCNTRL(7) == ZERO) THEN - FacSafe = 0.9_dp - ELSEIF (RCNTRL(7) > ZERO) THEN - FacSafe = RCNTRL(7) - ELSE - PRINT * , 'User-selected FacSafe: RCNTRL(7)=', RCNTRL(7) - CALL SDIRK_ErrorMsg(-4,Tinitial,ZERO,Ierr) - END IF - -!~~~> ThetaMin: decides whether the Jacobian should be recomputed - IF(RCNTRL(8) == 0.D0)THEN - ThetaMin = 1.0d-3 - ELSE - ThetaMin = RCNTRL(8) - END IF - -!~~~> Stopping criterion for Newton's method - IF(RCNTRL(9) == ZERO)THEN - NewtonTol = 3.0d-2 - ELSE - NewtonTol = RCNTRL(9) - END IF - -!~~~> Qmin, Qmax: IF Qmin < Hnew/Hold < Qmax, STEP SIZE = CONST. - IF(RCNTRL(10) == ZERO)THEN - Qmin=ONE - ELSE - Qmin=RCNTRL(10) - END IF - IF(RCNTRL(11) == ZERO)THEN - Qmax=1.2D0 - ELSE - Qmax=RCNTRL(11) - END IF - -!~~~> Check if tolerances are reasonable - IF (ITOL == 0) THEN - IF (AbsTol(1) <= ZERO .OR. RelTol(1) <= 10.D0*Roundoff) THEN - PRINT * , ' Scalar AbsTol = ',AbsTol(1) - PRINT * , ' Scalar RelTol = ',RelTol(1) - CALL SDIRK_ErrorMsg(-5,Tinitial,ZERO,Ierr) - END IF - ELSE - DO i=1,N - IF (AbsTol(i) <= 0.D0.OR.RelTol(i) <= 10.D0*Roundoff) THEN - PRINT * , ' AbsTol(',i,') = ',AbsTol(i) - PRINT * , ' RelTol(',i,') = ',RelTol(i) - CALL SDIRK_ErrorMsg(-5,Tinitial,ZERO,Ierr) - END IF - END DO - END IF - - IF (Ierr < 0) RETURN - -!~~~> Allocate memory buffers - CALL SDIRK_AllocBuffers - -!~~~> Call forward integration - CALL SDIRK_FwdTlmInt( N, NSOA, Tinitial, Tfinal, Y, Y_tlm, Ierr ) - -!~~~> Call adjoint integration - CALL SDIRK_SoaInt( N, NSOA, Lambda, Sigma, Ierr ) - -!~~~> Free memory buffers - CALL SDIRK_FreeBuffers - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - CONTAINS ! Procedures internal to SDIRK_SOA -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SDIRK_FwdTlmInt( N,NTLM,Tinitial,Tfinal,Y,Y_tlm,Ierr ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - USE KPP_ROOT_Parameters - IMPLICIT NONE - -!~~~> Arguments: - INTEGER, INTENT(IN) :: N, NTLM - KPP_REAL, INTENT(INOUT) :: Y(N), Y_tlm(N,NTLM) - KPP_REAL, INTENT(IN) :: Tinitial, Tfinal - INTEGER, INTENT(OUT) :: Ierr - -!~~~> Local variables: - KPP_REAL :: Z(NVAR,rkS), G(NVAR), TMP(NVAR), & - NewtonRate, SCAL(NVAR), DZ(NVAR), & - T, H, Theta, Hratio, NewtonPredictedErr, & - Qnewton, Err, Fac, Hnew, Tdirection, & - NewtonIncrement, NewtonIncrementOld, & - SCAL_tlm(NVAR), Yerr(N), Yerr_tlm(N,NTLM), ThetaTLM - KPP_REAL :: Z_tlm(NVAR,rkS,NTLM) - INTEGER :: itlm, j, IER, istage, NewtonIter, saveNiter, NewtonIterTLM - INTEGER :: IP(NVAR), IP_tlm(NVAR) - LOGICAL :: Reject, FirstStep, SkipJac, SkipLU, NewtonDone - -#ifdef FULL_ALGEBRA - KPP_REAL, DIMENSION(NVAR,NVAR) :: FJAC, E, Jac, E_tlm -#else - KPP_REAL, DIMENSION(LU_NONZERO) :: FJAC, E, Jac, E_tlm -#endif - KPP_REAL, PARAMETER :: ZERO = 0.0d0, ONE = 1.0d0 - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Initializations -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - T = Tinitial - Tdirection = SIGN(ONE,Tfinal-Tinitial) - H = MAX(ABS(Hmin),ABS(Hstart)) - IF (ABS(H) <= 10.D0*Roundoff) H=1.0D-6 - H=MIN(ABS(H),Hmax) - H=SIGN(H,Tdirection) - SkipLU = .FALSE. - SkipJac = .FALSE. - Reject = .FALSE. - FirstStep=.TRUE. - - CALL SDIRK_ErrorScale(N, ITOL, AbsTol, RelTol, Y, SCAL) - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Time loop begins -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Tloop: DO WHILE ( (Tfinal-T)*Tdirection - Roundoff > ZERO ) - - -!~~~> Compute E = 1/(h*gamma)-Jac and its LU decomposition - IF ( .NOT.SkipLU ) THEN ! This time around skip the Jac update and LU - CALL SDIRK_PrepareMatrix ( H, T, Y, FJAC, & - SkipJac, SkipLU, E, IP, Reject, IER ) - IF (IER /= 0) THEN - CALL SDIRK_ErrorMsg(-8,T,H,Ierr); RETURN - END IF - END IF - - IF (ISTATUS(Nstp) > Max_no_steps) THEN - CALL SDIRK_ErrorMsg(-6,T,H,Ierr); RETURN - END IF - IF ( (T+0.1d0*H == T) .OR. (ABS(H) <= Roundoff) ) THEN - CALL SDIRK_ErrorMsg(-7,T,H,Ierr); RETURN - END IF - -stages:DO istage = 1, rkS - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Simplified Newton iterations -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -!~~~> Starting values for Newton iterations - CALL Set2zero(N,Z(1,istage)) - -!~~~> Prepare the loop-independent part of the right-hand side - CALL Set2zero(N,G) - IF (istage > 1) THEN - DO j = 1, istage-1 - ! Gj(:) = sum_j Theta(i,j)*Zj(:) = H * sum_j A(i,j)*Fun(Zj(:)) - CALL WAXPY(N,rkTheta(istage,j),Z(1,j),1,G,1) - ! Zi(:) = sum_j Alpha(i,j)*Zj(:) - IF (StartNewton) THEN - CALL WAXPY(N,rkAlpha(istage,j),Z(1,j),1,Z(1,istage),1) - END IF - END DO - END IF - - !~~~> Initializations for Newton iteration - NewtonDone = .FALSE. - Fac = 0.5d0 ! Step reduction factor if too many iterations - -NewtonLoop:DO NewtonIter = 1, NewtonMaxit - -!~~~> Prepare the loop-dependent part of the right-hand side - CALL WADD(N,Y,Z(1,istage),TMP) ! TMP <- Y + Zi - CALL FUN_CHEM(T+rkC(istage)*H,TMP,DZ) ! DZ <- Fun(Y+Zi) - ISTATUS(Nfun) = ISTATUS(Nfun) + 1 -! DZ(1:N) = G(1:N) - Z(1:N,istage) + (H*rkGamma)*DZ(1:N) - CALL WSCAL(N, H*rkGamma, DZ, 1) - CALL WAXPY (N, -ONE, Z(1,istage), 1, DZ, 1) - CALL WAXPY (N, ONE, G,1, DZ,1) - -!~~~> Solve the linear system - CALL SDIRK_Solve ( 'N', H, N, E, IP, IER, DZ ) - -!~~~> Check convergence of Newton iterations - CALL SDIRK_ErrorNorm(N, DZ, SCAL, NewtonIncrement) - IF ( NewtonIter == 1 ) THEN - Theta = ABS(ThetaMin) - NewtonRate = 2.0d0 - ELSE - Theta = NewtonIncrement/NewtonIncrementOld - IF (Theta < 0.99d0) THEN - NewtonRate = Theta/(ONE-Theta) - ! Predict error at the end of Newton process - NewtonPredictedErr = NewtonIncrement & - *Theta**(NewtonMaxit-NewtonIter)/(ONE-Theta) - IF (NewtonPredictedErr >= NewtonTol) THEN - ! Non-convergence of Newton: predicted error too large - Qnewton = MIN(10.0d0,NewtonPredictedErr/NewtonTol) - Fac = 0.8d0*Qnewton**(-ONE/(1+NewtonMaxit-NewtonIter)) - EXIT NewtonLoop - END IF - ELSE ! Non-convergence of Newton: Theta too large - EXIT NewtonLoop - END IF - END IF - NewtonIncrementOld = NewtonIncrement - ! Update solution: Z(:) <-- Z(:)+DZ(:) - CALL WAXPY(N,ONE,DZ,1,Z(1,istage),1) - - ! Check error in Newton iterations - NewtonDone = (NewtonRate*NewtonIncrement <= NewtonTol) - IF (NewtonDone) THEN - ! Tune error in TLM variables by defining the minimal number of Newton iterations. - saveNiter = NewtonIter+1 - EXIT NewtonLoop - END IF - - END DO NewtonLoop - - IF (.NOT.NewtonDone) THEN - !CALL RK_ErrorMsg(-12,T,H,Ierr); - H = Fac*H; Reject=.TRUE. - SkipJac = .TRUE.; SkipLU = .FALSE. - CYCLE Tloop - END IF - -!~~~> End of simplified Newton iterations for forward variables - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Solve for TLM variables -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - TMP(1:N) = Y(1:N) + Z(1:N,istage) - SkipJac = .FALSE. - CALL SDIRK_PrepareMatrix ( H, T+rkC(istage)*H, TMP, Jac, & - SkipJac, SkipLU, E_tlm, IP_tlm, Reject, IER ) - IF (IER /= 0) CYCLE TLoop - -TlmL: DO itlm = 1, NTLM - G(1:N) = Y_tlm(1:N,itlm) - IF (istage > 1) THEN - ! Gj(:) = sum_j Theta(i,j)*Zj_tlm(:) - ! = H * sum_j A(i,j)*Jac(Zj(:))*(Yj_tlm+Zj_tlm) - DO j = 1, istage-1 - CALL WAXPY(N,rkTheta(istage,j),Z_tlm(1,j,itlm),1,G,1) - END DO - END IF - CALL SDIRK_Solve ( 'N', H, N, E_tlm, IP_tlm, IER, G ) - Z_tlm(1:N,istage,itlm) = G(1:N) - Y_tlm(1:N,itlm) - END DO TlmL - - - END DO stages - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Error estimation -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ISTATUS(Nstp) = ISTATUS(Nstp) + 1 - CALL Set2zero(N,Yerr) - DO i = 1,rkS - IF (rkE(i)/=ZERO) CALL WAXPY(N,rkE(i),Z(1,i),1,Yerr,1) - END DO - - CALL SDIRK_Solve ( 'N', H, N, E, IP, IER, Yerr ) - CALL SDIRK_ErrorNorm(N, Yerr, SCAL, Err) - -!~~~> Computation of new step size Hnew - Fac = FacSafe*(Err)**(-ONE/rkELO) - Fac = MAX(FacMin,MIN(FacMax,Fac)) - Hnew = H*Fac - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Accept/Reject step -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -accept: IF ( Err < ONE ) THEN !~~~> Step is accepted - - FirstStep=.FALSE. - ISTATUS(Nacc) = ISTATUS(Nacc) + 1 - -!~~~> Checkpoint (old) solution - CALL SDIRK_Push( T, H, Y, Z, Y_tlm, Z_tlm, E, IP ) - -!~~~> Update time and solution - T = T + H - ! Y(:) <-- Y(:) + Sum_j rkD(j)*Z_j(:) - DO i = 1,rkS - IF (rkD(i)/=ZERO) THEN - CALL WAXPY(N,rkD(i),Z(1,i),1,Y,1) - DO itlm = 1, NTLM - CALL WAXPY(N,rkD(i),Z_tlm(1,i,itlm),1,Y_tlm(1,itlm),1) - END DO - END IF - END DO - -!~~~> Update scaling coefficients - CALL SDIRK_ErrorScale(N, ITOL, AbsTol, RelTol, Y, SCAL) - -!~~~> Next time step - Hnew = Tdirection*MIN(ABS(Hnew),Hmax) - ! Last T and H - RSTATUS(Ntexit) = T - RSTATUS(Nhexit) = H - RSTATUS(Nhnew) = Hnew - ! No step increase after a rejection - IF (Reject) Hnew = Tdirection*MIN(ABS(Hnew),ABS(H)) - Reject = .FALSE. - IF ((T+Hnew/Qmin-Tfinal)*Tdirection > ZERO) THEN - H = Tfinal-T - ELSE - Hratio=Hnew/H - ! If step not changed too much keep Jacobian and reuse LU - SkipLU = ( (Theta <= ThetaMin) .AND. (Hratio >= Qmin) & - .AND. (Hratio <= Qmax) ) - ! For TLM: do not skip LU (decrease TLM error) - SkipLU = .FALSE. - IF (.NOT.SkipLU) H = Hnew - END IF - ! If convergence is fast enough, do not update Jacobian -! SkipJac = (Theta <= ThetaMin) - SkipJac = .FALSE. - - ELSE accept !~~~> Step is rejected - - IF (FirstStep .OR. Reject) THEN - H = FacRej*H - ELSE - H = Hnew - END IF - Reject = .TRUE. - SkipJac = .TRUE. - SkipLU = .FALSE. - IF (ISTATUS(Nacc) >= 1) ISTATUS(Nrej) = ISTATUS(Nrej) + 1 - - END IF accept - - END DO Tloop - - ! Successful return - Ierr = 1 - - END SUBROUTINE SDIRK_FwdTlmInt - - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SDIRK_SoaInt( N, NSOA, Lambda, Sigma, Ierr ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - USE KPP_ROOT_Parameters - IMPLICIT NONE - - INTEGER, PARAMETER :: NADJ = 1 -!~~~> Arguments: - INTEGER, INTENT(IN) :: N, NSOA - KPP_REAL, INTENT(INOUT) :: Lambda(NVAR,NADJ) - KPP_REAL, INTENT(INOUT) :: Sigma(NVAR,NSOA) - INTEGER, INTENT(OUT) :: Ierr - -!~~~> Local variables: - KPP_REAL :: Y(NVAR) - KPP_REAL :: Z(NVAR,Smax), U(NVAR,Smax), & - TMP(NVAR), G1(NVAR), & - NewtonRate, SCAL(NVAR), DU(NVAR), & - T, H, Theta, NewtonPredictedErr, & - NewtonIncrement, NewtonIncrementOld - KPP_REAL :: Y_tlm(NVAR,NSOA), Z_tlm(NVAR,Smax,NSOA), & - G2(NVAR,NSOA), Hess0(NHESS), TMP2(NVAR) - KPP_REAL :: W(NVAR,Smax,NSOA), TMP_tlm(NVAR) - INTEGER :: j, IER, istage, iadj, isoa, NewtonIter, & - IP(NVAR), IP_adj(NVAR) - LOGICAL :: Reject, SkipJac, SkipLU, NewtonDone - -#ifdef FULL_ALGEBRA - KPP_REAL, DIMENSION(NVAR,NVAR) :: E, Jac, E_adj -#else - KPP_REAL, DIMENSION(LU_NONZERO):: E, Jac, E_adj -#endif - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Time loop begins -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Tloop: DO WHILE ( stack_ptr > 0 ) - - !~~~> Recover checkpoints for stage values and vectors - CALL SDIRK_Pop( T, H, Y, Z, Y_tlm, Z_tlm, E, IP ) - -!~~~> Compute E = 1/(h*gamma)-Jac and its LU decomposition -! IF (.NOT.SaveLU) THEN -! SkipJac = .FALSE.; SkipLU = .FALSE. -! CALL SDIRK_PrepareMatrix ( H, T, Y, Jac, & -! SkipJac, SkipLU, E, IP, Reject, IER ) -! IF (IER /= 0) THEN -! CALL SDIRK_ErrorMsg(-8,T,H,Ierr); RETURN -! END IF -! END IF - -stages:DO istage = rkS, 1, -1 - -!~~~> Jacobian at the current stage solution - TMP(1:N) = Y(1:N) + Z(1:N,istage) - CALL JAC_CHEM(T+rkC(istage)*H,TMP,Jac) - ISTATUS(Njac) = ISTATUS(Njac) + 1 - -!~~~> Hessian at the current stage solution - CALL HESS_CHEM(T+rkC(istage)*H,TMP,Hess0) - -#ifdef FULL_ALGEBRA - E_adj(1:N,1:N) = -Jac(1:N,1:N) - DO j=1,N - E_adj(j,j) = E_adj(j,j) + ONE/(H*rkGamma) - END DO - CALL DGETRF( N, N, E_adj, N, IP_adj, IER ) -#else - E_adj(1:LU_NONZERO) = -Jac(1:LU_NONZERO) - DO i = 1,NVAR - j = LU_DIAG(i); E_adj(j) = E_adj(j) + ONE/(H*rkGamma) - END DO - CALL KppDecomp ( E_adj, IER) -#endif - ISTATUS(Ndec) = ISTATUS(Ndec) + 1 - IF (IER /= 0) THEN - PRINT*,'At stage ',istage,' the matrix used in adjoint', & - ' computation is singular' - CALL SDIRK_ErrorMsg(-8,T,H,Ierr); RETURN - END IF - -!~~~> Prepare the loop-independent part of the right-hand side -!~~~> G1(:) = H*( B(i)*Lambda + sum_j A(j,i)*Uj(:) ) - G1(1:N) = rkB(istage)*Lambda(1:N,1) - IF (istage < rkS) THEN - DO j = istage+1, rkS - CALL WAXPY(N,rkA(j,istage),U(1,j),1,G1,1) - END DO - END IF - G1(1:N) = H*G1(1:N) - TMP2(1:N) = G1(1:N) - -! G1(:) = H*Jac^T*( B(i)*Lambda + sum_j A(j,i)*Uj(:) ) -#ifdef FULL_ALGEBRA - TMP = MATMUL(TRANSPOSE(Jac),G1) ! DZ <- Jac(Y+Z)*Y_tlm -#else - CALL JacTR_SP_Vec ( Jac, G1, TMP ) -#endif - G1(1:N) = TMP(1:N) - -!~~~> Compute FOA stage - CALL SDIRK_Solve ( 'T', H, N, E_adj, IP_adj, IER, G1 ) - U(1:N,istage) = G1(1:N) - -!~~~> Prepare the loop-independent part of the SOA right-hand side - G1(1:N) = rkB(istage)*Lambda(1:N,1) - IF (istage < rkS) THEN - DO j = istage+1, rkS - CALL WAXPY(N,rkA(j,istage),U(1,j),1,G1,1) - END DO - CALL WAXPY(N,rkGamma,U(1,istage),1,G1,1) - END IF - G1(1:N) = H*G1(1:N) - -!~~~> G2(:) = H*( B(i)*Sigma + sum_j A(j,i)*Wj(:) ) - DO isoa = 1, NSOA - - G2(1:N,isoa) = rkB(istage)*Sigma(1:N,isoa) - IF (istage < rkS) THEN - DO j = istage+1, rkS - G2(1:N,isoa) = G2(1:N,isoa) + rkA(j,istage)*W(1:N,j,isoa) - END DO - END IF - G2(1:N,isoa) = H*G2(1:N,isoa) - -#ifdef FULL_ALGEBRA - TMP = MATMUL(TRANSPOSE(Jac),G2(1,isoa)) ! DZ <- Jac(Y+Z)*Y_tlm -#else - CALL JacTR_SP_Vec ( Jac, G2(1,isoa), TMP ) -#endif - G2(1:N,isoa) = TMP(1:N) - -!~~~> Add [ Hess0 x Y_tlm(istage) ]^T * G1 - TMP_tlm(1:N) = Y_tlm(1:N,isoa) + Z_tlm(1:N,istage,isoa) - CALL HessTR_Vec ( Hess0, G1, TMP_tlm, TMP ) - G2(1:N,isoa) = G2(1:N,isoa) + TMP(1:N) - - END DO ! isoa = 1, NSOA - -!~~~> Compute SOA stage - DO isoa = 1, NSOA - TMP(1:N) = G2(1:N,isoa) - CALL SDIRK_Solve ( 'T', H, N, E_adj, IP_adj, IER, TMP ) - W(1:N,istage,isoa) = TMP - END DO ! isoa = 1, NSOA - - END DO stages - -!~~~> Update first order adjoint solution - DO istage = 1,rkS - Lambda(1:N,1) = Lambda(1:N,1) + U(1:N,istage) - END DO - -!~~~> Update second order adjoint solution - DO istage = 1,rkS - DO isoa = 1,NSOA - Sigma(1:N,isoa) = Sigma(1:N,isoa) + W(1:N,istage,isoa) - END DO - END DO - - END DO Tloop - - ! Successful return - Ierr = 1 - - END SUBROUTINE SDIRK_SoaInt - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SDIRK_AllocBuffers -!~~~> Allocate buffer space for checkpointing -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - INTEGER :: i - - ALLOCATE( chk_H(Max_no_steps), STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed allocation of buffer H'; STOP - END IF - ALLOCATE( chk_T(Max_no_steps), STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed allocation of buffer T'; STOP - END IF - ALLOCATE( chk_Y(NVAR,Max_no_steps), STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed allocation of buffer Y'; STOP - END IF - ALLOCATE( chk_Y_tlm(NVAR,NSOA,Max_no_steps), STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed allocation of buffer Y_tlm'; STOP - END IF - ALLOCATE( chk_Z(NVAR,rkS,Max_no_steps), STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed allocation of buffer Z'; STOP - END IF - ALLOCATE( chk_Z_tlm(NVAR,rkS,NSOA,Max_no_steps), STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed allocation of buffer Z_tlm'; STOP - END IF - IF (SaveLU) THEN -#ifdef FULL_ALGEBRA - ALLOCATE( chk_J(NVAR,NVAR,Max_no_steps), STAT=i ) -#else - ALLOCATE( chk_J(LU_NONZERO,Max_no_steps), STAT=i ) -#endif - IF (i/=0) THEN - PRINT*,'Failed allocation of buffer J'; STOP - END IF - ALLOCATE( chk_P(NVAR,Max_no_steps), STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed allocation of buffer P'; STOP - END IF - END IF - - END SUBROUTINE SDIRK_AllocBuffers - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SDIRK_FreeBuffers -!~~~> Dallocate buffer space for discrete adjoint -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - INTEGER :: i - - DEALLOCATE( chk_H, STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed deallocation of buffer H'; STOP - END IF - DEALLOCATE( chk_T, STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed deallocation of buffer T'; STOP - END IF - DEALLOCATE( chk_Y, STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed deallocation of buffer Y'; STOP - END IF - DEALLOCATE( chk_Y_tlm, STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed deallocation of buffer Y_tlm'; STOP - END IF - DEALLOCATE( chk_Z, STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed deallocation of buffer Z'; STOP - END IF - DEALLOCATE( chk_Z_tlm, STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed deallocation of buffer Z_tlm'; STOP - END IF - IF (SaveLU) THEN - DEALLOCATE( chk_J, STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed deallocation of buffer J'; STOP - END IF - DEALLOCATE( chk_P, STAT=i ) - IF (i/=0) THEN - PRINT*,'Failed deallocation of buffer P'; STOP - END IF - END IF - - END SUBROUTINE SDIRK_FreeBuffers - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SDIRK_Push( T, H, Y, Z, Y_tlm, Z_tlm, E, P ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Saves the next trajectory snapshot for discrete adjoints -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - KPP_REAL :: T, H, Y(NVAR), Z(NVAR,rkS) - KPP_REAL :: Y_tlm(NVAR,NSOA), Z_tlm(NVAR,rkS,NSOA) - INTEGER :: P(NVAR) -#ifdef FULL_ALGEBRA - KPP_REAL :: E(NVAR,NVAR) -#else - KPP_REAL :: E(LU_NONZERO) -#endif - - stack_ptr = stack_ptr + 1 - IF ( stack_ptr > Max_no_steps ) THEN - PRINT*,'Push failed: buffer overflow' - STOP - END IF - chk_H( stack_ptr ) = H - chk_T( stack_ptr ) = T - chk_Y(1:NVAR,stack_ptr) = Y(1:NVAR) - chk_Z(1:NVAR,1:rkS,stack_ptr) = Z(1:NVAR,1:rkS) - chk_Y_tlm(1:NVAR,1:NSOA,stack_ptr) = Y_tlm(1:NVAR,1:NSOA) - chk_Z_tlm(1:NVAR,1:rkS,1:NSOA,stack_ptr) = Z_tlm(1:NVAR,1:rkS,1:NSOA) - IF (SaveLU) THEN -#ifdef FULL_ALGEBRA - chk_J(1:NVAR,1:NVAR,stack_ptr) = E(1:NVAR,1:NVAR) - chk_P(1:NVAR,stack_ptr) = P(1:NVAR) -#else - chk_J(1:LU_NONZERO,stack_ptr) = E(1:LU_NONZERO) -#endif - END IF - - END SUBROUTINE SDIRK_Push - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SDIRK_Pop( T, H, Y, Z, Y_tlm, Z_tlm, E, P ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Retrieves the next trajectory snapshot for discrete adjoints -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - KPP_REAL :: T, H, Y(NVAR), Z(NVAR,Smax) - KPP_REAL :: Y_tlm(NVAR,NSOA), Z_tlm(NVAR,Smax,NSOA) - INTEGER :: P(NVAR) -#ifdef FULL_ALGEBRA - KPP_REAL :: E(NVAR,NVAR) -#else - KPP_REAL :: E(LU_NONZERO) -#endif - - IF ( stack_ptr <= 0 ) THEN - PRINT*,'Pop failed: empty buffer' - STOP - END IF - H = chk_H( stack_ptr ) - T = chk_T( stack_ptr ) - Y(1:NVAR) = chk_Y(1:NVAR,stack_ptr) - Z(1:NVAR,1:rkS) = chk_Z(1:NVAR,1:rkS,stack_ptr) - Y_tlm(1:NVAR,1:NSOA) = chk_Y_tlm(1:NVAR,1:NSOA,stack_ptr) - Z_tlm(1:NVAR,1:rkS,1:NSOA) = chk_Z_tlm(1:NVAR,1:rkS,1:NSOA,stack_ptr) - IF (SaveLU) THEN -#ifdef FULL_ALGEBRA - E(1:NVAR,1:NVAR) = chk_J(1:NVAR,1:NVAR,stack_ptr) - P(1:NVAR) = chk_P(1:NVAR,stack_ptr) -#else - E(1:LU_NONZERO) = chk_J(1:LU_NONZERO,stack_ptr) -#endif - END IF - - stack_ptr = stack_ptr - 1 - - END SUBROUTINE SDIRK_Pop - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SDIRK_ErrorScale(N, ITOL, AbsTol, RelTol, Y, SCAL) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - INTEGER :: i, N, ITOL - KPP_REAL :: AbsTol(N), RelTol(N), & - Y(N), SCAL(N) - IF (ITOL == 0) THEN - DO i=1,N - SCAL(i) = ONE / ( AbsTol(1)+RelTol(1)*ABS(Y(i)) ) - END DO - ELSE - DO i=1,N - SCAL(i) = ONE / ( AbsTol(i)+RelTol(i)*ABS(Y(i)) ) - END DO - END IF - END SUBROUTINE SDIRK_ErrorScale - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SDIRK_ErrorNorm(N, Y, SCAL, Err) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! - INTEGER :: i, N - KPP_REAL :: Y(N), SCAL(N), Err - Err = ZERO - DO i=1,N - Err = Err+(Y(i)*SCAL(i))**2 - END DO - Err = MAX( SQRT(Err/DBLE(N)), 1.0d-10 ) -! - END SUBROUTINE SDIRK_ErrorNorm - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -SUBROUTINE SDIRK_ErrorMsg(Code,T,H,Ierr) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Handles all error messages -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - KPP_REAL, INTENT(IN) :: T, H - INTEGER, INTENT(IN) :: Code - INTEGER, INTENT(OUT) :: Ierr - - Ierr = Code - PRINT * , & - 'Forced exit from SDIRK due to the following error:' - - SELECT CASE (Code) - CASE (-1) - PRINT * , '--> Improper value for maximal no of steps' - CASE (-2) - PRINT * , '--> Improper value for maximal no of Newton iterations' - CASE (-3) - PRINT * , '--> Hmin/Hmax/Hstart must be positive' - CASE (-4) - PRINT * , '--> FacMin/FacMax/FacRej must be positive' - CASE (-5) - PRINT * , '--> Improper tolerance values' - CASE (-6) - PRINT * , '--> No of steps exceeds maximum bound', max_no_steps - CASE (-7) - PRINT * , '--> Step size too small: T + 10*H = T', & - ' or H < Roundoff' - CASE (-8) - PRINT * , '--> Matrix is repeatedly singular' - CASE DEFAULT - PRINT *, 'Unknown Error code: ', Code - END SELECT - - PRINT *, "T=", T, "and H=", H - - END SUBROUTINE SDIRK_ErrorMsg - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SDIRK_PrepareMatrix ( H, T, Y, FJAC, & - SkipJac, SkipLU, E, IP, Reject, ISING ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Compute the matrix E = 1/(H*GAMMA)*Jac, and its decomposition -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - - KPP_REAL, INTENT(INOUT) :: H - KPP_REAL, INTENT(IN) :: T, Y(NVAR) - LOGICAL, INTENT(INOUT) :: SkipJac,SkipLU,Reject - INTEGER, INTENT(OUT) :: ISING, IP(NVAR) -#ifdef FULL_ALGEBRA - KPP_REAL, INTENT(INOUT) :: FJAC(NVAR,NVAR) - KPP_REAL, INTENT(OUT) :: E(NVAR,NVAR) -#else - KPP_REAL, INTENT(INOUT) :: FJAC(LU_NONZERO) - KPP_REAL, INTENT(OUT) :: E(LU_NONZERO) -#endif - KPP_REAL :: HGammaInv - INTEGER :: i, j, ConsecutiveSng - - ConsecutiveSng = 0 - ISING = 1 - -Hloop: DO WHILE (ISING /= 0) - - HGammaInv = ONE/(H*rkGamma) - -!~~~> Compute the Jacobian -! IF (SkipJac) THEN -! SkipJac = .FALSE. -! ELSE - IF (.NOT. SkipJac) THEN - CALL JAC_CHEM( T, Y, FJAC ) - ISTATUS(Njac) = ISTATUS(Njac) + 1 - END IF - -#ifdef FULL_ALGEBRA - DO j=1,NVAR - DO i=1,NVAR - E(i,j) = -FJAC(i,j) - END DO - E(j,j) = E(j,j)+HGammaInv - END DO - CALL DGETRF( NVAR, NVAR, E, NVAR, IP, ISING ) -#else - DO i = 1,LU_NONZERO - E(i) = -FJAC(i) - END DO - DO i = 1,NVAR - j = LU_DIAG(i); E(j) = E(j) + HGammaInv - END DO - CALL KppDecomp ( E, ISING) - IP(1) = 1 -#endif - ISTATUS(Ndec) = ISTATUS(Ndec) + 1 - - IF (ISING /= 0) THEN - WRITE (6,*) ' MATRIX IS SINGULAR, ISING=',ISING,' T=',T,' H=',H - ISTATUS(Nsng) = ISTATUS(Nsng) + 1; ConsecutiveSng = ConsecutiveSng + 1 - IF (ConsecutiveSng >= 6) RETURN ! Failure - H = 0.5d0*H - SkipJac = .FALSE. - SkipLU = .FALSE. - Reject = .TRUE. - END IF - - END DO Hloop - - END SUBROUTINE SDIRK_PrepareMatrix - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SDIRK_Solve ( Transp, H, N, E, IP, ISING, RHS ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Solves the system (H*Gamma-Jac)*x = R -! using the LU decomposition of E = I - 1/(H*Gamma)*Jac -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - INTEGER, INTENT(IN) :: N, IP(N), ISING - CHARACTER, INTENT(IN) :: Transp - KPP_REAL, INTENT(IN) :: H -#ifdef FULL_ALGEBRA - KPP_REAL, INTENT(IN) :: E(NVAR,NVAR) -#else - KPP_REAL, INTENT(IN) :: E(LU_NONZERO) -#endif - KPP_REAL, INTENT(INOUT) :: RHS(N) - KPP_REAL :: HGammaInv - - HGammaInv = ONE/(H*rkGamma) - CALL WSCAL(N,HGammaInv,RHS,1) - SELECT CASE (TRANSP) - CASE ('N') -#ifdef FULL_ALGEBRA - CALL DGETRS( 'N', N, 1, E, N, IP, RHS, N, ISING ) -#else - CALL KppSolve(E, RHS) -#endif - CASE ('T') -#ifdef FULL_ALGEBRA - CALL DGETRS( 'T', N, 1, E, N, IP, RHS, N, ISING ) -#else - CALL KppSolveTR(E, RHS, RHS) -#endif - CASE DEFAULT - PRINT*,'Error in SDIRK_Solve. Unknown Transp argument:',Transp - STOP - END SELECT - ISTATUS(Nsol) = ISTATUS(Nsol) + 1 - - END SUBROUTINE SDIRK_Solve - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Sdirk4a -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - sdMethod = S4A -! Number of stages - rkS = 5 - -! Method coefficients - rkGamma = .2666666666666666666666666666666667d0 - - rkA(1,1) = .2666666666666666666666666666666667d0 - rkA(2,1) = .5000000000000000000000000000000000d0 - rkA(2,2) = .2666666666666666666666666666666667d0 - rkA(3,1) = .3541539528432732316227461858529820d0 - rkA(3,2) = -.5415395284327323162274618585298197d-1 - rkA(3,3) = .2666666666666666666666666666666667d0 - rkA(4,1) = .8515494131138652076337791881433756d-1 - rkA(4,2) = -.6484332287891555171683963466229754d-1 - rkA(4,3) = .7915325296404206392428857585141242d-1 - rkA(4,4) = .2666666666666666666666666666666667d0 - rkA(5,1) = 2.100115700566932777970612055999074d0 - rkA(5,2) = -.7677800284445976813343102185062276d0 - rkA(5,3) = 2.399816361080026398094746205273880d0 - rkA(5,4) = -2.998818699869028161397714709433394d0 - rkA(5,5) = .2666666666666666666666666666666667d0 - - rkB(1) = 2.100115700566932777970612055999074d0 - rkB(2) = -.7677800284445976813343102185062276d0 - rkB(3) = 2.399816361080026398094746205273880d0 - rkB(4) = -2.998818699869028161397714709433394d0 - rkB(5) = .2666666666666666666666666666666667d0 - - rkBhat(1)= 2.885264204387193942183851612883390d0 - rkBhat(2)= -.1458793482962771337341223443218041d0 - rkBhat(3)= 2.390008682465139866479830743628554d0 - rkBhat(4)= -4.129393538556056674929560012190140d0 - rkBhat(5)= 0.d0 - - rkC(1) = .2666666666666666666666666666666667d0 - rkC(2) = .7666666666666666666666666666666667d0 - rkC(3) = .5666666666666666666666666666666667d0 - rkC(4) = .3661315380631796996374935266701191d0 - rkC(5) = 1.d0 - -! Ynew = Yold + h*Sum_i {rkB_i*k_i} = Yold + Sum_i {rkD_i*Z_i} - rkD(1) = 0.d0 - rkD(2) = 0.d0 - rkD(3) = 0.d0 - rkD(4) = 0.d0 - rkD(5) = 1.d0 - -! Err = h * Sum_i {(rkB_i-rkBhat_i)*k_i} = Sum_i {rkE_i*Z_i} - rkE(1) = -.6804000050475287124787034884002302d0 - rkE(2) = 1.558961944525217193393931795738823d0 - rkE(3) = -13.55893003128907927748632408763868d0 - rkE(4) = 15.48522576958521253098585004571302d0 - rkE(5) = 1.d0 - -! Local order of Err estimate - rkElo = 4 - -! h*Sum_j {rkA_ij*k_j} = Sum_j {rkTheta_ij*Z_j} - rkTheta(2,1) = 1.875000000000000000000000000000000d0 - rkTheta(3,1) = 1.708847304091539528432732316227462d0 - rkTheta(3,2) = -.2030773231622746185852981969486824d0 - rkTheta(4,1) = .2680325578937783958847157206823118d0 - rkTheta(4,2) = -.1828840955527181631794050728644549d0 - rkTheta(4,3) = .2968246986151577397160821594427966d0 - rkTheta(5,1) = .9096171815241460655379433581446771d0 - rkTheta(5,2) = -3.108254967778352416114774430509465d0 - rkTheta(5,3) = 12.33727431701306195581826123274001d0 - rkTheta(5,4) = -11.24557012450885560524143016037523d0 - -! Starting value for Newton iterations: Z_i^0 = Sum_j {rkAlpha_ij*Z_j} - rkAlpha(2,1) = 2.875000000000000000000000000000000d0 - rkAlpha(3,1) = .8500000000000000000000000000000000d0 - rkAlpha(3,2) = .4434782608695652173913043478260870d0 - rkAlpha(4,1) = .7352046091658870564637910527807370d0 - rkAlpha(4,2) = -.9525565003057343527941920657462074d-1 - rkAlpha(4,3) = .4290111305453813852259481840631738d0 - rkAlpha(5,1) = -16.10898993405067684831655675112808d0 - rkAlpha(5,2) = 6.559571569643355712998131800797873d0 - rkAlpha(5,3) = -15.90772144271326504260996815012482d0 - rkAlpha(5,4) = 25.34908987169226073668861694892683d0 - -!~~~> Coefficients for continuous solution -! rkD(1,1)= 24.74416644927758d0 -! rkD(1,2)= -4.325375951824688d0 -! rkD(1,3)= 41.39683763286316d0 -! rkD(1,4)= -61.04144619901784d0 -! rkD(1,5)= -3.391332232917013d0 -! rkD(2,1)= -51.98245719616925d0 -! rkD(2,2)= 10.52501981094525d0 -! rkD(2,3)= -154.2067922191855d0 -! rkD(2,4)= 214.3082125319825d0 -! rkD(2,5)= 14.71166018088679d0 -! rkD(3,1)= 33.14347947522142d0 -! rkD(3,2)= -19.72986789558523d0 -! rkD(3,3)= 230.4878502285804d0 -! rkD(3,4)= -287.6629744338197d0 -! rkD(3,5)= -18.99932366302254d0 -! rkD(4,1)= -5.905188728329743d0 -! rkD(4,2)= 13.53022403646467d0 -! rkD(4,3)= -117.6778956422581d0 -! rkD(4,4)= 134.3962081008550d0 -! rkD(4,5)= 8.678995715052762d0 -! -! DO i=1,4 ! CONTi <-- Sum_j rkD(i,j)*Zj -! CALL Set2zero(N,CONT(1,i)) -! DO j = 1,rkS -! CALL WAXPY(N,rkD(i,j),Z(1,j),1,CONT(1,i),1) -! END DO -! END DO - - rkELO = 4.0d0 - - END SUBROUTINE Sdirk4a - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Sdirk4b -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - sdMethod = S4B -! Number of stages - rkS = 5 - -! Method coefficients - rkGamma = .25d0 - - rkA(1,1) = 0.25d0 - rkA(2,1) = 0.5d00 - rkA(2,2) = 0.25d0 - rkA(3,1) = 0.34d0 - rkA(3,2) =-0.40d-1 - rkA(3,3) = 0.25d0 - rkA(4,1) = 0.2727941176470588235294117647058824d0 - rkA(4,2) =-0.5036764705882352941176470588235294d-1 - rkA(4,3) = 0.2757352941176470588235294117647059d-1 - rkA(4,4) = 0.25d0 - rkA(5,1) = 1.041666666666666666666666666666667d0 - rkA(5,2) =-1.020833333333333333333333333333333d0 - rkA(5,3) = 7.812500000000000000000000000000000d0 - rkA(5,4) =-7.083333333333333333333333333333333d0 - rkA(5,5) = 0.25d0 - - rkB(1) = 1.041666666666666666666666666666667d0 - rkB(2) = -1.020833333333333333333333333333333d0 - rkB(3) = 7.812500000000000000000000000000000d0 - rkB(4) = -7.083333333333333333333333333333333d0 - rkB(5) = 0.250000000000000000000000000000000d0 - - rkBhat(1)= 1.069791666666666666666666666666667d0 - rkBhat(2)= -0.894270833333333333333333333333333d0 - rkBhat(3)= 7.695312500000000000000000000000000d0 - rkBhat(4)= -7.083333333333333333333333333333333d0 - rkBhat(5)= 0.212500000000000000000000000000000d0 - - rkC(1) = 0.25d0 - rkC(2) = 0.75d0 - rkC(3) = 0.55d0 - rkC(4) = 0.50d0 - rkC(5) = 1.00d0 - -! Ynew = Yold + h*Sum_i {rkB_i*k_i} = Yold + Sum_i {rkD_i*Z_i} - rkD(1) = 0.0d0 - rkD(2) = 0.0d0 - rkD(3) = 0.0d0 - rkD(4) = 0.0d0 - rkD(5) = 1.0d0 - -! Err = h * Sum_i {(rkB_i-rkBhat_i)*k_i} = Sum_i {rkE_i*Z_i} - rkE(1) = 0.5750d0 - rkE(2) = 0.2125d0 - rkE(3) = -4.6875d0 - rkE(4) = 4.2500d0 - rkE(5) = 0.1500d0 - -! Local order of Err estimate - rkElo = 4 - -! h*Sum_j {rkA_ij*k_j} = Sum_j {rkTheta_ij*Z_j} - rkTheta(2,1) = 2.d0 - rkTheta(3,1) = 1.680000000000000000000000000000000d0 - rkTheta(3,2) = -.1600000000000000000000000000000000d0 - rkTheta(4,1) = 1.308823529411764705882352941176471d0 - rkTheta(4,2) = -.1838235294117647058823529411764706d0 - rkTheta(4,3) = 0.1102941176470588235294117647058824d0 - rkTheta(5,1) = -3.083333333333333333333333333333333d0 - rkTheta(5,2) = -4.291666666666666666666666666666667d0 - rkTheta(5,3) = 34.37500000000000000000000000000000d0 - rkTheta(5,4) = -28.33333333333333333333333333333333d0 - -! Starting value for Newton iterations: Z_i^0 = Sum_j {rkAlpha_ij*Z_j} - rkAlpha(2,1) = 3. - rkAlpha(3,1) = .8800000000000000000000000000000000d0 - rkAlpha(3,2) = .4400000000000000000000000000000000d0 - rkAlpha(4,1) = .1666666666666666666666666666666667d0 - rkAlpha(4,2) = -.8333333333333333333333333333333333d-1 - rkAlpha(4,3) = .9469696969696969696969696969696970d0 - rkAlpha(5,1) = -6.d0 - rkAlpha(5,2) = 9.d0 - rkAlpha(5,3) = -56.81818181818181818181818181818182d0 - rkAlpha(5,4) = 54.d0 - - END SUBROUTINE Sdirk4b - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Sdirk2a -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - sdMethod = S2A -! Number of stages - rkS = 2 - -! Method coefficients - rkGamma = .2928932188134524755991556378951510d0 - - rkA(1,1) = .2928932188134524755991556378951510d0 - rkA(2,1) = .7071067811865475244008443621048490d0 - rkA(2,2) = .2928932188134524755991556378951510d0 - - rkB(1) = .7071067811865475244008443621048490d0 - rkB(2) = .2928932188134524755991556378951510d0 - - rkBhat(1)= .6666666666666666666666666666666667d0 - rkBhat(2)= .3333333333333333333333333333333333d0 - - rkC(1) = 0.292893218813452475599155637895151d0 - rkC(2) = 1.0d0 - -! Ynew = Yold + h*Sum_i {rkB_i*k_i} = Yold + Sum_i {rkD_i*Z_i} - rkD(1) = 0.0d0 - rkD(2) = 1.0d0 - -! Err = h * Sum_i {(rkB_i-rkBhat_i)*k_i} = Sum_i {rkE_i*Z_i} - rkE(1) = 0.4714045207910316829338962414032326d0 - rkE(2) = -0.1380711874576983496005629080698993d0 - -! Local order of Err estimate - rkElo = 2 - -! h*Sum_j {rkA_ij*k_j} = Sum_j {rkTheta_ij*Z_j} - rkTheta(2,1) = 2.414213562373095048801688724209698d0 - -! Starting value for Newton iterations: Z_i^0 = Sum_j {rkAlpha_ij*Z_j} - rkAlpha(2,1) = 3.414213562373095048801688724209698d0 - - END SUBROUTINE Sdirk2a - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Sdirk2b -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - sdMethod = S2B -! Number of stages - rkS = 2 - -! Method coefficients - rkGamma = 1.707106781186547524400844362104849d0 - - rkA(1,1) = 1.707106781186547524400844362104849d0 - rkA(2,1) = -.707106781186547524400844362104849d0 - rkA(2,2) = 1.707106781186547524400844362104849d0 - - rkB(1) = -.707106781186547524400844362104849d0 - rkB(2) = 1.707106781186547524400844362104849d0 - - rkBhat(1)= .6666666666666666666666666666666667d0 - rkBhat(2)= .3333333333333333333333333333333333d0 - - rkC(1) = 1.707106781186547524400844362104849d0 - rkC(2) = 1.0d0 - -! Ynew = Yold + h*Sum_i {rkB_i*k_i} = Yold + Sum_i {rkD_i*Z_i} - rkD(1) = 0.0d0 - rkD(2) = 1.0d0 - -! Err = h * Sum_i {(rkB_i-rkBhat_i)*k_i} = Sum_i {rkE_i*Z_i} - rkE(1) = -.4714045207910316829338962414032326d0 - rkE(2) = .8047378541243650162672295747365659d0 - -! Local order of Err estimate - rkElo = 2 - -! h*Sum_j {rkA_ij*k_j} = Sum_j {rkTheta_ij*Z_j} - rkTheta(2,1) = -.414213562373095048801688724209698d0 - -! Starting value for Newton iterations: Z_i^0 = Sum_j {rkAlpha_ij*Z_j} - rkAlpha(2,1) = .5857864376269049511983112757903019d0 - - END SUBROUTINE Sdirk2b - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Sdirk3a -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - sdMethod = S3A -! Number of stages - rkS = 3 - -! Method coefficients - rkGamma = .2113248654051871177454256097490213d0 - - rkA(1,1) = .2113248654051871177454256097490213d0 - rkA(2,1) = .2113248654051871177454256097490213d0 - rkA(2,2) = .2113248654051871177454256097490213d0 - rkA(3,1) = .2113248654051871177454256097490213d0 - rkA(3,2) = .5773502691896257645091487805019573d0 - rkA(3,3) = .2113248654051871177454256097490213d0 - - rkB(1) = .2113248654051871177454256097490213d0 - rkB(2) = .5773502691896257645091487805019573d0 - rkB(3) = .2113248654051871177454256097490213d0 - - rkBhat(1)= .2113248654051871177454256097490213d0 - rkBhat(2)= .6477918909913548037576239837516312d0 - rkBhat(3)= .1408832436034580784969504064993475d0 - - rkC(1) = .2113248654051871177454256097490213d0 - rkC(2) = .4226497308103742354908512194980427d0 - rkC(3) = 1.d0 - -! Ynew = Yold + h*Sum_i {rkB_i*k_i} = Yold + Sum_i {rkD_i*Z_i} - rkD(1) = 0.d0 - rkD(2) = 0.d0 - rkD(3) = 1.d0 - -! Err = h * Sum_i {(rkB_i-rkBhat_i)*k_i} = Sum_i {rkE_i*Z_i} - rkE(1) = 0.9106836025229590978424821138352906d0 - rkE(2) = -1.244016935856292431175815447168624d0 - rkE(3) = 0.3333333333333333333333333333333333d0 - -! Local order of Err estimate - rkElo = 2 - -! h*Sum_j {rkA_ij*k_j} = Sum_j {rkTheta_ij*Z_j} - rkTheta(2,1) = 1.0d0 - rkTheta(3,1) = -1.732050807568877293527446341505872d0 - rkTheta(3,2) = 2.732050807568877293527446341505872d0 - -! Starting value for Newton iterations: Z_i^0 = Sum_j {rkAlpha_ij*Z_j} - rkAlpha(2,1) = 2.0d0 - rkAlpha(3,1) = -12.92820323027550917410978536602349d0 - rkAlpha(3,2) = 8.83012701892219323381861585376468d0 - - END SUBROUTINE Sdirk3a - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - END SUBROUTINE SDIRK_SOA ! AND ALL ITS INTERNAL PROCEDURES -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE FUN_CHEM( T, Y, P ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - USE KPP_ROOT_Parameters, ONLY: NVAR - USE KPP_ROOT_Global, ONLY: TIME, FIX, RCONST - USE KPP_ROOT_Function, ONLY: Fun - USE KPP_ROOT_Rates, ONLY: Update_SUN, Update_RCONST, Update_PHOTO - - KPP_REAL :: T, Told - KPP_REAL :: Y(NVAR), P(NVAR) - -! Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - - CALL Fun( Y, FIX, RCONST, P ) - -! TIME = Told - - END SUBROUTINE FUN_CHEM - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE JAC_CHEM( T, Y, JV ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - USE KPP_ROOT_Parameters, ONLY: NVAR, LU_NONZERO - USE KPP_ROOT_Global, ONLY: TIME, FIX, RCONST - USE KPP_ROOT_Jacobian, ONLY: Jac_SP,LU_IROW,LU_ICOL - USE KPP_ROOT_Rates, ONLY: Update_SUN, Update_RCONST, Update_PHOTO - - KPP_REAL :: T, Told - KPP_REAL :: Y(NVAR) -#ifdef FULL_ALGEBRA - KPP_REAL :: JS(LU_NONZERO), JV(NVAR,NVAR) - INTEGER :: i, j -#else - KPP_REAL :: JV(LU_NONZERO) -#endif - -! Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - -#ifdef FULL_ALGEBRA - CALL Jac_SP(Y, FIX, RCONST, JS) - DO j=1,NVAR - DO j=1,NVAR - JV(i,j) = 0.0d0 - END DO - END DO - DO i=1,LU_NONZERO - JV(LU_IROW(i),LU_ICOL(i)) = JS(i) - END DO -#else - CALL Jac_SP(Y, FIX, RCONST, JV) -#endif - -! TIME = Told - - END SUBROUTINE JAC_CHEM - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -SUBROUTINE HESS_CHEM( T, Y, Hes ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - USE KPP_ROOT_Rates, ONLY: Update_SUN, Update_RCONST, Update_PHOTO - -!~~~> Input variables - KPP_REAL, INTENT(IN) :: T, Y(NVAR) -!~~~> Output variables - KPP_REAL, INTENT(OUT) :: Hes(NHESS) -!~~~> Local variables - KPP_REAL :: Told - -! Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - - CALL Hessian( Y, FIX, RCONST, Hes ) - -! TIME = Told - -END SUBROUTINE HESS_CHEM - -END MODULE KPP_ROOT_Integrator - - diff --git a/boxmox/int/atm_lsodes.def b/boxmox/int/atm_lsodes.def deleted file mode 100644 index d5dade3324ccb5e9b35e7c2e693ad4d19ecd014a..0000000000000000000000000000000000000000 --- a/boxmox/int/atm_lsodes.def +++ /dev/null @@ -1,19 +0,0 @@ - -#FUNCTION AGGREGATE -#JACOBIAN FULL -#DOUBLE ON -#INTFILE atm_lsodes - -#INLINE F77_GLOBAL - REAL*8 STEPSTART - COMMON /GDATA/ STEPSTART -#ENDINLINE - -#INLINE F77_INIT - STEPMIN=1.D-12 - STEPMAX=3600. - STEPSTART=STEPMIN -#ENDINLINE - - - diff --git a/boxmox/int/atm_lsodes.f b/boxmox/int/atm_lsodes.f deleted file mode 100644 index 9602b277e3943d1087c74303351bb6d5723eabc1..0000000000000000000000000000000000000000 --- a/boxmox/int/atm_lsodes.f +++ /dev/null @@ -1,5474 +0,0 @@ - SUBROUTINE INTEGRATE( TIN, TOUT ) - - IMPLICIT KPP_REAL (A-H,O-Z) - INCLUDE 'KPP_ROOT_Parameters.h' - INCLUDE 'KPP_ROOT_Global.h' - -C TIN - Start Time - KPP_REAL TIN -C TOUT - End Time - KPP_REAL TOUT - - PARAMETER ( LRW=20+3*1500+16*NVAR ) - PARAMETER ( LIW=60 ) - EXTERNAL FUNC_CHEM, JAC_CHEM - - KPP_REAL RWORK(LRW) - INTEGER IWORK(LIW) - - STEPCUT = 0. - MAXORD = 5 - IBEGIN = 1 - ITOL=4 - -C ---- NORMAL COMPUTATION --- - ITASK=1 - ISTATE=1 -C ---- USE OPTIONAL INPUT --- - IOPT=1 - - IWORK(5) = MAXORD ! MAX ORD - IWORK(6) = 20000 - IWORK(7) = 0 - RWORK(6) = STEPMAX ! STEP MAX - RWORK(7) = STEPMIN ! STEP MIN - RWORK(5) = STEPMIN ! INITIAL STEP - -C ----- SIGNAL FOR STIFF CASE, FULL JACOBIAN, INTERN (22) or SUPPLIED (21) - MF = 121 - - CALL atmlsodes (FUNC_CHEM, NVAR, VAR, TIN, TOUT, ITOL, RTOL, ATOL, - ! ITASK, ISTATE, IOPT, RWORK, LRW, IWORK, LIW, - ! JAC_CHEM, MF) - - IF (ISTATE.LT.0) THEN - print *,'LSODES: Unsucessfull exit at T=', - & TIN,' (ISTATE=',ISTATE,')' - ENDIF - - RETURN - END - - subroutine atmlsodes (f, neq, y, t, tout, itol, RelTol, AbsTol, - 1 itask, istate, iopt, rwork, lrw, iwork, liw, jac, mf) - external f, jac - integer neq, itol, itask, istate, iopt, lrw, iwork, liw, mf - KPP_REAL y, t, tout, RelTol, AbsTol, rwork - dimension neq(1), y(1), RelTol(1), AbsTol(1), - 1 rwork(lrw), iwork(liw) -c----------------------------------------------------------------------- -c this is the march 30, 1987 version of -c lsodes.. livermore solver for ordinary differential equations -c with general sparse jacobian matrices. -c this version is in KPP_REAL. -c -c lsodes solves the initial value problem for stiff or nonstiff -c systems of first order ode-s, -c dy/dt = f(t,y) , or, in component form, -c dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(neq)) (i = 1,...,neq). -c lsodes is a variant of the lsode package, and is intended for -c problems in which the jacobian matrix df/dy has an arbitrary -c sparse structure (when the problem is stiff). -c -c authors.. alan c. hindmarsh, -c computing and mathematics research division, l-316 -c lawrence livermore national laboratory -c livermore, ca 94550. -c -c and andrew h. sherman -c j. s. nolen and associates -c houston, tx 77084 -c----------------------------------------------------------------------- -c references.. -c 1. alan c. hindmarsh, odepack, a systematized collection of ode -c solvers, in scientific computing, r. s. stepleman et al. (eds.), -c north-holland, amsterdam, 1983, pp. 55-64. -c -c 2. s. c. eisenstat, m. c. gursky, m. h. schultz, and a. h. sherman, -c yale sparse matrix package.. i. the symmetric codes, -c int. j. num. meth. eng., 18 (1982), pp. 1145-1151. -c -c 3. s. c. eisenstat, m. c. gursky, m. h. schultz, and a. h. sherman, -c yale sparse matrix package.. ii. the nonsymmetric codes, -c research report no. 114, dept. of computer sciences, yale -c university, 1977. -c----------------------------------------------------------------------- -c summary of usage. -c -c communication between the user and the lsodes package, for normal -c situations, is summarized here. this summary describes only a subset -c of the full set of options available. see the full description for -c details, including optional communication, nonstandard options, -c and instructions for special situations. see also the example -c problem (with program and output) following this summary. -c -c a. first provide a subroutine of the form.. -c subroutine f (neq, t, y, ydot) -c dimension y(neq), ydot(neq) -c which supplies the vector function f by loading ydot(i) with f(i). -c -c b. next determine (or guess) whether or not the problem is stiff. -c stiffness occurs when the jacobian matrix df/dy has an eigenvalue -c whose real part is negative and large in magnitude, compared to the -c reciprocal of the t span of interest. if the problem is nonstiff, -c use a method flag mf = 10. if it is stiff, there are two standard -c for the method flag, mf = 121 and mf = 222. in both cases, lsodes -c requires the jacobian matrix in some form, and it treats this matrix -c in general sparse form, with sparsity structure determined internally. -c (for options where the user supplies the sparsity structure, see -c the full description of mf below.) -c -c c. if the problem is stiff, you are encouraged to supply the jacobian -c directly (mf = 121), but if this is not feasible, lsodes will -c compute it internally by difference quotients (mf = 222). -c if you are supplying the jacobian, provide a subroutine of the form.. -c subroutine jac (neq, t, y, j, ian, jan, pdj) -c dimension y(1), ian(1), jan(1), pdj(1) -c here neq, t, y, and j are input arguments, and the jac routine is to -c load the array pdj (of length neq) with the j-th column of df/dy. -c i.e., load pdj(i) with df(i)/dy(j) for all relevant values of i. -c the arguments ian and jan should be ignored for normal situations. -c lsodes will CALL the jac routine with j = 1,2,...,neq. -c only nonzero elements need be loaded. usually, a crude approximation -c to df/dy, possibly with fewer nonzero elements, will suffice. -c -c d. write a main program which calls subroutine lsodes once for -c each point at which answers are desired. this should also provide -c for possible use of logical unit 6 for output of error messages -c by lsodes. on the first CALL to lsodes, supply arguments as follows.. -c f = name of subroutine for right-hand side vector f. -c this name must be declared external in calling program. -c neq = number of first order ode-s. -c y = array of initial values, of length neq. -c t = the initial value of the independent variable. -c tout = first point where output is desired (.ne. t). -c itol = 1 or 2 according as AbsTol (below) is a scalar or array. -c RelTol = relative tolerance parameter (scalar). -c AbsTol = absolute tolerance parameter (scalar or array). -c the estimated local error in y(i) will be controlled so as -c to be roughly less (in magnitude) than -c ewt(i) = RelTol*abs(y(i)) + AbsTol if itol = 1, or -c ewt(i) = RelTol*abs(y(i)) + AbsTol(i) if itol = 2. -c thus the local error test passes if, in each component, -c either the absolute error is less than AbsTol (or AbsTol(i)), -c or the relative error is less than RelTol. -c use RelTol = 0.0 for pure absolute error control, and -c use AbsTol = 0.0 (or AbsTol(i) = 0.0) for pure relative error -c control. caution.. actual (global) errors may exceed these -c local tolerances, so choose them conservatively. -c itask = 1 for normal computation of output values of y at t = tout. -c istate = integer flag (input and output). set istate = 1. -c iopt = 0 to indicate no optional inputs used. -c rwork = real work array of length at least.. -c 20 + 16*neq for mf = 10, -c 20 + (2 + 1./lenrat)*nnz + (11 + 9./lenrat)*neq -c for mf = 121 or 222, -c where.. -c nnz = the number of nonzero elements in the sparse -c jacobian (if this is unknown, use an estimate), and -c lenrat = the real to integer wordlength ratio (usually 1 in -c single precision and 2 in KPP_REAL). -c in any case, the required size of rwork cannot generally -c be predicted in advance if mf = 121 or 222, and the value -c above is a rough estimate of a crude lower bound. some -c experimentation with this size may be necessary. -c (when known, the correct required length is an optional -c output, available in iwork(17).) -c lrw = declared length of rwork (in user-s dimension). -c iwork = integer work array of length at least 30. -c liw = declared length of iwork (in user-s dimension). -c jac = name of subroutine for jacobian matrix (mf = 121). -c if used, this name must be declared external in calling -c program. if not used, pass a dummy name. -c mf = method flag. standard values are.. -c 10 for nonstiff (adams) method, no jacobian used. -c 121 for stiff (bdf) method, user-supplied sparse jacobian. -c 222 for stiff method, internally generated sparse jacobian. -c note that the main program must declare arrays y, rwork, iwork, -c and possibly AbsTol. -c -c e. the output from the first CALL (or any call) is.. -c y = array of computed values of y(t) vector. -c t = corresponding value of independent variable (normally tout). -c istate = 2 if lsodes was successful, negative otherwise. -c -1 means excess work done on this CALL (perhaps wrong mf). -c -2 means excess accuracy requested (tolerances too small). -c -3 means illegal input detected (see printed message). -c -4 means repeated error test failures (check all inputs). -c -5 means repeated convergence failures (perhaps bad jacobian -c supplied or wrong choice of mf or tolerances). -c -6 means error weight became zero during problem. (solution -c component i vanished, and AbsTol or AbsTol(i) = 0.) -c -7 means a fatal error return flag came from the sparse -c solver cdrv by way of prjs or slss. should never happen. -c a return with istate = -1, -4, or -5 may result from using -c an inappropriate sparsity structure, one that is quite -c different from the initial structure. consider calling -c lsodes again with istate = 3 to force the structure to be -c reevaluated. see the full description of istate below. -c -c f. to continue the integration after a successful return, simply -c reset tout and CALL lsodes again. no other parameters need be reset. -c -c----------------------------------------------------------------------- -c example problem. -c -c the following is a simple example problem, with the coding -c needed for its solution by lsodes. the problem is from chemical -c kinetics, and consists of the following 12 rate equations.. -c dy1/dt = -rk1*y1 -c dy2/dt = rk1*y1 + rk11*rk14*y4 + rk19*rk14*y5 -c - rk3*y2*y3 - rk15*y2*y12 - rk2*y2 -c dy3/dt = rk2*y2 - rk5*y3 - rk3*y2*y3 - rk7*y10*y3 -c + rk11*rk14*y4 + rk12*rk14*y6 -c dy4/dt = rk3*y2*y3 - rk11*rk14*y4 - rk4*y4 -c dy5/dt = rk15*y2*y12 - rk19*rk14*y5 - rk16*y5 -c dy6/dt = rk7*y10*y3 - rk12*rk14*y6 - rk8*y6 -c dy7/dt = rk17*y10*y12 - rk20*rk14*y7 - rk18*y7 -c dy8/dt = rk9*y10 - rk13*rk14*y8 - rk10*y8 -c dy9/dt = rk4*y4 + rk16*y5 + rk8*y6 + rk18*y7 -c dy10/dt = rk5*y3 + rk12*rk14*y6 + rk20*rk14*y7 -c + rk13*rk14*y8 - rk7*y10*y3 - rk17*y10*y12 -c - rk6*y10 - rk9*y10 -c dy11/dt = rk10*y8 -c dy12/dt = rk6*y10 + rk19*rk14*y5 + rk20*rk14*y7 -c - rk15*y2*y12 - rk17*y10*y12 -c -c with rk1 = rk5 = 0.1, rk4 = rk8 = rk16 = rk18 = 2.5, -c rk10 = 5.0, rk2 = rk6 = 10.0, rk14 = 30.0, -c rk3 = rk7 = rk9 = rk11 = rk12 = rk13 = rk19 = rk20 = 50.0, -c rk15 = rk17 = 100.0. -c -c the t interval is from 0 to 1000, and the initial conditions -c are y1 = 1, y2 = y3 = ... = y12 = 0. the problem is stiff. -c -c the following coding solves this problem with lsodes, using mf = 121 -c and printing results at t = .1, 1., 10., 100., 1000. it uses -c itol = 1 and mixed relative/absolute tolerance controls. -c during the run and at the end, statistical quantities of interest -c are printed (see optional outputs in the full description below). -c -c external fex, jex -c KPP_REAL AbsTol, RelTol, rwork, t, tout, y -c dimension y(12), rwork(500), iwork(30) -c data lrw/500/, liw/30/ -c neq = 12 -c do 10 i = 1,neq -c 10 y(i) = 0.0d0 -c y(1) = 1.0d0 -c t = 0.0d0 -c tout = 0.1d0 -c itol = 1 -c RelTol = 1.0d-4 -c AbsTol = 1.0d-6 -c itask = 1 -c istate = 1 -c iopt = 0 -c mf = 121 -c do 40 iout = 1,5 -c CALL lsodes (fex, neq, y, t, tout, itol, RelTol, AbsTol, -c 1 itask, istate, iopt, rwork, lrw, iwork, liw, jex, mf) -c write(6,30)t,iwork(11),rwork(11),(y(i),i=1,neq) -c 30 format(//7h at t =,e11.3,4x, -c 1 12h no. steps =,i5,4x,12h last step =,e11.3/ -c 2 13h y array = ,4e14.5/13x,4e14.5/13x,4e14.5) -c if (istate .lt. 0) go to 80 -c tout = tout*10.0d0 -c 40 continue -c lenrw = iwork(17) -c leniw = iwork(18) -c nst = iwork(11) -c nfe = iwork(12) -c nje = iwork(13) -c nlu = iwork(21) -c nnz = iwork(19) -c nnzlu = iwork(25) + iwork(26) + neq -c write (6,70) lenrw,leniw,nst,nfe,nje,nlu,nnz,nnzlu -c 70 format(//22h required rwork size =,i4,15h iwork size =,i4/ -c 1 12h no. steps =,i4,12h no. f-s =,i4,12h no. j-s =,i4, -c 2 13h no. lu-s =,i4/23h no. of nonzeros in j =,i5, -c 3 26h no. of nonzeros in lu =,i5) -c stop -c 80 write(6,90)istate -c 90 format(///22h error halt.. istate =,i3) -c stop -c end -c -c subroutine fex (neq, t, y, ydot) -c KPP_REAL t, y, ydot -c KPP_REAL rk1, rk2, rk3, rk4, rk5, rk6, rk7, rk8, rk9, -c 1 rk10, rk11, rk12, rk13, rk14, rk15, rk16, rk17 -c dimension y(12), ydot(12) -c data rk1/0.1d0/, rk2/10.0d0/, rk3/50.0d0/, rk4/2.5d0/, rk5/0.1d0/, -c 1 rk6/10.0d0/, rk7/50.0d0/, rk8/2.5d0/, rk9/50.0d0/, rk10/5.0d0/, -c 2 rk11/50.0d0/, rk12/50.0d0/, rk13/50.0d0/, rk14/30.0d0/, -c 3 rk15/100.0d0/, rk16/2.5d0/, rk17/100.0d0/, rk18/2.5d0/, -c 4 rk19/50.0d0/, rk20/50.0d0/ -c ydot(1) = -rk1*y(1) -c ydot(2) = rk1*y(1) + rk11*rk14*y(4) + rk19*rk14*y(5) -c 1 - rk3*y(2)*y(3) - rk15*y(2)*y(12) - rk2*y(2) -c ydot(3) = rk2*y(2) - rk5*y(3) - rk3*y(2)*y(3) - rk7*y(10)*y(3) -c 1 + rk11*rk14*y(4) + rk12*rk14*y(6) -c ydot(4) = rk3*y(2)*y(3) - rk11*rk14*y(4) - rk4*y(4) -c ydot(5) = rk15*y(2)*y(12) - rk19*rk14*y(5) - rk16*y(5) -c ydot(6) = rk7*y(10)*y(3) - rk12*rk14*y(6) - rk8*y(6) -c ydot(7) = rk17*y(10)*y(12) - rk20*rk14*y(7) - rk18*y(7) -c ydot(8) = rk9*y(10) - rk13*rk14*y(8) - rk10*y(8) -c ydot(9) = rk4*y(4) + rk16*y(5) + rk8*y(6) + rk18*y(7) -c ydot(10) = rk5*y(3) + rk12*rk14*y(6) + rk20*rk14*y(7) -c 1 + rk13*rk14*y(8) - rk7*y(10)*y(3) - rk17*y(10)*y(12) -c 2 - rk6*y(10) - rk9*y(10) -c ydot(11) = rk10*y(8) -c ydot(12) = rk6*y(10) + rk19*rk14*y(5) + rk20*rk14*y(7) -c 1 - rk15*y(2)*y(12) - rk17*y(10)*y(12) -c return -c end -c -c subroutine jex (neq, t, y, j, ia, ja, pdj) -c KPP_REAL t, y, pdj -c KPP_REAL rk1, rk2, rk3, rk4, rk5, rk6, rk7, rk8, rk9, -c 1 rk10, rk11, rk12, rk13, rk14, rk15, rk16, rk17 -c dimension y(1), ia(1), ja(1), pdj(1) -c data rk1/0.1d0/, rk2/10.0d0/, rk3/50.0d0/, rk4/2.5d0/, rk5/0.1d0/, -c 1 rk6/10.0d0/, rk7/50.0d0/, rk8/2.5d0/, rk9/50.0d0/, rk10/5.0d0/, -c 2 rk11/50.0d0/, rk12/50.0d0/, rk13/50.0d0/, rk14/30.0d0/, -c 3 rk15/100.0d0/, rk16/2.5d0/, rk17/100.0d0/, rk18/2.5d0/, -c 4 rk19/50.0d0/, rk20/50.0d0/ -c go to (1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12), j -c 1 pdj(1) = -rk1 -c pdj(2) = rk1 -c return -c 2 pdj(2) = -rk3*y(3) - rk15*y(12) - rk2 -c pdj(3) = rk2 - rk3*y(3) -c pdj(4) = rk3*y(3) -c pdj(5) = rk15*y(12) -c pdj(12) = -rk15*y(12) -c return -c 3 pdj(2) = -rk3*y(2) -c pdj(3) = -rk5 - rk3*y(2) - rk7*y(10) -c pdj(4) = rk3*y(2) -c pdj(6) = rk7*y(10) -c pdj(10) = rk5 - rk7*y(10) -c return -c 4 pdj(2) = rk11*rk14 -c pdj(3) = rk11*rk14 -c pdj(4) = -rk11*rk14 - rk4 -c pdj(9) = rk4 -c return -c 5 pdj(2) = rk19*rk14 -c pdj(5) = -rk19*rk14 - rk16 -c pdj(9) = rk16 -c pdj(12) = rk19*rk14 -c return -c 6 pdj(3) = rk12*rk14 -c pdj(6) = -rk12*rk14 - rk8 -c pdj(9) = rk8 -c pdj(10) = rk12*rk14 -c return -c 7 pdj(7) = -rk20*rk14 - rk18 -c pdj(9) = rk18 -c pdj(10) = rk20*rk14 -c pdj(12) = rk20*rk14 -c return -c 8 pdj(8) = -rk13*rk14 - rk10 -c pdj(10) = rk13*rk14 -c pdj(11) = rk10 -c 9 return -c 10 pdj(3) = -rk7*y(3) -c pdj(6) = rk7*y(3) -c pdj(7) = rk17*y(12) -c pdj(8) = rk9 -c pdj(10) = -rk7*y(3) - rk17*y(12) - rk6 - rk9 -c pdj(12) = rk6 - rk17*y(12) -c 11 return -c 12 pdj(2) = -rk15*y(2) -c pdj(5) = rk15*y(2) -c pdj(7) = rk17*y(10) -c pdj(10) = -rk17*y(10) -c pdj(12) = -rk15*y(2) - rk17*y(10) -c return -c end -c -c the output of this program (on a cray-1 in single precision) -c is as follows.. -c -c -c at t = 1.000e-01 no. steps = 12 last step = 1.515e-02 -c y array = 9.90050e-01 6.28228e-03 3.65313e-03 7.51934e-07 -c 1.12167e-09 1.18458e-09 1.77291e-12 3.26476e-07 -c 5.46720e-08 9.99500e-06 4.48483e-08 2.76398e-06 -c -c -c at t = 1.000e+00 no. steps = 33 last step = 7.880e-02 -c y array = 9.04837e-01 9.13105e-03 8.20622e-02 2.49177e-05 -c 1.85055e-06 1.96797e-06 1.46157e-07 2.39557e-05 -c 3.26306e-05 7.21621e-04 5.06433e-05 3.05010e-03 -c -c -c at t = 1.000e+01 no. steps = 48 last step = 1.239e+00 -c y array = 3.67876e-01 3.68958e-03 3.65133e-01 4.48325e-05 -c 6.10798e-05 4.33148e-05 5.90211e-05 1.18449e-04 -c 3.15235e-03 3.56531e-03 4.15520e-03 2.48741e-01 -c -c -c at t = 1.000e+02 no. steps = 91 last step = 3.764e+00 -c y array = 4.44981e-05 4.42666e-07 4.47273e-04 -3.53257e-11 -c 2.81577e-08 -9.67741e-11 2.77615e-07 1.45322e-07 -c 1.56230e-02 4.37394e-06 1.60104e-02 9.52246e-01 -c -c -c at t = 1.000e+03 no. steps = 111 last step = 4.156e+02 -c y array = -2.65492e-13 2.60539e-14 -8.59563e-12 6.29355e-14 -c -1.78066e-13 5.71471e-13 -1.47561e-12 4.58078e-15 -c 1.56314e-02 1.37878e-13 1.60184e-02 9.52719e-01 -c -c -c required rwork size = 442 iwork size = 30 -c no. steps = 111 no. f-s = 142 no. j-s = 2 no. lu-s = 20 -c no. of nonzeros in j = 44 no. of nonzeros in lu = 50 -c----------------------------------------------------------------------- -c full description of user interface to lsodes. -c -c the user interface to lsodes consists of the following parts. -c -c i. the CALL sequence to subroutine lsodes, which is a driver -c routine for the solver. this includes descriptions of both -c the CALL sequence arguments and of user-supplied routines. -c following these descriptions is a description of -c optional inputs available through the CALL sequence, and then -c a description of optional outputs (in the work arrays). -c -c ii. descriptions of other routines in the lsodes package that may be -c (optionally) called by the user. these provide the ability to -c alter error message handling, save and restore the internal -c common, and obtain specified derivatives of the solution y(t). -c -c iii. descriptions of common blocks to be declared in overlay -c or similar environments, or to be saved when doing an interrupt -c of the problem and continued solution later. -c -c iv. description of two routines in the lsodes package, either of -c which the user may replace with his own version, if desired. -c these relate to the measurement of errors. -c -c----------------------------------------------------------------------- -c part i. CALL sequence. -c -c the CALL sequence parameters used for input only are -c f, neq, tout, itol, RelTol, AbsTol, itask, iopt, lrw, liw, jac, mf, -c and those used for both input and output are -c y, t, istate. -c the work arrays rwork and iwork are also used for conditional and -c optional inputs and optional outputs. (the term output here refers -c to the return from subroutine lsodes to the user-s calling program.) -c -c the legality of input parameters will be thoroughly checked on the -c initial CALL for the problem, but not checked thereafter unless a -c change in input parameters is flagged by istate = 3 on input. -c -c the descriptions of the CALL arguments are as follows. -c -c f = the name of the user-supplied subroutine defining the -c ode system. the system must be put in the first-order -c form dy/dt = f(t,y), where f is a vector-valued function -c of the scalar t and the vector y. subroutine f is to -c compute the function f. it is to have the form -c subroutine f (neq, t, y, ydot) -c dimension y(1), ydot(1) -c where neq, t, and y are input, and the array ydot = f(t,y) -c is output. y and ydot are arrays of length neq. -c (in the dimension statement above, 1 is a dummy -c dimension.. it can be replaced by any value.) -c subroutine f should not alter y(1),...,y(neq). -c f must be declared external in the calling program. -c -c subroutine f may access user-defined quantities in -c neq(2),... and/or in y(neq(1)+1),... if neq is an array -c (dimensioned in f) and/or y has length exceeding neq(1). -c see the descriptions of neq and y below. -c -c if quantities computed in the f routine are needed -c externally to lsodes, an extra CALL to f should be made -c for this purpose, for consistent and accurate results. -c if only the derivative dy/dt is needed, use intdy instead. -c -c neq = the size of the ode system (number of first order -c ordinary differential equations). used only for input. -c neq may be decreased, but not increased, during the problem. -c if neq is decreased (with istate = 3 on input), the -c remaining components of y should be left undisturbed, if -c these are to be accessed in f and/or jac. -c -c normally, neq is a scalar, and it is generally referred to -c as a scalar in this user interface description. however, -c neq may be an array, with neq(1) set to the system size. -c (the lsodes package accesses only neq(1).) in either case, -c this parameter is passed as the neq argument in all calls -c to f and jac. hence, if it is an array, locations -c neq(2),... may be used to store other integer data and pass -c it to f and/or jac. subroutines f and/or jac must include -c neq in a dimension statement in that case. -c -c y = a real array for the vector of dependent variables, of -c length neq or more. used for both input and output on the -c first CALL (istate = 1), and only for output on other calls. -c on the first call, y must contain the vector of initial -c values. on output, y contains the computed solution vector, -c evaluated at t. if desired, the y array may be used -c for other purposes between calls to the solver. -c -c this array is passed as the y argument in all calls to -c f and jac. hence its length may exceed neq, and locations -c y(neq+1),... may be used to store other real data and -c pass it to f and/or jac. (the lsodes package accesses only -c y(1),...,y(neq).) -c -c t = the independent variable. on input, t is used only on the -c first call, as the initial point of the integration. -c on output, after each call, t is the value at which a -c computed solution y is evaluated (usually the same as tout). -c on an error return, t is the farthest point reached. -c -c tout = the next value of t at which a computed solution is desired. -c used only for input. -c -c when starting the problem (istate = 1), tout may be equal -c to t for one call, then should .ne. t for the next call. -c for the initial t, an input value of tout .ne. t is used -c in order to determine the direction of the integration -c (i.e. the algebraic sign of the step sizes) and the rough -c scale of the problem. integration in either direction -c (forward or backward in t) is permitted. -c -c if itask = 2 or 5 (one-step modes), tout is ignored after -c the first CALL (i.e. the first CALL with tout .ne. t). -c otherwise, tout is required on every call. -c -c if itask = 1, 3, or 4, the values of tout need not be -c monotone, but a value of tout which backs up is limited -c to the current internal t interval, whose endpoints are -c tcur - hu and tcur (see optional outputs, below, for -c tcur and hu). -c -c itol = an indicator for the type of error control. see -c description below under AbsTol. used only for input. -c -c RelTol = a relative error tolerance parameter, either a scalar or -c an array of length neq. see description below under AbsTol. -c input only. -c -c AbsTol = an absolute error tolerance parameter, either a scalar or -c an array of length neq. input only. -c -c the input parameters itol, RelTol, and AbsTol determine -c the error control performed by the solver. the solver will -c control the vector e = (e(i)) of estimated local errors -c in y, according to an inequality of the form -c rms-norm of ( e(i)/ewt(i) ) .le. 1, -c where ewt(i) = RelTol(i)*abs(y(i)) + AbsTol(i), -c and the rms-norm (root-mean-square norm) here is -c rms-norm(v) = sqrt(sum v(i)**2 / neq). here ewt = (ewt(i)) -c is a vector of weights which must always be positive, and -c the values of RelTol and AbsTol should all be non-negative. -c the following table gives the types (scalar/array) of -c RelTol and AbsTol, and the corresponding form of ewt(i). -c -c itol RelTol AbsTol ewt(i) -c 1 scalar scalar RelTol*abs(y(i)) + AbsTol -c 2 scalar array RelTol*abs(y(i)) + AbsTol(i) -c 3 array scalar RelTol(i)*abs(y(i)) + AbsTol -c 4 array array RelTol(i)*abs(y(i)) + AbsTol(i) -c -c when either of these parameters is a scalar, it need not -c be dimensioned in the user-s calling program. -c -c if none of the above choices (with itol, RelTol, and AbsTol -c fixed throughout the problem) is suitable, more general -c error controls can be obtained by substituting -c user-supplied routines for the setting of ewt and/or for -c the norm calculation. see part iv below. -c -c if global errors are to be estimated by making a repeated -c run on the same problem with smaller tolerances, then all -c components of RelTol and AbsTol (i.e. of ewt) should be scaled -c down uniformly. -c -c itask = an index specifying the task to be performed. -c input only. itask has the following values and meanings. -c 1 means normal computation of output values of y(t) at -c t = tout (by overshooting and interpolating). -c 2 means take one step only and return. -c 3 means stop at the first internal mesh point at or -c beyond t = tout and return. -c 4 means normal computation of output values of y(t) at -c t = tout but without overshooting t = tcrit. -c tcrit must be input as rwork(1). tcrit may be equal to -c or beyond tout, but not behind it in the direction of -c integration. this option is useful if the problem -c has a singularity at or beyond t = tcrit. -c 5 means take one step, without passing tcrit, and return. -c tcrit must be input as rwork(1). -c -c note.. if itask = 4 or 5 and the solver reaches tcrit -c (within roundoff), it will return t = tcrit (exactly) to -c indicate this (unless itask = 4 and tout comes before tcrit, -c in which case answers at t = tout are returned first). -c -c istate = an index used for input and output to specify the -c the state of the calculation. -c -c on input, the values of istate are as follows. -c 1 means this is the first CALL for the problem -c (initializations will be done). see note below. -c 2 means this is not the first call, and the calculation -c is to continue normally, with no change in any input -c parameters except possibly tout and itask. -c (if itol, RelTol, and/or AbsTol are changed between calls -c with istate = 2, the new values will be used but not -c tested for legality.) -c 3 means this is not the first call, and the -c calculation is to continue normally, but with -c a change in input parameters other than -c tout and itask. changes are allowed in -c neq, itol, RelTol, AbsTol, iopt, lrw, liw, mf, -c the conditional inputs ia and ja, -c and any of the optional inputs except h0. -c in particular, if miter = 1 or 2, a CALL with istate = 3 -c will cause the sparsity structure of the problem to be -c recomputed (or reread from ia and ja if moss = 0). -c note.. a preliminary CALL with tout = t is not counted -c as a first CALL here, as no initialization or checking of -c input is done. (such a CALL is sometimes useful for the -c purpose of outputting the initial conditions.) -c thus the first CALL for which tout .ne. t requires -c istate = 1 on input. -c -c on output, istate has the following values and meanings. -c 1 means nothing was done, as tout was equal to t with -c istate = 1 on input. (however, an internal counter was -c set to detect and prevent repeated calls of this type.) -c 2 means the integration was performed successfully. -c -1 means an excessive amount of work (more than mxstep -c steps) was done on this call, before completing the -c requested task, but the integration was otherwise -c successful as far as t. (mxstep is an optional input -c and is normally 500.) to continue, the user may -c simply reset istate to a value .gt. 1 and CALL again -c (the excess work step counter will be reset to 0). -c in addition, the user may increase mxstep to avoid -c this error return (see below on optional inputs). -c -2 means too much accuracy was requested for the precision -c of the machine being used. this was detected before -c completing the requested task, but the integration -c was successful as far as t. to continue, the tolerance -c parameters must be reset, and istate must be set -c to 3. the optional output tolsf may be used for this -c purpose. (note.. if this condition is detected before -c taking any steps, then an illegal input return -c (istate = -3) occurs instead.) -c -3 means illegal input was detected, before taking any -c integration steps. see written message for details. -c note.. if the solver detects an infinite loop of calls -c to the solver with illegal input, it will cause -c the run to stop. -c -4 means there were repeated error test failures on -c one attempted step, before completing the requested -c task, but the integration was successful as far as t. -c the problem may have a singularity, or the input -c may be inappropriate. -c -5 means there were repeated convergence test failures on -c one attempted step, before completing the requested -c task, but the integration was successful as far as t. -c this may be caused by an inaccurate jacobian matrix, -c if one is being used. -c -6 means ewt(i) became zero for some i during the -c integration. pure relative error control (AbsTol(i)=0.0) -c was requested on a variable which has now vanished. -c the integration was successful as far as t. -c -7 means a fatal error return flag came from the sparse -c solver cdrv by way of prjs or slss (numerical -c factorization or backsolve). this should never happen. -c the integration was successful as far as t. -c -c note.. an error return with istate = -1, -4, or -5 and with -c miter = 1 or 2 may mean that the sparsity structure of the -c problem has changed significantly since it was last -c determined (or input). in that case, one can attempt to -c complete the integration by setting istate = 3 on the next -c call, so that a new structure determination is done. -c -c note.. since the normal output value of istate is 2, -c it does not need to be reset for normal continuation. -c also, since a negative input value of istate will be -c regarded as illegal, a negative output value requires the -c user to change it, and possibly other inputs, before -c calling the solver again. -c -c iopt = an integer flag to specify whether or not any optional -c inputs are being used on this call. input only. -c the optional inputs are listed separately below. -c iopt = 0 means no optional inputs are being used. -c default values will be used in all cases. -c iopt = 1 means one or more optional inputs are being used. -c -c rwork = a work array used for a mixture of real (KPP_REAL) -c and integer work space. -c the length of rwork (in real words) must be at least -c 20 + nyh*(maxord + 1) + 3*neq + lwm where -c nyh = the initial value of neq, -c maxord = 12 (if meth = 1) or 5 (if meth = 2) (unless a -c smaller value is given as an optional input), -c lwm = 0 if miter = 0, -c lwm = 2*nnz + 2*neq + (nnz+9*neq)/lenrat if miter = 1, -c lwm = 2*nnz + 2*neq + (nnz+10*neq)/lenrat if miter = 2, -c lwm = neq + 2 if miter = 3. -c in the above formulas, -c nnz = number of nonzero elements in the jacobian matrix. -c lenrat = the real to integer wordlength ratio (usually 1 in -c single precision and 2 in KPP_REAL). -c (see the mf description for meth and miter.) -c thus if maxord has its default value and neq is constant, -c the minimum length of rwork is.. -c 20 + 16*neq for mf = 10, -c 20 + 16*neq + lwm for mf = 11, 111, 211, 12, 112, 212, -c 22 + 17*neq for mf = 13, -c 20 + 9*neq for mf = 20, -c 20 + 9*neq + lwm for mf = 21, 121, 221, 22, 122, 222, -c 22 + 10*neq for mf = 23. -c if miter = 1 or 2, the above formula for lwm is only a -c crude lower bound. the required length of rwork cannot -c be readily predicted in general, as it depends on the -c sparsity structure of the problem. some experimentation -c may be necessary. -c -c the first 20 words of rwork are reserved for conditional -c and optional inputs and optional outputs. -c -c the following word in rwork is a conditional input.. -c rwork(1) = tcrit = critical value of t which the solver -c is not to overshoot. required if itask is -c 4 or 5, and ignored otherwise. (see itask.) -c -c lrw = the length of the array rwork, as declared by the user. -c (this will be checked by the solver.) -c -c iwork = an integer work array. the length of iwork must be at least -c 31 + neq + nnz if moss = 0 and miter = 1 or 2, or -c 30 otherwise. -c (nnz is the number of nonzero elements in df/dy.) -c -c in lsodes, iwork is used only for conditional and -c optional inputs and optional outputs. -c -c the following two blocks of words in iwork are conditional -c inputs, required if moss = 0 and miter = 1 or 2, but not -c otherwise (see the description of mf for moss). -c iwork(30+j) = ia(j) (j=1,...,neq+1) -c iwork(31+neq+k) = ja(k) (k=1,...,nnz) -c the two arrays ia and ja describe the sparsity structure -c to be assumed for the jacobian matrix. ja contains the row -c indices where nonzero elements occur, reading in columnwise -c order, and ia contains the starting locations in ja of the -c descriptions of columns 1,...,neq, in that order, with -c ia(1) = 1. thus, for each column index j = 1,...,neq, the -c values of the row index i in column j where a nonzero -c element may occur are given by -c i = ja(k), where ia(j) .le. k .lt. ia(j+1). -c if nnz is the total number of nonzero locations assumed, -c then the length of the ja array is nnz, and ia(neq+1) must -c be nnz + 1. duplicate entries are not allowed. -c -c liw = the length of the array iwork, as declared by the user. -c (this will be checked by the solver.) -c -c note.. the work arrays must not be altered between calls to lsodes -c for the same problem, except possibly for the conditional and -c optional inputs, and except for the last 3*neq words of rwork. -c the latter space is used for internal scratch space, and so is -c available for use by the user outside lsodes between calls, if -c desired (but not for use by f or jac). -c -c jac = name of user-supplied routine (miter = 1 or moss = 1) to -c compute the jacobian matrix, df/dy, as a function of -c the scalar t and the vector y. it is to have the form -c subroutine jac (neq, t, y, j, ian, jan, pdj) -c dimension y(1), ian(1), jan(1), pdj(1) -c where neq, t, y, j, ian, and jan are input, and the array -c pdj, of length neq, is to be loaded with column j -c of the jacobian on output. thus df(i)/dy(j) is to be -c loaded into pdj(i) for all relevant values of i. -c here t and y have the same meaning as in subroutine f, -c and j is a column index (1 to neq). ian and jan are -c undefined in calls to jac for structure determination -c (moss = 1). otherwise, ian and jan are structure -c descriptors, as defined under optional outputs below, and -c so can be used to determine the relevant row indices i, if -c desired. (in the dimension statement above, 1 is a -c dummy dimension.. it can be replaced by any value.) -c jac need not provide df/dy exactly. a crude -c approximation (possibly with greater sparsity) will do. -c in any case, pdj is preset to zero by the solver, -c so that only the nonzero elements need be loaded by jac. -c calls to jac are made with j = 1,...,neq, in that order, and -c each such set of calls is preceded by a CALL to f with the -c same arguments neq, t, and y. thus to gain some efficiency, -c intermediate quantities shared by both calculations may be -c saved in a user common block by f and not recomputed by jac, -c if desired. jac must not alter its input arguments. -c jac must be declared external in the calling program. -c subroutine jac may access user-defined quantities in -c neq(2),... and y(neq(1)+1),... if neq is an array -c (dimensioned in jac) and y has length exceeding neq(1). -c see the descriptions of neq and y above. -c -c mf = the method flag. used only for input. -c mf has three decimal digits-- moss, meth, miter-- -c mf = 100*moss + 10*meth + miter. -c moss indicates the method to be used to obtain the sparsity -c structure of the jacobian matrix if miter = 1 or 2.. -c moss = 0 means the user has supplied ia and ja -c (see descriptions under iwork above). -c moss = 1 means the user has supplied jac (see below) -c and the structure will be obtained from neq -c initial calls to jac. -c moss = 2 means the structure will be obtained from neq+1 -c initial calls to f. -c meth indicates the basic linear multistep method.. -c meth = 1 means the implicit adams method. -c meth = 2 means the method based on backward -c differentiation formulas (bdf-s). -c miter indicates the corrector iteration method.. -c miter = 0 means functional iteration (no jacobian matrix -c is involved). -c miter = 1 means chord iteration with a user-supplied -c sparse jacobian, given by subroutine jac. -c miter = 2 means chord iteration with an internally -c generated (difference quotient) sparse jacobian -c (using ngp extra calls to f per df/dy value, -c where ngp is an optional output described below.) -c miter = 3 means chord iteration with an internally -c generated diagonal jacobian approximation. -c (using 1 extra CALL to f per df/dy evaluation). -c if miter = 1 or moss = 1, the user must supply a subroutine -c jac (the name is arbitrary) as described above under jac. -c otherwise, a dummy argument can be used. -c -c the standard choices for mf are.. -c mf = 10 for a nonstiff problem, -c mf = 21 or 22 for a stiff problem with ia/ja supplied -c (21 if jac is supplied, 22 if not), -c mf = 121 for a stiff problem with jac supplied, -c but not ia/ja, -c mf = 222 for a stiff problem with neither ia/ja nor -c jac supplied. -c the sparseness structure can be changed during the -c problem by making a CALL to lsodes with istate = 3. -c----------------------------------------------------------------------- -c optional inputs. -c -c the following is a list of the optional inputs provided for in the -c CALL sequence. (see also part ii.) for each such input variable, -c this table lists its name as used in this documentation, its -c location in the CALL sequence, its meaning, and the default value. -c the use of any of these inputs requires iopt = 1, and in that -c case all of these inputs are examined. a value of zero for any -c of these optional inputs will cause the default value to be used. -c thus to use a subset of the optional inputs, simply preload -c locations 5 to 10 in rwork and iwork to 0.0 and 0 respectively, and -c then set those of interest to nonzero values. -c -c name location meaning and default value -c -c h0 rwork(5) the step size to be attempted on the first step. -c the default value is determined by the solver. -c -c hmax rwork(6) the maximum absolute step size allowed. -c the default value is infinite. -c -c hmin rwork(7) the minimum absolute step size allowed. -c the default value is 0. (this lower bound is not -c enforced on the final step before reaching tcrit -c when itask = 4 or 5.) -c -c seth rwork(8) the element threshhold for sparsity determination -c when moss = 1 or 2. if the absolute value of -c an estimated jacobian element is .le. seth, it -c will be assumed to be absent in the structure. -c the default value of seth is 0. -c -c maxord iwork(5) the maximum order to be allowed. the default -c value is 12 if meth = 1, and 5 if meth = 2. -c if maxord exceeds the default value, it will -c be reduced to the default value. -c if maxord is changed during the problem, it may -c cause the current order to be reduced. -c -c mxstep iwork(6) maximum number of (internally defined) steps -c allowed during one CALL to the solver. -c the default value is 500. -c -c mxhnil iwork(7) maximum number of messages printed (per problem) -c warning that t + h = t on a step (h = step size). -c this must be positive to result in a non-default -c value. the default value is 10. -c----------------------------------------------------------------------- -c optional outputs. -c -c as optional additional output from lsodes, the variables listed -c below are quantities related to the performance of lsodes -c which are available to the user. these are communicated by way of -c the work arrays, but also have internal mnemonic names as shown. -c except where stated otherwise, all of these outputs are defined -c on any successful return from lsodes, and on any return with -c istate = -1, -2, -4, -5, or -6. on an illegal input return -c (istate = -3), they will be unchanged from their existing values -c (if any), except possibly for tolsf, lenrw, and leniw. -c on any error return, outputs relevant to the error will be defined, -c as noted below. -c -c name location meaning -c -c hu rwork(11) the step size in t last used (successfully). -c -c hcur rwork(12) the step size to be attempted on the next step. -c -c tcur rwork(13) the current value of the independent variable -c which the solver has actually reached, i.e. the -c current internal mesh point in t. on output, tcur -c will always be at least as far as the argument -c t, but may be farther (if interpolation was done). -c -c tolsf rwork(14) a tolerance scale factor, greater than 1.0, -c computed when a request for too much accuracy was -c detected (istate = -3 if detected at the start of -c the problem, istate = -2 otherwise). if itol is -c left unaltered but RelTol and AbsTol are uniformly -c scaled up by a factor of tolsf for the next call, -c then the solver is deemed likely to succeed. -c (the user may also ignore tolsf and alter the -c tolerance parameters in any other way appropriate.) -c -c nst iwork(11) the number of steps taken for the problem so far. -c -c nfe iwork(12) the number of f evaluations for the problem so far, -c excluding those for structure determination -c (moss = 2). -c -c nje iwork(13) the number of jacobian evaluations for the problem -c so far, excluding those for structure determination -c (moss = 1). -c -c nqu iwork(14) the method order last used (successfully). -c -c nqcur iwork(15) the order to be attempted on the next step. -c -c imxer iwork(16) the index of the component of largest magnitude in -c the weighted local error vector ( e(i)/ewt(i) ), -c on an error return with istate = -4 or -5. -c -c lenrw iwork(17) the length of rwork actually required. -c this is defined on normal returns and on an illegal -c input return for insufficient storage. -c -c leniw iwork(18) the length of iwork actually required. -c this is defined on normal returns and on an illegal -c input return for insufficient storage. -c -c nnz iwork(19) the number of nonzero elements in the jacobian -c matrix, including the diagonal (miter = 1 or 2). -c (this may differ from that given by ia(neq+1)-1 -c if moss = 0, because of added diagonal entries.) -c -c ngp iwork(20) the number of groups of column indices, used in -c difference quotient jacobian aproximations if -c miter = 2. this is also the number of extra f -c evaluations needed for each jacobian evaluation. -c -c nlu iwork(21) the number of sparse lu decompositions for the -c problem so far. -c -c lyh iwork(22) the base address in rwork of the history array yh, -c described below in this list. -c -c ipian iwork(23) the base address of the structure descriptor array -c ian, described below in this list. -c -c ipjan iwork(24) the base address of the structure descriptor array -c jan, described below in this list. -c -c nzl iwork(25) the number of nonzero elements in the strict lower -c triangle of the lu factorization used in the chord -c iteration (miter = 1 or 2). -c -c nzu iwork(26) the number of nonzero elements in the strict upper -c triangle of the lu factorization used in the chord -c iteration (miter = 1 or 2). -c the total number of nonzeros in the factorization -c is therefore nzl + nzu + neq. -c -c the following four arrays are segments of the rwork array which -c may also be of interest to the user as optional outputs. -c for each array, the table below gives its internal name, -c its base address, and its description. -c for yh and acor, the base addresses are in rwork (a real array). -c the integer arrays ian and jan are to be obtained by declaring an -c integer array iwk and identifying iwk(1) with rwork(21), using either -c an equivalence statement or a subroutine call. then the base -c addresses ipian (of ian) and ipjan (of jan) in iwk are to be obtained -c as optional outputs iwork(23) and iwork(24), respectively. -c thus ian(1) is iwk(ipian), etc. -c -c name base address description -c -c ian ipian (in iwk) structure descriptor array of size neq + 1. -c jan ipjan (in iwk) structure descriptor array of size nnz. -c (see above) ian and jan together describe the sparsity -c structure of the jacobian matrix, as used by -c lsodes when miter = 1 or 2. -c jan contains the row indices of the nonzero -c locations, reading in columnwise order, and -c ian contains the starting locations in jan of -c the descriptions of columns 1,...,neq, in -c that order, with ian(1) = 1. thus for each -c j = 1,...,neq, the row indices i of the -c nonzero locations in column j are -c i = jan(k), ian(j) .le. k .lt. ian(j+1). -c note that ian(neq+1) = nnz + 1. -c (if moss = 0, ian/jan may differ from the -c input ia/ja because of a different ordering -c in each column, and added diagonal entries.) -c -c yh lyh the nordsieck history array, of size nyh by -c (optional (nqcur + 1), where nyh is the initial value -c output) of neq. for j = 0,1,...,nqcur, column j+1 -c of yh contains hcur**j/factorial(j) times -c the j-th derivative of the interpolating -c polynomial currently representing the solution, -c evaluated at t = tcur. the base address lyh -c is another optional output, listed above. -c -c acor lenrw-neq+1 array of size neq used for the accumulated -c corrections on each step, scaled on output -c to represent the estimated local error in y -c on the last step. this is the vector e in -c the description of the error control. it is -c defined only on a successful return from -c lsodes. -c -c----------------------------------------------------------------------- -c part ii. other routines callable. -c -c the following are optional calls which the user may make to -c gain additional capabilities in conjunction with lsodes. -c (the routines xsetun and xsetf are designed to conform to the -c slatec error handling package.) -c -c form of CALL function -c CALL xsetun(lun) set the logical unit number, lun, for -c output of messages from lsodes, if -c the default is not desired. -c the default value of lun is 6. -c -c CALL xsetf(mflag) set a flag to control the printing of -c messages by lsodes. -c mflag = 0 means do not print. (danger.. -c this risks losing valuable information.) -c mflag = 1 means print (the default). -c -c either of the above calls may be made at -c any time and will take effect immediately. -c -c CALL srcms(rsav,isav,job) saves and restores the contents of -c the internal common blocks used by -c lsodes (see part iii below). -c rsav must be a real array of length 224 -c or more, and isav must be an integer -c array of length 75 or more. -c job=1 means save common into rsav/isav. -c job=2 means restore common from rsav/isav. -c srcms is useful if one is -c interrupting a run and restarting -c later, or alternating between two or -c more problems solved with lsodes. -c -c CALL intdy(,,,,,) provide derivatives of y, of various -c (see below) orders, at a specified point t, if -c desired. it may be called only after -c a successful return from lsodes. -c -c the detailed instructions for using intdy are as follows. -c the form of the CALL is.. -c -c lyh = iwork(22) -c CALL intdy (t, k, rwork(lyh), nyh, dky, iflag) -c -c the input parameters are.. -c -c t = value of independent variable where answers are desired -c (normally the same as the t last returned by lsodes). -c for valid results, t must lie between tcur - hu and tcur. -c (see optional outputs for tcur and hu.) -c k = integer order of the derivative desired. k must satisfy -c 0 .le. k .le. nqcur, where nqcur is the current order -c (see optional outputs). the capability corresponding -c to k = 0, i.e. computing y(t), is already provided -c by lsodes directly. since nqcur .ge. 1, the first -c derivative dy/dt is always available with intdy. -c lyh = the base address of the history array yh, obtained -c as an optional output as shown above. -c nyh = column length of yh, equal to the initial value of neq. -c -c the output parameters are.. -c -c dky = a real array of length neq containing the computed value -c of the k-th derivative of y(t). -c iflag = integer flag, returned as 0 if k and t were legal, -c -1 if k was illegal, and -2 if t was illegal. -c on an error return, a message is also written. -c----------------------------------------------------------------------- -c part iii. common blocks. -c -c if lsodes is to be used in an overlay situation, the user -c must declare, in the primary overlay, the variables in.. -c (1) the CALL sequence to lsodes, -c (2) the three internal common blocks -c /ls0001/ of length 257 (218 KPP_REAL words -c followed by 39 integer words), -c /lss001/ of length 40 ( 6 KPP_REAL words -c followed by 34 integer words), -c /eh0001/ of length 2 (integer words). -c -c if lsodes is used on a system in which the contents of internal -c common blocks are not preserved between calls, the user should -c declare the above three common blocks in his main program to insure -c that their contents are preserved. -c -c if the solution of a given problem by lsodes is to be interrupted -c and then later continued, such as when restarting an interrupted run -c or alternating between two or more problems, the user should save, -c following the return from the last lsodes CALL prior to the -c interruption, the contents of the CALL sequence variables and the -c internal common blocks, and later restore these values before the -c next lsodes CALL for that problem. to save and restore the common -c blocks, use subroutine srcms (see part ii above). -c -c----------------------------------------------------------------------- -c part iv. optionally replaceable solver routines. -c -c below are descriptions of two routines in the lsodes package which -c relate to the measurement of errors. either routine can be -c replaced by a user-supplied version, if desired. however, since such -c a replacement may have a major impact on performance, it should be -c done only when absolutely necessary, and only with great caution. -c (note.. the means by which the package version of a routine is -c superseded by the user-s version may be system-dependent.) -c -c (a) ewset. -c the following subroutine is called just before each internal -c integration step, and sets the array of error weights, ewt, as -c described under itol/RelTol/AbsTol above.. -c subroutine ewset (neq, itol, RelTol, AbsTol, ycur, ewt) -c where neq, itol, RelTol, and AbsTol are as in the lsodes CALL sequence, -c ycur contains the current dependent variable vector, and -c ewt is the array of weights set by ewset. -c -c if the user supplies this subroutine, it must return in ewt(i) -c (i = 1,...,neq) a positive quantity suitable for comparing errors -c in y(i) to. the ewt array returned by ewset is passed to the -c vnorm routine (see below), and also used by lsodes in the computation -c of the optional output imxer, the diagonal jacobian approximation, -c and the increments for difference quotient jacobians. -c -c in the user-supplied version of ewset, it may be desirable to use -c the current values of derivatives of y. derivatives up to order nq -c are available from the history array yh, described above under -c optional outputs. in ewset, yh is identical to the ycur array, -c extended to nq + 1 columns with a column length of nyh and scale -c factors of h**j/factorial(j). on the first CALL for the problem, -c given by nst = 0, nq is 1 and h is temporarily set to 1.0. -c the quantities nq, nyh, h, and nst can be obtained by including -c in ewset the statements.. -c KPP_REAL h, rls -c common /ls0001/ rls(218),ils(39) -c nq = ils(35) -c nyh = ils(14) -c nst = ils(36) -c h = rls(212) -c thus, for example, the current value of dy/dt can be obtained as -c ycur(nyh+i)/h (i=1,...,neq) (and the division by h is -c unnecessary when nst = 0). -c -c (b) vnorm. -c the following is a real function routine which computes the weighted -c root-mean-square norm of a vector v.. -c d = vnorm (n, v, w) -c where.. -c n = the length of the vector, -c v = real array of length n containing the vector, -c w = real array of length n containing weights, -c d = sqrt( (1/n) * sum(v(i)*w(i))**2 ). -c vnorm is called with n = neq and with w(i) = 1.0/ewt(i), where -c ewt is as set by subroutine ewset. -c -c if the user supplies this function, it should return a non-negative -c value of vnorm suitable for use in the error control in lsodes. -c none of the arguments should be altered by vnorm. -c for example, a user-supplied vnorm routine might.. -c -substitute a max-norm of (v(i)*w(i)) for the rms-norm, or -c -ignore some components of v in the norm, with the effect of -c suppressing the error control on those components of y. -c----------------------------------------------------------------------- -c----------------------------------------------------------------------- -c other routines in the lsodes package. -c -c in addition to subroutine lsodes, the lsodes package includes the -c following subroutines and function routines.. -c iprep acts as an iterface between lsodes and prep, and also does -c adjusting of work space pointers and work arrays. -c prep is called by iprep to compute sparsity and do sparse matrix -c preprocessing if miter = 1 or 2. -c jgroup is called by prep to compute groups of jacobian column -c indices for use when miter = 2. -c adjlr adjusts the length of required sparse matrix work space. -c it is called by prep. -c cntnzu is called by prep and counts the nonzero elements in the -c strict upper triangle of j + j-transpose, where j = df/dy. -c intdy computes an interpolated value of the y vector at t = tout. -c stode is the core integrator, which does one step of the -c integration and the associated error control. -c cfode sets all method coefficients and test constants. -c prjs computes and preprocesses the jacobian matrix j = df/dy -c and the newton iteration matrix p = i - h*l0*j. -c slss manages solution of linear system in chord iteration. -c ewset sets the error weight vector ewt before each step. -c vnorm computes the weighted r.m.s. norm of a vector. -c srcms is a user-callable routine to save and restore -c the contents of the internal common blocks. -c odrv constructs a reordering of the rows and columns of -c a matrix by the minimum degree algorithm. odrv is a -c driver routine which calls subroutines md, mdi, mdm, -c mdp, mdu, and sro. see ref. 2 for details. (the odrv -c module has been modified since ref. 2, however.) -c cdrv performs reordering, symbolic factorization, numerical -c factorization, or linear system solution operations, -c depending on a path argument ipath. cdrv is a -c driver routine which calls subroutines nroc, nsfc, -c nnfc, nnsc, and nntc. see ref. 3 for details. -c lsodes uses cdrv to solve linear systems in which the -c coefficient matrix is p = i - con*j, where i is the -c identity, con is a scalar, and j is an approximation to -c the jacobian df/dy. because cdrv deals with rowwise -c sparsity descriptions, cdrv works with p-transpose, not p. -c d1mach computes the unit roundoff in a machine-independent manner. -c xerrwv, xsetun, and xsetf handle the printing of all error -c messages and warnings. xerrwv is machine-dependent. -c note.. vnorm and d1mach are function routines. -c all the others are subroutines. -c -c the intrinsic and external routines used by lsodes are.. -c dabs, DMAX1, dmin1, dfloat, max0, min0, mod, DSIGN, DSQRT, and write. -c -c a block data subprogram is also included with the package, -c for loading some of the variables in internal common. -c -c----------------------------------------------------------------------- -c the following card is for optimized compilation on lll compilers. -clll. optimize -c----------------------------------------------------------------------- - external prjs, slss - integer illin, init, lyh, lewt, lacor, lsavf, lwm, liwm, - 1 mxstep, mxhnil, nhnil, ntrep, nslast, nyh, iowns - integer icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, - 1 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu - integer iplost, iesp, istatc, iys, iba, ibian, ibjan, ibjgp, - 1 ipian, ipjan, ipjgp, ipigp, ipr, ipc, ipic, ipisp, iprsp, ipa, - 2 lenyh, lenyhm, lenwk, lreq, lrat, lrest, lwmin, moss, msbj, - 3 nslj, ngp, nlu, nnz, nsp, nzl, nzu - integer i, i1, i2, iflag, imax, imul, imxer, ipflag, ipgo, irem, - 1 j, kgo, lenrat, lenyht, leniw, lenrw, lf0, lia, lja, - 2 lrtem, lwtem, lyhd, lyhn, mf1, mord, mxhnl0, mxstp0, ncolm - KPP_REAL rowns, - 1 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround - KPP_REAL con0, conmin, ccmxj, psmall, rbig, seth - KPP_REAL AbsToli, ayi, big, ewti, h0, hmax, hmx, rh, RelToli, - 1 tcrit, tdist, tnext, tol, tolsf, tp, size, sum, w0, - 2 d1mach, vnorm - dimension mord(2) - logical ihit -c----------------------------------------------------------------------- -c the following two internal common blocks contain -c (a) variables which are local to any subroutine but whose values must -c be preserved between calls to the routine (own variables), and -c (b) variables which are communicated between subroutines. -c the structure of each block is as follows.. all real variables are -c listed first, followed by all integers. within each type, the -c variables are grouped with those local to subroutine lsodes first, -c then those local to subroutine stode or subroutine prjs -c (no other routines have own variables), and finally those used -c for communication. the block ls0001 is declared in subroutines -c lsodes, iprep, prep, intdy, stode, prjs, and slss. the block lss001 -c is declared in subroutines lsodes, iprep, prep, prjs, and slss. -c groups of variables are replaced by dummy arrays in the common -c declarations in routines where those variables are not used. -c----------------------------------------------------------------------- - common /ls0001/ rowns(209), - 1 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround, - 2 illin, init, lyh, lewt, lacor, lsavf, lwm, liwm, - 3 mxstep, mxhnil, nhnil, ntrep, nslast, nyh, iowns(6), - 4 icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, - 5 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu -c - common /lss001/ con0, conmin, ccmxj, psmall, rbig, seth, - 1 iplost, iesp, istatc, iys, iba, ibian, ibjan, ibjgp, - 2 ipian, ipjan, ipjgp, ipigp, ipr, ipc, ipic, ipisp, iprsp, ipa, - 3 lenyh, lenyhm, lenwk, lreq, lrat, lrest, lwmin, moss, msbj, - 4 nslj, ngp, nlu, nnz, nsp, nzl, nzu -c - data mord(1),mord(2)/12,5/, mxstp0/500/, mxhnl0/10/ -c----------------------------------------------------------------------- -c in the data statement below, set lenrat equal to the ratio of -c the wordlength for a real number to that for an integer. usually, -c lenrat = 1 for single precision and 2 for KPP_REAL. if the -c true ratio is not an integer, use the next smaller integer (.ge. 1). -c----------------------------------------------------------------------- - data lenrat/2/ -c----------------------------------------------------------------------- -c block a. -c this code block is executed on every call. -c it tests istate and itask for legality and branches appropriately. -c if istate .gt. 1 but the flag init shows that initialization has -c not yet been done, an error return occurs. -c if istate = 1 and tout = t, jump to block g and return immediately. -c----------------------------------------------------------------------- - if (istate .lt. 1 .or. istate .gt. 3) go to 601 - if (itask .lt. 1 .or. itask .gt. 5) go to 602 - if (istate .eq. 1) go to 10 - if (init .eq. 0) go to 603 - if (istate .eq. 2) go to 200 - go to 20 - 10 init = 0 - if (tout .eq. t) go to 430 - 20 ntrep = 0 -c----------------------------------------------------------------------- -c block b. -c the next code block is executed for the initial CALL (istate = 1), -c or for a continuation CALL with parameter changes (istate = 3). -c it contains checking of all inputs and various initializations. -c if istate = 1, the final setting of work space pointers, the matrix -c preprocessing, and other initializations are done in block c. -c -c first check legality of the non-optional inputs neq, itol, iopt, -c mf, ml, and mu. -c----------------------------------------------------------------------- - if (neq(1) .le. 0) go to 604 - if (istate .eq. 1) go to 25 - if (neq(1) .gt. n) go to 605 - 25 n = neq(1) - if (itol .lt. 1 .or. itol .gt. 4) go to 606 - if (iopt .lt. 0 .or. iopt .gt. 1) go to 607 - moss = mf/100 - mf1 = mf - 100*moss - meth = mf1/10 - miter = mf1 - 10*meth - if (moss .lt. 0 .or. moss .gt. 2) go to 608 - if (meth .lt. 1 .or. meth .gt. 2) go to 608 - if (miter .lt. 0 .or. miter .gt. 3) go to 608 - if (miter .eq. 0 .or. miter .eq. 3) moss = 0 -c next process and check the optional inputs. -------------------------- - if (iopt .eq. 1) go to 40 - maxord = mord(meth) - mxstep = mxstp0 - mxhnil = mxhnl0 - if (istate .eq. 1) h0 = 0.0d0 - hmxi = 0.0d0 - hmin = 0.0d0 - seth = 0.0d0 - go to 60 - 40 maxord = iwork(5) - if (maxord .lt. 0) go to 611 - if (maxord .eq. 0) maxord = 100 - maxord = min0(maxord,mord(meth)) - mxstep = iwork(6) - if (mxstep .lt. 0) go to 612 - if (mxstep .eq. 0) mxstep = mxstp0 - mxhnil = iwork(7) - if (mxhnil .lt. 0) go to 613 - if (mxhnil .eq. 0) mxhnil = mxhnl0 - if (istate .ne. 1) go to 50 - h0 = rwork(5) - if ((tout - t)*h0 .lt. 0.0d0) go to 614 - 50 hmax = rwork(6) - if (hmax .lt. 0.0d0) go to 615 - hmxi = 0.0d0 - if (hmax .gt. 0.0d0) hmxi = 1.0d0/hmax - hmin = rwork(7) - if (hmin .lt. 0.0d0) go to 616 - seth = rwork(8) - if (seth .lt. 0.0d0) go to 609 -c check RelTol and AbsTol for legality. ------------------------------------ - 60 RelToli = RelTol(1) - AbsToli = AbsTol(1) - do 65 i = 1,n - if (itol .ge. 3) RelToli = RelTol(i) - if (itol .eq. 2 .or. itol .eq. 4) AbsToli = AbsTol(i) - if (RelToli .lt. 0.0d0) go to 619 - if (AbsToli .lt. 0.0d0) go to 620 - 65 continue -c----------------------------------------------------------------------- -c compute required work array lengths, as far as possible, and test -c these against lrw and liw. then set tentative pointers for work -c arrays. pointers to rwork/iwork segments are named by prefixing l to -c the name of the segment. e.g., the segment yh starts at rwork(lyh). -c segments of rwork (in order) are denoted wm, yh, savf, ewt, acor. -c if miter = 1 or 2, the required length of the matrix work space wm -c is not yet known, and so a crude minimum value is used for the -c initial tests of lrw and liw, and yh is temporarily stored as far -c to the right in rwork as possible, to leave the maximum amount -c of space for wm for matrix preprocessing. thus if miter = 1 or 2 -c and moss .ne. 2, some of the segments of rwork are temporarily -c omitted, as they are not needed in the preprocessing. these -c omitted segments are.. acor if istate = 1, ewt and acor if istate = 3 -c and moss = 1, and savf, ewt, and acor if istate = 3 and moss = 0. -c----------------------------------------------------------------------- - lrat = lenrat - if (istate .eq. 1) nyh = n - lwmin = 0 - if (miter .eq. 1) lwmin = 4*n + 10*n/lrat - if (miter .eq. 2) lwmin = 4*n + 11*n/lrat - if (miter .eq. 3) lwmin = n + 2 - lenyh = (maxord+1)*nyh - lrest = lenyh + 3*n - lenrw = 20 + lwmin + lrest - iwork(17) = lenrw - leniw = 30 - if (moss .eq. 0 .and. miter .ne. 0 .and. miter .ne. 3) - 1 leniw = leniw + n + 1 - iwork(18) = leniw - if (lenrw .gt. lrw) go to 617 - if (leniw .gt. liw) go to 618 - lia = 31 - if (moss .eq. 0 .and. miter .ne. 0 .and. miter .ne. 3) - 1 leniw = leniw + iwork(lia+n) - 1 - iwork(18) = leniw - if (leniw .gt. liw) go to 618 - lja = lia + n + 1 - lia = min0(lia,liw) - lja = min0(lja,liw) - lwm = 21 - if (istate .eq. 1) nq = 1 - ncolm = min0(nq+1,maxord+2) - lenyhm = ncolm*nyh - lenyht = lenyh - if (miter .eq. 1 .or. miter .eq. 2) lenyht = lenyhm - imul = 2 - if (istate .eq. 3) imul = moss - if (moss .eq. 2) imul = 3 - lrtem = lenyht + imul*n - lwtem = lwmin - if (miter .eq. 1 .or. miter .eq. 2) lwtem = lrw - 20 - lrtem - lenwk = lwtem - lyhn = lwm + lwtem - lsavf = lyhn + lenyht - lewt = lsavf + n - lacor = lewt + n - istatc = istate - if (istate .eq. 1) go to 100 -c----------------------------------------------------------------------- -c istate = 3. move yh to its new location. -c note that only the part of yh needed for the next step, namely -c min(nq+1,maxord+2) columns, is actually moved. -c a temporary error weight array ewt is loaded if moss = 2. -c sparse matrix processing is done in iprep/prep if miter = 1 or 2. -c if maxord was reduced below nq, then the pointers are finally set -c so that savf is identical to yh(*,maxord+2). -c----------------------------------------------------------------------- - lyhd = lyh - lyhn - imax = lyhn - 1 + lenyhm -c move yh. branch for move right, no move, or move left. -------------- - if (lyhd) 70,80,74 - 70 do 72 i = lyhn,imax - j = imax + lyhn - i - 72 rwork(j) = rwork(j+lyhd) - go to 80 - 74 do 76 i = lyhn,imax - 76 rwork(i) = rwork(i+lyhd) - 80 lyh = lyhn - iwork(22) = lyh - if (miter .eq. 0 .or. miter .eq. 3) go to 92 - if (moss .ne. 2) go to 85 -c temporarily load ewt if miter = 1 or 2 and moss = 2. ----------------- - CALL ewset (n, itol, RelTol, AbsTol, rwork(lyh), rwork(lewt)) - do 82 i = 1,n - if (rwork(i+lewt-1) .le. 0.0d0) go to 621 - 82 rwork(i+lewt-1) = 1.0d0/rwork(i+lewt-1) - 85 continue -c iprep and prep do sparse matrix preprocessing if miter = 1 or 2. ----- - lsavf = min0(lsavf,lrw) - lewt = min0(lewt,lrw) - lacor = min0(lacor,lrw) - CALL iprep (neq, y, rwork, iwork(lia), iwork(lja), ipflag, f, jac) - lenrw = lwm - 1 + lenwk + lrest - iwork(17) = lenrw - if (ipflag .ne. -1) iwork(23) = ipian - if (ipflag .ne. -1) iwork(24) = ipjan - ipgo = -ipflag + 1 - go to (90, 628, 629, 630, 631, 632, 633), ipgo - 90 iwork(22) = lyh - if (lenrw .gt. lrw) go to 617 -c set flag to signal parameter changes to stode. ----------------------- - 92 jstart = -1 - if (n .eq. nyh) go to 200 -c neq was reduced. zero part of yh to avoid undefined references. ----- - i1 = lyh + l*nyh - i2 = lyh + (maxord + 1)*nyh - 1 - if (i1 .gt. i2) go to 200 - do 95 i = i1,i2 - 95 rwork(i) = 0.0d0 - go to 200 -c----------------------------------------------------------------------- -c block c. -c the next block is for the initial CALL only (istate = 1). -c it contains all remaining initializations, the initial CALL to f, -c the sparse matrix preprocessing (miter = 1 or 2), and the -c calculation of the initial step size. -c the error weights in ewt are inverted after being loaded. -c----------------------------------------------------------------------- - 100 continue - lyh = lyhn - iwork(22) = lyh - tn = t - nst = 0 - h = 1.0d0 - nnz = 0 - ngp = 0 - nzl = 0 - nzu = 0 -c load the initial value vector in yh. --------------------------------- - do 105 i = 1,n - 105 rwork(i+lyh-1) = y(i) -c initial CALL to f. (lf0 points to yh(*,2).) ------------------------- - lf0 = lyh + nyh - CALL f (neq, t, y, rwork(lf0)) - nfe = 1 -c load and invert the ewt array. (h is temporarily set to 1.0.) ------- - CALL ewset (n, itol, RelTol, AbsTol, rwork(lyh), rwork(lewt)) - do 110 i = 1,n - if (rwork(i+lewt-1) .le. 0.0d0) go to 621 - 110 rwork(i+lewt-1) = 1.0d0/rwork(i+lewt-1) - if (miter .eq. 0 .or. miter .eq. 3) go to 120 -c iprep and prep do sparse matrix preprocessing if miter = 1 or 2. ----- - lacor = min0(lacor,lrw) - CALL iprep (neq, y, rwork, iwork(lia), iwork(lja), ipflag, f, jac) - lenrw = lwm - 1 + lenwk + lrest - iwork(17) = lenrw - if (ipflag .ne. -1) iwork(23) = ipian - if (ipflag .ne. -1) iwork(24) = ipjan - ipgo = -ipflag + 1 - go to (115, 628, 629, 630, 631, 632, 633), ipgo - 115 iwork(22) = lyh - if (lenrw .gt. lrw) go to 617 -c check tcrit for legality (itask = 4 or 5). --------------------------- - 120 continue - if (itask .ne. 4 .and. itask .ne. 5) go to 125 - tcrit = rwork(1) - if ((tcrit - tout)*(tout - t) .lt. 0.0d0) go to 625 - if (h0 .ne. 0.0d0 .and. (t + h0 - tcrit)*h0 .gt. 0.0d0) - 1 h0 = tcrit - t -c initialize all remaining parameters. --------------------------------- - 125 uround = d1mach(4) - jstart = 0 - if (miter .ne. 0) rwork(lwm) = DSQRT(uround) - msbj = 50 - nslj = 0 - ccmxj = 0.2d0 - psmall = 1000.0d0*uround - rbig = 0.01d0/psmall - nhnil = 0 - nje = 0 - nlu = 0 - nslast = 0 - hu = 0.0d0 - nqu = 0 - ccmax = 0.3d0 - maxcor = 3 - msbp = 20 - mxncf = 10 -c----------------------------------------------------------------------- -c the coding below computes the step size, h0, to be attempted on the -c first step, unless the user has supplied a value for this. -c first check that tout - t differs significantly from zero. -c a scalar tolerance quantity tol is computed, as max(RelTol(i)) -c if this is positive, or max(AbsTol(i)/abs(y(i))) otherwise, adjusted -c so as to be between 100*uround and 1.0e-3. -c then the computed value h0 is given by.. -c neq -c h0**2 = tol / ( w0**-2 + (1/neq) * sum ( f(i)/ywt(i) )**2 ) -c 1 -c where w0 = max ( abs(t), abs(tout) ), -c f(i) = i-th component of initial value of f, -c ywt(i) = ewt(i)/tol (a weight for y(i)). -c the sign of h0 is inferred from the initial values of tout and t. -c----------------------------------------------------------------------- - lf0 = lyh + nyh - if (h0 .ne. 0.0d0) go to 180 - tdist = dabs(tout - t) - w0 = DMAX1(dabs(t),dabs(tout)) - if (tdist .lt. 2.0d0*uround*w0) go to 622 - tol = RelTol(1) - if (itol .le. 2) go to 140 - do 130 i = 1,n - 130 tol = DMAX1(tol,RelTol(i)) - 140 if (tol .gt. 0.0d0) go to 160 - AbsToli = AbsTol(1) - do 150 i = 1,n - if (itol .eq. 2 .or. itol .eq. 4) AbsToli = AbsTol(i) - ayi = dabs(y(i)) - if (ayi .ne. 0.0d0) tol = DMAX1(tol,AbsToli/ayi) - 150 continue - 160 tol = DMAX1(tol,100.0d0*uround) - tol = dmin1(tol,0.001d0) - sum = vnorm (n, rwork(lf0), rwork(lewt)) - sum = 1.0d0/(tol*w0*w0) + tol*sum**2 - h0 = 1.0d0/DSQRT(sum) - h0 = dmin1(h0,tdist) - h0 = DSIGN(h0,tout-t) -c adjust h0 if necessary to meet hmax bound. --------------------------- - 180 rh = dabs(h0)*hmxi - if (rh .gt. 1.0d0) h0 = h0/rh -c load h with h0 and scale yh(*,2) by h0. ------------------------------ - h = h0 - do 190 i = 1,n - 190 rwork(i+lf0-1) = h0*rwork(i+lf0-1) - go to 270 -c----------------------------------------------------------------------- -c block d. -c the next code block is for continuation calls only (istate = 2 or 3) -c and is to check stop conditions before taking a step. -c----------------------------------------------------------------------- - 200 nslast = nst - go to (210, 250, 220, 230, 240), itask - 210 if ((tn - tout)*h .lt. 0.0d0) go to 250 - CALL intdy (tout, 0, rwork(lyh), nyh, y, iflag) - if (iflag .ne. 0) go to 627 - t = tout - go to 420 - 220 tp = tn - hu*(1.0d0 + 100.0d0*uround) - if ((tp - tout)*h .gt. 0.0d0) go to 623 - if ((tn - tout)*h .lt. 0.0d0) go to 250 - go to 400 - 230 tcrit = rwork(1) - if ((tn - tcrit)*h .gt. 0.0d0) go to 624 - if ((tcrit - tout)*h .lt. 0.0d0) go to 625 - if ((tn - tout)*h .lt. 0.0d0) go to 245 - CALL intdy (tout, 0, rwork(lyh), nyh, y, iflag) - if (iflag .ne. 0) go to 627 - t = tout - go to 420 - 240 tcrit = rwork(1) - if ((tn - tcrit)*h .gt. 0.0d0) go to 624 - 245 hmx = dabs(tn) + dabs(h) - ihit = dabs(tn - tcrit) .le. 100.0d0*uround*hmx - if (ihit) go to 400 - tnext = tn + h*(1.0d0 + 4.0d0*uround) - if ((tnext - tcrit)*h .le. 0.0d0) go to 250 - h = (tcrit - tn)*(1.0d0 - 4.0d0*uround) - if (istate .eq. 2) jstart = -2 -c----------------------------------------------------------------------- -c block e. -c the next block is normally executed for all calls and contains -c the CALL to the one-step core integrator stode. -c -c this is a looping point for the integration steps. -c -c first check for too many steps being taken, update ewt (if not at -c start of problem), check for too much accuracy being requested, and -c check for h below the roundoff level in t. -c----------------------------------------------------------------------- - 250 continue - if ((nst-nslast) .ge. mxstep) go to 500 - CALL ewset (n, itol, RelTol, AbsTol, rwork(lyh), rwork(lewt)) - do 260 i = 1,n - if (rwork(i+lewt-1) .le. 0.0d0) go to 510 - 260 rwork(i+lewt-1) = 1.0d0/rwork(i+lewt-1) - 270 tolsf = uround*vnorm (n, rwork(lyh), rwork(lewt)) - if (tolsf .le. 1.0d0) go to 280 - tolsf = tolsf*2.0d0 - if (nst .eq. 0) go to 626 - go to 520 - 280 if ((tn + h) .ne. tn) go to 290 - nhnil = nhnil + 1 - if (nhnil .gt. mxhnil) go to 290 - CALL xerrwv(50hlsodes-- warning..internal t (=r1) and h (=r2) are, - 1 50, 101, 0, 0, 0, 0, 0, 0.0d0, 0.0d0) - CALL xerrwv( - 1 60h such that in the machine, t + h = t on the next step , - 1 60, 101, 0, 0, 0, 0, 0, 0.0d0, 0.0d0) - CALL xerrwv(50h (h = step size). solver will continue anyway, - 1 50, 101, 0, 0, 0, 0, 2, tn, h) - if (nhnil .lt. mxhnil) go to 290 - CALL xerrwv(50hlsodes-- above warning has been issued i1 times. , - 1 50, 102, 0, 0, 0, 0, 0, 0.0d0, 0.0d0) - CALL xerrwv(50h it will not be issued again for this problem, - 1 50, 102, 0, 1, mxhnil, 0, 0, 0.0d0, 0.0d0) - 290 continue -c----------------------------------------------------------------------- -c CALL stode(neq,y,yh,nyh,yh,ewt,savf,acor,wm,wm,f,jac,prjs,slss) -c----------------------------------------------------------------------- - CALL stode (neq, y, rwork(lyh), nyh, rwork(lyh), rwork(lewt), - 1 rwork(lsavf), rwork(lacor), rwork(lwm), rwork(lwm), - 2 f, jac, prjs, slss) - kgo = 1 - kflag - go to (300, 530, 540, 550), kgo -c----------------------------------------------------------------------- -c block f. -c the following block handles the case of a successful return from the -c core integrator (kflag = 0). test for stop conditions. -c----------------------------------------------------------------------- - 300 init = 1 - go to (310, 400, 330, 340, 350), itask -c itask = 1. if tout has been reached, interpolate. ------------------- - 310 if ((tn - tout)*h .lt. 0.0d0) go to 250 - CALL intdy (tout, 0, rwork(lyh), nyh, y, iflag) - t = tout - go to 420 -c itask = 3. jump to exit if tout was reached. ------------------------ - 330 if ((tn - tout)*h .ge. 0.0d0) go to 400 - go to 250 -c itask = 4. see if tout or tcrit was reached. adjust h if necessary. - 340 if ((tn - tout)*h .lt. 0.0d0) go to 345 - CALL intdy (tout, 0, rwork(lyh), nyh, y, iflag) - t = tout - go to 420 - 345 hmx = dabs(tn) + dabs(h) - ihit = dabs(tn - tcrit) .le. 100.0d0*uround*hmx - if (ihit) go to 400 - tnext = tn + h*(1.0d0 + 4.0d0*uround) - if ((tnext - tcrit)*h .le. 0.0d0) go to 250 - h = (tcrit - tn)*(1.0d0 - 4.0d0*uround) - jstart = -2 - go to 250 -c itask = 5. see if tcrit was reached and jump to exit. --------------- - 350 hmx = dabs(tn) + dabs(h) - ihit = dabs(tn - tcrit) .le. 100.0d0*uround*hmx -c----------------------------------------------------------------------- -c block g. -c the following block handles all successful returns from lsodes. -c if itask .ne. 1, y is loaded from yh and t is set accordingly. -c istate is set to 2, the illegal input counter is zeroed, and the -c optional outputs are loaded into the work arrays before returning. -c if istate = 1 and tout = t, there is a return with no action taken, -c except that if this has happened repeatedly, the run is terminated. -c----------------------------------------------------------------------- - 400 do 410 i = 1,n - 410 y(i) = rwork(i+lyh-1) - t = tn - if (itask .ne. 4 .and. itask .ne. 5) go to 420 - if (ihit) t = tcrit - 420 istate = 2 - illin = 0 - rwork(11) = hu - rwork(12) = h - rwork(13) = tn - iwork(11) = nst - iwork(12) = nfe - iwork(13) = nje - iwork(14) = nqu - iwork(15) = nq - iwork(19) = nnz - iwork(20) = ngp - iwork(21) = nlu - iwork(25) = nzl - iwork(26) = nzu - return -c - 430 ntrep = ntrep + 1 - if (ntrep .lt. 5) return - CALL xerrwv( - 1 60hlsodes-- repeated calls with istate = 1 and tout = t (=r1) , - 1 60, 301, 0, 0, 0, 0, 1, t, 0.0d0) - go to 800 -c----------------------------------------------------------------------- -c block h. -c the following block handles all unsuccessful returns other than -c those for illegal input. first the error message routine is called. -c if there was an error test or convergence test failure, imxer is set. -c then y is loaded from yh, t is set to tn, and the illegal input -c counter illin is set to 0. the optional outputs are loaded into -c the work arrays before returning. -c----------------------------------------------------------------------- -c the maximum number of steps was taken before reaching tout. ---------- - 500 CALL xerrwv(50hlsodes-- at current t (=r1), mxstep (=i1) steps , - 1 50, 201, 0, 0, 0, 0, 0, 0.0d0, 0.0d0) - CALL xerrwv(50h taken on this CALL before reaching tout , - 1 50, 201, 0, 1, mxstep, 0, 1, tn, 0.0d0) - istate = -1 - go to 580 -c ewt(i) .le. 0.0 for some i (not at start of problem). ---------------- - 510 ewti = rwork(lewt+i-1) - CALL xerrwv(50hlsodes-- at t (=r1), ewt(i1) has become r2 .le. 0., - 1 50, 202, 0, 1, i, 0, 2, tn, ewti) - istate = -6 - go to 580 -c too much accuracy requested for machine precision. ------------------- - 520 CALL xerrwv(50hlsodes-- at t (=r1), too much accuracy requested , - 1 50, 203, 0, 0, 0, 0, 0, 0.0d0, 0.0d0) - CALL xerrwv(50h for precision of machine.. see tolsf (=r2) , - 1 50, 203, 0, 0, 0, 0, 2, tn, tolsf) - rwork(14) = tolsf - istate = -2 - go to 580 -c kflag = -1. error test failed repeatedly or with abs(h) = hmin. ----- - 530 CALL xerrwv(50hlsodes-- at t(=r1) and step size h(=r2), the error, - 1 50, 204, 0, 0, 0, 0, 0, 0.0d0, 0.0d0) - CALL xerrwv(50h test failed repeatedly or with abs(h) = hmin, - 1 50, 204, 0, 0, 0, 0, 2, tn, h) - istate = -4 - go to 560 -c kflag = -2. convergence failed repeatedly or with abs(h) = hmin. ---- - 540 CALL xerrwv(50hlsodes-- at t (=r1) and step size h (=r2), the , - 1 50, 205, 0, 0, 0, 0, 0, 0.0d0, 0.0d0) - CALL xerrwv(50h corrector convergence failed repeatedly , - 1 50, 205, 0, 0, 0, 0, 0, 0.0d0, 0.0d0) - CALL xerrwv(30h or with abs(h) = hmin , - 1 30, 205, 0, 0, 0, 0, 2, tn, h) - istate = -5 - go to 560 -c kflag = -3. fatal error flag returned by prjs or slss (cdrv). ------- - 550 CALL xerrwv(50hlsodes-- at t (=r1) and step size h (=r2), a fatal, - 1 50, 207, 0, 0, 0, 0, 0, 0.0d0, 0.0d0) - CALL xerrwv(50h error flag was returned by cdrv (by way of , - 1 50, 207, 0, 0, 0, 0, 0, 0.0d0, 0.0d0) - CALL xerrwv(30h subroutine prjs or slss), - 1 30, 207, 0, 0, 0, 0, 2, tn, h) - istate = -7 - go to 580 -c compute imxer if relevant. ------------------------------------------- - 560 big = 0.0d0 - imxer = 1 - do 570 i = 1,n - size = dabs(rwork(i+lacor-1)*rwork(i+lewt-1)) - if (big .ge. size) go to 570 - big = size - imxer = i - 570 continue - iwork(16) = imxer -c set y vector, t, illin, and optional outputs. ------------------------ - 580 do 590 i = 1,n - 590 y(i) = rwork(i+lyh-1) - t = tn - illin = 0 - rwork(11) = hu - rwork(12) = h - rwork(13) = tn - iwork(11) = nst - iwork(12) = nfe - iwork(13) = nje - iwork(14) = nqu - iwork(15) = nq - iwork(19) = nnz - iwork(20) = ngp - iwork(21) = nlu - iwork(25) = nzl - iwork(26) = nzu - return -c----------------------------------------------------------------------- -c block i. -c the following block handles all error returns due to illegal input -c (istate = -3), as detected before calling the core integrator. -c first the error message routine is called. then if there have been -c 5 consecutive such returns just before this CALL to the solver, -c the run is halted. -c----------------------------------------------------------------------- - 601 CALL xerrwv(30hlsodes-- istate (=i1) illegal , - 1 30, 1, 0, 1, istate, 0, 0, 0.0d0, 0.0d0) - go to 700 - 602 CALL xerrwv(30hlsodes-- itask (=i1) illegal , - 1 30, 2, 0, 1, itask, 0, 0, 0.0d0, 0.0d0) - go to 700 - 603 CALL xerrwv(50hlsodes-- istate .gt. 1 but lsodes not initialized , - 1 50, 3, 0, 0, 0, 0, 0, 0.0d0, 0.0d0) - go to 700 - 604 CALL xerrwv(30hlsodes-- neq (=i1) .lt. 1 , - 1 30, 4, 0, 1, neq(1), 0, 0, 0.0d0, 0.0d0) - go to 700 - 605 CALL xerrwv(50hlsodes-- istate = 3 and neq increased (i1 to i2) , - 1 50, 5, 0, 2, n, neq(1), 0, 0.0d0, 0.0d0) - go to 700 - 606 CALL xerrwv(30hlsodes-- itol (=i1) illegal , - 1 30, 6, 0, 1, itol, 0, 0, 0.0d0, 0.0d0) - go to 700 - 607 CALL xerrwv(30hlsodes-- iopt (=i1) illegal , - 1 30, 7, 0, 1, iopt, 0, 0, 0.0d0, 0.0d0) - go to 700 - 608 CALL xerrwv(30hlsodes-- mf (=i1) illegal , - 1 30, 8, 0, 1, mf, 0, 0, 0.0d0, 0.0d0) - go to 700 - 609 CALL xerrwv(30hlsodes-- seth (=r1) .lt. 0.0 , - 1 30, 9, 0, 0, 0, 0, 1, seth, 0.0d0) - go to 700 - 611 CALL xerrwv(30hlsodes-- maxord (=i1) .lt. 0 , - 1 30, 11, 0, 1, maxord, 0, 0, 0.0d0, 0.0d0) - go to 700 - 612 CALL xerrwv(30hlsodes-- mxstep (=i1) .lt. 0 , - 1 30, 12, 0, 1, mxstep, 0, 0, 0.0d0, 0.0d0) - go to 700 - 613 CALL xerrwv(30hlsodes-- mxhnil (=i1) .lt. 0 , - 1 30, 13, 0, 1, mxhnil, 0, 0, 0.0d0, 0.0d0) - go to 700 - 614 CALL xerrwv(40hlsodes-- tout (=r1) behind t (=r2) , - 1 40, 14, 0, 0, 0, 0, 2, tout, t) - CALL xerrwv(50h integration direction is given by h0 (=r1) , - 1 50, 14, 0, 0, 0, 0, 1, h0, 0.0d0) - go to 700 - 615 CALL xerrwv(30hlsodes-- hmax (=r1) .lt. 0.0 , - 1 30, 15, 0, 0, 0, 0, 1, hmax, 0.0d0) - go to 700 - 616 CALL xerrwv(30hlsodes-- hmin (=r1) .lt. 0.0 , - 1 30, 16, 0, 0, 0, 0, 1, hmin, 0.0d0) - go to 700 - 617 CALL xerrwv(50hlsodes-- rwork length is insufficient to proceed. , - 1 50, 17, 0, 0, 0, 0, 0, 0.0d0, 0.0d0) - CALL xerrwv( - 1 60h length needed is .ge. lenrw (=i1), exceeds lrw (=i2), - 1 60, 17, 0, 2, lenrw, lrw, 0, 0.0d0, 0.0d0) - go to 700 - 618 CALL xerrwv(50hlsodes-- iwork length is insufficient to proceed. , - 1 50, 18, 0, 0, 0, 0, 0, 0.0d0, 0.0d0) - CALL xerrwv( - 1 60h length needed is .ge. leniw (=i1), exceeds liw (=i2), - 1 60, 18, 0, 2, leniw, liw, 0, 0.0d0, 0.0d0) - go to 700 - 619 CALL xerrwv(40hlsodes-- RelTol(i1) is r1 .lt. 0.0 , - 1 40, 19, 0, 1, i, 0, 1, RelToli, 0.0d0) - go to 700 - 620 CALL xerrwv(40hlsodes-- AbsTol(i1) is r1 .lt. 0.0 , - 1 40, 20, 0, 1, i, 0, 1, AbsToli, 0.0d0) - go to 700 - 621 ewti = rwork(lewt+i-1) - CALL xerrwv(40hlsodes-- ewt(i1) is r1 .le. 0.0 , - 1 40, 21, 0, 1, i, 0, 1, ewti, 0.0d0) - go to 700 - 622 CALL xerrwv( - 1 60hlsodes-- tout (=r1) too close to t(=r2) to start integration, - 1 60, 22, 0, 0, 0, 0, 2, tout, t) - go to 700 - 623 CALL xerrwv( - 1 60hlsodes-- itask = i1 and tout (=r1) behind tcur - hu (= r2) , - 1 60, 23, 0, 1, itask, 0, 2, tout, tp) - go to 700 - 624 CALL xerrwv( - 1 60hlsodes-- itask = 4 or 5 and tcrit (=r1) behind tcur (=r2) , - 1 60, 24, 0, 0, 0, 0, 2, tcrit, tn) - go to 700 - 625 CALL xerrwv( - 1 60hlsodes-- itask = 4 or 5 and tcrit (=r1) behind tout (=r2) , - 1 60, 25, 0, 0, 0, 0, 2, tcrit, tout) - go to 700 - 626 CALL xerrwv(50hlsodes-- at start of problem, too much accuracy , - 1 50, 26, 0, 0, 0, 0, 0, 0.0d0, 0.0d0) - CALL xerrwv( - 1 60h requested for precision of machine.. see tolsf (=r1) , - 1 60, 26, 0, 0, 0, 0, 1, tolsf, 0.0d0) - rwork(14) = tolsf - go to 700 - 627 CALL xerrwv(50hlsodes-- trouble from intdy. itask = i1, tout = r1, - 1 50, 27, 0, 1, itask, 0, 1, tout, 0.0d0) - go to 700 - 628 CALL xerrwv( - 1 60hlsodes-- rwork length insufficient (for subroutine prep). , - 1 60, 28, 0, 0, 0, 0, 0, 0.0d0, 0.0d0) - CALL xerrwv( - 1 60h length needed is .ge. lenrw (=i1), exceeds lrw (=i2), - 1 60, 28, 0, 2, lenrw, lrw, 0, 0.0d0, 0.0d0) - go to 700 - 629 CALL xerrwv( - 1 60hlsodes-- rwork length insufficient (for subroutine jgroup). , - 1 60, 29, 0, 0, 0, 0, 0, 0.0d0, 0.0d0) - CALL xerrwv( - 1 60h length needed is .ge. lenrw (=i1), exceeds lrw (=i2), - 1 60, 29, 0, 2, lenrw, lrw, 0, 0.0d0, 0.0d0) - go to 700 - 630 CALL xerrwv( - 1 60hlsodes-- rwork length insufficient (for subroutine odrv). , - 1 60, 30, 0, 0, 0, 0, 0, 0.0d0, 0.0d0) - CALL xerrwv( - 1 60h length needed is .ge. lenrw (=i1), exceeds lrw (=i2), - 1 60, 30, 0, 2, lenrw, lrw, 0, 0.0d0, 0.0d0) - go to 700 - 631 CALL xerrwv( - 1 60hlsodes-- error from odrv in yale sparse matrix package , - 1 60, 31, 0, 0, 0, 0, 0, 0.0d0, 0.0d0) - imul = (iys - 1)/n - irem = iys - imul*n - CALL xerrwv( - 1 60h at t (=r1), odrv returned error flag = i1*neq + i2. , - 1 60, 31, 0, 2, imul, irem, 1, tn, 0.0d0) - go to 700 - 632 CALL xerrwv( - 1 60hlsodes-- rwork length insufficient (for subroutine cdrv). , - 1 60, 32, 0, 0, 0, 0, 0, 0.0d0, 0.0d0) - CALL xerrwv( - 1 60h length needed is .ge. lenrw (=i1), exceeds lrw (=i2), - 1 60, 32, 0, 2, lenrw, lrw, 0, 0.0d0, 0.0d0) - go to 700 - 633 CALL xerrwv( - 1 60hlsodes-- error from cdrv in yale sparse matrix package , - 1 60, 33, 0, 0, 0, 0, 0, 0.0d0, 0.0d0) - imul = (iys - 1)/n - irem = iys - imul*n - CALL xerrwv( - 1 60h at t (=r1), cdrv returned error flag = i1*neq + i2. , - 1 60, 33, 0, 2, imul, irem, 1, tn, 0.0d0) - if (imul .eq. 2) CALL xerrwv( - 1 60h duplicate entry in sparsity structure descriptors , - 1 60, 33, 0, 0, 0, 0, 0, 0.0d0, 0.0d0) - if (imul .eq. 3 .or. imul .eq. 6) CALL xerrwv( - 1 60h insufficient storage for nsfc (called by cdrv) , - 1 60, 33, 0, 0, 0, 0, 0, 0.0d0, 0.0d0) -c - 700 if (illin .eq. 5) go to 710 - illin = illin + 1 - istate = -3 - return - 710 CALL xerrwv(50hlsodes-- repeated occurrences of illegal input , - 1 50, 302, 0, 0, 0, 0, 0, 0.0d0, 0.0d0) -c - 800 CALL xerrwv(50hlsodes-- run aborted.. apparent infinite loop , - 1 50, 303, 2, 0, 0, 0, 0, 0.0d0, 0.0d0) - return -c----------------------- end of subroutine lsodes ---------------------- - end - subroutine iprep (neq, y, rwork, ia, ja, ipflag, f, jac) -clll. optimize - external f, jac - integer neq, ia, ja, ipflag - integer illin, init, lyh, lewt, lacor, lsavf, lwm, liwm, - 1 mxstep, mxhnil, nhnil, ntrep, nslast, nyh, iowns - integer icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, - 1 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu - integer iplost, iesp, istatc, iys, iba, ibian, ibjan, ibjgp, - 1 ipian, ipjan, ipjgp, ipigp, ipr, ipc, ipic, ipisp, iprsp, ipa, - 2 lenyh, lenyhm, lenwk, lreq, lrat, lrest, lwmin, moss, msbj, - 3 nslj, ngp, nlu, nnz, nsp, nzl, nzu - integer i, imax, lewtn, lyhd, lyhn - KPP_REAL y, rwork - KPP_REAL rowns, - 1 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround - KPP_REAL rlss - dimension neq(1), y(1), rwork(1), ia(1), ja(1) - common /ls0001/ rowns(209), - 1 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround, - 2 illin, init, lyh, lewt, lacor, lsavf, lwm, liwm, - 3 mxstep, mxhnil, nhnil, ntrep, nslast, nyh, iowns(6), - 4 icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, - 5 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu - common /lss001/ rlss(6), - 1 iplost, iesp, istatc, iys, iba, ibian, ibjan, ibjgp, - 2 ipian, ipjan, ipjgp, ipigp, ipr, ipc, ipic, ipisp, iprsp, ipa, - 3 lenyh, lenyhm, lenwk, lreq, lrat, lrest, lwmin, moss, msbj, - 4 nslj, ngp, nlu, nnz, nsp, nzl, nzu -c----------------------------------------------------------------------- -c this routine serves as an interface between the driver and -c subroutine prep. it is called only if miter is 1 or 2. -c tasks performed here are.. -c * CALL prep, -c * reset the required wm segment length lenwk, -c * move yh back to its final location (following wm in rwork), -c * reset pointers for yh, savf, ewt, and acor, and -c * move ewt to its new position if istate = 1. -c ipflag is an output error indication flag. ipflag = 0 if there was -c no trouble, and ipflag is the value of the prep error flag ipper -c if there was trouble in subroutine prep. -c----------------------------------------------------------------------- - ipflag = 0 -c CALL prep to do matrix preprocessing operations. --------------------- -c CALL prep (neq, y, rwork(lyh), rwork(lsavf), rwork(lewt), -c 1 rwork(lacor), ia, ja, rwork(lwm), rwork(lwm), ipflag, f, jac) - CALL prep (neq, y, rwork(lyh), rwork(lsavf), rwork(lewt), - 1 rwork(lacor), ia, ja, rwork(lwm), rwork(lwm), ipflag, f, jac) - lenwk = max0(lreq,lwmin) - if (ipflag .lt. 0) return -c if prep was successful, move yh to end of required space for wm. ----- - lyhn = lwm + lenwk - if (lyhn .gt. lyh) return - lyhd = lyh - lyhn - if (lyhd .eq. 0) go to 20 - imax = lyhn - 1 + lenyhm - do 10 i = lyhn,imax - 10 rwork(i) = rwork(i+lyhd) - lyh = lyhn -c reset pointers for savf, ewt, and acor. ------------------------------ - 20 lsavf = lyh + lenyh - lewtn = lsavf + n - lacor = lewtn + n - if (istatc .eq. 3) go to 40 -c if istate = 1, move ewt (left) to its new position. ------------------ - if (lewtn .gt. lewt) return - do 30 i = 1,n - 30 rwork(i+lewtn-1) = rwork(i+lewt-1) - 40 lewt = lewtn - return -c----------------------- end of subroutine iprep ----------------------- - end - subroutine slss (wk, iwk, x, tem) -clll. optimize - integer iwk - integer iownd, iowns, - 1 icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, - 2 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu - integer iplost, iesp, istatc, iys, iba, ibian, ibjan, ibjgp, - 1 ipian, ipjan, ipjgp, ipigp, ipr, ipc, ipic, ipisp, iprsp, ipa, - 2 lenyh, lenyhm, lenwk, lreq, lrat, lrest, lwmin, moss, msbj, - 3 nslj, ngp, nlu, nnz, nsp, nzl, nzu - integer i - KPP_REAL wk, x, tem - KPP_REAL rowns, - 1 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround - KPP_REAL rlss - KPP_REAL di, hl0, phl0, r - dimension wk(*), iwk(*), x(*), tem(*) - common /ls0001/ rowns(209), - 2 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround, - 3 iownd(14), iowns(6), - 4 icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, - 5 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu - common /lss001/ rlss(6), - 1 iplost, iesp, istatc, iys, iba, ibian, ibjan, ibjgp, - 2 ipian, ipjan, ipjgp, ipigp, ipr, ipc, ipic, ipisp, iprsp, ipa, - 3 lenyh, lenyhm, lenwk, lreq, lrat, lrest, lwmin, moss, msbj, - 4 nslj, ngp, nlu, nnz, nsp, nzl, nzu -c----------------------------------------------------------------------- -c this routine manages the solution of the linear system arising from -c a chord iteration. it is called if miter .ne. 0. -c if miter is 1 or 2, it calls cdrv to accomplish this. -c if miter = 3 it updates the coefficient h*el0 in the diagonal -c matrix, and then computes the solution. -c communication with slss uses the following variables.. -c wk = real work space containing the inverse diagonal matrix if -c miter = 3 and the lu decomposition of the matrix otherwise. -c storage of matrix elements starts at wk(3). -c wk also contains the following matrix-related data.. -c wk(1) = sqrt(uround) (not used here), -c wk(2) = hl0, the previous value of h*el0, used if miter = 3. -c iwk = integer work space for matrix-related data, assumed to -c be equivalenced to wk. in addition, wk(iprsp) and iwk(ipisp) -c are assumed to have identical locations. -c x = the right-hand side vector on input, and the solution vector -c on output, of length n. -c tem = vector of work space of length n, not used in this version. -c iersl = output flag (in common). -c iersl = 0 if no trouble occurred. -c iersl = -1 if cdrv returned an error flag (miter = 1 or 2). -c this should never occur and is considered fatal. -c iersl = 1 if a singular matrix arose with miter = 3. -c this routine also uses other variables in common. -c----------------------------------------------------------------------- - iersl = 0 - go to (100, 100, 300), miter - 100 CALL cdrv (n,iwk(ipr),iwk(ipc),iwk(ipic),iwk(ipian),iwk(ipjan), - 1 wk(ipa),x,x,nsp,iwk(ipisp),wk(iprsp),iesp,4,iersl) - if (iersl .ne. 0) iersl = -1 - return -c - 300 phl0 = wk(2) - hl0 = h*el0 - wk(2) = hl0 - if (hl0 .eq. phl0) go to 330 - r = hl0/phl0 - do 320 i = 1,n - di = 1.0d0 - r*(1.0d0 - 1.0d0/wk(i+2)) - if (dabs(di) .eq. 0.0d0) go to 390 - 320 wk(i+2) = 1.0d0/di - 330 do 340 i = 1,n - 340 x(i) = wk(i+2)*x(i) - return - 390 iersl = 1 - return -c -c----------------------- end of subroutine slss ------------------------ - end - subroutine intdy (t, k, yh, nyh, dky, iflag) -clll. optimize - integer k, nyh, iflag - integer iownd, iowns, - 1 icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, - 2 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu - integer i, ic, j, jb, jb2, jj, jj1, jp1 - KPP_REAL t, yh, dky - KPP_REAL rowns, - 1 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround - KPP_REAL c, r, s, tp - dimension yh(nyh,1), dky(1) - common /ls0001/ rowns(209), - 2 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround, - 3 iownd(14), iowns(6), - 4 icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, - 5 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu -c----------------------------------------------------------------------- -c intdy computes interpolated values of the k-th derivative of the -c dependent variable vector y, and stores it in dky. this routine -c is called within the package with k = 0 and t = tout, but may -c also be called by the user for any k up to the current order. -c (see detailed instructions in the usage documentation.) -c----------------------------------------------------------------------- -c the computed values in dky are gotten by interpolation using the -c nordsieck history array yh. this array corresponds uniquely to a -c vector-valued polynomial of degree nqcur or less, and dky is set -c to the k-th derivative of this polynomial at t. -c the formula for dky is.. -c q -c dky(i) = sum c(j,k) * (t - tn)**(j-k) * h**(-j) * yh(i,j+1) -c j=k -c where c(j,k) = j*(j-1)*...*(j-k+1), q = nqcur, tn = tcur, h = hcur. -c the quantities nq = nqcur, l = nq+1, n = neq, tn, and h are -c communicated by common. the above sum is done in reverse order. -c iflag is returned negative if either k or t is out of bounds. -c----------------------------------------------------------------------- - iflag = 0 - if (k .lt. 0 .or. k .gt. nq) go to 80 - tp = tn - hu - 100.0d0*uround*(tn + hu) - if ((t-tp)*(t-tn) .gt. 0.0d0) go to 90 -c - s = (t - tn)/h - ic = 1 - if (k .eq. 0) go to 15 - jj1 = l - k - do 10 jj = jj1,nq - 10 ic = ic*jj - 15 c = dfloat(ic) - do 20 i = 1,n - 20 dky(i) = c*yh(i,l) - if (k .eq. nq) go to 55 - jb2 = nq - k - do 50 jb = 1,jb2 - j = nq - jb - jp1 = j + 1 - ic = 1 - if (k .eq. 0) go to 35 - jj1 = jp1 - k - do 30 jj = jj1,j - 30 ic = ic*jj - 35 c = dfloat(ic) - do 40 i = 1,n - 40 dky(i) = c*yh(i,jp1) + s*dky(i) - 50 continue - if (k .eq. 0) return - 55 r = h**(-k) - do 60 i = 1,n - 60 dky(i) = r*dky(i) - return -c - 80 CALL xerrwv(30hintdy-- k (=i1) illegal , - 1 30, 51, 0, 1, k, 0, 0, 0.0d0, 0.0d0) - iflag = -1 - return - 90 CALL xerrwv(30hintdy-- t (=r1) illegal , - 1 30, 52, 0, 0, 0, 0, 1, t, 0.0d0) - CALL xerrwv( - 1 60h t not in interval tcur - hu (= r1) to tcur (=r2) , - 1 60, 52, 0, 0, 0, 0, 2, tp, tn) - iflag = -2 - return -c----------------------- end of subroutine intdy ----------------------- - end - subroutine prjs (neq,y,yh,nyh,ewt,ftem,savf,wk,iwk,f,jac) -clll. optimize - external f,jac - integer neq, nyh, iwk - integer iownd, iowns, - 1 icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, - 2 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu - integer iplost, iesp, istatc, iys, iba, ibian, ibjan, ibjgp, - 1 ipian, ipjan, ipjgp, ipigp, ipr, ipc, ipic, ipisp, iprsp, ipa, - 2 lenyh, lenyhm, lenwk, lreq, lrat, lrest, lwmin, moss, msbj, - 3 nslj, ngp, nlu, nnz, nsp, nzl, nzu - integer i, imul, j, jj, jok, jmax, jmin, k, kmax, kmin, ng - KPP_REAL JJJ(n,n) - KPP_REAL rowns, - 1 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround - KPP_REAL con0, conmin, ccmxj, psmall, rbig, seth - KPP_REAL con, di, fac, hl0, pij, r, r0, rcon, rcont, - 1 srur, vnorm - dimension neq(*), iwk(*) - KPP_REAL y(*), yh(nyh,*), ewt(*), ftem(*), savf(*), wk(*) - common /ls0001/ rowns(209), - 2 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround, - 3 iownd(14), iowns(6), - 4 icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, - 5 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu - common /lss001/ con0, conmin, ccmxj, psmall, rbig, seth, - 1 iplost, iesp, istatc, iys, iba, ibian, ibjan, ibjgp, - 2 ipian, ipjan, ipjgp, ipigp, ipr, ipc, ipic, ipisp, iprsp, ipa, - 3 lenyh, lenyhm, lenwk, lreq, lrat, lrest, lwmin, moss, msbj, - 4 nslj, ngp, nlu, nnz, nsp, nzl, nzu -c----------------------------------------------------------------------- -c prjs is called to compute and process the matrix -c p = i - h*el(1)*j , where j is an approximation to the jacobian. -c j is computed by columns, either by the user-supplied routine jac -c if miter = 1, or by finite differencing if miter = 2. -c if miter = 3, a diagonal approximation to j is used. -c if miter = 1 or 2, and if the existing value of the jacobian -c (as contained in p) is considered acceptable, then a new value of -c p is reconstructed from the old value. in any case, when miter -c is 1 or 2, the p matrix is subjected to lu decomposition in cdrv. -c p and its lu decomposition are stored (separately) in wk. -c -c in addition to variables described previously, communication -c with prjs uses the following.. -c y = array containing predicted values on entry. -c ftem = work array of length n (acor in stode). -c savf = array containing f evaluated at predicted y. -c wk = real work space for matrices. on output it contains the -c inverse diagonal matrix if miter = 3, and p and its sparse -c lu decomposition if miter is 1 or 2. -c storage of matrix elements starts at wk(3). -c wk also contains the following matrix-related data.. -c wk(1) = sqrt(uround), used in numerical jacobian increments. -c wk(2) = h*el0, saved for later use if miter = 3. -c iwk = integer work space for matrix-related data, assumed to -c be equivalenced to wk. in addition, wk(iprsp) and iwk(ipisp) -c are assumed to have identical locations. -c el0 = el(1) (input). -c ierpj = output error flag (in common). -c = 0 if no error. -c = 1 if zero pivot found in cdrv. -c = 2 if a singular matrix arose with miter = 3. -c = -1 if insufficient storage for cdrv (should not occur here). -c = -2 if other error found in cdrv (should not occur here). -c jcur = output flag = 1 to indicate that the jacobian matrix -c (or approximation) is now current. -c this routine also uses other variables in common. -c----------------------------------------------------------------------- - hl0 = h*el0 - con = -hl0 - if (miter .eq. 3) go to 300 -c see whether j should be reevaluated (jok = 0) or not (jok = 1). ------ - jok = 1 - if (nst .eq. 0 .or. nst .ge. nslj+msbj) jok = 0 - if (icf .eq. 1 .and. dabs(rc - 1.0d0) .lt. ccmxj) jok = 0 - if (icf .eq. 2) jok = 0 - if (jok .eq. 1) go to 250 -c -c miter = 1 or 2, and the jacobian is to be reevaluated. --------------- - 20 jcur = 1 - nje = nje + 1 - nslj = nst - iplost = 0 - conmin = dabs(con) - go to (100, 200), miter -c -c if miter = 1, call jac_chem, multiply by scalar, and add identity. -------- - 100 continue - kmin = iwk(ipian) - call jac_chem (neq, tn, y, JJJ, j, iwk(ipian), iwk(ipjan)) - do 130 j = 1, n - kmax = iwk(ipian+j) - 1 - do 110 i = 1,n - 110 ftem(i) = 0.0d0 -C call jac_chem (neq, tn, y, ftem, j, iwk(ipian), iwk(ipjan)) - do k=1,n - ftem(k) = JJJ(k,j) - end do - do 120 k = kmin, kmax - i = iwk(ibjan+k) - wk(iba+k) = ftem(i)*con - if (i .eq. j) wk(iba+k) = wk(iba+k) + 1.0d0 - 120 continue - kmin = kmax + 1 - 130 continue - go to 290 -c -c if miter = 2, make ngp calls to f to approximate j and p. ------------ - 200 continue - fac = vnorm(n, savf, ewt) - r0 = 1000.0d0 * dabs(h) * uround * dfloat(n) * fac - if (r0 .eq. 0.0d0) r0 = 1.0d0 - srur = wk(1) - jmin = iwk(ipigp) - do 240 ng = 1,ngp - jmax = iwk(ipigp+ng) - 1 - do 210 j = jmin,jmax - jj = iwk(ibjgp+j) - r = DMAX1(srur*dabs(y(jj)),r0/ewt(jj)) - 210 y(jj) = y(jj) + r - CALL f (neq, tn, y, ftem) - do 230 j = jmin,jmax - jj = iwk(ibjgp+j) - y(jj) = yh(jj,1) - r = DMAX1(srur*dabs(y(jj)),r0/ewt(jj)) - fac = -hl0/r - kmin =iwk(ibian+jj) - kmax =iwk(ibian+jj+1) - 1 - do 220 k = kmin,kmax - i = iwk(ibjan+k) - wk(iba+k) = (ftem(i) - savf(i))*fac - if (i .eq. jj) wk(iba+k) = wk(iba+k) + 1.0d0 - 220 continue - 230 continue - jmin = jmax + 1 - 240 continue - nfe = nfe + ngp - go to 290 -c -c if jok = 1, reconstruct new p from old p. ---------------------------- - 250 jcur = 0 - rcon = con/con0 - rcont = dabs(con)/conmin - if (rcont .gt. rbig .and. iplost .eq. 1) go to 20 - kmin = iwk(ipian) - do 275 j = 1,n - kmax = iwk(ipian+j) - 1 - do 270 k = kmin,kmax - i = iwk(ibjan+k) - pij = wk(iba+k) - if (i .ne. j) go to 260 - pij = pij - 1.0d0 - if (dabs(pij) .ge. psmall) go to 260 - iplost = 1 - conmin = dmin1(dabs(con0),conmin) - 260 pij = pij*rcon - if (i .eq. j) pij = pij + 1.0d0 - wk(iba+k) = pij - 270 continue - kmin = kmax + 1 - 275 continue -c -c do numerical factorization of p matrix. ------------------------------ - 290 nlu = nlu + 1 - con0 = con - ierpj = 0 - do 295 i = 1,n - 295 ftem(i) = 0.0d0 - CALL cdrv (n,iwk(ipr),iwk(ipc),iwk(ipic),iwk(ipian),iwk(ipjan), - 1 wk(ipa),ftem,ftem,nsp,iwk(ipisp),wk(iprsp),iesp,2,iys) - if (iys .eq. 0) return - imul = (iys - 1)/n - ierpj = -2 - if (imul .eq. 8) ierpj = 1 - if (imul .eq. 10) ierpj = -1 - return -c -c if miter = 3, construct a diagonal approximation to j and p. --------- - 300 continue - jcur = 1 - nje = nje + 1 - wk(2) = hl0 - ierpj = 0 - r = el0*0.1d0 - do 310 i = 1,n - 310 y(i) = y(i) + r*(h*savf(i) - yh(i,2)) - CALL f (neq, tn, y, wk(3)) - nfe = nfe + 1 - do 320 i = 1,n - r0 = h*savf(i) - yh(i,2) - di = 0.1d0*r0 - h*(wk(i+2) - savf(i)) - wk(i+2) = 1.0d0 - if (dabs(r0) .lt. uround/ewt(i)) go to 320 - if (dabs(di) .eq. 0.0d0) go to 330 - wk(i+2) = 0.1d0*r0/di - 320 continue - return - 330 ierpj = 2 - return -c----------------------- end of subroutine prjs ------------------------ - end - subroutine stode (neq, y, yh, nyh, yh1, ewt, savf, acor, - 1 wm, iwm, f, jac, pjac, slvs) -clll. optimize - external f, jac, pjac, slvs - integer neq, nyh, iwm - integer iownd, ialth, ipup, lmax, meo, nqnyh, nslp, - 1 icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, - 2 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu - integer i, i1, iredo, iret, j, jb, m, ncf, newq - KPP_REAL y, yh, yh1, ewt, savf, acor, wm - KPP_REAL conit, crate, el, elco, hold, rmax, tesco, - 2 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround - KPP_REAL dcon, ddn, del, delp, dsm, dup, exdn, exsm, exup, - 1 r, rh, rhdn, rhsm, rhup, told, vnorm - dimension neq(*), y(*), yh(nyh,*), yh1(*), ewt(*), savf(*), - 1 acor(*), wm(*), iwm(*) - common /ls0001/ conit, crate, el(13), elco(13,12), - 1 hold, rmax, tesco(3,12), - 2 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround, iownd(14), - 3 ialth, ipup, lmax, meo, nqnyh, nslp, - 4 icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, - 5 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu -c----------------------------------------------------------------------- -c stode performs one step of the integration of an initial value -c problem for a system of ordinary differential equations. -c note.. stode is independent of the value of the iteration method -c indicator miter, when this is .ne. 0, and hence is independent -c of the type of chord method used, or the jacobian structure. -c communication with stode is done with the following variables.. -c -c neq = integer array containing problem size in neq(1), and -c passed as the neq argument in all calls to f and jac. -c y = an array of length .ge. n used as the y argument in -c all calls to f and jac. -c yh = an nyh by lmax array containing the dependent variables -c and their approximate scaled derivatives, where -c lmax = maxord + 1. yh(i,j+1) contains the approximate -c j-th derivative of y(i), scaled by h**j/factorial(j) -c (j = 0,1,...,nq). on entry for the first step, the first -c two columns of yh must be set from the initial values. -c nyh = a constant integer .ge. n, the first dimension of yh. -c yh1 = a one-dimensional array occupying the same space as yh. -c ewt = an array of length n containing multiplicative weights -c for local error measurements. local errors in y(i) are -c compared to 1.0/ewt(i) in various error tests. -c savf = an array of working storage, of length n. -c also used for input of yh(*,maxord+2) when jstart = -1 -c and maxord .lt. the current order nq. -c acor = a work array of length n, used for the accumulated -c corrections. on a successful return, acor(i) contains -c the estimated one-step local error in y(i). -c wm,iwm = real and integer work arrays associated with matrix -c operations in chord iteration (miter .ne. 0). -c pjac = name of routine to evaluate and preprocess jacobian matrix -c and p = i - h*el0*jac, if a chord method is being used. -c slvs = name of routine to solve linear system in chord iteration. -c ccmax = maximum relative change in h*el0 before pjac is called. -c h = the step size to be attempted on the next step. -c h is altered by the error control algorithm during the -c problem. h can be either positive or negative, but its -c sign must remain constant throughout the problem. -c hmin = the minimum absolute value of the step size h to be used. -c hmxi = inverse of the maximum absolute value of h to be used. -c hmxi = 0.0 is allowed and corresponds to an infinite hmax. -c hmin and hmxi may be changed at any time, but will not -c take effect until the next change of h is considered. -c tn = the independent variable. tn is updated on each step taken. -c jstart = an integer used for input only, with the following -c values and meanings.. -c 0 perform the first step. -c .gt.0 take a new step continuing from the last. -c -1 take the next step with a new value of h, maxord, -c n, meth, miter, and/or matrix parameters. -c -2 take the next step with a new value of h, -c but with other inputs unchanged. -c on return, jstart is set to 1 to facilitate continuation. -c kflag = a completion code with the following meanings.. -c 0 the step was succesful. -c -1 the requested error could not be achieved. -c -2 corrector convergence could not be achieved. -c -3 fatal error in pjac or slvs. -c a return with kflag = -1 or -2 means either -c abs(h) = hmin or 10 consecutive failures occurred. -c on a return with kflag negative, the values of tn and -c the yh array are as of the beginning of the last -c step, and h is the last step size attempted. -c maxord = the maximum order of integration method to be allowed. -c maxcor = the maximum number of corrector iterations allowed. -c msbp = maximum number of steps between pjac calls (miter .gt. 0). -c mxncf = maximum number of convergence failures allowed. -c meth/miter = the method flags. see description in driver. -c n = the number of first-order differential equations. -c----------------------------------------------------------------------- - kflag = 0 - told = tn - ncf = 0 - ierpj = 0 - iersl = 0 - jcur = 0 - icf = 0 - delp = 0.0d0 - if (jstart .gt. 0) go to 200 - if (jstart .eq. -1) go to 100 - if (jstart .eq. -2) go to 160 -c----------------------------------------------------------------------- -c on the first call, the order is set to 1, and other variables are -c initialized. rmax is the maximum ratio by which h can be increased -c in a single step. it is initially 1.e4 to compensate for the small -c initial h, but then is normally equal to 10. if a failure -c occurs (in corrector convergence or error test), rmax is set at 2 -c for the next increase. -c----------------------------------------------------------------------- - lmax = maxord + 1 - nq = 1 - l = 2 - ialth = 2 - rmax = 10000.0d0 - rc = 0.0d0 - el0 = 1.0d0 - crate = 0.7d0 - hold = h - meo = meth - nslp = 0 - ipup = miter - iret = 3 - go to 140 -c----------------------------------------------------------------------- -c the following block handles preliminaries needed when jstart = -1. -c ipup is set to miter to force a matrix update. -c if an order increase is about to be considered (ialth = 1), -c ialth is reset to 2 to postpone consideration one more step. -c if the caller has changed meth, cfode is called to reset -c the coefficients of the method. -c if the caller has changed maxord to a value less than the current -c order nq, nq is reduced to maxord, and a new h chosen accordingly. -c if h is to be changed, yh must be rescaled. -c if h or meth is being changed, ialth is reset to l = nq + 1 -c to prevent further changes in h for that many steps. -c----------------------------------------------------------------------- - 100 ipup = miter - lmax = maxord + 1 - if (ialth .eq. 1) ialth = 2 - if (meth .eq. meo) go to 110 - CALL cfode (meth, elco, tesco) - meo = meth - if (nq .gt. maxord) go to 120 - ialth = l - iret = 1 - go to 150 - 110 if (nq .le. maxord) go to 160 - 120 nq = maxord - l = lmax - do 125 i = 1,l - 125 el(i) = elco(i,nq) - nqnyh = nq*nyh - rc = rc*el(1)/el0 - el0 = el(1) - conit = 0.5d0/dfloat(nq+2) - ddn = vnorm (n, savf, ewt)/tesco(1,l) - exdn = 1.0d0/dfloat(l) - rhdn = 1.0d0/(1.3d0*ddn**exdn + 0.0000013d0) - rh = dmin1(rhdn,1.0d0) - iredo = 3 - if (h .eq. hold) go to 170 - rh = dmin1(rh,dabs(h/hold)) - h = hold - go to 175 -c----------------------------------------------------------------------- -c cfode is called to get all the integration coefficients for the -c current meth. then the el vector and related constants are reset -c whenever the order nq is changed, or at the start of the problem. -c----------------------------------------------------------------------- - 140 CALL cfode (meth, elco, tesco) - 150 do 155 i = 1,l - 155 el(i) = elco(i,nq) - nqnyh = nq*nyh - rc = rc*el(1)/el0 - el0 = el(1) - conit = 0.5d0/dfloat(nq+2) - go to (160, 170, 200), iret -c----------------------------------------------------------------------- -c if h is being changed, the h ratio rh is checked against -c rmax, hmin, and hmxi, and the yh array rescaled. ialth is set to -c l = nq + 1 to prevent a change of h for that many steps, unless -c forced by a convergence or error test failure. -c----------------------------------------------------------------------- - 160 if (h .eq. hold) go to 200 - rh = h/hold - h = hold - iredo = 3 - go to 175 - 170 rh = DMAX1(rh,hmin/dabs(h)) - 175 rh = dmin1(rh,rmax) - rh = rh/DMAX1(1.0d0,dabs(h)*hmxi*rh) - r = 1.0d0 - do 180 j = 2,l - r = r*rh - do 180 i = 1,n - 180 yh(i,j) = yh(i,j)*r - h = h*rh - rc = rc*rh - ialth = l - if (iredo .eq. 0) go to 690 -c----------------------------------------------------------------------- -c this section computes the predicted values by effectively -c multiplying the yh array by the pascal triangle matrix. -c rc is the ratio of new to old values of the coefficient h*el(1). -c when rc differs from 1 by more than ccmax, ipup is set to miter -c to force pjac to be called, if a jacobian is involved. -c in any case, pjac is called at least every msbp steps. -c----------------------------------------------------------------------- - 200 if (dabs(rc-1.0d0) .gt. ccmax) ipup = miter - if (nst .ge. nslp+msbp) ipup = miter - tn = tn + h - i1 = nqnyh + 1 - do 215 jb = 1,nq - i1 = i1 - nyh -cdir$ ivdep - do 210 i = i1,nqnyh - 210 yh1(i) = yh1(i) + yh1(i+nyh) - 215 continue -c----------------------------------------------------------------------- -c up to maxcor corrector iterations are taken. a convergence test is -c made on the r.m.s. norm of each correction, weighted by the error -c weight vector ewt. the sum of the corrections is accumulated in the -c vector acor(i). the yh array is not altered in the corrector loop. -c----------------------------------------------------------------------- - 220 m = 0 - do 230 i = 1,n - 230 y(i) = yh(i,1) - CALL f (neq, tn, y, savf) - nfe = nfe + 1 - if (ipup .le. 0) go to 250 -c----------------------------------------------------------------------- -c if indicated, the matrix p = i - h*el(1)*j is reevaluated and -c preprocessed before starting the corrector iteration. ipup is set -c to 0 as an indicator that this has been done. -c----------------------------------------------------------------------- - CALL pjac (neq, y, yh, nyh, ewt, acor, savf, wm, iwm, f, jac) - ipup = 0 - rc = 1.0d0 - nslp = nst - crate = 0.7d0 - if (ierpj .ne. 0) go to 430 - 250 do 260 i = 1,n - 260 acor(i) = 0.0d0 - 270 if (miter .ne. 0) go to 350 -c----------------------------------------------------------------------- -c in the case of functional iteration, update y directly from -c the result of the last function evaluation. -c----------------------------------------------------------------------- - do 290 i = 1,n - savf(i) = h*savf(i) - yh(i,2) - 290 y(i) = savf(i) - acor(i) - del = vnorm (n, y, ewt) - do 300 i = 1,n - y(i) = yh(i,1) + el(1)*savf(i) - 300 acor(i) = savf(i) - go to 400 -c----------------------------------------------------------------------- -c in the case of the chord method, compute the corrector error, -c and solve the linear system with that as right-hand side and -c p as coefficient matrix. -c----------------------------------------------------------------------- - 350 do 360 i = 1,n - 360 y(i) = h*savf(i) - (yh(i,2) + acor(i)) - CALL slvs (wm, iwm, y, savf) - if (iersl .lt. 0) go to 430 - if (iersl .gt. 0) go to 410 - del = vnorm (n, y, ewt) - do 380 i = 1,n - acor(i) = acor(i) + y(i) - 380 y(i) = yh(i,1) + el(1)*acor(i) -c----------------------------------------------------------------------- -c test for convergence. if m.gt.0, an estimate of the convergence -c rate constant is stored in crate, and this is used in the test. -c----------------------------------------------------------------------- - 400 if (m .ne. 0) crate = DMAX1(0.2d0*crate,del/delp) - dcon = del*dmin1(1.0d0,1.5d0*crate)/(tesco(2,nq)*conit) - if (dcon .le. 1.0d0) go to 450 - m = m + 1 - if (m .eq. maxcor) go to 410 - if (m .ge. 2 .and. del .gt. 2.0d0*delp) go to 410 - delp = del - CALL f (neq, tn, y, savf) - nfe = nfe + 1 - go to 270 -c----------------------------------------------------------------------- -c the corrector iteration failed to converge. -c if miter .ne. 0 and the jacobian is out of date, pjac is called for -c the next try. otherwise the yh array is retracted to its values -c before prediction, and h is reduced, if possible. if h cannot be -c reduced or mxncf failures have occurred, exit with kflag = -2. -c----------------------------------------------------------------------- - 410 if (miter .eq. 0 .or. jcur .eq. 1) go to 430 - icf = 1 - ipup = miter - go to 220 - 430 icf = 2 - ncf = ncf + 1 - rmax = 2.0d0 - tn = told - i1 = nqnyh + 1 - do 445 jb = 1,nq - i1 = i1 - nyh -cdir$ ivdep - do 440 i = i1,nqnyh - 440 yh1(i) = yh1(i) - yh1(i+nyh) - 445 continue - if (ierpj .lt. 0 .or. iersl .lt. 0) go to 680 - if (dabs(h) .le. hmin*1.00001d0) go to 670 - if (ncf .eq. mxncf) go to 670 - rh = 0.25d0 - ipup = miter - iredo = 1 - go to 170 -c----------------------------------------------------------------------- -c the corrector has converged. jcur is set to 0 -c to signal that the jacobian involved may need updating later. -c the local error test is made and control passes to statement 500 -c if it fails. -c----------------------------------------------------------------------- - 450 jcur = 0 - if (m .eq. 0) dsm = del/tesco(2,nq) - if (m .gt. 0) dsm = vnorm (n, acor, ewt)/tesco(2,nq) - if (dsm .gt. 1.0d0) go to 500 -c----------------------------------------------------------------------- -c after a successful step, update the yh array. -c consider changing h if ialth = 1. otherwise decrease ialth by 1. -c if ialth is then 1 and nq .lt. maxord, then acor is saved for -c use in a possible order increase on the next step. -c if a change in h is considered, an increase or decrease in order -c by one is considered also. a change in h is made only if it is by a -c factor of at least 1.1. if not, ialth is set to 3 to prevent -c testing for that many steps. -c----------------------------------------------------------------------- - kflag = 0 - iredo = 0 - nst = nst + 1 - hu = h - nqu = nq - do 470 j = 1,l - do 470 i = 1,n - 470 yh(i,j) = yh(i,j) + el(j)*acor(i) - ialth = ialth - 1 - if (ialth .eq. 0) go to 520 - if (ialth .gt. 1) go to 700 - if (l .eq. lmax) go to 700 - do 490 i = 1,n - 490 yh(i,lmax) = acor(i) - go to 700 -c----------------------------------------------------------------------- -c the error test failed. kflag keeps track of multiple failures. -c restore tn and the yh array to their previous values, and prepare -c to try the step again. compute the optimum step size for this or -c one lower order. after 2 or more failures, h is forced to decrease -c by a factor of 0.2 or less. -c----------------------------------------------------------------------- - 500 kflag = kflag - 1 - tn = told - i1 = nqnyh + 1 - do 515 jb = 1,nq - i1 = i1 - nyh -cdir$ ivdep - do 510 i = i1,nqnyh - 510 yh1(i) = yh1(i) - yh1(i+nyh) - 515 continue - rmax = 2.0d0 - if (dabs(h) .le. hmin*1.00001d0) go to 660 - if (kflag .le. -3) go to 640 - iredo = 2 - rhup = 0.0d0 - go to 540 -c----------------------------------------------------------------------- -c regardless of the success or failure of the step, factors -c rhdn, rhsm, and rhup are computed, by which h could be multiplied -c at order nq - 1, order nq, or order nq + 1, respectively. -c in the case of failure, rhup = 0.0 to avoid an order increase. -c the largest of these is determined and the new order chosen -c accordingly. if the order is to be increased, we compute one -c additional scaled derivative. -c----------------------------------------------------------------------- - 520 rhup = 0.0d0 - if (l .eq. lmax) go to 540 - do 530 i = 1,n - 530 savf(i) = acor(i) - yh(i,lmax) - dup = vnorm (n, savf, ewt)/tesco(3,nq) - exup = 1.0d0/dfloat(l+1) - rhup = 1.0d0/(1.4d0*dup**exup + 0.0000014d0) - 540 exsm = 1.0d0/dfloat(l) - rhsm = 1.0d0/(1.2d0*dsm**exsm + 0.0000012d0) - rhdn = 0.0d0 - if (nq .eq. 1) go to 560 - ddn = vnorm (n, yh(1,l), ewt)/tesco(1,nq) - exdn = 1.0d0/dfloat(nq) - rhdn = 1.0d0/(1.3d0*ddn**exdn + 0.0000013d0) - 560 if (rhsm .ge. rhup) go to 570 - if (rhup .gt. rhdn) go to 590 - go to 580 - 570 if (rhsm .lt. rhdn) go to 580 - newq = nq - rh = rhsm - go to 620 - 580 newq = nq - 1 - rh = rhdn - if (kflag .lt. 0 .and. rh .gt. 1.0d0) rh = 1.0d0 - go to 620 - 590 newq = l - rh = rhup - if (rh .lt. 1.1d0) go to 610 - r = el(l)/dfloat(l) - do 600 i = 1,n - 600 yh(i,newq+1) = acor(i)*r - go to 630 - 610 ialth = 3 - go to 700 - 620 if ((kflag .eq. 0) .and. (rh .lt. 1.1d0)) go to 610 - if (kflag .le. -2) rh = dmin1(rh,0.2d0) -c----------------------------------------------------------------------- -c if there is a change of order, reset nq, l, and the coefficients. -c in any case h is reset according to rh and the yh array is rescaled. -c then exit from 690 if the step was ok, or redo the step otherwise. -c----------------------------------------------------------------------- - if (newq .eq. nq) go to 170 - 630 nq = newq - l = nq + 1 - iret = 2 - go to 150 -c----------------------------------------------------------------------- -c control reaches this section if 3 or more failures have occured. -c if 10 failures have occurred, exit with kflag = -1. -c it is assumed that the derivatives that have accumulated in the -c yh array have errors of the wrong order. hence the first -c derivative is recomputed, and the order is set to 1. then -c h is reduced by a factor of 10, and the step is retried, -c until it succeeds or h reaches hmin. -c----------------------------------------------------------------------- - 640 if (kflag .eq. -10) go to 660 - rh = 0.1d0 - rh = DMAX1(hmin/dabs(h),rh) - h = h*rh - do 645 i = 1,n - 645 y(i) = yh(i,1) - CALL f (neq, tn, y, savf) - nfe = nfe + 1 - do 650 i = 1,n - 650 yh(i,2) = h*savf(i) - ipup = miter - ialth = 5 - if (nq .eq. 1) go to 200 - nq = 1 - l = 2 - iret = 3 - go to 150 -c----------------------------------------------------------------------- -c all returns are made through this section. h is saved in hold -c to allow the caller to change h on the next step. -c----------------------------------------------------------------------- - 660 kflag = -1 - go to 720 - 670 kflag = -2 - go to 720 - 680 kflag = -3 - go to 720 - 690 rmax = 10.0d0 - 700 r = 1.0d0/tesco(2,nqu) - do 710 i = 1,n - 710 acor(i) = acor(i)*r - 720 hold = h - jstart = 1 - return -c----------------------- end of subroutine stode ----------------------- - end - subroutine xerrwv (msg, nmes, nerr, level, ni, i1, i2, nr, r1, r2) - integer msg, nmes, nerr, level, ni, i1, i2, nr, - 1 i, lun, lunit, mesflg, ncpw, nch, nwds - KPP_REAL r1, r2 - dimension msg(nmes) -c----------------------------------------------------------------------- -c subroutines xerrwv, xsetf, and xsetun, as given here, constitute -c a simplified version of the slatec error handling package. -c written by a. c. hindmarsh at llnl. version of march 30, 1987. -c this version is in KPP_REAL. -c -c all arguments are input arguments. -c -c msg = the message (hollerith literal or integer array). -c nmes = the length of msg (number of characters). -c nerr = the error number (not used). -c level = the error level.. -c 0 or 1 means recoverable (control returns to caller). -c 2 means fatal (run is aborted--see note below). -c ni = number of integers (0, 1, or 2) to be printed with message. -c i1,i2 = integers to be printed, depending on ni. -c nr = number of reals (0, 1, or 2) to be printed with message. -c r1,r2 = reals to be printed, depending on nr. -c -c note.. this routine is machine-dependent and specialized for use -c in limited context, in the following ways.. -c 1. the number of hollerith characters stored per word, denoted -c by ncpw below, is a data-loaded constant. -c 2. the value of nmes is assumed to be at most 60. -c (multi-line messages are generated by repeated calls.) -c 3. if level = 2, control passes to the statement stop -c to abort the run. this statement may be machine-dependent. -c 4. r1 and r2 are assumed to be in KPP_REAL and are printed -c in d21.13 format. -c 5. the common block /eh0001/ below is data-loaded (a machine- -c dependent feature) with default values. -c this block is needed for proper retention of parameters used by -c this routine which the user can reset by calling xsetf or xsetun. -c the variables in this block are as follows.. -c mesflg = print control flag.. -c 1 means print all messages (the default). -c 0 means no printing. -c lunit = logical unit number for messages. -c the default is 6 (machine-dependent). -c----------------------------------------------------------------------- -c the following are instructions for installing this routine -c in different machine environments. -c -c to change the default output unit, change the data statement -c in the block data subprogram below. -c -c for a different number of characters per word, change the -c data statement setting ncpw below, and format 10. alternatives for -c various computers are shown in comment cards. -c -c for a different run-abort command, change the statement following -c statement 100 at the end. -c----------------------------------------------------------------------- - common /eh0001/ mesflg, lunit -c----------------------------------------------------------------------- -c the following data-loaded value of ncpw is valid for the cdc-6600 -c and cdc-7600 computers. -c data ncpw/10/ -c the following is valid for the cray-1 computer. -c data ncpw/8/ -c the following is valid for the burroughs 6700 and 7800 computers. -c data ncpw/6/ -c the following is valid for the pdp-10 computer. -c data ncpw/5/ -c the following is valid for the vax computer with 4 bytes per integer, -c and for the ibm-360, ibm-370, ibm-303x, and ibm-43xx computers. - data ncpw/4/ -c the following is valid for the pdp-11, or vax with 2-byte integers. -c data ncpw/2/ -c----------------------------------------------------------------------- - if (mesflg .eq. 0) go to 100 -c get logical unit number. --------------------------------------------- - lun = lunit -c get number of words in message. -------------------------------------- - nch = min0(nmes,60) - nwds = nch/ncpw - if (nch .ne. nwds*ncpw) nwds = nwds + 1 -c write the message. --------------------------------------------------- - write (lun, 10) (msg(i),i=1,nwds) -c----------------------------------------------------------------------- -c the following format statement is to have the form -c 10 format(1x,mmann) -c where nn = ncpw and mm is the smallest integer .ge. 60/ncpw. -c the following is valid for ncpw = 10. -c 10 format(1x,6a10) -c the following is valid for ncpw = 8. -c 10 format(1x,8a8) -c the following is valid for ncpw = 6. -c 10 format(1x,10a6) -c the following is valid for ncpw = 5. -c 10 format(1x,12a5) -c the following is valid for ncpw = 4. - 10 format(1x,15a4) -c the following is valid for ncpw = 2. -c 10 format(1x,30a2) -c----------------------------------------------------------------------- - if (ni .eq. 1) write (lun, 20) i1 - 20 format(6x,23hin above message, i1 =,i10) - if (ni .eq. 2) write (lun, 30) i1,i2 - 30 format(6x,23hin above message, i1 =,i10,3x,4hi2 =,i10) - if (nr .eq. 1) write (lun, 40) r1 - 40 format(6x,23hin above message, r1 =,d21.13) - if (nr .eq. 2) write (lun, 50) r1,r2 - 50 format(6x,15hin above, r1 =,d21.13,3x,4hr2 =,d21.13) -c abort the run if level = 2. ------------------------------------------ - 100 if (level .ne. 2) return - stop -c----------------------- end of subroutine xerrwv ---------------------- - end - KPP_REAL function vnorm (n, v, w) -clll. optimize -c----------------------------------------------------------------------- -c this function routine computes the weighted root-mean-square norm -c of the vector of length n contained in the array v, with weights -c contained in the array w of length n.. -c vnorm = sqrt( (1/n) * sum( v(i)*w(i) )**2 ) -c----------------------------------------------------------------------- - integer n, i - KPP_REAL v, w, sum - dimension v(n), w(n) - sum = 0.0d0 - do 10 i = 1,n - 10 sum = sum + (v(i)*w(i))**2 - vnorm = DSQRT(sum/dfloat(n)) - return -c----------------------- end of function vnorm ------------------------- - end - subroutine ewset (n, itol, RelTol, AbsTol, ycur, ewt) -clll. optimize -c----------------------------------------------------------------------- -c this subroutine sets the error weight vector ewt according to -c ewt(i) = RelTol(i)*abs(ycur(i)) + AbsTol(i), i = 1,...,n, -c with the subscript on RelTol and/or AbsTol possibly replaced by 1 above, -c depending on the value of itol. -c----------------------------------------------------------------------- - integer n, itol - integer i - KPP_REAL RelTol, AbsTol, ycur, ewt - dimension RelTol(1), AbsTol(1), ycur(n), ewt(n) -c - go to (10, 20, 30, 40), itol - 10 continue - do 15 i = 1,n - 15 ewt(i) = RelTol(1)*dabs(ycur(i)) + AbsTol(1) - return - 20 continue - do 25 i = 1,n - 25 ewt(i) = RelTol(1)*dabs(ycur(i)) + AbsTol(i) - return - 30 continue - do 35 i = 1,n - 35 ewt(i) = RelTol(i)*dabs(ycur(i)) + AbsTol(1) - return - 40 continue - do 45 i = 1,n - 45 ewt(i) = RelTol(i)*dabs(ycur(i)) + AbsTol(i) - return -c----------------------- end of subroutine ewset ----------------------- - end - subroutine cfode (meth, elco, tesco) -clll. optimize - integer meth - integer i, ib, nq, nqm1, nqp1 - KPP_REAL elco, tesco - KPP_REAL agamq, fnq, fnqm1, pc, pint, ragq, - 1 rqfac, rq1fac, tsign, xpin - dimension elco(13,12), tesco(3,12) -c----------------------------------------------------------------------- -c cfode is called by the integrator routine to set coefficients -c needed there. the coefficients for the current method, as -c given by the value of meth, are set for all orders and saved. -c the maximum order assumed here is 12 if meth = 1 and 5 if meth = 2. -c (a smaller value of the maximum order is also allowed.) -c cfode is called once at the beginning of the problem, -c and is not called again unless and until meth is changed. -c -c the elco array contains the basic method coefficients. -c the coefficients el(i), 1 .le. i .le. nq+1, for the method of -c order nq are stored in elco(i,nq). they are given by a genetrating -c polynomial, i.e., -c l(x) = el(1) + el(2)*x + ... + el(nq+1)*x**nq. -c for the implicit adams methods, l(x) is given by -c dl/dx = (x+1)*(x+2)*...*(x+nq-1)/factorial(nq-1), l(-1) = 0. -c for the bdf methods, l(x) is given by -c l(x) = (x+1)*(x+2)* ... *(x+nq)/k, -c where k = factorial(nq)*(1 + 1/2 + ... + 1/nq). -c -c the tesco array contains test constants used for the -c local error test and the selection of step size and/or order. -c at order nq, tesco(k,nq) is used for the selection of step -c size at order nq - 1 if k = 1, at order nq if k = 2, and at order -c nq + 1 if k = 3. -c----------------------------------------------------------------------- - dimension pc(12) -c - go to (100, 200), meth -c - 100 elco(1,1) = 1.0d0 - elco(2,1) = 1.0d0 - tesco(1,1) = 0.0d0 - tesco(2,1) = 2.0d0 - tesco(1,2) = 1.0d0 - tesco(3,12) = 0.0d0 - pc(1) = 1.0d0 - rqfac = 1.0d0 - do 140 nq = 2,12 -c----------------------------------------------------------------------- -c the pc array will contain the coefficients of the polynomial -c p(x) = (x+1)*(x+2)*...*(x+nq-1). -c initially, p(x) = 1. -c----------------------------------------------------------------------- - rq1fac = rqfac - rqfac = rqfac/dfloat(nq) - nqm1 = nq - 1 - fnqm1 = dfloat(nqm1) - nqp1 = nq + 1 -c form coefficients of p(x)*(x+nq-1). ---------------------------------- - pc(nq) = 0.0d0 - do 110 ib = 1,nqm1 - i = nqp1 - ib - 110 pc(i) = pc(i-1) + fnqm1*pc(i) - pc(1) = fnqm1*pc(1) -c compute integral, -1 to 0, of p(x) and x*p(x). ----------------------- - pint = pc(1) - xpin = pc(1)/2.0d0 - tsign = 1.0d0 - do 120 i = 2,nq - tsign = -tsign - pint = pint + tsign*pc(i)/dfloat(i) - 120 xpin = xpin + tsign*pc(i)/dfloat(i+1) -c store coefficients in elco and tesco. -------------------------------- - elco(1,nq) = pint*rq1fac - elco(2,nq) = 1.0d0 - do 130 i = 2,nq - 130 elco(i+1,nq) = rq1fac*pc(i)/dfloat(i) - agamq = rqfac*xpin - ragq = 1.0d0/agamq - tesco(2,nq) = ragq - if (nq .lt. 12) tesco(1,nqp1) = ragq*rqfac/dfloat(nqp1) - tesco(3,nqm1) = ragq - 140 continue - return -c - 200 pc(1) = 1.0d0 - rq1fac = 1.0d0 - do 230 nq = 1,5 -c----------------------------------------------------------------------- -c the pc array will contain the coefficients of the polynomial -c p(x) = (x+1)*(x+2)*...*(x+nq). -c initially, p(x) = 1. -c----------------------------------------------------------------------- - fnq = dfloat(nq) - nqp1 = nq + 1 -c form coefficients of p(x)*(x+nq). ------------------------------------ - pc(nqp1) = 0.0d0 - do 210 ib = 1,nq - i = nq + 2 - ib - 210 pc(i) = pc(i-1) + fnq*pc(i) - pc(1) = fnq*pc(1) -c store coefficients in elco and tesco. -------------------------------- - do 220 i = 1,nqp1 - 220 elco(i,nq) = pc(i)/pc(2) - elco(2,nq) = 1.0d0 - tesco(1,nq) = rq1fac - tesco(2,nq) = dfloat(nqp1)/elco(1,nq) - tesco(3,nq) = dfloat(nq+2)/elco(1,nq) - rq1fac = rq1fac/fnq - 230 continue - return -c----------------------- end of subroutine cfode ----------------------- - end - subroutine cdrv - * (n, r,c,ic, ia,ja,a, b, z, nsp,isp,rsp,esp, path, flag) -clll. optimize -c*** subroutine cdrv -c*** driver for subroutines for solving sparse nonsymmetric systems of -c linear equations (compressed pointer storage) -c -c -c parameters -c class abbreviations are-- -c n - integer variable -c f - real variable -c v - supplies a value to the driver -c r - returns a result from the driver -c i - used internally by the driver -c a - array -c -c class - parameter -c ------+---------- -c - -c the nonzero entries of the coefficient matrix m are stored -c row-by-row in the array a. to identify the individual nonzero -c entries in each row, we need to know in which column each entry -c lies. the column indices which correspond to the nonzero entries -c of m are stored in the array ja. i.e., if a(k) = m(i,j), then -c ja(k) = j. in addition, we need to know where each row starts and -c how long it is. the index positions in ja and a where the rows of -c m begin are stored in the array ia. i.e., if m(i,j) is the first -c nonzero entry (stored) in the i-th row and a(k) = m(i,j), then -c ia(i) = k. moreover, the index in ja and a of the first location -c following the last element in the last row is stored in ia(n+1). -c thus, the number of entries in the i-th row is given by -c ia(i+1) - ia(i), the nonzero entries of the i-th row are stored -c consecutively in -c a(ia(i)), a(ia(i)+1), ..., a(ia(i+1)-1), -c and the corresponding column indices are stored consecutively in -c ja(ia(i)), ja(ia(i)+1), ..., ja(ia(i+1)-1). -c for example, the 5 by 5 matrix -c ( 1. 0. 2. 0. 0.) -c ( 0. 3. 0. 0. 0.) -c m = ( 0. 4. 5. 6. 0.) -c ( 0. 0. 0. 7. 0.) -c ( 0. 0. 0. 8. 9.) -c would be stored as -c - 1 2 3 4 5 6 7 8 9 -c ---+-------------------------- -c ia - 1 3 4 7 8 10 -c ja - 1 3 2 2 3 4 4 4 5 -c a - 1. 2. 3. 4. 5. 6. 7. 8. 9. . -c -c nv - n - number of variables/equations. -c fva - a - nonzero entries of the coefficient matrix m, stored -c - by rows. -c - size = number of nonzero entries in m. -c nva - ia - pointers to delimit the rows in a. -c - size = n+1. -c nva - ja - column numbers corresponding to the elements of a. -c - size = size of a. -c fva - b - right-hand side b. b and z can the same array. -c - size = n. -c fra - z - solution x. b and z can be the same array. -c - size = n. -c -c the rows and columns of the original matrix m can be -c reordered (e.g., to reduce fillin or ensure numerical stability) -c before calling the driver. if no reordering is done, then set -c r(i) = c(i) = ic(i) = i for i=1,...,n. the solution z is returned -c in the original order. -c if the columns have been reordered (i.e., c(i).ne.i for some -c i), then the driver will CALL a subroutine (nroc) which rearranges -c each row of ja and a, leaving the rows in the original order, but -c placing the elements of each row in increasing order with respect -c to the new ordering. if path.ne.1, then nroc is assumed to have -c been called already. -c -c nva - r - ordering of the rows of m. -c - size = n. -c nva - c - ordering of the columns of m. -c - size = n. -c nva - ic - inverse of the ordering of the columns of m. i.e., -c - ic(c(i)) = i for i=1,...,n. -c - size = n. -c -c the solution of the system of linear equations is divided into -c three stages -- -c nsfc -- the matrix m is processed symbolically to determine where -c fillin will occur during the numeric factorization. -c nnfc -- the matrix m is factored numerically into the product ldu -c of a unit lower triangular matrix l, a diagonal matrix -c d, and a unit upper triangular matrix u, and the system -c mx = b is solved. -c nnsc -- the linear system mx = b is solved using the ldu -c or factorization from nnfc. -c nntc -- the transposed linear system mt x = b is solved using -c the ldu factorization from nnf. -c for several systems whose coefficient matrices have the same -c nonzero structure, nsfc need be done only once (for the first -c system). then nnfc is done once for each additional system. for -c several systems with the same coefficient matrix, nsfc and nnfc -c need be done only once (for the first system). then nnsc or nntc -c is done once for each additional right-hand side. -c -c nv - path - path specification. values and their meanings are -- -c - 1 perform nroc, nsfc, and nnfc. -c - 2 perform nnfc only (nsfc is assumed to have been -c - done in a manner compatible with the storage -c - allocation used in the driver). -c - 3 perform nnsc only (nsfc and nnfc are assumed to -c - have been done in a manner compatible with the -c - storage allocation used in the driver). -c - 4 perform nntc only (nsfc and nnfc are assumed to -c - have been done in a manner compatible with the -c - storage allocation used in the driver). -c - 5 perform nroc and nsfc. -c -c various errors are detected by the driver and the individual -c subroutines. -c -c nr - flag - error flag. values and their meanings are -- -c - 0 no errors detected -c - n+k null row in a -- row = k -c - 2n+k duplicate entry in a -- row = k -c - 3n+k insufficient storage in nsfc -- row = k -c - 4n+1 insufficient storage in nnfc -c - 5n+k null pivot -- row = k -c - 6n+k insufficient storage in nsfc -- row = k -c - 7n+1 insufficient storage in nnfc -c - 8n+k zero pivot -- row = k -c - 10n+1 insufficient storage in cdrv -c - 11n+1 illegal path specification -c -c working storage is needed for the factored form of the matrix -c m plus various temporary vectors. the arrays isp and rsp should be -c equivalenced. integer storage is allocated from the beginning of -c isp and real storage from the end of rsp. -c -c nv - nsp - declared dimension of rsp. nsp generally must -c - be larger than 8n+2 + 2k (where k = (number of -c - nonzero entries in m)). -c nvira - isp - integer working storage divided up into various arrays -c - needed by the subroutines. isp and rsp should be -c - equivalenced. -c - size = lratio*nsp. -c fvira - rsp - real working storage divided up into various arrays -c - needed by the subroutines. isp and rsp should be -c - equivalenced. -c - size = nsp. -c nr - esp - if sufficient storage was available to perform the -c - symbolic factorization (nsfc), then esp is set to -c - the amount of excess storage provided (negative if -c - insufficient storage was available to perform the -c - numeric factorization (nnfc)). -c -c -c conversion to KPP_REAL -c -c to convert these routines for KPP_REAL arrays.. -c (1) use the KPP_REAL declarations in place of the real -c declarations in each subprogram, as given in comment cards. -c (2) change the data-loaded value of the integer lratio -c in subroutine cdrv, as indicated below. -c (3) change e0 to d0 in the constants in statement number 10 -c in subroutine nnfc and the line following that. -c - integer r(1), c(1), ic(1), ia(1), ja(1), isp(1), esp, path, - * flag, d, u, q, row, tmp, ar, umax - KPP_REAL a(1), b(1), z(1), rsp(1) -c -c set lratio equal to the ratio between the length of floating point -c and integer array data. e. g., lratio = 1 for (real, integer), -c lratio = 2 for (KPP_REAL, integer) -c - data lratio/2/ -c - if (path.lt.1 .or. 5.lt.path) go to 111 -c******initialize and divide up temporary storage ******************* - il = 1 - ijl = il + (n+1) - iu = ijl + n - iju = iu + (n+1) - irl = iju + n - jrl = irl + n - jl = jrl + n -c -c ****** reorder a if necessary, CALL nsfc if flag is set *********** - if ((path-1) * (path-5) .ne. 0) go to 5 - max = (lratio*nsp + 1 - jl) - (n+1) - 5*n - jlmax = max/2 - q = jl + jlmax - ira = q + (n+1) - jra = ira + n - irac = jra + n - iru = irac + n - jru = iru + n - jutmp = jru + n - jumax = lratio*nsp + 1 - jutmp - esp = max/lratio - if (jlmax.le.0 .or. jumax.le.0) go to 110 -c - do 1 i=1,n - if (c(i).ne.i) go to 2 - 1 continue - go to 3 - 2 ar = nsp + 1 - n - CALL nroc - * (n, ic, ia,ja,a, isp(il), rsp(ar), isp(iu), flag) - if (flag.ne.0) go to 100 -c - 3 CALL nsfc - * (n, r, ic, ia,ja, - * jlmax, isp(il), isp(jl), isp(ijl), - * jumax, isp(iu), isp(jutmp), isp(iju), - * isp(q), isp(ira), isp(jra), isp(irac), - * isp(irl), isp(jrl), isp(iru), isp(jru), flag) - if(flag .ne. 0) go to 100 -c ****** move ju next to jl ***************************************** - jlmax = isp(ijl+n-1) - ju = jl + jlmax - jumax = isp(iju+n-1) - if (jumax.le.0) go to 5 - do 4 j=1,jumax - 4 isp(ju+j-1) = isp(jutmp+j-1) -c -c ****** CALL remaining subroutines ********************************* - 5 jlmax = isp(ijl+n-1) - ju = jl + jlmax - jumax = isp(iju+n-1) - l = (ju + jumax - 2 + lratio) / lratio + 1 - lmax = isp(il+n) - 1 - d = l + lmax - u = d + n - row = nsp + 1 - n - tmp = row - n - umax = tmp - u - esp = umax - (isp(iu+n) - 1) -c - if ((path-1) * (path-2) .ne. 0) go to 6 - if (umax.lt.0) go to 110 - CALL nnfc - * (n, r, c, ic, ia, ja, a, z, b, - * lmax, isp(il), isp(jl), isp(ijl), rsp(l), rsp(d), - * umax, isp(iu), isp(ju), isp(iju), rsp(u), - * rsp(row), rsp(tmp), isp(irl), isp(jrl), flag) - if(flag .ne. 0) go to 100 -c - 6 if ((path-3) .ne. 0) go to 7 - CALL nnsc - * (n, r, c, isp(il), isp(jl), isp(ijl), rsp(l), - * rsp(d), isp(iu), isp(ju), isp(iju), rsp(u), - * z, b, rsp(tmp)) -c - 7 if ((path-4) .ne. 0) go to 8 - CALL nntc - * (n, r, c, isp(il), isp(jl), isp(ijl), rsp(l), - * rsp(d), isp(iu), isp(ju), isp(iju), rsp(u), - * z, b, rsp(tmp)) - 8 return -c -c ** error.. error detected in nroc, nsfc, nnfc, or nnsc - 100 return -c ** error.. insufficient storage - 110 flag = 10*n + 1 - return -c ** error.. illegal path specification - 111 flag = 11*n + 1 - return - end - subroutine prep (neq, y, yh, savf, ewt, ftem, ia, ja, - 1 wk, iwk, ipper, f, jac) -clll. optimize - external f,jac - integer neq(*), ia(*), ja(*), iwk(*), ipper - integer iownd, iowns, - 1 icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, - 2 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu - integer iplost, iesp, istatc, iys, iba, ibian, ibjan, ibjgp, - 1 ipian, ipjan, ipjgp, ipigp, ipr, ipc, ipic, ipisp, iprsp, ipa, - 2 lenyh, lenyhm, lenwk, lreq, lrat, lrest, lwmin, moss, msbj, - 3 nslj, ngp, nlu, nnz, nsp, nzl, nzu - integer i, ibr, ier, ipil, ipiu, iptt1, iptt2, j, jfound, k, - 1 knew, kmax, kmin, ldif, lenigp, liwk, maxg, np1, nzsut - KPP_REAL y(*), yh(*), savf(*), ewt(*), ftem(*), wk(*) - KPP_REAL rowns, - 1 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround - KPP_REAL con0, conmin, ccmxj, psmall, rbig, seth - KPP_REAL dq, dyj, erwt, fac, yj, JJJ(n,n) - common /ls0001/ rowns(209), - 2 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround, - 3 iownd(14), iowns(6), - 4 icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, - 5 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu - common /lss001/ con0, conmin, ccmxj, psmall, rbig, seth, - 1 iplost, iesp, istatc, iys, iba, ibian, ibjan, ibjgp, - 2 ipian, ipjan, ipjgp, ipigp, ipr, ipc, ipic, ipisp, iprsp, ipa, - 3 lenyh, lenyhm, lenwk, lreq, lrat, lrest, lwmin, moss, msbj, - 4 nslj, ngp, nlu, nnz, nsp, nzl, nzu -c----------------------------------------------------------------------- -c this routine performs preprocessing related to the sparse linear -c systems that must be solved if miter = 1 or 2. -c the operations that are performed here are.. -c * compute sparseness structure of jacobian according to moss, -c * compute grouping of column indices (miter = 2), -c * compute a new ordering of rows and columns of the matrix, -c * reorder ja corresponding to the new ordering, -c * perform a symbolic lu factorization of the matrix, and -c * set pointers for segments of the iwk/wk array. -c in addition to variables described previously, prep uses the -c following for communication.. -c yh = the history array. only the first column, containing the -c current y vector, is used. used only if moss .ne. 0. -c savf = a work array of length neq, used only if moss .ne. 0. -c ewt = array of length neq containing (inverted) error weights. -c used only if moss = 2 or if istate = moss = 1. -c ftem = a work array of length neq, identical to acor in the driver, -c used only if moss = 2. -c wk = a real work array of length lenwk, identical to wm in -c the driver. -c iwk = integer work array, assumed to occupy the same space as wk. -c lenwk = the length of the work arrays wk and iwk. -c istatc = a copy of the driver input argument istate (= 1 on the -c first call, = 3 on a continuation call). -c iys = flag value from odrv or cdrv. -c ipper = output error flag with the following values and meanings.. -c 0 no error. -c -1 insufficient storage for internal structure pointers. -c -2 insufficient storage for jgroup. -c -3 insufficient storage for odrv. -c -4 other error flag from odrv (should never occur). -c -5 insufficient storage for cdrv. -c -6 other error flag from cdrv. -c----------------------------------------------------------------------- - ibian = lrat*2 - ipian = ibian + 1 - np1 = n + 1 - ipjan = ipian + np1 - ibjan = ipjan - 1 - liwk = lenwk*lrat - if (ipjan+n-1 .gt. liwk) go to 210 - if (moss .eq. 0) go to 30 -c - if (istatc .eq. 3) go to 20 -c istate = 1 and moss .ne. 0. perturb y for structure determination. -- - do 10 i = 1,n - erwt = 1.0d0/ewt(i) - fac = 1.0d0 + 1.0d0/(dfloat(i)+1.0d0) - y(i) = y(i) + fac*DSIGN(erwt,y(i)) - 10 continue - go to (70, 100), moss -c - 20 continue -c istate = 3 and moss .ne. 0. load y from yh(*,1). -------------------- - do 25 i = 1,n - 25 y(i) = yh(i) - go to (70, 100), moss -c -c moss = 0. process user-s ia,ja. add diagonal entries if necessary. - - 30 knew = ipjan - kmin = ia(1) - iwk(ipian) = 1 - do 60 j = 1,n - jfound = 0 - kmax = ia(j+1) - 1 - if (kmin .gt. kmax) go to 45 - do 40 k = kmin,kmax - i = ja(k) - if (i .eq. j) jfound = 1 - if (knew .gt. liwk) go to 210 - iwk(knew) = i - knew = knew + 1 - 40 continue - if (jfound .eq. 1) go to 50 - 45 if (knew .gt. liwk) go to 210 - iwk(knew) = j - knew = knew + 1 - 50 iwk(ipian+j) = knew + 1 - ipjan - kmin = kmax + 1 - 60 continue - go to 140 -c -c moss = 1. compute structure from user-supplied jacobian routine jac. - 70 continue -c a dummy CALL to f allows user to create temporaries for use in jac. -- - CALL f (neq, tn, y, savf) - k = ipjan - iwk(ipian) = 1 - call jac_chem (neq, tn, y, JJJ, j, iwk(ipian), iwk(ipjan)) - do 90 j = 1,n - if (k .gt. liwk) go to 210 - iwk(k) = j - k = k + 1 - do 75 i = 1,n - 75 savf(i) = 0.0d0 -C call jac_chem (neq, tn, y, j, iwk(ipian), iwk(ipjan), savf) - do i=1,n - savf(i) = JJJ(i,j) - end do - do 80 i = 1,n - if (dabs(savf(i)) .le. seth) go to 80 - if (i .eq. j) go to 80 - if (k .gt. liwk) go to 210 - iwk(k) = i - k = k + 1 - 80 continue - iwk(ipian+j) = k + 1 - ipjan - 90 continue - go to 140 -c -c moss = 2. compute structure from results of n + 1 calls to f. ------- - 100 k = ipjan - iwk(ipian) = 1 - CALL f (neq, tn, y, savf) - do 120 j = 1,n - if (k .gt. liwk) go to 210 - iwk(k) = j - k = k + 1 - yj = y(j) - erwt = 1.0d0/ewt(j) - dyj = DSIGN(erwt,yj) - y(j) = yj + dyj - CALL f (neq, tn, y, ftem) - y(j) = yj - do 110 i = 1,n - dq = (ftem(i) - savf(i))/dyj - if (dabs(dq) .le. seth) go to 110 - if (i .eq. j) go to 110 - if (k .gt. liwk) go to 210 - iwk(k) = i - k = k + 1 - 110 continue - iwk(ipian+j) = k + 1 - ipjan - 120 continue -c - 140 continue - if (moss .eq. 0 .or. istatc .ne. 1) go to 150 -c if istate = 1 and moss .ne. 0, restore y from yh. -------------------- - do 145 i = 1,n - 145 y(i) = yh(i) - 150 nnz = iwk(ipian+n) - 1 - lenigp = 0 - ipigp = ipjan + nnz - if (miter .ne. 2) go to 160 -c -c compute grouping of column indices (miter = 2). ---------------------- - maxg = np1 - ipjgp = ipjan + nnz - ibjgp = ipjgp - 1 - ipigp = ipjgp + n - iptt1 = ipigp + np1 - iptt2 = iptt1 + n - lreq = iptt2 + n - 1 - if (lreq .gt. liwk) go to 220 - CALL jgroup (n, iwk(ipian), iwk(ipjan), maxg, ngp, iwk(ipigp), - 1 iwk(ipjgp), iwk(iptt1), iwk(iptt2), ier) - if (ier .ne. 0) go to 220 - lenigp = ngp + 1 -c -c compute new ordering of rows/columns of jacobian. -------------------- - 160 ipr = ipigp + lenigp - ipc = ipr - ipic = ipc + n - ipisp = ipic + n - iprsp = (ipisp - 2)/lrat + 2 - iesp = lenwk + 1 - iprsp - if (iesp .lt. 0) go to 230 - ibr = ipr - 1 - do 170 i = 1,n - 170 iwk(ibr+i) = i - nsp = liwk + 1 - ipisp - CALL odrv (n, iwk(ipian), iwk(ipjan), wk, iwk(ipr), iwk(ipic), - 1 nsp, iwk(ipisp), 1, iys) - if (iys .eq. 11*n+1) go to 240 - if (iys .ne. 0) go to 230 -c -c reorder jan and do symbolic lu factorization of matrix. -------------- - ipa = lenwk + 1 - nnz - nsp = ipa - iprsp - lreq = max0(12*n/lrat, 6*n/lrat+2*n+nnz) + 3 - lreq = lreq + iprsp - 1 + nnz - if (lreq .gt. lenwk) go to 250 - iba = ipa - 1 - do 180 i = 1,nnz - 180 wk(iba+i) = 0.0d0 - ipisp = lrat*(iprsp - 1) + 1 - CALL cdrv (n,iwk(ipr),iwk(ipc),iwk(ipic),iwk(ipian),iwk(ipjan), - 1 wk(ipa),wk(ipa),wk(ipa),nsp,iwk(ipisp),wk(iprsp),iesp,5,iys) - lreq = lenwk - iesp - if (iys .eq. 10*n+1) go to 250 - if (iys .ne. 0) go to 260 - ipil = ipisp - ipiu = ipil + 2*n + 1 - nzu = iwk(ipil+n) - iwk(ipil) - nzl = iwk(ipiu+n) - iwk(ipiu) - if (lrat .gt. 1) go to 190 - CALL adjlr (n, iwk(ipisp), ldif) - lreq = lreq + ldif - 190 continue - if (lrat .eq. 2 .and. nnz .eq. n) lreq = lreq + 1 - nsp = nsp + lreq - lenwk - ipa = lreq + 1 - nnz - iba = ipa - 1 - ipper = 0 - return -c - 210 ipper = -1 - lreq = 2 + (2*n + 1)/lrat - lreq = max0(lenwk+1,lreq) - return -c - 220 ipper = -2 - lreq = (lreq - 1)/lrat + 1 - return -c - 230 ipper = -3 - CALL cntnzu (n, iwk(ipian), iwk(ipjan), nzsut) - lreq = lenwk - iesp + (3*n + 4*nzsut - 1)/lrat + 1 - return -c - 240 ipper = -4 - return -c - 250 ipper = -5 - return -c - 260 ipper = -6 - lreq = lenwk - return -c----------------------- end of subroutine prep ------------------------ - end - subroutine cntnzu (n, ia, ja, nzsut) - integer n, ia, ja, nzsut - dimension ia(1), ja(1) -c----------------------------------------------------------------------- -c this routine counts the number of nonzero elements in the strict -c upper triangle of the matrix m + m(transpose), where the sparsity -c structure of m is given by pointer arrays ia and ja. -c this is needed to compute the storage requirements for the -c sparse matrix reordering operation in odrv. -c----------------------------------------------------------------------- - integer ii, jj, j, jmin, jmax, k, kmin, kmax, num -c - num = 0 - do 50 ii = 1,n - jmin = ia(ii) - jmax = ia(ii+1) - 1 - if (jmin .gt. jmax) go to 50 - do 40 j = jmin,jmax - if (ja(j) - ii) 10, 40, 30 - 10 jj =ja(j) - kmin = ia(jj) - kmax = ia(jj+1) - 1 - if (kmin .gt. kmax) go to 30 - do 20 k = kmin,kmax - if (ja(k) .eq. ii) go to 40 - 20 continue - 30 num = num + 1 - 40 continue - 50 continue - nzsut = num - return -c----------------------- end of subroutine cntnzu ---------------------- - end - subroutine nntc - * (n, r, c, il, jl, ijl, l, d, iu, ju, iju, u, z, b, tmp) -clll. optimize -c*** subroutine nntc -c*** numeric solution of the transpose of a sparse nonsymmetric system -c of linear equations given lu-factorization (compressed pointer -c storage) -c -c -c input variables.. n, r, c, il, jl, ijl, l, d, iu, ju, iju, u, b -c output variables.. z -c -c parameters used internally.. -c fia - tmp - temporary vector which gets result of solving ut y = b -c - size = n. -c -c internal variables.. -c jmin, jmax - indices of the first and last positions in a row of -c u or l to be used. -c - integer r(1), c(1), il(1), jl(1), ijl(1), iu(1), ju(1), iju(1) - KPP_REAL l(1), d(1), u(1), b(1), z(1), tmp(1), tmpk,sum -c -c ****** set tmp to reordered b ************************************* - do 1 k=1,n - 1 tmp(k) = b(c(k)) -c ****** solve ut y = b by forward substitution ******************* - do 3 k=1,n - jmin = iu(k) - jmax = iu(k+1) - 1 - tmpk = -tmp(k) - if (jmin .gt. jmax) go to 3 - mu = iju(k) - jmin - do 2 j=jmin,jmax - 2 tmp(ju(mu+j)) = tmp(ju(mu+j)) + tmpk * u(j) - 3 continue -c ****** solve lt x = y by back substitution ********************** - k = n - do 6 i=1,n - sum = -tmp(k) - jmin = il(k) - jmax = il(k+1) - 1 - if (jmin .gt. jmax) go to 5 - ml = ijl(k) - jmin - do 4 j=jmin,jmax - 4 sum = sum + l(j) * tmp(jl(ml+j)) - 5 tmp(k) = -sum * d(k) - z(r(k)) = tmp(k) - k = k - 1 - 6 continue - return - end - subroutine nnsc - * (n, r, c, il, jl, ijl, l, d, iu, ju, iju, u, z, b, tmp) -clll. optimize -c*** subroutine nnsc -c*** numerical solution of sparse nonsymmetric system of linear -c equations given ldu-factorization (compressed pointer storage) -c -c -c input variables.. n, r, c, il, jl, ijl, l, d, iu, ju, iju, u, b -c output variables.. z -c -c parameters used internally.. -c fia - tmp - temporary vector which gets result of solving ly = b. -c - size = n. -c -c internal variables.. -c jmin, jmax - indices of the first and last positions in a row of -c u or l to be used. -c - integer r(1), c(1), il(1), jl(1), ijl(1), iu(1), ju(1), iju(1) - KPP_REAL l(1), d(1), u(1), b(1), z(1), tmp(1), tmpk,sum -c -c ****** set tmp to reordered b ************************************* - do 1 k=1,n - 1 tmp(k) = b(r(k)) -c ****** solve ly = b by forward substitution ********************* - do 3 k=1,n - jmin = il(k) - jmax = il(k+1) - 1 - tmpk = -d(k) * tmp(k) - tmp(k) = -tmpk - if (jmin .gt. jmax) go to 3 - ml = ijl(k) - jmin - do 2 j=jmin,jmax - 2 tmp(jl(ml+j)) = tmp(jl(ml+j)) + tmpk * l(j) - 3 continue -c ****** solve ux = y by back substitution ************************ - k = n - do 6 i=1,n - sum = -tmp(k) - jmin = iu(k) - jmax = iu(k+1) - 1 - if (jmin .gt. jmax) go to 5 - mu = iju(k) - jmin - do 4 j=jmin,jmax - 4 sum = sum + u(j) * tmp(ju(mu+j)) - 5 tmp(k) = -sum - z(c(k)) = -sum - k = k - 1 - 6 continue - return - end - subroutine nroc (n, ic, ia, ja, a, jar, ar, p, flag) -clll. optimize -c -c ---------------------------------------------------------------- -c -c yale sparse matrix package - nonsymmetric codes -c solving the system of equations mx = b -c -c i. calling sequences -c the coefficient matrix can be processed by an ordering routine -c (e.g., to reduce fillin or ensure numerical stability) before using -c the remaining subroutines. if no reordering is done, then set -c r(i) = c(i) = ic(i) = i for i=1,...,n. if an ordering subroutine -c is used, then nroc should be used to reorder the coefficient matrix -c the calling sequence is -- -c ( (matrix ordering)) -c (nroc (matrix reordering)) -c nsfc (symbolic factorization to determine where fillin will -c occur during numeric factorization) -c nnfc (numeric factorization into product ldu of unit lower -c triangular matrix l, diagonal matrix d, and unit -c upper triangular matrix u, and solution of linear -c system) -c nnsc (solution of linear system for additional right-hand -c side using ldu factorization from nnfc) -c (if only one system of equations is to be solved, then the -c subroutine trk should be used.) -c -c ii. storage of sparse matrices -c the nonzero entries of the coefficient matrix m are stored -c row-by-row in the array a. to identify the individual nonzero -c entries in each row, we need to know in which column each entry -c lies. the column indices which correspond to the nonzero entries -c of m are stored in the array ja. i.e., if a(k) = m(i,j), then -c ja(k) = j. in addition, we need to know where each row starts and -c how long it is. the index positions in ja and a where the rows of -c m begin are stored in the array ia. i.e., if m(i,j) is the first -c (leftmost) entry in the i-th row and a(k) = m(i,j), then -c ia(i) = k. moreover, the index in ja and a of the first location -c following the last element in the last row is stored in ia(n+1). -c thus, the number of entries in the i-th row is given by -c ia(i+1) - ia(i), the nonzero entries of the i-th row are stored -c consecutively in -c a(ia(i)), a(ia(i)+1), ..., a(ia(i+1)-1), -c and the corresponding column indices are stored consecutively in -c ja(ia(i)), ja(ia(i)+1), ..., ja(ia(i+1)-1). -c for example, the 5 by 5 matrix -c ( 1. 0. 2. 0. 0.) -c ( 0. 3. 0. 0. 0.) -c m = ( 0. 4. 5. 6. 0.) -c ( 0. 0. 0. 7. 0.) -c ( 0. 0. 0. 8. 9.) -c would be stored as -c - 1 2 3 4 5 6 7 8 9 -c ---+-------------------------- -c ia - 1 3 4 7 8 10 -c ja - 1 3 2 2 3 4 4 4 5 -c a - 1. 2. 3. 4. 5. 6. 7. 8. 9. . -c -c the strict upper (lower) triangular portion of the matrix -c u (l) is stored in a similar fashion using the arrays iu, ju, u -c (il, jl, l) except that an additional array iju (ijl) is used to -c compress storage of ju (jl) by allowing some sequences of column -c (row) indices to used for more than one row (column) (n.b., l is -c stored by columns). iju(k) (ijl(k)) points to the starting -c location in ju (jl) of entries for the kth row (column). -c compression in ju (jl) occurs in two ways. first, if a row -c (column) i was merged into the current row (column) k, and the -c number of elements merged in from (the tail portion of) row -c (column) i is the same as the final length of row (column) k, then -c the kth row (column) and the tail of row (column) i are identical -c and iju(k) (ijl(k)) points to the start of the tail. second, if -c some tail portion of the (k-1)st row (column) is identical to the -c head of the kth row (column), then iju(k) (ijl(k)) points to the -c start of that tail portion. for example, the nonzero structure of -c the strict upper triangular part of the matrix -c d 0 x x x -c 0 d 0 x x -c 0 0 d x 0 -c 0 0 0 d x -c 0 0 0 0 d -c would be represented as -c - 1 2 3 4 5 6 -c ----+------------ -c iu - 1 4 6 7 8 8 -c ju - 3 4 5 4 -c iju - 1 2 4 3 . -c the diagonal entries of l and u are assumed to be equal to one and -c are not stored. the array d contains the reciprocals of the -c diagonal entries of the matrix d. -c -c iii. additional storage savings -c in nsfc, r and ic can be the same array in the calling -c sequence if no reordering of the coefficient matrix has been done. -c in nnfc, r, c, and ic can all be the same array if no -c reordering has been done. if only the rows have been reordered, -c then c and ic can be the same array. if the row and column -c orderings are the same, then r and c can be the same array. z and -c row can be the same array. -c in nnsc or nntc, r and c can be the same array if no -c reordering has been done or if the row and column orderings are the -c same. z and b can be the same array. however, then b will be -c destroyed. -c -c iv. parameters -c following is a list of parameters to the programs. names are -c uniform among the various subroutines. class abbreviations are -- -c n - integer variable -c f - real variable -c v - supplies a value to a subroutine -c r - returns a result from a subroutine -c i - used internally by a subroutine -c a - array -c -c class - parameter -c ------+---------- -c fva - a - nonzero entries of the coefficient matrix m, stored -c - by rows. -c - size = number of nonzero entries in m. -c fva - b - right-hand side b. -c - size = n. -c nva - c - ordering of the columns of m. -c - size = n. -c fvra - d - reciprocals of the diagonal entries of the matrix d. -c - size = n. -c nr - flag - error flag. values and their meanings are -- -c - 0 no errors detected -c - n+k null row in a -- row = k -c - 2n+k duplicate entry in a -- row = k -c - 3n+k insufficient storage for jl -- row = k -c - 4n+1 insufficient storage for l -c - 5n+k null pivot -- row = k -c - 6n+k insufficient storage for ju -- row = k -c - 7n+1 insufficient storage for u -c - 8n+k zero pivot -- row = k -c nva - ia - pointers to delimit the rows of a. -c - size = n+1. -c nvra - ijl - pointers to the first element in each column in jl, -c - used to compress storage in jl. -c - size = n. -c nvra - iju - pointers to the first element in each row in ju, used -c - to compress storage in ju. -c - size = n. -c nvra - il - pointers to delimit the columns of l. -c - size = n+1. -c nvra - iu - pointers to delimit the rows of u. -c - size = n+1. -c nva - ja - column numbers corresponding to the elements of a. -c - size = size of a. -c nvra - jl - row numbers corresponding to the elements of l. -c - size = jlmax. -c nv - jlmax - declared dimension of jl. jlmax must be larger than -c - the number of nonzeros in the strict lower triangle -c - of m plus fillin minus compression. -c nvra - ju - column numbers corresponding to the elements of u. -c - size = jumax. -c nv - jumax - declared dimension of ju. jumax must be larger than -c - the number of nonzeros in the strict upper triangle -c - of m plus fillin minus compression. -c fvra - l - nonzero entries in the strict lower triangular portion -c - of the matrix l, stored by columns. -c - size = lmax. -c nv - lmax - declared dimension of l. lmax must be larger than -c - the number of nonzeros in the strict lower triangle -c - of m plus fillin (il(n+1)-1 after nsfc). -c nv - n - number of variables/equations. -c nva - r - ordering of the rows of m. -c - size = n. -c fvra - u - nonzero entries in the strict upper triangular portion -c - of the matrix u, stored by rows. -c - size = umax. -c nv - umax - declared dimension of u. umax must be larger than -c - the number of nonzeros in the strict upper triangle -c - of m plus fillin (iu(n+1)-1 after nsfc). -c fra - z - solution x. -c - size = n. -c -c ---------------------------------------------------------------- -c -c*** subroutine nroc -c*** reorders rows of a, leaving row order unchanged -c -c -c input parameters.. n, ic, ia, ja, a -c output parameters.. ja, a, flag -c -c parameters used internally.. -c nia - p - at the kth step, p is a linked list of the reordered -c - column indices of the kth row of a. p(n+1) points -c - to the first entry in the list. -c - size = n+1. -c nia - jar - at the kth step,jar contains the elements of the -c - reordered column indices of a. -c - size = n. -c fia - ar - at the kth step, ar contains the elements of the -c - reordered row of a. -c - size = n. -c - integer ic(1), ia(1), ja(1), jar(1), p(1), flag - KPP_REAL a(1), ar(1) -c -c ****** for each nonempty row ******************************* - do 5 k=1,n - jmin = ia(k) - jmax = ia(k+1) - 1 - if(jmin .gt. jmax) go to 5 - p(n+1) = n + 1 -c ****** insert each element in the list ********************* - do 3 j=jmin,jmax - newj = ic(ja(j)) - i = n + 1 - 1 if(p(i) .ge. newj) go to 2 - i = p(i) - go to 1 - 2 if(p(i) .eq. newj) go to 102 - p(newj) = p(i) - p(i) = newj - jar(newj) = ja(j) - ar(newj) = a(j) - 3 continue -c ****** replace old row in ja and a ************************* - i = n + 1 - do 4 j=jmin,jmax - i = p(i) - ja(j) = jar(i) - 4 a(j) = ar(i) - 5 continue - flag = 0 - return -c -c ** error.. duplicate entry in a - 102 flag = n + k - return - end - subroutine adjlr (n, isp, ldif) - integer n, isp, ldif - dimension isp(1) -c----------------------------------------------------------------------- -c this routine computes an adjustment, ldif, to the required -c integer storage space in iwk (sparse matrix work space). -c it is called only if the word length ratio is lrat = 1. -c this is to account for the possibility that the symbolic lu phase -c may require more storage than the numerical lu and solution phases. -c----------------------------------------------------------------------- - integer ip, jlmax, jumax, lnfc, lsfc, nzlu -c - ip = 2*n + 1 -c get jlmax = ijl(n) and jumax = iju(n) (sizes of jl and ju). ---------- - jlmax = isp(ip) - jumax = isp(ip+ip) -c nzlu = (size of l) + (size of u) = (il(n+1)-il(1)) + (iu(n+1)-iu(1)). - nzlu = isp(n+1) - isp(1) + isp(ip+n+1) - isp(ip+1) - lsfc = 12*n + 3 + 2*max0(jlmax,jumax) - lnfc = 9*n + 2 + jlmax + jumax + nzlu - ldif = max0(0, lsfc - lnfc) - return -c----------------------- end of subroutine adjlr ----------------------- - end - subroutine odrv - * (n, ia,ja,a, p,ip, nsp,isp, path, flag) -clll. optimize -c 5/2/83 -c*********************************************************************** -c odrv -- driver for sparse matrix reordering routines -c*********************************************************************** -c -c description -c -c odrv finds a minimum degree ordering of the rows and columns -c of a matrix m stored in (ia,ja,a) format (see below). for the -c reordered matrix, the work and storage required to perform -c gaussian elimination is (usually) significantly less. -c -c note.. odrv and its subordinate routines have been modified to -c compute orderings for general matrices, not necessarily having any -c symmetry. the miminum degree ordering is computed for the -c structure of the symmetric matrix m + m-transpose. -c modifications to the original odrv module have been made in -c the coding in subroutine mdi, and in the initial comments in -c subroutines odrv and md. -c -c if only the nonzero entries in the upper triangle of m are being -c stored, then odrv symmetrically reorders (ia,ja,a), (optionally) -c with the diagonal entries placed first in each row. this is to -c ensure that if m(i,j) will be in the upper triangle of m with -c respect to the new ordering, then m(i,j) is stored in row i (and -c thus m(j,i) is not stored), whereas if m(i,j) will be in the -c strict lower triangle of m, then m(j,i) is stored in row j (and -c thus m(i,j) is not stored). -c -c -c storage of sparse matrices -c -c the nonzero entries of the matrix m are stored row-by-row in the -c array a. to identify the individual nonzero entries in each row, -c we need to know in which column each entry lies. these column -c indices are stored in the array ja. i.e., if a(k) = m(i,j), then -c ja(k) = j. to identify the individual rows, we need to know where -c each row starts. these row pointers are stored in the array ia. -c i.e., if m(i,j) is the first nonzero entry (stored) in the i-th row -c and a(k) = m(i,j), then ia(i) = k. moreover, ia(n+1) points to -c the first location following the last element in the last row. -c thus, the number of entries in the i-th row is ia(i+1) - ia(i), -c the nonzero entries in the i-th row are stored consecutively in -c -c a(ia(i)), a(ia(i)+1), ..., a(ia(i+1)-1), -c -c and the corresponding column indices are stored consecutively in -c -c ja(ia(i)), ja(ia(i)+1), ..., ja(ia(i+1)-1). -c -c since the coefficient matrix is symmetric, only the nonzero entries -c in the upper triangle need be stored. for example, the matrix -c -c ( 1 0 2 3 0 ) -c ( 0 4 0 0 0 ) -c m = ( 2 0 5 6 0 ) -c ( 3 0 6 7 8 ) -c ( 0 0 0 8 9 ) -c -c could be stored as -c -c - 1 2 3 4 5 6 7 8 9 10 11 12 13 -c ---+-------------------------------------- -c ia - 1 4 5 8 12 14 -c ja - 1 3 4 2 1 3 4 1 3 4 5 4 5 -c a - 1 2 3 4 2 5 6 3 6 7 8 8 9 -c -c or (symmetrically) as -c -c - 1 2 3 4 5 6 7 8 9 -c ---+-------------------------- -c ia - 1 4 5 7 9 10 -c ja - 1 3 4 2 3 4 4 5 5 -c a - 1 2 3 4 5 6 7 8 9 . -c -c -c parameters -c -c n - order of the matrix -c -c ia - integer one-dimensional array containing pointers to delimit -c rows in ja and a. dimension = n+1 -c -c ja - integer one-dimensional array containing the column indices -c corresponding to the elements of a. dimension = number of -c nonzero entries in (the upper triangle of) m -c -c a - real one-dimensional array containing the nonzero entries in -c (the upper triangle of) m, stored by rows. dimension = -c number of nonzero entries in (the upper triangle of) m -c -c p - integer one-dimensional array used to return the permutation -c of the rows and columns of m corresponding to the minimum -c degree ordering. dimension = n -c -c ip - integer one-dimensional array used to return the inverse of -c the permutation returned in p. dimension = n -c -c nsp - declared dimension of the one-dimensional array isp. nsp -c must be at least 3n+4k, where k is the number of nonzeroes -c in the strict upper triangle of m -c -c isp - integer one-dimensional array used for working storage. -c dimension = nsp -c -c path - integer path specification. values and their meanings are - -c 1 find minimum degree ordering only -c 2 find minimum degree ordering and reorder symmetrically -c stored matrix (used when only the nonzero entries in -c the upper triangle of m are being stored) -c 3 reorder symmetrically stored matrix as specified by -c input permutation (used when an ordering has already -c been determined and only the nonzero entries in the -c upper triangle of m are being stored) -c 4 same as 2 but put diagonal entries at start of each row -c 5 same as 3 but put diagonal entries at start of each row -c -c flag - integer error flag. values and their meanings are - -c 0 no errors detected -c 9n+k insufficient storage in md -c 10n+1 insufficient storage in odrv -c 11n+1 illegal path specification -c -c -c conversion from real to KPP_REAL -c -c change the real declarations in odrv and sro to KPP_REAL -c declarations. -c -c----------------------------------------------------------------------- -c - integer ia(1), ja(1), p(1), ip(1), isp(1), path, flag, - * v, l, head, tmp, q - KPP_REAL a(1) - logical dflag -c -c----initialize error flag and validate path specification - flag = 0 - if (path.lt.1 .or. 5.lt.path) go to 111 -c -c----allocate storage and find minimum degree ordering - if ((path-1) * (path-2) * (path-4) .ne. 0) go to 1 - max = (nsp-n)/2 - v = 1 - l = v + max - head = l + max - next = head + n - if (max.lt.n) go to 110 -c - CALL md - * (n, ia,ja, max,isp(v),isp(l), isp(head),p,ip, isp(v), flag) - if (flag.ne.0) go to 100 -c -c----allocate storage and symmetrically reorder matrix - 1 if ((path-2) * (path-3) * (path-4) * (path-5) .ne. 0) go to 2 - tmp = (nsp+1) - n - q = tmp - (ia(n+1)-1) - if (q.lt.1) go to 110 -c - dflag = path.eq.4 .or. path.eq.5 - CALL sro - * (n, ip, ia, ja, a, isp(tmp), isp(q), dflag) -c - 2 return -c -c ** error -- error detected in md - 100 return -c ** error -- insufficient storage - 110 flag = 10*n + 1 - return -c ** error -- illegal path specified - 111 flag = 11*n + 1 - return - end - subroutine nnfc - * (n, r,c,ic, ia,ja,a, z, b, - * lmax,il,jl,ijl,l, d, umax,iu,ju,iju,u, - * row, tmp, irl,jrl, flag) -clll. optimize -c*** subroutine nnfc -c*** numerical ldu-factorization of sparse nonsymmetric matrix and -c solution of system of linear equations (compressed pointer -c storage) -c -c -c input variables.. n, r, c, ic, ia, ja, a, b, -c il, jl, ijl, lmax, iu, ju, iju, umax -c output variables.. z, l, d, u, flag -c -c parameters used internally.. -c nia - irl, - vectors used to find the rows of l. at the kth step -c nia - jrl of the factorization, jrl(k) points to the head -c - of a linked list in jrl of column indices j -c - such j .lt. k and l(k,j) is nonzero. zero -c - indicates the end of the list. irl(j) (j.lt.k) -c - points to the smallest i such that i .ge. k and -c - l(i,j) is nonzero. -c - size of each = n. -c fia - row - holds intermediate values in calculation of u and l. -c - size = n. -c fia - tmp - holds new right-hand side b* for solution of the -c - equation ux = b*. -c - size = n. -c -c internal variables.. -c jmin, jmax - indices of the first and last positions in a row to -c be examined. -c sum - used in calculating tmp. -c - integer rk,umax - integer r(1), c(1), ic(1), ia(1), ja(1), il(1), jl(1), ijl(1) - integer iu(1), ju(1), iju(1), irl(1), jrl(1), flag - KPP_REAL a(1), l(1), d(1), u(1), z(1), b(1), row(1) - KPP_REAL tmp(1), lki, sum, dk -c -c ****** initialize pointers and test storage *********************** - if(il(n+1)-1 .gt. lmax) go to 104 - if(iu(n+1)-1 .gt. umax) go to 107 - do 1 k=1,n - irl(k) = il(k) - jrl(k) = 0 - 1 continue -c -c ****** for each row *********************************************** - do 19 k=1,n -c ****** reverse jrl and zero row where kth row of l will fill in *** - row(k) = 0 - i1 = 0 - if (jrl(k) .eq. 0) go to 3 - i = jrl(k) - 2 i2 = jrl(i) - jrl(i) = i1 - i1 = i - row(i) = 0 - i = i2 - if (i .ne. 0) go to 2 -c ****** set row to zero where u will fill in *********************** - 3 jmin = iju(k) - jmax = jmin + iu(k+1) - iu(k) - 1 - if (jmin .gt. jmax) go to 5 - do 4 j=jmin,jmax - 4 row(ju(j)) = 0 -c ****** place kth row of a in row ********************************** - 5 rk = r(k) - jmin = ia(rk) - jmax = ia(rk+1) - 1 - do 6 j=jmin,jmax - row(ic(ja(j))) = a(j) - 6 continue -c ****** initialize sum, and link through jrl *********************** - sum = b(rk) - i = i1 - if (i .eq. 0) go to 10 -c ****** assign the kth row of l and adjust row, sum **************** - 7 lki = -row(i) -c ****** if l is not required, then comment out the following line ** - l(irl(i)) = -lki - sum = sum + lki * tmp(i) - jmin = iu(i) - jmax = iu(i+1) - 1 - if (jmin .gt. jmax) go to 9 - mu = iju(i) - jmin - do 8 j=jmin,jmax - 8 row(ju(mu+j)) = row(ju(mu+j)) + lki * u(j) - 9 i = jrl(i) - if (i .ne. 0) go to 7 -c -c ****** assign kth row of u and diagonal d, set tmp(k) ************* - 10 if (row(k) .eq. 0.0d0) go to 108 - dk = 1.0d0 / row(k) - d(k) = dk - tmp(k) = sum * dk - if (k .eq. n) go to 19 - jmin = iu(k) - jmax = iu(k+1) - 1 - if (jmin .gt. jmax) go to 12 - mu = iju(k) - jmin - do 11 j=jmin,jmax - 11 u(j) = row(ju(mu+j)) * dk - 12 continue -c -c ****** update irl and jrl, keeping jrl in decreasing order ******** - i = i1 - if (i .eq. 0) go to 18 - 14 irl(i) = irl(i) + 1 - i1 = jrl(i) - if (irl(i) .ge. il(i+1)) go to 17 - ijlb = irl(i) - il(i) + ijl(i) - j = jl(ijlb) - 15 if (i .gt. jrl(j)) go to 16 - j = jrl(j) - go to 15 - 16 jrl(i) = jrl(j) - jrl(j) = i - 17 i = i1 - if (i .ne. 0) go to 14 - 18 if (irl(k) .ge. il(k+1)) go to 19 - j = jl(ijl(k)) - jrl(k) = jrl(j) - jrl(j) = k - 19 continue -c -c ****** solve ux = tmp by back substitution ********************** - k = n - do 22 i=1,n - sum = tmp(k) - jmin = iu(k) - jmax = iu(k+1) - 1 - if (jmin .gt. jmax) go to 21 - mu = iju(k) - jmin - do 20 j=jmin,jmax - 20 sum = sum - u(j) * tmp(ju(mu+j)) - 21 tmp(k) = sum - z(c(k)) = sum - 22 k = k-1 - flag = 0 - return -c -c ** error.. insufficient storage for l - 104 flag = 4*n + 1 - return -c ** error.. insufficient storage for u - 107 flag = 7*n + 1 - return -c ** error.. zero pivot - 108 flag = 8*n + k - return - end - subroutine jgroup (n,ia,ja,maxg,ngrp,igp,jgp,incl,jdone,ier) -clll. optimize - integer n, ia, ja, maxg, ngrp, igp, jgp, incl, jdone, ier - dimension ia(1), ja(1), igp(1), jgp(n), incl(n), jdone(n) -c----------------------------------------------------------------------- -c this subroutine constructs groupings of the column indices of -c the jacobian matrix, used in the numerical evaluation of the -c jacobian by finite differences. -c -c input.. -c n = the order of the matrix. -c ia,ja = sparse structure descriptors of the matrix by rows. -c maxg = length of available storate in the igp array. -c -c output.. -c ngrp = number of groups. -c jgp = array of length n containing the column indices by groups. -c igp = pointer array of length ngrp + 1 to the locations in jgp -c of the beginning of each group. -c ier = error indicator. ier = 0 if no error occurred, or 1 if -c maxg was insufficient. -c -c incl and jdone are working arrays of length n. -c----------------------------------------------------------------------- - integer i, j, k, kmin, kmax, ncol, ng -c - ier = 0 - do 10 j = 1,n - 10 jdone(j) = 0 - ncol = 1 - do 60 ng = 1,maxg - igp(ng) = ncol - do 20 i = 1,n - 20 incl(i) = 0 - do 50 j = 1,n -c reject column j if it is already in a group.-------------------------- - if (jdone(j) .eq. 1) go to 50 - kmin = ia(j) - kmax = ia(j+1) - 1 - do 30 k = kmin,kmax -c reject column j if it overlaps any column already in this group.------ - i = ja(k) - if (incl(i) .eq. 1) go to 50 - 30 continue -c accept column j into group ng.---------------------------------------- - jgp(ncol) = j - ncol = ncol + 1 - jdone(j) = 1 - do 40 k = kmin,kmax - i = ja(k) - 40 incl(i) = 1 - 50 continue -c stop if this group is empty (grouping is complete).------------------- - if (ncol .eq. igp(ng)) go to 70 - 60 continue -c error return if not all columns were chosen (maxg too small).--------- - if (ncol .le. n) go to 80 - ng = maxg - 70 ngrp = ng - 1 - return - 80 ier = 1 - return -c----------------------- end of subroutine jgroup ---------------------- - end - subroutine nsfc - * (n, r, ic, ia,ja, jlmax,il,jl,ijl, jumax,iu,ju,iju, - * q, ira,jra, irac, irl,jrl, iru,jru, flag) -clll. optimize -c*** subroutine nsfc -c*** symbolic ldu-factorization of nonsymmetric sparse matrix -c (compressed pointer storage) -c -c -c input variables.. n, r, ic, ia, ja, jlmax, jumax. -c output variables.. il, jl, ijl, iu, ju, iju, flag. -c -c parameters used internally.. -c nia - q - suppose m* is the result of reordering m. if -c - processing of the ith row of m* (hence the ith -c - row of u) is being done, q(j) is initially -c - nonzero if m*(i,j) is nonzero (j.ge.i). since -c - values need not be stored, each entry points to the -c - next nonzero and q(n+1) points to the first. n+1 -c - indicates the end of the list. for example, if n=9 -c - and the 5th row of m* is -c - 0 x x 0 x 0 0 x 0 -c - then q will initially be -c - a a a a 8 a a 10 5 (a - arbitrary). -c - as the algorithm proceeds, other elements of q -c - are inserted in the list because of fillin. -c - q is used in an analogous manner to compute the -c - ith column of l. -c - size = n+1. -c nia - ira, - vectors used to find the columns of m. at the kth -c nia - jra, step of the factorization, irac(k) points to the -c nia - irac head of a linked list in jra of row indices i -c - such that i .ge. k and m(i,k) is nonzero. zero -c - indicates the end of the list. ira(i) (i.ge.k) -c - points to the smallest j such that j .ge. k and -c - m(i,j) is nonzero. -c - size of each = n. -c nia - irl, - vectors used to find the rows of l. at the kth step -c nia - jrl of the factorization, jrl(k) points to the head -c - of a linked list in jrl of column indices j -c - such j .lt. k and l(k,j) is nonzero. zero -c - indicates the end of the list. irl(j) (j.lt.k) -c - points to the smallest i such that i .ge. k and -c - l(i,j) is nonzero. -c - size of each = n. -c nia - iru, - vectors used in a manner analogous to irl and jrl -c nia - jru to find the columns of u. -c - size of each = n. -c -c internal variables.. -c jlptr - points to the last position used in jl. -c juptr - points to the last position used in ju. -c jmin,jmax - are the indices in a or u of the first and last -c elements to be examined in a given row. -c for example, jmin=ia(k), jmax=ia(k+1)-1. -c - integer cend, qm, rend, rk, vj - integer ia(1), ja(1), ira(1), jra(1), il(1), jl(1), ijl(1) - integer iu(1), ju(1), iju(1), irl(1), jrl(1), iru(1), jru(1) - integer r(1), ic(1), q(1), irac(1), flag -c -c ****** initialize pointers **************************************** - np1 = n + 1 - jlmin = 1 - jlptr = 0 - il(1) = 1 - jumin = 1 - juptr = 0 - iu(1) = 1 - do 1 k=1,n - irac(k) = 0 - jra(k) = 0 - jrl(k) = 0 - 1 jru(k) = 0 -c ****** initialize column pointers for a *************************** - do 2 k=1,n - rk = r(k) - iak = ia(rk) - if (iak .ge. ia(rk+1)) go to 101 - jaiak = ic(ja(iak)) - if (jaiak .gt. k) go to 105 - jra(k) = irac(jaiak) - irac(jaiak) = k - 2 ira(k) = iak -c -c ****** for each column of l and row of u ************************** - do 41 k=1,n -c -c ****** initialize q for computing kth column of l ***************** - q(np1) = np1 - luk = -1 -c ****** by filling in kth column of a ****************************** - vj = irac(k) - if (vj .eq. 0) go to 5 - 3 qm = np1 - 4 m = qm - qm = q(m) - if (qm .lt. vj) go to 4 - if (qm .eq. vj) go to 102 - luk = luk + 1 - q(m) = vj - q(vj) = qm - vj = jra(vj) - if (vj .ne. 0) go to 3 -c ****** link through jru ******************************************* - 5 lastid = 0 - lasti = 0 - ijl(k) = jlptr - i = k - 6 i = jru(i) - if (i .eq. 0) go to 10 - qm = np1 - jmin = irl(i) - jmax = ijl(i) + il(i+1) - il(i) - 1 - long = jmax - jmin - if (long .lt. 0) go to 6 - jtmp = jl(jmin) - if (jtmp .ne. k) long = long + 1 - if (jtmp .eq. k) r(i) = -r(i) - if (lastid .ge. long) go to 7 - lasti = i - lastid = long -c ****** and merge the corresponding columns into the kth column **** - 7 do 9 j=jmin,jmax - vj = jl(j) - 8 m = qm - qm = q(m) - if (qm .lt. vj) go to 8 - if (qm .eq. vj) go to 9 - luk = luk + 1 - q(m) = vj - q(vj) = qm - qm = vj - 9 continue - go to 6 -c ****** lasti is the longest column merged into the kth ************ -c ****** see if it equals the entire kth column ********************* - 10 qm = q(np1) - if (qm .ne. k) go to 105 - if (luk .eq. 0) go to 17 - if (lastid .ne. luk) go to 11 -c ****** if so, jl can be compressed ******************************** - irll = irl(lasti) - ijl(k) = irll + 1 - if (jl(irll) .ne. k) ijl(k) = ijl(k) - 1 - go to 17 -c ****** if not, see if kth column can overlap the previous one ***** - 11 if (jlmin .gt. jlptr) go to 15 - qm = q(qm) - do 12 j=jlmin,jlptr - if (jl(j) - qm) 12, 13, 15 - 12 continue - go to 15 - 13 ijl(k) = j - do 14 i=j,jlptr - if (jl(i) .ne. qm) go to 15 - qm = q(qm) - if (qm .gt. n) go to 17 - 14 continue - jlptr = j - 1 -c ****** move column indices from q to jl, update vectors *********** - 15 jlmin = jlptr + 1 - ijl(k) = jlmin - if (luk .eq. 0) go to 17 - jlptr = jlptr + luk - if (jlptr .gt. jlmax) go to 103 - qm = q(np1) - do 16 j=jlmin,jlptr - qm = q(qm) - 16 jl(j) = qm - 17 irl(k) = ijl(k) - il(k+1) = il(k) + luk -c -c ****** initialize q for computing kth row of u ******************** - q(np1) = np1 - luk = -1 -c ****** by filling in kth row of reordered a *********************** - rk = r(k) - jmin = ira(k) - jmax = ia(rk+1) - 1 - if (jmin .gt. jmax) go to 20 - do 19 j=jmin,jmax - vj = ic(ja(j)) - qm = np1 - 18 m = qm - qm = q(m) - if (qm .lt. vj) go to 18 - if (qm .eq. vj) go to 102 - luk = luk + 1 - q(m) = vj - q(vj) = qm - 19 continue -c ****** link through jrl, ****************************************** - 20 lastid = 0 - lasti = 0 - iju(k) = juptr - i = k - i1 = jrl(k) - 21 i = i1 - if (i .eq. 0) go to 26 - i1 = jrl(i) - qm = np1 - jmin = iru(i) - jmax = iju(i) + iu(i+1) - iu(i) - 1 - long = jmax - jmin - if (long .lt. 0) go to 21 - jtmp = ju(jmin) - if (jtmp .eq. k) go to 22 -c ****** update irl and jrl, ***************************************** - long = long + 1 - cend = ijl(i) + il(i+1) - il(i) - irl(i) = irl(i) + 1 - if (irl(i) .ge. cend) go to 22 - j = jl(irl(i)) - jrl(i) = jrl(j) - jrl(j) = i - 22 if (lastid .ge. long) go to 23 - lasti = i - lastid = long -c ****** and merge the corresponding rows into the kth row ********** - 23 do 25 j=jmin,jmax - vj = ju(j) - 24 m = qm - qm = q(m) - if (qm .lt. vj) go to 24 - if (qm .eq. vj) go to 25 - luk = luk + 1 - q(m) = vj - q(vj) = qm - qm = vj - 25 continue - go to 21 -c ****** update jrl(k) and irl(k) *********************************** - 26 if (il(k+1) .le. il(k)) go to 27 - j = jl(irl(k)) - jrl(k) = jrl(j) - jrl(j) = k -c ****** lasti is the longest row merged into the kth *************** -c ****** see if it equals the entire kth row ************************ - 27 qm = q(np1) - if (qm .ne. k) go to 105 - if (luk .eq. 0) go to 34 - if (lastid .ne. luk) go to 28 -c ****** if so, ju can be compressed ******************************** - irul = iru(lasti) - iju(k) = irul + 1 - if (ju(irul) .ne. k) iju(k) = iju(k) - 1 - go to 34 -c ****** if not, see if kth row can overlap the previous one ******** - 28 if (jumin .gt. juptr) go to 32 - qm = q(qm) - do 29 j=jumin,juptr - if (ju(j) - qm) 29, 30, 32 - 29 continue - go to 32 - 30 iju(k) = j - do 31 i=j,juptr - if (ju(i) .ne. qm) go to 32 - qm = q(qm) - if (qm .gt. n) go to 34 - 31 continue - juptr = j - 1 -c ****** move row indices from q to ju, update vectors ************** - 32 jumin = juptr + 1 - iju(k) = jumin - if (luk .eq. 0) go to 34 - juptr = juptr + luk - if (juptr .gt. jumax) go to 106 - qm = q(np1) - do 33 j=jumin,juptr - qm = q(qm) - 33 ju(j) = qm - 34 iru(k) = iju(k) - iu(k+1) = iu(k) + luk -c -c ****** update iru, jru ******************************************** - i = k - 35 i1 = jru(i) - if (r(i) .lt. 0) go to 36 - rend = iju(i) + iu(i+1) - iu(i) - if (iru(i) .ge. rend) go to 37 - j = ju(iru(i)) - jru(i) = jru(j) - jru(j) = i - go to 37 - 36 r(i) = -r(i) - 37 i = i1 - if (i .eq. 0) go to 38 - iru(i) = iru(i) + 1 - go to 35 -c -c ****** update ira, jra, irac ************************************** - 38 i = irac(k) - if (i .eq. 0) go to 41 - 39 i1 = jra(i) - ira(i) = ira(i) + 1 - if (ira(i) .ge. ia(r(i)+1)) go to 40 - irai = ira(i) - jairai = ic(ja(irai)) - if (jairai .gt. i) go to 40 - jra(i) = irac(jairai) - irac(jairai) = i - 40 i = i1 - if (i .ne. 0) go to 39 - 41 continue -c - ijl(n) = jlptr - iju(n) = juptr - flag = 0 - return -c -c ** error.. null row in a - 101 flag = n + rk - return -c ** error.. duplicate entry in a - 102 flag = 2*n + rk - return -c ** error.. insufficient storage for jl - 103 flag = 3*n + k - return -c ** error.. null pivot - 105 flag = 5*n + k - return -c ** error.. insufficient storage for ju - 106 flag = 6*n + k - return - end - subroutine sro - * (n, ip, ia,ja,a, q, r, dflag) -clll. optimize -c*********************************************************************** -c sro -- symmetric reordering of sparse symmetric matrix -c*********************************************************************** -c -c description -c -c the nonzero entries of the matrix m are assumed to be stored -c symmetrically in (ia,ja,a) format (i.e., not both m(i,j) and m(j,i) -c are stored if i ne j). -c -c sro does not rearrange the order of the rows, but does move -c nonzeroes from one row to another to ensure that if m(i,j) will be -c in the upper triangle of m with respect to the new ordering, then -c m(i,j) is stored in row i (and thus m(j,i) is not stored), whereas -c if m(i,j) will be in the strict lower triangle of m, then m(j,i) is -c stored in row j (and thus m(i,j) is not stored). -c -c -c additional parameters -c -c q - integer one-dimensional work array. dimension = n -c -c r - integer one-dimensional work array. dimension = number of -c nonzero entries in the upper triangle of m -c -c dflag - logical variable. if dflag = .true., then store nonzero -c diagonal elements at the beginning of the row -c -c----------------------------------------------------------------------- -c - integer ip(1), ia(1), ja(1), q(1), r(1) - KPP_REAL a(1), ak - logical dflag -c -c -c--phase 1 -- find row in which to store each nonzero -c----initialize count of nonzeroes to be stored in each row - do 1 i=1,n - 1 q(i) = 0 -c -c----for each nonzero element a(j) - do 3 i=1,n - jmin = ia(i) - jmax = ia(i+1) - 1 - if (jmin.gt.jmax) go to 3 - do 2 j=jmin,jmax -c -c--------find row (=r(j)) and column (=ja(j)) in which to store a(j) ... - k = ja(j) - if (ip(k).lt.ip(i)) ja(j) = i - if (ip(k).ge.ip(i)) k = i - r(j) = k -c -c--------... and increment count of nonzeroes (=q(r(j)) in that row - 2 q(k) = q(k) + 1 - 3 continue -c -c -c--phase 2 -- find new ia and permutation to apply to (ja,a) -c----determine pointers to delimit rows in permuted (ja,a) - do 4 i=1,n - ia(i+1) = ia(i) + q(i) - 4 q(i) = ia(i+1) -c -c----determine where each (ja(j),a(j)) is stored in permuted (ja,a) -c----for each nonzero element (in reverse order) - ilast = 0 - jmin = ia(1) - jmax = ia(n+1) - 1 - j = jmax - do 6 jdummy=jmin,jmax - i = r(j) - if (.not.dflag .or. ja(j).ne.i .or. i.eq.ilast) go to 5 -c -c------if dflag, then put diagonal nonzero at beginning of row - r(j) = ia(i) - ilast = i - go to 6 -c -c------put (off-diagonal) nonzero in last unused location in row - 5 q(i) = q(i) - 1 - r(j) = q(i) -c - 6 j = j-1 -c -c -c--phase 3 -- permute (ja,a) to upper triangular form (wrt new ordering) - do 8 j=jmin,jmax - 7 if (r(j).eq.j) go to 8 - k = r(j) - r(j) = r(k) - r(k) = k - jak = ja(k) - ja(k) = ja(j) - ja(j) = jak - ak = a(k) - a(k) = a(j) - a(j) = ak - go to 7 - 8 continue -c - return - end - subroutine md - * (n, ia,ja, max, v,l, head,last,next, mark, flag) -clll. optimize -c*********************************************************************** -c md -- minimum degree algorithm (based on element model) -c*********************************************************************** -c -c description -c -c md finds a minimum degree ordering of the rows and columns of a -c general sparse matrix m stored in (ia,ja,a) format. -c when the structure of m is nonsymmetric, the ordering is that -c obtained for the symmetric matrix m + m-transpose. -c -c -c additional parameters -c -c max - declared dimension of the one-dimensional arrays v and l. -c max must be at least n+2k, where k is the number of -c nonzeroes in the strict upper triangle of m + m-transpose -c -c v - integer one-dimensional work array. dimension = max -c -c l - integer one-dimensional work array. dimension = max -c -c head - integer one-dimensional work array. dimension = n -c -c last - integer one-dimensional array used to return the permutation -c of the rows and columns of m corresponding to the minimum -c degree ordering. dimension = n -c -c next - integer one-dimensional array used to return the inverse of -c the permutation returned in last. dimension = n -c -c mark - integer one-dimensional work array (may be the same as v). -c dimension = n -c -c flag - integer error flag. values and their meanings are - -c 0 no errors detected -c 9n+k insufficient storage in md -c -c -c definitions of internal parameters -c -c ---------+--------------------------------------------------------- -c v(s) - value field of list entry -c ---------+--------------------------------------------------------- -c l(s) - link field of list entry (0 =) end of list) -c ---------+--------------------------------------------------------- -c l(vi) - pointer to element list of uneliminated vertex vi -c ---------+--------------------------------------------------------- -c l(ej) - pointer to boundary list of active element ej -c ---------+--------------------------------------------------------- -c head(d) - vj =) vj head of d-list d -c - 0 =) no vertex in d-list d -c -c -c - vi uneliminated vertex -c - vi in ek - vi not in ek -c ---------+-----------------------------+--------------------------- -c next(vi) - undefined but nonnegative - vj =) vj next in d-list -c - - 0 =) vi tail of d-list -c ---------+-----------------------------+--------------------------- -c last(vi) - (not set until mdp) - -d =) vi head of d-list d -c --vk =) compute degree - vj =) vj last in d-list -c - ej =) vi prototype of ej - 0 =) vi not in any d-list -c - 0 =) do not compute degree - -c ---------+-----------------------------+--------------------------- -c mark(vi) - mark(vk) - nonneg. tag .lt. mark(vk) -c -c -c - vi eliminated vertex -c - ei active element - otherwise -c ---------+-----------------------------+--------------------------- -c next(vi) - -j =) vi was j-th vertex - -j =) vi was j-th vertex -c - to be eliminated - to be eliminated -c ---------+-----------------------------+--------------------------- -c last(vi) - m =) size of ei = m - undefined -c ---------+-----------------------------+--------------------------- -c mark(vi) - -m =) overlap count of ei - undefined -c - with ek = m - -c - otherwise nonnegative tag - -c - .lt. mark(vk) - -c -c----------------------------------------------------------------------- -c - integer ia(1), ja(1), v(1), l(1), head(1), last(1), next(1), - * mark(1), flag, tag, dmin, vk,ek, tail - equivalence (vk,ek) -c -c----initialization - tag = 0 - CALL mdi - * (n, ia,ja, max,v,l, head,last,next, mark,tag, flag) - if (flag.ne.0) return -c - k = 0 - dmin = 1 -c -c----while k .lt. n do - 1 if (k.ge.n) go to 4 -c -c------search for vertex of minimum degree - 2 if (head(dmin).gt.0) go to 3 - dmin = dmin + 1 - go to 2 -c -c------remove vertex vk of minimum degree from degree list - 3 vk = head(dmin) - head(dmin) = next(vk) - if (head(dmin).gt.0) last(head(dmin)) = -dmin -c -c------number vertex vk, adjust tag, and tag vk - k = k+1 - next(vk) = -k - last(ek) = dmin - 1 - tag = tag + last(ek) - mark(vk) = tag -c -c------form element ek from uneliminated neighbors of vk - CALL mdm - * (vk,tail, v,l, last,next, mark) -c -c------purge inactive elements and do mass elimination - CALL mdp - * (k,ek,tail, v,l, head,last,next, mark) -c -c------update degrees of uneliminated vertices in ek - CALL mdu - * (ek,dmin, v,l, head,last,next, mark) -c - go to 1 -c -c----generate inverse permutation from permutation - 4 do 5 k=1,n - next(k) = -next(k) - 5 last(next(k)) = k -c - return - end - subroutine mdi - * (n, ia,ja, max,v,l, head,last,next, mark,tag, flag) -clll. optimize -c*********************************************************************** -c mdi -- initialization -c*********************************************************************** - integer ia(1), ja(1), v(1), l(1), head(1), last(1), next(1), - * mark(1), tag, flag, sfs, vi,dvi, vj -c -c----initialize degrees, element lists, and degree lists - do 1 vi=1,n - mark(vi) = 1 - l(vi) = 0 - 1 head(vi) = 0 - sfs = n+1 -c -c----create nonzero structure -c----for each nonzero entry a(vi,vj) - do 6 vi=1,n - jmin = ia(vi) - jmax = ia(vi+1) - 1 - if (jmin.gt.jmax) go to 6 - do 5 j=jmin,jmax - vj = ja(j) - if (vj-vi) 2, 5, 4 -c -c------if a(vi,vj) is in strict lower triangle -c------check for previous occurrence of a(vj,vi) - 2 lvk = vi - kmax = mark(vi) - 1 - if (kmax .eq. 0) go to 4 - do 3 k=1,kmax - lvk = l(lvk) - if (v(lvk).eq.vj) go to 5 - 3 continue -c----for unentered entries a(vi,vj) - 4 if (sfs.ge.max) go to 101 -c -c------enter vj in element list for vi - mark(vi) = mark(vi) + 1 - v(sfs) = vj - l(sfs) = l(vi) - l(vi) = sfs - sfs = sfs+1 -c -c------enter vi in element list for vj - mark(vj) = mark(vj) + 1 - v(sfs) = vi - l(sfs) = l(vj) - l(vj) = sfs - sfs = sfs+1 - 5 continue - 6 continue -c -c----create degree lists and initialize mark vector - do 7 vi=1,n - dvi = mark(vi) - next(vi) = head(dvi) - head(dvi) = vi - last(vi) = -dvi - nextvi = next(vi) - if (nextvi.gt.0) last(nextvi) = vi - 7 mark(vi) = tag -c - return -c -c ** error- insufficient storage - 101 flag = 9*n + vi - return - end - subroutine mdm - * (vk,tail, v,l, last,next, mark) -clll. optimize -c*********************************************************************** -c mdm -- form element from uneliminated neighbors of vk -c*********************************************************************** - integer vk, tail, v(1), l(1), last(1), next(1), mark(1), - * tag, s,ls,vs,es, b,lb,vb, blp,blpmax - equivalence (vs, es) -c -c----initialize tag and list of uneliminated neighbors - tag = mark(vk) - tail = vk -c -c----for each vertex/element vs/es in element list of vk - ls = l(vk) - 1 s = ls - if (s.eq.0) go to 5 - ls = l(s) - vs = v(s) - if (next(vs).lt.0) go to 2 -c -c------if vs is uneliminated vertex, then tag and append to list of -c------uneliminated neighbors - mark(vs) = tag - l(tail) = s - tail = s - go to 4 -c -c------if es is active element, then ... -c--------for each vertex vb in boundary list of element es - 2 lb = l(es) - blpmax = last(es) - do 3 blp=1,blpmax - b = lb - lb = l(b) - vb = v(b) -c -c----------if vb is untagged vertex, then tag and append to list of -c----------uneliminated neighbors - if (mark(vb).ge.tag) go to 3 - mark(vb) = tag - l(tail) = b - tail = b - 3 continue -c -c--------mark es inactive - mark(es) = tag -c - 4 go to 1 -c -c----terminate list of uneliminated neighbors - 5 l(tail) = 0 -c - return - end - subroutine mdp - * (k,ek,tail, v,l, head,last,next, mark) -clll. optimize -c*********************************************************************** -c mdp -- purge inactive elements and do mass elimination -c*********************************************************************** - integer ek, tail, v(1), l(1), head(1), last(1), next(1), - * mark(1), tag, free, li,vi,lvi,evi, s,ls,es, ilp,ilpmax -c -c----initialize tag - tag = mark(ek) -c -c----for each vertex vi in ek - li = ek - ilpmax = last(ek) - if (ilpmax.le.0) go to 12 - do 11 ilp=1,ilpmax - i = li - li = l(i) - vi = v(li) -c -c------remove vi from degree list - if (last(vi).eq.0) go to 3 - if (last(vi).gt.0) go to 1 - head(-last(vi)) = next(vi) - go to 2 - 1 next(last(vi)) = next(vi) - 2 if (next(vi).gt.0) last(next(vi)) = last(vi) -c -c------remove inactive items from element list of vi - 3 ls = vi - 4 s = ls - ls = l(s) - if (ls.eq.0) go to 6 - es = v(ls) - if (mark(es).lt.tag) go to 5 - free = ls - l(s) = l(ls) - ls = s - 5 go to 4 -c -c------if vi is interior vertex, then remove from list and eliminate - 6 lvi = l(vi) - if (lvi.ne.0) go to 7 - l(i) = l(li) - li = i -c - k = k+1 - next(vi) = -k - last(ek) = last(ek) - 1 - go to 11 -c -c------else ... -c--------classify vertex vi - 7 if (l(lvi).ne.0) go to 9 - evi = v(lvi) - if (next(evi).ge.0) go to 9 - if (mark(evi).lt.0) go to 8 -c -c----------if vi is prototype vertex, then mark as such, initialize -c----------overlap count for corresponding element, and move vi to end -c----------of boundary list - last(vi) = evi - mark(evi) = -1 - l(tail) = li - tail = li - l(i) = l(li) - li = i - go to 10 -c -c----------else if vi is duplicate vertex, then mark as such and adjust -c----------overlap count for corresponding element - 8 last(vi) = 0 - mark(evi) = mark(evi) - 1 - go to 10 -c -c----------else mark vi to compute degree - 9 last(vi) = -ek -c -c--------insert ek in element list of vi - 10 v(free) = ek - l(free) = l(vi) - l(vi) = free - 11 continue -c -c----terminate boundary list - 12 l(tail) = 0 -c - return - end - subroutine mdu - * (ek,dmin, v,l, head,last,next, mark) -clll. optimize -c*********************************************************************** -c mdu -- update degrees of uneliminated vertices in ek -c*********************************************************************** - integer ek, dmin, v(1), l(1), head(1), last(1), next(1), - * mark(1), tag, vi,evi,dvi, s,vs,es, b,vb, ilp,ilpmax, - * blp,blpmax - equivalence (vs, es) -c -c----initialize tag - tag = mark(ek) - last(ek) -c -c----for each vertex vi in ek - i = ek - ilpmax = last(ek) - if (ilpmax.le.0) go to 11 - do 10 ilp=1,ilpmax - i = l(i) - vi = v(i) - if (last(vi)) 1, 10, 8 -c -c------if vi neither prototype nor duplicate vertex, then merge elements -c------to compute degree - 1 tag = tag + 1 - dvi = last(ek) -c -c--------for each vertex/element vs/es in element list of vi - s = l(vi) - 2 s = l(s) - if (s.eq.0) go to 9 - vs = v(s) - if (next(vs).lt.0) go to 3 -c -c----------if vs is uneliminated vertex, then tag and adjust degree - mark(vs) = tag - dvi = dvi + 1 - go to 5 -c -c----------if es is active element, then expand -c------------check for outmatched vertex - 3 if (mark(es).lt.0) go to 6 -c -c------------for each vertex vb in es - b = es - blpmax = last(es) - do 4 blp=1,blpmax - b = l(b) - vb = v(b) -c -c--------------if vb is untagged, then tag and adjust degree - if (mark(vb).ge.tag) go to 4 - mark(vb) = tag - dvi = dvi + 1 - 4 continue -c - 5 go to 2 -c -c------else if vi is outmatched vertex, then adjust overlaps but do not -c------compute degree - 6 last(vi) = 0 - mark(es) = mark(es) - 1 - 7 s = l(s) - if (s.eq.0) go to 10 - es = v(s) - if (mark(es).lt.0) mark(es) = mark(es) - 1 - go to 7 -c -c------else if vi is prototype vertex, then calculate degree by -c------inclusion/exclusion and reset overlap count - 8 evi = last(vi) - dvi = last(ek) + last(evi) + mark(evi) - mark(evi) = 0 -c -c------insert vi in appropriate degree list - 9 next(vi) = head(dvi) - head(dvi) = vi - last(vi) = -dvi - if (next(vi).gt.0) last(next(vi)) = vi - if (dvi.lt.dmin) dmin = dvi -c - 10 continue -c - 11 return - end - KPP_REAL FUNCTION D1MACH (IDUM) - INTEGER IDUM -C----------------------------------------------------------------------- -C This routine computes the unit roundoff of the machine. -C This is defined as the smallest positive machine number -C u such that 1.0 + u .ne. 1.0 -C -C Subroutines/functions called by D1MACH.. None -C----------------------------------------------------------------------- - KPP_REAL U, COMP - U = 1.0D0 - 10 U = U*0.5D0 - COMP = 1.0D0 + U - IF (COMP .NE. 1.0D0) GO TO 10 - D1MACH = U*2.0D0 - RETURN -C----------------------- End of Function D1MACH ------------------------ - END - - SUBROUTINE FUNC_CHEM (N, T, V, FCT) - IMPLICIT NONE - INCLUDE 'KPP_ROOT_Parameters.h' - INCLUDE 'KPP_ROOT_Global.h' - KPP_REAL V(NVAR), FCT(NVAR) - KPP_REAL T,TOLD - INTEGER N - TOLD = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - TIME = TOLD - CALL Fun(V, FIX, RCONST, FCT) - RETURN - END - - SUBROUTINE JAC_CHEM (N, T, V, JV, j, ian, jan) - IMPLICIT NONE - INCLUDE 'KPP_ROOT_Parameters.h' - INCLUDE 'KPP_ROOT_Global.h' - KPP_REAL V(NVAR), JV(NVAR,NVAR) - KPP_REAL T,TOLD - INTEGER N, j, ian(1), jan(1), ii, jj - TOLD = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - TIME = TOLD - - DO ii=1,NVAR - DO jj=1,NVAR - JV(ii,jj) = 0.D0 - END DO - END DO - call Jac(V, FIX, RCONST, JV) - - RETURN - END - diff --git a/boxmox/int/atm_odessa_ddm.def b/boxmox/int/atm_odessa_ddm.def deleted file mode 100644 index 193022c34d2c00a0f0c2022b058e00bc3fe1fd46..0000000000000000000000000000000000000000 --- a/boxmox/int/atm_odessa_ddm.def +++ /dev/null @@ -1,42 +0,0 @@ - -#FUNCTION AGGREGATE -#JACOBIAN FULL -#DOUBLE ON -#INTFILE atm_odessa_ddm - -#INLINE F77_GLOBAL - INTEGER Autonomous - COMMON /INTGDATA/ Autonomous - REAL*8 STEPSTART - COMMON /GDATA/ STEPSTART -#ENDINLINE - -#INLINE F77_INIT - STEPMIN=0.0001 - STEPMAX=3600. - Autonomous = 0 - STEPSTART=STEPMIN -#ENDINLINE - - - -#INLINE C_GLOBAL -extern int Autonomous; -extern double STEPSTART; -#ENDINLINE - -#INLINE C_DATA_INT -int Autonomous; -double STEPSTART; -#ENDINLINE - - - -#INLINE C_INIT - STEPMIN=0.0001; - STEPMAX=3600.0; - Autonomous = 0; - STEPSTART=STEPMIN; -#ENDINLINE - - diff --git a/boxmox/int/atm_odessa_ddm.f b/boxmox/int/atm_odessa_ddm.f deleted file mode 100644 index 55bfd2e731bebdf55bf716c98792e071994f2e87..0000000000000000000000000000000000000000 --- a/boxmox/int/atm_odessa_ddm.f +++ /dev/null @@ -1,4398 +0,0 @@ - SUBROUTINE INTEGRATE( NSENSIT, Y, TIN, TOUT ) - - INCLUDE 'KPP_ROOT_Parameters.h' - INCLUDE 'KPP_ROOT_Global.h' - -C TIN - Start Time - REAL*8 TIN -C TOUT - End Time - REAL*8 TOUT -C Concentrations and Sensitivities - REAL*8 Y(NVAR,NSENSIT+1), PARAMS(NSENSIT) -C --- Note: Y contains: (1:NVAR) concentrations, followed by -C --- (1:NVAR) sensitivities w.r.t. first parameter, followed by -C --- etc., followed by -C --- (1:NVAR) sensitivities w.r.t. NSENSIT's parameter - INTEGER i - - INTEGER LIW, LRW -C PARAMETER (LRW = 22 + 8*(NSENSIT+1)*NVAR + NVAR**2 + NVAR) -C PARAMETER (LIW = 21 + NVAR + NSENSIT) -C REAL*8 RWORK(LRW) -C INTEGER IWORK(LIW) -C Note: the following dynamic allocation is not standard F77 and may not work on -C some systems. Declare LRW, LIW parameters as above with some upper bound -C used for NSENSIT - REAL*8 RWORK(22 + 8*(NSENSIT+1)*NVAR + NVAR**2 + NVAR) - INTEGER IWORK(21 + NVAR + NSENSIT) - - INTEGER IOPT(3), NEQ(2) - - EXTERNAL FUNC_CHEM,JAC,DFUNC_CHEMDPAR - - MF = 21 ! --- BDF plus user-supplied Jacobian - - LRW = 22 + 8*(NSENSIT+1)*NVAR + NVAR**2 + NVAR - LIW = 21 + NVAR + NSENSIT - - NEQ(1) = NVAR ! --- No. of Variables - NEQ(2) = NSENSIT ! --- No of parameters - - ITOL=1 ! --- 1=Scalar Tolerances; 4 = VECTOR TOLERANCES - ITASK=1 ! --- Normal Output - ISTATE=1 - IOPT(1)=1 ! --- 0= No optional parameters, 1=Optional parameters - IOPT(2)=1 ! --- 1=Perform sensitivity analysis; 0 if not - IOPT(3)=0 ! --- DFUNC_CHEMDPAR supplied by the user; - ! --- 0 if finite differences are to be used -C --- Set optional parameters - DO 10 i=1,LRW - RWORK(i) = 0.0D0 - 10 CONTINUE - DO 20 i=1,LIW - IWORK(i) = 0 - 20 CONTINUE - - RWORK(5) = STEPMIN ! THE STEP SIZE TO BE ATTEMPTED ON THE FIRST STEP. - RWORK(6) = STEPMAX ! THE MAXIMUM ABSOLUTE STEP SIZE ALLOWED. - RWORK(7) = 0.0D0 ! THE MINIMUM ABSOLUTE STEP SIZE ALLOWED. - IWORK(6) = 5000 ! MAXIMUM NUMBER OF (INTERNALLY DEFINED) STEPS - - CALL ODESSA( FUNC_CHEM,DFUNC_CHEMDPAR,NEQ,Y,PARAMS,TIN,TOUT, - & ITOL,RTOL,ATOL, - 1 ITASK,ISTATE,IOPT,RWORK,LRW,IWORK,LIW, - & JAC,MF) - - IF (ISTATE.LT.0) THEN - print *,'ODESSA: Unsucessfull exit at T=', - & TIN,' (ISTATE=',ISTATE,')' - ENDIF - - RETURN - END - - - - SUBROUTINE FUNC_CHEM (N, T, V, PARAMS, FCT) - INCLUDE 'KPP_ROOT_Parameters.h' - INCLUDE 'KPP_ROOT_Global.h' - - DIMENSION V(NVAR), PARAMS(*), FCT(NVAR) - TOLD = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - TIME = TOLD - CALL Fun(V, FIX, RCONST, FCT) - RETURN - END - - SUBROUTINE DFUNC_CHEMDPAR (N, T, V, PARAMS, DFCT, JPAR) - INCLUDE 'KPP_ROOT_Parameters.h' - INCLUDE 'KPP_ROOT_Global.h' - - DIMENSION V(NVAR), PARAMS(*), DFCT(NVAR) - INTEGER JPAR, i -C This setting is required for sensitivities w.r.t. initial conditions - DO i=1,NVAR - DFCT(i) = 0.d0 - END DO - RETURN - END - - SUBROUTINE JAC (N, T, V, PARAMS, ML, MU, JV, NROWPD) - INCLUDE 'KPP_ROOT_Parameters.h' - INCLUDE 'KPP_ROOT_Global.h' - - REAL*8 V(NVAR), PARAMS(*), JV(NVAR,NVAR) - INTEGER ML, MU, NROWPD - TOLD = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - TIME = TOLD - DO i=1,NVAR - DO j=1,NVAR - JV(i,j) = 0.D0 - END DO - END DO - CALL Jac(V, FIX, RCONST, JV) - RETURN - END -! - -C ALGORITHM 658, COLLECTED ALGORITHMS FROM ACM. -C THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE, -C VOL. 14, NO. 1, P.61. -C----------------------------------------------------------------------- -C THIS IS THE SEPTEMBER 1, 1986 VERSION OF ODESSA.. -C AN ORDINARY DIFFERENTIAL EQUATION KppSolveR WITH EXPLICIT SIMULTANEOUS -C SENSITIVITY ANALYSIS. -C -C THIS PACKAGE IS A MODIFICATION OF THE AUGUST 13, 1981 VERSION OF -C LSODE.. LIVERMORE KppSolveR FOR ORDINARY DIFFERENTIAL EQUATIONS. -C THIS VERSION IS IN DOUBLE PRECISION. -C -C ODESSA KppSolveS FOR THE FIRST-ORDER SENSITIVITY COEFFICIENTS.. -C DY(I)/DP, FOR A SINGLE PARAMETER, OR, -C DY(I)/DP(J), FOR MULTIPLE PARAMETERS, -C ASSOCIATED WITH A SYSTEM OF ORDINARY DIFFERENTIAL EQUATIONS.. -C DY/DT = F(Y,T;P). -C----------------------------------------------------------------------- -C REFERENCES... -C -C 1. JORGE R. LEIS AND MARK A. KRAMER, THE SIMULTANEOUS SOLUTION AND -C EXPLICIT SENSITIVITY ANALYSIS OF SYSTEMS DESCRIBED BY ORDINARY -C DIFFERENTIAL EQUATIONS. SUBMITTED TO ACM TRANS. MATH. SOFTWARE, -C (1985). -C -C 2. JORGE R. LEIS AND MARK A. KRAMER, ODESSA - AN ORDINARY DIFFERENTIA -C EQUATION KppSolveR WITH EXPLICIT SIMULTANEOUS SENSITIVITY ANALYSIS. -C SUBMITTED TO ACM TRANS. MATH. SOFTWARE, (1985). -C -C 3. ALAN C. HINDMARSH, LSODE AND LSODI, TWO NEW INITIAL VALUE -C ORDINARY DIFFERENTIAL EQUATION KppSolveRS, ACM-SIGNUM NEWSLETTER, -C VOL. 15, NO. 4 (1980), PP. 10-11. -C----------------------------------------------------------------------- -C PROBLEM STATEMENT.. -C -C THE ODESSA MODIFICATION OF THE LSODE PACKAGE PROVIDES THE OPTION TO -C CALCULATE FIRST-ORDER SENSITIVITY COEFFICIENTS FOR A SYSTEM OF STIFF -C OR NON-STIFF EXPLICIT ORDINARY DIFFERENTIAL EQUATIONS OF THE GENERAL -C FORM : -C -C DY/DT = F(Y,T;P) (1) -C -C WHERE Y IS AN N-DIMENSIONAL DEPENDENT VARIABLE VECTOR, T IS THE -C INDEPENDENT INTEGRATION VARIABLE, AND P IS AN NPAR-DIMENSIONAL -C CONSTANT VECTOR. THE GOVERNING EQUATIONS FOR THE FIRST-ORDER -C SENSITIVITY COEFFICIENTS ARE GIVEN BY : -C -C S'(T) = J(T)*S(T) + DF/DP (2) -C -C WHERE -C -C S(T) = DY(T)/DP (= SENSITIVITY FUNCTIONS) -C S'(T) = D(DY(T)/DP)/DT -C J(T) = DF(Y,T;P)/DY(T) (= JACOBIAN MATRIX) -C AND DF/DP = DF(Y,T;P)/DP (= INHOMOGENEITY MATRIX) -C -C SOLUTION OF EQUATIONS (1) AND (2) PROCEEDS SIMULTANEOUSLY VIA AN -C EXTENSION OF THE LSODE PACKAGE AS DESCRIBED IN [1]. -C---------------------------------------------------------------------- -C ACKNOWLEDGEMENT : THE FOLLOWING ODESSA PACKAGE DOCUMENTATION IS A -C MODIFICATION OF THE LSODE DOCUMENTATION WHICH -C ACCOMPANIES THE LSODE PACKAGE CODE. -C---------------------------------------------------------------------- -C SUMMARY OF USAGE. -C -C COMMUNICATION BETWEEN THE USER AND THE ODESSA PACKAGE, FOR NORMAL -C SITUATIONS, IS SUMMARIZED HERE. THIS SUMMARY DESCRIBES ONLY A SUBSET -C OF THE FULL SET OF OPTIONS AVAILABLE. SEE THE FULL DESCRIPTION FOR -C DETAILS, INCLUDING OPTIONAL COMMUNICATION, NONSTANDARD OPTIONS, -C AND INSTRUCTIONS FOR SPECIAL SITUATIONS. SEE ALSO THE EXAMPLE -C PROBLEM (WITH PROGRAM AND OUTPUT) FOLLOWING THIS SUMMARY. -C -C A. FIRST PROVIDE A SUBROUTINE OF THE FORM.. -C SUBROUTINE F (N, T, Y, PAR, YDOT) -C DOUBLE PRECISION T, Y, PAR, YDOT -C DIMENSION Y(N), YDOT(N), PAR(NPAR) -C WHICH SUPPLIES THE VECTOR FUNCTION F BY LOADING YDOT(I) WITH F(I). -C N IS THE NUMBER OF FIRST-ORDER DIFFERENTIAL EQUATIONS IN THE -C ABOVE MODEL. NPAR IS THE NUMBER OF MODEL PARAMETERS FOR WHICH -C VECTOR SENSITIVITY FUNCTIONS ARE DESIRED. YOU ARE ALSO ENCOURAGED -C TO PROVIDE A SUBROUTINE OF THE FORM.. -C SUBROUTINE DF (N, T, Y, PAR, DFDP, JPAR) -C DOUBLE PRECISION T, Y, PAR, DFDP -C DIMENSION Y(N), PAR(NPAR), DFDP(N) -C GO TO (1,...,NPAR) JPAR -C 1 DFDP(1) = DF(1)/DP(1) -C . -C DFDP(I) = DF(I)/DP(1) -C . -C DFDP(N) = DF(N)/DP(1) -C RETURN -C 2 DFDP(1) = DF(1)/DP(2) -C . -C DFDP(I) = DF(I)/DP(2) -C . -C DFDP(N) = DF(N)/DP(2) -C RETURN -C . . -C . . -C RETURN -C NPAR DFDP(1) = DF(1)/DP(NPAR) -C . -C DFDP(I) = DF(I)/DP(NPAR) -C . -C DFDP(N) = DF(N)/DP(NPAR) -C RETURN -C END -C ONLY NONZERO ELEMENTS NEED BE LOADED. IF THIS IS NOT FEASIBLE, -C ODESSA WILL GENERATE THIS MATRIX INTERNALLY BY DIFFERENCE QUOTIENTS. -C -C B. NEXT DETERMINE (OR GUESS) WHETHER OR NOT THE PROBLEM IS STIFF. -C STIFFNESS OCCURS WHEN THE JACOBIAN MATRIX DF/DY HAS AN EIGENVALUE -C WHOSE REAL PART IS NEGATIVE AND LARGE IN MAGNITUDE, COMPARED TO THE -C RECIPROCAL OF THE T SPAN OF INTEREST. IF THE PROBLEM IS NONSTIFF, -C USE METH = 10. IF IT IS STIFF, USE METH = 20. THE USER IS REQUIRED -C TO INPUT THE METHOD FLAG MF = 10*METH + MITER. THERE ARE FOUR -C STANDARD CHOICES FOR MITER WHEN A SENSITIVITY ANALYSIS IS DESIRED, -C AND ODESSA REQUIRES THE JACOBIAN MATRIX IN SOME FORM. -C THIS MATRIX IS REGARDED EITHER AS FULL (MITER = 1 OR 2), -C OR BANDED (MITER = 4 OR 5). IN THE BANDED CASE, ODESSA REQUIRES TWO -C HALF-BANDWIDTH PARAMETERS ML AND MU. THESE ARE, RESPECTIVELY, THE -C WIDTHS OF THE LOWER AND UPPER PARTS OF THE BAND, EXCLUDING THE MAIN -C DIAGONAL. THUS THE BAND CONSISTS OF THE LOCATIONS (I,J) WITH -C I-ML .LE. J .LE. I+MU, AND THE FULL BANDWIDTH IS ML+MU+1. -C -C C. YOU ARE ENCOURAGED TO SUPPLY THE JACOBIAN DIRECTLY (MF = 11, 14, -C 21, OR 24), BUT IF THIS IS NOT FEASIBLE, ODESSA WILL COMPUTE IT -C INTERNALLY BY DIFFERENCE QUOTIENTS (MF = 12, 15, 22, OR 25). IF YOU -C ARE SUPPLYING THE JACOBIAN, PROVIDE A SUBROUTINE OF THE FORM.. -C SUBROUTINE JAC (NEQ, T, Y, PAR, ML, MU, PD, NROWPD) -C DOUBLE PRECISION T, Y, PAR, PD -C DIMENSION Y(N), PD(NROWPD,N), PAR(NPAR) -C WHICH SUPPLIES DF/DY BY LOADING PD AS FOLLOWS.. -C FOR A FULL JACOBIAN (MF = 11, OR 21), LOAD PD(I,J) WITH DF(I)/DY(J), -C THE PARTIAL DERIVATIVE OF F(I) WITH RESPECT TO Y(J). (IGNORE THE -C ML AND MU ARGUMENTS IN THIS CASE.) -C FOR A BANDED JACOBIAN (MF = 14, OR 24), LOAD PD(I-J+MU+1,J) WITH -C DF(I)/DY(J), I.E. LOAD THE DIAGONAL LINES OF DF/DY INTO THE ROWS OF -C PD FROM THE TOP DOWN. -C IN EITHER CASE, ONLY NONZERO ELEMENTS NEED BE LOADED. -C -C D. WRITE A MAIN PROGRAM WHICH CALLS SUBROUTINE ODESSA ONCE FOR -C EACH POINT AT WHICH ANSWERS ARE DESIRED. THIS SHOULD ALSO PROVIDE -C FOR POSSIBLE USE OF LOGICAL UNIT 6 FOR OUTPUT OF ERROR MESSAGES BY -C ODESSA. ON THE FIRST CALL TO ODESSA, SUPPLY ARGUMENTS AS FOLLOWS.. -C F = NAME OF SUBROUTINE FOR RIGHT-HAND SIDE VECTOR F (MODEL). -C THIS NAME MUST BE DECLARED EXTERNAL IN CALLING PROGRAM. -C DF = NAME OF SUBROUTINE FOR INHOMOGENEITY MATRIX DF/DP. -C IF USED (IDF = 1), THIS NAME MUST BE DECLARED EXTERNAL IN -C CALLING PROGRAM. IF NOT USED (IDF = 0), PASS A DUMMY NAME. -C N = NUMBER OF FIRST ORDER ODE-S IN MODEL; LOAD INTO NEQ(1). -C NPAR = NUMBER OF MODEL PARAMETERS OF INTEREST; LOAD INTO NEQ(2). -C Y = AN (N) BY (NPAR+1) REAL ARRAY OF INITIAL VALUES.. -C Y(I,1) , I = 1,N , CONTAIN THE STATE, OR MODEL, DEPENDENT -C VARIABLES, -C Y(I,J) , J = 2,NPAR , CONTAIN THE DEPENDENT SENSITIVITY -C COEFFICIENTS. -C PAR = A REAL ARRAY OF LENGTH NPAR CONTAINING MODEL PARAMETERS -C OF INTEREST. -C T = THE INITIAL VALUE OF THE INDEPENDENT VARIABLE. -C TOUT = FIRST POINT WHERE OUTPUT IS DESIRED (.NE. T). -C ITOL = 1, 2, 3, OR 4 ACCORDING AS RTOL, ATOL (BELOW) ARE SCALARS -C OR ARRAYS. -C RTOL = RELATIVE TOLERANCE PARAMETER (SCALAR OR (N) BY (NPAR+1) -C ARRAY). -C ATOL = ABSOLUTE TOLERANCE PARAMETER (SCALAR OR (N) BY (NPAR+1) -C ARRAY). -C THE ESTIMATED LOCAL ERROR IN Y(I,J) WILL BE CONTROLLED SO AS -C TO BE ROUGHLY LESS (IN MAGNITUDE) THAN -C EWT(I,J) = RTOL*ABS(Y(I,J)) + ATOL IF ITOL = 1, -C EWT(I,J) = RTOL*ABS(Y(I,J)) + ATOL(I,J) IF ITOL = 2, -C EWT(I,J) = RTOL(I,J)*ABS(Y(I,J) + ATOL IF ITOL = 3, OR -C EWT(I,J) = RTOL(I,J)*ABS(Y(I,J) + ATOL(I,J) IF ITOL = 4. -C THUS THE LOCAL ERROR TEST PASSES IF, IN EACH COMPONENT, -C EITHER THE ABSOLUTE ERROR IS LESS THAN ATOL (OR ATOL(I,J)), -C OR THE RELATIVE ERROR IS LESS THAN RTOL (OR RTOL(I,J)). -C USE RTOL = 0.0 FOR PURE ABSOLUTE ERROR CONTROL, AND -C USE ATOL = 0.0 FOR PURE RELATIVE ERROR CONTROL. -C CAUTION.. ACTUAL (GLOBAL) ERRORS MAY EXCEED THESE LOCAL -C TOLERANCES, SO CHOOSE THEM CONSERVATIVELY. -C ITASK = 1 FOR NORMAL COMPUTATION OF OUTPUT VALUES OF Y AT T = TOUT. -C ISTATE = INTEGER FLAG (INPUT AND OUTPUT). SET ISTATE = 1. -C IOPT = 0, TO INDICATE NO OPTIONAL INPUTS FOR INTEGRATION; -C LOAD INTO IOPT(1). -C ISOPT = 1, TO INDICATE SENSITIVITY ANALYSIS, = 0, TO INDICATE -C NO SENSITIVITY ANALYSIS; LOAD INTO IOPT(2). -C IDF = 1, IF SUBROUTINE DF (ABOVE) IS SUPPLIED BY THE USER, -C = 0, OTHERWISE; LOAD INTO IOPT(3). -C RWORK = REAL WORK ARRAY OF LENGTH AT LEAST.. -C 22 + 16*N + N**2 FOR MF = 11 OR 12, -C 22 + 17*N + (2*ML + MU)*N FOR MF = 14 OR 15, -C 22 + 9*N + N**2 FOR MF = 21 OR 22, -C 22 + 10*N + (2*ML + MU)*N FOR MF = 24 OR 25, -C IF ISOPT = 0, OR.. -C 22 + 15*(NPAR+1)*N + N**2 + N FOR MF = 11 OR 12, -C 24 + 15*(NPAR+1)*N + (2*ML+MU+2)*N + N FOR MF = 14 OR 15, -C 22 + 8*(NPAR+1)*N + N**2 + N FOR MF = 21 OR 22, -C 24 + 8*(NPAR+1)*N + (2*ML+MU+2)*N + N FOR MF = 24 OR 25, -C IF ISOPT = 1. -C LRW = DECLARED LENGTH OF RWORK (IN USER-S DIMENSION STATEMENT). -C IWORK = INTEGER WORK ARRAY OF LENGTH AT LEAST.. -C 20 + N IF ISOPT = 0, -C 21 + N + NPAR IF ISOPT = 1. -C IF MITER = 4 OR 5, INPUT IN IWORK(1),IWORK(2) THE LOWER -C AND UPPER HALF-BANDWIDTHS ML,MU (EXCLUDING MAIN DIAGONAL). -C LIW = DECLARED LENGTH OF IWORK (IN USER-S DIMENSION STATEMENT). -C JAC = NAME OF SUBROUTINE FOR JACOBIAN MATRIX. -C IF USED, THIS NAME MUST BE DECLARED EXTERNAL IN CALLING -C PROGRAM. IF NOT USED, PASS A DUMMY NAME. -C MF = METHOD FLAG. STANDARD VALUES FOR ISOPT = 0 ARE.. -C 10 FOR NONSTIFF (ADAMS) METHOD, NO JACOBIAN USED. -C 21 FOR STIFF (BDF) METHOD, USER-SUPPLIED FULL JACOBIAN. -C 22 FOR STIFF METHOD, INTERNALLY GENERATED FULL JACOBIAN. -C 24 FOR STIFF METHOD, USER-SUPPLIED BANDED JACOBIAN. -C 25 FOR STIFF METHOD, INTERNALLY GENERATED BANDED JACOBIAN. -C IF ISOPT = 1, MF = 10 IS ILLEGAL AND CAN BE REPLACED BY.. -C 11 FOR NONSTIFF METHOD, USER-SUPPLIED FULL JACOBIAN. -C 12 FOR NONSTIFF METHOD, INTERNALLY GENERATED FULL JACOBIAN. -C 14 FOR NONSTIFF METHOD, USER-SUPPLIED BANDED JACOBIAN. -C 15 FOR NONSTIFF METHOD, INTERNALLY GENERATED BANDED JACOBIAN. -C NOTE THAT THE MAIN PROGRAM MUST DECLARE ARRAYS Y, RWORK, IWORK, AND -C POSSIBLY ATOL AND RTOL, AS WELL AS NEQ, IOPT, AND PAR IF ISOPT = 1. -C -C E. THE OUTPUT FROM THE FIRST CALL (OR ANY CALL) IS.. -C Y = ARRAY OF COMPUTED VALUES OF Y(T) VECTOR. -C T = CORRESPONDING VALUE OF INDEPENDENT VARIABLE (NORMALLY TOUT). -C ISTATE = 2 IF ODESSA WAS SUCCESSFUL, NEGATIVE OTHERWISE. -C -1 MEANS EXCESS WORK DONE ON THIS CALL (PERHAPS WRONG MF). -C -2 MEANS EXCESS ACCURACY REQUESTED (TOLERANCES TOO SMALL). -C -3 MEANS ILLEGAL INPUT DETECTED (SEE PRINTED MESSAGE). -C -4 MEANS REPEATED ERROR TEST FAILURES (CHECK ALL INPUTS). -C -5 MEANS REPEATED CONVERGENCE FAILURES (PERHAPS BAD JACOBIAN -C SUPPLIED OR WRONG CHOICE OF MF OR TOLERANCES). -C -6 MEANS ERROR WEIGHT BECAME ZERO DURING PROBLEM. (SOLUTION -C COMPONENT I,J VANISHED, AND ATOL OR ATOL(I,J) = 0.0) -C -C F. TO CONTINUE THE INTEGRATION AFTER A SUCCESSFUL RETURN, SIMPLY -C RESET TOUT AND CALL ODESSA AGAIN. NO OTHER PARAMETERS NEED BE RESET. -C---------------------------------------------------------------------- -C EXAMPLE PROBLEM. -C -C THE FOLLOWING IS A SIMPLE EXAMPLE PROBLEM, WITH THE CODING -C NEEDED FOR ITS SOLUTION BY ODESSA. THE PROBLEM IS FROM CHEMICAL -C KINETICS, AND CONSISTS OF THE FOLLOWING THREE RATE EQUATIONS.. -C DY1/DT = -PAR(1)*Y1 + PAR(2)*Y2*Y3 ; PAR(1) = .04, PAR(2) = 1.E4 -C DY2/DT = PAR(1)*Y1 - PAR(2)*Y2*Y3 - PAR(3)*Y2**2 ; PAR(3) = 3.E7 -C DY3/DT = PAR(3)*Y2**2 -C ON THE INTERVAL FROM T = 0.0 TO T = 4.E10, WITH INITIAL CONDITIONS -C Y1 = 1.0, Y2 = Y3 = 0, AND S(I,J) = 0, I = 1,3, J = 1,3. -C THE PROBLEM IS STIFF. -C -C THE FOLLOWING CODING KppSolveS THIS PROBLEM WITH ODESSA, USING -C MF = 21 AND PRINTING RESULTS AT T = .4, 4., ..., 4.E10. -C IT USES ITOL = 4 AND ATOL MUCH SMALLER FOR Y2 THAN Y1 OR Y3, -C BECAUSE Y2 HAS MUCH SMALLER VALUES. LESS STRINGENT TOLERANCES -C ARE ASSIGNED FOR THE SENSITIVITIES TO ACHIEVE GREATER EFFICIENCY. -C AT THE END OF THE RUN, STATISTICAL QUANTITIES OF INTEREST ARE -C PRINTED (SEE OPTIONAL OUTPUTS IN THE FULL DESCRIPTION BELOW). -C -C DOUBLE PRECISION ATOL, RWORK, RTOL, T, TOUT, Y, PAR -C EXTERNAL FEX, JEX, DFEX -C DIMENSION Y(3,4), PAR(3), ATOL(3,4), RTOL(3,4), RWORK(130), -C 1 IWORK(27), NEQ(2), IOPT(3) -C N = 3 -C NPAR = 3 -C NEQ(1) = N -C NEQ(2) = NPAR -C NSV = NPAR+1 -C DO 10 I = 1,N -C DO 10 J = 1,NSV -C 10 Y(I,J) = 0.0D0 -C Y(1,1) = 1.0D0 -C PAR(1) = 0.04D0 -C PAR(2) = 1.0D4 -C PAR(3) = 3.0D7 -C T = 0.D0 -C TOUT = .4D0 -C ITOL = 4 -C ATOL(1,1) = 1.D-6 -C ATOL(2,1) = 1.D-10 -C ATOL(3,1) = 1.D-6 -C DO 20 I = 1,N -C RTOL(I,1) = 1.D-4 -C DO 15 J = 2,NSV -C RTOL(I,J) = 1.D-3 -C 15 ATOL(I,J) = 1.D2 * ATOL(I,1) -C 20 CONTINUE -C ITASK = 1 -C ISTATE = 1 -C IOPT(1) = 0 -C IOPT(2) = 1 -C IOPT(3) = 1 -C LRW = 130 -C LIW = 27 -C MF = 21 -C DO 60 IOUT = 1,12 -C CALL ODESSA(FEX,DFEX,NEQ,Y,PAR,T,TOUT,ITOL,RTOL,ATOL, -C 1 ITASK,ISTATE, IOPT,RWORK,LRW,IWORK,LIW,JEX,MF) -C WRITE(6,30)T,Y(1,1),Y(2,1),Y(3,1) -C 30 FORMAT(1X,7H AT T =,E12.4,6H Y =,3E14.6) -C DO 50 J = 2,NSV -C JPAR = J-1 -C WRITE(6,40)JPAR,Y(1,J),Y(2,J),Y(3,J) -C 40 FORMAT(20X,2HS(,I1,3H) =,3E14.6) -C 50 CONTINUE -C IF (ISTATE .LT. 0) GO TO 80 -C 60 TOUT = TOUT*10.D0 -C WRITE(6,70)IWORK(11),IWORK(12),IWORK(13),IWORK(19) -C 70 FORMAT(1X,/,12H NO. STEPS =,I4,11H NO. F-S =,I4,11H NO. J-S =, -C 1 I4,12H NO. DF-S =,I4) -C STOP -C 80 WRITE(6,90)ISTATE -C 90 FORMAT(///22H ERROR HALT.. ISTATE =,I3) -C STOP -C END -C -C SUBROUTINE FEX (NEQ, T, Y, PAR, YDOT) -C DOUBLE PRECISION T, Y, YDOT, PAR -C DIMENSION Y(3), YDOT(3), PAR(3) -C YDOT(1) = -PAR(1)*Y(1) + PAR(2)*Y(2)*Y(3) -C YDOT(3) = PAR(3)*Y(2)*Y(2) -C YDOT(2) = -YDOT(1) - YDOT(3) -C RETURN -C END -C -C SUBROUTINE JEX (NEQ, T, Y, PAR, ML, MU, PD, NRPD) -C DOUBLE PRECISION PD, T, Y, PAR -C DIMENSION Y(3), PD(NRPD,3), PAR(3) -C PD(1,1) = -PAR(1) -C PD(1,2) = PAR(2)*Y(3) -C PD(1,3) = PAR(2)*Y(2) -C PD(2,1) = PAR(1) -C PD(2,3) = -PD(1,3) -C PD(3,2) = 2.D0*PAR(3)*Y(2) -C PD(2,2) = -PD(1,2) - PD(3,2) -C RETURN -C END -C -C SUBROUTINE DFEX (NEQ, T, Y, PAR, DFDP, JPAR) -C DOUBLE PRECISION T, Y, PAR, DFDP -C DIMENSION Y(3), PAR(3), DFDP(3) -C GO TO (1,2,3), JPAR -C 1 DFDP(1) = -Y(1) -C DFDP(2) = Y(1) -C RETURN -C 2 DFDP(1) = Y(2)*Y(3) -C DFDP(2) = -Y(2)*Y(3) -C RETURN -C 3 DFDP(2) = -Y(2)*Y(2) -C DFDP(3) = Y(2)*Y(2) -C RETURN -C END -C -C THE OUTPUT OF THIS PROGRAM (ON A DATA GENERAL MV-8000 IN -C DOUBLE PRECISION IS AS FOLLOWS: -C -C AT T = .4000E+00 Y = .985173E+00 .338641E-04 .147930E-01 -C S(1) = -.355914E+00 .390261E-03 .355524E+00 -C S(2) = .955150E-07 -.213065E-09 -.953019E-07 -C S(3) = -.158466E-10 -.529012E-12 .163756E-10 -C AT T = .4000E+01 Y = .905516E+00 .224044E-04 .944615E-01 -C S(1) = -.187621E+01 .179197E-03 .187603E+01 -C S(2) = .296093E-05 -.583104E-09 -.296034E-05 -C S(3) = -.493267E-09 -.276246E-12 .493544E-09 -C AT T = .4000E+02 Y = .715848E+00 .918628E-05 .284143E+00 -C S(1) = -.424730E+01 .459360E-04 .424726E+01 -C S(2) = .137294E-04 -.235815E-09 -.137291E-04 -C S(3) = -.228818E-08 -.113803E-12 .228829E-08 -C AT T = .4000E+03 Y = .450526E+00 .322299E-05 .549471E+00 -C S(1) = -.595837E+01 .354310E-05 .595836E+01 -C S(2) = .227380E-04 -.226041E-10 -.227380E-04 -C S(3) = -.378971E-08 -.499501E-13 .378976E-08 -C AT T = .4000E+04 Y = .183185E+00 .894131E-06 .816814E+00 -C S(1) = -.475006E+01 -.599504E-05 .475007E+01 -C S(2) = .188089E-04 .231330E-10 -.188089E-04 -C S(3) = -.313478E-08 -.187575E-13 .313480E-08 -C AT T = .4000E+05 Y = .389733E-01 .162133E-06 .961027E+00 -C S(1) = -.157477E+01 -.276199E-05 .157477E+01 -C S(2) = .628668E-05 .110026E-10 -.628670E-05 -C S(3) = -.104776E-08 -.453588E-14 .104776E-08 -C AT T = .4000E+06 Y = .493609E-02 .198411E-07 .995064E+00 -C S(1) = -.236244E+00 -.458262E-06 .236244E+00 -C S(2) = .944669E-06 .183193E-11 -.944671E-06 -C S(3) = -.157441E-09 -.635990E-15 .157442E-09 -C AT T = .4000E+07 Y = .516087E-03 .206540E-08 .999484E+00 -C S(1) = -.256277E-01 -.509808E-07 .256278E-01 -C S(2) = .102506E-06 .203905E-12 -.102506E-06 -C S(3) = -.170825E-10 -.684002E-16 .170826E-10 -C AT T = .4000E+08 Y = .519314E-04 .207736E-09 .999948E+00 -C S(1) = -.259316E-02 -.518029E-08 .259316E-02 -C S(2) = .103726E-07 .207209E-13 -.103726E-07 -C S(3) = -.172845E-11 -.691450E-17 .172845E-11 -C AT T = .4000E+09 Y = .544710E-05 .217885E-10 .999995E+00 -C S(1) = -.271637E-03 -.541849E-09 .271638E-03 -C S(2) = .108655E-08 .216739E-14 -.108655E-08 -C S(3) = -.180902E-12 -.723615E-18 .180902E-12 -C AT T = .4000E+10 Y = .446748E-06 .178699E-11 .100000E+01 -C S(1) = -.322322E-04 -.842541E-10 .322323E-04 -C S(2) = .128929E-09 .337016E-15 -.128929E-09 -C S(3) = -.209715E-13 -.838859E-19 .209715E-13 -C AT T = .4000E+11 Y = -.363960E-07 -.145584E-12 .100000E+01 -C S(1) = -.164109E-06 -.429604E-11 .164113E-06 -C S(2) = .656436E-12 .171842E-16 -.656451E-12 -C S(3) = -.689361E-15 -.275745E-20 .689363E-15 -C -C NO. STEPS = 340 NO. F-S = 412 NO. J-S = 343 NO. DF-S =1023 -C---------------------------------------------------------------------- -C FULL DESCRIPTION OF USER INTERFACE TO ODESSA. -C -C THE USER INTERFACE TO ODESSA CONSISTS OF THE FOLLOWING PARTS. -C -C I. THE CALL SEQUENCE TO SUBROUTINE ODESSA, WHICH IS A DRIVER -C ROUTINE FOR THE KppSolveR. THIS INCLUDES DESCRIPTIONS OF BOTH -C THE CALL SEQUENCE ARGUMENTS AND OF USER-SUPPLIED ROUTINES. -C FOLLOWING THESE DESCRIPTIONS IS A DESCRIPTION OF -C OPTIONAL INPUTS AVAILABLE THROUGH THE CALL SEQUENCE, AND THEN -C A DESCRIPTION OF OPTIONAL OUTPUTS (IN THE WORK ARRAYS). -C -C II. DESCRIPTIONS OF OTHER ROUTINES IN THE ODESSA PACKAGE THAT MAY -C BE (OPTIONALLY) CALLED BY THE USER. THESE PROVIDE THE ABILITY -C TO ALTER ERROR MESSAGE HANDLING, SAVE AND RESTORE THE INTERNAL -C COMMON, AND OBTAIN SPECIFIED DERIVATIVES OF THE SOLUTION Y(T). -C -C III. DESCRIPTIONS OF COMMON BLOCKS TO BE DECLARED IN OVERLAY -C OR SIMILAR ENVIRONMENTS, OR TO BE SAVED WHEN DOING AN INTERRUPT -C OF THE PROBLEM AND CONTINUED SOLUTION LATER. -C -C IV. DESCRIPTION OF TWO SUBROUTINES IN THE ODESSA PACKAGE, EITHER OF -C WHICH THE USER MAY REPLACE WITH HIS OWN VERSION, IF DESIRED. -C THESE RELATE TO THE MEASUREMENT OF ERRORS. -C -C V. GENERAL REMARKS WHICH HIGHLIGHT DIFFERENCES BETWEEN THE LSODE -C PACKAGE AND THE ODESSA PACKAGE. -C---------------------------------------------------------------------- -C PART I. CALL SEQUENCE. -C -C THE CALL SEQUENCE PARAMETERS USED FOR INPUT ONLY ARE.. -C F, DF, NEQ, PAR, TOUT, ITOL, RTOL, ATOL, ITASK, IOPT, LRW, LIW, -C JAC, MF, -C AND THOSE USED FOR BOTH INPUT AND OUTPUT ARE -C Y, T, ISTATE. -C THE WORK ARRAYS RWORK AND IWORK ARE ALSO USED FOR CONDITIONAL AND -C OPTIONAL INPUTS AND OPTIONAL OUTPUTS. (THE TERM OUTPUT HERE REFERS -C TO THE RETURN FROM SUBROUTINE ODESSA TO THE USER-S CALLING PROGRAM.) -C -C THE LEGALITY OF INPUT PARAMETERS WILL BE THOROUGHLY CHECKED ON THE -C INITIAL CALL FOR THE PROBLEM, BUT NOT CHECKED THEREAFTER UNLESS A -C CHANGE IN INPUT PARAMETERS IS FLAGGED BY ISTATE = 3 ON INPUT. -C -C THE DESCRIPTIONS OF THE CALL ARGUMENTS ARE AS FOLLOWS. -C -C F = THE NAME OF THE USER-SUPPLIED SUBROUTINE DEFINING THE -C ODE MODEL. THIS SYSTEM MUST BE PUT IN THE FIRST-ORDER -C FORM DY/DT = F(Y,T;P), WHERE F IS A VECTOR-VALUED FUNCTION -C OF THE SCALAR T AND VECTORS Y, AND PAR. SUBROUTINE F IS TO -C COMPUTE THE FUNCTION F. IT IS TO HAVE THE FORM.. -C SUBROUTINE F (NEQ, T, Y, PAR, YDOT) -C DOUBLE PRECISION T, Y, PAR, YDOT -C DIMENSION Y(1), PAR(1), YDOT(1) -C WHERE NEQ, T, Y, AND PAR ARE INPUT, AND YDOT = F(Y,T;P) -C IS OUTPUT. Y AND YDOT ARE ARRAYS OF LENGTH N (= NEQ(1)). -C (IN THE DIMENSION STATEMENT ABOVE, 1 IS A DUMMY -C DIMENSION.. IT CAN BE REPLACED BY ANY VALUE.) -C F SHOULD NOT ALTER ARRAY Y, OR PAR(1),...,PAR(NPAR). -C F MUST BE DECLARED EXTERNAL IN THE CALLING PROGRAM. -C -C SUBROUTINE F MAY ACCESS USER-DEFINED QUANTITIES IN -C NEQ(2),... AND PAR(NPAR+1),... IF NEQ IS AN ARRAY -C (DIMENSIONED IN F) AND PAR HAS LENGTH EXCEEDING NPAR. -C SEE THE DESCRIPTIONS OF NEQ AND PAR BELOW. -C -C DF = THE NAME OF THE USER-SUPPLIED ROUTINE (IDF = 1) TO COMPUTE -C THE INHOMOGENEITY MATRIX, DF/DP, AS A FUNCTION OF THE SCALAR -C T, AND THE VECTORS Y, AND PAR. IT IS TO HAVE THE FORM -C SUBROUTINE DF (NEQ, T, Y, PAR, DFDP, JPAR) -C DOUBLE PRECISION T, Y, PAR, DFDP -C DIMENSION Y(1), PAR(1), DFDP(1) -C GO TO (1,2,...,NPAR) JPAR -C 1 DFDP(1) = DF(1)/DP(1) -C . -C DFDP(I) = DF(I)/DP(1) -C . -C DFDP(N) = DF(N)/DP(1) -C RETURN -C 2 DFDP(1) = DF(1)/DP(2) -C . -C DFDP(I) = DF(I)/DP(2) -C . -C DFDP(N) = DF(N)/DP(2) -C . -C RETURN -C . . -C . . -C NPAR DFDP(1) = DF(1)/DP(NPAR) -C . -C DFDP(I) = DF(I)/DP(NPAR) -C . -C DFDP(N) = DF(N)/DP(NPAR) -C RETURN -C END -C WHERE NEQ, T, Y, PAR, AND JPAR ARE INPUT AND THE VECTOR -C DFDP(*,JPAR) IS TO BE LOADED WITH THE PARTIAL DERIVATIVES -C DF(Y,T;PAR)/DP(JPAR) ON OUTPUT. ONLY NONZERO ELEMENTS NEED -C BE LOADED. T, Y, AND PAR HAVE THE SAME MEANING AS IN -C SUBROUTINE F. (IN THE DIMENSION STATEMENT ABOVE, 1 IS A DUMMY -C DIMENSION.. IT CAN BE REPLACED BY ANY VALUE). -C -C DFDP(*,JPAR) IS PRESET TO ZERO BY THE KppSolveR, SO THAT ONLY -C THE NONZERO ELEMENTS NEED BE LOADED BY DF. SUBROUTINE DF -C MUST BE DECLARED EXTERNAL IN THE CALLING PROGRAM IF USED. -C IF IDF = 0 (OR ISOPT = 0), A DUMMY ARGUMENT CAN BE USED. -C -C SUBROUTINE DF MAY ACCESS USER-DEFINED QUANTITIES IN -C NEQ(2),... AND PAR(NPAR+1),... IF NEQ IS AN ARRAY -C (DIMENSIONED IN DF) AND PAR HAS A LENGTH EXCEEDING NPAR. -C SEE THE DESCRIPTIONS OF NEQ AND PAR (BELOW). -C -C NEQ = THE SIZE OF THE ODE SYSTEM (NUMBER OF FIRST ORDER ORDINARY -C DIFFERENTIAL EQUATIONS (N) IN THE MODEL). USED ONLY FOR -C INPUT. NEQ MAY NOT BE CHANGED DURING THE PROBLEM. -C -C FOR ISOPT = 0, NEQ IS NORMALLY A SCALAR. HOWEVER, NEQ MAY -C BE AN ARRAY, WITH NEQ(1) SET TO THE SYSTEM SIZE (N), IN WHICH -C CASE THE ODESSA PACKAGE ACCESSES ONLY NEQ(1). HOWEVER, -C THIS PARAMETER IS PASSED AS THE NEQ ARGUMENT IN ALL CALLS -C TO F, DF, AND JAC. HENCE, IF IT IS AN ARRAY, LOCATIONS -C NEQ(2),... MAY BE USED TO STORE OTHER INTEGER DATA AND PASS -C IT TO F, DF, AND/OR JAC. FOR ISOPT = 1, NPAR MUST BE LOADED -C INTO NEQ(2), AND IS NOT ALLOWED TO CHANGE DURING THE PROBLEM. -C IN THESE CASES, SUBROUTINES F, DF, AND/OR JAC MUST INCLUDE -C NEQ IN A DIMENSION STATEMENT. -C -C Y = A REAL ARRAY FOR THE VECTOR OF DEPENDENT VARIABLES, OF -C DIMENSION (N) BY (NPAR+1). USED FOR BOTH INPUT AND -C OUTPUT ON THE FIRST CALL (ISTATE = 1), AND ONLY FOR -C OUTPUT ON OTHER CALLS. ON THE FIRST CALL, Y MUST CONTAIN -C THE VECTORS OF INITIAL VALUES. ON OUTPUT, Y CONTAINS THE -C COMPUTED SOLUTION VECTORS, EVALUATED AT T. -C -C PAR = A REAL ARRAY FOR THE VECTOR OF CONSTANT MODEL PARAMETERS -C OF INTEREST IN THE SENSITIVITY ANALYSIS, OF LENGTH NPAR -C OR MORE. PAR IS PASSED AS AN ARGUMENT IN ALL CALLS TO F, -C DF, AND JAC. HENCE LOCATIONS PAR(NPAR+1),... MAY BE USED -C TO STORE OTHER REAL DATA AND PASS IT TO F, DF, AND/OR JAC. -C LOCATIONS PAR(1),...,PAR(NPAR) ARE USED AS INPUT ONLY, -C AND MUST NOT BE CHANGED DURING THE PROBLEM. -C -C T = THE INDEPENDENT VARIABLE. ON INPUT, T IS USED ONLY ON THE -C FIRST CALL, AS THE INITIAL POINT OF THE INTEGRATION. -C ON OUTPUT, AFTER EACH CALL, T IS THE VALUE AT WHICH A -C COMPUTED SOLUTION Y IS EVALUATED (USUALLY THE SAME AS TOUT). -C ON AN ERROR RETURN, T IS THE FARTHEST POINT REACHED. -C -C TOUT = THE NEXT VALUE OF T AT WHICH A COMPUTED SOLUTION IS DESIRED. -C USED ONLY FOR INPUT. -C -C WHEN STARTING THE PROBLEM (ISTATE = 1), TOUT MAY BE EQUAL -C TO T FOR ONE CALL, THEN SHOULD .NE. T FOR THE NEXT CALL. -C FOR THE INITIAL T, AN INPUT VALUE OF TOUT .NE. T IS USED -C IN ORDER TO DETERMINE THE DIRECTION OF THE INTEGRATION -C (I.E. THE ALGEBRAIC SIGN OF THE STEP SIZES) AND THE ROUGH -C SCALE OF THE PROBLEM. INTEGRATION IN EITHER DIRECTION -C (FORWARD OR BACKWARD IN T) IS PERMITTED. -C -C IF ITASK = 2 OR 5 (ONE-STEP MODES), TOUT IS IGNORED AFTER -C THE FIRST CALL (I.E. THE FIRST CALL WITH TOUT .NE. T). -C OTHERWISE, TOUT IS REQUIRED ON EVERY CALL. -C -C IF ITASK = 1, 3, OR 4, THE VALUES OF TOUT NEED NOT BE -C MONOTONE, BUT A VALUE OF TOUT WHICH BACKS UP IS LIMITED -C TO THE CURRENT INTERNAL T INTERVAL, WHOSE ENDPOINTS ARE -C TCUR - HU AND TCUR (SEE OPTIONAL OUTPUTS, BELOW, FOR -C TCUR AND HU). -C -C ITOL = AN INDICATOR FOR THE TYPE OF ERROR CONTROL. SEE -C DESCRIPTION BELOW UNDER ATOL. USED ONLY FOR INPUT. -C -C RTOL = A RELATIVE ERROR TOLERANCE PARAMETER, EITHER A SCALAR OR -C AN ARRAY OF SPACE (N) BY (NPAR+1). SEE DESCRIPTION BELOW -C UNDER ATOL. INPUT ONLY. -C -C ATOL = AN ABSOLUTE ERROR TOLERANCE PARAMETER, EITHER A SCALAR OR -C AN ARRAY OF SPACE (N) BY (NPAR+1). INPUT ONLY. -C -C THE INPUT PARAMETERS ITOL, RTOL, AND ATOL DETERMINE -C THE ERROR CONTROL PERFORMED BY THE KppSolveR. THE KppSolveR WILL -C CONTROL THE VECTOR E = (E(I,J)) OF ESTIMATED LOCAL ERRORS -C IN Y, ACCORDING TO AN INEQUALITY OF THE FORM -C RMS-NORM OF ( E(I,J)/EWT(I,J) ) .LE. 1, -C WHERE EWT(I,J) = RTOL(I,J)*ABS(Y(I,J)) + ATOL(I,J), -C AND THE RMS-NORM (ROOT-MEAN-SQUARE NORM) HERE IS -C RMS-NORM(V) = SQRT ( (1/N) * SUM (V(I,J)**2) ); I =1,...,N. -C HERE EWT = (EWT(I,J)) IS A VECTOR OF WEIGHTS WHICH MUST -C ALWAYS BE POSITIVE, AND THE VALUES OF RTOL AND ATOL SHOULD -C ALL BE NON-NEGATIVE. THE FOLLOWING TABLE GIVES THE TYPES -C (SCALAR/ARRAY) OF RTOL AND ATOL, AND THE CORRESPONDING FORM -C OF EWT(I,J). -C -C ITOL RTOL ATOL EWT(I,J) -C 1 SCALAR SCALAR RTOL*ABS(Y(I,J)) + ATOL -C 2 SCALAR ARRAY RTOL*ABS(Y(I,J)) + ATOL(I,J) -C 3 ARRAY SCALAR RTOL(I,J)*ABS(Y(I,J)) + ATOL -C 4 ARRAY ARRAY RTOL(I,J)*ABS(Y(I,J)) + ATOL(I,J) -C -C WHEN EITHER OF THESE PARAMETERS IS A SCALAR, IT NEED NOT -C BE DIMENSIONED IN THE USER-S CALLING PROGRAM. -C -C THE TOTAL NUMBER OF ERROR TEST FAILURES DUE TO THE SENSITIVITY -C ANALYSIS, AND WHICH REQUIRE AN INTEGRATION STEP TO BE -C REPEATED, ARE ACCUMULATED IN THE LAST NPAR+1 LOCATIONS OF THE -C INTEGER WORK ARRAY IWORK (SEE OPTIONAL OUTPUTS BELOW). -C THIS INFORMATION MAY BE OF VALUE IN DETERMINING APPROPRIATE -C ERROR TOLERANCES TO BE APPLIED TO THE SENSITIVITY FUNCTIONS. -C -C IF NONE OF THE ABOVE CHOICES (WITH ITOL, RTOL, AND ATOL -C FIXED THROUGHOUT THE PROBLEM) IS SUITABLE, MORE GENERAL -C ERROR CONTROLS CAN BE OBTAINED BY SUBSTITUTING -C USER-SUPPLIED ROUTINES FOR THE SETTING OF EWT AND/OR FOR -C THE NORM CALCULATION. SEE PART IV BELOW. -C -C IF GLOBAL ERRORS ARE TO BE ESTIMATED BY MAKING A REPEATED -C RUN ON THE SAME PROBLEM WITH SMALLER TOLERANCES, THEN ALL -C COMPONENTS OF RTOL AND ATOL (I.E. OF EWT) SHOULD BE SCALED -C DOWN UNIFORMLY. -C -C ITASK = AN INDEX SPECIFYING THE TASK TO BE PERFORMED. -C INPUT ONLY. ITASK HAS THE FOLLOWING VALUES AND MEANINGS. -C 1 MEANS NORMAL COMPUTATION OF OUTPUT VALUES OF Y(T) AT -C T = TOUT (BY OVERSHOOTING AND INTERPOLATING). -C 2 MEANS TAKE ONE STEP ONLY AND RETURN. -C 3 MEANS STOP AT THE FIRST INTERNAL MESH POINT AT OR -C BEYOND T = TOUT AND RETURN. -C 4 MEANS NORMAL COMPUTATION OF OUTPUT VALUES OF Y(T) AT -C T = TOUT BUT WITHOUT OVERSHOOTING T = TCRIT. -C TCRIT MUST BE INPUT AS RWORK(1). TCRIT MAY BE EQUAL TO -C OR BEYOND TOUT, BUT NOT BEHIND IT IN THE DIRECTION OF -C INTEGRATION. THIS OPTION IS USEFUL IF THE PROBLEM -C HAS A SINGULARITY AT OR BEYOND T = TCRIT. -C 5 MEANS TAKE ONE STEP, WITHOUT PASSING TCRIT, AND RETURN. -C TCRIT MUST BE INPUT AS RWORK(1). -C -C NOTE.. IF ITASK = 4 OR 5 AND THE KppSolveR REACHES TCRIT -C (WITHIN ROUNDOFF), IT WILL RETURN T = TCRIT (EXACTLY) TO -C INDICATE THIS (UNLESS ITASK = 4 AND TOUT COMES BEFORE TCRIT, -C IN WHICH CASE ANSWERS AT T = TOUT ARE RETURNED FIRST). -C -C ISTATE = AN INDEX USED FOR INPUT AND OUTPUT TO SPECIFY THE -C THE STATE OF THE CALCULATION. -C -C ON INPUT, THE VALUES OF ISTATE ARE AS FOLLOWS. -C 1 MEANS THIS IS THE FIRST CALL FOR THE PROBLEM -C (INITIALIZATIONS WILL BE DONE). SEE NOTE BELOW. -C 2 MEANS THIS IS NOT THE FIRST CALL, AND THE CALCULATION -C IS TO CONTINUE NORMALLY, WITH NO CHANGE IN ANY INPUT -C PARAMETERS EXCEPT POSSIBLY TOUT AND ITASK. -C (IF ITOL, RTOL, AND/OR ATOL ARE CHANGED BETWEEN CALLS -C WITH ISTATE = 2, THE NEW VALUES WILL BE USED BUT NOT -C TESTED FOR LEGALITY.) -C 3 MEANS THIS IS NOT THE FIRST CALL, AND THE -C CALCULATION IS TO CONTINUE NORMALLY, BUT WITH -C A CHANGE IN INPUT PARAMETERS OTHER THAN -C TOUT AND ITASK. CHANGES ARE ALLOWED IN -C ITOL, RTOL, ATOL, IOPT, LRW, LIW, MF, ML, MU, -C AND ANY OF THE OPTIONAL INPUTS EXCEPT H0. -C (SEE IWORK DESCRIPTION FOR ML AND MU.) -C NOTE.. A PRELIMINARY CALL WITH TOUT = T IS NOT COUNTED -C AS A FIRST CALL HERE, AS NO INITIALIZATION OR CHECKING OF -C INPUT IS DONE. (SUCH A CALL IS SOMETIMES USEFUL FOR THE -C PURPOSE OF OUTPUTTING THE INITIAL CONDITIONS.) -C THUS THE FIRST CALL FOR WHICH TOUT .NE. T REQUIRES -C ISTATE = 1 ON INPUT. -C -C ON OUTPUT, ISTATE HAS THE FOLLOWING VALUES AND MEANINGS. -C 1 MEANS NOTHING WAS DONE, AS TOUT WAS EQUAL TO T WITH -C ISTATE = 1 ON INPUT. (HOWEVER, AN INTERNAL COUNTER WAS -C SET TO DETECT AND PREVENT REPEATED CALLS OF THIS TYPE.) -C 2 MEANS THE INTEGRATION WAS PERFORMED SUCCESSFULLY. -C -1 MEANS AN EXCESSIVE AMOUNT OF WORK (MORE THAN MXSTEP -C STEPS) WAS DONE ON THIS CALL, BEFORE COMPLETING THE -C REQUESTED TASK, BUT THE INTEGRATION WAS OTHERWISE -C SUCCESSFUL AS FAR AS T. (MXSTEP IS AN OPTIONAL INPUT -C AND IS NORMALLY 500.) TO CONTINUE, THE USER MAY -C SIMPLY RESET ISTATE TO A VALUE .GT. 1 AND CALL AGAIN -C (THE EXCESS WORK STEP COUNTER WILL BE RESET TO 0). -C IN ADDITION, THE USER MAY INCREASE MXSTEP TO AVOID -C THIS ERROR RETURN (SEE BELOW ON OPTIONAL INPUTS). -C -2 MEANS TOO MUCH ACCURACY WAS REQUESTED FOR THE PRECISION -C OF THE MACHINE BEING USED. THIS WAS DETECTED BEFORE -C COMPLETING THE REQUESTED TASK, BUT THE INTEGRATION -C WAS SUCCESSFUL AS FAR AS T. TO CONTINUE, THE TOLERANCE -C PARAMETERS MUST BE RESET, AND ISTATE MUST BE SET -C TO 3. THE OPTIONAL OUTPUT TOLSF MAY BE USED FOR THIS -C PURPOSE. (NOTE.. IF THIS CONDITION IS DETECTED BEFORE -C TAKING ANY STEPS, THEN AN ILLEGAL INPUT RETURN -C (ISTATE = -3) OCCURS INSTEAD.) -C -3 MEANS ILLEGAL INPUT WAS DETECTED, BEFORE TAKING ANY -C INTEGRATION STEPS. SEE WRITTEN MESSAGE FOR DETAILS. -C NOTE.. IF THE KppSolveR DETECTS AN INFINITE LOOP OF CALLS -C TO THE KppSolveR WITH ILLEGAL INPUT, IT WILL CAUSE -C THE RUN TO STOP. -C -4 MEANS THERE WERE REPEATED ERROR TEST FAILURES ON -C ONE ATTEMPTED STEP, BEFORE COMPLETING THE REQUESTED -C TASK, BUT THE INTEGRATION WAS SUCCESSFUL AS FAR AS T. -C THE PROBLEM MAY HAVE A SINGULARITY, OR THE INPUT -C MAY BE INAPPROPRIATE. -C -5 MEANS THERE WERE REPEATED CONVERGENCE TEST FAILURES ON -C ONE ATTEMPTED STEP, BEFORE COMPLETING THE REQUESTED -C TASK, BUT THE INTEGRATION WAS SUCCESSFUL AS FAR AS T. -C THIS MAY BE CAUSED BY AN INACCURATE JACOBIAN MATRIX, -C IF ONE IS BEING USED. -C -6 MEANS EWT(I,J) BECAME ZERO FOR SOME I,J DURING THE -C INTEGRATION. PURE RELATIVE ERROR CONTROL (ATOL(I,J)=0.0) -C WAS REQUESTED ON A VARIABLE WHICH HAS NOW VANISHED. -C THE INTEGRATION WAS SUCCESSFUL AS FAR AS T. -C -C NOTE.. SINCE THE NORMAL OUTPUT VALUE OF ISTATE IS 2, -C IT DOES NOT NEED TO BE RESET FOR NORMAL CONTINUATION. -C ALSO, SINCE A NEGATIVE INPUT VALUE OF ISTATE WILL BE -C REGARDED AS ILLEGAL, A NEGATIVE OUTPUT VALUE REQUIRES THE -C USER TO CHANGE IT, AND POSSIBLY OTHER INPUTS, BEFORE -C CALLING THE KppSolveR AGAIN. -C -C IOPT = AN INTEGER ARRAY FLAG TO SPECIFY WHETHER OR NOT ANY OPTIONAL -C INPUTS ARE BEING USED ON THIS CALL. INPUT ONLY. -C THE OPTIONAL INPUTS ARE LISTED SEPARATELY BELOW. -C IOPT(1) = 0 MEANS NO OPTIONAL INPUTS FOR THE KppSolveR WILL BE -C USED. DEFAULT VALUES WILL BE USED IN ALL CASES. -C = 1 MEANS ONE OR MORE OPTIONAL INPUTS FOR THE -C KppSolveR ARE BEING USED. -C NOTE : IOPT(1) IS INDEPENDENT OF ISOPT AND IDF. -C IOPT(2) = 0 MEANS NO SENSITIVITY ANALYSIS WILL BE PERFORMED. -C = 1 MEANS A SENSITIVITY ANALYSIS WILL BE PERFORMED. -C NOTE : IOPT(2) IS RENAMED TO ISOPT IN ODESSA. -C = 0 MEANS DF/DP WILL BE CALCULATED BY FINITE -C DIFFERENCE WITHIN ODESSA. -C IOPT(3) = 1 MEANS DF/DP WILL BE CALCULATED BY A USER-SUPPLIED -C ROUTINE. -C NOTE : IOPT(3) IS RENAMED TO IDF IN ODESSA. -C IF IDF = 1, THE USER MUST SUPPLY A -C SUBROUTINE DF (THE NAME IS ARBITRARY) AS -C DESCRIBED BELOW UNDER DF. FOR IDF = 0, -C A DUMMY ARGUMENT CAN BE USED. -C -C RWORK = A REAL WORKING ARRAY (DOUBLE PRECISION). -C FOR ISOPT = 0, THE LENGTH OF RWORK MUST BE AT LEAST.. -C 20 + NYH*(MAXORD + 1) + 3*NEQ + LWM -C FOR ISOPT = 1, THE LENGTH OF RWORK MUST BE AT LEAST.. -C 20 + NYH*(MAXORD + 1) + 2*NYH + LWM + N -C WHERE.. -C NYH = THE TOTAL NUMBER OF DEPENDENT VARIABLES; -C (= N IF ISOPT = 0, AND N*(NPAR+1) IF ISOPT = 1). -C MAXORD = 12 (IF METH = 1) OR 5 (IF METH = 2) (UNLESS A -C SMALLER VALUE IS GIVEN AS AN OPTIONAL INPUT), -C LWM = 0 IF MITER = 0, -C LWM = N**2 + 2 IF MITER IS 1 OR 2, -C LWM = N + 2 IF MITER = 3, AND -C LWM = (2*ML+MU+1)*N + 2 IF MITER IS 4 OR 5. -C (SEE THE MF DESCRIPTION FOR METH AND MITER.) -C -C THE FIRST 20 WORDS OF RWORK ARE RESERVED FOR CONDITIONAL -C AND OPTIONAL INPUTS AND OPTIONAL OUTPUTS. -C -C THE FOLLOWING WORD IN RWORK IS A CONDITIONAL INPUT.. -C RWORK(1) = TCRIT = CRITICAL VALUE OF T WHICH THE KppSolveR -C IS NOT TO OVERSHOOT. REQUIRED IF ITASK IS -C 4 OR 5, AND IGNORED OTHERWISE. (SEE ITASK.) -C -C LRW = THE LENGTH OF THE ARRAY RWORK, AS DECLARED BY THE USER. -C (THIS WILL BE CHECKED BY THE KppSolveR.) -C -C IWORK = AN INTEGER WORK ARRAY. THE LENGTH MUST BE AT LEAST.. -C 20 IF MITER = 0 OR 3 (MF = 10, 13, 20, 23), OR -C 20 + N OTHERWISE (MF = 11, 12, 14, 15, 21, 22, 24, 25). -C FOR ISOPT = 0, OR.. -C 21 + N + NPAR -C FOR ISOPT = 1. -C THE FIRST FEW WORDS OF IWORK ARE USED FOR CONDITIONAL AND -C OPTIONAL INPUTS AND OPTIONAL OUTPUTS. -C -C THE FOLLOWING 2 WORDS IN IWORK ARE CONDITIONAL INPUTS.. -C IWORK(1) = ML THESE ARE THE LOWER AND UPPER -C IWORK(2) = MU HALF-BANDWIDTHS, RESPECTIVELY, OF THE -C BANDED JACOBIAN, EXCLUDING THE MAIN DIAGONAL. -C THE BAND IS DEFINED BY THE MATRIX LOCATIONS -C (I,J) WITH I-ML .LE. J .LE. I+MU. ML AND MU -C MUST SATISFY 0 .LE. ML,MU .LE. NEQ-1. -C THESE ARE REQUIRED IF MITER IS 4 OR 5, AND -C IGNORED OTHERWISE. ML AND MU MAY IN FACT BE -C THE BAND PARAMETERS FOR A MATRIX TO WHICH -C DF/DY IS ONLY APPROXIMATELY EQUAL. -* -C -C LIW = THE LENGTH OF THE ARRAY IWORK, AS DECLARED BY THE USER. -C (THIS WILL BE CHECKED BY THE KppSolveR.) -C -C NOTE.. THE WORK ARRAYS MUST NOT BE ALTERED BETWEEN CALLS TO ODESSA -C FOR THE SAME PROBLEM, EXCEPT POSSIBLY FOR THE CONDITIONAL AND -C OPTIONAL INPUTS, AND EXCEPT FOR THE LAST 2*NYH + N WORDS OF RWORK. -C THE LATTER SPACE IS USED FOR INTERNAL SCRATCH SPACE, AND SO IS -C AVAILABLE FOR USE BY THE USER OUTSIDE ODESSA BETWEEN CALLS, IF -C DESIRED (BUT NOT FOR USE BY F, DF, OR JAC). -C -C JAC = THE NAME OF THE USER-SUPPLIED ROUTINE (MITER = 1 OR 4) TO -C COMPUTE THE JACOBIAN MATRIX, DF/DY, AS A FUNCTION OF THE -C SCALAR T AND THE VECTORS Y, AND PAR. IT IS TO HAVE THE FORM -C SUBROUTINE JAC (NEQ, T, Y, PAR, ML, MU, PD, NROWPD) -C DOUBLE PRECISION T, Y, PAR, PD -C DIMENSION Y(1), PAR(1), PD(NROWPD,1) -C WHERE NEQ, T, Y, PAR, ML, MU, AND NROWPD ARE INPUT AND THE -C ARRAY PD IS TO BE LOADED WITH PARTIAL DERIVATIVES (ELEMENTS -C OF THE JACOBIAN MATRIX) ON OUTPUT. PD MUST BE GIVEN A FIRST -C DIMENSION OF NROWPD. T, Y, AND PAR HAVE THE SAME MEANING AS -C IN SUBROUTINE F. (IN THE DIMENSION STATEMENT ABOVE, 1 IS A -C DUMMY DIMENSION.. IT CAN BE REPLACED BY ANY VALUE.) -C IN THE FULL MATRIX CASE (MITER = 1), ML AND MU ARE -C IGNORED, AND THE JACOBIAN IS TO BE LOADED INTO PD IN -C COLUMNWISE MANNER, WITH DF(I)/DY(J) LOADED INTO PD(I,J). -C IN THE BAND MATRIX CASE (MITER = 4), THE ELEMENTS -C WITHIN THE BAND ARE TO BE LOADED INTO PD IN COLUMNWISE -C MANNER, WITH DIAGONAL LINES OF DF/DY LOADED INTO THE ROWS -C OF PD. THUS DF(I)/DY(J) IS TO BE LOADED INTO PD(I-J+MU+1,J). -C ML AND MU ARE THE HALF-BANDWIDTH PARAMETERS (SEE IWORK). -C THE LOCATIONS IN PD IN THE TWO TRIANGULAR AREAS WHICH -C CORRESPOND TO NONEXISTENT MATRIX ELEMENTS CAN BE IGNORED -C OR LOADED ARBITRARILY, AS THEY ARE OVERWRITTEN BY ODESSA. -C PD IS PRESET TO ZERO BY THE KppSolveR, SO THAT ONLY THE -C NONZERO ELEMENTS NEED BE LOADED BY JAC. EACH CALL TO JAC IS -C PRECEDED BY A CALL TO F WITH THE SAME ARGUMENTS NEQ, T, Y, -C AND PAR. THUS TO GAIN SOME EFFICIENCY, INTERMEDIATE -C QUANTITIES SHARED BY BOTH CALCULATIONS MAY BE SAVED IN A -C USER COMMON BLOCK BY F AND NOT RECOMPUTED BY JAC, IF -C DESIRED. ALSO, JAC MAY ALTER THE Y ARRAY, IF DESIRED. -C JAC MUST BE DECLARED EXTERNAL IN THE CALLING PROGRAM. -C SUBROUTINE JAC MAY ACCESS USER-DEFINED QUANTITIES IN -C NEQ(2),... AND PAR(NPAR+1),.... SEE THE DESCRIPTIONS OF -C NEQ (ABOVE) AND PAR (BELOW). -C -C MF = THE METHOD FLAG. USED ONLY FOR INPUT. THE LEGAL VALUES OF -C MF ARE 10, 11, 12, 13, 14, 15, 20, 21, 22, 23, 24, AND 25. -C MF HAS DECIMAL DIGITS METH AND MITER.. MF = 10*METH + MITER. -C METH INDICATES THE BASIC LINEAR MULTISTEP METHOD.. -C METH = 1 MEANS THE IMPLICIT ADAMS METHOD. -* -C METH = 2 MEANS THE METHOD BASED ON BACKWARD -C DIFFERENTIATION FORMULAS (BDF-S). -C MITER INDICATES THE CORRECTOR ITERATION METHOD.. -C MITER = 0 MEANS FUNCTIONAL ITERATION (NO JACOBIAN MATRIX -C IS INVOLVED). -C MITER = 1 MEANS CHORD ITERATION WITH A USER-SUPPLIED -C FULL (NEQ BY NEQ) JACOBIAN. -C MITER = 2 MEANS CHORD ITERATION WITH AN INTERNALLY -C GENERATED (DIFFERENCE QUOTIENT) FULL JACOBIAN -C (USING NEQ EXTRA CALLS TO F PER DF/DY VALUE). -C MITER = 3 MEANS CHORD ITERATION WITH AN INTERNALLY -C GENERATED DIAGONAL JACOBIAN APPROXIMATION. -C (USING 1 EXTRA CALL TO F PER DF/DY EVALUATION). -C MITER = 4 MEANS CHORD ITERATION WITH A USER-SUPPLIED -C BANDED JACOBIAN. -C MITER = 5 MEANS CHORD ITERATION WITH AN INTERNALLY -C GENERATED BANDED JACOBIAN (USING ML+MU+1 EXTRA -C CALLS TO F PER DF/DY EVALUATION). -C IF MITER = 1 OR 4, THE USER MUST SUPPLY A SUBROUTINE JAC -C (THE NAME IS ARBITRARY) AS DESCRIBED ABOVE UNDER JAC. -C FOR OTHER VALUES OF MITER, A DUMMY ARGUMENT CAN BE USED. -C -C IF A SENSITIVITY ANLYSIS IS DESIRED (ISOPT = 1), MITER = 0 -C AND 3 ARE DISALLOWED. IN THESE CASES, THE USER IS RECOMMENDED -C TO SUPPLY AN ANALYTICAL JACOBIAN (MITER = 1 OR 4) AND AN -C ANALYTICAL INHOMOGENEITY MATRIX (IDF = 1). -C---------------------------------------------------------------------- -C OPTIONAL INPUTS. -C -C THE FOLLOWING IS A LIST OF THE OPTIONAL INPUTS PROVIDED FOR IN THE -C CALL SEQUENCE. (SEE ALSO PART II.) FOR EACH SUCH INPUT VARIABLE, -C THIS TABLE LISTS ITS NAME AS USED IN THIS DOCUMENTATION, ITS -C LOCATION IN THE CALL SEQUENCE, ITS MEANING, AND THE DEFAULT VALUE. -C THE USE OF ANY OF THESE INPUTS REQUIRES IOPT(1) = 1, AND IN THAT -C CASE ALL OF THESE INPUTS ARE EXAMINED. A VALUE OF ZERO FOR ANY -C OF THESE OPTIONAL INPUTS WILL CAUSE THE DEFAULT VALUE TO BE USED. -C THUS TO USE A SUBSET OF THE OPTIONAL INPUTS, SIMPLY PRELOAD -C LOCATIONS 5 TO 10 IN RWORK AND IWORK TO 0.0 AND 0 RESPECTIVELY, AND -C THEN SET THOSE OF INTEREST TO NONZERO VALUES. -C -C NAME LOCATION MEANING AND DEFAULT VALUE -C -C H0 RWORK(5) THE STEP SIZE TO BE ATTEMPTED ON THE FIRST STEP. -C THE DEFAULT VALUE IS DETERMINED BY THE KppSolveR. -C -C HMAX RWORK(6) THE MAXIMUM ABSOLUTE STEP SIZE ALLOWED. -C THE DEFAULT VALUE IS INFINITE. -C -C HMIN RWORK(7) THE MINIMUM ABSOLUTE STEP SIZE ALLOWED. -C THE DEFAULT VALUE IS 0. (THIS LOWER BOUND IS NOT -C ENFORCED ON THE FINAL STEP BEFORE REACHING TCRIT -C WHEN ITASK = 4 OR 5.) -C -C MAXORD IWORK(5) THE MAXIMUM ORDER TO BE ALLOWED. THE DEFAULT -C VALUE IS 12 IF METH = 1, AND 5 IF METH = 2. -C IF MAXORD EXCEEDS THE DEFAULT VALUE, IT WILL -C BE REDUCED TO THE DEFAULT VALUE. -C IF MAXORD IS CHANGED DURING THE PROBLEM, IT MAY -C CAUSE THE CURRENT ORDER TO BE REDUCED. -C -C MXSTEP IWORK(6) MAXIMUM NUMBER OF (INTERNALLY DEFINED) STEPS -C ALLOWED DURING ONE CALL TO THE KppSolveR. -C THE DEFAULT VALUE IS 500. -C -C MXHNIL IWORK(7) MAXIMUM NUMBER OF MESSAGES PRINTED (PER PROBLEM) -C WARNING THAT T + H = T ON A STEP (H = STEP SIZE). -C THIS MUST BE POSITIVE TO RESULT IN A NON-DEFAULT -C VALUE. THE DEFAULT VALUE IS 10. -C---------------------------------------------------------------------- -C OPTIONAL OUTPUTS. -C -C AS OPTIONAL ADDITIONAL OUTPUT FROM ODESSA, THE VARIABLES LISTED -C BELOW ARE QUANTITIES RELATED TO THE PERFORMANCE OF ODESSA -C WHICH ARE AVAILABLE TO THE USER. THESE ARE COMMUNICATED BY WAY OF -C THE WORK ARRAYS, BUT ALSO HAVE INTERNAL MNEMONIC NAMES AS SHOWN. -C EXCEPT WHERE STATED OTHERWISE, ALL OF THESE OUTPUTS ARE DEFINED -C ON ANY SUCCESSFUL RETURN FROM ODESSA, AND ON ANY RETURN WITH -C ISTATE = -1, -2, -4, -5, OR -6. ON AN ILLEGAL INPUT RETURN -C (ISTATE = -3), THEY WILL BE UNCHANGED FROM THEIR EXISTING VALUES -C (IF ANY), EXCEPT POSSIBLY FOR TOLSF, LENRW, AND LENIW. -C ON ANY ERROR RETURN, OUTPUTS RELEVANT TO THE ERROR WILL BE DEFINED, -C AS NOTED BELOW. -C -C NAME LOCATION MEANING -C -C HU RWORK(11) THE STEP SIZE IN T LAST USED (SUCCESSFULLY). -C -C HCUR RWORK(12) THE STEP SIZE TO BE ATTEMPTED ON THE NEXT STEP. -C -C TCUR RWORK(13) THE CURRENT VALUE OF THE INDEPENDENT VARIABLE -C WHICH THE KppSolveR HAS ACTUALLY REACHED, I.E. THE -C CURRENT INTERNAL MESH POINT IN T. ON OUTPUT, TCUR -C WILL ALWAYS BE AT LEAST AS FAR AS THE ARGUMENT -C T, BUT MAY BE FARTHER (IF INTERPOLATION WAS DONE). -C -C TOLSF RWORK(14) A TOLERANCE SCALE FACTOR, GREATER THAN 1.0, -C COMPUTED WHEN A REQUEST FOR TOO MUCH ACCURACY WAS -C DETECTED (ISTATE = -3 IF DETECTED AT THE START OF -C THE PROBLEM, ISTATE = -2 OTHERWISE). IF ITOL IS -C LEFT UNALTERED BUT RTOL AND ATOL ARE UNIFORMLY -C SCALED UP BY A FACTOR OF TOLSF FOR THE NEXT CALL, -C THEN THE KppSolveR IS DEEMED LIKELY TO SUCCEED. -C (THE USER MAY ALSO IGNORE TOLSF AND ALTER THE -C TOLERANCE PARAMETERS IN ANY OTHER WAY APPROPRIATE.) -C -C NST IWORK(11) THE NUMBER OF STEPS TAKEN FOR THE PROBLEM SO FAR. -C -C NFE IWORK(12) THE NUMBER OF F EVALUATIONS FOR THE PROBLEM SO FAR. -C -C NJE IWORK(13) THE NUMBER OF JACOBIAN EVALUATIONS (AND OF MATRIX -C LU DECOMPOSITIONS IF ISOPT = 0) FOR THE PROBLEM SO -C FAR. IF ISOPT = 1, THE NUMBER OF LU DECOMPOSITIONS -C IS EQUAL TO NJE - NSPE (SEE BELOW). -C -C NQU IWORK(14) THE METHOD ORDER LAST USED (SUCCESSFULLY). -C -C NQCUR IWORK(15) THE ORDER TO BE ATTEMPTED ON THE NEXT STEP. -C -C IMXER IWORK(16) THE INDEX OF THE COMPONENT OF LARGEST MAGNITUDE IN -C THE WEIGHTED LOCAL ERROR VECTOR (E(I,J)/EWT(I,J)), -C ON AN ERROR RETURN WITH ISTATE = -4 OR -5. -C -C LENRW IWORK(17) THE LENGTH OF RWORK ACTUALLY REQUIRED. -C THIS IS DEFINED ON NORMAL RETURNS AND ON AN ILLEGAL -C INPUT RETURN FOR INSUFFICIENT STORAGE. -C -C LENIW IWORK(18) THE LENGTH OF IWORK ACTUALLY REQUIRED. -C THIS IS DEFINED ON NORMAL RETURNS AND ON AN ILLEGAL -C INPUT RETURN FOR INSUFFICIENT STORAGE. -C -C NDFE IWORK(19) THE NUMBER OF DF/DP (VECTOR) EVALUATIONS. -C -C NSPE IWORK(20) THE NUMBER OF CALLS TO SUBROUTINE SPRIME. EACH CALL -C TO SPRIME REQUIRES A JACOBIAN EVALUATION, BUT NOT -C AN LU DECOMPOSITION. -C -C THE FOLLOWING ARRAYS ARE SEGMENTS OF THE RWORK AND IWORK ARRAYS -C WHICH MAY ALSO BE OF INTEREST TO THE USER AS OPTIONAL OUTPUTS. -C FOR EACH ARRAY, THE TABLE BELOW GIVES ITS INTERNAL NAME, ITS BASE -C ADDRESS IN RWORK OR IWORK, AND ITS DESCRIPTION. -C -C NAME BASE ADDRESS DESCRIPTION -C -C YH 21 IN RWORK THE NORDSIECK HISTORY ARRAY, OF SIZE NYH BY -C (NQCUR + 1). FOR J = 0,1,...,NQCUR, COLUMN J+1 -C OF YH CONTAINS HCUR**J/FACTORIAL(J) TIMES -C THE J-TH DERIVATIVE OF THE INTERPOLATING -C POLYNOMIAL CURRENTLY REPRESENTING THE SOLUTION, -C EVALUATED AT T = TCUR. -C -C ACOR LENRW-NYH+1 ARRAY OF SIZE NYH USED FOR THE ACCUMULATED -C IN RWORK CORRECTIONS ON EACH STEP, SCALED ON OUTPUT -C TO REPRESENT THE ESTIMATED LOCAL ERROR IN Y -C ON THE LAST STEP. THIS IS THE VECTOR E IN -C THE DESCRIPTION OF THE ERROR CONTROL. -C IT IS DEFINED ONLY ON A SUCCESSFUL RETURN -C FROM ODESSA. -C NRS LENIW-NPAR ARRAY OF SIZE NPAR+1, USED TO STORE THE -C IN IWORK ACCUMULATED NUMBER OF REPEATED STEPS DUE TO -C THE SENSITIVITY ANALYSIS.. -C NRS(1) = TOTAL NUMBER OF REPEATED STEPS, -C NRS(2),... = NUMBER OF REPEATED STEPS DUE TO -C MODEL PARAMETER 1,... -C -C---------------------------------------------------------------------- -C PART II. OTHER ROUTINES CALLABLE. -C -C THE FOLLOWING ARE OPTIONAL CALLS WHICH THE USER MAY MAKE TO -C GAIN ADDITIONAL CAPABILITIES IN CONJUNCTION WITH ODESSA. -C (THE ROUTINES XSETUN AND XSETF ARE DESIGNED TO CONFORM TO THE -C SLATEC ERROR HANDLING PACKAGE.) -C -C FORM OF CALL FUNCTION -C CALL XSETUN(LUN) SET THE LOGICAL UNIT NUMBER, LUN, FOR -C OUTPUT OF MESSAGES FROM ODESSA, IF -C THE DEFAULT IS NOT DESIRED. -C THE DEFAULT VALUE OF LUN IS 6. -C -C CALL XSETF(MFLAG) SET A FLAG TO CONTROL THE PRINTING OF -C MESSAGES BY ODESSA.. -C MFLAG = 0 MEANS DO NOT PRINT. (DANGER.. -C THIS RISKS LOSING VALUABLE INFORMATION.) -C MFLAG = 1 MEANS PRINT (THE DEFAULT). -C -C EITHER OF THE ABOVE CALLS MAY BE MADE AT -C ANY TIME AND WILL TAKE EFFECT IMMEDIATELY. -C -C CALL SVCOM (RSAV, ISAV) STORE IN RSAV AND ISAV THE CONTENTS -C OF THE INTERNAL COMMON BLOCKS USED BY -C ODESSA (SEE PART III BELOW). -C RSAV MUST BE A REAL ARRAY OF LENGTH 222 -C OR MORE, AND ISAV MUST BE AN INTEGER -C ARRAY OF LENGTH 54 OR MORE. -C -C CALL RSCOM (RSAV, ISAV) RESTORE, FROM RSAV AND ISAV, THE CONTENTS -C OF THE INTERNAL COMMON BLOCKS USED BY -C ODESSA. PRESUMES A PRIOR CALL TO SVCOM -C WITH THE SAME ARGUMENTS. -C -C SVCOM AND RSCOM ARE USEFUL IF -C INTERRUPTING A RUN AND RESTARTING -C LATER, OR ALTERNATING BETWEEN TWO OR -C MORE PROBLEMS KppSolveD WITH ODESSA. -C -C CALL INTDY(,,,,,) PROVIDE DERIVATIVES OF Y, OF VARIOUS -C (SEE BELOW) ORDERS, AT A SPECIFIED POINT T, IF -C DESIRED. IT MAY BE CALLED ONLY AFTER -C A SUCCESSFUL RETURN FROM ODESSA. -C -C THE DETAILED INSTRUCTIONS FOR USING INTDY ARE AS FOLLOWS. -C THE FORM OF THE CALL IS.. -C -C CALL INTDY (T, K, RWORK(21), NYH, DKY, IFLAG) -C -C THE INPUT PARAMETERS ARE.. -C -C T = VALUE OF INDEPENDENT VARIABLE WHERE ANSWERS ARE DESIRED -C (NORMALLY THE SAME AS THE T LAST RETURNED BY ODESSA). -C FOR VALID RESULTS, T MUST LIE BETWEEN TCUR - HU AND TCUR. -C (SEE OPTIONAL OUTPUTS FOR TCUR AND HU.) -C K = INTEGER ORDER OF THE DERIVATIVE DESIRED. K MUST SATISFY -C 0 .LE. K .LE. NQCUR, WHERE NQCUR IS THE CURRENT ORDER -C (SEE OPTIONAL OUTPUTS). THE CAPABILITY CORRESPONDING -C TO K = 0, I.E. COMPUTING Y(T), IS ALREADY PROVIDED -C BY ODESSA DIRECTLY. SINCE NQCUR .GE. 1, THE FIRST -C DERIVATIVE DY/DT IS ALWAYS AVAILABLE WITH INTDY. -C RWORK(21) = THE BASE ADDRESS OF THE HISTORY ARRAY YH. -C NYH = COLUMN LENGTH OF YH, EQUAL TO THE TOTAL NUMBER OF -C DEPENDENT VARIABLES. IF ISOPT = 0, NYH = N. IF ISOPT = 1, -C NYH = N * (NPAR + 1). -C -C THE OUTPUT PARAMETERS ARE.. -C -C DKY = A REAL ARRAY OF LENGTH NYH CONTAINING THE COMPUTED VALUE -C OF THE K-TH DERIVATIVE OF Y(T). -C IFLAG = INTEGER FLAG, RETURNED AS 0 IF K AND T WERE LEGAL, -C -1 IF K WAS ILLEGAL, AND -2 IF T WAS ILLEGAL. -C ON AN ERROR RETURN, A MESSAGE IS ALSO WRITTEN. -C---------------------------------------------------------------------- -C PART III. COMMON BLOCKS. -C -C IF ODESSA IS TO BE USED IN AN OVERLAY SITUATION, THE USER -C MUST DECLARE, IN THE PRIMARY OVERLAY, THE VARIABLES IN.. -C (1) THE CALL SEQUENCE TO ODESSA, -C (2) THE THREE INTERNAL COMMON BLOCKS -C /ODE001/ OF LENGTH 258 (219 DOUBLE PRECISION WORDS -C FOLLOWED BY 39 INTEGER WORDS), -C /ODE002/ OF LENGTH 14 (3 DOUBLE PRECISION WORDS FOLLOWED -C BY 11 INTEGER WORDS), -C /EH0001/ OF LENGTH 2 (INTEGER WORDS). -C -C IF ODESSA IS USED ON A SYSTEM IN WHICH THE CONTENTS OF INTERNAL -C COMMON BLOCKS ARE NOT PRESERVED BETWEEN CALLS, THE USER SHOULD -C DECLARE THE ABOVE THREE COMMON BLOCKS IN HIS MAIN PROGRAM TO INSURE -C THAT THEIR CONTENTS ARE PRESERVED. -C -C IF THE SOLUTION OF A GIVEN PROBLEM BY ODESSA IS TO BE INTERRUPTED -C AND THEN LATER CONTINUED, SUCH AS WHEN RESTARTING AN INTERRUPTED RUN -C OR ALTERNATING BETWEEN TWO OR MORE PROBLEMS, THE USER SHOULD SAVE, -C FOLLOWING THE RETURN FROM THE LAST ODESSA CALL PRIOR TO THE -C INTERRUPTION, THE CONTENTS OF THE CALL SEQUENCE VARIABLES AND THE -C INTERNAL COMMON BLOCKS, AND LATER RESTORE THESE VALUES BEFORE THE -C NEXT ODESSA CALL FOR THAT PROBLEM. TO SAVE AND RESTORE THE COMMON -C BLOCKS, USE SUBROUTINES SVCOM AND RSCOM (SEE PART II ABOVE). -C -C---------------------------------------------------------------------- -C PART IV. OPTIONALLY REPLACEABLE KppSolveR ROUTINES. -C -C BELOW ARE DESCRIPTIONS OF TWO ROUTINES IN THE ODESSA PACKAGE WHICH -C RELATE TO THE MEASUREMENT OF ERRORS. EITHER ROUTINE CAN BE -C REPLACED BY A USER-SUPPLIED VERSION, IF DESIRED. HOWEVER, SINCE SUCH -C A REPLACEMENT MAY HAVE A MAJOR IMPACT ON PERFORMANCE, IT SHOULD BE -C DONE ONLY WHEN ABSOLUTELY NECESSARY, AND ONLY WITH GREAT CAUTION. -C (NOTE.. THE MEANS BY WHICH THE PACKAGE VERSION OF A ROUTINE IS -C SUPERSEDED BY THE USER-S VERSION MAY BE SYSTEM-DEPENDENT.) -C -C (A) EWSET. -C THE FOLLOWING SUBROUTINE IS CALLED JUST BEFORE EACH INTERNAL -C INTEGRATION STEP, AND SETS THE ARRAY OF ERROR WEIGHTS, EWT, AS -C DESCRIBED UNDER ITOL/RTOL/ATOL ABOVE.. -C SUBROUTINE EWSET (NYH, ITOL, RTOL, ATOL, YCUR, EWT) -C WHERE NEQ, ITOL, RTOL, AND ATOL ARE AS IN THE ODESSA CALL SEQUENCE, -C YCUR CONTAINS THE CURRENT DEPENDENT VARIABLE VECTOR, AND -C EWT IS THE ARRAY OF WEIGHTS SET BY EWSET. -C -C IF THE USER SUPPLIES THIS SUBROUTINE, IT MUST RETURN IN EWT(I) -C (I = 1,...,NYH) A POSITIVE QUANTITY SUITABLE FOR COMPARING ERRORS -C IN Y(I) TO. THE EWT ARRAY RETURNED BY EWSET IS PASSED TO THE -C VNORM ROUTINE (SEE BELOW), AND ALSO USED BY ODESSA IN THE COMPUTATION -C OF THE OPTIONAL OUTPUT IMXER, THE DIAGONAL JACOBIAN APPROXIMATION, -C AND THE INCREMENTS FOR DIFFERENCE QUOTIENT JACOBIANS. -C -C IN THE USER-SUPPLIED VERSION OF EWSET, IT MAY BE DESIRABLE TO USE -C THE CURRENT VALUES OF DERIVATIVES OF Y. DERIVATIVES UP TO ORDER NQ -C ARE AVAILABLE FROM THE HISTORY ARRAY YH, DESCRIBED ABOVE UNDER -C OPTIONAL OUTPUTS. IN EWSET, YH IS IDENTICAL TO THE YCUR ARRAY, -C EXTENDED TO NQ + 1 COLUMNS WITH A COLUMN LENGTH OF NYH AND SCALE -C FACTORS OF H**J/FACTORIAL(J). ON THE FIRST CALL FOR THE PROBLEM, -C GIVEN BY NST = 0, NQ IS 1 AND H IS TEMPORARILY SET TO 1.0. -C THE QUANTITIES NQ, NYH, H, AND NST CAN BE OBTAINED BY INCLUDING -C IN EWSET THE STATEMENTS.. -C DOUBLE PRECISION H, RLS -C COMMON /ODE001/ RLS(219),ILS(39) -C NQ = ILS(35) -C NYH = ILS(14) -C NST = ILS(36) -C H = RLS(213) -C THUS, FOR EXAMPLE, THE CURRENT VALUE OF DY/DT CAN BE OBTAINED AS -C YCUR(NYH+I)/H (I=1,...,N) (AND THE DIVISION BY H IS -C UNNECESSARY WHEN NST = 0). -C -C (B) VNORM. -C THE FOLLOWING IS A REAL FUNCTION ROUTINE WHICH COMPUTES THE WEIGHTED -C ROOT-MEAN-SQUARE NORM OF A VECTOR V.. -C D = VNORM (LV, V, W) -C WHERE.. -C LV = THE LENGTH OF THE VECTOR, -C V = REAL ARRAY OF LENGTH N CONTAINING THE VECTOR, -C W = REAL ARRAY OF LENGTH N CONTAINING WEIGHTS, -C D = SQRT( (1/N) * SUM(V(I)*W(I))**2 ). -C VNORM IS CALLED WITH LV = N AND WITH W(I) = 1.0/EWT(I), WHERE -C EWT IS AS SET BY SUBROUTINE EWSET. -C -C IF THE USER SUPPLIES THIS FUNCTION, IT SHOULD RETURN A NON-NEGATIVE -C VALUE OF VNORM SUITABLE FOR USE IN THE ERROR CONTROL IN ODESSA. -C NONE OF THE ARGUMENTS SHOULD BE ALTERED BY VNORM. -C FOR EXAMPLE, A USER-SUPPLIED VNORM ROUTINE MIGHT.. -C -SUBSTITUTE A MAX-NORM OF (V(I)*W(I)) FOR THE RMS-NORM, OR -C -IGNORE SOME COMPONENTS OF V IN THE NORM, WITH THE EFFECT OF -C SUPPRESSING THE ERROR CONTROL ON THOSE COMPONENTS OF Y. -C---------------------------------------------------------------------- -C OTHER ROUTINES IN THE ODESSA PACKAGE. -C -C IN ADDITION TO SUBROUTINE ODESSA, THE ODESSA PACKAGE INCLUDES THE -C FOLLOWING SUBROUTINES AND FUNCTION ROUTINES.. -C INTDY COMPUTES AN INTERPOLATED VALUE OF THE Y VECTOR AT T = TOUT. -C STODE IS THE CORE INTEGRATOR, WHICH DOES ONE STEP OF THE -C INTEGRATION AND THE ASSOCIATED ERROR CONTROL. -C STESA MANAGES THE SOLUTION OF THE SENSITIVITY FUNCTIONS. -C CFODE SETS ALL METHOD COEFFICIENTS AND TEST CONSTANTS. -C PREPJ COMPUTES AND PREPROCESSES THE JACOBIAN MATRIX J = DF/DY -C AND THE NEWTON ITERATION MATRIX P = I - H*L0*J. -C IT IS ALSO CALLED BY SPRIME (WITH JOPT = 1) TO JUST -C COMPUTE THE JACOBIAN MATRIX. -C PREPDF COMPUTES THE INHOMOGENEITY MATRIX DF/DP. -C SPRIME DEFINES THE SYSTEM OF SENSITIVITY EQUATIONS. -C SOLSY MANAGES SOLUTION OF LINEAR SYSTEM IN CHORD ITERATION. -C EWSET SETS THE ERROR WEIGHT VECTOR EWT BEFORE EACH STEP. -C VNORM COMPUTES THE WEIGHTED R.M.S. NORM OF A VECTOR. -C SVCOM AND RSCOM ARE USER-CALLABLE ROUTINES TO SAVE AND RESTORE, -C RESPECTIVELY, THE CONTENTS OF THE INTERNAL COMMON BLOCKS. -C DGEFA AND DGESL ARE ROUTINES FROM LINPACK FOR SOLVING FULL -C SYSTEMS OF LINEAR ALGEBRAIC EQUATIONS. -C DGBFA AND DGBSL ARE ROUTINES FROM LINPACK FOR SOLVING BANDED -C LINEAR SYSTEMS. -C DAXPY, DSCAL, IDAMAX, AND DDOT ARE BASIC LINEAR ALGEBRA MODULES -C (BLAS) USED BY THE ABOVE LINPACK ROUTINES. -C D1MACH COMPUTES THE UNIT ROUNDOFF IN A MACHINE-INDEPENDENT MANNER. -C XERR, XSETUN, AND XSETF HANDLE THE PRINTING OF ALL ERROR -C MESSAGES AND WARNINGS. -C NOTE.. VNORM, IDAMAX, DDOT, AND D1MACH ARE FUNCTION ROUTINES. -C ALL THE OTHERS ARE SUBROUTINES. -C -C THE FORTRAN GENERIC INTRINSIC FUNCTIONS USED BY ODESSA ARE.. -C ABS, MAX, MIN, REAL, MOD, SIGN, SQRT, AND WRITE -C -C A BLOCK DATA SUBPROGRAM IS ALSO INCLUDED WITH THE PACKAGE, -C FOR LOADING SOME OF THE VARIABLES IN INTERNAL COMMON. -C -C---------------------------------------------------------------------- -C PART V. GENERAL REMARKS -C -C THIS SECTION HIGHLIGHTS THE BASIC DIFFERENCES BETWEEN THE ORIGINAL -C LSODE PACKAGE AND THE ODESSA MODIFICATION. THIS IS PROVIDED AS A -C SERVICE TO EXPERIENCED LSODE USERS TO EXPEDITE FAMILIARIZATION WITH -C ODESSA. -C -C (A). ORIGINAL SUBROUTINES AND FUNCTIONS. -C -C OF THE ORIGINAL 22 SUBROUTINES AND FUNCTIONS USED IN THE LSODE -C PACKAGE, ALL ARE USED BY ODESSA, WITH THE FOLLOWING HAVING BEEN -C MODIFIED.. -C -C LSODE THE ORIGINAL DRIVER SUBROUTINE FOR THE LSODE PACKAGE IS -C EXTENSIVELY MODIFIED AND RENAMED ODESSA, WHICH NOW -C CONTAINS A CALL TO SPRIME TO ESTABLISH INITIAL CONDITIONS -C FOR THE SENSITIVITY CALCULATIONS. -C -C STODE THE ONE STEP INTEGRATOR IS SLIGHTLY MODIFIED AND RETAINS -C ITS ORIGINAL NAME. IT NOW CONTAINS THE CALL TO STESA, -C AND ALSO CALLS SPRIME IF KFLAG .LE. -3. -C -C PREPJ ALSO NAMED PREPJ IN ODESSA IS SLIGHTLY MODIFIED TO ALLOW -C FOR THE CALCULATION OF JACOBIAN WITH NO PREPROCESSING -C (JOPT = 1). -C -C (B). NEW SUBROUTINES. -C -C IN ADDITION TO THE CHANGES NOTED ABOVE, THREE NEW SUBROUTINES -C HAVE BEEN INTRODUCED (SEE STESA, SPRIME, AND PREPDF AS DESCRIBED -C IN PART IV. ABOVE). -C -C (C). COMMON BLOCKS. -C -C /LS0001/ RETAINS THE SAME LENGTH AND IS RENAMED /ODE001/; -C HOWEVER THE REAL ARRAY ROWNS(209) IS SHORTENED TO A -C LENGTH OF (173) REAL WORDS, ALLOWING THE REMOVAL OF -C TESCO(3,12) WHICH IS NOW PASSED FROM STODE TO STESA. -C IN ADDITION, THE INTEGER ARRAY IOWNS(6) IS SHORTENED -C TO A LENGTH OF (4) INTEGER WORDS, ALLOWING THE REMOVAL -C OF IALTH AND LMAX WHICH ARE NOW PASSED FROM STODE TO -C STESA. -C -C /ODE002/ ADDED COMMON BLOCK FOR VARIABLES IMPORTANT TO -C SENSITIVITY ANALYSIS (SEE PART III. ABOVE). A BLOCK -C DATA PROGRAM IS NOT REQUIRED FOR THIS COMMON BLOCK. -C -C SVCOM,RSCOM THESE TWO SUBROUTINES ARE MODIFIED TO HANDLE -C COMMON BLOCK /ODE002/ AS WELL. -C -C (D). OPTIONAL INPUTS. -C -C THE FULL SET OF OPTIONAL INPUTS AVAILABLE IN LSODE IS ALSO -C AVAILABLE IN ODESSA, WITH THE EXCEPTION THAT THE NUMBER OF ODE'S -C IN THE MODEL (NEQ(1)), MAY NOT BE CHANGED DURING THE PROBLEM. -C IN ODESSA, NYH NOW REFERS TO THE TOTAL NUMBER OF FIRST-ORDER -C ODE'S (MODEL AND SENSITIVITY EQUATIONS) WHICH IS EQUAL TO -C NEQ(1) IF ISOPT = 0, OR NEQ(1)*(NEQ(2)+1) IF ISOPT = 1. -C NEQ(1), NEQ(2), AND NYH ARE NOT ALLOWED TO CHANGE DURING -C THE COURSE OF AN INTEGRATION. -C -C (E). OPTIONAL OUTPUTS. -C -C THE FULL SET OF OPTIONAL OUTPUTS AVAILABLE IN LSODE IS ALSO -C AVAILABLE IN ODESSA. IN ADDITION, IWORK(19) AND IWORK(20) ARE -C LOADED WITH NDFE AND NSPE, RESPECTIVELY, UPON OUTPUT. THE TOTAL -C NUMBER OF LU DECOMPOSITIONS OF THE PROCESSED JACOBIAN IS EQUAL -C TO NJE - NSPE. -C----------------------------------------------------------------------- - SUBROUTINE ODESSA (F, DF, NEQ, Y, PAR, T, TOUT, ITOL, RTOL, ATOL, - 1 ITASK, ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, MF) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - LOGICAL IHIT - EXTERNAL F, DF, JAC, PREPJ, SOLSY, PREPDF - DIMENSION NEQ(*), Y(*), PAR(*), RTOL(*), ATOL(*), IOPT(*), - 1 RWORK(LRW), IWORK(LIW), MORD(2) -C----------------------------------------------------------------------- -C THIS IS THE SEPTEMBER 1, 1986 VERSION OF ODESSA.. -C AN ORDINARY DIFFERENTIAL EQUATION KppSolveR WITH EXPLICIT SIMULTANEOUS -C SENSITIVITY ANALYSIS. -C -C THIS PACKAGE IS A MODIFICATION OF THE AUGUST 13, 1981 VERSION OF -C LSODE.. LIVERMORE KppSolveR FOR ORDINARY DIFFERENTIAL EQUATIONS. -C THIS VERSION IS IN DOUBLE PRECISION. -C -C ODESSA KppSolveS FOR THE FIRST-ORDER SENSITIVITY COEFFICIENTS.. -C DY(I)/DP, FOR A SINGLE PARAMETER, OR, -C DY(I)/DP(J), FOR MULTIPLE PARAMETERS, -C ASSOCIATED WITH A SYSTEM OF ORDINARY DIFFERENTIAL EQUATIONS.. -C DY(T)/DT = F(Y,T;P). -C----------------------------------------------------------------------- -C REFERENCES... -C -C 1. JORGE R. LEIS AND MARK A. KRAMER, THE SIMULTANEOUS SOLUTION AND -C EXPLICIT SENSITIVITY ANALYSIS OF SYSTEMS DESCRIBED BY ORDINARY -C DIFFERENTIAL EQUATIONS, SUBMITTED TO ACM TRANS. MATH. SOFTWARE, -C (1985). -C -C 2. JORGE R. LEIS AND MARK A. KRAMER, ODESSA - AN ORDINARY -C DIFFERENTIAL EQUATION KppSolveR WITH EXPLICIT SIMULTANEOUS -C SENSITIVITY ANALYSIS, SUBMITTED TO ACM TRANS. MATH. SOFTWARE. -C (1985). -C -C 3. ALAN C. HINDMARSH, LSODE AND LSODI, TWO NEW INITIAL VALUE -C ORDINARY DIFFERENTIAL EQUATION KppSolveRS, ACM-SIGNUM NEWSLETTER, -C VOL. 15, NO. 4 (1980), PP. 10-11. -C----------------------------------------------------------------------- -C THE FOLLOWING INTERNAL COMMON BLOCKS CONTAIN -C (A) VARIABLES WHICH ARE LOCAL TO ANY SUBROUTINE BUT WHOSE VALUES MUST -C BE PRESERVED BETWEEN CALLS TO THE ROUTINE (OWN VARIABLES), AND -C (B) VARIABLES WHICH ARE COMMUNICATED BETWEEN SUBROUTINES. -C THE STRUCTURE OF THE BLOCKS ARE AS FOLLOWS.. ALL REAL VARIABLES ARE -C LISTED FIRST, FOLLOWED BY ALL INTEGERS. WITHIN EACH TYPE, THE -C VARIABLES ARE GROUPED WITH THOSE LOCAL TO SUBROUTINE ODESSA FIRST, -C THEN THOSE LOCAL TO SUBROUTINE STODE, AND FINALLY THOSE USED -C FOR COMMUNICATION. THE BLOCKS ARE DECLARED IN SUBROUTINES ODESSA -C INTDY, STODE, STESA, PREPJ, PREPDF, AND SOLSY. GROUPS OF VARIABLES -C ARE REPLACED BY DUMMY ARRAYS IN THE COMMON DECLARATIONS IN ROUTINES -C WHERE THOSE VARIABLES ARE NOT USED. -C----------------------------------------------------------------------- - COMMON /ODE001/ TRET, ROWNS(173), - 1 TESCO(3,12), CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, - 2 ILLIN, INIT, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, - 3 MXSTEP, MXHNIL, NHNIL, NTREP, NSLAST, NYH, IOWNS(4), - 4 IALTH, LMAX, ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, METH, - 5 MITER, MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU - COMMON /ODE002/ DUPS, DSMS, DDNS, - 1 NPAR, LDFDP, LNRS, - 2 ISOPT, NSV, NDFE, NSPE, IDF, IERSP, JOPT, KFLAGS - PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,FOUR=4.0D0) - DATA MORD(1),MORD(2)/12,5/, MXSTP0/500/, MXHNL0/10/ -C----------------------------------------------------------------------- -C BLOCK A. -C THIS CODE BLOCK IS EXECUTED ON EVERY CALL. -C IT TESTS ISTATE AND ITASK FOR LEGALITY AND BRANCHES APPROPIATELY. -C IF ISTATE .GT. 1 BUT THE FLAG INIT SHOWS THAT INITIALIZATION HAS -C NOT YET BEEN DONE, AN ERROR RETURN OCCURS. -C IF ISTATE = 1 AND TOUT = T, JUMP TO BLOCK G AND RETURN IMMEDIATELY. -C----------------------------------------------------------------------- - IF (ISTATE .LT. 1 .OR. ISTATE .GT. 3) GO TO 601 - IF (ITASK .LT. 1 .OR. ITASK .GT. 5) GO TO 602 - IF (ISTATE .EQ. 1) GO TO 10 - IF (INIT .EQ. 0) GO TO 603 - IF (ISTATE .EQ. 2) GO TO 200 - GO TO 20 - 10 INIT = 0 - IF (TOUT .EQ. T) GO TO 430 - 20 NTREP = 0 -C----------------------------------------------------------------------- -C BLOCK B. -C THE NEXT CODE BLOCK IS EXECUTED FOR THE INITIAL CALL (ISTATE = 1), -C OR FOR A CONTINUATION CALL WITH PARAMETER CHANGES (ISTATE = 3). -C IT CONTAINS CHECKING OF ALL INPUTS AND VARIOUS INITIALIZATIONS. -C -C FIRST CHECK LEGALITY OF THE NON-OPTIONAL INPUTS NEQ, ITOL, IOPT, -C MF, ML, AND MU. -C----------------------------------------------------------------------- - IF (NEQ(1) .LE. 0) GO TO 604 - IF (ISTATE .EQ. 1) GO TO 25 - IF (NEQ(1) .NE. N) GO TO 605 - 25 N = NEQ(1) - IF (ITOL .LT. 1 .OR. ITOL .GT. 4) GO TO 606 - DO 26 I = 1,3 - 26 IF (IOPT(I) .LT. 0 .OR. IOPT(I) .GT. 1) GO TO 607 - ISOPT = IOPT(2) - IDF = IOPT(3) - NYH = N - NSV = 1 - METH = MF/10 - MITER = MF - 10*METH - IF (METH .LT. 1 .OR. METH .GT. 2) GO TO 608 - IF (MITER .LT. 0 .OR. MITER .GT. 5) GO TO 608 - IF (MITER .LE. 3) GO TO 30 - ML = IWORK(1) - MU = IWORK(2) - IF (ML .LT. 0 .OR. ML .GE. N) GO TO 609 - IF (MU .LT. 0 .OR. MU .GE. N) GO TO 610 - 30 IF (ISOPT .EQ. 0) GO TO 32 -C CHECK LEGALITY OF THE NON-OPTIONAL INPUTS ISOPT, NPAR. -C COMPUTE NUMBER OF SOLUTION VECTORS AND TOTAL NUMBER OF EQUATIONS. - IF (NEQ(2) .LE. 0) GO TO 628 - IF (ISTATE .EQ. 1) GO TO 31 - IF (NEQ(2) .NE. NPAR) GO TO 629 - 31 NPAR = NEQ(2) - NSV = NPAR + 1 - NYH = NSV * N - IF (MITER .EQ. 0 .OR. MITER .EQ. 3) GO TO 630 -C NEXT PROCESS AND CHECK THE OPTIONAL INPUTS. -------------------------- - 32 IF (IOPT(1) .EQ. 1) GO TO 40 - MAXORD = MORD(METH) - MXSTEP = MXSTP0 - MXHNIL = MXHNL0 - IF (ISTATE .EQ. 1) H0 = ZERO - HMXI = ZERO - HMIN = ZERO - GO TO 60 - 40 MAXORD = IWORK(5) - IF (MAXORD .LT. 0) GO TO 611 - IF (MAXORD .EQ. 0) MAXORD = 100 - MAXORD = MIN(MAXORD,MORD(METH)) - MXSTEP = IWORK(6) - IF (MXSTEP .LT. 0) GO TO 612 - IF (MXSTEP .EQ. 0) MXSTEP = MXSTP0 - MXHNIL = IWORK(7) - IF (MXHNIL .LT. 0) GO TO 613 - IF (MXHNIL .EQ. 0) MXHNIL = MXHNL0 - IF (ISTATE .NE. 1) GO TO 50 - H0 = RWORK(5) - IF ((TOUT - T)*H0 .LT. ZERO) GO TO 614 - 50 HMAX = RWORK(6) - IF (HMAX .LT. ZERO) GO TO 615 - HMXI = ZERO - IF (HMAX .GT. ZERO) HMXI = ONE/HMAX - HMIN = RWORK(7) - IF (HMIN .LT. ZERO) GO TO 616 -C----------------------------------------------------------------------- -C SET WORK ARRAY POINTERS AND CHECK LENGTHS LRW AND LIW. -C POINTERS TO SEGMENTS OF RWORK AND IWORK ARE NAMED BY PREFIXING L TO -C THE NAME OF THE SEGMENT. E.G., THE SEGMENT YH STARTS AT RWORK(LYH). -C SEGMENTS OF RWORK (IN ORDER) ARE DENOTED YH, WM, EWT, SAVF, ACOR. -C WORK SPACE FOR DFDP IS CONTAINED IN ACOR. -C----------------------------------------------------------------------- - 60 LYH = 21 - LWM = LYH + (MAXORD + 1)*NYH - IF (MITER .EQ. 0) LENWM = 0 - IF (MITER .EQ. 1 .OR. MITER .EQ. 2) LENWM = N*N + 2 - IF (MITER .EQ. 3) LENWM = N + 2 - IF (MITER .GE. 4) LENWM = (2*ML + MU + 1)*N + 2 - LEWT = LWM + LENWM - LSAVF = LEWT + NYH - LACOR = LSAVF + N - LDFDP = LACOR + N - LENRW = LACOR + NYH - 1 - IWORK(17) = LENRW - LIWM = 1 - LENIW = 20 + N - IF (MITER .EQ. 0 .OR. MITER .EQ. 3) LENIW = 20 - LNRS = LENIW + LIWM - IF (ISOPT .EQ. 1) LENIW = LNRS + NPAR - IWORK(18) = LENIW - IF (LENRW .GT. LRW) GO TO 617 - IF (LENIW .GT. LIW) GO TO 618 -C CHECK RTOL AND ATOL FOR LEGALITY. ------------------------------------ - RTOLI = RTOL(1) - ATOLI = ATOL(1) - DO 70 I = 1,NYH - IF (ITOL .GE. 3) RTOLI = RTOL(I) - IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) - IF (RTOLI .LT. ZERO) GO TO 619 - IF (ATOLI .LT. ZERO) GO TO 620 - 70 CONTINUE - IF (ISTATE .EQ. 1) GO TO 100 -C IF ISTATE = 3, SET FLAG TO SIGNAL PARAMETER CHANGES TO STODE. -------- - JSTART = -1 - IF (NQ .LE. MAXORD) GO TO 90 -C MAXORD WAS REDUCED BELOW NQ. COPY YH(*,MAXORD+2) INTO SAVF. --------- - DO 80 I = 1,N - 80 RWORK(I+LSAVF-1) = RWORK(I+LWM-1) -C RELOAD WM(1) = RWORK(LWM), SINCE LWM MAY HAVE CHANGED. --------------- - 90 IF (MITER .GT. 0) RWORK(LWM) = SQRT(UROUND) - GO TO 200 -C----------------------------------------------------------------------- -C BLOCK C. -C THE NEXT BLOCK IS FOR THE INITIAL CALL ONLY (ISTATE = 1). -C IT CONTAINS ALL REMAINING INITIALIZATIONS, THE INITIAL CALL TO F, -C THE INITIAL CALL TO SPRIME IF ISOPT = 1, -C AND THE CALCULATION OF THE INITIAL STEP SIZE. -C THE ERROR WEIGHTS IN EWT ARE INVERTED AFTER BEING LOADED. -C----------------------------------------------------------------------- - 100 UROUND = D1MACH(4) - TN = T - IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 105 - TCRIT = RWORK(1) - IF ((TCRIT - TOUT)*(TOUT - T) .LT. ZERO) GO TO 625 - IF (H0 .NE. ZERO .AND. (T + H0 - TCRIT)*H0 .GT. ZERO) - 1 H0 = TCRIT - T - 105 JSTART = 0 - IF (MITER .GT. 0) RWORK(LWM) = SQRT(UROUND) - NHNIL = 0 - NST = 0 - NJE = 0 - NSLAST = 0 - HU = ZERO - NQU = 0 - CCMAX = 0.3D0 - MAXCOR = 3 - IF (ISOPT .EQ. 1) MAXCOR = 4 - MSBP = 20 - MXNCF = 10 -C INITIAL CALL TO F. (LF0 POINTS TO YH(1,2) AND LOADS IN VALUES). - LF0 = LYH + NYH - CALL F (NEQ, T, Y, PAR, RWORK(LF0)) - NFE = 1 - DUPS = ZERO - DSMS = ZERO - DDNS = ZERO - NDFE = 0 - NSPE = 0 - IF (ISOPT .EQ. 0) GO TO 114 -C INITIALIZE COUNTS FOR REPEATED STEPS DUE TO SENSITIVITY ANALYSIS. - DO 110 J = 1,NSV - 110 IWORK(J + LNRS - 1) = 0 -C LOAD THE INITIAL VALUE VECTOR IN YH. --------------------------------- - 114 DO 115 I = 1,NYH - 115 RWORK(I+LYH-1) = Y(I) -C LOAD AND INVERT THE EWT ARRAY. (H IS TEMPORARILY SET TO ONE.) ------- - NQ = 1 - H = ONE - CALL EWSET (NYH, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) - DO 120 I = 1,NYH - IF (RWORK(I+LEWT-1) .LE. ZERO) GO TO 621 - 120 RWORK(I+LEWT-1) = ONE/RWORK(I+LEWT-1) - IF (ISOPT .EQ. 0) GO TO 125 -C CALL SPRIME TO LOAD FIRST-ORDER SENSITIVITY DERIVATIVES INTO -C REMAINING YH(*,2) POSITIONS. - CALL SPRIME (NEQ, Y, RWORK(LYH), NYH, N, NSV, RWORK(LWM), - 1 IWORK(LIWM), RWORK(LEWT), RWORK(LF0), RWORK(LACOR), - 2 RWORK(LDFDP), PAR, F, JAC, DF, PREPJ, PREPDF) - IF (IERSP .EQ. -1) GO TO 631 - IF (IERSP .EQ. -2) GO TO 632 -C----------------------------------------------------------------------- -C THE CODING BELOW COMPUTES THE STEP SIZE, H0, TO BE ATTEMPTED ON THE -C FIRST STEP, UNLESS THE USER HAS SUPPLIED A VALUE FOR THIS. -C FIRST CHECK THAT TOUT - T DIFFERS SIGNIFICANTLY FROM ZERO. -C A SCALAR TOLERANCE QUANTITY TOL IS COMPUTED, AS MAX(RTOL(I)) -C IF THIS IS POSITIVE, OR MAX(ATOL(I)/ABS(Y(I))) OTHERWISE, ADJUSTED -C SO AS TO BE BETWEEN 100*UROUND AND 1.0E-3. ONLY THE ORIGINAL -C SOLUTION VECTOR IS CONSIDERED IN THIS CALCULATION (ISOPT = 0 OR 1). -C THEN THE COMPUTED VALUE H0 IS GIVEN BY.. -C NEQ -C H0**2 = TOL / ( W0**-2 + (1/NEQ) * SUM ( F(I)/YWT(I) )**2 ) -C 1 -C WHERE W0 = MAX ( ABS(T), ABS(TOUT) ), -C F(I) = I-TH COMPONENT OF INITIAL VALUE OF F, -C YWT(I) = EWT(I)/TOL (A WEIGHT FOR Y(I)). -C THE SIGN OF H0 IS INFERRED FROM THE INITIAL VALUES OF TOUT AND T. -C----------------------------------------------------------------------- - 125 IF (H0 .NE. ZERO) GO TO 180 - TDIST = ABS(TOUT - T) - W0 = MAX(ABS(T),ABS(TOUT)) - IF (TDIST .LT. TWO*UROUND*W0) GO TO 622 - TOL = RTOL(1) - IF (ITOL .LE. 2) GO TO 140 - DO 130 I = 1,N - 130 TOL = MAX(TOL,RTOL(I)) - 140 IF (TOL .GT. ZERO) GO TO 160 - ATOLI = ATOL(1) - DO 150 I = 1,N - IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) - AYI = ABS(Y(I)) - IF (AYI .NE. ZERO) TOL = MAX(TOL,ATOLI/AYI) - 150 CONTINUE - 160 TOL = MAX(TOL,100.0D0*UROUND) - TOL = MIN(TOL,0.001D0) - SUM = VNORM (N, RWORK(LF0), RWORK(LEWT)) - SUM = ONE/(TOL*W0*W0) + TOL*SUM**2 - H0 = ONE/SQRT(SUM) - H0 = MIN(H0,TDIST) - H0 = SIGN(H0,TOUT-T) -C ADJUST H0 IF NECESSARY TO MEET HMAX BOUND. --------------------------- - 180 RH = ABS(H0)*HMXI - IF (RH .GT. ONE) H0 = H0/RH -C LOAD H WITH H0 AND SCALE YH(*,2) BY H0. ------------------------------ - H = H0 - DO 190 I = 1,NYH - 190 RWORK(I+LF0-1) = H0*RWORK(I+LF0-1) - GO TO 270 -C----------------------------------------------------------------------- -C BLOCK D. -C THE NEXT CODE BLOCK IS FOR CONTINUATION CALLS ONLY (ISTATE = 2 OR 3) -C AND IS TO CHECK STOP CONDITIONS BEFORE TAKING A STEP. -C----------------------------------------------------------------------- - 200 NSLAST = NST - GO TO (210, 250, 220, 230, 240), ITASK - 210 IF ((TN - TOUT)*H .LT. ZERO) GO TO 250 - CALL INTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) - IF (IFLAG .NE. 0) GO TO 627 - T = TOUT - GO TO 420 - 220 TP = TN - HU*(ONE + 100.0D0*UROUND) - IF ((TP - TOUT)*H .GT. ZERO) GO TO 623 - IF ((TN - TOUT)*H .LT. ZERO) GO TO 250 - GO TO 400 - 230 TCRIT = RWORK(1) - IF ((TN - TCRIT)*H .GT. ZERO) GO TO 624 - IF ((TCRIT - TOUT)*H .LT. ZERO) GO TO 625 - IF ((TN - TOUT)*H .LT. ZERO) GO TO 245 - CALL INTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) - IF (IFLAG .NE. 0) GO TO 627 - T = TOUT - GO TO 420 - 240 TCRIT = RWORK(1) - IF ((TN - TCRIT)*H .GT. ZERO) GO TO 624 - 245 HMX = ABS(TN) + ABS(H) - IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX - IF (IHIT) GO TO 400 - TNEXT = TN + H*(ONE + FOUR*UROUND) - IF ((TNEXT - TCRIT)*H .LE. ZERO) GO TO 250 - H = (TCRIT - TN)*(ONE - FOUR*UROUND) - IF (ISTATE .EQ. 2) JSTART = -2 -C----------------------------------------------------------------------- -C BLOCK E. -C THE NEXT BLOCK IS NORMALLY EXECUTED FOR ALL CALLS AND CONTAINS -C THE CALL TO THE ONE-STEP CORE INTEGRATOR STODE. -C -C THIS IS A LOOPING POINT FOR THE INTEGRATION STEPS. -C -C FIRST CHECK FOR TOO MANY STEPS BEING TAKEN, UPDATE EWT (IF NOT AT -C START OF PROBLEM), CHECK FOR TOO MUCH ACCURACY BEING REQUESTED, AND -C CHECK FOR H BELOW THE ROUNDOFF LEVEL IN T. -C TOLSF IS CALCULATED CONSIDERING ALL SOLUTION VECTORS. -C----------------------------------------------------------------------- - 250 CONTINUE - IF ((NST-NSLAST) .GE. MXSTEP) GO TO 500 - CALL EWSET (NYH, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) - DO 260 I = 1,NYH - IF (RWORK(I+LEWT-1) .LE. ZERO) GO TO 510 - 260 RWORK(I+LEWT-1) = ONE/RWORK(I+LEWT-1) - 270 TOLSF = UROUND*VNORM (NYH, RWORK(LYH), RWORK(LEWT)) - IF (TOLSF .LE. ONE) GO TO 280 - TOLSF = TOLSF*2.0D0 - IF (NST .EQ. 0) GO TO 626 - GO TO 520 - 280 IF (ADDX(TN,H) .NE. TN) GO TO 290 - NHNIL = NHNIL + 1 - IF (NHNIL .GT. MXHNIL) GO TO 290 - CALL XERR ('ODESSA - WARNING..INTERNAL T (=R1) AND H (=R2) ARE', - 1 101, 1, 0, 0, 0, 0, ZERO, ZERO) - CALL XERR ('SUCH THAT IN THE MACHINE, T + H = T ON THE NEXT STEP', - 1 101, 1, 0, 0, 0, 0, ZERO, ZERO) - CALL XERR ('(H = STEP SIZE). KppSolveR WILL CONTINUE ANYWAY', - 1 101, 1, 0, 0, 0, 2, TN, H) - IF (NHNIL .LT. MXHNIL) GO TO 290 - CALL XERR ('ODESSA - ABOVE WARNING HAS BEEN ISSUED I1 TIMES.', - 1 102, 1, 0, 0, 0, 0, ZERO, ZERO) - CALL XERR ('IT WILL NOT BE ISSUED AGAIN FOR THIS PROBLEM', - 1 102, 1, 1, MXHNIL, 0, 0, ZERO,ZERO) - 290 CONTINUE -C----------------------------------------------------------------------- -C CALL STODE(NEQ,Y,YH,NYH,YH,WM,IWM,EWT,SAVF,ACOR,PAR,NRS, -C 1 F,JAC,DF,PREPJ,PREPDF,SOLSY) -C----------------------------------------------------------------------- - CALL STODE (NEQ, Y, RWORK(LYH), NYH, RWORK(LYH), RWORK(LWM), - 1 IWORK(LIWM), RWORK(LEWT), RWORK(LSAVF), RWORK(LACOR), - 2 PAR, IWORK(LNRS), F, JAC, DF, PREPJ, PREPDF, SOLSY) - KGO = 1 - KFLAG - GO TO (300, 530, 540, 633), KGO -C----------------------------------------------------------------------- -C BLOCK F. -C THE FOLLOWING BLOCK HANDLES THE CASE OF A SUCCESSFUL RETURN FROM THE -C CORE INTEGRATOR (KFLAG = 0). TEST FOR STOP CONDITIONS. -C----------------------------------------------------------------------- - 300 INIT = 1 - GO TO (310, 400, 330, 340, 350), ITASK -C ITASK = 1. IF TOUT HAS BEEN REACHED, INTERPOLATE. ------------------- - 310 IF ((TN - TOUT)*H .LT. ZERO) GO TO 250 - CALL INTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) - T = TOUT - GO TO 420 -C ITASK = 3. JUMP TO EXIT IF TOUT WAS REACHED. ------------------------ - 330 IF ((TN - TOUT)*H .GE. ZERO) GO TO 400 - GO TO 250 -C ITASK = 4. SEE IF TOUT OR TCRIT WAS REACHED. ADJUST H IF NECESSARY. - 340 IF ((TN - TOUT)*H .LT. ZERO) GO TO 345 - CALL INTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) - T = TOUT - GO TO 420 - 345 HMX = ABS(TN) + ABS(H) - IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX - IF (IHIT) GO TO 400 - TNEXT = TN + H*(ONE + FOUR*UROUND) - IF ((TNEXT - TCRIT)*H .LE. ZERO) GO TO 250 - H = (TCRIT - TN)*(ONE - FOUR*UROUND) - JSTART = -2 - GO TO 250 -C ITASK = 5. SEE IF TCRIT WAS REACHED AND JUMP TO EXIT. --------------- - 350 HMX = ABS(TN) + ABS(H) - IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX -C----------------------------------------------------------------------- -C BLOCK G. -C THE FOLLOWING BLOCK HANDLES ALL SUCCESSFUL RETURNS FROM ODESSA. -C IF ITASK .NE. 1, Y IS LOADED FROM YH AND T IS SET ACCORDINGLY. -C ISTATE IS SET TO 2, THE ILLEGAL INPUT COUNTER IS ZEROED, AND THE -C OPTIONAL OUTPUTS ARE LOADED INTO THE WORK ARRAYS BEFORE RETURNING. -C IF ISTATE = 1 AND TOUT = T, THERE IS A RETURN WITH NO ACTION TAKEN, -C EXCEPT THAT IF THIS HAS HAPPENED REPEATEDLY, THE RUN IS TERMINATED. -C----------------------------------------------------------------------- - 400 DO 410 I = 1,NYH - 410 Y(I) = RWORK(I+LYH-1) - T = TN - IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 420 - IF (IHIT) T = TCRIT - 420 ISTATE = 2 - ILLIN = 0 - RWORK(11) = HU - RWORK(12) = H - RWORK(13) = TN - IWORK(11) = NST - IWORK(12) = NFE - IWORK(13) = NJE - IWORK(14) = NQU - IWORK(15) = NQ - IF (ISOPT .EQ. 0) RETURN - IWORK(19) = NDFE - IWORK(20) = NSPE - RETURN - 430 NTREP = NTREP + 1 - IF (NTREP .LT. 5) RETURN - CALL XERR ('ODESSA -- REPEATED CALLS WITH ISTATE = 1 AND - 1TOUT = T (=R1)', 301, 1, 0, 0, 0, 1, T, ZERO) - GO TO 800 -C----------------------------------------------------------------------- -C BLOCK H. -C THE FOLLOWING BLOCK HANDLES ALL UNSUCCESSFUL RETURNS OTHER THAN -C THOSE FOR ILLEGAL INPUT. FIRST THE ERROR MESSAGE ROUTINE IS CALLED. -C IF THERE WAS AN ERROR TEST OR CONVERGENCE TEST FAILURE, IMXER IS SET. -C THEN Y IS LOADED FROM YH, T IS SET TO TN, AND THE ILLEGAL INPUT -C COUNTER ILLIN IS SET TO 0. THE OPTIONAL OUTPUTS ARE LOADED INTO -C THE WORK ARRAYS BEFORE RETURNING. -C----------------------------------------------------------------------- -C THE MAXIMUM NUMBER OF STEPS WAS TAKEN BEFORE REACHING TOUT. ---------- - 500 CALL XERR ('ODESSA - AT CURRENT T (=R1), MXSTEP (=I1) STEPS', - 1 201, 1, 0, 0, 0, 0, ZERO,ZERO) - CALL XERR ('TAKEN ON THIS CALL BEFORE REACHING TOUT', - 1 201, 1, 1, MXSTEP, 0, 1, TN, ZERO) - ISTATE = -1 - GO TO 580 -C EWT(I) .LE. 0.0 FOR SOME I (NOT AT START OF PROBLEM). ---------------- - 510 EWTI = RWORK(LEWT+I-1) - CALL XERR ('ODESSA - AT T (=R1), EWT(I1) HAS BECOME R2 .LE. 0.', - 1 202, 1, 1, I, 0, 2, TN, EWTI) - ISTATE = -6 - GO TO 580 -C TOO MUCH ACCURACY REQUESTED FOR MACHINE PRECISION. ------------------- - 520 CALL XERR ('ODESSA - AT T (=R1), TOO MUCH ACCURACY REQUESTED', - 1 203, 1, 0, 0, 0, 0, ZERO,ZERO) - CALL XERR ('FOR PRECISION OF MACHINE.. SEE TOLSF (=R2)', - 1 203, 1, 0, 0, 0, 2, TN, TOLSF) - RWORK(14) = TOLSF - ISTATE = -2 - GO TO 580 -C KFLAG = -1. ERROR TEST FAILED REPEATEDLY OR WITH ABS(H) = HMIN. ----- - 530 CALL XERR ('ODESSA - AT T(=R1) AND STEP SIZE H(=R2), THE ERROR', - 1 204, 1, 0, 0, 0, 0, ZERO, ZERO) - CALL XERR ('TEST FAILED REPEATEDLY OR WITH ABS(H) = HMIN', - 1 204, 1, 0, 0, 0, 2, TN, H) - ISTATE = -4 - GO TO 560 -C KFLAG = -2. CONVERGENCE FAILED REPEATEDLY OR WITH ABS(H) = HMIN. ---- - 540 CALL XERR ('ODESSA - AT T (=R1) AND STEP SIZE H (=R2), THE', - 1 205, 1, 0, 0, 0, 0, ZERO,ZERO) - CALL XERR ('CORRECTOR CONVERGENCE FAILED REPEATEDLY', - 1 205, 1, 0, 0, 0, 0, ZERO,ZERO) - CALL XERR ('OR WITH ABS(H) = HMIN', - 1 205, 1, 0, 0, 0, 2, TN, H) - ISTATE = -5 -C COMPUTE IMXER IF RELEVANT. ------------------------------------------- - 560 BIG = ZERO - IMXER = 1 - DO 570 I = 1,NYH - SIZE = ABS(RWORK(I+LACOR-1)*RWORK(I+LEWT-1)) - IF (BIG .GE. SIZE) GO TO 570 - BIG = SIZE - IMXER = I - 570 CONTINUE - IWORK(16) = IMXER -C SET Y VECTOR, T, ILLIN, AND OPTIONAL OUTPUTS. ------------------------ - 580 DO 590 I = 1,NYH - 590 Y(I) = RWORK(I+LYH-1) - T = TN - ILLIN = 0 - RWORK(11) = HU - RWORK(12) = H - RWORK(13) = TN - IWORK(11) = NST - IWORK(12) = NFE - IWORK(13) = NJE - IWORK(14) = NQU - IWORK(15) = NQ - IF (ISOPT .EQ. 0) RETURN - IWORK(19) = NDFE - IWORK(20) = NSPE - RETURN -C----------------------------------------------------------------------- -C BLOCK I. -C THE FOLLOWING BLOCK HANDLES ALL ERROR RETURNS DUE TO ILLEGAL INPUT -C (ISTATE = -3), AS DETECTED BEFORE CALLING THE CORE INTEGRATOR. -C FIRST THE ERROR MESSAGE ROUTINE IS CALLED. THEN IF THERE HAVE BEEN -C 5 CONSECUTIVE SUCH RETURNS JUST BEFORE THIS CALL TO THE KppSolveR, -C THE RUN IS HALTED. -C----------------------------------------------------------------------- - 601 CALL XERR ('ODESSA - ISTATE (=I1) ILLEGAL', - 1 1, 1, 1, ISTATE, 0, 0, ZERO,ZERO) - GO TO 700 - 602 CALL XERR ('ODESSA - ITASK (=I1) ILLEGAL', - 1 2, 1, 1, ITASK, 0, 0, ZERO,ZERO) - GO TO 700 - 603 CALL XERR ('ODESSA - ISTATE .GT. 1 BUT ODESSA NOT INITIALIZED', - 1 3, 1, 0, 0, 0, 0, ZERO,ZERO) - GO TO 700 - 604 CALL XERR ('ODESSA - NEQ (=I1) .LT. 1', - 1 4, 1, 1, NEQ(1), 0, 0, ZERO,ZERO) - GO TO 700 - 605 CALL XERR ('ODESSA - ISTATE = 3 AND NEQ CHANGED. (I1 TO I2)', - 1 5, 1, 2, N, NEQ(1), 0, ZERO,ZERO) - GO TO 700 - 606 CALL XERR ('ODESSA - ITOL (=I1) ILLEGAL', - 1 6, 1, 1, ITOL, 0, 0, ZERO,ZERO) - GO TO 700 - 607 CALL XERR ('ODESSA - IOPT (=I1) ILLEGAL', - 1 7, 1, 1, IOPT, 0, 0, ZERO,ZERO) - GO TO 700 - 608 CALL XERR('ODESSA - MF (=I1) ILLEGAL', - 1 8, 1, 1, MF, 0, 0, ZERO,ZERO) - GO TO 700 - 609 CALL XERR('ODESSA - ML (=I1) ILLEGAL.. .LT.0 OR .GE.NEQ (=I2)', - 1 9, 1, 2, ML, NEQ(1), 0, ZERO,ZERO) - GO TO 700 - 610 CALL XERR('ODESSA - MU (=I1) ILLEGAL.. .LT.0 OR .GE.NEQ (=I2)', - 1 10, 1, 2, MU, NEQ(1), 0, ZERO,ZERO) - GO TO 700 - 611 CALL XERR('ODESSA - MAXORD (=I1) .LT. 0', - 1 11, 1, 1, MAXORD, 0, 0, ZERO,ZERO) - GO TO 700 - 612 CALL XERR('ODESSA - MXSTEP (=I1) .LT. 0', - 1 12, 1, 1, MXSTEP, 0, 0, ZERO,ZERO) - GO TO 700 - 613 CALL XERR('ODESSA - MXHNIL (=I1) .LT. 0', - 1 13, 1, 1, MXHNIL, 0, 0, ZERO,ZERO) - GO TO 700 - 614 CALL XERR('ODESSA - TOUT (=R1) BEHIND T (=R2)', - 1 14, 1, 0, 0, 0, 2, TOUT, T) - CALL XERR('INTEGRATION DIRECTION IS GIVEN BY H0 (=R1)', - 1 14, 1, 0, 0, 0, 1, H0, ZERO) - GO TO 700 - 615 CALL XERR('ODESSA - HMAX (=R1) .LT. 0.0', - 1 15, 1, 0, 0, 0, 1, HMAX, ZERO) - GO TO 700 - 616 CALL XERR('ODESSA - HMIN (=R1) .LT. 0.0', - 1 16, 1, 0, 0, 0, 1, HMIN, ZERO) - GO TO 700 - 617 CALL XERR('ODESSA - RWORK LENGTH NEEDED, LENRW (=I1), EXCEEDS - 1 LRW (=I2)', 17, 1, 2, LENRW, LRW, 0, ZERO,ZERO) - GO TO 700 - 618 CALL XERR('ODESSA - IWORK LENGTH NEEDED, LENIW (=I1), EXCEEDS - 1 LIW (=I2)', 18, 1, 2, LENIW, LIW, 0, ZERO,ZERO) - GO TO 700 - 619 CALL XERR('ODESSA - RTOL(I1) IS R1 .LT. 0.0', - 1 19, 1, 1, I, 0, 1, RTOLI, ZREO) - GO TO 700 - 620 CALL XERR('ODESSA - ATOL(I1) IS R1 .LT. 0.0', - 1 20, 1, 1, I, 0, 1, ATOLI, ZERO) - GO TO 700 -* - 621 EWTI = RWORK(LEWT+I-1) - CALL XERR('ODESSA - EWT(I1) IS R1 .LE. 0.0', - 1 21, 1, 1, I, 0, 1, EWTI, ZERO) - GO TO 700 - 622 CALL XERR('ODESSA - TOUT (=R1) TOO CLOSE TO T(=R2) TO START - 1 INTEGRATION', 22, 1, 0, 0, 0, 2, TOUT, T) - GO TO 700 - 623 CALL XERR('ODESSA - ITASK = I1 AND TOUT (=R1) BEHIND TCUR - HU - 1 (= R2)', 23, 1, 1, ITASK, 0, 2, TOUT, TP) - GO TO 700 - 624 CALL XERR('ODESSA - ITASK = 4 OR 5 AND TCRIT (=R1) BEHIND TCUR - 1 (=R2)', 24, 1, 0, 0, 0, 2, TCRIT, TN) - GO TO 700 - 625 CALL XERR('ODESSA - ITASK = 4 OR 5 AND TCRIT (=R1) BEHIND TOUT - 1 (=R2)', 25, 1, 0, 0, 0, 2, TCRIT, TOUT) - GO TO 700 - 626 CALL XERR('ODESSA - AT START OF PROBLEM, TOO MUCH ACCURACY', - 1 26, 1, 0, 0, 0, 0, ZERO,ZERO) - CALL XERR('REQUESTED FOR PRECISION OF MACHINE. SEE TOLSF (=R1)', - 1 26, 1, 0, 0, 0, 1, TOLSF, ZERO) - RWORK(14) = TOLSF - GO TO 700 - 627 CALL XERR('ODESSA - TROUBLE FROM INTDY. ITASK = I1, TOUT = R1', - 1 27, 1, 1, ITASK, 0, 1, TOUT, ZERO) - GO TO 700 -C ERROR STATEMENTS ASSOCIATED WITH SENSITIVITY ANALYSIS. - 628 CALL XERR('ODESSA - NPAR (=I1) .LT. 1', - 1 28, 1, 1, NPAR, 0, 0, ZERO,ZERO) - GO TO 700 - 629 CALL XERR('ODESSA - ISTATE = 3 AND NPAR CHANGED (I1 TO I2)', - 1 29, 1, 2, NP, NPAR, 0, ZERO,ZERO) - GO TO 700 - 630 CALL XERR('ODESSA - MITER (=I1) ILLEGAL', - 1 30, 1, 1, MITER, 0, 0, ZERO,ZERO) - GO TO 700 - 631 CALL XERR('ODESSA - TROUBLE IN SPRIME (IERPJ)', - 1 31, 1, 0, 0, 0, 0, ZERO,ZERO) - GO TO 700 - 632 CALL XERR('ODESSA - TROUBLE IN SPRIME (MITER)', - 1 32, 1, 0, 0, 0, 0, ZERO,ZERO) - GO TO 700 - 633 CALL XERR('ODESSA - FATAL ERROR IN STODE (KFLAG = -3)', - 1 33, 2, 0, 0, 0, 0, ZERO,ZERO) - GO TO 801 -C - 700 IF (ILLIN .EQ. 5) GO TO 710 - ILLIN = ILLIN + 1 - ISTATE = -3 - RETURN - 710 CALL XERR('ODESSA - REPEATED OCCURRENCES OF ILLEGAL INPUT', - 1 302, 1, 0, 0, 0, 0, ZERO,ZERO) -C - 800 CALL XERR('ODESSA - RUN ABORTED.. APPARENT INFINITE LOOP', - 1 303, 2, 0, 0, 0, 0, ZERO,ZERO) - RETURN - 801 CALL XERR('ODESSA - RUN ABORTED', - 1 304, 2, 0, 0, 0, 0, ZERO,ZERO) - RETURN -C-------------------- END OF SUBROUTINE ODESSA ------------------------- - END - DOUBLE PRECISION FUNCTION ADDX(A,B) - DOUBLE PRECISION A,B -C -C THIS FUNCTION IS NECESSARY TO FORCE OPTIMIZING COMPILERS TO -C EXECUTE AND STORE A SUM, FOR SUCCESSFUL EXECUTION OF THE -C TEST A + B = B. -C - ADDX = A + B - RETURN -C-------------------- END OF FUNCTION SUM ------------------------------ - END - SUBROUTINE SPRIME (NEQ, Y, YH, NYH, NROW, NCOL, WM, IWM, - 1 EWT, SAVF, FTEM, DFDP, PAR, F, JAC, DF, PJAC, PDF) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - DIMENSION NEQ(*), Y(*), YH(NROW,NCOL,*), WM(*), IWM(*), - 1 EWT(*), SAVF(*), FTEM(*), DFDP(NROW,*), PAR(*) - EXTERNAL F, JAC, DF, PJAC, PDF - PARAMETER (ONE=1.0D0,ZERO=0.0D0) - COMMON /ODE001/ ROWND, ROWNS(173), - 1 RDUM1(37),EL0, H, RDUM2(6), - 2 IOWND1(14), IOWNS(4), - 3 IDUM1(3), IERPJ, IDUM2(6), - 4 MITER, IDUM3(4), N, IDUM4(5) - COMMON /ODE002/ RDUM3(3), - 1 IOWND2(3), IDUM5, NSV, IDUM6, NSPE, IDUM7, IERSP, JOPT, IDUM8 -C----------------------------------------------------------------------- -C SPRIME IS CALLED BY ODESSA TO INITIALIZE THE YH ARRAY. IT IS ALSO -C CALLED BY STODE TO REEVALUATE FIRST ORDER DERIVATIVES WHEN KFLAG -C .LE. -3. SPRIME COMPUTES THE FIRST DERIVATIVES OF THE SENSITIVITY -C COEFFICIENTS WITH RESPECT TO THE INDEPENDENT VARIABLE T... -C -C SPRIME = D(DY/DP)/DT = JAC*DY/DP + DF/DP -C WHERE JAC = JACOBIAN MATRIX -C DY/DP = SENSITIVITY MATRIX -C DF/DP = INHOMOGENEITY MATRIX -C THIS ROUTINE USES THE COMMON VARIABLES EL0, H, IERPJ, MITER, N, -C NSV, NSPE, IERSP, JOPT -C----------------------------------------------------------------------- -C CALL PREPJ WITH JOPT = 1. -C IF MITER = 2 OR 5, EL0 IS TEMPORARILY SET TO -1.0 AND H IS -C TEMPORARILY SET TO 1.0D0. -C----------------------------------------------------------------------- - NSPE = NSPE + 1 - JOPT = 1 - IF (MITER .EQ. 1 .OR. MITER .EQ. 4) GO TO 10 - HTEMP = H - ETEMP = EL0 - H = ONE - EL0 = -ONE - 10 CALL PJAC (NEQ, Y, YH, NYH, WM, IWM, EWT, SAVF, FTEM, - 1 PAR, F, JAC, JOPT) - IF (IERPJ .NE. 0) GO TO 300 - JOPT = 0 - IF (MITER .EQ. 1 .OR. MITER .EQ. 4) GO TO 20 - H = HTEMP - EL0 = ETEMP -C----------------------------------------------------------------------- -C CALL PREPDF AND LOAD DFDP(*,JPAR). -C----------------------------------------------------------------------- - 20 DO 30 J = 2,NSV - JPAR = J - 1 - CALL PDF (NEQ, Y, WM, SAVF, FTEM, DFDP(1,JPAR), PAR, - 1 F, DF, JPAR) - 30 CONTINUE -C----------------------------------------------------------------------- -C COMPUTE JAC*DY/DP AND STORE RESULTS IN YH(*,*,2). -C----------------------------------------------------------------------- - GO TO (40,40,310,100,100) MITER -C THE JACOBIAN IS FULL.------------------------------------------------ -C FOR EACH ROW OF THE JACOBIAN.. - 40 DO 70 IROW = 1,N -C AND EACH COLUMN OF THE SENSITIVITY MATRIX.. - DO 60 J = 2,NSV - SUM = ZERO -C TAKE THE VECTOR DOT PRODUCT.. - DO 50 I = 1,N - IPD = IROW + N*(I-1) + 2 - SUM = SUM + WM(IPD)*YH(I,J,1) - 50 CONTINUE - YH(IROW,J,2) = SUM - 60 CONTINUE - 70 CONTINUE - GO TO 200 -C THE JACOBIAN IS BANDED.----------------------------------------------- - 100 ML = IWM(1) - MU = IWM(2) - ICOUNT = 1 - MBAND = ML + MU + 1 - MEBAND = MBAND + ML - NMU = N - MU - ML1 = ML + 1 -C FOR EACH ROW OF THE JACOBIAN.. - DO 160 IROW = 1,N - IF (IROW .GT. ML1) GO TO 110 - IPD = MBAND + IROW + 1 - IYH = 1 - LBAND = MU + IROW - GO TO 120 - 110 ICOUNT = ICOUNT + 1 - IPD = ICOUNT*MEBAND + 2 - IYH = IYH + 1 - LBAND = LBAND - 1 - IF (IROW .LE. NMU) LBAND = MBAND -C AND EACH COLUMN OF THE SENSITIVITY MATRIX.. - 120 DO 150 J = 2,NSV - SUM = ZERO - I1 = IPD - I2 = IYH -C TAKE THE VECTOR DOT PRODUCT. - DO 140 I = 1,LBAND - SUM = SUM + WM(I1)*YH(I2,J,1) - I1 = I1 + MEBAND - 1 - I2 = I2 + 1 - 140 CONTINUE - YH(IROW,J,2) = SUM - 150 CONTINUE - 160 CONTINUE -C----------------------------------------------------------------------- -C ADD THE INHOMOGENEITY TERM, I.E., ADD DFDP(*,JPAR) TO YH(*,JPAR+1,2). -C----------------------------------------------------------------------- - 200 DO 220 J = 2,NSV - JPAR = J - 1 - DO 210 I = 1,N - YH(I,J,2) = YH(I,J,2) + DFDP(I,JPAR) - 210 CONTINUE - 220 CONTINUE - RETURN -C----------------------------------------------------------------------- -C ERROR RETURNS. -C----------------------------------------------------------------------- - 300 IERSP = -1 - RETURN - 310 IERSP = -2 - RETURN -C------------------------END OF SUBROUTINE SPRIME----------------------- - END - SUBROUTINE PREPJ (NEQ, Y, YH, NYH, WM, IWM, EWT, SAVF, FTEM, - 1 PAR, F, JAC, JOPT) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - DIMENSION NEQ(*), Y(*), YH(NYH,*), WM(*), IWM(*), EWT(*), - 1 SAVF(*), FTEM(*), PAR(*) - EXTERNAL F, JAC - PARAMETER (ZERO=0.0D0,ONE=1.0D0) - COMMON /ODE001/ ROWND, ROWNS(173), - 2 RDUM1(37), EL0, H, RDUM2(4), TN, UROUND, - 3 IOWND(14), IOWNS(4), - 4 IDUM1(3), IERPJ, IDUM2, JCUR, IDUM3(4), - 5 MITER, IDUM4(4), N, IDUM5(2), NFE, NJE, IDUM6 -C----------------------------------------------------------------------- -C PREPJ IS CALLED BY STODE TO COMPUTE AND PROCESS THE MATRIX -C P = I - H*EL(1)*J , WHERE J IS AN APPROXIMATION TO THE JACOBIAN. -C IF ISOPT = 1, PREPJ IS ALSO CALLED BY SPRIME WITH JOPT = 1. -C HERE J IS COMPUTED BY THE USER-SUPPLIED ROUTINE JAC IF -C MITER = 1 OR 4, OR BY FINITE DIFFERENCING IF MITER = 2, 3, OR 5. -C IF MITER = 3, A DIAGONAL APPROXIMATION TO J IS USED. -C J IS STORED IN WM AND REPLACED BY P. IF MITER .NE. 3, P IS THEN -C SUBJECTED TO LU DECOMPOSITION (JOPT = 0) IN PREPARATION FOR LATER -C SOLUTION OF LINEAR SYSTEMS WITH P AS COEFFICIENT MATRIX. THIS IS -C DONE BY DGEFA IF MITER = 1 OR 2, AND BY DGBFA IF MITER = 4 OR 5. -C -C IN ADDITION TO VARIABLES DESCRIBED PREVIOUSLY, COMMUNICATION -C WITH PREPJ USES THE FOLLOWING.. -C Y = ARRAY CONTAINING PREDICTED VALUES ON ENTRY. -C FTEM = WORK ARRAY OF LENGTH N (ACOR IN STODE). -C SAVF = ARRAY CONTAINING F EVALUATED AT PREDICTED Y. -C WM = REAL WORK SPACE FOR MATRICES. ON OUTPUT IT CONTAINS THE -C INVERSE DIAGONAL MATRIX IF MITER = 3 AND THE LU DECOMPOSITION -C OF P IF MITER IS 1, 2 , 4, OR 5. -C STORAGE OF MATRIX ELEMENTS STARTS AT WM(3). -C WM ALSO CONTAINS THE FOLLOWING MATRIX-RELATED DATA.. -C WM(1) = SQRT(UROUND), USED IN NUMERICAL JACOBIAN INCREMENTS. -C WM(2) = H*EL0, SAVED FOR LATER USE IF MITER = 3. -C IWM = INTEGER WORK SPACE CONTAINING PIVOT INFORMATION, STARTING AT -C IWM(21), IF MITER IS 1, 2, 4, OR 5. IWM ALSO CONTAINS BAND -C PARAMETERS ML = IWM(1) AND MU = IWM(2) IF MITER IS 4 OR 5. -C EL0 = EL(1) (INPUT). -C IERPJ = OUTPUT ERROR FLAG, = 0 IF NO TROUBLE, .GT. 0 IF -C P MATRIX FOUND TO BE SINGULAR. -C JCUR = OUTPUT FLAG = 1 TO INDICATE THAT THE JACOBIAN MATRIX -C (OR APPROXIMATION) IS NOW CURRENT. -C JOPT = INPUT JACOBIAN OPTION, = 1 IF JAC IS DESIRED ONLY. -C THIS ROUTINE ALSO USES THE COMMON VARIABLES EL0, H, TN, UROUND, -C IERPJ, JCUR, MITER, N, NFE, AND NJE. -C----------------------------------------------------------------------- - NJE = NJE + 1 - IERPJ = 0 - JCUR = 1 - HL0 = H*EL0 - GO TO (100, 200, 300, 400, 500), MITER -C IF MITER = 1, CALL JAC AND MULTIPLY BY SCALAR. ----------------------- - 100 LENP = N*N - DO 110 I = 1,LENP - 110 WM(I+2) = ZERO - CALL JAC (NEQ, TN, Y, PAR, 0, 0, WM(3), N) - IF (JOPT .EQ. 1) RETURN - CON = -HL0 - DO 120 I = 1,LENP - 120 WM(I+2) = WM(I+2)*CON - GO TO 240 -C IF MITER = 2, MAKE N CALLS TO F TO APPROXIMATE J. -------------------- - 200 FAC = VNORM (N, SAVF, EWT) - R0 = 1000.0D0*ABS(H)*UROUND*REAL(N)*FAC - IF (R0 .EQ. ZERO) R0 = ONE - SRUR = WM(1) - J1 = 2 - DO 230 J = 1,N - YJ = Y(J) - R = MAX(SRUR*ABS(YJ),R0/EWT(J)) - Y(J) = Y(J) + R - FAC = -HL0/R - CALL F (NEQ, TN, Y, PAR, FTEM) - DO 220 I = 1,N - 220 WM(I+J1) = (FTEM(I) - SAVF(I))*FAC - Y(J) = YJ - J1 = J1 + N - 230 CONTINUE - NFE = NFE + N - IF (JOPT .EQ. 1) RETURN -C ADD IDENTITY MATRIX. ------------------------------------------------- - 240 J = 3 - DO 250 I = 1,N - WM(J) = WM(J) + ONE - 250 J = J + (N + 1) -C DO LU DECOMPOSITION ON P. -------------------------------------------- - CALL DGEFA (WM(3), N, N, IWM(21), IER) - IF (IER .NE. 0) IERPJ = 1 - RETURN -C IF MITER = 3, CONSTRUCT A DIAGONAL APPROXIMATION TO J AND P. --------- - 300 WM(2) = HL0 - R = EL0*0.1D0 - DO 310 I = 1,N - 310 Y(I) = Y(I) + R*(H*SAVF(I) - YH(I,2)) - CALL F (NEQ, TN, Y, PAR, WM(3)) - NFE = NFE + 1 - DO 320 I = 1,N - R0 = H*SAVF(I) - YH(I,2) - DI = 0.1D0*R0 - H*(WM(I+2) - SAVF(I)) - WM(I+2) = 1.0D0 - IF (ABS(R0) .LT. UROUND/EWT(I)) GO TO 320 - IF (ABS(DI) .EQ. ZERO) GO TO 330 - WM(I+2) = 0.1D0*R0/DI - 320 CONTINUE - RETURN - 330 IERPJ = 1 - RETURN -C IF MITER = 4, CALL JAC AND MULTIPLY BY SCALAR. ----------------------- - 400 ML = IWM(1) - MU = IWM(2) - ML3 = ML + 3 - MBAND = ML + MU + 1 - MEBAND = MBAND + ML - LENP = MEBAND*N - DO 410 I = 1,LENP - 410 WM(I+2) = ZERO - CALL JAC (NEQ, TN, Y, PAR, ML, MU, WM(ML3), MEBAND) - IF (JOPT .EQ. 1) RETURN - CON = -HL0 - DO 420 I = 1,LENP - 420 WM(I+2) = WM(I+2)*CON - GO TO 570 -C IF MITER = 5, MAKE MBAND CALLS TO F TO APPROXIMATE J. ---------------- - 500 ML = IWM(1) - MU = IWM(2) - MBAND = ML + MU + 1 - MBA = MIN(MBAND,N) - MEBAND = MBAND + ML - MEB1 = MEBAND - 1 - SRUR = WM(1) - FAC = VNORM (N, SAVF, EWT) - R0 = 1000.0D0*ABS(H)*UROUND*REAL(N)*FAC - IF (R0 .EQ. ZERO) R0 = ONE - DO 560 J = 1,MBA - DO 530 I = J,N,MBAND - YI = Y(I) - R = MAX(SRUR*ABS(YI),R0/EWT(I)) - 530 Y(I) = Y(I) + R - CALL F (NEQ, TN, Y, PAR, FTEM) - DO 550 JJ = J,N,MBAND - Y(JJ) = YH(JJ,1) - YJJ = Y(JJ) - R = MAX(SRUR*ABS(YJJ),R0/EWT(JJ)) - FAC = -HL0/R - I1 = MAX(JJ-MU,1) - I2 = MIN(JJ+ML,N) - II = JJ*MEB1 - ML + 2 - DO 540 I = I1,I2 - 540 WM(II+I) = (FTEM(I) - SAVF(I))*FAC - 550 CONTINUE - 560 CONTINUE - NFE = NFE + MBA - IF (JOPT .EQ. 1) RETURN -C ADD IDENTITY MATRIX. ------------------------------------------------- - 570 II = MBAND + 2 - DO 580 I = 1,N - WM(II) = WM(II) + ONE - 580 II = II + MEBAND -C DO LU DECOMPOSITION OF P. -------------------------------------------- - CALL DGBFA (WM(3), MEBAND, N, ML, MU, IWM(21), IER) - IF (IER .NE. 0) IERPJ = 1 - RETURN -C----------------------- END OF SUBROUTINE PREPJ ----------------------- - END - SUBROUTINE PREPDF (NEQ, Y, SRUR, SAVF, FTEM, DFDP, PAR, - 1 F, DF, JPAR) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - EXTERNAL F, DF - DIMENSION NEQ(*), Y(*), SAVF(*), FTEM(*), DFDP(*), PAR(*) - COMMON /ODE001/ ROWND, ROWNS(173), - 1 RDUM1(43), TN, RDUM2, - 2 IOWND1(14), IOWNS(4), - 3 IDUM1(10), MITER, IDUM2(4), N, IDUM3(2), NFE, IDUM4(2) - COMMON /ODE002/ RDUM3(3), - 1 IOWND2(3), IDUM5(2), NDFE, IDUM6, IDF, IDUM7(3) -C----------------------------------------------------------------------- -C PREPDF IS CALLED BY SPRIME AND STESA TO COMPUTE THE INHOMOGENEITY -C VECTORS DF(I)/DP(JPAR). HERE DF/DP IS COMPUTED BY THE USER-SUPPLIED -C ROUTINE DF IF IDF = 1, OR BY FINITE DIFFERENCING IF IDF = 0. -C -C IN ADDITION TO VARIABLES DESCRIBED PREVIOUSLY, COMMUNICATION WITH -C PREPDF USES THE FOLLOWING.. -C Y = REAL ARRAY OF LENGTH NYH CONTAINING DEPENDENT VARIABLES. -C PREPDF USES ONLY THE FIRST N ENTRIES OF Y(*). -C SRUR = SQRT(UROUND) (= WM(1)). -C SAVF = REAL ARRAY OF LENGTH N CONTAINING DERIVATIVES DY/DT. -C FTEM = REAL ARRAY OF LENGTH N USED TO TEMPORARILY STORE DY/DT FOR -C NUMERICAL DIFFERENTIATION. -C DFDP = REAL ARRAY OF LENGTH N USED TO STORE DF(I)/DP(JPAR), I = 1,N. -C PAR = REAL ARRAY OF LENGTH NPAR CONTAINING EQUATION PARAMETERS -C OF INTEREST. -C JPAR = INPUT PARAMETER, 2 .LE. JPAR .LE. NSV, DESIGNATING THE -C APPROPRIATE SOLUTION VECTOR CORRESPONDING TO PAR(JPAR). -C THIS ROUTINE ALSO USES THE COMMON VARIABLES TN, MITER, N, NFE, NDFE, -C AND IDF. -C----------------------------------------------------------------------- - NDFE = NDFE + 1 - IDF1 = IDF + 1 - GO TO (100, 200), IDF1 -C IDF = 0, CALL F TO APPROXIMATE DFDP. --------------------------------- - 100 RPAR = PAR(JPAR) - R = MAX(SRUR*ABS(RPAR),SRUR) - PAR(JPAR) = RPAR + R - FAC = 1.0D0/R - CALL F (NEQ, TN, Y, PAR, FTEM) - DO 110 I = 1,N - 110 DFDP(I) = (FTEM(I) - SAVF(I))*FAC - PAR(JPAR) = RPAR - NFE = NFE + 1 - RETURN -C IDF = 1, CALL USER SUPPLIED DF. -------------------------------------- - 200 DO 210 I = 1,N - 210 DFDP(I) = 0.0D0 - CALL DF (NEQ, TN, Y, PAR, DFDP, JPAR) - RETURN -C -------------------- END OF SUBROUTINE PREPDF ------------------------ - END - SUBROUTINE INTDY (T, K, YH, NYH, DKY, IFLAG) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - DIMENSION YH(NYH,1), DKY(1) - COMMON /ODE001/ ROWND, ROWNS(173), - 2 RDUM1(38),H, RDUM2(2), HU, RDUM3, TN, UROUND, - 3 IOWND(14), IOWNS(4), - 4 IDUM1(8), L, IDUM2, - 5 IDUM3(5), N, NQ, IDUM4(4) -C----------------------------------------------------------------------- -C INTDY COMPUTES INTERPOLATED VALUES OF THE K-TH DERIVATIVE OF THE -C DEPENDENT VARIABLE VECTOR Y, AND STORES IT IN DKY. THIS ROUTINE -C IS CALLED WITHIN THE PACKAGE WITH K = 0 AND T = TOUT, BUT MAY -C ALSO BE CALLED BY THE USER FOR ANY K UP TO THE CURRENT ORDER. -C (SEE DETAILED INSTRUCTIONS IN THE USAGE DOCUMENTATION.) -C----------------------------------------------------------------------- -C THE COMPUTED VALUES IN DKY ARE GOTTEN BY INTERPOLATION USING THE -C NORDSIECK HISTORY ARRAY YH. THIS ARRAY CORRESPONDS UNIQUELY TO A -C VECTOR-VALUED POLYNOMIAL OF DEGREE NQCUR OR LESS, AND DKY IS SET -C TO THE K-TH DERIVATIVE OF THIS POLYNOMIAL AT T. -C THE FORMULA FOR DKY IS.. -C Q -C DKY(I) = SUM C(J,K) * (T - TN)**(J-K) * H**(-J) * YH(I,J+1) -C J=K -C WHERE C(J,K) = J*(J-1)*...*(J-K+1), Q = NQCUR, TN = TCUR, H = HCUR. -C THE QUANTITIES NQ = NQCUR, L = NQ+1, N = NEQ, TN, AND H ARE -C COMMUNICATED BY COMMON. THE ABOVE SUM IS DONE IN REVERSE ORDER. -C IFLAG IS RETURNED NEGATIVE IF EITHER K OR T IS OUT OF BOUNDS. -C----------------------------------------------------------------------- - IFLAG = 0 - IF (K .LT. 0 .OR. K .GT. NQ) GO TO 80 - TP = TN - HU*(1.0D0 + 100.0D0*UROUND) - IF ((T-TP)*(T-TN) .GT. 0.0D0) GO TO 90 -C - S = (T - TN)/H - IC = 1 - IF (K .EQ. 0) GO TO 15 - JJ1 = L - K - DO 10 JJ = JJ1,NQ - 10 IC = IC*JJ - 15 C = REAL(IC) - DO 20 I = 1,NYH - 20 DKY(I) = C*YH(I,L) - IF (K .EQ. NQ) GO TO 55 - JB2 = NQ - K - DO 50 JB = 1,JB2 - J = NQ - JB - JP1 = J + 1 - IC = 1 - IF (K .EQ. 0) GO TO 35 - JJ1 = JP1 - K - DO 30 JJ = JJ1,J - 30 IC = IC*JJ - 35 C = REAL(IC) - DO 40 I = 1,NYH - 40 DKY(I) = C*YH(I,JP1) + S*DKY(I) - 50 CONTINUE - IF (K .EQ. 0) RETURN - 55 R = H**(-K) - DO 60 I = 1,NYH - 60 DKY(I) = R*DKY(I) - RETURN -C - 80 CALL XERR('INTDY-- K (=I1) ILLEGAL', - 1 51, 1, 1, K, 0, 0, ZERO,ZERO) - IFLAG = -1 - RETURN - 90 CALL XERR ('INTDY-- T (=R1) ILLEGAL', - 1 52, 1, 0, 0, 0, 1, T, ZERO) - CALL XERR('T NOT IN INTERVAL TCUR - HU (= R1) TO TCUR (=R2)', - 1 52, 1, 0, 0, 0, 2, TP, TN) - IFLAG = -2 - RETURN -C----------------------- END OF SUBROUTINE INTDY ----------------------- - END - SUBROUTINE STESA (NEQ, Y, NROW, NCOL, YH, WM, IWM, EWT, SAVF, - 1 ACOR, PAR, NRS, F, JAC, DF, PJAC, PDF, KppSolve) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - EXTERNAL F, JAC, DF, PJAC, PDF, KppSolve - DIMENSION NEQ(*), Y(NROW,*), YH(NROW,NCOL,*), WM(*), IWM(*), - 1 EWT(NROW,*), SAVF(*), ACOR(NROW,*), PAR(*), NRS(*) - PARAMETER (ONE=1.0D0,ZERO=0.0D0) - COMMON /ODE001/ ROWND, ROWNS(173), - 1 TESCO(3,12), RDUM1, EL0, H, RDUM2(4), TN, RDUM3, - 2 IOWND1(14), IOWNS(4), - 3 IALTH, LMAX, IDUM1, IERPJ, IERSL, JCUR, IDUM2, KFLAG, L, IDUM3, - 4 MITER, IDUM4(4), N, NQ, IDUM5, NFE, IDUM6(2) - COMMON /ODE002/ DUPS, DSMS, DDNS, - 1 IOWND2(3), IDUM7, NSV, IDUM8(2), IDF, IDUM9, JOPT, KFLAGS -C----------------------------------------------------------------------- -C STESA IS CALLED BY STODE TO PERFORM AN EXPLICIT CALCULATION FOR THE -C FIRST-ORDER SENSITIVITY COEFFICIENTS DY(I)/DP(J), I = 1,N; J = 1,NPAR. -C -C IN ADDITION TO THE VARIABLES DESCRIBED PREVIOUSLY, COMMUNICATION -C WITH STESA USES THE FOLLOWING.. -C Y = AN NROW (=N) BY NCOL (=NSV) REAL ARRAY CONTAINING THE -C CORRECTED DEPENDENT VARIABLES ON OUTPUT.. -C Y(I,1) , I = 1,N = STATE VARIABLES (INPUT); -C Y(I,J) , I = 1,N , J = 2,NSV , -C = SENSITIVITY COEFFICIENTS, DY(I)/DP(J). -C YH = AN N BY NSV BY LMAX REAL ARRAY CONTAINING THE PREDICTED -C DEPENDENT VARIABLES AND THEIR APPROXIMATE SCALED DERIVATIVES. -C SAVF = A REAL ARRAY OF LENGTH N USED TO STORE FIRST DERIVATIVES -C OF DEPENDENT VARIABLES IF MITER = 2 OR 5. -C PAR = A REAL ARRAY OF LENGTH NPAR CONTAINING THE EQUATION -C PARAMETERS OF INTEREST. -C NRS = AN INTEGER ARRAY OF LENGTH NPAR + 1 CONTAINING THE NUMBER -C OF REPEATED STEPS (KFLAGS .LT. 0) DUE TO THE SENSITIVITY -C CALCULATIONS.. -C NRS(1) = TOTAL NUMBER OF REPEATED STEPS -C NRS(I) , I = 2,NPAR = NUMBER OF REPEATED STEPS DUE -C TO PARAMETER I. -C NSV = NUMBER OF SOLUTION VECTORS = NPAR + 1. -C KFLAGS = LOCAL ERROR TEST FLAG, = 0 IF TEST PASSES, .LT. 0 IF TEST -C FAILS, AND STEP NEEDS TO BE REPEATED. ERROR TEST IS APPLIED -C TO EACH SOLUTION VECTOR INDEPENDENTLY. -C DUPS, DSMS, DDNS = REAL SCALARS USED FOR COMPUTING RHUP, RHSM, RHDN, -C ON RETURN TO STODE (IALTH .EQ. 1). -C THIS ROUTINE ALSO USES THE COMMON VARIABLES EL0, H, TN, IALTH, LMAX, -C IERPJ, IERSL, JCUR, KFLAG, L, MITER, N, NQ, NFE, AND JOPT. -C----------------------------------------------------------------------- - DUPS = ZERO - DSMS = ZERO - DDNS = ZERO - HL0 = H*EL0 - EL0I = ONE/EL0 - TI2 = ONE/TESCO(2,NQ) - TI3 = ONE/TESCO(3,NQ) -C IF MITER = 2 OR 5 (OR IDF = 0), SUPPLY DERIVATIVES AT CORRECTED -C Y(*,1) VALUES FOR NUMERICAL DIFFERENTIATION IN PJAC AND/OR PDF. - IF (MITER .EQ. 2 .OR. MITER .EQ. 5 .OR. IDF .EQ. 0) GO TO 10 - GO TO 15 - 10 CALL F (NEQ, TN, Y, PAR, SAVF) - NFE = NFE + 1 -C IF JCUR = 0, UPDATE THE JACOBIAN MATRIX. -C IF MITER = 5, LOAD CORRECTED Y(*,1) VALUES INTO Y(*,2). - 15 IF (JCUR .EQ. 1) GO TO 30 - IF (MITER .NE. 5) GO TO 25 - DO 20 I = 1,N - 20 Y(I,2) = Y(I,1) - 25 CALL PJAC (NEQ, Y, Y(1,2), N, WM, IWM, EWT, SAVF, ACOR(1,2), - 1 PAR, F, JAC, JOPT) - IF (IERPJ .NE. 0) RETURN -C----------------------------------------------------------------------- -C THIS IS A LOOPING POINT FOR THE SENSITIVITY CALCULATIONS. -C----------------------------------------------------------------------- -C FOR EACH PARAMETER PAR(*), A SENSITIVITY SOLUTION VECTOR IS COMPUTED -C USING THE SAME STEP SIZE (H) AND ORDER (NQ) AS IN STODE. -C A LOCAL ERROR TEST IS APPLIED INDEPENDENTLY TO EACH SOLUTION VECTOR. -C----------------------------------------------------------------------- - 30 DO 100 J = 2,NSV - JPAR = J - 1 -C EVALUATE INHOMOGENEITY TERM, TEMPORARILY LOAD INTO Y(*,JPAR+1). ------ - CALL PDF(NEQ, Y, WM, SAVF, ACOR(1,J), Y(1,J), PAR, - 1 F, DF, JPAR) -C----------------------------------------------------------------------- -C LOAD RHS OF SENSITIVITY SOLUTION (CORRECTOR) EQUATION.. -C -C RHS = DY/DP - EL(1)*H*D(DY/DP)/DT + EL(1)*H*DF/DP -C -C----------------------------------------------------------------------- - DO 40 I = 1,N - 40 Y(I,J) = YH(I,J,1) - EL0*YH(I,J,2) + HL0*Y(I,J) -C----------------------------------------------------------------------- -C KppSolve CORRECTOR EQUATION: THE SOLUTIONS ARE LOCATED IN Y(*,JPAR+1). -C THE EXPLICIT FORMULA IS.. -C -C (I - EL(1)*H*JAC) * DY/DP(CORRECTED) = RHS -C -C----------------------------------------------------------------------- - CALL KppSolve (WM, IWM, Y(1,J), DUM) - IF (IERSL .NE. 0) RETURN -C ESTIMATE LOCAL TRUNCATION ERROR. ------------------------------------- - DO 50 I = 1,N - 50 ACOR(I,J) = (Y(I,J) - YH(I,J,1))*EL0I - ERR = VNORM(N, ACOR(1,J), EWT(1,J))*TI2 - IF (ERR .GT. ONE) GO TO 200 -C----------------------------------------------------------------------- -C LOCAL ERROR TEST PASSED. SET KFLAGS TO 0 TO INDICATE THIS. -C IF IALTH = 1, COMPUTE DSMS, DDNS, AND DUPS (IF L .LT. LMAX). -C----------------------------------------------------------------------- - KFLAGS = 0 - IF (IALTH .GT. 1) GO TO 100 - IF (L .EQ. LMAX) GO TO 70 - DO 60 I= 1,N - 60 Y(I,J) = ACOR(I,J) - YH(I,J,LMAX) - DUPS = MAX(DUPS,VNORM(N,Y(1,J),EWT(1,J))*TI3) - 70 DSMS = MAX(DSMS,ERR) - 100 CONTINUE - RETURN -C----------------------------------------------------------------------- -C THIS SECTION IS REACHED IF THE ERROR TOLERANCE FOR SENSITIVITY -C SOLUTION VECTOR JPAR HAS BEEN VIOLATED. KFLAGS IS MADE NEGATIVE TO -C INDICATE THIS. IF KFLAGS = -1, SET KFLAG EQUAL TO ZERO SO THAT KFLAG -C IS SET TO -1 ON RETURN TO STODE BEFORE REPEATING THE STEP. -C INCREMENT NRS(1) (= TOTAL NUMBER OF REPEATED STEPS DUE TO ALL -C SENSITIVITY SOLUTION VECTORS) BY ONE. -C INCREMENT NRS(JPAR+1) (= TOTAL NUMBER OF REPEATED STEPS DUE TO -C SOLUTION VECTOR JPAR+1) BY ONE. -C LOAD DSMS FOR RH CALCULATION IN STODE. -C----------------------------------------------------------------------- - 200 KFLAGS = KFLAGS - 1 - IF (KFLAGS .EQ. -1) KFLAG = 0 - NRS(1) = NRS(1) + 1 - NRS(J) = NRS(J) + 1 - DSMS = ERR - RETURN -C------------------------ END OF SUBROUTINE STESA ---------------------- - END - SUBROUTINE STODE (NEQ, Y, YH, NYH, YH1, WM, IWM, EWT, SAVF, ACOR, - 1 PAR, NRS, F, JAC, DF, PJAC, PDF, SLVS) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - EXTERNAL F, JAC, DF, PJAC, PDF, SLVS - DIMENSION NEQ(*), Y(*), YH(NYH,*), YH1(*), WM(*), IWM(*), EWT(*), - 1 SAVF(*), ACOR(*), PAR(*), NRS(*) - PARAMETER (ONE=1.0D0,ZERO=0.0D0) - COMMON /ODE001/ ROWND, - 1 CONIT, CRATE, EL(13), ELCO(13,12), HOLD, RMAX, - 2 TESCO(3,12), CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, - 3 IOWND1(14), IPUP, MEO, NQNYH, NSLP, - 4 IALTH, LMAX, ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, METH, - 5 MITER, MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU - COMMON /ODE002/ DUPS, DSMS, DDNS, - 1 IOWND2(3), ISOPT, NSV, NDFE, NSPE, IDF, IERSP, JOPT, KFLAGS -C----------------------------------------------------------------------- -C STODE PERFORMS ONE STEP OF THE INTEGRATION OF AN INITIAL VALUE -C PROBLEM FOR A SYSTEM OF ORDINARY DIFFERENTIAL EQUATIONS. -C NOTE.. STODE IS INDEPENDENT OF THE VALUE OF THE ITERATION METHOD -C INDICATOR MITER, WHEN THIS IS .NE. 0, AND HENCE IS INDEPENDENT -C OF THE TYPE OF CHORD METHOD USED, OR THE JACOBIAN STRUCTURE. -C FOR ISOPT = 1, STODE CALLS STESA FOR SENSITIVITY CALCULATIONS. -C VARIABLES USED FOR COMMUNICATION WITH STESA ARE DESCRIBED IN STESA. -C COMMUNICATION WITH STODE IS DONE WITH THE FOLLOWING VARIABLES.. -C -C NEQ = INTEGER ARRAY CONTAINING PROBLEM SIZE IN NEQ(1), AND -C NUMBER OF PARAMETERS TO BE CONSIDERED IN THE SENSITIVITY -C ANALYSIS NEQ(2) (FOR ISOPT = 1), AND PASSED AS THE -C NEQ ARGUMENT IN ALL CALLS TO F, JAC, AND DF. -C Y = AN ARRAY OF LENGTH .GE. N USED AS THE Y ARGUMENT IN -C ALL CALLS TO F, JAC, AND DF. -C YH = AN NYH BY LMAX ARRAY CONTAINING THE DEPENDENT VARIABLES -C AND THEIR APPROXIMATE SCALED DERIVATIVES, WHERE -C LMAX = MAXORD + 1. YH(I,J+1) CONTAINS THE APPROXIMATE -C J-TH DERIVATIVE OF Y(I), SCALED BY H**J/FACTORIAL(J) -C (J = 0,1,...,NQ). ON ENTRY FOR THE FIRST STEP, THE FIRST -C TWO COLUMNS OF YH MUST BE SET FROM THE INITIAL VALUES. -C NYH = A CONSTANT INTEGER .GE. N, THE FIRST DIMENSION OF YH. -C THE TOTAL NUMBER OF FIRST-ORDER DIFFERENTIAL EQUATIONS.. -C NYH = N, ISOPT = 0, -C NYH = N * (NPAR + 1), ISOPT = 1 -C YH1 = A ONE-DIMENSIONAL ARRAY OCCUPYING THE SAME SPACE AS YH. -C EWT = AN ARRAY OF LENGTH NYH CONTAINING MULTIPLICATIVE WEIGHTS -C FOR LOCAL ERROR MEASUREMENTS. LOCAL ERRORS IN Y(I) ARE -C COMPARED TO 1.0/EWT(I) IN VARIOUS ERROR TESTS. -C SAVF = AN ARRAY OF WORKING STORAGE, OF LENGTH N. -C ALSO USED FOR INPUT OF YH(*,MAXORD+2) WHEN JSTART = -1 -C AND MAXORD .LT. THE CURRENT ORDER NQ. -C ACOR = A WORK ARRAY OF LENGTH NYH, USED FOR THE ACCUMULATED -C CORRECTIONS. ON A SUCCESSFUL RETURN, ACOR(I) CONTAINS -C THE ESTIMATED ONE-STEP LOCAL ERROR IN Y(I). -C WM,IWM = REAL AND INTEGER WORK ARRAYS ASSOCIATED WITH MATRIX -C OPERATIONS IN CHORD ITERATION (MITER .NE. 0). -C PJAC = NAME OF ROUTINE TO EVALUATE AND PREPROCESS JACOBIAN MATRIX -C AND P = I - H*EL0*JAC, IF A CHORD METHOD IS BEING USED. -C IF ISOPT = 1, PJAC CAN BE CALLED TO CALCULATE JAC BY -C SETTING JOPT = 1. -C SLVS = NAME OF ROUTINE TO KppSolve LINEAR SYSTEM IN CHORD ITERATION. -C CCMAX = MAXIMUM RELATIVE CHANGE IN H*EL0 BEFORE PJAC IS CALLED. -C H = THE STEP SIZE TO BE ATTEMPTED ON THE NEXT STEP. -C H IS ALTERED BY THE ERROR CONTROL ALGORITHM DURING THE -C PROBLEM. H CAN BE EITHER POSITIVE OR NEGATIVE, BUT ITS -C SIGN MUST REMAIN CONSTANT THROUGHOUT THE PROBLEM. -C HMIN = THE MINIMUM ABSOLUTE VALUE OF THE STEP SIZE H TO BE USED. -C HMXI = INVERSE OF THE MAXIMUM ABSOLUTE VALUE OF H TO BE USED. -C HMXI = 0.0 IS ALLOWED AND CORRESPONDS TO AN INFINITE HMAX. -C HMIN AND HMXI MAY BE CHANGED AT ANY TIME, BUT WILL NOT -C TAKE EFFECT UNTIL THE NEXT CHANGE OF H IS CONSIDERED. -C TN = THE INDEPENDENT VARIABLE. TN IS UPDATED ON EACH STEP TAKEN. -C JSTART = AN INTEGER USED FOR INPUT ONLY, WITH THE FOLLOWING -C VALUES AND MEANINGS.. -C 0 PERFORM THE FIRST STEP. -C .GT.0 TAKE A NEW STEP CONTINUING FROM THE LAST. -C -1 TAKE THE NEXT STEP WITH A NEW VALUE OF H, MAXORD, -C N, METH, OR MITER. -C -2 TAKE THE NEXT STEP WITH A NEW VALUE OF H, -C BUT WITH OTHER INPUTS UNCHANGED. -C ON RETURN, JSTART IS SET TO 1 TO FACILITATE CONTINUATION. -C KFLAG = A COMPLETION CODE WITH THE FOLLOWING MEANINGS.. -C 0 THE STEP WAS SUCCESFUL. -C -1 THE REQUESTED ERROR COULD NOT BE ACHIEVED. -C -2 CORRECTOR CONVERGENCE COULD NOT BE ACHIEVED. -C -3 FATAL ERROR IN PJAC, OR SLVS, (OR STESA). -C A RETURN WITH KFLAG = -1 OR -2 MEANS EITHER -C ABS(H) = HMIN OR 10 CONSECUTIVE FAILURES OCCURRED. -C ON A RETURN WITH KFLAG NEGATIVE, THE VALUES OF TN AND -C THE YH ARRAY ARE AS OF THE BEGINNING OF THE LAST -C STEP, AND H IS THE LAST STEP SIZE ATTEMPTED. -C MAXORD = THE MAXIMUM ORDER OF INTEGRATION METHOD TO BE ALLOWED. -C MAXCOR = THE MAXIMUM NUMBER OF CORRECTOR ITERATIONS ALLOWED. -C (= 3, IF ISOPT = 0) -C (= 4, IF ISOPT = 1) -C MSBP = MAXIMUM NUMBER OF STEPS BETWEEN PJAC CALLS (MITER .GT. 0). -C IF ISOPT = 1, PJAC IS CALLED AT LEAST ONCE EVERY STEP. -C MXNCF = MAXIMUM NUMBER OF CONVERGENCE FAILURES ALLOWED. -C METH/MITER = THE METHOD FLAGS. SEE DESCRIPTION IN DRIVER. -C N = THE NUMBER OF FIRST-ORDER MODEL DIFFERENTIAL EQUATIONS. -C----------------------------------------------------------------------- - KFLAG = 0 - KFLAGS = 0 - TOLD = TN - NCF = 0 - IERPJ = 0 - IERSL = 0 - JCUR = 0 - ICF = 0 - IF (JSTART .GT. 0) GO TO 200 - IF (JSTART .EQ. -1) GO TO 100 - IF (JSTART .EQ. -2) GO TO 160 -C----------------------------------------------------------------------- -C ON THE FIRST CALL, THE ORDER IS SET TO 1, AND OTHER VARIABLES ARE -C INITIALIZED. RMAX IS THE MAXIMUM RATIO BY WHICH H CAN BE INCREASED -C IN A SINGLE STEP. IT IS INITIALLY 1.E4 TO COMPENSATE FOR THE SMALL -C INITIAL H, BUT THEN IS NORMALLY EQUAL TO 10. IF A FAILURE -C OCCURS (IN CORRECTOR CONVERGENCE OR ERROR TEST), RMAX IS SET AT 2 -C FOR THE NEXT INCREASE. -C THESE COMPUTATIONS CONSIDER ONLY THE ORIGINAL SOLUTION VECTOR. -C THE SENSITIVITY SOLUTION VECTORS ARE CONSIDERED IN STESA (ISOPT = 1). -C----------------------------------------------------------------------- - LMAX = MAXORD + 1 - NQ = 1 - L = 2 - IALTH = 2 - RMAX = 10000.0D0 - RC = ZERO - EL0 = ONE - CRATE = 0.7D0 - DELP = ZERO - HOLD = H - MEO = METH - NSLP = 0 - IPUP = MITER - IRET = 3 - GO TO 140 -C----------------------------------------------------------------------- -C THE FOLLOWING BLOCK HANDLES PRELIMINARIES NEEDED WHEN JSTART = -1. -C IPUP IS SET TO MITER TO FORCE A MATRIX UPDATE. -C IF AN ORDER INCREASE IS ABOUT TO BE CONSIDERED (IALTH = 1), -C IALTH IS RESET TO 2 TO POSTPONE CONSIDERATION ONE MORE STEP. -C IF THE CALLER HAS CHANGED METH, CFODE IS CALLED TO RESET -C THE COEFFICIENTS OF THE METHOD. -C IF THE CALLER HAS CHANGED MAXORD TO A VALUE LESS THAN THE CURRENT -C ORDER NQ, NQ IS REDUCED TO MAXORD, AND A NEW H CHOSEN ACCORDINGLY. -C IF H IS TO BE CHANGED, YH MUST BE RESCALED. -C IF H OR METH IS BEING CHANGED, IALTH IS RESET TO L = NQ + 1 -C TO PREVENT FURTHER CHANGES IN H FOR THAT MANY STEPS. -C----------------------------------------------------------------------- - 100 IPUP = MITER - LMAX = MAXORD + 1 - IF (IALTH .EQ. 1) IALTH = 2 - IF (METH .EQ. MEO) GO TO 110 - CALL CFODE (METH, ELCO, TESCO) - MEO = METH - IF (NQ .GT. MAXORD) GO TO 120 - IALTH = L - IRET = 1 - GO TO 150 - 110 IF (NQ .LE. MAXORD) GO TO 160 - 120 NQ = MAXORD - L = LMAX - DO 125 I = 1,L - 125 EL(I) = ELCO(I,NQ) - NQNYH = NQ*NYH - RC = RC*EL(1)/EL0 - EL0 = EL(1) - CONIT = 0.5D0/REAL(NQ+2) - DDN = VNORM (N, SAVF, EWT)/TESCO(1,L) - EXDN = ONE/REAL(L) - RHDN = ONE/(1.3D0*DDN**EXDN + 0.0000013D0) - RH = MIN(RHDN,ONE) - IREDO = 3 - IF (H .EQ. HOLD) GO TO 170 - RH = MIN(RH,ABS(H/HOLD)) - H = HOLD - GO TO 175 -C----------------------------------------------------------------------- -C CFODE IS CALLED TO GET ALL THE INTEGRATION COEFFICIENTS FOR THE -C CURRENT METH. THEN THE EL VECTOR AND RELATED CONSTANTS ARE RESET -C WHENEVER THE ORDER NQ IS CHANGED, OR AT THE START OF THE PROBLEM. -C----------------------------------------------------------------------- - 140 CALL CFODE (METH, ELCO, TESCO) - 150 DO 155 I = 1,L - 155 EL(I) = ELCO(I,NQ) - NQNYH = NQ*NYH - RC = RC*EL(1)/EL0 - EL0 = EL(1) - CONIT = 0.5D0/REAL(NQ+2) - GO TO (160, 170, 200), IRET -C----------------------------------------------------------------------- -C IF H IS BEING CHANGED, THE H RATIO RH IS CHECKED AGAINST -C RMAX, HMIN, AND HMXI, AND THE YH ARRAY RESCALED. IALTH IS SET TO -C L = NQ + 1 TO PREVENT A CHANGE OF H FOR THAT MANY STEPS, UNLESS -C FORCED BY A CONVERGENCE OR ERROR TEST FAILURE. -C----------------------------------------------------------------------- - 160 IF (H .EQ. HOLD) GO TO 200 - RH = H/HOLD - H = HOLD - IREDO = 3 - GO TO 175 - 170 RH = MAX(RH,HMIN/ABS(H)) - 175 RH = MIN(RH,RMAX) - RH = RH/MAX(ONE,ABS(H)*HMXI*RH) - R = ONE - DO 180 J = 2,L - R = R*RH - DO 180 I = 1,NYH - 180 YH(I,J) = YH(I,J)*R - H = H*RH - RC = RC*RH - IALTH = L - IF (IREDO .EQ. 0) GO TO 690 -C----------------------------------------------------------------------- -C THIS SECTION COMPUTES THE PREDICTED VALUES BY EFFECTIVELY -C MULTIPLYING THE YH ARRAY BY THE PASCAL TRIANGLE MATRIX. -C RC IS THE RATIO OF NEW TO OLD VALUES OF THE COEFFICIENT H*EL(1). -C WHEN RC DIFFERS FROM 1 BY MORE THAN CCMAX, IPUP IS SET TO MITER -C TO FORCE PJAC TO BE CALLED, IF A JACOBIAN IS INVOLVED. -C IN ANY CASE, PJAC IS CALLED AT LEAST EVERY MSBP STEPS FOR ISOPT = 0, -C AND AT LEAST ONCE EVERY STEP FOR ISOPT = 1. -C----------------------------------------------------------------------- - 200 IF (ABS(RC-ONE) .GT. CCMAX) IPUP = MITER - IF (NST .GE. NSLP+MSBP) IPUP = MITER - TN = TN + H - I1 = NQNYH + 1 - DO 215 JB = 1,NQ - I1 = I1 - NYH - DO 210 I = I1,NQNYH - 210 YH1(I) = YH1(I) + YH1(I+NYH) - 215 CONTINUE -C----------------------------------------------------------------------- -C UP TO MAXCOR CORRECTOR ITERATIONS ARE TAKEN. (= 3, FOR ISOPT = 0; -C = 4, FOR ISOPT = 1). A CONVERGENCE TEST IS MADE ON THE R.M.S. NORM -C OF EACH CORRECTION, WEIGHTED BY THE ERROR WEIGHT VECTOR EWT. THE SUM -C OF THE CORRECTIONS IS ACCUMULATED IN THE VECTOR ACOR(I), I = 1,N. -C (ACOR(I), I = N+1,NYH IS LOADED IN SUBROUTINE STESA (ISOPT = 1).) -C THE YH ARRAY IS NOT ALTERED IN THE CORRECTOR LOOP. -C----------------------------------------------------------------------- - 220 M = 0 - DO 230 I = 1,N - 230 Y(I) = YH(I,1) - CALL F (NEQ, TN, Y, PAR, SAVF) - NFE = NFE + 1 - IF (IPUP .LE. 0) GO TO 250 -C----------------------------------------------------------------------- -C IF INDICATED, THE MATRIX P = I - H*EL(1)*J IS REEVALUATED AND -C PREPROCESSED BEFORE STARTING THE CORRECTOR ITERATION. IPUP IS SET -C TO 0 AS AN INDICATOR THAT THIS HAS BEEN DONE. -C----------------------------------------------------------------------- - IPUP = 0 - RC = ONE - NSLP = NST - CRATE = 0.7D0 - CALL PJAC (NEQ, Y, YH, NYH, WM, IWM, EWT, SAVF, ACOR, PAR, - 1 F, JAC, JOPT) - IF (IERPJ .NE. 0) GO TO 430 - 250 DO 260 I = 1,N - 260 ACOR(I) = ZERO - 270 IF (MITER .NE. 0) GO TO 350 -C----------------------------------------------------------------------- -C IN THE CASE OF FUNCTIONAL ITERATION, UPDATE Y DIRECTLY FROM -C THE RESULT OF THE LAST FUNCTION EVALUATION. -C (IF ISOPT = 1, FUNCTIONAL ITERATION IS NOT ALLOWED.) -C----------------------------------------------------------------------- - DO 290 I = 1,N - SAVF(I) = H*SAVF(I) - YH(I,2) - 290 Y(I) = SAVF(I) - ACOR(I) - DEL = VNORM (N, Y, EWT) - DO 300 I = 1,N - Y(I) = YH(I,1) + EL(1)*SAVF(I) - 300 ACOR(I) = SAVF(I) - GO TO 400 -C----------------------------------------------------------------------- -C IN THE CASE OF THE CHORD METHOD, COMPUTE THE CORRECTOR ERROR, -C AND KppSolve THE LINEAR SYSTEM WITH THAT AS RIGHT-HAND SIDE AND -C P AS COEFFICIENT MATRIX. -C----------------------------------------------------------------------- - 350 DO 360 I = 1,N - 360 Y(I) = H*SAVF(I) - (YH(I,2) + ACOR(I)) - CALL SLVS (WM, IWM, Y, SAVF) - IF (IERSL .LT. 0) GO TO 430 - IF (IERSL .GT. 0) GO TO 410 - DEL = VNORM (N, Y, EWT) - DO 380 I = 1,N - ACOR(I) = ACOR(I) + Y(I) - 380 Y(I) = YH(I,1) + EL(1)*ACOR(I) -C----------------------------------------------------------------------- -C TEST FOR CONVERGENCE. IF M.GT.0, AN ESTIMATE OF THE CONVERGENCE -C RATE CONSTANT IS STORED IN CRATE, AND THIS IS USED IN THE TEST. -C----------------------------------------------------------------------- - 400 IF (M .NE. 0) CRATE = MAX(0.2D0*CRATE,DEL/DELP) - DCON = DEL*MIN(ONE,1.5D0*CRATE)/(TESCO(2,NQ)*CONIT) - IF (DCON .LE. ONE) GO TO 450 - M = M + 1 - IF (M .EQ. MAXCOR) GO TO 410 - IF (M .GE. 2 .AND. DEL .GT. 2.0D0*DELP) GO TO 410 - DELP = DEL - CALL F (NEQ, TN, Y, PAR, SAVF) - NFE = NFE + 1 - GO TO 270 -C----------------------------------------------------------------------- -C THE CORRECTOR ITERATION FAILED TO CONVERGE IN MAXCOR TRIES. -C IF MITER .NE. 0 AND THE JACOBIAN IS OUT OF DATE, PJAC IS CALLED FOR -C THE NEXT TRY. OTHERWISE THE YH ARRAY IS RETRACTED TO ITS VALUES -C BEFORE PREDICTION, AND H IS REDUCED, IF POSSIBLE. IF H CANNOT BE -C REDUCED OR MXNCF FAILURES HAVE OCCURRED, EXIT WITH KFLAG = -2. -C----------------------------------------------------------------------- - 410 IF (MITER .EQ. 0 .OR. JCUR .EQ. 1) GO TO 430 - ICF = 1 - IPUP = MITER - GO TO 220 - 430 ICF = 2 - NCF = NCF + 1 - RMAX = 2.0D0 - TN = TOLD - I1 = NQNYH + 1 - DO 445 JB = 1,NQ - I1 = I1 - NYH - DO 440 I = I1,NQNYH - 440 YH1(I) = YH1(I) - YH1(I+NYH) - 445 CONTINUE - IF (IERPJ .LT. 0 .OR. IERSL .LT. 0) GO TO 680 - IF (ABS(H) .LE. HMIN*1.00001D0) GO TO 670 - IF (NCF .EQ. MXNCF) GO TO 670 - RH = 0.25D0 - IPUP = MITER - IREDO = 1 - GO TO 170 -C----------------------------------------------------------------------- -C THE CORRECTOR HAS CONVERGED. -C THE LOCAL ERROR TEST IS MADE AND CONTROL PASSES TO STATEMENT 500 -C IF IT FAILS. OTHERWISE, STESA IS CALLED (ISOPT = 1) TO PERFORM -C SENSITIVITY CALCULATIONS AT CURRENT STEP SIZE AND ORDER. -C----------------------------------------------------------------------- - 450 CONTINUE - IF (M .EQ. 0) DSM = DEL/TESCO(2,NQ) - IF (M .GT. 0) DSM = VNORM (N, ACOR, EWT)/TESCO(2,NQ) - IF (DSM .GT. ONE) GO TO 500 -C - IF (ISOPT .EQ. 0) GO TO 460 -C----------------------------------------------------------------------- -C CALL STESA TO PERFORM EXPLICIT SENSITIVITY ANALYSIS. -C IF THE LOCAL ERROR TEST FAILS (WITHIN STESA) FOR ANY SOLUTION VECTOR, -C KFLAGS IS SET .LT. 0 AND CONTROL PASSES TO STATEMENT 500 UPON RETURN. -C IN EITHER CASE, JCUR IS SET TO ZERO TO SIGNAL THAT THE JACOBIAN MAY -C NEED UPDATING LATER. -C----------------------------------------------------------------------- - CALL STESA (NEQ, Y, N, NSV, YH, WM, IWM, EWT, SAVF, ACOR, - 1 PAR, NRS, F, JAC, DF, PJAC, PDF, SLVS) - IF (IERPJ .NE. 0 .OR. IERSL .NE. 0) GO TO 680 - IF (KFLAGS .LT. 0) GO TO 500 -C----------------------------------------------------------------------- -C AFTER A SUCCESSFUL STEP, UPDATE THE YH ARRAY. -C CONSIDER CHANGING H IF IALTH = 1. OTHERWISE DECREASE IALTH BY 1. -C IF IALTH IS THEN 1 AND NQ .LT. MAXORD, THEN ACOR IS SAVED FOR -C USE IN A POSSIBLE ORDER INCREASE ON THE NEXT STEP. -C IF A CHANGE IN H IS CONSIDERED, AN INCREASE OR DECREASE IN ORDER -C BY ONE IS CONSIDERED ALSO. A CHANGE IN H IS MADE ONLY IF IT IS BY A -C FACTOR OF AT LEAST 1.1. IF NOT, IALTH IS SET TO 3 TO PREVENT -C TESTING FOR THAT MANY STEPS. -C----------------------------------------------------------------------- - 460 JCUR = 0 - KFLAG = 0 - IREDO = 0 - NST = NST + 1 - HU = H - NQU = NQ - DO 470 J = 1,L - DO 470 I = 1,NYH - 470 YH(I,J) = YH(I,J) + EL(J)*ACOR(I) - IALTH = IALTH - 1 - IF (IALTH .EQ. 0) GO TO 520 - IF (IALTH .GT. 1) GO TO 700 - IF (L .EQ. LMAX) GO TO 700 - DO 490 I = 1,NYH - 490 YH(I,LMAX) = ACOR(I) - GO TO 700 -C----------------------------------------------------------------------- -C THE ERROR TEST FAILED IN EITHER STODE OR STESA. -C KFLAG KEEPS TRACK OF MULTIPLE FAILURES. -C RESTORE TN AND THE YH ARRAY TO THEIR PREVIOUS VALUES, AND PREPARE -C TO TRY THE STEP AGAIN. COMPUTE THE OPTIMUM STEP SIZE FOR THIS OR -C ONE LOWER ORDER. AFTER 2 OR MORE FAILURES, H IS FORCED TO DECREASE -C BY A FACTOR OF 0.2 OR LESS. -C----------------------------------------------------------------------- - 500 KFLAG = KFLAG - 1 - JCUR = 0 - TN = TOLD - I1 = NQNYH + 1 - DO 515 JB = 1,NQ - I1 = I1 - NYH - DO 510 I = I1,NQNYH - 510 YH1(I) = YH1(I) - YH1(I+NYH) - 515 CONTINUE - RMAX = 2.0D0 - IF (ABS(H) .LE. HMIN*1.00001D0) GO TO 660 - IF (KFLAG .LE. -3) GO TO 640 - IREDO = 2 - RHUP = ZERO - GO TO 540 -C----------------------------------------------------------------------- -* -C REGARDLESS OF THE SUCCESS OR FAILURE OF THE STEP, FACTORS -C RHDN, RHSM, AND RHUP ARE COMPUTED, BY WHICH H COULD BE MULTIPLIED -C AT ORDER NQ - 1, ORDER NQ, OR ORDER NQ + 1, RESPECTIVELY. -C IN THE CASE OF FAILURE, RHUP = 0.0 TO AVOID AN ORDER INCREASE. -C THE LARGEST OF THESE IS DETERMINED AND THE NEW ORDER CHOSEN -C ACCORDINGLY. IF THE ORDER IS TO BE INCREASED, WE COMPUTE ONE -C ADDITIONAL SCALED DERIVATIVE. -C FOR ISOPT = 1, DUPS AND DSMS ARE LOADED WITH THE LARGEST RMS-NORMS -C OBTAINED BY CONSIDERING SEPARATELY THE SENSITIVITY SOLUTION VECTORS. -C----------------------------------------------------------------------- - 520 RHUP = ZERO - IF (L .EQ. LMAX) GO TO 540 - DO 530 I = 1,N - 530 SAVF(I) = ACOR(I) - YH(I,LMAX) - DUP = VNORM (N, SAVF, EWT)/TESCO(3,NQ) - DUP = MAX(DUP,DUPS) - EXUP = ONE/REAL(L+1) - RHUP = ONE/(1.4D0*DUP**EXUP + 0.0000014D0) - 540 EXSM = ONE/REAL(L) - DSM = MAX(DSM,DSMS) - RHSM = ONE/(1.2D0*DSM**EXSM + 0.0000012D0) - RHDN = ZERO - IF (NQ .EQ. 1) GO TO 560 - JPOINT = 1 - DO 550 J = 1,NSV - DDN = VNORM (N, YH(JPOINT,L), EWT(JPOINT))/TESCO(1,NQ) - DDNS = MAX(DDNS,DDN) - JPOINT = JPOINT + N - 550 CONTINUE - DDN = DDNS - DDNS = ZERO - EXDN = ONE/REAL(NQ) - RHDN = ONE/(1.3D0*DDN**EXDN + 0.0000013D0) - 560 IF (RHSM .GE. RHUP) GO TO 570 - IF (RHUP .GT. RHDN) GO TO 590 - GO TO 580 - 570 IF (RHSM .LT. RHDN) GO TO 580 - NEWQ = NQ - RH = RHSM - GO TO 620 - 580 NEWQ = NQ - 1 - RH = RHDN - IF (KFLAG .LT. 0 .AND. RH .GT. ONE) RH = ONE - GO TO 620 - 590 NEWQ = L - RH = RHUP - IF (RH .LT. 1.1D0) GO TO 610 - R = EL(L)/REAL(L) - DO 600 I = 1,NYH - 600 YH(I,NEWQ+1) = ACOR(I)*R - GO TO 630 - 610 IALTH = 3 - GO TO 700 - 620 IF ((KFLAG .EQ. 0) .AND. (RH .LT. 1.1D0)) GO TO 610 - IF (KFLAG .LE. -2) RH = MIN(RH,0.2D0) -C----------------------------------------------------------------------- -C IF THERE IS A CHANGE OF ORDER, RESET NQ, L, AND THE COEFFICIENTS. -C IN ANY CASE H IS RESET ACCORDING TO RH AND THE YH ARRAY IS RESCALED. -C THEN EXIT FROM 690 IF THE STEP WAS OK, OR REDO THE STEP OTHERWISE. -C----------------------------------------------------------------------- - IF (NEWQ .EQ. NQ) GO TO 170 - 630 NQ = NEWQ - L = NQ + 1 - IRET = 2 - GO TO 150 -C----------------------------------------------------------------------- -C CONTROL REACHES THIS SECTION IF 3 OR MORE FAILURES HAVE OCCURED. -C IF 10 FAILURES HAVE OCCURRED, EXIT WITH KFLAG = -1. -C IT IS ASSUMED THAT THE DERIVATIVES THAT HAVE ACCUMULATED IN THE -C YH ARRAY HAVE ERRORS OF THE WRONG ORDER. HENCE THE FIRST -C DERIVATIVE IS RECOMPUTED, AND THE ORDER IS SET TO 1. THEN -C H IS REDUCED BY A FACTOR OF 10, AND THE STEP IS RETRIED, -C UNTIL IT SUCCEEDS OR H REACHES HMIN. -C----------------------------------------------------------------------- - 640 IF (KFLAG .EQ. -10) GO TO 660 - RH = 0.1D0 - RH = MAX(HMIN/ABS(H),RH) - H = H*RH - DO 645 I = 1,NYH - 645 Y(I) = YH(I,1) - CALL F (NEQ, TN, Y, PAR, SAVF) - NFE = NFE + 1 - IF (ISOPT .EQ. 0) GO TO 649 - CALL SPRIME (NEQ, Y, YH, NYH, N, NSV, WM, IWM, EWT, SAVF, ACOR, - 1 ACOR(N+1), PAR, F, JAC, DF, PJAC, PDF) - IF (IERSP .LT. 0) GO TO 680 - DO 646 I = N+1,NYH - 646 YH(I,2) = H*YH(I,2) - 649 DO 650 I = 1,N - 650 YH(I,2) = H*SAVF(I) - IPUP = MITER - IALTH = 5 - IF (NQ .EQ. 1) GO TO 200 - NQ = 1 - L = 2 - IRET = 3 - GO TO 150 -C----------------------------------------------------------------------- -C ALL RETURNS ARE MADE THROUGH THIS SECTION. H IS SAVED IN HOLD -C TO ALLOW THE CALLER TO CHANGE H ON THE NEXT STEP. -C----------------------------------------------------------------------- - 660 KFLAG = -1 - GO TO 720 - 670 KFLAG = -2 - GO TO 720 - 680 KFLAG = -3 - GO TO 720 - 690 RMAX = 10.0D0 - 700 R = ONE/TESCO(2,NQU) - DO 710 I = 1,NYH - 710 ACOR(I) = ACOR(I)*R - 720 HOLD = H - JSTART = 1 - RETURN -C----------------------- END OF SUBROUTINE STODE ----------------------- - END - SUBROUTINE CFODE (METH, ELCO, TESCO) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - DIMENSION ELCO(13,12), TESCO(3,12) -C----------------------------------------------------------------------- -C CFODE IS CALLED BY THE INTEGRATOR ROUTINE TO SET COEFFICIENTS -C NEEDED THERE. THE COEFFICIENTS FOR THE CURRENT METHOD, AS -C GIVEN BY THE VALUE OF METH, ARE SET FOR ALL ORDERS AND SAVED. -C THE MAXIMUM ORDER ASSUMED HERE IS 12 IF METH = 1 AND 5 IF METH = 2. -C (A SMALLER VALUE OF THE MAXIMUM ORDER IS ALSO ALLOWED.) -C CFODE IS CALLED ONCE AT THE BEGINNING OF THE PROBLEM, -C AND IS NOT CALLED AGAIN UNLESS AND UNTIL METH IS CHANGED. -C -C THE ELCO ARRAY CONTAINS THE BASIC METHOD COEFFICIENTS. -C THE COEFFICIENTS EL(I), 1 .LE. I .LE. NQ+1, FOR THE METHOD OF -C ORDER NQ ARE STORED IN ELCO(I,NQ). THEY ARE GIVEN BY A GENETRATING -C POLYNOMIAL, I.E., -C L(X) = EL(1) + EL(2)*X + ... + EL(NQ+1)*X**NQ. -C FOR THE IMPLICIT ADAMS METHODS, L(X) IS GIVEN BY -C DL/DX = (X+1)*(X+2)*...*(X+NQ-1)/FACTORIAL(NQ-1), L(-1) = 0. -C FOR THE BDF METHODS, L(X) IS GIVEN BY -C L(X) = (X+1)*(X+2)* ... *(X+NQ)/K, -C WHERE K = FACTORIAL(NQ)*(1 + 1/2 + ... + 1/NQ). -C -C THE TESCO ARRAY CONTAINS TEST CONSTANTS USED FOR THE -C LOCAL ERROR TEST AND THE SELECTION OF STEP SIZE AND/OR ORDER. -C AT ORDER NQ, TESCO(K,NQ) IS USED FOR THE SELECTION OF STEP -C SIZE AT ORDER NQ - 1 IF K = 1, AT ORDER NQ IF K = 2, AND AT ORDER -C NQ + 1 IF K = 3. -C----------------------------------------------------------------------- - DIMENSION PC(12) - PARAMETER (ONE=1.0D0,ZERO=0.0D0) -C - GO TO (100, 200), METH -C - 100 ELCO(1,1) = ONE - ELCO(2,1) = ONE - TESCO(1,1) = ZERO - TESCO(2,1) = 2.0D0 - TESCO(1,2) = ONE - TESCO(3,12) = ZERO - PC(1) = ONE - RQFAC = ONE - DO 140 NQ = 2,12 -C----------------------------------------------------------------------- -C THE PC ARRAY WILL CONTAIN THE COEFFICIENTS OF THE POLYNOMIAL -C P(X) = (X+1)*(X+2)*...*(X+NQ-1). -C INITIALLY, P(X) = 1. -C----------------------------------------------------------------------- - RQ1FAC = RQFAC - RQFAC = RQFAC/REAL(NQ) - NQM1 = NQ - 1 - FNQM1 = REAL(NQM1) - NQP1 = NQ + 1 -C FORM COEFFICIENTS OF P(X)*(X+NQ-1). ---------------------------------- - PC(NQ) = ZERO - DO 110 IB = 1,NQM1 - I = NQP1 - IB - 110 PC(I) = PC(I-1) + FNQM1*PC(I) - PC(1) = FNQM1*PC(1) -C COMPUTE INTEGRAL, -1 TO 0, OF P(X) AND X*P(X). ----------------------- - PINT = PC(1) - XPIN = PC(1)/2.0D0 - TSIGN = ONE - DO 120 I = 2,NQ - TSIGN = -TSIGN - PINT = PINT + TSIGN*PC(I)/REAL(I) - 120 XPIN = XPIN + TSIGN*PC(I)/REAL(I+1) -C STORE COEFFICIENTS IN ELCO AND TESCO. -------------------------------- - ELCO(1,NQ) = PINT*RQ1FAC - ELCO(2,NQ) = ONE - DO 130 I = 2,NQ - 130 ELCO(I+1,NQ) = RQ1FAC*PC(I)/REAL(I) - AGAMQ = RQFAC*XPIN - RAGQ = ONE/AGAMQ - TESCO(2,NQ) = RAGQ - IF (NQ .LT. 12) TESCO(1,NQP1) = RAGQ*RQFAC/REAL(NQP1) - TESCO(3,NQM1) = RAGQ - 140 CONTINUE - RETURN -C - 200 PC(1) = ONE - RQ1FAC = ONE - DO 230 NQ = 1,5 -C----------------------------------------------------------------------- -C THE PC ARRAY WILL CONTAIN THE COEFFICIENTS OF THE POLYNOMIAL -C P(X) = (X+1)*(X+2)*...*(X+NQ). -C INITIALLY, P(X) = 1. -C----------------------------------------------------------------------- - FNQ = REAL(NQ) - NQP1 = NQ + 1 -C FORM COEFFICIENTS OF P(X)*(X+NQ). ------------------------------------ - PC(NQP1) = ZERO - DO 210 IB = 1,NQ - I = NQ + 2 - IB - 210 PC(I) = PC(I-1) + FNQ*PC(I) - PC(1) = FNQ*PC(1) -C STORE COEFFICIENTS IN ELCO AND TESCO. -------------------------------- - DO 220 I = 1,NQP1 - 220 ELCO(I,NQ) = PC(I)/PC(2) - ELCO(2,NQ) = ONE - TESCO(1,NQ) = RQ1FAC - TESCO(2,NQ) = REAL(NQP1)/ELCO(1,NQ) - TESCO(3,NQ) = REAL(NQ+2)/ELCO(1,NQ) - RQ1FAC = RQ1FAC/FNQ - 230 CONTINUE - RETURN -C----------------------- END OF SUBROUTINE CFODE ----------------------- - END - SUBROUTINE SOLSY (WM, IWM, X, TEM) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - DIMENSION WM(*), IWM(*), X(*), TEM(*) - PARAMETER (ZERO=0.0D0,ONE=1.0D0) - COMMON /ODE001/ ROWND, ROWNS(173), - 2 RDUM1(37), EL0, H, RDUM2(6), - 3 IOWND(14), IOWNS(4), - 4 IDUM1(4), IERSL, IDUM2(5), - 5 MITER, IDUM3(4), N, IDUM4(5) -C----------------------------------------------------------------------- -C THIS ROUTINE MANAGES THE SOLUTION OF THE LINEAR SYSTEM ARISING FROM -C A CHORD ITERATION. IT IS CALLED IF MITER .NE. 0. -C IF MITER IS 1 OR 2, IT CALLS DGESL TO ACCOMPLISH THIS. -C IF MITER = 3 IT UPDATES THE COEFFICIENT H*EL0 IN THE DIAGONAL -C MATRIX, AND THEN COMPUTES THE SOLUTION. -C IF MITER IS 4 OR 5, IT CALLS DGBSL. -C COMMUNICATION WITH SOLSY USES THE FOLLOWING VARIABLES.. -C WM = REAL WORK SPACE CONTAINING THE INVERSE DIAGONAL MATRIX IF -C MITER = 3 AND THE LU DECOMPOSITION OF THE MATRIX OTHERWISE. -C STORAGE OF MATRIX ELEMENTS STARTS AT WM(3). -C WM ALSO CONTAINS THE FOLLOWING MATRIX-RELATED DATA.. -C WM(1) = SQRT(UROUND) (NOT USED HERE), -C WM(2) = HL0, THE PREVIOUS VALUE OF H*EL0, USED IF MITER = 3. -C IWM = INTEGER WORK SPACE CONTAINING PIVOT INFORMATION, STARTING AT -C IWM(21), IF MITER IS 1, 2, 4, OR 5. IWM ALSO CONTAINS BAND -C PARAMETERS ML = IWM(1) AND MU = IWM(2) IF MITER IS 4 OR 5. -C X = THE RIGHT-HAND SIDE VECTOR ON INPUT, AND THE SOLUTION VECTOR -C ON OUTPUT, OF LENGTH N. -C TEM = VECTOR OF WORK SPACE OF LENGTH N, NOT USED IN THIS VERSION. -C IERSL = OUTPUT FLAG (IN COMMON). IERSL = 0 IF NO TROUBLE OCCURRED. -C IERSL = 1 IF A SINGULAR MATRIX AROSE WITH MITER = 3. -C THIS ROUTINE ALSO USES THE COMMON VARIABLES EL0, H, MITER, AND N. -C----------------------------------------------------------------------- - IERSL = 0 - GO TO (100, 100, 300, 400, 400), MITER - 100 CALL DGESL (WM(3), N, N, IWM(21), X, 0) - RETURN -C - 300 PHL0 = WM(2) - HL0 = H*EL0 - WM(2) = HL0 - IF (HL0 .EQ. PHL0) GO TO 330 - R = HL0/PHL0 - DO 320 I = 1,N - DI = ONE - R*(ONE - ONE/WM(I+2)) - IF (ABS(DI) .EQ. ZERO) GO TO 390 - 320 WM(I+2) = ONE/DI - 330 DO 340 I = 1,N - 340 X(I) = WM(I+2)*X(I) - RETURN - 390 IERSL = 1 - RETURN -C - 400 ML = IWM(1) - MU = IWM(2) - MEBAND = 2*ML + MU + 1 - CALL DGBSL (WM(3), MEBAND, N, ML, MU, IWM(21), X, 0) - RETURN -C----------------------- END OF SUBROUTINE SOLSY ----------------------- - END - SUBROUTINE EWSET (N, ITOL, RTOL, ATOL, YCUR, EWT) -C----------------------------------------------------------------------- -C THIS SUBROUTINE SETS THE ERROR WEIGHT VECTOR EWT ACCORDING TO -C EWT(I) = RTOL(I)*ABS(YCUR(I)) + ATOL(I), I = 1,...,N, -C WITH THE SUBSCRIPT ON RTOL AND/OR ATOL POSSIBLY REPLACED BY 1 ABOVE, -C DEPENDING ON THE VALUE OF ITOL. -C----------------------------------------------------------------------- - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - DIMENSION RTOL(*), ATOL(*), YCUR(N), EWT(N) - RTOLI = RTOL(1) - ATOLI = ATOL(1) - DO 10 I = 1,N - IF (ITOL .GE. 3) RTOLI = RTOL(I) - IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) - EWT(I) = RTOLI*ABS(YCUR(I)) + ATOLI - 10 CONTINUE - RETURN -C----------------------- END OF SUBROUTINE EWSET ----------------------- - END - DOUBLE PRECISION FUNCTION VNORM (N, V, W) -C----------------------------------------------------------------------- -C THIS FUNCTION ROUTINE COMPUTES THE WEIGHTED ROOT-MEAN-SQUARE NORM -C OF THE VECTOR OF LENGTH N CONTAINED IN THE ARRAY V, WITH WEIGHTS -C CONTAINED IN THE ARRAY W OF LENGTH N.. -C VNORM = SQRT( (1/N) * SUM( V(I)*W(I) )**2 ) -C PROTECTION FOR UNDERFLOW/OVERFLOW IS ACCOMPLISHED USING TWO -C CONSTANTS WHICH ARE HOPEFULLY APPLICABLE FOR ALL MACHINES. -C THESE ARE: -C CUTLO = maximum of SQRT(U/EPS) over all known machines -C CUTHI = minimum of SQRT(Z) over all known machines -C WHERE -C EPS = smallest number s.t. EPS + 1 .GT. 1 -C U = smallest positive number (underflow limit) -C Z = largest number (overflow limit) -C -C DETAILS OF THE ALGORITHM AND OF VALUES OF CUTLO AND CUTHI ARE -C FOUND IN THE BLAS ROUTINE SNRM2 (SEE ALSO ALGORITHM 539, TRANS. -C MATH. SOFTWARE, VOL. 5 NO. 3, 1979, 308-323. -C FOR SINGLE PRECISION, THE FOLLOWING VALUES SHOULD BE UNIVERSAL: -C DATA CUTLO,CUTHI /4.441E-16,1.304E19/ -C FOR DOUBLE PRECISION, USE -C DATA CUTLO,CUTHI /8.232D-11,1.304D19/ -C -C----------------------------------------------------------------------- - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - INTEGER NEXT,I,J,N - DIMENSION V(N),W(N) - DATA CUTLO,CUTHI /8.232D-11,1.304D19/ - DATA ZERO,ONE/0.0D0,1.0D0/ -C BLAS ALGORITHM - NEXT = 1 - SUM = ZERO - I = 1 -20 SX = V(I)*W(I) - GO TO (30,40,70,80),NEXT -30 IF (ABS(SX).GT.CUTLO) GO TO 110 - NEXT = 2 - XMAX = ZERO -40 IF (SX.EQ.ZERO) GO TO 130 - IF (ABS(SX).GT.CUTLO) GO TO 110 - NEXT = 3 - GO TO 60 -50 I=J - NEXT = 4 - SUM = (SUM/SX)/SX -60 XMAX = ABS(SX) - GO TO 90 -70 IF(ABS(SX).GT.CUTLO) GO TO 100 -80 IF(ABS(SX).LE.XMAX) GO TO 90 - SUM = ONE + SUM * (XMAX/SX)**2 - XMAX = ABS(SX) - GO TO 130 -90 SUM = SUM + (SX/XMAX)**2 - GO TO 130 -100 SUM = (SUM*XMAX)*XMAX -110 HITEST = CUTHI/REAL(N) - DO 120 J = I,N - SX = V(J)*W(J) - IF(ABS(SX).GE.HITEST) GO TO 50 - SUM = SUM + SX**2 -120 CONTINUE - VNORM = SQRT(SUM) - GO TO 140 -130 CONTINUE - I = I + 1 - IF (I.LE.N) GO TO 20 - VNORM = XMAX * SQRT(SUM) -140 CONTINUE - RETURN -C----------------------- END OF FUNCTION VNORM ------------------------- - END - SUBROUTINE SVCOM (RSAV, ISAV) -C----------------------------------------------------------------------- -C THIS ROUTINE STORES IN RSAV AND ISAV THE CONTENTS OF COMMON BLOCKS -C ODE001, ODE002 AND EH0001, WHICH ARE USED INTERNALLY IN THE ODESSA -C PACKAGE. -C RSAV = REAL ARRAY OF LENGTH 222 OR MORE. -C ISAV = INTEGER ARRAY OF LENGTH 52 OR MORE. -C----------------------------------------------------------------------- - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - DIMENSION RSAV(*), ISAV(*) - COMMON /ODE001/ RODE1(219), IODE1(39) - COMMON /ODE002/ RODE2(3), IODE2(11) - COMMON /EH0001/ IEH(2) - DATA LRODE1/219/, LIODE1/39/, LRODE2/3/, LIODE2/11/ -C - DO 10 I = 1,LRODE1 - 10 RSAV(I) = RODE1(I) - DO 20 I = 1,LRODE2 - J = LRODE1 + I - 20 RSAV(J) = RODE2(I) - DO 30 I = 1,LIODE1 - 30 ISAV(I) = IODE1(I) - DO 40 I = 1,LIODE2 - J = LIODE1 + I - 40 ISAV(J) = IODE2(I) - ISAV(LIODE1+LIODE2+1) = IEH(1) - ISAV(LIODE1+LIODE2+2) = IEH(2) - RETURN -C----------------------- END OF SUBROUTINE SVCOM ----------------------- - END - SUBROUTINE RSCOM (RSAV, ISAV) -C----------------------------------------------------------------------- -C THIS ROUTINE RESTORES FROM RSAV AND ISAV THE CONTENTS OF COMMON BLOCKS -C ODE001, ODE002 AND EH0001, WHICH ARE USED INTERNALLY IN THE ODESSSA -C PACKAGE. THIS PRESUMES THAT RSAV AND ISAV WERE LOADED BY MEANS -C OF SUBROUTINE SVCOM OR THE EQUIVALENT. -C----------------------------------------------------------------------- - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - DIMENSION RSAV(*), ISAV(*) - COMMON /ODE001/ RODE1(219), IODE1(39) - COMMON /ODE002/ RODE2(3), IODE2(11) - COMMON /EH0001/ IEH(2) - DATA LRODE1/219/, LIODE1/39/, LRODE2/3/, LIODE2/11/ -C - DO 10 I = 1,LRODE1 - 10 RODE1(I) = RSAV(I) - DO 20 I = 1,LRODE2 - J = LRODE1 + I - 20 RODE2(I) = RSAV(J) - DO 30 I = 1,LIODE1 - 30 IODE1(I) = ISAV(I) - DO 40 I = 1,LODE2 - J = LIODE1 + I - 40 IODE2(I) = ISAV(J) - IEH(1) = ISAV(LIODE1+LIODE2+1) - IEH(2) = ISAV(LIODE1+LIODE2+2) - RETURN -C----------------------- END OF SUBROUTINE RSCOM ----------------------- - END - SUBROUTINE DGEFA(A,LDA,N,IPVT,INFO) - INTEGER LDA,N,IPVT(*),INFO - DOUBLE PRECISION A(LDA,*) -C -C DGEFA FACTORS A DOUBLE PRECISION MATRIX BY GAUSSIAN ELIMINATION. -C -C DGEFA IS USUALLY CALLED BY DGECO, BUT IT CAN BE CALLED -C DIRECTLY WITH A SAVING IN TIME IF RCOND IS NOT NEEDED. -C (TIME FOR DGECO) = (1 + 9/N)*(TIME FOR DGEFA) . -C -C ON ENTRY -C -C A DOUBLE PRECISION(LDA, N) -C THE MATRIX TO BE FACTORED. -C -C LDA INTEGER -C THE LEADING DIMENSION OF THE ARRAY A . -C -C N INTEGER -C THE ORDER OF THE MATRIX A . -C -C ON RETURN -C -C A AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS -C WHICH WERE USED TO OBTAIN IT. -C THE FACTORIZATION CAN BE WRITTEN A = L*U WHERE -C L IS A PRODUCT OF PERMUTATION AND UNIT LOWER -C TRIANGULAR MATRICES AND U IS UPPER TRIANGULAR. -C -C IPVT INTEGER(N) -C AN INTEGER VECTOR OF PIVOT INDICES. -C -C INFO INTEGER -C = 0 NORMAL VALUE. -C = K IF U(K,K) .EQ. 0.0 . THIS IS NOT AN ERROR -C CONDITION FOR THIS SUBROUTINE, BUT IT DOES -C INDICATE THAT DGESL OR DGEDI WILL DIVIDE BY ZERO -C IF CALLED. USE RCOND IN DGECO FOR A RELIABLE -C INDICATION OF SINGULARITY. -C -C LINPACK. THIS VERSION DATED 08/14/78 . -C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. -C -C SUBROUTINES AND FUNCTIONS -C -C BLAS DAXPY,DSCAL,IDAMAX -C -C INTERNAL VARIABLES -C - DOUBLE PRECISION T - INTEGER IDAMAX,J,K,KP1,L,NM1 -C -C -C GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING -C - INFO = 0 - NM1 = N - 1 - IF (NM1 .LT. 1) GO TO 70 - DO 60 K = 1, NM1 - KP1 = K + 1 -C -C FIND L = PIVOT INDEX -C - L = IDAMAX(N-K+1,A(K,K),1) + K - 1 - IPVT(K) = L -C -C ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED -C - IF (A(L,K) .EQ. 0.0D0) GO TO 40 -C -C INTERCHANGE IF NECESSARY -C - IF (L .EQ. K) GO TO 10 - T = A(L,K) - A(L,K) = A(K,K) - A(K,K) = T - 10 CONTINUE -C -C COMPUTE MULTIPLIERS -C - T = -1.0D0/A(K,K) - CALL DSCAL(N-K,T,A(K+1,K),1) -C -C ROW ELIMINATION WITH COLUMN INDEXING -C - DO 30 J = KP1, N - T = A(L,J) - IF (L .EQ. K) GO TO 20 - A(L,J) = A(K,J) - A(K,J) = T - 20 CONTINUE - CALL DAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1) - 30 CONTINUE - GO TO 50 - 40 CONTINUE - INFO = K - 50 CONTINUE - 60 CONTINUE - 70 CONTINUE - IPVT(N) = N - IF (A(N,N) .EQ. 0.0D0) INFO = N - RETURN - END - SUBROUTINE DGESL(A,LDA,N,IPVT,B,JOB) - INTEGER LDA,N,IPVT(*),JOB - DOUBLE PRECISION A(LDA,*),B(*) -C -C DGESL KppSolveS THE DOUBLE PRECISION SYSTEM -C A * X = B OR TRANS(A) * X = B -C USING THE FACTORS COMPUTED BY DGECO OR DGEFA. -C -C ON ENTRY -C -C A DOUBLE PRECISION(LDA, N) -C THE OUTPUT FROM DGECO OR DGEFA. -C -C LDA INTEGER -C THE LEADING DIMENSION OF THE ARRAY A . -C -C N INTEGER -C THE ORDER OF THE MATRIX A . -C -C IPVT INTEGER(N) -C THE PIVOT VECTOR FROM DGECO OR DGEFA. -C -C B DOUBLE PRECISION(N) -C THE RIGHT HAND SIDE VECTOR. -C -C JOB INTEGER -C = 0 TO KppSolve A*X = B , -C = NONZERO TO KppSolve TRANS(A)*X = B WHERE -C TRANS(A) IS THE TRANSPOSE. -C -C ON RETURN -C -C B THE SOLUTION VECTOR X . -C -C ERROR CONDITION -C -C A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A -C ZERO ON THE DIAGONAL. TECHNICALLY THIS INDICATES SINGULARITY -C BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER -C SETTING OF LDA . IT WILL NOT OCCUR IF THE SUBROUTINES ARE -C CALLED CORRECTLY AND IF DGECO HAS SET RCOND .GT. 0.0 -C OR DGEFA HAS SET INFO .EQ. 0 . -C -C TO COMPUTE INVERSE(A) * C WHERE C IS A MATRIX -C WITH P COLUMNS -C CALL DGECO(A,LDA,N,IPVT,RCOND,Z) -C IF (RCOND IS TOO SMALL) GO TO ... -C DO 10 J = 1, P -C CALL DGESL(A,LDA,N,IPVT,C(1,J),0) -C 10 CONTINUE -C -C LINPACK. THIS VERSION DATED 08/14/78 . -C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. -C -C SUBROUTINES AND FUNCTIONS -C -C BLAS DAXPY,DDOT -C -C INTERNAL VARIABLES -C - DOUBLE PRECISION DDOT,T - INTEGER K,KB,L,NM1 -C - NM1 = N - 1 - IF (JOB .NE. 0) GO TO 50 -C -C JOB = 0 , KppSolve A * X = B -C FIRST KppSolve L*Y = B -C - IF (NM1 .LT. 1) GO TO 30 - DO 20 K = 1, NM1 - L = IPVT(K) - T = B(L) - IF (L .EQ. K) GO TO 10 - B(L) = B(K) - B(K) = T - 10 CONTINUE - CALL DAXPY(N-K,T,A(K+1,K),1,B(K+1),1) - 20 CONTINUE - 30 CONTINUE -C -C NOW KppSolve U*X = Y -C - DO 40 KB = 1, N - K = N + 1 - KB - B(K) = B(K)/A(K,K) - T = -B(K) - CALL DAXPY(K-1,T,A(1,K),1,B(1),1) - 40 CONTINUE - GO TO 100 - 50 CONTINUE -C -C JOB = NONZERO, KppSolve TRANS(A) * X = B -C FIRST KppSolve TRANS(U)*Y = B -C - DO 60 K = 1, N - T = DDOT(K-1,A(1,K),1,B(1),1) - B(K) = (B(K) - T)/A(K,K) - 60 CONTINUE -C -C NOW KppSolve TRANS(L)*X = Y -C - IF (NM1 .LT. 1) GO TO 90 - DO 80 KB = 1, NM1 - K = N - KB - B(K) = B(K) + DDOT(N-K,A(K+1,K),1,B(K+1),1) - L = IPVT(K) - IF (L .EQ. K) GO TO 70 - T = B(L) - B(L) = B(K) - B(K) = T - 70 CONTINUE - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE - RETURN - END - SUBROUTINE DGBFA(ABD,LDA,N,ML,MU,IPVT,INFO) - INTEGER LDA,N,ML,MU,IPVT(*),INFO - DOUBLE PRECISION ABD(LDA,*) -C -C DGBFA FACTORS A DOUBLE PRECISION BAND MATRIX BY ELIMINATION. -C -C DGBFA IS USUALLY CALLED BY DGBCO, BUT IT CAN BE CALLED -C DIRECTLY WITH A SAVING IN TIME IF RCOND IS NOT NEEDED. -C -C ON ENTRY -C -C ABD DOUBLE PRECISION(LDA, N) -C CONTAINS THE MATRIX IN BAND STORAGE. THE COLUMNS -C OF THE MATRIX ARE STORED IN THE COLUMNS OF ABD AND -C THE DIAGONALS OF THE MATRIX ARE STORED IN ROWS -C ML+1 THROUGH 2*ML+MU+1 OF ABD . -C SEE THE COMMENTS BELOW FOR DETAILS. -C -C LDA INTEGER -C THE LEADING DIMENSION OF THE ARRAY ABD . -C LDA MUST BE .GE. 2*ML + MU + 1 . -C -C N INTEGER -C THE ORDER OF THE ORIGINAL MATRIX. -C -C ML INTEGER -C NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL. -C 0 .LE. ML .LT. N . -C -C MU INTEGER -C NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL. -C 0 .LE. MU .LT. N . -C MORE EFFICIENT IF ML .LE. MU . -C ON RETURN -C -C ABD AN UPPER TRIANGULAR MATRIX IN BAND STORAGE AND -C THE MULTIPLIERS WHICH WERE USED TO OBTAIN IT. -C THE FACTORIZATION CAN BE WRITTEN A = L*U WHERE -C L IS A PRODUCT OF PERMUTATION AND UNIT LOWER -C TRIANGULAR MATRICES AND U IS UPPER TRIANGULAR. -C -C IPVT INTEGER(N) -C AN INTEGER VECTOR OF PIVOT INDICES. -C -C INFO INTEGER -C = 0 NORMAL VALUE. -C = K IF U(K,K) .EQ. 0.0 . THIS IS NOT AN ERROR -C CONDITION FOR THIS SUBROUTINE, BUT IT DOES -C INDICATE THAT DGBSL WILL DIVIDE BY ZERO IF -C CALLED. USE RCOND IN DGBCO FOR A RELIABLE -C INDICATION OF SINGULARITY. -C -C BAND STORAGE -C -C IF A IS A BAND MATRIX, THE FOLLOWING PROGRAM SEGMENT -C WILL SET UP THE INPUT. -C -C ML = (BAND WIDTH BELOW THE DIAGONAL) -C MU = (BAND WIDTH ABOVE THE DIAGONAL) -C M = ML + MU + 1 -C DO 20 J = 1, N -C I1 = MAX0(1, J-MU) -C I2 = MIN0(N, J+ML) -C DO 10 I = I1, I2 -C K = I - J + M -C ABD(K,J) = A(I,J) -C 10 CONTINUE -C 20 CONTINUE -C -C THIS USES ROWS ML+1 THROUGH 2*ML+MU+1 OF ABD . -C IN ADDITION, THE FIRST ML ROWS IN ABD ARE USED FOR -C ELEMENTS GENERATED DURING THE TRIANGULARIZATION. -C THE TOTAL NUMBER OF ROWS NEEDED IN ABD IS 2*ML+MU+1 . -C THE ML+MU BY ML+MU UPPER LEFT TRIANGLE AND THE -C ML BY ML LOWER RIGHT TRIANGLE ARE NOT REFERENCED. -C -C LINPACK. THIS VERSION DATED 08/14/78 . -C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. -C -C SUBROUTINES AND FUNCTIONS -C -C BLAS DAXPY,DSCAL,IDAMAX -C FORTRAN MAX0,MIN0 -C -C INTERNAL VARIABLES -C - DOUBLE PRECISION T - INTEGER I,IDAMAX,I0,J,JU,JZ,J0,J1,K,KP1,L,LM,M,MM,NM1 -C -C - M = ML + MU + 1 - INFO = 0 -C -C ZERO INITIAL FILL-IN COLUMNS -C - J0 = MU + 2 - J1 = MIN0(N,M) - 1 - IF (J1 .LT. J0) GO TO 30 - DO 20 JZ = J0, J1 - I0 = M + 1 - JZ - DO 10 I = I0, ML - ABD(I,JZ) = 0.0D0 - 10 CONTINUE - 20 CONTINUE - 30 CONTINUE - JZ = J1 - JU = 0 -C -C GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING -C - NM1 = N - 1 - IF (NM1 .LT. 1) GO TO 130 - DO 120 K = 1, NM1 - KP1 = K + 1 -C -C ZERO NEXT FILL-IN COLUMN -C - JZ = JZ + 1 - IF (JZ .GT. N) GO TO 50 - IF (ML .LT. 1) GO TO 50 - DO 40 I = 1, ML - ABD(I,JZ) = 0.0D0 - 40 CONTINUE - 50 CONTINUE -C -C FIND L = PIVOT INDEX -C - LM = MIN0(ML,N-K) - L = IDAMAX(LM+1,ABD(M,K),1) + M - 1 - IPVT(K) = L + K - M -C -C ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED -C - IF (ABD(L,K) .EQ. 0.0D0) GO TO 100 -C -C INTERCHANGE IF NECESSARY -C - IF (L .EQ. M) GO TO 60 - T = ABD(L,K) - ABD(L,K) = ABD(M,K) - ABD(M,K) = T - 60 CONTINUE -C -C COMPUTE MULTIPLIERS -C - T = -1.0D0/ABD(M,K) - CALL DSCAL(LM,T,ABD(M+1,K),1) -C -C ROW ELIMINATION WITH COLUMN INDEXING -C - JU = MIN0(MAX0(JU,MU+IPVT(K)),N) - MM = M - IF (JU .LT. KP1) GO TO 90 - DO 80 J = KP1, JU - L = L - 1 - MM = MM - 1 - T = ABD(L,J) - IF (L .EQ. MM) GO TO 70 - ABD(L,J) = ABD(MM,J) - ABD(MM,J) = T - 70 CONTINUE - CALL DAXPY(LM,T,ABD(M+1,K),1,ABD(MM+1,J),1) - 80 CONTINUE - 90 CONTINUE - GO TO 110 - 100 CONTINUE - INFO = K - 110 CONTINUE - 120 CONTINUE - 130 CONTINUE - IPVT(N) = N - IF (ABD(M,N) .EQ. 0.0D0) INFO = N - RETURN - END - SUBROUTINE DGBSL(ABD,LDA,N,ML,MU,IPVT,B,JOB) - INTEGER LDA,N,ML,MU,IPVT(*),JOB - DOUBLE PRECISION ABD(LDA,*),B(*) -C -C DGBSL KppSolveS THE DOUBLE PRECISION BAND SYSTEM -C A * X = B OR TRANS(A) * X = B -C USING THE FACTORS COMPUTED BY DGBCO OR DGBFA. -C -C ON ENTRY -C -C ABD DOUBLE PRECISION(LDA, N) -C THE OUTPUT FROM DGBCO OR DGBFA. -C -C LDA INTEGER -C THE LEADING DIMENSION OF THE ARRAY ABD . -C -C N INTEGER -C THE ORDER OF THE ORIGINAL MATRIX. -C -C ML INTEGER -C NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL. -C -C MU INTEGER -C NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL. -C -C IPVT INTEGER(N) -C THE PIVOT VECTOR FROM DGBCO OR DGBFA. -C -C B DOUBLE PRECISION(N) -C THE RIGHT HAND SIDE VECTOR. -C -C JOB INTEGER -C = 0 TO KppSolve A*X = B , -C = NONZERO TO KppSolve TRANS(A)*X = B , WHERE -C TRANS(A) IS THE TRANSPOSE. -C -C ON RETURN -C -C B THE SOLUTION VECTOR X . -C -C ERROR CONDITION -C -C A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A -C ZERO ON THE DIAGONAL. TECHNICALLY THIS INDICATES SINGULARITY -C BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER -C SETTING OF LDA . IT WILL NOT OCCUR IF THE SUBROUTINES ARE -C CALLED CORRECTLY AND IF DGBCO HAS SET RCOND .GT. 0.0 -C OR DGBFA HAS SET INFO .EQ. 0 . -C -C TO COMPUTE INVERSE(A) * C WHERE C IS A MATRIX -C WITH P COLUMNS -C CALL DGBCO(ABD,LDA,N,ML,MU,IPVT,RCOND,Z) -C IF (RCOND IS TOO SMALL) GO TO ... -C DO 10 J = 1, P -C CALL DGBSL(ABD,LDA,N,ML,MU,IPVT,C(1,J),0) -C 10 CONTINUE -C -C LINPACK. THIS VERSION DATED 08/14/78 . -C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. -C -C SUBROUTINES AND FUNCTIONS -C -C BLAS DAXPY,DDOT -C FORTRAN MIN0 -C -C INTERNAL VARIABLES -C - DOUBLE PRECISION DDOT,T - INTEGER K,KB,L,LA,LB,LM,M,NM1 -C - M = MU + ML + 1 - NM1 = N - 1 - IF (JOB .NE. 0) GO TO 50 -C -C JOB = 0 , KppSolve A * X = B -C FIRST KppSolve L*Y = B -C - IF (ML .EQ. 0) GO TO 30 - IF (NM1 .LT. 1) GO TO 30 - DO 20 K = 1, NM1 - LM = MIN0(ML,N-K) - L = IPVT(K) - T = B(L) - IF (L .EQ. K) GO TO 10 - B(L) = B(K) - B(K) = T - 10 CONTINUE - CALL DAXPY(LM,T,ABD(M+1,K),1,B(K+1),1) - 20 CONTINUE - 30 CONTINUE -C -C NOW KppSolve U*X = Y -C - DO 40 KB = 1, N - K = N + 1 - KB - B(K) = B(K)/ABD(M,K) - LM = MIN0(K,M) - 1 - LA = M - LM - LB = K - LM - T = -B(K) - CALL DAXPY(LM,T,ABD(LA,K),1,B(LB),1) - 40 CONTINUE - GO TO 100 - 50 CONTINUE -C -C JOB = NONZERO, KppSolve TRANS(A) * X = B -C FIRST KppSolve TRANS(U)*Y = B -C - DO 60 K = 1, N - LM = MIN0(K,M) - 1 - LA = M - LM - LB = K - LM - T = DDOT(LM,ABD(LA,K),1,B(LB),1) - B(K) = (B(K) - T)/ABD(M,K) - 60 CONTINUE -C -C NOW KppSolve TRANS(L)*X = Y -C - IF (ML .EQ. 0) GO TO 90 - IF (NM1 .LT. 1) GO TO 90 - DO 80 KB = 1, NM1 - K = N - KB - LM = MIN0(ML,N-K) - B(K) = B(K) + DDOT(LM,ABD(M+1,K),1,B(K+1),1) - L = IPVT(K) - IF (L .EQ. K) GO TO 70 - T = B(L) - B(L) = B(K) - B(K) = T - 70 CONTINUE - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE - RETURN - END - SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) -C -C CONSTANT TIMES A VECTOR PLUS A VECTOR. -C USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE. -C JACK DONGARRA, LINPACK, 3/11/78. -C - DOUBLE PRECISION DX(*),DY(*),DA - INTEGER I,INCX,INCY,IX,IY,M,MP1,N -C - IF(N.LE.0)RETURN - IF (DA .EQ. 0.0D0) RETURN - IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 -C -C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS -C NOT EQUAL TO 1 -C - IX = 1 - IY = 1 - IF(INCX.LT.0)IX = (-N+1)*INCX + 1 - IF(INCY.LT.0)IY = (-N+1)*INCY + 1 - DO 10 I = 1,N - DY(IY) = DY(IY) + DA*DX(IX) - IX = IX + INCX - IY = IY + INCY - 10 CONTINUE - RETURN -C -C CODE FOR BOTH INCREMENTS EQUAL TO 1 -C -C -C CLEAN-UP LOOP -C - 20 M = MOD(N,4) - IF( M .EQ. 0 ) GO TO 40 - DO 30 I = 1,M - DY(I) = DY(I) + DA*DX(I) - 30 CONTINUE - IF( N .LT. 4 ) RETURN - 40 MP1 = M + 1 - DO 50 I = MP1,N,4 - DY(I) = DY(I) + DA*DX(I) - DY(I + 1) = DY(I + 1) + DA*DX(I + 1) - DY(I + 2) = DY(I + 2) + DA*DX(I + 2) - DY(I + 3) = DY(I + 3) + DA*DX(I + 3) - 50 CONTINUE - RETURN - END - SUBROUTINE DSCAL(N,DA,DX,INCX) -C -C SCALES A VECTOR BY A CONSTANT. -C USES UNROLLED LOOPS FOR INCREMENT EQUAL TO ONE. -C JACK DONGARRA, LINPACK, 3/11/78. -C - DOUBLE PRECISION DA,DX(*) - INTEGER I,INCX,M,MP1,N,NINCX -C - IF(N.LE.0)RETURN - IF(INCX.EQ.1)GO TO 20 -C -C CODE FOR INCREMENT NOT EQUAL TO 1 -* -C - NINCX = N*INCX - DO 10 I = 1,NINCX,INCX - DX(I) = DA*DX(I) - 10 CONTINUE - RETURN -C -C CODE FOR INCREMENT EQUAL TO 1 -C -C -C CLEAN-UP LOOP -C - 20 M = MOD(N,5) - IF( M .EQ. 0 ) GO TO 40 - DO 30 I = 1,M - DX(I) = DA*DX(I) - 30 CONTINUE - IF( N .LT. 5 ) RETURN - 40 MP1 = M + 1 - DO 50 I = MP1,N,5 - DX(I) = DA*DX(I) - DX(I + 1) = DA*DX(I + 1) - DX(I + 2) = DA*DX(I + 2) - DX(I + 3) = DA*DX(I + 3) - DX(I + 4) = DA*DX(I + 4) - 50 CONTINUE - RETURN - END - DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) -C -C FORMS THE DOT PRODUCT OF TWO VECTORS. -C USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE. -C JACK DONGARRA, LINPACK, 3/11/78. -C - DOUBLE PRECISION DX(*),DY(*),DTEMP - INTEGER I,INCX,INCY,IX,IY,M,MP1,N -C - DDOT = 0.0D0 - DTEMP = 0.0D0 - IF(N.LE.0)RETURN - IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 -C -C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS -C NOT EQUAL TO 1 -C - IX = 1 - IY = 1 - IF(INCX.LT.0)IX = (-N+1)*INCX + 1 - IF(INCY.LT.0)IY = (-N+1)*INCY + 1 - DO 10 I = 1,N - DTEMP = DTEMP + DX(IX)*DY(IY) - IX = IX + INCX - IY = IY + INCY - 10 CONTINUE - DDOT = DTEMP - RETURN -C -C CODE FOR BOTH INCREMENTS EQUAL TO 1 -C -C -C CLEAN-UP LOOP -C - 20 M = MOD(N,5) - IF( M .EQ. 0 ) GO TO 40 - DO 30 I = 1,M - DTEMP = DTEMP + DX(I)*DY(I) - 30 CONTINUE - IF( N .LT. 5 ) GO TO 60 - 40 MP1 = M + 1 - DO 50 I = MP1,N,5 - DTEMP = DTEMP + DX(I)*DY(I) + DX(I + 1)*DY(I + 1) + - * DX(I + 2)*DY(I + 2) + DX(I + 3)*DY(I + 3) + DX(I + 4)*DY(I + 4) - 50 CONTINUE - 60 DDOT = DTEMP - RETURN - END - INTEGER FUNCTION IDAMAX(N,DX,INCX) -C -C FINDS THE INDEX OF ELEMENT HAVING MAX. ABSOLUTE VALUE. -C JACK DONGARRA, LINPACK, 3/11/78. -C - DOUBLE PRECISION DX(*),DMAX - INTEGER I,INCX,IX,N -C - IDAMAX = 0 - IF( N .LT. 1 ) RETURN - IDAMAX = 1 - IF(N.EQ.1)RETURN - IF(INCX.EQ.1)GO TO 20 -C -C CODE FOR INCREMENT NOT EQUAL TO 1 -C - IX = 1 - DMAX = DABS(DX(1)) - IX = IX + INCX - DO 10 I = 2,N - IF(DABS(DX(IX)).LE.DMAX) GO TO 5 - IDAMAX = I - DMAX = DABS(DX(IX)) - 5 IX = IX + INCX - 10 CONTINUE - RETURN -C -C CODE FOR INCREMENT EQUAL TO 1 -C - 20 DMAX = DABS(DX(1)) - DO 30 I = 2,N - IF(DABS(DX(I)).LE.DMAX) GO TO 30 - IDAMAX = I - DMAX = DABS(DX(I)) - 30 CONTINUE - RETURN - END - DOUBLE PRECISION FUNCTION D1MACH (IDUM) - INTEGER IDUM -C----------------------------------------------------------------------- -C THIS ROUTINE COMPUTES THE UNIT ROUNDOFF OF THE MACHINE IN DOUBLE -C PRECISION. THIS IS DEFINED AS THE SMALLEST POSITIVE MACHINE NUMBER -C U SUCH THAT 1.0D0 + U .NE. 1.0D0 (IN DOUBLE PRECISION). -C----------------------------------------------------------------------- - DOUBLE PRECISION U, COMP - U = 1.0D0 - 10 U = U*0.5D0 - COMP = 1.0D0 + U - IF (COMP .NE. 1.0D0) GO TO 10 - D1MACH = U*2.0D0 - RETURN -C----------------------- END OF FUNCTION D1MACH ------------------------ - END - SUBROUTINE XERR (MSG, NERR, IERT, NI, I1, I2, NR, R1, R2) - INTEGER NERR, IERT, NI, I1, I2, NR, - 1 LUN, LUNIT, MESFLG - DOUBLE PRECISION R1, R2 - CHARACTER*(*) MSG -C------------------------------------------------------------------- -C -C ALL ARGUMENTS ARE INPUT ARGUMENTS. -C -C MSG = THE MESSAGE (CHARACTER VARIABLE) -C NERR = THE ERROR NUMBER (NOT USED). -C IERT = THE ERROR TYPE.. -C 1 MEANS RECOVERABLE (CONTROL RETURNS TO CALLER). -C 2 MEANS FATAL (RUN IS ABORTED--SEE NOTE BELOW). -C NI = NUMBER OF INTEGERS (0, 1, OR 2) TO BE PRINTED WITH MESSAGE. -C I1,I2 = INTEGERS TO BE PRINTED, DEPENDING ON NI. -C NR = NUMBER OF REALS (0, 1, OR 2) TO BE PRINTED WITH MESSAGE. -C R1,R2 = REALS TO BE PRINTED, DEPENDING ON NR. -C -C NOTES: -C 1. THE DIMENSION OF MSG IS ASSUMED TO BE AT MOST 60. -C (MULTI-LINE MESSAGES ARE GENERATED BY REPEATED CALLS.) -C 2. IF IERT = 2, CONTROL PASSES TO THE STATEMENT STOP -C TO ABORT THE RUN. THIS STATEMENT MAY BE MACHINE-DEPENDENT. -C 3. R1 AND R2 ARE ASSUMED TO BE IN DOUBLE PRECISION AND ARE PRINTED -C IN D21.13 FORMAT. -C 4. THE COMMON BLOCK /EH0001/ BELOW IS DATA-LOADED (A MACHINE- -C DEPENDENT FEATURE) WITH DEFAULT VALUES. -C THIS BLOCK IS NEEDED FOR PROPER RETENTION OF PARAMETERS USED BY -C THIS ROUTINE WHICH THE USER CAN RESET BY CALLING XSETF OR XSETUN. -C THE VARIABLES IN THIS BLOCK ARE AS FOLLOWS.. -C MESFLG = PRINT CONTROL FLAG.. -C 1 MEANS PRINT ALL MESSAGES (THE DEFAULT). -C 0 MEANS NO PRINTING. -C LUNIT = LOGICAL UNIT NUMBER FOR MESSAGES. -C THE DEFAULT IS 6 (MACHINE-DEPENDENT). -C 5. TO CHANGE THE DEFAULT OUTPUT UNIT, CHANGE THE DATA STATEMENT -C IN THE BLOCK DATA SUBPROGRAM BELOW. -C -C FOR A DIFFERENT RUN-ABORT COMMAND, CHANGE THE STATEMENT FOLLOWING -C STATEMENT 100 AT THE END. -C----------------------------------------------------------------------- - COMMON /EH0001/ MESFLG, LUNIT - IF (MESFLG .EQ. 0) GO TO 100 -C GET LOGICAL UNIT NUMBER. --------------------------------------------- - LUN = LUNIT -C WRITE THE MESSAGE. --------------------------------------------------- - WRITE (LUN, 10) MSG - 10 FORMAT(1X,A) -C----------------------------------------------------------------------- - IF (NI .EQ. 1) WRITE (LUN, 20) I1 - 20 FORMAT(6X,'IN ABOVE MESSAGE, I1 = ',I10) - IF (NI .EQ. 2) WRITE (LUN, 30) I1,I2 - 30 FORMAT(6X,'IN ABOVE MESSAGE, I1 = ',I10,3X,'I2 = ',I10) - IF (NR .EQ. 1) WRITE (LUN, 40) R1 - 40 FORMAT(6X,'IN ABOVE MESSAGE, R1 = ',D21.13) - IF (NR .EQ. 2) WRITE (LUN, 50) R1,R2 - 50 FORMAT(6X,'IN ABOVE, R1 = ',D21.13,3X,'R2 = ',D21.13) -C ABORT THE RUN IF IERT = 2. ------------------------------------------- - 100 IF (IERT .NE. 2) RETURN - STOP -C----------------------- END OF SUBROUTINE XERR ---------------------- - END - SUBROUTINE XSETF (MFLAG) -C -C THIS ROUTINE RESETS THE PRINT CONTROL FLAG MFLAG. -C - INTEGER MFLAG, MESFLG, LUNIT - COMMON /EH0001/ MESFLG, LUNIT -C - IF (MFLAG .EQ. 0 .OR. MFLAG .EQ. 1) MESFLG = MFLAG - RETURN -C----------------------- END OF SUBROUTINE XSETF ----------------------- - END - SUBROUTINE XSETUN (LUN) -C -C THIS ROUTINE RESETS THE LOGICAL UNIT NUMBER FOR MESSAGES. -C - INTEGER LUN, MESFLG, LUNIT - COMMON /EH0001/ MESFLG, LUNIT -C - IF (LUN .GT. 0) LUNIT = LUN - RETURN -C----------------------- END OF SUBROUTINE XSETUN ---------------------- - END - BLOCK DATA -C----------------------------------------------------------------------- -C THIS DATA SUBPROGRAM LOADS VARIABLES INTO THE INTERNAL COMMON -C BLOCKS USED BY ODESSA AND ITS VARIANTS. THE VARIABLES ARE -C DEFINED AS FOLLOWS.. -C ILLIN = COUNTER FOR THE NUMBER OF CONSECUTIVE TIMES THE PACKAGE -C WAS CALLED WITH ILLEGAL INPUT. THE RUN IS STOPPED WHEN -C ILLIN REACHES 5. -C NTREP = COUNTER FOR THE NUMBER OF CONSECUTIVE TIMES THE PACKAGE -C WAS CALLED WITH ISTATE = 1 AND TOUT = T. THE RUN IS -C STOPPED WHEN NTREP REACHES 5. -C MESFLG = FLAG TO CONTROL PRINTING OF ERROR MESSAGES. 1 MEANS PRINT, -C 0 MEANS NO PRINTING. -C LUNIT = DEFAULT VALUE OF LOGICAL UNIT NUMBER FOR PRINTING OF ERROR -C MESSAGES. -C----------------------------------------------------------------------- - INTEGER ILLIN, IDUMA, NTREP, IDUMB, IOWNS, ICOMM, MESFLG, LUNIT - DOUBLE PRECISION ROWND, ROWNS, RCOMM - COMMON /ODE001/ ROWND, ROWNS(173), RCOMM(45), - 1 ILLIN, IDUMA(10), NTREP, IDUMB(2), IOWNS(4), ICOMM(21) - COMMON /EH0001/ MESFLG, LUNIT - DATA ILLIN/0/, NTREP/0/ - DATA MESFLG/1/, LUNIT/6/ -C -C------------------------ END OF BLOCK DATA ---------------------------- - END -C----------------------------------------------------------------------- -C INSTRUCTIONS FOR INSTALLING THE ODESSA PACKAGE. (see @ below.) -C -C ODESSA is an enhanced version of the widely disseminated ODE solver -C LSODE, and as such retains the same properties regarding portability. -C The notes below, adapted from the installation instructions for LSODE, -C are intended to facilitate the installation of the ODESSA package in -C the user's software library. -C -C 1. Both a single and a double precision version of ODESSA are -C provided in this release. It is expected that most users will -C utilize the double precision version, except in the case of -C extended word-length computers. Most routines used by ODESSA -C are named the same regardless of whether they are single or -C double precision. The exceptions are the LINPAK and BLAS -C routines that follow the LINPAK/BLAS naming conventions, i.e. -C D--- for a double precision routine, and S--- for a single -C precision routine. Thus, care should be taken if both single -C and double precision versions are stored in the same library. -C -C 2. Several routines in ODESSA have the same names as the LSODE -C routines from which they were derived, although they contain -C different code. These are: INTDY, STODE, PREPJ, SVCOM, and -C RSCOM. If ODESSA is added to a subroutine library of which -C LSODE is already a member, these routine names must be changed -C in one of the two programs. Also see the note regarding BLOCK -C DATA subroutines below. -C -C 3. In many cases, ODESSA uses unaltered LSODE routines and -C common library routines that may already reside on your system. -C The installation of ODESSA should be done so that identical routines -C are shared rather than kept as duplicate copies. -C a. Normally, the user calls only subroutine ODESSA, but for optional -C capabilities the user may also CALL XSETUN, XSETF, SVCOM, RSCOM, -C or INTDY, as described in Part II of the Full Description in the -C User Documentation (ODESSA.DOC, see below). Except for INTDY, -C none of these are called from within the package. -C b. Two routines, EWSET and VNORM, are optionally replaceable by the -C user if the package version is unsuitable. Hence, the install- -C ation of the package should be done so that the user's version -C for either routine overrides the package version. -C c. The function routine D1MACH is provided to compute the unit -C roundoff of the machine and precision in use, in a manner com- -C patible with machine parameter routines developed at Bell Lab- -C oratories. If such a routine has already been installed on -C your system, the version supplied here may be discarded. -C d. Linear algebraic systems are solved with routines from the -C LINPACK collection, in conjunction with routines from the Basic -C Linear Algebra module collection (BLAS). In double precision, -C the names are DGEFA, DGESL, DGBFA, and DGBSL (from LINPACK), and -C DAXPY, DSCAL, IDAMAX, and DDOT (from BLAS). If these routines -C have already been installed on your system, copies supplied with -C ODESSA may be discarded. The single precision versions of these -C routines are used in the single precision version. -C -C 4. There are four integer variables, in the two labeled COMMON -C blocks /ODE001/ and /EH0001/, which need to be loaded with DATA -C statements. They can vary during execution, and are in common to -C assure their retention between calls. This is legal in ANSI Fortran -C only if done in a BLOCK DATA subprogram, and this package has a -C BLOCK DATA for this purpose. However, BLOCK DATA subprograms can be -C difficult to install in libraries, and many compilers allow such DATA -C statements in subroutines. If your system allows this, the location -C of the DATA statements are just after the initial type and common -C declarations in subroutines ODESSA and XERR. In ODESSA, ILLIN and -C NTREP are DATA-loaded as 0. In XERR, MESFLG is loaded as 1 and -C LUNIT is loaded as the appropriate default logical unit number. -C -C 5. The ODESSA package contains subscript expressions which may not -C be accepted by some compilers. Subscripts of the form I + J, I - J, -C etc., occur in various routines. If any of these forms are -C unacceptable to your compiler, an extra line of code setting the -C subscript to a dummy integer value should be added for each subscipt. -C -C 6. User documentation is provided in a two-level structure -C to accommmodate both the casual and serious user. The novice or -C casual user should need to read only the Summary of Usage and the -C Example Problem located at the beginning of the documentation. More -C experienced users, requiring the full set of available options, -C should read the Full Description which follows the Example Problem. -C -C 7. The user documentation may need corrections in the following ways: -C a. If subroutine names have been changed to avoid conflicts between -C the LSODE and ODESSA packages, the corresponding name changes -C should be made in the documentation. -C b. In the Summary of Usage, and in the description of XSETUN under -C Part II of the Full Description, the default logical unit number -C should be corrected if it is not 6. -C c. In the Summary of Usage, users should be instructed to execute -C CALL XSETF(1) before the first CALL to ODESSA, if this is neces- -C sary for proper error message handling. (see note 2(e) above.) -C d. In the description of the subroutines DF and JAC in the Summary -C of Usage and in Part I of the Full Description, it is stated -C that dummy names may be passed if these two routines are not user -C supplied. Your system may require the user to supply a dummy -C subroutine instead. -C e. The ODESSA package treats the arguments NEQ, RTOL, and ATOL as -C arrays (possibly of length 1), while the usage documentation -C states that these arguments may be either arrays or scalars. -C If your system does not allow such a mismatch, then the -C documentation should be changed to reflect this. -C 8. A demonstration program is provided with the package for -C verification. -C -C -C Jorge R. Leis and Mark A. Kramer -C Department of Chemical Engineering -C Massachusetts Institute of Technology -C Cambridge, Massachusetts 02139 -C U.S.A. -C -C Current address of J.R. Leis (Jan. 1988): -C -C Shell Development Company -C Westhollow Research Center -C Houston, TX -C -C @ Adapted from 'Instructions for Installing LSODE', written by -C Alan C. Hindmarsh, Mathematics & Statistics Division, L-316, -C Lawrence Livermore National Laboratory, Livermore, CA. 94550 diff --git a/boxmox/int/atm_radau5.def b/boxmox/int/atm_radau5.def deleted file mode 100644 index 7b3bb1a9ab1e01eed344164de37e244fe536d91a..0000000000000000000000000000000000000000 --- a/boxmox/int/atm_radau5.def +++ /dev/null @@ -1,19 +0,0 @@ - -#FUNCTION AGGREGATE -#JACOBIAN FULL -#DOUBLE ON -#INTFILE atm_radau5 - -#INLINE F77_GLOBAL - REAL*8 STEPSTART - COMMON /GDATA/ STEPSTART -#ENDINLINE - -#INLINE F77_INIT - STEPMIN=0.0001 - STEPMAX=3600. - STEPSTART=STEPMIN -#ENDINLINE - - - diff --git a/boxmox/int/atm_radau5.f b/boxmox/int/atm_radau5.f deleted file mode 100644 index 2b3a6042afc61f5e284f7f5dadd7ef1d2ba13e55..0000000000000000000000000000000000000000 --- a/boxmox/int/atm_radau5.f +++ /dev/null @@ -1,4572 +0,0 @@ - SUBROUTINE INTEGRATE( TIN, TOUT ) - - IMPLICIT KPP_REAL (A-H,O-Z) - INCLUDE 'KPP_ROOT_Parameters.h' - INCLUDE 'KPP_ROOT_Global.h' - -C TIN - Start Time - KPP_REAL TIN -C TOUT - End Time - KPP_REAL TOUT, H - SAVE H - DATA H /0.0d0/ - INTEGER Nfun, Njac, Nstp, Nacc, Nrej, Ndec, Nsol - SAVE Nstp, Nacc, Nrej - DATA Nstp /0/ - DATA Nacc /0/ - DATA Nrej /0/ - INTEGER i - - PARAMETER (LWORK=5*NVAR*NVAR+12*NVAR+20,LIWORK=3*NVAR+20) - PARAMETER (LRCONT=4*NVAR+4) - - KPP_REAL WORK(LWORK), RPAR(1) - INTEGER IWORK(LIWORK), IPAR(1) - COMMON /CONT/ ICONT(4),RCONT(LRCONT) - EXTERNAL FUNC_CHEM,JAC_CHEM,SOLOUT - - - ITOL=1 ! --- VECTOR TOLERANCES - IJAC=1 ! --- COMPUTE THE JACOBIAN ANALYTICALLY - IMAS=0 ! --- DIFFERENTIAL EQUATION IS IN EXPLICIT FORM - IOUT=0 ! --- OUTPUT ROUTINE IS NOT USED DURING INTEGRATION - MLJAC=NVAR ! --- JACOBIAN IS A FULL MATRIX - MUJAC=NVAR ! --- JACOBIAN IS A FULL MATRIX - MLMAS=NVAR ! --- JACOBIAN IS A FULL MATRIX - MUMAS=NVAR ! --- JACOBIAN IS A FULL MATRIX - - DO i=1,20 - IWORK(i) = 0 - WORK(i) = 0.D0 - ENDDO - - IWORK(3) = 8 ! Max no. of Newton iterations - IWORK(4) = 0 ! Starting values for Newton are interpolated (0) or zero (1) - IWORK(8) = 2 ! Gustaffson (1) or classic(2) controller - WORK(2) = 0.9 ! Safety factor - - CALL RADAU5(NVAR,FUNC_CHEM,TIN,VAR,TOUT,H, - & RTOL,ATOL,ITOL, - & JAC_CHEM ,IJAC,MLJAC,MUJAC, - & FUNC_CHEM ,IMAS,MLMAS,MUMAS, - & SOLOUT,IOUT, - & WORK,LWORK,IWORK,LIWORK,RPAR,IPAR,IDID) - - - Nfun = Nfun + IWORK(14) - Njac = Njac + IWORK(15) - Nstp = Nstp + IWORK(16) - Nacc = Nacc + IWORK(17) - Nrej = Nrej + IWORK(18) - Ndec = Ndec + IWORK(19) - Nsol = Nsol + IWORK(20) - - print("('Nstep=',I5,' Nacc=',I6,' Nrej=',I6)"),Nstp, Nacc, Nrej - - IF (IDID.LT.0) THEN - print *,'RADAU: Unsucessfull exit at T=', - & TIN,' (IDID=',IDID,')' - ENDIF - - RETURN - END - - - SUBROUTINE RADAU5(N,FCN,X,Y,XEND,H, - & RelTol,AbsTol,ITOL, - & JAC ,IJAC,MLJAC,MUJAC, - & MAS ,IMAS,MLMAS,MUMAS, - & SOLOUT,IOUT, - & WORK,LWORK,IWORK,LIWORK,RPAR,IPAR,IDID) -C ---------------------------------------------------------- -C NUMERICAL SOLUTION OF A STIFF (OR DIFFERENTIAL ALGEBRAIC) -C SYSTEM OF FIRST 0RDER ORDINARY DIFFERENTIAL EQUATIONS -C M*Y'=F(X,Y). -C THE SYSTEM CAN BE (LINEARLY) IMPLICIT (MASS-MATRIX M .NE. I) -C OR EXPLICIT (M=I). -C THE METHOD USED IS AN IMPLICIT RUNGE-KUTTA METHOD (RADAU IIA) -C OF ORDER 5 WITH STEP SIZE CONTROL AND CONTINUOUS OUTPUT. -C C.F. SECTION IV.8 -C -C AUTHORS: E. HAIRER AND G. WANNER -C UNIVERSITE DE GENEVE, DEPT. DE MATHEMATIQUES -C CH-1211 GENEVE 24, SWITZERLAND -C E-MAIL: HAIRER@DIVSUN.UNIGE.CH, WANNER@DIVSUN.UNIGE.CH -C -C THIS CODE IS PART OF THE BOOK: -C E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL -C EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS. -C SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS 14, -C SPRINGER-VERLAG (1991) -C -C VERSION OF SEPTEMBER 30, 1995 -C -C INPUT PARAMETERS -C ---------------- -C N DIMENSION OF THE SYSTEM -C -C FCN NAME (EXTERNAL) OF SUBROUTINE COMPUTING THE -C VALUE OF F(X,Y): -C SUBROUTINE FCN(N,X,Y,F,RPAR,IPAR) -C KPP_REAL X,Y(N),F(N) -C F(1)=... ETC. -C RPAR, IPAR (SEE BELOW) -C -C X INITIAL X-VALUE -C -C Y(N) INITIAL VALUES FOR Y -C -C XEND FINAL X-VALUE (XEND-X MAY BE POSITIVE OR NEGATIVE) -C -C H INITIAL STEP SIZE GUESS; -C FOR STIFF EQUATIONS WITH INITIAL TRANSIENT, -C H=1.D0/(NORM OF F'), USUALLY 1.D-3 OR 1.D-5, IS GOOD. -C THIS CHOICE IS NOT VERY IMPORTANT, THE STEP SIZE IS -C QUICKLY ADAPTED. (IF H=0.D0, THE CODE PUTS H=1.D-6). -C -C RelTol,AbsTol RELATIVE AND ABSOLUTE ERROR TOLERANCES. THEY -C CAN BE BOTH SCALARS OR ELSE BOTH VECTORS OF LENGTH N. -C -C ITOL SWITCH FOR RelTol AND AbsTol: -C ITOL=0: BOTH RelTol AND AbsTol ARE SCALARS. -C THE CODE KEEPS, ROUGHLY, THE LOCAL ERROR OF -C Y(I) BELOW RelTol*ABS(Y(I))+AbsTol -C ITOL=1: BOTH RelTol AND AbsTol ARE VECTORS. -C THE CODE KEEPS THE LOCAL ERROR OF Y(I) BELOW -C RelTol(I)*ABS(Y(I))+AbsTol(I). -C -C JAC NAME (EXTERNAL) OF THE SUBROUTINE WHICH COMPUTES -C THE PARTIAL DERIVATIVES OF F(X,Y) WITH RESPECT TO Y -C (THIS ROUTINE IS ONLY CALLED IF IJAC=1; SUPPLY -C A DUMMY SUBROUTINE IN THE CASE IJAC=0). -C FOR IJAC=1, THIS SUBROUTINE MUST HAVE THE FORM -C SUBROUTINE JAC(N,X,Y,DFY,LDFY,RPAR,IPAR) -C KPP_REAL X,Y(N),DFY(LDFY,N) -C DFY(1,1)= ... -C LDFY, THE COLUMN-LENGTH OF THE ARRAY, IS -C FURNISHED BY THE CALLING PROGRAM. -C IF (MLJAC.EQ.N) THE JACOBIAN IS SUPPOSED TO -C BE FULL AND THE PARTIAL DERIVATIVES ARE -C STORED IN DFY AS -C DFY(I,J) = PARTIAL F(I) / PARTIAL Y(J) -C ELSE, THE JACOBIAN IS TAKEN AS BANDED AND -C THE PARTIAL DERIVATIVES ARE STORED -C DIAGONAL-WISE AS -C DFY(I-J+MUJAC+1,J) = PARTIAL F(I) / PARTIAL Y(J). -C -C IJAC SWITCH FOR THE COMPUTATION OF THE JACOBIAN: -C IJAC=0: JACOBIAN IS COMPUTED INTERNALLY BY FINITE -C DIFFERENCES, SUBROUTINE "JAC" IS NEVER CALLED. -C IJAC=1: JACOBIAN IS SUPPLIED BY SUBROUTINE JAC. -C -C MLJAC SWITCH FOR THE BANDED STRUCTURE OF THE JACOBIAN: -C MLJAC=N: JACOBIAN IS A FULL MATRIX. THE LINEAR -C ALGEBRA IS DONE BY FULL-MATRIX GAUSS-ELIMINATION. -C 0<=MLJAC= NUMBER OF NON-ZERO DIAGONALS BELOW -C THE MAIN DIAGONAL). -C -C MUJAC UPPER BANDWITH OF JACOBIAN MATRIX (>= NUMBER OF NON- -C ZERO DIAGONALS ABOVE THE MAIN DIAGONAL). -C NEED NOT BE DEFINED IF MLJAC=N. -C -C ---- MAS,IMAS,MLMAS, AND MUMAS HAVE ANALOG MEANINGS ----- -C ---- FOR THE "MASS MATRIX" (THE MATRIX "M" OF SECTION IV.8): - -C -C MAS NAME (EXTERNAL) OF SUBROUTINE COMPUTING THE MASS- -C MATRIX M. -C IF IMAS=0, THIS MATRIX IS ASSUMED TO BE THE IDENTITY -C MATRIX AND NEEDS NOT TO BE DEFINED; -C SUPPLY A DUMMY SUBROUTINE IN THIS CASE. -C IF IMAS=1, THE SUBROUTINE MAS IS OF THE FORM -C SUBROUTINE MAS(N,AM,LMAS,RPAR,IPAR) -C KPP_REAL AM(LMAS,N) -C AM(1,1)= .... -C IF (MLMAS.EQ.N) THE MASS-MATRIX IS STORED -C AS FULL MATRIX LIKE -C AM(I,J) = M(I,J) -C ELSE, THE MATRIX IS TAKEN AS BANDED AND STORED -C DIAGONAL-WISE AS -C AM(I-J+MUMAS+1,J) = M(I,J). -C -C IMAS GIVES INFORMATION ON THE MASS-MATRIX: -C IMAS=0: M IS SUPPOSED TO BE THE IDENTITY -C MATRIX, MAS IS NEVER CALLED. -C IMAS=1: MASS-MATRIX IS SUPPLIED. -C -C MLMAS SWITCH FOR THE BANDED STRUCTURE OF THE MASS-MATRIX: -C MLMAS=N: THE FULL MATRIX CASE. THE LINEAR -C ALGEBRA IS DONE BY FULL-MATRIX GAUSS-ELIMINATION. -C 0<=MLMAS= NUMBER OF NON-ZERO DIAGONALS BELOW -C THE MAIN DIAGONAL). -C MLMAS IS SUPPOSED TO BE .LE. MLJAC. -C -C MUMAS UPPER BANDWITH OF MASS-MATRIX (>= NUMBER OF NON- -C ZERO DIAGONALS ABOVE THE MAIN DIAGONAL). -C NEED NOT BE DEFINED IF MLMAS=N. -C MUMAS IS SUPPOSED TO BE .LE. MUJAC. -C -C SOLOUT NAME (EXTERNAL) OF SUBROUTINE PROVIDING THE -C NUMERICAL SOLUTION DURING INTEGRATION. -C IF IOUT=1, IT IS CALLED AFTER EVERY SUCCESSFUL STEP. -C SUPPLY A DUMMY SUBROUTINE IF IOUT=0. -C IT MUST HAVE THE FORM -C SUBROUTINE SOLOUT (NR,XOLD,X,Y,CONT,LRC,N, -C RPAR,IPAR,IRTRN) -C KPP_REAL X,Y(N),CONT(LRC) -C .... -C SOLOUT FURNISHES THE SOLUTION "Y" AT THE NR-TH -C GRID-POINT "X" (THEREBY THE INITIAL VALUE IS -C THE FIRST GRID-POINT). -C "XOLD" IS THE PRECEEDING GRID-POINT. -C "IRTRN" SERVES TO INTERRUPT THE INTEGRATION. IF IRTRN -C IS SET <0, RADAU5 RETURNS TO THE CALLING PROGRAM. -C -C ----- CONTINUOUS OUTPUT: ----- -C DURING CALLS TO "SOLOUT", A CONTINUOUS SOLUTION -C FOR THE INTERVAL [XOLD,X] IS AVAILABLE THROUGH -C THE FUNCTION -C >>> CONTR5(I,S,CONT,LRC) <<< -C WHICH PROVIDES AN APPROXIMATION TO THE I-TH -C COMPONENT OF THE SOLUTION AT THE POINT S. THE VALUE -C S SHOULD LIE IN THE INTERVAL [XOLD,X]. -C DO NOT CHANGE THE ENTRIES OF CONT(LRC), IF THE -C DENSE OUTPUT FUNCTION IS USED. -C -C IOUT SWITCH FOR CALLING THE SUBROUTINE SOLOUT: -C IOUT=0: SUBROUTINE IS NEVER CALLED -C IOUT=1: SUBROUTINE IS AVAILABLE FOR OUTPUT. -C -C WORK ARRAY OF WORKING SPACE OF LENGTH "LWORK". -C WORK(1), WORK(2),.., WORK(20) SERVE AS PARAMETERS -C FOR THE CODE. FOR STANDARD USE OF THE CODE -C WORK(1),..,WORK(20) MUST BE SET TO ZERO BEFORE -C CALLING. SEE BELOW FOR A MORE SOPHISTICATED USE. -C WORK(21),..,WORK(LWORK) SERVE AS WORKING SPACE -C FOR ALL VECTORS AND MATRICES. -C "LWORK" MUST BE AT LEAST -C N*(LJAC+LMAS+3*LE+12)+20 -C WHERE -C LJAC=N IF MLJAC=N (FULL JACOBIAN) -C LJAC=MLJAC+MUJAC+1 IF MLJAC0 THEN "LWORK" MUST BE AT LEAST -C N*(LJAC+12)+(N-M1)*(LMAS+3*LE)+20 -C WHERE IN THE DEFINITIONS OF LJAC, LMAS AND LE THE -C NUMBER N CAN BE REPLACED BY N-M1. -C -C LWORK DECLARED LENGTH OF ARRAY "WORK". -C -C IWORK INTEGER WORKING SPACE OF LENGTH "LIWORK". -C IWORK(1),IWORK(2),...,IWORK(20) SERVE AS PARAMETERS -C FOR THE CODE. FOR STANDARD USE, SET IWORK(1),.., -C IWORK(20) TO ZERO BEFORE CALLING. -C IWORK(21),...,IWORK(LIWORK) SERVE AS WORKING AREA. -C "LIWORK" MUST BE AT LEAST 3*N+20. -C -C LIWORK DECLARED LENGTH OF ARRAY "IWORK". -C -C RPAR, IPAR REAL AND INTEGER PARAMETERS (OR PARAMETER ARRAYS) WHICH -C CAN BE USED FOR COMMUNICATION BETWEEN YOUR CALLING -C PROGRAM AND THE FCN, JAC, MAS, SOLOUT SUBROUTINES. -C -C ---------------------------------------------------------------------- -C -C SOPHISTICATED SETTING OF PARAMETERS -C ----------------------------------- -C SEVERAL PARAMETERS OF THE CODE ARE TUNED TO MAKE IT WORK -C WELL. THEY MAY BE DEFINED BY SETTING WORK(1),... -C AS WELL AS IWORK(1),... DIFFERENT FROM ZERO. -C FOR ZERO INPUT, THE CODE CHOOSES DEFAULT VALUES: -C -C IWORK(1) IF IWORK(1).NE.0, THE CODE TRANSFORMS THE JACOBIAN -C MATRIX TO HESSENBERG FORM. THIS IS PARTICULARLY -C ADVANTAGEOUS FOR LARGE SYSTEMS WITH FULL JACOBIAN. -C IT DOES NOT WORK FOR BANDED JACOBIAN (MLJAC 1. -C THE FUNCTION-SUBROUTINE SHOULD BE WRITTEN SUCH THAT -C THE INDEX 1,2,3 VARIABLES APPEAR IN THIS ORDER. -C IN ESTIMATING THE ERROR THE INDEX 2 VARIABLES ARE -C MULTIPLIED BY H, THE INDEX 3 VARIABLES BY H**2. -C -C IWORK(5) DIMENSION OF THE INDEX 1 VARIABLES (MUST BE > 0). FOR -C ODE'S THIS EQUALS THE DIMENSION OF THE SYSTEM. -C DEFAULT IWORK(5)=N. -C -C IWORK(6) DIMENSION OF THE INDEX 2 VARIABLES. DEFAULT IWORK(6)=0. -C -C IWORK(7) DIMENSION OF THE INDEX 3 VARIABLES. DEFAULT IWORK(7)=0. -C -C IWORK(8) SWITCH FOR STEP SIZE STRATEGY -C IF IWORK(8).EQ.1 MOD. PREDICTIVE CONTROLLER (GUSTAFSSON) -C IF IWORK(8).EQ.2 CLASSICAL STEP SIZE CONTROL -C THE DEFAULT VALUE (FOR IWORK(8)=0) IS IWORK(8)=1. -C THE CHOICE IWORK(8).EQ.1 SEEMS TO PRODUCE SAFER RESULTS; -C FOR SIMPLE PROBLEMS, THE CHOICE IWORK(8).EQ.2 PRODUCES -C OFTEN SLIGHTLY FASTER RUNS -C -C IF THE DIFFERENTIAL SYSTEM HAS THE SPECIAL STRUCTURE THAT -C Y(I)' = Y(I+M2) FOR I=1,...,M1, -C WITH M1 A MULTIPLE OF M2, A SUBSTANTIAL GAIN IN COMPUTERTIME -C CAN BE ACHIEVED BY SETTING THE FOLLOWING TWO PARAMETERS. E.G., -C FOR SECOND ORDER SYSTEMS P'=V, V'=G(P,V), WHERE P AND V ARE -C VECTORS OF DIMENSION N/2, ONE HAS TO PUT M1=M2=N/2. -C FOR M1>0 SOME OF THE INPUT PARAMETERS HAVE DIFFERENT MEANINGS: -C - JAC: ONLY THE ELEMENTS OF THE NON-TRIVIAL PART OF THE -C JACOBIAN HAVE TO BE STORED -C IF (MLJAC.EQ.N-M1) THE JACOBIAN IS SUPPOSED TO BE FULL -C DFY(I,J) = PARTIAL F(I+M1) / PARTIAL Y(J) -C FOR I=1,N-M1 AND J=1,N. -C ELSE, THE JACOBIAN IS BANDED ( M1 = M2 * MM ) -C DFY(I-J+MUJAC+1,J+K*M2) = PARTIAL F(I+M1) / PARTIAL Y(J+K*M2) -C FOR I=1,MLJAC+MUJAC+1 AND J=1,M2 AND K=0,MM. -C - MLJAC: MLJAC=N-M1: IF THE NON-TRIVIAL PART OF THE JACOBIAN IS FULL -C 0<=MLJAC= x) { - m = i+1; - break; - } - - /* Update T with time to next reaction */ - *T = *T - log(r2)/A[NREACT-1]; - - /* Update state vector after reaction m */ - MoleculeChange( m, NmlcV ); - - } /* for event */ - -} /* Gillespie */ diff --git a/boxmox/int/gillespie.def b/boxmox/int/gillespie.def deleted file mode 100644 index f6b2a1a3bd17a500a71217d3ce9d9520af39074a..0000000000000000000000000000000000000000 --- a/boxmox/int/gillespie.def +++ /dev/null @@ -1,10 +0,0 @@ - -#FUNCTION aggregate -#JACOBIAN SPARSE_LU_ROW -#DOUBLE on -#STOCHASTIC on -#INTFILE gillespie - - - - diff --git a/boxmox/int/gillespie.f90 b/boxmox/int/gillespie.f90 deleted file mode 100644 index 025c905ddab0ecd8843bebcc6f5af09b86e11bf1..0000000000000000000000000000000000000000 --- a/boxmox/int/gillespie.f90 +++ /dev/null @@ -1,86 +0,0 @@ -MODULE KPP_ROOT_Integrator - - USE KPP_ROOT_Parameters, ONLY : NVAR, NFIX, NREACT - USE KPP_ROOT_Global, ONLY : TIME, RCONST, Volume - USE KPP_ROOT_Stoichiom - USE KPP_ROOT_Stochastic - USE KPP_ROOT_Rates - IMPLICIT NONE - -CONTAINS - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Gillespie(Nevents, T, SCT, NmlcV, NmlcF) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -! Gillespie stochastic integration -! INPUT: -! Nevents = no. of individual reaction events to be simulated -! SCT = stochastic rate constants -! T = time -! NmlcV, NmlcF = no. of molecules for variable and fixed species -! OUTPUT: -! T = updated time (after Nevents reactions) -! NmlcV = updated no. of molecules for variable species -! -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - KPP_REAL:: T - INTEGER :: Nevents - INTEGER :: NmlcV(NVAR), NmlcF(NFIX) - INTEGER :: i, m, issa - REAL :: r1, r2 - KPP_REAL :: A(NREACT), SCT(NREACT), x - - DO issa = 1, Nevents - - ! Uniformly distributed random numbers - CALL RANDOM_NUMBER(r1) - CALL RANDOM_NUMBER(r2) - ! Avoid log of zero - r2 = MAX(r2,1.e-14) - - ! Propensity vector - CALL Propensity ( NmlcV, NmlcF, SCT, A ) - ! Cumulative sum of propensities - DO i = 2, NREACT - A(i) = A(i-1)+A(i); - END DO - - ! Index of next reaction - x = r1*A(NREACT) - DO i = 1, NREACT - IF (A(i)>=x) THEN - m = i; - EXIT - END IF - END DO - - ! Update time with time to next reaction - T = T - LOG(r2)/A(NREACT); - - ! Update state vector - CALL MoleculeChange( m, NmlcV ) - - END DO - - CONTAINS - - SUBROUTINE PropensityTemplate( T, NmlcV, NmlcF, Prop ) - KPP_REAL, INTENT(IN) :: T - INTEGER, INTENT(IN) :: NmlcV(NVAR), NmlcF(NFIX) - KPP_REAL, INTENT(OUT) :: Prop(NREACT) - KPP_REAL :: Tsave, SCT(NREACT) - ! Update the stochastic reaction rates, which may be time dependent - Tsave = TIME - TIME = T - CALL Update_RCONST() - CALL StochasticRates( RCONST, Volume, SCT ) - CALL Propensity ( NmlcV, NmlcF, SCT, Prop ) - TIME = Tsave - END SUBROUTINE PropensityTemplate - - END SUBROUTINE Gillespie - -END MODULE KPP_ROOT_Integrator diff --git a/boxmox/int/kpp_dvode.def b/boxmox/int/kpp_dvode.def deleted file mode 100644 index 12804bc11a307df05527fd779a33506a80d313ea..0000000000000000000000000000000000000000 --- a/boxmox/int/kpp_dvode.def +++ /dev/null @@ -1,14 +0,0 @@ - -#FUNCTION AGGREGATE -#JACOBIAN SPARSE_LU_ROW - -#DOUBLE ON -#INTFILE kpp_dvode - -#INLINE F77_INIT - STEPMIN=0.0001 - STEPMAX=3600. -#ENDINLINE - - - diff --git a/boxmox/int/kpp_dvode.f b/boxmox/int/kpp_dvode.f deleted file mode 100644 index e120543074caa4c54bfb3e58818bd59029e5b034..0000000000000000000000000000000000000000 --- a/boxmox/int/kpp_dvode.f +++ /dev/null @@ -1,3850 +0,0 @@ - SUBROUTINE INTEGRATE( TIN, TOUT ) - - IMPLICIT KPP_REAL (A-H,O-Z) - INCLUDE 'KPP_ROOT_Parameters.h' - INCLUDE 'KPP_ROOT_Global.h' - -C TIN - Start Time - KPP_REAL TIN -C TOUT - End Time - KPP_REAL TOUT - - PARAMETER (LRW=2*NVAR*NVAR+9*NVAR+25,LIW=NVAR+35) - PARAMETER (LRCONT=4*NVAR+4+10) - COMMON /CONT/ICONT(4),RCONT(LRCONT) - COMMON/STAT/NFCN,NJAC,NSTEP,NACCPT,NREJCT,NDEC,NSOL - COMMON /VERWER/ IVERWER, IBEGIN, STEPCUT - EXTERNAL VODE_FSPLIT_VAR, VODE_Jac_SP - - KPP_REAL RWORK(LRW) - INTEGER IWORK(LIW) - - STEPCUT = 0. - MAXORD = 5 - IBEGIN = 1 - ITOL=4 - -C ---- NORMAL COMPUTATION --- - ITASK=1 - ISTATE=1 -C ---- USE OPTIONAL INPUT --- - IOPT=1 - IWORK(5) = MAXORD ! MAX ORD - IWORK(6) = 20000 - IWORK(7) = 0 - RWORK(6) = STEPMAX ! STEP MAX - RWORK(7) = STEPMIN ! STEP MIN - RWORK(5) = STEPMIN ! INITIAL STEP - -C ----- SIGNAL FOR STIFF CASE, FULL JACOBIAN, INTERN (22) or SUPPLIED (21) - MF = 21 - - CALL DVODE (VODE_FSPLIT_VAR, NVAR, VAR, TIN, TOUT, ITOL, - * RTOL, ATOL, ITASK, - * ISTATE, IOPT, RWORK, LRW, IWORK, LIW, - * VODE_Jac_SP, MF, RPAR, IPAR) - - IF (ISTATE.LT.0) THEN - print *,'ATMDVODE: Unsucessfull exit at T=', - & TIN,' (ISTATE=',ISTATE,')' - ENDIF - - RETURN - END - - -C -- This version has JAC sparse, FCN aggregate -- - - SUBROUTINE DVODE (F, NEQ, Y, T, TOUT, ITOL, RelTol, AbsTol, ITASK, - 1 ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, MF, - 2 RPAR, IPAR) - - KPP_REAL Y, T, TOUT, RelTol, AbsTol, RWORK, RPAR - INTEGER NEQ, ITOL, ITASK, ISTATE, IOPT, LRW, IWORK, LIW, - 1 MF, IPAR - DIMENSION Y(*), RelTol(*), AbsTol(*), RWORK(LRW), IWORK(LIW), - 1 RPAR(*), IPAR(*) -C----------------------------------------------------------------------- -C DVODE.. Variable-coefficient Ordinary Differential Equation solver, -C with fixed-leading coefficient implementation. -C This version is in KPP_REAL. -C -C DVODE solves the initial value problem for stiff or nonstiff -C systems of first order ODEs, -C dy/dt = f(t,y) , or, in component form, -C dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(NEQ)) (i = 1,...,NEQ). -C DVODE is a package based on the EPISODE and EPISODEB packages, and -C on the ODEPACK user interface standard, with minor modifications. -C----------------------------------------------------------------------- -C Revision History (YYMMDD) -C 890615 Date Written -C 890922 Added interrupt/restart ability, minor changes throughout. -C 910228 Minor revisions in line format, prologue, etc. -C 920227 Modifications by D. Pang: -C (1) Applied subgennam to get generic intrinsic names. -C (2) Changed intrinsic names to generic in comments. -C (3) Added *DECK lines before each routine. -C 920721 Names of routines and labeled Common blocks changed, so as -C to be unique in combined single/KPP_REAL code (ACH). -C 920722 Minor revisions to prologue (ACH). -C 920831 Conversion to KPP_REAL done (ACH). -C----------------------------------------------------------------------- -C References.. -C -C 1. P. N. Brown, G. D. Byrne, and A. C. Hindmarsh, "VODE: A Variable -C Coefficient ODE Solver," SIAM J. Sci. Stat. Comput., 10 (1989), -C pp. 1038-1051. Also, LLNL Report UCRL-98412, June 1988. -C 2. G. D. Byrne and A. C. Hindmarsh, "A Polyalgorithm for the -C Numerical Solution of Ordinary Differential Equations," -C ACM Trans. Math. Software, 1 (1975), pp. 71-96. -C 3. A. C. Hindmarsh and G. D. Byrne, "EPISODE: An Effective Package -C for the Integration of Systems of Ordinary Differential -C Equations," LLNL Report UCID-30112, Rev. 1, April 1977. -C 4. G. D. Byrne and A. C. Hindmarsh, "EPISODEB: An Experimental -C Package for the Integration of Systems of Ordinary Differential -C Equations with Banded Jacobians," LLNL Report UCID-30132, April -C 1976. -C 5. A. C. Hindmarsh, "ODEPACK, a Systematized Collection of ODE -C Solvers," in Scientific Computing, R. S. Stepleman et al., eds., -C North-Holland, Amsterdam, 1983, pp. 55-64. -C 6. K. R. Jackson and R. Sacks-Davis, "An Alternative Implementation -C of Variable Step-Size Multistep Formulas for Stiff ODEs," ACM -C Trans. Math. Software, 6 (1980), pp. 295-318. -C----------------------------------------------------------------------- -C Authors.. -C -C Peter N. Brown and Alan C. Hindmarsh -C Computing and Mathematics Research Division, L-316 -C Lawrence Livermore National Laboratory -C Livermore, CA 94550 -C and -C George D. Byrne -C Exxon Research and Engineering Co. -C Clinton Township -C Route 22 East -C Annandale, NJ 08801 -C----------------------------------------------------------------------- -C Summary of usage. -C -C Communication between the user and the DVODE package, for normal -C situations, is summarized here. This summary describes only a subset -C of the full set of options available. See the full description for -C details, including optional communication, nonstandard options, -C and instructions for special situations. See also the example -C problem (with program and output) following this summary. -C -C A. First provide a subroutine of the form.. -C -C SUBROUTINE F (NEQ, T, Y, YDOT, RPAR, IPAR) -C KPP_REAL T, Y, YDOT, RPAR -C DIMENSION Y(NEQ), YDOT(NEQ) -C -C which supplies the vector function f by loading YDOT(i) with f(i). -C -C B. Next determine (or guess) whether or not the problem is stiff. -C Stiffness occurs when the Jacobian matrix df/dy has an eigenvalue -C whose real part is negative and large in magnitude, compared to the -C reciprocal of the t span of interest. If the problem is nonstiff, -C use a method flag MF = 10. If it is stiff, there are four standard -C choices for MF (21, 22, 24, 25), and DVODE requires the Jacobian -C matrix in some form. In these cases (MF .gt. 0), DVODE will use a -C saved copy of the Jacobian matrix. If this is undesirable because of -C storage limitations, set MF to the corresponding negative value -C (-21, -22, -24, -25). (See full description of MF below.) -C The Jacobian matrix is regarded either as full (MF = 21 or 22), -C or banded (MF = 24 or 25). In the banded case, DVODE requires two -C half-bandwidth parameters ML and MU. These are, respectively, the -C widths of the lower and upper parts of the band, excluding the main -C diagonal. Thus the band consists of the locations (i,j) with -C i-ML .le. j .le. i+MU, and the full bandwidth is ML+MU+1. -C -C C. If the problem is stiff, you are encouraged to supply the Jacobian -C directly (MF = 21 or 24), but if this is not feasible, DVODE will -C compute it internally by difference quotients (MF = 22 or 25). -C If you are supplying the Jacobian, provide a subroutine of the form.. -C -C SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD, RPAR, IPAR) -C KPP_REAL T, Y, PD, RPAR -C DIMENSION Y(NEQ), PD(NROWPD,NEQ) -C -C which supplies df/dy by loading PD as follows.. -C For a full Jacobian (MF = 21), load PD(i,j) with df(i)/dy(j), -C the partial derivative of f(i) with respect to y(j). (Ignore the -C ML and MU arguments in this case.) -C For a banded Jacobian (MF = 24), load PD(i-j+MU+1,j) with -C df(i)/dy(j), i.e. load the diagonal lines of df/dy into the rows of -C PD from the top down. -C In either case, only nonzero elements need be loaded. -C -C D. Write a main program which calls subroutine DVODE once for -C each point at which answers are desired. This should also provide -C for possible use of logical unit 6 for output of error messages -C by DVODE. On the first CALL to DVODE, supply arguments as follows.. -C F = Name of subroutine for right-hand side vector f. -C This name must be declared external in calling program. -C NEQ = Number of first order ODE-s. -C Y = Array of initial values, of length NEQ. -C T = The initial value of the independent variable. -C TOUT = First point where output is desired (.ne. T). -C ITOL = 1 or 2 according as AbsTol (below) is a scalar or array. -C RelTol = Relative tolerance parameter (scalar). -C AbsTol = Absolute tolerance parameter (scalar or array). -C The estimated local error in Y(i) will be controlled so as -C to be roughly less (in magnitude) than -C EWT(i) = RelTol*abs(Y(i)) + AbsTol if ITOL = 1, or -C EWT(i) = RelTol*abs(Y(i)) + AbsTol(i) if ITOL = 2. -C Thus the local error test passes if, in each component, -C either the absolute error is less than AbsTol (or AbsTol(i)), -C or the relative error is less than RelTol. -C Use RelTol = 0.0 for pure absolute error control, and -C use AbsTol = 0.0 (or AbsTol(i) = 0.0) for pure relative error -C control. Caution.. Actual (global) errors may exceed these -C local tolerances, so choose them conservatively. -C ITASK = 1 for normal computation of output values of Y at t = TOUT. -C ISTATE = Integer flag (input and output). Set ISTATE = 1. -C IOPT = 0 to indicate no optional input used. -C RWORK = Real work array of length at least.. -C 20 + 16*NEQ for MF = 10, -C 22 + 9*NEQ + 2*NEQ**2 for MF = 21 or 22, -C 22 + 11*NEQ + (3*ML + 2*MU)*NEQ for MF = 24 or 25. -C LRW = Declared length of RWORK (in user's DIMENSION statement). -C IWORK = Integer work array of length at least.. -C 30 for MF = 10, -C 30 + NEQ for MF = 21, 22, 24, or 25. -C If MF = 24 or 25, input in IWORK(1),IWORK(2) the lower -C and upper half-bandwidths ML,MU. -C LIW = Declared length of IWORK (in user's DIMENSION). -C JAC = Name of subroutine for Jacobian matrix (MF = 21 or 24). -C If used, this name must be declared external in calling -C program. If not used, pass a dummy name. -C MF = Method flag. Standard values are.. -C 10 for nonstiff (Adams) method, no Jacobian used. -C 21 for stiff (BDF) method, user-supplied full Jacobian. -C 22 for stiff method, internally generated full Jacobian. -C 24 for stiff method, user-supplied banded Jacobian. -C 25 for stiff method, internally generated banded Jacobian. -C RPAR,IPAR = user-defined real and integer arrays passed to F and JAC. -C Note that the main program must declare arrays Y, RWORK, IWORK, -C and possibly AbsTol, RPAR, and IPAR. -C -C E. The output from the first CALL (or any call) is.. -C Y = Array of computed values of y(t) vector. -C T = Corresponding value of independent variable (normally TOUT). -C ISTATE = 2 if DVODE was successful, negative otherwise. -C -1 means excess work done on this call. (Perhaps wrong MF.) -C -2 means excess accuracy requested. (Tolerances too small.) -C -3 means illegal input detected. (See printed message.) -C -4 means repeated error test failures. (Check all input.) -C -5 means repeated convergence failures. (Perhaps bad -C Jacobian supplied or wrong choice of MF or tolerances.) -C -6 means error weight became zero during problem. (Solution -C component i vanished, and AbsTol or AbsTol(i) = 0.) -C -C F. To continue the integration after a successful return, simply -C reset TOUT and CALL DVODE again. No other parameters need be reset. -C -C----------------------------------------------------------------------- -C EXAMPLE PROBLEM -C -C The following is a simple example problem, with the coding -C needed for its solution by DVODE. The problem is from chemical -C kinetics, and consists of the following three rate equations.. -C dy1/dt = -.04*y1 + 1.e4*y2*y3 -C dy2/dt = .04*y1 - 1.e4*y2*y3 - 3.e7*y2**2 -C dy3/dt = 3.e7*y2**2 -C on the interval from t = 0.0 to t = 4.e10, with initial conditions -C y1 = 1.0, y2 = y3 = 0. The problem is stiff. -C -C The following coding solves this problem with DVODE, using MF = 21 -C and printing results at t = .4, 4., ..., 4.e10. It uses -C ITOL = 2 and AbsTol much smaller for y2 than y1 or y3 because -C y2 has much smaller values. -C At the end of the run, statistical quantities of interest are -C printed. (See optional output in the full description below.) -C To generate Fortran source code, replace C in column 1 with a blank -C in the coding below. -C -C EXTERNAL FEX, JEX -C KPP_REAL AbsTol, RPAR, RelTol, RWORK, T, TOUT, Y -C DIMENSION Y(3), AbsTol(3), RWORK(67), IWORK(33) -C NEQ = 3 -C Y(1) = 1.0D0 -C Y(2) = 0.0D0 -C Y(3) = 0.0D0 -C T = 0.0D0 -C TOUT = 0.4D0 -C ITOL = 2 -C RelTol = 1.D-4 -C AbsTol(1) = 1.D-8 -C AbsTol(2) = 1.D-14 -C AbsTol(3) = 1.D-6 -C ITASK = 1 -C ISTATE = 1 -C IOPT = 0 -C LRW = 67 -C LIW = 33 -C MF = 21 -C DO 40 IOUT = 1,12 -C CALL DVODE(FEX,NEQ,Y,T,TOUT,ITOL,RelTol,AbsTol,ITASK,ISTATE, -C 1 IOPT,RWORK,LRW,IWORK,LIW,JEX,MF,RPAR,IPAR) -C WRITE(6,20)T,Y(1),Y(2),Y(3) -C 20 FORMAT(' At t =',D12.4,' y =',3D14.6) -C IF (ISTATE .LT. 0) GO TO 80 -C 40 TOUT = TOUT*10. -C WRITE(6,60) IWORK(11),IWORK(12),IWORK(13),IWORK(19), -C 1 IWORK(20),IWORK(21),IWORK(22) -C 60 FORMAT(/' No. steps =',I4,' No. f-s =',I4, -C 1 ' No. J-s =',I4,' No. LU-s =',I4/ -C 2 ' No. nonlinear iterations =',I4/ -C 3 ' No. nonlinear convergence failures =',I4/ -C 4 ' No. error test failures =',I4/) -C STOP -C 80 WRITE(6,90)ISTATE -C 90 FORMAT(///' Error halt.. ISTATE =',I3) -C STOP -C END -C -C SUBROUTINE FEX (NEQ, T, Y, YDOT, RPAR, IPAR) -C KPP_REAL RPAR, T, Y, YDOT -C DIMENSION Y(NEQ), YDOT(NEQ) -C YDOT(1) = -.04D0*Y(1) + 1.D4*Y(2)*Y(3) -C YDOT(3) = 3.D7*Y(2)*Y(2) -C YDOT(2) = -YDOT(1) - YDOT(3) -C RETURN -C END -C -C SUBROUTINE JEX (NEQ, T, Y, ML, MU, PD, NRPD, RPAR, IPAR) -C KPP_REAL PD, RPAR, T, Y -C DIMENSION Y(NEQ), PD(NRPD,NEQ) -C PD(1,1) = -.04D0 -C PD(1,2) = 1.D4*Y(3) -C PD(1,3) = 1.D4*Y(2) -C PD(2,1) = .04D0 -C PD(2,3) = -PD(1,3) -C PD(3,2) = 6.D7*Y(2) -C PD(2,2) = -PD(1,2) - PD(3,2) -C RETURN -C END -C -C The following output was obtained from the above program on a -C Cray-1 computer with the CFT compiler. -C -C At t = 4.0000e-01 y = 9.851680e-01 3.386314e-05 1.479817e-02 -C At t = 4.0000e+00 y = 9.055255e-01 2.240539e-05 9.445214e-02 -C At t = 4.0000e+01 y = 7.158108e-01 9.184883e-06 2.841800e-01 -C At t = 4.0000e+02 y = 4.505032e-01 3.222940e-06 5.494936e-01 -C At t = 4.0000e+03 y = 1.832053e-01 8.942690e-07 8.167938e-01 -C At t = 4.0000e+04 y = 3.898560e-02 1.621875e-07 9.610142e-01 -C At t = 4.0000e+05 y = 4.935882e-03 1.984013e-08 9.950641e-01 -C At t = 4.0000e+06 y = 5.166183e-04 2.067528e-09 9.994834e-01 -C At t = 4.0000e+07 y = 5.201214e-05 2.080593e-10 9.999480e-01 -C At t = 4.0000e+08 y = 5.213149e-06 2.085271e-11 9.999948e-01 -C At t = 4.0000e+09 y = 5.183495e-07 2.073399e-12 9.999995e-01 -C At t = 4.0000e+10 y = 5.450996e-08 2.180399e-13 9.999999e-01 -C -C No. steps = 595 No. f-s = 832 No. J-s = 13 No. LU-s = 112 -C No. nonlinear iterations = 831 -C No. nonlinear convergence failures = 0 -C No. error test failures = 22 -C----------------------------------------------------------------------- -C Full description of user interface to DVODE. -C -C The user interface to DVODE consists of the following parts. -C -C i. The CALL sequence to subroutine DVODE, which is a driver -C routine for the solver. This includes descriptions of both -C the CALL sequence arguments and of user-supplied routines. -C Following these descriptions is -C * a description of optional input available through the -C CALL sequence, -C * a description of optional output (in the work arrays), and -C * instructions for interrupting and restarting a solution. -C -C ii. Descriptions of other routines in the DVODE package that may be -C (optionally) called by the user. These provide the ability to -C alter error message handling, save and restore the internal -C COMMON, and obtain specified derivatives of the solution y(t). -C -C iii. Descriptions of COMMON blocks to be declared in overlay -C or similar environments. -C -C iv. Description of two routines in the DVODE package, either of -C which the user may replace with his own version, if desired. -C these relate to the measurement of errors. -C -C----------------------------------------------------------------------- -C Part i. Call Sequence. -C -C The CALL sequence parameters used for input only are -C F, NEQ, TOUT, ITOL, RelTol, AbsTol, ITASK, IOPT, LRW, LIW, JAC, MF, -C and those used for both input and output are -C Y, T, ISTATE. -C The work arrays RWORK and IWORK are also used for conditional and -C optional input and optional output. (The term output here refers -C to the return from subroutine DVODE to the user's calling program.) -C -C The legality of input parameters will be thoroughly checked on the -C initial CALL for the problem, but not checked thereafter unless a -C change in input parameters is flagged by ISTATE = 3 in the input. -C -C The descriptions of the CALL arguments are as follows. -C -C F = The name of the user-supplied subroutine defining the -C ODE system. The system must be put in the first-order -C form dy/dt = f(t,y), where f is a vector-valued function -C of the scalar t and the vector y. Subroutine F is to -C compute the function f. It is to have the form -C SUBROUTINE F (NEQ, T, Y, YDOT, RPAR, IPAR) -C KPP_REAL T, Y, YDOT, RPAR -C DIMENSION Y(NEQ), YDOT(NEQ) -C where NEQ, T, and Y are input, and the array YDOT = f(t,y) -C is output. Y and YDOT are arrays of length NEQ. -C (In the DIMENSION statement above, NEQ can be replaced by -C * to make Y and YDOT assumed size arrays.) -C Subroutine F should not alter Y(1),...,Y(NEQ). -C F must be declared EXTERNAL in the calling program. -C -C Subroutine F may access user-defined real and integer -C work arrays RPAR and IPAR, which are to be dimensioned -C in the main program. -C -C If quantities computed in the F routine are needed -C externally to DVODE, an extra CALL to F should be made -C for this purpose, for consistent and accurate results. -C If only the derivative dy/dt is needed, use DVINDY instead. -C -C NEQ = The size of the ODE system (number of first order -C ordinary differential equations). Used only for input. -C NEQ may not be increased during the problem, but -C can be decreased (with ISTATE = 3 in the input). -C -C Y = A real array for the vector of dependent variables, of -C length NEQ or more. Used for both input and output on the -C first CALL (ISTATE = 1), and only for output on other calls. -C On the first call, Y must contain the vector of initial -C values. In the output, Y contains the computed solution -C evaluated at T. If desired, the Y array may be used -C for other purposes between calls to the solver. -C -C This array is passed as the Y argument in all calls to -C F and JAC. -C -C T = The independent variable. In the input, T is used only on -C the first call, as the initial point of the integration. -C In the output, after each call, T is the value at which a -C computed solution Y is evaluated (usually the same as TOUT). -C On an error return, T is the farthest point reached. -C -C TOUT = The next value of t at which a computed solution is desired. -C Used only for input. -C -C When starting the problem (ISTATE = 1), TOUT may be equal -C to T for one call, then should .ne. T for the next call. -C For the initial T, an input value of TOUT .ne. T is used -C in order to determine the direction of the integration -C (i.e. the algebraic sign of the step sizes) and the rough -C scale of the problem. Integration in either direction -C (forward or backward in t) is permitted. -C -C If ITASK = 2 or 5 (one-step modes), TOUT is ignored after -C the first CALL (i.e. the first CALL with TOUT .ne. T). -C Otherwise, TOUT is required on every call. -C -C If ITASK = 1, 3, or 4, the values of TOUT need not be -C monotone, but a value of TOUT which backs up is limited -C to the current internal t interval, whose endpoints are -C TCUR - HU and TCUR. (See optional output, below, for -C TCUR and HU.) -C -C ITOL = An indicator for the type of error control. See -C description below under AbsTol. Used only for input. -C -C RelTol = A relative error tolerance parameter, either a scalar or -C an array of length NEQ. See description below under AbsTol. -C Input only. -C -C AbsTol = An absolute error tolerance parameter, either a scalar or -C an array of length NEQ. Input only. -C -C The input parameters ITOL, RelTol, and AbsTol determine -C the error control performed by the solver. The solver will -C control the vector e = (e(i)) of estimated local errors -C in Y, according to an inequality of the form -C rms-norm of ( e(i)/EWT(i) ) .le. 1, -C where EWT(i) = RelTol(i)*abs(Y(i)) + AbsTol(i), -C and the rms-norm (root-mean-square norm) here is -C rms-norm(v) = sqrt(sum v(i)**2 / NEQ). Here EWT = (EWT(i)) -C is a vector of weights which must always be positive, and -C the values of RelTol and AbsTol should all be non-negative. -C The following table gives the types (scalar/array) of -C RelTol and AbsTol, and the corresponding form of EWT(i). -C -C ITOL RelTol AbsTol EWT(i) -C 1 scalar scalar RelTol*ABS(Y(i)) + AbsTol -C 2 scalar array RelTol*ABS(Y(i)) + AbsTol(i) -C 3 array scalar RelTol(i)*ABS(Y(i)) + AbsTol -C 4 array array RelTol(i)*ABS(Y(i)) + AbsTol(i) -C -C When either of these parameters is a scalar, it need not -C be dimensioned in the user's calling program. -C -C If none of the above choices (with ITOL, RelTol, and AbsTol -C fixed throughout the problem) is suitable, more general -C error controls can be obtained by substituting -C user-supplied routines for the setting of EWT and/or for -C the norm calculation. See Part iv below. -C -C If global errors are to be estimated by making a repeated -C run on the same problem with smaller tolerances, then all -C components of RelTol and AbsTol (i.e. of EWT) should be scaled -C down uniformly. -C -C ITASK = An index specifying the task to be performed. -C Input only. ITASK has the following values and meanings. -C 1 means normal computation of output values of y(t) at -C t = TOUT (by overshooting and interpolating). -C 2 means take one step only and return. -C 3 means stop at the first internal mesh point at or -C beyond t = TOUT and return. -C 4 means normal computation of output values of y(t) at -C t = TOUT but without overshooting t = TCRIT. -C TCRIT must be input as RWORK(1). TCRIT may be equal to -C or beyond TOUT, but not behind it in the direction of -C integration. This option is useful if the problem -C has a singularity at or beyond t = TCRIT. -C 5 means take one step, without passing TCRIT, and return. -C TCRIT must be input as RWORK(1). -C -C Note.. If ITASK = 4 or 5 and the solver reaches TCRIT -C (within roundoff), it will return T = TCRIT (exactly) to -C indicate this (unless ITASK = 4 and TOUT comes before TCRIT, -C in which case answers at T = TOUT are returned first). -C -C ISTATE = an index used for input and output to specify the -C the state of the calculation. -C -C In the input, the values of ISTATE are as follows. -C 1 means this is the first CALL for the problem -C (initializations will be done). See note below. -C 2 means this is not the first call, and the calculation -C is to continue normally, with no change in any input -C parameters except possibly TOUT and ITASK. -C (If ITOL, RelTol, and/or AbsTol are changed between calls -C with ISTATE = 2, the new values will be used but not -C tested for legality.) -C 3 means this is not the first call, and the -C calculation is to continue normally, but with -C a change in input parameters other than -C TOUT and ITASK. Changes are allowed in -C NEQ, ITOL, RelTol, AbsTol, IOPT, LRW, LIW, MF, ML, MU, -C and any of the optional input except H0. -C (See IWORK description for ML and MU.) -C Note.. A preliminary CALL with TOUT = T is not counted -C as a first CALL here, as no initialization or checking of -C input is done. (Such a CALL is sometimes useful to include -C the initial conditions in the output.) -C Thus the first CALL for which TOUT .ne. T requires -C ISTATE = 1 in the input. -C -C In the output, ISTATE has the following values and meanings. -C 1 means nothing was done, as TOUT was equal to T with -C ISTATE = 1 in the input. -C 2 means the integration was performed successfully. -C -1 means an excessive amount of work (more than MXSTEP -C steps) was done on this call, before completing the -C requested task, but the integration was otherwise -C successful as far as T. (MXSTEP is an optional input -C and is normally 500.) To continue, the user may -C simply reset ISTATE to a value .gt. 1 and CALL again. -C (The excess work step counter will be reset to 0.) -C In addition, the user may increase MXSTEP to avoid -C this error return. (See optional input below.) -C -2 means too much accuracy was requested for the precision -C of the machine being used. This was detected before -C completing the requested task, but the integration -C was successful as far as T. To continue, the tolerance -C parameters must be reset, and ISTATE must be set -C to 3. The optional output TOLSF may be used for this -C purpose. (Note.. If this condition is detected before -C taking any steps, then an illegal input return -C (ISTATE = -3) occurs instead.) -C -3 means illegal input was detected, before taking any -C integration steps. See written message for details. -C Note.. If the solver detects an infinite loop of calls -C to the solver with illegal input, it will cause -C the run to stop. -C -4 means there were repeated error test failures on -C one attempted step, before completing the requested -C task, but the integration was successful as far as T. -C The problem may have a singularity, or the input -C may be inappropriate. -C -5 means there were repeated convergence test failures on -C one attempted step, before completing the requested -C task, but the integration was successful as far as T. -C This may be caused by an inaccurate Jacobian matrix, -C if one is being used. -C -6 means EWT(i) became zero for some i during the -C integration. Pure relative error control (AbsTol(i)=0.0) -C was requested on a variable which has now vanished. -C The integration was successful as far as T. -C -C Note.. Since the normal output value of ISTATE is 2, -C it does not need to be reset for normal continuation. -C Also, since a negative input value of ISTATE will be -C regarded as illegal, a negative output value requires the -C user to change it, and possibly other input, before -C calling the solver again. -C -C IOPT = An integer flag to specify whether or not any optional -C input is being used on this call. Input only. -C The optional input is listed separately below. -C IOPT = 0 means no optional input is being used. -C Default values will be used in all cases. -C IOPT = 1 means optional input is being used. -C -C RWORK = A real working array (KPP_REAL). -C The length of RWORK must be at least -C 20 + NYH*(MAXORD + 1) + 3*NEQ + LWM where -C NYH = the initial value of NEQ, -C MAXORD = 12 (if METH = 1) or 5 (if METH = 2) (unless a -C smaller value is given as an optional input), -C LWM = length of work space for matrix-related data.. -C LWM = 0 if MITER = 0, -C LWM = 2*NEQ**2 + 2 if MITER = 1 or 2, and MF.gt.0, -C LWM = NEQ**2 + 2 if MITER = 1 or 2, and MF.lt.0, -C LWM = NEQ + 2 if MITER = 3, -C LWM = (3*ML+2*MU+2)*NEQ + 2 if MITER = 4 or 5, and MF.gt.0, -C LWM = (2*ML+MU+1)*NEQ + 2 if MITER = 4 or 5, and MF.lt.0. -C (See the MF description for METH and MITER.) -C Thus if MAXORD has its default value and NEQ is constant, -C this length is.. -C 20 + 16*NEQ for MF = 10, -C 22 + 16*NEQ + 2*NEQ**2 for MF = 11 or 12, -C 22 + 16*NEQ + NEQ**2 for MF = -11 or -12, -C 22 + 17*NEQ for MF = 13, -C 22 + 18*NEQ + (3*ML+2*MU)*NEQ for MF = 14 or 15, -C 22 + 17*NEQ + (2*ML+MU)*NEQ for MF = -14 or -15, -C 20 + 9*NEQ for MF = 20, -C 22 + 9*NEQ + 2*NEQ**2 for MF = 21 or 22, -C 22 + 9*NEQ + NEQ**2 for MF = -21 or -22, -C 22 + 10*NEQ for MF = 23, -C 22 + 11*NEQ + (3*ML+2*MU)*NEQ for MF = 24 or 25. -C 22 + 10*NEQ + (2*ML+MU)*NEQ for MF = -24 or -25. -C The first 20 words of RWORK are reserved for conditional -C and optional input and optional output. -C -C The following word in RWORK is a conditional input.. -C RWORK(1) = TCRIT = critical value of t which the solver -C is not to overshoot. Required if ITASK is -C 4 or 5, and ignored otherwise. (See ITASK.) -C -C LRW = The length of the array RWORK, as declared by the user. -C (This will be checked by the solver.) -C -C IWORK = An integer work array. The length of IWORK must be at least -C 30 if MITER = 0 or 3 (MF = 10, 13, 20, 23), or -C 30 + NEQ otherwise (abs(MF) = 11,12,14,15,21,22,24,25). -C The first 30 words of IWORK are reserved for conditional and -C optional input and optional output. -C -C The following 2 words in IWORK are conditional input.. -C IWORK(1) = ML These are the lower and upper -C IWORK(2) = MU half-bandwidths, respectively, of the -C banded Jacobian, excluding the main diagonal. -C The band is defined by the matrix locations -C (i,j) with i-ML .le. j .le. i+MU. ML and MU -C must satisfy 0 .le. ML,MU .le. NEQ-1. -C These are required if MITER is 4 or 5, and -C ignored otherwise. ML and MU may in fact be -C the band parameters for a matrix to which -C df/dy is only approximately equal. -C -C LIW = the length of the array IWORK, as declared by the user. -C (This will be checked by the solver.) -C -C Note.. The work arrays must not be altered between calls to DVODE -C for the same problem, except possibly for the conditional and -C optional input, and except for the last 3*NEQ words of RWORK. -C The latter space is used for internal scratch space, and so is -C available for use by the user outside DVODE between calls, if -C desired (but not for use by F or JAC). -C -C JAC = The name of the user-supplied routine (MITER = 1 or 4) to -C compute the Jacobian matrix, df/dy, as a function of -C the scalar t and the vector y. It is to have the form -C SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD, -C RPAR, IPAR) -C KPP_REAL T, Y, PD, RPAR -C DIMENSION Y(NEQ), PD(NROWPD, NEQ) -C where NEQ, T, Y, ML, MU, and NROWPD are input and the array -C PD is to be loaded with partial derivatives (elements of the -C Jacobian matrix) in the output. PD must be given a first -C dimension of NROWPD. T and Y have the same meaning as in -C Subroutine F. (In the DIMENSION statement above, NEQ can -C be replaced by * to make Y and PD assumed size arrays.) -C In the full matrix case (MITER = 1), ML and MU are -C ignored, and the Jacobian is to be loaded into PD in -C columnwise manner, with df(i)/dy(j) loaded into PD(i,j). -C In the band matrix case (MITER = 4), the elements -C within the band are to be loaded into PD in columnwise -C manner, with diagonal lines of df/dy loaded into the rows -C of PD. Thus df(i)/dy(j) is to be loaded into PD(i-j+MU+1,j). -C ML and MU are the half-bandwidth parameters. (See IWORK). -C The locations in PD in the two triangular areas which -C correspond to nonexistent matrix elements can be ignored -C or loaded arbitrarily, as they are overwritten by DVODE. -C JAC need not provide df/dy exactly. A crude -C approximation (possibly with a smaller bandwidth) will do. -C In either case, PD is preset to zero by the solver, -C so that only the nonzero elements need be loaded by JAC. -C Each CALL to JAC is preceded by a CALL to F with the same -C arguments NEQ, T, and Y. Thus to gain some efficiency, -C intermediate quantities shared by both calculations may be -C saved in a user COMMON block by F and not recomputed by JAC, -C if desired. Also, JAC may alter the Y array, if desired. -C JAC must be declared external in the calling program. -C Subroutine JAC may access user-defined real and integer -C work arrays, RPAR and IPAR, whose dimensions are set by the -C user in the main program. -C -C MF = The method flag. Used only for input. The legal values of -C MF are 10, 11, 12, 13, 14, 15, 20, 21, 22, 23, 24, 25, -C -11, -12, -14, -15, -21, -22, -24, -25. -C MF is a signed two-digit integer, MF = JSV*(10*METH + MITER). -C JSV = SIGN(MF) indicates the Jacobian-saving strategy.. -C JSV = 1 means a copy of the Jacobian is saved for reuse -C in the corrector iteration algorithm. -C JSV = -1 means a copy of the Jacobian is not saved -C (valid only for MITER = 1, 2, 4, or 5). -C METH indicates the basic linear multistep method.. -C METH = 1 means the implicit Adams method. -C METH = 2 means the method based on backward -C differentiation formulas (BDF-s). -C MITER indicates the corrector iteration method.. -C MITER = 0 means functional iteration (no Jacobian matrix -C is involved). -C MITER = 1 means chord iteration with a user-supplied -C full (NEQ by NEQ) Jacobian. -C MITER = 2 means chord iteration with an internally -C generated (difference quotient) full Jacobian -C (using NEQ extra calls to F per df/dy value). -C MITER = 3 means chord iteration with an internally -C generated diagonal Jacobian approximation -C (using 1 extra CALL to F per df/dy evaluation). -C MITER = 4 means chord iteration with a user-supplied -C banded Jacobian. -C MITER = 5 means chord iteration with an internally -C generated banded Jacobian (using ML+MU+1 extra -C calls to F per df/dy evaluation). -C If MITER = 1 or 4, the user must supply a subroutine JAC -C (the name is arbitrary) as described above under JAC. -C For other values of MITER, a dummy argument can be used. -C -C RPAR User-specified array used to communicate real parameters -C to user-supplied subroutines. If RPAR is a vector, then -C it must be dimensioned in the user's main program. If it -C is unused or it is a scalar, then it need not be -C dimensioned. -C -C IPAR User-specified array used to communicate integer parameter -C to user-supplied subroutines. The comments on dimensioning -C RPAR apply to IPAR. -C----------------------------------------------------------------------- -C Optional Input. -C -C The following is a list of the optional input provided for in the -C CALL sequence. (See also Part ii.) For each such input variable, -C this table lists its name as used in this documentation, its -C location in the CALL sequence, its meaning, and the default value. -C The use of any of this input requires IOPT = 1, and in that -C case all of this input is examined. A value of zero for any -C of these optional input variables will cause the default value to be -C used. Thus to use a subset of the optional input, simply preload -C locations 5 to 10 in RWORK and IWORK to 0.0 and 0 respectively, and -C then set those of interest to nonzero values. -C -C NAME LOCATION MEANING AND DEFAULT VALUE -C -C H0 RWORK(5) The step size to be attempted on the first step. -C The default value is determined by the solver. -C -C HMAX RWORK(6) The maximum absolute step size allowed. -C The default value is infinite. -C -C HMIN RWORK(7) The minimum absolute step size allowed. -C The default value is 0. (This lower bound is not -C enforced on the final step before reaching TCRIT -C when ITASK = 4 or 5.) -C -C MAXORD IWORK(5) The maximum order to be allowed. The default -C value is 12 if METH = 1, and 5 if METH = 2. -C If MAXORD exceeds the default value, it will -C be reduced to the default value. -C If MAXORD is changed during the problem, it may -C cause the current order to be reduced. -C -C MXSTEP IWORK(6) Maximum number of (internally defined) steps -C allowed during one CALL to the solver. -C The default value is 500. -C -C MXHNIL IWORK(7) Maximum number of messages printed (per problem) -C warning that T + H = T on a step (H = step size). -C This must be positive to result in a non-default -C value. The default value is 10. -C -C----------------------------------------------------------------------- -C Optional Output. -C -C As optional additional output from DVODE, the variables listed -C below are quantities related to the performance of DVODE -C which are available to the user. These are communicated by way of -C the work arrays, but also have internal mnemonic names as shown. -C Except where stated otherwise, all of this output is defined -C on any successful return from DVODE, and on any return with -C ISTATE = -1, -2, -4, -5, or -6. On an illegal input return -C (ISTATE = -3), they will be unchanged from their existing values -C (if any), except possibly for TOLSF, LENRW, and LENIW. -C On any error return, output relevant to the error will be defined, -C as noted below. -C -C NAME LOCATION MEANING -C -C HU RWORK(11) The step size in t last used (successfully). -C -C HCUR RWORK(12) The step size to be attempted on the next step. -C -C TCUR RWORK(13) The current value of the independent variable -C which the solver has actually reached, i.e. the -C current internal mesh point in t. In the output, -C TCUR will always be at least as far from the -C initial value of t as the current argument T, -C but may be farther (if interpolation was done). -C -C TOLSF RWORK(14) A tolerance scale factor, greater than 1.0, -C computed when a request for too much accuracy was -C detected (ISTATE = -3 if detected at the start of -C the problem, ISTATE = -2 otherwise). If ITOL is -C left unaltered but RelTol and AbsTol are uniformly -C scaled up by a factor of TOLSF for the next call, -C then the solver is deemed likely to succeed. -C (The user may also ignore TOLSF and alter the -C tolerance parameters in any other way appropriate.) -C -C NST IWORK(11) The number of steps taken for the problem so far. -C -C NFE IWORK(12) The number of f evaluations for the problem so far. -C -C NJE IWORK(13) The number of Jacobian evaluations so far. -C -C NQU IWORK(14) The method order last used (successfully). -C -C NQCUR IWORK(15) The order to be attempted on the next step. -C -C IMXER IWORK(16) The index of the component of largest magnitude in -C the weighted local error vector ( e(i)/EWT(i) ), -C on an error return with ISTATE = -4 or -5. -C -C LENRW IWORK(17) The length of RWORK actually required. -C This is defined on normal returns and on an illegal -C input return for insufficient storage. -C -C LENIW IWORK(18) The length of IWORK actually required. -C This is defined on normal returns and on an illegal -C input return for insufficient storage. -C -C NLU IWORK(19) The number of matrix LU decompositions so far. -C -C NNI IWORK(20) The number of nonlinear (Newton) iterations so far. -C -C NCFN IWORK(21) The number of convergence failures of the nonlinear -C solver so far. -C -C NETF IWORK(22) The number of error test failures of the integrator -C so far. -C -C The following two arrays are segments of the RWORK array which -C may also be of interest to the user as optional output. -C For each array, the table below gives its internal name, -C its base address in RWORK, and its description. -C -C NAME BASE ADDRESS DESCRIPTION -C -C YH 21 The Nordsieck history array, of size NYH by -C (NQCUR + 1), where NYH is the initial value -C of NEQ. For j = 0,1,...,NQCUR, column j+1 -C of YH contains HCUR**j/factorial(j) times -C the j-th derivative of the interpolating -C polynomial currently representing the -C solution, evaluated at t = TCUR. -C -C ACOR LENRW-NEQ+1 Array of size NEQ used for the accumulated -C corrections on each step, scaled in the output -C to represent the estimated local error in Y -C on the last step. This is the vector e in -C the description of the error control. It is -C defined only on a successful return from DVODE. -C -C----------------------------------------------------------------------- -C Interrupting and Restarting -C -C If the integration of a given problem by DVODE is to be -C interrupted and then later continued, such as when restarting -C an interrupted run or alternating between two or more ODE problems, -C the user should save, following the return from the last DVODE call -C prior to the interruption, the contents of the CALL sequence -C variables and internal COMMON blocks, and later restore these -C values before the next DVODE CALL for that problem. To save -C and restore the COMMON blocks, use subroutine DVSRCO, as -C described below in part ii. -C -C In addition, if non-default values for either LUN or MFLAG are -C desired, an extra CALL to XSETUN and/or XSETF should be made just -C before continuing the integration. See Part ii below for details. -C -C----------------------------------------------------------------------- -C Part ii. Other Routines Callable. -C -C The following are optional calls which the user may make to -C gain additional capabilities in conjunction with DVODE. -C (The routines XSETUN and XSETF are designed to conform to the -C SLATEC error handling package.) -C -C FORM OF CALL FUNCTION -C CALL XSETUN(LUN) Set the logical unit number, LUN, for -C output of messages from DVODE, if -C the default is not desired. -C The default value of LUN is 6. -C -C CALL XSETF(MFLAG) Set a flag to control the printing of -C messages by DVODE. -C MFLAG = 0 means do not print. (Danger.. -C This risks losing valuable information.) -C MFLAG = 1 means print (the default). -C -C Either of the above calls may be made at -C any time and will take effect immediately. -C -C CALL DVSRCO(RSAV,ISAV,JOB) Saves and restores the contents of -C the internal COMMON blocks used by -C DVODE. (See Part iii below.) -C RSAV must be a real array of length 49 -C or more, and ISAV must be an integer -C array of length 40 or more. -C JOB=1 means save COMMON into RSAV/ISAV. -C JOB=2 means restore COMMON from RSAV/ISAV. -C DVSRCO is useful if one is -C interrupting a run and restarting -C later, or alternating between two or -C more problems solved with DVODE. -C -C CALL DVINDY(,,,,,) Provide derivatives of y, of various -C (See below.) orders, at a specified point T, if -C desired. It may be called only after -C a successful return from DVODE. -C -C The detailed instructions for using DVINDY are as follows. -C The form of the CALL is.. -C -C CALL DVINDY (T, K, RWORK(21), NYH, DKY, IFLAG) -C -C The input parameters are.. -C -C T = Value of independent variable where answers are desired -C (normally the same as the T last returned by DVODE). -C For valid results, T must lie between TCUR - HU and TCUR. -C (See optional output for TCUR and HU.) -C K = Integer order of the derivative desired. K must satisfy -C 0 .le. K .le. NQCUR, where NQCUR is the current order -C (see optional output). The capability corresponding -C to K = 0, i.e. computing y(T), is already provided -C by DVODE directly. Since NQCUR .ge. 1, the first -C derivative dy/dt is always available with DVINDY. -C RWORK(21) = The base address of the history array YH. -C NYH = Column length of YH, equal to the initial value of NEQ. -C -C The output parameters are.. -C -C DKY = A real array of length NEQ containing the computed value -C of the K-th derivative of y(t). -C IFLAG = Integer flag, returned as 0 if K and T were legal, -C -1 if K was illegal, and -2 if T was illegal. -C On an error return, a message is also written. -C----------------------------------------------------------------------- -C Part iii. COMMON Blocks. -C If DVODE is to be used in an overlay situation, the user -C must declare, in the primary overlay, the variables in.. -C (1) the CALL sequence to DVODE, -C (2) the two internal COMMON blocks -C /DVOD01/ of length 81 (48 KPP_REAL words -C followed by 33 integer words), -C /DVOD02/ of length 9 (1 KPP_REAL word -C followed by 8 integer words), -C -C If DVODE is used on a system in which the contents of internal -C COMMON blocks are not preserved between calls, the user should -C declare the above two COMMON blocks in his main program to insure -C that their contents are preserved. -C -C----------------------------------------------------------------------- -C Part iv. Optionally Replaceable Solver Routines. -C -C Below are descriptions of two routines in the DVODE package which -C relate to the measurement of errors. Either routine can be -C replaced by a user-supplied version, if desired. However, since such -C a replacement may have a major impact on performance, it should be -C done only when absolutely necessary, and only with great caution. -C (Note.. The means by which the package version of a routine is -C superseded by the user's version may be system-dependent.) -C -C (a) DEWSET. -C The following subroutine is called just before each internal -C integration step, and sets the array of error weights, EWT, as -C described under ITOL/RelTol/AbsTol above.. -C SUBROUTINE DEWSET (NEQ, ITOL, RelTol, AbsTol, YCUR, EWT) -C where NEQ, ITOL, RelTol, and AbsTol are as in the DVODE CALL sequence, -C YCUR contains the current dependent variable vector, and -C EWT is the array of weights set by DEWSET. -C -C If the user supplies this subroutine, it must return in EWT(i) -C (i = 1,...,NEQ) a positive quantity suitable for comparison with -C errors in Y(i). The EWT array returned by DEWSET is passed to the -C DVNORM routine (See below.), and also used by DVODE in the computation -C of the optional output IMXER, the diagonal Jacobian approximation, -C and the increments for difference quotient Jacobians. -C -C In the user-supplied version of DEWSET, it may be desirable to use -C the current values of derivatives of y. Derivatives up to order NQ -C are available from the history array YH, described above under -C Optional Output. In DEWSET, YH is identical to the YCUR array, -C extended to NQ + 1 columns with a column length of NYH and scale -C factors of h**j/factorial(j). On the first CALL for the problem, -C given by NST = 0, NQ is 1 and H is temporarily set to 1.0. -C NYH is the initial value of NEQ. The quantities NQ, H, and NST -C can be obtained by including in DEWSET the statements.. -C KPP_REAL RVOD, H, HU -C COMMON /DVOD01/ RVOD(48), IVOD(33) -C COMMON /DVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST -C NQ = IVOD(28) -C H = RVOD(21) -C Thus, for example, the current value of dy/dt can be obtained as -C YCUR(NYH+i)/H (i=1,...,NEQ) (and the division by H is -C unnecessary when NST = 0). -C -C (b) DVNORM. -C The following is a real function routine which computes the weighted -C root-mean-square norm of a vector v.. -C D = DVNORM (N, V, W) -C where.. -C N = the length of the vector, -C V = real array of length N containing the vector, -C W = real array of length N containing weights, -C D = sqrt( (1/N) * sum(V(i)*W(i))**2 ). -C DVNORM is called with N = NEQ and with W(i) = 1.0/EWT(i), where -C EWT is as set by subroutine DEWSET. -C -C If the user supplies this function, it should return a non-negative -C value of DVNORM suitable for use in the error control in DVODE. -C None of the arguments should be altered by DVNORM. -C For example, a user-supplied DVNORM routine might.. -C -substitute a max-norm of (V(i)*W(i)) for the rms-norm, or -C -ignore some components of V in the norm, with the effect of -C suppressing the error control on those components of Y. -C----------------------------------------------------------------------- -C Other Routines in the DVODE Package. -C -C In addition to subroutine DVODE, the DVODE package includes the -C following subroutines and function routines.. -C DVHIN computes an approximate step size for the initial step. -C DVINDY computes an interpolated value of the y vector at t = TOUT. -C DVSTEP is the core integrator, which does one step of the -C integration and the associated error control. -C DVSET sets all method coefficients and test constants. -C DVNLSD solves the underlying nonlinear system -- the corrector. -C DVJAC computes and preprocesses the Jacobian matrix J = df/dy -C and the Newton iteration matrix P = I - (h/l1)*J. -C DVSOL manages solution of linear system in chord iteration. -C DVJUST adjusts the history array on a change of order. -C DEWSET sets the error weight vector EWT before each step. -C DVNORM computes the weighted r.m.s. norm of a vector. -C DVSRCO is a user-callable routines to save and restore -C the contents of the internal COMMON blocks. -C DACOPY is a routine to copy one two-dimensional array to another. -C DGEFA and DGESL are routines from LINPACK for solving full -C systems of linear algebraic equations. -C DGBFA and DGBSL are routines from LINPACK for solving banded -C linear systems. -C DAXPY, DSCAL, and DCOPY are basic linear algebra modules (BLAS). -C D1MACH sets the unit roundoff of the machine. -C XERRWD, XSETUN, XSETF, LUNSAV, and MFLGSV handle the printing of all -C error messages and warnings. XERRWD is machine-dependent. -C Note.. DVNORM, D1MACH, LUNSAV, and MFLGSV are function routines. -C All the others are subroutines. -C -C The intrinsic and external routines used by the DVODE package are.. -C ABS, MAX, MIN, REAL, SIGN, SQRT, and WRITE. -C -C----------------------------------------------------------------------- -C -C Type declarations for labeled COMMON block DVOD01 -------------------- -C - KPP_REAL ACNRM, CCMXJ, CONP, CRATE, DRC, EL, - 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, - 2 RC, RL1, TAU, TQ, TN, UROUND - INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, - 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, - 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, - 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, - 4 NSLP, NYH -C -C Type declarations for labeled COMMON block DVOD02 -------------------- -C - KPP_REAL HU - INTEGER NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST -C -C Type declarations for local variables -------------------------------- -C - EXTERNAL DVNLSD, F, JAC - LOGICAL IHIT - KPP_REAL AbsTolI, BIG, EWTI, FOUR, H0, HMAX, HMX, HUN, ONE, - 1 PT2, RH, RelTolI, SIZE, TCRIT, TNEXT, TOLSF, TP, TWO, ZERO - INTEGER I, IER, IFLAG, IMXER, JCO, KGO, LENIW, LENJ, LENP, LENRW, - 1 LENWM, LF0, MBAND, ML, MORD, MU, MXHNL0, MXSTP0, NITER, NSLAST - CHARACTER*80 MSG -C -C Type declaration for function subroutines called --------------------- -C - KPP_REAL D1MACH, DVNORM -C - DIMENSION MORD(2) -C----------------------------------------------------------------------- -C The following Fortran-77 declaration is to cause the values of the -C listed (local) variables to be saved between calls to DVODE. -C----------------------------------------------------------------------- - SAVE MORD, MXHNL0, MXSTP0 - SAVE ZERO, ONE, TWO, FOUR, PT2, HUN -C----------------------------------------------------------------------- -C The following internal COMMON blocks contain variables which are -C communicated between subroutines in the DVODE package, or which are -C to be saved between calls to DVODE. -C In each block, real variables precede integers. -C The block /DVOD01/ appears in subroutines DVODE, DVINDY, DVSTEP, -C DVSET, DVNLSD, DVJAC, DVSOL, DVJUST and DVSRCO. -C The block /DVOD02/ appears in subroutines DVODE, DVINDY, DVSTEP, -C DVNLSD, DVJAC, and DVSRCO. -C -C The variables stored in the internal COMMON blocks are as follows.. -C -C ACNRM = Weighted r.m.s. norm of accumulated correction vectors. -C CCMXJ = Threshhold on DRC for updating the Jacobian. (See DRC.) -C CONP = The saved value of TQ(5). -C CRATE = Estimated corrector convergence rate constant. -C DRC = Relative change in H*RL1 since last DVJAC call. -C EL = Real array of integration coefficients. See DVSET. -C ETA = Saved tentative ratio of new to old H. -C ETAMAX = Saved maximum value of ETA to be allowed. -C H = The step size. -C HMIN = The minimum absolute value of the step size H to be used. -C HMXI = Inverse of the maximum absolute value of H to be used. -C HMXI = 0.0 is allowed and corresponds to an infinite HMAX. -C HNEW = The step size to be attempted on the next step. -C HSCAL = Stepsize in scaling of YH array. -C PRL1 = The saved value of RL1. -C RC = Ratio of current H*RL1 to value on last DVJAC call. -C RL1 = The reciprocal of the coefficient EL(1). -C TAU = Real vector of past NQ step sizes, length 13. -C TQ = A real vector of length 5 in which DVSET stores constants -C used for the convergence test, the error test, and the -C selection of H at a new order. -C TN = The independent variable, updated on each step taken. -C UROUND = The machine unit roundoff. The smallest positive real number -C such that 1.0 + UROUND .ne. 1.0 -C ICF = Integer flag for convergence failure in DVNLSD.. -C 0 means no failures. -C 1 means convergence failure with out of date Jacobian -C (recoverable error). -C 2 means convergence failure with current Jacobian or -C singular matrix (unrecoverable error). -C INIT = Saved integer flag indicating whether initialization of the -C problem has been done (INIT = 1) or not. -C IPUP = Saved flag to signal updating of Newton matrix. -C JCUR = Output flag from DVJAC showing Jacobian status.. -C JCUR = 0 means J is not current. -C JCUR = 1 means J is current. -C JSTART = Integer flag used as input to DVSTEP.. -C 0 means perform the first step. -C 1 means take a new step continuing from the last. -C -1 means take the next step with a new value of MAXORD, -C HMIN, HMXI, N, METH, MITER, and/or matrix parameters. -C On return, DVSTEP sets JSTART = 1. -C JSV = Integer flag for Jacobian saving, = sign(MF). -C KFLAG = A completion code from DVSTEP with the following meanings.. -C 0 the step was succesful. -C -1 the requested error could not be achieved. -C -2 corrector convergence could not be achieved. -C -3, -4 fatal error in VNLS (can not occur here). -C KUTH = Input flag to DVSTEP showing whether H was reduced by the -C driver. KUTH = 1 if H was reduced, = 0 otherwise. -C L = Integer variable, NQ + 1, current order plus one. -C LMAX = MAXORD + 1 (used for dimensioning). -C LOCJS = A pointer to the saved Jacobian, whose storage starts at -C WM(LOCJS), if JSV = 1. -C LYH, LEWT, LACOR, LSAVF, LWM, LIWM = Saved integer pointers -C to segments of RWORK and IWORK. -C MAXORD = The maximum order of integration method to be allowed. -C METH/MITER = The method flags. See MF. -C MSBJ = The maximum number of steps between J evaluations, = 50. -C MXHNIL = Saved value of optional input MXHNIL. -C MXSTEP = Saved value of optional input MXSTEP. -C N = The number of first-order ODEs, = NEQ. -C NEWH = Saved integer to flag change of H. -C NEWQ = The method order to be used on the next step. -C NHNIL = Saved counter for occurrences of T + H = T. -C NQ = Integer variable, the current integration method order. -C NQNYH = Saved value of NQ*NYH. -C NQWAIT = A counter controlling the frequency of order changes. -C An order change is about to be considered if NQWAIT = 1. -C NSLJ = The number of steps taken as of the last Jacobian update. -C NSLP = Saved value of NST as of last Newton matrix update. -C NYH = Saved value of the initial value of NEQ. -C HU = The step size in t last used. -C NCFN = Number of nonlinear convergence failures so far. -C NETF = The number of error test failures of the integrator so far. -C NFE = The number of f evaluations for the problem so far. -C NJE = The number of Jacobian evaluations so far. -C NLU = The number of matrix LU decompositions so far. -C NNI = Number of nonlinear iterations so far. -C NQU = The method order last used. -C NST = The number of steps taken for the problem so far. -C----------------------------------------------------------------------- - COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), - 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, - 2 RC, RL1, TAU(13), TQ(5), TN, UROUND, - 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, - 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, - 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, - 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, - 7 NSLP, NYH - COMMON /DVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST -C - - DATA MORD(1) /12/, MORD(2) /5/, MXSTP0 /500/, MXHNL0 /10/ - DATA ZERO /0.0D0/, ONE /1.0D0/, TWO /2.0D0/, FOUR /4.0D0/, - 1 PT2 /0.2D0/, HUN /100.0D0/ -C----------------------------------------------------------------------- -C Block A. -C This code block is executed on every call. -C It tests ISTATE and ITASK for legality and branches appropriately. -C If ISTATE .gt. 1 but the flag INIT shows that initialization has -C not yet been done, an error return occurs. -C If ISTATE = 1 and TOUT = T, return immediately. -C----------------------------------------------------------------------- - IF (ISTATE .LT. 1 .OR. ISTATE .GT. 3) GO TO 601 - IF (ITASK .LT. 1 .OR. ITASK .GT. 5) GO TO 602 - IF (ISTATE .EQ. 1) GO TO 10 - IF (INIT .NE. 1) GO TO 603 - IF (ISTATE .EQ. 2) GO TO 200 - GO TO 20 - 10 INIT = 0 - IF (TOUT .EQ. T) RETURN -C----------------------------------------------------------------------- -C Block B. -C The next code block is executed for the initial CALL (ISTATE = 1), -C or for a continuation CALL with parameter changes (ISTATE = 3). -C It contains checking of all input and various initializations. -C -C First check legality of the non-optional input NEQ, ITOL, IOPT, -C MF, ML, and MU. -C----------------------------------------------------------------------- - 20 IF (NEQ .LE. 0) GO TO 604 - IF (ISTATE .EQ. 1) GO TO 25 - IF (NEQ .GT. N) GO TO 605 - 25 N = NEQ - IF (ITOL .LT. 1 .OR. ITOL .GT. 4) GO TO 606 - IF (IOPT .LT. 0 .OR. IOPT .GT. 1) GO TO 607 - JSV = SIGN(1,MF) - MF = ABS(MF) - METH = MF/10 - MITER = MF - 10*METH - IF (METH .LT. 1 .OR. METH .GT. 2) GO TO 608 - IF (MITER .LT. 0 .OR. MITER .GT. 5) GO TO 608 - IF (MITER .LE. 3) GO TO 30 - ML = IWORK(1) - MU = IWORK(2) - IF (ML .LT. 0 .OR. ML .GE. N) GO TO 609 - IF (MU .LT. 0 .OR. MU .GE. N) GO TO 610 - 30 CONTINUE -C Next process and check the optional input. --------------------------- - IF (IOPT .EQ. 1) GO TO 40 - MAXORD = MORD(METH) - MXSTEP = MXSTP0 - MXHNIL = MXHNL0 - IF (ISTATE .EQ. 1) H0 = ZERO - HMXI = ZERO - HMIN = ZERO - GO TO 60 - 40 MAXORD = IWORK(5) - IF (MAXORD .LT. 0) GO TO 611 - IF (MAXORD .EQ. 0) MAXORD = 100 - MAXORD = MIN(MAXORD,MORD(METH)) - MXSTEP = IWORK(6) - IF (MXSTEP .LT. 0) GO TO 612 - IF (MXSTEP .EQ. 0) MXSTEP = MXSTP0 - MXHNIL = IWORK(7) - IF (MXHNIL .LT. 0) GO TO 613 - IF (MXHNIL .EQ. 0) MXHNIL = MXHNL0 - IF (ISTATE .NE. 1) GO TO 50 - H0 = RWORK(5) - IF ((TOUT - T)*H0 .LT. ZERO) GO TO 614 - 50 HMAX = RWORK(6) - IF (HMAX .LT. ZERO) GO TO 615 - HMXI = ZERO - IF (HMAX .GT. ZERO) HMXI = ONE/HMAX - HMIN = RWORK(7) - IF (HMIN .LT. ZERO) GO TO 616 -C----------------------------------------------------------------------- -C Set work array pointers and check lengths LRW and LIW. -C Pointers to segments of RWORK and IWORK are named by prefixing L to -C the name of the segment. E.g., the segment YH starts at RWORK(LYH). -C Segments of RWORK (in order) are denoted YH, WM, EWT, SAVF, ACOR. -C Within WM, LOCJS is the location of the saved Jacobian (JSV .gt. 0). -C----------------------------------------------------------------------- - 60 LYH = 21 - IF (ISTATE .EQ. 1) NYH = N - LWM = LYH + (MAXORD + 1)*NYH - JCO = MAX(0,JSV) - IF (MITER .EQ. 0) LENWM = 0 - IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN - LENWM = 2 + (1 + JCO)*N*N - LOCJS = N*N + 3 - ENDIF - IF (MITER .EQ. 3) LENWM = 2 + N - IF (MITER .EQ. 4 .OR. MITER .EQ. 5) THEN - MBAND = ML + MU + 1 - LENP = (MBAND + ML)*N - LENJ = MBAND*N - LENWM = 2 + LENP + JCO*LENJ - LOCJS = LENP + 3 - ENDIF - LEWT = LWM + LENWM - LSAVF = LEWT + N - LACOR = LSAVF + N - LENRW = LACOR + N - 1 - IWORK(17) = LENRW - LIWM = 1 - LENIW = 30 + N - IF (MITER .EQ. 0 .OR. MITER .EQ. 3) LENIW = 30 - IWORK(18) = LENIW - IF (LENRW .GT. LRW) GO TO 617 - IF (LENIW .GT. LIW) GO TO 618 -C Check RelTol and AbsTol for legality. ------------------------------------ - RelTolI = RelTol(1) - AbsTolI = AbsTol(1) - DO 70 I = 1,N - IF (ITOL .GE. 3) RelTolI = RelTol(I) - IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) AbsTolI = AbsTol(I) - IF (RelTolI .LT. ZERO) GO TO 619 - IF (AbsTolI .LT. ZERO) GO TO 620 - 70 CONTINUE - IF (ISTATE .EQ. 1) GO TO 100 -C If ISTATE = 3, set flag to signal parameter changes to DVSTEP. ------- - JSTART = -1 - IF (NQ .LE. MAXORD) GO TO 90 -C MAXORD was reduced below NQ. Copy YH(*,MAXORD+2) into SAVF. --------- - CALL DCOPY (N, RWORK(LWM), 1, RWORK(LSAVF), 1) -C Reload WM(1) = RWORK(LWM), since LWM may have changed. --------------- - 90 IF (MITER .GT. 0) RWORK(LWM) = SQRT(UROUND) -C----------------------------------------------------------------------- -C Block C. -C The next block is for the initial CALL only (ISTATE = 1). -C It contains all remaining initializations, the initial CALL to F, -C and the calculation of the initial step size. -C The error weights in EWT are inverted after being loaded. -C----------------------------------------------------------------------- - 100 UROUND = D1MACH(4) - TN = T - IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 110 - TCRIT = RWORK(1) - IF ((TCRIT - TOUT)*(TOUT - T) .LT. ZERO) GO TO 625 - IF (H0 .NE. ZERO .AND. (T + H0 - TCRIT)*H0 .GT. ZERO) - 1 H0 = TCRIT - T - 110 JSTART = 0 - IF (MITER .GT. 0) RWORK(LWM) = SQRT(UROUND) - CCMXJ = PT2 - MSBJ = 50 - NHNIL = 0 - NST = 0 - NJE = 0 - NNI = 0 - NCFN = 0 - NETF = 0 - NLU = 0 - NSLJ = 0 - NSLAST = 0 - HU = ZERO - NQU = 0 -C Initial CALL to F. (LF0 points to YH(*,2).) ------------------------- - LF0 = LYH + NYH - CALL F (N, T, Y, RWORK(LF0)) - NFE = 1 -C Load the initial value vector in YH. --------------------------------- - CALL DCOPY (N, Y, 1, RWORK(LYH), 1) -C Load and invert the EWT array. (H is temporarily set to 1.0.) ------- - NQ = 1 - H = ONE - CALL DEWSET (N, ITOL, RelTol, AbsTol, RWORK(LYH), RWORK(LEWT)) - DO 120 I = 1,N - IF (RWORK(I+LEWT-1) .LE. ZERO) GO TO 621 - 120 RWORK(I+LEWT-1) = ONE/RWORK(I+LEWT-1) - IF (H0 .NE. ZERO) GO TO 180 -C Call DVHIN to set initial step size H0 to be attempted. -------------- - CALL DVHIN (N, T, RWORK(LYH), RWORK(LF0), F, RPAR, IPAR, TOUT, - 1 UROUND, RWORK(LEWT), ITOL, AbsTol, Y, RWORK(LACOR), H0, - 2 NITER, IER) - NFE = NFE + NITER - IF (IER .NE. 0) GO TO 622 -C Adjust H0 if necessary to meet HMAX bound. --------------------------- - 180 RH = ABS(H0)*HMXI - IF (RH .GT. ONE) H0 = H0/RH -C Load H with H0 and scale YH(*,2) by H0. ------------------------------ - H = H0 - CALL DSCAL (N, H0, RWORK(LF0), 1) - GO TO 270 -C----------------------------------------------------------------------- -C Block D. -C The next code block is for continuation calls only (ISTATE = 2 or 3) -C and is to check stop conditions before taking a step. -C----------------------------------------------------------------------- - 200 NSLAST = NST - KUTH = 0 - GO TO (210, 250, 220, 230, 240), ITASK - 210 IF ((TN - TOUT)*H .LT. ZERO) GO TO 250 - CALL DVINDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) - IF (IFLAG .NE. 0) GO TO 627 - T = TOUT - GO TO 420 - 220 TP = TN - HU*(ONE + HUN*UROUND) - IF ((TP - TOUT)*H .GT. ZERO) GO TO 623 - IF ((TN - TOUT)*H .LT. ZERO) GO TO 250 - GO TO 400 - 230 TCRIT = RWORK(1) - IF ((TN - TCRIT)*H .GT. ZERO) GO TO 624 - IF ((TCRIT - TOUT)*H .LT. ZERO) GO TO 625 - IF ((TN - TOUT)*H .LT. ZERO) GO TO 245 - CALL DVINDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) - IF (IFLAG .NE. 0) GO TO 627 - T = TOUT - GO TO 420 - 240 TCRIT = RWORK(1) - IF ((TN - TCRIT)*H .GT. ZERO) GO TO 624 - 245 HMX = ABS(TN) + ABS(H) - IHIT = ABS(TN - TCRIT) .LE. HUN*UROUND*HMX - IF (IHIT) GO TO 400 - TNEXT = TN + HNEW*(ONE + FOUR*UROUND) - IF ((TNEXT - TCRIT)*H .LE. ZERO) GO TO 250 - H = (TCRIT - TN)*(ONE - FOUR*UROUND) - KUTH = 1 -C----------------------------------------------------------------------- -C Block E. -C The next block is normally executed for all calls and contains -C the CALL to the one-step core integrator DVSTEP. -C -C This is a looping point for the integration steps. -C -C First check for too many steps being taken, update EWT (if not at -C start of problem), check for too much accuracy being requested, and -C check for H below the roundoff level in T. -C----------------------------------------------------------------------- - 250 CONTINUE - IF ((NST-NSLAST) .GE. MXSTEP) GO TO 500 - CALL DEWSET (N, ITOL, RelTol, AbsTol, RWORK(LYH), RWORK(LEWT)) - DO 260 I = 1,N - IF (RWORK(I+LEWT-1) .LE. ZERO) GO TO 510 - 260 RWORK(I+LEWT-1) = ONE/RWORK(I+LEWT-1) - 270 TOLSF = UROUND*DVNORM (N, RWORK(LYH), RWORK(LEWT)) - IF (TOLSF .LE. ONE) GO TO 280 - TOLSF = TOLSF*TWO - IF (NST .EQ. 0) GO TO 626 - GO TO 520 - 280 IF ((TN + H) .NE. TN) GO TO 290 - NHNIL = NHNIL + 1 - IF (NHNIL .GT. MXHNIL) GO TO 290 - MSG = 'DVODE-- Warning..internal T (=R1) and H (=R2) are' - CALL XERRWD (MSG, 50, 101, 1, 0, 0, 0, 0, ZERO, ZERO) - MSG=' such that in the machine, T + H = T on the next step ' - CALL XERRWD (MSG, 60, 101, 1, 0, 0, 0, 0, ZERO, ZERO) - MSG = ' (H = step size). solver will continue anyway' - CALL XERRWD (MSG, 50, 101, 1, 0, 0, 0, 2, TN, H) - IF (NHNIL .LT. MXHNIL) GO TO 290 - MSG = 'DVODE-- Above warning has been issued I1 times. ' - CALL XERRWD (MSG, 50, 102, 1, 0, 0, 0, 0, ZERO, ZERO) - MSG = ' it will not be issued again for this problem' - CALL XERRWD (MSG, 50, 102, 1, 1, MXHNIL, 0, 0, ZERO, ZERO) - 290 CONTINUE -C----------------------------------------------------------------------- -C CALL DVSTEP (Y, YH, NYH, YH, EWT, SAVF, VSAV, ACOR, -C WM, IWM, F, JAC, F, DVNLSD, RPAR, IPAR) -C----------------------------------------------------------------------- - CALL DVSTEP (Y, RWORK(LYH), NYH, RWORK(LYH), RWORK(LEWT), - 1 RWORK(LSAVF), Y, RWORK(LACOR), RWORK(LWM), IWORK(LIWM), - 2 F, JAC, F, DVNLSD, RPAR, IPAR) - KGO = 1 - KFLAG -C Branch on KFLAG. Note..In this version, KFLAG can not be set to -3. -C KFLAG .eq. 0, -1, -2 - GO TO (300, 530, 540), KGO -C----------------------------------------------------------------------- -C Block F. -C The following block handles the case of a successful return from the -C core integrator (KFLAG = 0). Test for stop conditions. -C----------------------------------------------------------------------- - 300 INIT = 1 - KUTH = 0 - GO TO (310, 400, 330, 340, 350), ITASK -C ITASK = 1. If TOUT has been reached, interpolate. ------------------- - 310 IF ((TN - TOUT)*H .LT. ZERO) GO TO 250 - CALL DVINDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) - T = TOUT - GO TO 420 -C ITASK = 3. Jump to exit if TOUT was reached. ------------------------ - 330 IF ((TN - TOUT)*H .GE. ZERO) GO TO 400 - GO TO 250 -C ITASK = 4. See if TOUT or TCRIT was reached. Adjust H if necessary. - 340 IF ((TN - TOUT)*H .LT. ZERO) GO TO 345 - CALL DVINDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) - T = TOUT - GO TO 420 - 345 HMX = ABS(TN) + ABS(H) - IHIT = ABS(TN - TCRIT) .LE. HUN*UROUND*HMX - IF (IHIT) GO TO 400 - TNEXT = TN + HNEW*(ONE + FOUR*UROUND) - IF ((TNEXT - TCRIT)*H .LE. ZERO) GO TO 250 - H = (TCRIT - TN)*(ONE - FOUR*UROUND) - KUTH = 1 - GO TO 250 -C ITASK = 5. See if TCRIT was reached and jump to exit. --------------- - 350 HMX = ABS(TN) + ABS(H) - IHIT = ABS(TN - TCRIT) .LE. HUN*UROUND*HMX -C----------------------------------------------------------------------- -C Block G. -C The following block handles all successful returns from DVODE. -C If ITASK .ne. 1, Y is loaded from YH and T is set accordingly. -C ISTATE is set to 2, and the optional output is loaded into the work -C arrays before returning. -C----------------------------------------------------------------------- - 400 CONTINUE - CALL DCOPY (N, RWORK(LYH), 1, Y, 1) - T = TN - IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 420 - IF (IHIT) T = TCRIT - 420 ISTATE = 2 - RWORK(11) = HU - RWORK(12) = HNEW - RWORK(13) = TN - IWORK(11) = NST - IWORK(12) = NFE - IWORK(13) = NJE - IWORK(14) = NQU - IWORK(15) = NEWQ - IWORK(19) = NLU - IWORK(20) = NNI - IWORK(21) = NCFN - IWORK(22) = NETF - RETURN -C----------------------------------------------------------------------- -C Block H. -C The following block handles all unsuccessful returns other than -C those for illegal input. First the error message routine is called. -C if there was an error test or convergence test failure, IMXER is set. -C Then Y is loaded from YH, T is set to TN, and the illegal input -C The optional output is loaded into the work arrays before returning. -C----------------------------------------------------------------------- -C The maximum number of steps was taken before reaching TOUT. ---------- - 500 MSG = 'DVODE-- At current T (=R1), MXSTEP (=I1) steps ' - CALL XERRWD (MSG, 50, 201, 1, 0, 0, 0, 0, ZERO, ZERO) - MSG = ' taken on this CALL before reaching TOUT ' - CALL XERRWD (MSG, 50, 201, 1, 1, MXSTEP, 0, 1, TN, ZERO) - ISTATE = -1 - GO TO 580 -C EWT(i) .le. 0.0 for some i (not at start of problem). ---------------- - 510 EWTI = RWORK(LEWT+I-1) - MSG = 'DVODE-- At T (=R1), EWT(I1) has become R2 .le. 0.' - CALL XERRWD (MSG, 50, 202, 1, 1, I, 0, 2, TN, EWTI) - ISTATE = -6 - GO TO 580 -C Too much accuracy requested for machine precision. ------------------- - 520 MSG = 'DVODE-- At T (=R1), too much accuracy requested ' - CALL XERRWD (MSG, 50, 203, 1, 0, 0, 0, 0, ZERO, ZERO) - MSG = ' for precision of machine.. see TOLSF (=R2) ' - CALL XERRWD (MSG, 50, 203, 1, 0, 0, 0, 2, TN, TOLSF) - RWORK(14) = TOLSF - ISTATE = -2 - GO TO 580 -C KFLAG = -1. Error test failed repeatedly or with ABS(H) = HMIN. ----- - 530 MSG = 'DVODE-- At T(=R1) and step size H(=R2), the error' - CALL XERRWD (MSG, 50, 204, 1, 0, 0, 0, 0, ZERO, ZERO) - MSG = ' test failed repeatedly or with abs(H) = HMIN' - CALL XERRWD (MSG, 50, 204, 1, 0, 0, 0, 2, TN, H) - ISTATE = -4 - GO TO 560 -C KFLAG = -2. Convergence failed repeatedly or with abs(H) = HMIN. ---- - 540 MSG = 'DVODE-- At T (=R1) and step size H (=R2), the ' - CALL XERRWD (MSG, 50, 205, 1, 0, 0, 0, 0, ZERO, ZERO) - MSG = ' corrector convergence failed repeatedly ' - CALL XERRWD (MSG, 50, 205, 1, 0, 0, 0, 0, ZERO, ZERO) - MSG = ' or with abs(H) = HMIN ' - CALL XERRWD (MSG, 30, 205, 1, 0, 0, 0, 2, TN, H) - ISTATE = -5 -C Compute IMXER if relevant. ------------------------------------------- - 560 BIG = ZERO - IMXER = 1 - DO 570 I = 1,N - SIZE = ABS(RWORK(I+LACOR-1)*RWORK(I+LEWT-1)) - IF (BIG .GE. SIZE) GO TO 570 - BIG = SIZE - IMXER = I - 570 CONTINUE - IWORK(16) = IMXER -C Set Y vector, T, and optional output. -------------------------------- - 580 CONTINUE - CALL DCOPY (N, RWORK(LYH), 1, Y, 1) - T = TN - RWORK(11) = HU - RWORK(12) = H - RWORK(13) = TN - IWORK(11) = NST - IWORK(12) = NFE - IWORK(13) = NJE - IWORK(14) = NQU - IWORK(15) = NQ - IWORK(19) = NLU - IWORK(20) = NNI - IWORK(21) = NCFN - IWORK(22) = NETF - RETURN -C----------------------------------------------------------------------- -C Block I. -C The following block handles all error returns due to illegal input -C (ISTATE = -3), as detected before calling the core integrator. -C First the error message routine is called. If the illegal input -C is a negative ISTATE, the run is aborted (apparent infinite loop). -C----------------------------------------------------------------------- - 601 MSG = 'DVODE-- ISTATE (=I1) illegal ' - CALL XERRWD (MSG, 30, 1, 1, 1, ISTATE, 0, 0, ZERO, ZERO) - IF (ISTATE .LT. 0) GO TO 800 - GO TO 700 - 602 MSG = 'DVODE-- ITASK (=I1) illegal ' - CALL XERRWD (MSG, 30, 2, 1, 1, ITASK, 0, 0, ZERO, ZERO) - GO TO 700 - 603 MSG='DVODE-- ISTATE (=I1) .gt. 1 but DVODE not initialized ' - CALL XERRWD (MSG, 60, 3, 1, 1, ISTATE, 0, 0, ZERO, ZERO) - GO TO 700 - 604 MSG = 'DVODE-- NEQ (=I1) .lt. 1 ' - CALL XERRWD (MSG, 30, 4, 1, 1, NEQ, 0, 0, ZERO, ZERO) - GO TO 700 - 605 MSG = 'DVODE-- ISTATE = 3 and NEQ increased (I1 to I2) ' - CALL XERRWD (MSG, 50, 5, 1, 2, N, NEQ, 0, ZERO, ZERO) - GO TO 700 - 606 MSG = 'DVODE-- ITOL (=I1) illegal ' - CALL XERRWD (MSG, 30, 6, 1, 1, ITOL, 0, 0, ZERO, ZERO) - GO TO 700 - 607 MSG = 'DVODE-- IOPT (=I1) illegal ' - CALL XERRWD (MSG, 30, 7, 1, 1, IOPT, 0, 0, ZERO, ZERO) - GO TO 700 - 608 MSG = 'DVODE-- MF (=I1) illegal ' - CALL XERRWD (MSG, 30, 8, 1, 1, MF, 0, 0, ZERO, ZERO) - GO TO 700 - 609 MSG = 'DVODE-- ML (=I1) illegal.. .lt.0 or .ge.NEQ (=I2)' - CALL XERRWD (MSG, 50, 9, 1, 2, ML, NEQ, 0, ZERO, ZERO) - GO TO 700 - 610 MSG = 'DVODE-- MU (=I1) illegal.. .lt.0 or .ge.NEQ (=I2)' - CALL XERRWD (MSG, 50, 10, 1, 2, MU, NEQ, 0, ZERO, ZERO) - GO TO 700 - 611 MSG = 'DVODE-- MAXORD (=I1) .lt. 0 ' - CALL XERRWD (MSG, 30, 11, 1, 1, MAXORD, 0, 0, ZERO, ZERO) - GO TO 700 - 612 MSG = 'DVODE-- MXSTEP (=I1) .lt. 0 ' - CALL XERRWD (MSG, 30, 12, 1, 1, MXSTEP, 0, 0, ZERO, ZERO) - GO TO 700 - 613 MSG = 'DVODE-- MXHNIL (=I1) .lt. 0 ' - CALL XERRWD (MSG, 30, 13, 1, 1, MXHNIL, 0, 0, ZERO, ZERO) - GO TO 700 - 614 MSG = 'DVODE-- TOUT (=R1) behind T (=R2) ' - CALL XERRWD (MSG, 40, 14, 1, 0, 0, 0, 2, TOUT, T) - MSG = ' integration direction is given by H0 (=R1) ' - CALL XERRWD (MSG, 50, 14, 1, 0, 0, 0, 1, H0, ZERO) - GO TO 700 - 615 MSG = 'DVODE-- HMAX (=R1) .lt. 0.0 ' - CALL XERRWD (MSG, 30, 15, 1, 0, 0, 0, 1, HMAX, ZERO) - GO TO 700 - 616 MSG = 'DVODE-- HMIN (=R1) .lt. 0.0 ' - CALL XERRWD (MSG, 30, 16, 1, 0, 0, 0, 1, HMIN, ZERO) - GO TO 700 - 617 CONTINUE - MSG='DVODE-- RWORK length needed, LENRW (=I1), exceeds LRW (=I2)' - CALL XERRWD (MSG, 60, 17, 1, 2, LENRW, LRW, 0, ZERO, ZERO) - GO TO 700 - 618 CONTINUE - MSG='DVODE-- IWORK length needed, LENIW (=I1), exceeds LIW (=I2)' - CALL XERRWD (MSG, 60, 18, 1, 2, LENIW, LIW, 0, ZERO, ZERO) - GO TO 700 - 619 MSG = 'DVODE-- RelTol(I1) is R1 .lt. 0.0 ' - CALL XERRWD (MSG, 40, 19, 1, 1, I, 0, 1, RelTolI, ZERO) - GO TO 700 - 620 MSG = 'DVODE-- AbsTol(I1) is R1 .lt. 0.0 ' - CALL XERRWD (MSG, 40, 20, 1, 1, I, 0, 1, AbsTolI, ZERO) - GO TO 700 - 621 EWTI = RWORK(LEWT+I-1) - MSG = 'DVODE-- EWT(I1) is R1 .le. 0.0 ' - CALL XERRWD (MSG, 40, 21, 1, 1, I, 0, 1, EWTI, ZERO) - GO TO 700 - 622 CONTINUE - MSG='DVODE-- TOUT (=R1) too close to T(=R2) to start integration' - CALL XERRWD (MSG, 60, 22, 1, 0, 0, 0, 2, TOUT, T) - GO TO 700 - 623 CONTINUE - MSG='DVODE-- ITASK = I1 and TOUT (=R1) behind TCUR - HU (= R2) ' - CALL XERRWD (MSG, 60, 23, 1, 1, ITASK, 0, 2, TOUT, TP) - GO TO 700 - 624 CONTINUE - MSG='DVODE-- ITASK = 4 or 5 and TCRIT (=R1) behind TCUR (=R2) ' - CALL XERRWD (MSG, 60, 24, 1, 0, 0, 0, 2, TCRIT, TN) - GO TO 700 - 625 CONTINUE - MSG='DVODE-- ITASK = 4 or 5 and TCRIT (=R1) behind TOUT (=R2) ' - CALL XERRWD (MSG, 60, 25, 1, 0, 0, 0, 2, TCRIT, TOUT) - GO TO 700 - 626 MSG = 'DVODE-- At start of problem, too much accuracy ' - CALL XERRWD (MSG, 50, 26, 1, 0, 0, 0, 0, ZERO, ZERO) - MSG=' requested for precision of machine.. see TOLSF (=R1) ' - CALL XERRWD (MSG, 60, 26, 1, 0, 0, 0, 1, TOLSF, ZERO) - RWORK(14) = TOLSF - GO TO 700 - 627 MSG='DVODE-- Trouble from DVINDY. ITASK = I1, TOUT = R1. ' - CALL XERRWD (MSG, 60, 27, 1, 1, ITASK, 0, 1, TOUT, ZERO) -C - 700 CONTINUE - ISTATE = -3 - RETURN -C - 800 MSG = 'DVODE-- Run aborted.. apparent infinite loop ' - CALL XERRWD (MSG, 50, 303, 2, 0, 0, 0, 0, ZERO, ZERO) - RETURN -C----------------------- End of Subroutine DVODE ----------------------- - END -*DECK DVHIN - SUBROUTINE DVHIN (N, T0, Y0, YDOT, F, RPAR, IPAR, TOUT, UROUND, - 1 EWT, ITOL, AbsTol, Y, TEMP, H0, NITER, IER) - EXTERNAL F - KPP_REAL T0, Y0, YDOT, RPAR, TOUT, UROUND, EWT, AbsTol, Y, - 1 TEMP, H0 - INTEGER N, IPAR, ITOL, NITER, IER - DIMENSION Y0(*), YDOT(*), EWT(*), AbsTol(*), Y(*), - 1 TEMP(*), RPAR(*), IPAR(*) -C----------------------------------------------------------------------- -C Call sequence input -- N, T0, Y0, YDOT, F, RPAR, IPAR, TOUT, UROUND, -C EWT, ITOL, AbsTol, Y, TEMP -C Call sequence output -- H0, NITER, IER -C COMMON block variables accessed -- None -C -C Subroutines called by DVHIN.. F -C Function routines called by DVHIN.. DVNORM -C----------------------------------------------------------------------- -C This routine computes the step size, H0, to be attempted on the -C first step, when the user has not supplied a value for this. -C -C First we check that TOUT - T0 differs significantly from zero. Then -C an iteration is done to approximate the initial second derivative -C and this is used to define h from w.r.m.s.norm(h**2 * yddot / 2) = 1. -C A bias factor of 1/2 is applied to the resulting h. -C The sign of H0 is inferred from the initial values of TOUT and T0. -C -C Communication with DVHIN is done with the following variables.. -C -C N = Size of ODE system, input. -C T0 = Initial value of independent variable, input. -C Y0 = Vector of initial conditions, input. -C YDOT = Vector of initial first derivatives, input. -C F = Name of subroutine for right-hand side f(t,y), input. -C RPAR, IPAR = Dummy names for user's real and integer work arrays. -C TOUT = First output value of independent variable -C UROUND = Machine unit roundoff -C EWT, ITOL, AbsTol = Error weights and tolerance parameters -C as described in the driver routine, input. -C Y, TEMP = Work arrays of length N. -C H0 = Step size to be attempted, output. -C NITER = Number of iterations (and of f evaluations) to compute H0, -C output. -C IER = The error flag, returned with the value -C IER = 0 if no trouble occurred, or -C IER = -1 if TOUT and T0 are considered too close to proceed. -C----------------------------------------------------------------------- -C -C Type declarations for local variables -------------------------------- -C - KPP_REAL AFI, AbsTolI, DELYI, HALF, HG, HLB, HNEW, HRAT, - 1 HUB, HUN, PT1, T1, TDIST, TROUND, TWO, YDDNRM - INTEGER I, ITER - -C -C Type declaration for function subroutines called --------------------- -C - KPP_REAL DVNORM -C----------------------------------------------------------------------- -C The following Fortran-77 declaration is to cause the values of the -C listed (local) variables to be saved between calls to this integrator. -C----------------------------------------------------------------------- - SAVE HALF, HUN, PT1, TWO - DATA HALF /0.5D0/, HUN /100.0D0/, PT1 /0.1D0/, TWO /2.0D0/ -C - NITER = 0 - TDIST = ABS(TOUT - T0) - TROUND = UROUND*MAX(ABS(T0),ABS(TOUT)) - IF (TDIST .LT. TWO*TROUND) GO TO 100 -C -C Set a lower bound on h based on the roundoff level in T0 and TOUT. --- - HLB = HUN*TROUND -C Set an upper bound on h based on TOUT-T0 and the initial Y and YDOT. - - HUB = PT1*TDIST - AbsTolI = AbsTol(1) - DO 10 I = 1, N - IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) AbsTolI = AbsTol(I) - DELYI = PT1*ABS(Y0(I)) + AbsTolI - AFI = ABS(YDOT(I)) - IF (AFI*HUB .GT. DELYI) HUB = DELYI/AFI - 10 CONTINUE -C -C Set initial guess for h as geometric mean of upper and lower bounds. - - ITER = 0 - HG = SQRT(HLB*HUB) -C If the bounds have crossed, exit with the mean value. ---------------- - IF (HUB .LT. HLB) THEN - H0 = HG - GO TO 90 - ENDIF -C -C Looping point for iteration. ----------------------------------------- - 50 CONTINUE -C Estimate the second derivative as a difference quotient in f. -------- - T1 = T0 + HG - DO 60 I = 1, N - 60 Y(I) = Y0(I) + HG*YDOT(I) - CALL F (N, T1, Y, TEMP) - DO 70 I = 1, N - 70 TEMP(I) = (TEMP(I) - YDOT(I))/HG - YDDNRM = DVNORM (N, TEMP, EWT) -C Get the corresponding new value of h. -------------------------------- - IF (YDDNRM*HUB*HUB .GT. TWO) THEN - HNEW = SQRT(TWO/YDDNRM) - ELSE - HNEW = SQRT(HG*HUB) - ENDIF - ITER = ITER + 1 -C----------------------------------------------------------------------- -C Test the stopping conditions. -C Stop if the new and previous h values differ by a factor of .lt. 2. -C Stop if four iterations have been done. Also, stop with previous h -C if HNEW/HG .gt. 2 after first iteration, as this probably means that -C the second derivative value is bad because of cancellation error. -C----------------------------------------------------------------------- - IF (ITER .GE. 4) GO TO 80 - HRAT = HNEW/HG -C AICI - IF ( (HRAT .GT. HALF) .AND. (HRAT .LT. TWO) ) GO TO 80 - IF ( (ITER .GE. 2) .AND. (HNEW .GT. TWO*HG) ) THEN - HNEW = HG - GO TO 80 - ENDIF - HG = HNEW - GO TO 50 -C -C Iteration done. Apply bounds, bias factor, and sign. Then exit. ---- - 80 H0 = HNEW*HALF - IF (H0 .LT. HLB) H0 = HLB - IF (H0 .GT. HUB) H0 = HUB - 90 H0 = SIGN(H0, TOUT - T0) - NITER = ITER - IER = 0 - RETURN -C Error return for TOUT - T0 too small. -------------------------------- - 100 IER = -1 - RETURN -C----------------------- End of Subroutine DVHIN ----------------------- - END -*DECK DVINDY - SUBROUTINE DVINDY (T, K, YH, LDYH, DKY, IFLAG) - KPP_REAL T, YH, DKY - INTEGER K, LDYH, IFLAG - DIMENSION YH(LDYH,*), DKY(*) -C----------------------------------------------------------------------- -C Call sequence input -- T, K, YH, LDYH -C Call sequence output -- DKY, IFLAG -C COMMON block variables accessed.. -C /DVOD01/ -- H, TN, UROUND, L, N, NQ -C /DVOD02/ -- HU -C -C Subroutines called by DVINDY.. DSCAL, XERRWD -C Function routines called by DVINDY.. None -C----------------------------------------------------------------------- -C DVINDY computes interpolated values of the K-th derivative of the -C dependent variable vector y, and stores it in DKY. This routine -C is called within the package with K = 0 and T = TOUT, but may -C also be called by the user for any K up to the current order. -C (See detailed instructions in the usage documentation.) -C----------------------------------------------------------------------- -C The computed values in DKY are gotten by interpolation using the -C Nordsieck history array YH. This array corresponds uniquely to a -C vector-valued polynomial of degree NQCUR or less, and DKY is set -C to the K-th derivative of this polynomial at T. -C The formula for DKY is.. -C q -C DKY(i) = sum c(j,K) * (T - TN)**(j-K) * H**(-j) * YH(i,j+1) -C j=K -C where c(j,K) = j*(j-1)*...*(j-K+1), q = NQCUR, TN = TCUR, H = HCUR. -C The quantities NQ = NQCUR, L = NQ+1, N, TN, and H are -C communicated by COMMON. The above sum is done in reverse order. -C IFLAG is returned negative if either K or T is out of bounds. -C -C Discussion above and comments in driver explain all variables. -C----------------------------------------------------------------------- -C -C Type declarations for labeled COMMON block DVOD01 -------------------- -C - KPP_REAL ACNRM, CCMXJ, CONP, CRATE, DRC, EL, - 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, - 2 RC, RL1, TAU, TQ, TN, UROUND - INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, - 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, - 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, - 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, - 4 NSLP, NYH -C -C Type declarations for labeled COMMON block DVOD02 -------------------- -C - KPP_REAL HU - INTEGER NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST -C -C Type declarations for local variables -------------------------------- -C - KPP_REAL C, HUN, R, S, TFUZZ, TN1, TP, ZERO - INTEGER I, IC, J, JB, JB2, JJ, JJ1, JP1 - CHARACTER*80 MSG -C----------------------------------------------------------------------- -C The following Fortran-77 declaration is to cause the values of the -C listed (local) variables to be saved between calls to this integrator. -C----------------------------------------------------------------------- - SAVE HUN, ZERO -C - COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), - 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, - 2 RC, RL1, TAU(13), TQ(5), TN, UROUND, - 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, - 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, - 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, - 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, - 7 NSLP, NYH - COMMON /DVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST -C - DATA HUN /100.0D0/, ZERO /0.0D0/ -C - IFLAG = 0 - IF (K .LT. 0 .OR. K .GT. NQ) GO TO 80 - TFUZZ = HUN*UROUND*(TN + HU) - TP = TN - HU - TFUZZ - TN1 = TN + TFUZZ - IF ((T-TP)*(T-TN1) .GT. ZERO) GO TO 90 -C - S = (T - TN)/H - IC = 1 - IF (K .EQ. 0) GO TO 15 - JJ1 = L - K - DO 10 JJ = JJ1, NQ - 10 IC = IC*JJ - 15 C = REAL(IC) - DO 20 I = 1, N - 20 DKY(I) = C*YH(I,L) - IF (K .EQ. NQ) GO TO 55 - JB2 = NQ - K - DO 50 JB = 1, JB2 - J = NQ - JB - JP1 = J + 1 - IC = 1 - IF (K .EQ. 0) GO TO 35 - JJ1 = JP1 - K - DO 30 JJ = JJ1, J - 30 IC = IC*JJ - 35 C = REAL(IC) - DO 40 I = 1, N - 40 DKY(I) = C*YH(I,JP1) + S*DKY(I) - 50 CONTINUE - IF (K .EQ. 0) RETURN - 55 R = H**(-K) - CALL DSCAL (N, R, DKY, 1) - RETURN -C - 80 MSG = 'DVINDY-- K (=I1) illegal ' - CALL XERRWD (MSG, 30, 51, 1, 1, K, 0, 0, ZERO, ZERO) - IFLAG = -1 - RETURN - 90 MSG = 'DVINDY-- T (=R1) illegal ' - CALL XERRWD (MSG, 30, 52, 1, 0, 0, 0, 1, T, ZERO) - MSG=' T not in interval TCUR - HU (= R1) to TCUR (=R2) ' - CALL XERRWD (MSG, 60, 52, 1, 0, 0, 0, 2, TP, TN) - IFLAG = -2 - RETURN -C----------------------- End of Subroutine DVINDY ---------------------- - END -*DECK DVSTEP - SUBROUTINE DVSTEP (Y, YH, LDYH, YH1, EWT, SAVF, VSAV, ACOR, - 1 WM, IWM, F, JAC, PSOL, VNLS, RPAR, IPAR) - EXTERNAL F, JAC, PSOL, VNLS - KPP_REAL Y, YH, YH1, EWT, SAVF, VSAV, ACOR, WM, RPAR - INTEGER LDYH, IWM, IPAR - DIMENSION Y(*), YH(LDYH,*), YH1(*), EWT(*), SAVF(*), VSAV(*), - 1 ACOR(*), WM(*), IWM(*), RPAR(*), IPAR(*) - -C----------------------------------------------------------------------- -C Call sequence input -- Y, YH, LDYH, YH1, EWT, SAVF, VSAV, -C ACOR, WM, IWM, F, JAC, PSOL, VNLS, RPAR, IPAR -C Call sequence output -- YH, ACOR, WM, IWM -C COMMON block variables accessed.. -C /DVOD01/ ACNRM, EL(13), H, HMIN, HMXI, HNEW, HSCAL, RC, TAU(13), -C TQ(5), TN, JCUR, JSTART, KFLAG, KUTH, -C L, LMAX, MAXORD, MITER, N, NEWQ, NQ, NQWAIT -C /DVOD02/ HU, NCFN, NETF, NFE, NQU, NST -C -C Subroutines called by DVSTEP.. F, DAXPY, DCOPY, DSCAL, -C DVJUST, VNLS, DVSET -C Function routines called by DVSTEP.. DVNORM -C----------------------------------------------------------------------- -C DVSTEP performs one step of the integration of an initial value -C problem for a system of ordinary differential equations. -C DVSTEP calls subroutine VNLS for the solution of the nonlinear system -C arising in the time step. Thus it is independent of the problem -C Jacobian structure and the type of nonlinear system solution method. -C DVSTEP returns a completion flag KFLAG (in COMMON). -C A return with KFLAG = -1 or -2 means either ABS(H) = HMIN or 10 -C consecutive failures occurred. On a return with KFLAG negative, -C the values of TN and the YH array are as of the beginning of the last -C step, and H is the last step size attempted. -C -C Communication with DVSTEP is done with the following variables.. -C -C Y = An array of length N used for the dependent variable vector. -C YH = An LDYH by LMAX array containing the dependent variables -C and their approximate scaled derivatives, where -C LMAX = MAXORD + 1. YH(i,j+1) contains the approximate -C j-th derivative of y(i), scaled by H**j/factorial(j) -C (j = 0,1,...,NQ). On entry for the first step, the first -C two columns of YH must be set from the initial values. -C LDYH = A constant integer .ge. N, the first dimension of YH. -C N is the number of ODEs in the system. -C YH1 = A one-dimensional array occupying the same space as YH. -C EWT = An array of length N containing multiplicative weights -C for local error measurements. Local errors in y(i) are -C compared to 1.0/EWT(i) in various error tests. -C SAVF = An array of working storage, of length N. -C also used for input of YH(*,MAXORD+2) when JSTART = -1 -C and MAXORD .lt. the current order NQ. -C VSAV = A work array of length N passed to subroutine VNLS. -C ACOR = A work array of length N, used for the accumulated -C corrections. On a successful return, ACOR(i) contains -C the estimated one-step local error in y(i). -C WM,IWM = Real and integer work arrays associated with matrix -C operations in VNLS. -C F = Dummy name for the user supplied subroutine for f. -C JAC = Dummy name for the user supplied Jacobian subroutine. -C PSOL = Dummy name for the subroutine passed to VNLS, for -C possible use there. -C VNLS = Dummy name for the nonlinear system solving subroutine, -C whose real name is dependent on the method used. -C RPAR, IPAR = Dummy names for user's real and integer work arrays. -C----------------------------------------------------------------------- -C -C Type declarations for labeled COMMON block DVOD01 -------------------- -C - KPP_REAL ACNRM, CCMXJ, CONP, CRATE, DRC, EL, - 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, - 2 RC, RL1, TAU, TQ, TN, UROUND - INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, - 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, - 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, - 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, - 4 NSLP, NYH -C -C Type declarations for labeled COMMON block DVOD02 -------------------- -C - KPP_REAL HU - INTEGER NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST -C -C Type declarations for local variables -------------------------------- -C - KPP_REAL ADDON, BIAS1,BIAS2,BIAS3, CNQUOT, DDN, DSM, DUP, - 1 ETACF, ETAMIN, ETAMX1, ETAMX2, ETAMX3, ETAMXF, - 2 ETAQ, ETAQM1, ETAQP1, FLOTL, ONE, ONEPSM, - 3 R, THRESH, TOLD, ZERO - INTEGER I, I1, I2, IBACK, J, JB, KFC, KFH, MXNCF, NCF, NFLAG -C -C Type declaration for function subroutines called --------------------- -C - KPP_REAL DVNORM -C----------------------------------------------------------------------- -C The following Fortran-77 declaration is to cause the values of the -C listed (local) variables to be saved between calls to this integrator. -C----------------------------------------------------------------------- - SAVE ADDON, BIAS1, BIAS2, BIAS3, - 1 ETACF, ETAMIN, ETAMX1, ETAMX2, ETAMX3, ETAMXF, - 2 KFC, KFH, MXNCF, ONEPSM, THRESH, ONE, ZERO -C----------------------------------------------------------------------- - COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), - 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, - 2 RC, RL1, TAU(13), TQ(5), TN, UROUND, - 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, - 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, - 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, - 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, - 7 NSLP, NYH - COMMON /DVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST -C - DATA KFC/-3/, KFH/-7/, MXNCF/10/ - DATA ADDON /1.0D-6/, BIAS1 /6.0D0/, BIAS2 /6.0D0/, - 1 BIAS3 /10.0D0/, ETACF /0.25D0/, ETAMIN /0.1D0/, - 2 ETAMXF /0.2D0/, ETAMX1 /1.0D4/, ETAMX2 /10.0D1/, - 3 ETAMX3 /10.0D1/, ONEPSM /1.00001D0/, THRESH /1.5D0/ - - DATA ONE/1.0D0/, ZERO/0.0D0/ -C - ETAQ = ETAMX1 - ETAQM1 = ETAMX1 - ETAQP1 = ETAMX1 - KFLAG = 0 - TOLD = TN - NCF = 0 - JCUR = 0 - NFLAG = 0 - IF (JSTART .GT. 0) GO TO 20 - IF (JSTART .EQ. -1) GO TO 100 -C----------------------------------------------------------------------- -C On the first call, the order is set to 1, and other variables are -C initialized. ETAMAX is the maximum ratio by which H can be increased -C in a single step. It is normally 1.5, but is larger during the -C first 10 steps to compensate for the small initial H. If a failure -C occurs (in corrector convergence or error test), ETAMAX is set to 1 -C for the next increase. -C----------------------------------------------------------------------- - LMAX = MAXORD + 1 - NQ = 1 - L = 2 - NQNYH = NQ*LDYH - TAU(1) = H - PRL1 = ONE - RC = ZERO - ETAMAX = ETAMX1 - NQWAIT = 2 - HSCAL = H - GO TO 200 -C----------------------------------------------------------------------- -C Take preliminary actions on a normal continuation step (JSTART.GT.0). -C If the driver changed H, then ETA must be reset and NEWH set to 1. -C If a change of order was dictated on the previous step, then -C it is done here and appropriate adjustments in the history are made. -C On an order decrease, the history array is adjusted by DVJUST. -C On an order increase, the history array is augmented by a column. -C On a change of step size H, the history array YH is rescaled. -C----------------------------------------------------------------------- - 20 CONTINUE - IF (KUTH .EQ. 1) THEN - ETA = MIN(ETA,H/HSCAL) - NEWH = 1 - ENDIF - 50 IF (NEWH .EQ. 0) GO TO 200 - IF (NEWQ .EQ. NQ) GO TO 150 - IF (NEWQ .LT. NQ) THEN - CALL DVJUST (YH, LDYH, -1) - NQ = NEWQ - L = NQ + 1 - NQWAIT = L - GO TO 150 - ENDIF - IF (NEWQ .GT. NQ) THEN - CALL DVJUST (YH, LDYH, 1) - NQ = NEWQ - L = NQ + 1 - NQWAIT = L - GO TO 150 - ENDIF -C----------------------------------------------------------------------- -C The following block handles preliminaries needed when JSTART = -1. -C If N was reduced, zero out part of YH to avoid undefined references. -C If MAXORD was reduced to a value less than the tentative order NEWQ, -C then NQ is set to MAXORD, and a new H ratio ETA is chosen. -C Otherwise, we take the same preliminary actions as for JSTART .gt. 0. -C In any case, NQWAIT is reset to L = NQ + 1 to prevent further -C changes in order for that many steps. -C The new H ratio ETA is limited by the input H if KUTH = 1, -C by HMIN if KUTH = 0, and by HMXI in any case. -C Finally, the history array YH is rescaled. -C----------------------------------------------------------------------- - 100 CONTINUE - LMAX = MAXORD + 1 - IF (N .EQ. LDYH) GO TO 120 - I1 = 1 + (NEWQ + 1)*LDYH - I2 = (MAXORD + 1)*LDYH - IF (I1 .GT. I2) GO TO 120 - DO 110 I = I1, I2 - 110 YH1(I) = ZERO - 120 IF (NEWQ .LE. MAXORD) GO TO 140 - FLOTL = REAL(LMAX) - IF (MAXORD .LT. NQ-1) THEN - DDN = DVNORM (N, SAVF, EWT)/TQ(1) - ETA = ONE/((BIAS1*DDN)**(ONE/FLOTL) + ADDON) - ENDIF - IF (MAXORD .EQ. NQ .AND. NEWQ .EQ. NQ+1) ETA = ETAQ - IF (MAXORD .EQ. NQ-1 .AND. NEWQ .EQ. NQ+1) THEN - ETA = ETAQM1 - CALL DVJUST (YH, LDYH, -1) - ENDIF - IF (MAXORD .EQ. NQ-1 .AND. NEWQ .EQ. NQ) THEN - DDN = DVNORM (N, SAVF, EWT)/TQ(1) - ETA = ONE/((BIAS1*DDN)**(ONE/FLOTL) + ADDON) - CALL DVJUST (YH, LDYH, -1) - ENDIF - ETA = MIN(ETA,ONE) - NQ = MAXORD - L = LMAX - 140 IF (KUTH .EQ. 1) ETA = MIN(ETA,ABS(H/HSCAL)) - IF (KUTH .EQ. 0) ETA = MAX(ETA,HMIN/ABS(HSCAL)) - ETA = ETA/MAX(ONE,ABS(HSCAL)*HMXI*ETA) - NEWH = 1 - NQWAIT = L - IF (NEWQ .LE. MAXORD) GO TO 50 -C Rescale the history array for a change in H by a factor of ETA. ------ - 150 R = ONE - DO 180 J = 2, L - R = R*ETA - CALL DSCAL (N, R, YH(1,J), 1 ) - 180 CONTINUE - H = HSCAL*ETA - HSCAL = H - RC = RC*ETA - NQNYH = NQ*LDYH -C----------------------------------------------------------------------- -C This section computes the predicted values by effectively -C multiplying the YH array by the Pascal triangle matrix. -C DVSET is called to calculate all integration coefficients. -C RC is the ratio of new to old values of the coefficient H/EL(2)=h/l1. -C----------------------------------------------------------------------- - 200 TN = TN + H - I1 = NQNYH + 1 - DO 220 JB = 1, NQ - I1 = I1 - LDYH - DO 210 I = I1, NQNYH - 210 YH1(I) = YH1(I) + YH1(I+LDYH) - 220 CONTINUE - CALL DVSET - RL1 = ONE/EL(2) - RC = RC*(RL1/PRL1) - PRL1 = RL1 -C -C Call the nonlinear system solver. ------------------------------------ -C - CALL VNLS (Y, YH, LDYH, VSAV, SAVF, EWT, ACOR, IWM, WM, - 1 F, JAC, PSOL, NFLAG, RPAR, IPAR) -C - IF ((NFLAG .EQ. 0).OR.(H.LE.1.2*HMIN)) GO TO 450 -C----------------------------------------------------------------------- -C The VNLS routine failed to achieve convergence (NFLAG .NE. 0). -C The YH array is retracted to its values before prediction. -C The step size H is reduced and the step is retried, if possible. -C Otherwise, an error exit is taken. -C----------------------------------------------------------------------- - NCF = NCF + 1 - NCFN = NCFN + 1 - ETAMAX = ONE - TN = TOLD - I1 = NQNYH + 1 - DO 430 JB = 1, NQ - I1 = I1 - LDYH - DO 420 I = I1, NQNYH - 420 YH1(I) = YH1(I) - YH1(I+LDYH) - 430 CONTINUE - IF (NFLAG .LT. -1) GO TO 680 - IF (ABS(H) .LE. HMIN*ONEPSM) GO TO 670 - IF (NCF .EQ. MXNCF) GO TO 670 - ETA = ETACF - ETA = MAX(ETA,HMIN/ABS(H)) - NFLAG = -1 - GO TO 150 -C----------------------------------------------------------------------- -C The corrector has converged (NFLAG = 0). The local error test is -C made and control passes to statement 500 if it fails. -C----------------------------------------------------------------------- - 450 CONTINUE - DSM = ACNRM/TQ(2) - IF ( (DSM .GT. ONE).and.(H.GT.HMIN) ) GO TO 500 -C----------------------------------------------------------------------- -C After a successful step, update the YH and TAU arrays and decrement -C NQWAIT. If NQWAIT is then 1 and NQ .lt. MAXORD, then ACOR is saved -C for use in a possible order increase on the next step. -C If ETAMAX = 1 (a failure occurred this step), keep NQWAIT .ge. 2. -C----------------------------------------------------------------------- - KFLAG = 0 - NST = NST + 1 - HU = H - NQU = NQ - DO 470 IBACK = 1, NQ - I = L - IBACK - 470 TAU(I+1) = TAU(I) - TAU(1) = H - DO 480 J = 1, L - CALL DAXPY (N, EL(J), ACOR, 1, YH(1,J), 1 ) - 480 CONTINUE - NQWAIT = NQWAIT - 1 - IF ((L .EQ. LMAX) .OR. (NQWAIT .NE. 1)) GO TO 490 - CALL DCOPY (N, ACOR, 1, YH(1,LMAX), 1 ) - CONP = TQ(5) - 490 IF (ETAMAX .NE. ONE) GO TO 560 - IF (NQWAIT .LT. 2) NQWAIT = 2 - NEWQ = NQ - NEWH = 0 - ETA = ONE - HNEW = H - GO TO 690 -C----------------------------------------------------------------------- -C The error test failed. KFLAG keeps track of multiple failures. -C Restore TN and the YH array to their previous values, and prepare -C to try the step again. Compute the optimum step size for the -C same order. After repeated failures, H is forced to decrease -C more rapidly. -C----------------------------------------------------------------------- - 500 KFLAG = KFLAG - 1 - NETF = NETF + 1 - NFLAG = -2 - TN = TOLD - I1 = NQNYH + 1 - DO 520 JB = 1, NQ - I1 = I1 - LDYH - DO 510 I = I1, NQNYH - 510 YH1(I) = YH1(I) - YH1(I+LDYH) - 520 CONTINUE - IF (ABS(H) .LE. HMIN*ONEPSM) GO TO 660 - ETAMAX = ONE - IF (KFLAG .LE. KFC) GO TO 530 -C Compute ratio of new H to current H at the current order. ------------ - FLOTL = REAL(L) - ETA = ONE/((BIAS2*DSM)**(ONE/FLOTL) + ADDON) - ETA = MAX(ETA,HMIN/ABS(H),ETAMIN) - IF ((KFLAG .LE. -2) .AND. (ETA .GT. ETAMXF)) ETA = ETAMXF - GO TO 150 -C----------------------------------------------------------------------- -C Control reaches this section if 3 or more consecutive failures -C have occurred. It is assumed that the elements of the YH array -C have accumulated errors of the wrong order. The order is reduced -C by one, if possible. Then H is reduced by a factor of 0.1 and -C the step is retried. After a total of 7 consecutive failures, -C an exit is taken with KFLAG = -1. -C----------------------------------------------------------------------- - 530 IF (KFLAG .EQ. KFH) GO TO 660 - IF (NQ .EQ. 1) GO TO 540 - ETA = MAX(ETAMIN,HMIN/ABS(H)) - CALL DVJUST (YH, LDYH, -1) - L = NQ - NQ = NQ - 1 - NQWAIT = L - GO TO 150 - 540 ETA = MAX(ETAMIN,HMIN/ABS(H)) - H = H*ETA - HSCAL = H - TAU(1) = H - CALL F (N, TN, Y, SAVF) - NFE = NFE + 1 - DO 550 I = 1, N - 550 YH(I,2) = H*SAVF(I) - NQWAIT = 10 - GO TO 200 -C----------------------------------------------------------------------- -C If NQWAIT = 0, an increase or decrease in order by one is considered. -C Factors ETAQ, ETAQM1, ETAQP1 are computed by which H could -C be multiplied at order q, q-1, or q+1, respectively. -C The largest of these is determined, and the new order and -C step size set accordingly. -C A change of H or NQ is made only if H increases by at least a -C factor of THRESH. If an order change is considered and rejected, -C then NQWAIT is set to 2 (reconsider it after 2 steps). -C----------------------------------------------------------------------- -C Compute ratio of new H to current H at the current order. ------------ - 560 FLOTL = REAL(L) - ETAQ = ONE/((BIAS2*DSM)**(ONE/FLOTL) + ADDON) - IF (NQWAIT .NE. 0) GO TO 600 - NQWAIT = 2 - ETAQM1 = ZERO - IF (NQ .EQ. 1) GO TO 570 -C Compute ratio of new H to current H at the current order less one. --- - DDN = DVNORM (N, YH(1,L), EWT)/TQ(1) - ETAQM1 = ONE/((BIAS1*DDN)**(ONE/(FLOTL - ONE)) + ADDON) - 570 ETAQP1 = ZERO - IF (L .EQ. LMAX) GO TO 580 -C Compute ratio of new H to current H at current order plus one. ------- - CNQUOT = (TQ(5)/CONP)*(H/TAU(2))**L - DO 575 I = 1, N - 575 SAVF(I) = ACOR(I) - CNQUOT*YH(I,LMAX) - DUP = DVNORM (N, SAVF, EWT)/TQ(3) - ETAQP1 = ONE/((BIAS3*DUP)**(ONE/(FLOTL + ONE)) + ADDON) - 580 IF (ETAQ .GE. ETAQP1) GO TO 590 - IF (ETAQP1 .GT. ETAQM1) GO TO 620 - GO TO 610 - 590 IF (ETAQ .LT. ETAQM1) GO TO 610 - 600 ETA = ETAQ - NEWQ = NQ - GO TO 630 - 610 ETA = ETAQM1 - NEWQ = NQ - 1 - GO TO 630 - 620 ETA = ETAQP1 - NEWQ = NQ + 1 - CALL DCOPY (N, ACOR, 1, YH(1,LMAX), 1) -C Test tentative new H against THRESH, ETAMAX, and HMXI, then exit. ---- - 630 IF (ETA .LT. THRESH .OR. ETAMAX .EQ. ONE) GO TO 640 - ETA = MIN(ETA,ETAMAX) - ETA = ETA/MAX(ONE,ABS(H)*HMXI*ETA) - NEWH = 1 - HNEW = H*ETA - GO TO 690 - 640 NEWQ = NQ - NEWH = 0 - ETA = ONE - HNEW = H - GO TO 690 -C----------------------------------------------------------------------- -C All returns are made through this section. -C On a successful return, ETAMAX is reset and ACOR is scaled. -C----------------------------------------------------------------------- - 660 KFLAG = -1 - GO TO 720 - 670 KFLAG = -2 - GO TO 720 - 680 IF (NFLAG .EQ. -2) KFLAG = -3 - IF (NFLAG .EQ. -3) KFLAG = -4 - GO TO 720 - 690 ETAMAX = ETAMX3 - IF (NST .LE. 10) ETAMAX = ETAMX2 - 700 R = ONE/TQ(2) - CALL DSCAL (N, R, ACOR, 1) - 720 JSTART = 1 - RETURN -C----------------------- End of Subroutine DVSTEP ---------------------- - END -*DECK DVSET - SUBROUTINE DVSET -C----------------------------------------------------------------------- -C Call sequence communication.. None -C COMMON block variables accessed.. -C /DVOD01/ -- EL(13), H, TAU(13), TQ(5), L(= NQ + 1), -C METH, NQ, NQWAIT -C -C Subroutines called by DVSET.. None -C Function routines called by DVSET.. None -C----------------------------------------------------------------------- -C DVSET is called by DVSTEP and sets coefficients for use there. -C -C For each order NQ, the coefficients in EL are calculated by use of -C the generating polynomial lambda(x), with coefficients EL(i). -C lambda(x) = EL(1) + EL(2)*x + ... + EL(NQ+1)*(x**NQ). -C For the backward differentiation formulas, -C NQ-1 -C lambda(x) = (1 + x/xi*(NQ)) * product (1 + x/xi(i) ) . -C i = 1 -C For the Adams formulas, -C NQ-1 -C (d/dx) lambda(x) = c * product (1 + x/xi(i) ) , -C i = 1 -C lambda(-1) = 0, lambda(0) = 1, -C where c is a normalization constant. -C In both cases, xi(i) is defined by -C H*xi(i) = t sub n - t sub (n-i) -C = H + TAU(1) + TAU(2) + ... TAU(i-1). -C -C -C In addition to variables described previously, communication -C with DVSET uses the following.. -C TAU = A vector of length 13 containing the past NQ values -C of H. -C EL = A vector of length 13 in which vset stores the -C coefficients for the corrector formula. -C TQ = A vector of length 5 in which vset stores constants -C used for the convergence test, the error test, and the -C selection of H at a new order. -C METH = The basic method indicator. -C NQ = The current order. -C L = NQ + 1, the length of the vector stored in EL, and -C the number of columns of the YH array being used. -C NQWAIT = A counter controlling the frequency of order changes. -C An order change is about to be considered if NQWAIT = 1. -C----------------------------------------------------------------------- -C -C Type declarations for labeled COMMON block DVOD01 -------------------- -C - KPP_REAL ACNRM, CCMXJ, CONP, CRATE, DRC, EL, - 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, - 2 RC, RL1, TAU, TQ, TN, UROUND - INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, - 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, - 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, - 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, - 4 NSLP, NYH -C -C Type declarations for local variables -------------------------------- -C - KPP_REAL AHATN0, ALPH0, CNQM1, CORTES, CSUM, ELP, EM, - 1 EM0, FLOTI, FLOTL, FLOTNQ, HSUM, ONE, RXI, RXIS, S, SIX, - 2 T1, T2, T3, T4, T5, T6, TWO, XI, ZERO - INTEGER I, IBACK, J, JP1, NQM1, NQM2 -C - DIMENSION EM(13) -C----------------------------------------------------------------------- -C The following Fortran-77 declaration is to cause the values of the -C listed (local) variables to be saved between calls to this integrator. -C----------------------------------------------------------------------- - SAVE CORTES, ONE, SIX, TWO, ZERO -C - COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), - 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, - 2 RC, RL1, TAU(13), TQ(5), TN, UROUND, - 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, - 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, - 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, - 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, - 7 NSLP, NYH -C - DATA CORTES /0.1D0/ - DATA ONE /1.0D0/, SIX /6.0D0/, TWO /2.0D0/, ZERO /0.0D0/ -C - FLOTL = REAL(L) - NQM1 = NQ - 1 - NQM2 = NQ - 2 - GO TO (100, 200), METH -C -C Set coefficients for Adams methods. ---------------------------------- - 100 IF (NQ .NE. 1) GO TO 110 - EL(1) = ONE - EL(2) = ONE - TQ(1) = ONE - TQ(2) = TWO - TQ(3) = SIX*TQ(2) - TQ(5) = ONE - GO TO 300 - 110 HSUM = H - EM(1) = ONE - FLOTNQ = FLOTL - ONE - DO 115 I = 2, L - 115 EM(I) = ZERO - DO 150 J = 1, NQM1 - IF ((J .NE. NQM1) .OR. (NQWAIT .NE. 1)) GO TO 130 - S = ONE - CSUM = ZERO - DO 120 I = 1, NQM1 - CSUM = CSUM + S*EM(I)/REAL(I+1) - 120 S = -S - TQ(1) = EM(NQM1)/(FLOTNQ*CSUM) - 130 RXI = H/HSUM - DO 140 IBACK = 1, J - I = (J + 2) - IBACK - 140 EM(I) = EM(I) + EM(I-1)*RXI - HSUM = HSUM + TAU(J) - 150 CONTINUE -C Compute integral from -1 to 0 of polynomial and of x times it. ------- - S = ONE - EM0 = ZERO - CSUM = ZERO - DO 160 I = 1, NQ - FLOTI = REAL(I) - EM0 = EM0 + S*EM(I)/FLOTI - CSUM = CSUM + S*EM(I)/(FLOTI+ONE) - 160 S = -S -C In EL, form coefficients of normalized integrated polynomial. -------- - S = ONE/EM0 - EL(1) = ONE - DO 170 I = 1, NQ - 170 EL(I+1) = S*EM(I)/REAL(I) - XI = HSUM/H - TQ(2) = XI*EM0/CSUM - TQ(5) = XI/EL(L) - IF (NQWAIT .NE. 1) GO TO 300 -C For higher order control constant, multiply polynomial by 1+x/xi(q). - - RXI = ONE/XI - DO 180 IBACK = 1, NQ - I = (L + 1) - IBACK - 180 EM(I) = EM(I) + EM(I-1)*RXI -C Compute integral of polynomial. -------------------------------------- - S = ONE - CSUM = ZERO - DO 190 I = 1, L - CSUM = CSUM + S*EM(I)/REAL(I+1) - 190 S = -S - TQ(3) = FLOTL*EM0/CSUM - GO TO 300 -C -C Set coefficients for BDF methods. ------------------------------------ - 200 DO 210 I = 3, L - 210 EL(I) = ZERO - EL(1) = ONE - EL(2) = ONE - ALPH0 = -ONE - AHATN0 = -ONE - HSUM = H - RXI = ONE - RXIS = ONE - IF (NQ .EQ. 1) GO TO 240 - DO 230 J = 1, NQM2 -C In EL, construct coefficients of (1+x/xi(1))*...*(1+x/xi(j+1)). ------ - HSUM = HSUM + TAU(J) - RXI = H/HSUM - JP1 = J + 1 - ALPH0 = ALPH0 - ONE/REAL(JP1) - DO 220 IBACK = 1, JP1 - I = (J + 3) - IBACK - 220 EL(I) = EL(I) + EL(I-1)*RXI - 230 CONTINUE - ALPH0 = ALPH0 - ONE/REAL(NQ) - RXIS = -EL(2) - ALPH0 - HSUM = HSUM + TAU(NQM1) - RXI = H/HSUM - AHATN0 = -EL(2) - RXI - DO 235 IBACK = 1, NQ - I = (NQ + 2) - IBACK - 235 EL(I) = EL(I) + EL(I-1)*RXIS - 240 T1 = ONE - AHATN0 + ALPH0 - T2 = ONE + REAL(NQ)*T1 - TQ(2) = ABS(ALPH0*T2/T1) - TQ(5) = ABS(T2/(EL(L)*RXI/RXIS)) - IF (NQWAIT .NE. 1) GO TO 300 - CNQM1 = RXIS/EL(L) - T3 = ALPH0 + ONE/REAL(NQ) - T4 = AHATN0 + RXI - ELP = T3/(ONE - T4 + T3) - TQ(1) = ABS(ELP/CNQM1) - HSUM = HSUM + TAU(NQ) - RXI = H/HSUM - T5 = ALPH0 - ONE/REAL(NQ+1) - T6 = AHATN0 - RXI - ELP = T2/(ONE - T6 + T5) - TQ(3) = ABS(ELP*RXI*(FLOTL + ONE)*T5) - 300 TQ(4) = CORTES*TQ(2) - RETURN -C----------------------- End of Subroutine DVSET ----------------------- - END -*DECK DVJUST - SUBROUTINE DVJUST (YH, LDYH, IORD) - KPP_REAL YH - INTEGER LDYH, IORD - DIMENSION YH(LDYH,*) -C----------------------------------------------------------------------- -C Call sequence input -- YH, LDYH, IORD -C Call sequence output -- YH -C COMMON block input -- NQ, METH, LMAX, HSCAL, TAU(13), N -C COMMON block variables accessed.. -C /DVOD01/ -- HSCAL, TAU(13), LMAX, METH, N, NQ, -C -C Subroutines called by DVJUST.. DAXPY -C Function routines called by DVJUST.. None -C----------------------------------------------------------------------- -C This subroutine adjusts the YH array on reduction of order, -C and also when the order is increased for the stiff option (METH = 2). -C Communication with DVJUST uses the following.. -C IORD = An integer flag used when METH = 2 to indicate an order -C increase (IORD = +1) or an order decrease (IORD = -1). -C HSCAL = Step size H used in scaling of Nordsieck array YH. -C (If IORD = +1, DVJUST assumes that HSCAL = TAU(1).) -C See References 1 and 2 for details. -C----------------------------------------------------------------------- -C -C Type declarations for labeled COMMON block DVOD01 -------------------- -C - KPP_REAL ACNRM, CCMXJ, CONP, CRATE, DRC, EL, - 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, - 2 RC, RL1, TAU, TQ, TN, UROUND - INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, - 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, - 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, - 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, - 4 NSLP, NYH -C -C Type declarations for local variables -------------------------------- -C - KPP_REAL ALPH0, ALPH1, HSUM, ONE, PROD, T1, XI,XIOLD, ZERO - INTEGER I, IBACK, J, JP1, LP1, NQM1, NQM2, NQP1 -C----------------------------------------------------------------------- -C The following Fortran-77 declaration is to cause the values of the -C listed (local) variables to be saved between calls to this integrator. -C----------------------------------------------------------------------- - SAVE ONE, ZERO -C - COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), - 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, - 2 RC, RL1, TAU(13), TQ(5), TN, UROUND, - 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, - 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, - 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, - 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, - 7 NSLP, NYH -C - DATA ONE /1.0D0/, ZERO /0.0D0/ -C - IF ((NQ .EQ. 2) .AND. (IORD .NE. 1)) RETURN - NQM1 = NQ - 1 - NQM2 = NQ - 2 - GO TO (100, 200), METH -C----------------------------------------------------------------------- -C Nonstiff option... -C Check to see if the order is being increased or decreased. -C----------------------------------------------------------------------- - 100 CONTINUE - IF (IORD .EQ. 1) GO TO 180 -C Order decrease. ------------------------------------------------------ - DO 110 J = 1, LMAX - 110 EL(J) = ZERO - EL(2) = ONE - HSUM = ZERO - DO 130 J = 1, NQM2 -C Construct coefficients of x*(x+xi(1))*...*(x+xi(j)). ----------------- - HSUM = HSUM + TAU(J) - XI = HSUM/HSCAL - JP1 = J + 1 - DO 120 IBACK = 1, JP1 - I = (J + 3) - IBACK - 120 EL(I) = EL(I)*XI + EL(I-1) - 130 CONTINUE -C Construct coefficients of integrated polynomial. --------------------- - DO 140 J = 2, NQM1 - 140 EL(J+1) = REAL(NQ)*EL(J)/REAL(J) -C Subtract correction terms from YH array. ----------------------------- - DO 170 J = 3, NQ - DO 160 I = 1, N - 160 YH(I,J) = YH(I,J) - YH(I,L)*EL(J) - 170 CONTINUE - RETURN -C Order increase. ------------------------------------------------------ -C Zero out next column in YH array. ------------------------------------ - 180 CONTINUE - LP1 = L + 1 - DO 190 I = 1, N - 190 YH(I,LP1) = ZERO - RETURN -C----------------------------------------------------------------------- -C Stiff option... -C Check to see if the order is being increased or decreased. -C----------------------------------------------------------------------- - 200 CONTINUE - IF (IORD .EQ. 1) GO TO 300 -C Order decrease. ------------------------------------------------------ - DO 210 J = 1, LMAX - 210 EL(J) = ZERO - EL(3) = ONE - HSUM = ZERO - DO 230 J = 1,NQM2 -C Construct coefficients of x*x*(x+xi(1))*...*(x+xi(j)). --------------- - HSUM = HSUM + TAU(J) - XI = HSUM/HSCAL - JP1 = J + 1 - DO 220 IBACK = 1, JP1 - I = (J + 4) - IBACK - 220 EL(I) = EL(I)*XI + EL(I-1) - 230 CONTINUE -C Subtract correction terms from YH array. ----------------------------- - DO 250 J = 3,NQ - DO 240 I = 1, N - 240 YH(I,J) = YH(I,J) - YH(I,L)*EL(J) - 250 CONTINUE - RETURN -C Order increase. ------------------------------------------------------ - 300 DO 310 J = 1, LMAX - 310 EL(J) = ZERO - EL(3) = ONE - ALPH0 = -ONE - ALPH1 = ONE - PROD = ONE - XIOLD = ONE - HSUM = HSCAL - IF (NQ .EQ. 1) GO TO 340 - DO 330 J = 1, NQM1 -C Construct coefficients of x*x*(x+xi(1))*...*(x+xi(j)). --------------- - JP1 = J + 1 - HSUM = HSUM + TAU(JP1) - XI = HSUM/HSCAL - PROD = PROD*XI - ALPH0 = ALPH0 - ONE/REAL(JP1) - ALPH1 = ALPH1 + ONE/XI - DO 320 IBACK = 1, JP1 - I = (J + 4) - IBACK - 320 EL(I) = EL(I)*XIOLD + EL(I-1) - XIOLD = XI - 330 CONTINUE - 340 CONTINUE - T1 = (-ALPH0 - ALPH1)/PROD -C Load column L + 1 in YH array. --------------------------------------- - LP1 = L + 1 - DO 350 I = 1, N - 350 YH(I,LP1) = T1*YH(I,LMAX) -C Add correction terms to YH array. ------------------------------------ - NQP1 = NQ + 1 - DO 370 J = 3, NQP1 - CALL DAXPY (N, EL(J), YH(1,LP1), 1, YH(1,J), 1 ) - 370 CONTINUE - RETURN -C----------------------- End of Subroutine DVJUST ---------------------- - END -*DECK DVNLSD - SUBROUTINE DVNLSD (Y, YH, LDYH, VSAV, SAVF, EWT, ACOR, IWM, WM, - 1 F, JAC, PDUM, NFLAG, RPAR, IPAR) - EXTERNAL F, JAC, PDUM - KPP_REAL Y, YH, VSAV, SAVF, EWT, ACOR, WM, RPAR - INTEGER LDYH, IWM, NFLAG, IPAR - DIMENSION Y(*), YH(LDYH,*), VSAV(*), SAVF(*), EWT(*), ACOR(*), - 1 IWM(*), WM(*), RPAR(*), IPAR(*) - -C----------------------------------------------------------------------- -C Call sequence input -- Y, YH, LDYH, SAVF, EWT, ACOR, IWM, WM, -C F, JAC, NFLAG, RPAR, IPAR -C Call sequence output -- YH, ACOR, WM, IWM, NFLAG -C COMMON block variables accessed.. -C /DVOD01/ ACNRM, CRATE, DRC, H, RC, RL1, TQ(5), TN, ICF, -C JCUR, METH, MITER, N, NSLP -C /DVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST -C -C Subroutines called by DVNLSD.. F, DAXPY, DCOPY, DSCAL, DVJAC, DVSOL -C Function routines called by DVNLSD.. DVNORM -C----------------------------------------------------------------------- -C Subroutine DVNLSD is a nonlinear system solver, which uses functional -C iteration or a chord (modified Newton) method. For the chord method -C direct linear algebraic system solvers are used. Subroutine DVNLSD -C then handles the corrector phase of this integration package. -C -C Communication with DVNLSD is done with the following variables. (For -C more details, please see the comments in the driver subroutine.) -C -C Y = The dependent variable, a vector of length N, input. -C YH = The Nordsieck (Taylor) array, LDYH by LMAX, input -C and output. On input, it contains predicted values. -C LDYH = A constant .ge. N, the first dimension of YH, input. -C VSAV = Unused work array. -C SAVF = A work array of length N. -C EWT = An error weight vector of length N, input. -C ACOR = A work array of length N, used for the accumulated -C corrections to the predicted y vector. -C WM,IWM = Real and integer work arrays associated with matrix -C operations in chord iteration (MITER .ne. 0). -C F = Dummy name for user supplied routine for f. -C JAC = Dummy name for user supplied Jacobian routine. -C PDUM = Unused dummy subroutine name. Included for uniformity -C over collection of integrators. -C NFLAG = Input/output flag, with values and meanings as follows.. -C INPUT -C 0 first CALL for this time step. -C -1 convergence failure in previous CALL to DVNLSD. -C -2 error test failure in DVSTEP. -C OUTPUT -C 0 successful completion of nonlinear solver. -C -1 convergence failure or singular matrix. -C -2 unrecoverable error in matrix preprocessing -C (cannot occur here). -C -3 unrecoverable error in solution (cannot occur -C here). -C RPAR, IPAR = Dummy names for user's real and integer work arrays. -C -C IPUP = Own variable flag with values and meanings as follows.. -C 0, do not update the Newton matrix. -C MITER .ne. 0, update Newton matrix, because it is the -C initial step, order was changed, the error -C test failed, or an update is indicated by -C the scalar RC or step counter NST. -C -C For more details, see comments in driver subroutine. -C----------------------------------------------------------------------- -C Type declarations for labeled COMMON block DVOD01 -------------------- -C - KPP_REAL ACNRM, CCMXJ, CONP, CRATE, DRC, EL, - 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, - 2 RC, RL1, TAU, TQ, TN, UROUND - INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, - 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, - 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, - 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, - 4 NSLP, NYH -C -C Type declarations for labeled COMMON block DVOD02 -------------------- -C - KPP_REAL HU - INTEGER NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST -C -C Type declarations for local variables -------------------------------- -C - KPP_REAL CCMAX, CRDOWN, CSCALE, DCON, DEL, DELP, ONE, - 1 RDIV, TWO, ZERO - INTEGER I, IERPJ, IERSL, M, MAXCOR, MSBP -C -C Type declaration for function subroutines called --------------------- -C - KPP_REAL DVNORM, STEPCUT -C----------------------------------------------------------------------- -C The following Fortran-77 declaration is to cause the values of the -C listed (local) variables to be saved between calls to this integrator. -C----------------------------------------------------------------------- - SAVE CCMAX, CRDOWN, MAXCOR, MSBP, RDIV, ONE, TWO, ZERO -C - COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), - 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, - 2 RC, RL1, TAU(13), TQ(5), TN, UROUND, - 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, - 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, - 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, - 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, - 7 NSLP, NYH - COMMON /DVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST -C - COMMON /VERWER/ IVERWER, IBEGIN, STEPCUT - DATA CCMAX /0.3D0/, CRDOWN /0.3D0/, MAXCOR /3/, MSBP /20/, - 1 RDIV /2.0D0/ - DATA ONE /1.0D0/, TWO /2.0D0/, ZERO /0.0D0/ -C----------------------------------------------------------------------- -C On the first step, on a change of method order, or after a -C nonlinear convergence failure with NFLAG = -2, set IPUP = MITER -C to force a Jacobian update when MITER .ne. 0. -C----------------------------------------------------------------------- - if ( (h.lt.stepcut).and.(IBEGIN.eq.1) ) then -c if (h.lt.stepcut) then - iverwer = 1 - else - ibegin = 0 - iverwer = 0 - end if - IF (JSTART .EQ. 0) NSLP = 0 - IF (NFLAG .EQ. 0) ICF = 0 - IF (NFLAG .EQ. -2) IPUP = MITER - IF ( (JSTART .EQ. 0) .OR. (JSTART .EQ. -1) ) IPUP = MITER -C If this is functional iteration, set CRATE .eq. 1 and drop to 220 - IF (MITER .EQ. 0) THEN - CRATE = ONE - GO TO 220 - ENDIF -C----------------------------------------------------------------------- -C RC is the ratio of new to old values of the coefficient H/EL(2)=h/l1. -C When RC differs from 1 by more than CCMAX, IPUP is set to MITER -C to force DVJAC to be called, if a Jacobian is involved. -C In any case, DVJAC is called at least every MSBP steps. -C----------------------------------------------------------------------- - DRC = ABS(RC-ONE) - IF (DRC .GT. CCMAX .OR. NST .GE. NSLP+MSBP) IPUP = MITER -C----------------------------------------------------------------------- -C Up to MAXCOR corrector iterations are taken. A convergence test is -C made on the r.m.s. norm of each correction, weighted by the error -C weight vector EWT. The sum of the corrections is accumulated in the -C vector ACOR(i). The YH array is not altered in the corrector loop. -C----------------------------------------------------------------------- - 220 M = 0 - DELP = ZERO - CALL DCOPY (N, YH(1,1), 1, Y, 1 ) - CALL F (N, TN, Y, SAVF) - NFE = NFE + 1 - IF (IPUP .LE. 0) GO TO 250 -C----------------------------------------------------------------------- -C If indicated, the matrix P = I - h*rl1*J is reevaluated and -C preprocessed before starting the corrector iteration. IPUP is set -C to 0 as an indicator that this has been done. -C----------------------------------------------------------------------- - IF (IVERWER.EQ.0) THEN - CALL DVJAC (Y, YH, LDYH, EWT, ACOR, SAVF, WM, IWM, F, JAC, IERPJ, - 1 RPAR, IPAR) - ELSE - IERPJ = 0 - END IF - IPUP = 0 - RC = ONE - DRC = ZERO - CRATE = ONE - NSLP = NST -C If matrix is singular, take error return to force cut in step size. -- - IF (IERPJ .NE. 0) GO TO 430 - 250 DO 260 I = 1,N - 260 ACOR(I) = ZERO -C This is a looping point for the corrector iteration. ----------------- - 270 IF (MITER .NE. 0) GO TO 350 -C----------------------------------------------------------------------- -C In the case of functional iteration, update Y directly from -C the result of the last function evaluation. -C----------------------------------------------------------------------- - DO 280 I = 1,N - 280 SAVF(I) = RL1*(H*SAVF(I) - YH(I,2)) - DO 290 I = 1,N - 290 Y(I) = SAVF(I) - ACOR(I) - DEL = DVNORM (N, Y, EWT) - DO 300 I = 1,N - 300 Y(I) = YH(I,1) + SAVF(I) - CALL DCOPY (N, SAVF, 1, ACOR, 1) - GO TO 400 -C----------------------------------------------------------------------- -C In the case of the chord method, compute the corrector error, -C and solve the linear system with that as right-hand side and -C P as coefficient matrix. The correction is scaled by the factor -C 2/(1+RC) to account for changes in h*rl1 since the last DVJAC call. -C----------------------------------------------------------------------- - 350 continue - if (IVERWER.EQ.1) then - CRATE = 1 - DO I = 1,N - Y(I) = SAVF(I) - ACOR(I) - end do - DEL = DVNORM (N, Y, EWT) - DO I = 1,N - Y(I) = YH(I,1) + SAVF(I) - end do - CALL DCOPY (N, SAVF, 1, ACOR, 1) - GO TO 400 - end if - DO 360 I = 1,N - 360 Y(I) = (RL1*H)*SAVF(I) - (RL1*YH(I,2) + ACOR(I)) - CALL DVSOL (WM, IWM, Y, IERSL) - NNI = NNI + 1 - IF (IERSL .GT. 0) GO TO 410 - IF (METH .EQ. 2 .AND. RC .NE. ONE) THEN - CSCALE = TWO/(ONE + RC) - CALL DSCAL (N, CSCALE, Y, 1) - ENDIF - DEL = DVNORM (N, Y, EWT) - CALL DAXPY (N, ONE, Y, 1, ACOR, 1) - DO 380 I = 1,N - 380 Y(I) = YH(I,1) + ACOR(I) -C----------------------------------------------------------------------- -C Test for convergence. If M .gt. 0, an estimate of the convergence -C rate constant is stored in CRATE, and this is used in the test. -C----------------------------------------------------------------------- - 400 IF (M .NE. 0) CRATE = MAX(CRDOWN*CRATE,DEL/DELP) - DCON = DEL*MIN(ONE,CRATE)/TQ(4) - IF (DCON .LE. ONE) GO TO 450 - M = M + 1 - IF (M .EQ. MAXCOR) GO TO 410 - IF (M .GE. 2 .AND. DEL .GT. RDIV*DELP) GO TO 410 - DELP = DEL - CALL F (N, TN, Y, SAVF) - NFE = NFE + 1 - GO TO 270 -C - 410 IF (MITER .EQ. 0 .OR. JCUR .EQ. 1) GO TO 430 - ICF = 1 - IPUP = MITER - GO TO 220 -C - 430 CONTINUE - NFLAG = -1 - ICF = 2 - IPUP = MITER - RETURN -C -C Return for successful step. ------------------------------------------ - 450 NFLAG = 0 - JCUR = 0 - ICF = 0 - IF (M .EQ. 0) ACNRM = DEL - IF (M .GT. 0) ACNRM = DVNORM (N, ACOR, EWT) - RETURN -C----------------------- End of Subroutine DVNLSD ---------------------- - END - -*DECK DVJAC - SUBROUTINE DVJAC (Y, YH, LDYH, EWT, FTEM, SAVF, WM, IWM, FUN, JAC, - 1 IERPJ, RPAR, IPAR) -C IMPLICIT KPP_REAL (A-H, O-Z) - INCLUDE 'KPP_ROOT_Parameters.h' - INCLUDE 'KPP_ROOT_Sparse.h' - EXTERNAL FUN, JAC - KPP_REAL Y, YH, EWT, FTEM, SAVF, WM, RPAR - INTEGER LDYH, IWM, IERPJ, IPAR - DIMENSION Y(*), YH(LDYH,*), EWT(*), FTEM(*), SAVF(*), - 1 WM(*), IWM(*), RPAR(*), IPAR(*) - -C----------------------------------------------------------------------- -C Call sequence input -- Y, YH, LDYH, EWT, FTEM, SAVF, WM, IWM, -C FUN, JAC, RPAR, IPAR -C Call sequence output -- WM, IWM, IERPJ -C COMMON block variables accessed.. -C /DVOD01/ CCMXJ, DRC, H, RL1, TN, UROUND, ICF, JCUR, LOCJS, -C MSBJ, NSLJ -C /DVOD02/ NFE, NST, NJE, NLU -C -C Subroutines called by DVJAC.. FUN, JAC, DACOPY, DCOPY, DGBFA, DGEFA, -C DSCAL -C Function routines called by DVJAC.. DVNORM -C----------------------------------------------------------------------- -C DVJAC is called by DVSTEP to compute and process the matrix -C P = I - h*rl1*J , where J is an approximation to the Jacobian. -C Here J is computed by the user-supplied routine JAC if -C MITER = 1 or 4, or by finite differencing if MITER = 2, 3, or 5. -C If MITER = 3, a diagonal approximation to J is used. -C If JSV = -1, J is computed from scratch in all cases. -C If JSV = 1 and MITER = 1, 2, 4, or 5, and if the saved value of J is -C considered acceptable, then P is constructed from the saved J. -C J is stored in wm and replaced by P. If MITER .ne. 3, P is then -C subjected to LU decomposition in preparation for later solution -C of linear systems with P as coefficient matrix. This is done -C by DGEFA if MITER = 1 or 2, and by DGBFA if MITER = 4 or 5. -C -C Communication with DVJAC is done with the following variables. (For -C more details, please see the comments in the driver subroutine.) -C Y = Vector containing predicted values on entry. -C YH = The Nordsieck array, an LDYH by LMAX array, input. -C LDYH = A constant .ge. N, the first dimension of YH, input. -C EWT = An error weight vector of length N. -C SAVF = Array containing f evaluated at predicted y, input. -C WM = Real work space for matrices. In the output, it containS -C the inverse diagonal matrix if MITER = 3 and the LU -C decomposition of P if MITER is 1, 2 , 4, or 5. -C Storage of matrix elements starts at WM(3). -C Storage of the saved Jacobian starts at WM(LOCJS). -C WM also contains the following matrix-related data.. -C WM(1) = SQRT(UROUND), used in numerical Jacobian step. -C WM(2) = H*RL1, saved for later use if MITER = 3. -C IWM = Integer work space containing pivot information, -C starting at IWM(31), if MITER is 1, 2, 4, or 5. -C IWM also contains band parameters ML = IWM(1) and -C MU = IWM(2) if MITER is 4 or 5. -C FUN = Dummy name for the user supplied subroutine for f. -C JAC = Dummy name for the user supplied Jacobian subroutine. -C RPAR, IPAR = Dummy names for user's real and integer work arrays. -C RL1 = 1/EL(2) (input). -C IERPJ = Output error flag, = 0 if no trouble, 1 if the P -C matrix is found to be singular. -C JCUR = Output flag to indicate whether the Jacobian matrix -C (or approximation) is now current. -C JCUR = 0 means J is not current. -C JCUR = 1 means J is current. -C----------------------------------------------------------------------- -C -C Type declarations for labeled COMMON block DVOD01 -------------------- -C - KPP_REAL ACNRM, CCMXJ, CONP, CRATE, DRC, EL, - 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, - 2 RC, RL1, TAU, TQ, TN, UROUND - INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, - 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, - 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, - 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, - 4 NSLP, NYH -C -C Type declarations for labeled COMMON block DVOD02 -------------------- -C - KPP_REAL HU - INTEGER NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST -C -C Type declarations for local variables -------------------------------- -C - KPP_REAL CON, DI, FAC, HRL1, ONE, PT1, R, R0, SRUR, THOU, - 1 YI, YJ, YJJ, ZERO - INTEGER I, I1, I2, IER, II, J, J1, JJ, JOK, LENP, MBA, MBAND, - 1 MEB1, MEBAND, ML, ML3, MU, NP1 -C -C Type declaration for function subroutines called --------------------- -C - KPP_REAL DVNORM -C----------------------------------------------------------------------- -C The following Fortran-77 declaration is to cause the values of the -C listed (local) variables to be saved between calls to this subroutine. -C----------------------------------------------------------------------- - SAVE ONE, PT1, THOU, ZERO -C----------------------------------------------------------------------- - COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), - 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, - 2 RC, RL1, TAU(13), TQ(5), TN, UROUND, - 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, - 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, - 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, - 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, - 7 NSLP, NYH - COMMON /DVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST -C - DATA ONE /1.0D0/, THOU /1000.0D0/, ZERO /0.0D0/, PT1 /0.1D0/ -C - IER = 0 - IERPJ = 0 - HRL1 = H*RL1 -C See whether J should be evaluated (JOK = -1) or not (JOK = 1). ------- - JOK = JSV - IF (JSV .EQ. 1) THEN - IF (NST .EQ. 0 .OR. NST .GT. NSLJ+MSBJ) JOK = -1 - IF (ICF .EQ. 1 .AND. DRC .LT. CCMXJ) JOK = -1 - IF (ICF .EQ. 2) JOK = -1 - ENDIF -C End of setting JOK. -------------------------------------------------- -C - IF (JOK .EQ. -1 .AND. MITER .EQ. 1) THEN -C If JOK = -1 and MITER = 1, CALL JAC to evaluate Jacobian. ------------ - NJE = NJE + 1 - NSLJ = NST - JCUR = 1 - LENP = LU_NONZERO - DO 110 I = 1,LENP - 110 WM(I+2) = ZERO - -c CALL Update_SUN(TN) -c CALL Update_RCONST() - CALL JAC (N, TN, Y, WM(3)) - IF (JSV .EQ. 1) CALL DCOPY (LENP, WM(3), 1, WM(LOCJS), 1) - ENDIF -C - IF (JOK .EQ. -1 .AND. MITER .EQ. 2) THEN -C If MITER = 2, make N calls to FUN to approximate the Jacobian. --------- - NJE = NJE + 1 - NSLJ = NST - JCUR = 1 - FAC = DVNORM (N, SAVF, EWT) - R0 = THOU*ABS(H)*UROUND*REAL(N)*FAC - IF (R0 .EQ. ZERO) R0 = ONE - SRUR = WM(1) - J1 = 2 - DO 230 J = 1,N - YJ = Y(J) - R = MAX(SRUR*ABS(YJ),R0/EWT(J)) - Y(J) = Y(J) + R - FAC = ONE/R - CALL FUN (N, TN, Y, FTEM) - DO 220 I = 1,N - 220 WM(I+J1) = (FTEM(I) - SAVF(I))*FAC - Y(J) = YJ - J1 = J1 + N - 230 CONTINUE - NFE = NFE + N - LENP = LU_NONZERO - IF (JSV .EQ. 1) CALL DCOPY (LENP, WM(3), 1, WM(LOCJS), 1) - ENDIF -C - IF (JOK .EQ. 1 .AND. (MITER .EQ. 1 .OR. MITER .EQ. 2)) THEN - JCUR = 0 - LENP = LU_NONZERO - CALL DCOPY (LENP, WM(LOCJS), 1, WM(3), 1) - ENDIF -C - IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN -C Multiply Jacobian by scalar, add identity, and do LU decomposition. -- - CON = -HRL1 - CALL DSCAL (LENP, CON, WM(3), 1) - J = 3 - NP1 = N + 1 - DO 250 I = 1,N - WM(2+LU_DIAG(i)) = WM(2+LU_DIAG(i)) + ONE - 250 CONTINUE - NLU = NLU + 1 -C CALL DGEFA (WM(3), N, N, IWM(31), IER) - CALL KppDecomp ( WM(3), IER) - IF (IER .NE. 0) IERPJ = 1 - RETURN - ENDIF -C End of code block for MITER = 1 or 2. -------------------------------- -C - IF (MITER .EQ. 3) THEN -C If MITER = 3, construct a diagonal approximation to J and P. --------- - NJE = NJE + 1 - JCUR = 1 - WM(2) = HRL1 - R = RL1*PT1 - DO 310 I = 1,N - 310 Y(I) = Y(I) + R*(H*SAVF(I) - YH(I,2)) - CALL FUN (N, TN, Y, WM(3)) - NFE = NFE + 1 - DO 320 I = 1,N - R0 = H*SAVF(I) - YH(I,2) - DI = PT1*R0 - H*(WM(I+2) - SAVF(I)) - WM(I+2) = ONE - IF (ABS(R0) .LT. UROUND/EWT(I)) GO TO 320 - IF (ABS(DI) .EQ. ZERO) GO TO 330 - WM(I+2) = PT1*R0/DI - 320 CONTINUE - RETURN - 330 IERPJ = 1 - RETURN - ENDIF -C End of code block for MITER = 3. ------------------------------------- -C -C Set constants for MITER = 4 or 5. ------------------------------------ - ML = IWM(1) - MU = IWM(2) - ML3 = ML + 3 - MBAND = ML + MU + 1 - MEBAND = MBAND + ML - LENP = MEBAND*N -C - IF (JOK .EQ. -1 .AND. MITER .EQ. 4) THEN -C If JOK = -1 and MITER = 4, CALL JAC to evaluate Jacobian. ------------ - NJE = NJE + 1 - NSLJ = NST - JCUR = 1 - DO 410 I = 1,LENP - 410 WM(I+2) = ZERO - -c CALL Update_SUN(TN) -c CALL Update_RCONST() - CALL JAC (N, TN, Y, WM(ML3)) - IF (JSV .EQ. 1) - 1 CALL DACOPY (MBAND, N, WM(ML3), MEBAND, WM(LOCJS), MBAND) - ENDIF -C - IF (JOK .EQ. -1 .AND. MITER .EQ. 5) THEN -C If MITER = 5, make N calls to FUN to approximate the Jacobian. --------- - NJE = NJE + 1 - NSLJ = NST - JCUR = 1 - MBA = MIN(MBAND,N) - MEB1 = MEBAND - 1 - SRUR = WM(1) - FAC = DVNORM (N, SAVF, EWT) - R0 = THOU*ABS(H)*UROUND*REAL(N)*FAC - IF (R0 .EQ. ZERO) R0 = ONE - DO 560 J = 1,MBA - DO 530 I = J,N,MBAND - YI = Y(I) - R = MAX(SRUR*ABS(YI),R0/EWT(I)) - 530 Y(I) = Y(I) + R - CALL FUN (N, TN, Y, FTEM) - DO 550 JJ = J,N,MBAND - Y(JJ) = YH(JJ,1) - YJJ = Y(JJ) - R = MAX(SRUR*ABS(YJJ),R0/EWT(JJ)) - FAC = ONE/R - I1 = MAX(JJ-MU,1) - I2 = MIN(JJ+ML,N) - II = JJ*MEB1 - ML + 2 - DO 540 I = I1,I2 - 540 WM(II+I) = (FTEM(I) - SAVF(I))*FAC - 550 CONTINUE - 560 CONTINUE - NFE = NFE + MBA - IF (JSV .EQ. 1) - 1 CALL DACOPY (MBAND, N, WM(ML3), MEBAND, WM(LOCJS), MBAND) - ENDIF -C - IF (JOK .EQ. 1) THEN - JCUR = 0 - CALL DACOPY (MBAND, N, WM(LOCJS), MBAND, WM(ML3), MEBAND) - ENDIF -C -C Multiply Jacobian by scalar, add identity, and do LU decomposition. - CON = -HRL1 - CALL DSCAL (LENP, CON, WM(3), 1 ) - II = MBAND + 2 - DO 580 I = 1,N - WM(II) = WM(II) + ONE - 580 II = II + MEBAND - NLU = NLU + 1 -C CALL DGBFA (WM(3), MEBAND, N, ML, MU, IWM(31), IER) - IF (IER .NE. 0) IERPJ = 1 - RETURN -C End of code block for MITER = 4 or 5. -------------------------------- -C -C----------------------- End of Subroutine DVJAC ----------------------- - END -*DECK DACOPY - SUBROUTINE DACOPY (NROW, NCOL, A, NROWA, B, NROWB) - KPP_REAL A, B - INTEGER NROW, NCOL, NROWA, NROWB - DIMENSION A(NROWA,NCOL), B(NROWB,NCOL) -C----------------------------------------------------------------------- -C Call sequence input -- NROW, NCOL, A, NROWA, NROWB -C Call sequence output -- B -C COMMON block variables accessed -- None -C -C Subroutines called by DACOPY.. DCOPY -C Function routines called by DACOPY.. None -C----------------------------------------------------------------------- -C This routine copies one rectangular array, A, to another, B, -C where A and B may have different row dimensions, NROWA and NROWB. -C The data copied consists of NROW rows and NCOL columns. -C----------------------------------------------------------------------- - INTEGER IC -C - DO 20 IC = 1,NCOL - CALL DCOPY (NROW, A(1,IC), 1, B(1,IC), 1) - 20 CONTINUE -C - RETURN -C----------------------- End of Subroutine DACOPY ---------------------- - END -*DECK DVSOL - SUBROUTINE DVSOL (WM, IWM, X, IERSL) - KPP_REAL WM, X - INTEGER IWM, IERSL - DIMENSION WM(*), IWM(*), X(*) -C----------------------------------------------------------------------- -C Call sequence input -- WM, IWM, X -C Call sequence output -- X, IERSL -C COMMON block variables accessed.. -C /DVOD01/ -- H, RL1, MITER, N -C -C Subroutines called by DVSOL.. DGESL, DGBSL -C Function routines called by DVSOL.. None -C----------------------------------------------------------------------- -C This routine manages the solution of the linear system arising from -C a chord iteration. It is called if MITER .ne. 0. -C If MITER is 1 or 2, it calls DGESL to accomplish this. -C If MITER = 3 it updates the coefficient H*RL1 in the diagonal -C matrix, and then computes the solution. -C If MITER is 4 or 5, it calls DGBSL. -C Communication with DVSOL uses the following variables.. -C WM = Real work space containing the inverse diagonal matrix if -C MITER = 3 and the LU decomposition of the matrix otherwise. -C Storage of matrix elements starts at WM(3). -C WM also contains the following matrix-related data.. -C WM(1) = SQRT(UROUND) (not used here), -C WM(2) = HRL1, the previous value of H*RL1, used if MITER = 3. -C IWM = Integer work space containing pivot information, starting at -C IWM(31), if MITER is 1, 2, 4, or 5. IWM also contains band -C parameters ML = IWM(1) and MU = IWM(2) if MITER is 4 or 5. -C X = The right-hand side vector on input, and the solution vector -C on output, of length N. -C IERSL = Output flag. IERSL = 0 if no trouble occurred. -C IERSL = 1 if a singular matrix arose with MITER = 3. -C----------------------------------------------------------------------- -C -C Type declarations for labeled COMMON block DVOD01 -------------------- -C - KPP_REAL ACNRM, CCMXJ, CONP, CRATE, DRC, EL, - 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, - 2 RC, RL1, TAU, TQ, TN, UROUND - INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, - 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, - 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, - 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, - 4 NSLP, NYH -C -C Type declarations for local variables -------------------------------- -C - INTEGER I, MEBAND, ML, MU - KPP_REAL DI, HRL1, ONE, PHRL1, R, ZERO -C----------------------------------------------------------------------- -C The following Fortran-77 declaration is to cause the values of the -C listed (local) variables to be saved between calls to this integrator. -C----------------------------------------------------------------------- - SAVE ONE, ZERO -C - COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), - 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, - 2 RC, RL1, TAU(13), TQ(5), TN, UROUND, - 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, - 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, - 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, - 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, - 7 NSLP, NYH -C - DATA ONE /1.0D0/, ZERO /0.0D0/ -C - IERSL = 0 - GO TO (100, 100, 300, 400, 400), MITER -C 100 CALL DGESL (WM(3), N, N, IWM(31), X, 0) - 100 CALL KppSolve (WM(3), X) - RETURN -C - 300 PHRL1 = WM(2) - HRL1 = H*RL1 - WM(2) = HRL1 - IF (HRL1 .EQ. PHRL1) GO TO 330 - R = HRL1/PHRL1 - DO 320 I = 1,N - DI = ONE - R*(ONE - ONE/WM(I+2)) - IF (ABS(DI) .EQ. ZERO) GO TO 390 - 320 WM(I+2) = ONE/DI -C - 330 DO 340 I = 1,N - 340 X(I) = WM(I+2)*X(I) - RETURN - 390 IERSL = 1 - RETURN -C - 400 ML = IWM(1) - MU = IWM(2) - MEBAND = 2*ML + MU + 1 - CALL KppSolve (WM(3), X) - RETURN -C----------------------- End of Subroutine DVSOL ----------------------- - END -*DECK DVSRCO - SUBROUTINE DVSRCO (RSAV, ISAV, JOB) - KPP_REAL RSAV - INTEGER ISAV, JOB - DIMENSION RSAV(*), ISAV(*) -C----------------------------------------------------------------------- -C Call sequence input -- RSAV, ISAV, JOB -C Call sequence output -- RSAV, ISAV -C COMMON block variables accessed -- All of /DVOD01/ and /DVOD02/ -C -C Subroutines/functions called by DVSRCO.. None -C----------------------------------------------------------------------- -C This routine saves or restores (depending on JOB) the contents of the -C COMMON blocks DVOD01 and DVOD02, which are used internally by DVODE. -C -C RSAV = real array of length 49 or more. -C ISAV = integer array of length 41 or more. -C JOB = flag indicating to save or restore the COMMON blocks.. -C JOB = 1 if COMMON is to be saved (written to RSAV/ISAV). -C JOB = 2 if COMMON is to be restored (read from RSAV/ISAV). -C A CALL with JOB = 2 presumes a prior CALL with JOB = 1. -C----------------------------------------------------------------------- - KPP_REAL RVOD1, RVOD2 - INTEGER IVOD1, IVOD2 - INTEGER I, LENIV1, LENIV2, LENRV1, LENRV2 -C----------------------------------------------------------------------- -C The following Fortran-77 declaration is to cause the values of the -C listed (local) variables to be saved between calls to this integrator. -C----------------------------------------------------------------------- - SAVE LENRV1, LENIV1, LENRV2, LENIV2 -C - COMMON /DVOD01/ RVOD1(48), IVOD1(33) - COMMON /DVOD02/ RVOD2(1), IVOD2(8) - DATA LENRV1/48/, LENIV1/33/, LENRV2/1/, LENIV2/8/ -C - IF (JOB .EQ. 2) GO TO 100 - DO 10 I = 1,LENRV1 - 10 RSAV(I) = RVOD1(I) - DO 15 I = 1,LENRV2 - 15 RSAV(LENRV1+I) = RVOD2(I) -C - DO 20 I = 1,LENIV1 - 20 ISAV(I) = IVOD1(I) - DO 25 I = 1,LENIV2 - 25 ISAV(LENIV1+I) = IVOD2(I) -C - RETURN -C - 100 CONTINUE - DO 110 I = 1,LENRV1 - 110 RVOD1(I) = RSAV(I) - DO 115 I = 1,LENRV2 - 115 RVOD2(I) = RSAV(LENRV1+I) -C - DO 120 I = 1,LENIV1 - 120 IVOD1(I) = ISAV(I) - DO 125 I = 1,LENIV2 - 125 IVOD2(I) = ISAV(LENIV1+I) -C - RETURN -C----------------------- End of Subroutine DVSRCO ---------------------- - END -*DECK DEWSET - SUBROUTINE DEWSET (N, ITOL, RelTol, AbsTol, YCUR, EWT) - KPP_REAL RelTol, AbsTol, YCUR, EWT - INTEGER N, ITOL - DIMENSION RelTol(*), AbsTol(*), YCUR(N), EWT(N) -C----------------------------------------------------------------------- -C Call sequence input -- N, ITOL, RelTol, AbsTol, YCUR -C Call sequence output -- EWT -C COMMON block variables accessed -- None -C -C Subroutines/functions called by DEWSET.. None -C----------------------------------------------------------------------- -C This subroutine sets the error weight vector EWT according to -C EWT(i) = RelTol(i)*abs(YCUR(i)) + AbsTol(i), i = 1,...,N, -C with the subscript on RelTol and/or AbsTol possibly replaced by 1 above, -C depending on the value of ITOL. -C----------------------------------------------------------------------- - INTEGER I -C - GO TO (10, 20, 30, 40), ITOL - 10 CONTINUE - DO 15 I = 1, N - 15 EWT(I) = RelTol(1)*ABS(YCUR(I)) + AbsTol(1) - RETURN - 20 CONTINUE - DO 25 I = 1, N - 25 EWT(I) = RelTol(1)*ABS(YCUR(I)) + AbsTol(I) - RETURN - 30 CONTINUE - DO 35 I = 1, N - 35 EWT(I) = RelTol(I)*ABS(YCUR(I)) + AbsTol(1) - RETURN - 40 CONTINUE - DO 45 I = 1, N - 45 EWT(I) = RelTol(I)*ABS(YCUR(I)) + AbsTol(I) - RETURN -C----------------------- End of Subroutine DEWSET ---------------------- - END -*DECK DVNORM - KPP_REAL FUNCTION DVNORM (N, V, W) - KPP_REAL V, W - INTEGER N - DIMENSION V(N), W(N) -C----------------------------------------------------------------------- -C Call sequence input -- N, V, W -C Call sequence output -- None -C COMMON block variables accessed -- None -C -C Subroutines/functions called by DVNORM.. None -C----------------------------------------------------------------------- -C This function routine computes the weighted root-mean-square norm -C of the vector of length N contained in the array V, with weights -C contained in the array W of length N.. -C DVNORM = sqrt( (1/N) * sum( V(i)*W(i) )**2 ) -C -C LOOP UNROLLING BY ADRIAN SANDU, AUG 2, 1995 -C -C----------------------------------------------------------------------- - KPP_REAL SUM - INTEGER I -C - SUM = 0.0D0 - - 20 m = mod(n,7) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - SUM = SUM + (V(I)*W(I))**2 - 30 continue - if( n .lt. 7 ) return - 40 mp1 = m + 1 - do 50 i = mp1,n,7 - SUM = SUM + (V(I)*W(I))**2 - SUM = SUM + (V(I + 1)*W(I + 1))**2 - SUM = SUM + (V(I + 2)*W(I + 2))**2 - SUM = SUM + (V(I + 3)*W(I + 3))**2 - SUM = SUM + (V(I + 4)*W(I + 4))**2 - SUM = SUM + (V(I + 5)*W(I + 5))**2 - SUM = SUM + (V(I + 6)*W(I + 6))**2 - 50 continue - - DVNORM = SQRT(SUM/REAL(N)) - RETURN -C----------------------- End of Function DVNORM ------------------------ - END - -*DECK D1MACH - KPP_REAL FUNCTION D1MACH (IDUM) - INTEGER IDUM -C----------------------------------------------------------------------- -C This routine computes the unit roundoff of the machine. -C This is defined as the smallest positive machine number -C u such that 1.0 + u .ne. 1.0 -C -C Subroutines/functions called by D1MACH.. None -C----------------------------------------------------------------------- - KPP_REAL U, COMP - U = 1.0D0 - 10 U = U*0.5D0 - COMP = 1.0D0 + U - IF (COMP .NE. 1.0D0) GO TO 10 - D1MACH = U*2.0D0 - RETURN -C----------------------- End of Function D1MACH ------------------------ - END -*DECK XERRWD - SUBROUTINE XERRWD (MSG, NMES, NERR, LEVEL, NI, I1, I2, NR, R1, R2) - KPP_REAL R1, R2 - INTEGER NMES, NERR, LEVEL, NI, I1, I2, NR - CHARACTER*1 MSG(NMES) -C----------------------------------------------------------------------- -C Subroutines XERRWD, XSETF, XSETUN, and the two function routines -C MFLGSV and LUNSAV, as given here, constitute a simplified version of -C the SLATEC error handling package. -C Written by A. C. Hindmarsh and P. N. Brown at LLNL. -C Version of 13 April, 1989. -C This version is in KPP_REAL. -C -C All arguments are input arguments. -C -C MSG = The message (character array). -C NMES = The length of MSG (number of characters). -C NERR = The error number (not used). -C LEVEL = The error level.. -C 0 or 1 means recoverable (control returns to caller). -C 2 means fatal (run is aborted--see note below). -C NI = Number of integers (0, 1, or 2) to be printed with message. -C I1,I2 = Integers to be printed, depending on NI. -C NR = Number of reals (0, 1, or 2) to be printed with message. -C R1,R2 = Reals to be printed, depending on NR. -C -C Note.. this routine is machine-dependent and specialized for use -C in limited context, in the following ways.. -C 1. The argument MSG is assumed to be of type CHARACTER, and -C the message is printed with a format of (1X,80A1). -C 2. The message is assumed to take only one line. -C Multi-line messages are generated by repeated calls. -C 3. If LEVEL = 2, control passes to the statement STOP -C to abort the run. This statement may be machine-dependent. -C 4. R1 and R2 are assumed to be in KPP_REAL and are printed -C in D21.13 format. -C -C For a different default logical unit number, change the data -C statement in function routine LUNSAV. -C For a different run-abort command, change the statement following -C statement 100 at the end. -C----------------------------------------------------------------------- -C Subroutines called by XERRWD.. None -C Function routines called by XERRWD.. MFLGSV, LUNSAV -C----------------------------------------------------------------------- -C - INTEGER I, LUNIT, LUNSAV, MESFLG, MFLGSV -C -C Get message print flag and logical unit number. ---------------------- - MESFLG = MFLGSV (0,.FALSE.) - LUNIT = LUNSAV (0,.FALSE.) - IF (MESFLG .EQ. 0) GO TO 100 -C Write the message. --------------------------------------------------- - WRITE (LUNIT,10) (MSG(I),I=1,NMES) - 10 FORMAT(1X,80A1) - IF (NI .EQ. 1) WRITE (LUNIT, 20) I1 - 20 FORMAT(6X,'In above message, I1 =',I10) - IF (NI .EQ. 2) WRITE (LUNIT, 30) I1,I2 - 30 FORMAT(6X,'In above message, I1 =',I10,3X,'I2 =',I10) - IF (NR .EQ. 1) WRITE (LUNIT, 40) R1 - 40 FORMAT(6X,'In above message, R1 =',D21.13) - IF (NR .EQ. 2) WRITE (LUNIT, 50) R1,R2 - 50 FORMAT(6X,'In above, R1 =',D21.13,3X,'R2 =',D21.13) -C Abort the run if LEVEL = 2. ------------------------------------------ - 100 IF (LEVEL .NE. 2) RETURN - STOP -C----------------------- End of Subroutine XERRWD ---------------------- - END -*DECK XSETF - SUBROUTINE XSETF (MFLAG) -C----------------------------------------------------------------------- -C This routine resets the print control flag MFLAG. -C -C Subroutines called by XSETF.. None -C Function routines called by XSETF.. MFLGSV -C----------------------------------------------------------------------- - INTEGER MFLAG, JUNK, MFLGSV -C - IF (MFLAG .EQ. 0 .OR. MFLAG .EQ. 1) JUNK = MFLGSV (MFLAG,.TRUE.) - RETURN -C----------------------- End of Subroutine XSETF ----------------------- - END -*DECK XSETUN - SUBROUTINE XSETUN (LUN) -C----------------------------------------------------------------------- -C This routine resets the logical unit number for messages. -C -C Subroutines called by XSETUN.. None -C Function routines called by XSETUN.. LUNSAV -C----------------------------------------------------------------------- - INTEGER LUN, JUNK, LUNSAV -C - IF (LUN .GT. 0) JUNK = LUNSAV (LUN,.TRUE.) - RETURN -C----------------------- End of Subroutine XSETUN ---------------------- - END -*DECK MFLGSV - INTEGER FUNCTION MFLGSV (IVALUE, ISET) - LOGICAL ISET - INTEGER IVALUE -C----------------------------------------------------------------------- -C MFLGSV saves and recalls the parameter MESFLG which controls the -C printing of the error messages. -C -C Saved local variable.. -C -C MESFLG = Print control flag.. -C 1 means print all messages (the default). -C 0 means no printing. -C -C On input.. -C -C IVALUE = The value to be set for the MESFLG parameter, -C if ISET is .TRUE. . -C -C ISET = Logical flag to indicate whether to read or write. -C If ISET=.TRUE., the MESFLG parameter will be given -C the value IVALUE. If ISET=.FALSE., the MESFLG -C parameter will be unchanged, and IVALUE is a dummy -C parameter. -C -C On return.. -C -C The (old) value of the MESFLG parameter will be returned -C in the function value, MFLGSV. -C -C This is a modification of the SLATEC library routine J4SAVE. -C -C Subroutines/functions called by MFLGSV.. None -C----------------------------------------------------------------------- - INTEGER MESFLG -C----------------------------------------------------------------------- -C The following Fortran-77 declaration is to cause the values of the -C listed (local) variables to be saved between calls to this integrator. -C----------------------------------------------------------------------- - SAVE MESFLG - DATA MESFLG/1/ -C - MFLGSV = MESFLG - IF (ISET) MESFLG = IVALUE - RETURN -C----------------------- End of Function MFLGSV ------------------------ - END -*DECK LUNSAV - INTEGER FUNCTION LUNSAV (IVALUE, ISET) - LOGICAL ISET - INTEGER IVALUE -C----------------------------------------------------------------------- -C LUNSAV saves and recalls the parameter LUNIT which is the logical -C unit number to which error messages are printed. -C -C Saved local variable.. -C -C LUNIT = Logical unit number for messages. -C The default is 6 (machine-dependent). -C -C On input.. -C -C IVALUE = The value to be set for the LUNIT parameter, -C if ISET is .TRUE. . -C -C ISET = Logical flag to indicate whether to read or write. -C If ISET=.TRUE., the LUNIT parameter will be given -C the value IVALUE. If ISET=.FALSE., the LUNIT -C parameter will be unchanged, and IVALUE is a dummy -C parameter. -C -C On return.. -C -C The (old) value of the LUNIT parameter will be returned -C in the function value, LUNSAV. -C -C This is a modification of the SLATEC library routine J4SAVE. -C -C Subroutines/functions called by LUNSAV.. None -C----------------------------------------------------------------------- - INTEGER LUNIT -C----------------------------------------------------------------------- -C The following Fortran-77 declaration is to cause the values of the -C listed (local) variables to be saved between calls to this integrator. -C----------------------------------------------------------------------- - SAVE LUNIT - DATA LUNIT/6/ -C - LUNSAV = LUNIT - IF (ISET) LUNIT = IVALUE - RETURN -C----------------------- End of Function LUNSAV ------------------------ - END - - SUBROUTINE VODE_FSPLIT_VAR(N, T, Y, PR) - INCLUDE 'KPP_ROOT_Parameters.h' - INCLUDE 'KPP_ROOT_Global.h' - INTEGER N - REAL*8 Told, T - REAL*8 Y(NVAR), PR(NVAR) - - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Fun( Y, FIX, RCONST, PR ) - TIME = Told - RETURN - END - - SUBROUTINE VODE_Jac_SP(N, T, Y, J) - INCLUDE 'KPP_ROOT_Parameters.h' - INCLUDE 'KPP_ROOT_Global.h' - INTEGER N - REAL*8 Told, T - REAL*8 Y(NVAR), J(LU_NONZERO) - - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Jac_SP( Y, FIX, RCONST, J ) - TIME = Told - RETURN - END - diff --git a/boxmox/int/kpp_lsode.def b/boxmox/int/kpp_lsode.def deleted file mode 100644 index 500c69147210bbb694f98305b34d00480754f01d..0000000000000000000000000000000000000000 --- a/boxmox/int/kpp_lsode.def +++ /dev/null @@ -1,7 +0,0 @@ -#FUNCTION AGGREGATE -#JACOBIAN SPARSE_LU_ROW -#DOUBLE ON -#INTFILE kpp_lsode - - - diff --git a/boxmox/int/kpp_odessa_ddm.def b/boxmox/int/kpp_odessa_ddm.def deleted file mode 100644 index 5219914416a6f0e2d6682c1c83b4d84ade8bf4c2..0000000000000000000000000000000000000000 --- a/boxmox/int/kpp_odessa_ddm.def +++ /dev/null @@ -1,42 +0,0 @@ - -#FUNCTION AGGREGATE -#JACOBIAN SPARSE_LU_ROW -#DOUBLE ON -#INTFILE kpp_odessa_ddm - -#INLINE F77_GLOBAL - INTEGER Autonomous - COMMON /INTGDATA/ Autonomous - REAL*8 STEPSTART - COMMON /GDATA/ STEPSTART -#ENDINLINE - -#INLINE F77_INIT - STEPMIN=0.0001 - STEPMAX=3600. - Autonomous = 0 - STEPSTART=STEPMIN -#ENDINLINE - - - -#INLINE C_GLOBAL -extern int Autonomous; -extern double STEPSTART; -#ENDINLINE - -#INLINE C_DATA_INT -int Autonomous; -double STEPSTART; -#ENDINLINE - - - -#INLINE C_INIT - STEPMIN=0.0001; - STEPMAX=3600.0; - Autonomous = 0; - STEPSTART=STEPMIN; -#ENDINLINE - - diff --git a/boxmox/int/kpp_odessa_ddm.f b/boxmox/int/kpp_odessa_ddm.f deleted file mode 100644 index 788321fb3228ca028d7325cc504afab6b489a8ad..0000000000000000000000000000000000000000 --- a/boxmox/int/kpp_odessa_ddm.f +++ /dev/null @@ -1,4427 +0,0 @@ - SUBROUTINE INTEGRATE( NSENSIT, Y, TIN, TOUT ) - - INCLUDE 'KPP_ROOT_Parameters.h' - INCLUDE 'KPP_ROOT_Global.h' - -C TIN - Start Time - REAL*8 TIN -C TOUT - End Time - REAL*8 TOUT -C Concentrations and Sensitivities - REAL*8 Y(NVAR,NSENSIT+1), PARAMS(NSENSIT) -C --- Note: Y contains: (1:NVAR) concentrations, followed by -C --- (1:NVAR) sensitivities w.r.t. first parameter, followed by -C --- etc., followed by -C --- (1:NVAR) sensitivities w.r.t. NSENSIT's parameter - INTEGER i - - INTEGER LIW, LRW -C PARAMETER (LRW = 22 + 8*(NSENSIT+1)*NVAR + NVAR**2 + NVAR) -C PARAMETER (LIW = 21 + NVAR + NSENSIT) -C REAL*8 RWORK(LRW) -C INTEGER IWORK(LIW) -C Note: the following dynamic allocation is not standard F77 and may not work on -C some systems. Declare LRW, LIW parameters as above with some upper bound used for NSENSIT - REAL*8 RWORK(22 + 8*(NSENSIT+1)*NVAR + NVAR**2 + NVAR) - INTEGER IWORK(21 + NVAR + NSENSIT) - - INTEGER IOPT(3), NEQ(2) - - EXTERNAL FUNC_CHEM,JAC,DFUNC_CHEMDPAR - - MF = 21 ! --- BDF plus user-supplied Jacobian - - LRW = 22 + 8*(NSENSIT+1)*NVAR + NVAR**2 + NVAR - LIW = 21 + NVAR + NSENSIT - - NEQ(1) = NVAR ! --- No. of Variables - NEQ(2) = NSENSIT ! --- No of parameters - - ITOL=1 ! --- 1=Scalar Tolerances; 4 = VECTOR TOLERANCES - ITASK=1 ! --- Normal Output - ISTATE=1 - IOPT(1)=1 ! --- 0= No optional parameters, 1=Optional parameters - IOPT(2)=1 ! --- 1=Perform sensitivity analysis; 0 if not - IOPT(3)=1 ! --- 1 if DFUNC_CHEMDPAR supplied by the user; - ! --- 0 if finite differences are to be used -C --- Set optional parameters - DO 10 i=1,LRW - RWORK(i) = 0.0D0 - 10 CONTINUE - DO 20 i=1,LIW - IWORK(i) = 0 - 20 CONTINUE - - RWORK(5) = STEPMIN ! THE STEP SIZE TO BE ATTEMPTED ON THE FIRST STEP. - RWORK(6) = STEPMAX ! THE MAXIMUM ABSOLUTE STEP SIZE ALLOWED. - RWORK(7) = 0.0D0 ! THE MINIMUM ABSOLUTE STEP SIZE ALLOWED. - IWORK(6) = 5000 ! MAXIMUM NUMBER OF (INTERNALLY DEFINED) STEPS - - CALL KPP_ODESSA( FUNC_CHEM,DFUNC_CHEMDPAR,NEQ,Y,PARAMS,TIN,TOUT, - & ITOL,RTOL,ATOL, - 1 ITASK,ISTATE,IOPT,RWORK,LRW,IWORK,LIW, - & JAC,MF) - - IF (ISTATE.LT.0) THEN - print *,'KPP_ODESSA: Unsucessfull exit at T=', - & TIN,' (ISTATE=',ISTATE,')' - ENDIF - - RETURN - END - - - - - SUBROUTINE FUNC_CHEM (N, T, V, PARAMS, FCT) - INCLUDE 'KPP_ROOT_Parameters.h' - INCLUDE 'KPP_ROOT_Global.h' - - DIMENSION V(NVAR), PARAMS(*), FCT(NVAR) - TOLD = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - TIME = TOLD - CALL Fun(V, FIX, RCONST, FCT) - RETURN - END - - SUBROUTINE DFUNC_CHEMDPAR (N, T, V, PARAMS, DFCT, JPAR) - INCLUDE 'KPP_ROOT_Parameters.h' - INCLUDE 'KPP_ROOT_Global.h' -C --- NCOEFF = number of rate coefficients w.r.t. which we differentiate -C (note that in some applications NCOEFF may be different than NSENSIT) -C JCOEFF(1:NCOEFF) are the indices of rate coefficients w.r.t. which we differentiate - INTEGER NCOEFF, JCOEFF(NREACT) - COMMON /DDMRCOEFF/ NCOEFF, JCOEFF - - DIMENSION V(NVAR), PARAMS(*), DFCT(NVAR) - INTEGER JPAR, i, JC(1) - IF (DDMTYPE .EQ. 0) THEN -C This setting is required for sensitivities w.r.t. initial conditions - DO i=1,NVAR - DFCT(i) = 0.d0 - END DO - ELSE -C This setting is required for sensitivities w.r.t. rate coefficients -C ... and should be changed by the user for other applications - JC(1) = JCOEFF(JPAR) - CALL dFun_dRcoeff(V, FIX, 1, JC, DFCT ) - END IF - RETURN - END - - SUBROUTINE JAC (N, T, V, PARAMS, ML, MU, JS, NROWPD) - INCLUDE 'KPP_ROOT_Parameters.h' - INCLUDE 'KPP_ROOT_Sparse.h' - - REAL*8 V(NVAR), PARAMS(*), JS(LU_NONZERO) - INTEGER ML, MU, NROWPD - TOLD = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - TIME = TOLD - DO i=1,LU_NONZERO - JS(i) = 0.0D0 - END DO - CALL Jac_SP(V, FIX, RCONST, JS) - RETURN - END - - -C ALGORITHM 658, COLLECTED ALGORITHMS FROM ACM. -C THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE, -C VOL. 14, NO. 1, P.61. -C----------------------------------------------------------------------- -C THIS IS THE SEPTEMBER 1, 1986 VERSION OF ODESSA.. -C AN ORDINARY DIFFERENTIAL EQUATION KppSolveR WITH EXPLICIT SIMULTANEOUS -C SENSITIVITY ANALYSIS. -C -C THIS PACKAGE IS A MODIFICATION OF THE AUGUST 13, 1981 VERSION OF -C LSODE.. LIVERMORE KppSolveR FOR ORDINARY DIFFERENTIAL EQUATIONS. -C THIS VERSION IS IN DOUBLE PRECISION. -C -C ODESSA KppSolveS FOR THE FIRST-ORDER SENSITIVITY COEFFICIENTS.. -C DY(I)/DP, FOR A SINGLE PARAMETER, OR, -C DY(I)/DP(J), FOR MULTIPLE PARAMETERS, -C ASSOCIATED WITH A SYSTEM OF ORDINARY DIFFERENTIAL EQUATIONS.. -C DY/DT = F(Y,T;P). -C----------------------------------------------------------------------- -C REFERENCES... -C -C 1. JORGE R. LEIS AND MARK A. KRAMER, THE SIMULTANEOUS SOLUTION AND -C EXPLICIT SENSITIVITY ANALYSIS OF SYSTEMS DESCRIBED BY ORDINARY -C DIFFERENTIAL EQUATIONS. SUBMITTED TO ACM TRANS. MATH. SOFTWARE, -C (1985). -C -C 2. JORGE R. LEIS AND MARK A. KRAMER, ODESSA - AN ORDINARY DIFFERENTIA -C EQUATION KppSolveR WITH EXPLICIT SIMULTANEOUS SENSITIVITY ANALYSIS. -C SUBMITTED TO ACM TRANS. MATH. SOFTWARE, (1985). -C -C 3. ALAN C. HINDMARSH, LSODE AND LSODI, TWO NEW INITIAL VALUE -C ORDINARY DIFFERENTIAL EQUATION KppSolveRS, ACM-SIGNUM NEWSLETTER, -C VOL. 15, NO. 4 (1980), PP. 10-11. -C----------------------------------------------------------------------- -C PROBLEM STATEMENT.. -C -C THE ODESSA MODIFICATION OF THE LSODE PACKAGE PROVIDES THE OPTION TO -C CALCULATE FIRST-ORDER SENSITIVITY COEFFICIENTS FOR A SYSTEM OF STIFF -C OR NON-STIFF EXPLICIT ORDINARY DIFFERENTIAL EQUATIONS OF THE GENERAL -C FORM : -C -C DY/DT = F(Y,T;P) (1) -C -C WHERE Y IS AN N-DIMENSIONAL DEPENDENT VARIABLE VECTOR, T IS THE -C INDEPENDENT INTEGRATION VARIABLE, AND P IS AN NPAR-DIMENSIONAL -C CONSTANT VECTOR. THE GOVERNING EQUATIONS FOR THE FIRST-ORDER -C SENSITIVITY COEFFICIENTS ARE GIVEN BY : -C -C S'(T) = J(T)*S(T) + DF/DP (2) -C -C WHERE -C -C S(T) = DY(T)/DP (= SENSITIVITY FUNCTIONS) -C S'(T) = D(DY(T)/DP)/DT -C J(T) = DF(Y,T;P)/DY(T) (= JACOBIAN MATRIX) -C AND DF/DP = DF(Y,T;P)/DP (= INHOMOGENEITY MATRIX) -C -C SOLUTION OF EQUATIONS (1) AND (2) PROCEEDS SIMULTANEOUSLY VIA AN -C EXTENSION OF THE LSODE PACKAGE AS DESCRIBED IN [1]. -C---------------------------------------------------------------------- -C ACKNOWLEDGEMENT : THE FOLLOWING ODESSA PACKAGE DOCUMENTATION IS A -C MODIFICATION OF THE LSODE DOCUMENTATION WHICH -C ACCOMPANIES THE LSODE PACKAGE CODE. -C---------------------------------------------------------------------- -C SUMMARY OF USAGE. -C -C COMMUNICATION BETWEEN THE USER AND THE ODESSA PACKAGE, FOR NORMAL -C SITUATIONS, IS SUMMARIZED HERE. THIS SUMMARY DESCRIBES ONLY A SUBSET -C OF THE FULL SET OF OPTIONS AVAILABLE. SEE THE FULL DESCRIPTION FOR -C DETAILS, INCLUDING OPTIONAL COMMUNICATION, NONSTANDARD OPTIONS, -C AND INSTRUCTIONS FOR SPECIAL SITUATIONS. SEE ALSO THE EXAMPLE -C PROBLEM (WITH PROGRAM AND OUTPUT) FOLLOWING THIS SUMMARY. -C -C A. FIRST PROVIDE A SUBROUTINE OF THE FORM.. -C SUBROUTINE F (N, T, Y, PAR, YDOT) -C DOUBLE PRECISION T, Y, PAR, YDOT -C DIMENSION Y(N), YDOT(N), PAR(NPAR) -C WHICH SUPPLIES THE VECTOR FUNCTION F BY LOADING YDOT(I) WITH F(I). -C N IS THE NUMBER OF FIRST-ORDER DIFFERENTIAL EQUATIONS IN THE -C ABOVE MODEL. NPAR IS THE NUMBER OF MODEL PARAMETERS FOR WHICH -C VECTOR SENSITIVITY FUNCTIONS ARE DESIRED. YOU ARE ALSO ENCOURAGED -C TO PROVIDE A SUBROUTINE OF THE FORM.. -C SUBROUTINE DF (N, T, Y, PAR, DFDP, JPAR) -C DOUBLE PRECISION T, Y, PAR, DFDP -C DIMENSION Y(N), PAR(NPAR), DFDP(N) -C GO TO (1,...,NPAR) JPAR -C 1 DFDP(1) = DF(1)/DP(1) -C . -C DFDP(I) = DF(I)/DP(1) -C . -C DFDP(N) = DF(N)/DP(1) -C RETURN -C 2 DFDP(1) = DF(1)/DP(2) -C . -C DFDP(I) = DF(I)/DP(2) -C . -C DFDP(N) = DF(N)/DP(2) -C RETURN -C . . -C . . -C RETURN -C NPAR DFDP(1) = DF(1)/DP(NPAR) -C . -C DFDP(I) = DF(I)/DP(NPAR) -C . -C DFDP(N) = DF(N)/DP(NPAR) -C RETURN -C END -C ONLY NONZERO ELEMENTS NEED BE LOADED. IF THIS IS NOT FEASIBLE, -C ODESSA WILL GENERATE THIS MATRIX INTERNALLY BY DIFFERENCE QUOTIENTS. -C -C B. NEXT DETERMINE (OR GUESS) WHETHER OR NOT THE PROBLEM IS STIFF. -C STIFFNESS OCCURS WHEN THE JACOBIAN MATRIX DF/DY HAS AN EIGENVALUE -C WHOSE REAL PART IS NEGATIVE AND LARGE IN MAGNITUDE, COMPARED TO THE -C RECIPROCAL OF THE T SPAN OF INTEREST. IF THE PROBLEM IS NONSTIFF, -C USE METH = 10. IF IT IS STIFF, USE METH = 20. THE USER IS REQUIRED -C TO INPUT THE METHOD FLAG MF = 10*METH + MITER. THERE ARE FOUR -C STANDARD CHOICES FOR MITER WHEN A SENSITIVITY ANALYSIS IS DESIRED, -C AND ODESSA REQUIRES THE JACOBIAN MATRIX IN SOME FORM. -C THIS MATRIX IS REGARDED EITHER AS FULL (MITER = 1 OR 2), -C OR BANDED (MITER = 4 OR 5). IN THE BANDED CASE, ODESSA REQUIRES TWO -C HALF-BANDWIDTH PARAMETERS ML AND MU. THESE ARE, RESPECTIVELY, THE -C WIDTHS OF THE LOWER AND UPPER PARTS OF THE BAND, EXCLUDING THE MAIN -C DIAGONAL. THUS THE BAND CONSISTS OF THE LOCATIONS (I,J) WITH -C I-ML .LE. J .LE. I+MU, AND THE FULL BANDWIDTH IS ML+MU+1. -C -C C. YOU ARE ENCOURAGED TO SUPPLY THE JACOBIAN DIRECTLY (MF = 11, 14, -C 21, OR 24), BUT IF THIS IS NOT FEASIBLE, ODESSA WILL COMPUTE IT -C INTERNALLY BY DIFFERENCE QUOTIENTS (MF = 12, 15, 22, OR 25). IF YOU -C ARE SUPPLYING THE JACOBIAN, PROVIDE A SUBROUTINE OF THE FORM.. -C SUBROUTINE JAC (NEQ, T, Y, PAR, ML, MU, PD, NROWPD) -C DOUBLE PRECISION T, Y, PAR, PD -C DIMENSION Y(N), PD(NROWPD,N), PAR(NPAR) -C WHICH SUPPLIES DF/DY BY LOADING PD AS FOLLOWS.. -C FOR A FULL JACOBIAN (MF = 11, OR 21), LOAD PD(I,J) WITH DF(I)/DY(J), -C THE PARTIAL DERIVATIVE OF F(I) WITH RESPECT TO Y(J). (IGNORE THE -C ML AND MU ARGUMENTS IN THIS CASE.) -C FOR A BANDED JACOBIAN (MF = 14, OR 24), LOAD PD(I-J+MU+1,J) WITH -C DF(I)/DY(J), I.E. LOAD THE DIAGONAL LINES OF DF/DY INTO THE ROWS OF -C PD FROM THE TOP DOWN. -C IN EITHER CASE, ONLY NONZERO ELEMENTS NEED BE LOADED. -C -C D. WRITE A MAIN PROGRAM WHICH CALLS SUBROUTINE ODESSA ONCE FOR -C EACH POINT AT WHICH ANSWERS ARE DESIRED. THIS SHOULD ALSO PROVIDE -C FOR POSSIBLE USE OF LOGICAL UNIT 6 FOR OUTPUT OF ERROR MESSAGES BY -C ODESSA. ON THE FIRST CALL TO ODESSA, SUPPLY ARGUMENTS AS FOLLOWS.. -C F = NAME OF SUBROUTINE FOR RIGHT-HAND SIDE VECTOR F (MODEL). -C THIS NAME MUST BE DECLARED EXTERNAL IN CALLING PROGRAM. -C DF = NAME OF SUBROUTINE FOR INHOMOGENEITY MATRIX DF/DP. -C IF USED (IDF = 1), THIS NAME MUST BE DECLARED EXTERNAL IN -C CALLING PROGRAM. IF NOT USED (IDF = 0), PASS A DUMMY NAME. -C N = NUMBER OF FIRST ORDER ODE-S IN MODEL; LOAD INTO NEQ(1). -C NPAR = NUMBER OF MODEL PARAMETERS OF INTEREST; LOAD INTO NEQ(2). -C Y = AN (N) BY (NPAR+1) REAL ARRAY OF INITIAL VALUES.. -C Y(I,1) , I = 1,N , CONTAIN THE STATE, OR MODEL, DEPENDENT -C VARIABLES, -C Y(I,J) , J = 2,NPAR , CONTAIN THE DEPENDENT SENSITIVITY -C COEFFICIENTS. -C PAR = A REAL ARRAY OF LENGTH NPAR CONTAINING MODEL PARAMETERS -C OF INTEREST. -C T = THE INITIAL VALUE OF THE INDEPENDENT VARIABLE. -C TOUT = FIRST POINT WHERE OUTPUT IS DESIRED (.NE. T). -C ITOL = 1, 2, 3, OR 4 ACCORDING AS RTOL, ATOL (BELOW) ARE SCALARS -C OR ARRAYS. -C RTOL = RELATIVE TOLERANCE PARAMETER (SCALAR OR (N) BY (NPAR+1) -C ARRAY). -C ATOL = ABSOLUTE TOLERANCE PARAMETER (SCALAR OR (N) BY (NPAR+1) -C ARRAY). -C THE ESTIMATED LOCAL ERROR IN Y(I,J) WILL BE CONTROLLED SO AS -C TO BE ROUGHLY LESS (IN MAGNITUDE) THAN -C EWT(I,J) = RTOL*ABS(Y(I,J)) + ATOL IF ITOL = 1, -C EWT(I,J) = RTOL*ABS(Y(I,J)) + ATOL(I,J) IF ITOL = 2, -C EWT(I,J) = RTOL(I,J)*ABS(Y(I,J) + ATOL IF ITOL = 3, OR -C EWT(I,J) = RTOL(I,J)*ABS(Y(I,J) + ATOL(I,J) IF ITOL = 4. -C THUS THE LOCAL ERROR TEST PASSES IF, IN EACH COMPONENT, -C EITHER THE ABSOLUTE ERROR IS LESS THAN ATOL (OR ATOL(I,J)), -C OR THE RELATIVE ERROR IS LESS THAN RTOL (OR RTOL(I,J)). -C USE RTOL = 0.0 FOR PURE ABSOLUTE ERROR CONTROL, AND -C USE ATOL = 0.0 FOR PURE RELATIVE ERROR CONTROL. -C CAUTION.. ACTUAL (GLOBAL) ERRORS MAY EXCEED THESE LOCAL -C TOLERANCES, SO CHOOSE THEM CONSERVATIVELY. -C ITASK = 1 FOR NORMAL COMPUTATION OF OUTPUT VALUES OF Y AT T = TOUT. -C ISTATE = INTEGER FLAG (INPUT AND OUTPUT). SET ISTATE = 1. -C IOPT = 0, TO INDICATE NO OPTIONAL INPUTS FOR INTEGRATION; -C LOAD INTO IOPT(1). -C ISOPT = 1, TO INDICATE SENSITIVITY ANALYSIS, = 0, TO INDICATE -C NO SENSITIVITY ANALYSIS; LOAD INTO IOPT(2). -C IDF = 1, IF SUBROUTINE DF (ABOVE) IS SUPPLIED BY THE USER, -C = 0, OTHERWISE; LOAD INTO IOPT(3). -C RWORK = REAL WORK ARRAY OF LENGTH AT LEAST.. -C 22 + 16*N + N**2 FOR MF = 11 OR 12, -C 22 + 17*N + (2*ML + MU)*N FOR MF = 14 OR 15, -C 22 + 9*N + N**2 FOR MF = 21 OR 22, -C 22 + 10*N + (2*ML + MU)*N FOR MF = 24 OR 25, -C IF ISOPT = 0, OR.. -C 22 + 15*(NPAR+1)*N + N**2 + N FOR MF = 11 OR 12, -C 24 + 15*(NPAR+1)*N + (2*ML+MU+2)*N + N FOR MF = 14 OR 15, -C 22 + 8*(NPAR+1)*N + N**2 + N FOR MF = 21 OR 22, -C 24 + 8*(NPAR+1)*N + (2*ML+MU+2)*N + N FOR MF = 24 OR 25, -C IF ISOPT = 1. -C LRW = DECLARED LENGTH OF RWORK (IN USER-S DIMENSION STATEMENT). -C IWORK = INTEGER WORK ARRAY OF LENGTH AT LEAST.. -C 20 + N IF ISOPT = 0, -C 21 + N + NPAR IF ISOPT = 1. -C IF MITER = 4 OR 5, INPUT IN IWORK(1),IWORK(2) THE LOWER -C AND UPPER HALF-BANDWIDTHS ML,MU (EXCLUDING MAIN DIAGONAL). -C LIW = DECLARED LENGTH OF IWORK (IN USER-S DIMENSION STATEMENT). -C JAC = NAME OF SUBROUTINE FOR JACOBIAN MATRIX. -C IF USED, THIS NAME MUST BE DECLARED EXTERNAL IN CALLING -C PROGRAM. IF NOT USED, PASS A DUMMY NAME. -C MF = METHOD FLAG. STANDARD VALUES FOR ISOPT = 0 ARE.. -C 10 FOR NONSTIFF (ADAMS) METHOD, NO JACOBIAN USED. -C 21 FOR STIFF (BDF) METHOD, USER-SUPPLIED FULL JACOBIAN. -C 22 FOR STIFF METHOD, INTERNALLY GENERATED FULL JACOBIAN. -C 24 FOR STIFF METHOD, USER-SUPPLIED BANDED JACOBIAN. -C 25 FOR STIFF METHOD, INTERNALLY GENERATED BANDED JACOBIAN. -C IF ISOPT = 1, MF = 10 IS ILLEGAL AND CAN BE REPLACED BY.. -C 11 FOR NONSTIFF METHOD, USER-SUPPLIED FULL JACOBIAN. -C 12 FOR NONSTIFF METHOD, INTERNALLY GENERATED FULL JACOBIAN. -C 14 FOR NONSTIFF METHOD, USER-SUPPLIED BANDED JACOBIAN. -C 15 FOR NONSTIFF METHOD, INTERNALLY GENERATED BANDED JACOBIAN. -C NOTE THAT THE MAIN PROGRAM MUST DECLARE ARRAYS Y, RWORK, IWORK, AND -C POSSIBLY ATOL AND RTOL, AS WELL AS NEQ, IOPT, AND PAR IF ISOPT = 1. -C -C E. THE OUTPUT FROM THE FIRST CALL (OR ANY CALL) IS.. -C Y = ARRAY OF COMPUTED VALUES OF Y(T) VECTOR. -C T = CORRESPONDING VALUE OF INDEPENDENT VARIABLE (NORMALLY TOUT). -C ISTATE = 2 IF ODESSA WAS SUCCESSFUL, NEGATIVE OTHERWISE. -C -1 MEANS EXCESS WORK DONE ON THIS CALL (PERHAPS WRONG MF). -C -2 MEANS EXCESS ACCURACY REQUESTED (TOLERANCES TOO SMALL). -C -3 MEANS ILLEGAL INPUT DETECTED (SEE PRINTED MESSAGE). -C -4 MEANS REPEATED ERROR TEST FAILURES (CHECK ALL INPUTS). -C -5 MEANS REPEATED CONVERGENCE FAILURES (PERHAPS BAD JACOBIAN -C SUPPLIED OR WRONG CHOICE OF MF OR TOLERANCES). -C -6 MEANS ERROR WEIGHT BECAME ZERO DURING PROBLEM. (SOLUTION -C COMPONENT I,J VANISHED, AND ATOL OR ATOL(I,J) = 0.0) -C -C F. TO CONTINUE THE INTEGRATION AFTER A SUCCESSFUL RETURN, SIMPLY -C RESET TOUT AND CALL ODESSA AGAIN. NO OTHER PARAMETERS NEED BE RESET. -C---------------------------------------------------------------------- -C EXAMPLE PROBLEM. -C -C THE FOLLOWING IS A SIMPLE EXAMPLE PROBLEM, WITH THE CODING -C NEEDED FOR ITS SOLUTION BY ODESSA. THE PROBLEM IS FROM CHEMICAL -C KINETICS, AND CONSISTS OF THE FOLLOWING THREE RATE EQUATIONS.. -C DY1/DT = -PAR(1)*Y1 + PAR(2)*Y2*Y3 ; PAR(1) = .04, PAR(2) = 1.E4 -C DY2/DT = PAR(1)*Y1 - PAR(2)*Y2*Y3 - PAR(3)*Y2**2 ; PAR(3) = 3.E7 -C DY3/DT = PAR(3)*Y2**2 -C ON THE INTERVAL FROM T = 0.0 TO T = 4.E10, WITH INITIAL CONDITIONS -C Y1 = 1.0, Y2 = Y3 = 0, AND S(I,J) = 0, I = 1,3, J = 1,3. -C THE PROBLEM IS STIFF. -C -C THE FOLLOWING CODING KppSolveS THIS PROBLEM WITH ODESSA, USING -C MF = 21 AND PRINTING RESULTS AT T = .4, 4., ..., 4.E10. -C IT USES ITOL = 4 AND ATOL MUCH SMALLER FOR Y2 THAN Y1 OR Y3, -C BECAUSE Y2 HAS MUCH SMALLER VALUES. LESS STRINGENT TOLERANCES -C ARE ASSIGNED FOR THE SENSITIVITIES TO ACHIEVE GREATER EFFICIENCY. -C AT THE END OF THE RUN, STATISTICAL QUANTITIES OF INTEREST ARE -C PRINTED (SEE OPTIONAL OUTPUTS IN THE FULL DESCRIPTION BELOW). -C -C DOUBLE PRECISION ATOL, RWORK, RTOL, T, TOUT, Y, PAR -C EXTERNAL FEX, JEX, DFEX -C DIMENSION Y(3,4), PAR(3), ATOL(3,4), RTOL(3,4), RWORK(130), -C 1 IWORK(27), NEQ(2), IOPT(3) -C N = 3 -C NPAR = 3 -C NEQ(1) = N -C NEQ(2) = NPAR -C NSV = NPAR+1 -C DO 10 I = 1,N -C DO 10 J = 1,NSV -C 10 Y(I,J) = 0.0D0 -C Y(1,1) = 1.0D0 -C PAR(1) = 0.04D0 -C PAR(2) = 1.0D4 -C PAR(3) = 3.0D7 -C T = 0.D0 -C TOUT = .4D0 -C ITOL = 4 -C ATOL(1,1) = 1.D-6 -C ATOL(2,1) = 1.D-10 -C ATOL(3,1) = 1.D-6 -C DO 20 I = 1,N -C RTOL(I,1) = 1.D-4 -C DO 15 J = 2,NSV -C RTOL(I,J) = 1.D-3 -C 15 ATOL(I,J) = 1.D2 * ATOL(I,1) -C 20 CONTINUE -C ITASK = 1 -C ISTATE = 1 -C IOPT(1) = 0 -C IOPT(2) = 1 -C IOPT(3) = 1 -C LRW = 130 -C LIW = 27 -C MF = 21 -C DO 60 IOUT = 1,12 -C CALL ODESSA(FEX,DFEX,NEQ,Y,PAR,T,TOUT,ITOL,RTOL,ATOL, -C 1 ITASK,ISTATE, IOPT,RWORK,LRW,IWORK,LIW,JEX,MF) -C WRITE(6,30)T,Y(1,1),Y(2,1),Y(3,1) -C 30 FORMAT(1X,7H AT T =,E12.4,6H Y =,3E14.6) -C DO 50 J = 2,NSV -C JPAR = J-1 -C WRITE(6,40)JPAR,Y(1,J),Y(2,J),Y(3,J) -C 40 FORMAT(20X,2HS(,I1,3H) =,3E14.6) -C 50 CONTINUE -C IF (ISTATE .LT. 0) GO TO 80 -C 60 TOUT = TOUT*10.D0 -C WRITE(6,70)IWORK(11),IWORK(12),IWORK(13),IWORK(19) -C 70 FORMAT(1X,/,12H NO. STEPS =,I4,11H NO. F-S =,I4,11H NO. J-S =, -C 1 I4,12H NO. DF-S =,I4) -C STOP -C 80 WRITE(6,90)ISTATE -C 90 FORMAT(///22H ERROR HALT.. ISTATE =,I3) -C STOP -C END -C -C SUBROUTINE FEX (NEQ, T, Y, PAR, YDOT) -C DOUBLE PRECISION T, Y, YDOT, PAR -C DIMENSION Y(3), YDOT(3), PAR(3) -C YDOT(1) = -PAR(1)*Y(1) + PAR(2)*Y(2)*Y(3) -C YDOT(3) = PAR(3)*Y(2)*Y(2) -C YDOT(2) = -YDOT(1) - YDOT(3) -C RETURN -C END -C -C SUBROUTINE JEX (NEQ, T, Y, PAR, ML, MU, PD, NRPD) -C DOUBLE PRECISION PD, T, Y, PAR -C DIMENSION Y(3), PD(NRPD,3), PAR(3) -C PD(1,1) = -PAR(1) -C PD(1,2) = PAR(2)*Y(3) -C PD(1,3) = PAR(2)*Y(2) -C PD(2,1) = PAR(1) -C PD(2,3) = -PD(1,3) -C PD(3,2) = 2.D0*PAR(3)*Y(2) -C PD(2,2) = -PD(1,2) - PD(3,2) -C RETURN -C END -C -C SUBROUTINE DFEX (NEQ, T, Y, PAR, DFDP, JPAR) -C DOUBLE PRECISION T, Y, PAR, DFDP -C DIMENSION Y(3), PAR(3), DFDP(3) -C GO TO (1,2,3), JPAR -C 1 DFDP(1) = -Y(1) -C DFDP(2) = Y(1) -C RETURN -C 2 DFDP(1) = Y(2)*Y(3) -C DFDP(2) = -Y(2)*Y(3) -C RETURN -C 3 DFDP(2) = -Y(2)*Y(2) -C DFDP(3) = Y(2)*Y(2) -C RETURN -C END -C -C THE OUTPUT OF THIS PROGRAM (ON A DATA GENERAL MV-8000 IN -C DOUBLE PRECISION IS AS FOLLOWS: -C -C AT T = .4000E+00 Y = .985173E+00 .338641E-04 .147930E-01 -C S(1) = -.355914E+00 .390261E-03 .355524E+00 -C S(2) = .955150E-07 -.213065E-09 -.953019E-07 -C S(3) = -.158466E-10 -.529012E-12 .163756E-10 -C AT T = .4000E+01 Y = .905516E+00 .224044E-04 .944615E-01 -C S(1) = -.187621E+01 .179197E-03 .187603E+01 -C S(2) = .296093E-05 -.583104E-09 -.296034E-05 -C S(3) = -.493267E-09 -.276246E-12 .493544E-09 -C AT T = .4000E+02 Y = .715848E+00 .918628E-05 .284143E+00 -C S(1) = -.424730E+01 .459360E-04 .424726E+01 -C S(2) = .137294E-04 -.235815E-09 -.137291E-04 -C S(3) = -.228818E-08 -.113803E-12 .228829E-08 -C AT T = .4000E+03 Y = .450526E+00 .322299E-05 .549471E+00 -C S(1) = -.595837E+01 .354310E-05 .595836E+01 -C S(2) = .227380E-04 -.226041E-10 -.227380E-04 -C S(3) = -.378971E-08 -.499501E-13 .378976E-08 -C AT T = .4000E+04 Y = .183185E+00 .894131E-06 .816814E+00 -C S(1) = -.475006E+01 -.599504E-05 .475007E+01 -C S(2) = .188089E-04 .231330E-10 -.188089E-04 -C S(3) = -.313478E-08 -.187575E-13 .313480E-08 -C AT T = .4000E+05 Y = .389733E-01 .162133E-06 .961027E+00 -C S(1) = -.157477E+01 -.276199E-05 .157477E+01 -C S(2) = .628668E-05 .110026E-10 -.628670E-05 -C S(3) = -.104776E-08 -.453588E-14 .104776E-08 -C AT T = .4000E+06 Y = .493609E-02 .198411E-07 .995064E+00 -C S(1) = -.236244E+00 -.458262E-06 .236244E+00 -C S(2) = .944669E-06 .183193E-11 -.944671E-06 -C S(3) = -.157441E-09 -.635990E-15 .157442E-09 -C AT T = .4000E+07 Y = .516087E-03 .206540E-08 .999484E+00 -C S(1) = -.256277E-01 -.509808E-07 .256278E-01 -C S(2) = .102506E-06 .203905E-12 -.102506E-06 -C S(3) = -.170825E-10 -.684002E-16 .170826E-10 -C AT T = .4000E+08 Y = .519314E-04 .207736E-09 .999948E+00 -C S(1) = -.259316E-02 -.518029E-08 .259316E-02 -C S(2) = .103726E-07 .207209E-13 -.103726E-07 -C S(3) = -.172845E-11 -.691450E-17 .172845E-11 -C AT T = .4000E+09 Y = .544710E-05 .217885E-10 .999995E+00 -C S(1) = -.271637E-03 -.541849E-09 .271638E-03 -C S(2) = .108655E-08 .216739E-14 -.108655E-08 -C S(3) = -.180902E-12 -.723615E-18 .180902E-12 -C AT T = .4000E+10 Y = .446748E-06 .178699E-11 .100000E+01 -C S(1) = -.322322E-04 -.842541E-10 .322323E-04 -C S(2) = .128929E-09 .337016E-15 -.128929E-09 -C S(3) = -.209715E-13 -.838859E-19 .209715E-13 -C AT T = .4000E+11 Y = -.363960E-07 -.145584E-12 .100000E+01 -C S(1) = -.164109E-06 -.429604E-11 .164113E-06 -C S(2) = .656436E-12 .171842E-16 -.656451E-12 -C S(3) = -.689361E-15 -.275745E-20 .689363E-15 -C -C NO. STEPS = 340 NO. F-S = 412 NO. J-S = 343 NO. DF-S =1023 -C---------------------------------------------------------------------- -C FULL DESCRIPTION OF USER INTERFACE TO ODESSA. -C -C THE USER INTERFACE TO ODESSA CONSISTS OF THE FOLLOWING PARTS. -C -C I. THE CALL SEQUENCE TO SUBROUTINE ODESSA, WHICH IS A DRIVER -C ROUTINE FOR THE KppSolveR. THIS INCLUDES DESCRIPTIONS OF BOTH -C THE CALL SEQUENCE ARGUMENTS AND OF USER-SUPPLIED ROUTINES. -C FOLLOWING THESE DESCRIPTIONS IS A DESCRIPTION OF -C OPTIONAL INPUTS AVAILABLE THROUGH THE CALL SEQUENCE, AND THEN -C A DESCRIPTION OF OPTIONAL OUTPUTS (IN THE WORK ARRAYS). -C -C II. DESCRIPTIONS OF OTHER ROUTINES IN THE ODESSA PACKAGE THAT MAY -C BE (OPTIONALLY) CALLED BY THE USER. THESE PROVIDE THE ABILITY -C TO ALTER ERROR MESSAGE HANDLING, SAVE AND RESTORE THE INTERNAL -C COMMON, AND OBTAIN SPECIFIED DERIVATIVES OF THE SOLUTION Y(T). -C -C III. DESCRIPTIONS OF COMMON BLOCKS TO BE DECLARED IN OVERLAY -C OR SIMILAR ENVIRONMENTS, OR TO BE SAVED WHEN DOING AN INTERRUPT -C OF THE PROBLEM AND CONTINUED SOLUTION LATER. -C -C IV. DESCRIPTION OF TWO SUBROUTINES IN THE ODESSA PACKAGE, EITHER OF -C WHICH THE USER MAY REPLACE WITH HIS OWN VERSION, IF DESIRED. -C THESE RELATE TO THE MEASUREMENT OF ERRORS. -C -C V. GENERAL REMARKS WHICH HIGHLIGHT DIFFERENCES BETWEEN THE LSODE -C PACKAGE AND THE ODESSA PACKAGE. -C---------------------------------------------------------------------- -C PART I. CALL SEQUENCE. -C -C THE CALL SEQUENCE PARAMETERS USED FOR INPUT ONLY ARE.. -C F, DF, NEQ, PAR, TOUT, ITOL, RTOL, ATOL, ITASK, IOPT, LRW, LIW, -C JAC, MF, -C AND THOSE USED FOR BOTH INPUT AND OUTPUT ARE -C Y, T, ISTATE. -C THE WORK ARRAYS RWORK AND IWORK ARE ALSO USED FOR CONDITIONAL AND -C OPTIONAL INPUTS AND OPTIONAL OUTPUTS. (THE TERM OUTPUT HERE REFERS -C TO THE RETURN FROM SUBROUTINE ODESSA TO THE USER-S CALLING PROGRAM.) -C -C THE LEGALITY OF INPUT PARAMETERS WILL BE THOROUGHLY CHECKED ON THE -C INITIAL CALL FOR THE PROBLEM, BUT NOT CHECKED THEREAFTER UNLESS A -C CHANGE IN INPUT PARAMETERS IS FLAGGED BY ISTATE = 3 ON INPUT. -C -C THE DESCRIPTIONS OF THE CALL ARGUMENTS ARE AS FOLLOWS. -C -C F = THE NAME OF THE USER-SUPPLIED SUBROUTINE DEFINING THE -C ODE MODEL. THIS SYSTEM MUST BE PUT IN THE FIRST-ORDER -C FORM DY/DT = F(Y,T;P), WHERE F IS A VECTOR-VALUED FUNCTION -C OF THE SCALAR T AND VECTORS Y, AND PAR. SUBROUTINE F IS TO -C COMPUTE THE FUNCTION F. IT IS TO HAVE THE FORM.. -C SUBROUTINE F (NEQ, T, Y, PAR, YDOT) -C DOUBLE PRECISION T, Y, PAR, YDOT -C DIMENSION Y(1), PAR(1), YDOT(1) -C WHERE NEQ, T, Y, AND PAR ARE INPUT, AND YDOT = F(Y,T;P) -C IS OUTPUT. Y AND YDOT ARE ARRAYS OF LENGTH N (= NEQ(1)). -C (IN THE DIMENSION STATEMENT ABOVE, 1 IS A DUMMY -C DIMENSION.. IT CAN BE REPLACED BY ANY VALUE.) -C F SHOULD NOT ALTER ARRAY Y, OR PAR(1),...,PAR(NPAR). -C F MUST BE DECLARED EXTERNAL IN THE CALLING PROGRAM. -C -C SUBROUTINE F MAY ACCESS USER-DEFINED QUANTITIES IN -C NEQ(2),... AND PAR(NPAR+1),... IF NEQ IS AN ARRAY -C (DIMENSIONED IN F) AND PAR HAS LENGTH EXCEEDING NPAR. -C SEE THE DESCRIPTIONS OF NEQ AND PAR BELOW. -C -C DF = THE NAME OF THE USER-SUPPLIED ROUTINE (IDF = 1) TO COMPUTE -C THE INHOMOGENEITY MATRIX, DF/DP, AS A FUNCTION OF THE SCALAR -C T, AND THE VECTORS Y, AND PAR. IT IS TO HAVE THE FORM -C SUBROUTINE DF (NEQ, T, Y, PAR, DFDP, JPAR) -C DOUBLE PRECISION T, Y, PAR, DFDP -C DIMENSION Y(1), PAR(1), DFDP(1) -C GO TO (1,2,...,NPAR) JPAR -C 1 DFDP(1) = DF(1)/DP(1) -C . -C DFDP(I) = DF(I)/DP(1) -C . -C DFDP(N) = DF(N)/DP(1) -C RETURN -C 2 DFDP(1) = DF(1)/DP(2) -C . -C DFDP(I) = DF(I)/DP(2) -C . -C DFDP(N) = DF(N)/DP(2) -C . -C RETURN -C . . -C . . -C NPAR DFDP(1) = DF(1)/DP(NPAR) -C . -C DFDP(I) = DF(I)/DP(NPAR) -C . -C DFDP(N) = DF(N)/DP(NPAR) -C RETURN -C END -C WHERE NEQ, T, Y, PAR, AND JPAR ARE INPUT AND THE VECTOR -C DFDP(*,JPAR) IS TO BE LOADED WITH THE PARTIAL DERIVATIVES -C DF(Y,T;PAR)/DP(JPAR) ON OUTPUT. ONLY NONZERO ELEMENTS NEED -C BE LOADED. T, Y, AND PAR HAVE THE SAME MEANING AS IN -C SUBROUTINE F. (IN THE DIMENSION STATEMENT ABOVE, 1 IS A DUMMY -C DIMENSION.. IT CAN BE REPLACED BY ANY VALUE). -C -C DFDP(*,JPAR) IS PRESET TO ZERO BY THE KppSolveR, SO THAT ONLY -C THE NONZERO ELEMENTS NEED BE LOADED BY DF. SUBROUTINE DF -C MUST BE DECLARED EXTERNAL IN THE CALLING PROGRAM IF USED. -C IF IDF = 0 (OR ISOPT = 0), A DUMMY ARGUMENT CAN BE USED. -C -C SUBROUTINE DF MAY ACCESS USER-DEFINED QUANTITIES IN -C NEQ(2),... AND PAR(NPAR+1),... IF NEQ IS AN ARRAY -C (DIMENSIONED IN DF) AND PAR HAS A LENGTH EXCEEDING NPAR. -C SEE THE DESCRIPTIONS OF NEQ AND PAR (BELOW). -C -C NEQ = THE SIZE OF THE ODE SYSTEM (NUMBER OF FIRST ORDER ORDINARY -C DIFFERENTIAL EQUATIONS (N) IN THE MODEL). USED ONLY FOR -C INPUT. NEQ MAY NOT BE CHANGED DURING THE PROBLEM. -C -C FOR ISOPT = 0, NEQ IS NORMALLY A SCALAR. HOWEVER, NEQ MAY -C BE AN ARRAY, WITH NEQ(1) SET TO THE SYSTEM SIZE (N), IN WHICH -C CASE THE ODESSA PACKAGE ACCESSES ONLY NEQ(1). HOWEVER, -C THIS PARAMETER IS PASSED AS THE NEQ ARGUMENT IN ALL CALLS -C TO F, DF, AND JAC. HENCE, IF IT IS AN ARRAY, LOCATIONS -C NEQ(2),... MAY BE USED TO STORE OTHER INTEGER DATA AND PASS -C IT TO F, DF, AND/OR JAC. FOR ISOPT = 1, NPAR MUST BE LOADED -C INTO NEQ(2), AND IS NOT ALLOWED TO CHANGE DURING THE PROBLEM. -C IN THESE CASES, SUBROUTINES F, DF, AND/OR JAC MUST INCLUDE -C NEQ IN A DIMENSION STATEMENT. -C -C Y = A REAL ARRAY FOR THE VECTOR OF DEPENDENT VARIABLES, OF -C DIMENSION (N) BY (NPAR+1). USED FOR BOTH INPUT AND -C OUTPUT ON THE FIRST CALL (ISTATE = 1), AND ONLY FOR -C OUTPUT ON OTHER CALLS. ON THE FIRST CALL, Y MUST CONTAIN -C THE VECTORS OF INITIAL VALUES. ON OUTPUT, Y CONTAINS THE -C COMPUTED SOLUTION VECTORS, EVALUATED AT T. -C -C PAR = A REAL ARRAY FOR THE VECTOR OF CONSTANT MODEL PARAMETERS -C OF INTEREST IN THE SENSITIVITY ANALYSIS, OF LENGTH NPAR -C OR MORE. PAR IS PASSED AS AN ARGUMENT IN ALL CALLS TO F, -C DF, AND JAC. HENCE LOCATIONS PAR(NPAR+1),... MAY BE USED -C TO STORE OTHER REAL DATA AND PASS IT TO F, DF, AND/OR JAC. -C LOCATIONS PAR(1),...,PAR(NPAR) ARE USED AS INPUT ONLY, -C AND MUST NOT BE CHANGED DURING THE PROBLEM. -C -C T = THE INDEPENDENT VARIABLE. ON INPUT, T IS USED ONLY ON THE -C FIRST CALL, AS THE INITIAL POINT OF THE INTEGRATION. -C ON OUTPUT, AFTER EACH CALL, T IS THE VALUE AT WHICH A -C COMPUTED SOLUTION Y IS EVALUATED (USUALLY THE SAME AS TOUT). -C ON AN ERROR RETURN, T IS THE FARTHEST POINT REACHED. -C -C TOUT = THE NEXT VALUE OF T AT WHICH A COMPUTED SOLUTION IS DESIRED. -C USED ONLY FOR INPUT. -C -C WHEN STARTING THE PROBLEM (ISTATE = 1), TOUT MAY BE EQUAL -C TO T FOR ONE CALL, THEN SHOULD .NE. T FOR THE NEXT CALL. -C FOR THE INITIAL T, AN INPUT VALUE OF TOUT .NE. T IS USED -C IN ORDER TO DETERMINE THE DIRECTION OF THE INTEGRATION -C (I.E. THE ALGEBRAIC SIGN OF THE STEP SIZES) AND THE ROUGH -C SCALE OF THE PROBLEM. INTEGRATION IN EITHER DIRECTION -C (FORWARD OR BACKWARD IN T) IS PERMITTED. -C -C IF ITASK = 2 OR 5 (ONE-STEP MODES), TOUT IS IGNORED AFTER -C THE FIRST CALL (I.E. THE FIRST CALL WITH TOUT .NE. T). -C OTHERWISE, TOUT IS REQUIRED ON EVERY CALL. -C -C IF ITASK = 1, 3, OR 4, THE VALUES OF TOUT NEED NOT BE -C MONOTONE, BUT A VALUE OF TOUT WHICH BACKS UP IS LIMITED -C TO THE CURRENT INTERNAL T INTERVAL, WHOSE ENDPOINTS ARE -C TCUR - HU AND TCUR (SEE OPTIONAL OUTPUTS, BELOW, FOR -C TCUR AND HU). -C -C ITOL = AN INDICATOR FOR THE TYPE OF ERROR CONTROL. SEE -C DESCRIPTION BELOW UNDER ATOL. USED ONLY FOR INPUT. -C -C RTOL = A RELATIVE ERROR TOLERANCE PARAMETER, EITHER A SCALAR OR -C AN ARRAY OF SPACE (N) BY (NPAR+1). SEE DESCRIPTION BELOW -C UNDER ATOL. INPUT ONLY. -C -C ATOL = AN ABSOLUTE ERROR TOLERANCE PARAMETER, EITHER A SCALAR OR -C AN ARRAY OF SPACE (N) BY (NPAR+1). INPUT ONLY. -C -C THE INPUT PARAMETERS ITOL, RTOL, AND ATOL DETERMINE -C THE ERROR CONTROL PERFORMED BY THE KppSolveR. THE KppSolveR WILL -C CONTROL THE VECTOR E = (E(I,J)) OF ESTIMATED LOCAL ERRORS -C IN Y, ACCORDING TO AN INEQUALITY OF THE FORM -C RMS-NORM OF ( E(I,J)/EWT(I,J) ) .LE. 1, -C WHERE EWT(I,J) = RTOL(I,J)*ABS(Y(I,J)) + ATOL(I,J), -C AND THE RMS-NORM (ROOT-MEAN-SQUARE NORM) HERE IS -C RMS-NORM(V) = SQRT ( (1/N) * SUM (V(I,J)**2) ); I =1,...,N. -C HERE EWT = (EWT(I,J)) IS A VECTOR OF WEIGHTS WHICH MUST -C ALWAYS BE POSITIVE, AND THE VALUES OF RTOL AND ATOL SHOULD -C ALL BE NON-NEGATIVE. THE FOLLOWING TABLE GIVES THE TYPES -C (SCALAR/ARRAY) OF RTOL AND ATOL, AND THE CORRESPONDING FORM -C OF EWT(I,J). -C -C ITOL RTOL ATOL EWT(I,J) -C 1 SCALAR SCALAR RTOL*ABS(Y(I,J)) + ATOL -C 2 SCALAR ARRAY RTOL*ABS(Y(I,J)) + ATOL(I,J) -C 3 ARRAY SCALAR RTOL(I,J)*ABS(Y(I,J)) + ATOL -C 4 ARRAY ARRAY RTOL(I,J)*ABS(Y(I,J)) + ATOL(I,J) -C -C WHEN EITHER OF THESE PARAMETERS IS A SCALAR, IT NEED NOT -C BE DIMENSIONED IN THE USER-S CALLING PROGRAM. -C -C THE TOTAL NUMBER OF ERROR TEST FAILURES DUE TO THE SENSITIVITY -C ANALYSIS, AND WHICH REQUIRE AN INTEGRATION STEP TO BE -C REPEATED, ARE ACCUMULATED IN THE LAST NPAR+1 LOCATIONS OF THE -C INTEGER WORK ARRAY IWORK (SEE OPTIONAL OUTPUTS BELOW). -C THIS INFORMATION MAY BE OF VALUE IN DETERMINING APPROPRIATE -C ERROR TOLERANCES TO BE APPLIED TO THE SENSITIVITY FUNCTIONS. -C -C IF NONE OF THE ABOVE CHOICES (WITH ITOL, RTOL, AND ATOL -C FIXED THROUGHOUT THE PROBLEM) IS SUITABLE, MORE GENERAL -C ERROR CONTROLS CAN BE OBTAINED BY SUBSTITUTING -C USER-SUPPLIED ROUTINES FOR THE SETTING OF EWT AND/OR FOR -C THE NORM CALCULATION. SEE PART IV BELOW. -C -C IF GLOBAL ERRORS ARE TO BE ESTIMATED BY MAKING A REPEATED -C RUN ON THE SAME PROBLEM WITH SMALLER TOLERANCES, THEN ALL -C COMPONENTS OF RTOL AND ATOL (I.E. OF EWT) SHOULD BE SCALED -C DOWN UNIFORMLY. -C -C ITASK = AN INDEX SPECIFYING THE TASK TO BE PERFORMED. -C INPUT ONLY. ITASK HAS THE FOLLOWING VALUES AND MEANINGS. -C 1 MEANS NORMAL COMPUTATION OF OUTPUT VALUES OF Y(T) AT -C T = TOUT (BY OVERSHOOTING AND INTERPOLATING). -C 2 MEANS TAKE ONE STEP ONLY AND RETURN. -C 3 MEANS STOP AT THE FIRST INTERNAL MESH POINT AT OR -C BEYOND T = TOUT AND RETURN. -C 4 MEANS NORMAL COMPUTATION OF OUTPUT VALUES OF Y(T) AT -C T = TOUT BUT WITHOUT OVERSHOOTING T = TCRIT. -C TCRIT MUST BE INPUT AS RWORK(1). TCRIT MAY BE EQUAL TO -C OR BEYOND TOUT, BUT NOT BEHIND IT IN THE DIRECTION OF -C INTEGRATION. THIS OPTION IS USEFUL IF THE PROBLEM -C HAS A SINGULARITY AT OR BEYOND T = TCRIT. -C 5 MEANS TAKE ONE STEP, WITHOUT PASSING TCRIT, AND RETURN. -C TCRIT MUST BE INPUT AS RWORK(1). -C -C NOTE.. IF ITASK = 4 OR 5 AND THE KppSolveR REACHES TCRIT -C (WITHIN ROUNDOFF), IT WILL RETURN T = TCRIT (EXACTLY) TO -C INDICATE THIS (UNLESS ITASK = 4 AND TOUT COMES BEFORE TCRIT, -C IN WHICH CASE ANSWERS AT T = TOUT ARE RETURNED FIRST). -C -C ISTATE = AN INDEX USED FOR INPUT AND OUTPUT TO SPECIFY THE -C THE STATE OF THE CALCULATION. -C -C ON INPUT, THE VALUES OF ISTATE ARE AS FOLLOWS. -C 1 MEANS THIS IS THE FIRST CALL FOR THE PROBLEM -C (INITIALIZATIONS WILL BE DONE). SEE NOTE BELOW. -C 2 MEANS THIS IS NOT THE FIRST CALL, AND THE CALCULATION -C IS TO CONTINUE NORMALLY, WITH NO CHANGE IN ANY INPUT -C PARAMETERS EXCEPT POSSIBLY TOUT AND ITASK. -C (IF ITOL, RTOL, AND/OR ATOL ARE CHANGED BETWEEN CALLS -C WITH ISTATE = 2, THE NEW VALUES WILL BE USED BUT NOT -C TESTED FOR LEGALITY.) -C 3 MEANS THIS IS NOT THE FIRST CALL, AND THE -C CALCULATION IS TO CONTINUE NORMALLY, BUT WITH -C A CHANGE IN INPUT PARAMETERS OTHER THAN -C TOUT AND ITASK. CHANGES ARE ALLOWED IN -C ITOL, RTOL, ATOL, IOPT, LRW, LIW, MF, ML, MU, -C AND ANY OF THE OPTIONAL INPUTS EXCEPT H0. -C (SEE IWORK DESCRIPTION FOR ML AND MU.) -C NOTE.. A PRELIMINARY CALL WITH TOUT = T IS NOT COUNTED -C AS A FIRST CALL HERE, AS NO INITIALIZATION OR CHECKING OF -C INPUT IS DONE. (SUCH A CALL IS SOMETIMES USEFUL FOR THE -C PURPOSE OF OUTPUTTING THE INITIAL CONDITIONS.) -C THUS THE FIRST CALL FOR WHICH TOUT .NE. T REQUIRES -C ISTATE = 1 ON INPUT. -C -C ON OUTPUT, ISTATE HAS THE FOLLOWING VALUES AND MEANINGS. -C 1 MEANS NOTHING WAS DONE, AS TOUT WAS EQUAL TO T WITH -C ISTATE = 1 ON INPUT. (HOWEVER, AN INTERNAL COUNTER WAS -C SET TO DETECT AND PREVENT REPEATED CALLS OF THIS TYPE.) -C 2 MEANS THE INTEGRATION WAS PERFORMED SUCCESSFULLY. -C -1 MEANS AN EXCESSIVE AMOUNT OF WORK (MORE THAN MXSTEP -C STEPS) WAS DONE ON THIS CALL, BEFORE COMPLETING THE -C REQUESTED TASK, BUT THE INTEGRATION WAS OTHERWISE -C SUCCESSFUL AS FAR AS T. (MXSTEP IS AN OPTIONAL INPUT -C AND IS NORMALLY 500.) TO CONTINUE, THE USER MAY -C SIMPLY RESET ISTATE TO A VALUE .GT. 1 AND CALL AGAIN -C (THE EXCESS WORK STEP COUNTER WILL BE RESET TO 0). -C IN ADDITION, THE USER MAY INCREASE MXSTEP TO AVOID -C THIS ERROR RETURN (SEE BELOW ON OPTIONAL INPUTS). -C -2 MEANS TOO MUCH ACCURACY WAS REQUESTED FOR THE PRECISION -C OF THE MACHINE BEING USED. THIS WAS DETECTED BEFORE -C COMPLETING THE REQUESTED TASK, BUT THE INTEGRATION -C WAS SUCCESSFUL AS FAR AS T. TO CONTINUE, THE TOLERANCE -C PARAMETERS MUST BE RESET, AND ISTATE MUST BE SET -C TO 3. THE OPTIONAL OUTPUT TOLSF MAY BE USED FOR THIS -C PURPOSE. (NOTE.. IF THIS CONDITION IS DETECTED BEFORE -C TAKING ANY STEPS, THEN AN ILLEGAL INPUT RETURN -C (ISTATE = -3) OCCURS INSTEAD.) -C -3 MEANS ILLEGAL INPUT WAS DETECTED, BEFORE TAKING ANY -C INTEGRATION STEPS. SEE WRITTEN MESSAGE FOR DETAILS. -C NOTE.. IF THE KppSolveR DETECTS AN INFINITE LOOP OF CALLS -C TO THE KppSolveR WITH ILLEGAL INPUT, IT WILL CAUSE -C THE RUN TO STOP. -C -4 MEANS THERE WERE REPEATED ERROR TEST FAILURES ON -C ONE ATTEMPTED STEP, BEFORE COMPLETING THE REQUESTED -C TASK, BUT THE INTEGRATION WAS SUCCESSFUL AS FAR AS T. -C THE PROBLEM MAY HAVE A SINGULARITY, OR THE INPUT -C MAY BE INAPPROPRIATE. -C -5 MEANS THERE WERE REPEATED CONVERGENCE TEST FAILURES ON -C ONE ATTEMPTED STEP, BEFORE COMPLETING THE REQUESTED -C TASK, BUT THE INTEGRATION WAS SUCCESSFUL AS FAR AS T. -C THIS MAY BE CAUSED BY AN INACCURATE JACOBIAN MATRIX, -C IF ONE IS BEING USED. -C -6 MEANS EWT(I,J) BECAME ZERO FOR SOME I,J DURING THE -C INTEGRATION. PURE RELATIVE ERROR CONTROL (ATOL(I,J)=0.0) -C WAS REQUESTED ON A VARIABLE WHICH HAS NOW VANISHED. -C THE INTEGRATION WAS SUCCESSFUL AS FAR AS T. -C -C NOTE.. SINCE THE NORMAL OUTPUT VALUE OF ISTATE IS 2, -C IT DOES NOT NEED TO BE RESET FOR NORMAL CONTINUATION. -C ALSO, SINCE A NEGATIVE INPUT VALUE OF ISTATE WILL BE -C REGARDED AS ILLEGAL, A NEGATIVE OUTPUT VALUE REQUIRES THE -C USER TO CHANGE IT, AND POSSIBLY OTHER INPUTS, BEFORE -C CALLING THE KppSolveR AGAIN. -C -C IOPT = AN INTEGER ARRAY FLAG TO SPECIFY WHETHER OR NOT ANY OPTIONAL -C INPUTS ARE BEING USED ON THIS CALL. INPUT ONLY. -C THE OPTIONAL INPUTS ARE LISTED SEPARATELY BELOW. -C IOPT(1) = 0 MEANS NO OPTIONAL INPUTS FOR THE KppSolveR WILL BE -C USED. DEFAULT VALUES WILL BE USED IN ALL CASES. -C = 1 MEANS ONE OR MORE OPTIONAL INPUTS FOR THE -C KppSolveR ARE BEING USED. -C NOTE : IOPT(1) IS INDEPENDENT OF ISOPT AND IDF. -C IOPT(2) = 0 MEANS NO SENSITIVITY ANALYSIS WILL BE PERFORMED. -C = 1 MEANS A SENSITIVITY ANALYSIS WILL BE PERFORMED. -C NOTE : IOPT(2) IS RENAMED TO ISOPT IN ODESSA. -C = 0 MEANS DF/DP WILL BE CALCULATED BY FINITE -C DIFFERENCE WITHIN ODESSA. -C IOPT(3) = 1 MEANS DF/DP WILL BE CALCULATED BY A USER-SUPPLIED -C ROUTINE. -C NOTE : IOPT(3) IS RENAMED TO IDF IN ODESSA. -C IF IDF = 1, THE USER MUST SUPPLY A -C SUBROUTINE DF (THE NAME IS ARBITRARY) AS -C DESCRIBED BELOW UNDER DF. FOR IDF = 0, -C A DUMMY ARGUMENT CAN BE USED. -C -C RWORK = A REAL WORKING ARRAY (DOUBLE PRECISION). -C FOR ISOPT = 0, THE LENGTH OF RWORK MUST BE AT LEAST.. -C 20 + NYH*(MAXORD + 1) + 3*NEQ + LWM -C FOR ISOPT = 1, THE LENGTH OF RWORK MUST BE AT LEAST.. -C 20 + NYH*(MAXORD + 1) + 2*NYH + LWM + N -C WHERE.. -C NYH = THE TOTAL NUMBER OF DEPENDENT VARIABLES; -C (= N IF ISOPT = 0, AND N*(NPAR+1) IF ISOPT = 1). -C MAXORD = 12 (IF METH = 1) OR 5 (IF METH = 2) (UNLESS A -C SMALLER VALUE IS GIVEN AS AN OPTIONAL INPUT), -C LWM = 0 IF MITER = 0, -C LWM = N**2 + 2 IF MITER IS 1 OR 2, -C LWM = N + 2 IF MITER = 3, AND -C LWM = (2*ML+MU+1)*N + 2 IF MITER IS 4 OR 5. -C (SEE THE MF DESCRIPTION FOR METH AND MITER.) -C -C THE FIRST 20 WORDS OF RWORK ARE RESERVED FOR CONDITIONAL -C AND OPTIONAL INPUTS AND OPTIONAL OUTPUTS. -C -C THE FOLLOWING WORD IN RWORK IS A CONDITIONAL INPUT.. -C RWORK(1) = TCRIT = CRITICAL VALUE OF T WHICH THE KppSolveR -C IS NOT TO OVERSHOOT. REQUIRED IF ITASK IS -C 4 OR 5, AND IGNORED OTHERWISE. (SEE ITASK.) -C -C LRW = THE LENGTH OF THE ARRAY RWORK, AS DECLARED BY THE USER. -C (THIS WILL BE CHECKED BY THE KppSolveR.) -C -C IWORK = AN INTEGER WORK ARRAY. THE LENGTH MUST BE AT LEAST.. -C 20 IF MITER = 0 OR 3 (MF = 10, 13, 20, 23), OR -C 20 + N OTHERWISE (MF = 11, 12, 14, 15, 21, 22, 24, 25). -C FOR ISOPT = 0, OR.. -C 21 + N + NPAR -C FOR ISOPT = 1. -C THE FIRST FEW WORDS OF IWORK ARE USED FOR CONDITIONAL AND -C OPTIONAL INPUTS AND OPTIONAL OUTPUTS. -C -C THE FOLLOWING 2 WORDS IN IWORK ARE CONDITIONAL INPUTS.. -C IWORK(1) = ML THESE ARE THE LOWER AND UPPER -C IWORK(2) = MU HALF-BANDWIDTHS, RESPECTIVELY, OF THE -C BANDED JACOBIAN, EXCLUDING THE MAIN DIAGONAL. -C THE BAND IS DEFINED BY THE MATRIX LOCATIONS -C (I,J) WITH I-ML .LE. J .LE. I+MU. ML AND MU -C MUST SATISFY 0 .LE. ML,MU .LE. NEQ-1. -C THESE ARE REQUIRED IF MITER IS 4 OR 5, AND -C IGNORED OTHERWISE. ML AND MU MAY IN FACT BE -C THE BAND PARAMETERS FOR A MATRIX TO WHICH -C DF/DY IS ONLY APPROXIMATELY EQUAL. -* -C -C LIW = THE LENGTH OF THE ARRAY IWORK, AS DECLARED BY THE USER. -C (THIS WILL BE CHECKED BY THE KppSolveR.) -C -C NOTE.. THE WORK ARRAYS MUST NOT BE ALTERED BETWEEN CALLS TO ODESSA -C FOR THE SAME PROBLEM, EXCEPT POSSIBLY FOR THE CONDITIONAL AND -C OPTIONAL INPUTS, AND EXCEPT FOR THE LAST 2*NYH + N WORDS OF RWORK. -C THE LATTER SPACE IS USED FOR INTERNAL SCRATCH SPACE, AND SO IS -C AVAILABLE FOR USE BY THE USER OUTSIDE ODESSA BETWEEN CALLS, IF -C DESIRED (BUT NOT FOR USE BY F, DF, OR JAC). -C -C JAC = THE NAME OF THE USER-SUPPLIED ROUTINE (MITER = 1 OR 4) TO -C COMPUTE THE JACOBIAN MATRIX, DF/DY, AS A FUNCTION OF THE -C SCALAR T AND THE VECTORS Y, AND PAR. IT IS TO HAVE THE FORM -C SUBROUTINE JAC (NEQ, T, Y, PAR, ML, MU, PD, NROWPD) -C DOUBLE PRECISION T, Y, PAR, PD -C DIMENSION Y(1), PAR(1), PD(NROWPD,1) -C WHERE NEQ, T, Y, PAR, ML, MU, AND NROWPD ARE INPUT AND THE -C ARRAY PD IS TO BE LOADED WITH PARTIAL DERIVATIVES (ELEMENTS -C OF THE JACOBIAN MATRIX) ON OUTPUT. PD MUST BE GIVEN A FIRST -C DIMENSION OF NROWPD. T, Y, AND PAR HAVE THE SAME MEANING AS -C IN SUBROUTINE F. (IN THE DIMENSION STATEMENT ABOVE, 1 IS A -C DUMMY DIMENSION.. IT CAN BE REPLACED BY ANY VALUE.) -C IN THE FULL MATRIX CASE (MITER = 1), ML AND MU ARE -C IGNORED, AND THE JACOBIAN IS TO BE LOADED INTO PD IN -C COLUMNWISE MANNER, WITH DF(I)/DY(J) LOADED INTO PD(I,J). -C IN THE BAND MATRIX CASE (MITER = 4), THE ELEMENTS -C WITHIN THE BAND ARE TO BE LOADED INTO PD IN COLUMNWISE -C MANNER, WITH DIAGONAL LINES OF DF/DY LOADED INTO THE ROWS -C OF PD. THUS DF(I)/DY(J) IS TO BE LOADED INTO PD(I-J+MU+1,J). -C ML AND MU ARE THE HALF-BANDWIDTH PARAMETERS (SEE IWORK). -C THE LOCATIONS IN PD IN THE TWO TRIANGULAR AREAS WHICH -C CORRESPOND TO NONEXISTENT MATRIX ELEMENTS CAN BE IGNORED -C OR LOADED ARBITRARILY, AS THEY ARE OVERWRITTEN BY ODESSA. -C PD IS PRESET TO ZERO BY THE KppSolveR, SO THAT ONLY THE -C NONZERO ELEMENTS NEED BE LOADED BY JAC. EACH CALL TO JAC IS -C PRECEDED BY A CALL TO F WITH THE SAME ARGUMENTS NEQ, T, Y, -C AND PAR. THUS TO GAIN SOME EFFICIENCY, INTERMEDIATE -C QUANTITIES SHARED BY BOTH CALCULATIONS MAY BE SAVED IN A -C USER COMMON BLOCK BY F AND NOT RECOMPUTED BY JAC, IF -C DESIRED. ALSO, JAC MAY ALTER THE Y ARRAY, IF DESIRED. -C JAC MUST BE DECLARED EXTERNAL IN THE CALLING PROGRAM. -C SUBROUTINE JAC MAY ACCESS USER-DEFINED QUANTITIES IN -C NEQ(2),... AND PAR(NPAR+1),.... SEE THE DESCRIPTIONS OF -C NEQ (ABOVE) AND PAR (BELOW). -C -C MF = THE METHOD FLAG. USED ONLY FOR INPUT. THE LEGAL VALUES OF -C MF ARE 10, 11, 12, 13, 14, 15, 20, 21, 22, 23, 24, AND 25. -C MF HAS DECIMAL DIGITS METH AND MITER.. MF = 10*METH + MITER. -C METH INDICATES THE BASIC LINEAR MULTISTEP METHOD.. -C METH = 1 MEANS THE IMPLICIT ADAMS METHOD. -* -C METH = 2 MEANS THE METHOD BASED ON BACKWARD -C DIFFERENTIATION FORMULAS (BDF-S). -C MITER INDICATES THE CORRECTOR ITERATION METHOD.. -C MITER = 0 MEANS FUNCTIONAL ITERATION (NO JACOBIAN MATRIX -C IS INVOLVED). -C MITER = 1 MEANS CHORD ITERATION WITH A USER-SUPPLIED -C FULL (NEQ BY NEQ) JACOBIAN. -C MITER = 2 MEANS CHORD ITERATION WITH AN INTERNALLY -C GENERATED (DIFFERENCE QUOTIENT) FULL JACOBIAN -C (USING NEQ EXTRA CALLS TO F PER DF/DY VALUE). -C MITER = 3 MEANS CHORD ITERATION WITH AN INTERNALLY -C GENERATED DIAGONAL JACOBIAN APPROXIMATION. -C (USING 1 EXTRA CALL TO F PER DF/DY EVALUATION). -C MITER = 4 MEANS CHORD ITERATION WITH A USER-SUPPLIED -C BANDED JACOBIAN. -C MITER = 5 MEANS CHORD ITERATION WITH AN INTERNALLY -C GENERATED BANDED JACOBIAN (USING ML+MU+1 EXTRA -C CALLS TO F PER DF/DY EVALUATION). -C IF MITER = 1 OR 4, THE USER MUST SUPPLY A SUBROUTINE JAC -C (THE NAME IS ARBITRARY) AS DESCRIBED ABOVE UNDER JAC. -C FOR OTHER VALUES OF MITER, A DUMMY ARGUMENT CAN BE USED. -C -C IF A SENSITIVITY ANLYSIS IS DESIRED (ISOPT = 1), MITER = 0 -C AND 3 ARE DISALLOWED. IN THESE CASES, THE USER IS RECOMMENDED -C TO SUPPLY AN ANALYTICAL JACOBIAN (MITER = 1 OR 4) AND AN -C ANALYTICAL INHOMOGENEITY MATRIX (IDF = 1). -C---------------------------------------------------------------------- -C OPTIONAL INPUTS. -C -C THE FOLLOWING IS A LIST OF THE OPTIONAL INPUTS PROVIDED FOR IN THE -C CALL SEQUENCE. (SEE ALSO PART II.) FOR EACH SUCH INPUT VARIABLE, -C THIS TABLE LISTS ITS NAME AS USED IN THIS DOCUMENTATION, ITS -C LOCATION IN THE CALL SEQUENCE, ITS MEANING, AND THE DEFAULT VALUE. -C THE USE OF ANY OF THESE INPUTS REQUIRES IOPT(1) = 1, AND IN THAT -C CASE ALL OF THESE INPUTS ARE EXAMINED. A VALUE OF ZERO FOR ANY -C OF THESE OPTIONAL INPUTS WILL CAUSE THE DEFAULT VALUE TO BE USED. -C THUS TO USE A SUBSET OF THE OPTIONAL INPUTS, SIMPLY PRELOAD -C LOCATIONS 5 TO 10 IN RWORK AND IWORK TO 0.0 AND 0 RESPECTIVELY, AND -C THEN SET THOSE OF INTEREST TO NONZERO VALUES. -C -C NAME LOCATION MEANING AND DEFAULT VALUE -C -C H0 RWORK(5) THE STEP SIZE TO BE ATTEMPTED ON THE FIRST STEP. -C THE DEFAULT VALUE IS DETERMINED BY THE KppSolveR. -C -C HMAX RWORK(6) THE MAXIMUM ABSOLUTE STEP SIZE ALLOWED. -C THE DEFAULT VALUE IS INFINITE. -C -C HMIN RWORK(7) THE MINIMUM ABSOLUTE STEP SIZE ALLOWED. -C THE DEFAULT VALUE IS 0. (THIS LOWER BOUND IS NOT -C ENFORCED ON THE FINAL STEP BEFORE REACHING TCRIT -C WHEN ITASK = 4 OR 5.) -C -C MAXORD IWORK(5) THE MAXIMUM ORDER TO BE ALLOWED. THE DEFAULT -C VALUE IS 12 IF METH = 1, AND 5 IF METH = 2. -C IF MAXORD EXCEEDS THE DEFAULT VALUE, IT WILL -C BE REDUCED TO THE DEFAULT VALUE. -C IF MAXORD IS CHANGED DURING THE PROBLEM, IT MAY -C CAUSE THE CURRENT ORDER TO BE REDUCED. -C -C MXSTEP IWORK(6) MAXIMUM NUMBER OF (INTERNALLY DEFINED) STEPS -C ALLOWED DURING ONE CALL TO THE KppSolveR. -C THE DEFAULT VALUE IS 500. -C -C MXHNIL IWORK(7) MAXIMUM NUMBER OF MESSAGES PRINTED (PER PROBLEM) -C WARNING THAT T + H = T ON A STEP (H = STEP SIZE). -C THIS MUST BE POSITIVE TO RESULT IN A NON-DEFAULT -C VALUE. THE DEFAULT VALUE IS 10. -C---------------------------------------------------------------------- -C OPTIONAL OUTPUTS. -C -C AS OPTIONAL ADDITIONAL OUTPUT FROM ODESSA, THE VARIABLES LISTED -C BELOW ARE QUANTITIES RELATED TO THE PERFORMANCE OF ODESSA -C WHICH ARE AVAILABLE TO THE USER. THESE ARE COMMUNICATED BY WAY OF -C THE WORK ARRAYS, BUT ALSO HAVE INTERNAL MNEMONIC NAMES AS SHOWN. -C EXCEPT WHERE STATED OTHERWISE, ALL OF THESE OUTPUTS ARE DEFINED -C ON ANY SUCCESSFUL RETURN FROM ODESSA, AND ON ANY RETURN WITH -C ISTATE = -1, -2, -4, -5, OR -6. ON AN ILLEGAL INPUT RETURN -C (ISTATE = -3), THEY WILL BE UNCHANGED FROM THEIR EXISTING VALUES -C (IF ANY), EXCEPT POSSIBLY FOR TOLSF, LENRW, AND LENIW. -C ON ANY ERROR RETURN, OUTPUTS RELEVANT TO THE ERROR WILL BE DEFINED, -C AS NOTED BELOW. -C -C NAME LOCATION MEANING -C -C HU RWORK(11) THE STEP SIZE IN T LAST USED (SUCCESSFULLY). -C -C HCUR RWORK(12) THE STEP SIZE TO BE ATTEMPTED ON THE NEXT STEP. -C -C TCUR RWORK(13) THE CURRENT VALUE OF THE INDEPENDENT VARIABLE -C WHICH THE KppSolveR HAS ACTUALLY REACHED, I.E. THE -C CURRENT INTERNAL MESH POINT IN T. ON OUTPUT, TCUR -C WILL ALWAYS BE AT LEAST AS FAR AS THE ARGUMENT -C T, BUT MAY BE FARTHER (IF INTERPOLATION WAS DONE). -C -C TOLSF RWORK(14) A TOLERANCE SCALE FACTOR, GREATER THAN 1.0, -C COMPUTED WHEN A REQUEST FOR TOO MUCH ACCURACY WAS -C DETECTED (ISTATE = -3 IF DETECTED AT THE START OF -C THE PROBLEM, ISTATE = -2 OTHERWISE). IF ITOL IS -C LEFT UNALTERED BUT RTOL AND ATOL ARE UNIFORMLY -C SCALED UP BY A FACTOR OF TOLSF FOR THE NEXT CALL, -C THEN THE KppSolveR IS DEEMED LIKELY TO SUCCEED. -C (THE USER MAY ALSO IGNORE TOLSF AND ALTER THE -C TOLERANCE PARAMETERS IN ANY OTHER WAY APPROPRIATE.) -C -C NST IWORK(11) THE NUMBER OF STEPS TAKEN FOR THE PROBLEM SO FAR. -C -C NFE IWORK(12) THE NUMBER OF F EVALUATIONS FOR THE PROBLEM SO FAR. -C -C NJE IWORK(13) THE NUMBER OF JACOBIAN EVALUATIONS (AND OF MATRIX -C LU DECOMPOSITIONS IF ISOPT = 0) FOR THE PROBLEM SO -C FAR. IF ISOPT = 1, THE NUMBER OF LU DECOMPOSITIONS -C IS EQUAL TO NJE - NSPE (SEE BELOW). -C -C NQU IWORK(14) THE METHOD ORDER LAST USED (SUCCESSFULLY). -C -C NQCUR IWORK(15) THE ORDER TO BE ATTEMPTED ON THE NEXT STEP. -C -C IMXER IWORK(16) THE INDEX OF THE COMPONENT OF LARGEST MAGNITUDE IN -C THE WEIGHTED LOCAL ERROR VECTOR (E(I,J)/EWT(I,J)), -C ON AN ERROR RETURN WITH ISTATE = -4 OR -5. -C -C LENRW IWORK(17) THE LENGTH OF RWORK ACTUALLY REQUIRED. -C THIS IS DEFINED ON NORMAL RETURNS AND ON AN ILLEGAL -C INPUT RETURN FOR INSUFFICIENT STORAGE. -C -C LENIW IWORK(18) THE LENGTH OF IWORK ACTUALLY REQUIRED. -C THIS IS DEFINED ON NORMAL RETURNS AND ON AN ILLEGAL -C INPUT RETURN FOR INSUFFICIENT STORAGE. -C -C NDFE IWORK(19) THE NUMBER OF DF/DP (VECTOR) EVALUATIONS. -C -C NSPE IWORK(20) THE NUMBER OF CALLS TO SUBROUTINE SPRIME. EACH CALL -C TO SPRIME REQUIRES A JACOBIAN EVALUATION, BUT NOT -C AN LU DECOMPOSITION. -C -C THE FOLLOWING ARRAYS ARE SEGMENTS OF THE RWORK AND IWORK ARRAYS -C WHICH MAY ALSO BE OF INTEREST TO THE USER AS OPTIONAL OUTPUTS. -C FOR EACH ARRAY, THE TABLE BELOW GIVES ITS INTERNAL NAME, ITS BASE -C ADDRESS IN RWORK OR IWORK, AND ITS DESCRIPTION. -C -C NAME BASE ADDRESS DESCRIPTION -C -C YH 21 IN RWORK THE NORDSIECK HISTORY ARRAY, OF SIZE NYH BY -C (NQCUR + 1). FOR J = 0,1,...,NQCUR, COLUMN J+1 -C OF YH CONTAINS HCUR**J/FACTORIAL(J) TIMES -C THE J-TH DERIVATIVE OF THE INTERPOLATING -C POLYNOMIAL CURRENTLY REPRESENTING THE SOLUTION, -C EVALUATED AT T = TCUR. -C -C ACOR LENRW-NYH+1 ARRAY OF SIZE NYH USED FOR THE ACCUMULATED -C IN RWORK CORRECTIONS ON EACH STEP, SCALED ON OUTPUT -C TO REPRESENT THE ESTIMATED LOCAL ERROR IN Y -C ON THE LAST STEP. THIS IS THE VECTOR E IN -C THE DESCRIPTION OF THE ERROR CONTROL. -C IT IS DEFINED ONLY ON A SUCCESSFUL RETURN -C FROM ODESSA. -C NRS LENIW-NPAR ARRAY OF SIZE NPAR+1, USED TO STORE THE -C IN IWORK ACCUMULATED NUMBER OF REPEATED STEPS DUE TO -C THE SENSITIVITY ANALYSIS.. -C NRS(1) = TOTAL NUMBER OF REPEATED STEPS, -C NRS(2),... = NUMBER OF REPEATED STEPS DUE TO -C MODEL PARAMETER 1,... -C -C---------------------------------------------------------------------- -C PART II. OTHER ROUTINES CALLABLE. -C -C THE FOLLOWING ARE OPTIONAL CALLS WHICH THE USER MAY MAKE TO -C GAIN ADDITIONAL CAPABILITIES IN CONJUNCTION WITH ODESSA. -C (THE ROUTINES XSETUN AND XSETF ARE DESIGNED TO CONFORM TO THE -C SLATEC ERROR HANDLING PACKAGE.) -C -C FORM OF CALL FUNCTION -C CALL XSETUN(LUN) SET THE LOGICAL UNIT NUMBER, LUN, FOR -C OUTPUT OF MESSAGES FROM ODESSA, IF -C THE DEFAULT IS NOT DESIRED. -C THE DEFAULT VALUE OF LUN IS 6. -C -C CALL XSETF(MFLAG) SET A FLAG TO CONTROL THE PRINTING OF -C MESSAGES BY ODESSA.. -C MFLAG = 0 MEANS DO NOT PRINT. (DANGER.. -C THIS RISKS LOSING VALUABLE INFORMATION.) -C MFLAG = 1 MEANS PRINT (THE DEFAULT). -C -C EITHER OF THE ABOVE CALLS MAY BE MADE AT -C ANY TIME AND WILL TAKE EFFECT IMMEDIATELY. -C -C CALL SVCOM (RSAV, ISAV) STORE IN RSAV AND ISAV THE CONTENTS -C OF THE INTERNAL COMMON BLOCKS USED BY -C ODESSA (SEE PART III BELOW). -C RSAV MUST BE A REAL ARRAY OF LENGTH 222 -C OR MORE, AND ISAV MUST BE AN INTEGER -C ARRAY OF LENGTH 54 OR MORE. -C -C CALL RSCOM (RSAV, ISAV) RESTORE, FROM RSAV AND ISAV, THE CONTENTS -C OF THE INTERNAL COMMON BLOCKS USED BY -C ODESSA. PRESUMES A PRIOR CALL TO SVCOM -C WITH THE SAME ARGUMENTS. -C -C SVCOM AND RSCOM ARE USEFUL IF -C INTERRUPTING A RUN AND RESTARTING -C LATER, OR ALTERNATING BETWEEN TWO OR -C MORE PROBLEMS KppSolveD WITH ODESSA. -C -C CALL INTDY(,,,,,) PROVIDE DERIVATIVES OF Y, OF VARIOUS -C (SEE BELOW) ORDERS, AT A SPECIFIED POINT T, IF -C DESIRED. IT MAY BE CALLED ONLY AFTER -C A SUCCESSFUL RETURN FROM ODESSA. -C -C THE DETAILED INSTRUCTIONS FOR USING INTDY ARE AS FOLLOWS. -C THE FORM OF THE CALL IS.. -C -C CALL INTDY (T, K, RWORK(21), NYH, DKY, IFLAG) -C -C THE INPUT PARAMETERS ARE.. -C -C T = VALUE OF INDEPENDENT VARIABLE WHERE ANSWERS ARE DESIRED -C (NORMALLY THE SAME AS THE T LAST RETURNED BY ODESSA). -C FOR VALID RESULTS, T MUST LIE BETWEEN TCUR - HU AND TCUR. -C (SEE OPTIONAL OUTPUTS FOR TCUR AND HU.) -C K = INTEGER ORDER OF THE DERIVATIVE DESIRED. K MUST SATISFY -C 0 .LE. K .LE. NQCUR, WHERE NQCUR IS THE CURRENT ORDER -C (SEE OPTIONAL OUTPUTS). THE CAPABILITY CORRESPONDING -C TO K = 0, I.E. COMPUTING Y(T), IS ALREADY PROVIDED -C BY ODESSA DIRECTLY. SINCE NQCUR .GE. 1, THE FIRST -C DERIVATIVE DY/DT IS ALWAYS AVAILABLE WITH INTDY. -C RWORK(21) = THE BASE ADDRESS OF THE HISTORY ARRAY YH. -C NYH = COLUMN LENGTH OF YH, EQUAL TO THE TOTAL NUMBER OF -C DEPENDENT VARIABLES. IF ISOPT = 0, NYH = N. IF ISOPT = 1, -C NYH = N * (NPAR + 1). -C -C THE OUTPUT PARAMETERS ARE.. -C -C DKY = A REAL ARRAY OF LENGTH NYH CONTAINING THE COMPUTED VALUE -C OF THE K-TH DERIVATIVE OF Y(T). -C IFLAG = INTEGER FLAG, RETURNED AS 0 IF K AND T WERE LEGAL, -C -1 IF K WAS ILLEGAL, AND -2 IF T WAS ILLEGAL. -C ON AN ERROR RETURN, A MESSAGE IS ALSO WRITTEN. -C---------------------------------------------------------------------- -C PART III. COMMON BLOCKS. -C -C IF ODESSA IS TO BE USED IN AN OVERLAY SITUATION, THE USER -C MUST DECLARE, IN THE PRIMARY OVERLAY, THE VARIABLES IN.. -C (1) THE CALL SEQUENCE TO ODESSA, -C (2) THE THREE INTERNAL COMMON BLOCKS -C /ODE001/ OF LENGTH 258 (219 DOUBLE PRECISION WORDS -C FOLLOWED BY 39 INTEGER WORDS), -C /ODE002/ OF LENGTH 14 (3 DOUBLE PRECISION WORDS FOLLOWED -C BY 11 INTEGER WORDS), -C /EH0001/ OF LENGTH 2 (INTEGER WORDS). -C -C IF ODESSA IS USED ON A SYSTEM IN WHICH THE CONTENTS OF INTERNAL -C COMMON BLOCKS ARE NOT PRESERVED BETWEEN CALLS, THE USER SHOULD -C DECLARE THE ABOVE THREE COMMON BLOCKS IN HIS MAIN PROGRAM TO INSURE -C THAT THEIR CONTENTS ARE PRESERVED. -C -C IF THE SOLUTION OF A GIVEN PROBLEM BY ODESSA IS TO BE INTERRUPTED -C AND THEN LATER CONTINUED, SUCH AS WHEN RESTARTING AN INTERRUPTED RUN -C OR ALTERNATING BETWEEN TWO OR MORE PROBLEMS, THE USER SHOULD SAVE, -C FOLLOWING THE RETURN FROM THE LAST ODESSA CALL PRIOR TO THE -C INTERRUPTION, THE CONTENTS OF THE CALL SEQUENCE VARIABLES AND THE -C INTERNAL COMMON BLOCKS, AND LATER RESTORE THESE VALUES BEFORE THE -C NEXT ODESSA CALL FOR THAT PROBLEM. TO SAVE AND RESTORE THE COMMON -C BLOCKS, USE SUBROUTINES SVCOM AND RSCOM (SEE PART II ABOVE). -C -C---------------------------------------------------------------------- -C PART IV. OPTIONALLY REPLACEABLE KppSolveR ROUTINES. -C -C BELOW ARE DESCRIPTIONS OF TWO ROUTINES IN THE ODESSA PACKAGE WHICH -C RELATE TO THE MEASUREMENT OF ERRORS. EITHER ROUTINE CAN BE -C REPLACED BY A USER-SUPPLIED VERSION, IF DESIRED. HOWEVER, SINCE SUCH -C A REPLACEMENT MAY HAVE A MAJOR IMPACT ON PERFORMANCE, IT SHOULD BE -C DONE ONLY WHEN ABSOLUTELY NECESSARY, AND ONLY WITH GREAT CAUTION. -C (NOTE.. THE MEANS BY WHICH THE PACKAGE VERSION OF A ROUTINE IS -C SUPERSEDED BY THE USER-S VERSION MAY BE SYSTEM-DEPENDENT.) -C -C (A) EWSET. -C THE FOLLOWING SUBROUTINE IS CALLED JUST BEFORE EACH INTERNAL -C INTEGRATION STEP, AND SETS THE ARRAY OF ERROR WEIGHTS, EWT, AS -C DESCRIBED UNDER ITOL/RTOL/ATOL ABOVE.. -C SUBROUTINE EWSET (NYH, ITOL, RTOL, ATOL, YCUR, EWT) -C WHERE NEQ, ITOL, RTOL, AND ATOL ARE AS IN THE ODESSA CALL SEQUENCE, -C YCUR CONTAINS THE CURRENT DEPENDENT VARIABLE VECTOR, AND -C EWT IS THE ARRAY OF WEIGHTS SET BY EWSET. -C -C IF THE USER SUPPLIES THIS SUBROUTINE, IT MUST RETURN IN EWT(I) -C (I = 1,...,NYH) A POSITIVE QUANTITY SUITABLE FOR COMPARING ERRORS -C IN Y(I) TO. THE EWT ARRAY RETURNED BY EWSET IS PASSED TO THE -C VNORM ROUTINE (SEE BELOW), AND ALSO USED BY ODESSA IN THE COMPUTATION -C OF THE OPTIONAL OUTPUT IMXER, THE DIAGONAL JACOBIAN APPROXIMATION, -C AND THE INCREMENTS FOR DIFFERENCE QUOTIENT JACOBIANS. -C -C IN THE USER-SUPPLIED VERSION OF EWSET, IT MAY BE DESIRABLE TO USE -C THE CURRENT VALUES OF DERIVATIVES OF Y. DERIVATIVES UP TO ORDER NQ -C ARE AVAILABLE FROM THE HISTORY ARRAY YH, DESCRIBED ABOVE UNDER -C OPTIONAL OUTPUTS. IN EWSET, YH IS IDENTICAL TO THE YCUR ARRAY, -C EXTENDED TO NQ + 1 COLUMNS WITH A COLUMN LENGTH OF NYH AND SCALE -C FACTORS OF H**J/FACTORIAL(J). ON THE FIRST CALL FOR THE PROBLEM, -C GIVEN BY NST = 0, NQ IS 1 AND H IS TEMPORARILY SET TO 1.0. -C THE QUANTITIES NQ, NYH, H, AND NST CAN BE OBTAINED BY INCLUDING -C IN EWSET THE STATEMENTS.. -C DOUBLE PRECISION H, RLS -C COMMON /ODE001/ RLS(219),ILS(39) -C NQ = ILS(35) -C NYH = ILS(14) -C NST = ILS(36) -C H = RLS(213) -C THUS, FOR EXAMPLE, THE CURRENT VALUE OF DY/DT CAN BE OBTAINED AS -C YCUR(NYH+I)/H (I=1,...,N) (AND THE DIVISION BY H IS -C UNNECESSARY WHEN NST = 0). -C -C (B) VNORM. -C THE FOLLOWING IS A REAL FUNCTION ROUTINE WHICH COMPUTES THE WEIGHTED -C ROOT-MEAN-SQUARE NORM OF A VECTOR V.. -C D = VNORM (LV, V, W) -C WHERE.. -C LV = THE LENGTH OF THE VECTOR, -C V = REAL ARRAY OF LENGTH N CONTAINING THE VECTOR, -C W = REAL ARRAY OF LENGTH N CONTAINING WEIGHTS, -C D = SQRT( (1/N) * SUM(V(I)*W(I))**2 ). -C VNORM IS CALLED WITH LV = N AND WITH W(I) = 1.0/EWT(I), WHERE -C EWT IS AS SET BY SUBROUTINE EWSET. -C -C IF THE USER SUPPLIES THIS FUNCTION, IT SHOULD RETURN A NON-NEGATIVE -C VALUE OF VNORM SUITABLE FOR USE IN THE ERROR CONTROL IN ODESSA. -C NONE OF THE ARGUMENTS SHOULD BE ALTERED BY VNORM. -C FOR EXAMPLE, A USER-SUPPLIED VNORM ROUTINE MIGHT.. -C -SUBSTITUTE A MAX-NORM OF (V(I)*W(I)) FOR THE RMS-NORM, OR -C -IGNORE SOME COMPONENTS OF V IN THE NORM, WITH THE EFFECT OF -C SUPPRESSING THE ERROR CONTROL ON THOSE COMPONENTS OF Y. -C---------------------------------------------------------------------- -C OTHER ROUTINES IN THE ODESSA PACKAGE. -C -C IN ADDITION TO SUBROUTINE ODESSA, THE ODESSA PACKAGE INCLUDES THE -C FOLLOWING SUBROUTINES AND FUNCTION ROUTINES.. -C INTDY COMPUTES AN INTERPOLATED VALUE OF THE Y VECTOR AT T = TOUT. -C STODE IS THE CORE INTEGRATOR, WHICH DOES ONE STEP OF THE -C INTEGRATION AND THE ASSOCIATED ERROR CONTROL. -C STESA MANAGES THE SOLUTION OF THE SENSITIVITY FUNCTIONS. -C CFODE SETS ALL METHOD COEFFICIENTS AND TEST CONSTANTS. -C PREPJ COMPUTES AND PREPROCESSES THE JACOBIAN MATRIX J = DF/DY -C AND THE NEWTON ITERATION MATRIX P = I - H*L0*J. -C IT IS ALSO CALLED BY SPRIME (WITH JOPT = 1) TO JUST -C COMPUTE THE JACOBIAN MATRIX. -C PREPDF COMPUTES THE INHOMOGENEITY MATRIX DF/DP. -C SPRIME DEFINES THE SYSTEM OF SENSITIVITY EQUATIONS. -C SOLSY MANAGES SOLUTION OF LINEAR SYSTEM IN CHORD ITERATION. -C EWSET SETS THE ERROR WEIGHT VECTOR EWT BEFORE EACH STEP. -C VNORM COMPUTES THE WEIGHTED R.M.S. NORM OF A VECTOR. -C SVCOM AND RSCOM ARE USER-CALLABLE ROUTINES TO SAVE AND RESTORE, -C RESPECTIVELY, THE CONTENTS OF THE INTERNAL COMMON BLOCKS. -C DGEFA AND DGESL ARE ROUTINES FROM LINPACK FOR SOLVING FULL -C SYSTEMS OF LINEAR ALGEBRAIC EQUATIONS. -C DGBFA AND DGBSL ARE ROUTINES FROM LINPACK FOR SOLVING BANDED -C LINEAR SYSTEMS. -C DAXPY, DSCAL, IDAMAX, AND DDOT ARE BASIC LINEAR ALGEBRA MODULES -C (BLAS) USED BY THE ABOVE LINPACK ROUTINES. -C D1MACH COMPUTES THE UNIT ROUNDOFF IN A MACHINE-INDEPENDENT MANNER. -C XERR, XSETUN, AND XSETF HANDLE THE PRINTING OF ALL ERROR -C MESSAGES AND WARNINGS. -C NOTE.. VNORM, IDAMAX, DDOT, AND D1MACH ARE FUNCTION ROUTINES. -C ALL THE OTHERS ARE SUBROUTINES. -C -C THE FORTRAN GENERIC INTRINSIC FUNCTIONS USED BY ODESSA ARE.. -C ABS, MAX, MIN, REAL, MOD, SIGN, SQRT, AND WRITE -C -C A BLOCK DATA SUBPROGRAM IS ALSO INCLUDED WITH THE PACKAGE, -C FOR LOADING SOME OF THE VARIABLES IN INTERNAL COMMON. -C -C---------------------------------------------------------------------- -C PART V. GENERAL REMARKS -C -C THIS SECTION HIGHLIGHTS THE BASIC DIFFERENCES BETWEEN THE ORIGINAL -C LSODE PACKAGE AND THE ODESSA MODIFICATION. THIS IS PROVIDED AS A -C SERVICE TO EXPERIENCED LSODE USERS TO EXPEDITE FAMILIARIZATION WITH -C ODESSA. -C -C (A). ORIGINAL SUBROUTINES AND FUNCTIONS. -C -C OF THE ORIGINAL 22 SUBROUTINES AND FUNCTIONS USED IN THE LSODE -C PACKAGE, ALL ARE USED BY ODESSA, WITH THE FOLLOWING HAVING BEEN -C MODIFIED.. -C -C LSODE THE ORIGINAL DRIVER SUBROUTINE FOR THE LSODE PACKAGE IS -C EXTENSIVELY MODIFIED AND RENAMED ODESSA, WHICH NOW -C CONTAINS A CALL TO SPRIME TO ESTABLISH INITIAL CONDITIONS -C FOR THE SENSITIVITY CALCULATIONS. -C -C STODE THE ONE STEP INTEGRATOR IS SLIGHTLY MODIFIED AND RETAINS -C ITS ORIGINAL NAME. IT NOW CONTAINS THE CALL TO STESA, -C AND ALSO CALLS SPRIME IF KFLAG .LE. -3. -C -C PREPJ ALSO NAMED PREPJ IN ODESSA IS SLIGHTLY MODIFIED TO ALLOW -C FOR THE CALCULATION OF JACOBIAN WITH NO PREPROCESSING -C (JOPT = 1). -C -C (B). NEW SUBROUTINES. -C -C IN ADDITION TO THE CHANGES NOTED ABOVE, THREE NEW SUBROUTINES -C HAVE BEEN INTRODUCED (SEE STESA, SPRIME, AND PREPDF AS DESCRIBED -C IN PART IV. ABOVE). -C -C (C). COMMON BLOCKS. -C -C /LS0001/ RETAINS THE SAME LENGTH AND IS RENAMED /ODE001/; -C HOWEVER THE REAL ARRAY ROWNS(209) IS SHORTENED TO A -C LENGTH OF (173) REAL WORDS, ALLOWING THE REMOVAL OF -C TESCO(3,12) WHICH IS NOW PASSED FROM STODE TO STESA. -C IN ADDITION, THE INTEGER ARRAY IOWNS(6) IS SHORTENED -C TO A LENGTH OF (4) INTEGER WORDS, ALLOWING THE REMOVAL -C OF IALTH AND LMAX WHICH ARE NOW PASSED FROM STODE TO -C STESA. -C -C /ODE002/ ADDED COMMON BLOCK FOR VARIABLES IMPORTANT TO -C SENSITIVITY ANALYSIS (SEE PART III. ABOVE). A BLOCK -C DATA PROGRAM IS NOT REQUIRED FOR THIS COMMON BLOCK. -C -C SVCOM,RSCOM THESE TWO SUBROUTINES ARE MODIFIED TO HANDLE -C COMMON BLOCK /ODE002/ AS WELL. -C -C (D). OPTIONAL INPUTS. -C -C THE FULL SET OF OPTIONAL INPUTS AVAILABLE IN LSODE IS ALSO -C AVAILABLE IN ODESSA, WITH THE EXCEPTION THAT THE NUMBER OF ODE'S -C IN THE MODEL (NEQ(1)), MAY NOT BE CHANGED DURING THE PROBLEM. -C IN ODESSA, NYH NOW REFERS TO THE TOTAL NUMBER OF FIRST-ORDER -C ODE'S (MODEL AND SENSITIVITY EQUATIONS) WHICH IS EQUAL TO -C NEQ(1) IF ISOPT = 0, OR NEQ(1)*(NEQ(2)+1) IF ISOPT = 1. -C NEQ(1), NEQ(2), AND NYH ARE NOT ALLOWED TO CHANGE DURING -C THE COURSE OF AN INTEGRATION. -C -C (E). OPTIONAL OUTPUTS. -C -C THE FULL SET OF OPTIONAL OUTPUTS AVAILABLE IN LSODE IS ALSO -C AVAILABLE IN ODESSA. IN ADDITION, IWORK(19) AND IWORK(20) ARE -C LOADED WITH NDFE AND NSPE, RESPECTIVELY, UPON OUTPUT. THE TOTAL -C NUMBER OF LU DECOMPOSITIONS OF THE PROCESSED JACOBIAN IS EQUAL -C TO NJE - NSPE. -C----------------------------------------------------------------------- - SUBROUTINE KPP_ODESSA (F, DF, NEQ, Y, PAR, T, TOUT, - 1 ITOL, RTOL, ATOL, - 1 ITASK, ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, MF) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - LOGICAL IHIT - EXTERNAL F, DF, JAC, PREPJ, SOLSY, PREPDF - DIMENSION NEQ(*), Y(*), PAR(*), RTOL(*), ATOL(*), IOPT(*), - 1 RWORK(LRW), IWORK(LIW), MORD(2) -C----------------------------------------------------------------------- -C THIS IS THE SEPTEMBER 1, 1986 VERSION OF ODESSA.. -C AN ORDINARY DIFFERENTIAL EQUATION KppSolveR WITH EXPLICIT SIMULTANEOUS -C SENSITIVITY ANALYSIS. -C -C THIS PACKAGE IS A MODIFICATION OF THE AUGUST 13, 1981 VERSION OF -C LSODE.. LIVERMORE KppSolveR FOR ORDINARY DIFFERENTIAL EQUATIONS. -C THIS VERSION IS IN DOUBLE PRECISION. -C -C ODESSA KppSolveS FOR THE FIRST-ORDER SENSITIVITY COEFFICIENTS.. -C DY(I)/DP, FOR A SINGLE PARAMETER, OR, -C DY(I)/DP(J), FOR MULTIPLE PARAMETERS, -C ASSOCIATED WITH A SYSTEM OF ORDINARY DIFFERENTIAL EQUATIONS.. -C DY(T)/DT = F(Y,T;P). -C----------------------------------------------------------------------- -C REFERENCES... -C -C 1. JORGE R. LEIS AND MARK A. KRAMER, THE SIMULTANEOUS SOLUTION AND -C EXPLICIT SENSITIVITY ANALYSIS OF SYSTEMS DESCRIBED BY ORDINARY -C DIFFERENTIAL EQUATIONS, SUBMITTED TO ACM TRANS. MATH. SOFTWARE, -C (1985). -C -C 2. JORGE R. LEIS AND MARK A. KRAMER, ODESSA - AN ORDINARY -C DIFFERENTIAL EQUATION KppSolveR WITH EXPLICIT SIMULTANEOUS -C SENSITIVITY ANALYSIS, SUBMITTED TO ACM TRANS. MATH. SOFTWARE. -C (1985). -C -C 3. ALAN C. HINDMARSH, LSODE AND LSODI, TWO NEW INITIAL VALUE -C ORDINARY DIFFERENTIAL EQUATION KppSolveRS, ACM-SIGNUM NEWSLETTER, -C VOL. 15, NO. 4 (1980), PP. 10-11. -C----------------------------------------------------------------------- -C THE FOLLOWING INTERNAL COMMON BLOCKS CONTAIN -C (A) VARIABLES WHICH ARE LOCAL TO ANY SUBROUTINE BUT WHOSE VALUES MUST -C BE PRESERVED BETWEEN CALLS TO THE ROUTINE (OWN VARIABLES), AND -C (B) VARIABLES WHICH ARE COMMUNICATED BETWEEN SUBROUTINES. -C THE STRUCTURE OF THE BLOCKS ARE AS FOLLOWS.. ALL REAL VARIABLES ARE -C LISTED FIRST, FOLLOWED BY ALL INTEGERS. WITHIN EACH TYPE, THE -C VARIABLES ARE GROUPED WITH THOSE LOCAL TO SUBROUTINE ODESSA FIRST, -C THEN THOSE LOCAL TO SUBROUTINE STODE, AND FINALLY THOSE USED -C FOR COMMUNICATION. THE BLOCKS ARE DECLARED IN SUBROUTINES ODESSA -C INTDY, STODE, STESA, PREPJ, PREPDF, AND SOLSY. GROUPS OF VARIABLES -C ARE REPLACED BY DUMMY ARRAYS IN THE COMMON DECLARATIONS IN ROUTINES -C WHERE THOSE VARIABLES ARE NOT USED. -C----------------------------------------------------------------------- - COMMON /ODE001/ TRET, ROWNS(173), - 1 TESCO(3,12), CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, - 2 ILLIN, INIT, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, - 3 MXSTEP, MXHNIL, NHNIL, NTREP, NSLAST, NYH, IOWNS(4), - 4 IALTH, LMAX, ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, METH, - 5 MITER, MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU - COMMON /ODE002/ DUPS, DSMS, DDNS, - 1 NPAR, LDFDP, LNRS, - 2 ISOPT, NSV, NDFE, NSPE, IDF, IERSP, JOPT, KFLAGS - PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,FOUR=4.0D0) - DATA MORD(1),MORD(2)/12,5/, MXSTP0/500/, MXHNL0/10/ -C----------------------------------------------------------------------- -C BLOCK A. -C THIS CODE BLOCK IS EXECUTED ON EVERY CALL. -C IT TESTS ISTATE AND ITASK FOR LEGALITY AND BRANCHES APPROPIATELY. -C IF ISTATE .GT. 1 BUT THE FLAG INIT SHOWS THAT INITIALIZATION HAS -C NOT YET BEEN DONE, AN ERROR RETURN OCCURS. -C IF ISTATE = 1 AND TOUT = T, JUMP TO BLOCK G AND RETURN IMMEDIATELY. -C----------------------------------------------------------------------- - IF (ISTATE .LT. 1 .OR. ISTATE .GT. 3) GO TO 601 - IF (ITASK .LT. 1 .OR. ITASK .GT. 5) GO TO 602 - IF (ISTATE .EQ. 1) GO TO 10 - IF (INIT .EQ. 0) GO TO 603 - IF (ISTATE .EQ. 2) GO TO 200 - GO TO 20 - 10 INIT = 0 - IF (TOUT .EQ. T) GO TO 430 - 20 NTREP = 0 -C----------------------------------------------------------------------- -C BLOCK B. -C THE NEXT CODE BLOCK IS EXECUTED FOR THE INITIAL CALL (ISTATE = 1), -C OR FOR A CONTINUATION CALL WITH PARAMETER CHANGES (ISTATE = 3). -C IT CONTAINS CHECKING OF ALL INPUTS AND VARIOUS INITIALIZATIONS. -C -C FIRST CHECK LEGALITY OF THE NON-OPTIONAL INPUTS NEQ, ITOL, IOPT, -C MF, ML, AND MU. -C----------------------------------------------------------------------- - IF (NEQ(1) .LE. 0) GO TO 604 - IF (ISTATE .EQ. 1) GO TO 25 - IF (NEQ(1) .NE. N) GO TO 605 - 25 N = NEQ(1) - IF (ITOL .LT. 1 .OR. ITOL .GT. 4) GO TO 606 - DO 26 I = 1,3 - 26 IF (IOPT(I) .LT. 0 .OR. IOPT(I) .GT. 1) GO TO 607 - ISOPT = IOPT(2) - IDF = IOPT(3) - NYH = N - NSV = 1 - METH = MF/10 - MITER = MF - 10*METH - IF (METH .LT. 1 .OR. METH .GT. 2) GO TO 608 - IF (MITER .LT. 0 .OR. MITER .GT. 5) GO TO 608 - IF (MITER .LE. 3) GO TO 30 - ML = IWORK(1) - MU = IWORK(2) - IF (ML .LT. 0 .OR. ML .GE. N) GO TO 609 - IF (MU .LT. 0 .OR. MU .GE. N) GO TO 610 - 30 IF (ISOPT .EQ. 0) GO TO 32 -C CHECK LEGALITY OF THE NON-OPTIONAL INPUTS ISOPT, NPAR. -C COMPUTE NUMBER OF SOLUTION VECTORS AND TOTAL NUMBER OF EQUATIONS. - IF (NEQ(2) .LE. 0) GO TO 628 - IF (ISTATE .EQ. 1) GO TO 31 - IF (NEQ(2) .NE. NPAR) GO TO 629 - 31 NPAR = NEQ(2) - NSV = NPAR + 1 - NYH = NSV * N - IF (MITER .EQ. 0 .OR. MITER .EQ. 3) GO TO 630 -C NEXT PROCESS AND CHECK THE OPTIONAL INPUTS. -------------------------- - 32 IF (IOPT(1) .EQ. 1) GO TO 40 - MAXORD = MORD(METH) - MXSTEP = MXSTP0 - MXHNIL = MXHNL0 - IF (ISTATE .EQ. 1) H0 = ZERO - HMXI = ZERO - HMIN = ZERO - GO TO 60 - 40 MAXORD = IWORK(5) - IF (MAXORD .LT. 0) GO TO 611 - IF (MAXORD .EQ. 0) MAXORD = 100 - MAXORD = MIN(MAXORD,MORD(METH)) - MXSTEP = IWORK(6) - IF (MXSTEP .LT. 0) GO TO 612 - IF (MXSTEP .EQ. 0) MXSTEP = MXSTP0 - MXHNIL = IWORK(7) - IF (MXHNIL .LT. 0) GO TO 613 - IF (MXHNIL .EQ. 0) MXHNIL = MXHNL0 - IF (ISTATE .NE. 1) GO TO 50 - H0 = RWORK(5) - IF ((TOUT - T)*H0 .LT. ZERO) GO TO 614 - 50 HMAX = RWORK(6) - IF (HMAX .LT. ZERO) GO TO 615 - HMXI = ZERO - IF (HMAX .GT. ZERO) HMXI = ONE/HMAX - HMIN = RWORK(7) - IF (HMIN .LT. ZERO) GO TO 616 -C----------------------------------------------------------------------- -C SET WORK ARRAY POINTERS AND CHECK LENGTHS LRW AND LIW. -C POINTERS TO SEGMENTS OF RWORK AND IWORK ARE NAMED BY PREFIXING L TO -C THE NAME OF THE SEGMENT. E.G., THE SEGMENT YH STARTS AT RWORK(LYH). -C SEGMENTS OF RWORK (IN ORDER) ARE DENOTED YH, WM, EWT, SAVF, ACOR. -C WORK SPACE FOR DFDP IS CONTAINED IN ACOR. -C----------------------------------------------------------------------- - 60 LYH = 21 - LWM = LYH + (MAXORD + 1)*NYH - IF (MITER .EQ. 0) LENWM = 0 - IF (MITER .EQ. 1 .OR. MITER .EQ. 2) LENWM = N*N + 2 - IF (MITER .EQ. 3) LENWM = N + 2 - IF (MITER .GE. 4) LENWM = (2*ML + MU + 1)*N + 2 - LEWT = LWM + LENWM - LSAVF = LEWT + NYH - LACOR = LSAVF + N - LDFDP = LACOR + N - LENRW = LACOR + NYH - 1 - IWORK(17) = LENRW - LIWM = 1 - LENIW = 20 + N - IF (MITER .EQ. 0 .OR. MITER .EQ. 3) LENIW = 20 - LNRS = LENIW + LIWM - IF (ISOPT .EQ. 1) LENIW = LNRS + NPAR - IWORK(18) = LENIW - IF (LENRW .GT. LRW) GO TO 617 - IF (LENIW .GT. LIW) GO TO 618 -C CHECK RTOL AND ATOL FOR LEGALITY. ------------------------------------ - RTOLI = RTOL(1) - ATOLI = ATOL(1) - DO 70 I = 1,NYH - IF (ITOL .GE. 3) RTOLI = RTOL(I) - IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) - IF (RTOLI .LT. ZERO) GO TO 619 - IF (ATOLI .LT. ZERO) GO TO 620 - 70 CONTINUE - IF (ISTATE .EQ. 1) GO TO 100 -C IF ISTATE = 3, SET FLAG TO SIGNAL PARAMETER CHANGES TO STODE. -------- - JSTART = -1 - IF (NQ .LE. MAXORD) GO TO 90 -C MAXORD WAS REDUCED BELOW NQ. COPY YH(*,MAXORD+2) INTO SAVF. --------- - DO 80 I = 1,N - 80 RWORK(I+LSAVF-1) = RWORK(I+LWM-1) -C RELOAD WM(1) = RWORK(LWM), SINCE LWM MAY HAVE CHANGED. --------------- - 90 IF (MITER .GT. 0) RWORK(LWM) = SQRT(UROUND) - GO TO 200 -C----------------------------------------------------------------------- -C BLOCK C. -C THE NEXT BLOCK IS FOR THE INITIAL CALL ONLY (ISTATE = 1). -C IT CONTAINS ALL REMAINING INITIALIZATIONS, THE INITIAL CALL TO F, -C THE INITIAL CALL TO SPRIME IF ISOPT = 1, -C AND THE CALCULATION OF THE INITIAL STEP SIZE. -C THE ERROR WEIGHTS IN EWT ARE INVERTED AFTER BEING LOADED. -C----------------------------------------------------------------------- - 100 UROUND = D1MACH(4) - TN = T - IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 105 - TCRIT = RWORK(1) - IF ((TCRIT - TOUT)*(TOUT - T) .LT. ZERO) GO TO 625 - IF (H0 .NE. ZERO .AND. (T + H0 - TCRIT)*H0 .GT. ZERO) - 1 H0 = TCRIT - T - 105 JSTART = 0 - IF (MITER .GT. 0) RWORK(LWM) = SQRT(UROUND) - NHNIL = 0 - NST = 0 - NJE = 0 - NSLAST = 0 - HU = ZERO - NQU = 0 - CCMAX = 0.3D0 - MAXCOR = 3 - IF (ISOPT .EQ. 1) MAXCOR = 4 - MSBP = 20 - MXNCF = 10 -C INITIAL CALL TO F. (LF0 POINTS TO YH(1,2) AND LOADS IN VALUES). - LF0 = LYH + NYH - CALL F (NEQ, T, Y, PAR, RWORK(LF0)) - NFE = 1 - DUPS = ZERO - DSMS = ZERO - DDNS = ZERO - NDFE = 0 - NSPE = 0 - IF (ISOPT .EQ. 0) GO TO 114 -C INITIALIZE COUNTS FOR REPEATED STEPS DUE TO SENSITIVITY ANALYSIS. - DO 110 J = 1,NSV - 110 IWORK(J + LNRS - 1) = 0 -C LOAD THE INITIAL VALUE VECTOR IN YH. --------------------------------- - 114 DO 115 I = 1,NYH - 115 RWORK(I+LYH-1) = Y(I) -C LOAD AND INVERT THE EWT ARRAY. (H IS TEMPORARILY SET TO ONE.) ------- - NQ = 1 - H = ONE - CALL EWSET (NYH, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) - DO 120 I = 1,NYH - IF (RWORK(I+LEWT-1) .LE. ZERO) GO TO 621 - 120 RWORK(I+LEWT-1) = ONE/RWORK(I+LEWT-1) - IF (ISOPT .EQ. 0) GO TO 125 -C CALL SPRIME TO LOAD FIRST-ORDER SENSITIVITY DERIVATIVES INTO -C REMAINING YH(*,2) POSITIONS. - CALL SPRIME (NEQ, Y, RWORK(LYH), NYH, N, NSV, RWORK(LWM), - 1 IWORK(LIWM), RWORK(LEWT), RWORK(LF0), RWORK(LACOR), - 2 RWORK(LDFDP), PAR, F, JAC, DF, PREPJ, PREPDF) - IF (IERSP .EQ. -1) GO TO 631 - IF (IERSP .EQ. -2) GO TO 632 -C----------------------------------------------------------------------- -C THE CODING BELOW COMPUTES THE STEP SIZE, H0, TO BE ATTEMPTED ON THE -C FIRST STEP, UNLESS THE USER HAS SUPPLIED A VALUE FOR THIS. -C FIRST CHECK THAT TOUT - T DIFFERS SIGNIFICANTLY FROM ZERO. -C A SCALAR TOLERANCE QUANTITY TOL IS COMPUTED, AS MAX(RTOL(I)) -C IF THIS IS POSITIVE, OR MAX(ATOL(I)/ABS(Y(I))) OTHERWISE, ADJUSTED -C SO AS TO BE BETWEEN 100*UROUND AND 1.0E-3. ONLY THE ORIGINAL -C SOLUTION VECTOR IS CONSIDERED IN THIS CALCULATION (ISOPT = 0 OR 1). -C THEN THE COMPUTED VALUE H0 IS GIVEN BY.. -C NEQ -C H0**2 = TOL / ( W0**-2 + (1/NEQ) * SUM ( F(I)/YWT(I) )**2 ) -C 1 -C WHERE W0 = MAX ( ABS(T), ABS(TOUT) ), -C F(I) = I-TH COMPONENT OF INITIAL VALUE OF F, -C YWT(I) = EWT(I)/TOL (A WEIGHT FOR Y(I)). -C THE SIGN OF H0 IS INFERRED FROM THE INITIAL VALUES OF TOUT AND T. -C----------------------------------------------------------------------- - 125 IF (H0 .NE. ZERO) GO TO 180 - TDIST = ABS(TOUT - T) - W0 = MAX(ABS(T),ABS(TOUT)) - IF (TDIST .LT. TWO*UROUND*W0) GO TO 622 - TOL = RTOL(1) - IF (ITOL .LE. 2) GO TO 140 - DO 130 I = 1,N - 130 TOL = MAX(TOL,RTOL(I)) - 140 IF (TOL .GT. ZERO) GO TO 160 - ATOLI = ATOL(1) - DO 150 I = 1,N - IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) - AYI = ABS(Y(I)) - IF (AYI .NE. ZERO) TOL = MAX(TOL,ATOLI/AYI) - 150 CONTINUE - 160 TOL = MAX(TOL,100.0D0*UROUND) - TOL = MIN(TOL,0.001D0) - SUM = VNORM (N, RWORK(LF0), RWORK(LEWT)) - SUM = ONE/(TOL*W0*W0) + TOL*SUM**2 - H0 = ONE/SQRT(SUM) - H0 = MIN(H0,TDIST) - H0 = SIGN(H0,TOUT-T) -C ADJUST H0 IF NECESSARY TO MEET HMAX BOUND. --------------------------- - 180 RH = ABS(H0)*HMXI - IF (RH .GT. ONE) H0 = H0/RH -C LOAD H WITH H0 AND SCALE YH(*,2) BY H0. ------------------------------ - H = H0 - DO 190 I = 1,NYH - 190 RWORK(I+LF0-1) = H0*RWORK(I+LF0-1) - GO TO 270 -C----------------------------------------------------------------------- -C BLOCK D. -C THE NEXT CODE BLOCK IS FOR CONTINUATION CALLS ONLY (ISTATE = 2 OR 3) -C AND IS TO CHECK STOP CONDITIONS BEFORE TAKING A STEP. -C----------------------------------------------------------------------- - 200 NSLAST = NST - GO TO (210, 250, 220, 230, 240), ITASK - 210 IF ((TN - TOUT)*H .LT. ZERO) GO TO 250 - CALL INTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) - IF (IFLAG .NE. 0) GO TO 627 - T = TOUT - GO TO 420 - 220 TP = TN - HU*(ONE + 100.0D0*UROUND) - IF ((TP - TOUT)*H .GT. ZERO) GO TO 623 - IF ((TN - TOUT)*H .LT. ZERO) GO TO 250 - GO TO 400 - 230 TCRIT = RWORK(1) - IF ((TN - TCRIT)*H .GT. ZERO) GO TO 624 - IF ((TCRIT - TOUT)*H .LT. ZERO) GO TO 625 - IF ((TN - TOUT)*H .LT. ZERO) GO TO 245 - CALL INTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) - IF (IFLAG .NE. 0) GO TO 627 - T = TOUT - GO TO 420 - 240 TCRIT = RWORK(1) - IF ((TN - TCRIT)*H .GT. ZERO) GO TO 624 - 245 HMX = ABS(TN) + ABS(H) - IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX - IF (IHIT) GO TO 400 - TNEXT = TN + H*(ONE + FOUR*UROUND) - IF ((TNEXT - TCRIT)*H .LE. ZERO) GO TO 250 - H = (TCRIT - TN)*(ONE - FOUR*UROUND) - IF (ISTATE .EQ. 2) JSTART = -2 -C----------------------------------------------------------------------- -C BLOCK E. -C THE NEXT BLOCK IS NORMALLY EXECUTED FOR ALL CALLS AND CONTAINS -C THE CALL TO THE ONE-STEP CORE INTEGRATOR STODE. -C -C THIS IS A LOOPING POINT FOR THE INTEGRATION STEPS. -C -C FIRST CHECK FOR TOO MANY STEPS BEING TAKEN, UPDATE EWT (IF NOT AT -C START OF PROBLEM), CHECK FOR TOO MUCH ACCURACY BEING REQUESTED, AND -C CHECK FOR H BELOW THE ROUNDOFF LEVEL IN T. -C TOLSF IS CALCULATED CONSIDERING ALL SOLUTION VECTORS. -C----------------------------------------------------------------------- - 250 CONTINUE - IF ((NST-NSLAST) .GE. MXSTEP) GO TO 500 - CALL EWSET (NYH, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) - DO 260 I = 1,NYH - IF (RWORK(I+LEWT-1) .LE. ZERO) GO TO 510 - 260 RWORK(I+LEWT-1) = ONE/RWORK(I+LEWT-1) - 270 TOLSF = UROUND*VNORM (NYH, RWORK(LYH), RWORK(LEWT)) - IF (TOLSF .LE. ONE) GO TO 280 - TOLSF = TOLSF*2.0D0 - IF (NST .EQ. 0) GO TO 626 - GO TO 520 - 280 IF (ADDX(TN,H) .NE. TN) GO TO 290 - NHNIL = NHNIL + 1 - IF (NHNIL .GT. MXHNIL) GO TO 290 - CALL XERR ('ODESSA - WARNING..INTERNAL T (=R1) AND H (=R2) ARE', - 1 101, 1, 0, 0, 0, 0, ZERO, ZERO) - CALL XERR ('SUCH THAT IN THE MACHINE, T + H = T ON THE NEXT STEP', - 1 101, 1, 0, 0, 0, 0, ZERO, ZERO) - CALL XERR ('(H = STEP SIZE). KppSolveR WILL CONTINUE ANYWAY', - 1 101, 1, 0, 0, 0, 2, TN, H) - IF (NHNIL .LT. MXHNIL) GO TO 290 - CALL XERR ('ODESSA - ABOVE WARNING HAS BEEN ISSUED I1 TIMES.', - 1 102, 1, 0, 0, 0, 0, ZERO, ZERO) - CALL XERR ('IT WILL NOT BE ISSUED AGAIN FOR THIS PROBLEM', - 1 102, 1, 1, MXHNIL, 0, 0, ZERO,ZERO) - 290 CONTINUE -C----------------------------------------------------------------------- -C CALL STODE(NEQ,Y,YH,NYH,YH,WM,IWM,EWT,SAVF,ACOR,PAR,NRS, -C 1 F,JAC,DF,PREPJ,PREPDF,SOLSY) -C----------------------------------------------------------------------- - CALL STODE (NEQ, Y, RWORK(LYH), NYH, RWORK(LYH), RWORK(LWM), - 1 IWORK(LIWM), RWORK(LEWT), RWORK(LSAVF), RWORK(LACOR), - 2 PAR, IWORK(LNRS), F, JAC, DF, PREPJ, PREPDF, SOLSY) - KGO = 1 - KFLAG - GO TO (300, 530, 540, 633), KGO -C----------------------------------------------------------------------- -C BLOCK F. -C THE FOLLOWING BLOCK HANDLES THE CASE OF A SUCCESSFUL RETURN FROM THE -C CORE INTEGRATOR (KFLAG = 0). TEST FOR STOP CONDITIONS. -C----------------------------------------------------------------------- - 300 INIT = 1 - GO TO (310, 400, 330, 340, 350), ITASK -C ITASK = 1. IF TOUT HAS BEEN REACHED, INTERPOLATE. ------------------- - 310 IF ((TN - TOUT)*H .LT. ZERO) GO TO 250 - CALL INTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) - T = TOUT - GO TO 420 -C ITASK = 3. JUMP TO EXIT IF TOUT WAS REACHED. ------------------------ - 330 IF ((TN - TOUT)*H .GE. ZERO) GO TO 400 - GO TO 250 -C ITASK = 4. SEE IF TOUT OR TCRIT WAS REACHED. ADJUST H IF NECESSARY. - 340 IF ((TN - TOUT)*H .LT. ZERO) GO TO 345 - CALL INTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) - T = TOUT - GO TO 420 - 345 HMX = ABS(TN) + ABS(H) - IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX - IF (IHIT) GO TO 400 - TNEXT = TN + H*(ONE + FOUR*UROUND) - IF ((TNEXT - TCRIT)*H .LE. ZERO) GO TO 250 - H = (TCRIT - TN)*(ONE - FOUR*UROUND) - JSTART = -2 - GO TO 250 -C ITASK = 5. SEE IF TCRIT WAS REACHED AND JUMP TO EXIT. --------------- - 350 HMX = ABS(TN) + ABS(H) - IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX -C----------------------------------------------------------------------- -C BLOCK G. -C THE FOLLOWING BLOCK HANDLES ALL SUCCESSFUL RETURNS FROM ODESSA. -C IF ITASK .NE. 1, Y IS LOADED FROM YH AND T IS SET ACCORDINGLY. -C ISTATE IS SET TO 2, THE ILLEGAL INPUT COUNTER IS ZEROED, AND THE -C OPTIONAL OUTPUTS ARE LOADED INTO THE WORK ARRAYS BEFORE RETURNING. -C IF ISTATE = 1 AND TOUT = T, THERE IS A RETURN WITH NO ACTION TAKEN, -C EXCEPT THAT IF THIS HAS HAPPENED REPEATEDLY, THE RUN IS TERMINATED. -C----------------------------------------------------------------------- - 400 DO 410 I = 1,NYH - 410 Y(I) = RWORK(I+LYH-1) - T = TN - IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 420 - IF (IHIT) T = TCRIT - 420 ISTATE = 2 - ILLIN = 0 - RWORK(11) = HU - RWORK(12) = H - RWORK(13) = TN - IWORK(11) = NST - IWORK(12) = NFE - IWORK(13) = NJE - IWORK(14) = NQU - IWORK(15) = NQ - IF (ISOPT .EQ. 0) RETURN - IWORK(19) = NDFE - IWORK(20) = NSPE - RETURN - 430 NTREP = NTREP + 1 - IF (NTREP .LT. 5) RETURN - CALL XERR ('ODESSA -- REPEATED CALLS WITH ISTATE = 1 AND - 1TOUT = T (=R1)', 301, 1, 0, 0, 0, 1, T, ZERO) - GO TO 800 -C----------------------------------------------------------------------- -C BLOCK H. -C THE FOLLOWING BLOCK HANDLES ALL UNSUCCESSFUL RETURNS OTHER THAN -C THOSE FOR ILLEGAL INPUT. FIRST THE ERROR MESSAGE ROUTINE IS CALLED. -C IF THERE WAS AN ERROR TEST OR CONVERGENCE TEST FAILURE, IMXER IS SET. -C THEN Y IS LOADED FROM YH, T IS SET TO TN, AND THE ILLEGAL INPUT -C COUNTER ILLIN IS SET TO 0. THE OPTIONAL OUTPUTS ARE LOADED INTO -C THE WORK ARRAYS BEFORE RETURNING. -C----------------------------------------------------------------------- -C THE MAXIMUM NUMBER OF STEPS WAS TAKEN BEFORE REACHING TOUT. ---------- - 500 CALL XERR ('ODESSA - AT CURRENT T (=R1), MXSTEP (=I1) STEPS', - 1 201, 1, 0, 0, 0, 0, ZERO,ZERO) - CALL XERR ('TAKEN ON THIS CALL BEFORE REACHING TOUT', - 1 201, 1, 1, MXSTEP, 0, 1, TN, ZERO) - ISTATE = -1 - GO TO 580 -C EWT(I) .LE. 0.0 FOR SOME I (NOT AT START OF PROBLEM). ---------------- - 510 EWTI = RWORK(LEWT+I-1) - CALL XERR ('ODESSA - AT T (=R1), EWT(I1) HAS BECOME R2 .LE. 0.', - 1 202, 1, 1, I, 0, 2, TN, EWTI) - ISTATE = -6 - GO TO 580 -C TOO MUCH ACCURACY REQUESTED FOR MACHINE PRECISION. ------------------- - 520 CALL XERR ('ODESSA - AT T (=R1), TOO MUCH ACCURACY REQUESTED', - 1 203, 1, 0, 0, 0, 0, ZERO,ZERO) - CALL XERR ('FOR PRECISION OF MACHINE.. SEE TOLSF (=R2)', - 1 203, 1, 0, 0, 0, 2, TN, TOLSF) - RWORK(14) = TOLSF - ISTATE = -2 - GO TO 580 -C KFLAG = -1. ERROR TEST FAILED REPEATEDLY OR WITH ABS(H) = HMIN. ----- - 530 CALL XERR ('ODESSA - AT T(=R1) AND STEP SIZE H(=R2), THE ERROR', - 1 204, 1, 0, 0, 0, 0, ZERO, ZERO) - CALL XERR ('TEST FAILED REPEATEDLY OR WITH ABS(H) = HMIN', - 1 204, 1, 0, 0, 0, 2, TN, H) - ISTATE = -4 - GO TO 560 -C KFLAG = -2. CONVERGENCE FAILED REPEATEDLY OR WITH ABS(H) = HMIN. ---- - 540 CALL XERR ('ODESSA - AT T (=R1) AND STEP SIZE H (=R2), THE', - 1 205, 1, 0, 0, 0, 0, ZERO,ZERO) - CALL XERR ('CORRECTOR CONVERGENCE FAILED REPEATEDLY', - 1 205, 1, 0, 0, 0, 0, ZERO,ZERO) - CALL XERR ('OR WITH ABS(H) = HMIN', - 1 205, 1, 0, 0, 0, 2, TN, H) - ISTATE = -5 -C COMPUTE IMXER IF RELEVANT. ------------------------------------------- - 560 BIG = ZERO - IMXER = 1 - DO 570 I = 1,NYH - SIZE = ABS(RWORK(I+LACOR-1)*RWORK(I+LEWT-1)) - IF (BIG .GE. SIZE) GO TO 570 - BIG = SIZE - IMXER = I - 570 CONTINUE - IWORK(16) = IMXER -C SET Y VECTOR, T, ILLIN, AND OPTIONAL OUTPUTS. ------------------------ - 580 DO 590 I = 1,NYH - 590 Y(I) = RWORK(I+LYH-1) - T = TN - ILLIN = 0 - RWORK(11) = HU - RWORK(12) = H - RWORK(13) = TN - IWORK(11) = NST - IWORK(12) = NFE - IWORK(13) = NJE - IWORK(14) = NQU - IWORK(15) = NQ - IF (ISOPT .EQ. 0) RETURN - IWORK(19) = NDFE - IWORK(20) = NSPE - RETURN -C----------------------------------------------------------------------- -C BLOCK I. -C THE FOLLOWING BLOCK HANDLES ALL ERROR RETURNS DUE TO ILLEGAL INPUT -C (ISTATE = -3), AS DETECTED BEFORE CALLING THE CORE INTEGRATOR. -C FIRST THE ERROR MESSAGE ROUTINE IS CALLED. THEN IF THERE HAVE BEEN -C 5 CONSECUTIVE SUCH RETURNS JUST BEFORE THIS CALL TO THE KppSolveR, -C THE RUN IS HALTED. -C----------------------------------------------------------------------- - 601 CALL XERR ('ODESSA - ISTATE (=I1) ILLEGAL', - 1 1, 1, 1, ISTATE, 0, 0, ZERO,ZERO) - GO TO 700 - 602 CALL XERR ('ODESSA - ITASK (=I1) ILLEGAL', - 1 2, 1, 1, ITASK, 0, 0, ZERO,ZERO) - GO TO 700 - 603 CALL XERR ('ODESSA - ISTATE .GT. 1 BUT ODESSA NOT INITIALIZED', - 1 3, 1, 0, 0, 0, 0, ZERO,ZERO) - GO TO 700 - 604 CALL XERR ('ODESSA - NEQ (=I1) .LT. 1', - 1 4, 1, 1, NEQ(1), 0, 0, ZERO,ZERO) - GO TO 700 - 605 CALL XERR ('ODESSA - ISTATE = 3 AND NEQ CHANGED. (I1 TO I2)', - 1 5, 1, 2, N, NEQ(1), 0, ZERO,ZERO) - GO TO 700 - 606 CALL XERR ('ODESSA - ITOL (=I1) ILLEGAL', - 1 6, 1, 1, ITOL, 0, 0, ZERO,ZERO) - GO TO 700 - 607 CALL XERR ('ODESSA - IOPT (=I1) ILLEGAL', - 1 7, 1, 1, IOPT, 0, 0, ZERO,ZERO) - GO TO 700 - 608 CALL XERR('ODESSA - MF (=I1) ILLEGAL', - 1 8, 1, 1, MF, 0, 0, ZERO,ZERO) - GO TO 700 - 609 CALL XERR('ODESSA - ML (=I1) ILLEGAL.. .LT.0 OR .GE.NEQ (=I2)', - 1 9, 1, 2, ML, NEQ(1), 0, ZERO,ZERO) - GO TO 700 - 610 CALL XERR('ODESSA - MU (=I1) ILLEGAL.. .LT.0 OR .GE.NEQ (=I2)', - 1 10, 1, 2, MU, NEQ(1), 0, ZERO,ZERO) - GO TO 700 - 611 CALL XERR('ODESSA - MAXORD (=I1) .LT. 0', - 1 11, 1, 1, MAXORD, 0, 0, ZERO,ZERO) - GO TO 700 - 612 CALL XERR('ODESSA - MXSTEP (=I1) .LT. 0', - 1 12, 1, 1, MXSTEP, 0, 0, ZERO,ZERO) - GO TO 700 - 613 CALL XERR('ODESSA - MXHNIL (=I1) .LT. 0', - 1 13, 1, 1, MXHNIL, 0, 0, ZERO,ZERO) - GO TO 700 - 614 CALL XERR('ODESSA - TOUT (=R1) BEHIND T (=R2)', - 1 14, 1, 0, 0, 0, 2, TOUT, T) - CALL XERR('INTEGRATION DIRECTION IS GIVEN BY H0 (=R1)', - 1 14, 1, 0, 0, 0, 1, H0, ZERO) - GO TO 700 - 615 CALL XERR('ODESSA - HMAX (=R1) .LT. 0.0', - 1 15, 1, 0, 0, 0, 1, HMAX, ZERO) - GO TO 700 - 616 CALL XERR('ODESSA - HMIN (=R1) .LT. 0.0', - 1 16, 1, 0, 0, 0, 1, HMIN, ZERO) - GO TO 700 - 617 CALL XERR('ODESSA - RWORK LENGTH NEEDED, LENRW (=I1), EXCEEDS - 1 LRW (=I2)', 17, 1, 2, LENRW, LRW, 0, ZERO,ZERO) - GO TO 700 - 618 CALL XERR('ODESSA - IWORK LENGTH NEEDED, LENIW (=I1), EXCEEDS - 1 LIW (=I2)', 18, 1, 2, LENIW, LIW, 0, ZERO,ZERO) - GO TO 700 - 619 CALL XERR('ODESSA - RTOL(I1) IS R1 .LT. 0.0', - 1 19, 1, 1, I, 0, 1, RTOLI, ZREO) - GO TO 700 - 620 CALL XERR('ODESSA - ATOL(I1) IS R1 .LT. 0.0', - 1 20, 1, 1, I, 0, 1, ATOLI, ZERO) - GO TO 700 -* - 621 EWTI = RWORK(LEWT+I-1) - CALL XERR('ODESSA - EWT(I1) IS R1 .LE. 0.0', - 1 21, 1, 1, I, 0, 1, EWTI, ZERO) - GO TO 700 - 622 CALL XERR('ODESSA - TOUT (=R1) TOO CLOSE TO T(=R2) TO START - 1 INTEGRATION', 22, 1, 0, 0, 0, 2, TOUT, T) - GO TO 700 - 623 CALL XERR('ODESSA - ITASK = I1 AND TOUT (=R1) BEHIND TCUR - HU - 1 (= R2)', 23, 1, 1, ITASK, 0, 2, TOUT, TP) - GO TO 700 - 624 CALL XERR('ODESSA - ITASK = 4 OR 5 AND TCRIT (=R1) BEHIND TCUR - 1 (=R2)', 24, 1, 0, 0, 0, 2, TCRIT, TN) - GO TO 700 - 625 CALL XERR('ODESSA - ITASK = 4 OR 5 AND TCRIT (=R1) BEHIND TOUT - 1 (=R2)', 25, 1, 0, 0, 0, 2, TCRIT, TOUT) - GO TO 700 - 626 CALL XERR('ODESSA - AT START OF PROBLEM, TOO MUCH ACCURACY', - 1 26, 1, 0, 0, 0, 0, ZERO,ZERO) - CALL XERR('REQUESTED FOR PRECISION OF MACHINE. SEE TOLSF (=R1)', - 1 26, 1, 0, 0, 0, 1, TOLSF, ZERO) - RWORK(14) = TOLSF - GO TO 700 - 627 CALL XERR('ODESSA - TROUBLE FROM INTDY. ITASK = I1, TOUT = R1', - 1 27, 1, 1, ITASK, 0, 1, TOUT, ZERO) - GO TO 700 -C ERROR STATEMENTS ASSOCIATED WITH SENSITIVITY ANALYSIS. - 628 CALL XERR('ODESSA - NPAR (=I1) .LT. 1', - 1 28, 1, 1, NPAR, 0, 0, ZERO,ZERO) - GO TO 700 - 629 CALL XERR('ODESSA - ISTATE = 3 AND NPAR CHANGED (I1 TO I2)', - 1 29, 1, 2, NP, NPAR, 0, ZERO,ZERO) - GO TO 700 - 630 CALL XERR('ODESSA - MITER (=I1) ILLEGAL', - 1 30, 1, 1, MITER, 0, 0, ZERO,ZERO) - GO TO 700 - 631 CALL XERR('ODESSA - TROUBLE IN SPRIME (IERPJ)', - 1 31, 1, 0, 0, 0, 0, ZERO,ZERO) - GO TO 700 - 632 CALL XERR('ODESSA - TROUBLE IN SPRIME (MITER)', - 1 32, 1, 0, 0, 0, 0, ZERO,ZERO) - GO TO 700 - 633 CALL XERR('ODESSA - FATAL ERROR IN STODE (KFLAG = -3)', - 1 33, 2, 0, 0, 0, 0, ZERO,ZERO) - GO TO 801 -C - 700 IF (ILLIN .EQ. 5) GO TO 710 - ILLIN = ILLIN + 1 - ISTATE = -3 - RETURN - 710 CALL XERR('ODESSA - REPEATED OCCURRENCES OF ILLEGAL INPUT', - 1 302, 1, 0, 0, 0, 0, ZERO,ZERO) -C - 800 CALL XERR('ODESSA - RUN ABORTED.. APPARENT INFINITE LOOP', - 1 303, 2, 0, 0, 0, 0, ZERO,ZERO) - RETURN - 801 CALL XERR('ODESSA - RUN ABORTED', - 1 304, 2, 0, 0, 0, 0, ZERO,ZERO) - RETURN -C-------------------- END OF SUBROUTINE ODESSA ------------------------- - END - DOUBLE PRECISION FUNCTION ADDX(A,B) - DOUBLE PRECISION A,B -C -C THIS FUNCTION IS NECESSARY TO FORCE OPTIMIZING COMPILERS TO -C EXECUTE AND STORE A SUM, FOR SUCCESSFUL EXECUTION OF THE -C TEST A + B = B. -C - ADDX = A + B - RETURN -C-------------------- END OF FUNCTION SUM ------------------------------ - END - SUBROUTINE SPRIME (NEQ, Y, YH, NYH, NROW, NCOL, WM, IWM, - 1 EWT, SAVF, FTEM, DFDP, PAR, F, JAC, DF, PJAC, PDF) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - DIMENSION NEQ(*), Y(*), YH(NROW,NCOL,*), WM(*), IWM(*), - 1 EWT(*), SAVF(*), FTEM(*), DFDP(NROW,*), PAR(*) - EXTERNAL F, JAC, DF, PJAC, PDF - PARAMETER (ONE=1.0D0,ZERO=0.0D0) - COMMON /ODE001/ ROWND, ROWNS(173), - 1 RDUM1(37),EL0, H, RDUM2(6), - 2 IOWND1(14), IOWNS(4), - 3 IDUM1(3), IERPJ, IDUM2(6), - 4 MITER, IDUM3(4), N, IDUM4(5) - COMMON /ODE002/ RDUM3(3), - 1 IOWND2(3), IDUM5, NSV, IDUM6, NSPE, IDUM7, IERSP, JOPT, IDUM8 -C----------------------------------------------------------------------- -C SPRIME IS CALLED BY ODESSA TO INITIALIZE THE YH ARRAY. IT IS ALSO -C CALLED BY STODE TO REEVALUATE FIRST ORDER DERIVATIVES WHEN KFLAG -C .LE. -3. SPRIME COMPUTES THE FIRST DERIVATIVES OF THE SENSITIVITY -C COEFFICIENTS WITH RESPECT TO THE INDEPENDENT VARIABLE T... -C -C SPRIME = D(DY/DP)/DT = JAC*DY/DP + DF/DP -C WHERE JAC = JACOBIAN MATRIX -C DY/DP = SENSITIVITY MATRIX -C DF/DP = INHOMOGENEITY MATRIX -C THIS ROUTINE USES THE COMMON VARIABLES EL0, H, IERPJ, MITER, N, -C NSV, NSPE, IERSP, JOPT -C----------------------------------------------------------------------- -C CALL PREPJ WITH JOPT = 1. -C IF MITER = 2 OR 5, EL0 IS TEMPORARILY SET TO -1.0 AND H IS -C TEMPORARILY SET TO 1.0D0. -C----------------------------------------------------------------------- - NSPE = NSPE + 1 - JOPT = 1 - IF (MITER .EQ. 1 .OR. MITER .EQ. 4) GO TO 10 - HTEMP = H - ETEMP = EL0 - H = ONE - EL0 = -ONE - 10 CALL PJAC (NEQ, Y, YH, NYH, WM, IWM, EWT, SAVF, FTEM, - 1 PAR, F, JAC, JOPT) - IF (IERPJ .NE. 0) GO TO 300 - JOPT = 0 - IF (MITER .EQ. 1 .OR. MITER .EQ. 4) GO TO 20 - H = HTEMP - EL0 = ETEMP -C----------------------------------------------------------------------- -C CALL PREPDF AND LOAD DFDP(*,JPAR). -C----------------------------------------------------------------------- - 20 DO 30 J = 2,NSV - JPAR = J - 1 - CALL PDF (NEQ, Y, WM, SAVF, FTEM, DFDP(1,JPAR), PAR, - 1 F, DF, JPAR) - 30 CONTINUE -C----------------------------------------------------------------------- -C COMPUTE JAC*DY/DP AND STORE RESULTS IN YH(*,*,2). -C----------------------------------------------------------------------- - GO TO (40,40,310,100,100) MITER -C THE JACOBIAN IS FULL.------------------------------------------------ -C FOR EACH ROW OF THE JACOBIAN.. -C 40 DO 70 IROW = 1,N -C AND EACH COLUMN OF THE SENSITIVITY MATRIX.. -C DO 60 J = 2,NSV -C SUM = ZERO -C TAKE THE VECTOR DOT PRODUCT.. -C DO 50 I = 1,N -C IPD = IROW + N*(I-1) + 2 -C SUM = SUM + WM(IPD)*YH(I,J,1) -C 50 CONTINUE -C YH(IROW,J,2) = SUM -C 60 CONTINUE -C 70 CONTINUE - 40 CONTINUE -C FOR EACH COLUMN OF THE SENSITIVITY MATRIX.. - DO 60 J = 2,NSV - CALL Jac_SP_Vec( WM(3), YH(1,J,1), YH(1,J,2) ) - 60 CONTINUE - GO TO 200 -C THE JACOBIAN IS BANDED.----------------------------------------------- - 100 ML = IWM(1) - MU = IWM(2) - ICOUNT = 1 - MBAND = ML + MU + 1 - MEBAND = MBAND + ML - NMU = N - MU - ML1 = ML + 1 -C FOR EACH ROW OF THE JACOBIAN.. - DO 160 IROW = 1,N - IF (IROW .GT. ML1) GO TO 110 - IPD = MBAND + IROW + 1 - IYH = 1 - LBAND = MU + IROW - GO TO 120 - 110 ICOUNT = ICOUNT + 1 - IPD = ICOUNT*MEBAND + 2 - IYH = IYH + 1 - LBAND = LBAND - 1 - IF (IROW .LE. NMU) LBAND = MBAND -C AND EACH COLUMN OF THE SENSITIVITY MATRIX.. - 120 DO 150 J = 2,NSV - SUM = ZERO - I1 = IPD - I2 = IYH -C TAKE THE VECTOR DOT PRODUCT. - DO 140 I = 1,LBAND - SUM = SUM + WM(I1)*YH(I2,J,1) - I1 = I1 + MEBAND - 1 - I2 = I2 + 1 - 140 CONTINUE - YH(IROW,J,2) = SUM - 150 CONTINUE - 160 CONTINUE -C----------------------------------------------------------------------- -C ADD THE INHOMOGENEITY TERM, I.E., ADD DFDP(*,JPAR) TO YH(*,JPAR+1,2). -C----------------------------------------------------------------------- - 200 DO 220 J = 2,NSV - JPAR = J - 1 - DO 210 I = 1,N - YH(I,J,2) = YH(I,J,2) + DFDP(I,JPAR) - 210 CONTINUE - 220 CONTINUE - RETURN -C----------------------------------------------------------------------- -C ERROR RETURNS. -C----------------------------------------------------------------------- - 300 IERSP = -1 - RETURN - 310 IERSP = -2 - RETURN -C------------------------END OF SUBROUTINE SPRIME----------------------- - END - SUBROUTINE PREPJ (NEQ, Y, YH, NYH, WM, IWM, EWT, SAVF, FTEM, - 1 PAR, FUNC_CHEM, JAC, JOPT) -C IMPLICIT DOUBLE PRECISION (A-H,O-Z) - INCLUDE 'KPP_ROOT_Parameters.h' - INCLUDE 'KPP_ROOT_Sparse.h' - DIMENSION NEQ(*), Y(*), YH(NYH,*), WM(*), IWM(*), EWT(*), - 1 SAVF(*), FTEM(*), PAR(*) - EXTERNAL FUNC_CHEM, JAC - PARAMETER (ZERO=0.0D0,ONE=1.0D0) - COMMON /ODE001/ ROWND, ROWNS(173), - 2 RDUM1(37), EL0, H, RDUM2(4), TN, UROUND, - 3 IOWND(14), IOWNS(4), - 4 IDUM1(3), IERPJ, IDUM2, JCUR, IDUM3(4), - 5 MITER, IDUM4(4), N, IDUM5(2), NFE, NJE, IDUM6 -C----------------------------------------------------------------------- -C PREPJ IS CALLED BY STODE TO COMPUTE AND PROCESS THE MATRIX -C P = I - H*EL(1)*J , WHERE J IS AN APPROXIMATION TO THE JACOBIAN. -C IF ISOPT = 1, PREPJ IS ALSO CALLED BY SPRIME WITH JOPT = 1. -C HERE J IS COMPUTED BY THE USER-SUPPLIED ROUTINE JAC IF -C MITER = 1 OR 4, OR BY FINITE DIFFERENCING IF MITER = 2, 3, OR 5. -C IF MITER = 3, A DIAGONAL APPROXIMATION TO J IS USED. -C J IS STORED IN WM AND REPLACED BY P. IF MITER .NE. 3, P IS THEN -C SUBJECTED TO LU DECOMPOSITION (JOPT = 0) IN PREPARATION FOR LATER -C SOLUTION OF LINEAR SYSTEMS WITH P AS COEFFICIENT MATRIX. THIS IS -C DONE BY DGEFA IF MITER = 1 OR 2, AND BY DGBFA IF MITER = 4 OR 5. -C -C IN ADDITION TO VARIABLES DESCRIBED PREVIOUSLY, COMMUNICATION -C WITH PREPJ USES THE FOLLOWING.. -C Y = ARRAY CONTAINING PREDICTED VALUES ON ENTRY. -C FTEM = WORK ARRAY OF LENGTH N (ACOR IN STODE). -C SAVF = ARRAY CONTAINING F EVALUATED AT PREDICTED Y. -C WM = REAL WORK SPACE FOR MATRICES. ON OUTPUT IT CONTAINS THE -C INVERSE DIAGONAL MATRIX IF MITER = 3 AND THE LU DECOMPOSITION -C OF P IF MITER IS 1, 2 , 4, OR 5. -C STORAGE OF MATRIX ELEMENTS STARTS AT WM(3). -C WM ALSO CONTAINS THE FOLLOWING MATRIX-RELATED DATA.. -C WM(1) = SQRT(UROUND), USED IN NUMERICAL JACOBIAN INCREMENTS. -C WM(2) = H*EL0, SAVED FOR LATER USE IF MITER = 3. -C IWM = INTEGER WORK SPACE CONTAINING PIVOT INFORMATION, STARTING AT -C IWM(21), IF MITER IS 1, 2, 4, OR 5. IWM ALSO CONTAINS BAND -C PARAMETERS ML = IWM(1) AND MU = IWM(2) IF MITER IS 4 OR 5. -C EL0 = EL(1) (INPUT). -C IERPJ = OUTPUT ERROR FLAG, = 0 IF NO TROUBLE, .GT. 0 IF -C P MATRIX FOUND TO BE SINGULAR. -C JCUR = OUTPUT FLAG = 1 TO INDICATE THAT THE JACOBIAN MATRIX -C (OR APPROXIMATION) IS NOW CURRENT. -C JOPT = INPUT JACOBIAN OPTION, = 1 IF JAC IS DESIRED ONLY. -C THIS ROUTINE ALSO USES THE COMMON VARIABLES EL0, H, TN, UROUND, -C IERPJ, JCUR, MITER, N, NFE, AND NJE. -C----------------------------------------------------------------------- - NJE = NJE + 1 - IERPJ = 0 - JCUR = 1 - HL0 = H*EL0 - GO TO (100, 200, 300, 400, 500), MITER -C IF MITER = 1, CALL JAC AND MULTIPLY BY SCALAR. ----------------------- -C 100 LENP = N*N - 100 LENP = LU_NONZERO - DO 110 I = 1,LU_NONZERO - 110 WM(I+2) = ZERO - CALL JAC (NEQ, TN, Y, PAR, 0, 0, WM(3), N) - IF (JOPT .EQ. 1) RETURN - CON = -HL0 - DO 120 I = 1,LU_NONZERO - 120 WM(I+2) = WM(I+2)*CON - GO TO 240 -C IF MITER = 2, MAKE N CALLS TO F TO APPROXIMATE J. -------------------- - 200 FAC = VNORM (N, SAVF, EWT) - R0 = 1000.0D0*ABS(H)*UROUND*REAL(N)*FAC - IF (R0 .EQ. ZERO) R0 = ONE - SRUR = WM(1) - J1 = 2 - DO 230 J = 1,N - YJ = Y(J) - R = MAX(SRUR*ABS(YJ),R0/EWT(J)) - Y(J) = Y(J) + R - FAC = -HL0/R - CALL FUNC_CHEM (NEQ, TN, Y, PAR, FTEM) - DO 220 I = 1,N - 220 WM(I+J1) = (FTEM(I) - SAVF(I))*FAC - Y(J) = YJ - J1 = J1 + N - 230 CONTINUE - NFE = NFE + N - IF (JOPT .EQ. 1) RETURN -C ADD IDENTITY MATRIX. ------------------------------------------------- - 240 J = 3 -C DO 250 I = 1,N -C WM(J) = WM(J) + ONE -C 250 J = J + (N + 1) - DO 250 I = 1,NVAR - 250 WM(2+LU_DIAG(I)) = WM(2+LU_DIAG(I)) + ONE -C DO LU DECOMPOSITION ON P. -------------------------------------------- -C CALL DGEFA (WM(3), N, N, IWM(21), IER) - CALL KppDecomp (WM(3), IER) - IF (IER .NE. 0) THEN - IERPJ = 1 - PRINT*,"Singular Matrix" - STOP - END IF - RETURN -C IF MITER = 3, CONSTRUCT A DIAGONAL APPROXIMATION TO J AND P. --------- - 300 WM(2) = HL0 - R = EL0*0.1D0 - DO 310 I = 1,N - 310 Y(I) = Y(I) + R*(H*SAVF(I) - YH(I,2)) - CALL FUNC_CHEM (NEQ, TN, Y, PAR, WM(3)) - NFE = NFE + 1 - DO 320 I = 1,N - R0 = H*SAVF(I) - YH(I,2) - DI = 0.1D0*R0 - H*(WM(I+2) - SAVF(I)) - WM(I+2) = 1.0D0 - IF (ABS(R0) .LT. UROUND/EWT(I)) GO TO 320 - IF (ABS(DI) .EQ. ZERO) GO TO 330 - WM(I+2) = 0.1D0*R0/DI - 320 CONTINUE - RETURN - 330 IERPJ = 1 - RETURN -C IF MITER = 4, CALL JAC AND MULTIPLY BY SCALAR. ----------------------- - 400 ML = IWM(1) - MU = IWM(2) - ML3 = ML + 3 - MBAND = ML + MU + 1 - MEBAND = MBAND + ML - LENP = MEBAND*N - DO 410 I = 1,LENP - 410 WM(I+2) = ZERO - CALL JAC (NEQ, TN, Y, PAR, ML, MU, WM(ML3), MEBAND) - IF (JOPT .EQ. 1) RETURN - CON = -HL0 - DO 420 I = 1,LENP - 420 WM(I+2) = WM(I+2)*CON - GO TO 570 -C IF MITER = 5, MAKE MBAND CALLS TO F TO APPROXIMATE J. ---------------- - 500 ML = IWM(1) - MU = IWM(2) - MBAND = ML + MU + 1 - MBA = MIN(MBAND,N) - MEBAND = MBAND + ML - MEB1 = MEBAND - 1 - SRUR = WM(1) - FAC = VNORM (N, SAVF, EWT) - R0 = 1000.0D0*ABS(H)*UROUND*REAL(N)*FAC - IF (R0 .EQ. ZERO) R0 = ONE - DO 560 J = 1,MBA - DO 530 I = J,N,MBAND - YI = Y(I) - R = MAX(SRUR*ABS(YI),R0/EWT(I)) - 530 Y(I) = Y(I) + R - CALL FUNC_CHEM (NEQ, TN, Y, PAR, FTEM) - DO 550 JJ = J,N,MBAND - Y(JJ) = YH(JJ,1) - YJJ = Y(JJ) - R = MAX(SRUR*ABS(YJJ),R0/EWT(JJ)) - FAC = -HL0/R - I1 = MAX(JJ-MU,1) - I2 = MIN(JJ+ML,N) - II = JJ*MEB1 - ML + 2 - DO 540 I = I1,I2 - 540 WM(II+I) = (FTEM(I) - SAVF(I))*FAC - 550 CONTINUE - 560 CONTINUE - NFE = NFE + MBA - IF (JOPT .EQ. 1) RETURN -C ADD IDENTITY MATRIX. ------------------------------------------------- - 570 II = MBAND + 2 - DO 580 I = 1,N - WM(II) = WM(II) + ONE - 580 II = II + MEBAND -C DO LU DECOMPOSITION OF P. -------------------------------------------- - CALL DGBFA (WM(3), MEBAND, N, ML, MU, IWM(21), IER) - IF (IER .NE. 0) IERPJ = 1 - RETURN -C----------------------- END OF SUBROUTINE PREPJ ----------------------- - END - SUBROUTINE PREPDF (NEQ, Y, SRUR, SAVF, FTEM, DFDP, PAR, - 1 F, DF, JPAR) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - EXTERNAL F, DF - DIMENSION NEQ(*), Y(*), SAVF(*), FTEM(*), DFDP(*), PAR(*) - COMMON /ODE001/ ROWND, ROWNS(173), - 1 RDUM1(43), TN, RDUM2, - 2 IOWND1(14), IOWNS(4), - 3 IDUM1(10), MITER, IDUM2(4), N, IDUM3(2), NFE, IDUM4(2) - COMMON /ODE002/ RDUM3(3), - 1 IOWND2(3), IDUM5(2), NDFE, IDUM6, IDF, IDUM7(3) -C----------------------------------------------------------------------- -C PREPDF IS CALLED BY SPRIME AND STESA TO COMPUTE THE INHOMOGENEITY -C VECTORS DF(I)/DP(JPAR). HERE DF/DP IS COMPUTED BY THE USER-SUPPLIED -C ROUTINE DF IF IDF = 1, OR BY FINITE DIFFERENCING IF IDF = 0. -C -C IN ADDITION TO VARIABLES DESCRIBED PREVIOUSLY, COMMUNICATION WITH -C PREPDF USES THE FOLLOWING.. -C Y = REAL ARRAY OF LENGTH NYH CONTAINING DEPENDENT VARIABLES. -C PREPDF USES ONLY THE FIRST N ENTRIES OF Y(*). -C SRUR = SQRT(UROUND) (= WM(1)). -C SAVF = REAL ARRAY OF LENGTH N CONTAINING DERIVATIVES DY/DT. -C FTEM = REAL ARRAY OF LENGTH N USED TO TEMPORARILY STORE DY/DT FOR -C NUMERICAL DIFFERENTIATION. -C DFDP = REAL ARRAY OF LENGTH N USED TO STORE DF(I)/DP(JPAR), I = 1,N. -C PAR = REAL ARRAY OF LENGTH NPAR CONTAINING EQUATION PARAMETERS -C OF INTEREST. -C JPAR = INPUT PARAMETER, 2 .LE. JPAR .LE. NSV, DESIGNATING THE -C APPROPRIATE SOLUTION VECTOR CORRESPONDING TO PAR(JPAR). -C THIS ROUTINE ALSO USES THE COMMON VARIABLES TN, MITER, N, NFE, NDFE, -C AND IDF. -C----------------------------------------------------------------------- - NDFE = NDFE + 1 - IDF1 = IDF + 1 - GO TO (100, 200), IDF1 -C IDF = 0, CALL F TO APPROXIMATE DFDP. --------------------------------- - 100 RPAR = PAR(JPAR) - R = MAX(SRUR*ABS(RPAR),SRUR) - PAR(JPAR) = RPAR + R - FAC = 1.0D0/R - CALL F (NEQ, TN, Y, PAR, FTEM) - DO 110 I = 1,N - 110 DFDP(I) = (FTEM(I) - SAVF(I))*FAC - PAR(JPAR) = RPAR - NFE = NFE + 1 - RETURN -C IDF = 1, CALL USER SUPPLIED DF. -------------------------------------- - 200 DO 210 I = 1,N - 210 DFDP(I) = 0.0D0 - CALL DF (NEQ, TN, Y, PAR, DFDP, JPAR) - RETURN -C -------------------- END OF SUBROUTINE PREPDF ------------------------ - END - SUBROUTINE INTDY (T, K, YH, NYH, DKY, IFLAG) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - DIMENSION YH(NYH,1), DKY(1) - COMMON /ODE001/ ROWND, ROWNS(173), - 2 RDUM1(38),H, RDUM2(2), HU, RDUM3, TN, UROUND, - 3 IOWND(14), IOWNS(4), - 4 IDUM1(8), L, IDUM2, - 5 IDUM3(5), N, NQ, IDUM4(4) -C----------------------------------------------------------------------- -C INTDY COMPUTES INTERPOLATED VALUES OF THE K-TH DERIVATIVE OF THE -C DEPENDENT VARIABLE VECTOR Y, AND STORES IT IN DKY. THIS ROUTINE -C IS CALLED WITHIN THE PACKAGE WITH K = 0 AND T = TOUT, BUT MAY -C ALSO BE CALLED BY THE USER FOR ANY K UP TO THE CURRENT ORDER. -C (SEE DETAILED INSTRUCTIONS IN THE USAGE DOCUMENTATION.) -C----------------------------------------------------------------------- -C THE COMPUTED VALUES IN DKY ARE GOTTEN BY INTERPOLATION USING THE -C NORDSIECK HISTORY ARRAY YH. THIS ARRAY CORRESPONDS UNIQUELY TO A -C VECTOR-VALUED POLYNOMIAL OF DEGREE NQCUR OR LESS, AND DKY IS SET -C TO THE K-TH DERIVATIVE OF THIS POLYNOMIAL AT T. -C THE FORMULA FOR DKY IS.. -C Q -C DKY(I) = SUM C(J,K) * (T - TN)**(J-K) * H**(-J) * YH(I,J+1) -C J=K -C WHERE C(J,K) = J*(J-1)*...*(J-K+1), Q = NQCUR, TN = TCUR, H = HCUR. -C THE QUANTITIES NQ = NQCUR, L = NQ+1, N = NEQ, TN, AND H ARE -C COMMUNICATED BY COMMON. THE ABOVE SUM IS DONE IN REVERSE ORDER. -C IFLAG IS RETURNED NEGATIVE IF EITHER K OR T IS OUT OF BOUNDS. -C----------------------------------------------------------------------- - IFLAG = 0 - IF (K .LT. 0 .OR. K .GT. NQ) GO TO 80 - TP = TN - HU*(1.0D0 + 100.0D0*UROUND) - IF ((T-TP)*(T-TN) .GT. 0.0D0) GO TO 90 -C - S = (T - TN)/H - IC = 1 - IF (K .EQ. 0) GO TO 15 - JJ1 = L - K - DO 10 JJ = JJ1,NQ - 10 IC = IC*JJ - 15 C = REAL(IC) - DO 20 I = 1,NYH - 20 DKY(I) = C*YH(I,L) - IF (K .EQ. NQ) GO TO 55 - JB2 = NQ - K - DO 50 JB = 1,JB2 - J = NQ - JB - JP1 = J + 1 - IC = 1 - IF (K .EQ. 0) GO TO 35 - JJ1 = JP1 - K - DO 30 JJ = JJ1,J - 30 IC = IC*JJ - 35 C = REAL(IC) - DO 40 I = 1,NYH - 40 DKY(I) = C*YH(I,JP1) + S*DKY(I) - 50 CONTINUE - IF (K .EQ. 0) RETURN - 55 R = H**(-K) - DO 60 I = 1,NYH - 60 DKY(I) = R*DKY(I) - RETURN -C - 80 CALL XERR('INTDY-- K (=I1) ILLEGAL', - 1 51, 1, 1, K, 0, 0, ZERO,ZERO) - IFLAG = -1 - RETURN - 90 CALL XERR ('INTDY-- T (=R1) ILLEGAL', - 1 52, 1, 0, 0, 0, 1, T, ZERO) - CALL XERR('T NOT IN INTERVAL TCUR - HU (= R1) TO TCUR (=R2)', - 1 52, 1, 0, 0, 0, 2, TP, TN) - IFLAG = -2 - RETURN -C----------------------- END OF SUBROUTINE INTDY ----------------------- - END - SUBROUTINE STESA (NEQ, Y, NROW, NCOL, YH, WM, IWM, EWT, SAVF, - 1 ACOR, PAR, NRS, F, JAC, DF, PJAC, PDF, KppSolve) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - EXTERNAL F, JAC, DF, PJAC, PDF, KppSolve - DIMENSION NEQ(*), Y(NROW,*), YH(NROW,NCOL,*), WM(*), IWM(*), - 1 EWT(NROW,*), SAVF(*), ACOR(NROW,*), PAR(*), NRS(*) - PARAMETER (ONE=1.0D0,ZERO=0.0D0) - COMMON /ODE001/ ROWND, ROWNS(173), - 1 TESCO(3,12), RDUM1, EL0, H, RDUM2(4), TN, RDUM3, - 2 IOWND1(14), IOWNS(4), - 3 IALTH, LMAX, IDUM1, IERPJ, IERSL, JCUR, IDUM2, KFLAG, L, IDUM3, - 4 MITER, IDUM4(4), N, NQ, IDUM5, NFE, IDUM6(2) - COMMON /ODE002/ DUPS, DSMS, DDNS, - 1 IOWND2(3), IDUM7, NSV, IDUM8(2), IDF, IDUM9, JOPT, KFLAGS -C----------------------------------------------------------------------- -C STESA IS CALLED BY STODE TO PERFORM AN EXPLICIT CALCULATION FOR THE -C FIRST-ORDER SENSITIVITY COEFFICIENTS DY(I)/DP(J), I = 1,N; J = 1,NPAR. -C -C IN ADDITION TO THE VARIABLES DESCRIBED PREVIOUSLY, COMMUNICATION -C WITH STESA USES THE FOLLOWING.. -C Y = AN NROW (=N) BY NCOL (=NSV) REAL ARRAY CONTAINING THE -C CORRECTED DEPENDENT VARIABLES ON OUTPUT.. -C Y(I,1) , I = 1,N = STATE VARIABLES (INPUT); -C Y(I,J) , I = 1,N , J = 2,NSV , -C = SENSITIVITY COEFFICIENTS, DY(I)/DP(J). -C YH = AN N BY NSV BY LMAX REAL ARRAY CONTAINING THE PREDICTED -C DEPENDENT VARIABLES AND THEIR APPROXIMATE SCALED DERIVATIVES. -C SAVF = A REAL ARRAY OF LENGTH N USED TO STORE FIRST DERIVATIVES -C OF DEPENDENT VARIABLES IF MITER = 2 OR 5. -C PAR = A REAL ARRAY OF LENGTH NPAR CONTAINING THE EQUATION -C PARAMETERS OF INTEREST. -C NRS = AN INTEGER ARRAY OF LENGTH NPAR + 1 CONTAINING THE NUMBER -C OF REPEATED STEPS (KFLAGS .LT. 0) DUE TO THE SENSITIVITY -C CALCULATIONS.. -C NRS(1) = TOTAL NUMBER OF REPEATED STEPS -C NRS(I) , I = 2,NPAR = NUMBER OF REPEATED STEPS DUE -C TO PARAMETER I. -C NSV = NUMBER OF SOLUTION VECTORS = NPAR + 1. -C KFLAGS = LOCAL ERROR TEST FLAG, = 0 IF TEST PASSES, .LT. 0 IF TEST -C FAILS, AND STEP NEEDS TO BE REPEATED. ERROR TEST IS APPLIED -C TO EACH SOLUTION VECTOR INDEPENDENTLY. -C DUPS, DSMS, DDNS = REAL SCALARS USED FOR COMPUTING RHUP, RHSM, RHDN, -C ON RETURN TO STODE (IALTH .EQ. 1). -C THIS ROUTINE ALSO USES THE COMMON VARIABLES EL0, H, TN, IALTH, LMAX, -C IERPJ, IERSL, JCUR, KFLAG, L, MITER, N, NQ, NFE, AND JOPT. -C----------------------------------------------------------------------- - DUPS = ZERO - DSMS = ZERO - DDNS = ZERO - HL0 = H*EL0 - EL0I = ONE/EL0 - TI2 = ONE/TESCO(2,NQ) - TI3 = ONE/TESCO(3,NQ) -C IF MITER = 2 OR 5 (OR IDF = 0), SUPPLY DERIVATIVES AT CORRECTED -C Y(*,1) VALUES FOR NUMERICAL DIFFERENTIATION IN PJAC AND/OR PDF. - IF (MITER .EQ. 2 .OR. MITER .EQ. 5 .OR. IDF .EQ. 0) GO TO 10 - GO TO 15 - 10 CALL F (NEQ, TN, Y, PAR, SAVF) - NFE = NFE + 1 -C IF JCUR = 0, UPDATE THE JACOBIAN MATRIX. -C IF MITER = 5, LOAD CORRECTED Y(*,1) VALUES INTO Y(*,2). - 15 IF (JCUR .EQ. 1) GO TO 30 - IF (MITER .NE. 5) GO TO 25 - DO 20 I = 1,N - 20 Y(I,2) = Y(I,1) - 25 CALL PJAC (NEQ, Y, Y(1,2), N, WM, IWM, EWT, SAVF, ACOR(1,2), - 1 PAR, F, JAC, JOPT) - IF (IERPJ .NE. 0) RETURN -C----------------------------------------------------------------------- -C THIS IS A LOOPING POINT FOR THE SENSITIVITY CALCULATIONS. -C----------------------------------------------------------------------- -C FOR EACH PARAMETER PAR(*), A SENSITIVITY SOLUTION VECTOR IS COMPUTED -C USING THE SAME STEP SIZE (H) AND ORDER (NQ) AS IN STODE. -C A LOCAL ERROR TEST IS APPLIED INDEPENDENTLY TO EACH SOLUTION VECTOR. -C----------------------------------------------------------------------- - 30 DO 100 J = 2,NSV - JPAR = J - 1 -C EVALUATE INHOMOGENEITY TERM, TEMPORARILY LOAD INTO Y(*,JPAR+1). ------ - CALL PDF(NEQ, Y, WM, SAVF, ACOR(1,J), Y(1,J), PAR, - 1 F, DF, JPAR) -C----------------------------------------------------------------------- -C LOAD RHS OF SENSITIVITY SOLUTION (CORRECTOR) EQUATION.. -C -C RHS = DY/DP - EL(1)*H*D(DY/DP)/DT + EL(1)*H*DF/DP -C -C----------------------------------------------------------------------- - DO 40 I = 1,N - 40 Y(I,J) = YH(I,J,1) - EL0*YH(I,J,2) + HL0*Y(I,J) -C----------------------------------------------------------------------- -C KppSolve CORRECTOR EQUATION: THE SOLUTIONS ARE LOCATED IN Y(*,JPAR+1). -C THE EXPLICIT FORMULA IS.. -C -C (I - EL(1)*H*JAC) * DY/DP(CORRECTED) = RHS -C -C----------------------------------------------------------------------- - CALL KppSolve (WM, IWM, Y(1,J), DUM) - IF (IERSL .NE. 0) RETURN -C ESTIMATE LOCAL TRUNCATION ERROR. ------------------------------------- - DO 50 I = 1,N - 50 ACOR(I,J) = (Y(I,J) - YH(I,J,1))*EL0I - ERR = VNORM(N, ACOR(1,J), EWT(1,J))*TI2 - IF (ERR .GT. ONE) GO TO 200 -C----------------------------------------------------------------------- -C LOCAL ERROR TEST PASSED. SET KFLAGS TO 0 TO INDICATE THIS. -C IF IALTH = 1, COMPUTE DSMS, DDNS, AND DUPS (IF L .LT. LMAX). -C----------------------------------------------------------------------- - KFLAGS = 0 - IF (IALTH .GT. 1) GO TO 100 - IF (L .EQ. LMAX) GO TO 70 - DO 60 I= 1,N - 60 Y(I,J) = ACOR(I,J) - YH(I,J,LMAX) - DUPS = MAX(DUPS,VNORM(N,Y(1,J),EWT(1,J))*TI3) - 70 DSMS = MAX(DSMS,ERR) - 100 CONTINUE - RETURN -C----------------------------------------------------------------------- -C THIS SECTION IS REACHED IF THE ERROR TOLERANCE FOR SENSITIVITY -C SOLUTION VECTOR JPAR HAS BEEN VIOLATED. KFLAGS IS MADE NEGATIVE TO -C INDICATE THIS. IF KFLAGS = -1, SET KFLAG EQUAL TO ZERO SO THAT KFLAG -C IS SET TO -1 ON RETURN TO STODE BEFORE REPEATING THE STEP. -C INCREMENT NRS(1) (= TOTAL NUMBER OF REPEATED STEPS DUE TO ALL -C SENSITIVITY SOLUTION VECTORS) BY ONE. -C INCREMENT NRS(JPAR+1) (= TOTAL NUMBER OF REPEATED STEPS DUE TO -C SOLUTION VECTOR JPAR+1) BY ONE. -C LOAD DSMS FOR RH CALCULATION IN STODE. -C----------------------------------------------------------------------- - 200 KFLAGS = KFLAGS - 1 - IF (KFLAGS .EQ. -1) KFLAG = 0 - NRS(1) = NRS(1) + 1 - NRS(J) = NRS(J) + 1 - DSMS = ERR - RETURN -C------------------------ END OF SUBROUTINE STESA ---------------------- - END - SUBROUTINE STODE (NEQ, Y, YH, NYH, YH1, WM, IWM, EWT, SAVF, ACOR, - 1 PAR, NRS, F, JAC, DF, PJAC, PDF, SLVS) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - EXTERNAL F, JAC, DF, PJAC, PDF, SLVS - DIMENSION NEQ(*), Y(*), YH(NYH,*), YH1(*), WM(*), IWM(*), EWT(*), - 1 SAVF(*), ACOR(*), PAR(*), NRS(*) - PARAMETER (ONE=1.0D0,ZERO=0.0D0) - COMMON /ODE001/ ROWND, - 1 CONIT, CRATE, EL(13), ELCO(13,12), HOLD, RMAX, - 2 TESCO(3,12), CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, - 3 IOWND1(14), IPUP, MEO, NQNYH, NSLP, - 4 IALTH, LMAX, ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, METH, - 5 MITER, MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU - COMMON /ODE002/ DUPS, DSMS, DDNS, - 1 IOWND2(3), ISOPT, NSV, NDFE, NSPE, IDF, IERSP, JOPT, KFLAGS -C----------------------------------------------------------------------- -C STODE PERFORMS ONE STEP OF THE INTEGRATION OF AN INITIAL VALUE -C PROBLEM FOR A SYSTEM OF ORDINARY DIFFERENTIAL EQUATIONS. -C NOTE.. STODE IS INDEPENDENT OF THE VALUE OF THE ITERATION METHOD -C INDICATOR MITER, WHEN THIS IS .NE. 0, AND HENCE IS INDEPENDENT -C OF THE TYPE OF CHORD METHOD USED, OR THE JACOBIAN STRUCTURE. -C FOR ISOPT = 1, STODE CALLS STESA FOR SENSITIVITY CALCULATIONS. -C VARIABLES USED FOR COMMUNICATION WITH STESA ARE DESCRIBED IN STESA. -C COMMUNICATION WITH STODE IS DONE WITH THE FOLLOWING VARIABLES.. -C -C NEQ = INTEGER ARRAY CONTAINING PROBLEM SIZE IN NEQ(1), AND -C NUMBER OF PARAMETERS TO BE CONSIDERED IN THE SENSITIVITY -C ANALYSIS NEQ(2) (FOR ISOPT = 1), AND PASSED AS THE -C NEQ ARGUMENT IN ALL CALLS TO F, JAC, AND DF. -C Y = AN ARRAY OF LENGTH .GE. N USED AS THE Y ARGUMENT IN -C ALL CALLS TO F, JAC, AND DF. -C YH = AN NYH BY LMAX ARRAY CONTAINING THE DEPENDENT VARIABLES -C AND THEIR APPROXIMATE SCALED DERIVATIVES, WHERE -C LMAX = MAXORD + 1. YH(I,J+1) CONTAINS THE APPROXIMATE -C J-TH DERIVATIVE OF Y(I), SCALED BY H**J/FACTORIAL(J) -C (J = 0,1,...,NQ). ON ENTRY FOR THE FIRST STEP, THE FIRST -C TWO COLUMNS OF YH MUST BE SET FROM THE INITIAL VALUES. -C NYH = A CONSTANT INTEGER .GE. N, THE FIRST DIMENSION OF YH. -C THE TOTAL NUMBER OF FIRST-ORDER DIFFERENTIAL EQUATIONS.. -C NYH = N, ISOPT = 0, -C NYH = N * (NPAR + 1), ISOPT = 1 -C YH1 = A ONE-DIMENSIONAL ARRAY OCCUPYING THE SAME SPACE AS YH. -C EWT = AN ARRAY OF LENGTH NYH CONTAINING MULTIPLICATIVE WEIGHTS -C FOR LOCAL ERROR MEASUREMENTS. LOCAL ERRORS IN Y(I) ARE -C COMPARED TO 1.0/EWT(I) IN VARIOUS ERROR TESTS. -C SAVF = AN ARRAY OF WORKING STORAGE, OF LENGTH N. -C ALSO USED FOR INPUT OF YH(*,MAXORD+2) WHEN JSTART = -1 -C AND MAXORD .LT. THE CURRENT ORDER NQ. -C ACOR = A WORK ARRAY OF LENGTH NYH, USED FOR THE ACCUMULATED -C CORRECTIONS. ON A SUCCESSFUL RETURN, ACOR(I) CONTAINS -C THE ESTIMATED ONE-STEP LOCAL ERROR IN Y(I). -C WM,IWM = REAL AND INTEGER WORK ARRAYS ASSOCIATED WITH MATRIX -C OPERATIONS IN CHORD ITERATION (MITER .NE. 0). -C PJAC = NAME OF ROUTINE TO EVALUATE AND PREPROCESS JACOBIAN MATRIX -C AND P = I - H*EL0*JAC, IF A CHORD METHOD IS BEING USED. -C IF ISOPT = 1, PJAC CAN BE CALLED TO CALCULATE JAC BY -C SETTING JOPT = 1. -C SLVS = NAME OF ROUTINE TO KppSolve LINEAR SYSTEM IN CHORD ITERATION. -C CCMAX = MAXIMUM RELATIVE CHANGE IN H*EL0 BEFORE PJAC IS CALLED. -C H = THE STEP SIZE TO BE ATTEMPTED ON THE NEXT STEP. -C H IS ALTERED BY THE ERROR CONTROL ALGORITHM DURING THE -C PROBLEM. H CAN BE EITHER POSITIVE OR NEGATIVE, BUT ITS -C SIGN MUST REMAIN CONSTANT THROUGHOUT THE PROBLEM. -C HMIN = THE MINIMUM ABSOLUTE VALUE OF THE STEP SIZE H TO BE USED. -C HMXI = INVERSE OF THE MAXIMUM ABSOLUTE VALUE OF H TO BE USED. -C HMXI = 0.0 IS ALLOWED AND CORRESPONDS TO AN INFINITE HMAX. -C HMIN AND HMXI MAY BE CHANGED AT ANY TIME, BUT WILL NOT -C TAKE EFFECT UNTIL THE NEXT CHANGE OF H IS CONSIDERED. -C TN = THE INDEPENDENT VARIABLE. TN IS UPDATED ON EACH STEP TAKEN. -C JSTART = AN INTEGER USED FOR INPUT ONLY, WITH THE FOLLOWING -C VALUES AND MEANINGS.. -C 0 PERFORM THE FIRST STEP. -C .GT.0 TAKE A NEW STEP CONTINUING FROM THE LAST. -C -1 TAKE THE NEXT STEP WITH A NEW VALUE OF H, MAXORD, -C N, METH, OR MITER. -C -2 TAKE THE NEXT STEP WITH A NEW VALUE OF H, -C BUT WITH OTHER INPUTS UNCHANGED. -C ON RETURN, JSTART IS SET TO 1 TO FACILITATE CONTINUATION. -C KFLAG = A COMPLETION CODE WITH THE FOLLOWING MEANINGS.. -C 0 THE STEP WAS SUCCESFUL. -C -1 THE REQUESTED ERROR COULD NOT BE ACHIEVED. -C -2 CORRECTOR CONVERGENCE COULD NOT BE ACHIEVED. -C -3 FATAL ERROR IN PJAC, OR SLVS, (OR STESA). -C A RETURN WITH KFLAG = -1 OR -2 MEANS EITHER -C ABS(H) = HMIN OR 10 CONSECUTIVE FAILURES OCCURRED. -C ON A RETURN WITH KFLAG NEGATIVE, THE VALUES OF TN AND -C THE YH ARRAY ARE AS OF THE BEGINNING OF THE LAST -C STEP, AND H IS THE LAST STEP SIZE ATTEMPTED. -C MAXORD = THE MAXIMUM ORDER OF INTEGRATION METHOD TO BE ALLOWED. -C MAXCOR = THE MAXIMUM NUMBER OF CORRECTOR ITERATIONS ALLOWED. -C (= 3, IF ISOPT = 0) -C (= 4, IF ISOPT = 1) -C MSBP = MAXIMUM NUMBER OF STEPS BETWEEN PJAC CALLS (MITER .GT. 0). -C IF ISOPT = 1, PJAC IS CALLED AT LEAST ONCE EVERY STEP. -C MXNCF = MAXIMUM NUMBER OF CONVERGENCE FAILURES ALLOWED. -C METH/MITER = THE METHOD FLAGS. SEE DESCRIPTION IN DRIVER. -C N = THE NUMBER OF FIRST-ORDER MODEL DIFFERENTIAL EQUATIONS. -C----------------------------------------------------------------------- - KFLAG = 0 - KFLAGS = 0 - TOLD = TN - NCF = 0 - IERPJ = 0 - IERSL = 0 - JCUR = 0 - ICF = 0 - IF (JSTART .GT. 0) GO TO 200 - IF (JSTART .EQ. -1) GO TO 100 - IF (JSTART .EQ. -2) GO TO 160 -C----------------------------------------------------------------------- -C ON THE FIRST CALL, THE ORDER IS SET TO 1, AND OTHER VARIABLES ARE -C INITIALIZED. RMAX IS THE MAXIMUM RATIO BY WHICH H CAN BE INCREASED -C IN A SINGLE STEP. IT IS INITIALLY 1.E4 TO COMPENSATE FOR THE SMALL -C INITIAL H, BUT THEN IS NORMALLY EQUAL TO 10. IF A FAILURE -C OCCURS (IN CORRECTOR CONVERGENCE OR ERROR TEST), RMAX IS SET AT 2 -C FOR THE NEXT INCREASE. -C THESE COMPUTATIONS CONSIDER ONLY THE ORIGINAL SOLUTION VECTOR. -C THE SENSITIVITY SOLUTION VECTORS ARE CONSIDERED IN STESA (ISOPT = 1). -C----------------------------------------------------------------------- - LMAX = MAXORD + 1 - NQ = 1 - L = 2 - IALTH = 2 - RMAX = 10000.0D0 - RC = ZERO - EL0 = ONE - CRATE = 0.7D0 - DELP = ZERO - HOLD = H - MEO = METH - NSLP = 0 - IPUP = MITER - IRET = 3 - GO TO 140 -C----------------------------------------------------------------------- -C THE FOLLOWING BLOCK HANDLES PRELIMINARIES NEEDED WHEN JSTART = -1. -C IPUP IS SET TO MITER TO FORCE A MATRIX UPDATE. -C IF AN ORDER INCREASE IS ABOUT TO BE CONSIDERED (IALTH = 1), -C IALTH IS RESET TO 2 TO POSTPONE CONSIDERATION ONE MORE STEP. -C IF THE CALLER HAS CHANGED METH, CFODE IS CALLED TO RESET -C THE COEFFICIENTS OF THE METHOD. -C IF THE CALLER HAS CHANGED MAXORD TO A VALUE LESS THAN THE CURRENT -C ORDER NQ, NQ IS REDUCED TO MAXORD, AND A NEW H CHOSEN ACCORDINGLY. -C IF H IS TO BE CHANGED, YH MUST BE RESCALED. -C IF H OR METH IS BEING CHANGED, IALTH IS RESET TO L = NQ + 1 -C TO PREVENT FURTHER CHANGES IN H FOR THAT MANY STEPS. -C----------------------------------------------------------------------- - 100 IPUP = MITER - LMAX = MAXORD + 1 - IF (IALTH .EQ. 1) IALTH = 2 - IF (METH .EQ. MEO) GO TO 110 - CALL CFODE (METH, ELCO, TESCO) - MEO = METH - IF (NQ .GT. MAXORD) GO TO 120 - IALTH = L - IRET = 1 - GO TO 150 - 110 IF (NQ .LE. MAXORD) GO TO 160 - 120 NQ = MAXORD - L = LMAX - DO 125 I = 1,L - 125 EL(I) = ELCO(I,NQ) - NQNYH = NQ*NYH - RC = RC*EL(1)/EL0 - EL0 = EL(1) - CONIT = 0.5D0/REAL(NQ+2) - DDN = VNORM (N, SAVF, EWT)/TESCO(1,L) - EXDN = ONE/REAL(L) - RHDN = ONE/(1.3D0*DDN**EXDN + 0.0000013D0) - RH = MIN(RHDN,ONE) - IREDO = 3 - IF (H .EQ. HOLD) GO TO 170 - RH = MIN(RH,ABS(H/HOLD)) - H = HOLD - GO TO 175 -C----------------------------------------------------------------------- -C CFODE IS CALLED TO GET ALL THE INTEGRATION COEFFICIENTS FOR THE -C CURRENT METH. THEN THE EL VECTOR AND RELATED CONSTANTS ARE RESET -C WHENEVER THE ORDER NQ IS CHANGED, OR AT THE START OF THE PROBLEM. -C----------------------------------------------------------------------- - 140 CALL CFODE (METH, ELCO, TESCO) - 150 DO 155 I = 1,L - 155 EL(I) = ELCO(I,NQ) - NQNYH = NQ*NYH - RC = RC*EL(1)/EL0 - EL0 = EL(1) - CONIT = 0.5D0/REAL(NQ+2) - GO TO (160, 170, 200), IRET -C----------------------------------------------------------------------- -C IF H IS BEING CHANGED, THE H RATIO RH IS CHECKED AGAINST -C RMAX, HMIN, AND HMXI, AND THE YH ARRAY RESCALED. IALTH IS SET TO -C L = NQ + 1 TO PREVENT A CHANGE OF H FOR THAT MANY STEPS, UNLESS -C FORCED BY A CONVERGENCE OR ERROR TEST FAILURE. -C----------------------------------------------------------------------- - 160 IF (H .EQ. HOLD) GO TO 200 - RH = H/HOLD - H = HOLD - IREDO = 3 - GO TO 175 - 170 RH = MAX(RH,HMIN/ABS(H)) - 175 RH = MIN(RH,RMAX) - RH = RH/MAX(ONE,ABS(H)*HMXI*RH) - R = ONE - DO 180 J = 2,L - R = R*RH - DO 180 I = 1,NYH - 180 YH(I,J) = YH(I,J)*R - H = H*RH - RC = RC*RH - IALTH = L - IF (IREDO .EQ. 0) GO TO 690 -C----------------------------------------------------------------------- -C THIS SECTION COMPUTES THE PREDICTED VALUES BY EFFECTIVELY -C MULTIPLYING THE YH ARRAY BY THE PASCAL TRIANGLE MATRIX. -C RC IS THE RATIO OF NEW TO OLD VALUES OF THE COEFFICIENT H*EL(1). -C WHEN RC DIFFERS FROM 1 BY MORE THAN CCMAX, IPUP IS SET TO MITER -C TO FORCE PJAC TO BE CALLED, IF A JACOBIAN IS INVOLVED. -C IN ANY CASE, PJAC IS CALLED AT LEAST EVERY MSBP STEPS FOR ISOPT = 0, -C AND AT LEAST ONCE EVERY STEP FOR ISOPT = 1. -C----------------------------------------------------------------------- - 200 IF (ABS(RC-ONE) .GT. CCMAX) IPUP = MITER - IF (NST .GE. NSLP+MSBP) IPUP = MITER - TN = TN + H - I1 = NQNYH + 1 - DO 215 JB = 1,NQ - I1 = I1 - NYH - DO 210 I = I1,NQNYH - 210 YH1(I) = YH1(I) + YH1(I+NYH) - 215 CONTINUE -C----------------------------------------------------------------------- -C UP TO MAXCOR CORRECTOR ITERATIONS ARE TAKEN. (= 3, FOR ISOPT = 0; -C = 4, FOR ISOPT = 1). A CONVERGENCE TEST IS MADE ON THE R.M.S. NORM -C OF EACH CORRECTION, WEIGHTED BY THE ERROR WEIGHT VECTOR EWT. THE SUM -C OF THE CORRECTIONS IS ACCUMULATED IN THE VECTOR ACOR(I), I = 1,N. -C (ACOR(I), I = N+1,NYH IS LOADED IN SUBROUTINE STESA (ISOPT = 1).) -C THE YH ARRAY IS NOT ALTERED IN THE CORRECTOR LOOP. -C----------------------------------------------------------------------- - 220 M = 0 - DO 230 I = 1,N - 230 Y(I) = YH(I,1) - CALL F (NEQ, TN, Y, PAR, SAVF) - NFE = NFE + 1 - IF (IPUP .LE. 0) GO TO 250 -C----------------------------------------------------------------------- -C IF INDICATED, THE MATRIX P = I - H*EL(1)*J IS REEVALUATED AND -C PREPROCESSED BEFORE STARTING THE CORRECTOR ITERATION. IPUP IS SET -C TO 0 AS AN INDICATOR THAT THIS HAS BEEN DONE. -C----------------------------------------------------------------------- - IPUP = 0 - RC = ONE - NSLP = NST - CRATE = 0.7D0 - CALL PJAC (NEQ, Y, YH, NYH, WM, IWM, EWT, SAVF, ACOR, PAR, - 1 F, JAC, JOPT) - IF (IERPJ .NE. 0) GO TO 430 - 250 DO 260 I = 1,N - 260 ACOR(I) = ZERO - 270 IF (MITER .NE. 0) GO TO 350 -C----------------------------------------------------------------------- -C IN THE CASE OF FUNCTIONAL ITERATION, UPDATE Y DIRECTLY FROM -C THE RESULT OF THE LAST FUNCTION EVALUATION. -C (IF ISOPT = 1, FUNCTIONAL ITERATION IS NOT ALLOWED.) -C----------------------------------------------------------------------- - DO 290 I = 1,N - SAVF(I) = H*SAVF(I) - YH(I,2) - 290 Y(I) = SAVF(I) - ACOR(I) - DEL = VNORM (N, Y, EWT) - DO 300 I = 1,N - Y(I) = YH(I,1) + EL(1)*SAVF(I) - 300 ACOR(I) = SAVF(I) - GO TO 400 -C----------------------------------------------------------------------- -C IN THE CASE OF THE CHORD METHOD, COMPUTE THE CORRECTOR ERROR, -C AND KppSolve THE LINEAR SYSTEM WITH THAT AS RIGHT-HAND SIDE AND -C P AS COEFFICIENT MATRIX. -C----------------------------------------------------------------------- - 350 DO 360 I = 1,N - 360 Y(I) = H*SAVF(I) - (YH(I,2) + ACOR(I)) - CALL SLVS (WM, IWM, Y, SAVF) - IF (IERSL .LT. 0) GO TO 430 - IF (IERSL .GT. 0) GO TO 410 - DEL = VNORM (N, Y, EWT) - DO 380 I = 1,N - ACOR(I) = ACOR(I) + Y(I) - 380 Y(I) = YH(I,1) + EL(1)*ACOR(I) -C----------------------------------------------------------------------- -C TEST FOR CONVERGENCE. IF M.GT.0, AN ESTIMATE OF THE CONVERGENCE -C RATE CONSTANT IS STORED IN CRATE, AND THIS IS USED IN THE TEST. -C----------------------------------------------------------------------- - 400 IF (M .NE. 0) CRATE = MAX(0.2D0*CRATE,DEL/DELP) - DCON = DEL*MIN(ONE,1.5D0*CRATE)/(TESCO(2,NQ)*CONIT) - IF (DCON .LE. ONE) GO TO 450 - M = M + 1 - IF (M .EQ. MAXCOR) GO TO 410 - IF (M .GE. 2 .AND. DEL .GT. 2.0D0*DELP) GO TO 410 - DELP = DEL - CALL F (NEQ, TN, Y, PAR, SAVF) - NFE = NFE + 1 - GO TO 270 -C----------------------------------------------------------------------- -C THE CORRECTOR ITERATION FAILED TO CONVERGE IN MAXCOR TRIES. -C IF MITER .NE. 0 AND THE JACOBIAN IS OUT OF DATE, PJAC IS CALLED FOR -C THE NEXT TRY. OTHERWISE THE YH ARRAY IS RETRACTED TO ITS VALUES -C BEFORE PREDICTION, AND H IS REDUCED, IF POSSIBLE. IF H CANNOT BE -C REDUCED OR MXNCF FAILURES HAVE OCCURRED, EXIT WITH KFLAG = -2. -C----------------------------------------------------------------------- - 410 IF (MITER .EQ. 0 .OR. JCUR .EQ. 1) GO TO 430 - ICF = 1 - IPUP = MITER - GO TO 220 - 430 ICF = 2 - NCF = NCF + 1 - RMAX = 2.0D0 - TN = TOLD - I1 = NQNYH + 1 - DO 445 JB = 1,NQ - I1 = I1 - NYH - DO 440 I = I1,NQNYH - 440 YH1(I) = YH1(I) - YH1(I+NYH) - 445 CONTINUE - IF (IERPJ .LT. 0 .OR. IERSL .LT. 0) GO TO 680 - IF (ABS(H) .LE. HMIN*1.00001D0) GO TO 670 - IF (NCF .EQ. MXNCF) GO TO 670 - RH = 0.25D0 - IPUP = MITER - IREDO = 1 - GO TO 170 -C----------------------------------------------------------------------- -C THE CORRECTOR HAS CONVERGED. -C THE LOCAL ERROR TEST IS MADE AND CONTROL PASSES TO STATEMENT 500 -C IF IT FAILS. OTHERWISE, STESA IS CALLED (ISOPT = 1) TO PERFORM -C SENSITIVITY CALCULATIONS AT CURRENT STEP SIZE AND ORDER. -C----------------------------------------------------------------------- - 450 CONTINUE - IF (M .EQ. 0) DSM = DEL/TESCO(2,NQ) - IF (M .GT. 0) DSM = VNORM (N, ACOR, EWT)/TESCO(2,NQ) - IF (DSM .GT. ONE) GO TO 500 -C - IF (ISOPT .EQ. 0) GO TO 460 -C----------------------------------------------------------------------- -C CALL STESA TO PERFORM EXPLICIT SENSITIVITY ANALYSIS. -C IF THE LOCAL ERROR TEST FAILS (WITHIN STESA) FOR ANY SOLUTION VECTOR, -C KFLAGS IS SET .LT. 0 AND CONTROL PASSES TO STATEMENT 500 UPON RETURN. -C IN EITHER CASE, JCUR IS SET TO ZERO TO SIGNAL THAT THE JACOBIAN MAY -C NEED UPDATING LATER. -C----------------------------------------------------------------------- - CALL STESA (NEQ, Y, N, NSV, YH, WM, IWM, EWT, SAVF, ACOR, - 1 PAR, NRS, F, JAC, DF, PJAC, PDF, SLVS) - IF (IERPJ .NE. 0 .OR. IERSL .NE. 0) GO TO 680 - IF (KFLAGS .LT. 0) GO TO 500 -C----------------------------------------------------------------------- -C AFTER A SUCCESSFUL STEP, UPDATE THE YH ARRAY. -C CONSIDER CHANGING H IF IALTH = 1. OTHERWISE DECREASE IALTH BY 1. -C IF IALTH IS THEN 1 AND NQ .LT. MAXORD, THEN ACOR IS SAVED FOR -C USE IN A POSSIBLE ORDER INCREASE ON THE NEXT STEP. -C IF A CHANGE IN H IS CONSIDERED, AN INCREASE OR DECREASE IN ORDER -C BY ONE IS CONSIDERED ALSO. A CHANGE IN H IS MADE ONLY IF IT IS BY A -C FACTOR OF AT LEAST 1.1. IF NOT, IALTH IS SET TO 3 TO PREVENT -C TESTING FOR THAT MANY STEPS. -C----------------------------------------------------------------------- - 460 JCUR = 0 - KFLAG = 0 - IREDO = 0 - NST = NST + 1 - HU = H - NQU = NQ - DO 470 J = 1,L - DO 470 I = 1,NYH - 470 YH(I,J) = YH(I,J) + EL(J)*ACOR(I) - IALTH = IALTH - 1 - IF (IALTH .EQ. 0) GO TO 520 - IF (IALTH .GT. 1) GO TO 700 - IF (L .EQ. LMAX) GO TO 700 - DO 490 I = 1,NYH - 490 YH(I,LMAX) = ACOR(I) - GO TO 700 -C----------------------------------------------------------------------- -C THE ERROR TEST FAILED IN EITHER STODE OR STESA. -C KFLAG KEEPS TRACK OF MULTIPLE FAILURES. -C RESTORE TN AND THE YH ARRAY TO THEIR PREVIOUS VALUES, AND PREPARE -C TO TRY THE STEP AGAIN. COMPUTE THE OPTIMUM STEP SIZE FOR THIS OR -C ONE LOWER ORDER. AFTER 2 OR MORE FAILURES, H IS FORCED TO DECREASE -C BY A FACTOR OF 0.2 OR LESS. -C----------------------------------------------------------------------- - 500 KFLAG = KFLAG - 1 - JCUR = 0 - TN = TOLD - I1 = NQNYH + 1 - DO 515 JB = 1,NQ - I1 = I1 - NYH - DO 510 I = I1,NQNYH - 510 YH1(I) = YH1(I) - YH1(I+NYH) - 515 CONTINUE - RMAX = 2.0D0 - IF (ABS(H) .LE. HMIN*1.00001D0) GO TO 660 - IF (KFLAG .LE. -3) GO TO 640 - IREDO = 2 - RHUP = ZERO - GO TO 540 -C----------------------------------------------------------------------- -* -C REGARDLESS OF THE SUCCESS OR FAILURE OF THE STEP, FACTORS -C RHDN, RHSM, AND RHUP ARE COMPUTED, BY WHICH H COULD BE MULTIPLIED -C AT ORDER NQ - 1, ORDER NQ, OR ORDER NQ + 1, RESPECTIVELY. -C IN THE CASE OF FAILURE, RHUP = 0.0 TO AVOID AN ORDER INCREASE. -C THE LARGEST OF THESE IS DETERMINED AND THE NEW ORDER CHOSEN -C ACCORDINGLY. IF THE ORDER IS TO BE INCREASED, WE COMPUTE ONE -C ADDITIONAL SCALED DERIVATIVE. -C FOR ISOPT = 1, DUPS AND DSMS ARE LOADED WITH THE LARGEST RMS-NORMS -C OBTAINED BY CONSIDERING SEPARATELY THE SENSITIVITY SOLUTION VECTORS. -C----------------------------------------------------------------------- - 520 RHUP = ZERO - IF (L .EQ. LMAX) GO TO 540 - DO 530 I = 1,N - 530 SAVF(I) = ACOR(I) - YH(I,LMAX) - DUP = VNORM (N, SAVF, EWT)/TESCO(3,NQ) - DUP = MAX(DUP,DUPS) - EXUP = ONE/REAL(L+1) - RHUP = ONE/(1.4D0*DUP**EXUP + 0.0000014D0) - 540 EXSM = ONE/REAL(L) - DSM = MAX(DSM,DSMS) - RHSM = ONE/(1.2D0*DSM**EXSM + 0.0000012D0) - RHDN = ZERO - IF (NQ .EQ. 1) GO TO 560 - JPOINT = 1 - DO 550 J = 1,NSV - DDN = VNORM (N, YH(JPOINT,L), EWT(JPOINT))/TESCO(1,NQ) - DDNS = MAX(DDNS,DDN) - JPOINT = JPOINT + N - 550 CONTINUE - DDN = DDNS - DDNS = ZERO - EXDN = ONE/REAL(NQ) - RHDN = ONE/(1.3D0*DDN**EXDN + 0.0000013D0) - 560 IF (RHSM .GE. RHUP) GO TO 570 - IF (RHUP .GT. RHDN) GO TO 590 - GO TO 580 - 570 IF (RHSM .LT. RHDN) GO TO 580 - NEWQ = NQ - RH = RHSM - GO TO 620 - 580 NEWQ = NQ - 1 - RH = RHDN - IF (KFLAG .LT. 0 .AND. RH .GT. ONE) RH = ONE - GO TO 620 - 590 NEWQ = L - RH = RHUP - IF (RH .LT. 1.1D0) GO TO 610 - R = EL(L)/REAL(L) - DO 600 I = 1,NYH - 600 YH(I,NEWQ+1) = ACOR(I)*R - GO TO 630 - 610 IALTH = 3 - GO TO 700 - 620 IF ((KFLAG .EQ. 0) .AND. (RH .LT. 1.1D0)) GO TO 610 - IF (KFLAG .LE. -2) RH = MIN(RH,0.2D0) -C----------------------------------------------------------------------- -C IF THERE IS A CHANGE OF ORDER, RESET NQ, L, AND THE COEFFICIENTS. -C IN ANY CASE H IS RESET ACCORDING TO RH AND THE YH ARRAY IS RESCALED. -C THEN EXIT FROM 690 IF THE STEP WAS OK, OR REDO THE STEP OTHERWISE. -C----------------------------------------------------------------------- - IF (NEWQ .EQ. NQ) GO TO 170 - 630 NQ = NEWQ - L = NQ + 1 - IRET = 2 - GO TO 150 -C----------------------------------------------------------------------- -C CONTROL REACHES THIS SECTION IF 3 OR MORE FAILURES HAVE OCCURED. -C IF 10 FAILURES HAVE OCCURRED, EXIT WITH KFLAG = -1. -C IT IS ASSUMED THAT THE DERIVATIVES THAT HAVE ACCUMULATED IN THE -C YH ARRAY HAVE ERRORS OF THE WRONG ORDER. HENCE THE FIRST -C DERIVATIVE IS RECOMPUTED, AND THE ORDER IS SET TO 1. THEN -C H IS REDUCED BY A FACTOR OF 10, AND THE STEP IS RETRIED, -C UNTIL IT SUCCEEDS OR H REACHES HMIN. -C----------------------------------------------------------------------- - 640 IF (KFLAG .EQ. -10) GO TO 660 - RH = 0.1D0 - RH = MAX(HMIN/ABS(H),RH) - H = H*RH - DO 645 I = 1,NYH - 645 Y(I) = YH(I,1) - CALL F (NEQ, TN, Y, PAR, SAVF) - NFE = NFE + 1 - IF (ISOPT .EQ. 0) GO TO 649 - CALL SPRIME (NEQ, Y, YH, NYH, N, NSV, WM, IWM, EWT, SAVF, ACOR, - 1 ACOR(N+1), PAR, F, JAC, DF, PJAC, PDF) - IF (IERSP .LT. 0) GO TO 680 - DO 646 I = N+1,NYH - 646 YH(I,2) = H*YH(I,2) - 649 DO 650 I = 1,N - 650 YH(I,2) = H*SAVF(I) - IPUP = MITER - IALTH = 5 - IF (NQ .EQ. 1) GO TO 200 - NQ = 1 - L = 2 - IRET = 3 - GO TO 150 -C----------------------------------------------------------------------- -C ALL RETURNS ARE MADE THROUGH THIS SECTION. H IS SAVED IN HOLD -C TO ALLOW THE CALLER TO CHANGE H ON THE NEXT STEP. -C----------------------------------------------------------------------- - 660 KFLAG = -1 - GO TO 720 - 670 KFLAG = -2 - GO TO 720 - 680 KFLAG = -3 - GO TO 720 - 690 RMAX = 10.0D0 - 700 R = ONE/TESCO(2,NQU) - DO 710 I = 1,NYH - 710 ACOR(I) = ACOR(I)*R - 720 HOLD = H - JSTART = 1 - RETURN -C----------------------- END OF SUBROUTINE STODE ----------------------- - END - SUBROUTINE CFODE (METH, ELCO, TESCO) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - DIMENSION ELCO(13,12), TESCO(3,12) -C----------------------------------------------------------------------- -C CFODE IS CALLED BY THE INTEGRATOR ROUTINE TO SET COEFFICIENTS -C NEEDED THERE. THE COEFFICIENTS FOR THE CURRENT METHOD, AS -C GIVEN BY THE VALUE OF METH, ARE SET FOR ALL ORDERS AND SAVED. -C THE MAXIMUM ORDER ASSUMED HERE IS 12 IF METH = 1 AND 5 IF METH = 2. -C (A SMALLER VALUE OF THE MAXIMUM ORDER IS ALSO ALLOWED.) -C CFODE IS CALLED ONCE AT THE BEGINNING OF THE PROBLEM, -C AND IS NOT CALLED AGAIN UNLESS AND UNTIL METH IS CHANGED. -C -C THE ELCO ARRAY CONTAINS THE BASIC METHOD COEFFICIENTS. -C THE COEFFICIENTS EL(I), 1 .LE. I .LE. NQ+1, FOR THE METHOD OF -C ORDER NQ ARE STORED IN ELCO(I,NQ). THEY ARE GIVEN BY A GENETRATING -C POLYNOMIAL, I.E., -C L(X) = EL(1) + EL(2)*X + ... + EL(NQ+1)*X**NQ. -C FOR THE IMPLICIT ADAMS METHODS, L(X) IS GIVEN BY -C DL/DX = (X+1)*(X+2)*...*(X+NQ-1)/FACTORIAL(NQ-1), L(-1) = 0. -C FOR THE BDF METHODS, L(X) IS GIVEN BY -C L(X) = (X+1)*(X+2)* ... *(X+NQ)/K, -C WHERE K = FACTORIAL(NQ)*(1 + 1/2 + ... + 1/NQ). -C -C THE TESCO ARRAY CONTAINS TEST CONSTANTS USED FOR THE -C LOCAL ERROR TEST AND THE SELECTION OF STEP SIZE AND/OR ORDER. -C AT ORDER NQ, TESCO(K,NQ) IS USED FOR THE SELECTION OF STEP -C SIZE AT ORDER NQ - 1 IF K = 1, AT ORDER NQ IF K = 2, AND AT ORDER -C NQ + 1 IF K = 3. -C----------------------------------------------------------------------- - DIMENSION PC(12) - PARAMETER (ONE=1.0D0,ZERO=0.0D0) -C - GO TO (100, 200), METH -C - 100 ELCO(1,1) = ONE - ELCO(2,1) = ONE - TESCO(1,1) = ZERO - TESCO(2,1) = 2.0D0 - TESCO(1,2) = ONE - TESCO(3,12) = ZERO - PC(1) = ONE - RQFAC = ONE - DO 140 NQ = 2,12 -C----------------------------------------------------------------------- -C THE PC ARRAY WILL CONTAIN THE COEFFICIENTS OF THE POLYNOMIAL -C P(X) = (X+1)*(X+2)*...*(X+NQ-1). -C INITIALLY, P(X) = 1. -C----------------------------------------------------------------------- - RQ1FAC = RQFAC - RQFAC = RQFAC/REAL(NQ) - NQM1 = NQ - 1 - FNQM1 = REAL(NQM1) - NQP1 = NQ + 1 -C FORM COEFFICIENTS OF P(X)*(X+NQ-1). ---------------------------------- - PC(NQ) = ZERO - DO 110 IB = 1,NQM1 - I = NQP1 - IB - 110 PC(I) = PC(I-1) + FNQM1*PC(I) - PC(1) = FNQM1*PC(1) -C COMPUTE INTEGRAL, -1 TO 0, OF P(X) AND X*P(X). ----------------------- - PINT = PC(1) - XPIN = PC(1)/2.0D0 - TSIGN = ONE - DO 120 I = 2,NQ - TSIGN = -TSIGN - PINT = PINT + TSIGN*PC(I)/REAL(I) - 120 XPIN = XPIN + TSIGN*PC(I)/REAL(I+1) -C STORE COEFFICIENTS IN ELCO AND TESCO. -------------------------------- - ELCO(1,NQ) = PINT*RQ1FAC - ELCO(2,NQ) = ONE - DO 130 I = 2,NQ - 130 ELCO(I+1,NQ) = RQ1FAC*PC(I)/REAL(I) - AGAMQ = RQFAC*XPIN - RAGQ = ONE/AGAMQ - TESCO(2,NQ) = RAGQ - IF (NQ .LT. 12) TESCO(1,NQP1) = RAGQ*RQFAC/REAL(NQP1) - TESCO(3,NQM1) = RAGQ - 140 CONTINUE - RETURN -C - 200 PC(1) = ONE - RQ1FAC = ONE - DO 230 NQ = 1,5 -C----------------------------------------------------------------------- -C THE PC ARRAY WILL CONTAIN THE COEFFICIENTS OF THE POLYNOMIAL -C P(X) = (X+1)*(X+2)*...*(X+NQ). -C INITIALLY, P(X) = 1. -C----------------------------------------------------------------------- - FNQ = REAL(NQ) - NQP1 = NQ + 1 -C FORM COEFFICIENTS OF P(X)*(X+NQ). ------------------------------------ - PC(NQP1) = ZERO - DO 210 IB = 1,NQ - I = NQ + 2 - IB - 210 PC(I) = PC(I-1) + FNQ*PC(I) - PC(1) = FNQ*PC(1) -C STORE COEFFICIENTS IN ELCO AND TESCO. -------------------------------- - DO 220 I = 1,NQP1 - 220 ELCO(I,NQ) = PC(I)/PC(2) - ELCO(2,NQ) = ONE - TESCO(1,NQ) = RQ1FAC - TESCO(2,NQ) = REAL(NQP1)/ELCO(1,NQ) - TESCO(3,NQ) = REAL(NQ+2)/ELCO(1,NQ) - RQ1FAC = RQ1FAC/FNQ - 230 CONTINUE - RETURN -C----------------------- END OF SUBROUTINE CFODE ----------------------- - END - SUBROUTINE SOLSY (WM, IWM, X, TEM) -C IMPLICIT DOUBLE PRECISION (A-H,O-Z) - INCLUDE 'KPP_ROOT_Parameters.h' - INCLUDE 'KPP_ROOT_Sparse.h' - DIMENSION WM(*), IWM(*), X(*), TEM(*) - PARAMETER (ZERO=0.0D0,ONE=1.0D0) - COMMON /ODE001/ ROWND, ROWNS(173), - 2 RDUM1(37), EL0, H, RDUM2(6), - 3 IOWND(14), IOWNS(4), - 4 IDUM1(4), IERSL, IDUM2(5), - 5 MITER, IDUM3(4), N, IDUM4(5) -C----------------------------------------------------------------------- -C THIS ROUTINE MANAGES THE SOLUTION OF THE LINEAR SYSTEM ARISING FROM -C A CHORD ITERATION. IT IS CALLED IF MITER .NE. 0. -C IF MITER IS 1 OR 2, IT CALLS DGESL TO ACCOMPLISH THIS. -C IF MITER = 3 IT UPDATES THE COEFFICIENT H*EL0 IN THE DIAGONAL -C MATRIX, AND THEN COMPUTES THE SOLUTION. -C IF MITER IS 4 OR 5, IT CALLS DGBSL. -C COMMUNICATION WITH SOLSY USES THE FOLLOWING VARIABLES.. -C WM = REAL WORK SPACE CONTAINING THE INVERSE DIAGONAL MATRIX IF -C MITER = 3 AND THE LU DECOMPOSITION OF THE MATRIX OTHERWISE. -C STORAGE OF MATRIX ELEMENTS STARTS AT WM(3). -C WM ALSO CONTAINS THE FOLLOWING MATRIX-RELATED DATA.. -C WM(1) = SQRT(UROUND) (NOT USED HERE), -C WM(2) = HL0, THE PREVIOUS VALUE OF H*EL0, USED IF MITER = 3. -C IWM = INTEGER WORK SPACE CONTAINING PIVOT INFORMATION, STARTING AT -C IWM(21), IF MITER IS 1, 2, 4, OR 5. IWM ALSO CONTAINS BAND -C PARAMETERS ML = IWM(1) AND MU = IWM(2) IF MITER IS 4 OR 5. -C X = THE RIGHT-HAND SIDE VECTOR ON INPUT, AND THE SOLUTION VECTOR -C ON OUTPUT, OF LENGTH N. -C TEM = VECTOR OF WORK SPACE OF LENGTH N, NOT USED IN THIS VERSION. -C IERSL = OUTPUT FLAG (IN COMMON). IERSL = 0 IF NO TROUBLE OCCURRED. -C IERSL = 1 IF A SINGULAR MATRIX AROSE WITH MITER = 3. -C THIS ROUTINE ALSO USES THE COMMON VARIABLES EL0, H, MITER, AND N. -C----------------------------------------------------------------------- - IERSL = 0 - GO TO (100, 100, 300, 400, 400), MITER -C 100 CALL DGESL (WM(3), N, N, IWM(21), X, 0) - 100 CALL KppSolve (WM(3), X) - RETURN -C - 300 PHL0 = WM(2) - HL0 = H*EL0 - WM(2) = HL0 - IF (HL0 .EQ. PHL0) GO TO 330 - R = HL0/PHL0 - DO 320 I = 1,N - DI = ONE - R*(ONE - ONE/WM(I+2)) - IF (ABS(DI) .EQ. ZERO) GO TO 390 - 320 WM(I+2) = ONE/DI - 330 DO 340 I = 1,N - 340 X(I) = WM(I+2)*X(I) - RETURN - 390 IERSL = 1 - RETURN -C - 400 ML = IWM(1) - MU = IWM(2) - MEBAND = 2*ML + MU + 1 - CALL DGBSL (WM(3), MEBAND, N, ML, MU, IWM(21), X, 0) - RETURN -C----------------------- END OF SUBROUTINE SOLSY ----------------------- - END - SUBROUTINE EWSET (N, ITOL, RTOL, ATOL, YCUR, EWT) -C----------------------------------------------------------------------- -C THIS SUBROUTINE SETS THE ERROR WEIGHT VECTOR EWT ACCORDING TO -C EWT(I) = RTOL(I)*ABS(YCUR(I)) + ATOL(I), I = 1,...,N, -C WITH THE SUBSCRIPT ON RTOL AND/OR ATOL POSSIBLY REPLACED BY 1 ABOVE, -C DEPENDING ON THE VALUE OF ITOL. -C----------------------------------------------------------------------- - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - DIMENSION RTOL(*), ATOL(*), YCUR(N), EWT(N) - RTOLI = RTOL(1) - ATOLI = ATOL(1) - DO 10 I = 1,N - IF (ITOL .GE. 3) RTOLI = RTOL(I) - IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) - EWT(I) = RTOLI*ABS(YCUR(I)) + ATOLI - 10 CONTINUE - RETURN -C----------------------- END OF SUBROUTINE EWSET ----------------------- - END - DOUBLE PRECISION FUNCTION VNORM (N, V, W) -C----------------------------------------------------------------------- -C THIS FUNCTION ROUTINE COMPUTES THE WEIGHTED ROOT-MEAN-SQUARE NORM -C OF THE VECTOR OF LENGTH N CONTAINED IN THE ARRAY V, WITH WEIGHTS -C CONTAINED IN THE ARRAY W OF LENGTH N.. -C VNORM = SQRT( (1/N) * SUM( V(I)*W(I) )**2 ) -C PROTECTION FOR UNDERFLOW/OVERFLOW IS ACCOMPLISHED USING TWO -C CONSTANTS WHICH ARE HOPEFULLY APPLICABLE FOR ALL MACHINES. -C THESE ARE: -C CUTLO = maximum of SQRT(U/EPS) over all known machines -C CUTHI = minimum of SQRT(Z) over all known machines -C WHERE -C EPS = smallest number s.t. EPS + 1 .GT. 1 -C U = smallest positive number (underflow limit) -C Z = largest number (overflow limit) -C -C DETAILS OF THE ALGORITHM AND OF VALUES OF CUTLO AND CUTHI ARE -C FOUND IN THE BLAS ROUTINE SNRM2 (SEE ALSO ALGORITHM 539, TRANS. -C MATH. SOFTWARE, VOL. 5 NO. 3, 1979, 308-323. -C FOR SINGLE PRECISION, THE FOLLOWING VALUES SHOULD BE UNIVERSAL: -C DATA CUTLO,CUTHI /4.441E-16,1.304E19/ -C FOR DOUBLE PRECISION, USE -C DATA CUTLO,CUTHI /8.232D-11,1.304D19/ -C -C----------------------------------------------------------------------- - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - INTEGER NEXT,I,J,N - DIMENSION V(N),W(N) - DATA CUTLO,CUTHI /8.232D-11,1.304D19/ - DATA ZERO,ONE/0.0D0,1.0D0/ -C BLAS ALGORITHM - NEXT = 1 - SUM = ZERO - I = 1 -20 SX = V(I)*W(I) - GO TO (30,40,70,80),NEXT -30 IF (ABS(SX).GT.CUTLO) GO TO 110 - NEXT = 2 - XMAX = ZERO -40 IF (SX.EQ.ZERO) GO TO 130 - IF (ABS(SX).GT.CUTLO) GO TO 110 - NEXT = 3 - GO TO 60 -50 I=J - NEXT = 4 - SUM = (SUM/SX)/SX -60 XMAX = ABS(SX) - GO TO 90 -70 IF(ABS(SX).GT.CUTLO) GO TO 100 -80 IF(ABS(SX).LE.XMAX) GO TO 90 - SUM = ONE + SUM * (XMAX/SX)**2 - XMAX = ABS(SX) - GO TO 130 -90 SUM = SUM + (SX/XMAX)**2 - GO TO 130 -100 SUM = (SUM*XMAX)*XMAX -110 HITEST = CUTHI/REAL(N) - DO 120 J = I,N - SX = V(J)*W(J) - IF(ABS(SX).GE.HITEST) GO TO 50 - SUM = SUM + SX**2 -120 CONTINUE - VNORM = SQRT(SUM) - GO TO 140 -130 CONTINUE - I = I + 1 - IF (I.LE.N) GO TO 20 - VNORM = XMAX * SQRT(SUM) -140 CONTINUE - RETURN -C----------------------- END OF FUNCTION VNORM ------------------------- - END - SUBROUTINE SVCOM (RSAV, ISAV) -C----------------------------------------------------------------------- -C THIS ROUTINE STORES IN RSAV AND ISAV THE CONTENTS OF COMMON BLOCKS -C ODE001, ODE002 AND EH0001, WHICH ARE USED INTERNALLY IN THE ODESSA -C PACKAGE. -C RSAV = REAL ARRAY OF LENGTH 222 OR MORE. -C ISAV = INTEGER ARRAY OF LENGTH 52 OR MORE. -C----------------------------------------------------------------------- - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - DIMENSION RSAV(*), ISAV(*) - COMMON /ODE001/ RODE1(219), IODE1(39) - COMMON /ODE002/ RODE2(3), IODE2(11) - COMMON /EH0001/ IEH(2) - DATA LRODE1/219/, LIODE1/39/, LRODE2/3/, LIODE2/11/ -C - DO 10 I = 1,LRODE1 - 10 RSAV(I) = RODE1(I) - DO 20 I = 1,LRODE2 - J = LRODE1 + I - 20 RSAV(J) = RODE2(I) - DO 30 I = 1,LIODE1 - 30 ISAV(I) = IODE1(I) - DO 40 I = 1,LIODE2 - J = LIODE1 + I - 40 ISAV(J) = IODE2(I) - ISAV(LIODE1+LIODE2+1) = IEH(1) - ISAV(LIODE1+LIODE2+2) = IEH(2) - RETURN -C----------------------- END OF SUBROUTINE SVCOM ----------------------- - END - SUBROUTINE RSCOM (RSAV, ISAV) -C----------------------------------------------------------------------- -C THIS ROUTINE RESTORES FROM RSAV AND ISAV THE CONTENTS OF COMMON BLOCKS -C ODE001, ODE002 AND EH0001, WHICH ARE USED INTERNALLY IN THE ODESSSA -C PACKAGE. THIS PRESUMES THAT RSAV AND ISAV WERE LOADED BY MEANS -C OF SUBROUTINE SVCOM OR THE EQUIVALENT. -C----------------------------------------------------------------------- - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - DIMENSION RSAV(*), ISAV(*) - COMMON /ODE001/ RODE1(219), IODE1(39) - COMMON /ODE002/ RODE2(3), IODE2(11) - COMMON /EH0001/ IEH(2) - DATA LRODE1/219/, LIODE1/39/, LRODE2/3/, LIODE2/11/ -C - DO 10 I = 1,LRODE1 - 10 RODE1(I) = RSAV(I) - DO 20 I = 1,LRODE2 - J = LRODE1 + I - 20 RODE2(I) = RSAV(J) - DO 30 I = 1,LIODE1 - 30 IODE1(I) = ISAV(I) - DO 40 I = 1,LODE2 - J = LIODE1 + I - 40 IODE2(I) = ISAV(J) - IEH(1) = ISAV(LIODE1+LIODE2+1) - IEH(2) = ISAV(LIODE1+LIODE2+2) - RETURN -C----------------------- END OF SUBROUTINE RSCOM ----------------------- - END - SUBROUTINE DGEFA(A,LDA,N,IPVT,INFO) - INTEGER LDA,N,IPVT(*),INFO - DOUBLE PRECISION A(LDA,*) -C -C DGEFA FACTORS A DOUBLE PRECISION MATRIX BY GAUSSIAN ELIMINATION. -C -C DGEFA IS USUALLY CALLED BY DGECO, BUT IT CAN BE CALLED -C DIRECTLY WITH A SAVING IN TIME IF RCOND IS NOT NEEDED. -C (TIME FOR DGECO) = (1 + 9/N)*(TIME FOR DGEFA) . -C -C ON ENTRY -C -C A DOUBLE PRECISION(LDA, N) -C THE MATRIX TO BE FACTORED. -C -C LDA INTEGER -C THE LEADING DIMENSION OF THE ARRAY A . -C -C N INTEGER -C THE ORDER OF THE MATRIX A . -C -C ON RETURN -C -C A AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS -C WHICH WERE USED TO OBTAIN IT. -C THE FACTORIZATION CAN BE WRITTEN A = L*U WHERE -C L IS A PRODUCT OF PERMUTATION AND UNIT LOWER -C TRIANGULAR MATRICES AND U IS UPPER TRIANGULAR. -C -C IPVT INTEGER(N) -C AN INTEGER VECTOR OF PIVOT INDICES. -C -C INFO INTEGER -C = 0 NORMAL VALUE. -C = K IF U(K,K) .EQ. 0.0 . THIS IS NOT AN ERROR -C CONDITION FOR THIS SUBROUTINE, BUT IT DOES -C INDICATE THAT DGESL OR DGEDI WILL DIVIDE BY ZERO -C IF CALLED. USE RCOND IN DGECO FOR A RELIABLE -C INDICATION OF SINGULARITY. -C -C LINPACK. THIS VERSION DATED 08/14/78 . -C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. -C -C SUBROUTINES AND FUNCTIONS -C -C BLAS DAXPY,DSCAL,IDAMAX -C -C INTERNAL VARIABLES -C - DOUBLE PRECISION T - INTEGER IDAMAX,J,K,KP1,L,NM1 -C -C -C GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING -C - INFO = 0 - NM1 = N - 1 - IF (NM1 .LT. 1) GO TO 70 - DO 60 K = 1, NM1 - KP1 = K + 1 -C -C FIND L = PIVOT INDEX -C - L = IDAMAX(N-K+1,A(K,K),1) + K - 1 - IPVT(K) = L -C -C ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED -C - IF (A(L,K) .EQ. 0.0D0) GO TO 40 -C -C INTERCHANGE IF NECESSARY -C - IF (L .EQ. K) GO TO 10 - T = A(L,K) - A(L,K) = A(K,K) - A(K,K) = T - 10 CONTINUE -C -C COMPUTE MULTIPLIERS -C - T = -1.0D0/A(K,K) - CALL DSCAL(N-K,T,A(K+1,K),1) -C -C ROW ELIMINATION WITH COLUMN INDEXING -C - DO 30 J = KP1, N - T = A(L,J) - IF (L .EQ. K) GO TO 20 - A(L,J) = A(K,J) - A(K,J) = T - 20 CONTINUE - CALL DAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1) - 30 CONTINUE - GO TO 50 - 40 CONTINUE - INFO = K - 50 CONTINUE - 60 CONTINUE - 70 CONTINUE - IPVT(N) = N - IF (A(N,N) .EQ. 0.0D0) INFO = N - RETURN - END - SUBROUTINE DGESL(A,LDA,N,IPVT,B,JOB) - INTEGER LDA,N,IPVT(*),JOB - DOUBLE PRECISION A(LDA,*),B(*) -C -C DGESL KppSolveS THE DOUBLE PRECISION SYSTEM -C A * X = B OR TRANS(A) * X = B -C USING THE FACTORS COMPUTED BY DGECO OR DGEFA. -C -C ON ENTRY -C -C A DOUBLE PRECISION(LDA, N) -C THE OUTPUT FROM DGECO OR DGEFA. -C -C LDA INTEGER -C THE LEADING DIMENSION OF THE ARRAY A . -C -C N INTEGER -C THE ORDER OF THE MATRIX A . -C -C IPVT INTEGER(N) -C THE PIVOT VECTOR FROM DGECO OR DGEFA. -C -C B DOUBLE PRECISION(N) -C THE RIGHT HAND SIDE VECTOR. -C -C JOB INTEGER -C = 0 TO KppSolve A*X = B , -C = NONZERO TO KppSolve TRANS(A)*X = B WHERE -C TRANS(A) IS THE TRANSPOSE. -C -C ON RETURN -C -C B THE SOLUTION VECTOR X . -C -C ERROR CONDITION -C -C A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A -C ZERO ON THE DIAGONAL. TECHNICALLY THIS INDICATES SINGULARITY -C BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER -C SETTING OF LDA . IT WILL NOT OCCUR IF THE SUBROUTINES ARE -C CALLED CORRECTLY AND IF DGECO HAS SET RCOND .GT. 0.0 -C OR DGEFA HAS SET INFO .EQ. 0 . -C -C TO COMPUTE INVERSE(A) * C WHERE C IS A MATRIX -C WITH P COLUMNS -C CALL DGECO(A,LDA,N,IPVT,RCOND,Z) -C IF (RCOND IS TOO SMALL) GO TO ... -C DO 10 J = 1, P -C CALL DGESL(A,LDA,N,IPVT,C(1,J),0) -C 10 CONTINUE -C -C LINPACK. THIS VERSION DATED 08/14/78 . -C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. -C -C SUBROUTINES AND FUNCTIONS -C -C BLAS DAXPY,DDOT -C -C INTERNAL VARIABLES -C - DOUBLE PRECISION DDOT,T - INTEGER K,KB,L,NM1 -C - NM1 = N - 1 - IF (JOB .NE. 0) GO TO 50 -C -C JOB = 0 , KppSolve A * X = B -C FIRST KppSolve L*Y = B -C - IF (NM1 .LT. 1) GO TO 30 - DO 20 K = 1, NM1 - L = IPVT(K) - T = B(L) - IF (L .EQ. K) GO TO 10 - B(L) = B(K) - B(K) = T - 10 CONTINUE - CALL DAXPY(N-K,T,A(K+1,K),1,B(K+1),1) - 20 CONTINUE - 30 CONTINUE -C -C NOW KppSolve U*X = Y -C - DO 40 KB = 1, N - K = N + 1 - KB - B(K) = B(K)/A(K,K) - T = -B(K) - CALL DAXPY(K-1,T,A(1,K),1,B(1),1) - 40 CONTINUE - GO TO 100 - 50 CONTINUE -C -C JOB = NONZERO, KppSolve TRANS(A) * X = B -C FIRST KppSolve TRANS(U)*Y = B -C - DO 60 K = 1, N - T = DDOT(K-1,A(1,K),1,B(1),1) - B(K) = (B(K) - T)/A(K,K) - 60 CONTINUE -C -C NOW KppSolve TRANS(L)*X = Y -C - IF (NM1 .LT. 1) GO TO 90 - DO 80 KB = 1, NM1 - K = N - KB - B(K) = B(K) + DDOT(N-K,A(K+1,K),1,B(K+1),1) - L = IPVT(K) - IF (L .EQ. K) GO TO 70 - T = B(L) - B(L) = B(K) - B(K) = T - 70 CONTINUE - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE - RETURN - END - SUBROUTINE DGBFA(ABD,LDA,N,ML,MU,IPVT,INFO) - INTEGER LDA,N,ML,MU,IPVT(*),INFO - DOUBLE PRECISION ABD(LDA,*) -C -C DGBFA FACTORS A DOUBLE PRECISION BAND MATRIX BY ELIMINATION. -C -C DGBFA IS USUALLY CALLED BY DGBCO, BUT IT CAN BE CALLED -C DIRECTLY WITH A SAVING IN TIME IF RCOND IS NOT NEEDED. -C -C ON ENTRY -C -C ABD DOUBLE PRECISION(LDA, N) -C CONTAINS THE MATRIX IN BAND STORAGE. THE COLUMNS -C OF THE MATRIX ARE STORED IN THE COLUMNS OF ABD AND -C THE DIAGONALS OF THE MATRIX ARE STORED IN ROWS -C ML+1 THROUGH 2*ML+MU+1 OF ABD . -C SEE THE COMMENTS BELOW FOR DETAILS. -C -C LDA INTEGER -C THE LEADING DIMENSION OF THE ARRAY ABD . -C LDA MUST BE .GE. 2*ML + MU + 1 . -C -C N INTEGER -C THE ORDER OF THE ORIGINAL MATRIX. -C -C ML INTEGER -C NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL. -C 0 .LE. ML .LT. N . -C -C MU INTEGER -C NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL. -C 0 .LE. MU .LT. N . -C MORE EFFICIENT IF ML .LE. MU . -C ON RETURN -C -C ABD AN UPPER TRIANGULAR MATRIX IN BAND STORAGE AND -C THE MULTIPLIERS WHICH WERE USED TO OBTAIN IT. -C THE FACTORIZATION CAN BE WRITTEN A = L*U WHERE -C L IS A PRODUCT OF PERMUTATION AND UNIT LOWER -C TRIANGULAR MATRICES AND U IS UPPER TRIANGULAR. -C -C IPVT INTEGER(N) -C AN INTEGER VECTOR OF PIVOT INDICES. -C -C INFO INTEGER -C = 0 NORMAL VALUE. -C = K IF U(K,K) .EQ. 0.0 . THIS IS NOT AN ERROR -C CONDITION FOR THIS SUBROUTINE, BUT IT DOES -C INDICATE THAT DGBSL WILL DIVIDE BY ZERO IF -C CALLED. USE RCOND IN DGBCO FOR A RELIABLE -C INDICATION OF SINGULARITY. -C -C BAND STORAGE -C -C IF A IS A BAND MATRIX, THE FOLLOWING PROGRAM SEGMENT -C WILL SET UP THE INPUT. -C -C ML = (BAND WIDTH BELOW THE DIAGONAL) -C MU = (BAND WIDTH ABOVE THE DIAGONAL) -C M = ML + MU + 1 -C DO 20 J = 1, N -C I1 = MAX0(1, J-MU) -C I2 = MIN0(N, J+ML) -C DO 10 I = I1, I2 -C K = I - J + M -C ABD(K,J) = A(I,J) -C 10 CONTINUE -C 20 CONTINUE -C -C THIS USES ROWS ML+1 THROUGH 2*ML+MU+1 OF ABD . -C IN ADDITION, THE FIRST ML ROWS IN ABD ARE USED FOR -C ELEMENTS GENERATED DURING THE TRIANGULARIZATION. -C THE TOTAL NUMBER OF ROWS NEEDED IN ABD IS 2*ML+MU+1 . -C THE ML+MU BY ML+MU UPPER LEFT TRIANGLE AND THE -C ML BY ML LOWER RIGHT TRIANGLE ARE NOT REFERENCED. -C -C LINPACK. THIS VERSION DATED 08/14/78 . -C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. -C -C SUBROUTINES AND FUNCTIONS -C -C BLAS DAXPY,DSCAL,IDAMAX -C FORTRAN MAX0,MIN0 -C -C INTERNAL VARIABLES -C - DOUBLE PRECISION T - INTEGER I,IDAMAX,I0,J,JU,JZ,J0,J1,K,KP1,L,LM,M,MM,NM1 -C -C - M = ML + MU + 1 - INFO = 0 -C -C ZERO INITIAL FILL-IN COLUMNS -C - J0 = MU + 2 - J1 = MIN0(N,M) - 1 - IF (J1 .LT. J0) GO TO 30 - DO 20 JZ = J0, J1 - I0 = M + 1 - JZ - DO 10 I = I0, ML - ABD(I,JZ) = 0.0D0 - 10 CONTINUE - 20 CONTINUE - 30 CONTINUE - JZ = J1 - JU = 0 -C -C GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING -C - NM1 = N - 1 - IF (NM1 .LT. 1) GO TO 130 - DO 120 K = 1, NM1 - KP1 = K + 1 -C -C ZERO NEXT FILL-IN COLUMN -C - JZ = JZ + 1 - IF (JZ .GT. N) GO TO 50 - IF (ML .LT. 1) GO TO 50 - DO 40 I = 1, ML - ABD(I,JZ) = 0.0D0 - 40 CONTINUE - 50 CONTINUE -C -C FIND L = PIVOT INDEX -C - LM = MIN0(ML,N-K) - L = IDAMAX(LM+1,ABD(M,K),1) + M - 1 - IPVT(K) = L + K - M -C -C ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED -C - IF (ABD(L,K) .EQ. 0.0D0) GO TO 100 -C -C INTERCHANGE IF NECESSARY -C - IF (L .EQ. M) GO TO 60 - T = ABD(L,K) - ABD(L,K) = ABD(M,K) - ABD(M,K) = T - 60 CONTINUE -C -C COMPUTE MULTIPLIERS -C - T = -1.0D0/ABD(M,K) - CALL DSCAL(LM,T,ABD(M+1,K),1) -C -C ROW ELIMINATION WITH COLUMN INDEXING -C - JU = MIN0(MAX0(JU,MU+IPVT(K)),N) - MM = M - IF (JU .LT. KP1) GO TO 90 - DO 80 J = KP1, JU - L = L - 1 - MM = MM - 1 - T = ABD(L,J) - IF (L .EQ. MM) GO TO 70 - ABD(L,J) = ABD(MM,J) - ABD(MM,J) = T - 70 CONTINUE - CALL DAXPY(LM,T,ABD(M+1,K),1,ABD(MM+1,J),1) - 80 CONTINUE - 90 CONTINUE - GO TO 110 - 100 CONTINUE - INFO = K - 110 CONTINUE - 120 CONTINUE - 130 CONTINUE - IPVT(N) = N - IF (ABD(M,N) .EQ. 0.0D0) INFO = N - RETURN - END - SUBROUTINE DGBSL(ABD,LDA,N,ML,MU,IPVT,B,JOB) - INTEGER LDA,N,ML,MU,IPVT(*),JOB - DOUBLE PRECISION ABD(LDA,*),B(*) -C -C DGBSL KppSolveS THE DOUBLE PRECISION BAND SYSTEM -C A * X = B OR TRANS(A) * X = B -C USING THE FACTORS COMPUTED BY DGBCO OR DGBFA. -C -C ON ENTRY -C -C ABD DOUBLE PRECISION(LDA, N) -C THE OUTPUT FROM DGBCO OR DGBFA. -C -C LDA INTEGER -C THE LEADING DIMENSION OF THE ARRAY ABD . -C -C N INTEGER -C THE ORDER OF THE ORIGINAL MATRIX. -C -C ML INTEGER -C NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL. -C -C MU INTEGER -C NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL. -C -C IPVT INTEGER(N) -C THE PIVOT VECTOR FROM DGBCO OR DGBFA. -C -C B DOUBLE PRECISION(N) -C THE RIGHT HAND SIDE VECTOR. -C -C JOB INTEGER -C = 0 TO KppSolve A*X = B , -C = NONZERO TO KppSolve TRANS(A)*X = B , WHERE -C TRANS(A) IS THE TRANSPOSE. -C -C ON RETURN -C -C B THE SOLUTION VECTOR X . -C -C ERROR CONDITION -C -C A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A -C ZERO ON THE DIAGONAL. TECHNICALLY THIS INDICATES SINGULARITY -C BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER -C SETTING OF LDA . IT WILL NOT OCCUR IF THE SUBROUTINES ARE -C CALLED CORRECTLY AND IF DGBCO HAS SET RCOND .GT. 0.0 -C OR DGBFA HAS SET INFO .EQ. 0 . -C -C TO COMPUTE INVERSE(A) * C WHERE C IS A MATRIX -C WITH P COLUMNS -C CALL DGBCO(ABD,LDA,N,ML,MU,IPVT,RCOND,Z) -C IF (RCOND IS TOO SMALL) GO TO ... -C DO 10 J = 1, P -C CALL DGBSL(ABD,LDA,N,ML,MU,IPVT,C(1,J),0) -C 10 CONTINUE -C -C LINPACK. THIS VERSION DATED 08/14/78 . -C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. -C -C SUBROUTINES AND FUNCTIONS -C -C BLAS DAXPY,DDOT -C FORTRAN MIN0 -C -C INTERNAL VARIABLES -C - DOUBLE PRECISION DDOT,T - INTEGER K,KB,L,LA,LB,LM,M,NM1 -C - M = MU + ML + 1 - NM1 = N - 1 - IF (JOB .NE. 0) GO TO 50 -C -C JOB = 0 , KppSolve A * X = B -C FIRST KppSolve L*Y = B -C - IF (ML .EQ. 0) GO TO 30 - IF (NM1 .LT. 1) GO TO 30 - DO 20 K = 1, NM1 - LM = MIN0(ML,N-K) - L = IPVT(K) - T = B(L) - IF (L .EQ. K) GO TO 10 - B(L) = B(K) - B(K) = T - 10 CONTINUE - CALL DAXPY(LM,T,ABD(M+1,K),1,B(K+1),1) - 20 CONTINUE - 30 CONTINUE -C -C NOW KppSolve U*X = Y -C - DO 40 KB = 1, N - K = N + 1 - KB - B(K) = B(K)/ABD(M,K) - LM = MIN0(K,M) - 1 - LA = M - LM - LB = K - LM - T = -B(K) - CALL DAXPY(LM,T,ABD(LA,K),1,B(LB),1) - 40 CONTINUE - GO TO 100 - 50 CONTINUE -C -C JOB = NONZERO, KppSolve TRANS(A) * X = B -C FIRST KppSolve TRANS(U)*Y = B -C - DO 60 K = 1, N - LM = MIN0(K,M) - 1 - LA = M - LM - LB = K - LM - T = DDOT(LM,ABD(LA,K),1,B(LB),1) - B(K) = (B(K) - T)/ABD(M,K) - 60 CONTINUE -C -C NOW KppSolve TRANS(L)*X = Y -C - IF (ML .EQ. 0) GO TO 90 - IF (NM1 .LT. 1) GO TO 90 - DO 80 KB = 1, NM1 - K = N - KB - LM = MIN0(ML,N-K) - B(K) = B(K) + DDOT(LM,ABD(M+1,K),1,B(K+1),1) - L = IPVT(K) - IF (L .EQ. K) GO TO 70 - T = B(L) - B(L) = B(K) - B(K) = T - 70 CONTINUE - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE - RETURN - END - SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) -C -C CONSTANT TIMES A VECTOR PLUS A VECTOR. -C USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE. -C JACK DONGARRA, LINPACK, 3/11/78. -C - DOUBLE PRECISION DX(*),DY(*),DA - INTEGER I,INCX,INCY,IX,IY,M,MP1,N -C - IF(N.LE.0)RETURN - IF (DA .EQ. 0.0D0) RETURN - IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 -C -C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS -C NOT EQUAL TO 1 -C - IX = 1 - IY = 1 - IF(INCX.LT.0)IX = (-N+1)*INCX + 1 - IF(INCY.LT.0)IY = (-N+1)*INCY + 1 - DO 10 I = 1,N - DY(IY) = DY(IY) + DA*DX(IX) - IX = IX + INCX - IY = IY + INCY - 10 CONTINUE - RETURN -C -C CODE FOR BOTH INCREMENTS EQUAL TO 1 -C -C -C CLEAN-UP LOOP -C - 20 M = MOD(N,4) - IF( M .EQ. 0 ) GO TO 40 - DO 30 I = 1,M - DY(I) = DY(I) + DA*DX(I) - 30 CONTINUE - IF( N .LT. 4 ) RETURN - 40 MP1 = M + 1 - DO 50 I = MP1,N,4 - DY(I) = DY(I) + DA*DX(I) - DY(I + 1) = DY(I + 1) + DA*DX(I + 1) - DY(I + 2) = DY(I + 2) + DA*DX(I + 2) - DY(I + 3) = DY(I + 3) + DA*DX(I + 3) - 50 CONTINUE - RETURN - END - SUBROUTINE DSCAL(N,DA,DX,INCX) -C -C SCALES A VECTOR BY A CONSTANT. -C USES UNROLLED LOOPS FOR INCREMENT EQUAL TO ONE. -C JACK DONGARRA, LINPACK, 3/11/78. -C - DOUBLE PRECISION DA,DX(*) - INTEGER I,INCX,M,MP1,N,NINCX -C - IF(N.LE.0)RETURN - IF(INCX.EQ.1)GO TO 20 -C -C CODE FOR INCREMENT NOT EQUAL TO 1 -* -C - NINCX = N*INCX - DO 10 I = 1,NINCX,INCX - DX(I) = DA*DX(I) - 10 CONTINUE - RETURN -C -C CODE FOR INCREMENT EQUAL TO 1 -C -C -C CLEAN-UP LOOP -C - 20 M = MOD(N,5) - IF( M .EQ. 0 ) GO TO 40 - DO 30 I = 1,M - DX(I) = DA*DX(I) - 30 CONTINUE - IF( N .LT. 5 ) RETURN - 40 MP1 = M + 1 - DO 50 I = MP1,N,5 - DX(I) = DA*DX(I) - DX(I + 1) = DA*DX(I + 1) - DX(I + 2) = DA*DX(I + 2) - DX(I + 3) = DA*DX(I + 3) - DX(I + 4) = DA*DX(I + 4) - 50 CONTINUE - RETURN - END - DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) -C -C FORMS THE DOT PRODUCT OF TWO VECTORS. -C USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE. -C JACK DONGARRA, LINPACK, 3/11/78. -C - DOUBLE PRECISION DX(*),DY(*),DTEMP - INTEGER I,INCX,INCY,IX,IY,M,MP1,N -C - DDOT = 0.0D0 - DTEMP = 0.0D0 - IF(N.LE.0)RETURN - IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 -C -C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS -C NOT EQUAL TO 1 -C - IX = 1 - IY = 1 - IF(INCX.LT.0)IX = (-N+1)*INCX + 1 - IF(INCY.LT.0)IY = (-N+1)*INCY + 1 - DO 10 I = 1,N - DTEMP = DTEMP + DX(IX)*DY(IY) - IX = IX + INCX - IY = IY + INCY - 10 CONTINUE - DDOT = DTEMP - RETURN -C -C CODE FOR BOTH INCREMENTS EQUAL TO 1 -C -C -C CLEAN-UP LOOP -C - 20 M = MOD(N,5) - IF( M .EQ. 0 ) GO TO 40 - DO 30 I = 1,M - DTEMP = DTEMP + DX(I)*DY(I) - 30 CONTINUE - IF( N .LT. 5 ) GO TO 60 - 40 MP1 = M + 1 - DO 50 I = MP1,N,5 - DTEMP = DTEMP + DX(I)*DY(I) + DX(I + 1)*DY(I + 1) + - * DX(I + 2)*DY(I + 2) + DX(I + 3)*DY(I + 3) + DX(I + 4)*DY(I + 4) - 50 CONTINUE - 60 DDOT = DTEMP - RETURN - END - INTEGER FUNCTION IDAMAX(N,DX,INCX) -C -C FINDS THE INDEX OF ELEMENT HAVING MAX. ABSOLUTE VALUE. -C JACK DONGARRA, LINPACK, 3/11/78. -C - DOUBLE PRECISION DX(*),DMAX - INTEGER I,INCX,IX,N -C - IDAMAX = 0 - IF( N .LT. 1 ) RETURN - IDAMAX = 1 - IF(N.EQ.1)RETURN - IF(INCX.EQ.1)GO TO 20 -C -C CODE FOR INCREMENT NOT EQUAL TO 1 -C - IX = 1 - DMAX = DABS(DX(1)) - IX = IX + INCX - DO 10 I = 2,N - IF(DABS(DX(IX)).LE.DMAX) GO TO 5 - IDAMAX = I - DMAX = DABS(DX(IX)) - 5 IX = IX + INCX - 10 CONTINUE - RETURN -C -C CODE FOR INCREMENT EQUAL TO 1 -C - 20 DMAX = DABS(DX(1)) - DO 30 I = 2,N - IF(DABS(DX(I)).LE.DMAX) GO TO 30 - IDAMAX = I - DMAX = DABS(DX(I)) - 30 CONTINUE - RETURN - END - DOUBLE PRECISION FUNCTION D1MACH (IDUM) - INTEGER IDUM -C----------------------------------------------------------------------- -C THIS ROUTINE COMPUTES THE UNIT ROUNDOFF OF THE MACHINE IN DOUBLE -C PRECISION. THIS IS DEFINED AS THE SMALLEST POSITIVE MACHINE NUMBER -C U SUCH THAT 1.0D0 + U .NE. 1.0D0 (IN DOUBLE PRECISION). -C----------------------------------------------------------------------- - DOUBLE PRECISION U, COMP - U = 1.0D0 - 10 U = U*0.5D0 - COMP = 1.0D0 + U - IF (COMP .NE. 1.0D0) GO TO 10 - D1MACH = U*2.0D0 - RETURN -C----------------------- END OF FUNCTION D1MACH ------------------------ - END - SUBROUTINE XERR (MSG, NERR, IERT, NI, I1, I2, NR, R1, R2) - INTEGER NERR, IERT, NI, I1, I2, NR, - 1 LUN, LUNIT, MESFLG - DOUBLE PRECISION R1, R2 - CHARACTER*(*) MSG -C------------------------------------------------------------------- -C -C ALL ARGUMENTS ARE INPUT ARGUMENTS. -C -C MSG = THE MESSAGE (CHARACTER VARIABLE) -C NERR = THE ERROR NUMBER (NOT USED). -C IERT = THE ERROR TYPE.. -C 1 MEANS RECOVERABLE (CONTROL RETURNS TO CALLER). -C 2 MEANS FATAL (RUN IS ABORTED--SEE NOTE BELOW). -C NI = NUMBER OF INTEGERS (0, 1, OR 2) TO BE PRINTED WITH MESSAGE. -C I1,I2 = INTEGERS TO BE PRINTED, DEPENDING ON NI. -C NR = NUMBER OF REALS (0, 1, OR 2) TO BE PRINTED WITH MESSAGE. -C R1,R2 = REALS TO BE PRINTED, DEPENDING ON NR. -C -C NOTES: -C 1. THE DIMENSION OF MSG IS ASSUMED TO BE AT MOST 60. -C (MULTI-LINE MESSAGES ARE GENERATED BY REPEATED CALLS.) -C 2. IF IERT = 2, CONTROL PASSES TO THE STATEMENT STOP -C TO ABORT THE RUN. THIS STATEMENT MAY BE MACHINE-DEPENDENT. -C 3. R1 AND R2 ARE ASSUMED TO BE IN DOUBLE PRECISION AND ARE PRINTED -C IN D21.13 FORMAT. -C 4. THE COMMON BLOCK /EH0001/ BELOW IS DATA-LOADED (A MACHINE- -C DEPENDENT FEATURE) WITH DEFAULT VALUES. -C THIS BLOCK IS NEEDED FOR PROPER RETENTION OF PARAMETERS USED BY -C THIS ROUTINE WHICH THE USER CAN RESET BY CALLING XSETF OR XSETUN. -C THE VARIABLES IN THIS BLOCK ARE AS FOLLOWS.. -C MESFLG = PRINT CONTROL FLAG.. -C 1 MEANS PRINT ALL MESSAGES (THE DEFAULT). -C 0 MEANS NO PRINTING. -C LUNIT = LOGICAL UNIT NUMBER FOR MESSAGES. -C THE DEFAULT IS 6 (MACHINE-DEPENDENT). -C 5. TO CHANGE THE DEFAULT OUTPUT UNIT, CHANGE THE DATA STATEMENT -C IN THE BLOCK DATA SUBPROGRAM BELOW. -C -C FOR A DIFFERENT RUN-ABORT COMMAND, CHANGE THE STATEMENT FOLLOWING -C STATEMENT 100 AT THE END. -C----------------------------------------------------------------------- - COMMON /EH0001/ MESFLG, LUNIT - IF (MESFLG .EQ. 0) GO TO 100 -C GET LOGICAL UNIT NUMBER. --------------------------------------------- - LUN = LUNIT -C WRITE THE MESSAGE. --------------------------------------------------- - WRITE (LUN, 10) MSG - 10 FORMAT(1X,A) -C----------------------------------------------------------------------- - IF (NI .EQ. 1) WRITE (LUN, 20) I1 - 20 FORMAT(6X,'IN ABOVE MESSAGE, I1 = ',I10) - IF (NI .EQ. 2) WRITE (LUN, 30) I1,I2 - 30 FORMAT(6X,'IN ABOVE MESSAGE, I1 = ',I10,3X,'I2 = ',I10) - IF (NR .EQ. 1) WRITE (LUN, 40) R1 - 40 FORMAT(6X,'IN ABOVE MESSAGE, R1 = ',D21.13) - IF (NR .EQ. 2) WRITE (LUN, 50) R1,R2 - 50 FORMAT(6X,'IN ABOVE, R1 = ',D21.13,3X,'R2 = ',D21.13) -C ABORT THE RUN IF IERT = 2. ------------------------------------------- - 100 IF (IERT .NE. 2) RETURN - STOP -C----------------------- END OF SUBROUTINE XERR ---------------------- - END - SUBROUTINE XSETF (MFLAG) -C -C THIS ROUTINE RESETS THE PRINT CONTROL FLAG MFLAG. -C - INTEGER MFLAG, MESFLG, LUNIT - COMMON /EH0001/ MESFLG, LUNIT -C - IF (MFLAG .EQ. 0 .OR. MFLAG .EQ. 1) MESFLG = MFLAG - RETURN -C----------------------- END OF SUBROUTINE XSETF ----------------------- - END - SUBROUTINE XSETUN (LUN) -C -C THIS ROUTINE RESETS THE LOGICAL UNIT NUMBER FOR MESSAGES. -C - INTEGER LUN, MESFLG, LUNIT - COMMON /EH0001/ MESFLG, LUNIT -C - IF (LUN .GT. 0) LUNIT = LUN - RETURN -C----------------------- END OF SUBROUTINE XSETUN ---------------------- - END - BLOCK DATA -C----------------------------------------------------------------------- -C THIS DATA SUBPROGRAM LOADS VARIABLES INTO THE INTERNAL COMMON -C BLOCKS USED BY ODESSA AND ITS VARIANTS. THE VARIABLES ARE -C DEFINED AS FOLLOWS.. -C ILLIN = COUNTER FOR THE NUMBER OF CONSECUTIVE TIMES THE PACKAGE -C WAS CALLED WITH ILLEGAL INPUT. THE RUN IS STOPPED WHEN -C ILLIN REACHES 5. -C NTREP = COUNTER FOR THE NUMBER OF CONSECUTIVE TIMES THE PACKAGE -C WAS CALLED WITH ISTATE = 1 AND TOUT = T. THE RUN IS -C STOPPED WHEN NTREP REACHES 5. -C MESFLG = FLAG TO CONTROL PRINTING OF ERROR MESSAGES. 1 MEANS PRINT, -C 0 MEANS NO PRINTING. -C LUNIT = DEFAULT VALUE OF LOGICAL UNIT NUMBER FOR PRINTING OF ERROR -C MESSAGES. -C----------------------------------------------------------------------- - INTEGER ILLIN, IDUMA, NTREP, IDUMB, IOWNS, ICOMM, MESFLG, LUNIT - DOUBLE PRECISION ROWND, ROWNS, RCOMM - COMMON /ODE001/ ROWND, ROWNS(173), RCOMM(45), - 1 ILLIN, IDUMA(10), NTREP, IDUMB(2), IOWNS(4), ICOMM(21) - COMMON /EH0001/ MESFLG, LUNIT - DATA ILLIN/0/, NTREP/0/ - DATA MESFLG/1/, LUNIT/6/ -C -C------------------------ END OF BLOCK DATA ---------------------------- - END -C----------------------------------------------------------------------- -C INSTRUCTIONS FOR INSTALLING THE ODESSA PACKAGE. (see @ below.) -C -C ODESSA is an enhanced version of the widely disseminated ODE solver -C LSODE, and as such retains the same properties regarding portability. -C The notes below, adapted from the installation instructions for LSODE, -C are intended to facilitate the installation of the ODESSA package in -C the user's software library. -C -C 1. Both a single and a double precision version of ODESSA are -C provided in this release. It is expected that most users will -C utilize the double precision version, except in the case of -C extended word-length computers. Most routines used by ODESSA -C are named the same regardless of whether they are single or -C double precision. The exceptions are the LINPAK and BLAS -C routines that follow the LINPAK/BLAS naming conventions, i.e. -C D--- for a double precision routine, and S--- for a single -C precision routine. Thus, care should be taken if both single -C and double precision versions are stored in the same library. -C -C 2. Several routines in ODESSA have the same names as the LSODE -C routines from which they were derived, although they contain -C different code. These are: INTDY, STODE, PREPJ, SVCOM, and -C RSCOM. If ODESSA is added to a subroutine library of which -C LSODE is already a member, these routine names must be changed -C in one of the two programs. Also see the note regarding BLOCK -C DATA subroutines below. -C -C 3. In many cases, ODESSA uses unaltered LSODE routines and -C common library routines that may already reside on your system. -C The installation of ODESSA should be done so that identical routines -C are shared rather than kept as duplicate copies. -C a. Normally, the user calls only subroutine ODESSA, but for optional -C capabilities the user may also CALL XSETUN, XSETF, SVCOM, RSCOM, -C or INTDY, as described in Part II of the Full Description in the -C User Documentation (ODESSA.DOC, see below). Except for INTDY, -C none of these are called from within the package. -C b. Two routines, EWSET and VNORM, are optionally replaceable by the -C user if the package version is unsuitable. Hence, the install- -C ation of the package should be done so that the user's version -C for either routine overrides the package version. -C c. The function routine D1MACH is provided to compute the unit -C roundoff of the machine and precision in use, in a manner com- -C patible with machine parameter routines developed at Bell Lab- -C oratories. If such a routine has already been installed on -C your system, the version supplied here may be discarded. -C d. Linear algebraic systems are solved with routines from the -C LINPACK collection, in conjunction with routines from the Basic -C Linear Algebra module collection (BLAS). In double precision, -C the names are DGEFA, DGESL, DGBFA, and DGBSL (from LINPACK), and -C DAXPY, DSCAL, IDAMAX, and DDOT (from BLAS). If these routines -C have already been installed on your system, copies supplied with -C ODESSA may be discarded. The single precision versions of these -C routines are used in the single precision version. -C -C 4. There are four integer variables, in the two labeled COMMON -C blocks /ODE001/ and /EH0001/, which need to be loaded with DATA -C statements. They can vary during execution, and are in common to -C assure their retention between calls. This is legal in ANSI Fortran -C only if done in a BLOCK DATA subprogram, and this package has a -C BLOCK DATA for this purpose. However, BLOCK DATA subprograms can be -C difficult to install in libraries, and many compilers allow such DATA -C statements in subroutines. If your system allows this, the location -C of the DATA statements are just after the initial type and common -C declarations in subroutines ODESSA and XERR. In ODESSA, ILLIN and -C NTREP are DATA-loaded as 0. In XERR, MESFLG is loaded as 1 and -C LUNIT is loaded as the appropriate default logical unit number. -C -C 5. The ODESSA package contains subscript expressions which may not -C be accepted by some compilers. Subscripts of the form I + J, I - J, -C etc., occur in various routines. If any of these forms are -C unacceptable to your compiler, an extra line of code setting the -C subscript to a dummy integer value should be added for each subscipt. -C -C 6. User documentation is provided in a two-level structure -C to accommmodate both the casual and serious user. The novice or -C casual user should need to read only the Summary of Usage and the -C Example Problem located at the beginning of the documentation. More -C experienced users, requiring the full set of available options, -C should read the Full Description which follows the Example Problem. -C -C 7. The user documentation may need corrections in the following ways: -C a. If subroutine names have been changed to avoid conflicts between -C the LSODE and ODESSA packages, the corresponding name changes -C should be made in the documentation. -C b. In the Summary of Usage, and in the description of XSETUN under -C Part II of the Full Description, the default logical unit number -C should be corrected if it is not 6. -C c. In the Summary of Usage, users should be instructed to execute -C CALL XSETF(1) before the first CALL to ODESSA, if this is neces- -C sary for proper error message handling. (see note 2(e) above.) -C d. In the description of the subroutines DF and JAC in the Summary -C of Usage and in Part I of the Full Description, it is stated -C that dummy names may be passed if these two routines are not user -C supplied. Your system may require the user to supply a dummy -C subroutine instead. -C e. The ODESSA package treats the arguments NEQ, RTOL, and ATOL as -C arrays (possibly of length 1), while the usage documentation -C states that these arguments may be either arrays or scalars. -C If your system does not allow such a mismatch, then the -C documentation should be changed to reflect this. -C 8. A demonstration program is provided with the package for -C verification. -C -C -C Jorge R. Leis and Mark A. Kramer -C Department of Chemical Engineering -C Massachusetts Institute of Technology -C Cambridge, Massachusetts 02139 -C U.S.A. -C -C Current address of J.R. Leis (Jan. 1988): -C -C Shell Development Company -C Westhollow Research Center -C Houston, TX -C -C @ Adapted from 'Instructions for Installing LSODE', written by -C Alan C. Hindmarsh, Mathematics & Statistics Division, L-316, -C Lawrence Livermore National Laboratory, Livermore, CA. 94550 diff --git a/boxmox/int/kpp_radau5.def b/boxmox/int/kpp_radau5.def deleted file mode 100644 index e7d0bf54dc5b3f11c57cf537c2ed97d37ccde18f..0000000000000000000000000000000000000000 --- a/boxmox/int/kpp_radau5.def +++ /dev/null @@ -1,5 +0,0 @@ -#FUNCTION AGGREGATE -#JACOBIAN SPARSE_LU_ROW -#DOUBLE ON -#INTFILE kpp_radau5 - diff --git a/boxmox/int/kpp_sdirk4.def b/boxmox/int/kpp_sdirk4.def deleted file mode 100644 index 6cf1158efbad1cbe450d0daa38ae5eb5a7b9d8f0..0000000000000000000000000000000000000000 --- a/boxmox/int/kpp_sdirk4.def +++ /dev/null @@ -1,20 +0,0 @@ - -#FUNCTION AGGREGATE -#JACOBIAN SPARSE_LU_ROW - -#DOUBLE ON -#INTFILE kpp_sdirk4 - -#INLINE F77_GLOBAL - REAL*8 STEPSTART - COMMON /GDATA/ STEPSTART -#ENDINLINE - -#INLINE F77_INIT - STEPMIN=0.0001 - STEPMAX=3600. - STEPSTART=STEPMIN -#ENDINLINE - - - diff --git a/boxmox/int/kpp_sdirk4.f b/boxmox/int/kpp_sdirk4.f deleted file mode 100644 index e04fe7d9a8e6fdae42e56c89888abb8acb2b4806..0000000000000000000000000000000000000000 --- a/boxmox/int/kpp_sdirk4.f +++ /dev/null @@ -1,705 +0,0 @@ - SUBROUTINE INTEGRATE( TIN, TOUT ) - - IMPLICIT KPP_REAL (A-H,O-Z) - INCLUDE 'KPP_ROOT_Parameters.h' - INCLUDE 'KPP_ROOT_Global.h' - -C TIN - Start Time - KPP_REAL TIN -C TOUT - End Time - KPP_REAL TOUT - INTEGER i - - PARAMETER (LWORK=2*NVAR*NVAR+12*NVAR+7,LIWORK=2*NVAR+7) - PARAMETER (LRCONT=5*NVAR+2) - - KPP_REAL WORK(LWORK) - INTEGER IWORK(LIWORK) - COMMON /CONT/ ICONT(4),RCONT(LRCONT) - EXTERNAL FUNC_CHEM,JAC_CHEM - - ITOL=1 ! --- VECTOR TOLERANCES - IJAC=1 ! --- COMPUTE THE JACOBIAN ANALYTICALLY - IMAS=0 ! --- DIFFERENTIAL EQUATION IS IN EXPLICIT FORM - - DO i=1,20 - IWORK(i) = 0 - WORK(i) = 0.D0 - ENDDO - - IWORK(3) = 8 - - CALL ATMSDIRK(NVAR,FUNC_CHEM,TIN,VAR,TOUT,STEPMIN, - & RTOL,ATOL,ITOL, - & JAC_CHEM ,IJAC, FUNC_CHEM ,IMAS, - & WORK,LWORK,IWORK,LIWORK,LRCONT,IDID) - - IF (IDID.LT.0) THEN - print *,'ATMSDIRK: Unsucessfull exit at T=', - & TIN,' (IDID=',IDID,')' - ENDIF - - RETURN - END - - - SUBROUTINE ATMSDIRK(N,FCN,X,Y,XEND,H, - & RelTol,AbsTol,ITOL, - & JAC ,IJAC, MAS ,IMAS, - & WORK,LWORK,IWORK,LIWORK,LRCONT,IDID) -C ---------------------------------------------------------- -C *** *** *** *** *** *** *** *** *** *** *** *** *** -C DECLARATIONS -C *** *** *** *** *** *** *** *** *** *** *** *** *** - IMPLICIT KPP_REAL (A-H,O-Z) - DIMENSION Y(N),AbsTol(1),RelTol(1),WORK(LWORK),IWORK(LIWORK) - LOGICAL IMPLCT,JBAND,ARRET - EXTERNAL FCN,JAC,MAS - COMMON/STAT/NFCN,NJAC,NSTEP,NACCPT,NREJCT,NDEC,NSOL - -C *** *** *** *** *** *** *** -C SETTING THE PARAMETERS -C *** *** *** *** *** *** *** - NFCN=0 - NJAC=0 - NSTEP=0 - NACCPT=0 - NREJCT=0 - NDEC=0 - NSOL=0 - ARRET=.FALSE. -C -------- SWITCH FOR TRANSFORMATION OF JACOBIAN TO HESS_CHEM FORM --- - NHESS1 = 0 ! ADRIAN -C -------- NMAX , THE MAXIMAL NUMBER OF STEPS ----- - IF(IWORK(2).EQ.0)THEN - NMAX=100000 - ELSE - NMAX=IWORK(2) - IF(NMAX.LE.0)THEN - WRITE(6,*)' WRONG INPUT IWORK(2)=',IWORK(2) - ARRET=.TRUE. - END IF - END IF -C -------- NIT MAXIMAL NUMBER OF NEWTON ITERATIONS - IF(IWORK(3).EQ.0)THEN - NIT=8 - ELSE - NIT=IWORK(3) - IF(NIT.LE.0)THEN - WRITE(6,*)' CURIOUS INPUT IWORK(3)=',IWORK(3) - ARRET=.TRUE. - END IF - END IF -C -------- METH SWITCH FOR THE COEFFICIENTS OF THE METHOD - METH = 2 -C -------- UROUND SMALLEST NUMBER SATISFYING 1.D0+UROUND>1.D0 - IF(WORK(1).EQ.0.D0)THEN - UROUND=1.D-16 - ELSE - UROUND=WORK(1) - IF(UROUND.LE.1.D-19.OR.UROUND.GE.1.D0)THEN - WRITE(6,*)' COEFFICIENTS HAVE 20 DIGITS, UROUND=',WORK(1) - ARRET=.TRUE. - END IF - END IF -C --------- SAFE SAFETY FACTOR IN STEP SIZE PREDICTION - IF(WORK(2).EQ.0.D0)THEN - SAFE=0.9D0 - ELSE - SAFE=WORK(2) - IF(SAFE.LE..001D0.OR.SAFE.GE.1.D0)THEN - WRITE(6,*)' CURIOUS INPUT FOR WORK(2)=',WORK(2) - ARRET=.TRUE. - END IF - END IF -C ------ THET DECIDES WHETHER THE JACOBIAN SHOULD BE RECOMPUTED; - IF(WORK(3).EQ.0.D0)THEN - THET=0.001D0 - ELSE - THET=WORK(3) - END IF -C --- FNEWT STOPPING CRIERION FOR NEWTON'S METHOD, USUALLY CHOSEN <1. - IF(WORK(4).EQ.0.D0)THEN - FNEWT=0.03D0 - ELSE - FNEWT=WORK(4) - END IF -C --- QUOT1 AND QUOT2: IF QUOT1 < HNEW/HOLD < QUOT2, STEP SIZE = CONST. - IF(WORK(5).EQ.0.D0)THEN - QUOT1=1.D0 - ELSE - QUOT1=WORK(5) - END IF - IF(WORK(6).EQ.0.D0)THEN - QUOT2=1.2D0 - ELSE - QUOT2=WORK(6) - END IF -C -------- MAXIMAL STEP SIZE - IF(WORK(7).EQ.0.D0)THEN - HMAX=XEND-X - ELSE - HMAX=WORK(7) - END IF -C --------- CHECK IF TOLERANCES ARE O.K. - IF (ITOL.EQ.0) THEN - IF (AbsTol(1).LE.0.D0.OR.RelTol(1).LE.10.D0*UROUND) THEN - WRITE (6,*) ' TOLERANCES ARE TOO SMALL' - ARRET=.TRUE. - END IF - ELSE - DO 15 I=1,N - IF (AbsTol(I).LE.0.D0.OR.RelTol(I).LE.10.D0*UROUND) THEN - WRITE (6,*) ' TOLERANCES(',I,') ARE TOO SMALL' - ARRET=.TRUE. - END IF - 15 CONTINUE - END IF - -C *** *** *** *** *** *** *** *** *** *** *** *** *** -C COMPUTATION OF ARRAY ENTRIES -C *** *** *** *** *** *** *** *** *** *** *** *** *** -C ---- IMPLICIT, BANDED OR NOT ? - IMPLCT=IMAS.NE.0 - ARRET=.FALSE. -C -------- COMPUTATION OF THE ROW-DIMENSIONS OF THE 2-ARRAYS --- -C -- JACOBIAN - LDJAC=N -C -- MATRIX E FOR LINEAR ALGEBRA - LDE=N -C -- MASS MATRIX - IF (IMPLCT) THEN - print *,'IMPLCT 1' - ELSE - LDMAS=0 - END IF - LDMAS2=MAX(1,LDMAS) - -C ------- PREPARE THE ENTRY-POINTS FOR THE ARRAYS IN WORK ----- - IEYHAT=8 - IEZ=IEYHAT+N - IEY0=IEZ+N - IEZ1=IEY0+N - IEZ2=IEZ1+N - IEZ3=IEZ2+N - IEZ4=IEZ3+N - IEZ5=IEZ4+N - IESCAL=IEZ5+N - IEF1=IESCAL+N - IEG1=IEF1+N - IEH1=IEG1+N - IEJAC=IEH1+N - IEMAS=IEJAC+N*LDJAC - IEE=IEMAS+N*LDMAS - -C ------ TOTAL STORAGE REQUIREMENT ----------- - ISTORE=IEE+N*LDE-1 - IF(ISTORE.GT.LWORK)THEN - WRITE(6,*)' INSUFFICIENT STORAGE FOR WORK, MIN. LWORK=',ISTORE - ARRET=.TRUE. - END IF -C ------- ENTRY POINTS FOR INTEGER WORKSPACE ----- - IEIP=5 - IEHES=IEIP+N -C --------- TOTAL REQUIREMENT --------------- - ISTORE=IEHES+N-1 - IF(ISTORE.GT.LIWORK)THEN - WRITE(6,*)' INSUFF. STORAGE FOR IWORK, MIN. LIWORK=',ISTORE - ARRET=.TRUE. - END IF -C --------- CONTROL OF LENGTH OF COMMON BLOCK "CONT" ------- - IF(LRCONT.LT.(5*N+2))THEN - WRITE(6,*)' INSUFF. STORAGE FOR RCONT, MIN. LRCONT=',5*N+2 - ARRET=.TRUE. - END IF -C ------ WHEN A FAIL HAS OCCURED, WE RETURN WITH IDID=-1 - IF (ARRET) THEN - IDID=-1 - RETURN - END IF -C -------- CALL TO CORE INTEGRATOR ------------ - CALL SDICOR(N,FCN,X,Y,XEND,HMAX,H,RelTol,AbsTol,ITOL, - & JAC,IJAC,MLJAC,MUJAC,MAS,MLMAS,MUMAS,IOUT,IDID, - & NMAX,UROUND,SAFE,THET,FNEWT,QUOT1,QUOT2,NIT,METH,NHESS1, - & IMPLCT,JBAND,LDJAC,LDE,LDMAS2, - & WORK(IEYHAT),WORK(IEZ),WORK(IEY0),WORK(IEZ1),WORK(IEZ2), - & WORK(IEZ3),WORK(IEZ4),WORK(IEZ5),WORK(IESCAL),WORK(IEF1), - & WORK(IEG1),WORK(IEH1),WORK(IEJAC),WORK(IEE), - & WORK(IEMAS),IWORK(IEIP),IWORK(IEHES)) -C ----------- RETURN ----------- - RETURN - END -C -C -C -C ----- ... AND HERE IS THE CORE INTEGRATOR ---------- -C - SUBROUTINE SDICOR(N,FCN,X,Y,XEND,HMAX,H,RelTol,AbsTol,ITOL, - & JAC,IJAC,MLJAC,MUJAC,MAS,MLMAS,MUMAS,IOUT,IDID, - & NMAX,UROUND,SAFE,THET,FNEWT,QUOT1,QUOT2,NIT,METH,NHESS1, - & IMPLCT,BANDED,LDJAC,LE,LDMAS, - & YHAT,Z,Y0,Z1,Z2,Z3,Z4,Z5,SCAL,F1,G1,H1,FJAC,E,FMAS,IP,IPHES) -C ---------------------------------------------------------- -C CORE INTEGRATOR FOR SDIRK4 -C PARAMETERS SAME AS IN SDIRK4 WITH WORKSPACE ADDED -C ---------------------------------------------------------- -C DECLARATIONS -C ---------------------------------------------------------- - IMPLICIT KPP_REAL (A-H,O-Z) - INCLUDE 'KPP_ROOT_Parameters.h' - INCLUDE 'KPP_ROOT_Sparse.h' - KPP_REAL Y(N),YHAT(N),Z(N),Y0(N),Z1(N),Z2(N),Z3(N),Z4(N),Z5(N) - KPP_REAL SCAL(N),F1(N),G1(N),H1(N) - KPP_REAL FJAC(LU_NONZERO),E(LU_NONZERO),FMAS(LDMAS,N) - KPP_REAL AbsTol(1),RelTol(1) - INTEGER IP(N),IPHES(N) - LOGICAL REJECT,FIRST,IMPLCT,BANDED,CALJAC,NEWTRE - COMMON /CONT/NN,NN2,NN3,NN4,XOLD,HSOL,CONT(5*NVAR) - COMMON/STAT/NFCN,NJAC,NSTEP,NACCPT,NREJCT,NDEC,NSOL - EXTERNAL MAS, FCN, JAC - -C *** *** *** *** *** *** *** -C INITIALISATIONS -C *** *** *** *** *** *** *** - -C --------- DUPLIFY N FOR COMMON BLOCK CONT ----- - NN=N - NN2=2*N - NN3=3*N - NN4=4*N - -C ------- COMPUTE MASS MATRIX FOR IMPLICIT CASE ---------- - IF(IMPLCT) CALL MAS(N,FMAS,LDMAS) - -C ---------- CONSTANTS --------- - MBDIAG=MUMAS+1 - IF (METH.EQ.2) THEN -C ---------- METHOD WITH GAMMA = 4/15 --------------- - GAMMA=4.0D0/15.0D0 - C2=23.0D0/30.0D0 - C3=17.0D0/30.0D0 - C4=2881.0D0/28965.0D0+GAMMA - ALPH21=15.0D0/8.0D0 - ALPH31=1577061.0D0/922880.0D0 - ALPH32=-23427.0D0/115360.0D0 - ALPH41=647163682356923881.0D0/2414496535205978880.0D0 - ALPH42=-593512117011179.0D0/3245291041943520.0D0 - ALPH43=559907973726451.0D0/1886325418129671.0D0 - ALPH51=724545451.0D0/796538880.0D0 - ALPH52=-830832077.0D0/267298560.0D0 - ALPH53=30957577.0D0/2509272.0D0 - ALPH54=-69863904375173.0D0/6212571137048.0D0 - E1=7752107607.0D0/11393456128.0D0 - E2=-17881415427.0D0/11470078208.0D0 - E3=2433277665.0D0/179459416.0D0 - E4=-96203066666797.0D0/6212571137048.0D0 - D11= 24.74416644927758D0 - D12= -4.325375951824688D0 - D13= 41.39683763286316D0 - D14= -61.04144619901784D0 - D15= -3.391332232917013D0 - D21= -51.98245719616925D0 - D22= 10.52501981094525D0 - D23= -154.2067922191855D0 - D24= 214.3082125319825D0 - D25= 14.71166018088679D0 - D31= 33.14347947522142D0 - D32= -19.72986789558523D0 - D33= 230.4878502285804D0 - D34= -287.6629744338197D0 - D35= -18.99932366302254D0 - D41= -5.905188728329743D0 - D42= 13.53022403646467D0 - D43= -117.6778956422581D0 - D44= 134.3962081008550D0 - D45= 8.678995715052762D0 - ETA1=23.D0/8.D0 - ANU1= 0.9838473040915402D0 - ANU2= 0.3969226768377252D0 - AMU1= 0.6563374010466914D0 - AMU3= 0.3372498196189311D0 - ELSE - PRINT *, 'WRONG CHOICE OF ' - END IF - POSNEG=SIGN(1.D0,XEND-X) - HMAX1=MIN(ABS(HMAX),ABS(XEND-X)) - IF (ABS(H).LE.10.D0*UROUND) H=1.0D-6 - H=MIN(ABS(H),HMAX1) - H=SIGN(H,POSNEG) - HOLD=H - CFAC=SAFE*(1+2*NIT) - NEWTRE=.FALSE. - REJECT=.FALSE. - FIRST=.TRUE. - FACCO1=1.D0 - FACCO2=1.D0 - FACCO3=1.D0 - FACCO4=1.D0 - FACCO5=1.D0 - NSING=0 - XOLD=X - IF (ITOL.EQ.0) THEN - DO 8 I=1,N - 8 SCAL(I)=1.D0 / ( AbsTol(1)+RelTol(1)*DABS(Y(I)) ) - ELSE - DO 9 I=1,N - 9 SCAL(I)=1.D0 / ( AbsTol(I)+RelTol(I)*DABS(Y(I)) ) - END IF - -C --- BASIC INTEGRATION STEP - 10 CONTINUE - -C *** *** *** *** *** *** *** -C COMPUTATION OF THE JACOBIAN -C *** *** *** *** *** *** *** - NJAC=NJAC+1 - CALL JAC(N,X,Y,FJAC) - CALJAC=.TRUE. - 20 CONTINUE - -C *** *** *** *** *** *** *** -C COMPUTE THE MATRIX E AND ITS DECOMPOSITION -C *** *** *** *** *** *** *** - FAC1=1.D0/(H*GAMMA) - IF (IMPLCT) THEN - print *, 'IMPLCT 4' - ELSE ! EXPLICIT SYSTEM -C --- THE MATRIX E (MAS=IDENTITY, JACOBIAN A FULL MATRIX) -c DO 526 J=1,N -c DO 525 I=1,N -c 525 E(I,J)=-FJAC(I,J) -c 526 E(J,J)=E(J,J)+FAC1 -c CALL DEC(N,LE,E,IP,IER) - DO K=1,LU_NONZERO - E(K) = -FJAC(K) - END DO - DO I=1,N - IDG = LU_DIAG(I) - E(IDG) = E(IDG) + FAC1 - END DO - CALL KppDecomp ( E, IER) - - IF (IER.NE.0) GOTO 79 - END IF - NDEC=NDEC+1 - 30 CONTINUE - - IF (NSTEP.GT.NMAX.OR.X+.1D0*H.EQ.X.OR.ABS(H).LE.UROUND) GOTO 79 - XPH=X+H -C --- LOOP FOR THE 5 STAGES - FACCO1=DMAX1(FACCO1,UROUND)**0.8D0 - FACCO2=DMAX1(FACCO2,UROUND)**0.8D0 - FACCO3=DMAX1(FACCO3,UROUND)**0.8D0 - FACCO4=DMAX1(FACCO4,UROUND)**0.8D0 - FACCO5=DMAX1(FACCO5,UROUND)**0.8D0 - -C *** *** *** *** *** *** *** -C STARTING VALUES FOR NEWTON ITERATION -C *** *** *** *** *** *** *** - DO 59 ISTAGE=1,5 - IF (ISTAGE.EQ.1) THEN - XCH=X+GAMMA*H - IF (FIRST.OR.NEWTRE) THEN - DO 132 I=1,N - 132 Z(I)=0.D0 - ELSE - S=1.D0+GAMMA*H/HOLD - DO 232 I=1,N -c 232 Z(I) = 0.D0 - 232 Z(I)=S*(CONT(I+NN)+S*(CONT(I+NN2)+S*(CONT(I+NN3) - & +S*CONT(I+NN4))))-YHAT(I) - - END IF - DO 31 I=1,N - 31 G1(I)=0.D0 - FACCON=FACCO1 - END IF - IF (ISTAGE.EQ.2) THEN - XCH=X+C2*H - DO 131 I=1,N - Z1I=Z1(I) - Z(I)=ETA1*Z1I - 131 G1(I)=ALPH21*Z1I - FACCON=FACCO2 - END IF - IF (ISTAGE.EQ.3) THEN - XCH=X+C3*H - DO 231 I=1,N - Z1I=Z1(I) - Z2I=Z2(I) - Z(I)=ANU1*Z1I+ANU2*Z2I - 231 G1(I)=ALPH31*Z1I+ALPH32*Z2I - FACCON=FACCO3 - END IF - IF (ISTAGE.EQ.4) THEN - XCH=X+C4*H - DO 331 I=1,N - Z1I=Z1(I) - Z3I=Z3(I) - Z(I)=AMU1*Z1I+AMU3*Z3I - 331 G1(I)=ALPH41*Z1I+ALPH42*Z2(I)+ALPH43*Z3I - FACCON=FACCO4 - END IF - IF (ISTAGE.EQ.5) THEN - XCH=XPH - DO 431 I=1,N - Z1I=Z1(I) - Z2I=Z2(I) - Z3I=Z3(I) - Z4I=Z4(I) - Z(I)=E1*Z1I+E2*Z2I+E3*Z3I+E4*Z4I - YHAT(I)=Z(I) - 431 G1(I)=ALPH51*Z1I+ALPH52*Z2I+ALPH53*Z3I+ALPH54*Z4I - FACCON=FACCO5 - END IF - - - -C *** *** *** *** *** *** *** *** *** *** *** -C LOOP FOR THE SIMPLIFIED NEWTON ITERATION -C *** *** *** *** *** *** *** *** *** *** *** - NEWT=0 - THETA=ABS(THET) - IF (REJECT) THETA=2*ABS(THET) - 40 CONTINUE - IF (NEWT.GE.NIT) THEN - H=H/2.D0 - REJECT=.TRUE. - NEWTRE=.TRUE. - IF (CALJAC) GOTO 20 - GOTO 10 - END IF - -C --- COMPUTE THE RIGHT-HAND SIDE - DO 41 I=1,N - H1(I)=G1(I)-Z(I) - 41 CONT(I)=Y(I)+Z(I) - CALL FCN(N,XCH,CONT,F1) - NFCN=NFCN+1 - -C --- KppSolve THE LINEAR SYSTEMS - IF (IMPLCT) THEN - print *, 'IMPLCT 2' - ELSE - DO 345 I=1,N - 345 F1(I)=H1(I)*FAC1+F1(I) -C CALL SOL(N,LE,E,F1,IP) - CALL KppSolve(E, F1) - END IF - NEWT=NEWT+1 - DYNO=0.D0 -C --- NORM 2 --- - DO 57 I=1,N - 57 DYNO=DYNO+(F1(I)*SCAL(I))**2 - DYNO=DSQRT(DYNO/N) -C --- NORM INF --- -C DO 57 I=1,N -C 57 DYNO=DMAX1( DYNO, DABS(F1(I)*SCAL(I)) ) - - -C --- BAD CONVERGENCE OR NUMBER OF ITERATIONS TO LARGE - IF (NEWT.GE.2.AND.NEWT.LT.NIT) THEN - THETA=DYNO/DYNOLD - IF (THETA.LT.0.99D0) THEN - FACCON=THETA/(1.0D0-THETA) - DYTH=FACCON*DYNO*THETA**(NIT-1-NEWT) - QNEWT=DMAX1(1.0D-4,DMIN1(16.0D0,DYTH/FNEWT)) - IF (QNEWT.GE.1.0D0) THEN - H=.8D0*H*QNEWT**(-1.0D0/(NIT-NEWT)) - REJECT=.TRUE. - NEWTRE=.TRUE. - IF (CALJAC) GOTO 20 - GOTO 10 - END IF - ELSE - NEWTRE=.TRUE. - GOTO 78 - END IF - END IF - DYNOLD=DYNO - DO 58 I=1,N - 58 Z(I)=Z(I)+F1(I) - NSOL=NSOL+1 - IF (FACCON*DYNO.GT.FNEWT) GOTO 40 - -C --- END OF SIMPILFIED NEWTON - IF (ISTAGE.EQ.1) THEN - DO I=1,N - Z1(I) = Z(I) - END DO - FACCO1=FACCON - END IF - IF (ISTAGE.EQ.2) THEN - DO I=1,N - Z2(I) = Z(I) - END DO - FACCO2=FACCON - END IF - IF (ISTAGE.EQ.3) THEN - DO I=1,N - Z3(I) = Z(I) - END DO - FACCO3=FACCON - END IF - IF (ISTAGE.EQ.4) THEN - DO I=1,N - Z4(I) = Z(I) - END DO - FACCO4=FACCON - END IF - IF (ISTAGE.EQ.5) THEN - DO I=1,N - Z5(I) = Z(I) - END DO - FACCO5=FACCON - END IF - 59 CONTINUE - - -C *** *** *** *** *** *** *** -C ERROR ESTIMATION -C *** *** *** *** *** *** *** - NSTEP=NSTEP+1 - IF (IMPLCT) THEN - print *,'IMPLCT 3' - ELSE - DO 461 I=1,N - 461 CONT(I)=FAC1*(Z5(I)-YHAT(I)) - END IF - - CALL KppSolve(E, CONT) - - ERR=0.D0 -C ---- NORM 2 --- - DO 64 I=1,N - 64 ERR=ERR+(CONT(I)*SCAL(I))**2 - ERR=DMAX1(DSQRT(ERR/N),1.D-10) - -C ---- NORM INF --- -C DO 64 I=1,N -c 64 ERR=DMAX1( ERR, DABS( CONT(I)*SCAL(I) ) ) - -C --- COMPUTATION OF HNEW -C --- WE REQUIRE .25<=HNEW/H<=10. - FAC=DMIN1(SAFE,CFAC/(NEWT+2*NIT)) - QUOT=DMAX1(.25D0,DMIN1(10.D0,(ERR)**.25D0/FAC)) - HNEW= H/QUOT - -C *** *** *** *** *** *** *** -C IS THE ERROR SMALL ENOUGH ? -C *** *** *** *** *** *** *** - IF (ERR.LT.1.D0) THEN -C --- STEP IS ACCEPTED - FIRST=.FALSE. - NACCPT=NACCPT+1 - HOLD=H - XOLD=X -C --- COEFFICIENTS FOR CONTINUOUS SOLUTION - DO 74 I=1,N - Z1I=Z1(I) - Z2I=Z2(I) - Z3I=Z3(I) - Z4I=Z4(I) - Z5I=Z5(I) - CONT(I)=Y(I) - Y(I)=Y(I)+Z5I - CONT(I+NN) =D11*Z1I+D12*Z2I+D13*Z3I+D14*Z4I+D15*Z5I - CONT(I+NN2)=D21*Z1I+D22*Z2I+D23*Z3I+D24*Z4I+D25*Z5I - CONT(I+NN3)=D31*Z1I+D32*Z2I+D33*Z3I+D34*Z4I+D35*Z5I - CONT(I+NN4)=D41*Z1I+D42*Z2I+D43*Z3I+D44*Z4I+D45*Z5I - YHAT(I)=Z5I - IF (ITOL.EQ.0) THEN - SCAL(I)=1.D0/( AbsTol(1)+RelTol(1)*DABS(Y(I)) ) - ELSE - SCAL(I)=1.D0/( AbsTol(I)+RelTol(I)*DABS(Y(I)) ) - END IF - 74 CONTINUE - X=XPH - CALJAC=.FALSE. - IF ((X-XEND)*POSNEG+UROUND.GT.0.D0) THEN - H=HOPT - IDID=1 - RETURN - END IF - IF (IJAC.EQ.0) CALL FCN(N,X,Y,Y0) - NFCN=NFCN+1 - HNEW=POSNEG*DMIN1(DABS(HNEW),HMAX1) - HOPT=HNEW - IF (REJECT) HNEW=POSNEG*DMIN1(DABS(HNEW),DABS(H)) - REJECT=.FALSE. - NEWTRE=.FALSE. - IF ((X+HNEW/QUOT1-XEND)*POSNEG.GT.0.D0) THEN - H=XEND-X - ELSE - QT=HNEW/H - IF (THETA.LE.THET.AND.QT.GE.QUOT1.AND.QT.LE.QUOT2) GOTO 30 - H = HNEW - END IF - IF (THETA.LE.THET) GOTO 20 - GOTO 10 - - ELSE -C --- STEP IS REJECTED - REJECT=.TRUE. - IF (FIRST) THEN - H=H/10.D0 - ELSE - H=HNEW - END IF - IF (NACCPT.GE.1) NREJCT=NREJCT+1 - IF (CALJAC) GOTO 20 - GOTO 10 - END IF - -C --- UNEXPECTED STEP-REJECTION - 78 CONTINUE - IF (IER.NE.0) THEN - WRITE (6,*) ' MATRIX IS SINGULAR, IER=',IER,' X=',X,' H=',H - NSING=NSING+1 - IF (NSING.GE.6) GOTO 79 - END IF - H=H*0.5D0 - REJECT=.TRUE. - IF (CALJAC) GOTO 20 - GOTO 10 - -C --- FAIL EXIT - 79 WRITE (6,979) X,H,IER - 979 FORMAT(' EXIT OF SDIRK4 AT X=',D14.7,' H=',D14.7,' IER=',I4) - IDID=-1 - RETURN - END -C - - - SUBROUTINE FUNC_CHEM(N, T, Y, P) - INCLUDE 'KPP_ROOT_Parameters.h' - INCLUDE 'KPP_ROOT_Global.h' - INTEGER N - KPP_REAL T, Told - KPP_REAL Y(NVAR), P(NVAR) - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Fun( Y, FIX, RCONST, P ) - TIME = Told - RETURN - END - - - SUBROUTINE JAC_CHEM(N, T, Y, J) - INCLUDE 'KPP_ROOT_Parameters.h' - INCLUDE 'KPP_ROOT_Global.h' - INTEGER N - KPP_REAL Told, T - KPP_REAL Y(NVAR), J(LU_NONZERO) - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Jac_SP( Y, FIX, RCONST, J ) - TIME = Told - RETURN - END - diff --git a/boxmox/int/kpp_seulex.def b/boxmox/int/kpp_seulex.def deleted file mode 100644 index 16dee74d10738617bbec34e97dd963b219e094e0..0000000000000000000000000000000000000000 --- a/boxmox/int/kpp_seulex.def +++ /dev/null @@ -1,23 +0,0 @@ - -#FUNCTION AGGREGATE -#JACOBIAN SPARSE_LU_ROW - -#DOUBLE ON -#INTFILE kpp_seulex - -#INLINE F77_GLOBAL - INTEGER Autonomous - COMMON /INTGDATA/ Autonomous - REAL*8 STEPSTART - COMMON /GDATA/ STEPSTART -#ENDINLINE - -#INLINE F77_INIT - STEPMIN=0.0001 - STEPMAX=3600. - Autonomous = 0 - STEPSTART=STEPMIN -#ENDINLINE - - - diff --git a/boxmox/int/kpp_seulex.f b/boxmox/int/kpp_seulex.f deleted file mode 100644 index 98b286ccf5d7be1483bdd6615758843bb7f00b4a..0000000000000000000000000000000000000000 --- a/boxmox/int/kpp_seulex.f +++ /dev/null @@ -1,1174 +0,0 @@ - SUBROUTINE INTEGRATE( TIN, TOUT ) - - IMPLICIT KPP_REAL (A-H,O-Z) - INCLUDE 'KPP_ROOT_Parameters.h' - INCLUDE 'KPP_ROOT_Global.h' - -C TIN - Start Time - KPP_REAL TIN -C TOUT - End Time - KPP_REAL TOUT - INTEGER i - - PARAMETER (KM=12,KM2=2+KM*(KM+3)/2,NRDENS=NVAR) - PARAMETER (LWORK=2*NVAR*NVAR+(KM+8)*NVAR+4*KM+20+KM2*NRDENS) - PARAMETER (LIWORK=2*NVAR+KM+20+NRDENS) - - KPP_REAL WORK(LWORK) - INTEGER IWORK(LIWORK) - EXTERNAL FUNC_CHEM,JAC_CHEM - - ITOL=1 ! --- VECTOR TOLERANCES - IJAC=1 ! --- COMPUTE THE JACOBIAN ANALYTICALLY - MLJAC=NVAR ! --- JACOBIAN IS A FULL MATRIX - MUJAC=NVAR ! --- JACOBIAN IS A FULL MATRIX - IMAS=0 ! --- DIFFERENTIAL EQUATION IS IN EXPLICIT FORM - IOUT=0 ! --- OUTPUT ROUTINE IS NOT USED DURING INTEGRATION - IDFX=0 ! --- INTERNAL TIME DERIVATIVE - - DO i=1,20 - IWORK(i) = 0 - WORK(i) = 0.D0 - ENDDO - - CALL ATMSEULEX(NVAR,FUNC_CHEM,Autonomous,TIN,VAR,TOUT, - & STEPMIN,RTOL,ATOL,ITOL, - & JAC_CHEM,IJAC,MLJAC,MUJAC, - & FUNC_CHEM,IMAS,MLJAC,MUJAC, - & WORK,LWORK,IWORK,LIWORK,IDID) - - IF (IDID.LT.0) THEN - print *,'ATMSEULEX: Unsucessfull exit at T=', - & TIN,' (IDID=',IDID,')' - ENDIF - - RETURN - END - - - SUBROUTINE ATMSEULEX(N,FCN,IFCN,X,Y,XEND,H, - & RelTol,AbsTol,ITOL, - & JAC ,IJAC,MLJAC,MUJAC, - & MAS,IMAS,MLMAS,MUMAS, - & WORK,LWORK,IWORK,LIWORK,IDID) -C ---------------------------------------------------------- -C NUMERICAL SOLUTION OF A STIFF (OR DIFFERENTIAL ALGEBRAIC) -C SYSTEM OF FIRST 0RDER ORDINARY DIFFERENTIAL EQUATIONS MY'=F(X,Y). -C THIS IS AN EXTRAPOLATION-ALGORITHM, BASED ON THE -C LINEARLY IMPLICIT EULER METHOD (WITH STEP SIZE CONTROL -C AND ORDER SELECTION). -C -C AUTHORS: E. HAIRER AND G. WANNER -C UNIVERSITE DE GENEVE, DEPT. DE MATHEMATIQUES -C CH-1211 GENEVE 24, SWITZERLAND -C E-MAIL: HAIRER@DIVSUN.UNIGE.CH, WANNER@DIVSUN.UNIGE.CH -C INCLUSION OF DENSE OUTPUT BY E. HAIRER AND A. OSTERMANN -C -C THIS CODE IS PART OF THE BOOK: -C E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL -C EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS. -C SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS 14, -C SPRINGER-VERLAG (1991) -C -C VERSION OF SEPTEMBER 30, 1995 -C -C INPUT PARAMETERS -C ---------------- -C N DIMENSION OF THE SYSTEM -C -C FCN NAME (EXTERNAL) OF SUBROUTINE COMPUTING THE -C VALUE OF F(X,Y): -C SUBROUTINE FCN(N,X,Y,F) -C KPP_REAL X,Y(N),F(N) -C F(1)=... ETC. -C RPAR, IPAR (SEE BELOW) -C -C IFCN GIVES INFORMATION ON FCN: -C IFCN=0: F(X,Y) INDEPENDENT OF X (AUTONOMOUS) -C IFCN=1: F(X,Y) MAY DEPEND ON X (NON-AUTONOMOUS) -C -C X INITIAL X-VALUE -C -C Y(N) INITIAL VALUES FOR Y -C -C XEND FINAL X-VALUE (XEND-X MAY BE POSITIVE OR NEGATIVE) -C -C H INITIAL STEP SIZE GUESS; -C FOR STIFF EQUATIONS WITH INITIAL TRANSIENT, -C H=1.D0/(NORM OF F'), USUALLY 1.D-2 OR 1.D-3, IS GOOD. -C THIS CHOICE IS NOT VERY IMPORTANT, THE CODE QUICKLY -C ADAPTS ITS STEP SIZE (IF H=0.D0, THE CODE PUTS H=1.D-6). -C -C RelTol,AbsTol RELATIVE AND ABSOLUTE ERROR TOLERANCES. THEY -C CAN BE BOTH SCALARS OR ELSE BOTH VECTORS OF LENGTH N. -C -C ITOL SWITCH FOR RelTol AND AbsTol: -C ITOL=0: BOTH RelTol AND AbsTol ARE SCALARS. -C THE CODE KEEPS, ROUGHLY, THE LOCAL ERROR OF -C Y(I) BELOW RelTol*ABS(Y(I))+AbsTol -C ITOL=1: BOTH RelTol AND AbsTol ARE VECTORS. -C THE CODE KEEPS THE LOCAL ERROR OF Y(I) BELOW -C RelTol(I)*ABS(Y(I))+AbsTol(I). -C -C JAC NAME (EXTERNAL) OF THE SUBROUTINE WHICH COMPUTES -C THE PARTIAL DERIVATIVES OF F(X,Y) WITH RESPECT TO Y -C (THIS ROUTINE IS ONLY CALLED IF IJAC=1; SUPPLY -C A DUMMY SUBROUTINE IN THE CASE IJAC=0). -C FOR IJAC=1, THIS SUBROUTINE MUST HAVE THE FORM -C SUBROUTINE JAC(N,X,Y,DFY,LDFY) -C KPP_REAL X,Y(N),DFY(LDFY,N) -C DFY(1,1)= ... -C LDFY, THE COLOMN-LENGTH OF THE ARRAY, IS -C FURNISHED BY THE CALLING PROGRAM. -C IF (MLJAC.EQ.N) THE JACOBIAN IS SUPPOSED TO -C BE FULL AND THE PARTIAL DERIVATIVES ARE -C STORED IN DFY AS -C DFY(I,J) = PARTIAL F(I) / PARTIAL Y(J) -C ELSE, THE JACOBIAN IS TAKEN AS BANDED AND -C THE PARTIAL DERIVATIVES ARE STORED -C DIAGONAL-WISE AS -C DFY(I-J+MUJAC+1,J) = PARTIAL F(I) / PARTIAL Y(J). -C -C IJAC SWITCH FOR THE COMPUTATION OF THE JACOBIAN: -C IJAC=0: JACOBIAN IS COMPUTED INTERNALLY BY FINITE -C DIFFERENCES, SUBROUTINE "JAC" IS NEVER CALLED. -C IJAC=1: JACOBIAN IS SUPPLIED BY SUBROUTINE JAC. -C -C MLJAC SWITCH FOR THE BANDED STRUCTURE OF THE JACOBIAN: -C MLJAC=N: JACOBIAN IS A FULL MATRIX. THE LINEAR -C ALGEBRA IS DONE BY FULL-MATRIX GAUSS-ELIMINATION. -C 0<=MLJAC= NUMBER OF NON-ZERO DIAGONALS BELOW -C THE MAIN DIAGONAL). -C -C MUJAC UPPER BANDWITH OF JACOBIAN MATRIX (>= NUMBER OF NON- -C ZERO DIAGONALS ABOVE THE MAIN DIAGONAL). -C NEED NOT BE DEFINED IF MLJAC=N. -C -C ---- MAS,IMAS,MLMAS, AND MUMAS HAVE ANALOG MEANINGS ----- -C ---- FOR THE "MASS MATRIX" (THE MATRIX "M" OF SECTION IV.8): - -C -C MAS NAME (EXTERNAL) OF SUBROUTINE COMPUTING THE MASS- -C MATRIX M. -C IF IMAS=0, THIS MATRIX IS ASSUMED TO BE THE IDENTITY -C MATRIX AND NEEDS NOT TO BE DEFINED; -C SUPPLY A DUMMY SUBROUTINE IN THIS CASE. -C IF IMAS=1, THE SUBROUTINE MAS IS OF THE FORM -C SUBROUTINE MAS(N,AM,LMAS) -C KPP_REAL AM(LMAS,N) -C AM(1,1)= .... -C IF (MLMAS.EQ.N) THE MASS-MATRIX IS STORED -C AS FULL MATRIX LIKE -C AM(I,J) = M(I,J) -C ELSE, THE MATRIX IS TAKEN AS BANDED AND STORED -C DIAGONAL-WISE AS -C AM(I-J+MUMAS+1,J) = M(I,J). -C -C IMAS GIVES INFORMATION ON THE MASS-MATRIX: -C IMAS=0: M IS SUPPOSED TO BE THE IDENTITY -C MATRIX, MAS IS NEVER CALLED. -C IMAS=1: MASS-MATRIX IS SUPPLIED. -C -C MLMAS SWITCH FOR THE BANDED STRUCTURE OF THE MASS-MATRIX: -C MLMAS=N: THE FULL MATRIX CASE. THE LINEAR -C ALGEBRA IS DONE BY FULL-MATRIX GAUSS-ELIMINATION. -C 0<=MLMAS= NUMBER OF NON-ZERO DIAGONALS BELOW -C THE MAIN DIAGONAL). -C MLMAS IS SUPPOSED TO BE .LE. MLJAC. -C -C MUMAS UPPER BANDWITH OF MASS-MATRIX (>= NUMBER OF NON- -C ZERO DIAGONALS ABOVE THE MAIN DIAGONAL). -C NEED NOT BE DEFINED IF MLMAS=N. -C MUMAS IS SUPPOSED TO BE .LE. MUJAC. -C -C SOLOUT NAME (EXTERNAL) OF SUBROUTINE PROVIDING THE -C NUMERICAL SOLUTION DURING INTEGRATION. -C IF IOUT>=1, IT IS CALLED AFTER EVERY SUCCESSFUL STEP. -C SUPPLY A DUMMY SUBROUTINE IF IOUT=0. -C IT MUST HAVE THE FORM -C SUBROUTINE SOLOUT (NR,XOLD,X,Y,RC,LRC,IC,LIC,N, -C RPAR,IPAR,IRTRN) -C KPP_REAL X,Y(N),RC(LRC),IC(LIC) -C .... -C SOLOUT FURNISHES THE SOLUTION "Y" AT THE NR-TH -C GRID-POINT "X" (THEREBY THE INITIAL VALUE IS -C THE FIRST GRID-POINT). -C "XOLD" IS THE PRECEEDING GRID-POINT. -C "IRTRN" SERVES TO INTERRUPT THE INTEGRATION. IF IRTRN -C IS SET <0, SEULEX RETURNS TO THE CALLING PROGRAM. -C DO NOT CHANGE THE ENTRIES OF RC(LRC),IC(LIC)! -C -C ----- CONTINUOUS OUTPUT (IF IOUT=2): ----- -C DURING CALLS TO "SOLOUT", A CONTINUOUS SOLUTION -C FOR THE INTERVAL [XOLD,X] IS AVAILABLE THROUGH -C THE KPP_REAL FUNCTION -C >>> CONTEX(I,S,RC,LRC,IC,LIC) <<< -C WHICH PROVIDES AN APPROXIMATION TO THE I-TH -C COMPONENT OF THE SOLUTION AT THE POINT S. THE VALUE -C S SHOULD LIE IN THE INTERVAL [XOLD,X]. -C -C IOUT GIVES INFORMATION ON THE SUBROUTINE SOLOUT: -C IOUT=0: SUBROUTINE IS NEVER CALLED -C IOUT=1: SUBROUTINE IS USED FOR OUTPUT -C IOUT=2: DENSE OUTPUT IS PERFORMED IN SOLOUT -C -C WORK ARRAY OF WORKING SPACE OF LENGTH "LWORK". -C SERVES AS WORKING SPACE FOR ALL VECTORS AND MATRICES. -C "LWORK" MUST BE AT LEAST -C N*(LJAC+LMAS+LE1+KM+8)+4*KM+20+KM2*NRDENS -C WHERE -C KM2=2+KM*(KM+3)/2 AND NRDENS=IWORK(6) (SEE BELOW) -C AND -C LJAC=N IF MLJAC=N (FULL JACOBIAN) -C LJAC=MLJAC+MUJAC+1 IF MLJAC0 THEN "LWORK" MUST BE AT LEAST -C N*(LJAC+KM+8)+(N-M1)*(LMAS+LE1)+4*KM+20+KM2*NRDENS -C WHERE IN THE DEFINITIONS OF LJAC, LMAS AND LE1 THE -C NUMBER N CAN BE REPLACED BY N-M1. -C -C LWORK DECLARED LENGTH OF ARRAY "WORK". -C -C IWORK INTEGER WORKING SPACE OF LENGTH "LIWORK". -C "LIWORK" MUST BE AT LEAST 2*N+KM+20+NRDENS. -C -C LIWORK DECLARED LENGTH OF ARRAY "IWORK". -C -C RPAR, IPAR REAL AND INTEGER PARAMETERS (OR PARAMETER ARRAYS) WHICH -C CAN BE USED FOR COMMUNICATION BETWEEN YOUR CALLING -C PROGRAM AND THE FCN, JAC, MAS, SOLOUT SUBROUTINES. -C -C ---------------------------------------------------------------------- -C -C SOPHISTICATED SETTING OF PARAMETERS -C ----------------------------------- -C SEVERAL PARAMETERS OF THE CODE ARE TUNED TO MAKE IT WORK -C WELL. THEY MAY BE DEFINED BY SETTING WORK(1),..,WORK(13) -C AS WELL AS IWORK(1),..,IWORK(4) DIFFERENT FROM ZERO. -C FOR ZERO INPUT, THE CODE CHOOSES DEFAULT VALUES: -C -C IWORK(1) IF IWORK(1).NE.0, THE CODE TRANSFORMS THE JACOBIAN -C MATRIX TO HESSENBERG FORM. THIS IS PARTICULARLY -C ADVANTAGEOUS FOR LARGE SYSTEMS WITH FULL JACOBIAN. -C IT DOES NOT WORK FOR BANDED JACOBIAN (MLJAC0 SOME OF THE INPUT PARAMETERS HAVE DIFFERENT MEANINGS: -C - JAC: ONLY THE ELEMENTS OF THE NON-TRIVIAL PART OF THE -C JACOBIAN HAVE TO BE STORED -C IF (MLJAC.EQ.N-M1) THE JACOBIAN IS SUPPOSED TO BE FULL -C DFY(I,J) = PARTIAL F(I+M1) / PARTIAL Y(J) -C FOR I=1,N-M1 AND J=1,N. -C ELSE, THE JACOBIAN IS BANDED ( M1 = M2 * MM ) -C DFY(I-J+MUJAC+1,J+K*M2) = PARTIAL F(I+M1) / PARTIAL Y(J+K*M2) -C FOR I=1,MLJAC+MUJAC+1 AND J=1,M2 AND K=0,MM. -C - MLJAC: MLJAC=N-M1: IF THE NON-TRIVIAL PART OF THE JACOBIAN IS FULL -C 0<=MLJAC OUTPUT ROUTINE IS NOT USED DURING INTEGRATION - - ! if optional parameters are given, and if they are >0, - ! they overwrite the default settings - IF (PRESENT(ICNTRL_U)) ICNTRL(:) = ICNTRL_U(:) - IF (PRESENT(RCNTRL_U)) RCNTRL(:) = RCNTRL_U(:) - !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~----- - - - CALL ATMSEULEX(NVAR,TIN,TOUT,VAR,H,RTOL,ATOL, & - RCNTRL,ICNTRL,RSTATUS,ISTATUS,IERR ) - Ntotal = Ntotal + Nstp -!!$ PRINT*,'NSTEPS=',Nstp,' (',Ntotal,') T=',TIN - - - Nfun = Nfun + ISTATUS(1) - Njac = Njac + ISTATUS(2) - Nstp = Nstp + ISTATUS(3) - Nacc = Nacc + ISTATUS(4) - Nrej = Nrej + ISTATUS(5) - Ndec = Ndec + ISTATUS(6) - Nsol = Nsol + ISTATUS(7) - - ! if optional parameters are given for output - ! use them to store information in them - IF (PRESENT(ISTATUS_U)) THEN - ISTATUS_U(:) = 0 - ISTATUS_U(1) = Nfun ! function calls - ISTATUS_U(2) = Njac ! jacobian calls - ISTATUS_U(3) = Nstp ! steps - ISTATUS_U(4) = Nacc ! accepted steps - ISTATUS_U(5) = Nrej ! rejected steps (except at the beginning) - ISTATUS_U(6) = Ndec ! LU decompositions - ISTATUS_U(7) = Nsol ! forward/backward substitutions - ENDIF - IF (PRESENT(RSTATUS_U)) THEN - RSTATUS_U(:) = 0. - RSTATUS_U(1) = TOUT ! final time - ENDIF - IF (PRESENT(IERR_U)) IERR_U = IERR - -! mz_rs_20050716: IERR is returned to the user who then decides what to do -! about it, i.e. either stop the run or ignore it. -!!$ IF (IERR < 0) THEN -!!$ PRINT *,'SEULEX: Unsuccessful exit at T=', TIN,' (IERR=',IERR,')' -!!$ STOP -!!$ ENDIF - - END SUBROUTINE INTEGRATE - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ATMSEULEX( N,Tinitial,Tfinal,Y,H,RelTol,AbsTol, & - RCNTRL,ICNTRL,RSTATUS,ISTATUS,IERR ) - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NUMERICAL SOLUTION OF A STIFF (OR DIFFERENTIAL ALGEBRAIC) -! SYSTEM OF FIRST 0RDER ORDINARY DIFFERENTIAL EQUATIONS MY'=F(T,Y). -! THIS IS AN EXTRAPOLATION-ALGORITHM, BASED ON THE -! LINEARLY IMPLICIT EULER METHOD (WITH STEP SIZE CONTROL -! AND ORDER SELECTION). -! -! AUTHORS: E. HAIRER AND G. WANNER -! UNIVERSITE DE GENEVE, DEPT. DE MATHEMATIQUES -! CH-1211 GENEVE 24, SWITZERLAND -! E-MAIL: HAIRER@DIVSUN.UNIGE.CH, WANNER@DIVSUN.UNIGE.CH -! INCLUSION OF DENSE OUTPUT BY E. HAIRER AND A. OSTERMANN -! -! 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) -! -! VERSION OF SEPTEMBER 30, 1995 -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -! INPUT PARAMETERS -! ---------------- -! N DIMENSION OF THE SYSTEM -! -! T INITIAL T-VALUE -! -! Y(N) INITIAL VALUES FOR Y -! -! Tend FINAL T-VALUE (Tend-T 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-2 OR 1.D-3, IS GOOD. -! THIS CHOICE IS NOT VERY IMPORTANT, THE CODE QUICKLY -! ADAPTS ITS STEP SIZE (IF H=0.D0, THE CODE PUTS H=1.D-6 -! -! RelTol,AbsTol RELATIVE AND ABSOLUTE ERROR TOLERANCES. THEY -! CAN BE BOTH SCALARS OR ELSE BOTH VECTORS OF LENGTH N. -! -! JAC NAME (EXTERNAL) OF THE SUBROUTINE WHICH COMPUTES -! THE PARTIAL DERIVATIVES OF F(T,Y) WITH RESPECT TO Y -! -! 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,TOLD,T,Y,RC,LRC,IC,LIC,N, -! RPAR,IPAR,IRTRN) -! KPP_REAL T,Y(N),RC(LRC),IC(LIC) -! .... -! SOLOUT FURNISHES THE SOLUTION "Y" AT THE NR-TH -! GRID-POINT "T" (THEREBY THE INITIAL VALUE IS -! THE FIRST GRID-POINT). -! "TOLD" IS THE PRECEEDING GRID-POINT. -! "IRTRN" SERVES TO INTERRUPT THE INTEGRATION. IF IRTRN -! IS SET <0, SEULEX RETURNS TO THE CALLING PROGRAM. -! DO NOT CHANGE THE ENTRIES OF RC(LRC),IC(LIC)! -! -! ----- CONTINUOUS OUTPUT (IF IOUT=2): ----- -! DURING CALLS TO "SOLOUT", A CONTINUOUS SOLUTION -! FOR THE INTERVAL [TOLD,T] IS AVAILABLE THROUGH -! THE KPP_REAL FUNCTION -! >>> CONTEX(I,S,RC,LRC,IC,LIC) <<< -! WHICH PROVIDES AN APPROXIMATION TO THE I-TH -! COMPONENT OF THE SOLUTION AT THE POINT S. THE VALUE -! S SHOULD LIE IN THE INTERVAL [TOLD,T]. -! -! IOUT GIVES INFORMATION ON THE SUBROUTINE SOLOUT: -! IOUT=0: SUBROUTINE IS NEVER CALLED -! IOUT=1: SUBROUTINE IS USED FOR OUTPUT -! IOUT=2: DENSE OUTPUT IS PERFORMED IN SOLOUT -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -! SOPHISTICATED SETTING OF PARAMETERS -! ----------------------------------- -! SEVERAL PARAMETERS OF THE CODE ARE TUNED TO MAKE IT CNTRL -! WELL. THEY MAY BE DEFINED BY SETTING CNTRL(1),..,CNTRL(13) -! AS WELL AS ICNTRL(1),..,ICNTRL(4) DIFFERENT FROM ZERO. -! FOR ZERO INPUT, THE CODE CHOOSES DEFAULT VALUES: -! -! -!~~~> INPUT PARAMETERS: -! -! Note: For input parameters equal to zero the default values of the -! corresponding variables are used. -!~~~> -! ICNTRL(1) = 1: F = F(y) Independent of T (autonomous) -! = 0: F = F(t,y) Depends on T (non-autonomous) -! -! ICNTRL(2) = 0: AbsTol, RelTol are NVAR-dimensional vectors -! = 1: AbsTol, RelTol are scalars -! -! ICNTRL(3) -> not used -! -! ICNTRL(4) -> maximum number of integration steps -! For ICNTRL(4)=0 the default value of 100000 is used -! -! ICNTRL(11) THE MAXIMUM NUMBER OF COLUMNS IN THE EXTRAPOLATION -! TABLE. THE DEFAULT VALUE (FOR ICNTRL(3)=0) IS 12. -! IF ICNTRL(3).NE.0 THEN ICNTRL(3) SHOULD BE >= 3. -! -! ICNTRL(12) SWITCH FOR THE STEP SIZE SEQUENCE -! IF ICNTRL(4) == 1 THEN 1,2,3,4,6,8,12,16,24,32,48,... -! IF ICNTRL(4) == 2 THEN 2,3,4,6,8,12,16,24,32,48,64,... -! IF ICNTRL(4) == 3 THEN 1,2,3,4,5,6,7,8,9,10,... -! IF ICNTRL(4) == 4 THEN 2,3,4,5,6,7,8,9,10,11,... -! THE DEFAULT VALUE (FOR ICNTRL(4)=0) IS ICNTRL(4)=2. -! -! ICNTRL(13) PARAMETER "LAMBDA" OF DENSE OUTPUT; POSSIBLE VALUES -! ARE 0 AND 1; DEFAULT ICNTRL(5)=0. -! -! ICNTRL(14) = NRDENS = NUMBER OF COMPONENTS, FOR WHICH DENSE OUTPUT -! IS REQUIRED -! -! ICNTRL(21),...,ICNTRL(NRDENS+20) INDICATE THE COMPONENTS, FOR WHICH -! DENSE OUTPUT IS REQUIRED -! -!~~~> Real parameters -! -! RCNTRL(1) -> Hmin, lower bound for the integration step size -! It is strongly recommended to keep Hmin = ZERO -! RCNTRL(2) -> Hmax, upper bound for the integration step size -! RCNTRL(3) -> Hstart, starting value for the integration step size -! RCNTRL(4) -> FacMin, lower bound on step decrease factor (default=0.2) -! RCNTRL(5) -> FacMax, upper bound on step increase factor (default=6) -! RCNTRL(6) -> FacRej, step decrease factor after multiple rejections -! (default=0.1) -! RCNTRL(7) -> FacSafe, by which the new step is slightly smaller -! than the predicted value (default=0.9) -! RCNTRL(8) -> ThetaMin. If Newton convergence rate smaller -! than ThetaMin the Jacobian is not recomputed; -! (default=0.001). Increase cntrl(3), to 0.01 say, when -! Jacobian evaluations are costly. for small systems it -! should be smaller. -! RCNTRL(9) -> not used -! RCNTRL(10,11) -> FAC1,FAC2 (parameters for step size selection) -! RCNTRL(12,13) -> FAC3,FAC4 (parameters for order selection) -! RCNTRL(14,15) -> FacSafe1, FacSafe2 -! Safety factors for step size prediction -! HNEW=H*FacSafe2*(FacSafe1*TOL/ERR)**(1/(J-1)) -! RCNTRL(16:19) -> WorkFcn, WorkJac, WorkDec, WorkSol -! estimated computational work -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -! OUTPUT PARAMETERS -! ----------------- -! T T-VALUE WHERE THE SOLUTION IS COMPUTED -! (AFTER SUCCESSFUL RETURN T=Tend) -! -! Y(N) SOLUTION AT T -! -! H PREDICTED STEP SIZE OF THE LAST ACCEPTED STEP -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! DECLARATIONS -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - INTEGER :: N, IERR, ITOL, Max_no_steps, Ncolumns, Nsequence, Lambda, & - NRDENS, i, Ncolumns2, NRD, IOUT - KPP_REAL :: Y(NVAR),AbsTol(*),RelTol(*) - KPP_REAL :: Tinitial, Tfinal, Roundoff, Hmin, Hmax, & - FacMin, FacMax, FAC1, FAC2, FAC3, FAC4, FacSafe1, & - FacSafe2, H, Hstart,WorkFcn,WorkJac, WorkDec, WorkSol,& - WorkRow, FacRej, FacSafe, ThetaMin, T - LOGICAL :: AUTNMS - KPP_REAL :: RCNTRL(20), RSTATUS(20) - INTEGER :: ICNTRL(20), ISTATUS(20) - KPP_REAL, PARAMETER :: ZERO = 0.0d0 - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! SETTING THE PARAMETERS -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Nfun=0 - Njac=0 - Nstp=0 - Nacc=0 - Nrej=0 - Ndec=0 - Nsol=0 - - IERR = 0 - - IF (ICNTRL(1) == 0) THEN - AUTNMS = .FALSE. - ELSE - AUTNMS = .TRUE. - END IF - -!~~~> For Scalar tolerances (ICNTRL(1)/=0) the code uses AbsTol(1) and RelTol(1) -!~~~> For Vector tolerances (ICNTRL(1)==0) the code uses AbsTol(1:NVAR) and RelTol(1:NVAR) - IF (ICNTRL(2) == 0) THEN - ITOL = 1 - ELSE - ITOL = 0 - END IF - -!~~~> Max_no_steps: the maximum number of time steps admitted - IF (ICNTRL(4) == 0) THEN - Max_no_steps = 100000 - ELSEIF (ICNTRL(4) > 0) THEN - Max_no_steps=ICNTRL(4) - ELSE - PRINT * ,'User-selected ICNTRL(4)=',ICNTRL(4) - CALL SEULEX_ErrorMsg(-1,Tinitial,ZERO,IERR); - END IF - -!~~~> IOUT = use (or not) the output routine - IOUT = ICNTRL(10) - IF ( IOUT<0 .OR. IOUT>2 ) THEN - PRINT * ,'User-selected ICNTRL(10)=',ICNTRL(10) - IOUT = 0 - END IF - -!~~~> Ncolumns: maximum number of columns in the extrapolation - IF (ICNTRL(11)==0) THEN - Ncolumns=12 - ELSEIF (ICNTRL(11) > 2) THEN - Ncolumns=ICNTRL(11) - ELSE - PRINT * ,'User-selected ICNTRL(11)=',ICNTRL(11) - CALL SEULEX_ErrorMsg(-2,Tinitial,ZERO,IERR); - END IF - -!~~~> Nsequence: choice of step size sequence - IF (ICNTRL(12)==0) THEN - Nsequence = 2 - ELSEIF ( (ICNTRL(12)>0).AND.(ICNTRL(12)<5) ) THEN - Nsequence = ICNTRL(4) - ELSE - PRINT * ,'User-selected ICNTRL(12)=',ICNTRL(12) - CALL SEULEX_ErrorMsg(-3,Tinitial,ZERO,IERR) - END IF - -!~~~> LAMBDA: parameter for dense output - LAMBDA = ICNTRL(13) - IF ( LAMBDA < 0 .OR. LAMBDA >= 2 ) THEN - PRINT * ,'User-selected ICNTRL(13)=',ICNTRL(13) - CALL SEULEX_ErrorMsg(-4,Tinitial,ZERO,IERR) - END IF - -!~~~>- NRDENS: number of dense output components - NRDENS=ICNTRL(14) - IF ( (NRDENS < 0) .OR. (NRDENS > N) ) THEN - PRINT * ,'User-selected ICNTRL(14)=',ICNTRL(14) - CALL SEULEX_ErrorMsg(-5,Tinitial,ZERO,IERR) - END IF - - -!~~~> Unit roundoff (1+Roundoff>1) - Roundoff = WLAMCH('E') - -!~~~> Lower bound on the step size: (positive value) - IF (RCNTRL(1) == ZERO) THEN - Hmin = ZERO - ELSEIF (RCNTRL(1) > ZERO) THEN - Hmin = RCNTRL(1) - ELSE - PRINT * , 'User-selected RCNTRL(1)=', RCNTRL(1) - CALL SEULEX_ErrorMsg(-7,Tinitial,ZERO,IERR) - RETURN - END IF - -!~~~> Upper bound on the step size: (positive value) - IF (RCNTRL(2) == ZERO) THEN - Hmax = ABS(Tfinal-Tinitial) - ELSEIF (RCNTRL(2) > ZERO) THEN - Hmax = MIN(ABS(RCNTRL(2)),ABS(Tfinal-Tinitial)) - ELSE - PRINT * , 'User-selected RCNTRL(2)=', RCNTRL(2) - CALL SEULEX_ErrorMsg(-7,Tinitial,ZERO,IERR) - RETURN - END IF - -!~~~> Starting step size: (positive value) - IF (RCNTRL(3) == ZERO) THEN - Hstart = MAX(Hmin,Roundoff) - ELSEIF (RCNTRL(3) > ZERO) THEN - Hstart = MIN(ABS(RCNTRL(3)),ABS(Tfinal-Tinitial)) - ELSE - PRINT * , 'User-selected Hstart: RCNTRL(3)=', RCNTRL(3) - CALL SEULEX_ErrorMsg(-7,Tinitial,ZERO,IERR) - RETURN - END IF - - -!~~~> Step size can be changed s.t. FacMin < Hnew/Hexit < FacMax - IF (RCNTRL(4) == ZERO) THEN - FacMin = 0.2_dp - ELSEIF (RCNTRL(4) > ZERO) THEN - FacMin = RCNTRL(4) - ELSE - PRINT * , 'User-selected FacMin: RCNTRL(4)=', RCNTRL(4) - CALL SEULEX_ErrorMsg(-8,Tinitial,ZERO,IERR) - RETURN - END IF - IF (RCNTRL(5) == ZERO) THEN - FacMax = 10.0_dp - ELSEIF (RCNTRL(5) > ZERO) THEN - FacMax = RCNTRL(5) - ELSE - PRINT * , 'User-selected FacMax: RCNTRL(5)=', RCNTRL(5) - CALL SEULEX_ErrorMsg(-8,Tinitial,ZERO,IERR) - RETURN - END IF -!~~~> FacRej: Factor to decrease step after 2 succesive rejections - IF (RCNTRL(6) == ZERO) THEN - FacRej = 0.1_dp - ELSEIF (RCNTRL(6) > ZERO) THEN - FacRej = RCNTRL(6) - ELSE - PRINT * , 'User-selected FacRej: RCNTRL(6)=', RCNTRL(6) - CALL SEULEX_ErrorMsg(-8,Tinitial,ZERO,IERR) - RETURN - END IF -!~~~> FacSafe: Safety Factor in the computation of new step size - IF (RCNTRL(7) == ZERO) THEN - FacSafe = 0.9_dp - ELSEIF (RCNTRL(7) > ZERO) THEN - FacSafe = RCNTRL(7) - ELSE - PRINT * , 'User-selected FacSafe: RCNTRL(7)=', RCNTRL(7) - CALL SEULEX_ErrorMsg(-8,Tinitial,ZERO,IERR) - RETURN - END IF - -!~~~> ThetaMin: DECIDES WHETHER THE JACOBIAN SHOULD BE RECOMPUTED; -! INCREASE WORK(3), TO 0.01 SAY, WHEN JACOBIAN EVALUATIONS -! ARE COSTLY. FOR SMALL SYSTEMS WORK(3) SHOULD BE SMALLER. - IF(RCNTRL(8) == 0.D0)THEN - ThetaMin = 1.0d-3 - ELSE - ThetaMin = RCNTRL(8) - END IF - -!~~~> FAC1,FAC2: PARAMETERS FOR STEP SIZE SELECTION -! THE NEW STEP SIZE FOR THE J-TH DIAGONAL ENTRY IS -! CHOSEN SUBJECT TO THE RESTRICTION -! FACMIN/WORK(5) <= HNEW(J)/HOLD <= 1/FACMIN -! WHERE FACMIN=WORK(4)**(1/(J-1)) - IF(RCNTRL(10) == 0.D0)THEN - FAC1=0.1D0 - ELSE - FAC1=RCNTRL(10) - END IF - IF(RCNTRL(11) == 0.D0)THEN - FAC2=4.0D0 - ELSE - FAC2=RCNTRL(11) - END IF -!~~~> FAC3, FAC4: PARAMETERS FOR THE ORDER SELECTION -! ORDER IS DECREASED IF W(K-1) <= W(K)*WORK(6) -! ORDER IS INCREASED IF W(K) <= W(K-1)*WORK(7) - IF(RCNTRL(12) == 0.D0)THEN - FAC3=0.7D0 - ELSE - FAC3=RCNTRL(12) - END IF - IF(RCNTRL(13) == 0.D0)THEN - FAC4=0.9D0 - ELSE - FAC4=RCNTRL(13) - END IF -!~~~>- FacSafe1, FacSafe2: safety factors for step size prediction -! HNEW=H*WORK(9)*(WORK(8)*TOL/ERR)**(1/(J-1)) - IF(RCNTRL(14) == 0.D0)THEN - FacSafe1=0.6D0 - ELSE - FacSafe1=RCNTRL(14) - END IF - IF(RCNTRL(15) == 0.D0)THEN - FacSafe2=0.93D0 - ELSE - FacSafe2=RCNTRL(15) - END IF - -!~~~> WorkFcn: estimated computational work for a calls to FCN - IF(RCNTRL(16) == 0.D0)THEN - WorkFcn=1.D0 - ELSE - WorkFcn=RCNTRL(16) - END IF -!~~~> WorkJac: estimated computational work for calls to JAC - IF(RCNTRL(17) == 0.D0)THEN - WorkJac=5.D0 - ELSE - WorkJac=RCNTRL(17) - END IF -!~~~> WorkDec: estimated computational work for calls to DEC - IF(RCNTRL(18) == 0.D0)THEN - WorkDec=1.D0 - ELSE - WorkDec=RCNTRL(18) - END IF -!~~~> WorkSol: estimated computational work for calls to SOL - IF(RCNTRL(19) == 0.D0)THEN - WorkSol=1.D0 - ELSE - WorkSol=RCNTRL(19) - END IF - WorkRow=WorkFcn+WorkSol - -!~~~> Check if tolerances are reasonable - IF (ITOL == 0) THEN - IF (AbsTol(1) <= 0.D0.OR.RelTol(1) <= 10.D0*Roundoff) THEN - PRINT * , ' Scalar AbsTol = ',AbsTol(1) - PRINT * , ' Scalar RelTol = ',RelTol(1) - CALL SEULEX_ErrorMsg(-9,Tinitial,ZERO,IERR) - END IF - ELSE - DO i=1,N - IF (AbsTol(i) <= 0.D0.OR.RelTol(i) <= 10.D0*Roundoff) THEN - PRINT * , ' AbsTol(',i,') = ',AbsTol(i) - PRINT * , ' RelTol(',i,') = ',RelTol(i) - CALL SEULEX_ErrorMsg(-9,Tinitial,ZERO,IERR) - END IF - END DO - END IF - - IF (IERR < 0) RETURN - -!~~~>---- PREPARE THE ENTRY-POINTS FOR THE ARRAYS IN WORK ----- - Ncolumns2=(Ncolumns*(Ncolumns+1))/2 - NRD=MAX(1,NRDENS) - - T = Tinitial -!~~~> CALL TO CORE INTEGRATOR - CALL SEULEX_Integrator(N,T,Tfinal,Y,Hmax,H,Ncolumns,RelTol,AbsTol,ITOL, & - IOUT,IERR,Max_no_steps,Roundoff,Nsequence,AUTNMS, & - FAC1,FAC2,FAC3,FAC4,ThetaMin,FacSafe1,FacSafe2,WorkJac, & - WorkDec,WorkRow,Ncolumns2,NRD,LAMBDA,Nstp) - - ISTATUS(1)=Nfun - ISTATUS(2)=Njac - ISTATUS(3)=Nstp - ISTATUS(4)=Nacc - ISTATUS(5)=Nrej - ISTATUS(6)=Ndec - ISTATUS(7)=Nsol - - END SUBROUTINE ATMSEULEX - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SEULEX_ErrorMsg(Code,T,H,IERR) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Handles all error messages -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - KPP_REAL, INTENT(IN) :: T, H - INTEGER, INTENT(IN) :: Code - INTEGER, INTENT(OUT) :: IERR - - IERR = Code - PRINT * , & - 'Forced exit from SEULEX due to the following error:' - - SELECT CASE (Code) - CASE (-1) - PRINT * , '--> Improper value for maximal no of steps' - CASE (-2) - PRINT * , '--> Improper value for maximum no of columns in extrapolation' - CASE (-3) - PRINT * , '--> Improper value for step size sequence' - CASE (-4) - PRINT * , '--> Improper value for Lambda (must be 0/1)' - CASE (-5) - PRINT * , '--> Improper number of dense output components' - CASE (-6) - PRINT * , '--> Improper parameters for second order equations' - CASE (-7) - PRINT * , '--> Hmin/Hmax/Hstart must be positive' - CASE (-8) - PRINT * , '--> FacMin/FacMax/FacRej must be positive' - CASE (-9) - PRINT * , '--> Improper tolerance values' - CASE (-10) - PRINT * , '--> No of steps exceeds maximum bound' - CASE (-11) - PRINT * , '--> Step size too small: T + 10*H = T', & - ' or H < Roundoff' - CASE (-12) - PRINT * , '--> Matrix is repeatedly singular' - CASE DEFAULT - PRINT *, 'Unknown Error code: ', Code - END SELECT - - PRINT *, "T=", T, "and H=", H - - END SUBROUTINE SEULEX_ErrorMsg - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SEULEX_Integrator(N,T,Tend,Y,Hmax,H,Ncolumns,RelTol,AbsTol,ITOL,& - IOUT,IERR,Max_no_steps,Roundoff,Nsequence,AUTNMS, & - FAC1,FAC2,FAC3,FAC4,ThetaMin,FacSafe1,FacSafe2,WorkJac, & - WorkDec,WorkRow,Ncolumns2,NRD,LAMBDA,Nstp) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! CORE INTEGRATOR FOR SEULEX -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! DECLARATIONS -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - USE KPP_ROOT_Parameters - USE KPP_ROOT_Jacobian - IMPLICIT KPP_REAL (A-H,O-Z) - IMPLICIT INTEGER (I-N) - - INTEGER :: N, Ncolumns, Ncolumns2, K, KC, KRIGHT, KLR, KK, KRN,& - KOPT, NRD - KPP_REAL :: Y(NVAR),DY(NVAR),FX(NVAR),YHH(NVAR) - KPP_REAL :: DYH(NVAR), DEL(NVAR), WH(NVAR) - KPP_REAL :: SCAL(NVAR), HH(Ncolumns), W(Ncolumns), A(Ncolumns) -#ifdef FULL_ALGEBRA - KPP_REAL :: FJAC(NVAR,NVAR) -#else - KPP_REAL :: FJAC(LU_NONZERO) -#endif - KPP_REAL Table(Ncolumns,N) - INTEGER IP(N),NJ(Ncolumns),IPHES(N),ICOMP(NRD) - KPP_REAL RelTol(*),AbsTol(*) - KPP_REAL FSAFE(Ncolumns2,NRD),FACUL(Ncolumns),E(N,N),DENS((Ncolumns+2)*NRD) - LOGICAL REJECT,LAST,ATOV,CALJAC,CALHES,AUTNMS - - KPP_REAL TOLDD,HHH,NNRD - COMMON /COSEU/TOLDD,HHH,NNRD,KRIGHT - -!~~~> COMPUTE COEFFICIENTS FOR DENSE OUTPUT - IF (IOUT == 2) THEN - NNRD=NRD -!~~~> COMPUTE THE FACTORIALS -------- - FACUL(1)=1.D0 - DO i=1,Ncolumns-1 - FACUL(i+1)=i*FACUL(i) - END DO - END IF - -!~~~> DEFINE THE STEP SIZE SEQUENCE - IF (Nsequence == 1) THEN - NJ(1)=1 - NJ(2)=2 - NJ(3)=3 - DO I=4,Ncolumns - NJ(i)=2*NJ(I-2) - END DO - END IF - IF (Nsequence == 2) THEN - NJ(1)=2 - NJ(2)=3 - DO I=3,Ncolumns - NJ(i)=2*NJ(I-2) - END DO - END IF - DO i=1,Ncolumns - IF (Nsequence == 3) NJ(i)=I - IF (Nsequence == 4) NJ(i)=I+1 - END DO - A(1)=WorkJac+NJ(1)*WorkRow+WorkDec - DO I=2,Ncolumns - A(i)=A(i-1)+(NJ(i)-1)*WorkRow+WorkDec - END DO - K=MAX0(3,MIN0(Ncolumns-2,INT(-DLOG10(RelTol(1)+AbsTol(1))*.6D0+1.5D0))) - - ! T = Tinitial - HmaxN = MIN(ABS(Hmax),ABS(Tend-T)) - IF (ABS(H) <= 10.D0*Roundoff) H=1.0D-6 - H=MIN(ABS(H),HmaxN) - Theta=2*ABS(ThetaMin) - ERR=0.D0 - W(1)=1.D30 - DO i=1,N - IF (ITOL == 0) THEN - SCAL(i)=AbsTol(1)+RelTol(1)*DABS(Y(i)) - ELSE - SCAL(i)=AbsTol(i)+RelTol(i)*DABS(Y(i)) - END IF - END DO - CALJAC=.FALSE. - REJECT=.FALSE. - LAST=.FALSE. - 10 CONTINUE - IF (REJECT) Theta=2*ABS(ThetaMin) - ATOV=.FALSE. -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> IS Tend REACHED IN THE NEXT STEP? -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - H1=Tend-T - IF (H1 <= Roundoff) GO TO 110 - HOPT=H - H=MIN(H,H1,HmaxN) - IF (H >= H1-Roundoff) LAST=.TRUE. - IF (AUTNMS) THEN - CALL FUN_CHEM(T,Y,DY) - END IF - IF (Theta > ThetaMin.AND..NOT.CALJAC) THEN -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! COMPUTATION OF THE JACOBIAN -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - CALL JAC_CHEM(T,Y,FJAC) - CALJAC=.TRUE. - CALHES=.FALSE. - END IF -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> THE FIRST AND LAST STEP -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IF (Nstp == 0.OR.LAST) THEN - IPT=0 - Nstp=Nstp+1 - DO J=1,K - KC=J - CALL SEUL(J,N,T,Y,DY,FX,FJAC,LFJAC,E,LE,IP,H,Ncolumns, & - HmaxN,Table,SCAL,NJ,HH,W,A,YHH,DYH,DEL,WH,ERR,FacSafe1,FAC, & - FAC1,FAC2,FacSafe2,Theta,Nfun,Ndec,Nsol, & - ERROLD,IPHES,ICOMP,AUTNMS,REJECT, & - ATOV,FSAFE,Ncolumns2,NRD,IOUT,IPT,CALHES) - IF (ATOV) GOTO 10 - IF (J > 1 .AND. ERR <= 1.d0) GOTO 60 - END DO - GO TO 55 - END IF -!~~~> BASIC INTEGRATION STEP - 30 CONTINUE - IPT=0 - Nstp=Nstp+1 - IF (Nstp >= Max_no_steps) GOTO 120 - KC=K-1 - DO J=1,KC - CALL SEUL(J,N,T,Y,DY,FX,FJAC,LFJAC,E,LE,IP,H,Ncolumns,& - HmaxN,Table,SCAL,NJ,HH,W,A,YHH,DYH,DEL,WH,ERR,FacSafe1,& - FAC,FAC1,FAC2,FacSafe2,Theta,Nfun,Ndec,Nsol,& - ERROLD,IPHES,ICOMP,AUTNMS,REJECT,& - ATOV,FSAFE,Ncolumns2,NRD,IOUT,IPT,CALHES) - IF (ATOV) GOTO 10 - END DO -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> CONVERGENCE MONITOR -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IF (K == 2.OR.REJECT) GO TO 50 - IF (ERR <= 1.D0) GO TO 60 - IF (ERR > DBLE(NJ(K+1)*NJ(K))*4.D0) GO TO 100 - 50 CALL SEUL(K,N,T,Y,DY,FX,FJAC,LFJAC,E,LE,IP,H,Ncolumns,& - HmaxN,Table,SCAL,NJ,HH,W,A,YHH,DYH,DEL,WH,ERR,FacSafe1,& - FAC,FAC1,FAC2,FacSafe2,Theta,Nfun,Ndec,Nsol,& - ERROLD,IPHES,ICOMP,AUTNMS,REJECT,& - ATOV,FSAFE,Ncolumns2,NRD,IOUT,IPT,CALHES) - IF (ATOV) GOTO 10 - KC=K - IF (ERR <= 1.D0) GO TO 60 -!~~~> HOPE FOR CONVERGENCE IN LINE K+1 - 55 IF (ERR > DBLE(NJ(K+1))*2.D0) GO TO 100 - KC=K+1 - CALL SEUL(KC,N,T,Y,DY,FX,FJAC,LFJAC,E,LE,IP,H,Ncolumns,& - HmaxN,Table,SCAL,NJ,HH,W,A,YHH,DYH,DEL,WH,ERR,FacSafe1,& - FAC,FAC1,FAC2,FacSafe2,Theta,Nfun,Ndec,Nsol,& - ERROLD,IPHES,ICOMP,AUTNMS,REJECT,& - ATOV,FSAFE,Ncolumns2,NRD,IOUT,IPT,CALHES) - IF (ATOV) GOTO 10 - IF (ERR > 1.D0) GO TO 100 - !Adi IF ((ERR > 1.D0).and.(H.gt.Hmin)) GO TO 100 -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> STEP IS ACCEPTED -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - 60 TOLD=T - T=T+H - IF (IOUT == 2) THEN - KRIGHT=KC - DO i=1,NRD - DENS(i)=Y(ICOMP(i)) - END DO - END IF - DO i=1,N - T1I=Table(1,I) - IF (ITOL == 0) THEN - SCAL(i)=AbsTol(1)+RelTol(1)*DABS(T1I) - ELSE - SCAL(i)=AbsTol(i)+RelTol(i)*DABS(T1I) - END IF - Y(i)=T1I - END DO - Nacc=Nacc+1 - CALJAC=.FALSE. - IF (IOUT == 2) THEN - TOLDD=TOLD - HHH=H - DO i=1,NRD - DENS(NRD+I)=Y(ICOMP(i)) - END DO - DO KLR=1,KRIGHT-1 -!~~~> COMPUTE DIFFERENCES - IF (KLR >= 2) THEN - DO KK=KLR,KC - LBEG=((KK+1)*KK)/2 - LEND=LBEG-KK+2 - DO L=LBEG,LEND,-1 - DO i=1,NRD - FSAFE(L,I)=FSAFE(L,I)-FSAFE(L-1,I) - END DO - END DO - END DO - END IF -!~~~> COMPUTE DERIVATIVES AT RIGHT END ---- - DO KK=KLR+LAMBDA,KC - FACNJ=NJ(KK) - FACNJ=FACNJ**KLR/FACUL(KLR+1) - IPT=((KK+1)*KK)/2 - DO I=1,NRD - KRN=(KK-LAMBDA+1)*NRD - DENS(KRN+I)=FSAFE(IPT,I)*FACNJ - END DO - END DO - DO J=KLR+LAMBDA+1,KC - DBLENJ=NJ(J) - DO L=J,KLR+LAMBDA+1,-1 - FACTOR=DBLENJ/NJ(L-1)-1.D0 - DO i=1,NRD - KRN=(L-LAMBDA+1)*NRD+I - DENS(KRN-NRD)=DENS(KRN)+(DENS(KRN)-DENS(KRN-NRD))/FACTOR - END DO - END DO - END DO - END DO -!~~~> COMPUTE THE COEFFICIENTS OF THE INTERPOLATION POLYNOMIAL - DO IN=1,NRD - DO J=1,KRIGHT - II=NRD*J+IN - DENS(II)=DENS(II)-DENS(II-NRD) - END DO - END DO - END IF -!~~~> COMPUTE OPTIMAL ORDER - IF (KC == 2) THEN - KOPT=3 - IF (REJECT) KOPT=2 - GO TO 80 - END IF - IF (KC <= K) THEN - KOPT=KC - IF (W(KC-1) < W(KC)*FAC3) KOPT=KC-1 - IF (W(KC) < W(KC-1)*FAC4) KOPT=MIN0(KC+1,Ncolumns-1) - ELSE - KOPT=KC-1 - IF (KC > 3.AND.W(KC-2) < W(KC-1)*FAC3) KOPT=KC-2 - IF (W(KC) < W(KOPT)*FAC4) KOPT=MIN0(KC,Ncolumns-1) - END IF -!~~~> AFTER A REJECTED STEP - 80 IF (REJECT) THEN - K=MIN0(KOPT,KC) - H=MIN(H,HH(K)) - REJECT=.FALSE. - GO TO 10 - END IF -!~~~> COMPUTE STEP SIZE FOR NEXT STEP - IF (KOPT <= KC) THEN - H=HH(KOPT) - ELSE - IF (KC < K.AND.W(KC) < W(KC-1)*FAC4) THEN - H=HH(KC)*A(KOPT+1)/A(KC) - ELSE - H=HH(KC)*A(KOPT)/A(KC) - END IF - END IF - K=KOPT - !Adi H = MAX(H, Hmin) - GO TO 10 -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> STEP IS REJECTED -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - 100 K=MIN0(K,KC) - IF (K > 2.AND.W(K-1) < W(K)*FAC3) K=K-1 - Nrej=Nrej+1 - H=HH(K) - LAST=.FALSE. - REJECT=.TRUE. - IF (CALJAC) GOTO 30 - GO TO 10 -!~~~> SOLUTION EXIT - 110 CONTINUE - H=HOPT - IERR=1 - RETURN -!~~~> FAIL EXIT - 120 WRITE (6,979) T,H - 979 FORMAT(' EXIT OF SEULEX AT T=',D14.7,' H=',D14.7) - IERR=-1 - RETURN - - - END SUBROUTINE SEULEX_Integrator - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SEUL(JJ,N,T,Y,DY,FX,FJAC,LFJAC,E,LE,IP,& - H,Ncolumns,HmaxN,Table,SCAL,NJ,HH,W,A,YH,DYH,DEL,WH,ERR,FacSafe1, & - FAC,FAC1,FAC2,FacSafe2,Theta,Nfun,Ndec,Nsol,& - ERROLD,IPHES,ICOMP, & - AUTNMS,REJECT,ATOV,FSAFE,Ncolumns2,NRD,IOUT, & - IPT,CALHES) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> THIS SUBROUTINE COMPUTES THE J-TH LINE OF THE -!~~~> EXTRAPOLATION TABLE AND PROVIDES AN ESTIMATE -!~~~> OF THE OPTIMAL STEP SIZE - USE KPP_ROOT_Parameters - USE KPP_ROOT_Jacobian - IMPLICIT KPP_REAL (A-H,O-Z) - IMPLICIT INTEGER (I-N) - INTEGER :: Ncolumns, Ncolumns2, N, NRD - KPP_REAL :: Y(NVAR),YH(NVAR),DY(NVAR),FX(NVAR),DYH(NVAR) - KPP_REAL :: DEL(NVAR),WH(NVAR),SCAL(NVAR),HH(Ncolumns),W(Ncolumns),A(Ncolumns) -#ifdef FULL_ALGEBRA - KPP_REAL :: FJAC(NVAR,NVAR), E(NVAR,NVAR) -#else - KPP_REAL :: FJAC(LU_NONZERO), E(LU_NONZERO) -#endif - KPP_REAL :: Table(Ncolumns,NVAR) - KPP_REAL :: FSAFE(Ncolumns2,NRD) - INTEGER :: IP(N),NJ(Ncolumns),IPHES(N),ICOMP(NRD) - LOGICAL ATOV,REJECT,AUTNMS,CALHES - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! COMPUTE THE MATRIX E AND ITS DECOMPOSITION -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - HJ=H/NJ(JJ) - HJI=1.D0/HJ -#ifdef FULL_ALGEBRA - DO j=1,N - DO i=1,N - E(i,j)=-FJAC(i,j) - END DO - E(j,j)=E(j,j)+HJI - END DO - CALL DGETRF(N,N,E,N,IP,ISING) -#else - DO i=1,LU_NONZERO - E(i)=-FJAC(i) - END DO - DO j=1,N - E(LU_DIAG(j))=E(LU_DIAG(j))+HJI - END DO - CALL KppDecomp (E,ISING) -#endif - Ndec=Ndec+1 - IF (ISING.NE.0) GOTO 79 -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> STARTING PROCEDURE -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IF (.NOT.AUTNMS) THEN - CALL FUN_CHEM(T+HJ,Y,DY) - END IF - DO i=1,N - YH(i)=Y(i) - DEL(i)=DY(i) - END DO -#ifdef FULL_ALGEBRA - CALL DGETRS ('N',N,1,E,N,IP,DEL,N,ISING) -#else - CALL KppSolve (E,DEL) -#endif - Nsol=Nsol+1 - M=NJ(JJ) - IF (IOUT == 2.AND.M == JJ) THEN - IPT=IPT+1 - DO i=1,NRD - FSAFE(IPT,I)=DEL(ICOMP(i)) - END DO - END IF -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> SEMI-IMPLICIT EULER METHOD -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IF (M > 1) THEN - DO MM=1,M-1 - DO i=1,N - YH(i)=YH(i)+DEL(i) - END DO - IF (AUTNMS) THEN - CALL FUN_CHEM(T+HJ*MM,YH,DYH) - ELSE - CALL FUN_CHEM(T+HJ*(MM+1),YH,DYH) - END IF - - IF (MM == 1.AND.JJ <= 2) THEN -!~~~> STABILITY CHECK - DEL1=0.D0 - DO i=1,N - DEL1=DEL1+(DEL(i)/SCAL(i))**2 - END DO - DEL1=SQRT(DEL1) - IF (.NOT.AUTNMS) THEN - CALL FUN_CHEM(T+HJ,YH,WH) - - DO i=1,N - DEL(i)=WH(i)-DEL(i)*HJI - END DO - ELSE - DO i=1,N - DEL(i)=DYH(i)-DEL(i)*HJI - END DO - END IF -#ifdef FULL_ALGEBRA - CALL DGETRS ('N',N,1,E,N,IP,DEL,N,ISING) -#else - CALL KppSolve (E,DEL) -#endif - Nsol=Nsol+1 - DEL2=0.D0 - DO i=1,N - DEL2=DEL2+(DEL(i)/SCAL(i))**2 - END DO - DEL2=SQRT(DEL2) - Theta=DEL2/MAX(1.D0,DEL1) - IF (Theta > 1.D0) GOTO 79 - END IF -#ifdef FULL_ALGEBRA - CALL DGETRS ('N',N,1,E,N,IP,DYH,N,ISING) -#else - CALL KppSolve (E,DYH) -#endif - Nsol=Nsol+1 - DO i=1,N - DEL(i)=DYH(i) - END DO - IF (IOUT == 2.AND.MM >= M-JJ) THEN - IPT=IPT+1 - DO i=1,NRD - FSAFE(IPT,i)=DEL(ICOMP(i)) - END DO - END IF - END DO - END IF - DO i=1,N - Table(JJ,I)=YH(i)+DEL(i) - END DO -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> POLYNOMIAL EXTRAPOLATION -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IF (JJ == 1) RETURN - DO L=JJ,2,-1 - FAC=(DBLE(NJ(JJ))/DBLE(NJ(L-1)))-1.D0 - DO i=1,N - Table(L-1,I)=Table(L,I)+(Table(L,I)-Table(L-1,I))/FAC - END DO - END DO - ERR=0.D0 - DO i=1,N - ERR=ERR+MIN(ABS((Table(1,I)-Table(2,I)))/SCAL(i),1.D15)**2 - END DO - IF (ERR >= 1.D30) GOTO 79 - ERR=SQRT(ERR/DBLE(N)) - IF (JJ > 2.AND.ERR >= ERROLD) GOTO 79 - ERROLD=MAX(4*ERR,1.D0) -!~~~> COMPUTE OPTIMAL STEP SIZES - EXPO=1.D0/JJ - FACMIN=FAC1**EXPO - FAC=MIN(FAC2/FACMIN,MAX(FACMIN,(ERR/FacSafe1)**EXPO/FacSafe2)) - FAC=1.D0/FAC - HH(JJ)=MIN(H*FAC,HmaxN) - W(JJ)=A(JJ)/HH(JJ) - RETURN - 79 ATOV=.TRUE. - H=H*0.5D0 - REJECT=.TRUE. - RETURN - END SUBROUTINE SEUL - - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE FUN_CHEM( T, V, FCT ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - USE KPP_ROOT_Parameters - USE KPP_ROOT_Global - USE KPP_ROOT_Function, ONLY: Fun - USE KPP_ROOT_Rates, ONLY: Update_SUN, Update_RCONST, Update_PHOTO - - IMPLICIT NONE - - KPP_REAL :: V(NVAR), FCT(NVAR) - KPP_REAL :: T, TOLD - - !TOLD = TIME - !TIME = T - !CALL Update_SUN() - !CALL Update_RCONST() - !CALL Update_PHOTO() - !TIME = TOLD - CALL Fun(V, FIX, RCONST, FCT) - Nfun=Nfun+1 - - END SUBROUTINE FUN_CHEM - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE JAC_CHEM ( T, V, Jcb ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - USE KPP_ROOT_Parameters - USE KPP_ROOT_Global - USE KPP_ROOT_Jacobian, ONLY: Jac_SP - USE KPP_ROOT_Rates, ONLY: Update_SUN, Update_RCONST, Update_PHOTO - - IMPLICIT NONE - - KPP_REAL :: V(NVAR), T, TOLD -#ifdef FULL_ALGEBRA - KPP_REAL :: JV(LU_NONZERO), Jcb(NVAR,NVAR) - INTEGER :: i,j -#else - KPP_REAL :: Jcb(LU_NONZERO) -#endif - - !TOLD = TIME - !TIME = T - !CALL Update_SUN() - !CALL Update_RCONST() - !CALL Update_PHOTO() - !TIME = TOLD - -#ifdef FULL_ALGEBRA - CALL Jac_SP(V, FIX, RCONST, JV) - DO j=1,NVAR - DO i=1,NVAR - Jcb(i,j) = 0.0D0 - END DO - END DO - DO i=1,LU_NONZERO - Jcb(LU_IROW(i),LU_ICOL(i)) = JV(i) - END DO -#else - CALL Jac_SP(V, FIX, RCONST, Jcb) -#endif - Njac=Njac+1 - - END SUBROUTINE JAC_CHEM - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -END MODULE KPP_ROOT_Integrator diff --git a/boxmox/int/none.c b/boxmox/int/none.c deleted file mode 100644 index e69de29bb2d1d6434b8b29ae775ad8c2e48c5391..0000000000000000000000000000000000000000 diff --git a/boxmox/int/none.def b/boxmox/int/none.def deleted file mode 100644 index e69de29bb2d1d6434b8b29ae775ad8c2e48c5391..0000000000000000000000000000000000000000 diff --git a/boxmox/int/none.f b/boxmox/int/none.f deleted file mode 100644 index e69de29bb2d1d6434b8b29ae775ad8c2e48c5391..0000000000000000000000000000000000000000 diff --git a/boxmox/int/none.f90 b/boxmox/int/none.f90 deleted file mode 100644 index e69de29bb2d1d6434b8b29ae775ad8c2e48c5391..0000000000000000000000000000000000000000 diff --git a/boxmox/int/none.m b/boxmox/int/none.m deleted file mode 100644 index e69de29bb2d1d6434b8b29ae775ad8c2e48c5391..0000000000000000000000000000000000000000 diff --git a/boxmox/int/oldies/exqssa.c b/boxmox/int/oldies/exqssa.c deleted file mode 100644 index 019895aed4d9e1e33638cc1d9b84a5ac49525521..0000000000000000000000000000000000000000 --- a/boxmox/int/oldies/exqssa.c +++ /dev/null @@ -1,90 +0,0 @@ -void INTEGRATE( double DT ) -{ -KPP_REAL P_VAR[NVAR], D_VAR[NVAR], V1[NVAR], V2[NVAR]; -int IsReject; -KPP_REAL T, Tnext, STEP, STEPold, Told, SUP; -KPP_REAL ERR, ERRold, ratio, factor, facmax, tmp; -int i; - - T = TIME; - Tnext = TIME + DT; - STEP = STEPMIN; - Told = T; - SUP = 1e-14; - IsReject = 0; - ERR = .5; - -/* -- BELOW THIS LIMIT USE TAYLOR INSTEAD OF EXP --- */ - - while ( T < Tnext ) { - - T = Told + STEP; - if ( T > Tnext ) { - STEP = Tnext - Told; - T = Tnext; - } - - FSPLIT_VAR ( VAR, P_VAR, D_VAR ); - - for( i = 0; i < NVAR; i++ ) { - if ( fabs(D_VAR[i]) > SUP ) { - ratio = P_VAR[i] / D_VAR[i]; - tmp = (KPP_REAL)exp( (double)(-D_VAR[i] * STEP * 0.5) ); - V1[i] = tmp * tmp * (VAR[i] - ratio) + ratio; - V2[i] = tmp * (VAR[i] - ratio) + ratio; - } else { - tmp = D_VAR[i] * STEP * 0.5; - V1[i] = VAR[i] + P_VAR[i] * STEP * ( 1 - tmp * - ( 1 - 2.0 / 3.0 * tmp ) ); - V2[i] = VAR[i] + P_VAR[i] * 0.5 * STEP * ( 1 - 0.5 * tmp * - ( 1 - 1.0 / 3.0 * tmp ) ); - } - } - - FSPLIT_VAR( V2, P_VAR, D_VAR ); - - for( i = 0; i < NVAR; i++ ) { - if ( fabs(D_VAR[i]) > SUP ) { - ratio = P_VAR[i] / D_VAR[i]; - tmp = (KPP_REAL)exp( (double)(-D_VAR[i] * STEP * 0.5) ); - V2[i] = tmp * (V2[i] - ratio) + ratio; - } else { - tmp = D_VAR[i] * STEP * 0.5; - V2[i] = V2[i] + P_VAR[i] * 0.5 * STEP * ( 1 - 0.5 * tmp * - ( 1 - 1.0 / 3.0 * tmp ) ); - } - } -/* ==== Extrapolation and error estimation ======== */ - - ERRold=ERR; - ERR=0.; - for( i = 0; i < NVAR; i++ ) { - V1[i] = 2.*V2[i] - V1[i]; - tmp = (V2[i] - V1[i]) / (ATOL[i] + RTOL[i]*V2[i]); - ERR = ERR + tmp*tmp; - } - ERR = sqrt(ERR/NVAR); - STEPold = STEP; - -/* ===== choosing the stepsize ==================== */ - - factor = 0.9 / pow(ERR,0.35) * pow(ERRold,0.2); - facmax = IsReject ? 1.0 : 5.0; - - factor = max( 0.2, min(factor,facmax) ); - STEP = min( STEPMAX, max(STEPMIN,factor*STEP) ); - -/*================================================= */ - - if ( (ERR > 1) && (STEPold > STEPMIN) ) { - T = Told; - IsReject = 1; - } else { - IsReject = 0; - Told = T; - for( i = 0; i < NVAR; i++ ) - VAR[i] = max( V1[i], 0.0 ); - TIME = Tnext; - } - } -} diff --git a/boxmox/int/oldies/exqssa.def b/boxmox/int/oldies/exqssa.def deleted file mode 100644 index 6169246f9d234f975bf5ad36dfcacad9508d79f1..0000000000000000000000000000000000000000 --- a/boxmox/int/oldies/exqssa.def +++ /dev/null @@ -1,16 +0,0 @@ - -#FUNCTION SPLIT -#JACOBIAN OFF -#SPARSEDATA OFF -#DOUBLE ON -#INTFILE exqssa - -#INLINE F_INIT_INT - STEPMIN=0.0001 - STEPMAX=60. -#ENDINLINE - -#INLINE C_INIT_INT - STEPMIN=0.0001; - STEPMAX=60.; -#ENDINLINE diff --git a/boxmox/int/oldies/exqssa.f b/boxmox/int/oldies/exqssa.f deleted file mode 100644 index 925d4a7896d3933e2939321c04c0b4ba4f362d1a..0000000000000000000000000000000000000000 --- a/boxmox/int/oldies/exqssa.f +++ /dev/null @@ -1,136 +0,0 @@ -C -- EXTRAPOLATED QSSA WITH STEADY STATE APPROXIMATION -- -C For extrapolated plain QSSA (to remove the steady state assumption) -C modify slow -> 0, fast -> 1e20 -C - - SUBROUTINE INTEGRATE( TIN, TOUT ) - - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - -C TIN - Start Time - KPP_REAL TIN -C TOUT - End Time - KPP_REAL TOUT - -C Local variables - KPP_REAL P_VAR(NVAR), D_VAR(NVAR), V1(NVAR), V2(NVAR) - LOGICAL IsReject - KPP_REAL T, Tnext, STEP, STEPold, Told, SUP - KPP_REAL ERR, ERRold, ratio, factor, facmax, tmp - INTEGER i - KPP_REAL slow, fast - - T = TIN - Tnext = TOUT - STEP = DMAX1(STEPMIN,1.d-10) - Told = T - SUP = 1e-14 - IsReject = .false. - ERR = 1.d0 - ERRold = 1.d0 - slow = 0.01 - fast = 10. - - 10 continue - Tplus = T + STEP - if ( Tplus .gt. Tnext ) then - STEP = Tnext - T - Tplus = Tnext - end if - - - TITI = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - TIME = TITI - CALL FSPLIT_VAR ( VAR, P_VAR, D_VAR ) - - do i=1,NVAR - IF ( D_VAR(i)*STEP .lt. slow) THEN ! SLOW SPECIES - XXX = STEP * (P_VAR(i) - D_VAR(i)*VAR(i)) - V1(i) = VAR(i) + XXX - V2(i) = VAR(i) + 0.5*XXX - ELSE IF ( D_VAR(i)*STEP .GT. fast) THEN ! FAST SPECIES - V1(i) = P_VAR(i)/D_VAR(i) - V2(i) = V1(i) - ELSE ! MEDIUM LIVED - if ( abs(D_VAR(i)).gt.SUP ) then - ratio = P_VAR(i)/D_VAR(i) - tmp = exp(-D_VAR(i)*STEP*0.5) - V1(i) = tmp * tmp * (VAR(i) - ratio) + ratio - V2(i) = tmp * (VAR(i) - ratio) + ratio - else - tmp = D_VAR(i) * STEP * 0.5 - V1(i) = VAR(i) + P_VAR(i) * STEP * ( 1 - tmp * - * ( 1 - 2.0 / 3.0 * tmp ) ) - V2(i) = VAR(i) + P_VAR(i) * 0.5 * STEP*( 1-0.5*tmp* - * ( 1 - 1.0 / 3.0 * tmp ) ) - end if - END IF - end do - - TITI = TIME - TIME = T + 0.5*STEP - CALL Update_SUN() - CALL Update_RCONST() - TIME = TITI - CALL FSPLIT_VAR ( V2, P_VAR, D_VAR ) - - do i=1,NVAR - IF ( D_VAR(i)*STEP .lt. slow) THEN ! SLOW SPECIES - XXX = STEP * (P_VAR(i) - D_VAR(i)*VAR(i)) - V2(i) = V2(i) + 0.5*XXX - ELSE IF ( D_VAR(i)*STEP .GT. fast) THEN ! FAST SPECIES - V2(i) = P_VAR(i)/D_VAR(i) - ELSE ! MEDIUM LIVED - if ( abs(D_VAR(i)).gt.SUP ) then - ratio = P_VAR(i)/D_VAR(i) - tmp = exp(-D_VAR(i)*STEP*0.5) - V2(i) = tmp * (V2(i) - ratio) + ratio - else - tmp = D_VAR(i) * STEP * 0.5 - V2(i) = V2(i) + P_VAR(i) * 0.5 * STEP * ( 1 - 0.5 * tmp * - * ( 1 - 1.0 / 3.0 * tmp ) ) - end if - END IF - end do - -C ===== Extrapolation and error estimation ======== - - ERRold=ERR - ERR=0.0D0 - do i=1,NVAR - ERR = ERR + ((V2(i)-V1(i))/(ATOL(i) + RTOL(i)*V2(i)))**2 - end do - ERR = DSQRT( ERR/NVAR ) - STEPold=STEP - -C ===== choosing the stepsize ===================== - - factor = 0.9*ERR**(-0.35)*ERRold**0.2 - if (IsReject) then - facmax=1. - else - facmax=8. - end if - factor = DMAX1( 1.25D-1, DMIN1(factor,facmax) ) - STEP = DMIN1( STEPMAX, DMAX1(STEPMIN,factor*STEP) ) - -C=================================================== - - if ( (ERR.gt.1).and.(STEPold.gt.STEPMIN) ) then - IsReject = .true. - else - IsReject = .false. - do 140 i=1,NVAR - VAR(i) = DMAX1(2*V2(i)-V1(i), 0.d0) - 140 continue - T = Tplus - end if - if ( T .lt. Tnext ) go to 10 - - TIME = Tnext - RETURN - END diff --git a/boxmox/int/oldies/kpp_rodas.def b/boxmox/int/oldies/kpp_rodas.def deleted file mode 100644 index 9e94c5b7bc9db254fe929616a57d1468775ace53..0000000000000000000000000000000000000000 --- a/boxmox/int/oldies/kpp_rodas.def +++ /dev/null @@ -1,23 +0,0 @@ - -#FUNCTION AGGREGATE -#JACOBIAN SPARSE_LU_ROW - -#DOUBLE ON -#INTFILE kpp_rodas - -#INLINE F_DECL_INT - INTEGER Autonomous - COMMON /INTGDATA/ Autonomous - REAL*8 STEPSTART - COMMON /GDATA/ STEPSTART -#ENDINLINE - -#INLINE F_INIT_INT - STEPMIN=0.0001 - STEPMAX=3600. - Autonomous = 0 - STEPSTART=STEPMIN -#ENDINLINE - - - diff --git a/boxmox/int/oldies/kpp_rodas.f b/boxmox/int/oldies/kpp_rodas.f deleted file mode 100644 index 600021ca6170226899d4c7525f976758b5d161e8..0000000000000000000000000000000000000000 --- a/boxmox/int/oldies/kpp_rodas.f +++ /dev/null @@ -1,647 +0,0 @@ - SUBROUTINE INTEGRATE( TIN, TOUT ) - - IMPLICIT KPP_REAL (A-H,O-Z) - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - -C TIN - Start Time - KPP_REAL TIN -C TOUT - End Time - KPP_REAL TOUT - INTEGER i - - PARAMETER (LWORK=2*NVAR*NVAR+14*NVAR+20,LIWORK=NVAR+20) - KPP_REAL WORK(LWORK) - INTEGER IWORK(LIWORK) - EXTERNAL FUNC_CHEM,JAC_CHEM - - - ITOL=1 ! --- VECTOR TOLERANCES - IJAC=1 ! --- COMPUTE THE JACOBIAN ANALYTICALLY - MLJAC=NVAR ! --- JACOBIAN IS A FULL MATRIX - MUJAC=NVAR ! --- JACOBIAN IS A FULL MATRIX - IMAS=0 ! --- DIFFERENTIAL EQUATION IS IN EXPLICIT FORM - IOUT=0 ! --- OUTPUT ROUTINE IS NOT USED DURING INTEGRATION - IDFX=0 ! --- INTERNAL TIME DERIVATIVE - - DO i=1,20 - IWORK(i) = 0 - WORK(i) = 0.D0 - ENDDO - - IWORK(3) = 1 - - CALL ATMRODAS(NVAR,FUNC_CHEM,Autonomous,TIN,VAR,TOUT, - & STEPMIN,RTOL,ATOL,ITOL, - & JAC_CHEM,IJAC,MLJAC,MUJAC,FUNC_CHEM,IDFX, - & FUNC_CHEM,IMAS, - & WORK,LWORK,IWORK,LIWORK,IDID) - - IF (IDID.LT.0) THEN - print *,'ATMRODAS: Unsucessfull exit at T=', - & TIN,' (IDID=',IDID,')' - ENDIF - - - RETURN - END - - - SUBROUTINE ATMRODAS(N,FCN,IFCN,X,Y,XEND,H, - & RelTol,AbsTol,ITOL, - & JAC ,IJAC,MLJAC,MUJAC,DFX,IDFX, - & MAS ,IMAS, - & WORK,LWORK,IWORK,LIWORK,IDID) -C ---------------------------------------------------------- -C NUMERICAL SOLUTION OF A STIFF (OR DIFFERENTIAL ALGEBRAIC) -C SYSTEM OF FIRST 0RDER ORDINARY DIFFERENTIAL EQUATIONS MY'=F(X,Y). -C THIS IS AN EMBEDDED ROSENBROCK METHOD OF ORDER (3)4 -C (WITH STEP SIZE CONTROL). -C C.F. SECTIONS IV.7 AND VI.3 -C -C AUTHORS: E. HAIRER AND G. WANNER -C UNIVERSITE DE GENEVE, DEPT. DE MATHEMATIQUES -C CH-1211 GENEVE 24, SWITZERLAND -C E-MAIL: HAIRER@DIVSUN.UNIGE.CH, WANNER@DIVSUN.UNIGE.CH -C --------------------------------------------------------- -C *** *** *** *** *** *** *** *** *** *** *** *** *** -C DECLARATIONS -C *** *** *** *** *** *** *** *** *** *** *** *** *** - IMPLICIT KPP_REAL (A-H,O-Z) - DIMENSION Y(N),AbsTol(*),RelTol(*),WORK(LWORK),IWORK(LIWORK) - LOGICAL AUTNMS,IMPLCT,JBAND,ARRET,PRED - EXTERNAL FCN,JAC,DFX,MAS - COMMON /STATISTICS/ NFCN,NACCPT,NREJCT,NSTEP,NJAC,NDEC,NSOL -C *** *** *** *** *** *** *** -C SETTING THE PARAMETERS -C *** *** *** *** *** *** *** - ARRET=.FALSE. - METH = 1 - NMAX=100000 -C -------- PRED STEP SIZE CONTROL - IF(IWORK(3).LE.1)THEN - PRED=.TRUE. - ELSE - PRED=.FALSE. - END IF - UROUND=1.D-16 - NM1 = N - M1 = N - M2 = N -C -------- MAXIMAL STEP SIZE - IF(WORK(2).EQ.0.D0)THEN - HMAX=XEND-X - ELSE - HMAX=WORK(2) - END IF -C ------- FAC1,FAC2 PARAMETERS FOR STEP SIZE SELECTION - IF(WORK(3).EQ.0.D0)THEN - FAC1=5.D0 - ELSE - FAC1=1.D0/WORK(3) - END IF - IF(WORK(4).EQ.0.D0)THEN - FAC2=1.D0/6.0D0 - ELSE - FAC2=1.D0/WORK(4) - END IF - IF (FAC1.LT.1.0D0.OR.FAC2.GT.1.0D0) THEN - WRITE(6,*)' CURIOUS INPUT WORK(3,4)=',WORK(3),WORK(4) - ARRET=.TRUE. - END IF -C --------- SAFE SAFETY FACTOR IN STEP SIZE PREDICTION - SAFE=0.9D0 -C --------- CHECK IF TOLERANCES ARE O.K. - IF (ITOL.EQ.0) THEN - IF (AbsTol(1).LE.0.D0.OR.RelTol(1).LE.10.D0*UROUND) THEN - WRITE (6,*) ' TOLERANCES ARE TOO SMALL' - ARRET=.TRUE. - END IF - ELSE - DO I=1,N - IF (AbsTol(I).LE.0.D0.OR.RelTol(I).LE.10.D0*UROUND) THEN - WRITE (6,*) ' TOLERANCES(',I,') ARE TOO SMALL' - ARRET=.TRUE. - END IF - END DO - END IF - - IF (ARRET) STOP - NM1 = N -C *** *** *** *** *** *** *** *** *** *** *** *** *** -C COMPUTATION OF ARRAY ENTRIES -C *** *** *** *** *** *** *** *** *** *** *** *** *** -C ---- AUTONOMOUS, IMPLICIT, BANDED OR NOT ? - AUTNMS=IFCN.EQ.0 - IMPLCT=IMAS.NE.0 - JBAND=MLJAC.LT.NM1 -C -------- COMPUTATION OF THE ROW-DIMENSIONS OF THE 2-ARRAYS --- -C -- JACOBIAN AND MATRIX E - MLJAC=NM1 - MUJAC=NM1 - LDJAC=NM1 - LDE=NM1 -C -- MASS MATRIX - IF (IMPLCT) THEN - print *, 'Implicit 1' - ELSE - LDMAS=0 - IJOB=1 - END IF - LDMAS2=MAX(1,LDMAS) -C ------- PREPARE THE ENTRY-POINTS FOR THE ARRAYS IN WORK ----- - IEYNEW=21 - IEDY1=IEYNEW+N - IEDY=IEDY1+N - IEAK1=IEDY+N - IEAK2=IEAK1+N - IEAK3=IEAK2+N - IEAK4=IEAK3+N - IEAK5=IEAK4+N - IEAK6=IEAK5+N - IEFX =IEAK6+N - IECON=IEFX+N - IEJAC=IECON+4*N - IEMAS=IEJAC+N*LDJAC - IEE =IEMAS+NM1*LDMAS -C ------ TOTAL STORAGE REQUIREMENT ----------- - ISTORE=IEE+NM1*LDE-1 - IF(ISTORE.GT.LWORK)THEN - WRITE(6,*)' INSUFFICIENT STORAGE FOR WORK, MIN. LWORK=',ISTORE - ARRET=.TRUE. - END IF -C ------- ENTRY POINTS FOR INTEGER WORKSPACE ----- - IEIP=21 - ISTORE=IEIP+NM1-1 - IF(ISTORE.GT.LIWORK)THEN - WRITE(6,*)' INSUFF. STORAGE FOR IWORK, MIN. LIWORK=',ISTORE - ARRET=.TRUE. - END IF -C ------ WHEN A FAIL HAS OCCURED, WE RETURN WITH IDID=-1 - IF (ARRET) THEN - IDID=-1 - RETURN - END IF -C -------- CALL TO CORE INTEGRATOR ------------ - CALL ROSCOR(N,FCN,X,Y,XEND,HMAX,H,RelTol,AbsTol,ITOL,JAC,IJAC, - & MLJAC,MUJAC,DFX,IDFX,MAS,MLMAS,MUMAS,IOUT,IDID,NMAX, - & UROUND,METH,IJOB,FAC1,FAC2,SAFE,AUTNMS,IMPLCT,JBAND,PRED,LDJAC, - & LDE,LDMAS2,WORK(IEYNEW),WORK(IEDY1),WORK(IEDY),WORK(IEAK1), - & WORK(IEAK2),WORK(IEAK3),WORK(IEAK4),WORK(IEAK5),WORK(IEAK6), - & WORK(IEFX),WORK(IEJAC),WORK(IEE),WORK(IEMAS),IWORK(IEIP), - & WORK(IECON), - & M1,M2,NM1,NFCN,NJAC,NSTEP,NACCPT,NREJCT,NDEC,NSOL) - IWORK(14)=NFCN - IWORK(15)=NJAC - IWORK(16)=NSTEP - IWORK(17)=NACCPT - IWORK(18)=NREJCT - IWORK(19)=NDEC - IWORK(20)=NSOL -C ----------- RETURN ----------- - RETURN - END -C -C -C -C ----- ... AND HERE IS THE CORE INTEGRATOR ---------- -C - SUBROUTINE ROSCOR(N,FCN,X,Y,XEND,HMAX,H,RelTol,AbsTol, - & ITOL,JAC,IJAC, - & MLJAC,MUJAC,DFX,IDFX,MAS,MLMAS,MUMAS,IOUT,IDID,NMAX, - & UROUND,METH,IJOB,FAC1,FAC2,SAFE,AUTNMS,IMPLCT,BANDED, - & PRED,LDJAC, - & LDE,LDMAS,YNEW,DY1,DY,AK1,AK2,AK3,AK4,AK5,AK6, - & FX,FJAC,E,FMAS,IP,CONT, - & M1,M2,NM1,NFCN,NJAC,NSTEP,NACCPT,NREJCT,NDEC,NSOL) -C ---------------------------------------------------------- -C CORE INTEGRATOR FOR RODAS -C PARAMETERS SAME AS IN RODAS WITH WORKSPACE ADDED -C ---------------------------------------------------------- -C DECLARATIONS -C ---------------------------------------------------------- - IMPLICIT KPP_REAL (A-H,O-Z) - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_sparse.h' - DIMENSION Y(N),YNEW(N),DY1(N),DY(N),AK1(N), - * AK2(N),AK3(N),AK4(N),AK5(N),AK6(N),FX(N), - * FJAC(LU_NONZERO),E(LDE,NM1),FMAS(LDMAS,NM1), - * AbsTol(*),RelTol(*) - DIMENSION CONT(4*N) - INTEGER IP(NM1) - LOGICAL REJECT,AUTNMS,IMPLCT,BANDED - LOGICAL ONE,LAST,PRED,SINGULAR - EXTERNAL FCN, MAS, JAC, DFX - COMMON/LINAL/MLE,MUE,MBJAC,MBB,MDIAG,MDIFF,MBDIAG - COMMON /CONROS/XOLD,HOUT,NN -C *** *** *** *** *** *** *** -C INITIALISATIONS -C *** *** *** *** *** *** *** - NN=N - NN2=2*N - NN3=3*N - LRC=4*N -C ------- COMPUTE MASS MATRIX FOR IMPLICIT CASE ---------- - IF (IMPLCT) CALL MAS (NM1,FMAS,LDMAS) -C ------ SET THE PARAMETERS OF THE METHOD ----- - CALL ROCOE(METH,A21,A31,A32,A41,A42,A43,A51,A52,A53,A54, - & C21,C31,C32,C41,C42,C43,C51,C52,C53,C54,C61, - & C62,C63,C64,C65,GAMMA,C2,C3,C4,D1,D2,D3,D4, - & D21,D22,D23,D24,D25,D31,D32,D33,D34,D35) -C --- INITIAL PREPARATIONS - IF (M1.GT.0) IJOB=IJOB+10 - POSNEG=SIGN(1.D0,XEND-X) - HMAXN=DMIN1(DABS(HMAX),DABS(XEND-X)) - IF (DABS(H).LE.10.D0*UROUND) H=1.0D-6 - H=DMIN1(DABS(H),HMAXN) - H=SIGN(H,POSNEG) - HACC = H - ERRACC = 1.0d0 - REJECT=.FALSE. - LAST=.FALSE. - NSING=0 - IRTRN=1 - IF (AUTNMS) THEN - HD1=0.0D0 - HD2=0.0D0 - HD3=0.0D0 - HD4=0.0D0 - END IF -C -------- PREPARE BAND-WIDTHS -------- - MBDIAG=MUMAS+1 - -C --- BASIC INTEGRATION STEP - LAST = .FALSE. - DO WHILE (.NOT.LAST) - IF (.NOT. REJECT) THEN - IF (NSTEP.GT.NMAX) CALL FAIL_EXIT(3,X,IDID,H,NMAX) - IF ( 0.1D0*DABS(H) .LE. DABS(X)*UROUND ) - * CALL FAIL_EXIT(2,X,IDID,H,NMAX) - HOPT=H - IF ((X+H*1.0001D0-XEND)*POSNEG.GE.0.D0) THEN - H=XEND-X - LAST=.TRUE. - END IF -C *** *** *** *** *** *** *** -C COMPUTATION OF THE JACOBIAN -C *** *** *** *** *** *** *** - CALL FCN(N,X,Y,DY1) - CALL JAC(N,X,Y,FJAC,LDJAC) - NFCN=NFCN+1 - NJAC=NJAC+1 - - IF (.NOT.AUTNMS) THEN -C --- COMPUTE NUMERICALLY THE DERIVATIVE WITH RESPECT TO X - DELT=DSQRT(UROUND*DMAX1(1.D-5,DABS(X))) - XDELT=X+DELT - CALL FCN(N,XDELT,Y,AK1) - DO J=1,N - FX(J)=(AK1(J)-DY1(J))/DELT - END DO - END IF - END IF - -C *** *** *** *** *** *** *** -C COMPUTE THE STAGES -C *** *** *** *** *** *** *** - SINGULAR = .TRUE. - DO WHILE (SINGULAR) - FAC=1.D0/(H*GAMMA) - CALL DECOMR(N,FJAC,LDJAC,FMAS,LDMAS,MLMAS,MUMAS, - & M1,M2,NM1,FAC,E,LDE,IP,IER,IJOB,IMPLCT,IP) - SINGULAR = IER.NE.0 - IF (SINGULAR) THEN - NSING=NSING+1 - IF (NSING.GE.5) CALL FAIL_EXIT(1,X,IDID,H,NMAX) - H=H*0.5D0 - REJECT=.TRUE. - LAST=.FALSE. - ONE = .FALSE. - END IF - END DO - - NDEC=NDEC+1 -C --- PREPARE FOR THE COMPUTATION OF THE 6 STAGES - HC21=C21/H - HC31=C31/H - HC32=C32/H - HC41=C41/H - HC42=C42/H - HC43=C43/H - HC51=C51/H - HC52=C52/H - HC53=C53/H - HC54=C54/H - HC61=C61/H - HC62=C62/H - HC63=C63/H - HC64=C64/H - HC65=C65/H - IF (.NOT.AUTNMS) THEN - HD1=H*D1 - HD2=H*D2 - HD3=H*D3 - HD4=H*D4 - END IF -C --- THE STAGES - CALL SLVROD(N,FJAC,LDJAC,MLJAC,MUJAC,FMAS,LDMAS,MLMAS,MUMAS, - & M1,M2,NM1,FAC,E,LDE,IP,DY1,AK1,FX,YNEW,HD1,IJOB,.FALSE.) - DO I=1,N - YNEW(I)=Y(I)+A21*AK1(I) - END DO - CALL FCN(N,X+C2*H,YNEW,DY) - DO I=1,N - YNEW(I)=HC21*AK1(I) - END DO - CALL SLVROD(N,FJAC,LDJAC,MLJAC,MUJAC,FMAS,LDMAS,MLMAS,MUMAS, - & M1,M2,NM1,FAC,E,LDE,IP,DY,AK2,FX,YNEW,HD2,IJOB,.TRUE.) - DO I=1,N - YNEW(I)=Y(I)+A31*AK1(I)+A32*AK2(I) - END DO - CALL FCN(N,X+C3*H,YNEW,DY) - DO I=1,N - YNEW(I)=HC31*AK1(I)+HC32*AK2(I) - END DO - CALL SLVROD(N,FJAC,LDJAC,MLJAC,MUJAC,FMAS,LDMAS,MLMAS,MUMAS, - & M1,M2,NM1,FAC,E,LDE,IP,DY,AK3,FX,YNEW,HD3,IJOB,.TRUE.) - DO I=1,N - YNEW(I)=Y(I)+A41*AK1(I)+A42*AK2(I)+A43*AK3(I) - END DO - CALL FCN(N,X+C4*H,YNEW,DY) - DO I=1,N - YNEW(I)=HC41*AK1(I)+HC42*AK2(I)+HC43*AK3(I) - END DO - CALL SLVROD(N,FJAC,LDJAC,MLJAC,MUJAC,FMAS,LDMAS,MLMAS,MUMAS, - & M1,M2,NM1,FAC,E,LDE,IP,DY,AK4,FX,YNEW,HD4,IJOB,.TRUE.) - DO I=1,N - YNEW(I)=Y(I)+A51*AK1(I)+A52*AK2(I)+A53*AK3(I)+A54*AK4(I) - END DO - CALL FCN(N,X+H,YNEW,DY) - DO I=1,N - AK6(I)=HC52*AK2(I)+HC54*AK4(I)+HC51*AK1(I)+HC53*AK3(I) - END DO - CALL SLVROD(N,FJAC,LDJAC,MLJAC,MUJAC,FMAS,LDMAS,MLMAS,MUMAS, - & M1,M2,NM1,FAC,E,LDE,IP,DY,AK5,FX,AK6,0.D0,IJOB,.TRUE.) -C ------------ EMBEDDED SOLUTION --------------- - DO I=1,N - YNEW(I)=YNEW(I)+AK5(I) - END DO - CALL FCN(N,X+H,YNEW,DY) - DO I=1,N - AK5(I)=HC61*AK1(I)+HC62*AK2(I)+HC65*AK5(I) - & +HC64*AK4(I)+HC63*AK3(I) - END DO - CALL SLVROD(N,FJAC,LDJAC,MLJAC,MUJAC,FMAS,LDMAS,MLMAS,MUMAS, - & M1,M2,NM1,FAC,E,LDE,IP,DY,AK6,FX,AK5,0.D0,IJOB,.TRUE.) -C ------------ NEW SOLUTION --------------- - DO I=1,N - YNEW(I)=YNEW(I)+AK6(I) - END DO - NSOL=NSOL+6 - NFCN=NFCN+5 - -C *** *** *** *** *** *** *** -C ERROR ESTIMATION -C *** *** *** *** *** *** *** - NSTEP=NSTEP+1 -C ------------ COMPUTE ERROR ESTIMATION ---------------- - ERR=0.0D0 - DO I=1,N - IF (ITOL.EQ.0) THEN - SK=AbsTol(1)+RelTol(1)*DMAX1(DABS(Y(I)),DABS(YNEW(I))) - ELSE - SK=AbsTol(I)+RelTol(I)*DMAX1(DABS(Y(I)),DABS(YNEW(I))) - END IF - ERR=ERR+(AK6(I)/SK)**2 -c2 ERR = DMAX1(ERR, AK6(I)/SK) - END DO - ERR=DSQRT(ERR/N) - -C --- COMPUTATION OF HNEW -C --- WE REQUIRE .2<=HNEW/H<=6. - FAC=DMAX1(FAC2,DMIN1(FAC1,(ERR)**0.25D0/SAFE)) - HNEW=DMAX1(H/FAC, STEPMIN) - -C *** *** *** *** *** *** *** -C IS THE ERROR SMALL ENOUGH ? -C *** *** *** *** *** *** *** - - IF ( (ERR.LE.1.D0).or.(H.LE.STEPMIN) ) THEN -C --- STEP IS ACCEPTED - NACCPT=NACCPT+1 - IF (PRED) THEN -C --- PREDICTIVE CONTROLLER OF GUSTAFSSON - IF (NACCPT.GT.1) THEN - FACGUS=(HACC/H)*(ERR**2/ERRACC)**0.25D0/SAFE - FACGUS=DMAX1(FAC2,DMIN1(FAC1,FACGUS)) - FAC=DMAX1(FAC,FACGUS) - HNEW=DMAX1(H/FAC, STEPMIN) - END IF - HACC=H - ERRACC=DMAX1(1.0D-2,ERR) - END IF - DO I=1,N - Y(I)=YNEW(I) - END DO - XOLD=X - X=X+H - IF (DABS(HNEW).GT.HMAXN) HNEW=POSNEG*HMAXN - IF (REJECT) HNEW=POSNEG*DMIN1(DABS(HNEW),DABS(H)) - REJECT=.FALSE. - H=HNEW - ELSE -C --- STEP IS REJECTED - REJECT=.TRUE. - LAST=.FALSE. - H=HNEW - IF (NACCPT.GE.1) NREJCT=NREJCT+1 - END IF - END DO - RETURN - END -C - SUBROUTINE FAIL_EXIT(NERR,X,IDID,H,NMAX) - INTEGER NERR, NMAX - KPP_REAL X, H - GO TO (1,2,3,4) NERR - 1 CONTINUE - WRITE(6,979)X - WRITE(6,*) ' MATRIX IS REPEATEDLY SINGULAR, IER=',IER - IDID=-4 - STOP - 2 CONTINUE - WRITE(6,979)X - WRITE(6,*) ' STEP SIZE TOO SMALL, H=',H - IDID=-3 - STOP - 3 CONTINUE - WRITE(6,979)X - WRITE(6,*) ' MORE THAN NMAX =',NMAX,'STEPS ARE NEEDED' - IDID=-2 - STOP -C --- EXIT CAUSED BY solout - 4 CONTINUE - WRITE(6,979)X - 979 FORMAT(' EXIT OF RODAS AT X=',E18.4) - IDID=2 - RETURN - END - - SUBROUTINE ROCOE(METH,A21,A31,A32,A41,A42,A43,A51,A52,A53,A54, - & C21,C31,C32,C41,C42,C43,C51,C52,C53,C54,C61, - & C62,C63,C64,C65,GAMMA,C2,C3,C4,D1,D2,D3,D4, - & D21,D22,D23,D24,D25,D31,D32,D33,D34,D35) - IMPLICIT KPP_REAL (A-H,O-Z) - - if (METH.ne.1) print *, 'WRONG CHOICE OF METHOD' - C2=0.386D0 - C3=0.21D0 - C4=0.63D0 - BET2P=0.0317D0 - BET3P=0.0635D0 - BET4P=0.3438D0 - D1= 0.2500000000000000D+00 - D2=-0.1043000000000000D+00 - D3= 0.1035000000000000D+00 - D4=-0.3620000000000023D-01 - A21= 0.1544000000000000D+01 - A31= 0.9466785280815826D+00 - A32= 0.2557011698983284D+00 - A41= 0.3314825187068521D+01 - A42= 0.2896124015972201D+01 - A43= 0.9986419139977817D+00 - A51= 0.1221224509226641D+01 - A52= 0.6019134481288629D+01 - A53= 0.1253708332932087D+02 - A54=-0.6878860361058950D+00 - C21=-0.5668800000000000D+01 - C31=-0.2430093356833875D+01 - C32=-0.2063599157091915D+00 - C41=-0.1073529058151375D+00 - C42=-0.9594562251023355D+01 - C43=-0.2047028614809616D+02 - C51= 0.7496443313967647D+01 - C52=-0.1024680431464352D+02 - C53=-0.3399990352819905D+02 - C54= 0.1170890893206160D+02 - C61= 0.8083246795921522D+01 - C62=-0.7981132988064893D+01 - C63=-0.3152159432874371D+02 - C64= 0.1631930543123136D+02 - C65=-0.6058818238834054D+01 - GAMMA= 0.2500000000000000D+00 - - D21= 0.1012623508344586D+02 - D22=-0.7487995877610167D+01 - D23=-0.3480091861555747D+02 - D24=-0.7992771707568823D+01 - D25= 0.1025137723295662D+01 - D31=-0.6762803392801253D+00 - D32= 0.6087714651680015D+01 - D33= 0.1643084320892478D+02 - D34= 0.2476722511418386D+02 - D35=-0.6594389125716872D+01 - RETURN - END -C - -C ****************************************** -C VERSION OF SEPTEMBER 18, 1995 -C ****************************************** -C - SUBROUTINE DECOMR(N,FJAC,LDJAC,FMAS,LDMAS,MLMAS,MUMAS, - & M1,M2,NM1,FAC1,E1,LDE1,IP1,IER,IJOB,CALHES,IPHES) - IMPLICIT KPP_REAL (A-H,O-Z) - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_sparse.h' - DIMENSION FJAC(LU_NONZERO),FMAS(LDMAS,NM1),E1(LU_NONZERO), - & IP1(NM1),IPHES(N) - LOGICAL CALHES - COMMON/LINAL/MLE,MUE,MBJAC,MBB,MDIAG,MDIFF,MBDIAG -C - - -C --- B=IDENTITY, JACOBIAN A FULL MATRIX - DO J=1,LU_NONZERO - E1(J) = -FJAC(J) - END DO - DO J=1,N - E1(LU_DIAG(J)) = E1(LU_DIAG(J)) + FAC1 - END DO - CALL KppDecomp (E1,IER) - RETURN - END -C -C END OF SUBROUTINE DECOMR -C -C *********************************************************** -C -C -C -C - SUBROUTINE SLVROD(N,FJAC,LDJAC,MLJAC,MUJAC,FMAS,LDMAS,MLMAS,MUMAS, - & M1,M2,NM1,FAC1,E,LDE,IP,DY,AK,FX,YNEW,HD,IJOB,STAGE1) - IMPLICIT KPP_REAL (A-H,O-Z) - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_sparse.h' - DIMENSION FJAC(LU_NONZERO),FMAS(LDMAS,NM1),E(LU_NONZERO), - & IP(NM1),DY(N),AK(N),FX(N),YNEW(N) - LOGICAL STAGE1 - COMMON/LINAL/MLE,MUE,MBJAC,MBB,MDIAG,MDIFF,MBDIAG -C - IF (HD.EQ.0.D0) THEN - DO I=1,N - AK(I)=DY(I) - END DO - ELSE - DO I=1,N - AK(I)=DY(I)+HD*FX(I) - END DO - END IF - -C --- B=IDENTITY, JACOBIAN A FULL MATRIX - IF (STAGE1) THEN - DO I=1,N - AK(I)=AK(I)+YNEW(I) - END DO - END IF - CALL KppSolve (E,AK) - RETURN - END -C -C END OF SUBROUTINE SLVROD -C -C -C *********************************************************** - - - SUBROUTINE FUNC_CHEM(N, T, Y, P) - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - INTEGER N - KPP_REAL T, Told - KPP_REAL Y(NVAR), P(NVAR) - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Fun( Y, FIX, RCONST, P ) - TIME = Told - RETURN - END - - - SUBROUTINE JAC_CHEM(N, T, Y, J) - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - INTEGER N - KPP_REAL Told, T - KPP_REAL Y(NVAR), J(LU_NONZERO) - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Jac_SP( Y, FIX, RCONST, J ) - TIME = Told - RETURN - END diff --git a/boxmox/int/oldies/kpp_ros4.def b/boxmox/int/oldies/kpp_ros4.def deleted file mode 100644 index a51d99aa3f84b2658ea25678971af8a762bf57d6..0000000000000000000000000000000000000000 --- a/boxmox/int/oldies/kpp_ros4.def +++ /dev/null @@ -1,23 +0,0 @@ - -#FUNCTION AGGREGATE -#JACOBIAN SPARSE_LU_ROW - -#DOUBLE ON -#INTFILE kpp_ros4 - -#INLINE F77_DECL_INT - INTEGER Autonomous - COMMON /INTGDATA/ Autonomous - REAL*8 STEPSTART - COMMON /GDATA/ STEPSTART -#ENDINLINE - -#INLINE F77_INIT_INT - STEPMIN=0.0001 - STEPMAX=3600. - Autonomous = 1 - STEPSTART=STEPMIN -#ENDINLINE - - - diff --git a/boxmox/int/oldies/kpp_ros4.f b/boxmox/int/oldies/kpp_ros4.f deleted file mode 100644 index 6e62b312585edff8f4c0e5ad3e20c1b285a5629e..0000000000000000000000000000000000000000 --- a/boxmox/int/oldies/kpp_ros4.f +++ /dev/null @@ -1,1052 +0,0 @@ - SUBROUTINE INTEGRATE( TIN, TOUT ) - - IMPLICIT KPP_REAL (A-H,O-Z) - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - -C TIN - Start Time - KPP_REAL TIN -C TOUT - End Time - KPP_REAL TOUT - INTEGER i - - PARAMETER (LWORK=2*NVAR*NVAR+14*NVAR+20,LIWORK=NVAR+20) - KPP_REAL WORK(LWORK) - INTEGER IWORK(LIWORK) - EXTERNAL FUNC_CHEM,JAC_CHEM,SOLOUT - - ITOL=1 ! --- VECTOR TOLERANCES - IJAC=1 ! --- COMPUTE THE JACOBIAN ANALYTICALLY - MLJAC=NVAR ! --- JACOBIAN IS A FULL MATRIX - MUJAC=NVAR ! --- JACOBIAN IS A FULL MATRIX - IMAS=0 ! --- DIFFERENTIAL EQUATION IS IN EXPLICIT FORM - IOUT=0 ! --- OUTPUT ROUTINE IS NOT USED DURING INTEGRATION - IDFX=0 ! --- INTERNAL TIME DERIVATIVE - - DO i=1,20 - IWORK(i) = 0 - WORK(i) = 0.D0 - ENDDO - IWORK(2) = 6 - - CALL KPP_ROS4(NVAR,FUNC_CHEM,Autonomous,TIN,VAR,TOUT, - & STEPMIN,RTOL,ATOL,ITOL, - & JAC_CHEM,IJAC,MLJAC,MUJAC,FUNC_CHEM,IDFX, - & FUNC_CHEM,IMAS,MLJAC,MUJAC, - & SOLOUT,IOUT, - & WORK,LWORK,IWORK,LIWORK,IDID) - - IF (IDID.LT.0) THEN - print *,'KPP_ROS4: Unsucessful step at T=', - & TIN,' (IDID=',IDID,')' - ENDIF - - RETURN - END - - - SUBROUTINE KPP_ROS4(N,FCN,IFCN,X,Y,XEND,H, - & RelTol,AbsTol,ITOL, - & JAC ,IJAC,MLJAC,MUJAC,DFX,IDFX, - & MAS ,IMAS,MLMAS,MUMAS, - & SOLOUT,IOUT, - & WORK,LWORK,IWORK,LIWORK,IDID) -C ---------------------------------------------------------- -C NUMERICAL SOLUTION OF A STIFF (OR DIFFERENTIAL ALGEBRAIC) -C SYSTEM OF FIRST 0RDER ORDINARY DIFFERENTIAL EQUATIONS MY'=F(X,Y). -C THIS IS AN EMBEDDED ROSENBROCK METHOD OF ORDER (3)4 -C (WITH STEP SIZE CONTROL). -C C.F. SECTION IV.7 -C -C AUTHORS: E. HAIRER AND G. WANNER -C UNIVERSITE DE GENEVE, DEPT. DE MATHEMATIQUES -C CH-1211 GENEVE 24, SWITZERLAND -C E-MAIL: HAIRER@CGEUGE51.BITNET, WANNER@CGEUGE51.BITNET -C -C THIS CODE IS PART OF THE BOOK: -C E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL -C EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS. -C SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS, -C SPRINGER-VERLAG (1990) -C -C VERSION OF NOVEMBER 17, 1992 -C -C INPUT PARAMETERS -C ---------------- -C N DIMENSION OF THE SYSTEM -C -C FCN NAME (EXTERNAL) OF SUBROUTINE COMPUTING THE -C VALUE OF F(X,Y): -C SUBROUTINE FCN(N,X,Y,F) -C KPP_REAL X,Y(N),F(N) -C F(1)=... ETC. -C -C IFCN GIVES INFORMATION ON FCN: -C IFCN=0: F(X,Y) INDEPENDENT OF X (AUTONOMOUS) -C IFCN=1: F(X,Y) MAY DEPEND ON X (NON-AUTONOMOUS) -C -C X INITIAL X-VALUE -C -C Y(N) INITIAL VALUES FOR Y -C -C XEND FINAL X-VALUE (XEND-X MAY BE POSITIVE OR NEGATIVE) -C -C H INITIAL STEP SIZE GUESS; -C FOR STIFF EQUATIONS WITH INITIAL TRANSIENT, -C H=1.D0/(NORM OF F'), USUALLY 1.D-2 OR 1.D-3, IS GOOD. -C THIS CHOICE IS NOT VERY IMPORTANT, THE CODE QUICKLY -C ADAPTS ITS STEP SIZE. STUDY THE CHOSEN VALUES FOR A FEW -C STEPS IN SUBROUTINE "SOLOUT", WHEN YOU ARE NOT SURE. -C (IF H=0.D0, THE CODE PUTS H=1.D-6). -C -C RelTol,AbsTol RELATIVE AND ABSOLUTE ERROR TOLERANCES. THEY -C CAN BE BOTH SCALARS OR ELSE BOTH VECTORS OF LENGTH N. -C -C ITOL SWITCH FOR RelTol AND AbsTol: -C ITOL=0: BOTH RelTol AND AbsTol ARE SCALARS. -C THE CODE KEEPS, ROUGHLY, THE LOCAL ERROR OF -C Y(I) BELOW RelTol*ABS(Y(I))+AbsTol -C ITOL=1: BOTH RelTol AND AbsTol ARE VECTORS. -C THE CODE KEEPS THE LOCAL ERROR OF Y(I) BELOW -C RelTol(I)*ABS(Y(I))+AbsTol(I). -C -C JAC NAME (EXTERNAL) OF THE SUBROUTINE WHICH COMPUTES -C THE PARTIAL DERIVATIVES OF F(X,Y) WITH RESPECT TO Y -C (THIS ROUTINE IS ONLY CALLED IF IJAC=1; SUPPLY -C A DUMMY SUBROUTINE IN THE CASE IJAC=0). -C FOR IJAC=1, THIS SUBROUTINE MUST HAVE THE FORM -C SUBROUTINE JAC(N,X,Y,DFY,LDFY) -C KPP_REAL X,Y(N),DFY(LDFY,N) -C DFY(1,1)= ... -C LDFY, THE COLOMN-LENGTH OF THE ARRAY, IS -C FURNISHED BY THE CALLING PROGRAM. -C IF (MLJAC.EQ.N) THE JACOBIAN IS SUPPOSED TO -C BE FULL AND THE PARTIAL DERIVATIVES ARE -C STORED IN DFY AS -C DFY(I,J) = PARTIAL F(I) / PARTIAL Y(J) -C ELSE, THE JACOBIAN IS TAKEN AS BANDED AND -C THE PARTIAL DERIVATIVES ARE STORED -C DIAGONAL-WISE AS -C DFY(I-J+MUJAC+1,J) = PARTIAL F(I) / PARTIAL Y(J). -C -C IJAC SWITCH FOR THE COMPUTATION OF THE JACOBIAN: -C IJAC=0: JACOBIAN IS COMPUTED INTERNALLY BY FINITE -C DIFFERENCES, SUBROUTINE "JAC" IS NEVER CALLED. -C IJAC=1: JACOBIAN IS SUPPLIED BY SUBROUTINE JAC. -C -C MLJAC SWITCH FOR THE BANDED STRUCTURE OF THE JACOBIAN: -C MLJAC=N: JACOBIAN IS A FULL MATRIX. THE LINEAR -C ALGEBRA IS DONE BY FULL-MATRIX GAUSS-ELIMINATION. -C 0<=MLJAC= NUMBER OF NON-ZERO DIAGONALS BELOW -C THE MAIN DIAGONAL). -C -C MUJAC UPPER BANDWITH OF JACOBIAN MATRIX (>= NUMBER OF NON- -C ZERO DIAGONALS ABOVE THE MAIN DIAGONAL). -C NEED NOT BE DEFINED IF MLJAC=N. -C -C DFX NAME (EXTERNAL) OF THE SUBROUTINE WHICH COMPUTES -C THE PARTIAL DERIVATIVES OF F(X,Y) WITH RESPECT TO X -C (THIS ROUTINE IS ONLY CALLED IF IDFX=1 AND IFCN=1; -C SUPPLY A DUMMY SUBROUTINE IN THE CASE IDFX=0 OR IFCN=0). -C OTHERWISE, THIS SUBROUTINE MUST HAVE THE FORM -C SUBROUTINE DFX(N,X,Y,FX) -C KPP_REAL X,Y(N),FX(N) -C FX(1)= ... -C -C IDFX SWITCH FOR THE COMPUTATION OF THE DF/DX: -C IDFX=0: DF/DX IS COMPUTED INTERNALLY BY FINITE -C DIFFERENCES, SUBROUTINE "DFX" IS NEVER CALLED. -C IDFX=1: DF/DX IS SUPPLIED BY SUBROUTINE DFX. -C -C ---- MAS,IMAS,MLMAS, AND MUMAS HAVE ANALOG MEANINGS ----- -C ---- FOR THE "MASS MATRIX" (THE MATRIX "M" OF SECTION IV.8): - -C -C MAS NAME (EXTERNAL) OF SUBROUTINE COMPUTING THE MASS- -C MATRIX M. -C IF IMAS=0, THIS MATRIX IS ASSUMED TO BE THE IDENTITY -C MATRIX AND NEEDS NOT TO BE DEFINED; -C SUPPLY A DUMMY SUBROUTINE IN THIS CASE. -C IF IMAS=1, THE SUBROUTINE MAS IS OF THE FORM -C SUBROUTINE MAS(N,AM,LMAS) -C KPP_REAL AM(LMAS,N) -C AM(1,1)= .... -C IF (MLMAS.EQ.N) THE MASS-MATRIX IS STORED -C AS FULL MATRIX LIKE -C AM(I,J) = M(I,J) -C ELSE, THE MATRIX IS TAKEN AS BANDED AND STORED -C DIAGONAL-WISE AS -C AM(I-J+MUMAS+1,J) = M(I,J). -C -C IMAS GIVES INFORMATION ON THE MASS-MATRIX: -C IMAS=0: M IS SUPPOSED TO BE THE IDENTITY -C MATRIX, MAS IS NEVER CALLED. -C IMAS=1: MASS-MATRIX IS SUPPLIED. -C -C MLMAS SWITCH FOR THE BANDED STRUCTURE OF THE MASS-MATRIX: -C MLMAS=N: THE FULL MATRIX CASE. THE LINEAR -C ALGEBRA IS DONE BY FULL-MATRIX GAUSS-ELIMINATION. -C 0<=MLMAS= NUMBER OF NON-ZERO DIAGONALS BELOW -C THE MAIN DIAGONAL). -C MLMAS IS SUPPOSED TO BE .LE. MLJAC. -C -C MUMAS UPPER BANDWITH OF MASS-MATRIX (>= NUMBER OF NON- -C ZERO DIAGONALS ABOVE THE MAIN DIAGONAL). -C NEED NOT BE DEFINED IF MLMAS=N. -C MUMAS IS SUPPOSED TO BE .LE. MUJAC. -C -C SOLOUT NAME (EXTERNAL) OF SUBROUTINE PROVIDING THE -C NUMERICAL SOLUTION DURING INTEGRATION. -C IF IOUT=1, IT IS CALLED AFTER EVERY SUCCESSFUL STEP. -C SUPPLY A DUMMY SUBROUTINE IF IOUT=0. -C IT MUST HAVE THE FORM -C SUBROUTINE SOLOUT (NR,XOLD,X,Y,N,IRTRN) -C KPP_REAL X,Y(N) -C .... -C SOLOUT FURNISHES THE SOLUTION "Y" AT THE NR-TH -C GRID-POINT "X" (THEREBY THE INITIAL VALUE IS -C THE FIRST GRID-POINT). -C "IRTRN" SERVES TO INTERRUPT THE INTEGRATION. IF IRTRN -C IS SET <0, ROS4 RETURNS TO THE CALLING PROGRAM. -C -C IOUT GIVES INFORMATION ON THE SUBROUTINE SOLOUT: -C IOUT=0: SUBROUTINE IS NEVER CALLED -C IOUT=1: SUBROUTINE IS USED FOR OUTPUT -C -C WORK ARRAY OF WORKING SPACE OF LENGTH "LWORK". -C SERVES AS WORKING SPACE FOR ALL VECTORS AND MATRICES. -C "LWORK" MUST BE AT LEAST -C N*(LJAC+LMAS+LE1+8)+5 -C WHERE -C LJAC=N IF MLJAC=N (FULL JACOBIAN) -C LJAC=MLJAC+MUJAC+1 IF MLJAC 0, fast -> 1e20 -C - - SUBROUTINE INTEGRATE( TIN, TOUT ) - - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - -C TIN - Start Time - KPP_REAL TIN -C TOUT - End Time - KPP_REAL TOUT - -C Local variables - KPP_REAL P_VAR(NVAR), D_VAR(NVAR), V1(NVAR), V2(NVAR) - LOGICAL IsReject - KPP_REAL T, Tnext, STEP, STEPold, Told, SUP - KPP_REAL ERR, ERRold, ratio, factor, facmax, tmp - INTEGER i - KPP_REAL slow, fast - - T = TIN - Tnext = TOUT - STEP = DMAX1(STEPMIN,1.d-10) - Told = T - SUP = 1e-14 - IsReject = .false. - ERR = 1.d0 - ERRold = 1.d0 - slow = 0.01 - fast = 10. - - 10 continue - Tplus = T + STEP - if ( Tplus .gt. Tnext ) then - STEP = Tnext - T - Tplus = Tnext - end if - - - TITI = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - TIME = TITI - CALL FSPLIT_VAR ( VAR, P_VAR, D_VAR ) - - do i=1,NVAR - IF ( D_VAR(i)*STEP .lt. slow) THEN ! SLOW SPECIES - XXX = STEP * (P_VAR(i) - D_VAR(i)*VAR(i)) - V1(i) = VAR(i) + XXX - V2(i) = VAR(i) + 0.5*XXX - ELSE IF ( D_VAR(i)*STEP .GT. fast) THEN ! FAST SPECIES - V1(i) = P_VAR(i)/D_VAR(i) - V2(i) = V1(i) - ELSE ! MEDIUM LIVED - if ( abs(D_VAR(i)).gt.SUP ) then - ratio = P_VAR(i)/D_VAR(i) - tmp = exp(-D_VAR(i)*STEP*0.5) - V1(i) = tmp * tmp * (VAR(i) - ratio) + ratio - V2(i) = tmp * (VAR(i) - ratio) + ratio - else - tmp = D_VAR(i) * STEP * 0.5 - V1(i) = VAR(i) + P_VAR(i) * STEP * ( 1 - tmp * - * ( 1 - 2.0 / 3.0 * tmp ) ) - V2(i) = VAR(i) + P_VAR(i) * 0.5 * STEP*( 1-0.5*tmp* - * ( 1 - 1.0 / 3.0 * tmp ) ) - end if - END IF - end do - - TITI = TIME - TIME = T + 0.5*STEP - CALL Update_SUN() - CALL Update_RCONST() - TIME = TITI - CALL FSPLIT_VAR ( V2, P_VAR, D_VAR ) - - do i=1,NVAR - IF ( D_VAR(i)*STEP .lt. slow) THEN ! SLOW SPECIES - XXX = STEP * (P_VAR(i) - D_VAR(i)*VAR(i)) - V2(i) = V2(i) + 0.5*XXX - ELSE IF ( D_VAR(i)*STEP .GT. fast) THEN ! FAST SPECIES - V2(i) = P_VAR(i)/D_VAR(i) - ELSE ! MEDIUM LIVED - if ( abs(D_VAR(i)).gt.SUP ) then - ratio = P_VAR(i)/D_VAR(i) - tmp = exp(-D_VAR(i)*STEP*0.5) - V2(i) = tmp * (V2(i) - ratio) + ratio - else - tmp = D_VAR(i) * STEP * 0.5 - V2(i) = V2(i) + P_VAR(i) * 0.5 * STEP * ( 1 - 0.5 * tmp * - * ( 1 - 1.0 / 3.0 * tmp ) ) - end if - END IF - end do - -C ===== Extrapolation and error estimation ======== - - ERRold=ERR - ERR=0.0D0 - do i=1,NVAR - ERR = ERR + ((V2(i)-V1(i))/(ATOL(i) + RTOL(i)*V2(i)))**2 - end do - ERR = DSQRT( ERR/NVAR ) - STEPold=STEP - -C ===== choosing the stepsize ===================== - - factor = 0.9*ERR**(-0.35)*ERRold**0.2 - if (IsReject) then - facmax=1. - else - facmax=8. - end if - factor = DMAX1( 1.25D-1, DMIN1(factor,facmax) ) - STEP = DMIN1( STEPMAX, DMAX1(STEPMIN,factor*STEP) ) - -C=================================================== - - if ( (ERR.gt.1).and.(STEPold.gt.STEPMIN) ) then - IsReject = .true. - else - IsReject = .false. - do 140 i=1,NVAR - VAR(i) = DMAX1(V2(i), 0.d0) - 140 continue - T = Tplus - end if - if ( T .lt. Tnext ) go to 10 - - TIME = Tnext - RETURN - END diff --git a/boxmox/int/oldies/qssa1.f b/boxmox/int/oldies/qssa1.f deleted file mode 100644 index 71e1620495e6c62d62fddff953d245b45e665235..0000000000000000000000000000000000000000 --- a/boxmox/int/oldies/qssa1.f +++ /dev/null @@ -1,136 +0,0 @@ -C -- QSSA WITH STEADY STATE APPROXIMATION -- -C For plain QSSA (to remove the steady state assumption) -C modify slow -> 0, fast -> 1e20 -C - - SUBROUTINE INTEGRATE( TIN, TOUT ) - - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - -C TIN - Start Time - KPP_REAL TIN -C TOUT - End Time - KPP_REAL TOUT - -C Local variables - KPP_REAL P_VAR(NVAR), D_VAR(NVAR), V1(NVAR), V2(NVAR) - LOGICAL IsReject - KPP_REAL T, Tnext, STEP, STEPold, Told, SUP - KPP_REAL ERR, ERRold, ratio, factor, facmax, tmp - INTEGER I - KPP_REAL slow, fast - - T = TIN - Tnext = TOUT - STEP = DMAX1(STEPMIN,1.d-10) - Told = T - SUP = 1e-14 - IsReject = .false. - ERR = 1.d0 - ERRold = 1.d0 - slow = 0.01 - fast = 10. - - 10 continue - Tplus = T + STEP - if ( Tplus .gt. Tnext ) then - STEP = Tnext - T - Tplus = Tnext - end if - - - TITI = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - TIME = TITI - CALL FSPLIT_VAR ( VAR, P_VAR, D_VAR ) - - do i=1,NVAR - IF ( D_VAR(i)*step .lt. slow) THEN ! SLOW SPECIES - XXX = STEP * (P_VAR(I) - D_VAR(I)*VAR(I)) - V1(I) = VAR(I) + XXX - V2(I) = VAR(I) + 0.5*XXX - ELSE IF ( D_VAR(i)*step .GT. fast) THEN ! FAST SPECIES - V1(I) = P_VAR(I)/D_VAR(I) - V2(I) = V1(I) - ELSE ! MEDIUM LIVED - if ( abs(D_VAR(i)).gt.SUP ) then - ratio = P_VAR(i)/D_VAR(i) - tmp = exp(-D_VAR(i)*STEP*0.5) - V1(i) = tmp * tmp * (VAR(i) - ratio) + ratio - V2(i) = tmp * (VAR(i) - ratio) + ratio - else - tmp = D_VAR(i) * STEP * 0.5 - V1(i) = VAR(i) + P_VAR(i) * STEP * ( 1 - tmp * - * ( 1 - 2.0 / 3.0 * tmp ) ) - V2(i) = VAR(i) + P_VAR(i) * 0.5 * STEP*( 1-0.5*tmp* - * ( 1 - 1.0 / 3.0 * tmp ) ) - end if - END IF - end do - - TITI = TIME - TIME = T + 0.5*STEP - CALL Update_SUN() - CALL Update_RCONST() - TIME = TITI - CALL FSPLIT_VAR ( V2, P_VAR, D_VAR ) - - do i=1,NVAR - IF ( D_VAR(i)*step .lt. slow) THEN ! SLOW SPECIES - XXX = STEP * (P_VAR(I) - D_VAR(I)*VAR(I)) - V2(I) = V2(I) + 0.5*XXX - ELSE IF ( D_VAR(i)*step .GT. fast) THEN ! FAST SPECIES - V2(I) = P_VAR(I)/D_VAR(I) - ELSE ! MEDIUM LIVED - if ( abs(D_VAR(i)).gt.SUP ) then - ratio = P_VAR(i)/D_VAR(i) - tmp = exp(-D_VAR(i)*STEP*0.5) - V2(i) = tmp * (V2(i) - ratio) + ratio - else - tmp = D_VAR(i) * STEP * 0.5 - V2(i) = V2(i) + P_VAR(i) * 0.5 * STEP * ( 1 - 0.5 * tmp * - * ( 1 - 1.0 / 3.0 * tmp ) ) - end if - END IF - end do - -C ===== Extrapolation and error estimation ======== - - ERRold=ERR - ERR=0.0D0 - do i=1,NVAR - ERR = ERR + ((V2(i)-V1(i))/(ATOL(i) + RTOL(i)*V2(i)))**2 - end do - ERR = DSQRT( ERR/NVAR ) - STEPold=STEP - -C ===== choosing the stepsize ===================== - - factor = 0.9*ERR**(-0.35)*ERRold**0.2 - if (IsReject) then - facmax=1. - else - facmax=8. - end if - factor = DMAX1( 1.25D-1, DMIN1(factor,facmax) ) - STEP = DMIN1( STEPMAX, DMAX1(STEPMIN,factor*STEP) ) - -C=================================================== - - if ( (ERR.gt.1).and.(STEPold.gt.STEPMIN) ) then - IsReject = .true. - else - IsReject = .false. - do 140 i=1,NVAR - VAR(i) = DMAX1(V2(i), 0.d0) - 140 continue - T = Tplus - end if - if ( T .lt. Tnext ) go to 10 - - TIME = Tnext - RETURN - END diff --git a/boxmox/int/oldies/qssafix.def b/boxmox/int/oldies/qssafix.def deleted file mode 100644 index ed6f40b3869eff8c2cf89e308dc6fe9671bc5b0a..0000000000000000000000000000000000000000 --- a/boxmox/int/oldies/qssafix.def +++ /dev/null @@ -1,16 +0,0 @@ - -#FUNCTION SPLIT -#JACOBIAN OFF -#SPARSEDATA OFF -#DOUBLE ON -#INTFILE qssafix - -#INLINE F_INIT_INT - STEPMIN=0.0001 - STEPMAX=60. -#ENDINLINE - -#INLINE C_INIT_INT - STEPMIN=0.0001; - STEPMAX=60.; -#ENDINLINE diff --git a/boxmox/int/oldies/qssafix.f b/boxmox/int/oldies/qssafix.f deleted file mode 100644 index 4f0a072e9b602bf3dd0f6e851288836d96e81f22..0000000000000000000000000000000000000000 --- a/boxmox/int/oldies/qssafix.f +++ /dev/null @@ -1,56 +0,0 @@ -C --- Plain QSSA with fixed step size -C - SUBROUTINE INTEGRATE( TIN, TOUT ) - - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - -C TIN - Start Time - KPP_REAL TIN -C TOUT - End Time - KPP_REAL TOUT - -C Local variables - KPP_REAL P_VAR(NVAR), D_VAR(NVAR) - LOGICAL IsReject - KPP_REAL T, Tnext, STEP, Told, SUP - KPP_REAL ratio, tmp - INTEGER i - - T = TIN - Tnext = TOUT - STEP = 0.1 - Told = T - SUP = 1e-14 - IsReject = .false. - -C -- BELOW THIS LIMIT USE TAYLOR INSTEAD OF EXP --- - - do while ( T.lt.Tnext ) - - if ( T.gt.Tnext ) then - STEP = Tnext - Told - T = Tnext - end if - - CALL FSPLIT_VAR ( VAR, P_VAR, D_VAR ) - - do i=1,NVAR - if ( abs(D_VAR(i)).gt.SUP ) then - ratio = P_VAR(i)/D_VAR(i) - tmp = exp(-D_VAR(i)*STEP) - VAR(i) = tmp * (VAR(i) - ratio) + ratio - else - tmp = D_VAR(i) * STEP - VAR(i) = VAR(i) + P_VAR(i) * 0.5 * STEP * ( 1 - 0.5 * tmp * - * ( 1 - 1.0 / 3.0 * tmp ) ) - end if - end do - - T = T + STEP - TIME = T - - end do - - RETURN - END diff --git a/boxmox/int/oldies/rodas3.c b/boxmox/int/oldies/rodas3.c deleted file mode 100644 index 92754698f0c059efe3497743fa7d206ce9020491..0000000000000000000000000000000000000000 --- a/boxmox/int/oldies/rodas3.c +++ /dev/null @@ -1,313 +0,0 @@ - - #define MAX(a,b) ((a) >= (b) ) ?(a):(b) - #define MIN(b,c) ((b) < (c) ) ?(b):(c) - #define abs(x) ((x) >= 0 ) ?(x):(-x) - #define dabs(y) (double)abs(y) - #define DSQRT(d) (double)pow(d,0.5) - - void (*forfun)(int,KPP_REAL,KPP_REAL [],KPP_REAL []); - void (*forjac)(int,KPP_REAL,KPP_REAL [],KPP_REAL []); - - -void FUNC_CHEM(int N,KPP_REAL T,KPP_REAL Y[NVAR],KPP_REAL P[NVAR]) - { - KPP_REAL Told; - Told = TIME; - TIME = T; - Update_SUN(); - Update_PHOTO(); - Fun( Y, FIX, RCONST, P ); - TIME = Told; - } /* function fun ends here */ - -void JAC_CHEM(int N,KPP_REAL T,KPP_REAL Y[NVAR],KPP_REAL J[LU_NONZERO]) - { - KPP_REAL Told; - Told = TIME; - TIME = T; - Update_SUN(); - Update_PHOTO(); - Jac_SP( Y, FIX, RCONST, J ); - TIME = Told; - } /* function jac_sp ends here */ - - - INTEGRATE( KPP_REAL TIN, KPP_REAL TOUT ) - { - /* TIN - Start Time */ - /* TOUT - End Time */ - - int INFO[5]; - - forfun = &FUNC_CHEM; - forjac = &JAC_CHEM; - INFO[0] = Autonomous; - - RODAS3( NVAR,TIN,TOUT,STEPMIN,STEPMAX,STEPMIN,VAR,ATOL,RTOL,INFO - ,forfun ,forjac ); - -} - - - -int RODAS3(int N,KPP_REAL T, KPP_REAL Tnext,KPP_REAL Hmin,KPP_REAL Hmax, - KPP_REAL Hstart,KPP_REAL y[NVAR],KPP_REAL AbsTol[NVAR],KPP_REAL RelTol[NVAR], - int INFO[5],void (*forfun)(int,KPP_REAL,KPP_REAL [],KPP_REAL []), - void (*forjac)(int,KPP_REAL,KPP_REAL [],KPP_REAL []) ) - { -/* - Stiffly accurate Rosenbrock 3(2), with - stiffly accurate embedded formula for error control. - - All the arguments aggree with the KPP syntax. - - INPUT ARGUMENTS: - y = Vector of (NVAR) concentrations, contains the - initial values on input - [T, Tnext] = the integration interval - Hmin, Hmax = lower and upper bounds for the selected step-size. - Note that for Step = Hmin the current computed - solution is unconditionally accepted by the error - control mechanism. - AbsTol, RelTol = (NVAR) dimensional vectors of - componentwise absolute and relative tolerances. - FUNC_CHEM = name of routine of derivatives. KPP syntax. - See the header below. - JAC_CHEM = name of routine that computes the Jacobian, in - sparse format. KPP syntax. See the header below. - Info(1) = 1 for autonomous system - = 0 for nonautonomous system - - OUTPUT ARGUMENTS: - y = the values of concentrations at Tend. - T = equals Tend on output. - Info(2) = # of FUNC_CHEM calls. - Info(3) = # of JAC_CHEM calls. - Info(4) = # of accepted steps. - Info(5) = # of rejected steps. - - Adrian Sandu, March 1996 - The Center for Global and Regional Environmental Research -*/ - KPP_REAL K1[NVAR], K2[NVAR], K3[NVAR], K4[NVAR]; - KPP_REAL F1[NVAR], JAC[LU_NONZERO]; - KPP_REAL ghinv,uround,c43,x1,x2,ytol; - KPP_REAL ynew[NVAR]; - KPP_REAL H, Hold, Tplus,tau,tau1,tau2,tau3; - KPP_REAL ERR, factor, facmax; - int n,nfcn,njac,Naccept,Nreject,i,j,ier; - char IsReject,Autonomous; - - - -/* Initialization of counters, etc. */ - Autonomous = (INFO[0] == 1); - uround = (double)1e-15; - c43 = (double)(-8.e0/3.e0); - H = MAX( (double)1e-8, Hstart ); - Hmin = MAX(Hmin,uround*(Tnext-T)); - Hmax = MIN(Hmax,Tnext-T); - Tplus = T; - IsReject = 0; - Naccept = 0; - Nreject = 0; - nfcn = 0; - njac = 0; - - -/* === Starting the time loop === */ - -while(T Tnext ) - { - H = Tnext - T; - Tplus = Tnext; - } - - (*forjac)(NVAR, T, y,JAC ); - - njac = njac+1; - ghinv = (double)-2.0e0/H; - for(j=0;j Hmin ) - { - H = (double)5.0e-1*H; - goto ten; - } - else - printf("IER <> 0 , H = %d", H); - }/* main ier if ends*/ - - - (*forfun)(NVAR , T, y, F1 ) ; - - -/* ====== NONAUTONOMOUS CASE =============== */ - - if( Autonomous == 0) - { - tau = DSQRT( uround*MAX( (double)1.0e-5, dabs(T) ) ); - (*forfun)(NVAR , T+tau , y ,K2 ); - nfcn=nfcn+1; - for(j=0;j1) && (Hold>Hmin) ) - { - IsReject = 1; - Nreject = Nreject + 1; - } - else - { - IsReject = 0; - - for(i=0;i 0, H=',H - stop - end if - end if - - CALL FUNC_CHEM(NVAR, T, y, F1) - -C ====== NONAUTONOMOUS CASE =============== - IF (.not. Autonomous) THEN - tau = DSQRT( uround*DMAX1( 1.0d-5, DABS(T) ) ) - CALL FUNC_CHEM(NVAR, T+tau, y, K2) - nfcn=nfcn+1 - do 30 j = 1,NVAR - K3(j) = ( K2(j)-F1(j) )/tau - 30 continue - -C ----- STAGE 1 (NONAUTONOMOUS) ----- - x1 = 0.5*H - do 40 j = 1,NVAR - K1(j) = F1(j) + x1*K3(j) - 40 continue - CALL KppSolve (JAC, K1) - -C ----- STAGE 2 (NONAUTONOMOUS) ----- - x1 = 4.d0/H - x2 = 1.5d0*H - do 50 j = 1,NVAR - K2(j) = F1(j) - x1*K1(j) + x2*K3(j) - 50 continue - CALL KppSolve (JAC, K2) - -C ====== AUTONOMOUS CASE =============== - ELSE -C ----- STAGE 1 (AUTONOMOUS) ----- - do 60 j = 1,NVAR - K1(j) = F1(j) - 60 continue - CALL KppSolve (JAC, K1) - -C ----- STAGE 2 (AUTONOMOUS) ----- - x1 = 4.d0/H - do 70 j = 1,NVAR - K2(j) = F1(j) - x1*K1(j) - 70 continue - CALL KppSolve (JAC, K2) - END IF - -C ----- STAGE 3 ----- - do 80 j = 1,NVAR - ynew(j) = y(j) - 2.0d0*K1(j) - 80 continue - CALL FUNC_CHEM(NVAR, T+H, ynew, F1) - nfcn=nfcn+1 - do 90 j = 1,NVAR - K3(j) = F1(j) + ( -K1(j) + K2(j) )/H - 90 continue - CALL KppSolve (JAC, K3) - -C ----- STAGE 4 ----- - do 100 j = 1,NVAR - ynew(j) = y(j) - 2.0d0*K1(j) - K3(j) - 100 continue - CALL FUNC_CHEM(NVAR, T+H, ynew, F1) - nfcn=nfcn+1 - do 110 j = 1,NVAR - K4(j) = F1(j) + ( -K1(j) + K2(j) - C43*K3(j) )/H - 110 continue - CALL KppSolve (JAC, K4) - -C ---- The Solution --- - - do 120 j = 1,NVAR - ynew(j) = y(j) - 2.0d0*K1(j) - K3(j) - K4(j) - 120 continue - - -C ====== Error estimation ======== - - ERR=0.d0 - do 130 i=1,NVAR - ytol = AbsTol(i) + RelTol(i)*DABS(ynew(i)) - ERR = ERR + ( K4(i)/ytol )**2 - 130 continue - ERR = DMAX1( uround, DSQRT( ERR/NVAR ) ) - -C ======= Choose the stepsize =============================== - elo = 3.0D0 ! estimator local order - factor = DMAX1(2.0D-1,DMIN1(6.0D0,ERR**(1.0D0/elo)/.9D0)) - Hnew = DMIN1(Hmax,DMAX1(Hmin, H/factor)) - -C ======= Rejected/Accepted Step ============================ - - IF ( (ERR.gt.1).and.(H.gt.Hmin) ) THEN - IsReject = .true. - H = DMIN1(H/10,Hnew) - Nreject = Nreject+1 - ELSE - DO 140 i=1,NVAR - y(i) = ynew(i) - 140 CONTINUE - T = Tplus - IF (.NOT.IsReject) THEN - H = Hnew ! Do not increase stepsize if previos step was rejected - END IF - IsReject = .false. - Naccept = Naccept+1 - END IF - - -C ======= End of the time loop =============================== - if ( T .lt. Tnext ) go to 10 - - - -C ======= Output Information ================================= - Info(2) = Nfcn - Info(3) = Njac - Info(4) = Naccept - Info(5) = Nreject - Hstart = H - - RETURN - END - - - - SUBROUTINE FUNC_CHEM(N, T, Y, P) - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - INTEGER N - KPP_REAL T, Told - KPP_REAL Y(NVAR), P(NVAR) - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Fun( Y, FIX, RCONST, P ) - TIME = Told - RETURN - END - - - SUBROUTINE JAC_CHEM(N, T, Y, J) - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - INTEGER N - KPP_REAL Told, T - KPP_REAL Y(NVAR), J(LU_NONZERO) - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Jac_SP( Y, FIX, RCONST, J ) - TIME = Told - RETURN - END - diff --git a/boxmox/int/oldies/rodas3_ddm.def b/boxmox/int/oldies/rodas3_ddm.def deleted file mode 100644 index 8aefee2db815fb26a095c1c53ced4414aee1bdbe..0000000000000000000000000000000000000000 --- a/boxmox/int/oldies/rodas3_ddm.def +++ /dev/null @@ -1,52 +0,0 @@ - -#FUNCTION AGGREGATE -#JACOBIAN SPARSE_LU_ROW - -#DOUBLE ON -#INTFILE rodas3_ddm -#HESSIAN ON - -#INLINE F77_DECL_INT - INTEGER Autonomous - COMMON /INTGDATA/ Autonomous - REAL*8 STEPSTART - COMMON /GDATA/ STEPSTART -#ENDINLINE - -#INLINE F77_INIT_INT - STEPMIN=1.0E-4 - STEPMAX=3600. - Autonomous = 0 - STEPSTART=STEPMIN -#ENDINLINE - - -#INLINE F90_DECL_INT - INTEGER :: Autonomous - DOUBLE PRECISION :: STEPSTART -#ENDINLINE - -#INLINE F90_INIT_INT - STEPMIN=1.e-4 - STEPMAX=3600. - Autonomous = 0 - STEPSTART=STEPMIN -#ENDINLINE - - -#INLINE C_DECL_INT - extern int Autonomous; - extern double STEPSTART; -#ENDINLINE - -#INLINE C_DATA_INT - int Autonomous; - double STEPSTART; -#ENDINLINE - -#INLINE C_INIT_INT - STEPMIN = 0.0001; - STEPMAX = 3600.0; - Autonomous = 0; - STEPSTART = STEPMIN; -#ENDINLINE diff --git a/boxmox/int/oldies/rodas3_ddm.f b/boxmox/int/oldies/rodas3_ddm.f deleted file mode 100644 index f4906c331a87e918c0bb1072359df9f68ae2e6ef..0000000000000000000000000000000000000000 --- a/boxmox/int/oldies/rodas3_ddm.f +++ /dev/null @@ -1,592 +0,0 @@ - SUBROUTINE INTEGRATE( NSENSIT, Y, TIN, TOUT ) - - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - -C TIN - Start Time - KPP_REAL TIN -C TOUT - End Time - KPP_REAL TOUT -C Y - Concentrations and Sensitivities - KPP_REAL Y(NVAR*(NSENSIT+1)) -C --- Note: Y contains: (1:NVAR) concentrations, followed by -C --- (1:NVAR) sensitivities w.r.t. first parameter, followed by -C --- etc., followed by -C --- (1:NVAR) sensitivities w.r.t. NSENSIT's parameter - - INTEGER INFO(5) - - EXTERNAL FUNC_CHEM, JAC_CHEM - - INFO(1) = Autonomous - - CALL RODAS3_DDM(NVAR,NSENSIT,TIN,TOUT,STEPMIN,STEPMAX, - + STEPMIN,Y,ATOL,RTOL, - + Info,FUNC_CHEM,JAC_CHEM) - - - RETURN - END - - - - - SUBROUTINE RODAS3_DDM(N,NSENSIT,T,Tnext,Hmin,Hmax,Hstart, - + y,AbsTol,RelTol, - + Info,FUNC_CHEM,JAC_CHEM) - - IMPLICIT NONE - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - INCLUDE 'KPP_ROOT_sparse.h' -C -C Stiffly accurate Rosenbrock 3(2), with -C stiffly accurate embedded formula for error control. -C -C Direct decoupled computation of sensitivities. -C The global variable DDMTYPE distinguishes between: -C DDMTYPE = 0 : sensitivities w.r.t. initial values -C DDMTYPE = 1 : sensitivities w.r.t. parameters -C -C INPUT ARGUMENTS: -C y = Vector of: (1:NVAR) concentrations, followed by -C (1:NVAR) sensitivities w.r.t. first parameter, followed by -C etc., followed by -C (1:NVAR) sensitivities w.r.t. NSENSIT's parameter -C (y contains initial values at input, final values at output) -C [T, Tnext] = the integration interval -C Hmin, Hmax = lower and upper bounds for the selected step-size. -C Note that for Step = Hmin the current computed -C solution is unconditionally accepted by the error -C control mechanism. -C AbsTol, RelTol = (NVAR) dimensional vectors of -C componentwise absolute and relative tolerances. -C FUNC_CHEM = name of routine of derivatives. KPP syntax. -C See the header below. -C JAC_CHEM = name of routine that computes the Jacobian, in -C sparse format. KPP syntax. See the header below. -C Info(1) = 1 for Autonomous system -C = 0 for nonAutonomous system -C -C OUTPUT ARGUMENTS: -C y = the values of concentrations and sensitivities at Tend. -C T = equals TENDon output. -C Info(2) = # of FUNC_CHEM CALLs. -C Info(3) = # of JAC_CHEM CALLs. -C Info(4) = # of accepted steps. -C Info(5) = # of rejected steps. -C -C Adrian Sandu, December 2001 -C - - INTEGER NSENSIT - KPP_REAL y(NVAR*(NSENSIT+1)), ynew(NVAR*(NSENSIT+1)) - KPP_REAL K1(NVAR*(NSENSIT+1)) - KPP_REAL K2(NVAR*(NSENSIT+1)) - KPP_REAL K3(NVAR*(NSENSIT+1)) - KPP_REAL K4(NVAR*(NSENSIT+1)) - KPP_REAL Fv(NVAR), Hv(NVAR) - KPP_REAL DFDT(NVAR*(NSENSIT+1)) - KPP_REAL DJDP(NVAR*NSENSIT) - KPP_REAL DFDP(NVAR*NSENSIT), DFDPDT(NVAR*NSENSIT) - KPP_REAL JAC(LU_NONZERO), AJAC(LU_NONZERO) - KPP_REAL DJDT(LU_NONZERO) - KPP_REAL HESS(NHESS) - KPP_REAL Hmin,Hmax,Hstart,ghinv,uround - KPP_REAL AbsTol(NVAR), RelTol(NVAR) - KPP_REAL T, Tnext, Tplus, H, Hnew, elo - KPP_REAL ERR, factor, facmax - KPP_REAL w, e, beta1, beta2, beta3, beta4 - KPP_REAL tau, x1, x2, ytol, dround - - INTEGER n,nfcn,njac,Naccept,Nreject,i,j,ier - INTEGER Info(5) - LOGICAL IsReject, Autonomous - EXTERNAL FUNC_CHEM, JAC_CHEM, HESS_CHEM - -C The method coefficients - DOUBLE PRECISION gamma, gamma2, gamma3, gamma4 - PARAMETER ( gamma = 0.5D+00 ) - PARAMETER ( gamma2 = 1.5D+00 ) - PARAMETER ( gamma3 = 0.0D+00 ) - PARAMETER ( gamma4 = 0.0D+00 ) - DOUBLE PRECISION a21, a31, a32, a41, a42, a43 - PARAMETER ( a21 = 0.0D+00 ) - PARAMETER ( a31 = 2.0D+00 ) - PARAMETER ( a32 = 0.0D+00 ) - PARAMETER ( a41 = 2.0D+00 ) - PARAMETER ( a42 = 0.0D+00 ) - PARAMETER ( a43 = 1.0D+00 ) - DOUBLE PRECISION alpha2, alpha3, alpha4 - PARAMETER ( alpha2 = 0.0D0 ) - PARAMETER ( alpha3 = 1.0D0 ) - PARAMETER ( alpha4 = 1.0D0 ) - DOUBLE PRECISION c21, c31, c32, c41, c42, c43 - PARAMETER ( c21 = 4.0D0 ) - PARAMETER ( c31 = 1.0D0 ) - PARAMETER ( c32 = -1.0D0 ) - PARAMETER ( c41 = 1.0D0 ) - PARAMETER ( c42 = -1.0D0 ) - PARAMETER ( c43 = -2.666666666666667D0 ) - DOUBLE PRECISION b1, b2, b3, b4 - PARAMETER ( b1 = 2.0D+00 ) - PARAMETER ( b2 = 0.0D0 ) - PARAMETER ( b3 = 1.0D0 ) - PARAMETER ( b4 = 1.0D0 ) - DOUBLE PRECISION d1, d2, d3, d4 - PARAMETER ( d1 = 0.0D0 ) - PARAMETER ( d2 = 0.0D0 ) - PARAMETER ( d3 = 0.0D0 ) - PARAMETER ( d4 = 1.0D0 ) - - -c Initialization of counters, etc. - Autonomous = Info(1) .EQ. 1 - uround = 1.d-15 - dround = DSQRT(uround) - IF (Hmax.le.0.D0) THEN - Hmax = DABS(Tnext-T) - END IF - H = DMAX1(1.d-8, Hstart) - Tplus = T - IsReject = .false. - Naccept = 0 - Nreject = 0 - Nfcn = 0 - Njac = 0 - -C === Starting the time loop === - 10 CONTINUE - - Tplus = T + H - IF ( Tplus .gt. Tnext ) THEN - H = Tnext - T - Tplus = Tnext - END IF - -C Initial Function, Jacobian, and Hessian Values - CALL FUNC_CHEM(NVAR, T, y, Fv) - CALL JAC_CHEM(NVAR, T, y, JAC) - CALL HESS_CHEM( NVAR, T, y, HESS ) - IF (DDMTYPE .EQ. 1) THEN - CALL DFUNDPAR(NVAR, NSENSIT, T, y, DFDP) - END IF - -C The time derivatives for non-Autonomous case - IF (.not. Autonomous) THEN - tau = DSIGN(dround*DMAX1( 1.0d0, DABS(T) ), T) - CALL FUNC_CHEM(NVAR, T+tau, y, K2) - CALL JAC_CHEM(NVAR, T+tau, y, AJAC) - nfcn=nfcn+1 - DO 20 j = 1,NVAR - DFDT(j) = ( K2(j)-Fv(j) )/tau - 20 CONTINUE - DO 30 j = 1,LU_NONZERO - DJDT(j) = ( AJAC(j)-JAC(j) )/tau - 30 CONTINUE - DO 35 i=1,NSENSIT - CALL Jac_SP_Vec (DJDT,y(i*NVAR+1),DFDT(i*NVAR+1)) - 35 CONTINUE - END IF - - 11 CONTINUE ! From here we restart after a rejected step - -C Form the Prediction matrix and compute its LU factorization - Njac = Njac+1 - ghinv = 1.0d0/(gamma*H) - DO 40 j=1,LU_NONZERO - AJAC(j) = -JAC(j) - 40 CONTINUE - DO 50 j=1,NVAR - AJAC(LU_DIAG(j)) = AJAC(LU_DIAG(j)) + ghinv - 50 CONTINUE - CALL KppDecomp (AJAC, ier) -C - IF (ier.ne.0) THEN - IF ( H.gt.Hmin) THEN - H = 5.0d-1*H - GO TO 10 - ELSE - PRINT *,'ROS4: Singular factorization at T=',T,'; H=',H - STOP - END IF - END IF - -C ------------ STAGE 1------------------------- - DO 60 j = 1,NVAR - K1(j) = Fv(j) - 60 CONTINUE - IF (.NOT. Autonomous) THEN - beta1 = H*gamma - DO 70 j=1,NVAR - K1(j) = K1(j) + beta1*DFDT(j) - 70 CONTINUE - END IF - CALL KppSolve (AJAC, K1) -C --- If derivative w.r.t. parameters - IF (DDMTYPE .EQ. 1) THEN - CALL DJACDPAR(NVAR, NSENSIT, T, y, K1(1), DJDP) - END IF -C --- End of derivative w.r.t. parameters - - DO 100 i=1,NSENSIT - CALL Jac_SP_Vec (JAC,y(i*NVAR+1),K1(i*NVAR+1)) - CALL Hess_Vec ( HESS, y(i*NVAR+1), K1(1), Hv ) - DO 80 j=1,NVAR - K1(i*NVAR+j) = K1(i*NVAR+j) + Hv(j) - 80 CONTINUE - IF (.NOT. Autonomous) THEN - DO 90 j=1,NVAR - K1(i*NVAR+j) = K1(i*NVAR+j) + beta1*DFDT(i*NVAR+j) - 90 CONTINUE - END IF -C --- If derivative w.r.t. parameters - IF (DDMTYPE .EQ. 1) THEN - DO 95 j = 1,NVAR - K1(i*NVAR+j) = K1(i*NVAR+j) + DFDP((i-1)*NVAR+j) - & + DJDP((i-1)*NVAR+j) - 95 CONTINUE - END IF -C --- End of derivative w.r.t. parameters - CALL KppSolve (AJAC, K1(i*NVAR+1)) - 100 CONTINUE - -C ----------- STAGE 2 ------------------------- -C Note: uses the same function values as Stage 1 -C DO 110 j = 1,NVAR*(NSENSIT+1) -C ynew(j) = y(j) + a21*K1(j) -C 110 CONTINUE -C CALL FUNC_CHEM(NVAR, T+alpha2*H, ynew, Fv) -C IF (DDMTYPE .EQ. 1) THEN -C CALL DFUNDPAR(NVAR, NSENSIT, T+alpha2*H, ynew, DFDP) -C END IF -C nfcn=nfcn+1 - beta1 = c21/H - DO 120 j = 1,NVAR - K2(j) = Fv(j) + beta1*K1(j) - 120 CONTINUE - IF (.NOT. Autonomous) THEN - beta2 = H*gamma2 - DO 130 j=1,NVAR - K2(j) = K2(j) + beta2*DFDT(j) - 130 CONTINUE - END IF - CALL KppSolve (AJAC, K2) -C --- If derivative w.r.t. parameters - IF (DDMTYPE .EQ. 1) THEN - CALL DJACDPAR(NVAR, NSENSIT, T, y, K2(1), DJDP) - END IF -C --- End of derivative w.r.t. parameters - - CALL JAC_CHEM(NVAR, T+alpha2*H, ynew, JAC) - njac=njac+1 - DO 160 i=1,NSENSIT - CALL Jac_SP_Vec (JAC,ynew(i*NVAR+1),K2(i*NVAR+1)) - CALL Hess_Vec ( HESS, y(i*NVAR+1), K2(1), Hv ) - DO 140 j = 1,NVAR - K2(i*NVAR+j) = K2(i*NVAR+j) + beta1*K1(i*NVAR+j) - & + Hv(j) - 140 CONTINUE - IF (.NOT. Autonomous) THEN - DO 150 j=1,NVAR - K2(i*NVAR+j) = K2(i*NVAR+j) + beta2*DFDT(i*NVAR+j) - 150 CONTINUE - END IF -C --- If derivative w.r.t. parameters - IF (DDMTYPE .EQ. 1) THEN - DO 155 j = 1,NVAR - K2(i*NVAR+j) = K2(i*NVAR+j) + DFDP((i-1)*NVAR+j) - & + DJDP((i-1)*NVAR+j) - 155 CONTINUE - END IF -C --- End of derivative w.r.t. parameters - CALL KppSolve (AJAC, K2(i*NVAR+1)) - 160 CONTINUE - - -C ------------ STAGE 3 ------------------------- - DO 170 j = 1,NVAR*(NSENSIT+1) - ynew(j) = y(j) + a31*K1(j) + a32*K2(j) - 170 CONTINUE - CALL FUNC_CHEM(NVAR, T+alpha3*H, ynew, Fv) - IF (DDMTYPE .EQ. 1) THEN - CALL DFUNDPAR(NVAR, NSENSIT, T+alpha3*H, ynew, DFDP) - END IF - nfcn=nfcn+1 - beta1 = c31/H - beta2 = c32/H - DO 180 j = 1,NVAR - K3(j) = Fv(j) + beta1*K1(j) + beta2*K2(j) - 180 CONTINUE - IF (.NOT. Autonomous) THEN - beta3 = H*gamma3 - DO 190 j=1,NVAR - K3(j) = K3(j) + beta3*DFDT(j) - 190 CONTINUE - END IF - CALL KppSolve (AJAC, K3) -C --- If derivative w.r.t. parameters - IF (DDMTYPE .EQ. 1) THEN - CALL DJACDPAR(NVAR, NSENSIT, T, y, K3(1), DJDP) - END IF -C --- End of derivative w.r.t. parameters - - CALL JAC_CHEM(NVAR, T+alpha3*H, ynew, JAC) - njac=njac+1 - DO 220 i=1,NSENSIT - CALL Jac_SP_Vec (JAC,ynew(i*NVAR+1),K3(i*NVAR+1)) - CALL Hess_Vec ( HESS, y(i*NVAR+1), K3(1), Hv ) - DO 200 j = 1,NVAR - K3(i*NVAR+j) = K3(i*NVAR+j) + beta1*K1(i*NVAR+j) - & + beta2*K2(i*NVAR+j) + Hv(j) - 200 CONTINUE - IF (.NOT. Autonomous) THEN - DO 210 j=1,NVAR - K3(i*NVAR+j) = K3(i*NVAR+j) + beta3*DFDT(i*NVAR+j) - 210 CONTINUE - END IF -C --- If derivative w.r.t. parameters - IF (DDMTYPE .EQ. 1) THEN - DO 215 j = 1,NVAR - K3(i*NVAR+j) = K3(i*NVAR+j) + DFDP((i-1)*NVAR+j) - & + DJDP((i-1)*NVAR+j) - 215 CONTINUE - END IF -C --- End of derivative w.r.t. parameters - CALL KppSolve (AJAC, K3(i*NVAR+1)) - 220 CONTINUE - -C ------------ STAGE 4 ------------------------- - DO 225 j = 1,NVAR*(NSENSIT+1) - ynew(j) = y(j) + a41*K1(j) + a42*K2(j) + a43*K3(j) - 225 CONTINUE - CALL FUNC_CHEM(NVAR, T+alpha4*H, ynew, Fv) - IF (DDMTYPE .EQ. 1) THEN - CALL DFUNDPAR(NVAR, NSENSIT, T+alpha4*H, ynew, DFDP) - END IF - nfcn=nfcn+1 - beta1 = c41/H - beta2 = c42/H - beta3 = c43/H - DO 230 j = 1,NVAR - K4(j) = Fv(j) + beta1*K1(j) + beta2*K2(j) + beta3*K3(j) - 230 CONTINUE - IF (.NOT. Autonomous) THEN - beta4 = H*gamma4 - DO 240 j=1,NVAR - K4(j) = K4(j) + beta4*DFDT(j) - 240 CONTINUE - END IF - CALL KppSolve (AJAC, K4) -C --- If derivative w.r.t. parameters - IF (DDMTYPE .EQ. 1) THEN - CALL DJACDPAR(NVAR, NSENSIT, T, y, K4(1), DJDP) - END IF -C --- End of derivative w.r.t. parameters - - njac=njac+1 - DO 270 i=1,NSENSIT - CALL Jac_SP_Vec (JAC,ynew(i*NVAR+1),K4(i*NVAR+1)) - CALL Hess_Vec ( HESS, y(i*NVAR+1), K4(1), Hv ) - DO 250 j = 1,NVAR - K4(i*NVAR+j) = K4(i*NVAR+j) + beta1*K1(i*NVAR+j) - & + beta2*K2(i*NVAR+j) + beta3*K3(i*NVAR+j) - & + Hv(j) - 250 CONTINUE - IF (.NOT. Autonomous) THEN - DO 260 j=1,NVAR - K4(i*NVAR+j) = K4(i*NVAR+j) + beta4*DFDT(i*NVAR+j) - 260 CONTINUE - END IF -C --- If derivative w.r.t. parameters - IF (DDMTYPE .EQ. 1) THEN - DO 265 j = 1,NVAR - K4(i*NVAR+j) = K4(i*NVAR+j) + DFDP((i-1)*NVAR+j) - & + DJDP((i-1)*NVAR+j) - 265 CONTINUE - END IF - CALL KppSolve (AJAC, K4(i*NVAR+1)) - 270 CONTINUE - - -C ---- The Solution --- - DO 280 j = 1,NVAR*(NSENSIT+1) -C ynew(j) = y(j) + b1*K1(j) + b2*K2(j) + b3*K3(j) + b4*K4(j) - ynew(j) = y(j) + 2*K1(j) + K3(j) + K4(j) - 280 CONTINUE - - -C ====== Error estimation -- can be extended to control sensitivities too ======== - - ERR = 0.d0 - DO 290 i=1,NVAR - w = AbsTol(i) + RelTol(i)*DMAX1(DABS(ynew(i)),DABS(y(i))) -C e = d1*K1(i) + d2*K2(i) + d3*K3(i) + d4*K4(i) - e = K4(i) - ERR = ERR + ( e/w )**2 - 290 CONTINUE - ERR = DMAX1( uround, DSQRT( ERR/NVAR ) ) - -C ======= Choose the stepsize =============================== - - elo = 3.0D0 ! estimator local order - factor = DMAX1(2.0D-1,DMIN1(6.0D0,ERR**(1.0D0/elo)/.9D0)) - Hnew = DMIN1(Hmax,DMAX1(Hmin, H/factor)) - -C ======= Rejected/Accepted Step ============================ - - IF ( (ERR.gt.1).and.(H.gt.Hmin) ) THEN - IsReject = .true. - H = DMIN1(H/10,Hnew) - Nreject = Nreject+1 - ELSE - DO 300 i=1,NVAR*(NSENSIT+1) - y(i) = ynew(i) - 300 CONTINUE - T = Tplus - IF (.NOT.IsReject) THEN - H = Hnew ! Do not increase stepsize if previos step was rejected - END IF - IsReject = .false. - Naccept = Naccept+1 - END IF - -C ======= End of the time loop =============================== - IF ( T .lt. Tnext ) GO TO 10 - - - -C ======= Output Information ================================= - Info(2) = Nfcn - Info(3) = Njac - Info(4) = Naccept - Info(5) = Nreject - Hstart = H - - RETURN - END - - - - SUBROUTINE FUNC_CHEM(N, T, Y, P) - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - INTEGER N - KPP_REAL T, Told - KPP_REAL Y(NVAR), P(NVAR) - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Fun( Y, FIX, RCONST, P ) - TIME = Told - RETURN - END - - - SUBROUTINE DFUNDPAR(N, NSENSIT, T, Y, P) -C --- Computes the partial derivatives of FUNC_CHEM w.r.t. parameters - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' -C --- NCOEFF, JCOEFF useful for derivatives w.r.t. rate coefficients - INTEGER N - INTEGER NCOEFF, JCOEFF(NREACT) - COMMON /DDMRCOEFF/ NCOEFF, JCOEFF - - KPP_REAL T, Told - KPP_REAL Y(NVAR), P(NVAR*NSENSIT) - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() -C - IF (DDMTYPE .EQ. 0) THEN -C --- Note: the values below are for sensitivities w.r.t. initial values; -C --- they may have to be changed for other applications - DO j=1,NSENSIT - DO i=1,NVAR - P(i+NVAR*(j-1)) = 0.0D0 - END DO - END DO - ELSE -C --- Example: the call below is for sensitivities w.r.t. rate coefficients; -C --- JCOEFF(1:NSENSIT) are the indices of the NSENSIT rate coefficients -C --- w.r.t. which one differentiates - CALL dFun_dRcoeff( Y, FIX, NCOEFF, JCOEFF, P ) - END IF - TIME = Told - RETURN - END - - SUBROUTINE JAC_CHEM(N, T, Y, J) - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - INTEGER N - KPP_REAL Told, T - KPP_REAL Y(NVAR), J(LU_NONZERO) - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Jac_SP( Y, FIX, RCONST, J ) - TIME = Told - RETURN - END - - - SUBROUTINE DJACDPAR(N, NSENSIT, T, Y, U, P) -C --- Computes the partial derivatives of JAC w.r.t. parameters times user vector U - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' -C --- NCOEFF, JCOEFF useful for derivatives w.r.t. rate coefficients - INTEGER NCOEFF, JCOEFF(NREACT) - COMMON /DDMRCOEFF/ NCOEFF, JCOEFF - - INTEGER N - KPP_REAL T, Told - KPP_REAL Y(NVAR), U(NVAR) - KPP_REAL P(NVAR*NSENSIT) - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() -C - IF (DDMTYPE .EQ. 0) THEN -C --- Note: the values below are for sensitivities w.r.t. initial values; -C --- they may have to be changed for other applications - DO j=1,NSENSIT - DO i=1,NVAR - P(i+NVAR*(j-1)) = 0.0D0 - END DO - END DO - ELSE -C --- Example: the call below is for sensitivities w.r.t. rate coefficients; -C --- JCOEFF(1:NSENSIT) are the indices of the NSENSIT rate coefficients -C --- w.r.t. which one differentiates - CALL dJac_dRcoeff( Y, FIX, U, NCOEFF, JCOEFF, P ) - END IF - TIME = Told - RETURN - END - - - SUBROUTINE HESS_CHEM(N, T, Y, HESS) - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - INTEGER N - KPP_REAL Told, T - KPP_REAL Y(NVAR), HESS(NHESS) - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Hessian( Y, FIX, RCONST, HESS ) - TIME = Told - RETURN - END - - - - - - diff --git a/boxmox/int/oldies/ros1.def b/boxmox/int/oldies/ros1.def deleted file mode 100644 index 63de92d4c1e323c8b3ecedc84a58b3263c514e0e..0000000000000000000000000000000000000000 --- a/boxmox/int/oldies/ros1.def +++ /dev/null @@ -1,50 +0,0 @@ - -#FUNCTION AGGREGATE -#JACOBIAN SPARSE_LU_ROW - -#DOUBLE ON -#INTFILE ros1 - -#INLINE F77_DECL_INT - INTEGER Autonomous - COMMON /INTGDATA/ Autonomous - REAL*8 STEPSTART - COMMON /GDATA/ STEPSTART -#ENDINLINE - -#INLINE F77_INIT_INT - STEPMIN=30.0 - STEPMAX=30.0 - Autonomous = 0 - STEPSTART=STEPMIN -#ENDINLINE - - -#INLINE F90_DECL_INT - INTEGER :: Autonomous - DOUBLE PRECISION :: STEPSTART -#ENDINLINE - -#INLINE F90_INIT_INT - STEPMIN=30.0 - STEPMAX=30.0 - Autonomous = 0 - STEPSTART=STEPMIN -#ENDINLINE - -#INLINE C_DECL_INT - extern int Autonomous; - extern double STEPSTART; -#ENDINLINE - -#INLINE C_DATA_INT -int Autonomous; -double STEPSTART; -#ENDINLINE - -#INLINE C_INIT_INT - STEPMIN = 30.0; - STEPMAX = 30.0; - Autonomous = 0; - STEPSTART = STEPMIN; -#ENDINLINE diff --git a/boxmox/int/oldies/ros1.f b/boxmox/int/oldies/ros1.f deleted file mode 100644 index 795c07bc17b7e88ac3588e1a9d6dc3dc8d59f531..0000000000000000000000000000000000000000 --- a/boxmox/int/oldies/ros1.f +++ /dev/null @@ -1,166 +0,0 @@ - SUBROUTINE INTEGRATE( TIN, TOUT ) - - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - -C TIN - Start Time - KPP_REAL TIN -C TOUT - End Time - KPP_REAL TOUT - - INTEGER INFO(5) - - EXTERNAL FUNC_CHEM, JAC_CHEM - - INFO(1) = Autonomous - - CALL ROS1(NVAR,TIN,TOUT,STEPMIN,VAR, - + Info,FUNC_CHEM,JAC_CHEM) - - - RETURN - END - - - - - SUBROUTINE ROS1(N,T,Tnext,Hstart, - + y,Info,FUNC_CHEM,JAC_CHEM) - - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_sparse.h' -C -C Linearly Implicit Euler -C A method of theoretical interest but of no practical value -C -C INPUT ARGUMENTS: -C y = Vector of (NVAR) concentrations, contains the -C initial values on input -C [T, Tnext] = the integration interval -C Hmin, Hmax = lower and upper bounds for the selected step-size. -C Note that for Step = Hmin the current computed -C solution is unconditionally accepted by the error -C control mechanism. -C AbsTol, RelTol = (NVAR) dimensional vectors of -C componentwise absolute and relative tolerances. -C FUNC_CHEM = name of routine of derivatives. KPP syntax. -C See the header below. -C JAC_CHEM = name of routine that computes the Jacobian, in -C sparse format. KPP syntax. See the header below. -C Info(1) = 1 for Autonomous system -C = 0 for nonAutonomous system -C -C OUTPUT ARGUMENTS: -C y = the values of concentrations at Tend. -C T = equals TENDon output. -C Info(2) = # of FUNC_CHEM CALLs. -C Info(3) = # of JAC_CHEM CALLs. -C Info(4) = # of accepted steps. -C Info(5) = # of rejected steps. -C Hstart = The last accepted stepsize -C -C Adrian Sandu, December 2001 -C - KPP_REAL Fv(NVAR) - KPP_REAL JAC(LU_NONZERO) - KPP_REAL H, Hstart - KPP_REAL y(NVAR) - KPP_REAL T, Tnext, Tplus - KPP_REAL elo,ghinv,uround - - INTEGER n,nfcn,njac,Naccept,Nreject,i,j - INTEGER Info(5) - LOGICAL IsReject, Autonomous - EXTERNAL FUNC_CHEM, JAC_CHEM - - - H = Hstart - Tplus = T - Nfcn = 0 - Njac = 0 - -C === Starting the time loop === - 10 CONTINUE - - Tplus = T + H - IF ( Tplus .gt. Tnext ) THEN - H = Tnext - T - Tplus = Tnext - END IF - -C Initial Function and Jacobian values - CALL FUNC_CHEM(NVAR, T, y, Fv) - Nfcn = Nfcn+1 - CALL JAC_CHEM(NVAR, T, y, JAC) - Njac = Njac+1 - -C Form the Prediction matrix and compute its LU factorization - DO 40 j=1,NVAR - JAC(LU_DIAG(j)) = JAC(LU_DIAG(j)) - 1.0d0/H - 40 CONTINUE - CALL KppDecomp (JAC, ier) -C - IF (ier.ne.0) THEN - PRINT *,'ROS1: Singular factorization at T=',T,'; H=',H - STOP - END IF - -C ------------ STAGE 1------------------------- - CALL KppSolve (JAC, Fv) - -C ---- The Solution --- - DO 160 j = 1,NVAR - y(j) = y(j) - Fv(j) - 160 CONTINUE - T = T + H - -C ======= End of the time loop =============================== - IF ( T .lt. Tnext ) GO TO 10 - -C ======= Output Information ================================= - Info(2) = Nfcn - Info(3) = Njac - Info(4) = Njac - Info(5) = 0 - Hstart = H - - RETURN - END - - - SUBROUTINE FUNC_CHEM(N, T, Y, P) - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - INTEGER N - KPP_REAL T, Told - KPP_REAL Y(NVAR), P(NVAR) - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Fun( Y, FIX, RCONST, P ) - TIME = Told - RETURN - END - - - SUBROUTINE JAC_CHEM(N, T, Y, J) - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - INTEGER N - KPP_REAL Told, T - KPP_REAL Y(NVAR), J(LU_NONZERO) - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Jac_SP( Y, FIX, RCONST, J ) - TIME = Told - RETURN - END - - - - - - diff --git a/boxmox/int/oldies/ros1_ddm.def b/boxmox/int/oldies/ros1_ddm.def deleted file mode 100644 index 25e7b87f7d979829812f132bf988a76e8ef08cd5..0000000000000000000000000000000000000000 --- a/boxmox/int/oldies/ros1_ddm.def +++ /dev/null @@ -1,50 +0,0 @@ - -#FUNCTION AGGREGATE -#JACOBIAN SPARSE_LU_ROW - -#DOUBLE ON -#INTFILE ros1_ddm - -#INLINE F77_DECL_INT - INTEGER Autonomous - COMMON /INTGDATA/ Autonomous - REAL*8 STEPSTART - COMMON /GDATA/ STEPSTART -#ENDINLINE - -#INLINE F77_INIT_INT - STEPMIN=30.0 - STEPMAX=30.0 - Autonomous = 0 - STEPSTART=STEPMIN -#ENDINLINE - -#INLINE F90_DECL_INT - INTEGER :: Autonomous - DOUBLE PRECISION :: STEPSTART -#ENDINLINE - -#INLINE F90_INIT_INT - STEPMIN=30.0 - STEPMAX=30.0 - Autonomous = 0 - STEPSTART=STEPMIN -#ENDINLINE - - -#INLINE C_DECL_INT - extern int Autonomous; - extern double STEPSTART; -#ENDINLINE - -#INLINE C_DATA_INT -int Autonomous; -double STEPSTART; -#ENDINLINE - -#INLINE C_INIT_INT - STEPMIN = 30.0; - STEPMAX = 30.0; - Autonomous = 0; - STEPSTART = STEPMIN; -#ENDINLINE diff --git a/boxmox/int/oldies/ros1_ddm.f b/boxmox/int/oldies/ros1_ddm.f deleted file mode 100644 index 0da726a01e73f55637dae3faa9ca22be10cb8803..0000000000000000000000000000000000000000 --- a/boxmox/int/oldies/ros1_ddm.f +++ /dev/null @@ -1,300 +0,0 @@ - SUBROUTINE INTEGRATE( NSENSIT, Y, TIN, TOUT ) - - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - - INTEGER NSENSIT -C TIN - Start Time - KPP_REAL TIN -C TOUT - End Time - KPP_REAL TOUT -C TOUT - End Time - KPP_REAL Y( NVAR*(NSENSIT+1) ) -C --- Note: Y contains: (1:NVAR) concentrations, followed by -C --- (1:NVAR) sensitivities w.r.t. first parameter, followed by -C --- etc., followed by -C --- (1:NVAR) sensitivities w.r.t. NSENSIT's parameter - - INTEGER INFO(5) - - EXTERNAL FUNC_CHEM, JAC_CHEM, HESS_CHEM - - INFO(1) = Autonomous - - CALL ROS1_DDM(NVAR,NSENSIT,TIN,TOUT,STEPMIN,Y, - + Info,FUNC_CHEM,JAC_CHEM,HESS_CHEM) - - - RETURN - END - - - - - SUBROUTINE ROS1_DDM(N,NSENSIT,T,Tnext,Hstart, - + y,Info,FUNC_CHEM,JAC_CHEM,HESS_CHEM) - IMPLICIT NONE - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_sparse.h' - INCLUDE 'KPP_ROOT_global.h' -C -C Linearly Implicit Euler with direct-decoupled calculation of sensitivities -C A method of theoretical interest but of no practical value -C -C The global variable DDMTYPE distinguishes between: -C DDMTYPE = 0 : sensitivities w.r.t. initial values -C DDMTYPE = 1 : sensitivities w.r.t. parameters -C -C INPUT ARGUMENTS: -C y = Vector of: (1:NVAR) concentrations, followed by -C (1:NVAR) sensitivities w.r.t. first parameter, followed by -C etc., followed by -C (1:NVAR) sensitivities w.r.t. NSENSIT's parameter -C (y contains initial values at input, final values at output) -C [T, Tnext] = the integration interval -C Hmin, Hmax = lower and upper bounds for the selected step-size. -C Note that for Step = Hmin the current computed -C solution is unconditionally accepted by the error -C control mechanism. -C AbsTol, RelTol = (NVAR) dimensional vectors of -C componentwise absolute and relative tolerances. -C FUNC_CHEM = name of routine of derivatives. KPP syntax. -C See the header below. -C JAC_CHEM = name of routine that computes the Jacobian, in -C sparse format. KPP syntax. See the header below. -C Info(1) = 1 for Autonomous system -C = 0 for nonAutonomous system -C -C OUTPUT ARGUMENTS: -C y = the values of concentrations at Tend. -C T = equals TENDon output. -C Info(2) = # of FUNC_CHEM CALLs. -C Info(3) = # of JAC_CHEM CALLs. -C Info(4) = # of accepted steps. -C Info(5) = # of rejected steps. -C Hstart = The last accepted stepsize -C -C Adrian Sandu, December 2001 -C - INTEGER NSENSIT - KPP_REAL Fv(NVAR*(NSENSIT+1)), Hv(NVAR) - KPP_REAL DFDP(NVAR*NSENSIT) - KPP_REAL JAC(LU_NONZERO), AJAC(LU_NONZERO) - KPP_REAL HESS(NHESS) - KPP_REAL DJDP(NVAR*NSENSIT) - KPP_REAL H, Hstart - KPP_REAL y(NVAR*(NSENSIT+1)) - KPP_REAL T, Tnext, Tplus - KPP_REAL elo,ghinv,uround - - INTEGER n,nfcn,njac,Naccept,Nreject,i,j,ier - INTEGER Info(5) - LOGICAL IsReject, Autonomous - EXTERNAL FUNC_CHEM, JAC_CHEM, HESS_CHEM - - - H = Hstart - Tplus = T - Nfcn = 0 - Njac = 0 - -C === Starting the time loop === - 10 CONTINUE - - Tplus = T + H - IF ( Tplus .gt. Tnext ) THEN - H = Tnext - T - Tplus = Tnext - END IF - -C Initial Function and Jacobian values - CALL FUNC_CHEM(NVAR, T, y, Fv) - Nfcn = Nfcn+1 - CALL JAC_CHEM(NVAR, T, y, JAC) - Njac = Njac+1 - CALL HESS_CHEM( NVAR, T, y, HESS ) - IF (DDMTYPE .EQ. 1) THEN - CALL DFUNDPAR(NVAR, NSENSIT, T, y, DFDP) - END IF - -C Form the Prediction matrix and compute its LU factorization - DO 40 j=1,LU_NONZERO - AJAC(j) = -JAC(j) - 40 CONTINUE - DO 50 j=1,NVAR - AJAC(LU_DIAG(j)) = AJAC(LU_DIAG(j)) + 1.0d0/H - 50 CONTINUE - CALL KppDecomp (AJAC, ier) -C - IF (ier.ne.0) THEN - PRINT *,'ROS1: Singular factorization at T=',T,'; H=',H - STOP - END IF - -C ------------ STAGE 1------------------------- - CALL KppSolve (AJAC, Fv) -C --- If derivative w.r.t. parameters - IF (DDMTYPE .EQ. 1) THEN - CALL DJACDPAR(NVAR, NSENSIT, T, y, Fv(1), DJDP) - END IF -C --- End of derivative w.r.t. parameters - - DO 100 i=1,NSENSIT - CALL Jac_SP_Vec (JAC, y(i*NVAR+1), Fv(i*NVAR+1)) - CALL Hess_Vec ( HESS, y(i*NVAR+1), Fv(1), Hv ) - IF (DDMTYPE .EQ. 0) THEN - DO 80 j=1,NVAR - Fv(i*NVAR+j) = Fv(i*NVAR+j) + Hv(j) - 80 CONTINUE - ELSE - DO 90 j=1,NVAR - Fv(i*NVAR+j) = Fv(i*NVAR+j) + Hv(j) - & + DFDP(i*NVAR+j)+ DJDP((i-1)*NVAR+j) - 90 CONTINUE - END IF - CALL KppSolve (AJAC, Fv(i*NVAR+1)) - 100 CONTINUE - -C ---- The Solution --- - DO 160 j = 1,NVAR*(NSENSIT+1) - y(j) = y(j) + Fv(j) - 160 CONTINUE - T = T + H - -C ======= End of the time loop =============================== - IF ( T .lt. Tnext ) THEN - GO TO 10 - END IF - -C ======= Output Information ================================= - Info(2) = Nfcn - Info(3) = Njac - Info(4) = Naccept - Info(5) = Nreject - Hstart = H - - RETURN - END - - - - SUBROUTINE FUNC_CHEM(N, T, Y, P) - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - INTEGER N - KPP_REAL T, Told - KPP_REAL Y(NVAR), P(NVAR) - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Fun( Y, FIX, RCONST, P ) - TIME = Told - RETURN - END - - - SUBROUTINE DFUNDPAR(N, NSENSIT, T, Y, P) -C --- Computes the partial derivatives of FUNC_CHEM w.r.t. parameters - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' -C --- NCOEFF, JCOEFF useful for derivatives w.r.t. rate coefficients - INTEGER NCOEFF, JCOEFF(NREACT) - COMMON /DDMRCOEFF/ NCOEFF, JCOEFF - - INTEGER N - KPP_REAL T, Told - KPP_REAL Y(NVAR), P(NVAR*NSENSIT) - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() -C - IF (DDMTYPE .EQ. 0) THEN -C --- Note: the values below are for sensitivities w.r.t. initial values; -C --- they may have to be changed for other applications - DO j=1,NSENSIT - DO i=1,NVAR - P(i+NVAR*(j-1)) = 0.0D0 - END DO - END DO - ELSE -C --- Example: the call below is for sensitivities w.r.t. rate coefficients; -C --- JCOEFF(1:NSENSIT) are the indices of the NSENSIT rate coefficients -C --- w.r.t. which one differentiates - CALL dFun_dRcoeff( Y, FIX, NCOEFF, JCOEFF, P ) - END IF - TIME = Told - RETURN - END - - SUBROUTINE JAC_CHEM(N, T, Y, J) - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - INTEGER N - KPP_REAL Told, T - KPP_REAL Y(NVAR), J(LU_NONZERO) - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Jac_SP( Y, FIX, RCONST, J ) - TIME = Told - RETURN - END - - - SUBROUTINE DJACDPAR(N, NSENSIT, T, Y, U, P) -C --- Computes the partial derivatives of JAC w.r.t. parameters times user vector U - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' -C --- NCOEFF, JCOEFF useful for derivatives w.r.t. rate coefficients - INTEGER NCOEFF, JCOEFF(NREACT) - COMMON /DDMRCOEFF/ NCOEFF, JCOEFF - - INTEGER N - KPP_REAL T, Told - KPP_REAL Y(NVAR), U(NVAR) - KPP_REAL P(NVAR*NSENSIT) - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() -C - IF (DDMTYPE .EQ. 0) THEN -C --- Note: the values below are for sensitivities w.r.t. initial values; -C --- they may have to be changed for other applications - DO j=1,NSENSIT - DO i=1,NVAR - P(i+NVAR*(j-1)) = 0.0D0 - END DO - END DO - ELSE -C --- Example: the call below is for sensitivities w.r.t. rate coefficients; -C --- JCOEFF(1:NSENSIT) are the indices of the NSENSIT rate coefficients -C --- w.r.t. which one differentiates - CALL dJac_dRcoeff( Y, FIX, U, NCOEFF, JCOEFF, P ) - END IF - TIME = Told - RETURN - END - - - SUBROUTINE HESS_CHEM(N, T, Y, HESS) - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - INTEGER N - KPP_REAL Told, T - KPP_REAL Y(NVAR), HESS(NHESS) - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Hessian( Y, FIX, RCONST, HESS ) - TIME = Told - RETURN - END - - - - diff --git a/boxmox/int/oldies/ros2.c b/boxmox/int/oldies/ros2.c deleted file mode 100644 index 88cc5116a33e0d9f63db506c040dc75c549290e4..0000000000000000000000000000000000000000 --- a/boxmox/int/oldies/ros2.c +++ /dev/null @@ -1,311 +0,0 @@ - - #define MAX(a,b) ((a) >= (b)) ?(a):(b) - #define MIN(b,c) ((b) < (c)) ?(b):(c) - #define abs(x) ((x) >= 0 ) ?(x):(-x) - #define dabs(y) (double)abs(y) - #define DSQRT(d) (double)pow(d,0.5) - #define signum(x)((x) >= 0 ) ?(1):(-1) - - - - void (*forfun)(int,KPP_REAL,KPP_REAL [],KPP_REAL []); - void (*forjac)(int,KPP_REAL,KPP_REAL [],KPP_REAL []); - - - - -void FUNC_CHEM(int N,KPP_REAL T,KPP_REAL Y[NVAR],KPP_REAL P[NVAR]) - { - KPP_REAL Told; - Told = TIME; - TIME = T; - Update_SUN(); - Update_RCONST(); - Fun( Y, FIX, RCONST, P ); - TIME = Told; - } - -void JAC_CHEM(int N,KPP_REAL T,KPP_REAL Y[NVAR],KPP_REAL J[LU_NONZERO]) - { - KPP_REAL Told; - Told = TIME; - TIME = T; - Update_SUN(); - Update_RCONST(); - Jac_SP( Y, FIX, RCONST, J ); - TIME = Told; - } - - - - - - INTEGRATE(KPP_REAL TIN,KPP_REAL TOUT ) - { - - /* TIN - Start Time */ - /* TOUT - End Time */ - - - int INFO[5]; - forfun = &FUNC_CHEM; - forjac = &JAC_CHEM; - INFO[0] = Autonomous; - ROS2(NVAR,TIN,TOUT,STEPMIN,STEPMAX,STEPMIN,VAR,ATOL - ,RTOL,INFO,forfun,forjac); - - } - - -int ROS2(int N,KPP_REAL T, KPP_REAL Tnext,KPP_REAL Hmin,KPP_REAL Hmax, - KPP_REAL Hstart,KPP_REAL y[NVAR],KPP_REAL AbsTol[NVAR],KPP_REAL RelTol[NVAR], - int INFO[5],void (*forfun)(int,KPP_REAL,KPP_REAL [],KPP_REAL []), - void (*forjac)(int,KPP_REAL,KPP_REAL [],KPP_REAL []) ) - { - - -/* - All the arguments aggree with the KPP syntax. - - INPUT ARGUMENTS: - y = Vector of (NVAR) concentrations, contains the - initial values on input - [T, Tnext] = the integration interval - Hmin, Hmax = lower and upper bounds for the selected step-size. - Note that for Step = Hmin the current computed - solution is unconditionally accepted by the error - control mechanism. - AbsTol, RelTol = (NVAR) dimensional vectors of - componentwise absolute and relative tolerances. - FUNC_CHEM = name of routine of derivatives. KPP syntax. - See the header below. - JAC_CHEM = name of routine that computes the Jacobian, in - sparse format. KPP syntax. See the header below. - Info(1) = 1 for autonomous system - = 0 for nonautonomous system - - OUTPUT ARGUMENTS: - y = the values of concentrations at Tend. - T = equals Tend on output. - Info(2) = # of FUNC_CHEM calls. - Info(3) = # of JAC_CHEM calls. - Info(4) = # of accepted steps. - Info(5) = # of rejected steps. -*/ - - KPP_REAL K1[NVAR], K2[NVAR], K3[NVAR], K4[NVAR]; - KPP_REAL F1[NVAR], JAC[LU_NONZERO]; - KPP_REAL ghinv , uround , dround , c43 , tau; - KPP_REAL ynew[NVAR]; - KPP_REAL H, Hold, Tplus; - KPP_REAL ERR, factor, facmax; - int n,nfcn,njac,Naccept,Nreject,i,j,ier; - char IsReject,Autonomous; - - KPP_REAL gamma, m1, m2, alpha, beta, delta, theta, g[NVAR], x[NVAR]; - -/* Initialization of counters, etc. */ - Autonomous = (INFO[0] == 1); - uround = (double)(1e-15); - - dround = DSQRT(uround); - c43 = (double)(- 8.e0/3.e0); - H = MAX( (double)1.e-8, Hmin ); - Tplus = T; - IsReject = 0; - Naccept = 0; - Nreject = 0; - nfcn = 0; - njac = 0; - gamma = (double)(1.e0 + 1.e0/DSQRT(2.e0)); - -/* === Starting the time loop === */ - while(T < Tnext) - { - ten : - Tplus = T + H; - - if ( Tplus > Tnext ) - { - H = Tnext - T; - Tplus = Tnext; - } - - (*forjac)(NVAR, T, y,JAC ); - - njac = njac+1; - ghinv = (double)(-1.0e0/(gamma*H)); - - - - for(j=0;j Hmin ) - { - H = (double)(5.0e-1*H); - goto ten; - } - else - printf("IER <> 0 , H = %d", H); - - }/* main ier if ends*/ - - - (*forfun)(NVAR , T, y, F1 ) ; - - - - - - -/* ====== NONAUTONOMOUS CASE =============== */ - if(Autonomous == 0) - { - tau =( dround*MAX ((double)1.0e-6, dabs(T)) *signum(T) ); - (*forfun)(NVAR, T+tau, y, K2); - nfcn=nfcn+1; - - for(j = 0;j1) && (Hold>Hmin) ) - { - IsReject = 1; - Nreject = Nreject + 1; - } - else - { - IsReject = 0; - for(i=0;i 0, H=',H - STOP - END IF - END IF - - CALL FUNC_CHEM( T, Y, F1 ) - -C ====== NONAUTONOMOUS CASE =============== - IF (.NOT. Autonomous) THEN - tau = DSIGN(DROUND*DMAX1( 1.0d-6, DABS(T) ), T) - CALL FUNC_CHEM( T+tau, Y, K2) - nfcn=nfcn+1 - DO 30 j = 1,NVAR - DFDT(j) = ( K2(j)-F1(j) )/tau - 30 CONTINUE - END IF ! .NOT.Autonomous - -C ----- STAGE 1 ----- - delta = gamma*H - DO 40 j = 1,NVAR - K1(j) = F1(j) - 40 CONTINUE - IF (.NOT.Autonomous) THEN - DO 45 j = 1,NVAR - K1(j) = K1(j) + delta*DFDT(j) - 45 CONTINUE - END IF ! .NOT.Autonomous - CALL KppSolve (JAC, K1) - -C ----- STAGE 2 ----- - DO 50 j = 1,NVAR - Ynew(j) = Y(j) + a21*K1(j) - 50 CONTINUE - CALL FUNC_CHEM( T+H, Ynew, F1) - nfcn=nfcn+1 - beta = -c21/H - DO 55 j = 1,NVAR - K2(j) = F1(j) + beta*K1(j) - 55 CONTINUE - IF (.NOT.Autonomous) THEN - delta = -gamma*H - DO 56 j = 1,NVAR - K2(j) = K2(j) + delta*DFDT(j) - 56 CONTINUE - END IF ! .NOT.Autonomous - CALL KppSolve (JAC, K2) - -C ----- STAGE 3 ----- - IF (Embed3) THEN - beta1 = -c31/H - beta2 = -c32/H - delta = gamma3*H - DO 57 j = 1,NVAR - K3(j) = F1(j) + beta1*K1(j) + beta2*K2(j) - 57 CONTINUE - IF (.NOT.Autonomous) THEN - DO 58 j = 1,NVAR - K3(j) = K3(j) + delta*DFDT(j) - 58 CONTINUE - END IF ! .NOT.Autonomous - CALL KppSolve (JAC, K3) - END IF ! Embed3 - - -C ---- The Solution --- - DO 120 j = 1,NVAR - Ynew(j) = Y(j) + m1*K1(j) + m2*K2(j) - 120 CONTINUE - - -C ====== Error estimation ======== - - ERR=0.d0 - DO 130 i=1,NVAR - w = AbsTol(i) + RelTol(i)*DMAX1(DABS(Y(i)),DABS(Ynew(i))) - IF ( Embed3 ) THEN - e = d1*K1(i) + d2*K2(i) + d3*K3(i) - ELSE - e = 1.d0/(2.d0*gamma)*(K1(i)+K2(i)) - END IF ! Embed3 - ERR = ERR + ( e/w )**2 - 130 CONTINUE - ERR = DMAX1( uround, DSQRT( ERR/NVAR ) ) - -C ======= Choose the stepsize =============================== - - IF ( Embed3 ) THEN - elo = 3.0D0 ! estimator local order - ELSE - elo = 2.0D0 - END IF - factor = DMAX1(2.0D-1,DMIN1(6.0D0,ERR**(1.0D0/elo)/.9D0)) - Hnew = DMIN1(Hmax,DMAX1(Hmin, H/factor)) - -C ======= Rejected/Accepted Step ============================ - - IF ( (ERR.gt.1).and.(H.gt.Hmin) ) THEN - IsReject = .true. - H = DMIN1(H/10,Hnew) - Nreject = Nreject+1 - ELSE - DO 140 i=1,NVAR - Y(i) = Ynew(i) - 140 CONTINUE - T = Tplus - IF (.NOT.IsReject) THEN - H = Hnew ! Do not increase stepsize IF previous step was rejected - END IF - IsReject = .false. - Naccept = Naccept+1 - END IF - -C ======= END of the time loop =============================== - END DO - - -C ======= Output Information ================================= - Info(2) = Nfcn - Info(3) = Njac - Info(4) = Naccept - Info(5) = Nreject - - RETURN - END - - - - SUBROUTINE FUNC_CHEM( T, Y, P ) - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - KPP_REAL T, Told - KPP_REAL Y(NVAR), P(NVAR) - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Fun( Y, FIX, RCONST, P ) - TIME = Told - RETURN - END - - - SUBROUTINE JAC_CHEM( T, Y, J ) - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - KPP_REAL Told, T - KPP_REAL Y(NVAR), J(LU_NONZERO) - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Jac_SP( Y, FIX, RCONST, J ) - TIME = Told - RETURN - END - - - - - - diff --git a/boxmox/int/oldies/ros2.f90 b/boxmox/int/oldies/ros2.f90 deleted file mode 100644 index e6b35f12bc7e9d3b1830680948720c01aa341099..0000000000000000000000000000000000000000 --- a/boxmox/int/oldies/ros2.f90 +++ /dev/null @@ -1,294 +0,0 @@ - SUBROUTINE INTEGRATE( TIN, TOUT ) - - USE KPP_ROOT_global - -! TIN - Start Time - KPP_REAL TIN -! TOUT - End Time - KPP_REAL TOUT - - INTEGER INFO(5) - - EXTERNAL FUNC_CHEM, JAC_CHEM - - INFO(1) = Autonomous - - call ROS2(NVAR,TIN,TOUT,STEPMIN,STEPMAX, & - STEPMIN,VAR,ATOL,RTOL, & - Info,FUNC_CHEM,JAC_CHEM) - - - END SUBROUTINE INTEGRATE - - - - - SUBROUTINE ROS2(N,T,Tnext,Hmin,Hmax,Hstart, & - y,AbsTol,RelTol, & - Info,FUNC_CHEM,JAC_CHEM) - - USE KPP_ROOT_params - USE KPP_ROOT_Jacobian_sparsity - IMPLICIT NONE - -! INPUT ARGUMENTS: -! y = Vector of (NVAR) concentrations, contains the -! initial values on input -! [T, Tnext] = the integration interval -! Hmin, Hmax = lower and upper bounds for the selected step-size. -! Note that for Step = Hmin the current computed -! solution is unconditionally accepted by the error -! control mechanism. -! AbsTol, RelTol = (NVAR) dimensional vectors of -! componentwise absolute and relative tolerances. -! FUNC_CHEM = name of routine of derivatives. KPP syntax. -! See the header below. -! JAC_CHEM = name of routine that computes the Jacobian, in -! sparse format. KPP syntax. See the header below. -! Info(1) = 1 for autonomous system -! = 0 for nonautonomous system -! Info(2) = 1 for third order embedded formula -! = 0 for first order embedded formula -! -! Note: Stage 3 used to build strongly A-stable order 3 formula for error control -! Embed3 = (Info(2).EQ.1) -! if Embed3 = .true. then the third order embedded formula is used -! .false. then a first order embedded formula is used -! -! -! OUTPUT ARGUMENTS: -! y = the values of concentrations at Tend. -! T = equals Tend on output. -! Info(2) = # of FUNC_CHEM calls. -! Info(3) = # of JAC_CHEM calls. -! Info(4) = # of accepted steps. -! Info(5) = # of rejected steps. - - KPP_REAL K1(NVAR), K2(NVAR), K3(NVAR) - KPP_REAL F1(NVAR), JAC(LU_NONZERO) - KPP_REAL DFDT(NVAR) - KPP_REAL Hmin,Hmax,Hnew,Hstart,ghinv,uround - KPP_REAL y(NVAR), ynew(NVAR) - KPP_REAL AbsTol(NVAR), RelTol(NVAR) - KPP_REAL T, Tnext, H, Hold, Tplus - KPP_REAL ERR, factor, facmax - KPP_REAL tau, beta, elo, dround, a21, c31, c32 - KPP_REAL gamma3, d1, d2, d3, gam - INTEGER n,nfcn,njac,Naccept,Nreject,i,j,ier - INTEGER Info(5) - LOGICAL IsReject, Autonomous, Embed3 - EXTERNAL FUNC_CHEM, JAC_CHEM - - KPP_REAL gamma, m1, m2, alpha, beta1, beta2, delta, w, e - -! Initialization of counters, etc. - Autonomous = Info(1) .EQ. 1 - Embed3 = Info(2) .EQ. 1 - uround = 1.d-15 - dround = dsqrt(uround) - H = DMAX1(1.d-8, Hmin) - Tplus = T - IsReject = .false. - Naccept = 0 - Nreject = 0 - Nfcn = 0 - Njac = 0 - -! Method Parameters - gamma = 1.d0 + 1.d0/sqrt(2.d0) - a21 = - 1.d0/gamma - m1 = -3.d0/(2.d0*gamma) - m2 = -1.d0/(2.d0*gamma) - c31 = -1.0D0/gamma**2*(1.0D0-7.0D0*gamma+9.0D0*gamma**2) & - /(-1.0D0+2.0D0*gamma) - c32 = -1.0D0/gamma**2*(1.0D0-6.0D0*gamma+6.0D0*gamma**2) & - /(-1.0D0+2.0D0*gamma)/2 - gamma3 = 0.5D0 - 2*gamma - d1 = ((-9.0D0*gamma+8.0D0*gamma**2+2.0D0)/gamma**2/ & - (-1.0D0+2*gamma))/6.0D0 - d2 = ((-1.0D0+3.0D0*gamma)/gamma**2/(-1.0D0+2.0D0*gamma))/6.0D0 - d3 = -1.0D0/(3.0D0*gamma) - -! === Starting the time loop === - 10 CONTINUE - Tplus = T + H - if ( Tplus .gt. Tnext ) then - H = Tnext - T - Tplus = Tnext - end if - - call JAC_CHEM(NVAR, T, y, JAC) - - Njac = Njac+1 - ghinv = -1.0d0/(gamma*H) - DO j=1,NVAR - JAC(LU_DIAG(j)) = JAC(LU_DIAG(j)) + ghinv - END DO - CALL KppDecomp (JAC, ier) - - if (ier.ne.0) then - if ( H.gt.Hmin) then - H = 5.0d-1*H - go to 10 - else - print *,'IER <> 0, H=',H - stop - end if - end if - - call FUNC_CHEM(NVAR, T, y, F1) - -! ====== NONAUTONOMOUS CASE =============== - IF (.not. Autonomous) THEN - tau = dsign(dround*dmax1( 1.0d-6, dabs(T) ), T) - call FUNC_CHEM(NVAR, T+tau, y, K2) - nfcn=nfcn+1 - DO j = 1,NVAR - DFDT(j) = ( K2(j)-F1(j) )/tau - END DO - END IF ! .NOT.Autonomous - -! ----- STAGE 1 ----- - DO j = 1,NVAR - K1(j) = F1(j) - END DO - IF (.NOT.Autonomous) THEN - delta = gamma*H - DO j = 1,NVAR - K1(j) = K1(j) + delta*DFDT(j) - END DO - END IF ! .NOT.Autonomous - call KppSolve (JAC, K1) - -! ----- STAGE 2 ----- - DO j = 1,NVAR - ynew(j) = y(j) + a21*K1(j) - END DO - call FUNC_CHEM(NVAR, T+H, ynew, F1) - nfcn=nfcn+1 - beta = 2.d0/(gamma*H) - DO j = 1,NVAR - K2(j) = F1(j) + beta*K1(j) - END DO - IF (.NOT. Autonomous) THEN - delta = -gamma*H - DO j = 1,NVAR - K2(j) = K2(j) + delta*DFDT(j) - END DO - END IF ! .NOT.Autonomous - call KppSolve (JAC, K2) - -! ----- STAGE 3 ----- - IF (Embed3) THEN - beta1 = -c31/H - beta2 = -c32/H - delta = gamma3*H - DO j = 1,NVAR - K3(j) = F1(j) + beta1*K1(j) + beta2*K2(j) - END DO - IF (.NOT.Autonomous) THEN - DO j = 1,NVAR - K3(j) = K3(j) + delta*DFDT(j) - END DO - END IF ! .NOT.Autonomous - CALL KppSolve (JAC, K3) - END IF ! Embed3 - - - -! ---- The Solution --- - DO j = 1,NVAR - ynew(j) = y(j) + m1*K1(j) + m2*K2(j) - END DO - - -! ====== Error estimation ======== - - ERR=0.d0 - DO i=1,NVAR - w = AbsTol(i) + RelTol(i)*DMAX1(DABS(y(i)),DABS(ynew(i))) - IF ( Embed3 ) THEN - e = d1*K1(i) + d2*K2(i) + d3*K3(i) - ELSE - e = 1.d0/(2.d0*gamma)*(K1(i)+K2(i)) - END IF ! Embed3 - ERR = ERR + ( e/w )**2 - END DO - ERR = DMAX1( uround, DSQRT( ERR/NVAR ) ) - -! ======= Choose the stepsize =============================== - - IF ( Embed3 ) THEN - elo = 3.0D0 ! estimator local order - ELSE - elo = 2.0D0 - END IF - factor = DMAX1(2.0D-1,DMIN1(6.0D0,ERR**(1.0D0/elo)/.9D0)) - Hnew = DMIN1(Hmax,DMAX1(Hmin, H/factor)) - -! ======= Rejected/Accepted Step ============================ - - IF ( (ERR.gt.1).and.(H.gt.Hmin) ) THEN - IsReject = .true. - H = DMIN1(H/10,Hnew) - Nreject = Nreject+1 - ELSE - DO i=1,NVAR - y(i) = ynew(i) - END DO - T = Tplus - IF (.NOT. IsReject) THEN - H = Hnew ! Do not increase stepsize if previous step was rejected - END IF - IsReject = .false. - Naccept = Naccept+1 - END IF - - -! ======= End of the time loop =============================== - IF ( T .lt. Tnext ) GO TO 10 - - - -! ======= Output Information ================================= - Info(2) = Nfcn - Info(3) = Njac - Info(4) = Naccept - Info(5) = Nreject - - END SUBROUTINE Ros2 - - - - SUBROUTINE FUNC_CHEM(N, T, Y, P) - USE KPP_ROOT_global - INTEGER N - KPP_REAL T, Told - KPP_REAL Y(NVAR), P(NVAR) - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Fun( Y, FIX, RCONST, P ) - TIME = Told - END SUBROUTINE FUNC_CHEM - - - SUBROUTINE JAC_CHEM(N, T, Y, J) - USE KPP_ROOT_global - INTEGER N - KPP_REAL Told, T - KPP_REAL Y(NVAR), J(LU_NONZERO) - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Jac_SP( Y, FIX, RCONST, J ) - TIME = Told - END SUBROUTINE JAC_CHEM - - - - - - diff --git a/boxmox/int/oldies/ros2_cts_adj.f b/boxmox/int/oldies/ros2_cts_adj.f deleted file mode 100644 index 353a0938825374d43e040f26e42493fef5266d4a..0000000000000000000000000000000000000000 --- a/boxmox/int/oldies/ros2_cts_adj.f +++ /dev/null @@ -1,312 +0,0 @@ - SUBROUTINE ros2_cts_adj(N,T,Tnext,Hmin,Hmax,Hstart, - + y,Lambda,Fix,Rconst,AbsTol,RelTol, - + Info) - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - -C INPUT ARGUMENTS: -C y = Vector of (NVAR) concentrations, contains the -C initial values on input -C [T, Tnext] = the integration interval -C Hmin, Hmax = lower and upper bounds for the selected step-size. -C Note that for Step = Hmin the current computed -C solution is unconditionally accepted by the error -C control mechanism. -C AbsTol, RelTol = (NVAR) dimensional vectors of -C componentwise absolute and relative tolerances. -C FUN = name of routine of derivatives. KPP syntax. -C See the header below. -C JAC_SP = name of routine that computes the Jacobian, in -C sparse format. KPP syntax. See the header below. -C Info(1) = 1 for autonomous system -C = 0 for nonautonomous system -C Info(2) = 1 for third order embedded formula -C = 0 for first order embedded formula -C -C Note: Stage 3 used to build strongly A-stable order 3 formula for error control -C Embed3 = (Info(2).EQ.1) -C IF Embed3 = .true. THEN the third order embedded formula is used -C .false. THEN a first order embedded formula is used -C -C -C OUTPUT ARGUMENTS: -C y = the values of concentrations at TEND. -C T = equals TEND on output. -C Info(2) = # of FUN CALLs. -C Info(3) = # of JAC_SP CALLs. -C Info(4) = # of accepted steps. -C Info(5) = # of rejected steps. - - INTEGER max_no_steps - PARAMETER (max_no_steps = 200) - KPP_REAL Trajectory(NVAR,max_no_steps) - KPP_REAL StepSize(max_no_steps) - - KPP_REAL K1(NVAR), K2(NVAR), K3(NVAR) - KPP_REAL F1(NVAR), JAC(LU_NONZERO) - KPP_REAL DFDT(NVAR)(NRAD) - KPP_REAL Fix(NFIX), Rconst(NREACT) - KPP_REAL Hmin,Hmax,Hstart,ghinv,uround - KPP_REAL y(NVAR), Ynew(NVAR) - KPP_REAL AbsTol(NVAR), RelTol(NVAR) - KPP_REAL T, Tnext, H, Hold, Tplus - KPP_REAL ERR, factor, facmax - KPP_REAL Lambda(NVAR), K11(NVAR), JAC1(LU_NONZERO) - INTEGER n,nfcn,njac,Naccept,Nreject,i,j - INTEGER Info(5) - LOGICAL IsReject, Autonomous, Embed3 - EXTERNAL FUN, JAC_SP - - KPP_REAL gamma, m1, m2, alpha, beta1, beta2, delta, w, e - KPP_REAL ginv -c Initialization of counters, etc. - Autonomous = Info(1) .EQ. 1 - Embed3 = Info(2) .EQ. 1 - uround = 1.d-15 - dround = dsqrt(uround) - H = DMAX1(Hstart,DMAX1(1.d-8, Hmin)) - Tplus = T - IsReject = .false. - Naccept = 0 - Nreject = 0 - Nfcn = 0 - Njac = 0 - -C Method Parameters - gamma = 1.d0 + 1.d0/sqrt(2.d0) - a21 = - 1.d0/gamma - m1 = -3.d0/(2.d0*gamma) - m2 = -1.d0/(2.d0*gamma) - c31 = -1.0D0/gamma**2*(1.0D0-7.0D0*gamma+9.0D0*gamma**2) - & /(-1.0D0+2.0D0*gamma) - c32 = -1.0D0/gamma**2*(1.0D0-6.0D0*gamma+6.0D0*gamma**2) - & /(-1.0D0+2.0D0*gamma)/2 - gamma3 = 0.5D0 - 2*gamma - d1 = ((-9.0D0*gamma+8.0D0*gamma**2+2.0D0)/gamma**2/ - & (-1.0D0+2*gamma))/6.0D0 - d2 = ((-1.0D0+3.0D0*gam)/gamma**2/ - & (-1.0D0+2.0D0*gamma))/6.0D0 - d3 = -1.0D0/(3.0D0*gamma) - - Trajectory(1:NVAR,1) = Ynew(1) - -C === Starting the time loop === - 10 CONTINUE - Tplus = T + H - IF ( Tplus .gt. Tnext ) THEN - H = Tnext - T - Tplus = Tnext - END IF - - CALL Jac_SP( Y, Fix, Rconst, JAC ) - - Njac = Njac+1 - ghinv = -1.0d0/(gamma*H) - DO 20 j=1,NVAR - JAC(LU_DIAG_V(j)) = JAC(LU_DIAG_V(j)) + ghinv - 20 CONTINUE - CALL KppDecomp (NVAR, JAC, ier) - - IF (ier.ne.0) THEN - IF ( H.gt.Hmin) THEN - H = 5.0d-1*H - GO TO 10 - else - PRINT *,'IER <> 0, H=',H - STOP - END IF - END IF - - CALL Fun( Y, Fix, Rconst, F1 ) - -C ====== NONAUTONOMOUS CASE =============== - IF (.not. Autonomous) THEN - tau = dsign(dround*dmax1( 1.0d-6, dabs(T) ), T) - CALL Fun( Y, Fix, Rconst, K2 ) - nfcn=nfcn+1 - DO 30 j = 1,NVAR - DFDT(j) = ( K2(j)-F1(j) )/tau - 30 CONTINUE - END IF ! .NOT.Autonomous - -C ----- STAGE 1 ----- - DO 40 j = 1,NVAR - K1(j) = F1(j) - 40 CONTINUE - IF (.NOT.Autonomous) THEN - delta = gamma*H - DO 45 j = 1,NVAR - K1(j) = K1(j) + delta*DFDT(j) - 45 CONTINUE - END IF ! .NOT.Autonomous - CALL KppSolve (JAC, K1) - -C ----- STAGE 2 ----- - DO 50 j = 1,NVAR - Ynew(j) = y(j) + a21*K1(j) - 50 CONTINUE - CALL Fun( Ynew, Fix, Rconst, F1 ) - nfcn=nfcn+1 - beta = 2.d0/(gamma*H) - delta = -gamma*H - DO 55 j = 1,NVAR - K2(j) = F1(j) + beta*K1(j) - 55 CONTINUE - IF (.NOT.Autonomous) THEN - DO 56 j = 1,NVAR - K2(j) = K2(j) + delta*DFDT(j) - 56 CONTINUE - END IF ! .NOT.Autonomous - CALL KppSolve (JAC, K2) - -C ----- STAGE 3 ----- - IF (Embed3) THEN - beta1 = -c31/H - beta2 = -c32/H - delta = gamma3*H - DO 57 j = 1,NVAR - K3(j) = F1(j) + beta1*K1(j) + beta2*K2(j) - 57 CONTINUE - IF (.NOT.Autonomous) THEN - DO 58 j = 1,NVAR - K3(j) = K3(j) + delta*DFDT(j) - 58 CONTINUE - END IF ! .NOT.Autonomous - CALL KppSolve (JAC, K3) - END IF ! Embed3 - - -C ---- The Solution --- - DO 120 j = 1,NVAR - Ynew(j) = y(j) + m1*K1(j) + m2*K2(j) - 120 CONTINUE - - -C ====== Error estimation ======== - - ERR=0.d0 - DO 130 i=1,NVAR - w = AbsTol(i) + RelTol(i)*DMAX1(DABS(y(i)),DABS(Ynew(i))) - IF ( Embed3 ) THEN - e = d1*K1(i) + d2*K2(i) + d3*K3(i) - ELSE - e = 1.d0/(2.d0*gamma)*(K1(i)+K2(i)) - END IF ! Embed3 - ERR = ERR + ( e/w )**2 - 130 CONTINUE - ERR = DMAX1( uround, DSQRT( ERR/NVAR ) ) - -C ======= Choose the stepsize =============================== - - IF ( Embed3 ) THEN - elo = 3.0D0 ! estimator local order - ELSE - elo = 2.0D0 - END IF - factor = DMAX1(2.0D-1,DMIN1(6.0D0,ERR**(1.0D0/elo)/.9D0)) - Hnew = DMIN1(Hmax,DMAX1(Hmin, H/factor)) - Hold = H - -C ======= Rejected/Accepted Step ============================ - - IF ( (ERR.gt.1).and.(H.gt.Hmin) ) THEN - IsReject = .true. - H = DMIN1(H/10,Hnew) - Nreject = Nreject+1 - ELSE - DO 140 i=1,NVAR - y(i) = Ynew(i) - 140 CONTINUE - T = Tplus - IF (.NOT.IsReject) THEN - H = Hnew ! Do not increase stepsize IF previous step was rejected - END IF - IsReject = .false. - Naccept = Naccept+1 - IF (Naccept+1>max_no_steps) THEN - PRINT*,'Error in Adjoint Ros2: more steps than allowed' - STOP - END IF - Trajectory(1:NVAR,Naccept+1) = Ynew(1:NVAR) - StepSize(Naccept) = Hold -! CALL TRAJISTORE(y,hold) - END IF -C ======= END of the time loop =============================== - IF ( T .lt. Tnext ) GO TO 10 - -C ======= Output Information ================================= - Info(2) = Nfcn - Info(3) = Njac - Info(4) = Naccept - Info(5) = Nreject - - ginv = 1.d0/gamma -C -- The backwards loop for the CONTINUOUS ADJOINT - DO istep = Naccept,1,-1 - - h = StepSize(istep) - y(1:NVAR) = Trajectory(1:NVAR,istep+1) - gHinv = -ginv/H - - CALL Jac_SP(Y, Fix, Rconst, JAC) - JAC1(1:LU_NONZERO)=JAC(1:LU_NONZERO) - DO j=1,NVAR - JAC(lu_diag_v(j)) = JAC(lu_diag_v(j)) + gHinv - END DO - CALL KppDecomp (NVAR,JAC,ier) -ccc equivalent to function evaluation in forward integration -ccc is J^T*Lambda in backward integration - CALL JacTR_SP_Vec ( JAC1, Lambda, F1) - -C ----- STAGE 1 (AUTONOMOUS) ----- - K11(1:NVAR) = F1(1:NVAR) - CALL KppSolveTR (JAC,K11,K1) -C ----- STAGE 2 (AUTONOMOUS) ----- - y(1:NVAR) = Trajectory(1:NVAR,istep) - CALL Jac_SP(Y, Fix, Rconst, JAC1) - Ynew(1:NVAR) = Lambda(1:NVAR) - ginv*K1(1:NVAR) - CALL JacTR_SP_Vec ( JAC1, Ynew, F1) - beta = -2.d0*ghinv - K11(1:NVAR) = F1(1:NVAR) + beta*K1(1:NVAR) - CALL KppSolveTR (JAC,K11,K2) -c ---- The solution - Lambda(1:NVAR) = Lambda(1:NVAR)+m1*K1(1:NVAR)+m2*K2(1:NVAR) - - END DO ! istep - - - RETURN - END - - - SUBROUTINE FUNC_CHEM(N, T, Y, P) - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - INTEGER N - KPP_REAL T, Told - KPP_REAL Y(NVAR), P(NVAR) - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Fun( Y, FIX, RCONST, P ) - TIME = Told - RETURN - END - - - SUBROUTINE JAC_CHEM(N, T, Y, J) - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - INTEGER N - KPP_REAL Told, T - KPP_REAL Y(NVAR), J(LU_NONZERO) - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Jac_SP( Y, FIX, RCONST, J ) - TIME = Told - RETURN - END - diff --git a/boxmox/int/oldies/ros2_ddm.def b/boxmox/int/oldies/ros2_ddm.def deleted file mode 100644 index a4ec807955fa87e0429467f0e40ce67828bd7ab1..0000000000000000000000000000000000000000 --- a/boxmox/int/oldies/ros2_ddm.def +++ /dev/null @@ -1,50 +0,0 @@ - -#FUNCTION AGGREGATE -#JACOBIAN SPARSE_LU_ROW - -#DOUBLE ON -#INTFILE ros2_ddm -#HESSIAN ON - -#INLINE F77_DECL_INT - INTEGER Autonomous - COMMON /INTGDATA/ Autonomous - REAL*8 STEPSTART - COMMON /GDATA/ STEPSTART -#ENDINLINE - -#INLINE F77_INIT_INT - STEPMIN=1.0E-4 - STEPMAX=3600. - Autonomous = 0 - STEPSTART=STEPMIN -#ENDINLINE - -#INLINE F90_DECL_INT - INTEGER :: Autonomous - DOUBLE PRECISION :: STEPSTART -#ENDINLINE - -#INLINE F90_INIT_INT - STEPMIN=0.0001 - STEPMAX=3600. - Autonomous = 0 - STEPSTART=STEPMIN -#ENDINLINE - -#INLINE C_DECL_INT - extern int Autonomous; - extern double STEPSTART; -#ENDINLINE - -#INLINE C_DATA_INT - int Autonomous; - double STEPSTART; -#ENDINLINE - -#INLINE C_INIT_INT - STEPMIN = 0.0001; - STEPMAX = 3600.0; - Autonomous = 0; - STEPSTART = STEPMIN; -#ENDINLINE diff --git a/boxmox/int/oldies/ros2_ddm.f b/boxmox/int/oldies/ros2_ddm.f deleted file mode 100644 index 2997e1b220ee15d132e49064d17386eb31a6cf75..0000000000000000000000000000000000000000 --- a/boxmox/int/oldies/ros2_ddm.f +++ /dev/null @@ -1,480 +0,0 @@ - SUBROUTINE INTEGRATE( NSENSIT, Y, TIN, TOUT ) - - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - - INTEGER NSENSIT -C TIN - Start Time - KPP_REAL TIN -C TOUT - End Time - KPP_REAL TOUT -C Y - Concentrations and Sensitivities - KPP_REAL Y(NVAR*(NSENSIT+1)) -C --- Note: Y contains: (1:NVAR) concentrations, followed by -C --- (1:NVAR) sensitivities w.r.t. first parameter, followed by -C --- etc., followed by -C --- (1:NVAR) sensitivities w.r.t. NSENSIT's parameter - - INTEGER INFO(5) - - EXTERNAL FUNC_CHEM, JAC_CHEM - - INFO(1) = Autonomous - - CALL ROS2_DDM(NVAR,NSENSIT,TIN,TOUT,STEPMIN,STEPMAX, - + STEPMIN,Y,ATOL,RTOL, - + Info,FUNC_CHEM,JAC_CHEM) - - - RETURN - END - - - - - SUBROUTINE ROS2_DDM(N,NSENSIT,T,Tnext,Hmin,Hmax,Hstart, - + y,AbsTol,RelTol, - + Info,FUNC_CHEM,JAC_CHEM) - IMPLICIT NONE - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - INCLUDE 'KPP_ROOT_sparse.h' -C -C Ros2 with direct-decoupled calculation of sensitivities -C -C The global variable DDMTYPE distinguishes between: -C DDMTYPE = 0 : sensitivities w.r.t. initial values -C DDMTYPE = 1 : sensitivities w.r.t. parameters -C -C INPUT ARGUMENTS: -C y = Vector of: (1:NVAR) concentrations, followed by -C (1:NVAR) sensitivities w.r.t. first parameter, followed by -C etc., followed by -C (1:NVAR) sensitivities w.r.t. NSENSIT's parameter -C (y contains initial values at input, final values at output) -C [T, Tnext] = the integration interval -C Hmin, Hmax = lower and upper bounds for the selected step-size. -C Note that for Step = Hmin the current computed -C solution is unconditionally accepted by the error -C control mechanism. -C AbsTol, RelTol = (NVAR) dimensional vectors of -C componentwise absolute and relative tolerances. -C FUNC_CHEM = name of routine of derivatives. KPP syntax. -C See the header below. -C JAC_CHEM = name of routine that computes the Jacobian, in -C sparse format. KPP syntax. See the header below. -C Info(1) = 1 for autonomous system -C = 0 for nonautonomous system -C -C OUTPUT ARGUMENTS: -C y = the values of concentrations at TEND. -C T = equals TEND on output. -C Info(2) = # of FUNC_CHEM calls. -C Info(3) = # of JAC_CHEM calls. -C Info(4) = # of accepted steps. -C Info(5) = # of rejected steps. -C -C Adrian Sandu, December 2001 - - - INTEGER NSENSIT - KPP_REAL y(NVAR*(NSENSIT+1)), ynew(NVAR*(NSENSIT+1)) - KPP_REAL K1(NVAR*(NSENSIT+1)) - KPP_REAL K2(NVAR*(NSENSIT+1)) - KPP_REAL K3(NVAR) - KPP_REAL DFDT(NVAR*(NSENSIT+1)) - KPP_REAL DFDP(NVAR*NSENSIT+1), DFDPDT(NVAR*NSENSIT+1) - KPP_REAL DJDP(NVAR*NSENSIT+1) - KPP_REAL F1(NVAR), F2(NVAR) - KPP_REAL JAC(LU_NONZERO), AJAC(LU_NONZERO) - KPP_REAL DJDT(LU_NONZERO) - KPP_REAL HESS(NHESS) - KPP_REAL Hmin,Hmax,Hnew,Hstart,ghinv,uround - KPP_REAL AbsTol(NVAR), RelTol(NVAR) - KPP_REAL T, Tnext, H, Hold, Tplus, e - KPP_REAL ERR, factor, facmax, dround, elo, tau, gam - - INTEGER n,nfcn,njac,Naccept,Nreject,i,j,ier - INTEGER Info(5) - LOGICAL IsReject,Autonomous,Embed3 - EXTERNAL FUNC_CHEM, JAC_CHEM, HESS_CHEM - - LOGICAL negative - KPP_REAL gamma, m1, m2, alpha, beta, delta, theta, w - KPP_REAL gamma3, d1, d2, d3, beta1, beta2 - KPP_REAL c31, c32, c34 - -c Initialization of counters, etc. - Autonomous = Info(1) .EQ. 1 - Embed3 = Info(2) .EQ. 1 - uround = 1.d-15 - dround = 1.0d-7 ! DSQRT(uround) - H = DMAX1(1.d-8, Hstart) - Tplus = T - IsReject = .false. - Naccept = 0 - Nreject = 0 - Nfcn = 0 - Njac = 0 - gamma = 1.d0 + 1.d0/DSQRT(2.0d0) - c31 = -1.0D0/gamma**2*(1.0D0-7.0D0*gamma+9.0D0*gamma**2) - & /(-1.0D0+2.0D0*gamma) - c32 = -1.0D0/gamma**2*(1.0D0-6.0D0*gamma+6.0D0*gamma**2) - & /(-1.0D0+2.0D0*gamma)/2 - gamma3 = 0.5D0 - 2*gamma - d1 = ((-9.0D0*gamma+8.0D0*gamma**2+2.0D0)/gamma**2/ - & (-1.0D0+2*gamma))/6.0D0 - d2 = ((-1.0D0+3.0D0*gamma)/gamma**2/ - & (-1.0D0+2.0D0*gamma))/6.0D0 - d3 = -1.0D0/(3.0D0*gamma) - m1 = -3.d0/(2.d0*gamma) - m2 = -1.d0/(2.d0*gamma) - - -C === Starting the time loop === - 10 CONTINUE - Tplus = T + H - IF ( Tplus .gt. Tnext ) THEN - H = Tnext - T - Tplus = Tnext - END IF - -C Initial Function, Jacobian, and Hessian Values - CALL FUNC_CHEM(NVAR, T, y, F1) - CALL JAC_CHEM(NVAR, T, y, JAC) - CALL HESS_CHEM( NVAR, T, y, HESS ) - IF (DDMTYPE .EQ. 1) THEN - CALL DFUNDPAR(NVAR, NSENSIT, T, y, DFDP) - END IF - -C Estimate the time derivatives in non-autonomous case - IF (.not. Autonomous) THEN - tau = DSIGN(dround*DMAX1( 1.0d0, DABS(T) ), T) - CALL FUNC_CHEM(NVAR, T+tau, y, K2) - nfcn=nfcn+1 - CALL JAC_CHEM(NVAR, T+tau, y, AJAC) - njac=njac+1 - DO 20 j = 1,NVAR - DFDT(j) = ( K2(j)-F1(j) )/tau - 20 CONTINUE - DO 30 j = 1,LU_NONZERO - DJDT(j) = ( AJAC(j)-JAC(j) )/tau - 30 CONTINUE - DO 40 i=1,NSENSIT - CALL Jac_SP_Vec (DJDT,y(i*NVAR+1),DFDT(i*NVAR+1)) - 40 CONTINUE - END IF ! .not. Autonomous - - Njac = Njac+1 - ghinv = - 1.0d0/(gamma*H) - DO 50 j=1,LU_NONZERO - AJAC(j) = JAC(j) - 50 CONTINUE - DO 60 j=1,NVAR - AJAC(LU_DIAG(j)) = JAC(LU_DIAG(j)) + ghinv - 60 CONTINUE - CALL KppDecomp (AJAC, ier) - - IF (ier.ne.0) THEN - IF ( H.gt.Hmin) THEN - H = 5.0d-1*H - go to 10 - ELSE - print *,'IER <> 0, H=',H - stop - END IF - END IF - - - - -C ----- STAGE 1 ----- - delta = gamma*H - DO 70 j = 1,NVAR - K1(j) = F1(j) - 70 CONTINUE - IF (.NOT. Autonomous) THEN - DO 80 j = 1,NVAR - K1(j) = K1(j) + delta*DFDT(j) - 80 CONTINUE - END IF - CALL KppSolve (AJAC, K1) -C --- If derivative w.r.t. parameters - IF (DDMTYPE .EQ. 1) THEN - CALL DJACDPAR(NVAR, NSENSIT, T, y, K1(1), DJDP) - END IF -C --- End of derivative w.r.t. parameters - DO 120 i=1,NSENSIT - CALL Jac_SP_Vec (JAC,y(i*NVAR+1),K1(i*NVAR+1)) - CALL Hess_Vec ( HESS, K1(1), y(i*NVAR+1), F2 ) - DO 90 j=1,NVAR - K1(i*NVAR+j) = K1(i*NVAR+j) + gHinv*F2(j) - 90 CONTINUE - IF (.NOT. Autonomous) THEN - DO 100 j = 1,NVAR - K1(i*NVAR+j) = K1(i*NVAR+j) + delta*DFDT(i*NVAR+j) - 100 CONTINUE - END IF -C --- If derivative w.r.t. parameters - IF (DDMTYPE .EQ. 1) THEN - DO 110 j = 1,NVAR - K1(i*NVAR+j) = K1(i*NVAR+j) + DFDP((i-1)*NVAR+j) - & + DJDP((i-1)*NVAR+j) - 110 CONTINUE - END IF -C --- End of derivative w.r.t. parameters - CALL KppSolve (AJAC, K1(i*NVAR+1)) - 120 CONTINUE - -C ----- STAGE 2 ----- - alpha = - 1.d0/gamma - DO 130 j = 1,NVAR*(NSENSIT+1) - ynew(j) = y(j) + alpha*K1(j) - 130 CONTINUE - CALL FUNC_CHEM(NVAR, T+H, ynew, F1) - IF (DDMTYPE.EQ.1) THEN - CALL DFUNDPAR(NVAR, NSENSIT, T+H, ynew, DFDP) - END IF - nfcn=nfcn+1 - beta1 = 2.d0/(gamma*H) - delta = -gamma*H - DO 140 j = 1,NVAR - K2(j) = F1(j) + beta1*K1(j) - 140 CONTINUE - IF (.NOT. Autonomous) THEN - DO 150 j = 1,NVAR - K2(j) = K2(j) + delta*DFDT(j) - 150 CONTINUE - END IF - CALL KppSolve (AJAC, K2) -C --- If derivative w.r.t. parameters - IF (DDMTYPE .EQ. 1) THEN - CALL DJACDPAR(NVAR, NSENSIT, T, y, K2(1), DJDP) - END IF -C --- End of derivative w.r.t. parameters - - CALL JAC_CHEM(NVAR, T+H, Ynew, JAC) - njac=njac+1 - DO 190 i=1,NSENSIT - CALL Jac_SP_Vec (JAC,ynew(i*NVAR+1),K2(i*NVAR+1)) - CALL Jac_SP_Vec (DJDT,y(i*NVAR+1),F1) - CALL Hess_Vec ( HESS, K2(1), y(i*NVAR+1), F2 ) - DO 160 j = 1,NVAR - K2(i*NVAR+j) = K2(i*NVAR+j) + beta1*K1(i*NVAR+j) - & + gHinv*F2(j) - 160 CONTINUE - IF (.NOT. Autonomous) THEN - DO 170 j = 1,NVAR - K2(i*NVAR+j) = K2(i*NVAR+j) + delta*DFDT(i*NVAR+j) - 170 CONTINUE - END IF -C --- If derivative w.r.t. parameters - IF (DDMTYPE .EQ. 1) THEN - DO 180 j = 1,NVAR - K2(i*NVAR+j) = K2(i*NVAR+j) + DFDP((i-1)*NVAR+j) - & + DJDP((i-1)*NVAR+j) - 180 CONTINUE - END IF -C --- End of derivative w.r.t. parameters - CALL KppSolve (AJAC, K2(i*NVAR+1)) - 190 CONTINUE - -C ----- STAGE 3 for error control only ----- - IF (Embed3) THEN - beta1 = -c31/H - beta2 = -c32/H - delta = gamma3*H - DO 195 j = 1,NVAR - K3(j) = F1(j) + beta1*K1(j) + beta2*K2(j) - 195 CONTINUE - IF (.NOT. Autonomous) THEN - DO 196 j = 1,NVAR - K3(j) = K3(j) + delta*DFDT(j) - 196 CONTINUE - END IF - CALL KppSolve (AJAC, K3) - END IF - -C ---- The Solution --- - DO 200 j = 1,NVAR*(NSENSIT+1) - ynew(j) = y(j) + m1*K1(j) + m2*K2(j) - 200 CONTINUE - - -C ====== Error estimation for concentrations only; this can be easily adapted to -C estimate the sensitivity error too ======== - - ERR=0.d0 - DO 210 i=1,NVAR - w = AbsTol(i) + RelTol(i)*DMAX1(DABS(y(i)),DABS(ynew(i))) - IF (Embed3) THEN - e = d1*K1(i) + d2*K2(i) + d3*K3(i) - ELSE - e = (1.d0/(2.d0*gamma))*(K1(i)+K2(i)) - END IF - ERR = ERR + ( e/w )**2 - 210 CONTINUE - ERR = DMAX1( uround, DSQRT( ERR/NVAR ) ) - -C ======= Choose the stepsize =============================== - - IF (Embed3) THEN - elo = 3.0D0 ! estimator local order - ELSE - elo = 2.0D0 - END IF - factor = DMAX1(2.0D-1,DMIN1(6.0D0,ERR**(1.0D0/elo)/.9D0)) - Hnew = DMIN1(Hmax,DMAX1(Hmin, H/factor)) - -C ======= Rejected/Accepted Step ============================ - - IF ( (ERR.gt.1).and.(H.gt.Hmin) ) THEN - IsReject = .true. - H = DMIN1(H/10,Hnew) - Nreject = Nreject+1 - ELSE - DO 300 i=1,NVAR*(NSENSIT+1) - y(i) = ynew(i) - 300 CONTINUE - T = Tplus - IF (.NOT.IsReject) THEN - H = Hnew ! Do not increase stepsize if previous step was rejected - END IF - IsReject = .false. - Naccept = Naccept+1 - END IF - -C ======= End of the time loop =============================== - IF ( T .lt. Tnext ) GO TO 10 - - - -C ======= Output Information ================================= - Info(2) = Nfcn - Info(3) = Njac - Info(4) = Naccept - Info(5) = Nreject - - RETURN - END - - - - SUBROUTINE FUNC_CHEM(N, T, Y, P) - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - KPP_REAL T, Told - KPP_REAL Y(NVAR), P(NVAR) - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Fun( Y, FIX, RCONST, P ) - TIME = Told - RETURN - END - - - SUBROUTINE DFUNDPAR(N, NSENSIT, T, Y, P) -C --- Computes the partial derivatives of FUNC_CHEM w.r.t. parameters - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' -C --- NCOEFF, JCOEFF useful for derivatives w.r.t. rate coefficients - INTEGER NCOEFF, JCOEFF(NREACT) - COMMON /DDMRCOEFF/ NCOEFF, JCOEFF - - KPP_REAL T, Told - KPP_REAL Y(NVAR), P(NVAR*NSENSIT) - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() -C - IF (DDMTYPE .EQ. 0) THEN -C --- Note: the values below are for sensitivities w.r.t. initial values; -C --- they may have to be changed for other applications - DO j=1,NSENSIT - DO i=1,NVAR - P(i+NVAR*(j-1)) = 0.0D0 - END DO - END DO - ELSE -C --- Example: the call below is for sensitivities w.r.t. rate coefficients; -C --- JCOEFF(1:NSENSIT) are the indices of the NSENSIT rate coefficients -C --- w.r.t. which one differentiates - CALL dFun_dRcoeff( Y, FIX, NCOEFF, JCOEFF, P ) - END IF - TIME = Told - RETURN - END - - SUBROUTINE DJACDPAR(N, NSENSIT, T, Y, U, P) -C --- Computes the partial derivatives of JAC w.r.t. parameters times user vector U - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' -C --- NCOEFF, JCOEFF useful for derivatives w.r.t. rate coefficients - INTEGER NCOEFF, JCOEFF(NREACT) - COMMON /DDMRCOEFF/ NCOEFF, JCOEFF - - KPP_REAL T, Told - KPP_REAL Y(NVAR), U(NVAR) - KPP_REAL P(NVAR*NSENSIT) - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() -C - IF (DDMTYPE .EQ. 0) THEN -C --- Note: the values below are for sensitivities w.r.t. initial values; -C --- they may have to be changed for other applications - DO j=1,NSENSIT - DO i=1,NVAR - P(i+NVAR*(j-1)) = 0.0D0 - END DO - END DO - ELSE -C --- Example: the call below is for sensitivities w.r.t. rate coefficients; -C --- JCOEFF(1:NSENSIT) are the indices of the NSENSIT rate coefficients -C --- w.r.t. which one differentiates - CALL dJac_dRcoeff( Y, FIX, U, NCOEFF, JCOEFF, P ) - END IF - TIME = Told - RETURN - END - - SUBROUTINE JAC_CHEM(N, T, Y, J) - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - INTEGER N - KPP_REAL Told, T - KPP_REAL Y(NVAR), J(LU_NONZERO) - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Jac_SP( Y, FIX, RCONST, J ) - TIME = Told - RETURN - END - - - SUBROUTINE HESS_CHEM(N, T, Y, HESS) - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - INTEGER N - KPP_REAL Told, T - KPP_REAL Y(NVAR), HESS(NHESS) - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Hessian( Y, FIX, RCONST, HESS ) - TIME = Told - RETURN - END - - - - - - diff --git a/boxmox/int/oldies/ros3.c b/boxmox/int/oldies/ros3.c deleted file mode 100644 index da6b1272468220322dc7288a1efe7b4c2ff3658b..0000000000000000000000000000000000000000 --- a/boxmox/int/oldies/ros3.c +++ /dev/null @@ -1,344 +0,0 @@ - - #define MAX(a,b) ((a) >= (b)) ?(a):(b) - #define MIN(b,c) ((b) < (c)) ?(b):(c) - #define abs(x) ((x) >= 0 ) ?(x):(-x) - #define dabs(y) (double)abs(y) - #define DSQRT(d) (double)pow(d,0.5) - #define signum(x)((x) >= 0 ) ?(1):(-1) - - void (*forfun)(int,KPP_REAL,KPP_REAL [],KPP_REAL []); - void (*forjac)(int,KPP_REAL,KPP_REAL [],KPP_REAL []); - - - - void FUNC_CHEM(int N,KPP_REAL T,KPP_REAL Y[NVAR],KPP_REAL P[NVAR]) - { - KPP_REAL Told; - Told = TIME; - TIME = T; - Update_SUN(); - Update_PHOTO(); - Fun( Y, FIX, RCONST, P ); - TIME = Told; - }/* function fun ends here */ - - - void JAC_CHEM(int N,KPP_REAL T,KPP_REAL Y[NVAR],KPP_REAL J[LU_NONZERO]) - { - KPP_REAL Told; - Told = TIME; - TIME = T; - Update_SUN(); - Update_PHOTO(); - Jac_SP( Y, FIX, RCONST, J ); - TIME = Told; - } - - - INTEGRATE( KPP_REAL TIN, KPP_REAL TOUT ) - { - - /* TIN - Start Time */ - /* TOUT - End Time */ - - int INFO[5]; - forfun = &FUNC_CHEM; - forjac = &JAC_CHEM; - INFO[0] = Autonomous; - ROS3(NVAR,TIN,TOUT,STEPMIN,STEPMAX,STEPMIN,VAR,ATOL,RTOL,INFO - ,forfun,forjac); - } /* function integrate ends here */ - - - -int ROS3(int N,KPP_REAL T,KPP_REAL Tnext,KPP_REAL Hmin,KPP_REAL Hmax, -KPP_REAL Hstart,KPP_REAL y[NVAR],KPP_REAL AbsTol[NVAR],KPP_REAL RelTol[NVAR], -int INFO[5],void (*forfun)(int,KPP_REAL,KPP_REAL [],KPP_REAL []) , -void (*forjac)(int,KPP_REAL,KPP_REAL [],KPP_REAL []) ) - { - -/* - - L-stable Rosenbrock 3(2), with - strongly A-stable embedded formula for error control. - - All the arguments aggree with the KPP syntax. - - INPUT ARGUMENTS: - y = Vector of (NVAR) concentrations, contains the - initial values on input - [T, Tnext] = the integration interval - Hmin, Hmax = lower and upper bounds for the selected step-size. - Note that for Step = Hmin the current computed - solution is unconditionally accepted by the error - control mechanism. - AbsTol, RelTol = (NVAR) dimensional vectors of - componentwise absolute and relative tolerances. - FUNC_CHEM = name of routine of derivatives. KPP syntax. - See the header below. - JAC_CHEM = name of routine that computes the Jacobian, in - sparse format. KPP syntax. See the header below. - Info(1) = 1 for autonomous system - = 0 for nonautonomous system - - OUTPUT ARGUMENTS: - y = the values of concentrations at Tend. - T = equals Tend on output. - Info(2) = # of FUNC_CHEM calls. - Info(3) = # of JAC_CHEM calls. - Info(4) = # of accepted steps. - Info(5) = # of rejected steps. - - Adrian Sandu, April 1996 - The Center for Global and Regional Environmental Research -*/ - - KPP_REAL K1[NVAR], K2[NVAR], K3[NVAR]; - KPP_REAL F1[NVAR], JAC[LU_NONZERO]; - KPP_REAL ghinv,uround,dround,c43,x1,x2,x3,ytol; - KPP_REAL gam,c21,c31,c32,b1,b2,b3,d1,d2,d3,a21,a31,a32,alpha2,alpha3, - g1,g2,g3; - KPP_REAL ynew[NVAR]; - KPP_REAL H, Hold, Tplus,tau; - KPP_REAL ERR, factor, facmax; - int n,nfcn,njac,Naccept,Nreject,i,j,ier; - char IsReject,Autonomous; - - -/* Initialization of counters, etc. */ - Autonomous = (INFO[0] == 1); - uround = (double)1.e-15; - dround = DSQRT(uround); - H = MAX( (double)1.e-8, Hstart); - Tplus = T; - IsReject = 0; - Naccept = 0; - Nreject = 0; - nfcn = 0; - njac = 0; - gam = (double) (.43586652150845899941601945119356e+00); - c21 = (double) -(.10156171083877702091975600115545e+01); - c31 = (double) (.40759956452537699824805835358067e+01); - c32 = (double) (.92076794298330791242156818474003e+01); - b1 = (double) (.10000000000000000000000000000000e+01); - b2 = (double) (.61697947043828245592553615689730e+01); - b3 = (double) -(.42772256543218573326238373806514e+00); - d1 = (double) (.50000000000000000000000000000000e+00); - d2 = (double) -(.29079558716805469821718236208017e+01); - d3 = (double) (.22354069897811569627360909276199e+00); - a21 = (double) 1.e0; - a31 = (double) 1.e0; - a32 = (double) 0.e0; - alpha2 = gam; - alpha3 = gam; - g1 = (double) (.43586652150845899941601945119356e+00); - g2 = (double) (.24291996454816804366592249683314e+00); - g3 = (double) (.21851380027664058511513169485832e+01); - - -/* === Starting the time loop === */ - -while( T < Tnext ) - { - ten : - Tplus = T + H; - - if ( Tplus > Tnext ) - { - H = Tnext - T; - Tplus = Tnext; - } - - (*forjac)(NVAR, T, y, JAC); - - njac = njac+1; - ghinv = (double)-1.0e0/(gam*H); - - for(j=0;j Hmin ) - { - H = (double)5.0e-1*H; - goto ten; - } - else - { - printf("IER <> 0 , H = %d", H); - } - }/* main ier if ends*/ - - - (*forfun)(NVAR, T, y, F1); - - -/* ====== NONAUTONOMOUS CASE =============== */ - if( Autonomous == 0 ) - { - tau =(double) (dround*MAX( (double)1.0e-6, dabs(T) ) * signum(T) ); - - (*forfun)(NVAR, T+tau, y, K2); - - nfcn=nfcn+1; - - for(j=0;j /lib/libm.so.6 (0x40015000) - libc.so.6 => /lib/libc.so.6 (0x40032000) - /lib/ld-linux.so.2 => /lib/ld-linux.so.2 (0x40000000) -*/ - -/* ======= Choose the stepsize =============================== */ - - factor = 0.9/pow( ERR , (1.e0/3.e0) ); - if(IsReject == 1) - facmax = (double)1.0; - - else - facmax = (double)10.0; - - - factor = (double)MAX( 1.0e-1, MIN(factor,facmax) ); - Hold = H; - H = (double)MIN( Hmax, MAX(Hmin,factor*H) ); - - -/* ======= Rejected/Accepted Step ============================ */ - - if ( (ERR > 1) && (Hold > Hmin) ) - { - IsReject = 1; - Nreject = Nreject+1; - } - else - { - IsReject = 0; - - for(i = 0;i < NVAR;i++) - y[i] = ynew[i]; - - T = Tplus; - Naccept = Naccept+1; - - }/* else should end here */ - - -/* ======= End of the time loop =============================== */ - - } /* while loop (T < Tnext) ends here */ - - -/* ======= Output Information ================================= */ - INFO[1] = nfcn; - INFO[2] = njac; - INFO[3] = Naccept; - INFO[4] = Nreject; - - } /* function rodas ends here */ - - diff --git a/boxmox/int/oldies/ros3.def b/boxmox/int/oldies/ros3.def deleted file mode 100644 index d179b6c62d7b57d5fbf91c28b38bc84c6537f43a..0000000000000000000000000000000000000000 --- a/boxmox/int/oldies/ros3.def +++ /dev/null @@ -1,46 +0,0 @@ - -#FUNCTION AGGREGATE -#JACOBIAN SPARSE_LU_ROW - -#DOUBLE ON -#INTFILE ros3 - -#INLINE F77_DECL_INT - INTEGER Autonomous - COMMON /INTGDATA/ Autonomous - REAL*8 STEPSTART - COMMON /GDATA/ STEPSTART -#ENDINLINE - -#INLINE F77_INIT_INT - STEPMIN=0.0001 - STEPMAX=3600. - Autonomous = 0 - STEPSTART=STEPMIN -#ENDINLINE - - -#INLINE F90_DECL_INT - INTEGER Autonomous - DOUBLE PRECISION STEPSTART -#ENDINLINE - -#INLINE F90_INIT_INT - STEPMIN=0.0001 - STEPMAX=3600. - Autonomous = 0 - STEPSTART=STEPMIN -#ENDINLINE - -#INLINE C_DECL_INT - int Autonomous; - double STEPSTART; -#ENDINLINE - -#INLINE C_INIT_INT - STEPMIN=1e-4; - STEPMAX=3600.; - Autonomous = 0; - STEPSTART=STEPMIN; -#ENDINLINE - diff --git a/boxmox/int/oldies/ros3.f b/boxmox/int/oldies/ros3.f deleted file mode 100644 index 0b773588d5d5333ea4126ecb86ad0a22e9cb1dc5..0000000000000000000000000000000000000000 --- a/boxmox/int/oldies/ros3.f +++ /dev/null @@ -1,304 +0,0 @@ - SUBROUTINE INTEGRATE( TIN, TOUT ) - - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - -C TIN - Start Time - KPP_REAL TIN -C TOUT - End Time - KPP_REAL TOUT - - INTEGER INFO(5) - - EXTERNAL FUNC_CHEM, JAC_CHEM - - INFO(1) = Autonomous - - CALL ROS3(NVAR,TIN,TOUT,STEPMIN,STEPMAX, - + STEPMIN,VAR,ATOL,RTOL, - + Info,FUNC_CHEM,JAC_CHEM) - - RETURN - END - - - SUBROUTINE ROS3(N,T,Tnext,Hmin,Hmax,Hstart, - + y,AbsTol,RelTol, - + Info,FUNC_CHEM,JAC_CHEM) - IMPLICIT NONE - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_sparse.h' - -C L-stable Rosenbrock 3(2), with -C strongly A-stable embedded formula for error control. -C -C All the arguments aggree with the KPP syntax. -C -C INPUT ARGUMENTS: -C y = Vector of (NVAR) concentrations, contains the -C initial values on input -C [T, Tnext] = the integration interval -C Hmin, Hmax = lower and upper bounds for the selected step-size. -C Note that for Step = Hmin the current computed -C solution is unconditionally accepted by the error -C control mechanism. -C AbsTol, RelTol = (NVAR) dimensional vectors of -C componentwise absolute and relative tolerances. -C FUNC_CHEM = name of routine of derivatives. KPP syntax. -C See the header below. -C JAC_CHEM = name of routine that computes the Jacobian, in -C sparse format. KPP syntax. See the header below. -C Info(1) = 1 for autonomous system -C = 0 for nonautonomous system -C -C OUTPUT ARGUMENTS: -C y = the values of concentrations at Tend. -C T = equals Tend on output. -C Info(2) = # of FUNC_CHEM calls. -C Info(3) = # of JAC_CHEM calls. -C Info(4) = # of accepted steps. -C Info(5) = # of rejected steps. -C -C Adrian Sandu, April 1996 -C The Center for Global and Regional Environmental Research - - KPP_REAL K1(NVAR), K2(NVAR), K3(NVAR) - KPP_REAL F1(NVAR), JAC(LU_NONZERO) - KPP_REAL Hmin,Hmax,Hnew,Hstart,ghinv,uround - KPP_REAL y(NVAR), ynew(NVAR) - KPP_REAL AbsTol(NVAR), RelTol(NVAR) - KPP_REAL T, Tnext, Tplus, H, elo - KPP_REAL ERR, factor, facmax - KPP_REAL gam, c21, c31, c32, b1, b2, b3 - KPP_REAL d1, d2, d3, a21, a31, a32 - KPP_REAL alpha2, alpha3, g1, g2, g3 - KPP_REAL tau, x1, x2, x3, dround, ytol - INTEGER n,nfcn,njac,Naccept,Nreject,i,j,ier - INTEGER Info(5) - LOGICAL IsReject,Autonomous - EXTERNAL FUNC_CHEM, JAC_CHEM - - gam= .43586652150845899941601945119356d+00 - c21= -.10156171083877702091975600115545d+01 - c31= .40759956452537699824805835358067d+01 - c32= .92076794298330791242156818474003d+01 - b1= .10000000000000000000000000000000d+01 - b2= .61697947043828245592553615689730d+01 - b3= -.42772256543218573326238373806514d+00 - d1= .50000000000000000000000000000000d+00 - d2= -.29079558716805469821718236208017d+01 - d3= .22354069897811569627360909276199d+00 - a21 = 1.d0 - a31 = 1.d0 - a32 = 0.d0 - alpha2 = gam - alpha3 = gam - g1= .43586652150845899941601945119356d+00 - g2= .24291996454816804366592249683314d+00 - g3= .21851380027664058511513169485832d+01 - - -c Initialization of counters, etc. - Autonomous = Info(1) .EQ. 1 - uround = 1.d-15 - dround = DSQRT(uround) - IF (Hmax.le.0.D0) THEN - Hmax = DABS(Tnext-T) - END IF - H = DMAX1(1.d-8, Hstart) - Tplus = T - IsReject = .false. - Naccept = 0 - Nreject = 0 - Nfcn = 0 - Njac = 0 - -C === Starting the time loop === - 10 continue - - Tplus = T + H - if ( Tplus .gt. Tnext ) then - H = Tnext - T - Tplus = Tnext - end if - - CALL JAC_CHEM(NVAR, T, y, JAC) - Njac = Njac+1 - gHinv = -1.0d0/(gam*H) - do 15 j=1,LU_NONZERO - JAC(j) = -JAC(j) - 15 continue - do 20 j=1,NVAR - JAC(LU_DIAG(j)) = JAC(LU_DIAG(j)) - gHinv - 20 continue - CALL KppDecomp (JAC, ier) - - if (ier.ne.0) then - if ( H.gt.Hmin) then - H = 5.0d-1*H - go to 10 - else - print *,'IER <> 0, H=',H - stop - end if - end if - - CALL FUNC_CHEM(NVAR, T, y, F1) - -C ====== NONAUTONOMOUS CASE =============== - IF (.not. Autonomous) THEN - tau = DSIGN(dround*DMAX1( 1.0d-6, DABS(T) ), T) - CALL FUNC_CHEM(NVAR, T+tau, y, K2) - nfcn=nfcn+1 - do 30 j = 1,NVAR - K3(j) = ( K2(j)-F1(j) )/tau - 30 continue - -C ----- STAGE 1 (NONAUTONOMOUS) ----- - x1 = g1*H - do 35 j = 1,NVAR - K1(j) = F1(j) + x1*K3(j) - 35 continue - CALL KppSolve (JAC, K1) - -C ----- STAGE 2 (NONAUTONOMOUS) ----- - do 40 j = 1,NVAR - ynew(j) = y(j) + K1(j) - 40 continue - CALL FUNC_CHEM(NVAR, T+gam*H, ynew, F1) - nfcn=nfcn+1 - x1 = c21/H - x2 = g2*H - do 45 j = 1,NVAR - K2(j) = F1(j) + x1*K1(j) + x2*K3(j) - 45 continue - CALL KppSolve (JAC, K2) - -C ----- STAGE 3 (NONAUTONOMOUS) ----- - x1 = c31/H - x2 = c32/H - x3 = g3*H - do 50 j = 1,NVAR - K3(j) = F1(j) + x1*K1(j) + x2*K2(j) + x3*K3(j) - 50 continue - CALL KppSolve (JAC, K3) - - -C ====== AUTONOMOUS CASE =============== - ELSE - -C ----- STAGE 1 (AUTONOMOUS) ----- - do 60 j = 1,NVAR - K1(j) = F1(j) - 60 continue - CALL KppSolve (JAC, K1) - -C ----- STAGE 2 (AUTONOMOUS) ----- - do 65 j = 1,NVAR - ynew(j) = y(j) + K1(j) - 65 continue - CALL FUNC_CHEM(NVAR, T + gam*H, ynew, F1) - nfcn=nfcn+1 - x1 = c21/H - do 70 j = 1,NVAR - K2(j) = F1(j) + x1*K1(j) - 70 continue - CALL KppSolve (JAC, K2) - -C ----- STAGE 3 (AUTONOMOUS) ----- - x1 = c31/H - x2 = c32/H - do 90 j = 1,NVAR - K3(j) = F1(j) + x1*K1(j) + x2*K2(j) - 90 continue - CALL KppSolve (JAC, K3) - - END IF ! Autonomousous - -C ---- The Solution --- - - do 120 j = 1,NVAR - ynew(j) = y(j) + b1*K1(j) + b2*K2(j) + b3*K3(j) - 120 continue - - -C ====== Error estimation ======== - - ERR=0.d0 - do 130 i=1,NVAR - ytol = AbsTol(i) + RelTol(i)*DMAX1(DABS(y(i)),DABS(ynew(i))) - ERR=ERR+((d1*K1(i)+d2*K2(i)+d3*K3(i))/ytol)**2 - 130 continue - ERR = DMAX1( uround, DSQRT( ERR/NVAR ) ) - -C ======= Choose the stepsize =============================== - - elo = 3.0D0 ! estimator local order - factor = DMAX1(2.0D-1,DMIN1(6.0D0,ERR**(1.0D0/elo)/.9D0)) - Hnew = DMIN1(Hmax,DMAX1(Hmin, H/factor)) - -C ======= Rejected/Accepted Step ============================ - - IF ( (ERR.gt.1).and.(H.gt.Hmin) ) THEN - IsReject = .true. - H = DMIN1(H/10,Hnew) - Nreject = Nreject+1 - ELSE - DO 140 i=1,NVAR - y(i) = ynew(i) - 140 CONTINUE - T = Tplus - IF (.NOT.IsReject) THEN - H = Hnew ! Do not increase stepsize if previos step was rejected - END IF - IsReject = .false. - Naccept = Naccept+1 - END IF - - -C ======= End of the time loop =============================== - if ( T .lt. Tnext ) go to 10 - - -C ======= Output Information ================================= - Info(2) = Nfcn - Info(3) = Njac - Info(4) = Naccept - Info(5) = Nreject - Hstart = H - - RETURN - END - - - - SUBROUTINE FUNC_CHEM(N, T, Y, P) - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - INTEGER N - KPP_REAL T, Told - KPP_REAL Y(NVAR), P(NVAR) - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Fun( Y, FIX, RCONST, P ) - TIME = Told - RETURN - END - - SUBROUTINE JAC_CHEM(N, T, Y, J) - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - INTEGER N - KPP_REAL Told, T - KPP_REAL Y(NVAR), J(LU_NONZERO) - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Jac_SP( Y, FIX, RCONST, J ) - TIME = Told - RETURN - END - diff --git a/boxmox/int/oldies/ros3_ddm.def b/boxmox/int/oldies/ros3_ddm.def deleted file mode 100644 index 04518bcdfdb3b032881498bb3c6857b7c9ad712b..0000000000000000000000000000000000000000 --- a/boxmox/int/oldies/ros3_ddm.def +++ /dev/null @@ -1,51 +0,0 @@ - -#FUNCTION AGGREGATE -#JACOBIAN SPARSE_LU_ROW - -#DOUBLE ON -#INTFILE ros3_ddm -#HESSIAN ON - -#INLINE F77_DECL_INT - INTEGER Autonomous - COMMON /INTGDATA/ Autonomous - REAL*8 STEPSTART - COMMON /GDATA/ STEPSTART -#ENDINLINE - -#INLINE F77_INIT_INT - STEPMIN=1.0E-4 - STEPMAX=3600. - Autonomous = 0 - STEPSTART=STEPMIN -#ENDINLINE - - -#INLINE F90_DECL_INT - INTEGER :: Autonomous - DOUBLE PRECISION :: STEPSTART -#ENDINLINE - -#INLINE F90_INIT_INT - STEPMIN=1.0E-4 - STEPMAX=3600. - Autonomous = 0 - STEPSTART=STEPMIN -#ENDINLINE - -#INLINE C_DECL_INT - extern int Autonomous; - extern double STEPSTART; -#ENDINLINE - -#INLINE C_DATA_INT - int Autonomous; - double STEPSTART; -#ENDINLINE - -#INLINE C_INIT_INT - STEPMIN = 0.0001; - STEPMAX = 3600.0; - Autonomous = 0; - STEPSTART = STEPMIN; -#ENDINLINE diff --git a/boxmox/int/oldies/ros3_ddm.f b/boxmox/int/oldies/ros3_ddm.f deleted file mode 100644 index db8b34311723182ce5aff53eaafbeb491e73f776..0000000000000000000000000000000000000000 --- a/boxmox/int/oldies/ros3_ddm.f +++ /dev/null @@ -1,503 +0,0 @@ - SUBROUTINE INTEGRATE( NSENSIT, Y, TIN, TOUT ) - - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - -C TIN - Start Time - KPP_REAL TIN -C TOUT - End Time - KPP_REAL TOUT -C Y - Concentrations and Sensitivities - KPP_REAL Y(NVAR*(NSENSIT+1)) -C --- Note: Y contains: (1:NVAR) concentrations, followed by -C --- (1:NVAR) sensitivities w.r.t. first parameter, followed by -C --- etc., followed by -C --- (1:NVAR) sensitivities w.r.t. NSENSIT's parameter - - INTEGER INFO(5) - - EXTERNAL FUNC_CHEM, JAC_CHEM - - INFO(1) = Autonomous - - CALL ROS3_DDM(NVAR,NSENSIT,TIN,TOUT,STEPMIN,STEPMAX, - + STEPMIN,Y,ATOL,RTOL, - + Info,FUNC_CHEM,JAC_CHEM) - - RETURN - END - - - SUBROUTINE ROS3_DDM(N,NSENSIT,T,Tnext,Hmin,Hmax,Hstart, - + y,AbsTol,RelTol, - + Info,FUNC_CHEM,JAC_CHEM) - IMPLICIT NONE - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - INCLUDE 'KPP_ROOT_sparse.h' - -C L-stable Rosenbrock 3(2), with -C strongly A-stable embedded formula for error control. -C -C Direct decoupled computation of sensitivities. -C The global variable DDMTYPE distinguishes between: -C DDMTYPE = 0 : sensitivities w.r.t. initial values -C DDMTYPE = 1 : sensitivities w.r.t. parameters -C -C All the arguments aggree with the KPP syntax. -C -C INPUT ARGUMENTS: -C y = Vector of: (1:NVAR) concentrations, followed by -C (1:NVAR) sensitivities w.r.t. first parameter, followed by -C etc., followed by -C (1:NVAR) sensitivities w.r.t. NSENSIT's parameter -C (y contains initial values at input, final values at output) -C [T, Tnext] = the integration interval -C Hmin, Hmax = lower and upper bounds for the selected step-size. -C Note that for Step = Hmin the current computed -C solution is unconditionally accepted by the error -C control mechanism. -C AbsTol, RelTol = (NVAR) dimensional vectors of -C componentwise absolute and relative tolerances. -C FUNC_CHEM = name of routine of derivatives. KPP syntax. -C See the header below. -C JAC_CHEM = name of routine that computes the Jacobian, in -C sparse format. KPP syntax. See the header below. -C Info(1) = 1 for Autonomous system -C = 0 for nonAutonomous system -C -C OUTPUT ARGUMENTS: -C y = the values of concentrations at TEND. -C T = equals TEND on output. -C Info(2) = # of FUNC_CHEM calls. -C Info(3) = # of JAC_CHEM calls. -C Info(4) = # of accepted steps. -C Info(5) = # of rejected steps. -C -C Adrian Sandu, April 1996 -C The Center for Global and Regional Environmental Research - INTEGER NSENSIT - KPP_REAL y(NVAR*(NSENSIT+1)), ynew(NVAR*(NSENSIT+1)) - KPP_REAL K1(NVAR*(NSENSIT+1)) - KPP_REAL K2(NVAR*(NSENSIT+1)) - KPP_REAL K3(NVAR*(NSENSIT+1)) - KPP_REAL DFDT(NVAR*(NSENSIT+1)) - KPP_REAL DFDP(NVAR*NSENSIT), DFDPDT(NVAR*NSENSIT) - KPP_REAL DJDP(NVAR*NSENSIT) - KPP_REAL JAC(LU_NONZERO), AJAC(LU_NONZERO) - KPP_REAL DJDT(LU_NONZERO) - KPP_REAL Fv(NVAR), Hv(NVAR) - KPP_REAL HESS(NHESS) - KPP_REAL Hmin,Hmax,Hstart,ghinv,uround - KPP_REAL AbsTol(NVAR), RelTol(NVAR) - KPP_REAL T, Tnext, Tplus, H, Hnew, elo - KPP_REAL ERR, factor, facmax - INTEGER n,nfcn,njac,Naccept,Nreject,i,j,ier - INTEGER Info(5) - LOGICAL IsReject,Autonomous - EXTERNAL FUNC_CHEM, JAC_CHEM, HESS_CHEM - - KPP_REAL gamma, c21, c31,c32,b1,b2,b3,d1,d2,d3,a21,a31,a32 - KPP_REAL alpha2, alpha3, g1, g2, g3, x1, x2, x3, ytol - KPP_REAL dround, tau - - gamma= .43586652150845899941601945119356d+00 - c21= -.10156171083877702091975600115545d+01 - c31= .40759956452537699824805835358067d+01 - c32= .92076794298330791242156818474003d+01 - b1= .10000000000000000000000000000000d+01 - b2= .61697947043828245592553615689730d+01 - b3= -.42772256543218573326238373806514d+00 - d1= .50000000000000000000000000000000d+00 - d2= -.29079558716805469821718236208017d+01 - d3= .22354069897811569627360909276199d+00 - a21 = 1.d0 - a31 = 1.d0 - a32 = 0.d0 - alpha2 = gamma - g1= .43586652150845899941601945119356d+00 - g2= .24291996454816804366592249683314d+00 - g3= .21851380027664058511513169485832d+01 - - -c Initialization of counters, etc. - Autonomous = Info(1) .EQ. 1 - uround = 1.d-15 - dround = DSQRT(uround) - IF (Hmax.le.0.D0) THEN - Hmax = DABS(Tnext-T) - END IF - H = DMAX1(1.d-8, Hstart) - Tplus = T - IsReject = .false. - Naccept = 0 - Nreject = 0 - Nfcn = 0 - Njac = 0 - - -C === Starting the time loop === - 10 CONTINUE - -C ====== Initial Function, Jacobian, and Hessian values =============== - CALL FUNC_CHEM(NVAR, T, y, Fv) - Nfcn = Nfcn + 1 - CALL JAC_CHEM(NVAR, T, y, JAC) - Njac = Njac + 1 - CALL HESS_CHEM( NVAR, T, y, HESS ) - IF (DDMTYPE .EQ. 1) THEN - CALL DFUNDPAR(NVAR, NSENSIT, T, y, DFDP) - END IF - -C ====== Time derivatives for NONAutonomousous CASE =============== - IF (.not. Autonomous) THEN - tau = DSIGN(dround*DMAX1( 1.0d-6, DABS(T) ), T) - CALL FUNC_CHEM(NVAR, T+tau, y, K2) - nfcn=nfcn+1 - DO 20 j = 1,NVAR - DFDT(j) = ( K2(j)-Fv(j) )/tau - 20 CONTINUE - CALL JAC_CHEM(NVAR, T+tau, y, AJAC) - DO 30 j = 1,LU_NONZERO - DJDT(j) = ( AJAC(j)-JAC(j) )/tau - 30 CONTINUE - DO 40 i=1,NSENSIT - CALL Jac_SP_Vec (DJDT,y(i*NVAR+1),DFDT(i*NVAR+1)) - 40 CONTINUE - END IF - - - Tplus = T + H - IF ( Tplus .gt. Tnext ) then - H = Tnext - T - Tplus = Tnext - END IF - - gHinv = 1.0d0/(gamma*H) - DO 50 j=1,LU_NONZERO - AJAC(j) = -JAC(j) - 50 CONTINUE - DO 60 j=1,NVAR - AJAC(LU_DIAG(j)) = AJAC(LU_DIAG(j)) + gHinv - 60 CONTINUE - CALL KppDecomp (AJAC, ier) - - IF (ier.NE.0) THEN - IF ( H.GT.Hmin) THEN - H = 5.0d-1*H - GO TO 10 - ELSE - PRINT *,'IER <> 0, H=',H - STOP - END IF - END IF - - Autonomous = .true. - -C ------------------------------- STAGE 1 -------------------------------------- - DO 70 j = 1,NVAR - K1(j) = Fv(j) - 70 CONTINUE - IF (.NOT.Autonomous) THEN - x1 = gamma*H - DO 80 j = 1,NVAR - K1(j) = K1(j) + x1*DFDT(j) - 80 CONTINUE - END IF - CALL KppSolve (AJAC, K1) -C --- If derivative w.r.t. parameters - IF (DDMTYPE .EQ. 1) THEN - CALL DJACDPAR(NVAR, NSENSIT, T, y, K1(1), DJDP) - END IF -C --- End of derivative w.r.t. parameters - - DO 110 i=1,NSENSIT - CALL Jac_SP_Vec (JAC,y(i*NVAR+1),K1(i*NVAR+1)) - CALL Hess_Vec ( HESS, y(i*NVAR+1), K1(1), Hv ) - DO 90 j=1,NVAR - K1(i*NVAR+j) = K1(i*NVAR+j) + Hv(j) - 90 CONTINUE - IF (.NOT. Autonomous) THEN - DO 100 j=1,NVAR - K1(i*NVAR+j) = K1(i*NVAR+j) + x1*DFDT(i*NVAR+j) - 100 CONTINUE - END IF -C --- If derivative w.r.t. parameters - IF (DDMTYPE .EQ. 1) THEN - DO 44 j = 1,NVAR - K1(i*NVAR+j) = K1(i*NVAR+j) + DFDP((i-1)*NVAR+j) - & + DJDP((i-1)*NVAR+j) - 44 CONTINUE - END IF -C --- End of derivative w.r.t. parameters - CALL KppSolve (AJAC, K1(i*NVAR+1)) - 110 CONTINUE - -C ------------------------------- STAGE 2 -------------------------------------- - DO 120 j = 1,NVAR*(NSENSIT+1) - ynew(j) = y(j) + a21*K1(j) - 120 CONTINUE - CALL FUNC_CHEM(NVAR, T + alpha2*H, ynew, Fv) - IF (DDMTYPE .EQ. 1) THEN - CALL DFUNDPAR(NVAR, NSENSIT, T+alpha3*H, ynew, DFDP) - END IF - nfcn=nfcn+1 - x1 = c21/H - DO 130 j = 1,NVAR - K2(j) = Fv(j) + x1*K1(j) - 130 CONTINUE - IF (.NOT.Autonomous) THEN - x2 = g2*H - DO 140 j = 1,NVAR - K2(j) = K2(j) + x2*DFDT(j) - 140 CONTINUE - END IF - CALL KppSolve (AJAC, K2) -C --- If derivative w.r.t. parameters - IF (DDMTYPE .EQ. 1) THEN - CALL DJACDPAR(NVAR, NSENSIT, T, y, K2(1), DJDP) - END IF -C --- End of derivative w.r.t. parameters - - CALL JAC_CHEM(NVAR, T+alpha2*H, ynew, JAC) - njac=njac+1 - DO 170 i=1,NSENSIT - CALL Jac_SP_Vec (JAC,ynew(i*NVAR+1),K2(i*NVAR+1)) - CALL Hess_Vec ( HESS, y(i*NVAR+1), K2(1), Hv ) - DO 150 j = 1,NVAR - K2(i*NVAR+j) = K2(i*NVAR+j) + x1*K1(i*NVAR+j) - & + Hv(j) - 150 CONTINUE - IF (.NOT. Autonomous) THEN - DO 160 j=1,NVAR - K2(i*NVAR+j) = K2(i*NVAR+j) + x2*DFDT(i*NVAR+j) - 160 CONTINUE - END IF -C --- If derivative w.r.t. parameters - IF (DDMTYPE .EQ. 1) THEN - DO 165 j = 1,NVAR - K2(i*NVAR+j) = K2(i*NVAR+j) + DFDP((i-1)*NVAR+j) - & + DJDP((i-1)*NVAR+j) - 165 CONTINUE - END IF -C --- End of derivative w.r.t. parameters - CALL KppSolve (AJAC, K2(i*NVAR+1)) - 170 CONTINUE - -C ------------------------------- STAGE 3 -------------------------------------- - x1 = c31/H - x2 = c32/H - DO 180 j = 1,NVAR - K3(j) = Fv(j) + x1*K1(j) + x2*K2(j) - 180 CONTINUE - IF (.NOT.Autonomous) THEN - x3 = g3*H - DO 190 j = 1,NVAR - K3(j) = K3(j) + x3*DFDT(j) - 190 CONTINUE - END IF - CALL KppSolve (AJAC, K3) -C --- If derivative w.r.t. parameters - IF (DDMTYPE .EQ. 1) THEN - CALL DJACDPAR(NVAR, NSENSIT, T, y, K3(1), DJDP) - END IF -C --- End of derivative w.r.t. parameters - - DO 220 i=1,NSENSIT - CALL Jac_SP_Vec (JAC,ynew(i*NVAR+1),K3(i*NVAR+1)) - CALL Hess_Vec ( HESS, y(i*NVAR+1), K3(1), Hv ) - DO 200 j = 1,NVAR - K3(i*NVAR+j) = K3(i*NVAR+j) +x1*K1(i*NVAR+j) - & + x2*K2(i*NVAR+j) + Hv(j) - 200 CONTINUE - IF (.NOT. Autonomous) THEN - DO 210 j=1,NVAR - K3(i*NVAR+j) = K3(i*NVAR+j) + x3*DFDT(i*NVAR+j) - 210 CONTINUE - END IF -C --- If derivative w.r.t. parameters - IF (DDMTYPE .EQ. 1) THEN - DO 215 j = 1,NVAR - K3(i*NVAR+j) = K3(i*NVAR+j) + DFDP((i-1)*NVAR+j) - & + DJDP((i-1)*NVAR+j) - 215 CONTINUE - END IF -C --- End of derivative w.r.t. parameters - CALL KppSolve (AJAC, K3(i*NVAR+1)) - 220 CONTINUE - -C ------------------------------ The Solution --- - - DO 230 j = 1,NVAR*(NSENSIT+1) - ynew(j) = y(j) + b1*K1(j) + b2*K2(j) + b3*K3(j) - 230 CONTINUE - - -C ====== Error estimation ======== - - ERR=0.d0 - DO 240 i=1,NVAR - ytol = AbsTol(i) + RelTol(i)*DABS(ynew(i)) - ERR=ERR+((d1*K1(i)+d2*K2(i)+d3*K3(i))/ytol)**2 - 240 CONTINUE - ERR = DMAX1( uround, DSQRT( ERR/NVAR ) ) - -C ======= Choose the stepsize =============================== - - elo = 3.0D0 ! estimator local order - factor = DMAX1(2.0D-1,DMIN1(6.0D0,ERR**(1.0D0/elo)/.9D0)) - Hnew = DMIN1(Hmax,DMAX1(Hmin, H/factor)) - -C ======= Rejected/Accepted Step ============================ - - IF ( (ERR.gt.1).and.(H.gt.Hmin) ) THEN - IsReject = .true. - H = DMIN1(H/10,Hnew) - Nreject = Nreject+1 - GO TO 10 - ELSE - DO 250 j=1,NVAR*(NSENSIT+1) - y(j) = ynew(j) - 250 CONTINUE - T = Tplus - IF (.NOT.IsReject) THEN - H = Hnew ! Do not increase stepsize IF previos step was rejected - END IF - IsReject = .false. - Naccept = Naccept+1 - END IF - - -C ======= End of the time loop =============================== - IF ( T .lt. Tnext ) GO TO 10 - - -C ======= Output Information ================================= - Info(2) = Nfcn - Info(3) = Njac - Info(4) = Naccept - Info(5) = Nreject - Hstart = H - - RETURN - END - - - - SUBROUTINE FUNC_CHEM(N, T, Y, P) - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - INTEGER N - KPP_REAL T, Told - KPP_REAL Y(NVAR), P(NVAR) - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Fun( Y, FIX, RCONST, P ) - TIME = Told - RETURN - END - - - SUBROUTINE DFUNDPAR(N, NSENSIT, T, Y, P) -C --- Computes the partial derivatives of FUNC_CHEM w.r.t. parameters - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' -C --- NCOEFF, JCOEFF useful for derivatives w.r.t. rate coefficients - INTEGER N - INTEGER NCOEFF, JCOEFF(NREACT) - COMMON /DDMRCOEFF/ NCOEFF, JCOEFF - - KPP_REAL T, Told - KPP_REAL Y(NVAR), P(NVAR*NSENSIT) - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() -C - IF (DDMTYPE .EQ. 0) THEN -C --- Note: the values below are for sensitivities w.r.t. initial values; -C --- they may have to be changed for other applications - DO j=1,NSENSIT - DO i=1,NVAR - P(i+NVAR*(j-1)) = 0.0D0 - END DO - END DO - ELSE -C --- Example: the call below is for sensitivities w.r.t. rate coefficients; -C --- JCOEFF(1:NSENSIT) are the indices of the NSENSIT rate coefficients -C --- w.r.t. which one differentiates - CALL dFun_dRcoeff( Y, FIX, NCOEFF, JCOEFF, P ) - END IF - TIME = Told - RETURN - END - - SUBROUTINE JAC_CHEM(N, T, Y, J) - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - INTEGER N - KPP_REAL Told, T - KPP_REAL Y(NVAR), J(LU_NONZERO) - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Jac_SP( Y, FIX, RCONST, J ) - TIME = Told - RETURN - END - - - SUBROUTINE DJACDPAR(N, NSENSIT, T, Y, U, P) -C --- Computes the partial derivatives of JAC w.r.t. parameters times user vector U - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' -C --- NCOEFF, JCOEFF useful for derivatives w.r.t. rate coefficients - INTEGER N - INTEGER NCOEFF, JCOEFF(NREACT) - COMMON /DDMRCOEFF/ NCOEFF, JCOEFF - - KPP_REAL T, Told - KPP_REAL Y(NVAR), U(NVAR) - KPP_REAL P(NVAR*NSENSIT) - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() -C - IF (DDMTYPE .EQ. 0) THEN -C --- Note: the values below are for sensitivities w.r.t. initial values; -C --- they may have to be changed for other applications - DO j=1,NSENSIT - DO i=1,NVAR - P(i+NVAR*(j-1)) = 0.0D0 - END DO - END DO - ELSE -C --- Example: the call below is for sensitivities w.r.t. rate coefficients; -C --- JCOEFF(1:NSENSIT) are the indices of the NSENSIT rate coefficients -C --- w.r.t. which one differentiates - CALL dJac_dRcoeff( Y, FIX, U, NCOEFF, JCOEFF, P ) - END IF - TIME = Told - RETURN - END - - - SUBROUTINE HESS_CHEM(N, T, Y, HESS) - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - INTEGER N - KPP_REAL Told, T - KPP_REAL Y(NVAR), HESS(NHESS) - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Hessian( Y, FIX, RCONST, HESS ) - TIME = Told - RETURN - END - diff --git a/boxmox/int/oldies/ros4.def b/boxmox/int/oldies/ros4.def deleted file mode 100644 index 9eebbf809b4f6af4f79d98b5e3bb562e1e4e1647..0000000000000000000000000000000000000000 --- a/boxmox/int/oldies/ros4.def +++ /dev/null @@ -1,63 +0,0 @@ - -#FUNCTION AGGREGATE -#JACOBIAN SPARSE_LU_ROW - -#DOUBLE ON -#INTFILE ros4 - -#INLINE F_DECL_INT - INTEGER Autonomous - COMMON /INTGDATA/ Autonomous - REAL*8 STEPSTART - COMMON /GDATA/ STEPSTART -#ENDINLINE - -#INLINE F77_INIT_INT - STEPMIN=1.e-4 - STEPMAX=3600. - Autonomous = 0 - STEPSTART=STEPMIN -#ENDINLINE - -#INLINE F77_DECL_INT - INTEGER Autonomous - COMMON /INTGDATA/ Autonomous - REAL*8 STEPSTART - COMMON /GDATA/ STEPSTART -#ENDINLINE - -#INLINE F90_INIT_INT - STEPMIN=1.e-4 - STEPMAX=3600. - Autonomous = 0 - STEPSTART=STEPMIN -#ENDINLINE - -#INLINE F90_DECL_INT - INTEGER :: Autonomous - DOUBLE PRECISION :: STEPSTART -#ENDINLINE - -#INLINE C_DECL_INT - extern int Autonomous; - extern double STEPSTART; -#ENDINLINE - -#INLINE C_DATA_INT -int Autonomous; -double STEPSTART; -#ENDINLINE - -#INLINE C_INIT_INT - STEPMIN = 0.0001; - STEPMAX = 3600.0; - Autonomous = 0; - STEPSTART = STEPMIN; -#ENDINLINE - -#INLINE MATLAB_INIT_INT - STEPMIN = 0.0001; - STEPMAX = 3600.0; - Autonomous = 0; - STEPSTART = STEPMIN; -#ENDINLINE diff --git a/boxmox/int/oldies/ros4.f b/boxmox/int/oldies/ros4.f deleted file mode 100644 index a3ad21a5c53d1c277122d887d62c41a0229d96e2..0000000000000000000000000000000000000000 --- a/boxmox/int/oldies/ros4.f +++ /dev/null @@ -1,334 +0,0 @@ - SUBROUTINE INTEGRATE( TIN, TOUT ) - - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - -C TIN - Start Time - KPP_REAL TIN -C TOUT - End Time - KPP_REAL TOUT - - INTEGER INFO(5) - - EXTERNAL FUNC_CHEM, JAC_CHEM - - INFO(1) = Autonomous - - CALL ROS4(NVAR,TIN,TOUT,STEPMIN,STEPMAX, - + STEPMIN,VAR,ATOL,RTOL, - + Info,FUNC_CHEM,JAC_CHEM) - - RETURN - END - - - - - SUBROUTINE ROS4(N,T,Tnext,Hmin,Hmax,Hstart, - + y,AbsTol,RelTol, - + Info,FUNC_CHEM,JAC_CHEM) - IMPLICIT NONE - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_sparse.h' -C -C Four Stages, Fourth Order L-stable Rosenbrock Method, -C with embedded L-stable, third order method for error control -C Simplified version of E. Hairer's atmros4; the coefficients are slightly -C different -C -C -C INPUT ARGUMENTS: -C y = Vector of (NVAR) concentrations, contains the -C initial values on input -C [T, Tnext] = the integration interval -C Hmin, Hmax = lower and upper bounds for the selected step-size. -C Note that for Step = Hmin the current computed -C solution is unconditionally accepted by the error -C control mechanism. -C AbsTol, RelTol = (NVAR) dimensional vectors of -C componentwise absolute and relative tolerances. -C FUNC_CHEM = name of routine of derivatives. KPP syntax. -C See the header below. -C JAC_CHEM = name of routine that computes the Jacobian, in -C sparse format. KPP syntax. See the header below. -C Info(1) = 1 for Autonomous system -C = 0 for nonAutonomous system -C -C OUTPUT ARGUMENTS: -C y = the values of concentrations at Tend. -C T = equals TENDon output. -C Info(2) = # of FUNC_CHEM CALLs. -C Info(3) = # of JAC_CHEM CALLs. -C Info(4) = # of accepted steps. -C Info(5) = # of rejected steps. -C Hstart = The last accepted stepsize -C -C Adrian Sandu, December 2001 -C - KPP_REAL K1(NVAR), K2(NVAR), K3(NVAR), K4(NVAR) - KPP_REAL F1(NVAR) - KPP_REAL DFDT(NVAR) - KPP_REAL JAC(LU_NONZERO) - KPP_REAL Hmin,Hmax,Hstart - KPP_REAL y(NVAR), ynew(NVAR) - KPP_REAL AbsTol(NVAR), RelTol(NVAR) - KPP_REAL T, Tnext, H, Hnew, Tplus - KPP_REAL elo,ghinv,uround - KPP_REAL ERR, factor, facmax - KPP_REAL w, e, dround, tau - KPP_REAL hgam1, hgam2, hgam3, hgam4 - KPP_REAL hc21, hc31, hc32, hc41, hc42, hc43 - - INTEGER n,nfcn,njac,Naccept,Nreject,i,j,ier - INTEGER Info(5) - LOGICAL IsReject, Autonomous - EXTERNAL FUNC_CHEM, JAC_CHEM - - -C The method coefficients - DOUBLE PRECISION gamma, gamma2, gamma3, gamma4 - PARAMETER ( gamma = 0.5728200000000000D+00 ) - PARAMETER ( gamma2 = -0.1769193891319233D+01 ) - PARAMETER ( gamma3 = 0.7592633437920482D+00 ) - PARAMETER ( gamma4 = -0.1049021087100450D+00 ) - DOUBLE PRECISION a21, a31, a32, a41, a42, a43 - PARAMETER ( a21 = 0.2000000000000000D+01 ) - PARAMETER ( a31 = 0.1867943637803922D+01 ) - PARAMETER ( a32 = 0.2344449711399156D+00 ) - DOUBLE PRECISION alpha2, alpha3 - PARAMETER ( alpha2 = 0.1145640000000000D+01 ) - PARAMETER ( alpha3 = 0.6552168638155900D+00 ) - DOUBLE PRECISION c21, c31, c32, c41, c42, c43 - PARAMETER ( c21 = -0.7137615036412310D+01 ) - PARAMETER ( c31 = 0.2580708087951457D+01 ) - PARAMETER ( c32 = 0.6515950076447975D+00 ) - PARAMETER ( c41 = -0.2137148994382534D+01 ) - PARAMETER ( c42 = -0.3214669691237626D+00 ) - PARAMETER ( c43 = -0.6949742501781779D+00 ) - DOUBLE PRECISION b1, b2, b3, b4 - PARAMETER ( b1 = 0.2255570073418735D+01 ) - PARAMETER ( b2 = 0.2870493262186792D+00 ) - PARAMETER ( b3 = 0.4353179431840180D+00 ) - PARAMETER ( b4 = 0.1093502252409163D+01 ) - DOUBLE PRECISION d1, d2, d3, d4 - PARAMETER ( d1 = -0.2815431932141155D+00 ) - PARAMETER ( d2 = -0.7276199124938920D-01 ) - PARAMETER ( d3 = -0.1082196201495311D+00 ) - PARAMETER ( d4 = -0.1093502252409163D+01 ) - -c Initialization of counters, etc. - Autonomous = Info(1) .EQ. 1 - uround = 1.d-15 - dround = DSQRT(uround) - IF (Hmax.le.0.D0) THEN - Hmax = DABS(Tnext-T) - END IF - H = DMAX1(1.d-8, Hstart) - Tplus = T - IsReject = .false. - Naccept = 0 - Nreject = 0 - Nfcn = 0 - Njac = 0 - -C === Starting the time loop === - 10 CONTINUE - - Tplus = T + H - IF ( Tplus .gt. Tnext ) THEN - H = Tnext - T - Tplus = Tnext - END IF - -C Initial Function and Jacobian values - CALL FUNC_CHEM( T, y, F1 ) - CALL JAC_CHEM( T, y, JAC ) - -C The time derivative for non-Autonomous case - IF (.not. Autonomous) THEN - tau = DSIGN(dround*DMAX1( 1.0d-6, DABS(T) ), T) - CALL FUNC_CHEM( T+tau, y, K2 ) - nfcn=nfcn+1 - DO 20 j = 1,NVAR - DFDT(j) = ( K2(j)-F1(j) )/tau - 20 CONTINUE - END IF - -C Form the Prediction matrix and compute its LU factorization - Njac = Njac+1 - ghinv = 1.0d0/(gamma*H) - DO 30 j=1,LU_NONZERO - JAC(j) = -JAC(j) - 30 CONTINUE - DO 40 j=1,NVAR - JAC(LU_DIAG(j)) = JAC(LU_DIAG(j)) + ghinv - 40 CONTINUE - CALL KppDecomp (JAC, ier) -C - IF (ier.ne.0) THEN - IF ( H.gt.Hmin) THEN - H = 5.0d-1*H - GO TO 10 - ELSE - PRINT *,'ROS4: Singular factorization at T=',T,'; H=',H - STOP - END IF - END IF - - -C ------------ STAGE 1------------------------- - DO 50 j = 1,NVAR - K1(j) = F1(j) - 50 CONTINUE - IF (.NOT. Autonomous) THEN - hgam1 = H*gamma - DO 60 j=1,NVAR - K1(j) = K1(j) + hgam1*DFDT(j) - 60 CONTINUE - END IF - CALL KppSolve (JAC, K1) - -C ----------- STAGE 2 ------------------------- - DO 70 j = 1,NVAR - ynew(j) = y(j) + a21*K1(j) - 70 CONTINUE - CALL FUNC_CHEM( T+alpha2*H, ynew, F1) - nfcn=nfcn+1 - hc21 = c21/H - DO 80 j = 1,NVAR - K2(j) = F1(j) + hc21*K1(j) - 80 CONTINUE - IF (.NOT. Autonomous) THEN - hgam2 = H*gamma2 - DO 90 j=1,NVAR - K2(j) = K2(j) + hgam2*DFDT(j) - 90 CONTINUE - END IF - CALL KppSolve (JAC, K2) - - -C ------------ STAGE 3 ------------------------- - DO 100 j = 1,NVAR - ynew(j) = y(j) + a31*K1(j) + a32*K2(j) - 100 CONTINUE - CALL FUNC_CHEM( T+alpha3*H, ynew, F1) - nfcn=nfcn+1 - hc31 = c31/H - hc32 = c32/H - DO 110 j = 1,NVAR - K3(j) = F1(j) + hc31*K1(j) + hc32*K2(j) - 110 CONTINUE - IF (.NOT. Autonomous) THEN - hgam3 = H*gamma3 - DO 120 j=1,NVAR - K3(j) = K3(j) + hgam3*DFDT(j) - 120 CONTINUE - END IF - CALL KppSolve (JAC, K3) - -C ------------ STAGE 4 ------------------------- -C Note: uses the same function value as stage 3 - hc41 = c41/H - hc42 = c42/H - hc43 = c43/H - DO 140 j = 1,NVAR - K4(j) = F1(j) + hc41*K1(j) + hc42*K2(j) + hc43*K3(j) - 140 CONTINUE - IF (.NOT. Autonomous) THEN - hgam4 = H*gamma4 - DO 150 j=1,NVAR - K4(j) = K4(j) + hgam4*DFDT(j) - 150 CONTINUE - END IF - CALL KppSolve (JAC, K4) - - - -C ---- The Solution --- - DO 160 j = 1,NVAR - ynew(j) = y(j) + b1*K1(j) + b2*K2(j) + b3*K3(j) + b4*K4(j) - 160 CONTINUE - - -C ====== Error estimation ======== - - ERR=0.d0 - DO 170 j = 1,NVAR - w = AbsTol(j) + RelTol(j)*DMAX1(DABS(y(j)),DABS(ynew(j))) - e = d1*K1(j) + d2*K2(j) + d3*K3(j) + d4*K4(j) - ERR = ERR + ( e/w )**2 - 170 CONTINUE - ERR = DMAX1( uround, DSQRT( ERR/NVAR ) ) - -C ======= Choose the stepsize =============================== - - elo = 4.0D0 ! estimator local order - factor = DMAX1(2.0D-1,DMIN1(6.0D0,ERR**(1.0D0/elo)/.9D0)) - Hnew = DMIN1(Hmax,DMAX1(Hmin, H/factor)) - -C ======= Rejected/Accepted Step ============================ - - IF ( (ERR.gt.1).and.(H.gt.Hmin) ) THEN - IsReject = .true. - H = DMIN1(H/10,Hnew) - Nreject = Nreject+1 - ELSE - DO 180 i=1,NVAR - y(i) = ynew(i) - 180 CONTINUE - T = Tplus - IF (.NOT.IsReject) THEN - H = Hnew ! Do not increase stepsize if previos step was rejected - END IF - IsReject = .false. - Naccept = Naccept+1 - END IF - -C ======= End of the time loop =============================== - IF ( T .lt. Tnext ) GO TO 10 - -C ======= Output Information ================================= - Info(2) = Nfcn - Info(3) = Njac - Info(4) = Naccept - Info(5) = Nreject - Hstart = H - - RETURN - END - - - SUBROUTINE FUNC_CHEM( T, Y, P ) - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - KPP_REAL T, Told - KPP_REAL Y(NVAR), P(NVAR) - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Fun( Y, FIX, RCONST, P ) - TIME = Told - RETURN - END - - - SUBROUTINE JAC_CHEM( T, Y, J ) - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - KPP_REAL Told, T - KPP_REAL Y(NVAR), J(LU_NONZERO) - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Jac_SP( Y, FIX, RCONST, J ) - TIME = Told - RETURN - END - - - - - - diff --git a/boxmox/int/oldies/ros4_ddm.def b/boxmox/int/oldies/ros4_ddm.def deleted file mode 100644 index cac5a9ade6653d94dd8762a2399249561de71577..0000000000000000000000000000000000000000 --- a/boxmox/int/oldies/ros4_ddm.def +++ /dev/null @@ -1,58 +0,0 @@ - -#FUNCTION AGGREGATE -#JACOBIAN SPARSE_LU_ROW - -#DOUBLE ON -#INTFILE ros4_ddm -#HESSIAN ON - -#INLINE F77_DECL_INT - INTEGER Autonomous - COMMON /INTGDATA/ Autonomous - REAL*8 STEPSTART - COMMON /GDATA/ STEPSTART -#ENDINLINE - -#INLINE F77_INIT_INT - STEPMIN=1.0E-4 - STEPMAX=3600. - Autonomous = 0 - STEPSTART=STEPMIN -#ENDINLINE - -#INLINE F90_DECL_INT - INTEGER Autonomous - DOUBLE PRECISION STEPSTART -#ENDINLINE - -#INLINE F90_INIT_INT - STEPMIN=1.0E-4 - STEPMAX=3600. - Autonomous = 0 - STEPSTART=STEPMIN -#ENDINLINE - - -#INLINE C_DECL_INT - extern int Autonomous; - extern double STEPSTART; -#ENDINLINE - -#INLINE C_DATA_INT - int Autonomous; - double STEPSTART; -#ENDINLINE - -#INLINE C_INIT_INT - STEPMIN = 0.0001; - STEPMAX = 3600.0; - Autonomous = 0; - STEPSTART = STEPMIN; -#ENDINLINE - -#INLINE MATLAB_INIT_INT - STEPMIN = 0.0001; - STEPMAX = 3600.0; - Autonomous = 0; - STEPSTART = STEPMIN; -#ENDINLINE diff --git a/boxmox/int/oldies/ros4_ddm.f b/boxmox/int/oldies/ros4_ddm.f deleted file mode 100644 index 79a939c81f744d2fe235803f34797d560974525c..0000000000000000000000000000000000000000 --- a/boxmox/int/oldies/ros4_ddm.f +++ /dev/null @@ -1,615 +0,0 @@ - SUBROUTINE INTEGRATE( NSENSIT, Y, TIN, TOUT ) - - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - -C TIN - Start Time - KPP_REAL TIN -C TOUT - End Time - KPP_REAL TOUT -C Y - Concentrations and Sensitivities - KPP_REAL Y(NVAR*(NSENSIT+1)) -C --- Note: Y contains: (1:NVAR) concentrations, followed by -C --- (1:NVAR) sensitivities w.r.t. first parameter, followed by -C --- etc., followed by -C --- (1:NVAR) sensitivities w.r.t. NSENSIT's parameter - - INTEGER INFO(5) - - EXTERNAL FUNC_CHEM, JAC_CHEM - - INFO(1) = Autonomous - - CALL ROS4_DDM(NVAR,NSENSIT,TIN,TOUT,STEPMIN,STEPMAX, - + STEPMIN,Y,ATOL,RTOL, - + Info,FUNC_CHEM,JAC_CHEM) - - - RETURN - END - - - - - SUBROUTINE ROS4_DDM(N,NSENSIT,T,Tnext,Hmin,Hmax,Hstart, - + y,AbsTol,RelTol, - + Info,FUNC_CHEM,JAC_CHEM) - IMPLICIT NONE - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - INCLUDE 'KPP_ROOT_sparse.h' -C -C Four Stages, Fourth Order L-stable Rosenbrock Method, -C with embedded L-stable, third order method for error control -C Simplified version of E. Hairer's atmros4; the coefficients are slightly different -C -C Direct decoupled computation of sensitivities. -C The global variable DDMTYPE distinguishes between: -C DDMTYPE = 0 : sensitivities w.r.t. initial values -C DDMTYPE = 1 : sensitivities w.r.t. parameters -C -C INPUT ARGUMENTS: -C y = Vector of: (1:NVAR) concentrations, followed by -C (1:NVAR) sensitivities w.r.t. first parameter, followed by -C etc., followed by -C (1:NVAR) sensitivities w.r.t. NSENSIT's parameter -C (y contains initial values at input, final values at output) -C [T, Tnext] = the integration interval -C Hmin, Hmax = lower and upper bounds for the selected step-size. -C Note that for Step = Hmin the current computed -C solution is unconditionally accepted by the error -C control mechanism. -C AbsTol, RelTol = (NVAR) dimensional vectors of -C componentwise absolute and relative tolerances. -C FUNC_CHEM = name of routine of derivatives. KPP syntax. -C See the header below. -C JAC_CHEM = name of routine that computes the Jacobian, in -C sparse format. KPP syntax. See the header below. -C Info(1) = 1 for Autonomous system -C = 0 for nonAutonomous system -C -C OUTPUT ARGUMENTS: -C y = the values of concentrations and sensitivities at Tend. -C T = equals TENDon output. -C Info(2) = # of FUNC_CHEM CALLs. -C Info(3) = # of JAC_CHEM CALLs. -C Info(4) = # of accepted steps. -C Info(5) = # of rejected steps. -C -C Adrian Sandu, December 2001 -C - - - INTEGER NSENSIT - KPP_REAL y(NVAR*(NSENSIT+1)), ynew(NVAR*(NSENSIT+1)) - KPP_REAL K1(NVAR*(NSENSIT+1)) - KPP_REAL K2(NVAR*(NSENSIT+1)) - KPP_REAL K3(NVAR*(NSENSIT+1)) - KPP_REAL K4(NVAR*(NSENSIT+1)) - KPP_REAL Fv(NVAR), Hv(NVAR) - KPP_REAL DFDT(NVAR*(NSENSIT+1)) - KPP_REAL DFDP(NVAR*NSENSIT), DFDPDT(NVAR*NSENSIT) - KPP_REAL DJDP(NVAR*NSENSIT) - KPP_REAL JAC(LU_NONZERO), AJAC(LU_NONZERO) - KPP_REAL DJDT(LU_NONZERO) - KPP_REAL HESS(NHESS) - KPP_REAL Hmin,Hmax,Hstart,ghinv,uround - KPP_REAL AbsTol(NVAR), RelTol(NVAR) - KPP_REAL T, Tnext, Tplus, H, Hnew, elo - KPP_REAL ERR, factor, facmax, dround, tau - KPP_REAL w, e, beta1, beta2, beta3, beta4 - - INTEGER n,nfcn,njac,Naccept,Nreject,i,j,ier - INTEGER Info(5) - LOGICAL IsReject, Autonomous - EXTERNAL FUNC_CHEM, JAC_CHEM, HESS_CHEM - - -C The method coefficients -C DOUBLE PRECISION gamma, gamma2, gamma3, gamma4 -C PARAMETER ( gamma = 0.57281606D0 ) -C PARAMETER ( gamma2 = -1.769177067112013949170520D0 ) -C PARAMETER ( gamma3 = 0.759293964293209853670967D0 ) -C PARAMETER ( gamma4 = -0.104894621490955803206743D0 ) -C DOUBLE PRECISION a21, a31, a32, a41, a42, a43 -C PARAMETER ( a21 = 2.00000000000000000000000D0 ) -C PARAMETER ( a31 = 1.86794814949823713234476D0 ) -C PARAMETER ( a32 = 0.23444556851723885002322D0 ) -C DOUBLE PRECISION alpha2, alpha3, alpha4 -C PARAMETER ( alpha2 = 1.145632120D0 ) -C PARAMETER ( alpha3 = 0.655214975973133829477748D0 ) -C DOUBLE PRECISION c21, c31, c32, c41, c42, c43 -C PARAMETER ( c21 = -7.137649943349979830369260D0 ) -C PARAMETER ( c31 = 2.580923666509657714488050D0 ) -C PARAMETER ( c32 = 0.651629887302032023387417D0 ) -C PARAMETER ( c41 = -2.137115266506619116806370D0 ) -C PARAMETER ( c42 = -0.321469531339951070769241D0 ) -C PARAMETER ( c43 = -0.694966049282445225157329D0 ) -C DOUBLE PRECISION m1, m2, m3, m4, mhat1, mhat2, mhat3, mhat4 -C PARAMETER ( m1 = 2.255566228604565243728840D0 ) -C PARAMETER ( m2 = 0.287055063194157607662630D0 ) -C PARAMETER ( m3 = 0.435311963379983213402707D0 ) -C PARAMETER ( m4 = 1.093507656403247803214820D0 ) -C PARAMETER ( mhat1 = 2.068399160527583734258670D0 ) -C PARAMETER ( mhat2 = 0.238681352067532797956493D0 ) -C PARAMETER ( mhat3 = 0.363373345435391708261747D0 ) -C PARAMETER ( mhat4 = 0.366557127936155144309163D0 ) -C DOUBLE PRECISION e1, e2, e3, e4 -c PARAMETER ( e1 = 1.8716706807698191283861888D-01 ) -c PARAMETER ( e2 = 4.8373711126624835410225955D-02 ) -c PARAMETER ( e3 = 7.1938617944591554120847832D-02 ) -c PARAMETER ( e4 = 7.2695052846709262706070831D-01 ) -C PARAMETER ( e1 = -0.2815431932141155D+00 ) -C PARAMETER ( e2 = -0.7276199124938920D-01 ) -C PARAMETER ( e3 = -0.1082196201495311D+00 ) -C PARAMETER ( e4 = -0.1093502252409163D+01 ) -C The method coefficients - DOUBLE PRECISION gamma, gamma2, gamma3, gamma4 - PARAMETER ( gamma = 0.5728200000000000D+00 ) - PARAMETER ( gamma2 = -0.1769193891319233D+01 ) - PARAMETER ( gamma3 = 0.7592633437920482D+00 ) - PARAMETER ( gamma4 = -0.1049021087100450D+00 ) - DOUBLE PRECISION a21, a31, a32, a41, a42, a43 - PARAMETER ( a21 = 0.2000000000000000D+01 ) - PARAMETER ( a31 = 0.1867943637803922D+01 ) - PARAMETER ( a32 = 0.2344449711399156D+00 ) - DOUBLE PRECISION alpha2, alpha3 - PARAMETER ( alpha2 = 0.1145640000000000D+01 ) - PARAMETER ( alpha3 = 0.6552168638155900D+00 ) - DOUBLE PRECISION c21, c31, c32, c41, c42, c43 - PARAMETER ( c21 = -0.7137615036412310D+01 ) - PARAMETER ( c31 = 0.2580708087951457D+01 ) - PARAMETER ( c32 = 0.6515950076447975D+00 ) - PARAMETER ( c41 = -0.2137148994382534D+01 ) - PARAMETER ( c42 = -0.3214669691237626D+00 ) - PARAMETER ( c43 = -0.6949742501781779D+00 ) - DOUBLE PRECISION b1, b2, b3, b4 - PARAMETER ( b1 = 0.2255570073418735D+01 ) - PARAMETER ( b2 = 0.2870493262186792D+00 ) - PARAMETER ( b3 = 0.4353179431840180D+00 ) - PARAMETER ( b4 = 0.1093502252409163D+01 ) - DOUBLE PRECISION d1, d2, d3, d4 - PARAMETER ( d1 = -0.2815431932141155D+00 ) - PARAMETER ( d2 = -0.7276199124938920D-01 ) - PARAMETER ( d3 = -0.1082196201495311D+00 ) - PARAMETER ( d4 = -0.1093502252409163D+01 ) - - -c Initialization of counters, etc. - Autonomous = Info(1) .EQ. 1 - uround = 1.d-15 - dround = DSQRT(uround) - IF (Hmax.le.0.D0) THEN - Hmax = DABS(Tnext-T) - END IF - H = DMAX1(1.d-8, Hstart) - Tplus = T - IsReject = .false. - Naccept = 0 - Nreject = 0 - Nfcn = 0 - Njac = 0 - -C === Starting the time loop === - 10 CONTINUE - - Tplus = T + H - IF ( Tplus .gt. Tnext ) THEN - H = Tnext - T - Tplus = Tnext - END IF - -C Initial Function, Jacobian, and Hessian Values - CALL FUNC_CHEM(NVAR, T, y, Fv) - CALL JAC_CHEM(NVAR, T, y, JAC) - CALL HESS_CHEM( NVAR, T, y, HESS ) - IF (DDMTYPE .EQ. 1) THEN - CALL DFUNDPAR(NVAR, NSENSIT, T, y, DFDP) - END IF - -C The time derivatives for non-Autonomous case - IF (.not. Autonomous) THEN - tau = DSIGN(dround*DMAX1( 1.0d0, DABS(T) ), T) - CALL FUNC_CHEM(NVAR, T+tau, y, K2) - CALL JAC_CHEM(NVAR, T+tau, y, AJAC) - nfcn=nfcn+1 - DO 20 j = 1,NVAR - DFDT(j) = ( K2(j)-Fv(j) )/tau - 20 CONTINUE - DO 30 j = 1,LU_NONZERO - DJDT(j) = ( AJAC(j)-JAC(j) )/tau - 30 CONTINUE - DO 35 i=1,NSENSIT - CALL Jac_SP_Vec (DJDT,y(i*NVAR+1),DFDT(i*NVAR+1)) - 35 CONTINUE - END IF - - 11 CONTINUE ! From here we restart after a rejected step - -C Form the Prediction matrix and compute its LU factorization - Njac = Njac+1 - ghinv = 1.0d0/(gamma*H) - DO 40 j=1,LU_NONZERO - AJAC(j) = -JAC(j) - 40 CONTINUE - DO 50 j=1,NVAR - AJAC(LU_DIAG(j)) = AJAC(LU_DIAG(j)) + ghinv - 50 CONTINUE - CALL KppDecomp (AJAC, ier) -C - IF (ier.ne.0) THEN - IF ( H.gt.Hmin) THEN - H = 5.0d-1*H - GO TO 10 - ELSE - PRINT *,'ROS4: Singular factorization at T=',T,'; H=',H - STOP - END IF - END IF - -C ------------ STAGE 1------------------------- - DO 60 j = 1,NVAR - K1(j) = Fv(j) - 60 CONTINUE - IF (.NOT. Autonomous) THEN - beta1 = H*gamma - DO 70 j=1,NVAR - K1(j) = K1(j) + beta1*DFDT(j) - 70 CONTINUE - END IF - CALL KppSolve (AJAC, K1) -C --- If derivative w.r.t. parameters - IF (DDMTYPE .EQ. 1) THEN - CALL DJACDPAR(NVAR, NSENSIT, T, y, K1(1), DJDP) - END IF -C --- End of derivative w.r.t. parameters - - DO 100 i=1,NSENSIT - CALL Jac_SP_Vec (JAC,y(i*NVAR+1),K1(i*NVAR+1)) - CALL Hess_Vec ( HESS, y(i*NVAR+1), K1(1), Hv ) - DO 80 j=1,NVAR - K1(i*NVAR+j) = K1(i*NVAR+j) + Hv(j) - 80 CONTINUE - IF (.NOT. Autonomous) THEN - DO 90 j=1,NVAR - K1(i*NVAR+j) = K1(i*NVAR+j) + beta1*DFDT(i*NVAR+j) - 90 CONTINUE - END IF -C --- If derivative w.r.t. parameters - IF (DDMTYPE .EQ. 1) THEN - DO 95 j = 1,NVAR - K1(i*NVAR+j) = K1(i*NVAR+j) + DFDP((i-1)*NVAR+j) - & + DJDP((i-1)*NVAR+j) - 95 CONTINUE - END IF -C --- End of derivative w.r.t. parameters - CALL KppSolve (AJAC, K1(i*NVAR+1)) - 100 CONTINUE - -C ----------- STAGE 2 ------------------------- - DO 110 j = 1,NVAR*(NSENSIT+1) - ynew(j) = y(j) + a21*K1(j) - 110 CONTINUE - CALL FUNC_CHEM(NVAR, T+alpha2*H, ynew, Fv) - IF (DDMTYPE .EQ. 1) THEN - CALL DFUNDPAR(NVAR, NSENSIT, T+alpha2*H, ynew, DFDP) - END IF - nfcn=nfcn+1 - beta1 = c21/H - DO 120 j = 1,NVAR - K2(j) = Fv(j) + beta1*K1(j) - 120 CONTINUE - IF (.NOT. Autonomous) THEN - beta2 = H*gamma2 - DO 130 j=1,NVAR - K2(j) = K2(j) + beta2*DFDT(j) - 130 CONTINUE - END IF - CALL KppSolve (AJAC, K2) -C --- If derivative w.r.t. parameters - IF (DDMTYPE .EQ. 1) THEN - CALL DJACDPAR(NVAR, NSENSIT, T, y, K2(1), DJDP) - END IF -C --- End of derivative w.r.t. parameters - - CALL JAC_CHEM(NVAR, T+alpha2*H, ynew, JAC) - njac=njac+1 - DO 160 i=1,NSENSIT - CALL Jac_SP_Vec (JAC,ynew(i*NVAR+1),K2(i*NVAR+1)) - CALL Hess_Vec ( HESS, y(i*NVAR+1), K2(1), Hv ) - DO 140 j = 1,NVAR - K2(i*NVAR+j) = K2(i*NVAR+j) + beta1*K1(i*NVAR+j) - & + Hv(j) - 140 CONTINUE - IF (.NOT. Autonomous) THEN - DO 150 j=1,NVAR - K2(i*NVAR+j) = K2(i*NVAR+j) + beta2*DFDT(i*NVAR+j) - 150 CONTINUE - END IF -C --- If derivative w.r.t. parameters - IF (DDMTYPE .EQ. 1) THEN - DO 155 j = 1,NVAR - K2(i*NVAR+j) = K2(i*NVAR+j) + DFDP((i-1)*NVAR+j) - & + DJDP((i-1)*NVAR+j) - 155 CONTINUE - END IF -C --- End of derivative w.r.t. parameters - CALL KppSolve (AJAC, K2(i*NVAR+1)) - 160 CONTINUE - - -C ------------ STAGE 3 ------------------------- - DO 170 j = 1,NVAR*(NSENSIT+1) - ynew(j) = y(j) + a31*K1(j) + a32*K2(j) - 170 CONTINUE - CALL FUNC_CHEM(NVAR, T+alpha3*H, ynew, Fv) - IF (DDMTYPE .EQ. 1) THEN - CALL DFUNDPAR(NVAR, NSENSIT, T+alpha3*H, ynew, DFDP) - END IF - nfcn=nfcn+1 - beta1 = c31/H - beta2 = c32/H - DO 180 j = 1,NVAR - K3(j) = Fv(j) + beta1*K1(j) + beta2*K2(j) - 180 CONTINUE - IF (.NOT. Autonomous) THEN - beta3 = H*gamma3 - DO 190 j=1,NVAR - K3(j) = K3(j) + beta3*DFDT(j) - 190 CONTINUE - END IF - CALL KppSolve (AJAC, K3) -C --- If derivative w.r.t. parameters - IF (DDMTYPE .EQ. 1) THEN - CALL DJACDPAR(NVAR, NSENSIT, T, y, K3(1), DJDP) - END IF -C --- End of derivative w.r.t. parameters - - CALL JAC_CHEM(NVAR, T+alpha3*H, ynew, JAC) - njac=njac+1 - DO 220 i=1,NSENSIT - CALL Jac_SP_Vec (JAC,ynew(i*NVAR+1),K3(i*NVAR+1)) - CALL Hess_Vec ( HESS, y(i*NVAR+1), K3(1), Hv ) - DO 200 j = 1,NVAR - K3(i*NVAR+j) = K3(i*NVAR+j) + beta1*K1(i*NVAR+j) - & + beta2*K2(i*NVAR+j) + Hv(j) - 200 CONTINUE - IF (.NOT. Autonomous) THEN - DO 210 j=1,NVAR - K3(i*NVAR+j) = K3(i*NVAR+j) + beta3*DFDT(i*NVAR+j) - 210 CONTINUE - END IF -C --- If derivative w.r.t. parameters - IF (DDMTYPE .EQ. 1) THEN - DO 215 j = 1,NVAR - K3(i*NVAR+j) = K3(i*NVAR+j) + DFDP((i-1)*NVAR+j) - & + DJDP((i-1)*NVAR+j) - 215 CONTINUE - END IF -C --- End of derivative w.r.t. parameters - CALL KppSolve (AJAC, K3(i*NVAR+1)) - 220 CONTINUE - -C ------------ STAGE 4 ------------------------- -C Note: uses the same function values as stage 3 - beta1 = c41/H - beta2 = c42/H - beta3 = c43/H - DO 230 j = 1,NVAR - K4(j) = Fv(j) + beta1*K1(j) + beta2*K2(j) + beta3*K3(j) - 230 CONTINUE - IF (.NOT. Autonomous) THEN - beta4 = H*gamma4 - DO 240 j=1,NVAR - K4(j) = K4(j) + beta4*DFDT(j) - 240 CONTINUE - END IF - CALL KppSolve (AJAC, K4) -C --- If derivative w.r.t. parameters - IF (DDMTYPE .EQ. 1) THEN - CALL DJACDPAR(NVAR, NSENSIT, T, y, K4(1), DJDP) - END IF -C --- End of derivative w.r.t. parameters - - njac=njac+1 - DO 270 i=1,NSENSIT - CALL Jac_SP_Vec (JAC,ynew(i*NVAR+1),K4(i*NVAR+1)) - CALL Hess_Vec ( HESS, y(i*NVAR+1), K4(1), Hv ) - DO 250 j = 1,NVAR - K4(i*NVAR+j) = K4(i*NVAR+j) + beta1*K1(i*NVAR+j) - & + beta2*K2(i*NVAR+j) + beta3*K3(i*NVAR+j) - & + Hv(j) - 250 CONTINUE - IF (.NOT. Autonomous) THEN - DO 260 j=1,NVAR - K4(i*NVAR+j) = K4(i*NVAR+j) + beta4*DFDT(i*NVAR+j) - 260 CONTINUE - END IF -C --- If derivative w.r.t. parameters - IF (DDMTYPE .EQ. 1) THEN - DO 265 j = 1,NVAR - K4(i*NVAR+j) = K4(i*NVAR+j) + DFDP((i-1)*NVAR+j) - & + DJDP((i-1)*NVAR+j) - 265 CONTINUE - END IF - CALL KppSolve (AJAC, K4(i*NVAR+1)) - 270 CONTINUE - - -C ---- The Solution --- - DO 280 j = 1,NVAR*(NSENSIT+1) - ynew(j) = y(j) + b1*K1(j) + b2*K2(j) + b3*K3(j) + b4*K4(j) - 280 CONTINUE - - -C ====== Error estimation -- can be extended to control sensitivities too ======== - - ERR = 0.d0 - DO 290 i=1,NVAR - w = AbsTol(i) + RelTol(i)*DMAX1(DABS(ynew(i)),DABS(y(i))) - e = d1*K1(i) + d2*K2(i) + d3*K3(i) + d4*K4(i) - ERR = ERR + ( e/w )**2 - 290 CONTINUE - ERR = DMAX1( uround, DSQRT( ERR/NVAR ) ) - -C ======= Choose the stepsize =============================== - - elo = 4.0D0 ! estimator local order - factor = DMAX1(2.0D-1,DMIN1(6.0D0,ERR**(1.0D0/elo)/.9D0)) - Hnew = DMIN1(Hmax,DMAX1(Hmin, H/factor)) - -C ======= Rejected/Accepted Step ============================ - - IF ( (ERR.gt.1).and.(H.gt.Hmin) ) THEN - IsReject = .true. - H = DMIN1(H/10,Hnew) - Nreject = Nreject+1 - ELSE - DO 300 i=1,NVAR*(NSENSIT+1) - y(i) = ynew(i) - 300 CONTINUE - T = Tplus - IF (.NOT.IsReject) THEN - H = Hnew ! Do not increase stepsize if previos step was rejected - END IF - IsReject = .false. - Naccept = Naccept+1 - END IF - -C ======= End of the time loop =============================== - IF ( T .lt. Tnext ) GO TO 10 - - - -C ======= Output Information ================================= - Info(2) = Nfcn - Info(3) = Njac - Info(4) = Naccept - Info(5) = Nreject - Hstart = H - - RETURN - END - - - - SUBROUTINE FUNC_CHEM(N, T, Y, P) - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - KPP_REAL T, Told - KPP_REAL Y(NVAR), P(NVAR) - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Fun( Y, FIX, RCONST, P ) - TIME = Told - RETURN - END - - - SUBROUTINE DFUNDPAR(N, NSENSIT, T, Y, P) -C --- Computes the partial derivatives of FUNC_CHEM w.r.t. parameters - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' -C --- NCOEFF, JCOEFF useful for derivatives w.r.t. rate coefficients - INTEGER NCOEFF, JCOEFF(NREACT) - COMMON /DDMRCOEFF/ NCOEFF, JCOEFF - - KPP_REAL T, Told - KPP_REAL Y(NVAR), P(NVAR*NSENSIT) - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() -C - IF (DDMTYPE .EQ. 0) THEN -C --- Note: the values below are for sensitivities w.r.t. initial values; -C --- they may have to be changed for other applications - DO j=1,NSENSIT - DO i=1,NVAR - P(i+NVAR*(j-1)) = 0.0D0 - END DO - END DO - ELSE -C --- Example: the call below is for sensitivities w.r.t. rate coefficients; -C --- JCOEFF(1:NSENSIT) are the indices of the NSENSIT rate coefficients -C --- w.r.t. which one differentiates - CALL dFun_dRcoeff( Y, FIX, NCOEFF, JCOEFF, P ) - END IF - TIME = Told - RETURN - END - - SUBROUTINE JAC_CHEM(N, T, Y, J) - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - INTEGER N - KPP_REAL Told, T - KPP_REAL Y(NVAR), J(LU_NONZERO) - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Jac_SP( Y, FIX, RCONST, J ) - TIME = Told - RETURN - END - - - SUBROUTINE DJACDPAR(N, NSENSIT, T, Y, U, P) -C --- Computes the partial derivatives of JAC w.r.t. parameters times user vector U - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' -C --- NCOEFF, JCOEFF useful for derivatives w.r.t. rate coefficients - INTEGER N - INTEGER NCOEFF, JCOEFF(NREACT) - COMMON /DDMRCOEFF/ NCOEFF, JCOEFF - - KPP_REAL T, Told - KPP_REAL Y(NVAR), U(NVAR) - KPP_REAL P(NVAR*NSENSIT) - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() -C - IF (DDMTYPE .EQ. 0) THEN -C --- Note: the values below are for sensitivities w.r.t. initial values; -C --- they may have to be changed for other applications - DO j=1,NSENSIT - DO i=1,NVAR - P(i+NVAR*(j-1)) = 0.0D0 - END DO - END DO - ELSE -C --- Example: the call below is for sensitivities w.r.t. rate coefficients; -C --- JCOEFF(1:NSENSIT) are the indices of the NSENSIT rate coefficients -C --- w.r.t. which one differentiates - CALL dJac_dRcoeff( Y, FIX, U, NCOEFF, JCOEFF, P ) - END IF - TIME = Told - RETURN - END - - - SUBROUTINE HESS_CHEM(N, T, Y, HESS) - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - INTEGER N - KPP_REAL Told, T - KPP_REAL Y(NVAR), HESS(NHESS) - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Hessian( Y, FIX, RCONST, HESS ) - TIME = Told - RETURN - END - - - - - - diff --git a/boxmox/int/oldies/twostepj.def b/boxmox/int/oldies/twostepj.def deleted file mode 100644 index 2e635625095adee785bd0f03e7a2407586455aa2..0000000000000000000000000000000000000000 --- a/boxmox/int/oldies/twostepj.def +++ /dev/null @@ -1,16 +0,0 @@ - -#FUNCTION SPLIT -#JACOBIAN OFF -#SPARSEDATA OFF -#DOUBLE ON -#INTFILE twostepj - -#INLINE F_INIT_INT - STEPMIN=0.0001 - STEPMAX=60. -#ENDINLINE - -#INLINE C_INIT_INT - STEPMIN=0.0001; - STEPMAX=60.; -#ENDINLINE diff --git a/boxmox/int/oldies/twostepj.f b/boxmox/int/oldies/twostepj.f deleted file mode 100644 index cb8dfe6ceeabffb81595b815cf2e98c2932d4933..0000000000000000000000000000000000000000 --- a/boxmox/int/oldies/twostepj.f +++ /dev/null @@ -1,244 +0,0 @@ - SUBROUTINE INTEGRATE( TIN, TOUT ) - - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - -C TIN - Start Time - KPP_REAL TIN -C TOUT - End Time - KPP_REAL TOUT - EXTERNAL ITER - KPP_REAL T - KPP_REAL V(NVAR), VOLD(NVAR), VNEW(NVAR) - KPP_REAL startdt, hmin, hmax, h - - INTEGER INFO(5) - - INFO(1) = Autonomous - h = hmin - -c Number of Jacobi-Seidel iterations - numit = 3 - - - DO i=1,NVAR - RTOL(i) = 1.e-2 - ENDDO - - CALL twostepj(NVAR,TIN,TOUT,h,hmin,hmax, - + VOLD,VAR,VNEW, - + ATOL,RTOL,numit, - + nfcn,naccpt,nrejec,nstart,startdt,ITER) - - - RETURN - END - - - - SUBROUTINE ITER(n,T,y,yp,yl) - INCLUDE 'KPP_ROOT_params.h' - INCLUDE 'KPP_ROOT_global.h' - REAL*8 T, y(NVAR), yp(NVAR), yl(NVAR) - TOLD = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL FunSPLIT_VAR(y,Rad,yp,yl) - TIME = TOLD - RETURN - END - - - subroutine twostepj(n,t,te,dt,dtmin,dtmax, - + yold,y,ynew, - + atol,rtol,numit, - + nfcn,naccpt,nrejec,nstart,startdt,ITER) - implicit real*8 (a-h,o-z) - external ITER - integer n,numit,nfcn,naccpt,nrejec,nstart,i,j - real*8 t,te,dt,dtmin,dtmax,startdt,ytol, - + ratio,dtold,a1,a2,c,cp1,dtg,errlte,dy - real*8 yold(n),y(n),ynew(n),yp(n),yl(n), - + work(n),sum(n),atol(n),rtol(n) - logical accept,failer,restart - -c -c Initialization of counters, etc. - - naccpt=0 - nrejec=0 - nfcn=0 - nstart=0 - failer=.false. - restart=.false. - accept=.true. - -c Initial stepsize computation. - - 10 if (dtmin.eq.dtmax) then - nstart=1 - dt=min(dtmin,(te-t)/2) - goto 28 - endif - CALL ITER(n,t,y,yp,yl) - nfcn=nfcn+1 - dt=te-t - do 20 i=1,n - ytol=atol(i)+rtol(i)*abs(y(i)) - dy=yp(i)-y(i)*yl(i) - if (dy.ne.0.0) dt=min(dt,ytol/abs(dy)) - 20 continue - 25 nstart=nstart+1 - if (restart) dt=dt/10.0 - restart=.true. - dt=max(dtmin,min(dt,dtmax)) - CALL FIT(t,te,dt) - dt=min(dt,(te-t)/2) - startdt=dt - -c The starting step is carried out, using the implicit Euler method. - - 28 do 30 i=1,n - ynew(i)=y(i) - yold(i)=y(i) - sum(i)=y(i) - 30 continue - do 40 i=1,numit - CALL ITER(n,t+dt,ynew,yp,yl) - do i2i=1,n - ynew(i2i) = (sum(i2i) + dt*yp(i2i))/(1.+dt*yl(i2i)) - end do - nfcn=nfcn+1 - 40 continue - naccpt=naccpt+1 - t=t+dt - do 50 j=1,n - y(j)=ynew(j) - 50 continue - -c Subsequent steps are carried out with the two-step BDF method. - - dtold=dt - ratio=1.0 - 60 continue - c=1.0/ratio - cp1=c+1.0 - a1=((c+1.0)**2)/(c*c+2.0*c) - a2=-1.0/(c*c+2.0*c) - dtg=dt*(1.0+c)/(2.0+c) - do 70 j=1,n - sum(j)=a1*y(j)+a2*yold(j) - ynew(j)=max(0.0,y(j)+ratio*(y(j)-yold(j))) - 70 continue - do 80 i=1,numit - CALL ITER(n,t+dt,ynew,yp,yl) - do i2i=1,n - ynew(i2i) = (sum(i2i) + dtg*yp(i2i))/(1.+dtg*yl(i2i)) - end do - nfcn=nfcn+1 - 80 continue - -c If stepsizes should remain equal, stepsize control is omitted. - - if (dtmin.eq.dtmax) then - t=t+dtold - naccpt=naccpt+1 - do 85 j=1,n - yold(j)=y(j) - y(j)=ynew(j) - 85 continue - if (dt.ne.dtold) then - t=t-dtold+dt - goto 120 - endif - dt=min(dtold,te-t) - ratio=dt/dtold - if (t.ge.te) goto 120 - goto 60 - endif - -c Otherwise stepsize control is carried out. - - errlte=0.0 - do 90 i=1,n - ytol=atol(i)+rtol(i)*abs(y(i)) - errlte=max(errlte,abs(c*ynew(i)-cp1*y(i)+yold(i))/ytol) - 90 continue - errlte=2.0*errlte/(c+c*c) - CALL NEWDT(t,te,dt,dtold,ratio,errlte,accept, - + dtmin,dtmax) - -c Here the step has been accepted. - - if (accept) then - 201 format(2(E24.16,1X)) - failer=.false. - restart=.false. - t=t+dtold - naccpt=naccpt+1 - do 100 j=1,n - yold(j)=y(j) - y(j)=ynew(j) - 100 continue - if (t.ge.te) goto 120 - goto 60 - endif - -c A restart check is carried out. - - if (failer) then - nrejec=nrejec+1 - failer=.false. - naccpt=naccpt-1 - t=t-dtold - do 110 j=1,n - y(j)=yold(j) - 110 continue - goto 25 - endif - -c Here the step has been rejected. - - nrejec=nrejec+1 - failer=.true. - goto 60 - -c End of TWOSTEP. - 120 end -c===================================================================== - - subroutine NEWDT(t,te,dt,dtold,ratio,errlte, - + accept,dtmin,dtmax) - real*8 t,te,dt,dtold,ratio,errlte,ts,dtmin,dtmax - logical accept - if (errlte.gt.1.0.and.dt.gt.dtmin) then - accept=.false. - ts=t - else - accept=.true. - dtold=dt - ts=t+dtold - endif - dt=max(0.5,min(2.0,0.8/sqrt(errlte)))*dt - dt=max(dtmin,min(dt,dtmax)) - CALL FIT(ts,te,dt) - ratio=dt/dtold - end - - subroutine FIT(t,te,dt) - real*8 t,te,dt,rns - integer ns - rns=(te-t)/dt - if (rns.gt.10.0) goto 10 - ns=int(rns)+1 - dt=(te-t)/ns - dt=(dt+t)-t - 10 return - end - - - -C End of MAIN function -C **************************************************************** - diff --git a/boxmox/int/readme b/boxmox/int/readme deleted file mode 100644 index 93d30ab72154c5b57123c3163f80f8091880f6dd..0000000000000000000000000000000000000000 --- a/boxmox/int/readme +++ /dev/null @@ -1,21 +0,0 @@ -The integrator naming conventions: - -*.def = definition file -*.f = Fortran 77 source code -*.f90 = Fortran 90 source code -*.c = C source code - -atm_* = off-the-shelf integrators, adapted to work with KPP - use the native full linear algebra - useful for providing reference solutions - -kpp_* = off-the-shelf integrators, using the KPP sparse linear algebra - very efficient, useful for production runs - -plain names = original integrators - either use the KPP sparse linear algebra, or provide - explicit solutions - -*_ddm = direct decoupled method - integrate for both the concentrations and their sensitivities - implements the forward and the tangent linear models together diff --git a/boxmox/int/rosenbrock.c b/boxmox/int/rosenbrock.c deleted file mode 100644 index 27eb893039d8efaba12f8b1a8682021f51aa1202..0000000000000000000000000000000000000000 --- a/boxmox/int/rosenbrock.c +++ /dev/null @@ -1,1216 +0,0 @@ - - #define MAX(a,b) ( ((a) >= (b)) ?(a):(b) ) - #define MIN(b,c) ( ((b) < (c)) ?(b):(c) ) - #define ABS(x) ( ((x) >= 0 ) ?(x):(-x) ) - #define SQRT(d) ( pow((d),0.5) ) - #define SIGN(x) ( ((x) >= 0 ) ?[0]:(-1) ) - -/*~~> Numerical constants */ - #define ZERO (KPP_REAL)0.0 - #define ONE (KPP_REAL)1.0 - #define HALF (KPP_REAL)0.5 - #define DeltaMin (KPP_REAL)1.0e-6 - -/*~~~> Collect statistics: global variables */ - int Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng; - - -/*~~~> Function headers */ - void FunTemplate(KPP_REAL, KPP_REAL [], KPP_REAL []); - void JacTemplate(KPP_REAL, KPP_REAL [], KPP_REAL []) ; - int Rosenbrock(KPP_REAL Y[], KPP_REAL Tstart, KPP_REAL Tend, - KPP_REAL AbsTol[], KPP_REAL RelTol[], - void (*ode_Fun)(KPP_REAL, KPP_REAL [], KPP_REAL []), - void (*ode_Jac)(KPP_REAL, KPP_REAL [], KPP_REAL []), - KPP_REAL RPAR[], int IPAR[]); - int RosenbrockIntegrator( - KPP_REAL Y[], KPP_REAL Tstart, KPP_REAL Tend , - KPP_REAL AbsTol[], KPP_REAL RelTol[], - void (*ode_Fun)(KPP_REAL, KPP_REAL [], KPP_REAL []), - void (*ode_Jac)(KPP_REAL, KPP_REAL [], KPP_REAL []), - int ros_S, - KPP_REAL ros_M[], KPP_REAL ros_E[], - KPP_REAL ros_A[], KPP_REAL ros_C[], - KPP_REAL ros_Alpha[],KPP_REAL ros_Gamma[], - KPP_REAL ros_ELO, char ros_NewF[], - char Autonomous, char VectorTol, int Max_no_steps, - KPP_REAL Roundoff, KPP_REAL Hmin, KPP_REAL Hmax, KPP_REAL Hstart, - KPP_REAL FacMin, KPP_REAL FacMax, KPP_REAL FacRej, KPP_REAL FacSafe, - KPP_REAL *Texit, KPP_REAL *Hexit ); - char ros_PrepareMatrix ( - KPP_REAL* H, - int Direction, KPP_REAL gam, KPP_REAL Jac0[], - KPP_REAL Ghimj[], int Pivot[] ); - KPP_REAL ros_ErrorNorm ( - KPP_REAL Y[], KPP_REAL Ynew[], KPP_REAL Yerr[], - KPP_REAL AbsTol[], KPP_REAL RelTol[], - char VectorTol ); - int ros_ErrorMsg(int Code, KPP_REAL T, KPP_REAL H); - void ros_FunTimeDerivative ( - KPP_REAL T, KPP_REAL Roundoff, - KPP_REAL Y[], KPP_REAL Fcn0[], - void ode_Fun(KPP_REAL, KPP_REAL [], KPP_REAL []), - KPP_REAL dFdT[] ); - void Fun( KPP_REAL Y[], KPP_REAL FIX[], KPP_REAL RCONST[], KPP_REAL Ydot[] ); - void Jac_SP( KPP_REAL Y[], KPP_REAL FIX[], KPP_REAL RCONST[], KPP_REAL Ydot[] ); - void FunTemplate( KPP_REAL T, KPP_REAL Y[], KPP_REAL Ydot[] ); - void JacTemplate( KPP_REAL T, KPP_REAL Y[], KPP_REAL Ydot[] ); - void DecompTemplate( KPP_REAL A[], int Pivot[], int* ising ); - void SolveTemplate( KPP_REAL A[], int Pivot[], KPP_REAL b[] ); - void WCOPY(int N, KPP_REAL X[], int incX, KPP_REAL Y[], int incY); - void WAXPY(int N, KPP_REAL Alpha, KPP_REAL X[], int incX, KPP_REAL Y[], int incY ); - void WSCAL(int N, KPP_REAL Alpha, KPP_REAL X[], int incX); - KPP_REAL WLAMCH( char C ); - void Ros2 ( int *ros_S, KPP_REAL ros_A[], KPP_REAL ros_C[], - KPP_REAL ros_M[], KPP_REAL ros_E[], - KPP_REAL ros_Alpha[], KPP_REAL ros_Gamma[], - char ros_NewF[], KPP_REAL *ros_ELO, char* ros_Name ); - void Ros3 ( int *ros_S, KPP_REAL ros_A[], KPP_REAL ros_C[], - KPP_REAL ros_M[], KPP_REAL ros_E[], - KPP_REAL ros_Alpha[], KPP_REAL ros_Gamma[], - char ros_NewF[], KPP_REAL *ros_ELO, char* ros_Name ); - void Ros4 ( int *ros_S, KPP_REAL ros_A[], KPP_REAL ros_C[], - KPP_REAL ros_M[], KPP_REAL ros_E[], - KPP_REAL ros_Alpha[], KPP_REAL ros_Gamma[], - char ros_NewF[], KPP_REAL *ros_ELO, char* ros_Name ); - void Rodas3 ( int *ros_S, KPP_REAL ros_A[], KPP_REAL ros_C[], - KPP_REAL ros_M[], KPP_REAL ros_E[], - KPP_REAL ros_Alpha[], KPP_REAL ros_Gamma[], - char ros_NewF[], KPP_REAL *ros_ELO, char* ros_Name ); - void Rodas4 ( int *ros_S, KPP_REAL ros_A[], KPP_REAL ros_C[], - KPP_REAL ros_M[], KPP_REAL ros_E[], - KPP_REAL ros_Alpha[], KPP_REAL ros_Gamma[], - char ros_NewF[], KPP_REAL *ros_ELO, char* ros_Name ); - int KppDecomp( KPP_REAL A[] ); - void KppSolve ( KPP_REAL A[], KPP_REAL b[] ); - void Update_SUN(); - void Update_RCONST(); - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void INTEGRATE( KPP_REAL TIN, KPP_REAL TOUT ) -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -{ - static KPP_REAL RPAR[20]; - static int i, IERR, IPAR[20]; - static int Ns=0, Na=0, Nr=0, Ng=0; - - for ( i = 0; i < 20; i++ ) { - IPAR[i] = 0; - RPAR[i] = ZERO; - } /* for */ - - - IPAR[0] = 0; /* non-autonomous */ - IPAR[1] = 1; /* vector tolerances */ - RPAR[2] = STEPMIN; /* starting step */ - IPAR[3] = 5; /* choice of the method */ - - IERR = Rosenbrock(VAR, TIN, TOUT, - ATOL, RTOL, - &FunTemplate, &JacTemplate, - RPAR, IPAR); - - - Ns=Ns+IPAR[12]; - Na=Na+IPAR[13]; - Nr=Nr+IPAR[14]; - Ng=Ng+IPAR[17]; - printf("\n Step=%d Acc=%d Rej=%d Singular=%d\n", - Ns,Na,Nr,Ng); - - - if (IERR < 0) - printf("\n Rosenbrock: Unsucessful step at T=%g: IERR=%d\n", - TIN,IERR); - - TIN = RPAR[10]; /* Exit time */ - STEPMIN = RPAR[11]; /* Last step */ - -} /* INTEGRATE */ - - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -int Rosenbrock(KPP_REAL Y[], KPP_REAL Tstart, KPP_REAL Tend, - KPP_REAL AbsTol[], KPP_REAL RelTol[], - void (*ode_Fun)(KPP_REAL, KPP_REAL [], KPP_REAL []), - void (*ode_Jac)(KPP_REAL, KPP_REAL [], KPP_REAL []), - KPP_REAL RPAR[], int IPAR[]) -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - Solves the system y'=F(t,y) using a Rosenbrock method defined by: - - G = 1/(H*gamma[0]) - ode_Jac(t0,Y0) - T_i = t0 + Alpha(i)*H - Y_i = Y0 + \sum_{j=1}^{i-1} A(i,j)*K_j - G * K_i = ode_Fun( T_i, Y_i ) + \sum_{j=1}^S C(i,j)/H * K_j + - gamma(i)*dF/dT(t0, Y0) - Y1 = Y0 + \sum_{j=1}^S M(j)*K_j - - For details on Rosenbrock methods and their implementation consult: - E. Hairer and G. Wanner - "Solving ODEs II. Stiff and differential-algebraic problems". - Springer series in computational mathematics, Springer-Verlag, 1996. - The codes contained in the book inspired this implementation. - - (C) Adrian Sandu, August 2004 - Virginia Polytechnic Institute and State University - Contact: sandu@cs.vt.edu - This implementation is part of KPP - the Kinetic PreProcessor -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - *~~~> INPUT ARGUMENTS: - -- Y(NVAR) = vector of initial conditions (at T=Tstart) -- [Tstart,Tend] = time range of integration - (if Tstart>Tend the integration is performed backwards in time) -- RelTol, AbsTol = user precribed accuracy -- void ode_Fun( T, Y, Ydot ) = ODE function, - returns Ydot = Y' = F(T,Y) -- void ode_Fun( T, Y, Ydot ) = Jacobian of the ODE function, - returns Jcb = dF/dY -- IPAR(1:10) = int inputs parameters -- RPAR(1:10) = real inputs parameters -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - *~~~> OUTPUT ARGUMENTS: - -- Y(NVAR) -> vector of final states (at T->Tend) -- IPAR(11:20) -> int output parameters -- RPAR(11:20) -> real output parameters -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - *~~~> RETURN VALUE (int): - -- IERR -> job status upon return - - succes (positive value) or failure (negative value) - - = 1 : Success - = -1 : Improper value for maximal no of steps - = -2 : Selected Rosenbrock method not implemented - = -3 : Hmin/Hmax/Hstart must be positive - = -4 : FacMin/FacMax/FacRej must be positive - = -5 : Improper tolerance values - = -6 : No of steps exceeds maximum bound - = -7 : Step size too small - = -8 : Matrix is repeatedly singular -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - *~~~> INPUT PARAMETERS: - - Note: For input parameters equal to zero the default values of the - corresponding variables are used. - - IPAR[0] = 1: F = F(y) Independent of T (AUTONOMOUS) - = 0: F = F(t,y) Depends on T (NON-AUTONOMOUS) - IPAR[1] = 0: AbsTol, RelTol are NVAR-dimensional vectors - = 1: AbsTol, RelTol are scalars - IPAR[2] -> maximum number of integration steps - For IPAR[2]=0) the default value of 100000 is used - - IPAR[3] -> selection of a particular Rosenbrock method - = 0 : default method is Rodas3 - = 1 : method is Ros2 - = 2 : method is Ros3 - = 3 : method is Ros4 - = 4 : method is Rodas3 - = 5: method is Rodas4 - - RPAR[0] -> Hmin, lower bound for the integration step size - It is strongly recommended to keep Hmin = ZERO - RPAR[1] -> Hmax, upper bound for the integration step size - RPAR[2] -> Hstart, starting value for the integration step size - - RPAR[3] -> FacMin, lower bound on step decrease factor (default=0.2) - RPAR[4] -> FacMin,upper bound on step increase factor (default=6) - RPAR[5] -> FacRej, step decrease factor after multiple rejections - (default=0.1) - RPAR[6] -> FacSafe, by which the new step is slightly smaller - than the predicted value (default=0.9) -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - *~~~> OUTPUT PARAMETERS: - - Note: each call to Rosenbrock adds the corrent no. of fcn calls - to previous value of IPAR[10], and similar for the other params. - Set IPAR(11:20) = 0 before call to avoid this accumulation. - - IPAR[10] = No. of function calls - IPAR[11] = No. of jacobian calls - IPAR[12] = No. of steps - IPAR[13] = No. of accepted steps - IPAR[14] = No. of rejected steps (except at the beginning) - IPAR[15] = No. of LU decompositions - IPAR[16] = No. of forward/backward substitutions - IPAR[17] = No. of singular matrix decompositions - - RPAR[10] -> Texit, the time corresponding to the - computed Y upon return - RPAR[11] -> Hexit, last accepted step before exit - For multiple restarts, use Hexit as Hstart in the following run -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ */ -{ - - /*~~~> The method parameters */ - #define Smax 6 - int Method, ros_S; - KPP_REAL ros_M[Smax], ros_E[Smax]; - KPP_REAL ros_A[Smax*(Smax-1)/2], ros_C[Smax*(Smax-1)/2]; - KPP_REAL ros_Alpha[Smax], ros_Gamma[Smax], ros_ELO; - char ros_NewF[Smax], ros_Name[12]; - /*~~~> Local variables */ - int Max_no_steps, IERR, i, UplimTol; - char Autonomous, VectorTol; - KPP_REAL Roundoff,FacMin,FacMax,FacRej,FacSafe; - KPP_REAL Hmin, Hmax, Hstart, Hexit, Texit; -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ */ - - /*~~~> Initialize statistics */ - Nfun = IPAR[10]; - Njac = IPAR[11]; - Nstp = IPAR[12]; - Nacc = IPAR[13]; - Nrej = IPAR[14]; - Ndec = IPAR[15]; - Nsol = IPAR[16]; - Nsng = IPAR[17]; - - /*~~~> Autonomous or time dependent ODE. Default is time dependent. */ - Autonomous = !(IPAR[0] == 0); - - /*~~~> For Scalar tolerances (IPAR[1] != 0) the code uses AbsTol[0] and RelTol[0] -! For Vector tolerances (IPAR[1] == 0) the code uses AbsTol(1:NVAR) and RelTol(1:NVAR) */ - if (IPAR[1] == 0) { - VectorTol = 1; UplimTol = KPP_NVAR; - } else { - VectorTol = 0; UplimTol = 1; - } /* end if */ - - /*~~~> The maximum number of steps admitted */ - if (IPAR[2] == 0) - Max_no_steps = 100000; - else - Max_no_steps=IPAR[2]; - if (Max_no_steps < 0) { - printf("\n User-selected max no. of steps: IPAR[2]=%d\n",IPAR[2]); - return ros_ErrorMsg(-1,Tstart,ZERO); - } /* end if */ - - /*~~~> The particular Rosenbrock method chosen */ - if (IPAR[3] == 0) - Method = 3; - else - Method = IPAR[3]; - if ( (IPAR[3] < 1) || (IPAR[3] > 5) ){ - printf("\n User-selected Rosenbrock method: IPAR[3]=%d\n",IPAR[3]); - return ros_ErrorMsg(-2,Tstart,ZERO); - } /* end if */ - - /*~~~> Unit Roundoff (1+Roundoff>1) */ - Roundoff = WLAMCH('E'); - - /*~~~> Lower bound on the step size: (positive value) */ - Hmin = RPAR[0]; - if (RPAR[0] < ZERO) { - printf("\n User-selected Hmin: RPAR[0]=%e\n", RPAR[0]); - return ros_ErrorMsg(-3,Tstart,ZERO); - } /* end if */ - /*~~~> Upper bound on the step size: (positive value) */ - if (RPAR[1] == ZERO) - Hmax = ABS(Tend-Tstart); - else - Hmax = MIN(ABS(RPAR[1]),ABS(Tend-Tstart)); - if (RPAR[1] < ZERO) { - printf("\n User-selected Hmax: RPAR[1]=%e\n", RPAR[1]); - return ros_ErrorMsg(-3,Tstart,ZERO); - } /* end if */ - /*~~~> Starting step size: (positive value) */ - if (RPAR[2] == ZERO) - Hstart = MAX(Hmin,DeltaMin); - else - Hstart = MIN(ABS(RPAR[2]),ABS(Tend-Tstart)); - if (RPAR[2] < ZERO) { - printf("\n User-selected Hstart: RPAR[2]=%e\n", RPAR[2]); - return ros_ErrorMsg(-3,Tstart,ZERO); - } /* end if */ - /*~~~> Step size can be changed s.t. FacMin < Hnew/Hexit < FacMax */ - if (RPAR[3] == ZERO) - FacMin = (KPP_REAL)0.2; - else - FacMin = RPAR[3]; - if (RPAR[3] < ZERO) { - printf("\n User-selected FacMin: RPAR[3]=%e\n", RPAR[3]); - return ros_ErrorMsg(-4,Tstart,ZERO); - } /* end if */ - if (RPAR[4] == ZERO) - FacMax = (KPP_REAL)6.0; - else - FacMax = RPAR[4]; - if (RPAR[4] < ZERO) { - printf("\n User-selected FacMax: RPAR[4]=%e\n", RPAR[4]); - return ros_ErrorMsg(-4,Tstart,ZERO); - } /* end if */ - /*~~~> FacRej: Factor to decrease step after 2 succesive rejections */ - if (RPAR[5] == ZERO) - FacRej = (KPP_REAL)0.1; - else - FacRej = RPAR[5]; - if (RPAR[5] < ZERO) { - printf("\n User-selected FacRej: RPAR[5]=%e\n", RPAR[5]); - return ros_ErrorMsg(-4,Tstart,ZERO); - } /* end if */ - /*~~~> FacSafe: Safety Factor in the computation of new step size */ - if (RPAR[6] == ZERO) - FacSafe = (KPP_REAL)0.9; - else - FacSafe = RPAR[6]; - if (RPAR[6] < ZERO) { - printf("\n User-selected FacSafe: RPAR[6]=%e\n", RPAR[6]); - return ros_ErrorMsg(-4,Tstart,ZERO); - } /* end if */ - /*~~~> Check if tolerances are reasonable */ - for (i = 0; i < UplimTol; i++) { - if ( (AbsTol[i] <= ZERO) || (RelTol[i] <= 10.0*Roundoff) - || (RelTol[i] >= ONE) ) { - printf("\n AbsTol[%d] = %e\n",i,AbsTol[i]); - printf("\n RelTol[%d] = %e\n",i,RelTol[i]); - return ros_ErrorMsg(-5,Tstart,ZERO); - } /* end if */ - } /* for */ - - - /*~~~> Initialize the particular Rosenbrock method */ - switch (Method) { - case 1: - Ros2(&ros_S, ros_A, ros_C, ros_M, ros_E, - ros_Alpha, ros_Gamma, ros_NewF, &ros_ELO, ros_Name); - break; - case 2: - Ros3(&ros_S, ros_A, ros_C, ros_M, ros_E, - ros_Alpha, ros_Gamma, ros_NewF, &ros_ELO, ros_Name); - break; - case 3: - Ros4(&ros_S, ros_A, ros_C, ros_M, ros_E, - ros_Alpha, ros_Gamma, ros_NewF, &ros_ELO, ros_Name); - break; - case 4: - Rodas3(&ros_S, ros_A, ros_C, ros_M, ros_E, - ros_Alpha, ros_Gamma, ros_NewF, &ros_ELO, ros_Name); - break; - case 5: - Rodas4(&ros_S, ros_A, ros_C, ros_M, ros_E, - ros_Alpha, ros_Gamma, ros_NewF, &ros_ELO, ros_Name); - break; - default: - printf("\n Unknown Rosenbrock method: IPAR[3]= %d", Method); - return ros_ErrorMsg(-2,Tstart,ZERO); - } /* end switch */ - - /*~~~> Rosenbrock method */ - IERR = RosenbrockIntegrator( Y,Tstart,Tend, - AbsTol, RelTol, - ode_Fun,ode_Jac , - /* Rosenbrock method coefficients */ - ros_S, ros_M, ros_E, ros_A, ros_C, - ros_Alpha, ros_Gamma, ros_ELO, ros_NewF, - /* Integration parameters */ - Autonomous, VectorTol, Max_no_steps, - Roundoff, Hmin, Hmax, Hstart, - FacMin, FacMax, FacRej, FacSafe, - /* Output parameters */ - &Texit, &Hexit ); - - - /*~~~> Collect run statistics */ - IPAR[10] = Nfun; - IPAR[11] = Njac; - IPAR[12] = Nstp; - IPAR[13] = Nacc; - IPAR[14] = Nrej; - IPAR[15] = Ndec; - IPAR[16] = Nsol; - IPAR[17] = Nsng; - /*~~~> Last T and H */ - RPAR[10] = Texit; - RPAR[11] = Hexit; - - return IERR; - -} /* Rosenbrock */ - - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -int RosenbrockIntegrator( - /*~~~> Input: the initial condition at Tstart; Output: the solution at T */ - KPP_REAL Y[], - /*~~~> Input: integration interval */ - KPP_REAL Tstart, KPP_REAL Tend , - /*~~~> Input: tolerances */ - KPP_REAL AbsTol[], KPP_REAL RelTol[], - /*~~~> Input: ode function and its Jacobian */ - void (*ode_Fun)(KPP_REAL, KPP_REAL [], KPP_REAL []), - void (*ode_Jac)(KPP_REAL, KPP_REAL [], KPP_REAL []) , - /*~~~> Input: The Rosenbrock method parameters */ - int ros_S, - KPP_REAL ros_M[], KPP_REAL ros_E[], - KPP_REAL ros_A[], KPP_REAL ros_C[], - KPP_REAL ros_Alpha[],KPP_REAL ros_Gamma[], - KPP_REAL ros_ELO, char ros_NewF[], - /*~~~> Input: integration parameters */ - char Autonomous, char VectorTol, - int Max_no_steps, - KPP_REAL Roundoff, KPP_REAL Hmin, KPP_REAL Hmax, KPP_REAL Hstart, - KPP_REAL FacMin, KPP_REAL FacMax, KPP_REAL FacRej, KPP_REAL FacSafe, - /*~~~> Output: time at which the solution is returned (T=Tend if success) - and last accepted step */ - KPP_REAL *Texit, KPP_REAL *Hexit ) -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Template for the implementation of a generic Rosenbrock method - defined by ros_S (no of stages) and coefficients ros_{A,C,M,E,Alpha,Gamma} - - returned value: IERR, indicator of success (if positive) - or failure (if negative) -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -{ - KPP_REAL Ynew[KPP_NVAR], Fcn0[KPP_NVAR], Fcn[KPP_NVAR], - dFdT[KPP_NVAR], - Jac0[KPP_LU_NONZERO], Ghimj[KPP_LU_NONZERO]; - KPP_REAL K[KPP_NVAR*ros_S]; - KPP_REAL H, T, Hnew, HC, HG, Fac, Tau; - KPP_REAL Err, Yerr[KPP_NVAR]; - int Pivot[KPP_NVAR], Direction, ioffset, j, istage; - char RejectLastH, RejectMoreH; - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - - /*~~~> INITIAL PREPARATIONS */ - T = Tstart; - *Hexit = 0.0; - H = MIN(Hstart,Hmax); - if (ABS(H) <= 10.0*Roundoff) - H = DeltaMin; - - if (Tend >= Tstart) { - Direction = +1; - } else { - Direction = -1; - } /* end if */ - - RejectLastH=0; RejectMoreH=0; - - /*~~~> Time loop begins below */ - - while ( ( (Direction > 0) && ((T-Tend)+Roundoff <= ZERO) ) - || ( (Direction < 0) && ((Tend-T)+Roundoff <= ZERO) ) ) { - - if ( Nstp > Max_no_steps ) { /* Too many steps */ - *Texit = T; - return ros_ErrorMsg(-6,T,H); - } - if ( ((T+0.1*H) == T) || (H <= Roundoff) ) { /* Step size too small */ - *Texit = T; - return ros_ErrorMsg(-7,T,H); - } - - /*~~~> Limit H if necessary to avoid going beyond Tend */ - *Hexit = H; - H = MIN(H,ABS(Tend-T)); - - /*~~~> Compute the function at current time */ - (*ode_Fun)(T,Y,Fcn0); - - /*~~~> Compute the function derivative with respect to T */ - if (!Autonomous) - ros_FunTimeDerivative ( T, Roundoff, Y, Fcn0, ode_Fun, dFdT ); - - /*~~~> Compute the Jacobian at current time */ - (*ode_Jac)(T,Y,Jac0); - - /*~~~> Repeat step calculation until current step accepted */ - while (1) { /* WHILE STEP NOT ACCEPTED */ - - - if( ros_PrepareMatrix( &H, Direction, ros_Gamma[0], - Jac0, Ghimj, Pivot) ) { /* More than 5 consecutive failed decompositions */ - *Texit = T; - return ros_ErrorMsg(-8,T,H); - } - - /*~~~> Compute the stages */ - for (istage = 1; istage <= ros_S; istage++) { - - /* Current istage offset. Current istage vector is K[ioffset:ioffset+KPP_NVAR-1] */ - ioffset = KPP_NVAR*(istage-1); - - /* For the 1st istage the function has been computed previously */ - if ( istage == 1 ) - WCOPY(KPP_NVAR,Fcn0,1,Fcn,1); - else { /* istage>1 and a new function evaluation is needed at current istage */ - if ( ros_NewF[istage-1] ) { - WCOPY(KPP_NVAR,Y,1,Ynew,1); - for (j = 1; j <= istage-1; j++) - WAXPY(KPP_NVAR,ros_A[(istage-1)*(istage-2)/2+j-1], - &K[KPP_NVAR*(j-1)],1,Ynew,1); - Tau = T + ros_Alpha[istage-1]*Direction*H; - (*ode_Fun)(Tau,Ynew,Fcn); - } /*end if ros_NewF(istage)*/ - } /* end if istage */ - - WCOPY(KPP_NVAR,Fcn,1,&K[ioffset],1); - for (j = 1; j <= istage-1; j++) { - HC = ros_C[(istage-1)*(istage-2)/2+j-1]/(Direction*H); - WAXPY(KPP_NVAR,HC,&K[KPP_NVAR*(j-1)],1,&K[ioffset],1); - } /* for j */ - - if ((!Autonomous) && (ros_Gamma[istage-1])) { - HG = Direction*H*ros_Gamma[istage-1]; - WAXPY(KPP_NVAR,HG,dFdT,1,&K[ioffset],1); - } /* end if !Autonomous */ - - SolveTemplate(Ghimj, Pivot, &K[ioffset]); - - } /* for istage */ - - - /*~~~> Compute the new solution */ - WCOPY(KPP_NVAR,Y,1,Ynew,1); - for (j=1; j<=ros_S; j++) - WAXPY(KPP_NVAR,ros_M[j-1],&K[KPP_NVAR*(j-1)],1,Ynew,1); - - /*~~~> Compute the error estimation */ - WSCAL(KPP_NVAR,ZERO,Yerr,1); - for (j=1; j<=ros_S; j++) - WAXPY(KPP_NVAR,ros_E[j-1],&K[KPP_NVAR*(j-1)],1,Yerr,1); - Err = ros_ErrorNorm ( Y, Ynew, Yerr, AbsTol, RelTol, VectorTol ); - - /*~~~> New step size is bounded by FacMin <= Hnew/H <= FacMax */ - Fac = MIN(FacMax,MAX(FacMin,FacSafe/pow(Err,ONE/ros_ELO))); - Hnew = H*Fac; - - /*~~~> Check the error magnitude and adjust step size */ - Nstp++; - if ( (Err <= ONE) || (H <= Hmin) ) { /*~~~> Accept step */ - Nacc++; - WCOPY(KPP_NVAR,Ynew,1,Y,1); - T += Direction*H; - Hnew = MAX(Hmin,MIN(Hnew,Hmax)); - /* No step size increase after a rejected step */ - if (RejectLastH) - Hnew = MIN(Hnew,H); - RejectLastH = 0; RejectMoreH = 0; - H = Hnew; - break; /* EXIT THE LOOP: WHILE STEP NOT ACCEPTED */ - } else { /*~~~> Reject step */ - if (Nacc >= 1) - Nrej++; - if (RejectMoreH) - Hnew=H*FacRej; - RejectMoreH = RejectLastH; RejectLastH = 1; - H = Hnew; - } /* end if Err <= 1 */ - - } /* while LOOP: WHILE STEP NOT ACCEPTED */ - - } /* while: time loop */ - - /*~~~> The integration was successful */ - *Texit = T; - return 1; - -} /* RosenbrockIntegrator */ - - - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -KPP_REAL ros_ErrorNorm ( - /*~~~> Input arguments */ - KPP_REAL Y[], KPP_REAL Ynew[], KPP_REAL Yerr[], - KPP_REAL AbsTol[], KPP_REAL RelTol[], - char VectorTol ) -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Computes and returns the "scaled norm" of the error vector Yerr -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -{ - /*~~~> Local variables */ - KPP_REAL Err, Scale, Ymax; - int i; - - Err = ZERO; - for (i=0; i Input arguments: */ - KPP_REAL T, KPP_REAL Roundoff, - KPP_REAL Y[], KPP_REAL Fcn0[], - void (*ode_Fun)(KPP_REAL, KPP_REAL [], KPP_REAL []), - /*~~~> Output arguments: */ - KPP_REAL dFdT[] ) -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - The time partial derivative of the function by finite differences -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -{ - /*~~~> Local variables */ - KPP_REAL Delta; - - Delta = SQRT(Roundoff)*MAX(DeltaMin,ABS(T)); - (*ode_Fun)(T+Delta,Y,dFdT); - WAXPY(KPP_NVAR,(-ONE),Fcn0,1,dFdT,1); - WSCAL(KPP_NVAR,(ONE/Delta),dFdT,1); - -} /* ros_FunTimeDerivative */ - - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -char ros_PrepareMatrix ( - /* Inout argument: (step size is decreased when LU fails) */ - KPP_REAL* H, - /* Input arguments: */ - int Direction, KPP_REAL gam, KPP_REAL Jac0[], - /* Output arguments: */ - KPP_REAL Ghimj[], int Pivot[] ) -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Prepares the LHS matrix for stage calculations - 1. Construct Ghimj = 1/(H*ham) - Jac0 - "(Gamma H) Inverse Minus Jacobian" - 2. Repeat LU decomposition of Ghimj until successful. - -half the step size if LU decomposition fails and retry - -exit after 5 consecutive fails - - Return value: Singular (true=1=failed_LU or false=0=successful_LU) -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -{ - /*~~~> Local variables */ - int i, ising, Nconsecutive; - KPP_REAL ghinv; - - Nconsecutive = 0; - - while (1) { /* while Singular */ - - /*~~~> Construct Ghimj = 1/(H*ham) - Jac0 */ - WCOPY(KPP_LU_NONZERO,Jac0,1,Ghimj,1); - WSCAL(KPP_LU_NONZERO,(-ONE),Ghimj,1); - ghinv = ONE/(Direction*(*H)*gam); - for (i=0; i Compute LU decomposition */ - DecompTemplate( Ghimj, Pivot, &ising ); - if (ising == 0) { - /*~~~> if successful done */ - return 0; /* Singular = false */ - } else { /* ising .ne. 0 */ - /*~~~> if unsuccessful half the step size; if 5 consecutive fails return */ - Nsng++; Nconsecutive++; - printf("\nWarning: LU Decomposition returned ising = %d\n",ising); - if (Nconsecutive <= 5) { /* Less than 5 consecutive failed LUs */ - *H = (*H)*HALF; - } else { /* More than 5 consecutive failed LUs */ - return 1; /* Singular = true */ - } /* end if Nconsecutive */ - } /* end if ising */ - - } /* while Singular */ - -} /* ros_PrepareMatrix */ - - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -int ros_ErrorMsg(int Code, KPP_REAL T, KPP_REAL H) -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Handles all error messages and returns IERR = error Code -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -{ - printf("\n~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"); - printf("\nForced exit from Rosenbrock due to the following error:\n"); - - switch (Code) { - case -1: - printf("--> Improper value for maximal no of steps"); break; - case -2: - printf("--> Selected Rosenbrock method not implemented"); break; - case -3: - printf("--> Hmin/Hmax/Hstart must be positive"); break; - case -4: - printf("--> FacMin/FacMax/FacRej must be positive"); break; - case -5: - printf("--> Improper tolerance values"); break; - case -6: - printf("--> No of steps exceeds maximum bound"); break; - case -7: - printf("--> Step size too small (T + H/10 = T) or H < Roundoff"); break; - case -8: - printf("--> Matrix is repeatedly singular"); break; - default: - printf("Unknown Error code: %d ",Code); - } /* end switch */ - - printf("\n Time = %15.7e, H = %15.7e",T,H); - printf("\n~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n"); - - return Code; - -} /* ros_ErrorMsg */ - - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void Ros2 ( int *ros_S, KPP_REAL ros_A[], KPP_REAL ros_C[], - KPP_REAL ros_M[], KPP_REAL ros_E[], - KPP_REAL ros_Alpha[], KPP_REAL ros_Gamma[], - char ros_NewF[], KPP_REAL *ros_ELO, char* ros_Name ) -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - AN L-STABLE METHOD, 2 stages, order 2 -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -{ - double g = (KPP_REAL)1.70710678118655; /* 1.0 + 1.0/SQRT(2.0) */ - - /*~~~> Name of the method */ - strcpy(ros_Name, "ROS-2"); - - /*~~~> Number of stages */ - *ros_S = 2; - - /*~~~> The coefficient matrices A and C are strictly lower triangular. - The lower triangular (subdiagonal) elements are stored in row-wise order: - A(2,1) = ros_A[0], A(3,1)=ros_A[1], A(3,2)=ros_A[2], etc. - The general mapping formula is: - A_{i,j} = ros_A[ (i-1)*(i-2)/2 + j -1 ] */ - ros_A[0] = 1.0/g; - - /*~~~> C_{i,j} = ros_C[ (i-1)*(i-2)/2 + j -1] */ - ros_C[0] = (-2.0)/g; - - /*~~~> does the stage i require a new function evaluation (ros_NewF(i)=TRUE) - or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) */ - ros_NewF[0] = 1; - ros_NewF[1] = 1; - - /*~~~> M_i = Coefficients for new step solution */ - ros_M[0]= (3.0)/(2.0*g); - ros_M[1]= (1.0)/(2.0*g); - - /*~~~> E_i = Coefficients for error estimator */ - ros_E[0] = 1.0/(2.0*g); - ros_E[1] = 1.0/(2.0*g); - - /*~~~> ros_ELO = estimator of local order - the minimum between the -! main and the embedded scheme orders plus one */ - *ros_ELO = (KPP_REAL)2.0; - - /*~~~> Y_stage_i ~ Y( T + H*Alpha_i ) */ - ros_Alpha[0] = (KPP_REAL)0.0; - ros_Alpha[1] = (KPP_REAL)1.0; - - /*~~~> Gamma_i = \sum_j gamma_{i,j} */ - ros_Gamma[0] = g; - ros_Gamma[1] = -g; - -} /* Ros2 */ - - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void Ros3 ( int *ros_S, KPP_REAL ros_A[], KPP_REAL ros_C[], - KPP_REAL ros_M[], KPP_REAL ros_E[], - KPP_REAL ros_Alpha[], KPP_REAL ros_Gamma[], - char ros_NewF[], KPP_REAL *ros_ELO, char* ros_Name ) -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - AN L-STABLE METHOD, 3 stages, order 3, 2 function evaluations -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -{ - /*~~~> Name of the method */ - strcpy(ros_Name, "ROS-3"); - - /*~~~> Number of stages */ - *ros_S = 3; - - /*~~~> The coefficient matrices A and C are strictly lower triangular. - The lower triangular (subdiagonal) elements are stored in row-wise order: - A(2,1) = ros_A[0], A(3,1)=ros_A[1], A(3,2)=ros_A[2], etc. - The general mapping formula is: - A_{i,j} = ros_A[ (i-1)*(i-2)/2 + j -1 ] */ - ros_A[0]= (KPP_REAL)1.0; - ros_A[1]= (KPP_REAL)1.0; - ros_A[2]= (KPP_REAL)0.0; - - /*~~~> C_{i,j} = ros_C[ (i-1)*(i-2)/2 + j -1] */ - ros_C[0] = (KPP_REAL)(-1.0156171083877702091975600115545); - ros_C[1] = (KPP_REAL)4.0759956452537699824805835358067; - ros_C[2] = (KPP_REAL)9.2076794298330791242156818474003; - - /*~~~> does the stage i require a new function evaluation (ros_NewF(i)=TRUE) - or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) */ - ros_NewF[0] = 1; - ros_NewF[1] = 1; - ros_NewF[2] = 0; - - /*~~~> M_i = Coefficients for new step solution */ - ros_M[0] = (KPP_REAL)1.0; - ros_M[1] = (KPP_REAL)6.1697947043828245592553615689730; - ros_M[2] = (KPP_REAL)(-0.4277225654321857332623837380651); - - /*~~~> E_i = Coefficients for error estimator */ - ros_E[0] = (KPP_REAL)0.5; - ros_E[1] = (KPP_REAL)(-2.9079558716805469821718236208017); - ros_E[2] = (KPP_REAL)0.2235406989781156962736090927619; - - /*~~~> ros_ELO = estimator of local order - the minimum between the -! main and the embedded scheme orders plus 1 */ - *ros_ELO = (KPP_REAL)3.0; - - /*~~~> Y_stage_i ~ Y( T + H*Alpha_i ) */ - ros_Alpha[0]= (KPP_REAL)0.0; - ros_Alpha[1]= (KPP_REAL)0.43586652150845899941601945119356; - ros_Alpha[2]= (KPP_REAL)0.43586652150845899941601945119356; - - /*~~~> Gamma_i = \sum_j gamma_{i,j} */ - ros_Gamma[0]= (KPP_REAL)0.43586652150845899941601945119356; - ros_Gamma[1]= (KPP_REAL)0.24291996454816804366592249683314; - ros_Gamma[2]= (KPP_REAL)2.1851380027664058511513169485832; - -} /* Ros3 */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void Ros4 ( int *ros_S, KPP_REAL ros_A[], KPP_REAL ros_C[], - KPP_REAL ros_M[], KPP_REAL ros_E[], - KPP_REAL ros_Alpha[], KPP_REAL ros_Gamma[], - char ros_NewF[], KPP_REAL *ros_ELO, char* ros_Name ) -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - L-STABLE ROSENBROCK METHOD OF ORDER 4, WITH 4 STAGES - L-STABLE EMBEDDED ROSENBROCK METHOD OF ORDER 3 - - E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL - EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS. - SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS, - SPRINGER-VERLAG (1990) -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -{ - /*~~~> Name of the method */ - strcpy(ros_Name, "ROS-4"); - - /*~~~> Number of stages */ - *ros_S = 4; - - /*~~~> The coefficient matrices A and C are strictly lower triangular. - The lower triangular (subdiagonal) elements are stored in row-wise order: - A(2,1) = ros_A[0], A(3,1)=ros_A[1], A(3,2)=ros_A[2], etc. - The general mapping formula is: - A_{i,j} = ros_A[ (i-1)*(i-2)/2 + j -1 ] */ - ros_A[0] = (KPP_REAL)0.2000000000000000e+01; - ros_A[1] = (KPP_REAL)0.1867943637803922e+01; - ros_A[2] = (KPP_REAL)0.2344449711399156; - ros_A[3] = ros_A[1]; - ros_A[4] = ros_A[2]; - ros_A[5] = (KPP_REAL)0.0; - - /*~~~> C(i,j) = (KPP_REAL)ros_C( (i-1)*(i-2)/2 + j ) */ - ros_C[0] = (KPP_REAL)(-0.7137615036412310e+01); - ros_C[1] = (KPP_REAL)( 0.2580708087951457e+01); - ros_C[2] = (KPP_REAL)( 0.6515950076447975); - ros_C[3] = (KPP_REAL)(-0.2137148994382534e+01); - ros_C[4] = (KPP_REAL)(-0.3214669691237626); - ros_C[5] = (KPP_REAL)(-0.6949742501781779); - - /*~~~> does the stage i require a new function evaluation (ros_NewF(i)=TRUE) - or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) */ - ros_NewF[0] = 1; - ros_NewF[1] = 1; - ros_NewF[2] = 1; - ros_NewF[3] = 0; - - /*~~~> M_i = Coefficients for new step solution */ - ros_M[0] = (KPP_REAL)0.2255570073418735e+01; - ros_M[1] = (KPP_REAL)0.2870493262186792; - ros_M[2] = (KPP_REAL)0.4353179431840180; - ros_M[3] = (KPP_REAL)0.1093502252409163e+01; - - /*~~~> E_i = Coefficients for error estimator */ - ros_E[0] = (KPP_REAL)(-0.2815431932141155); - ros_E[1] = (KPP_REAL)(-0.7276199124938920e-01); - ros_E[2] = (KPP_REAL)(-0.1082196201495311); - ros_E[3] = (KPP_REAL)(-0.1093502252409163e+01); - - /*~~~> ros_ELO = estimator of local order - the minimum between the -! main and the embedded scheme orders plus 1 */ - *ros_ELO = (KPP_REAL)4.0; - - /*~~~> Y_stage_i ~ Y( T + H*Alpha_i ) */ - ros_Alpha[0] = (KPP_REAL)0.0; - ros_Alpha[1] = (KPP_REAL)0.1145640000000000e+01; - ros_Alpha[2] = (KPP_REAL)0.6552168638155900; - ros_Alpha[3] = (KPP_REAL)ros_Alpha[2]; - - /*~~~> Gamma_i = \sum_j gamma_{i,j} */ - ros_Gamma[0] = (KPP_REAL)( 0.5728200000000000); - ros_Gamma[1] = (KPP_REAL)(-0.1769193891319233e+01); - ros_Gamma[2] = (KPP_REAL)( 0.7592633437920482); - ros_Gamma[3] = (KPP_REAL)(-0.1049021087100450); - -} /* Ros4 */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void Rodas3 ( int *ros_S, KPP_REAL ros_A[], KPP_REAL ros_C[], - KPP_REAL ros_M[], KPP_REAL ros_E[], - KPP_REAL ros_Alpha[], KPP_REAL ros_Gamma[], - char ros_NewF[], KPP_REAL *ros_ELO, char* ros_Name ) -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - --- A STIFFLY-STABLE METHOD, 4 stages, order 3 -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -{ - /*~~~> Name of the method */ - strcpy(ros_Name, "RODAS-3"); - - /*~~~> Number of stages */ - *ros_S = 4; - - /*~~~> The coefficient matrices A and C are strictly lower triangular. - The lower triangular (subdiagonal) elements are stored in row-wise order: - A(2,1) = ros_A[0], A(3,1)=ros_A[1], A(3,2)=ros_A[2], etc. - The general mapping formula is: - A_{i,j} = ros_A[ (i-1)*(i-2)/2 + j -1 ] */ - ros_A[0] = (KPP_REAL)0.0; - ros_A[1] = (KPP_REAL)2.0; - ros_A[2] = (KPP_REAL)0.0; - ros_A[3] = (KPP_REAL)2.0; - ros_A[4] = (KPP_REAL)0.0; - ros_A[5] = (KPP_REAL)1.0; - - /*~~~> C_{i,j} = ros_C[ (i-1)*(i-2)/2 + j -1] */ - ros_C[0] = (KPP_REAL)4.0; - ros_C[1] = (KPP_REAL)1.0; - ros_C[2] = (KPP_REAL)(-1.0); - ros_C[3] = (KPP_REAL)1.0; - ros_C[4] = (KPP_REAL)(-1.0); - ros_C[5] = (KPP_REAL)(-2.66666666666667); /* -8/3 */ - - /*~~~> does the stage i require a new function evaluation (ros_NewF(i)=TRUE) - or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) */ - ros_NewF[0] = 1; - ros_NewF[1] = 0; - ros_NewF[2] = 1; - ros_NewF[3] = 1; - - /*~~~> M_i = Coefficients for new step solution */ - ros_M[0] = (KPP_REAL)2.0; - ros_M[1] = (KPP_REAL)0.0; - ros_M[2] = (KPP_REAL)1.0; - ros_M[3] = (KPP_REAL)1.0; - - /*~~~> E_i = Coefficients for error estimator */ - ros_E[0] = (KPP_REAL)0.0; - ros_E[1] = (KPP_REAL)0.0; - ros_E[2] = (KPP_REAL)0.0; - ros_E[3] = (KPP_REAL)1.0; - - /*~~~> ros_ELO = estimator of local order - the minimum between the -! main and the embedded scheme orders plus 1 */ - *ros_ELO = (KPP_REAL)3.0; - - /*~~~> Y_stage_i ~ Y( T + H*Alpha_i ) */ - ros_Alpha[0] = (KPP_REAL)0.0; - ros_Alpha[1] = (KPP_REAL)0.0; - ros_Alpha[2] = (KPP_REAL)1.0; - ros_Alpha[3] = (KPP_REAL)1.0; - - /*~~~> Gamma_i = \sum_j gamma_{i,j} */ - ros_Gamma[0] = (KPP_REAL)0.5; - ros_Gamma[1] = (KPP_REAL)1.5; - ros_Gamma[2] = (KPP_REAL)0.0; - ros_Gamma[3] = (KPP_REAL)0.0; - -} /* Rodas3 */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void Rodas4 ( int *ros_S, KPP_REAL ros_A[], KPP_REAL ros_C[], - KPP_REAL ros_M[], KPP_REAL ros_E[], - KPP_REAL ros_Alpha[], KPP_REAL ros_Gamma[], - char ros_NewF[], KPP_REAL *ros_ELO, char* ros_Name ) -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - STIFFLY-STABLE ROSENBROCK METHOD OF ORDER 4, WITH 6 STAGES - - E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL - EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS. - SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS, - SPRINGER-VERLAG (1996) -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -{ - /*~~~> Name of the method */ - strcpy(ros_Name, "RODAS-4"); - - /*~~~> Number of stages */ - *ros_S = 6; - - /*~~~> Y_stage_i ~ Y( T + H*Alpha_i ) */ - ros_Alpha[0] = (KPP_REAL)0.000; - ros_Alpha[1] = (KPP_REAL)0.386; - ros_Alpha[2] = (KPP_REAL)0.210; - ros_Alpha[3] = (KPP_REAL)0.630; - ros_Alpha[4] = (KPP_REAL)1.000; - ros_Alpha[5] = (KPP_REAL)1.000; - - /*~~~> Gamma_i = \sum_j gamma_{i,j} */ - ros_Gamma[0] = (KPP_REAL)0.2500000000000000; - ros_Gamma[1] = (KPP_REAL)(-0.1043000000000000); - ros_Gamma[2] = (KPP_REAL)0.1035000000000000; - ros_Gamma[3] = (KPP_REAL)(-0.3620000000000023e-01); - ros_Gamma[4] = (KPP_REAL)0.0; - ros_Gamma[5] = (KPP_REAL)0.0; - - /*~~~> The coefficient matrices A and C are strictly lower triangular. - The lower triangular (subdiagonal) elements are stored in row-wise order: - A(2,1) = ros_A[0], A(3,1)=ros_A[1], A(3,2)=ros_A[2], etc. - The general mapping formula is: A_{i,j} = ros_A[ (i-1)*(i-2)/2 + j -1 ] */ - ros_A[0] = (KPP_REAL)0.1544000000000000e+01; - ros_A[1] = (KPP_REAL)0.9466785280815826; - ros_A[2] = (KPP_REAL)0.2557011698983284; - ros_A[3] = (KPP_REAL)0.3314825187068521e+01; - ros_A[4] = (KPP_REAL)0.2896124015972201e+01; - ros_A[5] = (KPP_REAL)0.9986419139977817; - ros_A[6] = (KPP_REAL)0.1221224509226641e+01; - ros_A[7] = (KPP_REAL)0.6019134481288629e+01; - ros_A[8] = (KPP_REAL)0.1253708332932087e+02; - ros_A[9] = (KPP_REAL)(-0.6878860361058950); - ros_A[10] = ros_A[6]; - ros_A[11] = ros_A[7]; - ros_A[12] = ros_A[8]; - ros_A[13] = ros_A[9]; - ros_A[14] = (KPP_REAL)1.0; - - /*~~~> C_{i,j} = ros_C[ (i-1)*(i-2)/2 + j -1] */ - ros_C[0] = (KPP_REAL)(-0.5668800000000000e+01); - ros_C[1] = (KPP_REAL)(-0.2430093356833875e+01); - ros_C[2] = (KPP_REAL)(-0.2063599157091915); - ros_C[3] = (KPP_REAL)(-0.1073529058151375); - ros_C[4] = (KPP_REAL)(-0.9594562251023355e+01); - ros_C[5] = (KPP_REAL)(-0.2047028614809616e+02); - ros_C[6] = (KPP_REAL)( 0.7496443313967647e+01); - ros_C[7] = (KPP_REAL)(-0.1024680431464352e+02); - ros_C[8] = (KPP_REAL)(-0.3399990352819905e+02); - ros_C[9] = (KPP_REAL)( 0.1170890893206160e+02); - ros_C[10] = (KPP_REAL)( 0.8083246795921522e+01); - ros_C[11] = (KPP_REAL)(-0.7981132988064893e+01); - ros_C[12] = (KPP_REAL)(-0.3152159432874371e+02); - ros_C[13] = (KPP_REAL)( 0.1631930543123136e+02); - ros_C[14] = (KPP_REAL)(-0.6058818238834054e+01); - - /*~~~> M_i = Coefficients for new step solution */ - ros_M[0] = ros_A[6]; - ros_M[1] = ros_A[7]; - ros_M[2] = ros_A[8]; - ros_M[3] = ros_A[9]; - ros_M[4] = (KPP_REAL)1.0; - ros_M[5] = (KPP_REAL)1.0; - - /*~~~> E_i = Coefficients for error estimator */ - ros_E[0] = (KPP_REAL)0.0; - ros_E[1] = (KPP_REAL)0.0; - ros_E[2] = (KPP_REAL)0.0; - ros_E[3] = (KPP_REAL)0.0; - ros_E[4] = (KPP_REAL)0.0; - ros_E[5] = (KPP_REAL)1.0; - - /*~~~> does the stage i require a new function evaluation (ros_NewF(i)=TRUE) - or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) */ - ros_NewF[0] = 1; - ros_NewF[1] = 1; - ros_NewF[2] = 1; - ros_NewF[3] = 1; - ros_NewF[4] = 1; - ros_NewF[5] = 1; - - /*~~~> ros_ELO = estimator of local order - the minimum between the -! main and the embedded scheme orders plus 1 */ - *ros_ELO = (KPP_REAL)4.0; - -} /* Rodas4 */ - - - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void DecompTemplate( KPP_REAL A[], int Pivot[], int* ising ) -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Template for the LU decomposition -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -{ - *ising = KppDecomp ( A ); - /*~~~> Note: for a full matrix use Lapack: - DGETRF( KPP_NVAR, KPP_NVAR, A, KPP_NVAR, Pivot, ising ) */ - - Ndec++; - -} /* DecompTemplate */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - void SolveTemplate( KPP_REAL A[], int Pivot[], KPP_REAL b[] ) -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Template for the forward/backward substitution (using pre-computed LU decomposition) -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -{ - KppSolve( A, b ); - /*~~~> Note: for a full matrix use Lapack: - NRHS = 1 - DGETRS( 'N', KPP_NVAR , NRHS, A, KPP_NVAR, Pivot, b, KPP_NVAR, INFO ) */ - - Nsol++; - -} /* SolveTemplate */ - - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void FunTemplate( KPP_REAL T, KPP_REAL Y[], KPP_REAL Ydot[] ) -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Template for the ODE function call. - Updates the rate coefficients (and possibly the fixed species) at each call -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -{ - KPP_REAL Told; - - Told = TIME; - TIME = T; - Update_SUN(); - Update_RCONST(); - Fun( Y, FIX, RCONST, Ydot ); - TIME = Told; - - Nfun++; - -} /* FunTemplate */ - - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void JacTemplate( KPP_REAL T, KPP_REAL Y[], KPP_REAL Jcb[] ) -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Template for the ODE Jacobian call. - Updates the rate coefficients (and possibly the fixed species) at each call -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -{ - /*~~~> Local variables */ - KPP_REAL Told; - - Told = TIME; - TIME = T ; - Update_SUN(); - Update_RCONST(); - Jac_SP( Y, FIX, RCONST, Jcb ); - TIME = Told; - - Njac++; - -} /* JacTemplate */ - - diff --git a/boxmox/int/rosenbrock.def b/boxmox/int/rosenbrock.def deleted file mode 100644 index 81a16c52c4405327317b87c85bd61986194770fd..0000000000000000000000000000000000000000 --- a/boxmox/int/rosenbrock.def +++ /dev/null @@ -1,23 +0,0 @@ - -#FUNCTION AGGREGATE -#JACOBIAN SPARSE_LU_ROW - -#DOUBLE ON -#INTFILE rosenbrock - -#INLINE F77_GLOBAL - INTEGER Autonomous - COMMON /INTGDATA/ Autonomous - REAL*8 STEPSTART - COMMON /GDATA/ STEPSTART -#ENDINLINE - -#INLINE F77_INIT - STEPMIN=0.0001 - STEPMAX=3600. - Autonomous = 1 - STEPSTART=STEPMIN -#ENDINLINE - - - diff --git a/boxmox/int/rosenbrock.f b/boxmox/int/rosenbrock.f deleted file mode 100644 index f7920b8f3b6e16fe91e85688fa1d22336fbd9655..0000000000000000000000000000000000000000 --- a/boxmox/int/rosenbrock.f +++ /dev/null @@ -1,1286 +0,0 @@ - SUBROUTINE INTEGRATE( TIN, TOUT ) - - IMPLICIT NONE - INCLUDE 'KPP_ROOT_Parameters.h' - INCLUDE 'KPP_ROOT_Global.h' - INTEGER Nstp, Nacc, Nrej, Nsng, IERR - SAVE Nstp, Nacc, Nrej, Nsng - -! TIN - Start Time - KPP_REAL TIN -! TOUT - End Time - KPP_REAL TOUT - INTEGER i - - KPP_REAL RPAR(20) - INTEGER IPAR(20) - EXTERNAL FunTemplate, JacTemplate - - - DO i=1,20 - IPAR(i) = 0 - RPAR(i) = 0.0d0 - ENDDO - - - IPAR(1) = 0 ! non-autonomous - IPAR(2) = 1 ! vector tolerances - RPAR(3) = STEPMIN ! starting step - IPAR(4) = 5 ! choice of the method - - CALL Rosenbrock(VAR,TIN,TOUT, - & ATOL,RTOL, - & FunTemplate,JacTemplate, - & RPAR,IPAR,IERR) - - - Nstp = Nstp + IPAR(13) - Nacc = Nacc + IPAR(14) - Nrej = Nrej + IPAR(15) - Nsng = Nsng + IPAR(18) - PRINT*,'Step=',Nstp,' Acc=',Nacc,' Rej=',Nrej, - & ' Singular=',Nsng - - - IF (IERR.LT.0) THEN - print *,'Rosenbrock: Unsucessful step at T=', - & TIN,' (IERR=',IERR,')' - ENDIF - - TIN = RPAR(11) ! Exit time - STEPMIN = RPAR(12) - - RETURN - END - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Rosenbrock(Y,Tstart,Tend, - & AbsTol,RelTol, - & ode_Fun,ode_Jac , - & RPAR,IPAR,IERR) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -! Solves the system y'=F(t,y) using a Rosenbrock method defined by: -! -! G = 1/(H*gamma(1)) - ode_Jac(t0,Y0) -! T_i = t0 + Alpha(i)*H -! Y_i = Y0 + \sum_{j=1}^{i-1} A(i,j)*K_j -! G * K_i = ode_Fun( T_i, Y_i ) + \sum_{j=1}^S C(i,j)/H * K_j + -! gamma(i)*dF/dT(t0, Y0) -! Y1 = Y0 + \sum_{j=1}^S M(j)*K_j -! -! For details on Rosenbrock methods and their implementation consult: -! E. Hairer and G. Wanner -! "Solving ODEs II. Stiff and differential-algebraic problems". -! Springer series in computational mathematics, Springer-Verlag, 1996. -! The codes contained in the book inspired this implementation. -! -! (C) Adrian Sandu, August 2004 -! Virginia Polytechnic Institute and State University -! Contact: sandu@cs.vt.edu -! This implementation is part of KPP - the Kinetic PreProcessor -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!~~~> INPUT ARGUMENTS: -! -!- Y(NVAR) = vector of initial conditions (at T=Tstart) -!- [Tstart,Tend] = time range of integration -! (if Tstart>Tend the integration is performed backwards in time) -!- RelTol, AbsTol = user precribed accuracy -!- SUBROUTINE ode_Fun( T, Y, Ydot ) = ODE function, -! returns Ydot = Y' = F(T,Y) -!- SUBROUTINE ode_Fun( T, Y, Ydot ) = Jacobian of the ODE function, -! returns Jcb = dF/dY -!- IPAR(1:10) = integer inputs parameters -!- RPAR(1:10) = real inputs parameters -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!~~~> OUTPUT ARGUMENTS: -! -!- Y(NVAR) -> vector of final states (at T->Tend) -!- IPAR(11:20) -> integer output parameters -!- RPAR(11:20) -> real output parameters -!- IERR -> job status upon return -! - succes (positive value) or failure (negative value) - -! = 1 : Success -! = -1 : Improper value for maximal no of steps -! = -2 : Selected Rosenbrock method not implemented -! = -3 : Hmin/Hmax/Hstart must be positive -! = -4 : FacMin/FacMax/FacRej must be positive -! = -5 : Improper tolerance values -! = -6 : No of steps exceeds maximum bound -! = -7 : Step size too small -! = -8 : Matrix is repeatedly singular -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!~~~> INPUT PARAMETERS: -! -! Note: For input parameters equal to zero the default values of the -! corresponding variables are used. -! -! IPAR(1) = 1: F = F(y) Independent of T (AUTONOMOUS) -! = 0: F = F(t,y) Depends on T (NON-AUTONOMOUS) -! IPAR(2) = 0: AbsTol, RelTol are NVAR-dimensional vectors -! = 1: AbsTol, RelTol are scalars -! IPAR(3) -> maximum number of integration steps -! For IPAR(3)=0) the default value of 100000 is used -! -! IPAR(4) -> selection of a particular Rosenbrock method -! = 0 : default method is Rodas3 -! = 1 : method is Ros2 -! = 2 : method is Ros3 -! = 3 : method is Ros4 -! = 4 : method is Rodas3 -! = 5: method is Rodas4 -! -! RPAR(1) -> Hmin, lower bound for the integration step size -! It is strongly recommended to keep Hmin = ZERO -! RPAR(2) -> Hmax, upper bound for the integration step size -! RPAR(3) -> Hstart, starting value for the integration step size -! -! RPAR(4) -> FacMin, lower bound on step decrease factor (default=0.2) -! RPAR(5) -> FacMin,upper bound on step increase factor (default=6) -! RPAR(6) -> FacRej, step decrease factor after multiple rejections -! (default=0.1) -! RPAR(7) -> FacSafe, by which the new step is slightly smaller -! than the predicted value (default=0.9) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!~~~> OUTPUT PARAMETERS: -! -! Note: each call to Rosenbrock adds the corrent no. of fcn calls -! to previous value of IPAR(11), and similar for the other params. -! Set IPAR(11:20) = 0 before call to avoid this accumulation. -! -! IPAR(11) = No. of function calls -! IPAR(12) = No. of jacobian calls -! IPAR(13) = No. of steps -! IPAR(14) = No. of accepted steps -! IPAR(15) = No. of rejected steps (except at the beginning) -! IPAR(16) = No. of LU decompositions -! IPAR(17) = No. of forward/backward substitutions -! IPAR(18) = No. of singular matrix decompositions -! -! RPAR(11) -> Texit, the time corresponding to the -! computed Y upon return -! RPAR(12) -> Hexit, last accepted step before exit -! For multiple restarts, use Hexit as Hstart in the following run -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - INCLUDE 'KPP_ROOT_Parameters.h' - INCLUDE 'KPP_ROOT_Sparse.h' - - KPP_REAL Tstart,Tend - KPP_REAL Y(KPP_NVAR),AbsTol(KPP_NVAR),RelTol(KPP_NVAR) - INTEGER IPAR(20) - KPP_REAL RPAR(20) - INTEGER IERR -!~~~> The method parameters - INTEGER Smax - PARAMETER (Smax = 6) - INTEGER Method, ros_S - KPP_REAL ros_M(Smax), ros_E(Smax) - KPP_REAL ros_A(Smax*(Smax-1)/2), ros_C(Smax*(Smax-1)/2) - KPP_REAL ros_Alpha(Smax), ros_Gamma(Smax), ros_ELO - LOGICAL ros_NewF(Smax) - CHARACTER*12 ros_Name -!~~~> Local variables - KPP_REAL Roundoff,FacMin,FacMax,FacRej,FacSafe - KPP_REAL Hmin, Hmax, Hstart, Hexit - KPP_REAL Texit - INTEGER i, UplimTol, Max_no_steps - LOGICAL Autonomous, VectorTol -!~~~> Statistics on the work performed - INTEGER Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng - COMMON /Statistics/ Nfun,Njac,Nstp,Nacc,Nrej, - & Ndec,Nsol,Nsng -!~~~> Parameters - KPP_REAL ZERO, ONE, DeltaMin - PARAMETER (ZERO = 0.0d0) - PARAMETER (ONE = 1.0d0) - PARAMETER (DeltaMin = 1.0d-5) -!~~~> Functions - EXTERNAL ode_Fun, ode_Jac - KPP_REAL WLAMCH, ros_ErrorNorm - EXTERNAL WLAMCH, ros_ErrorNorm - -!~~~> Initialize statistics - Nfun = IPAR(11) - Njac = IPAR(12) - Nstp = IPAR(13) - Nacc = IPAR(14) - Nrej = IPAR(15) - Ndec = IPAR(16) - Nsol = IPAR(17) - Nsng = IPAR(18) - -!~~~> Autonomous or time dependent ODE. Default is time dependent. - Autonomous = .NOT.(IPAR(1).EQ.0) - -!~~~> For Scalar tolerances (IPAR(2).NE.0) the code uses AbsTol(1) and RelTol(1) -! For Vector tolerances (IPAR(2).EQ.0) the code uses AbsTol(1:NVAR) and RelTol(1:NVAR) - IF (IPAR(2).EQ.0) THEN - VectorTol = .TRUE. - UplimTol = KPP_NVAR - ELSE - VectorTol = .FALSE. - UplimTol = 1 - END IF - -!~~~> The maximum number of steps admitted - IF (IPAR(3).EQ.0) THEN - Max_no_steps = 100000 - ELSEIF (Max_no_steps.GT.0) THEN - Max_no_steps=IPAR(3) - ELSE - WRITE(6,*)'User-selected max no. of steps: IPAR(3)=',IPAR(3) - CALL ros_ErrorMsg(-1,Tstart,ZERO,IERR) - RETURN - END IF - -!~~~> The particular Rosenbrock method chosen - IF (IPAR(4).EQ.0) THEN - Method = 3 - ELSEIF ( (IPAR(4).GE.1).AND.(IPAR(4).LE.5) ) THEN - Method = IPAR(4) - ELSE - WRITE (6,*) 'User-selected Rosenbrock method: IPAR(4)=', Method - CALL ros_ErrorMsg(-2,Tstart,ZERO,IERR) - RETURN - END IF - -!~~~> Unit roundoff (1+Roundoff>1) - Roundoff = WLAMCH('E') - -!~~~> Lower bound on the step size: (positive value) - IF (RPAR(1).EQ.ZERO) THEN - Hmin = ZERO - ELSEIF (RPAR(1).GT.ZERO) THEN - Hmin = RPAR(1) - ELSE - WRITE (6,*) 'User-selected Hmin: RPAR(1)=', RPAR(1) - CALL ros_ErrorMsg(-3,Tstart,ZERO,IERR) - RETURN - END IF -!~~~> Upper bound on the step size: (positive value) - IF (RPAR(2).EQ.ZERO) THEN - Hmax = ABS(Tend-Tstart) - ELSEIF (RPAR(2).GT.ZERO) THEN - Hmax = MIN(ABS(RPAR(2)),ABS(Tend-Tstart)) - ELSE - WRITE (6,*) 'User-selected Hmax: RPAR(2)=', RPAR(2) - CALL ros_ErrorMsg(-3,Tstart,ZERO,IERR) - RETURN - END IF -!~~~> Starting step size: (positive value) - IF (RPAR(3).EQ.ZERO) THEN - Hstart = MAX(Hmin,DeltaMin) - ELSEIF (RPAR(3).GT.ZERO) THEN - Hstart = MIN(ABS(RPAR(3)),ABS(Tend-Tstart)) - ELSE - WRITE (6,*) 'User-selected Hstart: RPAR(3)=', RPAR(3) - CALL ros_ErrorMsg(-3,Tstart,ZERO,IERR) - RETURN - END IF -!~~~> Step size can be changed s.t. FacMin < Hnew/Hexit < FacMax - IF (RPAR(4).EQ.ZERO) THEN - FacMin = 0.2d0 - ELSEIF (RPAR(4).GT.ZERO) THEN - FacMin = RPAR(4) - ELSE - WRITE (6,*) 'User-selected FacMin: RPAR(4)=', RPAR(4) - CALL ros_ErrorMsg(-4,Tstart,ZERO,IERR) - RETURN - END IF - IF (RPAR(5).EQ.ZERO) THEN - FacMax = 6.0d0 - ELSEIF (RPAR(5).GT.ZERO) THEN - FacMax = RPAR(5) - ELSE - WRITE (6,*) 'User-selected FacMax: RPAR(5)=', RPAR(5) - CALL ros_ErrorMsg(-4,Tstart,ZERO,IERR) - RETURN - END IF -!~~~> FacRej: Factor to decrease step after 2 succesive rejections - IF (RPAR(6).EQ.ZERO) THEN - FacRej = 0.1d0 - ELSEIF (RPAR(6).GT.ZERO) THEN - FacRej = RPAR(6) - ELSE - WRITE (6,*) 'User-selected FacRej: RPAR(6)=', RPAR(6) - CALL ros_ErrorMsg(-4,Tstart,ZERO,IERR) - RETURN - END IF -!~~~> FacSafe: Safety Factor in the computation of new step size - IF (RPAR(7).EQ.ZERO) THEN - FacSafe = 0.9d0 - ELSEIF (RPAR(7).GT.ZERO) THEN - FacSafe = RPAR(7) - ELSE - WRITE (6,*) 'User-selected FacSafe: RPAR(7)=', RPAR(7) - CALL ros_ErrorMsg(-4,Tstart,ZERO,IERR) - RETURN - END IF -!~~~> Check if tolerances are reasonable - DO i=1,UplimTol - IF ( (AbsTol(i).LE.ZERO) .OR. (RelTol(i).LE.10.d0*Roundoff) - & .OR. (RelTol(i).GE.1.0d0) ) THEN - WRITE (6,*) ' AbsTol(',i,') = ',AbsTol(i) - WRITE (6,*) ' RelTol(',i,') = ',RelTol(i) - CALL ros_ErrorMsg(-5,Tstart,ZERO,IERR) - RETURN - END IF - END DO - - -!~~~> Initialize the particular Rosenbrock method - - IF (Method .EQ. 1) THEN - CALL Ros2(ros_S, ros_A, ros_C, ros_M, ros_E, - & ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) - ELSEIF (Method .EQ. 2) THEN - CALL Ros3(ros_S, ros_A, ros_C, ros_M, ros_E, - & ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) - ELSEIF (Method .EQ. 3) THEN - CALL Ros4(ros_S, ros_A, ros_C, ros_M, ros_E, - & ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) - ELSEIF (Method .EQ. 4) THEN - CALL Rodas3(ros_S, ros_A, ros_C, ros_M, ros_E, - & ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) - ELSEIF (Method .EQ. 5) THEN - CALL Rodas4(ros_S, ros_A, ros_C, ros_M, ros_E, - & ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) - ELSE - WRITE (6,*) 'Unknown Rosenbrock method: IPAR(4)=', Method - CALL ros_ErrorMsg(-2,Tstart,ZERO,IERR) - RETURN - END IF - -!~~~> CALL Rosenbrock method - CALL RosenbrockIntegrator(Y,Tstart,Tend,Texit, - & AbsTol,RelTol, - & ode_Fun,ode_Jac , -! Rosenbrock method coefficients - & ros_S, ros_M, ros_E, ros_A, ros_C, - & ros_Alpha, ros_Gamma, ros_ELO, ros_NewF, -! Integration parameters - & Autonomous, VectorTol, Max_no_steps, - & Roundoff, Hmin, Hmax, Hstart, Hexit, - & FacMin, FacMax, FacRej, FacSafe, -! Error indicator - & IERR) - - -!~~~> Collect run statistics - IPAR(11) = Nfun - IPAR(12) = Njac - IPAR(13) = Nstp - IPAR(14) = Nacc - IPAR(15) = Nrej - IPAR(16) = Ndec - IPAR(17) = Nsol - IPAR(18) = Nsng -!~~~> Last T and H - RPAR(11) = Texit - RPAR(12) = Hexit - - RETURN - END ! SUBROUTINE Rosenbrock - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE RosenbrockIntegrator(Y,Tstart,Tend,T, - & AbsTol,RelTol, - & ode_Fun,ode_Jac , -!~~~> Rosenbrock method coefficients - & ros_S, ros_M, ros_E, ros_A, ros_C, - & ros_Alpha, ros_Gamma, ros_ELO, ros_NewF, -!~~~> Integration parameters - & Autonomous, VectorTol, Max_no_steps, - & Roundoff, Hmin, Hmax, Hstart, Hexit, - & FacMin, FacMax, FacRej, FacSafe, -!~~~> Error indicator - & IERR) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Template for the implementation of a generic Rosenbrock method -! defined by ros_S (no of stages) -! and its coefficients ros_{A,C,M,E,Alpha,Gamma} -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - INCLUDE 'KPP_ROOT_Parameters.h' - INCLUDE 'KPP_ROOT_Sparse.h' - -!~~~> Input: the initial condition at Tstart; Output: the solution at T - KPP_REAL Y(KPP_NVAR) -!~~~> Input: integration interval - KPP_REAL Tstart,Tend -!~~~> Output: time at which the solution is returned (T=Tend if success) - KPP_REAL T -!~~~> Input: tolerances - KPP_REAL AbsTol(KPP_NVAR), RelTol(KPP_NVAR) -!~~~> Input: ode function and its Jacobian - EXTERNAL ode_Fun, ode_Jac -!~~~> Input: The Rosenbrock method parameters - INTEGER ros_S - KPP_REAL ros_M(ros_S), ros_E(ros_S) - KPP_REAL ros_A(ros_S*(ros_S-1)/2), ros_C(ros_S*(ros_S-1)/2) - KPP_REAL ros_Alpha(ros_S), ros_Gamma(ros_S), ros_ELO - LOGICAL ros_NewF(ros_S) -!~~~> Input: integration parameters - LOGICAL Autonomous, VectorTol - KPP_REAL Hstart, Hmin, Hmax - INTEGER Max_no_steps - KPP_REAL Roundoff, FacMin, FacMax, FacRej, FacSafe -!~~~> Output: last accepted step - KPP_REAL Hexit -!~~~> Output: Error indicator - INTEGER IERR -! ~~~~ Local variables - KPP_REAL Ynew(KPP_NVAR), Fcn0(KPP_NVAR), Fcn(KPP_NVAR), - & K(KPP_NVAR*ros_S), dFdT(KPP_NVAR), - & Jac0(KPP_LU_NONZERO), Ghimj(KPP_LU_NONZERO) - KPP_REAL H, Hnew, HC, HG, Fac, Tau - KPP_REAL Err, Yerr(KPP_NVAR) - INTEGER Pivot(KPP_NVAR), Direction, ioffset, j, istage - LOGICAL RejectLastH, RejectMoreH, Singular -!~~~> Local parameters - KPP_REAL ZERO, ONE, DeltaMin - PARAMETER (ZERO = 0.0d0) - PARAMETER (ONE = 1.0d0) - PARAMETER (DeltaMin = 1.0d-5) -!~~~> Locally called functions - KPP_REAL WLAMCH, ros_ErrorNorm - EXTERNAL WLAMCH, ros_ErrorNorm -!~~~> Statistics on the work performed - INTEGER Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng - COMMON /Statistics/ Nfun,Njac,Nstp,Nacc,Nrej, - & Ndec,Nsol,Nsng -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - -!~~~> INITIAL PREPARATIONS - T = Tstart - Hexit = 0.0d0 - H = MIN(Hstart,Hmax) - IF (ABS(H).LE.10.d0*Roundoff) THEN - H = DeltaMin - END IF - - IF (Tend .GE. Tstart) THEN - Direction = +1 - ELSE - Direction = -1 - END IF - - RejectLastH=.FALSE. - RejectMoreH=.FALSE. - -!~~~> Time loop begins below - - DO WHILE ( (Direction.GT.0).AND.((T-Tend)+Roundoff.LE.ZERO) - & .OR. (Direction.LT.0).AND.((Tend-T)+Roundoff.LE.ZERO) ) - - IF ( Nstp.GT.Max_no_steps ) THEN ! Too many steps - CALL ros_ErrorMsg(-6,T,H,IERR) - RETURN - END IF - IF ( ((T+0.1d0*H).EQ.T).OR.(H.LE.Roundoff) ) THEN ! Step size too small - CALL ros_ErrorMsg(-7,T,H,IERR) - RETURN - END IF - -!~~~> Limit H if necessary to avoid going beyond Tend - Hexit = H - H = MIN(H,ABS(Tend-T)) - -!~~~> Compute the function at current time - CALL ode_Fun(T,Y,Fcn0) - -!~~~> Compute the function derivative with respect to T - IF (.NOT.Autonomous) THEN - CALL ros_FunTimeDerivative ( T, Roundoff, Y, - & Fcn0, ode_Fun, dFdT ) - END IF - -!~~~> Compute the Jacobian at current time - CALL ode_Jac(T,Y,Jac0) - -!~~~> Repeat step calculation until current step accepted - DO WHILE (.TRUE.) ! WHILE STEP NOT ACCEPTED - - - CALL ros_PrepareMatrix(H,Direction,ros_Gamma(1), - & Jac0,Ghimj,Pivot,Singular) - IF (Singular) THEN ! More than 5 consecutive failed decompositions - CALL ros_ErrorMsg(-8,T,H,IERR) - RETURN - END IF - -!~~~> Compute the stages - DO istage = 1, ros_S - - ! Current istage offset. Current istage vector is K(ioffset+1:ioffset+KPP_NVAR) - ioffset = KPP_NVAR*(istage-1) - - ! For the 1st istage the function has been computed previously - IF ( istage.EQ.1 ) THEN - CALL WCOPY(KPP_NVAR,Fcn0,1,Fcn,1) - ! istage>1 and a new function evaluation is needed at the current istage - ELSEIF ( ros_NewF(istage) ) THEN - CALL WCOPY(KPP_NVAR,Y,1,Ynew,1) - DO j = 1, istage-1 - CALL WAXPY(KPP_NVAR,ros_A((istage-1)*(istage-2)/2+j), - & K(KPP_NVAR*(j-1)+1),1,Ynew,1) - END DO - Tau = T + ros_Alpha(istage)*Direction*H - CALL ode_Fun(Tau,Ynew,Fcn) - END IF ! if istage.EQ.1 elseif ros_NewF(istage) - CALL WCOPY(KPP_NVAR,Fcn,1,K(ioffset+1),1) - DO j = 1, istage-1 - HC = ros_C((istage-1)*(istage-2)/2+j)/(Direction*H) - CALL WAXPY(KPP_NVAR,HC,K(KPP_NVAR*(j-1)+1),1,K(ioffset+1),1) - END DO - IF ((.NOT. Autonomous).AND.(ros_Gamma(istage).NE.ZERO)) THEN - HG = Direction*H*ros_Gamma(istage) - CALL WAXPY(KPP_NVAR,HG,dFdT,1,K(ioffset+1),1) - END IF - CALL SolveTemplate(Ghimj, Pivot, K(ioffset+1)) - - END DO ! istage - - -!~~~> Compute the new solution - CALL WCOPY(KPP_NVAR,Y,1,Ynew,1) - DO j=1,ros_S - CALL WAXPY(KPP_NVAR,ros_M(j),K(KPP_NVAR*(j-1)+1),1,Ynew,1) - END DO - -!~~~> Compute the error estimation - CALL WSCAL(KPP_NVAR,ZERO,Yerr,1) - DO j=1,ros_S - CALL WAXPY(KPP_NVAR,ros_E(j),K(KPP_NVAR*(j-1)+1),1,Yerr,1) - END DO - Err = ros_ErrorNorm ( Y, Ynew, Yerr, AbsTol, RelTol, VectorTol ) - -!~~~> New step size is bounded by FacMin <= Hnew/H <= FacMax - Fac = MIN(FacMax,MAX(FacMin,FacSafe/Err**(ONE/ros_ELO))) - Hnew = H*Fac - -!~~~> Check the error magnitude and adjust step size - Nstp = Nstp+1 - IF ( (Err.LE.ONE).OR.(H.LE.Hmin) ) THEN !~~~> Accept step - Nacc = Nacc+1 - CALL WCOPY(KPP_NVAR,Ynew,1,Y,1) - T = T + Direction*H - Hnew = MAX(Hmin,MIN(Hnew,Hmax)) - IF (RejectLastH) THEN ! No step size increase after a rejected step - Hnew = MIN(Hnew,H) - END IF - RejectLastH = .FALSE. - RejectMoreH = .FALSE. - H = Hnew - GOTO 101 ! EXIT THE LOOP: WHILE STEP NOT ACCEPTED - ELSE !~~~> Reject step - IF (RejectMoreH) THEN - Hnew=H*FacRej - END IF - RejectMoreH = RejectLastH - RejectLastH = .TRUE. - H = Hnew - IF (Nacc.GE.1) THEN - Nrej = Nrej+1 - END IF - END IF ! Err <= 1 - - END DO ! LOOP: WHILE STEP NOT ACCEPTED - -101 CONTINUE - - END DO ! Time loop - -!~~~> Succesful exit - IERR = 1 !~~~> The integration was successful - - RETURN - END ! SUBROUTINE RosenbrockIntegrator - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - KPP_REAL FUNCTION ros_ErrorNorm ( Y, Ynew, Yerr, - & AbsTol, RelTol, VectorTol ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Computes the "scaled norm" of the error vector Yerr -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - INCLUDE 'KPP_ROOT_Parameters.h' - -! Input arguments - KPP_REAL Y(KPP_NVAR), Ynew(KPP_NVAR), Yerr(KPP_NVAR) - KPP_REAL AbsTol(KPP_NVAR), RelTol(KPP_NVAR) - LOGICAL VectorTol -! Local variables - KPP_REAL Err, Scale, Ymax, ZERO - INTEGER i - PARAMETER (ZERO = 0.0d0) - - Err = ZERO - DO i=1,KPP_NVAR - Ymax = MAX(ABS(Y(i)),ABS(Ynew(i))) - IF (VectorTol) THEN - Scale = AbsTol(i)+RelTol(i)*Ymax - ELSE - Scale = AbsTol(1)+RelTol(1)*Ymax - END IF - Err = Err+(Yerr(i)/Scale)**2 - END DO - Err = SQRT(Err/KPP_NVAR) - - ros_ErrorNorm = Err - - RETURN - END ! FUNCTION ros_ErrorNorm - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_FunTimeDerivative ( T, Roundoff, Y, - & Fcn0, ode_Fun, dFdT ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> The time partial derivative of the function by finite differences -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - INCLUDE 'KPP_ROOT_Parameters.h' - -!~~~> Input arguments - KPP_REAL T, Roundoff, Y(KPP_NVAR), Fcn0(KPP_NVAR) - EXTERNAL ode_Fun -!~~~> Output arguments - KPP_REAL dFdT(KPP_NVAR) -!~~~> Global variables - INTEGER Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng - COMMON /Statistics/ Nfun,Njac,Nstp,Nacc,Nrej, - & Ndec,Nsol,Nsng -!~~~> Local variables - KPP_REAL Delta, DeltaMin, ONE - PARAMETER ( DeltaMin = 1.0d-6 ) - PARAMETER ( ONE = 1.0d0 ) - - Delta = SQRT(Roundoff)*MAX(DeltaMin,ABS(T)) - CALL ode_Fun(T+Delta,Y,dFdT) - CALL WAXPY(KPP_NVAR,(-ONE),Fcn0,1,dFdT,1) - CALL WSCAL(KPP_NVAR,(ONE/Delta),dFdT,1) - - RETURN - END ! SUBROUTINE ros_FunTimeDerivative - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_PrepareMatrix ( H, Direction, gam, - & Jac0, Ghimj, Pivot, Singular ) -! --- --- --- --- --- --- --- --- --- --- --- --- --- -! Prepares the LHS matrix for stage calculations -! 1. Construct Ghimj = 1/(H*ham) - Jac0 -! "(Gamma H) Inverse Minus Jacobian" -! 2. Repeat LU decomposition of Ghimj until successful. -! -half the step size if LU decomposition fails and retry -! -exit after 5 consecutive fails -! --- --- --- --- --- --- --- --- --- --- --- --- --- - IMPLICIT NONE - INCLUDE 'KPP_ROOT_Parameters.h' - INCLUDE 'KPP_ROOT_Sparse.h' - -!~~~> Input arguments - KPP_REAL gam, Jac0(KPP_LU_NONZERO) - INTEGER Direction -!~~~> Output arguments - KPP_REAL Ghimj(KPP_LU_NONZERO) - LOGICAL Singular - INTEGER Pivot(KPP_NVAR) -!~~~> Inout arguments - KPP_REAL H ! step size is decreased when LU fails -!~~~> Global variables - INTEGER Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng - COMMON /Statistics/ Nfun,Njac,Nstp,Nacc,Nrej, - & Ndec,Nsol,Nsng -!~~~> Local variables - INTEGER i, ising, Nconsecutive - KPP_REAL ghinv, ONE, HALF - PARAMETER ( ONE = 1.0d0 ) - PARAMETER ( HALF = 0.5d0 ) - - Nconsecutive = 0 - Singular = .TRUE. - - DO WHILE (Singular) - -!~~~> Construct Ghimj = 1/(H*ham) - Jac0 - CALL WCOPY(KPP_LU_NONZERO,Jac0,1,Ghimj,1) - CALL WSCAL(KPP_LU_NONZERO,(-ONE),Ghimj,1) - ghinv = ONE/(Direction*H*gam) - DO i=1,KPP_NVAR - Ghimj(LU_DIAG(i)) = Ghimj(LU_DIAG(i))+ghinv - END DO -!~~~> Compute LU decomposition - CALL DecompTemplate( Ghimj, Pivot, ising ) - IF (ising .EQ. 0) THEN -!~~~> If successful done - Singular = .FALSE. - ELSE ! ising .ne. 0 -!~~~> If unsuccessful half the step size; if 5 consecutive fails then return - Nsng = Nsng+1 - Nconsecutive = Nconsecutive+1 - Singular = .TRUE. - PRINT*,'Warning: LU Decomposition returned ising = ',ising - IF (Nconsecutive.LE.5) THEN ! Less than 5 consecutive failed decompositions - H = H*HALF - ELSE ! More than 5 consecutive failed decompositions - RETURN - END IF ! Nconsecutive - END IF ! ising - - END DO ! WHILE Singular - - RETURN - END ! SUBROUTINE ros_PrepareMatrix - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE ros_ErrorMsg(Code,T,H,IERR) - KPP_REAL T, H - INTEGER IERR, Code - - IERR = Code - WRITE(6,*) - & 'Forced exit from Rosenbrock due to the following error:' - - IF (Code .EQ. -1) THEN - WRITE(6,*) '--> Improper value for maximal no of steps' - ELSEIF (Code .EQ. -2) THEN - WRITE(6,*) '--> Selected Rosenbrock method not implemented' - ELSEIF (Code .EQ. -3) THEN - WRITE(6,*) '--> Hmin/Hmax/Hstart must be positive' - ELSEIF (Code .EQ. -4) THEN - WRITE(6,*) '--> FacMin/FacMax/FacRej must be positive' - ELSEIF (Code .EQ. -5) THEN - WRITE(6,*) '--> Improper tolerance values' - ELSEIF (Code .EQ. -6) THEN - WRITE(6,*) '--> No of steps exceeds maximum bound' - ELSEIF (Code .EQ. -7) THEN - WRITE(6,*) '--> Step size too small: T + 10*H = T', - & ' or H < Roundoff' - ELSEIF (Code .EQ. -8) THEN - WRITE(6,*) '--> Matrix is repeatedly singular' - ELSE - WRITE(6,102) 'Unknown Error code: ',Code - END IF - - 102 FORMAT(' ',A,I4) - WRITE(6,103) T, H - - 103 FORMAT(' T=',E15.7,' and H=',E15.7) - - RETURN - END - - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Ros2 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha, - & ros_Gamma,ros_NewF,ros_ELO,ros_Name) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! --- AN L-STABLE METHOD, 2 stages, order 2 -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - INTEGER S - PARAMETER (S=2) - INTEGER ros_S - KPP_REAL ros_M(S), ros_E(S), ros_A(S*(S-1)/2), ros_C(S*(S-1)/2) - KPP_REAL ros_Alpha(S), ros_Gamma(S), ros_ELO - LOGICAL ros_NewF(S) - CHARACTER*12 ros_Name - DOUBLE PRECISION g - - g = 1.0d0 + 1.0d0/SQRT(2.0d0) - -!~~~> Name of the method - ros_Name = 'ROS-2' -!~~~> Number of stages - ros_S = 2 - -!~~~> The coefficient matrices A and C are strictly lower triangular. -! The lower triangular (subdiagonal) elements are stored in row-wise order: -! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. -! The general mapping formula is: -! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) -! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) - - ros_A(1) = (1.d0)/g - ros_C(1) = (-2.d0)/g -!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) -! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) - ros_NewF(1) = .TRUE. - ros_NewF(2) = .TRUE. -!~~~> M_i = Coefficients for new step solution - ros_M(1)= (3.d0)/(2.d0*g) - ros_M(2)= (1.d0)/(2.d0*g) -! E_i = Coefficients for error estimator - ros_E(1) = 1.d0/(2.d0*g) - ros_E(2) = 1.d0/(2.d0*g) -!~~~> ros_ELO = estimator of local order - the minimum between the -! main and the embedded scheme orders plus one - ros_ELO = 2.0d0 -!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) - ros_Alpha(1) = 0.0d0 - ros_Alpha(2) = 1.0d0 -!~~~> Gamma_i = \sum_j gamma_{i,j} - ros_Gamma(1) = g - ros_Gamma(2) =-g - - RETURN - END ! SUBROUTINE Ros2 - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Ros3 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha, - & ros_Gamma,ros_NewF,ros_ELO,ros_Name) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! --- AN L-STABLE METHOD, 3 stages, order 3, 2 function evaluations -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - INTEGER S - PARAMETER (S=3) - INTEGER ros_S - KPP_REAL ros_M(S), ros_E(S), ros_A(S*(S-1)/2), ros_C(S*(S-1)/2) - KPP_REAL ros_Alpha(S), ros_Gamma(S), ros_ELO - LOGICAL ros_NewF(S) - CHARACTER*12 ros_Name - -!~~~> Name of the method - ros_Name = 'ROS-3' -!~~~> Number of stages - ros_S = 3 - -!~~~> The coefficient matrices A and C are strictly lower triangular. -! The lower triangular (subdiagonal) elements are stored in row-wise order: -! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. -! The general mapping formula is: -! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) -! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) - - ros_A(1)= 1.d0 - ros_A(2)= 1.d0 - ros_A(3)= 0.d0 - - ros_C(1) = -0.10156171083877702091975600115545d+01 - ros_C(2) = 0.40759956452537699824805835358067d+01 - ros_C(3) = 0.92076794298330791242156818474003d+01 -!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) -! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) - ros_NewF(1) = .TRUE. - ros_NewF(2) = .TRUE. - ros_NewF(3) = .FALSE. -!~~~> M_i = Coefficients for new step solution - ros_M(1) = 0.1d+01 - ros_M(2) = 0.61697947043828245592553615689730d+01 - ros_M(3) = -0.42772256543218573326238373806514d+00 -! E_i = Coefficients for error estimator - ros_E(1) = 0.5d+00 - ros_E(2) = -0.29079558716805469821718236208017d+01 - ros_E(3) = 0.22354069897811569627360909276199d+00 -!~~~> ros_ELO = estimator of local order - the minimum between the -! main and the embedded scheme orders plus 1 - ros_ELO = 3.0d0 -!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) - ros_Alpha(1)= 0.0d+00 - ros_Alpha(2)= 0.43586652150845899941601945119356d+00 - ros_Alpha(3)= 0.43586652150845899941601945119356d+00 -!~~~> Gamma_i = \sum_j gamma_{i,j} - ros_Gamma(1)= 0.43586652150845899941601945119356d+00 - ros_Gamma(2)= 0.24291996454816804366592249683314d+00 - ros_Gamma(3)= 0.21851380027664058511513169485832d+01 - RETURN - END ! SUBROUTINE Ros3 - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Ros4 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha, - & ros_Gamma,ros_NewF,ros_ELO,ros_Name) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! L-STABLE ROSENBROCK METHOD OF ORDER 4, WITH 4 STAGES -! L-STABLE EMBEDDED ROSENBROCK METHOD OF ORDER 3 -! -! E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL -! EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS. -! SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS, -! SPRINGER-VERLAG (1990) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - INTEGER S - PARAMETER (S=4) - INTEGER ros_S - KPP_REAL ros_M(S), ros_E(S), ros_A(S*(S-1)/2), ros_C(S*(S-1)/2) - KPP_REAL ros_Alpha(S), ros_Gamma(S), ros_ELO - LOGICAL ros_NewF(S) - CHARACTER*12 ros_Name - -!~~~> Name of the method - ros_Name = 'ROS-4' -!~~~> Number of stages - ros_S = 4 - -!~~~> The coefficient matrices A and C are strictly lower triangular. -! The lower triangular (subdiagonal) elements are stored in row-wise order: -! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. -! The general mapping formula is: -! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) -! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) - - ros_A(1) = 0.2000000000000000d+01 - ros_A(2) = 0.1867943637803922d+01 - ros_A(3) = 0.2344449711399156d+00 - ros_A(4) = ros_A(2) - ros_A(5) = ros_A(3) - ros_A(6) = 0.0D0 - - ros_C(1) =-0.7137615036412310d+01 - ros_C(2) = 0.2580708087951457d+01 - ros_C(3) = 0.6515950076447975d+00 - ros_C(4) =-0.2137148994382534d+01 - ros_C(5) =-0.3214669691237626d+00 - ros_C(6) =-0.6949742501781779d+00 -!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) -! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) - ros_NewF(1) = .TRUE. - ros_NewF(2) = .TRUE. - ros_NewF(3) = .TRUE. - ros_NewF(4) = .FALSE. -!~~~> M_i = Coefficients for new step solution - ros_M(1) = 0.2255570073418735d+01 - ros_M(2) = 0.2870493262186792d+00 - ros_M(3) = 0.4353179431840180d+00 - ros_M(4) = 0.1093502252409163d+01 -!~~~> E_i = Coefficients for error estimator - ros_E(1) =-0.2815431932141155d+00 - ros_E(2) =-0.7276199124938920d-01 - ros_E(3) =-0.1082196201495311d+00 - ros_E(4) =-0.1093502252409163d+01 -!~~~> ros_ELO = estimator of local order - the minimum between the -! main and the embedded scheme orders plus 1 - ros_ELO = 4.0d0 -!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) - ros_Alpha(1) = 0.D0 - ros_Alpha(2) = 0.1145640000000000d+01 - ros_Alpha(3) = 0.6552168638155900d+00 - ros_Alpha(4) = ros_Alpha(3) -!~~~> Gamma_i = \sum_j gamma_{i,j} - ros_Gamma(1) = 0.5728200000000000d+00 - ros_Gamma(2) =-0.1769193891319233d+01 - ros_Gamma(3) = 0.7592633437920482d+00 - ros_Gamma(4) =-0.1049021087100450d+00 - RETURN - END ! SUBROUTINE Ros4 - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Rodas3 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha, - & ros_Gamma,ros_NewF,ros_ELO,ros_Name) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! --- A STIFFLY-STABLE METHOD, 4 stages, order 3 -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - INTEGER S - PARAMETER (S=4) - INTEGER ros_S - KPP_REAL ros_M(S), ros_E(S), ros_A(S*(S-1)/2), ros_C(S*(S-1)/2) - KPP_REAL ros_Alpha(S), ros_Gamma(S), ros_ELO - LOGICAL ros_NewF(S) - CHARACTER*12 ros_Name - -!~~~> Name of the method - ros_Name = 'RODAS-3' -!~~~> Number of stages - ros_S = 4 - -!~~~> The coefficient matrices A and C are strictly lower triangular. -! The lower triangular (subdiagonal) elements are stored in row-wise order: -! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. -! The general mapping formula is: -! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) -! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) - - ros_A(1) = 0.0d+00 - ros_A(2) = 2.0d+00 - ros_A(3) = 0.0d+00 - ros_A(4) = 2.0d+00 - ros_A(5) = 0.0d+00 - ros_A(6) = 1.0d+00 - - ros_C(1) = 4.0d+00 - ros_C(2) = 1.0d+00 - ros_C(3) =-1.0d+00 - ros_C(4) = 1.0d+00 - ros_C(5) =-1.0d+00 - ros_C(6) =-(8.0d+00/3.0d+00) - -!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) -! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) - ros_NewF(1) = .TRUE. - ros_NewF(2) = .FALSE. - ros_NewF(3) = .TRUE. - ros_NewF(4) = .TRUE. -!~~~> M_i = Coefficients for new step solution - ros_M(1) = 2.0d+00 - ros_M(2) = 0.0d+00 - ros_M(3) = 1.0d+00 - ros_M(4) = 1.0d+00 -!~~~> E_i = Coefficients for error estimator - ros_E(1) = 0.0d+00 - ros_E(2) = 0.0d+00 - ros_E(3) = 0.0d+00 - ros_E(4) = 1.0d+00 -!~~~> ros_ELO = estimator of local order - the minimum between the -! main and the embedded scheme orders plus 1 - ros_ELO = 3.0d+00 -!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) - ros_Alpha(1) = 0.0d+00 - ros_Alpha(2) = 0.0d+00 - ros_Alpha(3) = 1.0d+00 - ros_Alpha(4) = 1.0d+00 -!~~~> Gamma_i = \sum_j gamma_{i,j} - ros_Gamma(1) = 0.5d+00 - ros_Gamma(2) = 1.5d+00 - ros_Gamma(3) = 0.0d+00 - ros_Gamma(4) = 0.0d+00 - RETURN - END ! SUBROUTINE Rodas3 - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Rodas4 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha, - & ros_Gamma,ros_NewF,ros_ELO,ros_Name) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! STIFFLY-STABLE ROSENBROCK METHOD OF ORDER 4, WITH 6 STAGES -! -! E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL -! EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS. -! SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS, -! SPRINGER-VERLAG (1996) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - INTEGER S - PARAMETER (S=6) - INTEGER ros_S - KPP_REAL ros_M(S), ros_E(S), ros_A(S*(S-1)/2), ros_C(S*(S-1)/2) - KPP_REAL ros_Alpha(S), ros_Gamma(S), ros_ELO - LOGICAL ros_NewF(S) - CHARACTER*12 ros_Name - -!~~~> Name of the method - ros_Name = 'RODAS-4' -!~~~> Number of stages - ros_S = 6 - -!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) - ros_Alpha(1) = 0.000d0 - ros_Alpha(2) = 0.386d0 - ros_Alpha(3) = 0.210d0 - ros_Alpha(4) = 0.630d0 - ros_Alpha(5) = 1.000d0 - ros_Alpha(6) = 1.000d0 - -!~~~> Gamma_i = \sum_j gamma_{i,j} - ros_Gamma(1) = 0.2500000000000000d+00 - ros_Gamma(2) =-0.1043000000000000d+00 - ros_Gamma(3) = 0.1035000000000000d+00 - ros_Gamma(4) =-0.3620000000000023d-01 - ros_Gamma(5) = 0.0d0 - ros_Gamma(6) = 0.0d0 - -!~~~> The coefficient matrices A and C are strictly lower triangular. -! The lower triangular (subdiagonal) elements are stored in row-wise order: -! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. -! The general mapping formula is: A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) -! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) - - ros_A(1) = 0.1544000000000000d+01 - ros_A(2) = 0.9466785280815826d+00 - ros_A(3) = 0.2557011698983284d+00 - ros_A(4) = 0.3314825187068521d+01 - ros_A(5) = 0.2896124015972201d+01 - ros_A(6) = 0.9986419139977817d+00 - ros_A(7) = 0.1221224509226641d+01 - ros_A(8) = 0.6019134481288629d+01 - ros_A(9) = 0.1253708332932087d+02 - ros_A(10) =-0.6878860361058950d+00 - ros_A(11) = ros_A(7) - ros_A(12) = ros_A(8) - ros_A(13) = ros_A(9) - ros_A(14) = ros_A(10) - ros_A(15) = 1.0d+00 - - ros_C(1) =-0.5668800000000000d+01 - ros_C(2) =-0.2430093356833875d+01 - ros_C(3) =-0.2063599157091915d+00 - ros_C(4) =-0.1073529058151375d+00 - ros_C(5) =-0.9594562251023355d+01 - ros_C(6) =-0.2047028614809616d+02 - ros_C(7) = 0.7496443313967647d+01 - ros_C(8) =-0.1024680431464352d+02 - ros_C(9) =-0.3399990352819905d+02 - ros_C(10) = 0.1170890893206160d+02 - ros_C(11) = 0.8083246795921522d+01 - ros_C(12) =-0.7981132988064893d+01 - ros_C(13) =-0.3152159432874371d+02 - ros_C(14) = 0.1631930543123136d+02 - ros_C(15) =-0.6058818238834054d+01 - -!~~~> M_i = Coefficients for new step solution - ros_M(1) = ros_A(7) - ros_M(2) = ros_A(8) - ros_M(3) = ros_A(9) - ros_M(4) = ros_A(10) - ros_M(5) = 1.0d+00 - ros_M(6) = 1.0d+00 - -!~~~> E_i = Coefficients for error estimator - ros_E(1) = 0.0d+00 - ros_E(2) = 0.0d+00 - ros_E(3) = 0.0d+00 - ros_E(4) = 0.0d+00 - ros_E(5) = 0.0d+00 - ros_E(6) = 1.0d+00 - -!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) -! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) - ros_NewF(1) = .TRUE. - ros_NewF(2) = .TRUE. - ros_NewF(3) = .TRUE. - ros_NewF(4) = .TRUE. - ros_NewF(5) = .TRUE. - ros_NewF(6) = .TRUE. - -!~~~> ros_ELO = estimator of local order - the minimum between the -! main and the embedded scheme orders plus 1 - ros_ELO = 4.0d0 - - RETURN - END ! SUBROUTINE Rodas4 - - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE DecompTemplate( A, Pivot, ising ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Template for the LU decomposition -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - INCLUDE 'KPP_ROOT_Parameters.h' - INCLUDE 'KPP_ROOT_Global.h' -!~~~> Inout variables - KPP_REAL A(KPP_LU_NONZERO) -!~~~> Output variables - INTEGER Pivot(KPP_NVAR), ising -!~~~> Collect statistics - INTEGER Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng - COMMON /Statistics/ Nfun,Njac,Nstp,Nacc,Nrej, - & Ndec,Nsol,Nsng - - CALL KppDecomp ( A, ising ) -!~~~> Note: for a full matrix use Lapack: -! CALL DGETRF( KPP_NVAR, KPP_NVAR, A, KPP_NVAR, Pivot, ising ) - - Ndec = Ndec + 1 - - END ! SUBROUTINE DecompTemplate - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SolveTemplate( A, Pivot, b ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Template for the forward/backward substitution (using pre-computed LU decomposition) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - INCLUDE 'KPP_ROOT_Parameters.h' - INCLUDE 'KPP_ROOT_Global.h' -!~~~> Input variables - KPP_REAL A(KPP_LU_NONZERO) - INTEGER Pivot(KPP_NVAR) -!~~~> InOut variables - KPP_REAL b(KPP_NVAR) -!~~~> Collect statistics - INTEGER Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng - COMMON /Statistics/ Nfun,Njac,Nstp,Nacc,Nrej, - & Ndec,Nsol,Nsng - - CALL KppSolve( A, b ) -!~~~> Note: for a full matrix use Lapack: -! NRHS = 1 -! CALL DGETRS( 'N', KPP_NVAR , NRHS, A, KPP_NVAR, Pivot, b, KPP_NVAR, INFO ) - - Nsol = Nsol+1 - - END ! SUBROUTINE SolveTemplate - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE FunTemplate( T, Y, Ydot ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Template for the ODE function call. -! Updates the rate coefficients (and possibly the fixed species) at each call -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - INCLUDE 'KPP_ROOT_Parameters.h' - INCLUDE 'KPP_ROOT_Global.h' -!~~~> Input variables - KPP_REAL T, Y(KPP_NVAR) -!~~~> Output variables - KPP_REAL Ydot(KPP_NVAR) -!~~~> Local variables - KPP_REAL Told -!~~~> Collect statistics - INTEGER Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng - COMMON /Statistics/ Nfun,Njac,Nstp,Nacc,Nrej, - & Ndec,Nsol,Nsng - - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Fun( Y, FIX, RCONST, Ydot ) - TIME = Told - - Nfun = Nfun+1 - - RETURN - END ! SUBROUTINE FunTemplate - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE JacTemplate( T, Y, Jcb ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Template for the ODE Jacobian call. -! Updates the rate coefficients (and possibly the fixed species) at each call -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - INCLUDE 'KPP_ROOT_Parameters.h' - INCLUDE 'KPP_ROOT_Global.h' -!~~~> Input variables - KPP_REAL T, Y(KPP_NVAR) -!~~~> Output variables - KPP_REAL Jcb(KPP_LU_NONZERO) -!~~~> Local variables - KPP_REAL Told -!~~~> Collect statistics - INTEGER Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng - COMMON /Statistics/ Nfun,Njac,Nstp,Nacc,Nrej, - & Ndec,Nsol,Nsng - - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Jac_SP( Y, FIX, RCONST, Jcb ) - TIME = Told - - Njac = Njac+1 - - RETURN - END ! SUBROUTINE JacTemplate - diff --git a/boxmox/int/rosenbrock.m b/boxmox/int/rosenbrock.m deleted file mode 100644 index 94ec63d20317205cd57d2f0f9d124525de48ffdf..0000000000000000000000000000000000000000 --- a/boxmox/int/rosenbrock.m +++ /dev/null @@ -1,986 +0,0 @@ -function [T, Y, RCNTRL, ICNTRL, RSTAT, ISTAT] = ... - Rosenbrock(Function, Tspan, Y0, Options, RCNTRL, ICNTRL) -%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -% Rosenbrock - Implementation of several Rosenbrock methods: -% * Ros2 -% * Ros3 -% * Ros4 -% * Rodas3 -% * Rodas4 -% -% Solves the system y'=F(t,y) using a Rosenbrock method defined by: -% -% G = 1/(H*gamma(1)) - Jac(t0,Y0) -% T_i = t0 + Alpha(i)*H -% Y_i = Y0 + \sum_{j=1}^{i-1} A(i,j)*K_j -% G * K_i = Fun( T_i, Y_i ) + \sum_{j=1}^S C(i,j)/H * K_j + -% gamma(i)*dF/dT(t0, Y0) -% Y1 = Y0 + \sum_{j=1}^S M(j)*K_j -% -% For details on Rosenbrock methods and their implementation consult: -% E. Hairer and G. Wanner -% "Solving ODEs II. Stiff and differential-algebraic problems". -% Springer series in computational mathematics, Springer-Verlag, 1996. -% The codes contained in the book inspired this implementation. -% -% MATLAB implementation (C) John C. Linford (jlinford@vt.edu). -% Virginia Polytechnic Institute and State University -% November, 2009 -% -% Based on the Fortran90 implementation (C) Adrian Sandu, August 2004 -% and revised by Philipp Miehe and Adrian Sandu, May 2006. -% Virginia Polytechnic Institute and State University -% Contact: sandu@cs.vt.edu -% -%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -% Input Arguments : -% The first four arguments are similar to the input arguments of -% MATLAB's ODE solvers -% Function - A function handle for the ODE function -% Tspan - The time space to integrate -% Y0 - Initial value -% Options - ODE solver options created by odeset(): -% AbsTol, InitialStep, Jacobian, MaxStep, and RelTol -% are considered. Other options are ignored. -% 'Jacobian' must be set. -% RCNTRL - real value input parameters (explained below) -% ICNTRL - integer input parameters (explained below) -%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -% Output Arguments: -% The first two arguments are similar to the output arguments of -% MATLAB's ODE solvers -% T - A vector of final integration times. -% Y - A matrix of function values. Y(T(i),:) is the value of -% the function at the ith output time. -% RCNTRL - real value input parameters (explained below) -% ICNTRL - integer input parameters (explained below) -% RSTAT - real output parameters (explained below) -% ISTAT - integer output parameters (explained below) -%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -% -% RCNTRL and ICNTRL on input and output: -% -% Note: For input parameters equal to zero the default values of the -% corresponding variables are used. -% -% ICNTRL(1) = 1: F = F(y) Independent of T (AUTONOMOUS) -% = 0: F = F(t,y) Depends on T (NON-AUTONOMOUS) -% -% ICNTRL(2) = 0: AbsTol, RelTol are N-dimensional vectors -% = 1: AbsTol, RelTol are scalars -% -% ICNTRL(3) -> selection of a particular Rosenbrock method -% = 0 : Rodas3 (default) -% = 1 : Ros2 -% = 2 : Ros3 -% = 3 : Ros4 -% = 4 : Rodas3 -% = 5 : Rodas4 -% -% ICNTRL(4) -> maximum number of integration steps -% For ICNTRL(4)=0) the default value of 100000 is used -% -% RCNTRL(1) -> Hmin, lower bound for the integration step size -% It is strongly recommended to keep Hmin = ZERO -% RCNTRL(2) -> Hmax, upper bound for the integration step size -% RCNTRL(3) -> Hstart, starting value for the integration step size -% -% RCNTRL(4) -> FacMin, lower bound on step decrease factor (default=0.2) -% RCNTRL(5) -> FacMax, upper bound on step increase factor (default=6) -% RCNTRL(6) -> FacRej, step decrease factor after multiple rejections -% (default=0.1) -% RCNTRL(7) -> FacSafe, by which the new step is slightly smaller -% than the predicted value (default=0.9) -%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -% -% RSTAT and ISTAT on output: -% -% ISTAT(1) -> No. of function calls -% ISTAT(2) -> No. of jacobian calls -% ISTAT(3) -> No. of steps -% ISTAT(4) -> No. of accepted steps -% ISTAT(5) -> No. of rejected steps (except at very beginning) -% ISTAT(6) -> No. of LU decompositions -% ISTAT(7) -> No. of forward/backward substitutions -% ISTAT(8) -> No. of singular matrix decompositions -% -% RSTAT(1) -> Texit, the time corresponding to the -% computed Y upon return -% RSTAT(2) -> Hexit, last accepted step before exit -% RSTAT(3) -> Hnew, last predicted step (not yet taken) -% For multiple restarts, use Hnew as Hstart -% in the subsequent run -%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -%~~~> Statistics on the work performed by the Rosenbrock method -global Nfun Njac Nstp Nacc Nrej Ndec Nsol Nsng Ntexit Nhexit Nhnew -global ISTATUS RSTATUS - -% Parse ODE options -AbsTol = odeget(Options, 'AbsTol'); -if isempty(AbsTol) - AbsTol = 1.0e-3; -end -Hstart = odeget(Options, 'InitialStep'); -if isempty(Hstart) - Hstart = 0; -end -Jacobian = odeget(Options, 'Jacobian'); -if isempty(Jacobian) - error('A Jacobian function is required.'); -end -Hmax = odeget(Options, 'MaxStep'); -if isempty(Hmax) - Hmax = 0; -end -RelTol = odeget(Options, 'RelTol'); -if isempty(RelTol) - RelTol = 1.0e-4; -end - -% Initialize statistics -Nfun=1; Njac=2; Nstp=3; Nacc=4; Nrej=5; Ndec=6; Nsol=7; Nsng=8; -Ntexit=1; Nhexit=2; Nhnew=3; -RSTATUS = zeros(20,1); -ISTATUS = zeros(20,1); - -% Get problem size -steps = length(Tspan); -N = length(Y0); - -% Initialize tolerances -ATOL = ones(N,1)*AbsTol; -RTOL = ones(N,1)*RelTol; - -% Initialize step -RCNTRL(2) = max(0, Hmax); -RCNTRL(3) = max(0, Hstart); - -% Integrate -Y = zeros(steps,N); -T = zeros(steps,1); -Y(1,:) = Y0; -T(1) = Tspan(1); -for i=2:steps - [T(i), Y(i,:), IERR] = ... - RosenbrockIntegrator(N, Y(i-1,:), T(i-1), Tspan(i), ... - Function, Jacobian, ATOL, RTOL, RCNTRL, ICNTRL); - - if IERR < 0 - error(['Rosenbrock exited with IERR=',num2str(IERR)]); - end - -end - -ISTAT = ISTATUS; -RSTAT = RSTATUS; - -return - -%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -function [ T, Y, IERR ] = RosenbrockIntegrator(N, Y, Tstart, Tend, ... - OdeFunction, OdeJacobian, AbsTol, RelTol, RCNTRL, ICNTRL) -%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -% Advances the ODE system defined by OdeFunction, OdeJacobian and Y -% from time=Tstart to time=Tend -%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -%~~~> Statistics on the work performed by the Rosenbrock method -global Nfun Njac Nstp Nacc Nrej Ndec Nsol Nsng Ntexit Nhexit Nhnew Ntotal -global ISTATUS RSTATUS - -%~~~> Parameters -global ZERO ONE DeltaMin -ZERO = 0.0; ONE = 1.0; DeltaMin = 1.0E-5; - -%~~~> Initialize statistics -ISTATUS(1:8) = 0; -RSTATUS(1:3) = ZERO; - -%~~~> Autonomous or time dependent ODE. Default is time dependent. -Autonomous = ~(ICNTRL(1) == 0); - -%~~~> For Scalar tolerances (ICNTRL(2).NE.0) the code uses AbsTol(1) and RelTol(1) -% For Vector tolerances (ICNTRL(2) == 0) the code uses AbsTol(1:N) and RelTol(1:N) -if ICNTRL(2) == 0 - VectorTol = true; - UplimTol = N; -else - VectorTol = false; - UplimTol = 1; -end - -%~~~> Initialize the particular Rosenbrock method selected -switch (ICNTRL(3)) - case (1) - ros_Param = Ros2; - case (2) - ros_Param = Ros3; - case (3) - ros_Param = Ros4; - case {0,4} - ros_Param = Rodas3; - case (5) - ros_Param = Rodas4; - otherwise - disp(['Unknown Rosenbrock method: ICNTRL(3)=',num2str(ICNTRL(3))]); - IERR = ros_ErrorMsg(-2,Tstart,ZERO); - return -end -ros_S = ros_Param{1}; -rosMethod = ros_Param{2}; -ros_A = ros_Param{3}; -ros_C = ros_Param{4}; -ros_M = ros_Param{5}; -ros_E = ros_Param{6}; -ros_Alpha = ros_Param{7}; -ros_Gamma = ros_Param{8}; -ros_ELO = ros_Param{9}; -ros_NewF = ros_Param{10}; -ros_Name = ros_Param{11}; - -%~~~> The maximum number of steps admitted -if ICNTRL(4) == 0 - Max_no_steps = 200000; -elseif ICNTRL(4) > 0 - Max_no_steps=ICNTRL(4); -else - disp(['User-selected max no. of steps: ICNTRL(4)=',num2str(ICNTRL(4))]); - IERR = ros_ErrorMsg(-1,Tstart,ZERO); - return -end - -%~~~> Unit roundoff (1+Roundoff>1) -Roundoff = eps; - -%~~~> Lower bound on the step size: (positive value) -if RCNTRL(1) == ZERO - Hmin = ZERO; -elseif RCNTRL(1) > ZERO - Hmin = RCNTRL(1); -else - disp(['User-selected Hmin: RCNTRL(1)=', num2str(RCNTRL(1))]); - IERR = ros_ErrorMsg(-3,Tstart,ZERO); - return -end - -%~~~> Upper bound on the step size: (positive value) -if RCNTRL(2) == ZERO - Hmax = abs(Tend-Tstart); -elseif RCNTRL(2) > ZERO - Hmax = min(abs(RCNTRL(2)),abs(Tend-Tstart)); -else - disp(['User-selected Hmax: RCNTRL(2)=', num2str(RCNTRL(2))]); - IERR = ros_ErrorMsg(-3,Tstart,ZERO); - return -end - -%~~~> Starting step size: (positive value) -if RCNTRL(3) == ZERO - Hstart = max(Hmin,DeltaMin); -elseif RCNTRL(3) > ZERO - Hstart = min(abs(RCNTRL(3)),abs(Tend-Tstart)); -else - disp(['User-selected Hstart: RCNTRL(3)=', num2str(RCNTRL(3))]); - IERR = ros_ErrorMsg(-3,Tstart,ZERO); - return -end - -%~~~> Step size can be changed s.t. FacMin < Hnew/Hold < FacMax -if RCNTRL(4) == ZERO - FacMin = 0.2; -elseif RCNTRL(4) > ZERO - FacMin = RCNTRL(4); -else - disp(['User-selected FacMin: RCNTRL(4)=', num2str(RCNTRL(4))]); - IERR = ros_ErrorMsg(-4,Tstart,ZERO); - return -end -if RCNTRL(5) == ZERO - FacMax = 6.0; -elseif RCNTRL(5) > ZERO - FacMax = RCNTRL(5); -else - disp(['User-selected FacMax: RCNTRL(5)=', num2str(RCNTRL(5))]); - IERR = ros_ErrorMsg(-4,Tstart,ZERO); - return -end - -%~~~> FacRej: Factor to decrease step after 2 succesive rejections -if RCNTRL(6) == ZERO - FacRej = 0.1; -elseif RCNTRL(6) > ZERO - FacRej = RCNTRL(6); -else - disp(['User-selected FacRej: RCNTRL(6)=', num2str(RCNTRL(6))]); - IERR = ros_ErrorMsg(-4,Tstart,ZERO); - return -end - -%~~~> FacSafe: Safety Factor in the computation of new step size -if RCNTRL(7) == ZERO - FacSafe = 0.9; -elseif RCNTRL(7) > ZERO - FacSafe = RCNTRL(7); -else - disp(['User-selected FacSafe: RCNTRL(7)=', num2str(RCNTRL(7))]); - IERR = ros_ErrorMsg(-4,Tstart,ZERO); - return -end - -%~~~> Check if tolerances are reasonable -for i=1:UplimTol - if (AbsTol(i) <= ZERO) || (RelTol(i) <= 10.0*Roundoff) || (RelTol(i) >= 1.0) - disp([' AbsTol(',i,') = ',num2str(AbsTol(i))]); - disp([' RelTol(',i,') = ',num2str(RelTol(i))]); - IERR = ros_ErrorMsg(-5,Tstart,ZERO); - return - end -end - -%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -% Template for the implementation of a generic Rosenbrock method -% defined by ros_S (no of stages) -% and its coefficients ros_{A,C,M,E,Alpha,Gamma} -%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -% ~~~~ Local variables -Ynew = zeros(N,1); -Fcn0 = zeros(N,1); -Fcn = zeros(N,1); -K = zeros(N,ros_S); -dFdT = zeros(N,1); -Jac0 = sparse(N,N); -Ghimj = sparse(N,N); -Yerr = zeros(N,1); -Pivot = zeros(N,1); - -%~~~> Initial preparations -T = Tstart; -RSTATUS(Nhexit) = ZERO; -H = min(max(abs(Hmin), abs(Hstart)), abs(Hmax)); -if abs(H) <= 10.0*Roundoff - H = DeltaMin; -end - -if Tend >= Tstart - Direction = +1; -else - Direction = -1; -end -H = Direction*H; - -RejectLastH = false; -RejectMoreH = false; - -%~~~> Time loop begins below - -while ( (Direction > 0) && ((T-Tend)+Roundoff <= ZERO) || ... - (Direction < 0) && ((Tend-T)+Roundoff <= ZERO) ) - - if ISTATUS(Nstp) > Max_no_steps % Too many steps - IERR = ros_ErrorMsg(-6,T,H); - return - end - if ((T+0.1*H) == T) || (H <= Roundoff) % Step size too small - IERR = ros_ErrorMsg(-7,T,H); - return - end - - %~~~> Limit H if necessary to avoid going beyond Tend - H = min(H, abs(Tend-T)); - - %~~~> Compute the function at current time - Fcn0 = OdeFunction(T, Y); - ISTATUS(Nfun) = ISTATUS(Nfun) + 1; - - %~~~> Compute the function derivative with respect to T - if ~Autonomous - dFdT = ros_FunTimeDerivative (T, OdeFunction, Roundoff, Y, Fcn0); - end - - %~~~> Compute the Jacobian at current time - Jac0 = OdeJacobian(T,Y); - ISTATUS(Njac) = ISTATUS(Njac) + 1; - - %~~~> Repeat step calculation until current step accepted - while(true) - - [H, Ghimj, Pivot, Singular] = ... - ros_PrepareMatrix(N, H, Direction, ros_Gamma(1), Jac0); - - % Not calculating LU decomposition in ros_PrepareMatrix anymore - % so don't need to check if the matrix is singular - % - %if Singular % More than 5 consecutive failed decompositions - % IERR = ros_ErrorMsg(-8,T,H); - % return - %end - - % For the 1st istage the function has been computed previously - Fcn = Fcn0; - K(:,1) = Fcn; - if (~Autonomous) && (ros_Gamma(1) ~= ZERO) - HG = Direction*H*ros_Gamma(1); - K(:,1) = K(:,1) + HG * dFdT; - end - K(:,1) = ros_Solve(Ghimj, Pivot, K(:,1)); - - %~~~> Compute the remaining stages - for istage=2:ros_S - - % istage>1 and a new function evaluation is needed - if ros_NewF(istage) - Ynew = Y; - for j=1:istage-1 - Ynew = Ynew + ros_A((istage-1)*(istage-2)/2+j)*K(:,j)'; - end - Tau = T + ros_Alpha(istage)*Direction*H; - Fcn = OdeFunction(Tau,Ynew); - ISTATUS(Nfun) = ISTATUS(Nfun) + 1; - end - - K(:,istage) = Fcn; - for j=1:istage-1 - HC = ros_C((istage-1)*(istage-2)/2+j)/(Direction*H); - K(:,istage) = K(:,istage) + HC * K(:,j); - end - if (~Autonomous) && (ros_Gamma(istage) ~= ZERO) - HG = Direction*H*ros_Gamma(istage); - K(:,istage) = K(:,istage) + HG * dFdT; - end - - % Linear system is solved here with MATLAB '\' operator - % instead of LU decomposition. - K(:,istage) = ros_Solve(Ghimj, Pivot, K(:,istage)); - - end - - %~~~> Compute the new solution - Ynew = Y; - for j=1:ros_S - Ynew = Ynew + ros_M(j) * K(:,j)'; - end - - %~~~> Compute the error estimation - Yerr = zeros(N,1); - for j=1:ros_S - Yerr = Yerr + ros_E(j) * K(:,j); - end - Err = ros_ErrorNorm(N, Y, Ynew, Yerr, AbsTol, RelTol, VectorTol); - - %~~~> New step size is bounded by FacMin <= Hnew/H <= FacMax - Fac = min(FacMax, max(FacMin, FacSafe/(Err^(ONE/ros_ELO)))); - Hnew = H*Fac; - - %~~~> Check the error magnitude and adjust step size - ISTATUS(Nstp) = ISTATUS(Nstp) + 1; - if (Err <= ONE) || (H <= Hmin) %~~~> Accept step - ISTATUS(Nacc) = ISTATUS(Nacc) + 1; - Y = Ynew; - T = T + Direction*H; - Hnew = max(Hmin, min(Hnew, Hmax)); - if RejectLastH % No step size increase after a rejected step - Hnew = min(Hnew, H); - end - RSTATUS(Nhexit) = H; - RSTATUS(Nhnew) = Hnew; - RSTATUS(Ntexit) = T; - RejectLastH = false; - RejectMoreH = false; - H = Hnew; - break % EXIT THE LOOP: WHILE STEP NOT ACCEPTED - else %~~~> Reject step - if RejectMoreH - Hnew = H*FacRej; - end - RejectMoreH = RejectLastH; - RejectLastH = true; - H = Hnew; - if ISTATUS(Nacc) >= 1 - ISTATUS(Nrej) = ISTATUS(Nrej) + 1; - end - end % Err <= 1 - - end % UntilAccepted - -end % TimeLoop - -%~~~> Succesful exit -IERR = 1; %~~~> The integration was successful - -return - - -%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -function [ ErrNorm ] = ros_ErrorNorm(N, Y, Ynew, Yerr, AbsTol, RelTol, VectorTol) -%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -%~~~> Computes the "scaled norm" of the error vector Yerr -%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Err = 0; -for i=1:N - Ymax = max(abs(Y(i)), abs(Ynew(i))); - if VectorTol - Scale = AbsTol(i) + RelTol(i)*Ymax; - else - Scale = AbsTol(1) + RelTol(1)*Ymax; - end - Err = Err + (Yerr(i)/Scale)^2; -end -Err = sqrt(Err/N); -ErrNorm = max(Err,1.0e-10); - -return - -%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -function [ dFdT ] = ros_FunTimeDerivative (T, OdeFunction, Roundoff, Y, Fcn0) -%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -%~~~> The time partial derivative of the function by finite differences -%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -%~~~> Statistics on the work performed by the Rosenbrock method -global Nfun ISTATUS - -%~~~> Parameters -global ZERO ONE DeltaMin - -Delta = sqrt(Roundoff) * max(DeltaMin, abs(T)); -dFdT = OdeFunction(T+Delta,Y); -ISTATUS(Nfun) = ISTATUS(Nfun) + 1; -dFdT = (dFdT - Fcn0) / Delta; - -return - - -%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -function [H, Ghimj, Pivot, Singular] = ... - ros_PrepareMatrix(N, H, Direction, gam, Jac0) -%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -% Prepares the LHS matrix for stage calculations -% 1. Construct Ghimj = 1/(H*ham) - Jac0 -% "(Gamma H) Inverse Minus Jacobian" -% 2. LU decomposition not performed here because -% MATLAB solves the linear system with '\'. -%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Ghimj = -Jac0; -ghinv = 1.0/(Direction*H*gam); -for i=1:N - Ghimj(i,i) = Ghimj(i,i)+ghinv; -end - -Pivot(1) = 1; -Singular = false; - -return - - -%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -function [ IERR ] = ros_ErrorMsg(Code, T, H) -%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -% Handles all error messages -%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -IERR = Code; - -disp('Forced exit from Rosenbrock due to the following error:'); - -switch (Code) - case (-1) - disp('--> Improper value for maximal no of steps'); - case (-2) - disp('--> Selected Rosenbrock method not implemented'); - case (-3) - disp('--> Hmin/Hmax/Hstart must be positive'); - case (-4) - disp('--> FacMin/FacMax/FacRej must be positive'); - case (-5) - disp('--> Improper tolerance values'); - case (-6) - disp('--> No of steps exceeds maximum bound'); - case (-7) - disp('--> Step size too small: T + 10*H = T or H < Roundoff'); - case (-8) - disp('--> Matrix is repeatedly singular'); - otherwise - disp(['Unknown Error code: ', num2str(Code)]); -end - -disp(['T=',num2str(T),' and H=',num2str(H)]); - -return - - -%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -function [X] = ros_Solve(JVS, Pivot, X) -%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -% Template for the forward/backward substitution -%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -global Nsol ISTATUS - -X = JVS\X; -Pivot(1) = 1; -ISTATUS(Nsol) = ISTATUS(Nsol) + 1; - -return - - -%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -function [ params ] = Ros2() -%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -% --- AN L-STABLE METHOD, 2 stages, order 2 -%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -g = 1.0 + 1.0/sqrt(2.0); -rosMethod = 1; -%~~~> Name of the method -ros_Name = 'ROS-2'; -%~~~> Number of stages -ros_S = 2; - -%~~~> The coefficient matrices A and C are strictly lower triangular. -% The lower triangular (subdiagonal) elements are stored in row-wise order: -% A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. -% The general mapping formula is: -% A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) -% C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) - -ros_A(1) = (1.0)/g; -ros_C(1) = (-2.0)/g; -%~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) -% or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) -ros_NewF(1) = true; -ros_NewF(2) = true; -%~~~> M_i = Coefficients for new step solution -ros_M(1)= (3.0)/(2.0*g); -ros_M(2)= (1.0)/(2.0*g); -% E_i = Coefficients for error estimator -ros_E(1) = 1.0/(2.0*g); -ros_E(2) = 1.0/(2.0*g); -%~~~> ros_ELO = estimator of local order - the minimum between the -% main and the embedded scheme orders plus one -ros_ELO = 2.0; -%~~~> Y_stage_i ~ Y( T + H*Alpha_i ) -ros_Alpha(1) = 0.0; -ros_Alpha(2) = 1.0; -%~~~> Gamma_i = \sum_j gamma_{i,j} -ros_Gamma(1) = g; -ros_Gamma(2) =-g; - -params = { ros_S, rosMethod, ros_A, ros_C, ros_M, ros_E, ... - ros_Alpha, ros_Gamma, ros_ELO, ros_NewF, ros_Name }; - -return - - -%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -function [ params ] = Ros3() -%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -% --- AN L-STABLE METHOD, 3 stages, order 3, 2 function evaluations -%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -rosMethod = 2; -%~~~> Name of the method -ros_Name = 'ROS-3'; -%~~~> Number of stages -ros_S = 3; - -%~~~> The coefficient matrices A and C are strictly lower triangular. -% The lower triangular (subdiagonal) elements are stored in row-wise order: -% A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. -% The general mapping formula is: -% A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) -% C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) - -ros_A(1)= 1.0; -ros_A(2)= 1.0; -ros_A(3)= 0.0; - -ros_C(1) = -0.10156171083877702091975600115545E+01; -ros_C(2) = 0.40759956452537699824805835358067E+01; -ros_C(3) = 0.92076794298330791242156818474003E+01; -%~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) -% or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) -ros_NewF(1) = true; -ros_NewF(2) = true; -ros_NewF(3) = false; -%~~~> M_i = Coefficients for new step solution -ros_M(1) = 0.1E+01; -ros_M(2) = 0.61697947043828245592553615689730E+01; -ros_M(3) = -0.42772256543218573326238373806514; -% E_i = Coefficients for error estimator -ros_E(1) = 0.5; -ros_E(2) = -0.29079558716805469821718236208017E+01; -ros_E(3) = 0.22354069897811569627360909276199; -%~~~> ros_ELO = estimator of local order - the minimum between the -% main and the embedded scheme orders plus 1 -ros_ELO = 3.0; -%~~~> Y_stage_i ~ Y( T + H*Alpha_i ) -ros_Alpha(1)= 0.0; -ros_Alpha(2)= 0.43586652150845899941601945119356; -ros_Alpha(3)= 0.43586652150845899941601945119356; -%~~~> Gamma_i = \sum_j gamma_{i,j} -ros_Gamma(1)= 0.43586652150845899941601945119356; -ros_Gamma(2)= 0.24291996454816804366592249683314; -ros_Gamma(3)= 0.21851380027664058511513169485832E+01; - -params = { ros_S, rosMethod, ros_A, ros_C, ros_M, ros_E, ... - ros_Alpha, ros_Gamma, ros_ELO, ros_NewF, ros_Name }; - -return - -%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - -%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -function [ params ] = Ros4() -%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -% L-STABLE ROSENBROCK METHOD OF ORDER 4, WITH 4 STAGES -% L-STABLE EMBEDDED ROSENBROCK METHOD OF ORDER 3 -% -% E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL -% EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS. -% SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS, -% SPRINGER-VERLAG (1990) -%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -rosMethod = 3; -%~~~> Name of the method -ros_Name = 'ROS-4'; -%~~~> Number of stages -ros_S = 4; - -%~~~> The coefficient matrices A and C are strictly lower triangular. -% The lower triangular (subdiagonal) elements are stored in row-wise order: -% A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. -% The general mapping formula is: -% A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) -% C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) - -ros_A(1) = 0.2000000000000000E+01; -ros_A(2) = 0.1867943637803922E+01; -ros_A(3) = 0.2344449711399156; -ros_A(4) = ros_A(2); -ros_A(5) = ros_A(3); -ros_A(6) = 0.0; - -ros_C(1) =-0.7137615036412310E+01; -ros_C(2) = 0.2580708087951457E+01; -ros_C(3) = 0.6515950076447975; -ros_C(4) =-0.2137148994382534E+01; -ros_C(5) =-0.3214669691237626; -ros_C(6) =-0.6949742501781779; -%~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) -% or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) -ros_NewF(1) = true; -ros_NewF(2) = true; -ros_NewF(3) = true; -ros_NewF(4) = false; -%~~~> M_i = Coefficients for new step solution -ros_M(1) = 0.2255570073418735E+01; -ros_M(2) = 0.2870493262186792; -ros_M(3) = 0.4353179431840180; -ros_M(4) = 0.1093502252409163E+01; -%~~~> E_i = Coefficients for error estimator -ros_E(1) =-0.2815431932141155; -ros_E(2) =-0.7276199124938920E-01; -ros_E(3) =-0.1082196201495311; -ros_E(4) =-0.1093502252409163E+01; -%~~~> ros_ELO = estimator of local order - the minimum between the -% main and the embedded scheme orders plus 1 -ros_ELO = 4.0; -%~~~> Y_stage_i ~ Y( T + H*Alpha_i ) -ros_Alpha(1) = 0.0; -ros_Alpha(2) = 0.1145640000000000E+01; -ros_Alpha(3) = 0.6552168638155900; -ros_Alpha(4) = ros_Alpha(3); -%~~~> Gamma_i = \sum_j gamma_{i,j} -ros_Gamma(1) = 0.5728200000000000; -ros_Gamma(2) =-0.1769193891319233E+01; -ros_Gamma(3) = 0.7592633437920482; -ros_Gamma(4) =-0.1049021087100450; - -params = { ros_S, rosMethod, ros_A, ros_C, ros_M, ros_E, ... - ros_Alpha, ros_Gamma, ros_ELO, ros_NewF, ros_Name }; - -return - -%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -function [ params ] = Rodas3() -%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -% --- A STIFFLY-STABLE METHOD, 4 stages, order 3 -%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -rosMethod = 4; -%~~~> Name of the method -ros_Name = 'RODAS-3'; -%~~~> Number of stages -ros_S = 4; - -%~~~> The coefficient matrices A and C are strictly lower triangular. -% The lower triangular (subdiagonal) elements are stored in row-wise order: -% A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. -% The general mapping formula is: -% A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) -% C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) - -ros_A(1) = 0.0; -ros_A(2) = 2.0; -ros_A(3) = 0.0; -ros_A(4) = 2.0; -ros_A(5) = 0.0; -ros_A(6) = 1.0; - -ros_C(1) = 4.0; -ros_C(2) = 1.0; -ros_C(3) =-1.0; -ros_C(4) = 1.0; -ros_C(5) =-1.0; -ros_C(6) =-(8.0/3.0); - -%~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) -% or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) -ros_NewF(1) = true; -ros_NewF(2) = false; -ros_NewF(3) = true; -ros_NewF(4) = true; -%~~~> M_i = Coefficients for new step solution -ros_M(1) = 2.0; -ros_M(2) = 0.0; -ros_M(3) = 1.0; -ros_M(4) = 1.0; -%~~~> E_i = Coefficients for error estimator -ros_E(1) = 0.0; -ros_E(2) = 0.0; -ros_E(3) = 0.0; -ros_E(4) = 1.0; -%~~~> ros_ELO = estimator of local order - the minimum between the -% main and the embedded scheme orders plus 1 -ros_ELO = 3.0; -%~~~> Y_stage_i ~ Y( T + H*Alpha_i ) -ros_Alpha(1) = 0.0; -ros_Alpha(2) = 0.0; -ros_Alpha(3) = 1.0; -ros_Alpha(4) = 1.0; -%~~~> Gamma_i = \sum_j gamma_{i,j} -ros_Gamma(1) = 0.5; -ros_Gamma(2) = 1.5; -ros_Gamma(3) = 0.0; -ros_Gamma(4) = 0.0; - -params = { ros_S, rosMethod, ros_A, ros_C, ros_M, ros_E, ... - ros_Alpha, ros_Gamma, ros_ELO, ros_NewF, ros_Name }; - -return - -%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -function [ params ] = Rodas4() -%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -% STIFFLY-STABLE ROSENBROCK METHOD OF ORDER 4, WITH 6 STAGES -% -% E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL -% EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS. -% SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS, -% SPRINGER-VERLAG (1996) -%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -rosMethod = 5; -%~~~> Name of the method -ros_Name = 'RODAS-4'; -%~~~> Number of stages -ros_S = 6; - -%~~~> Y_stage_i ~ Y( T + H*Alpha_i ) -ros_Alpha(1) = 0.000; -ros_Alpha(2) = 0.386; -ros_Alpha(3) = 0.210; -ros_Alpha(4) = 0.630; -ros_Alpha(5) = 1.000; -ros_Alpha(6) = 1.000; - -%~~~> Gamma_i = \sum_j gamma_{i,j} -ros_Gamma(1) = 0.2500000000000000; -ros_Gamma(2) =-0.1043000000000000; -ros_Gamma(3) = 0.1035000000000000; -ros_Gamma(4) =-0.3620000000000023E-01; -ros_Gamma(5) = 0.0; -ros_Gamma(6) = 0.0; - -%~~~> The coefficient matrices A and C are strictly lower triangular. -% The lower triangular (subdiagonal) elements are stored in row-wise order: -% A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. -% The general mapping formula is: A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) -% C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) - -ros_A(1) = 0.1544000000000000E+01; -ros_A(2) = 0.9466785280815826; -ros_A(3) = 0.2557011698983284; -ros_A(4) = 0.3314825187068521E+01; -ros_A(5) = 0.2896124015972201E+01; -ros_A(6) = 0.9986419139977817; -ros_A(7) = 0.1221224509226641E+01; -ros_A(8) = 0.6019134481288629E+01; -ros_A(9) = 0.1253708332932087E+02; -ros_A(10) =-0.6878860361058950; -ros_A(11) = ros_A(7); -ros_A(12) = ros_A(8); -ros_A(13) = ros_A(9); -ros_A(14) = ros_A(10); -ros_A(15) = 1.0; - -ros_C(1) =-0.5668800000000000E+01; -ros_C(2) =-0.2430093356833875E+01; -ros_C(3) =-0.2063599157091915; -ros_C(4) =-0.1073529058151375; -ros_C(5) =-0.9594562251023355E+01; -ros_C(6) =-0.2047028614809616E+02; -ros_C(7) = 0.7496443313967647E+01; -ros_C(8) =-0.1024680431464352E+02; -ros_C(9) =-0.3399990352819905E+02; -ros_C(10) = 0.1170890893206160E+02; -ros_C(11) = 0.8083246795921522E+01; -ros_C(12) =-0.7981132988064893E+01; -ros_C(13) =-0.3152159432874371E+02; -ros_C(14) = 0.1631930543123136E+02; -ros_C(15) =-0.6058818238834054E+01; - -%~~~> M_i = Coefficients for new step solution -ros_M(1) = ros_A(7); -ros_M(2) = ros_A(8); -ros_M(3) = ros_A(9); -ros_M(4) = ros_A(10); -ros_M(5) = 1.0; -ros_M(6) = 1.0; - -%~~~> E_i = Coefficients for error estimator -ros_E(1) = 0.0; -ros_E(2) = 0.0; -ros_E(3) = 0.0; -ros_E(4) = 0.0; -ros_E(5) = 0.0; -ros_E(6) = 1.0; - -%~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) -% or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) -ros_NewF(1) = true; -ros_NewF(2) = true; -ros_NewF(3) = true; -ros_NewF(4) = true; -ros_NewF(5) = true; -ros_NewF(6) = true; - -%~~~> ros_ELO = estimator of local order - the minimum between the -% main and the embedded scheme orders plus 1 -ros_ELO = 4.0; - -params = { ros_S, rosMethod, ros_A, ros_C, ros_M, ros_E, ... - ros_Alpha, ros_Gamma, ros_ELO, ros_NewF, ros_Name }; - -return - -% End of INTEGRATE function -% ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - diff --git a/boxmox/int/rosenbrock_adj.c b/boxmox/int/rosenbrock_adj.c deleted file mode 100644 index eb04fdcf161ba0aa609d6da03970bc18d94f57ba..0000000000000000000000000000000000000000 --- a/boxmox/int/rosenbrock_adj.c +++ /dev/null @@ -1,2470 +0,0 @@ -#define MAX(a,b) ( ((a) >= (b)) ? (a):(b) ) -#define MIN(b,c) ( ((b) < (c)) ? (b):(c) ) -#define ABS(x) ( ((x) >= 0 ) ? (x):(-x) ) -#define SQRT(d) ( pow((d),0.5) ) - -/* Numerical Constants */ -#define ZERO (KPP_REAL)0.0 -#define ONE (KPP_REAL)1.0 -#define HALF (KPP_REAL)0.5 -#define DeltaMin (KPP_REAL)1.0e-5 -enum boolean { FALSE=0, TRUE=1 }; - -/* Statistics on the work performed by the Rosenbrock method */ -enum statistics { Nfun=1, Njac=2, Nstp=3, Nacc=4, Nrej=5, Ndec=6, Nsol=7, - Nsng=8, Ntexit=1, Nhexit=2, Nhnew=3 }; - -/*~~~> Parameters of the Rosenbrock method, up to 6 stages */ -int ros_S, rosMethod; -enum ros_Params { RS2=1, RS3=2, RS4=3, RD3=4, RD4=5 }; -KPP_REAL ros_A[15], ros_C[15], ros_M[6], ros_E[6], ros_Alpha[6], ros_Gamma[6], - ros_ELO; -int ros_NewF[6]; /* Holds Boolean values */ -char ros_Name[12]; /* Length 12 */ - -/*~~~> Types of Adjoints Implemented */ -enum adjoint { Adj_none=1, Adj_discrete=2, Adj_continuous=3, - Adj_simple_continuous=4 }; - -/*~~~> Checkpoints in memory */ -int bufsize = 200000; -int stack_ptr; /* last written entry */ -KPP_REAL *chk_H, *chk_T; -KPP_REAL **chk_Y, **chk_K, **chk_J; /* 2D arrays */ -KPP_REAL **chk_dY, **chk_d2Y; /* 2D arrays */ - -/* Function Headers */ -void INTEGRATE_ADJ(int NADJ, KPP_REAL Y[], KPP_REAL Lambda[][NVAR], - KPP_REAL TIN, KPP_REAL TOUT, KPP_REAL ATOL_adj[][NVAR], - KPP_REAL RTOL_adj[][NVAR], int ICNTRL_U[], - KPP_REAL RCNTRL_U[], int ISTATUS_U[], KPP_REAL RSTATUS_U[]); -int RosenbrockADJ( KPP_REAL Y[], int NADJ, KPP_REAL Lambda[][NVAR], - KPP_REAL Tstart, KPP_REAL Tend, KPP_REAL AbsTol[], - KPP_REAL RelTol[], KPP_REAL AbsTol_adj[][NVAR], - KPP_REAL RelTol_adj[][NVAR], KPP_REAL RCNTRL[], - int ICNTRL[], KPP_REAL RSTATUS[], int ISTATUS[] ); -void ros_AllocateDBuffers( int S, int SaveLU ); -void ros_FreeDBuffers( int SaveLU ); -void ros_AllocateCBuffers(); -void ros_FreeCBuffers(); -void ros_DPush( int S, KPP_REAL T, KPP_REAL H, KPP_REAL Ystage[], - KPP_REAL K[], KPP_REAL E[], int P[], int SaveLU ); -void ros_DPop( int S, KPP_REAL* T, KPP_REAL* H, KPP_REAL* Ystage, - KPP_REAL* K, KPP_REAL* E, int* P, int SaveLU ); -void ros_CPush( KPP_REAL T, KPP_REAL H, KPP_REAL Y[], KPP_REAL dY[], - KPP_REAL d2Y[] ); -void ros_CPop( KPP_REAL T, KPP_REAL H, KPP_REAL Y[], KPP_REAL dY[], - KPP_REAL d2Y[] ); -int ros_ErrorMsg( int Code, KPP_REAL T, KPP_REAL H); -int ros_FwdInt (KPP_REAL Y[], KPP_REAL Tstart, KPP_REAL Tend, KPP_REAL T, - KPP_REAL AbsTol[], KPP_REAL RelTol[], int AdjointType, - KPP_REAL Hmin, KPP_REAL Hstart, KPP_REAL Hmax, - KPP_REAL Roundoff, int ISTATUS[], int Max_no_steps, - KPP_REAL RSTATUS[], int Autonomous, int VectorTol, - KPP_REAL FacMax, KPP_REAL FacMin, KPP_REAL FacSafe, - KPP_REAL FacRej, int SaveLU); -int ros_DadjInt ( int NADJ, KPP_REAL Lambda[][NVAR], KPP_REAL Tstart, - KPP_REAL Tend, KPP_REAL T, int SaveLU, int ISTATUS[], - KPP_REAL Roundoff, int Autonomous); -int ros_CadjInt ( int NADJ, KPP_REAL Y[][NVAR], KPP_REAL Tstart, KPP_REAL Tend, - KPP_REAL T, KPP_REAL AbsTol_adj[][NVAR], - KPP_REAL RelTol_adj[][NVAR], KPP_REAL RSTATUS[], - KPP_REAL Hmin, KPP_REAL Hmax, KPP_REAL Hstart, - KPP_REAL Roundoff, int Max_no_steps, int Autonomous, - int VectorTol, KPP_REAL FacMax, KPP_REAL FacMin, - KPP_REAL FacSafe, KPP_REAL FacRej, int ISTATUS[] ); -int ros_SimpleCadjInt ( int NADJ, KPP_REAL Y[][NVAR], KPP_REAL Tstart, - KPP_REAL Tend, KPP_REAL T, int ISTATUS[], - int Autonomous, KPP_REAL Roundoff ); -KPP_REAL ros_ErrorNorm ( KPP_REAL Y[], KPP_REAL Ynew[], KPP_REAL Yerr[], - KPP_REAL AbsTol[], KPP_REAL RelTol[], int VectorTol ); -void ros_FunTimeDerivative ( KPP_REAL T, KPP_REAL Roundoff, KPP_REAL Y[], - KPP_REAL Fcn0[], KPP_REAL dFdT[], int ISTATUS[] ); -void ros_JacTimeDerivative ( KPP_REAL T, KPP_REAL Roundoff, KPP_REAL Y[], - KPP_REAL Jac0[], KPP_REAL dJdT[], int ISTATUS[] ); -int ros_PrepareMatrix ( KPP_REAL H, int Direction, KPP_REAL gam, - KPP_REAL Jac0[], KPP_REAL Ghimj[], int Pivot[], - int ISTATUS[] ); -void ros_Decomp( KPP_REAL A[], int Pivot[], int* ising, int ISTATUS[] ); -void ros_Solve( char How, KPP_REAL A[], int Pivot[], KPP_REAL b[], - int ISTATUS[] ); -void ros_cadj_Y( KPP_REAL T, KPP_REAL Y[] ); -void ros_Hermite3( KPP_REAL a, KPP_REAL b, KPP_REAL T, KPP_REAL Ya[], - KPP_REAL Yb[], KPP_REAL Ja[], KPP_REAL Jb[], KPP_REAL Y[] ); -void ros_Hermite5( KPP_REAL a, KPP_REAL b, KPP_REAL T, KPP_REAL Ya[], - KPP_REAL Yb[], KPP_REAL Ja[], KPP_REAL Jb[], KPP_REAL Ha[], - KPP_REAL Hb[], KPP_REAL Y[] ); -void Ros2(); -void Ros3(); -void Ros4(); -void Rodas3(); -void Rodas4(); -void JacTemplate( KPP_REAL T, KPP_REAL Y[], KPP_REAL Jcb[] ); -void HessTemplate( KPP_REAL T, KPP_REAL Y[], KPP_REAL Hes[] ); -void FunTemplate( KPP_REAL T, KPP_REAL Y[], KPP_REAL Fun [] ); -void WSCAL( int N, KPP_REAL Alpha, KPP_REAL X[], int incX ); -void WAXPY( int N, KPP_REAL Alpha, KPP_REAL X[], int incX, KPP_REAL Y[], - int incY ); -void WCOPY( int N, KPP_REAL X[], int incX, KPP_REAL Y[], int incY ); -KPP_REAL WLAMCH( char C ); -void Update_SUN(); -void Update_RCONST(); -void Fun( KPP_REAL Y[], KPP_REAL FIX[], KPP_REAL RCONST[], KPP_REAL Ydot[] ); -void Jac_SP( KPP_REAL Y[], KPP_REAL FIX[], KPP_REAL RCONST[], KPP_REAL Ydot[]); -void Jac_SP_Vec( KPP_REAL Jac[], KPP_REAL Fcn[], KPP_REAL K[] ); -void JacTR_SP_Vec( KPP_REAL Jac[], KPP_REAL Fcn[], KPP_REAL K[] ); -void HessTR_Vec(KPP_REAL Hess[], KPP_REAL U1[], KPP_REAL U2[], KPP_REAL HTU[]); -void KppSolve( KPP_REAL A[], KPP_REAL b[] ); -int KppDecomp( KPP_REAL A[] ); -void KppSolveTR( KPP_REAL JVS[], KPP_REAL X[], KPP_REAL XX[] ); -void Hessian( KPP_REAL V[], KPP_REAL F[], KPP_REAL RCT[], KPP_REAL Hess[] ); - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void INTEGRATE_ADJ( int NADJ, KPP_REAL Y[], KPP_REAL Lambda[][NVAR], - KPP_REAL TIN, KPP_REAL TOUT, KPP_REAL ATOL_adj[][NVAR], - KPP_REAL RTOL_adj[][NVAR], int ICNTRL_U[], - KPP_REAL RCNTRL_U[], int ISTATUS_U[], - KPP_REAL RSTATUS_U[] ) { -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - -/* Local Variables */ - KPP_REAL RCNTRL[20], RSTATUS[20]; - int ICNTRL[20], ISTATUS[20], IERR, i; - - for( i = 0; i < 20; i++ ) { - ICNTRL[i] = 0; - RCNTRL[i] = ZERO; - ISTATUS[i] = 0; - RSTATUS[i] = ZERO; - } - -/*~~~> fine-tune the integrator: - ICNTRL(1) = 0 ! 0 = non-autonomous, 1 = autonomous - ICNTRL(2) = 1 ! 0 = scalar, 1 = vector tolerances - RCNTRL(3) = STEPMIN ! starting step - ICNTRL(3) = 5 ! choice of the method for forward integration - ICNTRL(6) = 1 ! choice of the method for continuous adjoint - ICNTRL(7) = 2 ! 1=none, 2=discrete, 3=full continuous, - 4=simplified continuous adjoint - ICNTRL(8) = 1 ! Save fwd LU factorization: 0=*don't* save, 1=save */ - -/* if optional parameters are given, and if they are >=0, then they overwrite - default settings */ -// if(ICNTRL_U != NULL) { -// for(i=0; i<20; i++) -// if(ICNTRL_U[i] > 0) -// ICNTRL[i] = ICNTRL_U[i]; -// } /* end for */ -// } /* end if */ - -// if(RCNTRL_U != NULL) { -// for(i=0; i<20; i++) -// if(RCNTRL_U[i] > 0) -// RCNTRL[i] = RCNTRL_U[i]; -// } /* end for */ -// } /* end if */ - - IERR = RosenbrockADJ( Y, NADJ, Lambda, TIN, TOUT, ATOL, RTOL, ATOL_adj, - RTOL_adj, RCNTRL, ICNTRL, RSTATUS, ISTATUS ); - - if (IERR < 0) - printf( "RosenbrockADJ: Unsucessful step at T=%f (IERR=%d)", TIN, IERR ); - - STEPMIN = RSTATUS[Nhexit]; - -/* if optional parameters are given for output - copy to them to return information */ -// if(ISTATUS_U != NULL) -// for(i=0; i<20; i++) -// ISTATUS_U[i] = ISTATUS[i]; -// } - -// if(RSTATUS_U != NULL) -// for(i=0; i<20; i++) -// RSTATUS_U[i] = RSTATUS[i]; -// } - -} /* End of INTEGRATE_ADJ */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -int RosenbrockADJ( KPP_REAL Y[], int NADJ, KPP_REAL Lambda[][NVAR], - KPP_REAL Tstart, KPP_REAL Tend, KPP_REAL AbsTol[], - KPP_REAL RelTol[], KPP_REAL AbsTol_adj[][NVAR], - KPP_REAL RelTol_adj[][NVAR], KPP_REAL RCNTRL[], - int ICNTRL[], KPP_REAL RSTATUS[], int ISTATUS[] ) { -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - ADJ = Adjoint of the Tangent Linear Model of a Rosenbrock Method - - Solves the system y'=F(t,y) using a RosenbrockADJ method defined by: - - G = 1/(H*gamma(1)) - Jac(t0,Y0) - T_i = t0 + Alpha(i)*H - Y_i = Y0 + \sum_{j=1}^{i-1} A(i,j)*K_j - G * K_i = Fun( T_i, Y_i ) + \sum_{j=1}^S C(i,j)/H * K_j + - gamma(i)*dF/dT(t0, Y0) - Y1 = Y0 + \sum_{j=1}^S M(j)*K_j - - For details on RosenbrockADJ methods and their implementation consult: - E. Hairer and G. Wanner - "Solving ODEs II. Stiff and differential-algebraic problems". - Springer series in computational mathematics, Springer-Verlag, 1996. - The codes contained in the book inspired this implementation. - - (C) Adrian Sandu, August 2004 - Virginia Polytechnic Institute and State University - Contact: sandu@cs.vt.edu - Revised by Philipp Miehe and Adrian Sandu, May 2006 - Translation F90 to C by Paul Eller, April 2007 - This implementation is part of KPP - the Kinetic PreProcessor -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -~~~> INPUT ARGUMENTS: - -- Y[NVAR] = vector of initial conditions (at T=Tstart) - NADJ -> dimension of linearized system, - i.e. the number of sensitivity coefficients -- Lambda[NVAR][NADJ] -> vector of initial sensitivity conditions - (at T=Tstart) -- [Tstart,Tend] = time range of integration - (if Tstart>Tend the integration is performed backwards in time) -- RelTol, AbsTol = user precribed accuracy -- void Fun( T, Y, Ydot ) = ODE function, - returns Ydot = Y' = F(T,Y) -- void Jac( T, Y, Jcb ) = Jacobian of the ODE function, - returns Jcb = dF/dY -- ICNTRL[0:9] = integer inputs parameters -- RCNTRL[0:9] = real inputs parameters -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -~~~> OUTPUT ARGUMENTS: - -- Y[NVAR] -> vector of final states (at T->Tend) -- Lambda[NVAR][NADJ] -> vector of final sensitivities (at T=Tend) -- ICNTRL[9:18] -> integer output parameters -- RCNTRL[9:18] -> real output parameters -- IERR -> job status upon return - - succes (positive value) or failure (negative value) - - = 1 : Success - = -1 : Improper value for maximal no of steps - = -2 : Selected RosenbrockADJ method not implemented - = -3 : Hmin/Hmax/Hstart must be positive - = -4 : FacMin/FacMax/FacRej must be positive - = -5 : Improper tolerance values - = -6 : No of steps exceeds maximum bound - = -7 : Step size too small - = -8 : Matrix is repeatedly singular -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -~~~> INPUT PARAMETERS: - - Note: For input parameters equal to zero the default values of the - corresponding variables are used. - - ICNTRL[0] = 1: F = F(y) Independent of T (AUTONOMOUS) - = 0: F = F(t,y) Depends on T (NON-AUTONOMOUS) - - ICNTRL[1] = 0: AbsTol, RelTol are NVAR-dimensional vectors - = 1: AbsTol, RelTol are scalars - - ICNTRL[2] -> selection of a particular Rosenbrock method - = 0 : default method is Rodas3 - = 1 : method is Ros2 - = 2 : method is Ros3 - = 3 : method is Ros4 - = 4 : method is Rodas3 - = 5: method is Rodas4 - - ICNTRL[3] -> maximum number of integration steps - For ICNTRL[4]=0) the default value of BUFSIZE is used - - ICNTRL[5] -> selection of a particular Rosenbrock method for the - continuous adjoint integration - for cts adjoint it - can be different than the forward method ICNTRL(3) - Note 1: to avoid interpolation errors (which can be huge!) - it is recommended to use only ICNTRL[6] = 2 or 4 - Note 2: the performance of the full continuous adjoint - strongly depends on the forward solution accuracy Abs/RelTol - - ICNTRL[6] -> Type of adjoint algorithm - = 0 : default is discrete adjoint ( of method ICNTRL[3] ) - = 1 : no adjoint - = 2 : discrete adjoint ( of method ICNTRL[3] ) - = 3 : fully adaptive continuous adjoint ( with method ICNTRL[6] ) - = 4 : simplified continuous adjoint ( with method ICNTRL[6] ) - - ICNTRL[7] -> checkpointing the LU factorization at each step: - ICNTRL[7]=0 : do *not* save LU factorization (the default) - ICNTRL[7]=1 : save LU factorization - Note: if ICNTRL[7]=1 the LU factorization is *not* saved - -~~~> Real input parameters: - - RCNTRL[0] -> Hmin, lower bound for the integration step size - It is strongly recommended to keep Hmin = ZERO - - RCNTRL[1] -> Hmax, upper bound for the integration step size - - RCNTRL[2] -> Hstart, starting value for the integration step size - - RCNTRL[3] -> FacMin, lower bound on step decrease factor (default=0.2) - - RCNTRL[4] -> FacMax, upper bound on step increase factor (default=6) - - RCNTRL[5] -> FacRej, step decrease factor after multiple rejections - (default=0.1) - - RCNTRL[6] -> FacSafe, by which the new step is slightly smaller - than the predicted value (default=0.9) - - RCNTRL[7] -> ThetaMin. If Newton convergence rate smaller - than ThetaMin the Jacobian is not recomputed; - (default=0.001) - -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -~~~> OUTPUT PARAMETERS: - - Note: each call to RosenbrockADJ adds the corrent no. of fcn calls - to previous value of ISTATUS(1), and similar for the other params. - Set ISTATUS[0:9] = 0 before call to avoid this accumulation. - - ISTATUS[0] = No. of function calls - ISTATUS[1] = No. of jacobian calls - ISTATUS[2] = No. of steps - ISTATUS[3] = No. of accepted steps - ISTATUS[4] = No. of rejected steps (except at the beginning) - ISTATUS[5] = No. of LU decompositions - ISTATUS[6] = No. of forward/backward substitutions - ISTATUS[7] = No. of singular matrix decompositions - - RSTATUS[0] -> Texit, the time corresponding to the - computed Y upon return - RSTATUS[1] -> Hexit, last accepted step before exit - For multiple restarts, use Hexit as Hstart in the following run -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - -/*~~~> Local variables */ - KPP_REAL Roundoff, FacMin, FacMax, FacRej, FacSafe; - KPP_REAL Hmin, Hmax, Hstart; - KPP_REAL Texit=0.0; - int i, UplimTol, Max_no_steps=0, IERR; - int AdjointType=0, CadjMethod=0; - int Autonomous, VectorTol, SaveLU; /* Holds boolean values */ - - stack_ptr = -1; - -/*~~~> Initialize statistics */ - for(i=0; i<20; i++) { - ISTATUS[i] = 0; - RSTATUS[i] = ZERO; - } - -/*~~~> Autonomous or time dependent ODE. Default is time dependent. */ - Autonomous = !(ICNTRL[0] == 0); - -/*~~~> For Scalar tolerances(ICNTRL[1] != 0) the code uses AbsTol[0] and - RelTol[0] - For Vector tolerances(ICNTRL[1] == 0) the code uses AbsTol[1:NVAR] and - RelTol[1:NVAR] */ - - if (ICNTRL[1] == 0) { - VectorTol = TRUE; - UplimTol = NVAR; - } - else { - VectorTol = FALSE; - UplimTol = 1; - } - -/*~~~> Initialize the particular Rosenbrock method selected */ - switch( ICNTRL[2] ) { - case 0: - case 4: - Rodas3(); - break; - case 1: - Ros2(); - break; - case 2: - Ros3(); - break; - case 3: - Ros4(); - break; - case 5: - Rodas4(); - break; - default: - printf( "Unknown Rosenbrock method: ICNTRL[2]=%d", ICNTRL[2] ); - return ros_ErrorMsg(-2, Tstart, ZERO); - } /* End switch */ - -/*~~~> The maximum number of steps admitted */ - if (ICNTRL[3] == 0) - Max_no_steps = bufsize - 1; - else if (Max_no_steps > 0) - Max_no_steps = ICNTRL[3]; - else { - printf("User-selected max no. of steps: ICNTRL[3]=%d",ICNTRL[3] ); - return ros_ErrorMsg(-1,Tstart,ZERO); - } - -/*~~~>The particular Rosenbrock method chosen for integrating the cts adjoint*/ - if (ICNTRL[5] == 0) - CadjMethod = 4; - else if ( (ICNTRL[5] >= 1) && (ICNTRL[5] <= 5) ) - CadjMethod = ICNTRL[5]; - else { - printf( "Unknown CADJ Rosenbrock method: ICNTRL[5]=%d", CadjMethod ); - return ros_ErrorMsg(-2,Tstart,ZERO); - } - -/*~~~> Discrete or continuous adjoint formulation */ - if ( ICNTRL[6] == 0 ) - AdjointType = Adj_discrete; - else if ( (ICNTRL[6] >= 1) && (ICNTRL[6] <= 4) ) - AdjointType = ICNTRL[6]; - else { - printf( "User-selected adjoint type: ICNTRL[6]=%d", AdjointType ); - return ros_ErrorMsg(-9,Tstart,ZERO); - } - -/*~~~> Save or not the forward LU factorization */ - SaveLU = (ICNTRL[7] != 0); - -/*~~~> Unit roundoff (1+Roundoff>1) */ - Roundoff = WLAMCH('E'); - -/*~~~> Lower bound on the step size: (positive value) */ - if (RCNTRL[0] == ZERO) - Hmin = ZERO; - else if (RCNTRL[0] > ZERO) - Hmin = RCNTRL[0]; - else { - printf( "User-selected Hmin: RCNTRL[0]=%f", RCNTRL[0] ); - return ros_ErrorMsg(-3,Tstart,ZERO); - } - -/*~~~> Upper bound on the step size: (positive value) */ - if (RCNTRL[1] == ZERO) - Hmax = ABS(Tend-Tstart); - else if (RCNTRL[1] > ZERO) - Hmax = MIN(ABS(RCNTRL[1]),ABS(Tend-Tstart)); - else { - printf( "User-selected Hmax: RCNTRL[1]=%f", RCNTRL[1] ); - return ros_ErrorMsg(-3,Tstart,ZERO); - } - -/*~~~> Starting step size: (positive value) */ - if (RCNTRL[2] == ZERO) { - Hstart = MAX(Hmin,DeltaMin); - } - else if (RCNTRL[2] > ZERO) - Hstart = MIN(ABS(RCNTRL[2]),ABS(Tend-Tstart)); - else { - printf( "User-selected Hstart: RCNTRL[2]=%f", RCNTRL[2] ); - return ros_ErrorMsg(-3,Tstart,ZERO); - } - -/*~~~> Step size can be changed s.t. FacMin < Hnew/Hold < FacMax */ - if (RCNTRL[3] == ZERO) - FacMin = (KPP_REAL)0.2; - else if (RCNTRL[3] > ZERO) - FacMin = RCNTRL[3]; - else { - printf( "User-selected FacMin: RCNTRL[3]=%f", RCNTRL[3] ); - return ros_ErrorMsg(-4,Tstart,ZERO); - } - if (RCNTRL[4] == ZERO) - FacMax = (KPP_REAL)6.0; - else if (RCNTRL[4] > ZERO) - FacMax = RCNTRL[4]; - else { - printf( "User-selected FacMax: RCNTRL[4]=%f", RCNTRL[4] ); - return ros_ErrorMsg(-4,Tstart,ZERO); - } - -/*~~~> FacRej: Factor to decrease step after 2 succesive rejections */ - if (RCNTRL[5] == ZERO) - FacRej = (KPP_REAL)0.1; - else if (RCNTRL[5] > ZERO) - FacRej = RCNTRL[5]; - else { - printf( "User-selected FacRej: RCNTRL[5]=%f", RCNTRL[5] ); - return ros_ErrorMsg(-4,Tstart,ZERO); - } - -/*~~~> FacSafe: Safety Factor in the computation of new step size */ - if (RCNTRL[6] == ZERO) - FacSafe = (KPP_REAL)0.9; - else if (RCNTRL[6] > ZERO) - FacSafe = RCNTRL[6]; - else { - printf( "User-selected FacSafe: RCNTRL[6]=%f", RCNTRL[6] ); - return ros_ErrorMsg(-4,Tstart,ZERO); - } - -/*~~~> Check if tolerances are reasonable */ - for(i=0; i < UplimTol; i++) { - if ( (AbsTol[i] <= ZERO) || (RelTol[i] <= (KPP_REAL)10.0*Roundoff) - || (RelTol[i] >= (KPP_REAL)1.0) ) { - printf( " AbsTol[%d] = %f", i, AbsTol[i] ); - printf( " RelTol[%d] = %f", i, RelTol[i] ); - return ros_ErrorMsg(-5,Tstart,ZERO); - } - } - -/*~~~> Allocate checkpoint space or open checkpoint files */ - if (AdjointType == Adj_discrete) { - ros_AllocateDBuffers( ros_S, SaveLU ); - } - else if ( (AdjointType == Adj_continuous) || - (AdjointType == Adj_simple_continuous) ) { - ros_AllocateCBuffers(); - } - -/*~~~> CALL Forward Rosenbrock method */ - IERR = ros_FwdInt(Y, Tstart, Tend, Texit, AbsTol, RelTol, AdjointType, Hmin, - Hstart, Hmax, Roundoff, ISTATUS, Max_no_steps, - RSTATUS, Autonomous, VectorTol, FacMax, FacMin, - FacSafe, FacRej, SaveLU); - - printf( "\n\nFORWARD STATISTICS\n" ); - printf( "Step=%d Acc=%d Rej=%d Singular=%d\n\n", Nstp, Nacc, Nrej, Nsng ); - -/*~~~> If Forward integration failed return */ - if (IERR<0) - return IERR; - -/*~~~> Initialize the particular Rosenbrock method for continuous adjoint */ - if ( (AdjointType == Adj_continuous) || - (AdjointType == Adj_simple_continuous) ) { - switch (CadjMethod) { - case 1: - Ros2(); - break; - case 2: - Ros3(); - break; - case 3: - Ros4(); - break; - case 4: - Rodas3(); - break; - case 5: - Rodas4(); - break; - default: - printf( "Unknown Rosenbrock method: ICNTRL[2]=%d", ICNTRL[2] ); - return ros_ErrorMsg(-2,Tstart,ZERO); - } - } /* End switch */ - - switch( AdjointType ) { - case Adj_discrete: - IERR = ros_DadjInt (NADJ, Lambda, Tstart, Tend, Texit, SaveLU, ISTATUS, - Roundoff, Autonomous ); - break; - case Adj_continuous: - IERR = ros_CadjInt (NADJ, Lambda, Tend, Tstart, Texit, AbsTol_adj, - RelTol_adj, RSTATUS, Hmin, Hmax, Hstart, Roundoff, - Max_no_steps, Autonomous, VectorTol, FacMax, FacMin, - FacSafe, FacRej, ISTATUS); - break; - case Adj_simple_continuous: - IERR = ros_SimpleCadjInt (NADJ, Lambda, Tstart, Tend, Texit, ISTATUS, - Autonomous, Roundoff); - } /* End switch for AdjointType */ - - printf( "ADJOINT STATISTICS\n" ); - printf( "Step=%d Acc=%d Rej=%d Singular=%d\n",Nstp,Nacc,Nrej,Nsng ); - -/*~~~> Free checkpoint space or close checkpoint files */ - if (AdjointType == Adj_discrete) - ros_FreeDBuffers( SaveLU ); - else if ( (AdjointType == Adj_continuous) || - (AdjointType == Adj_simple_continuous) ) - ros_FreeCBuffers(); - - return IERR; -} - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void ros_AllocateDBuffers( int S, int SaveLU ) { -/*~~~> Allocate buffer space for discrete adjoint -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - - int i; - - chk_H = (KPP_REAL*) malloc(bufsize * sizeof(KPP_REAL)); - if (chk_H == NULL) { - printf("Failed allocation of buffer H"); - exit(0); - } - - chk_T = (KPP_REAL*) malloc(bufsize * sizeof(KPP_REAL)); - if (chk_T == NULL) { - printf("Failed allocation of buffer T"); - exit(0); - } - - chk_Y = (KPP_REAL**) malloc(bufsize * sizeof(KPP_REAL*)); - if (chk_Y == NULL) { - printf("Failed allocation of buffer Y"); - exit(0); - } - for(i=0; i Deallocate buffer space for discrete adjoint -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - - int i; - - free(chk_H); - free(chk_T); - - for(i=0; i Allocate buffer space for continuous adjoint -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - - int i; - - chk_H = (KPP_REAL*) malloc(bufsize * sizeof(KPP_REAL)); - if (chk_H == NULL) { - printf( "Failed allocation of buffer H"); - exit(0); - } - - chk_T = (KPP_REAL*) malloc(bufsize * sizeof(KPP_REAL)); - if (chk_T == NULL) { - printf( "Failed allocation of buffer T"); - exit(0); - } - - chk_Y = (KPP_REAL**) malloc(sizeof(KPP_REAL*) * bufsize); - if (chk_Y == NULL) { - printf( "Failed allocation of buffer Y"); - exit(0); - } - for(i=0; i Dallocate buffer space for continuous adjoint -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - - int i; - - free(chk_H); - free(chk_T); - - for(i=0; i Saves the next trajectory snapshot for discrete adjoints -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - - int i; - - stack_ptr = stack_ptr + 1; - if ( stack_ptr >= bufsize ) { - printf( "Push failed: buffer overflow" ); - exit(0); - } - - chk_H[ stack_ptr ] = H; - chk_T[ stack_ptr ] = T; - for(i=0; i Retrieves the next trajectory snapshot for discrete adjoints -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - - int i; - - if ( stack_ptr < 0 ) { - printf( "Pop failed: empty buffer" ); - exit(0); - } - - *H = chk_H[ stack_ptr ]; - *T = chk_T[ stack_ptr ]; - - for(i=0; i Saves the next trajectory snapshot for discrete adjoints -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - - int i; - - stack_ptr++; - if ( stack_ptr > bufsize ) { - printf( "Push failed: buffer overflow" ); - exit(0); - } - chk_H[ stack_ptr ] = H; - chk_T[ stack_ptr ] = T; - - for(i = 0; i< NVAR; i++ ) { - chk_Y[stack_ptr][i] = Y[i]; - chk_dY[stack_ptr][i] = dY[i]; - chk_d2Y[stack_ptr][i] = d2Y[i]; - } -} /* End of ros_CPush */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void ros_CPop( KPP_REAL T, KPP_REAL H, KPP_REAL Y[], KPP_REAL dY[], - KPP_REAL d2Y[] ) { -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -~~~> Retrieves the next trajectory snapshot for discrete adjoints -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - - int i; - - if ( stack_ptr <= 0 ) { - printf( "Pop failed: empty buffer" ); - exit(0); - } - H = chk_H[ stack_ptr ]; - T = chk_T[ stack_ptr ]; - - for(i=0; i Improper value for maximal no of steps" ); - break; - case -2: - printf( "--> Selected RosenbrockADJ method not implemented" ); - break; - case -3: - printf( "--> Hmin/Hmax/Hstart must be positive" ); - break; - case -4: - printf( "--> FacMin/FacMax/FacRej must be positive" ); - break; - case -5: - printf( "--> Improper tolerance values" ); - break; - case -6: - printf( "--> No of steps exceeds maximum buffer bound" ); - break; - case -7: - printf( "--> Step size too small: T + 10*H = T or H < Roundoff" ); - break; - case -8: - printf( "--> Matrix is repeatedly singular" ); - break; - case -9: - printf( "--> Improper type of adjoint selected" ); - break; - default: - printf( "Unknown Error code: %d", Code ); - } /* End of switch */ - - return IERR; -} /* End of ros_ErrorMsg */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -int ros_FwdInt ( KPP_REAL Y[], KPP_REAL Tstart, KPP_REAL Tend, KPP_REAL T, - KPP_REAL AbsTol[], KPP_REAL RelTol[], int AdjointType, - KPP_REAL Hmin, KPP_REAL Hstart, KPP_REAL Hmax, - KPP_REAL Roundoff, int ISTATUS[], int Max_no_steps, - KPP_REAL RSTATUS[], int Autonomous, int VectorTol, - KPP_REAL FacMax, KPP_REAL FacMin, KPP_REAL FacSafe, - KPP_REAL FacRej, int SaveLU ) { -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Template for the implementation of a generic RosenbrockADJ method - defined by ros_S (no of stages) - and its coefficients ros_{A,C,M,E,Alpha,Gamma} -~~~> Y - Input: the initial condition at Tstart; Output: the solution at T -~~~> Tstart, Tend - Input: integration interval -~~~> T - Output: time at which the solution is returned (T=Tend if success) -~~~> AbsTol, RelTol - Input: tolerances -~~~> IERR - Output: Error indicator -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - -/* ~~~~ Local variables */ - KPP_REAL Ynew[NVAR], Fcn0[NVAR], Fcn[NVAR]; - KPP_REAL K[NVAR*ros_S], dFdT[NVAR]; - KPP_REAL *Ystage = NULL; /* Array pointer */ -#ifdef FULL_ALGEBRA - KPP_REAL Jac0[NVAR][NVAR], Ghimj[NVAR][NVAR]; -#else - KPP_REAL Jac0[LU_NONZERO], Ghimj[LU_NONZERO]; -#endif - KPP_REAL H, Hnew, HC, HG, Fac, Tau; - KPP_REAL Err, Yerr[NVAR]; - int Pivot[NVAR], Direction, ioffset, i, j=0, istage; - int RejectLastH, RejectMoreH, Singular; /* Boolean Values */ -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - -/*~~~> Allocate stage vector buffer if needed */ - if (AdjointType == Adj_discrete) { - Ystage = (KPP_REAL*) malloc(NVAR*ros_S*sizeof(KPP_REAL)); - /* Uninitialized Ystage may lead to NaN on some compilers */ - if (Ystage == NULL) { - printf( "Allocation of Ystage failed" ); - exit(0); - } - } - -/*~~~> Initial preparations */ - T = Tstart; - RSTATUS[Nhexit] = ZERO; - H = MIN( MAX(ABS(Hmin),ABS(Hstart)) , ABS(Hmax) ); - if (ABS(H) <= ((KPP_REAL)10.0)*Roundoff) - H = DeltaMin; - - if (Tend >= Tstart) - Direction = 1; - else - Direction = -1; - - H = Direction*H; - - RejectLastH = FALSE; - RejectMoreH = FALSE; - -/*~~~> Time loop begins below */ - while ( ((Direction > 0) && ((T-Tend)+Roundoff <= ZERO)) || - ((Direction < 0) && ((Tend-T)+Roundoff <= ZERO)) ) { /* TimeLoop */ - - if ( ISTATUS[Nstp] > Max_no_steps ) /* Too many steps */ - return ros_ErrorMsg(-6,T,H); - - if ( ((T+((KPP_REAL)0.1)*H) == T) || (H <= Roundoff) ) /* Step size - too small */ - return ros_ErrorMsg(-7,T,H); - -/*~~~> Limit H if necessary to avoid going beyond Tend */ - RSTATUS[Nhexit] = H; - H = MIN(H,ABS(Tend-T)); - -/*~~~> Compute the function at current time */ - FunTemplate(T,Y,Fcn0); - ISTATUS[Nfun] = ISTATUS[Nfun] + 1; - -/*~~~> Compute the function derivative with respect to T */ - if (!Autonomous) - ros_FunTimeDerivative ( T, Roundoff, Y, Fcn0, dFdT, ISTATUS ); - -/*~~~> Compute the Jacobian at current time */ - JacTemplate(T,Y,Jac0); - ISTATUS[Njac] = ISTATUS[Njac] + 1; - -/*~~~> Repeat step calculation until current step accepted */ - do { /* UntilAccepted */ - - Singular = ros_PrepareMatrix ( H,Direction,ros_Gamma[0],Jac0,Ghimj,Pivot, - ISTATUS ); - - if (Singular) /* More than 5 consecutive failed decompositions */ - return ros_ErrorMsg(-8,T,H); - -/*~~~> Compute the stages */ - for( istage = 0; istage < ros_S; istage++ ) { /* Stage */ - - /* Current istage offset. Current istage vector is - K(ioffset+1:ioffset+NVAR) */ - ioffset = NVAR*istage; - - /*For the 1st istage the function has been computed previously*/ - if ( istage == 0 ) { - WCOPY(NVAR,Fcn0,1,Fcn,1); - if (AdjointType == Adj_discrete) { /* Save stage solution */ - for(i=0; i0 and a new function evaluation is needed at the - current istage */ - else if ( ros_NewF[istage] ) { - WCOPY(NVAR,Y,1,Ynew,1); - for ( j = 0; j < istage; j++ ) { - WAXPY( NVAR,ros_A[(istage)*(istage-1)/2+j], - &K[NVAR*j],1,Ynew,1 ); - } - Tau = T + ros_Alpha[istage]*Direction*H; - FunTemplate(Tau,Ynew,Fcn); - ISTATUS[Nfun] = ISTATUS[Nfun] + 1; - } /* if istage == 1 elseif ros_NewF[istage] */ - - /* Save stage solution every time even if ynew is not updated */ - if ( ( istage > 0 ) && (AdjointType == Adj_discrete) ) { - for(i=0; i Compute the new solution */ - WCOPY(NVAR,Y,1,Ynew,1); - for( j=0; j Compute the error estimation */ - WSCAL(NVAR,ZERO,Yerr,1); - for( j=0; j New step size is bounded by FacMin <= Hnew/H <= FacMax */ - Fac = MIN(FacMax,MAX(FacMin,FacSafe/pow(Err,(ONE/ros_ELO)))); - Hnew = H*Fac; - -/*~~~> Check the error magnitude and adjust step size */ - ISTATUS[Nstp] = ISTATUS[Nstp] + 1; - if ( (Err <= ONE) || (H <= Hmin) ) { /*~~~> Accept step */ - ISTATUS[Nacc]++; - if (AdjointType == Adj_discrete) { /* Save current state */ - ros_DPush( ros_S, T, H, Ystage, K, Ghimj, Pivot, SaveLU ); - } - else if ( (AdjointType == Adj_continuous) || - (AdjointType == Adj_simple_continuous) ) { -#ifdef FULL_ALGEBRA - K = MATMUL(Jac0,Fcn0); -#else - Jac_SP_Vec( Jac0, Fcn0, &K[0] ); -#endif - if ( !Autonomous) - WAXPY(NVAR,ONE,dFdT,1,&K[0],1); - ros_CPush( T, H, Y, Fcn0, &K[0] ); - } - WCOPY(NVAR,Ynew,1,Y,1); - T = T + Direction*H; - Hnew = MAX(Hmin,MIN(Hnew,Hmax)); - if (RejectLastH) { /* No step size increase after a - rejected step */ - Hnew = MIN(Hnew,H); - } - RSTATUS[Nhexit] = H; - RSTATUS[Nhnew] = Hnew; - RSTATUS[Ntexit] = T; - RejectLastH = FALSE; - RejectMoreH = FALSE; - H = Hnew; - break; /* UntilAccepted - EXIT THE LOOP: WHILE STEP NOT ACCEPTED */ - } - - else { /*~~~> Reject step */ - if (RejectMoreH) - Hnew = H*FacRej; - RejectMoreH = RejectLastH; - RejectLastH = TRUE; - H = Hnew; - if (ISTATUS[Nacc] >= 1) - ISTATUS[Nrej]++; - } /* End if else - Err <= 1 */ - - } while(1); /* End of UntilAccepted do loop */ - } /* End of TimeLoop */ - -/*~~~> Save last state: only needed for continuous adjoint */ - if ( (AdjointType == Adj_continuous) || - (AdjointType == Adj_simple_continuous) ) { - FunTemplate(T,Y,Fcn0); - ISTATUS[Nfun]++; - JacTemplate(T,Y,Jac0); - ISTATUS[Njac]++; -#ifdef FULL_ALGEBRA - K = MATMUL(Jac0,Fcn0); -#else - Jac_SP_Vec( Jac0, Fcn0, &K[0] ); -#endif - if (!Autonomous) { - ros_FunTimeDerivative ( T, Roundoff, Y, Fcn0, dFdT, ISTATUS ); - WAXPY(NVAR,ONE,dFdT,1,&K[0],1); - } - ros_CPush( T, H, Y, Fcn0, &K[0] ); -/*~~~> Deallocate stage buffer: only needed for discrete adjoint */ - } - else if (AdjointType == Adj_discrete) { - free(Ystage); - } - -/*~~~> Succesful exit */ - return 1; /*~~~> The integration was successful */ -} /* End of ros_FwdInt */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -int ros_DadjInt ( int NADJ, KPP_REAL Lambda[][NVAR], KPP_REAL Tstart, - KPP_REAL Tend, KPP_REAL T, int SaveLU, int ISTATUS[], - KPP_REAL Roundoff, int Autonomous) { -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Template for the implementation of a generic RosenbrockSOA method - defined by ros_S (no of stages) - and its coefficients ros_{A,C,M,E,Alpha,Gamma} -!~~~> NADJ - Input: the initial condition at Tstart; Output: the solution at T -!~~~> Lambda[NADJ][NVAR] - First order adjoint -!~~~> Tstart, Tend - Input: integration interval -!~~~> T - Output: time at which the solution is returned (T=Tend if success) -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - -/*~~~~ Local variables */ - KPP_REAL Ystage[NVAR*ros_S], K[NVAR*ros_S]; - KPP_REAL U[NADJ][NVAR*ros_S], V[NADJ][NVAR*ros_S]; -#ifdef FULL_ALGEBRA - KPP_REAL Jac[NVAR][NVAR], dJdT[NVAR][NVAR], Ghimj[NVAR][NVAR]; -#else - KPP_REAL Jac[LU_NONZERO], dJdT[LU_NONZERO], Ghimj[LU_NONZERO]; -#endif - KPP_REAL Hes0[NHESS]; - KPP_REAL Tmp[NVAR], Tmp2[NVAR]; - KPP_REAL H=0.0, HC, HA, Tau; - int Pivot[NVAR], Direction; - int i, j, m, istage, istart, jstart; -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - - if (Tend >= Tstart) - Direction = 1; - else - Direction = -1; - - /*~~~> Time loop begins below */ - while ( stack_ptr > 0 ) { /* TimeLoop */ - - /*~~~> Recover checkpoints for stage values and vectors */ - ros_DPop( ros_S, &T, &H, &Ystage[0], &K[0], &Ghimj[0], &Pivot[0], SaveLU ); - - /*~~~> Compute LU decomposition */ - if (!SaveLU) { - JacTemplate(T,&Ystage[0],Ghimj); - ISTATUS[Njac] = ISTATUS[Njac] + 1; - Tau = ONE/(Direction*H*ros_Gamma[0]); -#ifdef FULL_ALGEBRA - for(j=0; j Compute Hessian at the beginning of the interval */ - HessTemplate(T,&Ystage[0],Hes0); - -/*~~~> Compute the stages */ - for (istage = ros_S - 1; istage >= 0; istage--) { /* Stage loop */ - - /*~~~> Current istage first entry */ - istart = NVAR*istage; - - /*~~~> Compute U */ - for (m = 0; m Compute V */ - Tau = T + ros_Alpha[istage]*Direction*H; - JacTemplate(Tau,&Ystage[istart],Jac); - ISTATUS[Njac]++; - for ( m = 0; m < NADJ; m++ ) { -#ifdef FULL_ALGEBRA - for (i=istart; i < istart+NVAR-1; i++ ) - V[[m][i] = MATMUL(TRANSPOSE(Jac),U[m][i]]; -#else - JacTR_SP_Vec(Jac,&U[m][istart],&V[m][istart]); -#endif - } /* m=0:NADJ-1 */ - } /*End of Stage loop */ - - if (!Autonomous) -/*~~~> Compute the Jacobian derivative with respect to T. - Last "Jac" computed for stage 1 */ - ros_JacTimeDerivative ( T, Roundoff, &Ystage[0], Jac, dJdT, ISTATUS ); - -/*~~~> Compute the new solution */ - /*~~~> Compute Lambda */ - for( istage = 0; istage < ros_S; istage++ ) { - istart = NVAR*istage; - for (m = 0; m < NADJ; m++) { - /* Add V_i */ - WAXPY(NVAR,ONE,&V[m][istart],1,&Lambda[m][0],1); - /* Add (H0xK_i)^T * U_i */ - HessTR_Vec ( Hes0, &U[m][istart], &K[istart], Tmp ); - WAXPY(NVAR,ONE,Tmp,1,&Lambda[m][0],1); - } /* m=0:NADJ-1 */ - } - - /* Add H * dJac_dT_0^T * \sum(gamma_i U_i) */ - /* Tmp holds sum gamma_i U_i */ - if (!Autonomous) { - for( m = 0; m < NADJ; m++ ) { - for(i=0; i Save last state */ - /*~~~> Succesful exit */ - return 1; /*~~~> The integration was successful */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -} /* End of ros_DadjInt */ -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -int ros_CadjInt ( int NADJ, KPP_REAL Y[][NVAR], KPP_REAL Tstart, KPP_REAL Tend, - KPP_REAL T, KPP_REAL AbsTol_adj[][NVAR], - KPP_REAL RelTol_adj[][NVAR], KPP_REAL RSTATUS[], - KPP_REAL Hmin, KPP_REAL Hmax, KPP_REAL Hstart, - KPP_REAL Roundoff, int Max_no_steps, int Autonomous, - int VectorTol, KPP_REAL FacMax, KPP_REAL FacMin, - KPP_REAL FacSafe, KPP_REAL FacRej, int ISTATUS[] ) { -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Template for the implementation of a generic RosenbrockADJ method - defined by ros_S (no of stages) - and its coefficients ros_{A,C,M,E,Alpha,Gamma} -~~~> NADJ, Y[NADJ][NVAR] - Input: the initial condition at Tstart; - Output: the solution at T -~~~> Tstart, Tend - Input: integration interval -~~~> AbsTol_adj[NADJ][NVAR], RelTol_adj[NADJ][NVAR] - Input: adjoint tolerances -~~~> T - Output: time at which the solution is returned (T=Tend if success) -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - -/*~~~~ Local variables */ - KPP_REAL Y0[NVAR]; - KPP_REAL Ynew[NADJ][NVAR], Fcn0[NADJ][NVAR], Fcn[NADJ][NVAR]; - KPP_REAL K[NADJ][NVAR*ros_S], dFdT[NADJ][NVAR]; -#ifdef FULL_ALGEBRA - KPP_REAL Jac0[NVAR][NVAR], Ghimj[NVAR][NVAR], Jac[NVAR][NVAR], - dJdT[NVAR][NVAR]; -#else - KPP_REAL Jac0[LU_NONZERO], Ghimj[LU_NONZERO], Jac[LU_NONZERO], - dJdT[LU_NONZERO]; -#endif - KPP_REAL H, Hnew, HC, HG, Fac, Tau; - KPP_REAL Err, Yerr[NADJ][NVAR]; - int Pivot[NVAR], Direction, ioffset, j, istage, iadj; - int RejectLastH, RejectMoreH, Singular; /* Boolean values */ -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - -/*~~~> Initial preparations */ - T = Tstart; - RSTATUS[Nhexit] = (KPP_REAL)0.0; - H = MIN( MAX(ABS(Hmin),ABS(Hstart)) , ABS(Hmax) ); - if (ABS(H) <= ((KPP_REAL)10.0)*Roundoff) - H = DeltaMin; - - if (Tend >= Tstart) - Direction = 1; - else - Direction = -1; - - H = Direction*H; - RejectLastH = FALSE; - RejectMoreH = FALSE; - -/*~~~> Time loop begins below */ - while ( ((Direction > 0) && ((T-Tend)+Roundoff <= ZERO)) - || ((Direction < 0) && ((Tend-T)+Roundoff <= ZERO)) ) { /*TimeLoop*/ - - if ( ISTATUS[Nstp] > Max_no_steps ) /* Too many steps */ - return ros_ErrorMsg(-6,T,H); - - /* Step size too small */ - if ( ((T+((KPP_REAL)0.1)*H) == T) || (H <= Roundoff) ) - return ros_ErrorMsg(-7,T,H); - -/*~~~> Limit H if necessary to avoid going beyond Tend */ - RSTATUS[Nhexit] = H; - H = MIN(H,ABS(Tend-T)); - -/*~~~> Interpolate forward solution */ - ros_cadj_Y( T, Y0 ); -/*~~~> Compute the Jacobian at current time */ - JacTemplate(T, Y0, Jac0); - ISTATUS[Njac]++; - -/*~~~> Compute the function derivative with respect to T */ - if (!Autonomous) { - ros_JacTimeDerivative ( T, Roundoff, Y0, Jac0, dJdT, ISTATUS ); - for (iadj = 0; iadj < NADJ; iadj++) { -#ifdef FULL_ALGEBRA - for (i=0; i Ydot = -J^T*Y */ -#ifdef FULL_ALGEBRA - int i; - for(i=0; i Repeat step calculation until current step accepted */ - do { /* UntilAccepted */ - - Singular = ros_PrepareMatrix(H,Direction,ros_Gamma[0], Jac0,Ghimj,Pivot, - ISTATUS); - if (Singular) /* More than 5 consecutive failed decompositions */ - return ros_ErrorMsg(-8,T,H); - -/*~~~> Compute the stages */ - for ( istage = 0; istage < ros_S; istage++ ) { /* Stage loop */ - - /* Current istage offset. Current istage vector - is K[ioffset+1:ioffset+NVAR] */ - ioffset = NVAR*(istage-1); - - /* For the 1st istage the function has been computed previously */ - if ( istage == 0 ) { - for ( iadj = 0; iadj < NADJ; iadj++ ) - WCOPY(NVAR,&Fcn0[iadj][0],1,&Fcn[iadj][0],1); - - /* istage>0 and a new function evaluation is needed at - the current istage */ - } - else if ( ros_NewF[istage] ) { - WCOPY(NVAR*NADJ,&Y[0][0],1,&Ynew[0][0],1); - for (j = 0; j < istage-1; j++) { - for ( iadj = 0; iadj < NADJ; iadj++ ) - WAXPY( NVAR,ros_A[(istage-1)*(istage-2)/2+j], - &K[iadj][NVAR*(j-1)+1],1,&Ynew[iadj][0],1); - } /* End for loop */ - Tau = T + ros_Alpha[istage]*Direction*H; - ros_cadj_Y( Tau, Y0 ); - JacTemplate(Tau, Y0, Jac); - ISTATUS[Njac]++; - -#ifdef FULL_ALGEBRA - for(i=0; i Compute the new solution */ - for ( iadj = 0; iadj < NADJ; iadj++ ) { - WCOPY(NVAR,&Y[iadj][0],1,&Ynew[iadj][0],1); - for ( j=0; j Compute the error estimation */ - WSCAL(NVAR*NADJ,ZERO,&Yerr[0][0],1); - for ( j=0; j Max error among all adjoint components */ - iadj = 1; - Err = ros_ErrorNorm ( &Y[iadj][0], &Ynew[iadj][0], &Yerr[iadj][0], - &AbsTol_adj[iadj][0], &RelTol_adj[iadj][0], - VectorTol ); - -/*~~~> New step size is bounded by FacMin <= Hnew/H <= FacMax */ - Fac = MIN(FacMax,MAX(FacMin,FacSafe/pow(Err,(ONE/ros_ELO)))); - Hnew = H*Fac; - -/*~~~> Check the error magnitude and adjust step size */ - /* ISTATUS[Nstp] = ISTATUS[Nstp] + 1 */ - if ( (Err <= ONE) || (H <= Hmin) ) { /*~~~> Accept step */ - ISTATUS[Nacc] = ISTATUS[Nacc] + 1; - WCOPY(NVAR*NADJ,&Ynew[0][0],1,&Y[0][0],1); - T = T + Direction*H; - Hnew = MAX(Hmin,MIN(Hnew,Hmax)); - if (RejectLastH) /* No step size increase after a rejected step */ - Hnew = MIN(Hnew,H); - RSTATUS[Nhexit] = H; - RSTATUS[Nhnew] = Hnew; - RSTATUS[Ntexit] = T; - RejectLastH = FALSE; - RejectMoreH = FALSE; - H = Hnew; - break; /* UntilAccepted - EXIT THE LOOP: WHILE STEP NOT ACCEPTED */ - } - else { /*~~~> Reject step */ - if (RejectMoreH) - Hnew = H*FacRej; - RejectMoreH = RejectLastH; - RejectLastH = TRUE; - H = Hnew; - if (ISTATUS[Nacc] >= 1) - ISTATUS[Nrej]++; - } /* Err <= 1 */ - - } while(1); /* End of UntilAccepted do loop */ - - } /* End of TimeLoop */ - - /*~~~> Succesful exit */ - return 1; /*~~~> The integration was successful */ -} /* End of ros_CadjInt */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -int ros_SimpleCadjInt ( int NADJ, KPP_REAL Y[][NVAR], KPP_REAL Tstart, - KPP_REAL Tend, KPP_REAL T, int ISTATUS[], - int Autonomous, KPP_REAL Roundoff ) { -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Template for the implementation of a generic RosenbrockADJ method - defined by ros_S (no of stages) - and its coefficients ros_{A,C,M,E,Alpha,Gamma} -~~~> NADJ, Y[NADJ][NVAR] - Input: the initial condition at Tstart; - Output: the solution at T -~~~> Tstart, Tend - Input: integration interval -~~~> T - Output: time at which the solution is returned (T=Tend if success) -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - -/*~~~~ Local variables */ - KPP_REAL Y0[NVAR]; - KPP_REAL Ynew[NADJ][NVAR], Fcn0[NADJ][NVAR], Fcn[NADJ][NVAR]; - KPP_REAL K[NADJ][NVAR*ros_S], dFdT[NADJ][NVAR]; -#ifdef FULL_ALGEBRA - KPP_REAL Jac0[NVAR][NVAR], Ghimj[NVAR][NVAR], Jac[NVAR][NVAR], - dJdT[NVAR][NVAR]; -#else - KPP_REAL Jac0[LU_NONZERO], Ghimj[LU_NONZERO], Jac[LU_NONZERO], - dJdT[LU_NONZERO]; -#endif - KPP_REAL H, HC, HG, Tau; - KPP_REAL ghinv; - int Pivot[NVAR], Direction, ioffset, i, j, istage, iadj; - int istack; - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - -/*~~~> INITIAL PREPARATIONS */ - if (Tend >= Tstart) - Direction = -1; - else - Direction = 1; - -/*~~~> Time loop begins below */ - for( istack = stack_ptr; istack >= 1; istack-- ) { /* TimeLoop */ - T = chk_T[istack]; - H = chk_H[istack-1]; - for(i=0; i Compute the Jacobian at current time */ - JacTemplate(T, Y0, Jac0); - ISTATUS[Njac] = ISTATUS[Njac] + 1; - -/*~~~> Compute the function derivative with respect to T */ - if (!Autonomous) { - ros_JacTimeDerivative ( T, Roundoff, Y0, Jac0, dJdT, ISTATUS ); - for ( iadj = 0; iadj < NADJ; iadj++ ) { -#ifdef FULL_ALGEBRA - for( i=0; i Ydot = -J^T*Y */ -#ifdef FULL_ALGEBRA - for(i=0; i Construct Ghimj = 1/(H*ham) - Jac0 */ - ghinv = ONE/(Direction*H*ros_Gamma[0]); -#ifdef FULL_ALGEBRA - for(i=0; i Compute LU decomposition */ - ros_Decomp( Ghimj, Pivot, &j, ISTATUS ); - if (j != 0) { - ros_ErrorMsg(-8,T,H); - printf( "The matrix is singular !"); - exit(0); - } - -/*~~~> Compute the stages */ - for(istage=0; istage=1 and a new function evaluation is needed - at the current istage */ - else if ( ros_NewF[istage] ) { - WCOPY(NVAR*NADJ,&Y[0][0],1,&Ynew[0][0],1); - for(j=0; j Compute the new solution */ - for(iadj=0; iadj Succesful exit */ - return 1; /*~~~> The integration was successful */ - -} /* End of ros_SimpleCadjInt */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -KPP_REAL ros_ErrorNorm ( KPP_REAL Y[], KPP_REAL Ynew[], KPP_REAL Yerr[], - KPP_REAL AbsTol[], KPP_REAL RelTol[], int VectorTol ) { -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -~~~> Computes the "scaled norm" of the error vector Yerr -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - -/* Local variables */ - KPP_REAL Err, Scale, Ymax; - int i; - - Err = ZERO; - for(i=0; i The time partial derivative of the function by finite differences -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - -/*~~~> Local variables */ - KPP_REAL Delta; - - Delta = SQRT(Roundoff)*MAX(DeltaMin,ABS(T)); - FunTemplate(T+Delta,Y,dFdT); - ISTATUS[Nfun]++; - WAXPY(NVAR,(-ONE),Fcn0,1,dFdT,1); - WSCAL(NVAR,(ONE/Delta),dFdT,1); - -} /* End of ros_FunTimeDerivative */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void ros_JacTimeDerivative ( KPP_REAL T, KPP_REAL Roundoff, KPP_REAL Y[], - KPP_REAL Jac0[], KPP_REAL dJdT[], int ISTATUS[]) { -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -~~~> The time partial derivative of the Jacobian by finite differences -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - -/*~~~> Local variables */ - KPP_REAL Delta; - - Delta = SQRT(Roundoff)*MAX(DeltaMin,ABS(T)); - JacTemplate(T+Delta,Y,dJdT); - ISTATUS[Njac]++; -#ifdef FULL_ALGEBRA - WAXPY(NVAR*NVAR,(-ONE),Jac0,1,dJdT,1); - WSCAL(NVAR*NVAR,(ONE/Delta),dJdT,1); -#else - WAXPY(LU_NONZERO,(-ONE),Jac0,1,dJdT,1); - WSCAL(LU_NONZERO,(ONE/Delta),dJdT,1); -#endif -} /* End of ros_JacTimeDerivative */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -int ros_PrepareMatrix ( KPP_REAL H, int Direction, KPP_REAL gam, - KPP_REAL Jac0[], KPP_REAL Ghimj[], int Pivot[], - int ISTATUS[] ) { -/* --- --- --- --- --- --- --- --- --- --- --- --- --- - Prepares the LHS matrix for stage calculations - 1. Construct Ghimj = 1/(H*gam) - Jac0 - "(Gamma H) Inverse Minus Jacobian" - 2. Repeat LU decomposition of Ghimj until successful. - -half the step size if LU decomposition fails and retry - -exit after 5 consecutive fails - --- --- --- --- --- --- --- --- --- --- --- --- --- */ - -/*~~~> Local variables */ - int i, ising, Nconsecutive; - int Singular; /* Boolean value */ - KPP_REAL ghinv; - - Nconsecutive = 0; - Singular = TRUE; - - while (Singular) { - -/*~~~> Construct Ghimj = 1/(H*gam) - Jac0 */ -#ifdef FULL_ALGEBRA - WCOPY(NVAR*NVAR,Jac0,1,Ghimj,1); - WSCAL(NVAR*NVAR,(-ONE),Ghimj,1); - ghinv = ONE/(Direction*H*gam); - for(i=0; i Compute LU decomposition */ - ros_Decomp( Ghimj, Pivot, &ising, ISTATUS ); - if (ising == 0) -/*~~~> If successful done */ - Singular = FALSE; - - else { /* ising != 0 */ -/*~~~> If unsuccessful half the step size; - if 5 consecutive fails then return */ - ISTATUS[Nsng]++; - Nconsecutive++; - Singular = TRUE; - printf( "Warning: LU Decomposition returned ising = %d", ising ); - if (Nconsecutive <= 5) /*Less than 5 consecutive failed decompositions*/ - H = H*HALF; - else /* More than 5 consecutive failed decompositions */ - return Singular; - - } /* End of ising */ - } /* while Singular */ - - return Singular; -} /* End of ros_PrepareMatrix */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void ros_Decomp( KPP_REAL A[], int Pivot[], int* ising, int ISTATUS[] ) { -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Template for the LU decomposition -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - -#ifdef FULL_ALGEBRA - DGETRF( NVAR, NVAR, A, NVAR, Pivot, ising ); -#else - *ising = KppDecomp ( A ); - Pivot[0] = 1; -#endif - ISTATUS[Ndec]++; - -} /* End of ros_Decomp */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void ros_Solve( char How, KPP_REAL A[], int Pivot[], KPP_REAL b[], - int ISTATUS[] ) { -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Template for the forward/backward substitution - (using pre-computed LU decomposition) -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - switch (How) { - case 'N': -#ifdef FULL_ALGEBRA - DGETRS( 'N', NVAR , 1, A, NVAR, Pivot, b, NVAR, 0 ); -#else - KppSolve( A, b ); -#endif - break; - case 'T': -#ifdef FULL_ALGEBRA - DGETRS( 'T', NVAR , 1, A, NVAR, Pivot, b, NVAR, 0 ); -#else - KppSolveTR( A, b, b ); -#endif - break; - default: - printf( "Error: unknown argument in ros_Solve: How=%d", How ); - exit(0); - } - ISTATUS[Nsol]++; - -} /* End of ros_Solve */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void ros_cadj_Y( KPP_REAL T, KPP_REAL Y[] ) { -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Finds the solution Y at T by interpolating the stored forward trajectory -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - -/*~~~> Local variables */ - int i,j; - - if( (T < chk_T[0]) || (T> chk_T[stack_ptr]) ) { - printf( "Cannot locate solution at T = %f", T ); - printf( "Stored trajectory is between Tstart = %f", chk_T[0] ); - printf( " and Tend = %f", chk_T[stack_ptr] ); - exit(0); - } - for(i=0; i= chk_T[i]) &&(T <= chk_T[i+1]) ) - exit(0); - } - - for(j=0; j Local variables */ - KPP_REAL Tau, amb[3], C[4][NVAR]; - int i, j; - - amb[0] = ((KPP_REAL)1.0)/(a-b); - for(i=1; i<3; i++) - amb[i] = amb[i-1]*amb[0]; - -/* c(1) = ya; */ - WCOPY(NVAR,Ya,1,&C[0][0],1); -/* c(2) = ja; */ - WCOPY(NVAR,Ja,1,&C[1][0],1); -/* c(3) = 2/(a-b)*ja + 1/(a-b)*jb - 3/(a - b)^2*ya + 3/(a - b)^2*yb; */ - WCOPY(NVAR,Ya,1,&C[2][0],1); - WSCAL(NVAR,-3.0*amb[1],&C[2][0],1); - WAXPY(NVAR,3.0*amb[1],Yb,1,&C[2][0],1); - WAXPY(NVAR,2.0*amb[0],Ja,1,&C[2][0],1); - WAXPY(NVAR,amb[0],Jb,1,&C[2][0],1); -/* c(4) = 1/(a-b)^2*ja + 1/(a-b)^2*jb - 2/(a-b)^3*ya + 2/(a-b)^3*yb */ - WCOPY(NVAR,Ya,1,&C[3][0],1); - WSCAL(NVAR,-2.0*amb[2],&C[3][0],1); - WAXPY(NVAR,2.0*amb[2],Yb,1,&C[3][0],1); - WAXPY(NVAR,amb[1],Ja,1,&C[3][0],1); - WAXPY(NVAR,amb[1],Jb,1,&C[3][0],1); - - Tau = T - a; - WCOPY(NVAR,&C[3][0],1,Y,1); - WSCAL(NVAR,pow(Tau,3),Y,1); - for(j=2; j>=0; j--) - WAXPY(NVAR,pow(Tau,(j-1)),&C[j][0],1,Y,1); - -} /* End of ros_Hermite3 */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void ros_Hermite5( KPP_REAL a, KPP_REAL b, KPP_REAL T, KPP_REAL Ya[], - KPP_REAL Yb[], KPP_REAL Ja[], KPP_REAL Jb[], KPP_REAL Ha[], - KPP_REAL Hb[], KPP_REAL Y[] ) { -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Template for Hermite interpolation of order 5 on the interval [a,b] - P = c(1) + c(2)*(x-a) + ... + c(6)*(x-a)^5 - P[a,b] = [Ya,Yb], P'[a,b] = [Ja,Jb], P"[a,b] = [Ha,Hb] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - -/*~~~> Local variables */ - KPP_REAL Tau, amb[5], C[6][NVAR]; - int i, j; - - amb[0] = ((KPP_REAL)1.0)/(a-b); - for(i=1; i<5; i++) - amb[i] = amb[i-1]*amb[0]; - -/* c(1) = ya; */ - WCOPY(NVAR,Ya,1,&C[0][0],1); -/* c(2) = ja; */ - WCOPY(NVAR,Ja,1,&C[1][0],1); -/* c(3) = ha/2; */ - WCOPY(NVAR,Ha,1,&C[2][0],1); - WSCAL(NVAR,HALF,&C[2][0],1); - -/* c(4) = 10*amb(3)*ya - 10*amb(3)*yb - 6*amb(2)*ja - 4*amb(2)*jb - + 1.5*amb(1)*ha - 0.5*amb(1)*hb ; */ - WCOPY(NVAR,Ya,1,&C[3][0],1); - WSCAL(NVAR,10.0*amb[2],&C[3][0],1); - WAXPY(NVAR,-10.0*amb[2],Yb,1,&C[3][0],1); - WAXPY(NVAR,-6.0*amb[1],Ja,1,&C[3][0],1); - WAXPY(NVAR,-4.0*amb[1],Jb,1,&C[3][0],1); - WAXPY(NVAR, 1.5*amb[0],Ha,1,&C[3][0],1); - WAXPY(NVAR,-0.5*amb[0],Hb,1,&C[3][0],1); - -/* c(5) = 15*amb(4)*ya - 15*amb(4)*yb - 8.*amb(3)*ja - 7*amb(3)*jb - + 1.5*amb(2)*ha - 1*amb(2)*hb ; */ - WCOPY(NVAR,Ya,1,&C[4][0],1); - WSCAL(NVAR, 15.0*amb[3],&C[4][0],1); - WAXPY(NVAR,-15.0*amb[3],Yb,1,&C[4][0],1); - WAXPY(NVAR,-8.0*amb[2],Ja,1,&C[4][0],1); - WAXPY(NVAR,-7.0*amb[2],Jb,1,&C[4][0],1); - WAXPY(NVAR,1.5*amb[1],Ha,1,&C[4][0],1); - WAXPY(NVAR,-amb[1],Hb,1,&C[4][0],1); - -/* c(6) = 6*amb(5)*ya - 6*amb(5)*yb - 3.*amb(4)*ja - 3.*amb(4)*jb - + 0.5*amb(3)*ha -0.5*amb(3)*hb ; */ - WCOPY(NVAR,Ya,1,&C[5][0],1); - WSCAL(NVAR, 6.0*amb[4],&C[5][0],1); - WAXPY(NVAR,-6.0*amb[4],Yb,1,&C[5][0],1); - WAXPY(NVAR,-3.0*amb[3],Ja,1,&C[5][0],1); - WAXPY(NVAR,-3.0*amb[3],Jb,1,&C[5][0],1); - WAXPY(NVAR, 0.5*amb[2],Ha,1,&C[5][0],1); - WAXPY(NVAR,-0.5*amb[2],Hb,1,&C[5][0],1); - - Tau = T - a; - WCOPY(NVAR,&C[5][0],1,Y,1); - for(j=4; j>=0; j--) { - WSCAL(NVAR,Tau,Y,1); - WAXPY(NVAR,ONE,&C[j][0],1,Y,1); - } - -} /* End of ros_Hermite5 */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void Ros2() { -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - --- AN L-STABLE METHOD, 2 stages, order 2 -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - - KPP_REAL g; - - g = (KPP_REAL)1.0 + ((KPP_REAL)1.0)/SQRT((KPP_REAL)2.0); - - rosMethod = RS2; -/*~~~> Name of the method */ - strcpy(ros_Name, "ROS-2"); -/*~~~> Number of stages */ - ros_S = 2; - -/*~~~> The coefficient matrices A and C are strictly lower triangular. - The lower triangular (subdiagonal) elements are stored in row-wise order: - A[0][1] = ros_A[0], A[0][2]=ros_A[1], A[1][2]=ros_A[2], etc. - The general mapping formula is: - A[i][j] = ros_A[ (i-1)*(i-2)/2 + j ] - C[i][j] = ros_C[ (i-1)*(i-2)/2 + j ] */ - - ros_A[0] = ((KPP_REAL)1.0)/g; - ros_C[0] = ((KPP_REAL)-2.0)/g; - -/*~~~> Does the stage i require a new function evaluation (ros_NewF[i]=TRUE) - or does it re-use the function evaluation from stage i-1 - (ros_NewF[i]=FALSE) */ - ros_NewF[0] = TRUE; - ros_NewF[1] = TRUE; - -/*~~~> M_i = Coefficients for new step solution */ - ros_M[0]= ((KPP_REAL)3.0)/((KPP_REAL)2.0*g); - ros_M[1]= ((KPP_REAL)1.0)/((KPP_REAL)2.0*g); - -/* E_i = Coefficients for error estimator */ - ros_E[0] = ((KPP_REAL)1.0)/((KPP_REAL)2.0*g); - ros_E[1] = ((KPP_REAL)1.0)/((KPP_REAL)2.0*g); - -/*~~~> ros_ELO = estimator of local order - the minimum between the - main and the embedded scheme orders plus one */ - ros_ELO = (KPP_REAL)2.0; - -/*~~~> Y_stage_i ~ Y( T + H*Alpha_i ) */ - ros_Alpha[0] = (KPP_REAL)0.0; - ros_Alpha[1] = (KPP_REAL)1.0; - -/*~~~> Gamma_i = \sum_j gamma_{i,j} */ - ros_Gamma[0] = g; - ros_Gamma[1] =-g; - -} /* End of Ros2 */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void Ros3() { -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - --- AN L-STABLE METHOD, 3 stages, order 3, 2 function evaluations -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - - rosMethod = RS3; -/*~~~> Name of the method */ - strcpy(ros_Name, "ROS-3"); -/*~~~> Number of stages */ - ros_S = 3; - -/*~~~> The coefficient matrices A and C are strictly lower triangular. - The lower triangular (subdiagonal) elements are stored in row-wise order: - A[0][1] = ros_A[0], A[0][2]=ros_A[1], A[1][2]=ros_A[2], etc. - The general mapping formula is: - A[i][j] = ros_A[ (i-1)*(i-2)/2 + j ] - C[i][j] = ros_C[ (i-1)*(i-2)/2 + j ] */ - - ros_A[0]= (KPP_REAL)1.0; - ros_A[1]= (KPP_REAL)1.0; - ros_A[2]= (KPP_REAL)0.0; - ros_C[0] = (KPP_REAL)-0.10156171083877702091975600115545e01; - ros_C[1] = (KPP_REAL) 0.40759956452537699824805835358067e01; - ros_C[2] = (KPP_REAL) 0.92076794298330791242156818474003e01; - -/*~~~> Does the stage i require a new function evaluation (ros_NewF[i]=TRUE) - or does it re-use the function evaluation from stage i-1 - (ros_NewF[i]=FALSE) */ - ros_NewF[0] = TRUE; - ros_NewF[1] = TRUE; - ros_NewF[2] = FALSE; -/*~~~> M_i = Coefficients for new step solution */ - ros_M[0] = (KPP_REAL) 0.1e01; - ros_M[1] = (KPP_REAL) 0.61697947043828245592553615689730e01; - ros_M[2] = (KPP_REAL)-0.42772256543218573326238373806514; -/* E_i = Coefficients for error estimator */ - ros_E[0] = (KPP_REAL) 0.5; - ros_E[1] = (KPP_REAL)-0.29079558716805469821718236208017e01; - ros_E[2] = (KPP_REAL) 0.22354069897811569627360909276199; - -/*~~~> ros_ELO = estimator of local order - the minimum between the - main and the embedded scheme orders plus 1 */ - ros_ELO = (KPP_REAL)3.0; -/*~~~> Y_stage_i ~ Y( T + H*Alpha_i ) */ - ros_Alpha[0]= (KPP_REAL)0.0; - ros_Alpha[1]= (KPP_REAL)0.43586652150845899941601945119356; - ros_Alpha[2]= (KPP_REAL)0.43586652150845899941601945119356; -/*~~~> Gamma_i = \sum_j gamma_{i,j} */ - ros_Gamma[0]= (KPP_REAL)0.43586652150845899941601945119356; - ros_Gamma[1]= (KPP_REAL)0.24291996454816804366592249683314; - ros_Gamma[2]= (KPP_REAL)0.21851380027664058511513169485832e01; - -} /* End of Ros3 */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void Ros4() { -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - L-STABLE ROSENBROCK METHOD OF ORDER 4, WITH 4 STAGES - L-STABLE EMBEDDED ROSENBROCK METHOD OF ORDER 3 - - E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL - EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS. - SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS, - SPRINGER-VERLAG (1990) -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - - rosMethod = RS4; -/*~~~> Name of the method */ - strcpy(ros_Name, "ROS-4"); -/*~~~> Number of stages */ - ros_S = 4; - -/*~~~> The coefficient matrices A and C are strictly lower triangular. - The lower triangular (subdiagonal) elements are stored in row-wise order: - A[0][1] = ros_A[0], A[0][2]=ros_A[1], A[1][2]=ros_A[2], etc. - The general mapping formula is: - A[i][j] = ros_A[ (i-1)*(i-2)/2 + j ] - C[i][j] = ros_C[ (i-1)*(i-2)/2 + j ] */ - - ros_A[0] = (KPP_REAL)0.2000000000000000e01; - ros_A[1] = (KPP_REAL)0.1867943637803922e01; - ros_A[2] = (KPP_REAL)0.2344449711399156; - ros_A[3] = ros_A[1]; - ros_A[4] = ros_A[2]; - ros_A[5] = (KPP_REAL)0.0; - - ros_C[0] = (KPP_REAL)-0.7137615036412310e01; - ros_C[1] = (KPP_REAL) 0.2580708087951457e01; - ros_C[2] = (KPP_REAL) 0.6515950076447975; - ros_C[3] = (KPP_REAL)-0.2137148994382534e01; - ros_C[4] = (KPP_REAL)-0.3214669691237626; - ros_C[5] = (KPP_REAL)-0.6949742501781779; - -/*~~~> Does the stage i require a new function evaluation (ros_NewF[i]=TRUE) - or does it re-use the function evaluation from stage i-1 - (ros_NewF[i]=FALSE) */ - ros_NewF[0] = TRUE; - ros_NewF[1] = TRUE; - ros_NewF[2] = TRUE; - ros_NewF[3] = FALSE; -/*~~~> M_i = Coefficients for new step solution */ - ros_M[0] = (KPP_REAL)0.2255570073418735e01; - ros_M[1] = (KPP_REAL)0.2870493262186792; - ros_M[2] = (KPP_REAL)0.4353179431840180; - ros_M[3] = (KPP_REAL)0.1093502252409163e01; -/*~~~> E_i = Coefficients for error estimator */ - ros_E[0] = (KPP_REAL)-0.2815431932141155; - ros_E[1] = (KPP_REAL)-0.7276199124938920e-01; - ros_E[2] = (KPP_REAL)-0.1082196201495311; - ros_E[3] = (KPP_REAL)-0.1093502252409163e01; - -/*~~~> ros_ELO = estimator of local order - the minimum between the - main and the embedded scheme orders plus 1 */ - ros_ELO = (KPP_REAL)4.0; -/*~~~> Y_stage_i ~ Y( T + H*Alpha_i ) */ - ros_Alpha[0] = (KPP_REAL)0.0; - ros_Alpha[1] = (KPP_REAL)0.1145640000000000e01; - ros_Alpha[2] = (KPP_REAL)0.6552168638155900; - ros_Alpha[3] = ros_Alpha[2]; -/*~~~> Gamma_i = \sum_j gamma_{i,j} */ - ros_Gamma[0] = (KPP_REAL) 0.5728200000000000; - ros_Gamma[1] = (KPP_REAL)-0.1769193891319233e01; - ros_Gamma[2] = (KPP_REAL) 0.7592633437920482; - ros_Gamma[3] = (KPP_REAL)-0.1049021087100450; - -} /* End of Ros4 */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void Rodas3() { -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - --- A STIFFLY-STABLE METHOD, 4 stages, order 3 -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - - rosMethod = RD3; -/*~~~> Name of the method */ - strcpy(ros_Name, "RODAS-3"); -/*~~~> Number of stages */ - ros_S = 4; - -/*~~~> The coefficient matrices A and C are strictly lower triangular. - The lower triangular (subdiagonal) elements are stored in row-wise order: - A[0][1] = ros_A[0], A[0][2]=ros_A[1], A[1][2]=ros_A[2], etc. - The general mapping formula is: - A[i][j] = ros_A[ (i-1)*(i-2)/2 + j ] - C[i][j] = ros_C[ (i-1)*(i-2)/2 + j ] */ - - ros_A[0] = (KPP_REAL)0.0; - ros_A[1] = (KPP_REAL)2.0; - ros_A[2] = (KPP_REAL)0.0; - ros_A[3] = (KPP_REAL)2.0; - ros_A[4] = (KPP_REAL)0.0; - ros_A[5] = (KPP_REAL)1.0; - - ros_C[0] = (KPP_REAL) 4.0; - ros_C[1] = (KPP_REAL) 1.0; - ros_C[2] = (KPP_REAL)-1.0; - ros_C[3] = (KPP_REAL) 1.0; - ros_C[4] = (KPP_REAL)-1.0; - ros_C[5] = -(((KPP_REAL)8.0)/((KPP_REAL)3.0)); - -/*~~~> Does the stage i require a new function evaluation (ros_NewF[i]=TRUE) - or does it re-use the function evaluation from stage i-1 - (ros_NewF[i]=FALSE) */ - ros_NewF[0] = TRUE; - ros_NewF[1] = FALSE; - ros_NewF[2] = TRUE; - ros_NewF[3] = TRUE; -/*~~~> M_i = Coefficients for new step solution */ - ros_M[0] = (KPP_REAL)2.0; - ros_M[1] = (KPP_REAL)0.0; - ros_M[2] = (KPP_REAL)1.0; - ros_M[3] = (KPP_REAL)1.0; -/*~~~> E_i = Coefficients for error estimator */ - ros_E[0] = (KPP_REAL)0.0; - ros_E[1] = (KPP_REAL)0.0; - ros_E[2] = (KPP_REAL)0.0; - ros_E[3] = (KPP_REAL)1.0; - -/*~~~> ros_ELO = estimator of local order - the minimum between the - main and the embedded scheme orders plus 1 */ - ros_ELO = (KPP_REAL)3.0; -/*~~~> Y_stage_i ~ Y( T + H*Alpha_i ) */ - ros_Alpha[0] = (KPP_REAL)0.0; - ros_Alpha[1] = (KPP_REAL)0.0; - ros_Alpha[2] = (KPP_REAL)1.0; - ros_Alpha[3] = (KPP_REAL)1.0; -/*~~~> Gamma_i = \sum_j gamma_{i,j} */ - ros_Gamma[0] = (KPP_REAL)0.5; - ros_Gamma[1] = (KPP_REAL)1.5; - ros_Gamma[2] = (KPP_REAL)0.0; - ros_Gamma[3] = (KPP_REAL)0.0; - -} /* End of Rodas3 */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void Rodas4() { -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - STIFFLY-STABLE ROSENBROCK METHOD OF ORDER 4, WITH 6 STAGES - - E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL - EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS. - SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS, - SPRINGER-VERLAG (1996) -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - - rosMethod = RD4; -/*~~~> Name of the method */ - strcpy(ros_Name, "RODAS-4"); -/*~~~> Number of stages */ - ros_S = 6; - -/*~~~> Y_stage_i ~ Y( T + H*Alpha_i ) */ - ros_Alpha[0] = (KPP_REAL)0.000; - ros_Alpha[1] = (KPP_REAL)0.386; - ros_Alpha[2] = (KPP_REAL)0.210; - ros_Alpha[3] = (KPP_REAL)0.630; - ros_Alpha[4] = (KPP_REAL)1.000; - ros_Alpha[5] = (KPP_REAL)1.000; - -/*~~~> Gamma_i = \sum_j gamma_{i,j} */ - ros_Gamma[0] = (KPP_REAL) 0.2500000000000000; - ros_Gamma[1] = (KPP_REAL)-0.1043000000000000; - ros_Gamma[2] = (KPP_REAL) 0.1035000000000000; - ros_Gamma[3] = (KPP_REAL)-0.3620000000000023e-01; - ros_Gamma[4] = (KPP_REAL) 0.0; - ros_Gamma[5] = (KPP_REAL) 0.0; - -/*~~~> The coefficient matrices A and C are strictly lower triangular. - The lower triangular (subdiagonal) elements are stored in row-wise order: - A[0][1] = ros_A[0], A[0][2]=ros_A[1], A[1][2]=ros_A[2], etc. - The general mapping formula is: A[i][j] = ros_A[ (i-1)*(i-2)/2 + j ] - C[i][j] = ros_C[ (i-1)*(i-2)/2 + j ] */ - - ros_A[0] = (KPP_REAL) 0.1544000000000000e01; - ros_A[1] = (KPP_REAL) 0.9466785280815826; - ros_A[2] = (KPP_REAL) 0.2557011698983284; - ros_A[3] = (KPP_REAL) 0.3314825187068521e01; - ros_A[4] = (KPP_REAL) 0.2896124015972201e01; - ros_A[5] = (KPP_REAL) 0.9986419139977817; - ros_A[6] = (KPP_REAL) 0.1221224509226641e01; - ros_A[7] = (KPP_REAL) 0.6019134481288629e01; - ros_A[8] = (KPP_REAL) 0.1253708332932087e02; - ros_A[9] = (KPP_REAL)-0.6878860361058950; - ros_A[10] = ros_A[6]; - ros_A[11] = ros_A[7]; - ros_A[12] = ros_A[8]; - ros_A[13] = ros_A[9]; - ros_A[14] = (KPP_REAL)1.0; - - ros_C[0] = (KPP_REAL)-0.5668800000000000e01; - ros_C[1] = (KPP_REAL)-0.2430093356833875e01; - ros_C[2] = (KPP_REAL)-0.2063599157091915; - ros_C[3] = (KPP_REAL)-0.1073529058151375; - ros_C[4] = (KPP_REAL)-0.9594562251023355e01; - ros_C[5] = (KPP_REAL)-0.2047028614809616e02; - ros_C[6] = (KPP_REAL) 0.7496443313967647e01; - ros_C[7] = (KPP_REAL)-0.1024680431464352e02; - ros_C[8] = (KPP_REAL)-0.3399990352819905e02; - ros_C[9] = (KPP_REAL) 0.1170890893206160e02; - ros_C[10] = (KPP_REAL) 0.8083246795921522e01; - ros_C[11] = (KPP_REAL)-0.7981132988064893e01; - ros_C[12] = (KPP_REAL)-0.3152159432874371e02; - ros_C[13] = (KPP_REAL) 0.1631930543123136e02; - ros_C[14] = (KPP_REAL)-0.6058818238834054e01; - -/*~~~> M_i = Coefficients for new step solution */ - ros_M[0] = ros_A[6]; - ros_M[1] = ros_A[7]; - ros_M[2] = ros_A[8]; - ros_M[3] = ros_A[9]; - ros_M[4] = (KPP_REAL)1.0; - ros_M[5] = (KPP_REAL)1.0; - -/*~~~> E_i = Coefficients for error estimator */ - ros_E[0] = (KPP_REAL)0.0; - ros_E[1] = (KPP_REAL)0.0; - ros_E[2] = (KPP_REAL)0.0; - ros_E[3] = (KPP_REAL)0.0; - ros_E[4] = (KPP_REAL)0.0; - ros_E[5] = (KPP_REAL)1.0; - -/*~~~> Does the stage i require a new function evaluation (ros_NewF[i]=TRUE) - or does it re-use the function evaluation from stage i-1 - (ros_NewF[i]=FALSE) */ - ros_NewF[0] = TRUE; - ros_NewF[1] = TRUE; - ros_NewF[2] = TRUE; - ros_NewF[3] = TRUE; - ros_NewF[4] = TRUE; - ros_NewF[5] = TRUE; - -/*~~~> ros_ELO = estimator of local order - the minimum between the - main and the embedded scheme orders plus 1 */ - ros_ELO = (KPP_REAL)4.0; - -} /* End of Rodas4 */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void FunTemplate( KPP_REAL T, KPP_REAL Y[], KPP_REAL Ydot[] ) { -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Template for the ODE function call. - Updates the rate coefficients (and possibly the fixed species) at each call -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - -/*~~~> Local variables */ - KPP_REAL Told; - - Told = TIME; - TIME = T; - Update_SUN(); - Update_RCONST(); - Fun( Y, FIX, RCONST, Ydot ); - TIME = Told; - -} /* End of FunTemplate */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void JacTemplate( KPP_REAL T, KPP_REAL Y[], KPP_REAL Jcb[] ) { -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Template for the ODE Jacobian call. - Updates the rate coefficients (and possibly the fixed species) at each call -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - -/*~~~> Local variables */ - KPP_REAL Told; -#ifdef FULL_ALGEBRA - KPP_REAL JV[LU_NONZERO]; - int i, j; -#endif - - Told = TIME; - TIME = T; - Update_SUN(); - Update_RCONST(); -#ifdef FULL_ALGEBRA - Jac_SP(Y, FIX, RCONST, JV); - for(j=0; j Local variables */ - KPP_REAL Told; - - Told = TIME; - TIME = T; - Update_SUN(); - Update_RCONST(); - Hessian( Y, FIX, RCONST, Hes ); - TIME = Told; - -} /* End of HessTemplate */ - -/* End of INTEGRATE function */ -/* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ */ diff --git a/boxmox/int/rosenbrock_adj.def b/boxmox/int/rosenbrock_adj.def deleted file mode 100644 index c42d76ee02bf1c1e06fdf1b91615857e47376bac..0000000000000000000000000000000000000000 --- a/boxmox/int/rosenbrock_adj.def +++ /dev/null @@ -1,23 +0,0 @@ - -#FUNCTION AGGREGATE -#JACOBIAN SPARSE_LU_ROW - -#DOUBLE ON -#INTFILE rosenbrock_adj - -#INLINE F77_GLOBAL - INTEGER Autonomous - COMMON /INTGDATA/ Autonomous - REAL*8 STEPSTART - COMMON /GDATA/ STEPSTART -#ENDINLINE - -#INLINE F77_INIT - STEPMIN=0.0001 - STEPMAX=3600. - Autonomous = 1 - STEPSTART=STEPMIN -#ENDINLINE - - - diff --git a/boxmox/int/rosenbrock_tlm.def b/boxmox/int/rosenbrock_tlm.def deleted file mode 100644 index 6d31074d5de9381d4dc6be1dc59587d472233cf0..0000000000000000000000000000000000000000 --- a/boxmox/int/rosenbrock_tlm.def +++ /dev/null @@ -1,23 +0,0 @@ - -#FUNCTION AGGREGATE -#JACOBIAN SPARSE_LU_ROW - -#DOUBLE ON -#INTFILE rosenbrock_tlm - -#INLINE F77_GLOBAL - INTEGER Autonomous - COMMON /INTGDATA/ Autonomous - REAL*8 STEPSTART - COMMON /GDATA/ STEPSTART -#ENDINLINE - -#INLINE F77_INIT - STEPMIN=0.0001 - STEPMAX=3600. - Autonomous = 1 - STEPSTART=STEPMIN -#ENDINLINE - - - diff --git a/boxmox/int/runge_kutta.c b/boxmox/int/runge_kutta.c deleted file mode 100644 index d5c3cd15b19be8a9c870c351892db28bad9935d7..0000000000000000000000000000000000000000 --- a/boxmox/int/runge_kutta.c +++ /dev/null @@ -1,2087 +0,0 @@ - #define MAX(a,b) ( ((a) >= (b)) ?(a):(b) ) - #define MIN(b,c) ( ((b) < (c)) ?(b):(c) ) - #define ABS(x) ( ((x) >= 0 ) ?(x):(-x) ) - #define SQRT(d) ( pow((d),0.5) ) - /* SIGN transfer function */ - #define SIGN(x,y) (((y) >= 0 ) ?(ABS(x)):(-ABS(x)) ) - -/*~~> Numerical constants */ - #define ZERO (KPP_REAL)0.0 - #define ONE (KPP_REAL)1.0 - -/*~~~> Statistics on the work performed by the Runge-Kutta method */ - #define Nfun 0 - #define Njac 1 - #define Nstp 2 - #define Nacc 3 - #define Nrej 4 - #define Ndec 5 - #define Nsol 6 - #define Nsng 7 - #define Ntexit 0 - #define Nhacc 1 - #define Nhnew 2 - -/*~~~> Runge-Kutta method parameters */ - #define RKmax 3 - - #define R2A 1 - #define R1A 2 - #define L3C 3 - #define GAU 4 - #define L3A 5 - - int rkMethod, - SdirkError; - KPP_REAL rkT[RKmax][RKmax], - rkTinv[RKmax][RKmax], - rkTinvAinv[RKmax][RKmax], - rkAinvT[RKmax][RKmax], - rkA[RKmax+1][RKmax+1], - rkB[RKmax+1], - rkC[RKmax+1], - rkD[RKmax+1], - rkE[RKmax+1], - rkBgam[RKmax+2], - rkBhat[RKmax+2], - rkTheta[RKmax+1], - rkF[RKmax+2], - rkGamma, - rkAlpha, - rkBeta, - rkELO; -/*~~~> Function headers */ -// void INTEGRATE(KPP_REAL TIN, KPP_REAL TOUT, int ICNTRL_U[], KPP_REAL RCNTRL_U[], -// int ISTATUS_U[], KPP_REAL RSTATUS_U[], int IERR_U); - void INTEGRATE(KPP_REAL TIN, KPP_REAL TOUT); - void RungeKutta(int N, KPP_REAL T, KPP_REAL Tend, KPP_REAL Y[], - KPP_REAL RelTol[], KPP_REAL AbsTol[], KPP_REAL RCNTRL[], - int ICNTRL[], KPP_REAL RSTATUS[], int ISTATUS[], int* IERR); - void RK_Integrator(int N, KPP_REAL* T, KPP_REAL Tend, KPP_REAL Y[], - KPP_REAL AbsTol[], KPP_REAL RelTol[], int ITOL, - int ISTATUS[], KPP_REAL RSTATUS[], KPP_REAL Hmin, - KPP_REAL Hmax, KPP_REAL Hstart, KPP_REAL Roundoff, - int Max_no_steps, int NewtonMaxit, int StartNewton, - int Gustafsson, KPP_REAL ThetaMin, KPP_REAL NewtonTol, - KPP_REAL FacSafe, KPP_REAL FacMax, KPP_REAL FacMin, - KPP_REAL FacRej, KPP_REAL Qmin, KPP_REAL Qmax, int* IERR); - void RK_ErrorMsg(int Code, KPP_REAL T, KPP_REAL H, int* IERR); - void RK_ErrorScale(int N, int ITOL, KPP_REAL AbsTol[], KPP_REAL RelTol[], - KPP_REAL Y[], KPP_REAL SCAL[]); - /*void RK_Transform(int N, KPP_REAL Tr[][RKmax], KPP_REAL Z1[], KPP_REAL Z2[], - KPP_REAL Z3[], KPP_REAL W1[], KPP_REAL W2[], KPP_REAL W3[]);*/ - void RK_Interpolate(char action[], int N, KPP_REAL H, KPP_REAL Hold, - KPP_REAL Z1[], KPP_REAL Z2[], KPP_REAL Z3[], KPP_REAL CONT[][RKmax]); - void RK_PrepareRHS(int N, KPP_REAL T, KPP_REAL H, KPP_REAL Y[], KPP_REAL FO[], - KPP_REAL Z1[], KPP_REAL Z2[], KPP_REAL Z3[], KPP_REAL R1[], KPP_REAL R2[], - KPP_REAL R3[]); - void RK_Decomp(int N, KPP_REAL H, KPP_REAL FJAC[], KPP_REAL E1[], - int IP1[], KPP_REAL E2R[], KPP_REAL E2I[], - int IP2[], int* ISING, int ISTATUS[]); - void RK_Solve(int N, KPP_REAL H, KPP_REAL E1[], int IP1[], KPP_REAL E2R[], - KPP_REAL E2I[], int IP2[], KPP_REAL R1[], KPP_REAL R2[], KPP_REAL R3[], - int ISTATUS[]); - void RK_ErrorEstimate(int N, KPP_REAL H, KPP_REAL T, KPP_REAL Y[], - KPP_REAL FO[], KPP_REAL E1[], int IP1[], KPP_REAL Z1[], - KPP_REAL Z2[], KPP_REAL Z3[], KPP_REAL SCAL[], KPP_REAL* Err, - int FirstStep, int Reject, int ISTATUS[]); - void Radau2A_Coefficients(); - void Lobatto3C_Coefficients (); - void Gauss_Coefficients(); - void Radau1A_Coefficients(); - void Lobatto3A_Coefficients(); - void FUN_CHEM(KPP_REAL T, KPP_REAL V[], KPP_REAL FCT[]); - void JAC_CHEM(KPP_REAL T, KPP_REAL V[], KPP_REAL JF[]); - KPP_REAL RK_ErrorNorm(int N, KPP_REAL SCAL[], KPP_REAL DY[]); - void Fun(KPP_REAL Y[], KPP_REAL FIX[], KPP_REAL RCONST[], KPP_REAL Ydot[]); - void Jac_SP(KPP_REAL Y[], KPP_REAL FIX[], KPP_REAL RCONST[], KPP_REAL Ydot[]); - void WCOPY(int N, KPP_REAL X[], int incX, KPP_REAL Y[], int incY); - void WADD(int N, KPP_REAL Y[], KPP_REAL Z[], KPP_REAL TMP[]); - void WAXPY(int N, KPP_REAL Alpha, KPP_REAL X[], int incX, KPP_REAL Y[], int incY ); - KPP_REAL WLAMCH( char C ); - void KppSolveCmplxR(KPP_REAL JVSR[], KPP_REAL JVSI[], KPP_REAL XR[], KPP_REAL XI[]); - int KppDecompCmplxR(KPP_REAL *JVSR, KPP_REAL *JVSI); - void Set2Zero(int N, KPP_REAL A[]); - int KppDecomp( KPP_REAL A[] ); - void KppSolve ( KPP_REAL A[], KPP_REAL b[] ); - void Update_SUN(); - void Update_RCONST(); - void Update_PHOTO(); - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -//void INTEGRATE(KPP_REAL TIN, KPP_REAL TOUT, int ICNTRL_U[], KPP_REAL RCNTRL_U[], -// int ISTATUS_U[], KPP_REAL RSTATUS_U[], int IERR_U ) -void INTEGRATE(KPP_REAL TIN, KPP_REAL TOUT ) -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -/* RungeKutta - Fully Implicit 3-stage Runge-Kutta methods based on: - * Radau-2A quadrature (order 5) - * Radau-1A quadrature (order 5) - * Lobatto-3C quadrature (order 4) - * Gauss quadrature (order 6) - By default the code employs the KPP sparse linear algebra routines - Compile with -DFULL_ALGEBRA to use full linear algebra (LAPACK) - - (C) Adrian Sandu, August 2005 - Virginia Polytechnic Institute and State University - Contact: sandu@cs.vt.edu - Revised by Philipp Miehe and Adrian Sandu, May 2006 - F90 to C translation by Tinting Jiang and Don Jacob, July 2006 - This implementation is part of KPP - the Kinetic PreProcessor -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -{ - int IERR; - KPP_REAL RCNTRL[20], - RSTATUS[20], - T1, - T2; - int ICNTRL[20], - ISTATUS[20]; - static int Ntotal = 0; /* for printing the number of steps */ - - int i; - for ( i = 0; i < 20; i++ ) { - RCNTRL[i] = ZERO; - ICNTRL[i] = 0; - } /* for */ - - /*~~~> fine-tune the integrator: */ - ICNTRL[1] = 0; /* 0=vector tolerances, 1=scalar tolerances */ - ICNTRL[4] = 8; /* Max no. of Newton iterations */ - ICNTRL[5] = 0; /* Starting values for Newton are interpolated(0) or zero(1) */ - ICNTRL[9] = 1; /* 0 - classic or 1 - SDIRK error estimation */ - ICNTRL[10] = 0; /* Gustaffson(0) or classic(1) controller */ - -// /*~~~> if optional parameters are given, and if they are >0, -// then use them to overwrite default settings */ -// if (ICNTRL_U != NULL) { -// for ( i = 0; i < 20; i++) { -// if (ICNTRL_U[i] > 0) { -// ICNTRL[i] = ICNTRL_U[i]; -// } /* end if */ -// } /* end for */ -// } /* end if */ -// if (RCNTRL_U != NULL) { -// for (i = 0; i < 20; i++) { -// if (RCNTRL_U[i] > 0) { -// RCNTRL[i] = RCNTRL_U[i]; -// } /* end if */ -// } /* end for */ -// } /* end if */ - - T1 = TIN; - /*printf("T1=%f\n", T1);*/ - T2 = TOUT; - /*printf("T2=%f\n", T2);*/ - RungeKutta(NVAR, T1, T2, VAR, RTOL, ATOL, RCNTRL,ICNTRL,RSTATUS,ISTATUS, &IERR); - - Ntotal += ISTATUS[Nstp]; - printf("NSTEPS=%d (%d) O3=%E ", ISTATUS[Nstp], Ntotal, VAR[ind_O3]); - -// /* if optional parameters are given for output -// * use them to store information in them */ -// if (ISTATUS_U != NULL) { -// for (i = 0; i < 20; i++) { -// ISTATUS_U[i] = ISTATUS[i]; -// } /* end for */ -// } /* end if */ -// if (RSTATUS_U != NULL) { -// for (i = 0; i < 20; i++) { -// RSTATUS_U[i] = RSTATUS[i]; -// } /* end for */ -// } /* end if */ -// /*if (IERR_U != NULL) */ -// IERR_U = IERR; - - if (IERR < 0) { - printf("Runge-Kutta: Unsuccessful exit at T=%f(IERR=%d)", TIN, IERR); - } /* end if */ - -} /* end INTEGRATE */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - -void RungeKutta(int N, KPP_REAL T, KPP_REAL Tend, KPP_REAL Y[], - KPP_REAL RelTol[], KPP_REAL AbsTol[], KPP_REAL RCNTRL[], - int ICNTRL[], KPP_REAL RSTATUS[], int ISTATUS[], int* IERR) -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - This implementation is based on the book and the code Radau5: - - E. HAIRER AND G. WANNER - "SOLVING ORDINARY DIFFERENTIAL EQUATIONS II. - STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS." - SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS 14, - SPRINGER-VERLAG (1991) - - UNIVERSITE DE GENEVE, DEPT. DE MATHEMATIQUES - CH-1211 GENEVE 24, SWITZERLAND - E-MAIL: HAIRER@DIVSUN.UNIGE.CH, WANNER@DIVSUN.UNIGE.CH - - Methods: - * Radau-2A quadrature (order 5) - * Radau-1A quadrature (order 5) - * Lobatto-3C quadrature (order 4) - * Gauss quadrature (order 6) - - (C) Adrian Sandu, August 2005 - Virginia Polytechnic Institute and State University - Contact: sandu@cs.vt.edu - This implementation is part of KPP - the Kinetic PreProcessor -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - *~~~> INPUT ARGUMENTS: - ---------------- - Note: For input parameters equal to zero the default values of the - corresponding variables are used. - - N Dimension of the system - T Initial time value - - Tend Final T value (Tend-T may be positive or negative) - - Y(N) Initial values for Y - - RelTol, AbsTol Relative and absolute error tolerances. - for ICNTRL[1] = 0: AbsTol, RelTol are N-dimensional vectors - = 1: AbsTol, RelTol are scalars - *~~~> Integer input parameters: - - ICNTRL[0] = not used - - ICNTRL[1] = 0: AbsTol, RelTol are NVAR-dimensional vectors - = 1: AbsTol, RelTol are scalars - - ICNTRL[2] = RK method selection - = 1: Radau-2A (the default) - = 2: Radau-1A - = 3: Lobatto-3C - = 4: Gauss - = 5: Lobatto-3A (not yet implemented) - - ICNTRL[3] -> maximum number of integration steps - For ICNTRL[3] = 0 the default value of 10000 is used - - ICNTRL[4] -> maximum number of Newton iterations - For ICNTRL[4] = 0 the default value of 8 is used - - ICNTRL[5] -> starting values of Newton iterations: - ICNTRL[5] = 0: starting values are obtained from - the extrapolated collocation solution - (the default) - ICNTRL[5] = 1: starting values are zero - - ICNTRL[9] -> switch for error estimation strategy - ICNTRL[9] = 0: one additional stage at c = 0, - see Hairer (default) - ICNTRL[9] = 1: two additional stages at c = 0, - and SDIRK at c = 1, stiffly accurate - - ICNTRL[10] -> switch for step size strategy - ICNTRL[10] = 0: mod. predictive controller (Gustafsson, default) - ICNTRL[10] = 1: classical step size control - the choice 1 seems to produce safer results; - for simple problems, the choice 2 produces - often slightly faster runs - - *~~~> Real input parameters: - RCNTRL[0] -> Hmin, lower bound for the integration step size - (highly recommended to keep Hmin = ZERO, the default) - - RCNTRL[1] -> Hmax, upper bound for the integration step size - - RCNTRL[2] -> Hstart, the starting step size - - RCNTRL[3] -> FacMin, lower bound on step decrease factor - (default=0.2) - - RCNTRL[4] -> FacMax, upper bound on step increase factor - (default=6) - - RCNTRL[5] -> FacRej, step decrease factor after multiple rejections - (default=0.1) - - RCNTRL[6] -> FacSafe, by which the new step is slightly smaller - than the predicted value (default=0.9) - - RCNTRL[7] -> ThetaMin. If Newton convergence rate smaller - than ThetaMin the Jacobian is not recomputed; - (default=0.001) - - RCNTRL[8] -> NewtonTol, stopping criterion for Newton's method - (default=0.03) - - RCNTRL[9] -> Qmin - - RCNTRL[10] -> Qmax. If Qmin < Hnew/Hold < Qmax, then the - step size is kept constant and the LU factorization - reused (default Qmin=1, Qmax=1.2) -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - *~~~> OUTPUT ARGUMENTS: - ----------------- - T -> T value for which the solution has been computed - (after successful return T=Tend). - - Y(N) -> Numerical solution at T - - Note: each call to RungeKutta adds the current no. of fcn calls - to previous value of ISTATUS[0], and similar to other params. - Set ISTATUS[1:9] = 0 before call to avoid this accumulation. - - ISTATUS[0] -> No. of function calls - ISTATUS[1] -> No. of Jacobian calls - ISTATUS[2] -> No. of steps - ISTATUS[3] -> No. of accepted steps - ISTATUS[4] -> No. of rejected steps (except at very beginning) - ISTATUS[5] -> No. of LU decompositions - ISTATUS[6] -> No. of forward/backward substitutions - ISTATUS[7] -> No. of singular matrix decompositions - - RSTATUS[0] -> Texit, the time corresponding to the - computed Y upon return - RSTATUS[1] -> Hexit, last accepted step before exit - RSTATUS[2] -> Hnew, last predicted step (not yet taken) - For multiple restarts, use Hnew as Hstart - in the subsequent run - -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - *~~~> RETURN VALUE (int): - - IERR -> Reports on successfulness upon return: - = 1 for success - < 0 for error (value equals error code) - = -1 : Improper value for maximal no of steps - = -2 : Improper value for maximal no of Newton iterations - = -3 : Hmin/Hmax/Hstart must be positive - = -4 : Improper values for FacMin/FacMax/FacSafe/FacRej - = -5 : Improper value for ThetaMin - = -6 : Newton stopping tolerance too small - = -7 : Improper values for Qmin, Qmax - = -8 : Tolerances are too small - = -9 : No of steps exceeds maximum bound - = -10 : Step size too small - = -11 : Matrix is repeatedly singular - = -12 : Non-convergence of Newton iterations - = -13 : Requested RK method not implemented -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ */ -{ - /*~~~> Control arguments */ - /*printf("Starting RungeKutta\n");*/ - int Max_no_steps; - KPP_REAL Hmin, - Hmax, - Hstart, - Qmin, - Qmax, - Roundoff, - ThetaMin, - NewtonTol, - FacSafe, - FacMin, - FacMax, - FacRej; - /*~~~> Local variables */ - int NewtonMaxit, - ITOL, - i, - StartNewton, - Gustafsson; - - *IERR = 0; - for (i = 0; i < 20; i++) { - ISTATUS[i] = 0; - RSTATUS[i] = ZERO; - } /* end for */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ */ - - /*~~~> ICNTRL[0] - autonomous system - not used */ - /*~~~> ITOL: 1 for vector and 0 for scalar AbsTol/RelTol */ - if (ICNTRL[1] == 0) { - /*printf("Entering if ICNTRL[1] == 0\n");*/ - ITOL = 1; - } - else { - ITOL = 0; - } /*end if */ - /*~~~> Error control selection */ - if (ICNTRL[9] == 0) { - SdirkError = 0; - } - else { - /*printf("Entering if ICNTRL[9] == 1\n");*/ - SdirkError = 1; - } /* end if */ - /*~~~> Method Selection */ - /*printf("Starting case ICNTRL[2]\n");*/ - switch (ICNTRL[2]) { - case 0: - case 1: Radau2A_Coefficients(); /*printf("case 0 or 1\n");*/ - break; - case 2: Lobatto3C_Coefficients(); printf("case 2\n"); - break; - case 3: Gauss_Coefficients(); printf("case 3\n"); - break; - case 4: Radau1A_Coefficients(); printf("case 4\n"); - break; - case 5: Lobatto3A_Coefficients(); printf("case 5\n"); - break; - default: - printf("\n ICNTRL[2]=%d\n", ICNTRL[2]); - RK_ErrorMsg(-13, T, ZERO, IERR); - } /* end switch */ - - /*~~~> Max_no_steps: the maximal number of time steps */ - if (ICNTRL[3] == 0) { - Max_no_steps = 200000; - /*printf("Max_no_steps = %d\n", Max_no_steps);*/ - } - else { - Max_no_steps = ICNTRL[3]; - if (Max_no_steps <= 0) - { - printf("\n ICNTRL[3]=%d\n", ICNTRL[3]); - RK_ErrorMsg(-1, T, ZERO, IERR); - } /* end if */ - } /* end if */ - - /*~~~> NewtonMaxit: maximal number of Newton iterations */ - if (ICNTRL[4] == 0) - NewtonMaxit = 8; - else - { - NewtonMaxit = ICNTRL[4]; - if (NewtonMaxit <= 0) { - printf("\n ICNTRL[4]=%d\n", ICNTRL[4]); - RK_ErrorMsg(-2, T, ZERO, IERR); - } - /*printf("NewtonMaxit = %d\n", NewtonMaxit);*/ - } /* end if */ - - /*~~~> StartNewton: Use extrapolation for starting values of Newton iterations */ - if (ICNTRL[5] == 0) { - StartNewton = 1; - /*printf("StartNewton = %d\n", StartNewton);*/ - } - else { - StartNewton = 0; - } /* end if */ - - /*~~~> Gustafsson: step size controller */ - if (ICNTRL[10] == 0) { - Gustafsson = 1; - /*printf("Gustafsson = %d\n", Gustafsson);*/ - } - else { - Gustafsson = 0; - } /* end if */ - - /*~~~> Roundoff: smallest number s.t. 1.0 + Roundoff > 1.0 */ - Roundoff = WLAMCH('E'); - /*printf("Roundoff=%f\n", Roundoff);*/ - /*~~~> Hmin = minimal step size */ - if (RCNTRL[0] == ZERO) { - /*printf("Entering if RCNTRL[0]=%f == ZERO\n", RCNTRL[0]);*/ - Hmin = ZERO; - } - else { - Hmin = MIN(ABS(RCNTRL[0]), ABS(Tend-T)); - } /* end if */ - /*~~~> Hmax = maximal step size */ - if (RCNTRL[1] == ZERO) { - /*printf("Entering if RCNTRL[1]=%f == ZERO\n", RCNTRL[1]);*/ - Hmax = ABS(Tend-T); - } - else { - Hmax = MIN(ABS(RCNTRL[1]),ABS(Tend-T)); - } /* end if */ - /*~~~> Hstart = starting step size */ - if (RCNTRL[2] == ZERO) { - /*printf("Entering if RCNTRL[2]=%f == ZERO\n", RCNTRL[2]);*/ - Hstart = ZERO; - } - else { - Hstart = MIN(ABS(RCNTRL[2]),ABS(Tend-T)); - } /* end if */ - /*~~~> FacMin: lower bound on step decrease factor */ - if (RCNTRL[3] == ZERO) { - /*printf("Entering if RCNTRL[3]=%f == ZERO\n", RCNTRL[3]);*/ - FacMin = (KPP_REAL)0.2; - } - else { - FacMin = RCNTRL[3]; - } /* end if */ - /*~~~> FacMax: upper bound on step increase factor */ - if (RCNTRL[4] == ZERO) { - /*printf("Entering if RCNTRL[4]=%f == ZERO\n", RCNTRL[4]);*/ - FacMax = (KPP_REAL)8.0; - } - else { - FacMax = RCNTRL[4]; - } /* end if */ - /*~~~> FacRej: step decrease factor after 2 consecutive rejections */ - if (RCNTRL[5] == ZERO) { - /*printf("Entering if RCNTRL[5]=%f == ZERO\n", RCNTRL[5]);*/ - FacRej = (KPP_REAL)0.1; - } - else { - FacRej = RCNTRL[5]; - } /* end if */ - /*~~~> FacSafe: by which the new step is slightly smaller - than the predicted value */ - if (RCNTRL[6] == ZERO) { - /*printf("Entering if RCNTRL[6]=%f == ZERO\n", RCNTRL[6]);*/ - FacSafe = (KPP_REAL)0.9; - } - else { - FacSafe = RCNTRL[6]; - } /* end if */ - if ((FacMax < ONE) || (FacMin > ONE) || (FacSafe <= 1.0e-03) || (FacSafe >= ONE)) { - printf("\n RCNTRL[3]=%f, RCNTRL[4]=%f, RCNTRL[5]=%f, RCNTRL[6]=%f\n", - RCNTRL[3], RCNTRL[4], RCNTRL[5], RCNTRL[6]); - RK_ErrorMsg(-4, T, ZERO, IERR); - } /* end if */ - - /*~~~> ThetaMin: decides whether the Jacobian should be recomputed */ - if (RCNTRL[7] == ZERO) - ThetaMin = (KPP_REAL)1.0e-03; - else { - ThetaMin = RCNTRL[7]; - if (ThetaMin <= (KPP_REAL)0.0 || ThetaMin >= (KPP_REAL)1.0) { - printf("\n RCNTRL[7]=%f\n", RCNTRL[7]); - RK_ErrorMsg(-5, T, ZERO, IERR); - } - } /* end if */ - /*~~~> NewtonTol: stopping criterion for Newton's method */ - if (RCNTRL[8] == ZERO) - NewtonTol = (KPP_REAL)3.0e-02; - else { - NewtonTol = RCNTRL[8]; - if (NewtonTol <= Roundoff) { - printf("\n RCNTRL[8]=%f\n", RCNTRL[8]); - RK_ErrorMsg(-6, T, ZERO, IERR); - } - } /* end if */ - /*~~~> Qmin AND Qmax: IF Qmin < Hnew/Hold < Qmax then step size = const. */ - if (RCNTRL[9] == ZERO) { - Qmin = ONE; - } - else { - Qmin = RCNTRL[9]; - } /* end if */ - if (RCNTRL[10] == ZERO) { - Qmax = (KPP_REAL)1.2; - } - else { - Qmax = RCNTRL[10]; - } /* end if */ - if (Qmin > ONE || Qmax < ONE) { - printf("\n RCNTRL[9]=%f\n", Qmin); - printf("\n RCNTRL[10]=%f\n", Qmax); - RK_ErrorMsg(-7, T, ZERO, IERR); - } /* end if */ - /*~~~> Check if tolerances are reasonable */ - if (ITOL == 0) { - if ( AbsTol[0] <= ZERO || RelTol[0] <= ( ((KPP_REAL)10.0)*Roundoff) ) { - printf("\n AbsTol=%f\n", AbsTol[0]); - printf("\n RelTol=%f\n", RelTol[0]); - RK_ErrorMsg(-8, T, ZERO, IERR); - } - } - else { - for (i = 0; i < N; i++) { - if ( (AbsTol[i] <= ZERO) || (RelTol[i] <= ((KPP_REAL)10.0)*Roundoff) ) { - printf("\n AbsTol[%d] = %f\n", i, AbsTol[i]); - printf("\n AbsTol[%d] = %f\n", i, RelTol[i]); - RK_ErrorMsg(-8, T, ZERO, IERR); - } /* end if */ - } /* end for */ - } /* end if */ - - /*~~~> Parameters are wrong */ - if (*IERR < 0) - return; - - /*~~~> Call the core method */ - RK_Integrator(N, &T, Tend, Y, AbsTol, RelTol, ITOL, ISTATUS, RSTATUS, - Hmin, Hmax, Hstart, Roundoff, Max_no_steps, NewtonMaxit, - StartNewton, Gustafsson, ThetaMin, NewtonTol, - FacSafe, FacMax, FacMin, FacRej, Qmin, Qmax, IERR); - /*printf("*IERR = %d\n", *IERR);*/ - /*printf("Ending RungeKutta\n");*/ -} /* RungeKutta */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void RK_Integrator( int N, - /*~~~> Input: integration interval */ - KPP_REAL* T, KPP_REAL Tend, KPP_REAL Y[], - KPP_REAL AbsTol[], KPP_REAL RelTol[], int ITOL, - /*~~~> Input: the initial condition at T; output: the solution at Tend */ - int ISTATUS[], KPP_REAL RSTATUS[], KPP_REAL Hmin, KPP_REAL Hmax, - KPP_REAL Hstart, KPP_REAL Roundoff, int Max_no_steps, int NewtonMaxit, - int StartNewton, int Gustafsson, KPP_REAL ThetaMin, - KPP_REAL NewtonTol, KPP_REAL FacSafe, KPP_REAL FacMax, KPP_REAL FacMin, - KPP_REAL FacRej, KPP_REAL Qmin, KPP_REAL Qmax, int* IERR) -{ - /*printf("Starting RK_Integrator\n");*/ - KPP_REAL FJAC[LU_NONZERO], - E1[LU_NONZERO], - E2R[LU_NONZERO], - E2I[LU_NONZERO]; - KPP_REAL Z1[NVAR], - Z2[NVAR], - Z3[NVAR], - Z4[NVAR], - SCAL[NVAR], - DZ1[NVAR], - DZ2[NVAR], - DZ3[NVAR], - DZ4[NVAR], - G[NVAR], - TMP[NVAR], - FO[NVAR]; - KPP_REAL CONT[NVAR][RKmax], - Tdirection, - H, - Hacc, - Hnew, - Hold, - Fac, - FacGus, - Theta, - Err, - ErrOld, - NewtonRate, - NewtonIncrement, - Hratio, - Qnewton, - NewtonPredictedErr, - NewtonIncrementOld, - ThetaSD; - int IP1[NVAR], - IP2[NVAR], - NewtonIter, - Nconsecutive, - i; - int ISING; - int Reject, - FirstStep, - SkipJac, - NewtonDone, - SkipLU; - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - - /*~~~> INITIAL setting */ - /*printf("ONE=%f Tend-*T=%f\n", ONE, Tend-*T);*/ - Tdirection = SIGN(ONE, Tend-*T); - /*printf("Tdirection=%f\n", Tdirection);*/ - /*printf("Hmin=%g Hstart=%g \n", Hmin, Hstart);*/ - /*printf("ABS(Hmin)=%g ABS(Hstart)=%g \n", ABS(Hmin), ABS(Hstart));*/ - H = MIN( MAX(ABS(Hmin), ABS(Hstart)), Hmax ); - if (ABS(H) <= ((KPP_REAL)10.0*Roundoff)) { - /*printf("Entering if ABS(H)=%g <= 10.0*Roundoff=%g\n", ABS(H),(KPP_REAL)10.0*Roundoff);*/ - H = (KPP_REAL)(1.0e-06); - } /* end if */ - H = SIGN(H, Tdirection); - Hold = H; - /*printf("Hold=%f\n", Hold);*/ - Reject = 0; - FirstStep = 1; - SkipJac = 0; - SkipLU = 0; - if ((*T+H*((KPP_REAL)1.0001)-Tend)*Tdirection >= ZERO) { - H = Tend - *T; - } /* end if */ - Nconsecutive = 0; - RK_ErrorScale(N, ITOL, AbsTol, RelTol, Y, SCAL); - /*for(i=0; i Time loop begins */ - /* while Tloop */ -Tloop: while ( (Tend-*T)*Tdirection - Roundoff > ZERO ) { - /*printf("Starting Tloop: (Tend-*T)*Tdirection - Roundoff=%g > ZERO\n", (Tend-*T)*Tdirection-Roundoff);*/ - /*if ( Reject == 0 ) { */ - FUN_CHEM(*T,Y,FO); - ISTATUS[Nfun]++; - /* } * end if */ - if ( SkipLU == 0 ) { /* This time around skip the Jac update and LU */ - /*~~~> Compute the Jacobian matrix */ - /*printf("Entering if SkipLU == 0\n");*/ - if ( SkipJac == 0 ) { - /*printf("Entering if SkipJac == 0\n");*/ - JAC_CHEM(*T,Y,FJAC); - ISTATUS[Njac]++; - } /* end if */ - /*~~~> Compute the matrices E1 and E2 and their decompositions */ - RK_Decomp(N,H,FJAC,E1,IP1,E2R,E2I,IP2,&ISING,ISTATUS); - /*printf("ISING=%d\n", ISING);*/ - if ( ISING != 0 ) { - /*printf("Entering if ISING != 0\n");*/ - ISTATUS[Nsng]++; - Nconsecutive++; - if (Nconsecutive >= 5) { - RK_ErrorMsg(-12,*T,H,IERR); - } - H = H * ((KPP_REAL)0.5); - Reject = 1; - SkipJac = 1; - SkipLU = 0; - goto Tloop; - } - else { - /*printf("Entering if ISING == 0\n");*/ - Nconsecutive = 0; - } /* end if */ - } /* end if !SkipLU */ - - /*printf("NSTEPS=%d\n", ISTATUS[Nstp]);*/ - ISTATUS[Nstp]++; - /*printf("NSTEPS=%d\n", ISTATUS[Nstp]);*/ - if (ISTATUS[Nstp] > Max_no_steps) { - printf("\n Max number of time steps is = %d", Max_no_steps); - RK_ErrorMsg(-9,*T,H,IERR); - } /* end if */ - if (((KPP_REAL)0.1)*ABS(H) <= ABS(*T)*Roundoff) - RK_ErrorMsg(-10,*T,H,IERR); - - /*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - /*~~~> Loop for the simplified Newton iterations */ - /*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - - /*~~~> Starting values for Newton iteration */ - if ( (FirstStep == 1) || (StartNewton == 0) ) { - /*printf("Entering if FirstStep or Not StartNewton\n");*/ - Set2Zero(N,Z1); - Set2Zero(N,Z2); - Set2Zero(N,Z3); - } - else - { - /* Evaluate quadratic polynomial */ - RK_Interpolate("eval",N,H,Hold,Z1,Z2,Z3,CONT); - } /* end if */ - - /*~~~> Initializations for Newton iteration */ - NewtonDone = 0; - Fac = (KPP_REAL)0.5; /* Step reduction if too many iterations */ - - /* for NewtonLoop */ - for (NewtonIter = 1; NewtonIter <= NewtonMaxit; NewtonIter++) - { - /*printf("Starting NewtonIter loop: NewtonIter=%d\n", NewtonIter);*/ - /* Prepare the right-hand side */ - RK_PrepareRHS(N,*T,H,Y,FO,Z1,Z2,Z3,DZ1,DZ2,DZ3); - - /* Solve the linear systems */ - RK_Solve(N,H,E1,IP1,E2R,E2I,IP2,DZ1,DZ2,DZ3,ISTATUS); - - NewtonIncrement = - SQRT((RK_ErrorNorm(N,SCAL,DZ1) * RK_ErrorNorm(N,SCAL,DZ1) - + RK_ErrorNorm(N,SCAL,DZ2) * RK_ErrorNorm(N,SCAL,DZ2) - + RK_ErrorNorm(N,SCAL,DZ3) * RK_ErrorNorm(N,SCAL,DZ3)) - / (KPP_REAL)3.0 ); - /*printf( "NewtonIncrement=%g \n", NewtonIncrement );*/ - if (NewtonIter == 1) { - /*printf("Entering NewtonIter=%d == 1\n", NewtonIter);*/ - Theta = ABS(ThetaMin); - NewtonRate = (KPP_REAL)2.0; - } - else { - /*printf("Entering else from NewtonIter=%d == 1\n", NewtonIter);*/ - Theta = NewtonIncrement / NewtonIncrementOld; - /*printf("Theta=%f\n", Theta);*/ - if (Theta < (KPP_REAL)0.99) { - /*printf( "Entering if Theta=%g < 0.99\n", Theta );*/ - NewtonRate = Theta / (ONE-Theta); - } - else { /* Non-convergence of Newton: Theta too large */ - break; /* EXIT NewtonLoop */ - } /* end if */ - if (NewtonIter < NewtonMaxit) { - /*printf("Entering if NewtonIter=%d < NewtonMaxit=%d\n", NewtonIter, NewtonMaxit);*/ - /* Predict error at the end of Newton process */ - NewtonPredictedErr = NewtonIncrement - *pow(Theta,(NewtonMaxit-NewtonIter))/(ONE-Theta); - /*printf("NewtonRate=%g NewtonPredictedErr=%g \n", NewtonRate, NewtonPredictedErr);*/ - if (NewtonPredictedErr >= NewtonTol) { - /*printf( "Entering if NewtonPredictedErr=%g >= NewtonTol%g \n", NewtonPredictedErr, NewtonTol );*/ - /* Non-convergence of Newton: predicted error too large */ - Qnewton = MIN((KPP_REAL)10.0, NewtonPredictedErr/NewtonTol); - Fac = (KPP_REAL)0.8*pow(Qnewton,(-ONE/(1+NewtonMaxit-NewtonIter))); - break; /* EXIT NewtonLoop */ - } /* end if */ - } /* end if */ - } /* end if */ - - NewtonIncrementOld = MAX(NewtonIncrement, Roundoff); - /*printf("NewtonIncrementOld=%f\n", NewtonIncrementOld);*/ - /*~~~> Update solution */ - WAXPY(N,-ONE,DZ1,1,Z1,1); /* Z1 <- Z1 - DZ1 */ - WAXPY(N,-ONE,DZ2,1,Z2,1); /* Z2 <- Z2 - DZ2 */ - WAXPY(N,-ONE,DZ3,1,Z3,1); /* Z3 <- Z3 - DZ3 */ - /*for(i=0; i Check error in Newton iterations */ - /*printf( "NewtonRate=%g NewtonIncrement=%g NewtonTol=%g \n", NewtonRate, NewtonIncrement, NewtonTol );*/ - NewtonDone = (NewtonRate*NewtonIncrement <= NewtonTol); - /*printf( "NewtonDone=%d \n", NewtonDone );*/ - if (NewtonDone == 1) - break; /* Exit NewtonLoop */ - if (NewtonIter == NewtonMaxit) - { - printf("\n Slow or no convergence in Newton Iteration:"); - printf(" Max no. of Newton iterations reached"); - } /* end if */ - }/* end for NewtonLoop */ - - if ( NewtonDone == 0) - { - /*printf( "Entering if NewtonDone == 0\n" );*/ - /*RK_ErrorMsg(-12,*T,H,IERR); */ - H = Fac*H; - Reject = 1; - SkipJac = 1; - SkipLU = 0; - goto Tloop; - } /* end if */ - - /*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - /*~~~> SDIRK Stage */ - /*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - if (SdirkError == 1) - { - /*printf("Entering if SdirkError=%d==1\n", SdirkError);*/ - /*~~~> Starting values for Newton iterations */ - for (i = 0; i < N; i++) - { - Z4[i] = Z3[i]; - } - /*~~~> Prepare the loop-independent part of the right-hand side */ - /* G = H*rkBgam(0)*FO + rkTheta(1)*Z1 - + rkTheta(2)*Z2 + rkTheta(3)*Z3; */ - Set2Zero(N,G); - if (rkMethod != L3A) - WAXPY(N,rkBgam[0]*H, FO,1,G,1); - WAXPY(N,rkTheta[0],Z1,1,G,1); - WAXPY(N,rkTheta[1],Z2,1,G,1); - WAXPY(N,rkTheta[2],Z3,1,G,1); - - /*~~~> Initializations for Newton iteration */ - NewtonDone = 0; - Fac = (KPP_REAL)0.5; /* Step reduction factor if too many iterations */ - - /* for SDNewtonLoop */ - for (NewtonIter = 1; NewtonIter <= NewtonMaxit; NewtonIter++) - { - /*printf("Starting NewtonIter loop: NewtonIter=%d\n", NewtonIter);*/ - /*~~~> Prepare the loop-dependent part of right-hand side */ - WADD(N,Y,Z4,TMP); /* TMP <- Y + Z4 */ - FUN_CHEM(*T+H,TMP,DZ4); /* DZ4 <- Fun(Y+Z4) */ - ISTATUS[Nfun]++; - /* DZ4[1,N] = (D[1, N]-Z4[1,N])*(rkGamma/H) + DZ4[1,N]; */ - WAXPY(N,-ONE*rkGamma/H,Z4,1,DZ4,1); - WAXPY(N,rkGamma/H,G,1,DZ4,1); - - /*~~~> Solve the linear system */ - KppSolve(E1, DZ4); - /*~~~> Note: for a full matrix use Lapack: - DGETRS('N', 5, 1, E1, N, IP1, DZ4, 5, ISING) */ - - /*~~~> Check convergence of Newton iterations */ - NewtonIncrement = RK_ErrorNorm(N,SCAL,DZ4); - /*printf( "NewtonIncrement=%g \n", NewtonIncrement );*/ - if (NewtonIter == 1) { - /*printf("Entering NewtonIter=%d == 1\n", NewtonIter);*/ - ThetaSD = ABS(ThetaMin); - NewtonRate = (KPP_REAL)2.0; - } - else { - /*printf("Entering else from NewtonIter=%d == 1\n", NewtonIter);*/ - ThetaSD = NewtonIncrement / NewtonIncrementOld; - if (ThetaSD < (KPP_REAL)0.99) { - /*printf( "Entering if Theta=%g < 0.99\n", Theta );*/ - NewtonRate = ThetaSD / (ONE-ThetaSD); - /* Predict error at the end of Newton process */ - NewtonPredictedErr = NewtonIncrement - *pow(ThetaSD,(NewtonMaxit-NewtonIter))/(ONE-ThetaSD); - /*printf("NewtonRate=%g NewtonPredictedErr=%g \n", NewtonRate, NewtonPredictedErr);*/ - if (NewtonPredictedErr >= NewtonTol) { - /*printf( "Entering if NewtonPredictedErr=%g >= NewtonTol%g \n", NewtonPredictedErr, NewtonTol );*/ - /* Non-convergence of Newton: predicted error too large */ - /* printf("\n Error too large", NewtonPredictedErr); */ - Qnewton = MIN((KPP_REAL)10.0,NewtonPredictedErr/NewtonTol); - Fac = (KPP_REAL)0.8*pow(Qnewton,(-ONE/(1+NewtonMaxit-NewtonIter))); - break; /* EXIT SDNewtonLoop */ - } /* end if */ - } - /* Non-convergence of Newton: Theta too large */ - else { - /* prinf("\n Theta too large", ThetaSD); */ - break; /* EXIT SDNewtonLoop */ - } /* end if */ - } /* end if */ - NewtonIncrementOld = NewtonIncrement; - /*printf("NewtonIncrementOld=%f\n", NewtonIncrementOld);*/ - /* Update solution: Z4 <-- Z4 + DZ4; */ - WAXPY(N,ONE,DZ4,1,Z4,1); - - /* Check error in Newton iterations */ - NewtonDone = (NewtonRate*NewtonIncrement <= NewtonTol); - /*printf( "NewtonDone=%d \n", NewtonDone );*/ - if (NewtonDone == 1) - break; /* EXIT SDNewtonLoop */ - } /* end for SDNewtonLoop */ - - if ( NewtonDone == 0 ) { - /*printf( "Entering if NewtonDone == 0\n" );*/ - H = Fac*H; - Reject = 1; - SkipJac = 1; - SkipLU = 0; - goto Tloop; - } /* end if */ - } /* end if */ - /*~~~> End of implified SDIRK Newton iterations */ - - /*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - /*~~~> Error estimation */ - /*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - if (SdirkError == 1) { - Set2Zero(N, DZ4); - if (rkMethod == L3A) { - for (i = 0; i < N; i++) - DZ4[i] = H*rkF[0]*FO[i]; - if (rkF[0] != ZERO) - WAXPY(N, rkF[0], Z1, 1, DZ4, 1); - if (rkF[1] != ZERO) - WAXPY(N, rkF[1], Z2, 1, DZ4, 1); - if (rkF[2] != ZERO) - WAXPY(N, rkF[2], Z3, 1, DZ4, 1); - for (i = 0; i < N; i++) - TMP[i] = Y[i] + Z4[i]; - FUN_CHEM(*T+H, TMP, DZ1); - WAXPY(N, H*rkBgam[4], DZ1, 1, DZ4, 1); - } - else { - /* DZ4(1,N) = rkD(1)*Z1 + rkD(2)*Z2 + rkD(3)*Z3 - Z4; */ - if (rkD[0] != ZERO) - WAXPY(N, rkD[0], Z1, 1, DZ4, 1); - if (rkD[1] != ZERO) - WAXPY(N, rkD[1], Z2, 1, DZ4, 1); - if (rkD[2] != ZERO) - WAXPY(N, rkD[2], Z3, 1, DZ4, 1); - WAXPY(N, -ONE, Z4, 1, DZ4, 1); - } /* end if */ - Err = RK_ErrorNorm(N,SCAL,DZ4); - } - else - { - RK_ErrorEstimate(N,H,*T,Y,FO,E1,IP1,Z1,Z2,Z3,SCAL,&Err, - FirstStep,Reject,ISTATUS); - } /* end if */ - - /*~~~> Computation of new step size Hnew */ - Fac = pow(Err, (-ONE/rkELO)) - *MIN(FacSafe,(ONE+2*NewtonMaxit)/(NewtonIter+2*NewtonMaxit)); - Fac = MIN(FacMax,MAX(FacMin,Fac)); - Hnew = Fac*H; - - /*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - /*~~~> Accept/reject step */ - /*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - // accept: - if (Err < ONE) { /*~~~> STEP IS ACCEPTED */ - FirstStep = 0; - ISTATUS[Nacc]++; - if (Gustafsson == 1) { - /*~~~> Predictive controller of Gustafsson */ - if (ISTATUS[Nacc] > 1) { - FacGus = FacSafe*(H/Hacc)*pow(Err*Err/ErrOld,(KPP_REAL)(-0.25)); - FacGus = MIN(FacMax,MAX(FacMin,FacGus)); - Fac = MIN(Fac,FacGus); - Hnew = Fac*H; - } /* end if */ - Hacc = H; - ErrOld = MAX((KPP_REAL)1.0e-02,Err); - } /* end if */ - Hold = H; - *T = *T + H; - /* Update solution: Y <- Y + sum(d_i Z-i) */ - if (rkD[0] != ZERO) - WAXPY(N, rkD[0], Z1, 1, Y, 1); - if (rkD[1] != ZERO) - WAXPY(N, rkD[1], Z2, 1, Y, 1); - if (rkD[2] != ZERO) - WAXPY(N, rkD[2], Z3, 1, Y, 1); - /* Construct the solution quadratic interpolant Q(c_i) = Z_i, i=1:3 */ - if (StartNewton == 1) - RK_Interpolate("make",N,H,Hold,Z1,Z2,Z3,CONT); - RK_ErrorScale(N,ITOL,AbsTol,RelTol,Y,SCAL); - RSTATUS[Ntexit] = *T; - RSTATUS[Nhnew] = Hnew; - RSTATUS[Nhacc] = H; - Hnew = Tdirection*MIN( MAX(ABS(Hnew),Hmin), Hmax ); - if (Reject == 1) - Hnew = Tdirection*MIN(ABS(Hnew),ABS(H)); - Reject = 0; - if ((*T+Hnew/Qmin-Tend)*Tdirection >= ZERO) - H = Tend - *T; - else { - Hratio = Hnew/H; - /* Reuse the LU decomposition */ - SkipLU = (Theta <= ThetaMin) && (Hratio >= Qmin) && (Hratio <= Qmax); - if ( SkipLU == 0) - H = Hnew; - } /* end if */ - /* If convergence is fast enough, do not update Jacobian */ - /* SkipJac = (Theta <= ThetaMin); */ - SkipJac = 0; - } - - /*~~~> Step is rejected */ - else { - if ((FirstStep == 1) || (Reject == 1)) - H = FacRej*H; - else - H = Hnew; - Reject = 1; - SkipJac = 1; /* Skip if rejected - Jac is independent of H */ - SkipLU = 0; - if (ISTATUS[Nacc] >= 1) - ISTATUS[Nrej]++; - } /* end if accept */ - } /* while: time Tloop */ - - /*~~~> Successful exit */ - *IERR = 1; - -} /* RK_Integrator */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Handles all error messages and returns IERR = error Code -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void RK_ErrorMsg(int Code, KPP_REAL T, KPP_REAL H, int* IERR) -{ - Code = *IERR; - printf("\n~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"); - printf("\nForced exit from RungeKutta due to the following error:\n"); - - switch (Code) { - case -1: - printf("--> Improper value for maximal no of steps"); - break; - case -2: - printf("--> Improper value for maximal no of Newton iterations"); - break; - case -3: - printf("--> Hmin/Hmax/Hstart must be positive"); - break; - case -4: - printf("--> Improper values for FacMin/FacMax/FacSafe/FacRej"); - break; - case -5: - printf("--> Improper value for ThetaMin"); - break; - case -6: - printf("--> Newton stopping tolerance too small"); - break; - case -7: - printf("--> Improper values for Qmin, Qmax"); - break; - case -8: - printf("--> Tolerances are too small"); - break; - case -9: - printf("--> No of steps exceeds maximum bound"); - break; - case -10: - printf("--> Step size too small: (T + 10*H = T) or H < Roundoff"); - break; - case -11: - printf("--> Matrix is repeatedly singular"); - break; - case -12: - printf("--> Non-convergence of Newton iterations"); - break; - case -13: - printf("--> Requested RK method not implemented"); - break; - default: - printf("Unknown Error code: %d \n", Code); - } /* end switch */ - - printf("\n T=%e, H =%e", T, H); - printf("\n~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n"); - -} /* RK_ErrorMsg */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -/* Handles all error messages and returns SCAL */ -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void RK_ErrorScale(int N, - /*~~~> Input arguments: */ - int ITOL, KPP_REAL AbsTol[], KPP_REAL RelTol[], KPP_REAL Y[], - /*~~~> Output arguments: */ - KPP_REAL SCAL[]) -{ - /*printf("Starting RK_ErrorScale\n");*/ - int i; - if (ITOL == 0) { - for (i = 0; i < N; i++) { - SCAL[i] = ONE/(AbsTol[0]+RelTol[0]*ABS(Y[i])); - } /* end for loop*/ - } - else { - for (i = 0; i< N; i++) { - SCAL[i] = ONE/(AbsTol[i]+RelTol[i]*ABS(Y[i])); - } /* end for loop */ - } /* end if */ - /*printf("Ending RK_ErrorScale\n");*/ -} /* RK_ErrorScale */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -void RK_Transform(int N, KPP_REAL Tr[][3], KPP_REAL Z1[], KPP_REAL Z2[], - KPP_REAL Z3[], KPP_REAL W1[], KPP_REAL W2[], KPP_REAL W3[]) ---> W <-- Tr x Z -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -{ - int i; - KPP_REAL x1,x2,x3; - for (i = 0; i < N; i++) - { - x1 = Z1[i]; - x2 = Z2[i]; - x3 = Z3[i]; - W1[i] = Tr[0][0]*x1 + Tr[0][1]*x2 + Tr[0][2]*x3; - W2[i] = Tr[1][0]*x1 + Tr[1][1]*x2 + Tr[1][2]*x3; - W1[i] = Tr[2][0]*x1 + Tr[2][1]*x2 + Tr[2][2]*x3; - } end for loop -} end RK_Transform */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -/*--> Constructs or evaluates a quadratic polynomial that - interpolates the Z solution at current step and - provides starting values for the next step -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void RK_Interpolate(char action[], int N, KPP_REAL H, KPP_REAL Hold, KPP_REAL Z1[], - KPP_REAL Z2[], KPP_REAL Z3[], KPP_REAL CONT[][RKmax]) -{ - int i; - KPP_REAL r,x1,x2,x3,den; - - /* Construct the solution quadratic interpolant Q(c_i) = Z_i, i=1:3 */ - if (action == "make") { - den = (rkC[2]-rkC[1])*(rkC[1]-rkC[0])*(rkC[0]-rkC[2]); - for (i = 0; i < N; i++) - { - CONT[i][0] = (-rkC[2]*rkC[2]*rkC[1]*Z1[i] - +Z3[i]*rkC[1]*rkC[0]*rkC[0] - +rkC[1]*rkC[1]*rkC[2]*Z1[i] - -rkC[1]*rkC[1]*rkC[0]*Z3[i] - +rkC[2]*rkC[2]*rkC[0]*Z2[i] - -Z2[i]*rkC[2]*rkC[0]*rkC[0])/den-Z3[i]; - CONT[i][1] = -( rkC[0]*rkC[0]*(Z3[i]-Z2[i]) - + rkC[1]*rkC[1]*(Z1[i]-Z3[i]) - + rkC[2]*rkC[2]*(Z2[i]-Z1[i]) )/den; - CONT[i][2] = ( rkC[0]*(Z3[i]-Z2[i]) - + rkC[1]*(Z1[i]-Z3[i]) - + rkC[2]*(Z2[i]-Z1[i]) )/den; - } /* end for loop */ - } - /* Evaluate quadratic polynomial */ - else if (action == "eval") { - r = H / Hold; - x1 = ONE + rkC[0]*r; - x2 = ONE + rkC[1]*r; - x3 = ONE + rkC[2]*r; - for (i = 0; i < N; i++) - { - Z1[i] = CONT[i][0]+x1*(CONT[i][1]+x1*CONT[i][2]); - Z2[i] = CONT[i][0]+x2*(CONT[i][1]+x2*CONT[i][2]); - Z3[i] = CONT[i][0]+x3*(CONT[i][1]+x3*CONT[i][2]); - } /* end for loop */ - } /* end if */ -} /* RK_Interpolate */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -/*~~~> Prepare the right-hand side for Newton iterations - R = Z - hA x F -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void RK_PrepareRHS(int N, KPP_REAL T, KPP_REAL H, KPP_REAL Y[], KPP_REAL FO[], - KPP_REAL Z1[], KPP_REAL Z2[], KPP_REAL Z3[], KPP_REAL R1[], KPP_REAL R2[], - KPP_REAL R3[]) -{ - KPP_REAL TMP[N], F[N]; - WCOPY(N,Z1,1,R1,1); /* R1 <- Z1 */ - WCOPY(N,Z2,1,R2,1); /* R2 <- Z2 */ - WCOPY(N,Z3,1,R3,1); /* R3 <- Z3 */ - - if (rkMethod == L3A) - { - WAXPY(N,-H*rkA[0][0],FO,1,R1,1); /* R1 <- R1 - h*A_10*FO */ - WAXPY(N,-H*rkA[1][0],FO,1,R2,1); /* R2 <- R2 - h*A_20*FO */ - WAXPY(N,-H*rkA[2][0],FO,1,R3,1); /* R3 <- R3 - h*A_30*FO */ - } /* end if */ - - WADD(N,Y,Z1,TMP); /* TMP <- Y + Z1 */ - FUN_CHEM(T+rkC[0]*H,TMP,F); /* F1 <- Fun(Y+Z1) */ - WAXPY(N,-H*rkA[0][0],F,1,R1,1); /* R1 <- R1 - h*A_11*F1 */ - WAXPY(N,-H*rkA[1][0],F,1,R2,1); /* R2 <- R2 - h*A_21*F1 */ - WAXPY(N,-H*rkA[2][0],F,1,R3,1); /* R3 <- R3 - h*A_31*F1 */ - - WADD(N,Y,Z2,TMP); /* TMP <- Y + Z2 */ - FUN_CHEM(T+rkC[1]*H,TMP,F); /* F2 <- Fun(Y+Z2) */ - WAXPY(N,-H*rkA[0][1],F,1,R1,1); /* R1 <- R1 - h*A_12*F2 */ - WAXPY(N,-H*rkA[1][1],F,1,R2,1); /* R2 <- R2 - h*A_22*F2 */ - WAXPY(N,-H*rkA[2][1],F,1,R3,1); /* R3 <- R3 - h*A_32*F2 */ - - WADD(N,Y,Z3,TMP); /* TMP <- Y + Z3 */ - FUN_CHEM(T+rkC[2]*H,TMP,F); /* F3 <- Fun(Y+Z3) */ - WAXPY(N,-H*rkA[0][2],F,1,R1,1); /* R1 <- R1 - h*A_13*F3 */ - WAXPY(N,-H*rkA[1][2],F,1,R2,1); /* R2 <- R2 - h*A_23*F3 */ - WAXPY(N,-H*rkA[2][2],F,1,R3,1); /* R3 <- R3 - h*A_33*F3 */ -} /* RK_PrepareRHS */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -/*~~~> Compute the matrices E1 and E2 and their decompositions -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void RK_Decomp(int N, KPP_REAL H, KPP_REAL FJAC[], KPP_REAL E1[], - int IP1[], KPP_REAL E2R[], KPP_REAL E2I[], int IP2[], - int* ISING, int ISTATUS[]) -{ - /*printf("Starting RK_Decomp\n");*/ - KPP_REAL Alpha, Beta, Gamma; - int i,j; - - Gamma = rkGamma / H; - Alpha = rkAlpha / H; - Beta = rkBeta / H; - - for (i = 0; i < LU_NONZERO; i++) { - E1[i] = -FJAC[i]; - } - for (i = 0; i < NVAR; i++) { - j = LU_DIAG[i]; - E1[j] = E1[j] + Gamma; - } - *ISING = KppDecomp(E1); - /*~~~> Note: for a full matrix use Lapack: - for (j = 0; j < N; j++) { - for (i = 0; i < N; i++) - { - E1[i,j] = -FJAC[i][j]; - } - E1[i][j] = E1[i][j]+Gamma; - } - DGETRF(N, N, E1, N, IP1, ISING); */ - - if (*ISING != 0) { - /*printf("Matrix is singular, ISING=%d\n", *ISING);*/ - ISTATUS[Ndec]++; - return; - } - - for (i = 0; i < LU_NONZERO; i++) { - E2R[i] = (KPP_REAL)(-FJAC[i]); - E2I[i] = ZERO; - } - for (i = 0; i < NVAR; i++) { - j = LU_DIAG[i]; - E2R[j] = E2R[j] + Alpha; - E2I[j] = E2I[j] + Beta; - } - *ISING = KppDecompCmplxR(E2R, E2I); - /*printf("Matrix is singular, ISING=%d\n", *ISING);*/ - /*~~~> Note: for a full matrix use Lapack: - for (j = 0; j < N; j++) { - for (i = 0; i < N; i++) { - E2[i,j] = DCMPLX( -FJAC[i,j], ZERO ); - } - E2[j,j] = E2[j,j] + CMPLX( Alpha, Beta ); - } - ZGETRF(N,N,E2,N,IP2,ISING); */ - ISTATUS[Ndec]++; -} /*RK_Decomp */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void RK_Solve(int N, KPP_REAL H, KPP_REAL E1[], int IP1[], KPP_REAL E2R[], - KPP_REAL E2I[], int IP2[],KPP_REAL R1[], KPP_REAL R2[], KPP_REAL R3[], - int ISTATUS[]) -{ - KPP_REAL x1, x2, x3; - KPP_REAL BCR[N], BCI[N]; - int i; - - /* Z <- h^{-1) T^{-1) A^{-1) x Z */ - for (i = 0; i < N; i++) - { - x1 = R1[i]/H; - x2 = R2[i]/H; - x3 = R3[i]/H; - R1[i] = rkTinvAinv[0][0]*x1 + rkTinvAinv[0][1]*x2 + rkTinvAinv[0][2]*x3; - R2[i] = rkTinvAinv[1][0]*x1 + rkTinvAinv[1][1]*x2 + rkTinvAinv[1][2]*x3; - R3[i] = rkTinvAinv[2][0]*x1 + rkTinvAinv[2][1]*x2 + rkTinvAinv[2][2]*x3; - } - KppSolve(E1,R1); - /*~~~> Note: for a full matrix use Lapack: - DGETRS('N',5,1,E1,N,IP1,R1,5,0); */ - for(i = 0; i < N; i++) - { - BCR[i] = (KPP_REAL)(R2[i]); - BCI[i] = (KPP_REAL)(R3[i]); - } - KppSolveCmplxR(E2R,E2I,BCR,BCI); - /*~~~> Note: for a full matrix use Lapack: - ZGETRS ('N',N,1,E2,N,IP2,BC,N,0); */ - for (i = 0; i < N; i++) - { - R2[i] = (KPP_REAL)( BCR[i] ); - R3[i] = (KPP_REAL)( BCI[i] ); - } - - /* Z <- T x Z */ - for (i = 0; i < N; i++) - { - x1 = R1[i]; - x2 = R2[i]; - x3 = R3[i]; - R1[i] = rkT[0][0]*x1 + rkT[0][1]*x2 + rkT[0][2]*x3; - R2[i] = rkT[1][0]*x1 + rkT[1][1]*x2 + rkT[1][2]*x3; - R3[i] = rkT[2][0]*x1 + rkT[2][1]*x2 + rkT[2][2]*x3; - } - ISTATUS[Nsol]++; -} /* RK_Solve */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void RK_ErrorEstimate(int N, KPP_REAL H, KPP_REAL T, KPP_REAL Y[], - KPP_REAL FO[], KPP_REAL E1[], int IP1[], KPP_REAL Z1[], - KPP_REAL Z2[], KPP_REAL Z3[], KPP_REAL SCAL[], KPP_REAL* Err, - int FirstStep, int Reject, int ISTATUS[]) -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -{ - KPP_REAL F1[N],F2[N],TMP[N]; - KPP_REAL HrkE1,HrkE2,HrkE3; - int i; - - HrkE1 = rkE[0]/H; - HrkE2 = rkE[1]/H; - HrkE3 = rkE[2]/H; - - for (i = 0; i < N; i++) - { - F2[i] = HrkE1*Z1[i]+HrkE2*Z2[i]+HrkE3*Z3[i]; - TMP[i] = rkE[0]*FO[i] + F2[i]; - } - - KppSolve(E1, TMP); - if ((rkMethod == R1A) || (rkMethod == GAU) || (rkMethod == L3A)) - KppSolve(E1,TMP); - if (rkMethod == GAU) - KppSolve(E1,TMP); - /*~~~> Note: for a full matrix use Lapack: - DGETRS ('N',N,1,E1,N,IP1,TMP,N,0); - if ((rkMethod == R1A) || (rkMethod == GAU) || (rkMethod == L3A)) - DGETRS('N',N,1,E1,N,IP1,TMP,N,0); - if (rkMethod == GAU) - DGETRS('N',N,1,E1,N,IP1,TMP,N,0); */ - - *Err = RK_ErrorNorm(N,SCAL,TMP); - - if (*Err < ONE) - return; - /* firej */ - if ((FirstStep == 1) || (Reject == 1)) { - for (i = 0; i < N; i++) { - TMP[i] = Y[i] + TMP[i]; - } /* end for */ - FUN_CHEM(T,TMP,F1); - ISTATUS[Nfun]++; - for (i = 0; i < N; i++) { - TMP[i] = F1[i] + F2[i]; - } /* end for */ - - KppSolve(E1, TMP); - /*~~~> Note: for a full matrix use Lapack: - DGETRS ('N',N,1,E1,N,IP1,TMP,N,0); */ - *Err = RK_ErrorNorm(N,SCAL,TMP); - } /* end if firej */ -} /* RK_ErrorEstimate */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - KPP_REAL RK_ErrorNorm(int N, KPP_REAL SCAL[], KPP_REAL DY[]) -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -{ - int i; - KPP_REAL RK_ErrorNorm = ZERO; - for (i = 0; i < N; i++) { - RK_ErrorNorm = RK_ErrorNorm + (DY[i]*SCAL[i]) * (DY[i]*SCAL[i]); - } - RK_ErrorNorm = MAX( SQRT(RK_ErrorNorm/N), (KPP_REAL)1.0e-10 ); - return RK_ErrorNorm; -} /* RK_ErrorNorm */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - The coefficients of the 3-stage Radau-2A method - (given to ~30 accurate digits) -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void Radau2A_Coefficients() -{ - /*printf("Starting Radau2A\n");*/ - /* The coefficients of the Radau2A method */ - KPP_REAL b0; - /* b0 = (KPP_REAL)1.0; */ - if (SdirkError == 1) { - b0 = (KPP_REAL)(0.2e-01); - /*printf("b0 = %f\n", b0);*/ - } - else { - b0 = (KPP_REAL)(0.5e-01); - /*printf("b0 = %f\n", b0);*/ - } /*end if */ - /* The coefficients of the Radau2A method */ - rkMethod = R2A; - - rkA[0][0] = (KPP_REAL)(1.968154772236604258683861429918299e-01); - rkA[0][1] = (KPP_REAL)(-6.55354258501983881085227825696087e-02); - rkA[0][2] = (KPP_REAL)(2.377097434822015242040823210718965e-02); - rkA[1][0] = (KPP_REAL)(3.944243147390872769974116714584975e-01); - rkA[1][1] = (KPP_REAL)(2.920734116652284630205027458970589e-01); - rkA[1][2] = (KPP_REAL)(-4.154875212599793019818600988496743e-02); - rkA[2][0] = (KPP_REAL)(3.764030627004672750500754423692808e-01); - rkA[2][1] = (KPP_REAL)(5.124858261884216138388134465196080e-01); - rkA[2][2] = (KPP_REAL)(1.111111111111111111111111111111111e-01); - - rkB[0] = (KPP_REAL)(3.764030627004672750500754423692808e-01); - rkB[1] = (KPP_REAL)(5.124858261884216138388134465196080e-01); - rkB[2] = (KPP_REAL)(1111111111111111111111111111111111e-01); - - rkC[0] = (KPP_REAL)(1.550510257216821901802715925294109e-01); - rkC[1] = (KPP_REAL)(6.449489742783178098197284074705891e-01); - rkC[2] = ONE; - - /* New solution: H* Sum B_j*f(Z_j) = Sum D_j*Z_j */ - rkD[0] = ZERO; - rkD[1] = ZERO; - rkD[2] = ONE; - - /* Classical error estimator: */ - /* H* Sum (B_j-Bhat_j)*f(Z_j) = H*E(0)*f(0) + Sum E_j*Z_j */ - rkE[0] = ONE*b0; - rkE[1] = (KPP_REAL)(-10.04880939982741556246032950764708)*b0; - rkE[2] = (KPP_REAL)1.382142733160748895793662840980412*b0; - rkE[3] = (KPP_REAL)(-.3333333333333333333333333333333333)*b0; - - /* Sdirk error estimator */ - rkBgam[0] = b0; - rkBgam[1] = (KPP_REAL).3764030627004672750500754423692807 - -(KPP_REAL)1.558078204724922382431975370686279*b0; - rkBgam[2] = (KPP_REAL).8914115380582557157653087040196118*b0 - +(KPP_REAL).5124858261884216138388134465196077; - rkBgam[3] = (KPP_REAL)(-.1637777184845662566367174924883037) - -(KPP_REAL).3333333333333333333333333333333333*b0; - rkBgam[4] = (KPP_REAL).2748888295956773677478286035994148; - - /* H* Sum Bgam_j*f(Z_j) = H*Bgam(0)*f(0) + Sum Theta_j*Z_j */ - rkTheta[0] = (KPP_REAL)(-1.520677486405081647234271944611547) - -(KPP_REAL)10.04880939982741556246032950764708*b0; - rkTheta[1] = (KPP_REAL)2.070455145596436382729929151810376 - +(KPP_REAL)1.382142733160748895793662840980413*b0; - rkTheta[2] = (KPP_REAL)(-.3333333333333333333333333333333333)*b0 - -(KPP_REAL).3744441479783868387391430179970741; - - /* Local order of error estimator */ - if ( b0 == ZERO) - rkELO = (KPP_REAL)6.0; - else - rkELO = (KPP_REAL)4.0; - - /*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ~~~> Diagonalize the RK matrix: - rkTinv * inv(rkA) * rkT = - | rkGamma 0 0 | - | 0 rkAlpha -rkBeta | - | 0 rkBeta rkAlpha | - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - - rkGamma = (KPP_REAL)3.637834252744495732208418513577775; - rkAlpha = (KPP_REAL)2.681082873627752133895790743211112; - rkBeta = (KPP_REAL)3.050430199247410569426377624787569; - - rkT[0][0] = (KPP_REAL)(9.443876248897524148749007950641664e-02); - rkT[0][1] = (KPP_REAL)(-1.412552950209542084279903838077973e-01); - rkT[0][2] = (KPP_REAL)(-3.00291941051474244918611170890539e-02); - rkT[1][0] = (KPP_REAL)(2.502131229653333113765090675125018e-01); - rkT[1][1] = (KPP_REAL)(2.041293522937999319959908102983381e-01); - rkT[1][2] = (KPP_REAL)(3.829421127572619377954382335998733e-01); - rkT[2][0] = ONE; - rkT[2][1] = ONE; - rkT[2][2] = ZERO; - - rkTinv[0][0] = (KPP_REAL)4.178718591551904727346462658512057; - rkTinv[0][1] = (KPP_REAL)(3.27682820761062387082533272429617e-01); - rkTinv[0][2] = (KPP_REAL)(5.233764454994495480399309159089876e-01); - rkTinv[1][0] = (KPP_REAL)(-4.178718591551904727346462658512057); - rkTinv[1][1] = (KPP_REAL)(-3.27682820761062387082533272429617e-01); - rkTinv[1][2] = (KPP_REAL)(4.766235545005504519600690840910124e-01); - rkTinv[2][0] = (KPP_REAL)(-5.02872634945786875951247343139544e-01); - rkTinv[2][1] = (KPP_REAL)2.571926949855605429186785353601676; - rkTinv[2][2] = (KPP_REAL)(-5.960392048282249249688219110993024e-01); - - rkTinvAinv[0][0] = (KPP_REAL)(1.520148562492775501049204957366528e+01); - rkTinvAinv[0][1] = (KPP_REAL)1.192055789400527921212348994770778; - rkTinvAinv[0][2] = (KPP_REAL)1.903956760517560343018332287285119; - rkTinvAinv[1][0] = (KPP_REAL)(-9.669512977505946748632625374449567); - rkTinvAinv[1][1] = (KPP_REAL)(-8.724028436822336183071773193986487); - rkTinvAinv[1][2] = (KPP_REAL)3.096043239482439656981667712714881; - rkTinvAinv[2][0] = (KPP_REAL)(-1.409513259499574544876303981551774e+01); - rkTinvAinv[2][1] = (KPP_REAL)5.895975725255405108079130152868952; - rkTinvAinv[2][2] = (KPP_REAL)(-1.441236197545344702389881889085515e-01); - - rkAinvT[0][0] = (KPP_REAL).3435525649691961614912493915818282; - rkAinvT[0][1] = (KPP_REAL)(-.4703191128473198422370558694426832); - rkAinvT[0][2] = (KPP_REAL).3503786597113668965366406634269080; - rkAinvT[1][0] = (KPP_REAL).9102338692094599309122768354288852; - rkAinvT[1][1] = (KPP_REAL)1.715425895757991796035292755937326; - rkAinvT[1][2] = (KPP_REAL).4040171993145015239277111187301784; - rkAinvT[2][0] = (KPP_REAL)3.637834252744495732208418513577775; - rkAinvT[2][1] = (KPP_REAL)2.681082873627752133895790743211112; - rkAinvT[2][2] = (KPP_REAL)(-3.050430199247410569426377624787569); - /*printf("Ending Radau2A");*/ -} /* Radau2A_Coefficients */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - The coefficients of the 3-stage Lobatto-3C method - (given to ~30 accurate digits) - The parameter b0 can be chosen to tune the error estimator -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void Lobatto3C_Coefficients () -{ - KPP_REAL b0; - rkMethod = L3C; - /* b0 = 1.0d0 */ - if (SdirkError == 1) - b0 = (KPP_REAL)0.2; - else - b0 = (KPP_REAL)0.5; - - /* The coefficients of the Lobatto3C method */ - rkA[0][0] = (KPP_REAL).1666666666666666666666666666666667; - rkA[0][1] = (KPP_REAL)(-.3333333333333333333333333333333333); - rkA[0][2] = (KPP_REAL).1666666666666666666666666666666667; - rkA[1][0] = (KPP_REAL).1666666666666666666666666666666667; - rkA[1][1] = (KPP_REAL).4166666666666666666666666666666667; - rkA[1][2] = (KPP_REAL)(-.8333333333333333333333333333333333e-01); - rkA[2][0] = (KPP_REAL).1666666666666666666666666666666667; - rkA[2][1] = (KPP_REAL).6666666666666666666666666666666667; - rkA[2][2] = (KPP_REAL).1666666666666666666666666666666667; - - rkB[0] = (KPP_REAL).1666666666666666666666666666666667; - rkB[1] = (KPP_REAL).6666666666666666666666666666666667; - rkB[2] = (KPP_REAL).1666666666666666666666666666666667; - - rkC[0] = ZERO; - rkC[1] = (KPP_REAL)0.5; - rkC[2] = ONE; - - /* Classical error estimator, embedded solution: */ - rkBhat[0] = b0; - rkBhat[1] = (KPP_REAL).16666666666666666666666666666666667-b0; - rkBhat[2] = (KPP_REAL).66666666666666666666666666666666667; - rkBhat[3] = (KPP_REAL).16666666666666666666666666666666667; - - /* New solution: h Sum_j b_j f(Z_j) = sum d_j Z_j */ - rkD[0] = ZERO; - rkD[1] = ZERO; - rkD[2] = ONE; - - /* Classical error estimator: */ - /* H* Sum (B_j-Bhat_j)*f(Z_j) = H*E(0)*f(0) + Sum E_j*Z_j */ - rkE[0] = (KPP_REAL).3808338772072650364017425226487022*b0; - rkE[1] = (KPP_REAL)(-1.142501631621795109205227567946107)*b0; - rkE[2] = (KPP_REAL)(-1.523335508829060145606970090594809)*b0; - rkE[3] = (KPP_REAL).3808338772072650364017425226487022*b0; - - /* Sdirk error estimator */ - rkBgam[0] = b0; - rkBgam[1] = (KPP_REAL).1666666666666666666666666666666667-1.0*b0; - rkBgam[2] = (KPP_REAL).6666666666666666666666666666666667; - rkBgam[3] = (KPP_REAL)(-.2141672105405983697350758559820354); - rkBgam[4] = (KPP_REAL).3808338772072650364017425226487021; - - /* H* Sum Bgam_j*f(Z_j) = H*Bgam(0)*f(0) + Sum Theta_j*Z_j */ - rkTheta[0] = -3.0*b0-(KPP_REAL).3808338772072650364017425226487021; - rkTheta[1] = -4.0*b0+(KPP_REAL)1.523335508829060145606970090594808; - rkTheta[2] = (KPP_REAL)(-.142501631621795109205227567946106)+b0; - - /* Local order of error estimator */ - if (b0 == ZERO) - rkELO = 5.0; - else - rkELO = 4.0; - - /*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ~~~> Diagonalize the RK matrix: - rkTinv * inv(rkA) * rkT = - | rkGamma 0 0 | - | 0 rkAlpha -rkBeta | - | 0 rkBeta rkAlpha | - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - - rkGamma = (KPP_REAL)2.625816818958466716011888933765284; - rkAlpha = (KPP_REAL)1.687091590520766641994055533117359; - rkBeta = (KPP_REAL)2.508731754924880510838743672432351; - - rkT[0][1] = ONE; - rkT[0][1] = ONE; - rkT[0][2] = ZERO; - rkT[1][0] = (KPP_REAL).4554100411010284672111720348287483; - rkT[1][1] = (KPP_REAL)(-.6027050205505142336055860174143743); - rkT[1][2] = (KPP_REAL)(-.4309321229203225731070721341350346); - rkT[2][0] = (KPP_REAL)2.195823345445647152832799205549709; - rkT[2][1] = (KPP_REAL)(-1.097911672722823576416399602774855); - rkT[2][2] = (KPP_REAL).7850032632435902184104551358922130; - - rkTinv[0][0] = (KPP_REAL).4205559181381766909344950150991349; - rkTinv[0][1] = (KPP_REAL).3488903392193734304046467270632057; - rkTinv[0][2] = (KPP_REAL).1915253879645878102698098373933487; - rkTinv[1][0] = (KPP_REAL).5794440818618233090655049849008650; - rkTinv[1][1] = (KPP_REAL)(-.3488903392193734304046467270632057); - rkTinv[1][2] = (KPP_REAL)(-.1915253879645878102698098373933487); - rkTinv[2][0] = (KPP_REAL)(-.3659705575742745254721332009249516); - rkTinv[2][1] = (KPP_REAL)(-1.463882230297098101888532803699806); - rkTinv[2][2] = (KPP_REAL).4702733607340189781407813565524989; - - rkTinvAinv[0][0] = (KPP_REAL)1.104302803159744452668648155627548; - rkTinvAinv[0][1] = (KPP_REAL).916122120694355522658740710823143; - rkTinvAinv[0][2] = (KPP_REAL).5029105849749601702795812241441172; - rkTinvAinv[1][0] = (KPP_REAL)1.895697196840255547331351844372453; - rkTinvAinv[1][1] = (KPP_REAL)3.083877879305644477341259289176857; - rkTinvAinv[1][2] = (KPP_REAL)(-1.502910584974960170279581224144117); - rkTinvAinv[2][0] = (KPP_REAL).8362439183082935036129145574774502; - rkTinvAinv[2][1] = (KPP_REAL)(-3.344975673233174014451658229909802); - rkTinvAinv[2][2] = (KPP_REAL).312908409479233358005944466882642; - - rkAinvT[0][0] = (KPP_REAL)2.625816818958466716011888933765282; - rkAinvT[0][1] = (KPP_REAL)1.687091590520766641994055533117358; - rkAinvT[0][2] = (KPP_REAL)(-2.508731754924880510838743672432351); - rkAinvT[1][0] = (KPP_REAL)1.195823345445647152832799205549710; - rkAinvT[1][1] = (KPP_REAL)(-2.097911672722823576416399602774855); - rkAinvT[1][2] = (KPP_REAL).7850032632435902184104551358922130; - rkAinvT[2][0] = (KPP_REAL)5.765829871932827589653709477334136; - rkAinvT[2][1] = (KPP_REAL).1170850640335862051731452613329320; - rkAinvT[2][2] = (KPP_REAL)4.078738281412060947659653944216779; -} /* Lobatto3C_Coefficients */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - The coefficients of the 3-stage Gauss method - (given to ~30 accurate digits) - The parameter b3 can be chosen by the user - to tune the error estimator - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void Gauss_Coefficients() -{ - rkMethod = GAU; - - /* The coefficients of the Gauss method */ - KPP_REAL b0; - /*b0 = (KPP_REAL)4.0; */ - b0 = (KPP_REAL)0.1; - - /* The coefficients of the Gauss method */ - rkA[0][0] = (KPP_REAL).1388888888888888888888888888888889; - rkA[0][1] = (KPP_REAL)(-.359766675249389034563954710966045e-01); - rkA[0][2] = (KPP_REAL)(.97894440153083260495800422294756e-02); - rkA[1][0] = (KPP_REAL).3002631949808645924380249472131556; - rkA[1][1] = (KPP_REAL).2222222222222222222222222222222222; - rkA[1][2] = (KPP_REAL)(-.224854172030868146602471694353778e-01); - rkA[2][0] = (KPP_REAL).2679883337624694517281977355483022; - rkA[2][1] = (KPP_REAL).4804211119693833479008399155410489; - rkA[2][2] = (KPP_REAL).1388888888888888888888888888888889; - - rkB[0] = (KPP_REAL).2777777777777777777777777777777778; - rkB[1] = (KPP_REAL).4444444444444444444444444444444444; - rkB[2] = (KPP_REAL).2777777777777777777777777777777778; - - rkC[0] = (KPP_REAL).1127016653792583114820734600217600; - rkC[1] = (KPP_REAL).5000000000000000000000000000000000; - rkC[2] = (KPP_REAL).8872983346207416885179265399782400; - - /* Classical error estimator, embedded solution: */ - rkBhat[0] = b0; - rkBhat[1] = (KPP_REAL)(-1.4788305577012361475298775666303999)*b0 - +(KPP_REAL).27777777777777777777777777777777778; - rkBhat[2] = (KPP_REAL).44444444444444444444444444444444444 - +(KPP_REAL).66666666666666666666666666666666667*b0; - rkBhat[3] = (KPP_REAL)(-.18783610896543051913678910003626672)*b0 - +(KPP_REAL).27777777777777777777777777777777778; - - /* New solution: h Sum_j b_j f(Z_j) = sum d_j Z_j */ - rkD[0] = (KPP_REAL)(.1666666666666666666666666666666667e+01); - rkD[1] = (KPP_REAL)(-.1333333333333333333333333333333333e+01); - rkD[2] = (KPP_REAL)(.1666666666666666666666666666666667e+01); - - /* Classical error estimator: */ - /* H* Sum (B_j-Bhat_j)*f(Z_j) = H*E(0)*f(0) + Sum E_j*Z_j */ - rkE[0] = (KPP_REAL).2153144231161121782447335303806954*b0; - rkE[1] = (KPP_REAL)(-2.825278112319014084275808340593191)*b0; - rkE[2] = (KPP_REAL).2870858974881495709929780405075939*b0; - rkE[3] = (KPP_REAL)(-.4558086256248162565397206448274867e-01)*b0; - - /* Sdirk error estimator */ - rkBgam[0] = ZERO; - rkBgam[1] = (KPP_REAL).2373339543355109188382583162660537; - rkBgam[2] = (KPP_REAL).5879873931885192299409334646982414; - rkBgam[3] = (KPP_REAL)(-.4063577064014232702392531134499046e-01); - rkBgam[4] = (KPP_REAL).2153144231161121782447335303806955; - - /* H* Sum Bgam_j*f(Z_j) = H*Bgam(0)*f(0) + Sum Theta_j*Z_j */ - rkTheta[0] = (KPP_REAL)(-2.594040933093095272574031876464493); - rkTheta[1] = (KPP_REAL)1.824611539036311947589425112250199; - rkTheta[2] = (KPP_REAL).1856563166634371860478043996459493; - - /* ELO = local order of classical error estimator */ - rkELO = (KPP_REAL)4.0; - - /*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ~~~> Diagonalize the RK matrix: - rkTinv * inv(rkA) * rkT = - | rkGamma 0 0 | - | 0 rkAlpha -rkBeta | - | 0 rkBeta rkAlpha | - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - - rkGamma = (KPP_REAL)4.644370709252171185822941421408064; - rkAlpha = (KPP_REAL)3.677814645373914407088529289295970; - rkBeta = (KPP_REAL)3.508761919567443321903661209182446; - - rkT[0][0] = (KPP_REAL)(.7215185205520017032081769924397664e-01); - rkT[0][1] = (KPP_REAL)(-.8224123057363067064866206597516454e-01); - rkT[0][2] = (KPP_REAL)(-.6012073861930850173085948921439054e-01); - rkT[1][0] = (KPP_REAL).1188325787412778070708888193730294; - rkT[1][1] = (KPP_REAL)(.5306509074206139504614411373957448e-01); - rkT[1][2] = (KPP_REAL).3162050511322915732224862926182701; - rkT[2][0] = ONE; - rkT[2][1] = ONE; - rkT[2][2] = ZERO; - - rkTinv[0][0] = (KPP_REAL)5.991698084937800775649580743981285; - rkTinv[0][1] = (KPP_REAL)1.139214295155735444567002236934009; - rkTinv[0][2] = (KPP_REAL).4323121137838583855696375901180497; - rkTinv[1][0] = (KPP_REAL)(-5.991698084937800775649580743981285); - rkTinv[1][1] = (KPP_REAL)(-1.139214295155735444567002236934009); - rkTinv[1][2] = (KPP_REAL).5676878862161416144303624098819503; - rkTinv[2][0] = (KPP_REAL)(-1.246213273586231410815571640493082); - rkTinv[2][1] = (KPP_REAL)2.925559646192313662599230367054972; - rkTinv[2][2] = (KPP_REAL)(-.2577352012734324923468722836888244); - - rkTinvAinv[0][0] = (KPP_REAL)27.82766708436744962047620566703329; - rkTinvAinv[0][1] = (KPP_REAL)5.290933503982655311815946575100597; - rkTinvAinv[0][2] = (KPP_REAL)2.007817718512643701322151051660114; - rkTinvAinv[1][0] = (KPP_REAL)(-17.66368928942422710690385180065675); - rkTinvAinv[1][1] = (KPP_REAL)(-14.45491129892587782538830044147713); - rkTinvAinv[1][2] = (KPP_REAL)2.992182281487356298677848948339886; - rkTinvAinv[2][0] = (KPP_REAL)(-25.60678350282974256072419392007303); - rkTinvAinv[2][1] = (KPP_REAL)6.762434375611708328910623303779923; - rkTinvAinv[2][2] = (KPP_REAL)1.043979339483109825041215970036771; - - rkAinvT[0][0] = (KPP_REAL).3350999483034677402618981153470483; - rkAinvT[0][1] = (KPP_REAL)(-.5134173605009692329246186488441294); - rkAinvT[0][2] = (KPP_REAL)(.6745196507033116204327635673208923e-01); - rkAinvT[1][0] = (KPP_REAL).5519025480108928886873752035738885; - rkAinvT[1][1] = (KPP_REAL)1.304651810077110066076640761092008; - rkAinvT[1][2] = (KPP_REAL).9767507983414134987545585703726984; - rkAinvT[2][0] = (KPP_REAL)4.644370709252171185822941421408064; - rkAinvT[2][1] = (KPP_REAL)3.677814645373914407088529289295970; - rkAinvT[2][2] = (KPP_REAL)(-3.508761919567443321903661209182446); -} /* Gauss_Coefficients */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - The coefficients of the 3-stage Gauss method - (given to ~30 accurate digits) - The parameter b3 can be chosen by the user - to tune the error estimator -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void Radau1A_Coefficients() -{ - /* The coefficients of the Radau1A method */ - KPP_REAL b0; - /*b0 = (KPP_REAL)0.3; */ - b0 = (KPP_REAL)0.1; - - /* The coefficients of the Radau1A method */ - rkMethod = R1A; - - rkA[0][0] = (KPP_REAL) .1111111111111111111111111111111111; - rkA[0][1] = (KPP_REAL)(-.1916383190435098943442935597058829); - rkA[0][2] = (KPP_REAL)(.8052720793239878323318244859477174e-01); - rkA[1][0] = (KPP_REAL).1111111111111111111111111111111111; - rkA[1][1] = (KPP_REAL).2920734116652284630205027458970589; - rkA[1][2] = (KPP_REAL)(-.481334970546573839513422644787591e-01); - rkA[2][0] = (KPP_REAL).1111111111111111111111111111111111; - rkA[2][1] = (KPP_REAL).5370223859435462728402311533676479; - rkA[2][2] = (KPP_REAL).1968154772236604258683861429918299; - - rkB[0] = (KPP_REAL).1111111111111111111111111111111111; - rkB[1] = (KPP_REAL).5124858261884216138388134465196080; - rkB[2] = (KPP_REAL).3764030627004672750500754423692808; - - rkC[0] = ZERO; - rkC[1] = (KPP_REAL).3550510257216821901802715925294109; - rkC[2] = (KPP_REAL).8449489742783178098197284074705891; - - /* Classical error estimator, embedded solution: */ - rkBhat[0] = b0; - rkBhat[1] = (KPP_REAL).11111111111111111111111111111111111-b0; - rkBhat[2] = (KPP_REAL).51248582618842161383881344651960810; - rkBhat[3] = (KPP_REAL).37640306270046727505007544236928079; - - /* New solution: H* Sum B_j*f(Z_j) = Sum D_j*Z_j */ - rkD[0] = (KPP_REAL).3333333333333333333333333333333333; - rkD[1] = (KPP_REAL)(-.8914115380582557157653087040196127); - rkD[2] = (KPP_REAL)(1.558078204724922382431975370686279); - - /* Classical error estimator: */ - /* H* Sum (b_j-bhat_j) f(Z_j) = H*E(0)*F(0) + Sum E_j Z_j */ - rkE[0] = (KPP_REAL).2748888295956773677478286035994148*b0; - rkE[1] = (KPP_REAL)(-1.374444147978386838739143017997074)*b0; - rkE[2] = (KPP_REAL)(-1.335337922441686804550326197041126)*b0; - rkE[3] = (KPP_REAL).235782604058977333559011782643466*b0; - - /* Sdirk error estimator */ - rkBgam[0] = ZERO; - rkBgam[1] = (KPP_REAL)(.1948150124588532186183490991130616e-01); - rkBgam[2] = (KPP_REAL).7575249005733381398986810981093584; - rkBgam[3] = (KPP_REAL)(-.518952314149008295083446116200793e-01); - rkBgam[4] = (KPP_REAL).2748888295956773677478286035994148; - - /* H* Sum Bgam_j*f(Z_j) = H*Bgam(0)*f(0) + Sum Theta_j*Z_j */ - rkTheta[0] = (KPP_REAL)(-1.224370034375505083904362087063351); - rkTheta[1] = (KPP_REAL).9340045331532641409047527962010133; - rkTheta[2] = (KPP_REAL).4656990124352088397561234800640929; - - /* ELO = local order of classical error estimator */ - rkELO = (KPP_REAL)4.0; - - /*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ~~~> Diagonalize the RK matrix: - rkTinv * inv(rkA) * rkT = - | rkGamma 0 0 | - | 0 rkAlpha -rkBeta | - | 0 rkBeta rkAlpha | - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - - rkGamma = (KPP_REAL)3.637834252744495732208418513577775; - rkAlpha = (KPP_REAL)2.681082873627752133895790743211112; - rkBeta = (KPP_REAL)3.050430199247410569426377624787569; - - rkT[0][0] = (KPP_REAL).424293819848497965354371036408369; - rkT[0][1] = (KPP_REAL)(-.3235571519651980681202894497035503); - rkT[0][2] = (KPP_REAL)(-.522137786846287839586599927945048); - rkT[1][0] = (KPP_REAL)(.57594609499806128896291585429339e-01); - rkT[1][1] = (KPP_REAL)(.3148663231849760131614374283783e-02); - rkT[1][2] = (KPP_REAL).452429247674359778577728510381731; - rkT[2][0] = ONE; - rkT[2][1] = ONE; - rkT[2][2] = ZERO; - - rkTinv[0][0] = (KPP_REAL)1.233523612685027760114769983066164; - rkTinv[0][1] = (KPP_REAL)1.423580134265707095505388133369554; - rkTinv[0][2] = (KPP_REAL).3946330125758354736049045150429624; - rkTinv[1][0] = (KPP_REAL)(-1.233523612685027760114769983066164); - rkTinv[1][1] = (KPP_REAL)(-1.423580134265707095505388133369554); - rkTinv[1][2] = (KPP_REAL).6053669874241645263950954849570376; - rkTinv[2][0] = (KPP_REAL)(-.1484438963257383124456490049673414); - rkTinv[2][1] = (KPP_REAL)2.038974794939896109682070471785315; - rkTinv[2][2] = (KPP_REAL)(-.544501292892686735299355831692542e-01); - - rkTinvAinv[0][0] = (KPP_REAL)4.487354449794728738538663081025420; - rkTinvAinv[0][1] = (KPP_REAL)5.178748573958397475446442544234494; - rkTinvAinv[0][2] = (KPP_REAL)1.435609490412123627047824222335563; - rkTinvAinv[1][0] = (KPP_REAL)(-2.854361287939276673073807031221493); - rkTinvAinv[1][1] = (KPP_REAL)(-1.003648660720543859000994063139137e+01); - rkTinvAinv[1][2] = (KPP_REAL)1.789135380979465422050817815017383; - rkTinvAinv[2][0] = (KPP_REAL)(-4.160768067752685525282947313530352); - rkTinvAinv[2][1] = (KPP_REAL)1.124128569859216916690209918405860; - rkTinvAinv[2][2] = (KPP_REAL)1.700644430961823796581896350418417; - - rkAinvT[0][0] = (KPP_REAL)1.543510591072668287198054583233180; - rkAinvT[0][1] = (KPP_REAL)(-2.460228411937788329157493833295004); - rkAinvT[0][2] = (KPP_REAL)(-.412906170450356277003910443520499); - rkAinvT[1][0] = (KPP_REAL).209519643211838264029272585946993; - rkAinvT[1][1] = (KPP_REAL)1.388545667194387164417459732995766; - rkAinvT[1][2] = (KPP_REAL)1.20339553005832004974976023130002; - rkAinvT[2][0] = (KPP_REAL)3.637834252744495732208418513577775; - rkAinvT[2][1] = (KPP_REAL)2.681082873627752133895790743211112; - rkAinvT[2][2] = (KPP_REAL)(-3.050430199247410569426377624787569); -} /* Radau1A_Coefficients */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - The coefficients of the 4-stage Lobatto-3A method - (given to ~30 accurate digits) - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void Lobatto3A_Coefficients() -{ - /* The coefficients of the Lobatto-3A method */ - rkMethod = L3A; - - rkA[0][0] = ZERO; - rkA[0][1] = ZERO; - rkA[0][2] = ZERO; - rkA[0][3] = ZERO; - rkA[1][0] = (KPP_REAL).11030056647916491413674311390609397; - rkA[1][1] = (KPP_REAL).1896994335208350858632568860939060; - rkA[1][2] = (KPP_REAL)(-.339073642291438837776604807792215e-01); - rkA[1][3] = (KPP_REAL)(.1030056647916491413674311390609397e-01); - rkA[2][0] = (KPP_REAL)(.73032766854168419196590219427239365e-01); - rkA[2][1] = (KPP_REAL).4505740308958105504443271474458881; - rkA[2][2] = (KPP_REAL).2269672331458315808034097805727606; - rkA[2][3] = (KPP_REAL)(-.2696723314583158080340978057276063e-01); - rkA[3][0] = (KPP_REAL)(.83333333333333333333333333333333333e-01); - rkA[3][1] = (KPP_REAL).4166666666666666666666666666666667; - rkA[3][2] = (KPP_REAL).4166666666666666666666666666666667; - rkA[3][3] = (KPP_REAL)(.8333333333333333333333333333333333e-01); - - rkB[0] = (KPP_REAL)(.83333333333333333333333333333333333e-01); - rkB[1] = (KPP_REAL).4166666666666666666666666666666667; - rkB[2] = (KPP_REAL).4166666666666666666666666666666667; - rkB[3] = (KPP_REAL)(.8333333333333333333333333333333333e-01); - - rkC[0] = ZERO; - rkC[1] = (KPP_REAL).2763932022500210303590826331268724; - rkC[2] = (KPP_REAL).7236067977499789696409173668731276; - rkC[3] = ONE; - - /* New solution: H*Sum B_j*f(Z_j) = Sum D_j*Z_j */ - rkD[0] = ZERO; - rkD[1] = ZERO; - rkD[2] = ZERO; - rkD[3] = ONE; - - /* Classical error estimator, embedded solution: */ - rkBhat[0] = (KPP_REAL)(.90909090909090909090909090909090909e-01); - rkBhat[1] = (KPP_REAL).39972675774621371442114262372173276; - rkBhat[2] = (KPP_REAL).43360657558711961891219070961160058; - rkBhat[3] = (KPP_REAL)(.15151515151515151515151515151515152e-01); - - /* Classical error estimator: */ - /* H* Sum (B_j-Bhat_j)*f(Z_j) = H*E(0)*f(0) + Sum E_j*Z_j */ - - rkE[0] = (KPP_REAL)(.1957403846510110711315759367097231e-01); - rkE[1] = (KPP_REAL)(-.1986820345632580910316020806676438); - rkE[2] = (KPP_REAL).1660586371214229125096727578826900; - rkE[3] = (KPP_REAL)(-.9787019232550553556578796835486154e-01); - - /* Sdirk error estimator: */ - rkF[0] = ZERO; - rkF[1] = (KPP_REAL)(-.66535815876916686607437314126436349); - rkF[2] = (KPP_REAL)1.7419302743497277572980407931678409; - rkF[3] = (KPP_REAL)(-1.2918865386966730694684011822841728); - - /* ELO = local order of classical error estimator */ - rkELO = (KPP_REAL)4.0; - - /* Sdirk error estimator: */ - rkBgam[0] = (KPP_REAL)(.2950472755430528877214995073815946e-01); - rkBgam[1] = (KPP_REAL).5370310883226113978352873633882769; - rkBgam[2] = (KPP_REAL).2963022450107219354980459699450564; - rkBgam[3] = (KPP_REAL)(-.7815248400375080035021681445218837e-01); - rkBgam[4] = (KPP_REAL).2153144231161121782447335303806956; - - /* H* Sum Bgam_j*f(Z_j) = H*Bgam(0)*f(0) + Sum Theta_j*Z_j */ - rkTheta[0] = (KPP_REAL)0.0; - rkTheta[1] = (KPP_REAL)(-.6653581587691668660743731412643631); - rkTheta[2] = (KPP_REAL)1.741930274349727757298040793167842; - rkTheta[3] = (KPP_REAL)(-.291886538696673069468401182284174); - - - /*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ~~~> Diagonalize the RK matrix: - rkTinv * inv(rkA) * rkT = - | rkGamma 0 0 | - | 0 rkAlpha -rkBeta | - | 0 rkBeta rkAlpha | - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - - rkGamma = (KPP_REAL)4.644370709252171185822941421408063; - rkAlpha = (KPP_REAL)3.677814645373914407088529289295968; - rkBeta = (KPP_REAL)3.508761919567443321903661209182446; - - rkT[0][0] = (KPP_REAL)(.5303036326129938105898786144870856e-01); - rkT[0][1] = (KPP_REAL)(-.7776129960563076320631956091016914e-01); - rkT[0][2] = (KPP_REAL)(.6043307469475508514468017399717112e-02); - rkT[1][0] = (KPP_REAL).2637242522173698467283726114649606; - rkT[1][1] = (KPP_REAL).2193839918662961493126393244533346; - rkT[1][2] = (KPP_REAL).3198765142300936188514264752235344; - rkT[2][0] = ONE; - rkT[2][1] = ZERO; - rkT[2][2] = ZERO; - - rkTinv[0][0] = (KPP_REAL)7.695032983257654470769069079238553; - rkTinv[0][1] = (KPP_REAL)(-.1453793830957233720334601186354032); - rkTinv[0][2] = (KPP_REAL).6302696746849084900422461036874826; - rkTinv[1][0] = (KPP_REAL)(-7.695032983257654470769069079238553); - rkTinv[1][1] = (KPP_REAL).1453793830957233720334601186354032; - rkTinv[1][2] = (KPP_REAL).3697303253150915099577538963125174; - rkTinv[2][0] = (KPP_REAL)(-1.066660885401270392058552736086173); - rkTinv[2][1] = (KPP_REAL)3.146358406832537460764521760668932; - rkTinv[2][2] = (KPP_REAL)(-.7732056038202974770406168510664738); - - rkTinvAinv[0][0] = (KPP_REAL)35.73858579417120341641749040405149; - rkTinvAinv[0][1] = (KPP_REAL)(-.675195748578927863668368190236025); - rkTinvAinv[0][2] = (KPP_REAL)2.927206016036483646751158874041632; - rkTinvAinv[1][0] = (KPP_REAL)(-24.55824590667225493437162206039511); - rkTinvAinv[1][1] = (KPP_REAL)(-10.50514413892002061837750015342036); - rkTinvAinv[1][2] = (KPP_REAL)4.072793983963516353248841125958369; - rkTinvAinv[2][0] = (KPP_REAL)(-30.92301972744621647251975054630589); - rkTinvAinv[2][1] = (KPP_REAL)12.08182467154052413351908559269928; - rkTinvAinv[2][2] = (KPP_REAL)(-1.546411207640594954081233702132946); - - rkAinvT[0][0] = (KPP_REAL).2462926658317812882584158369803835; - rkAinvT[0][1] = (KPP_REAL)(-.2647871194157644619747121197289574); - rkAinvT[0][2] = (KPP_REAL).2950720515900466654896406799284586; - rkAinvT[1][0] = (KPP_REAL)1.224833192317784474576995878738004; - rkAinvT[1][1] = (KPP_REAL)1.929224190340981580557006261869763; - rkAinvT[1][2] = (KPP_REAL).4066803323234419988910915619080306; - rkAinvT[2][0] = (KPP_REAL)4.644370709252171185822941421408064; - rkAinvT[2][1] = (KPP_REAL)3.677814645373914407088529289295968; - rkAinvT[2][2] = (KPP_REAL)(-3.508761919567443321903661209182446); -} /* Lobatto3A_Coefficients */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - END SUBROUTINE RungeKutta ! and all its internal procedures - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void FUN_CHEM(KPP_REAL T, KPP_REAL V[], KPP_REAL FCT[]) -{ - KPP_REAL Told; - - Told = TIME; - TIME = T; - Update_SUN(); - Update_RCONST(); - Update_PHOTO(); - TIME = Told; - - Fun(V, FIX, RCONST, FCT); - -} /* FUN_CHEM */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void JAC_CHEM (KPP_REAL T, KPP_REAL V[], KPP_REAL JF[]) -{ - KPP_REAL Told; - - Told = TIME; - TIME = T; - Update_SUN(); - Update_RCONST(); - Update_PHOTO(); - TIME = Told; - Jac_SP(V, FIX, RCONST, JF); -} /* JAC_CHEM */ diff --git a/boxmox/int/runge_kutta.def b/boxmox/int/runge_kutta.def deleted file mode 100644 index 33068e3a65a0fa0e06f50ac1acf134dffe7d4222..0000000000000000000000000000000000000000 --- a/boxmox/int/runge_kutta.def +++ /dev/null @@ -1,8 +0,0 @@ - -#FUNCTION AGGREGATE -#JACOBIAN SPARSE_LU_ROW - -#DOUBLE ON -#INTFILE runge_kutta - - diff --git a/boxmox/int/runge_kutta_adj.def b/boxmox/int/runge_kutta_adj.def deleted file mode 100644 index 0dd22b7ed67a4e501514b926b1b37d2f6e567efa..0000000000000000000000000000000000000000 --- a/boxmox/int/runge_kutta_adj.def +++ /dev/null @@ -1,8 +0,0 @@ - -#FUNCTION AGGREGATE -#JACOBIAN SPARSE_LU_ROW - -#DOUBLE ON -#INTFILE runge_kutta_adj - - diff --git a/boxmox/int/runge_kutta_tlm.def b/boxmox/int/runge_kutta_tlm.def deleted file mode 100644 index bc99e6db97bc055da8feb5527080796bf3fc9a72..0000000000000000000000000000000000000000 --- a/boxmox/int/runge_kutta_tlm.def +++ /dev/null @@ -1,8 +0,0 @@ - -#FUNCTION AGGREGATE -#JACOBIAN SPARSE_LU_ROW - -#DOUBLE ON -#INTFILE runge_kutta_tlm - - diff --git a/boxmox/int/sdirk.c b/boxmox/int/sdirk.c deleted file mode 100644 index 11b06872356ef466bb33ccde2129f11b01a05f9f..0000000000000000000000000000000000000000 --- a/boxmox/int/sdirk.c +++ /dev/null @@ -1,1361 +0,0 @@ -#define MAX(a,b) ( ((a) >= (b)) ?(a):(b) ) -#define MIN(b,c) ( ((b) < (c)) ?(b):(c) ) -#define ABS(x) ( ((x) >= 0 ) ?(x):(-x) ) -#define SQRT(d) ( pow((d),0.5) ) -#define SIGN(x,y)( ( (x*y) >= 0 ) ?(x):(-x) )/* Sign transfer function */ -#define MOD(A,B) (int)((A)%(B)) - -/* ~~~> Numerical constants */ -#define ZERO (KPP_REAL)0.0 -#define ONE (KPP_REAL)1.0 - -/* ~~~> Statistics on the work performed by the SDIRK method */ -#define Nfun 1 -#define Njac 2 -#define Nstp 3 -#define Nacc 4 -#define Nrej 5 -#define Ndec 6 -#define Nsol 7 -#define Nsng 8 -#define Ntexit 1 -#define Nhexit 2 -#define Nhnew 3 - -/*~~~> SDIRK method coefficients, up to 5 stages */ -#define Smax 5 - -int S2A=1, - S2B=2, - S3A=3, - S4A=4, - S4B=5; - -int sdMethod, - rkS; - -KPP_REAL rkGamma, - rkA[Smax][Smax], - rkB[Smax], - rkELO, - rkBhat[Smax], - rkC[Smax], - rkD[Smax], - rkE[Smax], - rkTheta[Smax][Smax], - rkAlpha[Smax][Smax]; - -/*~~~> Function headers */ -//void INTEGRATE(KPP_REAL TIN, KPP_REAL TOUT, int ICNTRL_U[], KPP_REAL RCNTRL_U[], -// int ISTATUS_U[], KPP_REAL RSTATUS_U[], int Ierr); -void INTEGRATE(KPP_REAL TIN, KPP_REAL TOUT); -int SDIRK(int N, KPP_REAL Tinitial, KPP_REAL Tfinal, KPP_REAL Y[], - KPP_REAL RelTol[], KPP_REAL AbsTol[], KPP_REAL RCNTRL[], int ICNTRL[], - KPP_REAL RSTATUS[], int ISTATUS[]); -int SDIRK_Integrator(int N, KPP_REAL Tinitial, KPP_REAL Tfinal, KPP_REAL Y[], - int Ierr, KPP_REAL Hstart, KPP_REAL Hmin, KPP_REAL Hmax, KPP_REAL Roundoff, - KPP_REAL AbsTol[], KPP_REAL RelTol[], int ISTATUS[], KPP_REAL RSTATUS[], - int ITOL, int Max_no_steps, int StartNewton, KPP_REAL NewtonTol, - KPP_REAL ThetaMin, KPP_REAL FacSafe, KPP_REAL FacMin, KPP_REAL FacMax, - KPP_REAL FacRej, KPP_REAL Qmin, KPP_REAL Qmax, int NewtonMaxit); -void SDIRK_ErrorScale(int N, int ITOL, KPP_REAL AbsTol[], KPP_REAL RelTol[], - KPP_REAL Y[], KPP_REAL SCAL[]); -KPP_REAL SDIRK_ErrorNorm(int N, KPP_REAL Y[], KPP_REAL SCAL[]); -int SDIRK_ErrorMsg(int code, KPP_REAL T, KPP_REAL H, int Ierr); -void SDIRK_PrepareMatrix(KPP_REAL H, KPP_REAL T, KPP_REAL Y[], KPP_REAL FJAC[], - int SkipJac, int SkipLU, KPP_REAL E[], int IP[], int Reject, - int ISING, int ISTATUS[]); -void SDIRK_Solve(KPP_REAL H, int N, KPP_REAL E[], int IP[], int ISING, - KPP_REAL RHS[], int ISTATUS[]); -void Sdirk4a(void); -void Sdirk4b(void); -void Sdirk2a(void); -void Sdirk2b(void); -void Sdirk3a(void); -void FUN_CHEM(KPP_REAL T, KPP_REAL Y[], KPP_REAL P[]); -void JAC_CHEM(KPP_REAL T, KPP_REAL Y[], KPP_REAL JV[]); -void Fun(KPP_REAL Y[], KPP_REAL FIX[], KPP_REAL RCONST[], KPP_REAL Ydot[]); -void Jac_SP(KPP_REAL Y[], KPP_REAL FIX[], KPP_REAL RCONST[], KPP_REAL Ydot[]); -void WAXPY(int N, KPP_REAL Alpha, KPP_REAL X[], int incX, KPP_REAL Y[], int incY); -void WSCAL(int N, KPP_REAL Alpha, KPP_REAL X[], int incX); -KPP_REAL WLAMCH(char C); -void WADD(int N, KPP_REAL Y[], KPP_REAL Z[], KPP_REAL TMP[]); -void Set2Zero(int N, KPP_REAL Y[]); -void KppSolve(KPP_REAL A[], KPP_REAL b[]); -int KppDecomp(KPP_REAL A[]); -void Update_SUN(); -void Update_RCONST(); - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -//void INTEGRATE(KPP_REAL TIN, KPP_REAL TOUT, int ICNTRL_U[], KPP_REAL RCNTRL_U[], -// int ISTATUS_U[], KPP_REAL RSTATUS_U[], int Ierr_U) -void INTEGRATE(KPP_REAL TIN, KPP_REAL TOUT) -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -{ - -/* int Ntotal = 0; *//* Used for debug option below to print the number of steps */ -KPP_REAL RCNTRL[20], - RSTATUS[20], - T1, - T2; - -int ICNTRL[20], - ISTATUS[20], - Ierr; - -Ierr = 0; - -int i; -for(i=0; i<20; i++) { - ICNTRL[i] = 0; - RCNTRL[i] = (KPP_REAL)0.0; - ISTATUS[i] = 0; - RSTATUS[i] = (KPP_REAL)0.0; -} /* end for */ - -/*~> fine-tune the integrator: */ -ICNTRL[1] = 0; /* 0 - vector tolerances, 1 - scalar tolerances */ -ICNTRL[5] = 0; /* starting values of N. iter.: interpolated 0), zero (1) */ - -///* If optional parameters are given, and if they are >0, -// then they overwrite default settings. */ -//if(ICNTRL_U != NULL) { /* Check to see if ICNTRL_U is not NULL */ -// for(i=0; i<20; i++) { -// if(ICNTRL_U[i] > 0) { -// ICNTRL[i] = ICNTRL_U[i]; -// } /* end if */ -// } /* end for */ -//} /* end if */ -// -//if(RCNTRL_U != NULL) { /* Check to see if RCNTRL_U is not NULL */ -// for(i=0; i<20; i++) { -// if(RCNTRL_U[i] > 0) { -// RCNTRL[i] = RCNTRL_U[i]; -// } /* end if */ -// } /* end for */ -//} /* end if */ - - -T1 = TIN; -T2 = TOUT; -Ierr = SDIRK( NVAR, T1, T2, VAR, RTOL, ATOL, RCNTRL, ICNTRL, RSTATUS, - ISTATUS); - - -/*~~~> Debug option: print number of steps - Ntotal += ISTATUS[Nstp]; */ - -if(Ierr < 0) { - printf("SDIRK: Unsuccessful exit at T=%f(Ierr=%d)", TIN, Ierr); -} - -///*if optional parameters are given for output they to return information */ -//if(ISTATUS_U != NULL) { /* Check to see if ISTATUS_U is not NULL */ -// for(i=0; i<20; i++) { -// ISTATUS_U[i] = ISTATUS[i]; -// } /* end for */ -//} /* end if */ -// -//if(RSTATUS_U != NULL) { /* Check to see if RSTATUS_U is not NULL */ -// for(i=0; i<20; i++) { -// RSTATUS_U[i] = RSTATUS[i]; -// } /* end for */ -//} /* end if */ -// -//Ierr_U = Ierr; - -} - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -int SDIRK(int N, KPP_REAL Tinitial, KPP_REAL Tfinal, KPP_REAL Y[], - KPP_REAL RelTol[], KPP_REAL AbsTol[], KPP_REAL RCNTRL[], - int ICNTRL[], KPP_REAL RSTATUS[], int ISTATUS[]) -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - Solves the system y'=F(t,y) using a Singly-Diagonally-Implicit - Runge-Kutta (SDIRK) method. - - This implementation is based on the book and the code Sdirk4: - - E. Hairer and G. Wanner - "Solving ODEs II. Stiff and differential-algebraic problems". - Springer series in computational mathematics, Springer-Verlag, 1996. - This code is based on the SDIRK4 routine in the above book. - - Methods: - * Sdirk 2a, 2b: L-stable, 2 stages, order 2 - * Sdirk 3a: L-stable, 3 stages, order 2, adjoint-invariant - * Sdirk 4a, 4b: L-stable, 5 stages, order 4 - - (C) Adrian Sandu, July 2005 - Virginia Polytechnic Institute and State University - Contact: sandu@cs.vt.edu - Revised by Philipp Miehe and Adrian Sandu, May 2006 - Translation F90 to C by Paul Eller and Nicholas Hobbs, July 2006 - This implementation is part of KPP - the Kinetic PreProcessor -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -~~~> INPUT ARGUMENTS: - - - Y[NVAR] = vector of initial conditions (at T=Tinitial) - - [Tinitial,Tfinal] = time range of integration - (if Tinitial>Tfinal the integration is performed backwards in time) - - RelTol, AbsTol = user precribed accuracy - - SUBROUTINE ode_Fun( T, Y, Ydot ) = ODE function, - returns Ydot = Y' = F(T,Y) - - SUBROUTINE ode_Fun( T, Y, Ydot ) = Jacobian of the ODE function, - returns Jcb = dF/dY - - ICNTRL[1:20] = integer inputs parameters - - RCNTRL[1:20] = real inputs parameters -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -~~~> OUTPUT ARGUMENTS: - - - Y[NVAR] -> vector of final states (at T->Tfinal) - - ISTATUS[1:20] -> integer output parameters - - RSTATUS[1:20] -> real output parameters - - Ierr -> job status upon return - success (positive value) or - failure (negative value) -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -~~~> INPUT PARAMETERS: - Note: For input parameters equal to zero the default values of the - corresponding variables are used. - - Note: For input parameters equal to zero the default values of the - corresponding variables are used. -~~~> - ICNTRL[0] = not used - ICNTRL[1] = 0: AbsTol, RelTol are NVAR-dimensional vectors - = 1: AbsTol, RelTol are scalars - ICNTRL[2] = Method - ICNTRL[3] -> maximum number of integration steps - For ICNTRL[3]=0 the default value of 100000 is used - ICNTRL[4] -> maximum number of Newton iterations - For ICNTRL(4)=0 the default value of 8 is used - ICNTRL[5] -> starting values of Newton iterations: - ICNTRL[5]=0 : starting values are interpolated (the default) - ICNTRL[5]=1 : starting values are zero - -~~~> Real parameters - - RCNTRL[0] -> Hmin, lower bound for the integration step size - It is strongly recommended to keep Hmin = ZERO - RCNTRL[1] -> Hmax, upper bound for the integration step size - RCNTRL[2] -> Hstart, starting value for the integration step size - RCNTRL[3] -> FacMin, lower bound on step decrease factor (default=0.2) - RCNTRL[4] -> FacMax, upper bound on step increase factor (default=6) - RCNTRL[5] -> FacRej, step decrease factor after multiple rejections - (default=0.1) - RCNTRL[6] -> FacSafe, by which the new step is slightly smaller - than the predicted value (default=0.9) - RCNTRL[7] -> ThetaMin. If Newton convergence rate smaller - than ThetaMin the Jacobian is not recomputed; - (default=0.001) - RCNTRL[8] -> NewtonTol, stopping criterion for Newton's method - (default=0.03) - RCNTRL[9] -> Qmin - RCNTRL[10] -> Qmax. If Qmin < Hnew/Hold < Qmax, then the - step size is kept constant and the LU factorization - reused (default Qmin=1, Qmax=1.2) -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -~~~> OUTPUT PARAMETERS: - Note: each call to Rosenbrock adds the current no. of fcn calls - to previous value of ISTATUS(1), and similar for the other params. - Set ISTATUS(1:10) = 0 before call to avoid this accumulation. - ISTATUS[0] = No. of function calls - ISTATUS[1] = No. of jacobian calls - ISTATUS[2] = No. of steps - ISTATUS[3] = No. of accepted steps - ISTATUS[4] = No. of rejected steps (except at the beginning) - ISTATUS[5] = No. of LU decompositions - ISTATUS[6] = No. of forward/backward substitutions - ISTATUS[7] = No. of singular matrix decompositions - RSTATUS[0] -> Texit, the time corresponding to the computed Y upon return - RSTATUS[1] -> Hexit,last accepted step before return - RSTATUS[2] -> Hnew, last predicted step before return - For multiple restarts, use Hnew as Hstart in the following run - -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -{ - -int Max_no_steps=0; - -/*~~~> Local variables */ -int StartNewton; - -KPP_REAL Hmin=0, - Hmax=0, - Hstart=0, - Roundoff, - FacMin=0, - FacMax=0, - FacSafe=0, - FacRej=0, - ThetaMin, - NewtonTol, - Qmin, - Qmax; - -int ITOL, - NewtonMaxit, - i, - Ierr = 0; - -/*~~~> For Scalar tolerances (ICNTRL[1] !=0 ) the code uses AbsTol[1] and RelTol[1) - For Vector tolerances (ICNTRL[1] == 0) the code uses AbsTol[1:NVAR] and RelTol[1:NVAR] */ -if (ICNTRL[1]==0){ - ITOL = 1; -} -else { - ITOL = 0; -} /* end if */ - -/*~~~> ICNTRL[3] - method selection */ - -switch (ICNTRL[2]) { - -case 0: Sdirk2a(); - break; - -case 1: Sdirk2a(); - break; - -case 2: Sdirk2b(); - break; - -case 3: Sdirk3a(); - break; - -case 4: Sdirk4a(); - break; - -case 5: Sdirk4b(); - break; - -default: Sdirk2a(); - -} /* end switch */ - -/*~~~> The maximum number of time steps admitted */ -if (ICNTRL[3] == 0) { - Max_no_steps = 200000; -} -else if (ICNTRL[3] > 0) { - Max_no_steps = ICNTRL[3]; -} -else { - printf("User-selected ICNTRL(4)=%d", ICNTRL[3]); - SDIRK_ErrorMsg(-1,Tinitial,ZERO,Ierr); -} /*end if */ - -/*~~~>The maximum number of Newton iterations admitted */ -if(ICNTRL[4]==0) { - NewtonMaxit = 8; -} -else { - NewtonMaxit=ICNTRL[4]; - if(NewtonMaxit <=0) { - printf("User-selected ICNTRL(5)=%d", ICNTRL[4] ); - SDIRK_ErrorMsg(-2,Tinitial,ZERO,Ierr); - } -} - -/*~~~> StartNewton: Extrapolate for starting values of Newton iterations */ -if (ICNTRL[5] == 0) { - StartNewton = 1; -} -else { - StartNewton = 0; -} /* end if */ - -/*~~~> Unit roundoff (1+Roundoff>1) */ -Roundoff = WLAMCH('E'); - -/*~~~> Lower bound on the step size: (positive value) */ -if (RCNTRL[0] == ZERO) { - Hmin = ZERO; -} -else if (RCNTRL[0] > ZERO) { - Hmin = RCNTRL[0]; -} -else { - printf("User-selected RCNTRL[0]=%f", RCNTRL[0]); - SDIRK_ErrorMsg(-3,Tinitial,ZERO,Ierr); -} /* end if */ - -/*~~~> Upper bound on the step size: (positive value) */ -if (RCNTRL[1] == ZERO) { - Hmax = ABS(Tfinal-Tinitial); -} -else if (RCNTRL[1] > ZERO) { - Hmax = MIN( ABS(RCNTRL[1]), ABS(Tfinal-Tinitial) ); -} -else { - printf("User-selected RCNTRL[1]=%f", RCNTRL[1]); - SDIRK_ErrorMsg(-3,Tinitial,ZERO,Ierr); -} /* end if */ - -/*~~~> Starting step size: (positive value) */ -if (RCNTRL[2] == ZERO) { - Hstart = MAX( Hmin, Roundoff); -} -else if (RCNTRL[2] > ZERO) { - Hstart = MIN( ABS(RCNTRL[2]), ABS(Tfinal-Tinitial) ); -} -else { - printf("User-selected Hstart: RCNTRL[2]=%f", RCNTRL[2]); - SDIRK_ErrorMsg(-3,Tinitial,ZERO,Ierr); -} /* end if */ - -/*~~~> Step size can be changed s.t. FacMin < Hnew/Hexit < FacMax */ -if (RCNTRL[3] == ZERO) { - FacMin = (KPP_REAL)0.2; -} -else if (RCNTRL[3] > ZERO) { - FacMin = RCNTRL[3]; -} -else { - printf("User-selected FacMin: RCNTRL[3]=%f", RCNTRL[3]); - SDIRK_ErrorMsg(-4,Tinitial,ZERO,Ierr); -} /* end if */ - -if (RCNTRL[4] == ZERO) { - FacMax = (KPP_REAL)10.0; -} -else if (RCNTRL[4] > ZERO) { - FacMax = RCNTRL[4]; -} -else { - printf("User-selected FacMax: RCNTRL[4]=%f", RCNTRL[4]); - SDIRK_ErrorMsg(-4,Tinitial,ZERO,Ierr); -} /* end if */ - -/*~~~> FacRej: Factor to decrease step after 2 succesive rejections */ -if (RCNTRL[5] == ZERO) { - FacRej = (KPP_REAL)0.1; -} -else if (RCNTRL[5] > ZERO) { - FacRej = RCNTRL[5]; -} -else { - printf("User-selected FacRej: RCNTRL[5]=%f", RCNTRL[5]); - SDIRK_ErrorMsg(-4,Tinitial,ZERO,Ierr); -} /*end if */ - -/* ~~~> FacSafe: Safety Factor in the computation of new step size */ -if (RCNTRL[6] == ZERO) { - FacSafe = (KPP_REAL)0.9; -} -else if (RCNTRL[6] > ZERO) { - FacSafe = RCNTRL[6]; -} -else { - printf("User-selected FacSafe: RCNTRL[6]=%f", RCNTRL[6]); - SDIRK_ErrorMsg(-4,Tinitial,ZERO,Ierr); -} /* end if */ - -/*~~~> ThetaMin: decides whether the Jacobian should be recomputed */ -if (RCNTRL[7] == ZERO) { - ThetaMin = (KPP_REAL)1.0e-03; -} -else { - ThetaMin = RCNTRL[7]; -} /* end if */ - -/*~~~> Stopping criterion for Newton's method */ -if (RCNTRL[8] == ZERO) { - NewtonTol = (KPP_REAL)3.0e-02; -} -else { - NewtonTol = RCNTRL[8]; -} /* end if */ - -/* ~~~> Qmin, Qmax: IF Qmin < Hnew/Hold < Qmax, STEP SIZE = CONST. */ -if (RCNTRL[9] == ZERO) { - Qmin = ONE; -} -else { - Qmin = RCNTRL[9]; -} /* end if */ - -if (RCNTRL[10] == ZERO) { - Qmax = (KPP_REAL)1.2; -} -else { - Qmax = RCNTRL [10]; -} /* end if */ - -/* ~~~> Check if tolerances are reasonable */ -if (ITOL == 0) { - if ((AbsTol[0]<=ZERO || RelTol[0])<=(((KPP_REAL)10.0)*Roundoff)) { - SDIRK_ErrorMsg(-5,Tinitial,ZERO,Ierr); - } /* end internal if */ -} -else { - for (i = 0; i < N; i++) { - if((AbsTol[i]<=ZERO)||(RelTol[i]<=((KPP_REAL)10.0)*Roundoff)){ - SDIRK_ErrorMsg(-5,Tinitial,ZERO,Ierr); - } /* end internal if */ - } /* end for */ -} /* end if */ - -if (Ierr < 0) { - return Ierr; -} /*end if */ - -Ierr = SDIRK_Integrator(N, Tinitial, Tfinal, Y, Ierr, Hstart, Hmin, Hmax, - Roundoff, AbsTol, RelTol, ISTATUS, RSTATUS, ITOL, Max_no_steps, - StartNewton, NewtonTol, ThetaMin, FacSafe, FacMin, FacMax, FacRej, - Qmin, Qmax, NewtonMaxit); - -return Ierr; - -} /* end of main SDIRK function */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -int SDIRK_Integrator(int N, KPP_REAL Tinitial, KPP_REAL Tfinal, KPP_REAL Y[], - int Ierr, KPP_REAL Hstart, KPP_REAL Hmin, KPP_REAL Hmax, KPP_REAL Roundoff, - KPP_REAL AbsTol[], KPP_REAL RelTol[], int ISTATUS[], KPP_REAL RSTATUS[], - int ITOL, int Max_no_steps, int StartNewton, KPP_REAL NewtonTol, - KPP_REAL ThetaMin, KPP_REAL FacSafe, KPP_REAL FacMin, KPP_REAL FacMax, - KPP_REAL FacRej, KPP_REAL Qmin, KPP_REAL Qmax, int NewtonMaxit) -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -{ - -/*~~~> Local variables: */ -KPP_REAL Z[Smax][NVAR], - G[NVAR], - TMP[NVAR], - NewtonRate, - SCAL[NVAR], - RHS[NVAR], - T, - H, - Theta=0, - Hratio, - NewtonPredictedErr, - Qnewton, - Err=0, - Fac, - Hnew, - Tdirection, - NewtonIncrement=0, - NewtonIncrementOld=0; - -int IER=0, - istage, - NewtonIter, - IP[NVAR], - Reject, - FirstStep, - SkipJac, - SkipLU, - NewtonDone, - CycleTloop, - i, - j; - -#ifdef FULL_ALGEBRA - KPP_REAL FJAC[NVAR][NVAR]; - KPP_REAL E[NVAR][NVAR]; -#else - KPP_REAL FJAC[LU_NONZERO]; - KPP_REAL E[LU_NONZERO]; -#endif - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -/*~~~~> Initializations */ -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -T = Tinitial; -Tdirection = SIGN(ONE, Tfinal-Tinitial); -H = MAX(ABS(Hmin), ABS(Hstart)); - -if(ABS(H) <= ((KPP_REAL)10.0 * Roundoff)) { - H = (KPP_REAL)(1.0e-06); -} /* end if */ - -H = MIN(ABS(H), Hmax); -H = SIGN(H, Tdirection); -SkipLU = 0; -SkipJac = 0; -Reject = 0; -FirstStep = 1; -CycleTloop = 0; - -SDIRK_ErrorScale(N, ITOL, AbsTol, RelTol, Y, SCAL); - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -/*~~~> Time loop begins */ -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -while((Tfinal-T)*Tdirection - Roundoff > ZERO) { /* Tloop */ - -/*~~~> Compute E = 1/(h*gamma)-Jac and its LU decomposition */ - if(SkipLU == 0) { /* This time around skip the Jac update and LU */ - SDIRK_PrepareMatrix(H, T, Y, FJAC, SkipJac, SkipLU, E, IP, - Reject, IER, ISTATUS); - if(IER != 0) { - SDIRK_ErrorMsg(-8, T, H, Ierr); - return Ierr; - } /* end if */ - } /* end if */ - - if(ISTATUS[Nstp] > Max_no_steps) { - SDIRK_ErrorMsg(-6, T, H, Ierr); - return Ierr; - } /* end if */ - - if((T + ((KPP_REAL)0.1) * H == T) || (ABS(H) <= Roundoff)) { - SDIRK_ErrorMsg(-7, T, H, Ierr); - return Ierr; - } /* end if */ - -/*stages*/ for(istage=0; istage < rkS; istage++) { - /*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - /*~~~> Simplified Newton iterations */ - /*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - - /*~~~> Starting values for Newton iterations */ - Set2Zero(N, &Z[istage][0]); - - /*~~~> Prepare the loop-independent part of the right-hand side */ - Set2Zero(N, G); - if(istage > 0) { - for(j=0; j < istage; j++) { - WAXPY(N, rkTheta[j][istage], - &Z[j][0], 1, G, 1); - if(StartNewton == 1) { - WAXPY(N, rkAlpha[j][istage], - &Z[j][0], 1, - &Z[istage][0], 1); - } /* end if */ - } /* end for */ - } /* end if */ - - /*~~~> Initializations for Newton iteration */ - NewtonDone = 0; /* false */ - Fac = (KPP_REAL)0.5; /* Step reduction factor */ - -/*NewtonLoop*/ for(NewtonIter=0; NewtonIter Prepare the loop-dependent part of the right-hand side */ - WADD(N, Y, &Z[istage][0], TMP); - FUN_CHEM(T+rkC[istage]*H, TMP, RHS); - ISTATUS[Nfun]++; - WSCAL(N, H*rkGamma, RHS, 1); - WAXPY(N, -ONE, &Z[istage][0], 1, RHS, 1); - WAXPY(N, ONE, G, 1, RHS, 1 ); - - /*~~~> Solve the linear system */ - SDIRK_Solve(H, N, E, IP, IER, RHS, ISTATUS); - - /*~~~> Check convergence of Newton iterations */ - NewtonIncrement = SDIRK_ErrorNorm(N, RHS, SCAL); - - if(NewtonIter == 0) { - Theta = ABS(ThetaMin); - NewtonRate = (KPP_REAL)2.0; - } - else { - Theta = NewtonIncrement/NewtonIncrementOld; - - if(Theta < (KPP_REAL)0.99) { - NewtonRate = Theta/(ONE-Theta); - /* Predict error at the end of Newton process */ - NewtonPredictedErr = - (NewtonIncrement*pow(Theta, - (NewtonMaxit - (NewtonIter + - 1)) / (ONE - Theta))); - if(NewtonPredictedErr >= NewtonTol) { - /* Non-convergence of Newton: - predicted error too large*/ - Qnewton = MIN((KPP_REAL)10.0, - NewtonPredictedErr/ - NewtonTol); - Fac = (KPP_REAL)0.8 * pow - (Qnewton, (-ONE / (1 - + NewtonMaxit - - NewtonIter + 1))); - break; - } /* end internal if */ - } - else /* Non-convergence of Newton: - Theta too large */ { - break; - } /* end internal if else */ - } /* end if else */ - - NewtonIncrementOld = NewtonIncrement; - - /* Update solution: Z(:) <-- Z(:)+RHS(:) */ - WAXPY(N, ONE, RHS, 1, &Z[istage][0], 1); - - /* Check error in Newton iterations */ - NewtonDone=(NewtonRate*NewtonIncrement<=NewtonTol); - - if(NewtonDone == 1) { - break; - } - } /* end NewtonLoop for */ - - if(NewtonDone == 0) { - /* CALL RK_ErrorMsg(-12,T,H,Ierr); */ - H = Fac*H; - Reject = 1; /* true */ - SkipJac = 1;/* true */ - SkipLU = 0;/* false */ - CycleTloop = 1; /* cycle Tloop */ - } /* end if */ - - if(CycleTloop == 1) { - CycleTloop=0; - break; - } - } /* end stages for */ - - if(CycleTloop==0) { - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -/*~~~> Error estimation */ -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - ISTATUS[Nstp]++; - Set2Zero(N, TMP); - - for(i=0; i Computation of new step size Hnew */ - Fac = FacSafe * pow((Err), (-ONE/rkELO)); - Fac = MAX(FacMin, MIN(FacMax, Fac)); - Hnew = H*Fac; - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -/*~~~> Accept/Reject step */ -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - - if(Err < ONE) { /*~~~> Step is accepted */ - FirstStep = 0; /* false */ - ISTATUS[Nacc]++; - - /*~~~> Update time and solution */ - T = T + H; - - /* Y(:) <-- Y(:) + Sum_j rkD(j)*Z_j(:) */ - for(i=0; i Update scaling coefficients */ - SDIRK_ErrorScale(N, ITOL, AbsTol, RelTol, Y, SCAL); - - /*~~~> Next time step */ - Hnew = Tdirection*MIN(ABS(Hnew), Hmax); - - /* Last T and H */ - RSTATUS[Ntexit] = T; - RSTATUS[Nhexit] = H; - RSTATUS[Nhnew] = Hnew; - - /* No step increase after a rejection */ - if(Reject==1) { - Hnew = Tdirection*MIN(ABS(Hnew), ABS(H)); - } /* end if */ - - Reject = 0; /* false */ - - if((T+Hnew/Qmin-Tfinal)*Tdirection > ZERO) { - H = Tfinal-T; - } - else { - Hratio = Hnew/H; - /* If step not changed too much keep Jacobian and reuse LU */ - SkipLU = ((Theta <= ThetaMin) && (Hratio >= Qmin) && - (Hratio <= Qmax)); - - if(SkipLU==0) { - H = Hnew; - } /* end internal if */ - } /* end if else */ - - SkipJac = (Theta <= ThetaMin); - SkipJac = 0; /* false */ - } - else { /*~~~> Step is rejected */ - if((FirstStep==1) || (Reject==1)) { - H = FacRej * H; - } - else { - H = Hnew; - } /* end internal if */ - - Reject = 1; - SkipJac = 1; - SkipLU = 0; - - if(ISTATUS[Nacc] >=1) { - ISTATUS[Nrej]++; - } /* end if */ - } /* end if else */ - } /* end CycleTloop if */ -} /* end Tloop */ - -/* Successful return */ -Ierr = 1; -return Ierr; - -} /* end SDIRK_Integrator */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void SDIRK_ErrorScale(int N, int ITOL, KPP_REAL AbsTol[], KPP_REAL RelTol[], - KPP_REAL Y[],KPP_REAL SCAL[]) -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -{ - -int i; -if (ITOL == 0){ - for (i = 0; i < NVAR; i++){ - SCAL[i] = ONE / (AbsTol[0]+RelTol[0]*ABS(Y[i]) ); - } /* end for */ -} -else { - for (i = 0; i < NVAR; i++){ - SCAL[i] = ONE / (AbsTol[i]+RelTol[i]*ABS(Y[i]) ); - } /* end for */ -} /* end if */ - -} /* end SDIRK_ErrorScale */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -KPP_REAL SDIRK_ErrorNorm(int N, KPP_REAL Y[], KPP_REAL SCAL[]) -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -{ - -int i; -KPP_REAL Err = ZERO; - -for (i = 0; i < N; i++) { - Err = Err + pow( (Y[i]*SCAL[i]), 2); -} /* end for */ - -Err = MAX( SQRT(Err/(KPP_REAL)N), (KPP_REAL)1.0e-10); - -return Err; - -} /* end SDIRK_ErrorNorm */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -int SDIRK_ErrorMsg(int code, KPP_REAL T, KPP_REAL H, int Ierr) -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - * Handles all error messages - *~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ */ -{ - -Ierr = code; - -printf("\n~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"); -printf("\nForced exit from Sdirk due to the following error:\n"); - -switch (code) { - -case -1: - printf("--> Improper value for maximal no of steps"); - break; -case -2: - printf("--> Selected Rosenbrock method not implemented"); - break; -case -3: - printf("--> Hmin/Hmax/Hstart must be positive"); - break; -case -4: - printf("--> FacMin/FacMax/FacRej must be positive"); - break; -case -5: - printf("--> Improper tolerance values"); - break; -case -6: - printf("--> No of steps exceeds maximum bound"); - break; -case -7: - printf("--> Step size too small (T + H/10 = T) or H < Roundoff"); - break; -case -8: - printf("--> Matrix is repeatedly singular"); - break; -default: /* causing an error */ - printf("Unknown Error code: %d", code); - -} /* end switch */ - -printf("\n Time = %f and H = %f", T, H ); -printf("\n~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n"); - -return code; - -} /* end SDIRK_ErrorMsg */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void SDIRK_PrepareMatrix(KPP_REAL H, KPP_REAL T, KPP_REAL Y[], KPP_REAL FJAC[], - int SkipJac, int SkipLU, KPP_REAL E[], int IP[], - int Reject, int ISING, int ISTATUS[] ) -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - * Compute the matrix E = 1/(H*GAMMA)*Jac, and its decomposition - *~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -{ - -KPP_REAL HGammaInv; -int i, j; -int ConsecutiveSng = 0; -ISING = 1; - - -while( ISING != 0) { - HGammaInv = ONE/(H*rkGamma); - -/*~~~> Compute the Jacobian */ - if(SkipJac==0) { - JAC_CHEM(T,Y,FJAC); - ISTATUS[Njac]++; - } /* end if */ - - #ifdef FULL_ALGEBRA - for(j=0; j= 6) { - return; /* Failure */ - } /* end internal if */ - - H = (KPP_REAL)(0.5) * H; - SkipJac = 1; /* true */ - SkipLU = 0; /* false */ - Reject = 1; /* true */ - } /* end if */ -} /* end while */ - -} /* end SDIRK_PrepareMatrix */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void SDIRK_Solve( KPP_REAL H, int N, KPP_REAL E[], int IP[], int ISING, - KPP_REAL RHS[], int ISTATUS[] ) -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - * Solves the system (H*Gamma-Jac)*x = RHS - * using the LU decomposition of E = I - 1/(H*Gamma)*Jac - *~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -{ - -KPP_REAL HGammaInv = ONE/(H * rkGamma); - -WSCAL(N, HGammaInv, RHS, 1); - -#ifdef FULL_ALGEBRA - DGETRS('N', N, 1, E, N, IP, RHS, N, ISING); -#else - KppSolve(E, RHS); -#endif - ISTATUS[Nsol]++; - -} /* end SDIRK_Solve */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void Sdirk4a() -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -{ - -sdMethod = S4A; - -/* Number of stages */ -rkS = 5; - -/* Method Coefficients */ -rkGamma = (KPP_REAL)0.2666666666666666666666666666666667; - -rkA[0][0] = (KPP_REAL)0.2666666666666666666666666666666667; -rkA[0][1] = (KPP_REAL)0.5000000000000000000000000000000000; -rkA[1][1] = (KPP_REAL)0.2666666666666666666666666666666667; -rkA[0][2] = (KPP_REAL)0.3541539528432732316227461858529820; -rkA[1][2] = (KPP_REAL)(-0.5415395284327323162274618585298197e-01); -rkA[2][2] = (KPP_REAL)0.2666666666666666666666666666666667; -rkA[0][3] = (KPP_REAL)0.8515494131138652076337791881433756e-01; -rkA[1][3] = (KPP_REAL)(-0.6484332287891555171683963466229754e-01); -rkA[2][3] = (KPP_REAL)0.7915325296404206392428857585141242e-01; -rkA[3][3] = (KPP_REAL)0.2666666666666666666666666666666667; -rkA[0][4] = (KPP_REAL)2.100115700566932777970612055999074; -rkA[1][4] = (KPP_REAL)(-0.7677800284445976813343102185062276); -rkA[2][4] = (KPP_REAL)2.399816361080026398094746205273880; -rkA[3][4] = (KPP_REAL)(-2.998818699869028161397714709433394); -rkA[4][4] = (KPP_REAL)0.2666666666666666666666666666666667; -rkB[0] = (KPP_REAL)2.100115700566932777970612055999074; -rkB[1] = (KPP_REAL)(-0.7677800284445976813343102185062276); -rkB[2] = (KPP_REAL)2.399816361080026398094746205273880; -rkB[3] = (KPP_REAL)(-2.998818699869028161397714709433394); -rkB[4] = (KPP_REAL)0.2666666666666666666666666666666667; - -rkBhat[0] = (KPP_REAL)2.885264204387193942183851612883390; -rkBhat[1] = (KPP_REAL)(-0.1458793482962771337341223443218041); -rkBhat[2] = (KPP_REAL)2.390008682465139866479830743628554; -rkBhat[3] = (KPP_REAL)(-4.129393538556056674929560012190140); -rkBhat[4] = ZERO; - -rkC[0] = (KPP_REAL)0.2666666666666666666666666666666667; -rkC[1] = (KPP_REAL)0.7666666666666666666666666666666667; -rkC[2] = (KPP_REAL)0.5666666666666666666666666666666667; -rkC[3] = (KPP_REAL)0.3661315380631796996374935266701191; -rkC[4] = ONE; - -/* Ynew = Yold + h*Sum_i {rkB_i*k_i} = Yold + Sum_i {rkD_i*Z_i} */ -rkD[0] = ZERO; -rkD[1] = ZERO; -rkD[2] = ZERO; -rkD[3] = ZERO; -rkD[4] = ONE; - -/* Err = h * Sum_i {(rkB_i-rkBhat_i)*k_i} = Sum_i {rkE_i*Z_i} */ -rkE[0] = (KPP_REAL)(-0.6804000050475287124787034884002302); -rkE[1] = (KPP_REAL)(1.558961944525217193393931795738823); -rkE[2] = (KPP_REAL)(-13.55893003128907927748632408763868); -rkE[3] = (KPP_REAL)(15.48522576958521253098585004571302); -rkE[4] = ONE; - -/* Local order of Err estimate */ -rkELO = 4; - -/* h*Sum_j {rkA_ij*k_j} = Sum_j {rkTheta_ij*Z_j} */ -rkTheta[0][1] = (KPP_REAL)1.875000000000000000000000000000000; -rkTheta[0][2] = (KPP_REAL)1.708847304091539528432732316227462; -rkTheta[1][2] = (KPP_REAL)(-0.2030773231622746185852981969486824); -rkTheta[0][3] = (KPP_REAL)0.2680325578937783958847157206823118; -rkTheta[1][3] = (KPP_REAL)(-0.1828840955527181631794050728644549); -rkTheta[2][3] = (KPP_REAL)0.2968246986151577397160821594427966; -rkTheta[0][4] = (KPP_REAL)0.9096171815241460655379433581446771; -rkTheta[1][4] = (KPP_REAL)(-3.108254967778352416114774430509465); -rkTheta[2][4] = (KPP_REAL)12.33727431701306195581826123274001; -rkTheta[3][4] = (KPP_REAL)(-11.24557012450885560524143016037523); - -/* Starting value for Newton iterations: Z_i^0 = Sum_j {rkAlpha_ij*Z_j} */ -rkAlpha[0][1] = (KPP_REAL)2.875000000000000000000000000000000; -rkAlpha[0][2] = (KPP_REAL)0.8500000000000000000000000000000000; -rkAlpha[1][2] = (KPP_REAL)0.4434782608695652173913043478260870; -rkAlpha[0][3] = (KPP_REAL)0.7352046091658870564637910527807370; -rkAlpha[1][3] = (KPP_REAL)(-0.9525565003057343527941920657462074e-01); -rkAlpha[2][3] = (KPP_REAL)0.4290111305453813852259481840631738; -rkAlpha[0][4] = (KPP_REAL)(-16.10898993405067684831655675112808); -rkAlpha[1][4] = (KPP_REAL)6.559571569643355712998131800797873; -rkAlpha[2][4] = (KPP_REAL)(-15.90772144271326504260996815012482); -rkAlpha[3][4] = (KPP_REAL)25.34908987169226073668861694892683; - -rkELO = (KPP_REAL)4.0; - -} /* end Sdirk4a */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void Sdirk4b() -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -{ - -sdMethod = S4B; - -/* Number of stages */ -rkS = 5; - -/* Method coefficients */ -rkGamma = (KPP_REAL)0.25; - -rkA[0][0] = (KPP_REAL)0.25; -rkA[0][1] = (KPP_REAL)0.5; -rkA[1][1] = (KPP_REAL)0.25; -rkA[0][2] = (KPP_REAL)0.34; -rkA[1][2] = (KPP_REAL)(-0.40e-01); -rkA[2][2] = (KPP_REAL)0.25; -rkA[0][3] = (KPP_REAL)0.2727941176470588235294117647058824; -rkA[1][3] = (KPP_REAL)(-0.5036764705882352941176470588235294e-01); -rkA[2][3] = (KPP_REAL)0.2757352941176470588235294117647059e-01; -rkA[3][3] = (KPP_REAL)0.25; -rkA[0][4] = (KPP_REAL)1.041666666666666666666666666666667; -rkA[1][4] = (KPP_REAL)(-1.020833333333333333333333333333333); -rkA[2][4] = (KPP_REAL)7.812500000000000000000000000000000; -rkA[3][4] = (KPP_REAL)(-7.083333333333333333333333333333333); -rkA[4][4] = (KPP_REAL)0.25; - -rkB[0] = (KPP_REAL)1.041666666666666666666666666666667; -rkB[1] = (KPP_REAL)(-1.020833333333333333333333333333333); -rkB[2] = (KPP_REAL)7.812500000000000000000000000000000; -rkB[3] = (KPP_REAL)(-7.083333333333333333333333333333333); -rkB[4] = (KPP_REAL)0.250000000000000000000000000000000; - -rkBhat[0] = (KPP_REAL)1.069791666666666666666666666666667; -rkBhat[1] = (KPP_REAL)(-0.894270833333333333333333333333333); -rkBhat[2] = (KPP_REAL)7.695312500000000000000000000000000; -rkBhat[3] = (KPP_REAL)(-7.083333333333333333333333333333333); -rkBhat[4] = (KPP_REAL)0.212500000000000000000000000000000; - -rkC[0] = (KPP_REAL)0.25; -rkC[1] = (KPP_REAL)0.75; -rkC[2] = (KPP_REAL)0.55; -rkC[3] = (KPP_REAL)0.5; -rkC[4] = ONE; - -/* Ynew = Yold + h*Sum_i {rkB_i*k_i} = Yold + Sum_i {rkD_i*Z_i} */ -rkD[0] = ZERO; -rkD[1] = ZERO; -rkD[2] = ZERO; -rkD[3] = ZERO; -rkD[4] = ONE; - -/* Err = h * Sum_i {(rkB_i-rkBhat_i)*k_i} = Sum_i {rkE_i*Z_i} */ -rkE[0] = (KPP_REAL)0.5750; -rkE[1] = (KPP_REAL)0.2125; -rkE[2] = (KPP_REAL)(-4.6875); -rkE[3] = (KPP_REAL)4.2500; -rkE[4] = (KPP_REAL)0.1500; - -/* Local order of Err estimate */ -rkELO = 4; - -/* h*Sum_j {rkA_ij*k_j} = Sum_j {rkTheta_ij*Z_j} */ -rkTheta[0][1] = (KPP_REAL)2.0; -rkTheta[0][2] = (KPP_REAL)1.680000000000000000000000000000000; -rkTheta[1][2] = (KPP_REAL)(-0.1600000000000000000000000000000000); -rkTheta[0][3] = (KPP_REAL)1.308823529411764705882352941176471; -rkTheta[1][3] = (KPP_REAL)(-0.1838235294117647058823529411764706); -rkTheta[2][3] = (KPP_REAL)0.1102941176470588235294117647058824; -rkTheta[0][4] = (KPP_REAL)(-3.083333333333333333333333333333333); -rkTheta[1][4] = (KPP_REAL)(-4.291666666666666666666666666666667); -rkTheta[2][4] = (KPP_REAL)34.37500000000000000000000000000000; -rkTheta[3][4] = (KPP_REAL)(-28.3333333333333333333333333333); - -/* Starting value for Newton iterations: Z_i^0 = Sum_j {rkAlpha_ij*Z_j} */ -rkAlpha[0][1] = (KPP_REAL)3.0; -rkAlpha[0][2] = (KPP_REAL)0.8800000000000000000000000000000000; -rkAlpha[1][2] = (KPP_REAL)0.4400000000000000000000000000000000; -rkAlpha[0][3] = (KPP_REAL)0.1666666666666666666666666666666667; -rkAlpha[1][3] = (KPP_REAL)(-0.8333333333333333333333333333333333e-01); -rkAlpha[2][3] = (KPP_REAL)0.9469696969696969696969696969696970; -rkAlpha[0][4] = (KPP_REAL)(-6.0); -rkAlpha[1][4] = (KPP_REAL)9.0; -rkAlpha[2][4] = (KPP_REAL)(-56.81818181818181818181818181818182); -rkAlpha[3][4] = (KPP_REAL)54.0; - -} /* end Sdirk4b */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void Sdirk2a() -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -{ - -sdMethod = S2A; - -/* ~~~> Number of stages */ -rkS = 2; - -/* ~~~> Method coefficients */ -rkGamma = (KPP_REAL)0.2928932188134524755991556378951510; -rkA[0][0] = (KPP_REAL)0.2928932188134524755991556378951510; -rkA[0][1] = (KPP_REAL)0.7071067811865475244008443621048490; -rkA[1][1] = (KPP_REAL)0.2928932188134524755991556378951510; -rkB[0] = (KPP_REAL)0.7071067811865475244008443621048490; -rkB[1] = (KPP_REAL)0.2928932188134524755991556378951510; -rkBhat[0] = (KPP_REAL)0.6666666666666666666666666666666667; -rkBhat[1] = (KPP_REAL)0.3333333333333333333333333333333333; -rkC[0] = (KPP_REAL)0.292893218813452475599155637895151; -rkC[1] = ONE; - -/* ~~~> Ynew = Yold + h*Sum_i {rkB_i*k_i} = Yold + Sum_i {rkD_i*Z_i} */ -rkD[0] = ZERO; -rkD[1] = ONE; - -/* ~~~> Err = h * Sum_i {(rkB_i-rkBhat_i)*k_i} = Sum_i {rkE_i*Z_i} */ -rkE[0] = (KPP_REAL)0.4714045207910316829338962414032326; -rkE[1] = (KPP_REAL)(-0.1380711874576983496005629080698993); - -/* ~~~> Local order of Err estimate */ -rkELO = 2; - -/* ~~~> h*Sum_j {rkA_ij*k_j} = Sum_j {rkTheta_ij*Z_j} */ -rkTheta[0][1] = (KPP_REAL)2.414213562373095048801688724209698; - -/* ~~~> Starting value for Newton iterations */ -rkAlpha[0][1] = (KPP_REAL)3.414213562373095048801688724209698; - -} /* end Sdirk2a */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void Sdirk2b() -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -{ - -sdMethod = S2B; - -/* ~~~> Number of stages */ -rkS = 2; - -/* ~~~> Method coefficients */ -rkGamma = (KPP_REAL)1.707106781186547524400844362104849; -rkA[0][0] = (KPP_REAL)1.707106781186547524400844362104849; -rkA[0][1] = (KPP_REAL)(-0.707106781186547524400844362104849); -rkA[1][1] = (KPP_REAL)1.707106781186547524400844362104849; -rkB[0] = (KPP_REAL)(-0.707106781186547524400844362104849); -rkB[1] = (KPP_REAL)1.707106781186547524400844362104849; -rkBhat[0] = (KPP_REAL)0.6666666666666666666666666666666667; -rkBhat[1] = (KPP_REAL)0.3333333333333333333333333333333333; -rkC[0] = (KPP_REAL)1.707106781186547524400844362104849; -rkC[1] = ONE; - -/* ~~~> Ynew = Yold + h*Sum_i {rkB_i*k_i} = Yold + Sum_i {rkD_i*Z_i} */ -rkD[0] = ZERO; -rkD[1] = ONE; - -/* ~~~> Err = h * Sum_i {(rkB_i-rkBhat_i)*k_i} = Sum_i {rkE_i*Z_i} */ -rkE[0] = (KPP_REAL)(-0.4714045207910316829338962414032326); -rkE[1] = (KPP_REAL)0.8047378541243650162672295747365659; - -/* ~~~> Local order of Err estimate */ -rkELO = 2; - -/* ~~~> h*Sum_j {rkA_ij*k_j} = Sum_j {rkTheta_ij*Z_j} */ -rkTheta[0][1] = (KPP_REAL)(-0.414213562373095048801688724209698); - -/* ~~~> Starting value for Newton iterations */ -rkAlpha[0][1] = (KPP_REAL)0.5857864376269049511983112757903019; - -} /* end Sdirk2b */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void Sdirk3a() -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -{ - -sdMethod = S3A; - -/* ~~~> Number of stages */ -rkS = 3; - -/* ~~~> Method coefficients */ -rkGamma = (KPP_REAL)0.2113248654051871177454256097490213; -rkA[0][0] = (KPP_REAL)0.2113248654051871177454256097490213; -rkA[0][1] = (KPP_REAL)0.2113248654051871177454256097490213; -rkA[1][1] = (KPP_REAL)0.2113248654051871177454256097490213; -rkA[0][2] = (KPP_REAL)0.2113248654051871177454256097490213; -rkA[1][2] = (KPP_REAL)0.5773502691896257645091487805019573; -rkA[2][2] = (KPP_REAL)0.2113248654051871177454256097490213; -rkB[0] = (KPP_REAL)0.2113248654051871177454256097490213; -rkB[1] = (KPP_REAL)0.5773502691896257645091487805019573; -rkB[2] = (KPP_REAL)0.2113248654051871177454256097490213; -rkBhat[0]= (KPP_REAL)0.2113248654051871177454256097490213; -rkBhat[1]= (KPP_REAL)0.6477918909913548037576239837516312; -rkBhat[2]= (KPP_REAL)0.1408832436034580784969504064993475; -rkC[0] = (KPP_REAL)0.2113248654051871177454256097490213; -rkC[1] = (KPP_REAL)0.4226497308103742354908512194980427; -rkC[2] = ONE; - -/* ~~~> Ynew = Yold + h*Sum_i {rkB_i*k_i} = Yold + Sum_i {rkD_i*Z_i} */ -rkD[0] = ZERO; -rkD[1] = ZERO; -rkD[2] = ONE; - -/* ~~~> Err = h * Sum_i {(rkB_i-rkBhat_i)*k_i} = Sum_i {rkE_i*Z_i} */ -rkE[0] = (KPP_REAL)0.9106836025229590978424821138352906; -rkE[1] = (KPP_REAL)(-1.244016935856292431175815447168624); -rkE[2] = (KPP_REAL)0.3333333333333333333333333333333333; - -/* ~~~> Local order of Err estimate */ -rkELO = 2; - -/* ~~~> h*Sum_j {rkA_ij*k_j} = Sum_j {rkTheta_ij*Z_j} */ -rkTheta[0][1] = ONE; -rkTheta[0][2] = (KPP_REAL)(-1.732050807568877293527446341505872); -rkTheta[1][2] = (KPP_REAL)2.732050807568877293527446341505872; - -/* ~~~> Starting value for Newton iterations */ -rkAlpha[0][1] = (KPP_REAL)2.0; -rkAlpha[0][2] = (KPP_REAL)(-12.92820323027550917410978536602349); -rkAlpha[1][2] = (KPP_REAL)8.83012701892219323381861585376468; - -} /* end Sdirk3a */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void FUN_CHEM(KPP_REAL T, KPP_REAL Y[], KPP_REAL P[]) -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -{ - -KPP_REAL Told; - -Told = TIME; -TIME = T; -Update_SUN(); -Update_RCONST(); -Fun( Y, FIX, RCONST, P ); -TIME = Told; - - -} /* end FUN_CHEM */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void JAC_CHEM(KPP_REAL T, KPP_REAL Y[], KPP_REAL JV[]) -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -{ - -KPP_REAL Told; - -#ifdef FULL_ALGEBRA - KPP_REAL JS[LU_NONZERO]; - int i,j; -#endif - -Told = TIME; -TIME = T; -Update_SUN(); -Update_RCONST(); - -#ifdef FULL_ALGEBRA - Jac_SP( Y, FIX, RCONST, JS); - - for(j=0; j' - END IF - POSNEG=SIGN(1.D0,XEND-X) - HMAX1=MIN(ABS(HMAX),ABS(XEND-X)) - IF (ABS(H).LE.10.D0*UROUND) H=1.0D-6 - H=MIN(ABS(H),HMAX1) - H=SIGN(H,POSNEG) - HOLD=H - CFAC=SAFE*(1+2*NIT) - NEWTRE=.FALSE. - REJECT=.FALSE. - FIRST=.TRUE. - FACCO1=1.D0 - FACCO2=1.D0 - FACCO3=1.D0 - FACCO4=1.D0 - FACCO5=1.D0 - NSING=0 - XOLD=X - IF (ITOL.EQ.0) THEN - DO 8 I=1,N - 8 SCAL(I)=1.D0 / ( AbsTol(1)+RelTol(1)*DABS(Y(I)) ) - ELSE - DO 9 I=1,N - 9 SCAL(I)=1.D0 / ( AbsTol(I)+RelTol(I)*DABS(Y(I)) ) - END IF - -C --- BASIC INTEGRATION STEP - 10 CONTINUE - -C *** *** *** *** *** *** *** -C COMPUTATION OF THE JACOBIAN -C *** *** *** *** *** *** *** - NJAC=NJAC+1 - CALL JAC(N,X,Y,FJAC) - CALJAC=.TRUE. - 20 CONTINUE - -C *** *** *** *** *** *** *** -C COMPUTE THE MATRIX E AND ITS DECOMPOSITION -C *** *** *** *** *** *** *** - FAC1=1.D0/(H*GAMMA) - IF (IMPLCT) THEN - print *, 'IMPLCT 4' - ELSE ! EXPLICIT SYSTEM -C --- THE MATRIX E (MAS=IDENTITY, JACOBIAN A FULL MATRIX) -c DO 526 J=1,N -c DO 525 I=1,N -c 525 E(I,J)=-FJAC(I,J) -c 526 E(J,J)=E(J,J)+FAC1 -c CALL DEC(N,LE,E,IP,IER) - DO K=1,LU_NONZERO - E(K) = -FJAC(K) - END DO - DO I=1,N - IDG = LU_DIAG(I) - E(IDG) = E(IDG) + FAC1 - END DO - CALL KppDecomp ( E, IER) - - IF (IER.NE.0) GOTO 79 - END IF - NDEC=NDEC+1 - 30 CONTINUE - - IF (NSTEP.GT.NMAX.OR.X+.1D0*H.EQ.X.OR.ABS(H).LE.UROUND) GOTO 79 - XPH=X+H -C --- LOOP FOR THE 5 STAGES - FACCO1=DMAX1(FACCO1,UROUND)**0.8D0 - FACCO2=DMAX1(FACCO2,UROUND)**0.8D0 - FACCO3=DMAX1(FACCO3,UROUND)**0.8D0 - FACCO4=DMAX1(FACCO4,UROUND)**0.8D0 - FACCO5=DMAX1(FACCO5,UROUND)**0.8D0 - -C *** *** *** *** *** *** *** -C STARTING VALUES FOR NEWTON ITERATION -C *** *** *** *** *** *** *** - DO 59 ISTAGE=1,5 - IF (ISTAGE.EQ.1) THEN - XCH=X+GAMMA*H - IF (FIRST.OR.NEWTRE) THEN - DO 132 I=1,N - 132 Z(I)=0.D0 - ELSE - S=1.D0+GAMMA*H/HOLD - DO 232 I=1,N -c 232 Z(I) = 0.D0 - 232 Z(I)=S*(CONT(I+NN)+S*(CONT(I+NN2)+S*(CONT(I+NN3) - & +S*CONT(I+NN4))))-YHAT(I) - - END IF - DO 31 I=1,N - 31 G1(I)=0.D0 - FACCON=FACCO1 - END IF - IF (ISTAGE.EQ.2) THEN - XCH=X+C2*H - DO 131 I=1,N - Z1I=Z1(I) - Z(I)=ETA1*Z1I - 131 G1(I)=ALPH21*Z1I - FACCON=FACCO2 - END IF - IF (ISTAGE.EQ.3) THEN - XCH=X+C3*H - DO 231 I=1,N - Z1I=Z1(I) - Z2I=Z2(I) - Z(I)=ANU1*Z1I+ANU2*Z2I - 231 G1(I)=ALPH31*Z1I+ALPH32*Z2I - FACCON=FACCO3 - END IF - IF (ISTAGE.EQ.4) THEN - XCH=X+C4*H - DO 331 I=1,N - Z1I=Z1(I) - Z3I=Z3(I) - Z(I)=AMU1*Z1I+AMU3*Z3I - 331 G1(I)=ALPH41*Z1I+ALPH42*Z2(I)+ALPH43*Z3I - FACCON=FACCO4 - END IF - IF (ISTAGE.EQ.5) THEN - XCH=XPH - DO 431 I=1,N - Z1I=Z1(I) - Z2I=Z2(I) - Z3I=Z3(I) - Z4I=Z4(I) - Z(I)=E1*Z1I+E2*Z2I+E3*Z3I+E4*Z4I - YHAT(I)=Z(I) - 431 G1(I)=ALPH51*Z1I+ALPH52*Z2I+ALPH53*Z3I+ALPH54*Z4I - FACCON=FACCO5 - END IF - - - -C *** *** *** *** *** *** *** *** *** *** *** -C LOOP FOR THE SIMPLIFIED NEWTON ITERATION -C *** *** *** *** *** *** *** *** *** *** *** - NEWT=0 - THETA=ABS(THET) - IF (REJECT) THETA=2*ABS(THET) - 40 CONTINUE - IF (NEWT.GE.NIT) THEN - H=H/2.D0 - REJECT=.TRUE. - NEWTRE=.TRUE. - IF (CALJAC) GOTO 20 - GOTO 10 - END IF - -C --- COMPUTE THE RIGHT-HAND SIDE - DO 41 I=1,N - H1(I)=G1(I)-Z(I) - 41 CONT(I)=Y(I)+Z(I) - CALL FCN(N,XCH,CONT,F1) - NFCN=NFCN+1 - -C --- KppSolve THE LINEAR SYSTEMS - IF (IMPLCT) THEN - print *, 'IMPLCT 2' - ELSE - DO 345 I=1,N - 345 F1(I)=H1(I)*FAC1+F1(I) -C CALL SOL(N,LE,E,F1,IP) - CALL KppSolve(E, F1) - END IF - NEWT=NEWT+1 - DYNO=0.D0 -C --- NORM 2 --- - DO 57 I=1,N - 57 DYNO=DYNO+(F1(I)*SCAL(I))**2 - DYNO=DSQRT(DYNO/N) -C --- NORM INF --- -C DO 57 I=1,N -C 57 DYNO=DMAX1( DYNO, DABS(F1(I)*SCAL(I)) ) - - -C --- BAD CONVERGENCE OR NUMBER OF ITERATIONS TO LARGE - IF (NEWT.GE.2.AND.NEWT.LT.NIT) THEN - THETA=DYNO/DYNOLD - IF (THETA.LT.0.99D0) THEN - FACCON=THETA/(1.0D0-THETA) - DYTH=FACCON*DYNO*THETA**(NIT-1-NEWT) - QNEWT=DMAX1(1.0D-4,DMIN1(16.0D0,DYTH/FNEWT)) - IF (QNEWT.GE.1.0D0) THEN - H=.8D0*H*QNEWT**(-1.0D0/(NIT-NEWT)) - REJECT=.TRUE. - NEWTRE=.TRUE. - IF (CALJAC) GOTO 20 - GOTO 10 - END IF - ELSE - NEWTRE=.TRUE. - GOTO 78 - END IF - END IF - DYNOLD=DYNO - DO 58 I=1,N - 58 Z(I)=Z(I)+F1(I) - NSOL=NSOL+1 - IF (FACCON*DYNO.GT.FNEWT) GOTO 40 - -C --- END OF SIMPILFIED NEWTON - IF (ISTAGE.EQ.1) THEN - DO I=1,N - Z1(I) = Z(I) - END DO - FACCO1=FACCON - END IF - IF (ISTAGE.EQ.2) THEN - DO I=1,N - Z2(I) = Z(I) - END DO - FACCO2=FACCON - END IF - IF (ISTAGE.EQ.3) THEN - DO I=1,N - Z3(I) = Z(I) - END DO - FACCO3=FACCON - END IF - IF (ISTAGE.EQ.4) THEN - DO I=1,N - Z4(I) = Z(I) - END DO - FACCO4=FACCON - END IF - IF (ISTAGE.EQ.5) THEN - DO I=1,N - Z5(I) = Z(I) - END DO - FACCO5=FACCON - END IF - 59 CONTINUE - - -C *** *** *** *** *** *** *** -C ERROR ESTIMATION -C *** *** *** *** *** *** *** - NSTEP=NSTEP+1 - IF (IMPLCT) THEN - print *,'IMPLCT 3' - ELSE - DO 461 I=1,N - 461 CONT(I)=FAC1*(Z5(I)-YHAT(I)) - END IF - - CALL KppSolve(E, CONT) - - ERR=0.D0 -C ---- NORM 2 --- - DO 64 I=1,N - 64 ERR=ERR+(CONT(I)*SCAL(I))**2 - ERR=DMAX1(DSQRT(ERR/N),1.D-10) - -C ---- NORM INF --- -C DO 64 I=1,N -c 64 ERR=DMAX1( ERR, DABS( CONT(I)*SCAL(I) ) ) - -C --- COMPUTATION OF HNEW -C --- WE REQUIRE .25<=HNEW/H<=10. - FAC=DMIN1(SAFE,CFAC/(NEWT+2*NIT)) - QUOT=DMAX1(.25D0,DMIN1(10.D0,(ERR)**.25D0/FAC)) - HNEW= H/QUOT - -C *** *** *** *** *** *** *** -C IS THE ERROR SMALL ENOUGH ? -C *** *** *** *** *** *** *** - IF (ERR.LT.1.D0) THEN -C --- STEP IS ACCEPTED - FIRST=.FALSE. - NACCPT=NACCPT+1 - HOLD=H - XOLD=X -C --- COEFFICIENTS FOR CONTINUOUS SOLUTION - DO 74 I=1,N - Z1I=Z1(I) - Z2I=Z2(I) - Z3I=Z3(I) - Z4I=Z4(I) - Z5I=Z5(I) - CONT(I)=Y(I) - Y(I)=Y(I)+Z5I - CONT(I+NN) =D11*Z1I+D12*Z2I+D13*Z3I+D14*Z4I+D15*Z5I - CONT(I+NN2)=D21*Z1I+D22*Z2I+D23*Z3I+D24*Z4I+D25*Z5I - CONT(I+NN3)=D31*Z1I+D32*Z2I+D33*Z3I+D34*Z4I+D35*Z5I - CONT(I+NN4)=D41*Z1I+D42*Z2I+D43*Z3I+D44*Z4I+D45*Z5I - YHAT(I)=Z5I - IF (ITOL.EQ.0) THEN - SCAL(I)=1.D0/( AbsTol(1)+RelTol(1)*DABS(Y(I)) ) - ELSE - SCAL(I)=1.D0/( AbsTol(I)+RelTol(I)*DABS(Y(I)) ) - END IF - 74 CONTINUE - X=XPH - CALJAC=.FALSE. - IF ((X-XEND)*POSNEG+UROUND.GT.0.D0) THEN - H=HOPT - IDID=1 - RETURN - END IF - IF (IJAC.EQ.0) CALL FCN(N,X,Y,Y0) - NFCN=NFCN+1 - HNEW=POSNEG*DMIN1(DABS(HNEW),HMAX1) - HOPT=HNEW - IF (REJECT) HNEW=POSNEG*DMIN1(DABS(HNEW),DABS(H)) - REJECT=.FALSE. - NEWTRE=.FALSE. - IF ((X+HNEW/QUOT1-XEND)*POSNEG.GT.0.D0) THEN - H=XEND-X - ELSE - QT=HNEW/H - IF (THETA.LE.THET.AND.QT.GE.QUOT1.AND.QT.LE.QUOT2) GOTO 30 - H = HNEW - END IF - IF (THETA.LE.THET) GOTO 20 - GOTO 10 - - ELSE -C --- STEP IS REJECTED - REJECT=.TRUE. - IF (FIRST) THEN - H=H/10.D0 - ELSE - H=HNEW - END IF - IF (NACCPT.GE.1) NREJCT=NREJCT+1 - IF (CALJAC) GOTO 20 - GOTO 10 - END IF - -C --- UNEXPECTED STEP-REJECTION - 78 CONTINUE - IF (IER.NE.0) THEN - WRITE (6,*) ' MATRIX IS SINGULAR, IER=',IER,' X=',X,' H=',H - NSING=NSING+1 - IF (NSING.GE.6) GOTO 79 - END IF - H=H*0.5D0 - REJECT=.TRUE. - IF (CALJAC) GOTO 20 - GOTO 10 - -C --- FAIL EXIT - 79 WRITE (6,979) X,H,IER - 979 FORMAT(' EXIT OF SDIRK4 AT X=',D14.7,' H=',D14.7,' IER=',I4) - IDID=-1 - RETURN - END -C - - - SUBROUTINE FUNC_CHEM(N, T, Y, P) - INCLUDE 'KPP_ROOT_Parameters.h' - INCLUDE 'KPP_ROOT_Global.h' - INTEGER N - KPP_REAL T, Told - KPP_REAL Y(NVAR), P(NVAR) - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Fun( Y, FIX, RCONST, P ) - TIME = Told - RETURN - END - - - SUBROUTINE JAC_CHEM(N, T, Y, J) - INCLUDE 'KPP_ROOT_Parameters.h' - INCLUDE 'KPP_ROOT_Global.h' - INTEGER N - KPP_REAL Told, T - KPP_REAL Y(NVAR), J(LU_NONZERO) - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - CALL Jac_SP( Y, FIX, RCONST, J ) - TIME = Told - RETURN - END - diff --git a/boxmox/int/sdirk.f90 b/boxmox/int/sdirk.f90 deleted file mode 100644 index 0f9a61398df87d5e91a2e8c2e35aab4f1369307d..0000000000000000000000000000000000000000 --- a/boxmox/int/sdirk.f90 +++ /dev/null @@ -1,1258 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! -! SDIRK - Singly-Diagonally-Implicit Runge-Kutta methods ! -! * Sdirk 2a, 2b: L-stable, 2 stages, order 2 ! -! * Sdirk 3a: L-stable, 3 stages, order 2, adj-invariant ! -! * Sdirk 4a, 4b: L-stable, 5 stages, order 4 ! -! By default the code employs the KPP sparse linear algebra routines ! -! Compile with -DFULL_ALGEBRA to use full linear algebra (LAPACK) ! -! ! -! (C) Adrian Sandu, July 2005 ! -! Virginia Polytechnic Institute and State University ! -! Contact: sandu@cs.vt.edu ! -! Revised by Philipp Miehe and Adrian Sandu, May 2006 ! -! This implementation is part of KPP - the Kinetic PreProcessor ! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! - -MODULE KPP_ROOT_Integrator - - USE KPP_ROOT_Precision - USE KPP_ROOT_Global, ONLY: FIX, RCONST, TIME - USE KPP_ROOT_Parameters, ONLY: NVAR, NSPEC, NFIX, LU_NONZERO - USE KPP_ROOT_JacobianSP, ONLY: LU_DIAG - USE KPP_ROOT_LinearAlgebra, ONLY: KppDecomp, & - KppSolve, Set2zero, WLAMCH, WCOPY, WAXPY, WSCAL, WADD - - IMPLICIT NONE - PUBLIC - SAVE - -!~~~> Statistics on the work performed by the SDIRK method - INTEGER, PARAMETER :: Nfun=1, Njac=2, Nstp=3, Nacc=4, & - Nrej=5, Ndec=6, Nsol=7, Nsng=8, & - Ntexit=1, Nhexit=2, Nhnew=3 - -CONTAINS - -SUBROUTINE INTEGRATE( TIN, TOUT, & - ICNTRL_U, RCNTRL_U, ISTATUS_U, RSTATUS_U, Ierr_U ) - - USE KPP_ROOT_Parameters - USE KPP_ROOT_Global - IMPLICIT NONE - - KPP_REAL, INTENT(IN) :: TIN ! Start Time - KPP_REAL, INTENT(IN) :: TOUT ! End Time - ! Optional input parameters and statistics - INTEGER, INTENT(IN), OPTIONAL :: ICNTRL_U(20) - KPP_REAL, INTENT(IN), OPTIONAL :: RCNTRL_U(20) - INTEGER, INTENT(OUT), OPTIONAL :: ISTATUS_U(20) - KPP_REAL, INTENT(OUT), OPTIONAL :: RSTATUS_U(20) - INTEGER, INTENT(OUT), OPTIONAL :: Ierr_U - - INTEGER, SAVE :: Ntotal = 0 - KPP_REAL :: RCNTRL(20), RSTATUS(20), T1, T2 - INTEGER :: ICNTRL(20), ISTATUS(20), Ierr - - ICNTRL(:) = 0 - RCNTRL(:) = 0.0_dp - ISTATUS(:) = 0 - RSTATUS(:) = 0.0_dp - - !~~~> fine-tune the integrator: - ICNTRL(2) = 0 ! 0 - vector tolerances, 1 - scalar tolerances - ICNTRL(6) = 0 ! starting values of Newton iterations: interpolated (0), zero (1) - ! If optional parameters are given, and if they are >0, - ! then they overwrite default settings. - IF (PRESENT(ICNTRL_U)) THEN - WHERE(ICNTRL_U(:) > 0) ICNTRL(:) = ICNTRL_U(:) - END IF - IF (PRESENT(RCNTRL_U)) THEN - WHERE(RCNTRL_U(:) > 0) RCNTRL(:) = RCNTRL_U(:) - END IF - - - T1 = TIN; T2 = TOUT - CALL SDIRK( NVAR,T1,T2,VAR,RTOL,ATOL, & - RCNTRL,ICNTRL,RSTATUS,ISTATUS,Ierr ) - - !~~~> Debug option: print number of steps - ! Ntotal = Ntotal + ISTATUS(Nstp) - ! PRINT*,'NSTEPS=',ISTATUS(Nstp), '(',Ntotal,')',' O3=',VAR(ind_O3), & - ! ' NO2=',VAR(ind_NO2) - - IF (Ierr < 0) THEN - PRINT *,'SDIRK: Unsuccessful exit at T=',TIN,' (Ierr=',Ierr,')' - ENDIF - - ! if optional parameters are given for output they to return information - IF (PRESENT(ISTATUS_U)) ISTATUS_U(:) = ISTATUS(:) - IF (PRESENT(RSTATUS_U)) RSTATUS_U(:) = RSTATUS(:) - IF (PRESENT(Ierr_U)) Ierr_U = Ierr - - END SUBROUTINE INTEGRATE - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SDIRK(N, Tinitial, Tfinal, Y, RelTol, AbsTol, & - RCNTRL, ICNTRL, RSTATUS, ISTATUS, Ierr) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -! Solves the system y'=F(t,y) using a Singly-Diagonally-Implicit -! Runge-Kutta (SDIRK) method. -! -! This implementation is based on the book and the code Sdirk4: -! -! E. Hairer and G. Wanner -! "Solving ODEs II. Stiff and differential-algebraic problems". -! Springer series in computational mathematics, Springer-Verlag, 1996. -! This code is based on the SDIRK4 routine in the above book. -! -! Methods: -! * Sdirk 2a, 2b: L-stable, 2 stages, order 2 -! * Sdirk 3a: L-stable, 3 stages, order 2, adjoint-invariant -! * Sdirk 4a, 4b: L-stable, 5 stages, order 4 -! -! (C) Adrian Sandu, July 2005 -! Virginia Polytechnic Institute and State University -! Contact: sandu@cs.vt.edu -! Revised by Philipp Miehe and Adrian Sandu, May 2006 -! This implementation is part of KPP - the Kinetic PreProcessor -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!~~~> INPUT ARGUMENTS: -! -!- Y(NVAR) = vector of initial conditions (at T=Tinitial) -!- [Tinitial,Tfinal] = time range of integration -! (if Tinitial>Tfinal the integration is performed backwards in time) -!- RelTol, AbsTol = user precribed accuracy -!- SUBROUTINE ode_Fun( T, Y, Ydot ) = ODE function, -! returns Ydot = Y' = F(T,Y) -!- SUBROUTINE ode_Fun( T, Y, Ydot ) = Jacobian of the ODE function, -! returns Jcb = dF/dY -!- ICNTRL(1:20) = integer inputs parameters -!- RCNTRL(1:20) = real inputs parameters -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!~~~> OUTPUT ARGUMENTS: -! -!- Y(NVAR) -> vector of final states (at T->Tfinal) -!- ISTATUS(1:20) -> integer output parameters -!- RSTATUS(1:20) -> real output parameters -!- Ierr -> job status upon return -! success (positive value) or -! failure (negative value) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!~~~> INPUT PARAMETERS: -! -! Note: For input parameters equal to zero the default values of the -! corresponding variables are used. -! -! Note: For input parameters equal to zero the default values of the -! corresponding variables are used. -!~~~> -! ICNTRL(1) = not used -! -! ICNTRL(2) = 0: AbsTol, RelTol are NVAR-dimensional vectors -! = 1: AbsTol, RelTol are scalars -! -! ICNTRL(3) = Method -! -! ICNTRL(4) -> maximum number of integration steps -! For ICNTRL(4)=0 the default value of 100000 is used -! -! ICNTRL(5) -> maximum number of Newton iterations -! For ICNTRL(5)=0 the default value of 8 is used -! -! ICNTRL(6) -> starting values of Newton iterations: -! ICNTRL(6)=0 : starting values are interpolated (the default) -! ICNTRL(6)=1 : starting values are zero -! -!~~~> Real parameters -! -! RCNTRL(1) -> Hmin, lower bound for the integration step size -! It is strongly recommended to keep Hmin = ZERO -! RCNTRL(2) -> Hmax, upper bound for the integration step size -! RCNTRL(3) -> Hstart, starting value for the integration step size -! -! RCNTRL(4) -> FacMin, lower bound on step decrease factor (default=0.2) -! RCNTRL(5) -> FacMax, upper bound on step increase factor (default=6) -! RCNTRL(6) -> FacRej, step decrease factor after multiple rejections -! (default=0.1) -! RCNTRL(7) -> FacSafe, by which the new step is slightly smaller -! than the predicted value (default=0.9) -! RCNTRL(8) -> ThetaMin. If Newton convergence rate smaller -! than ThetaMin the Jacobian is not recomputed; -! (default=0.001) -! RCNTRL(9) -> NewtonTol, stopping criterion for Newton's method -! (default=0.03) -! RCNTRL(10) -> Qmin -! RCNTRL(11) -> Qmax. If Qmin < Hnew/Hold < Qmax, then the -! step size is kept constant and the LU factorization -! reused (default Qmin=1, Qmax=1.2) -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!~~~> OUTPUT PARAMETERS: -! -! Note: each call to Rosenbrock adds the current no. of fcn calls -! to previous value of ISTATUS(1), and similar for the other params. -! Set ISTATUS(1:10) = 0 before call to avoid this accumulation. -! -! ISTATUS(1) = No. of function calls -! ISTATUS(2) = No. of jacobian calls -! ISTATUS(3) = No. of steps -! ISTATUS(4) = No. of accepted steps -! ISTATUS(5) = No. of rejected steps (except at the beginning) -! ISTATUS(6) = No. of LU decompositions -! ISTATUS(7) = No. of forward/backward substitutions -! ISTATUS(8) = No. of singular matrix decompositions -! -! RSTATUS(1) -> Texit, the time corresponding to the -! computed Y upon return -! RSTATUS(2) -> Hexit,last accepted step before return -! RSTATUS(3) -> Hnew, last predicted step before return -! For multiple restarts, use Hnew as Hstart in the following run -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - -! Arguments - INTEGER, INTENT(IN) :: N, ICNTRL(20) - KPP_REAL, INTENT(IN) :: Tinitial, Tfinal, & - RelTol(NVAR), AbsTol(NVAR), RCNTRL(20) - KPP_REAL, INTENT(INOUT) :: Y(NVAR) - INTEGER, INTENT(OUT) :: Ierr - INTEGER, INTENT(INOUT) :: ISTATUS(20) - KPP_REAL, INTENT(OUT) :: RSTATUS(20) - -!~~~> SDIRK method coefficients, up to 5 stages - INTEGER, PARAMETER :: Smax = 5 - INTEGER, PARAMETER :: S2A=1, S2B=2, S3A=3, S4A=4, S4B=5 - KPP_REAL :: rkGamma, rkA(Smax,Smax), rkB(Smax), rkC(Smax), & - rkD(Smax), rkE(Smax), rkBhat(Smax), rkELO, & - rkAlpha(Smax,Smax), rkTheta(Smax,Smax) - INTEGER :: sdMethod, rkS ! The number of stages -! Local variables - LOGICAL :: StartNewton - KPP_REAL :: Hmin, Hmax, Hstart, Roundoff, & - FacMin, Facmax, FacSafe, FacRej, & - ThetaMin, NewtonTol, Qmin, Qmax - INTEGER :: ITOL, NewtonMaxit, Max_no_steps, i - KPP_REAL, PARAMETER :: ZERO = 0.0d0, ONE = 1.0d0 - - - ISTATUS(1:20) = 0 - RSTATUS(1:20) = ZERO - Ierr = 0 - -!~~~> For Scalar tolerances (ICNTRL(2).NE.0) the code uses AbsTol(1) and RelTol(1) -! For Vector tolerances (ICNTRL(2) == 0) the code uses AbsTol(1:NVAR) and RelTol(1:NVAR) - IF (ICNTRL(2) == 0) THEN - ITOL = 1 - ELSE - ITOL = 0 - END IF - -!~~~> ICNTRL(3) - method selection - SELECT CASE (ICNTRL(3)) - CASE (0,1) - CALL Sdirk2a - CASE (2) - CALL Sdirk2b - CASE (3) - CALL Sdirk3a - CASE (4) - CALL Sdirk4a - CASE (5) - CALL Sdirk4b - CASE DEFAULT - CALL Sdirk2a - END SELECT - -!~~~> The maximum number of time steps admitted - IF (ICNTRL(4) == 0) THEN - Max_no_steps = 200000 - ELSEIF (ICNTRL(4) > 0) THEN - Max_no_steps=ICNTRL(4) - ELSE - PRINT * ,'User-selected ICNTRL(4)=',ICNTRL(4) - CALL SDIRK_ErrorMsg(-1,Tinitial,ZERO,Ierr) - END IF - -!~~~> The maximum number of Newton iterations admitted - IF(ICNTRL(5) == 0)THEN - NewtonMaxit=8 - ELSE - NewtonMaxit=ICNTRL(5) - IF(NewtonMaxit <= 0)THEN - PRINT * ,'User-selected ICNTRL(5)=',ICNTRL(5) - CALL SDIRK_ErrorMsg(-2,Tinitial,ZERO,Ierr) - END IF - END IF - -!~~~> StartNewton: Use extrapolation for starting values of Newton iterations - IF (ICNTRL(6) == 0) THEN - StartNewton = .TRUE. - ELSE - StartNewton = .FALSE. - END IF - -!~~~> Unit roundoff (1+Roundoff>1) - Roundoff = WLAMCH('E') - -!~~~> Lower bound on the step size: (positive value) - IF (RCNTRL(1) == ZERO) THEN - Hmin = ZERO - ELSEIF (RCNTRL(1) > ZERO) THEN - Hmin = RCNTRL(1) - ELSE - PRINT * , 'User-selected RCNTRL(1)=', RCNTRL(1) - CALL SDIRK_ErrorMsg(-3,Tinitial,ZERO,Ierr) - END IF - -!~~~> Upper bound on the step size: (positive value) - IF (RCNTRL(2) == ZERO) THEN - Hmax = ABS(Tfinal-Tinitial) - ELSEIF (RCNTRL(2) > ZERO) THEN - Hmax = MIN(ABS(RCNTRL(2)),ABS(Tfinal-Tinitial)) - ELSE - PRINT * , 'User-selected RCNTRL(2)=', RCNTRL(2) - CALL SDIRK_ErrorMsg(-3,Tinitial,ZERO,Ierr) - END IF - -!~~~> Starting step size: (positive value) - IF (RCNTRL(3) == ZERO) THEN - Hstart = MAX(Hmin,Roundoff) - ELSEIF (RCNTRL(3) > ZERO) THEN - Hstart = MIN(ABS(RCNTRL(3)),ABS(Tfinal-Tinitial)) - ELSE - PRINT * , 'User-selected Hstart: RCNTRL(3)=', RCNTRL(3) - CALL SDIRK_ErrorMsg(-3,Tinitial,ZERO,Ierr) - END IF - -!~~~> Step size can be changed s.t. FacMin < Hnew/Hexit < FacMax - IF (RCNTRL(4) == ZERO) THEN - FacMin = 0.2_dp - ELSEIF (RCNTRL(4) > ZERO) THEN - FacMin = RCNTRL(4) - ELSE - PRINT * , 'User-selected FacMin: RCNTRL(4)=', RCNTRL(4) - CALL SDIRK_ErrorMsg(-4,Tinitial,ZERO,Ierr) - END IF - IF (RCNTRL(5) == ZERO) THEN - FacMax = 10.0_dp - ELSEIF (RCNTRL(5) > ZERO) THEN - FacMax = RCNTRL(5) - ELSE - PRINT * , 'User-selected FacMax: RCNTRL(5)=', RCNTRL(5) - CALL SDIRK_ErrorMsg(-4,Tinitial,ZERO,Ierr) - END IF -!~~~> FacRej: Factor to decrease step after 2 succesive rejections - IF (RCNTRL(6) == ZERO) THEN - FacRej = 0.1_dp - ELSEIF (RCNTRL(6) > ZERO) THEN - FacRej = RCNTRL(6) - ELSE - PRINT * , 'User-selected FacRej: RCNTRL(6)=', RCNTRL(6) - CALL SDIRK_ErrorMsg(-4,Tinitial,ZERO,Ierr) - END IF -!~~~> FacSafe: Safety Factor in the computation of new step size - IF (RCNTRL(7) == ZERO) THEN - FacSafe = 0.9_dp - ELSEIF (RCNTRL(7) > ZERO) THEN - FacSafe = RCNTRL(7) - ELSE - PRINT * , 'User-selected FacSafe: RCNTRL(7)=', RCNTRL(7) - CALL SDIRK_ErrorMsg(-4,Tinitial,ZERO,Ierr) - END IF - -!~~~> ThetaMin: decides whether the Jacobian should be recomputed - IF(RCNTRL(8) == 0.D0)THEN - ThetaMin = 1.0d-3 - ELSE - ThetaMin = RCNTRL(8) - END IF - -!~~~> Stopping criterion for Newton's method - IF(RCNTRL(9) == ZERO)THEN - NewtonTol = 3.0d-2 - ELSE - NewtonTol = RCNTRL(9) - END IF - -!~~~> Qmin, Qmax: IF Qmin < Hnew/Hold < Qmax, STEP SIZE = CONST. - IF(RCNTRL(10) == ZERO)THEN - Qmin=ONE - ELSE - Qmin=RCNTRL(10) - END IF - IF(RCNTRL(11) == ZERO)THEN - Qmax=1.2D0 - ELSE - Qmax=RCNTRL(11) - END IF - -!~~~> Check if tolerances are reasonable - IF (ITOL == 0) THEN - IF (AbsTol(1) <= ZERO .OR. RelTol(1) <= 10.D0*Roundoff) THEN - PRINT * , ' Scalar AbsTol = ',AbsTol(1) - PRINT * , ' Scalar RelTol = ',RelTol(1) - CALL SDIRK_ErrorMsg(-5,Tinitial,ZERO,Ierr) - END IF - ELSE - DO i=1,N - IF (AbsTol(i) <= 0.D0.OR.RelTol(i) <= 10.D0*Roundoff) THEN - PRINT * , ' AbsTol(',i,') = ',AbsTol(i) - PRINT * , ' RelTol(',i,') = ',RelTol(i) - CALL SDIRK_ErrorMsg(-5,Tinitial,ZERO,Ierr) - END IF - END DO - END IF - - IF (Ierr < 0) RETURN - - CALL SDIRK_Integrator( N,Tinitial,Tfinal,Y,Ierr ) - - - !END SUBROUTINE SDIRK - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - CONTAINS ! PROCEDURES INTERNAL TO SDIRK -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SDIRK_Integrator( N,Tinitial,Tfinal,Y,Ierr ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - USE KPP_ROOT_Parameters - IMPLICIT NONE - -!~~~> Arguments: - INTEGER, INTENT(IN) :: N - KPP_REAL, INTENT(INOUT) :: Y(NVAR) - KPP_REAL, INTENT(IN) :: Tinitial, Tfinal - INTEGER, INTENT(OUT) :: Ierr - -!~~~> Local variables: - KPP_REAL :: Z(NVAR,Smax), G(NVAR), TMP(NVAR), & - NewtonRate, SCAL(NVAR), RHS(NVAR), & - T, H, Theta, Hratio, NewtonPredictedErr, & - Qnewton, Err, Fac, Hnew,Tdirection, & - NewtonIncrement, NewtonIncrementOld - INTEGER :: j, IER, istage, NewtonIter, IP(NVAR) - LOGICAL :: Reject, FirstStep, SkipJac, SkipLU, NewtonDone - -#ifdef FULL_ALGEBRA - KPP_REAL FJAC(NVAR,NVAR), E(NVAR,NVAR) -#else - KPP_REAL FJAC(LU_NONZERO), E(LU_NONZERO) -#endif - KPP_REAL, PARAMETER :: ZERO = 0.0d0, ONE = 1.0d0 - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Initializations -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - T = Tinitial - Tdirection = SIGN(ONE,Tfinal-Tinitial) - H = MAX(ABS(Hmin),ABS(Hstart)) - IF (ABS(H) <= 10.D0*Roundoff) H=1.0D-6 - H=MIN(ABS(H),Hmax) - H=SIGN(H,Tdirection) - SkipLU =.FALSE. - SkipJac = .FALSE. - Reject=.FALSE. - FirstStep=.TRUE. - - CALL SDIRK_ErrorScale(N, ITOL, AbsTol, RelTol, Y, SCAL) - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Time loop begins -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Tloop: DO WHILE ( (Tfinal-T)*Tdirection - Roundoff > ZERO ) - - -!~~~> Compute E = 1/(h*gamma)-Jac and its LU decomposition - IF ( .NOT.SkipLU ) THEN ! This time around skip the Jac update and LU - CALL SDIRK_PrepareMatrix ( H, T, Y, FJAC, & - SkipJac, SkipLU, E, IP, Reject, IER ) - IF (IER /= 0) THEN - CALL SDIRK_ErrorMsg(-8,T,H,Ierr); RETURN - END IF - END IF - - IF (ISTATUS(Nstp) > Max_no_steps) THEN - CALL SDIRK_ErrorMsg(-6,T,H,Ierr); RETURN - END IF - IF ( (T+0.1d0*H == T) .OR. (ABS(H) <= Roundoff) ) THEN - CALL SDIRK_ErrorMsg(-7,T,H,Ierr); RETURN - END IF - -stages:DO istage = 1, rkS - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Simplified Newton iterations -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -!~~~> Starting values for Newton iterations - CALL Set2zero(N,Z(1,istage)) - -!~~~> Prepare the loop-independent part of the right-hand side - CALL Set2zero(N,G) - IF (istage > 1) THEN - DO j = 1, istage-1 - ! Gj(:) = sum_j Theta(i,j)*Zj(:) = H * sum_j A(i,j)*Fun(Zj) - CALL WAXPY(N,rkTheta(istage,j),Z(1,j),1,G,1) - ! Zi(:) = sum_j Alpha(i,j)*Zj(:) - IF (StartNewton) THEN - CALL WAXPY(N,rkAlpha(istage,j),Z(1,j),1,Z(1,istage),1) - END IF - END DO - END IF - - !~~~> Initializations for Newton iteration - NewtonDone = .FALSE. - Fac = 0.5d0 ! Step reduction factor if too many iterations - -NewtonLoop:DO NewtonIter = 1, NewtonMaxit - -!~~~> Prepare the loop-dependent part of the right-hand side - CALL WADD(N,Y,Z(1,istage),TMP) ! TMP <- Y + Zi - CALL FUN_CHEM(T+rkC(istage)*H,TMP,RHS) ! RHS <- Fun(Y+Zi) - ISTATUS(Nfun) = ISTATUS(Nfun) + 1 -! RHS(1:N) = G(1:N) - Z(1:N,istage) + (H*rkGamma)*RHS(1:N) - CALL WSCAL(N, H*rkGamma, RHS, 1) - CALL WAXPY (N, -ONE, Z(1,istage), 1, RHS, 1) - CALL WAXPY (N, ONE, G,1, RHS,1) - -!~~~> Solve the linear system - CALL SDIRK_Solve ( H, N, E, IP, IER, RHS ) - -!~~~> Check convergence of Newton iterations - CALL SDIRK_ErrorNorm(N, RHS, SCAL, NewtonIncrement) - IF ( NewtonIter == 1 ) THEN - Theta = ABS(ThetaMin) - NewtonRate = 2.0d0 - ELSE - Theta = NewtonIncrement/NewtonIncrementOld - IF (Theta < 0.99d0) THEN - NewtonRate = Theta/(ONE-Theta) - ! Predict error at the end of Newton process - NewtonPredictedErr = NewtonIncrement & - *Theta**(NewtonMaxit-NewtonIter)/(ONE-Theta) - IF (NewtonPredictedErr >= NewtonTol) THEN - ! Non-convergence of Newton: predicted error too large - Qnewton = MIN(10.0d0,NewtonPredictedErr/NewtonTol) - Fac = 0.8d0*Qnewton**(-ONE/(1+NewtonMaxit-NewtonIter)) - EXIT NewtonLoop - END IF - ELSE ! Non-convergence of Newton: Theta too large - EXIT NewtonLoop - END IF - END IF - NewtonIncrementOld = NewtonIncrement - ! Update solution: Z(:) <-- Z(:)+RHS(:) - CALL WAXPY(N,ONE,RHS,1,Z(1,istage),1) - - ! Check error in Newton iterations - NewtonDone = (NewtonRate*NewtonIncrement <= NewtonTol) - IF (NewtonDone) EXIT NewtonLoop - - END DO NewtonLoop - - IF (.NOT.NewtonDone) THEN - !CALL RK_ErrorMsg(-12,T,H,Ierr); - H = Fac*H; Reject=.TRUE. - SkipJac = .TRUE.; SkipLU = .FALSE. - CYCLE Tloop - END IF - -!~~~> End of implified Newton iterations - - - END DO stages - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Error estimation -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ISTATUS(Nstp) = ISTATUS(Nstp) + 1 - CALL Set2zero(N,TMP) - DO i = 1,rkS - IF (rkE(i)/=ZERO) CALL WAXPY(N,rkE(i),Z(1,i),1,TMP,1) - END DO - - CALL SDIRK_Solve( H, N, E, IP, IER, TMP ) - CALL SDIRK_ErrorNorm(N, TMP, SCAL, Err) - -!~~~> Computation of new step size Hnew - Fac = FacSafe*(Err)**(-ONE/rkELO) - Fac = MAX(FacMin,MIN(FacMax,Fac)) - Hnew = H*Fac - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Accept/Reject step -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -accept: IF ( Err < ONE ) THEN !~~~> Step is accepted - - FirstStep=.FALSE. - ISTATUS(Nacc) = ISTATUS(Nacc) + 1 - -!~~~> Update time and solution - T = T + H - ! Y(:) <-- Y(:) + Sum_j rkD(j)*Z_j(:) - DO i = 1,rkS - IF (rkD(i)/=ZERO) CALL WAXPY(N,rkD(i),Z(1,i),1,Y,1) - END DO - -!~~~> Update scaling coefficients - CALL SDIRK_ErrorScale(N, ITOL, AbsTol, RelTol, Y, SCAL) - -!~~~> Next time step - Hnew = Tdirection*MIN(ABS(Hnew),Hmax) - ! Last T and H - RSTATUS(Ntexit) = T - RSTATUS(Nhexit) = H - RSTATUS(Nhnew) = Hnew - ! No step increase after a rejection - IF (Reject) Hnew = Tdirection*MIN(ABS(Hnew),ABS(H)) - Reject = .FALSE. - IF ((T+Hnew/Qmin-Tfinal)*Tdirection > ZERO) THEN - H = Tfinal-T - ELSE - Hratio=Hnew/H - ! If step not changed too much keep Jacobian and reuse LU - SkipLU = ( (Theta <= ThetaMin) .AND. (Hratio >= Qmin) & - .AND. (Hratio <= Qmax) ) - IF (.NOT.SkipLU) H = Hnew - END IF - ! If convergence is fast enough, do not update Jacobian -! SkipJac = (Theta <= ThetaMin) - SkipJac = .FALSE. - - ELSE accept !~~~> Step is rejected - - IF (FirstStep .OR. Reject) THEN - H = FacRej*H - ELSE - H = Hnew - END IF - Reject = .TRUE. - SkipJac = .TRUE. - SkipLU = .FALSE. - IF (ISTATUS(Nacc) >= 1) ISTATUS(Nrej) = ISTATUS(Nrej) + 1 - - END IF accept - - END DO Tloop - - ! Successful return - Ierr = 1 - - END SUBROUTINE SDIRK_Integrator - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SDIRK_ErrorScale(N, ITOL, AbsTol, RelTol, Y, SCAL) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - INTEGER :: i, N, ITOL - KPP_REAL :: AbsTol(NVAR), RelTol(NVAR), & - Y(NVAR), SCAL(NVAR) - IF (ITOL == 0) THEN - DO i=1,NVAR - SCAL(i) = ONE / ( AbsTol(1)+RelTol(1)*ABS(Y(i)) ) - END DO - ELSE - DO i=1,NVAR - SCAL(i) = ONE / ( AbsTol(i)+RelTol(i)*ABS(Y(i)) ) - END DO - END IF - END SUBROUTINE SDIRK_ErrorScale - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SDIRK_ErrorNorm(N, Y, SCAL, Err) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! - INTEGER :: i, N - KPP_REAL :: Y(N), SCAL(N), Err - Err = ZERO - DO i=1,N - Err = Err+(Y(i)*SCAL(i))**2 - END DO - Err = MAX( SQRT(Err/DBLE(N)), 1.0d-10 ) -! - END SUBROUTINE SDIRK_ErrorNorm - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SDIRK_ErrorMsg(Code,T,H,Ierr) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Handles all error messages -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - KPP_REAL, INTENT(IN) :: T, H - INTEGER, INTENT(IN) :: Code - INTEGER, INTENT(OUT) :: Ierr - - Ierr = Code - PRINT * , & - 'Forced exit from SDIRK due to the following error:' - - SELECT CASE (Code) - CASE (-1) - PRINT * , '--> Improper value for maximal no of steps' - CASE (-2) - PRINT * , '--> Improper value for maximal no of Newton iterations' - CASE (-3) - PRINT * , '--> Hmin/Hmax/Hstart must be positive' - CASE (-4) - PRINT * , '--> FacMin/FacMax/FacRej must be positive' - CASE (-5) - PRINT * , '--> Improper tolerance values' - CASE (-6) - PRINT * , '--> No of steps exceeds maximum bound' - CASE (-7) - PRINT * , '--> Step size too small: T + 10*H = T', & - ' or H < Roundoff' - CASE (-8) - PRINT * , '--> Matrix is repeatedly singular' - CASE DEFAULT - PRINT *, 'Unknown Error code: ', Code - END SELECT - - PRINT *, "T=", T, "and H=", H - - END SUBROUTINE SDIRK_ErrorMsg - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SDIRK_PrepareMatrix ( H, T, Y, FJAC, & - SkipJac, SkipLU, E, IP, Reject, ISING ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Compute the matrix E = 1/(H*GAMMA)*Jac, and its decomposition -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - - KPP_REAL, INTENT(INOUT) :: H - KPP_REAL, INTENT(IN) :: T, Y(NVAR) - LOGICAL, INTENT(INOUT) :: SkipJac,SkipLU,Reject - INTEGER, INTENT(OUT) :: ISING, IP(NVAR) -#ifdef FULL_ALGEBRA - KPP_REAL, INTENT(INOUT) :: FJAC(NVAR,NVAR) - KPP_REAL, INTENT(OUT) :: E(NVAR,NVAR) -#else - KPP_REAL, INTENT(INOUT) :: FJAC(LU_NONZERO) - KPP_REAL, INTENT(OUT) :: E(LU_NONZERO) -#endif - KPP_REAL :: HGammaInv - INTEGER :: i, j, ConsecutiveSng - - ConsecutiveSng = 0 - ISING = 1 - -Hloop: DO WHILE (ISING /= 0) - - HGammaInv = ONE/(H*rkGamma) - -!~~~> Compute the Jacobian -! IF (SkipJac) THEN -! SkipJac = .FALSE. -! ELSE - IF (.NOT. SkipJac) THEN - CALL JAC_CHEM( T, Y, FJAC ) - ISTATUS(Njac) = ISTATUS(Njac) + 1 - END IF - -#ifdef FULL_ALGEBRA - DO j=1,NVAR - DO i=1,NVAR - E(i,j) = -FJAC(i,j) - END DO - E(j,j) = E(j,j)+HGammaInv - END DO - CALL DGETRF( NVAR, NVAR, E, NVAR, IP, ISING ) -#else - DO i = 1,LU_NONZERO - E(i) = -FJAC(i) - END DO - DO i = 1,NVAR - j = LU_DIAG(i); E(j) = E(j) + HGammaInv - END DO - CALL KppDecomp ( E, ISING) - IP(1) = 1 -#endif - ISTATUS(Ndec) = ISTATUS(Ndec) + 1 - - IF (ISING /= 0) THEN - WRITE (6,*) ' MATRIX IS SINGULAR, ISING=',ISING,' T=',T,' H=',H - ISTATUS(Nsng) = ISTATUS(Nsng) + 1; ConsecutiveSng = ConsecutiveSng + 1 - IF (ConsecutiveSng >= 6) RETURN ! Failure - H = 0.5d0*H - SkipJac = .TRUE. - SkipLU = .FALSE. - Reject = .TRUE. - END IF - - END DO Hloop - - END SUBROUTINE SDIRK_PrepareMatrix - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SDIRK_Solve ( H, N, E, IP, ISING, RHS ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Solves the system (H*Gamma-Jac)*x = RHS -! using the LU decomposition of E = I - 1/(H*Gamma)*Jac -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - INTEGER, INTENT(IN) :: N, IP(N), ISING - KPP_REAL, INTENT(IN) :: H -#ifdef FULL_ALGEBRA - KPP_REAL, INTENT(IN) :: E(NVAR,NVAR) -#else - KPP_REAL, INTENT(IN) :: E(LU_NONZERO) -#endif - KPP_REAL, INTENT(INOUT) :: RHS(N) - KPP_REAL :: HGammaInv - - HGammaInv = ONE/(H*rkGamma) - CALL WSCAL(N,HGammaInv,RHS,1) -#ifdef FULL_ALGEBRA - CALL DGETRS( 'N', N, 1, E, N, IP, RHS, N, ISING ) -#else - CALL KppSolve(E, RHS) -#endif - ISTATUS(Nsol) = ISTATUS(Nsol) + 1 - - END SUBROUTINE SDIRK_Solve - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Sdirk4a -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - sdMethod = S4A -! Number of stages - rkS = 5 - -! Method coefficients - rkGamma = .2666666666666666666666666666666667d0 - - rkA(1,1) = .2666666666666666666666666666666667d0 - rkA(2,1) = .5000000000000000000000000000000000d0 - rkA(2,2) = .2666666666666666666666666666666667d0 - rkA(3,1) = .3541539528432732316227461858529820d0 - rkA(3,2) = -.5415395284327323162274618585298197d-1 - rkA(3,3) = .2666666666666666666666666666666667d0 - rkA(4,1) = .8515494131138652076337791881433756d-1 - rkA(4,2) = -.6484332287891555171683963466229754d-1 - rkA(4,3) = .7915325296404206392428857585141242d-1 - rkA(4,4) = .2666666666666666666666666666666667d0 - rkA(5,1) = 2.100115700566932777970612055999074d0 - rkA(5,2) = -.7677800284445976813343102185062276d0 - rkA(5,3) = 2.399816361080026398094746205273880d0 - rkA(5,4) = -2.998818699869028161397714709433394d0 - rkA(5,5) = .2666666666666666666666666666666667d0 - - rkB(1) = 2.100115700566932777970612055999074d0 - rkB(2) = -.7677800284445976813343102185062276d0 - rkB(3) = 2.399816361080026398094746205273880d0 - rkB(4) = -2.998818699869028161397714709433394d0 - rkB(5) = .2666666666666666666666666666666667d0 - - rkBhat(1)= 2.885264204387193942183851612883390d0 - rkBhat(2)= -.1458793482962771337341223443218041d0 - rkBhat(3)= 2.390008682465139866479830743628554d0 - rkBhat(4)= -4.129393538556056674929560012190140d0 - rkBhat(5)= 0.d0 - - rkC(1) = .2666666666666666666666666666666667d0 - rkC(2) = .7666666666666666666666666666666667d0 - rkC(3) = .5666666666666666666666666666666667d0 - rkC(4) = .3661315380631796996374935266701191d0 - rkC(5) = 1.d0 - -! Ynew = Yold + h*Sum_i {rkB_i*k_i} = Yold + Sum_i {rkD_i*Z_i} - rkD(1) = 0.d0 - rkD(2) = 0.d0 - rkD(3) = 0.d0 - rkD(4) = 0.d0 - rkD(5) = 1.d0 - -! Err = h * Sum_i {(rkB_i-rkBhat_i)*k_i} = Sum_i {rkE_i*Z_i} - rkE(1) = -.6804000050475287124787034884002302d0 - rkE(2) = 1.558961944525217193393931795738823d0 - rkE(3) = -13.55893003128907927748632408763868d0 - rkE(4) = 15.48522576958521253098585004571302d0 - rkE(5) = 1.d0 - -! Local order of Err estimate - rkElo = 4 - -! h*Sum_j {rkA_ij*k_j} = Sum_j {rkTheta_ij*Z_j} - rkTheta(2,1) = 1.875000000000000000000000000000000d0 - rkTheta(3,1) = 1.708847304091539528432732316227462d0 - rkTheta(3,2) = -.2030773231622746185852981969486824d0 - rkTheta(4,1) = .2680325578937783958847157206823118d0 - rkTheta(4,2) = -.1828840955527181631794050728644549d0 - rkTheta(4,3) = .2968246986151577397160821594427966d0 - rkTheta(5,1) = .9096171815241460655379433581446771d0 - rkTheta(5,2) = -3.108254967778352416114774430509465d0 - rkTheta(5,3) = 12.33727431701306195581826123274001d0 - rkTheta(5,4) = -11.24557012450885560524143016037523d0 - -! Starting value for Newton iterations: Z_i^0 = Sum_j {rkAlpha_ij*Z_j} - rkAlpha(2,1) = 2.875000000000000000000000000000000d0 - rkAlpha(3,1) = .8500000000000000000000000000000000d0 - rkAlpha(3,2) = .4434782608695652173913043478260870d0 - rkAlpha(4,1) = .7352046091658870564637910527807370d0 - rkAlpha(4,2) = -.9525565003057343527941920657462074d-1 - rkAlpha(4,3) = .4290111305453813852259481840631738d0 - rkAlpha(5,1) = -16.10898993405067684831655675112808d0 - rkAlpha(5,2) = 6.559571569643355712998131800797873d0 - rkAlpha(5,3) = -15.90772144271326504260996815012482d0 - rkAlpha(5,4) = 25.34908987169226073668861694892683d0 - -!~~~> Coefficients for continuous solution -! rkD(1,1)= 24.74416644927758d0 -! rkD(1,2)= -4.325375951824688d0 -! rkD(1,3)= 41.39683763286316d0 -! rkD(1,4)= -61.04144619901784d0 -! rkD(1,5)= -3.391332232917013d0 -! rkD(2,1)= -51.98245719616925d0 -! rkD(2,2)= 10.52501981094525d0 -! rkD(2,3)= -154.2067922191855d0 -! rkD(2,4)= 214.3082125319825d0 -! rkD(2,5)= 14.71166018088679d0 -! rkD(3,1)= 33.14347947522142d0 -! rkD(3,2)= -19.72986789558523d0 -! rkD(3,3)= 230.4878502285804d0 -! rkD(3,4)= -287.6629744338197d0 -! rkD(3,5)= -18.99932366302254d0 -! rkD(4,1)= -5.905188728329743d0 -! rkD(4,2)= 13.53022403646467d0 -! rkD(4,3)= -117.6778956422581d0 -! rkD(4,4)= 134.3962081008550d0 -! rkD(4,5)= 8.678995715052762d0 -! -! DO i=1,4 ! CONTi <-- Sum_j rkD(i,j)*Zj -! CALL Set2zero(N,CONT(1,i)) -! DO j = 1,rkS -! CALL WAXPY(N,rkD(i,j),Z(1,j),1,CONT(1,i),1) -! END DO -! END DO - - rkELO = 4.0d0 - - END SUBROUTINE Sdirk4a - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Sdirk4b -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - sdMethod = S4B -! Number of stages - rkS = 5 - -! Method coefficients - rkGamma = .25d0 - - rkA(1,1) = 0.25d0 - rkA(2,1) = 0.5d00 - rkA(2,2) = 0.25d0 - rkA(3,1) = 0.34d0 - rkA(3,2) =-0.40d-1 - rkA(3,3) = 0.25d0 - rkA(4,1) = 0.2727941176470588235294117647058824d0 - rkA(4,2) =-0.5036764705882352941176470588235294d-1 - rkA(4,3) = 0.2757352941176470588235294117647059d-1 - rkA(4,4) = 0.25d0 - rkA(5,1) = 1.041666666666666666666666666666667d0 - rkA(5,2) =-1.020833333333333333333333333333333d0 - rkA(5,3) = 7.812500000000000000000000000000000d0 - rkA(5,4) =-7.083333333333333333333333333333333d0 - rkA(5,5) = 0.25d0 - - rkB(1) = 1.041666666666666666666666666666667d0 - rkB(2) = -1.020833333333333333333333333333333d0 - rkB(3) = 7.812500000000000000000000000000000d0 - rkB(4) = -7.083333333333333333333333333333333d0 - rkB(5) = 0.250000000000000000000000000000000d0 - - rkBhat(1)= 1.069791666666666666666666666666667d0 - rkBhat(2)= -0.894270833333333333333333333333333d0 - rkBhat(3)= 7.695312500000000000000000000000000d0 - rkBhat(4)= -7.083333333333333333333333333333333d0 - rkBhat(5)= 0.212500000000000000000000000000000d0 - - rkC(1) = 0.25d0 - rkC(2) = 0.75d0 - rkC(3) = 0.55d0 - rkC(4) = 0.50d0 - rkC(5) = 1.00d0 - -! Ynew = Yold + h*Sum_i {rkB_i*k_i} = Yold + Sum_i {rkD_i*Z_i} - rkD(1) = 0.0d0 - rkD(2) = 0.0d0 - rkD(3) = 0.0d0 - rkD(4) = 0.0d0 - rkD(5) = 1.0d0 - -! Err = h * Sum_i {(rkB_i-rkBhat_i)*k_i} = Sum_i {rkE_i*Z_i} - rkE(1) = 0.5750d0 - rkE(2) = 0.2125d0 - rkE(3) = -4.6875d0 - rkE(4) = 4.2500d0 - rkE(5) = 0.1500d0 - -! Local order of Err estimate - rkElo = 4 - -! h*Sum_j {rkA_ij*k_j} = Sum_j {rkTheta_ij*Z_j} - rkTheta(2,1) = 2.d0 - rkTheta(3,1) = 1.680000000000000000000000000000000d0 - rkTheta(3,2) = -.1600000000000000000000000000000000d0 - rkTheta(4,1) = 1.308823529411764705882352941176471d0 - rkTheta(4,2) = -.1838235294117647058823529411764706d0 - rkTheta(4,3) = 0.1102941176470588235294117647058824d0 - rkTheta(5,1) = -3.083333333333333333333333333333333d0 - rkTheta(5,2) = -4.291666666666666666666666666666667d0 - rkTheta(5,3) = 34.37500000000000000000000000000000d0 - rkTheta(5,4) = -28.33333333333333333333333333333333d0 - -! Starting value for Newton iterations: Z_i^0 = Sum_j {rkAlpha_ij*Z_j} - rkAlpha(2,1) = 3. - rkAlpha(3,1) = .8800000000000000000000000000000000d0 - rkAlpha(3,2) = .4400000000000000000000000000000000d0 - rkAlpha(4,1) = .1666666666666666666666666666666667d0 - rkAlpha(4,2) = -.8333333333333333333333333333333333d-1 - rkAlpha(4,3) = .9469696969696969696969696969696970d0 - rkAlpha(5,1) = -6.d0 - rkAlpha(5,2) = 9.d0 - rkAlpha(5,3) = -56.81818181818181818181818181818182d0 - rkAlpha(5,4) = 54.d0 - - END SUBROUTINE Sdirk4b - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Sdirk2a -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - sdMethod = S2A -! Number of stages - rkS = 2 - -! Method coefficients - rkGamma = .2928932188134524755991556378951510d0 - - rkA(1,1) = .2928932188134524755991556378951510d0 - rkA(2,1) = .7071067811865475244008443621048490d0 - rkA(2,2) = .2928932188134524755991556378951510d0 - - rkB(1) = .7071067811865475244008443621048490d0 - rkB(2) = .2928932188134524755991556378951510d0 - - rkBhat(1)= .6666666666666666666666666666666667d0 - rkBhat(2)= .3333333333333333333333333333333333d0 - - rkC(1) = 0.292893218813452475599155637895151d0 - rkC(2) = 1.0d0 - -! Ynew = Yold + h*Sum_i {rkB_i*k_i} = Yold + Sum_i {rkD_i*Z_i} - rkD(1) = 0.0d0 - rkD(2) = 1.0d0 - -! Err = h * Sum_i {(rkB_i-rkBhat_i)*k_i} = Sum_i {rkE_i*Z_i} - rkE(1) = 0.4714045207910316829338962414032326d0 - rkE(2) = -0.1380711874576983496005629080698993d0 - -! Local order of Err estimate - rkElo = 2 - -! h*Sum_j {rkA_ij*k_j} = Sum_j {rkTheta_ij*Z_j} - rkTheta(2,1) = 2.414213562373095048801688724209698d0 - -! Starting value for Newton iterations: Z_i^0 = Sum_j {rkAlpha_ij*Z_j} - rkAlpha(2,1) = 3.414213562373095048801688724209698d0 - - END SUBROUTINE Sdirk2a - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Sdirk2b -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - sdMethod = S2B -! Number of stages - rkS = 2 - -! Method coefficients - rkGamma = 1.707106781186547524400844362104849d0 - - rkA(1,1) = 1.707106781186547524400844362104849d0 - rkA(2,1) = -.707106781186547524400844362104849d0 - rkA(2,2) = 1.707106781186547524400844362104849d0 - - rkB(1) = -.707106781186547524400844362104849d0 - rkB(2) = 1.707106781186547524400844362104849d0 - - rkBhat(1)= .6666666666666666666666666666666667d0 - rkBhat(2)= .3333333333333333333333333333333333d0 - - rkC(1) = 1.707106781186547524400844362104849d0 - rkC(2) = 1.0d0 - -! Ynew = Yold + h*Sum_i {rkB_i*k_i} = Yold + Sum_i {rkD_i*Z_i} - rkD(1) = 0.0d0 - rkD(2) = 1.0d0 - -! Err = h * Sum_i {(rkB_i-rkBhat_i)*k_i} = Sum_i {rkE_i*Z_i} - rkE(1) = -.4714045207910316829338962414032326d0 - rkE(2) = .8047378541243650162672295747365659d0 - -! Local order of Err estimate - rkElo = 2 - -! h*Sum_j {rkA_ij*k_j} = Sum_j {rkTheta_ij*Z_j} - rkTheta(2,1) = -.414213562373095048801688724209698d0 - -! Starting value for Newton iterations: Z_i^0 = Sum_j {rkAlpha_ij*Z_j} - rkAlpha(2,1) = .5857864376269049511983112757903019d0 - - END SUBROUTINE Sdirk2b - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Sdirk3a -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - sdMethod = S3A -! Number of stages - rkS = 3 - -! Method coefficients - rkGamma = .2113248654051871177454256097490213d0 - - rkA(1,1) = .2113248654051871177454256097490213d0 - rkA(2,1) = .2113248654051871177454256097490213d0 - rkA(2,2) = .2113248654051871177454256097490213d0 - rkA(3,1) = .2113248654051871177454256097490213d0 - rkA(3,2) = .5773502691896257645091487805019573d0 - rkA(3,3) = .2113248654051871177454256097490213d0 - - rkB(1) = .2113248654051871177454256097490213d0 - rkB(2) = .5773502691896257645091487805019573d0 - rkB(3) = .2113248654051871177454256097490213d0 - - rkBhat(1)= .2113248654051871177454256097490213d0 - rkBhat(2)= .6477918909913548037576239837516312d0 - rkBhat(3)= .1408832436034580784969504064993475d0 - - rkC(1) = .2113248654051871177454256097490213d0 - rkC(2) = .4226497308103742354908512194980427d0 - rkC(3) = 1.d0 - -! Ynew = Yold + h*Sum_i {rkB_i*k_i} = Yold + Sum_i {rkD_i*Z_i} - rkD(1) = 0.d0 - rkD(2) = 0.d0 - rkD(3) = 1.d0 - -! Err = h * Sum_i {(rkB_i-rkBhat_i)*k_i} = Sum_i {rkE_i*Z_i} - rkE(1) = 0.9106836025229590978424821138352906d0 - rkE(2) = -1.244016935856292431175815447168624d0 - rkE(3) = 0.3333333333333333333333333333333333d0 - -! Local order of Err estimate - rkElo = 2 - -! h*Sum_j {rkA_ij*k_j} = Sum_j {rkTheta_ij*Z_j} - rkTheta(2,1) = 1.0d0 - rkTheta(3,1) = -1.732050807568877293527446341505872d0 - rkTheta(3,2) = 2.732050807568877293527446341505872d0 - -! Starting value for Newton iterations: Z_i^0 = Sum_j {rkAlpha_ij*Z_j} - rkAlpha(2,1) = 2.0d0 - rkAlpha(3,1) = -12.92820323027550917410978536602349d0 - rkAlpha(3,2) = 8.83012701892219323381861585376468d0 - - END SUBROUTINE Sdirk3a - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - END SUBROUTINE SDIRK ! AND ALL ITS INTERNAL PROCEDURES -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE FUN_CHEM( T, Y, P ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - USE KPP_ROOT_Parameters, ONLY: NVAR, LU_NONZERO - USE KPP_ROOT_Global, ONLY: FIX, RCONST, TIME - USE KPP_ROOT_Function, ONLY: Fun - USE KPP_ROOT_Rates, ONLY: Update_SUN, Update_RCONST, Update_PHOTO - IMPLICIT NONE - - KPP_REAL :: T, Told - KPP_REAL :: Y(NVAR), P(NVAR) - - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - - CALL Fun( Y, FIX, RCONST, P ) - - TIME = Told - - END SUBROUTINE FUN_CHEM - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE JAC_CHEM( T, Y, JV ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - USE KPP_ROOT_Parameters, ONLY: NVAR, LU_NONZERO - USE KPP_ROOT_Global, ONLY: FIX, RCONST, TIME - USE KPP_ROOT_Jacobian - USE KPP_ROOT_Jacobian, ONLY: Jac_SP - USE KPP_ROOT_Rates, ONLY: Update_SUN, Update_RCONST, Update_PHOTO - IMPLICIT NONE - - KPP_REAL :: T, Told - KPP_REAL :: Y(NVAR) -#ifdef FULL_ALGEBRA - KPP_REAL :: JS(LU_NONZERO), JV(NVAR,NVAR) - INTEGER :: i, j -#else - KPP_REAL :: JV(LU_NONZERO) -#endif - - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - -#ifdef FULL_ALGEBRA - CALL Jac_SP(Y, FIX, RCONST, JS) - DO j=1,NVAR - DO i=1,NVAR - JV(i,j) = 0.0D0 - END DO - END DO - DO i=1,LU_NONZERO - JV(LU_IROW(i),LU_ICOL(i)) = JS(i) - END DO -#else - CALL Jac_SP(Y, FIX, RCONST, JV) -#endif - TIME = Told - - END SUBROUTINE JAC_CHEM - -END MODULE KPP_ROOT_Integrator - - diff --git a/boxmox/int/sdirk_adj.c b/boxmox/int/sdirk_adj.c deleted file mode 100644 index 07a24124aa0f2dcdaaa04a91d45067e23696744d..0000000000000000000000000000000000000000 --- a/boxmox/int/sdirk_adj.c +++ /dev/null @@ -1,1705 +0,0 @@ - -#define MAX(a,b) ( ((a) >= (b)) ? (a):(b) ) -#define MIN(b,c) ( ((b) < (c)) ? (b):(c) ) -#define ABS(x) ( ((x) >= 0 ) ? (x):(-x) ) -#define SIGN(x,y)( ( (x*y) >= 0 ) ?(x):(-x) ) -#define SQRT(d) ( pow((d),0.5) ) - -/* Numerical Constants */ -#define ZERO (KPP_REAL)0.0 -#define ONE (KPP_REAL)1.0 -#define HALF (KPP_REAL)0.5 -#define DeltaMin (KPP_REAL)1.0e-5 -enum boolean { FALSE=0, TRUE=1 }; - -/*~~~> Statistics on the work performed by the SDIRK method */ -enum statistics { Nfun=1, Njac=2, Nstp=3, Nacc=4, Nrej=5, Ndec=6, Nsol=7, - Nsng=8, Ntexit=1, Nhexit=2, Nhnew=3 }; - -/*~~~> SDIRK method coefficients, up to 5 stages */ -int Smax = 5; -enum ros_Params { S2A=1, S2B=2, S3A=3, S4A=4, S4B=5 }; -KPP_REAL rkGamma, rkA[5][5], rkB[5], rkC[5], rkD[5], rkE[5], - rkBhat[5], rkELO, rkAlpha[5][5], rkTheta[5][5]; -int sdMethod, rkS; /* The number of stages */ - -/*~~~> Checkpoints in memory buffers */ -int stack_ptr = -1; /* last written entry in checkpoint */ -KPP_REAL *chk_H, *chk_T; -KPP_REAL **chk_Y; -KPP_REAL ***chk_Z; -int **chk_P; -#ifdef FULL_ALGEBRA - KPP_REAL ***chk_J; -#else - KPP_REAL **chk_J; -#endif - -/* Function Headers */ -void INTEGRATE_ADJ( int NADJ, KPP_REAL Y[], KPP_REAL Lambda[][NVAR], - KPP_REAL TIN, KPP_REAL TOUT, KPP_REAL ATOL_adj[][NVAR], - KPP_REAL RTOL_adj[][NVAR], int ICNTRL_U[], - KPP_REAL RCNTRL_U[], int ISTATUS_U[], - KPP_REAL RSTATUS_U[] ); -int SDIRKADJ( int N, int NADJ, KPP_REAL Tinitial, KPP_REAL Tfinal, KPP_REAL Y[], - KPP_REAL Lambda[][NVAR], KPP_REAL RelTol[], KPP_REAL AbsTol[], - KPP_REAL RelTol_adj[][NVAR], KPP_REAL AbsTol_adj[][NVAR], - KPP_REAL RCNTRL[], int ICNTRL[], KPP_REAL RSTATUS[], - int ISTATUS[]); -int SDIRK_FwdInt( int N, KPP_REAL Tinitial, KPP_REAL Tfinal, KPP_REAL Y[], - KPP_REAL Hmax, KPP_REAL Hmin, KPP_REAL Hstart, - KPP_REAL Roundoff, KPP_REAL AbsTol[], KPP_REAL RelTol[], - int ISTATUS[], KPP_REAL RSTATUS[], int Max_no_steps, - int NewtonMaxit, KPP_REAL NewtonTol, KPP_REAL ThetaMin, - KPP_REAL FacSafe, KPP_REAL FacMin, KPP_REAL FacMax, - KPP_REAL FacRej, KPP_REAL Qmin, KPP_REAL Qmax, int ITOL, - int SaveLU ); -int SDIRK_DadjInt( int N, int NADJ, KPP_REAL Lambda[][NVAR], int SaveLU, - int ISTATUS[], int ITOL, KPP_REAL AbsTol_adj[][NVAR], - KPP_REAL RelTol_adj[][NVAR], int NewtonMaxit, - KPP_REAL ThetaMin, KPP_REAL NewtonTol, int DirectADJ ); -void SDIRK_AllocBuffers( int Max_no_steps, int rkS, int SaveLU ); -void SDIRK_FreeBuffers( int Max_no_steps, int SaveLU ); -void SDIRK_Push( KPP_REAL T, KPP_REAL H, KPP_REAL Y[], KPP_REAL Z[][NVAR], - KPP_REAL E[], int P[], int Max_no_steps, int SaveLU ); -void SDIRK_Pop( KPP_REAL* T, KPP_REAL* H, KPP_REAL* Y, KPP_REAL* Z, - KPP_REAL* E, int* P, int SaveLU ); -void SDIRK_ErrorScale( int N, int ITOL, KPP_REAL AbsTol[], KPP_REAL RelTol[], - KPP_REAL Y[],KPP_REAL SCAL[]); -KPP_REAL SDIRK_ErrorNorm( int N, KPP_REAL Y[], KPP_REAL SCAL[] ); -int SDIRK_ErrorMsg( int code, KPP_REAL T, KPP_REAL H ); -void SDIRK_PrepareMatrix( KPP_REAL H, KPP_REAL T, KPP_REAL Y[], KPP_REAL FJAC[], - int SkipJac, int SkipLU, KPP_REAL E[], int IP[], - int Reject, int ISING, int ISTATUS[] ); -void SDIRK_Solve ( char Transp, KPP_REAL H, int N, KPP_REAL E[], - int IP[], int ISING, KPP_REAL RHS[], int ISTATUS[] ); -void Sdirk4a(); -void Sdirk4b(); -void Sdirk2a(); -void Sdirk2b(); -void Sdirk3a(); -void FUN_CHEM( KPP_REAL T, KPP_REAL Y[], KPP_REAL P[] ); -void JAC_CHEM( KPP_REAL T, KPP_REAL Y[], KPP_REAL JV[] ); -KPP_REAL WLAMCH( char C ); -void Set2Zero( int N, KPP_REAL Y[] ); -void WAXPY( int N, KPP_REAL Alpha, KPP_REAL X[], int incX, KPP_REAL Y[], - int incY ); -void WADD( int N, KPP_REAL Y[], KPP_REAL Z[], KPP_REAL TMP[] ); -void WSCAL( int N, KPP_REAL Alpha, KPP_REAL X[], int incX ); -void JacTR_SP_Vec( KPP_REAL Jac[], KPP_REAL Fcn[], KPP_REAL K[] ); -void KppSolve( KPP_REAL A[], KPP_REAL b[] ); -void KppSolveTR( KPP_REAL JVS[], KPP_REAL X[], KPP_REAL XX[] ); -int KppDecomp( KPP_REAL A[] ); -void Update_SUN(); -void Update_RCONST(); -void Fun( KPP_REAL Y[], KPP_REAL FIX[], KPP_REAL RCONST[], KPP_REAL Ydot[] ); -void Jac_SP( KPP_REAL Y[], KPP_REAL FIX[], KPP_REAL RCONST[], KPP_REAL Ydot[] ); -void Set2Zero( int N, KPP_REAL Y[] ); - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void INTEGRATE_ADJ( int NADJ, KPP_REAL Y[], KPP_REAL Lambda[][NVAR], - KPP_REAL TIN, KPP_REAL TOUT, KPP_REAL ATOL_adj[][NVAR], - KPP_REAL RTOL_adj[][NVAR], int ICNTRL_U[], - KPP_REAL RCNTRL_U[], int ISTATUS_U[], - KPP_REAL RSTATUS_U[] ) { -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - - //int Ntotal = 0; - KPP_REAL RCNTRL[20], RSTATUS[20], T1, T2; - int ICNTRL[20], ISTATUS[20], Ierr, i; - - for(i=0; i<20; i++) { - ICNTRL[i] = 0; - RCNTRL[i] = (KPP_REAL)0.0; - ISTATUS[i] = 0; - RSTATUS[i] = (KPP_REAL)0.0; - } - - /*~~~> fine-tune the integrator: */ - ICNTRL[4] = 8; /* Max no. of Newton iterations */ - ICNTRL[6] = 1; /* Adjoint solution by: 0=Newton, 1=direct */ - ICNTRL[7] = 1; /* Save fwd LU factorization: 0 = do *not* save, 1 = save */ - - /* If optional parameters are given, and if they are >0, - then they overwrite default settings. */ - //if(ICNTRL_U != NULL) { /* Check to see if ICNTRL_U is not NULL */ - // for(i=0; i<20; i++) { - // if(ICNTRL_U[i] > 0) - // ICNTRL[i] = ICNTRL_U[i]; - // } - //} - // - //if(RCNTRL_U != NULL) { /* Check to see if RCNTRL_U is not NULL */ - // for(i=0; i<20; i++) { - // if(RCNTRL_U[i] > 0) - // RCNTRL[i] = RCNTRL_U[i]; - // } - //} - - T1 = TIN; - T2 = TOUT; - Ierr = SDIRKADJ( NVAR, NADJ, T1, T2, Y, Lambda, RTOL, ATOL, ATOL_adj, - RTOL_adj, RCNTRL, ICNTRL, RSTATUS, ISTATUS ); - - /*~~~> Debug option: number of steps */ - // Ntotal = Ntotal + ISTATUS(Nstp) - // printf( "NSTEP=%d Ntotal=%d O3=%e NO2=%e\n", ISTATUS(Nstp), Ntotal, - // VAR(ind_O3), VAR(ind_NO2) ); - - if (Ierr < 0) - printf("SDIRK: Unsuccessful exit at T=%f (Ierr=%d)\n", TIN, Ierr ); - - /* if optional parameters are given for output they to return information */ - //if(ISTATUS_U != NULL) { /* Check to see if ISTATUS_U is not NULL */ - // for(i=0; i<20; i++) - // ISTATUS_U[i] = ISTATUS[i]; - //} - // - //if(RSTATUS_U != NULL) { /* Check to see if RSTATUS_U is not NULL */ - // for(i=0; i<20; i++) - // RSTATUS_U[i] = RSTATUS[i]; - //} - // - //Ierr_U = Ierr; - -} /* END of SUBROUTINE INTEGRATE_ADJ */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -int SDIRKADJ( int N, int NADJ, KPP_REAL Tinitial, KPP_REAL Tfinal, KPP_REAL Y[], - KPP_REAL Lambda[][NVAR], KPP_REAL RelTol[], KPP_REAL AbsTol[], - KPP_REAL RelTol_adj[][NVAR], KPP_REAL AbsTol_adj[][NVAR], - KPP_REAL RCNTRL[], int ICNTRL[], KPP_REAL RSTATUS[], - int ISTATUS[] ) { -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - Solves the system y'=F(t,y) using a Singly-Diagonally-Implicit - Runge-Kutta (SDIRK) method. - - This implementation is based on the book and the code Sdirk4: - - E. Hairer and G. Wanner - "Solving ODEs II. Stiff and differential-algebraic problems". - Springer series in computational mathematics, Springer-Verlag, 1996. - This code is based on the SDIRK4 routine in the above book. - - Methods: - * Sdirk 2a, 2b: L-stable, 2 stages, order 2 - * Sdirk 3a: L-stable, 3 stages, order 2, adjoint-invariant - * Sdirk 4a, 4b: L-stable, 5 stages, order 4 - - (C) Adrian Sandu, July 2005 - Virginia Polytechnic Institute and State University - Contact: sandu@cs.vt.edu - Revised by Philipp Miehe and Adrian Sandu, May 2006 - Translation F90 to C by Paul Eller, May 2007 - This implementation is part of KPP - the Kinetic PreProcessor -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -~~~> INPUT ARGUMENTS: - -- Y[NVAR] = vector of initial conditions (at T=Tinitial) -- [Tinitial,Tfinal] = time range of integration - (if Tinitial>Tfinal the integration is performed backwards in time) -- RelTol, AbsTol = user precribed accuracy -- SUBROUTINE ode_Fun( T, Y, Ydot ) = ODE function, - returns Ydot = Y' = F(T,Y) -- SUBROUTINE ode_Fun( T, Y, Ydot ) = Jacobian of the ODE function, - returns Jcb = dF/dY -- ICNTRL[1:20] = integer inputs parameters -- RCNTRL[1:20] = real inputs parameters -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -~~~> OUTPUT ARGUMENTS: - -- Y[NVAR] -> vector of final states (at T->Tfinal) -- ISTATUS[0:19] -> integer output parameters -- RSTATUS[0:19] -> real output parameters -- Ierr -> job status upon return - success (positive value) or - failure (negative value) -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -~~~> INPUT PARAMETERS: - - Note: For input parameters equal to zero the default values of the - corresponding variables are used. - - Note: For input parameters equal to zero the default values of the - corresponding variables are used. -~~~> - ICNTRL[0] = not used - - ICNTRL[1] = 0: AbsTol, RelTol are NVAR-dimensional vectors - = 1: AbsTol, RelTol are scalars - - ICNTRL[2] = Method - - ICNTRL[3] -> maximum number of integration steps - For ICNTRL[3]=0 the default value of 1500 is used - Note: use a conservative estimate, since the checkpoint - buffers are allocated to hold Max_no_steps - - ICNTRL[4] -> maximum number of Newton iterations - For ICNTRL[4]=0 the default value of 8 is used - - ICNTRL[5] -> starting values of Newton iterations: - ICNTRL[5]=0 : starting values are interpolated (the default) - ICNTRL[5]=1 : starting values are zero - - ICNTRL[6] -> method to solve ADJ equations: - ICNTRL[6]=0 : modified Newton re-using LU (the default) - ICNTRL[6]=1 : direct solution(additional one LU factorization per stage) - - ICNTRL[7] -> checkpointing the LU factorization at each step: - ICNTRL[7]=0 : do *not* save LU factorization (the default) - ICNTRL[7]=1 : save LU factorization - Note: if ICNTRL[6]=1 the LU factorization is *not* saved - -~~~> Real parameters - - RCNTRL[0] -> Hmin, lower bound for the integration step size - It is strongly recommended to keep Hmin = ZERO - RCNTRL[1] -> Hmax, upper bound for the integration step size - RCNTRL[2] -> Hstart, starting value for the integration step size - - RCNTRL[3] -> FacMin, lower bound on step decrease factor (default=0.2) - RCNTRL[4] -> FacMax, upper bound on step increase factor (default=6) - RCNTRL[5] -> FacRej, step decrease factor after multiple rejections - (default=0.1) - RCNTRL[6] -> FacSafe, by which the new step is slightly smaller - than the predicted value (default=0.9) - RCNTRL[7] -> ThetaMin. If Newton convergence rate smaller - than ThetaMin the Jacobian is not recomputed; - (default=0.001) - RCNTRL[8] -> NewtonTol, stopping criterion for Newton's method - (default=0.03) - RCNTRL[9] -> Qmin - RCNTRL[10] -> Qmax. If Qmin < Hnew/Hold < Qmax, then the - step size is kept constant and the LU factorization - reused (default Qmin=1, Qmax=1.2) - -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -~~~> OUTPUT PARAMETERS: - - Note: each call to Rosenbrock adds the current no. of fcn calls - to previous value of ISTATUS[0], and similar for the other params. - Set ISTATUS[1:10] = 0 before call to avoid this accumulation. - - ISTATUS[0] = No. of function calls - ISTATUS[1] = No. of jacobian calls - ISTATUS[2] = No. of steps - ISTATUS[3] = No. of accepted steps - ISTATUS[4] = No. of rejected steps (except at the beginning) - ISTATUS[5] = No. of LU decompositions - ISTATUS[6] = No. of forward/backward substitutions - ISTATUS[7] = No. of singular matrix decompositions - - RSTATUS[0] -> Texit, the time corresponding to the - computed Y upon return - RSTATUS[1] -> Hexit,last accepted step before return - RSTATUS[2] -> Hnew, last predicted step before return - For multiple restarts, use Hnew as Hstart in the following run - -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - -/* Local variables */ - KPP_REAL Hmin=0.0, Hmax=0.0, Hstart=0.0, Roundoff, FacMin=0.0, FacMax=0.0, - FacSafe=0.0, FacRej=0.0, ThetaMin, NewtonTol,Qmin, Qmax; - int SaveLU, DirectADJ; /* Boolean variables */ - int ITOL, NewtonMaxit, Max_no_steps=0, i, Ierr=0; - - stack_ptr = -1; - -/*~~~> Initialize statistics */ - for(i=0; i<20; i++) { - ISTATUS[i] = 0; - RSTATUS[i] = ZERO; - } - -/*~~~> For Scalar tolerances (ICNTRL[1] != 0) the code uses AbsTol[0] - and RelTol[0] - For Vector tolerances (ICNTRL[1] == 0) the code uses AbsTol[0:NVAR-1] - and RelTol[0:NVAR-1]*/ - if (ICNTRL[1]==0) - ITOL = 1; - else - ITOL = 0; - -/*~~~> ICNTRL(3) - method selection */ - switch (ICNTRL[2]) { - case 0: - case 1: - Sdirk2a(); - break; - case 2: - Sdirk2b(); - break; - case 3: - Sdirk3a(); - break; - case 4: - Sdirk4a(); - break; - case 5: - Sdirk4b(); - break; - default: - Sdirk2a(); - } - -/*~~~> The maximum number of time steps admitted */ - if (ICNTRL[3] == 0) - Max_no_steps = 200000; - else if (ICNTRL[3] > 0) - Max_no_steps = ICNTRL[3]; - else { - printf("User-selected ICNTRL(4)=%d", ICNTRL[3]); - Ierr = SDIRK_ErrorMsg(-1,Tinitial,ZERO); - } - -/*~~~>The maximum number of Newton iterations admitted */ - if(ICNTRL[4]==0) - NewtonMaxit = 8; - else { - NewtonMaxit=ICNTRL[4]; - if(NewtonMaxit <=0) { - printf("User-selected ICNTRL(5)=%d", ICNTRL[4] ); - Ierr = SDIRK_ErrorMsg(-2,Tinitial,ZERO); - } - } - -/*~~~> Solve ADJ equations directly or by Newton iterations */ - DirectADJ = (ICNTRL[6] == 1); - -/*~~~> Save or not the forward LU factorization */ - SaveLU = ((ICNTRL[7] != 0) && (DirectADJ == 0)); - -/*~~~> Unit roundoff (1+Roundoff>1) */ - Roundoff = WLAMCH('E'); - -/*~~~> Lower bound on the step size: (positive value) */ - if (RCNTRL[0] == ZERO) - Hmin = ZERO; - else if (RCNTRL[0] > ZERO) - Hmin = RCNTRL[0]; - else { - printf("User-selected RCNTRL[0]=%f", RCNTRL[0]); - Ierr = SDIRK_ErrorMsg(-3,Tinitial,ZERO); - } - -/*~~~> Upper bound on the step size: (positive value) */ - if (RCNTRL[1] == ZERO) - Hmax = ABS(Tfinal-Tinitial); - else if (RCNTRL[1] > ZERO) - Hmax = MIN( ABS(RCNTRL[1]), ABS(Tfinal-Tinitial) ); - else { - printf("User-selected RCNTRL[1]=%f", RCNTRL[1]); - Ierr = SDIRK_ErrorMsg(-3,Tinitial,ZERO); - } - -/*~~~> Starting step size: (positive value) */ - if (RCNTRL[2] == ZERO) - Hstart = MAX( Hmin, Roundoff); - else if (RCNTRL[2] > ZERO) - Hstart = MIN( ABS(RCNTRL[2]), ABS(Tfinal-Tinitial) ); - else { - printf("User-selected Hstart: RCNTRL[2]=%f", RCNTRL[2]); - Ierr = SDIRK_ErrorMsg(-3,Tinitial,ZERO); - } - -/*~~~> Step size can be changed s.t. FacMin < Hnew/Hexit < FacMax */ - if (RCNTRL[3] == ZERO) - FacMin = (KPP_REAL)0.2; - else if (RCNTRL[3] > ZERO) - FacMin = RCNTRL[3]; - else { - printf("User-selected FacMin: RCNTRL[3]=%f", RCNTRL[3]); - Ierr = SDIRK_ErrorMsg(-4,Tinitial,ZERO); - } - - if (RCNTRL[4] == ZERO) - FacMax = (KPP_REAL)10.0; - else if (RCNTRL[4] > ZERO) - FacMax = RCNTRL[4]; - else { - printf("User-selected FacMax: RCNTRL[4]=%f", RCNTRL[4]); - Ierr = SDIRK_ErrorMsg(-4,Tinitial,ZERO); - } - -/*~~~> FacRej: Factor to decrease step after 2 succesive rejections */ - if (RCNTRL[5] == ZERO) - FacRej = (KPP_REAL)0.1; - else if (RCNTRL[5] > ZERO) - FacRej = RCNTRL[5]; - else { - printf("User-selected FacRej: RCNTRL[5]=%f", RCNTRL[5]); - Ierr = SDIRK_ErrorMsg(-4,Tinitial,ZERO); - } - -/* ~~~> FacSafe: Safety Factor in the computation of new step size */ - if (RCNTRL[6] == ZERO) - FacSafe = (KPP_REAL)0.9; - else if (RCNTRL[6] > ZERO) - FacSafe = RCNTRL[6]; - else { - printf("User-selected FacSafe: RCNTRL[6]=%f", RCNTRL[6]); - Ierr = SDIRK_ErrorMsg(-4,Tinitial,ZERO); - } - -/*~~~> ThetaMin: decides whether the Jacobian should be recomputed */ - if (RCNTRL[7] == ZERO) - ThetaMin = (KPP_REAL)1.0e-03; - else - ThetaMin = RCNTRL[7]; - -/*~~~> Stopping criterion for Newton's method */ - if (RCNTRL[8] == ZERO) - NewtonTol = (KPP_REAL)3.0e-02; - else - NewtonTol = RCNTRL[8]; - -/* ~~~> Qmin, Qmax: IF Qmin < Hnew/Hold < Qmax, STEP SIZE = CONST. */ - if (RCNTRL[9] == ZERO) - Qmin = ONE; - else - Qmin = RCNTRL[9]; - - if (RCNTRL[10] == ZERO) - Qmax = (KPP_REAL)1.2; - else - Qmax = RCNTRL [10]; - -/* ~~~> Check if tolerances are reasonable */ - if (ITOL == 0) { - if ((AbsTol[0]<=ZERO || RelTol[0])<=(((KPP_REAL)10.0)*Roundoff)) - Ierr = SDIRK_ErrorMsg(-5,Tinitial,ZERO); - } - else { - for (i = 0; i < N; i++) { - if ((AbsTol[i]<=ZERO)||(RelTol[i]<=((KPP_REAL)10.0)*Roundoff)) - Ierr = SDIRK_ErrorMsg(-5,Tinitial,ZERO); - } - } - - if (Ierr < 0) - return Ierr; - -/*~~~> Allocate memory buffers */ - SDIRK_AllocBuffers(Max_no_steps, rkS, SaveLU); - -/*~~~> Call forward integration */ - Ierr = SDIRK_FwdInt( N, Tinitial, Tfinal, Y, Hmax, Hmin, Hstart, Roundoff, - AbsTol, RelTol, ISTATUS, RSTATUS, Max_no_steps, - NewtonMaxit, NewtonTol, ThetaMin, FacSafe, FacMin, - FacMax, FacRej, Qmin, Qmax, ITOL, SaveLU ); - -/*~~~> Call adjoint integration */ - Ierr = SDIRK_DadjInt( N, NADJ, Lambda, SaveLU, ISTATUS, ITOL, AbsTol_adj, - RelTol_adj, NewtonMaxit, ThetaMin, NewtonTol, - DirectADJ ); - -/*~~~> Free memory buffers */ - SDIRK_FreeBuffers(Max_no_steps, SaveLU); - - return Ierr; - -} /* End of main SDIRK_ADJ */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -int SDIRK_FwdInt( int N, KPP_REAL Tinitial, KPP_REAL Tfinal, KPP_REAL Y[], - KPP_REAL Hmax, KPP_REAL Hmin, KPP_REAL Hstart, - KPP_REAL Roundoff, KPP_REAL AbsTol[], KPP_REAL RelTol[], - int ISTATUS[], KPP_REAL RSTATUS[], int Max_no_steps, - int NewtonMaxit, KPP_REAL NewtonTol, KPP_REAL ThetaMin, - KPP_REAL FacSafe, KPP_REAL FacMin, KPP_REAL FacMax, - KPP_REAL FacRej, KPP_REAL Qmin, KPP_REAL Qmax, int ITOL, - int SaveLU ) { -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - -/*~~~> Local variables: */ - KPP_REAL Z[Smax][NVAR], G[NVAR], TMP[NVAR], NewtonRate, SCAL[NVAR], RHS[NVAR], - T, H, Theta=0.0, Hratio, NewtonPredictedErr, Qnewton, Err, Fac, Hnew, - Tdirection, NewtonIncrement, NewtonIncrementOld=0.0; - int i, j, IER=0, istage, NewtonIter, IP[NVAR]; - - /*Boolean Variables*/ - int Reject, FirstStep, SkipJac, SkipLU, NewtonDone, CycleTloop; - -#ifdef FULL_ALGEBRA - KPP_REAL FJAC[NVAR][NVAR], E[NVAR][NVAR]; -#else - KPP_REAL FJAC[LU_NONZERO], E[LU_NONZERO]; -#endif - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -/*~~~~> Initializations */ -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - T = Tinitial; - Tdirection = SIGN(ONE, Tfinal-Tinitial); - H = MAX(ABS(Hmin), ABS(Hstart)); - if (ABS(H) <= ((KPP_REAL)10.0 * Roundoff)) - H = (KPP_REAL)(1.0e-06); - H = MIN(ABS(H), Hmax); - H = SIGN(H, Tdirection); - SkipLU = 0; - SkipJac = 0; - Reject = 0; - FirstStep = 1; - CycleTloop = 0; - - SDIRK_ErrorScale(N, ITOL, AbsTol, RelTol, Y, SCAL); - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -/*~~~> Time loop begins */ -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - while((Tfinal-T)*Tdirection - Roundoff > ZERO) { /* Tloop */ - - /*~~~> Compute E = 1/(h*gamma)-Jac and its LU decomposition */ - if (SkipLU == 0) { /* This time around skip the Jac update and LU */ - SDIRK_PrepareMatrix( H, T, Y, FJAC, SkipJac, SkipLU, E, IP, - Reject, IER, ISTATUS); - if (IER != 0) - return SDIRK_ErrorMsg(-8, T, H); - } - - if (ISTATUS[Nstp] > Max_no_steps) - return SDIRK_ErrorMsg(-6, T, H); - - if ((T + ((KPP_REAL)0.1) * H == T) || (ABS(H) <= Roundoff)) { - return SDIRK_ErrorMsg(-7, T, H); - } - - for (istage=0; istage < rkS; istage++) { /*stages*/ -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -/*~~~> Simplified Newton iterations */ -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - - /*~~~> Starting values for Newton iterations */ - Set2Zero(N, &Z[istage][0]); - - /*~~~> Prepare the loop-independent part of the right-hand side */ - Set2Zero(N, G); - if (istage > 0) { - for (j=0; j < istage; j++) { - /* Gj(:) = sum_j Theta(i,j)*Zj(:) = H * sum_j A(i,j)*Fun(Zj(:)) */ - WAXPY(N, rkTheta[j][istage], &Z[j][0], 1, G, 1); - /* Zi(:) = sum_j Alpha(i,j)*Zj(:) */ - WAXPY(N, rkAlpha[j][istage],&Z[j][0], 1, &Z[istage][0], 1); - } - } - - /*~~~> Initializations for Newton iteration */ - NewtonDone = 0; /* false */ - Fac = (KPP_REAL)0.5; /* Step reduction factor */ - - for (NewtonIter=0; NewtonIter Prepare the loop-dependent part of the right-hand side */ - WADD(N, Y, &Z[istage][0], TMP); /* TMP <- Y + Zi */ - FUN_CHEM(T+rkC[istage]*H, TMP, RHS); /* RHS <- Run(Y+Zi) */ - ISTATUS[Nfun]++; - /* RHS[0:N-1] = G[0:N-1] - Z[istage][0:N-1] + (H*rkGamma)*RHS[1:N] */ - WSCAL(N, H*rkGamma, RHS, 1); - WAXPY(N, -ONE, &Z[istage][0], 1, RHS, 1); - WAXPY(N, ONE, G, 1, RHS, 1 ); - - /*~~~> Solve the linear system */ - SDIRK_Solve('N', H, N, E, IP, IER, RHS, ISTATUS); - - /*~~~> Check convergence of Newton iterations */ - NewtonIncrement = SDIRK_ErrorNorm(N, RHS, SCAL); - if (NewtonIter == 0) { - Theta = ABS(ThetaMin); - NewtonRate = (KPP_REAL)2.0; - } - else { - Theta = NewtonIncrement/NewtonIncrementOld; - if (Theta < (KPP_REAL)0.99) { - NewtonRate = Theta/(ONE-Theta); - /* Predict error at the end of Newton process */ - NewtonPredictedErr = (NewtonIncrement*pow(Theta, - (NewtonMaxit - (NewtonIter+1))/(ONE - Theta))); - if(NewtonPredictedErr >= NewtonTol) { - /* Non-convergence of Newton: predicted error too large*/ - Qnewton = MIN((KPP_REAL)10.0, NewtonPredictedErr/NewtonTol); - Fac = (KPP_REAL)0.8 * pow(Qnewton, (-ONE / (1 + NewtonMaxit - - NewtonIter + 1))); - break; - } - } - else /* Non-convergence of Newton: Theta too large */ { - break; - } - } - - NewtonIncrementOld = NewtonIncrement; - - /* Update solution: Z(:) <-- Z(:)+RHS(:) */ - WAXPY(N, ONE, RHS, 1, &Z[istage][0], 1); - - /* Check error in Newton iterations */ - NewtonDone=(NewtonRate*NewtonIncrement<=NewtonTol); - if (NewtonDone == 1) - break; - } /* end NewtonLoop for */ - - if(NewtonDone == 0) { - H = Fac*H; - Reject = 1; - SkipJac = 1; - SkipLU = 0; - CycleTloop = 1; - } /* end if */ - - if (CycleTloop == 1) { - CycleTloop=0; - break; - } - /* End of implified Newton iterations */ - } /* end stages for */ - - if (CycleTloop==0) { -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -/*~~~> Error estimation */ -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - ISTATUS[Nstp]++; - Set2Zero(N, TMP); - - for (i=0; i Computation of new step size Hnew */ - Fac = FacSafe * pow((Err), (-ONE/rkELO)); - Fac = MAX(FacMin, MIN(FacMax, Fac)); - Hnew = H*Fac; - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -/*~~~> Accept/Reject step */ -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - if (Err < ONE) { /*~~~> Step is accepted */ - FirstStep = 0; /* false */ - ISTATUS[Nacc]++; - - /* Checkpoint solution */ - SDIRK_Push( T, H, Y, Z, E, IP, Max_no_steps, SaveLU ); - - /*~~~> Update time and solution */ - T = T + H; - /* Y(:) <-- Y(:) + Sum_j rkD(j)*Z_j(:) */ - for(i=0; i Update scaling coefficients */ - SDIRK_ErrorScale(N, ITOL, AbsTol, RelTol, Y, SCAL); - - /*~~~> Next time step */ - Hnew = Tdirection*MIN(ABS(Hnew), Hmax); - - /* Last T and H */ - RSTATUS[Ntexit] = T; - RSTATUS[Nhexit] = H; - RSTATUS[Nhnew] = Hnew; - - /* No step increase after a rejection */ - if (Reject==1) - Hnew = Tdirection*MIN(ABS(Hnew), ABS(H)); - Reject = 0; /* false */ - if ((T+Hnew/Qmin-Tfinal)*Tdirection > ZERO) - H = Tfinal-T; - else { - Hratio = Hnew/H; - /* If step not changed too much keep Jacobian and reuse LU */ - SkipLU = ((Theta <= ThetaMin) && (Hratio >= Qmin) - && (Hratio <= Qmax)); - if (SkipLU==0) - H = Hnew; - } - - /* If convergence is fast enough, do not update Jacobian */ - /* SkipJac = (Theta <= ThetaMin); */ - SkipJac = 0; - } - else { /*~~~> Step is rejected */ - if ((FirstStep==1) || (Reject==1)) - H = FacRej * H; - else - H = Hnew; - - Reject = 1; - SkipJac = 1; - SkipLU = 0; - if (ISTATUS[Nacc] >=1) - ISTATUS[Nrej]++; - - } - } /* end CycleTloop if */ - } /* end Tloop */ - - /* Successful return */ - return 1; - -} /* end SDIRK_FwdInt */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -int SDIRK_DadjInt( int N, int NADJ, KPP_REAL Lambda[][NVAR], int SaveLU, - int ISTATUS[], int ITOL, KPP_REAL AbsTol_adj[][NVAR], - KPP_REAL RelTol_adj[][NVAR], int NewtonMaxit, - KPP_REAL ThetaMin, KPP_REAL NewtonTol, int DirectADJ) { -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - -/*~~~> Local variables: */ - KPP_REAL Y[NVAR]; - KPP_REAL Z[Smax][NVAR], U[Smax][NADJ][NVAR], TMP[NVAR], G[NVAR], NewtonRate, - SCAL[NVAR], DU[NVAR], T, H, Theta, NewtonPredictedErr, NewtonIncrement, - NewtonIncrementOld=0.0; - int i, j, IER=0, istage, iadj, NewtonIter, IP[NVAR], IP_adj[NVAR]; - int Reject=0, SkipJac, SkipLU, NewtonDone; /* Boolean */ - -#ifdef FULL_ALGEBRA - KPP_REAL E[NVAR][NVAR], Jac[NVAR][NVAR], E_adj[NVAR][NVAR]; -#else - KPP_REAL E[LU_NONZERO], Jac[LU_NONZERO], E_adj[LU_NONZERO]; -#endif - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -~~~> Time loop begins -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - while ( stack_ptr > -1 ) { /* Tloop */ - - /*~~~> Recover checkpoints for stage values and vectors */ - SDIRK_Pop( &T, &H, &Y[0], &Z[0][0], &E[0], &IP[0], SaveLU ); - - /*~~~> Compute E = 1/(h*gamma)-Jac and its LU decomposition */ - if (!SaveLU) { - SkipJac = FALSE; - SkipLU = FALSE; - SDIRK_PrepareMatrix ( H, T, Y, Jac, SkipJac, SkipLU, E, IP, Reject, IER, - ISTATUS ); - if (IER != 0) - return SDIRK_ErrorMsg(-8,T,H); - } - - for( istage = rkS-1; istage >=0; istage--) { /* Stages Loop */ - /*~~~> Jacobian of the current stage solution */ - for(i=0; i Update scaling coefficients */ - for(i=0; i Prepare the loop-independent part of the right-hand side - G(:) = H*Jac^T*( B(i)*Lambda + sum_j A(j,i)*Uj(:) ) */ - for(i=0; i Initializations for Newton iteration */ - Set2Zero(N,&U[istage][iadj][0]); - NewtonDone = FALSE; - - /* Newton Loop */ - for( NewtonIter=0; NewtonIter Prepare the loop-dependent part of the right-hand side */ -#ifdef FULL_ALGEBRA - for(i=0; i Solve the linear system */ - SDIRK_Solve ( 'T', H, N, E, IP, IER, DU, ISTATUS ); - - /*~~~> Check convergence of Newton iterations */ - NewtonIncrement = SDIRK_ErrorNorm(N, DU, SCAL); - if ( NewtonIter == 0 ) { - Theta = ABS(ThetaMin); - NewtonRate = (KPP_REAL)2.0; - } - else { - Theta = NewtonIncrement/NewtonIncrementOld; - if (Theta < (KPP_REAL)0.99) { - NewtonRate = Theta/(ONE-Theta); - /* Predict error at the end of Newton process */ - NewtonPredictedErr = NewtonIncrement* - pow(Theta,(NewtonMaxit-NewtonIter)) / (ONE-Theta); - /* Non-convergence of Newton: predicted error too large */ - if (NewtonPredictedErr >= NewtonTol) - break; /* Exit NewtonLoop */ - } else { /* Non-convergence of Newton: Theta too large */ - break; - } - } - NewtonIncrementOld = NewtonIncrement; - /* Update solution */ - for(i=0; i=4) && NewtonDone) - break; /* Exit Newton Loop */ - } - - /*~~~> If Newton iterations fail employ the direct solution */ - if (!NewtonDone) { - printf("Problems with Newton Adjoint!!!\n"); -#ifdef FULL_ALGEBRA - for(i=0; i End of implified Newton iterations */ - } /* End of DirADJ */ - - } /* End of adj */ - - } /* End of stages */ - - /*~~~> Update adjoint solution - Y(:) <-- Y(:) + Sum_j rkD(j)*Z_j(:) */ - for (istage=0; istage Allocate buffer space for checkpointing -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - int i,j; - - chk_H = (KPP_REAL*) malloc(Max_no_steps * sizeof(KPP_REAL)); - if (chk_H == NULL) { - printf("Failed allocation of buffer H\n"); - exit(0); - } - - chk_T = (KPP_REAL*) malloc(Max_no_steps * sizeof(KPP_REAL)); - if (chk_T == NULL) { - printf("Failed allocation of buffer T\n"); - exit(0); - } - - chk_Y = (KPP_REAL**) malloc(Max_no_steps * sizeof(KPP_REAL*)); - if (chk_Y == NULL) { - printf("Failed allocation of buffer Y\n"); - exit(0); - } - for(i=0; i Deallocate buffer space for discrete adjoint -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - int i,j; - - free(chk_H); - free(chk_T); - - for(i=0; i Saves the next trajectory snapshot for discrete adjoints -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - - int i,j; - - stack_ptr++; - if( stack_ptr > Max_no_steps ) { - printf( "Push failed: buffer overflow"); - exit(0); - } - - chk_H[ stack_ptr ] = H; - chk_T[ stack_ptr ] = T; - for(i=0; i Retrieves the next trajectory snapshot for discrete adjoints -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - - int i,j; - - if ( stack_ptr < 0 ) { - printf( "Pop failed: empty buffer\n" ); - exit(0); - } - - *H = chk_H[ stack_ptr ]; - *T = chk_T[ stack_ptr ]; - for(i=0; i Improper value for maximal no of steps\n"); - break; - case -2: - printf("--> Selected Rosenbrock method not implemented\n"); - break; - case -3: - printf("--> Hmin/Hmax/Hstart must be positive\n"); - break; - case -4: - printf("--> FacMin/FacMax/FacRej must be positive\n"); - break; - case -5: - printf("--> Improper tolerance values\n"); - break; - case -6: - printf("--> No of steps exceeds maximum bound\n"); - break; - case -7: - printf("--> Step size too small T + 10*H = T or H < Roundoff\n"); - break; - case -8: - printf("--> Matrix is repeatedly singular\n"); - break; - default: /* causing an error */ - printf("Unknown Error code: %d\n", code); - } - - printf("\nTime = %f and H = %f\n", T, H ); - return code; - -} /* end SDIRK_ErrorMsg */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void SDIRK_PrepareMatrix ( KPP_REAL H, KPP_REAL T, KPP_REAL Y[], - KPP_REAL FJAC[], int SkipJac, int SkipLU, - KPP_REAL E[], int IP[], int Reject, int ISING, - int ISTATUS[] ) { -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -~~~> Compute the matrix E = 1/(H*GAMMA)*Jac, and its decomposition -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - - KPP_REAL HGammaInv; - int i, j, ConsecutiveSng = 0; - - ISING = 1; - - while (ISING != 0) { - HGammaInv = ONE/(H*rkGamma); - - /*~~~> Compute the Jacobian */ - if (SkipJac==0) { - JAC_CHEM(T,Y,FJAC); - ISTATUS[Njac]++; - } - -#ifdef FULL_ALGEBRA - for(j=0; j= 6) - return; /* Failure */ - H = (KPP_REAL)(0.5)*H; - SkipJac = 0; /* False */ - SkipLU = 0; /* False */ - Reject = 1; /* True */ - } - } -} /* End of SDIRK_PrepareMatrix */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void SDIRK_Solve ( char Transp, KPP_REAL H, int N, KPP_REAL E[], int IP[], - int ISING, KPP_REAL RHS[], int ISTATUS[] ) { -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -~~~> Solves the system (H*Gamma-Jac)*x = R - using the LU decomposition of E = I - 1/(H*Gamma)*Jac -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - - KPP_REAL HGammaInv; - - HGammaInv = ONE/(H*rkGamma); - WSCAL(N,HGammaInv,RHS,1); - switch (Transp) { - case 'N': -#ifdef FULL_ALGEBRA - DGETRS( 'N', N, 1, E, N, IP, RHS, N, ISING ); -#else - KppSolve(E, RHS); -#endif - break; - case 'T': -#ifdef FULL_ALGEBRA - DGETRS( 'T', N, 1, E, N, IP, RHS, N, ISING ); -#else - KppSolveTR(E, RHS, RHS); -#endif - break; - default: - printf("Error in SDIRK_Solve. Unknown Transp argument: %c\n", Transp); - exit(0); - } - ISTATUS[Nsol]++; -} /* End of SDIRK_Solve */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void Sdirk4a() -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -{ - sdMethod = S4A; - -/* Number of stages */ - rkS = 5; - -/* Method Coefficients */ - rkGamma = (KPP_REAL)0.2666666666666666666666666666666667; - - rkA[0][0] = (KPP_REAL)0.2666666666666666666666666666666667; - rkA[0][1] = (KPP_REAL)0.5000000000000000000000000000000000; - rkA[1][1] = (KPP_REAL)0.2666666666666666666666666666666667; - rkA[0][2] = (KPP_REAL)0.3541539528432732316227461858529820; - rkA[1][2] = (KPP_REAL)(-0.5415395284327323162274618585298197e-01); - rkA[2][2] = (KPP_REAL)0.2666666666666666666666666666666667; - rkA[0][3] = (KPP_REAL)0.8515494131138652076337791881433756e-01; - rkA[1][3] = (KPP_REAL)(-0.6484332287891555171683963466229754e-01); - rkA[2][3] = (KPP_REAL)0.7915325296404206392428857585141242e-01; - rkA[3][3] = (KPP_REAL)0.2666666666666666666666666666666667; - rkA[0][4] = (KPP_REAL)2.100115700566932777970612055999074; - rkA[1][4] = (KPP_REAL)(-0.7677800284445976813343102185062276); - rkA[2][4] = (KPP_REAL)2.399816361080026398094746205273880; - rkA[3][4] = (KPP_REAL)(-2.998818699869028161397714709433394); - rkA[4][4] = (KPP_REAL)0.2666666666666666666666666666666667; - rkB[0] = (KPP_REAL)2.100115700566932777970612055999074; - rkB[1] = (KPP_REAL)(-0.7677800284445976813343102185062276); - rkB[2] = (KPP_REAL)2.399816361080026398094746205273880; - rkB[3] = (KPP_REAL)(-2.998818699869028161397714709433394); - rkB[4] = (KPP_REAL)0.2666666666666666666666666666666667; - - rkBhat[0] = (KPP_REAL)2.885264204387193942183851612883390; - rkBhat[1] = (KPP_REAL)(-0.1458793482962771337341223443218041); - rkBhat[2] = (KPP_REAL)2.390008682465139866479830743628554; - rkBhat[3] = (KPP_REAL)(-4.129393538556056674929560012190140); - rkBhat[4] = ZERO; - - rkC[0] = (KPP_REAL)0.2666666666666666666666666666666667; - rkC[1] = (KPP_REAL)0.7666666666666666666666666666666667; - rkC[2] = (KPP_REAL)0.5666666666666666666666666666666667; - rkC[3] = (KPP_REAL)0.3661315380631796996374935266701191; - rkC[4] = ONE; - -/* Ynew = Yold + h*Sum_i {rkB_i*k_i} = Yold + Sum_i {rkD_i*Z_i} */ - rkD[0] = ZERO; - rkD[1] = ZERO; - rkD[2] = ZERO; - rkD[3] = ZERO; - rkD[4] = ONE; - -/* Err = h * Sum_i {(rkB_i-rkBhat_i)*k_i} = Sum_i {rkE_i*Z_i} */ - rkE[0] = (KPP_REAL)(-0.6804000050475287124787034884002302); - rkE[1] = (KPP_REAL)(1.558961944525217193393931795738823); - rkE[2] = (KPP_REAL)(-13.55893003128907927748632408763868); - rkE[3] = (KPP_REAL)(15.48522576958521253098585004571302); - rkE[4] = ONE; - -/* Local order of Err estimate */ - rkELO = 4; - -/* h*Sum_j {rkA_ij*k_j} = Sum_j {rkTheta_ij*Z_j} */ - rkTheta[0][1] = (KPP_REAL)1.875000000000000000000000000000000; - rkTheta[0][2] = (KPP_REAL)1.708847304091539528432732316227462; - rkTheta[1][2] = (KPP_REAL)(-0.2030773231622746185852981969486824); - rkTheta[0][3] = (KPP_REAL)0.2680325578937783958847157206823118; - rkTheta[1][3] = (KPP_REAL)(-0.1828840955527181631794050728644549); - rkTheta[2][3] = (KPP_REAL)0.2968246986151577397160821594427966; - rkTheta[0][4] = (KPP_REAL)0.9096171815241460655379433581446771; - rkTheta[1][4] = (KPP_REAL)(-3.108254967778352416114774430509465); - rkTheta[2][4] = (KPP_REAL)12.33727431701306195581826123274001; - rkTheta[3][4] = (KPP_REAL)(-11.24557012450885560524143016037523); - -/* Starting value for Newton iterations: Z_i^0 = Sum_j {rkAlpha_ij*Z_j} */ - rkAlpha[0][1] = (KPP_REAL)2.875000000000000000000000000000000; - rkAlpha[0][2] = (KPP_REAL)0.8500000000000000000000000000000000; - rkAlpha[1][2] = (KPP_REAL)0.4434782608695652173913043478260870; - rkAlpha[0][3] = (KPP_REAL)0.7352046091658870564637910527807370; - rkAlpha[1][3] = (KPP_REAL)(-0.9525565003057343527941920657462074e-01); - rkAlpha[2][3] = (KPP_REAL)0.4290111305453813852259481840631738; - rkAlpha[0][4] = (KPP_REAL)(-16.10898993405067684831655675112808); - rkAlpha[1][4] = (KPP_REAL)6.559571569643355712998131800797873; - rkAlpha[2][4] = (KPP_REAL)(-15.90772144271326504260996815012482); - rkAlpha[3][4] = (KPP_REAL)25.34908987169226073668861694892683; - - rkELO = (KPP_REAL)4.0; - -} /* end Sdirk4a */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void Sdirk4b() { -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - - sdMethod = S4B; - -/* Number of stages */ - rkS = 5; - -/* Method coefficients */ - rkGamma = (KPP_REAL)0.25; - - rkA[0][0] = (KPP_REAL)0.25; - rkA[0][1] = (KPP_REAL)0.5; - rkA[1][1] = (KPP_REAL)0.25; - rkA[0][2] = (KPP_REAL)0.34; - rkA[1][2] = (KPP_REAL)(-0.40e-01); - rkA[2][2] = (KPP_REAL)0.25; - rkA[0][3] = (KPP_REAL)0.2727941176470588235294117647058824; - rkA[1][3] = (KPP_REAL)(-0.5036764705882352941176470588235294e-01); - rkA[2][3] = (KPP_REAL)0.2757352941176470588235294117647059e-01; - rkA[3][3] = (KPP_REAL)0.25; - rkA[0][4] = (KPP_REAL)1.041666666666666666666666666666667; - rkA[1][4] = (KPP_REAL)(-1.020833333333333333333333333333333); - rkA[2][4] = (KPP_REAL)7.812500000000000000000000000000000; - rkA[3][4] = (KPP_REAL)(-7.083333333333333333333333333333333); - rkA[4][4] = (KPP_REAL)0.25; - - rkB[0] = (KPP_REAL)1.041666666666666666666666666666667; - rkB[1] = (KPP_REAL)(-1.020833333333333333333333333333333); - rkB[2] = (KPP_REAL)7.812500000000000000000000000000000; - rkB[3] = (KPP_REAL)(-7.083333333333333333333333333333333); - rkB[4] = (KPP_REAL)0.250000000000000000000000000000000; - - rkBhat[0] = (KPP_REAL)1.069791666666666666666666666666667; - rkBhat[1] = (KPP_REAL)(-0.894270833333333333333333333333333); - rkBhat[2] = (KPP_REAL)7.695312500000000000000000000000000; - rkBhat[3] = (KPP_REAL)(-7.083333333333333333333333333333333); - rkBhat[4] = (KPP_REAL)0.212500000000000000000000000000000; - - rkC[0] = (KPP_REAL)0.25; - rkC[1] = (KPP_REAL)0.75; - rkC[2] = (KPP_REAL)0.55; - rkC[3] = (KPP_REAL)0.5; - rkC[4] = ONE; - -/* Ynew = Yold + h*Sum_i {rkB_i*k_i} = Yold + Sum_i {rkD_i*Z_i} */ - rkD[0] = ZERO; - rkD[1] = ZERO; - rkD[2] = ZERO; - rkD[3] = ZERO; - rkD[4] = ONE; - -/* Err = h * Sum_i {(rkB_i-rkBhat_i)*k_i} = Sum_i {rkE_i*Z_i} */ - rkE[0] = (KPP_REAL)0.5750; - rkE[1] = (KPP_REAL)0.2125; - rkE[2] = (KPP_REAL)(-4.6875); - rkE[3] = (KPP_REAL)4.2500; - rkE[4] = (KPP_REAL)0.1500; - -/* Local order of Err estimate */ - rkELO = 4; - -/* h*Sum_j {rkA_ij*k_j} = Sum_j {rkTheta_ij*Z_j} */ - rkTheta[0][1] = (KPP_REAL)2.0; - rkTheta[0][2] = (KPP_REAL)1.680000000000000000000000000000000; - rkTheta[1][2] = (KPP_REAL)(-0.1600000000000000000000000000000000); - rkTheta[0][3] = (KPP_REAL)1.308823529411764705882352941176471; - rkTheta[1][3] = (KPP_REAL)(-0.1838235294117647058823529411764706); - rkTheta[2][3] = (KPP_REAL)0.1102941176470588235294117647058824; - rkTheta[0][4] = (KPP_REAL)(-3.083333333333333333333333333333333); - rkTheta[1][4] = (KPP_REAL)(-4.291666666666666666666666666666667); - rkTheta[2][4] = (KPP_REAL)34.37500000000000000000000000000000; - rkTheta[3][4] = (KPP_REAL)(-28.3333333333333333333333333333); - -/* Starting value for Newton iterations: Z_i^0 = Sum_j {rkAlpha_ij*Z_j} */ - rkAlpha[0][1] = (KPP_REAL)3.0; - rkAlpha[0][2] = (KPP_REAL)0.8800000000000000000000000000000000; - rkAlpha[1][2] = (KPP_REAL)0.4400000000000000000000000000000000; - rkAlpha[0][3] = (KPP_REAL)0.1666666666666666666666666666666667; - rkAlpha[1][3] = (KPP_REAL)(-0.8333333333333333333333333333333333e-01); - rkAlpha[2][3] = (KPP_REAL)0.9469696969696969696969696969696970; - rkAlpha[0][4] = (KPP_REAL)(-6.0); - rkAlpha[1][4] = (KPP_REAL)9.0; - rkAlpha[2][4] = (KPP_REAL)(-56.81818181818181818181818181818182); - rkAlpha[3][4] = (KPP_REAL)54.0; - -} /* end Sdirk4b */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void Sdirk2a() { -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - - sdMethod = S2A; - -/* ~~~> Number of stages */ - rkS = 2; - -/* ~~~> Method coefficients */ - rkGamma = (KPP_REAL)0.2928932188134524755991556378951510; - rkA[0][0] = (KPP_REAL)0.2928932188134524755991556378951510; - rkA[0][1] = (KPP_REAL)0.7071067811865475244008443621048490; - rkA[1][1] = (KPP_REAL)0.2928932188134524755991556378951510; - rkB[0] = (KPP_REAL)0.7071067811865475244008443621048490; - rkB[1] = (KPP_REAL)0.2928932188134524755991556378951510; - rkBhat[0] = (KPP_REAL)0.6666666666666666666666666666666667; - rkBhat[1] = (KPP_REAL)0.3333333333333333333333333333333333; - rkC[0] = (KPP_REAL)0.292893218813452475599155637895151; - rkC[1] = ONE; - -/* ~~~> Ynew = Yold + h*Sum_i {rkB_i*k_i} = Yold + Sum_i {rkD_i*Z_i} */ - rkD[0] = ZERO; - rkD[1] = ONE; - -/* ~~~> Err = h * Sum_i {(rkB_i-rkBhat_i)*k_i} = Sum_i {rkE_i*Z_i} */ - rkE[0] = (KPP_REAL)0.4714045207910316829338962414032326; - rkE[1] = (KPP_REAL)(-0.1380711874576983496005629080698993); - -/* ~~~> Local order of Err estimate */ - rkELO = 2; - -/* ~~~> h*Sum_j {rkA_ij*k_j} = Sum_j {rkTheta_ij*Z_j} */ - rkTheta[0][1] = (KPP_REAL)2.414213562373095048801688724209698; - -/* ~~~> Starting value for Newton iterations */ - rkAlpha[0][1] = (KPP_REAL)3.414213562373095048801688724209698; - -} /* end Sdirk2a */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void Sdirk2b() { -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - - sdMethod = S2B; - -/* ~~~> Number of stages */ - rkS = 2; - -/* ~~~> Method coefficients */ - rkGamma = (KPP_REAL)1.707106781186547524400844362104849; - rkA[0][0] = (KPP_REAL)1.707106781186547524400844362104849; - rkA[0][1] = (KPP_REAL)(-0.707106781186547524400844362104849); - rkA[1][1] = (KPP_REAL)1.707106781186547524400844362104849; - rkB[0] = (KPP_REAL)(-0.707106781186547524400844362104849); - rkB[1] = (KPP_REAL)1.707106781186547524400844362104849; - rkBhat[0] = (KPP_REAL)0.6666666666666666666666666666666667; - rkBhat[1] = (KPP_REAL)0.3333333333333333333333333333333333; - rkC[0] = (KPP_REAL)1.707106781186547524400844362104849; - rkC[1] = ONE; - -/* ~~~> Ynew = Yold + h*Sum_i {rkB_i*k_i} = Yold + Sum_i {rkD_i*Z_i} */ - rkD[0] = ZERO; - rkD[1] = ONE; - -/* ~~~> Err = h * Sum_i {(rkB_i-rkBhat_i)*k_i} = Sum_i {rkE_i*Z_i} */ - rkE[0] = (KPP_REAL)(-0.4714045207910316829338962414032326); - rkE[1] = (KPP_REAL)0.8047378541243650162672295747365659; - -/* ~~~> Local order of Err estimate */ - rkELO = 2; - -/* ~~~> h*Sum_j {rkA_ij*k_j} = Sum_j {rkTheta_ij*Z_j} */ - rkTheta[0][1] = (KPP_REAL)(-0.414213562373095048801688724209698); - -/* ~~~> Starting value for Newton iterations */ - rkAlpha[0][1] = (KPP_REAL)0.5857864376269049511983112757903019; - -} /* end Sdirk2b */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void Sdirk3a() { -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - - sdMethod = S3A; - -/* ~~~> Number of stages */ - rkS = 3; - -/* ~~~> Method coefficients */ - rkGamma = (KPP_REAL)0.2113248654051871177454256097490213; - rkA[0][0] = (KPP_REAL)0.2113248654051871177454256097490213; - rkA[0][1] = (KPP_REAL)0.2113248654051871177454256097490213; - rkA[1][1] = (KPP_REAL)0.2113248654051871177454256097490213; - rkA[0][2] = (KPP_REAL)0.2113248654051871177454256097490213; - rkA[1][2] = (KPP_REAL)0.5773502691896257645091487805019573; - rkA[2][2] = (KPP_REAL)0.2113248654051871177454256097490213; - rkB[0] = (KPP_REAL)0.2113248654051871177454256097490213; - rkB[1] = (KPP_REAL)0.5773502691896257645091487805019573; - rkB[2] = (KPP_REAL)0.2113248654051871177454256097490213; - rkBhat[0]= (KPP_REAL)0.2113248654051871177454256097490213; - rkBhat[1]= (KPP_REAL)0.6477918909913548037576239837516312; - rkBhat[2]= (KPP_REAL)0.1408832436034580784969504064993475; - rkC[0] = (KPP_REAL)0.2113248654051871177454256097490213; - rkC[1] = (KPP_REAL)0.4226497308103742354908512194980427; - rkC[2] = ONE; - -/* ~~~> Ynew = Yold + h*Sum_i {rkB_i*k_i} = Yold + Sum_i {rkD_i*Z_i} */ - rkD[0] = ZERO; - rkD[1] = ZERO; - rkD[2] = ONE; - -/* ~~~> Err = h * Sum_i {(rkB_i-rkBhat_i)*k_i} = Sum_i {rkE_i*Z_i} */ - rkE[0] = (KPP_REAL)0.9106836025229590978424821138352906; - rkE[1] = (KPP_REAL)(-1.244016935856292431175815447168624); - rkE[2] = (KPP_REAL)0.3333333333333333333333333333333333; - -/* ~~~> Local order of Err estimate */ - rkELO = 2; - -/* ~~~> h*Sum_j {rkA_ij*k_j} = Sum_j {rkTheta_ij*Z_j} */ - rkTheta[0][1] = ONE; - rkTheta[0][2] = (KPP_REAL)(-1.732050807568877293527446341505872); - rkTheta[1][2] = (KPP_REAL)2.732050807568877293527446341505872; - -/* ~~~> Starting value for Newton iterations */ - rkAlpha[0][1] = (KPP_REAL)2.0; - rkAlpha[0][2] = (KPP_REAL)(-12.92820323027550917410978536602349); - rkAlpha[1][2] = (KPP_REAL)8.83012701892219323381861585376468; - -} /* end Sdirk3a */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void FUN_CHEM(KPP_REAL T, KPP_REAL Y[], KPP_REAL P[]) -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -{ - - KPP_REAL Told; - - Told = TIME; - TIME = T; - Update_SUN(); - Update_RCONST(); - Fun( Y, FIX, RCONST, P ); - TIME = Told; - -} /* end FUN_CHEM */ - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void JAC_CHEM(KPP_REAL T, KPP_REAL Y[], KPP_REAL JV[]) { -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ - - KPP_REAL Told; - -#ifdef FULL_ALGEBRA - KPP_REAL JS[LU_NONZERO]; - int i,j; -#endif - - Told = TIME; - TIME = T; - Update_SUN(); - Update_RCONST(); - -#ifdef FULL_ALGEBRA - Jac_SP( Y, FIX, RCONST, JS); - - for(j=0; j Statistics on the work performed by the SDIRK method - INTEGER, PARAMETER :: Nfun=1, Njac=2, Nstp=3, Nacc=4, & - Nrej=5, Ndec=6, Nsol=7, Nsng=8, & - Ntexit=1, Nhexit=2, Nhnew=3 - -CONTAINS - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -SUBROUTINE INTEGRATE_TLM( NTLM, Y, Y_tlm, TIN, TOUT, ATOL_tlm,RTOL_tlm, & - ICNTRL_U, RCNTRL_U, ISTATUS_U, RSTATUS_U, IERR_U ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - USE KPP_ROOT_Parameters, ONLY: NVAR,ind_O3 - USE KPP_ROOT_Global, ONLY: ATOL,RTOL,VAR - - IMPLICIT NONE - -!~~~> Y - Concentrations - KPP_REAL :: Y(NVAR) -!~~~> NTLM - No. of sensitivity coefficients - INTEGER NTLM -!~~~> Y_tlm - Sensitivities of concentrations -! Note: Y_tlm (1:NVAR,j) contains sensitivities of -! Y(1:NVAR) w.r.t. the j-th parameter, j=1...NTLM - KPP_REAL :: Y_tlm(NVAR,NTLM) - KPP_REAL :: TIN ! TIN - Start Time - KPP_REAL :: TOUT ! TOUT - End Time - KPP_REAL, INTENT(IN), OPTIONAL :: RTOL_tlm(NVAR,NTLM),ATOL_tlm(NVAR,NTLM) - INTEGER, INTENT(IN), OPTIONAL :: ICNTRL_U(20) - KPP_REAL, INTENT(IN), OPTIONAL :: RCNTRL_U(20) - INTEGER, INTENT(OUT), OPTIONAL :: ISTATUS_U(20) - KPP_REAL, INTENT(OUT), OPTIONAL :: RSTATUS_U(20) - INTEGER, INTENT(OUT), OPTIONAL :: IERR_U - - INTEGER :: IERR - - KPP_REAL :: RCNTRL(20), RSTATUS(20), T1, T2 - INTEGER :: ICNTRL(20), ISTATUS(20) - INTEGER, SAVE :: Ntotal = 0 - - ICNTRL(1:20) = 0 - RCNTRL(1:20) = 0.0_dp - - !~~~> fine-tune the integrator: - ICNTRL(2) = 0 ! 0=vector tolerances, 1=scalar tolerances - ICNTRL(5) = 8 ! Max no. of Newton iterations - ICNTRL(6) = 0 ! Starting values for Newton are interpolated (0) or zero (1) - ICNTRL(7) = 0 ! How to solve TLM: 0=modified Newton, 1=direct - ICNTRL(9) = 0 ! TLM Newton Iterations influence - ICNTRL(12) = 0 ! TLM Truncation Error influence - - !~~~> if optional parameters are given, and if they are >0, - ! then use them to overwrite default settings - IF (PRESENT(ICNTRL_U)) THEN - WHERE(ICNTRL_U(:) > 0) ICNTRL(:) = ICNTRL_U(:) - END IF - IF (PRESENT(RCNTRL_U)) THEN - WHERE(RCNTRL_U(:) > 0) RCNTRL(:) = RCNTRL_U(:) - END IF - - - T1 = TIN; T2 = TOUT - CALL SdirkTLM( NVAR, NTLM, T1, T2, Y, Y_tlm, RTOL, ATOL, & - RTOL_tlm, ATOL_tlm, RCNTRL,ICNTRL,RSTATUS,ISTATUS,IERR ) - - !~~~> Debug option: print number of steps - ! Ntotal = Ntotal + ISTATUS(Nstp) - ! PRINT*,'NSTEPS=',ISTATUS(Nstp),' (',Ntotal,')',' O3=', VAR(ind_O3) - - ! if optional parameters are given for output - ! use them to store information in them - IF (PRESENT(ISTATUS_U)) ISTATUS_U(:) = ISTATUS(:) - IF (PRESENT(RSTATUS_U)) RSTATUS_U(:) = RSTATUS(:) - IF (PRESENT(IERR_U)) IERR_U = IERR - - IF (IERR < 0) THEN - PRINT *,'SDIRK-TLM: Unsuccessful exit at T=', TIN,' (IERR=',IERR,')' - ENDIF - - END SUBROUTINE INTEGRATE_TLM - - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SdirkTLM(N, NTLM, Tinitial, Tfinal, Y, Y_tlm, RelTol, AbsTol, & - RelTol_tlm, AbsTol_tlm, & - RCNTRL, ICNTRL, RSTATUS, ISTATUS, Ierr) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -! Solves the system y'=F(t,y) using a Singly-Diagonally-Implicit -! Runge-Kutta (SDIRK) method. -! -! This implementation is based on the book and the code Sdirk4: -! -! E. Hairer and G. Wanner -! "Solving ODEs II. Stiff and differential-algebraic problems". -! Springer series in computational mathematics, Springer-Verlag, 1996. -! This code is based on the SDIRK4 routine in the above book. -! -! Methods: -! * Sdirk 2a, 2b: L-stable, 2 stages, order 2 -! * Sdirk 3a: L-stable, 3 stages, order 2, adjoint-invariant -! * Sdirk 4a, 4b: L-stable, 5 stages, order 4 -! -! (C) Adrian Sandu, July 2005 -! Virginia Polytechnic Institute and State University -! Contact: sandu@cs.vt.edu -! Revised by Philipp Miehe and Adrian Sandu, May 2006 -! This implementation is part of KPP - the Kinetic PreProcessor -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!~~~> INPUT ARGUMENTS: -! -!- Y(NVAR) = vector of initial conditions (at T=Tinitial) -!- [Tinitial,Tfinal] = time range of integration -! (if Tinitial>Tfinal the integration is performed backwards in time) -!- RelTol, AbsTol = user precribed accuracy -!- SUBROUTINE ode_Fun( T, Y, Ydot ) = ODE function, -! returns Ydot = Y' = F(T,Y) -!- SUBROUTINE ode_Fun( T, Y, Ydot ) = Jacobian of the ODE function, -! returns Jcb = dF/dY -!- ICNTRL(1:20) = integer inputs parameters -!- RCNTRL(1:20) = real inputs parameters -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!~~~> OUTPUT ARGUMENTS: -! -!- Y(NVAR) -> vector of final states (at T->Tfinal) -!- ISTATUS(1:20) -> integer output parameters -!- RSTATUS(1:20) -> real output parameters -!- Ierr -> job status upon return -! success (positive value) or -! failure (negative value) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!~~~> INPUT PARAMETERS: -! -! Note: For input parameters equal to zero the default values of the -! corresponding variables are used. -! -! Note: For input parameters equal to zero the default values of the -! corresponding variables are used. -!~~~> -! ICNTRL(1) = not used -! -! ICNTRL(2) = 0: AbsTol, RelTol are NVAR-dimensional vectors -! = 1: AbsTol, RelTol are scalars -! -! ICNTRL(3) = Method -! -! ICNTRL(4) -> maximum number of integration steps -! For ICNTRL(4)=0 the default value of 100000 is used -! -! ICNTRL(5) -> maximum number of Newton iterations -! For ICNTRL(5)=0 the default value of 8 is used -! -! ICNTRL(6) -> starting values of Newton iterations: -! ICNTRL(6)=0 : starting values are interpolated (the default) -! ICNTRL(6)=1 : starting values are zero -! -! ICNTRL(7) -> method to solve TLM equations: -! ICNTRL(7)=0 : modified Newton re-using LU (the default) -! ICNTRL(7)=1 : direct solution (additional one LU factorization per stage) -! -! ICNTRL(9) -> switch for TLM Newton iteration error estimation strategy -! ICNTRL(9) = 0: base number of iterations as forward solution -! ICNTRL(9) = 1: use RTOL_tlm and ATOL_tlm to calculate -! error estimation for TLM at Newton stages -! -! ICNTRL(12) -> switch for TLM truncation error control -! ICNTRL(12) = 0: TLM error is not used -! ICNTRL(12) = 1: TLM error is computed and used -! -! -!~~~> Real parameters -! -! RCNTRL(1) -> Hmin, lower bound for the integration step size -! It is strongly recommended to keep Hmin = ZERO -! RCNTRL(2) -> Hmax, upper bound for the integration step size -! RCNTRL(3) -> Hstart, starting value for the integration step size -! -! RCNTRL(4) -> FacMin, lower bound on step decrease factor (default=0.2) -! RCNTRL(5) -> FacMax, upper bound on step increase factor (default=6) -! RCNTRL(6) -> FacRej, step decrease factor after multiple rejections -! (default=0.1) -! RCNTRL(7) -> FacSafe, by which the new step is slightly smaller -! than the predicted value (default=0.9) -! RCNTRL(8) -> ThetaMin. If Newton convergence rate smaller -! than ThetaMin the Jacobian is not recomputed; -! (default=0.001) -! RCNTRL(9) -> NewtonTol, stopping criterion for Newton's method -! (default=0.03) -! RCNTRL(10) -> Qmin -! RCNTRL(11) -> Qmax. If Qmin < Hnew/Hold < Qmax, then the -! step size is kept constant and the LU factorization -! reused (default Qmin=1, Qmax=1.2) -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -!~~~> OUTPUT PARAMETERS: -! -! Note: each call to Rosenbrock adds the current no. of fcn calls -! to previous value of ISTATUS(1), and similar for the other params. -! Set ISTATUS(1:10) = 0 before call to avoid this accumulation. -! -! ISTATUS(1) = No. of function calls -! ISTATUS(2) = No. of jacobian calls -! ISTATUS(3) = No. of steps -! ISTATUS(4) = No. of accepted steps -! ISTATUS(5) = No. of rejected steps (except at the beginning) -! ISTATUS(6) = No. of LU decompositions -! ISTATUS(7) = No. of forward/backward substitutions -! ISTATUS(8) = No. of singular matrix decompositions -! -! RSTATUS(1) -> Texit, the time corresponding to the -! computed Y upon return -! RSTATUS(2) -> Hexit,last accepted step before return -! RSTATUS(3) -> Hnew, last predicted step before return -! For multiple restarts, use Hnew as Hstart in the following run -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - -! Arguments - INTEGER, INTENT(IN) :: N, NTLM, ICNTRL(20) - KPP_REAL, INTENT(IN) :: Tinitial, Tfinal, & - RelTol(N), AbsTol(N), RCNTRL(20), & - RelTol_tlm(N,NTLM), AbsTol_tlm(N,NTLM) - KPP_REAL, INTENT(INOUT) :: Y(NVAR), Y_tlm(N,NTLM) - INTEGER, INTENT(OUT) :: Ierr - INTEGER, INTENT(INOUT) :: ISTATUS(20) - KPP_REAL, INTENT(OUT) :: RSTATUS(20) - -!~~~> SDIRK method coefficients, up to 5 stages - INTEGER, PARAMETER :: Smax = 5 - INTEGER, PARAMETER :: S2A=1, S2B=2, S3A=3, S4A=4, S4B=5 - KPP_REAL :: rkGamma, rkA(Smax,Smax), rkB(Smax), rkC(Smax), & - rkD(Smax), rkE(Smax), rkBhat(Smax), rkELO, & - rkAlpha(Smax,Smax), rkTheta(Smax,Smax) - INTEGER :: sdMethod, rkS ! The number of stages - -! Local variables - KPP_REAL :: Hmin, Hmax, Hstart, Roundoff, & - FacMin, Facmax, FacSafe, FacRej, & - ThetaMin, NewtonTol, Qmin, Qmax - INTEGER :: ITOL, NewtonMaxit, Max_no_steps, i - LOGICAL :: StartNewton, DirectTLM, TLMNewtonEst, TLMtruncErr - KPP_REAL, PARAMETER :: ZERO = 0.0d0, ONE = 1.0d0 - - - Ierr = 0 - ISTATUS(1:20) = 0 - RSTATUS(1:20) = ZERO - -!~~~> For Scalar tolerances (ICNTRL(2).NE.0) the code uses AbsTol(1) and RelTol(1) -! For Vector tolerances (ICNTRL(2) == 0) the code uses AbsTol(1:NVAR) and RelTol(1:NVAR) - IF (ICNTRL(2) == 0) THEN - ITOL = 1 - ELSE - ITOL = 0 - END IF - -!~~~> ICNTRL(3) - method selection - SELECT CASE (ICNTRL(3)) - CASE (0,1) - CALL Sdirk2a - CASE (2) - CALL Sdirk2b - CASE (3) - CALL Sdirk3a - CASE (4) - CALL Sdirk4a - CASE (5) - CALL Sdirk4b - CASE DEFAULT - CALL Sdirk2a - END SELECT - -!~~~> The maximum number of time steps admitted - IF (ICNTRL(4) == 0) THEN - Max_no_steps = 200000 - ELSEIF (ICNTRL(4) > 0) THEN - Max_no_steps=ICNTRL(4) - ELSE - PRINT * ,'User-selected ICNTRL(4)=',ICNTRL(4) - CALL SDIRK_ErrorMsg(-1,Tinitial,ZERO,Ierr) - END IF - !~~~> The maximum number of Newton iterations admitted - IF(ICNTRL(5) == 0)THEN - NewtonMaxit=8 - ELSE - NewtonMaxit=ICNTRL(5) - IF(NewtonMaxit <= 0)THEN - PRINT * ,'User-selected ICNTRL(5)=',ICNTRL(5) - CALL SDIRK_ErrorMsg(-2,Tinitial,ZERO,Ierr) - END IF - END IF -!~~~> StartNewton: Use extrapolation for starting values of Newton iterations - IF (ICNTRL(6) == 0) THEN - StartNewton = .TRUE. - ELSE - StartNewton = .FALSE. - END IF -!~~~> Solve TLM equations directly or by Newton iterations - DirectTLM = (ICNTRL(7) == 1) -!~~~> Newton iteration error control selection - IF (ICNTRL(9) == 0) THEN - TLMNewtonEst = .FALSE. - ELSE - TLMNewtonEst = .TRUE. - END IF -!~~~> TLM truncation error control selection - IF (ICNTRL(12) == 0) THEN - TLMtruncErr = .FALSE. - ELSE - TLMtruncErr = .TRUE. - END IF - -!~~~> Unit roundoff (1+Roundoff>1) - Roundoff = WLAMCH('E') - -!~~~> Lower bound on the step size: (positive value) - IF (RCNTRL(1) == ZERO) THEN - Hmin = ZERO - ELSEIF (RCNTRL(1) > ZERO) THEN - Hmin = RCNTRL(1) - ELSE - PRINT * , 'User-selected RCNTRL(1)=', RCNTRL(1) - CALL SDIRK_ErrorMsg(-3,Tinitial,ZERO,Ierr) - END IF - -!~~~> Upper bound on the step size: (positive value) - IF (RCNTRL(2) == ZERO) THEN - Hmax = ABS(Tfinal-Tinitial) - ELSEIF (RCNTRL(2) > ZERO) THEN - Hmax = MIN(ABS(RCNTRL(2)),ABS(Tfinal-Tinitial)) - ELSE - PRINT * , 'User-selected RCNTRL(2)=', RCNTRL(2) - CALL SDIRK_ErrorMsg(-3,Tinitial,ZERO,Ierr) - END IF - -!~~~> Starting step size: (positive value) - IF (RCNTRL(3) == ZERO) THEN - Hstart = MAX(Hmin,Roundoff) - ELSEIF (RCNTRL(3) > ZERO) THEN - Hstart = MIN(ABS(RCNTRL(3)),ABS(Tfinal-Tinitial)) - ELSE - PRINT * , 'User-selected Hstart: RCNTRL(3)=', RCNTRL(3) - CALL SDIRK_ErrorMsg(-3,Tinitial,ZERO,Ierr) - END IF - -!~~~> Step size can be changed s.t. FacMin < Hnew/Hexit < FacMax - IF (RCNTRL(4) == ZERO) THEN - FacMin = 0.2_dp - ELSEIF (RCNTRL(4) > ZERO) THEN - FacMin = RCNTRL(4) - ELSE - PRINT * , 'User-selected FacMin: RCNTRL(4)=', RCNTRL(4) - CALL SDIRK_ErrorMsg(-4,Tinitial,ZERO,Ierr) - END IF - IF (RCNTRL(5) == ZERO) THEN - FacMax = 10.0_dp - ELSEIF (RCNTRL(5) > ZERO) THEN - FacMax = RCNTRL(5) - ELSE - PRINT * , 'User-selected FacMax: RCNTRL(5)=', RCNTRL(5) - CALL SDIRK_ErrorMsg(-4,Tinitial,ZERO,Ierr) - END IF -!~~~> FacRej: Factor to decrease step after 2 succesive rejections - IF (RCNTRL(6) == ZERO) THEN - FacRej = 0.1_dp - ELSEIF (RCNTRL(6) > ZERO) THEN - FacRej = RCNTRL(6) - ELSE - PRINT * , 'User-selected FacRej: RCNTRL(6)=', RCNTRL(6) - CALL SDIRK_ErrorMsg(-4,Tinitial,ZERO,Ierr) - END IF -!~~~> FacSafe: Safety Factor in the computation of new step size - IF (RCNTRL(7) == ZERO) THEN - FacSafe = 0.9_dp - ELSEIF (RCNTRL(7) > ZERO) THEN - FacSafe = RCNTRL(7) - ELSE - PRINT * , 'User-selected FacSafe: RCNTRL(7)=', RCNTRL(7) - CALL SDIRK_ErrorMsg(-4,Tinitial,ZERO,Ierr) - END IF - -!~~~> ThetaMin: decides whether the Jacobian should be recomputed - IF(RCNTRL(8) == 0.D0)THEN - ThetaMin = 1.0d-3 - ELSE - ThetaMin = RCNTRL(8) - END IF - -!~~~> Stopping criterion for Newton's method - IF(RCNTRL(9) == ZERO)THEN - NewtonTol = 3.0d-2 - ELSE - NewtonTol = RCNTRL(9) - END IF - -!~~~> Qmin, Qmax: IF Qmin < Hnew/Hold < Qmax, STEP SIZE = CONST. - IF(RCNTRL(10) == ZERO)THEN - Qmin=ONE - ELSE - Qmin=RCNTRL(10) - END IF - IF(RCNTRL(11) == ZERO)THEN - Qmax=1.2D0 - ELSE - Qmax=RCNTRL(11) - END IF - -!~~~> Check if tolerances are reasonable - IF (ITOL == 0) THEN - IF (AbsTol(1) <= ZERO .OR. RelTol(1) <= 10.D0*Roundoff) THEN - PRINT * , ' Scalar AbsTol = ',AbsTol(1) - PRINT * , ' Scalar RelTol = ',RelTol(1) - CALL SDIRK_ErrorMsg(-5,Tinitial,ZERO,Ierr) - END IF - ELSE - DO i=1,N - IF (AbsTol(i) <= 0.D0.OR.RelTol(i) <= 10.D0*Roundoff) THEN - PRINT * , ' AbsTol(',i,') = ',AbsTol(i) - PRINT * , ' RelTol(',i,') = ',RelTol(i) - CALL SDIRK_ErrorMsg(-5,Tinitial,ZERO,Ierr) - END IF - END DO - END IF - - IF (Ierr < 0) RETURN - - CALL SDIRK_IntegratorTLM( N,NTLM,Tinitial,Tfinal,Y,Y_tlm,Ierr ) - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - CONTAINS ! PROCEDURES INTERNAL TO SDIRK -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SDIRK_IntegratorTLM( N,NTLM,Tinitial,Tfinal,Y,Y_tlm,Ierr ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - USE KPP_ROOT_Parameters - IMPLICIT NONE - -!~~~> Arguments: - INTEGER, INTENT(IN) :: N, NTLM - KPP_REAL, INTENT(INOUT) :: Y(N), Y_tlm(N,NTLM) - KPP_REAL, INTENT(IN) :: Tinitial, Tfinal - INTEGER, INTENT(OUT) :: Ierr - -!~~~> Local variables: - KPP_REAL :: Z(NVAR,rkS), G(NVAR), TMP(NVAR), & - NewtonRate, SCAL(NVAR), DZ(NVAR), & - T, H, Theta, Hratio, NewtonPredictedErr, & - Qnewton, Err, Fac, Hnew, Tdirection, & - NewtonIncrement, NewtonIncrementOld, & - SCAL_tlm(NVAR), Yerr(N), Yerr_tlm(N,NTLM), ThetaTLM - KPP_REAL :: Z_tlm(NVAR,rkS,NTLM) - INTEGER :: itlm, j, IER, istage, NewtonIter, saveNiter, NewtonIterTLM - INTEGER :: IP(NVAR), IP_tlm(NVAR) - LOGICAL :: Reject, FirstStep, SkipJac, SkipLU, NewtonDone - -#ifdef FULL_ALGEBRA - KPP_REAL, DIMENSION(NVAR,NVAR) :: FJAC, E, Jac, E_tlm -#else - KPP_REAL, DIMENSION(LU_NONZERO) :: FJAC, E, Jac, E_tlm -#endif - KPP_REAL, PARAMETER :: ZERO = 0.0d0, ONE = 1.0d0 - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Initializations -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - T = Tinitial - Tdirection = SIGN(ONE,Tfinal-Tinitial) - H = MAX(ABS(Hmin),ABS(Hstart)) - IF (ABS(H) <= 10.D0*Roundoff) H=1.0D-6 - H=MIN(ABS(H),Hmax) - H=SIGN(H,Tdirection) - SkipLU = .FALSE. - SkipJac = .FALSE. - Reject = .FALSE. - FirstStep=.TRUE. - - CALL SDIRK_ErrorScale(N, ITOL, AbsTol, RelTol, Y, SCAL) - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Time loop begins -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Tloop: DO WHILE ( (Tfinal-T)*Tdirection - Roundoff > ZERO ) - - -!~~~> Compute E = 1/(h*gamma)-Jac and its LU decomposition - IF ( .NOT.SkipLU ) THEN ! This time around skip the Jac update and LU - CALL SDIRK_PrepareMatrix ( H, T, Y, FJAC, & - SkipJac, SkipLU, E, IP, Reject, IER ) - IF (IER /= 0) THEN - CALL SDIRK_ErrorMsg(-8,T,H,Ierr); RETURN - END IF - END IF - - IF (ISTATUS(Nstp) > Max_no_steps) THEN - CALL SDIRK_ErrorMsg(-6,T,H,Ierr); RETURN - END IF - IF ( (T+0.1d0*H == T) .OR. (ABS(H) <= Roundoff) ) THEN - CALL SDIRK_ErrorMsg(-7,T,H,Ierr); RETURN - END IF - -stages:DO istage = 1, rkS - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Simplified Newton iterations -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -!~~~> Starting values for Newton iterations - CALL Set2zero(N,Z(1,istage)) - -!~~~> Prepare the loop-independent part of the right-hand side - CALL Set2zero(N,G) - IF (istage > 1) THEN - DO j = 1, istage-1 - ! Gj(:) = sum_j Theta(i,j)*Zj(:) = H * sum_j A(i,j)*Fun(Zj(:)) - CALL WAXPY(N,rkTheta(istage,j),Z(1,j),1,G,1) - ! Zi(:) = sum_j Alpha(i,j)*Zj(:) - IF (StartNewton) THEN - CALL WAXPY(N,rkAlpha(istage,j),Z(1,j),1,Z(1,istage),1) - END IF - END DO - END IF - - !~~~> Initializations for Newton iteration - NewtonDone = .FALSE. - Fac = 0.5d0 ! Step reduction factor if too many iterations - -NewtonLoop:DO NewtonIter = 1, NewtonMaxit - -!~~~> Prepare the loop-dependent part of the right-hand side - CALL WADD(N,Y,Z(1,istage),TMP) ! TMP <- Y + Zi - CALL FUN_CHEM(T+rkC(istage)*H,TMP,DZ) ! DZ <- Fun(Y+Zi) - ISTATUS(Nfun) = ISTATUS(Nfun) + 1 -! DZ(1:N) = G(1:N) - Z(1:N,istage) + (H*rkGamma)*DZ(1:N) - CALL WSCAL(N, H*rkGamma, DZ, 1) - CALL WAXPY (N, -ONE, Z(1,istage), 1, DZ, 1) - CALL WAXPY (N, ONE, G,1, DZ,1) - -!~~~> Solve the linear system - CALL SDIRK_Solve ( H, N, E, IP, IER, DZ ) - -!~~~> Check convergence of Newton iterations - CALL SDIRK_ErrorNorm(N, DZ, SCAL, NewtonIncrement) - IF ( NewtonIter == 1 ) THEN - Theta = ABS(ThetaMin) - NewtonRate = 2.0d0 - ELSE - Theta = NewtonIncrement/NewtonIncrementOld - IF (Theta < 0.99d0) THEN - NewtonRate = Theta/(ONE-Theta) - ! Predict error at the end of Newton process - NewtonPredictedErr = NewtonIncrement & - *Theta**(NewtonMaxit-NewtonIter)/(ONE-Theta) - IF (NewtonPredictedErr >= NewtonTol) THEN - ! Non-convergence of Newton: predicted error too large - Qnewton = MIN(10.0d0,NewtonPredictedErr/NewtonTol) - Fac = 0.8d0*Qnewton**(-ONE/(1+NewtonMaxit-NewtonIter)) - EXIT NewtonLoop - END IF - ELSE ! Non-convergence of Newton: Theta too large - EXIT NewtonLoop - END IF - END IF - NewtonIncrementOld = NewtonIncrement - ! Update solution: Z(:) <-- Z(:)+DZ(:) - CALL WAXPY(N,ONE,DZ,1,Z(1,istage),1) - - ! Check error in Newton iterations - NewtonDone = (NewtonRate*NewtonIncrement <= NewtonTol) - IF (NewtonDone) THEN - ! Tune error in TLM variables by defining the minimal number of Newton iterations. - saveNiter = NewtonIter+1 - EXIT NewtonLoop - END IF - - END DO NewtonLoop - - IF (.NOT.NewtonDone) THEN - !CALL RK_ErrorMsg(-12,T,H,Ierr); - H = Fac*H; Reject=.TRUE. - SkipJac = .TRUE.; SkipLU = .FALSE. - CYCLE Tloop - END IF - -!~~~> End of simplified Newton iterations for forward variables - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Solve for TLM variables -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -!~~~> Direct solution for TLM variables -DirTLM:IF (DirectTLM) THEN - - TMP(1:N) = Y(1:N) + Z(1:N,istage) - SkipJac = .FALSE. - CALL SDIRK_PrepareMatrix ( H, T+rkC(istage)*H, TMP, Jac, & - SkipJac, SkipLU, E_tlm, IP_tlm, Reject, IER ) - IF (IER /= 0) CYCLE TLoop - -TlmL: DO itlm = 1, NTLM - G(1:N) = Y_tlm(1:N,itlm) - IF (istage > 1) THEN - ! Gj(:) = sum_j Theta(i,j)*Zj_tlm(:) - ! = H * sum_j A(i,j)*Jac(Zj(:))*(Yj_tlm+Zj_tlm) - DO j = 1, istage-1 - CALL WAXPY(N,rkTheta(istage,j),Z_tlm(1,j,itlm),1,G,1) - END DO - END IF - CALL SDIRK_Solve ( H, N, E_tlm, IP_tlm, IER, G ) - Z_tlm(1:N,istage,itlm) = G(1:N) - Y_tlm(1:N,itlm) - END DO TlmL - - ELSE DirTLM - -!~~~> Jacobian of the current stage solution - TMP(1:N) = Y(1:N) + Z(1:N,istage) - CALL JAC_CHEM(T+rkC(istage)*H,TMP,Jac) - ISTATUS(Njac) = ISTATUS(Njac) + 1 - -!~~~> Simplified Newton iterations for TLM variables -TlmLoop:DO itlm = 1,NTLM - NewtonRate = MAX(NewtonRate,Roundoff)**0.8d0 - -!~~~> Starting values for Newton iterations - CALL Set2zero(N,Z_tlm(1,istage,itlm)) - -!~~~> Prepare the loop-independent part of the right-hand side -#ifdef FULL_ALGEBRA - DZ = MATMUL(Jac,Y_tlm(1,itlm)) ! DZ <- Jac(Y+Z)*Y_tlm -#else - CALL Jac_SP_Vec ( Jac, Y_tlm(1,itlm), DZ ) -#endif - G(1:N) = (H*rkGamma)*DZ(1:N) - IF (istage > 1) THEN - ! Gj(:) = sum_j Theta(i,j)*Zj_tlm(:) - ! = H * sum_j A(i,j)*Jac(Zj(:))*(Yj_tlm+Zj_tlm) - DO j = 1, istage-1 - CALL WAXPY(N,rkTheta(istage,j),Z_tlm(1,j,itlm),1,G,1) - END DO - END IF - - - !~~~> Initializations for Newton iteration - IF (TLMNewtonEst) THEN - NewtonDone = .FALSE. - Fac = 0.5d0 ! Step reduction factor if too many iterations - - CALL SDIRK_ErrorScale(N,ITOL,AbsTol_tlm(1,itlm),RelTol_tlm(1,itlm), & - Y_tlm(1,itlm),SCAL_tlm) - END IF - -NewtonLoopTLM:DO NewtonIterTLM = 1, NewtonMaxit - -!~~~> Prepare the loop-dependent part of the right-hand side -#ifdef FULL_ALGEBRA - DZ = MATMUL(Jac,Z_tlm(1,istage,itlm)) ! DZ <- Jac(Y+Z)*Z_tlm -#else - CALL Jac_SP_Vec ( Jac, Z_tlm(1,istage,itlm), DZ ) -#endif - DZ(1:N) = (H*rkGamma)*DZ(1:N)+G(1:N)-Z_tlm(1:N,istage,itlm) - - CALL SDIRK_Solve ( H, N, E, IP, IER, DZ ) - - IF (TLMNewtonEst) THEN -!~~~> Check convergence of Newton iterations - CALL SDIRK_ErrorNorm(N, DZ, SCAL_tlm, NewtonIncrement) - IF ( NewtonIterTLM <= 1 ) THEN - ThetaTLM = ABS(ThetaMin) - NewtonRate = 2.0d0 - ELSE - ThetaTLM = NewtonIncrement/NewtonIncrementOld - IF (ThetaTLM < 0.99d0) THEN - NewtonRate = ThetaTLM/(ONE-ThetaTLM) - ! Predict error at the end of Newton process - NewtonPredictedErr = NewtonIncrement & - *ThetaTLM**(NewtonMaxit-NewtonIterTLM)/(ONE-ThetaTLM) - IF (NewtonPredictedErr >= NewtonTol) THEN - ! Non-convergence of Newton: predicted error too large - Qnewton = MIN(10.0d0,NewtonPredictedErr/NewtonTol) - Fac = 0.8d0*Qnewton**(-ONE/(1+NewtonMaxit-NewtonIterTLM)) - EXIT NewtonLoopTLM - END IF - ELSE ! Non-convergence of Newton: Theta too large - EXIT NewtonLoopTLM - END IF - END IF - NewtonIncrementOld = NewtonIncrement - END IF !(TLMNewtonEst) - - ! Update solution: Z_tlm(:) <-- Z_tlm(:)+DZ(:) - CALL WAXPY(N,ONE,DZ,1,Z_tlm(1,istage,itlm),1) - - ! Check error in Newton iterations - IF (TLMNewtonEst) THEN - NewtonDone = (NewtonRate*NewtonIncrement <= NewtonTol) - IF (NewtonDone) EXIT NewtonLoopTLM - ELSE - ! Minimum number of iterations same as FWD iterations - IF (NewtonIterTLM>=saveNiter) EXIT NewtonLoopTLM - END IF - - END DO NewtonLoopTLM - - IF ((TLMNewtonEst) .AND. (.NOT.NewtonDone)) THEN - !CALL RK_ErrorMsg(-12,T,H,Ierr); - H = Fac*H; Reject=.TRUE. - SkipJac = .TRUE.; SkipLU = .FALSE. - CYCLE Tloop - END IF - - END DO TlmLoop -!~~~> End of simplified Newton iterations for TLM - - END IF DirTLM - - END DO stages - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Error estimation -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ISTATUS(Nstp) = ISTATUS(Nstp) + 1 - CALL Set2zero(N,Yerr) - DO i = 1,rkS - IF (rkE(i)/=ZERO) CALL WAXPY(N,rkE(i),Z(1,i),1,Yerr,1) - END DO - - CALL SDIRK_Solve ( H, N, E, IP, IER, Yerr ) - CALL SDIRK_ErrorNorm(N, Yerr, SCAL, Err) - - IF (TLMtruncErr) THEN - CALL Set2zero(NVAR*NTLM,Yerr_tlm) - DO itlm=1,NTLM - DO j=1,rkS - IF (rkE(j) /= ZERO) CALL WAXPY(N,rkE(j),Z_tlm(1,j,itlm),1,Yerr_tlm(1,itlm),1) - END DO - CALL SDIRK_Solve (H, N, E, IP, IER, Yerr_tlm(1,itlm)) - END DO - CALL SDIRK_ErrorNorm_tlm(N,NTLM, Yerr_tlm, Err) - END IF - -!~~~> Computation of new step size Hnew - Fac = FacSafe*(Err)**(-ONE/rkELO) - Fac = MAX(FacMin,MIN(FacMax,Fac)) - Hnew = H*Fac - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Accept/Reject step -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -accept: IF ( Err < ONE ) THEN !~~~> Step is accepted - - FirstStep=.FALSE. - ISTATUS(Nacc) = ISTATUS(Nacc) + 1 - -!~~~> Update time and solution - T = T + H - ! Y(:) <-- Y(:) + Sum_j rkD(j)*Z_j(:) - DO i = 1,rkS - IF (rkD(i)/=ZERO) THEN - CALL WAXPY(N,rkD(i),Z(1,i),1,Y,1) - DO itlm = 1, NTLM - CALL WAXPY(N,rkD(i),Z_tlm(1,i,itlm),1,Y_tlm(1,itlm),1) - END DO - END IF - END DO - -!~~~> Update scaling coefficients - CALL SDIRK_ErrorScale(N, ITOL, AbsTol, RelTol, Y, SCAL) - -!~~~> Next time step - Hnew = Tdirection*MIN(ABS(Hnew),Hmax) - ! Last T and H - RSTATUS(Ntexit) = T - RSTATUS(Nhexit) = H - RSTATUS(Nhnew) = Hnew - ! No step increase after a rejection - IF (Reject) Hnew = Tdirection*MIN(ABS(Hnew),ABS(H)) - Reject = .FALSE. - IF ((T+Hnew/Qmin-Tfinal)*Tdirection > ZERO) THEN - H = Tfinal-T - ELSE - Hratio=Hnew/H - ! If step not changed too much keep Jacobian and reuse LU - SkipLU = ( (Theta <= ThetaMin) .AND. (Hratio >= Qmin) & - .AND. (Hratio <= Qmax) ) - ! For TLM: do not skip LU (decrease TLM error) - SkipLU = .FALSE. - IF (.NOT.SkipLU) H = Hnew - END IF - ! If convergence is fast enough, do not update Jacobian -! SkipJac = (Theta <= ThetaMin) - SkipJac = .FALSE. - - ELSE accept !~~~> Step is rejected - - IF (FirstStep .OR. Reject) THEN - H = FacRej*H - ELSE - H = Hnew - END IF - Reject = .TRUE. - SkipJac = .TRUE. - SkipLU = .FALSE. - IF (ISTATUS(Nacc) >= 1) ISTATUS(Nrej) = ISTATUS(Nrej) + 1 - - END IF accept - - END DO Tloop - - ! Successful return - Ierr = 1 - - END SUBROUTINE SDIRK_IntegratorTLM - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SDIRK_ErrorScale(N, ITOL, AbsTol, RelTol, Y, SCAL) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - INTEGER :: N, i, ITOL - KPP_REAL :: AbsTol(NVAR), RelTol(NVAR), & - Y(NVAR), SCAL(NVAR) - IF (ITOL == 0) THEN - DO i=1,N - SCAL(i) = ONE / ( AbsTol(1)+RelTol(1)*ABS(Y(i)) ) - END DO - ELSE - DO i=1,N - SCAL(i) = ONE / ( AbsTol(i)+RelTol(i)*ABS(Y(i)) ) - END DO - END IF - END SUBROUTINE SDIRK_ErrorScale - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SDIRK_ErrorNorm(N, Y, SCAL, Err) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! - INTEGER :: i, N - KPP_REAL :: Y(N), SCAL(N), Err - Err = ZERO - DO i=1,N - Err = Err+(Y(i)*SCAL(i))**2 - END DO - Err = MAX( SQRT(Err/DBLE(N)), 1.0d-10 ) -! - END SUBROUTINE SDIRK_ErrorNorm - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SDIRK_ErrorNorm_tlm(N,NTLM, Y_tlm, FWD_Err) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! - INTEGER :: itlm, NTLM, N - KPP_REAL :: Y_tlm(N,NTLM), SCAL_tlm(N), FWD_Err, Err - - DO itlm=1,NTLM - CALL SDIRK_ErrorScale(N,ITOL,AbsTol_tlm(1,itlm),RelTol_tlm(1,itlm), & - Y_tlm(1,itlm),SCAL_tlm) - CALL SDIRK_ErrorNorm(N, Y_tlm(1,itlm), SCAL_tlm, Err) - FWD_Err = MAX(FWD_Err, Err) - END DO -! - END SUBROUTINE SDIRK_ErrorNorm_tlm - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SDIRK_ErrorMsg(Code,T,H,Ierr) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Handles all error messages -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - KPP_REAL, INTENT(IN) :: T, H - INTEGER, INTENT(IN) :: Code - INTEGER, INTENT(OUT) :: Ierr - - Ierr = Code - PRINT * , & - 'Forced exit from SDIRK due to the following error:' - - SELECT CASE (Code) - CASE (-1) - PRINT * , '--> Improper value for maximal no of steps' - CASE (-2) - PRINT * , '--> Improper value for maximal no of Newton iterations' - CASE (-3) - PRINT * , '--> Hmin/Hmax/Hstart must be positive' - CASE (-4) - PRINT * , '--> FacMin/FacMax/FacRej must be positive' - CASE (-5) - PRINT * , '--> Improper tolerance values' - CASE (-6) - PRINT * , '--> No of steps exceeds maximum bound' - CASE (-7) - PRINT * , '--> Step size too small: T + 10*H = T', & - ' or H < Roundoff' - CASE (-8) - PRINT * , '--> Matrix is repeatedly singular' - CASE DEFAULT - PRINT *, 'Unknown Error code: ', Code - END SELECT - - PRINT *, "T=", T, "and H=", H - - END SUBROUTINE SDIRK_ErrorMsg - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SDIRK_PrepareMatrix ( H, T, Y, FJAC, & - SkipJac, SkipLU, E, IP, Reject, ISING ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Compute the matrix E = I - 1/(H*Gamma)*Jac, and its decomposition -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - IMPLICIT NONE - - KPP_REAL, INTENT(INOUT) :: H - KPP_REAL, INTENT(IN) :: T, Y(NVAR) - LOGICAL, INTENT(INOUT) :: SkipJac,SkipLU,Reject - INTEGER, INTENT(OUT) :: ISING, IP(NVAR) -#ifdef FULL_ALGEBRA - KPP_REAL, INTENT(INOUT) :: FJAC(NVAR,NVAR) - KPP_REAL, INTENT(OUT) :: E(NVAR,NVAR) -#else - KPP_REAL, INTENT(INOUT) :: FJAC(LU_NONZERO) - KPP_REAL, INTENT(OUT) :: E(LU_NONZERO) -#endif - KPP_REAL :: HGammaInv - INTEGER :: i, j, ConsecutiveSng - - ConsecutiveSng = 0 - ISING = 1 - -Hloop: DO WHILE (ISING /= 0) - - HGammaInv = ONE/(H*rkGamma) - -!~~~> Compute the Jacobian -! IF (SkipJac) THEN -! SkipJac = .FALSE. -! ELSE - IF (.NOT. SkipJac) THEN - CALL JAC_CHEM( T, Y, FJAC ) - ISTATUS(Njac) = ISTATUS(Njac) + 1 - END IF - -#ifdef FULL_ALGEBRA - DO j=1,NVAR - DO i=1,NVAR - E(i,j) = -FJAC(i,j) - END DO - E(j,j) = E(j,j)+HGammaInv - END DO - CALL DGETRF( NVAR, NVAR, E, NVAR, IP, ISING ) -#else - DO i = 1,LU_NONZERO - E(i) = -FJAC(i) - END DO - DO i = 1,NVAR - j = LU_DIAG(i); E(j) = E(j) + HGammaInv - END DO - CALL KppDecomp ( E, ISING) - IP(1) = 1 -#endif - ISTATUS(Ndec) = ISTATUS(Ndec) + 1 - - IF (ISING /= 0) THEN - WRITE (6,*) ' MATRIX IS SINGULAR, ISING=',ISING,' T=',T,' H=',H - ISTATUS(Nsng) = ISTATUS(Nsng) + 1; ConsecutiveSng = ConsecutiveSng + 1 - IF (ConsecutiveSng >= 6) RETURN ! Failure - H = 0.5d0*H - SkipJac = .TRUE. - SkipLU = .FALSE. - Reject = .TRUE. - END IF - - END DO Hloop - - END SUBROUTINE SDIRK_PrepareMatrix - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE SDIRK_Solve ( H, N, E, IP, ISING, RHS ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~> Solves the system (H*Gamma-Jac)*x = R -! using the LU decomposition of E = I - 1/(H*Gamma)*Jac -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE - INTEGER, INTENT(IN) :: N, IP(N), ISING - KPP_REAL, INTENT(IN) :: H -#ifdef FULL_ALGEBRA - KPP_REAL, INTENT(IN) :: E(NVAR,NVAR) -#else - KPP_REAL, INTENT(IN) :: E(LU_NONZERO) -#endif - KPP_REAL, INTENT(INOUT) :: RHS(N) - KPP_REAL :: HGammaInv - - HGammaInv = ONE/(H*rkGamma) - CALL WSCAL(N,HGammaInv,RHS,1) -#ifdef FULL_ALGEBRA - CALL DGETRS( 'N', N, 1, E, N, IP, RHS, N, ISING ) -#else - CALL KppSolve(E, RHS) -#endif - ISTATUS(Nsol) = ISTATUS(Nsol) + 1 - - END SUBROUTINE SDIRK_Solve - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Sdirk4a -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - sdMethod = S4A -! Number of stages - rkS = 5 - -! Method coefficients - rkGamma = .2666666666666666666666666666666667d0 - - rkA(1,1) = .2666666666666666666666666666666667d0 - rkA(2,1) = .5000000000000000000000000000000000d0 - rkA(2,2) = .2666666666666666666666666666666667d0 - rkA(3,1) = .3541539528432732316227461858529820d0 - rkA(3,2) = -.5415395284327323162274618585298197d-1 - rkA(3,3) = .2666666666666666666666666666666667d0 - rkA(4,1) = .8515494131138652076337791881433756d-1 - rkA(4,2) = -.6484332287891555171683963466229754d-1 - rkA(4,3) = .7915325296404206392428857585141242d-1 - rkA(4,4) = .2666666666666666666666666666666667d0 - rkA(5,1) = 2.100115700566932777970612055999074d0 - rkA(5,2) = -.7677800284445976813343102185062276d0 - rkA(5,3) = 2.399816361080026398094746205273880d0 - rkA(5,4) = -2.998818699869028161397714709433394d0 - rkA(5,5) = .2666666666666666666666666666666667d0 - - rkB(1) = 2.100115700566932777970612055999074d0 - rkB(2) = -.7677800284445976813343102185062276d0 - rkB(3) = 2.399816361080026398094746205273880d0 - rkB(4) = -2.998818699869028161397714709433394d0 - rkB(5) = .2666666666666666666666666666666667d0 - - rkBhat(1)= 2.885264204387193942183851612883390d0 - rkBhat(2)= -.1458793482962771337341223443218041d0 - rkBhat(3)= 2.390008682465139866479830743628554d0 - rkBhat(4)= -4.129393538556056674929560012190140d0 - rkBhat(5)= 0.d0 - - rkC(1) = .2666666666666666666666666666666667d0 - rkC(2) = .7666666666666666666666666666666667d0 - rkC(3) = .5666666666666666666666666666666667d0 - rkC(4) = .3661315380631796996374935266701191d0 - rkC(5) = 1.d0 - -! Ynew = Yold + h*Sum_i {rkB_i*k_i} = Yold + Sum_i {rkD_i*Z_i} - rkD(1) = 0.d0 - rkD(2) = 0.d0 - rkD(3) = 0.d0 - rkD(4) = 0.d0 - rkD(5) = 1.d0 - -! Err = h * Sum_i {(rkB_i-rkBhat_i)*k_i} = Sum_i {rkE_i*Z_i} - rkE(1) = -.6804000050475287124787034884002302d0 - rkE(2) = 1.558961944525217193393931795738823d0 - rkE(3) = -13.55893003128907927748632408763868d0 - rkE(4) = 15.48522576958521253098585004571302d0 - rkE(5) = 1.d0 - -! Local order of Err estimate - rkElo = 4 - -! h*Sum_j {rkA_ij*k_j} = Sum_j {rkTheta_ij*Z_j} - rkTheta(2,1) = 1.875000000000000000000000000000000d0 - rkTheta(3,1) = 1.708847304091539528432732316227462d0 - rkTheta(3,2) = -.2030773231622746185852981969486824d0 - rkTheta(4,1) = .2680325578937783958847157206823118d0 - rkTheta(4,2) = -.1828840955527181631794050728644549d0 - rkTheta(4,3) = .2968246986151577397160821594427966d0 - rkTheta(5,1) = .9096171815241460655379433581446771d0 - rkTheta(5,2) = -3.108254967778352416114774430509465d0 - rkTheta(5,3) = 12.33727431701306195581826123274001d0 - rkTheta(5,4) = -11.24557012450885560524143016037523d0 - -! Starting value for Newton iterations: Z_i^0 = Sum_j {rkAlpha_ij*Z_j} - rkAlpha(2,1) = 2.875000000000000000000000000000000d0 - rkAlpha(3,1) = .8500000000000000000000000000000000d0 - rkAlpha(3,2) = .4434782608695652173913043478260870d0 - rkAlpha(4,1) = .7352046091658870564637910527807370d0 - rkAlpha(4,2) = -.9525565003057343527941920657462074d-1 - rkAlpha(4,3) = .4290111305453813852259481840631738d0 - rkAlpha(5,1) = -16.10898993405067684831655675112808d0 - rkAlpha(5,2) = 6.559571569643355712998131800797873d0 - rkAlpha(5,3) = -15.90772144271326504260996815012482d0 - rkAlpha(5,4) = 25.34908987169226073668861694892683d0 - -!~~~> Coefficients for continuous solution -! rkD(1,1)= 24.74416644927758d0 -! rkD(1,2)= -4.325375951824688d0 -! rkD(1,3)= 41.39683763286316d0 -! rkD(1,4)= -61.04144619901784d0 -! rkD(1,5)= -3.391332232917013d0 -! rkD(2,1)= -51.98245719616925d0 -! rkD(2,2)= 10.52501981094525d0 -! rkD(2,3)= -154.2067922191855d0 -! rkD(2,4)= 214.3082125319825d0 -! rkD(2,5)= 14.71166018088679d0 -! rkD(3,1)= 33.14347947522142d0 -! rkD(3,2)= -19.72986789558523d0 -! rkD(3,3)= 230.4878502285804d0 -! rkD(3,4)= -287.6629744338197d0 -! rkD(3,5)= -18.99932366302254d0 -! rkD(4,1)= -5.905188728329743d0 -! rkD(4,2)= 13.53022403646467d0 -! rkD(4,3)= -117.6778956422581d0 -! rkD(4,4)= 134.3962081008550d0 -! rkD(4,5)= 8.678995715052762d0 -! -! DO i=1,4 ! CONTi <-- Sum_j rkD(i,j)*Zj -! CALL Set2zero(N,CONT(1,i)) -! DO j = 1,rkS -! CALL WAXPY(N,rkD(i,j),Z(1,j),1,CONT(1,i),1) -! END DO -! END DO - - rkELO = 4.0d0 - - END SUBROUTINE Sdirk4a - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Sdirk4b -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - sdMethod = S4B -! Number of stages - rkS = 5 - -! Method coefficients - rkGamma = .25d0 - - rkA(1,1) = 0.25d0 - rkA(2,1) = 0.5d00 - rkA(2,2) = 0.25d0 - rkA(3,1) = 0.34d0 - rkA(3,2) =-0.40d-1 - rkA(3,3) = 0.25d0 - rkA(4,1) = 0.2727941176470588235294117647058824d0 - rkA(4,2) =-0.5036764705882352941176470588235294d-1 - rkA(4,3) = 0.2757352941176470588235294117647059d-1 - rkA(4,4) = 0.25d0 - rkA(5,1) = 1.041666666666666666666666666666667d0 - rkA(5,2) =-1.020833333333333333333333333333333d0 - rkA(5,3) = 7.812500000000000000000000000000000d0 - rkA(5,4) =-7.083333333333333333333333333333333d0 - rkA(5,5) = 0.25d0 - - rkB(1) = 1.041666666666666666666666666666667d0 - rkB(2) = -1.020833333333333333333333333333333d0 - rkB(3) = 7.812500000000000000000000000000000d0 - rkB(4) = -7.083333333333333333333333333333333d0 - rkB(5) = 0.250000000000000000000000000000000d0 - - rkBhat(1)= 1.069791666666666666666666666666667d0 - rkBhat(2)= -0.894270833333333333333333333333333d0 - rkBhat(3)= 7.695312500000000000000000000000000d0 - rkBhat(4)= -7.083333333333333333333333333333333d0 - rkBhat(5)= 0.212500000000000000000000000000000d0 - - rkC(1) = 0.25d0 - rkC(2) = 0.75d0 - rkC(3) = 0.55d0 - rkC(4) = 0.50d0 - rkC(5) = 1.00d0 - -! Ynew = Yold + h*Sum_i {rkB_i*k_i} = Yold + Sum_i {rkD_i*Z_i} - rkD(1) = 0.0d0 - rkD(2) = 0.0d0 - rkD(3) = 0.0d0 - rkD(4) = 0.0d0 - rkD(5) = 1.0d0 - -! Err = h * Sum_i {(rkB_i-rkBhat_i)*k_i} = Sum_i {rkE_i*Z_i} - rkE(1) = 0.5750d0 - rkE(2) = 0.2125d0 - rkE(3) = -4.6875d0 - rkE(4) = 4.2500d0 - rkE(5) = 0.1500d0 - -! Local order of Err estimate - rkElo = 4 - -! h*Sum_j {rkA_ij*k_j} = Sum_j {rkTheta_ij*Z_j} - rkTheta(2,1) = 2.d0 - rkTheta(3,1) = 1.680000000000000000000000000000000d0 - rkTheta(3,2) = -.1600000000000000000000000000000000d0 - rkTheta(4,1) = 1.308823529411764705882352941176471d0 - rkTheta(4,2) = -.1838235294117647058823529411764706d0 - rkTheta(4,3) = 0.1102941176470588235294117647058824d0 - rkTheta(5,1) = -3.083333333333333333333333333333333d0 - rkTheta(5,2) = -4.291666666666666666666666666666667d0 - rkTheta(5,3) = 34.37500000000000000000000000000000d0 - rkTheta(5,4) = -28.33333333333333333333333333333333d0 - -! Starting value for Newton iterations: Z_i^0 = Sum_j {rkAlpha_ij*Z_j} - rkAlpha(2,1) = 3. - rkAlpha(3,1) = .8800000000000000000000000000000000d0 - rkAlpha(3,2) = .4400000000000000000000000000000000d0 - rkAlpha(4,1) = .1666666666666666666666666666666667d0 - rkAlpha(4,2) = -.8333333333333333333333333333333333d-1 - rkAlpha(4,3) = .9469696969696969696969696969696970d0 - rkAlpha(5,1) = -6.d0 - rkAlpha(5,2) = 9.d0 - rkAlpha(5,3) = -56.81818181818181818181818181818182d0 - rkAlpha(5,4) = 54.d0 - - END SUBROUTINE Sdirk4b - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Sdirk2a -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - sdMethod = S2A -! Number of stages - rkS = 2 - -! Method coefficients - rkGamma = .2928932188134524755991556378951510d0 - - rkA(1,1) = .2928932188134524755991556378951510d0 - rkA(2,1) = .7071067811865475244008443621048490d0 - rkA(2,2) = .2928932188134524755991556378951510d0 - - rkB(1) = .7071067811865475244008443621048490d0 - rkB(2) = .2928932188134524755991556378951510d0 - - rkBhat(1)= .6666666666666666666666666666666667d0 - rkBhat(2)= .3333333333333333333333333333333333d0 - - rkC(1) = 0.292893218813452475599155637895151d0 - rkC(2) = 1.0d0 - -! Ynew = Yold + h*Sum_i {rkB_i*k_i} = Yold + Sum_i {rkD_i*Z_i} - rkD(1) = 0.0d0 - rkD(2) = 1.0d0 - -! Err = h * Sum_i {(rkB_i-rkBhat_i)*k_i} = Sum_i {rkE_i*Z_i} - rkE(1) = 0.4714045207910316829338962414032326d0 - rkE(2) = -0.1380711874576983496005629080698993d0 - -! Local order of Err estimate - rkElo = 2 - -! h*Sum_j {rkA_ij*k_j} = Sum_j {rkTheta_ij*Z_j} - rkTheta(2,1) = 2.414213562373095048801688724209698d0 - -! Starting value for Newton iterations: Z_i^0 = Sum_j {rkAlpha_ij*Z_j} - rkAlpha(2,1) = 3.414213562373095048801688724209698d0 - - END SUBROUTINE Sdirk2a - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Sdirk2b -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - sdMethod = S2B -! Number of stages - rkS = 2 - -! Method coefficients - rkGamma = 1.707106781186547524400844362104849d0 - - rkA(1,1) = 1.707106781186547524400844362104849d0 - rkA(2,1) = -.707106781186547524400844362104849d0 - rkA(2,2) = 1.707106781186547524400844362104849d0 - - rkB(1) = -.707106781186547524400844362104849d0 - rkB(2) = 1.707106781186547524400844362104849d0 - - rkBhat(1)= .6666666666666666666666666666666667d0 - rkBhat(2)= .3333333333333333333333333333333333d0 - - rkC(1) = 1.707106781186547524400844362104849d0 - rkC(2) = 1.0d0 - -! Ynew = Yold + h*Sum_i {rkB_i*k_i} = Yold + Sum_i {rkD_i*Z_i} - rkD(1) = 0.0d0 - rkD(2) = 1.0d0 - -! Err = h * Sum_i {(rkB_i-rkBhat_i)*k_i} = Sum_i {rkE_i*Z_i} - rkE(1) = -.4714045207910316829338962414032326d0 - rkE(2) = .8047378541243650162672295747365659d0 - -! Local order of Err estimate - rkElo = 2 - -! h*Sum_j {rkA_ij*k_j} = Sum_j {rkTheta_ij*Z_j} - rkTheta(2,1) = -.414213562373095048801688724209698d0 - -! Starting value for Newton iterations: Z_i^0 = Sum_j {rkAlpha_ij*Z_j} - rkAlpha(2,1) = .5857864376269049511983112757903019d0 - - END SUBROUTINE Sdirk2b - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE Sdirk3a -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - sdMethod = S3A -! Number of stages - rkS = 3 - -! Method coefficients - rkGamma = .2113248654051871177454256097490213d0 - - rkA(1,1) = .2113248654051871177454256097490213d0 - rkA(2,1) = .2113248654051871177454256097490213d0 - rkA(2,2) = .2113248654051871177454256097490213d0 - rkA(3,1) = .2113248654051871177454256097490213d0 - rkA(3,2) = .5773502691896257645091487805019573d0 - rkA(3,3) = .2113248654051871177454256097490213d0 - - rkB(1) = .2113248654051871177454256097490213d0 - rkB(2) = .5773502691896257645091487805019573d0 - rkB(3) = .2113248654051871177454256097490213d0 - - rkBhat(1)= .2113248654051871177454256097490213d0 - rkBhat(2)= .6477918909913548037576239837516312d0 - rkBhat(3)= .1408832436034580784969504064993475d0 - - rkC(1) = .2113248654051871177454256097490213d0 - rkC(2) = .4226497308103742354908512194980427d0 - rkC(3) = 1.d0 - -! Ynew = Yold + h*Sum_i {rkB_i*k_i} = Yold + Sum_i {rkD_i*Z_i} - rkD(1) = 0.d0 - rkD(2) = 0.d0 - rkD(3) = 1.d0 - -! Err = h * Sum_i {(rkB_i-rkBhat_i)*k_i} = Sum_i {rkE_i*Z_i} - rkE(1) = 0.9106836025229590978424821138352906d0 - rkE(2) = -1.244016935856292431175815447168624d0 - rkE(3) = 0.3333333333333333333333333333333333d0 - -! Local order of Err estimate - rkElo = 2 - -! h*Sum_j {rkA_ij*k_j} = Sum_j {rkTheta_ij*Z_j} - rkTheta(2,1) = 1.0d0 - rkTheta(3,1) = -1.732050807568877293527446341505872d0 - rkTheta(3,2) = 2.732050807568877293527446341505872d0 - -! Starting value for Newton iterations: Z_i^0 = Sum_j {rkAlpha_ij*Z_j} - rkAlpha(2,1) = 2.0d0 - rkAlpha(3,1) = -12.92820323027550917410978536602349d0 - rkAlpha(3,2) = 8.83012701892219323381861585376468d0 - - END SUBROUTINE Sdirk3a - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - END SUBROUTINE SdirkTLM ! AND ALL ITS INTERNAL PROCEDURES -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE FUN_CHEM( T, Y, P ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - USE KPP_ROOT_Parameters, ONLY: NVAR - USE KPP_ROOT_Global, ONLY: TIME, FIX, RCONST - USE KPP_ROOT_Function, ONLY: Fun - USE KPP_ROOT_Rates, ONLY: Update_SUN, Update_RCONST, Update_PHOTO - - KPP_REAL :: T, Told - KPP_REAL :: Y(NVAR), P(NVAR) - - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - - CALL Fun( Y, FIX, RCONST, P ) - - TIME = Told - - END SUBROUTINE FUN_CHEM - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - SUBROUTINE JAC_CHEM( T, Y, JV ) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - - USE KPP_ROOT_Parameters, ONLY: NVAR, LU_NONZERO - USE KPP_ROOT_Global, ONLY: TIME, FIX, RCONST - USE KPP_ROOT_Jacobian, ONLY: Jac_SP,LU_IROW,LU_ICOL - USE KPP_ROOT_Rates, ONLY: Update_SUN, Update_RCONST, Update_PHOTO - - KPP_REAL :: T, Told - KPP_REAL :: Y(NVAR) -#ifdef FULL_ALGEBRA - KPP_REAL :: JS(LU_NONZERO), JV(NVAR,NVAR) - INTEGER :: i, j -#else - KPP_REAL :: JV(LU_NONZERO) -#endif - - Told = TIME - TIME = T - CALL Update_SUN() - CALL Update_RCONST() - -#ifdef FULL_ALGEBRA - CALL Jac_SP(Y, FIX, RCONST, JS) - DO j=1,NVAR - DO i=1,NVAR - JV(i,j) = 0.0D0 - END DO - END DO - DO i=1,LU_NONZERO - JV(LU_IROW(i),LU_ICOL(i)) = JS(i) - END DO -#else - CALL Jac_SP(Y, FIX, RCONST, JV) -#endif - TIME = Told - - END SUBROUTINE JAC_CHEM - -END MODULE KPP_ROOT_Integrator diff --git a/boxmox/int/tau_leap.def b/boxmox/int/tau_leap.def deleted file mode 100644 index 98f65d6527773a7776e214e24b0de25544aa629a..0000000000000000000000000000000000000000 --- a/boxmox/int/tau_leap.def +++ /dev/null @@ -1,10 +0,0 @@ - -#FUNCTION aggregate -#JACOBIAN SPARSE_LU_ROW -#DOUBLE on -#STOCHASTIC on -#INTFILE tau_leap - - - - diff --git a/boxmox/int/tau_leap.f90 b/boxmox/int/tau_leap.f90 deleted file mode 100644 index c069d867d00aa5d0ecad19cebb9c9fe039ad10f3..0000000000000000000000000000000000000000 --- a/boxmox/int/tau_leap.f90 +++ /dev/null @@ -1,1688 +0,0 @@ -MODULE KPP_ROOT_Random -! A module for random number generation from the following distributions: -! -! Distribution Function/subroutine name -! -! Normal (Gaussian) random_normal -! Gamma random_gamma -! Chi-squared random_chisq -! Exponential random_exponential -! Weibull random_Weibull -! Beta random_beta -! t random_t -! Multivariate normal random_mvnorm -! Generalized inverse Gaussian random_inv_gauss -! Poisson random_Poisson -! Binomial random_binomial1 * -! random_binomial2 * -! Negative binomial random_neg_binomial -! von Mises random_von_Mises -! Cauchy random_Cauchy -! -! Generate a random ordering of the integers 1 .. N -! random_order -! Initialize (seed) the uniform random number generator for ANY compiler -! seed_random_number - -! Lognormal - see note below. - -! ** Two functions are provided for the binomial distribution. -! If the parameter values remain constant, it is recommended that the -! first function is used (random_binomial1). If one or both of the -! parameters change, use the second function (random_binomial2). - -! The compilers own random number generator, SUBROUTINE RANDOM_NUMBER(r), -! is used to provide a source of uniformly distributed random numbers. - -! N.B. At this stage, only one random number is generated at each call to -! one of the functions above. - -! The module uses the following functions which are included here: -! bin_prob to calculate a single binomial probability -! lngamma to calculate the logarithm to base e of the gamma function - -! Some of the code is adapted from Dagpunar's book: -! Dagpunar, J. 'Principles of random variate generation' -! Clarendon Press, Oxford, 1988. ISBN 0-19-852202-9 -! -! In most of Dagpunar's routines, there is a test to see whether the value -! of one or two floating-point parameters has changed since the last call. -! These tests have been replaced by using a logical variable FIRST. -! This should be set to .TRUE. on the first call using new values of the -! parameters, and .FALSE. if the parameter values are the same as for the -! previous call. - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Lognormal distribution -! If X has a lognormal distribution, then log(X) is normally distributed. -! Here the logarithm is the natural logarithm, that is to base e, sometimes -! denoted as ln. To generate random variates from this distribution, generate -! a random deviate from the normal distribution with mean and variance equal -! to the mean and variance of the logarithms of X, then take its exponential. - -! Relationship between the mean & variance of log(X) and the mean & variance -! of X, when X has a lognormal distribution. -! Let m = mean of log(X), and s^2 = variance of log(X) -! Then -! mean of X = exp(m + 0.5s^2) -! variance of X = (mean(X))^2.[exp(s^2) - 1] - -! In the reverse direction (rarely used) -! variance of log(X) = log[1 + var(X)/(mean(X))^2] -! mean of log(X) = log(mean(X) - 0.5var(log(X)) - -! N.B. The above formulae relate to population parameters; they will only be -! approximate if applied to sample values. -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! Version 1.13, 2 October 2000 -! Changes from version 1.01 -! 1. The random_order, random_Poisson & random_binomial routines have been -! replaced with more efficient routines. -! 2. A routine, seed_random_number, has been added to seed the uniform random -! number generator. This requires input of the required number of seeds -! for the particular compiler from a specified I/O unit such as a keyboard. -! 3. Made compatible with Lahey's ELF90. -! 4. Marsaglia & Tsang algorithm used for random_gamma when shape parameter > 1. -! 5. INTENT for array f corrected in random_mvnorm. - -! Author: Alan Miller -! CSIRO Division of Mathematical & Information Sciences -! Private Bag 10, Clayton South MDC -! Clayton 3169, Victoria, Australia -! Phone: (+61) 3 9545-8016 Fax: (+61) 3 9545-8080 -! e-mail: amiller @ bigpond.net.au - -IMPLICIT NONE -REAL, PRIVATE :: zero = 0.0, half = 0.5, one = 1.0, two = 2.0, & - vsmall = TINY(1.0), vlarge = HUGE(1.0) -PRIVATE :: integral -INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(12, 60) - - -CONTAINS - - -FUNCTION random_normal() RESULT(fn_val) - -! Adapted from the following Fortran 77 code -! ALGORITHM 712, COLLECTED ALGORITHMS FROM ACM. -! THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE, -! VOL. 18, NO. 4, DECEMBER, 1992, PP. 434-435. - -! The function random_normal() returns a normally distributed pseudo-random -! number with zero mean and unit variance. - -! The algorithm uses the ratio of uniforms method of A.J. Kinderman -! and J.F. Monahan augmented with quadratic bounding curves. - -REAL :: fn_val - -! Local variables -REAL :: s = 0.449871, t = -0.386595, a = 0.19600, b = 0.25472, & - r1 = 0.27597, r2 = 0.27846, u, v, x, y, q - -! Generate P = (u,v) uniform in rectangle enclosing acceptance region - -DO - CALL RANDOM_NUMBER(u) - CALL RANDOM_NUMBER(v) - v = 1.7156 * (v - half) - -! Evaluate the quadratic form - x = u - s - y = ABS(v) - t - q = x**2 + y*(a*y - b*x) - -! Accept P if inside inner ellipse - IF (q < r1) EXIT -! Reject P if outside outer ellipse - IF (q > r2) CYCLE -! Reject P if outside acceptance region - IF (v**2 < -4.0*LOG(u)*u**2) EXIT -END DO - -! Return ratio of P's coordinates as the normal deviate -fn_val = v/u -RETURN - -END FUNCTION random_normal - - - -FUNCTION random_gamma(s, first) RESULT(fn_val) - -! Adapted from Fortran 77 code from the book: -! Dagpunar, J. 'Principles of random variate generation' -! Clarendon Press, Oxford, 1988. ISBN 0-19-852202-9 - -! FUNCTION GENERATES A RANDOM GAMMA VARIATE. -! CALLS EITHER random_gamma1 (S > 1.0) -! OR random_exponential (S = 1.0) -! OR random_gamma2 (S < 1.0). - -! S = SHAPE PARAMETER OF DISTRIBUTION (0 < REAL). - -REAL, INTENT(IN) :: s -LOGICAL, INTENT(IN) :: first -REAL :: fn_val - -IF (s <= zero) THEN - WRITE(*, *) 'SHAPE PARAMETER VALUE MUST BE POSITIVE' - STOP -END IF - -IF (s > one) THEN - fn_val = random_gamma1(s, first) -ELSE IF (s < one) THEN - fn_val = random_gamma2(s, first) -ELSE - fn_val = random_exponential() -END IF - -RETURN -END FUNCTION random_gamma - - - -FUNCTION random_gamma1(s, first) RESULT(fn_val) - -! Uses the algorithm in -! Marsaglia, G. and Tsang, W.W. (2000) `A simple method for generating -! gamma variables', Trans. om Math. Software (TOMS), vol.26(3), pp.363-372. - -! Generates a random gamma deviate for shape parameter s >= 1. - -REAL, INTENT(IN) :: s -LOGICAL, INTENT(IN) :: first -REAL :: fn_val - -! Local variables -REAL, SAVE :: c, d -REAL :: u, v, x - -IF (first) THEN - d = s - one/3. - c = one/SQRT(9.0*d) -END IF - -! Start of main loop -DO - -! Generate v = (1+cx)^3 where x is random normal; repeat if v <= 0. - - DO - x = random_normal() - v = (one + c*x)**3 - IF (v > zero) EXIT - END DO - -! Generate uniform variable U - - CALL RANDOM_NUMBER(u) - IF (u < one - 0.0331*x**4) THEN - fn_val = d*v - EXIT - ELSE IF (LOG(u) < half*x**2 + d*(one - v + LOG(v))) THEN - fn_val = d*v - EXIT - END IF -END DO - -RETURN -END FUNCTION random_gamma1 - - - -FUNCTION random_gamma2(s, first) RESULT(fn_val) - -! Adapted from Fortran 77 code from the book: -! Dagpunar, J. 'Principles of random variate generation' -! Clarendon Press, Oxford, 1988. ISBN 0-19-852202-9 - -! FUNCTION GENERATES A RANDOM VARIATE IN [0,INFINITY) FROM -! A GAMMA DISTRIBUTION WITH DENSITY PROPORTIONAL TO -! GAMMA2**(S-1) * EXP(-GAMMA2), -! USING A SWITCHING METHOD. - -! S = SHAPE PARAMETER OF DISTRIBUTION -! (REAL < 1.0) - -REAL, INTENT(IN) :: s -LOGICAL, INTENT(IN) :: first -REAL :: fn_val - -! Local variables -REAL :: r, x, w -REAL, SAVE :: a, p, c, uf, vr, d - -IF (s <= zero .OR. s >= one) THEN - WRITE(*, *) 'SHAPE PARAMETER VALUE OUTSIDE PERMITTED RANGE' - STOP -END IF - -IF (first) THEN ! Initialization, if necessary - a = one - s - p = a/(a + s*EXP(-a)) - IF (s < vsmall) THEN - WRITE(*, *) 'SHAPE PARAMETER VALUE TOO SMALL' - STOP - END IF - c = one/s - uf = p*(vsmall/a)**s - vr = one - vsmall - d = a*LOG(a) -END IF - -DO - CALL RANDOM_NUMBER(r) - IF (r >= vr) THEN - CYCLE - ELSE IF (r > p) THEN - x = a - LOG((one - r)/(one - p)) - w = a*LOG(x)-d - ELSE IF (r > uf) THEN - x = a*(r/p)**c - w = x - ELSE - fn_val = zero - RETURN - END IF - - CALL RANDOM_NUMBER(r) - IF (one-r <= w .AND. r > zero) THEN - IF (r*(w + one) >= one) CYCLE - IF (-LOG(r) <= w) CYCLE - END IF - EXIT -END DO - -fn_val = x -RETURN - -END FUNCTION random_gamma2 - - - -FUNCTION random_chisq(ndf, first) RESULT(fn_val) - -! Generates a random variate from the chi-squared distribution with -! ndf degrees of freedom - -INTEGER, INTENT(IN) :: ndf -LOGICAL, INTENT(IN) :: first -REAL :: fn_val - -fn_val = two * random_gamma(half*ndf, first) -RETURN - -END FUNCTION random_chisq - - - -FUNCTION random_exponential() RESULT(fn_val) - -! Adapted from Fortran 77 code from the book: -! Dagpunar, J. 'Principles of random variate generation' -! Clarendon Press, Oxford, 1988. ISBN 0-19-852202-9 - -! FUNCTION GENERATES A RANDOM VARIATE IN [0,INFINITY) FROM -! A NEGATIVE EXPONENTIAL DlSTRIBUTION WlTH DENSITY PROPORTIONAL -! TO EXP(-random_exponential), USING INVERSION. - -REAL :: fn_val - -! Local variable -REAL :: r - -DO - CALL RANDOM_NUMBER(r) - IF (r > zero) EXIT -END DO - -fn_val = -LOG(r) -RETURN - -END FUNCTION random_exponential - - - -FUNCTION random_Weibull(a) RESULT(fn_val) - -! Generates a random variate from the Weibull distribution with -! probability density: -! a -! a-1 -x -! f(x) = a.x e - -REAL, INTENT(IN) :: a -REAL :: fn_val - -! For speed, there is no checking that a is not zero or very small. - -fn_val = random_exponential() ** (one/a) -RETURN - -END FUNCTION random_Weibull - - - -FUNCTION random_beta(aa, bb, first) RESULT(fn_val) - -! Adapted from Fortran 77 code from the book: -! Dagpunar, J. 'Principles of random variate generation' -! Clarendon Press, Oxford, 1988. ISBN 0-19-852202-9 - -! FUNCTION GENERATES A RANDOM VARIATE IN [0,1] -! FROM A BETA DISTRIBUTION WITH DENSITY -! PROPORTIONAL TO BETA**(AA-1) * (1-BETA)**(BB-1). -! USING CHENG'S LOG LOGISTIC METHOD. - -! AA = SHAPE PARAMETER FROM DISTRIBUTION (0 < REAL) -! BB = SHAPE PARAMETER FROM DISTRIBUTION (0 < REAL) - -REAL, INTENT(IN) :: aa, bb -LOGICAL, INTENT(IN) :: first -REAL :: fn_val - -! Local variables -REAL, PARAMETER :: aln4 = 1.3862944 -REAL :: a, b, g, r, s, x, y, z -REAL, SAVE :: d, f, h, t, c -LOGICAL, SAVE :: swap - -IF (aa <= zero .OR. bb <= zero) THEN - WRITE(*, *) 'IMPERMISSIBLE SHAPE PARAMETER VALUE(S)' - STOP -END IF - -IF (first) THEN ! Initialization, if necessary - a = aa - b = bb - swap = b > a - IF (swap) THEN - g = b - b = a - a = g - END IF - d = a/b - f = a+b - IF (b > one) THEN - h = SQRT((two*a*b - f)/(f - two)) - t = one - ELSE - h = b - t = one/(one + (a/(vlarge*b))**b) - END IF - c = a+h -END IF - -DO - CALL RANDOM_NUMBER(r) - CALL RANDOM_NUMBER(x) - s = r*r*x - IF (r < vsmall .OR. s <= zero) CYCLE - IF (r < t) THEN - x = LOG(r/(one - r))/h - y = d*EXP(x) - z = c*x + f*LOG((one + d)/(one + y)) - aln4 - IF (s - one > z) THEN - IF (s - s*z > one) CYCLE - IF (LOG(s) > z) CYCLE - END IF - fn_val = y/(one + y) - ELSE - IF (4.0*s > (one + one/d)**f) CYCLE - fn_val = one - END IF - EXIT -END DO - -IF (swap) fn_val = one - fn_val -RETURN -END FUNCTION random_beta - - - -FUNCTION random_t(m) RESULT(fn_val) - -! Adapted from Fortran 77 code from the book: -! Dagpunar, J. 'Principles of random variate generation' -! Clarendon Press, Oxford, 1988. ISBN 0-19-852202-9 - -! FUNCTION GENERATES A RANDOM VARIATE FROM A -! T DISTRIBUTION USING KINDERMAN AND MONAHAN'S RATIO METHOD. - -! M = DEGREES OF FREEDOM OF DISTRIBUTION -! (1 <= 1NTEGER) - -INTEGER, INTENT(IN) :: m -REAL :: fn_val - -! Local variables -REAL, SAVE :: s, c, a, f, g -REAL :: r, x, v - -REAL, PARAMETER :: three = 3.0, four = 4.0, quart = 0.25, & - five = 5.0, sixteen = 16.0 -INTEGER :: mm = 0 - -IF (m < 1) THEN - WRITE(*, *) 'IMPERMISSIBLE DEGREES OF FREEDOM' - STOP -END IF - -IF (m /= mm) THEN ! Initialization, if necessary - s = m - c = -quart*(s + one) - a = four/(one + one/s)**c - f = sixteen/a - IF (m > 1) THEN - g = s - one - g = ((s + one)/g)**c*SQRT((s+s)/g) - ELSE - g = one - END IF - mm = m -END IF - -DO - CALL RANDOM_NUMBER(r) - IF (r <= zero) CYCLE - CALL RANDOM_NUMBER(v) - x = (two*v - one)*g/r - v = x*x - IF (v > five - a*r) THEN - IF (m >= 1 .AND. r*(v + three) > f) CYCLE - IF (r > (one + v/s)**c) CYCLE - END IF - EXIT -END DO - -fn_val = x -RETURN -END FUNCTION random_t - - - -SUBROUTINE random_mvnorm(n, h, d, f, first, x, ier) - -! Adapted from Fortran 77 code from the book: -! Dagpunar, J. 'Principles of random variate generation' -! Clarendon Press, Oxford, 1988. ISBN 0-19-852202-9 - -! N.B. An extra argument, ier, has been added to Dagpunar's routine - -! SUBROUTINE GENERATES AN N VARIATE RANDOM NORMAL -! VECTOR USING A CHOLESKY DECOMPOSITION. - -! ARGUMENTS: -! N = NUMBER OF VARIATES IN VECTOR -! (INPUT,INTEGER >= 1) -! H(J) = J'TH ELEMENT OF VECTOR OF MEANS -! (INPUT,REAL) -! X(J) = J'TH ELEMENT OF DELIVERED VECTOR -! (OUTPUT,REAL) -! -! D(J*(J-1)/2+I) = (I,J)'TH ELEMENT OF VARIANCE MATRIX (J> = I) -! (INPUT,REAL) -! F((J-1)*(2*N-J)/2+I) = (I,J)'TH ELEMENT OF LOWER TRIANGULAR -! DECOMPOSITION OF VARIANCE MATRIX (J <= I) -! (OUTPUT,REAL) - -! FIRST = .TRUE. IF THIS IS THE FIRST CALL OF THE ROUTINE -! OR IF THE DISTRIBUTION HAS CHANGED SINCE THE LAST CALL OF THE ROUTINE. -! OTHERWISE SET TO .FALSE. -! (INPUT,LOGICAL) - -! ier = 1 if the input covariance matrix is not +ve definite -! = 0 otherwise - -INTEGER, INTENT(IN) :: n -REAL, INTENT(IN) :: h(:), d(:) ! d(n*(n+1)/2) -REAL, INTENT(IN OUT) :: f(:) ! f(n*(n+1)/2) -REAL, INTENT(OUT) :: x(:) -LOGICAL, INTENT(IN) :: first -INTEGER, INTENT(OUT) :: ier - -! Local variables -INTEGER :: j, i, m -REAL :: y, v -INTEGER, SAVE :: n2 - -IF (n < 1) THEN - WRITE(*, *) 'SIZE OF VECTOR IS NON POSITIVE' - STOP -END IF - -ier = 0 -IF (first) THEN ! Initialization, if necessary - n2 = 2*n - IF (d(1) < zero) THEN - ier = 1 - RETURN - END IF - - f(1) = SQRT(d(1)) - y = one/f(1) - DO j = 2,n - f(j) = d(1+j*(j-1)/2) * y - END DO - - DO i = 2,n - v = d(i*(i-1)/2+i) - DO m = 1,i-1 - v = v - f((m-1)*(n2-m)/2+i)**2 - END DO - - IF (v < zero) THEN - ier = 1 - RETURN - END IF - - v = SQRT(v) - y = one/v - f((i-1)*(n2-i)/2+i) = v - DO j = i+1,n - v = d(j*(j-1)/2+i) - DO m = 1,i-1 - v = v - f((m-1)*(n2-m)/2+i)*f((m-1)*(n2-m)/2 + j) - END DO ! m = 1,i-1 - f((i-1)*(n2-i)/2 + j) = v*y - END DO ! j = i+1,n - END DO ! i = 2,n -END IF - -x(1:n) = h(1:n) -DO j = 1,n - y = random_normal() - DO i = j,n - x(i) = x(i) + f((j-1)*(n2-j)/2 + i) * y - END DO ! i = j,n -END DO ! j = 1,n - -RETURN -END SUBROUTINE random_mvnorm - - - -FUNCTION random_inv_gauss(h, b, first) RESULT(fn_val) - -! Adapted from Fortran 77 code from the book: -! Dagpunar, J. 'Principles of random variate generation' -! Clarendon Press, Oxford, 1988. ISBN 0-19-852202-9 - -! FUNCTION GENERATES A RANDOM VARIATE IN [0,INFINITY] FROM -! A REPARAMETERISED GENERALISED INVERSE GAUSSIAN (GIG) DISTRIBUTION -! WITH DENSITY PROPORTIONAL TO GIG**(H-1) * EXP(-0.5*B*(GIG+1/GIG)) -! USING A RATIO METHOD. - -! H = PARAMETER OF DISTRIBUTION (0 <= REAL) -! B = PARAMETER OF DISTRIBUTION (0 < REAL) - -REAL, INTENT(IN) :: h, b -LOGICAL, INTENT(IN) :: first -REAL :: fn_val - -! Local variables -REAL :: ym, xm, r, w, r1, r2, x -REAL, SAVE :: a, c, d, e -REAL, PARAMETER :: quart = 0.25 - -IF (h < zero .OR. b <= zero) THEN - WRITE(*, *) 'IMPERMISSIBLE DISTRIBUTION PARAMETER VALUES' - STOP -END IF - -IF (first) THEN ! Initialization, if necessary - IF (h > quart*b*SQRT(vlarge)) THEN - WRITE(*, *) 'THE RATIO H:B IS TOO SMALL' - STOP - END IF - e = b*b - d = h + one - ym = (-d + SQRT(d*d + e))/b - IF (ym < vsmall) THEN - WRITE(*, *) 'THE VALUE OF B IS TOO SMALL' - STOP - END IF - - d = h - one - xm = (d + SQRT(d*d + e))/b - d = half*d - e = -quart*b - r = xm + one/xm - w = xm*ym - a = w**(-half*h) * SQRT(xm/ym) * EXP(-e*(r - ym - one/ym)) - IF (a < vsmall) THEN - WRITE(*, *) 'THE VALUE OF H IS TOO LARGE' - STOP - END IF - c = -d*LOG(xm) - e*r -END IF - -DO - CALL RANDOM_NUMBER(r1) - IF (r1 <= zero) CYCLE - CALL RANDOM_NUMBER(r2) - x = a*r2/r1 - IF (x <= zero) CYCLE - IF (LOG(r1) < d*LOG(x) + e*(x + one/x) + c) EXIT -END DO - -fn_val = x - -RETURN -END FUNCTION random_inv_gauss - - - -FUNCTION random_Poisson(mu, first) RESULT(ival) -!********************************************************************** -! Translated to Fortran 90 by Alan Miller from: -! RANLIB -! -! Library of Fortran Routines for Random Number Generation -! -! Compiled and Written by: -! -! Barry W. Brown -! James Lovato -! -! Department of Biomathematics, Box 237 -! The University of Texas, M.D. Anderson Cancer Center -! 1515 Holcombe Boulevard -! Houston, TX 77030 -! -! This work was supported by grant CA-16672 from the National Cancer Institute. - -! GENerate POIsson random deviate - -! Function - -! Generates a single random deviate from a Poisson distribution with mean mu. - -! Arguments - -! mu --> The mean of the Poisson distribution from which -! a random deviate is to be generated. -! REAL mu - -! Method - -! For details see: - -! Ahrens, J.H. and Dieter, U. -! Computer Generation of Poisson Deviates -! From Modified Normal Distributions. -! ACM Trans. Math. Software, 8, 2 -! (June 1982),163-179 - -! TABLES: COEFFICIENTS A0-A7 FOR STEP F. FACTORIALS FACT -! COEFFICIENTS A(K) - FOR PX = FK*V*V*SUM(A(K)*V**K)-DEL - -! SEPARATION OF CASES A AND B - -! .. Scalar Arguments .. -REAL, INTENT(IN) :: mu -LOGICAL, INTENT(IN) :: first -INTEGER :: ival -! .. -! .. Local Scalars .. -REAL :: b1, b2, c, c0, c1, c2, c3, del, difmuk, e, fk, fx, fy, g, & - omega, px, py, t, u, v, x, xx -REAL, SAVE :: s, d, p, q, p0 -INTEGER :: j, k, kflag -LOGICAL, SAVE :: full_init -INTEGER, SAVE :: l, m -! .. -! .. Local Arrays .. -REAL, SAVE :: pp(35) -! .. -! .. Data statements .. -REAL, PARAMETER :: a0 = -.5, a1 = .3333333, a2 = -.2500068, a3 = .2000118, & - a4 = -.1661269, a5 = .1421878, a6 = -.1384794, & - a7 = .1250060 - -REAL, PARAMETER :: fact(10) = (/ 1., 1., 2., 6., 24., 120., 720., 5040., & - 40320., 362880. /) - -! .. -! .. Executable Statements .. -IF (mu > 10.0) THEN -! C A S E A. (RECALCULATION OF S, D, L IF MU HAS CHANGED) - - IF (first) THEN - s = SQRT(mu) - d = 6.0*mu*mu - -! THE POISSON PROBABILITIES PK EXCEED THE DISCRETE NORMAL -! PROBABILITIES FK WHENEVER K >= M(MU). L=IFIX(MU-1.1484) -! IS AN UPPER BOUND TO M(MU) FOR ALL MU >= 10 . - - l = mu - 1.1484 - full_init = .false. - END IF - - -! STEP N. NORMAL SAMPLE - random_normal() FOR STANDARD NORMAL DEVIATE - - g = mu + s*random_normal() - IF (g > 0.0) THEN - ival = g - -! STEP I. IMMEDIATE ACCEPTANCE IF ival IS LARGE ENOUGH - - IF (ival>=l) RETURN - -! STEP S. SQUEEZE ACCEPTANCE - SAMPLE U - - fk = ival - difmuk = mu - fk - CALL RANDOM_NUMBER(u) - IF (d*u >= difmuk*difmuk*difmuk) RETURN - END IF - -! STEP P. PREPARATIONS FOR STEPS Q AND H. -! (RECALCULATIONS OF PARAMETERS IF NECESSARY) -! .3989423=(2*PI)**(-.5) .416667E-1=1./24. .1428571=1./7. -! THE QUANTITIES B1, B2, C3, C2, C1, C0 ARE FOR THE HERMITE -! APPROXIMATIONS TO THE DISCRETE NORMAL PROBABILITIES FK. -! C=.1069/MU GUARANTEES MAJORIZATION BY THE 'HAT'-FUNCTION. - - IF (.NOT. full_init) THEN - omega = .3989423/s - b1 = .4166667E-1/mu - b2 = .3*b1*b1 - c3 = .1428571*b1*b2 - c2 = b2 - 15.*c3 - c1 = b1 - 6.*b2 + 45.*c3 - c0 = 1. - b1 + 3.*b2 - 15.*c3 - c = .1069/mu - full_init = .true. - END IF - - IF (g < 0.0) GO TO 50 - -! 'SUBROUTINE' F IS CALLED (KFLAG=0 FOR CORRECT RETURN) - - kflag = 0 - GO TO 70 - -! STEP Q. QUOTIENT ACCEPTANCE (RARE CASE) - - 40 IF (fy-u*fy <= py*EXP(px-fx)) RETURN - -! STEP E. EXPONENTIAL SAMPLE - random_exponential() FOR STANDARD EXPONENTIAL -! DEVIATE E AND SAMPLE T FROM THE LAPLACE 'HAT' -! (IF T <= -.6744 THEN PK < FK FOR ALL MU >= 10.) - - 50 e = random_exponential() - CALL RANDOM_NUMBER(u) - u = u + u - one - t = 1.8 + SIGN(e, u) - IF (t <= (-.6744)) GO TO 50 - ival = mu + s*t - fk = ival - difmuk = mu - fk - -! 'SUBROUTINE' F IS CALLED (KFLAG=1 FOR CORRECT RETURN) - - kflag = 1 - GO TO 70 - -! STEP H. HAT ACCEPTANCE (E IS REPEATED ON REJECTION) - - 60 IF (c*ABS(u) > py*EXP(px+e) - fy*EXP(fx+e)) GO TO 50 - RETURN - -! STEP F. 'SUBROUTINE' F. CALCULATION OF PX, PY, FX, FY. -! CASE ival < 10 USES FACTORIALS FROM TABLE FACT - - 70 IF (ival>=10) GO TO 80 - px = -mu - py = mu**ival/fact(ival+1) - GO TO 110 - -! CASE ival >= 10 USES POLYNOMIAL APPROXIMATION -! A0-A7 FOR ACCURACY WHEN ADVISABLE -! .8333333E-1=1./12. .3989423=(2*PI)**(-.5) - - 80 del = .8333333E-1/fk - del = del - 4.8*del*del*del - v = difmuk/fk - IF (ABS(v)>0.25) THEN - px = fk*LOG(one + v) - difmuk - del - ELSE - px = fk*v*v* (((((((a7*v+a6)*v+a5)*v+a4)*v+a3)*v+a2)*v+a1)*v+a0) - del - END IF - py = .3989423/SQRT(fk) - 110 x = (half - difmuk)/s - xx = x*x - fx = -half*xx - fy = omega* (((c3*xx + c2)*xx + c1)*xx + c0) - IF (kflag <= 0) GO TO 40 - GO TO 60 - -!--------------------------------------------------------------------------- -! C A S E B. mu < 10 -! START NEW TABLE AND CALCULATE P0 IF NECESSARY - -ELSE - IF (first) THEN - m = MAX(1, INT(mu)) - l = 0 - p = EXP(-mu) - q = p - p0 = p - END IF - -! STEP U. UNIFORM SAMPLE FOR INVERSION METHOD - - DO - CALL RANDOM_NUMBER(u) - ival = 0 - IF (u <= p0) RETURN - -! STEP T. TABLE COMPARISON UNTIL THE END PP(L) OF THE -! PP-TABLE OF CUMULATIVE POISSON PROBABILITIES -! (0.458=PP(9) FOR MU=10) - - IF (l == 0) GO TO 150 - j = 1 - IF (u > 0.458) j = MIN(l, m) - DO k = j, l - IF (u <= pp(k)) GO TO 180 - END DO - IF (l == 35) CYCLE - -! STEP C. CREATION OF NEW POISSON PROBABILITIES P -! AND THEIR CUMULATIVES Q=PP(K) - - 150 l = l + 1 - DO k = l, 35 - p = p*mu / k - q = q + p - pp(k) = q - IF (u <= q) GO TO 170 - END DO - l = 35 - END DO - - 170 l = k - 180 ival = k - RETURN -END IF - -RETURN -END FUNCTION random_Poisson - - - -FUNCTION random_binomial1(n, p, first) RESULT(ival) - -! FUNCTION GENERATES A RANDOM BINOMIAL VARIATE USING C.D.Kemp's method. -! This algorithm is suitable when many random variates are required -! with the SAME parameter values for n & p. - -! P = BERNOULLI SUCCESS PROBABILITY -! (0 <= REAL <= 1) -! N = NUMBER OF BERNOULLI TRIALS -! (1 <= INTEGER) -! FIRST = .TRUE. for the first call using the current parameter values -! = .FALSE. if the values of (n,p) are unchanged from last call - -! Reference: Kemp, C.D. (1986). `A modal method for generating binomial -! variables', Commun. Statist. - Theor. Meth. 15(3), 805-813. - -INTEGER, INTENT(IN) :: n -REAL, INTENT(IN) :: p -LOGICAL, INTENT(IN) :: first -INTEGER :: ival - -! Local variables - -INTEGER :: ru, rd -INTEGER, SAVE :: r0 -REAL :: u, pd, pu -REAL, SAVE :: odds_ratio, p_r -REAL, PARAMETER :: zero = 0.0, one = 1.0 - -IF (first) THEN - r0 = (n+1)*p - p_r = bin_prob(n, p, r0) - odds_ratio = p / (one - p) -END IF - -CALL RANDOM_NUMBER(u) -u = u - p_r -IF (u < zero) THEN - ival = r0 - RETURN -END IF - -pu = p_r -ru = r0 -pd = p_r -rd = r0 -DO - rd = rd - 1 - IF (rd >= 0) THEN - pd = pd * (rd+1) / (odds_ratio * (n-rd)) - u = u - pd - IF (u < zero) THEN - ival = rd - RETURN - END IF - END IF - - ru = ru + 1 - IF (ru <= n) THEN - pu = pu * (n-ru+1) * odds_ratio / ru - u = u - pu - IF (u < zero) THEN - ival = ru - RETURN - END IF - END IF -END DO - -! This point should not be reached, but just in case: - -ival = r0 -RETURN - -END FUNCTION random_binomial1 - - - -FUNCTION bin_prob(n, p, r) RESULT(fn_val) -! Calculate a binomial probability - -INTEGER, INTENT(IN) :: n, r -REAL, INTENT(IN) :: p -REAL :: fn_val - -! Local variable -REAL :: one = 1.0 - -fn_val = EXP( lngamma(DBLE(n+1)) - lngamma(DBLE(r+1)) - lngamma(DBLE(n-r+1)) & - + r*LOG(p) + (n-r)*LOG(one - p) ) -RETURN - -END FUNCTION bin_prob - - - -FUNCTION lngamma(x) RESULT(fn_val) - -! Logarithm to base e of the gamma function. -! -! Accurate to about 1.e-14. -! Programmer: Alan Miller - -! Latest revision of Fortran 77 version - 28 February 1988 - -REAL (dp), INTENT(IN) :: x -REAL (dp) :: fn_val - -! Local variables - -REAL (dp) :: a1 = -4.166666666554424D-02, a2 = 2.430554511376954D-03, & - a3 = -7.685928044064347D-04, a4 = 5.660478426014386D-04, & - temp, arg, product, lnrt2pi = 9.189385332046727D-1, & - pi = 3.141592653589793D0 -LOGICAL :: reflect - -! lngamma is not defined if x = 0 or a negative integer. - -IF (x > 0.d0) GO TO 10 -IF (x /= INT(x)) GO TO 10 -fn_val = 0.d0 -RETURN - -! If x < 0, use the reflection formula: -! gamma(x) * gamma(1-x) = pi * cosec(pi.x) - -10 reflect = (x < 0.d0) -IF (reflect) THEN - arg = 1.d0 - x -ELSE - arg = x -END IF - -! Increase the argument, if necessary, to make it > 10. - -product = 1.d0 -20 IF (arg <= 10.d0) THEN - product = product * arg - arg = arg + 1.d0 - GO TO 20 -END IF - -! Use a polynomial approximation to Stirling's formula. -! N.B. The real Stirling's formula is used here, not the simpler, but less -! accurate formula given by De Moivre in a letter to Stirling, which -! is the one usually quoted. - -arg = arg - 0.5D0 -temp = 1.d0/arg**2 -fn_val = lnrt2pi + arg * (LOG(arg) - 1.d0 + & - (((a4*temp + a3)*temp + a2)*temp + a1)*temp) - LOG(product) -IF (reflect) THEN - temp = SIN(pi * x) - fn_val = LOG(pi/temp) - fn_val -END IF -RETURN -END FUNCTION lngamma - - - -FUNCTION random_binomial2(n, pp, first) RESULT(ival) -!********************************************************************** -! Translated to Fortran 90 by Alan Miller from: -! RANLIB -! -! Library of Fortran Routines for Random Number Generation -! -! Compiled and Written by: -! -! Barry W. Brown -! James Lovato -! -! Department of Biomathematics, Box 237 -! The University of Texas, M.D. Anderson Cancer Center -! 1515 Holcombe Boulevard -! Houston, TX 77030 -! -! This work was supported by grant CA-16672 from the National Cancer Institute. - -! GENerate BINomial random deviate - -! Function - -! Generates a single random deviate from a binomial -! distribution whose number of trials is N and whose -! probability of an event in each trial is P. - -! Arguments - -! N --> The number of trials in the binomial distribution -! from which a random deviate is to be generated. -! INTEGER N - -! P --> The probability of an event in each trial of the -! binomial distribution from which a random deviate -! is to be generated. -! REAL P - -! FIRST --> Set FIRST = .TRUE. for the first call to perform initialization -! the set FIRST = .FALSE. for further calls using the same pair -! of parameter values (N, P). -! LOGICAL FIRST - -! random_binomial2 <-- A random deviate yielding the number of events -! from N independent trials, each of which has -! a probability of event P. -! INTEGER random_binomial - -! Method - -! This is algorithm BTPE from: - -! Kachitvichyanukul, V. and Schmeiser, B. W. -! Binomial Random Variate Generation. -! Communications of the ACM, 31, 2 (February, 1988) 216. - -!********************************************************************** - -!*****DETERMINE APPROPRIATE ALGORITHM AND WHETHER SETUP IS NECESSARY - -! .. -! .. Scalar Arguments .. -REAL, INTENT(IN) :: pp -INTEGER, INTENT(IN) :: n -LOGICAL, INTENT(IN) :: first -INTEGER :: ival -! .. -! .. Local Scalars .. -REAL :: alv, amaxp, f, f1, f2, u, v, w, w2, x, x1, x2, ynorm, z, z2 -REAL, PARAMETER :: zero = 0.0, half = 0.5, one = 1.0 -INTEGER :: i, ix, ix1, k, mp -INTEGER, SAVE :: m -REAL, SAVE :: p, q, xnp, ffm, fm, xnpq, p1, xm, xl, xr, c, al, xll, & - xlr, p2, p3, p4, qn, r, g - -! .. -! .. Executable Statements .. - -!*****SETUP, PERFORM ONLY WHEN PARAMETERS CHANGE - -IF (first) THEN - p = MIN(pp, one-pp) - q = one - p - xnp = n * p -END IF - -IF (xnp > 30.) THEN - IF (first) THEN - ffm = xnp + p - m = ffm - fm = m - xnpq = xnp * q - p1 = INT(2.195*SQRT(xnpq) - 4.6*q) + half - xm = fm + half - xl = xm - p1 - xr = xm + p1 - c = 0.134 + 20.5 / (15.3 + fm) - al = (ffm-xl) / (ffm - xl*p) - xll = al * (one + half*al) - al = (xr - ffm) / (xr*q) - xlr = al * (one + half*al) - p2 = p1 * (one + c + c) - p3 = p2 + c / xll - p4 = p3 + c / xlr - END IF - -!*****GENERATE VARIATE, Binomial mean at least 30. - - 20 CALL RANDOM_NUMBER(u) - u = u * p4 - CALL RANDOM_NUMBER(v) - -! TRIANGULAR REGION - - IF (u <= p1) THEN - ix = xm - p1 * v + u - GO TO 110 - END IF - -! PARALLELOGRAM REGION - - IF (u <= p2) THEN - x = xl + (u-p1) / c - v = v * c + one - ABS(xm-x) / p1 - IF (v > one .OR. v <= zero) GO TO 20 - ix = x - ELSE - -! LEFT TAIL - - IF (u <= p3) THEN - ix = xl + LOG(v) / xll - IF (ix < 0) GO TO 20 - v = v * (u-p2) * xll - ELSE - -! RIGHT TAIL - - ix = xr - LOG(v) / xlr - IF (ix > n) GO TO 20 - v = v * (u-p3) * xlr - END IF - END IF - -!*****DETERMINE APPROPRIATE WAY TO PERFORM ACCEPT/REJECT TEST - - k = ABS(ix-m) - IF (k <= 20 .OR. k >= xnpq/2-1) THEN - -! EXPLICIT EVALUATION - - f = one - r = p / q - g = (n+1) * r - IF (m < ix) THEN - mp = m + 1 - DO i = mp, ix - f = f * (g/i-r) - END DO - - ELSE IF (m > ix) THEN - ix1 = ix + 1 - DO i = ix1, m - f = f / (g/i-r) - END DO - END IF - - IF (v > f) THEN - GO TO 20 - ELSE - GO TO 110 - END IF - END IF - -! SQUEEZING USING UPPER AND LOWER BOUNDS ON LOG(F(X)) - - amaxp = (k/xnpq) * ((k*(k/3. + .625) + .1666666666666)/xnpq + half) - ynorm = -k * k / (2.*xnpq) - alv = LOG(v) - IF (alvynorm + amaxp) GO TO 20 - -! STIRLING'S (actually de Moivre's) FORMULA TO MACHINE ACCURACY FOR -! THE FINAL ACCEPTANCE/REJECTION TEST - - x1 = ix + 1 - f1 = fm + one - z = n + 1 - fm - w = n - ix + one - z2 = z * z - x2 = x1 * x1 - f2 = f1 * f1 - w2 = w * w - IF (alv - (xm*LOG(f1/x1) + (n-m+half)*LOG(z/w) + (ix-m)*LOG(w*p/(x1*q)) + & - (13860.-(462.-(132.-(99.-140./f2)/f2)/f2)/f2)/f1/166320. + & - (13860.-(462.-(132.-(99.-140./z2)/z2)/z2)/z2)/z/166320. + & - (13860.-(462.-(132.-(99.-140./x2)/x2)/x2)/x2)/x1/166320. + & - (13860.-(462.-(132.-(99.-140./w2)/w2)/w2)/w2)/w/166320.) > zero) THEN - GO TO 20 - ELSE - GO TO 110 - END IF - -ELSE -! INVERSE CDF LOGIC FOR MEAN LESS THAN 30 - IF (first) THEN - qn = q ** n - r = p / q - g = r * (n+1) - END IF - - 90 ix = 0 - f = qn - CALL RANDOM_NUMBER(u) - 100 IF (u >= f) THEN - IF (ix > 110) GO TO 90 - u = u - f - ix = ix + 1 - f = f * (g/ix - r) - GO TO 100 - END IF -END IF - -110 IF (pp > half) ix = n - ix -ival = ix -RETURN - -END FUNCTION random_binomial2 - - - - -FUNCTION random_neg_binomial(sk, p) RESULT(ival) - -! Adapted from Fortran 77 code from the book: -! Dagpunar, J. 'Principles of random variate generation' -! Clarendon Press, Oxford, 1988. ISBN 0-19-852202-9 - -! FUNCTION GENERATES A RANDOM NEGATIVE BINOMIAL VARIATE USING UNSTORED -! INVERSION AND/OR THE REPRODUCTIVE PROPERTY. - -! SK = NUMBER OF FAILURES REQUIRED (Dagpunar's words!) -! = the `power' parameter of the negative binomial -! (0 < REAL) -! P = BERNOULLI SUCCESS PROBABILITY -! (0 < REAL < 1) - -! THE PARAMETER H IS SET SO THAT UNSTORED INVERSION ONLY IS USED WHEN P <= H, -! OTHERWISE A COMBINATION OF UNSTORED INVERSION AND -! THE REPRODUCTIVE PROPERTY IS USED. - -REAL, INTENT(IN) :: sk, p -INTEGER :: ival - -! Local variables -! THE PARAMETER ULN = -LOG(MACHINE'S SMALLEST REAL NUMBER). - -REAL, PARAMETER :: h = 0.7 -REAL :: q, x, st, uln, v, r, s, y, g -INTEGER :: k, i, n - -IF (sk <= zero .OR. p <= zero .OR. p >= one) THEN - WRITE(*, *) 'IMPERMISSIBLE DISTRIBUTION PARAMETER VALUES' - STOP -END IF - -q = one - p -x = zero -st = sk -IF (p > h) THEN - v = one/LOG(p) - k = st - DO i = 1,k - DO - CALL RANDOM_NUMBER(r) - IF (r > zero) EXIT - END DO - n = v*LOG(r) - x = x + n - END DO - st = st - k -END IF - -s = zero -uln = -LOG(vsmall) -IF (st > -uln/LOG(q)) THEN - WRITE(*, *) ' P IS TOO LARGE FOR THIS VALUE OF SK' - STOP -END IF - -y = q**st -g = st -CALL RANDOM_NUMBER(r) -DO - IF (y > r) EXIT - r = r - y - s = s + one - y = y*p*g/s - g = g + one -END DO - -ival = x + s + half -RETURN -END FUNCTION random_neg_binomial - - - -FUNCTION random_von_Mises(k, first) RESULT(fn_val) - -! Algorithm VMD from: -! Dagpunar, J.S. (1990) `Sampling from the von Mises distribution via a -! comparison of random numbers', J. of Appl. Statist., 17, 165-168. - -! Fortran 90 code by Alan Miller -! CSIRO Division of Mathematical & Information Sciences - -! Arguments: -! k (real) parameter of the von Mises distribution. -! first (logical) set to .TRUE. the first time that the function -! is called, or the first time with a new value -! for k. When first = .TRUE., the function sets -! up starting values and may be very much slower. - -REAL, INTENT(IN) :: k -LOGICAL, INTENT(IN) :: first -REAL :: fn_val - -! Local variables - -INTEGER :: j, n -INTEGER, SAVE :: nk -REAL, PARAMETER :: pi = 3.14159265 -REAL, SAVE :: p(20), theta(0:20) -REAL :: sump, r, th, lambda, rlast -REAL (dp) :: dk - -IF (first) THEN ! Initialization, if necessary - IF (k < zero) THEN - WRITE(*, *) '** Error: argument k for random_von_Mises = ', k - RETURN - END IF - - nk = k + k + one - IF (nk > 20) THEN - WRITE(*, *) '** Error: argument k for random_von_Mises = ', k - RETURN - END IF - - dk = k - theta(0) = zero - IF (k > half) THEN - -! Set up array p of probabilities. - - sump = zero - DO j = 1, nk - IF (j < nk) THEN - theta(j) = ACOS(one - j/k) - ELSE - theta(nk) = pi - END IF - -! Numerical integration of e^[k.cos(x)] from theta(j-1) to theta(j) - - CALL integral(theta(j-1), theta(j), p(j), dk) - sump = sump + p(j) - END DO - p(1:nk) = p(1:nk) / sump - ELSE - p(1) = one - theta(1) = pi - END IF ! if k > 0.5 -END IF ! if first - -CALL RANDOM_NUMBER(r) -DO j = 1, nk - r = r - p(j) - IF (r < zero) EXIT -END DO -r = -r/p(j) - -DO - th = theta(j-1) + r*(theta(j) - theta(j-1)) - lambda = k - j + one - k*COS(th) - n = 1 - rlast = lambda - - DO - CALL RANDOM_NUMBER(r) - IF (r > rlast) EXIT - n = n + 1 - rlast = r - END DO - - IF (n .NE. 2*(n/2)) EXIT ! is n even? - CALL RANDOM_NUMBER(r) -END DO - -fn_val = SIGN(th, (r - rlast)/(one - rlast) - half) -RETURN -END FUNCTION random_von_Mises - - - -SUBROUTINE integral(a, b, result, dk) - -! Gaussian integration of exp(k.cosx) from a to b. - -REAL (dp), INTENT(IN) :: dk -REAL, INTENT(IN) :: a, b -REAL, INTENT(OUT) :: result - -! Local variables - -REAL (dp) :: xmid, range, x1, x2, & - x(3) = (/0.238619186083197_dp, 0.661209386466265_dp, 0.932469514203152_dp/), & - w(3) = (/0.467913934572691_dp, 0.360761573048139_dp, 0.171324492379170_dp/) -INTEGER :: i - -xmid = (a + b)/2._dp -range = (b - a)/2._dp - -result = 0._dp -DO i = 1, 3 - x1 = xmid + x(i)*range - x2 = xmid - x(i)*range - result = result + w(i)*(EXP(dk*COS(x1)) + EXP(dk*COS(x2))) -END DO - -result = result * range -RETURN -END SUBROUTINE integral - - - -FUNCTION random_Cauchy() RESULT(fn_val) - -! Generate a random deviate from the standard Cauchy distribution - -REAL :: fn_val - -! Local variables -REAL :: v(2) - -DO - CALL RANDOM_NUMBER(v) - v = two*(v - half) - IF (ABS(v(2)) < vsmall) CYCLE ! Test for zero - IF (v(1)**2 + v(2)**2 < one) EXIT -END DO -fn_val = v(1) / v(2) - -RETURN -END FUNCTION random_Cauchy - - - -SUBROUTINE random_order(order, n) - -! Generate a random ordering of the integers 1 ... n. - -INTEGER, INTENT(IN) :: n -INTEGER, INTENT(OUT) :: order(n) - -! Local variables - -INTEGER :: i, j, k -REAL :: wk - -DO i = 1, n - order(i) = i -END DO - -! Starting at the end, swap the current last indicator with one -! randomly chosen from those preceeding it. - -DO i = n, 2, -1 - CALL RANDOM_NUMBER(wk) - j = 1 + i * wk - IF (j < i) THEN - k = order(i) - order(i) = order(j) - order(j) = k - END IF -END DO - -RETURN -END SUBROUTINE random_order - - - -SUBROUTINE seed_random_number(iounit) - -INTEGER, INTENT(IN) :: iounit - -! Local variables - -INTEGER :: k -INTEGER, ALLOCATABLE :: seed(:) - -CALL RANDOM_SEED(SIZE=k) -ALLOCATE( seed(k) ) - -WRITE(*, '(a, i2, a)')' Enter ', k, ' integers for random no. seeds: ' -READ(*, *) seed -WRITE(iounit, '(a, (7i10))') ' Random no. seeds: ', seed -CALL RANDOM_SEED(PUT=seed) - -DEALLOCATE( seed ) - -RETURN -END SUBROUTINE seed_random_number - - -END MODULE KPP_ROOT_Random - -MODULE KPP_ROOT_Integrator - USE KPP_ROOT_Random - USE KPP_ROOT_Parameters, ONLY : NVAR, NFIX, NREACT - USE KPP_ROOT_Global, ONLY : TIME, RCONST, Volume - USE KPP_ROOT_Stoichiom - USE KPP_ROOT_Stochastic - USE KPP_ROOT_Rates - USE KPP_ROOT_Random, ddp => dp - IMPLICIT NONE - -CONTAINS - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -SUBROUTINE TauLeap(Nsteps, Tau, T, SCT, NmlcV, NmlcF) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! -! Tau-leap stochastic integration -! INPUT: -! Nsteps = no. of tau-leap steps to be simulated -! Tau = time step length -! T = time -! SCT = stochastic rate constants -! NmlcV, NmlcF = no. of molecules for variable and fixed species -! OUTPUT: -! T = updated time (after Nsteps) -! NmlcV = updated no. of molecules for variable species -! -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IMPLICIT NONE -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - KPP_REAL:: T, Tau - INTEGER :: Nsteps - INTEGER :: NmlcV(NVAR), NmlcF(NFIX) - INTEGER :: i, j, irct, id, istep, Nfirings(NREACT) - REAL :: mu - KPP_REAL :: A(NREACT), SCT(NREACT), x - LOGICAL, SAVE :: First = .TRUE. - - DO istep = 1, Nsteps - - ! Propensity vector - CALL Propensity ( NmlcV, NmlcF, SCT, A ) - - ! Index of next reaction - DO irct = 1, NREACT - mu = A(irct)*Tau - Nfirings(irct) = random_Poisson(mu, First) - First = .TRUE. - END DO - - ! Update time with the leap interval - T = T + Tau; - - ! Directly update state vector - DO irct = 1, NREACT - DO i = CCOL_STOICM(irct), CCOL_STOICM(irct+1)-1 - id = IROW_STOICM(i) - NmlcV(id) = MAX(0, NmlcV(id) + Nfirings(irct)*INT(STOICM(i))) - END DO - END DO - - ! Update state vector - ! DO irct = 1, NREACT - ! DO j = 1, Nfirings(irct) - ! CALL MoleculeChange( irct, NmlcV ) - ! END DO - ! END DO - - END DO - -CONTAINS - - SUBROUTINE PropensityTemplate( T, NmlcV, NmlcF, Prop ) - KPP_REAL, INTENT(IN) :: T - INTEGER, INTENT(IN) :: NmlcV(NVAR), NmlcF(NFIX) - KPP_REAL, INTENT(OUT) :: Prop(NREACT) - KPP_REAL :: Tsave -! Update the stochastic reaction rates, which may be time dependent - Tsave = TIME - TIME = T - CALL Update_RCONST() - CALL StochasticRates( RCONST, Volume, SCT ) - CALL Propensity ( NmlcV, NmlcF, SCT, Prop ) - TIME = Tsave - END SUBROUTINE PropensityTemplate - -END SUBROUTINE TauLeap -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -END MODULE KPP_ROOT_Integrator diff --git a/boxmox/int/user_contributed/readme b/boxmox/int/user_contributed/readme deleted file mode 100644 index c2176aa0bb9b6ac2caa6ff7050c8f0ac2e7402eb..0000000000000000000000000000000000000000 --- a/boxmox/int/user_contributed/readme +++ /dev/null @@ -1,3 +0,0 @@ -Integrators in this directory have been contributed by KPP users. By -default, KPP will not search for integrators in this directory. To -activate them, move them into the int/ directory. diff --git a/boxmox/int/user_contributed/ros2_manual.def b/boxmox/int/user_contributed/ros2_manual.def deleted file mode 100644 index 85c194bf78285656e1388abd5748ab9eced943d5..0000000000000000000000000000000000000000 --- a/boxmox/int/user_contributed/ros2_manual.def +++ /dev/null @@ -1,5 +0,0 @@ -#FUNCTION AGGREGATE -#JACOBIAN SPARSE_LU_ROW - -#DOUBLE ON -#INTFILE ros2_manual diff --git a/boxmox/int/user_contributed/ros2_manual.f90 b/boxmox/int/user_contributed/ros2_manual.f90 deleted file mode 100644 index 90b6424a41c897a71b4a164634c40c5c76e16156..0000000000000000000000000000000000000000 --- a/boxmox/int/user_contributed/ros2_manual.f90 +++ /dev/null @@ -1,119 +0,0 @@ -! Rosenbrock integrator with manual time step control -! Solve: d/dt c = f(t,c) - -! written by Edwin Spee, CWI, Amsterdam. Last update: July 28, 1997 -! email: Edwin.Spee@cwi.nl (http://edwin-spee.mypage.org/) -! adapted to KPP-2.1 by Rolf Sander, Max-Planck Institute, Mainz, Germany, 2005 -! -! Integration method for Ros2: -! C_{n+1} = C_n + 3/2 dt k_1 + 1/2 dt k_2 -! k_1 = S f(t_n, C_n) -! k_2 = S [f(t_{n+1},C_n + dt k_1) - 2 k_1] -! -! where g = 1.0 + sqrt(0.5_dp), -! S = (I - g dt J ) ^ {-1} -! with J the Jacobian - -MODULE KPP_ROOT_Integrator - - USE KPP_ROOT_Precision, ONLY: dp - - IMPLICIT NONE - PUBLIC - SAVE - - ! description of the error numbers IERR - CHARACTER(LEN=50), PARAMETER, DIMENSION(1) :: IERR_NAMES = (/ & - 'dummy value ' /) - -CONTAINS - - ! ************************************************************************** - - SUBROUTINE INTEGRATE( TIN, TOUT, & - ICNTRL_U, RCNTRL_U, ISTATUS_U, RSTATUS_U, IERR_U ) - - IMPLICIT NONE - - KPP_REAL, INTENT(IN) :: TIN ! TIN - Start Time - KPP_REAL, INTENT(IN) :: TOUT ! TOUT - End Time - ! Optional input parameters and statistics - INTEGER, INTENT(IN), OPTIONAL :: ICNTRL_U(20) - KPP_REAL, INTENT(IN), OPTIONAL :: RCNTRL_U(20) - INTEGER, INTENT(OUT), OPTIONAL :: ISTATUS_U(20) - KPP_REAL, INTENT(OUT), OPTIONAL :: RSTATUS_U(20) - INTEGER, INTENT(OUT), OPTIONAL :: IERR_U - - CALL ROS2(TIN, TOUT) - - ! if optional parameters are given for output - ! use them to store information in them - IF (PRESENT(ISTATUS_U)) ISTATUS_U(:) = 0 - IF (PRESENT(RSTATUS_U)) THEN - RSTATUS_U(:) = 0._dp - RSTATUS_U(1)=TOUT ! put final time into RSTATUS_U - ENDIF - IF (PRESENT(IERR_U)) IERR_U = 1 ! dummy value - - END SUBROUTINE INTEGRATE - - ! ************************************************************************** - - SUBROUTINE ROS2(Tstart,Tend) - - USE KPP_ROOT_Jacobian, ONLY: Jac_SP - USE KPP_ROOT_Global, ONLY: VAR, & ! VARiable species - FIX, & ! FIXed species - RCONST ! rate coefficients - USE KPP_ROOT_JacobianSP, ONLY: LU_DIAG - USE KPP_ROOT_Function, ONLY: Fun - USE KPP_ROOT_LinearAlgebra, ONLY: KppDecomp, KppSolve - USE KPP_ROOT_Parameters, ONLY: NVAR, LU_NONZERO - - IMPLICIT NONE - - KPP_REAL, INTENT(IN) :: Tstart, Tend - - KPP_REAL :: dt ! time step - KPP_REAL :: k1(NVAR), k2(NVAR), w1(NVAR), g, jvs(LU_NONZERO) - INTEGER ising, i - - dt = Tend - Tstart - g = 1.0 + SQRT(0.5_dp) - CALL JAC_sp(VAR, FIX, RCONST, jvs) - jvs(1:LU_NONZERO) = -g*dt*jvs(1:LU_NONZERO) - - ! Rolf von Kuhlmann: - ! optionally cut this out and replace it by directly addressed statements - DO i=1,NVAR - jvs(LU_DIAG(i)) = jvs(LU_DIAG(i)) + 1.0_dp - END DO - - CALL KppDecomp (jvs, ising) - - IF (ising /= 0) THEN - PRINT *,'ising <> 0, dt=',dt - STOP - END IF - - CALL Fun(VAR, FIX, RCONST, k1 ) - - CALL KppSolve (jvs,k1) - - DO i = 1,NVAR - w1(i) = MAX(0.0_dp, VAR(i) + dt * k1(i) ) - END DO - - CALL Fun(w1, FIX, RCONST, k2 ) - - k2(1:NVAR) = k2(1:NVAR) - 2.0_dp*k1(1:NVAR) - CALL KppSolve (jvs,k2) - DO i = 1,NVAR - VAR(i) = MAX( 0.0_dp, VAR(i)+1.5_dp*dt*k1(i)+0.5_dp*dt*k2(i) ) - END DO - - END SUBROUTINE ROS2 - - ! ************************************************************************** - -END MODULE KPP_ROOT_Integrator diff --git a/boxmox/readme b/boxmox/readme deleted file mode 100644 index d777b6b9f1e50ba1754591d4cdb0f1bd9aed1cab..0000000000000000000000000000000000000000 --- a/boxmox/readme +++ /dev/null @@ -1,65 +0,0 @@ -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - KPP - symbolic chemistry Kinetics PreProcessor, Version 2.1 - (http://www.cs.vt.edu/~asandu/Software/KPP) - KPP is distributed under GPL, the general public licence - (http://www.gnu.org/copyleft/gpl.html) - (C) 1995-1997, V. Damian & A. Sandu, CGRER, Univ. Iowa - (C) 1997-2005, A. Sandu, Michigan Tech, Virginia Tech - with contributions from: - R. Sander, Max-Planck Institute for Chemistry, Mainz, Germany - -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -To get started with KPP: Read user's manual (doc/kpp-UserManual.pdf) ------------------------- - -To install KPP: ---------------- - -1. Make sure that FLEX (public domain lexical analizer) is installed - on your machine. Type "flex --version" to test this. - -2. Note down the exact path name where the FLEX library is installed. The - library is called: - libfl.a or libfl.sh - -3. Define the KPP_HOME environment variable to point to the complete - path location of KPP. If, for example, KPP is installed in $HOME/kpp: - - - with C shell (or tcsh) edit the file .cshrc (or .tcshrc) in your - home directory and add: - setenv KPP_HOME $HOME/kpp - set path=( $path $HOME/kpp/bin ) - Execute 'source .cshrc' (or 'source .tcshrc') to make sure these - changes are in effect. - - - with bash shell edit the file .bashrc in your home directory and add: - export KPP_HOME=$HOME/kpp - export PATH=$PATH:$HOME/kpp/bin - -3. In KPP_HOME directory edit: - Makefile.defs - and follow the instructions included to specify the compiler, - the location of the FLEX library, etc. - -4. In KPP_HOME directory build the sources using: - make - -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -To clean the KPP installation: ------------------------------- - -1. Delete the KPP object files with: - make clean - -2. Delete the whole distribution (including the KPP binaries) with: - make distclean - -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -If you have any problems please send the detailed error report and the machine -environment to: - - sandu@cs.vt.edu diff --git a/boxmox/site-lisp/kpp.el b/boxmox/site-lisp/kpp.el deleted file mode 100644 index b01020c628b682075a559ada3cd97b89035c5c8b..0000000000000000000000000000000000000000 --- a/boxmox/site-lisp/kpp.el +++ /dev/null @@ -1,130 +0,0 @@ -;; kpp.el --- kpp mode for GNU Emacs 21 -;; (c) Rolf Sander -;; Time-stamp: <2005-02-15 15:18:42 sander> - -;; to activate it copy kpp.el to a place where emacs can find it and then -;; add "(require 'kpp)" to your .emacs startup file - -;; known problem: -;; ":" inside comments between reaction products confuses font-lock - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2 of the License, or -;; (at your option) any later version. -;; 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 General Public License for more details. - -;; start kpp-mode automatically when loading a *.eqn, *.spc, or *.kpp file -(setq auto-mode-alist - (cons '("\\.eqn\\'" . kpp-mode) auto-mode-alist)) -(setq auto-mode-alist - (cons '("\\.spc\\'" . kpp-mode) auto-mode-alist)) -(setq auto-mode-alist - (cons '("\\.kpp\\'" . kpp-mode) auto-mode-alist)) - -(setq kpp-font-lock-keywords - (list - '("^\\([^=\n]*=[^:\n]*\\):[^;\n]*;" 1 font-lock-constant-face) ; reaction - ;; alternatively, use another color for rate constant: - ;; '("^\\([^=\n]*=[^:\n]*\\):\\([^;\n]*\\);" - ;; (1 font-lock-constant-face) (2 font-lock-keyword-face)) - '("<[A-z0-9_#]+>" 0 font-lock-variable-name-face t) ; equation tag - '("{[^}\n]*}" 0 font-lock-comment-face t) ; comment - '("!.*" 0 font-lock-comment-face t) ; f90 comment - '("{@[^}]+}" 0 font-lock-doc-face t) ; alternative LaTeX text - '("{$[^}]+}" 0 font-lock-string-face t) ; alternative LaTeX text - '("{&[^}]+}" 0 font-lock-builtin-face t) ; BibTeX reference - '("{%[A-z0-9#]+}" 0 font-lock-type-face t) ; marker - ;; KPP sections (Tab. 3 in thesis), commands (Tab. 13 in thesis), and - ;; fragments (Tab. 17 in thesis) - (cons (concat - "\\(#ATOMS\\|#CHECKALL\\|#CHECK\\|#DEFFIX\\|#DEFRAD" - "\\|#DEFVAR\\|#DOUBLE\\|#DRIVER\\|#DUMMYINDEX" - "\\|#ENDINLINE\\|#EQNTAGS\\|#EQUATIONS\\|#FUNCTION" - "\\|#HESSIAN\\|#INCLUDE\\|#INITIALIZE" - "\\|#INITVALUES\\|#INLINE\\|#INTEGRATOR\\|#INTFILE" - "\\|#JACOBIAN\\|#LANGUAGE\\|#LOOKATALL" - "\\|#LOOKAT\\|#LUMP\\|#MEX\\|#MODEL\\|#MONITOR" - "\\|#REORDER\\|#RUN\\|#SETFIX\\|#SETRAD\\|#SETVAR" - "\\|#SPARSEDATA\\|#STOCHASTIC\\|#STOICMAT\\|#TRANSPORTALL" - "\\|#TRANSPORT\\|#USE\\|#USES\\|#WRITE_ATM" - "\\|#WRITE_MAT\\|#WRITE_OPT\\|#WRITE_SPC" - "\\|#XGRID\\|#YGRID\\|#ZGRID\\)" - ) 'font-lock-keyword-face) - '("^//.*" 0 font-lock-comment-face t) ; comment - ) -) - -; comment a region (adopted from wave-comment-region) - -(defvar kpp-comment-region "// " - "*String inserted by \\[kpp-comment-region] at start of each line in region.") - -(defun kpp-comment-region (beg-region end-region arg) - "Comments every line in the region. -Puts kpp-comment-region at the beginning of every line in the region. -BEG-REGION and END-REGION are args which specify the region boundaries. -With non-nil ARG, uncomments the region." - (interactive "*r\nP") - (let ((end-region-mark (make-marker)) (save-point (point-marker))) - (set-marker end-region-mark end-region) - (goto-char beg-region) - (beginning-of-line) - (if (not arg) ;comment the region - (progn (insert kpp-comment-region) - (while (and (= (forward-line 1) 0) - (< (point) end-region-mark)) - (insert kpp-comment-region))) - (let ((com (regexp-quote kpp-comment-region))) ;uncomment the region - (if (looking-at com) - (delete-region (point) (match-end 0))) - (while (and (= (forward-line 1) 0) - (< (point) end-region-mark)) - (if (looking-at com) - (delete-region (point) (match-end 0)))))) - (goto-char save-point) - (set-marker end-region-mark nil) - (set-marker save-point nil))) - -(defvar kpp-mode-map () - "Keymap used in kpp mode.") - -(if kpp-mode-map - () - (setq kpp-mode-map (make-sparse-keymap)) - (define-key kpp-mode-map "\C-c;" 'kpp-comment-region) - ;; TAB inserts 8 spaces, not the TAB character - (define-key kpp-mode-map (kbd "TAB") - '(lambda () (interactive) (insert " "))) -) - -(defun kpp-mode () - "Major mode for editing kpp code. -Turning on kpp mode calls the value of the variable `kpp-mode-hook' -with no args, if that value is non-nil. - -Command Table: -\\{kpp-mode-map}" - (interactive) - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults '((kpp-font-lock-keywords) t t)) - (make-local-variable 'comment-start) - (setq comment-start "{") - (make-local-variable 'comment-end) - (setq comment-end "}") - (use-local-map kpp-mode-map) - (setq mode-name "kpp") - (setq major-mode 'kpp-mode) - (turn-on-font-lock) - (set-syntax-table (copy-syntax-table)) - (modify-syntax-entry ?_ "w") ; the underscore can be part of a word - (auto-fill-mode 0) ; no automatic line breaks - (run-hooks 'kpp-mode-hook) -) - -(provide 'kpp) - -;; kpp.el ends here diff --git a/boxmox/src/Makefile b/boxmox/src/Makefile deleted file mode 100755 index 7cb2a92aeefadd29aa63a9cf7b6e16d779851d9a..0000000000000000000000000000000000000000 --- a/boxmox/src/Makefile +++ /dev/null @@ -1,87 +0,0 @@ -######################################################################################## -# -# KPP - The Kinetic PreProcessor -# Builds simulation code for chemical kinetic systems -# -# Copyright (C) 1995-1996 Valeriu Damian and Adrian Sandu -# Copyright (C) 1997-2005 Adrian Sandu -# with contributions from: Mirela Damian, Rolf Sander -# -# KPP is free software; you can redistribute it and/or modify it under the -# terms of the GNU General Public License as published by the Free Software -# Foundation (http://www.gnu.org/copyleft/gpl.html); either version 2 of the -# License, or (at your option) any later version. -# -# KPP is distributed in the hope that it will be useful, but WITHOUT ANY -# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS -# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more -# details. -# -# You should have received a copy of the GNU General Public License along -## with this program; if not, consult http://www.gnu.org/copyleft/gpl.html or -# write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -# Boston, MA 02111-1307, USA. -# -# Adrian Sandu -# Computer Science Department -# Virginia Polytechnic Institute and State University -# Blacksburg, VA 24060 -# E-mail: sandu@cs.vt.edu -# -####################################################################################### - -include ../Makefile.defs - -BISON=bison -d -CFLAGS=`cat ../cflags` - -all: kpp - -.c.o: - @echo " "$(CC) $(CC_FLAGS) $(CFLAGS) -c $*.c - @$(CC) $(CC_FLAGS) $(CFLAGS) -I$(INCLUDE_DIR) -c $*.c - -OBJS = \ - y.tab.o \ - lex.yy.o \ - scanner.o \ - scanutil.o \ - kpp.o \ - gen.o \ - code.o \ - code_c.o \ - code_f77.o \ - code_f90.o \ - code_matlab.o \ - debug.o - -kpp: $(OBJS) - @echo " "$(CC) $(CC_FLAGS) $(CFLAGS) $(OBJS) -L$(FLEX_LIB_DIR) -lfl -o kpp - @$(CC) $(CC_FLAGS) $(CFLAGS) $(OBJS) -L$(FLEX_LIB_DIR) -lfl -o kpp - @mv kpp ../bin - -clean: - @rm -f *~ *.o cflags - -maintainer-clean: clean - @rm -f lex.yy.c y.tab.c y.tab.h - -lex.yy.c: scan.l scan.h - @echo " "$(FLEX) scan.l - @$(FLEX) -olex.yy.c scan.l - -y.tab.c: scan.y scan.h - @echo " "$(BISON) scan.y - @$(BISON) -o y.tab.c scan.y - -flex: lex.yy.c y.tab.c - -scanner.o: scan.h gdata.h -scanutil.o: scan.h -kpp.o: gdata.h -gen.o: gdata.h code.h -debug.o: gdata.h -code.o: gdata.h code.h - -code_c.o: gdata.h code.h -code_f.o: gdata.h code.h diff --git a/boxmox/boxmox/wrapper b/boxmox/wrapper similarity index 100% rename from boxmox/boxmox/wrapper rename to boxmox/wrapper diff --git a/build_dist.sh b/build_dist.sh new file mode 100755 index 0000000000000000000000000000000000000000..ba9e14836bdfc4f8102b6c6a02ef11ad80e2df65 --- /dev/null +++ b/build_dist.sh @@ -0,0 +1,86 @@ +#!/bin/sh +buildDir=$1 + +echo +echo " --- pruning existing build dir ---" +echo + +if [ ! -z "$buildDir" ] +then + rm -rf $buildDir +fi + +echo +echo " --- prep Makefile.am ---" +echo + +# (1) fancy shit: no wildcards in automake, add all files to be distributed with BOXMOX/KPP explicitly +cp Makefile.am_BLUEPRINT Makefile.am + +# list all files in these subdirectories +distFiles=$(find boxmox drv examples case_studies int models util -type f) + +#pretty print them 45 char wide dd tab, backslash at end remove backslash last line remove tab first line +printf 'nobase_dist_pkgdata_DATA = %s\n' "${distFiles[*]}" | fmt -w 45 | sed -e 's/\(.*\)$/\t\1 \\/g' | sed '$ s/\\//g' | sed '1 s/\t//g' >> Makefile.am + +echo +echo " --- build documentation ---" +echo + +cd boxmox +pdflatex UserManual +pdflatex UserManual +cp UserManual.pdf ../doc/boxmox_UserManual.pdf +cd .. + +# now standard: + +echo +echo " --- aclocal ---" +echo +aclocal + +echo +echo " --- autoconf ---" +echo +autoconf + +echo +echo " --- automake ---" +echo +automake -a -c + +echo +echo " --- configure ---" +echo +./configure --prefix="${buildDir}" + +echo +echo " --- makec maintainer-clean ---" +echo +make maintainer-clean + +echo +echo " --- configure ---" +echo +./configure --prefix="${buildDir}" + +echo +echo " --- make ---" +echo +make + +echo +echo " --- make install ---" +echo +make install + +echo +echo " --- make dist ---" +echo +make dist + +echo +echo " --- make distcheck ---" +echo +make distcheck diff --git a/boxmox/boxmox/examples/BOXMOX.nml b/case_studies/BOXMOX.nml similarity index 100% rename from boxmox/boxmox/examples/BOXMOX.nml rename to case_studies/BOXMOX.nml diff --git a/boxmox/boxmox/examples/chamber_experiment/BOXMOX.nml b/case_studies/chamber_experiment/BOXMOX.nml similarity index 100% rename from boxmox/boxmox/examples/chamber_experiment/BOXMOX.nml rename to case_studies/chamber_experiment/BOXMOX.nml diff --git a/boxmox/boxmox/examples/chamber_experiment/Environment.csv b/case_studies/chamber_experiment/Environment.csv similarity index 100% rename from boxmox/boxmox/examples/chamber_experiment/Environment.csv rename to case_studies/chamber_experiment/Environment.csv diff --git a/boxmox/boxmox/examples/chamber_experiment/InitialConditions.csv b/case_studies/chamber_experiment/InitialConditions.csv similarity index 100% rename from boxmox/boxmox/examples/chamber_experiment/InitialConditions.csv rename to case_studies/chamber_experiment/InitialConditions.csv diff --git a/boxmox/boxmox/examples/chamber_experiment/PhotolysisRates.csv b/case_studies/chamber_experiment/PhotolysisRates.csv similarity index 100% rename from boxmox/boxmox/examples/chamber_experiment/PhotolysisRates.csv rename to case_studies/chamber_experiment/PhotolysisRates.csv diff --git a/boxmox/boxmox/examples/chamber_experiment/README b/case_studies/chamber_experiment/README similarity index 100% rename from boxmox/boxmox/examples/chamber_experiment/README rename to case_studies/chamber_experiment/README diff --git a/boxmox/boxmox/examples/chamber_experiment/mech_used b/case_studies/chamber_experiment/mech_used similarity index 100% rename from boxmox/boxmox/examples/chamber_experiment/mech_used rename to case_studies/chamber_experiment/mech_used diff --git a/boxmox/boxmox/examples/chamber_experiment/plot.R b/case_studies/chamber_experiment/plot.R similarity index 100% rename from boxmox/boxmox/examples/chamber_experiment/plot.R rename to case_studies/chamber_experiment/plot.R diff --git a/boxmox/boxmox/examples/dilution/BOXMOX.nml b/case_studies/dilution/BOXMOX.nml similarity index 100% rename from boxmox/boxmox/examples/dilution/BOXMOX.nml rename to case_studies/dilution/BOXMOX.nml diff --git a/boxmox/boxmox/examples/dilution/Background.csv b/case_studies/dilution/Background.csv similarity index 100% rename from boxmox/boxmox/examples/dilution/Background.csv rename to case_studies/dilution/Background.csv diff --git a/boxmox/boxmox/examples/dilution/Environment.csv b/case_studies/dilution/Environment.csv similarity index 100% rename from boxmox/boxmox/examples/dilution/Environment.csv rename to case_studies/dilution/Environment.csv diff --git a/boxmox/boxmox/examples/dilution/InitialConditions.csv b/case_studies/dilution/InitialConditions.csv similarity index 100% rename from boxmox/boxmox/examples/dilution/InitialConditions.csv rename to case_studies/dilution/InitialConditions.csv diff --git a/boxmox/boxmox/examples/dilution/PhotolysisRates.csv b/case_studies/dilution/PhotolysisRates.csv similarity index 100% rename from boxmox/boxmox/examples/dilution/PhotolysisRates.csv rename to case_studies/dilution/PhotolysisRates.csv diff --git a/boxmox/boxmox/examples/dilution/README b/case_studies/dilution/README similarity index 100% rename from boxmox/boxmox/examples/dilution/README rename to case_studies/dilution/README diff --git a/boxmox/boxmox/examples/dilution/mech_used b/case_studies/dilution/mech_used similarity index 100% rename from boxmox/boxmox/examples/dilution/mech_used rename to case_studies/dilution/mech_used diff --git a/boxmox/boxmox/examples/dilution/plot.R b/case_studies/dilution/plot.R similarity index 100% rename from boxmox/boxmox/examples/dilution/plot.R rename to case_studies/dilution/plot.R diff --git a/boxmox/boxmox/examples/het_chem/Aerosol.csv b/case_studies/het_chem/Aerosol.csv similarity index 100% rename from boxmox/boxmox/examples/het_chem/Aerosol.csv rename to case_studies/het_chem/Aerosol.csv diff --git a/boxmox/boxmox/examples/het_chem/BOXMOX.nml b/case_studies/het_chem/BOXMOX.nml similarity index 100% rename from boxmox/boxmox/examples/het_chem/BOXMOX.nml rename to case_studies/het_chem/BOXMOX.nml diff --git a/boxmox/boxmox/examples/het_chem/Environment.csv b/case_studies/het_chem/Environment.csv similarity index 100% rename from boxmox/boxmox/examples/het_chem/Environment.csv rename to case_studies/het_chem/Environment.csv diff --git a/boxmox/boxmox/examples/het_chem/InitialConditions.csv b/case_studies/het_chem/InitialConditions.csv similarity index 100% rename from boxmox/boxmox/examples/het_chem/InitialConditions.csv rename to case_studies/het_chem/InitialConditions.csv diff --git a/boxmox/boxmox/examples/het_chem/README b/case_studies/het_chem/README similarity index 100% rename from boxmox/boxmox/examples/het_chem/README rename to case_studies/het_chem/README diff --git a/boxmox/boxmox/examples/het_chem/mech_used b/case_studies/het_chem/mech_used similarity index 100% rename from boxmox/boxmox/examples/het_chem/mech_used rename to case_studies/het_chem/mech_used diff --git a/boxmox/boxmox/examples/het_chem/plot.R b/case_studies/het_chem/plot.R similarity index 100% rename from boxmox/boxmox/examples/het_chem/plot.R rename to case_studies/het_chem/plot.R diff --git a/boxmox/boxmox/examples/pbl_diurnal_cycle/BOXMOX.nml b/case_studies/pbl_diurnal_cycle/BOXMOX.nml similarity index 100% rename from boxmox/boxmox/examples/pbl_diurnal_cycle/BOXMOX.nml rename to case_studies/pbl_diurnal_cycle/BOXMOX.nml diff --git a/boxmox/boxmox/examples/pbl_diurnal_cycle/Background.csv b/case_studies/pbl_diurnal_cycle/Background.csv similarity index 100% rename from boxmox/boxmox/examples/pbl_diurnal_cycle/Background.csv rename to case_studies/pbl_diurnal_cycle/Background.csv diff --git a/boxmox/boxmox/examples/pbl_diurnal_cycle/Deposition.csv b/case_studies/pbl_diurnal_cycle/Deposition.csv similarity index 100% rename from boxmox/boxmox/examples/pbl_diurnal_cycle/Deposition.csv rename to case_studies/pbl_diurnal_cycle/Deposition.csv diff --git a/boxmox/boxmox/examples/pbl_diurnal_cycle/Emissions.csv b/case_studies/pbl_diurnal_cycle/Emissions.csv similarity index 100% rename from boxmox/boxmox/examples/pbl_diurnal_cycle/Emissions.csv rename to case_studies/pbl_diurnal_cycle/Emissions.csv diff --git a/boxmox/boxmox/examples/pbl_diurnal_cycle/Environment.csv b/case_studies/pbl_diurnal_cycle/Environment.csv similarity index 100% rename from boxmox/boxmox/examples/pbl_diurnal_cycle/Environment.csv rename to case_studies/pbl_diurnal_cycle/Environment.csv diff --git a/boxmox/boxmox/examples/pbl_diurnal_cycle/InitialConditions.csv b/case_studies/pbl_diurnal_cycle/InitialConditions.csv similarity index 100% rename from boxmox/boxmox/examples/pbl_diurnal_cycle/InitialConditions.csv rename to case_studies/pbl_diurnal_cycle/InitialConditions.csv diff --git a/boxmox/boxmox/examples/pbl_diurnal_cycle/PhotolysisRates.csv b/case_studies/pbl_diurnal_cycle/PhotolysisRates.csv similarity index 100% rename from boxmox/boxmox/examples/pbl_diurnal_cycle/PhotolysisRates.csv rename to case_studies/pbl_diurnal_cycle/PhotolysisRates.csv diff --git a/boxmox/boxmox/examples/pbl_diurnal_cycle/README b/case_studies/pbl_diurnal_cycle/README similarity index 100% rename from boxmox/boxmox/examples/pbl_diurnal_cycle/README rename to case_studies/pbl_diurnal_cycle/README diff --git a/boxmox/boxmox/examples/pbl_diurnal_cycle/mech_used b/case_studies/pbl_diurnal_cycle/mech_used similarity index 100% rename from boxmox/boxmox/examples/pbl_diurnal_cycle/mech_used rename to case_studies/pbl_diurnal_cycle/mech_used diff --git a/boxmox/boxmox/examples/pbl_diurnal_cycle/plot.R b/case_studies/pbl_diurnal_cycle/plot.R similarity index 100% rename from boxmox/boxmox/examples/pbl_diurnal_cycle/plot.R rename to case_studies/pbl_diurnal_cycle/plot.R diff --git a/boxmox/boxmox/examples/urban_plume/BOXMOX.nml b/case_studies/urban_plume/BOXMOX.nml similarity index 100% rename from boxmox/boxmox/examples/urban_plume/BOXMOX.nml rename to case_studies/urban_plume/BOXMOX.nml diff --git a/boxmox/boxmox/examples/urban_plume/Deposition.csv b/case_studies/urban_plume/Deposition.csv similarity index 100% rename from boxmox/boxmox/examples/urban_plume/Deposition.csv rename to case_studies/urban_plume/Deposition.csv diff --git a/boxmox/boxmox/examples/urban_plume/Emissions.csv b/case_studies/urban_plume/Emissions.csv similarity index 100% rename from boxmox/boxmox/examples/urban_plume/Emissions.csv rename to case_studies/urban_plume/Emissions.csv diff --git a/boxmox/boxmox/examples/urban_plume/Environment.csv b/case_studies/urban_plume/Environment.csv similarity index 100% rename from boxmox/boxmox/examples/urban_plume/Environment.csv rename to case_studies/urban_plume/Environment.csv diff --git a/boxmox/boxmox/examples/urban_plume/InitialConditions.csv b/case_studies/urban_plume/InitialConditions.csv similarity index 100% rename from boxmox/boxmox/examples/urban_plume/InitialConditions.csv rename to case_studies/urban_plume/InitialConditions.csv diff --git a/boxmox/boxmox/examples/urban_plume/PhotolysisRates.csv b/case_studies/urban_plume/PhotolysisRates.csv similarity index 100% rename from boxmox/boxmox/examples/urban_plume/PhotolysisRates.csv rename to case_studies/urban_plume/PhotolysisRates.csv diff --git a/boxmox/boxmox/examples/urban_plume/README b/case_studies/urban_plume/README similarity index 100% rename from boxmox/boxmox/examples/urban_plume/README rename to case_studies/urban_plume/README diff --git a/boxmox/boxmox/examples/urban_plume/mech_used b/case_studies/urban_plume/mech_used similarity index 100% rename from boxmox/boxmox/examples/urban_plume/mech_used rename to case_studies/urban_plume/mech_used diff --git a/boxmox/boxmox/examples/urban_plume/plot.R b/case_studies/urban_plume/plot.R similarity index 100% rename from boxmox/boxmox/examples/urban_plume/plot.R rename to case_studies/urban_plume/plot.R diff --git a/configure.ac b/configure.ac new file mode 100644 index 0000000000000000000000000000000000000000..fb67220e04bd76bd9b5537ac07d53a959f42cf1b --- /dev/null +++ b/configure.ac @@ -0,0 +1,33 @@ +dnl run `autoreconf -i` to generate a configure script. +dnl Then run ./configure to generate a Makefile. +dnl Finally run make to generate the project. + +AC_INIT([boxmox], [1.8], [christoph.knote@med.uni-augsburg.de]) +dnl we use the build type foreign here instead of gnu because I do not have a NEWS file and similar, yet. +AM_INIT_AUTOMAKE([-Wall foreign tar-pax]) +AC_PROG_CC +if test "x$CC" = "x" ; then + AC_MSG_ERROR([C compiler is required to build KPP.]) +fi +AC_PROG_LEX(noyywrap) +if test "x$LEX" = "x" ; then + AC_MSG_ERROR([flex is required to build KPP.]) +fi +AC_PROG_YACC +if test "x$YACC" = "x" ; then + AC_MSG_ERROR([bison or yacc is required to build KPP.]) +fi +AC_PROG_SED +if test "x$SED" = "x" ; then + AC_MSG_ERROR([sed is required to build BOXMOX.]) +fi +AC_PROG_FC +if test "x$FC" = "x" ; then + AC_MSG_ERROR([Fortran compiler is required to build BOXMOX mechanisms.]) +fi +AC_PROG_MKDIR_P +AC_CONFIG_FILES([ + Makefile + src/Makefile +]) +AC_OUTPUT diff --git a/boxmox/doc/kpp_UserManual.pdf b/doc/kpp_UserManual.pdf similarity index 100% rename from boxmox/doc/kpp_UserManual.pdf rename to doc/kpp_UserManual.pdf diff --git a/boxmox/boxmox/boxmox.f90 b/drv/boxmox.f90 similarity index 100% rename from boxmox/boxmox/boxmox.f90 rename to drv/boxmox.f90 diff --git a/boxmox/boxmox/boxmox_adjoint.f90 b/drv/boxmox_adjoint.f90 similarity index 100% rename from boxmox/boxmox/boxmox_adjoint.f90 rename to drv/boxmox_adjoint.f90 diff --git a/boxmox/boxmox/boxmox_lib.f90 b/drv/boxmox_lib.f90 similarity index 100% rename from boxmox/boxmox/boxmox_lib.f90 rename to drv/boxmox_lib.f90 diff --git a/boxmox/drv/exact.c b/drv/exact.c similarity index 100% rename from boxmox/drv/exact.c rename to drv/exact.c diff --git a/boxmox/drv/exact.f b/drv/exact.f similarity index 100% rename from boxmox/drv/exact.f rename to drv/exact.f diff --git a/boxmox/drv/general.c b/drv/general.c similarity index 100% rename from boxmox/drv/general.c rename to drv/general.c diff --git a/boxmox/drv/general.f b/drv/general.f similarity index 100% rename from boxmox/drv/general.f rename to drv/general.f diff --git a/boxmox/drv/general.f90 b/drv/general.f90 similarity index 100% rename from boxmox/drv/general.f90 rename to drv/general.f90 diff --git a/boxmox/drv/general.m b/drv/general.m similarity index 100% rename from boxmox/drv/general.m rename to drv/general.m diff --git a/boxmox/drv/general_adj.c b/drv/general_adj.c similarity index 100% rename from boxmox/drv/general_adj.c rename to drv/general_adj.c diff --git a/boxmox/drv/general_adj.f90 b/drv/general_adj.f90 similarity index 100% rename from boxmox/drv/general_adj.f90 rename to drv/general_adj.f90 diff --git a/boxmox/drv/general_complete.f90 b/drv/general_complete.f90 similarity index 100% rename from boxmox/drv/general_complete.f90 rename to drv/general_complete.f90 diff --git a/boxmox/drv/general_ddm_ic.f b/drv/general_ddm_ic.f similarity index 100% rename from boxmox/drv/general_ddm_ic.f rename to drv/general_ddm_ic.f diff --git a/boxmox/drv/general_hsv.f90 b/drv/general_hsv.f90 similarity index 100% rename from boxmox/drv/general_hsv.f90 rename to drv/general_hsv.f90 diff --git a/boxmox/drv/general_soa.f90 b/drv/general_soa.f90 similarity index 100% rename from boxmox/drv/general_soa.f90 rename to drv/general_soa.f90 diff --git a/boxmox/drv/general_soa_check.f90 b/drv/general_soa_check.f90 similarity index 100% rename from boxmox/drv/general_soa_check.f90 rename to drv/general_soa_check.f90 diff --git a/boxmox/drv/general_stochastic.c b/drv/general_stochastic.c similarity index 100% rename from boxmox/drv/general_stochastic.c rename to drv/general_stochastic.c diff --git a/boxmox/drv/general_stochastic.f90 b/drv/general_stochastic.f90 similarity index 100% rename from boxmox/drv/general_stochastic.f90 rename to drv/general_stochastic.f90 diff --git a/boxmox/drv/general_tlm.f90 b/drv/general_tlm.f90 similarity index 100% rename from boxmox/drv/general_tlm.f90 rename to drv/general_tlm.f90 diff --git a/boxmox/drv/main.c b/drv/main.c similarity index 100% rename from boxmox/drv/main.c rename to drv/main.c diff --git a/boxmox/drv/main.f b/drv/main.f similarity index 100% rename from boxmox/drv/main.f rename to drv/main.f diff --git a/boxmox/drv/none.c b/drv/none.c similarity index 100% rename from boxmox/drv/none.c rename to drv/none.c diff --git a/boxmox/drv/none.f b/drv/none.f similarity index 100% rename from boxmox/drv/none.f rename to drv/none.f diff --git a/boxmox/drv/none.f90 b/drv/none.f90 similarity index 100% rename from boxmox/drv/none.f90 rename to drv/none.f90 diff --git a/boxmox/examples/CB05TUCl_EPA.kpp b/examples/CB05TUCl_EPA.kpp similarity index 85% rename from boxmox/examples/CB05TUCl_EPA.kpp rename to examples/CB05TUCl_EPA.kpp index 055aff28e7e8a5a063fb804fb4ee8216b7a25b1f..6f838bb23b7303cec49ea0551d44c5937d1c55a7 100644 --- a/boxmox/examples/CB05TUCl_EPA.kpp +++ b/examples/CB05TUCl_EPA.kpp @@ -2,7 +2,7 @@ #LANGUAGE Fortran90 #DOUBLE ON #INTEGRATOR rosenbrock -#DRIVER ../boxmox/boxmox +#DRIVER boxmox #JACOBIAN SPARSE_LU_ROW #HESSIAN OFF #FUNCTION AGGREGATE diff --git a/boxmox/examples/CB05TUCl_NCSU.kpp b/examples/CB05TUCl_NCSU.kpp similarity index 81% rename from boxmox/examples/CB05TUCl_NCSU.kpp rename to examples/CB05TUCl_NCSU.kpp index aa89ca3b5772ed9755d53e25535f8ba964557d0a..7fdc7cb9032646f1e3d1fb303c8234010d41acba 100644 --- a/boxmox/examples/CB05TUCl_NCSU.kpp +++ b/examples/CB05TUCl_NCSU.kpp @@ -2,6 +2,6 @@ #LANGUAGE Fortran90 #DOUBLE ON #INTEGRATOR rosenbrock -#DRIVER ../boxmox/boxmox +#DRIVER boxmox #JACOBIAN SPARSE_LU_ROW #HESSIAN OFF diff --git a/boxmox/examples/CB05_CSIRO.kpp b/examples/CB05_CSIRO.kpp similarity index 85% rename from boxmox/examples/CB05_CSIRO.kpp rename to examples/CB05_CSIRO.kpp index 5cbd7f36eac0f71ef9b793b8accda0a3b0897609..f3f81c82c75c024ad4888422fa09e83d33fbce6c 100644 --- a/boxmox/examples/CB05_CSIRO.kpp +++ b/examples/CB05_CSIRO.kpp @@ -2,7 +2,7 @@ #LANGUAGE Fortran90 #DOUBLE ON #INTEGRATOR rosenbrock -#DRIVER ../boxmox/boxmox +#DRIVER boxmox #JACOBIAN SPARSE_LU_ROW #HESSIAN OFF #FUNCTION AGGREGATE diff --git a/boxmox/examples/CBMZ.kpp b/examples/CBMZ.kpp similarity index 80% rename from boxmox/examples/CBMZ.kpp rename to examples/CBMZ.kpp index 24c3f203ea1500ed2206e613d14872ac4c733a6b..678b9d065ba093a9f763d955753e50625767d9e1 100644 --- a/boxmox/examples/CBMZ.kpp +++ b/examples/CBMZ.kpp @@ -2,6 +2,6 @@ #LANGUAGE Fortran90 #DOUBLE ON #INTEGRATOR rosenbrock -#DRIVER ../boxmox/boxmox +#DRIVER boxmox #JACOBIAN SPARSE_LU_ROW #HESSIAN OFF diff --git a/boxmox/examples/CBMZ_wrfkpp.equiv b/examples/CBMZ_wrfkpp.equiv similarity index 100% rename from boxmox/examples/CBMZ_wrfkpp.equiv rename to examples/CBMZ_wrfkpp.equiv diff --git a/boxmox/examples/HETCHEM.kpp b/examples/HETCHEM.kpp similarity index 80% rename from boxmox/examples/HETCHEM.kpp rename to examples/HETCHEM.kpp index d9e34ee9820fb2a72d3327f86636a8e24fa89726..f4738c87db3c243677d52f5646da49e6cb48e0cc 100644 --- a/boxmox/examples/HETCHEM.kpp +++ b/examples/HETCHEM.kpp @@ -2,6 +2,6 @@ #LANGUAGE Fortran90 #DOUBLE ON #INTEGRATOR rosenbrock -#DRIVER ../boxmox/boxmox +#DRIVER boxmox #JACOBIAN SPARSE_LU_ROW #HESSIAN OFF diff --git a/boxmox/examples/MCMv3_3.kpp b/examples/MCMv3_3.kpp similarity index 80% rename from boxmox/examples/MCMv3_3.kpp rename to examples/MCMv3_3.kpp index 97218035d813997e3657fa1e22faff5bf624ea1a..a4024436a2f72c0fed78ebc04659229e9072746a 100644 --- a/boxmox/examples/MCMv3_3.kpp +++ b/examples/MCMv3_3.kpp @@ -2,6 +2,6 @@ #LANGUAGE Fortran90 #DOUBLE ON #INTEGRATOR rosenbrock -#DRIVER ../boxmox/boxmox +#DRIVER boxmox #JACOBIAN SPARSE_LU_ROW #HESSIAN OFF diff --git a/boxmox/examples/MOZART_4.kpp b/examples/MOZART_4.kpp similarity index 81% rename from boxmox/examples/MOZART_4.kpp rename to examples/MOZART_4.kpp index ea637760961ae4ba627c26552a31e662db8960bc..ef211e12bee5ea2348e8580957f22b2c4a8f21cc 100644 --- a/boxmox/examples/MOZART_4.kpp +++ b/examples/MOZART_4.kpp @@ -2,6 +2,6 @@ #LANGUAGE Fortran90 #DOUBLE ON #INTEGRATOR rosenbrock -#DRIVER ../boxmox/boxmox +#DRIVER boxmox #JACOBIAN SPARSE_LU_ROW #HESSIAN OFF diff --git a/boxmox/examples/MOZART_4_wrfkpp.equiv b/examples/MOZART_4_wrfkpp.equiv similarity index 100% rename from boxmox/examples/MOZART_4_wrfkpp.equiv rename to examples/MOZART_4_wrfkpp.equiv diff --git a/boxmox/examples/MOZART_T1.kpp b/examples/MOZART_T1.kpp similarity index 81% rename from boxmox/examples/MOZART_T1.kpp rename to examples/MOZART_T1.kpp index 985c57d3720bcc20d9849e4949635e79d1a6cb7d..052b163898b2a9882551e1a63ba71e46d7368528 100644 --- a/boxmox/examples/MOZART_T1.kpp +++ b/examples/MOZART_T1.kpp @@ -2,6 +2,6 @@ #LANGUAGE Fortran90 #DOUBLE ON #INTEGRATOR rosenbrock -#DRIVER ../boxmox/boxmox +#DRIVER boxmox #JACOBIAN SPARSE_LU_ROW #HESSIAN OFF diff --git a/boxmox/examples/MOZART_T1_wrfkpp.equiv b/examples/MOZART_T1_wrfkpp.equiv similarity index 100% rename from boxmox/examples/MOZART_T1_wrfkpp.equiv rename to examples/MOZART_T1_wrfkpp.equiv diff --git a/boxmox/examples/NO_NO2.kpp b/examples/NO_NO2.kpp similarity index 80% rename from boxmox/examples/NO_NO2.kpp rename to examples/NO_NO2.kpp index 28bf2605a392758f04e95e10058dc4d1ee882a83..cef26aa800ad79f202ad3fd9e17a9f4c316f8084 100644 --- a/boxmox/examples/NO_NO2.kpp +++ b/examples/NO_NO2.kpp @@ -2,6 +2,6 @@ #LANGUAGE Fortran90 #DOUBLE ON #INTEGRATOR rosenbrock -#DRIVER ../boxmox/boxmox +#DRIVER boxmox #JACOBIAN SPARSE_LU_ROW #HESSIAN OFF diff --git a/boxmox/examples/RACM.kpp b/examples/RACM.kpp similarity index 80% rename from boxmox/examples/RACM.kpp rename to examples/RACM.kpp index a8851e245229333ccbd94d35c77b237565bcb5ea..63e31d45fcb9aee15f070a1e01c16d6c7067237e 100644 --- a/boxmox/examples/RACM.kpp +++ b/examples/RACM.kpp @@ -2,6 +2,6 @@ #LANGUAGE Fortran90 #DOUBLE ON #INTEGRATOR rosenbrock -#DRIVER ../boxmox/boxmox +#DRIVER boxmox #JACOBIAN SPARSE_LU_ROW #HESSIAN OFF diff --git a/boxmox/examples/RACM_wrfkpp.equiv b/examples/RACM_wrfkpp.equiv similarity index 100% rename from boxmox/examples/RACM_wrfkpp.equiv rename to examples/RACM_wrfkpp.equiv diff --git a/boxmox/examples/RADM2.kpp b/examples/RADM2.kpp similarity index 80% rename from boxmox/examples/RADM2.kpp rename to examples/RADM2.kpp index 785be2e7fa5203ac3f3ffb8cb6a46708e745f65c..93d692f18f1e8b986509d14ea96453928aab2751 100644 --- a/boxmox/examples/RADM2.kpp +++ b/examples/RADM2.kpp @@ -2,6 +2,6 @@ #LANGUAGE Fortran90 #DOUBLE ON #INTEGRATOR rosenbrock -#DRIVER ../boxmox/boxmox +#DRIVER boxmox #JACOBIAN SPARSE_LU_ROW #HESSIAN OFF diff --git a/boxmox/examples/RADM2_wrfkpp.equiv b/examples/RADM2_wrfkpp.equiv similarity index 100% rename from boxmox/examples/RADM2_wrfkpp.equiv rename to examples/RADM2_wrfkpp.equiv diff --git a/boxmox/examples/RADMKA.kpp b/examples/RADMKA.kpp similarity index 80% rename from boxmox/examples/RADMKA.kpp rename to examples/RADMKA.kpp index ca7a9b7859dd7ea4a2db63973fa3ec3641c204e4..0a2f02161c3f0b67b5666ce5d1b345caeefddc4b 100644 --- a/boxmox/examples/RADMKA.kpp +++ b/examples/RADMKA.kpp @@ -2,6 +2,6 @@ #LANGUAGE Fortran90 #DOUBLE ON #INTEGRATOR rosenbrock -#DRIVER ../boxmox/boxmox +#DRIVER boxmox #JACOBIAN SPARSE_LU_ROW #HESSIAN OFF diff --git a/boxmox/examples/SAPRC99.kpp b/examples/SAPRC99.kpp similarity index 80% rename from boxmox/examples/SAPRC99.kpp rename to examples/SAPRC99.kpp index d828cf535644f9ec2a59198f5df6e316b2cec9f0..5e30a88fece861aff004fc39f4696ec1831d6641 100644 --- a/boxmox/examples/SAPRC99.kpp +++ b/examples/SAPRC99.kpp @@ -2,6 +2,6 @@ #LANGUAGE Fortran90 #DOUBLE ON #INTEGRATOR rosenbrock -#DRIVER ../boxmox/boxmox +#DRIVER boxmox #JACOBIAN SPARSE_LU_ROW #HESSIAN OFF diff --git a/boxmox/examples/SAPRC99_wrfkpp.equiv b/examples/SAPRC99_wrfkpp.equiv similarity index 100% rename from boxmox/examples/SAPRC99_wrfkpp.equiv rename to examples/SAPRC99_wrfkpp.equiv diff --git a/boxmox/examples/smog.kpp b/examples/smog.kpp similarity index 80% rename from boxmox/examples/smog.kpp rename to examples/smog.kpp index ed76a9d5ff108fd38775c0034868d8f3be049574..a0d0cb40109978044ca52d1ffadd4843649c361f 100644 --- a/boxmox/examples/smog.kpp +++ b/examples/smog.kpp @@ -2,6 +2,6 @@ #LANGUAGE Fortran90 #DOUBLE ON #INTEGRATOR rosenbrock -#DRIVER ../boxmox/boxmox +#DRIVER boxmox #JACOBIAN SPARSE_LU_ROW #HESSIAN OFF diff --git a/boxmox/gpl/gpl.txt b/gpl/gpl.txt similarity index 100% rename from boxmox/gpl/gpl.txt rename to gpl/gpl.txt diff --git a/boxmox/int/DVODE/ChangeRecord.txt b/int/DVODE/ChangeRecord.txt similarity index 100% rename from boxmox/int/DVODE/ChangeRecord.txt rename to int/DVODE/ChangeRecord.txt diff --git a/boxmox/int/DVODE/NonstiffOptionsReadme.txt b/int/DVODE/NonstiffOptionsReadme.txt similarity index 100% rename from boxmox/int/DVODE/NonstiffOptionsReadme.txt rename to int/DVODE/NonstiffOptionsReadme.txt diff --git a/boxmox/int/DVODE/StiffOptionsReadme.txt b/int/DVODE/StiffOptionsReadme.txt similarity index 100% rename from boxmox/int/DVODE/StiffOptionsReadme.txt rename to int/DVODE/StiffOptionsReadme.txt diff --git a/boxmox/int/DVODE/a.out b/int/DVODE/a.out similarity index 100% rename from boxmox/int/DVODE/a.out rename to int/DVODE/a.out diff --git a/boxmox/int/DVODE/dvode_f90_m.f90 b/int/DVODE/dvode_f90_m.f90 similarity index 100% rename from boxmox/int/DVODE/dvode_f90_m.f90 rename to int/DVODE/dvode_f90_m.f90 diff --git a/boxmox/int/DVODE/dvode_f90_m.mod b/int/DVODE/dvode_f90_m.mod similarity index 100% rename from boxmox/int/DVODE/dvode_f90_m.mod rename to int/DVODE/dvode_f90_m.mod diff --git a/boxmox/int/DVODE/example1.dat b/int/DVODE/example1.dat similarity index 100% rename from boxmox/int/DVODE/example1.dat rename to int/DVODE/example1.dat diff --git a/boxmox/int/DVODE/example1.f90 b/int/DVODE/example1.f90 similarity index 100% rename from boxmox/int/DVODE/example1.f90 rename to int/DVODE/example1.f90 diff --git a/boxmox/int/DVODE/example1.mod b/int/DVODE/example1.mod similarity index 100% rename from boxmox/int/DVODE/example1.mod rename to int/DVODE/example1.mod diff --git a/boxmox/int/DVODE/example2.f90 b/int/DVODE/example2.f90 similarity index 100% rename from boxmox/int/DVODE/example2.f90 rename to int/DVODE/example2.f90 diff --git a/boxmox/int/DVODE/nonstiffoptions.f90 b/int/DVODE/nonstiffoptions.f90 similarity index 100% rename from boxmox/int/DVODE/nonstiffoptions.f90 rename to int/DVODE/nonstiffoptions.f90 diff --git a/boxmox/int/DVODE/quickstart.pdf b/int/DVODE/quickstart.pdf similarity index 100% rename from boxmox/int/DVODE/quickstart.pdf rename to int/DVODE/quickstart.pdf diff --git a/boxmox/int/DVODE/stiffoptions.dat b/int/DVODE/stiffoptions.dat similarity index 100% rename from boxmox/int/DVODE/stiffoptions.dat rename to int/DVODE/stiffoptions.dat diff --git a/boxmox/int/DVODE/stiffoptions.f90 b/int/DVODE/stiffoptions.f90 similarity index 100% rename from boxmox/int/DVODE/stiffoptions.f90 rename to int/DVODE/stiffoptions.f90 diff --git a/boxmox/int/DVODE/stiffset.mod b/int/DVODE/stiffset.mod similarity index 100% rename from boxmox/int/DVODE/stiffset.mod rename to int/DVODE/stiffset.mod diff --git a/boxmox/int/DVODE/test.f90 b/int/DVODE/test.f90 similarity index 100% rename from boxmox/int/DVODE/test.f90 rename to int/DVODE/test.f90 diff --git a/boxmox/int.modified_WCOPY/atm_lsodes.def b/int/atm_lsodes.def similarity index 100% rename from boxmox/int.modified_WCOPY/atm_lsodes.def rename to int/atm_lsodes.def diff --git a/boxmox/int.modified_WCOPY/atm_lsodes.f b/int/atm_lsodes.f similarity index 100% rename from boxmox/int.modified_WCOPY/atm_lsodes.f rename to int/atm_lsodes.f diff --git a/boxmox/int.modified_WCOPY/atm_odessa_ddm.def b/int/atm_odessa_ddm.def similarity index 100% rename from boxmox/int.modified_WCOPY/atm_odessa_ddm.def rename to int/atm_odessa_ddm.def diff --git a/boxmox/int.modified_WCOPY/atm_odessa_ddm.f b/int/atm_odessa_ddm.f similarity index 100% rename from boxmox/int.modified_WCOPY/atm_odessa_ddm.f rename to int/atm_odessa_ddm.f diff --git a/boxmox/int.modified_WCOPY/atm_radau5.def b/int/atm_radau5.def similarity index 100% rename from boxmox/int.modified_WCOPY/atm_radau5.def rename to int/atm_radau5.def diff --git a/boxmox/int.modified_WCOPY/atm_radau5.f b/int/atm_radau5.f similarity index 100% rename from boxmox/int.modified_WCOPY/atm_radau5.f rename to int/atm_radau5.f diff --git a/boxmox/int.modified_WCOPY/gillespie.c b/int/gillespie.c similarity index 100% rename from boxmox/int.modified_WCOPY/gillespie.c rename to int/gillespie.c diff --git a/boxmox/int.modified_WCOPY/gillespie.def b/int/gillespie.def similarity index 100% rename from boxmox/int.modified_WCOPY/gillespie.def rename to int/gillespie.def diff --git a/boxmox/int.modified_WCOPY/gillespie.f90 b/int/gillespie.f90 similarity index 100% rename from boxmox/int.modified_WCOPY/gillespie.f90 rename to int/gillespie.f90 diff --git a/boxmox/int.modified_WCOPY/kpp_dvode.def b/int/kpp_dvode.def similarity index 100% rename from boxmox/int.modified_WCOPY/kpp_dvode.def rename to int/kpp_dvode.def diff --git a/boxmox/int.modified_WCOPY/kpp_dvode.f b/int/kpp_dvode.f similarity index 100% rename from boxmox/int.modified_WCOPY/kpp_dvode.f rename to int/kpp_dvode.f diff --git a/boxmox/int/kpp_dvode.f90 b/int/kpp_dvode.f90 similarity index 100% rename from boxmox/int/kpp_dvode.f90 rename to int/kpp_dvode.f90 diff --git a/boxmox/int/kpp_dvode.f90.save b/int/kpp_dvode.f90.save similarity index 100% rename from boxmox/int/kpp_dvode.f90.save rename to int/kpp_dvode.f90.save diff --git a/boxmox/int.modified_WCOPY/kpp_lsode.def b/int/kpp_lsode.def similarity index 100% rename from boxmox/int.modified_WCOPY/kpp_lsode.def rename to int/kpp_lsode.def diff --git a/boxmox/int/kpp_lsode.f90 b/int/kpp_lsode.f90 similarity index 100% rename from boxmox/int/kpp_lsode.f90 rename to int/kpp_lsode.f90 diff --git a/boxmox/int.modified_WCOPY/kpp_odessa_ddm.def b/int/kpp_odessa_ddm.def similarity index 100% rename from boxmox/int.modified_WCOPY/kpp_odessa_ddm.def rename to int/kpp_odessa_ddm.def diff --git a/boxmox/int.modified_WCOPY/kpp_odessa_ddm.f b/int/kpp_odessa_ddm.f similarity index 100% rename from boxmox/int.modified_WCOPY/kpp_odessa_ddm.f rename to int/kpp_odessa_ddm.f diff --git a/boxmox/int.modified_WCOPY/kpp_radau5.def b/int/kpp_radau5.def similarity index 100% rename from boxmox/int.modified_WCOPY/kpp_radau5.def rename to int/kpp_radau5.def diff --git a/boxmox/int/kpp_radau5.f90 b/int/kpp_radau5.f90 similarity index 100% rename from boxmox/int/kpp_radau5.f90 rename to int/kpp_radau5.f90 diff --git a/boxmox/int.modified_WCOPY/kpp_sdirk4.def b/int/kpp_sdirk4.def similarity index 100% rename from boxmox/int.modified_WCOPY/kpp_sdirk4.def rename to int/kpp_sdirk4.def diff --git a/boxmox/int.modified_WCOPY/kpp_sdirk4.f b/int/kpp_sdirk4.f similarity index 100% rename from boxmox/int.modified_WCOPY/kpp_sdirk4.f rename to int/kpp_sdirk4.f diff --git a/boxmox/int/kpp_sdirk4.f90 b/int/kpp_sdirk4.f90 similarity index 100% rename from boxmox/int/kpp_sdirk4.f90 rename to int/kpp_sdirk4.f90 diff --git a/boxmox/int.modified_WCOPY/kpp_seulex.def b/int/kpp_seulex.def similarity index 100% rename from boxmox/int.modified_WCOPY/kpp_seulex.def rename to int/kpp_seulex.def diff --git a/boxmox/int.modified_WCOPY/kpp_seulex.f b/int/kpp_seulex.f similarity index 100% rename from boxmox/int.modified_WCOPY/kpp_seulex.f rename to int/kpp_seulex.f diff --git a/boxmox/int.modified_WCOPY/kpp_seulex.f90 b/int/kpp_seulex.f90 similarity index 100% rename from boxmox/int.modified_WCOPY/kpp_seulex.f90 rename to int/kpp_seulex.f90 diff --git a/boxmox/int.modified_WCOPY/none.c b/int/none.c similarity index 100% rename from boxmox/int.modified_WCOPY/none.c rename to int/none.c diff --git a/boxmox/int.modified_WCOPY/none.def b/int/none.def similarity index 100% rename from boxmox/int.modified_WCOPY/none.def rename to int/none.def diff --git a/boxmox/int.modified_WCOPY/none.f b/int/none.f similarity index 100% rename from boxmox/int.modified_WCOPY/none.f rename to int/none.f diff --git a/boxmox/int.modified_WCOPY/none.f90 b/int/none.f90 similarity index 100% rename from boxmox/int.modified_WCOPY/none.f90 rename to int/none.f90 diff --git a/boxmox/int.modified_WCOPY/none.m b/int/none.m similarity index 100% rename from boxmox/int.modified_WCOPY/none.m rename to int/none.m diff --git a/boxmox/int.modified_WCOPY/oldies/exqssa.c b/int/oldies/exqssa.c similarity index 100% rename from boxmox/int.modified_WCOPY/oldies/exqssa.c rename to int/oldies/exqssa.c diff --git a/boxmox/int.modified_WCOPY/oldies/exqssa.def b/int/oldies/exqssa.def similarity index 100% rename from boxmox/int.modified_WCOPY/oldies/exqssa.def rename to int/oldies/exqssa.def diff --git a/boxmox/int.modified_WCOPY/oldies/exqssa.f b/int/oldies/exqssa.f similarity index 100% rename from boxmox/int.modified_WCOPY/oldies/exqssa.f rename to int/oldies/exqssa.f diff --git a/boxmox/int.modified_WCOPY/oldies/kpp_rodas.def b/int/oldies/kpp_rodas.def similarity index 100% rename from boxmox/int.modified_WCOPY/oldies/kpp_rodas.def rename to int/oldies/kpp_rodas.def diff --git a/boxmox/int.modified_WCOPY/oldies/kpp_rodas.f b/int/oldies/kpp_rodas.f similarity index 100% rename from boxmox/int.modified_WCOPY/oldies/kpp_rodas.f rename to int/oldies/kpp_rodas.f diff --git a/boxmox/int.modified_WCOPY/oldies/kpp_ros4.def b/int/oldies/kpp_ros4.def similarity index 100% rename from boxmox/int.modified_WCOPY/oldies/kpp_ros4.def rename to int/oldies/kpp_ros4.def diff --git a/boxmox/int.modified_WCOPY/oldies/kpp_ros4.f b/int/oldies/kpp_ros4.f similarity index 100% rename from boxmox/int.modified_WCOPY/oldies/kpp_ros4.f rename to int/oldies/kpp_ros4.f diff --git a/boxmox/int.modified_WCOPY/oldies/qssa.def b/int/oldies/qssa.def similarity index 100% rename from boxmox/int.modified_WCOPY/oldies/qssa.def rename to int/oldies/qssa.def diff --git a/boxmox/int.modified_WCOPY/oldies/qssa.f b/int/oldies/qssa.f similarity index 100% rename from boxmox/int.modified_WCOPY/oldies/qssa.f rename to int/oldies/qssa.f diff --git a/boxmox/int.modified_WCOPY/oldies/qssa1.f b/int/oldies/qssa1.f similarity index 100% rename from boxmox/int.modified_WCOPY/oldies/qssa1.f rename to int/oldies/qssa1.f diff --git a/boxmox/int.modified_WCOPY/oldies/qssafix.def b/int/oldies/qssafix.def similarity index 100% rename from boxmox/int.modified_WCOPY/oldies/qssafix.def rename to int/oldies/qssafix.def diff --git a/boxmox/int.modified_WCOPY/oldies/qssafix.f b/int/oldies/qssafix.f similarity index 100% rename from boxmox/int.modified_WCOPY/oldies/qssafix.f rename to int/oldies/qssafix.f diff --git a/boxmox/int.modified_WCOPY/oldies/rodas3.c b/int/oldies/rodas3.c similarity index 100% rename from boxmox/int.modified_WCOPY/oldies/rodas3.c rename to int/oldies/rodas3.c diff --git a/boxmox/int.modified_WCOPY/oldies/rodas3.def b/int/oldies/rodas3.def similarity index 100% rename from boxmox/int.modified_WCOPY/oldies/rodas3.def rename to int/oldies/rodas3.def diff --git a/boxmox/int.modified_WCOPY/oldies/rodas3.f b/int/oldies/rodas3.f similarity index 100% rename from boxmox/int.modified_WCOPY/oldies/rodas3.f rename to int/oldies/rodas3.f diff --git a/boxmox/int.modified_WCOPY/oldies/rodas3_ddm.def b/int/oldies/rodas3_ddm.def similarity index 100% rename from boxmox/int.modified_WCOPY/oldies/rodas3_ddm.def rename to int/oldies/rodas3_ddm.def diff --git a/boxmox/int.modified_WCOPY/oldies/rodas3_ddm.f b/int/oldies/rodas3_ddm.f similarity index 100% rename from boxmox/int.modified_WCOPY/oldies/rodas3_ddm.f rename to int/oldies/rodas3_ddm.f diff --git a/boxmox/int.modified_WCOPY/oldies/ros1.def b/int/oldies/ros1.def similarity index 100% rename from boxmox/int.modified_WCOPY/oldies/ros1.def rename to int/oldies/ros1.def diff --git a/boxmox/int.modified_WCOPY/oldies/ros1.f b/int/oldies/ros1.f similarity index 100% rename from boxmox/int.modified_WCOPY/oldies/ros1.f rename to int/oldies/ros1.f diff --git a/boxmox/int.modified_WCOPY/oldies/ros1_ddm.def b/int/oldies/ros1_ddm.def similarity index 100% rename from boxmox/int.modified_WCOPY/oldies/ros1_ddm.def rename to int/oldies/ros1_ddm.def diff --git a/boxmox/int.modified_WCOPY/oldies/ros1_ddm.f b/int/oldies/ros1_ddm.f similarity index 100% rename from boxmox/int.modified_WCOPY/oldies/ros1_ddm.f rename to int/oldies/ros1_ddm.f diff --git a/boxmox/int.modified_WCOPY/oldies/ros2.c b/int/oldies/ros2.c similarity index 100% rename from boxmox/int.modified_WCOPY/oldies/ros2.c rename to int/oldies/ros2.c diff --git a/boxmox/int.modified_WCOPY/oldies/ros2.def b/int/oldies/ros2.def similarity index 100% rename from boxmox/int.modified_WCOPY/oldies/ros2.def rename to int/oldies/ros2.def diff --git a/boxmox/int.modified_WCOPY/oldies/ros2.f b/int/oldies/ros2.f similarity index 100% rename from boxmox/int.modified_WCOPY/oldies/ros2.f rename to int/oldies/ros2.f diff --git a/boxmox/int.modified_WCOPY/oldies/ros2.f90 b/int/oldies/ros2.f90 similarity index 100% rename from boxmox/int.modified_WCOPY/oldies/ros2.f90 rename to int/oldies/ros2.f90 diff --git a/boxmox/int.modified_WCOPY/oldies/ros2_cts_adj.f b/int/oldies/ros2_cts_adj.f similarity index 100% rename from boxmox/int.modified_WCOPY/oldies/ros2_cts_adj.f rename to int/oldies/ros2_cts_adj.f diff --git a/boxmox/int.modified_WCOPY/oldies/ros2_ddm.def b/int/oldies/ros2_ddm.def similarity index 100% rename from boxmox/int.modified_WCOPY/oldies/ros2_ddm.def rename to int/oldies/ros2_ddm.def diff --git a/boxmox/int.modified_WCOPY/oldies/ros2_ddm.f b/int/oldies/ros2_ddm.f similarity index 100% rename from boxmox/int.modified_WCOPY/oldies/ros2_ddm.f rename to int/oldies/ros2_ddm.f diff --git a/boxmox/int.modified_WCOPY/oldies/ros3.c b/int/oldies/ros3.c similarity index 100% rename from boxmox/int.modified_WCOPY/oldies/ros3.c rename to int/oldies/ros3.c diff --git a/boxmox/int.modified_WCOPY/oldies/ros3.def b/int/oldies/ros3.def similarity index 100% rename from boxmox/int.modified_WCOPY/oldies/ros3.def rename to int/oldies/ros3.def diff --git a/boxmox/int.modified_WCOPY/oldies/ros3.f b/int/oldies/ros3.f similarity index 100% rename from boxmox/int.modified_WCOPY/oldies/ros3.f rename to int/oldies/ros3.f diff --git a/boxmox/int.modified_WCOPY/oldies/ros3_ddm.def b/int/oldies/ros3_ddm.def similarity index 100% rename from boxmox/int.modified_WCOPY/oldies/ros3_ddm.def rename to int/oldies/ros3_ddm.def diff --git a/boxmox/int.modified_WCOPY/oldies/ros3_ddm.f b/int/oldies/ros3_ddm.f similarity index 100% rename from boxmox/int.modified_WCOPY/oldies/ros3_ddm.f rename to int/oldies/ros3_ddm.f diff --git a/boxmox/int.modified_WCOPY/oldies/ros4.def b/int/oldies/ros4.def similarity index 100% rename from boxmox/int.modified_WCOPY/oldies/ros4.def rename to int/oldies/ros4.def diff --git a/boxmox/int.modified_WCOPY/oldies/ros4.f b/int/oldies/ros4.f similarity index 100% rename from boxmox/int.modified_WCOPY/oldies/ros4.f rename to int/oldies/ros4.f diff --git a/boxmox/int.modified_WCOPY/oldies/ros4_ddm.def b/int/oldies/ros4_ddm.def similarity index 100% rename from boxmox/int.modified_WCOPY/oldies/ros4_ddm.def rename to int/oldies/ros4_ddm.def diff --git a/boxmox/int.modified_WCOPY/oldies/ros4_ddm.f b/int/oldies/ros4_ddm.f similarity index 100% rename from boxmox/int.modified_WCOPY/oldies/ros4_ddm.f rename to int/oldies/ros4_ddm.f diff --git a/boxmox/int.modified_WCOPY/oldies/twostepj.def b/int/oldies/twostepj.def similarity index 100% rename from boxmox/int.modified_WCOPY/oldies/twostepj.def rename to int/oldies/twostepj.def diff --git a/boxmox/int.modified_WCOPY/oldies/twostepj.f b/int/oldies/twostepj.f similarity index 100% rename from boxmox/int.modified_WCOPY/oldies/twostepj.f rename to int/oldies/twostepj.f diff --git a/boxmox/int.modified_WCOPY/readme b/int/readme similarity index 100% rename from boxmox/int.modified_WCOPY/readme rename to int/readme diff --git a/boxmox/int.modified_WCOPY/rosenbrock.c b/int/rosenbrock.c similarity index 100% rename from boxmox/int.modified_WCOPY/rosenbrock.c rename to int/rosenbrock.c diff --git a/boxmox/int.modified_WCOPY/rosenbrock.def b/int/rosenbrock.def similarity index 100% rename from boxmox/int.modified_WCOPY/rosenbrock.def rename to int/rosenbrock.def diff --git a/boxmox/int.modified_WCOPY/rosenbrock.f b/int/rosenbrock.f similarity index 100% rename from boxmox/int.modified_WCOPY/rosenbrock.f rename to int/rosenbrock.f diff --git a/boxmox/int/rosenbrock.f90 b/int/rosenbrock.f90 similarity index 100% rename from boxmox/int/rosenbrock.f90 rename to int/rosenbrock.f90 diff --git a/boxmox/int.modified_WCOPY/rosenbrock.m b/int/rosenbrock.m similarity index 100% rename from boxmox/int.modified_WCOPY/rosenbrock.m rename to int/rosenbrock.m diff --git a/boxmox/int.modified_WCOPY/rosenbrock_adj.c b/int/rosenbrock_adj.c similarity index 100% rename from boxmox/int.modified_WCOPY/rosenbrock_adj.c rename to int/rosenbrock_adj.c diff --git a/boxmox/int.modified_WCOPY/rosenbrock_adj.def b/int/rosenbrock_adj.def similarity index 100% rename from boxmox/int.modified_WCOPY/rosenbrock_adj.def rename to int/rosenbrock_adj.def diff --git a/boxmox/int/rosenbrock_adj.f90 b/int/rosenbrock_adj.f90 similarity index 100% rename from boxmox/int/rosenbrock_adj.f90 rename to int/rosenbrock_adj.f90 diff --git a/boxmox/int.modified_WCOPY/rosenbrock_tlm.def b/int/rosenbrock_tlm.def similarity index 100% rename from boxmox/int.modified_WCOPY/rosenbrock_tlm.def rename to int/rosenbrock_tlm.def diff --git a/boxmox/int/rosenbrock_tlm.f90 b/int/rosenbrock_tlm.f90 similarity index 100% rename from boxmox/int/rosenbrock_tlm.f90 rename to int/rosenbrock_tlm.f90 diff --git a/boxmox/int.modified_WCOPY/runge_kutta.c b/int/runge_kutta.c similarity index 100% rename from boxmox/int.modified_WCOPY/runge_kutta.c rename to int/runge_kutta.c diff --git a/boxmox/int.modified_WCOPY/runge_kutta.def b/int/runge_kutta.def similarity index 100% rename from boxmox/int.modified_WCOPY/runge_kutta.def rename to int/runge_kutta.def diff --git a/boxmox/int/runge_kutta.f90 b/int/runge_kutta.f90 similarity index 100% rename from boxmox/int/runge_kutta.f90 rename to int/runge_kutta.f90 diff --git a/boxmox/int/runge_kutta.m b/int/runge_kutta.m similarity index 100% rename from boxmox/int/runge_kutta.m rename to int/runge_kutta.m diff --git a/boxmox/int.modified_WCOPY/runge_kutta_adj.def b/int/runge_kutta_adj.def similarity index 100% rename from boxmox/int.modified_WCOPY/runge_kutta_adj.def rename to int/runge_kutta_adj.def diff --git a/boxmox/int/runge_kutta_adj.f90 b/int/runge_kutta_adj.f90 similarity index 100% rename from boxmox/int/runge_kutta_adj.f90 rename to int/runge_kutta_adj.f90 diff --git a/boxmox/int.modified_WCOPY/runge_kutta_tlm.def b/int/runge_kutta_tlm.def similarity index 100% rename from boxmox/int.modified_WCOPY/runge_kutta_tlm.def rename to int/runge_kutta_tlm.def diff --git a/boxmox/int/runge_kutta_tlm.f90 b/int/runge_kutta_tlm.f90 similarity index 100% rename from boxmox/int/runge_kutta_tlm.f90 rename to int/runge_kutta_tlm.f90 diff --git a/boxmox/int.modified_WCOPY/sdirk.c b/int/sdirk.c similarity index 100% rename from boxmox/int.modified_WCOPY/sdirk.c rename to int/sdirk.c diff --git a/boxmox/int.modified_WCOPY/sdirk.def b/int/sdirk.def similarity index 100% rename from boxmox/int.modified_WCOPY/sdirk.def rename to int/sdirk.def diff --git a/boxmox/int.modified_WCOPY/sdirk.f b/int/sdirk.f similarity index 100% rename from boxmox/int.modified_WCOPY/sdirk.f rename to int/sdirk.f diff --git a/boxmox/int.modified_WCOPY/sdirk.f90 b/int/sdirk.f90 similarity index 100% rename from boxmox/int.modified_WCOPY/sdirk.f90 rename to int/sdirk.f90 diff --git a/boxmox/int/sdirk.m b/int/sdirk.m similarity index 100% rename from boxmox/int/sdirk.m rename to int/sdirk.m diff --git a/boxmox/int.modified_WCOPY/sdirk_adj.c b/int/sdirk_adj.c similarity index 100% rename from boxmox/int.modified_WCOPY/sdirk_adj.c rename to int/sdirk_adj.c diff --git a/boxmox/int.modified_WCOPY/sdirk_adj.def b/int/sdirk_adj.def similarity index 100% rename from boxmox/int.modified_WCOPY/sdirk_adj.def rename to int/sdirk_adj.def diff --git a/boxmox/int/sdirk_adj.f90 b/int/sdirk_adj.f90 similarity index 100% rename from boxmox/int/sdirk_adj.f90 rename to int/sdirk_adj.f90 diff --git a/boxmox/int.modified_WCOPY/sdirk_tlm.def b/int/sdirk_tlm.def similarity index 100% rename from boxmox/int.modified_WCOPY/sdirk_tlm.def rename to int/sdirk_tlm.def diff --git a/boxmox/int.modified_WCOPY/sdirk_tlm.f90 b/int/sdirk_tlm.f90 similarity index 100% rename from boxmox/int.modified_WCOPY/sdirk_tlm.f90 rename to int/sdirk_tlm.f90 diff --git a/boxmox/int.modified_WCOPY/tau_leap.def b/int/tau_leap.def similarity index 100% rename from boxmox/int.modified_WCOPY/tau_leap.def rename to int/tau_leap.def diff --git a/boxmox/int.modified_WCOPY/tau_leap.f90 b/int/tau_leap.f90 similarity index 100% rename from boxmox/int.modified_WCOPY/tau_leap.f90 rename to int/tau_leap.f90 diff --git a/boxmox/int.modified_WCOPY/user_contributed/readme b/int/user_contributed/readme similarity index 100% rename from boxmox/int.modified_WCOPY/user_contributed/readme rename to int/user_contributed/readme diff --git a/boxmox/int.modified_WCOPY/user_contributed/ros2_manual.def b/int/user_contributed/ros2_manual.def similarity index 100% rename from boxmox/int.modified_WCOPY/user_contributed/ros2_manual.def rename to int/user_contributed/ros2_manual.def diff --git a/boxmox/int.modified_WCOPY/user_contributed/ros2_manual.f90 b/int/user_contributed/ros2_manual.f90 similarity index 100% rename from boxmox/int.modified_WCOPY/user_contributed/ros2_manual.f90 rename to int/user_contributed/ros2_manual.f90 diff --git a/boxmox/models/CB05TUCl_EPA.def b/models/CB05TUCl_EPA.def similarity index 100% rename from boxmox/models/CB05TUCl_EPA.def rename to models/CB05TUCl_EPA.def diff --git a/boxmox/models/CB05TUCl_EPA.eqn b/models/CB05TUCl_EPA.eqn similarity index 100% rename from boxmox/models/CB05TUCl_EPA.eqn rename to models/CB05TUCl_EPA.eqn diff --git a/boxmox/models/CB05TUCl_EPA.spc b/models/CB05TUCl_EPA.spc similarity index 100% rename from boxmox/models/CB05TUCl_EPA.spc rename to models/CB05TUCl_EPA.spc diff --git a/boxmox/models/CB05TUCl_NCSU.def b/models/CB05TUCl_NCSU.def similarity index 100% rename from boxmox/models/CB05TUCl_NCSU.def rename to models/CB05TUCl_NCSU.def diff --git a/boxmox/models/CB05TUCl_NCSU.eqn b/models/CB05TUCl_NCSU.eqn similarity index 100% rename from boxmox/models/CB05TUCl_NCSU.eqn rename to models/CB05TUCl_NCSU.eqn diff --git a/boxmox/models/CB05TUCl_NCSU.spc b/models/CB05TUCl_NCSU.spc similarity index 100% rename from boxmox/models/CB05TUCl_NCSU.spc rename to models/CB05TUCl_NCSU.spc diff --git a/boxmox/models/CB05_CSIRO.def b/models/CB05_CSIRO.def similarity index 100% rename from boxmox/models/CB05_CSIRO.def rename to models/CB05_CSIRO.def diff --git a/boxmox/models/CB05_CSIRO.eqn b/models/CB05_CSIRO.eqn similarity index 100% rename from boxmox/models/CB05_CSIRO.eqn rename to models/CB05_CSIRO.eqn diff --git a/boxmox/models/CB05_CSIRO.spc b/models/CB05_CSIRO.spc similarity index 100% rename from boxmox/models/CB05_CSIRO.spc rename to models/CB05_CSIRO.spc diff --git a/boxmox/models/CBMZ.def b/models/CBMZ.def similarity index 100% rename from boxmox/models/CBMZ.def rename to models/CBMZ.def diff --git a/boxmox/models/CBMZ.eqn b/models/CBMZ.eqn similarity index 100% rename from boxmox/models/CBMZ.eqn rename to models/CBMZ.eqn diff --git a/boxmox/models/CBMZ.spc b/models/CBMZ.spc similarity index 100% rename from boxmox/models/CBMZ.spc rename to models/CBMZ.spc diff --git a/boxmox/models/HETCHEM.def b/models/HETCHEM.def similarity index 100% rename from boxmox/models/HETCHEM.def rename to models/HETCHEM.def diff --git a/boxmox/models/HETCHEM.eqn b/models/HETCHEM.eqn similarity index 100% rename from boxmox/models/HETCHEM.eqn rename to models/HETCHEM.eqn diff --git a/boxmox/models/HETCHEM.spc b/models/HETCHEM.spc similarity index 100% rename from boxmox/models/HETCHEM.spc rename to models/HETCHEM.spc diff --git a/boxmox/models/MCMv3_3.def b/models/MCMv3_3.def similarity index 100% rename from boxmox/models/MCMv3_3.def rename to models/MCMv3_3.def diff --git a/boxmox/models/MCMv3_3.eqn b/models/MCMv3_3.eqn similarity index 100% rename from boxmox/models/MCMv3_3.eqn rename to models/MCMv3_3.eqn diff --git a/boxmox/models/MCMv3_3.spc b/models/MCMv3_3.spc similarity index 100% rename from boxmox/models/MCMv3_3.spc rename to models/MCMv3_3.spc diff --git a/boxmox/models/MOZART_4.def b/models/MOZART_4.def similarity index 100% rename from boxmox/models/MOZART_4.def rename to models/MOZART_4.def diff --git a/boxmox/models/MOZART_4.eqn b/models/MOZART_4.eqn similarity index 100% rename from boxmox/models/MOZART_4.eqn rename to models/MOZART_4.eqn diff --git a/boxmox/models/MOZART_4.spc b/models/MOZART_4.spc similarity index 100% rename from boxmox/models/MOZART_4.spc rename to models/MOZART_4.spc diff --git a/boxmox/models/MOZART_T1.def b/models/MOZART_T1.def similarity index 100% rename from boxmox/models/MOZART_T1.def rename to models/MOZART_T1.def diff --git a/boxmox/models/MOZART_T1.eqn b/models/MOZART_T1.eqn similarity index 100% rename from boxmox/models/MOZART_T1.eqn rename to models/MOZART_T1.eqn diff --git a/boxmox/models/MOZART_T1.spc b/models/MOZART_T1.spc similarity index 100% rename from boxmox/models/MOZART_T1.spc rename to models/MOZART_T1.spc diff --git a/boxmox/models/NO_NO2.def b/models/NO_NO2.def similarity index 100% rename from boxmox/models/NO_NO2.def rename to models/NO_NO2.def diff --git a/boxmox/models/NO_NO2.eqn b/models/NO_NO2.eqn similarity index 100% rename from boxmox/models/NO_NO2.eqn rename to models/NO_NO2.eqn diff --git a/boxmox/models/NO_NO2.spc b/models/NO_NO2.spc similarity index 100% rename from boxmox/models/NO_NO2.spc rename to models/NO_NO2.spc diff --git a/boxmox/models/RACM.def b/models/RACM.def similarity index 100% rename from boxmox/models/RACM.def rename to models/RACM.def diff --git a/boxmox/models/RACM.eqn b/models/RACM.eqn similarity index 100% rename from boxmox/models/RACM.eqn rename to models/RACM.eqn diff --git a/boxmox/models/RACM.spc b/models/RACM.spc similarity index 100% rename from boxmox/models/RACM.spc rename to models/RACM.spc diff --git a/boxmox/models/RADM2.def b/models/RADM2.def similarity index 100% rename from boxmox/models/RADM2.def rename to models/RADM2.def diff --git a/boxmox/models/RADM2.eqn b/models/RADM2.eqn similarity index 100% rename from boxmox/models/RADM2.eqn rename to models/RADM2.eqn diff --git a/boxmox/models/RADM2.spc b/models/RADM2.spc similarity index 100% rename from boxmox/models/RADM2.spc rename to models/RADM2.spc diff --git a/boxmox/models/RADMKA.def b/models/RADMKA.def similarity index 100% rename from boxmox/models/RADMKA.def rename to models/RADMKA.def diff --git a/boxmox/models/RADMKA.eqn b/models/RADMKA.eqn similarity index 100% rename from boxmox/models/RADMKA.eqn rename to models/RADMKA.eqn diff --git a/boxmox/models/RADMKA.spc b/models/RADMKA.spc similarity index 100% rename from boxmox/models/RADMKA.spc rename to models/RADMKA.spc diff --git a/boxmox/models/SAPRC99.def b/models/SAPRC99.def similarity index 100% rename from boxmox/models/SAPRC99.def rename to models/SAPRC99.def diff --git a/boxmox/models/SAPRC99.eqn b/models/SAPRC99.eqn similarity index 100% rename from boxmox/models/SAPRC99.eqn rename to models/SAPRC99.eqn diff --git a/boxmox/models/SAPRC99.spc b/models/SAPRC99.spc similarity index 100% rename from boxmox/models/SAPRC99.spc rename to models/SAPRC99.spc diff --git a/boxmox/models/atoms b/models/atoms similarity index 100% rename from boxmox/models/atoms rename to models/atoms diff --git a/boxmox/models/atoms_red b/models/atoms_red similarity index 100% rename from boxmox/models/atoms_red rename to models/atoms_red diff --git a/models/smog.def b/models/smog.def new file mode 100644 index 0000000000000000000000000000000000000000..02375e97cb85da498bfb822d25ea9f298e96c13f --- /dev/null +++ b/models/smog.def @@ -0,0 +1,6 @@ +#include smog.spc +#include smog.eqn + +#include ../boxmox/wrapper + +#LOOKATALL diff --git a/models/smog.eqn b/models/smog.eqn new file mode 100644 index 0000000000000000000000000000000000000000..0952795111b555eb96dc3d4636e52e6fab24e04f --- /dev/null +++ b/models/smog.eqn @@ -0,0 +1,17 @@ +#EQUATIONS + +{ A Generalized Reaction Mechanism for Photochemical Smog } + +{ 1.} NO2 + hv = NO + O : 1.7e-2_dp ; +{ 2.} O + O2 = O3 : M * 6.0e-34_dp * (TEMP/300._dp)**(-2.3_dp) ; +{ 3.} NO + O3 = NO2 + O2 : ARR2(1.8e-12_dp, 1370._dp, TEMP) ; +{ 4.} RH + OH = RO2 + H2O : ARR2(2.0e-11_dp, 500._dp, TEMP) ; +{ 5.} RCHO + OH = RCOO2 + H2O : ARR2(7.0e-12_dp, -250._dp, TEMP) ; +{ 6.} RCHO + hv = RO2 + HO2 + CO : 2.7e-5_dp ; +{ 7.} HO2 + NO = NO2 + OH : ARR2(3.7e-12_dp, -240.0_dp, TEMP) ; +{ 8.} RO2 + NO = NO2 + RCHO + HO2 : ARR2(4.2e-12_dp, -180.0_dp, TEMP) ; +{ 9.} RCOO2 + NO = NO2 + RO2 + CO2 : ARR2(5.4e-12_dp, -250.0_dp, TEMP) ; +{10.} OH + NO2 = HNO3 : ARR2(1.0e-12_dp, -713.0_dp, TEMP) ; +{11.} RCOO2 + NO2 = RCOO2NO2 : ARR2(1.2e-11_dp, 0.0_dp, TEMP) ; +{12.} RCOO2NO2 = RCOO2 + NO2 : ARR2(9.4e+16_dp, 14000.0_dp, TEMP) ; + diff --git a/models/smog.spc b/models/smog.spc new file mode 100644 index 0000000000000000000000000000000000000000..fa070ef90ef8ac937e583f378488c8dcadd8a437 --- /dev/null +++ b/models/smog.spc @@ -0,0 +1,37 @@ +#include atoms + + #DEFVAR + O = O ; {oxygen atomic ground state (3P)} + O3 = 3O ; {ozone} + NO = N + O ; {nitric oxide} + NO2 = N + 2O ; {nitrogen dioxide} + NO3 = N + 3O ; {nitrogen trioxide} + N2O5 = 2N + 5O ; {dinitrogen pentoxide} + HNO3 = H + N + 3O ; { nitric acid } + HNO4 = H + N + 4O ; {HO2NO2 pernitric acid} + H = H ; {hydrogen atomic ground state (2S)} + OH = O + H ; {hydroxyl radical} + HO2 = H + 2O ; {perhydroxyl radical} + H2O2 = 2H + 2O ; {hydrogen peroxide} + CH3 = C + 3H ; {methyl radical} + CH3O = C + 3H + O ; {methoxy radical} + CH3O2 = C + 3H + 2O ; {methylperoxy radical} + CH3OOH = C + 4H + 2O ; {CH4O2 methylperoxy alcohol} + HCO = H + C + O ; {CHO formyl radical} + CH2O = C + 2H + O ; {formalydehyde} + + RH = ignore ; + RO2 = ignore ; + RCHO = ignore ; + RCOO2 = ignore ; + RCOO2NO2 = ignore ; + +#DEFFIX + H2O = H + 2O ; {water} + H2 = 2H ; {molecular hydrogen} + O2 = 2O ; {molecular oxygen} + N2 = 2N ; {molecular nitrogen} + CH4 = C + 4H ; {methane} + CO = C + O ; {carbon monoxide} + CO2 = C + 2O ; {carbon dioxide} + diff --git a/boxmox/boxmox/bin/list_BOXMOX_mechanisms b/scripts/list_BOXMOX_mechanisms similarity index 72% rename from boxmox/boxmox/bin/list_BOXMOX_mechanisms rename to scripts/list_BOXMOX_mechanisms index b5278d706cdd958420132ff9974b06bfca2de1fb..433bf515171433a0905720435d300b3188105c7e 100755 --- a/boxmox/boxmox/bin/list_BOXMOX_mechanisms +++ b/scripts/list_BOXMOX_mechanisms @@ -14,8 +14,6 @@ done shift $(($OPTIND - 1)) -BOXMOX_PATH=${KPP_HOME}/boxmox - # sanity checks if $help then @@ -28,16 +26,18 @@ fi # check if BOXMOX is correctly set up validate_BOXMOX_installation || { echo "Validating BOXMOX installation failed"; exit 1; } -BOXMOX_MECH_PATH=${BOXMOX_PATH}/compiled_mechs +BOXMOX_MECH_PATH=${KPP_HOME}/compiled_mechs -for mech in $(ls -1 -d ${BOXMOX_MECH_PATH}/*) -do - mechList+=($(basename $mech)) -done +if [ ! -z $(ls -A ${BOXMOX_MECH_PATH}) ]; then + for mech in $(ls -1 -d ${BOXMOX_MECH_PATH}/*) + do + mechList+=($(basename $mech)) + done +fi if $all then - for mech in $(ls -1 ${BOXMOX_PATH}/models/*.eqn) + for mech in $(ls -1 ${KPP_HOME}/models/*.eqn) do mechi=$(basename $mech) mechList+=(${mechi/.eqn/}) @@ -46,4 +46,3 @@ fi echo $( for i in "${mechList[@]}"; do echo $i; done | sort -u ) - diff --git a/boxmox/boxmox/bin/new_BOXMOX_experiment b/scripts/new_BOXMOX_experiment similarity index 89% rename from boxmox/boxmox/bin/new_BOXMOX_experiment rename to scripts/new_BOXMOX_experiment index 41aa16cbbef58af3b73a8fa62c9ae60ab83f6d81..e6a4f901f40d165697b4456be5912ebff35c2b77 100755 --- a/boxmox/boxmox/bin/new_BOXMOX_experiment +++ b/scripts/new_BOXMOX_experiment @@ -12,8 +12,6 @@ done shift $(($OPTIND - 1)) -BOXMOX_PATH=${KPP_HOME}/boxmox - # sanity checks if [[ $# -lt 1 ]] || [[ $# -gt 2 ]] then @@ -29,9 +27,9 @@ mech_req=$1 # check if BOXMOX is correctly set up validate_BOXMOX_installation || { echo "Validating BOXMOX installation failed"; exit 1; } -BOXMOX_MECH_PATH=${BOXMOX_PATH}/compiled_mechs +BOXMOX_MECH_PATH=${KPP_HOME}/compiled_mechs -default_nml=${BOXMOX_PATH}/examples/BOXMOX.nml +default_nml=${KPP_HOME}/case_studies/BOXMOX.nml mech_path=${BOXMOX_MECH_PATH}/${mech_req} mech_exe=${mech_path}/${mech_req}.exe diff --git a/boxmox/boxmox/bin/new_BOXMOX_experiment_from_example b/scripts/new_BOXMOX_experiment_from_example similarity index 84% rename from boxmox/boxmox/bin/new_BOXMOX_experiment_from_example rename to scripts/new_BOXMOX_experiment_from_example index 5854cdb5e9e524b2c6f9ac7d54a0ca9e9106b277..cf3c5805004494984083bbdb2e09046b758bf4cc 100755 --- a/boxmox/boxmox/bin/new_BOXMOX_experiment_from_example +++ b/scripts/new_BOXMOX_experiment_from_example @@ -12,15 +12,13 @@ done shift $(($OPTIND - 1)) -BOXMOX_PATH=${KPP_HOME}/boxmox - # sanity checks if [[ $# -lt 1 ]] || [[ $# -gt 2 ]] then echo "Call with ()." echo "If you omit , a subfolder with the name will be used." echo "Use -f to force removal of existing experiment folder." - echo "Examples available: "$(find ${BOXMOX_PATH}/examples/* -maxdepth 1 -type d -exec basename {} \;) + echo "Examples available: "$(find ${KPP_HOME}/case_studies/* -maxdepth 1 -type d -exec basename {} \;) exit 1 fi @@ -30,7 +28,7 @@ example_req=$1 # check if BOXMOX is correctly set up validate_BOXMOX_installation || { echo "Validating BOXMOX installation failed"; exit 1; } -example_dir=${BOXMOX_PATH}/examples/${example_req} +example_dir=${KPP_HOME}/case_studies/${example_req} # check if example exists if [ ! -d ${example_dir} ] diff --git a/boxmox/boxmox/bin/prepare_BOXMOX_mechanism b/scripts/prepare_BOXMOX_mechanism similarity index 97% rename from boxmox/boxmox/bin/prepare_BOXMOX_mechanism rename to scripts/prepare_BOXMOX_mechanism index fbf4c8b15da7122b8d05985f6cc00511d2623d1a..606a83434cb427f2f2b5e129b391a91722785011 100755 --- a/boxmox/boxmox/bin/prepare_BOXMOX_mechanism +++ b/scripts/prepare_BOXMOX_mechanism @@ -14,8 +14,6 @@ done shift $(($OPTIND - 1)) -BOXMOX_PATH=${KPP_HOME}/boxmox - # sanity checks if [ $# -ne 1 ] then @@ -32,7 +30,7 @@ mech_req=$1 # check if BOXMOX is correctly set up validate_BOXMOX_installation || { echo "Validating BOXMOX installation failed."; exit 1; } -BOXMOX_MECH_PATH=${BOXMOX_PATH}/compiled_mechs +BOXMOX_MECH_PATH=${KPP_HOME}/compiled_mechs work_path=${KPP_HOME}/tmp_${mech_req}_${RANDOM}_BOXMOX diff --git a/boxmox/boxmox/bin/validate_BOXMOX_installation b/scripts/validate_BOXMOX_installation similarity index 67% rename from boxmox/boxmox/bin/validate_BOXMOX_installation rename to scripts/validate_BOXMOX_installation index 493dffe20c6bf98f3a2f337b14e2d2b7cf7b681f..6afc953582c01de55d8d72d8c16e96106858e50a 100755 --- a/boxmox/boxmox/bin/validate_BOXMOX_installation +++ b/scripts/validate_BOXMOX_installation @@ -7,17 +7,15 @@ echo "Set it with" echo "" echo "export KPP_HOME= (bash)" - echo "setenv KPP_HOME (*csh)" + echo "setenv KPP_HOME (*csh)" echo "" exit 1 } -BOXMOX_PATH=${KPP_HOME}/boxmox - -[ ! -d ${BOXMOX_PATH} ] && { +[ ! -d ${KPP_HOME} ] && { echo "" - echo "No BOXMOX found at ${BOXMOX_PATH}." + echo "No BOXMOX found at ${KPP_HOME}." echo "" echo "Please reinstall or correctly set the \$KPP_HOME environment variable." echo "" diff --git a/src/.gitignore b/src/.gitignore new file mode 100644 index 0000000000000000000000000000000000000000..763306ec4b50eaa317465d6429ca9ce98eca6b31 --- /dev/null +++ b/src/.gitignore @@ -0,0 +1,9 @@ +Makefile.in +aclocal.m4 +compile +configure +depcomp +install-sh +missing +ylwrap +*.o diff --git a/boxmox/Makefile b/src/Makefile.am old mode 100644 new mode 100755 similarity index 65% rename from boxmox/Makefile rename to src/Makefile.am index 942e039e21816f8c16fb1fd831fa24c75544a801..6fe87681e6fb9d7380fd06cfa13d6d835e905fbf --- a/boxmox/Makefile +++ b/src/Makefile.am @@ -4,7 +4,8 @@ # Builds simulation code for chemical kinetic systems # # Copyright (C) 1995-1996 Valeriu Damian and Adrian Sandu -# Copyright (C) 1997-2004 Adrian Sandu +# Copyright (C) 1997-2005 Adrian Sandu +# with contributions from: Mirela Damian, Rolf Sander # # KPP is free software; you can redistribute it and/or modify it under the # terms of the GNU General Public License as published by the Free Software @@ -28,35 +29,12 @@ # E-mail: sandu@cs.vt.edu # ####################################################################################### -include Makefile.defs -.PHONY: boxmox +# modified to use GNU autotools +# Christoph Knote, christoph.knote@med.uni-augsburg.de, 11-2021 -all: setup kpp boxmox - -setup: - @./cflags.guess $(CC); mkdir -p bin - -kpp: - @echo "Compiling KPP" - @cd src;make;cd .. - -boxmox_clean: - @rm -f boxmox/README.pdf boxmox/README.aux boxmox/README.log boxmox/README.toc - -boxmox_doc: - @echo "Tex'ing BOXMOX readme (boxmox/README.pdf, if pdflatex is available)" - -cd boxmox; pdflatex README.tex - -cd boxmox; pdflatex README.tex - -boxmox: boxmox_doc - @echo "Setting the execute bit for user commands" - @chmod +x boxmox/bin/* - -clean: boxmox_clean - @cd src;make clean;cd .. - @rm -f *~ */*~ - -distclean: clean - @cd src;make maintainer-clean;cd .. - @rm -f bin/kpp +BUILT_SOURCES = yacc.c bison.c bison.h +AM_YFLAGS = -d +bin_PROGRAMS = kpp +kpp_SOURCES = code.c code_c.c code_f77.c code_f90.c code_matlab.c \ + debug.c gen.c kpp.c scanner.c scanutil.c gdata.h code.h scan.h yacc.l bison.y diff --git a/boxmox/src/scan.y b/src/bison.y similarity index 99% rename from boxmox/src/scan.y rename to src/bison.y index 021fc642aa6159ac376cae9aa83c89951e96b731..18ca99ea8d6c64b1044efe125ed1256752b9a1af 100755 --- a/boxmox/src/scan.y +++ b/src/bison.y @@ -37,10 +37,11 @@ %{ #include #include - #include + //#include #include #include #include "scan.h" + #include "gdata.h" #define __YYSCLASS @@ -66,6 +67,8 @@ void ParserErrorMessage(); void yyerror(char *); + + int yylex(); %} diff --git a/boxmox/src/code.c b/src/code.c similarity index 99% rename from boxmox/src/code.c rename to src/code.c index 6cbe1b169060442226f53dc84f7f848fe0861360..92b20dca19f11b227995f5c3d8ff1e2feef4466b 100755 --- a/boxmox/src/code.c +++ b/src/code.c @@ -32,6 +32,7 @@ #include "gdata.h" #include "code.h" +#include "scan.h" #include #include diff --git a/boxmox/src/code.h b/src/code.h similarity index 98% rename from boxmox/src/code.h rename to src/code.h index 86c4c01d66b4707ff2a6321ff7cf8f6031cf2f1d..10bff7ca78f534d53931e361847ed381b5a04f15 100755 --- a/boxmox/src/code.h +++ b/src/code.h @@ -186,6 +186,9 @@ extern void (*FunctionPrototipe)( int f, ... ); extern void (*FunctionBegin)( int f, ... ); extern void (*FunctionEnd)( int f ); +void MATLAB_Inline( char *fmt, ... ); +void F90_Inline( char *fmt, ... ); + void WriteDelim(); #endif diff --git a/boxmox/src/code_c.c b/src/code_c.c similarity index 99% rename from boxmox/src/code_c.c rename to src/code_c.c index 821d19eeb9d1c1c3d96ac88f2577de64de13f331..cf82ba440d42ee7ec90704c77b1a26b329d201aa 100755 --- a/boxmox/src/code_c.c +++ b/src/code_c.c @@ -32,6 +32,7 @@ #include "gdata.h" #include "code.h" +#include "scan.h" #include #define MAX_LINE 120 diff --git a/boxmox/src/code_f77.c b/src/code_f77.c similarity index 100% rename from boxmox/src/code_f77.c rename to src/code_f77.c diff --git a/boxmox/src/code_f90.c b/src/code_f90.c similarity index 100% rename from boxmox/src/code_f90.c rename to src/code_f90.c diff --git a/boxmox/src/code_matlab.c b/src/code_matlab.c similarity index 99% rename from boxmox/src/code_matlab.c rename to src/code_matlab.c index afb105756314b35188b878b5fb613d3847746c2b..cf749df301a3cfd29c15cc20d99904236b8572b0 100755 --- a/boxmox/src/code_matlab.c +++ b/src/code_matlab.c @@ -34,10 +34,11 @@ #include "code.h" #include #include +#include "scan.h" #define MAX_LINE 120 -void FatalError( int status, char *fmt, char *buf ); +//void FatalError( int status, char *fmt, char *buf ); char *MATLAB_types[] = { "", /* VOID */ "INTEGER", /* INT */ diff --git a/boxmox/src/copyright b/src/copyright similarity index 100% rename from boxmox/src/copyright rename to src/copyright diff --git a/boxmox/src/debug.c b/src/debug.c similarity index 100% rename from boxmox/src/debug.c rename to src/debug.c diff --git a/boxmox/src/gdata.h b/src/gdata.h similarity index 100% rename from boxmox/src/gdata.h rename to src/gdata.h diff --git a/boxmox/src/gdef.h b/src/gdef.h similarity index 100% rename from boxmox/src/gdef.h rename to src/gdef.h diff --git a/boxmox/src/gen.c b/src/gen.c similarity index 99% rename from boxmox/src/gen.c rename to src/gen.c index b7635e5f909c68b711295cdec51b89d8ea2d8581..488deed00ca976603bb125b89cceb2a3203efd4a 100755 --- a/boxmox/src/gen.c +++ b/src/gen.c @@ -363,6 +363,82 @@ int dim; } + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +int EqnStr( int eq, char * buf, float** mat ) +{ +int spc, first; + +/* bugfix if stoichiometric factor is not an integer */ +int n; +char s[40]; + + first = 1; + *buf = 0; + for( spc = 0; spc < SpcNr; spc++ ) + if( mat[spc][eq] != 0 ) { + if( ((mat[spc][eq] == 1)||(mat[spc][eq] == -1)) ) { + sprintf(s, ""); + } else { + /* real */ + /* mz_rs_20050130+ */ + /* sprintf(s, "%g", mat[spc][eq]); */ + /* remove the minus sign with fabs(), it will be re-inserted later */ + sprintf(s, "%g", mat[spc][eq]?mat[spc][eq]:(-mat[spc][eq])); + /* mz_rs_20050130- */ + /* remove trailing zeroes */ + for (n= strlen(s) - 1; n >= 0; n--) + if (s[n] != '0') break; + s[n + 1]= '\0'; + sprintf(s, "%s ", s); + } + + if( first ) { + if( mat[spc][eq] > 0 ) sprintf(buf, "%s%s", buf, s); + else sprintf(buf, "%s- %s", buf, s); + first = 0; + } else { + if( mat[spc][eq] > 0 ) sprintf(buf, "%s + %s", buf, s); + else sprintf(buf, "%s - %s", buf, s); + } + sprintf(buf, "%s%s", buf, SpeciesTable[ Code[spc] ].name); + if (strlen(buf)>MAX_EQNLEN/2) { /* truncate if eqn string too long */ + sprintf(buf, "%s ... etc.",buf); + break; + } + } + + return strlen(buf); +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +int EqnString( int eq, char * buf ) +{ +static int lhs = 0; +static int rhs = 0; + +int i, l; +char lhsbuf[MAX_EQNLEN], rhsbuf[MAX_EQNLEN]; + + if(lhs == 0) for( i = 0; i < EqnNr; i++ ) { + l = EqnStr( i, lhsbuf, Stoich_Left); + lhs = (lhs > l) ? lhs : l; + } + + if(rhs == 0) for( i = 0; i < EqnNr; i++ ) { + l = EqnStr( i, rhsbuf, Stoich_Right); + rhs = (rhs > l) ? lhs : l; + } + + + EqnStr( eq, lhsbuf, Stoich_Left); + EqnStr( eq, rhsbuf, Stoich_Right); + + sprintf(buf, "%*s --> %-*s", lhs, lhsbuf, rhs, rhsbuf); + return strlen(buf); +} + + /*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ void GenerateMonitorData() { @@ -2380,81 +2456,6 @@ char buf[100]; FlushBuf(); } -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -int EqnStr( int eq, char * buf, float** mat ) -{ -int spc, first; - -/* bugfix if stoichiometric factor is not an integer */ -int n; -char s[40]; - - first = 1; - *buf = 0; - for( spc = 0; spc < SpcNr; spc++ ) - if( mat[spc][eq] != 0 ) { - if( ((mat[spc][eq] == 1)||(mat[spc][eq] == -1)) ) { - sprintf(s, ""); - } else { - /* real */ - /* mz_rs_20050130+ */ - /* sprintf(s, "%g", mat[spc][eq]); */ - /* remove the minus sign with fabs(), it will be re-inserted later */ - sprintf(s, "%g", mat[spc][eq]?mat[spc][eq]:(-mat[spc][eq])); - /* mz_rs_20050130- */ - /* remove trailing zeroes */ - for (n= strlen(s) - 1; n >= 0; n--) - if (s[n] != '0') break; - s[n + 1]= '\0'; - sprintf(s, "%s ", s); - } - - if( first ) { - if( mat[spc][eq] > 0 ) sprintf(buf, "%s%s", buf, s); - else sprintf(buf, "%s- %s", buf, s); - first = 0; - } else { - if( mat[spc][eq] > 0 ) sprintf(buf, "%s + %s", buf, s); - else sprintf(buf, "%s - %s", buf, s); - } - sprintf(buf, "%s%s", buf, SpeciesTable[ Code[spc] ].name); - if (strlen(buf)>MAX_EQNLEN/2) { /* truncate if eqn string too long */ - sprintf(buf, "%s ... etc.",buf); - break; - } - } - - return strlen(buf); -} - -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -int EqnString( int eq, char * buf ) -{ -static int lhs = 0; -static int rhs = 0; - -int i, l; -char lhsbuf[MAX_EQNLEN], rhsbuf[MAX_EQNLEN]; - - if(lhs == 0) for( i = 0; i < EqnNr; i++ ) { - l = EqnStr( i, lhsbuf, Stoich_Left); - lhs = (lhs > l) ? lhs : l; - } - - if(rhs == 0) for( i = 0; i < EqnNr; i++ ) { - l = EqnStr( i, rhsbuf, Stoich_Right); - rhs = (rhs > l) ? lhs : l; - } - - - EqnStr( eq, lhsbuf, Stoich_Left); - EqnStr( eq, rhsbuf, Stoich_Right); - - sprintf(buf, "%*s --> %-*s", lhs, lhsbuf, rhs, rhsbuf); - return strlen(buf); -} - - /*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ void GenerateMap() { diff --git a/boxmox/src/kpp.c b/src/kpp.c similarity index 100% rename from boxmox/src/kpp.c rename to src/kpp.c diff --git a/boxmox/src/scan.h b/src/scan.h similarity index 90% rename from boxmox/src/scan.h rename to src/scan.h index 6154e87bbe14fc0976881a391b4629e7a58aa1fb..350fb42b7cdce07512c7731fcdfbf46ca40bf204 100755 --- a/boxmox/src/scan.h +++ b/src/scan.h @@ -72,6 +72,10 @@ extern int nError; extern int nWarning; extern int crt_section; +int EqNoCase( char *s1, char *s2 ); + +int ParseEquationFile( char * filename ); + int Parser( char * filename ); void ScanError( char *fmt, ... ); void ParserError( char *fmt, ... ); @@ -102,6 +106,17 @@ void WriteSpecies(); void WriteMatrices(); void WriteOptions(); +void CmdStoicmat( char *cmd ); +void CheckAll(); +void LookAtAll(); +void TransportAll(); +void DefineInitializeNbr( char *cmd ); +void DefineXGrid( char *cmd ); +void DefineYGrid( char *cmd ); +void DefineZGrid( char *cmd ); +void SparseData( char *cmd ); +void AddUseFile( char *fname ); + char * AppendString( char * s1, char * s2, int * len, int addlen ); void AddInlineCode( char * context, char * code ); diff --git a/boxmox/src/scanner.c b/src/scanner.c similarity index 99% rename from boxmox/src/scanner.c rename to src/scanner.c index 3cbad0a7dc0db6323eecd4566b77501dfcbb5d17..7f96ff96f127d28d25e23ee7641c707478a3da53 100755 --- a/boxmox/src/scanner.c +++ b/src/scanner.c @@ -32,7 +32,7 @@ #include "gdata.h" #include "scan.h" -#include "y.tab.h" +#include "bison.h" #include #include #include diff --git a/boxmox/src/scanutil.c b/src/scanutil.c similarity index 99% rename from boxmox/src/scanutil.c rename to src/scanutil.c index cd992aee4e2205c472c8b1845500dd645ce9b9ac..e42e2dbb9a97a8dba2d6c3d2d339e7efea7e7313 100755 --- a/boxmox/src/scanutil.c +++ b/src/scanutil.c @@ -32,11 +32,12 @@ #include #include -#include +//#include #include #include #include "gdata.h" #include "scan.h" +#include #define MAX_BUFFER 200 diff --git a/boxmox/src/scan.l b/src/yacc.l similarity index 99% rename from boxmox/src/scan.l rename to src/yacc.l index ce564357f587493787e005e26a8939352288b81a..7b11d96276937addbc0d5baf586cc1156d892083 100755 --- a/boxmox/src/scan.l +++ b/src/yacc.l @@ -41,11 +41,14 @@ %s COMMENT COMMENT2 EQN_ID %x INL_CODE +%option noyywrap + %{ #include /* strcpy, strlen */ #include "gdata.h" #include "scan.h" - #include "y.tab.h" + #include "bison.h" + #include void Include ( char * filename ); int EndInclude(); @@ -82,6 +85,8 @@ KEYWORD keywords[]; + int EqNoCase( char *s1, char *s2 ); + int CheckKeyword( char *cmd ); #define RETURN( x ) \ diff --git a/create_BOXMOX_patch.bash b/tools/create_BOXMOX_patch.bash similarity index 100% rename from create_BOXMOX_patch.bash rename to tools/create_BOXMOX_patch.bash diff --git a/install_BOXMOX.bash b/tools/install_BOXMOX.bash similarity index 70% rename from install_BOXMOX.bash rename to tools/install_BOXMOX.bash index d167cb62849b442e59f9f82553b2c6876d4047bc..5965c06601a0fedf4c924a06c48d2306178d3401 100644 --- a/install_BOXMOX.bash +++ b/tools/install_BOXMOX.bash @@ -30,9 +30,6 @@ # 1.8 Christoph Knote - UniA - christoph.knote@med.uni-augsburg.de - 11/2021 # first release from new website at University Augsburg # -# ----------------------------------------------------------------------------- -hidden_switch=$1 # for internal use only -# ----------------------------------------------------------------------------- # USER SECTION # This is where your BOXMOX will be @@ -54,15 +51,6 @@ CC_FLAGS="-g -Wall" # standard headers INCLUDE_DIR=/usr/include -# possibly working configuration with Mac OS X Catalina (10.15), -# flex installed via homebrew, and Xcode (and developer command line tools) -# installed: -# CC=cc -# FLEX=/usr/local/opt/flex/bin/flex -# FLEX_LIB_DIR=/usr/local/Cellar/flex/2.6.4_1/lib/ -# CC_FLAGS="-g -Wall -I/Library/Developer/CommandLineTools/SDKs/MacOSX.sdk/usr/include/malloc" -# INCLUDE_DIR=/Library/Developer/CommandLineTools/SDKs/MacOSX.sdk/usr/include - # ----------------------------------------------------------------------------- # ----------------------------------------------------------------------------- # nothing to be changed beyond this point... @@ -70,9 +58,6 @@ INCLUDE_DIR=/usr/include boxmoxVersion=1.8 # see if we have everything we need -hash wget >/dev/null 2>&1 || { echo "BOXMOX installer needs 'wget'"; exit 1; } -hash tar >/dev/null 2>&1 || { echo "BOXMOX installer needs 'tar'"; exit 1; } -hash patch >/dev/null 2>&1 || { echo "BOXMOX installer needs 'patch'"; exit 1; } hash sed >/dev/null 2>&1 || { echo "BOXMOX installer needs 'sed'"; exit 1; } hash make >/dev/null 2>&1 || { echo "BOXMOX installer needs 'make'"; exit 1; } hash bison >/dev/null 2>&1 || { echo "BOXMOX installer needs 'bison'"; exit 1; } @@ -83,19 +68,8 @@ hash $CC >/dev/null 2>&1 || { echo "C compiler $CC unknown"; exit 1; } [ -f $FLEX_LIB_DIR/libfl.a ] || { echo "No FLEX library found in $FLEX_LIB_DIR"; exit 1; } [ -d $INCLUDE_DIR ] || { echo "No include directory found at $INCLUDE_DIR"; exit 1; } -if [ "$hidden_switch" != "COMPILE_ONLY" ] -then - [ -d $boxmoxDir ] && { echo "BOXMOX directory $boxmoxDir already exists"; exit 1; } -fi - hash gfortran >/dev/null 2>&1 || { echo "Note: BOXMOX will need 'gfortran' or another Fortran compiler."; } -# current KPP version -kppURL=http://people.cs.vt.edu/~asandu/Software/Kpp/Download/kpp-2.2.3_Nov.2012.tar.gz - -# current BOXMOX patch -boxmoxURL=https://mbees.med.uni-augsburg.de/boxmodeling/downloads/boxmox_${boxmoxVersion}_2.2.3.patch - # let's go - describe what's gonna happen echo " " echo "BOXMOX extension to KPP (${boxmoxVersion})" @@ -113,29 +87,6 @@ mkdir -p $boxmoxDir || { echo "Could not create BOXMOX directory $boxmoxDir"; ex cd $boxmoxDir -if [ "$hidden_switch" != "COMPILE_ONLY" ] -then - - echo "Downloading BOXMOX" - wget --no-check-certificate -o boxmox_download.log -O boxmox.patch $boxmoxURL || { echo "Could not download BOXMOX patch"; exit 1; } - - echo "Downloading KPP" - wget --no-check-certificate -o kpp_download.log -O kpp.tar.gz $kppURL || { echo "Could not download KPP"; exit 1; } - - echo "Unpacking KPP" - tar xzf kpp.tar.gz || { echo "Could not unpack KPP"; exit 1; } - - # get KPP out of its subfolder - subfolder=$(tar tf kpp.tar.gz) - subfolder=( $subfolder ) - subfolder=${subfolder[0]} - mv $subfolder/* . - rm -r $subfolder - - echo "Patching KPP" - patch -p1 < boxmox.patch > kpp_patch.log || { echo "Could not patch KPP"; exit 1; } -fi - # make (missing) bin subfolder mkdir -p bin diff --git a/kpp-2.2.3_Nov.2012.tar.gz b/tools/kpp-2.2.3_Nov.2012.tar.gz similarity index 100% rename from kpp-2.2.3_Nov.2012.tar.gz rename to tools/kpp-2.2.3_Nov.2012.tar.gz diff --git a/prep_BOXMOX_src_directory.bash b/tools/prep_BOXMOX_src_directory.bash similarity index 100% rename from prep_BOXMOX_src_directory.bash rename to tools/prep_BOXMOX_src_directory.bash diff --git a/boxmox/util/Makefile.c b/util/Makefile.c similarity index 100% rename from boxmox/util/Makefile.c rename to util/Makefile.c diff --git a/boxmox/util/Makefile.f b/util/Makefile.f similarity index 100% rename from boxmox/util/Makefile.f rename to util/Makefile.f diff --git a/boxmox/util/Makefile.f90 b/util/Makefile.f90 similarity index 100% rename from boxmox/util/Makefile.f90 rename to util/Makefile.f90 diff --git a/boxmox/util/Mex_Fun.c b/util/Mex_Fun.c similarity index 100% rename from boxmox/util/Mex_Fun.c rename to util/Mex_Fun.c diff --git a/boxmox/util/Mex_Fun.f b/util/Mex_Fun.f similarity index 100% rename from boxmox/util/Mex_Fun.f rename to util/Mex_Fun.f diff --git a/boxmox/util/Mex_Fun.f90 b/util/Mex_Fun.f90 similarity index 100% rename from boxmox/util/Mex_Fun.f90 rename to util/Mex_Fun.f90 diff --git a/boxmox/util/Mex_Hessian.c b/util/Mex_Hessian.c similarity index 100% rename from boxmox/util/Mex_Hessian.c rename to util/Mex_Hessian.c diff --git a/boxmox/util/Mex_Hessian.f b/util/Mex_Hessian.f similarity index 100% rename from boxmox/util/Mex_Hessian.f rename to util/Mex_Hessian.f diff --git a/boxmox/util/Mex_Hessian.f90 b/util/Mex_Hessian.f90 similarity index 100% rename from boxmox/util/Mex_Hessian.f90 rename to util/Mex_Hessian.f90 diff --git a/boxmox/util/Mex_Jac_SP.c b/util/Mex_Jac_SP.c similarity index 100% rename from boxmox/util/Mex_Jac_SP.c rename to util/Mex_Jac_SP.c diff --git a/boxmox/util/Mex_Jac_SP.f b/util/Mex_Jac_SP.f similarity index 100% rename from boxmox/util/Mex_Jac_SP.f rename to util/Mex_Jac_SP.f diff --git a/boxmox/util/Mex_Jac_SP.f90 b/util/Mex_Jac_SP.f90 similarity index 100% rename from boxmox/util/Mex_Jac_SP.f90 rename to util/Mex_Jac_SP.f90 diff --git a/boxmox/util/Template_Fun_Chem.m b/util/Template_Fun_Chem.m similarity index 100% rename from boxmox/util/Template_Fun_Chem.m rename to util/Template_Fun_Chem.m diff --git a/boxmox/util/Template_Jac_Chem.m b/util/Template_Jac_Chem.m similarity index 100% rename from boxmox/util/Template_Jac_Chem.m rename to util/Template_Jac_Chem.m diff --git a/boxmox/util/UpdateSun.c b/util/UpdateSun.c similarity index 100% rename from boxmox/util/UpdateSun.c rename to util/UpdateSun.c diff --git a/boxmox/util/UpdateSun.f b/util/UpdateSun.f similarity index 100% rename from boxmox/util/UpdateSun.f rename to util/UpdateSun.f diff --git a/boxmox/util/UpdateSun.f90 b/util/UpdateSun.f90 similarity index 100% rename from boxmox/util/UpdateSun.f90 rename to util/UpdateSun.f90 diff --git a/boxmox/util/UpdateSun.m b/util/UpdateSun.m similarity index 100% rename from boxmox/util/UpdateSun.m rename to util/UpdateSun.m diff --git a/boxmox/util/UserRateLaws.c b/util/UserRateLaws.c similarity index 100% rename from boxmox/util/UserRateLaws.c rename to util/UserRateLaws.c diff --git a/boxmox/util/UserRateLaws.f b/util/UserRateLaws.f similarity index 100% rename from boxmox/util/UserRateLaws.f rename to util/UserRateLaws.f diff --git a/boxmox/util/UserRateLaws.f90 b/util/UserRateLaws.f90 similarity index 100% rename from boxmox/util/UserRateLaws.f90 rename to util/UserRateLaws.f90 diff --git a/boxmox/util/UserRateLaws.m b/util/UserRateLaws.m similarity index 100% rename from boxmox/util/UserRateLaws.m rename to util/UserRateLaws.m diff --git a/boxmox/util/UserRateLaws_BOXMOX.f90 b/util/UserRateLaws_BOXMOX.f90 similarity index 100% rename from boxmox/util/UserRateLaws_BOXMOX.f90 rename to util/UserRateLaws_BOXMOX.f90 diff --git a/boxmox/util/UserRateLaws_FcnHeader.f b/util/UserRateLaws_FcnHeader.f similarity index 100% rename from boxmox/util/UserRateLaws_FcnHeader.f rename to util/UserRateLaws_FcnHeader.f diff --git a/boxmox/util/blas.c b/util/blas.c similarity index 100% rename from boxmox/util/blas.c rename to util/blas.c diff --git a/boxmox/util/blas.f b/util/blas.f similarity index 100% rename from boxmox/util/blas.f rename to util/blas.f diff --git a/boxmox/util/blas.f90 b/util/blas.f90 similarity index 100% rename from boxmox/util/blas.f90 rename to util/blas.f90 diff --git a/boxmox/util/dFun_dRcoeff.c b/util/dFun_dRcoeff.c similarity index 100% rename from boxmox/util/dFun_dRcoeff.c rename to util/dFun_dRcoeff.c diff --git a/boxmox/util/dFun_dRcoeff.f b/util/dFun_dRcoeff.f similarity index 100% rename from boxmox/util/dFun_dRcoeff.f rename to util/dFun_dRcoeff.f diff --git a/boxmox/util/dFun_dRcoeff.f90 b/util/dFun_dRcoeff.f90 similarity index 100% rename from boxmox/util/dFun_dRcoeff.f90 rename to util/dFun_dRcoeff.f90 diff --git a/boxmox/util/dFun_dRcoeff.m b/util/dFun_dRcoeff.m similarity index 100% rename from boxmox/util/dFun_dRcoeff.m rename to util/dFun_dRcoeff.m diff --git a/boxmox/util/dJac_dRcoeff.c b/util/dJac_dRcoeff.c similarity index 100% rename from boxmox/util/dJac_dRcoeff.c rename to util/dJac_dRcoeff.c diff --git a/boxmox/util/dJac_dRcoeff.f b/util/dJac_dRcoeff.f similarity index 100% rename from boxmox/util/dJac_dRcoeff.f rename to util/dJac_dRcoeff.f diff --git a/boxmox/util/dJac_dRcoeff.f90 b/util/dJac_dRcoeff.f90 similarity index 100% rename from boxmox/util/dJac_dRcoeff.f90 rename to util/dJac_dRcoeff.f90 diff --git a/boxmox/util/dJac_dRcoeff.m b/util/dJac_dRcoeff.m similarity index 100% rename from boxmox/util/dJac_dRcoeff.m rename to util/dJac_dRcoeff.m diff --git a/boxmox/util/mex.c b/util/mex.c similarity index 100% rename from boxmox/util/mex.c rename to util/mex.c diff --git a/boxmox/util/mex.f b/util/mex.f similarity index 100% rename from boxmox/util/mex.f rename to util/mex.f diff --git a/boxmox/util/ncar.c b/util/ncar.c similarity index 100% rename from boxmox/util/ncar.c rename to util/ncar.c diff --git a/boxmox/util/ncar.h b/util/ncar.h similarity index 100% rename from boxmox/util/ncar.h rename to util/ncar.h diff --git a/boxmox/util/sparsity_plots.m b/util/sparsity_plots.m similarity index 100% rename from boxmox/util/sparsity_plots.m rename to util/sparsity_plots.m diff --git a/boxmox/util/sutil.c b/util/sutil.c similarity index 100% rename from boxmox/util/sutil.c rename to util/sutil.c diff --git a/boxmox/util/sutil.f b/util/sutil.f similarity index 100% rename from boxmox/util/sutil.f rename to util/sutil.f diff --git a/boxmox/util/sutil.f90 b/util/sutil.f90 similarity index 100% rename from boxmox/util/sutil.f90 rename to util/sutil.f90 diff --git a/boxmox/util/tag2num.f90 b/util/tag2num.f90 similarity index 100% rename from boxmox/util/tag2num.f90 rename to util/tag2num.f90 diff --git a/boxmox/util/util.c b/util/util.c similarity index 100% rename from boxmox/util/util.c rename to util/util.c diff --git a/boxmox/util/util.f b/util/util.f similarity index 100% rename from boxmox/util/util.f rename to util/util.f diff --git a/boxmox/util/util.f90 b/util/util.f90 similarity index 100% rename from boxmox/util/util.f90 rename to util/util.f90 diff --git a/boxmox/util/util.m b/util/util.m similarity index 100% rename from boxmox/util/util.m rename to util/util.m