Index: /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_cbm4/cbm4.eqn
===================================================================
--- /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_cbm4/cbm4.eqn (revision 3698)
+++ /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_cbm4/cbm4.eqn (revision 3698)
@@ -0,0 +1,113 @@
+#EQUATIONS {CBM4}
+
+{01:J01} NO2+hv=NO+O : phot(j_no2) ;
+{02:J02} O3+hv=O : phot(j_o33p) ;
+{03:J03} O3+hv=O1D_CB4 : phot(j_o31d) ;
+{04:J04} NO3+hv=0.89 NO2+0.89 O+0.11 NO : phot(j_no3o)+phot(j_no3o2);
+{05:J05} HONO+hv=HO+NO : phot(j_hono) ;
+{06:J06} H2O2+hv=2 HO : phot(j_h2o2) ;
+{07:J07} HCHO+hv{+2 O2}= 2 HO2+CO : phot(j_ch2or) ;
+{08:J08} HCHO+hv=CO : phot(j_ch2om) ;
+{09:J09} ALD2+hv{+ 2 O2}=HCHO+XO2+CO+ 2 HO2 : 4.6E-4_dp*phot(j_no2) ;
+{10:J10} OPEN+hv=C2O3+CO+HO2 : 9.04_dp*phot(j_ch2or) ;
+{11:J11} MGLY+hv=C2O3+CO+HO2 : 9.64_dp*phot(j_ch2or) ;
+{12:01} O{+O2+M}=O3 : arr2(1.4E+3_dp, -1175.0_dp, temp) ;
+{13:02} O3+NO=NO2 : arr2(1.8E-12_dp, +1370.0_dp, temp) ;
+{14:03} O+NO2=NO : 9.3E-12_dp ;
+{15:04} O+NO2=NO3 : arr2(1.6E-13_dp, -687.0_dp, temp) ;
+{16:05} O+NO=NO2 : arr2(2.2E-13_dp, -602.0_dp, temp) ;
+{17:06} O3+NO2=NO3 : arr2(1.2E-13_dp, +2450.0_dp, temp) ;
+{18:07} O1D_CB4=O : arr2(1.9E+8_dp, -390.0_dp, temp) ;
+{19:08} O1D_CB4+H2O=2HO : 2.2E-10_dp ;
+{20:09} O3+HO=HO2 : arr2(1.6E-12_dp, +940.0_dp, temp) ;
+{21:10} O3+HO2=HO : arr2(1.4E-14_dp, +580.0_dp, temp) ;
+{22:11} NO3+NO=2 NO2 : arr2(1.3E-11_dp, -250.0_dp, temp) ;
+{23:12} NO3+NO2=NO+NO2 : arr2(2.5E-14_dp, +1230.0_dp, temp) ;
+{24:13} NO3+NO2=N2O5 : arr2(5.3E-13_dp, -256.0_dp, temp) ;
+{25:14} N2O5+H2O=2 HNO3 : 1.3E-21_dp ;
+{26:15} N2O5=NO3+NO2 : arr2(3.5E+14_dp, +10897.0_dp, temp) ;
+{27:16} 2 NO=2 NO2 : arr2(1.8E-20_dp, -530.0_dp, temp) ;
+{28:17} NO+NO2+H2O=2 HONO : 4.4E-40_dp ;
+{29:18} HO+NO=HONO : arr2(4.5E-13_dp, -806.0_dp, temp) ;
+{30:19} HO+HONO=NO2 : 6.6E-12_dp ;
+{31:20} 2 HONO=NO+NO2 : 1.0E-20_dp ;
+{32:21} HO+NO2=HNO3 : arr2(1.0E-12_dp, -713.0_dp, temp) ;
+{33:22} HO+HNO3=NO3 : arr2(5.1E-15_dp, -1000.0_dp, temp) ;
+{34:23} HO2+NO=HO+NO2 : arr2(3.7E-12_dp, -240.0_dp, temp) ;
+{35:24} HO2+NO2=PNA : arr2(1.2E-13_dp, -749.0_dp, temp) ;
+{36:25} PNA=HO2+NO2 : arr2(4.8E+13_dp, +10121.0_dp, temp) ;
+{37:26} HO+PNA=NO2 : arr2(1.3E-12_dp, -380.0_dp, temp) ;
+{38:27} 2 HO2=H2O2 : arr2(5.9E-14_dp, -1150.0_dp, temp) ;
+{39:28} 2 HO2+H2O=H2O2 : arr2(2.2E-38_dp, -5800.0_dp, temp) ;
+{40:29} HO+H2O2=HO2 : arr2(3.1E-12_dp, +187.0_dp, temp) ;
+{41:30} HO+CO=HO2 : 2.2E-13_dp ;
+{42:31} HCHO+HO=HO2+CO : 1.0E-11_dp ;
+{43:32} HCHO+O=HO+HO2+CO : arr2(3.0E-11_dp, +1550.0_dp, temp) ;
+{44:33} HCHO+NO3=HNO3+HO2+CO : 6.3E-16_dp ;
+{45:34} ALD2+O=C2O3+HO : arr2(1.2E-11_dp, +986.0_dp, temp) ;
+{46:35} ALD2+HO=C2O3 : arr2(7.0E-12_dp, -250.0_dp, temp) ;
+{47:36} ALD2+NO3=C2O3+HNO3 : 2.5E-15_dp ;
+{48:37} C2O3+NO=HCHO+XO2+HO2+NO2 : arr2(5.4E-12_dp, -250.0_dp, temp) ;
+{49:38} C2O3+NO2=PAN : arr2(8.0E-20_dp, -5500.0_dp, temp) ;
+{50:39} PAN=C2O3+NO2 : arr2(9.4E+16_dp, +14000.0_dp, temp) ;
+{51:40} 2 C2O3=2 HCHO+2 XO2+2 HO2 : 2.0E-12_dp ;
+{52:41} C2O3+HO2=0.79 HCHO+0.79 XO2
+ +0.79 HO2+0.79 HO : 6.5E-12_dp ;
+{53:42} HO=HCHO+XO2+HO2 : arr2(1.1E+2_dp, +1710.0_dp, temp) ;
+{54:43} PAR+HO=0.87 XO2+0.13 XO2N
+ +0.11 HO2+0.11 ALD2
+ +0.76 ROR-0.11 PAR : 8.1E-13_dp ;
+{55:44} ROR=1.1 ALD2+0.96 XO2
+ +0.94 HO2 +0.04 XO2N
+ +0.02 ROR-2.10 PAR : arr2(1.0E+15_dp, +8000.0_dp, temp) ;
+{56:45} ROR=HO2 : 1.6E+03_dp ;
+{57:46} ROR+NO2= PROD : 1.5E-11_dp ;
+{58:47} O+OLE=0.63 ALD2+0.38 HO2
+ +0.28 XO2+0.3 CO
+ +0.2 HCHO+0.02 XO2N
+ +0.22 PAR+0.2 HO : arr2(1.2E-11_dp, +324.0_dp, temp) ;
+{59:48} HO+OLE=HCHO+ALD2+XO2+HO2-PAR : arr2(5.2E-12_dp, -504.0_dp, temp) ;
+{60:49} O3+OLE=0.5 ALD2+0.74 HCHO
+ +0.33 CO+0.44 HO2
+ +0.22 XO2+0.1 HO-PAR : arr2(1.4E-14_dp, +2105.0_dp, temp) ;
+{61:50} NO3+OLE=0.91 XO2+HCHO
+ +ALD2+0.09 XO2N
+ +NO2-PAR : 7.7E-15_dp ;
+{62:51} O+ETH=HCHO+0.7 XO2
+ +CO+1.7 HO2+0.3 HO : arr2(1.0E-11_dp, +792.0_dp, temp) ;
+{63:52} HO+ETH=XO2+1.56 HCHO
+ +HO2+0.22 ALD2 : arr2(2.0E-12_dp, -411.0_dp, temp) ;
+{64:53} O3+ETH=HCHO+0.42 CO+0.12 HO2 : arr2(1.3E-14_dp, +2633.0_dp, temp) ;
+{65:54} HO+TOL=0.08 XO2+0.36 CRES
+ +0.44 HO2+0.56 TO2 : arr2(2.1E-12_dp, -322.0_dp, temp) ;
+{66:55} TO2+NO=0.9 NO2+0.9 OPEN+0.9 HO2 : 8.1E-12_dp ;
+{67:56} TO2=HO2+CRES : 4.20_dp ;
+{68:57} HO+CRES=0.4 CRO+0.6 XO2
+ +0.6 HO2+0.3 OPEN : 4.1E-11_dp ;
+{69:58} NO3+CRES=CRO+HNO3 : 2.2E-11_dp ;
+{70:59} CRO+NO2=PROD : 1.4E-11_dp ;
+{71:60} HO+XYL=0.7 HO2+0.5 XO2
+ +0.2 CRES+0.8 MGLY
+ +1.10 PAR+0.3 TO2 : arr2(1.7E-11_dp, -116.0_dp, temp) ;
+{72:61} HO+OPEN=XO2+C2O3+2 HO2+2 CO+HCHO : 3.0E-11_dp ;
+{73:62} O3+OPEN=0.03 ALD2+0.62 C2O3
+ +0.7 HCHO+0.03 XO2
+ +0.69 CO+0.08 HO
+ +0.76 HO2+0.2 MGLY : arr2(5.4E-17_dp, +500.0_dp, temp) ;
+{74:63} HO+MGLY=XO2+C2O3 : 1.70E-11_dp ;
+{75:64} O+ISOP=0.6 HO2+0.8 ALD2
+ +0.55 OLE+0.5 XO2
+ +0.5 CO+0.45 ETH
+ +0.9 PAR : 1.80E-11_dp ;
+{76:65} HO+ISOP=HCHO+XO2
+ +0.67 HO2+0.4 MGLY
+ +0.2 C2O3+ETH
+ +0.2 ALD2+0.13 XO2N : 9.6E-11_dp ;
+{77:66} O3+ISOP=HCHO+0.4 ALD2
+ +0.55 ETH+0.2 MGLY
+ +0.06 CO+0.1 PAR
+ +0.44 HO2+0.1 HO : 1.2E-17_dp ;
+{78:67} NO3+ISOP=XO2N : 3.2E-13_dp ;
+{79:68} XO2+NO=NO2 : 8.1E-12_dp ;
+{80:69} 2 XO2=PROD : arr2(1.7E-14_dp, -1300.0_dp, temp) ;
+{81:70} XO2N+NO=PROD : 6.8E-13_dp ;
Index: /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_cbm4/cbm4.spc
===================================================================
--- /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_cbm4/cbm4.spc (revision 3698)
+++ /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_cbm4/cbm4.spc (revision 3698)
@@ -0,0 +1,40 @@
+{cbm4.spc}
+
+#include atoms
+
+#DEFVAR
+ NO = N + O ; {nitric oxide}
+ NO2 = N + 2O ; {nitrogen dioxide}
+ NO3 = N + 3O ; {nitrogen trioxide}
+ N2O5 = 2N + 5O ; {dinitrogen pentoxide}
+ HONO = H + 2O + N ; {nitrous acid}
+ HNO3 = H + N + 3O ; { nitric acid }
+ PNA = H + 4 O + N ; {HO2NO2 peroxynitric acid}
+ O1D_CB4 = O ; {oxygen atomic first singlet state}
+ O = O ; {oxygen atomic ground state (3P)}
+ HO = O + H ; {hydroxyl radical}
+ O3 = 3O ; {ozone}
+ HO2 = H + 2O ; {perhydroxyl radical}
+ H2O2 = 2H + 2O ; {hydrogen peroxide}
+ HCHO = C + 2H + O ; {formalydehyde}
+ ALD2 = IGNORE ; {high molecular weight aldehides}
+ C2O3 = 2C + 3H + 3O ; {CH3CO(O)OO peroxyacyl radical}
+ PAN = 2C + 3H + 5O + N ; {CH3C(O)OONO2, peroxyacyl nitrate}
+ PAR = IGNORE ; {parafin carbon bond}
+ ROR = IGNORE ; {secondary organic oxy radical}
+ OLE = IGNORE ; {olefinic carbon bond}
+ ETH = 2C + 4H ; {CH2=CH2 ethene}
+ TOL = 7C + 8H ; {C6H5-CH3 toluene}
+ CRES = IGNORE ; {cresol and h.m.w. phenols}
+ TO2 = IGNORE ; {toluene-hydroxyl radical adduct}
+ CRO = IGNORE ; {methylphenoxy radical}
+ OPEN = IGNORE ; {h.m.w. aromatic oxidation ring fragment}
+ XYL = 8C + 10H ; {C6H4-(CH3)2 xylene}
+ MGLY = 3C + 4H + 2O ; {CH3C(O)C(O)H methylglyoxal}
+ ISOP = IGNORE ; {isoprene}
+ XO2 = IGNORE ; {NO-to-NO2 operation}
+ XO2N = IGNORE ; {NO-to-nitrate operation}
+ CO = C + O ; {carbon monoxide}
+#DEFFIX
+ H2O = H + 2O ; {water}
+
Index: /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_cbm4/chem_gasphase_mod.f90
===================================================================
--- /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_cbm4/chem_gasphase_mod.f90 (revision 3698)
+++ /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_cbm4/chem_gasphase_mod.f90 (revision 3698)
@@ -0,0 +1,4033 @@
+MODULE chem_gasphase_mod
+
+! Mechanism: cbm4
+!
+!------------------------------------------------------------------------------!
+!
+! ******Module chem_gasphase_mod is automatically generated by kpp4palm ******
+!
+! *********Please do NOT change this Code,it will be ovewritten *********
+!
+!------------------------------------------------------------------------------!
+! This file was created by KPP (http://people.cs.vt.edu/asandu/Software/Kpp/)
+! and kpp4palm (created by Klaus Ketelsen). kpp4palm is an adapted version
+! of KP4 (Jöckel,P.,Kerkweg,A.,Pozzer,A.,Sander,R.,Tost,H.,Riede,
+! H.,Baumgaertner,A.,Gromov,S.,and Kern,B.,2010: Development cycle 2 of
+! the Modular Earth Submodel System (MESSy2),Geosci. Model Dev.,3,717-752,
+! https://doi.org/10.5194/gmd-3-717-2010). KP4 is part of the Modular Earth
+! Submodel System (MESSy),which is is available under the GNU General Public
+! License (GPL).
+!
+! KPP is free software; you can redistribute it and/or modify it under the terms
+! of the General Public Licence as published by the Free Software Foundation;
+! 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 Licence for more details.
+!
+!------------------------------------------------------------------------------!
+! This file is part of the PALM model system.
+!
+! PALM is free software: you can redistribute it and/or modify it under the
+! terms of the GNU General Public License as published by the Free Software
+! Foundation,either version 3 of the License,or (at your option) any later
+! version.
+!
+! PALM 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
+! PALM. If not,see .
+!
+! Copyright 1997-2019 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+!
+! MODULE HEADER TEMPLATE
+!
+! Initial version (Nov. 2016,ketelsen),for later modifications of module_header
+! see comments in kpp4palm/src/create_kpp_module.C
+
+! Set kpp Double Precision to PALM Default Precision
+
+ USE kinds, ONLY: dp=>wp
+
+ USE pegrid, ONLY: myid, threads_per_task
+
+ IMPLICIT NONE
+ PRIVATE
+ !SAVE ! note: occurs again in automatically generated code ...
+
+! PUBLIC :: IERR_NAMES
+
+! PUBLIC :: SPC_NAMES,EQN_NAMES,EQN_TAGS,REQ_HET,REQ_AEROSOL,REQ_PHOTRAT &
+! ,REQ_MCFCT,IP_MAX,jname
+
+ PUBLIC :: eqn_names, phot_names, spc_names
+ PUBLIC :: nmaxfixsteps
+ PUBLIC :: atol, rtol
+ PUBLIC :: nspec, nreact
+ PUBLIC :: temp
+ PUBLIC :: qvap
+ PUBLIC :: fakt
+ PUBLIC :: phot
+ PUBLIC :: rconst
+ PUBLIC :: nvar
+ PUBLIC :: nphot
+ PUBLIC :: vl_dim ! PUBLIC to ebable other MODULEs to distiguish between scalar and vec
+
+ PUBLIC :: initialize, integrate, update_rconst
+ PUBLIC :: chem_gasphase_integrate
+ PUBLIC :: initialize_kpp_ctrl
+
+! END OF MODULE HEADER TEMPLATE
+
+! Variables used for vector mode
+
+ LOGICAL, PARAMETER :: l_vector = .FALSE.
+ INTEGER, PARAMETER :: i_lu_di = 2
+ INTEGER, PARAMETER :: vl_dim = 1
+ INTEGER :: vl
+
+ INTEGER :: vl_glo
+ INTEGER :: is, ie
+
+
+ INTEGER, DIMENSION(vl_dim) :: kacc, krej
+ INTEGER, DIMENSION(vl_dim) :: ierrv
+ LOGICAL :: data_loaded = .FALSE.
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Parameter Module File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Parameters.f90
+! Time : Wed Dec 12 11:47:05 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181212/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! NSPEC - Number of chemical species
+ INTEGER, PARAMETER :: nspec = 33
+! NVAR - Number of Variable species
+ INTEGER, PARAMETER :: nvar = 32
+! NVARACT - Number of Active species
+ INTEGER, PARAMETER :: nvaract = 32
+! NFIX - Number of Fixed species
+ INTEGER, PARAMETER :: nfix = 1
+! NREACT - Number of reactions
+ INTEGER, PARAMETER :: nreact = 81
+! NVARST - Starting of variables in conc. vect.
+ INTEGER, PARAMETER :: nvarst = 1
+! NFIXST - Starting of fixed in conc. vect.
+ INTEGER, PARAMETER :: nfixst = 33
+! NONZERO - Number of nonzero entries in Jacobian
+ INTEGER, PARAMETER :: nonzero = 276
+! LU_NONZERO - Number of nonzero entries in LU factoriz. of Jacobian
+ INTEGER, PARAMETER :: lu_nonzero = 300
+! CNVAR - (NVAR+1) Number of elements in compressed row format
+ INTEGER, PARAMETER :: cnvar = 33
+! CNEQN - (NREACT+1) Number stoicm elements in compressed col format
+ INTEGER, PARAMETER :: cneqn = 82
+! NHESS - Length of Sparse Hessian
+ INTEGER, PARAMETER :: nhess = 258
+! NMASS - Number of atoms to check mass balance
+ INTEGER, PARAMETER :: nmass = 1
+
+! Index declaration for variable species in C and VAR
+! VAR(ind_spc) = C(ind_spc)
+
+ INTEGER, PARAMETER, PUBLIC :: ind_o1d_cb4 = 1
+ INTEGER, PARAMETER, PUBLIC :: ind_h2o2 = 2
+ INTEGER, PARAMETER, PUBLIC :: ind_pan = 3
+ INTEGER, PARAMETER, PUBLIC :: ind_cro = 4
+ INTEGER, PARAMETER, PUBLIC :: ind_tol = 5
+ INTEGER, PARAMETER, PUBLIC :: ind_n2o5 = 6
+ INTEGER, PARAMETER, PUBLIC :: ind_xyl = 7
+ INTEGER, PARAMETER, PUBLIC :: ind_xo2n = 8
+ INTEGER, PARAMETER, PUBLIC :: ind_hono = 9
+ INTEGER, PARAMETER, PUBLIC :: ind_pna = 10
+ INTEGER, PARAMETER, PUBLIC :: ind_to2 = 11
+ INTEGER, PARAMETER, PUBLIC :: ind_hno3 = 12
+ INTEGER, PARAMETER, PUBLIC :: ind_ror = 13
+ INTEGER, PARAMETER, PUBLIC :: ind_cres = 14
+ INTEGER, PARAMETER, PUBLIC :: ind_mgly = 15
+ INTEGER, PARAMETER, PUBLIC :: ind_co = 16
+ INTEGER, PARAMETER, PUBLIC :: ind_eth = 17
+ INTEGER, PARAMETER, PUBLIC :: ind_xo2 = 18
+ INTEGER, PARAMETER, PUBLIC :: ind_open = 19
+ INTEGER, PARAMETER, PUBLIC :: ind_par = 20
+ INTEGER, PARAMETER, PUBLIC :: ind_hcho = 21
+ INTEGER, PARAMETER, PUBLIC :: ind_isop = 22
+ INTEGER, PARAMETER, PUBLIC :: ind_ole = 23
+ INTEGER, PARAMETER, PUBLIC :: ind_ald2 = 24
+ INTEGER, PARAMETER, PUBLIC :: ind_o3 = 25
+ INTEGER, PARAMETER, PUBLIC :: ind_no2 = 26
+ INTEGER, PARAMETER, PUBLIC :: ind_ho = 27
+ INTEGER, PARAMETER, PUBLIC :: ind_ho2 = 28
+ INTEGER, PARAMETER, PUBLIC :: ind_o = 29
+ INTEGER, PARAMETER, PUBLIC :: ind_no3 = 30
+ INTEGER, PARAMETER, PUBLIC :: ind_no = 31
+ INTEGER, PARAMETER, PUBLIC :: ind_c2o3 = 32
+
+! Index declaration for fixed species in C
+! C(ind_spc)
+
+ INTEGER, PARAMETER, PUBLIC :: ind_h2o = 33
+
+! Index declaration for fixed species in FIX
+! FIX(indf_spc) = C(ind_spc) = C(NVAR+indf_spc)
+
+ INTEGER, PARAMETER :: indf_h2o = 1
+
+! NJVRP - Length of sparse Jacobian JVRP
+ INTEGER, PARAMETER :: njvrp = 134
+
+! NSTOICM - Length of Sparse Stoichiometric Matrix
+ INTEGER, PARAMETER :: nstoicm = 329
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Global Data Module File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Global.f90
+! Time : Wed Dec 12 11:47:05 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181212/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! Declaration of global variables
+
+! C - Concentration of all species
+ REAL(kind=dp):: c(nspec)
+! VAR - Concentrations of variable species (global)
+ REAL(kind=dp):: var(nvar)
+! FIX - Concentrations of fixed species (global)
+ REAL(kind=dp):: fix(nfix)
+! VAR,FIX are chunks of array C
+ EQUIVALENCE( c(1), var(1))
+ EQUIVALENCE( c(33), fix(1))
+! RCONST - Rate constants (global)
+ REAL(kind=dp):: rconst(nreact)
+! TIME - Current integration time
+ REAL(kind=dp):: time
+! TEMP - Temperature
+ REAL(kind=dp):: temp
+! TSTART - Integration start time
+ REAL(kind=dp):: tstart
+! ATOL - Absolute tolerance
+ REAL(kind=dp):: atol(nvar)
+! RTOL - Relative tolerance
+ REAL(kind=dp):: rtol(nvar)
+! STEPMIN - Lower bound for integration step
+ REAL(kind=dp):: stepmin
+! CFACTOR - Conversion factor for concentration units
+ REAL(kind=dp):: cfactor
+
+! INLINED global variable declarations
+
+! QVAP - Water vapor
+ REAL(kind=dp):: qvap
+! FAKT - Conversion factor
+ REAL(kind=dp):: fakt
+
+
+! INLINED global variable declarations
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Sparse Jacobian Data Structures File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_JacobianSP.f90
+! Time : Wed Dec 12 11:47:05 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181212/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! Sparse Jacobian Data
+
+
+ INTEGER, PARAMETER, DIMENSION(300):: lu_irow = (/ &
+ 1, 1, 2, 2, 2, 3, 3, 3, 4, 4, 4, 4, &
+ 4, 5, 5, 6, 6, 6, 7, 7, 8, 8, 8, 8, &
+ 8, 8, 8, 8, 8, 9, 9, 9, 9, 10, 10, 10, &
+ 10, 11, 11, 11, 11, 11, 12, 12, 12, 12, 12, 12, &
+ 12, 12, 13, 13, 13, 13, 14, 14, 14, 14, 14, 14, &
+ 14, 15, 15, 15, 15, 15, 15, 16, 16, 16, 16, 16, &
+ 16, 16, 16, 16, 16, 16, 16, 17, 17, 17, 17, 17, &
+ 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, &
+ 18, 18, 18, 18, 18, 18, 18, 18, 19, 19, 19, 19, &
+ 19, 19, 19, 20, 20, 20, 20, 20, 20, 20, 20, 20, &
+ 20, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, &
+ 21, 21, 22, 22, 22, 22, 22, 23, 23, 23, 23, 23, &
+ 23, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, &
+ 24, 24, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, &
+ 25, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, &
+ 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 27, &
+ 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, &
+ 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, &
+ 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, &
+ 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, &
+ 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, &
+ 29, 29, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, &
+ 30, 30, 30, 30, 30, 31, 31, 31, 31, 31, 31, 31, &
+ 31, 31, 31, 31, 31, 31, 31, 31, 31, 31, 31, 32, &
+ 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32 /)
+
+ INTEGER, PARAMETER, DIMENSION(300):: lu_icol = (/ &
+ 1, 25, 2, 27, 28, 3, 26, 32, 4, 14, 26, 27, &
+ 30, 5, 27, 6, 26, 30, 7, 27, 8, 13, 20, 22, &
+ 23, 27, 29, 30, 31, 9, 26, 27, 31, 10, 26, 27, &
+ 28, 5, 7, 11, 27, 31, 6, 12, 14, 21, 24, 26, &
+ 27, 30, 13, 20, 26, 27, 5, 7, 11, 14, 27, 30, &
+ 31, 7, 15, 19, 22, 25, 27, 15, 16, 17, 19, 21, &
+ 22, 23, 24, 25, 27, 29, 30, 17, 22, 25, 27, 29, &
+ 5, 7, 13, 14, 15, 17, 18, 19, 20, 22, 23, 24, &
+ 25, 26, 27, 28, 29, 30, 31, 32, 11, 14, 19, 25, &
+ 27, 30, 31, 7, 13, 20, 22, 23, 25, 26, 27, 29, &
+ 30, 17, 19, 21, 22, 23, 24, 25, 27, 28, 29, 30, &
+ 31, 32, 22, 25, 27, 29, 30, 22, 23, 25, 27, 29, &
+ 30, 13, 17, 19, 20, 22, 23, 24, 25, 26, 27, 29, &
+ 30, 31, 17, 19, 22, 23, 25, 26, 27, 28, 29, 30, &
+ 31, 3, 4, 6, 9, 10, 11, 13, 14, 18, 19, 20, &
+ 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 1, &
+ 2, 5, 7, 9, 10, 12, 14, 15, 16, 17, 19, 20, &
+ 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, &
+ 2, 5, 7, 10, 11, 13, 14, 15, 16, 17, 19, 20, &
+ 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, &
+ 1, 17, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, &
+ 31, 32, 6, 12, 14, 21, 22, 23, 24, 25, 26, 27, &
+ 28, 29, 30, 31, 32, 8, 9, 11, 13, 18, 19, 20, &
+ 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 3, &
+ 15, 19, 22, 24, 25, 26, 27, 28, 29, 30, 31, 32 /)
+
+ INTEGER, PARAMETER, DIMENSION(33):: lu_crow = (/ &
+ 1, 3, 6, 9, 14, 16, 19, 21, 30, 34, 38, 43, &
+ 51, 55, 62, 68, 80, 85, 105, 112, 122, 135, 140, 146, &
+ 159, 170, 192, 217, 241, 255, 270, 288, 301 /)
+
+ INTEGER, PARAMETER, DIMENSION(33):: lu_diag = (/ &
+ 1, 3, 6, 9, 14, 16, 19, 21, 30, 34, 40, 44, &
+ 51, 58, 63, 69, 80, 91, 107, 114, 124, 135, 141, 152, &
+ 163, 185, 211, 236, 251, 267, 286, 300, 301 /)
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Utility Data Module File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Monitor.f90
+! Time : Wed Dec 12 11:47:05 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181212/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+ CHARACTER(len=15), PARAMETER, DIMENSION(33):: spc_names = (/ &
+ 'O1D_CB4 ','H2O2 ','PAN ',&
+ 'CRO ','TOL ','N2O5 ',&
+ 'XYL ','XO2N ','HONO ',&
+ 'PNA ','TO2 ','HNO3 ',&
+ 'ROR ','CRES ','MGLY ',&
+ 'CO ','ETH ','XO2 ',&
+ 'OPEN ','PAR ','HCHO ',&
+ 'ISOP ','OLE ','ALD2 ',&
+ 'O3 ','NO2 ','HO ',&
+ 'HO2 ','O ','NO3 ',&
+ 'NO ','C2O3 ','H2O ' /)
+
+ CHARACTER(len=100), PARAMETER, DIMENSION(30):: eqn_names_0 = (/ &
+ ' NO2 --> O + NO ',&
+ ' O3 --> O ',&
+ ' O3 --> O1D_CB4 ',&
+ ' NO3 --> 0.89 NO2 + 0.89 O + 0.11 NO ',&
+ ' HONO --> HO + NO ',&
+ ' H2O2 --> 2 HO ',&
+ ' HCHO --> CO + 2 HO2 ',&
+ ' HCHO --> CO ',&
+ ' ALD2 --> CO + XO2 + HCHO + 2 HO2 ',&
+ ' OPEN --> CO + HO2 + C2O3 ',&
+ ' MGLY --> CO + HO2 + C2O3 ',&
+ ' O --> O3 ',&
+ ' O3 + NO --> NO2 ',&
+ ' NO2 + O --> NO ',&
+ ' NO2 + O --> NO3 ',&
+ ' O + NO --> NO2 ',&
+ ' O3 + NO2 --> NO3 ',&
+ ' O1D_CB4 --> O ',&
+ ' O1D_CB4 + H2O --> 2 HO ',&
+ ' O3 + HO --> HO2 ',&
+ ' O3 + HO2 --> HO ',&
+ ' NO3 + NO --> 2 NO2 ',&
+ ' NO2 + NO3 --> NO2 + NO ',&
+ ' NO2 + NO3 --> N2O5 ',&
+ ' N2O5 + H2O --> 2 HNO3 ',&
+ ' N2O5 --> NO2 + NO3 ',&
+ ' 2 NO --> 2 NO2 ',&
+ 'NO2 + NO + H2O --> 2 HONO ',&
+ ' HO + NO --> HONO ',&
+ ' HONO + HO --> NO2 ' /)
+ CHARACTER(len=100), PARAMETER, DIMENSION(30):: eqn_names_1 = (/ &
+ ' 2 HONO --> NO2 + NO ',&
+ ' NO2 + HO --> HNO3 ',&
+ ' HNO3 + HO --> NO3 ',&
+ ' HO2 + NO --> NO2 + HO ',&
+ ' NO2 + HO2 --> PNA ',&
+ ' PNA --> NO2 + HO2 ',&
+ ' PNA + HO --> NO2 ',&
+ ' 2 HO2 --> H2O2 ',&
+ ' 2 HO2 + H2O --> H2O2 ',&
+ ' H2O2 + HO --> HO2 ',&
+ ' CO + HO --> HO2 ',&
+ ' HCHO + HO --> CO + HO2 ',&
+ ' HCHO + O --> CO + HO + HO2 ',&
+ ' HCHO + NO3 --> HNO3 + CO + HO2 ',&
+ ' ALD2 + O --> HO + C2O3 ',&
+ ' ALD2 + HO --> C2O3 ',&
+ ' ALD2 + NO3 --> HNO3 + C2O3 ',&
+ ' NO + C2O3 --> XO2 + HCHO + NO2 + HO2 ',&
+ ' NO2 + C2O3 --> PAN ',&
+ ' PAN --> NO2 + C2O3 ',&
+ ' 2 C2O3 --> 2 XO2 + 2 HCHO + 2 HO2 ',&
+ ' HO2 + C2O3 --> 0.79 XO2 + 0.79 HCHO + 0.79 HO + 0.79 HO2 ',&
+ ' HO --> XO2 + HCHO + HO2 ',&
+ ' PAR + HO --> 0.13 XO2N + 0.76 ROR + 0.87 XO2 - -0.11 PAR + 0.11 ALD2 ... etc. ',&
+ ' ROR --> 0.04 XO2N + 0.02 ROR + 0.96 XO2 - -2.1 PAR + 1.1 ALD2 ... etc. ',&
+ ' ROR --> HO2 ',&
+ ' ROR + NO2 --> ',&
+ ' OLE + O --> 0.02 XO2N + 0.3 CO + 0.28 XO2 + 0.22 PAR + 0.2 HCHO ... etc. ',&
+ ' OLE + HO --> XO2 - PAR + HCHO + ALD2 + HO2 ',&
+ ' OLE + O3 --> 0.33 CO + 0.22 XO2 - PAR + 0.74 HCHO + 0.5 ALD2 + 0.1 HO ... etc. ' /)
+ CHARACTER(len=100), PARAMETER, DIMENSION(21):: eqn_names_2 = (/ &
+ ' OLE + NO3 --> 0.09 XO2N + 0.91 XO2 - PAR + HCHO + ALD2 + NO2 ',&
+ ' ETH + O --> CO + 0.7 XO2 + HCHO + 0.3 HO + 1.7 HO2 ',&
+ ' ETH + HO --> XO2 + 1.56 HCHO + 0.22 ALD2 + HO2 ',&
+ ' ETH + O3 --> 0.42 CO + HCHO + 0.12 HO2 ',&
+ ' TOL + HO --> 0.56 TO2 + 0.36 CRES + 0.08 XO2 + 0.44 HO2 ',&
+ ' TO2 + NO --> 0.9 OPEN + 0.9 NO2 + 0.9 HO2 ',&
+ ' TO2 --> CRES + HO2 ',&
+ ' CRES + HO --> 0.4 CRO + 0.6 XO2 + 0.3 OPEN + 0.6 HO2 ',&
+ ' CRES + NO3 --> CRO + HNO3 ',&
+ ' CRO + NO2 --> ',&
+ ' XYL + HO --> 0.3 TO2 + 0.2 CRES + 0.8 MGLY + 0.5 XO2 + 1.1 PAR + 0.7 HO2 ... etc. ',&
+ ' OPEN + HO --> 2 CO + XO2 + HCHO + 2 HO2 + C2O3 ',&
+ ' OPEN + O3 --> 0.2 MGLY + 0.69 CO + 0.03 XO2 + 0.7 HCHO + 0.03 ALD2 ... etc. ',&
+ ' MGLY + HO --> XO2 + C2O3 ',&
+ ' ISOP + O --> 0.5 CO + 0.45 ETH + 0.5 XO2 + 0.9 PAR + 0.55 OLE + 0.8 ALD2 ... etc. ',&
+ ' ISOP + HO --> 0.13 XO2N + 0.4 MGLY + ETH + XO2 + HCHO + 0.2 ALD2 + 0.67 HO2 ... etc. ',&
+ ' ISOP + O3 --> 0.2 MGLY + 0.06 CO + 0.55 ETH + 0.1 PAR + HCHO + 0.4 ALD2 ... etc. ',&
+ ' ISOP + NO3 --> XO2N ',&
+ ' XO2 + NO --> NO2 ',&
+ ' 2 XO2 --> ',&
+ ' XO2N + NO --> ' /)
+ CHARACTER(len=100), PARAMETER, DIMENSION(81):: eqn_names = (/&
+ eqn_names_0, eqn_names_1, eqn_names_2 /)
+
+! INLINED global variables
+
+ ! inline f90_data: declaration of global variables for photolysis
+ ! REAL(kind=dp):: phot(nphot)must eventually be moved to global later for
+ INTEGER, PARAMETER :: nphot = 9
+ ! phot photolysis frequencies
+ REAL(kind=dp):: phot(nphot)
+
+ INTEGER, PARAMETER, PUBLIC :: j_no2 = 1
+ INTEGER, PARAMETER, PUBLIC :: j_o33p = 2
+ INTEGER, PARAMETER, PUBLIC :: j_o31d = 3
+ INTEGER, PARAMETER, PUBLIC :: j_no3o = 4
+ INTEGER, PARAMETER, PUBLIC :: j_no3o2 = 5
+ INTEGER, PARAMETER, PUBLIC :: j_hono = 6
+ INTEGER, PARAMETER, PUBLIC :: j_h2o2 = 7
+ INTEGER, PARAMETER, PUBLIC :: j_ch2or = 8
+ INTEGER, PARAMETER, PUBLIC :: j_ch2om = 9
+
+ CHARACTER(len=15), PARAMETER, DIMENSION(nphot):: phot_names = (/ &
+ 'J_NO2 ','J_O33P ','J_O31D ', &
+ 'J_NO3O ','J_NO3O2 ','J_HONO ', &
+ 'J_H2O2 ','J_HCHO_B ','J_HCHO_A '/)
+
+! End INLINED global variables
+
+
+! Automatic generated PUBLIC Statements for ip_ and ihs_ variables
+
+! Automatic generated PUBLIC Statements for ip_ and ihs_ variables
+
+! Automatic generated PUBLIC Statements for ip_ and ihs_ variables
+
+! Automatic generated PUBLIC Statements for ip_ and ihs_ variables
+
+
+! variable definations from individual module headers
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Initialization File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Initialize.f90
+! Time : Wed Dec 12 11:47:05 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181212/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Numerical Integrator (Time-Stepping) File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Integrator.f90
+! Time : Wed Dec 12 11:47:05 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181212/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! INTEGRATE - Integrator routine
+! Arguments :
+! TIN - Start Time for Integration
+! TOUT - End Time for Integration
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!
+! 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 !
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!
+
+
+ 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
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Linear Algebra Data and Routines File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_LinearAlgebra.f90
+! Time : Wed Dec 12 11:47:05 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181212/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! The ODE Jacobian of Chemical Model File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Jacobian.f90
+! Time : Wed Dec 12 11:47:05 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181212/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! The ODE Function of Chemical Model File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Function.f90
+! Time : Wed Dec 12 11:47:05 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181212/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+! A - Rate for each equation
+ REAL(kind=dp):: a(nreact)
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! The Reaction Rates File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Rates.f90
+! Time : Wed Dec 12 11:47:05 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181212/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Auxiliary Routines File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Util.f90
+! Time : Wed Dec 12 11:47:05 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181212/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+ ! header MODULE initialize_kpp_ctrl_template
+
+ ! notes:
+ ! - l_vector is automatically defined by kp4
+ ! - vl_dim is automatically defined by kp4
+ ! - i_lu_di is automatically defined by kp4
+ ! - wanted is automatically defined by xmecca
+ ! - icntrl rcntrl are automatically defined by kpp
+ ! - "USE messy_main_tools" is in MODULE_header of messy_mecca_kpp.f90
+ ! - SAVE will be automatically added by kp4
+
+ !SAVE
+
+ ! for fixed time step control
+ ! ... max. number of fixed time steps (sum must be 1)
+ INTEGER, PARAMETER :: nmaxfixsteps = 50
+ ! ... switch for fixed time stepping
+ LOGICAL, PUBLIC :: l_fixed_step = .FALSE.
+ INTEGER, PUBLIC :: nfsteps = 1
+ ! ... number of kpp control PARAMETERs
+ INTEGER, PARAMETER, PUBLIC :: nkppctrl = 20
+ !
+ INTEGER, DIMENSION(nkppctrl), PUBLIC :: icntrl = 0
+ REAL(dp), DIMENSION(nkppctrl), PUBLIC :: rcntrl = 0.0_dp
+ REAL(dp), DIMENSION(nmaxfixsteps), PUBLIC :: t_steps = 0.0_dp
+
+ ! END header MODULE initialize_kpp_ctrl_template
+
+
+! Interface Block
+
+ INTERFACE initialize
+ MODULE PROCEDURE initialize
+ END INTERFACE initialize
+
+ INTERFACE integrate
+ MODULE PROCEDURE integrate
+ END INTERFACE integrate
+
+ INTERFACE fun
+ MODULE PROCEDURE fun
+ END INTERFACE fun
+
+ INTERFACE kppsolve
+ MODULE PROCEDURE kppsolve
+ END INTERFACE kppsolve
+
+ INTERFACE jac_sp
+ MODULE PROCEDURE jac_sp
+ END INTERFACE jac_sp
+
+ INTERFACE k_arr
+ MODULE PROCEDURE k_arr
+ END INTERFACE k_arr
+
+ INTERFACE update_rconst
+ MODULE PROCEDURE update_rconst
+ END INTERFACE update_rconst
+
+ INTERFACE arr2
+ MODULE PROCEDURE arr2
+ END INTERFACE arr2
+
+ INTERFACE initialize_kpp_ctrl
+ MODULE PROCEDURE initialize_kpp_ctrl
+ END INTERFACE initialize_kpp_ctrl
+
+ INTERFACE error_output
+ MODULE PROCEDURE error_output
+ END INTERFACE error_output
+
+ INTERFACE wscal
+ MODULE PROCEDURE wscal
+ END INTERFACE wscal
+
+!INTERFACE not working INTERFACE waxpy
+!INTERFACE not working MODULE PROCEDURE waxpy
+!INTERFACE not working END INTERFACE waxpy
+
+ INTERFACE rosenbrock
+ MODULE PROCEDURE rosenbrock
+ END INTERFACE rosenbrock
+
+ INTERFACE funtemplate
+ MODULE PROCEDURE funtemplate
+ END INTERFACE funtemplate
+
+ INTERFACE jactemplate
+ MODULE PROCEDURE jactemplate
+ END INTERFACE jactemplate
+
+ INTERFACE kppdecomp
+ MODULE PROCEDURE kppdecomp
+ END INTERFACE kppdecomp
+
+ INTERFACE chem_gasphase_integrate
+ MODULE PROCEDURE chem_gasphase_integrate
+ END INTERFACE chem_gasphase_integrate
+
+
+ CONTAINS
+
+SUBROUTINE initialize()
+
+
+ INTEGER :: j, k
+
+ INTEGER :: i
+ REAL(kind=dp):: x
+ k = is
+ cfactor = 1.000000e+00_dp
+
+ x = (0.) * cfactor
+ DO i = 1 , nvar
+ ENDDO
+
+ x = (0.) * cfactor
+ DO i = 1 , nfix
+ fix(i) = x
+ ENDDO
+
+! constant rate coefficients
+! END constant rate coefficients
+
+! INLINED initializations
+
+ fix(indf_h2o) = qvap
+
+! End INLINED initializations
+
+
+END SUBROUTINE initialize
+
+SUBROUTINE integrate( tin, tout, &
+ icntrl_u, rcntrl_u, istatus_u, rstatus_u, ierr_u)
+
+
+ REAL(kind=dp), INTENT(IN):: tin ! start time
+ REAL(kind=dp), INTENT(IN):: tout ! END time
+ ! OPTIONAL input PARAMETERs and statistics
+ INTEGER, INTENT(IN), OPTIONAL :: icntrl_u(20)
+ REAL(kind=dp), INTENT(IN), OPTIONAL :: rcntrl_u(20)
+ INTEGER, INTENT(OUT), OPTIONAL :: istatus_u(20)
+ REAL(kind=dp), INTENT(OUT), OPTIONAL :: rstatus_u(20)
+ INTEGER, INTENT(OUT), OPTIONAL :: ierr_u
+
+ REAL(kind=dp):: 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(:)
+ ENDIF
+ IF (PRESENT(rcntrl_u))THEN
+ WHERE(rcntrl_u(:)> 0)rcntrl(:) = rcntrl_u(:)
+ ENDIF
+
+
+ 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 fun(v, f, rct, vdot)
+
+! V - Concentrations of variable species (local)
+ REAL(kind=dp):: v(nvar)
+! F - Concentrations of fixed species (local)
+ REAL(kind=dp):: f(nfix)
+! RCT - Rate constants (local)
+ REAL(kind=dp):: rct(nreact)
+! Vdot - Time derivative of variable species concentrations
+ REAL(kind=dp):: vdot(nvar)
+
+
+! Computation of equation rates
+ a(1) = rct(1) * v(26)
+ a(2) = rct(2) * v(25)
+ a(3) = rct(3) * v(25)
+ a(4) = rct(4) * v(30)
+ a(5) = rct(5) * v(9)
+ a(6) = rct(6) * v(2)
+ a(7) = rct(7) * v(21)
+ a(8) = rct(8) * v(21)
+ a(9) = rct(9) * v(24)
+ a(10) = rct(10) * v(19)
+ a(11) = rct(11) * v(15)
+ a(12) = rct(12) * v(29)
+ a(13) = rct(13) * v(25) * v(31)
+ a(14) = rct(14) * v(26) * v(29)
+ a(15) = rct(15) * v(26) * v(29)
+ a(16) = rct(16) * v(29) * v(31)
+ a(17) = rct(17) * v(25) * v(26)
+ a(18) = rct(18) * v(1)
+ a(19) = rct(19) * v(1) * f(1)
+ a(20) = rct(20) * v(25) * v(27)
+ a(21) = rct(21) * v(25) * v(28)
+ a(22) = rct(22) * v(30) * v(31)
+ a(23) = rct(23) * v(26) * v(30)
+ a(24) = rct(24) * v(26) * v(30)
+ a(25) = rct(25) * v(6) * f(1)
+ a(26) = rct(26) * v(6)
+ a(27) = rct(27) * v(31) * v(31)
+ a(28) = rct(28) * v(26) * v(31) * f(1)
+ a(29) = rct(29) * v(27) * v(31)
+ a(30) = rct(30) * v(9) * v(27)
+ a(31) = rct(31) * v(9) * v(9)
+ a(32) = rct(32) * v(26) * v(27)
+ a(33) = rct(33) * v(12) * v(27)
+ a(34) = rct(34) * v(28) * v(31)
+ a(35) = rct(35) * v(26) * v(28)
+ a(36) = rct(36) * v(10)
+ a(37) = rct(37) * v(10) * v(27)
+ a(38) = rct(38) * v(28) * v(28)
+ a(39) = rct(39) * v(28) * v(28) * f(1)
+ a(40) = rct(40) * v(2) * v(27)
+ a(41) = rct(41) * v(16) * v(27)
+ a(42) = rct(42) * v(21) * v(27)
+ a(43) = rct(43) * v(21) * v(29)
+ a(44) = rct(44) * v(21) * v(30)
+ a(45) = rct(45) * v(24) * v(29)
+ a(46) = rct(46) * v(24) * v(27)
+ a(47) = rct(47) * v(24) * v(30)
+ a(48) = rct(48) * v(31) * v(32)
+ a(49) = rct(49) * v(26) * v(32)
+ a(50) = rct(50) * v(3)
+ a(51) = rct(51) * v(32) * v(32)
+ a(52) = rct(52) * v(28) * v(32)
+ a(53) = rct(53) * v(27)
+ a(54) = rct(54) * v(20) * v(27)
+ a(55) = rct(55) * v(13)
+ a(56) = rct(56) * v(13)
+ a(57) = rct(57) * v(13) * v(26)
+ a(58) = rct(58) * v(23) * v(29)
+ a(59) = rct(59) * v(23) * v(27)
+ a(60) = rct(60) * v(23) * v(25)
+ a(61) = rct(61) * v(23) * v(30)
+ a(62) = rct(62) * v(17) * v(29)
+ a(63) = rct(63) * v(17) * v(27)
+ a(64) = rct(64) * v(17) * v(25)
+ a(65) = rct(65) * v(5) * v(27)
+ a(66) = rct(66) * v(11) * v(31)
+ a(67) = rct(67) * v(11)
+ a(68) = rct(68) * v(14) * v(27)
+ a(69) = rct(69) * v(14) * v(30)
+ a(70) = rct(70) * v(4) * v(26)
+ a(71) = rct(71) * v(7) * v(27)
+ a(72) = rct(72) * v(19) * v(27)
+ a(73) = rct(73) * v(19) * v(25)
+ a(74) = rct(74) * v(15) * v(27)
+ a(75) = rct(75) * v(22) * v(29)
+ a(76) = rct(76) * v(22) * v(27)
+ a(77) = rct(77) * v(22) * v(25)
+ a(78) = rct(78) * v(22) * v(30)
+ a(79) = rct(79) * v(18) * v(31)
+ a(80) = rct(80) * v(18) * v(18)
+ a(81) = rct(81) * v(8) * v(31)
+
+! Aggregate function
+ vdot(1) = a(3) - a(18) - a(19)
+ vdot(2) = - a(6) + a(38) + a(39) - a(40)
+ vdot(3) = a(49) - a(50)
+ vdot(4) = 0.4* a(68) + a(69) - a(70)
+ vdot(5) = - a(65)
+ vdot(6) = a(24) - a(25) - a(26)
+ vdot(7) = - a(71)
+ vdot(8) = 0.13* a(54) + 0.04* a(55) + 0.02* a(58) + 0.09* a(61) + 0.13* a(76) + a(78) - a(81)
+ vdot(9) = - a(5) + 2* a(28) + a(29) - a(30) - 2* a(31)
+ vdot(10) = a(35) - a(36) - a(37)
+ vdot(11) = 0.56* a(65) - a(66) - a(67) + 0.3* a(71)
+ vdot(12) = 2* a(25) + a(32) - a(33) + a(44) + a(47) + a(69)
+ vdot(13) = 0.76* a(54) - 0.98* a(55) - a(56) - a(57)
+ vdot(14) = 0.36* a(65) + a(67) - a(68) - a(69) + 0.2* a(71)
+ vdot(15) = - a(11) + 0.8* a(71) + 0.2* a(73) - a(74) + 0.4* a(76) + 0.2* a(77)
+ vdot(16) = a(7) + a(8) + a(9) + a(10) + a(11) - a(41) + a(42) + a(43) + a(44) + 0.3* a(58) + 0.33* a(60) + a(62) + 0.42* a(64) &
+ + 2* a(72) + 0.69* a(73)&
+ &+ 0.5* a(75) + 0.06* a(77)
+ vdot(17) = - a(62) - a(63) - a(64) + 0.45* a(75) + a(76) + 0.55* a(77)
+ vdot(18) = a(9) + a(48) + 2* a(51) + 0.79* a(52) + a(53) + 0.87* a(54) + 0.96* a(55) + 0.28* a(58) + a(59) + 0.22* a(60) + &
+ 0.91* a(61) + 0.7* a(62)&
+ &+ a(63) + 0.08* a(65) + 0.6* a(68) + 0.5* a(71) + a(72) + 0.03* a(73) + a(74) + 0.5* a(75) + a(76) - a(79) - 2* &
+ a(80)
+ vdot(19) = - a(10) + 0.9* a(66) + 0.3* a(68) - a(72) - a(73)
+ vdot(20) = - 1.11* a(54) - 2.1* a(55) + 0.22* a(58) - a(59) - a(60) - a(61) + 1.1* a(71) + 0.9* a(75) + 0.1* a(77)
+ vdot(21) = - a(7) - a(8) + a(9) - a(42) - a(43) - a(44) + a(48) + 2* a(51) + 0.79* a(52) + a(53) + 0.2* a(58) + a(59) + 0.74* &
+ a(60) + a(61) + a(62)&
+ &+ 1.56* a(63) + a(64) + a(72) + 0.7* a(73) + a(76) + a(77)
+ vdot(22) = - a(75) - a(76) - a(77) - a(78)
+ vdot(23) = - a(58) - a(59) - a(60) - a(61) + 0.55* a(75)
+ vdot(24) = - a(9) - a(45) - a(46) - a(47) + 0.11* a(54) + 1.1* a(55) + 0.63* a(58) + a(59) + 0.5* a(60) + a(61) + 0.22* a(63) + &
+ 0.03* a(73) + 0.8&
+ &* a(75) + 0.2* a(76) + 0.4* a(77)
+ vdot(25) = - a(2) - a(3) + a(12) - a(13) - a(17) - a(20) - a(21) - a(60) - a(64) - a(73) - a(77)
+ vdot(26) = - a(1) + 0.89* a(4) + a(13) - a(14) - a(15) + a(16) - a(17) + 2* a(22) - a(24) + a(26) + 2* a(27) - a(28) + a(30) + &
+ a(31) - a(32) + a(34)&
+ &- a(35) + a(36) + a(37) + a(48) - a(49) + a(50) - a(57) + a(61) + 0.9* a(66) - a(70) + a(79)
+ vdot(27) = a(5) + 2* a(6) + 2* a(19) - a(20) + a(21) - a(29) - a(30) - a(32) - a(33) + a(34) - a(37) - a(40) - a(41) - a(42) + &
+ a(43) + a(45) - a(46)&
+ &+ 0.79* a(52) - a(53) - a(54) + 0.2* a(58) - a(59) + 0.1* a(60) + 0.3* a(62) - a(63) - a(65) - a(68) - a(71) - &
+ a(72) + 0.08* a(73) - a(74)&
+ &- a(76) + 0.1* a(77)
+ vdot(28) = 2* a(7) + 2* a(9) + a(10) + a(11) + a(20) - a(21) - a(34) - a(35) + a(36) - 2* a(38) - 2* a(39) + a(40) + a(41) + &
+ a(42) + a(43) + a(44) + a(48)&
+ &+ 2* a(51) - 0.21* a(52) + a(53) + 0.11* a(54) + 0.94* a(55) + a(56) + 0.38* a(58) + a(59) + 0.44* a(60) + 1.7* &
+ a(62) + a(63) + 0.12* a(64)&
+ &+ 0.44* a(65) + 0.9* a(66) + a(67) + 0.6* a(68) + 0.7* a(71) + 2* a(72) + 0.76* a(73) + 0.6* a(75) + 0.67* a(76) &
+ + 0.44* a(77)
+ vdot(29) = a(1) + a(2) + 0.89* a(4) - a(12) - a(14) - a(15) - a(16) + a(18) - a(43) - a(45) - a(58) - a(62) - a(75)
+ vdot(30) = - a(4) + a(15) + a(17) - a(22) - a(23) - a(24) + a(26) + a(33) - a(44) - a(47) - a(61) - a(69) - a(78)
+ vdot(31) = a(1) + 0.11* a(4) + a(5) - a(13) + a(14) - a(16) - a(22) + a(23) - 2* a(27) - a(28) - a(29) + a(31) - a(34) - a(48) &
+ - a(66) - a(79) - a(81)
+ vdot(32) = a(10) + a(11) + a(45) + a(46) + a(47) - a(48) - a(49) + a(50) - 2* a(51) - a(52) + a(72) + 0.62* a(73) + a(74) + &
+ 0.2* a(76)
+
+END SUBROUTINE fun
+
+SUBROUTINE kppsolve(jvs, x)
+
+! JVS - sparse Jacobian of variables
+ REAL(kind=dp):: jvs(lu_nonzero)
+! X - Vector for variables
+ REAL(kind=dp):: x(nvar)
+
+ x(11) = x(11) - jvs(38) * x(5) - jvs(39) * x(7)
+ x(12) = x(12) - jvs(43) * x(6)
+ x(14) = x(14) - jvs(55) * x(5) - jvs(56) * x(7) - jvs(57) * x(11)
+ x(15) = x(15) - jvs(62) * x(7)
+ x(16) = x(16) - jvs(68) * x(15)
+ x(18) = x(18) - jvs(85) * x(5) - jvs(86) * x(7) - jvs(87) * x(13) - jvs(88) * x(14) - jvs(89) * x(15) - jvs(90) * x(17)
+ x(19) = x(19) - jvs(105) * x(11) - jvs(106) * x(14)
+ x(20) = x(20) - jvs(112) * x(7) - jvs(113) * x(13)
+ x(21) = x(21) - jvs(122) * x(17) - jvs(123) * x(19)
+ x(23) = x(23) - jvs(140) * x(22)
+ x(24) = x(24) - jvs(146) * x(13) - jvs(147) * x(17) - jvs(148) * x(19) - jvs(149) * x(20) - jvs(150) * x(22) - jvs(151) * x(23)
+ x(25) = x(25) - jvs(159) * x(17) - jvs(160) * x(19) - jvs(161) * x(22) - jvs(162) * x(23)
+ x(26) = x(26) - jvs(170) * x(3) - jvs(171) * x(4) - jvs(172) * x(6) - jvs(173) * x(9) - jvs(174) * x(10) - jvs(175) * x(11) - &
+ jvs(176) * x(13)&
+ &- jvs(177) * x(14) - jvs(178) * x(18) - jvs(179) * x(19) - jvs(180) * x(20) - jvs(181) * x(22) - jvs(182) * x(23) - &
+ jvs(183) * x(24)&
+ &- jvs(184) * x(25)
+ x(27) = x(27) - jvs(192) * x(1) - jvs(193) * x(2) - jvs(194) * x(5) - jvs(195) * x(7) - jvs(196) * x(9) - jvs(197) * x(10) - &
+ jvs(198) * x(12)&
+ &- jvs(199) * x(14) - jvs(200) * x(15) - jvs(201) * x(16) - jvs(202) * x(17) - jvs(203) * x(19) - jvs(204) * x(20) - &
+ jvs(205) * x(21)&
+ &- jvs(206) * x(22) - jvs(207) * x(23) - jvs(208) * x(24) - jvs(209) * x(25) - jvs(210) * x(26)
+ x(28) = x(28) - jvs(217) * x(2) - jvs(218) * x(5) - jvs(219) * x(7) - jvs(220) * x(10) - jvs(221) * x(11) - jvs(222) * x(13) - &
+ jvs(223) * x(14)&
+ &- jvs(224) * x(15) - jvs(225) * x(16) - jvs(226) * x(17) - jvs(227) * x(19) - jvs(228) * x(20) - jvs(229) * x(21) - &
+ jvs(230) * x(22)&
+ &- jvs(231) * x(23) - jvs(232) * x(24) - jvs(233) * x(25) - jvs(234) * x(26) - jvs(235) * x(27)
+ x(29) = x(29) - jvs(241) * x(1) - jvs(242) * x(17) - jvs(243) * x(21) - jvs(244) * x(22) - jvs(245) * x(23) - jvs(246) * x(24) &
+ - jvs(247) * x(25)&
+ &- jvs(248) * x(26) - jvs(249) * x(27) - jvs(250) * x(28)
+ x(30) = x(30) - jvs(255) * x(6) - jvs(256) * x(12) - jvs(257) * x(14) - jvs(258) * x(21) - jvs(259) * x(22) - jvs(260) * x(23) &
+ - jvs(261) * x(24)&
+ &- jvs(262) * x(25) - jvs(263) * x(26) - jvs(264) * x(27) - jvs(265) * x(28) - jvs(266) * x(29)
+ x(31) = x(31) - jvs(270) * x(8) - jvs(271) * x(9) - jvs(272) * x(11) - jvs(273) * x(13) - jvs(274) * x(18) - jvs(275) * x(19) - &
+ jvs(276) * x(20)&
+ &- jvs(277) * x(22) - jvs(278) * x(23) - jvs(279) * x(24) - jvs(280) * x(25) - jvs(281) * x(26) - jvs(282) * x(27) - &
+ jvs(283) * x(28)&
+ &- jvs(284) * x(29) - jvs(285) * x(30)
+ x(32) = x(32) - jvs(288) * x(3) - jvs(289) * x(15) - jvs(290) * x(19) - jvs(291) * x(22) - jvs(292) * x(24) - jvs(293) * x(25) &
+ - jvs(294) * x(26)&
+ &- jvs(295) * x(27) - jvs(296) * x(28) - jvs(297) * x(29) - jvs(298) * x(30) - jvs(299) * x(31)
+ x(32) = x(32) / jvs(300)
+ x(31) = (x(31) - jvs(287) * x(32)) /(jvs(286))
+ x(30) = (x(30) - jvs(268) * x(31) - jvs(269) * x(32)) /(jvs(267))
+ x(29) = (x(29) - jvs(252) * x(30) - jvs(253) * x(31) - jvs(254) * x(32)) /(jvs(251))
+ x(28) = (x(28) - jvs(237) * x(29) - jvs(238) * x(30) - jvs(239) * x(31) - jvs(240) * x(32)) /(jvs(236))
+ x(27) = (x(27) - jvs(212) * x(28) - jvs(213) * x(29) - jvs(214) * x(30) - jvs(215) * x(31) - jvs(216) * x(32)) /(jvs(211))
+ x(26) = (x(26) - jvs(186) * x(27) - jvs(187) * x(28) - jvs(188) * x(29) - jvs(189) * x(30) - jvs(190) * x(31) - jvs(191) * &
+ x(32)) /(jvs(185))
+ x(25) = (x(25) - jvs(164) * x(26) - jvs(165) * x(27) - jvs(166) * x(28) - jvs(167) * x(29) - jvs(168) * x(30) - jvs(169) * &
+ x(31)) /(jvs(163))
+ x(24) = (x(24) - jvs(153) * x(25) - jvs(154) * x(26) - jvs(155) * x(27) - jvs(156) * x(29) - jvs(157) * x(30) - jvs(158) * &
+ x(31)) /(jvs(152))
+ x(23) = (x(23) - jvs(142) * x(25) - jvs(143) * x(27) - jvs(144) * x(29) - jvs(145) * x(30)) /(jvs(141))
+ x(22) = (x(22) - jvs(136) * x(25) - jvs(137) * x(27) - jvs(138) * x(29) - jvs(139) * x(30)) /(jvs(135))
+ x(21) = (x(21) - jvs(125) * x(22) - jvs(126) * x(23) - jvs(127) * x(24) - jvs(128) * x(25) - jvs(129) * x(27) - jvs(130) * &
+ x(28) - jvs(131)&
+ &* x(29) - jvs(132) * x(30) - jvs(133) * x(31) - jvs(134) * x(32)) /(jvs(124))
+ x(20) = (x(20) - jvs(115) * x(22) - jvs(116) * x(23) - jvs(117) * x(25) - jvs(118) * x(26) - jvs(119) * x(27) - jvs(120) * &
+ x(29) - jvs(121)&
+ &* x(30)) /(jvs(114))
+ x(19) = (x(19) - jvs(108) * x(25) - jvs(109) * x(27) - jvs(110) * x(30) - jvs(111) * x(31)) /(jvs(107))
+ x(18) = (x(18) - jvs(92) * x(19) - jvs(93) * x(20) - jvs(94) * x(22) - jvs(95) * x(23) - jvs(96) * x(24) - jvs(97) * x(25) - &
+ jvs(98) * x(26)&
+ &- jvs(99) * x(27) - jvs(100) * x(28) - jvs(101) * x(29) - jvs(102) * x(30) - jvs(103) * x(31) - jvs(104) * x(32)) &
+ /(jvs(91))
+ x(17) = (x(17) - jvs(81) * x(22) - jvs(82) * x(25) - jvs(83) * x(27) - jvs(84) * x(29)) /(jvs(80))
+ x(16) = (x(16) - jvs(70) * x(17) - jvs(71) * x(19) - jvs(72) * x(21) - jvs(73) * x(22) - jvs(74) * x(23) - jvs(75) * x(24) - &
+ jvs(76) * x(25)&
+ &- jvs(77) * x(27) - jvs(78) * x(29) - jvs(79) * x(30)) /(jvs(69))
+ x(15) = (x(15) - jvs(64) * x(19) - jvs(65) * x(22) - jvs(66) * x(25) - jvs(67) * x(27)) /(jvs(63))
+ x(14) = (x(14) - jvs(59) * x(27) - jvs(60) * x(30) - jvs(61) * x(31)) /(jvs(58))
+ x(13) = (x(13) - jvs(52) * x(20) - jvs(53) * x(26) - jvs(54) * x(27)) /(jvs(51))
+ x(12) = (x(12) - jvs(45) * x(14) - jvs(46) * x(21) - jvs(47) * x(24) - jvs(48) * x(26) - jvs(49) * x(27) - jvs(50) * x(30)) &
+ /(jvs(44))
+ x(11) = (x(11) - jvs(41) * x(27) - jvs(42) * x(31)) /(jvs(40))
+ x(10) = (x(10) - jvs(35) * x(26) - jvs(36) * x(27) - jvs(37) * x(28)) /(jvs(34))
+ x(9) = (x(9) - jvs(31) * x(26) - jvs(32) * x(27) - jvs(33) * x(31)) /(jvs(30))
+ x(8) = (x(8) - jvs(22) * x(13) - jvs(23) * x(20) - jvs(24) * x(22) - jvs(25) * x(23) - jvs(26) * x(27) - jvs(27) * x(29) - &
+ jvs(28) * x(30) - jvs(29)&
+ &* x(31)) /(jvs(21))
+ x(7) = (x(7) - jvs(20) * x(27)) /(jvs(19))
+ x(6) = (x(6) - jvs(17) * x(26) - jvs(18) * x(30)) /(jvs(16))
+ x(5) = (x(5) - jvs(15) * x(27)) /(jvs(14))
+ x(4) = (x(4) - jvs(10) * x(14) - jvs(11) * x(26) - jvs(12) * x(27) - jvs(13) * x(30)) /(jvs(9))
+ x(3) = (x(3) - jvs(7) * x(26) - jvs(8) * x(32)) /(jvs(6))
+ x(2) = (x(2) - jvs(4) * x(27) - jvs(5) * x(28)) /(jvs(3))
+ x(1) = (x(1) - jvs(2) * x(25)) /(jvs(1))
+
+END SUBROUTINE kppsolve
+
+SUBROUTINE jac_sp(v, f, rct, jvs)
+
+! V - Concentrations of variable species (local)
+ REAL(kind=dp):: v(nvar)
+! F - Concentrations of fixed species (local)
+ REAL(kind=dp):: f(nfix)
+! RCT - Rate constants (local)
+ REAL(kind=dp):: rct(nreact)
+! JVS - sparse Jacobian of variables
+ REAL(kind=dp):: jvs(lu_nonzero)
+
+
+! Local variables
+! B - Temporary array
+ REAL(kind=dp):: b(138)
+
+! B(1) = dA(1)/dV(26)
+ b(1) = rct(1)
+! B(2) = dA(2)/dV(25)
+ b(2) = rct(2)
+! B(3) = dA(3)/dV(25)
+ b(3) = rct(3)
+! B(4) = dA(4)/dV(30)
+ b(4) = rct(4)
+! B(5) = dA(5)/dV(9)
+ b(5) = rct(5)
+! B(6) = dA(6)/dV(2)
+ b(6) = rct(6)
+! B(7) = dA(7)/dV(21)
+ b(7) = rct(7)
+! B(8) = dA(8)/dV(21)
+ b(8) = rct(8)
+! B(9) = dA(9)/dV(24)
+ b(9) = rct(9)
+! B(10) = dA(10)/dV(19)
+ b(10) = rct(10)
+! B(11) = dA(11)/dV(15)
+ b(11) = rct(11)
+! B(12) = dA(12)/dV(29)
+ b(12) = rct(12)
+! B(13) = dA(13)/dV(25)
+ b(13) = rct(13) * v(31)
+! B(14) = dA(13)/dV(31)
+ b(14) = rct(13) * v(25)
+! B(15) = dA(14)/dV(26)
+ b(15) = rct(14) * v(29)
+! B(16) = dA(14)/dV(29)
+ b(16) = rct(14) * v(26)
+! B(17) = dA(15)/dV(26)
+ b(17) = rct(15) * v(29)
+! B(18) = dA(15)/dV(29)
+ b(18) = rct(15) * v(26)
+! B(19) = dA(16)/dV(29)
+ b(19) = rct(16) * v(31)
+! B(20) = dA(16)/dV(31)
+ b(20) = rct(16) * v(29)
+! B(21) = dA(17)/dV(25)
+ b(21) = rct(17) * v(26)
+! B(22) = dA(17)/dV(26)
+ b(22) = rct(17) * v(25)
+! B(23) = dA(18)/dV(1)
+ b(23) = rct(18)
+! B(24) = dA(19)/dV(1)
+ b(24) = rct(19) * f(1)
+! B(26) = dA(20)/dV(25)
+ b(26) = rct(20) * v(27)
+! B(27) = dA(20)/dV(27)
+ b(27) = rct(20) * v(25)
+! B(28) = dA(21)/dV(25)
+ b(28) = rct(21) * v(28)
+! B(29) = dA(21)/dV(28)
+ b(29) = rct(21) * v(25)
+! B(30) = dA(22)/dV(30)
+ b(30) = rct(22) * v(31)
+! B(31) = dA(22)/dV(31)
+ b(31) = rct(22) * v(30)
+! B(32) = dA(23)/dV(26)
+ b(32) = rct(23) * v(30)
+! B(33) = dA(23)/dV(30)
+ b(33) = rct(23) * v(26)
+! B(34) = dA(24)/dV(26)
+ b(34) = rct(24) * v(30)
+! B(35) = dA(24)/dV(30)
+ b(35) = rct(24) * v(26)
+! B(36) = dA(25)/dV(6)
+ b(36) = rct(25) * f(1)
+! B(38) = dA(26)/dV(6)
+ b(38) = rct(26)
+! B(39) = dA(27)/dV(31)
+ b(39) = rct(27) * 2* v(31)
+! B(40) = dA(28)/dV(26)
+ b(40) = rct(28) * v(31) * f(1)
+! B(41) = dA(28)/dV(31)
+ b(41) = rct(28) * v(26) * f(1)
+! B(43) = dA(29)/dV(27)
+ b(43) = rct(29) * v(31)
+! B(44) = dA(29)/dV(31)
+ b(44) = rct(29) * v(27)
+! B(45) = dA(30)/dV(9)
+ b(45) = rct(30) * v(27)
+! B(46) = dA(30)/dV(27)
+ b(46) = rct(30) * v(9)
+! B(47) = dA(31)/dV(9)
+ b(47) = rct(31) * 2* v(9)
+! B(48) = dA(32)/dV(26)
+ b(48) = rct(32) * v(27)
+! B(49) = dA(32)/dV(27)
+ b(49) = rct(32) * v(26)
+! B(50) = dA(33)/dV(12)
+ b(50) = rct(33) * v(27)
+! B(51) = dA(33)/dV(27)
+ b(51) = rct(33) * v(12)
+! B(52) = dA(34)/dV(28)
+ b(52) = rct(34) * v(31)
+! B(53) = dA(34)/dV(31)
+ b(53) = rct(34) * v(28)
+! B(54) = dA(35)/dV(26)
+ b(54) = rct(35) * v(28)
+! B(55) = dA(35)/dV(28)
+ b(55) = rct(35) * v(26)
+! B(56) = dA(36)/dV(10)
+ b(56) = rct(36)
+! B(57) = dA(37)/dV(10)
+ b(57) = rct(37) * v(27)
+! B(58) = dA(37)/dV(27)
+ b(58) = rct(37) * v(10)
+! B(59) = dA(38)/dV(28)
+ b(59) = rct(38) * 2* v(28)
+! B(60) = dA(39)/dV(28)
+ b(60) = rct(39) * 2* v(28) * f(1)
+! B(62) = dA(40)/dV(2)
+ b(62) = rct(40) * v(27)
+! B(63) = dA(40)/dV(27)
+ b(63) = rct(40) * v(2)
+! B(64) = dA(41)/dV(16)
+ b(64) = rct(41) * v(27)
+! B(65) = dA(41)/dV(27)
+ b(65) = rct(41) * v(16)
+! B(66) = dA(42)/dV(21)
+ b(66) = rct(42) * v(27)
+! B(67) = dA(42)/dV(27)
+ b(67) = rct(42) * v(21)
+! B(68) = dA(43)/dV(21)
+ b(68) = rct(43) * v(29)
+! B(69) = dA(43)/dV(29)
+ b(69) = rct(43) * v(21)
+! B(70) = dA(44)/dV(21)
+ b(70) = rct(44) * v(30)
+! B(71) = dA(44)/dV(30)
+ b(71) = rct(44) * v(21)
+! B(72) = dA(45)/dV(24)
+ b(72) = rct(45) * v(29)
+! B(73) = dA(45)/dV(29)
+ b(73) = rct(45) * v(24)
+! B(74) = dA(46)/dV(24)
+ b(74) = rct(46) * v(27)
+! B(75) = dA(46)/dV(27)
+ b(75) = rct(46) * v(24)
+! B(76) = dA(47)/dV(24)
+ b(76) = rct(47) * v(30)
+! B(77) = dA(47)/dV(30)
+ b(77) = rct(47) * v(24)
+! B(78) = dA(48)/dV(31)
+ b(78) = rct(48) * v(32)
+! B(79) = dA(48)/dV(32)
+ b(79) = rct(48) * v(31)
+! B(80) = dA(49)/dV(26)
+ b(80) = rct(49) * v(32)
+! B(81) = dA(49)/dV(32)
+ b(81) = rct(49) * v(26)
+! B(82) = dA(50)/dV(3)
+ b(82) = rct(50)
+! B(83) = dA(51)/dV(32)
+ b(83) = rct(51) * 2* v(32)
+! B(84) = dA(52)/dV(28)
+ b(84) = rct(52) * v(32)
+! B(85) = dA(52)/dV(32)
+ b(85) = rct(52) * v(28)
+! B(86) = dA(53)/dV(27)
+ b(86) = rct(53)
+! B(87) = dA(54)/dV(20)
+ b(87) = rct(54) * v(27)
+! B(88) = dA(54)/dV(27)
+ b(88) = rct(54) * v(20)
+! B(89) = dA(55)/dV(13)
+ b(89) = rct(55)
+! B(90) = dA(56)/dV(13)
+ b(90) = rct(56)
+! B(91) = dA(57)/dV(13)
+ b(91) = rct(57) * v(26)
+! B(92) = dA(57)/dV(26)
+ b(92) = rct(57) * v(13)
+! B(93) = dA(58)/dV(23)
+ b(93) = rct(58) * v(29)
+! B(94) = dA(58)/dV(29)
+ b(94) = rct(58) * v(23)
+! B(95) = dA(59)/dV(23)
+ b(95) = rct(59) * v(27)
+! B(96) = dA(59)/dV(27)
+ b(96) = rct(59) * v(23)
+! B(97) = dA(60)/dV(23)
+ b(97) = rct(60) * v(25)
+! B(98) = dA(60)/dV(25)
+ b(98) = rct(60) * v(23)
+! B(99) = dA(61)/dV(23)
+ b(99) = rct(61) * v(30)
+! B(100) = dA(61)/dV(30)
+ b(100) = rct(61) * v(23)
+! B(101) = dA(62)/dV(17)
+ b(101) = rct(62) * v(29)
+! B(102) = dA(62)/dV(29)
+ b(102) = rct(62) * v(17)
+! B(103) = dA(63)/dV(17)
+ b(103) = rct(63) * v(27)
+! B(104) = dA(63)/dV(27)
+ b(104) = rct(63) * v(17)
+! B(105) = dA(64)/dV(17)
+ b(105) = rct(64) * v(25)
+! B(106) = dA(64)/dV(25)
+ b(106) = rct(64) * v(17)
+! B(107) = dA(65)/dV(5)
+ b(107) = rct(65) * v(27)
+! B(108) = dA(65)/dV(27)
+ b(108) = rct(65) * v(5)
+! B(109) = dA(66)/dV(11)
+ b(109) = rct(66) * v(31)
+! B(110) = dA(66)/dV(31)
+ b(110) = rct(66) * v(11)
+! B(111) = dA(67)/dV(11)
+ b(111) = rct(67)
+! B(112) = dA(68)/dV(14)
+ b(112) = rct(68) * v(27)
+! B(113) = dA(68)/dV(27)
+ b(113) = rct(68) * v(14)
+! B(114) = dA(69)/dV(14)
+ b(114) = rct(69) * v(30)
+! B(115) = dA(69)/dV(30)
+ b(115) = rct(69) * v(14)
+! B(116) = dA(70)/dV(4)
+ b(116) = rct(70) * v(26)
+! B(117) = dA(70)/dV(26)
+ b(117) = rct(70) * v(4)
+! B(118) = dA(71)/dV(7)
+ b(118) = rct(71) * v(27)
+! B(119) = dA(71)/dV(27)
+ b(119) = rct(71) * v(7)
+! B(120) = dA(72)/dV(19)
+ b(120) = rct(72) * v(27)
+! B(121) = dA(72)/dV(27)
+ b(121) = rct(72) * v(19)
+! B(122) = dA(73)/dV(19)
+ b(122) = rct(73) * v(25)
+! B(123) = dA(73)/dV(25)
+ b(123) = rct(73) * v(19)
+! B(124) = dA(74)/dV(15)
+ b(124) = rct(74) * v(27)
+! B(125) = dA(74)/dV(27)
+ b(125) = rct(74) * v(15)
+! B(126) = dA(75)/dV(22)
+ b(126) = rct(75) * v(29)
+! B(127) = dA(75)/dV(29)
+ b(127) = rct(75) * v(22)
+! B(128) = dA(76)/dV(22)
+ b(128) = rct(76) * v(27)
+! B(129) = dA(76)/dV(27)
+ b(129) = rct(76) * v(22)
+! B(130) = dA(77)/dV(22)
+ b(130) = rct(77) * v(25)
+! B(131) = dA(77)/dV(25)
+ b(131) = rct(77) * v(22)
+! B(132) = dA(78)/dV(22)
+ b(132) = rct(78) * v(30)
+! B(133) = dA(78)/dV(30)
+ b(133) = rct(78) * v(22)
+! B(134) = dA(79)/dV(18)
+ b(134) = rct(79) * v(31)
+! B(135) = dA(79)/dV(31)
+ b(135) = rct(79) * v(18)
+! B(136) = dA(80)/dV(18)
+ b(136) = rct(80) * 2* v(18)
+! B(137) = dA(81)/dV(8)
+ b(137) = rct(81) * v(31)
+! B(138) = dA(81)/dV(31)
+ b(138) = rct(81) * v(8)
+
+! Construct the Jacobian terms from B's
+! JVS(1) = Jac_FULL(1,1)
+ jvs(1) = - b(23) - b(24)
+! JVS(2) = Jac_FULL(1,25)
+ jvs(2) = b(3)
+! JVS(3) = Jac_FULL(2,2)
+ jvs(3) = - b(6) - b(62)
+! JVS(4) = Jac_FULL(2,27)
+ jvs(4) = - b(63)
+! JVS(5) = Jac_FULL(2,28)
+ jvs(5) = b(59) + b(60)
+! JVS(6) = Jac_FULL(3,3)
+ jvs(6) = - b(82)
+! JVS(7) = Jac_FULL(3,26)
+ jvs(7) = b(80)
+! JVS(8) = Jac_FULL(3,32)
+ jvs(8) = b(81)
+! JVS(9) = Jac_FULL(4,4)
+ jvs(9) = - b(116)
+! JVS(10) = Jac_FULL(4,14)
+ jvs(10) = 0.4* b(112) + b(114)
+! JVS(11) = Jac_FULL(4,26)
+ jvs(11) = - b(117)
+! JVS(12) = Jac_FULL(4,27)
+ jvs(12) = 0.4* b(113)
+! JVS(13) = Jac_FULL(4,30)
+ jvs(13) = b(115)
+! JVS(14) = Jac_FULL(5,5)
+ jvs(14) = - b(107)
+! JVS(15) = Jac_FULL(5,27)
+ jvs(15) = - b(108)
+! JVS(16) = Jac_FULL(6,6)
+ jvs(16) = - b(36) - b(38)
+! JVS(17) = Jac_FULL(6,26)
+ jvs(17) = b(34)
+! JVS(18) = Jac_FULL(6,30)
+ jvs(18) = b(35)
+! JVS(19) = Jac_FULL(7,7)
+ jvs(19) = - b(118)
+! JVS(20) = Jac_FULL(7,27)
+ jvs(20) = - b(119)
+! JVS(21) = Jac_FULL(8,8)
+ jvs(21) = - b(137)
+! JVS(22) = Jac_FULL(8,13)
+ jvs(22) = 0.04* b(89)
+! JVS(23) = Jac_FULL(8,20)
+ jvs(23) = 0.13* b(87)
+! JVS(24) = Jac_FULL(8,22)
+ jvs(24) = 0.13* b(128) + b(132)
+! JVS(25) = Jac_FULL(8,23)
+ jvs(25) = 0.02* b(93) + 0.09* b(99)
+! JVS(26) = Jac_FULL(8,27)
+ jvs(26) = 0.13* b(88) + 0.13* b(129)
+! JVS(27) = Jac_FULL(8,29)
+ jvs(27) = 0.02* b(94)
+! JVS(28) = Jac_FULL(8,30)
+ jvs(28) = 0.09* b(100) + b(133)
+! JVS(29) = Jac_FULL(8,31)
+ jvs(29) = - b(138)
+! JVS(30) = Jac_FULL(9,9)
+ jvs(30) = - b(5) - b(45) - 2* b(47)
+! JVS(31) = Jac_FULL(9,26)
+ jvs(31) = 2* b(40)
+! JVS(32) = Jac_FULL(9,27)
+ jvs(32) = b(43) - b(46)
+! JVS(33) = Jac_FULL(9,31)
+ jvs(33) = 2* b(41) + b(44)
+! JVS(34) = Jac_FULL(10,10)
+ jvs(34) = - b(56) - b(57)
+! JVS(35) = Jac_FULL(10,26)
+ jvs(35) = b(54)
+! JVS(36) = Jac_FULL(10,27)
+ jvs(36) = - b(58)
+! JVS(37) = Jac_FULL(10,28)
+ jvs(37) = b(55)
+! JVS(38) = Jac_FULL(11,5)
+ jvs(38) = 0.56* b(107)
+! JVS(39) = Jac_FULL(11,7)
+ jvs(39) = 0.3* b(118)
+! JVS(40) = Jac_FULL(11,11)
+ jvs(40) = - b(109) - b(111)
+! JVS(41) = Jac_FULL(11,27)
+ jvs(41) = 0.56* b(108) + 0.3* b(119)
+! JVS(42) = Jac_FULL(11,31)
+ jvs(42) = - b(110)
+! JVS(43) = Jac_FULL(12,6)
+ jvs(43) = 2* b(36)
+! JVS(44) = Jac_FULL(12,12)
+ jvs(44) = - b(50)
+! JVS(45) = Jac_FULL(12,14)
+ jvs(45) = b(114)
+! JVS(46) = Jac_FULL(12,21)
+ jvs(46) = b(70)
+! JVS(47) = Jac_FULL(12,24)
+ jvs(47) = b(76)
+! JVS(48) = Jac_FULL(12,26)
+ jvs(48) = b(48)
+! JVS(49) = Jac_FULL(12,27)
+ jvs(49) = b(49) - b(51)
+! JVS(50) = Jac_FULL(12,30)
+ jvs(50) = b(71) + b(77) + b(115)
+! JVS(51) = Jac_FULL(13,13)
+ jvs(51) = - 0.98* b(89) - b(90) - b(91)
+! JVS(52) = Jac_FULL(13,20)
+ jvs(52) = 0.76* b(87)
+! JVS(53) = Jac_FULL(13,26)
+ jvs(53) = - b(92)
+! JVS(54) = Jac_FULL(13,27)
+ jvs(54) = 0.76* b(88)
+! JVS(55) = Jac_FULL(14,5)
+ jvs(55) = 0.36* b(107)
+! JVS(56) = Jac_FULL(14,7)
+ jvs(56) = 0.2* b(118)
+! JVS(57) = Jac_FULL(14,11)
+ jvs(57) = b(111)
+! JVS(58) = Jac_FULL(14,14)
+ jvs(58) = - b(112) - b(114)
+! JVS(59) = Jac_FULL(14,27)
+ jvs(59) = 0.36* b(108) - b(113) + 0.2* b(119)
+! JVS(60) = Jac_FULL(14,30)
+ jvs(60) = - b(115)
+! JVS(61) = Jac_FULL(14,31)
+ jvs(61) = 0
+! JVS(62) = Jac_FULL(15,7)
+ jvs(62) = 0.8* b(118)
+! JVS(63) = Jac_FULL(15,15)
+ jvs(63) = - b(11) - b(124)
+! JVS(64) = Jac_FULL(15,19)
+ jvs(64) = 0.2* b(122)
+! JVS(65) = Jac_FULL(15,22)
+ jvs(65) = 0.4* b(128) + 0.2* b(130)
+! JVS(66) = Jac_FULL(15,25)
+ jvs(66) = 0.2* b(123) + 0.2* b(131)
+! JVS(67) = Jac_FULL(15,27)
+ jvs(67) = 0.8* b(119) - b(125) + 0.4* b(129)
+! JVS(68) = Jac_FULL(16,15)
+ jvs(68) = b(11)
+! JVS(69) = Jac_FULL(16,16)
+ jvs(69) = - b(64)
+! JVS(70) = Jac_FULL(16,17)
+ jvs(70) = b(101) + 0.42* b(105)
+! JVS(71) = Jac_FULL(16,19)
+ jvs(71) = b(10) + 2* b(120) + 0.69* b(122)
+! JVS(72) = Jac_FULL(16,21)
+ jvs(72) = b(7) + b(8) + b(66) + b(68) + b(70)
+! JVS(73) = Jac_FULL(16,22)
+ jvs(73) = 0.5* b(126) + 0.06* b(130)
+! JVS(74) = Jac_FULL(16,23)
+ jvs(74) = 0.3* b(93) + 0.33* b(97)
+! JVS(75) = Jac_FULL(16,24)
+ jvs(75) = b(9)
+! JVS(76) = Jac_FULL(16,25)
+ jvs(76) = 0.33* b(98) + 0.42* b(106) + 0.69* b(123) + 0.06* b(131)
+! JVS(77) = Jac_FULL(16,27)
+ jvs(77) = - b(65) + b(67) + 2* b(121)
+! JVS(78) = Jac_FULL(16,29)
+ jvs(78) = b(69) + 0.3* b(94) + b(102) + 0.5* b(127)
+! JVS(79) = Jac_FULL(16,30)
+ jvs(79) = b(71)
+! JVS(80) = Jac_FULL(17,17)
+ jvs(80) = - b(101) - b(103) - b(105)
+! JVS(81) = Jac_FULL(17,22)
+ jvs(81) = 0.45* b(126) + b(128) + 0.55* b(130)
+! JVS(82) = Jac_FULL(17,25)
+ jvs(82) = - b(106) + 0.55* b(131)
+! JVS(83) = Jac_FULL(17,27)
+ jvs(83) = - b(104) + b(129)
+! JVS(84) = Jac_FULL(17,29)
+ jvs(84) = - b(102) + 0.45* b(127)
+! JVS(85) = Jac_FULL(18,5)
+ jvs(85) = 0.08* b(107)
+! JVS(86) = Jac_FULL(18,7)
+ jvs(86) = 0.5* b(118)
+! JVS(87) = Jac_FULL(18,13)
+ jvs(87) = 0.96* b(89)
+! JVS(88) = Jac_FULL(18,14)
+ jvs(88) = 0.6* b(112)
+! JVS(89) = Jac_FULL(18,15)
+ jvs(89) = b(124)
+! JVS(90) = Jac_FULL(18,17)
+ jvs(90) = 0.7* b(101) + b(103)
+! JVS(91) = Jac_FULL(18,18)
+ jvs(91) = - b(134) - 2* b(136)
+! JVS(92) = Jac_FULL(18,19)
+ jvs(92) = b(120) + 0.03* b(122)
+! JVS(93) = Jac_FULL(18,20)
+ jvs(93) = 0.87* b(87)
+! JVS(94) = Jac_FULL(18,22)
+ jvs(94) = 0.5* b(126) + b(128)
+! JVS(95) = Jac_FULL(18,23)
+ jvs(95) = 0.28* b(93) + b(95) + 0.22* b(97) + 0.91* b(99)
+! JVS(96) = Jac_FULL(18,24)
+ jvs(96) = b(9)
+! JVS(97) = Jac_FULL(18,25)
+ jvs(97) = 0.22* b(98) + 0.03* b(123)
+! JVS(98) = Jac_FULL(18,26)
+ jvs(98) = 0
+! JVS(99) = Jac_FULL(18,27)
+ jvs(99) = b(86) + 0.87* b(88) + b(96) + b(104) + 0.08* b(108) + 0.6* b(113) + 0.5* b(119) + b(121) + b(125) + b(129)
+! JVS(100) = Jac_FULL(18,28)
+ jvs(100) = 0.79* b(84)
+! JVS(101) = Jac_FULL(18,29)
+ jvs(101) = 0.28* b(94) + 0.7* b(102) + 0.5* b(127)
+! JVS(102) = Jac_FULL(18,30)
+ jvs(102) = 0.91* b(100)
+! JVS(103) = Jac_FULL(18,31)
+ jvs(103) = b(78) - b(135)
+! JVS(104) = Jac_FULL(18,32)
+ jvs(104) = b(79) + 2* b(83) + 0.79* b(85)
+! JVS(105) = Jac_FULL(19,11)
+ jvs(105) = 0.9* b(109)
+! JVS(106) = Jac_FULL(19,14)
+ jvs(106) = 0.3* b(112)
+! JVS(107) = Jac_FULL(19,19)
+ jvs(107) = - b(10) - b(120) - b(122)
+! JVS(108) = Jac_FULL(19,25)
+ jvs(108) = - b(123)
+! JVS(109) = Jac_FULL(19,27)
+ jvs(109) = 0.3* b(113) - b(121)
+! JVS(110) = Jac_FULL(19,30)
+ jvs(110) = 0
+! JVS(111) = Jac_FULL(19,31)
+ jvs(111) = 0.9* b(110)
+! JVS(112) = Jac_FULL(20,7)
+ jvs(112) = 1.1* b(118)
+! JVS(113) = Jac_FULL(20,13)
+ jvs(113) = - 2.1* b(89)
+! JVS(114) = Jac_FULL(20,20)
+ jvs(114) = - 1.11* b(87)
+! JVS(115) = Jac_FULL(20,22)
+ jvs(115) = 0.9* b(126) + 0.1* b(130)
+! JVS(116) = Jac_FULL(20,23)
+ jvs(116) = 0.22* b(93) - b(95) - b(97) - b(99)
+! JVS(117) = Jac_FULL(20,25)
+ jvs(117) = - b(98) + 0.1* b(131)
+! JVS(118) = Jac_FULL(20,26)
+ jvs(118) = 0
+! JVS(119) = Jac_FULL(20,27)
+ jvs(119) = - 1.11* b(88) - b(96) + 1.1* b(119)
+! JVS(120) = Jac_FULL(20,29)
+ jvs(120) = 0.22* b(94) + 0.9* b(127)
+! JVS(121) = Jac_FULL(20,30)
+ jvs(121) = - b(100)
+! JVS(122) = Jac_FULL(21,17)
+ jvs(122) = b(101) + 1.56* b(103) + b(105)
+! JVS(123) = Jac_FULL(21,19)
+ jvs(123) = b(120) + 0.7* b(122)
+! JVS(124) = Jac_FULL(21,21)
+ jvs(124) = - b(7) - b(8) - b(66) - b(68) - b(70)
+! JVS(125) = Jac_FULL(21,22)
+ jvs(125) = b(128) + b(130)
+! JVS(126) = Jac_FULL(21,23)
+ jvs(126) = 0.2* b(93) + b(95) + 0.74* b(97) + b(99)
+! JVS(127) = Jac_FULL(21,24)
+ jvs(127) = b(9)
+! JVS(128) = Jac_FULL(21,25)
+ jvs(128) = 0.74* b(98) + b(106) + 0.7* b(123) + b(131)
+! JVS(129) = Jac_FULL(21,27)
+ jvs(129) = - b(67) + b(86) + b(96) + 1.56* b(104) + b(121) + b(129)
+! JVS(130) = Jac_FULL(21,28)
+ jvs(130) = 0.79* b(84)
+! JVS(131) = Jac_FULL(21,29)
+ jvs(131) = - b(69) + 0.2* b(94) + b(102)
+! JVS(132) = Jac_FULL(21,30)
+ jvs(132) = - b(71) + b(100)
+! JVS(133) = Jac_FULL(21,31)
+ jvs(133) = b(78)
+! JVS(134) = Jac_FULL(21,32)
+ jvs(134) = b(79) + 2* b(83) + 0.79* b(85)
+! JVS(135) = Jac_FULL(22,22)
+ jvs(135) = - b(126) - b(128) - b(130) - b(132)
+! JVS(136) = Jac_FULL(22,25)
+ jvs(136) = - b(131)
+! JVS(137) = Jac_FULL(22,27)
+ jvs(137) = - b(129)
+! JVS(138) = Jac_FULL(22,29)
+ jvs(138) = - b(127)
+! JVS(139) = Jac_FULL(22,30)
+ jvs(139) = - b(133)
+! JVS(140) = Jac_FULL(23,22)
+ jvs(140) = 0.55* b(126)
+! JVS(141) = Jac_FULL(23,23)
+ jvs(141) = - b(93) - b(95) - b(97) - b(99)
+! JVS(142) = Jac_FULL(23,25)
+ jvs(142) = - b(98)
+! JVS(143) = Jac_FULL(23,27)
+ jvs(143) = - b(96)
+! JVS(144) = Jac_FULL(23,29)
+ jvs(144) = - b(94) + 0.55* b(127)
+! JVS(145) = Jac_FULL(23,30)
+ jvs(145) = - b(100)
+! JVS(146) = Jac_FULL(24,13)
+ jvs(146) = 1.1* b(89)
+! JVS(147) = Jac_FULL(24,17)
+ jvs(147) = 0.22* b(103)
+! JVS(148) = Jac_FULL(24,19)
+ jvs(148) = 0.03* b(122)
+! JVS(149) = Jac_FULL(24,20)
+ jvs(149) = 0.11* b(87)
+! JVS(150) = Jac_FULL(24,22)
+ jvs(150) = 0.8* b(126) + 0.2* b(128) + 0.4* b(130)
+! JVS(151) = Jac_FULL(24,23)
+ jvs(151) = 0.63* b(93) + b(95) + 0.5* b(97) + b(99)
+! JVS(152) = Jac_FULL(24,24)
+ jvs(152) = - b(9) - b(72) - b(74) - b(76)
+! JVS(153) = Jac_FULL(24,25)
+ jvs(153) = 0.5* b(98) + 0.03* b(123) + 0.4* b(131)
+! JVS(154) = Jac_FULL(24,26)
+ jvs(154) = 0
+! JVS(155) = Jac_FULL(24,27)
+ jvs(155) = - b(75) + 0.11* b(88) + b(96) + 0.22* b(104) + 0.2* b(129)
+! JVS(156) = Jac_FULL(24,29)
+ jvs(156) = - b(73) + 0.63* b(94) + 0.8* b(127)
+! JVS(157) = Jac_FULL(24,30)
+ jvs(157) = - b(77) + b(100)
+! JVS(158) = Jac_FULL(24,31)
+ jvs(158) = 0
+! JVS(159) = Jac_FULL(25,17)
+ jvs(159) = - b(105)
+! JVS(160) = Jac_FULL(25,19)
+ jvs(160) = - b(122)
+! JVS(161) = Jac_FULL(25,22)
+ jvs(161) = - b(130)
+! JVS(162) = Jac_FULL(25,23)
+ jvs(162) = - b(97)
+! JVS(163) = Jac_FULL(25,25)
+ jvs(163) = - b(2) - b(3) - b(13) - b(21) - b(26) - b(28) - b(98) - b(106) - b(123) - b(131)
+! JVS(164) = Jac_FULL(25,26)
+ jvs(164) = - b(22)
+! JVS(165) = Jac_FULL(25,27)
+ jvs(165) = - b(27)
+! JVS(166) = Jac_FULL(25,28)
+ jvs(166) = - b(29)
+! JVS(167) = Jac_FULL(25,29)
+ jvs(167) = b(12)
+! JVS(168) = Jac_FULL(25,30)
+ jvs(168) = 0
+! JVS(169) = Jac_FULL(25,31)
+ jvs(169) = - b(14)
+! JVS(170) = Jac_FULL(26,3)
+ jvs(170) = b(82)
+! JVS(171) = Jac_FULL(26,4)
+ jvs(171) = - b(116)
+! JVS(172) = Jac_FULL(26,6)
+ jvs(172) = b(38)
+! JVS(173) = Jac_FULL(26,9)
+ jvs(173) = b(45) + b(47)
+! JVS(174) = Jac_FULL(26,10)
+ jvs(174) = b(56) + b(57)
+! JVS(175) = Jac_FULL(26,11)
+ jvs(175) = 0.9* b(109)
+! JVS(176) = Jac_FULL(26,13)
+ jvs(176) = - b(91)
+! JVS(177) = Jac_FULL(26,14)
+ jvs(177) = 0
+! JVS(178) = Jac_FULL(26,18)
+ jvs(178) = b(134)
+! JVS(179) = Jac_FULL(26,19)
+ jvs(179) = 0
+! JVS(180) = Jac_FULL(26,20)
+ jvs(180) = 0
+! JVS(181) = Jac_FULL(26,22)
+ jvs(181) = 0
+! JVS(182) = Jac_FULL(26,23)
+ jvs(182) = b(99)
+! JVS(183) = Jac_FULL(26,24)
+ jvs(183) = 0
+! JVS(184) = Jac_FULL(26,25)
+ jvs(184) = b(13) - b(21)
+! JVS(185) = Jac_FULL(26,26)
+ jvs(185) = - b(1) - b(15) - b(17) - b(22) - b(34) - b(40) - b(48) - b(54) - b(80) - b(92) - b(117)
+! JVS(186) = Jac_FULL(26,27)
+ jvs(186) = b(46) - b(49) + b(58)
+! JVS(187) = Jac_FULL(26,28)
+ jvs(187) = b(52) - b(55)
+! JVS(188) = Jac_FULL(26,29)
+ jvs(188) = - b(16) - b(18) + b(19)
+! JVS(189) = Jac_FULL(26,30)
+ jvs(189) = 0.89* b(4) + 2* b(30) - b(35) + b(100)
+! JVS(190) = Jac_FULL(26,31)
+ jvs(190) = b(14) + b(20) + 2* b(31) + 2* b(39) - b(41) + b(53) + b(78) + 0.9* b(110) + b(135)
+! JVS(191) = Jac_FULL(26,32)
+ jvs(191) = b(79) - b(81)
+! JVS(192) = Jac_FULL(27,1)
+ jvs(192) = 2* b(24)
+! JVS(193) = Jac_FULL(27,2)
+ jvs(193) = 2* b(6) - b(62)
+! JVS(194) = Jac_FULL(27,5)
+ jvs(194) = - b(107)
+! JVS(195) = Jac_FULL(27,7)
+ jvs(195) = - b(118)
+! JVS(196) = Jac_FULL(27,9)
+ jvs(196) = b(5) - b(45)
+! JVS(197) = Jac_FULL(27,10)
+ jvs(197) = - b(57)
+! JVS(198) = Jac_FULL(27,12)
+ jvs(198) = - b(50)
+! JVS(199) = Jac_FULL(27,14)
+ jvs(199) = - b(112)
+! JVS(200) = Jac_FULL(27,15)
+ jvs(200) = - b(124)
+! JVS(201) = Jac_FULL(27,16)
+ jvs(201) = - b(64)
+! JVS(202) = Jac_FULL(27,17)
+ jvs(202) = 0.3* b(101) - b(103)
+! JVS(203) = Jac_FULL(27,19)
+ jvs(203) = - b(120) + 0.08* b(122)
+! JVS(204) = Jac_FULL(27,20)
+ jvs(204) = - b(87)
+! JVS(205) = Jac_FULL(27,21)
+ jvs(205) = - b(66) + b(68)
+! JVS(206) = Jac_FULL(27,22)
+ jvs(206) = - b(128) + 0.1* b(130)
+! JVS(207) = Jac_FULL(27,23)
+ jvs(207) = 0.2* b(93) - b(95) + 0.1* b(97)
+! JVS(208) = Jac_FULL(27,24)
+ jvs(208) = b(72) - b(74)
+! JVS(209) = Jac_FULL(27,25)
+ jvs(209) = - b(26) + b(28) + 0.1* b(98) + 0.08* b(123) + 0.1* b(131)
+! JVS(210) = Jac_FULL(27,26)
+ jvs(210) = - b(48)
+! JVS(211) = Jac_FULL(27,27)
+ jvs(211) = - b(27) - b(43) - b(46) - b(49) - b(51) - b(58) - b(63) - b(65) - b(67) - b(75) - b(86) - b(88) - b(96) - b(104) - &
+ b(108) - b(113) - b(119)&
+ &- b(121) - b(125) - b(129)
+! JVS(212) = Jac_FULL(27,28)
+ jvs(212) = b(29) + b(52) + 0.79* b(84)
+! JVS(213) = Jac_FULL(27,29)
+ jvs(213) = b(69) + b(73) + 0.2* b(94) + 0.3* b(102)
+! JVS(214) = Jac_FULL(27,30)
+ jvs(214) = 0
+! JVS(215) = Jac_FULL(27,31)
+ jvs(215) = - b(44) + b(53)
+! JVS(216) = Jac_FULL(27,32)
+ jvs(216) = 0.79* b(85)
+! JVS(217) = Jac_FULL(28,2)
+ jvs(217) = b(62)
+! JVS(218) = Jac_FULL(28,5)
+ jvs(218) = 0.44* b(107)
+! JVS(219) = Jac_FULL(28,7)
+ jvs(219) = 0.7* b(118)
+! JVS(220) = Jac_FULL(28,10)
+ jvs(220) = b(56)
+! JVS(221) = Jac_FULL(28,11)
+ jvs(221) = 0.9* b(109) + b(111)
+! JVS(222) = Jac_FULL(28,13)
+ jvs(222) = 0.94* b(89) + b(90)
+! JVS(223) = Jac_FULL(28,14)
+ jvs(223) = 0.6* b(112)
+! JVS(224) = Jac_FULL(28,15)
+ jvs(224) = b(11)
+! JVS(225) = Jac_FULL(28,16)
+ jvs(225) = b(64)
+! JVS(226) = Jac_FULL(28,17)
+ jvs(226) = 1.7* b(101) + b(103) + 0.12* b(105)
+! JVS(227) = Jac_FULL(28,19)
+ jvs(227) = b(10) + 2* b(120) + 0.76* b(122)
+! JVS(228) = Jac_FULL(28,20)
+ jvs(228) = 0.11* b(87)
+! JVS(229) = Jac_FULL(28,21)
+ jvs(229) = 2* b(7) + b(66) + b(68) + b(70)
+! JVS(230) = Jac_FULL(28,22)
+ jvs(230) = 0.6* b(126) + 0.67* b(128) + 0.44* b(130)
+! JVS(231) = Jac_FULL(28,23)
+ jvs(231) = 0.38* b(93) + b(95) + 0.44* b(97)
+! JVS(232) = Jac_FULL(28,24)
+ jvs(232) = 2* b(9)
+! JVS(233) = Jac_FULL(28,25)
+ jvs(233) = b(26) - b(28) + 0.44* b(98) + 0.12* b(106) + 0.76* b(123) + 0.44* b(131)
+! JVS(234) = Jac_FULL(28,26)
+ jvs(234) = - b(54)
+! JVS(235) = Jac_FULL(28,27)
+ jvs(235) = b(27) + b(63) + b(65) + b(67) + b(86) + 0.11* b(88) + b(96) + b(104) + 0.44* b(108) + 0.6* b(113) + 0.7* b(119) + 2* &
+ b(121) + 0.67&
+ &* b(129)
+! JVS(236) = Jac_FULL(28,28)
+ jvs(236) = - b(29) - b(52) - b(55) - 2* b(59) - 2* b(60) - 0.21* b(84)
+! JVS(237) = Jac_FULL(28,29)
+ jvs(237) = b(69) + 0.38* b(94) + 1.7* b(102) + 0.6* b(127)
+! JVS(238) = Jac_FULL(28,30)
+ jvs(238) = b(71)
+! JVS(239) = Jac_FULL(28,31)
+ jvs(239) = - b(53) + b(78) + 0.9* b(110)
+! JVS(240) = Jac_FULL(28,32)
+ jvs(240) = b(79) + 2* b(83) - 0.21* b(85)
+! JVS(241) = Jac_FULL(29,1)
+ jvs(241) = b(23)
+! JVS(242) = Jac_FULL(29,17)
+ jvs(242) = - b(101)
+! JVS(243) = Jac_FULL(29,21)
+ jvs(243) = - b(68)
+! JVS(244) = Jac_FULL(29,22)
+ jvs(244) = - b(126)
+! JVS(245) = Jac_FULL(29,23)
+ jvs(245) = - b(93)
+! JVS(246) = Jac_FULL(29,24)
+ jvs(246) = - b(72)
+! JVS(247) = Jac_FULL(29,25)
+ jvs(247) = b(2)
+! JVS(248) = Jac_FULL(29,26)
+ jvs(248) = b(1) - b(15) - b(17)
+! JVS(249) = Jac_FULL(29,27)
+ jvs(249) = 0
+! JVS(250) = Jac_FULL(29,28)
+ jvs(250) = 0
+! JVS(251) = Jac_FULL(29,29)
+ jvs(251) = - b(12) - b(16) - b(18) - b(19) - b(69) - b(73) - b(94) - b(102) - b(127)
+! JVS(252) = Jac_FULL(29,30)
+ jvs(252) = 0.89* b(4)
+! JVS(253) = Jac_FULL(29,31)
+ jvs(253) = - b(20)
+! JVS(254) = Jac_FULL(29,32)
+ jvs(254) = 0
+! JVS(255) = Jac_FULL(30,6)
+ jvs(255) = b(38)
+! JVS(256) = Jac_FULL(30,12)
+ jvs(256) = b(50)
+! JVS(257) = Jac_FULL(30,14)
+ jvs(257) = - b(114)
+! JVS(258) = Jac_FULL(30,21)
+ jvs(258) = - b(70)
+! JVS(259) = Jac_FULL(30,22)
+ jvs(259) = - b(132)
+! JVS(260) = Jac_FULL(30,23)
+ jvs(260) = - b(99)
+! JVS(261) = Jac_FULL(30,24)
+ jvs(261) = - b(76)
+! JVS(262) = Jac_FULL(30,25)
+ jvs(262) = b(21)
+! JVS(263) = Jac_FULL(30,26)
+ jvs(263) = b(17) + b(22) - b(32) - b(34)
+! JVS(264) = Jac_FULL(30,27)
+ jvs(264) = b(51)
+! JVS(265) = Jac_FULL(30,28)
+ jvs(265) = 0
+! JVS(266) = Jac_FULL(30,29)
+ jvs(266) = b(18)
+! JVS(267) = Jac_FULL(30,30)
+ jvs(267) = - b(4) - b(30) - b(33) - b(35) - b(71) - b(77) - b(100) - b(115) - b(133)
+! JVS(268) = Jac_FULL(30,31)
+ jvs(268) = - b(31)
+! JVS(269) = Jac_FULL(30,32)
+ jvs(269) = 0
+! JVS(270) = Jac_FULL(31,8)
+ jvs(270) = - b(137)
+! JVS(271) = Jac_FULL(31,9)
+ jvs(271) = b(5) + b(47)
+! JVS(272) = Jac_FULL(31,11)
+ jvs(272) = - b(109)
+! JVS(273) = Jac_FULL(31,13)
+ jvs(273) = 0
+! JVS(274) = Jac_FULL(31,18)
+ jvs(274) = - b(134)
+! JVS(275) = Jac_FULL(31,19)
+ jvs(275) = 0
+! JVS(276) = Jac_FULL(31,20)
+ jvs(276) = 0
+! JVS(277) = Jac_FULL(31,22)
+ jvs(277) = 0
+! JVS(278) = Jac_FULL(31,23)
+ jvs(278) = 0
+! JVS(279) = Jac_FULL(31,24)
+ jvs(279) = 0
+! JVS(280) = Jac_FULL(31,25)
+ jvs(280) = - b(13)
+! JVS(281) = Jac_FULL(31,26)
+ jvs(281) = b(1) + b(15) + b(32) - b(40)
+! JVS(282) = Jac_FULL(31,27)
+ jvs(282) = - b(43)
+! JVS(283) = Jac_FULL(31,28)
+ jvs(283) = - b(52)
+! JVS(284) = Jac_FULL(31,29)
+ jvs(284) = b(16) - b(19)
+! JVS(285) = Jac_FULL(31,30)
+ jvs(285) = 0.11* b(4) - b(30) + b(33)
+! JVS(286) = Jac_FULL(31,31)
+ jvs(286) = - b(14) - b(20) - b(31) - 2* b(39) - b(41) - b(44) - b(53) - b(78) - b(110) - b(135) - b(138)
+! JVS(287) = Jac_FULL(31,32)
+ jvs(287) = - b(79)
+! JVS(288) = Jac_FULL(32,3)
+ jvs(288) = b(82)
+! JVS(289) = Jac_FULL(32,15)
+ jvs(289) = b(11) + b(124)
+! JVS(290) = Jac_FULL(32,19)
+ jvs(290) = b(10) + b(120) + 0.62* b(122)
+! JVS(291) = Jac_FULL(32,22)
+ jvs(291) = 0.2* b(128)
+! JVS(292) = Jac_FULL(32,24)
+ jvs(292) = b(72) + b(74) + b(76)
+! JVS(293) = Jac_FULL(32,25)
+ jvs(293) = 0.62* b(123)
+! JVS(294) = Jac_FULL(32,26)
+ jvs(294) = - b(80)
+! JVS(295) = Jac_FULL(32,27)
+ jvs(295) = b(75) + b(121) + b(125) + 0.2* b(129)
+! JVS(296) = Jac_FULL(32,28)
+ jvs(296) = - b(84)
+! JVS(297) = Jac_FULL(32,29)
+ jvs(297) = b(73)
+! JVS(298) = Jac_FULL(32,30)
+ jvs(298) = b(77)
+! JVS(299) = Jac_FULL(32,31)
+ jvs(299) = - b(78)
+! JVS(300) = Jac_FULL(32,32)
+ jvs(300) = - b(79) - b(81) - 2* b(83) - b(85)
+
+END SUBROUTINE jac_sp
+
+ elemental REAL(kind=dp)FUNCTION k_arr (k_298, tdep, temp)
+ ! arrhenius FUNCTION
+
+ REAL, INTENT(IN):: k_298 ! k at t = 298.15k
+ REAL, INTENT(IN):: tdep ! temperature dependence
+ REAL(kind=dp), INTENT(IN):: temp ! temperature
+
+ intrinsic exp
+
+ k_arr = k_298 * exp(tdep* (1._dp/temp- 3.3540e-3_dp))! 1/298.15=3.3540e-3
+
+ END FUNCTION k_arr
+
+SUBROUTINE update_rconst()
+ INTEGER :: k
+
+ k = is
+
+! Begin INLINED RCONST
+
+
+! End INLINED RCONST
+
+ rconst(1) = (phot(j_no2))
+ rconst(2) = (phot(j_o33p))
+ rconst(3) = (phot(j_o31d))
+ rconst(4) = (phot(j_no3o) + phot(j_no3o2))
+ rconst(5) = (phot(j_hono))
+ rconst(6) = (phot(j_h2o2))
+ rconst(7) = (phot(j_ch2or))
+ rconst(8) = (phot(j_ch2om))
+ rconst(9) = (4.6e-4_dp * phot(j_no2))
+ rconst(10) = (9.04_dp * phot(j_ch2or))
+ rconst(11) = (9.64_dp * phot(j_ch2or))
+ rconst(12) = (arr2(1.4e+3_dp , -1175.0_dp , temp))
+ rconst(13) = (arr2(1.8e-12_dp , + 1370.0_dp , temp))
+ rconst(14) = (9.3e-12_dp)
+ rconst(15) = (arr2(1.6e-13_dp , -687.0_dp , temp))
+ rconst(16) = (arr2(2.2e-13_dp , -602.0_dp , temp))
+ rconst(17) = (arr2(1.2e-13_dp , + 2450.0_dp , temp))
+ rconst(18) = (arr2(1.9e+8_dp , -390.0_dp , temp))
+ rconst(19) = (2.2e-10_dp)
+ rconst(20) = (arr2(1.6e-12_dp , + 940.0_dp , temp))
+ rconst(21) = (arr2(1.4e-14_dp , + 580.0_dp , temp))
+ rconst(22) = (arr2(1.3e-11_dp , -250.0_dp , temp))
+ rconst(23) = (arr2(2.5e-14_dp , + 1230.0_dp , temp))
+ rconst(24) = (arr2(5.3e-13_dp , -256.0_dp , temp))
+ rconst(25) = (1.3e-21_dp)
+ rconst(26) = (arr2(3.5e+14_dp , + 10897.0_dp , temp))
+ rconst(27) = (arr2(1.8e-20_dp , -530.0_dp , temp))
+ rconst(28) = (4.4e-40_dp)
+ rconst(29) = (arr2(4.5e-13_dp , -806.0_dp , temp))
+ rconst(30) = (6.6e-12_dp)
+ rconst(31) = (1.0e-20_dp)
+ rconst(32) = (arr2(1.0e-12_dp , -713.0_dp , temp))
+ rconst(33) = (arr2(5.1e-15_dp , -1000.0_dp , temp))
+ rconst(34) = (arr2(3.7e-12_dp , -240.0_dp , temp))
+ rconst(35) = (arr2(1.2e-13_dp , -749.0_dp , temp))
+ rconst(36) = (arr2(4.8e+13_dp , + 10121.0_dp , temp))
+ rconst(37) = (arr2(1.3e-12_dp , -380.0_dp , temp))
+ rconst(38) = (arr2(5.9e-14_dp , -1150.0_dp , temp))
+ rconst(39) = (arr2(2.2e-38_dp , -5800.0_dp , temp))
+ rconst(40) = (arr2(3.1e-12_dp , + 187.0_dp , temp))
+ rconst(41) = (2.2e-13_dp)
+ rconst(42) = (1.0e-11_dp)
+ rconst(43) = (arr2(3.0e-11_dp , + 1550.0_dp , temp))
+ rconst(44) = (6.3e-16_dp)
+ rconst(45) = (arr2(1.2e-11_dp , + 986.0_dp , temp))
+ rconst(46) = (arr2(7.0e-12_dp , -250.0_dp , temp))
+ rconst(47) = (2.5e-15_dp)
+ rconst(48) = (arr2(5.4e-12_dp , -250.0_dp , temp))
+ rconst(49) = (arr2(8.0e-20_dp , -5500.0_dp , temp))
+ rconst(50) = (arr2(9.4e+16_dp , + 14000.0_dp , temp))
+ rconst(51) = (2.0e-12_dp)
+ rconst(52) = (6.5e-12_dp)
+ rconst(53) = (arr2(1.1e+2_dp , + 1710.0_dp , temp))
+ rconst(54) = (8.1e-13_dp)
+ rconst(55) = (arr2(1.0e+15_dp , + 8000.0_dp , temp))
+ rconst(56) = (1.6e+03_dp)
+ rconst(57) = (1.5e-11_dp)
+ rconst(58) = (arr2(1.2e-11_dp , + 324.0_dp , temp))
+ rconst(59) = (arr2(5.2e-12_dp , -504.0_dp , temp))
+ rconst(60) = (arr2(1.4e-14_dp , + 2105.0_dp , temp))
+ rconst(61) = (7.7e-15_dp)
+ rconst(62) = (arr2(1.0e-11_dp , + 792.0_dp , temp))
+ rconst(63) = (arr2(2.0e-12_dp , -411.0_dp , temp))
+ rconst(64) = (arr2(1.3e-14_dp , + 2633.0_dp , temp))
+ rconst(65) = (arr2(2.1e-12_dp , -322.0_dp , temp))
+ rconst(66) = (8.1e-12_dp)
+ rconst(67) = (4.20_dp)
+ rconst(68) = (4.1e-11_dp)
+ rconst(69) = (2.2e-11_dp)
+ rconst(70) = (1.4e-11_dp)
+ rconst(71) = (arr2(1.7e-11_dp , -116.0_dp , temp))
+ rconst(72) = (3.0e-11_dp)
+ rconst(73) = (arr2(5.4e-17_dp , + 500.0_dp , temp))
+ rconst(74) = (1.70e-11_dp)
+ rconst(75) = (1.80e-11_dp)
+ rconst(76) = (9.6e-11_dp)
+ rconst(77) = (1.2e-17_dp)
+ rconst(78) = (3.2e-13_dp)
+ rconst(79) = (8.1e-12_dp)
+ rconst(80) = (arr2(1.7e-14_dp , -1300.0_dp , temp))
+ rconst(81) = (6.8e-13_dp)
+
+END SUBROUTINE update_rconst
+
+! END FUNCTION ARR2
+REAL(kind=dp)FUNCTION arr2( a0, b0, temp)
+ REAL(kind=dp):: temp
+ REAL(kind=dp):: a0, b0
+ arr2 = a0 * exp( - b0 / temp)
+END FUNCTION arr2
+
+SUBROUTINE initialize_kpp_ctrl(status)
+
+
+ ! i/o
+ INTEGER, INTENT(OUT):: status
+
+ ! local
+ REAL(dp):: tsum
+ INTEGER :: i
+
+ ! check fixed time steps
+ tsum = 0.0_dp
+ DO i=1, nmaxfixsteps
+ IF (t_steps(i)< tiny(0.0_dp))exit
+ tsum = tsum + t_steps(i)
+ ENDDO
+
+ nfsteps = i- 1
+
+ l_fixed_step = (nfsteps > 0).and.((tsum - 1.0)< tiny(0.0_dp))
+
+ IF (l_vector)THEN
+ WRITE(*,*) ' MODE : VECTOR (LENGTH=',VL_DIM,')'
+ ELSE
+ WRITE(*,*) ' MODE : SCALAR'
+ ENDIF
+ !
+ WRITE(*,*) ' DE-INDEXING MODE :',I_LU_DI
+ !
+ WRITE(*,*) ' ICNTRL : ',icntrl
+ WRITE(*,*) ' RCNTRL : ',rcntrl
+ !
+ ! note: this is ONLY meaningful for vectorized (kp4)rosenbrock- methods
+ IF (l_vector)THEN
+ IF (l_fixed_step)THEN
+ WRITE(*,*) ' TIME STEPS : FIXED (',t_steps(1:nfsteps),')'
+ ELSE
+ WRITE(*,*) ' TIME STEPS : AUTOMATIC'
+ ENDIF
+ ELSE
+ WRITE(*,*) ' TIME STEPS : AUTOMATIC '//&
+ &'(t_steps (CTRL_KPP) ignored in SCALAR MODE)'
+ ENDIF
+ ! mz_pj_20070531-
+
+ status = 0
+
+
+END SUBROUTINE initialize_kpp_ctrl
+
+SUBROUTINE error_output(c, ierr, pe)
+
+
+ INTEGER, INTENT(IN):: ierr
+ INTEGER, INTENT(IN):: pe
+ REAL(dp), DIMENSION(:), INTENT(IN):: c
+
+ write(6,*) 'ERROR in chem_gasphase_mod ',ierr,C(1)
+
+
+END SUBROUTINE error_output
+
+ SUBROUTINE wscal(n, alpha, x, incx)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+! constant times a vector: x(1:N) <- Alpha*x(1:N)
+! only for incX=incY=1
+! after BLAS
+! replace this by the function from the optimized BLAS implementation:
+! CALL SSCAL(N,Alpha,X,1) or CALL DSCAL(N,Alpha,X,1)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ INTEGER :: i, incx, m, mp1, n
+ REAL(kind=dp) :: x(n), alpha
+ REAL(kind=dp), PARAMETER :: zero=0.0_dp, one=1.0_dp
+
+ IF (alpha .eq. one)RETURN
+ IF (n .le. 0)RETURN
+
+ m = mod(n, 5)
+ IF ( m .ne. 0)THEN
+ IF (alpha .eq. (- one))THEN
+ DO i = 1, m
+ x(i) = - x(i)
+ ENDDO
+ ELSEIF (alpha .eq. zero)THEN
+ DO i = 1, m
+ x(i) = zero
+ ENDDO
+ ELSE
+ DO i = 1, m
+ x(i) = alpha* x(i)
+ ENDDO
+ ENDIF
+ IF ( n .lt. 5)RETURN
+ ENDIF
+ mp1 = m + 1
+ IF (alpha .eq. (- one))THEN
+ DO i = mp1, n, 5
+ x(i) = - x(i)
+ x(i + 1) = - x(i + 1)
+ x(i + 2) = - x(i + 2)
+ x(i + 3) = - x(i + 3)
+ x(i + 4) = - x(i + 4)
+ ENDDO
+ ELSEIF (alpha .eq. zero)THEN
+ DO i = mp1, n, 5
+ x(i) = zero
+ x(i + 1) = zero
+ x(i + 2) = zero
+ x(i + 3) = zero
+ x(i + 4) = zero
+ ENDDO
+ ELSE
+ DO i = mp1, n, 5
+ x(i) = alpha* x(i)
+ x(i + 1) = alpha* x(i + 1)
+ x(i + 2) = alpha* x(i + 2)
+ x(i + 3) = alpha* x(i + 3)
+ x(i + 4) = alpha* x(i + 4)
+ ENDDO
+ ENDIF
+
+ END SUBROUTINE wscal
+
+ SUBROUTINE waxpy(n, alpha, x, incx, y, incy)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+! constant times a vector plus a vector: y <- y + Alpha*x
+! only for incX=incY=1
+! after BLAS
+! replace this by the function from the optimized BLAS implementation:
+! CALL SAXPY(N,Alpha,X,1,Y,1) or CALL DAXPY(N,Alpha,X,1,Y,1)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ INTEGER :: i, incx, incy, m, mp1, n
+ REAL(kind=dp):: x(n), y(n), alpha
+ REAL(kind=dp), PARAMETER :: zero = 0.0_dp
+
+ IF (alpha .eq. zero)RETURN
+ IF (n .le. 0)RETURN
+
+ m = mod(n, 4)
+ IF ( m .ne. 0)THEN
+ DO i = 1, m
+ y(i) = y(i) + alpha* x(i)
+ ENDDO
+ IF ( n .lt. 4)RETURN
+ ENDIF
+ mp1 = m + 1
+ DO i = mp1, n, 4
+ y(i) = y(i) + alpha* x(i)
+ y(i + 1) = y(i + 1) + alpha* x(i + 1)
+ y(i + 2) = y(i + 2) + alpha* x(i + 2)
+ y(i + 3) = y(i + 3) + alpha* x(i + 3)
+ ENDDO
+
+ END SUBROUTINE waxpy
+
+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
+!
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+!~~~> arguments
+ INTEGER, INTENT(IN) :: n
+ REAL(kind=dp), INTENT(INOUT):: y(n)
+ REAL(kind=dp), INTENT(IN) :: tstart, tend
+ REAL(kind=dp), INTENT(IN) :: abstol(n), reltol(n)
+ INTEGER, INTENT(IN) :: icntrl(20)
+ REAL(kind=dp), INTENT(IN) :: rcntrl(20)
+ INTEGER, INTENT(INOUT):: istatus(20)
+ REAL(kind=dp), 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
+ REAL(kind=dp):: 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
+ REAL(kind=dp):: roundoff, facmin, facmax, facrej, facsafe
+ REAL(kind=dp):: hmin, hmax, hstart
+ REAL(kind=dp):: texit
+ INTEGER :: i, uplimtol, max_no_steps
+ LOGICAL :: autonomous, vectortol
+!~~~> PARAMETERs
+ REAL(kind=dp), PARAMETER :: zero = 0.0_dp, one = 1.0_dp
+ REAL(kind=dp), 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
+ ENDIF
+
+!~~~> 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
+ ENDIF
+
+!~~~> unit roundoff (1+ roundoff>1)
+ roundoff = epsilon(one)
+
+!~~~> 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
+ ENDIF
+!~~~> 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
+ ENDIF
+!~~~> 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
+ ENDIF
+!~~~> 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
+ ENDIF
+ 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
+ ENDIF
+!~~~> 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
+ ENDIF
+!~~~> 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
+ ENDIF
+!~~~> 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
+ ENDIF
+ ENDDO
+
+
+!~~~> 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ REAL(kind=dp), 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}
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+!~~~> input: the initial condition at tstart; output: the solution at t
+ REAL(kind=dp), INTENT(INOUT):: y(n)
+!~~~> input: integration interval
+ REAL(kind=dp), INTENT(IN):: tstart, tend
+!~~~> output: time at which the solution is RETURNed (t=tendIF success)
+ REAL(kind=dp), INTENT(OUT):: t
+!~~~> input: tolerances
+ REAL(kind=dp), INTENT(IN):: abstol(n), reltol(n)
+!~~~> input: integration PARAMETERs
+ LOGICAL, INTENT(IN):: autonomous, vectortol
+ REAL(kind=dp), INTENT(IN):: hstart, hmin, hmax
+ INTEGER, INTENT(IN):: max_no_steps
+ REAL(kind=dp), INTENT(IN):: roundoff, facmin, facmax, facrej, facsafe
+!~~~> output: error indicator
+ INTEGER, INTENT(OUT):: ierr
+! ~~~~ Local variables
+ REAL(kind=dp):: ynew(n), fcn0(n), fcn(n)
+ REAL(kind=dp):: k(n* ros_s), dfdt(n)
+#ifdef full_algebra
+ REAL(kind=dp):: jac0(n, n), ghimj(n, n)
+#else
+ REAL(kind=dp):: jac0(lu_nonzero), ghimj(lu_nonzero)
+#endif
+ REAL(kind=dp):: h, hnew, hc, hg, fac, tau
+ REAL(kind=dp):: err, yerr(n)
+ INTEGER :: pivot(n), direction, ioffset, j, istage
+ LOGICAL :: rejectlasth, rejectmoreh, singular
+!~~~> local PARAMETERs
+ REAL(kind=dp), PARAMETER :: zero = 0.0_dp, one = 1.0_dp
+ REAL(kind=dp), PARAMETER :: deltamin = 1.0e-5_dp
+!~~~> locally called FUNCTIONs
+! REAL(kind=dp) 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
+ ENDIF
+ 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
+ ENDIF
+ IF (((t+ 0.1_dp* h) == t).or.(h <= roundoff))THEN ! step size too small
+ CALL ros_errormsg(- 7, t, h, ierr)
+ RETURN
+ ENDIF
+
+!~~~> 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)
+ ENDIF
+
+!~~~> 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
+ ENDIF
+
+!~~~> 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
+ !slim: CALL wcopy(n, fcn0, 1, fcn, 1)
+ fcn(1:n) = fcn0(1:n)
+ ! istage>1 and a new FUNCTION evaluation is needed at the current istage
+ ELSEIF(ros_newf(istage))THEN
+ !slim: CALL wcopy(n, y, 1, ynew, 1)
+ ynew(1:n) = y(1:n)
+ DO j = 1, istage-1
+ CALL waxpy(n, ros_a((istage-1) * (istage-2) /2+ j), &
+ k(n* (j- 1) + 1), 1, ynew, 1)
+ ENDDO
+ tau = t + ros_alpha(istage) * direction* h
+ CALL funtemplate(tau, ynew, fcn)
+ istatus(nfun) = istatus(nfun) + 1
+ ENDIF ! IF istage == 1 ELSEIF ros_newf(istage)
+ !slim: CALL wcopy(n, fcn, 1, k(ioffset+ 1), 1)
+ k(ioffset+ 1:ioffset+ n) = fcn(1:n)
+ 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), 1, k(ioffset+ 1), 1)
+ ENDDO
+ 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), 1)
+ ENDIF
+ CALL ros_solve(ghimj, pivot, k(ioffset+ 1))
+
+ END DO stage
+
+
+!~~~> compute the new solution
+ !slim: CALL wcopy(n, y, 1, ynew, 1)
+ ynew(1:n) = y(1:n)
+ DO j=1, ros_s
+ CALL waxpy(n, ros_m(j), k(n* (j- 1) + 1), 1, ynew, 1)
+ ENDDO
+
+!~~~> compute the error estimation
+ !slim: CALL wscal(n, zero, yerr, 1)
+ yerr(1:n) = zero
+ DO j=1, ros_s
+ CALL waxpy(n, ros_e(j), k(n* (j- 1) + 1), 1, yerr, 1)
+ ENDDO
+ 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
+ !slim: CALL wcopy(n, ynew, 1, y, 1)
+ y(1:n) = ynew(1:n)
+ 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)
+ ENDIF
+ 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
+ ENDIF
+ rejectmoreh = rejectlasth
+ rejectlasth = .TRUE.
+ h = hnew
+ IF (istatus(nacc)>= 1) istatus(nrej) = istatus(nrej) + 1
+ ENDIF ! err <= 1
+
+ END DO untilaccepted
+
+ END DO timeloop
+
+!~~~> succesful exit
+ ierr = 1 !~~~> the integration was successful
+
+ END SUBROUTINE ros_integrator
+
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ REAL(kind=dp)FUNCTION ros_errornorm(y, ynew, yerr, &
+ abstol, reltol, vectortol)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> computes the "scaled norm" of the error vector yerr
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+! Input arguments
+ REAL(kind=dp), INTENT(IN):: y(n), ynew(n), &
+ yerr(n), abstol(n), reltol(n)
+ LOGICAL, INTENT(IN):: vectortol
+! Local variables
+ REAL(kind=dp):: err, scale, ymax
+ INTEGER :: i
+ REAL(kind=dp), 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
+ ENDIF
+ err = err+ (yerr(i) /scale) ** 2
+ ENDDO
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+!~~~> input arguments
+ REAL(kind=dp), INTENT(IN):: t, roundoff, y(n), fcn0(n)
+!~~~> output arguments
+ REAL(kind=dp), INTENT(OUT):: dfdt(n)
+!~~~> local variables
+ REAL(kind=dp):: delta
+ REAL(kind=dp), 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
+! --- --- --- --- --- --- --- --- --- --- --- --- ---
+
+!~~~> input arguments
+#ifdef full_algebra
+ REAL(kind=dp), INTENT(IN):: jac0(n, n)
+#else
+ REAL(kind=dp), INTENT(IN):: jac0(lu_nonzero)
+#endif
+ REAL(kind=dp), INTENT(IN):: gam
+ INTEGER, INTENT(IN):: direction
+!~~~> output arguments
+#ifdef full_algebra
+ REAL(kind=dp), INTENT(OUT):: ghimj(n, n)
+#else
+ REAL(kind=dp), INTENT(OUT):: ghimj(lu_nonzero)
+#endif
+ LOGICAL, INTENT(OUT):: singular
+ INTEGER, INTENT(OUT):: pivot(n)
+!~~~> inout arguments
+ REAL(kind=dp), INTENT(INOUT):: h ! step size is decreased when lu fails
+!~~~> local variables
+ INTEGER :: i, ising, nconsecutive
+ REAL(kind=dp):: ghinv
+ REAL(kind=dp), 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
+ !slim: CALL wcopy(n* n, jac0, 1, ghimj, 1)
+ !slim: CALL wscal(n* n, (- one), ghimj, 1)
+ ghimj = - jac0
+ ghinv = one/(direction* h* gam)
+ DO i=1, n
+ ghimj(i, i) = ghimj(i, i) + ghinv
+ ENDDO
+#else
+ !slim: CALL wcopy(lu_nonzero, jac0, 1, ghimj, 1)
+ !slim: CALL wscal(lu_nonzero, (- one), ghimj, 1)
+ ghimj(1:lu_nonzero) = - jac0(1:lu_nonzero)
+ ghinv = one/(direction* h* gam)
+ DO i=1, n
+ ghimj(lu_diag(i)) = ghimj(lu_diag(i)) + ghinv
+ ENDDO
+#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
+ ENDIF ! nconsecutive
+ ENDIF ! ising
+
+ END DO ! WHILE singular
+
+ END SUBROUTINE ros_preparematrix
+
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE ros_decomp( a, pivot, ising)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! Template for the LU decomposition
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> inout variables
+#ifdef full_algebra
+ REAL(kind=dp), INTENT(INOUT):: a(n, n)
+#else
+ REAL(kind=dp), INTENT(INOUT):: a(lu_nonzero)
+#endif
+!~~~> 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)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> input variables
+#ifdef full_algebra
+ REAL(kind=dp), INTENT(IN):: a(n, n)
+ INTEGER :: ising
+#else
+ REAL(kind=dp), INTENT(IN):: a(lu_nonzero)
+#endif
+ INTEGER, INTENT(IN):: pivot(n)
+!~~~> inout variables
+ REAL(kind=dp), INTENT(INOUT):: b(n)
+
+#ifdef full_algebra
+ CALL DGETRS( 'N',N ,1,A,N,Pivot,b,N,ISING)
+ IF (info < 0)THEN
+ print* , "error in dgetrs. ising=", ising
+ ENDIF
+#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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ 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)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+ 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)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> input variables
+ REAL(kind=dp):: t, y(nvar)
+!~~~> output variables
+ REAL(kind=dp):: ydot(nvar)
+!~~~> local variables
+ REAL(kind=dp):: told
+
+ told = time
+ time = t
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> input variables
+ REAL(kind=dp):: t, y(nvar)
+!~~~> output variables
+#ifdef full_algebra
+ REAL(kind=dp):: jv(lu_nonzero), jcb(nvar, nvar)
+#else
+ REAL(kind=dp):: jcb(lu_nonzero)
+#endif
+!~~~> local variables
+ REAL(kind=dp):: told
+#ifdef full_algebra
+ INTEGER :: i, j
+#endif
+
+ told = time
+ time = t
+#ifdef full_algebra
+ CALL jac_sp(y, fix, rconst, jv)
+ DO j=1, nvar
+ DO i=1, nvar
+ jcb(i, j) = 0.0_dp
+ ENDDO
+ ENDDO
+ DO i=1, lu_nonzero
+ jcb(lu_irow(i), lu_icol(i)) = jv(i)
+ ENDDO
+#else
+ CALL jac_sp( y, fix, rconst, jcb)
+#endif
+ time = told
+
+END SUBROUTINE jactemplate
+
+ SUBROUTINE kppdecomp( jvs, ier)
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! sparse lu factorization
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! loop expansion generated by kp4
+
+ INTEGER :: ier
+ REAL(kind=dp):: jvs(lu_nonzero), w(nvar), a
+ INTEGER :: k, kk, j, jj
+
+ a = 0.
+ ier = 0
+
+! i = 1
+! i = 2
+! i = 3
+! i = 4
+! i = 5
+! i = 6
+! i = 7
+! i = 8
+! i = 9
+! i = 10
+! i = 11
+ jvs(38) = (jvs(38)) / jvs(14)
+ jvs(39) = (jvs(39)) / jvs(19)
+ jvs(41) = jvs(41) - jvs(15) * jvs(38) - jvs(20) * jvs(39)
+! i = 12
+ jvs(43) = (jvs(43)) / jvs(16)
+ jvs(48) = jvs(48) - jvs(17) * jvs(43)
+ jvs(50) = jvs(50) - jvs(18) * jvs(43)
+! i = 13
+! i = 14
+ jvs(55) = (jvs(55)) / jvs(14)
+ jvs(56) = (jvs(56)) / jvs(19)
+ jvs(57) = (jvs(57)) / jvs(40)
+ jvs(59) = jvs(59) - jvs(15) * jvs(55) - jvs(20) * jvs(56) - jvs(41) * jvs(57)
+ jvs(61) = jvs(61) - jvs(42) * jvs(57)
+! i = 15
+ jvs(62) = (jvs(62)) / jvs(19)
+ jvs(67) = jvs(67) - jvs(20) * jvs(62)
+! i = 16
+ jvs(68) = (jvs(68)) / jvs(63)
+ jvs(71) = jvs(71) - jvs(64) * jvs(68)
+ jvs(73) = jvs(73) - jvs(65) * jvs(68)
+ jvs(76) = jvs(76) - jvs(66) * jvs(68)
+ jvs(77) = jvs(77) - jvs(67) * jvs(68)
+! i = 17
+! i = 18
+ jvs(85) = (jvs(85)) / jvs(14)
+ jvs(86) = (jvs(86)) / jvs(19)
+ jvs(87) = (jvs(87)) / jvs(51)
+ jvs(88) = (jvs(88)) / jvs(58)
+ jvs(89) = (jvs(89)) / jvs(63)
+ jvs(90) = (jvs(90)) / jvs(80)
+ jvs(92) = jvs(92) - jvs(64) * jvs(89)
+ jvs(93) = jvs(93) - jvs(52) * jvs(87)
+ jvs(94) = jvs(94) - jvs(65) * jvs(89) - jvs(81) * jvs(90)
+ jvs(97) = jvs(97) - jvs(66) * jvs(89) - jvs(82) * jvs(90)
+ jvs(98) = jvs(98) - jvs(53) * jvs(87)
+ jvs(99) = jvs(99) - jvs(15) * jvs(85) - jvs(20) * jvs(86) - jvs(54) * jvs(87) - jvs(59) * jvs(88)&
+ - jvs(67) * jvs(89) - jvs(83) * jvs(90)
+ jvs(101) = jvs(101) - jvs(84) * jvs(90)
+ jvs(102) = jvs(102) - jvs(60) * jvs(88)
+ jvs(103) = jvs(103) - jvs(61) * jvs(88)
+! i = 19
+ jvs(105) = (jvs(105)) / jvs(40)
+ jvs(106) = (jvs(106)) / jvs(58)
+ jvs(109) = jvs(109) - jvs(41) * jvs(105) - jvs(59) * jvs(106)
+ jvs(110) = jvs(110) - jvs(60) * jvs(106)
+ jvs(111) = jvs(111) - jvs(42) * jvs(105) - jvs(61) * jvs(106)
+! i = 20
+ jvs(112) = (jvs(112)) / jvs(19)
+ jvs(113) = (jvs(113)) / jvs(51)
+ jvs(114) = jvs(114) - jvs(52) * jvs(113)
+ jvs(118) = jvs(118) - jvs(53) * jvs(113)
+ jvs(119) = jvs(119) - jvs(20) * jvs(112) - jvs(54) * jvs(113)
+! i = 21
+ jvs(122) = (jvs(122)) / jvs(80)
+ jvs(123) = (jvs(123)) / jvs(107)
+ jvs(125) = jvs(125) - jvs(81) * jvs(122)
+ jvs(128) = jvs(128) - jvs(82) * jvs(122) - jvs(108) * jvs(123)
+ jvs(129) = jvs(129) - jvs(83) * jvs(122) - jvs(109) * jvs(123)
+ jvs(131) = jvs(131) - jvs(84) * jvs(122)
+ jvs(132) = jvs(132) - jvs(110) * jvs(123)
+ jvs(133) = jvs(133) - jvs(111) * jvs(123)
+! i = 22
+! i = 23
+ jvs(140) = (jvs(140)) / jvs(135)
+ jvs(142) = jvs(142) - jvs(136) * jvs(140)
+ jvs(143) = jvs(143) - jvs(137) * jvs(140)
+ jvs(144) = jvs(144) - jvs(138) * jvs(140)
+ jvs(145) = jvs(145) - jvs(139) * jvs(140)
+! i = 24
+ jvs(146) = (jvs(146)) / jvs(51)
+ jvs(147) = (jvs(147)) / jvs(80)
+ jvs(148) = (jvs(148)) / jvs(107)
+ a = 0.0; a = a - jvs(52) * jvs(146)
+ jvs(149) = (jvs(149) + a) / jvs(114)
+ a = 0.0; a = a - jvs(81) * jvs(147) - jvs(115) * jvs(149)
+ jvs(150) = (jvs(150) + a) / jvs(135)
+ a = 0.0; a = a - jvs(116) * jvs(149)
+ jvs(151) = (jvs(151) + a) / jvs(141)
+ jvs(153) = jvs(153) - jvs(82) * jvs(147) - jvs(108) * jvs(148) - jvs(117) * jvs(149) - jvs(136) * jvs(150)&
+ - jvs(142) * jvs(151)
+ jvs(154) = jvs(154) - jvs(53) * jvs(146) - jvs(118) * jvs(149)
+ jvs(155) = jvs(155) - jvs(54) * jvs(146) - jvs(83) * jvs(147) - jvs(109) * jvs(148) - jvs(119) * jvs(149)&
+ - jvs(137) * jvs(150) - jvs(143) * jvs(151)
+ jvs(156) = jvs(156) - jvs(84) * jvs(147) - jvs(120) * jvs(149) - jvs(138) * jvs(150) - jvs(144) * jvs(151)
+ jvs(157) = jvs(157) - jvs(110) * jvs(148) - jvs(121) * jvs(149) - jvs(139) * jvs(150) - jvs(145) * jvs(151)
+ jvs(158) = jvs(158) - jvs(111) * jvs(148)
+! i = 25
+ jvs(159) = (jvs(159)) / jvs(80)
+ jvs(160) = (jvs(160)) / jvs(107)
+ a = 0.0; a = a - jvs(81) * jvs(159)
+ jvs(161) = (jvs(161) + a) / jvs(135)
+ jvs(162) = (jvs(162)) / jvs(141)
+ jvs(163) = jvs(163) - jvs(82) * jvs(159) - jvs(108) * jvs(160) - jvs(136) * jvs(161) - jvs(142) * jvs(162)
+ jvs(165) = jvs(165) - jvs(83) * jvs(159) - jvs(109) * jvs(160) - jvs(137) * jvs(161) - jvs(143) * jvs(162)
+ jvs(167) = jvs(167) - jvs(84) * jvs(159) - jvs(138) * jvs(161) - jvs(144) * jvs(162)
+ jvs(168) = jvs(168) - jvs(110) * jvs(160) - jvs(139) * jvs(161) - jvs(145) * jvs(162)
+ jvs(169) = jvs(169) - jvs(111) * jvs(160)
+! i = 26
+ jvs(170) = (jvs(170)) / jvs(6)
+ jvs(171) = (jvs(171)) / jvs(9)
+ jvs(172) = (jvs(172)) / jvs(16)
+ jvs(173) = (jvs(173)) / jvs(30)
+ jvs(174) = (jvs(174)) / jvs(34)
+ jvs(175) = (jvs(175)) / jvs(40)
+ jvs(176) = (jvs(176)) / jvs(51)
+ a = 0.0; a = a - jvs(10) * jvs(171)
+ jvs(177) = (jvs(177) + a) / jvs(58)
+ jvs(178) = (jvs(178)) / jvs(91)
+ a = 0.0; a = a - jvs(92) * jvs(178)
+ jvs(179) = (jvs(179) + a) / jvs(107)
+ a = 0.0; a = a - jvs(52) * jvs(176) - jvs(93) * jvs(178)
+ jvs(180) = (jvs(180) + a) / jvs(114)
+ a = 0.0; a = a - jvs(94) * jvs(178) - jvs(115) * jvs(180)
+ jvs(181) = (jvs(181) + a) / jvs(135)
+ a = 0.0; a = a - jvs(95) * jvs(178) - jvs(116) * jvs(180)
+ jvs(182) = (jvs(182) + a) / jvs(141)
+ a = 0.0; a = a - jvs(96) * jvs(178)
+ jvs(183) = (jvs(183) + a) / jvs(152)
+ a = 0.0; a = a - jvs(97) * jvs(178) - jvs(108) * jvs(179) - jvs(117) * jvs(180) - jvs(136) * jvs(181)&
+ - jvs(142) * jvs(182) - jvs(153) * jvs(183)
+ jvs(184) = (jvs(184) + a) / jvs(163)
+ jvs(185) = jvs(185) - jvs(7) * jvs(170) - jvs(11) * jvs(171) - jvs(17) * jvs(172) - jvs(31) * jvs(173)&
+ - jvs(35) * jvs(174) - jvs(53) * jvs(176) - jvs(98) * jvs(178) - jvs(118) * jvs(180) - jvs(154) * jvs(183)&
+ - jvs(164) * jvs(184)
+ jvs(186) = jvs(186) - jvs(12) * jvs(171) - jvs(32) * jvs(173) - jvs(36) * jvs(174) - jvs(41) * jvs(175)&
+ - jvs(54) * jvs(176) - jvs(59) * jvs(177) - jvs(99) * jvs(178) - jvs(109) * jvs(179) - jvs(119) * jvs(180)&
+ - jvs(137) * jvs(181) - jvs(143) * jvs(182) - jvs(155) * jvs(183) - jvs(165) * jvs(184)
+ jvs(187) = jvs(187) - jvs(37) * jvs(174) - jvs(100) * jvs(178) - jvs(166) * jvs(184)
+ jvs(188) = jvs(188) - jvs(101) * jvs(178) - jvs(120) * jvs(180) - jvs(138) * jvs(181) - jvs(144) * jvs(182)&
+ - jvs(156) * jvs(183) - jvs(167) * jvs(184)
+ jvs(189) = jvs(189) - jvs(13) * jvs(171) - jvs(18) * jvs(172) - jvs(60) * jvs(177) - jvs(102) * jvs(178)&
+ - jvs(110) * jvs(179) - jvs(121) * jvs(180) - jvs(139) * jvs(181) - jvs(145) * jvs(182) - jvs(157) * jvs(183)&
+ - jvs(168) * jvs(184)
+ jvs(190) = jvs(190) - jvs(33) * jvs(173) - jvs(42) * jvs(175) - jvs(61) * jvs(177) - jvs(103) * jvs(178)&
+ - jvs(111) * jvs(179) - jvs(158) * jvs(183) - jvs(169) * jvs(184)
+ jvs(191) = jvs(191) - jvs(8) * jvs(170) - jvs(104) * jvs(178)
+! i = 27
+ jvs(192) = (jvs(192)) / jvs(1)
+ jvs(193) = (jvs(193)) / jvs(3)
+ jvs(194) = (jvs(194)) / jvs(14)
+ jvs(195) = (jvs(195)) / jvs(19)
+ jvs(196) = (jvs(196)) / jvs(30)
+ jvs(197) = (jvs(197)) / jvs(34)
+ jvs(198) = (jvs(198)) / jvs(44)
+ a = 0.0; a = a - jvs(45) * jvs(198)
+ jvs(199) = (jvs(199) + a) / jvs(58)
+ jvs(200) = (jvs(200)) / jvs(63)
+ jvs(201) = (jvs(201)) / jvs(69)
+ a = 0.0; a = a - jvs(70) * jvs(201)
+ jvs(202) = (jvs(202) + a) / jvs(80)
+ a = 0.0; a = a - jvs(64) * jvs(200) - jvs(71) * jvs(201)
+ jvs(203) = (jvs(203) + a) / jvs(107)
+ jvs(204) = (jvs(204)) / jvs(114)
+ a = 0.0; a = a - jvs(46) * jvs(198) - jvs(72) * jvs(201)
+ jvs(205) = (jvs(205) + a) / jvs(124)
+ a = 0.0; a = a - jvs(65) * jvs(200) - jvs(73) * jvs(201) - jvs(81) * jvs(202) - jvs(115) * jvs(204)&
+ - jvs(125) * jvs(205)
+ jvs(206) = (jvs(206) + a) / jvs(135)
+ a = 0.0; a = a - jvs(74) * jvs(201) - jvs(116) * jvs(204) - jvs(126) * jvs(205)
+ jvs(207) = (jvs(207) + a) / jvs(141)
+ a = 0.0; a = a - jvs(47) * jvs(198) - jvs(75) * jvs(201) - jvs(127) * jvs(205)
+ jvs(208) = (jvs(208) + a) / jvs(152)
+ a = 0.0; a = a - jvs(2) * jvs(192) - jvs(66) * jvs(200) - jvs(76) * jvs(201) - jvs(82) * jvs(202)&
+ - jvs(108) * jvs(203) - jvs(117) * jvs(204) - jvs(128) * jvs(205) - jvs(136) * jvs(206) - jvs(142) * jvs(207)&
+ - jvs(153) * jvs(208)
+ jvs(209) = (jvs(209) + a) / jvs(163)
+ a = 0.0; a = a - jvs(31) * jvs(196) - jvs(35) * jvs(197) - jvs(48) * jvs(198) - jvs(118) * jvs(204)&
+ - jvs(154) * jvs(208) - jvs(164) * jvs(209)
+ jvs(210) = (jvs(210) + a) / jvs(185)
+ jvs(211) = jvs(211) - jvs(4) * jvs(193) - jvs(15) * jvs(194) - jvs(20) * jvs(195) - jvs(32) * jvs(196)&
+ - jvs(36) * jvs(197) - jvs(49) * jvs(198) - jvs(59) * jvs(199) - jvs(67) * jvs(200) - jvs(77) * jvs(201)&
+ - jvs(83) * jvs(202) - jvs(109) * jvs(203) - jvs(119) * jvs(204) - jvs(129) * jvs(205) - jvs(137) * jvs(206)&
+ - jvs(143) * jvs(207) - jvs(155) * jvs(208) - jvs(165) * jvs(209) - jvs(186) * jvs(210)
+ jvs(212) = jvs(212) - jvs(5) * jvs(193) - jvs(37) * jvs(197) - jvs(130) * jvs(205) - jvs(166) * jvs(209)&
+ - jvs(187) * jvs(210)
+ jvs(213) = jvs(213) - jvs(78) * jvs(201) - jvs(84) * jvs(202) - jvs(120) * jvs(204) - jvs(131) * jvs(205)&
+ - jvs(138) * jvs(206) - jvs(144) * jvs(207) - jvs(156) * jvs(208) - jvs(167) * jvs(209) - jvs(188) * jvs(210)
+ jvs(214) = jvs(214) - jvs(50) * jvs(198) - jvs(60) * jvs(199) - jvs(79) * jvs(201) - jvs(110) * jvs(203)&
+ - jvs(121) * jvs(204) - jvs(132) * jvs(205) - jvs(139) * jvs(206) - jvs(145) * jvs(207) - jvs(157) * jvs(208)&
+ - jvs(168) * jvs(209) - jvs(189) * jvs(210)
+ jvs(215) = jvs(215) - jvs(33) * jvs(196) - jvs(61) * jvs(199) - jvs(111) * jvs(203) - jvs(133) * jvs(205)&
+ - jvs(158) * jvs(208) - jvs(169) * jvs(209) - jvs(190) * jvs(210)
+ jvs(216) = jvs(216) - jvs(134) * jvs(205) - jvs(191) * jvs(210)
+! i = 28
+ jvs(217) = (jvs(217)) / jvs(3)
+ jvs(218) = (jvs(218)) / jvs(14)
+ jvs(219) = (jvs(219)) / jvs(19)
+ jvs(220) = (jvs(220)) / jvs(34)
+ jvs(221) = (jvs(221)) / jvs(40)
+ jvs(222) = (jvs(222)) / jvs(51)
+ jvs(223) = (jvs(223)) / jvs(58)
+ jvs(224) = (jvs(224)) / jvs(63)
+ jvs(225) = (jvs(225)) / jvs(69)
+ a = 0.0; a = a - jvs(70) * jvs(225)
+ jvs(226) = (jvs(226) + a) / jvs(80)
+ a = 0.0; a = a - jvs(64) * jvs(224) - jvs(71) * jvs(225)
+ jvs(227) = (jvs(227) + a) / jvs(107)
+ a = 0.0; a = a - jvs(52) * jvs(222)
+ jvs(228) = (jvs(228) + a) / jvs(114)
+ a = 0.0; a = a - jvs(72) * jvs(225)
+ jvs(229) = (jvs(229) + a) / jvs(124)
+ a = 0.0; a = a - jvs(65) * jvs(224) - jvs(73) * jvs(225) - jvs(81) * jvs(226) - jvs(115) * jvs(228)&
+ - jvs(125) * jvs(229)
+ jvs(230) = (jvs(230) + a) / jvs(135)
+ a = 0.0; a = a - jvs(74) * jvs(225) - jvs(116) * jvs(228) - jvs(126) * jvs(229)
+ jvs(231) = (jvs(231) + a) / jvs(141)
+ a = 0.0; a = a - jvs(75) * jvs(225) - jvs(127) * jvs(229)
+ jvs(232) = (jvs(232) + a) / jvs(152)
+ a = 0.0; a = a - jvs(66) * jvs(224) - jvs(76) * jvs(225) - jvs(82) * jvs(226) - jvs(108) * jvs(227)&
+ - jvs(117) * jvs(228) - jvs(128) * jvs(229) - jvs(136) * jvs(230) - jvs(142) * jvs(231) - jvs(153) * jvs(232)
+ jvs(233) = (jvs(233) + a) / jvs(163)
+ a = 0.0; a = a - jvs(35) * jvs(220) - jvs(53) * jvs(222) - jvs(118) * jvs(228) - jvs(154) * jvs(232)&
+ - jvs(164) * jvs(233)
+ jvs(234) = (jvs(234) + a) / jvs(185)
+ a = 0.0; a = a - jvs(4) * jvs(217) - jvs(15) * jvs(218) - jvs(20) * jvs(219) - jvs(36) * jvs(220)&
+ - jvs(41) * jvs(221) - jvs(54) * jvs(222) - jvs(59) * jvs(223) - jvs(67) * jvs(224) - jvs(77) * jvs(225)&
+ - jvs(83) * jvs(226) - jvs(109) * jvs(227) - jvs(119) * jvs(228) - jvs(129) * jvs(229) - jvs(137) * jvs(230)&
+ - jvs(143) * jvs(231) - jvs(155) * jvs(232) - jvs(165) * jvs(233) - jvs(186) * jvs(234)
+ jvs(235) = (jvs(235) + a) / jvs(211)
+ jvs(236) = jvs(236) - jvs(5) * jvs(217) - jvs(37) * jvs(220) - jvs(130) * jvs(229) - jvs(166) * jvs(233)&
+ - jvs(187) * jvs(234) - jvs(212) * jvs(235)
+ jvs(237) = jvs(237) - jvs(78) * jvs(225) - jvs(84) * jvs(226) - jvs(120) * jvs(228) - jvs(131) * jvs(229)&
+ - jvs(138) * jvs(230) - jvs(144) * jvs(231) - jvs(156) * jvs(232) - jvs(167) * jvs(233) - jvs(188) * jvs(234)&
+ - jvs(213) * jvs(235)
+ jvs(238) = jvs(238) - jvs(60) * jvs(223) - jvs(79) * jvs(225) - jvs(110) * jvs(227) - jvs(121) * jvs(228)&
+ - jvs(132) * jvs(229) - jvs(139) * jvs(230) - jvs(145) * jvs(231) - jvs(157) * jvs(232) - jvs(168) * jvs(233)&
+ - jvs(189) * jvs(234) - jvs(214) * jvs(235)
+ jvs(239) = jvs(239) - jvs(42) * jvs(221) - jvs(61) * jvs(223) - jvs(111) * jvs(227) - jvs(133) * jvs(229)&
+ - jvs(158) * jvs(232) - jvs(169) * jvs(233) - jvs(190) * jvs(234) - jvs(215) * jvs(235)
+ jvs(240) = jvs(240) - jvs(134) * jvs(229) - jvs(191) * jvs(234) - jvs(216) * jvs(235)
+! i = 29
+ jvs(241) = (jvs(241)) / jvs(1)
+ jvs(242) = (jvs(242)) / jvs(80)
+ jvs(243) = (jvs(243)) / jvs(124)
+ a = 0.0; a = a - jvs(81) * jvs(242) - jvs(125) * jvs(243)
+ jvs(244) = (jvs(244) + a) / jvs(135)
+ a = 0.0; a = a - jvs(126) * jvs(243)
+ jvs(245) = (jvs(245) + a) / jvs(141)
+ a = 0.0; a = a - jvs(127) * jvs(243)
+ jvs(246) = (jvs(246) + a) / jvs(152)
+ a = 0.0; a = a - jvs(2) * jvs(241) - jvs(82) * jvs(242) - jvs(128) * jvs(243) - jvs(136) * jvs(244)&
+ - jvs(142) * jvs(245) - jvs(153) * jvs(246)
+ jvs(247) = (jvs(247) + a) / jvs(163)
+ a = 0.0; a = a - jvs(154) * jvs(246) - jvs(164) * jvs(247)
+ jvs(248) = (jvs(248) + a) / jvs(185)
+ a = 0.0; a = a - jvs(83) * jvs(242) - jvs(129) * jvs(243) - jvs(137) * jvs(244) - jvs(143) * jvs(245)&
+ - jvs(155) * jvs(246) - jvs(165) * jvs(247) - jvs(186) * jvs(248)
+ jvs(249) = (jvs(249) + a) / jvs(211)
+ a = 0.0; a = a - jvs(130) * jvs(243) - jvs(166) * jvs(247) - jvs(187) * jvs(248) - jvs(212) * jvs(249)
+ jvs(250) = (jvs(250) + a) / jvs(236)
+ jvs(251) = jvs(251) - jvs(84) * jvs(242) - jvs(131) * jvs(243) - jvs(138) * jvs(244) - jvs(144) * jvs(245)&
+ - jvs(156) * jvs(246) - jvs(167) * jvs(247) - jvs(188) * jvs(248) - jvs(213) * jvs(249) - jvs(237) * jvs(250)
+ jvs(252) = jvs(252) - jvs(132) * jvs(243) - jvs(139) * jvs(244) - jvs(145) * jvs(245) - jvs(157) * jvs(246)&
+ - jvs(168) * jvs(247) - jvs(189) * jvs(248) - jvs(214) * jvs(249) - jvs(238) * jvs(250)
+ jvs(253) = jvs(253) - jvs(133) * jvs(243) - jvs(158) * jvs(246) - jvs(169) * jvs(247) - jvs(190) * jvs(248)&
+ - jvs(215) * jvs(249) - jvs(239) * jvs(250)
+ jvs(254) = jvs(254) - jvs(134) * jvs(243) - jvs(191) * jvs(248) - jvs(216) * jvs(249) - jvs(240) * jvs(250)
+! i = 30
+ jvs(255) = (jvs(255)) / jvs(16)
+ jvs(256) = (jvs(256)) / jvs(44)
+ a = 0.0; a = a - jvs(45) * jvs(256)
+ jvs(257) = (jvs(257) + a) / jvs(58)
+ a = 0.0; a = a - jvs(46) * jvs(256)
+ jvs(258) = (jvs(258) + a) / jvs(124)
+ a = 0.0; a = a - jvs(125) * jvs(258)
+ jvs(259) = (jvs(259) + a) / jvs(135)
+ a = 0.0; a = a - jvs(126) * jvs(258)
+ jvs(260) = (jvs(260) + a) / jvs(141)
+ a = 0.0; a = a - jvs(47) * jvs(256) - jvs(127) * jvs(258)
+ jvs(261) = (jvs(261) + a) / jvs(152)
+ a = 0.0; a = a - jvs(128) * jvs(258) - jvs(136) * jvs(259) - jvs(142) * jvs(260) - jvs(153) * jvs(261)
+ jvs(262) = (jvs(262) + a) / jvs(163)
+ a = 0.0; a = a - jvs(17) * jvs(255) - jvs(48) * jvs(256) - jvs(154) * jvs(261) - jvs(164) * jvs(262)
+ jvs(263) = (jvs(263) + a) / jvs(185)
+ a = 0.0; a = a - jvs(49) * jvs(256) - jvs(59) * jvs(257) - jvs(129) * jvs(258) - jvs(137) * jvs(259)&
+ - jvs(143) * jvs(260) - jvs(155) * jvs(261) - jvs(165) * jvs(262) - jvs(186) * jvs(263)
+ jvs(264) = (jvs(264) + a) / jvs(211)
+ a = 0.0; a = a - jvs(130) * jvs(258) - jvs(166) * jvs(262) - jvs(187) * jvs(263) - jvs(212) * jvs(264)
+ jvs(265) = (jvs(265) + a) / jvs(236)
+ a = 0.0; a = a - jvs(131) * jvs(258) - jvs(138) * jvs(259) - jvs(144) * jvs(260) - jvs(156) * jvs(261)&
+ - jvs(167) * jvs(262) - jvs(188) * jvs(263) - jvs(213) * jvs(264) - jvs(237) * jvs(265)
+ jvs(266) = (jvs(266) + a) / jvs(251)
+ jvs(267) = jvs(267) - jvs(18) * jvs(255) - jvs(50) * jvs(256) - jvs(60) * jvs(257) - jvs(132) * jvs(258)&
+ - jvs(139) * jvs(259) - jvs(145) * jvs(260) - jvs(157) * jvs(261) - jvs(168) * jvs(262) - jvs(189) * jvs(263)&
+ - jvs(214) * jvs(264) - jvs(238) * jvs(265) - jvs(252) * jvs(266)
+ jvs(268) = jvs(268) - jvs(61) * jvs(257) - jvs(133) * jvs(258) - jvs(158) * jvs(261) - jvs(169) * jvs(262)&
+ - jvs(190) * jvs(263) - jvs(215) * jvs(264) - jvs(239) * jvs(265) - jvs(253) * jvs(266)
+ jvs(269) = jvs(269) - jvs(134) * jvs(258) - jvs(191) * jvs(263) - jvs(216) * jvs(264) - jvs(240) * jvs(265)&
+ - jvs(254) * jvs(266)
+! i = 31
+ jvs(270) = (jvs(270)) / jvs(21)
+ jvs(271) = (jvs(271)) / jvs(30)
+ jvs(272) = (jvs(272)) / jvs(40)
+ a = 0.0; a = a - jvs(22) * jvs(270)
+ jvs(273) = (jvs(273) + a) / jvs(51)
+ jvs(274) = (jvs(274)) / jvs(91)
+ a = 0.0; a = a - jvs(92) * jvs(274)
+ jvs(275) = (jvs(275) + a) / jvs(107)
+ a = 0.0; a = a - jvs(23) * jvs(270) - jvs(52) * jvs(273) - jvs(93) * jvs(274)
+ jvs(276) = (jvs(276) + a) / jvs(114)
+ a = 0.0; a = a - jvs(24) * jvs(270) - jvs(94) * jvs(274) - jvs(115) * jvs(276)
+ jvs(277) = (jvs(277) + a) / jvs(135)
+ a = 0.0; a = a - jvs(25) * jvs(270) - jvs(95) * jvs(274) - jvs(116) * jvs(276)
+ jvs(278) = (jvs(278) + a) / jvs(141)
+ a = 0.0; a = a - jvs(96) * jvs(274)
+ jvs(279) = (jvs(279) + a) / jvs(152)
+ a = 0.0; a = a - jvs(97) * jvs(274) - jvs(108) * jvs(275) - jvs(117) * jvs(276) - jvs(136) * jvs(277)&
+ - jvs(142) * jvs(278) - jvs(153) * jvs(279)
+ jvs(280) = (jvs(280) + a) / jvs(163)
+ a = 0.0; a = a - jvs(31) * jvs(271) - jvs(53) * jvs(273) - jvs(98) * jvs(274) - jvs(118) * jvs(276)&
+ - jvs(154) * jvs(279) - jvs(164) * jvs(280)
+ jvs(281) = (jvs(281) + a) / jvs(185)
+ a = 0.0; a = a - jvs(26) * jvs(270) - jvs(32) * jvs(271) - jvs(41) * jvs(272) - jvs(54) * jvs(273)&
+ - jvs(99) * jvs(274) - jvs(109) * jvs(275) - jvs(119) * jvs(276) - jvs(137) * jvs(277) - jvs(143) * jvs(278)&
+ - jvs(155) * jvs(279) - jvs(165) * jvs(280) - jvs(186) * jvs(281)
+ jvs(282) = (jvs(282) + a) / jvs(211)
+ a = 0.0; a = a - jvs(100) * jvs(274) - jvs(166) * jvs(280) - jvs(187) * jvs(281) - jvs(212) * jvs(282)
+ jvs(283) = (jvs(283) + a) / jvs(236)
+ a = 0.0; a = a - jvs(27) * jvs(270) - jvs(101) * jvs(274) - jvs(120) * jvs(276) - jvs(138) * jvs(277)&
+ - jvs(144) * jvs(278) - jvs(156) * jvs(279) - jvs(167) * jvs(280) - jvs(188) * jvs(281) - jvs(213) * jvs(282)&
+ - jvs(237) * jvs(283)
+ jvs(284) = (jvs(284) + a) / jvs(251)
+ a = 0.0; a = a - jvs(28) * jvs(270) - jvs(102) * jvs(274) - jvs(110) * jvs(275) - jvs(121) * jvs(276)&
+ - jvs(139) * jvs(277) - jvs(145) * jvs(278) - jvs(157) * jvs(279) - jvs(168) * jvs(280) - jvs(189) * jvs(281)&
+ - jvs(214) * jvs(282) - jvs(238) * jvs(283) - jvs(252) * jvs(284)
+ jvs(285) = (jvs(285) + a) / jvs(267)
+ jvs(286) = jvs(286) - jvs(29) * jvs(270) - jvs(33) * jvs(271) - jvs(42) * jvs(272) - jvs(103) * jvs(274)&
+ - jvs(111) * jvs(275) - jvs(158) * jvs(279) - jvs(169) * jvs(280) - jvs(190) * jvs(281) - jvs(215) * jvs(282)&
+ - jvs(239) * jvs(283) - jvs(253) * jvs(284) - jvs(268) * jvs(285)
+ jvs(287) = jvs(287) - jvs(104) * jvs(274) - jvs(191) * jvs(281) - jvs(216) * jvs(282) - jvs(240) * jvs(283)&
+ - jvs(254) * jvs(284) - jvs(269) * jvs(285)
+! i = 32
+ jvs(288) = (jvs(288)) / jvs(6)
+ jvs(289) = (jvs(289)) / jvs(63)
+ a = 0.0; a = a - jvs(64) * jvs(289)
+ jvs(290) = (jvs(290) + a) / jvs(107)
+ a = 0.0; a = a - jvs(65) * jvs(289)
+ jvs(291) = (jvs(291) + a) / jvs(135)
+ jvs(292) = (jvs(292)) / jvs(152)
+ a = 0.0; a = a - jvs(66) * jvs(289) - jvs(108) * jvs(290) - jvs(136) * jvs(291) - jvs(153) * jvs(292)
+ jvs(293) = (jvs(293) + a) / jvs(163)
+ a = 0.0; a = a - jvs(7) * jvs(288) - jvs(154) * jvs(292) - jvs(164) * jvs(293)
+ jvs(294) = (jvs(294) + a) / jvs(185)
+ a = 0.0; a = a - jvs(67) * jvs(289) - jvs(109) * jvs(290) - jvs(137) * jvs(291) - jvs(155) * jvs(292)&
+ - jvs(165) * jvs(293) - jvs(186) * jvs(294)
+ jvs(295) = (jvs(295) + a) / jvs(211)
+ a = 0.0; a = a - jvs(166) * jvs(293) - jvs(187) * jvs(294) - jvs(212) * jvs(295)
+ jvs(296) = (jvs(296) + a) / jvs(236)
+ a = 0.0; a = a - jvs(138) * jvs(291) - jvs(156) * jvs(292) - jvs(167) * jvs(293) - jvs(188) * jvs(294)&
+ - jvs(213) * jvs(295) - jvs(237) * jvs(296)
+ jvs(297) = (jvs(297) + a) / jvs(251)
+ a = 0.0; a = a - jvs(110) * jvs(290) - jvs(139) * jvs(291) - jvs(157) * jvs(292) - jvs(168) * jvs(293)&
+ - jvs(189) * jvs(294) - jvs(214) * jvs(295) - jvs(238) * jvs(296) - jvs(252) * jvs(297)
+ jvs(298) = (jvs(298) + a) / jvs(267)
+ a = 0.0; a = a - jvs(111) * jvs(290) - jvs(158) * jvs(292) - jvs(169) * jvs(293) - jvs(190) * jvs(294)&
+ - jvs(215) * jvs(295) - jvs(239) * jvs(296) - jvs(253) * jvs(297) - jvs(268) * jvs(298)
+ jvs(299) = (jvs(299) + a) / jvs(286)
+ jvs(300) = jvs(300) - jvs(8) * jvs(288) - jvs(191) * jvs(294) - jvs(216) * jvs(295) - jvs(240) * jvs(296)&
+ - jvs(254) * jvs(297) - jvs(269) * jvs(298) - jvs(287) * jvs(299)
+ RETURN
+
+ END SUBROUTINE kppdecomp
+
+SUBROUTINE chem_gasphase_integrate (time_step_len, conc, tempi, qvapi, fakti, photo, ierrf, xnacc, xnrej, istatus, l_debug, pe, &
+ icntrl_i, rcntrl_i)
+
+ IMPLICIT NONE
+
+ REAL(dp), INTENT(IN) :: time_step_len
+ REAL(dp), DIMENSION(:, :), INTENT(INOUT) :: conc
+ REAL(dp), DIMENSION(:, :), INTENT(IN) :: photo
+ REAL(dp), DIMENSION(:), INTENT(IN) :: tempi
+ REAL(dp), DIMENSION(:), INTENT(IN) :: qvapi
+ REAL(dp), DIMENSION(:), INTENT(IN) :: fakti
+ INTEGER, INTENT(OUT), OPTIONAL :: ierrf(:)
+ INTEGER, INTENT(OUT), OPTIONAL :: xnacc(:)
+ INTEGER, INTENT(OUT), OPTIONAL :: xnrej(:)
+ INTEGER, INTENT(INOUT), OPTIONAL :: istatus(:)
+ INTEGER, INTENT(IN), OPTIONAL :: pe
+ LOGICAL, INTENT(IN), OPTIONAL :: l_debug
+ INTEGER, DIMENSION(nkppctrl), INTENT(IN), OPTIONAL :: icntrl_i
+ REAL(dp), DIMENSION(nkppctrl), INTENT(IN), OPTIONAL :: rcntrl_i
+
+ INTEGER :: k ! loop variable
+ REAL(dp) :: dt
+ INTEGER, DIMENSION(20) :: istatus_u
+ INTEGER :: ierr_u
+ INTEGER :: istatf
+ INTEGER :: vl_dim_lo
+
+
+ IF (PRESENT (istatus)) istatus = 0
+ IF (PRESENT (icntrl_i)) icntrl = icntrl_i
+ IF (PRESENT (rcntrl_i)) rcntrl = rcntrl_i
+
+ vl_glo = size(tempi, 1)
+
+ vl_dim_lo = vl_dim
+ DO k=1, vl_glo, vl_dim_lo
+ is = k
+ ie = min(k+ vl_dim_lo-1, vl_glo)
+ vl = ie-is+ 1
+
+ c(:) = conc(is, :)
+
+ temp = tempi(is)
+
+ qvap = qvapi(is)
+
+ fakt = fakti(is)
+
+ CALL initialize
+
+ phot(:) = photo(is, :)
+
+ CALL update_rconst
+
+ dt = time_step_len
+
+ ! integrate from t=0 to t=dt
+ CALL integrate(0._dp, dt, icntrl, rcntrl, istatus_u = istatus_u, ierr_u=ierr_u)
+
+
+ IF (PRESENT(l_debug) .AND. PRESENT(pe)) THEN
+ IF (l_debug) CALL error_output(conc(is, :), ierr_u, pe)
+ ENDIF
+
+ conc(is, :) = c(:)
+
+ ! RETURN diagnostic information
+
+ IF (PRESENT(ierrf)) ierrf(is) = ierr_u
+ IF (PRESENT(xnacc)) xnacc(is) = istatus_u(4)
+ IF (PRESENT(xnrej)) xnrej(is) = istatus_u(5)
+
+ IF (PRESENT (istatus)) THEN
+ istatus(1:8) = istatus(1:8) + istatus_u(1:8)
+ ENDIF
+
+ END DO
+
+
+! Deallocate input arrays
+
+
+ data_loaded = .FALSE.
+
+ RETURN
+END SUBROUTINE chem_gasphase_integrate
+
+END MODULE chem_gasphase_mod
+
Index: /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_cbm4/chem_gasphase_mod.kpp
===================================================================
--- /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_cbm4/chem_gasphase_mod.kpp (revision 3698)
+++ /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_cbm4/chem_gasphase_mod.kpp (revision 3698)
@@ -0,0 +1,48 @@
+//chem_gasphase_mod.kpp
+//
+//Former revisions
+//----------------
+// $Id: chem_gasphase_mod.kpp 2459 2017-09-13 14:10:33Z forkel $
+// initial revision branch chemistry rev 3090
+//
+#include cbm4.spc
+#include cbm4.eqn
+#INTEGRATOR rosenbrock
+#LANGUAGE Fortran90
+#HESSIAN on
+#STOICMAT on
+//
+// *******************************************************************************************
+// *** adapt the lines below occurding to the photolysis reactions of your mechanism *
+// *** adapt the number of photolysis frequencies NPHO *
+// *** adapt/extend the indices in the INTEGER, PARAMETER,PUBLIC statement below *
+// *** adapt/extend PHOT_NAMES: Note that the order of PHOT_NAMES and the indices must match *
+// *******************************************************************************************
+//
+#INLINE F90_DATA
+ ! INLINE F90_DATA: Declaration of global variables for photolysis
+ ! REAL(kind=dp) :: phot(nphot) must eventually be moved to GLOBAL later for vector version
+ INTEGER, PARAMETER :: nphot = 9
+ ! phot Photolysis frequencies
+ REAL(kind=dp) :: phot(nphot)
+
+ INTEGER, PARAMETER,PUBLIC :: j_no2 = 1
+ INTEGER, PARAMETER,PUBLIC :: j_o33p = 2
+ INTEGER, PARAMETER,PUBLIC :: j_o31d = 3
+ INTEGER, PARAMETER,PUBLIC :: j_no3o = 4
+ INTEGER, PARAMETER,PUBLIC :: j_no3o2 = 5
+ INTEGER, PARAMETER,PUBLIC :: j_hono = 6
+ INTEGER, PARAMETER,PUBLIC :: j_h2o2 = 7
+ INTEGER, PARAMETER,PUBLIC :: j_ch2or = 8
+ INTEGER, PARAMETER,PUBLIC :: j_ch2om = 9
+
+ CHARACTER(LEN=15), PARAMETER, DIMENSION(NPHOT) :: phot_names = (/ &
+ 'J_NO2 ','J_O33P ','J_O31D ', &
+ 'J_NO3O ','J_NO3O2 ','J_HONO ', &
+ 'J_H2O2 ','J_HCHO_B ','J_HCHO_A '/)
+#ENDINLINE
+
+#INLINE F90_INIT
+ fix(indf_h2o) = qvap
+#ENDINLINE
+
Index: /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_passive1/chem_gasphase_mod.f90
===================================================================
--- /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_passive1/chem_gasphase_mod.f90 (revision 3698)
+++ /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_passive1/chem_gasphase_mod.f90 (revision 3698)
@@ -0,0 +1,2302 @@
+MODULE chem_gasphase_mod
+
+! Mechanism: passive1
+!
+!------------------------------------------------------------------------------!
+!
+! ******Module chem_gasphase_mod is automatically generated by kpp4palm ******
+!
+! *********Please do NOT change this Code,it will be ovewritten *********
+!
+!------------------------------------------------------------------------------!
+! This file was created by KPP (http://people.cs.vt.edu/asandu/Software/Kpp/)
+! and kpp4palm (created by Klaus Ketelsen). kpp4palm is an adapted version
+! of KP4 (Jöckel,P.,Kerkweg,A.,Pozzer,A.,Sander,R.,Tost,H.,Riede,
+! H.,Baumgaertner,A.,Gromov,S.,and Kern,B.,2010: Development cycle 2 of
+! the Modular Earth Submodel System (MESSy2),Geosci. Model Dev.,3,717-752,
+! https://doi.org/10.5194/gmd-3-717-2010). KP4 is part of the Modular Earth
+! Submodel System (MESSy),which is is available under the GNU General Public
+! License (GPL).
+!
+! KPP is free software; you can redistribute it and/or modify it under the terms
+! of the General Public Licence as published by the Free Software Foundation;
+! 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 Licence for more details.
+!
+!------------------------------------------------------------------------------!
+! This file is part of the PALM model system.
+!
+! PALM is free software: you can redistribute it and/or modify it under the
+! terms of the GNU General Public License as published by the Free Software
+! Foundation,either version 3 of the License,or (at your option) any later
+! version.
+!
+! PALM 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
+! PALM. If not,see .
+!
+! Copyright 1997-2019 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+!
+! MODULE HEADER TEMPLATE
+!
+! Initial version (Nov. 2016,ketelsen),for later modifications of module_header
+! see comments in kpp4palm/src/create_kpp_module.C
+
+! Set kpp Double Precision to PALM Default Precision
+
+ USE kinds, ONLY: dp=>wp
+
+ USE pegrid, ONLY: myid, threads_per_task
+
+ IMPLICIT NONE
+ PRIVATE
+ !SAVE ! note: occurs again in automatically generated code ...
+
+! PUBLIC :: IERR_NAMES
+
+! PUBLIC :: SPC_NAMES,EQN_NAMES,EQN_TAGS,REQ_HET,REQ_AEROSOL,REQ_PHOTRAT &
+! ,REQ_MCFCT,IP_MAX,jname
+
+ PUBLIC :: eqn_names, phot_names, spc_names
+ PUBLIC :: nmaxfixsteps
+ PUBLIC :: atol, rtol
+ PUBLIC :: nspec, nreact
+ PUBLIC :: temp
+ PUBLIC :: qvap
+ PUBLIC :: fakt
+ PUBLIC :: phot
+ PUBLIC :: rconst
+ PUBLIC :: nvar
+ PUBLIC :: nphot
+ PUBLIC :: vl_dim ! PUBLIC to ebable other MODULEs to distiguish between scalar and vec
+
+ PUBLIC :: initialize, integrate, update_rconst
+ PUBLIC :: chem_gasphase_integrate
+ PUBLIC :: initialize_kpp_ctrl
+
+! END OF MODULE HEADER TEMPLATE
+
+! Variables used for vector mode
+
+ LOGICAL, PARAMETER :: l_vector = .FALSE.
+ INTEGER, PARAMETER :: i_lu_di = 2
+ INTEGER, PARAMETER :: vl_dim = 1
+ INTEGER :: vl
+
+ INTEGER :: vl_glo
+ INTEGER :: is, ie
+
+
+ INTEGER, DIMENSION(vl_dim) :: kacc, krej
+ INTEGER, DIMENSION(vl_dim) :: ierrv
+ LOGICAL :: data_loaded = .FALSE.
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Parameter Module File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Parameters.f90
+! Time : Fri Nov 30 13:52:18 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! NSPEC - Number of chemical species
+ INTEGER, PARAMETER :: nspec = 1
+! NVAR - Number of Variable species
+ INTEGER, PARAMETER :: nvar = 1
+! NVARACT - Number of Active species
+ INTEGER, PARAMETER :: nvaract = 1
+! NFIX - Number of Fixed species
+ INTEGER, PARAMETER :: nfix = 1
+! NREACT - Number of reactions
+ INTEGER, PARAMETER :: nreact = 1
+! NVARST - Starting of variables in conc. vect.
+ INTEGER, PARAMETER :: nvarst = 1
+! NFIXST - Starting of fixed in conc. vect.
+ INTEGER, PARAMETER :: nfixst = 2
+! NONZERO - Number of nonzero entries in Jacobian
+ INTEGER, PARAMETER :: nonzero = 1
+! LU_NONZERO - Number of nonzero entries in LU factoriz. of Jacobian
+ INTEGER, PARAMETER :: lu_nonzero = 1
+! CNVAR - (NVAR+1) Number of elements in compressed row format
+ INTEGER, PARAMETER :: cnvar = 2
+! CNEQN - (NREACT+1) Number stoicm elements in compressed col format
+ INTEGER, PARAMETER :: cneqn = 2
+! NHESS - Length of Sparse Hessian
+ INTEGER, PARAMETER :: nhess = 1
+! NMASS - Number of atoms to check mass balance
+ INTEGER, PARAMETER :: nmass = 1
+
+! Index declaration for variable species in C and VAR
+! VAR(ind_spc) = C(ind_spc)
+
+ INTEGER, PARAMETER, PUBLIC :: ind_pm10 = 1
+
+! Index declaration for fixed species in C
+! C(ind_spc)
+
+
+! Index declaration for fixed species in FIX
+! FIX(indf_spc) = C(ind_spc) = C(NVAR+indf_spc)
+
+
+! NJVRP - Length of sparse Jacobian JVRP
+ INTEGER, PARAMETER :: njvrp = 1
+
+! NSTOICM - Length of Sparse Stoichiometric Matrix
+ INTEGER, PARAMETER :: nstoicm = 1
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Global Data Module File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Global.f90
+! Time : Fri Nov 30 13:52:18 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! Declaration of global variables
+
+! C - Concentration of all species
+ REAL(kind=dp):: c(nspec)
+! VAR - Concentrations of variable species (global)
+ REAL(kind=dp):: var(nvar)
+! FIX - Concentrations of fixed species (global)
+ REAL(kind=dp):: fix(nfix)
+! VAR,FIX are chunks of array C
+ EQUIVALENCE( c(1), var(1))
+! RCONST - Rate constants (global)
+ REAL(kind=dp):: rconst(nreact)
+! TIME - Current integration time
+ REAL(kind=dp):: time
+! TEMP - Temperature
+ REAL(kind=dp):: temp
+! TSTART - Integration start time
+ REAL(kind=dp):: tstart
+! ATOL - Absolute tolerance
+ REAL(kind=dp):: atol(nvar)
+! RTOL - Relative tolerance
+ REAL(kind=dp):: rtol(nvar)
+! STEPMIN - Lower bound for integration step
+ REAL(kind=dp):: stepmin
+! CFACTOR - Conversion factor for concentration units
+ REAL(kind=dp):: cfactor
+
+! INLINED global variable declarations
+
+! QVAP - Water vapor
+ REAL(kind=dp):: qvap
+! FAKT - Conversion factor
+ REAL(kind=dp):: fakt
+
+
+! INLINED global variable declarations
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Sparse Jacobian Data Structures File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_JacobianSP.f90
+! Time : Fri Nov 30 13:52:18 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! Sparse Jacobian Data
+
+
+ INTEGER, PARAMETER, DIMENSION(1):: lu_irow = (/ &
+ 1 /)
+
+ INTEGER, PARAMETER, DIMENSION(1):: lu_icol = (/ &
+ 1 /)
+
+ INTEGER, PARAMETER, DIMENSION(2):: lu_crow = (/ &
+ 1, 2 /)
+
+ INTEGER, PARAMETER, DIMENSION(2):: lu_diag = (/ &
+ 1, 2 /)
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Utility Data Module File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Monitor.f90
+! Time : Fri Nov 30 13:52:18 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+ CHARACTER(len=15), PARAMETER, DIMENSION(1):: spc_names = (/ &
+ 'PM10 ' /)
+
+ CHARACTER(len=100), PARAMETER, DIMENSION(1):: eqn_names = (/ &
+ 'PM10 --> PM10 ' /)
+
+! INLINED global variables
+
+ ! inline f90_data: declaration of global variables for photolysis
+ ! REAL(kind=dp):: phot(nphot)must eventually be moved to global later for
+ INTEGER, PARAMETER :: nphot = 1
+ ! phot photolysis frequencies
+ REAL(kind=dp):: phot(nphot)
+
+ INTEGER, PARAMETER, PUBLIC :: j_no2 = 1
+
+ CHARACTER(len=15), PARAMETER, DIMENSION(nphot):: phot_names = (/ &
+ 'J_NO2 '/)
+
+! End INLINED global variables
+
+
+! Automatic generated PUBLIC Statements for ip_ and ihs_ variables
+
+! Automatic generated PUBLIC Statements for ip_ and ihs_ variables
+
+! Automatic generated PUBLIC Statements for ip_ and ihs_ variables
+
+! Automatic generated PUBLIC Statements for ip_ and ihs_ variables
+
+
+! variable definations from individual module headers
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Initialization File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Initialize.f90
+! Time : Fri Nov 30 13:52:18 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Numerical Integrator (Time-Stepping) File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Integrator.f90
+! Time : Fri Nov 30 13:52:18 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! INTEGRATE - Integrator routine
+! Arguments :
+! TIN - Start Time for Integration
+! TOUT - End Time for Integration
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!
+! 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 !
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!
+
+
+ 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
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Linear Algebra Data and Routines File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_LinearAlgebra.f90
+! Time : Fri Nov 30 13:52:18 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! The ODE Jacobian of Chemical Model File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Jacobian.f90
+! Time : Fri Nov 30 13:52:18 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! The ODE Function of Chemical Model File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Function.f90
+! Time : Fri Nov 30 13:52:18 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+! A - Rate for each equation
+ REAL(kind=dp):: a(nreact)
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! The Reaction Rates File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Rates.f90
+! Time : Fri Nov 30 13:52:18 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Auxiliary Routines File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Util.f90
+! Time : Fri Nov 30 13:52:18 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+ ! header MODULE initialize_kpp_ctrl_template
+
+ ! notes:
+ ! - l_vector is automatically defined by kp4
+ ! - vl_dim is automatically defined by kp4
+ ! - i_lu_di is automatically defined by kp4
+ ! - wanted is automatically defined by xmecca
+ ! - icntrl rcntrl are automatically defined by kpp
+ ! - "USE messy_main_tools" is in MODULE_header of messy_mecca_kpp.f90
+ ! - SAVE will be automatically added by kp4
+
+ !SAVE
+
+ ! for fixed time step control
+ ! ... max. number of fixed time steps (sum must be 1)
+ INTEGER, PARAMETER :: nmaxfixsteps = 50
+ ! ... switch for fixed time stepping
+ LOGICAL, PUBLIC :: l_fixed_step = .FALSE.
+ INTEGER, PUBLIC :: nfsteps = 1
+ ! ... number of kpp control PARAMETERs
+ INTEGER, PARAMETER, PUBLIC :: nkppctrl = 20
+ !
+ INTEGER, DIMENSION(nkppctrl), PUBLIC :: icntrl = 0
+ REAL(dp), DIMENSION(nkppctrl), PUBLIC :: rcntrl = 0.0_dp
+ REAL(dp), DIMENSION(nmaxfixsteps), PUBLIC :: t_steps = 0.0_dp
+
+ ! END header MODULE initialize_kpp_ctrl_template
+
+
+! Interface Block
+
+ INTERFACE initialize
+ MODULE PROCEDURE initialize
+ END INTERFACE initialize
+
+ INTERFACE integrate
+ MODULE PROCEDURE integrate
+ END INTERFACE integrate
+
+ INTERFACE fun
+ MODULE PROCEDURE fun
+ END INTERFACE fun
+
+ INTERFACE kppsolve
+ MODULE PROCEDURE kppsolve
+ END INTERFACE kppsolve
+
+ INTERFACE jac_sp
+ MODULE PROCEDURE jac_sp
+ END INTERFACE jac_sp
+
+ INTERFACE k_arr
+ MODULE PROCEDURE k_arr
+ END INTERFACE k_arr
+
+ INTERFACE update_rconst
+ MODULE PROCEDURE update_rconst
+ END INTERFACE update_rconst
+
+ INTERFACE arr2
+ MODULE PROCEDURE arr2
+ END INTERFACE arr2
+
+ INTERFACE initialize_kpp_ctrl
+ MODULE PROCEDURE initialize_kpp_ctrl
+ END INTERFACE initialize_kpp_ctrl
+
+ INTERFACE error_output
+ MODULE PROCEDURE error_output
+ END INTERFACE error_output
+
+ INTERFACE wscal
+ MODULE PROCEDURE wscal
+ END INTERFACE wscal
+
+!INTERFACE not working INTERFACE waxpy
+!INTERFACE not working MODULE PROCEDURE waxpy
+!INTERFACE not working END INTERFACE waxpy
+
+ INTERFACE rosenbrock
+ MODULE PROCEDURE rosenbrock
+ END INTERFACE rosenbrock
+
+ INTERFACE funtemplate
+ MODULE PROCEDURE funtemplate
+ END INTERFACE funtemplate
+
+ INTERFACE jactemplate
+ MODULE PROCEDURE jactemplate
+ END INTERFACE jactemplate
+
+ INTERFACE kppdecomp
+ MODULE PROCEDURE kppdecomp
+ END INTERFACE kppdecomp
+
+ INTERFACE chem_gasphase_integrate
+ MODULE PROCEDURE chem_gasphase_integrate
+ END INTERFACE chem_gasphase_integrate
+
+
+ CONTAINS
+
+SUBROUTINE initialize()
+
+
+ INTEGER :: j, k
+
+ INTEGER :: i
+ REAL(kind=dp):: x
+ k = is
+ cfactor = 1.000000e+00_dp
+
+ x = (0.) * cfactor
+ DO i = 1 , nvar
+ ENDDO
+
+ x = (0.) * cfactor
+ DO i = 1 , nfix
+ fix(i) = x
+ ENDDO
+
+! constant rate coefficients
+! END constant rate coefficients
+
+! INLINED initializations
+
+! End INLINED initializations
+
+
+END SUBROUTINE initialize
+
+SUBROUTINE integrate( tin, tout, &
+ icntrl_u, rcntrl_u, istatus_u, rstatus_u, ierr_u)
+
+
+ REAL(kind=dp), INTENT(IN):: tin ! start time
+ REAL(kind=dp), INTENT(IN):: tout ! END time
+ ! OPTIONAL input PARAMETERs and statistics
+ INTEGER, INTENT(IN), OPTIONAL :: icntrl_u(20)
+ REAL(kind=dp), INTENT(IN), OPTIONAL :: rcntrl_u(20)
+ INTEGER, INTENT(OUT), OPTIONAL :: istatus_u(20)
+ REAL(kind=dp), INTENT(OUT), OPTIONAL :: rstatus_u(20)
+ INTEGER, INTENT(OUT), OPTIONAL :: ierr_u
+
+ REAL(kind=dp):: 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(:)
+ ENDIF
+ IF (PRESENT(rcntrl_u))THEN
+ WHERE(rcntrl_u(:)> 0)rcntrl(:) = rcntrl_u(:)
+ ENDIF
+
+
+ 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 fun(v, f, rct, vdot)
+
+! V - Concentrations of variable species (local)
+ REAL(kind=dp):: v(nvar)
+! F - Concentrations of fixed species (local)
+ REAL(kind=dp):: f(nfix)
+! RCT - Rate constants (local)
+ REAL(kind=dp):: rct(nreact)
+! Vdot - Time derivative of variable species concentrations
+ REAL(kind=dp):: vdot(nvar)
+
+
+! Computation of equation rates
+
+! Aggregate function
+ vdot(1) = 0
+
+END SUBROUTINE fun
+
+SUBROUTINE kppsolve(jvs, x)
+
+! JVS - sparse Jacobian of variables
+ REAL(kind=dp):: jvs(lu_nonzero)
+! X - Vector for variables
+ REAL(kind=dp):: x(nvar)
+
+ x(1) = x(1) / jvs(1)
+
+END SUBROUTINE kppsolve
+
+SUBROUTINE jac_sp(v, f, rct, jvs)
+
+! V - Concentrations of variable species (local)
+ REAL(kind=dp):: v(nvar)
+! F - Concentrations of fixed species (local)
+ REAL(kind=dp):: f(nfix)
+! RCT - Rate constants (local)
+ REAL(kind=dp):: rct(nreact)
+! JVS - sparse Jacobian of variables
+ REAL(kind=dp):: jvs(lu_nonzero)
+
+
+! Local variables
+! B - Temporary array
+ REAL(kind=dp):: b(1)
+
+! B(1) = dA(1)/dV(1)
+ b(1) = rct(1)
+
+! Construct the Jacobian terms from B's
+! JVS(1) = Jac_FULL(1,1)
+ jvs(1) = 0
+
+END SUBROUTINE jac_sp
+
+ elemental REAL(kind=dp)FUNCTION k_arr (k_298, tdep, temp)
+ ! arrhenius FUNCTION
+
+ REAL, INTENT(IN):: k_298 ! k at t = 298.15k
+ REAL, INTENT(IN):: tdep ! temperature dependence
+ REAL(kind=dp), INTENT(IN):: temp ! temperature
+
+ intrinsic exp
+
+ k_arr = k_298 * exp(tdep* (1._dp/temp- 3.3540e-3_dp))! 1/298.15=3.3540e-3
+
+ END FUNCTION k_arr
+
+SUBROUTINE update_rconst()
+ INTEGER :: k
+
+ k = is
+
+! Begin INLINED RCONST
+
+
+! End INLINED RCONST
+
+ rconst(1) = (1.0_dp)
+
+END SUBROUTINE update_rconst
+
+! END FUNCTION ARR2
+REAL(kind=dp)FUNCTION arr2( a0, b0, temp)
+ REAL(kind=dp):: temp
+ REAL(kind=dp):: a0, b0
+ arr2 = a0 * exp( - b0 / temp)
+END FUNCTION arr2
+
+SUBROUTINE initialize_kpp_ctrl(status)
+
+
+ ! i/o
+ INTEGER, INTENT(OUT):: status
+
+ ! local
+ REAL(dp):: tsum
+ INTEGER :: i
+
+ ! check fixed time steps
+ tsum = 0.0_dp
+ DO i=1, nmaxfixsteps
+ IF (t_steps(i)< tiny(0.0_dp))exit
+ tsum = tsum + t_steps(i)
+ ENDDO
+
+ nfsteps = i- 1
+
+ l_fixed_step = (nfsteps > 0).and.((tsum - 1.0)< tiny(0.0_dp))
+
+ IF (l_vector)THEN
+ WRITE(*,*) ' MODE : VECTOR (LENGTH=',VL_DIM,')'
+ ELSE
+ WRITE(*,*) ' MODE : SCALAR'
+ ENDIF
+ !
+ WRITE(*,*) ' DE-INDEXING MODE :',I_LU_DI
+ !
+ WRITE(*,*) ' ICNTRL : ',icntrl
+ WRITE(*,*) ' RCNTRL : ',rcntrl
+ !
+ ! note: this is ONLY meaningful for vectorized (kp4)rosenbrock- methods
+ IF (l_vector)THEN
+ IF (l_fixed_step)THEN
+ WRITE(*,*) ' TIME STEPS : FIXED (',t_steps(1:nfsteps),')'
+ ELSE
+ WRITE(*,*) ' TIME STEPS : AUTOMATIC'
+ ENDIF
+ ELSE
+ WRITE(*,*) ' TIME STEPS : AUTOMATIC '//&
+ &'(t_steps (CTRL_KPP) ignored in SCALAR MODE)'
+ ENDIF
+ ! mz_pj_20070531-
+
+ status = 0
+
+
+END SUBROUTINE initialize_kpp_ctrl
+
+SUBROUTINE error_output(c, ierr, pe)
+
+
+ INTEGER, INTENT(IN):: ierr
+ INTEGER, INTENT(IN):: pe
+ REAL(dp), DIMENSION(:), INTENT(IN):: c
+
+ write(6,*) 'ERROR in chem_gasphase_mod ',ierr,C(1)
+
+
+END SUBROUTINE error_output
+
+ SUBROUTINE wscal(n, alpha, x, incx)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+! constant times a vector: x(1:N) <- Alpha*x(1:N)
+! only for incX=incY=1
+! after BLAS
+! replace this by the function from the optimized BLAS implementation:
+! CALL SSCAL(N,Alpha,X,1) or CALL DSCAL(N,Alpha,X,1)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ INTEGER :: i, incx, m, mp1, n
+ REAL(kind=dp) :: x(n), alpha
+ REAL(kind=dp), PARAMETER :: zero=0.0_dp, one=1.0_dp
+
+ IF (alpha .eq. one)RETURN
+ IF (n .le. 0)RETURN
+
+ m = mod(n, 5)
+ IF ( m .ne. 0)THEN
+ IF (alpha .eq. (- one))THEN
+ DO i = 1, m
+ x(i) = - x(i)
+ ENDDO
+ ELSEIF (alpha .eq. zero)THEN
+ DO i = 1, m
+ x(i) = zero
+ ENDDO
+ ELSE
+ DO i = 1, m
+ x(i) = alpha* x(i)
+ ENDDO
+ ENDIF
+ IF ( n .lt. 5)RETURN
+ ENDIF
+ mp1 = m + 1
+ IF (alpha .eq. (- one))THEN
+ DO i = mp1, n, 5
+ x(i) = - x(i)
+ x(i + 1) = - x(i + 1)
+ x(i + 2) = - x(i + 2)
+ x(i + 3) = - x(i + 3)
+ x(i + 4) = - x(i + 4)
+ ENDDO
+ ELSEIF (alpha .eq. zero)THEN
+ DO i = mp1, n, 5
+ x(i) = zero
+ x(i + 1) = zero
+ x(i + 2) = zero
+ x(i + 3) = zero
+ x(i + 4) = zero
+ ENDDO
+ ELSE
+ DO i = mp1, n, 5
+ x(i) = alpha* x(i)
+ x(i + 1) = alpha* x(i + 1)
+ x(i + 2) = alpha* x(i + 2)
+ x(i + 3) = alpha* x(i + 3)
+ x(i + 4) = alpha* x(i + 4)
+ ENDDO
+ ENDIF
+
+ END SUBROUTINE wscal
+
+ SUBROUTINE waxpy(n, alpha, x, incx, y, incy)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+! constant times a vector plus a vector: y <- y + Alpha*x
+! only for incX=incY=1
+! after BLAS
+! replace this by the function from the optimized BLAS implementation:
+! CALL SAXPY(N,Alpha,X,1,Y,1) or CALL DAXPY(N,Alpha,X,1,Y,1)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ INTEGER :: i, incx, incy, m, mp1, n
+ REAL(kind=dp):: x(n), y(n), alpha
+ REAL(kind=dp), PARAMETER :: zero = 0.0_dp
+
+ IF (alpha .eq. zero)RETURN
+ IF (n .le. 0)RETURN
+
+ m = mod(n, 4)
+ IF ( m .ne. 0)THEN
+ DO i = 1, m
+ y(i) = y(i) + alpha* x(i)
+ ENDDO
+ IF ( n .lt. 4)RETURN
+ ENDIF
+ mp1 = m + 1
+ DO i = mp1, n, 4
+ y(i) = y(i) + alpha* x(i)
+ y(i + 1) = y(i + 1) + alpha* x(i + 1)
+ y(i + 2) = y(i + 2) + alpha* x(i + 2)
+ y(i + 3) = y(i + 3) + alpha* x(i + 3)
+ ENDDO
+
+ END SUBROUTINE waxpy
+
+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
+!
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+!~~~> arguments
+ INTEGER, INTENT(IN) :: n
+ REAL(kind=dp), INTENT(INOUT):: y(n)
+ REAL(kind=dp), INTENT(IN) :: tstart, tend
+ REAL(kind=dp), INTENT(IN) :: abstol(n), reltol(n)
+ INTEGER, INTENT(IN) :: icntrl(20)
+ REAL(kind=dp), INTENT(IN) :: rcntrl(20)
+ INTEGER, INTENT(INOUT):: istatus(20)
+ REAL(kind=dp), 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
+ REAL(kind=dp):: 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
+ REAL(kind=dp):: roundoff, facmin, facmax, facrej, facsafe
+ REAL(kind=dp):: hmin, hmax, hstart
+ REAL(kind=dp):: texit
+ INTEGER :: i, uplimtol, max_no_steps
+ LOGICAL :: autonomous, vectortol
+!~~~> PARAMETERs
+ REAL(kind=dp), PARAMETER :: zero = 0.0_dp, one = 1.0_dp
+ REAL(kind=dp), 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
+ ENDIF
+
+!~~~> 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
+ ENDIF
+
+!~~~> unit roundoff (1+ roundoff>1)
+ roundoff = epsilon(one)
+
+!~~~> 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
+ ENDIF
+!~~~> 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
+ ENDIF
+!~~~> 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
+ ENDIF
+!~~~> 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
+ ENDIF
+ 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
+ ENDIF
+!~~~> 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
+ ENDIF
+!~~~> 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
+ ENDIF
+!~~~> 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
+ ENDIF
+ ENDDO
+
+
+!~~~> 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ REAL(kind=dp), 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}
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+!~~~> input: the initial condition at tstart; output: the solution at t
+ REAL(kind=dp), INTENT(INOUT):: y(n)
+!~~~> input: integration interval
+ REAL(kind=dp), INTENT(IN):: tstart, tend
+!~~~> output: time at which the solution is RETURNed (t=tendIF success)
+ REAL(kind=dp), INTENT(OUT):: t
+!~~~> input: tolerances
+ REAL(kind=dp), INTENT(IN):: abstol(n), reltol(n)
+!~~~> input: integration PARAMETERs
+ LOGICAL, INTENT(IN):: autonomous, vectortol
+ REAL(kind=dp), INTENT(IN):: hstart, hmin, hmax
+ INTEGER, INTENT(IN):: max_no_steps
+ REAL(kind=dp), INTENT(IN):: roundoff, facmin, facmax, facrej, facsafe
+!~~~> output: error indicator
+ INTEGER, INTENT(OUT):: ierr
+! ~~~~ Local variables
+ REAL(kind=dp):: ynew(n), fcn0(n), fcn(n)
+ REAL(kind=dp):: k(n* ros_s), dfdt(n)
+#ifdef full_algebra
+ REAL(kind=dp):: jac0(n, n), ghimj(n, n)
+#else
+ REAL(kind=dp):: jac0(lu_nonzero), ghimj(lu_nonzero)
+#endif
+ REAL(kind=dp):: h, hnew, hc, hg, fac, tau
+ REAL(kind=dp):: err, yerr(n)
+ INTEGER :: pivot(n), direction, ioffset, j, istage
+ LOGICAL :: rejectlasth, rejectmoreh, singular
+!~~~> local PARAMETERs
+ REAL(kind=dp), PARAMETER :: zero = 0.0_dp, one = 1.0_dp
+ REAL(kind=dp), PARAMETER :: deltamin = 1.0e-5_dp
+!~~~> locally called FUNCTIONs
+! REAL(kind=dp) 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
+ ENDIF
+ 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
+ ENDIF
+ IF (((t+ 0.1_dp* h) == t).or.(h <= roundoff))THEN ! step size too small
+ CALL ros_errormsg(- 7, t, h, ierr)
+ RETURN
+ ENDIF
+
+!~~~> 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)
+ ENDIF
+
+!~~~> 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
+ ENDIF
+
+!~~~> 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
+ !slim: CALL wcopy(n, fcn0, 1, fcn, 1)
+ fcn(1:n) = fcn0(1:n)
+ ! istage>1 and a new FUNCTION evaluation is needed at the current istage
+ ELSEIF(ros_newf(istage))THEN
+ !slim: CALL wcopy(n, y, 1, ynew, 1)
+ ynew(1:n) = y(1:n)
+ DO j = 1, istage-1
+ CALL waxpy(n, ros_a((istage-1) * (istage-2) /2+ j), &
+ k(n* (j- 1) + 1), 1, ynew, 1)
+ ENDDO
+ tau = t + ros_alpha(istage) * direction* h
+ CALL funtemplate(tau, ynew, fcn)
+ istatus(nfun) = istatus(nfun) + 1
+ ENDIF ! IF istage == 1 ELSEIF ros_newf(istage)
+ !slim: CALL wcopy(n, fcn, 1, k(ioffset+ 1), 1)
+ k(ioffset+ 1:ioffset+ n) = fcn(1:n)
+ 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), 1, k(ioffset+ 1), 1)
+ ENDDO
+ 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), 1)
+ ENDIF
+ CALL ros_solve(ghimj, pivot, k(ioffset+ 1))
+
+ END DO stage
+
+
+!~~~> compute the new solution
+ !slim: CALL wcopy(n, y, 1, ynew, 1)
+ ynew(1:n) = y(1:n)
+ DO j=1, ros_s
+ CALL waxpy(n, ros_m(j), k(n* (j- 1) + 1), 1, ynew, 1)
+ ENDDO
+
+!~~~> compute the error estimation
+ !slim: CALL wscal(n, zero, yerr, 1)
+ yerr(1:n) = zero
+ DO j=1, ros_s
+ CALL waxpy(n, ros_e(j), k(n* (j- 1) + 1), 1, yerr, 1)
+ ENDDO
+ 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
+ !slim: CALL wcopy(n, ynew, 1, y, 1)
+ y(1:n) = ynew(1:n)
+ 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)
+ ENDIF
+ 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
+ ENDIF
+ rejectmoreh = rejectlasth
+ rejectlasth = .TRUE.
+ h = hnew
+ IF (istatus(nacc)>= 1) istatus(nrej) = istatus(nrej) + 1
+ ENDIF ! err <= 1
+
+ END DO untilaccepted
+
+ END DO timeloop
+
+!~~~> succesful exit
+ ierr = 1 !~~~> the integration was successful
+
+ END SUBROUTINE ros_integrator
+
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ REAL(kind=dp)FUNCTION ros_errornorm(y, ynew, yerr, &
+ abstol, reltol, vectortol)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> computes the "scaled norm" of the error vector yerr
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+! Input arguments
+ REAL(kind=dp), INTENT(IN):: y(n), ynew(n), &
+ yerr(n), abstol(n), reltol(n)
+ LOGICAL, INTENT(IN):: vectortol
+! Local variables
+ REAL(kind=dp):: err, scale, ymax
+ INTEGER :: i
+ REAL(kind=dp), 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
+ ENDIF
+ err = err+ (yerr(i) /scale) ** 2
+ ENDDO
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+!~~~> input arguments
+ REAL(kind=dp), INTENT(IN):: t, roundoff, y(n), fcn0(n)
+!~~~> output arguments
+ REAL(kind=dp), INTENT(OUT):: dfdt(n)
+!~~~> local variables
+ REAL(kind=dp):: delta
+ REAL(kind=dp), 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
+! --- --- --- --- --- --- --- --- --- --- --- --- ---
+
+!~~~> input arguments
+#ifdef full_algebra
+ REAL(kind=dp), INTENT(IN):: jac0(n, n)
+#else
+ REAL(kind=dp), INTENT(IN):: jac0(lu_nonzero)
+#endif
+ REAL(kind=dp), INTENT(IN):: gam
+ INTEGER, INTENT(IN):: direction
+!~~~> output arguments
+#ifdef full_algebra
+ REAL(kind=dp), INTENT(OUT):: ghimj(n, n)
+#else
+ REAL(kind=dp), INTENT(OUT):: ghimj(lu_nonzero)
+#endif
+ LOGICAL, INTENT(OUT):: singular
+ INTEGER, INTENT(OUT):: pivot(n)
+!~~~> inout arguments
+ REAL(kind=dp), INTENT(INOUT):: h ! step size is decreased when lu fails
+!~~~> local variables
+ INTEGER :: i, ising, nconsecutive
+ REAL(kind=dp):: ghinv
+ REAL(kind=dp), 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
+ !slim: CALL wcopy(n* n, jac0, 1, ghimj, 1)
+ !slim: CALL wscal(n* n, (- one), ghimj, 1)
+ ghimj = - jac0
+ ghinv = one/(direction* h* gam)
+ DO i=1, n
+ ghimj(i, i) = ghimj(i, i) + ghinv
+ ENDDO
+#else
+ !slim: CALL wcopy(lu_nonzero, jac0, 1, ghimj, 1)
+ !slim: CALL wscal(lu_nonzero, (- one), ghimj, 1)
+ ghimj(1:lu_nonzero) = - jac0(1:lu_nonzero)
+ ghinv = one/(direction* h* gam)
+ DO i=1, n
+ ghimj(lu_diag(i)) = ghimj(lu_diag(i)) + ghinv
+ ENDDO
+#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
+ ENDIF ! nconsecutive
+ ENDIF ! ising
+
+ END DO ! WHILE singular
+
+ END SUBROUTINE ros_preparematrix
+
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE ros_decomp( a, pivot, ising)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! Template for the LU decomposition
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> inout variables
+#ifdef full_algebra
+ REAL(kind=dp), INTENT(INOUT):: a(n, n)
+#else
+ REAL(kind=dp), INTENT(INOUT):: a(lu_nonzero)
+#endif
+!~~~> 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)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> input variables
+#ifdef full_algebra
+ REAL(kind=dp), INTENT(IN):: a(n, n)
+ INTEGER :: ising
+#else
+ REAL(kind=dp), INTENT(IN):: a(lu_nonzero)
+#endif
+ INTEGER, INTENT(IN):: pivot(n)
+!~~~> inout variables
+ REAL(kind=dp), INTENT(INOUT):: b(n)
+
+#ifdef full_algebra
+ CALL DGETRS( 'N',N ,1,A,N,Pivot,b,N,ISING)
+ IF (info < 0)THEN
+ print* , "error in dgetrs. ising=", ising
+ ENDIF
+#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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ 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)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+ 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)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> input variables
+ REAL(kind=dp):: t, y(nvar)
+!~~~> output variables
+ REAL(kind=dp):: ydot(nvar)
+!~~~> local variables
+ REAL(kind=dp):: told
+
+ told = time
+ time = t
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> input variables
+ REAL(kind=dp):: t, y(nvar)
+!~~~> output variables
+#ifdef full_algebra
+ REAL(kind=dp):: jv(lu_nonzero), jcb(nvar, nvar)
+#else
+ REAL(kind=dp):: jcb(lu_nonzero)
+#endif
+!~~~> local variables
+ REAL(kind=dp):: told
+#ifdef full_algebra
+ INTEGER :: i, j
+#endif
+
+ told = time
+ time = t
+#ifdef full_algebra
+ CALL jac_sp(y, fix, rconst, jv)
+ DO j=1, nvar
+ DO i=1, nvar
+ jcb(i, j) = 0.0_dp
+ ENDDO
+ ENDDO
+ DO i=1, lu_nonzero
+ jcb(lu_irow(i), lu_icol(i)) = jv(i)
+ ENDDO
+#else
+ CALL jac_sp( y, fix, rconst, jcb)
+#endif
+ time = told
+
+END SUBROUTINE jactemplate
+
+ SUBROUTINE kppdecomp( jvs, ier)
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! sparse lu factorization
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! loop expansion generated by kp4
+
+ INTEGER :: ier
+ REAL(kind=dp):: jvs(lu_nonzero), w(nvar), a
+ INTEGER :: k, kk, j, jj
+
+ a = 0.
+ ier = 0
+
+! i = 1
+ RETURN
+
+ END SUBROUTINE kppdecomp
+
+SUBROUTINE chem_gasphase_integrate (time_step_len, conc, tempi, qvapi, fakti, photo, ierrf, xnacc, xnrej, istatus, l_debug, pe, &
+ icntrl_i, rcntrl_i)
+
+ IMPLICIT NONE
+
+ REAL(dp), INTENT(IN) :: time_step_len
+ REAL(dp), DIMENSION(:, :), INTENT(INOUT) :: conc
+ REAL(dp), DIMENSION(:, :), INTENT(IN) :: photo
+ REAL(dp), DIMENSION(:), INTENT(IN) :: tempi
+ REAL(dp), DIMENSION(:), INTENT(IN) :: qvapi
+ REAL(dp), DIMENSION(:), INTENT(IN) :: fakti
+ INTEGER, INTENT(OUT), OPTIONAL :: ierrf(:)
+ INTEGER, INTENT(OUT), OPTIONAL :: xnacc(:)
+ INTEGER, INTENT(OUT), OPTIONAL :: xnrej(:)
+ INTEGER, INTENT(INOUT), OPTIONAL :: istatus(:)
+ INTEGER, INTENT(IN), OPTIONAL :: pe
+ LOGICAL, INTENT(IN), OPTIONAL :: l_debug
+ INTEGER, DIMENSION(nkppctrl), INTENT(IN), OPTIONAL :: icntrl_i
+ REAL(dp), DIMENSION(nkppctrl), INTENT(IN), OPTIONAL :: rcntrl_i
+
+ INTEGER :: k ! loop variable
+ REAL(dp) :: dt
+ INTEGER, DIMENSION(20) :: istatus_u
+ INTEGER :: ierr_u
+ INTEGER :: istatf
+ INTEGER :: vl_dim_lo
+
+
+ IF (PRESENT (istatus)) istatus = 0
+ IF (PRESENT (icntrl_i)) icntrl = icntrl_i
+ IF (PRESENT (rcntrl_i)) rcntrl = rcntrl_i
+
+ vl_glo = size(tempi, 1)
+
+ vl_dim_lo = vl_dim
+ DO k=1, vl_glo, vl_dim_lo
+ is = k
+ ie = min(k+ vl_dim_lo-1, vl_glo)
+ vl = ie-is+ 1
+
+ c(:) = conc(is, :)
+
+ temp = tempi(is)
+
+ qvap = qvapi(is)
+
+ fakt = fakti(is)
+
+ CALL initialize
+
+ phot(:) = photo(is, :)
+
+ CALL update_rconst
+
+ dt = time_step_len
+
+ ! integrate from t=0 to t=dt
+ CALL integrate(0._dp, dt, icntrl, rcntrl, istatus_u = istatus_u, ierr_u=ierr_u)
+
+
+ IF (PRESENT(l_debug) .AND. PRESENT(pe)) THEN
+ IF (l_debug) CALL error_output(conc(is, :), ierr_u, pe)
+ ENDIF
+
+ conc(is, :) = c(:)
+
+ ! RETURN diagnostic information
+
+ IF (PRESENT(ierrf)) ierrf(is) = ierr_u
+ IF (PRESENT(xnacc)) xnacc(is) = istatus_u(4)
+ IF (PRESENT(xnrej)) xnrej(is) = istatus_u(5)
+
+ IF (PRESENT (istatus)) THEN
+ istatus(1:8) = istatus(1:8) + istatus_u(1:8)
+ ENDIF
+
+ END DO
+
+
+! Deallocate input arrays
+
+
+ data_loaded = .FALSE.
+
+ RETURN
+END SUBROUTINE chem_gasphase_integrate
+
+END MODULE chem_gasphase_mod
+
Index: /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_passive1/chem_gasphase_mod.kpp
===================================================================
--- /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_passive1/chem_gasphase_mod.kpp (revision 3698)
+++ /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_passive1/chem_gasphase_mod.kpp (revision 3698)
@@ -0,0 +1,35 @@
+
+//chem_gasphase_mod.kpp
+//
+//Former revisions
+//----------------
+// $Id: chem_gasphase_mod.kpp 2459 2017-09-13 14:10:33Z forkel $
+// initial revision branch chemistry rev 2973 (16.04.18 forkel)
+//
+#include passive1.spc
+#include passive1.eqn
+#INTEGRATOR rosenbrock
+#LANGUAGE Fortran90
+#HESSIAN on
+#STOICMAT on
+//
+// *******************************************************************************************
+// *** adapt the lines below occurding to the photolysis reactions of your mechanism *
+// *** adapt the number of photolysis frequencies NPHO *
+// *** adapt/extend the indices in the INTEGER, PARAMETER,PUBLIC statement below *
+// *** adapt/extend PHOT_NAMES: Note that the order of PHOT_NAMES and the indices must match *
+// *******************************************************************************************
+//
+#INLINE F90_DATA
+ ! INLINE F90_DATA: Declaration of global variables for photolysis
+ ! REAL(kind=dp) :: phot(nphot) must eventually be moved to GLOBAL later for vector version
+ INTEGER, PARAMETER :: nphot = 1
+ ! phot Photolysis frequencies
+ REAL(kind=dp) :: phot(nphot)
+
+ INTEGER, PARAMETER,PUBLIC :: j_no2 = 1
+
+ CHARACTER(LEN=15), PARAMETER, DIMENSION(NPHOT) :: phot_names = (/ &
+ 'J_NO2 '/)
+#ENDINLINE
+
Index: /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_passive1/passive1.eqn
===================================================================
--- /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_passive1/passive1.eqn (revision 3698)
+++ /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_passive1/passive1.eqn (revision 3698)
@@ -0,0 +1,10 @@
+
+{passive1.eqn
+Former revisions
+----------------
+ $Id$
+}
+#EQUATIONS
+
+{ passive1: does nothing }
+ { 1.} PM10 = PM10 : 1.0_dp ;
Index: /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_passive1/passive1.spc
===================================================================
--- /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_passive1/passive1.spc (revision 3698)
+++ /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_passive1/passive1.spc (revision 3698)
@@ -0,0 +1,19 @@
+
+{passive1.spc
+Former revisions
+----------------
+ $Id$
+}
+#include atoms
+
+ #DEFVAR
+ PM10 = ignore ;
+
+#DEFFIX
+ H2O = H + 2O ; {water}
+ H2 = 2H ; {molecular hydrogen}
+ O2 = 2O ; {molecular oxygen}
+ N2 = 2N ; {molecular nitrogen}
+ CH4 = C + 4H ; {methane}
+ CO2 = C + 2O ; {carbon dioxide}
+
Index: /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_phstat/chem_gasphase_mod.f90
===================================================================
--- /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_phstat/chem_gasphase_mod.f90 (revision 3698)
+++ /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_phstat/chem_gasphase_mod.f90 (revision 3698)
@@ -0,0 +1,2343 @@
+MODULE chem_gasphase_mod
+
+! Mechanism: phstat
+!
+!------------------------------------------------------------------------------!
+!
+! ******Module chem_gasphase_mod is automatically generated by kpp4palm ******
+!
+! *********Please do NOT change this Code,it will be ovewritten *********
+!
+!------------------------------------------------------------------------------!
+! This file was created by KPP (http://people.cs.vt.edu/asandu/Software/Kpp/)
+! and kpp4palm (created by Klaus Ketelsen). kpp4palm is an adapted version
+! of KP4 (Jöckel,P.,Kerkweg,A.,Pozzer,A.,Sander,R.,Tost,H.,Riede,
+! H.,Baumgaertner,A.,Gromov,S.,and Kern,B.,2010: Development cycle 2 of
+! the Modular Earth Submodel System (MESSy2),Geosci. Model Dev.,3,717-752,
+! https://doi.org/10.5194/gmd-3-717-2010). KP4 is part of the Modular Earth
+! Submodel System (MESSy),which is is available under the GNU General Public
+! License (GPL).
+!
+! KPP is free software; you can redistribute it and/or modify it under the terms
+! of the General Public Licence as published by the Free Software Foundation;
+! 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 Licence for more details.
+!
+!------------------------------------------------------------------------------!
+! This file is part of the PALM model system.
+!
+! PALM is free software: you can redistribute it and/or modify it under the
+! terms of the GNU General Public License as published by the Free Software
+! Foundation,either version 3 of the License,or (at your option) any later
+! version.
+!
+! PALM 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
+! PALM. If not,see .
+!
+! Copyright 1997-2019 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+!
+! MODULE HEADER TEMPLATE
+!
+! Initial version (Nov. 2016,ketelsen),for later modifications of module_header
+! see comments in kpp4palm/src/create_kpp_module.C
+
+! Set kpp Double Precision to PALM Default Precision
+
+ USE kinds, ONLY: dp=>wp
+
+ USE pegrid, ONLY: myid, threads_per_task
+
+ IMPLICIT NONE
+ PRIVATE
+ !SAVE ! note: occurs again in automatically generated code ...
+
+! PUBLIC :: IERR_NAMES
+
+! PUBLIC :: SPC_NAMES,EQN_NAMES,EQN_TAGS,REQ_HET,REQ_AEROSOL,REQ_PHOTRAT &
+! ,REQ_MCFCT,IP_MAX,jname
+
+ PUBLIC :: eqn_names, phot_names, spc_names
+ PUBLIC :: nmaxfixsteps
+ PUBLIC :: atol, rtol
+ PUBLIC :: nspec, nreact
+ PUBLIC :: temp
+ PUBLIC :: qvap
+ PUBLIC :: fakt
+ PUBLIC :: phot
+ PUBLIC :: rconst
+ PUBLIC :: nvar
+ PUBLIC :: nphot
+ PUBLIC :: vl_dim ! PUBLIC to ebable other MODULEs to distiguish between scalar and vec
+
+ PUBLIC :: initialize, integrate, update_rconst
+ PUBLIC :: chem_gasphase_integrate
+ PUBLIC :: initialize_kpp_ctrl
+
+! END OF MODULE HEADER TEMPLATE
+
+! Variables used for vector mode
+
+ LOGICAL, PARAMETER :: l_vector = .FALSE.
+ INTEGER, PARAMETER :: i_lu_di = 2
+ INTEGER, PARAMETER :: vl_dim = 1
+ INTEGER :: vl
+
+ INTEGER :: vl_glo
+ INTEGER :: is, ie
+
+
+ INTEGER, DIMENSION(vl_dim) :: kacc, krej
+ INTEGER, DIMENSION(vl_dim) :: ierrv
+ LOGICAL :: data_loaded = .FALSE.
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Parameter Module File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Parameters.f90
+! Time : Fri Nov 30 13:52:19 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! NSPEC - Number of chemical species
+ INTEGER, PARAMETER :: nspec = 3
+! NVAR - Number of Variable species
+ INTEGER, PARAMETER :: nvar = 3
+! NVARACT - Number of Active species
+ INTEGER, PARAMETER :: nvaract = 3
+! NFIX - Number of Fixed species
+ INTEGER, PARAMETER :: nfix = 1
+! NREACT - Number of reactions
+ INTEGER, PARAMETER :: nreact = 2
+! NVARST - Starting of variables in conc. vect.
+ INTEGER, PARAMETER :: nvarst = 1
+! NFIXST - Starting of fixed in conc. vect.
+ INTEGER, PARAMETER :: nfixst = 4
+! NONZERO - Number of nonzero entries in Jacobian
+ INTEGER, PARAMETER :: nonzero = 9
+! LU_NONZERO - Number of nonzero entries in LU factoriz. of Jacobian
+ INTEGER, PARAMETER :: lu_nonzero = 9
+! CNVAR - (NVAR+1) Number of elements in compressed row format
+ INTEGER, PARAMETER :: cnvar = 4
+! CNEQN - (NREACT+1) Number stoicm elements in compressed col format
+ INTEGER, PARAMETER :: cneqn = 3
+! NHESS - Length of Sparse Hessian
+ INTEGER, PARAMETER :: nhess = 3
+! NMASS - Number of atoms to check mass balance
+ INTEGER, PARAMETER :: nmass = 1
+
+! Index declaration for variable species in C and VAR
+! VAR(ind_spc) = C(ind_spc)
+
+ INTEGER, PARAMETER, PUBLIC :: ind_o3 = 1
+ INTEGER, PARAMETER, PUBLIC :: ind_no = 2
+ INTEGER, PARAMETER, PUBLIC :: ind_no2 = 3
+
+! Index declaration for fixed species in C
+! C(ind_spc)
+
+
+! Index declaration for fixed species in FIX
+! FIX(indf_spc) = C(ind_spc) = C(NVAR+indf_spc)
+
+
+! NJVRP - Length of sparse Jacobian JVRP
+ INTEGER, PARAMETER :: njvrp = 3
+
+! NSTOICM - Length of Sparse Stoichiometric Matrix
+ INTEGER, PARAMETER :: nstoicm = 6
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Global Data Module File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Global.f90
+! Time : Fri Nov 30 13:52:19 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! Declaration of global variables
+
+! C - Concentration of all species
+ REAL(kind=dp):: c(nspec)
+! VAR - Concentrations of variable species (global)
+ REAL(kind=dp):: var(nvar)
+! FIX - Concentrations of fixed species (global)
+ REAL(kind=dp):: fix(nfix)
+! VAR,FIX are chunks of array C
+ EQUIVALENCE( c(1), var(1))
+! RCONST - Rate constants (global)
+ REAL(kind=dp):: rconst(nreact)
+! TIME - Current integration time
+ REAL(kind=dp):: time
+! TEMP - Temperature
+ REAL(kind=dp):: temp
+! TSTART - Integration start time
+ REAL(kind=dp):: tstart
+! ATOL - Absolute tolerance
+ REAL(kind=dp):: atol(nvar)
+! RTOL - Relative tolerance
+ REAL(kind=dp):: rtol(nvar)
+! STEPMIN - Lower bound for integration step
+ REAL(kind=dp):: stepmin
+! CFACTOR - Conversion factor for concentration units
+ REAL(kind=dp):: cfactor
+
+! INLINED global variable declarations
+
+! QVAP - Water vapor
+ REAL(kind=dp):: qvap
+! FAKT - Conversion factor
+ REAL(kind=dp):: fakt
+
+
+! INLINED global variable declarations
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Sparse Jacobian Data Structures File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_JacobianSP.f90
+! Time : Fri Nov 30 13:52:19 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! Sparse Jacobian Data
+
+
+ INTEGER, PARAMETER, DIMENSION(9):: lu_irow = (/ &
+ 1, 1, 1, 2, 2, 2, 3, 3, 3 /)
+
+ INTEGER, PARAMETER, DIMENSION(9):: lu_icol = (/ &
+ 1, 2, 3, 1, 2, 3, 1, 2, 3 /)
+
+ INTEGER, PARAMETER, DIMENSION(4):: lu_crow = (/ &
+ 1, 4, 7, 10 /)
+
+ INTEGER, PARAMETER, DIMENSION(4):: lu_diag = (/ &
+ 1, 5, 9, 10 /)
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Utility Data Module File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Monitor.f90
+! Time : Fri Nov 30 13:52:19 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+ CHARACTER(len=15), PARAMETER, DIMENSION(3):: spc_names = (/ &
+ 'O3 ','NO ','NO2 ' /)
+
+ CHARACTER(len=100), PARAMETER, DIMENSION(2):: eqn_names = (/ &
+ ' NO2 --> O3 + NO ',&
+ 'O3 + NO --> NO2 ' /)
+
+! INLINED global variables
+
+ ! inline f90_data: declaration of global variables for photolysis
+ ! REAL(kind=dp):: phot(nphot)must eventually be moved to global later for
+ INTEGER, PARAMETER :: nphot = 1
+ ! phot photolysis frequencies
+ REAL(kind=dp):: phot(nphot)
+
+ INTEGER, PARAMETER, PUBLIC :: j_no2 = 1
+
+ CHARACTER(len=15), PARAMETER, DIMENSION(nphot):: phot_names = (/ &
+ 'J_NO2 '/)
+
+! End INLINED global variables
+
+
+! Automatic generated PUBLIC Statements for ip_ and ihs_ variables
+
+! Automatic generated PUBLIC Statements for ip_ and ihs_ variables
+
+! Automatic generated PUBLIC Statements for ip_ and ihs_ variables
+
+! Automatic generated PUBLIC Statements for ip_ and ihs_ variables
+
+
+! variable definations from individual module headers
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Initialization File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Initialize.f90
+! Time : Fri Nov 30 13:52:19 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Numerical Integrator (Time-Stepping) File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Integrator.f90
+! Time : Fri Nov 30 13:52:19 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! INTEGRATE - Integrator routine
+! Arguments :
+! TIN - Start Time for Integration
+! TOUT - End Time for Integration
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!
+! 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 !
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!
+
+
+ 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
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Linear Algebra Data and Routines File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_LinearAlgebra.f90
+! Time : Fri Nov 30 13:52:19 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! The ODE Jacobian of Chemical Model File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Jacobian.f90
+! Time : Fri Nov 30 13:52:19 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! The ODE Function of Chemical Model File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Function.f90
+! Time : Fri Nov 30 13:52:19 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+! A - Rate for each equation
+ REAL(kind=dp):: a(nreact)
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! The Reaction Rates File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Rates.f90
+! Time : Fri Nov 30 13:52:19 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Auxiliary Routines File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Util.f90
+! Time : Fri Nov 30 13:52:19 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+ ! header MODULE initialize_kpp_ctrl_template
+
+ ! notes:
+ ! - l_vector is automatically defined by kp4
+ ! - vl_dim is automatically defined by kp4
+ ! - i_lu_di is automatically defined by kp4
+ ! - wanted is automatically defined by xmecca
+ ! - icntrl rcntrl are automatically defined by kpp
+ ! - "USE messy_main_tools" is in MODULE_header of messy_mecca_kpp.f90
+ ! - SAVE will be automatically added by kp4
+
+ !SAVE
+
+ ! for fixed time step control
+ ! ... max. number of fixed time steps (sum must be 1)
+ INTEGER, PARAMETER :: nmaxfixsteps = 50
+ ! ... switch for fixed time stepping
+ LOGICAL, PUBLIC :: l_fixed_step = .FALSE.
+ INTEGER, PUBLIC :: nfsteps = 1
+ ! ... number of kpp control PARAMETERs
+ INTEGER, PARAMETER, PUBLIC :: nkppctrl = 20
+ !
+ INTEGER, DIMENSION(nkppctrl), PUBLIC :: icntrl = 0
+ REAL(dp), DIMENSION(nkppctrl), PUBLIC :: rcntrl = 0.0_dp
+ REAL(dp), DIMENSION(nmaxfixsteps), PUBLIC :: t_steps = 0.0_dp
+
+ ! END header MODULE initialize_kpp_ctrl_template
+
+
+! Interface Block
+
+ INTERFACE initialize
+ MODULE PROCEDURE initialize
+ END INTERFACE initialize
+
+ INTERFACE integrate
+ MODULE PROCEDURE integrate
+ END INTERFACE integrate
+
+ INTERFACE fun
+ MODULE PROCEDURE fun
+ END INTERFACE fun
+
+ INTERFACE kppsolve
+ MODULE PROCEDURE kppsolve
+ END INTERFACE kppsolve
+
+ INTERFACE jac_sp
+ MODULE PROCEDURE jac_sp
+ END INTERFACE jac_sp
+
+ INTERFACE k_arr
+ MODULE PROCEDURE k_arr
+ END INTERFACE k_arr
+
+ INTERFACE update_rconst
+ MODULE PROCEDURE update_rconst
+ END INTERFACE update_rconst
+
+ INTERFACE arr2
+ MODULE PROCEDURE arr2
+ END INTERFACE arr2
+
+ INTERFACE initialize_kpp_ctrl
+ MODULE PROCEDURE initialize_kpp_ctrl
+ END INTERFACE initialize_kpp_ctrl
+
+ INTERFACE error_output
+ MODULE PROCEDURE error_output
+ END INTERFACE error_output
+
+ INTERFACE wscal
+ MODULE PROCEDURE wscal
+ END INTERFACE wscal
+
+!INTERFACE not working INTERFACE waxpy
+!INTERFACE not working MODULE PROCEDURE waxpy
+!INTERFACE not working END INTERFACE waxpy
+
+ INTERFACE rosenbrock
+ MODULE PROCEDURE rosenbrock
+ END INTERFACE rosenbrock
+
+ INTERFACE funtemplate
+ MODULE PROCEDURE funtemplate
+ END INTERFACE funtemplate
+
+ INTERFACE jactemplate
+ MODULE PROCEDURE jactemplate
+ END INTERFACE jactemplate
+
+ INTERFACE kppdecomp
+ MODULE PROCEDURE kppdecomp
+ END INTERFACE kppdecomp
+
+ INTERFACE chem_gasphase_integrate
+ MODULE PROCEDURE chem_gasphase_integrate
+ END INTERFACE chem_gasphase_integrate
+
+
+ CONTAINS
+
+SUBROUTINE initialize()
+
+
+ INTEGER :: j, k
+
+ INTEGER :: i
+ REAL(kind=dp):: x
+ k = is
+ cfactor = 1.000000e+00_dp
+
+ x = (0.) * cfactor
+ DO i = 1 , nvar
+ ENDDO
+
+ x = (0.) * cfactor
+ DO i = 1 , nfix
+ fix(i) = x
+ ENDDO
+
+! constant rate coefficients
+! END constant rate coefficients
+
+! INLINED initializations
+
+! End INLINED initializations
+
+
+END SUBROUTINE initialize
+
+SUBROUTINE integrate( tin, tout, &
+ icntrl_u, rcntrl_u, istatus_u, rstatus_u, ierr_u)
+
+
+ REAL(kind=dp), INTENT(IN):: tin ! start time
+ REAL(kind=dp), INTENT(IN):: tout ! END time
+ ! OPTIONAL input PARAMETERs and statistics
+ INTEGER, INTENT(IN), OPTIONAL :: icntrl_u(20)
+ REAL(kind=dp), INTENT(IN), OPTIONAL :: rcntrl_u(20)
+ INTEGER, INTENT(OUT), OPTIONAL :: istatus_u(20)
+ REAL(kind=dp), INTENT(OUT), OPTIONAL :: rstatus_u(20)
+ INTEGER, INTENT(OUT), OPTIONAL :: ierr_u
+
+ REAL(kind=dp):: 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(:)
+ ENDIF
+ IF (PRESENT(rcntrl_u))THEN
+ WHERE(rcntrl_u(:)> 0)rcntrl(:) = rcntrl_u(:)
+ ENDIF
+
+
+ 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 fun(v, f, rct, vdot)
+
+! V - Concentrations of variable species (local)
+ REAL(kind=dp):: v(nvar)
+! F - Concentrations of fixed species (local)
+ REAL(kind=dp):: f(nfix)
+! RCT - Rate constants (local)
+ REAL(kind=dp):: rct(nreact)
+! Vdot - Time derivative of variable species concentrations
+ REAL(kind=dp):: vdot(nvar)
+
+
+! Computation of equation rates
+ a(1) = rct(1) * v(3)
+ a(2) = rct(2) * v(1) * v(2)
+
+! Aggregate function
+ vdot(1) = a(1) - a(2)
+ vdot(2) = a(1) - a(2)
+ vdot(3) = - a(1) + a(2)
+
+END SUBROUTINE fun
+
+SUBROUTINE kppsolve(jvs, x)
+
+! JVS - sparse Jacobian of variables
+ REAL(kind=dp):: jvs(lu_nonzero)
+! X - Vector for variables
+ REAL(kind=dp):: x(nvar)
+
+ x(2) = x(2) - jvs(4) * x(1)
+ x(3) = x(3) - jvs(7) * x(1) - jvs(8) * x(2)
+ x(3) = x(3) / jvs(9)
+ x(2) = (x(2) - jvs(6) * x(3)) /(jvs(5))
+ x(1) = (x(1) - jvs(2) * x(2) - jvs(3) * x(3)) /(jvs(1))
+
+END SUBROUTINE kppsolve
+
+SUBROUTINE jac_sp(v, f, rct, jvs)
+
+! V - Concentrations of variable species (local)
+ REAL(kind=dp):: v(nvar)
+! F - Concentrations of fixed species (local)
+ REAL(kind=dp):: f(nfix)
+! RCT - Rate constants (local)
+ REAL(kind=dp):: rct(nreact)
+! JVS - sparse Jacobian of variables
+ REAL(kind=dp):: jvs(lu_nonzero)
+
+
+! Local variables
+! B - Temporary array
+ REAL(kind=dp):: b(3)
+
+! B(1) = dA(1)/dV(3)
+ b(1) = rct(1)
+! B(2) = dA(2)/dV(1)
+ b(2) = rct(2) * v(2)
+! B(3) = dA(2)/dV(2)
+ b(3) = rct(2) * v(1)
+
+! Construct the Jacobian terms from B's
+! JVS(1) = Jac_FULL(1,1)
+ jvs(1) = - b(2)
+! JVS(2) = Jac_FULL(1,2)
+ jvs(2) = - b(3)
+! JVS(3) = Jac_FULL(1,3)
+ jvs(3) = b(1)
+! JVS(4) = Jac_FULL(2,1)
+ jvs(4) = - b(2)
+! JVS(5) = Jac_FULL(2,2)
+ jvs(5) = - b(3)
+! JVS(6) = Jac_FULL(2,3)
+ jvs(6) = b(1)
+! JVS(7) = Jac_FULL(3,1)
+ jvs(7) = b(2)
+! JVS(8) = Jac_FULL(3,2)
+ jvs(8) = b(3)
+! JVS(9) = Jac_FULL(3,3)
+ jvs(9) = - b(1)
+
+END SUBROUTINE jac_sp
+
+ elemental REAL(kind=dp)FUNCTION k_arr (k_298, tdep, temp)
+ ! arrhenius FUNCTION
+
+ REAL, INTENT(IN):: k_298 ! k at t = 298.15k
+ REAL, INTENT(IN):: tdep ! temperature dependence
+ REAL(kind=dp), INTENT(IN):: temp ! temperature
+
+ intrinsic exp
+
+ k_arr = k_298 * exp(tdep* (1._dp/temp- 3.3540e-3_dp))! 1/298.15=3.3540e-3
+
+ END FUNCTION k_arr
+
+SUBROUTINE update_rconst()
+ INTEGER :: k
+
+ k = is
+
+! Begin INLINED RCONST
+
+
+! End INLINED RCONST
+
+ rconst(1) = (phot(j_no2))
+ rconst(2) = (arr2(1.8e-12_dp , 1370.0_dp , temp))
+
+END SUBROUTINE update_rconst
+
+! END FUNCTION ARR2
+REAL(kind=dp)FUNCTION arr2( a0, b0, temp)
+ REAL(kind=dp):: temp
+ REAL(kind=dp):: a0, b0
+ arr2 = a0 * exp( - b0 / temp)
+END FUNCTION arr2
+
+SUBROUTINE initialize_kpp_ctrl(status)
+
+
+ ! i/o
+ INTEGER, INTENT(OUT):: status
+
+ ! local
+ REAL(dp):: tsum
+ INTEGER :: i
+
+ ! check fixed time steps
+ tsum = 0.0_dp
+ DO i=1, nmaxfixsteps
+ IF (t_steps(i)< tiny(0.0_dp))exit
+ tsum = tsum + t_steps(i)
+ ENDDO
+
+ nfsteps = i- 1
+
+ l_fixed_step = (nfsteps > 0).and.((tsum - 1.0)< tiny(0.0_dp))
+
+ IF (l_vector)THEN
+ WRITE(*,*) ' MODE : VECTOR (LENGTH=',VL_DIM,')'
+ ELSE
+ WRITE(*,*) ' MODE : SCALAR'
+ ENDIF
+ !
+ WRITE(*,*) ' DE-INDEXING MODE :',I_LU_DI
+ !
+ WRITE(*,*) ' ICNTRL : ',icntrl
+ WRITE(*,*) ' RCNTRL : ',rcntrl
+ !
+ ! note: this is ONLY meaningful for vectorized (kp4)rosenbrock- methods
+ IF (l_vector)THEN
+ IF (l_fixed_step)THEN
+ WRITE(*,*) ' TIME STEPS : FIXED (',t_steps(1:nfsteps),')'
+ ELSE
+ WRITE(*,*) ' TIME STEPS : AUTOMATIC'
+ ENDIF
+ ELSE
+ WRITE(*,*) ' TIME STEPS : AUTOMATIC '//&
+ &'(t_steps (CTRL_KPP) ignored in SCALAR MODE)'
+ ENDIF
+ ! mz_pj_20070531-
+
+ status = 0
+
+
+END SUBROUTINE initialize_kpp_ctrl
+
+SUBROUTINE error_output(c, ierr, pe)
+
+
+ INTEGER, INTENT(IN):: ierr
+ INTEGER, INTENT(IN):: pe
+ REAL(dp), DIMENSION(:), INTENT(IN):: c
+
+ write(6,*) 'ERROR in chem_gasphase_mod ',ierr,C(1)
+
+
+END SUBROUTINE error_output
+
+ SUBROUTINE wscal(n, alpha, x, incx)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+! constant times a vector: x(1:N) <- Alpha*x(1:N)
+! only for incX=incY=1
+! after BLAS
+! replace this by the function from the optimized BLAS implementation:
+! CALL SSCAL(N,Alpha,X,1) or CALL DSCAL(N,Alpha,X,1)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ INTEGER :: i, incx, m, mp1, n
+ REAL(kind=dp) :: x(n), alpha
+ REAL(kind=dp), PARAMETER :: zero=0.0_dp, one=1.0_dp
+
+ IF (alpha .eq. one)RETURN
+ IF (n .le. 0)RETURN
+
+ m = mod(n, 5)
+ IF ( m .ne. 0)THEN
+ IF (alpha .eq. (- one))THEN
+ DO i = 1, m
+ x(i) = - x(i)
+ ENDDO
+ ELSEIF (alpha .eq. zero)THEN
+ DO i = 1, m
+ x(i) = zero
+ ENDDO
+ ELSE
+ DO i = 1, m
+ x(i) = alpha* x(i)
+ ENDDO
+ ENDIF
+ IF ( n .lt. 5)RETURN
+ ENDIF
+ mp1 = m + 1
+ IF (alpha .eq. (- one))THEN
+ DO i = mp1, n, 5
+ x(i) = - x(i)
+ x(i + 1) = - x(i + 1)
+ x(i + 2) = - x(i + 2)
+ x(i + 3) = - x(i + 3)
+ x(i + 4) = - x(i + 4)
+ ENDDO
+ ELSEIF (alpha .eq. zero)THEN
+ DO i = mp1, n, 5
+ x(i) = zero
+ x(i + 1) = zero
+ x(i + 2) = zero
+ x(i + 3) = zero
+ x(i + 4) = zero
+ ENDDO
+ ELSE
+ DO i = mp1, n, 5
+ x(i) = alpha* x(i)
+ x(i + 1) = alpha* x(i + 1)
+ x(i + 2) = alpha* x(i + 2)
+ x(i + 3) = alpha* x(i + 3)
+ x(i + 4) = alpha* x(i + 4)
+ ENDDO
+ ENDIF
+
+ END SUBROUTINE wscal
+
+ SUBROUTINE waxpy(n, alpha, x, incx, y, incy)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+! constant times a vector plus a vector: y <- y + Alpha*x
+! only for incX=incY=1
+! after BLAS
+! replace this by the function from the optimized BLAS implementation:
+! CALL SAXPY(N,Alpha,X,1,Y,1) or CALL DAXPY(N,Alpha,X,1,Y,1)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ INTEGER :: i, incx, incy, m, mp1, n
+ REAL(kind=dp):: x(n), y(n), alpha
+ REAL(kind=dp), PARAMETER :: zero = 0.0_dp
+
+ IF (alpha .eq. zero)RETURN
+ IF (n .le. 0)RETURN
+
+ m = mod(n, 4)
+ IF ( m .ne. 0)THEN
+ DO i = 1, m
+ y(i) = y(i) + alpha* x(i)
+ ENDDO
+ IF ( n .lt. 4)RETURN
+ ENDIF
+ mp1 = m + 1
+ DO i = mp1, n, 4
+ y(i) = y(i) + alpha* x(i)
+ y(i + 1) = y(i + 1) + alpha* x(i + 1)
+ y(i + 2) = y(i + 2) + alpha* x(i + 2)
+ y(i + 3) = y(i + 3) + alpha* x(i + 3)
+ ENDDO
+
+ END SUBROUTINE waxpy
+
+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
+!
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+!~~~> arguments
+ INTEGER, INTENT(IN) :: n
+ REAL(kind=dp), INTENT(INOUT):: y(n)
+ REAL(kind=dp), INTENT(IN) :: tstart, tend
+ REAL(kind=dp), INTENT(IN) :: abstol(n), reltol(n)
+ INTEGER, INTENT(IN) :: icntrl(20)
+ REAL(kind=dp), INTENT(IN) :: rcntrl(20)
+ INTEGER, INTENT(INOUT):: istatus(20)
+ REAL(kind=dp), 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
+ REAL(kind=dp):: 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
+ REAL(kind=dp):: roundoff, facmin, facmax, facrej, facsafe
+ REAL(kind=dp):: hmin, hmax, hstart
+ REAL(kind=dp):: texit
+ INTEGER :: i, uplimtol, max_no_steps
+ LOGICAL :: autonomous, vectortol
+!~~~> PARAMETERs
+ REAL(kind=dp), PARAMETER :: zero = 0.0_dp, one = 1.0_dp
+ REAL(kind=dp), 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
+ ENDIF
+
+!~~~> 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
+ ENDIF
+
+!~~~> unit roundoff (1+ roundoff>1)
+ roundoff = epsilon(one)
+
+!~~~> 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
+ ENDIF
+!~~~> 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
+ ENDIF
+!~~~> 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
+ ENDIF
+!~~~> 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
+ ENDIF
+ 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
+ ENDIF
+!~~~> 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
+ ENDIF
+!~~~> 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
+ ENDIF
+!~~~> 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
+ ENDIF
+ ENDDO
+
+
+!~~~> 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ REAL(kind=dp), 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}
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+!~~~> input: the initial condition at tstart; output: the solution at t
+ REAL(kind=dp), INTENT(INOUT):: y(n)
+!~~~> input: integration interval
+ REAL(kind=dp), INTENT(IN):: tstart, tend
+!~~~> output: time at which the solution is RETURNed (t=tendIF success)
+ REAL(kind=dp), INTENT(OUT):: t
+!~~~> input: tolerances
+ REAL(kind=dp), INTENT(IN):: abstol(n), reltol(n)
+!~~~> input: integration PARAMETERs
+ LOGICAL, INTENT(IN):: autonomous, vectortol
+ REAL(kind=dp), INTENT(IN):: hstart, hmin, hmax
+ INTEGER, INTENT(IN):: max_no_steps
+ REAL(kind=dp), INTENT(IN):: roundoff, facmin, facmax, facrej, facsafe
+!~~~> output: error indicator
+ INTEGER, INTENT(OUT):: ierr
+! ~~~~ Local variables
+ REAL(kind=dp):: ynew(n), fcn0(n), fcn(n)
+ REAL(kind=dp):: k(n* ros_s), dfdt(n)
+#ifdef full_algebra
+ REAL(kind=dp):: jac0(n, n), ghimj(n, n)
+#else
+ REAL(kind=dp):: jac0(lu_nonzero), ghimj(lu_nonzero)
+#endif
+ REAL(kind=dp):: h, hnew, hc, hg, fac, tau
+ REAL(kind=dp):: err, yerr(n)
+ INTEGER :: pivot(n), direction, ioffset, j, istage
+ LOGICAL :: rejectlasth, rejectmoreh, singular
+!~~~> local PARAMETERs
+ REAL(kind=dp), PARAMETER :: zero = 0.0_dp, one = 1.0_dp
+ REAL(kind=dp), PARAMETER :: deltamin = 1.0e-5_dp
+!~~~> locally called FUNCTIONs
+! REAL(kind=dp) 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
+ ENDIF
+ 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
+ ENDIF
+ IF (((t+ 0.1_dp* h) == t).or.(h <= roundoff))THEN ! step size too small
+ CALL ros_errormsg(- 7, t, h, ierr)
+ RETURN
+ ENDIF
+
+!~~~> 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)
+ ENDIF
+
+!~~~> 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
+ ENDIF
+
+!~~~> 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
+ !slim: CALL wcopy(n, fcn0, 1, fcn, 1)
+ fcn(1:n) = fcn0(1:n)
+ ! istage>1 and a new FUNCTION evaluation is needed at the current istage
+ ELSEIF(ros_newf(istage))THEN
+ !slim: CALL wcopy(n, y, 1, ynew, 1)
+ ynew(1:n) = y(1:n)
+ DO j = 1, istage-1
+ CALL waxpy(n, ros_a((istage-1) * (istage-2) /2+ j), &
+ k(n* (j- 1) + 1), 1, ynew, 1)
+ ENDDO
+ tau = t + ros_alpha(istage) * direction* h
+ CALL funtemplate(tau, ynew, fcn)
+ istatus(nfun) = istatus(nfun) + 1
+ ENDIF ! IF istage == 1 ELSEIF ros_newf(istage)
+ !slim: CALL wcopy(n, fcn, 1, k(ioffset+ 1), 1)
+ k(ioffset+ 1:ioffset+ n) = fcn(1:n)
+ 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), 1, k(ioffset+ 1), 1)
+ ENDDO
+ 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), 1)
+ ENDIF
+ CALL ros_solve(ghimj, pivot, k(ioffset+ 1))
+
+ END DO stage
+
+
+!~~~> compute the new solution
+ !slim: CALL wcopy(n, y, 1, ynew, 1)
+ ynew(1:n) = y(1:n)
+ DO j=1, ros_s
+ CALL waxpy(n, ros_m(j), k(n* (j- 1) + 1), 1, ynew, 1)
+ ENDDO
+
+!~~~> compute the error estimation
+ !slim: CALL wscal(n, zero, yerr, 1)
+ yerr(1:n) = zero
+ DO j=1, ros_s
+ CALL waxpy(n, ros_e(j), k(n* (j- 1) + 1), 1, yerr, 1)
+ ENDDO
+ 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
+ !slim: CALL wcopy(n, ynew, 1, y, 1)
+ y(1:n) = ynew(1:n)
+ 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)
+ ENDIF
+ 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
+ ENDIF
+ rejectmoreh = rejectlasth
+ rejectlasth = .TRUE.
+ h = hnew
+ IF (istatus(nacc)>= 1) istatus(nrej) = istatus(nrej) + 1
+ ENDIF ! err <= 1
+
+ END DO untilaccepted
+
+ END DO timeloop
+
+!~~~> succesful exit
+ ierr = 1 !~~~> the integration was successful
+
+ END SUBROUTINE ros_integrator
+
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ REAL(kind=dp)FUNCTION ros_errornorm(y, ynew, yerr, &
+ abstol, reltol, vectortol)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> computes the "scaled norm" of the error vector yerr
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+! Input arguments
+ REAL(kind=dp), INTENT(IN):: y(n), ynew(n), &
+ yerr(n), abstol(n), reltol(n)
+ LOGICAL, INTENT(IN):: vectortol
+! Local variables
+ REAL(kind=dp):: err, scale, ymax
+ INTEGER :: i
+ REAL(kind=dp), 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
+ ENDIF
+ err = err+ (yerr(i) /scale) ** 2
+ ENDDO
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+!~~~> input arguments
+ REAL(kind=dp), INTENT(IN):: t, roundoff, y(n), fcn0(n)
+!~~~> output arguments
+ REAL(kind=dp), INTENT(OUT):: dfdt(n)
+!~~~> local variables
+ REAL(kind=dp):: delta
+ REAL(kind=dp), 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
+! --- --- --- --- --- --- --- --- --- --- --- --- ---
+
+!~~~> input arguments
+#ifdef full_algebra
+ REAL(kind=dp), INTENT(IN):: jac0(n, n)
+#else
+ REAL(kind=dp), INTENT(IN):: jac0(lu_nonzero)
+#endif
+ REAL(kind=dp), INTENT(IN):: gam
+ INTEGER, INTENT(IN):: direction
+!~~~> output arguments
+#ifdef full_algebra
+ REAL(kind=dp), INTENT(OUT):: ghimj(n, n)
+#else
+ REAL(kind=dp), INTENT(OUT):: ghimj(lu_nonzero)
+#endif
+ LOGICAL, INTENT(OUT):: singular
+ INTEGER, INTENT(OUT):: pivot(n)
+!~~~> inout arguments
+ REAL(kind=dp), INTENT(INOUT):: h ! step size is decreased when lu fails
+!~~~> local variables
+ INTEGER :: i, ising, nconsecutive
+ REAL(kind=dp):: ghinv
+ REAL(kind=dp), 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
+ !slim: CALL wcopy(n* n, jac0, 1, ghimj, 1)
+ !slim: CALL wscal(n* n, (- one), ghimj, 1)
+ ghimj = - jac0
+ ghinv = one/(direction* h* gam)
+ DO i=1, n
+ ghimj(i, i) = ghimj(i, i) + ghinv
+ ENDDO
+#else
+ !slim: CALL wcopy(lu_nonzero, jac0, 1, ghimj, 1)
+ !slim: CALL wscal(lu_nonzero, (- one), ghimj, 1)
+ ghimj(1:lu_nonzero) = - jac0(1:lu_nonzero)
+ ghinv = one/(direction* h* gam)
+ DO i=1, n
+ ghimj(lu_diag(i)) = ghimj(lu_diag(i)) + ghinv
+ ENDDO
+#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
+ ENDIF ! nconsecutive
+ ENDIF ! ising
+
+ END DO ! WHILE singular
+
+ END SUBROUTINE ros_preparematrix
+
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE ros_decomp( a, pivot, ising)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! Template for the LU decomposition
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> inout variables
+#ifdef full_algebra
+ REAL(kind=dp), INTENT(INOUT):: a(n, n)
+#else
+ REAL(kind=dp), INTENT(INOUT):: a(lu_nonzero)
+#endif
+!~~~> 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)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> input variables
+#ifdef full_algebra
+ REAL(kind=dp), INTENT(IN):: a(n, n)
+ INTEGER :: ising
+#else
+ REAL(kind=dp), INTENT(IN):: a(lu_nonzero)
+#endif
+ INTEGER, INTENT(IN):: pivot(n)
+!~~~> inout variables
+ REAL(kind=dp), INTENT(INOUT):: b(n)
+
+#ifdef full_algebra
+ CALL DGETRS( 'N',N ,1,A,N,Pivot,b,N,ISING)
+ IF (info < 0)THEN
+ print* , "error in dgetrs. ising=", ising
+ ENDIF
+#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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ 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)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+ 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)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> input variables
+ REAL(kind=dp):: t, y(nvar)
+!~~~> output variables
+ REAL(kind=dp):: ydot(nvar)
+!~~~> local variables
+ REAL(kind=dp):: told
+
+ told = time
+ time = t
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> input variables
+ REAL(kind=dp):: t, y(nvar)
+!~~~> output variables
+#ifdef full_algebra
+ REAL(kind=dp):: jv(lu_nonzero), jcb(nvar, nvar)
+#else
+ REAL(kind=dp):: jcb(lu_nonzero)
+#endif
+!~~~> local variables
+ REAL(kind=dp):: told
+#ifdef full_algebra
+ INTEGER :: i, j
+#endif
+
+ told = time
+ time = t
+#ifdef full_algebra
+ CALL jac_sp(y, fix, rconst, jv)
+ DO j=1, nvar
+ DO i=1, nvar
+ jcb(i, j) = 0.0_dp
+ ENDDO
+ ENDDO
+ DO i=1, lu_nonzero
+ jcb(lu_irow(i), lu_icol(i)) = jv(i)
+ ENDDO
+#else
+ CALL jac_sp( y, fix, rconst, jcb)
+#endif
+ time = told
+
+END SUBROUTINE jactemplate
+
+ SUBROUTINE kppdecomp( jvs, ier)
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! sparse lu factorization
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! loop expansion generated by kp4
+
+ INTEGER :: ier
+ REAL(kind=dp):: jvs(lu_nonzero), w(nvar), a
+ INTEGER :: k, kk, j, jj
+
+ a = 0.
+ ier = 0
+
+! i = 1
+! i = 2
+ jvs(4) = (jvs(4)) / jvs(1)
+ jvs(5) = jvs(5) - jvs(2) * jvs(4)
+ jvs(6) = jvs(6) - jvs(3) * jvs(4)
+! i = 3
+ jvs(7) = (jvs(7)) / jvs(1)
+ a = 0.0; a = a - jvs(2) * jvs(7)
+ jvs(8) = (jvs(8) + a) / jvs(5)
+ jvs(9) = jvs(9) - jvs(3) * jvs(7) - jvs(6) * jvs(8)
+ RETURN
+
+ END SUBROUTINE kppdecomp
+
+SUBROUTINE chem_gasphase_integrate (time_step_len, conc, tempi, qvapi, fakti, photo, ierrf, xnacc, xnrej, istatus, l_debug, pe, &
+ icntrl_i, rcntrl_i)
+
+ IMPLICIT NONE
+
+ REAL(dp), INTENT(IN) :: time_step_len
+ REAL(dp), DIMENSION(:, :), INTENT(INOUT) :: conc
+ REAL(dp), DIMENSION(:, :), INTENT(IN) :: photo
+ REAL(dp), DIMENSION(:), INTENT(IN) :: tempi
+ REAL(dp), DIMENSION(:), INTENT(IN) :: qvapi
+ REAL(dp), DIMENSION(:), INTENT(IN) :: fakti
+ INTEGER, INTENT(OUT), OPTIONAL :: ierrf(:)
+ INTEGER, INTENT(OUT), OPTIONAL :: xnacc(:)
+ INTEGER, INTENT(OUT), OPTIONAL :: xnrej(:)
+ INTEGER, INTENT(INOUT), OPTIONAL :: istatus(:)
+ INTEGER, INTENT(IN), OPTIONAL :: pe
+ LOGICAL, INTENT(IN), OPTIONAL :: l_debug
+ INTEGER, DIMENSION(nkppctrl), INTENT(IN), OPTIONAL :: icntrl_i
+ REAL(dp), DIMENSION(nkppctrl), INTENT(IN), OPTIONAL :: rcntrl_i
+
+ INTEGER :: k ! loop variable
+ REAL(dp) :: dt
+ INTEGER, DIMENSION(20) :: istatus_u
+ INTEGER :: ierr_u
+ INTEGER :: istatf
+ INTEGER :: vl_dim_lo
+
+
+ IF (PRESENT (istatus)) istatus = 0
+ IF (PRESENT (icntrl_i)) icntrl = icntrl_i
+ IF (PRESENT (rcntrl_i)) rcntrl = rcntrl_i
+
+ vl_glo = size(tempi, 1)
+
+ vl_dim_lo = vl_dim
+ DO k=1, vl_glo, vl_dim_lo
+ is = k
+ ie = min(k+ vl_dim_lo-1, vl_glo)
+ vl = ie-is+ 1
+
+ c(:) = conc(is, :)
+
+ temp = tempi(is)
+
+ qvap = qvapi(is)
+
+ fakt = fakti(is)
+
+ CALL initialize
+
+ phot(:) = photo(is, :)
+
+ CALL update_rconst
+
+ dt = time_step_len
+
+ ! integrate from t=0 to t=dt
+ CALL integrate(0._dp, dt, icntrl, rcntrl, istatus_u = istatus_u, ierr_u=ierr_u)
+
+
+ IF (PRESENT(l_debug) .AND. PRESENT(pe)) THEN
+ IF (l_debug) CALL error_output(conc(is, :), ierr_u, pe)
+ ENDIF
+
+ conc(is, :) = c(:)
+
+ ! RETURN diagnostic information
+
+ IF (PRESENT(ierrf)) ierrf(is) = ierr_u
+ IF (PRESENT(xnacc)) xnacc(is) = istatus_u(4)
+ IF (PRESENT(xnrej)) xnrej(is) = istatus_u(5)
+
+ IF (PRESENT (istatus)) THEN
+ istatus(1:8) = istatus(1:8) + istatus_u(1:8)
+ ENDIF
+
+ END DO
+
+
+! Deallocate input arrays
+
+
+ data_loaded = .FALSE.
+
+ RETURN
+END SUBROUTINE chem_gasphase_integrate
+
+END MODULE chem_gasphase_mod
+
Index: /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_phstat/chem_gasphase_mod.kpp
===================================================================
--- /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_phstat/chem_gasphase_mod.kpp (revision 3698)
+++ /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_phstat/chem_gasphase_mod.kpp (revision 3698)
@@ -0,0 +1,33 @@
+//chem_gasphase_mod.kpp
+//
+//Former revisions
+//----------------
+// $Id: chem_gasphase_mod.kpp 2459 2017-09-13 14:10:33Z forkel $
+// initial revision branch chemistry rev 2931 (23.03.2018, forkel)
+//
+#include phstat.spc
+#include phstat.eqn
+#INTEGRATOR rosenbrock
+#LANGUAGE Fortran90
+#HESSIAN on
+#STOICMAT on
+//
+// *******************************************************************************************
+// *** adapt the lines below occurding to the photolysis reactions of your mechanism *
+// *** adapt the number of photolysis frequencies NPHO *
+// *** adapt/extend the indices in the INTEGER, PARAMETER,PUBLIC statement below *
+// *** adapt/extend PHOT_NAMES: Note that the order of PHOT_NAMES and the indices must match *
+// *******************************************************************************************
+//
+#INLINE F90_DATA
+ ! INLINE F90_DATA: Declaration of global variables for photolysis
+ ! REAL(kind=dp) :: phot(nphot) must eventually be moved to GLOBAL later for vector version
+ INTEGER, PARAMETER :: nphot = 1
+ ! phot Photolysis frequencies
+ REAL(kind=dp) :: phot(nphot)
+
+ INTEGER, PARAMETER,PUBLIC :: j_no2 = 1
+
+ CHARACTER(LEN=15), PARAMETER, DIMENSION(NPHOT) :: phot_names = (/ &
+ 'J_NO2 '/)
+#ENDINLINE
Index: /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_phstat/phstat.eqn
===================================================================
--- /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_phstat/phstat.eqn (revision 3698)
+++ /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_phstat/phstat.eqn (revision 3698)
@@ -0,0 +1,9 @@
+{phstat.eqn
+Current revision
+----------------
+ 20180319 Photostationary O3-NO-NO2-equilibrium forkel
+}
+#EQUATIONS
+
+ { 1.} NO2 + hv = NO + O3 : phot(j_no2) ;
+ { 2.} NO + O3 = NO2 : arr2(1.8E-12_dp, 1370.0_dp, temp) ;
Index: /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_phstat/phstat.spc
===================================================================
--- /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_phstat/phstat.spc (revision 3698)
+++ /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_phstat/phstat.spc (revision 3698)
@@ -0,0 +1,19 @@
+{phstat.spc
+Former revisions
+----------------
+ $Id: smog.spc 2459 2017-09-13 14:10:33Z forkel $
+}
+#include atoms
+
+ #DEFVAR
+ O = O ; {oxygen atomic ground state (3P)}
+ O3 = 3O ; {ozone}
+ NO = N + O ; {nitric oxide}
+ NO2 = N + 2O ; {nitrogen dioxide}
+
+#DEFFIX
+ H2O = H + 2O ; {water}
+ H2 = 2H ; {molecular hydrogen}
+ O2 = 2O ; {molecular oxygen}
+ N2 = 2N ; {molecular nitrogen}
+
Index: /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_phstatp/chem_gasphase_mod.f90
===================================================================
--- /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_phstatp/chem_gasphase_mod.f90 (revision 3698)
+++ /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_phstatp/chem_gasphase_mod.f90 (revision 3698)
@@ -0,0 +1,2354 @@
+MODULE chem_gasphase_mod
+
+! Mechanism: phstatp
+!
+!------------------------------------------------------------------------------!
+!
+! ******Module chem_gasphase_mod is automatically generated by kpp4palm ******
+!
+! *********Please do NOT change this Code,it will be ovewritten *********
+!
+!------------------------------------------------------------------------------!
+! This file was created by KPP (http://people.cs.vt.edu/asandu/Software/Kpp/)
+! and kpp4palm (created by Klaus Ketelsen). kpp4palm is an adapted version
+! of KP4 (Jöckel,P.,Kerkweg,A.,Pozzer,A.,Sander,R.,Tost,H.,Riede,
+! H.,Baumgaertner,A.,Gromov,S.,and Kern,B.,2010: Development cycle 2 of
+! the Modular Earth Submodel System (MESSy2),Geosci. Model Dev.,3,717-752,
+! https://doi.org/10.5194/gmd-3-717-2010). KP4 is part of the Modular Earth
+! Submodel System (MESSy),which is is available under the GNU General Public
+! License (GPL).
+!
+! KPP is free software; you can redistribute it and/or modify it under the terms
+! of the General Public Licence as published by the Free Software Foundation;
+! 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 Licence for more details.
+!
+!------------------------------------------------------------------------------!
+! This file is part of the PALM model system.
+!
+! PALM is free software: you can redistribute it and/or modify it under the
+! terms of the GNU General Public License as published by the Free Software
+! Foundation,either version 3 of the License,or (at your option) any later
+! version.
+!
+! PALM 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
+! PALM. If not,see .
+!
+! Copyright 1997-2019 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+!
+! MODULE HEADER TEMPLATE
+!
+! Initial version (Nov. 2016,ketelsen),for later modifications of module_header
+! see comments in kpp4palm/src/create_kpp_module.C
+
+! Set kpp Double Precision to PALM Default Precision
+
+ USE kinds, ONLY: dp=>wp
+
+ USE pegrid, ONLY: myid, threads_per_task
+
+ IMPLICIT NONE
+ PRIVATE
+ !SAVE ! note: occurs again in automatically generated code ...
+
+! PUBLIC :: IERR_NAMES
+
+! PUBLIC :: SPC_NAMES,EQN_NAMES,EQN_TAGS,REQ_HET,REQ_AEROSOL,REQ_PHOTRAT &
+! ,REQ_MCFCT,IP_MAX,jname
+
+ PUBLIC :: eqn_names, phot_names, spc_names
+ PUBLIC :: nmaxfixsteps
+ PUBLIC :: atol, rtol
+ PUBLIC :: nspec, nreact
+ PUBLIC :: temp
+ PUBLIC :: qvap
+ PUBLIC :: fakt
+ PUBLIC :: phot
+ PUBLIC :: rconst
+ PUBLIC :: nvar
+ PUBLIC :: nphot
+ PUBLIC :: vl_dim ! PUBLIC to ebable other MODULEs to distiguish between scalar and vec
+
+ PUBLIC :: initialize, integrate, update_rconst
+ PUBLIC :: chem_gasphase_integrate
+ PUBLIC :: initialize_kpp_ctrl
+
+! END OF MODULE HEADER TEMPLATE
+
+! Variables used for vector mode
+
+ LOGICAL, PARAMETER :: l_vector = .FALSE.
+ INTEGER, PARAMETER :: i_lu_di = 2
+ INTEGER, PARAMETER :: vl_dim = 1
+ INTEGER :: vl
+
+ INTEGER :: vl_glo
+ INTEGER :: is, ie
+
+
+ INTEGER, DIMENSION(vl_dim) :: kacc, krej
+ INTEGER, DIMENSION(vl_dim) :: ierrv
+ LOGICAL :: data_loaded = .FALSE.
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Parameter Module File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Parameters.f90
+! Time : Fri Nov 30 13:52:19 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! NSPEC - Number of chemical species
+ INTEGER, PARAMETER :: nspec = 4
+! NVAR - Number of Variable species
+ INTEGER, PARAMETER :: nvar = 4
+! NVARACT - Number of Active species
+ INTEGER, PARAMETER :: nvaract = 4
+! NFIX - Number of Fixed species
+ INTEGER, PARAMETER :: nfix = 1
+! NREACT - Number of reactions
+ INTEGER, PARAMETER :: nreact = 3
+! NVARST - Starting of variables in conc. vect.
+ INTEGER, PARAMETER :: nvarst = 1
+! NFIXST - Starting of fixed in conc. vect.
+ INTEGER, PARAMETER :: nfixst = 5
+! NONZERO - Number of nonzero entries in Jacobian
+ INTEGER, PARAMETER :: nonzero = 10
+! LU_NONZERO - Number of nonzero entries in LU factoriz. of Jacobian
+ INTEGER, PARAMETER :: lu_nonzero = 10
+! CNVAR - (NVAR+1) Number of elements in compressed row format
+ INTEGER, PARAMETER :: cnvar = 5
+! CNEQN - (NREACT+1) Number stoicm elements in compressed col format
+ INTEGER, PARAMETER :: cneqn = 4
+! NHESS - Length of Sparse Hessian
+ INTEGER, PARAMETER :: nhess = 3
+! NMASS - Number of atoms to check mass balance
+ INTEGER, PARAMETER :: nmass = 1
+
+! Index declaration for variable species in C and VAR
+! VAR(ind_spc) = C(ind_spc)
+
+ INTEGER, PARAMETER, PUBLIC :: ind_pm10 = 1
+ INTEGER, PARAMETER, PUBLIC :: ind_no = 2
+ INTEGER, PARAMETER, PUBLIC :: ind_no2 = 3
+ INTEGER, PARAMETER, PUBLIC :: ind_o3 = 4
+
+! Index declaration for fixed species in C
+! C(ind_spc)
+
+
+! Index declaration for fixed species in FIX
+! FIX(indf_spc) = C(ind_spc) = C(NVAR+indf_spc)
+
+
+! NJVRP - Length of sparse Jacobian JVRP
+ INTEGER, PARAMETER :: njvrp = 4
+
+! NSTOICM - Length of Sparse Stoichiometric Matrix
+ INTEGER, PARAMETER :: nstoicm = 6
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Global Data Module File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Global.f90
+! Time : Fri Nov 30 13:52:19 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! Declaration of global variables
+
+! C - Concentration of all species
+ REAL(kind=dp):: c(nspec)
+! VAR - Concentrations of variable species (global)
+ REAL(kind=dp):: var(nvar)
+! FIX - Concentrations of fixed species (global)
+ REAL(kind=dp):: fix(nfix)
+! VAR,FIX are chunks of array C
+ EQUIVALENCE( c(1), var(1))
+! RCONST - Rate constants (global)
+ REAL(kind=dp):: rconst(nreact)
+! TIME - Current integration time
+ REAL(kind=dp):: time
+! TEMP - Temperature
+ REAL(kind=dp):: temp
+! TSTART - Integration start time
+ REAL(kind=dp):: tstart
+! ATOL - Absolute tolerance
+ REAL(kind=dp):: atol(nvar)
+! RTOL - Relative tolerance
+ REAL(kind=dp):: rtol(nvar)
+! STEPMIN - Lower bound for integration step
+ REAL(kind=dp):: stepmin
+! CFACTOR - Conversion factor for concentration units
+ REAL(kind=dp):: cfactor
+
+! INLINED global variable declarations
+
+! QVAP - Water vapor
+ REAL(kind=dp):: qvap
+! FAKT - Conversion factor
+ REAL(kind=dp):: fakt
+
+
+! INLINED global variable declarations
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Sparse Jacobian Data Structures File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_JacobianSP.f90
+! Time : Fri Nov 30 13:52:19 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! Sparse Jacobian Data
+
+
+ INTEGER, PARAMETER, DIMENSION(10):: lu_irow = (/ &
+ 1, 2, 2, 2, 3, 3, 3, 4, 4, 4 /)
+
+ INTEGER, PARAMETER, DIMENSION(10):: lu_icol = (/ &
+ 1, 2, 3, 4, 2, 3, 4, 2, 3, 4 /)
+
+ INTEGER, PARAMETER, DIMENSION(5):: lu_crow = (/ &
+ 1, 2, 5, 8, 11 /)
+
+ INTEGER, PARAMETER, DIMENSION(5):: lu_diag = (/ &
+ 1, 2, 6, 10, 11 /)
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Utility Data Module File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Monitor.f90
+! Time : Fri Nov 30 13:52:19 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+ CHARACTER(len=15), PARAMETER, DIMENSION(4):: spc_names = (/ &
+ 'PM10 ','NO ','NO2 ',&
+ 'O3 ' /)
+
+ CHARACTER(len=100), PARAMETER, DIMENSION(3):: eqn_names = (/ &
+ ' NO2 --> NO + O3 ',&
+ 'NO + O3 --> NO2 ',&
+ ' PM10 --> PM10 ' /)
+
+! INLINED global variables
+
+ ! inline f90_data: declaration of global variables for photolysis
+ ! REAL(kind=dp):: phot(nphot)must eventually be moved to global later for
+ INTEGER, PARAMETER :: nphot = 1
+ ! phot photolysis frequencies
+ REAL(kind=dp):: phot(nphot)
+
+ INTEGER, PARAMETER, PUBLIC :: j_no2 = 1
+
+ CHARACTER(len=15), PARAMETER, DIMENSION(nphot):: phot_names = (/ &
+ 'J_NO2 '/)
+
+! End INLINED global variables
+
+
+! Automatic generated PUBLIC Statements for ip_ and ihs_ variables
+
+! Automatic generated PUBLIC Statements for ip_ and ihs_ variables
+
+! Automatic generated PUBLIC Statements for ip_ and ihs_ variables
+
+! Automatic generated PUBLIC Statements for ip_ and ihs_ variables
+
+
+! variable definations from individual module headers
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Initialization File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Initialize.f90
+! Time : Fri Nov 30 13:52:19 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Numerical Integrator (Time-Stepping) File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Integrator.f90
+! Time : Fri Nov 30 13:52:19 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! INTEGRATE - Integrator routine
+! Arguments :
+! TIN - Start Time for Integration
+! TOUT - End Time for Integration
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!
+! 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 !
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!
+
+
+ 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
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Linear Algebra Data and Routines File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_LinearAlgebra.f90
+! Time : Fri Nov 30 13:52:19 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! The ODE Jacobian of Chemical Model File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Jacobian.f90
+! Time : Fri Nov 30 13:52:19 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! The ODE Function of Chemical Model File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Function.f90
+! Time : Fri Nov 30 13:52:19 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+! A - Rate for each equation
+ REAL(kind=dp):: a(nreact)
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! The Reaction Rates File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Rates.f90
+! Time : Fri Nov 30 13:52:19 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Auxiliary Routines File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Util.f90
+! Time : Fri Nov 30 13:52:19 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+ ! header MODULE initialize_kpp_ctrl_template
+
+ ! notes:
+ ! - l_vector is automatically defined by kp4
+ ! - vl_dim is automatically defined by kp4
+ ! - i_lu_di is automatically defined by kp4
+ ! - wanted is automatically defined by xmecca
+ ! - icntrl rcntrl are automatically defined by kpp
+ ! - "USE messy_main_tools" is in MODULE_header of messy_mecca_kpp.f90
+ ! - SAVE will be automatically added by kp4
+
+ !SAVE
+
+ ! for fixed time step control
+ ! ... max. number of fixed time steps (sum must be 1)
+ INTEGER, PARAMETER :: nmaxfixsteps = 50
+ ! ... switch for fixed time stepping
+ LOGICAL, PUBLIC :: l_fixed_step = .FALSE.
+ INTEGER, PUBLIC :: nfsteps = 1
+ ! ... number of kpp control PARAMETERs
+ INTEGER, PARAMETER, PUBLIC :: nkppctrl = 20
+ !
+ INTEGER, DIMENSION(nkppctrl), PUBLIC :: icntrl = 0
+ REAL(dp), DIMENSION(nkppctrl), PUBLIC :: rcntrl = 0.0_dp
+ REAL(dp), DIMENSION(nmaxfixsteps), PUBLIC :: t_steps = 0.0_dp
+
+ ! END header MODULE initialize_kpp_ctrl_template
+
+
+! Interface Block
+
+ INTERFACE initialize
+ MODULE PROCEDURE initialize
+ END INTERFACE initialize
+
+ INTERFACE integrate
+ MODULE PROCEDURE integrate
+ END INTERFACE integrate
+
+ INTERFACE fun
+ MODULE PROCEDURE fun
+ END INTERFACE fun
+
+ INTERFACE kppsolve
+ MODULE PROCEDURE kppsolve
+ END INTERFACE kppsolve
+
+ INTERFACE jac_sp
+ MODULE PROCEDURE jac_sp
+ END INTERFACE jac_sp
+
+ INTERFACE k_arr
+ MODULE PROCEDURE k_arr
+ END INTERFACE k_arr
+
+ INTERFACE update_rconst
+ MODULE PROCEDURE update_rconst
+ END INTERFACE update_rconst
+
+ INTERFACE arr2
+ MODULE PROCEDURE arr2
+ END INTERFACE arr2
+
+ INTERFACE initialize_kpp_ctrl
+ MODULE PROCEDURE initialize_kpp_ctrl
+ END INTERFACE initialize_kpp_ctrl
+
+ INTERFACE error_output
+ MODULE PROCEDURE error_output
+ END INTERFACE error_output
+
+ INTERFACE wscal
+ MODULE PROCEDURE wscal
+ END INTERFACE wscal
+
+!INTERFACE not working INTERFACE waxpy
+!INTERFACE not working MODULE PROCEDURE waxpy
+!INTERFACE not working END INTERFACE waxpy
+
+ INTERFACE rosenbrock
+ MODULE PROCEDURE rosenbrock
+ END INTERFACE rosenbrock
+
+ INTERFACE funtemplate
+ MODULE PROCEDURE funtemplate
+ END INTERFACE funtemplate
+
+ INTERFACE jactemplate
+ MODULE PROCEDURE jactemplate
+ END INTERFACE jactemplate
+
+ INTERFACE kppdecomp
+ MODULE PROCEDURE kppdecomp
+ END INTERFACE kppdecomp
+
+ INTERFACE chem_gasphase_integrate
+ MODULE PROCEDURE chem_gasphase_integrate
+ END INTERFACE chem_gasphase_integrate
+
+
+ CONTAINS
+
+SUBROUTINE initialize()
+
+
+ INTEGER :: j, k
+
+ INTEGER :: i
+ REAL(kind=dp):: x
+ k = is
+ cfactor = 1.000000e+00_dp
+
+ x = (0.) * cfactor
+ DO i = 1 , nvar
+ ENDDO
+
+ x = (0.) * cfactor
+ DO i = 1 , nfix
+ fix(i) = x
+ ENDDO
+
+! constant rate coefficients
+! END constant rate coefficients
+
+! INLINED initializations
+
+! End INLINED initializations
+
+
+END SUBROUTINE initialize
+
+SUBROUTINE integrate( tin, tout, &
+ icntrl_u, rcntrl_u, istatus_u, rstatus_u, ierr_u)
+
+
+ REAL(kind=dp), INTENT(IN):: tin ! start time
+ REAL(kind=dp), INTENT(IN):: tout ! END time
+ ! OPTIONAL input PARAMETERs and statistics
+ INTEGER, INTENT(IN), OPTIONAL :: icntrl_u(20)
+ REAL(kind=dp), INTENT(IN), OPTIONAL :: rcntrl_u(20)
+ INTEGER, INTENT(OUT), OPTIONAL :: istatus_u(20)
+ REAL(kind=dp), INTENT(OUT), OPTIONAL :: rstatus_u(20)
+ INTEGER, INTENT(OUT), OPTIONAL :: ierr_u
+
+ REAL(kind=dp):: 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(:)
+ ENDIF
+ IF (PRESENT(rcntrl_u))THEN
+ WHERE(rcntrl_u(:)> 0)rcntrl(:) = rcntrl_u(:)
+ ENDIF
+
+
+ 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 fun(v, f, rct, vdot)
+
+! V - Concentrations of variable species (local)
+ REAL(kind=dp):: v(nvar)
+! F - Concentrations of fixed species (local)
+ REAL(kind=dp):: f(nfix)
+! RCT - Rate constants (local)
+ REAL(kind=dp):: rct(nreact)
+! Vdot - Time derivative of variable species concentrations
+ REAL(kind=dp):: vdot(nvar)
+
+
+! Computation of equation rates
+ a(1) = rct(1) * v(3)
+ a(2) = rct(2) * v(2) * v(4)
+
+! Aggregate function
+ vdot(1) = 0
+ vdot(2) = a(1) - a(2)
+ vdot(3) = - a(1) + a(2)
+ vdot(4) = a(1) - a(2)
+
+END SUBROUTINE fun
+
+SUBROUTINE kppsolve(jvs, x)
+
+! JVS - sparse Jacobian of variables
+ REAL(kind=dp):: jvs(lu_nonzero)
+! X - Vector for variables
+ REAL(kind=dp):: x(nvar)
+
+ x(3) = x(3) - jvs(5) * x(2)
+ x(4) = x(4) - jvs(8) * x(2) - jvs(9) * x(3)
+ x(4) = x(4) / jvs(10)
+ x(3) = (x(3) - jvs(7) * x(4)) /(jvs(6))
+ x(2) = (x(2) - jvs(3) * x(3) - jvs(4) * x(4)) /(jvs(2))
+ x(1) = x(1) / jvs(1)
+
+END SUBROUTINE kppsolve
+
+SUBROUTINE jac_sp(v, f, rct, jvs)
+
+! V - Concentrations of variable species (local)
+ REAL(kind=dp):: v(nvar)
+! F - Concentrations of fixed species (local)
+ REAL(kind=dp):: f(nfix)
+! RCT - Rate constants (local)
+ REAL(kind=dp):: rct(nreact)
+! JVS - sparse Jacobian of variables
+ REAL(kind=dp):: jvs(lu_nonzero)
+
+
+! Local variables
+! B - Temporary array
+ REAL(kind=dp):: b(4)
+
+! B(1) = dA(1)/dV(3)
+ b(1) = rct(1)
+! B(2) = dA(2)/dV(2)
+ b(2) = rct(2) * v(4)
+! B(3) = dA(2)/dV(4)
+ b(3) = rct(2) * v(2)
+! B(4) = dA(3)/dV(1)
+ b(4) = rct(3)
+
+! Construct the Jacobian terms from B's
+! JVS(1) = Jac_FULL(1,1)
+ jvs(1) = 0
+! JVS(2) = Jac_FULL(2,2)
+ jvs(2) = - b(2)
+! JVS(3) = Jac_FULL(2,3)
+ jvs(3) = b(1)
+! JVS(4) = Jac_FULL(2,4)
+ jvs(4) = - b(3)
+! JVS(5) = Jac_FULL(3,2)
+ jvs(5) = b(2)
+! JVS(6) = Jac_FULL(3,3)
+ jvs(6) = - b(1)
+! JVS(7) = Jac_FULL(3,4)
+ jvs(7) = b(3)
+! JVS(8) = Jac_FULL(4,2)
+ jvs(8) = - b(2)
+! JVS(9) = Jac_FULL(4,3)
+ jvs(9) = b(1)
+! JVS(10) = Jac_FULL(4,4)
+ jvs(10) = - b(3)
+
+END SUBROUTINE jac_sp
+
+ elemental REAL(kind=dp)FUNCTION k_arr (k_298, tdep, temp)
+ ! arrhenius FUNCTION
+
+ REAL, INTENT(IN):: k_298 ! k at t = 298.15k
+ REAL, INTENT(IN):: tdep ! temperature dependence
+ REAL(kind=dp), INTENT(IN):: temp ! temperature
+
+ intrinsic exp
+
+ k_arr = k_298 * exp(tdep* (1._dp/temp- 3.3540e-3_dp))! 1/298.15=3.3540e-3
+
+ END FUNCTION k_arr
+
+SUBROUTINE update_rconst()
+ INTEGER :: k
+
+ k = is
+
+! Begin INLINED RCONST
+
+
+! End INLINED RCONST
+
+ rconst(1) = (phot(j_no2))
+ rconst(2) = (arr2(1.8e-12_dp , 1370.0_dp , temp))
+ rconst(3) = (1.0_dp)
+
+END SUBROUTINE update_rconst
+
+! END FUNCTION ARR2
+REAL(kind=dp)FUNCTION arr2( a0, b0, temp)
+ REAL(kind=dp):: temp
+ REAL(kind=dp):: a0, b0
+ arr2 = a0 * exp( - b0 / temp)
+END FUNCTION arr2
+
+SUBROUTINE initialize_kpp_ctrl(status)
+
+
+ ! i/o
+ INTEGER, INTENT(OUT):: status
+
+ ! local
+ REAL(dp):: tsum
+ INTEGER :: i
+
+ ! check fixed time steps
+ tsum = 0.0_dp
+ DO i=1, nmaxfixsteps
+ IF (t_steps(i)< tiny(0.0_dp))exit
+ tsum = tsum + t_steps(i)
+ ENDDO
+
+ nfsteps = i- 1
+
+ l_fixed_step = (nfsteps > 0).and.((tsum - 1.0)< tiny(0.0_dp))
+
+ IF (l_vector)THEN
+ WRITE(*,*) ' MODE : VECTOR (LENGTH=',VL_DIM,')'
+ ELSE
+ WRITE(*,*) ' MODE : SCALAR'
+ ENDIF
+ !
+ WRITE(*,*) ' DE-INDEXING MODE :',I_LU_DI
+ !
+ WRITE(*,*) ' ICNTRL : ',icntrl
+ WRITE(*,*) ' RCNTRL : ',rcntrl
+ !
+ ! note: this is ONLY meaningful for vectorized (kp4)rosenbrock- methods
+ IF (l_vector)THEN
+ IF (l_fixed_step)THEN
+ WRITE(*,*) ' TIME STEPS : FIXED (',t_steps(1:nfsteps),')'
+ ELSE
+ WRITE(*,*) ' TIME STEPS : AUTOMATIC'
+ ENDIF
+ ELSE
+ WRITE(*,*) ' TIME STEPS : AUTOMATIC '//&
+ &'(t_steps (CTRL_KPP) ignored in SCALAR MODE)'
+ ENDIF
+ ! mz_pj_20070531-
+
+ status = 0
+
+
+END SUBROUTINE initialize_kpp_ctrl
+
+SUBROUTINE error_output(c, ierr, pe)
+
+
+ INTEGER, INTENT(IN):: ierr
+ INTEGER, INTENT(IN):: pe
+ REAL(dp), DIMENSION(:), INTENT(IN):: c
+
+ write(6,*) 'ERROR in chem_gasphase_mod ',ierr,C(1)
+
+
+END SUBROUTINE error_output
+
+ SUBROUTINE wscal(n, alpha, x, incx)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+! constant times a vector: x(1:N) <- Alpha*x(1:N)
+! only for incX=incY=1
+! after BLAS
+! replace this by the function from the optimized BLAS implementation:
+! CALL SSCAL(N,Alpha,X,1) or CALL DSCAL(N,Alpha,X,1)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ INTEGER :: i, incx, m, mp1, n
+ REAL(kind=dp) :: x(n), alpha
+ REAL(kind=dp), PARAMETER :: zero=0.0_dp, one=1.0_dp
+
+ IF (alpha .eq. one)RETURN
+ IF (n .le. 0)RETURN
+
+ m = mod(n, 5)
+ IF ( m .ne. 0)THEN
+ IF (alpha .eq. (- one))THEN
+ DO i = 1, m
+ x(i) = - x(i)
+ ENDDO
+ ELSEIF (alpha .eq. zero)THEN
+ DO i = 1, m
+ x(i) = zero
+ ENDDO
+ ELSE
+ DO i = 1, m
+ x(i) = alpha* x(i)
+ ENDDO
+ ENDIF
+ IF ( n .lt. 5)RETURN
+ ENDIF
+ mp1 = m + 1
+ IF (alpha .eq. (- one))THEN
+ DO i = mp1, n, 5
+ x(i) = - x(i)
+ x(i + 1) = - x(i + 1)
+ x(i + 2) = - x(i + 2)
+ x(i + 3) = - x(i + 3)
+ x(i + 4) = - x(i + 4)
+ ENDDO
+ ELSEIF (alpha .eq. zero)THEN
+ DO i = mp1, n, 5
+ x(i) = zero
+ x(i + 1) = zero
+ x(i + 2) = zero
+ x(i + 3) = zero
+ x(i + 4) = zero
+ ENDDO
+ ELSE
+ DO i = mp1, n, 5
+ x(i) = alpha* x(i)
+ x(i + 1) = alpha* x(i + 1)
+ x(i + 2) = alpha* x(i + 2)
+ x(i + 3) = alpha* x(i + 3)
+ x(i + 4) = alpha* x(i + 4)
+ ENDDO
+ ENDIF
+
+ END SUBROUTINE wscal
+
+ SUBROUTINE waxpy(n, alpha, x, incx, y, incy)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+! constant times a vector plus a vector: y <- y + Alpha*x
+! only for incX=incY=1
+! after BLAS
+! replace this by the function from the optimized BLAS implementation:
+! CALL SAXPY(N,Alpha,X,1,Y,1) or CALL DAXPY(N,Alpha,X,1,Y,1)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ INTEGER :: i, incx, incy, m, mp1, n
+ REAL(kind=dp):: x(n), y(n), alpha
+ REAL(kind=dp), PARAMETER :: zero = 0.0_dp
+
+ IF (alpha .eq. zero)RETURN
+ IF (n .le. 0)RETURN
+
+ m = mod(n, 4)
+ IF ( m .ne. 0)THEN
+ DO i = 1, m
+ y(i) = y(i) + alpha* x(i)
+ ENDDO
+ IF ( n .lt. 4)RETURN
+ ENDIF
+ mp1 = m + 1
+ DO i = mp1, n, 4
+ y(i) = y(i) + alpha* x(i)
+ y(i + 1) = y(i + 1) + alpha* x(i + 1)
+ y(i + 2) = y(i + 2) + alpha* x(i + 2)
+ y(i + 3) = y(i + 3) + alpha* x(i + 3)
+ ENDDO
+
+ END SUBROUTINE waxpy
+
+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
+!
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+!~~~> arguments
+ INTEGER, INTENT(IN) :: n
+ REAL(kind=dp), INTENT(INOUT):: y(n)
+ REAL(kind=dp), INTENT(IN) :: tstart, tend
+ REAL(kind=dp), INTENT(IN) :: abstol(n), reltol(n)
+ INTEGER, INTENT(IN) :: icntrl(20)
+ REAL(kind=dp), INTENT(IN) :: rcntrl(20)
+ INTEGER, INTENT(INOUT):: istatus(20)
+ REAL(kind=dp), 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
+ REAL(kind=dp):: 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
+ REAL(kind=dp):: roundoff, facmin, facmax, facrej, facsafe
+ REAL(kind=dp):: hmin, hmax, hstart
+ REAL(kind=dp):: texit
+ INTEGER :: i, uplimtol, max_no_steps
+ LOGICAL :: autonomous, vectortol
+!~~~> PARAMETERs
+ REAL(kind=dp), PARAMETER :: zero = 0.0_dp, one = 1.0_dp
+ REAL(kind=dp), 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
+ ENDIF
+
+!~~~> 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
+ ENDIF
+
+!~~~> unit roundoff (1+ roundoff>1)
+ roundoff = epsilon(one)
+
+!~~~> 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
+ ENDIF
+!~~~> 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
+ ENDIF
+!~~~> 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
+ ENDIF
+!~~~> 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
+ ENDIF
+ 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
+ ENDIF
+!~~~> 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
+ ENDIF
+!~~~> 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
+ ENDIF
+!~~~> 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
+ ENDIF
+ ENDDO
+
+
+!~~~> 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ REAL(kind=dp), 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}
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+!~~~> input: the initial condition at tstart; output: the solution at t
+ REAL(kind=dp), INTENT(INOUT):: y(n)
+!~~~> input: integration interval
+ REAL(kind=dp), INTENT(IN):: tstart, tend
+!~~~> output: time at which the solution is RETURNed (t=tendIF success)
+ REAL(kind=dp), INTENT(OUT):: t
+!~~~> input: tolerances
+ REAL(kind=dp), INTENT(IN):: abstol(n), reltol(n)
+!~~~> input: integration PARAMETERs
+ LOGICAL, INTENT(IN):: autonomous, vectortol
+ REAL(kind=dp), INTENT(IN):: hstart, hmin, hmax
+ INTEGER, INTENT(IN):: max_no_steps
+ REAL(kind=dp), INTENT(IN):: roundoff, facmin, facmax, facrej, facsafe
+!~~~> output: error indicator
+ INTEGER, INTENT(OUT):: ierr
+! ~~~~ Local variables
+ REAL(kind=dp):: ynew(n), fcn0(n), fcn(n)
+ REAL(kind=dp):: k(n* ros_s), dfdt(n)
+#ifdef full_algebra
+ REAL(kind=dp):: jac0(n, n), ghimj(n, n)
+#else
+ REAL(kind=dp):: jac0(lu_nonzero), ghimj(lu_nonzero)
+#endif
+ REAL(kind=dp):: h, hnew, hc, hg, fac, tau
+ REAL(kind=dp):: err, yerr(n)
+ INTEGER :: pivot(n), direction, ioffset, j, istage
+ LOGICAL :: rejectlasth, rejectmoreh, singular
+!~~~> local PARAMETERs
+ REAL(kind=dp), PARAMETER :: zero = 0.0_dp, one = 1.0_dp
+ REAL(kind=dp), PARAMETER :: deltamin = 1.0e-5_dp
+!~~~> locally called FUNCTIONs
+! REAL(kind=dp) 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
+ ENDIF
+ 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
+ ENDIF
+ IF (((t+ 0.1_dp* h) == t).or.(h <= roundoff))THEN ! step size too small
+ CALL ros_errormsg(- 7, t, h, ierr)
+ RETURN
+ ENDIF
+
+!~~~> 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)
+ ENDIF
+
+!~~~> 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
+ ENDIF
+
+!~~~> 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
+ !slim: CALL wcopy(n, fcn0, 1, fcn, 1)
+ fcn(1:n) = fcn0(1:n)
+ ! istage>1 and a new FUNCTION evaluation is needed at the current istage
+ ELSEIF(ros_newf(istage))THEN
+ !slim: CALL wcopy(n, y, 1, ynew, 1)
+ ynew(1:n) = y(1:n)
+ DO j = 1, istage-1
+ CALL waxpy(n, ros_a((istage-1) * (istage-2) /2+ j), &
+ k(n* (j- 1) + 1), 1, ynew, 1)
+ ENDDO
+ tau = t + ros_alpha(istage) * direction* h
+ CALL funtemplate(tau, ynew, fcn)
+ istatus(nfun) = istatus(nfun) + 1
+ ENDIF ! IF istage == 1 ELSEIF ros_newf(istage)
+ !slim: CALL wcopy(n, fcn, 1, k(ioffset+ 1), 1)
+ k(ioffset+ 1:ioffset+ n) = fcn(1:n)
+ 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), 1, k(ioffset+ 1), 1)
+ ENDDO
+ 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), 1)
+ ENDIF
+ CALL ros_solve(ghimj, pivot, k(ioffset+ 1))
+
+ END DO stage
+
+
+!~~~> compute the new solution
+ !slim: CALL wcopy(n, y, 1, ynew, 1)
+ ynew(1:n) = y(1:n)
+ DO j=1, ros_s
+ CALL waxpy(n, ros_m(j), k(n* (j- 1) + 1), 1, ynew, 1)
+ ENDDO
+
+!~~~> compute the error estimation
+ !slim: CALL wscal(n, zero, yerr, 1)
+ yerr(1:n) = zero
+ DO j=1, ros_s
+ CALL waxpy(n, ros_e(j), k(n* (j- 1) + 1), 1, yerr, 1)
+ ENDDO
+ 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
+ !slim: CALL wcopy(n, ynew, 1, y, 1)
+ y(1:n) = ynew(1:n)
+ 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)
+ ENDIF
+ 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
+ ENDIF
+ rejectmoreh = rejectlasth
+ rejectlasth = .TRUE.
+ h = hnew
+ IF (istatus(nacc)>= 1) istatus(nrej) = istatus(nrej) + 1
+ ENDIF ! err <= 1
+
+ END DO untilaccepted
+
+ END DO timeloop
+
+!~~~> succesful exit
+ ierr = 1 !~~~> the integration was successful
+
+ END SUBROUTINE ros_integrator
+
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ REAL(kind=dp)FUNCTION ros_errornorm(y, ynew, yerr, &
+ abstol, reltol, vectortol)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> computes the "scaled norm" of the error vector yerr
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+! Input arguments
+ REAL(kind=dp), INTENT(IN):: y(n), ynew(n), &
+ yerr(n), abstol(n), reltol(n)
+ LOGICAL, INTENT(IN):: vectortol
+! Local variables
+ REAL(kind=dp):: err, scale, ymax
+ INTEGER :: i
+ REAL(kind=dp), 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
+ ENDIF
+ err = err+ (yerr(i) /scale) ** 2
+ ENDDO
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+!~~~> input arguments
+ REAL(kind=dp), INTENT(IN):: t, roundoff, y(n), fcn0(n)
+!~~~> output arguments
+ REAL(kind=dp), INTENT(OUT):: dfdt(n)
+!~~~> local variables
+ REAL(kind=dp):: delta
+ REAL(kind=dp), 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
+! --- --- --- --- --- --- --- --- --- --- --- --- ---
+
+!~~~> input arguments
+#ifdef full_algebra
+ REAL(kind=dp), INTENT(IN):: jac0(n, n)
+#else
+ REAL(kind=dp), INTENT(IN):: jac0(lu_nonzero)
+#endif
+ REAL(kind=dp), INTENT(IN):: gam
+ INTEGER, INTENT(IN):: direction
+!~~~> output arguments
+#ifdef full_algebra
+ REAL(kind=dp), INTENT(OUT):: ghimj(n, n)
+#else
+ REAL(kind=dp), INTENT(OUT):: ghimj(lu_nonzero)
+#endif
+ LOGICAL, INTENT(OUT):: singular
+ INTEGER, INTENT(OUT):: pivot(n)
+!~~~> inout arguments
+ REAL(kind=dp), INTENT(INOUT):: h ! step size is decreased when lu fails
+!~~~> local variables
+ INTEGER :: i, ising, nconsecutive
+ REAL(kind=dp):: ghinv
+ REAL(kind=dp), 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
+ !slim: CALL wcopy(n* n, jac0, 1, ghimj, 1)
+ !slim: CALL wscal(n* n, (- one), ghimj, 1)
+ ghimj = - jac0
+ ghinv = one/(direction* h* gam)
+ DO i=1, n
+ ghimj(i, i) = ghimj(i, i) + ghinv
+ ENDDO
+#else
+ !slim: CALL wcopy(lu_nonzero, jac0, 1, ghimj, 1)
+ !slim: CALL wscal(lu_nonzero, (- one), ghimj, 1)
+ ghimj(1:lu_nonzero) = - jac0(1:lu_nonzero)
+ ghinv = one/(direction* h* gam)
+ DO i=1, n
+ ghimj(lu_diag(i)) = ghimj(lu_diag(i)) + ghinv
+ ENDDO
+#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
+ ENDIF ! nconsecutive
+ ENDIF ! ising
+
+ END DO ! WHILE singular
+
+ END SUBROUTINE ros_preparematrix
+
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE ros_decomp( a, pivot, ising)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! Template for the LU decomposition
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> inout variables
+#ifdef full_algebra
+ REAL(kind=dp), INTENT(INOUT):: a(n, n)
+#else
+ REAL(kind=dp), INTENT(INOUT):: a(lu_nonzero)
+#endif
+!~~~> 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)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> input variables
+#ifdef full_algebra
+ REAL(kind=dp), INTENT(IN):: a(n, n)
+ INTEGER :: ising
+#else
+ REAL(kind=dp), INTENT(IN):: a(lu_nonzero)
+#endif
+ INTEGER, INTENT(IN):: pivot(n)
+!~~~> inout variables
+ REAL(kind=dp), INTENT(INOUT):: b(n)
+
+#ifdef full_algebra
+ CALL DGETRS( 'N',N ,1,A,N,Pivot,b,N,ISING)
+ IF (info < 0)THEN
+ print* , "error in dgetrs. ising=", ising
+ ENDIF
+#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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ 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)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+ 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)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> input variables
+ REAL(kind=dp):: t, y(nvar)
+!~~~> output variables
+ REAL(kind=dp):: ydot(nvar)
+!~~~> local variables
+ REAL(kind=dp):: told
+
+ told = time
+ time = t
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> input variables
+ REAL(kind=dp):: t, y(nvar)
+!~~~> output variables
+#ifdef full_algebra
+ REAL(kind=dp):: jv(lu_nonzero), jcb(nvar, nvar)
+#else
+ REAL(kind=dp):: jcb(lu_nonzero)
+#endif
+!~~~> local variables
+ REAL(kind=dp):: told
+#ifdef full_algebra
+ INTEGER :: i, j
+#endif
+
+ told = time
+ time = t
+#ifdef full_algebra
+ CALL jac_sp(y, fix, rconst, jv)
+ DO j=1, nvar
+ DO i=1, nvar
+ jcb(i, j) = 0.0_dp
+ ENDDO
+ ENDDO
+ DO i=1, lu_nonzero
+ jcb(lu_irow(i), lu_icol(i)) = jv(i)
+ ENDDO
+#else
+ CALL jac_sp( y, fix, rconst, jcb)
+#endif
+ time = told
+
+END SUBROUTINE jactemplate
+
+ SUBROUTINE kppdecomp( jvs, ier)
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! sparse lu factorization
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! loop expansion generated by kp4
+
+ INTEGER :: ier
+ REAL(kind=dp):: jvs(lu_nonzero), w(nvar), a
+ INTEGER :: k, kk, j, jj
+
+ a = 0.
+ ier = 0
+
+! i = 1
+! i = 2
+! i = 3
+ jvs(5) = (jvs(5)) / jvs(2)
+ jvs(6) = jvs(6) - jvs(3) * jvs(5)
+ jvs(7) = jvs(7) - jvs(4) * jvs(5)
+! i = 4
+ jvs(8) = (jvs(8)) / jvs(2)
+ a = 0.0; a = a - jvs(3) * jvs(8)
+ jvs(9) = (jvs(9) + a) / jvs(6)
+ jvs(10) = jvs(10) - jvs(4) * jvs(8) - jvs(7) * jvs(9)
+ RETURN
+
+ END SUBROUTINE kppdecomp
+
+SUBROUTINE chem_gasphase_integrate (time_step_len, conc, tempi, qvapi, fakti, photo, ierrf, xnacc, xnrej, istatus, l_debug, pe, &
+ icntrl_i, rcntrl_i)
+
+ IMPLICIT NONE
+
+ REAL(dp), INTENT(IN) :: time_step_len
+ REAL(dp), DIMENSION(:, :), INTENT(INOUT) :: conc
+ REAL(dp), DIMENSION(:, :), INTENT(IN) :: photo
+ REAL(dp), DIMENSION(:), INTENT(IN) :: tempi
+ REAL(dp), DIMENSION(:), INTENT(IN) :: qvapi
+ REAL(dp), DIMENSION(:), INTENT(IN) :: fakti
+ INTEGER, INTENT(OUT), OPTIONAL :: ierrf(:)
+ INTEGER, INTENT(OUT), OPTIONAL :: xnacc(:)
+ INTEGER, INTENT(OUT), OPTIONAL :: xnrej(:)
+ INTEGER, INTENT(INOUT), OPTIONAL :: istatus(:)
+ INTEGER, INTENT(IN), OPTIONAL :: pe
+ LOGICAL, INTENT(IN), OPTIONAL :: l_debug
+ INTEGER, DIMENSION(nkppctrl), INTENT(IN), OPTIONAL :: icntrl_i
+ REAL(dp), DIMENSION(nkppctrl), INTENT(IN), OPTIONAL :: rcntrl_i
+
+ INTEGER :: k ! loop variable
+ REAL(dp) :: dt
+ INTEGER, DIMENSION(20) :: istatus_u
+ INTEGER :: ierr_u
+ INTEGER :: istatf
+ INTEGER :: vl_dim_lo
+
+
+ IF (PRESENT (istatus)) istatus = 0
+ IF (PRESENT (icntrl_i)) icntrl = icntrl_i
+ IF (PRESENT (rcntrl_i)) rcntrl = rcntrl_i
+
+ vl_glo = size(tempi, 1)
+
+ vl_dim_lo = vl_dim
+ DO k=1, vl_glo, vl_dim_lo
+ is = k
+ ie = min(k+ vl_dim_lo-1, vl_glo)
+ vl = ie-is+ 1
+
+ c(:) = conc(is, :)
+
+ temp = tempi(is)
+
+ qvap = qvapi(is)
+
+ fakt = fakti(is)
+
+ CALL initialize
+
+ phot(:) = photo(is, :)
+
+ CALL update_rconst
+
+ dt = time_step_len
+
+ ! integrate from t=0 to t=dt
+ CALL integrate(0._dp, dt, icntrl, rcntrl, istatus_u = istatus_u, ierr_u=ierr_u)
+
+
+ IF (PRESENT(l_debug) .AND. PRESENT(pe)) THEN
+ IF (l_debug) CALL error_output(conc(is, :), ierr_u, pe)
+ ENDIF
+
+ conc(is, :) = c(:)
+
+ ! RETURN diagnostic information
+
+ IF (PRESENT(ierrf)) ierrf(is) = ierr_u
+ IF (PRESENT(xnacc)) xnacc(is) = istatus_u(4)
+ IF (PRESENT(xnrej)) xnrej(is) = istatus_u(5)
+
+ IF (PRESENT (istatus)) THEN
+ istatus(1:8) = istatus(1:8) + istatus_u(1:8)
+ ENDIF
+
+ END DO
+
+
+! Deallocate input arrays
+
+
+ data_loaded = .FALSE.
+
+ RETURN
+END SUBROUTINE chem_gasphase_integrate
+
+END MODULE chem_gasphase_mod
+
Index: /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_phstatp/chem_gasphase_mod.kpp
===================================================================
--- /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_phstatp/chem_gasphase_mod.kpp (revision 3698)
+++ /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_phstatp/chem_gasphase_mod.kpp (revision 3698)
@@ -0,0 +1,33 @@
+//chem_gasphase_mod.kpp
+//
+//Former revisions
+//----------------
+// $Id: chem_gasphase_mod.kpp 2459 2017-09-13 14:10:33Z forkel $
+// initial revision branch chemistry rev 3453 (30.10.2018, forkel)
+//
+#include phstatp.spc
+#include phstatp.eqn
+#INTEGRATOR rosenbrock
+#LANGUAGE Fortran90
+#HESSIAN on
+#STOICMAT on
+//
+// *******************************************************************************************
+// *** adapt the lines below occurding to the photolysis reactions of your mechanism *
+// *** adapt the number of photolysis frequencies NPHO *
+// *** adapt/extend the indices in the INTEGER, PARAMETER,PUBLIC statement below *
+// *** adapt/extend PHOT_NAMES: Note that the order of PHOT_NAMES and the indices must match *
+// *******************************************************************************************
+//
+#INLINE F90_DATA
+ ! INLINE F90_DATA: Declaration of global variables for photolysis
+ ! REAL(kind=dp) :: phot(nphot) must eventually be moved to GLOBAL later for vector version
+ INTEGER, PARAMETER :: nphot = 1
+ ! phot Photolysis frequencies
+ REAL(kind=dp) :: phot(nphot)
+
+ INTEGER, PARAMETER,PUBLIC :: j_no2 = 1
+
+ CHARACTER(LEN=15), PARAMETER, DIMENSION(NPHOT) :: phot_names = (/ &
+ 'J_NO2 '/)
+#ENDINLINE
Index: /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_phstatp/phstatp.eqn
===================================================================
--- /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_phstatp/phstatp.eqn (revision 3698)
+++ /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_phstatp/phstatp.eqn (revision 3698)
@@ -0,0 +1,10 @@
+{phstatp.eqn
+Current revision
+----------------
+ 20180319 Photostationary O3-NO-NO2-equilibrium forkel
+}
+#EQUATIONS
+
+ { 1.} NO2 + hv = NO + O3 : phot(j_no2) ;
+ { 2.} NO + O3 = NO2 : arr2(1.8E-12_dp, 1370.0_dp, temp) ;
+ { 3.} PM10 = PM10 : 1.0_dp ;
Index: /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_phstatp/phstatp.spc
===================================================================
--- /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_phstatp/phstatp.spc (revision 3698)
+++ /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_phstatp/phstatp.spc (revision 3698)
@@ -0,0 +1,20 @@
+{phstatp.spc
+Former revisions
+----------------
+ $Id: smog.spc 2459 2017-09-13 14:10:33Z forkel $
+}
+#include atoms
+
+ #DEFVAR
+ O = O ; {oxygen atomic ground state (3P)}
+ O3 = 3O ; {ozone}
+ NO = N + O ; {nitric oxide}
+ NO2 = N + 2O ; {nitrogen dioxide}
+ PM10 = ignore ; {PM10}
+
+#DEFFIX
+ H2O = H + 2O ; {water}
+ H2 = 2H ; {molecular hydrogen}
+ O2 = 2O ; {molecular oxygen}
+ N2 = 2N ; {molecular nitrogen}
+
Index: /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+phstat/chem_gasphase_mod.f90
===================================================================
--- /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+phstat/chem_gasphase_mod.f90 (revision 3698)
+++ /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+phstat/chem_gasphase_mod.f90 (revision 3698)
@@ -0,0 +1,2352 @@
+MODULE chem_gasphase_mod
+
+! Mechanism: salsa+phstat
+!
+!------------------------------------------------------------------------------!
+!
+! ******Module chem_gasphase_mod is automatically generated by kpp4palm ******
+!
+! *********Please do NOT change this Code,it will be ovewritten *********
+!
+!------------------------------------------------------------------------------!
+! This file was created by KPP (http://people.cs.vt.edu/asandu/Software/Kpp/)
+! and kpp4palm (created by Klaus Ketelsen). kpp4palm is an adapted version
+! of KP4 (Jöckel,P.,Kerkweg,A.,Pozzer,A.,Sander,R.,Tost,H.,Riede,
+! H.,Baumgaertner,A.,Gromov,S.,and Kern,B.,2010: Development cycle 2 of
+! the Modular Earth Submodel System (MESSy2),Geosci. Model Dev.,3,717-752,
+! https://doi.org/10.5194/gmd-3-717-2010). KP4 is part of the Modular Earth
+! Submodel System (MESSy),which is is available under the GNU General Public
+! License (GPL).
+!
+! KPP is free software; you can redistribute it and/or modify it under the terms
+! of the General Public Licence as published by the Free Software Foundation;
+! 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 Licence for more details.
+!
+!------------------------------------------------------------------------------!
+! This file is part of the PALM model system.
+!
+! PALM is free software: you can redistribute it and/or modify it under the
+! terms of the GNU General Public License as published by the Free Software
+! Foundation,either version 3 of the License,or (at your option) any later
+! version.
+!
+! PALM 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
+! PALM. If not,see .
+!
+! Copyright 1997-2019 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+!
+! MODULE HEADER TEMPLATE
+!
+! Initial version (Nov. 2016,ketelsen),for later modifications of module_header
+! see comments in kpp4palm/src/create_kpp_module.C
+
+! Set kpp Double Precision to PALM Default Precision
+
+ USE kinds, ONLY: dp=>wp
+
+ USE pegrid, ONLY: myid, threads_per_task
+
+ IMPLICIT NONE
+ PRIVATE
+ !SAVE ! note: occurs again in automatically generated code ...
+
+! PUBLIC :: IERR_NAMES
+
+! PUBLIC :: SPC_NAMES,EQN_NAMES,EQN_TAGS,REQ_HET,REQ_AEROSOL,REQ_PHOTRAT &
+! ,REQ_MCFCT,IP_MAX,jname
+
+ PUBLIC :: eqn_names, phot_names, spc_names
+ PUBLIC :: nmaxfixsteps
+ PUBLIC :: atol, rtol
+ PUBLIC :: nspec, nreact
+ PUBLIC :: temp
+ PUBLIC :: qvap
+ PUBLIC :: fakt
+ PUBLIC :: phot
+ PUBLIC :: rconst
+ PUBLIC :: nvar
+ PUBLIC :: nphot
+ PUBLIC :: vl_dim ! PUBLIC to ebable other MODULEs to distiguish between scalar and vec
+
+ PUBLIC :: initialize, integrate, update_rconst
+ PUBLIC :: chem_gasphase_integrate
+ PUBLIC :: initialize_kpp_ctrl
+
+! END OF MODULE HEADER TEMPLATE
+
+! Variables used for vector mode
+
+ LOGICAL, PARAMETER :: l_vector = .FALSE.
+ INTEGER, PARAMETER :: i_lu_di = 2
+ INTEGER, PARAMETER :: vl_dim = 1
+ INTEGER :: vl
+
+ INTEGER :: vl_glo
+ INTEGER :: is, ie
+
+
+ INTEGER, DIMENSION(vl_dim) :: kacc, krej
+ INTEGER, DIMENSION(vl_dim) :: ierrv
+ LOGICAL :: data_loaded = .FALSE.
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Parameter Module File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Parameters.f90
+! Time : Fri Nov 30 13:52:20 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! NSPEC - Number of chemical species
+ INTEGER, PARAMETER :: nspec = 3
+! NVAR - Number of Variable species
+ INTEGER, PARAMETER :: nvar = 3
+! NVARACT - Number of Active species
+ INTEGER, PARAMETER :: nvaract = 3
+! NFIX - Number of Fixed species
+ INTEGER, PARAMETER :: nfix = 1
+! NREACT - Number of reactions
+ INTEGER, PARAMETER :: nreact = 2
+! NVARST - Starting of variables in conc. vect.
+ INTEGER, PARAMETER :: nvarst = 1
+! NFIXST - Starting of fixed in conc. vect.
+ INTEGER, PARAMETER :: nfixst = 4
+! NONZERO - Number of nonzero entries in Jacobian
+ INTEGER, PARAMETER :: nonzero = 9
+! LU_NONZERO - Number of nonzero entries in LU factoriz. of Jacobian
+ INTEGER, PARAMETER :: lu_nonzero = 9
+! CNVAR - (NVAR+1) Number of elements in compressed row format
+ INTEGER, PARAMETER :: cnvar = 4
+! CNEQN - (NREACT+1) Number stoicm elements in compressed col format
+ INTEGER, PARAMETER :: cneqn = 3
+! NHESS - Length of Sparse Hessian
+ INTEGER, PARAMETER :: nhess = 3
+! NMASS - Number of atoms to check mass balance
+ INTEGER, PARAMETER :: nmass = 1
+
+! Index declaration for variable species in C and VAR
+! VAR(ind_spc) = C(ind_spc)
+
+ INTEGER, PARAMETER, PUBLIC :: ind_o3 = 1
+ INTEGER, PARAMETER, PUBLIC :: ind_no = 2
+ INTEGER, PARAMETER, PUBLIC :: ind_no2 = 3
+
+! Index declaration for fixed species in C
+! C(ind_spc)
+
+
+! Index declaration for fixed species in FIX
+! FIX(indf_spc) = C(ind_spc) = C(NVAR+indf_spc)
+
+
+! NJVRP - Length of sparse Jacobian JVRP
+ INTEGER, PARAMETER :: njvrp = 3
+
+! NSTOICM - Length of Sparse Stoichiometric Matrix
+ INTEGER, PARAMETER :: nstoicm = 6
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Global Data Module File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Global.f90
+! Time : Fri Nov 30 13:52:20 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! Declaration of global variables
+
+! C - Concentration of all species
+ REAL(kind=dp):: c(nspec)
+! VAR - Concentrations of variable species (global)
+ REAL(kind=dp):: var(nvar)
+! FIX - Concentrations of fixed species (global)
+ REAL(kind=dp):: fix(nfix)
+! VAR,FIX are chunks of array C
+ EQUIVALENCE( c(1), var(1))
+! RCONST - Rate constants (global)
+ REAL(kind=dp):: rconst(nreact)
+! TIME - Current integration time
+ REAL(kind=dp):: time
+! TEMP - Temperature
+ REAL(kind=dp):: temp
+! TSTART - Integration start time
+ REAL(kind=dp):: tstart
+! ATOL - Absolute tolerance
+ REAL(kind=dp):: atol(nvar)
+! RTOL - Relative tolerance
+ REAL(kind=dp):: rtol(nvar)
+! STEPMIN - Lower bound for integration step
+ REAL(kind=dp):: stepmin
+! CFACTOR - Conversion factor for concentration units
+ REAL(kind=dp):: cfactor
+
+! INLINED global variable declarations
+
+! QVAP - Water vapor
+! REAL(dp),dimension(:),allocatable :: qvap
+ REAL(dp) :: qvap
+! FAKT - Conversion factor
+! REAL(dp),dimension(:),allocatable :: fakt
+ REAL(dp) :: fakt
+
+ ! declaration of global variable declarations for photolysis will come from
+
+! QVAP - Water vapor
+ REAL(kind=dp):: qvap
+! FAKT - Conversion factor
+ REAL(kind=dp):: fakt
+
+
+! INLINED global variable declarations
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Sparse Jacobian Data Structures File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_JacobianSP.f90
+! Time : Fri Nov 30 13:52:20 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! Sparse Jacobian Data
+
+
+ INTEGER, PARAMETER, DIMENSION(9):: lu_irow = (/ &
+ 1, 1, 1, 2, 2, 2, 3, 3, 3 /)
+
+ INTEGER, PARAMETER, DIMENSION(9):: lu_icol = (/ &
+ 1, 2, 3, 1, 2, 3, 1, 2, 3 /)
+
+ INTEGER, PARAMETER, DIMENSION(4):: lu_crow = (/ &
+ 1, 4, 7, 10 /)
+
+ INTEGER, PARAMETER, DIMENSION(4):: lu_diag = (/ &
+ 1, 5, 9, 10 /)
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Utility Data Module File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Monitor.f90
+! Time : Fri Nov 30 13:52:20 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+ CHARACTER(len=15), PARAMETER, DIMENSION(3):: spc_names = (/ &
+ 'O3 ','NO ','NO2 ' /)
+
+ CHARACTER(len=100), PARAMETER, DIMENSION(2):: eqn_names = (/ &
+ ' NO2 --> O3 + NO ',&
+ 'O3 + NO --> NO2 ' /)
+
+! INLINED global variables
+
+ ! inline f90_data: declaration of global variables for photolysis
+ ! REAL(kind=dp):: phot(nphot)must eventually be moved to global later for
+ INTEGER, PARAMETER :: nphot = 1
+ ! phot photolysis frequencies
+ REAL(kind=dp):: phot(nphot)
+
+ INTEGER, PARAMETER, PUBLIC :: j_no2 = 1
+
+ CHARACTER(len=15), PARAMETER, DIMENSION(nphot):: phot_names = (/ &
+ 'J_NO2 '/)
+
+! End INLINED global variables
+
+
+! Automatic generated PUBLIC Statements for ip_ and ihs_ variables
+
+! Automatic generated PUBLIC Statements for ip_ and ihs_ variables
+
+! Automatic generated PUBLIC Statements for ip_ and ihs_ variables
+
+! Automatic generated PUBLIC Statements for ip_ and ihs_ variables
+
+
+! variable definations from individual module headers
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Initialization File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Initialize.f90
+! Time : Fri Nov 30 13:52:20 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Numerical Integrator (Time-Stepping) File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Integrator.f90
+! Time : Fri Nov 30 13:52:20 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! INTEGRATE - Integrator routine
+! Arguments :
+! TIN - Start Time for Integration
+! TOUT - End Time for Integration
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!
+! 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 !
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!
+
+
+ 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
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Linear Algebra Data and Routines File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_LinearAlgebra.f90
+! Time : Fri Nov 30 13:52:20 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! The ODE Jacobian of Chemical Model File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Jacobian.f90
+! Time : Fri Nov 30 13:52:20 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! The ODE Function of Chemical Model File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Function.f90
+! Time : Fri Nov 30 13:52:20 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+! A - Rate for each equation
+ REAL(kind=dp):: a(nreact)
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! The Reaction Rates File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Rates.f90
+! Time : Fri Nov 30 13:52:20 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Auxiliary Routines File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Util.f90
+! Time : Fri Nov 30 13:52:20 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+ ! header MODULE initialize_kpp_ctrl_template
+
+ ! notes:
+ ! - l_vector is automatically defined by kp4
+ ! - vl_dim is automatically defined by kp4
+ ! - i_lu_di is automatically defined by kp4
+ ! - wanted is automatically defined by xmecca
+ ! - icntrl rcntrl are automatically defined by kpp
+ ! - "USE messy_main_tools" is in MODULE_header of messy_mecca_kpp.f90
+ ! - SAVE will be automatically added by kp4
+
+ !SAVE
+
+ ! for fixed time step control
+ ! ... max. number of fixed time steps (sum must be 1)
+ INTEGER, PARAMETER :: nmaxfixsteps = 50
+ ! ... switch for fixed time stepping
+ LOGICAL, PUBLIC :: l_fixed_step = .FALSE.
+ INTEGER, PUBLIC :: nfsteps = 1
+ ! ... number of kpp control PARAMETERs
+ INTEGER, PARAMETER, PUBLIC :: nkppctrl = 20
+ !
+ INTEGER, DIMENSION(nkppctrl), PUBLIC :: icntrl = 0
+ REAL(dp), DIMENSION(nkppctrl), PUBLIC :: rcntrl = 0.0_dp
+ REAL(dp), DIMENSION(nmaxfixsteps), PUBLIC :: t_steps = 0.0_dp
+
+ ! END header MODULE initialize_kpp_ctrl_template
+
+
+! Interface Block
+
+ INTERFACE initialize
+ MODULE PROCEDURE initialize
+ END INTERFACE initialize
+
+ INTERFACE integrate
+ MODULE PROCEDURE integrate
+ END INTERFACE integrate
+
+ INTERFACE fun
+ MODULE PROCEDURE fun
+ END INTERFACE fun
+
+ INTERFACE kppsolve
+ MODULE PROCEDURE kppsolve
+ END INTERFACE kppsolve
+
+ INTERFACE jac_sp
+ MODULE PROCEDURE jac_sp
+ END INTERFACE jac_sp
+
+ INTERFACE k_arr
+ MODULE PROCEDURE k_arr
+ END INTERFACE k_arr
+
+ INTERFACE update_rconst
+ MODULE PROCEDURE update_rconst
+ END INTERFACE update_rconst
+
+ INTERFACE arr2
+ MODULE PROCEDURE arr2
+ END INTERFACE arr2
+
+ INTERFACE initialize_kpp_ctrl
+ MODULE PROCEDURE initialize_kpp_ctrl
+ END INTERFACE initialize_kpp_ctrl
+
+ INTERFACE error_output
+ MODULE PROCEDURE error_output
+ END INTERFACE error_output
+
+ INTERFACE wscal
+ MODULE PROCEDURE wscal
+ END INTERFACE wscal
+
+!INTERFACE not working INTERFACE waxpy
+!INTERFACE not working MODULE PROCEDURE waxpy
+!INTERFACE not working END INTERFACE waxpy
+
+ INTERFACE rosenbrock
+ MODULE PROCEDURE rosenbrock
+ END INTERFACE rosenbrock
+
+ INTERFACE funtemplate
+ MODULE PROCEDURE funtemplate
+ END INTERFACE funtemplate
+
+ INTERFACE jactemplate
+ MODULE PROCEDURE jactemplate
+ END INTERFACE jactemplate
+
+ INTERFACE kppdecomp
+ MODULE PROCEDURE kppdecomp
+ END INTERFACE kppdecomp
+
+ INTERFACE chem_gasphase_integrate
+ MODULE PROCEDURE chem_gasphase_integrate
+ END INTERFACE chem_gasphase_integrate
+
+
+ CONTAINS
+
+SUBROUTINE initialize()
+
+
+ INTEGER :: j, k
+
+ INTEGER :: i
+ REAL(kind=dp):: x
+ k = is
+ cfactor = 1.000000e+00_dp
+
+ x = (0.) * cfactor
+ DO i = 1 , nvar
+ ENDDO
+
+ x = (0.) * cfactor
+ DO i = 1 , nfix
+ fix(i) = x
+ ENDDO
+
+! constant rate coefficients
+! END constant rate coefficients
+
+! INLINED initializations
+
+! End INLINED initializations
+
+
+END SUBROUTINE initialize
+
+SUBROUTINE integrate( tin, tout, &
+ icntrl_u, rcntrl_u, istatus_u, rstatus_u, ierr_u)
+
+
+ REAL(kind=dp), INTENT(IN):: tin ! start time
+ REAL(kind=dp), INTENT(IN):: tout ! END time
+ ! OPTIONAL input PARAMETERs and statistics
+ INTEGER, INTENT(IN), OPTIONAL :: icntrl_u(20)
+ REAL(kind=dp), INTENT(IN), OPTIONAL :: rcntrl_u(20)
+ INTEGER, INTENT(OUT), OPTIONAL :: istatus_u(20)
+ REAL(kind=dp), INTENT(OUT), OPTIONAL :: rstatus_u(20)
+ INTEGER, INTENT(OUT), OPTIONAL :: ierr_u
+
+ REAL(kind=dp):: 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(:)
+ ENDIF
+ IF (PRESENT(rcntrl_u))THEN
+ WHERE(rcntrl_u(:)> 0)rcntrl(:) = rcntrl_u(:)
+ ENDIF
+
+
+ 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 fun(v, f, rct, vdot)
+
+! V - Concentrations of variable species (local)
+ REAL(kind=dp):: v(nvar)
+! F - Concentrations of fixed species (local)
+ REAL(kind=dp):: f(nfix)
+! RCT - Rate constants (local)
+ REAL(kind=dp):: rct(nreact)
+! Vdot - Time derivative of variable species concentrations
+ REAL(kind=dp):: vdot(nvar)
+
+
+! Computation of equation rates
+ a(1) = rct(1) * v(3)
+ a(2) = rct(2) * v(1) * v(2)
+
+! Aggregate function
+ vdot(1) = a(1) - a(2)
+ vdot(2) = a(1) - a(2)
+ vdot(3) = - a(1) + a(2)
+
+END SUBROUTINE fun
+
+SUBROUTINE kppsolve(jvs, x)
+
+! JVS - sparse Jacobian of variables
+ REAL(kind=dp):: jvs(lu_nonzero)
+! X - Vector for variables
+ REAL(kind=dp):: x(nvar)
+
+ x(2) = x(2) - jvs(4) * x(1)
+ x(3) = x(3) - jvs(7) * x(1) - jvs(8) * x(2)
+ x(3) = x(3) / jvs(9)
+ x(2) = (x(2) - jvs(6) * x(3)) /(jvs(5))
+ x(1) = (x(1) - jvs(2) * x(2) - jvs(3) * x(3)) /(jvs(1))
+
+END SUBROUTINE kppsolve
+
+SUBROUTINE jac_sp(v, f, rct, jvs)
+
+! V - Concentrations of variable species (local)
+ REAL(kind=dp):: v(nvar)
+! F - Concentrations of fixed species (local)
+ REAL(kind=dp):: f(nfix)
+! RCT - Rate constants (local)
+ REAL(kind=dp):: rct(nreact)
+! JVS - sparse Jacobian of variables
+ REAL(kind=dp):: jvs(lu_nonzero)
+
+
+! Local variables
+! B - Temporary array
+ REAL(kind=dp):: b(3)
+
+! B(1) = dA(1)/dV(3)
+ b(1) = rct(1)
+! B(2) = dA(2)/dV(1)
+ b(2) = rct(2) * v(2)
+! B(3) = dA(2)/dV(2)
+ b(3) = rct(2) * v(1)
+
+! Construct the Jacobian terms from B's
+! JVS(1) = Jac_FULL(1,1)
+ jvs(1) = - b(2)
+! JVS(2) = Jac_FULL(1,2)
+ jvs(2) = - b(3)
+! JVS(3) = Jac_FULL(1,3)
+ jvs(3) = b(1)
+! JVS(4) = Jac_FULL(2,1)
+ jvs(4) = - b(2)
+! JVS(5) = Jac_FULL(2,2)
+ jvs(5) = - b(3)
+! JVS(6) = Jac_FULL(2,3)
+ jvs(6) = b(1)
+! JVS(7) = Jac_FULL(3,1)
+ jvs(7) = b(2)
+! JVS(8) = Jac_FULL(3,2)
+ jvs(8) = b(3)
+! JVS(9) = Jac_FULL(3,3)
+ jvs(9) = - b(1)
+
+END SUBROUTINE jac_sp
+
+ elemental REAL(kind=dp)FUNCTION k_arr (k_298, tdep, temp)
+ ! arrhenius FUNCTION
+
+ REAL, INTENT(IN):: k_298 ! k at t = 298.15k
+ REAL, INTENT(IN):: tdep ! temperature dependence
+ REAL(kind=dp), INTENT(IN):: temp ! temperature
+
+ intrinsic exp
+
+ k_arr = k_298 * exp(tdep* (1._dp/temp- 3.3540e-3_dp))! 1/298.15=3.3540e-3
+
+ END FUNCTION k_arr
+
+SUBROUTINE update_rconst()
+ INTEGER :: k
+
+ k = is
+
+! Begin INLINED RCONST
+
+
+! End INLINED RCONST
+
+ rconst(1) = (phot(j_no2))
+ rconst(2) = (arr2(1.8e-12_dp , 1370.0_dp , temp))
+
+END SUBROUTINE update_rconst
+
+! END FUNCTION ARR2
+REAL(kind=dp)FUNCTION arr2( a0, b0, temp)
+ REAL(kind=dp):: temp
+ REAL(kind=dp):: a0, b0
+ arr2 = a0 * exp( - b0 / temp)
+END FUNCTION arr2
+
+SUBROUTINE initialize_kpp_ctrl(status)
+
+
+ ! i/o
+ INTEGER, INTENT(OUT):: status
+
+ ! local
+ REAL(dp):: tsum
+ INTEGER :: i
+
+ ! check fixed time steps
+ tsum = 0.0_dp
+ DO i=1, nmaxfixsteps
+ IF (t_steps(i)< tiny(0.0_dp))exit
+ tsum = tsum + t_steps(i)
+ ENDDO
+
+ nfsteps = i- 1
+
+ l_fixed_step = (nfsteps > 0).and.((tsum - 1.0)< tiny(0.0_dp))
+
+ IF (l_vector)THEN
+ WRITE(*,*) ' MODE : VECTOR (LENGTH=',VL_DIM,')'
+ ELSE
+ WRITE(*,*) ' MODE : SCALAR'
+ ENDIF
+ !
+ WRITE(*,*) ' DE-INDEXING MODE :',I_LU_DI
+ !
+ WRITE(*,*) ' ICNTRL : ',icntrl
+ WRITE(*,*) ' RCNTRL : ',rcntrl
+ !
+ ! note: this is ONLY meaningful for vectorized (kp4)rosenbrock- methods
+ IF (l_vector)THEN
+ IF (l_fixed_step)THEN
+ WRITE(*,*) ' TIME STEPS : FIXED (',t_steps(1:nfsteps),')'
+ ELSE
+ WRITE(*,*) ' TIME STEPS : AUTOMATIC'
+ ENDIF
+ ELSE
+ WRITE(*,*) ' TIME STEPS : AUTOMATIC '//&
+ &'(t_steps (CTRL_KPP) ignored in SCALAR MODE)'
+ ENDIF
+ ! mz_pj_20070531-
+
+ status = 0
+
+
+END SUBROUTINE initialize_kpp_ctrl
+
+SUBROUTINE error_output(c, ierr, pe)
+
+
+ INTEGER, INTENT(IN):: ierr
+ INTEGER, INTENT(IN):: pe
+ REAL(dp), DIMENSION(:), INTENT(IN):: c
+
+ write(6,*) 'ERROR in chem_gasphase_mod ',ierr,C(1)
+
+
+END SUBROUTINE error_output
+
+ SUBROUTINE wscal(n, alpha, x, incx)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+! constant times a vector: x(1:N) <- Alpha*x(1:N)
+! only for incX=incY=1
+! after BLAS
+! replace this by the function from the optimized BLAS implementation:
+! CALL SSCAL(N,Alpha,X,1) or CALL DSCAL(N,Alpha,X,1)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ INTEGER :: i, incx, m, mp1, n
+ REAL(kind=dp) :: x(n), alpha
+ REAL(kind=dp), PARAMETER :: zero=0.0_dp, one=1.0_dp
+
+ IF (alpha .eq. one)RETURN
+ IF (n .le. 0)RETURN
+
+ m = mod(n, 5)
+ IF ( m .ne. 0)THEN
+ IF (alpha .eq. (- one))THEN
+ DO i = 1, m
+ x(i) = - x(i)
+ ENDDO
+ ELSEIF (alpha .eq. zero)THEN
+ DO i = 1, m
+ x(i) = zero
+ ENDDO
+ ELSE
+ DO i = 1, m
+ x(i) = alpha* x(i)
+ ENDDO
+ ENDIF
+ IF ( n .lt. 5)RETURN
+ ENDIF
+ mp1 = m + 1
+ IF (alpha .eq. (- one))THEN
+ DO i = mp1, n, 5
+ x(i) = - x(i)
+ x(i + 1) = - x(i + 1)
+ x(i + 2) = - x(i + 2)
+ x(i + 3) = - x(i + 3)
+ x(i + 4) = - x(i + 4)
+ ENDDO
+ ELSEIF (alpha .eq. zero)THEN
+ DO i = mp1, n, 5
+ x(i) = zero
+ x(i + 1) = zero
+ x(i + 2) = zero
+ x(i + 3) = zero
+ x(i + 4) = zero
+ ENDDO
+ ELSE
+ DO i = mp1, n, 5
+ x(i) = alpha* x(i)
+ x(i + 1) = alpha* x(i + 1)
+ x(i + 2) = alpha* x(i + 2)
+ x(i + 3) = alpha* x(i + 3)
+ x(i + 4) = alpha* x(i + 4)
+ ENDDO
+ ENDIF
+
+ END SUBROUTINE wscal
+
+ SUBROUTINE waxpy(n, alpha, x, incx, y, incy)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+! constant times a vector plus a vector: y <- y + Alpha*x
+! only for incX=incY=1
+! after BLAS
+! replace this by the function from the optimized BLAS implementation:
+! CALL SAXPY(N,Alpha,X,1,Y,1) or CALL DAXPY(N,Alpha,X,1,Y,1)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ INTEGER :: i, incx, incy, m, mp1, n
+ REAL(kind=dp):: x(n), y(n), alpha
+ REAL(kind=dp), PARAMETER :: zero = 0.0_dp
+
+ IF (alpha .eq. zero)RETURN
+ IF (n .le. 0)RETURN
+
+ m = mod(n, 4)
+ IF ( m .ne. 0)THEN
+ DO i = 1, m
+ y(i) = y(i) + alpha* x(i)
+ ENDDO
+ IF ( n .lt. 4)RETURN
+ ENDIF
+ mp1 = m + 1
+ DO i = mp1, n, 4
+ y(i) = y(i) + alpha* x(i)
+ y(i + 1) = y(i + 1) + alpha* x(i + 1)
+ y(i + 2) = y(i + 2) + alpha* x(i + 2)
+ y(i + 3) = y(i + 3) + alpha* x(i + 3)
+ ENDDO
+
+ END SUBROUTINE waxpy
+
+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
+!
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+!~~~> arguments
+ INTEGER, INTENT(IN) :: n
+ REAL(kind=dp), INTENT(INOUT):: y(n)
+ REAL(kind=dp), INTENT(IN) :: tstart, tend
+ REAL(kind=dp), INTENT(IN) :: abstol(n), reltol(n)
+ INTEGER, INTENT(IN) :: icntrl(20)
+ REAL(kind=dp), INTENT(IN) :: rcntrl(20)
+ INTEGER, INTENT(INOUT):: istatus(20)
+ REAL(kind=dp), 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
+ REAL(kind=dp):: 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
+ REAL(kind=dp):: roundoff, facmin, facmax, facrej, facsafe
+ REAL(kind=dp):: hmin, hmax, hstart
+ REAL(kind=dp):: texit
+ INTEGER :: i, uplimtol, max_no_steps
+ LOGICAL :: autonomous, vectortol
+!~~~> PARAMETERs
+ REAL(kind=dp), PARAMETER :: zero = 0.0_dp, one = 1.0_dp
+ REAL(kind=dp), 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
+ ENDIF
+
+!~~~> 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
+ ENDIF
+
+!~~~> unit roundoff (1+ roundoff>1)
+ roundoff = epsilon(one)
+
+!~~~> 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
+ ENDIF
+!~~~> 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
+ ENDIF
+!~~~> 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
+ ENDIF
+!~~~> 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
+ ENDIF
+ 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
+ ENDIF
+!~~~> 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
+ ENDIF
+!~~~> 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
+ ENDIF
+!~~~> 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
+ ENDIF
+ ENDDO
+
+
+!~~~> 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ REAL(kind=dp), 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}
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+!~~~> input: the initial condition at tstart; output: the solution at t
+ REAL(kind=dp), INTENT(INOUT):: y(n)
+!~~~> input: integration interval
+ REAL(kind=dp), INTENT(IN):: tstart, tend
+!~~~> output: time at which the solution is RETURNed (t=tendIF success)
+ REAL(kind=dp), INTENT(OUT):: t
+!~~~> input: tolerances
+ REAL(kind=dp), INTENT(IN):: abstol(n), reltol(n)
+!~~~> input: integration PARAMETERs
+ LOGICAL, INTENT(IN):: autonomous, vectortol
+ REAL(kind=dp), INTENT(IN):: hstart, hmin, hmax
+ INTEGER, INTENT(IN):: max_no_steps
+ REAL(kind=dp), INTENT(IN):: roundoff, facmin, facmax, facrej, facsafe
+!~~~> output: error indicator
+ INTEGER, INTENT(OUT):: ierr
+! ~~~~ Local variables
+ REAL(kind=dp):: ynew(n), fcn0(n), fcn(n)
+ REAL(kind=dp):: k(n* ros_s), dfdt(n)
+#ifdef full_algebra
+ REAL(kind=dp):: jac0(n, n), ghimj(n, n)
+#else
+ REAL(kind=dp):: jac0(lu_nonzero), ghimj(lu_nonzero)
+#endif
+ REAL(kind=dp):: h, hnew, hc, hg, fac, tau
+ REAL(kind=dp):: err, yerr(n)
+ INTEGER :: pivot(n), direction, ioffset, j, istage
+ LOGICAL :: rejectlasth, rejectmoreh, singular
+!~~~> local PARAMETERs
+ REAL(kind=dp), PARAMETER :: zero = 0.0_dp, one = 1.0_dp
+ REAL(kind=dp), PARAMETER :: deltamin = 1.0e-5_dp
+!~~~> locally called FUNCTIONs
+! REAL(kind=dp) 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
+ ENDIF
+ 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
+ ENDIF
+ IF (((t+ 0.1_dp* h) == t).or.(h <= roundoff))THEN ! step size too small
+ CALL ros_errormsg(- 7, t, h, ierr)
+ RETURN
+ ENDIF
+
+!~~~> 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)
+ ENDIF
+
+!~~~> 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
+ ENDIF
+
+!~~~> 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
+ !slim: CALL wcopy(n, fcn0, 1, fcn, 1)
+ fcn(1:n) = fcn0(1:n)
+ ! istage>1 and a new FUNCTION evaluation is needed at the current istage
+ ELSEIF(ros_newf(istage))THEN
+ !slim: CALL wcopy(n, y, 1, ynew, 1)
+ ynew(1:n) = y(1:n)
+ DO j = 1, istage-1
+ CALL waxpy(n, ros_a((istage-1) * (istage-2) /2+ j), &
+ k(n* (j- 1) + 1), 1, ynew, 1)
+ ENDDO
+ tau = t + ros_alpha(istage) * direction* h
+ CALL funtemplate(tau, ynew, fcn)
+ istatus(nfun) = istatus(nfun) + 1
+ ENDIF ! IF istage == 1 ELSEIF ros_newf(istage)
+ !slim: CALL wcopy(n, fcn, 1, k(ioffset+ 1), 1)
+ k(ioffset+ 1:ioffset+ n) = fcn(1:n)
+ 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), 1, k(ioffset+ 1), 1)
+ ENDDO
+ 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), 1)
+ ENDIF
+ CALL ros_solve(ghimj, pivot, k(ioffset+ 1))
+
+ END DO stage
+
+
+!~~~> compute the new solution
+ !slim: CALL wcopy(n, y, 1, ynew, 1)
+ ynew(1:n) = y(1:n)
+ DO j=1, ros_s
+ CALL waxpy(n, ros_m(j), k(n* (j- 1) + 1), 1, ynew, 1)
+ ENDDO
+
+!~~~> compute the error estimation
+ !slim: CALL wscal(n, zero, yerr, 1)
+ yerr(1:n) = zero
+ DO j=1, ros_s
+ CALL waxpy(n, ros_e(j), k(n* (j- 1) + 1), 1, yerr, 1)
+ ENDDO
+ 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
+ !slim: CALL wcopy(n, ynew, 1, y, 1)
+ y(1:n) = ynew(1:n)
+ 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)
+ ENDIF
+ 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
+ ENDIF
+ rejectmoreh = rejectlasth
+ rejectlasth = .TRUE.
+ h = hnew
+ IF (istatus(nacc)>= 1) istatus(nrej) = istatus(nrej) + 1
+ ENDIF ! err <= 1
+
+ END DO untilaccepted
+
+ END DO timeloop
+
+!~~~> succesful exit
+ ierr = 1 !~~~> the integration was successful
+
+ END SUBROUTINE ros_integrator
+
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ REAL(kind=dp)FUNCTION ros_errornorm(y, ynew, yerr, &
+ abstol, reltol, vectortol)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> computes the "scaled norm" of the error vector yerr
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+! Input arguments
+ REAL(kind=dp), INTENT(IN):: y(n), ynew(n), &
+ yerr(n), abstol(n), reltol(n)
+ LOGICAL, INTENT(IN):: vectortol
+! Local variables
+ REAL(kind=dp):: err, scale, ymax
+ INTEGER :: i
+ REAL(kind=dp), 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
+ ENDIF
+ err = err+ (yerr(i) /scale) ** 2
+ ENDDO
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+!~~~> input arguments
+ REAL(kind=dp), INTENT(IN):: t, roundoff, y(n), fcn0(n)
+!~~~> output arguments
+ REAL(kind=dp), INTENT(OUT):: dfdt(n)
+!~~~> local variables
+ REAL(kind=dp):: delta
+ REAL(kind=dp), 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
+! --- --- --- --- --- --- --- --- --- --- --- --- ---
+
+!~~~> input arguments
+#ifdef full_algebra
+ REAL(kind=dp), INTENT(IN):: jac0(n, n)
+#else
+ REAL(kind=dp), INTENT(IN):: jac0(lu_nonzero)
+#endif
+ REAL(kind=dp), INTENT(IN):: gam
+ INTEGER, INTENT(IN):: direction
+!~~~> output arguments
+#ifdef full_algebra
+ REAL(kind=dp), INTENT(OUT):: ghimj(n, n)
+#else
+ REAL(kind=dp), INTENT(OUT):: ghimj(lu_nonzero)
+#endif
+ LOGICAL, INTENT(OUT):: singular
+ INTEGER, INTENT(OUT):: pivot(n)
+!~~~> inout arguments
+ REAL(kind=dp), INTENT(INOUT):: h ! step size is decreased when lu fails
+!~~~> local variables
+ INTEGER :: i, ising, nconsecutive
+ REAL(kind=dp):: ghinv
+ REAL(kind=dp), 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
+ !slim: CALL wcopy(n* n, jac0, 1, ghimj, 1)
+ !slim: CALL wscal(n* n, (- one), ghimj, 1)
+ ghimj = - jac0
+ ghinv = one/(direction* h* gam)
+ DO i=1, n
+ ghimj(i, i) = ghimj(i, i) + ghinv
+ ENDDO
+#else
+ !slim: CALL wcopy(lu_nonzero, jac0, 1, ghimj, 1)
+ !slim: CALL wscal(lu_nonzero, (- one), ghimj, 1)
+ ghimj(1:lu_nonzero) = - jac0(1:lu_nonzero)
+ ghinv = one/(direction* h* gam)
+ DO i=1, n
+ ghimj(lu_diag(i)) = ghimj(lu_diag(i)) + ghinv
+ ENDDO
+#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
+ ENDIF ! nconsecutive
+ ENDIF ! ising
+
+ END DO ! WHILE singular
+
+ END SUBROUTINE ros_preparematrix
+
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE ros_decomp( a, pivot, ising)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! Template for the LU decomposition
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> inout variables
+#ifdef full_algebra
+ REAL(kind=dp), INTENT(INOUT):: a(n, n)
+#else
+ REAL(kind=dp), INTENT(INOUT):: a(lu_nonzero)
+#endif
+!~~~> 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)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> input variables
+#ifdef full_algebra
+ REAL(kind=dp), INTENT(IN):: a(n, n)
+ INTEGER :: ising
+#else
+ REAL(kind=dp), INTENT(IN):: a(lu_nonzero)
+#endif
+ INTEGER, INTENT(IN):: pivot(n)
+!~~~> inout variables
+ REAL(kind=dp), INTENT(INOUT):: b(n)
+
+#ifdef full_algebra
+ CALL DGETRS( 'N',N ,1,A,N,Pivot,b,N,ISING)
+ IF (info < 0)THEN
+ print* , "error in dgetrs. ising=", ising
+ ENDIF
+#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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ 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)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+ 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)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> input variables
+ REAL(kind=dp):: t, y(nvar)
+!~~~> output variables
+ REAL(kind=dp):: ydot(nvar)
+!~~~> local variables
+ REAL(kind=dp):: told
+
+ told = time
+ time = t
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> input variables
+ REAL(kind=dp):: t, y(nvar)
+!~~~> output variables
+#ifdef full_algebra
+ REAL(kind=dp):: jv(lu_nonzero), jcb(nvar, nvar)
+#else
+ REAL(kind=dp):: jcb(lu_nonzero)
+#endif
+!~~~> local variables
+ REAL(kind=dp):: told
+#ifdef full_algebra
+ INTEGER :: i, j
+#endif
+
+ told = time
+ time = t
+#ifdef full_algebra
+ CALL jac_sp(y, fix, rconst, jv)
+ DO j=1, nvar
+ DO i=1, nvar
+ jcb(i, j) = 0.0_dp
+ ENDDO
+ ENDDO
+ DO i=1, lu_nonzero
+ jcb(lu_irow(i), lu_icol(i)) = jv(i)
+ ENDDO
+#else
+ CALL jac_sp( y, fix, rconst, jcb)
+#endif
+ time = told
+
+END SUBROUTINE jactemplate
+
+ SUBROUTINE kppdecomp( jvs, ier)
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! sparse lu factorization
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! loop expansion generated by kp4
+
+ INTEGER :: ier
+ REAL(kind=dp):: jvs(lu_nonzero), w(nvar), a
+ INTEGER :: k, kk, j, jj
+
+ a = 0.
+ ier = 0
+
+! i = 1
+! i = 2
+ jvs(4) = (jvs(4)) / jvs(1)
+ jvs(5) = jvs(5) - jvs(2) * jvs(4)
+ jvs(6) = jvs(6) - jvs(3) * jvs(4)
+! i = 3
+ jvs(7) = (jvs(7)) / jvs(1)
+ a = 0.0; a = a - jvs(2) * jvs(7)
+ jvs(8) = (jvs(8) + a) / jvs(5)
+ jvs(9) = jvs(9) - jvs(3) * jvs(7) - jvs(6) * jvs(8)
+ RETURN
+
+ END SUBROUTINE kppdecomp
+
+SUBROUTINE chem_gasphase_integrate (time_step_len, conc, tempi, qvapi, fakti, photo, ierrf, xnacc, xnrej, istatus, l_debug, pe, &
+ icntrl_i, rcntrl_i)
+
+ IMPLICIT NONE
+
+ REAL(dp), INTENT(IN) :: time_step_len
+ REAL(dp), DIMENSION(:, :), INTENT(INOUT) :: conc
+ REAL(dp), DIMENSION(:, :), INTENT(IN) :: photo
+ REAL(dp), DIMENSION(:), INTENT(IN) :: tempi
+ REAL(dp), DIMENSION(:), INTENT(IN) :: qvapi
+ REAL(dp), DIMENSION(:), INTENT(IN) :: fakti
+ INTEGER, INTENT(OUT), OPTIONAL :: ierrf(:)
+ INTEGER, INTENT(OUT), OPTIONAL :: xnacc(:)
+ INTEGER, INTENT(OUT), OPTIONAL :: xnrej(:)
+ INTEGER, INTENT(INOUT), OPTIONAL :: istatus(:)
+ INTEGER, INTENT(IN), OPTIONAL :: pe
+ LOGICAL, INTENT(IN), OPTIONAL :: l_debug
+ INTEGER, DIMENSION(nkppctrl), INTENT(IN), OPTIONAL :: icntrl_i
+ REAL(dp), DIMENSION(nkppctrl), INTENT(IN), OPTIONAL :: rcntrl_i
+
+ INTEGER :: k ! loop variable
+ REAL(dp) :: dt
+ INTEGER, DIMENSION(20) :: istatus_u
+ INTEGER :: ierr_u
+ INTEGER :: istatf
+ INTEGER :: vl_dim_lo
+
+
+ IF (PRESENT (istatus)) istatus = 0
+ IF (PRESENT (icntrl_i)) icntrl = icntrl_i
+ IF (PRESENT (rcntrl_i)) rcntrl = rcntrl_i
+
+ vl_glo = size(tempi, 1)
+
+ vl_dim_lo = vl_dim
+ DO k=1, vl_glo, vl_dim_lo
+ is = k
+ ie = min(k+ vl_dim_lo-1, vl_glo)
+ vl = ie-is+ 1
+
+ c(:) = conc(is, :)
+
+ temp = tempi(is)
+
+ qvap = qvapi(is)
+
+ fakt = fakti(is)
+
+ CALL initialize
+
+ phot(:) = photo(is, :)
+
+ CALL update_rconst
+
+ dt = time_step_len
+
+ ! integrate from t=0 to t=dt
+ CALL integrate(0._dp, dt, icntrl, rcntrl, istatus_u = istatus_u, ierr_u=ierr_u)
+
+
+ IF (PRESENT(l_debug) .AND. PRESENT(pe)) THEN
+ IF (l_debug) CALL error_output(conc(is, :), ierr_u, pe)
+ ENDIF
+
+ conc(is, :) = c(:)
+
+ ! RETURN diagnostic information
+
+ IF (PRESENT(ierrf)) ierrf(is) = ierr_u
+ IF (PRESENT(xnacc)) xnacc(is) = istatus_u(4)
+ IF (PRESENT(xnrej)) xnrej(is) = istatus_u(5)
+
+ IF (PRESENT (istatus)) THEN
+ istatus(1:8) = istatus(1:8) + istatus_u(1:8)
+ ENDIF
+
+ END DO
+
+
+! Deallocate input arrays
+
+
+ data_loaded = .FALSE.
+
+ RETURN
+END SUBROUTINE chem_gasphase_integrate
+
+END MODULE chem_gasphase_mod
+
Index: /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+phstat/chem_gasphase_mod.kpp
===================================================================
--- /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+phstat/chem_gasphase_mod.kpp (revision 3698)
+++ /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+phstat/chem_gasphase_mod.kpp (revision 3698)
@@ -0,0 +1,43 @@
+//chem_gasphase_mod.kpp
+//
+//Former revisions
+//----------------
+// $Id: chem_gasphase_mod.kpp 2459 2017-09-13 14:10:33Z forkel $
+// initial revision from branch salsa rev 3576 (29.11.2018, monakurppa)
+//
+#include phstat.spc
+#include phstat.eqn
+#INTEGRATOR rosenbrock
+#LANGUAGE Fortran90
+#HESSIAN on
+#STOICMAT on
+#INLINE F90_GLOBAL
+! QVAP - Water vapor
+! REAL(dp),dimension(:),allocatable :: qvap
+ REAL(dp) :: qvap
+! FAKT - Conversion factor
+! REAL(dp),dimension(:),allocatable :: fakt
+ REAL(dp) :: fakt
+
+ ! Declaration of global variable declarations for photolysis will come from INLINE F90_DATA
+#ENDINLINE
+//
+// *******************************************************************************************
+// *** adapt the lines below occurding to the photolysis reactions of your mechanism *
+// *** adapt the number of photolysis frequencies NPHO *
+// *** adapt/extend the indices in the INTEGER, PARAMETER,PUBLIC statement below *
+// *** adapt/extend PHOT_NAMES: Note that the order of PHOT_NAMES and the indices must match *
+// *******************************************************************************************
+//
+#INLINE F90_DATA
+ ! INLINE F90_DATA: Declaration of global variables for photolysis
+ ! REAL(kind=dp) :: phot(nphot) must eventually be moved to GLOBAL later for vector version
+ INTEGER, PARAMETER :: nphot = 1
+ ! phot Photolysis frequencies
+ REAL(kind=dp) :: phot(nphot)
+
+ INTEGER, PARAMETER,PUBLIC :: j_no2 = 1
+
+ CHARACTER(LEN=15), PARAMETER, DIMENSION(NPHOT) :: phot_names = (/ &
+ 'J_NO2 '/)
+#ENDINLINE
Index: /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+phstat/phstat.eqn
===================================================================
--- /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+phstat/phstat.eqn (revision 3698)
+++ /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+phstat/phstat.eqn (revision 3698)
@@ -0,0 +1,9 @@
+{phstat.eqn
+Current revision
+----------------
+ 20180319 Photostationary O3-NO-NO2-equilibrium forkel
+}
+#EQUATIONS
+
+ { 1.} NO2 + hv = NO + O3 : phot(j_no2) ;
+ { 3.} NO + O3 = NO2 : arr2(1.8E-12_dp, 1370.0_dp, temp) ;
Index: /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+phstat/phstat.spc
===================================================================
--- /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+phstat/phstat.spc (revision 3698)
+++ /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+phstat/phstat.spc (revision 3698)
@@ -0,0 +1,19 @@
+{phstat.spc
+Former revisions
+----------------
+ $Id: smog.spc 2459 2017-09-13 14:10:33Z forkel $
+}
+#include atoms
+
+ #DEFVAR
+ O = O ; {oxygen atomic ground state (3P)}
+ O3 = 3O ; {ozone}
+ NO = N + O ; {nitric oxide}
+ NO2 = N + 2O ; {nitrogen dioxide}
+
+#DEFFIX
+ H2O = H + 2O ; {water}
+ H2 = 2H ; {molecular hydrogen}
+ O2 = 2O ; {molecular oxygen}
+ N2 = 2N ; {molecular nitrogen}
+
Index: /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+simple/chem_gasphase_mod.f90
===================================================================
--- /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+simple/chem_gasphase_mod.f90 (revision 3698)
+++ /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+simple/chem_gasphase_mod.f90 (revision 3698)
@@ -0,0 +1,2543 @@
+MODULE chem_gasphase_mod
+
+! Mechanism: salsa+simple
+!
+!------------------------------------------------------------------------------!
+!
+! ******Module chem_gasphase_mod is automatically generated by kpp4palm ******
+!
+! *********Please do NOT change this Code,it will be ovewritten *********
+!
+!------------------------------------------------------------------------------!
+! This file was created by KPP (http://people.cs.vt.edu/asandu/Software/Kpp/)
+! and kpp4palm (created by Klaus Ketelsen). kpp4palm is an adapted version
+! of KP4 (Jöckel,P.,Kerkweg,A.,Pozzer,A.,Sander,R.,Tost,H.,Riede,
+! H.,Baumgaertner,A.,Gromov,S.,and Kern,B.,2010: Development cycle 2 of
+! the Modular Earth Submodel System (MESSy2),Geosci. Model Dev.,3,717-752,
+! https://doi.org/10.5194/gmd-3-717-2010). KP4 is part of the Modular Earth
+! Submodel System (MESSy),which is is available under the GNU General Public
+! License (GPL).
+!
+! KPP is free software; you can redistribute it and/or modify it under the terms
+! of the General Public Licence as published by the Free Software Foundation;
+! 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 Licence for more details.
+!
+!------------------------------------------------------------------------------!
+! This file is part of the PALM model system.
+!
+! PALM is free software: you can redistribute it and/or modify it under the
+! terms of the GNU General Public License as published by the Free Software
+! Foundation,either version 3 of the License,or (at your option) any later
+! version.
+!
+! PALM 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
+! PALM. If not,see .
+!
+! Copyright 1997-2019 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+!
+! MODULE HEADER TEMPLATE
+!
+! Initial version (Nov. 2016,ketelsen),for later modifications of module_header
+! see comments in kpp4palm/src/create_kpp_module.C
+
+! Set kpp Double Precision to PALM Default Precision
+
+ USE kinds, ONLY: dp=>wp
+
+ USE pegrid, ONLY: myid, threads_per_task
+
+ IMPLICIT NONE
+ PRIVATE
+ !SAVE ! note: occurs again in automatically generated code ...
+
+! PUBLIC :: IERR_NAMES
+
+! PUBLIC :: SPC_NAMES,EQN_NAMES,EQN_TAGS,REQ_HET,REQ_AEROSOL,REQ_PHOTRAT &
+! ,REQ_MCFCT,IP_MAX,jname
+
+ PUBLIC :: eqn_names, phot_names, spc_names
+ PUBLIC :: nmaxfixsteps
+ PUBLIC :: atol, rtol
+ PUBLIC :: nspec, nreact
+ PUBLIC :: temp
+ PUBLIC :: qvap
+ PUBLIC :: fakt
+ PUBLIC :: phot
+ PUBLIC :: rconst
+ PUBLIC :: nvar
+ PUBLIC :: nphot
+ PUBLIC :: vl_dim ! PUBLIC to ebable other MODULEs to distiguish between scalar and vec
+
+ PUBLIC :: initialize, integrate, update_rconst
+ PUBLIC :: chem_gasphase_integrate
+ PUBLIC :: initialize_kpp_ctrl
+
+! END OF MODULE HEADER TEMPLATE
+
+! Variables used for vector mode
+
+ LOGICAL, PARAMETER :: l_vector = .FALSE.
+ INTEGER, PARAMETER :: i_lu_di = 2
+ INTEGER, PARAMETER :: vl_dim = 1
+ INTEGER :: vl
+
+ INTEGER :: vl_glo
+ INTEGER :: is, ie
+
+
+ INTEGER, DIMENSION(vl_dim) :: kacc, krej
+ INTEGER, DIMENSION(vl_dim) :: ierrv
+ LOGICAL :: data_loaded = .FALSE.
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Parameter Module File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Parameters.f90
+! Time : Thu Dec 20 14:58:04 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181220/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! NSPEC - Number of chemical species
+ INTEGER, PARAMETER :: nspec = 14
+! NVAR - Number of Variable species
+ INTEGER, PARAMETER :: nvar = 13
+! NVARACT - Number of Active species
+ INTEGER, PARAMETER :: nvaract = 11
+! NFIX - Number of Fixed species
+ INTEGER, PARAMETER :: nfix = 1
+! NREACT - Number of reactions
+ INTEGER, PARAMETER :: nreact = 11
+! NVARST - Starting of variables in conc. vect.
+ INTEGER, PARAMETER :: nvarst = 1
+! NFIXST - Starting of fixed in conc. vect.
+ INTEGER, PARAMETER :: nfixst = 14
+! NONZERO - Number of nonzero entries in Jacobian
+ INTEGER, PARAMETER :: nonzero = 39
+! LU_NONZERO - Number of nonzero entries in LU factoriz. of Jacobian
+ INTEGER, PARAMETER :: lu_nonzero = 41
+! CNVAR - (NVAR+1) Number of elements in compressed row format
+ INTEGER, PARAMETER :: cnvar = 14
+! CNEQN - (NREACT+1) Number stoicm elements in compressed col format
+ INTEGER, PARAMETER :: cneqn = 12
+! NHESS - Length of Sparse Hessian
+ INTEGER, PARAMETER :: nhess = 18
+! NMASS - Number of atoms to check mass balance
+ INTEGER, PARAMETER :: nmass = 1
+
+! Index declaration for variable species in C and VAR
+! VAR(ind_spc) = C(ind_spc)
+
+ INTEGER, PARAMETER, PUBLIC :: ind_h2so4 = 1
+ INTEGER, PARAMETER, PUBLIC :: ind_nh3 = 2
+ INTEGER, PARAMETER, PUBLIC :: ind_ocnv = 3
+ INTEGER, PARAMETER, PUBLIC :: ind_ocsv = 4
+ INTEGER, PARAMETER, PUBLIC :: ind_hno3 = 5
+ INTEGER, PARAMETER, PUBLIC :: ind_rcho = 6
+ INTEGER, PARAMETER, PUBLIC :: ind_rh = 7
+ INTEGER, PARAMETER, PUBLIC :: ind_o3 = 8
+ INTEGER, PARAMETER, PUBLIC :: ind_oh = 9
+ INTEGER, PARAMETER, PUBLIC :: ind_no2 = 10
+ INTEGER, PARAMETER, PUBLIC :: ind_no = 11
+ INTEGER, PARAMETER, PUBLIC :: ind_ho2 = 12
+ INTEGER, PARAMETER, PUBLIC :: ind_ro2 = 13
+
+! Index declaration for fixed species in C
+! C(ind_spc)
+
+ INTEGER, PARAMETER, PUBLIC :: ind_h2o = 14
+
+! Index declaration for fixed species in FIX
+! FIX(indf_spc) = C(ind_spc) = C(NVAR+indf_spc)
+
+ INTEGER, PARAMETER :: indf_h2o = 1
+
+! NJVRP - Length of sparse Jacobian JVRP
+ INTEGER, PARAMETER :: njvrp = 16
+
+! NSTOICM - Length of Sparse Stoichiometric Matrix
+ INTEGER, PARAMETER :: nstoicm = 23
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Global Data Module File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Global.f90
+! Time : Thu Dec 20 14:58:04 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181220/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! Declaration of global variables
+
+! C - Concentration of all species
+ REAL(kind=dp):: c(nspec)
+! VAR - Concentrations of variable species (global)
+ REAL(kind=dp):: var(nvar)
+! FIX - Concentrations of fixed species (global)
+ REAL(kind=dp):: fix(nfix)
+! VAR,FIX are chunks of array C
+ EQUIVALENCE( c(1), var(1))
+ EQUIVALENCE( c(14), fix(1))
+! RCONST - Rate constants (global)
+ REAL(kind=dp):: rconst(nreact)
+! TIME - Current integration time
+ REAL(kind=dp):: time
+! TEMP - Temperature
+ REAL(kind=dp):: temp
+! TSTART - Integration start time
+ REAL(kind=dp):: tstart
+! ATOL - Absolute tolerance
+ REAL(kind=dp):: atol(nvar)
+! RTOL - Relative tolerance
+ REAL(kind=dp):: rtol(nvar)
+! STEPMIN - Lower bound for integration step
+ REAL(kind=dp):: stepmin
+! CFACTOR - Conversion factor for concentration units
+ REAL(kind=dp):: cfactor
+
+! INLINED global variable declarations
+
+! QVAP - Water vapor
+ REAL(dp) :: qvap
+! FAKT - Conversion factor
+ REAL(dp) :: fakt
+! Declaration of global variable declarations for photolysis will come from IN
+
+! QVAP - Water vapor
+ REAL(kind=dp):: qvap
+! FAKT - Conversion factor
+ REAL(kind=dp):: fakt
+
+
+! INLINED global variable declarations
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Sparse Jacobian Data Structures File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_JacobianSP.f90
+! Time : Thu Dec 20 14:58:04 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181220/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! Sparse Jacobian Data
+
+
+ INTEGER, PARAMETER, DIMENSION(41):: lu_irow = (/ &
+ 1, 2, 3, 4, 5, 5, 5, 6, 6, 6, 7, 7, &
+ 8, 8, 8, 9, 9, 9, 9, 9, 9, 10, 10, 10, &
+ 10, 10, 10, 11, 11, 11, 11, 11, 12, 12, 12, 13, &
+ 13, 13, 13, 13, 13 /)
+
+ INTEGER, PARAMETER, DIMENSION(41):: lu_icol = (/ &
+ 1, 2, 3, 4, 5, 9, 10, 6, 11, 13, 7, 9, &
+ 8, 10, 11, 7, 8, 9, 10, 11, 12, 8, 9, 10, &
+ 11, 12, 13, 8, 10, 11, 12, 13, 11, 12, 13, 7, &
+ 9, 10, 11, 12, 13 /)
+
+ INTEGER, PARAMETER, DIMENSION(14):: lu_crow = (/ &
+ 1, 2, 3, 4, 5, 8, 11, 13, 16, 22, 28, 33, &
+ 36, 42 /)
+
+ INTEGER, PARAMETER, DIMENSION(14):: lu_diag = (/ &
+ 1, 2, 3, 4, 5, 8, 11, 13, 18, 24, 30, 34, &
+ 41, 42 /)
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Utility Data Module File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Monitor.f90
+! Time : Thu Dec 20 14:58:04 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181220/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+ CHARACTER(len=15), PARAMETER, DIMENSION(14):: spc_names = (/ &
+ 'H2SO4 ','NH3 ','OCNV ',&
+ 'OCSV ','HNO3 ','RCHO ',&
+ 'RH ','O3 ','OH ',&
+ 'NO2 ','NO ','HO2 ',&
+ 'RO2 ','H2O ' /)
+
+ CHARACTER(len=100), PARAMETER, DIMENSION(11):: eqn_names = (/ &
+ ' NO2 --> O3 + NO ',&
+ 'O3 + H2O --> 2 OH ',&
+ ' O3 + NO --> NO2 ',&
+ ' RH + OH --> RO2 + H2O ',&
+ 'NO + RO2 --> RCHO + NO2 + HO2 ',&
+ 'NO + HO2 --> OH + NO2 ',&
+ 'OH + NO2 --> HNO3 ',&
+ ' H2SO4 --> H2SO4 ',&
+ ' NH3 --> NH3 ',&
+ ' OCNV --> OCNV ',&
+ ' OCSV --> OCSV ' /)
+
+! INLINED global variables
+
+ ! inline f90_data: declaration of global variables for photolysis
+ ! REAL(kind=dp):: phot(nphot)must eventually be moved to global later for
+ INTEGER, PARAMETER :: nphot = 2
+ ! phot photolysis frequencies
+ REAL(kind=dp):: phot(nphot)
+
+ INTEGER, PARAMETER, PUBLIC :: j_no2 = 1
+ INTEGER, PARAMETER, PUBLIC :: j_o31d = 2
+
+ CHARACTER(len=15), PARAMETER, DIMENSION(nphot):: phot_names = (/ &
+ 'J_NO2 ','J_O31D '/)
+
+! End INLINED global variables
+
+
+! Automatic generated PUBLIC Statements for ip_ and ihs_ variables
+
+! Automatic generated PUBLIC Statements for ip_ and ihs_ variables
+
+! Automatic generated PUBLIC Statements for ip_ and ihs_ variables
+
+! Automatic generated PUBLIC Statements for ip_ and ihs_ variables
+
+
+! variable definations from individual module headers
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Initialization File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Initialize.f90
+! Time : Thu Dec 20 14:58:04 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181220/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Numerical Integrator (Time-Stepping) File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Integrator.f90
+! Time : Thu Dec 20 14:58:04 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181220/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! INTEGRATE - Integrator routine
+! Arguments :
+! TIN - Start Time for Integration
+! TOUT - End Time for Integration
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!
+! 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 !
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!
+
+
+ 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
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Linear Algebra Data and Routines File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_LinearAlgebra.f90
+! Time : Thu Dec 20 14:58:04 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181220/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! The ODE Jacobian of Chemical Model File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Jacobian.f90
+! Time : Thu Dec 20 14:58:04 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181220/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! The ODE Function of Chemical Model File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Function.f90
+! Time : Thu Dec 20 14:58:04 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181220/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+! A - Rate for each equation
+ REAL(kind=dp):: a(nreact)
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! The Reaction Rates File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Rates.f90
+! Time : Thu Dec 20 14:58:04 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181220/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Auxiliary Routines File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Util.f90
+! Time : Thu Dec 20 14:58:04 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181220/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+ ! header MODULE initialize_kpp_ctrl_template
+
+ ! notes:
+ ! - l_vector is automatically defined by kp4
+ ! - vl_dim is automatically defined by kp4
+ ! - i_lu_di is automatically defined by kp4
+ ! - wanted is automatically defined by xmecca
+ ! - icntrl rcntrl are automatically defined by kpp
+ ! - "USE messy_main_tools" is in MODULE_header of messy_mecca_kpp.f90
+ ! - SAVE will be automatically added by kp4
+
+ !SAVE
+
+ ! for fixed time step control
+ ! ... max. number of fixed time steps (sum must be 1)
+ INTEGER, PARAMETER :: nmaxfixsteps = 50
+ ! ... switch for fixed time stepping
+ LOGICAL, PUBLIC :: l_fixed_step = .FALSE.
+ INTEGER, PUBLIC :: nfsteps = 1
+ ! ... number of kpp control PARAMETERs
+ INTEGER, PARAMETER, PUBLIC :: nkppctrl = 20
+ !
+ INTEGER, DIMENSION(nkppctrl), PUBLIC :: icntrl = 0
+ REAL(dp), DIMENSION(nkppctrl), PUBLIC :: rcntrl = 0.0_dp
+ REAL(dp), DIMENSION(nmaxfixsteps), PUBLIC :: t_steps = 0.0_dp
+
+ ! END header MODULE initialize_kpp_ctrl_template
+
+
+! Interface Block
+
+ INTERFACE initialize
+ MODULE PROCEDURE initialize
+ END INTERFACE initialize
+
+ INTERFACE integrate
+ MODULE PROCEDURE integrate
+ END INTERFACE integrate
+
+ INTERFACE fun
+ MODULE PROCEDURE fun
+ END INTERFACE fun
+
+ INTERFACE kppsolve
+ MODULE PROCEDURE kppsolve
+ END INTERFACE kppsolve
+
+ INTERFACE jac_sp
+ MODULE PROCEDURE jac_sp
+ END INTERFACE jac_sp
+
+ INTERFACE k_arr
+ MODULE PROCEDURE k_arr
+ END INTERFACE k_arr
+
+ INTERFACE update_rconst
+ MODULE PROCEDURE update_rconst
+ END INTERFACE update_rconst
+
+ INTERFACE arr2
+ MODULE PROCEDURE arr2
+ END INTERFACE arr2
+
+ INTERFACE initialize_kpp_ctrl
+ MODULE PROCEDURE initialize_kpp_ctrl
+ END INTERFACE initialize_kpp_ctrl
+
+ INTERFACE error_output
+ MODULE PROCEDURE error_output
+ END INTERFACE error_output
+
+ INTERFACE wscal
+ MODULE PROCEDURE wscal
+ END INTERFACE wscal
+
+!INTERFACE not working INTERFACE waxpy
+!INTERFACE not working MODULE PROCEDURE waxpy
+!INTERFACE not working END INTERFACE waxpy
+
+ INTERFACE rosenbrock
+ MODULE PROCEDURE rosenbrock
+ END INTERFACE rosenbrock
+
+ INTERFACE funtemplate
+ MODULE PROCEDURE funtemplate
+ END INTERFACE funtemplate
+
+ INTERFACE jactemplate
+ MODULE PROCEDURE jactemplate
+ END INTERFACE jactemplate
+
+ INTERFACE kppdecomp
+ MODULE PROCEDURE kppdecomp
+ END INTERFACE kppdecomp
+
+ INTERFACE chem_gasphase_integrate
+ MODULE PROCEDURE chem_gasphase_integrate
+ END INTERFACE chem_gasphase_integrate
+
+
+ CONTAINS
+
+SUBROUTINE initialize()
+
+
+ INTEGER :: j, k
+
+ INTEGER :: i
+ REAL(kind=dp):: x
+ k = is
+ cfactor = 1.000000e+00_dp
+
+ x = (0.) * cfactor
+ DO i = 1 , nvar
+ ENDDO
+
+ x = (0.) * cfactor
+ DO i = 1 , nfix
+ fix(i) = x
+ ENDDO
+
+! constant rate coefficients
+! END constant rate coefficients
+
+! INLINED initializations
+
+! End INLINED initializations
+
+
+END SUBROUTINE initialize
+
+SUBROUTINE integrate( tin, tout, &
+ icntrl_u, rcntrl_u, istatus_u, rstatus_u, ierr_u)
+
+
+ REAL(kind=dp), INTENT(IN):: tin ! start time
+ REAL(kind=dp), INTENT(IN):: tout ! END time
+ ! OPTIONAL input PARAMETERs and statistics
+ INTEGER, INTENT(IN), OPTIONAL :: icntrl_u(20)
+ REAL(kind=dp), INTENT(IN), OPTIONAL :: rcntrl_u(20)
+ INTEGER, INTENT(OUT), OPTIONAL :: istatus_u(20)
+ REAL(kind=dp), INTENT(OUT), OPTIONAL :: rstatus_u(20)
+ INTEGER, INTENT(OUT), OPTIONAL :: ierr_u
+
+ REAL(kind=dp):: 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(:)
+ ENDIF
+ IF (PRESENT(rcntrl_u))THEN
+ WHERE(rcntrl_u(:)> 0)rcntrl(:) = rcntrl_u(:)
+ ENDIF
+
+
+ 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 fun(v, f, rct, vdot)
+
+! V - Concentrations of variable species (local)
+ REAL(kind=dp):: v(nvar)
+! F - Concentrations of fixed species (local)
+ REAL(kind=dp):: f(nfix)
+! RCT - Rate constants (local)
+ REAL(kind=dp):: rct(nreact)
+! Vdot - Time derivative of variable species concentrations
+ REAL(kind=dp):: vdot(nvar)
+
+
+! Computation of equation rates
+ a(1) = rct(1) * v(10)
+ a(2) = rct(2) * v(8) * f(1)
+ a(3) = rct(3) * v(8) * v(11)
+ a(4) = rct(4) * v(7) * v(9)
+ a(5) = rct(5) * v(11) * v(13)
+ a(6) = rct(6) * v(11) * v(12)
+ a(7) = rct(7) * v(9) * v(10)
+
+! Aggregate function
+ vdot(1) = 0
+ vdot(2) = 0
+ vdot(3) = 0
+ vdot(4) = 0
+ vdot(5) = a(7)
+ vdot(6) = a(5)
+ vdot(7) = - a(4)
+ vdot(8) = a(1) - a(2) - a(3)
+ vdot(9) = 2* a(2) - a(4) + a(6) - a(7)
+ vdot(10) = - a(1) + a(3) + a(5) + a(6) - a(7)
+ vdot(11) = a(1) - a(3) - a(5) - a(6)
+ vdot(12) = a(5) - a(6)
+ vdot(13) = a(4) - a(5)
+
+END SUBROUTINE fun
+
+SUBROUTINE kppsolve(jvs, x)
+
+! JVS - sparse Jacobian of variables
+ REAL(kind=dp):: jvs(lu_nonzero)
+! X - Vector for variables
+ REAL(kind=dp):: x(nvar)
+
+ x(9) = x(9) - jvs(16) * x(7) - jvs(17) * x(8)
+ x(10) = x(10) - jvs(22) * x(8) - jvs(23) * x(9)
+ x(11) = x(11) - jvs(28) * x(8) - jvs(29) * x(10)
+ x(12) = x(12) - jvs(33) * x(11)
+ x(13) = x(13) - jvs(36) * x(7) - jvs(37) * x(9) - jvs(38) * x(10) - jvs(39) * x(11) - jvs(40) * x(12)
+ x(13) = x(13) / jvs(41)
+ x(12) = (x(12) - jvs(35) * x(13)) /(jvs(34))
+ x(11) = (x(11) - jvs(31) * x(12) - jvs(32) * x(13)) /(jvs(30))
+ x(10) = (x(10) - jvs(25) * x(11) - jvs(26) * x(12) - jvs(27) * x(13)) /(jvs(24))
+ x(9) = (x(9) - jvs(19) * x(10) - jvs(20) * x(11) - jvs(21) * x(12)) /(jvs(18))
+ x(8) = (x(8) - jvs(14) * x(10) - jvs(15) * x(11)) /(jvs(13))
+ x(7) = (x(7) - jvs(12) * x(9)) /(jvs(11))
+ x(6) = (x(6) - jvs(9) * x(11) - jvs(10) * x(13)) /(jvs(8))
+ x(5) = (x(5) - jvs(6) * x(9) - jvs(7) * x(10)) /(jvs(5))
+ x(4) = x(4) / jvs(4)
+ x(3) = x(3) / jvs(3)
+ x(2) = x(2) / jvs(2)
+ x(1) = x(1) / jvs(1)
+
+END SUBROUTINE kppsolve
+
+SUBROUTINE jac_sp(v, f, rct, jvs)
+
+! V - Concentrations of variable species (local)
+ REAL(kind=dp):: v(nvar)
+! F - Concentrations of fixed species (local)
+ REAL(kind=dp):: f(nfix)
+! RCT - Rate constants (local)
+ REAL(kind=dp):: rct(nreact)
+! JVS - sparse Jacobian of variables
+ REAL(kind=dp):: jvs(lu_nonzero)
+
+
+! Local variables
+! B - Temporary array
+ REAL(kind=dp):: b(17)
+
+! B(1) = dA(1)/dV(10)
+ b(1) = rct(1)
+! B(2) = dA(2)/dV(8)
+ b(2) = rct(2) * f(1)
+! B(4) = dA(3)/dV(8)
+ b(4) = rct(3) * v(11)
+! B(5) = dA(3)/dV(11)
+ b(5) = rct(3) * v(8)
+! B(6) = dA(4)/dV(7)
+ b(6) = rct(4) * v(9)
+! B(7) = dA(4)/dV(9)
+ b(7) = rct(4) * v(7)
+! B(8) = dA(5)/dV(11)
+ b(8) = rct(5) * v(13)
+! B(9) = dA(5)/dV(13)
+ b(9) = rct(5) * v(11)
+! B(10) = dA(6)/dV(11)
+ b(10) = rct(6) * v(12)
+! B(11) = dA(6)/dV(12)
+ b(11) = rct(6) * v(11)
+! B(12) = dA(7)/dV(9)
+ b(12) = rct(7) * v(10)
+! B(13) = dA(7)/dV(10)
+ b(13) = rct(7) * v(9)
+! B(14) = dA(8)/dV(1)
+ b(14) = rct(8)
+! B(15) = dA(9)/dV(2)
+ b(15) = rct(9)
+! B(16) = dA(10)/dV(3)
+ b(16) = rct(10)
+! B(17) = dA(11)/dV(4)
+ b(17) = rct(11)
+
+! Construct the Jacobian terms from B's
+! JVS(1) = Jac_FULL(1,1)
+ jvs(1) = 0
+! JVS(2) = Jac_FULL(2,2)
+ jvs(2) = 0
+! JVS(3) = Jac_FULL(3,3)
+ jvs(3) = 0
+! JVS(4) = Jac_FULL(4,4)
+ jvs(4) = 0
+! JVS(5) = Jac_FULL(5,5)
+ jvs(5) = 0
+! JVS(6) = Jac_FULL(5,9)
+ jvs(6) = b(12)
+! JVS(7) = Jac_FULL(5,10)
+ jvs(7) = b(13)
+! JVS(8) = Jac_FULL(6,6)
+ jvs(8) = 0
+! JVS(9) = Jac_FULL(6,11)
+ jvs(9) = b(8)
+! JVS(10) = Jac_FULL(6,13)
+ jvs(10) = b(9)
+! JVS(11) = Jac_FULL(7,7)
+ jvs(11) = - b(6)
+! JVS(12) = Jac_FULL(7,9)
+ jvs(12) = - b(7)
+! JVS(13) = Jac_FULL(8,8)
+ jvs(13) = - b(2) - b(4)
+! JVS(14) = Jac_FULL(8,10)
+ jvs(14) = b(1)
+! JVS(15) = Jac_FULL(8,11)
+ jvs(15) = - b(5)
+! JVS(16) = Jac_FULL(9,7)
+ jvs(16) = - b(6)
+! JVS(17) = Jac_FULL(9,8)
+ jvs(17) = 2* b(2)
+! JVS(18) = Jac_FULL(9,9)
+ jvs(18) = - b(7) - b(12)
+! JVS(19) = Jac_FULL(9,10)
+ jvs(19) = - b(13)
+! JVS(20) = Jac_FULL(9,11)
+ jvs(20) = b(10)
+! JVS(21) = Jac_FULL(9,12)
+ jvs(21) = b(11)
+! JVS(22) = Jac_FULL(10,8)
+ jvs(22) = b(4)
+! JVS(23) = Jac_FULL(10,9)
+ jvs(23) = - b(12)
+! JVS(24) = Jac_FULL(10,10)
+ jvs(24) = - b(1) - b(13)
+! JVS(25) = Jac_FULL(10,11)
+ jvs(25) = b(5) + b(8) + b(10)
+! JVS(26) = Jac_FULL(10,12)
+ jvs(26) = b(11)
+! JVS(27) = Jac_FULL(10,13)
+ jvs(27) = b(9)
+! JVS(28) = Jac_FULL(11,8)
+ jvs(28) = - b(4)
+! JVS(29) = Jac_FULL(11,10)
+ jvs(29) = b(1)
+! JVS(30) = Jac_FULL(11,11)
+ jvs(30) = - b(5) - b(8) - b(10)
+! JVS(31) = Jac_FULL(11,12)
+ jvs(31) = - b(11)
+! JVS(32) = Jac_FULL(11,13)
+ jvs(32) = - b(9)
+! JVS(33) = Jac_FULL(12,11)
+ jvs(33) = b(8) - b(10)
+! JVS(34) = Jac_FULL(12,12)
+ jvs(34) = - b(11)
+! JVS(35) = Jac_FULL(12,13)
+ jvs(35) = b(9)
+! JVS(36) = Jac_FULL(13,7)
+ jvs(36) = b(6)
+! JVS(37) = Jac_FULL(13,9)
+ jvs(37) = b(7)
+! JVS(38) = Jac_FULL(13,10)
+ jvs(38) = 0
+! JVS(39) = Jac_FULL(13,11)
+ jvs(39) = - b(8)
+! JVS(40) = Jac_FULL(13,12)
+ jvs(40) = 0
+! JVS(41) = Jac_FULL(13,13)
+ jvs(41) = - b(9)
+
+END SUBROUTINE jac_sp
+
+ elemental REAL(kind=dp)FUNCTION k_arr (k_298, tdep, temp)
+ ! arrhenius FUNCTION
+
+ REAL, INTENT(IN):: k_298 ! k at t = 298.15k
+ REAL, INTENT(IN):: tdep ! temperature dependence
+ REAL(kind=dp), INTENT(IN):: temp ! temperature
+
+ intrinsic exp
+
+ k_arr = k_298 * exp(tdep* (1._dp/temp- 3.3540e-3_dp))! 1/298.15=3.3540e-3
+
+ END FUNCTION k_arr
+
+SUBROUTINE update_rconst()
+ INTEGER :: k
+
+ k = is
+
+! Begin INLINED RCONST
+
+
+! End INLINED RCONST
+
+ rconst(1) = (phot(j_no2))
+ rconst(2) = (2.0_dp * 2.2e-10_dp * phot(j_o31d) / (arr2(1.9e+8_dp , -390.0_dp , temp)))
+ rconst(3) = (arr2(1.80e-12_dp , 1370.0_dp , temp))
+ rconst(4) = (arr2(2.00e-11_dp , 500.0_dp , temp))
+ rconst(5) = (arr2(4.20e-12_dp , -180.0_dp , temp))
+ rconst(6) = (arr2(3.70e-12_dp , -240.0_dp , temp))
+ rconst(7) = (arr2(1.15e-11_dp , 0.0_dp , temp))
+ rconst(8) = (1.0_dp)
+ rconst(9) = (1.0_dp)
+ rconst(10) = (1.0_dp)
+ rconst(11) = (1.0_dp)
+
+END SUBROUTINE update_rconst
+
+! END FUNCTION ARR2
+REAL(kind=dp)FUNCTION arr2( a0, b0, temp)
+ REAL(kind=dp):: temp
+ REAL(kind=dp):: a0, b0
+ arr2 = a0 * exp( - b0 / temp)
+END FUNCTION arr2
+
+SUBROUTINE initialize_kpp_ctrl(status)
+
+
+ ! i/o
+ INTEGER, INTENT(OUT):: status
+
+ ! local
+ REAL(dp):: tsum
+ INTEGER :: i
+
+ ! check fixed time steps
+ tsum = 0.0_dp
+ DO i=1, nmaxfixsteps
+ IF (t_steps(i)< tiny(0.0_dp))exit
+ tsum = tsum + t_steps(i)
+ ENDDO
+
+ nfsteps = i- 1
+
+ l_fixed_step = (nfsteps > 0).and.((tsum - 1.0)< tiny(0.0_dp))
+
+ IF (l_vector)THEN
+ WRITE(*,*) ' MODE : VECTOR (LENGTH=',VL_DIM,')'
+ ELSE
+ WRITE(*,*) ' MODE : SCALAR'
+ ENDIF
+ !
+ WRITE(*,*) ' DE-INDEXING MODE :',I_LU_DI
+ !
+ WRITE(*,*) ' ICNTRL : ',icntrl
+ WRITE(*,*) ' RCNTRL : ',rcntrl
+ !
+ ! note: this is ONLY meaningful for vectorized (kp4)rosenbrock- methods
+ IF (l_vector)THEN
+ IF (l_fixed_step)THEN
+ WRITE(*,*) ' TIME STEPS : FIXED (',t_steps(1:nfsteps),')'
+ ELSE
+ WRITE(*,*) ' TIME STEPS : AUTOMATIC'
+ ENDIF
+ ELSE
+ WRITE(*,*) ' TIME STEPS : AUTOMATIC '//&
+ &'(t_steps (CTRL_KPP) ignored in SCALAR MODE)'
+ ENDIF
+ ! mz_pj_20070531-
+
+ status = 0
+
+
+END SUBROUTINE initialize_kpp_ctrl
+
+SUBROUTINE error_output(c, ierr, pe)
+
+
+ INTEGER, INTENT(IN):: ierr
+ INTEGER, INTENT(IN):: pe
+ REAL(dp), DIMENSION(:), INTENT(IN):: c
+
+ write(6,*) 'ERROR in chem_gasphase_mod ',ierr,C(1)
+
+
+END SUBROUTINE error_output
+
+ SUBROUTINE wscal(n, alpha, x, incx)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+! constant times a vector: x(1:N) <- Alpha*x(1:N)
+! only for incX=incY=1
+! after BLAS
+! replace this by the function from the optimized BLAS implementation:
+! CALL SSCAL(N,Alpha,X,1) or CALL DSCAL(N,Alpha,X,1)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ INTEGER :: i, incx, m, mp1, n
+ REAL(kind=dp) :: x(n), alpha
+ REAL(kind=dp), PARAMETER :: zero=0.0_dp, one=1.0_dp
+
+ IF (alpha .eq. one)RETURN
+ IF (n .le. 0)RETURN
+
+ m = mod(n, 5)
+ IF ( m .ne. 0)THEN
+ IF (alpha .eq. (- one))THEN
+ DO i = 1, m
+ x(i) = - x(i)
+ ENDDO
+ ELSEIF (alpha .eq. zero)THEN
+ DO i = 1, m
+ x(i) = zero
+ ENDDO
+ ELSE
+ DO i = 1, m
+ x(i) = alpha* x(i)
+ ENDDO
+ ENDIF
+ IF ( n .lt. 5)RETURN
+ ENDIF
+ mp1 = m + 1
+ IF (alpha .eq. (- one))THEN
+ DO i = mp1, n, 5
+ x(i) = - x(i)
+ x(i + 1) = - x(i + 1)
+ x(i + 2) = - x(i + 2)
+ x(i + 3) = - x(i + 3)
+ x(i + 4) = - x(i + 4)
+ ENDDO
+ ELSEIF (alpha .eq. zero)THEN
+ DO i = mp1, n, 5
+ x(i) = zero
+ x(i + 1) = zero
+ x(i + 2) = zero
+ x(i + 3) = zero
+ x(i + 4) = zero
+ ENDDO
+ ELSE
+ DO i = mp1, n, 5
+ x(i) = alpha* x(i)
+ x(i + 1) = alpha* x(i + 1)
+ x(i + 2) = alpha* x(i + 2)
+ x(i + 3) = alpha* x(i + 3)
+ x(i + 4) = alpha* x(i + 4)
+ ENDDO
+ ENDIF
+
+ END SUBROUTINE wscal
+
+ SUBROUTINE waxpy(n, alpha, x, incx, y, incy)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+! constant times a vector plus a vector: y <- y + Alpha*x
+! only for incX=incY=1
+! after BLAS
+! replace this by the function from the optimized BLAS implementation:
+! CALL SAXPY(N,Alpha,X,1,Y,1) or CALL DAXPY(N,Alpha,X,1,Y,1)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ INTEGER :: i, incx, incy, m, mp1, n
+ REAL(kind=dp):: x(n), y(n), alpha
+ REAL(kind=dp), PARAMETER :: zero = 0.0_dp
+
+ IF (alpha .eq. zero)RETURN
+ IF (n .le. 0)RETURN
+
+ m = mod(n, 4)
+ IF ( m .ne. 0)THEN
+ DO i = 1, m
+ y(i) = y(i) + alpha* x(i)
+ ENDDO
+ IF ( n .lt. 4)RETURN
+ ENDIF
+ mp1 = m + 1
+ DO i = mp1, n, 4
+ y(i) = y(i) + alpha* x(i)
+ y(i + 1) = y(i + 1) + alpha* x(i + 1)
+ y(i + 2) = y(i + 2) + alpha* x(i + 2)
+ y(i + 3) = y(i + 3) + alpha* x(i + 3)
+ ENDDO
+
+ END SUBROUTINE waxpy
+
+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
+!
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+!~~~> arguments
+ INTEGER, INTENT(IN) :: n
+ REAL(kind=dp), INTENT(INOUT):: y(n)
+ REAL(kind=dp), INTENT(IN) :: tstart, tend
+ REAL(kind=dp), INTENT(IN) :: abstol(n), reltol(n)
+ INTEGER, INTENT(IN) :: icntrl(20)
+ REAL(kind=dp), INTENT(IN) :: rcntrl(20)
+ INTEGER, INTENT(INOUT):: istatus(20)
+ REAL(kind=dp), 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
+ REAL(kind=dp):: 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
+ REAL(kind=dp):: roundoff, facmin, facmax, facrej, facsafe
+ REAL(kind=dp):: hmin, hmax, hstart
+ REAL(kind=dp):: texit
+ INTEGER :: i, uplimtol, max_no_steps
+ LOGICAL :: autonomous, vectortol
+!~~~> PARAMETERs
+ REAL(kind=dp), PARAMETER :: zero = 0.0_dp, one = 1.0_dp
+ REAL(kind=dp), 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
+ ENDIF
+
+!~~~> 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
+ ENDIF
+
+!~~~> unit roundoff (1+ roundoff>1)
+ roundoff = epsilon(one)
+
+!~~~> 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
+ ENDIF
+!~~~> 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
+ ENDIF
+!~~~> 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
+ ENDIF
+!~~~> 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
+ ENDIF
+ 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
+ ENDIF
+!~~~> 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
+ ENDIF
+!~~~> 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
+ ENDIF
+!~~~> 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
+ ENDIF
+ ENDDO
+
+
+!~~~> 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ REAL(kind=dp), 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}
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+!~~~> input: the initial condition at tstart; output: the solution at t
+ REAL(kind=dp), INTENT(INOUT):: y(n)
+!~~~> input: integration interval
+ REAL(kind=dp), INTENT(IN):: tstart, tend
+!~~~> output: time at which the solution is RETURNed (t=tendIF success)
+ REAL(kind=dp), INTENT(OUT):: t
+!~~~> input: tolerances
+ REAL(kind=dp), INTENT(IN):: abstol(n), reltol(n)
+!~~~> input: integration PARAMETERs
+ LOGICAL, INTENT(IN):: autonomous, vectortol
+ REAL(kind=dp), INTENT(IN):: hstart, hmin, hmax
+ INTEGER, INTENT(IN):: max_no_steps
+ REAL(kind=dp), INTENT(IN):: roundoff, facmin, facmax, facrej, facsafe
+!~~~> output: error indicator
+ INTEGER, INTENT(OUT):: ierr
+! ~~~~ Local variables
+ REAL(kind=dp):: ynew(n), fcn0(n), fcn(n)
+ REAL(kind=dp):: k(n* ros_s), dfdt(n)
+#ifdef full_algebra
+ REAL(kind=dp):: jac0(n, n), ghimj(n, n)
+#else
+ REAL(kind=dp):: jac0(lu_nonzero), ghimj(lu_nonzero)
+#endif
+ REAL(kind=dp):: h, hnew, hc, hg, fac, tau
+ REAL(kind=dp):: err, yerr(n)
+ INTEGER :: pivot(n), direction, ioffset, j, istage
+ LOGICAL :: rejectlasth, rejectmoreh, singular
+!~~~> local PARAMETERs
+ REAL(kind=dp), PARAMETER :: zero = 0.0_dp, one = 1.0_dp
+ REAL(kind=dp), PARAMETER :: deltamin = 1.0e-5_dp
+!~~~> locally called FUNCTIONs
+! REAL(kind=dp) 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
+ ENDIF
+ 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
+ ENDIF
+ IF (((t+ 0.1_dp* h) == t).or.(h <= roundoff))THEN ! step size too small
+ CALL ros_errormsg(- 7, t, h, ierr)
+ RETURN
+ ENDIF
+
+!~~~> 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)
+ ENDIF
+
+!~~~> 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
+ ENDIF
+
+!~~~> 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
+ !slim: CALL wcopy(n, fcn0, 1, fcn, 1)
+ fcn(1:n) = fcn0(1:n)
+ ! istage>1 and a new FUNCTION evaluation is needed at the current istage
+ ELSEIF(ros_newf(istage))THEN
+ !slim: CALL wcopy(n, y, 1, ynew, 1)
+ ynew(1:n) = y(1:n)
+ DO j = 1, istage-1
+ CALL waxpy(n, ros_a((istage-1) * (istage-2) /2+ j), &
+ k(n* (j- 1) + 1), 1, ynew, 1)
+ ENDDO
+ tau = t + ros_alpha(istage) * direction* h
+ CALL funtemplate(tau, ynew, fcn)
+ istatus(nfun) = istatus(nfun) + 1
+ ENDIF ! IF istage == 1 ELSEIF ros_newf(istage)
+ !slim: CALL wcopy(n, fcn, 1, k(ioffset+ 1), 1)
+ k(ioffset+ 1:ioffset+ n) = fcn(1:n)
+ 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), 1, k(ioffset+ 1), 1)
+ ENDDO
+ 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), 1)
+ ENDIF
+ CALL ros_solve(ghimj, pivot, k(ioffset+ 1))
+
+ END DO stage
+
+
+!~~~> compute the new solution
+ !slim: CALL wcopy(n, y, 1, ynew, 1)
+ ynew(1:n) = y(1:n)
+ DO j=1, ros_s
+ CALL waxpy(n, ros_m(j), k(n* (j- 1) + 1), 1, ynew, 1)
+ ENDDO
+
+!~~~> compute the error estimation
+ !slim: CALL wscal(n, zero, yerr, 1)
+ yerr(1:n) = zero
+ DO j=1, ros_s
+ CALL waxpy(n, ros_e(j), k(n* (j- 1) + 1), 1, yerr, 1)
+ ENDDO
+ 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
+ !slim: CALL wcopy(n, ynew, 1, y, 1)
+ y(1:n) = ynew(1:n)
+ 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)
+ ENDIF
+ 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
+ ENDIF
+ rejectmoreh = rejectlasth
+ rejectlasth = .TRUE.
+ h = hnew
+ IF (istatus(nacc)>= 1) istatus(nrej) = istatus(nrej) + 1
+ ENDIF ! err <= 1
+
+ END DO untilaccepted
+
+ END DO timeloop
+
+!~~~> succesful exit
+ ierr = 1 !~~~> the integration was successful
+
+ END SUBROUTINE ros_integrator
+
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ REAL(kind=dp)FUNCTION ros_errornorm(y, ynew, yerr, &
+ abstol, reltol, vectortol)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> computes the "scaled norm" of the error vector yerr
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+! Input arguments
+ REAL(kind=dp), INTENT(IN):: y(n), ynew(n), &
+ yerr(n), abstol(n), reltol(n)
+ LOGICAL, INTENT(IN):: vectortol
+! Local variables
+ REAL(kind=dp):: err, scale, ymax
+ INTEGER :: i
+ REAL(kind=dp), 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
+ ENDIF
+ err = err+ (yerr(i) /scale) ** 2
+ ENDDO
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+!~~~> input arguments
+ REAL(kind=dp), INTENT(IN):: t, roundoff, y(n), fcn0(n)
+!~~~> output arguments
+ REAL(kind=dp), INTENT(OUT):: dfdt(n)
+!~~~> local variables
+ REAL(kind=dp):: delta
+ REAL(kind=dp), 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
+! --- --- --- --- --- --- --- --- --- --- --- --- ---
+
+!~~~> input arguments
+#ifdef full_algebra
+ REAL(kind=dp), INTENT(IN):: jac0(n, n)
+#else
+ REAL(kind=dp), INTENT(IN):: jac0(lu_nonzero)
+#endif
+ REAL(kind=dp), INTENT(IN):: gam
+ INTEGER, INTENT(IN):: direction
+!~~~> output arguments
+#ifdef full_algebra
+ REAL(kind=dp), INTENT(OUT):: ghimj(n, n)
+#else
+ REAL(kind=dp), INTENT(OUT):: ghimj(lu_nonzero)
+#endif
+ LOGICAL, INTENT(OUT):: singular
+ INTEGER, INTENT(OUT):: pivot(n)
+!~~~> inout arguments
+ REAL(kind=dp), INTENT(INOUT):: h ! step size is decreased when lu fails
+!~~~> local variables
+ INTEGER :: i, ising, nconsecutive
+ REAL(kind=dp):: ghinv
+ REAL(kind=dp), 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
+ !slim: CALL wcopy(n* n, jac0, 1, ghimj, 1)
+ !slim: CALL wscal(n* n, (- one), ghimj, 1)
+ ghimj = - jac0
+ ghinv = one/(direction* h* gam)
+ DO i=1, n
+ ghimj(i, i) = ghimj(i, i) + ghinv
+ ENDDO
+#else
+ !slim: CALL wcopy(lu_nonzero, jac0, 1, ghimj, 1)
+ !slim: CALL wscal(lu_nonzero, (- one), ghimj, 1)
+ ghimj(1:lu_nonzero) = - jac0(1:lu_nonzero)
+ ghinv = one/(direction* h* gam)
+ DO i=1, n
+ ghimj(lu_diag(i)) = ghimj(lu_diag(i)) + ghinv
+ ENDDO
+#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
+ ENDIF ! nconsecutive
+ ENDIF ! ising
+
+ END DO ! WHILE singular
+
+ END SUBROUTINE ros_preparematrix
+
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE ros_decomp( a, pivot, ising)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! Template for the LU decomposition
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> inout variables
+#ifdef full_algebra
+ REAL(kind=dp), INTENT(INOUT):: a(n, n)
+#else
+ REAL(kind=dp), INTENT(INOUT):: a(lu_nonzero)
+#endif
+!~~~> 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)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> input variables
+#ifdef full_algebra
+ REAL(kind=dp), INTENT(IN):: a(n, n)
+ INTEGER :: ising
+#else
+ REAL(kind=dp), INTENT(IN):: a(lu_nonzero)
+#endif
+ INTEGER, INTENT(IN):: pivot(n)
+!~~~> inout variables
+ REAL(kind=dp), INTENT(INOUT):: b(n)
+
+#ifdef full_algebra
+ CALL DGETRS( 'N',N ,1,A,N,Pivot,b,N,ISING)
+ IF (info < 0)THEN
+ print* , "error in dgetrs. ising=", ising
+ ENDIF
+#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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ 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)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+ 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)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> input variables
+ REAL(kind=dp):: t, y(nvar)
+!~~~> output variables
+ REAL(kind=dp):: ydot(nvar)
+!~~~> local variables
+ REAL(kind=dp):: told
+
+ told = time
+ time = t
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> input variables
+ REAL(kind=dp):: t, y(nvar)
+!~~~> output variables
+#ifdef full_algebra
+ REAL(kind=dp):: jv(lu_nonzero), jcb(nvar, nvar)
+#else
+ REAL(kind=dp):: jcb(lu_nonzero)
+#endif
+!~~~> local variables
+ REAL(kind=dp):: told
+#ifdef full_algebra
+ INTEGER :: i, j
+#endif
+
+ told = time
+ time = t
+#ifdef full_algebra
+ CALL jac_sp(y, fix, rconst, jv)
+ DO j=1, nvar
+ DO i=1, nvar
+ jcb(i, j) = 0.0_dp
+ ENDDO
+ ENDDO
+ DO i=1, lu_nonzero
+ jcb(lu_irow(i), lu_icol(i)) = jv(i)
+ ENDDO
+#else
+ CALL jac_sp( y, fix, rconst, jcb)
+#endif
+ time = told
+
+END SUBROUTINE jactemplate
+
+ SUBROUTINE kppdecomp( jvs, ier)
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! sparse lu factorization
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! loop expansion generated by kp4
+
+ INTEGER :: ier
+ REAL(kind=dp):: jvs(lu_nonzero), w(nvar), a
+ INTEGER :: k, kk, j, jj
+
+ a = 0.
+ ier = 0
+
+! i = 1
+! i = 2
+! i = 3
+! i = 4
+! i = 5
+! i = 6
+! i = 7
+! i = 8
+! i = 9
+ jvs(16) = (jvs(16)) / jvs(11)
+ jvs(17) = (jvs(17)) / jvs(13)
+ jvs(18) = jvs(18) - jvs(12) * jvs(16)
+ jvs(19) = jvs(19) - jvs(14) * jvs(17)
+ jvs(20) = jvs(20) - jvs(15) * jvs(17)
+! i = 10
+ jvs(22) = (jvs(22)) / jvs(13)
+ jvs(23) = (jvs(23)) / jvs(18)
+ jvs(24) = jvs(24) - jvs(14) * jvs(22) - jvs(19) * jvs(23)
+ jvs(25) = jvs(25) - jvs(15) * jvs(22) - jvs(20) * jvs(23)
+ jvs(26) = jvs(26) - jvs(21) * jvs(23)
+! i = 11
+ jvs(28) = (jvs(28)) / jvs(13)
+ a = 0.0; a = a - jvs(14) * jvs(28)
+ jvs(29) = (jvs(29) + a) / jvs(24)
+ jvs(30) = jvs(30) - jvs(15) * jvs(28) - jvs(25) * jvs(29)
+ jvs(31) = jvs(31) - jvs(26) * jvs(29)
+ jvs(32) = jvs(32) - jvs(27) * jvs(29)
+! i = 12
+ jvs(33) = (jvs(33)) / jvs(30)
+ jvs(34) = jvs(34) - jvs(31) * jvs(33)
+ jvs(35) = jvs(35) - jvs(32) * jvs(33)
+! i = 13
+ jvs(36) = (jvs(36)) / jvs(11)
+ a = 0.0; a = a - jvs(12) * jvs(36)
+ jvs(37) = (jvs(37) + a) / jvs(18)
+ a = 0.0; a = a - jvs(19) * jvs(37)
+ jvs(38) = (jvs(38) + a) / jvs(24)
+ a = 0.0; a = a - jvs(20) * jvs(37) - jvs(25) * jvs(38)
+ jvs(39) = (jvs(39) + a) / jvs(30)
+ a = 0.0; a = a - jvs(21) * jvs(37) - jvs(26) * jvs(38) - jvs(31) * jvs(39)
+ jvs(40) = (jvs(40) + a) / jvs(34)
+ jvs(41) = jvs(41) - jvs(27) * jvs(38) - jvs(32) * jvs(39) - jvs(35) * jvs(40)
+ RETURN
+
+ END SUBROUTINE kppdecomp
+
+SUBROUTINE chem_gasphase_integrate (time_step_len, conc, tempi, qvapi, fakti, photo, ierrf, xnacc, xnrej, istatus, l_debug, pe, &
+ icntrl_i, rcntrl_i)
+
+ IMPLICIT NONE
+
+ REAL(dp), INTENT(IN) :: time_step_len
+ REAL(dp), DIMENSION(:, :), INTENT(INOUT) :: conc
+ REAL(dp), DIMENSION(:, :), INTENT(IN) :: photo
+ REAL(dp), DIMENSION(:), INTENT(IN) :: tempi
+ REAL(dp), DIMENSION(:), INTENT(IN) :: qvapi
+ REAL(dp), DIMENSION(:), INTENT(IN) :: fakti
+ INTEGER, INTENT(OUT), OPTIONAL :: ierrf(:)
+ INTEGER, INTENT(OUT), OPTIONAL :: xnacc(:)
+ INTEGER, INTENT(OUT), OPTIONAL :: xnrej(:)
+ INTEGER, INTENT(INOUT), OPTIONAL :: istatus(:)
+ INTEGER, INTENT(IN), OPTIONAL :: pe
+ LOGICAL, INTENT(IN), OPTIONAL :: l_debug
+ INTEGER, DIMENSION(nkppctrl), INTENT(IN), OPTIONAL :: icntrl_i
+ REAL(dp), DIMENSION(nkppctrl), INTENT(IN), OPTIONAL :: rcntrl_i
+
+ INTEGER :: k ! loop variable
+ REAL(dp) :: dt
+ INTEGER, DIMENSION(20) :: istatus_u
+ INTEGER :: ierr_u
+ INTEGER :: istatf
+ INTEGER :: vl_dim_lo
+
+
+ IF (PRESENT (istatus)) istatus = 0
+ IF (PRESENT (icntrl_i)) icntrl = icntrl_i
+ IF (PRESENT (rcntrl_i)) rcntrl = rcntrl_i
+
+ vl_glo = size(tempi, 1)
+
+ vl_dim_lo = vl_dim
+ DO k=1, vl_glo, vl_dim_lo
+ is = k
+ ie = min(k+ vl_dim_lo-1, vl_glo)
+ vl = ie-is+ 1
+
+ c(:) = conc(is, :)
+
+ temp = tempi(is)
+
+ qvap = qvapi(is)
+
+ fakt = fakti(is)
+
+ CALL initialize
+
+ phot(:) = photo(is, :)
+
+ CALL update_rconst
+
+ dt = time_step_len
+
+ ! integrate from t=0 to t=dt
+ CALL integrate(0._dp, dt, icntrl, rcntrl, istatus_u = istatus_u, ierr_u=ierr_u)
+
+
+ IF (PRESENT(l_debug) .AND. PRESENT(pe)) THEN
+ IF (l_debug) CALL error_output(conc(is, :), ierr_u, pe)
+ ENDIF
+
+ conc(is, :) = c(:)
+
+ ! RETURN diagnostic information
+
+ IF (PRESENT(ierrf)) ierrf(is) = ierr_u
+ IF (PRESENT(xnacc)) xnacc(is) = istatus_u(4)
+ IF (PRESENT(xnrej)) xnrej(is) = istatus_u(5)
+
+ IF (PRESENT (istatus)) THEN
+ istatus(1:8) = istatus(1:8) + istatus_u(1:8)
+ ENDIF
+
+ END DO
+
+
+! Deallocate input arrays
+
+
+ data_loaded = .FALSE.
+
+ RETURN
+END SUBROUTINE chem_gasphase_integrate
+
+END MODULE chem_gasphase_mod
+
Index: /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+simple/chem_gasphase_mod.kpp
===================================================================
--- /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+simple/chem_gasphase_mod.kpp (revision 3698)
+++ /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+simple/chem_gasphase_mod.kpp (revision 3698)
@@ -0,0 +1,42 @@
+//chem_gasphase_mod.kpp
+//
+//Former revisions
+//----------------
+// $Id: chem_gasphase_mod.kpp 2459 2017-09-13 14:10:33Z forkel $
+// initial revision from branch salsa rev 3576 (29.11.2018, monakurppa)
+//
+#include salsa+simple.spc
+#include salsa+simple.eqn
+#INTEGRATOR rosenbrock
+#LANGUAGE Fortran90
+#HESSIAN on
+#STOICMAT on
+#INLINE F90_GLOBAL
+! QVAP - Water vapor
+ REAL(dp) :: qvap
+! FAKT - Conversion factor
+ REAL(dp) :: fakt
+! Declaration of global variable declarations for photolysis will come from INLINE F90_DATA
+#ENDINLINE
+//
+// *******************************************************************************************
+// *** adapt the lines below occurding to the photolysis reactions of your mechanism *
+// *** adapt the number of photolysis frequencies NPHO *
+// *** adapt/extend the indices in the INTEGER, PARAMETER,PUBLIC statement below *
+// *** adapt/extend PHOT_NAMES: Note that the order of PHOT_NAMES and the indices must match *
+// *******************************************************************************************
+//
+#INLINE F90_DATA
+ ! INLINE F90_DATA: Declaration of global variables for photolysis
+ ! REAL(kind=dp) :: phot(nphot) must eventually be moved to GLOBAL later for vector version
+ INTEGER, PARAMETER :: nphot = 2
+ ! phot Photolysis frequencies
+ REAL(kind=dp) :: phot(nphot)
+
+ INTEGER, PARAMETER,PUBLIC :: j_no2 = 1
+ INTEGER, PARAMETER,PUBLIC :: j_o31d = 2
+
+ CHARACTER(LEN=15), PARAMETER, DIMENSION(NPHOT) :: phot_names = (/ &
+ 'J_NO2 ','J_O31D '/)
+#ENDINLINE
+
Index: /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+simple/salsa+simple.eqn
===================================================================
--- /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+simple/salsa+simple.eqn (revision 3698)
+++ /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+simple/salsa+simple.eqn (revision 3698)
@@ -0,0 +1,25 @@
+{salsa+simple.eqn
+Current revision
+----------------
+ 20181220 Fixed effective rate of equation 2 forkel
+ according to eq. 11.1 of
+ http://acmg.seas.harvard.edu/publications/jacobbook/bookchap11.pdf
+ 20180903 Added SALSA variables to 'simple' monakurppa
+ 20180316 Added equation no. 7 forkel
+ 201711xx Created simple.eqn with 6 equations forkel
+}
+#EQUATIONS
+
+{ simplified smog (by forkel) and salsa variables }
+
+ { 1.} NO2 + hv = NO + O3 : phot(j_no2);
+ { 2.} O3 + H2O = 2OH : 2.0_dp * 2.2E-10_dp * phot(j_o31d) / (arr2(1.9E+8_dp, -390.0_dp, temp));
+ { 3.} NO + O3 = NO2 : arr2(1.80E-12_dp, 1370.0_dp, temp);
+ { 4.} RH + OH = RO2 + H2O : arr2(2.00E-11_dp, 500.0_dp, temp);
+ { 5.} RO2 + NO = NO2 + RCHO + HO2 : arr2(4.20E-12_dp, -180.0_dp, temp);
+ { 6.} HO2 + NO = NO2 + OH : arr2(3.70E-12_dp, -240.0_dp, temp);
+ { 7.} NO2 + OH = HNO3 : arr2(1.15E-11_dp, 0.0_dp, temp);
+ { 8.} H2SO4 = H2SO4 : 1.0_dp;
+ { 9.} NH3 = NH3 : 1.0_dp;
+ { 10.} OCNV = OCNV : 1.0_dp;
+ { 11.} OCSV = OCSV : 1.0_dp;
Index: /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+simple/salsa+simple.spc
===================================================================
--- /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+simple/salsa+simple.spc (revision 3698)
+++ /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+simple/salsa+simple.spc (revision 3698)
@@ -0,0 +1,50 @@
+{salsa+simple.spc
+Current revision
+----------------
+ 20180903 Added SALSA variables monakurppa
+Former revisions
+----------------
+ $Id: smog.spc 2459 2017-09-13 14:10:33Z forkel $
+}
+#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}
+ CO = C + O ; {carbon monoxide}
+
+ RH = ignore ; {alkanes}
+ RO2 = ignore ; {alkyl peroxy radical}
+ RCHO = ignore ; {carbonyl}
+ RCOO2 = ignore ;
+ RCOO2NO2= ignore ;
+
+ H2SO4 = 2H + S +4O ; {sulfuric acid}
+ NH3 = 3H + N ; {ammonia}
+ OCNV = ignore ; {non-volatile OC}
+ OCSV = ignore ; {semi-volatile OC}
+
+#DEFFIX
+ H2O = H + 2O ; {water}
+ H2 = 2H ; {molecular hydrogen}
+ O2 = 2O ; {molecular oxygen}
+ N2 = 2N ; {molecular nitrogen}
+ CH4 = C + 4H ; {methane}
+ CO2 = C + 2O ; {carbon dioxide}
+
Index: /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsagas/chem_gasphase_mod.f90
===================================================================
--- /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsagas/chem_gasphase_mod.f90 (revision 3698)
+++ /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsagas/chem_gasphase_mod.f90 (revision 3698)
@@ -0,0 +1,2345 @@
+MODULE chem_gasphase_mod
+
+! Mechanism: salsagas
+!
+!------------------------------------------------------------------------------!
+!
+! ******Module chem_gasphase_mod is automatically generated by kpp4palm ******
+!
+! *********Please do NOT change this Code,it will be ovewritten *********
+!
+!------------------------------------------------------------------------------!
+! This file was created by KPP (http://people.cs.vt.edu/asandu/Software/Kpp/)
+! and kpp4palm (created by Klaus Ketelsen). kpp4palm is an adapted version
+! of KP4 (Jöckel,P.,Kerkweg,A.,Pozzer,A.,Sander,R.,Tost,H.,Riede,
+! H.,Baumgaertner,A.,Gromov,S.,and Kern,B.,2010: Development cycle 2 of
+! the Modular Earth Submodel System (MESSy2),Geosci. Model Dev.,3,717-752,
+! https://doi.org/10.5194/gmd-3-717-2010). KP4 is part of the Modular Earth
+! Submodel System (MESSy),which is is available under the GNU General Public
+! License (GPL).
+!
+! KPP is free software; you can redistribute it and/or modify it under the terms
+! of the General Public Licence as published by the Free Software Foundation;
+! 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 Licence for more details.
+!
+!------------------------------------------------------------------------------!
+! This file is part of the PALM model system.
+!
+! PALM is free software: you can redistribute it and/or modify it under the
+! terms of the GNU General Public License as published by the Free Software
+! Foundation,either version 3 of the License,or (at your option) any later
+! version.
+!
+! PALM 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
+! PALM. If not,see .
+!
+! Copyright 1997-2019 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+!
+! MODULE HEADER TEMPLATE
+!
+! Initial version (Nov. 2016,ketelsen),for later modifications of module_header
+! see comments in kpp4palm/src/create_kpp_module.C
+
+! Set kpp Double Precision to PALM Default Precision
+
+ USE kinds, ONLY: dp=>wp
+
+ USE pegrid, ONLY: myid, threads_per_task
+
+ IMPLICIT NONE
+ PRIVATE
+ !SAVE ! note: occurs again in automatically generated code ...
+
+! PUBLIC :: IERR_NAMES
+
+! PUBLIC :: SPC_NAMES,EQN_NAMES,EQN_TAGS,REQ_HET,REQ_AEROSOL,REQ_PHOTRAT &
+! ,REQ_MCFCT,IP_MAX,jname
+
+ PUBLIC :: eqn_names, phot_names, spc_names
+ PUBLIC :: nmaxfixsteps
+ PUBLIC :: atol, rtol
+ PUBLIC :: nspec, nreact
+ PUBLIC :: temp
+ PUBLIC :: qvap
+ PUBLIC :: fakt
+ PUBLIC :: phot
+ PUBLIC :: rconst
+ PUBLIC :: nvar
+ PUBLIC :: nphot
+ PUBLIC :: vl_dim ! PUBLIC to ebable other MODULEs to distiguish between scalar and vec
+
+ PUBLIC :: initialize, integrate, update_rconst
+ PUBLIC :: chem_gasphase_integrate
+ PUBLIC :: initialize_kpp_ctrl
+
+! END OF MODULE HEADER TEMPLATE
+
+! Variables used for vector mode
+
+ LOGICAL, PARAMETER :: l_vector = .FALSE.
+ INTEGER, PARAMETER :: i_lu_di = 2
+ INTEGER, PARAMETER :: vl_dim = 1
+ INTEGER :: vl
+
+ INTEGER :: vl_glo
+ INTEGER :: is, ie
+
+
+ INTEGER, DIMENSION(vl_dim) :: kacc, krej
+ INTEGER, DIMENSION(vl_dim) :: ierrv
+ LOGICAL :: data_loaded = .FALSE.
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Parameter Module File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Parameters.f90
+! Time : Fri Nov 30 13:52:19 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! NSPEC - Number of chemical species
+ INTEGER, PARAMETER :: nspec = 5
+! NVAR - Number of Variable species
+ INTEGER, PARAMETER :: nvar = 5
+! NVARACT - Number of Active species
+ INTEGER, PARAMETER :: nvaract = 5
+! NFIX - Number of Fixed species
+ INTEGER, PARAMETER :: nfix = 1
+! NREACT - Number of reactions
+ INTEGER, PARAMETER :: nreact = 5
+! NVARST - Starting of variables in conc. vect.
+ INTEGER, PARAMETER :: nvarst = 1
+! NFIXST - Starting of fixed in conc. vect.
+ INTEGER, PARAMETER :: nfixst = 6
+! NONZERO - Number of nonzero entries in Jacobian
+ INTEGER, PARAMETER :: nonzero = 5
+! LU_NONZERO - Number of nonzero entries in LU factoriz. of Jacobian
+ INTEGER, PARAMETER :: lu_nonzero = 5
+! CNVAR - (NVAR+1) Number of elements in compressed row format
+ INTEGER, PARAMETER :: cnvar = 6
+! CNEQN - (NREACT+1) Number stoicm elements in compressed col format
+ INTEGER, PARAMETER :: cneqn = 6
+! NHESS - Length of Sparse Hessian
+ INTEGER, PARAMETER :: nhess = 1
+! NMASS - Number of atoms to check mass balance
+ INTEGER, PARAMETER :: nmass = 1
+
+! Index declaration for variable species in C and VAR
+! VAR(ind_spc) = C(ind_spc)
+
+ INTEGER, PARAMETER, PUBLIC :: ind_hno3 = 1
+ INTEGER, PARAMETER, PUBLIC :: ind_h2so4 = 2
+ INTEGER, PARAMETER, PUBLIC :: ind_nh3 = 3
+ INTEGER, PARAMETER, PUBLIC :: ind_ocnv = 4
+ INTEGER, PARAMETER, PUBLIC :: ind_ocsv = 5
+
+! Index declaration for fixed species in C
+! C(ind_spc)
+
+
+! Index declaration for fixed species in FIX
+! FIX(indf_spc) = C(ind_spc) = C(NVAR+indf_spc)
+
+
+! NJVRP - Length of sparse Jacobian JVRP
+ INTEGER, PARAMETER :: njvrp = 5
+
+! NSTOICM - Length of Sparse Stoichiometric Matrix
+ INTEGER, PARAMETER :: nstoicm = 1
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Global Data Module File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Global.f90
+! Time : Fri Nov 30 13:52:19 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! Declaration of global variables
+
+! C - Concentration of all species
+ REAL(kind=dp):: c(nspec)
+! VAR - Concentrations of variable species (global)
+ REAL(kind=dp):: var(nvar)
+! FIX - Concentrations of fixed species (global)
+ REAL(kind=dp):: fix(nfix)
+! VAR,FIX are chunks of array C
+ EQUIVALENCE( c(1), var(1))
+! RCONST - Rate constants (global)
+ REAL(kind=dp):: rconst(nreact)
+! TIME - Current integration time
+ REAL(kind=dp):: time
+! TEMP - Temperature
+ REAL(kind=dp):: temp
+! TSTART - Integration start time
+ REAL(kind=dp):: tstart
+! ATOL - Absolute tolerance
+ REAL(kind=dp):: atol(nvar)
+! RTOL - Relative tolerance
+ REAL(kind=dp):: rtol(nvar)
+! STEPMIN - Lower bound for integration step
+ REAL(kind=dp):: stepmin
+! CFACTOR - Conversion factor for concentration units
+ REAL(kind=dp):: cfactor
+
+! INLINED global variable declarations
+
+ ! declaration of global variable declarations for photolysis will come from
+
+! QVAP - Water vapor
+ REAL(kind=dp):: qvap
+! FAKT - Conversion factor
+ REAL(kind=dp):: fakt
+
+
+! INLINED global variable declarations
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Sparse Jacobian Data Structures File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_JacobianSP.f90
+! Time : Fri Nov 30 13:52:19 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! Sparse Jacobian Data
+
+
+ INTEGER, PARAMETER, DIMENSION(5):: lu_irow = (/ &
+ 1, 2, 3, 4, 5 /)
+
+ INTEGER, PARAMETER, DIMENSION(5):: lu_icol = (/ &
+ 1, 2, 3, 4, 5 /)
+
+ INTEGER, PARAMETER, DIMENSION(6):: lu_crow = (/ &
+ 1, 2, 3, 4, 5, 6 /)
+
+ INTEGER, PARAMETER, DIMENSION(6):: lu_diag = (/ &
+ 1, 2, 3, 4, 5, 6 /)
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Utility Data Module File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Monitor.f90
+! Time : Fri Nov 30 13:52:19 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+ CHARACTER(len=15), PARAMETER, DIMENSION(5):: spc_names = (/ &
+ 'HNO3 ','H2SO4 ','NH3 ',&
+ 'OCNV ','OCSV ' /)
+
+ CHARACTER(len=100), PARAMETER, DIMENSION(5):: eqn_names = (/ &
+ 'H2SO4 --> H2SO4 ',&
+ ' HNO3 --> HNO3 ',&
+ ' NH3 --> NH3 ',&
+ ' OCNV --> OCNV ',&
+ ' OCSV --> OCSV ' /)
+
+! INLINED global variables
+
+ ! inline f90_data: declaration of global variables for photolysis
+ ! REAL(kind=dp):: phot(nphot)must eventually be moved to global later for
+ INTEGER, PARAMETER :: nphot = 1
+ ! phot photolysis frequencies
+ REAL(kind=dp):: phot(nphot)
+
+ INTEGER, PARAMETER, PUBLIC :: j_no2 = 1
+
+ CHARACTER(len=15), PARAMETER, DIMENSION(nphot):: phot_names = (/ &
+ 'J_NO2 '/)
+
+! End INLINED global variables
+
+
+! Automatic generated PUBLIC Statements for ip_ and ihs_ variables
+
+! Automatic generated PUBLIC Statements for ip_ and ihs_ variables
+
+! Automatic generated PUBLIC Statements for ip_ and ihs_ variables
+
+! Automatic generated PUBLIC Statements for ip_ and ihs_ variables
+
+
+! variable definations from individual module headers
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Initialization File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Initialize.f90
+! Time : Fri Nov 30 13:52:19 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Numerical Integrator (Time-Stepping) File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Integrator.f90
+! Time : Fri Nov 30 13:52:19 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! INTEGRATE - Integrator routine
+! Arguments :
+! TIN - Start Time for Integration
+! TOUT - End Time for Integration
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!
+! 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 !
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!
+
+
+ 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
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Linear Algebra Data and Routines File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_LinearAlgebra.f90
+! Time : Fri Nov 30 13:52:19 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! The ODE Jacobian of Chemical Model File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Jacobian.f90
+! Time : Fri Nov 30 13:52:19 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! The ODE Function of Chemical Model File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Function.f90
+! Time : Fri Nov 30 13:52:19 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+! A - Rate for each equation
+ REAL(kind=dp):: a(nreact)
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! The Reaction Rates File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Rates.f90
+! Time : Fri Nov 30 13:52:19 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Auxiliary Routines File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Util.f90
+! Time : Fri Nov 30 13:52:19 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181130/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+ ! header MODULE initialize_kpp_ctrl_template
+
+ ! notes:
+ ! - l_vector is automatically defined by kp4
+ ! - vl_dim is automatically defined by kp4
+ ! - i_lu_di is automatically defined by kp4
+ ! - wanted is automatically defined by xmecca
+ ! - icntrl rcntrl are automatically defined by kpp
+ ! - "USE messy_main_tools" is in MODULE_header of messy_mecca_kpp.f90
+ ! - SAVE will be automatically added by kp4
+
+ !SAVE
+
+ ! for fixed time step control
+ ! ... max. number of fixed time steps (sum must be 1)
+ INTEGER, PARAMETER :: nmaxfixsteps = 50
+ ! ... switch for fixed time stepping
+ LOGICAL, PUBLIC :: l_fixed_step = .FALSE.
+ INTEGER, PUBLIC :: nfsteps = 1
+ ! ... number of kpp control PARAMETERs
+ INTEGER, PARAMETER, PUBLIC :: nkppctrl = 20
+ !
+ INTEGER, DIMENSION(nkppctrl), PUBLIC :: icntrl = 0
+ REAL(dp), DIMENSION(nkppctrl), PUBLIC :: rcntrl = 0.0_dp
+ REAL(dp), DIMENSION(nmaxfixsteps), PUBLIC :: t_steps = 0.0_dp
+
+ ! END header MODULE initialize_kpp_ctrl_template
+
+
+! Interface Block
+
+ INTERFACE initialize
+ MODULE PROCEDURE initialize
+ END INTERFACE initialize
+
+ INTERFACE integrate
+ MODULE PROCEDURE integrate
+ END INTERFACE integrate
+
+ INTERFACE fun
+ MODULE PROCEDURE fun
+ END INTERFACE fun
+
+ INTERFACE kppsolve
+ MODULE PROCEDURE kppsolve
+ END INTERFACE kppsolve
+
+ INTERFACE jac_sp
+ MODULE PROCEDURE jac_sp
+ END INTERFACE jac_sp
+
+ INTERFACE k_arr
+ MODULE PROCEDURE k_arr
+ END INTERFACE k_arr
+
+ INTERFACE update_rconst
+ MODULE PROCEDURE update_rconst
+ END INTERFACE update_rconst
+
+ INTERFACE arr2
+ MODULE PROCEDURE arr2
+ END INTERFACE arr2
+
+ INTERFACE initialize_kpp_ctrl
+ MODULE PROCEDURE initialize_kpp_ctrl
+ END INTERFACE initialize_kpp_ctrl
+
+ INTERFACE error_output
+ MODULE PROCEDURE error_output
+ END INTERFACE error_output
+
+ INTERFACE wscal
+ MODULE PROCEDURE wscal
+ END INTERFACE wscal
+
+!INTERFACE not working INTERFACE waxpy
+!INTERFACE not working MODULE PROCEDURE waxpy
+!INTERFACE not working END INTERFACE waxpy
+
+ INTERFACE rosenbrock
+ MODULE PROCEDURE rosenbrock
+ END INTERFACE rosenbrock
+
+ INTERFACE funtemplate
+ MODULE PROCEDURE funtemplate
+ END INTERFACE funtemplate
+
+ INTERFACE jactemplate
+ MODULE PROCEDURE jactemplate
+ END INTERFACE jactemplate
+
+ INTERFACE kppdecomp
+ MODULE PROCEDURE kppdecomp
+ END INTERFACE kppdecomp
+
+ INTERFACE chem_gasphase_integrate
+ MODULE PROCEDURE chem_gasphase_integrate
+ END INTERFACE chem_gasphase_integrate
+
+
+ CONTAINS
+
+SUBROUTINE initialize()
+
+
+ INTEGER :: j, k
+
+ INTEGER :: i
+ REAL(kind=dp):: x
+ k = is
+ cfactor = 1.000000e+00_dp
+
+ x = (0.) * cfactor
+ DO i = 1 , nvar
+ ENDDO
+
+ x = (0.) * cfactor
+ DO i = 1 , nfix
+ fix(i) = x
+ ENDDO
+
+! constant rate coefficients
+! END constant rate coefficients
+
+! INLINED initializations
+
+! End INLINED initializations
+
+
+END SUBROUTINE initialize
+
+SUBROUTINE integrate( tin, tout, &
+ icntrl_u, rcntrl_u, istatus_u, rstatus_u, ierr_u)
+
+
+ REAL(kind=dp), INTENT(IN):: tin ! start time
+ REAL(kind=dp), INTENT(IN):: tout ! END time
+ ! OPTIONAL input PARAMETERs and statistics
+ INTEGER, INTENT(IN), OPTIONAL :: icntrl_u(20)
+ REAL(kind=dp), INTENT(IN), OPTIONAL :: rcntrl_u(20)
+ INTEGER, INTENT(OUT), OPTIONAL :: istatus_u(20)
+ REAL(kind=dp), INTENT(OUT), OPTIONAL :: rstatus_u(20)
+ INTEGER, INTENT(OUT), OPTIONAL :: ierr_u
+
+ REAL(kind=dp):: 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(:)
+ ENDIF
+ IF (PRESENT(rcntrl_u))THEN
+ WHERE(rcntrl_u(:)> 0)rcntrl(:) = rcntrl_u(:)
+ ENDIF
+
+
+ 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 fun(v, f, rct, vdot)
+
+! V - Concentrations of variable species (local)
+ REAL(kind=dp):: v(nvar)
+! F - Concentrations of fixed species (local)
+ REAL(kind=dp):: f(nfix)
+! RCT - Rate constants (local)
+ REAL(kind=dp):: rct(nreact)
+! Vdot - Time derivative of variable species concentrations
+ REAL(kind=dp):: vdot(nvar)
+
+
+! Computation of equation rates
+
+! Aggregate function
+ vdot(1) = 0
+ vdot(2) = 0
+ vdot(3) = 0
+ vdot(4) = 0
+ vdot(5) = 0
+
+END SUBROUTINE fun
+
+SUBROUTINE kppsolve(jvs, x)
+
+! JVS - sparse Jacobian of variables
+ REAL(kind=dp):: jvs(lu_nonzero)
+! X - Vector for variables
+ REAL(kind=dp):: x(nvar)
+
+ x(5) = x(5) / jvs(5)
+ x(4) = x(4) / jvs(4)
+ x(3) = x(3) / jvs(3)
+ x(2) = x(2) / jvs(2)
+ x(1) = x(1) / jvs(1)
+
+END SUBROUTINE kppsolve
+
+SUBROUTINE jac_sp(v, f, rct, jvs)
+
+! V - Concentrations of variable species (local)
+ REAL(kind=dp):: v(nvar)
+! F - Concentrations of fixed species (local)
+ REAL(kind=dp):: f(nfix)
+! RCT - Rate constants (local)
+ REAL(kind=dp):: rct(nreact)
+! JVS - sparse Jacobian of variables
+ REAL(kind=dp):: jvs(lu_nonzero)
+
+
+! Local variables
+! B - Temporary array
+ REAL(kind=dp):: b(5)
+
+! B(1) = dA(1)/dV(2)
+ b(1) = rct(1)
+! B(2) = dA(2)/dV(1)
+ b(2) = rct(2)
+! B(3) = dA(3)/dV(3)
+ b(3) = rct(3)
+! B(4) = dA(4)/dV(4)
+ b(4) = rct(4)
+! B(5) = dA(5)/dV(5)
+ b(5) = rct(5)
+
+! Construct the Jacobian terms from B's
+! JVS(1) = Jac_FULL(1,1)
+ jvs(1) = 0
+! JVS(2) = Jac_FULL(2,2)
+ jvs(2) = 0
+! JVS(3) = Jac_FULL(3,3)
+ jvs(3) = 0
+! JVS(4) = Jac_FULL(4,4)
+ jvs(4) = 0
+! JVS(5) = Jac_FULL(5,5)
+ jvs(5) = 0
+
+END SUBROUTINE jac_sp
+
+ elemental REAL(kind=dp)FUNCTION k_arr (k_298, tdep, temp)
+ ! arrhenius FUNCTION
+
+ REAL, INTENT(IN):: k_298 ! k at t = 298.15k
+ REAL, INTENT(IN):: tdep ! temperature dependence
+ REAL(kind=dp), INTENT(IN):: temp ! temperature
+
+ intrinsic exp
+
+ k_arr = k_298 * exp(tdep* (1._dp/temp- 3.3540e-3_dp))! 1/298.15=3.3540e-3
+
+ END FUNCTION k_arr
+
+SUBROUTINE update_rconst()
+ INTEGER :: k
+
+ k = is
+
+! Begin INLINED RCONST
+
+
+! End INLINED RCONST
+
+ rconst(1) = (1.0_dp)
+ rconst(2) = (1.0_dp)
+ rconst(3) = (1.0_dp)
+ rconst(4) = (1.0_dp)
+ rconst(5) = (1.0_dp)
+
+END SUBROUTINE update_rconst
+
+! END FUNCTION ARR2
+REAL(kind=dp)FUNCTION arr2( a0, b0, temp)
+ REAL(kind=dp):: temp
+ REAL(kind=dp):: a0, b0
+ arr2 = a0 * exp( - b0 / temp)
+END FUNCTION arr2
+
+SUBROUTINE initialize_kpp_ctrl(status)
+
+
+ ! i/o
+ INTEGER, INTENT(OUT):: status
+
+ ! local
+ REAL(dp):: tsum
+ INTEGER :: i
+
+ ! check fixed time steps
+ tsum = 0.0_dp
+ DO i=1, nmaxfixsteps
+ IF (t_steps(i)< tiny(0.0_dp))exit
+ tsum = tsum + t_steps(i)
+ ENDDO
+
+ nfsteps = i- 1
+
+ l_fixed_step = (nfsteps > 0).and.((tsum - 1.0)< tiny(0.0_dp))
+
+ IF (l_vector)THEN
+ WRITE(*,*) ' MODE : VECTOR (LENGTH=',VL_DIM,')'
+ ELSE
+ WRITE(*,*) ' MODE : SCALAR'
+ ENDIF
+ !
+ WRITE(*,*) ' DE-INDEXING MODE :',I_LU_DI
+ !
+ WRITE(*,*) ' ICNTRL : ',icntrl
+ WRITE(*,*) ' RCNTRL : ',rcntrl
+ !
+ ! note: this is ONLY meaningful for vectorized (kp4)rosenbrock- methods
+ IF (l_vector)THEN
+ IF (l_fixed_step)THEN
+ WRITE(*,*) ' TIME STEPS : FIXED (',t_steps(1:nfsteps),')'
+ ELSE
+ WRITE(*,*) ' TIME STEPS : AUTOMATIC'
+ ENDIF
+ ELSE
+ WRITE(*,*) ' TIME STEPS : AUTOMATIC '//&
+ &'(t_steps (CTRL_KPP) ignored in SCALAR MODE)'
+ ENDIF
+ ! mz_pj_20070531-
+
+ status = 0
+
+
+END SUBROUTINE initialize_kpp_ctrl
+
+SUBROUTINE error_output(c, ierr, pe)
+
+
+ INTEGER, INTENT(IN):: ierr
+ INTEGER, INTENT(IN):: pe
+ REAL(dp), DIMENSION(:), INTENT(IN):: c
+
+ write(6,*) 'ERROR in chem_gasphase_mod ',ierr,C(1)
+
+
+END SUBROUTINE error_output
+
+ SUBROUTINE wscal(n, alpha, x, incx)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+! constant times a vector: x(1:N) <- Alpha*x(1:N)
+! only for incX=incY=1
+! after BLAS
+! replace this by the function from the optimized BLAS implementation:
+! CALL SSCAL(N,Alpha,X,1) or CALL DSCAL(N,Alpha,X,1)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ INTEGER :: i, incx, m, mp1, n
+ REAL(kind=dp) :: x(n), alpha
+ REAL(kind=dp), PARAMETER :: zero=0.0_dp, one=1.0_dp
+
+ IF (alpha .eq. one)RETURN
+ IF (n .le. 0)RETURN
+
+ m = mod(n, 5)
+ IF ( m .ne. 0)THEN
+ IF (alpha .eq. (- one))THEN
+ DO i = 1, m
+ x(i) = - x(i)
+ ENDDO
+ ELSEIF (alpha .eq. zero)THEN
+ DO i = 1, m
+ x(i) = zero
+ ENDDO
+ ELSE
+ DO i = 1, m
+ x(i) = alpha* x(i)
+ ENDDO
+ ENDIF
+ IF ( n .lt. 5)RETURN
+ ENDIF
+ mp1 = m + 1
+ IF (alpha .eq. (- one))THEN
+ DO i = mp1, n, 5
+ x(i) = - x(i)
+ x(i + 1) = - x(i + 1)
+ x(i + 2) = - x(i + 2)
+ x(i + 3) = - x(i + 3)
+ x(i + 4) = - x(i + 4)
+ ENDDO
+ ELSEIF (alpha .eq. zero)THEN
+ DO i = mp1, n, 5
+ x(i) = zero
+ x(i + 1) = zero
+ x(i + 2) = zero
+ x(i + 3) = zero
+ x(i + 4) = zero
+ ENDDO
+ ELSE
+ DO i = mp1, n, 5
+ x(i) = alpha* x(i)
+ x(i + 1) = alpha* x(i + 1)
+ x(i + 2) = alpha* x(i + 2)
+ x(i + 3) = alpha* x(i + 3)
+ x(i + 4) = alpha* x(i + 4)
+ ENDDO
+ ENDIF
+
+ END SUBROUTINE wscal
+
+ SUBROUTINE waxpy(n, alpha, x, incx, y, incy)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+! constant times a vector plus a vector: y <- y + Alpha*x
+! only for incX=incY=1
+! after BLAS
+! replace this by the function from the optimized BLAS implementation:
+! CALL SAXPY(N,Alpha,X,1,Y,1) or CALL DAXPY(N,Alpha,X,1,Y,1)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ INTEGER :: i, incx, incy, m, mp1, n
+ REAL(kind=dp):: x(n), y(n), alpha
+ REAL(kind=dp), PARAMETER :: zero = 0.0_dp
+
+ IF (alpha .eq. zero)RETURN
+ IF (n .le. 0)RETURN
+
+ m = mod(n, 4)
+ IF ( m .ne. 0)THEN
+ DO i = 1, m
+ y(i) = y(i) + alpha* x(i)
+ ENDDO
+ IF ( n .lt. 4)RETURN
+ ENDIF
+ mp1 = m + 1
+ DO i = mp1, n, 4
+ y(i) = y(i) + alpha* x(i)
+ y(i + 1) = y(i + 1) + alpha* x(i + 1)
+ y(i + 2) = y(i + 2) + alpha* x(i + 2)
+ y(i + 3) = y(i + 3) + alpha* x(i + 3)
+ ENDDO
+
+ END SUBROUTINE waxpy
+
+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
+!
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+!~~~> arguments
+ INTEGER, INTENT(IN) :: n
+ REAL(kind=dp), INTENT(INOUT):: y(n)
+ REAL(kind=dp), INTENT(IN) :: tstart, tend
+ REAL(kind=dp), INTENT(IN) :: abstol(n), reltol(n)
+ INTEGER, INTENT(IN) :: icntrl(20)
+ REAL(kind=dp), INTENT(IN) :: rcntrl(20)
+ INTEGER, INTENT(INOUT):: istatus(20)
+ REAL(kind=dp), 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
+ REAL(kind=dp):: 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
+ REAL(kind=dp):: roundoff, facmin, facmax, facrej, facsafe
+ REAL(kind=dp):: hmin, hmax, hstart
+ REAL(kind=dp):: texit
+ INTEGER :: i, uplimtol, max_no_steps
+ LOGICAL :: autonomous, vectortol
+!~~~> PARAMETERs
+ REAL(kind=dp), PARAMETER :: zero = 0.0_dp, one = 1.0_dp
+ REAL(kind=dp), 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
+ ENDIF
+
+!~~~> 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
+ ENDIF
+
+!~~~> unit roundoff (1+ roundoff>1)
+ roundoff = epsilon(one)
+
+!~~~> 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
+ ENDIF
+!~~~> 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
+ ENDIF
+!~~~> 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
+ ENDIF
+!~~~> 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
+ ENDIF
+ 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
+ ENDIF
+!~~~> 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
+ ENDIF
+!~~~> 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
+ ENDIF
+!~~~> 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
+ ENDIF
+ ENDDO
+
+
+!~~~> 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ REAL(kind=dp), 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}
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+!~~~> input: the initial condition at tstart; output: the solution at t
+ REAL(kind=dp), INTENT(INOUT):: y(n)
+!~~~> input: integration interval
+ REAL(kind=dp), INTENT(IN):: tstart, tend
+!~~~> output: time at which the solution is RETURNed (t=tendIF success)
+ REAL(kind=dp), INTENT(OUT):: t
+!~~~> input: tolerances
+ REAL(kind=dp), INTENT(IN):: abstol(n), reltol(n)
+!~~~> input: integration PARAMETERs
+ LOGICAL, INTENT(IN):: autonomous, vectortol
+ REAL(kind=dp), INTENT(IN):: hstart, hmin, hmax
+ INTEGER, INTENT(IN):: max_no_steps
+ REAL(kind=dp), INTENT(IN):: roundoff, facmin, facmax, facrej, facsafe
+!~~~> output: error indicator
+ INTEGER, INTENT(OUT):: ierr
+! ~~~~ Local variables
+ REAL(kind=dp):: ynew(n), fcn0(n), fcn(n)
+ REAL(kind=dp):: k(n* ros_s), dfdt(n)
+#ifdef full_algebra
+ REAL(kind=dp):: jac0(n, n), ghimj(n, n)
+#else
+ REAL(kind=dp):: jac0(lu_nonzero), ghimj(lu_nonzero)
+#endif
+ REAL(kind=dp):: h, hnew, hc, hg, fac, tau
+ REAL(kind=dp):: err, yerr(n)
+ INTEGER :: pivot(n), direction, ioffset, j, istage
+ LOGICAL :: rejectlasth, rejectmoreh, singular
+!~~~> local PARAMETERs
+ REAL(kind=dp), PARAMETER :: zero = 0.0_dp, one = 1.0_dp
+ REAL(kind=dp), PARAMETER :: deltamin = 1.0e-5_dp
+!~~~> locally called FUNCTIONs
+! REAL(kind=dp) 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
+ ENDIF
+ 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
+ ENDIF
+ IF (((t+ 0.1_dp* h) == t).or.(h <= roundoff))THEN ! step size too small
+ CALL ros_errormsg(- 7, t, h, ierr)
+ RETURN
+ ENDIF
+
+!~~~> 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)
+ ENDIF
+
+!~~~> 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
+ ENDIF
+
+!~~~> 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
+ !slim: CALL wcopy(n, fcn0, 1, fcn, 1)
+ fcn(1:n) = fcn0(1:n)
+ ! istage>1 and a new FUNCTION evaluation is needed at the current istage
+ ELSEIF(ros_newf(istage))THEN
+ !slim: CALL wcopy(n, y, 1, ynew, 1)
+ ynew(1:n) = y(1:n)
+ DO j = 1, istage-1
+ CALL waxpy(n, ros_a((istage-1) * (istage-2) /2+ j), &
+ k(n* (j- 1) + 1), 1, ynew, 1)
+ ENDDO
+ tau = t + ros_alpha(istage) * direction* h
+ CALL funtemplate(tau, ynew, fcn)
+ istatus(nfun) = istatus(nfun) + 1
+ ENDIF ! IF istage == 1 ELSEIF ros_newf(istage)
+ !slim: CALL wcopy(n, fcn, 1, k(ioffset+ 1), 1)
+ k(ioffset+ 1:ioffset+ n) = fcn(1:n)
+ 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), 1, k(ioffset+ 1), 1)
+ ENDDO
+ 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), 1)
+ ENDIF
+ CALL ros_solve(ghimj, pivot, k(ioffset+ 1))
+
+ END DO stage
+
+
+!~~~> compute the new solution
+ !slim: CALL wcopy(n, y, 1, ynew, 1)
+ ynew(1:n) = y(1:n)
+ DO j=1, ros_s
+ CALL waxpy(n, ros_m(j), k(n* (j- 1) + 1), 1, ynew, 1)
+ ENDDO
+
+!~~~> compute the error estimation
+ !slim: CALL wscal(n, zero, yerr, 1)
+ yerr(1:n) = zero
+ DO j=1, ros_s
+ CALL waxpy(n, ros_e(j), k(n* (j- 1) + 1), 1, yerr, 1)
+ ENDDO
+ 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
+ !slim: CALL wcopy(n, ynew, 1, y, 1)
+ y(1:n) = ynew(1:n)
+ 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)
+ ENDIF
+ 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
+ ENDIF
+ rejectmoreh = rejectlasth
+ rejectlasth = .TRUE.
+ h = hnew
+ IF (istatus(nacc)>= 1) istatus(nrej) = istatus(nrej) + 1
+ ENDIF ! err <= 1
+
+ END DO untilaccepted
+
+ END DO timeloop
+
+!~~~> succesful exit
+ ierr = 1 !~~~> the integration was successful
+
+ END SUBROUTINE ros_integrator
+
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ REAL(kind=dp)FUNCTION ros_errornorm(y, ynew, yerr, &
+ abstol, reltol, vectortol)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> computes the "scaled norm" of the error vector yerr
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+! Input arguments
+ REAL(kind=dp), INTENT(IN):: y(n), ynew(n), &
+ yerr(n), abstol(n), reltol(n)
+ LOGICAL, INTENT(IN):: vectortol
+! Local variables
+ REAL(kind=dp):: err, scale, ymax
+ INTEGER :: i
+ REAL(kind=dp), 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
+ ENDIF
+ err = err+ (yerr(i) /scale) ** 2
+ ENDDO
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+!~~~> input arguments
+ REAL(kind=dp), INTENT(IN):: t, roundoff, y(n), fcn0(n)
+!~~~> output arguments
+ REAL(kind=dp), INTENT(OUT):: dfdt(n)
+!~~~> local variables
+ REAL(kind=dp):: delta
+ REAL(kind=dp), 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
+! --- --- --- --- --- --- --- --- --- --- --- --- ---
+
+!~~~> input arguments
+#ifdef full_algebra
+ REAL(kind=dp), INTENT(IN):: jac0(n, n)
+#else
+ REAL(kind=dp), INTENT(IN):: jac0(lu_nonzero)
+#endif
+ REAL(kind=dp), INTENT(IN):: gam
+ INTEGER, INTENT(IN):: direction
+!~~~> output arguments
+#ifdef full_algebra
+ REAL(kind=dp), INTENT(OUT):: ghimj(n, n)
+#else
+ REAL(kind=dp), INTENT(OUT):: ghimj(lu_nonzero)
+#endif
+ LOGICAL, INTENT(OUT):: singular
+ INTEGER, INTENT(OUT):: pivot(n)
+!~~~> inout arguments
+ REAL(kind=dp), INTENT(INOUT):: h ! step size is decreased when lu fails
+!~~~> local variables
+ INTEGER :: i, ising, nconsecutive
+ REAL(kind=dp):: ghinv
+ REAL(kind=dp), 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
+ !slim: CALL wcopy(n* n, jac0, 1, ghimj, 1)
+ !slim: CALL wscal(n* n, (- one), ghimj, 1)
+ ghimj = - jac0
+ ghinv = one/(direction* h* gam)
+ DO i=1, n
+ ghimj(i, i) = ghimj(i, i) + ghinv
+ ENDDO
+#else
+ !slim: CALL wcopy(lu_nonzero, jac0, 1, ghimj, 1)
+ !slim: CALL wscal(lu_nonzero, (- one), ghimj, 1)
+ ghimj(1:lu_nonzero) = - jac0(1:lu_nonzero)
+ ghinv = one/(direction* h* gam)
+ DO i=1, n
+ ghimj(lu_diag(i)) = ghimj(lu_diag(i)) + ghinv
+ ENDDO
+#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
+ ENDIF ! nconsecutive
+ ENDIF ! ising
+
+ END DO ! WHILE singular
+
+ END SUBROUTINE ros_preparematrix
+
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE ros_decomp( a, pivot, ising)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! Template for the LU decomposition
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> inout variables
+#ifdef full_algebra
+ REAL(kind=dp), INTENT(INOUT):: a(n, n)
+#else
+ REAL(kind=dp), INTENT(INOUT):: a(lu_nonzero)
+#endif
+!~~~> 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)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> input variables
+#ifdef full_algebra
+ REAL(kind=dp), INTENT(IN):: a(n, n)
+ INTEGER :: ising
+#else
+ REAL(kind=dp), INTENT(IN):: a(lu_nonzero)
+#endif
+ INTEGER, INTENT(IN):: pivot(n)
+!~~~> inout variables
+ REAL(kind=dp), INTENT(INOUT):: b(n)
+
+#ifdef full_algebra
+ CALL DGETRS( 'N',N ,1,A,N,Pivot,b,N,ISING)
+ IF (info < 0)THEN
+ print* , "error in dgetrs. ising=", ising
+ ENDIF
+#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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ 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)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+ 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)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> input variables
+ REAL(kind=dp):: t, y(nvar)
+!~~~> output variables
+ REAL(kind=dp):: ydot(nvar)
+!~~~> local variables
+ REAL(kind=dp):: told
+
+ told = time
+ time = t
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> input variables
+ REAL(kind=dp):: t, y(nvar)
+!~~~> output variables
+#ifdef full_algebra
+ REAL(kind=dp):: jv(lu_nonzero), jcb(nvar, nvar)
+#else
+ REAL(kind=dp):: jcb(lu_nonzero)
+#endif
+!~~~> local variables
+ REAL(kind=dp):: told
+#ifdef full_algebra
+ INTEGER :: i, j
+#endif
+
+ told = time
+ time = t
+#ifdef full_algebra
+ CALL jac_sp(y, fix, rconst, jv)
+ DO j=1, nvar
+ DO i=1, nvar
+ jcb(i, j) = 0.0_dp
+ ENDDO
+ ENDDO
+ DO i=1, lu_nonzero
+ jcb(lu_irow(i), lu_icol(i)) = jv(i)
+ ENDDO
+#else
+ CALL jac_sp( y, fix, rconst, jcb)
+#endif
+ time = told
+
+END SUBROUTINE jactemplate
+
+ SUBROUTINE kppdecomp( jvs, ier)
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! sparse lu factorization
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! loop expansion generated by kp4
+
+ INTEGER :: ier
+ REAL(kind=dp):: jvs(lu_nonzero), w(nvar), a
+ INTEGER :: k, kk, j, jj
+
+ a = 0.
+ ier = 0
+
+! i = 1
+! i = 2
+! i = 3
+! i = 4
+! i = 5
+ RETURN
+
+ END SUBROUTINE kppdecomp
+
+SUBROUTINE chem_gasphase_integrate (time_step_len, conc, tempi, qvapi, fakti, photo, ierrf, xnacc, xnrej, istatus, l_debug, pe, &
+ icntrl_i, rcntrl_i)
+
+ IMPLICIT NONE
+
+ REAL(dp), INTENT(IN) :: time_step_len
+ REAL(dp), DIMENSION(:, :), INTENT(INOUT) :: conc
+ REAL(dp), DIMENSION(:, :), INTENT(IN) :: photo
+ REAL(dp), DIMENSION(:), INTENT(IN) :: tempi
+ REAL(dp), DIMENSION(:), INTENT(IN) :: qvapi
+ REAL(dp), DIMENSION(:), INTENT(IN) :: fakti
+ INTEGER, INTENT(OUT), OPTIONAL :: ierrf(:)
+ INTEGER, INTENT(OUT), OPTIONAL :: xnacc(:)
+ INTEGER, INTENT(OUT), OPTIONAL :: xnrej(:)
+ INTEGER, INTENT(INOUT), OPTIONAL :: istatus(:)
+ INTEGER, INTENT(IN), OPTIONAL :: pe
+ LOGICAL, INTENT(IN), OPTIONAL :: l_debug
+ INTEGER, DIMENSION(nkppctrl), INTENT(IN), OPTIONAL :: icntrl_i
+ REAL(dp), DIMENSION(nkppctrl), INTENT(IN), OPTIONAL :: rcntrl_i
+
+ INTEGER :: k ! loop variable
+ REAL(dp) :: dt
+ INTEGER, DIMENSION(20) :: istatus_u
+ INTEGER :: ierr_u
+ INTEGER :: istatf
+ INTEGER :: vl_dim_lo
+
+
+ IF (PRESENT (istatus)) istatus = 0
+ IF (PRESENT (icntrl_i)) icntrl = icntrl_i
+ IF (PRESENT (rcntrl_i)) rcntrl = rcntrl_i
+
+ vl_glo = size(tempi, 1)
+
+ vl_dim_lo = vl_dim
+ DO k=1, vl_glo, vl_dim_lo
+ is = k
+ ie = min(k+ vl_dim_lo-1, vl_glo)
+ vl = ie-is+ 1
+
+ c(:) = conc(is, :)
+
+ temp = tempi(is)
+
+ qvap = qvapi(is)
+
+ fakt = fakti(is)
+
+ CALL initialize
+
+ phot(:) = photo(is, :)
+
+ CALL update_rconst
+
+ dt = time_step_len
+
+ ! integrate from t=0 to t=dt
+ CALL integrate(0._dp, dt, icntrl, rcntrl, istatus_u = istatus_u, ierr_u=ierr_u)
+
+
+ IF (PRESENT(l_debug) .AND. PRESENT(pe)) THEN
+ IF (l_debug) CALL error_output(conc(is, :), ierr_u, pe)
+ ENDIF
+
+ conc(is, :) = c(:)
+
+ ! RETURN diagnostic information
+
+ IF (PRESENT(ierrf)) ierrf(is) = ierr_u
+ IF (PRESENT(xnacc)) xnacc(is) = istatus_u(4)
+ IF (PRESENT(xnrej)) xnrej(is) = istatus_u(5)
+
+ IF (PRESENT (istatus)) THEN
+ istatus(1:8) = istatus(1:8) + istatus_u(1:8)
+ ENDIF
+
+ END DO
+
+
+! Deallocate input arrays
+
+
+ data_loaded = .FALSE.
+
+ RETURN
+END SUBROUTINE chem_gasphase_integrate
+
+END MODULE chem_gasphase_mod
+
Index: /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsagas/chem_gasphase_mod.kpp
===================================================================
--- /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsagas/chem_gasphase_mod.kpp (revision 3698)
+++ /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsagas/chem_gasphase_mod.kpp (revision 3698)
@@ -0,0 +1,37 @@
+//chem_gasphase_mod.kpp
+//
+//Former revisions
+//----------------
+// $Id: chem_gasphase_mod.kpp 2459 2017-09-13 14:10:33Z forkel $
+// initial revision from branch salsa rev 3576 (29.11.2018, monakurppa)
+//
+#include salsagas.spc
+#include salsagas.eqn
+#INTEGRATOR rosenbrock
+#LANGUAGE Fortran90
+#HESSIAN on
+#STOICMAT on
+#INLINE F90_GLOBAL
+ ! Declaration of global variable declarations for photolysis will come from INLINE F90_DATA
+#ENDINLINE
+//
+// *******************************************************************************************
+// *** adapt the lines below occurding to the photolysis reactions of your mechanism *
+// *** adapt the number of photolysis frequencies NPHO *
+// *** adapt/extend the indices in the INTEGER, PARAMETER,PUBLIC statement below *
+// *** adapt/extend PHOT_NAMES: Note that the order of PHOT_NAMES and the indices must match *
+// *******************************************************************************************
+//
+#INLINE F90_DATA
+ ! INLINE F90_DATA: Declaration of global variables for photolysis
+ ! REAL(kind=dp) :: phot(nphot) must eventually be moved to GLOBAL later for vector version
+ INTEGER, PARAMETER :: nphot = 1
+ ! phot Photolysis frequencies
+ REAL(kind=dp) :: phot(nphot)
+
+ INTEGER, PARAMETER,PUBLIC :: j_no2 = 1
+
+ CHARACTER(LEN=15), PARAMETER, DIMENSION(NPHOT) :: phot_names = (/ &
+ 'J_NO2 '/)
+#ENDINLINE
+
Index: /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsagas/salsagas.eqn
===================================================================
--- /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsagas/salsagas.eqn (revision 3698)
+++ /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsagas/salsagas.eqn (revision 3698)
@@ -0,0 +1,13 @@
+{salsagas.eqn
+Former revisions
+----------------
+ $Id$
+}
+#EQUATIONS
+
+{ passive: does nothing }
+ { 1.} H2SO4 = H2SO4 : 1.0_dp ;
+ { 2.} HNO3 = HNO3 : 1.0_dp ;
+ { 3.} NH3 = NH3 : 1.0_dp ;
+ { 4.} OCNV = OCNV : 1.0_dp ;
+ { 5.} OCSV = OCSV : 1.0_dp ;
Index: /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsagas/salsagas.spc
===================================================================
--- /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsagas/salsagas.spc (revision 3698)
+++ /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsagas/salsagas.spc (revision 3698)
@@ -0,0 +1,22 @@
+{salsagas.spc
+Former revisions
+----------------
+ $Id$
+}
+#include atoms
+
+ #DEFVAR
+ HNO3 = H + N + 3O ; { nitric acid }
+ H2SO4 = 2H + S +4O ; {sulfuric acid}
+ NH3 = 3H + N ; {ammonia}
+ OCNV = ignore ; {non-volatile OC}
+ OCSV = ignore ; {semi-volatile OC}
+
+#DEFFIX
+ H2O = H + 2O ; {water}
+ H2 = 2H ; {molecular hydrogen}
+ O2 = 2O ; {molecular oxygen}
+ N2 = 2N ; {molecular nitrogen}
+ CH4 = C + 4H ; {methane}
+ CO2 = C + 2O ; {carbon dioxide}
+
Index: /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_simplep/chem_gasphase_mod.f90
===================================================================
--- /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_simplep/chem_gasphase_mod.f90 (revision 3698)
+++ /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_simplep/chem_gasphase_mod.f90 (revision 3698)
@@ -0,0 +1,2501 @@
+MODULE chem_gasphase_mod
+
+! Mechanism: simplep
+!
+!------------------------------------------------------------------------------!
+!
+! ******Module chem_gasphase_mod is automatically generated by kpp4palm ******
+!
+! *********Please do NOT change this Code,it will be ovewritten *********
+!
+!------------------------------------------------------------------------------!
+! This file was created by KPP (http://people.cs.vt.edu/asandu/Software/Kpp/)
+! and kpp4palm (created by Klaus Ketelsen). kpp4palm is an adapted version
+! of KP4 (Jöckel,P.,Kerkweg,A.,Pozzer,A.,Sander,R.,Tost,H.,Riede,
+! H.,Baumgaertner,A.,Gromov,S.,and Kern,B.,2010: Development cycle 2 of
+! the Modular Earth Submodel System (MESSy2),Geosci. Model Dev.,3,717-752,
+! https://doi.org/10.5194/gmd-3-717-2010). KP4 is part of the Modular Earth
+! Submodel System (MESSy),which is is available under the GNU General Public
+! License (GPL).
+!
+! KPP is free software; you can redistribute it and/or modify it under the terms
+! of the General Public Licence as published by the Free Software Foundation;
+! 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 Licence for more details.
+!
+!------------------------------------------------------------------------------!
+! This file is part of the PALM model system.
+!
+! PALM is free software: you can redistribute it and/or modify it under the
+! terms of the GNU General Public License as published by the Free Software
+! Foundation,either version 3 of the License,or (at your option) any later
+! version.
+!
+! PALM 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
+! PALM. If not,see .
+!
+! Copyright 1997-2019 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+!
+! MODULE HEADER TEMPLATE
+!
+! Initial version (Nov. 2016,ketelsen),for later modifications of module_header
+! see comments in kpp4palm/src/create_kpp_module.C
+
+! Set kpp Double Precision to PALM Default Precision
+
+ USE kinds, ONLY: dp=>wp
+
+ USE pegrid, ONLY: myid, threads_per_task
+
+ IMPLICIT NONE
+ PRIVATE
+ !SAVE ! note: occurs again in automatically generated code ...
+
+! PUBLIC :: IERR_NAMES
+
+! PUBLIC :: SPC_NAMES,EQN_NAMES,EQN_TAGS,REQ_HET,REQ_AEROSOL,REQ_PHOTRAT &
+! ,REQ_MCFCT,IP_MAX,jname
+
+ PUBLIC :: eqn_names, phot_names, spc_names
+ PUBLIC :: nmaxfixsteps
+ PUBLIC :: atol, rtol
+ PUBLIC :: nspec, nreact
+ PUBLIC :: temp
+ PUBLIC :: qvap
+ PUBLIC :: fakt
+ PUBLIC :: phot
+ PUBLIC :: rconst
+ PUBLIC :: nvar
+ PUBLIC :: nphot
+ PUBLIC :: vl_dim ! PUBLIC to ebable other MODULEs to distiguish between scalar and vec
+
+ PUBLIC :: initialize, integrate, update_rconst
+ PUBLIC :: chem_gasphase_integrate
+ PUBLIC :: initialize_kpp_ctrl
+
+! END OF MODULE HEADER TEMPLATE
+
+! Variables used for vector mode
+
+ LOGICAL, PARAMETER :: l_vector = .FALSE.
+ INTEGER, PARAMETER :: i_lu_di = 2
+ INTEGER, PARAMETER :: vl_dim = 1
+ INTEGER :: vl
+
+ INTEGER :: vl_glo
+ INTEGER :: is, ie
+
+
+ INTEGER, DIMENSION(vl_dim) :: kacc, krej
+ INTEGER, DIMENSION(vl_dim) :: ierrv
+ LOGICAL :: data_loaded = .FALSE.
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Parameter Module File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Parameters.f90
+! Time : Thu Dec 20 14:57:53 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181220/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! NSPEC - Number of chemical species
+ INTEGER, PARAMETER :: nspec = 11
+! NVAR - Number of Variable species
+ INTEGER, PARAMETER :: nvar = 10
+! NVARACT - Number of Active species
+ INTEGER, PARAMETER :: nvaract = 8
+! NFIX - Number of Fixed species
+ INTEGER, PARAMETER :: nfix = 1
+! NREACT - Number of reactions
+ INTEGER, PARAMETER :: nreact = 8
+! NVARST - Starting of variables in conc. vect.
+ INTEGER, PARAMETER :: nvarst = 1
+! NFIXST - Starting of fixed in conc. vect.
+ INTEGER, PARAMETER :: nfixst = 11
+! NONZERO - Number of nonzero entries in Jacobian
+ INTEGER, PARAMETER :: nonzero = 36
+! LU_NONZERO - Number of nonzero entries in LU factoriz. of Jacobian
+ INTEGER, PARAMETER :: lu_nonzero = 38
+! CNVAR - (NVAR+1) Number of elements in compressed row format
+ INTEGER, PARAMETER :: cnvar = 11
+! CNEQN - (NREACT+1) Number stoicm elements in compressed col format
+ INTEGER, PARAMETER :: cneqn = 9
+! NHESS - Length of Sparse Hessian
+ INTEGER, PARAMETER :: nhess = 18
+! NMASS - Number of atoms to check mass balance
+ INTEGER, PARAMETER :: nmass = 1
+
+! Index declaration for variable species in C and VAR
+! VAR(ind_spc) = C(ind_spc)
+
+ INTEGER, PARAMETER, PUBLIC :: ind_pm10 = 1
+ INTEGER, PARAMETER, PUBLIC :: ind_hno3 = 2
+ INTEGER, PARAMETER, PUBLIC :: ind_rcho = 3
+ INTEGER, PARAMETER, PUBLIC :: ind_rh = 4
+ INTEGER, PARAMETER, PUBLIC :: ind_ho2 = 5
+ INTEGER, PARAMETER, PUBLIC :: ind_o3 = 6
+ INTEGER, PARAMETER, PUBLIC :: ind_oh = 7
+ INTEGER, PARAMETER, PUBLIC :: ind_ro2 = 8
+ INTEGER, PARAMETER, PUBLIC :: ind_no = 9
+ INTEGER, PARAMETER, PUBLIC :: ind_no2 = 10
+
+! Index declaration for fixed species in C
+! C(ind_spc)
+
+ INTEGER, PARAMETER, PUBLIC :: ind_h2o = 11
+
+! Index declaration for fixed species in FIX
+! FIX(indf_spc) = C(ind_spc) = C(NVAR+indf_spc)
+
+ INTEGER, PARAMETER :: indf_h2o = 1
+
+! NJVRP - Length of sparse Jacobian JVRP
+ INTEGER, PARAMETER :: njvrp = 13
+
+! NSTOICM - Length of Sparse Stoichiometric Matrix
+ INTEGER, PARAMETER :: nstoicm = 23
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Global Data Module File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Global.f90
+! Time : Thu Dec 20 14:57:53 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181220/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! Declaration of global variables
+
+! C - Concentration of all species
+ REAL(kind=dp):: c(nspec)
+! VAR - Concentrations of variable species (global)
+ REAL(kind=dp):: var(nvar)
+! FIX - Concentrations of fixed species (global)
+ REAL(kind=dp):: fix(nfix)
+! VAR,FIX are chunks of array C
+ EQUIVALENCE( c(1), var(1))
+ EQUIVALENCE( c(11), fix(1))
+! RCONST - Rate constants (global)
+ REAL(kind=dp):: rconst(nreact)
+! TIME - Current integration time
+ REAL(kind=dp):: time
+! TEMP - Temperature
+ REAL(kind=dp):: temp
+! TSTART - Integration start time
+ REAL(kind=dp):: tstart
+! ATOL - Absolute tolerance
+ REAL(kind=dp):: atol(nvar)
+! RTOL - Relative tolerance
+ REAL(kind=dp):: rtol(nvar)
+! STEPMIN - Lower bound for integration step
+ REAL(kind=dp):: stepmin
+! CFACTOR - Conversion factor for concentration units
+ REAL(kind=dp):: cfactor
+
+! INLINED global variable declarations
+
+! QVAP - Water vapor
+ REAL(kind=dp):: qvap
+! FAKT - Conversion factor
+ REAL(kind=dp):: fakt
+
+
+! INLINED global variable declarations
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Sparse Jacobian Data Structures File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_JacobianSP.f90
+! Time : Thu Dec 20 14:57:53 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181220/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! Sparse Jacobian Data
+
+
+ INTEGER, PARAMETER, DIMENSION(38):: lu_irow = (/ &
+ 1, 2, 2, 2, 3, 3, 3, 4, 4, 5, 5, 5, &
+ 6, 6, 6, 7, 7, 7, 7, 7, 7, 7, 8, 8, &
+ 8, 8, 8, 9, 9, 9, 9, 9, 10, 10, 10, 10, &
+ 10, 10 /)
+
+ INTEGER, PARAMETER, DIMENSION(38):: lu_icol = (/ &
+ 1, 2, 7, 10, 3, 8, 9, 4, 7, 5, 8, 9, &
+ 6, 9, 10, 4, 5, 6, 7, 8, 9, 10, 4, 7, &
+ 8, 9, 10, 5, 6, 8, 9, 10, 5, 6, 7, 8, &
+ 9, 10 /)
+
+ INTEGER, PARAMETER, DIMENSION(11):: lu_crow = (/ &
+ 1, 2, 5, 8, 10, 13, 16, 23, 28, 33, 39 /)
+
+ INTEGER, PARAMETER, DIMENSION(11):: lu_diag = (/ &
+ 1, 2, 5, 8, 10, 13, 19, 25, 31, 38, 39 /)
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Utility Data Module File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Monitor.f90
+! Time : Thu Dec 20 14:57:53 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181220/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+ CHARACTER(len=15), PARAMETER, DIMENSION(11):: spc_names = (/ &
+ 'PM10 ','HNO3 ','RCHO ',&
+ 'RH ','HO2 ','O3 ',&
+ 'OH ','RO2 ','NO ',&
+ 'NO2 ','H2O ' /)
+
+ CHARACTER(len=100), PARAMETER, DIMENSION(8):: eqn_names = (/ &
+ ' NO2 --> O3 + NO ',&
+ 'O3 + H2O --> 2 OH ',&
+ ' O3 + NO --> NO2 ',&
+ ' RH + OH --> RO2 + H2O ',&
+ 'RO2 + NO --> RCHO + HO2 + NO2 ',&
+ 'HO2 + NO --> OH + NO2 ',&
+ 'OH + NO2 --> HNO3 ',&
+ ' PM10 --> PM10 ' /)
+
+! INLINED global variables
+
+ ! inline f90_data: declaration of global variables for photolysis
+ ! REAL(kind=dp):: phot(nphot)must eventually be moved to global later for
+ INTEGER, PARAMETER :: nphot = 2
+ ! phot photolysis frequencies
+ REAL(kind=dp):: phot(nphot)
+
+ INTEGER, PARAMETER, PUBLIC :: j_no2 = 1
+ INTEGER, PARAMETER, PUBLIC :: j_o31d = 2
+
+ CHARACTER(len=15), PARAMETER, DIMENSION(nphot):: phot_names = (/ &
+ 'J_NO2 ','J_O31D '/)
+
+! End INLINED global variables
+
+
+! Automatic generated PUBLIC Statements for ip_ and ihs_ variables
+
+! Automatic generated PUBLIC Statements for ip_ and ihs_ variables
+
+! Automatic generated PUBLIC Statements for ip_ and ihs_ variables
+
+! Automatic generated PUBLIC Statements for ip_ and ihs_ variables
+
+
+! variable definations from individual module headers
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Initialization File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Initialize.f90
+! Time : Thu Dec 20 14:57:53 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181220/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Numerical Integrator (Time-Stepping) File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Integrator.f90
+! Time : Thu Dec 20 14:57:53 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181220/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! INTEGRATE - Integrator routine
+! Arguments :
+! TIN - Start Time for Integration
+! TOUT - End Time for Integration
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!
+! 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 !
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!
+
+
+ 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
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Linear Algebra Data and Routines File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_LinearAlgebra.f90
+! Time : Thu Dec 20 14:57:53 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181220/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! The ODE Jacobian of Chemical Model File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Jacobian.f90
+! Time : Thu Dec 20 14:57:53 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181220/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! The ODE Function of Chemical Model File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Function.f90
+! Time : Thu Dec 20 14:57:53 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181220/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+! A - Rate for each equation
+ REAL(kind=dp):: a(nreact)
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! The Reaction Rates File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Rates.f90
+! Time : Thu Dec 20 14:57:53 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181220/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Auxiliary Routines File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (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 important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Util.f90
+! Time : Thu Dec 20 14:57:53 2018
+! Working directory : /home/forkel-r/palmstuff/work/trunk20181220/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+ ! header MODULE initialize_kpp_ctrl_template
+
+ ! notes:
+ ! - l_vector is automatically defined by kp4
+ ! - vl_dim is automatically defined by kp4
+ ! - i_lu_di is automatically defined by kp4
+ ! - wanted is automatically defined by xmecca
+ ! - icntrl rcntrl are automatically defined by kpp
+ ! - "USE messy_main_tools" is in MODULE_header of messy_mecca_kpp.f90
+ ! - SAVE will be automatically added by kp4
+
+ !SAVE
+
+ ! for fixed time step control
+ ! ... max. number of fixed time steps (sum must be 1)
+ INTEGER, PARAMETER :: nmaxfixsteps = 50
+ ! ... switch for fixed time stepping
+ LOGICAL, PUBLIC :: l_fixed_step = .FALSE.
+ INTEGER, PUBLIC :: nfsteps = 1
+ ! ... number of kpp control PARAMETERs
+ INTEGER, PARAMETER, PUBLIC :: nkppctrl = 20
+ !
+ INTEGER, DIMENSION(nkppctrl), PUBLIC :: icntrl = 0
+ REAL(dp), DIMENSION(nkppctrl), PUBLIC :: rcntrl = 0.0_dp
+ REAL(dp), DIMENSION(nmaxfixsteps), PUBLIC :: t_steps = 0.0_dp
+
+ ! END header MODULE initialize_kpp_ctrl_template
+
+
+! Interface Block
+
+ INTERFACE initialize
+ MODULE PROCEDURE initialize
+ END INTERFACE initialize
+
+ INTERFACE integrate
+ MODULE PROCEDURE integrate
+ END INTERFACE integrate
+
+ INTERFACE fun
+ MODULE PROCEDURE fun
+ END INTERFACE fun
+
+ INTERFACE kppsolve
+ MODULE PROCEDURE kppsolve
+ END INTERFACE kppsolve
+
+ INTERFACE jac_sp
+ MODULE PROCEDURE jac_sp
+ END INTERFACE jac_sp
+
+ INTERFACE k_arr
+ MODULE PROCEDURE k_arr
+ END INTERFACE k_arr
+
+ INTERFACE update_rconst
+ MODULE PROCEDURE update_rconst
+ END INTERFACE update_rconst
+
+ INTERFACE arr2
+ MODULE PROCEDURE arr2
+ END INTERFACE arr2
+
+ INTERFACE initialize_kpp_ctrl
+ MODULE PROCEDURE initialize_kpp_ctrl
+ END INTERFACE initialize_kpp_ctrl
+
+ INTERFACE error_output
+ MODULE PROCEDURE error_output
+ END INTERFACE error_output
+
+ INTERFACE wscal
+ MODULE PROCEDURE wscal
+ END INTERFACE wscal
+
+!INTERFACE not working INTERFACE waxpy
+!INTERFACE not working MODULE PROCEDURE waxpy
+!INTERFACE not working END INTERFACE waxpy
+
+ INTERFACE rosenbrock
+ MODULE PROCEDURE rosenbrock
+ END INTERFACE rosenbrock
+
+ INTERFACE funtemplate
+ MODULE PROCEDURE funtemplate
+ END INTERFACE funtemplate
+
+ INTERFACE jactemplate
+ MODULE PROCEDURE jactemplate
+ END INTERFACE jactemplate
+
+ INTERFACE kppdecomp
+ MODULE PROCEDURE kppdecomp
+ END INTERFACE kppdecomp
+
+ INTERFACE chem_gasphase_integrate
+ MODULE PROCEDURE chem_gasphase_integrate
+ END INTERFACE chem_gasphase_integrate
+
+
+ CONTAINS
+
+SUBROUTINE initialize()
+
+
+ INTEGER :: j, k
+
+ INTEGER :: i
+ REAL(kind=dp):: x
+ k = is
+ cfactor = 1.000000e+00_dp
+
+ x = (0.) * cfactor
+ DO i = 1 , nvar
+ ENDDO
+
+ x = (0.) * cfactor
+ DO i = 1 , nfix
+ fix(i) = x
+ ENDDO
+
+! constant rate coefficients
+! END constant rate coefficients
+
+! INLINED initializations
+
+! End INLINED initializations
+
+
+END SUBROUTINE initialize
+
+SUBROUTINE integrate( tin, tout, &
+ icntrl_u, rcntrl_u, istatus_u, rstatus_u, ierr_u)
+
+
+ REAL(kind=dp), INTENT(IN):: tin ! start time
+ REAL(kind=dp), INTENT(IN):: tout ! END time
+ ! OPTIONAL input PARAMETERs and statistics
+ INTEGER, INTENT(IN), OPTIONAL :: icntrl_u(20)
+ REAL(kind=dp), INTENT(IN), OPTIONAL :: rcntrl_u(20)
+ INTEGER, INTENT(OUT), OPTIONAL :: istatus_u(20)
+ REAL(kind=dp), INTENT(OUT), OPTIONAL :: rstatus_u(20)
+ INTEGER, INTENT(OUT), OPTIONAL :: ierr_u
+
+ REAL(kind=dp):: 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(:)
+ ENDIF
+ IF (PRESENT(rcntrl_u))THEN
+ WHERE(rcntrl_u(:)> 0)rcntrl(:) = rcntrl_u(:)
+ ENDIF
+
+
+ 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 fun(v, f, rct, vdot)
+
+! V - Concentrations of variable species (local)
+ REAL(kind=dp):: v(nvar)
+! F - Concentrations of fixed species (local)
+ REAL(kind=dp):: f(nfix)
+! RCT - Rate constants (local)
+ REAL(kind=dp):: rct(nreact)
+! Vdot - Time derivative of variable species concentrations
+ REAL(kind=dp):: vdot(nvar)
+
+
+! Computation of equation rates
+ a(1) = rct(1) * v(10)
+ a(2) = rct(2) * v(6) * f(1)
+ a(3) = rct(3) * v(6) * v(9)
+ a(4) = rct(4) * v(4) * v(7)
+ a(5) = rct(5) * v(8) * v(9)
+ a(6) = rct(6) * v(5) * v(9)
+ a(7) = rct(7) * v(7) * v(10)
+
+! Aggregate function
+ vdot(1) = 0
+ vdot(2) = a(7)
+ vdot(3) = a(5)
+ vdot(4) = - a(4)
+ vdot(5) = a(5) - a(6)
+ vdot(6) = a(1) - a(2) - a(3)
+ vdot(7) = 2* a(2) - a(4) + a(6) - a(7)
+ vdot(8) = a(4) - a(5)
+ vdot(9) = a(1) - a(3) - a(5) - a(6)
+ vdot(10) = - a(1) + a(3) + a(5) + a(6) - a(7)
+
+END SUBROUTINE fun
+
+SUBROUTINE kppsolve(jvs, x)
+
+! JVS - sparse Jacobian of variables
+ REAL(kind=dp):: jvs(lu_nonzero)
+! X - Vector for variables
+ REAL(kind=dp):: x(nvar)
+
+ x(7) = x(7) - jvs(16) * x(4) - jvs(17) * x(5) - jvs(18) * x(6)
+ x(8) = x(8) - jvs(23) * x(4) - jvs(24) * x(7)
+ x(9) = x(9) - jvs(28) * x(5) - jvs(29) * x(6) - jvs(30) * x(8)
+ x(10) = x(10) - jvs(33) * x(5) - jvs(34) * x(6) - jvs(35) * x(7) - jvs(36) * x(8) - jvs(37) * x(9)
+ x(10) = x(10) / jvs(38)
+ x(9) = (x(9) - jvs(32) * x(10)) /(jvs(31))
+ x(8) = (x(8) - jvs(26) * x(9) - jvs(27) * x(10)) /(jvs(25))
+ x(7) = (x(7) - jvs(20) * x(8) - jvs(21) * x(9) - jvs(22) * x(10)) /(jvs(19))
+ x(6) = (x(6) - jvs(14) * x(9) - jvs(15) * x(10)) /(jvs(13))
+ x(5) = (x(5) - jvs(11) * x(8) - jvs(12) * x(9)) /(jvs(10))
+ x(4) = (x(4) - jvs(9) * x(7)) /(jvs(8))
+ x(3) = (x(3) - jvs(6) * x(8) - jvs(7) * x(9)) /(jvs(5))
+ x(2) = (x(2) - jvs(3) * x(7) - jvs(4) * x(10)) /(jvs(2))
+ x(1) = x(1) / jvs(1)
+
+END SUBROUTINE kppsolve
+
+SUBROUTINE jac_sp(v, f, rct, jvs)
+
+! V - Concentrations of variable species (local)
+ REAL(kind=dp):: v(nvar)
+! F - Concentrations of fixed species (local)
+ REAL(kind=dp):: f(nfix)
+! RCT - Rate constants (local)
+ REAL(kind=dp):: rct(nreact)
+! JVS - sparse Jacobian of variables
+ REAL(kind=dp):: jvs(lu_nonzero)
+
+
+! Local variables
+! B - Temporary array
+ REAL(kind=dp):: b(14)
+
+! B(1) = dA(1)/dV(10)
+ b(1) = rct(1)
+! B(2) = dA(2)/dV(6)
+ b(2) = rct(2) * f(1)
+! B(4) = dA(3)/dV(6)
+ b(4) = rct(3) * v(9)
+! B(5) = dA(3)/dV(9)
+ b(5) = rct(3) * v(6)
+! B(6) = dA(4)/dV(4)
+ b(6) = rct(4) * v(7)
+! B(7) = dA(4)/dV(7)
+ b(7) = rct(4) * v(4)
+! B(8) = dA(5)/dV(8)
+ b(8) = rct(5) * v(9)
+! B(9) = dA(5)/dV(9)
+ b(9) = rct(5) * v(8)
+! B(10) = dA(6)/dV(5)
+ b(10) = rct(6) * v(9)
+! B(11) = dA(6)/dV(9)
+ b(11) = rct(6) * v(5)
+! B(12) = dA(7)/dV(7)
+ b(12) = rct(7) * v(10)
+! B(13) = dA(7)/dV(10)
+ b(13) = rct(7) * v(7)
+! B(14) = dA(8)/dV(1)
+ b(14) = rct(8)
+
+! Construct the Jacobian terms from B's
+! JVS(1) = Jac_FULL(1,1)
+ jvs(1) = 0
+! JVS(2) = Jac_FULL(2,2)
+ jvs(2) = 0
+! JVS(3) = Jac_FULL(2,7)
+ jvs(3) = b(12)
+! JVS(4) = Jac_FULL(2,10)
+ jvs(4) = b(13)
+! JVS(5) = Jac_FULL(3,3)
+ jvs(5) = 0
+! JVS(6) = Jac_FULL(3,8)
+ jvs(6) = b(8)
+! JVS(7) = Jac_FULL(3,9)
+ jvs(7) = b(9)
+! JVS(8) = Jac_FULL(4,4)
+ jvs(8) = - b(6)
+! JVS(9) = Jac_FULL(4,7)
+ jvs(9) = - b(7)
+! JVS(10) = Jac_FULL(5,5)
+ jvs(10) = - b(10)
+! JVS(11) = Jac_FULL(5,8)
+ jvs(11) = b(8)
+! JVS(12) = Jac_FULL(5,9)
+ jvs(12) = b(9) - b(11)
+! JVS(13) = Jac_FULL(6,6)
+ jvs(13) = - b(2) - b(4)
+! JVS(14) = Jac_FULL(6,9)
+ jvs(14) = - b(5)
+! JVS(15) = Jac_FULL(6,10)
+ jvs(15) = b(1)
+! JVS(16) = Jac_FULL(7,4)
+ jvs(16) = - b(6)
+! JVS(17) = Jac_FULL(7,5)
+ jvs(17) = b(10)
+! JVS(18) = Jac_FULL(7,6)
+ jvs(18) = 2* b(2)
+! JVS(19) = Jac_FULL(7,7)
+ jvs(19) = - b(7) - b(12)
+! JVS(20) = Jac_FULL(7,8)
+ jvs(20) = 0
+! JVS(21) = Jac_FULL(7,9)
+ jvs(21) = b(11)
+! JVS(22) = Jac_FULL(7,10)
+ jvs(22) = - b(13)
+! JVS(23) = Jac_FULL(8,4)
+ jvs(23) = b(6)
+! JVS(24) = Jac_FULL(8,7)
+ jvs(24) = b(7)
+! JVS(25) = Jac_FULL(8,8)
+ jvs(25) = - b(8)
+! JVS(26) = Jac_FULL(8,9)
+ jvs(26) = - b(9)
+! JVS(27) = Jac_FULL(8,10)
+ jvs(27) = 0
+! JVS(28) = Jac_FULL(9,5)
+ jvs(28) = - b(10)
+! JVS(29) = Jac_FULL(9,6)
+ jvs(29) = - b(4)
+! JVS(30) = Jac_FULL(9,8)
+ jvs(30) = - b(8)
+! JVS(31) = Jac_FULL(9,9)
+ jvs(31) = - b(5) - b(9) - b(11)
+! JVS(32) = Jac_FULL(9,10)
+ jvs(32) = b(1)
+! JVS(33) = Jac_FULL(10,5)
+ jvs(33) = b(10)
+! JVS(34) = Jac_FULL(10,6)
+ jvs(34) = b(4)
+! JVS(35) = Jac_FULL(10,7)
+ jvs(35) = - b(12)
+! JVS(36) = Jac_FULL(10,8)
+ jvs(36) = b(8)
+! JVS(37) = Jac_FULL(10,9)
+ jvs(37) = b(5) + b(9) + b(11)
+! JVS(38) = Jac_FULL(10,10)
+ jvs(38) = - b(1) - b(13)
+
+END SUBROUTINE jac_sp
+
+ elemental REAL(kind=dp)FUNCTION k_arr (k_298, tdep, temp)
+ ! arrhenius FUNCTION
+
+ REAL, INTENT(IN):: k_298 ! k at t = 298.15k
+ REAL, INTENT(IN):: tdep ! temperature dependence
+ REAL(kind=dp), INTENT(IN):: temp ! temperature
+
+ intrinsic exp
+
+ k_arr = k_298 * exp(tdep* (1._dp/temp- 3.3540e-3_dp))! 1/298.15=3.3540e-3
+
+ END FUNCTION k_arr
+
+SUBROUTINE update_rconst()
+ INTEGER :: k
+
+ k = is
+
+! Begin INLINED RCONST
+
+
+! End INLINED RCONST
+
+ rconst(1) = (phot(j_no2))
+ rconst(2) = (2.0_dp * 2.2e-10_dp * phot(j_o31d) / (arr2(1.9e+8_dp , -390.0_dp , temp)))
+ rconst(3) = (arr2(1.8e-12_dp , 1370.0_dp , temp))
+ rconst(4) = (arr2(2.e-11_dp , 500.0_dp , temp))
+ rconst(5) = (arr2(4.2e-12_dp , -180.0_dp , temp))
+ rconst(6) = (arr2(3.7e-12_dp , -240.0_dp , temp))
+ rconst(7) = (arr2(1.15e-11_dp , 0.0_dp , temp))
+ rconst(8) = (1.0_dp)
+
+END SUBROUTINE update_rconst
+
+! END FUNCTION ARR2
+REAL(kind=dp)FUNCTION arr2( a0, b0, temp)
+ REAL(kind=dp):: temp
+ REAL(kind=dp):: a0, b0
+ arr2 = a0 * exp( - b0 / temp)
+END FUNCTION arr2
+
+SUBROUTINE initialize_kpp_ctrl(status)
+
+
+ ! i/o
+ INTEGER, INTENT(OUT):: status
+
+ ! local
+ REAL(dp):: tsum
+ INTEGER :: i
+
+ ! check fixed time steps
+ tsum = 0.0_dp
+ DO i=1, nmaxfixsteps
+ IF (t_steps(i)< tiny(0.0_dp))exit
+ tsum = tsum + t_steps(i)
+ ENDDO
+
+ nfsteps = i- 1
+
+ l_fixed_step = (nfsteps > 0).and.((tsum - 1.0)< tiny(0.0_dp))
+
+ IF (l_vector)THEN
+ WRITE(*,*) ' MODE : VECTOR (LENGTH=',VL_DIM,')'
+ ELSE
+ WRITE(*,*) ' MODE : SCALAR'
+ ENDIF
+ !
+ WRITE(*,*) ' DE-INDEXING MODE :',I_LU_DI
+ !
+ WRITE(*,*) ' ICNTRL : ',icntrl
+ WRITE(*,*) ' RCNTRL : ',rcntrl
+ !
+ ! note: this is ONLY meaningful for vectorized (kp4)rosenbrock- methods
+ IF (l_vector)THEN
+ IF (l_fixed_step)THEN
+ WRITE(*,*) ' TIME STEPS : FIXED (',t_steps(1:nfsteps),')'
+ ELSE
+ WRITE(*,*) ' TIME STEPS : AUTOMATIC'
+ ENDIF
+ ELSE
+ WRITE(*,*) ' TIME STEPS : AUTOMATIC '//&
+ &'(t_steps (CTRL_KPP) ignored in SCALAR MODE)'
+ ENDIF
+ ! mz_pj_20070531-
+
+ status = 0
+
+
+END SUBROUTINE initialize_kpp_ctrl
+
+SUBROUTINE error_output(c, ierr, pe)
+
+
+ INTEGER, INTENT(IN):: ierr
+ INTEGER, INTENT(IN):: pe
+ REAL(dp), DIMENSION(:), INTENT(IN):: c
+
+ write(6,*) 'ERROR in chem_gasphase_mod ',ierr,C(1)
+
+
+END SUBROUTINE error_output
+
+ SUBROUTINE wscal(n, alpha, x, incx)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+! constant times a vector: x(1:N) <- Alpha*x(1:N)
+! only for incX=incY=1
+! after BLAS
+! replace this by the function from the optimized BLAS implementation:
+! CALL SSCAL(N,Alpha,X,1) or CALL DSCAL(N,Alpha,X,1)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ INTEGER :: i, incx, m, mp1, n
+ REAL(kind=dp) :: x(n), alpha
+ REAL(kind=dp), PARAMETER :: zero=0.0_dp, one=1.0_dp
+
+ IF (alpha .eq. one)RETURN
+ IF (n .le. 0)RETURN
+
+ m = mod(n, 5)
+ IF ( m .ne. 0)THEN
+ IF (alpha .eq. (- one))THEN
+ DO i = 1, m
+ x(i) = - x(i)
+ ENDDO
+ ELSEIF (alpha .eq. zero)THEN
+ DO i = 1, m
+ x(i) = zero
+ ENDDO
+ ELSE
+ DO i = 1, m
+ x(i) = alpha* x(i)
+ ENDDO
+ ENDIF
+ IF ( n .lt. 5)RETURN
+ ENDIF
+ mp1 = m + 1
+ IF (alpha .eq. (- one))THEN
+ DO i = mp1, n, 5
+ x(i) = - x(i)
+ x(i + 1) = - x(i + 1)
+ x(i + 2) = - x(i + 2)
+ x(i + 3) = - x(i + 3)
+ x(i + 4) = - x(i + 4)
+ ENDDO
+ ELSEIF (alpha .eq. zero)THEN
+ DO i = mp1, n, 5
+ x(i) = zero
+ x(i + 1) = zero
+ x(i + 2) = zero
+ x(i + 3) = zero
+ x(i + 4) = zero
+ ENDDO
+ ELSE
+ DO i = mp1, n, 5
+ x(i) = alpha* x(i)
+ x(i + 1) = alpha* x(i + 1)
+ x(i + 2) = alpha* x(i + 2)
+ x(i + 3) = alpha* x(i + 3)
+ x(i + 4) = alpha* x(i + 4)
+ ENDDO
+ ENDIF
+
+ END SUBROUTINE wscal
+
+ SUBROUTINE waxpy(n, alpha, x, incx, y, incy)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+! constant times a vector plus a vector: y <- y + Alpha*x
+! only for incX=incY=1
+! after BLAS
+! replace this by the function from the optimized BLAS implementation:
+! CALL SAXPY(N,Alpha,X,1,Y,1) or CALL DAXPY(N,Alpha,X,1,Y,1)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ INTEGER :: i, incx, incy, m, mp1, n
+ REAL(kind=dp):: x(n), y(n), alpha
+ REAL(kind=dp), PARAMETER :: zero = 0.0_dp
+
+ IF (alpha .eq. zero)RETURN
+ IF (n .le. 0)RETURN
+
+ m = mod(n, 4)
+ IF ( m .ne. 0)THEN
+ DO i = 1, m
+ y(i) = y(i) + alpha* x(i)
+ ENDDO
+ IF ( n .lt. 4)RETURN
+ ENDIF
+ mp1 = m + 1
+ DO i = mp1, n, 4
+ y(i) = y(i) + alpha* x(i)
+ y(i + 1) = y(i + 1) + alpha* x(i + 1)
+ y(i + 2) = y(i + 2) + alpha* x(i + 2)
+ y(i + 3) = y(i + 3) + alpha* x(i + 3)
+ ENDDO
+
+ END SUBROUTINE waxpy
+
+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
+!
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+!~~~> arguments
+ INTEGER, INTENT(IN) :: n
+ REAL(kind=dp), INTENT(INOUT):: y(n)
+ REAL(kind=dp), INTENT(IN) :: tstart, tend
+ REAL(kind=dp), INTENT(IN) :: abstol(n), reltol(n)
+ INTEGER, INTENT(IN) :: icntrl(20)
+ REAL(kind=dp), INTENT(IN) :: rcntrl(20)
+ INTEGER, INTENT(INOUT):: istatus(20)
+ REAL(kind=dp), 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
+ REAL(kind=dp):: 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
+ REAL(kind=dp):: roundoff, facmin, facmax, facrej, facsafe
+ REAL(kind=dp):: hmin, hmax, hstart
+ REAL(kind=dp):: texit
+ INTEGER :: i, uplimtol, max_no_steps
+ LOGICAL :: autonomous, vectortol
+!~~~> PARAMETERs
+ REAL(kind=dp), PARAMETER :: zero = 0.0_dp, one = 1.0_dp
+ REAL(kind=dp), 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
+ ENDIF
+
+!~~~> 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
+ ENDIF
+
+!~~~> unit roundoff (1+ roundoff>1)
+ roundoff = epsilon(one)
+
+!~~~> 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
+ ENDIF
+!~~~> 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
+ ENDIF
+!~~~> 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
+ ENDIF
+!~~~> 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
+ ENDIF
+ 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
+ ENDIF
+!~~~> 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
+ ENDIF
+!~~~> 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
+ ENDIF
+!~~~> 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
+ ENDIF
+ ENDDO
+
+
+!~~~> 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ REAL(kind=dp), 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}
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+!~~~> input: the initial condition at tstart; output: the solution at t
+ REAL(kind=dp), INTENT(INOUT):: y(n)
+!~~~> input: integration interval
+ REAL(kind=dp), INTENT(IN):: tstart, tend
+!~~~> output: time at which the solution is RETURNed (t=tendIF success)
+ REAL(kind=dp), INTENT(OUT):: t
+!~~~> input: tolerances
+ REAL(kind=dp), INTENT(IN):: abstol(n), reltol(n)
+!~~~> input: integration PARAMETERs
+ LOGICAL, INTENT(IN):: autonomous, vectortol
+ REAL(kind=dp), INTENT(IN):: hstart, hmin, hmax
+ INTEGER, INTENT(IN):: max_no_steps
+ REAL(kind=dp), INTENT(IN):: roundoff, facmin, facmax, facrej, facsafe
+!~~~> output: error indicator
+ INTEGER, INTENT(OUT):: ierr
+! ~~~~ Local variables
+ REAL(kind=dp):: ynew(n), fcn0(n), fcn(n)
+ REAL(kind=dp):: k(n* ros_s), dfdt(n)
+#ifdef full_algebra
+ REAL(kind=dp):: jac0(n, n), ghimj(n, n)
+#else
+ REAL(kind=dp):: jac0(lu_nonzero), ghimj(lu_nonzero)
+#endif
+ REAL(kind=dp):: h, hnew, hc, hg, fac, tau
+ REAL(kind=dp):: err, yerr(n)
+ INTEGER :: pivot(n), direction, ioffset, j, istage
+ LOGICAL :: rejectlasth, rejectmoreh, singular
+!~~~> local PARAMETERs
+ REAL(kind=dp), PARAMETER :: zero = 0.0_dp, one = 1.0_dp
+ REAL(kind=dp), PARAMETER :: deltamin = 1.0e-5_dp
+!~~~> locally called FUNCTIONs
+! REAL(kind=dp) 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
+ ENDIF
+ 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
+ ENDIF
+ IF (((t+ 0.1_dp* h) == t).or.(h <= roundoff))THEN ! step size too small
+ CALL ros_errormsg(- 7, t, h, ierr)
+ RETURN
+ ENDIF
+
+!~~~> 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)
+ ENDIF
+
+!~~~> 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
+ ENDIF
+
+!~~~> 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
+ !slim: CALL wcopy(n, fcn0, 1, fcn, 1)
+ fcn(1:n) = fcn0(1:n)
+ ! istage>1 and a new FUNCTION evaluation is needed at the current istage
+ ELSEIF(ros_newf(istage))THEN
+ !slim: CALL wcopy(n, y, 1, ynew, 1)
+ ynew(1:n) = y(1:n)
+ DO j = 1, istage-1
+ CALL waxpy(n, ros_a((istage-1) * (istage-2) /2+ j), &
+ k(n* (j- 1) + 1), 1, ynew, 1)
+ ENDDO
+ tau = t + ros_alpha(istage) * direction* h
+ CALL funtemplate(tau, ynew, fcn)
+ istatus(nfun) = istatus(nfun) + 1
+ ENDIF ! IF istage == 1 ELSEIF ros_newf(istage)
+ !slim: CALL wcopy(n, fcn, 1, k(ioffset+ 1), 1)
+ k(ioffset+ 1:ioffset+ n) = fcn(1:n)
+ 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), 1, k(ioffset+ 1), 1)
+ ENDDO
+ 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), 1)
+ ENDIF
+ CALL ros_solve(ghimj, pivot, k(ioffset+ 1))
+
+ END DO stage
+
+
+!~~~> compute the new solution
+ !slim: CALL wcopy(n, y, 1, ynew, 1)
+ ynew(1:n) = y(1:n)
+ DO j=1, ros_s
+ CALL waxpy(n, ros_m(j), k(n* (j- 1) + 1), 1, ynew, 1)
+ ENDDO
+
+!~~~> compute the error estimation
+ !slim: CALL wscal(n, zero, yerr, 1)
+ yerr(1:n) = zero
+ DO j=1, ros_s
+ CALL waxpy(n, ros_e(j), k(n* (j- 1) + 1), 1, yerr, 1)
+ ENDDO
+ 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
+ !slim: CALL wcopy(n, ynew, 1, y, 1)
+ y(1:n) = ynew(1:n)
+ 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)
+ ENDIF
+ 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
+ ENDIF
+ rejectmoreh = rejectlasth
+ rejectlasth = .TRUE.
+ h = hnew
+ IF (istatus(nacc)>= 1) istatus(nrej) = istatus(nrej) + 1
+ ENDIF ! err <= 1
+
+ END DO untilaccepted
+
+ END DO timeloop
+
+!~~~> succesful exit
+ ierr = 1 !~~~> the integration was successful
+
+ END SUBROUTINE ros_integrator
+
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ REAL(kind=dp)FUNCTION ros_errornorm(y, ynew, yerr, &
+ abstol, reltol, vectortol)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> computes the "scaled norm" of the error vector yerr
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+! Input arguments
+ REAL(kind=dp), INTENT(IN):: y(n), ynew(n), &
+ yerr(n), abstol(n), reltol(n)
+ LOGICAL, INTENT(IN):: vectortol
+! Local variables
+ REAL(kind=dp):: err, scale, ymax
+ INTEGER :: i
+ REAL(kind=dp), 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
+ ENDIF
+ err = err+ (yerr(i) /scale) ** 2
+ ENDDO
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+!~~~> input arguments
+ REAL(kind=dp), INTENT(IN):: t, roundoff, y(n), fcn0(n)
+!~~~> output arguments
+ REAL(kind=dp), INTENT(OUT):: dfdt(n)
+!~~~> local variables
+ REAL(kind=dp):: delta
+ REAL(kind=dp), 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
+! --- --- --- --- --- --- --- --- --- --- --- --- ---
+
+!~~~> input arguments
+#ifdef full_algebra
+ REAL(kind=dp), INTENT(IN):: jac0(n, n)
+#else
+ REAL(kind=dp), INTENT(IN):: jac0(lu_nonzero)
+#endif
+ REAL(kind=dp), INTENT(IN):: gam
+ INTEGER, INTENT(IN):: direction
+!~~~> output arguments
+#ifdef full_algebra
+ REAL(kind=dp), INTENT(OUT):: ghimj(n, n)
+#else
+ REAL(kind=dp), INTENT(OUT):: ghimj(lu_nonzero)
+#endif
+ LOGICAL, INTENT(OUT):: singular
+ INTEGER, INTENT(OUT):: pivot(n)
+!~~~> inout arguments
+ REAL(kind=dp), INTENT(INOUT):: h ! step size is decreased when lu fails
+!~~~> local variables
+ INTEGER :: i, ising, nconsecutive
+ REAL(kind=dp):: ghinv
+ REAL(kind=dp), 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
+ !slim: CALL wcopy(n* n, jac0, 1, ghimj, 1)
+ !slim: CALL wscal(n* n, (- one), ghimj, 1)
+ ghimj = - jac0
+ ghinv = one/(direction* h* gam)
+ DO i=1, n
+ ghimj(i, i) = ghimj(i, i) + ghinv
+ ENDDO
+#else
+ !slim: CALL wcopy(lu_nonzero, jac0, 1, ghimj, 1)
+ !slim: CALL wscal(lu_nonzero, (- one), ghimj, 1)
+ ghimj(1:lu_nonzero) = - jac0(1:lu_nonzero)
+ ghinv = one/(direction* h* gam)
+ DO i=1, n
+ ghimj(lu_diag(i)) = ghimj(lu_diag(i)) + ghinv
+ ENDDO
+#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
+ ENDIF ! nconsecutive
+ ENDIF ! ising
+
+ END DO ! WHILE singular
+
+ END SUBROUTINE ros_preparematrix
+
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE ros_decomp( a, pivot, ising)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! Template for the LU decomposition
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> inout variables
+#ifdef full_algebra
+ REAL(kind=dp), INTENT(INOUT):: a(n, n)
+#else
+ REAL(kind=dp), INTENT(INOUT):: a(lu_nonzero)
+#endif
+!~~~> 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)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> input variables
+#ifdef full_algebra
+ REAL(kind=dp), INTENT(IN):: a(n, n)
+ INTEGER :: ising
+#else
+ REAL(kind=dp), INTENT(IN):: a(lu_nonzero)
+#endif
+ INTEGER, INTENT(IN):: pivot(n)
+!~~~> inout variables
+ REAL(kind=dp), INTENT(INOUT):: b(n)
+
+#ifdef full_algebra
+ CALL DGETRS( 'N',N ,1,A,N,Pivot,b,N,ISING)
+ IF (info < 0)THEN
+ print* , "error in dgetrs. ising=", ising
+ ENDIF
+#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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ 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)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+ 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)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> input variables
+ REAL(kind=dp):: t, y(nvar)
+!~~~> output variables
+ REAL(kind=dp):: ydot(nvar)
+!~~~> local variables
+ REAL(kind=dp):: told
+
+ told = time
+ time = t
+ 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
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> input variables
+ REAL(kind=dp):: t, y(nvar)
+!~~~> output variables
+#ifdef full_algebra
+ REAL(kind=dp):: jv(lu_nonzero), jcb(nvar, nvar)
+#else
+ REAL(kind=dp):: jcb(lu_nonzero)
+#endif
+!~~~> local variables
+ REAL(kind=dp):: told
+#ifdef full_algebra
+ INTEGER :: i, j
+#endif
+
+ told = time
+ time = t
+#ifdef full_algebra
+ CALL jac_sp(y, fix, rconst, jv)
+ DO j=1, nvar
+ DO i=1, nvar
+ jcb(i, j) = 0.0_dp
+ ENDDO
+ ENDDO
+ DO i=1, lu_nonzero
+ jcb(lu_irow(i), lu_icol(i)) = jv(i)
+ ENDDO
+#else
+ CALL jac_sp( y, fix, rconst, jcb)
+#endif
+ time = told
+
+END SUBROUTINE jactemplate
+
+ SUBROUTINE kppdecomp( jvs, ier)
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! sparse lu factorization
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! loop expansion generated by kp4
+
+ INTEGER :: ier
+ REAL(kind=dp):: jvs(lu_nonzero), w(nvar), a
+ INTEGER :: k, kk, j, jj
+
+ a = 0.
+ ier = 0
+
+! i = 1
+! i = 2
+! i = 3
+! i = 4
+! i = 5
+! i = 6
+! i = 7
+ jvs(16) = (jvs(16)) / jvs(8)
+ jvs(17) = (jvs(17)) / jvs(10)
+ jvs(18) = (jvs(18)) / jvs(13)
+ jvs(19) = jvs(19) - jvs(9) * jvs(16)
+ jvs(20) = jvs(20) - jvs(11) * jvs(17)
+ jvs(21) = jvs(21) - jvs(12) * jvs(17) - jvs(14) * jvs(18)
+ jvs(22) = jvs(22) - jvs(15) * jvs(18)
+! i = 8
+ jvs(23) = (jvs(23)) / jvs(8)
+ a = 0.0; a = a - jvs(9) * jvs(23)
+ jvs(24) = (jvs(24) + a) / jvs(19)
+ jvs(25) = jvs(25) - jvs(20) * jvs(24)
+ jvs(26) = jvs(26) - jvs(21) * jvs(24)
+ jvs(27) = jvs(27) - jvs(22) * jvs(24)
+! i = 9
+ jvs(28) = (jvs(28)) / jvs(10)
+ jvs(29) = (jvs(29)) / jvs(13)
+ a = 0.0; a = a - jvs(11) * jvs(28)
+ jvs(30) = (jvs(30) + a) / jvs(25)
+ jvs(31) = jvs(31) - jvs(12) * jvs(28) - jvs(14) * jvs(29) - jvs(26) * jvs(30)
+ jvs(32) = jvs(32) - jvs(15) * jvs(29) - jvs(27) * jvs(30)
+! i = 10
+ jvs(33) = (jvs(33)) / jvs(10)
+ jvs(34) = (jvs(34)) / jvs(13)
+ jvs(35) = (jvs(35)) / jvs(19)
+ a = 0.0; a = a - jvs(11) * jvs(33) - jvs(20) * jvs(35)
+ jvs(36) = (jvs(36) + a) / jvs(25)
+ a = 0.0; a = a - jvs(12) * jvs(33) - jvs(14) * jvs(34) - jvs(21) * jvs(35) - jvs(26) * jvs(36)
+ jvs(37) = (jvs(37) + a) / jvs(31)
+ jvs(38) = jvs(38) - jvs(15) * jvs(34) - jvs(22) * jvs(35) - jvs(27) * jvs(36) - jvs(32) * jvs(37)
+ RETURN
+
+ END SUBROUTINE kppdecomp
+
+SUBROUTINE chem_gasphase_integrate (time_step_len, conc, tempi, qvapi, fakti, photo, ierrf, xnacc, xnrej, istatus, l_debug, pe, &
+ icntrl_i, rcntrl_i)
+
+ IMPLICIT NONE
+
+ REAL(dp), INTENT(IN) :: time_step_len
+ REAL(dp), DIMENSION(:, :), INTENT(INOUT) :: conc
+ REAL(dp), DIMENSION(:, :), INTENT(IN) :: photo
+ REAL(dp), DIMENSION(:), INTENT(IN) :: tempi
+ REAL(dp), DIMENSION(:), INTENT(IN) :: qvapi
+ REAL(dp), DIMENSION(:), INTENT(IN) :: fakti
+ INTEGER, INTENT(OUT), OPTIONAL :: ierrf(:)
+ INTEGER, INTENT(OUT), OPTIONAL :: xnacc(:)
+ INTEGER, INTENT(OUT), OPTIONAL :: xnrej(:)
+ INTEGER, INTENT(INOUT), OPTIONAL :: istatus(:)
+ INTEGER, INTENT(IN), OPTIONAL :: pe
+ LOGICAL, INTENT(IN), OPTIONAL :: l_debug
+ INTEGER, DIMENSION(nkppctrl), INTENT(IN), OPTIONAL :: icntrl_i
+ REAL(dp), DIMENSION(nkppctrl), INTENT(IN), OPTIONAL :: rcntrl_i
+
+ INTEGER :: k ! loop variable
+ REAL(dp) :: dt
+ INTEGER, DIMENSION(20) :: istatus_u
+ INTEGER :: ierr_u
+ INTEGER :: istatf
+ INTEGER :: vl_dim_lo
+
+
+ IF (PRESENT (istatus)) istatus = 0
+ IF (PRESENT (icntrl_i)) icntrl = icntrl_i
+ IF (PRESENT (rcntrl_i)) rcntrl = rcntrl_i
+
+ vl_glo = size(tempi, 1)
+
+ vl_dim_lo = vl_dim
+ DO k=1, vl_glo, vl_dim_lo
+ is = k
+ ie = min(k+ vl_dim_lo-1, vl_glo)
+ vl = ie-is+ 1
+
+ c(:) = conc(is, :)
+
+ temp = tempi(is)
+
+ qvap = qvapi(is)
+
+ fakt = fakti(is)
+
+ CALL initialize
+
+ phot(:) = photo(is, :)
+
+ CALL update_rconst
+
+ dt = time_step_len
+
+ ! integrate from t=0 to t=dt
+ CALL integrate(0._dp, dt, icntrl, rcntrl, istatus_u = istatus_u, ierr_u=ierr_u)
+
+
+ IF (PRESENT(l_debug) .AND. PRESENT(pe)) THEN
+ IF (l_debug) CALL error_output(conc(is, :), ierr_u, pe)
+ ENDIF
+
+ conc(is, :) = c(:)
+
+ ! RETURN diagnostic information
+
+ IF (PRESENT(ierrf)) ierrf(is) = ierr_u
+ IF (PRESENT(xnacc)) xnacc(is) = istatus_u(4)
+ IF (PRESENT(xnrej)) xnrej(is) = istatus_u(5)
+
+ IF (PRESENT (istatus)) THEN
+ istatus(1:8) = istatus(1:8) + istatus_u(1:8)
+ ENDIF
+
+ END DO
+
+
+! Deallocate input arrays
+
+
+ data_loaded = .FALSE.
+
+ RETURN
+END SUBROUTINE chem_gasphase_integrate
+
+END MODULE chem_gasphase_mod
+
Index: /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_simplep/chem_gasphase_mod.kpp
===================================================================
--- /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_simplep/chem_gasphase_mod.kpp (revision 3698)
+++ /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_simplep/chem_gasphase_mod.kpp (revision 3698)
@@ -0,0 +1,37 @@
+//chem_gasphase_mod.kpp
+//
+//Former revisions
+//----------------
+// $Id: chem_gasphase_mod.kpp 2459 2017-09-13 14:10:33Z forkel $
+// initial revision from branch chemistry
+//
+//
+#include simplep.spc
+#include simplep.eqn
+#INTEGRATOR rosenbrock
+#LANGUAGE Fortran90
+#HESSIAN on
+#STOICMAT on
+//
+// 'simple' gas phase chemistry with additional tracer named PM10
+// *******************************************************************************************
+// *** adapt the lines below occurding to the photolysis reactions of your mechanism *
+// *** adapt the number of photolysis frequencies NPHO *
+// *** adapt/extend the indices in the INTEGER, PARAMETER,PUBLIC statement below *
+// *** adapt/extend PHOT_NAMES: Note that the order of PHOT_NAMES and the indices must match *
+// *******************************************************************************************
+//
+#INLINE F90_DATA
+ ! INLINE F90_DATA: Declaration of global variables for photolysis
+ ! REAL(kind=dp) :: phot(nphot) must eventually be moved to GLOBAL later for vector version
+ INTEGER, PARAMETER :: nphot = 2
+ ! phot Photolysis frequencies
+ REAL(kind=dp) :: phot(nphot)
+
+ INTEGER, PARAMETER,PUBLIC :: j_no2 = 1
+ INTEGER, PARAMETER,PUBLIC :: j_o31d = 2
+
+ CHARACTER(LEN=15), PARAMETER, DIMENSION(NPHOT) :: phot_names = (/ &
+ 'J_NO2 ','J_O31D '/)
+#ENDINLINE
+
Index: /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_simplep/simplep.eqn
===================================================================
--- /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_simplep/simplep.eqn (revision 3698)
+++ /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_simplep/simplep.eqn (revision 3698)
@@ -0,0 +1,23 @@
+{simplep.eqn
+Current revision
+----------------
+ 20181220 Fixed effective rate of equation 2 forkel
+ according to eq. 11.1 of
+ http://acmg.seas.harvard.edu/publications/jacobbook/bookchap11.pdf
+ 20180316 Added passive compound named PM10 forkel
+ 20180316 Added equation no. 7 forkel
+ 201711xx Created simple.eqn with 6 equations forkel
+}
+#EQUATIONS
+
+{ home made very simple mechanism - please do not show to a chemist! }
+
+ { 1.} NO2 + hv = NO + O3 : phot(j_no2) ;
+ { 2.} O3 + H2O = 2OH : 2.0_dp * 2.2E-10_dp * phot(j_o31d) / (arr2(1.9E+8_dp, -390.0_dp, temp));
+ { 3.} NO + O3 = NO2 : arr2(1.8E-12_dp, 1370.0_dp, temp) ;
+ { 4.} RH + OH = RO2 + H2O : arr2(2.E-11_dp, 500.0_dp, temp) ;
+ { 5.} RO2 + NO = NO2 + RCHO + HO2 : arr2(4.2E-12_dp, -180.0_dp, temp);
+ { 6.} HO2 + NO = NO2 + OH : arr2(3.7E-12_dp, -240.0_dp, temp) ;
+ { 7.} NO2 + OH = HNO3 : arr2(1.15E-11_dp, 0.0_dp, temp) ;
+ { 8.} PM10 = PM10 : 1.0_dp ;
+
Index: /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_simplep/simplep.spc
===================================================================
--- /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_simplep/simplep.spc (revision 3698)
+++ /palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_simplep/simplep.spc (revision 3698)
@@ -0,0 +1,43 @@
+{simple.spc
+Former revisions
+----------------
+ $Id: smog.spc 2459 2017-09-13 14:10:33Z forkel $
+}
+#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}
+ CO = C + O ; {carbon monoxide}
+
+ PM10 = ignore ; {passive tracer}
+ 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}
+ CO2 = C + 2O ; {carbon dioxide}
+