├── .github └── workflows │ └── CI.yml ├── .gitignore ├── LICENSE ├── README.md ├── codecov.yml ├── dop853.code-workspace ├── ford.md ├── fpm.toml ├── media ├── dop853_backward.png ├── dop853_forward.png ├── logo.png └── logo.svg ├── src └── dop853_module.F90 └── test ├── dop853_example_original.f90 └── dop853_test.f90 /.github/workflows/CI.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | on: [push] 3 | jobs: 4 | 5 | Build: 6 | runs-on: ${{ matrix.os }} 7 | permissions: 8 | contents: write 9 | strategy: 10 | fail-fast: false 11 | matrix: 12 | os: [ubuntu-latest] 13 | gcc_v: [10] # Version of GFortran we want to use. 14 | python-version: [3.9] 15 | env: 16 | FC: gfortran-${{ matrix.gcc_v }} 17 | GCC_V: ${{ matrix.gcc_v }} 18 | 19 | steps: 20 | - name: Checkout code 21 | uses: actions/checkout@v3 22 | with: 23 | submodules: recursive 24 | 25 | - name: Install Python 26 | uses: actions/setup-python@v4 # Use pip to install latest CMake, & FORD/Jin2For, etc. 27 | with: 28 | python-version: ${{ matrix.python-version }} 29 | 30 | - name: Setup Graphviz 31 | uses: ts-graphviz/setup-graphviz@v1 32 | 33 | - name: Setup Fortran Package Manager 34 | uses: fortran-lang/setup-fpm@v5 35 | with: 36 | github-token: ${{ secrets.GITHUB_TOKEN }} 37 | 38 | - name: Install Python dependencies 39 | if: contains( matrix.os, 'ubuntu') 40 | run: | 41 | python -m pip install --upgrade pip 42 | pip install ford numpy matplotlib 43 | if [ -f requirements.txt ]; then pip install -r requirements.txt; fi 44 | 45 | - name: Install GFortran Linux 46 | if: contains( matrix.os, 'ubuntu') 47 | run: | 48 | sudo apt-get install lcov 49 | sudo update-alternatives \ 50 | --install /usr/bin/gcc gcc /usr/bin/gcc-${{ matrix.gcc_v }} 100 \ 51 | --slave /usr/bin/gfortran gfortran /usr/bin/gfortran-${{ matrix.gcc_v }} \ 52 | --slave /usr/bin/gcov gcov /usr/bin/gcov-${{ matrix.gcc_v }} 53 | 54 | # - name: Compile 55 | # run: fpm build --profile release 56 | 57 | - name: Run tests 58 | run: fpm test --profile debug --flag -coverage 59 | 60 | - name: Create coverage report 61 | run: | 62 | mkdir -p ${{ env.COV_DIR }} 63 | lcov --capture --initial --base-directory . --directory build/gfortran_*/ --output-file ${{ env.COV_DIR }}/coverage.base 64 | lcov --capture --base-directory . --directory build/gfortran_*/ --output-file ${{ env.COV_DIR }}/coverage.capture 65 | lcov --add-tracefile ${{ env.COV_DIR }}/coverage.base --add-tracefile ${{ env.COV_DIR }}/coverage.capture --output-file ${{ env.COV_DIR }}/coverage.info 66 | env: 67 | COV_DIR: build/coverage 68 | 69 | - name: Upload coverage report 70 | uses: codecov/codecov-action@v3 71 | with: 72 | files: build/coverage/coverage.info 73 | 74 | - name: Build documentation 75 | run: ford ./ford.md 76 | 77 | - name: Deploy Documentation 78 | if: github.ref == 'refs/heads/master' 79 | uses: JamesIves/github-pages-deploy-action@v4.4.1 80 | with: 81 | branch: gh-pages # The branch the action should deploy to. 82 | folder: doc # The folder the action should deploy. 83 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /bin 2 | /lib 3 | /doc 4 | /build 5 | 6 | # Compiled Object files 7 | *.slo 8 | *.lo 9 | *.o 10 | *.obj 11 | 12 | # Precompiled Headers 13 | *.gch 14 | *.pch 15 | 16 | # Compiled Dynamic libraries 17 | *.so 18 | *.dylib 19 | *.dll 20 | 21 | # Fortran module files 22 | *.mod 23 | 24 | # Compiled Static libraries 25 | *.lai 26 | *.la 27 | *.a 28 | *.lib 29 | 30 | # Executables 31 | *.exe 32 | *.out 33 | *.app 34 | 35 | # mac 36 | .DS_Store 37 | 38 | # misc 39 | /*.png -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Modern Fortran Edition of the DOP853 ODE Solver 2 | https://github.com/jacobwilliams/dop853 3 | 4 | Copyright (c) 2015-2022, Jacob Williams 5 | All rights reserved. 6 | 7 | Redistribution and use in source and binary forms, with or without modification, 8 | are permitted provided that the following conditions are met: 9 | 10 | * Redistributions of source code must retain the above copyright notice, this 11 | list of conditions and the following disclaimer. 12 | 13 | * Redistributions in binary form must reproduce the above copyright notice, this 14 | list of conditions and the following disclaimer in the documentation and/or 15 | other materials provided with the distribution. 16 | 17 | * The names of its contributors may not be used to endorse or promote products 18 | derived from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 21 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 22 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR 24 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 25 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 26 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 27 | ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 29 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | -------------------------------------------------------------------------------- 32 | Original DOP853 License 33 | -------------------------------------------------------------------------------- 34 | 35 | Copyright (c) 2004, Ernst Hairer 36 | 37 | Redistribution and use in source and binary forms, with or without 38 | modification, are permitted provided that the following conditions are 39 | met: 40 | 41 | - Redistributions of source code must retain the above copyright 42 | notice, this list of conditions and the following disclaimer. 43 | 44 | - Redistributions in binary form must reproduce the above copyright 45 | notice, this list of conditions and the following disclaimer in the 46 | documentation and/or other materials provided with the distribution. 47 | 48 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS �AS 49 | IS� AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED 50 | TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A 51 | PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR 52 | CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 53 | EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, 54 | PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 55 | PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 56 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 57 | NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 58 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 59 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ![dop853](media/logo.png) 2 | ============ 3 | 4 | This is a modern Fortran (2003/2008) implementation of Hairer's DOP853 ODE solver. The original FORTRAN 77 code has been extensively refactored, and is now object-oriented and thread-safe, with an easy-to-use class interface. DOP853 is an explicit Runge-Kutta method of order 8(5,3) due to Dormand & Prince (with stepsize control and dense output). 5 | 6 | This project is hosted on [GitHub](https://github.com/jacobwilliams/dop853). 7 | 8 | ## Status 9 | 10 | [![GitHub release](https://img.shields.io/github/release/jacobwilliams/dop853.svg)](https://github.com/jacobwilliams/dop853/releases/latest) 11 | [![CI Status](https://github.com/jacobwilliams/dop853/actions/workflows/CI.yml/badge.svg)](https://github.com/jacobwilliams/dop853/actions) 12 | [![codecov](https://codecov.io/gh/jacobwilliams/dop853/branch/master/graph/badge.svg)](https://codecov.io/gh/jacobwilliams/dop853) 13 | [![last-commit](https://img.shields.io/github/last-commit/jacobwilliams/dop853)](https://github.com/jacobwilliams/dop853/commits/master) 14 | 15 | ## Example 16 | 17 | Basic use of the solver is shown here. The main methods in the `dop853_class` are `initialize()` and `integrate()`. 18 | 19 | ```fortran 20 | program dop853_example 21 | 22 | use dop853_module, wp => dop853_wp 23 | use iso_fortran_env, only: output_unit 24 | 25 | implicit none 26 | 27 | integer,parameter :: n = 2 !! dimension of the system 28 | real(wp),parameter :: tol = 1.0e-12_wp !! integration tolerance 29 | real(wp),parameter :: x0 = 0.0_wp !! initial x value 30 | real(wp),parameter :: xf = 100.0_wp !! endpoint of integration 31 | real(wp),dimension(n),parameter :: y0 = [0.0_wp,0.1_wp] !! initial y value 32 | 33 | type(dop853_class) :: prop 34 | real(wp),dimension(n) :: y 35 | real(wp),dimension(1) :: rtol,atol 36 | real(wp) :: x 37 | integer :: idid 38 | logical :: status_ok 39 | 40 | x = x0 ! initial conditions 41 | y = y0 ! 42 | rtol = tol ! set tolerances 43 | atol = tol ! 44 | 45 | !initialize the integrator: 46 | call prop%initialize(fcn=fvpol,n=n,status_ok=status_ok) 47 | if (.not. status_ok) error stop 'initialization error' 48 | 49 | !now, perform the integration: 50 | call prop%integrate(x,y,xf,rtol,atol,iout=0,idid=idid) 51 | 52 | !print solution: 53 | write (output_unit,'(1X,A,F6.2,A,2E18.10)') & 54 | 'x =',x ,' y =',y(1),y(2) 55 | 56 | contains 57 | 58 | subroutine fvpol(me,x,y,f) 59 | !! Right-hand side of van der Pol's equation 60 | 61 | implicit none 62 | 63 | class(dop853_class),intent(inout) :: me 64 | real(wp),intent(in) :: x 65 | real(wp),dimension(:),intent(in) :: y 66 | real(wp),dimension(:),intent(out) :: f 67 | 68 | real(wp),parameter :: mu = 0.2_wp 69 | 70 | f(1) = y(2) 71 | f(2) = mu*(1.0_wp-y(1)**2)*y(2) - y(1) 72 | 73 | end subroutine fvpol 74 | 75 | end program dop853_example 76 | ``` 77 | 78 | The result is: 79 | 80 | ``` 81 | x =100.00 y = -0.1360372426E+01 0.1325538438E+01 82 | ``` 83 | 84 | For dense output, see the example in the `src/tests` directory. 85 | 86 | ## Building DOP853 87 | 88 | A [Fortran Package Manager](https://github.com/fortran-lang/fpm) manifest file is included, so that the library and tests cases can be compiled with FPM. For example: 89 | 90 | ``` 91 | fpm build --profile release 92 | fpm test --profile release 93 | ``` 94 | 95 | To use `dop853` within your FPM project, add the following to your `fpm.toml` file: 96 | ```toml 97 | [dependencies] 98 | dop853 = { git="https://github.com/jacobwilliams/dop853.git" } 99 | ``` 100 | 101 | By default, the library is built with double precision (`real64`) real values. Explicitly specifying the real kind can be done using the following processor flags: 102 | 103 | Preprocessor flag | Kind | Number of bytes 104 | ----------------- | ----- | --------------- 105 | `REAL32` | `real(kind=real32)` | 4 106 | `REAL64` | `real(kind=real64)` | 8 107 | `REAL128` | `real(kind=real128)` | 16 108 | 109 | For example, to build a single precision version of the library, use: 110 | 111 | ``` 112 | fpm build --profile release --flag "-DREAL32" 113 | ``` 114 | 115 | To generate the documentation using [FORD](https://github.com/Fortran-FOSS-Programmers/ford), run: 116 | 117 | ``` 118 | ford dop853.md 119 | ``` 120 | 121 | ## 3rd Party Dependencies 122 | 123 | The unit tests require [pyplot-fortran](https://github.com/jacobwilliams/pyplot-fortran) which will be automatically downloaded by FPM. 124 | 125 | ## Documentation 126 | 127 | The latest API documentation for the `master` branch can be found [here](https://jacobwilliams.github.io/dop853/). This is generated by processing the source files with [FORD](https://github.com/Fortran-FOSS-Programmers/ford). 128 | 129 | ## References 130 | 131 | 1. E. Hairer, S.P. Norsett and G. Wanner, "[Solving ordinary 132 | Differential Equations I. Nonstiff Problems](http://www.unige.ch/~hairer/books.html)", 2nd edition. 133 | Springer Series in Computational Mathematics, 134 | Springer-Verlag (1993). 135 | 2. Ernst Hairer's website: [Fortran and Matlab Codes](http://www.unige.ch/~hairer/software.html) 136 | 137 | ## License 138 | 139 | * [Original license for Hairer's codes](http://www.unige.ch/~hairer/prog/licence.txt). 140 | * The updates are released under a [similar BSD-style license](https://raw.githubusercontent.com/jacobwilliams/dop853/master/LICENSE). 141 | 142 | ## See also 143 | * [numbalsoda](https://github.com/Nicholaswogan/numbalsoda) Python wrapper to this code. 144 | -------------------------------------------------------------------------------- /codecov.yml: -------------------------------------------------------------------------------- 1 | comment: 2 | layout: header, changes, diff, sunburst 3 | coverage: 4 | ignore: 5 | - test 6 | - doc 7 | status: 8 | patch: 9 | default: 10 | target: 20% 11 | project: 12 | default: 13 | target: 70% 14 | -------------------------------------------------------------------------------- /dop853.code-workspace: -------------------------------------------------------------------------------- 1 | { 2 | "folders": [ 3 | { 4 | "path": "." 5 | } 6 | ], 7 | "settings": { 8 | "files.trimTrailingWhitespace": true, 9 | "editor.insertSpaces": true, 10 | "editor.tabSize": 4, 11 | "editor.trimAutoWhitespace": true 12 | } 13 | } -------------------------------------------------------------------------------- /ford.md: -------------------------------------------------------------------------------- 1 | project: dop853 2 | project_dir: ./src 3 | output_dir: ./doc 4 | media_dir: ./media 5 | project_github: https://github.com/jacobwilliams/dop853 6 | summary: Modern Fortran Implementation of the DOP853 ODE Solver 7 | author: Jacob Williams 8 | github: https://github.com/jacobwilliams 9 | predocmark_alt: > 10 | predocmark: < 11 | docmark_alt: 12 | docmark: ! 13 | display: public 14 | private 15 | protected 16 | source: true 17 | graph: true 18 | extra_mods: pyplot_module:https://github.com/jacobwilliams/pyplot-fortran 19 | iso_fortran_env:https://gcc.gnu.org/onlinedocs/gfortran/ISO_005fFORTRAN_005fENV.html 20 | 21 | {!README.md!} -------------------------------------------------------------------------------- /fpm.toml: -------------------------------------------------------------------------------- 1 | name = "dop853" 2 | author = "Jacob Williams" 3 | maintainer = "Jacob Williams" 4 | copyright = "Copyright (c) 2015-2022, Jacob Williams" 5 | license = "BSD" 6 | description = "Modern Fortran Edition of Hairer's DOP853 ODE Solver" 7 | homepage = "https://github.com/jacobwilliams/dop853" 8 | keywords = ["runge-kutta"] 9 | 10 | [dev-dependencies] 11 | pyplot-fortran= { git = "https://github.com/jacobwilliams/pyplot-fortran", rev = "3.2.0" } 12 | 13 | [library] 14 | source-dir = "src" 15 | 16 | [install] 17 | library = true 18 | 19 | [build] 20 | auto-executables = false 21 | auto-examples = false 22 | auto-tests = true 23 | 24 | -------------------------------------------------------------------------------- /media/dop853_backward.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jacobwilliams/dop853/ccb2f3e8d0947d247e76d3eabd8a0433b608e94a/media/dop853_backward.png -------------------------------------------------------------------------------- /media/dop853_forward.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jacobwilliams/dop853/ccb2f3e8d0947d247e76d3eabd8a0433b608e94a/media/dop853_forward.png -------------------------------------------------------------------------------- /media/logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jacobwilliams/dop853/ccb2f3e8d0947d247e76d3eabd8a0433b608e94a/media/logo.png -------------------------------------------------------------------------------- /media/logo.svg: -------------------------------------------------------------------------------- 1 | 2 | 20 | 22 | 28 | 31 | 38 | 39 | 42 | 49 | 50 | 51 | 74 | 76 | 77 | 79 | image/svg+xml 80 | 82 | 83 | 84 | 85 | 86 | 91 | 99 | 107 | DOP8(5,3) 115 | 116 | 117 | -------------------------------------------------------------------------------- /src/dop853_module.F90: -------------------------------------------------------------------------------- 1 | !***************************************************************************************** 2 | !> author: Jacob Williams 3 | ! 4 | ! Modern Fortran Edition of the DOP853 ODE Solver. 5 | ! 6 | !### See also 7 | ! * [DOP853.f](http://www.unige.ch/~hairer/prog/nonstiff/dop853.f) -- The original code 8 | ! 9 | !### History 10 | ! * Jacob Williams : December 2015 : Created module from the DOP853 Fortran 77 code. 11 | ! * Development continues at [GitHub](https://github.com/jacobwilliams/dop853). 12 | ! 13 | !@note The default real kind (`wp`) can be 14 | ! changed using optional preprocessor flags. 15 | ! This library was built with real kind: 16 | #ifdef REAL32 17 | ! `real(kind=real32)` [4 bytes] 18 | #elif REAL64 19 | ! `real(kind=real64)` [8 bytes] 20 | #elif REAL128 21 | ! `real(kind=real128)` [16 bytes] 22 | #else 23 | ! `real(kind=real64)` [8 bytes] 24 | #endif 25 | 26 | 27 | module dop853_module 28 | 29 | use, intrinsic :: iso_fortran_env 30 | 31 | implicit none 32 | 33 | private 34 | 35 | #ifdef REAL32 36 | integer,parameter,public :: dop853_wp = real32 !! real kind used by this module [4 bytes] 37 | #elif REAL64 38 | integer,parameter,public :: dop853_wp = real64 !! real kind used by this module [8 bytes] 39 | #elif REAL128 40 | integer,parameter,public :: dop853_wp = real128 !! real kind used by this module [16 bytes] 41 | #else 42 | integer,parameter,public :: dop853_wp = real64 !! real kind used by this module [8 bytes] 43 | #endif 44 | 45 | integer,parameter :: wp = dop853_wp !! local copy of `dop853_wp` with a shorter name 46 | real(wp),parameter :: uround = epsilon(1.0_wp) !! machine \( \epsilon \) 47 | 48 | !integration constants (formerly in dp86co): 49 | real(wp),parameter :: c2 = 0.526001519587677318785587544488e-01_wp 50 | real(wp),parameter :: c3 = 0.789002279381515978178381316732e-01_wp 51 | real(wp),parameter :: c4 = 0.118350341907227396726757197510_wp 52 | real(wp),parameter :: c5 = 0.281649658092772603273242802490_wp 53 | real(wp),parameter :: c6 = 0.333333333333333333333333333333_wp 54 | real(wp),parameter :: c7 = 0.25_wp 55 | real(wp),parameter :: c8 = 0.307692307692307692307692307692_wp 56 | real(wp),parameter :: c9 = 0.651282051282051282051282051282_wp 57 | real(wp),parameter :: c10 = 0.6_wp 58 | real(wp),parameter :: c11 = 0.857142857142857142857142857142_wp 59 | real(wp),parameter :: c14 = 0.1_wp 60 | real(wp),parameter :: c15 = 0.2_wp 61 | real(wp),parameter :: c16 = 0.777777777777777777777777777778_wp 62 | real(wp),parameter :: b1 = 5.42937341165687622380535766363e-2_wp 63 | real(wp),parameter :: b6 = 4.45031289275240888144113950566_wp 64 | real(wp),parameter :: b7 = 1.89151789931450038304281599044_wp 65 | real(wp),parameter :: b8 = -5.8012039600105847814672114227_wp 66 | real(wp),parameter :: b9 = 3.1116436695781989440891606237e-1_wp 67 | real(wp),parameter :: b10 = -1.52160949662516078556178806805e-1_wp 68 | real(wp),parameter :: b11 = 2.01365400804030348374776537501e-1_wp 69 | real(wp),parameter :: b12 = 4.47106157277725905176885569043e-2_wp 70 | real(wp),parameter :: bhh1 = 0.244094488188976377952755905512_wp 71 | real(wp),parameter :: bhh2 = 0.733846688281611857341361741547_wp 72 | real(wp),parameter :: bhh3 = 0.220588235294117647058823529412e-1_wp 73 | real(wp),parameter :: er1 = 0.1312004499419488073250102996e-01_wp 74 | real(wp),parameter :: er6 = -0.1225156446376204440720569753e+01_wp 75 | real(wp),parameter :: er7 = -0.4957589496572501915214079952_wp 76 | real(wp),parameter :: er8 = 0.1664377182454986536961530415e+01_wp 77 | real(wp),parameter :: er9 = -0.3503288487499736816886487290_wp 78 | real(wp),parameter :: er10 = 0.3341791187130174790297318841_wp 79 | real(wp),parameter :: er11 = 0.8192320648511571246570742613e-01_wp 80 | real(wp),parameter :: er12 = -0.2235530786388629525884427845e-01_wp 81 | real(wp),parameter :: a21 = 5.26001519587677318785587544488e-2_wp 82 | real(wp),parameter :: a31 = 1.97250569845378994544595329183e-2_wp 83 | real(wp),parameter :: a32 = 5.91751709536136983633785987549e-2_wp 84 | real(wp),parameter :: a41 = 2.95875854768068491816892993775e-2_wp 85 | real(wp),parameter :: a43 = 8.87627564304205475450678981324e-2_wp 86 | real(wp),parameter :: a51 = 2.41365134159266685502369798665e-1_wp 87 | real(wp),parameter :: a53 = -8.84549479328286085344864962717e-1_wp 88 | real(wp),parameter :: a54 = 9.24834003261792003115737966543e-1_wp 89 | real(wp),parameter :: a61 = 3.7037037037037037037037037037e-2_wp 90 | real(wp),parameter :: a64 = 1.70828608729473871279604482173e-1_wp 91 | real(wp),parameter :: a65 = 1.25467687566822425016691814123e-1_wp 92 | real(wp),parameter :: a71 = 3.7109375e-2_wp 93 | real(wp),parameter :: a74 = 1.70252211019544039314978060272e-1_wp 94 | real(wp),parameter :: a75 = 6.02165389804559606850219397283e-2_wp 95 | real(wp),parameter :: a76 = -1.7578125e-2_wp 96 | real(wp),parameter :: a81 = 3.70920001185047927108779319836e-2_wp 97 | real(wp),parameter :: a84 = 1.70383925712239993810214054705e-1_wp 98 | real(wp),parameter :: a85 = 1.07262030446373284651809199168e-1_wp 99 | real(wp),parameter :: a86 = -1.53194377486244017527936158236e-2_wp 100 | real(wp),parameter :: a87 = 8.27378916381402288758473766002e-3_wp 101 | real(wp),parameter :: a91 = 6.24110958716075717114429577812e-1_wp 102 | real(wp),parameter :: a94 = -3.36089262944694129406857109825_wp 103 | real(wp),parameter :: a95 = -8.68219346841726006818189891453e-1_wp 104 | real(wp),parameter :: a96 = 2.75920996994467083049415600797e+1_wp 105 | real(wp),parameter :: a97 = 2.01540675504778934086186788979e+1_wp 106 | real(wp),parameter :: a98 = -4.34898841810699588477366255144e+1_wp 107 | real(wp),parameter :: a101 = 4.77662536438264365890433908527e-1_wp 108 | real(wp),parameter :: a104 = -2.48811461997166764192642586468_wp 109 | real(wp),parameter :: a105 = -5.90290826836842996371446475743e-1_wp 110 | real(wp),parameter :: a106 = 2.12300514481811942347288949897e+1_wp 111 | real(wp),parameter :: a107 = 1.52792336328824235832596922938e+1_wp 112 | real(wp),parameter :: a108 = -3.32882109689848629194453265587e+1_wp 113 | real(wp),parameter :: a109 = -2.03312017085086261358222928593e-2_wp 114 | real(wp),parameter :: a111 = -9.3714243008598732571704021658e-1_wp 115 | real(wp),parameter :: a114 = 5.18637242884406370830023853209_wp 116 | real(wp),parameter :: a115 = 1.09143734899672957818500254654_wp 117 | real(wp),parameter :: a116 = -8.14978701074692612513997267357_wp 118 | real(wp),parameter :: a117 = -1.85200656599969598641566180701e+1_wp 119 | real(wp),parameter :: a118 = 2.27394870993505042818970056734e+1_wp 120 | real(wp),parameter :: a119 = 2.49360555267965238987089396762_wp 121 | real(wp),parameter :: a1110 = -3.0467644718982195003823669022_wp 122 | real(wp),parameter :: a121 = 2.27331014751653820792359768449_wp 123 | real(wp),parameter :: a124 = -1.05344954667372501984066689879e+1_wp 124 | real(wp),parameter :: a125 = -2.00087205822486249909675718444_wp 125 | real(wp),parameter :: a126 = -1.79589318631187989172765950534e+1_wp 126 | real(wp),parameter :: a127 = 2.79488845294199600508499808837e+1_wp 127 | real(wp),parameter :: a128 = -2.85899827713502369474065508674_wp 128 | real(wp),parameter :: a129 = -8.87285693353062954433549289258_wp 129 | real(wp),parameter :: a1210 = 1.23605671757943030647266201528e+1_wp 130 | real(wp),parameter :: a1211 = 6.43392746015763530355970484046e-1_wp 131 | real(wp),parameter :: a141 = 5.61675022830479523392909219681e-2_wp 132 | real(wp),parameter :: a147 = 2.53500210216624811088794765333e-1_wp 133 | real(wp),parameter :: a148 = -2.46239037470802489917441475441e-1_wp 134 | real(wp),parameter :: a149 = -1.24191423263816360469010140626e-1_wp 135 | real(wp),parameter :: a1410 = 1.5329179827876569731206322685e-1_wp 136 | real(wp),parameter :: a1411 = 8.20105229563468988491666602057e-3_wp 137 | real(wp),parameter :: a1412 = 7.56789766054569976138603589584e-3_wp 138 | real(wp),parameter :: a1413 = -8.298e-3_wp 139 | real(wp),parameter :: a151 = 3.18346481635021405060768473261e-2_wp 140 | real(wp),parameter :: a156 = 2.83009096723667755288322961402e-2_wp 141 | real(wp),parameter :: a157 = 5.35419883074385676223797384372e-2_wp 142 | real(wp),parameter :: a158 = -5.49237485713909884646569340306e-2_wp 143 | real(wp),parameter :: a1511 = -1.08347328697249322858509316994e-4_wp 144 | real(wp),parameter :: a1512 = 3.82571090835658412954920192323e-4_wp 145 | real(wp),parameter :: a1513 = -3.40465008687404560802977114492e-4_wp 146 | real(wp),parameter :: a1514 = 1.41312443674632500278074618366e-1_wp 147 | real(wp),parameter :: a161 = -4.28896301583791923408573538692e-1_wp 148 | real(wp),parameter :: a166 = -4.69762141536116384314449447206_wp 149 | real(wp),parameter :: a167 = 7.68342119606259904184240953878_wp 150 | real(wp),parameter :: a168 = 4.06898981839711007970213554331_wp 151 | real(wp),parameter :: a169 = 3.56727187455281109270669543021e-1_wp 152 | real(wp),parameter :: a1613 = -1.39902416515901462129418009734e-3_wp 153 | real(wp),parameter :: a1614 = 2.9475147891527723389556272149_wp 154 | real(wp),parameter :: a1615 = -9.15095847217987001081870187138_wp 155 | real(wp),parameter :: d41 = -0.84289382761090128651353491142e+01_wp 156 | real(wp),parameter :: d46 = 0.56671495351937776962531783590_wp 157 | real(wp),parameter :: d47 = -0.30689499459498916912797304727e+01_wp 158 | real(wp),parameter :: d48 = 0.23846676565120698287728149680e+01_wp 159 | real(wp),parameter :: d49 = 0.21170345824450282767155149946e+01_wp 160 | real(wp),parameter :: d410 = -0.87139158377797299206789907490_wp 161 | real(wp),parameter :: d411 = 0.22404374302607882758541771650e+01_wp 162 | real(wp),parameter :: d412 = 0.63157877876946881815570249290_wp 163 | real(wp),parameter :: d413 = -0.88990336451333310820698117400e-01_wp 164 | real(wp),parameter :: d414 = 0.18148505520854727256656404962e+02_wp 165 | real(wp),parameter :: d415 = -0.91946323924783554000451984436e+01_wp 166 | real(wp),parameter :: d416 = -0.44360363875948939664310572000e+01_wp 167 | real(wp),parameter :: d51 = 0.10427508642579134603413151009e+02_wp 168 | real(wp),parameter :: d56 = 0.24228349177525818288430175319e+03_wp 169 | real(wp),parameter :: d57 = 0.16520045171727028198505394887e+03_wp 170 | real(wp),parameter :: d58 = -0.37454675472269020279518312152e+03_wp 171 | real(wp),parameter :: d59 = -0.22113666853125306036270938578e+02_wp 172 | real(wp),parameter :: d510 = 0.77334326684722638389603898808e+01_wp 173 | real(wp),parameter :: d511 = -0.30674084731089398182061213626e+02_wp 174 | real(wp),parameter :: d512 = -0.93321305264302278729567221706e+01_wp 175 | real(wp),parameter :: d513 = 0.15697238121770843886131091075e+02_wp 176 | real(wp),parameter :: d514 = -0.31139403219565177677282850411e+02_wp 177 | real(wp),parameter :: d515 = -0.93529243588444783865713862664e+01_wp 178 | real(wp),parameter :: d516 = 0.35816841486394083752465898540e+02_wp 179 | real(wp),parameter :: d61 = 0.19985053242002433820987653617e+02_wp 180 | real(wp),parameter :: d66 = -0.38703730874935176555105901742e+03_wp 181 | real(wp),parameter :: d67 = -0.18917813819516756882830838328e+03_wp 182 | real(wp),parameter :: d68 = 0.52780815920542364900561016686e+03_wp 183 | real(wp),parameter :: d69 = -0.11573902539959630126141871134e+02_wp 184 | real(wp),parameter :: d610 = 0.68812326946963000169666922661e+01_wp 185 | real(wp),parameter :: d611 = -0.10006050966910838403183860980e+01_wp 186 | real(wp),parameter :: d612 = 0.77771377980534432092869265740_wp 187 | real(wp),parameter :: d613 = -0.27782057523535084065932004339e+01_wp 188 | real(wp),parameter :: d614 = -0.60196695231264120758267380846e+02_wp 189 | real(wp),parameter :: d615 = 0.84320405506677161018159903784e+02_wp 190 | real(wp),parameter :: d616 = 0.11992291136182789328035130030e+02_wp 191 | real(wp),parameter :: d71 = -0.25693933462703749003312586129e+02_wp 192 | real(wp),parameter :: d76 = -0.15418974869023643374053993627e+03_wp 193 | real(wp),parameter :: d77 = -0.23152937917604549567536039109e+03_wp 194 | real(wp),parameter :: d78 = 0.35763911791061412378285349910e+03_wp 195 | real(wp),parameter :: d79 = 0.93405324183624310003907691704e+02_wp 196 | real(wp),parameter :: d710 = -0.37458323136451633156875139351e+02_wp 197 | real(wp),parameter :: d711 = 0.10409964950896230045147246184e+03_wp 198 | real(wp),parameter :: d712 = 0.29840293426660503123344363579e+02_wp 199 | real(wp),parameter :: d713 = -0.43533456590011143754432175058e+02_wp 200 | real(wp),parameter :: d714 = 0.96324553959188282948394950600e+02_wp 201 | real(wp),parameter :: d715 = -0.39177261675615439165231486172e+02_wp 202 | real(wp),parameter :: d716 = -0.14972683625798562581422125276e+03_wp 203 | 204 | type,public :: dop853_class 205 | 206 | private 207 | 208 | !internal variables: 209 | integer :: n = 0 !! the dimension of the system 210 | integer :: nfcn = 0 !! number of function evaluations 211 | integer :: nstep = 0 !! number of computed steps 212 | integer :: naccpt = 0 !! number of accepted steps 213 | integer :: nrejct = 0 !! number of rejected steps (due to error test), 214 | !! (step rejections in the first step are not counted) 215 | integer :: nrdens = 0 !! number of components, for which dense output 216 | !! is required. for `0 < nrdens < n` the components 217 | !! (for which dense output is required) have to be 218 | !! specified in `icomp(1),...,icomp(nrdens)`. 219 | real(wp) :: h = 0.0_wp !! predicted step size of the last accepted step 220 | 221 | !input paramters: 222 | ! these parameters allow 223 | ! to adapt the code to the problem and to the needs of 224 | ! the user. set them on class initialization. 225 | 226 | integer :: iprint = output_unit !! switch for printing error messages 227 | !! if `iprint==0` no messages are being printed 228 | !! if `iprint/=0` messages are printed with 229 | !! `write (iprint,*)` ... 230 | 231 | integer :: nmax = 100000 !! the maximal number of allowed steps. 232 | integer :: nstiff = 1000 !! test for stiffness is activated after step number 233 | !! `j*nstiff` (`j` integer), provided `nstiff>0`. 234 | !! for negative `nstiff` the stiffness test is 235 | !! never activated. 236 | real(wp) :: hinitial = 0.0_wp !! initial step size, for `hinitial=0` an initial guess 237 | !! is computed with help of the function [[hinit]]. 238 | real(wp) :: hmax = 0.0_wp !! maximal step size, defaults to `xend-x` if `hmax=0`. 239 | real(wp) :: safe = 0.9_wp !! safety factor in step size prediction 240 | real(wp) :: fac1 = 0.333_wp !! parameter for step size selection. 241 | !! the new step size is chosen subject to the restriction 242 | !! `fac1 <= hnew/hold <= fac2` 243 | real(wp) :: fac2 = 6.0_wp !! parameter for step size selection. 244 | !! the new step size is chosen subject to the restriction 245 | !! `fac1 <= hnew/hold <= fac2` 246 | real(wp) :: beta = 0.0_wp !! is the `beta` for stabilized step size control 247 | !! (see section iv.2). positive values of beta ( <= 0.04 ) 248 | !! make the step size control more stable. 249 | 250 | integer,dimension(:),allocatable :: icomp !! `dimension(nrdens)` 251 | !! the components for which dense output is required 252 | real(wp),dimension(:),allocatable :: cont !! `dimension(8*nrdens)` 253 | 254 | integer :: iout = 0 !! copy of `iout` input to [[dop853]] 255 | 256 | !formerly in the condo8 common block: 257 | real(wp) :: xold = 0.0_wp 258 | real(wp) :: hout = 0.0_wp 259 | 260 | !user-defined procedures: 261 | procedure(deriv_func),pointer :: fcn => null() !! subroutine computing the value of `f(x,y)` 262 | procedure(solout_func),pointer :: solout => null() !! subroutine providing the 263 | !! numerical solution during integration. 264 | !! if `iout>=1`, it is called during integration. 265 | 266 | contains 267 | 268 | private 269 | 270 | procedure,public :: initialize => set_parameters !! initialization routine. 271 | procedure,public :: integrate => dop853 !! main integration routine. 272 | procedure,public :: destroy => destroy_dop853 !! destructor. 273 | procedure,public :: info => get_dop853_info !! to get info after a run. 274 | 275 | procedure :: dp86co 276 | procedure :: hinit 277 | procedure,public :: contd8 !! can be called in user's [[solout_func]] for dense output. 278 | 279 | end type dop853_class 280 | 281 | abstract interface 282 | 283 | subroutine deriv_func(me,x,y,f) 284 | !! subroutine computing the value of \( dy/dx = f(x,y) \) 285 | import :: wp,dop853_class 286 | implicit none 287 | class(dop853_class),intent(inout) :: me 288 | real(wp),intent(in) :: x !! independent variable \(x\) 289 | real(wp),dimension(:),intent(in) :: y !! state vector \( y(x) \) [size n] 290 | real(wp),dimension(:),intent(out) :: f !! derivative vector \( f(x,y) = dy/dx \) [size n] 291 | end subroutine deriv_func 292 | 293 | subroutine solout_func(me,nr,xold,x,y,irtrn,xout) 294 | !! `solout` furnishes the solution `y` at the `nr`-th 295 | !! grid-point `x` (thereby the initial value is 296 | !! the first grid-point). 297 | import :: wp,dop853_class 298 | implicit none 299 | class(dop853_class),intent(inout) :: me 300 | integer,intent(in) :: nr !! grid point (0,1,...) 301 | real(wp),intent(in) :: xold !! the preceding grid point 302 | real(wp),intent(in) :: x !! current grid point 303 | real(wp),dimension(:),intent(in) :: y !! state vector \( y(x) \) [size n] 304 | integer,intent(inout) :: irtrn !! serves to interrupt the integration. if 305 | !! `irtrn` is set `<0`, [[dop853]] will return to 306 | !! the calling program. if the numerical solution 307 | !! is altered in `solout`, set `irtrn = 2`. 308 | real(wp),intent(out) :: xout !! `xout` can be used for efficient intermediate output 309 | !! if one puts `iout=3`. when `nr=1` define the first 310 | !! output point `xout` in `solout`. the subroutine 311 | !! `solout` will be called only when `xout` is in the 312 | !! interval `[xold,x]`; during this call 313 | !! a new value for `xout` can be defined, etc. 314 | end subroutine solout_func 315 | 316 | end interface 317 | 318 | contains 319 | !***************************************************************************************** 320 | 321 | !***************************************************************************************** 322 | !> 323 | ! Get info from a [[dop853_class]]. 324 | 325 | subroutine get_dop853_info(me,n,nfcn,nstep,naccpt,nrejct,h,iout) 326 | 327 | implicit none 328 | 329 | class(dop853_class),intent(in) :: me 330 | integer,intent(out),optional :: n !! dimension of the system 331 | integer,intent(out),optional :: nfcn !! number of function evaluations 332 | integer,intent(out),optional :: nstep !! number of computed steps 333 | integer,intent(out),optional :: naccpt !! number of accepted steps 334 | integer,intent(out),optional :: nrejct !! number of rejected steps (due to error test), 335 | !! (step rejections in the first step are not counted) 336 | real(wp),intent(out),optional :: h !! predicted step size of the last accepted step 337 | integer,intent(out),optional :: iout !! `iout` flag passed into [[dop853]], used to 338 | !! specify how `solout` is called during integration. 339 | 340 | if (present(n )) n = me%n 341 | if (present(nfcn )) nfcn = me%nfcn 342 | if (present(nstep )) nstep = me%nstep 343 | if (present(naccpt)) naccpt = me%naccpt 344 | if (present(nrejct)) nrejct = me%nrejct 345 | if (present(h)) h = me%h 346 | if (present(iout)) iout = me%iout 347 | 348 | end subroutine get_dop853_info 349 | !***************************************************************************************** 350 | 351 | !***************************************************************************************** 352 | !> 353 | ! Destructor for [[dop853_class]]. 354 | 355 | subroutine destroy_dop853(me) 356 | 357 | implicit none 358 | 359 | class(dop853_class),intent(out) :: me 360 | 361 | end subroutine destroy_dop853 362 | !***************************************************************************************** 363 | 364 | !***************************************************************************************** 365 | !> 366 | ! Set the optional inputs for [[dop853]]. 367 | ! 368 | !@note In the original code, these were part of the `work` and `iwork` arrays. 369 | 370 | subroutine set_parameters(me,n,fcn,solout,iprint,nstiff,nmax,hinitial,& 371 | hmax,safe,fac1,fac2,beta,icomp,status_ok) 372 | 373 | implicit none 374 | 375 | class(dop853_class),intent(inout) :: me 376 | integer,intent(in) :: n !! the dimension of the system (size of \(y\) and \(y'\) vectors) 377 | procedure(deriv_func) :: fcn !! subroutine computing the value of \( y' = f(x,y) \) 378 | procedure(solout_func),optional :: solout !! subroutine providing the 379 | !! numerical solution during integration. 380 | !! if `iout>=1`, it is called during integration. 381 | !! supply a dummy subroutine if `iout=0`. 382 | integer,intent(in),optional :: iprint !! switch for printing error messages 383 | !! if `iprint==0` no messages are being printed 384 | !! if `iprint/=0` messages are printed with 385 | !! `write (iprint,*)` ... 386 | integer,intent(in),optional :: nstiff !! test for stiffness is activated after step number 387 | !! `j*nstiff` (`j` integer), provided `nstiff>0`. 388 | !! for negative `nstiff` the stiffness test is 389 | !! never activated. 390 | integer,intent(in),optional :: nmax !! the maximal number of allowed steps. 391 | real(wp),intent(in),optional :: hinitial !! initial step size, for `hinitial=0` an initial guess 392 | !! is computed with help of the function [[hinit]]. 393 | real(wp),intent(in),optional :: hmax !! maximal step size, defaults to `xend-x` if `hmax=0`. 394 | real(wp),intent(in),optional :: safe !! safety factor in step size prediction 395 | real(wp),intent(in),optional :: fac1 !! parameter for step size selection. 396 | !! the new step size is chosen subject to the restriction 397 | !! `fac1 <= hnew/hold <= fac2` 398 | real(wp),intent(in),optional :: fac2 !! parameter for step size selection. 399 | !! the new step size is chosen subject to the restriction 400 | !! `fac1 <= hnew/hold <= fac2` 401 | real(wp),intent(in),optional :: beta !! is the `beta` for stabilized step size control 402 | !! (see section iv.2). positive values of `beta` ( <= 0.04 ) 403 | !! make the step size control more stable. 404 | integer,dimension(:),intent(in),optional :: icomp !! the components for which dense output is required (size from 0 to `n`). 405 | logical,intent(out) :: status_ok !! will be false for invalid inputs. 406 | 407 | call me%destroy() 408 | 409 | status_ok = .true. 410 | 411 | !required inputs: 412 | me%n = n 413 | me%fcn => fcn 414 | 415 | !optional inputs: 416 | 417 | if (present(solout)) me%solout => solout 418 | 419 | if (present(iprint)) me%iprint = iprint 420 | if (present(nstiff)) me%nstiff = nstiff 421 | if (present(hinitial)) me%hinitial = hinitial 422 | if (present(hmax)) me%hmax = hmax 423 | if (present(fac1)) me%fac1 = fac1 424 | if (present(fac2)) me%fac2 = fac2 425 | 426 | if (present(nmax)) then 427 | if ( nmax<=0 ) then 428 | if ( me%iprint/=0 ) & 429 | write (me%iprint,*) ' wrong input nmax=', nmax 430 | status_ok = .false. 431 | else 432 | me%nmax = nmax 433 | end if 434 | end if 435 | 436 | if (present(safe)) then 437 | if ( safe>=1.0_wp .or. safe<=1.0e-4_wp ) then 438 | if ( me%iprint/=0 ) & 439 | write (me%iprint,*) ' curious input for safety factor safe:', & 440 | safe 441 | status_ok = .false. 442 | else 443 | me%safe = safe 444 | end if 445 | end if 446 | 447 | if (present(beta)) then 448 | if ( beta<=0.0_wp ) then 449 | me%beta = 0.0_wp 450 | else 451 | if ( beta>0.2_wp ) then 452 | if ( me%iprint/=0 ) write (me%iprint,*) & 453 | ' curious input for beta: ', beta 454 | status_ok = .false. 455 | else 456 | me%beta = beta 457 | end if 458 | end if 459 | end if 460 | 461 | if (present(icomp)) then 462 | me%nrdens = size(icomp) 463 | !check validity of icomp array: 464 | if (size(icomp)<=me%n .and. all(icomp>0 .and. icomp<=me%n)) then 465 | allocate(me%icomp(me%nrdens)); me%icomp = icomp 466 | allocate(me%cont(8*me%nrdens)); me%cont = 0.0_wp 467 | else 468 | if ( me%iprint/=0 ) write (me%iprint,*) & 469 | ' invalid icomp array: ',icomp 470 | status_ok = .false. 471 | end if 472 | end if 473 | 474 | end subroutine set_parameters 475 | !***************************************************************************************** 476 | 477 | !***************************************************************************************** 478 | !> 479 | ! Numerical solution of a system of first order 480 | ! ordinary differential equations \( y'=f(x,y) \). 481 | ! This is an explicit Runge-Kutta method of order 8(5,3) 482 | ! due to Dormand & Prince (with stepsize control and 483 | ! dense output). 484 | ! 485 | !### Authors 486 | ! * E. Hairer and G. Wanner 487 | ! Universite de Geneve, Dept. De Mathematiques 488 | ! ch-1211 geneve 24, switzerland 489 | ! e-mail: ernst.hairer@unige.ch 490 | ! gerhard.wanner@unige.ch 491 | ! * Version of October 11, 2009 492 | ! (new option `iout=3` for sparse dense output) 493 | ! * Jacob Williams, Dec 2015: significant refactoring into modern Fortran. 494 | ! 495 | !### Reference 496 | ! * E. Hairer, S.P. Norsett and G. Wanner, [Solving Ordinary 497 | ! Differential Equations I. Nonstiff Problems. 2nd Edition](http://www.unige.ch/~hairer/books.html). 498 | ! Springer Series in Computational Mathematics, Springer-Verlag (1993) 499 | 500 | subroutine dop853(me,x,y,xend,rtol,atol,iout,idid) 501 | 502 | implicit none 503 | 504 | class(dop853_class),intent(inout) :: me 505 | real(wp),intent(inout) :: x !! *input:* initial value of independent variable. 506 | !! *output:* `x` for which the solution has been computed 507 | !! (after successful return `x=xend`). 508 | real(wp),dimension(:),intent(inout) :: y !! *input:* initial values for `y`. [size n] 509 | !! 510 | !! *output:* numerical solution at `x`. 511 | real(wp),intent(in) :: xend !! final x-value (`xend`-`x` may be positive or negative) 512 | real(wp),dimension(:),intent(in) :: rtol !! relative error tolerance. `rtol` and `atol` 513 | !! can be both scalars or else both vectors of length `n`. 514 | real(wp),dimension(:),intent(in) :: atol !! absolute error tolerance. `rtol` and `atol` 515 | !! can be both scalars or else both vectors of length `n`. 516 | !! `atol` should be strictly positive (possibly very small) 517 | integer,intent(in) :: iout !! switch for calling the subroutine `solout`: 518 | !! 519 | !! * `iout=0`: subroutine is never called 520 | !! * `iout=1`: subroutine is called after every successful step 521 | !! * `iout=2`: dense output is performed after every successful step 522 | !! * `iout=3`: dense output is performed in steps defined by the user 523 | !! (see `xout` above) 524 | integer,intent(out) :: idid !! reports on successfulness upon return: 525 | !! 526 | !! * `idid=1` computation successful, 527 | !! * `idid=2` comput. successful (interrupted by [[solout]]), 528 | !! * `idid=-1` input is not consistent, 529 | !! * `idid=-2` larger `nmax` is needed, 530 | !! * `idid=-3` step size becomes too small. 531 | !! * `idid=-4` problem is probably stiff (interrupted). 532 | 533 | real(wp) :: beta,fac1,fac2,hmax,safe 534 | integer :: i,ieco,iprint,istore,nrdens,nstiff,nmax 535 | logical :: arret 536 | integer :: itol !! switch for `rtol` and `atol`: 537 | !! 538 | !! * `itol=0`: both `rtol` and `atol` are scalars. 539 | !! the code keeps, roughly, the local error of 540 | !! `y(i)` below `rtol*abs(y(i))+atol`. 541 | !! 542 | !! * `itol=1`: both `rtol` and `atol` are vectors. 543 | !! the code keeps the local error of `y(i)` below 544 | !! `rtol(i)*abs(y(i))+atol(i)`. 545 | 546 | iprint = me%iprint 547 | me%iout = iout 548 | arret = .false. 549 | 550 | !check procedures: 551 | if (.not. associated(me%fcn)) then 552 | if ( iprint/=0 ) & 553 | write (iprint,*) & 554 | 'Error in dop853: procedure FCN is not associated.' 555 | idid = -1 556 | return 557 | end if 558 | 559 | if (iout/=0 .and. .not. associated(me%solout)) then 560 | if ( iprint/=0 ) & 561 | write (iprint,*) & 562 | 'Error in dop853: procedure SOLOUT must be associated if IOUT/=0.' 563 | idid = -1 564 | return 565 | end if 566 | 567 | !scalar or vector tolerances: 568 | if (size(rtol)==1 .and. size(atol)==1) then 569 | itol = 0 570 | elseif (size(rtol)==me%n .and. size(atol)==me%n) then 571 | itol = 1 572 | else 573 | if ( iprint/=0 ) & 574 | write (iprint,*) & 575 | 'Error in dop853: improper dimensions for rtol and/or atol.' 576 | idid = -1 577 | return 578 | end if 579 | 580 | ! setting the parameters 581 | me%nfcn = 0 582 | me%nstep = 0 583 | me%naccpt = 0 584 | me%nrejct = 0 585 | 586 | nmax = me%nmax 587 | nrdens = me%nrdens !number of dense output components 588 | 589 | ! nstiff parameter for stiffness detection 590 | if ( me%nstiff<=0 ) then 591 | nstiff = nmax + 10 !no stiffness check 592 | else 593 | nstiff = me%nstiff 594 | end if 595 | 596 | if ( nrdens<0 .or. me%nrdens>me%n ) then 597 | if ( iprint/=0 ) write (iprint,*) ' curious input nrdens=' , nrdens 598 | arret = .true. 599 | else 600 | if ( nrdens>0 .and. iout<2 .and. iprint/=0 ) & 601 | write (iprint,*) ' warning: set iout=2 or iout=3 for dense output ' 602 | end if 603 | 604 | if (size(y)/=me%n) then 605 | if ( iprint/=0 ) & 606 | write (iprint,*) ' error: y must have n elements: size(y)= ',size(y) 607 | arret = .true. 608 | end if 609 | 610 | safe = me%safe 611 | fac1 = me%fac1 612 | fac2 = me%fac2 613 | beta = me%beta 614 | 615 | if ( me%hmax==0.0_wp ) then 616 | hmax = xend - x 617 | else 618 | hmax = me%hmax 619 | end if 620 | 621 | me%h = me%hinitial ! initial step size 622 | 623 | ! when a fail has occurred, we return with idid=-1 624 | if ( arret ) then 625 | 626 | idid = -1 627 | 628 | else 629 | 630 | ! call to core integrator 631 | call me%dp86co(x,y,xend,hmax,me%h,rtol,atol,itol,iprint, & 632 | iout,idid,nmax,nstiff,safe,beta,fac1,fac2, & 633 | me%nfcn,me%nstep,me%naccpt,me%nrejct) 634 | 635 | end if 636 | 637 | end subroutine dop853 638 | !***************************************************************************************** 639 | 640 | !***************************************************************************************** 641 | !> 642 | ! Core integrator for [[dop853]]. 643 | ! parameters same as in [[dop853]] with workspace added. 644 | 645 | subroutine dp86co(me,x,y,xend,hmax,h,rtol,atol,itol,iprint, & 646 | iout,idid,nmax,nstiff,safe, & 647 | beta,fac1,fac2, & 648 | nfcn,nstep,naccpt,nrejct) 649 | 650 | implicit none 651 | 652 | class(dop853_class),intent(inout) :: me 653 | real(wp),intent(inout) :: x 654 | real(wp),dimension(:),intent(inout) :: y 655 | real(wp),intent(in) :: xend 656 | real(wp),intent(inout) :: hmax 657 | real(wp),intent(inout) :: h 658 | real(wp),dimension(:),intent(in) :: rtol 659 | real(wp),dimension(:),intent(in) :: atol 660 | integer,intent(in) :: itol 661 | integer,intent(in) :: iprint 662 | integer,intent(in) :: iout 663 | integer,intent(out) :: idid 664 | integer,intent(in) :: nmax 665 | integer,intent(in) :: nstiff 666 | real(wp),intent(in) :: safe 667 | real(wp),intent(in) :: beta 668 | real(wp),intent(in) :: fac1 669 | real(wp),intent(in) :: fac2 670 | integer,intent(inout) :: nfcn 671 | integer,intent(inout) :: nstep 672 | integer,intent(inout) :: naccpt 673 | integer,intent(inout) :: nrejct 674 | 675 | real(wp),dimension(me%n) :: y1,k1,k2,k3,k4,k5,k6,k7,k8,k9,k10 676 | real(wp) :: atoli,bspl,deno,err,err2,erri,expo1,fac,fac11,& 677 | facc1,facc2,facold,hlamb,hnew,posneg,rtoli,& 678 | sk,stden,stnum,xout,xph,ydiff 679 | integer :: i,iasti,iord,irtrn,j,nonsti,nrd 680 | logical :: reject,last,event,abort 681 | 682 | ! initializations 683 | nrd = me%nrdens 684 | facold = 1.0e-4_wp 685 | expo1 = 1.0_wp/8.0_wp - beta*0.2_wp 686 | facc1 = 1.0_wp/fac1 687 | facc2 = 1.0_wp/fac2 688 | posneg = sign(1.0_wp,xend-x) 689 | irtrn = 0 ! these were not initialized 690 | nonsti = 0 ! in the original code 691 | xout = 0.0_wp ! 692 | 693 | ! initial preparations 694 | atoli = atol(1) 695 | rtoli = rtol(1) 696 | last = .false. 697 | hlamb = 0.0_wp 698 | iasti = 0 699 | call me%fcn(x,y,k1) 700 | hmax = abs(hmax) 701 | iord = 8 702 | if ( h==0.0_wp ) then 703 | h = me%hinit(x,y,posneg,k1,iord,hmax,atol,rtol,itol) 704 | end if 705 | nfcn = nfcn + 2 706 | reject = .false. 707 | me%xold = x 708 | if ( iout/=0 ) then 709 | irtrn = 1 710 | me%hout = 1.0_wp 711 | call me%solout(naccpt+1,me%xold,x,y,irtrn,xout) 712 | abort = ( irtrn<0 ) 713 | else 714 | abort = .false. 715 | end if 716 | 717 | if (.not. abort) then 718 | do 719 | ! basic integration step 720 | if ( nstep>nmax ) then 721 | if ( iprint/=0 ) & 722 | write (iprint,'(A,E18.4)') ' exit of dop853 at x=', x 723 | if ( iprint/=0 ) & 724 | write (iprint,*) ' more than nmax =' , nmax , 'steps are needed' 725 | idid = -2 726 | return 727 | elseif ( 0.1_wp*abs(h)<=abs(x)*uround ) then 728 | if ( iprint/=0 ) & 729 | write (iprint,'(A,E18.4)') ' exit of dop853 at x=', x 730 | if ( iprint/=0 ) & 731 | write (iprint,*) ' step size too small, h=' , h 732 | idid = -3 733 | return 734 | else 735 | if ( (x+1.01_wp*h-xend)*posneg>0.0_wp ) then 736 | h = xend - x 737 | last = .true. 738 | end if 739 | nstep = nstep + 1 740 | ! the twelve stages 741 | if ( irtrn>=2 ) call me%fcn(x,y,k1) 742 | y1 = y + h*a21*k1 743 | call me%fcn(x+c2*h,y1,k2) 744 | y1 = y + h*(a31*k1+a32*k2) 745 | call me%fcn(x+c3*h,y1,k3) 746 | y1 = y + h*(a41*k1+a43*k3) 747 | call me%fcn(x+c4*h,y1,k4) 748 | y1 = y + h*(a51*k1+a53*k3+a54*k4) 749 | call me%fcn(x+c5*h,y1,k5) 750 | y1 = y + h*(a61*k1+a64*k4+a65*k5) 751 | call me%fcn(x+c6*h,y1,k6) 752 | y1 = y + h*(a71*k1+a74*k4+a75*k5+a76*k6) 753 | call me%fcn(x+c7*h,y1,k7) 754 | y1 = y + h*(a81*k1+a84*k4+a85*k5+a86*k6+a87*k7) 755 | call me%fcn(x+c8*h,y1,k8) 756 | y1 = y + h*(a91*k1+a94*k4+a95*k5+a96*k6+a97*k7+a98*k8) 757 | call me%fcn(x+c9*h,y1,k9) 758 | y1 = y + h*(a101*k1+a104*k4+a105*k5+a106*k6+a107*k7+& 759 | a108*k8+a109*k9) 760 | call me%fcn(x+c10*h,y1,k10) 761 | y1 = y + h*(a111*k1+a114*k4+a115*k5+a116*k6+a117*k7+& 762 | a118*k8+a119*k9+a1110*k10) 763 | call me%fcn(x+c11*h,y1,k2) 764 | xph = x + h 765 | y1 = y + h*(a121*k1+a124*k4+a125*k5+a126*k6+a127*k7+& 766 | a128*k8+a129*k9+a1210*k10+a1211*k2) 767 | call me%fcn(xph,y1,k3) 768 | nfcn = nfcn + 11 769 | k4 = b1*k1+b6*k6+b7*k7+b8*k8+b9*k9+b10*k10+b11*k2+b12*k3 770 | k5 = y + h*k4 771 | ! error estimation 772 | err = 0.0_wp 773 | err2 = 0.0_wp 774 | if ( itol==0 ) then 775 | do i = 1 , me%n 776 | sk = atoli + rtoli*max(abs(y(i)),abs(k5(i))) 777 | erri = k4(i) - bhh1*k1(i) - bhh2*k9(i) - bhh3*k3(i) 778 | err2 = err2 + (erri/sk)**2 779 | erri = er1*k1(i) + er6*k6(i) + er7*k7(i) + er8*k8(i) & 780 | + er9*k9(i) + er10*k10(i) + er11*k2(i) & 781 | + er12*k3(i) 782 | err = err + (erri/sk)**2 783 | end do 784 | else 785 | do i = 1 , me%n 786 | sk = atol(i) + rtol(i)*max(abs(y(i)),abs(k5(i))) 787 | erri = k4(i) - bhh1*k1(i) - bhh2*k9(i) - bhh3*k3(i) 788 | err2 = err2 + (erri/sk)**2 789 | erri = er1*k1(i) + er6*k6(i) + er7*k7(i) + er8*k8(i) & 790 | + er9*k9(i) + er10*k10(i) + er11*k2(i) & 791 | + er12*k3(i) 792 | err = err + (erri/sk)**2 793 | end do 794 | end if 795 | deno = err + 0.01_wp*err2 796 | if ( deno<=0.0_wp ) deno = 1.0_wp 797 | err = abs(h)*err*sqrt(1.0_wp/(me%n*deno)) 798 | ! computation of hnew 799 | fac11 = err**expo1 800 | ! lund-stabilization 801 | fac = fac11/facold**beta 802 | ! we require fac1 <= hnew/h <= fac2 803 | fac = max(facc2,min(facc1,fac/safe)) 804 | hnew = h/fac 805 | if ( err<=1.0_wp ) then 806 | ! step is accepted 807 | facold = max(err,1.0e-4_wp) 808 | naccpt = naccpt + 1 809 | call me%fcn(xph,k5,k4) 810 | nfcn = nfcn + 1 811 | ! stiffness detection 812 | if ( mod(naccpt,nstiff)==0 .or. iasti>0 ) then 813 | stnum = 0.0_wp 814 | stden = 0.0_wp 815 | do i = 1 , me%n 816 | stnum = stnum + (k4(i)-k3(i))**2 817 | stden = stden + (k5(i)-y1(i))**2 818 | end do 819 | if ( stden>0.0_wp ) hlamb = abs(h)*sqrt(stnum/stden) 820 | if ( hlamb>6.1_wp ) then 821 | nonsti = 0 822 | iasti = iasti + 1 823 | if ( iasti==15 ) then 824 | if ( iprint/=0 ) & 825 | write (iprint,*) & 826 | ' the problem seems to become stiff at x = ', x 827 | if ( iprint==0 ) then 828 | idid = -4 ! fail exit 829 | return 830 | end if 831 | end if 832 | else 833 | nonsti = nonsti + 1 834 | if ( nonsti==6 ) iasti = 0 835 | end if 836 | end if 837 | ! final preparation for dense output 838 | event = (iout==3) .and. (xout<=xph) 839 | if ( iout==2 .or. event ) then 840 | ! save the first function evaluations 841 | do j = 1 , nrd 842 | i = me%icomp(j) 843 | me%cont(j) = y(i) 844 | ydiff = k5(i) - y(i) 845 | me%cont(j+nrd) = ydiff 846 | bspl = h*k1(i) - ydiff 847 | me%cont(j+nrd*2) = bspl 848 | me%cont(j+nrd*3) = ydiff - h*k4(i) - bspl 849 | me%cont(j+nrd*4) = d41*k1(i)+d46*k6(i)+d47*k7(i)+& 850 | d48*k8(i)+d49*k9(i)+d410*k10(i)+& 851 | d411*k2(i)+d412*k3(i) 852 | me%cont(j+nrd*5) = d51*k1(i)+d56*k6(i)+d57*k7(i)+& 853 | d58*k8(i)+d59*k9(i)+d510*k10(i)+& 854 | d511*k2(i)+d512*k3(i) 855 | me%cont(j+nrd*6) = d61*k1(i)+d66*k6(i)+d67*k7(i)+& 856 | d68*k8(i)+d69*k9(i)+d610*k10(i)+& 857 | d611*k2(i)+d612*k3(i) 858 | me%cont(j+nrd*7) = d71*k1(i)+d76*k6(i)+d77*k7(i)+& 859 | d78*k8(i)+d79*k9(i)+d710*k10(i)+& 860 | d711*k2(i)+d712*k3(i) 861 | end do 862 | ! the next three function evaluations 863 | y1 = y + h*(a141*k1+a147*k7+a148*k8+a149*k9+& 864 | a1410*k10+a1411*k2+a1412*k3+a1413*k4) 865 | call me%fcn(x+c14*h,y1,k10) 866 | y1 = y + h*(a151*k1+a156*k6+a157*k7+a158*k8+& 867 | a1511*k2+a1512*k3+a1513*k4+a1514*k10) 868 | call me%fcn(x+c15*h,y1,k2) 869 | y1 = y + h*(a161*k1+a166*k6+a167*k7+a168*k8+a169*k9+& 870 | a1613*k4+a1614*k10+a1615*k2) 871 | call me%fcn(x+c16*h,y1,k3) 872 | nfcn = nfcn + 3 873 | ! final preparation 874 | do j = 1 , nrd 875 | i = me%icomp(j) 876 | me%cont(j+nrd*4) = h*(me%cont(j+nrd*4)+d413*k4(i)+& 877 | d414*k10(i)+d415*k2(i)+d416*k3(i)) 878 | me%cont(j+nrd*5) = h*(me%cont(j+nrd*5)+d513*k4(i)+& 879 | d514*k10(i)+d515*k2(i)+d516*k3(i)) 880 | me%cont(j+nrd*6) = h*(me%cont(j+nrd*6)+d613*k4(i)+& 881 | d614*k10(i)+d615*k2(i)+d616*k3(i)) 882 | me%cont(j+nrd*7) = h*(me%cont(j+nrd*7)+d713*k4(i)+& 883 | d714*k10(i)+d715*k2(i)+d716*k3(i)) 884 | end do 885 | me%hout = h 886 | end if 887 | k1 = k4 888 | y = k5 889 | me%xold = x 890 | x = xph 891 | if ( iout==1 .or. iout==2 .or. event ) then 892 | call me%solout(naccpt+1,me%xold,x,y,irtrn,xout) 893 | if ( irtrn<0 ) exit !abort 894 | end if 895 | ! normal exit 896 | if ( last ) then 897 | h = hnew 898 | idid = 1 899 | return 900 | end if 901 | if ( abs(hnew)>hmax ) hnew = posneg*hmax 902 | if ( reject ) hnew = posneg*min(abs(hnew),abs(h)) 903 | reject = .false. 904 | else 905 | ! step is rejected 906 | hnew = h/min(facc1,fac11/safe) 907 | reject = .true. 908 | if ( naccpt>=1 ) nrejct = nrejct + 1 909 | last = .false. 910 | end if 911 | h = hnew 912 | end if 913 | end do 914 | end if 915 | 916 | if ( iprint/=0 ) write (iprint,'(A,E18.4)') ' exit of dop853 at x=', x 917 | idid = 2 918 | 919 | end subroutine dp86co 920 | !***************************************************************************************** 921 | 922 | !***************************************************************************************** 923 | !> 924 | ! computation of an initial step size guess 925 | 926 | function hinit(me,x,y,posneg,f0,iord,hmax,atol,rtol,itol) 927 | 928 | implicit none 929 | 930 | class(dop853_class),intent(inout) :: me 931 | real(wp),intent(in) :: x 932 | real(wp),dimension(:),intent(in) :: y !! dimension(n) 933 | real(wp),intent(in) :: posneg 934 | real(wp),dimension(:),intent(in) :: f0 !! dimension(n) 935 | integer,intent(in) :: iord 936 | real(wp),intent(in) :: hmax 937 | real(wp),dimension(:),intent(in) :: atol 938 | real(wp),dimension(:),intent(in) :: rtol 939 | integer,intent(in) :: itol 940 | 941 | real(wp) :: atoli,der12,der2,dnf,dny,h,h1,hinit,rtoli,sk 942 | integer :: i 943 | real(wp),dimension(me%n) :: f1,y1 944 | 945 | ! compute a first guess for explicit euler as 946 | ! h = 0.01 * norm (y0) / norm (f0) 947 | ! the increment for explicit euler is small 948 | ! compared to the solution 949 | dnf = 0.0_wp 950 | dny = 0.0_wp 951 | atoli = atol(1) 952 | rtoli = rtol(1) 953 | if ( itol==0 ) then 954 | do i = 1 , me%n 955 | sk = atoli + rtoli*abs(y(i)) 956 | dnf = dnf + (f0(i)/sk)**2 957 | dny = dny + (y(i)/sk)**2 958 | end do 959 | else 960 | do i = 1 , me%n 961 | sk = atol(i) + rtol(i)*abs(y(i)) 962 | dnf = dnf + (f0(i)/sk)**2 963 | dny = dny + (y(i)/sk)**2 964 | end do 965 | end if 966 | if ( dnf<=1.0e-10_wp .or. dny<=1.0e-10_wp ) then 967 | h = 1.0e-6_wp 968 | else 969 | h = sqrt(dny/dnf)*0.01_wp 970 | end if 971 | h = min(h,hmax) 972 | h = sign(h,posneg) 973 | ! perform an explicit euler step 974 | do i = 1 , me%n 975 | y1(i) = y(i) + h*f0(i) 976 | end do 977 | call me%fcn(x+h,y1,f1) 978 | ! estimate the second derivative of the solution 979 | der2 = 0.0_wp 980 | if ( itol==0 ) then 981 | do i = 1 , me%n 982 | sk = atoli + rtoli*abs(y(i)) 983 | der2 = der2 + ((f1(i)-f0(i))/sk)**2 984 | end do 985 | else 986 | do i = 1 , me%n 987 | sk = atol(i) + rtol(i)*abs(y(i)) 988 | der2 = der2 + ((f1(i)-f0(i))/sk)**2 989 | end do 990 | end if 991 | der2 = sqrt(der2)/h 992 | ! step size is computed such that 993 | ! h**iord * max ( norm (f0), norm (der2)) = 0.01 994 | der12 = max(abs(der2),sqrt(dnf)) 995 | if ( der12<=1.0e-15_wp ) then 996 | h1 = max(1.0e-6_wp,abs(h)*1.0e-3_wp) 997 | else 998 | h1 = (0.01_wp/der12)**(1.0_wp/iord) 999 | end if 1000 | 1001 | h = min(100.0_wp*abs(h),h1,hmax) 1002 | hinit = sign(h,posneg) 1003 | 1004 | end function hinit 1005 | !***************************************************************************************** 1006 | 1007 | !***************************************************************************************** 1008 | !> 1009 | ! this function can be used for continuous output in connection 1010 | ! with the output-subroutine for [[dop853]]. it provides an 1011 | ! approximation to the `ii`-th component of the solution at `x`. 1012 | 1013 | function contd8(me,ii,x) result(y) 1014 | 1015 | implicit none 1016 | 1017 | class(dop853_class),intent(in) :: me 1018 | integer,intent(in) :: ii 1019 | real(wp),intent(in) :: x 1020 | real(wp) :: y 1021 | 1022 | real(wp) :: conpar, s, s1 1023 | integer :: i,j,nd,ierr 1024 | 1025 | ! compute place of ii-th component 1026 | i = 0 1027 | do j = 1, me%nrdens 1028 | if ( me%icomp(j)==ii ) i = j 1029 | end do 1030 | if ( i==0 ) then 1031 | !always report this message, since it is an invalid use of the code. 1032 | if (me%iprint==0) then 1033 | ierr = error_unit 1034 | else 1035 | ierr = me%iprint 1036 | end if 1037 | write (ierr,*) & 1038 | ' Error in contd8: no dense output available for component:', ii 1039 | y = 0.0_wp 1040 | else 1041 | nd = me%nrdens 1042 | s = (x-me%xold)/me%hout 1043 | s1 = 1.0_wp - s 1044 | conpar = me%cont(i+nd*4) + & 1045 | s*(me%cont(i+nd*5)+ & 1046 | s1*(me%cont(i+nd*6)+s*me%cont(i+nd*7))) 1047 | y = me%cont(i) + & 1048 | s*(me%cont(i+nd)+ & 1049 | s1*(me%cont(i+nd*2)+& 1050 | s*(me%cont(i+nd*3)+s1*conpar))) 1051 | end if 1052 | 1053 | end function contd8 1054 | !***************************************************************************************** 1055 | 1056 | !***************************************************************************************** 1057 | end module dop853_module 1058 | !***************************************************************************************** 1059 | -------------------------------------------------------------------------------- /test/dop853_example_original.f90: -------------------------------------------------------------------------------- 1 | !***************************************************************************************** 2 | !> 3 | ! Original Hairer test case. 4 | 5 | program dop853_example_original 6 | 7 | use dop853_module, wp => dop853_wp 8 | use iso_fortran_env, only: output_unit 9 | 10 | implicit none 11 | 12 | integer,parameter :: n = 2 !! dimension of the system 13 | real(wp),parameter :: tol = 1.0e-9_wp !! integration tolerance 14 | real(wp),parameter :: x0 = 0.0_wp !! initial `x` value 15 | real(wp),parameter :: xf = 2.0_wp !! endpoint of integration 16 | real(wp),dimension(n),parameter :: y0 = [2.0_wp,0.0_wp] !! initial `y` value 17 | 18 | type(dop853_class) :: prop 19 | real(wp),dimension(n) :: y 20 | real(wp),dimension(1) :: rtol,atol 21 | real(wp) :: x 22 | integer :: idid 23 | logical :: status_ok 24 | 25 | x = x0 26 | y = y0 27 | rtol = tol ! set tolerances 28 | atol = tol ! 29 | call prop%initialize( fcn = fvpol, & 30 | nstiff = 1, & 31 | n = n, & 32 | status_ok = status_ok ) 33 | if (.not. status_ok) error stop 'initialization error' 34 | 35 | call prop%integrate(x,y,xf,rtol,atol,iout=0,idid=idid) 36 | 37 | write (output_unit,'(1X,A,F6.2,A,2E18.10)') & 38 | 'x =',x ,' y =',y(1),y(2) 39 | 40 | contains 41 | 42 | subroutine fvpol(me,x,y,f) 43 | 44 | !! Right-hand side of van der Pol's equation 45 | 46 | implicit none 47 | 48 | class(dop853_class),intent(inout) :: me 49 | real(wp),intent(in) :: x 50 | real(wp),dimension(:),intent(in) :: y 51 | real(wp),dimension(:),intent(out) :: f 52 | 53 | real(wp),parameter :: eps = 1.0e-3_wp 54 | 55 | f(1) = y(2) 56 | f(2) = ((1-y(1)**2)*y(2)-y(1))/eps 57 | 58 | end subroutine fvpol 59 | 60 | end program dop853_example_original 61 | -------------------------------------------------------------------------------- /test/dop853_test.f90: -------------------------------------------------------------------------------- 1 | !***************************************************************************************** 2 | !> 3 | ! Driver for [[dop853]] on van der Pol's equation. 4 | ! 5 | !### See also 6 | ! * Based on [dr_dop853.f](http://www.unige.ch/~hairer/prog/nonstiff/dr_dop853.f) 7 | ! 8 | !### Results 9 | ! ![Forward Test](|media|/dop853_forward.png) 10 | ! ![Backward Test](|media|/dop853_backward.png) 11 | ! 12 | !@note This requires [pyplot-fortran](https://github.com/jacobwilliams/pyplot-fortran). 13 | 14 | program dop853_test 15 | 16 | use dop853_module, wp => dop853_wp 17 | use iso_fortran_env, only: output_unit 18 | use pyplot_module 19 | 20 | implicit none 21 | 22 | integer,parameter :: n = 2 !! dimension of the system 23 | integer,dimension(n),parameter :: icomp = [1,2] !! indices of `y` where we need dense output 24 | integer,parameter :: iout = 3 !! output routine (and dense output) is used during integration 25 | real(wp),parameter :: tol = 1.0e-12_wp !! required (relative) tolerance 26 | real(wp),parameter :: x0 = 0.0_wp !! initial `x` value 27 | real(wp),parameter :: xf = 100.0_wp !! endpoint of integration 28 | real(wp),dimension(n),parameter :: y0 = [0.0_wp,0.1_wp] !! initial `y` value 29 | real(wp),parameter :: dx = 0.01_wp !! time step for dense output 30 | real(wp),dimension(2),parameter :: xylim = [-3.0_wp,3.0_wp] !! plot axis limits 31 | 32 | logical,parameter :: make_plots = .true. !! use pyplot to generate plots. 33 | 34 | type(dop853_class) :: prop 35 | real(wp),dimension(n) :: y 36 | real(wp),dimension(1) :: rtol,atol 37 | real(wp) :: x,xend 38 | integer :: i,idid,j,nfcn,nstep,naccpt,nrejct 39 | logical :: status_ok 40 | type(pyplot) :: plt 41 | real(wp),dimension(:),allocatable :: t_vec, y_vec, yp_vec 42 | integer :: istat !! pyplot-fortran status flag 43 | 44 | x = x0 45 | y = y0 46 | xend = xf 47 | rtol = tol 48 | atol = tol 49 | call prop%initialize( fcn = fvpol, & 50 | n = n, & 51 | solout = solout, & 52 | icomp = icomp, & 53 | nstiff = 1, & 54 | status_ok = status_ok ) 55 | !all other parameters use defaults 56 | 57 | if (status_ok) then 58 | 59 | call prop%integrate(x,y,xend,rtol,atol,iout,idid) 60 | call prop%info(nfcn,nstep,naccpt,nrejct) 61 | 62 | if (make_plots) then 63 | t_vec = [t_vec,x] !last point 64 | y_vec = [y_vec,y(1)] 65 | yp_vec = [yp_vec,y(2)] 66 | end if 67 | 68 | ! print final solution 69 | write (output_unit,'(1X,A,F6.2,A,2E18.10)') & 70 | 'x =',x ,' y =',y(1),y(2) 71 | 72 | ! print statistics 73 | write (output_unit,'(A,D8.2)') ' tol=',tol 74 | write (output_unit,'(A,I5,A,I5,A,I4,A,I3)') & 75 | ' fcn=',nfcn,' step=',nstep,' accpt=',naccpt,' rejct=',nrejct 76 | 77 | ! plot: 78 | if (make_plots) then 79 | call plt%initialize(grid=.true.,xlabel='y(x)',& 80 | ylabel='y''(x)',& 81 | title='van der Pol''s Equation ($\mu = 0.2$)',legend=.true.) 82 | call plt%add_plot(y_vec,yp_vec,label='Forward',& 83 | linestyle='r-',linewidth=2,& 84 | xlim=xylim, ylim=xylim,istat=istat) 85 | call plt%savefig('dop853_forward.png',istat=istat) 86 | call plt%destroy() 87 | 88 | deallocate(t_vec ) 89 | deallocate(y_vec ) 90 | deallocate(yp_vec) 91 | end if 92 | 93 | !-------------------------------------------------- 94 | 95 | write(*,*) '' 96 | write(*,*) 'backwards test' 97 | write(*,*) '' 98 | call prop%destroy() 99 | call prop%initialize(fcn=fvpol,n=n,solout=solout2,status_ok = status_ok) 100 | call prop%integrate(x,y,x0,rtol,atol,iout=1,idid=idid) 101 | 102 | write(*,*) '' 103 | write(*,*) 'error:', norm2(y-y0) 104 | write(*,*) '' 105 | 106 | ! plot: 107 | if (make_plots) then 108 | call plt%initialize(grid=.true.,xlabel='y(x)',& 109 | ylabel='y''(x)',& 110 | title='van der Pol''s Equation ($\mu = 0.2$)',legend=.true.) 111 | 112 | call plt%add_plot(y_vec,yp_vec,label='Backward',& 113 | linestyle='r-',linewidth=2,& 114 | xlim=xylim, ylim=xylim,istat=istat) 115 | 116 | call plt%savefig('dop853_backward.png',istat=istat) 117 | call plt%destroy() 118 | end if 119 | 120 | else 121 | write(output_unit,'(A)') 'error calling INITIALIZE.' 122 | end if 123 | 124 | contains 125 | !***************************************************************************************** 126 | 127 | !******************************************************************************* 128 | !> 129 | ! Prints solution at equidistant output-points 130 | ! by using [[contd8]], the continuous collocation solution. 131 | ! This is for an `iout=3` case. 132 | ! 133 | !@note This routine uses Fortran 2008 LHS automatic allocations. 134 | 135 | subroutine solout(me,nr,xold,x,y,irtrn,xout) 136 | 137 | implicit none 138 | 139 | class(dop853_class),intent(inout) :: me 140 | integer,intent(in) :: nr 141 | real(wp),intent(in) :: xold 142 | real(wp),intent(in) :: x 143 | real(wp),dimension(:),intent(in) :: y 144 | integer,intent(inout) :: irtrn 145 | real(wp),intent(out) :: xout !! the point where we want the next output reported 146 | 147 | if ( nr==1 ) then 148 | write (output_unit,'(1X,A,F6.2,A,2E18.10,A,I4)') & 149 | 'x =',x,& 150 | ' y =',y(1),y(2),& 151 | ' nstep =',nr - 1 152 | xout = dx 153 | else 154 | do 155 | if ( x